From: Matt Birkholz Date: Wed, 22 Jun 2011 16:15:07 +0000 (-0700) Subject: Require FFI option. Punt compile-/run-time separation. X-Git-Tag: mit-scheme-pucked-9.2.12~697 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=5c52b501caf687ebad1aaa0dd7e48dd0fbb9b3da;p=mit-scheme.git Require FFI option. Punt compile-/run-time separation. This eliminates unanalyzable (unCREFable) syntax transformers, and compile-time imports. Bind c-includes in (gtk) so that it does not need to be c-included in every subpackage. This assumes compile-system is used, and that gtk.scm/bin/com is loaded before subpackages are compiled. --- diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm index bd6aba49c..8b095feed 100644 --- a/src/gtk/compile.scm +++ b/src/gtk/compile.scm @@ -26,9 +26,4 @@ ("main" "gtk-const.bin") ("gtk-ev" "gtk.ext" "pango.ext" "gtk-const.bin") ("fix-demo" "gtk.ext" "pango.ext") - ("swat" "gtk.ext" "pango.ext")) - ;; - ;; Compile-time imports that needn't (shouldn't) exist - ;; at run-time. - 'imports - '(((gtk keys) (ffi) find-c-includes c-enum-constant-values))) \ No newline at end of file + ("swat" "gtk.ext" "pango.ext"))) \ No newline at end of file diff --git a/src/gtk/fix-layout.scm b/src/gtk/fix-layout.scm index 5c3ac65f3..cbc1d496a 100644 --- a/src/gtk/fix-layout.scm +++ b/src/gtk/fix-layout.scm @@ -24,8 +24,6 @@ USA. ;;;; : A fixnum-centric canvas. ;;; package: (gtk fix-layout) -(c-include "gtk") - (define-class ( (constructor () (width height))) () diff --git a/src/gtk/gobject.scm b/src/gtk/gobject.scm index 971b2daef..edbeb3f21 100644 --- a/src/gtk/gobject.scm +++ b/src/gtk/gobject.scm @@ -24,8 +24,6 @@ USA. ;;;; GObjects ;;; package: (gtk gobject) -(c-include "gtk") - (define-class () ;; The address of the toolkit object. A null alien if the GObject diff --git a/src/gtk/gtk-ev.scm b/src/gtk/gtk-ev.scm index 177b567f2..1fbe35899 100644 --- a/src/gtk/gtk-ev.scm +++ b/src/gtk/gtk-ev.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -24,8 +24,6 @@ USA. ;;;; An event viewer, a translation of Havoc Pennington's GtkEv example. ;;; package: (gtk event-viewer) -(c-include "gtk") - (define (make-gtk-event-viewer-demo) (let ((window (gtk-window-new 'toplevel)) (gtk-ev (make-gtk-event-viewer))) diff --git a/src/gtk/gtk-object.scm b/src/gtk/gtk-object.scm index f7cde673a..e1b62849d 100644 --- a/src/gtk/gtk-object.scm +++ b/src/gtk/gtk-object.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -24,8 +24,6 @@ USA. ;;;; GtkObjects/GtkWidgets/GtkContainers ;;; package: (gtk gtk-object) -(c-include "gtk") - (define-class () (destroyed? define standard initial-value #f)) diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 9a5fdd76a..b5416a63e 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -89,7 +89,7 @@ USA. gtk-widget? guarantee-gtk-widget gtk-widget-parent gtk-widget-realized? - gtk-widget-drawable? gtk-widget-has-focus? + gtk-widget-drawable? gtk-widget-has-focus? gtk-widget-grab-focus gtk-widget-show gtk-widget-show-all @@ -236,9 +236,7 @@ USA. (export (gtk) gdk-key-state->char-bits gdk-keyval->name) - ;; Needed (only) at compile-time. - ;; Positively NOT needed at run-time. - #;(import (ffi) + (import (ffi) find-c-includes c-enum-constant-values)) @@ -250,6 +248,8 @@ USA. stop-gtk-thread) (import (gtk gobject) run-gc-cleanups) + (import (gtk main) + run-gtk) (import (runtime primitive-io) select-registry-handle)) diff --git a/src/gtk/gtk.scm b/src/gtk/gtk.scm index 2ef3620a5..80de6a54f 100644 --- a/src/gtk/gtk.scm +++ b/src/gtk/gtk.scm @@ -24,6 +24,8 @@ USA. ;;;; Core utilities. ;;; package: (gtk) +(define c-includes (load-c-includes "gtk")) + (define-syntax define-integrable-operator (er-macro-transformer (lambda (form rename compare) diff --git a/src/gtk/keys.scm b/src/gtk/keys.scm index c1d460687..b24ffbf34 100644 --- a/src/gtk/keys.scm +++ b/src/gtk/keys.scm @@ -24,8 +24,6 @@ USA. ;;;; Gtk Keys ;;; Package: (gtk keys) -(c-include "gtk") - (define (gdk-key-state->char-bits modifier-state) (fix:+ (if (bit? modifier-state (C-enum "GDK_CONTROL_MASK")) char-bit:control 0) diff --git a/src/gtk/main.scm b/src/gtk/main.scm index 82848c6c6..a796a801b 100644 --- a/src/gtk/main.scm +++ b/src/gtk/main.scm @@ -24,8 +24,6 @@ USA. ;;;; Main Loop Hack ;;; package: (gtk main) -(c-include "gtk") - (define (gtk-start) ;; Called from gtk/make.scm, from a (load-option 'Gtk). (set! hook/subprocess-wait nonblocking/subprocess-wait) @@ -83,6 +81,9 @@ USA. (create-gtk-thread) (cdr new-args))))))) +(define (run-gtk select-registry-handle time) + (C-call "run_gtk" select-registry-handle time)) + (define (stop-gtk) ;; Sortof does the opposite of gtk-start. (without-interrupts diff --git a/src/gtk/make.scm b/src/gtk/make.scm index 4514aaa05..8bc32f2fd 100644 --- a/src/gtk/make.scm +++ b/src/gtk/make.scm @@ -3,6 +3,7 @@ Load the Gtk option. |# (load-option 'SOS) +(load-option 'FFI) ;; (ffi) package referenced in gtk.pkg! (with-loader-base-uri (system-library-uri "gtk/") (lambda () (load-package-set "gtk"))) diff --git a/src/gtk/pango.scm b/src/gtk/pango.scm index 50e18131d..5be39e7ef 100644 --- a/src/gtk/pango.scm +++ b/src/gtk/pango.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2009, 2010 Matthew Birkholz +Copyright (C) 2009, 2010, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -24,8 +24,6 @@ USA. ;;;; Pango interface. ;;; package: (gtk pango) -(c-include "gtk") - (define-class ( (constructor ())) ()) diff --git a/src/gtk/scm-widget.scm b/src/gtk/scm-widget.scm index 3311d974f..a49635df7 100644 --- a/src/gtk/scm-widget.scm +++ b/src/gtk/scm-widget.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -Copyright (C) 2007, 2008, 2009, 2010 Matthew Birkholz +Copyright (C) 2007, 2008, 2009, 2010, 2011 Matthew Birkholz This file is part of MIT/GNU Scheme. @@ -24,8 +24,6 @@ USA. ;;;; A representing a ScmWidget. ;;; package: (gtk widget) -(c-include "gtk") - (define-class ()) (define-guarantee scm-widget "a ") diff --git a/src/gtk/thread.scm b/src/gtk/thread.scm index b492f7bc2..c3dabca33 100644 --- a/src/gtk/thread.scm +++ b/src/gtk/thread.scm @@ -25,8 +25,6 @@ USA. ;;; package: (gtk thread) ;;; parent: (runtime thread) -(c-include "gtk") - (define gtk-thread #f) ;; Number of GCs between applications of trigger-secondary-gc-daemons! @@ -69,9 +67,7 @@ USA. (or next-scheduled-timeout (no-threads-nor-timers))))) (%trace ";run-gtk until "time"\n") - (C-call "run_gtk" - (select-registry-handle io-registry) - time) + (run-gtk (select-registry-handle io-registry) time) (%trace ";run-gtk done at "(real-time-clock)"\n")) (maybe-signal-io-thread-events))) (yield-current-thread)