From: Matt Birkholz Date: Wed, 20 Apr 2011 15:45:43 +0000 (-0700) Subject: Merge branch 'master' into Gtk X-Git-Tag: 20110426-Gtk~2 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1449fadd97c05e8d663d4048e83109cb2c6409e9;p=mit-scheme.git Merge branch 'master' into Gtk * src/: Makefile.in, Setup.sh, configure.ac, microcode/achost.ac: Resolved conflicts with the new FFIS build support. * src/sf/butils.scm: Punt sf-package-set; using new compile-system. * src/ffi/: ffi.sf, ffi.cbf, compile.scm: Replaced ye ol' .sf and .cbf files with the new hotness. --- 1449fadd97c05e8d663d4048e83109cb2c6409e9 diff --cc src/Setup.sh index f799a27ae,eee163e4c..b50e1d4a6 --- a/src/Setup.sh +++ b/src/Setup.sh @@@ -84,10 -84,12 +84,14 @@@ maybe_link lib/edwin ../edwi maybe_link lib/include ../microcode maybe_link lib/optiondb.scm ../etc/optiondb.scm maybe_link lib/runtime ../runtime +maybe_link lib/sos ../sos maybe_link lib/mit-scheme.h ../microcode/pruxffi.h maybe_link lib/ffi ../ffi + maybe_link lib/ffi-test-shim.so ../ffi/ffi-test-shim.so + maybe_link lib/ffi-test-types.bin ../ffi/ffi-test-types.bin + maybe_link lib/ffi-test-const.bin ../ffi/ffi-test-const.bin +maybe_link lib/gtk ../gtk + maybe_link config.sub microcode/config.sub maybe_link config.guess microcode/config.guess diff --cc src/configure.ac index 364b6e87a,36cec94ca..7edbfd067 --- a/src/configure.ac +++ b/src/configure.ac @@@ -38,17 -43,6 +43,12 @@@ AC_ARG_ENABLE([host-scheme-test] [Test for working scheme on build host [[no]]])) : ${enable_host_scheme_test=no} - AC_ARG_ENABLE([debugging], - AS_HELP_STRING([--enable-debugging], - [Compile with debugging support [[no]]])) - : ${enable_debugging='no'} - +AC_ARG_WITH([gtk], + [AS_HELP_STRING([--with-gtk], + [Support the GNOME Toolkits [[auto]]])], + [], + [with_gtk=auto]) + AC_CANONICAL_HOST MIT_SCHEME_NATIVE_CODE([${enable_native_code}],[${host_cpu}]) diff --cc src/cref/butils.scm index 000000000,01ffa682c..b92715c2c mode 000000,100644..100644 --- a/src/cref/butils.scm +++ b/src/cref/butils.scm @@@ -1,0 -1,93 +1,76 @@@ + #| -*-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)) + -(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))) ++(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 () - (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))) ++ (let ((pmodel (read-package-model name microcode-id/operating-system))) + - (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))))) ++ (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)))) + - (define (deps file) - (let ((entry (assoc file dependencies))) - (if entry (cdr entry) '()))) ++ (define-integrable (file-environment file) ++ (->environment (package/name (file-package file)))) + - (for-each (lambda (file.deps) - (if (not (for-all? string? file.deps)) - (error "Bogus dependency:" file.deps))) - dependencies) ++ (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 - (warn "Package already exists:" (package/name (car packages))) - ;; Build package(s) for use at syntax-time. ++ (error "Package already exists:" existing) + (construct-packages-from-file + (construct-external-descriptions pmodel)))) + + (for-each + (lambda (file) - (compile-file file (deps file) (env file)) - (load 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))))) diff --cc src/cref/redpkg.scm index 56ee91451,99641bd48..6b545f601 --- a/src/cref/redpkg.scm +++ b/src/cref/redpkg.scm @@@ -387,13 -372,6 +372,13 @@@ USA package (append! (package-description/finalizations package) (list finalization)))))) + ((DEPENDS-ON) + (if (not (check-list (cdr option) string?)) - (error "illegal dependencies" option)) ++ (error "Illegal depends-on" (cdr option))) + (set-package-description/depends-on! + package + (append! (package-description/depends-on package) + (map parse-filename (cdr option))))) (else (error "Unrecognized option keyword:" (car option))))) options)) @@@ -605,10 -581,6 +588,10 @@@ (append-map! (lambda (file-case) (append-map cdr (cdr file-case))) file-cases)))) - (let ((dependencies (package-description/depends-on description))) - (set-package/depends-on! - package - (append! (package/depends-on package) (list-copy dependencies)))) ++ (set-package/depends-on! ++ package ++ (append! (package/depends-on package) ++ (list-copy (package-description/depends-on description)))) (for-each (lambda (export) (let ((destination (get-package (car export) #t))) (for-each (lambda (names) diff --cc src/gtk/compile.scm index 03b1a6077,000000000..ddefcef06 mode 100644,000000..100644 --- a/src/gtk/compile.scm +++ b/src/gtk/compile.scm @@@ -1,12 -1,0 +1,10 @@@ +#| -*-Scheme-*- |# + - ;;;; Syntax the GTK system ++;;;; Compile the GTK system + +(fluid-let ((load/suppress-loading-message? #t)) + (load-option 'CREF) + (load-option 'SOS) + (load-option 'FFI)) + - (sf-package-set "gtk-new") - - (cref/generate-constructors "gtk" 'ALL) ++(compile-system "gtk-new" (directory-pathname (current-load-pathname))) diff --cc src/gtk/gobject.scm index 1425e9af5,000000000..f795185d1 mode 100644,000000..100644 --- a/src/gtk/gobject.scm +++ b/src/gtk/gobject.scm @@@ -1,633 -1,0 +1,633 @@@ +#| -*-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 () + + ;; 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 ") + +(define-integrable (gobject-live? object) + (not (alien-null? (gobject-alien object)))) + +(define-method initialize-instance ((object )) + (call-next-method object) + (set-gobject-weak-self! + object (add-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) - (declare (ignore instance)) + ;; 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 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))) + +;;; 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))))))) + + +;;; 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?)) + +;;; 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) + +;;; GdkPixbufLoaders + +(define-class ( (constructor ())) + () + (port define standard initial-value #f) + (thread define standard initial-value #f) + (size define standard initial-value #f) + (pixbuf define standard initial-value #f) + (error-message define standard initial-value #f) + (closed? define standard initial-value #f) + (size-hook define standard initial-value #f + modifier %set-pixbuf-loader-size-hook!) + (pixbuf-hook define standard initial-value #f + modifier %set-pixbuf-loader-pixbuf-hook!) + (update-hook define standard initial-value #f) + (close-hook define standard initial-value #f + modifier %set-pixbuf-loader-close-hook!)) + +(define-class ( (constructor ())) + ()) + +(define-method initialize-instance ((pixbuf )) + (call-next-method pixbuf) + (set-alien/ctype! (gobject-alien pixbuf) '|GdkPixbuf|)) + +(define-method initialize-instance ((loader )) + (call-next-method loader) + (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))))) + +(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!) diff --cc src/gtk/gtk-new.pkg index d8ea860b9,000000000..c1bc66795 mode 100644,000000..100644 --- a/src/gtk/gtk-new.pkg +++ b/src/gtk/gtk-new.pkg @@@ -1,363 -1,0 +1,359 @@@ +#| -*-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") + - ;;; This is largely a copy of gtk.pkg, with a few new declarations added. - - (declare (usual-integrations)) - +(define-package (gtk) + (parent ()) + (files "gtk")) + +(define-package (gtk gobject) + (parent (gtk)) + (files "gobject") + (depends-on "gtk-const.bin") + (export (gtk) + 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 + 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 + + gdk-window-process-updates)) + +(define-package (gtk pango) + (parent (gtk)) + (files "pango") + (depends-on "gtk-const.bin") + (export (gtk) + + 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? guarantee-gtk-object + gtk-object-destroyed? gtk-object-destroy + gtk-adjustment? guarantee-gtk-adjustment + make-gtk-adjustment set-gtk-adjustment! + 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? 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? 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? guarantee-gtk-label + gtk-label-new + gtk-label-get-text gtk-label-set-text + gtk-label-set-width-chars + gtk-button? guarantee-gtk-button + gtk-button-new + set-gtk-button-clicked-callback! + gtk-check-button? guarantee-gtk-check-button + gtk-check-button-new + gtk-check-button-get-active gtk-check-button-set-active + set-gtk-check-button-toggled-callback! + gtk-vbox? guarantee-gtk-vbox gtk-vbox-new + gtk-hbox? guarantee-gtk-hbox gtk-hbox-new + gtk-box-pack-start gtk-box-pack-end + gtk-frame? guarantee-gtk-frame gtk-frame-new + gtk-frame-set-shadow-type + gtk-scrolled-window? + guarantee-gtk-scrolled-window gtk-scrolled-window-new + gtk-scrolled-window-set-policy gtk-scrolled-window-set-placement) + (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) + + 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? 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! + + guarantee-fix-drawing + make-fix-drawing fix-drawing-widgets + set-fix-drawing-size! fix-drawing-pick-list + fix-drawing-add-ink! + + fix-ink? + fix-ink-drawing + fix-ink-widgets set-fix-ink-widgets! + fix-ink-move! fix-ink-remove! + + + line-ink? make-line-ink set-line-ink! + line-ink-width set-line-ink-width! + line-ink-color set-line-ink-color! + line-ink-dash-color set-line-ink-dash-color! + + 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? make-arc-ink set-arc-ink! + arc-ink-start-angle set-arc-ink-start-angle! + arc-ink-sweep-angle set-arc-ink-sweep-angle! + arc-ink-color set-arc-ink-color! + arc-ink-width set-arc-ink-width! + arc-ink-fill-color set-arc-ink-fill-color! + + text-ink? + set-text-ink-position! + text-ink-xy-to-index + with-text-ink-grapheme-rect + text-ink-color set-text-ink-color! + + simple-text-ink? make-simple-text-ink + simple-text-ink-text set-simple-text-ink-text! + simple-text-ink-font set-simple-text-ink-font! + + make-image-ink-from-file set-image-ink! + + box-ink? make-box-ink + set-box-ink! set-box-ink-position! + box-ink-shadow set-box-ink-shadow! + + ;; make-hline-ink set-hline-ink-size! + ;; 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))