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"' && \
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"' && \
DEFAULT_SUBDIRS=( \
6001 \
- blowfish \
compiler \
cref \
- edwin \
ffi \
- gdbm \
- imail \
- mcrypt \
- mhash \
microcode \
+ pgsql \
runtime \
sf \
sos \
\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
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,")))
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,")))
--- /dev/null
- (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)))))
+#| -*-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* ((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))))))
+\f
+;;;; 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)))))
+\f
+;;;; 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))))
+\f
+;;;; 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)))))
+\f
+;;;; 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 <plugin>
+ (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 <host>
+ (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))))
+\f
+;;;; 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<? (version-comparator < >))
+(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))))
--- /dev/null
- scmlib_sub_DATA += rename.scm rename.bci rename.com
+## 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 += 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)"
(declare (usual-integrations))
\f
(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
"termcap"
"utils"
"win32"
- "winren"
- "xform"
- "xterm"))
+ "xform"))
(sf-edwin "tterm" "termcap")
(let ((includes '("struct" "comman" "modes" "buffer" "edtstr")))
(let loop ((files includes) (includes '()))
("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))))
(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)
|#
- (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)
(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
--- /dev/null
- "reccom" "regcom" "regexp" "regops" "rename" "replaz" "rfc822"
+#!/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"
- "win32com" "wincom" "window" "winout" "winren" "world-monitor"
++ "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"
- (let ((command (car (command-line)))
++ "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-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)
+ string<?)))
+ ((string=? command "com")
+ (for-each
+ (lambda (name) (my-write " "name".bci "name".com"))
+ (sort (map ->namestring files) string<?)))
+ ((string=? command "deps")
+ (for-each
+ (lambda (name)
+ (my-write-line name".bci: stamp-scheme")
+ (my-write-line name".com: stamp-scheme"))
+ (sort (map ->namestring files) string<?)))
+ (else
+ (error "Unexpected command:" command))))
+ )
+EOF
"machines/C/make"
"make")))
- (define-load-option 'CREF
+ (define-load-option 'cref
(guarded-system-loader '(cross-reference) "cref"))
- (define-load-option 'FFI
+ (define-load-option 'ffi
(guarded-system-loader '(ffi) "ffi"))
- (define-load-option '*PARSER
-(define-load-option 'imail
- (guarded-system-loader '(edwin imail) "imail"))
-
+ (define-load-option '*parser
(guarded-system-loader '(runtime *parser) "star-parser"))
- (define-load-option 'SF
+ (define-load-option 'sf
(guarded-system-loader '(scode-optimizer) "sf"))
- (define-load-option 'SOS
+ (define-load-option 'sos
(guarded-system-loader '(sos) "sos"))
- (define-load-option 'SSP
+ (define-load-option 'ssp
(guarded-system-loader '(runtime ssp) "ssp"))
- (define-load-option 'STUDENT
+ (define-load-option 'student
(guarded-system-loader '(student) "6001"))
- (define-load-option 'WIN32
+ (define-load-option 'win32
(guarded-system-loader '(win32) "win32"))
- (define-load-option 'XDOC
+ (define-load-option 'xdoc
(guarded-system-loader '(runtime ssp xdoc) "xdoc"))
- (define-load-option 'XML
+ (define-load-option 'xml
(guarded-system-loader '(runtime xml) "xml"))
(further-load-options standard-load-options)
@comment %**end of header
@copying
-This manual documents MIT/GNU Scheme GDBM @value{VERSION}.
+This manual documents MIT/GNU Scheme Pucked GDBM @value{VERSION}.
- Copyright @copyright{} 2017 Matthew Birkholz
+ Copyright @copyright{} 2017 Massachusetts Institute of Technology
Copyright @copyright{} 1993-99 Free Software Foundation, Inc.
@quotation
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,")))
--- /dev/null
- (let* ((commandline (command-line))
- (printInfo (member "-info" commandline)))
- (set! stereo (member "-stereo" commandline))
- (set! samples (let ((entry (member "-samples" commandline)))
+#| -*-Scheme-*-
+
+Copyright (C) 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015,
+ 2016, 2017 Matthew Birkholz
+
+This file is part of an OpenGL 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.
+
+|#
+
+;;;; This is a translation of the C code for the venerable GLX Gears demo.
+
+(C-include "glxgears")
+
+(define view-rotx 20.)
+(define view-roty 30.)
+(define view-rotz 0.)
+
+(define gear1)
+(define gear2)
+(define gear3)
+(define angle 0.)
+
+(define fullscreen #f) ; Create a single fullscreen window
+(define stereo #f) ; Enable stereo.
+(define samples) ; Choose visual with at least N samples.
+(define animate #f) ; Animation
+(define eyesep 5.) ; Eye separation.
+(define fix-point 40.) ; Fixation point distance.
+(define left) ; Stereo frustum params.
+(define right)
+(define asp)
+
+(define (draw-gear inner-radius ; radius of hole at center
+ outer-radius ; radius at center of teeth
+ width ; width of gear
+ teeth ; number of teeth
+ tooth-depth) ; depth of tooth
+ (let ((r0 inner-radius)
+ (r1 (- outer-radius (/ tooth-depth 2.)))
+ (r2 (+ outer-radius (/ tooth-depth 2.)))
+ (2pi/teeth (/ 2pi teeth))
+ (width/2 (* width .5))
+ (-width/2 (* (- width) .5)))
+ (let ((da (/ 2pi/teeth 4.)))
+ (let ((2da (* 2. da))
+ (3da (* 3. da)))
+
+ (gl:shade-model 'FLAT)
+ (gl:normal (flo:3d 0. 0. 1.))
+
+ ;; draw front face
+ (gl:begin 'QUAD-STRIP)
+ (do ((i 0. (+ i 1.)))
+ ((> 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 <displayname> 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)
- (set! fullscreen (member "-fullscreen" 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)))
- (let ((entry (member "-geometry" commandline)))
++ (set! fullscreen (member "-fullscreen" args))
+ (let* ((geometry
- (let ((entry (member "-display" 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" 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 ...)))))
--- /dev/null
- (let ((name (car (command-line))))
+#!/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-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
--- /dev/null
- (import (runtime load)
- *unused-command-line*
- hook/process-command-line
- default/process-command-line)
- (import (runtime)
- ucode-primitive)
+#| -*-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> 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-stream>
+ <g-input-stream>
+ g-input-stream-read
+ g-input-stream-skip
+ g-input-stream-close
+ <g-output-stream>
+ g-output-stream-write
+ g-output-stream-flush
+ g-output-stream-close
+ <gfile-input-stream>
+ gfile-read
+ <gfile-output-stream>
+ gfile-append-to
+ gfile-create
+ gfile-replace
+ <gfile-info>
+ gfile-query-info
+ gfile-info-list-attributes
+ gfile-info-get-attribute-status
+ gfile-info-get-attribute-value
+ <gfile-enumerator>
+ gfile-enumerate-children
+ gfile-enumerator-next-files
+ gfile-enumerator-close
+ <gfile>
+ make-gfile))
+
+(define-package (glib main)
+ (parent (glib internal))
+ (files "glib-main")
+ ;;(depends-on "glib.bin" "glib")
+ (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))
--- /dev/null
- (define gquark-to-string-cache (make-eqv-hash-table))
+#| -*-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 <gobject> ()
+
+ ;; 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 <gobject>")
+
+(define-integrable (gobject-live? object)
+ (not (alien-null? (gobject-alien object))))
+
+(define-method initialize-instance ((object <gobject>))
+ (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 <gobject> 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)))
+\f
+
+;;; 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?))
+\f
+;;; 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))
+
- (or (hash-table/get gquark-from-string-cache string #f)
++(define gquark-to-string-cache (make-key-weak-eqv-hash-table))
+
+(define (gquark-from-string string)
+ (assert-glib-locked 'gquark-from-string)
- (hash-table/put! gquark-from-string-cache string gq)
- (hash-table/put! gquark-to-string-cache gq string)
++ (or (hash-table-ref/default gquark-from-string-cache string #f)
+ (let ((gq (C-call "g_quark_from_string" (string->utf8 string))))
- (or (hash-table/get gquark-to-string-cache gquark #f)
++ (hash-table-set! gquark-from-string-cache string gq)
++ (hash-table-set! gquark-to-string-cache gq string)
+ gq)))
+
+(define (gquark-to-string gquark)
- (set! gquark-to-string-cache (make-eqv-hash-table))
++ (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-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!)
--- /dev/null
- (let ((name (car (command-line))))
+#!/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-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
--- /dev/null
- (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))))))
+#| -*-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)
+
+;;; <fix-widget> 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 (<fix-widget> (constructor () (width height bgcolor)))
+ (<scm-widget>)
+
+ ;; 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 <fix-widget>")
+
+(define-integrable (guarantee-size object operator)
+ (guarantee non-negative-fixnum? object operator))
+
+(define-method initialize-instance ((widget <fix-widget>) width height bgcolor)
+ (let ((bg (if (null? bgcolor)
+ '()
+ (->color bgcolor '(initialize-instance <fix-widget>)))))
+ (call-next-method widget)
+ (%trace "; (initialize-instance <fix-widget>) "widget" "width"x"height"\n")
+ (assert-glib-locked '(initialize-instance <fix-widget>))
+ (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 <fix-widget>))
+ (%trace "; (fix-widget-realize-callback <fix-widget>) "widget"\n")
+ (assert-glib-locked '(fix-widget-realize-callback <fix-widget>))
+ (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 <fix-widget>))
+ (%trace "; (fix-widget-unrealize-callback <fix-widget>) "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 <fix-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)))))
+\f
+(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)))
+\f
+(define-class (<fix-layout> (constructor () (width height bgcolor)))
+ (<fix-widget>)
+
+ ;; 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 <fix-layout>")
+
+(define-method initialize-instance ((widget <fix-layout>) width height bgcolor)
+ (call-next-method widget width height bgcolor)
+ (%trace "; (initialize-instance <fix-layout>) "widget" "width"x"height"\n")
+ (assert-glib-locked '(initialize-instance <fix-layout>))
+ (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 <fix-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))))))))
+\f
+;;; Callbacks.
+
+(define-method fix-widget-new-geometry-callback ((widget <fix-layout>))
+ (call-next-method widget)
+ (%trace "; (fix-widget-new-geometry-callback <fix-layout>) "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 <fix-layout>))
+ (call-next-method widget)
+ (%trace "; (fix-widget-realize-callback <fix-layout>) "widget"\n")
+ (assert-glib-locked '(fix-widget-realize-callback <fix-layout>))
+ #;(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 <fix-layout>)
+ 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))))
+\f
+(define-class (<fix-drawing> (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 <fix-drawing>")
+
+(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)
- (or (hash-table/get cached-font-descriptions spec #f)
++ (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 <ink>"
+ " 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))))
+\f
+(define-class <fix-ink>
+ ()
+ (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 <fix-ink>")
+
+(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)))))
+\f
+;; 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 <draw-ink>
+ (<fix-ink>)
+ ;; Alist of option names (symbols) X values (whatnot).
+ (options define standard initial-value '()))
+
+(define-guarantee draw-ink "a <draw-ink>")
+
+;;; 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))))
+\f
+(define-class (<line-ink> (constructor ()))
+ (<draw-ink>)
+ (vector define standard initializer (lambda () (make-fix-rect 0 0 0 0))))
+
+(define-guarantee line-ink "a <line-ink>")
+
+(define-method fix-ink-draw-callback ((ink <line-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 <line-ink>) dx dy)
+ (assert-glib-locked '(fix-ink-move! <line-ink>))
+ (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)))))
+\f
+(define-class (<rectangle-ink> (constructor ()))
+ (<draw-ink>)
+ (rect define standard initializer (lambda () (make-fix-rect 0 0 0 0))))
+
+(define-guarantee rectangle-ink "a <rectangle-ink>")
+
+(define-method fix-ink-draw-callback ((ink <rectangle-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 <rectangle-ink>) dx dy)
+ (assert-glib-locked '(fix-ink-move! <rectangle-ink>))
+ (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))))))
+\f
+(define-class (<polygon-ink> (constructor ()))
+ (<draw-ink>)
+ (vertices define standard initial-value '()))
+
+(define-guarantee polygon-ink "a <polygon-ink>")
+
+(define-method fix-ink-draw-callback ((ink <polygon-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 <polygon-ink>) dx dy)
+ (assert-glib-locked '(fix-ink-move! <polygon-ink>))
+ (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))))))
+
+\f
+(define-integrable flo:pi (flo:* 4. (flo:atan2 1. 1.)))
+
+(define-class (<arc-ink> (constructor ()))
+ (<draw-ink>)
+ (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 <arc-ink>")
+
+(define-method fix-ink-draw-callback ((ink <arc-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 <arc-ink>) dx dy)
+ (assert-glib-locked '(fix-ink-move! <arc-ink>))
+ (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))))))
+\f
+(define-class (<text-ink> (constructor ()))
+ (<draw-ink>))
+
+(define-guarantee text-ink "a <text-ink>")
+
+(define-generic text-ink-pango-layout (ink))
+
+(define-method fix-ink-draw-callback ((ink <text-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 <text-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)
- (hash-table/put! cached-font-descriptions spec alien)
++ (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/clear! cached-font-descriptions))
++ (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!)
- (standard-unparser-method 'FIX-RECT
++ (set! cached-font-descriptions (make-string-hash-table)))
+
+(add-event-receiver! event:after-restore reset-font-descriptions!)
+\f
+(define-class (<simple-text-ink> (constructor ()))
+ (<text-ink>)
+
+ ;; 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 <simple-text-ink>")
+
+(define-method text-ink-pango-layout ((ink <simple-text-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))))))))
+\f
+(define-class (<image-ink> (constructor ()))
+ (<fix-ink>)
+ ;; This slot is set to a <pixbuf> 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 <image-ink>))
+ (call-next-method ink)
+ (%trace ";(initialize-instance <image-ink>) "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 <image-ink>) widget window cr area)
+ (declare (ignore window area))
+ (%trace2 ";drawing "ink" on "widget"\n")
+ (assert-glib-locked '(fix-ink-draw-callback <image-ink>))
+ (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 <image-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))
+\f
+(define-class (<surface-ink> (constructor () (width height)))
+ (<fix-ink>)
+
+ ;; 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 <surface-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 <surface-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))
+\f
+;;;; Fixnum Rectangles
+
+(define-structure (fix-rect (constructor make-fix-rect (#!optional x y width height))
+ (copier)
+ (print-procedure
++ (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 ...)))))
--- /dev/null
- (define displays (make-weak-eqv-hash-table))
+#| -*-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))
+\f
+;;; GdkPixbufLoaders
+
+(define-class (<pixbuf-loader> (constructor ()))
+ (<gobject>)
+ (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 (<pixbuf> (constructor ()))
+ (<gobject>))
+
+(define-method initialize-instance ((pixbuf <pixbuf>))
+ (call-next-method pixbuf)
+ (set-alien/ctype! (gobject-alien pixbuf) '|GdkPixbuf|))
+
+(define-method initialize-instance ((loader <pixbuf-loader>))
+ (call-next-method loader)
+ (assert-glib-locked '(initialize-instance <pixbuf-loader>))
+ (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)))
+\f
+;;; GdkDisplays
+
+(define-record-type <gdk-display>
+ (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))
+
- (or (hash-table/get displays bignum #f)
++(define displays (make-key-weak-eqv-hash-table))
+
+(define (get-gdk-display alien)
+ (let ((bignum (alien/address alien)))
- (hash-table/put! displays bignum display)
++ (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-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 ...)))))
--- /dev/null
- (import (runtime load)
- *unused-command-line*
- hook/process-command-line
- default/process-command-line)
+#| -*-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
+ <pixbuf-loader> 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
+ <pixbuf>))
+
+(define-package (gtk gtk-widget)
+ (parent (gtk internal))
+ (files "gtk-widget")
+ ;;(depends-on "gtk.bin" "gtk" "../runtime/ffi" "../pango/" "../glib/")
+ (export (gtk)
+ <gtk-adjustment> gtk-adjustment? guarantee-gtk-adjustment
+ make-gtk-adjustment set-gtk-adjustment!
+ <gtk-widget> 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> 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> gtk-container? guarantee-gtk-container
+ gtk-container-children gtk-bin-child
+ gtk-container-add gtk-container-remove
+ gtk-container-set-border-width
+
+ <gtk-window> 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> gtk-label? guarantee-gtk-label
+ gtk-label-new
+ gtk-label-get-text gtk-label-set-text
+ gtk-label-set-width-chars
+ <gtk-button> gtk-button? guarantee-gtk-button
+ gtk-button-new
+ set-gtk-button-clicked-callback!
+ <gtk-check-button> 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> 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> gtk-frame? guarantee-gtk-frame gtk-frame-new
+ gtk-frame-set-shadow-type
+ <gtk-scrolled-window> 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? gtk-scrolled-view-new
+ <gtk-paned> 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? 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)
+ <scm-widget> 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?
+ 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> 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!
+
+ <fix-drawing> 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?
+ fix-ink-drawing
+ fix-ink-widgets set-fix-ink-widgets!
+ fix-ink-move! fix-ink-remove!
+ <draw-ink>
+
+ <line-ink> 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> 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> 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> 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> 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> 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!
+
+ <image-ink> make-image-ink-from-file set-image-ink!
+
+ <surface-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 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))
--- /dev/null
- (init-gtk ((ucode-primitive scheme-program-name 0)) *unused-command-line*))
+#| -*-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).
- (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)))))))))
++ (init-gtk ((ucode-primitive scheme-program-name 0))
++ (command-line-arguments)))
+
+(define (initialize-package!)
+ (reset-gtk!)
+ (add-event-receiver! event:after-restore reset-gtk!)
++ (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!)
--- /dev/null
- (let ((name (car (command-line))))
+#!/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-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
--- /dev/null
- (load-option 'REGULAR-EXPRESSION)
- (load-option 'WT-TREE)
- (load-option 'SOS)
- (load-option 'EDWIN)
+#| -*-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)
+(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))
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,")))
--- /dev/null
- (let ((name (car (command-line))))
+#!/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-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
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,")))
("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))
(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))
\f
(define (pa procedure)
- (guarantee procedure? procedure 'PA)
+ (guarantee procedure? procedure 'pa)
(cond ((procedure-lambda procedure)
=> (lambda (scode)
(pp (unsyntax-lambda-list scode))))
(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.
(define (define-feature name procedure)
(set! supported-features (cons (cons name procedure) supported-features))
name)
- \f
+
+ (define supported-features '())
+
(define (always) #t)
+(define-feature 'pucked always)
+
(define-feature 'mit always)
(define-feature 'mit/gnu always)
(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")
cell-contents
cell?
constant-procedure
- default/exit
- default/quit
+ edit
+ edwin
+ emergency-exit ;R7RS
environment-link-name
ephemeron-broken?
ephemeron-datum
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))
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))
\f
- (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")
(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))
\f
(define thread-population)
(define first-running-thread)
(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"
(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
(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)
(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))))
(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)
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,")))
"microcode/test-keccak"
"microcode/test-lookup"
"runtime/test-arith"
- "runtime/test-blowfish"
+ "runtime/test-binary-port"
+ "runtime/test-bundle"
"runtime/test-bytevector"
("runtime/test-char" (runtime))
("runtime/test-char-set" (runtime character-set))
"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
projects / mit-scheme.git / commitdiff