From: Matt Birkholz Date: Tue, 5 Jun 2018 06:20:56 +0000 (-0700) Subject: Merge branch 'master' into pucked. X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8389f39873b9eea4054a1bc74f44bdecb5989e00;p=mit-scheme.git Merge branch 'master' into pucked. --- 8389f39873b9eea4054a1bc74f44bdecb5989e00 diff --cc src/Makefile.tools.in index c64861bd9,843532e68..ab315f161 --- a/src/Makefile.tools.in +++ b/src/Makefile.tools.in @@@ -126,9 -126,8 +126,10 @@@ tools/compiler.com: cross-compile tools/compiler.com: cross-cref tools/compiler.com: cross-sf tools/compiler.com: kludgerous-star-parser + tools/compiler.com: runtime/host-adapter.scm (echo '(begin' && \ + echo ' (with-working-directory-pathname "runtime"' && \ + echo ' (lambda () (load "host-adapter")))' && \ echo ' (with-working-directory-pathname "cref"' && \ echo ' (lambda () (load "make")))' && \ echo ' (with-working-directory-pathname "sf"' && \ @@@ -143,9 -142,8 +144,10 @@@ tools/syntaxer.com: cross-cref tools/syntaxer.com: cross-sf tools/syntaxer.com: kludgerous-star-parser + tools/syntaxer.com: runtime/host-adapter.scm (echo '(begin' && \ + echo ' (with-working-directory-pathname "runtime"' && \ + echo ' (lambda () (load "host-adapter")))' && \ echo ' (with-working-directory-pathname "cref"' && \ echo ' (lambda () (load "make")))' && \ echo ' (with-working-directory-pathname "sf"' && \ diff --cc src/Tags.sh index f6731b76c,8dd3a9d28..2094c5a99 --- a/src/Tags.sh +++ b/src/Tags.sh @@@ -29,10 -29,17 +29,11 @@@ set - DEFAULT_SUBDIRS=( \ 6001 \ - blowfish \ compiler \ cref \ - edwin \ ffi \ - gdbm \ - imail \ - mcrypt \ - mhash \ microcode \ + pgsql \ runtime \ sf \ sos \ diff --cc src/blowfish/blowfish.texi index cbc1edeb1,824e05416..dc96eb1d0 --- a/src/blowfish/blowfish.texi +++ b/src/blowfish/blowfish.texi @@@ -1,34 -1,18 +1,36 @@@ \input texinfo @c -*-texinfo-*- @comment %**start of header -@setfilename mit-scheme-blowfish.info +@setfilename blowfish.info @include version.texi - @set SCMVERS 9.2.7 -@set SCMVERS 9.2.1 -@settitle MIT/GNU Scheme Blowfish Plugin Manual ++@set SCMVERS 9.2.13 +@settitle Blowfish Plugin Manual @comment %**end of header +@ifhtml +@macro bref {name} +@ref{\name\,,@code{\name\}} +@end macro +@end ifhtml +@ifinfo +@macro bref {name} +\name\ +@end macro +@end ifinfo +@ifnothtml +@ifnotinfo +@macro bref {name} +@code{\name\} +@end macro +@end ifnotinfo +@end ifnothtml + @copying -This manual documents MIT/GNU Scheme Blowfish @value{VERSION}. +This manual documents MIT/GNU Scheme Pucked Blowfish @value{VERSION}. - Copyright @copyright{} 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, - 2015, 2016, 2017 Matthew Birkholz + Copyright @copyright{} 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, + 1994, 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, + 2005, 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, - 2016, 2017 Massachusetts Institute of Technology ++ 2016, 2017, 2018 Massachusetts Institute of Technology @quotation Permission is granted to copy, distribute and/or modify this document diff --cc src/blowfish/tags-fix.sh index 14e5e8636,14e5e8636..a22e6bab5 --- a/src/blowfish/tags-fix.sh +++ b/src/blowfish/tags-fix.sh @@@ -6,7 -6,7 +6,7 @@@ set -e : ${MIT_SCHEME_EXE=mit-scheme} ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF --(let ((name (car (command-line)))) ++(let ((name (car (command-line-arguments)))) (let ((shim.c-prefix (string-append name "-shim.c,")) (const.c-prefix (string-append name "-const.c,"))) diff --cc src/cairo/tags-fix.sh index c2823ad7f,14e5e8636..aee615c48 --- a/src/cairo/tags-fix.sh +++ b/src/cairo/tags-fix.sh @@@ -5,8 -5,8 +5,8 @@@ set -e : ${MIT_SCHEME_EXE=mit-scheme} -${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF -(let ((name (car (command-line)))) +${MIT_SCHEME_EXE} --batch-mode -- "${@}" <<\EOF - (let ((name (car (command-line)))) ++(let ((name (car (command-line-arguments)))) (let ((shim.c-prefix (string-append name "-shim.c,")) (const.c-prefix (string-append name "-const.c,"))) diff --cc src/devops/devops.scm index d36aa7ecf,000000000..ff27b9314 mode 100644,000000..100644 --- a/src/devops/devops.scm +++ b/src/devops/devops.scm @@@ -1,1216 -1,0 +1,1216 @@@ +#| -*-Scheme-*- + +Copyright (C) 2016, 2017, 2018 Matthew Birkholz + +This file is part of a devops plugin for MIT/GNU Scheme Pucked. + +This plugin is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This plugin is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this plugin; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. + +|# + +;;;; Developer Operations + +;;; See devops.texi for complete details. + +(define (main) - (let* ((cmdl (command-line)) - (arg1 (and (pair? cmdl) (car cmdl)))) - (cond ((equal? arg1 "status") (apply devops:status (cdr cmdl))) - ((equal? arg1 "release") (apply devops:release (cdr cmdl))) - ((equal? arg1 "build") (apply devops:build (cdr cmdl))) - ((equal? arg1 "make") (apply devops:make (cdr cmdl))) - (else (error "Unknown developer operation:" cmdl))))) ++ (let* ((args (command-line-arguments)) ++ (arg1 (and (pair? args) (car args)))) ++ (cond ((equal? arg1 "status") (apply devops:status (cdr args))) ++ ((equal? arg1 "release") (apply devops:release (cdr args))) ++ ((equal? arg1 "build") (apply devops:build (cdr args))) ++ ((equal? arg1 "make") (apply devops:make (cdr args))) ++ (else (error "Unknown developer operation:" args))))) + +(define (devops:status #!optional name) + (load "devops/config.scm" '(devops)) + (cond ((default-object? name) + (status)) + ((string=? "core" name) + (core-status (get-core-version) (dirt))) + (else + (plugin-status (->plugin name) (dirt))))) + +(define (dirt) + (shell-lines "git status --porcelain --untracked-files=no")) + +(define (status) + (let ((dirt (dirt)) + (version (get-core-version))) + (if version + (core-status version dirt)) + (for-each (lambda (p) (plugin-status p dirt)) plugin-list))) + +(define (core-status version dirt) + (let ((lint (core-lint version (or (get-core-changes) '()) dirt))) + (if (not (null? lint)) + (begin + (log "\n# core "(version-string version)"\n") + (write-lint lint))))) + +(define (plugin-status plugin dirt) + (let* ((version (plugin-version plugin)) + (changes (plugin-changes plugin)) + (lint (plugin-lint plugin version changes dirt))) + (if (not (null? lint)) + (begin + (log "\n# "(plugin-name plugin)" "(version-string version)"\n") + (write-lint lint))))) + +(define (write-lint lint) + (for-each (lambda (line) + (write-string line) + (newline)) + lint)) + +(define core-lint-hook #f) +(define plugin-lint-hook #f) + +(define (core-lint version changes dirt) + (let ((dirt (core-dirt dirt))) + (append + (debian-version-lint version "src/runtime/version.scm" + (debian-version ".") "debian/changelog") + (released-version-lint version (released-version (project-name)) + changes "src/runtime/version.scm") + (if core-lint-hook + (core-lint-hook version changes dirt) + '()) + (dirt-lint dirt) + (changes-lint changes)))) + +(define (plugin-lint plugin version changes dirt) + (let ((pdirt (plugin-dirt plugin dirt)) + (pkg (plugin-package plugin)) + (dir (plugin-directory plugin))) + (append + (debian-version-lint version (string dir"/configure.ac") + (debian-version dir) (string dir"/debian/changelog")) + (news-version-lint plugin version) + (subsystem-version-lint plugin version) + (released-version-lint version (released-version pkg) changes + (string (plugin-directory plugin)"/configure.ac")) + (if plugin-lint-hook + (plugin-lint-hook plugin version changes dirt) + '()) + (dirt-lint pdirt) + (changes-lint changes)))) + +(define debian-changelog-version-pattern + (compile-regsexp '(seq (* (any-char)) + #\space #\( + (group version (+ (char-not-in #\)))) + #\)))) + +(define (debian-version dir) + (let* ((changelog (string dir"/debian/changelog")) + (line (and (file-exists? changelog) + (read-first-line changelog))) + (match (and line + (regsexp-match-string debian-changelog-version-pattern + line)))) + (and match + (->version (match-extract match 'version))))) + +(define (debian-version-lint version filename dversion dfilename) + (append + (if (not version) + (list (string filename": package version not found.")) + '()) + (if (not dversion) + (list (string dfilename": Debian version not found.")) + '()) + (if (and version dversion + (not (version=? version dversion))) + (list (string dfilename": Debian version" + " ("(version-string dversion)")" + " does not match.")) + '()))) + +(define (news-version-lint plugin version) + (let ((nvers (read-news-version plugin))) + (if nvers + (if (string=? nvers (version-string version)) + '() + (list (string (plugin-directory plugin)"/NEWS:" + " version ("nvers") does not match."))) + (list (string (plugin-directory plugin)"/NEWS:" + " version not found."))))) + +(define (subsystem-version-lint plugin version) + (let ((svers (read-subsystem-version plugin))) + (if svers + (if (version=? svers version) + '() + (list (string (plugin-directory plugin)"/make.scm:" + " subsystem version "svers + " does not match."))) + (list (string (plugin-directory plugin)"/make.scm:" + " subsystem version not found."))))) + +(define (released-version-lint version released changes filename) + (cond ((eq? #f released) + (list "First release!")) + ((and (pair? changes) + (not (version>? version released))) + (list (string filename": version is out-of-date."))) + (else + '()))) + +(define (dirt-lint dirt) + (if (pair? dirt) + (cons "Uncommitted files:" dirt) + '())) + +(define (changes-lint changes) + (if (pair? changes) + (cons "Unreleased commits:" changes) + '())) + +(define (core-dirt dirt) + (filter (lambda (line) + (not (any (lambda (plugin) (plugin-dirt? plugin line)) + plugin-list))) + dirt)) + +(define (plugin-dirt plugin dirt) + (filter (lambda (line) + (plugin-dirt? plugin line)) + dirt)) + +(define (plugin-dirt? plugin line) + (let* ((dir (plugin-directory plugin)) + (dir-len (string-length dir)) + (dir-end (fix:+ 3 dir-len))) + (and (fix:> (string-length line) dir-end) + (string=? dir (string-slice line 3 dir-end)) + (char=? #\/ (string-ref line dir-end))))) + +(define core-version-pattern + (compile-regsexp '(seq (* (any-char)) + "ubsystem-identification! \"Release\"" + " '(" + (group version (+ (alt #\space (char-in numeric)))) + ")"))) + +(define (get-core-version) + (and (file-exists? "src/runtime/version.scm") + (call-with-input-file "src/runtime/version.scm" + (lambda (in) + (let loop () + (let* ((line (read-line in)) + (match (and (string? line) + (regsexp-match-string core-version-pattern + line)))) + (if match + (map (lambda (s) (string->number s 10)) + (burst-string (match-extract match 'version) + #\space #t)) + (if (eof-object? line) + (error "Could not find core version.") + (loop))))))))) + +(define (make-news-pattern fullname) + (compile-regsexp `(seq ,fullname + #\space + (group version + (+ (alt #\. (char-in numeric)))) + " - " + (group author (+ (char-not-in #\,))) + ", " + (group year (+ (char-in numeric))) + "-" + (group month (+ (char-in numeric))) + "-" + (group day (+ (char-in numeric))) + (string-end)))) + +(define (read-news-version plugin) + (let* ((fullname (string (project-name)"-"(plugin-name plugin))) + (file (string (plugin-directory plugin)"/NEWS"))) + (and (file-exists? file) + (let ((pattern (make-news-pattern fullname))) + (call-with-input-file file + (lambda (in) + (let loop () + (let ((line (read-line in))) + (if (eof-object? line) + #f + (let ((match (regsexp-match-string pattern line))) + (if match + (match-extract match 'version) + (loop)))))))))))) + +(define subsystem-pattern + (compile-regsexp + '(seq "(add-subsystem-identification!" + " \""(+ (char-not-in #\"))"\"" + " '"(group version (seq "(" + (+ (alt #\space (char-in numeric))) + ")")) + ")"))) + +(define (read-subsystem-version plugin) + (let ((file (find-plugin-make.scm plugin))) + (and file + (call-with-input-file file + (lambda (in) + (let loop () + (let ((line (read-line in))) + (if (eof-object? line) + #f + (let ((match + (regsexp-match-string subsystem-pattern line))) + (if match + (call-with-input-string + (match-extract match 'version) + read) + (loop))))))))))) + +(define (find-plugin-make.scm plugin) + (or (let ((file (string (plugin-directory plugin)"/make.scm"))) + (and (file-exists? file) + file)) + (let ((file (string (plugin-directory plugin)"/mit-make.scm"))) + (and (file-exists? file) + file)))) + +(define (released-version name) + (let ((tags (sorted-tags name))) + (and (pair? tags) + (caar tags)))) + +(define (get-core-changes) + (let ((start-hash (released-hash (project-name)))) + (and start-hash + (append-map! + (lambda (hash) + (let* ((lines + (shell-lines "git log --oneline --name-status -1 "hash)) + (files + (filter (let ((excludes (plugin-dir-prefixes))) + (lambda (line) + (let* ((i (string-find-next-char line #\tab)) + (name (string-slice line (fix:1+ i)))) + (not (any (lambda (exclude) + (string-prefix? exclude name)) + excludes))))) + (cdr lines)))) + (if (null? files) + '() + (cons (car lines) files)))) + (shell-lines "git log --format=%H "start-hash"..HEAD"))))) + +#;(define (core-changed-files) + (let ((hash (released-hash (project-name)))) + (and hash + (let ((excluded-dirs (map plugin-directory plugin-list))) + (filter + (lambda (filename) + (not (any (lambda (excluded-dir) + (string-prefix? excluded-dir filename)) + excluded-dirs))) + (shell-lines "git diff --name-only "hash)))))) + +(define (plugin-dir-prefixes) + (map (lambda (p) (string-append (plugin-directory p) "/")) + plugin-list)) + +(define (released-hash name) + (let* ((tags (sorted-tags name)) + (last-tag (and (pair? tags) + (cdar tags)))) + (and last-tag + (car (shell-lines "git log --format=%H -1 "last-tag))))) + +(define plugin-version-pattern + (compile-regsexp '(seq (* (char-in whitespace)) + #\[ + (group version (+ (alt #\. (char-in numeric)))) + #\]))) + +(define (plugin-version plugin) + (call-with-input-file (string (plugin-directory plugin)"/configure.ac") + (lambda (in) + (let loop () + (let ((line (read-line in))) + (if (and (string? line) + (string-prefix? "AC_INIT" line)) + (let* ((line (read-line in)) + (match (and (string? line) + (regsexp-match-string plugin-version-pattern + line)))) + (if match + (->version (match-extract match 'version)) + (error "No plugin version:" (plugin-name plugin)))) + (if (eof-object? line) + (error "No AC_INIT:" (plugin-name plugin)) + (loop)))))))) + +(define (plugin-changes plugin) + (let ((hash (released-hash (plugin-package plugin)))) + (and hash + (shell-lines "git log --no-merges --oneline --name-status "hash".." + " -- "(plugin-directory plugin)"/")))) + +#;(define (plugin-changed-files plugin) + (let ((hash (released-hash (plugin-package plugin)))) + (and hash + (let ((dir (plugin-directory plugin))) + (filter (lambda (filename) + (string-prefix? dir filename)) + (shell-lines "git diff --name-only "hash)))))) + +;;;; Release + +(define tag-create-options "") + +(define (tag-options . options) + (guarantee-list-of string? options 'tag-options) + (if (not (null? options)) + (set! tag-create-options ((string-joiner* 'infix " ") options))) + tag-create-options) + +(define (devops:release #!optional plugin) + (load "devops/config.scm" '(devops)) + (let ((dirt (shell-lines "git status --porcelain --untracked-files=no"))) + (cond ((default-object? plugin) + (release-core (get-core-version) (get-core-changes) dirt #f)) + ((or (equal? "snapshot" plugin) + (eq? 'snapshot plugin)) + (snapshot-core dirt) + (for-each (lambda (p) (snapshot-plugin p dirt)) + plugin-list)) + ((or (string? plugin) (symbol? plugin)) + (let ((p (->plugin plugin))) + (release-plugin p (plugin-version p) (plugin-changes p) dirt #f))) + (else + (error "Plugin must be a string or symbol."))))) + +(define (release-core version changes dirt snap?) + (if (and (null? changes) (not snap?)) + (error "No unreleased commits.")) + (let* ((project (project-name)) + (vers (version-string version)) + (pkgvers (string project"-"vers)) + (out (current-output-port)) + (runl (lambda strings (runl* out strings))) + (logfile (string "devops/"pkgvers"-src.log"))) + (log "# "pkgvers":\n") + (write-lint (core-lint version '() dirt)) + (with-output-log + logfile + (lambda () + (runl "mkdir devops/"pkgvers) + (if snap? + (runl "git archive --prefix="project"/ HEAD" + " | ( cd devops/"pkgvers" && tar xf - )") + (begin + (runl "git tag "tag-create-options" -m \"\" "pkgvers) + (runl "git archive --prefix="project"/ "pkgvers + " | ( cd devops/"pkgvers" && tar xf - )"))) + (runl "cd devops/"pkgvers" && "project"/dist/make-src-files standard") + (runl "mv devops/"pkgvers"/"pkgvers".tar.gz devops/") + (runl "rm -rf devops/"pkgvers) + (runl "cd devops/ && tar xzf "pkgvers".tar.gz") + (runl "cd devops/ && dpkg-source --build "pkgvers) + (runl "chmod 444 devops/"project"_"vers".dsc") + (runl "chmod 444 devops/"project"_"vers".tar.xz") + (runl "rm -rf devops/"pkgvers))) + (delete-file logfile))) + +(define (runl* out strings) + (let ((cmdln (string* strings))) + (write-string cmdln out)(newline out) + (write-string cmdln)(newline) + (shell* cmdln))) + +(define (release-plugin plugin version changes dirt snap?) + (if (and (null? changes) (not snap?)) + (error "No unreleased commits.")) + (let* ((vers (version-string version)) + (pkg (plugin-package plugin)) + (pkgvers (string pkg"-"vers)) + (out (current-output-port)) + (runl (lambda strings (runl* out strings))) + (logfile (string "devops/"pkgvers"-src.log")) + (dir (plugin-directory plugin))) + (log "# "pkgvers":\n") + (write-lint (plugin-lint plugin version '() dirt)) + (with-output-log + logfile + (lambda () + (if snap? + (runl "git archive --prefix="pkgvers"/ HEAD -- "dir + " | ( cd devops && tar xf - )") + (begin + (runl "git tag "tag-create-options" -m \"\" "pkgvers) + (runl "git archive --prefix="pkgvers"/ "pkgvers" -- "dir + " | ( cd devops && tar xf - )"))) + (runl "cd devops/"pkgvers"/"dir" && ./autogen.sh") + (runl "cd devops/"pkgvers"/"dir" && ./configure") + (runl "cd devops/"pkgvers"/"dir" && make dist") + (runl "mv devops/"pkgvers"/"dir"/"pkgvers".tar.gz devops/") + (runl "chmod 444 devops/"pkgvers".tar.gz") + (runl "rm -rf devops/"pkgvers) + (runl "cd devops/ && tar xzf "pkgvers".tar.gz") + (runl "cd devops/ && dpkg-source --build "pkgvers) + (runl "chmod 444 devops/"pkg"_"vers".dsc") + (runl "chmod 444 devops/"pkg"_"vers".tar.xz") + (runl "rm -rf devops/"pkgvers))) + (delete-file logfile))) + +(define (snapshot-core version dirt) + (let* ((changes (or (get-core-changes) '())) + (released (released-version (project-name))) + (vers (version-string version)) + (source-filename (string "devops/"(project-name)"-"vers".tar.gz"))) + (define (found) (log "# "source-filename":\nAlready done.\n")) + (cond ((and (null? changes) + (version=? version released)) + (if (file-exists? source-filename) + (found) + (release-core version changes dirt #t))) + ((and (pair? changes) + (version>? version released)) + ;; Clobber! + (release-core version changes dirt #t)) + ((null? changes) + (if (file-exists? source-filename) + (found) + (release-core version changes dirt #t))) + (else + (error "Version has not incremented:" version))))) + +(define (snapshot-plugin plugin dirt) + (let* ((changes (or (plugin-changes plugin) '())) + (version (plugin-version plugin)) + (released (released-version (plugin-package plugin))) + (vers (version-string version)) + (source-filename (string "devops/" + (plugin-package plugin)"-"vers".tar.gz"))) + (define (found) (log "# "source-filename":\nAlready done.\n")) + (cond ((and (null? changes) + (version=? version released)) + (if (file-exists? source-filename) + (found) + (release-plugin plugin version changes dirt #t))) + ((and (pair? changes) + (version>? version released)) + ;; Clobber! + (release-plugin plugin version changes dirt #t)) + ((null? changes) + (if (file-exists? source-filename) + (found) + (release-plugin plugin version changes dirt #t))) + (else + (error "Version has not incremented:" version))))) + +;;;; Build + +(define (devops:build #!optional hostname) + (load "devops/config.scm" '(devops)) + (let ((srcs (available-sources "devops")) + (hosts (hosts))) + (if (null? hosts) + (error "No build hosts defined.") + (if (default-object? hostname) + (for-each (lambda (host) (write-host-status host srcs)) + hosts) + (let* ((name + (cond ((string? hostname) hostname) + ((symbol? hostname) (symbol->string hostname)) + (else (error "Hostname is not a symbol or string:" + hostname)))) + (host (find (lambda (host) + (string=? name (host-name host))) + hosts))) + (if host + (write-host-status host srcs) + (error "Build host not found:" hostname))))))) + +(define build-dir "devops") + +(define reply-wait 10000) + +(define (read-reply query i/o) + (write-line `(write-line ,query) i/o) + (flush-output-port i/o) + (let ((object (read-until reply-wait i/o))) + (if (eq? object 'timeout) + (error "Timeout awaiting reply:" query)) + object)) + +(define (write-host-status host srcs) + (log "# "(host-name host)":\n") + (call-with-host-i/o + host + (lambda (i/o) + (let ((reply (read-reply '(quote ready) i/o))) + (if (not (eq? reply 'ready)) + (error "Build host not ready:" reply))) + (let ((reply (read-reply `(let ((dirname ,(host-directory host))) + (if (and (file-exists? dirname) + (file-directory? dirname)) + 'yes + 'no)) + i/o))) + (cond ((eq? reply 'yes) + unspecific) + ((eq? reply 'no) + (error "No build directory:" (host-directory host))) + (else (error "Unexpected reply:" reply)))) + (let ((files (read-reply `(directory-file-names ,(host-directory host) #f) + i/o)) + (proj (project-name)) + (sarch (host-scheme-architecture host)) + (darch (host-debian-architecture host))) + (if (not (list-of-type? files string?)) + (error "Unexpected filename list:" files)) + (write-lock-report host i/o files) + (for-each + (lambda (src) + (let ((name (car src)) + (vers (cdr src))) + (if (not (member (string name"-"vers".tar.gz") files)) + (run "scp -p devops/"name"-"vers".tar.gz" + " "(host-login/dir host)) + (if (string=? proj name) + (write-pkg-status name vers sarch files host i/o))) + + (if (host-build-ubuntu? host) + (let ((dsc (string name"_"vers".dsc")) + (tar (string name"_"vers".tar.xz"))) + (if (or (not (member dsc files)) + (not (member tar files))) + (begin + (if (not (member dsc files)) + (run "scp -p devops/"dsc" "(host-login/dir host))) + (if (not (member tar files)) + (run "scp -p devops/"tar" "(host-login/dir host)))) + (write-ubuntu-status name vers darch files host i/o)))))) + srcs)) + (start-builds host i/o)))) + +(define (write-lock-report host i/o files) + (if (member "lock" files) + (let* ((lockfile (string (host-directory host)"/lock")) + (start-time + (read-reply `(file-time->local-time-string + (file-modification-time ,lockfile)) + i/o))) + (log "Daemon started "start-time"\n")) + (log "No daemon running.\n"))) + +(define (write-pkg-status name vers sarch files host i/o) + (let ((logfile (string name"-"vers"-"sarch"-pkg.log"))) + (if (not (member logfile files)) + (let ((bin (string name"-"vers"-"sarch".tar.gz")) + (elogfile (string name"-"vers"-"sarch"-pkg-error.log"))) + (log bin"\n") + (if (member elogfile files) + (write-minutes-stalled + (string (host-directory host)"/"elogfile) i/o)))))) + +(define (write-ubuntu-status name vers darch files host i/o) + (let ((logfile (string name"-"vers"-"darch"-dpkg.log"))) + (if (not (member logfile files)) + (let ((bin (string name"_"vers"_"darch".deb")) + (elogfile (string name"_"vers"_"darch"-dpkg-error.log"))) + (log bin"\n") + (if (member elogfile files) + (write-minutes-stalled + (string (host-directory host)"/"elogfile) i/o)))))) + +(define (write-minutes-stalled elogpath i/o) + (let* ((sec (read-reply `(- (get-universal-time) + (file-time->universal-time + (file-modification-time ,elogpath))) + i/o)) + (min (quotient sec 60))) + (cond ((> min 60) + (log " No progress in over an hour!\n")) + ((> min 10) + (log " No progress in "(number->string min 10)" minutes.\n")) + (else + (log " Working...\n"))))) + +(define (start-builds host i/o) + (write-file (let ((repo "src/devops/build.scm")) + (if (file-exists? repo) + repo + (let ((sys (system-library-pathname "devops/build.scm" #f))) + (if (file-exists? sys) + sys + (error "Could not find build script."))))) + i/o) + + (verify-host-architecture host i/o) + + (write-line `(begin + (set! project-name ,(project-name)) + (set! build-dir ,(host-directory host)) + (set! build-scheme-architecture + ',(host-scheme-architecture host)) + (set! build-debian-architecture + ,(host-debian-architecture host)) + (set! build-ubuntu? + ,(host-build-ubuntu? host)) + (build)) + i/o) + (flush-output-port i/o) + (let ((reply (read-reply '(quote ok) i/o))) + (if (not (eq? reply 'ok)) + (error "Build host not OK."))) + (close-input-port i/o) + (close-output-port i/o)) + +(define (verify-host-architecture host i/o) + (if (host-build-ubuntu? host) + (begin + (let ((darch (read-reply '(read-debian-architecture) i/o))) + (if (not (string? darch)) + (error "No Debian architecture.")) + (if (not (string=? darch (host-debian-architecture host))) + (error "Wrong Debian architecture."))) + (let ((str (read-reply '(if (ubuntu?) "yes" "no") i/o))) + (if (not (string? str)) + (error "No Ubuntu-ness.")) + (let ((ubu? (string=? "yes" str))) + (if (not (eq? ubu? (host-ubuntu? host))) + (error "Wrong Ubuntu-ness."))))))) + +(define (call-with-host-i/o host receiver) + (call-with-current-continuation + (lambda (punt) + (bind-condition-handler (list condition-type:serious-condition + condition-type:simple-condition) + (named-lambda (host-condition-handler condition) + (write-condition-report condition (current-output-port)) + (newline) + (punt unspecific)) + (lambda () + (let ((proc #f)) + (dynamic-wind + (lambda () + unspecific) + (lambda () + (set! proc (start-pipe-subprocess + (os/find-program "ssh" #f) + (vector "ssh" (host-login host) + "mit-scheme" "--batch-mode") + #f)) + (receiver (subprocess-i/o-port proc))) + (lambda () + (if (and proc (memq (subprocess-status proc) '(running stopped))) + (ignore-errors (lambda () (subprocess-kill proc)))))))))))) + +(define (read-lines-until line usec in) + (do-until + (lambda () + (let loop ((lines '())) + (let ((line* (read-line in))) + (if (eof-object? line*) + (reverse! lines) + (if (string=? line line*) + (reverse! (cons line* lines)) + (loop (cons line* lines))))))) + usec + (lambda () #f))) + +(define (read-until usec in) + (do-until (lambda () (read in)) + usec + (lambda () 'timeout))) + +(define (do-until thunk usec timeout) + (call-with-current-continuation + (lambda (return) + (let* ((record + (register-timer-event usec + (named-lambda (timeout-do-until) + (return (timeout))))) + (value (thunk))) + (deregister-timer-event record) + value)))) + +;;;; Make + +(define (devops:make target) + (if (not (member target '("native" "svm" "C" "C-old" "C2native" "C2svm"))) + (error "Unknown build target:" target)) + (load-make-config) + (%exit + (call-with-current-continuation ;throw here to unwind all + (lambda (abort-job) + (bind-condition-handler (list condition-type:error) + (named-lambda (job-error-handler condition) + (fresh-line) + (log "# "(emacs-friendly-timestamp)"\n") + (write-condition-report condition (current-output-port)) + (newline) + (flush-output) + (abort-job 2)) + (lambda () + (with-^G-interrupt-handler + (named-lambda (job-^G-interrupt-handler) + (abort-job 3)) + (lambda () + (devops:make* target) + 0)))))))) + +(define (devops:make* target) + (let* ((prefix (or (get-environment-variable "PWD") + (error "PWD not set."))) + (host-exe (or (get-environment-variable "MIT_SCHEME_EXE") + "mit-scheme")) + (target-exe 'unset)) + (if (file-directory? ".git") + (make-install-doc prefix) + (if (file-directory? "../.git") + (begin + (lndir "../doc") + (make-install-doc prefix) + (for-each lndir '("../src" "../tests"))) + (error "Not a git working directory:" + (working-directory-pathname)))) + + ;;(set-environment-variable! "LD_LIBRARY_PATH" "/usr/local/lib") + (set-subprocess-environment-variable! "FAST" "please") + (delete-subprocess-environment-variable! "DISPLAY") + + (log "# Host: "host-exe"\n") + (log "# Target: "target"\n") + (log "# Config: "make-config"\n") + + (cond + ((equal? target "native") + (if (not (file-exists? "src/configure")) + (trun "cd src/; ./Setup.sh")) + (if (not (file-exists? "src/Makefile")) + (trun "cd src/; ./configure --prefix="prefix" "make-config)) + (trun "cd src/; make tags") + (trun "cd src/; make all") + (trun "cd src/; make check") + (trun "cd src/; umask 022; make install") + (set! target-exe (project-name))) + + ((equal? target "svm") + (if (not (file-exists? "src/configure")) + (trun "cd src/; ./Setup.sh")) + (if (not (file-exists? "src/Makefile")) + (trun "cd src/; ./configure" " --prefix="prefix + " --enable-cross-compiling --enable-native-code=svm " + make-config)) + (trun "cd src/; make tags") + (trun "cd src/; make all") + (trun "cd src/; make check") + (trun "cd src/; umask 022; make install") + (set! target-exe (string (project-name)"-svm1"))) + + ((equal? target "C") + (if (not (file-exists? "src/configure")) + (trun "cd src/; ./Setup.sh")) + (if (not (file-exists? "src/Makefile")) + (trun "cd src/; ./configure --prefix="prefix + " --enable-native-code=C "make-config)) + (trun "cd src/; make tags") + (trun "cd src/; make all-native") + (trun "cd src/; make check") + (trun "cd src/; umask 022; make install") + (set! target-exe (string (project-name)"-c"))) + + ((equal? target "C-old") + (trun "cd src/; make tags") + (trun "cd src/; ./etc/make-liarc-dist.sh --prefix="prefix" "make-config) + (trun "cd src/; ./etc/make-liarc.sh --prefix="prefix" "make-config) + (trun "cd src/; make check") + (trun "cd src/; umask 022; make install") + (set! target-exe (string (project-name)"-c"))) + + ((equal? target "C2native") + (trun "cd src/; make tags") + (trun "cd src/; ./etc/make-native.sh --prefix="prefix" "make-config) + (trun "cd src/; make check") + (trun "cd src/; umask 022; make install") + (set! target-exe (project-name))) + + ((equal? target "C2svm") + (trun "cd src/; make tags") + (trun "cd src/; ./etc/make-native.sh --prefix="prefix" "make-config) + (trun "cd src/; make check") + (trun "cd src/; umask 022; make install") + (set! target-exe (string (project-name)"-svm1"))) + + (else + (error "Unexpected target:" target))) + + (let ((plugin-errors + (with-subprocess-environment-variable + "MIT_SCHEME_EXE" (string prefix"/bin/"target-exe) + (lambda () + (reduce + 0 + (map (lambda (plugin) (make-install-plugin plugin prefix)) + plugin-list)))))) + (if (not (zero? plugin-errors)) + (error "Plugins failed to build:" plugin-errors))))) + +(define (load-make-config) + (cond ((file-exists? "devops-config.scm") + (load "devops-config.scm" '(devops))) + ((file-exists? "../devops-config.scm") + (load "../devops-config.scm" '(devops))) + ((let* ((git-root (find-git-root)) + (file (string git-root"/devops-config.scm"))) + (and (file-exists? file) + (begin (load file '(devops)) + #t)))) + (else + (error "No devops test configuration found.")))) + +(define make-config "") +(define (make-configuration . args) + (guarantee-list-of string? args 'make-configuration) + (if (not (null? args)) + (set! make-config ((string-joiner* 'infix " ") args))) + make-config) + +(define (lndir dest) + (let ((dirname (dirname dest))) + (let loop ((name (filename dest)) + (dstdir dirname) + (srcdir "") + (reldir (drop-slash dirname))) + (let ((dst (string dstdir name)) + (src (string srcdir name))) + (let ((dst-atts (file-attributes-direct dst)) + (src-atts (file-attributes-direct src))) + (if (eq? #t (file-attributes/type dst-atts)) + (if (not (or (eq? #f src-atts) + (eq? #t (file-attributes/type src-atts)))) + (warn "not a directory:" src) + (let ((dstdir* (string dst"/")) + (srcdir* (string src "/")) + (reldir* (string "../"reldir"/"name))) + (if (eq? #f src-atts) + (make-directory src)) + (for-each + (lambda (name) + (cond ((string=? "." name)) + ((string=? ".." name)) + ((string-suffix? "~" name)) + (else (loop name dstdir* srcdir* reldir*)))) + (directory-file-names dst)))) + (let ((reldirname (string reldir"/"name))) + (if (eq? #f src-atts) + (soft-link-file reldirname src) + (let ((src-type (file-attributes/type src-atts))) + (cond ((not (string? src-type)) + (warn "not a symlink:" src)) + ((not (string=? src-type reldirname)) + (warn "bogus symlink:" src reldirname)))))))))))) + +(define (make-install-doc prefix) + (if (not (file-exists? "doc/configure")) + (trun "cd doc/; autoconf")) + (if (not (file-exists? "doc/Makefile")) + (trun "cd doc/; ./configure --prefix="prefix)) + (trun "cd doc/; make all") + (trun "cd doc/; umask 022; make install")) + +(define (make-install-plugin plugin prefix) + (let ((result (ignore-errors + (lambda () (make-install-plugin* plugin prefix))))) + (if (condition? result) + (begin + (log "# "(plugin-name plugin)" failed to build:" + " "(condition/report-string result)"\n") + 1) + 0))) + +(define (make-install-plugin* plugin prefix) + (let ((dir (plugin-directory plugin))) + (if (not (file-directory? dir)) + (error "Plugin directory not found:" dir)) + (log "# "dir":\n") + (if (not (file-exists? (string dir"/configure"))) + (trun "cd "dir"/; ./autogen.sh")) + (if (not (file-exists? (string dir"/Makefile"))) + (trun "cd "dir"/; ./configure --prefix="prefix)) + (trun "cd "dir"/; make tags") + (trun "cd "dir"/; make all") + (trun "cd "dir"/; make check") + (trun "cd "dir"/; umask 022; make install") + (if (find (lambda (line) (string-prefix? "info_TEXINFOS" line)) + (file-lines dir"/Makefile.am")) + (begin + (trun "cd "dir"/; umask 022; make install-html") + (trun "cd "dir"/; umask 022; make install-pdf"))))) + +(define (trun . strings) + ;;(log-timestamp) + (log "# "(emacs-friendly-timestamp)"\n") + (apply run strings)) + +(define (emacs-friendly-timestamp) + (let ((dt (local-decoded-time))) + (define (pad num) (string-pad-left (number->string num) 2 #\0)) + (let ((year (number->string (decoded-time/year dt))) + (month (pad (decoded-time/month dt))) + (day (pad (decoded-time/day dt))) + (hour (pad (decoded-time/hour dt))) + (minute (pad (decoded-time/minute dt))) + (second (pad (decoded-time/second dt)))) + (string year"-"month"-"day" "hour"."minute"."second)))) + +(define (with-^G-interrupt-handler inside-handler thunk) + (let ((env (->environment '(runtime interrupt-handler))) + (outside-handler)) + (dynamic-wind + (lambda () + (set! outside-handler (environment-lookup env 'hook/^G-interrupt)) + (environment-assign! env 'hook/^G-interrupt inside-handler)) + thunk + (lambda () + (set! inside-handler (environment-lookup env 'hook/^G-interrupt)) + (environment-assign! env 'hook/^G-interrupt outside-handler))))) + +;;;; Configuration + +(define (project-name #!optional name) + (if (default-object? name) + project-name-string + (begin + (if (not (string? name)) + (error "Project name is not a string:" name)) + (set! project-name-string name) + name))) + +(define project-name-string "new-scheme") + +(define (plugin-package plugin) + (string (project-name)"-"(plugin-name plugin))) + +(define (plugin name directory) + (let ((duplicate (find (lambda (p) (string=? name (plugin-name p))) + plugin-list))) + (if duplicate + (error (string "Plugin "name" already defined.")))) + (set! plugin-list + (append! plugin-list + (list (make-plugin name directory)))) + unspecific) + +(define plugin-list '()) + +(define (->plugin name) + (let ((n (string name))) + (or (find (lambda (p) (string=? n (plugin-name p))) + plugin-list) + (error "No such plugin:" name)))) + +(define-record-type + (make-plugin name directory) + plugin? + (name plugin-name) + (directory plugin-directory)) + +(define (host name user directory arch os) + (let ((duplicate (find (lambda (h) (string=? name (host-name h))) + host-list))) + (if duplicate + (error (string "Host "name" already defined.")))) + (set! host-list + (append! host-list + (list (make-host name user directory arch os)))) + unspecific) + +(define (hosts) (list-copy host-list)) + +(define host-list '()) + +(define (host-login/dir h) + (string (host-login h)":"(host-directory h))) + +(define (host-login h) + (let ((n (host-name h)) + (u (host-user h))) + (if u + (string u"@"n) + n))) + +(define-record-type + (make-host name user directory arch os) + host? + (name host-name) + (user host-user) + (directory host-directory) + (arch host-scheme-architecture) + (os host-os)) + +(define (host-ubuntu? host) + (os-ubuntu? (host-os host))) + +(define (host-build-ubuntu? host) + (and (host-ubuntu? host) + (not (string-prefix? "svm" (host-scheme-architecture host))))) + +(define (host-debian-architecture host) + (let ((arch (host-scheme-architecture host))) + (cond ((string=? "x86-64" arch) "amd64") + ((string=? "i386" arch) "i386") + ((string=? "svm1-32" arch) #f) + ((string=? "svm1-64" arch) #f) + (else (error "Unknown host architecture:" arch))))) + +(define (host-ubuntu-codename host) + (ubuntu-os-codename (host-os host))) + +(define (host-ubuntu-version host) + (ubuntu-os-version (host-os host))) + +(define (os-ubuntu? os) + (string-prefix? "Ubuntu " os)) + +(define (ubuntu-os-codename os) + (cond ((string=? "Ubuntu 18.04" os) "bionic") + ((string=? "Ubuntu 17.10" os) "artful") + ((string=? "Ubuntu 17.04" os) "zesty") + ((string=? "Ubuntu 16.10" os) "yakkety") + ((string=? "Ubuntu 16.04" os) "xenial") + (else (error "Unexpected Ubuntu OS:" os)))) + +(define (ubuntu-os-version os) + (cond ((string=? "Ubuntu 18.04" os) "18.04") + ((string=? "Ubuntu 17.10" os) "17.10") + ((string=? "Ubuntu 17.04" os) "17.04") + ((string=? "Ubuntu 16.10" os) "16.10") + ((string=? "Ubuntu 16.04" os) "16.04") + (else (error "Unexpected Ubuntu OS:" os)))) + +;;;; Misc + +(define (sorted-tags package-name) + (sort (let ((pattern (compile-regsexp + `(seq ,package-name #\- + (group version + (+ (alt #\. (char-in numeric)))) + (string-end))))) + (append-map! + (lambda (line) + (let ((match (regsexp-match-string pattern line))) + (if match + (list (cons (->version (match-extract match 'version)) + line)) + '()))) + (shell-lines "git tag -l '"package-name"-*'"))) + (lambda (a b) (version>? (car a) (car b))))) + +(define (match-extract match key) + (let ((entry (assq key (cddr match)))) + (if entry + (cdr entry) + (error "Match key not found:" key match)))) + +(define (version-comparator < >) + (named-lambda (version-compare v1 v2) + (let loop ((v1 v1) (v2 v2)) + (cond ((eq? #f v1) + #t) + ((eq? #f v2) + #f) + ((null? v2) + #f) + ((null? v1) ;; and (pair? v2) + #t) + ((< (car v1) (car v2)) + #t) + ((> (car v1) (car v2)) + #f) + (else + (loop (cdr v1) (cdr v2))))))) + +(define (->version string) + (and string + (map string->number (burst-string string #\. #f)))) + +(define (version-string version) + (if (pair? version) + (decorated-string-append "" "." "" + (map (lambda (num) (number->string num 10)) + version)) + (error "Bad version:" version))) + +(define version=? equal?) +(define version)) +(define version>? (version-comparator > <)) + +(define (read-first-line filename) + (call-with-input-file filename + (lambda (in) + (let ((line (read-line in))) + (and (string? line) + line))))) + +(define (write-file filename out) + (call-with-input-file filename + (lambda (in) + (let loop () + (let ((line (read-line in))) + (if (not (eof-object? line)) + (begin + (write-string line out) + (newline out) + (loop)))))))) + +(define (find-git-root) + (let ((pwd (drop-slash (or (get-environment-variable "PWD") + (error "PWD not set."))))) + (let loop ((parent (drop-slash (dirname pwd)))) + (if (string-null? parent) + (error "No git root found:" pwd) + (if (file-directory? (string parent"/.git")) + parent + (loop (drop-slash (dirname pwd)))))))) + +(define (drop-slash string) + (let ((len-1 (fix:-1+ (string-length string)))) + (if (and (fix:>= len-1 0) + (char=? #\/ (string-ref string len-1))) + (string-slice string 0 len-1) + string))) + +(define (filename filename) + (let ((i (string-find-previous-char filename #\/))) + (if (not i) + filename + (string-slice filename (fix:1+ i))))) + +(define (dirname filename) + (let ((i (string-find-previous-char filename #\/))) + (if (not i) + "" + (string-slice filename 0 (fix:1+ i))))) + +(define (basename filename) + (let* ((start (let ((i (string-find-previous-char filename #\/))) + (if (not i) + 0 + (fix:1+ i)))) + (end (string-find-next-char filename #\. start))) + (if (not end) + (if (fix:zero? start) + filename + (string-slice filename start)) + (string-slice filename start end)))) diff --cc src/edwin/Makefile.am index 1f0bc8cde,000000000..6b7ad7bae mode 100644,000000..100644 --- a/src/edwin/Makefile.am +++ b/src/edwin/Makefile.am @@@ -1,90 -1,0 +1,89 @@@ +## Process this file with automake to produce Makefile.in +## +## Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, +## 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, +## 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 +## Massachusetts Institute of Technology +## +## This file is part of MIT/GNU Scheme. +## +## MIT/GNU Scheme is free software; you can redistribute it and/or modify +## it under the terms of the GNU General Public License as published by +## the Free Software Foundation; either version 2 of the License, or (at +## your option) any later version. +## +## MIT/GNU Scheme is distributed in the hope that it will be useful, but +## WITHOUT ANY WARRANTY; without even the implied warranty of +## MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +## General Public License for more details. +## +## You should have received a copy of the GNU General Public License +## along with MIT/GNU Scheme; if not, write to the Free Software +## Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +## USA. + +EXTRA_DIST = autogen.sh + +MIT_SCHEME_EXE = @MIT_SCHEME_EXE@ +scmlibdir = @MIT_SCHEME_LIBDIR@ +scmlib_subdir = $(scmlibdir)edwin +scmdocdir = $(datarootdir)/doc/@MIT_SCHEME_PROJECT@ +#scminfodir = $(scmdocdir)/info + +sources =@MIT_SCHEME_SOURCES@ +binaries =@MIT_SCHEME_BINARIES@ + +scmlib_sub_DATA = $(sources) +scmlib_sub_DATA += $(binaries) - scmlib_sub_DATA += rename.scm rename.bci rename.com +scmlib_sub_DATA += loadef.scm edwin.bld +scmlib_sub_DATA += make.scm edwin-@MIT_SCHEME_OS_SUFFIX@.pkd +scmlib_sub_DATA += TUTORIAL + +#scminfo_DATA = edwin.info +#info_TEXINFOS = edwin.texi +#AM_MAKEINFOHTMLFLAGS = --no-split +#AM_UPDATE_INFO_DIR = no + +include $(srcdir)/source-dependencies.am +edwin.bld: stamp-scheme +edwin-@MIT_SCHEME_OS_SUFFIX@.pkd: stamp-scheme +stamp-scheme: $(sources) edwin.ldr edwin.pkg + touch stamp-scheme + if ! ./compile.sh; then rm stamp-scheme; exit 1; fi + +CLEANFILES = *.bin *.ext *.com *.bci *.moc *.fni *.crf *.fre *.pkd *.bld +CLEANFILES += stamp-scheme + +ETAGS_ARGS = $(sources) edwin.ldr +TAGS_DEPENDENCIES = $(sources) edwin.ldr + +EXTRA_DIST += $(sources) TUTORIAL +EXTRA_DIST += sources.sh compile.sh decls.scm edwin.ldr +EXTRA_DIST += edwin.sf edwin.cbf edwin.pkg debian + +install-data-hook: + ( echo '(add-plugin "edwin" "@MIT_SCHEME_PROJECT@"'; \ + echo ' "$(DESTDIR)$(infodir)"'; \ + echo ' "$(DESTDIR)$(scmlibdir)"'; \ + echo ' "$(DESTDIR)$(scmdocdir)")' ) \ + | $(MIT_SCHEME_EXE) --batch-mode + +install-html: install-html-am + ( echo '(add-plugin "edwin" "@MIT_SCHEME_PROJECT@"'; \ + echo ' "$(DESTDIR)$(infodir)"'; \ + echo ' "$(DESTDIR)$(scmlibdir)"'; \ + echo ' "$(DESTDIR)$(scmdocdir)")' ) \ + | $(MIT_SCHEME_EXE) --batch-mode + +install-info-am: + +uninstall-info-am: + +uninstall-hook: + ( echo '(remove-plugin "edwin" "@MIT_SCHEME_PROJECT@"'; \ + echo ' "$(DESTDIR)$(infodir)"'; \ + echo ' "$(DESTDIR)$(scmlibdir)"'; \ + echo ' "$(DESTDIR)$(scmdocdir)")' ) \ + | $(MIT_SCHEME_EXE) --batch-mode + [ -d "$(DESTDIR)$(scmlib_subdir)" ] \ + && rmdir "$(DESTDIR)$(scmlib_subdir)" diff --cc src/edwin/buffer.scm index 8fa83c5e6,4220640d3..afb414a53 --- a/src/edwin/buffer.scm +++ b/src/edwin/buffer.scm @@@ -29,11 -29,7 +29,11 @@@ USA (declare (usual-integrations)) (define-structure (buffer - (constructor %make-buffer (%name %default-directory))) + (constructor %make-buffer (%name %default-directory)) + (print-procedure - (simple-unparser-method 'BUFFER ++ (standard-print-method 'BUFFER + (lambda (buffer) + (list (buffer-name buffer)))))) %name group mark-ring diff --cc src/edwin/decls.scm index 854823e71,d27c2c165..83f4bca58 --- a/src/edwin/decls.scm +++ b/src/edwin/decls.scm @@@ -98,8 -98,8 +97,7 @@@ USA "termcap" "utils" "win32" - "winren" - "xform" - "xterm")) + "xform")) (sf-edwin "tterm" "termcap") (let ((includes '("struct" "comman" "modes" "buffer" "edtstr"))) (let loop ((files includes) (includes '())) diff --cc src/edwin/ed-ffi.scm index 8b26f49b6,161209dde..220c9116e --- a/src/edwin/ed-ffi.scm +++ b/src/edwin/ed-ffi.scm @@@ -184,5 -184,7 +183,4 @@@ USA ("wincom" (edwin)) ("window" (edwin window)) ("winout" (edwin window-output-port)) - ("winren" (edwin)) - ("xcom" (edwin x-commands)) - ("xform" (edwin class-macros transform-instance-variables)) - ("xmodef" (edwin)) - ("xterm" (edwin screen x-screen)))) + ("xform" (edwin class-macros transform-instance-variables)))) diff --cc src/edwin/edwin.ldr index d0bec9b2c,698afde88..f824639d9 --- a/src/edwin/edwin.ldr +++ b/src/edwin/edwin.ldr @@@ -165,33 -164,38 +164,33 @@@ USA (if (load "bios" env) ((access bios-initialize-package! env)))))) - (case (lookup 'OS-TYPE) - ((NT) + (case (lookup 'os-type) + ((nt) (load-set-and-initialize! '("win32") - (->environment '(EDWIN SCREEN WIN32))) + (->environment '(edwin screen win32))) (load-set-and-initialize! '("key-w32") - (->environment '(EDWIN WIN32-KEYS))))) - (->environment '(edwin win32-keys)))) - ((unix) - (load-set-and-initialize! '("xterm") - (->environment '(edwin screen x-screen))) - (load "key-x11" (->environment '(edwin x-keys))))) ++ (->environment '(edwin win32-keys))))) - (load-case 'OS-TYPE - '((UNIX . "process") - (DOS . "dosproc") - (NT . "process")) - (->environment '(EDWIN PROCESS))) + (load-case 'os-type + '((unix . "process") + (dos . "dosproc") + (nt . "process")) + (->environment '(edwin process))) (load "mousecom" environment) - (case (lookup 'OS-TYPE) - ((NT) (load "win32com" (->environment '(EDWIN WIN-COMMANDS))))) + (case (lookup 'os-type) - ((unix) (load "xcom" (->environment '(edwin x-commands)))) + ((nt) (load "win32com" (->environment '(edwin win-commands))))) ;; debug depends on button1-down defined in mousecom - (load "debug" (->environment '(EDWIN DEBUGGER))) + (load "debug" (->environment '(edwin debugger))) - (let ((env (->environment '(EDWIN DIRED)))) + (let ((env (->environment '(edwin dired)))) (load "dired" env) - (case (lookup 'OS-TYPE) - ((UNIX) (load "dirunx" env)) - ((NT) (load "dirw32" env)))) + (case (lookup 'os-type) + ((unix) (load "dirunx" env)) + ((nt) (load "dirw32" env)))) (load "abbrev" environment) - (load "argred" (->environment '(EDWIN COMMAND-ARGUMENT))) + (load "argred" (->environment '(edwin command-argument))) (load "autold" environment) (load "autosv" environment) (load "basic" environment) diff --cc src/edwin/edwin.sf index 607a35cff,1f45ba3d7..7353fb7e4 --- a/src/edwin/edwin.sf +++ b/src/edwin/edwin.sf @@@ -24,27 -24,23 +24,27 @@@ USA |# - (load-option 'CREF) - (load-option 'SOS) - (load-option 'XML) - (load-option 'BLOWFISH) - (load-option 'GDBM) + (load-option 'cref) ++(load-option 'sos) ++(load-option 'xml) ++(load-option 'blowfish) ++(load-option 'gdbm) - (if (not (name->package '(EDWIN))) + (if (not (name->package '(edwin))) (let ((package-set (package-set-pathname "edwin"))) (if (not (file-exists? package-set)) - (cref/generate-trivial-constructor "edwin")) + (cref/generate-trivial-constructor "edwin" #f)) (construct-packages-from-file (fasload package-set)))) - (if (lexical-unreferenceable? (->environment '(EDWIN STRING)) - 'STRING?) + (if (lexical-unreferenceable? (->environment '(edwin string)) + 'string?) (begin - (fluid-let ((sf/default-syntax-table (->environment '(EDWIN)))) + (fluid-let ((sf/default-syntax-table (->environment '(edwin)))) (sf-conditionally "string")) - (load "string.bin" '(EDWIN STRING)))) + (load "string.bin" '(edwin string)))) - (if (lexical-unreferenceable? (->environment '(EDWIN CLASS-CONSTRUCTOR)) - 'CLASS-DESCRIPTORS) + (if (lexical-unreferenceable? (->environment '(edwin class-constructor)) + 'class-descriptors) (begin (let ((sf-and-load (lambda (files package) diff --cc src/edwin/intmod.scm index eb951db56,d1fd9c6d9..cb15e5977 --- a/src/edwin/intmod.scm +++ b/src/edwin/intmod.scm @@@ -114,39 -114,31 +114,39 @@@ evaluated in the specified inferior REP (buffer-put! buffer 'MAJOR-MODE-LOCKED #t)) (if (environment? environment) (local-set-variable! scheme-environment environment buffer)) - (create-thread editor-thread-root-continuation - (lambda () - (let ((port - (make-interface-port buffer - (let ((thread (current-thread))) - (detach-thread thread) - thread)))) - (attach-buffer-interface-port! buffer port) - (parameterize* (list (cons param:exit-hook inferior-repl/exit) - (cons param:suspend-hook inferior-repl/suspend)) - (lambda () - (dynamic-wind - (lambda () unspecific) - (lambda () - (repl/start (make-repl #f - port - environment - #f - `((ERROR-DECISION ,error-decision)) - user-initial-prompt) - (make-init-message message))) - (lambda () - (signal-thread-event editor-thread - (lambda () - (unwind-inferior-repl-buffer buffer))))))))))) + (let ((return (make-thread-queue 1)) + (proceed (make-thread-queue 1))) + (create-thread editor-thread-root-continuation + (lambda () + (let ((port + (make-interface-port buffer + (let ((thread (current-thread))) + (detach-thread thread) + thread)))) + (thread-queue/queue! return port) ;pass port to editor-thread + (thread-queue/dequeue! proceed) ;wait for port to be attached - (parameterize* (list (cons param:%exit-hook inferior-repl/%exit) - (cons param:quit-hook inferior-repl/quit)) ++ (parameterize* (list (cons param:exit-hook inferior-repl/exit) ++ (cons param:suspend-hook inferior-repl/suspend)) + (lambda () + (dynamic-wind + (lambda () unspecific) + (lambda () + (repl/start + (make-repl #f + port + environment + #f + `((ERROR-DECISION ,error-decision)) + user-initial-prompt) + (make-init-message message))) + (lambda () + (signal-thread-event editor-thread + (lambda () + (unwind-inferior-repl-buffer buffer))))))))) + buffer) + (let ((port (thread-queue/dequeue! return))) + (attach-buffer-interface-port! buffer port) + (thread-queue/queue! proceed 'ready)))) (define (make-init-message message) (if message diff --cc src/edwin/sources.sh index 7c020e02d,000000000..1c04f1805 mode 100755,000000..100755 --- a/src/edwin/sources.sh +++ b/src/edwin/sources.sh @@@ -1,86 -1,0 +1,86 @@@ +#!/bin/sh +# -*-Scheme-*- +# +# Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, +# 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, +# 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 +# Massachusetts Institute of Technology +# +# This file is part of MIT/GNU Scheme. +# +# MIT/GNU Scheme is free software; you can redistribute it and/or modify +# it under the terms of the GNU General Public License as published by +# the Free Software Foundation; either version 2 of the License, or (at +# your option) any later version. +# +# MIT/GNU Scheme is distributed in the hope that it will be useful, but +# WITHOUT ANY WARRANTY; without even the implied warranty of +# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +# General Public License for more details. +# +# You should have received a copy of the GNU General Public License +# along with MIT/GNU Scheme; if not, write to the Free Software +# Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, +# USA. + +# Generate a list of all source files. + +set -e +: ${MIT_SCHEME_EXE=mit-scheme} +${MIT_SCHEME_EXE} --batch-mode -- $1 <<\EOF +(begin + + (define (filenames) + '("abbrev" "ansi" "argred" "artdebug" "autold" "autosv" "basic" + "bios" "bufcom" "buffer" "buffrm" "bufinp" "bufmnu" "bufout" + "bufset" "bufwfs" "bufwin" "bufwiu" "bufwmc" "c-mode" "calias" + "cinden" "class" "clscon" "clsmac" "comatch" "comhst" "comint" + "comman" "compile" "comred" "comtab" "comwin" "curren" "dabbrev" + "debian-changelog" "debug" "debuge" "diff" "dired" "dirunx" + "dirw32" "display" "docstr" "dos" "doscom" "dosfile" "dosproc" + "dosshell" "ed-ffi" "editor" "edtfrm" "edtstr" "evlcom" "eystep" + "filcom" "fileio" "fill" "grpops" "hlpcom" "htmlmode" "image" + "info" "input" "intmod" "iserch" "javamode" "key-w32" "keymap" + "keyparse" "kilcom" "kmacro" "lincom" "linden" "lisppaste" + "loadef" "lspcom" "macros" "make" "malias" "manual" "midas" + "modefs" "modes" "modlin" "modwin" "motcom" "motion" "mousecom" + "nntp" "notify" "nvector" "occur" "outline" "paredit" "pasmod" + "paths" "print" "process" "prompt" "pwedit" "pwparse" "rcsparse" - "reccom" "regcom" "regexp" "regops" "rename" "replaz" "rfc822" ++ "reccom" "regcom" "regexp" "regops" "replaz" "rfc822" + "ring" "rmail" "rmailsrt" "rmailsum" "schmod" "scrcom" "screen" + "search" "sendmail" "sercom" "shell" "simple" "snr" "sort" + "string" "strpad" "strtab" "struct" "syntax" "tagutl" "techinfo" + "telnet" "termcap" "texcom" "things" "tparse" "tterm" "tximod" + "txtprp" "undo" "unix" "utils" "utlwin" "vc" "vc-bzr" "vc-cvs" + "vc-git" "vc-rcs" "vc-svn" "verilog" "vhdl" "webster" "win32" - "win32com" "wincom" "window" "winout" "winren" "world-monitor" ++ "win32com" "wincom" "window" "winout" "world-monitor" + "xform")) + + (define (my-write . strings) + (for-each write-string strings)) + + (define (my-write-line . strings) + (apply my-write strings) (newline)) + - (let ((command (car (command-line))) ++ (let ((command (car (command-line-arguments))) + (files (filenames))) + (cond ((string=? command "scm") + (for-each (lambda (name) (my-write " "name)) + (sort (map (lambda (pathname) + (->namestring (pathname-new-type pathname "scm"))) + files) + stringnamestring files) stringnamestring files) string i teeth)) + (let ((angle (* i 2pi/teeth))) + (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) width/2) + (gl:vertex3 (* r1 (cos angle)) (* r1 (sin angle)) width/2) + (if (< i teeth) + (let ((angl4 (+ angle 3da))) + (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) width/2) + (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) width/2))))) + (gl:end) + + ;; draw front sides of teeth + (gl:begin 'QUADS) + (do ((i 0. (+ i 1.))) + ((= i teeth)) + (let ((angle (* i 2pi/teeth))) + (let ((angl1 angle)) + (gl:vertex3 (* r1 (cos angl1)) (* r1 (sin angl1)) width/2)) + (let ((angl2 (+ angle da))) + (gl:vertex3 (* r2 (cos angl2)) (* r2 (sin angl2)) width/2)) + (let ((angl3 (+ angle 2da))) + (gl:vertex3 (* r2 (cos angl3)) (* r2 (sin angl3)) width/2)) + (let ((angl4 (+ angle 3da))) + (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) width/2)))) + (gl:end) + + (gl:normal (flo:3d 0. 0. -1.)) + + ;; draw back face + (gl:begin 'QUAD-STRIP) + (do ((i 0. (+ i 1.))) + ((> i teeth)) + (let ((angle (* i 2pi/teeth))) + (gl:vertex3 (* r1 (cos angle)) (* r1 (sin angle)) -width/2) + (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) -width/2) + (if (< i teeth) + (let ((angl4 (+ angle 3da))) + (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) -width/2) + (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) -width/2) + )))) + (gl:end) + + ;; draw back sides of teeth + (gl:begin 'QUADS) + (do ((i 0. (+ i 1.))) + ((= i teeth)) + (let ((angle (* i 2pi/teeth))) + (let ((angl4 (+ angle 3da))) + (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) -width/2)) + (let ((angl3 (+ angle 2da))) + (gl:vertex3 (* r2 (cos angl3)) (* r2 (sin angl3)) -width/2)) + (let ((angl2 (+ angle da))) + (gl:vertex3 (* r2 (cos angl2)) (* r2 (sin angl2)) -width/2)) + (let ((angl1 angle)) + (gl:vertex3 (* r1 (cos angl1)) (* r1 (sin angl1)) -width/2)))) + (gl:end) + + ;; draw outward faces of teeth + (gl:begin 'QUAD-STRIP) + (do ((i 0. (+ i 1.))) + ((= i teeth)) + (let ((angle (* i 2pi/teeth))) + (let ((angl2 (+ angle da)) + (angl3 (+ angle 2da)) + (angl4 (+ angle 3da))) + (gl:vertex3 (* r1 (cos angle)) (* r1 (sin angle)) width/2) + (gl:vertex3 (* r1 (cos angle)) (* r1 (sin angle)) -width/2) + (let ((u (- (* r2 (cos angl2)) (* r1 (cos angle)))) + (v (- (* r2 (sin angl2)) (* r1 (sin angle))))) + (let ((len (sqrt (+ (* u u) (* v v))))) + (gl:normal (flo:3d (/ v len) (- (/ u len)) 0.)))) + (gl:vertex3 (* r2 (cos angl2)) (* r2 (sin angl2)) width/2) + (gl:vertex3 (* r2 (cos angl2)) (* r2 (sin angl2)) -width/2) + (gl:normal (flo:3d (cos angle) (sin angle) 0.)) + (gl:vertex3 (* r2 (cos angl3)) (* r2 (sin angl3)) width/2) + (gl:vertex3 (* r2 (cos angl3)) (* r2 (sin angl3)) -width/2) + (let ((u (- (* r1 (cos angl4)) (* r2 (cos angl3)))) + (v (- (* r1 (sin angl4)) (* r2 (sin angl3))))) + (gl:normal (flo:3d v (- u) 0.))) + (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) width/2) + (gl:vertex3 (* r1 (cos angl4)) (* r1 (sin angl4)) -width/2) + (gl:normal (flo:3d (cos angle) (sin angle) 0.))))) + (gl:vertex3 (* r1 (cos 0.)) (* r1 (sin 0.)) width/2) + (gl:vertex3 (* r1 (cos 0.)) (* r1 (sin 0.)) -width/2) + (gl:end) + + (gl:shade-model 'SMOOTH) + + ;; draw inside radius cylinder + (gl:begin 'QUAD-STRIP) + (do ((i 0. (+ i 1.))) + ((> i teeth)) + (let ((angle (* i 2pi/teeth))) + (gl:normal (flo:3d (- (cos angle)) (- (sin angle)) 0.)) + (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) -width/2) + (gl:vertex3 (* r0 (cos angle)) (* r0 (sin angle)) width/2))) + (gl:end))))) + +(define-integrable (gl:vertex3 x y z) + (let ((v (flo:vector-cons 3))) + (flo:vector-set! v 0 x) + (flo:vector-set! v 1 y) + (flo:vector-set! v 2 z) + (gl:vertex v))) + +(define (draw) + (gl:clear 'COLOR-BUFFER 'DEPTH-BUFFER) + (gl:push-matrix) + (gl:rotate view-rotx 1. 0. 0.) + (gl:rotate view-roty 0. 1. 0.) + (gl:rotate view-rotz 0. 0. 1.) + + (gl:push-matrix) + (gl:translate -3. -2. 0.) + (gl:rotate angle 0. 0. 1.) + (gl:call-list gear1) + (gl:pop-matrix) + + (gl:push-matrix) + (gl:translate 3.1 -2. 0.) + (gl:rotate (- (* -2.0 angle) 9.) 0. 0. 1.) + (gl:call-list gear2) + (gl:pop-matrix) + + (gl:push-matrix) + (gl:translate -3.1 4.2 0.) + (gl:rotate (- (* -2.0 angle) 25.) 0. 0. 1.) + (gl:call-list gear3) + (gl:pop-matrix) + + (gl:pop-matrix)) + +(define (draw-gears) + (if stereo + (begin + ;; First left eye. + (gl:draw-buffer 'BACK-LEFT) + + (gl:matrix-mode 'PROJECTION) + (gl:load-identity) + (gl:frustum left right (- asp) asp 5. 60.) + + (gl:matrix-mode 'MODELVIEW) + + (gl:push-matrix) + (gl:translate (* .5 eyesep) 0. 0.) + (draw) + (gl:pop-matrix) + + ;; Then right eye. + (gl:draw-buffer 'BACK-RIGHT) + + (gl:matrix-mode 'PROJECTION) + (gl:load-identity) + (gl:frustum (- right) (- left) (- asp) asp 5. 60.) + + (gl:matrix-mode 'MODELVIEW) + + (gl:push-matrix) + (gl:translate (* -.5 eyesep) 0. 0.) + (draw) + (gl:pop-matrix)) + (begin + (draw)))) + +;; Draw single frame, do SwapBuffers, compute FPS +(define draw-frame + (let ((frames 0) + (tRot0 #f) + (tRate0 #f)) + (named-lambda (draw-frame dpy win) + (%trace ";draw-frame\n") + (let ((t (real-time-clock))) + (if (not tRot0) + (set! tRot0 t)) + (let ((dt (internal-time/ticks->seconds (- t tRot0)))) + (set! tRot0 t) + (if animate + (begin + ;; advance rotation for next frame + (set! angle (+ angle (* 70.0 dt))) ; 70 degrees per second + (if (> angle 3600.0) + (set! angle (- angle 3600.0)))))) + (draw-gears) + (C-call "glXSwapBuffers" dpy win) + (gl:flush) + (set! frames (1+ frames)) + + (if (not tRate0) + (set! tRate0 t)) + + (let ((seconds (internal-time/ticks->seconds (fix:- t tRate0)))) + (if (>= seconds 5.0) + (let ((fps (/ frames seconds))) + (for-each display + (list frames" frames" + " in "(%3.1f seconds)" seconds" + " = "(%6.3f fps)" FPS\n")) + (set! tRate0 t) + (set! frames 0)))))))) + +(define (%3.1f n) + (number->string (/ (round (* 10. n)) 10.))) + +(define (%6.3f n) + (number->string (/ (round (* 1000. n)) 1000.))) + +;; new window size or exposure +(define (reshape width height) + (%trace ";reshape "width" "height"\n") + (gl:viewport 0 0 width height) + (let ((widthf (->flonum width)) + (heightf (->flonum height))) + + (if stereo + (let ((w (* fix-point (/ 1. 5.)))) + (set! asp (/ heightf widthf)) + (set! left (* -5. (/ (- w (* .5 eyesep)) fix-point))) + (set! right (* 5. (/ (+ w (* .5 eyesep)) fix-point)))) + (let ((h (/ heightf widthf))) + (gl:matrix-mode 'PROJECTION) + (gl:load-identity) + (gl:frustum -1. 1. (- h) h 5. 60.))) + + (gl:matrix-mode 'MODELVIEW) + (gl:load-identity) + (gl:translate 0. 0. -40.))) + +(define (init) + (%trace ";init\n") + (let ((pos (flo:4d 5.0 5.0 10.0 0.0)) + (red (color 0.8 0.1 0.0 1.0)) + (green (color 0.0 0.8 0.2 1.0)) + (blue (color 0.2 0.2 1.0 1.0))) + (%trace ";light\n") + (gl:light 'LIGHT0 'POSITION pos) + (gl:enable 'CULL-FACE) + (gl:enable 'LIGHTING) + (gl:enable 'LIGHT0) + (gl:enable 'DEPTH-TEST) + + ;; make the gears + (set! gear1 (gl:gen-lists 1)) + (%trace ";gear1 => "gear1"\n") + (gl:new-list gear1 'COMPILE) + (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE red) + (draw-gear 1.0 4.0 1.0 20. 0.7) + (gl:end-list) + + (set! gear2 (gl:gen-lists 1)) + (%trace ";gear2 => "gear2"\n") + (gl:new-list gear2 'COMPILE) + (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE green) + (draw-gear 0.5 2.0 2.0 10. 0.7) + (gl:end-list) + + (set! gear3 (gl:gen-lists 1)) + (%trace ";gear3 => "gear3"\n") + (gl:new-list gear3 'COMPILE) + (gl:material 'FRONT 'AMBIENT-AND-DIFFUSE blue) + (draw-gear 1.3 2.0 0.5 10. 0.7) + (gl:end-list) + + (gl:enable 'NORMALIZE))) + +(define (no-border dpy w) + (declare (ignore dpy w)) + unspecific) +#| + /** + * Remove window border/decorations. + */ + static void + no_border( Display *dpy, Window w) + { + static const unsigned MWM_HINTS_DECORATIONS = (1 << 1); + static const int PROP_MOTIF_WM_HINTS_ELEMENTS = 5; + + typedef struct + { + unsigned long flags; + unsigned long functions; + unsigned long decorations; + long inputMode; + unsigned long status; + } PropMotifWmHints; + + PropMotifWmHints motif_hints; + Atom prop, proptype; + unsigned long flags = 0; + + /* setup the property */ + motif_hints.flags = MWM_HINTS_DECORATIONS; + motif_hints.decorations = flags; + + /* get the atom for the property */ + prop = XInternAtom( dpy, "_MOTIF_WM_HINTS", True ); + if (!prop) { + /* something went wrong! */ + return; + } + + /* not sure this is correct, seems to work, XA_WM_HINTS didn't work */ + proptype = prop; + + XChangeProperty( dpy, w, /* display, window */ + prop, proptype, /* property, type */ + 32, /* format: 32-bit datums */ + PropModeReplace, /* mode */ + (unsigned char *) &motif_hints, /* data */ + PROP_MOTIF_WM_HINTS_ELEMENTS /* nelements */ + ); + } +|# + +(define (make-window dpy name geometry) + (%trace ";make-window "dpy" "name" "geometry"\n") + ;; Create an RGB, double-buffered window. + ;; Return the window and context handles. + + (let* ((attribs (make-attribs + `( + ;; Singleton attributes. + ,(C-enum "GLX_RGBA") + ,(C-enum "GLX_DOUBLEBUFFER") + ,@(if stereo (list (C-enum "GLX_STEREO")) '()) + + ;; Key/value attributes. + ,(C-enum "GLX_RED_SIZE") 1 + ,(C-enum "GLX_GREEN_SIZE") 1 + ,(C-enum "GLX_BLUE_SIZE") 1 + ,(C-enum "GLX_DEPTH_SIZE") 1 + ,@(if (> samples 0) + (list (C-enum "GLX_SAMPLE_BUFFERS") 1 + (C-enum "GLX_SAMPLES") samples) + '()) + ,(C-enum "None")))) + (scrnum (C-call "DefaultScreen" dpy)) + (root (C-call "RootWindow" dpy scrnum)) + (visinfo (C-call "glXChooseVisual" (make-alien '|XVisualInfo|) + dpy scrnum attribs))) + (if (alien-null? visinfo) + (error (string-append + "couldn't get an RGB, Double-buffered" + (if stereo ", Stereo" "") + (if (> samples 0) ", Multisample" "") + " visual\n"))) + (%trace ";glXChooseVisual => "visinfo"\n") + (free attribs) + + ;; window attributes + (let ((attr (malloc (C-sizeof "XSetWindowAttributes") + '|XSetWindowAttibutes|))) + (C->= attr "XSetWindowAttributes background_pixel" 0) + (C->= attr "XSetWindowAttributes border_pixel" 0) + (let ((colormap (C-call "XCreateColormap" dpy root + (C-> visinfo "XVisualInfo visual") + (C-enum "AllocNone")))) + (%trace ";XCreateColormap => "colormap"\n") + (C->= attr "XSetWindowAttributes colormap" colormap)) + (C->= attr "XSetWindowAttributes event_mask" + (bit-ior (C-enum "StructureNotifyMask") + (C-enum "ExposureMask") + (C-enum "KeyPressMask"))) + ;; XXX this is a bad way to get a borderless window! + (let* ((mask (bit-ior (C-enum "CWBackPixel") + (C-enum "CWBorderPixel") + (C-enum "CWColormap") + (C-enum "CWEventMask"))) + (win (C-call "XCreateWindow" dpy root + (vector-ref geometry 0) ;x + (vector-ref geometry 1) ;y + (vector-ref geometry 2) ;width + (vector-ref geometry 3) ;height + 0 ;pixmap + (C-> visinfo "XVisualInfo depth") + (C-enum "InputOutput") ;type + (C-> visinfo "XVisualInfo visual") + mask ;valuemask + attr))) + (%trace ";XCreateWindow => "win"\n") + (free attr) + (if fullscreen + (no-border dpy win)) + + ;; set hints and properties + (let ((hints (malloc (C-sizeof "XSizeHints") '|XSizeHints|))) + (C->= hints "XSizeHints x" (vector-ref geometry 0)) + (C->= hints "XSizeHints y" (vector-ref geometry 1)) + (C->= hints "XSizeHints width" (vector-ref geometry 2)) + (C->= hints "XSizeHints height" (vector-ref geometry 3)) + (C->= hints "XSizeHints flags" (bit-ior (C-enum "USSize") + (C-enum "USPosition"))) + (C-call "XSetNormalHints" dpy win hints) + (C-call "XSetStandardProperties" + dpy win name name (C-enum "None") 0 0 hints) + (%trace ";XSetNormalHints\n") + (free hints)) + + (%trace ";glXCreateContext\n") + (let ((ctx (C-call "glXCreateContext" (make-alien '|GLXContext|) + dpy visinfo 0 (C-enum "True")))) + (if (alien-null? ctx) + (error "glXCreateContext failed")) + + (%trace ";glXCreateContext => "ctx"\n") + (C-call "XFree" visinfo) + + (cons win ctx)))))) + +(define (make-attribs attribs) + (let* ((len (length attribs)) + (alien (malloc (fix:* len (C-sizeof "int")) '|int|))) + (do ((attribs attribs (cdr attribs)) + (i 0 (fix:1+ i))) + ((fix:= i len)) + (let ((attrib (car attribs))) + (guarantee-integer attrib 'make-attribs) + (c-poke-int alien (fix:* i (C-sizeof "int")) attrib))) + alien)) + +(define (query-vsync dpy win) + (declare (ignore dpy win)) + unspecific) +#| + /** + * Determine whether or not a GLX extension is supported. + */ + static int + is_glx_extension_supported(Display *dpy, const char *query) + { + const int scrnum = DefaultScreen(dpy); + const char *glx_extensions = NULL; + const size_t len = strlen(query); + const char *ptr; + + if (glx_extensions == NULL) { + glx_extensions = glXQueryExtensionsString(dpy, scrnum); + } + + ptr = strstr(glx_extensions, query); + return ((ptr != NULL) && ((ptr[len] == ' ') || (ptr[len] == '\0'))); + } + + + /** + * Attempt to determine whether or not the display is synched to vblank. + */ + static void + query_vsync(Display *dpy, GLXDrawable drawable) + { + int interval = 0; + + #if defined(GLX_EXT_swap_control) + if (is_glx_extension_supported(dpy, "GLX_EXT_swap_control")) { + unsigned int tmp = -1; + glXQueryDrawable(dpy, drawable, GLX_SWAP_INTERVAL_EXT, &tmp); + interval = tmp; + } else + #endif + if (is_glx_extension_supported(dpy, "GLX_MESA_swap_control")) { + PFNGLXGETSWAPINTERVALMESAPROC pglXGetSwapIntervalMESA = + (PFNGLXGETSWAPINTERVALMESAPROC) + glXGetProcAddressARB((const GLubyte *) "glXGetSwapIntervalMESA"); + + interval = (*pglXGetSwapIntervalMESA)(); + } else if (is_glx_extension_supported(dpy, "GLX_SGI_swap_control")) { + /* The default swap interval with this extension is 1. Assume that it + * is set to the default. + * + * Many Mesa-based drivers default to 0, but all of these drivers also + * export GLX_MESA_swap_control. In that case, this branch will never + * be taken, and the correct result should be reported. + */ + interval = 1; + } + + + if (interval > 0) { + printf("Running synchronized to the vertical refresh. The framerate should be\n"); + if (interval == 1) { + printf("approximately the same as the monitor refresh rate.\n"); + } else if (interval > 1) { + printf("approximately 1/%d the monitor refresh rate.\n", + interval); + } + } + } +|# + +(define (handle-event dpy win event) + (declare (ignore dpy win)) + ;; Handle one X event. + ;; \return NOP, EXIT or DRAW + + (let ((type (C-> event "XEvent type"))) + (cond ((int:= type (C-enum "Expose")) + (%trace ";handle-event Expose\n") + 'DRAW) + ((int:= type (C-enum "ConfigureNotify")) + (%trace ";handle-event ConfigureNotify\n") + (reshape (C-> event "XConfigureEvent width") + (C-> event "XConfigureEvent height")) + 'DRAW) + ((int:= type (C-enum "KeyPress")) + (%trace ";handle-event KeyPress\n") + (let ((code (C-call "XLookupKeysym" event 0))) + (cond ((int:= code (C-enum "XK_Left")) + (set! view-roty (+ view-roty 5.)) + 'DRAW) + ((int:= code (C-enum "XK_Right")) + (set! view-roty (- view-roty 5.)) + 'DRAW) + ((int:= code (C-enum "XK_Up")) + (set! view-rotx (+ view-rotx 5.)) + 'DRAW) + ((int:= code (C-enum "XK_Down")) + (set! view-rotx (- view-rotx 5.)) + 'DRAW) + (else + (let ((buffer (malloc 10 'char))) + (C-call "XLookupString" event buffer 10 0 0) + (let ((buffer0 (C-> buffer "char"))) + (free buffer) + (cond ((= buffer0 27) + ;; escape + 'EXIT) + ((or (= buffer0 (char->ascii #\a)) + (= buffer0 (char->ascii #\A))) + (set! animate (not animate)) + 'DRAW) + (else 'DRAW)))))))) + (else + (%trace ";handle-event "type"\n") + 'NOP)))) + +(define (event-loop dpy win) + (%trace ";event-loop\n") + (let while-loop () + (let ((op + (let while-loop () + (if (or (not animate) (> (C-call "XPending" dpy) 0)) + (let ((event (malloc (C-sizeof "XEvent") '|XEvent|))) + (C-call "XNextEvent" dpy event) + (let ((op (handle-event dpy win event))) + (%trace ";handle-event => "op"\n") + (free event) + (if (memq op '(EXIT DRAW)) + op + (while-loop)))))))) + (if (eq? op 'EXIT) + 'EXIT + (begin + (draw-frame dpy win) + (while-loop)))))) + +(define (usage-error . msg) + (display "Usage:\n") + (display " -display set the display to run on\n") + (display " -stereo run in stereo mode\n") + (display " -samples N run in multisample mode with at least N samples\n") + (display " -fullscreen run in fullscreen mode\n") + (display " -info display OpenGL renderer info\n") + (display " -geometry WxH+X+Y window geometry\n") + (apply error msg)) + +(define (main) - (let* ((commandline (command-line)) - (printInfo (member "-info" commandline))) - (set! stereo (member "-stereo" commandline)) - (set! samples (let ((entry (member "-samples" commandline))) ++ (let* ((args (command-line-arguments)) ++ (printInfo (member "-info" args))) ++ (set! stereo (member "-stereo" args)) ++ (set! samples (let ((entry (member "-samples" args))) + (if (pair? entry) + (if (pair? (cdr entry)) + (let ((num (cadr entry))) + (or (number->string num) + (usage-error "Samples not a number:" num))) + (usage-error "Number of samples not specified.")) + 0))) - (set! fullscreen (member "-fullscreen" commandline)) ++ (set! fullscreen (member "-fullscreen" args)) + (let* ((geometry - (let ((entry (member "-geometry" commandline))) ++ (let ((entry (member "-geometry" args))) + (if (pair? entry) + (if (pair? (cdr entry)) + (let* ((string (cadr entry)) + (results (malloc (fix:* 4 (C-sizeof "int")) #f)) + (x (C-array-loc results "int" 0)) + (y (C-array-loc results "int" 1)) + (width (C-array-loc results "int" 2)) + (height (C-array-loc results "int" 3)) + (result + (C-call "XParseGeometry" + string x y width height)) + (v (vector + (if (bit? result (C-enum "XValue")) + (C-> x "int") 0) + (if (bit? result (C-enum "YValue")) + (C-> y "int") 0) + (if (bit? result (C-enum "WidthValue")) + (C-> width "uint") 300) + (if (bit? result (C-enum "HeightValue")) + (C-> height "uint") 300)))) + (free results) + v) + (usage-error "Geometry not specified.")) + (vector 0 0 300 300)))) + (dpyName - (let ((entry (member "-display" commandline))) ++ (let ((entry (member "-display" args))) + (if (pair? entry) + (if (pair? (cdr entry)) + (cadr entry) + (error "Display not specified.")) + 0))) + (dpy (C-call "XOpenDisplay" (make-alien '|Display|) + (if (string? dpyName) (string->utf8 dpyName) 0)))) + (if (alien-null? dpy) + (error "couldn't open display:" (if (string? dpyName) dpyName ""))) + + (if fullscreen + (let ((scrnum (C-call "DefaultScreen" dpy))) + (vector-set! geometry 0 0) + (vector-set! geometry 1 0) + (vector-set! geometry 2 (C-call "DisplayWidth" dpy scrnum)) + (vector-set! geometry 3 (C-call "DisplayHeight" dpy scrnum)))) + + (let* ((win.ctx (make-window dpy "glxgears" geometry)) + (win (car win.ctx)) + (ctx (cdr win.ctx))) + (%trace ";XMapWindow\n") + (C-call "XMapWindow" dpy win) + + (with-gl-context + (lambda () + (%trace ";glXMakeCurrent\n") + (C-call "glXMakeCurrent" dpy win ctx) + (query-vsync dpy win) + + (if printInfo + (for-each + display + (list "GL_RENDERER = "(get-string 'RENDERER)"\n" + "GL_VERSION = "(get-string 'VERSION)"\n" + "GL_VENDOR = "(get-string 'VENDOR)"\n" + "GL_EXTENSIONS = "(get-string 'EXTENSIONS)"\n"))) + + (init) + + ;; Set initial projection/viewing transformation. + ;; We can't be sure we'll get a ConfigureNotify event when the + ;; window first appears. + (reshape (vector-ref geometry 2) (vector-ref geometry 3)) + + (event-loop dpy win) + + (gl:delete-lists gear1 1) + (gl:delete-lists gear2 1) + (gl:delete-lists gear3 1) + (C-call "glXMakeCurrent" dpy (C-enum "None") 0))) + + (C-call "glXDestroyContext" dpy ctx) + (C-call "XDestroyWindow" dpy win) + (C-call "XCloseDisplay" dpy))))) + +(define-integrable 2pi (* 8. (flo:atan2 1. 1.))) + +(define (flo:3d x y z) + (let ((v (flo:vector-cons 3))) + (flo:vector-set! v 0 x) + (flo:vector-set! v 1 y) + (flo:vector-set! v 2 z) + v)) + +(define (flo:4d r g b a) + (let ((v (flo:vector-cons 4))) + (flo:vector-set! v 0 r) + (flo:vector-set! v 1 g) + (flo:vector-set! v 2 b) + (flo:vector-set! v 3 a) + v)) + +(define-integrable color flo:4d) + +(define-integrable (bit? int mask) + (not (int:zero? (bitwise-and int mask)))) + +(declare (integrate-operator bit-ior)) +(define (bit-ior . ints) + (reduce bitwise-ior 0 ints)) + +(define c-poke-int (make-primitive-procedure 'C-POKE-INT 3)) + +(define (get-string symbol) + (utf8->string + (c-peek-cstring + (case symbol + ((renderer) + (C-call "glGetString" (make-alien 'char) (C-enum "GL_RENDERER"))) + ((version) + (C-call "glGetString" (make-alien 'char) (C-enum "GL_VERSION"))) + ((vendor) + (C-call "glGetString" (make-alien 'char) (C-enum "GL_VENDOR"))) + ((extensions) + (C-call "glGetString" (make-alien 'char) (C-enum "GL_EXTENSIONS"))) + (else + (error "Unknown gl String:" symbol)))))) + +(define %trace? #f) + +(define-syntax %trace + (syntax-rules () + ((_ ARGS ...) + (if %trace? (display ARGS ...))))) diff --cc src/gl/tags-fix.sh index c2823ad7f,000000000..aee615c48 mode 100755,000000..100755 --- a/src/gl/tags-fix.sh +++ b/src/gl/tags-fix.sh @@@ -1,42 -1,0 +1,42 @@@ +#!/bin/sh +# -*-Scheme-*- +# +# Chop the generated $1-shim.c and $1-const.c files out of TAGS. + +set -e +: ${MIT_SCHEME_EXE=mit-scheme} +${MIT_SCHEME_EXE} --batch-mode -- "${@}" <<\EOF - (let ((name (car (command-line)))) ++(let ((name (car (command-line-arguments)))) + (let ((shim.c-prefix (string-append name "-shim.c,")) + (const.c-prefix (string-append name "-const.c,"))) + + (define (rewriter in out) + (let loop ((skipping? #f)) + (let ((line (read-line in))) + (cond ((eof-object? line) + unspecific) + ((string=? line "\f") + (let ((next (read-line in))) + (cond ((eof-object? next) (error "Bogus TAGS format:" next)) + ((or (string-prefix? shim.c-prefix next) + (string-prefix? const.c-prefix next)) + (loop #t)) + (else + (write-string line out) + (newline out) + (write-string next out) + (newline out) + (loop #f))))) + (skipping? + (loop skipping?)) + (else + (write-string line out) + (newline out) + (loop skipping?)))))) + + (parameterize ((param:suppress-loading-message? #t)) + (load-option 'FFI)) + ((access rewrite-file (->environment '(ffi build))) + (merge-pathnames "TAGS") + rewriter))) +EOF diff --cc src/glib/glib.pkg index 2c818c75a,000000000..fc1d89f4d mode 100644,000000..100644 --- a/src/glib/glib.pkg +++ b/src/glib/glib.pkg @@@ -1,131 -1,0 +1,128 @@@ +#| -*-Scheme-*- + +Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, + 2016, 2017 Matthew Birkholz + +This file is part of a GLib plugin for MIT/GNU Scheme Pucked. + +This plugin is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This plugin is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this plugin; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. + +|# + +;;;; Glib System Packaging + +(global-definitions runtime/) +(global-definitions sos/) + +(define-package (glib) + (parent ())) + +(define-package (glib internal) + (parent (glib)) + (files "glib") + (import (runtime thread) + get-thread-event-block) + (export (glib) + with-glib-lock without-glib-lock + assert-glib-locked assert-without-interruption + add-glib-cleanup execute-glib-cleanup)) + +(define-package (gobject) + (parent (glib internal)) + (files "gobject") + ;;(depends-on "glib.bin" "glib") + (export (glib) + gobject-alien + gobject-live? gobject-unref! + g-signal-connect g-signal-disconnect + gobject-get-property gobject-set-properties + gquark-from-string gquark-to-string)) + +(define-package (gio) + (parent (glib internal)) + (files "gio") + ;;(depends-on "glib.bin" "glib") + (import (runtime ffi) + %set-alien/address!) + (import (runtime generic-i/o-port) + make-generic-i/o-port) + (import (runtime binary-port) + make-binary-port) ++ (import (runtime) ++ make-non-channel-input-source ++ make-non-channel-output-sink) + (import (glib main) + maybe-yield-glib) + (export () + open-input-gfile + open-output-gfile + gdirectory-read) + (export (glib) + + + g-input-stream-read + g-input-stream-skip + g-input-stream-close + + g-output-stream-write + g-output-stream-flush + g-output-stream-close + + gfile-read + + gfile-append-to + gfile-create + gfile-replace + + gfile-query-info + gfile-info-list-attributes + gfile-info-get-attribute-status + gfile-info-get-attribute-value + + gfile-enumerate-children + gfile-enumerator-next-files + gfile-enumerator-close + + make-gfile)) + +(define-package (glib main) + (parent (glib internal)) + (files "glib-main") + ;;(depends-on "glib.bin" "glib") - (import (runtime load) - *unused-command-line* - hook/process-command-line - default/process-command-line) - (import (runtime) - ucode-primitive) + (import (glib thread) + create-glib-thread exit-glib-thread) + (export () + glib-select-trace? + glib-select-trace!)) + +(define-package (glib thread) + (parent (runtime thread)) + (files "glib-thread") + ;;(depends-on "glib-main") + (export () + stop-glib-thread) + (import (glib internal) + with-glib-lock + assert-glib-locked + run-glib-cleanups + run-glib-daemons) + (import (glib main) + run-glib) + #;(import (runtime thread) + account-for-times + get-system-times + record-start-times!) + (import (runtime primitive-io) + select-registry-handle)) diff --cc src/glib/gobject.scm index 780f84f1e,000000000..75d9c46af mode 100644,000000..100644 --- a/src/glib/gobject.scm +++ b/src/glib/gobject.scm @@@ -1,441 -1,0 +1,441 @@@ +#| -*-Scheme-*- + +Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, + 2016, 2017 Matthew Birkholz + +This file is part of a GLib plugin for MIT/GNU Scheme Pucked. + +This plugin is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This plugin is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this plugin; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. + +|# + +;;;; GObjects +;;; package: (glib gobject) + +(C-include "glib") + +(define-class () + + ;; The address of the toolkit object. A null alien if the GObject + ;; has not been created (yet), or has been unrefed. + (alien define accessor + initializer (lambda () (make-alien '|GObject|))) + + ;; A pair, shared with cleanup thunks. The cdr of this + ;; pair is the alist associating signal names with Scheme callback + ;; IDs and toolkit handles. In this alist, a callback ID will be #f + ;; if the signal was disconnected. + (signals define standard + initializer (lambda () (list 'GOBJECT-SIGNALS))) + + ;; This instance's weak-pair on the glib-cleanups list. This is + ;; cached here mainly for g-signal-connect, which must create + ;; callbacks that only weakly reference this instance. + (weak-self define standard)) + +(define-guarantee gobject "a ") + +(define-integrable (gobject-live? object) + (not (alien-null? (gobject-alien object)))) + +(define-method initialize-instance ((object )) + (call-next-method object) + (set-gobject-weak-self! + object (add-glib-cleanup object (make-gobject-cleanup + (gobject-alien object) + (gobject-signals object))))) + +(define (make-gobject-cleanup alien signals) + ;; This separate procedure ensures that the gobject is not caught in + ;; the closure. + (named-lambda (gobject-cleanup) + (%trace ";gobject-cleanup "alien"\n") + (assert-glib-locked 'gobject-cleanup) + (if (not (alien-null? alien)) + (begin + (for-each + (lambda (name.id.handle) (disconnect!? alien (cdr name.id.handle))) + (cdr signals)) + (C-call "g_object_unref" alien) + (alien-null! alien))) + (%trace ";gobject-cleanup done with "alien"\n"))) + +(define (gobject-unref! object) + (assert-glib-locked 'gobject-unref!) + (without-interruption + (lambda () + (execute-glib-cleanup object)))) + +(define (g-signal-connect gobject alien-function callback + #!optional signal-name) + ;; Specify SIGNAL-NAME if it is not the same as ALIEN-FUNCTION's name. + (guarantee-gobject gobject 'g-signal-connect) + (guarantee-alien-function alien-function 'g-signal-connect) + (assert-glib-locked 'g-signal-connect) + (let ((name (cond ((default-object? signal-name) + (string->symbol (alien-function/name alien-function))) + ((symbol? signal-name) signal-name) + ((string? signal-name) (string->symbol signal-name)) + (else + (error:wrong-type-argument + signal-name "string or symbol" 'g-signal-connect))))) + (without-interruption + (lambda () + (let* ((alien (gobject-alien gobject)) + (signals (gobject-signals gobject)) + (name.id.handle + (or (assq name (cdr signals)) + (let ((entry (cons* name #f #f))) + (set-cdr! signals (cons entry (cdr signals))) + entry)))) + (disconnect!? alien (cdr name.id.handle)) + (connect! alien name.id.handle + alien-function + (register-c-callback + (make-gobject-signal-callback + name (gobject-weak-self gobject) callback)))))))) + +(define (make-gobject-signal-callback name weak-pair callback) + (named-lambda (gobject-signal-callback instance . args) + ;; Callbacks run without-interrupts. + (if (weak-pair/car? weak-pair) + (let ((gobject (weak-car weak-pair))) + (if (not (alien=? (gobject-alien gobject) instance)) + (warn "Signal instance / gobject mismatch:" instance gobject)) + (apply callback gobject args)) + (error "Cannot signal a that is already GC'ed:" name args)))) + +(define (connect! alien name.id.handle alien-function newid) + (let ((id.handle (cdr name.id.handle))) + (set-car! id.handle newid) + (set-cdr! id.handle + (C-call "g_signal_connect_data" alien + (string->utf8 (symbol->string (car name.id.handle))) + alien-function newid 0 0)))) + +(define (g-signal-disconnect gobject name) + (guarantee-gobject gobject 'g-signal-disconnect) + (guarantee symbol? name 'g-signal-disconnect) + (assert-glib-locked 'g-signal-disconnect) + (without-interruption + (lambda () + (let* ((alien (gobject-alien gobject)) + (signals (gobject-signals gobject)) + (name.id.handle (assq name (cdr signals)))) + (if (not name.id.handle) + (warn "No signal to disconnect:" name gobject) + (if (not (disconnect!? alien (cdr name.id.handle))) + (warn "Signal already disconnected:" name gobject))))))) + +(define (disconnect!? alien id.handle) + (if (eq? (car id.handle) #f) + #f + (begin + (C-call "g_signal_handler_disconnect" alien (cdr id.handle)) + (de-register-c-callback (car id.handle)) + (set-car! id.handle #f) + #t))) + + +;;; Properties + +(define (gobject-get-property gobject property) + (guarantee-gobject gobject 'gobject-get-property) + (assert-glib-locked 'gobject-get-property) + + (let ((name (check-prop-name property)) + (gvalue (malloc (C-sizeof "GValue") '|GValue|))) + + (define (unimplemented type) + (error "Unimplemented property type:" type name gobject)) + + (C-call "g_object_get_property" (gobject-alien gobject) + (string->utf8 name) gvalue) + (let* ((type (C-> gvalue "GValue g_type")) + (value + (cond + ((int:= type (C-enum "G_TYPE_INVALID")) + (error "Invalid property:" name gobject)) + ((int:= type (C-enum "G_TYPE_NONE")) + (error "Void property:" name gobject)) + ((int:= type (C-enum "G_TYPE_INTERFACE")) + (unimplemented "an interface")) + ((int:= type (C-enum "G_TYPE_CHAR")) + (C-call "g_value_get_schar" gvalue)) + ((int:= type (C-enum "G_TYPE_UCHAR")) + (C-call "g_value_get_uchar" gvalue)) + ((int:= type (C-enum "G_TYPE_BOOLEAN")) + (C-call "g_value_get_boolean" gvalue)) + ((int:= type (C-enum "G_TYPE_INT")) + (C-call "g_value_get_int" gvalue)) + ((int:= type (C-enum "G_TYPE_UINT")) + (C-call "g_value_get_uint" gvalue)) + ((int:= type (C-enum "G_TYPE_LONG")) + (C-call "g_value_get_long" gvalue)) + ((int:= type (C-enum "G_TYPE_ULONG")) + (C-call "g_value_get_ulong" gvalue)) +; ((int:= type (C-enum "G_TYPE_INT64")) +; (C-call "g_value_get_int64" gvalue)) +; ((int:= type (C-enum "G_TYPE_UINT64")) +; (C-call "g_value_get_uint64" gvalue)) + ((int:= type (C-enum "G_TYPE_ENUM")) + (C-call "g_value_get_enum" gvalue)) + ((int:= type (C-enum "G_TYPE_FLAGS")) + (C-call "g_value_get_flags" gvalue)) + ((int:= type (C-enum "G_TYPE_FLOAT")) + (C-call "g_value_get_float" gvalue)) + ((int:= type (C-enum "G_TYPE_DOUBLE")) + (C-call "g_value_get_double" gvalue)) + ((int:= type (C-enum "G_TYPE_STRING")) + (let ((alien (make-alien '(const (* |gchar|))))) + (C-call "g_value_get_string" alien gvalue) + (let ((str (c-peek-cstring alien))) + (free alien) + str))) + ((int:= type (C-enum "G_TYPE_POINTER")) + (let ((alien (make-alien '|gpointer|))) + (C-call "g_value_get_pointer" alien gvalue) + alien)) + ((int:= type (C-enum "G_TYPE_BOXED")) (unimplemented "a boxed")) + ((int:= type (C-enum "G_TYPE_PARAM")) (unimplemented "a param")) + ((int:= type (C-enum "G_TYPE_OBJECT")) + (let ((alien (make-alien '|GObject|))) + (C-call "g_value_get_object" alien gvalue) + alien)) + (else + (error "Unexpected GFundamentalType:" type))))) + (free gvalue) + value))) + +(define (gobject-set-properties gobject . property-list) + (assert-glib-locked 'gobject-set-properties) + (let* ((gobject-alien (gobject-alien gobject)) + (gvalue (malloc (C-sizeof "GValue") '|GValue|)) + (pspec (malloc (C-sizeof "GParamSpec") '|GParamSpec|)) + (gtype (malloc (C-sizeof "GType") '|GType|)) + (gclass (gobject-get-gclass gobject-alien)) + (gclass-name (gclass-get-name gclass))) + (let loop ((plist property-list)) + (cond ((null? plist) unspecific) + ((not (and (pair? plist) (pair? (cdr plist)))) + (error "Odd length property list:" property-list)) + (else + (let ((name (check-prop-name (car plist))) + (value (cadr plist))) + (C-call "g_object_class_find_property" + pspec gclass (string->utf8 name)) + (if (alien-null? pspec) + (error "No property:" name gclass-name)) + (let ((flags (C-> pspec "GParamSpec flags"))) + (if (flag-set? flags (C-enum "G_PARAM_WRITABLE")) + (error "Property not writable:" name gclass-name)) + (if (not (flag-set? flags (C-enum "G_PARAM_CONSTRUCT_ONLY"))) + (error "Property not writable outside constructor:" + name gclass-name)) + (C-call "G_PARAM_SPEC_VALUE_TYPE" gtype pspec) + (C-call "g_value_init" gvalue gtype) + ;; g_value_set_* gvalue * + (let ((fundamental (C-call "G_TYPE_FUNDAMENTAL" gtype))) + (cond + ((int:= fundamental (C-enum "G_TYPE_CHAR")) + (C-call "g_value_set_schar" + gvalue (check-prop-char value name))) + ((int:= fundamental (C-enum "G_TYPE_UCHAR")) + (C-call "g_value_set_uchar" + gvalue (check-prop-uchar value name))) + ((int:= fundamental (C-enum "G_TYPE_INT")) + (C-call "g_value_set_int" + gvalue (check-prop-int value name))) + ((int:= fundamental (C-enum "G_TYPE_UINT")) + (C-call "g_value_set_uint" + gvalue (check-prop-uint value name))) +; (((C-enum "G_TYPE_LONG")) +; (C-call "g_value_set_long" +; gvalue (check-prop-long value name))) +; (((C-enum "G_TYPE_ULONG")) +; (C-call "g_value_set_ulong" +; gvalue (check-prop-ulong value name))) + ((int:= fundamental (C-enum "G_TYPE_FLOAT")) + (C-call "g_value_set_float" + gvalue (check-prop-flonum value name))) + ((int:= fundamental (C-enum "G_TYPE_DOUBLE")) + (C-call "g_value_set_double" + gvalue (check-prop-flonum value name))) + ((int:= fundamental (C-enum "G_TYPE_STRING")) + (C-call "g_value_set_string" + gvalue (check-prop-string value name))) + ((int:= fundamental (C-enum "G_TYPE_BOOLEAN")) + (C-call "g_value_set_boolean" + gvalue (check-prop-boolean value name))) + ((int:= fundamental (C-enum "G_TYPE_ENUM")) + (C-call "g_value_set_enum" + gvalue (check-prop-enum value name))) + ((int:= fundamental (C-enum "G_TYPE_FLAGS")) + (C-call "g_value_set_flags" + gvalue (check-prop-flags value name))) + ((int:= fundamental (C-enum "G_TYPE_OBJECT")) + (let* ((value-alien + (cond ((gobject? value) (gobject-alien value)) + ((alien? value) value) + (else + (error "Property value not an object:" + value name gclass-name)))) + (value-gtype + (gobject-get-gtype value-alien))) + (if (fix:zero? (C-call "g_value_type_compatible" + value-gtype gtype)) + (error "Property value incompatible:" + value name gclass-name)) + (C-call "g_value_set_object" gvalue value-alien))) + (else + (error "Property type unsupported:" + (or (C-enum "enum GFundamentalType" fundamental) + fundamental) + name gclass-name)))) + (C-call "g_object_set_property" gobject-alien + (string->utf8 name) gvalue) + (C-call "g_value_reset" gvalue))) + (loop (cddr plist))))) + (free gtype) + (free pspec) + (free gvalue)) + unspecific) + +(define (gobject-get-gclass alien) + (assert-glib-locked 'gobject-get-gclass) + (let ((ret (make-alien '|GObjectClass|))) + (C-call "G_OBJECT_GET_CLASS" ret alien) + ret)) + +(define (gclass-get-name gclass) + (assert-glib-locked 'gclass-get-name) + ;; GCLASS should be an alien of type GObjectClass. + (let ((c* (make-alien '(* |gchar|)))) + (C-call "G_OBJECT_CLASS_NAME" c* gclass) + (c-peek-cstring c*))) + +(define (gobject-get-gtype gobject) + (assert-glib-locked 'gobject-get-gtype) + (let ((ret (make-alien '|GType|))) + (C-call "G_OBJECT_TYPE" ret (gobject-alien gobject)) + ret)) + +(define (flag-set? fixnum mask) + (not (fix:zero? (fix:and fixnum mask)))) + +(define (check-prop-name name) + ;; Allows NAME to be a symbol OR string. + (cond ((symbol? name) (symbol->string name)) + ((string? name) name) + (else (check-prop-name + (error "Invalid property name:" name))))) + +(define (check-prop-value value property verb-phrase type-predicate) + (if (type-predicate value) value + (check-prop-value + (error (string-append "Property value must " verb-phrase ":") + value property) + property verb-phrase type-predicate))) + +(define (check-prop-char value name) + (check-prop-value value name "fit in a char" + (lambda (x) (and (fixnum? x) + (fix:<= -128 x) (fix:< x 128))))) + +(define (check-prop-uchar value name) + (check-prop-value value name "fit in an unsigned char" + (lambda (x) (and (fixnum? x) (fix:<= 0 x) (fix:< x 256))))) + +(define (check-prop-int value name) + (check-prop-value value name "fit in an int" + (lambda (x) (and (exact-integer? x) + (int:<= (expt -2 31) x) + (int:< x (expt 2 31)))))) + +(define (uint? x) + (and (exact-integer? x) (int:<= 0 x) (int:< x (expt 2 32)))) + +(define (check-prop-uint value name) + (check-prop-value value name "fit in an unsigned int" uint?)) + +#;(define (check-prop-long value name) + (check-prop-value value name "fit in a long" + (lambda (x) (and (exact-integer? x) + (int:<= (expt -2 63) x) + (int:< x (expt 2 63)))))) + +#;(define (check-prop-ulong value name) + (check-prop-value value name "fit in an unsigned long" + (lambda (x) (and (exact-integer? x) + (int:<= 0 x) + (int:< x (expt 2 64)))))) + +(define (check-prop-flonum value name) + (check-prop-value value name "be a flonum" flo:flonum?)) + +(define (check-prop-string value name) + (check-prop-value value name "be a string" string?)) + +(define (check-prop-boolean value name) + (check-prop-value value name "be a boolean" + (lambda (x) (or (eq? #t x) (eq? #f x))))) + +(define (check-prop-enum value name) + (check-prop-value value name "be an enum" uint?)) + +(define (check-prop-flags value name) + (check-prop-value value name "be a flagset" uint?)) + +(define (check-prop-gobject value name) + (check-prop-value value name "be a gobject" gobject?)) + +;;; GQuarks + +;;; No way (nor need) to GC. Cache them here and toss cache when +;;; restored or reloaded. + +(define gquark-from-string-cache (make-string-hash-table)) + - (define gquark-to-string-cache (make-eqv-hash-table)) ++(define gquark-to-string-cache (make-key-weak-eqv-hash-table)) + +(define (gquark-from-string string) + (assert-glib-locked 'gquark-from-string) - (or (hash-table/get gquark-from-string-cache string #f) ++ (or (hash-table-ref/default gquark-from-string-cache string #f) + (let ((gq (C-call "g_quark_from_string" (string->utf8 string)))) - (hash-table/put! gquark-from-string-cache string gq) - (hash-table/put! gquark-to-string-cache gq string) ++ (hash-table-set! gquark-from-string-cache string gq) ++ (hash-table-set! gquark-to-string-cache gq string) + gq))) + +(define (gquark-to-string gquark) - (or (hash-table/get gquark-to-string-cache gquark #f) ++ (or (hash-table-ref/default gquark-to-string-cache gquark #f) + (error "Unknown GQuark:" gquark))) + +(define (reset-quark-cache!) + (set! gquark-from-string-cache (make-string-hash-table)) - (set! gquark-to-string-cache (make-eqv-hash-table)) ++ (set! gquark-to-string-cache (make-key-weak-eqv-hash-table)) + unspecific) + +(define (initialize-package!) + (add-event-receiver! event:after-restore reset-quark-cache!) + unspecific) + +(define %trace? #f) + +(define-syntax %trace + (syntax-rules () + ((_ ARGS ...) + (if %trace? (outf-error ARGS ...))))) + +(initialize-package!) diff --cc src/glib/tags-fix.sh index c2823ad7f,000000000..aee615c48 mode 100755,000000..100755 --- a/src/glib/tags-fix.sh +++ b/src/glib/tags-fix.sh @@@ -1,42 -1,0 +1,42 @@@ +#!/bin/sh +# -*-Scheme-*- +# +# Chop the generated $1-shim.c and $1-const.c files out of TAGS. + +set -e +: ${MIT_SCHEME_EXE=mit-scheme} +${MIT_SCHEME_EXE} --batch-mode -- "${@}" <<\EOF - (let ((name (car (command-line)))) ++(let ((name (car (command-line-arguments)))) + (let ((shim.c-prefix (string-append name "-shim.c,")) + (const.c-prefix (string-append name "-const.c,"))) + + (define (rewriter in out) + (let loop ((skipping? #f)) + (let ((line (read-line in))) + (cond ((eof-object? line) + unspecific) + ((string=? line "\f") + (let ((next (read-line in))) + (cond ((eof-object? next) (error "Bogus TAGS format:" next)) + ((or (string-prefix? shim.c-prefix next) + (string-prefix? const.c-prefix next)) + (loop #t)) + (else + (write-string line out) + (newline out) + (write-string next out) + (newline out) + (loop #f))))) + (skipping? + (loop skipping?)) + (else + (write-string line out) + (newline out) + (loop skipping?)))))) + + (parameterize ((param:suppress-loading-message? #t)) + (load-option 'FFI)) + ((access rewrite-file (->environment '(ffi build))) + (merge-pathnames "TAGS") + rewriter))) +EOF diff --cc src/gtk/fix-layout.scm index 9f75d7f6a,000000000..a1de3193d mode 100644,000000..100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@@ -1,2014 -1,0 +1,2014 @@@ +#| -*-Scheme-*- + +Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, + 2016, 2017 Matthew Birkholz + +This file is part of a Gtk plugin for MIT/GNU Scheme Pucked. + +This plugin is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This plugin is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this plugin; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. + +|# + +;;;; A fixnum-centric canvas. +;;; package: (gtk fix-layout) + +;;; is the base class that handles the realization of a +;;; widget's GdkWindow. It will allocate/move/resize the GdkWindow +;;; and dispatch events received on it. + +(define-class ( (constructor () (width height bgcolor))) + () + + ;; Our window -- a GdkWindow alien. Until realized, a NULL pointer. + (window define accessor + initializer (lambda () (make-alien '|GdkWindow|))) + (%background-color define standard) + + ;; Our window geometry (allocation) -- a rectangular extent in + ;; fixnum device coordinates (e.g. size in pixels, offset within + ;; parent window [ancestor widget]). + (geometry define accessor initializer (lambda () (make-fix-rect))) + + (event-handlers define accessor initializer + (lambda () (make-vector (C-enum "GDK_EVENT_LAST") #f)))) + +(define-guarantee fix-widget "a ") + +(define-integrable (guarantee-size object operator) + (guarantee non-negative-fixnum? object operator)) + +(define-method initialize-instance ((widget ) width height bgcolor) + (let ((bg (if (null? bgcolor) + '() + (->color bgcolor '(initialize-instance ))))) + (call-next-method widget) + (%trace "; (initialize-instance ) "widget" "width"x"height"\n") + (assert-glib-locked '(initialize-instance )) + (set-scm-widget-natural-size! widget width height) + (set-fix-widget-%background-color! widget bg) + ;; Init. size, for a realize signal arriving before an allocation. + (set-fix-rect-size! (fix-widget-geometry widget) width height) + (let ((gtkwidget (gobject-alien widget))) + (C-call "gtk_widget_set_has_window" gtkwidget 1) + ;;(C-call "gtk_widget_set_app_paintable" gtkwidget 1) + (C-call "gtk_widget_set_events" gtkwidget event-mask)) + + (set-gtk-widget-realize-callback! widget fix-widget-realize-callback) + (set-gtk-widget-unrealize-callback! widget fix-widget-unrealize-callback) + (set-gtk-widget-size-allocate-callback! widget allocate-callback) + (set-gtk-widget-event-callback! widget event-callback))) + +(define-generic fix-widget-realize-callback (widget)) + +(define-method fix-widget-realize-callback ((widget )) + (%trace "; (fix-widget-realize-callback ) "widget"\n") + (assert-glib-locked '(fix-widget-realize-callback )) + (let ((geometry (fix-widget-geometry widget)) + (attr (malloc (C-sizeof "GdkWindowAttr") '|GdkWindowAttr|)) + (main-GdkWindow (fix-widget-window widget)) + (parent-GdkWindow (make-alien '|GdkWindow|)) + (GtkWidget (gobject-alien widget))) + + ;; Create widget window. + (C->= attr "GdkWindowAttr window_type" (C-enum "GDK_WINDOW_CHILD")) + (C->= attr "GdkWindowAttr wclass" (C-enum "GDK_INPUT_OUTPUT")) + (let ((x (fix-rect-x geometry)) + (y (fix-rect-y geometry)) + (width (fix-rect-width geometry)) + (height (fix-rect-height geometry))) + (if x (C->= attr "GdkWindowAttr x" x)) + (if y (C->= attr "GdkWindowAttr y" y)) + (C->= attr "GdkWindowAttr width" width) + (C->= attr "GdkWindowAttr height" height) + (C->= attr "GdkWindowAttr event_mask" event-mask) + + (C-call "gtk_widget_get_parent_window" parent-GdkWindow GtkWidget) + (error-if-null parent-GdkWindow "Could not get parent:" widget) + + (C-call "gdk_window_new" main-GdkWindow parent-GdkWindow attr + (bit-ior (if x (C-enum "GDK_WA_X") 0) + (if y (C-enum "GDK_WA_Y") 0))) + (free attr) + (error-if-null main-GdkWindow "Could not create main window:" widget) + (C-call "gtk_widget_set_window" GtkWidget main-GdkWindow) + (C-call "gtk_widget_register_window" GtkWidget main-GdkWindow) + ;; gtk_widget_unregister_window (as well as gdk_window_destroy) + ;; are called by the default unrealize method. + (%trace "; window: "main-GdkWindow"\n")))) + +(define event-mask + (bit-ior + (C-enum "GDK_ENTER_NOTIFY_MASK") + (C-enum "GDK_LEAVE_NOTIFY_MASK") + (C-enum "GDK_FOCUS_CHANGE_MASK") + (C-enum "GDK_VISIBILITY_NOTIFY_MASK") + (C-enum "GDK_KEY_PRESS_MASK") + (C-enum "GDK_POINTER_MOTION_MASK") + (C-enum "GDK_BUTTON_PRESS_MASK") + (C-enum "GDK_BUTTON_RELEASE_MASK"))) + +(define-generic fix-widget-unrealize-callback (widget)) + +(define-method fix-widget-unrealize-callback ((widget )) + (%trace "; (fix-widget-unrealize-callback ) "widget"\n") + ) + +(define (allocate-callback widget GtkAllocation) + (let ((x (C-> GtkAllocation "GtkAllocation x")) + (y (C-> GtkAllocation "GtkAllocation y")) + (width (C-> GtkAllocation "GtkAllocation width")) + (height (C-> GtkAllocation "GtkAllocation height")) + (rect (fix-widget-geometry widget))) + (%trace "; allocated "width"x"height" at "x","y" for "widget"\n") + (assert-glib-locked 'allocate-callback) + (C-call "gtk_widget_set_allocation" (gobject-alien widget) GtkAllocation) + (set-fix-rect! rect x y width height) + (if (fix-widget-realized? widget) + (C-call "gdk_window_move_resize" + (fix-widget-window widget) + x y width height)) + (fix-widget-new-geometry-callback widget))) + +(define-generic fix-widget-new-geometry-callback (widget)) + +(define-method fix-widget-new-geometry-callback ((widget )) + (declare (ignore widget)) + unspecific) + +(define (fix-widget-realized? widget) + (not (alien-null? (fix-widget-window widget)))) + +(define-syntax pointer-shapes + (sc-macro-transformer + (lambda (form usage-env) + + (define (simplify name) + ;; |GDK_BASED_ARROW_DOWN| => based-arrow-down + (let ((string (symbol->string name))) + (if (string-prefix? "GDK_" string) + (intern (string-replace (string-tail string 4) #\_ #\-)) + (begin + (warn "Unexpected GdkCursorType name:" name) + name)))) + + (list 'quote + (map (lambda (name.value) + (cons (simplify (car name.value)) + (cdr name.value))) + (c-enum-constant-values '|GdkCursorType| form + (find-c-includes usage-env))))))) + +(define set-fix-widget-pointer-shape! + (let ((alist (pointer-shapes))) + (named-lambda (set-fix-widget-pointer-shape! widget name) + (let ((name.value (or (assq name alist) + (error "Not a pointer shape:" name + (map car alist)))) + (cursor (make-alien '|GdkCursor|)) + (display (make-alien '|GdkDisplay|))) + (assert-glib-locked 'set-fix-widget-pointer-shape!) + ;; GC-protect cursor! + (C-call "gtk_widget_get_display" display (gobject-alien widget)) + (C-call "gdk_cursor_new_for_display" cursor display (cdr name.value)) + (C-call "gdk_window_set_cursor" (fix-widget-window widget) cursor) + (C-call "g_object_unref" cursor))))) + +(define (event-callback widget GdkEvent) + (%trace2 ";event-callback "widget) + + (let ((type (C-> GdkEvent "GdkEvent any type"))) + (%trace2 " "(C-enum "GdkEventType" type)"\n") + (let ((handler (vector-ref (fix-widget-event-handlers widget) type))) + (and handler + (handler widget GdkEvent))))) + +(define (set-fix-widget-enter-notify-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-enter-notify-handler!) + (guarantee-procedure-of-arity handler 1 'set-fix-widget-enter-notify-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_ENTER_NOTIFY") + (named-lambda (fix-widget-enter-notify-handler widget GdkEvent) + (declare (ignore GdkEvent)) + (handler widget)))) + +(define (set-fix-widget-leave-notify-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-leave-notify-handler!) + (guarantee-procedure-of-arity handler 1 'set-fix-widget-leave-notify-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_LEAVE_NOTIFY") + (named-lambda (fix-widget-leave-notify-handler widget GdkEvent) + (declare (ignore GdkEvent)) + (handler widget)))) + +(define (set-fix-widget-focus-change-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-focus-change-handler!) + (guarantee-procedure-of-arity handler 2 'set-fix-widget-focus-change-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_FOCUS_CHANGE") + (named-lambda (fix-widget-focus-change-handler widget GdkEvent) + (let ((in? (not (zero? (C-> GdkEvent "GdkEventFocus in"))))) + (handler widget in?))))) + +(define (set-fix-widget-visibility-notify-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-visibility-notify-handler!) + (guarantee-procedure-of-arity handler 2 'set-fix-widget-visibility-notify-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_VISIBILITY_NOTIFY") + (named-lambda (fix-widget-visibility-notify-handler widget GdkEvent) + (let ((state (C-> GdkEvent "GdkEventVisibility state"))) + (handler + widget + (cond + ((int:= state (C-enum "GDK_VISIBILITY_UNOBSCURED")) 'VISIBLE) + ((int:= state (C-enum "GDK_VISIBILITY_PARTIAL")) 'PARTIALLY-OBSCURED) + ((int:= state (C-enum "GDK_VISIBILITY_FULLY_OBSCURED")) 'OBSCURED) + (else (C-enum "GdkVisibilityState" state)))))))) + +(define (set-fix-widget-key-press-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-key-press-handler!) + (guarantee-procedure-of-arity handler 3 'set-fix-widget-key-press-handler!) + (vector-set! + (fix-widget-event-handlers widget) (C-enum "GDK_KEY_PRESS") + (named-lambda (fix-widget-key-press-handler widget GdkEvent) + (let ((alien (C-> GdkEvent "GdkEvent key string")) + (length (C-> GdkEvent "GdkEvent key length")) + (state (C-> GdkEvent "GdkEvent key state")) + (keyval (C-> GdkEvent "GdkEvent key keyval"))) + (let ((string (c-peek-cstring alien)) + (char-bits (gdk-key-state->char-bits state))) + (cond ((zero? (string-length string)) + (cond ((fix:= length 1) + (handler widget #\NUL char-bits)) + ((fix:= length 0) + (handler widget (gdk-keyval->name keyval) char-bits)) + (else (error "Unexpected length in GdkEventKey.")))) + ;; Kludge: BackSpace and C-h both have "key string" "\b"?! + ;; And Delete is already "\177" (aka (string #\rubout)). + ((and (fix:= 1 (string-length string)) + (char=? #\backspace (string-ref string 0))) + (let ((name (gdk-keyval->name keyval))) + (cond ((string-ci=? (symbol->string name) "backspace") + (handler widget #\backspace char-bits)) + ((memq name '(|h| |H|)) + (handler widget #\C-h + (fix:- char-bits char-bit:control))) + (else (error "Unexpected backspace keyval:" keyval))))) + (else + (let ((l (string-length string))) + (let loop ((i 0)) + (if (fix:< i l) + (and (handler widget (string-ref string i) char-bits) + (loop (fix:1+ i))) + #t)))))))))) + +(define (set-fix-widget-motion-handler! widget handler) + (guarantee-fix-widget widget 'set-fix-widget-motion-handler!) + (guarantee-procedure-of-arity handler 4 'set-fix-widget-motion-handler!) + (vector-set! + (fix-widget-event-handlers widget) + (C-enum "GDK_MOTION_NOTIFY") + (named-lambda (fix-widget-motion-handler widget GdkEvent) + (handler widget + (->modifiers (C-> GdkEvent "GdkEventMotion state")) + (floor->exact (C-> GdkEvent "GdkEventMotion x")) + (floor->exact (C-> GdkEvent "GdkEventMotion y")))))) + +(define ->modifiers + (let ((names (make-vector 32 #f))) + (define-integrable (name mask symbol) + (vector-set! names (car (bit-mask-indices mask)) symbol)) + (name (C-enum "GDK_SHIFT_MASK") 'shift) + (name (C-enum "GDK_LOCK_MASK") 'lock) + (name (C-enum "GDK_CONTROL_MASK") 'control) + (name (C-enum "GDK_MOD1_MASK") 'mod1) + (name (C-enum "GDK_MOD2_MASK") 'mod2) + (name (C-enum "GDK_MOD3_MASK") 'mod3) + (name (C-enum "GDK_MOD4_MASK") 'mod4) + (name (C-enum "GDK_MOD5_MASK") 'mod5) + (name (C-enum "GDK_BUTTON1_MASK") 'button1) + (name (C-enum "GDK_BUTTON2_MASK") 'button2) + (name (C-enum "GDK_BUTTON3_MASK") 'button3) + (name (C-enum "GDK_BUTTON4_MASK") 'button4) + (name (C-enum "GDK_BUTTON5_MASK") 'button5) + (name (C-enum "GDK_SUPER_MASK") 'super) + (name (C-enum "GDK_HYPER_MASK") 'hyper) + (name (C-enum "GDK_META_MASK") 'meta) + (name (C-enum "GDK_RELEASE_MASK") 'release) + (named-lambda (->modifiers num) + (map! (lambda (i) (vector-ref names i)) (bit-mask-indices num))))) + +(define (set-fix-widget-button-handler! widget type handler) + (guarantee-fix-widget widget 'set-fix-widget-button-handler!) + (guarantee-procedure-of-arity handler 6 'set-fix-widget-button-handler!) + (let ((index (->button-event-type type 'set-fix-widget-button-handler!)) + (handler (make-button-handler handler))) + (vector-set! (fix-widget-event-handlers widget) index handler))) + +(define (make-button-handler handler) + (named-lambda (fix-widget-button-handler widget GdkEvent) + (handler widget + (button-event-type->name (C-> GdkEvent "GdkEvent any type")) + (C-> GdkEvent "GdkEventButton button") + (->modifiers (C-> GdkEvent "GdkEventButton state")) + (floor->exact (C-> GdkEvent "GdkEventButton x")) + (floor->exact (C-> GdkEvent "GdkEventButton y"))))) + +(define (->button-event-type type operator) + (guarantee symbol? type operator) + (case type + ((PRESS) (C-enum "GDK_BUTTON_PRESS")) + ((RELEASE) (C-enum "GDK_BUTTON_RELEASE")) + ((DOUBLE-PRESS) (C-enum "GDK_2BUTTON_PRESS")) + ((TRIPLE-PRESS) (C-enum "GDK_3BUTTON_PRESS")) + (else (error:wrong-type-argument + type "a button event type (press, release, double-press or triple-press)" + operator)))) + +(define (button-event-type->name type) + (cond ((= type (C-enum "GDK_BUTTON_PRESS")) 'PRESS) + ((= type (C-enum "GDK_BUTTON_RELEASE")) 'RELEASE) + ((= type (C-enum "GDK_2BUTTON_PRESS")) 'DOUBLE-PRESS) + ((= type (C-enum "GDK_3BUTTON_PRESS")) 'TRIPLE-PRESS) + (else 'BOGUS))) + +(define-class ( (constructor () (width height bgcolor))) + () + + ;; Scrollbar widgets. + (vadjustment define standard initial-value #f) + (hadjustment define standard initial-value #f) + (scroll-step define accessor initializer (lambda () (cons 10 20))) + + ;; Scrollable extent (drawing size), in logical device coords. + (scrollable-extent define accessor + initializer (lambda () (make-fix-rect 0 0 100 100))) + + ;; Scroll offset (and window size) in logical device coordinates. + ;; (The size should match the window geometry.) + (view define accessor initializer (lambda () (make-fix-rect 0 0))) + + (drawing define standard + modifier %set-fix-layout-drawing! + initial-value #f)) + +(define-guarantee fix-layout "a ") + +(define-method initialize-instance ((widget ) width height bgcolor) + (call-next-method widget width height bgcolor) + (%trace "; (initialize-instance ) "widget" "width"x"height"\n") + (assert-glib-locked '(initialize-instance )) + (set-fix-rect! (fix-layout-view widget) 0 0 width height) + (set-gtk-widget-draw-callback! widget layout-draw-callback) + (set-scm-widget-set-scroll-adjustments-callback! widget adjustments-callback) + (C-call "gtk_widget_set_can_focus" (gobject-alien widget) 1) + widget) + +(define-method gtk-widget-destroy-callback ((layout )) + (call-next-method layout) + (let ((drawing (fix-layout-drawing layout))) + (if drawing (fix-drawing-remove-widget! drawing layout)))) + +(define-integrable (fix-layout-hstep-incr widget) + (car (fix-layout-scroll-step widget))) + +(define-integrable (fix-layout-vstep-incr widget) + (cdr (fix-layout-scroll-step widget))) + +(define (fix-layout-clip-area layout cairo) + ;; The cairo context is clipped to the exposed area in widget + ;; coords (window coordinates). + (cairo-clip-extents + cairo + (lambda (x1. y1. x2. y2.) + (let ((x1 (floor->exact x1.)) + (y1 (floor->exact y1.)) + (x2 (floor->exact x2.)) + (y2 (floor->exact y2.)) + (view (fix-layout-view layout))) + (make-fix-rect (fix:+ x1 (fix-rect-x view)) + (fix:+ y1 (fix-rect-y view)) + (fix:- x2 x1) + (fix:- y2 y1)))))) + +(define (layout-draw-callback layout cr) + (set-alien/ctype! cr '|cairo_t|) + (%trace2 ";draw "layout" at " + (cairo-clip-extents + cr (lambda (min-x min-y max-x max-y) + (define-integrable n->s number->string) + (string-append (n->s min-x)","(n->s min-y) + " "(n->s (- max-x min-x)) + "x"(n->s (- max-y min-y))))) + "\n") + (let ((window (fix-widget-window layout)) + (drawing (fix-layout-drawing layout)) + (area (fix-layout-clip-area layout cr))) + (%trace2 "; view: "(fix-rect-string (fix-layout-view layout))"\n") + (%trace2 "; area: "(fix-rect-string area)"\n") + (let ((bg (fix-widget-%background-color layout))) + (if (color? bg) + (begin + (cairo-save cr) + (cairo-set-source-color cr bg) + (cairo-paint cr) + (cairo-restore cr)))) + (if drawing + (for-each + (lambda (ink) + (if (fix-ink-in? ink layout area) + (begin + (cairo-save cr) + (fix-ink-draw-callback ink layout window cr area) + (cairo-restore cr)))) + (fix-drawing-display-list drawing)) + (%trace2 "; no drawing\n")))) + +(define (set-fix-layout-scroll-size! widget width height) + ;; Tells WIDGET to adjust its scrollable extent. Notifies any + ;; scrollbars. + (guarantee-fix-layout widget 'set-fix-layout-scroll-size!) + (guarantee-size width 'set-fix-layout-scroll-size!) + (guarantee-size height 'set-fix-layout-scroll-size!) + (let ((extent (fix-layout-scrollable-extent widget))) + (if (not (and (fix:= width (fix-rect-width extent)) + (fix:= height (fix-rect-height extent)))) + (begin + (set-fix-rect-size! extent width height) + (if (fix-widget-realized? widget) + (adjust-adjustments widget)))))) + +(define (fix-layout-scroll-to! widget x y) + (guarantee-fix-layout widget 'fix-layout-scroll-to!) + (guarantee fixnum? x 'fix-layout-scroll-to!) + (guarantee fixnum? y 'fix-layout-scroll-to!) + (scroll widget x y)) + +(define (fix-layout-scroll-nw! widget extent) + (let ((view (fix-layout-view widget))) + (cond ((not (fix-rect-nominal? extent)) + (error "Undefined extent:" extent)) + ((not (fix-rect-nominal? view)) + (error "Undefined extent:" view)) + ((fix-rect-contains? view extent) + unspecific) + (else + (with-fix-rect-bounds + view + (lambda (min-x-view max-x-view min-y-view max-y-view) + (with-fix-rect-bounds + extent + (lambda (min-x-extent max-x-extent min-y-extent max-y-extent) + (let ((delta-y (cond ((fix:< min-y-extent min-y-view) + ;; extent is too low (N), go low + (fix:- min-y-extent min-y-view)) + ((fix:< max-y-view max-y-extent) + ;; extent is too high (S), go high + (fix:- max-y-extent max-y-view)) + (else 0))) + (delta-x (cond ((fix:< min-x-extent min-x-view) + ;; extent is too low (W), go low + (fix:- min-x-extent min-x-view)) + ((fix:< max-x-view max-x-extent) + ;; extent is too high (E), go high + (fix:- max-x-extent max-x-view)) + (else 0)))) + (fix-layout-scroll-to! + widget + (fix:+ min-x-view delta-x) + (fix:+ min-y-view delta-y))))))))))) + +(define (scroll widget new-x new-y) + ;; Scroll if more than 25% will remain in the window, else jump. + (assert-glib-locked 'scroll) + (if (fix-widget-realized? widget) + (let ((view (fix-layout-view widget))) + (let ((old-x (fix-rect-x view)) + (old-y (fix-rect-y view))) + (let ((dx (fix:- new-x old-x)) + (dy (fix:- new-y old-y))) + (if (not (and (fix:zero? dx) (fix:zero? dy))) + (let ((width (fix-rect-width view)) + (height (fix-rect-height view)) + (gdkwindow (fix-widget-window widget))) + (let ((remaining-width (fix:- width (fix:abs dy))) + (remaining-height (fix:- height (fix:abs dx)))) + (if (or (fix:negative? remaining-width) + (fix:negative? remaining-height) + (< 0.25 (/ (fix:* remaining-width remaining-height) + (fix:* width height)))) + (C-call "gdk_window_scroll" + gdkwindow (fix:negate dx) (fix:negate dy)) + (C-call "gtk_widget_queue_draw" + (gobject-alien widget))) + (set-fix-rect-position! view new-x new-y) + (adjust-adjustments widget)) + ;;(C-call "gdk_window_process_updates" gdkwindow 0) + ))))))) + +(define (set-fix-layout-scroll-step! widget width height) + (guarantee-fix-layout widget 'set-fix-layout-scroll-step!) + (guarantee positive-fixnum? width 'set-fix-layout-scroll-step!) + (guarantee positive-fixnum? height 'set-fix-layout-scroll-step!) + (let ((width.height (fix-layout-scroll-step widget))) + (set-car! width.height width) + (set-cdr! width.height height)) + (if (fix-widget-realized? widget) + (adjust-adjustments widget))) + +(define (set-fix-layout-drawing! widget drawing x y) + (assert-glib-locked 'set-fix-layout-drawing!) + (guarantee-fix-layout widget 'set-fix-layout-drawing!) + (guarantee-fix-drawing drawing 'set-fix-layout-drawing!) + (guarantee fixnum? x 'set-fix-layout-drawing!) + (guarantee fixnum? y 'set-fix-layout-drawing!) + (let* ((old (fix-layout-drawing widget)) + (view (fix-layout-view widget))) + (if (and (eq? drawing old) (fix-rect-at-point? view x y)) + unspecific + (let ((extent (fix-drawing-extent drawing)) + (scrollable (fix-layout-scrollable-extent widget))) + (set-fix-rect-position! view x y) + (set-fix-rect-size! scrollable + (fix-rect-width extent) (fix-rect-height extent)) + (if old (fix-drawing-remove-widget! old widget)) + (if drawing (fix-drawing-add-widget! drawing widget)) + (%set-fix-layout-drawing! widget drawing) + (if (fix-widget-realized? widget) + (begin + (adjust-adjustments widget) + (C-call "gtk_widget_queue_draw" (gobject-alien widget)))))))) + +;;; Callbacks. + +(define-method fix-widget-new-geometry-callback ((widget )) + (call-next-method widget) + (%trace "; (fix-widget-new-geometry-callback ) "widget"\n") + (let ((geom (fix-widget-geometry widget))) + (set-fix-rect-size! (fix-layout-view widget) + (fix-rect-width geom) (fix-rect-height geom))) + (adjust-adjustments widget)) + +(define-method fix-widget-realize-callback ((widget )) + (call-next-method widget) + (%trace "; (fix-widget-realize-callback ) "widget"\n") + (assert-glib-locked '(fix-widget-realize-callback )) + #;(let ((style (gtk-widget-style-context widget))) + (C-call "gtk_style_context_set_background" + style (fix-widget-window widget))) + (adjust-adjustments widget)) + +(define (adjustments-callback widget hGtkAdjustment vGtkAdjustment) + (%trace2 ";set-scroll-adjustments "widget + " "hGtkAdjustment" "vGtkAdjustment"\n") + (%trace ";adjustments:" + " 0x"(alien/address-string hGtkAdjustment) + " 0x"(alien/address-string vGtkAdjustment)"\n") + (connect-adjustment (fix-layout-hadjustment widget) hGtkAdjustment + widget set-fix-layout-hadjustment!) + (connect-adjustment (fix-layout-vadjustment widget) vGtkAdjustment + widget set-fix-layout-vadjustment!) + (if (fix-widget-realized? widget) + (adjust-adjustments widget))) + +(define (connect-adjustment old-adjustment new-alien widget setter) + (assert-glib-locked 'connect-adjustment) + (let ((old-alien (and old-adjustment (gobject-alien old-adjustment)))) + ;; Disconnect. + (cond ((not old-adjustment)) + ((alien=? new-alien old-alien)) + (else + (gobject-unref! old-adjustment))) + ;; Connect. + (cond ((alien-null? new-alien)) + ((and old-alien (alien=? new-alien old-alien))) + (else + (let ((new-adjustment (make-gtk-adjustment))) + (copy-alien-address! (gobject-alien new-adjustment) new-alien) + (C-call "g_object_ref_sink" new-alien new-alien) + (setter widget new-adjustment) + (g-signal-connect + new-adjustment (C-callback "value_changed") + (make-adjustment-value-changed-callback widget))))))) + +(define (make-adjustment-value-changed-callback widget) + (named-lambda (fix-layout-adjustment-value-changed-callback adjustment) + (%trace2 ";adjustment-value-changed "widget" "adjustment"\n") + (assert-glib-locked 'make-adjustment-value-changed-callback) + (let ((window-extent (fix-layout-view widget)) + (vadjustment (fix-layout-vadjustment widget)) + (hadjustment (fix-layout-hadjustment widget)) + (value (floor->exact + (C-call "gtk_adjustment_get_value" + (gobject-alien adjustment))))) + (cond ((eq? adjustment vadjustment) + (%trace2 ";vadjustment to "value"\n") + (scroll widget (fix-rect-x window-extent) value)) + ((eq? adjustment hadjustment) + (%trace2 ";hadjustment to "value"\n") + (scroll widget value (fix-rect-y window-extent))) + (else (warn "Unexpected adjustment:" adjustment)))))) + +(define (adjust-adjustments widget) + ;; Called after the widget gets new adjustment(s) or its size or + ;; scrollable extent changes. + + (%trace2 ";adjust horizontal adjustment "widget"\n") + (adjust-adjustment widget (fix-layout-hadjustment widget) + fix-rect-width fix-rect-x + (lambda (rect x) + (set-fix-rect-x! rect x) + (gtk-widget-queue-draw widget)) + fix-layout-hstep-incr) + (%trace2 ";adjust vertical adjustment "widget"\n") + (adjust-adjustment widget (fix-layout-vadjustment widget) + fix-rect-height fix-rect-y + (lambda (rect y) + (set-fix-rect-y! rect y) + (gtk-widget-queue-draw widget)) + fix-layout-vstep-incr)) + +(define (adjust-adjustment widget adj + fix-rect-size fix-rect-low set-fix-rect-low! + widget-step-incr) + (if (and adj (gobject-live? adj)) + (let ((view (fix-layout-view widget)) + (extent (fix-layout-scrollable-extent widget))) + (let ((view-size (fix-rect-size view)) + (extent-size (fix-rect-size extent)) + (extent-low (fix-rect-low extent)) + (step-incr (widget-step-incr widget))) + (fix-layout-adjustment-parameters + widget view-size extent-size extent-low + (lambda (low page-size) + + (define-integrable (clamped-value! low high) + (let ((value (fix-rect-low view))) + (cond ((fix:< value low) + (set-fix-rect-low! view low) + low) + ((fix:< high value) + (set-fix-rect-low! view high) + high) + (else value)))) + + (let ((high (fix:+ extent-low extent-size)) + (page-incr (fix:max 1 (fix:- page-size step-incr)))) + (let ((value (clamped-value! low (fix:- high page-size)))) + (%trace2 "; adjustment: "low" "value" "high" "page-size"\n") + (set-gtk-adjustment! adj value low high + page-size step-incr page-incr))))))))) + +(define-generic fix-layout-adjustment-parameters (widget + view-size extent-size + extent-low receiver)) + +(define-method fix-layout-adjustment-parameters ((widget ) + view-size extent-size + extent-low receiver) + (if (fix:< view-size extent-size) + ;; Drawing is larger than viewport: thumb (page) is viewport. + (let ((low extent-low) + (page-size view-size)) + (%trace2 "; large-drawing:"(fix-layout-scrollable-extent widget) + " view:"(fix-layout-view widget)"\n") + (receiver low page-size)) + ;; Viewport is larger than drawing: thumb (page) is drawing. + (let ((low (fix:- extent-low (fix:- view-size extent-size))) + (page-size extent-size)) + (%trace2 "; drawing:"(fix-layout-scrollable-extent widget) + " large-view:"(fix-layout-view widget)"\n") + (receiver low page-size)))) + +(define-class ( (constructor () no-init)) + () + (extent define accessor initializer (lambda () (make-fix-rect 0 0 0 0))) + (widgets define standard initial-value '()) + (display-list define standard initial-value '())) + +(define-guarantee fix-drawing "a ") + +(define (drawing-damage ink #!optional rect) + ;; Invalidates any widget extents affected by RECT in INK. By + ;; default, RECT is INK's entire extent. + (assert-glib-locked 'drawing-damage) + (let ((extent (if (default-object? rect) + (fix-ink-extent ink) + rect)) + (drawing (fix-ink-drawing ink))) + (%trace2 ";drawing-damage "ink" "(fix-rect-string extent)"\n") + + (cond ((not drawing)) + ((not (fix-rect-nominal? extent)) + (error "Cannot damage ill-defined extent:" ink)) + ((and (not (fix:zero? (fix-rect-width extent))) + (not (fix:zero? (fix-rect-height extent)))) + (for-each + (lambda (widget) + (if (not (gtk-widget-destroyed? widget)) + (let ((intersect (let ((v (fix-layout-view widget))) + (and (fix-rect-nominal? v) + (window-intersection v extent))))) + (if intersect + (C-call "gtk_widget_queue_draw_area" + (gobject-alien widget) + (fix-rect-x intersect) (fix-rect-y intersect) + (fix-rect-width intersect) + (fix-rect-height intersect)))))) + (let ((widgets (fix-ink-widgets ink))) + (if (eq? #t widgets) + (fix-drawing-widgets drawing) + widgets))))))) + +(define (fix-drawing-pick-list drawing widget x y) - (keep-matching-items (fix-drawing-display-list drawing) - (lambda (ink) - (and (fix-ink-in-widget? ink widget) - (point-in-fix-rect? x y (fix-ink-extent ink)))))) ++ (filter (lambda (ink) ++ (and (fix-ink-in-widget? ink widget) ++ (point-in-fix-rect? x y (fix-ink-extent ink)))) ++ (fix-drawing-display-list drawing))) + +(define (fix-ink-in? ink widget area) + (declare (integrate-operator fix-ink-in?)) + (and (fix-ink-in-widget? ink widget) + (let ((extent (fix-ink-extent ink))) + (and (fix-rect-nominal? extent) + (fix-rect-intersect? extent area))))) + +(define-integrable (fix-ink-in-widget? ink widget) + (let ((widgets (fix-ink-widgets ink))) + (or (eq? #t widgets) + (memq widget widgets)))) + +(define-generic fix-ink-draw-callback (ink widget window cr exposed-area) + ;; Due to the checks in layout-draw-callback, methods of this generic can + ;; assume expose-area and the ink's extent are intersecting, and INK + ;; is visible in the WIDGET. Methods may also assume the widget is + ;; realized and its window's cairo's clipping is already set. The + ;; widget's scroll offset (view extent) is also set. + ) + +(define (fix-drawing-add-widget! drawing widget) + (guarantee-fix-drawing drawing 'fix-drawing-add-widget!) + (guarantee-fix-layout widget 'fix-drawing-add-widget!) + (let ((widgets (fix-drawing-widgets drawing))) + (if (not (memq widget widgets)) + (set-fix-drawing-widgets! drawing (cons widget widgets))))) + +(define (fix-drawing-remove-widget! drawing widget) + (guarantee-fix-drawing drawing 'fix-drawing-remove-widget!) + (guarantee-fix-layout widget 'fix-drawing-remove-widget!) + (set-fix-drawing-widgets! drawing (delq! widget + (fix-drawing-widgets drawing)))) + +(define (fix-drawing-add-ink! drawing ink #!optional where) + (guarantee-fix-drawing drawing 'fix-drawing-add-ink!) + (guarantee-fix-ink ink 'fix-drawing-add-ink!) + + (let ((where (and (not (default-object? where)) where))) + (if (fix-ink-drawing ink) (error "Already in a drawing:" ink)) + (cond ((or (eq? #f where) + (eq? 'TOP where)) + (set-fix-drawing-display-list! + drawing (append! (fix-drawing-display-list drawing) (list ink)))) + ((eq? 'BOTTOM where) + (set-fix-drawing-display-list! + drawing (cons ink (fix-drawing-display-list drawing)))) + ((fix-ink? where) + (let loop ((inks (fix-drawing-display-list drawing)) + (prev #f)) + (if (null? inks) + (error "Ink not found in drawing:" ink drawing) + (let ((i (car inks))) + (if (eq? where i) + (if (pair? prev) + (set-cdr! prev (cons ink inks)) + (set-fix-drawing-display-list! drawing + (cons ink inks))) + (loop (cdr inks) inks)))))) + (else (error:wrong-type-argument + where + (string-append "display list location" + ", one of: #F, TOP, BOTTOM, or an " + " already in the drawing's display list") + 'fix-drawing-add-ink!)))) + (set-fix-ink-drawing! ink drawing) + (drawing-damage ink)) + +(define (set-fix-drawing-size! drawing width height) + (guarantee-fix-drawing drawing 'set-fix-drawing-size!) + (guarantee-size width 'set-fix-drawing-size!) + (guarantee-size height 'set-fix-drawing-size!) + (set-fix-rect-size! (fix-drawing-extent drawing) width height) + (for-each + (lambda (widget) (set-fix-layout-scroll-size! widget width height)) + (fix-drawing-widgets drawing))) + +(define (set-drawing-extent! drawing rectangle) + (let ((extent (fix-drawing-extent drawing))) + (set-fix-rect! extent + (fix-rect-x rectangle) + (fix-rect-y rectangle) + (fix-rect-width rectangle) + (fix-rect-height rectangle)))) + +(define-class + () + (extent define standard initializer (lambda () (make-fix-rect 0 0 0 0))) + (drawing define standard initial-value #f) + + ;; A list of widgets in which the ink should be drawn. #t if the + ;; ink should be visible in all views of the drawing. + (widgets define standard initial-value #t + modifier set-fix-ink-%widgets!)) + +(define-guarantee fix-ink "a ") + +(define (set-fix-ink-%position! ink x y) + (assert-glib-locked 'set-fix-ink-%position!) + (let ((extent (fix-ink-extent ink))) + (without-interruption + (lambda () + (if (not (and (fix:= x (fix-rect-x extent)) + (fix:= y (fix-rect-y extent)))) + (begin + (drawing-damage ink) + (set-fix-rect-position! extent x y) + (drawing-damage ink))))))) + +(define (set-fix-ink! ink x y width height) + (assert-glib-locked 'set-fix-ink!) + (let ((extent (fix-ink-extent ink))) + (without-interruption + (lambda () + (if (not (and (fix:= x (fix-rect-x extent)) + (fix:= y (fix-rect-y extent)) + (fix:= width (fix-rect-width extent)) + (fix:= height (fix-rect-height extent)))) + (begin + (drawing-damage ink) + (set-fix-rect! extent x y width height) + (drawing-damage ink))))))) + +(define (set-fix-ink-widgets! ink widgets) + (assert-glib-locked 'set-fix-ink-widgets!) + (without-interruption + (lambda () + (if (not (equal? widgets (fix-ink-widgets ink))) + (begin + (drawing-damage ink) + (set-fix-ink-%widgets! ink widgets) + (drawing-damage ink)))))) + +(define (fix-ink-remove! ink) + (assert-glib-locked 'fix-ink-remove!) + (guarantee-fix-ink ink 'fix-ink-remove!) + (let ((drawing (fix-ink-drawing ink))) + (cond ((not drawing) unspecific) + ((not (memq ink (fix-drawing-display-list drawing))) + (warn "Could not remove ink:" ink drawing)) + (else + (without-interruption + (lambda () + (set-fix-drawing-display-list! + drawing (delq! ink (fix-drawing-display-list drawing))) + (drawing-damage ink) + (set-fix-ink-drawing! ink #f))))))) + +;; For the convenience of SWAT's canvas item group, mostly. +(define-generic fix-ink-move! (ink dx dy)) + +;; Use this to define your fix-ink-move! method iff your extent is all +;; that needs to be updated when you move. This is not a default +;; method, else things might (only) appear to work. +(define-integrable (generic-fix-ink-move! ink dx dy) + (assert-glib-locked 'generic-fix-ink-move!) + (without-interruption + (lambda () + (let ((extent (fix-ink-extent ink))) + (drawing-damage ink) + (fix-rect-move! extent dx dy) + (drawing-damage ink))))) + +;; This kind of ink draws (outlines and/or fills) a shape according to +;; a variety of options. These can be converted LATE, e.g. on expose, +;; when there is a realized widget. + +(define-class + () + ;; Alist of option names (symbols) X values (whatnot). + (options define standard initial-value '())) + +(define-guarantee draw-ink "a ") + +;;; For draw-ink expose handlers (without-interrupts in gtk-thread). + +(define-integrable (get-option ink name default) + (let ((entry (assq name (draw-ink-options ink)))) + (if entry (cdr entry) default))) + +(define-integrable (set-option!? ink name value) + ;; If VALUE is null, the option is unset. If the option value is + ;; already VALUE, returns #f (else #t). + (let* ((options (draw-ink-options ink)) + (entry (assq name options)) + (old-value (if entry (cdr entry) '()))) + (if (equal? value old-value) + #f + (begin + (if entry + (if (null? value) + (set-draw-ink-options! ink (delq! entry options)) + (set-cdr! entry value)) + (set-draw-ink-options! ink (cons (cons name value) options))) + #t)))) + +(define-class ( (constructor ())) + () + (vector define standard initializer (lambda () (make-fix-rect 0 0 0 0)))) + +(define-guarantee line-ink "a ") + +(define-method fix-ink-draw-callback ((ink ) widget window cr area) + (declare (ignore window area)) + (%trace2 ";drawing "ink" on "widget"\n") + (let ((view (fix-layout-view widget)) + (vector (line-ink-vector ink))) + (with-fix-rect + vector + (lambda (x y dx dy) + (let ((x (fix:- x (fix-rect-x view))) + (y (fix:- y (fix-rect-y view)))) + (cairo-move-to cr x y) + (cairo-rel-line-to cr dx dy)))) + (set-line-options! cr ink) + (let ((color (get-option ink 'DASH-COLOR '()))) + (if (not (null? color)) + (begin + (cairo-save cr) + (cairo-set-source-color cr color) + (cairo-stroke-preserve cr) + (cairo-restore cr)))) + (set-line-dashes! cr ink) + (cairo-stroke cr))) + +(define (set-line-options! cr ink) + (for-each + (lambda (entry) + (let ((name (car entry)) + (value (cdr entry))) + (case name + ((COLOR) (cairo-set-source-color cr value)) + ;;((LINE-CAP) ...) + ;;((LINE-JOIN) ...) + ;;((LINE-MITER-LIMIT) ...) + ((LINE-WIDTH) (cairo-set-line-width cr value))))) + (draw-ink-options ink))) + +(define (set-line-dashes! cr ink) + (let ((entry (assq 'DASHES (draw-ink-options ink)))) + (if entry + (cairo-set-dash cr (cdr entry))))) + +(define-integrable (half-line-width ink) + (fix:max 1 (fix:1+ (floor->exact (quotient (get-option ink 'LINE-WIDTH 1.) + 2))))) + +(define (recache-line-extent! ink) + (assert-without-interruption 'recache-line-extent!) + (assert-glib-locked 'recache-line-extent!) + (with-fix-rect + (line-ink-vector ink) + (lambda (x1 y1 dx dy) + (let ((x2 (fix:+ x1 dx)) + (y2 (fix:+ y1 dy))) + (let ((min-x (fix:min x1 x2)) + (min-y (fix:min y1 y2)) + (max-x (fix:max x1 x2)) + (max-y (fix:max y1 y2)) + (lw/2 (half-line-width ink))) + (drawing-damage ink) + (set-fix-rect-bounds! (fix-ink-extent ink) + (fix:- min-x lw/2) + (fix:+ max-x lw/2) + (fix:- min-y lw/2) + (fix:+ max-y lw/2)) + (drawing-damage ink)))))) + +(define (set-line-ink! ink x1 y1 x2 y2) + (assert-glib-locked 'set-line-ink!) + (guarantee fixnum? x1 'set-line-ink!) + (guarantee fixnum? y1 'set-line-ink!) + (guarantee fixnum? x2 'set-line-ink!) + (guarantee fixnum? y2 'set-line-ink!) + (without-interruption + (lambda () + (let ((vector (line-ink-vector ink)) + (dx (fix:- x2 x1)) + (dy (fix:- y2 y1))) + (if (not (and (fix:= x1 (fix-rect-x vector)) + (fix:= y1 (fix-rect-y vector)) + (fix:= dx (fix-rect-width vector)) + (fix:= dy (fix-rect-height vector)))) + (begin + (set-fix-rect! vector x1 y1 dx dy) + (recache-line-extent! ink))))))) + +(define-method fix-ink-move! ((ink ) dx dy) + (assert-glib-locked '(fix-ink-move! )) + (without-interruption + (lambda () + (let ((vector (line-ink-vector ink)) + (extent (fix-ink-extent ink))) + (drawing-damage ink) + (fix-rect-move! vector dx dy) + (fix-rect-move! extent dx dy) + (drawing-damage ink))))) + +(define (line-ink-width ink) + (guarantee-line-ink ink 'line-ink-width) + (get-option ink 'LINE-WIDTH '())) + +(define (set-line-ink-width! ink width) + (assert-glib-locked 'set-line-ink-width!) + (guarantee-line-ink ink 'set-line-ink-width!) + (guarantee positive-fixnum? width 'set-line-ink-width!) + (without-interruption + (lambda () + (if (set-option!? ink 'LINE-WIDTH (->flonum width)) + (recache-line-extent! ink))))) + +(define (line-ink-color ink) + (guarantee-line-ink ink 'line-ink-color) + (get-option ink 'COLOR '())) + +(define (set-line-ink-color! ink color) + (assert-glib-locked 'set-line-ink-color!) + (guarantee-line-ink ink 'set-line-ink-color!) + (let ((color (->color color 'set-line-ink-color!))) + (without-interruption + (lambda () + (if (set-option!? ink 'COLOR color) + (drawing-damage ink)))))) + +(define (line-ink-dash-color ink) + (guarantee-line-ink ink 'line-ink-dash-color) + (get-option ink 'DASH-COLOR '())) + +(define (set-line-ink-dash-color! ink color) + (assert-glib-locked 'set-line-ink-dash-color!) + (guarantee-line-ink ink 'set-line-ink-dash-color!) + (let ((color (cond ((eq? color '()) '()) + (else (->color color 'set-line-ink-dash-color!))))) + (without-interruption + (lambda () + (if (set-option!? ink 'DASH-COLOR color) + (drawing-damage ink)))))) + +(define (line-ink-dashes ink) + (guarantee-line-ink ink 'line-ink-dash-color) + (get-option ink 'DASHES '())) + +(define (set-line-ink-dashes! ink lengths) + (assert-glib-locked 'set-line-ink-dashes!) + (guarantee-line-ink ink 'set-line-ink-dashes!) + (guarantee-list-of-type lengths flo:flonum? + "list of flonums" 'set-line-ink-dashes!) + (without-interruption + (lambda () + (if (set-option!? ink 'DASHES lengths) + (drawing-damage ink))))) + +(define-class ( (constructor ())) + () + (rect define standard initializer (lambda () (make-fix-rect 0 0 0 0)))) + +(define-guarantee rectangle-ink "a ") + +(define-method fix-ink-draw-callback ((ink ) + widget window cr area) + (declare (ignore window area)) + (%trace2 ";drawing "ink" on "widget"\n") + (let ((view (fix-layout-view widget)) + (rect (rectangle-ink-rect ink))) + (with-fix-rect + rect + (lambda (x y width height) + (let ((x (fix:- x (fix-rect-x view))) + (y (fix:- y (fix-rect-y view)))) + (cairo-rectangle cr x y width height) + (let ((fill (get-option ink 'FILL '()))) + (if (not (null? fill)) + (begin + (cairo-save cr) + (set-fill-options! cr ink) + (cairo-fill-preserve cr) + (cairo-restore cr)))) + (let ((outline (get-option ink 'OUTLINE '()))) + (if (not (null? outline)) + (begin + (set-outline-options! cr ink) + (cairo-stroke cr))))))))) + +(define (set-fill-options! cr ink) + ;; For filling ovals, rectangles... + (for-each + (lambda (entry) + (let ((name (car entry)) + (value (cdr entry))) + (case name + ((FILL) (cairo-set-source-color cr value))))) + (draw-ink-options ink))) + +(define (set-outline-options! cr ink) + (for-each + (lambda (entry) + (let ((name (car entry)) + (value (cdr entry))) + (case name + ((OUTLINE) (cairo-set-source-color cr value)) + ((LINE-WIDTH) (cairo-set-line-width cr value)) + ((DASHES) (set-line-dashes! cr ink))))) + (draw-ink-options ink))) + +(define (recache-rectangle-extent! ink) + (with-fix-rect-bounds + (rectangle-ink-rect ink) + (lambda (min-x max-x min-y max-y) + (let ((lw/2 (half-line-width ink))) + (drawing-damage ink) + (set-fix-rect-bounds! (fix-ink-extent ink) + (fix:- min-x lw/2) + (fix:+ max-x lw/2) + (fix:- min-y lw/2) + (fix:+ max-y lw/2)) + (drawing-damage ink))))) + +(define (set-rectangle-ink! ink x y width height) + (assert-glib-locked 'set-rectangle-ink!) + (guarantee fixnum? x 'set-rectangle-ink!) + (guarantee fixnum? y 'set-rectangle-ink!) + (guarantee-size width 'set-rectangle-ink!) + (guarantee-size height 'set-rectangle-ink!) + (without-interruption + (lambda () + (let ((rect (rectangle-ink-rect ink))) + (if (not (and (fix:= x (fix-rect-x rect)) + (fix:= y (fix-rect-y rect)) + (fix:= width (fix-rect-width rect)) + (fix:= height (fix-rect-height rect)))) + (begin + (set-fix-rect! rect x y width height) + (recache-rectangle-extent! ink))))))) + +(define (set-rectangle-ink-position! ink x y) + (assert-glib-locked 'set-rectangle-ink-position!) + (guarantee fixnum? x 'set-rectangle-ink-position!) + (guarantee fixnum? y 'set-rectangle-ink-position!) + (without-interruption + (lambda () + (let ((rect (rectangle-ink-rect ink))) + (if (not (and (fix:= x (fix-rect-x rect)) + (fix:= y (fix-rect-y rect)))) + (begin + (set-fix-rect-position! rect x y) + (recache-rectangle-extent! ink))))))) + +(define-method fix-ink-move! ((ink ) dx dy) + (assert-glib-locked '(fix-ink-move! )) + (without-interruption + (lambda () + (let ((rect (rectangle-ink-rect ink)) + (extent (fix-ink-extent ink))) + (drawing-damage ink) + (fix-rect-move! rect dx dy) + (fix-rect-move! extent dx dy) + (drawing-damage ink))))) + +(define (rectangle-ink-width ink) + (guarantee-rectangle-ink ink 'rectangle-ink-width) + (get-option ink 'LINE-WIDTH '())) + +(define (set-rectangle-ink-width! ink width) + (assert-glib-locked 'set-rectangle-ink-width!) + (guarantee-rectangle-ink ink 'set-rectangle-ink-width!) + (guarantee positive-fixnum? width 'set-rectangle-ink-width!) + (without-interruption + (lambda () + (if (set-option!? ink 'LINE-WIDTH (->flonum width)) + (recache-rectangle-extent! ink))))) + +(define (rectangle-ink-color ink) + (guarantee-rectangle-ink ink 'rectangle-ink-color) + (get-option ink 'OUTLINE '())) + +(define (set-rectangle-ink-color! ink color) + (assert-glib-locked 'set-rectangle-ink-color!) + (guarantee-rectangle-ink ink 'set-rectangle-ink-color!) + (let ((color (->color color 'set-rectangle-ink-color!))) + (without-interruption + (lambda () + (if (set-option!? ink 'OUTLINE color) + (drawing-damage ink)))))) + +(define (rectangle-ink-fill-color ink) + (guarantee-rectangle-ink ink 'rectangle-ink-fill-color) + (get-option ink 'FILL '())) + +(define (set-rectangle-ink-fill-color! ink color) + (assert-glib-locked 'set-rectangle-ink-fill-color!) + (guarantee-rectangle-ink ink 'set-rectangle-ink-fill-color!) + (let ((color (->color color 'set-rectangle-ink-fill-color!))) + (without-interruption + (lambda () + (if (set-option!? ink 'FILL color) + (drawing-damage ink)))))) + +(define-class ( (constructor ())) + () + (vertices define standard initial-value '())) + +(define-guarantee polygon-ink "a ") + +(define-method fix-ink-draw-callback ((ink ) widget window cr area) + (declare (ignore window area)) + (%trace2 ";drawing "ink" on "widget"\n") + (let ((view (fix-layout-view widget)) + (vertices (polygon-ink-vertices ink))) + (if (not (null? vertices)) + (let ((view-x (fix-rect-x view)) + (view-y (fix-rect-y view))) + (cairo-move-to cr + (fix:- (caar vertices) view-x) + (fix:- (cdar vertices) view-y)) + (let loop ((verts (cdr vertices))) + (if (not (null? verts)) + (begin + (cairo-line-to cr + (fix:- (caar verts) view-x) + (fix:- (cdar verts) view-y)) + (loop (cdr verts))))) + (let ((fill (get-option ink 'FILL '()))) + (if (not (null? fill)) + (begin + (cairo-save cr) + (set-fill-options! cr ink) + (cairo-fill-preserve cr) + (cairo-restore cr)))) + (let ((outline (get-option ink 'OUTLINE '()))) + (if (not (null? outline)) + (begin + (set-outline-options! cr ink) + (cairo-stroke cr)))))))) + +(define (recache-polygon-extent! ink) + (let ((vertices (polygon-ink-vertices ink))) + (if (null? vertices) + (let ((extent (fix-ink-extent ink))) + (if (not (fix:zero? (fix-rect-width ink))) + (begin + (set-fix-rect! extent 0 0 0 0) + (drawing-damage ink)))) + (let loop ((verts vertices) (min-x #f) (max-x #f) (min-y #f) (max-y #f)) + (if (pair? verts) + (let ((x (caar verts)) + (y (cdar verts))) + (loop (cdr verts) + (if min-x (fix:min min-x x) x) + (if max-x (fix:max max-x x) x) + (if min-y (fix:min min-y y) y) + (if max-y (fix:max max-y y) y))) + (let ((lw/2 (half-line-width ink))) + (drawing-damage ink) + (set-fix-rect-bounds! (fix-ink-extent ink) + (fix:- min-x lw/2) + (fix:+ max-x lw/2) + (fix:- min-y lw/2) + (fix:+ max-y lw/2)) + (drawing-damage ink))))))) + +(define (set-polygon-ink! ink vertices) + (assert-glib-locked 'set-polygon-ink!) + (if (or (null? vertices) + (not (every (lambda (p) + (and (pair? p) (fixnum? (car p)) (fixnum? (cdr p)))) + vertices))) + (error:wrong-type-argument vertices "a list of pairs of fixnums" + 'SET-POLYGON-INK!)) + (without-interruption + (lambda () + (set-polygon-ink-vertices! ink vertices) + (recache-polygon-extent! ink)))) + +(define-method fix-ink-move! ((ink ) dx dy) + (assert-glib-locked '(fix-ink-move! )) + (without-interruption + (lambda () + (for-each (lambda (p) + (set-car! p (fix:+ (car p) dx)) + (set-cdr! p (fix:+ (cdr p) dy))) + (polygon-ink-vertices ink)) + (drawing-damage ink) + (fix-rect-move! (fix-ink-extent ink) dx dy) + (drawing-damage ink)))) + +(define (polygon-ink-width ink) + (guarantee-polygon-ink ink 'polygon-ink-width) + (get-option ink 'LINE-WIDTH '())) + +(define (set-polygon-ink-width! ink width) + (assert-glib-locked 'set-polygon-ink-width!) + (guarantee-polygon-ink ink 'set-polygon-ink-width!) + (guarantee positive-fixnum? width 'set-polygon-ink-width!) + (without-interruption + (lambda () + (if (set-option!? ink 'LINE-WIDTH (->flonum width)) + (recache-polygon-extent! ink))))) + +(define (polygon-ink-color ink) + (guarantee-polygon-ink ink 'polygon-ink-color) + (get-option ink 'OUTLINE '())) + +(define (set-polygon-ink-color! ink color) + (assert-glib-locked 'set-polygon-ink-color!) + (guarantee-polygon-ink ink 'set-polygon-ink-color!) + (let ((color (->color color 'set-polygon-ink-color!))) + (without-interruption + (lambda () + (if (set-option!? ink 'OUTLINE color) + (drawing-damage ink)))))) + +(define (polygon-ink-fill-color ink) + (guarantee-polygon-ink ink 'polygon-ink-fill-color) + (get-option ink 'FILL '())) + +(define (set-polygon-ink-fill-color! ink color) + (assert-glib-locked 'set-polygon-ink-fill-color!) + (guarantee-polygon-ink ink 'set-polygon-ink-fill-color!) + (let ((color (->color color 'set-polygon-ink-fill-color!))) + (without-interruption + (lambda () + (if (set-option!? ink 'FILL color) + (drawing-damage ink)))))) + + +(define-integrable flo:pi (flo:* 4. (flo:atan2 1. 1.))) + +(define-class ( (constructor ())) + () + (rect define standard initializer (lambda () (make-fix-rect 0 0 0 0))) + (%start-angle define standard initial-value 0.) + (%sweep-angle define standard initial-value (flo:* 2. flo:pi))) + +(define-guarantee arc-ink "an ") + +(define-method fix-ink-draw-callback ((ink ) widget window cr area) + (declare (ignore window area)) + (%trace2 ";drawing "ink" on "widget"\n") + (let ((view (fix-layout-view widget)) + (rect (arc-ink-rect ink))) + (with-fix-rect + rect + (lambda (x y width height) + (let ((x. (->flonum (fix:- x (fix-rect-x view)))) + (y. (->flonum (fix:- y (fix-rect-y view)))) + (width. (->flonum width)) + (height. (->flonum height)) + (start. (arc-ink-%start-angle ink)) + (end. (flo:+ (arc-ink-%start-angle ink) + (arc-ink-%sweep-angle ink)))) + (cairo-save cr) + (cairo-translate cr + (flo:+ x. (flo:/ width. 2.)) + (flo:+ y. (flo:/ height. 2.))) + (cairo-scale cr (flo:/ width. 2.) (flo:/ height. 2.)) + (cairo-arc cr 0. 0. 1. start. end.) + (cairo-restore cr) + (let ((fill (get-option ink 'FILL '()))) + (if (not (null? fill)) + (begin + (set-fill-options! cr ink) + (cairo-fill-preserve cr)))) + (let ((outline (get-option ink 'OUTLINE '()))) + (if (not (null? outline)) + (begin + (set-outline-options! cr ink) + (cairo-stroke cr))))))))) + +(define (recache-arc-extent! ink) + (with-fix-rect-bounds + (arc-ink-rect ink) + (lambda (min-x max-x min-y max-y) + (let ((lw/2 (half-line-width ink))) + (drawing-damage ink) + (set-fix-rect-bounds! (fix-ink-extent ink) + (fix:- min-x lw/2) + (fix:+ max-x lw/2) + (fix:- min-y lw/2) + (fix:+ max-y lw/2)) + (drawing-damage ink))))) + +(define (set-arc-ink! ink x y width height) + (assert-glib-locked 'set-arc-ink!) + (guarantee fixnum? x 'set-arc-ink!) + (guarantee fixnum? y 'set-arc-ink!) + (guarantee-size width 'set-arc-ink!) + (guarantee-size height 'set-arc-ink!) + (without-interruption + (lambda () + (let ((rect (arc-ink-rect ink))) + (if (not (and (fix:= x (fix-rect-x rect)) + (fix:= y (fix-rect-y rect)) + (fix:= width (fix-rect-width rect)) + (fix:= height (fix-rect-height rect)))) + (begin + (set-fix-rect! rect x y width height) + (recache-arc-extent! ink))))))) + +(define-method fix-ink-move! ((ink ) dx dy) + (assert-glib-locked '(fix-ink-move! )) + (without-interruption + (lambda () + (let ((rect (arc-ink-rect ink)) + (extent (fix-ink-extent ink))) + (drawing-damage ink) + (fix-rect-move! rect dx dy) + (fix-rect-move! extent dx dy) + (drawing-damage ink))))) + +(define (arc-ink-start-angle arc) + (guarantee-arc-ink arc 'arc-ink-start-angle) + (flo:* (flo:/ (arc-ink-%start-angle arc) flo:pi) 180.)) + +(define (set-arc-ink-start-angle! arc degrees) + (guarantee-arc-ink arc 'set-arc-ink-start-angle!) + (guarantee real? degrees 'set-arc-ink-start-angle!) + (let ((new (flo:* (->flonum degrees) (flo:/ flo:pi 180.)))) + (if (not (flo:= new (arc-ink-%start-angle arc))) + (begin + (set-arc-ink-%start-angle! arc new) + (drawing-damage arc))))) + +(define (arc-ink-sweep-angle arc) + (guarantee-arc-ink arc 'arc-ink-sweep-angle) + (flo:* (flo:/ (arc-ink-%sweep-angle arc) flo:pi) 180.)) + +(define (set-arc-ink-sweep-angle! arc degrees) + (guarantee-arc-ink arc 'set-arc-ink-sweep-angle!) + (guarantee real? degrees 'set-arc-ink-sweep-angle!) + (let ((new (flo:* (->flonum degrees) (flo:/ flo:pi 180.)))) + (if (not (flo:= new (arc-ink-%sweep-angle arc))) + (begin + (set-arc-ink-%sweep-angle! arc new) + (drawing-damage arc))))) + +(define (arc-ink-width ink) + (guarantee-arc-ink ink 'arc-ink-width) + (get-option ink 'LINE-WIDTH '())) + +(define (set-arc-ink-width! ink width) + (assert-glib-locked 'set-arc-ink-width!) + (guarantee-arc-ink ink 'set-arc-ink-width!) + (guarantee positive-fixnum? width 'set-arc-ink-width!) + (without-interruption + (lambda () + (if (set-option!? ink 'LINE-WIDTH (->flonum width)) + (recache-arc-extent! ink))))) + +(define (arc-ink-color ink) + (guarantee-arc-ink ink 'arc-ink-color) + (get-option ink 'OUTLINE '())) + +(define (set-arc-ink-color! ink color) + (assert-glib-locked 'set-arc-ink-color!) + (guarantee-arc-ink ink 'set-arc-ink-color!) + (let ((color (->color color 'set-arc-ink-color!))) + (without-interruption + (lambda () + (if (set-option!? ink 'OUTLINE color) + (drawing-damage ink)))))) + +(define (arc-ink-fill-color ink) + (guarantee-arc-ink ink 'arc-ink-fill-color) + (get-option ink 'FILL '())) + +(define (set-arc-ink-fill-color! ink color) + (assert-glib-locked 'set-arc-ink-fill-color!) + (guarantee-arc-ink ink 'set-arc-ink-fill-color!) + (let ((color (->color color 'set-arc-ink-fill-color!))) + (without-interruption + (lambda () + (if (set-option!? ink 'FILL color) + (drawing-damage ink)))))) + +(define-class ( (constructor ())) + ()) + +(define-guarantee text-ink "a ") + +(define-generic text-ink-pango-layout (ink)) + +(define-method fix-ink-draw-callback ((ink ) widget window cr area) + (declare (ignore window area)) + (%trace2 ";drawing "ink" on "widget"\n") + (let ((layout (text-ink-pango-layout ink))) + (if layout + (let ((view (fix-layout-view widget)) + (rect (fix-ink-extent ink))) + (let ((x (fix:- (fix-rect-x rect) (fix-rect-x view))) + (y (fix:- (fix-rect-y rect) (fix-rect-y view)))) + (set-text-options! cr ink) + (cairo-move-to cr x y) + (cairo-show-pango-layout cr layout)))))) + +(define (set-text-options! cr ink) + (for-each + (lambda (entry) + (let ((name (car entry)) + (value (cdr entry))) + (case name + ((COLOR) (cairo-set-source-color cr value))))) + (draw-ink-options ink))) + +(define (set-text-ink-position! ink x y) + (assert-glib-locked 'set-text-ink-position!) + (guarantee fixnum? x 'set-text-ink-position!) + (guarantee fixnum? y 'set-text-ink-position!) + (without-interruption + (lambda () + (let ((rect (fix-ink-extent ink))) + (if (not (and (fix:= x (fix-rect-x rect)) + (fix:= y (fix-rect-y rect)))) + (begin + (drawing-damage ink) + (set-fix-rect-position! rect x y) + (drawing-damage ink))))))) + +(define-method fix-ink-move! ((ink ) dx dy) + (generic-fix-ink-move! ink dx dy)) + +(define (recache-text-extent! ink) + (let ((layout (text-ink-pango-layout ink))) + (pango-layout-get-pixel-extents + layout + (lambda (width height) + (drawing-damage ink) + (set-fix-rect-size! (fix-ink-extent ink) width height) + (drawing-damage ink))))) + +(define (text-ink-color ink) + (guarantee-text-ink ink 'text-ink-color) + (get-option ink 'COLOR '())) + +(define (set-text-ink-color! ink color) + (assert-glib-locked 'set-text-ink-color!) + (guarantee-text-ink ink 'set-text-ink-color!) + (let ((color (->color color 'set-text-ink-color!))) + (without-interruption + (lambda () + (if (set-option!? ink 'COLOR color) + (drawing-damage ink)))))) + +(define (text-ink-xy-to-index ink x y) + (and (text-ink-pango-layout ink) + (pango-layout-xy-to-index (text-ink-pango-layout ink) + (fix:- x (fix-rect-x (fix-ink-extent ink))) + (fix:- y (fix-rect-y (fix-ink-extent ink)))))) + +(define (with-text-ink-grapheme-rect ink index receiver) + (and (text-ink-pango-layout ink) + (pango-layout-index-to-pos (text-ink-pango-layout ink) + index receiver))) + +(define (->pango-font-description spec operator) + (cond ((and (alien? spec) (eq? '|PangoFontDescription| (alien/ctype spec))) + spec) + ((string? spec) - (or (hash-table/get cached-font-descriptions spec #f) ++ (or (hash-table-ref/default cached-font-descriptions spec #f) + (let ((alien (pango-font-description-from-string spec))) + (if (not alien) + (error:wrong-type-argument spec "PangoFontDescription" + operator)) - (hash-table/put! cached-font-descriptions spec alien) ++ (hash-table-set! cached-font-descriptions spec alien) + alien))) + (else (error:wrong-type-argument spec "PangoFontDescription" + operator)))) + +(define cached-font-descriptions (make-string-hash-table)) + +(define (reset-font-descriptions!) - (hash-table/clear! cached-font-descriptions)) ++ (set! cached-font-descriptions (make-string-hash-table))) + +(add-event-receiver! event:after-restore reset-font-descriptions!) + +(define-class ( (constructor ())) + () + + ;; A Scheme string. The content of the paragraph. + (text define standard initial-value #f modifier set-simple-text-ink-%text!) + + ;; Corresponding PangoLayout. + (pango-layout define standard initial-value #f)) + +(define-guarantee simple-text-ink "a ") + +(define-method text-ink-pango-layout ((ink )) + ;; Simply return the PangoLayout, which is only #f if no text has + ;; (ever) been set. + (simple-text-ink-pango-layout ink)) + +(define (set-simple-text-ink-text! ink widget text) + ;; The TEXT string is shared. + (assert-glib-locked 'set-simple-text-ink-text!) + (guarantee-simple-text-ink ink 'set-simple-text-ink-text!) + (guarantee-gtk-widget widget 'set-simple-text-ink-text!) + (guarantee string? text 'set-simple-text-ink-text!) + (without-interruption + (lambda () + (let ((old (simple-text-ink-text ink))) + (if (not (and old (string=? text old))) + (let ((layout (simple-text-ink-pango-layout ink))) + (if layout + (pango-layout-set-text layout text) + (let* ((desc (get-option ink 'FONT #f)) + (layout + (if desc + (let ((layout + (gtk-widget-create-pango-layout widget ""))) + (pango-layout-set-font-description layout desc) + (pango-layout-set-text layout text) + layout) + (gtk-widget-create-pango-layout widget text)))) + (set-simple-text-ink-pango-layout! ink layout))) + (set-simple-text-ink-%text! ink text) + (recache-text-extent! ink))))))) + +(define (simple-text-ink-font ink) + (guarantee-simple-text-ink ink 'simple-text-ink-font) + (get-option ink 'FONT #f)) + +(define (set-simple-text-ink-font! ink font) + (assert-glib-locked 'set-simple-text-ink-font!) + (guarantee-simple-text-ink ink 'set-simple-text-ink-font!) + (let ((new (->pango-font-description font 'set-simple-text-ink-font!))) + (without-interruption + (lambda () + (let ((layout (simple-text-ink-pango-layout ink))) + (if (and (set-option!? ink 'FONT new) layout) + (begin + (pango-layout-set-font-description layout new) + (recache-text-extent! ink)))))))) + +(define-class ( (constructor ())) + () + ;; This slot is set to a soon after loading has begun. + (pixbuf define standard initial-value #f) + ;; This slot is set to #f when the pixbuf has been successfully loaded. + (loader define standard initializer make-pixbuf-loader)) + +(define-method initialize-instance ((ink )) + (call-next-method ink) + (%trace ";(initialize-instance ) "ink"\n") + (let ((loader (image-ink-loader ink))) + (set-pixbuf-loader-size-hook! loader (image-ink-size-prepared ink)) + (set-pixbuf-loader-pixbuf-hook! loader (image-ink-pixbuf-prepared ink)) + (set-pixbuf-loader-update-hook! loader (image-ink-pixbuf-updated ink)) + (set-pixbuf-loader-close-hook! loader (image-ink-pixbuf-loaded ink)))) + +(define (image-ink-size-prepared ink) + (named-lambda (image-ink-size-prepared-handler width height) + (%trace ";image-ink-size-prepared-handler "ink" "width" "height"\n") + (let ((extent (fix-ink-extent ink))) + (if (not (and (fix:= width (fix-rect-width extent)) + (fix:= height (fix-rect-height extent)))) + (begin + (drawing-damage ink) + (set-fix-rect-size! extent width height) + (drawing-damage ink)))))) + +(define (image-ink-pixbuf-prepared ink) + (named-lambda (image-ink-pixbuf-prepared-handler pixbuf) + (%trace ";image-ink-pixbuf-prepared-handler "ink" "pixbuf"\n") + (set-image-ink-pixbuf! ink pixbuf))) + +(define (image-ink-pixbuf-updated ink) + (named-lambda (image-ink-pixbuf-updated-handler x y width height) + (let* ((extent (fix-ink-extent ink)) + (rect (make-fix-rect + (fix:+ x (fix-rect-x extent)) + (fix:+ y (fix-rect-y extent)) + width height))) + (%trace ";image-ink-pixbuf-updated-handler "ink" "rect"\n") + (drawing-damage ink rect)))) + +(define (image-ink-pixbuf-loaded ink) + (named-lambda (image-ink-pixbuf-loaded-handler loader) + (%trace ";image-ink-pixbuf-loaded-handler "ink" ("(image-ink-pixbuf ink)")" + " "(pixbuf-loader-error-message loader)"\n") + (if (not (pixbuf-loader-error-message loader)) + (begin + (set-image-ink-loader! ink #f) + (gobject-unref! loader)) + (begin + ;; Hack the pixbuf with a "broken image" overlay? + ;; + ;; Leave the loader, with dead thread and closed + ;; input-port, for debugging purposes. + unspecific)))) + +(define-method fix-ink-draw-callback ((ink ) widget window cr area) + (declare (ignore window area)) + (%trace2 ";drawing "ink" on "widget"\n") + (assert-glib-locked '(fix-ink-draw-callback )) + (let ((pixbuf (let ((p (image-ink-pixbuf ink))) + (if p (gobject-alien p) #f)))) + (if (and pixbuf (not (alien-null? pixbuf))) + (let ((view (fix-layout-view widget)) + (extent (fix-ink-extent ink))) + (let ((x. (->flonum (fix:- (fix-rect-x extent) (fix-rect-x view)))) + (y. (->flonum (fix:- (fix-rect-y extent) (fix-rect-y view))))) + (C-call "gdk_cairo_set_source_pixbuf" cr pixbuf x. y.) + (cairo-paint cr)))))) + +(define-method fix-ink-move! ((ink ) dx dy) + (generic-fix-ink-move! ink dx dy)) + +(define (make-image-ink-from-file filename) + (let ((ink (make-image-ink))) + (load-pixbuf-from-file (image-ink-loader ink) filename) + ink)) + +(define (set-image-ink! ink x y) + (guarantee fixnum? x 'set-image-ink-position!) + (guarantee fixnum? y 'set-image-ink-position!) + (set-fix-ink-%position! ink x y)) + +(define-class ( (constructor () (width height))) + () + + ;; Cairo Image Surface -- a |cairo_surface_t| alien. + (surface define standard) + + ;; For use by the glib thread only. + (exposed define standard initial-value #f)) + +(define-method initialize-instance ((ink ) width height) + (call-next-method ink) + (set-fix-rect-size! (fix-ink-extent ink) width height) + (set-surface-ink-surface! ink (cairo-image-surface-create width height))) + +(define-method fix-ink-draw-callback ((ink ) widget window cr area) + (declare (ignore area)) + (%trace ";drawing "ink" on "widget"\n") + (let ((view (fix-layout-view widget)) + (extent (fix-ink-extent ink)) + (surface (get-exposed ink window))) + (let ((x (fix:- (fix-rect-x extent) (fix-rect-x view))) + (y (fix:- (fix-rect-y extent) (fix-rect-y view)))) + (cairo-set-source-surface cr surface x y) + (cairo-paint cr)))) + +(define (get-exposed ink window) + (assert-glib-locked 'get-exposed) + (or (surface-ink-exposed ink) + (let ((extent (fix-ink-extent ink)) + (scale (C-call "gdk_window_get_scale_factor" window))) + (let ((width (fix:* scale (fix-rect-width extent))) + (height (fix:* scale (fix-rect-height extent)))) + (let* ((surface (gdk-window-create-similar-surface window + width height)) + (cr (cairo-create surface))) + (cairo-set-source-surface cr (surface-ink-surface ink) 0 0) + (cairo-paint cr) + (cairo-destroy cr) + (set-surface-ink-exposed! ink surface) + surface))))) + +(define (surface-ink-flush ink) + (let ((surface (surface-ink-surface ink))) + (cairo-surface-flush surface) + (with-glib-lock + (lambda () + (let ((exposed (surface-ink-exposed ink))) + (if exposed + (let ((cr (cairo-create exposed))) + (cairo-set-source-surface cr surface 0 0) + (cairo-paint cr) + (cairo-destroy cr) + (cairo-surface-flush exposed))) + (drawing-damage ink)))))) + +(define (set-surface-ink-position! ink x y) + (set-fix-rect-position! (fix-ink-extent ink) x y)) + +;;;; Fixnum Rectangles + +(define-structure (fix-rect (constructor make-fix-rect (#!optional x y width height)) + (copier) + (print-procedure - (standard-unparser-method 'FIX-RECT ++ (bracketed-print-method 'fix-rect + (lambda (rect port) + (write-string " " port) + (write-string (fix-rect-string rect) port))))) + (x #f) (y #f) (width #f) (height #f)) + +(define (fix-rect-string rect) + (define-integrable (S a) (write-to-string a)) + (string-append (S (fix-rect-x rect))","(S (fix-rect-y rect)) + " "(S (fix-rect-width rect))"x"(S (fix-rect-height rect)))) + +(define-integrable-operator (make-fix-rect-from-bounds min-x min-y max-x max-y) + (make-fix-rect min-x min-y (fix:- max-x min-x) (fix:- max-y min-y))) + +(define-integrable-operator (set-fix-rect! rect x y width height) + (set-fix-rect-x! rect x) + (set-fix-rect-y! rect y) + (set-fix-rect-width! rect width) + (set-fix-rect-height! rect height)) + +(define-integrable-operator (set-fix-rect-bounds! rect min-x max-x min-y max-y) + (set-fix-rect-x! rect min-x) + (set-fix-rect-y! rect min-y) + (set-fix-rect-width! rect (fix:- max-x min-x)) + (set-fix-rect-height! rect (fix:- max-y min-y))) + +(define-integrable-operator (set-fix-rect-position! rect x y) + (set-fix-rect-x! rect x) + (set-fix-rect-y! rect y)) + +(define-integrable-operator (fix-rect-move! rect dx dy) + (set-fix-rect-x! rect (fix:+ (fix-rect-x rect) dx)) + (set-fix-rect-y! rect (fix:+ (fix-rect-y rect) dy))) + +(define-integrable-operator (set-fix-rect-size! rect width height) + (set-fix-rect-width! rect width) + (set-fix-rect-height! rect height)) + +(define-integrable-operator (fix-rect-nominal? rect) + (and (fixnum? (fix-rect-x rect)) + (fixnum? (fix-rect-y rect)) + (fixnum? (fix-rect-width rect)) + (fixnum? (fix-rect-height rect)))) + +;;; The rest of these procedures assume a "nominal" rectangle. + +(define-integrable-operator (fix-rect-max-y rect) + (fix:+ (fix-rect-y rect) (fix-rect-height rect))) + +(define-integrable-operator (fix-rect-max-x rect) + (fix:+ (fix-rect-x rect) (fix-rect-width rect))) + +(define-integrable fix-rect-min-x fix-rect-x) +(define-integrable fix-rect-min-y fix-rect-y) + +(define-integrable-operator (with-fix-rect-bounds rect receiver) + ;; Tail-calls RECEIVER with the RECT's minx, maxx, miny and maxy (in + ;; that order). Assumes RECT is nominal. + (let ((x (fix-rect-x rect)) + (y (fix-rect-y rect)) + (width (fix-rect-width rect)) + (height (fix-rect-height rect))) + (receiver x (fix:+ x width) y (fix:+ y height)))) + +(define-integrable-operator (with-fix-rect rect receiver) + (receiver (fix-rect-x rect) (fix-rect-y rect) (fix-rect-width rect) (fix-rect-height rect))) + +(define-integrable-operator (copy-fix-rect! target source) + (set-fix-rect-x! target (fix-rect-x source)) + (set-fix-rect-y! target (fix-rect-y source)) + (set-fix-rect-width! target (fix-rect-width source)) + (set-fix-rect-height! target (fix-rect-height source))) + +(define-integrable-operator (point-in-fix-rect? x y rect) + (with-fix-rect-bounds rect + (lambda (min-x max-x min-y max-y) + (and (fix:<= min-x x) (fix:<= x max-x) + (fix:<= min-y y) (fix:<= y max-y))))) + +(define-integrable-operator (fix-rect-at-point? rect x y) + (and (fix:= x (fix-rect-x rect)) + (fix:= y (fix-rect-y rect)))) + +(define-integrable-operator (fix-rect-intersect? rect1 rect2) + ;; Useful when you do not need to cons a new rect. + (with-fix-rect-bounds rect1 + (lambda (min-x1 max-x1 min-y1 max-y1) + (with-fix-rect-bounds rect2 + (lambda (min-x2 max-x2 min-y2 max-y2) + (cond ((fix:< max-x1 min-x2) #f) + ((fix:< max-y1 min-y2) #f) + ((fix:< max-x2 min-x1) #f) + ((fix:< max-y2 min-y1) #f) + (else #t))))))) + +(define (fix-rect-intersection rect1 rect2) + ;; Returns #f if RECT1 and RECT2 do not intersect, else returns a + ;; new rect -- the intersection. Assumes both rectangles are + ;; nominal. + (with-fix-rect-bounds rect1 + (lambda (min-x1 max-x1 min-y1 max-y1) + (with-fix-rect-bounds rect2 + (lambda (min-x2 max-x2 min-y2 max-y2) + (cond ((fix:< max-x1 min-x2) #f) + ((fix:< max-y1 min-y2) #f) + ((fix:< max-x2 min-x1) #f) + ((fix:< max-y2 min-y1) #f) + (else + (let ((min-x (fix:max min-x1 min-x2)) + (min-y (fix:max min-y1 min-y2)) + (max-x (fix:min max-x1 max-x2)) + (max-y (fix:min max-y1 max-y2))) + (make-fix-rect min-x min-y + (fix:- max-x min-x) + (fix:- max-y min-y)))))))))) + +(define (window-intersection window item) + ;; Returns #f if WINDOW and ITEM do not intersect, else returns a + ;; new rect -- the intersection *translated* to WINDOW's coords. + ;; Assumes both rectangles are nominal. + (with-fix-rect-bounds window + (lambda (window-x-start window-x-end window-y-start window-y-end) + (with-fix-rect-bounds item + (lambda (item-x-start item-x-end item-y-start item-y-end) + (cond ((fix:< window-x-end item-x-start) #f) + ((fix:< window-y-end item-y-start) #f) + ((fix:< item-x-end window-x-start) #f) + ((fix:< item-y-end window-y-start) #f) + (else + (let ((x (fix:max window-x-start item-x-start)) + (y (fix:max window-y-start item-y-start)) + (x-end (fix:min window-x-end item-x-end)) + (y-end (fix:min window-y-end item-y-end))) + (make-fix-rect (fix:- x window-x-start) + (fix:- y window-y-start) + (fix:- x-end x) + (fix:- y-end y)))))))))) + +(define (fix-rect-union! rect1 rect2) + (with-fix-rect-bounds rect1 + (lambda (min-x1 max-x1 min-y1 max-y1) + (with-fix-rect-bounds rect2 + (lambda (min-x2 max-x2 min-y2 max-y2) + (let ((x (fix:min min-x1 min-x2)) + (y (fix:min min-y1 min-y2))) + (set-fix-rect! rect1 + x y + (fix:- (fix:max max-x1 max-x2) x) + (fix:- (fix:max max-y1 max-y2) y)))))))) + +(define (fix-rect-contains? rect1 rect2) + ;; True if RECT2 is wholly contained within RECT1. + (with-fix-rect-bounds rect1 + (lambda (min-x1 max-x1 min-y1 max-y1) + (with-fix-rect-bounds rect2 + (lambda (min-x2 max-x2 min-y2 max-y2) + (and (fix:<= min-x1 min-x2) (fix:<= max-x2 max-x1) + (fix:<= min-y1 min-y2) (fix:<= max-y2 max-y1))))))) + +(define (gdk-rectangle #!optional x y width height) + (if (not (default-object? x)) (guarantee fixnum? x 'gdk-rectangle)) + (if (not (default-object? y)) (guarantee fixnum? y 'gdk-rectangle)) + (if (not (default-object? width)) (guarantee-size width 'gdk-rectangle)) + (if (not (default-object? height)) (guarantee-size height 'gdk-rectangle)) + (let ((alien (malloc (C-sizeof "GdkRectangle") '|GdkRectangle|))) + (if (default-object? x) alien + (begin + (C->= alien "GdkRectangle x" x) + (if (default-object? y) alien + (begin + (C->= alien "GdkRectangle y" y) + (if (default-object? width) alien + (begin + (C->= alien "GdkRectangle width" width) + (if (default-object? height) alien + (begin + (C->= alien "GdkRectangle height" height) + alien)))))))))) + +(define (gdk-rectangle-from-rect rect) + (gdk-rectangle (fix-rect-x rect) (fix-rect-y rect) + (fix-rect-width rect) (fix-rect-height rect))) + + +(define %trace? #f) + +(define-syntax %trace + (syntax-rules () + ((_ ARGS ...) + (if %trace? (outf-error ARGS ...))))) + +(define %trace2? #f) + +(define-syntax %trace2 + (syntax-rules () + ((_ ARGS ...) + (if %trace2? (outf-error ARGS ...))))) diff --cc src/gtk/gdk.scm index 55cf01034,000000000..6d4445cfa mode 100644,000000..100644 --- a/src/gtk/gdk.scm +++ b/src/gtk/gdk.scm @@@ -1,343 -1,0 +1,343 @@@ +#| -*-Scheme-*- + +Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, + 2016, 2017 Matthew Birkholz + +This file is part of a Gtk plugin for MIT/GNU Scheme Pucked. + +This plugin is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This plugin is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this plugin; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. + +|# + +;;;; GDK Objects +;;; package: (gdk) + +(define-integrable-operator (guarantee-gdk-window object operator) + (if (not (and (alien? object) (eq? '|GdkWindow| (alien/ctype object)))) + (error:wrong-type-argument object "a GdkWindow address" operator))) + +(define (gdk-window-create-similar-surface window width height) + (assert-glib-locked 'gdk-window-create-similar-surface) + (let ((surface (make-alien '|cairo_surface_t|)) + (copy (make-alien '|cairo_surface_t|))) + (add-glib-cleanup surface (make-cairo-surface-cleanup copy)) + (C-call "gdk_window_create_similar_surface" copy + window (C-enum "CAIRO_CONTENT_COLOR") width height) + (copy-alien-address! surface copy) + (check-cairo-surface-status surface) + surface)) + +(define (gdk-window-create-similar-image-surface window width height scale) + (assert-glib-locked 'gdk-window-create-similar-image-surface) + (let ((surface (make-alien '|cairo_surface_t|)) + (copy (make-alien '|cairo_surface_t|))) + (add-glib-cleanup surface (make-cairo-surface-cleanup copy)) + (C-call "gdk_window_create_similar_image_surface" copy + window (C-enum "CAIRO_FORMAT_RGB24") width height scale) + (copy-alien-address! surface copy) + (check-cairo-surface-status surface) + surface)) + +;;; GdkPixbufLoaders + +(define-class ( (constructor ())) + () + (port define standard initial-value #f) + (thread define standard initial-value #f) + (size define standard initial-value #f) + (pixbuf define standard initial-value #f) + (error-message define standard initial-value #f) + (closed? define standard initial-value #f) + (size-hook define standard initial-value #f + modifier %set-pixbuf-loader-size-hook!) + (pixbuf-hook define standard initial-value #f + modifier %set-pixbuf-loader-pixbuf-hook!) + (update-hook define standard initial-value #f) + (close-hook define standard initial-value #f + modifier %set-pixbuf-loader-close-hook!)) + +(define-class ( (constructor ())) + ()) + +(define-method initialize-instance ((pixbuf )) + (call-next-method pixbuf) + (set-alien/ctype! (gobject-alien pixbuf) '|GdkPixbuf|)) + +(define-method initialize-instance ((loader )) + (call-next-method loader) + (assert-glib-locked '(initialize-instance )) + (C-call "gdk_pixbuf_loader_new" (gobject-alien loader)) + (g-signal-connect loader (C-callback "size_prepared") + pixbuf-loader-size-prepared) + (g-signal-connect loader (C-callback "area_prepared") + pixbuf-loader-area-prepared) + (g-signal-connect loader (C-callback "area_updated") + pixbuf-loader-area-updated)) + +(define (pixbuf-loader-size-prepared loader width height) + (%trace "; pixbuf-loader-size-prepared "loader" "width" "height"\n") + (assert-glib-locked 'pixbuf-loader-size-prepared) + (let ((size (pixbuf-loader-size loader))) + (if size (outf-error ";pixbuf loader already has a size: "loader"\n")) + (set-pixbuf-loader-size! loader (cons width height)) + (let ((receiver (pixbuf-loader-size-hook loader))) + (if receiver (receiver width height))))) + +(define (pixbuf-loader-area-prepared loader) + (%trace "; pixbuf-loader-area-prepared "loader"\n") + (assert-glib-locked 'pixbuf-loader-area-prepared) + (let* ((alien (gobject-alien loader)) + (pixbuf (let ((p (pixbuf-loader-pixbuf loader))) + (if p + (error "Pixbuf loader already has a pixbuf:" loader) + (make-pixbuf)))) + (pixbuf-alien (gobject-alien pixbuf))) + (C-call "gdk_pixbuf_loader_get_pixbuf" pixbuf-alien alien) + (C-call "g_object_ref" #f pixbuf-alien) + (set-pixbuf-loader-pixbuf! loader pixbuf) + (let ((receiver (pixbuf-loader-pixbuf-hook loader))) + (if receiver (receiver pixbuf))))) + +(define (pixbuf-loader-area-updated loader x y width height) + (%trace "; pixbuf-loader-area-updated "loader" "x","y" "width"x"height"\n") + (assert-glib-locked 'pixbuf-loader-area-updated) + (let ((receiver (pixbuf-loader-update-hook loader))) + (if receiver (receiver x y width height)))) + +(define (load-pixbuf-from-port loader input-port) + (if (pixbuf-loader-port loader) + (error "Pixbuf loader has already started:" loader)) + (set-pixbuf-loader-port! loader input-port) + (detach-thread (create-pixbuf-loader-thread loader)) + unspecific) + +(define (create-pixbuf-loader-thread loader) + (create-thread + #f + (named-lambda (load-pixbuf) + (%trace "; "loader" started in "(current-thread)"\n") + (set-pixbuf-loader-thread! loader (current-thread)) + (let ((port (pixbuf-loader-port loader)) + (alien (gobject-alien loader)) + (gerror* (make-gerror-pointer)) + (buffer (make-bytevector 4200))) + (C->= gerror* "* GError" 0) + + (define (note-done) + (assert-without-interruption 'load-pixbuf) + (gerror-pointer-free gerror*) + (set-pixbuf-loader-closed?! loader #t) + (close-input-port port) + (%trace "; "loader" closed by "(current-thread)"\n") + (let ((proc (pixbuf-loader-close-hook loader))) + (if proc + (proc loader))) + unspecific) + + (define (note-error) + (let* ((gerror (C-> gerror* "* GError")) + (message (or (and (not (alien-null? gerror)) + (c-peek-cstring + (C-> gerror "GError message"))) + "GError pointer not set."))) + (set-pixbuf-loader-error-message! loader message)) + (note-done)) + + (define-integrable (with-glib-atom thunk) + (with-glib-lock + (lambda () + (without-interruption thunk)))) + + (let loop () + (let ((n (read-bytevector! buffer port))) + (cond ((eof-object? n) + (with-glib-atom + (lambda () + (if (fix:zero? (C-call "gdk_pixbuf_loader_close" + alien gerror*)) + (note-error) + (note-done))))) + ((or (not (fix:fixnum? n)) + (fix:zero? n)) + (with-glib-atom note-error)) + ((not (fix:zero? + (with-glib-lock + (lambda () + (C-call "gdk_pixbuf_loader_write" + alien buffer n gerror*))))) + (loop)) + (else + (with-glib-atom note-error))))))))) + +(define (make-gerror-pointer) + (with-glib-lock + (lambda () + (let ((alien (make-alien '(* |GError|))) + (copy (make-alien '(* |GError|)))) + (add-glib-cleanup alien (make-gerror-pointer-cleanup copy)) + (C-call "g_try_malloc0" copy (C-sizeof "* GError")) + (copy-alien-address! alien copy) + (error-if-null alien "Could not create:" alien) + alien)))) + +(define (make-gerror-pointer-cleanup copy) + (named-lambda (cleanup-gerror-pointer) + (assert-glib-locked 'cleanup-gerror-pointer) + (assert-without-interruption 'cleanup-gerror-pointer) + (if (not (alien-null? copy)) + (let ((gerror (make-alien '|GError|))) + (C-> copy "* GError" gerror) + (if (not (alien-null? gerror)) + (C-call "g_error_free" gerror)) + (C-call "g_free" copy) + (alien-null! copy))))) + +(define (gerror-pointer-free gerror*) + (assert-glib-locked 'gerror-pointer-free) + (assert-without-interruption 'gerror-pointer-free) + (if (not (alien-null? gerror*)) + (begin + (execute-glib-cleanup gerror*) + (alien-null! gerror*)))) + +(define (load-pixbuf-from-file loader filename) + (load-pixbuf-from-port + loader (open-binary-input-file (->namestring (->truename filename))))) + +(define (set-pixbuf-loader-size-hook! loader receiver) + (assert-glib-locked 'set-pixbuf-loader-size-hook!) ; serialize with loader + (%set-pixbuf-loader-size-hook! loader receiver) + (let ((size (pixbuf-loader-size loader))) + (if size (receiver (car size) (cdr size))))) + +(define (set-pixbuf-loader-pixbuf-hook! loader receiver) + (assert-glib-locked 'set-pixbuf-loader-pixbuf-hook!) ; serialize with loader + (%set-pixbuf-loader-pixbuf-hook! loader receiver) + (let ((pixbuf (pixbuf-loader-pixbuf loader))) + (if pixbuf (receiver pixbuf)))) + +(define (set-pixbuf-loader-close-hook! loader thunk) + (assert-glib-locked 'set-pixbuf-loader-close-hook!) ; serialize with loader + (%set-pixbuf-loader-close-hook! loader thunk) + (if (pixbuf-loader-closed? loader) + (thunk))) + +;;; GdkDisplays + +(define-record-type + (make-gdk-display alien atoms clipboard queue callback-idv) + gdk-display? + (alien gdk-display/alien) + (atoms gdk-display/atoms set-gdk-display/atoms!) + (clipboard gdk-display/clipboard set-gdk-display/clipboard!) + (queue gdk-display/queue) + (callback-idv gdk-display/callback-idv)) + - (define displays (make-weak-eqv-hash-table)) ++(define displays (make-key-weak-eqv-hash-table)) + +(define (get-gdk-display alien) + (let ((bignum (alien/address alien))) - (or (hash-table/get displays bignum #f) ++ (or (hash-table-ref/default displays bignum #f) + (let ((alien (copy-alien alien)) + (callback-idv (vector #f)) + (queue (make-thread-queue 1))) + (let ((display (make-gdk-display alien '() #f queue callback-idv))) + (add-glib-cleanup display (make-gdk-display-cleanup callback-idv)) - (hash-table/put! displays bignum display) ++ (hash-table-set! displays bignum display) + display))))) + +(define (make-gdk-display-cleanup callback-idv) + (named-lambda (gdk-display-cleanup) + (cleanup-callback callback-idv))) + +(define (cleanup-callback callback-idv) + (let ((id (vector-ref callback-idv 0))) + (if id + (begin + (de-register-c-callback id) + (vector-set! callback-idv 0 #f))))) + +(define (clipboard display) + (assert-glib-locked 'clipboard) + (or (gdk-display/clipboard display) + (let ((atom (get-atom display '|CLIPBOARD|)) + (gdkdisplay (gdk-display/alien display)) + (clipboard (make-alien '|GtkClipboard|))) + (set-gdk-display/clipboard! display clipboard) + (C-call "gtk_clipboard_get_for_display" clipboard gdkdisplay atom) + clipboard))) + +(define (get-atom display symbol) + (assert-glib-locked 'get-atom) + (let ((entry (assq symbol (gdk-display/atoms display)))) + (if entry + (cdr entry) + (let ((atom (make-alien '(struct |_GdkAtom|)))) + (C-call "gdk_atom_intern" atom + (string->utf8 (symbol->string symbol)) 0) + (set-gdk-display/atoms! display + (cons (cons symbol atom) + (gdk-display/atoms display))) + atom)))) + +(define (gdk-display-set-clipboard-text display string) + (%trace "; gdk-display-set-clipboard-text "display"\n") + (assert-glib-locked 'gdk-display-set-clipboard-text) + (let ((string-bv (string->utf8 string))) + (C-call "gtk_clipboard_set_text" + (clipboard display) + string-bv (bytevector-length string-bv)))) + +(define (gdk-display-get-clipboard-text display msec) + (%trace "; gdk-display-get-clipboard-text "display" "msec"\n") + (assert-glib-locked 'gdk-display-get-clipboard-text) + (if (vector-ref (gdk-display/callback-idv display) 0) + (error "Operation pending:" display)) + (let ((queue (gdk-display/queue display)) + (callback-idv (gdk-display/callback-idv display))) + (%trace "; gdk-display-get-clipboard-text registering\n") + (let ((callback-id (make-text-callback-id queue))) + (vector-set! callback-idv 0 callback-id) + (thread-queue/empty! queue) + (C-call "gtk_clipboard_request_text" + (clipboard display) + (C-callback "receive_clipboard_text") + callback-id) + (%trace "; gdk-display-get-clipboard-text waiting\n") + (let ((text (thread-queue/dequeue-no-hang! queue msec))) + (%trace "; gdk-display-get-clipboard-text finishing\n") + (cleanup-callback callback-idv) + (if (string? text) + text + (error "Operation failed:" display)))))) + +(define (make-text-callback-id queue) + (C-callback + (named-lambda (gdk-display-get-clipboard-text-callback clipboard char*) + (declare (ignore clipboard)) + (if (alien-null? char*) + (queue! queue #t) + (queue! queue (c-peek-cstring char*)))))) + +(define (queue! queue value) + (thread-queue/queue! queue value) + (maybe-yield-glib)) + +(define %trace? #f) + +(define-syntax %trace + (syntax-rules () + ((_ ARGS ...) + (if %trace? (outf-error ARGS ...))))) diff --cc src/gtk/gtk.pkg index 890926540,000000000..2249c4e48 mode 100644,000000..100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@@ -1,446 -1,0 +1,444 @@@ +#| -*-Scheme-*- + +Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, + 2016, 2017 Matthew Birkholz + +This file is part of a Gtk plugin for MIT/GNU Scheme Pucked. + +This plugin is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This plugin is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this plugin; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. + +|# + +;;;; Gtk System Packaging + +(global-definitions runtime/) +(global-definitions ffi/) +(global-definitions sos/) +(global-definitions glib/) +(global-definitions pango/) +(global-definitions cairo/) + +(define-package (gtk) + (parent (glib))) + +(define-package (gtk internal) + (parent (gtk)) + (files "gtk") + ;;(depends-on "gtk-const.bin" "../glib/") + (import (pango) + ->color + pango-font-description-from-string + pango-layout-get-baseline + pango-layout-get-pixel-extents + pango-layout-index-to-pos + pango-layout-set-font-description + pango-layout-set-text + pango-layout-xy-to-index) + (import (cairo) + cairo-arc + cairo-clip + cairo-clip-extents + cairo-close-path + cairo-create + cairo-destroy + cairo-fill + cairo-fill-preserve + cairo-image-surface-create + cairo-line-to + cairo-matrix + cairo-move-to + cairo-paint + cairo-pattern-add-color-stop + cairo-pattern-create-radial + cairo-pattern-destroy + cairo-rectangle + cairo-rel-line-to + cairo-reset-clip + cairo-restore + cairo-save + cairo-scale + cairo-set-dash + cairo-set-font-matrix + cairo-set-line-width + cairo-set-operator + cairo-set-source + cairo-set-source-color + cairo-set-source-surface + cairo-show-pango-layout + cairo-show-text + cairo-stroke + cairo-stroke-preserve + cairo-surface-destroy + cairo-surface-flush + cairo-translate)) + +(define-package (gtk gdk) + (parent (gtk internal)) + (files "gdk") + ;;(depends-on "gtk-const.bin") + (import (cairo internal) + check-cairo-status + check-cairo-surface-status + make-cairo-cleanup + make-cairo-surface-cleanup) + (import (runtime ffi) + alien/address) + (import (glib main) + maybe-yield-glib) + (export (gtk) + gdk-window-create-similar-surface + gdk-window-create-similar-image-surface + make-pixbuf-loader + load-pixbuf-from-port load-pixbuf-from-file + pixbuf-loader-size-hook set-pixbuf-loader-size-hook! + pixbuf-loader-pixbuf-hook set-pixbuf-loader-pixbuf-hook! + pixbuf-loader-update-hook set-pixbuf-loader-update-hook! + pixbuf-loader-close-hook set-pixbuf-loader-close-hook! + pixbuf-loader-pixbuf pixbuf-loader-error-message + )) + +(define-package (gtk gtk-widget) + (parent (gtk internal)) + (files "gtk-widget") + ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi" "../pango/" "../glib/") + (export (gtk) + gtk-adjustment? guarantee-gtk-adjustment + make-gtk-adjustment set-gtk-adjustment! + gtk-widget? guarantee-gtk-widget + gtk-widget-destroyed? gtk-widget-destroy + gtk-widget-parent + gtk-widget-realized? + gtk-widget-drawable? gtk-widget-has-focus? + gtk-widget-grab-focus + gtk-widget-show + gtk-widget-show-all + gtk-widget-error-bell + gtk-widget-queue-draw + gtk-widget-queue-resize + gtk-widget-queue-resize-no-redraw + gtk-widget-get-pango-context + gtk-widget-create-pango-layout + gtk-widget-get-size + gtk-widget-set-hexpand + gtk-widget-set-vexpand + gtk-widget-set-size-request + ;;gtk-widget-set-can-focus + set-gtk-widget-size-allocate-callback! + set-gtk-widget-realize-callback! + set-gtk-widget-unrealize-callback! + set-gtk-widget-draw-callback! + set-gtk-widget-event-callback! + gtk-widget-set-opacity + gtk-widget-set-name + gtk-widget-get-style-context + gtk-style-context? + gtk-style-context-add-provider + + gtk-css-provider? guarantee-gtk-css-provider + gtk-css-provider-new + gtk-css-provider-get-default + gtk-css-provider-get-named + gtk-css-provider-load-from-data + gtk-css-provider-load-from-file + gtk-css-provider-load-from-path + + gtk-container? guarantee-gtk-container + gtk-container-children gtk-bin-child + gtk-container-add gtk-container-remove + gtk-container-set-border-width + + gtk-window? guarantee-gtk-window + gtk-window-new gtk-window-type + gtk-window-set-accept-focus + gtk-window-set-geometry-hints + gtk-window-set-title + gtk-window-set-type-hint + gtk-window-set-default-size gtk-window-get-default-size + gtk-window-resize + gtk-window-present + set-gtk-window-delete-event-callback! + gtk-clipboard-timeout + gtk-window-get-clipboard-text + gtk-window-set-clipboard-text + gtk-label? guarantee-gtk-label + gtk-label-new + gtk-label-get-text gtk-label-set-text + gtk-label-set-width-chars + gtk-button? guarantee-gtk-button + gtk-button-new + set-gtk-button-clicked-callback! + gtk-check-button? guarantee-gtk-check-button + gtk-check-button-new + gtk-check-button-get-active gtk-check-button-set-active + set-gtk-check-button-toggled-callback! + gtk-grid? guarantee-gtk-grid gtk-grid-new + gtk-grid-set-row-spacing + gtk-grid-set-column-spacing + gtk-grid-set-row-homogeneous + gtk-grid-set-column-homogeneous + gtk-grid-attach gtk-grid-attach-next-to + gtk-orientable-get-orientation gtk-orientable-set-orientation + gtk-frame? guarantee-gtk-frame gtk-frame-new + gtk-frame-set-shadow-type + gtk-scrolled-window? + guarantee-gtk-scrolled-window gtk-scrolled-window-new + gtk-scrolled-window-set-policy gtk-scrolled-window-set-placement + gtk-scrolled-view? gtk-scrolled-view-new + gtk-paned? gtk-paned-new + gtk-paned-pack1 gtk-paned-pack2 + gtk-paned-get-child1 gtk-paned-get-child2 + gtk-paned-get-position gtk-paned-set-position + gtk-paned-view? gtk-paned-view-new) + (import (pango internal) + make-pango-layout guarantee-pango-font-description) + (import (gio) gfile?) + (import (gtk gdk) + get-gdk-display + gdk-display-get-clipboard-text + gdk-display-set-clipboard-text)) + +(define-package (gtk widget) + (parent (gtk internal)) + (files "scm-widget") + ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi") + (import (gtk gtk-widget) + set-gtk-widget-destroy-callback!) + (export (gtk) + guarantee-scm-widget + set-scm-widget-set-scroll-adjustments-callback! + set-scm-widget-minimum-size! set-scm-widget-natural-size!)) + +(define-package (gtk fix-layout) + (parent (gtk internal)) + (files "fix-layout") + ;;(depends-on "pango" "cairo" "gtk.bin" "gtk" "../runtime/ffi" "gtk-const.bin") + (import (ffi) + find-c-includes + c-enum-constant-values) + (import (pango internal) + make-pango-layout pango-rectangle pangos->pixels pixels->pangos) + (import (glib thread) + glib-thread) + (import (gtk gtk-widget) + set-gtk-widget-destroy-callback! + gtk-widget-destroy-callback + gtk-widget-style-context) + (export (gtk) + fix-widget? + fix-widget-new-geometry-callback + fix-widget-realize-callback + fix-widget-unrealize-callback + set-fix-widget-pointer-shape! + set-fix-widget-enter-notify-handler! + set-fix-widget-leave-notify-handler! + set-fix-widget-focus-change-handler! + set-fix-widget-visibility-notify-handler! + set-fix-widget-key-press-handler! + set-fix-widget-motion-handler! + set-fix-widget-button-handler! + + fix-layout? make-fix-layout + fix-layout-view fix-layout-drawing set-fix-layout-drawing! + fix-layout-scroll-step set-fix-layout-scroll-step! + fix-layout-scroll-to! fix-layout-scroll-nw! + + guarantee-fix-drawing + make-fix-drawing fix-drawing-widgets + set-fix-drawing-size! fix-drawing-pick-list + fix-drawing-add-ink! + + fix-ink? + fix-ink-drawing + fix-ink-widgets set-fix-ink-widgets! + fix-ink-move! fix-ink-remove! + + + line-ink? make-line-ink set-line-ink! + line-ink-width set-line-ink-width! + line-ink-color set-line-ink-color! + line-ink-dash-color set-line-ink-dash-color! + line-ink-dashes set-line-ink-dashes! + + rectangle-ink? make-rectangle-ink + set-rectangle-ink! set-rectangle-ink-position! + rectangle-ink-color set-rectangle-ink-color! + rectangle-ink-width set-rectangle-ink-width! + rectangle-ink-fill-color set-rectangle-ink-fill-color! + + polygon-ink? make-polygon-ink set-polygon-ink! + polygon-ink-color set-polygon-ink-color! + polygon-ink-width set-polygon-ink-width! + polygon-ink-fill-color set-polygon-ink-fill-color! + + arc-ink? make-arc-ink set-arc-ink! + arc-ink-start-angle set-arc-ink-start-angle! + arc-ink-sweep-angle set-arc-ink-sweep-angle! + arc-ink-color set-arc-ink-color! + arc-ink-width set-arc-ink-width! + arc-ink-fill-color set-arc-ink-fill-color! + + text-ink? + set-text-ink-position! + text-ink-xy-to-index + with-text-ink-grapheme-rect + text-ink-color set-text-ink-color! + + simple-text-ink? make-simple-text-ink + simple-text-ink-text set-simple-text-ink-text! + simple-text-ink-font set-simple-text-ink-font! + + make-image-ink-from-file set-image-ink! + + surface-ink? make-surface-ink + surface-ink-surface set-surface-ink-position! + surface-ink-flush + )) + +(define-package (gtk keys) + (parent (gtk internal)) + (files "keys") + ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi" "gtk-const.bin") + (export (gtk) + gdk-key-state->char-bits + gdk-keyval->name) + (import (ffi) + find-c-includes + c-enum-constant-values)) + +(define-package (gtk main) + (parent (gtk internal)) + (files "main") + ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi") - (import (runtime load) - *unused-command-line* - hook/process-command-line - default/process-command-line) ++ (import (runtime command-line) ++ *command-line-arguments*) + (import (runtime) + ucode-primitive) + (import (gtk gtk-widget) + toplevel-windows) + (export () + gtk-initialized? + gtk-time-slice-window? + gtk-time-slice-window!)) + +(define-package (gtk event-viewer) + (parent (gtk internal)) + (files "gtk-ev") + ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi") + (import (gtk fix-layout) + gdk-rectangle gdk-rectangle-from-rect + make-fix-rect + fix-rect-x fix-rect-y fix-rect-width fix-rect-height + fix-rect-max-y set-fix-rect! fix-rect-union!) + (import (pango internal) + pango-rectangle pangos->pixels) + (export () + make-gtk-event-viewer-demo)) + +(define-package (runtime gtk-graphics) + (parent (gtk internal)) + (files "gtk-graphics") + (import (gtk fix-layout) + fix-ink-extent fix-rect-height fix-rect-width + set-surface-ink-surface! drawing-damage) + (export () + gtk-graphics/set-background-color + gtk-graphics/set-foreground-color + gtk-graphics/draw-line + gtk-graphics/draw-text + gtk-graphics/draw-circle + gtk-graphics/fill-polygon-list + gtk-graphics/clear + gtk-graphics/flush)) + +(define-package (gtk fix-layout demo) + (parent (gtk fix-layout)) + (files "fix-demo") + (import (cairo internal) + cairo-identity-matrix cairo-matrix-scale! cairo-matrix-translate! + cairo-point x y cairo-transform! guarantee-flonum) + (export () + make-fix-layout-demo)) + +(define-package (gtk swat) + (parent (gtk internal)) + (files "swat") + (import (runtime thread-queue) + thread-queue/peek-until) + (import (gtk gtk-widget) + gtk-widget-destroy-callback) + (import (gtk fix-layout) + fix-layout-view fix-ink-extent fix-ink-draw-callback + fix-drawing-display-list set-fix-drawing-display-list! + set-fix-ink-drawing! fix-ink-in-widget? fix-ink-in? + line-ink-vector + fix-rect-x fix-rect-y with-fix-rect + set-fix-rect-size! fix-rect-move! copy-fix-rect! + point-in-fix-rect? fix-rect-union!) + (import (cairo internal) + cairo-point x y set-x! set-y! cairo-transform! + cairo-rotation-matrix cairo-matrix-scale! cairo-matrix-translate!) + (export (swat) + add-child! remove-child! ask-widget + add-event-handler! set-callback! + after-delay on-death! + swat-open swat-close + make-active-variable set-active-variable! + make-hbox make-vbox box-children + make-button make-label + make-checkbutton checkbutton-variable-on? + make-canvas make-canvas-item-group + make-line-on-canvas make-rectangle-on-canvas + make-oval-on-canvas make-text-on-canvas)) + +(define-package (swat) + (parent ())) + +#;(define-package (swat examples) + (parent (swat)) + (files "swat-examples")) + +(define-package (swat pole-zero) + (parent (swat)) + (files "swat-pole-zero") + (export () + make-pole-zero)) + +#;(define-package (swat plotter) + (parent (swat)) + (files "swat-plotter") + (export () + plotter + plot + set-plotter-params + reset-plotter-params + make-vals + change-color + change-pt-style + change-num-pts + clear-curve + plot-curve + delete-curve + add-show-vals + clear-show-vals + draw-show-vals + delete-show-vals + add-xticks + add-yticks + clear-ticks + draw-ticks + delete-ticks + clear-plotter + replot + reset-plotter)) diff --cc src/gtk/main.scm index 2996a480f,000000000..74e32fa30 mode 100644,000000..100644 --- a/src/gtk/main.scm +++ b/src/gtk/main.scm @@@ -1,119 -1,0 +1,117 @@@ +#| -*-Scheme-*- + +Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, + 2016, 2017 Matthew Birkholz + +This file is part of a Gtk plugin for MIT/GNU Scheme Pucked. + +This plugin is free software; you can redistribute it and/or modify it +under the terms of the GNU General Public License as published by the +Free Software Foundation; either version 2 of the License, or (at your +option) any later version. + +This plugin is distributed in the hope that it will be useful, but +WITHOUT ANY WARRANTY; without even the implied warranty of +MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU +General Public License for more details. + +You should have received a copy of the GNU General Public License +along with this plugin; if not, write to the Free Software Foundation, +Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. + +|# + +;;;; Initialize per $DISPLAY. +;;; package: (gtk main) + +(define initialized?) + +(define (gtk-initialized?) + initialized?) + +(define (gtk-start) + ;; Called from gtk/make.scm, from a (load-option 'Gtk). - (init-gtk ((ucode-primitive scheme-program-name 0)) *unused-command-line*)) ++ (init-gtk ((ucode-primitive scheme-program-name 0)) ++ (command-line-arguments))) + +(define (initialize-package!) + (reset-gtk!) + (add-event-receiver! event:after-restore reset-gtk!) - (let ((program-name ((ucode-primitive scheme-program-name 0)))) - (let ((processor hook/process-command-line)) - (set! hook/process-command-line - (lambda (line) - (processor - (let ((val (ignore-errors - (lambda () - (init-gtk program-name (vector->list line)))))) - (if (condition? val) - (begin - (warn val) - line) - (list->vector val))))))))) ++ (restart-gtk!) ++ (add-event-receiver! event:after-restart restart-gtk!)) ++ ++(define (restart-gtk!) ++ (let* ((program-name ((ucode-primitive scheme-program-name 0))) ++ (val (ignore-errors ++ (lambda () (init-gtk program-name (command-line-arguments)))))) ++ (if (condition? val) ++ (warn val) ++ (set! *command-line-arguments* val)))) + +(define (reset-gtk!) + (for-each (lambda (w) + (alien-null! (gobject-alien w))) + toplevel-windows) + (set! toplevel-windows '()) + (set! initialized? #f)) + +(define (init-gtk name args) + (if (let ((s (get-environment-variable "DISPLAY"))) + (and (string? s) (not (string-null? s)))) + (init-gtk* name args) + (warn "DISPLAY not set"))) + +(define (init-gtk* name args) + ;; Call gtk_init_check. Warn if it returns 0. Return a list of + ;; unused ARGS. + (let ((arg-count (guarantee-list-of-type->length + args string? "list of commandline arguments (strings)" + 'INIT-GTK)) + (vars-size (+ (C-sizeof "int") ;gtk_init_check return var + (C-sizeof "* * char")))) ;gtk_init_check return var + (guarantee string? name 'INIT-GTK) + (let* ((words (cons name args)) + (words-bv (map string->utf8 words)) + (vector-size + (* (C-sizeof "* char") (+ 1 arg-count))) + (total-size + (+ vars-size vector-size + (fold-left (lambda (sum arg) + (+ sum (bytevector-length arg) 1)) ;null terminated + 0 words-bv))) + (bytes (malloc total-size #f)) + (vector (alien-byte-increment bytes vars-size)) + (word-scan (alien-byte-increment vector vector-size)) + (vector-scan (copy-alien vector)) + (count-var bytes) + (vector-var (alien-byte-increment count-var (C-sizeof "int")))) + (for-each (lambda (word-bv) + (c-poke-pointer! vector-scan word-scan) + (c-poke-string! word-scan word-bv)) + words-bv) + (C->= count-var "int" (+ 1 arg-count)) + (C->= vector-var "* * char" vector) + (if (fix:zero? (with-glib-lock + (lambda () + (C-call "gtk_init_check" count-var vector-var)))) + (warn "Could not initialize Gtk.") + (let ((new-argc (C-> count-var "int"))) + (C-> vector-var "* * char" vector-scan) + (let ((new-args + (let loop ((i 0)(args '())) + (if (fix:< i new-argc) + (loop (fix:1+ i) + (cons (c-peek-cstringp! vector-scan) + args)) + (reverse! args))))) + (free bytes) + (set! initialized? #t) + (cdr new-args))))))) + +(define (gtk-time-slice-window?) + (C-call "gtk_time_slice_window_p")) + +(define (gtk-time-slice-window! open?) + (with-glib-lock (lambda () (C-call "gtk_time_slice_window" (if open? 1 0))))) + +(initialize-package!) diff --cc src/gtk/tags-fix.sh index c2823ad7f,000000000..aee615c48 mode 100755,000000..100755 --- a/src/gtk/tags-fix.sh +++ b/src/gtk/tags-fix.sh @@@ -1,42 -1,0 +1,42 @@@ +#!/bin/sh +# -*-Scheme-*- +# +# Chop the generated $1-shim.c and $1-const.c files out of TAGS. + +set -e +: ${MIT_SCHEME_EXE=mit-scheme} +${MIT_SCHEME_EXE} --batch-mode -- "${@}" <<\EOF - (let ((name (car (command-line)))) ++(let ((name (car (command-line-arguments)))) + (let ((shim.c-prefix (string-append name "-shim.c,")) + (const.c-prefix (string-append name "-const.c,"))) + + (define (rewriter in out) + (let loop ((skipping? #f)) + (let ((line (read-line in))) + (cond ((eof-object? line) + unspecific) + ((string=? line "\f") + (let ((next (read-line in))) + (cond ((eof-object? next) (error "Bogus TAGS format:" next)) + ((or (string-prefix? shim.c-prefix next) + (string-prefix? const.c-prefix next)) + (loop #t)) + (else + (write-string line out) + (newline out) + (write-string next out) + (newline out) + (loop #f))))) + (skipping? + (loop skipping?)) + (else + (write-string line out) + (newline out) + (loop skipping?)))))) + + (parameterize ((param:suppress-loading-message? #t)) + (load-option 'FFI)) + ((access rewrite-file (->environment '(ffi build))) + (merge-pathnames "TAGS") + rewriter))) +EOF diff --cc src/imail/make.scm index d6cd53736,000000000..7d789193f mode 100644,000000..100644 --- a/src/imail/make.scm +++ b/src/imail/make.scm @@@ -1,36 -1,0 +1,36 @@@ +#| -*-Scheme-*- + +Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994, + 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005, + 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016 + Massachusetts Institute of Technology + +This file is part of the IMail option for MIT/GNU Scheme. + +IMail is free software; you can redistribute it and/or modify it under +the terms of the GNU General Public License as published by the Free +Software Foundation; either version 2 of the License, or (at your +option) any later version. + +IMail is distributed in the hope that it will be useful, but WITHOUT +ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or +FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License +for more details. + +You should have received a copy of the GNU General Public License +along with IMail; if not, write to the Free Software Foundation, Inc., +51 Franklin St, Fifth Floor, Boston, MA 02110-1301, USA. + +|# + +;;;; IMAIL mail reader: loader + - (load-option 'REGULAR-EXPRESSION) - (load-option 'WT-TREE) - (load-option 'SOS) - (load-option 'EDWIN) ++(load-option 'regular-expression) ++(load-option 'wt-tree) ++(load-option 'sos) ++(load-option 'edwin) +(with-loader-base-uri (system-library-uri "imail/") + (lambda () + (fluid-let ((*allow-package-redefinition?* #t)) + (load-package-set "imail")))) +(add-subsystem-identification! "IMAIL" '(1 21 2)) diff --cc src/mcrypt/tags-fix.sh index 14e5e8636,14e5e8636..a22e6bab5 --- a/src/mcrypt/tags-fix.sh +++ b/src/mcrypt/tags-fix.sh @@@ -6,7 -6,7 +6,7 @@@ set -e : ${MIT_SCHEME_EXE=mit-scheme} ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF --(let ((name (car (command-line)))) ++(let ((name (car (command-line-arguments)))) (let ((shim.c-prefix (string-append name "-shim.c,")) (const.c-prefix (string-append name "-const.c,"))) diff --cc src/pango/tags-fix.sh index c2823ad7f,000000000..aee615c48 mode 100755,000000..100755 --- a/src/pango/tags-fix.sh +++ b/src/pango/tags-fix.sh @@@ -1,42 -1,0 +1,42 @@@ +#!/bin/sh +# -*-Scheme-*- +# +# Chop the generated $1-shim.c and $1-const.c files out of TAGS. + +set -e +: ${MIT_SCHEME_EXE=mit-scheme} +${MIT_SCHEME_EXE} --batch-mode -- "${@}" <<\EOF - (let ((name (car (command-line)))) ++(let ((name (car (command-line-arguments)))) + (let ((shim.c-prefix (string-append name "-shim.c,")) + (const.c-prefix (string-append name "-const.c,"))) + + (define (rewriter in out) + (let loop ((skipping? #f)) + (let ((line (read-line in))) + (cond ((eof-object? line) + unspecific) + ((string=? line "\f") + (let ((next (read-line in))) + (cond ((eof-object? next) (error "Bogus TAGS format:" next)) + ((or (string-prefix? shim.c-prefix next) + (string-prefix? const.c-prefix next)) + (loop #t)) + (else + (write-string line out) + (newline out) + (write-string next out) + (newline out) + (loop #f))))) + (skipping? + (loop skipping?)) + (else + (write-string line out) + (newline out) + (loop skipping?)))))) + + (parameterize ((param:suppress-loading-message? #t)) + (load-option 'FFI)) + ((access rewrite-file (->environment '(ffi build))) + (merge-pathnames "TAGS") + rewriter))) +EOF diff --cc src/pgsql/tags-fix.sh index 14e5e8636,14e5e8636..a22e6bab5 --- a/src/pgsql/tags-fix.sh +++ b/src/pgsql/tags-fix.sh @@@ -6,7 -6,7 +6,7 @@@ set -e : ${MIT_SCHEME_EXE=mit-scheme} ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF --(let ((name (car (command-line)))) ++(let ((name (car (command-line-arguments)))) (let ((shim.c-prefix (string-append name "-shim.c,")) (const.c-prefix (string-append name "-const.c,"))) diff --cc src/runtime/ed-ffi.scm index d0cc48175,7d869630a..5ab540819 --- a/src/runtime/ed-ffi.scm +++ b/src/runtime/ed-ffi.scm @@@ -116,18 -117,21 +116,20 @@@ USA ("option" (runtime options)) ("optiondb" ()) ("ordvec" (runtime ordered-vector)) - ("output" (runtime output-port)) + ("output-port" (runtime output-port)) ("packag" (package)) - ("parse" (runtime parser)) ("parser-buffer" (runtime parser-buffer)) - ("pathnm" (runtime pathname)) + ("pathname" (runtime pathname)) - ("pgsql" (runtime postgresql)) ("poplat" (runtime population)) - ("port" (runtime port)) ("pp" (runtime pretty-printer)) ("prgcop" (runtime program-copier)) + ("primitive-arithmetic" (runtime primitive-arithmetic)) + ("primitive-io" (runtime primitive-io)) + ("printer" (runtime printer)) + ("procedure" (runtime procedure)) ("process" (runtime subprocess)) ("prop1d" (runtime 1d-property)) - ("prop2d" (runtime 2D-property)) + ("prop2d" (runtime 2d-property)) ("qsort" (runtime quick-sort)) ("queue" (runtime simple-queue)) ("random" (runtime random-number)) diff --cc src/runtime/global.scm index 82e4bf5e2,a60add01d..1f3ab3fa3 --- a/src/runtime/global.scm +++ b/src/runtime/global.scm @@@ -155,35 -143,9 +143,35 @@@ USA (call-with-truncated-output-string max (lambda (port) (write object port))))) + +(define (edit . args) + (let ((env (let ((package (name->package '(edwin)))) + (and package (package/environment package))))) + (if env + (apply (environment-lookup env 'edit) args) + (begin + (with-notification + (lambda (port) (display "Loading Edwin" port)) + (lambda () + (parameterize* + (list (cons param:suppress-loading-message? #t)) + (lambda () + (load-option 'EDWIN) + (if (let ((DISPLAY (get-environment-variable "DISPLAY"))) + (and (string? DISPLAY) + (not (string-null? DISPLAY)))) + (ignore-errors (lambda () (load-option 'x11-screen)))))))) + (apply (environment-lookup (->environment '(edwin)) 'edit) args))))) + +(define edwin edit) + +(define (spawn-edwin . args) + (let ((thread (create-thread #f (lambda () (apply edwin args))))) + (detach-thread thread) + thread)) (define (pa procedure) - (guarantee procedure? procedure 'PA) + (guarantee procedure? procedure 'pa) (cond ((procedure-lambda procedure) => (lambda (scode) (pp (unsyntax-lambda-list scode)))) diff --cc src/runtime/make.scm index 07c3e69b0,49f0ca1b4..f1fa4705c --- a/src/runtime/make.scm +++ b/src/runtime/make.scm @@@ -449,111 -447,108 +447,106 @@@ USA (package-initialization-sequence '( ;; Microcode interface - ((RUNTIME MICROCODE-TABLES) READ-MICROCODE-TABLES!) - (RUNTIME APPLY) - (RUNTIME PRIMITIVE-IO) - (RUNTIME SYSTEM-CLOCK) - ((RUNTIME GC-FINALIZER) INITIALIZE-EVENTS!) + (runtime microcode-tables) + (runtime apply) + (runtime primitive-io) + (runtime system-clock) + ((runtime gc-finalizer) initialize-events!) ;; Basic data structures - (RUNTIME NUMBER) - ((RUNTIME NUMBER) INITIALIZE-DRAGON4!) - (RUNTIME MISCELLANEOUS-GLOBAL) - (RUNTIME CHARACTER) - (RUNTIME BYTEVECTOR) - (RUNTIME CHARACTER-SET) - (RUNTIME LAMBDA-ABSTRACTION) - (RUNTIME USTRING) - (RUNTIME GENSYM) - (RUNTIME STREAM) - (RUNTIME 2D-PROPERTY) - (RUNTIME HASH-TABLE) - (RUNTIME MEMOIZER) - (RUNTIME UCD-TABLES) - (RUNTIME UCD-GLUE) - (RUNTIME PREDICATE-METADATA) - (RUNTIME PREDICATE-LATTICE) - (RUNTIME PREDICATE-TAGGING) - (RUNTIME PREDICATE-DISPATCH) - (RUNTIME COMPOUND-PREDICATE) - (RUNTIME PARAMETRIC-PREDICATE) - (RUNTIME HASH) - (RUNTIME DYNAMIC) - (RUNTIME REGULAR-SEXPRESSION) + (runtime number) + ((runtime number) initialize-dragon4!) + (runtime miscellaneous-global) + (runtime character) + (runtime bytevector) + (runtime character-set) + (runtime lambda-abstraction) + (runtime string) + (runtime stream) + (runtime 2d-property) + (runtime hash-table) + (runtime memoizer) + (runtime ucd-tables) + (runtime ucd-glue) - (runtime blowfish) + (runtime predicate) + (runtime predicate-tagging) + (runtime predicate-dispatch) + (runtime compound-predicate) + (runtime parametric-predicate) + (runtime hash) + (runtime dynamic) + (runtime regular-sexpression) ;; Microcode data structures - (RUNTIME HISTORY) - (RUNTIME SCODE) - (RUNTIME SCODE-WALKER) - (RUNTIME CONTINUATION-PARSER) - (RUNTIME PROGRAM-COPIER) - ;; Generic Procedures - ((RUNTIME GENERIC-PROCEDURE EQHT) INITIALIZE-ADDRESS-HASHING!) - ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-GENERIC-PROCEDURES!) - ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-MULTIPLEXER!) - ((RUNTIME TAGGED-VECTOR) INITIALIZE-TAGGED-VECTOR!) - ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-RECORD-SLOT-ACCESS!) - ((RUNTIME RECORD) INITIALIZE-RECORD-PROCEDURES!) - ((PACKAGE) FINALIZE-PACKAGE-RECORD-TYPE!) - ((RUNTIME RANDOM-NUMBER) FINALIZE-RANDOM-STATE-TYPE!) + (runtime history) + (runtime scode) + (runtime scode-walker) + (runtime continuation-parser) + (runtime program-copier) + ;; Finish records + ((runtime record) initialize-record-procedures!) + ((package) finalize-package-record-type!) + ((runtime random-number) finalize-random-state-type!) ;; Condition System - (RUNTIME ERROR-HANDLER) - (RUNTIME MICROCODE-ERRORS) - ((RUNTIME GENERIC-PROCEDURE) INITIALIZE-CONDITIONS!) - ((RUNTIME GENERIC-PROCEDURE MULTIPLEXER) INITIALIZE-CONDITIONS!) - ((RUNTIME RECORD-SLOT-ACCESS) INITIALIZE-CONDITIONS!) - ((RUNTIME STREAM) INITIALIZE-CONDITIONS!) - ((RUNTIME REGULAR-SEXPRESSION) INITIALIZE-CONDITIONS!) + (runtime error-handler) + (runtime microcode-errors) + ((runtime record) initialize-conditions!) + ((runtime stream) initialize-conditions!) + ((runtime regular-sexpression) initialize-conditions!) ;; System dependent stuff - ((RUNTIME OS-PRIMITIVES) INITIALIZE-SYSTEM-PRIMITIVES!) + (runtime os-primitives) ;; Floating-point environment -- needed by threads. - (RUNTIME FLOATING-POINT-ENVIRONMENT) - ((RUNTIME THREAD) INITIALIZE-HIGH!) + (runtime floating-point-environment) + ((runtime thread) initialize-high!) ;; I/O - (RUNTIME BINARY-PORT) - (RUNTIME PORT) - (RUNTIME OUTPUT-PORT) - (RUNTIME GENERIC-I/O-PORT) - (RUNTIME FILE-I/O-PORT) - (RUNTIME CONSOLE-I/O-PORT) - (RUNTIME SOCKET) - (RUNTIME STRING-I/O-PORT) - (RUNTIME USER-INTERFACE) + (runtime port) + (runtime output-port) + (runtime generic-i/o-port) + (runtime file-i/o-port) + (runtime console-i/o-port) + (runtime socket) + (runtime string-i/o-port) + (runtime user-interface) ;; These MUST be done before (RUNTIME PATHNAME) ;; Typically only one of them is loaded. - (RUNTIME PATHNAME UNIX) - (RUNTIME PATHNAME DOS) - (RUNTIME PATHNAME) - (RUNTIME DIRECTORY) - (RUNTIME WORKING-DIRECTORY) - (RUNTIME LOAD) - (RUNTIME SIMPLE-FILE-OPS) - (OPTIONAL (RUNTIME OS-PRIMITIVES) INITIALIZE-MIME-TYPES!) + (runtime pathname unix) + (runtime pathname dos) + (runtime pathname) + (runtime directory) + (runtime working-directory) + (runtime load) + (runtime command-line) + (runtime simple-file-ops) + (optional (runtime os-primitives) initialize-mime-types!) ;; Syntax - (RUNTIME NUMBER-PARSER) - (RUNTIME OPTIONS) - (RUNTIME PARSER) - (RUNTIME FILE-ATTRIBUTES) - ((RUNTIME PATHNAME) INITIALIZE-PARSER-METHOD!) - (RUNTIME UNPARSER) - (RUNTIME UNSYNTAXER) - (RUNTIME PRETTY-PRINTER) - (RUNTIME EXTENDED-SCODE-EVAL) - (RUNTIME SYNTAX DEFINITIONS) - (RUNTIME SYNTAX OUTPUT) + (runtime number-parser) + (runtime options) + (runtime reader) + (runtime file-attributes) + ((runtime pathname) initialize-parser-method!) + (runtime printer) + (runtime unsyntaxer) + (runtime pretty-printer) + (runtime extended-scode-eval) + (runtime syntax items) + (runtime syntax rename) + (runtime syntax top-level) + (runtime syntax parser) + ;; R7RS Libraries + (runtime library standard) ;; REP Loops - (RUNTIME INTERRUPT-HANDLER) - (RUNTIME GC-STATISTICS) - (RUNTIME GC-NOTIFICATION) - (RUNTIME REP) + (runtime interrupt-handler) + (runtime gc-statistics) + (runtime gc-notification) + (runtime rep) ;; Debugging - (RUNTIME COMPILER-INFO) - (RUNTIME ADVICE) - (RUNTIME DEBUGGER-COMMAND-LOOP) - (RUNTIME DEBUGGER-UTILITIES) - (RUNTIME ENVIRONMENT-INSPECTOR) - (RUNTIME DEBUGGING-INFO) - (RUNTIME DEBUGGER) + (runtime compiler-info) + (runtime advice) + (runtime debugger-command-loop) + (runtime debugger-utilities) + (runtime environment-inspector) + (runtime debugging-info) + (runtime debugger) ;; Misc (e.g., version) - (RUNTIME) + (runtime) - (runtime crypto) ;; Graphics. The last type initialized is the default for ;; MAKE-GRAPHICS-DEVICE, only the types that are valid for the ;; operating system are actually loaded and initialized. diff --cc src/runtime/mit-macros.scm index 35a40e1f1,74aaf0319..76cb2927e --- a/src/runtime/mit-macros.scm +++ b/src/runtime/mit-macros.scm @@@ -89,11 -712,11 +712,13 @@@ USA (define (define-feature name procedure) (set! supported-features (cons (cons name procedure) supported-features)) name) - + + (define supported-features '()) + (define (always) #t) +(define-feature 'pucked always) + (define-feature 'mit always) (define-feature 'mit/gnu always) diff --cc src/runtime/optiondb.scm index 2fd41a45a,6d4925263..a7d2802ff --- a/src/runtime/optiondb.scm +++ b/src/runtime/optiondb.scm @@@ -63,19 -63,21 +63,19 @@@ USA (for-each (lambda (spec) (define-load-option (car spec) (apply standard-option-loader (cdr spec)))) - '((COMPRESS (RUNTIME COMPRESS) #F "cpress") - (DOSPROCESS () #F "dosproc") - (FORMAT (RUNTIME FORMAT) (INITIALIZE-PACKAGE!) "format") - (MIME-CODEC (RUNTIME MIME-CODEC) #F "mime-codec") - (ORDERED-VECTOR (RUNTIME ORDERED-VECTOR) #F "ordvec") - (RB-TREE (RUNTIME RB-TREE) #F "rbtree") - (STEPPER (RUNTIME STEPPER) #F "ystep") - (SUBPROCESS (RUNTIME SUBPROCESS) (INITIALIZE-PACKAGE!) "process") - (SYNCHRONOUS-SUBPROCESS (RUNTIME SYNCHRONOUS-SUBPROCESS) #F "syncproc") - (WT-TREE (RUNTIME WT-TREE) #F "wttree") + '((compress (runtime compress) #f "cpress") + (dosprocess () #f "dosproc") + (format (runtime format) (initialize-package!) "format") - (gdbm (runtime gdbm) #f "gdbm") + (mime-codec (runtime mime-codec) #f "mime-codec") + (ordered-vector (runtime ordered-vector) #f "ordvec") - (postgresql (runtime postgresql) #f "pgsql") + (rb-tree (runtime rb-tree) #f "rbtree") + (stepper (runtime stepper) #f "ystep") + (subprocess (runtime subprocess) (initialize-package!) "process") + (synchronous-subprocess (runtime synchronous-subprocess) #f "syncproc") + (wt-tree (runtime wt-tree) #f "wttree") )) - (define-load-option 'REGULAR-EXPRESSION + (define-load-option 'regular-expression (standard-option-loader '(runtime regular-expression-compiler) #f "rgxcmp") diff --cc src/runtime/runtime.pkg index f509528ba,bdc41fd0b..50cbe78d3 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@@ -437,10 -528,7 +512,9 @@@ USA cell-contents cell? constant-procedure - default/exit - default/quit + edit + edwin + emergency-exit ;R7RS environment-link-name ephemeron-broken? ephemeron-datum @@@ -4231,17 -4239,134 +4226,8 @@@ image/width image? make-graphics-device - make-graphics-device-type) - (export (runtime x-graphics) - make-image-type)) - -(define-package (runtime x-graphics) - (file-case os-type - ((unix) "x11graph") - (else)) - (parent (runtime)) - (export () - create-x-colormap - create-x-image - x-character-bounds/ascent - x-character-bounds/descent - x-character-bounds/lbearing - x-character-bounds/rbearing - x-character-bounds/width - x-close-all-displays - x-colormap/allocate-color - x-colormap/free - x-colormap/query-color - x-colormap/store-color - x-colormap/store-colors - x-colormap? - x-display/name - x-display/properties - x-font-structure/all-chars-exist? - x-font-structure/character-bounds - x-font-structure/default-char - x-font-structure/direction - x-font-structure/max-ascent - x-font-structure/max-bounds - x-font-structure/max-descent - x-font-structure/min-bounds - x-font-structure/name - x-font-structure/start-index - x-geometry-string - x-graphics-default-display-name - x-graphics-default-geometry - x-graphics-device-type - x-graphics/available? - x-graphics/clear - x-graphics/close-display - x-graphics/close-window - x-graphics/color? - x-graphics/coordinate-limits - x-graphics/copy-area - x-graphics/device-coordinate-limits - x-graphics/disable-keyboard-focus - x-graphics/discard-events - x-graphics/display - x-graphics/drag-cursor - x-graphics/draw-arc - x-graphics/draw-circle - x-graphics/draw-line - x-graphics/draw-lines - x-graphics/draw-point - x-graphics/draw-points - x-graphics/draw-text - x-graphics/enable-keyboard-focus - x-graphics/fill-circle - x-graphics/flush - x-graphics/font-structure - x-graphics/get-colormap - x-graphics/get-default - x-graphics/iconify-window - x-graphics/image-depth - x-graphics/lower-window - x-graphics/map-window - x-graphics/move-cursor - x-graphics/move-window - x-graphics/open-display - x-graphics/open-display? - x-graphics/open-window? - x-graphics/query-pointer - x-graphics/raise-window - x-graphics/read-button - x-graphics/read-user-event - x-graphics/reset-clip-rectangle - x-graphics/resize-window - x-graphics/select-user-events - x-graphics/set-background-color - x-graphics/set-border-color - x-graphics/set-border-width - x-graphics/set-clip-rectangle - x-graphics/set-colormap - x-graphics/set-coordinate-limits - x-graphics/set-drawing-mode - x-graphics/set-font - x-graphics/set-foreground-color - x-graphics/set-icon-name - x-graphics/set-input-hint - x-graphics/set-internal-border-width - x-graphics/set-line-style - x-graphics/set-mouse-color - x-graphics/set-mouse-shape - x-graphics/set-window-name - x-graphics/visual-info - x-graphics/window-id - x-graphics/withdraw-window - x-graphics:auto-raise? - x-image/destroy - x-image/draw - x-image/draw-subimage - x-image/fill-from-byte-vector - x-image/get-pixel - x-image/height - x-image/set-pixel - x-image/width - x-image? - x-visual-class:direct-color - x-visual-class:gray-scale - x-visual-class:pseudo-color - x-visual-class:static-color - x-visual-class:static-gray - x-visual-class:true-color - x-visual-info/bits-per-rgb - x-visual-info/blue-mask - x-visual-info/class - x-visual-info/colormap-size - x-visual-info/depth - x-visual-info/green-mask - x-visual-info/red-mask - x-visual-info/screen - x-visual-info/visual - x-visual-info/visual-id) - (initialization (initialize-package!))) + make-graphics-device-type)) - (define-package (runtime starbase-graphics) - (file-case os-type - ((unix) "starbase") - (else)) - (parent (runtime)) - (export () - starbase-graphics-device-type) - (initialization (initialize-package!))) - (define-package (runtime state-space) (files "wind") (parent (runtime)) @@@ -4953,91 -5164,64 +5027,35 @@@ ordered-vector-minimum-match search-ordered-subvector search-ordered-vector)) - -(define-package (runtime gdbm) - (file-case options - ((load) "gdbm") - (else)) - (parent (runtime)) - (export () - gdbm-available? - gdbm-close - gdbm-delete - gdbm-exists? - gdbm-fetch - gdbm-firstkey - gdbm-nextkey - gdbm-open - gdbm-reorganize - gdbm-setopt - gdbm-store - gdbm-sync - gdbm-version - gdbm_cachesize - gdbm_fast - gdbm_fastmode - gdbm_insert - gdbm_newdb - gdbm_reader - gdbm_replace - gdbm_wrcreat - gdbm_writer)) - (define-package (runtime generic-procedure) - (files "gentag" "gencache" "generic") - (parent (runtime)) - (export () - dispatch-tag-contents + (define-package (runtime tagged-dispatch) + (files "dispatch-tag" "dispatch-cache") + (parent (runtime)) + (export () + dispatch-metatag-constructor + dispatch-metatag? + dispatch-tag->predicate + dispatch-tag-extra + dispatch-tag-extra-length + dispatch-tag-extra-ref + dispatch-tag-metatag + dispatch-tag-name dispatch-tag? - make-dispatch-tag - - ;; generic.scm: - built-in-dispatch-tag - built-in-dispatch-tags - condition-type:no-applicable-methods - dispatch-tag - error:no-applicable-methods - generic-procedure-applicable? - generic-procedure-arity - generic-procedure-arity-max - generic-procedure-arity-min - generic-procedure-name - generic-procedure? - guarantee-generic-procedure - make-generic-procedure - purge-generic-procedure-cache - standard-generic-procedure-tag) - (export (runtime generic-procedure multiplexer) - generic-procedure-generator - set-generic-procedure-generator!)) - - (define-package (runtime generic-procedure multiplexer) - (files "genmult") - (parent (runtime)) - (export () - add-generic-procedure-generator - condition-type:extra-applicable-methods - error:extra-applicable-methods - generic-procedure-default-generator - generic-procedure-generator-list - remove-generic-procedure-generator - remove-generic-procedure-generators - set-generic-procedure-default-generator!)) - - (define-package (runtime tagged-vector) - (files "tvector") - (parent (runtime)) - (export () - guarantee-tagged-vector - make-tagged-vector - record-slot-uninitialized - set-tagged-vector-element! - set-tagged-vector-tag! - tagged-vector - tagged-vector-element - tagged-vector-element-initialized? - tagged-vector-length - tagged-vector-tag - tagged-vector?)) - - (define-package (runtime record-slot-access) - (files "recslot") - (parent (runtime)) - (export () - condition-type:no-such-slot - condition-type:slot-error - condition-type:uninitialized-slot - %record-accessor - %record-accessor-generator - %record-initpred - %record-initpred-generator - %record-modifier - %record-modifier-generator - %record-slot-index - %record-slot-name - %record-slot-names) + make-dispatch-metatag) + (export (runtime predicate) + add-dispatch-tag-superset + any-dispatch-tag-superset) + (export (runtime predicate-dispatch) + fill-cache + new-cache + probe-cache + probe-cache-1 + probe-cache-2 + probe-cache-3 + probe-cache-4) (export (runtime record) - error:no-such-slot)) - - (define-package (runtime generic-procedure eqht) - (files "geneqht") - (parent (runtime)) - (export (runtime generic-procedure) - eqht/for-each - eqht/get - eqht/put! - make-eqht)) + %dispatch-tag-extra-index + %dispatch-tag-extra-set!)) (define-package (runtime crypto) (files "crypto") diff --cc src/runtime/thread.scm index dec9b6362,774780f27..6a0d1b8eb --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@@ -94,19 -94,11 +94,19 @@@ USA (properties #f read-only #t)) (define no-exit-value-marker - (list 'NO-EXIT-VALUE-MARKER)) + (list 'no-exit-value-marker)) (define (thread-dead? thread) - (guarantee thread? thread 'THREAD-DEAD?) - (eq? 'DEAD (thread/execution-state thread))) + (guarantee thread? thread 'thread-dead?) + (eq? 'dead (thread/execution-state thread))) + +(define (thread-get thread property) + (guarantee thread? thread 'thread-get) + (1d-table/get (thread/properties thread) property #f)) + +(define (thread-put! thread property value) + (guarantee thread? thread 'thread-put!) + (1d-table/put! (thread/properties thread) property value)) (define thread-population) (define first-running-thread) @@@ -204,10 -199,10 +207,10 @@@ (map-over-population thread-population (lambda (thread) thread))) (define (thread-execution-state thread) - (guarantee thread? thread 'THREAD-EXECUTION-STATE) + (guarantee thread? thread 'thread-execution-state) (thread/execution-state thread)) -(define (create-thread root-continuation thunk) +(define (create-thread root-continuation thunk #!optional name) (if (not (or (not root-continuation) (continuation? root-continuation))) (error:wrong-type-argument root-continuation "continuation or #f" diff --cc src/runtime/version.scm index 804f63ead,f2aee32db..cac8f8930 --- a/src/runtime/version.scm +++ b/src/runtime/version.scm @@@ -52,13 -52,9 +52,13 @@@ USA (let ((port (if (default-object? port) (current-output-port) - (guarantee textual-output-port? port 'WRITE-MIT-SCHEME-COPYRIGHT))) + (guarantee textual-output-port? port 'write-mit-scheme-copyright))) (cmark (if (default-object? cmark) "(C)" cmark)) (line-prefix (if (default-object? line-prefix) "" line-prefix))) + (write-words `("Copyright" ,cmark ,(number->string last-copyright-year) + "Matthew" "Birkholz") + line-prefix " " port) + (newline port) (write-words (let ((years (map number->string copyright-years))) `("Copyright" ,cmark diff --cc src/runtime/world-report.scm index a1d4433b2,5aab41762..18e9c7ee6 --- a/src/runtime/world-report.scm +++ b/src/runtime/world-report.scm @@@ -33,7 -33,11 +33,7 @@@ USA (let ((port (if (default-object? port) (current-output-port) - (guarantee textual-output-port? port 'WORLD-REPORT))) + (guarantee textual-output-port? port 'world-report))) - (flags (cons (cons (console-thread) "console") - (if (default-object? thread-flags) - '() - thread-flags))) (now (get-universal-time)) (cpu (process-time-clock))) (write-string "-*-Outline-*-" port) @@@ -50,10 -54,10 +50,10 @@@ (write-time-interval (- now time-world-restored) port) (newline port) (memory-report port) - (thread-report flags port))) + (thread-report port))) (define (ticks->string ticks) - (parameterize* (list (cons param:flonum-unparser-cutoff '(absolute 3))) + (parameterize* (list (cons param:flonum-printer-cutoff '(absolute 3))) (lambda () (number->string (internal-time/ticks->seconds ticks) 10)))) @@@ -154,13 -158,19 +154,13 @@@ (write-string " CPU, " port) (write-time (thread/real-time thread) port) (write-string " real" port) - (for-each - (lambda (name) - (write-string ", " port) - (write-string name port)) - (append-map! (lambda (item) - (if (and (pair? item) - (string? (cdr item)) - (eq? thread (car item))) - (list (cdr item)) - '())) - flags)) + (let ((name (thread-get thread 'name))) + (if name + (begin + (write-char #\space port) + (write name port)))) (newline port))) - (sort (map (lambda (t) (cons (hash t) t)) (threads-list)) + (sort (map (lambda (t) (cons (hash-object t) t)) (threads-list)) (lambda (a b) (< (car a) (car b)))))) (define (write-state thread port) diff --cc src/x11/tags-fix.sh index 14e5e8636,14e5e8636..a22e6bab5 --- a/src/x11/tags-fix.sh +++ b/src/x11/tags-fix.sh @@@ -6,7 -6,7 +6,7 @@@ set -e : ${MIT_SCHEME_EXE=mit-scheme} ${MIT_SCHEME_EXE} --batch-mode -- ${1+"$@"} <<\EOF --(let ((name (car (command-line)))) ++(let ((name (car (command-line-arguments)))) (let ((shim.c-prefix (string-append name "-shim.c,")) (const.c-prefix (string-append name "-const.c,"))) diff --cc tests/check.scm index e133c985d,633e3a1cf..89e00cb2d --- a/tests/check.scm +++ b/tests/check.scm @@@ -48,6 -48,9 +48,8 @@@ USA "microcode/test-keccak" "microcode/test-lookup" "runtime/test-arith" + "runtime/test-binary-port" - "runtime/test-blowfish" + "runtime/test-bundle" "runtime/test-bytevector" ("runtime/test-char" (runtime)) ("runtime/test-char-set" (runtime character-set)) @@@ -79,7 -82,8 +81,8 @@@ "runtime/test-thread-queue" "runtime/test-url" ("runtime/test-wttree" (runtime wt-tree)) - ;;"ffi/test-ffi" + "ffi/test-ffi.scm" + "sos/test-genmult" )) (with-working-directory-pathname