--- /dev/null
-(define (compile-system name directory . options)
- ;; Gets a list of file.package from DIRECTORY/NAME.pkg, creates the
- ;; packages described therein, then (re)compiles (as necessary) and
- ;; loads each file in order.
- ;;
- ;; If OPTIONS includes 'dependencies, its value should be an alist
- ;; of filenames, as they appear in the NAME.pkg file, each
- ;; associated with a list of pathnames (relative to DIRECTORY).
-
- (define (find-option name options default)
- (let loop ((opts options))
- (if (pair? opts)
- (if (eq? (car opts) name)
- (cadr opts)
- (loop (cddr opts)))
- default)))
+ #| -*-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 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.
+
+ |#
+
+ ;;;; Build utilities
+ ;;; package: (cross-reference build-utilities)
+
+ (declare (usual-integrations))
+ \f
- (let* ((os-type microcode-id/operating-system)
- (pmodel (read-package-model name os-type))
- (pathname (pmodel/pathname pmodel))
- (dependencies (find-option 'dependencies options '()))
- (syntax-only? (find-option 'syntax-only? options #f)))
++(define (compile-system name directory)
++ ;; Gets a list of files from DIRECTORY/NAME.pkg, creates the
++ ;; packages described therein, and loads each file, in order,
++ ;; re-compiling it first when necessary.
+
+ (with-working-directory-pathname directory
+ (lambda ()
- (define (env file)
- (->environment
- (let loop ((cps (pmodel/packages pmodel)))
- (if (pair? cps)
- (if (find (lambda (f) (pathname=? f file))
- (package/files (car cps)))
- (package/name (car cps))
- (loop (cdr cps)))
- (error "No cref-package for file:" file)))))
++ (let ((pmodel (read-package-model name microcode-id/operating-system)))
+
- (define (deps file)
- (let ((entry (assoc file dependencies)))
- (if entry (cdr entry) '())))
++ (declare (integrate-operator file-package))
++ (define (file-package file)
++ (let loop ((packages (pmodel/packages pmodel)))
++ (if (pair? packages)
++ (if (find (lambda (f) (pathname=? f file))
++ (package/files (car packages)))
++ (car packages)
++ (loop (cdr packages)))
++ (error "No cref package for file:" file pmodel))))
+
- (for-each (lambda (file.deps)
- (if (not (for-all? string? file.deps))
- (error "Bogus dependency:" file.deps)))
- dependencies)
++ (define-integrable (file-environment file)
++ (->environment (package/name (file-package file))))
+
- (warn "Package already exists:" (package/name (car packages)))
- ;; Build package(s) for use at syntax-time.
++ (define-integrable (file-dependencies file)
++ (package/depends-on (file-package file)))
+
+ (let ((existing
+ (let loop ((packages (pmodel/packages pmodel)))
+ (if (pair? packages)
+ (or (name->package (package/name (car packages)))
+ (loop (cdr packages)))
+ #f))))
+ (if existing
- (compile-file file (deps file) (env file))
- (load file))
++ (error "Package already exists:" existing)
+ (construct-packages-from-file
+ (construct-external-descriptions pmodel))))
+
+ (for-each
+ (lambda (file)
++ (let ((env (file-environment file))
++ (deps (file-dependencies file))
++ (type (if compile-file:sf-only? "bin" #f)))
++ (compile-file file deps env)
++ (load (pathname-new-type file type) env)))
+ (append-map package/files (pmodel/packages pmodel)))
+
+ (cref/generate-constructors name 'ALL)))))
--- /dev/null
- (declare (ignore instance))
+#| -*-Scheme-*-
+
+Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
+
+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.
+
+|#
+
+;;;; GtkObjects
+;;; package: (gtk gobject)
+
+(c-include "gtk")
+
+(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 gc-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-gc-cleanup object (make-gobject-cleanup-thunk
+ (gobject-alien object)
+ (gobject-signals object)))))
+
+(define (make-gobject-cleanup-thunk alien signals)
+ ;; This separate procedure ensures that the gobject is not caught in
+ ;; the closure.
+ (named-lambda (gobject-cleanup-thunk)
+ (gobject-cleanup alien signals)))
+
+(define (gobject-unref! object)
+ (without-interrupts
+ (lambda ()
+ (gobject-cleanup (gobject-alien object) (gobject-signals object))
+ (set! gc-cleanups (delq! (gobject-weak-self object) gc-cleanups)))))
+
+(define (gobject-cleanup alien signals)
+ ;; Run as a gc-daemon, or with exclusive write access to ALIEN and
+ ;; SIGNALS (or without-interrupts).
+
+ (%trace ";gobject-cleanup "alien"\n")
+ (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 (g-signal-connect gobject alien-function callback)
+ (guarantee-gobject gobject 'g-signal-connect)
+ (guarantee-alien-function alien-function 'g-signal-connect)
+ (without-interrupts
+ (lambda ()
+ (let* ((name (alien-function/name alien-function))
+ (sym (string->symbol name))
+ (alien (gobject-alien gobject))
+ (signals (gobject-signals gobject))
+ (sym.id.handle (or (assq sym (cdr signals))
+ (let ((entry (cons* sym #f #f)))
+ (set-cdr! signals (cons entry (cdr signals)))
+ entry))))
+ (disconnect!? alien (cdr sym.id.handle))
+ (connect! alien sym.id.handle
+ alien-function
+ (register-c-callback
+ (make-gobject-signal-callback
+ sym (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.
++ instance ;ignore
+ (if (weak-pair/car? weak-pair)
+ (let ((gobject (weak-car weak-pair)))
+ (if-debugging
+ (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 sym.id.handle alien-function newid)
+ (let ((id.handle (cdr sym.id.handle)))
+ (set-car! id.handle newid)
+ (set-cdr! id.handle
+ (C-call "g_signal_connect_data" alien
+ (alien-function/name alien-function)
+ alien-function newid 0 0))))
+
+(define (g-signal-disconnect gobject name)
+ (guarantee-gobject gobject 'g-signal-disconnect)
+ (guarantee-symbol name 'g-signal-disconnect)
+ (without-interrupts
+ (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
+;;; GC Cleanups
+
+(define gc-cleanups)
+
+(define (initialize-gc-cleanups!)
+ (set! gc-cleanups '()))
+
+(define (run-gc-cleanups)
+ (%trace ";run-gc-cleanups\n")
+ (let loop ((alist gc-cleanups)
+ (prev #f))
+ (if (pair? alist)
+ (if (weak-pair/car? (car alist))
+ (loop (cdr alist) alist)
+ (let ((thunk (weak-cdr (car alist)))
+ (next (cdr alist)))
+ (thunk)
+ (if prev
+ (set-cdr! prev next)
+ (set! gc-cleanups next))
+ (loop next prev)))))
+ (%trace ";run-gc-cleanups done\n"))
+
+(define (reset-gc-cleanups!)
+ (set! gc-cleanups '()))
+
+(define-integrable (add-gc-cleanup object cleanup-thunk)
+ (let ((weak-pair (weak-cons object cleanup-thunk)))
+ (without-interrupts
+ (lambda ()
+ (set! gc-cleanups (cons weak-pair gc-cleanups))))
+ weak-pair))
+
+(define-integrable (punt-gc-cleanup object)
+ (without-interrupts
+ (lambda ()
+ (let ((entry (weak-assq object gc-cleanups)))
+ (if entry
+ (begin
+ (set! gc-cleanups (delq! entry gc-cleanups))
+ (weak-cdr entry))
+ #f)))))
+
+(define (weak-assq obj alist)
+ (let loop ((alist alist))
+ (if (null? alist) #f
+ (let* ((entry (car alist))
+ (key (weak-car entry)))
+ (if (eq? obj key) entry
+ (loop (cdr alist)))))))
+\f
+
+;;; Properties
+
+(define (gobject-get-property gobject property)
+ (guarantee-gobject gobject '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) 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_char" 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)
+ ;; WAS primitive G-OBJECT-SET-PROPERTIES [gtk.c]
+ (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 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_char"
+ 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 name gvalue)
+ (C-call "g_value_reset" gvalue)))
+ (loop (cddr plist)))))
+ (free gtype)
+ (free pspec)
+ (free gvalue))
+ unspecific)
+
+(define (gobject-get-gclass alien)
+ (let ((ret (make-alien '|GObjectClass|)))
+ (C-call "G_OBJECT_GET_CLASS" ret alien)
+ ret))
+
+(define (gclass-get-name gclass)
+ ;; 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)
+ (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-name 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))
+
+(define gquark-to-string-cache (make-eqv-hash-table))
+
+(define (gquark-from-string string)
+ (or (hash-table/get gquark-from-string-cache string #f)
+ (let ((gq (C-call "g_quark_from_string" string)))
+ (hash-table/put! gquark-from-string-cache string gq)
+ (hash-table/put! gquark-to-string-cache gq string)
+ gq)))
+
+(define (gquark-to-string gquark)
+ (or (hash-table/get gquark-to-string-cache gquark #f)
+ (error "Unknown GQuark:" gquark)))
+
+(define (reset-quark-cache!)
+ (set! gquark-from-string-cache (make-string-hash-table))
+ (set! gquark-to-string-cache (make-eqv-hash-table))
+ unspecific)
+\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)
+ (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")
+ (let ((size (pixbuf-loader-size loader)))
+ (if size (error "Pixbuf loader already has a size:" loader))
+ (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")
+ (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")
+ (let ((receiver (pixbuf-loader-update-hook loader)))
+ (if receiver (receiver x y width height))))
+
+(define (load-pixbuf-from-port loader input-port)
+ (without-interrupts
+ (lambda ()
+ (if (pixbuf-loader-port loader)
+ (error "Pixbuf loader has already started:" loader))
+ (set-pixbuf-loader-port! loader input-port)
+ (let ((thread (create-pixbuf-loader-thread loader)))
+ (set-pixbuf-loader-thread! loader thread)
+ (detach-thread thread)))))
+
+(define (create-pixbuf-loader-thread loader)
+ (create-thread
+ #f (lambda ()
+ (%trace "; "loader" started in "(current-thread)"\n")
+ (let ((port (pixbuf-loader-port loader))
+ (alien (gobject-alien loader))
+ (GError-ptr (malloc (C-sizeof "*") '(* |GError|)))
+ (buff (allocate-external-string 4200)))
+ (C->= GError-ptr "* GError" 0)
+ (let ((buff-address (external-string-descriptor buff)))
+
+ (define (note-done)
+ (without-interrupts
+ (lambda ()
+ (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))))))
+
+ (define (note-error)
+ (let* ((GError (C-> GError-ptr "*" (make-alien '|GError|)))
+ (message (or (and (not (alien-null? GError))
+ (c-peek-cstring
+ (C-> GError "GError message")))
+ "GError not set.")))
+ (set-pixbuf-loader-error-message! loader message)
+ (C-call "g_error_free" GError)
+ (free GError-ptr)
+ (note-done)))
+
+ (let loop ()
+ (let ((n (input-port/read-string! port buff)))
+ (cond ((and (fix:zero? n) (eof-object? (peek-char port)))
+ (if (fix:zero? (C-call "gdk_pixbuf_loader_close"
+ alien GError-ptr))
+ (note-error)
+ (note-done)))
+ ((not (fix:zero?
+ (C-call "gdk_pixbuf_loader_write"
+ alien buff-address n GError-ptr)))
+ (loop))
+ (else
+ (note-error))))))))))
+
+(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)
+ (without-interrupts
+ (lambda ()
+ (%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)
+ (without-interrupts
+ (lambda ()
+ (%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)
+ (without-interrupts
+ (lambda ()
+ (%set-pixbuf-loader-close-hook! loader thunk)
+ (if (pixbuf-loader-closed? loader)
+ (thunk)))))
+\f
+(define (gdk-window-process-updates gdkwindow children-too?)
+ (guarantee-gdk-window gdkwindow 'gdk-window-process-updates)
+ (C-call "gdk_window_process_updates" gdkwindow (if children-too? 1 0)))
+
+(define-integrable (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 (initialize-package!)
+ (initialize-gc-cleanups!)
+ (add-event-receiver! event:after-restore reset-quark-cache!)
+ (add-event-receiver! event:after-restore reset-gc-cleanups!)
+ unspecific)
+
+(define %trace? #f)
+
+(define-syntax %trace
+ (syntax-rules ()
+ ((_ . ARGS) (if %trace? ((lambda () (outf-console . ARGS)))))))
+
+(initialize-package!)
--- /dev/null
- ;;; This is largely a copy of gtk.pkg, with a few new declarations added.
-
- (declare (usual-integrations))
-
+#| -*-Scheme-*-
+
+Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz
+
+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.
+
+|#
+
+;;;; Gtk System Packaging
+
+(global-definitions "../runtime/runtime")
+(global-definitions "../ffi/ffi")
+(global-definitions "../sos/sos")
+
+(define-package (gtk)
+ (parent ())
+ (files "gtk"))
+
+(define-package (gtk gobject)
+ (parent (gtk))
+ (files "gobject")
+ (depends-on "gtk-const.bin")
+ (export (gtk)
+ <gobject> gobject-alien
+ gobject-live? gobject-unref!
+ g-signal-connect g-signal-disconnect
+ add-gc-cleanup punt-gc-cleanup
+ gobject-get-property gobject-set-properties
+ gquark-from-string gquark-to-string
+ <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>
+ gdk-window-process-updates))
+
+(define-package (gtk pango)
+ (parent (gtk))
+ (files "pango")
+ (depends-on "gtk-const.bin")
+ (export (gtk)
+ <pango-layout>
+ pango-layout-get-context
+ pango-layout-context-changed
+ pango-layout-get-font-description
+ pango-layout-set-font-description
+ pango-layout-set-text
+ pango-layout-get-pixel-extents
+ pango-layout-index-to-pos
+ pango-font-description-from-string
+ pango-font-description-to-string
+ pango-font-description-free
+ pango-context-get-font-description
+ pango-context-set-font-description
+ pango-context-get-metrics
+ pango-context-spacing
+ pango-font-metrics-get-ascent
+ pango-font-metrics-get-descent
+ pango-font-metrics-get-approximate-char-width
+ pango-font-metrics-unref))
+
+(define-package (gtk gtk-object)
+ (parent (gtk))
+ (files "gtk-object")
+ (depends-on "gtk-const.bin")
+ (export (gtk)
+ <gtk-object> gtk-object? guarantee-gtk-object
+ gtk-object-destroyed? gtk-object-destroy
+ <gtk-adjustment> gtk-adjustment? guarantee-gtk-adjustment
+ make-gtk-adjustment set-gtk-adjustment!
+ <gtk-widget> gtk-widget? guarantee-gtk-widget
+ 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-get-colormap
+ gtk-widget-get-pango-context
+ gtk-widget-create-pango-layout
+ 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-event-callback!
+
+ gtk-widget-font set-gtk-widget-font!
+ gtk-widget-fg-color gtk-widget-bg-color
+ gtk-widget-text-color gtk-widget-base-color
+ set-gtk-widget-fg-color! set-gtk-widget-bg-color!
+ set-gtk-widget-text-color! set-gtk-widget-base-color!
+ gtk-widget-parse-color
+
+ <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-container-set-resize-mode
+ ;;gtk-container-check-resize
+
+ <gtk-window> gtk-window? guarantee-gtk-window
+ gtk-window-new gtk-window-set-title gtk-window-type
+ gtk-window-set-opacity
+ gtk-window-set-default-size gtk-window-get-default-size
+ gtk-window-parse-geometry
+ gtk-window-resize
+ gtk-window-present
+ set-gtk-window-delete-event-callback!
+ <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-vbox> gtk-vbox? guarantee-gtk-vbox gtk-vbox-new
+ <gtk-hbox> gtk-hbox? guarantee-gtk-hbox gtk-hbox-new
+ gtk-box-pack-start gtk-box-pack-end
+ <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)
+ (import (gtk pango) make-pango-layout guarantee-pango-font-description))
+
+(define-package (gtk widget)
+ (parent (gtk))
+ (files "scm-widget")
+ (depends-on "gtk-const.bin")
+ (import (gtk gtk-object)
+ set-gtk-object-destroy-callback!)
+ (export (gtk)
+ <scm-widget>
+ set-scm-widget-set-scroll-adjustments-callback!))
+
+(define-package (gtk fix-layout)
+ (parent (gtk))
+ (files "fix-layout")
+ (depends-on "gtk.ext" "pango.ext" "gtk-const.bin")
+ (import (gtk pango)
+ make-pango-layout pango-rectangle pangos->pixels pixels->pangos)
+ (import (gtk gtk-object)
+ parse-gdkcolor set-gtk-object-destroy-callback!)
+ (export (gtk)
+
+ <fix-layout> fix-layout? make-fix-layout set-fix-layout-size!
+ fix-layout-drawing set-fix-layout-drawing!
+ fix-layout-scroll-step set-fix-layout-scroll-step!
+ fix-layout-view fix-layout-scroll-to! fix-layout-scroll-nw!
+ fix-layout-new-geometry-callback fix-layout-realize-callback
+ set-fix-layout-map-handler!
+ set-fix-layout-unmap-handler!
+ set-fix-layout-focus-change-handler!
+ set-fix-layout-visibility-notify-handler!
+ set-fix-layout-key-press-handler!
+ set-fix-layout-motion-handler!
+ set-fix-layout-button-handler!
+
+ <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!
+
+ <rectangle-ink> rectangle-ink? make-rectangle-ink set-rectangle-ink!
+ rectangle-ink-color set-rectangle-ink-color!
+ rectangle-ink-width set-rectangle-ink-width!
+ rectangle-ink-fill-color set-rectangle-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!
+
+ <box-ink> box-ink? make-box-ink
+ set-box-ink! set-box-ink-position!
+ box-ink-shadow set-box-ink-shadow!
+
+ ;;<hline-ink> make-hline-ink set-hline-ink-size!
+ ;;<vline-ink> make-vline-ink set-vline-ink-size!
+ ))
+
+(define-package (gtk keys)
+ (parent (gtk))
+ (files "keys")
+ (depends-on "gtk-const.bin")
+ (export (gtk)
+ gdk-key-state->char-bits
+ gdk-keyval->name))
+
+(define-package (gtk thread)
+ (parent (runtime thread))
+ (files "thread")
+ (depends-on "gtk.ext" "pango.ext")
+ (export ()
+ stop-gtk-thread)
+ (import (gtk gobject)
+ run-gc-cleanups)
+ (import (runtime primitive-io)
+ select-registry-handle))
+
+(define-package (gtk main)
+ (parent (gtk))
+ (files "main")
+ (depends-on "gtk-const.bin")
+ (import (runtime load)
+ *unused-command-line*
+ hook/process-command-line
+ default/process-command-line)
+ (import (runtime)
+ ucode-primitive)
+ (import (runtime subprocess)
+ hook/subprocess-wait nonblocking/subprocess-wait)
+ (import (gtk thread)
+ create-gtk-thread exit-gtk-thread)
+ (export ()
+ gtk-time-slice-window?
+ gtk-time-slice-window!
+ gtk-select-trace?
+ gtk-select-trace!))
+
+(define-package (gtk event-viewer)
+ (parent (gtk))
+ (files "gtk-ev")
+ (depends-on "gtk.ext" "pango.ext" "gtk-const.bin")
+ (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 (gtk pango)
+ pango-rectangle pangos->pixels)
+ (export ()
+ make-gtk-event-viewer-demo))
+
+(define-package (gtk fix-layout demo)
+ (parent (gtk fix-layout))
+ (files "fix-demo")
+ (depends-on "gtk.ext" "pango.ext")
+ (import (gtk fix-layout)
+ fix-layout-view)
+ (export ()
+ make-fix-layout-demo))
+
+(define-package (gtk swat)
+ (parent (gtk))
+ (files "swat")
+ (depends-on "gtk.ext" "pango.ext")
+ (import (gtk gtk-object)
+ gtk-object-destroy-callback)
+ (import (gtk fix-layout)
+ fix-layout-view fix-ink-extent fix-ink-expose-callback
+ fix-drawing-display-list set-fix-drawing-display-list!
+ set-fix-ink-drawing! fix-ink-in-widget? fix-ink-in?
+ 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!)
+ (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))
projects / mit-scheme.git / commitdiff