;;; -*- Mode: LISP; Syntax: Common-Lisp; Package: USER; Base: 10 -*- ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The Garnet User Interface Development Environment. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; This code was written as part of the Garnet project at ;;; ;;; Carnegie Mellon University, and has been placed in the public ;;; ;;; domain. If you are using this code or any part of Garnet, ;;; ;;; please contact garnet@cs.cmu.edu to be put on the mailing list. ;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; This file loads all the garnet modules. ;;; ;;; ** To prevent certain parts from being loaded, first set ;;; user::load-XX-p to NIL. ;;; ** To get some of the parts which are not loaded by default to be loaded, ;;; set user::load-XX-p to T. ;;; ** If you are a non-CMU user, set Your-Garnet-Pathname to be your local ;;; Garnet directory, and set Your-CLX-Pathname to be your local CLX ;;; directory. ;;; ** To override where something is loaded from, set Garnet-xx-PathName ;;; before loading this file and/or Garnet-xx-src ;;; ;;; The controlling variables are: ;;; ;;; load-clx-p (Default: NIL => clx not loaded) ;;; load-utils-p (Default: T => utilities loaded) ;;; load-kr-p (Default: T => kr loaded) ;;; load-opal-p (Default: T => opal loaded) ;;; load-inter-p (Default: T => interactors loaded) ;;; load-multifont-p (Default: NIL => multifont *NOT* loaded) ;;; load-gesture-p (Default: NIL => gestures *NOT* loaded) ;;; load-ps-p (Default: T => ps loaded) ;;; load-aggregadgets-p (Default: T => aggregadgets loaded) ;;; load-aggregraphs-p (Default: NIL => aggregraphs *NOT* loaded) ;;; load-gadgets-p (Default: NIL => gadgets *NOT* loaded) ;;; load-debug-p (Default: T => debugging tools loaded) ;;; load-demos-p (Default: NIL => demos *NOT* loaded) ;;; load-c32-p (Default: NIL => C32 *NOT* loaded) ;;; load-gilt-p (Default: NIL => gilt *NOT* loaded) ;;; load-lapidary-p (Default: NIL => lapidary *NOT* loaded) ;;; ;;; The first part of this file lists the file names where the various ;;; parts of Garnet come from. This will need to be modified for each new ;;; installation of Garnet. ;;; ;;; To override any particular file name place, it is only necessary to ;;; assign the variable name Garnet-XX-Pathname before this file is loaded ;;; (since they are defined here using defvar, the old name will stay in ;;; affect). ;;; #| ============================================================ Change log: 9/22/93 Bruno Haible - Added FLET for merge-pathnames in CLISP 8/13/93 Andrew Mickish - Added user::Garnet-Readtable 8/12/93 Andrew Mickish - Closed display in Verify-Display-Can-Be-Opened; added #+garnet-processes to *features* list 5/17/93 Andrew Mickish - Added compiler optimization proclamation 5/13/93 Andrew Mickish - Removed commas from Garnet-Load-Alist so it notices changes in the values of the pathname variables 4/15/93 Andrew Mickish - Added lucid memory-management instruction 4/ 5/93 Dave Kosbie - Added Garnet-Utils package (where Garnet-independent Lisp utilities will now reside) 3/25/93 Andrew Mickish - Made Garnet-Load use an association list 3/17/93 Andrew Mickish - Removed Motif-Gilt-Loader 10/23/92 Dave Kosbie - Added KATIE package 08/17/92 Andrew Mickish - Added display check, changed names of switches, changed names of directories, changed method for determining Garnet pathnames 07/29/92 Andrew Mickish - :cmu-sparc now loads from cmu-bin, removed :cmu and :test versions. 07/23/92 Dario Giuse - moved loading of C32 before Lapidary, which needs it. 05/27/92 Joly - Interactors package should use kr package. 05/25/92 Joly/Pervin - Package CLTL1 does not exist in LispWorks. 05/21/92 Dario Giuse - Added load-c32-p. 05/14/92 Szekely/Pervin - Do not launch process if compiling. 05/04/92 Russell Almond - Added allegro-v4.1 switches. 04/22/92 Ed Pervin - Added launch-process-p switch. 04/10/92 Andrew Mickish - Added "gg:" prefix to garnet-load and garnet-compile 04/02/92 Rich McDaniel - Added load-multifont-p 03/13/92 Ed Pervin - Added :cmu-test 03/11/92 Andrew Mickish - Removed unlesses from CMU ext:search-list setf's 03/06/92 Andrew Mickish - Added *compiler-extension* switches 02/20/92 Andrew Mickish - Added package definitions for Explorer lisp; Added gesture pathnames, etc. 02/11/92 Andrew Mickish - Added :garnet-debug to *features* list; changed pathnames from /afs/cs/ to /afs/cs.cmu.edu/. 04/25/91 Ed Pervin - Official release of version 1.4; alpha directory changed back to test. No longer support :cmu-lucid3.1 and :cmu-lucid4.0. 04/19/91 Ed Pervin - Added lispworks to switches. 04/15/91 Ed Pervin - Changed (make-packages **) to (unless (find-package **) (make-package **)). 04/03/91 Ed Pervin - Changed :sparc-test4.0 --> :sparc-test and added :pmax-test. 03/21/91 Ed Pervin - Release 1.4; test directory changed to alpha. 03/07/91 Andrew Mickish - Added aggregraphs. 03/07/91 Brad Myers - Made new motif-gilt-loader, and also garnet-load. 03/01/91 Ed Pervin - Added :sparc-test for version compiled in Allegro 4.0. 02/27/91 Dilip D'Souza - Added everything with #+allegro-v4.0 switches. 02/25/91 Ed Pervin - Pushed :garnet on *features* list. 01/24/91 Andrew Mickish - Added Gilt. 01/02/90 Andrew Mickish - Added :rt-test and :sparc-test options. 11/29/90 Brad Myers - Added :cmu-sparc option. 10/05/90 Ed Pervin - New variables Your-Garnet-Pathname and Your-CLX-Pathname which determine all the :external pathnames. 08/09/90 Ed Pervin - Release 1.3 08/07/90 Ed Pervin - rbd --> ecp 07/25/90 Ed Pervin - Added *dont-load-modules-twice*; amickish --> preddy 04/02/90 Ed Pervin - Call xlib:load-clx in Lucid explicitly. 03/19/90 Ed Pervin - Got rid of Garnet-Font-Pathname 02/14/90 Ed Pervin - Added color screen option 01/04/90 Ed Pervin - Added :external option and version number 12/19/89 Ed Pervin - Now loads CLX. 12/13/89 Ed Pervin - Added :cmu-allegro option. 12/05/89 Brad Myers - Fixed so works with garnet-compiler 10/30/89 Brad Myers - New file structure and src directories; changed dont-load-xx to load-xxx-p 10/17/89 Brad Myers - Added debug 08/18/89 Brad Myers - Added Toolkit 06/07/89 Brad Myers - Created ============================================================ |# (in-package "USER") (defparameter Garnet-Version-Number "2.2") (pushnew :GARNET *features*) (pushnew :GARNET-V2.2 *features*) ;;; The :GARNET-DEBUG option allows many different kinds of run-time checking, ;;; and also loads some extra test code. After you have debugged your code ;;; and want it to run faster, remove :GARNET-DEBUG from the *features* list ;;; and RECOMPILE all of Garnet and your code. The result will be smaller and ;;; somewhat faster. ;;; To remove :GARNET-DEBUG from the *features* list, either defvar ;;; Garnet-Garnet-Debug to NIL before you load the garnet-loader, or simply ;;; comment out the next few lines. (defvar Garnet-Garnet-Debug T) (if Garnet-Garnet-Debug (pushnew :garnet-debug *features*) (setf *features* (delete :garnet-debug *features*))) ;;; The :GARNET-PROCESSES keyword goes on the *features* list if this version ;;; of lisp supports multiple processes. Then things like the animation ;;; interactor can use the #+garnet-processes switch, instead of referring ;;; explicitly to different versions of lisp. #+(or allegro lucid lispworks) (pushnew :GARNET-PROCESSES *features*) ;; This variable is used by Allegro to restore the old value of the *readtable* ;; when a saved image is restarted (see opal:make-image in opal/utils.lisp). (defvar Garnet-Readtable *readtable*) ;; Set compiler optimization settings ;; (defvar *default-garnet-proclaim* #+allegro '(optimize (speed 3) (safety 1) (space 0) (debug #+garnet-debug 3 #-garnet-debug 0)) ;; Lucid needs a safety of 1 and compilation-speed of 0 to avoid problems ;; with CLX calls. #+lucid '(optimize (compilation-speed 0) (safety 1) (speed 2)) #+cmu '(optimize (speed 3) (safety 1) (space 0)) #+lispworks '(optimize (speed 3) (safety 1) (space 0) ; CT added this (debug #+garnet-debug 3 #-garnet-debug 0)) #-(or allegro lucid cmu lispworks) NIL) (when user::*default-garnet-proclaim* (proclaim user::*default-garnet-proclaim*)) ;; The function provide is no longer part of common lisp and so was ;; removed from the lisp package in the most recent release of ;; LispWorks (version 2.1 onwards). This will retrieve its definition. #+lispworks (setf (symbol-function 'lisp::provide) (symbol-function 'system::provide)) #+lispworks (export 'provide 'lisp) #+lucid (change-memory-management :growth-limit 655 :expand 400) #+(or allegro-v4.0 allegro-v4.1) (setf excl::*cltl1-in-package-compatibility-p* t) #+(or allegro-v4.0 allegro-v4.1) (setf comp:*cltl1-compile-file-toplevel-compatibility-p* t) #+(or allegro-v4.0 allegro-v4.1) (progn (unless (find-package "GARNET-UTILS") (make-package "GARNET-UTILS" :use '("LISP" "CLTL1") :nicknames '("GU"))) (unless (find-package "KR") (make-package "KR" :use '("LISP" "CLTL1"))) (unless (find-package "KR-DEBUG") (make-package "KR-DEBUG" :use '("LISP" "CLTL1"))) (unless (find-package "OPAL") (make-package "OPAL" :use '("LISP" "KR" "CLTL1"))) (unless (find-package "KATIE") (make-package "KATIE" :use '("LISP" "KR" "CLTL1") :nicknames '("KT"))) (unless (find-package "INTERACTORS") (make-package "INTERACTORS" :use '("LISP" "KR" "CLTL1") :nicknames '("INTER"))) (unless (find-package "GARNET-GADGETS") (make-package "GARNET-GADGETS" :use '("LISP" "KR" "CLTL1") :nicknames '("GG"))) (unless (find-package "GARNET-DEBUG") (make-package "GARNET-DEBUG" :use '("KR" "OPAL" "LISP" "CLTL1") :nicknames '("GD"))) (unless (find-package "GILT") (make-package "GILT" :use '("LISP" "KR" "CLTL1"))) (unless (find-package "C32") (make-package "C32" :use '("LISP" "KR" "CLTL1"))) (unless (find-package "GARNETDRAW") (make-package "GARNETDRAW" :use '("LISP" "KR" "CLTL1"))) (unless (find-package "LAPIDARY") (make-package "LAPIDARY" :use '("LISP" "KR" "CLTL1")))) #-(or allegro-v4.0 allegro-v4.1) (progn (unless (find-package "GARNET-UTILS") (make-package "GARNET-UTILS" :use '("LISP") :nicknames '("GU"))) (unless (find-package "KR") (make-package "KR" :use '("LISP"))) (unless (find-package "KR-DEBUG") (make-package "KR-DEBUG" :use '("LISP"))) (unless (find-package "OPAL") (make-package "OPAL" :use '("LISP" "KR"))) (unless (find-package "INTERACTORS") (make-package "INTERACTORS" :use '("LISP" "KR") :nicknames '("INTER"))) (unless (find-package "GARNET-GADGETS") (make-package "GARNET-GADGETS" :use '("LISP" "KR") :nicknames '("GG"))) (unless (find-package "GARNET-DEBUG") (make-package "GARNET-DEBUG" :use '("KR" "OPAL" "LISP") :nicknames '("GD"))) (unless (find-package "GILT") (make-package "GILT" :use '("LISP" "KR"))) (unless (find-package "C32") (make-package "C32" :use '("LISP" "KR"))) (unless (find-package "GARNETDRAW") (make-package "GARNETDRAW" :use '("LISP" "KR"))) (unless (find-package "LAPIDARY") (make-package "LAPIDARY" :use '("LISP" "KR")))) ;;; *dont-load-modules-twice* tells whether to re-load modules ;;; if a user loads garnet-loader.lisp a second time. (defparameter *dont-load-modules-twice* t) (unless (boundp '*Garnet-Going-To-Compile*) (defvar load-utils-p T) (defvar load-kr-p T) (defvar load-opal-p T) (defvar load-inter-p T) (defvar load-multifont-p NIL) (defvar load-gesture-p NIL) (defvar load-ps-p T) (defvar load-aggregadgets-p T) (defvar load-aggregraphs-p NIL) (defvar load-debug-p #+garnet-debug T #-garnet-debug NIL) (defvar load-gadgets-p NIL) (defvar load-demos-p NIL) (defvar load-lapidary-p NIL) (defvar load-gilt-p NIL) (defvar load-c32-p NIL)) ;;; load-XX-p control whether the various parts are loaded or not ;;; Because these use defvar, if they are set before this file is ;;; loaded, their original value will be used. (defvar load-clx-p #+clx NIL #-clx T) ;;; launch-process-p controls whether Garnet will launch ;;; a separate process to detect keyboard and mouse events. (defvar launch-process-p T) ;;; update-locking-p controls whether process locks will be activated ;;; around the update method (this keeps two processes from calling update ;;; at the same time). (defvar update-locking-p T "If T, uses process locks to keep Update in a process from interrupting itself in a different process.") (defun Version-Error () (error "Could not determine which compiled binaries are appropriate to load into your lisp. Please set user::Garnet-Version before loading Garnet-Loader again.")) (defun Get-Garnet-Version () #+sparc (or #+allegro-v4.0 :sparc-allegro #+allegro-v4.1 :sparc-allegro4.1 #+cmu :sparc-cmucl #+lucid :sparc-lucid #-(and allegro-v4.0 allegro-v4.1 cmu lucid) (version-error)) #+dec3100 (or #+allegro-v3.1 :pmax-allegro #+allegro-v4.1 :pmax-allegro4.1 #-(and allegro-v3.1 allegro-v4.1) (version-error)) #+pa (or #+lucid :hp-lucid #-lucid (version-error)) #+clisp :clisp #+lispworks :alpha-lw #-(or sparc dec3100 pa clisp lispworks) (version-error)) ;;; Garnet-Version controls where the files are loaded from. ;;; Because this is a defvar, if Garnet-Version is set before this file is ;;; loaded, its original value will be used. ;;; Garnet-Version should be set to :external for non-CMU users, and ;;; Your-Garnet-Pathname should be set appropriately. ;;; (defvar garnet-version :external) (format T "** Loading Garnet Version ~a from ~s~%" Garnet-Version-Number Garnet-Version) ;;; Insert your pathname of Garnet into Your-Garnet-Pathname and where ;;; your CLX comes from into Your-CLX-pathname. All the :external pathnames ;;; will depend on these two pathnames. ;;; ;;; On CMU's Andrew system, do ;;; (setf Your-CLX-Pathname "/usr/local/lib/cl/lib/code/") ;;; before loading garnet-loader.lisp. (defvar Your-CLX-Pathname (if (eq garnet-version :external) "**FILL THIS IN**" ;; SET THIS "/usr/misc/.allegro/lib/code/")) (defvar Your-Garnet-Pathname (if (eq garnet-version :external) "**FILL THIS IN**" ;; SET THIS "/afs/cs.cmu.edu/project/garnet/garnet/")) ;; This FLET is required for KCL because it does not properly concatenate ;; directory pathnames ;; (flet (#+KCL (merge-pathnames (subdir dir) (pathname (concatenate 'string (namestring dir) (namestring subdir))) )) (defun Get-Garnet-Binary-Pathname (version) (let ((directory-name (case version (:external "bin/") (:sparc-allegro "sparc-allegro-bin/") (:sparc-allegro4.1 "sparc-allegro4.1-bin/") (:sparc-cmucl "sparc-cmucl-bin/") (:sparc-lucid "sparc-lucid-bin/") (:pmax-allegro "pmax-allegro-bin/") (:pmax-allegro4.1 "pmax-allegro4.1-bin/") (:hp-lucid "hp-lucid-bin/") (:clisp "clisp-bin") (:alpha-lw "alpha-lw-bin/") (t (error "~S is an invalid garnet-version" version))))) (merge-pathnames directory-name Your-Garnet-Pathname))) (defvar Garnet-Src-Pathname (merge-pathnames "src/" Your-Garnet-Pathname)) (defvar Garnet-Binary-Pathname (Get-Garnet-Binary-Pathname garnet-version)) (defvar Garnet-Lib-Pathname (merge-pathnames "lib/" Your-Garnet-Pathname)) (defvar CLX-Pathname Your-CLX-Pathname) (defvar Garnet-Utils-Src (merge-pathnames "utils/" Garnet-Src-Pathname)) (defvar Garnet-Utils-Pathname (merge-pathnames "utils/" Garnet-Binary-Pathname)) (defvar Garnet-KR-Src (merge-pathnames "kr/" Garnet-Src-Pathname)) (defvar Garnet-KR-Pathname (merge-pathnames "kr/" Garnet-Binary-Pathname)) (defvar Garnet-Opal-Src (merge-pathnames "opal/" Garnet-Src-Pathname)) (defvar Garnet-Opal-Pathname (merge-pathnames "opal/" Garnet-Binary-Pathname)) (defvar Garnet-Inter-Src (merge-pathnames "inter/" Garnet-Src-Pathname)) (defvar Garnet-Inter-Pathname (merge-pathnames "inter/" Garnet-Binary-Pathname)) (defvar Garnet-Gesture-Src (merge-pathnames "gesture/" Garnet-Src-Pathname)) (defvar Garnet-Gesture-Pathname (merge-pathnames "gesture/" Garnet-Binary-Pathname)) (defvar Garnet-Aggregadgets-Src (merge-pathnames "aggregadgets/" Garnet-Src-Pathname)) (defvar Garnet-Aggregadgets-Pathname (merge-pathnames "aggregadgets/" Garnet-Binary-Pathname)) (defvar Garnet-PS-Src (merge-pathnames "ps/" Garnet-Src-Pathname)) (defvar Garnet-PS-Pathname (merge-pathnames "ps/" Garnet-Binary-Pathname)) (defvar Garnet-Gadgets-Src (merge-pathnames "gadgets/" Garnet-Src-Pathname)) (defvar Garnet-Gadgets-Pathname (merge-pathnames "gadgets/" Garnet-Binary-Pathname)) (defvar Garnet-Debug-Src (merge-pathnames "debug/" Garnet-Src-Pathname)) (defvar Garnet-Debug-Pathname (merge-pathnames "debug/" Garnet-Binary-Pathname)) (defvar Garnet-Demos-Src (merge-pathnames "demos/" Garnet-Src-Pathname)) (defvar Garnet-Demos-Pathname (merge-pathnames "demos/" Garnet-Binary-Pathname)) (defvar Garnet-Gilt-Src (merge-pathnames "gilt/" Garnet-Src-Pathname)) (defvar Garnet-Gilt-Pathname (merge-pathnames "gilt/" Garnet-Binary-Pathname)) (defvar Garnet-C32-Src (merge-pathnames "c32/" Garnet-Src-Pathname)) (defvar Garnet-C32-Pathname (merge-pathnames "c32/" Garnet-Binary-Pathname)) (defvar Garnet-Lapidary-Src (merge-pathnames "lapidary/" Garnet-Src-Pathname)) (defvar Garnet-Lapidary-Pathname (merge-pathnames "lapidary/" Garnet-Binary-Pathname)) (defvar Garnet-Contrib-Src (merge-pathnames "contrib/" Garnet-Src-Pathname)) (defvar Garnet-Contrib-Pathname (merge-pathnames "contrib/" Garnet-Binary-Pathname)) (defvar Garnet-Bitmap-Pathname (merge-pathnames "bitmaps/" Garnet-Lib-Pathname)) (defvar Garnet-Pixmap-Pathname (merge-pathnames "pixmaps/" Garnet-Lib-Pathname)) (defvar Garnet-Gilt-Bitmap-Pathname (merge-pathnames "gilt/" Garnet-Lib-Pathname)) (defvar Garnet-C32-Bitmap-Pathname (merge-pathnames "c32/" Garnet-Lib-Pathname)) (defvar Garnet-DataFile-Pathname (merge-pathnames "data/" Garnet-Lib-Pathname)) (defvar Garnet-Gesture-Data-Pathname (merge-pathnames "gesture/" Garnet-Lib-Pathname)) ) ; Close CLISP's flet ;;;---------------------------------------------------------- ;;; When compiling, the binaries will be in the same directories as the ;;; source files, so make all the path names be the same ;;; ;;; After compilation is finished, the user should move all the binaries ;;; into their own directories, as specified by the pathnames above. (defvar *Garnet-Going-To-Compile*) (when (and (boundp '*Garnet-Going-To-Compile*) *Garnet-Going-To-Compile*) (setf Garnet-Utils-Pathname Garnet-Utils-Src) (setf Garnet-KR-Pathname Garnet-KR-Src) (setf Garnet-Opal-Pathname Garnet-Opal-Src) (setf Garnet-Inter-Pathname Garnet-Inter-Src) (setf Garnet-Gesture-Pathname Garnet-Gesture-Src) (setf Garnet-PS-Pathname Garnet-PS-Src) (setf Garnet-Aggregadgets-Pathname Garnet-Aggregadgets-Src) (setf Garnet-Gadgets-Pathname Garnet-Gadgets-Src) (setf Garnet-Debug-Pathname Garnet-Debug-Src) (setf Garnet-Demos-Pathname Garnet-Demos-Src) (setf Garnet-Gilt-Pathname Garnet-Gilt-Src) (setf Garnet-C32-Pathname Garnet-C32-Src) (setf Garnet-Lapidary-Pathname Garnet-Lapidary-Src) (setf Garnet-Contrib-Pathname Garnet-Contrib-Src) ) ;;;---------------------------------------------------------- ;;; If at cmu, then set up the search lists #+cmu (progn (setf (ext:search-list "utils:") (list (namestring Garnet-Utils-PathName))) (setf (ext:search-list "utils-src:") (list (namestring Garnet-Utils-Src))) (setf (ext:search-list "kr:") (list (namestring Garnet-KR-PathName))) (setf (ext:search-list "kr-src:") (list (namestring Garnet-KR-Src))) (setf (ext:search-list "opal:") (list (namestring Garnet-Opal-PathName))) (setf (ext:search-list "opal-src:") (list (namestring Garnet-Opal-Src))) (setf (ext:search-list "inter:") (list (namestring Garnet-Inter-PathName))) (setf (ext:search-list "inter-src:") (list (namestring Garnet-Inter-Src))) (setf (ext:search-list "gesture:") (list (namestring Garnet-Gesture-PathName))) (setf (ext:search-list "gesture-src:") (list (namestring Garnet-Gesture-Src))) (setf (ext:search-list "gesture-data:") (list (namestring Garnet-Gesture-Data-PathName))) (setf (ext:search-list "ps:") (list (namestring Garnet-PS-PathName))) (setf (ext:search-list "ps-src:") (list (namestring Garnet-PS-Src))) (setf (ext:search-list "aggregadgets:") (list (namestring Garnet-Aggregadgets-PathName))) (setf (ext:search-list "aggregadgets-src:") (list (namestring Garnet-Aggregadgets-Src))) (setf (ext:search-list "gadgets:") (list (namestring Garnet-Gadgets-PathName))) (setf (ext:search-list "gadgets-src:") (list (namestring Garnet-Gadgets-Src))) (setf (ext:search-list "debug:") (list (namestring Garnet-Debug-PathName))) (setf (ext:search-list "debug-src:") (list (namestring Garnet-Debug-Src))) (setf (ext:search-list "demos:") (list (namestring Garnet-Demos-PathName))) (setf (ext:search-list "demos-src:") (list (namestring Garnet-Demos-Src))) (setf (ext:search-list "gilt:") (list (namestring Garnet-Gilt-PathName))) (setf (ext:search-list "gilt-src:") (list (namestring Garnet-Gilt-Src))) (setf (ext:search-list "c32:") (list (namestring Garnet-C32-PathName))) (setf (ext:search-list "c32-src:") (list (namestring Garnet-C32-Src))) (setf (ext:search-list "lapidary:") (list (namestring Garnet-Lapidary-PathName))) (setf (ext:search-list "lapidary-src:") (list (namestring Garnet-Lapidary-Src))) (setf (ext:search-list "contrib:") (list (namestring Garnet-Contrib-PathName))) (setf (ext:search-list "contrib-src:") (list (namestring Garnet-Contrib-Src))) ) (defparameter Garnet-Utils-Loader (merge-pathnames "utils-loader" #+cmu "utils:" #+(not cmu) Garnet-Utils-PathName)) (defparameter Garnet-KR-Loader (merge-pathnames "kr-loader" #+cmu "kr:" #+(not cmu) Garnet-KR-PathName)) (defparameter Garnet-Opal-Loader (merge-pathnames "opal-loader" #+cmu "opal:" #+(not cmu) Garnet-Opal-PathName)) (defparameter Garnet-Inter-Loader (merge-pathnames "inter-loader" #+cmu "inter:" #+(not cmu) Garnet-Inter-PathName)) (defparameter Garnet-Multifont-Loader (merge-pathnames "multifont-loader" #+cmu "opal:" #+(not cmu) Garnet-Opal-PathName)) (defparameter Garnet-Gesture-Loader (merge-pathnames "gesture-loader" #+cmu "gesture:" #+(not cmu) Garnet-Gesture-PathName)) (defparameter Garnet-PS-Loader (merge-pathnames "ps-loader" #+cmu "ps:" #+(not cmu) Garnet-PS-PathName)) (defparameter Garnet-Aggregadgets-Loader (merge-pathnames "aggregadgets-loader" #+cmu "aggregadgets:" #+(not cmu) Garnet-Aggregadgets-PathName)) (defparameter Garnet-Aggregraphs-Loader (merge-pathnames "aggregraphs-loader" #+cmu "aggregadgets:" #+(not cmu) Garnet-Aggregadgets-PathName)) (defparameter Garnet-Gadgets-Loader (merge-pathnames "gadgets-loader" #+cmu "gadgets:" #+(not cmu) Garnet-Gadgets-PathName)) (defparameter Garnet-Debug-Loader (merge-pathnames "debug-loader" #+cmu "debug:" #+(not cmu) Garnet-Debug-PathName)) (defparameter Garnet-Demos-Loader (merge-pathnames "demos-loader" #+cmu "demos:" #+(not cmu) Garnet-Demos-PathName)) (defparameter Garnet-Gilt-Loader (merge-pathnames "gilt-loader" #+cmu "gilt:" #+(not cmu) Garnet-Gilt-PathName)) (defparameter Garnet-C32-Loader (merge-pathnames "c32-loader" #+cmu "c32:" #+(not cmu) Garnet-C32-PathName)) (defparameter Garnet-Lapidary-Loader (merge-pathnames "lapidary-loader" #+cmu "lapidary:" #+(not cmu) Garnet-Lapidary-PathName)) ;-------------------------------------------------------------------- (defparameter Garnet-Load-Alist `(("gg" . Garnet-Gadgets-PathName) ("gadgets" . Garnet-Gadgets-PathName) ("utils" . Garnet-Utils-PathName) ("kr" . Garnet-KR-PathName) ("opal" . Garnet-Opal-Pathname) ("inter" . Garnet-Inter-PathName) ("gesture" . Garnet-Gesture-PathName) ("gestures" . Garnet-Gesture-PathName) ("ps" . Garnet-PS-PathName) ("aggregadgets" . Garnet-Aggregadgets-PathName) ("debug" . Garnet-Debug-PathName) ("demos" . Garnet-Demos-PathName) ("demo" . Garnet-Demos-PathName) ("gilt" . Garnet-Gilt-PathName) ("c32" . Garnet-C32-PathName) ("lapidary" . Garnet-Lapidary-PathName) ("contrib" . Garnet-Contrib-PathName) ("utils-src" . Garnet-Utils-Src) ("kr-src" . Garnet-KR-Src) ("opal-src" . Garnet-Opal-Src) ("inter-src" . Garnet-Inter-Src) ("gesture-src" . Garnet-Gesture-Src) ("gestures-src" . Garnet-Gesture-Src) ("ps-src" . Garnet-PS-Src) ("aggregadgets-src" . Garnet-Aggregadgets-Src) ("gadgets-src" . Garnet-Gadgets-Src) ("gg-src" . Garnet-Gadgets-Src) ("debug-src" . Garnet-Debug-Src) ("demos-src" . Garnet-Demos-Src) ("demo-src" . Garnet-Demos-Src) ("gilt-src" . Garnet-Gilt-Src) ("c32-src" . Garnet-C32-Src) ("lapidary-src" . Garnet-Lapidary-Src) ("contrib-src" . Garnet-Contrib-Src) ("clx" . CLX-PathName) )) (defun Add-Garnet-Load-Prefix (prefix pathname) (push (cons prefix pathname) Garnet-Load-Alist)) (defun user::Garnet-Load (filename) (let ((pos (position #\: filename))) (if pos (let* ((head (subseq filename 0 pos)) (tail (subseq filename (1+ pos))) (prefix (or (eval (cdr (assoc head Garnet-Load-Alist :test #'string=))) (error "Bad prefix ~S~%" head))) (finalname (merge-pathnames tail prefix))) (format T "Loading ~s~%" finalname) (load finalname)) ;; else no colon, load regular (progn (format T "NO COLON, Loading ~s~%" filename) (load filename))))) ;;; ;;; This function will compile your garnet files while keeping the ;;; sources and binaries separated. If you want to just compile one ;;; file from Garnet, like the gadget file gauge.lisp, then you could ;;; use this function to compile the source file and automatically ;;; save the binary file in the bin directory. ;;; ;;; Example: ;;; (garnet-compile "gadgets:gauge") ;;; Takes the source file from Garnet-Gadgets-Src, compiles it, and ;;; saves the binary file in Garnet-Gadgets-Pathname (the binary ;;; gadgets directory). ;;; (defvar *compiler-extension* #+allegro ".fasl" #+(and lucid sparc) ".sbin" #+(and lucid pa) ".hbin" #+(and cmu sparc) ".sparcf" #+(and cmu (not sparc)) ".fasl" #+lispworks ".afasl") (defun user::Garnet-Compile (filename) (let ((pos (position #\: filename))) (if pos (let* ((head (subseq filename 0 pos)) (tail (subseq filename (1+ pos))) (head-src (concatenate 'string head "-src")) (src-prefix (or (eval (cdr (assoc head-src Garnet-Load-Alist :test #'string=))) (eval (cdr (assoc head Garnet-Load-Alist :test #'string=))) (error "Prefix ~S not found in Garnet-Load-Alist" head))) (bin-prefix (or (eval (cdr (assoc head Garnet-Load-Alist :test #'string=))) (error "Prefix ~S not found in Garnet-Load-Alist" head))) (src-finalname (merge-pathnames (concatenate 'string tail ".lisp") src-prefix)) (bin-finalname (merge-pathnames (concatenate 'string tail *compiler-extension*) bin-prefix))) (format T "Compiling ~s~%" src-finalname) (format T "for output to ~s~%" bin-finalname) (compile-file src-finalname :output-file bin-finalname)) ;; else no colon, abort (error "NO COLON, aborting compile")))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; The real load ;;; (format t "...Loading Garnet ...~%") (setf *load-verbose* t) (cond (load-clx-p (defparameter CLX-Loader #+lucid (merge-pathnames "defsystem" CLX-Pathname) #+lispworks (merge-pathnames "defsys" CLX-Pathname) #-(or lucid lispworks) (merge-pathnames "clx" CLX-Pathname)) (format T "~% %%%%%%% Loading CLX %%%%%%%%~%") (load CLX-Loader) #+lucid (load-clx CLX-Pathname)) (t (format T "~%****** NOT Loading CLX *******~%"))) ;;; ;;; Functions that will determine whether the display can be opened ;;; (defun get-full-display-name () #+cmu (cdr (assoc :DISPLAY lisp::*environment-list*)) #+(or allegro lispworks kcl clisp) (sys::getenv "DISPLAY") #+(and lucid lcl3.0) (lucid-common-lisp:environment-variable "DISPLAY") #+(and lucid (not lcl3.0)) (system:environment-variable "DISPLAY") ) (defun get-display-name (display) (do* ((dlist (coerce display 'list) (cdr dlist)) (c (car dlist) (car dlist)) (namelist nil)) ((or (eq c nil) (eq c '#\:)) (coerce (reverse namelist) 'string)) (push c namelist))) (defun get-display-number (display) (let* ((dlist (coerce display 'list)) (numstr (progn (do ((c (pop dlist) (pop dlist))) ((or (eq c nil) (eq c '#\:)))) (do ((c (pop dlist) (pop dlist)) (numlist nil) ) ((or (eq c nil) (eq c '#\.)) (coerce (reverse numlist) 'string)) (push c numlist) ) )) (num (if (equal numstr "") 0 (read-from-string numstr))) ) num)) (defun verify-display-can-be-opened () (let* ((full-display-name (get-full-display-name)) (d-name (if full-display-name (get-display-name full-display-name) #-(or allegro clisp) (machine-instance) #+clisp "" #+allegro (short-site-name))) (d-number (get-display-number full-display-name))) (multiple-value-bind (val errorp) #+cmu (ignore-errors (xlib:open-display d-name :display d-number)) #+lucid (system::ignore-errors (xlib:open-display d-name :display d-number)) #+allegro (excl::ignore-errors (xlib:open-display d-name :display d-number)) #+lispworks (common-lisp:ignore-errors (xlib:open-display d-name :display d-number)) #-(or cmu lucid allegro lispworks) (xlib:open-display d-name :display d-number) ; just try it (if errorp (error "Could not open a display for ~S. You must already be running X to load or compile Garnet. Your DISPLAY environment variable must be set with the name of the machine on which the Garnet windows will be displayed. Please exit lisp and execute a command like the following to the unix shell before loading or compiling Garnet: \"setenv DISPLAY windowmachine.cs.cmu.edu:0.0\" \"setenv DISPLAY unix:0.0\" \"setenv DISPLAY 0.0\" The last two values may be more efficient when you want the Garnet windows to appear on the same machine that Garnet is running on. Additionally, you must execute the command \"xhost +\" on the machine that the windows will be displayed on, if it is different from the machine running Garnet." full-display-name)) (xlib:close-display val) T))) (verify-display-can-be-opened) ;;; ;;; Now back to loading Garnet ;;; (if load-utils-p (if (and *dont-load-modules-twice* (get :garnet-modules :utils)) (format T "~%****** Utils already loaded *******~%") (progn (format T "~% %%%%%%%% Loading Utils %%%%%%%%~%") (load Garnet-Utils-Loader))) (format T "~%****** NOT Loading Utils *******~%")) (if load-kr-p (if (and *dont-load-modules-twice* (get :garnet-modules :kr)) (format T "~%****** KR already loaded *******~%") (progn (format T "~% %%%%%%%% Loading KR %%%%%%%%~%") (load Garnet-KR-Loader))) (format T "~%****** NOT Loading KR *******~%")) (if load-opal-p (if (and *dont-load-modules-twice* (get :garnet-modules :opal)) (format T "~%****** Opal already loaded *******~%") (progn (format T "~% %%%%%%%% Loading Opal %%%%%%%%~%") (load Garnet-Opal-Loader))) (format T "~%****** NOT Loading Opal *******~%")) (if load-inter-p (if (and *dont-load-modules-twice* (get :garnet-modules :inter)) (format T "~%****** Interactors already loaded *******~%") (progn (format T "~% %%%%%%%% Loading Interactors %%%%%%%%~%") (load Garnet-Inter-Loader))) (format T "~%****** NOT Loading Interactors *******~%")) (if load-multifont-p (if (and *dont-load-modules-twice* (get :garnet-modules :multifont)) (format T "~%****** Multifont already loaded *******~%") (progn (format T "~% %%%%%%%% Loading Multifont %%%%%%%%~%") (load Garnet-Multifont-Loader))) (format T "~%****** NOT Loading Multifont *******~%")) (if load-gesture-p (if (and *dont-load-modules-twice* (get :garnet-modules :gesture)) (format T "~%****** Gestures already loaded *******~%") (progn (format T "~% %%%%%%%% Loading Gestures %%%%%%%%~%") (load Garnet-Gesture-Loader))) (format T "~%****** NOT Loading Gestures *******~%")) (if load-ps-p (if (and *dont-load-modules-twice* (get :garnet-modules :ps)) (format T "~%****** PS already loaded *******~%") (progn (format T "~% %%%%%%%% Loading PS %%%%%%%%~%") (load Garnet-PS-Loader))) (format T "~%****** NOT Loading PS *******~%")) (if load-aggregadgets-p (if (and *dont-load-modules-twice* (get :garnet-modules :aggregadgets)) (format T "~%****** Aggregadgets already loaded *******~%") (progn (format T "~% %%%%%%%% Loading Aggregadgets %%%%%%%%~%") (load Garnet-Aggregadgets-Loader))) (format T "~%****** NOT Loading Aggregadgets *******~%")) (if load-aggregraphs-p (if (and *dont-load-modules-twice* (get :garnet-modules :aggregraphs)) (format T "~%****** Aggregraphs already loaded *******~%") (progn (format T "~% %%%%%%%% Loading Aggregraphs %%%%%%%%~%") (load Garnet-Aggregraphs-Loader))) (format T "~%****** NOT Loading Aggregraphs ******* ** To load aggregraph programs, execute (load Garnet-Aggregraphs-Loader)~%")) (if load-gadgets-p (if (and *dont-load-modules-twice* (get :garnet-modules :gadgets)) (format T "~%****** Gadgets already loaded *******~%") (progn (format T "~% %%%%%%%% Loading Gadgets %%%%%%%%~%") (load Garnet-Gadgets-Loader))) (format T "~%****** NOT Loading Gadgets *******~%")) (if load-debug-p (if (and *dont-load-modules-twice* (get :garnet-modules :debug)) (format T "~%****** Debugging programs already loaded *******~%") (progn (format T "~% %%%%%%%% Loading Debugging programs %%%%%%%%~%") (load Garnet-Debug-Loader))) (format T "~%****** NOT Loading Debug Files ******* ** To load debug programs, execute (load Garnet-Debug-Loader)~%")) (if load-demos-p (if (and *dont-load-modules-twice* (get :garnet-modules :demos)) (format T "~%****** Demos already loaded *******~%") (progn (format T "~% %%%%%%%% Loading Demos %%%%%%%%~%") (load Garnet-Demos-Loader))) (format T "~%****** NOT Loading Demos ******* ** To load Demos, execute (load Garnet-Demos-Loader)~%")) (if load-gilt-p (if (and *dont-load-modules-twice* (get :garnet-modules :gilt)) (format T "~%****** Gilt already loaded *******~%") (progn (format T "~% %%%%%%%% Loading Gilt %%%%%%%%~%") (load Garnet-Gilt-Loader))) (format T "~%****** NOT Loading Gilt ******* ** To load Gilt, execute (load Garnet-Gilt-Loader)~%")) (if load-c32-p (if (and *dont-load-modules-twice* (get :garnet-modules :c32)) (format T "~%****** C32 already loaded *******~%") (progn (format T "~% %%%%%%%% Loading C32 %%%%%%%%~%") (load Garnet-C32-Loader))) (format T "~%****** NOT Loading C32 ******* ** To load C32, execute (load Garnet-C32-Loader)~%")) (if load-lapidary-p (if (and *dont-load-modules-twice* (get :garnet-modules :lapidary)) (format T "~%****** Lapidary already loaded *******~%") (progn (format T "~% %%%%%%%% Loading Lapidary %%%%%%%%~%") (load Garnet-Lapidary-Loader))) (format T "~%****** NOT Loading Lapidary ******* ** To load Lapidary, execute (load Garnet-Lapidary-Loader)~%")) #| ;; Only set the k-reader if we are loading, not compiling (if (get :garnet-modules :kr) (set-dispatch-macro-character #\# #\k (function kr::k-reader))) |# (format t "~%... Garnet Load Complete ...~%")