From: Matt Birkholz Date: Wed, 9 Oct 2013 23:39:02 +0000 (-0700) Subject: Eliminate compile-system in gtk and planetarium. X-Git-Tag: mit-scheme-pucked-9.2.12~452 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ee97317d8efa16da970cbe86081a578219520a08;p=mit-scheme.git Eliminate compile-system in gtk and planetarium. Fixed old, build-tree-relative global-definitions declarations. --- diff --git a/src/gtk/compile.scm b/src/gtk/compile.scm index b7a9470de..c9e517ec3 100644 --- a/src/gtk/compile.scm +++ b/src/gtk/compile.scm @@ -1,50 +1,71 @@ -#| -*-Scheme-*- |# +#| -*-Scheme-*- -;;;; Compile the GTK system +Copyright (C) 2009, 2010, 2011, 2012, 2013 Matthew Birkholz -(fluid-let ((load/suppress-loading-message? #t)) - (load-option 'CREF) - (load-option 'SOS) - (load-option 'FFI)) +This file is part of an extension to MIT/GNU Scheme. -(with-system-library-directories - '("./") +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. + +|# + +;;;; Compile the GTK wrapper. + +(load-option 'CREF) +(load-option 'SOS) +(load-option 'FFI) +(with-working-directory-pathname (directory-pathname (current-load-pathname)) (lambda () - (compile-system "gtk" (directory-pathname (current-load-pathname)) - ;; Temporary hack, until the released CREF loosens up - ;; and simply warns about new options it does not - ;; support, like the depends-on options commented out - ;; of gtk.pkg and recreated below. - 'dependencies - (let ( - ;; gtk.scm includes the Gtk c-includes, but does - ;; not otherwise use the FFI. - (c-types '("gtk-const.bin")) - - ;; The wrappers use the FFI, c-includes, and - ;; some integrable definitions in gtk.scm. - ;; Dependencies between them are rare. - (base '("gtk.bin" "gtk" - ;; "../runtime/ffi" ;; No workie???!!! - )) - - ;; Users of the toolkit interface do NOT use the - ;; FFI directly, and do not need integrable - ;; definitions. - (user '())) - `(("gtk" ,@c-types) - ("gobject" ,@base) - ("gio" ,@base) - ("pango" ,@base) - ("cairo" ,@base) - ("gtk-widget" ,@base) - ("scm-widget" ,@base) - ("fix-layout" "pango" "cairo" ,@base ,@c-types) - ("keys" ,@base ,@c-types) - ("gtk-graphics" ,@base) - ("main" ,@base) - ("thread" "main" ,@user) - ("gtk-ev" ,@base) - ("fix-demo" ,@user) - ("swat" ,@user) - ("swat-pole-zero" ,@user)))))) \ No newline at end of file + (with-system-library-directories + '("./") + (lambda () + (if (name->package '(GTK)) + (error "The GTK package already exists.") + (let ((package-set (package-set-pathname "gtk"))) + (if (not (file-exists? package-set)) + (cref/generate-trivial-constructor "gtk")) + (construct-packages-from-file (fasload package-set)))) + + ;; gtk.scm includes the Gtk c-includes, but does not otherwise + ;; use the FFI. + (compile-file "gtk" '("gtk-const.bin") (->environment '(gtk))) + ;; Mostly to set! c-includes: + (load "gtk" (->environment '(gtk))) + + ;; The wrappers use the FFI, c-includes, and some integrable + ;; definitions in gtk.scm. Dependencies between them are + ;; rare. + (compile-file "gobject" '("gtk") (->environment '(gtk gobject))) + (compile-file "gio" '("gtk") (->environment '(gtk gio))) + (compile-file "pango" '("gtk") (->environment '(gtk pango))) + (compile-file "cairo" '("gtk") (->environment '(gtk cairo))) + (compile-file "gtk-widget" '("gtk") (->environment '(gtk gtk-widget))) + (compile-file "scm-widget" '("gtk") (->environment '(gtk widget))) + (compile-file "fix-layout" '("pango" "cairo" "gtk") + (->environment '(gtk fix-layout))) + (compile-file "keys" '("gtk") (->environment '(gtk keys))) + (compile-file "main" '("gtk") (->environment '(gtk main))) + (compile-file "thread" '("main") (->environment '(gtk thread))) + (compile-file "gtk-ev" '("gtk") (->environment '(gtk event-viewer))) + (compile-file "gtk-graphics" '("gtk") + (->environment '(runtime gtk-graphics))) + + ;; Users of the toolkit interface do NOT use the FFI directly, + ;; and do not need integrable definitions. + (compile-file "fix-demo" '() (->environment '(gtk fix-layout demo))) + (compile-file "swat" '() (->environment '(gtk swat))) + (compile-file "swat-pole-zero" '() (->environment '(swat))) + + (cref/generate-constructors "gtk" 'ALL))))) \ No newline at end of file diff --git a/src/gtk/gtk.pkg b/src/gtk/gtk.pkg index 007183d0c..a843958e8 100644 --- a/src/gtk/gtk.pkg +++ b/src/gtk/gtk.pkg @@ -23,9 +23,9 @@ USA. ;;;; Gtk System Packaging -(global-definitions "../runtime/runtime") -(global-definitions "../ffi/ffi") -(global-definitions "../sos/sos") +(global-definitions runtime/) +(global-definitions ffi/) +(global-definitions sos/) (define-package (gtk) (parent ()) @@ -395,14 +395,6 @@ USA. (export () make-gtk-event-viewer-demo)) -(define-package (gtk fix-layout demo) - (parent (gtk fix-layout)) - (files "fix-demo") - (import (gtk fix-layout) - fix-layout-view) - (export () - make-fix-layout-demo)) - (define-package (runtime gtk-graphics) (parent (gtk)) (files "gtk-graphics") @@ -422,6 +414,14 @@ USA. gtk-graphics/flush gtk-graphics/make)) +(define-package (gtk fix-layout demo) + (parent (gtk fix-layout)) + (files "fix-demo") + (import (gtk fix-layout) + fix-layout-view) + (export () + make-fix-layout-demo)) + (define-package (gtk swat) (parent (gtk)) (files "swat") diff --git a/src/planetarium/mit-compile.scm b/src/planetarium/mit-compile.scm index e3929681e..453d92ad0 100644 --- a/src/planetarium/mit-compile.scm +++ b/src/planetarium/mit-compile.scm @@ -22,9 +22,37 @@ USA. |# (load-option 'CREF) -(compile-system "mit" (directory-pathname (current-load-pathname)) - 'dependencies - `(("solar" "geometry") - ("earth" "geometry" "matrices") - ("mit-cil" "mit-syntax" ,@(directory-read "cil-*.txt")) - ("tellurion" "geometry" "matrices"))) \ No newline at end of file + +(with-working-directory-pathname (directory-pathname (current-load-pathname)) + (lambda () + (if (name->package '(PLANETARIUM)) + (error "The PLANETARIUM package already exists.") + (let ((package-set (package-set-pathname "mit"))) + (if (not (file-exists? package-set)) + (cref/generate-trivial-constructor "mit")) + (construct-packages-from-file (fasload package-set)))) + + (compile-file "mit-r3rs" '() (->environment '(r3rs extras))) + (load "mit-r3rs" (->environment '(r3rs extras))) + + (compile-file "mit-syntax" '() (->environment '(planetarium syntax))) + (load "mit-syntax" (->environment '(planetarium syntax))) + + (let ((planet (->environment '(planetarium)))) + (for-each (lambda (file) (compile-file file '() planet)) + '("geometry" "matrices" "time" "graphics")) + (compile-file "solar" '("geometry") planet) + (compile-file "earth" '("geometry" "matrices") planet) + (compile-file "tellurion" '("geometry" "matrices") planet)) + + (compile-file "mit-gtk" '() + (->environment '(planetarium gtk-graphics))) + (compile-file "mit-x" '() + (->environment '(planetarium x-graphics))) + (compile-file "mit-graphics" '() + (->environment '(planetarium simple-graphics))) + + (compile-file "mit-cil" `("mit-syntax" ,@(directory-read "cil-*.txt")) + (->environment '(planetarium earth-cil))) + + (cref/generate-constructors "mit" 'ALL))) \ No newline at end of file diff --git a/src/planetarium/mit-snapshot.scm b/src/planetarium/mit-snapshot.scm index 0a5dcee92..f23caf014 100644 --- a/src/planetarium/mit-snapshot.scm +++ b/src/planetarium/mit-snapshot.scm @@ -30,7 +30,15 @@ USA. (directory-pathname (current-load-pathname)) (lambda () (load "mit-compile") - (load-package-set "mit"))) + (let* ((package-set (package-set-pathname "mit")) + (file (fasload package-set))) + (if (not ((access package-file? (->environment '(package))) file)) + (error "Malformed package-description file:" pkg)) + (load-packages-from-file file '() + (lambda (pathname environment) + (load pathname environment 'DEFAULT #t))) + ((access initialize-packages-from-file (->environment '(package))) file) + (flush-purification-queue!)))) (let ((planet (->environment '(planetarium))) (graphics (->environment '(planetarium gtk-graphics)))) diff --git a/src/planetarium/mit.pkg b/src/planetarium/mit.pkg index cf435e53f..56dcb8918 100644 --- a/src/planetarium/mit.pkg +++ b/src/planetarium/mit.pkg @@ -23,8 +23,8 @@ USA. ;;;; Planetarium Packaging -(global-definitions "../runtime/runtime") -(global-definitions "../gtk/gtk") +(global-definitions runtime/) +(global-definitions gtk/) (define-package (r3rs essential) (parent #f) @@ -119,8 +119,8 @@ USA. (files "geometry" "matrices" "time" - "solar" "graphics" + "solar" "earth" "tellurion") (export ()