Ticket #1028: tools.diff

File tools.diff, 113.2 KB (added by fare, 22 months ago)

tools update

  • asdf.lisp

     
    11;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*- 
    2 ;;; This is ASDF 2.23: Another System Definition Facility. 
     2;;; This is ASDF 2.26: Another System Definition Facility. 
    33;;; 
    44;;; Feedback, bug reports, and patches are all welcome: 
    55;;; please mail to <asdf-devel@common-lisp.net>. 
     
    5050(cl:in-package :common-lisp-user) 
    5151#+genera (in-package :future-common-lisp-user) 
    5252 
    53 #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) 
     53#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) 
    5454(error "ASDF is not supported on your implementation. Please help us port it.") 
    5555 
    5656;;;; Create and setup packages in a way that is compatible with hot-upgrade. 
     
    7171            (and (= system::*gcl-major-version* 2) 
    7272                 (< system::*gcl-minor-version* 7))) 
    7373    (pushnew :gcl-pre2.7 *features*)) 
    74   #+(or abcl (and allegro ics) (and clisp unicode) clozure (and cmu unicode) 
    75         (and ecl unicode) lispworks (and sbcl sb-unicode) scl) 
     74  #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode) 
     75        clozure lispworks (and sbcl sb-unicode) scl) 
    7676  (pushnew :asdf-unicode *features*) 
    7777  ;;; make package if it doesn't exist yet. 
    7878  ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it. 
     
    8686  ;;; except that the defun has to be in package asdf. 
    8787  #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) 
    8888  #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp)) 
     89  #+mkcl (require :cmp) 
     90  #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have strict ANSI class redefinition semantics 
    8991 
    9092  ;;; Package setup, step 2. 
    9193  (defvar *asdf-version* nil) 
     
    116118         ;; "2.345.6" would be a development version in the official upstream 
    117119         ;; "2.345.0.7" would be your seventh local modification of official release 2.345 
    118120         ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6 
    119          (asdf-version "2.23") 
     121         (asdf-version "2.26") 
    120122         (existing-asdf (find-class 'component nil)) 
    121123         (existing-version *asdf-version*) 
    122124         (already-there (equal asdf-version existing-version))) 
     
    228230                   :redefined-functions ',redefined-functions))) 
    229231          (pkgdcl 
    230232           :asdf 
    231            :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only. 
    232233           :use (:common-lisp) 
    233234           :redefined-functions 
    234235           (#:perform #:explain #:output-files #:operation-done-p 
     
    303304            #:*compile-file-warnings-behaviour* 
    304305            #:*compile-file-failure-behaviour* 
    305306            #:*resolve-symlinks* 
    306             #:*require-asdf-operator* 
     307            #:*load-system-operation* 
    307308            #:*asdf-verbose* 
    308309            #:*verbose-out* 
    309310 
     
    362363            #:user-source-registry-directory 
    363364            #:system-source-registry-directory 
    364365 
    365             ;; Utilities 
     366            ;; Utilities: please use asdf-utils instead 
     367            #| 
    366368            ;; #:aif #:it 
    367             #:appendf #:orf 
     369            ;; #:appendf #:orf 
    368370            #:length=n-p 
    369371            #:remove-keys #:remove-keyword 
    370             #:first-char #:last-char #:ends-with 
     372            #:first-char #:last-char #:string-suffix-p 
    371373            #:coerce-name 
    372374            #:directory-pathname-p #:ensure-directory-pathname 
    373375            #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root 
    374             #:getenv #:getenv-pathname #:getenv-pathname 
     376            #:getenv #:getenv-pathname #:getenv-pathnames 
    375377            #:getenv-absolute-directory #:getenv-absolute-directories 
    376378            #:probe-file* 
    377379            #:find-symbol* #:strcat 
     
    387389            #:while-collecting 
    388390            #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors* 
    389391            #:*wild-path* #:wilden 
    390             #:directorize-pathname-host-device 
     392            #:directorize-pathname-host-device|# 
    391393            ))) 
    392394        #+genera (import 'scl:boolean :asdf) 
    393395        (setf *asdf-version* asdf-version 
     
    419421(defparameter +asdf-methods+ 
    420422  '(perform-with-restarts perform explain output-files operation-done-p)) 
    421423 
     424(defvar *load-system-operation* 'load-op 
     425  "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP. 
     426You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle, 
     427or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.") 
     428 
     429(defvar *compile-op-compile-file-function* 'compile-file* 
     430  "Function used to compile lisp files.") 
     431 
     432 
     433 
    422434#+allegro 
    423435(eval-when (:compile-toplevel :execute) 
    424436  (defparameter *acl-warn-save* 
     
    450462(progn 
    451463  (deftype logical-pathname () nil) 
    452464  (defun make-broadcast-stream () *error-output*) 
     465  (defun translate-logical-pathname (x) x) 
    453466  (defun file-namestring (p) 
    454467    (setf p (pathname p)) 
    455468    (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) 
     
    659672         ;; Giving :unspecific as argument to make-pathname is not portable. 
    660673         ;; See CLHS make-pathname and 19.2.2.2.3. 
    661674         ;; We only use it on implementations that support it, 
    662          #+(or abcl allegro clozure cmu gcl genera lispworks sbcl scl xcl) :unspecific 
     675         #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific 
    663676         #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil)) 
    664677    (destructuring-bind (name &optional (type unspecific)) 
    665678        (split-string filename :max 2 :separator ".") 
     
    741754          (let ((value (_getenv name))) 
    742755            (unless (ccl:%null-ptr-p value) 
    743756              (ccl:%get-cstring value)))) 
     757  #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext)) x) 
    744758  #+sbcl (sb-ext:posix-getenv x) 
    745   #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl) 
     759  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) 
    746760  (error "~S is not supported on your implementation" 'getenv)) 
    747761 
    748762(defun* directory-pathname-p (pathname) 
     
    849863      ((zerop i) (return (null l))) 
    850864      ((not (consp l)) (return nil))))) 
    851865 
    852 (defun* ends-with (s suffix) 
     866(defun* string-suffix-p (s suffix) 
    853867  (check-type s string) 
    854868  (check-type suffix string) 
    855869  (let ((start (- (length s) (length suffix)))) 
     
    877891    (null nil) 
    878892    (string (probe-file* (parse-namestring p))) 
    879893    (pathname (unless (wild-pathname-p p) 
    880                 #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl) 
     894                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl) 
    881895                      '(probe-file p) 
    882896                      #+clisp (aif (find-symbol* '#:probe-pathname :ext) 
    883897                                   `(ignore-errors (,it p))) 
     
    24502464        (funcall (ensure-function hook) thunk) 
    24512465        (funcall thunk)))) 
    24522466 
    2453 (defvar *compile-op-compile-file-function* 'compile-file* 
    2454   "Function used to compile lisp files.") 
    2455  
    24562467;;; perform is required to check output-files to find out where to put 
    24572468;;; its answers, in case it has been overridden for site policy 
    24582469(defmethod perform ((operation compile-op) (c cl-source-file)) 
    2459   #-:broken-fasl-loader 
    24602470  (let ((source-file (component-pathname c)) 
    24612471        ;; on some implementations, there are more than one output-file, 
    24622472        ;; but the first one should always be the primary fasl that gets loaded. 
     
    24892499 
    24902500(defmethod output-files ((operation compile-op) (c cl-source-file)) 
    24912501  (declare (ignorable operation)) 
    2492   (let ((p (lispize-pathname (component-pathname c)))) 
    2493     #-broken-fasl-loader (list (compile-file-pathname p)) 
    2494     #+broken-fasl-loader (list p))) 
     2502  (let* ((p (lispize-pathname (component-pathname c))) 
     2503         (f (compile-file-pathname ;; fasl 
     2504             p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl)) 
     2505         #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file 
     2506    #+ecl (if (use-ecl-byte-compiler-p) 
     2507              (list f) 
     2508              (list (compile-file-pathname p :type :object) f)) 
     2509    #+mkcl (list o f) 
     2510    #-(or ecl mkcl) (list f))) 
    24952511 
    24962512(defmethod perform ((operation compile-op) (c static-file)) 
    24972513  (declare (ignorable operation c)) 
     
    25322548        (perform (make-sub-operation c o c 'compile-op) c))))) 
    25332549 
    25342550(defmethod perform ((o load-op) (c cl-source-file)) 
    2535   (map () #'load (input-files o c))) 
     2551  (map () #'load 
     2552       #-(or ecl mkcl) 
     2553       (input-files o c) 
     2554       #+(or ecl mkcl) 
     2555       (loop :for i :in (input-files o c) 
     2556             :unless (string= (pathname-type i) "fas") 
     2557             :collect (compile-file-pathname (lispize-pathname i))))) 
    25362558 
    25372559(defmethod perform ((operation load-op) (c static-file)) 
    25382560  (declare (ignorable operation c)) 
     
    27362758  (setf (documentation 'operate 'function) 
    27372759        operate-docstring)) 
    27382760 
    2739 (defun* load-system (system &rest args &key force verbose version &allow-other-keys) 
     2761(defun* load-system (system &rest keys &key force verbose version &allow-other-keys) 
    27402762  "Shorthand for `(operate 'asdf:load-op system)`. 
    27412763See OPERATE for details." 
    27422764  (declare (ignore force verbose version)) 
    2743   (apply 'operate 'load-op system args) 
     2765  (apply 'operate *load-system-operation* system keys) 
    27442766  t) 
    27452767 
    27462768(defun* load-systems (&rest systems) 
     
    27522774(defun loaded-systems () 
    27532775  (remove-if-not 'component-loaded-p (registered-systems))) 
    27542776 
    2755 (defun require-system (s) 
    2756   (load-system s :force-not (loaded-systems))) 
     2777(defun require-system (s &rest keys &key &allow-other-keys) 
     2778  (apply 'load-system s :force-not (loaded-systems) keys)) 
    27572779 
    27582780(defun* compile-system (system &rest args &key force verbose version 
    27592781                       &allow-other-keys) 
     
    30963118    #+mcl 
    30973119    (ccl::with-cstrs ((%command command)) (_system %command)) 
    30983120 
     3121    #+mkcl 
     3122    ;; This has next to no chance of working on basic Windows! 
     3123    ;; Your best hope is that Cygwin or MSYS is somewhere in the PATH. 
     3124    (multiple-value-bind (io process exit-code) 
     3125        (apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh" 
     3126                                  (list "-c" command) 
     3127                                  :input nil :output t #|*verbose-out*|# ;; will be *verbose-out* when we support it 
     3128                                  #-windows '(:search nil)) 
     3129      (declare (ignore io process)) 
     3130      exit-code) 
     3131 
    30993132    #+sbcl 
    31003133    (sb-ext:process-exit-code 
    31013134     (apply 'sb-ext:run-program 
     
    31073140    #+xcl 
    31083141    (ext:run-shell-command command) 
    31093142 
    3110     #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl) 
     3143    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl) 
    31113144    (error "RUN-SHELL-COMMAND not implemented for this Lisp"))) 
    31123145 
    31133146#+clisp 
     
    31973230(defun implementation-type () 
    31983231  (first-feature 
    31993232   '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu 
    3200      :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl))) 
     3233     :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl))) 
    32013234 
    32023235(defun operating-system () 
    32033236  (first-feature 
     
    32323265    (car ; as opposed to OR, this idiom prevents some unreachable code warning 
    32333266     (list 
    32343267      #+allegro 
    3235       (format nil "~A~A~@[~A~]" 
     3268      (format nil "~A~@[~A~]~@[~A~]~@[~A~]" 
    32363269              excl::*common-lisp-version-number* 
    3237               ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox 
    3238               (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A") 
     3270              ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default) 
     3271              (and (eq excl:*current-case-mode* :case-sensitive-lower) "M") 
    32393272              ;; Note if not using International ACL 
    32403273              ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm 
    3241               (excl:ics-target-case (:-ics "8"))) 
     3274              (excl:ics-target-case (:-ics "8")) 
     3275              (and (member :smp *features*) "S")) 
    32423276      #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*) 
    32433277      #+clisp 
    32443278      (subseq s 0 (position #\space s)) ; strip build information (date, etc.) 
     
    32723306 
    32733307(defun* hostname () 
    32743308  ;; Note: untested on RMCL 
    3275   #+(or abcl clozure cmucl ecl genera lispworks mcl sbcl scl xcl) (machine-instance) 
     3309  #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) 
    32763310  #+cormanlisp "localhost" ;; is there a better way? Does it matter? 
    32773311  #+allegro (excl.osi:gethostname) 
    32783312  #+clisp (first (split-string (machine-instance) :separator " ")) 
     
    32883322(defun* user-homedir () 
    32893323  (truenamize 
    32903324   (pathname-directory-pathname 
     3325    #+cormanlisp (ensure-directory-pathname (user-homedir-pathname)) 
    32913326    #+mcl (current-user-homedir-pathname) 
    3292     #-mcl (user-homedir-pathname)))) 
     3327    #-(or cormanlisp mcl) (user-homedir-pathname)))) 
    32933328 
    32943329(defun* ensure-pathname* (x want-absolute want-directory fmt &rest args) 
    32953330  (when (plusp (length x)) 
     
    33043339  (loop :for dir :in (split-string 
    33053340                      x :separator (string (inter-directory-separator))) 
    33063341        :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args))) 
    3307 (defun getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x))) 
     3342(defun* getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x))) 
    33083343  (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x)) 
    3309 (defun getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x))) 
     3344(defun* getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x))) 
    33103345  (and (plusp (length s)) 
    33113346       (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s))) 
    3312 (defun getenv-absolute-directory (x) 
     3347(defun* getenv-absolute-directory (x) 
    33133348  (getenv-pathname x :want-absolute t :want-directory t)) 
    3314 (defun getenv-absolute-directories (x) 
     3349(defun* getenv-absolute-directories (x) 
    33153350  (getenv-pathnames x :want-absolute t :want-directory t)) 
    33163351 
     3352(defun* get-folder-path (folder) 
     3353  (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path 
     3354   #+(and lispworks mswindows) (sys:get-folder-path folder) 
     3355   ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData 
     3356   (ecase folder 
     3357    (:local-appdata (getenv-absolute-directory "LOCALAPPDATA")) 
     3358    (:appdata (getenv-absolute-directory "APPDATA")) 
     3359    (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA") 
     3360                         (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))) 
    33173361 
    33183362(defun* user-configuration-directories () 
    33193363  (let ((dirs 
     
    33233367                (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS") 
    33243368                  :collect (subpathname* dir "common-lisp/")))) 
    33253369           ,@(when (os-windows-p) 
    3326                `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata) 
    3327                                     (getenv-absolute-directory "LOCALAPPDATA")) 
    3328                                "common-lisp/config/") 
    3329                  ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData 
    3330                  ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata) 
    3331                                     (getenv-absolute-directory "APPDATA")) 
    3332                                 "common-lisp/config/"))) 
     3370               `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/") 
     3371                 ,(subpathname* (get-folder-path :appdata) "common-lisp/config/"))) 
    33333372           ,(subpathname (user-homedir) ".config/common-lisp/")))) 
    33343373    (remove-duplicates (remove-if-not #'absolute-pathname-p dirs) 
    33353374                       :from-end t :test 'equal))) 
     
    33403379    ((os-windows-p) 
    33413380     (aif 
    33423381      ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData 
    3343       (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata) 
    3344                         (getenv-absolute-directory "ALLUSERSAPPDATA") 
    3345                         (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")) 
    3346                     "common-lisp/config/") 
     3382      (subpathname* (get-folder-path :common-appdata) "common-lisp/config/") 
    33473383      (list it))))) 
    33483384 
    33493385(defun* in-first-directory (dirs x &key (direction :input)) 
     
    34683504    (or 
    34693505     (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation) 
    34703506     (when (os-windows-p) 
    3471        (try (or #+lispworks (sys:get-folder-path :local-appdata) 
    3472                 (getenv-absolute-directory "LOCALAPPDATA") 
    3473                 #+lispworks (sys:get-folder-path :appdata) 
    3474                 (getenv-absolute-directory "APPDATA")) 
     3507       (try (or (get-folder-path :local-appdata) 
     3508                (get-folder-path :appdata)) 
    34753509            "common-lisp" "cache" :implementation)) 
    34763510     '(:home ".cache" "common-lisp" :implementation)))) 
    34773511 
     
    36983732    #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t))) 
    36993733              (when h `((,(truenamize h) ,*wild-inferiors*) ()))) 
    37003734    ;; The below two are not needed: no precompiled ASDF system there 
    3701     #+ecl (,(translate-logical-pathname "SYS:**;*.*") ()) 
     3735    #+(or ecl mkcl) (,(translate-logical-pathname "SYS:**;*.*") ()) 
     3736    #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) 
    37023737    ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ())) 
    37033738    ;; All-import, here is where we want user stuff to be: 
    37043739    :inherit-configuration 
     
    38753910  (if (absolute-pathname-p output-file) 
    38763911      ;; what cfp should be doing, w/ mp* instead of mp 
    38773912      (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys))) 
    3878              (defaults (make-pathname 
    3879                         :type type :defaults (merge-pathnames* input-file)))) 
    3880         (merge-pathnames* output-file defaults)) 
     3913             (defaults (make-pathname 
     3914                        :type type :defaults (merge-pathnames* input-file)))) 
     3915        (merge-pathnames* output-file defaults)) 
    38813916      (apply-output-translations 
    3882        (apply 'compile-file-pathname input-file keys)))) 
     3917       (apply 'compile-file-pathname input-file 
     3918              (if output-file keys (remove-keyword :output-file keys)))))) 
    38833919 
    38843920(defun* tmpize-pathname (x) 
    38853921  (make-pathname 
     
    39543990     (default-toplevel-directory 
    39553991         (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? 
    39563992     (include-per-user-information nil) 
    3957      (map-all-source-files (or #+(or ecl clisp) t nil)) 
     3993     (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) 
    39583994     (source-to-target-mappings nil)) 
    3959   #+(or ecl clisp) 
     3995  #+(or clisp ecl mkcl) 
    39603996  (when (null map-all-source-files) 
    3961     (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP")) 
     3997    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL")) 
    39623998  (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp"))) 
    39633999         (mapped-files (if map-all-source-files *wild-file* 
    39644000                           (make-pathname :type fasl-type :defaults *wild-file*))) 
     
    41614197                      string)) 
    41624198             (setf inherit t) 
    41634199             (push ':inherit-configuration directives)) 
    4164             ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix? 
     4200            ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix? 
    41654201             (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives)) 
    41664202            (t 
    41674203             (push `(:directory ,(check s)) directives)))) 
     
    41924228 
    41934229(defun* wrapping-source-registry () 
    41944230  `(:source-registry 
     4231    #+ecl (:tree ,(translate-logical-pathname "SYS:")) 
     4232    #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) 
    41954233    #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t))) 
    41964234    :inherit-configuration 
    41974235    #+cmu (:tree #p"modules:") 
     
    42004238  `(:source-registry 
    42014239    #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/")) 
    42024240    (:directory ,(default-directory)) 
    4203       ,@(loop :for dir :in 
    4204           `(,@(when (os-unix-p) 
    4205                 `(,(or (getenv-absolute-directory "XDG_DATA_HOME") 
    4206                        (subpathname (user-homedir) ".local/share/")) 
    4207                   ,@(or (getenv-absolute-directories "XDG_DATA_DIRS") 
    4208                         '("/usr/local/share" "/usr/share")))) 
    4209             ,@(when (os-windows-p) 
    4210                 `(,(or #+lispworks (sys:get-folder-path :local-appdata) 
    4211                        (getenv-absolute-directory "LOCALAPPDATA")) 
    4212                   ,(or #+lispworks (sys:get-folder-path :appdata) 
    4213                        (getenv-absolute-directory "APPDATA")) 
    4214                   ,(or #+lispworks (sys:get-folder-path :common-appdata) 
    4215                        (getenv-absolute-directory "ALLUSERSAPPDATA") 
    4216                        (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))) 
    4217           :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) 
    4218           :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) 
    4219       :inherit-configuration)) 
     4241    ,@(loop :for dir :in 
     4242        `(,@(when (os-unix-p) 
     4243              `(,(or (getenv-absolute-directory "XDG_DATA_HOME") 
     4244                     (subpathname (user-homedir) ".local/share/")) 
     4245                ,@(or (getenv-absolute-directories "XDG_DATA_DIRS") 
     4246                      '("/usr/local/share" "/usr/share")))) 
     4247          ,@(when (os-windows-p) 
     4248              (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata)))) 
     4249        :collect `(:directory ,(subpathname* dir "common-lisp/systems/")) 
     4250        :collect `(:tree ,(subpathname* dir "common-lisp/source/"))) 
     4251    :inherit-configuration)) 
    42204252(defun* user-source-registry (&key (direction :input)) 
    42214253  (in-user-configuration-directory *source-registry-file* :direction direction)) 
    42224254(defun* system-source-registry (&key (direction :input)) 
     
    43624394  (clear-output-translations)) 
    43634395 
    43644396 
    4365 ;;; ECL support for COMPILE-OP / LOAD-OP 
     4397;;; ECL and MKCL support for COMPILE-OP / LOAD-OP 
    43664398;;; 
    4367 ;;; In ECL, these operations produce both FASL files and the 
    4368 ;;; object files that they are built from. Having both of them allows 
    4369 ;;; us to later on reuse the object files for bundles, libraries, 
    4370 ;;; standalone executables, etc. 
     4399;;; In ECL and MKCL, these operations produce both 
     4400;;; FASL files and the object files that they are built from. 
     4401;;; Having both of them allows us to later on reuse the object files 
     4402;;; for bundles, libraries, standalone executables, etc. 
    43714403;;; 
    43724404;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes 
    43734405;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp. 
    43744406;;; 
    4375 #+ecl 
     4407;;; Also, register-pre-built-system. 
     4408 
     4409#+(or ecl mkcl) 
    43764410(progn 
    4377   (setf *compile-op-compile-file-function* 'ecl-compile-file) 
     4411  (defun register-pre-built-system (name) 
     4412    (register-system (make-instance 'system :name (coerce-name name) :source-file nil))) 
    43784413 
    4379   (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys) 
    4380     (if (use-ecl-byte-compiler-p) 
    4381         (apply 'compile-file* input-file keys) 
    4382         (multiple-value-bind (object-file flags1 flags2) 
    4383             (apply 'compile-file* input-file :system-p t keys) 
    4384           (values (and object-file 
    4385                        (c::build-fasl (compile-file-pathname object-file :type :fasl) 
    4386                                       :lisp-files (list object-file)) 
    4387                        object-file) 
    4388                   flags1 
    4389                   flags2)))) 
     4414  #+(or (and ecl win32) (and mkcl windows)) 
     4415  (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal) 
     4416    (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source)))) 
    43904417 
    4391   (defmethod output-files ((operation compile-op) (c cl-source-file)) 
    4392     (declare (ignorable operation)) 
    4393     (let* ((p (lispize-pathname (component-pathname c))) 
    4394            (f (compile-file-pathname p :type :fasl))) 
    4395       (if (use-ecl-byte-compiler-p) 
    4396           (list f) 
    4397           (list (compile-file-pathname p :type :object) f)))) 
     4418  (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* 
     4419        (loop :for f :in #+ecl ext:*module-provider-functions* 
     4420          #+mkcl mk-ext::*module-provider-functions* 
     4421          :unless (eq f 'module-provide-asdf) 
     4422          :collect #'(lambda (name) 
     4423                       (let ((l (multiple-value-list (funcall f name)))) 
     4424                         (and (first l) (register-pre-built-system (coerce-name name))) 
     4425                         (values-list l))))) 
    43984426 
    4399   (defmethod perform ((o load-op) (c cl-source-file)) 
    4400     (map () #'load 
    4401          (loop :for i :in (input-files o c) 
    4402            :unless (string= (pathname-type i) "fas") 
    4403                :collect (compile-file-pathname (lispize-pathname i)))))) 
     4427  (setf *compile-op-compile-file-function* 'compile-file-keeping-object) 
    44044428 
    4405 ;;;; ----------------------------------------------------------------- 
    4406 ;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL 
     4429  (defun compile-file-keeping-object (input-file &rest keys &key &allow-other-keys) 
     4430    (#+ecl if #+ecl (use-ecl-byte-compiler-p) #+ecl (apply 'compile-file* input-file keys) 
     4431     #+mkcl progn 
     4432     (multiple-value-bind (object-file flags1 flags2) 
     4433         (apply 'compile-file* input-file 
     4434                #+ecl :system-p #+ecl t #+mkcl :fasl-p #+mkcl nil keys) 
     4435       (values (and object-file 
     4436                    (compiler::build-fasl 
     4437                     (compile-file-pathname object-file 
     4438                                            #+ecl :type #+ecl :fasl #+mkcl :fasl-p #+mkcl t) 
     4439                     #+ecl :lisp-files #+mkcl :lisp-object-files (list object-file)) 
     4440                    object-file) 
     4441               flags1 
     4442               flags2))))) 
     4443 
     4444;;;; ----------------------------------------------------------------------- 
     4445;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL 
    44074446;;;; 
    4408 (defvar *require-asdf-operator* 'load-op) 
    4409  
    44104447(defun* module-provide-asdf (name) 
    44114448  (handler-bind 
    44124449      ((style-warning #'muffle-warning) 
     
    44184455    (let ((*verbose-out* (make-broadcast-stream)) 
    44194456          (system (find-system (string-downcase name) nil))) 
    44204457      (when system 
    4421         (operate *require-asdf-operator* system :verbose nil :force-not (loaded-systems)) 
     4458        (require-system system :verbose nil) 
    44224459        t)))) 
    44234460 
    4424 #+(or abcl clisp clozure cmu ecl sbcl) 
     4461#+(or abcl clisp clozure cmu ecl mkcl sbcl) 
    44254462(let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom)))) 
    44264463  (when x 
    44274464    (eval `(pushnew 'module-provide-asdf 
     
    44294466            #+clisp ,x 
    44304467            #+clozure ccl:*module-provider-functions* 
    44314468            #+(or cmu ecl) ext:*module-provider-functions* 
     4469            #+mkcl mk-ext:*module-provider-functions* 
    44324470            #+sbcl sb-ext:*module-provider-functions*)))) 
    44334471 
    44344472 
     
    44484486(when *load-verbose* 
    44494487  (asdf-message ";; ASDF, version ~a~%" (asdf-version))) 
    44504488 
     4489#+mkcl 
     4490(progn 
     4491  (defvar *loading-asdf-bundle* nil) 
     4492  (unless *loading-asdf-bundle* 
     4493    (let ((*central-registry* 
     4494           (cons (translate-logical-pathname #P"CONTRIB:asdf-bundle;") *central-registry*)) 
     4495          (*loading-asdf-bundle* t)) 
     4496      (clear-system :asdf-bundle) ;; we hope to force a reload. 
     4497      (multiple-value-bind (result bundling-error) 
     4498          (ignore-errors (asdf:oos 'asdf:load-op :asdf-bundle)) 
     4499        (unless result 
     4500          (format *error-output* 
     4501                  "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ASDF: Reason is: ~A.~%" 
     4502                  bundling-error)))))) 
     4503 
    44514504#+allegro 
    44524505(eval-when (:compile-toplevel :execute) 
    44534506  (when (boundp 'excl:*warn-on-nested-reader-conditionals*) 
  • README-OpenMCL.txt

     
    11This directory contains various third-party opensourced 
    22system-building tools. 
    33 
    4 The code here is current as of February 1, 2005; you may want 
    5 to check the originating project's homepages to see if more recent 
    6 versions are available. 
     4The code here is current as of November 11, 2012; 
     5you may want to check the originating project's homepages 
     6to see if more recent versions are available. 
    77 
    8 "defsystem.lisp" is part of the clocc project on SourcForge: 
    9 <http://sourceforge.net/projects/clocc>.  It's a "system definition 
    10 facility" which provides functionality similar to that offered by 
    11 the Unix "make" program.  It was originally written by Mark Kantrowitz 
    12 and has been maintained and enhanced by many people; I believe that 
    13 Marco Antoniotti is currently the principal developer.  This is 
    14 version 3.4i of DEFSYSTEM (which is often called "MK-DEFSYSTEM"). 
    15 Note that, for historical reasons, DEFSYSTEM will try to redefine 
    16 the CL:REQUIRE function. 
     8"asdf.lisp" is Another System Definition Facility and 
     9is available as part of its own project on Common-Lisp.net: 
     10<http://common-lisp.net/project/asdf/>. 
     11It was written by Daniel Barlow and 
     12is currently maintained by Francois-Rene Rideau. 
     13It hooks into CCL's existing CL:REQUIRE function. 
    1714 
    18 "asdf.lisp" is Another System Definition Facility and is available as 
    19 part of the cclan project on SourceForge: 
    20 <http://sourceforge.net/projects/cclan>.  It was written by and 
    21 is maintained by Daniel Barlow. 
     15To automatically download libraries, we recommend 
     16you use quicklisp <http://www.quicklisp.org/> 
     17or clbuild <http://common-lisp.net/project/clbuild/> 
    2218 
    23 "asdf-install" is a library which can be used to download CL packages 
    24 from the Internet and which uses ASDF to build and install them.  It's 
    25 also part of the cclan project and was originally written (for SBCL) 
    26 by Dan Barlow.  It's since been ported to several other CL 
    27 implementations; Marco Baringer did the OpenMCL port. 
    28  
    29 There's excellent documentation on asdf-install in the asdf-install/doc 
    30 directory.  As that document mentions, asdf-install is designed to use 
    31 the GnuPG package to validate cryptographic signatures associated with 
    32 asdf-install-able packages, though it can apparently be configured to 
    33 work in an environment in which GnuPG is not available. 
    34  
    35 Downloading code from publicly-writable Internet sites - without the 
    36 ability to verify that that code's really what it claims to be and 
    37 from the author who claims to have provided it - is obviously a 
    38 dangerous and unwise thing to do.  It's strongly recommended that 
    39 people ensure that GnuPG is installed (and ensure that asdf-install is 
    40 configured to use it) before using asdf-install to download packages. 
    41  
    42 (GnuPG packages for OSX are available from <http://macgpg.sourceforge.net>. 
    43 Most Linux distributions offer GnuPG through their packaging system; 
    44 further information on GnuPG is available at <http:///www.gnupg.org>. 
    45  
    46  
     19"defsystem.lisp" is part of the clocc project on SourceForge: 
     20<http://sourceforge.net/projects/clocc>. 
     21It's a "system definition facility" that provides functionality 
     22similar to that offered by the Unix "make" program. 
     23It was originally written by Mark Kantrowitz 
     24and has been maintained and enhanced by many people; 
     25I believe that Marco Antoniotti was the last maintainer. 
     26This is version 3.6i of DEFSYSTEM (which is often called "MK-DEFSYSTEM"). 
     27Note that, for historical reasons, 
     28DEFSYSTEM will try to redefine the CL:REQUIRE function. 
  • defsystem.lisp

     
    11;;; -*- Mode: Lisp; Package: make -*- 
    22;;; -*- Mode: CLtL; Syntax: Common-Lisp -*- 
    33 
    4 ;;; DEFSYSTEM 3.4 Interim. 
     4;;; DEFSYSTEM 3.6 Interim. 
    55 
    66;;; defsystem.lisp -- 
    77 
     
    2828;;; Originally written by Mark Kantrowitz, School of Computer Science, 
    2929;;; Carnegie Mellon University, October 1989. 
    3030 
    31 ;;; MK:DEFSYSTEM 3.3 Interim 
     31;;; MK:DEFSYSTEM 3.6 Interim 
    3232;;; 
    3333;;; Copyright (c) 1989 - 1999 Mark Kantrowitz. All rights reserved. 
    34 ;;;               1999 - 2004 Mark Kantrowitz and Marco Antoniotti. All 
     34;;;               1999 - 2005 Mark Kantrowitz and Marco Antoniotti. All 
    3535;;;                           rights reserved. 
    3636 
    3737;;; Use, copying, modification, merging, publishing, distribution 
     
    835835;;; ******************************** 
    836836;;; Let's be smart about CLtL2 compatible Lisps: 
    837837(eval-when (compile load eval) 
    838   #+(or (and allegro-version>= (version>= 4 0)) :mcl :openmcl :sbcl) 
     838  #+(or (and allegro-version>= (version>= 4 0)) :mcl :sbcl) 
    839839  (pushnew :cltl2 *features*)) 
    840840 
    841841;;; ******************************** 
     
    864864#-(or :CMU 
    865865      :vms 
    866866      :mcl 
    867       :openmcl 
    868867      :lispworks 
    869868      :clisp 
    870869      :gcl 
     
    10131012 
    10141013#+:lispworks 
    10151014(defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP") 
    1016             (:import-from system *modules* provide require) 
     1015            (:import-from "SYSTEM" *modules* provide require) 
    10171016            (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM" 
    10181017                     "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*")) 
    10191018 
     
    11081107;;; then a succeeding export as well. 
    11091108 
    11101109(eval-when (compile load eval) 
    1111    (defvar *special-exports* nil) 
    1112    (defvar *exports* nil) 
    1113    (defvar *other-exports* nil) 
     1110  (defvar *special-exports* nil) 
     1111  (defvar *exports* nil) 
     1112  (defvar *other-exports* nil) 
    11141113 
    1115    (export (setq *exports* 
    1116                 '(operate-on-system 
    1117                    oos 
    1118                    afs-binary-directory afs-source-directory 
    1119                    files-in-system))) 
    1120    (export (setq *special-exports* 
    1121                 '())) 
    1122    (export (setq *other-exports* 
    1123                 '(*central-registry* 
    1124                    *bin-subdir* 
     1114  (export (setq *exports* 
     1115                '(operate-on-system 
     1116                  oos 
     1117                  afs-binary-directory afs-source-directory 
     1118                  files-in-system))) 
     1119  (export (setq *special-exports* 
     1120                '())) 
     1121  (export (setq *other-exports* 
     1122                '(*central-registry* 
     1123                  *bin-subdir* 
    11251124 
    1126                    add-registry-location 
    1127                    find-system 
    1128                    defsystem compile-system load-system hardcopy-system 
     1125                  add-registry-location 
     1126                  list-central-registry-directories 
     1127                  print-central-registry-directories 
     1128                  find-system 
     1129                  defsystem compile-system load-system hardcopy-system 
    11291130 
    1130                    system-definition-pathname 
     1131                  system-definition-pathname 
    11311132 
    1132                    missing-component 
    1133                    missing-component-name 
    1134                    missing-component-component 
    1135                    missing-module 
    1136                    missing-system 
     1133                  missing-component 
     1134                  missing-component-name 
     1135                  missing-component-component 
     1136                  missing-module 
     1137                  missing-system 
    11371138 
    1138                    register-foreign-system 
     1139                  register-foreign-system 
    11391140 
    1140                    machine-type-translation 
    1141                    software-type-translation 
    1142                    compiler-type-translation 
    1143                    ;; require 
    1144                    define-language 
    1145                    allegro-make-system-fasl 
    1146                    files-which-need-compilation 
    1147                    undefsystem 
    1148                    defined-systems 
    1149                    describe-system clean-system edit-system ;hardcopy-system 
    1150                    system-source-size make-system-tag-table 
    1151                    *defsystem-version* 
    1152                    *compile-during-load* 
    1153                    *minimal-load* 
    1154                    *dont-redefine-require* 
    1155                    *files-missing-is-an-error* 
    1156                    *reload-systems-from-disk* 
    1157                    *source-pathname-default* 
    1158                    *binary-pathname-default* 
    1159                    *multiple-lisp-support* 
    1160                    )))) 
     1141                  machine-type-translation 
     1142                  software-type-translation 
     1143                  compiler-type-translation 
     1144                  ;; require 
     1145                  define-language 
     1146                  allegro-make-system-fasl 
     1147                  files-which-need-compilation 
     1148                  undefsystem 
     1149                  defined-systems 
     1150                  describe-system clean-system edit-system ;hardcopy-system 
     1151                  system-source-size make-system-tag-table 
     1152                  *defsystem-version* 
     1153                  *compile-during-load* 
     1154                  *minimal-load* 
     1155                  *dont-redefine-require* 
     1156                  *files-missing-is-an-error* 
     1157                  *reload-systems-from-disk* 
     1158                  *source-pathname-default* 
     1159                  *binary-pathname-default* 
     1160                  *multiple-lisp-support* 
    11611161 
     1162                  run-unix-program 
     1163                  *default-shell* 
     1164                  run-shell-command 
     1165                  ))) 
     1166  ) 
    11621167 
     1168 
    11631169;;; We import these symbols into the USER package to make them 
    11641170;;; easier to use. Since some lisps have already defined defsystem 
    11651171;;; in the user package, we may have to shadowing-import it. 
     
    11841190  (pushnew :pcl *modules*) 
    11851191  (pushnew :pcl *features*)) 
    11861192 
     1193 
    11871194;;; ******************************** 
    11881195;;; Defsystem Version ************** 
    11891196;;; ******************************** 
    1190 (defparameter *defsystem-version* "3.3 Interim, 2002-06-13" 
    1191   "Current version number/date for Defsystem.") 
     1197(defparameter *defsystem-version* "3.6 Interim, 2008-12-18" 
     1198  "Current version number/date for MK:DEFSYSTEM.") 
    11921199 
     1200 
    11931201;;; ******************************** 
    11941202;;; Customizable System Parameters * 
    11951203;;; ******************************** 
    11961204 
    1197 (defvar *dont-redefine-require* nil 
    1198   "If T, prevents the redefinition of REQUIRE. This is useful for 
    1199    lisps that treat REQUIRE specially in the compiler.") 
     1205(defvar *dont-redefine-require* 
     1206  #+cmu (if (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" "EXT") t nil) 
     1207  #+(or clisp sbcl) t 
     1208  #+allegro t 
     1209  #-(or cmu sbcl clisp allegro) nil 
     1210  "If T, prevents the redefinition of REQUIRE. 
     1211This is useful for lisps that treat REQUIRE specially in the compiler.") 
    12001212 
     1213 
    12011214(defvar *multiple-lisp-support* t 
    12021215  "If T, afs-binary-directory will try to return a name dependent 
    1203    on the particular lisp compiler version being used.") 
     1216on the particular lisp compiler version being used.") 
    12041217 
     1218 
    12051219;;; home-subdirectory -- 
    12061220;;; HOME-SUBDIRECTORY is used only in *central-registry* below. 
    12071221;;; Note that CMU CL 17e does not understand the ~/ shorthand for home 
     
    12131227;;; it is UNIX dependent. 
    12141228;;; I added the kludgy #+cormalisp (v 1.5) one, since it is missing 
    12151229;;; the ANSI USER-HOMEDIR-PATHNAME function. 
     1230 
    12161231#-cormanlisp 
    12171232(defun home-subdirectory (directory) 
    12181233  (concatenate 'string 
     
    12241239              "~/")) 
    12251240        directory)) 
    12261241 
     1242 
    12271243#+cormanlisp 
    12281244(defun home-subdirectory (directory) 
    12291245  (declare (type string directory)) 
    12301246  (concatenate 'string "C:\\" directory)) 
    12311247 
     1248 
    12321249;;; The following function is available for users to add 
    12331250;;;   (setq mk:*central-registry* (defsys-env-search-path)) 
    12341251;;; to Lisp init files in order to use the value of the DEFSYSPATH 
    12351252;;; instead of directly coding it in the file. 
     1253 
    12361254#+:allegro 
    12371255(defun defsys-env-search-path () 
    12381256  "This function grabs the value of the DEFSYSPATH environment variable 
     
    12401258  (remove-duplicates (split-string (sys:getenv "DEFSYSPATH") :item #\:) 
    12411259                     :test #'string-equal)) 
    12421260 
     1261 
    12431262;;; Change this variable to set up the location of a central 
    12441263;;; repository for system definitions if you want one. 
    12451264;;; This is a defvar to allow users to change the value in their 
     
    12551274    #+:LUCID     (working-directory) 
    12561275    #+ACLPC      (current-directory) 
    12571276    #+:allegro   (excl:current-directory) 
     1277    #+:clisp     (ext:default-directory) 
    12581278    #+:sbcl      (progn *default-pathname-defaults*) 
    12591279    #+(or :cmu :scl)       (ext:default-directory) 
    12601280    ;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu> 
    12611281    ;; Somehow it is better to qualify default-directory in CMU with 
    12621282    ;; the appropriate package (i.e. "EXTENSIONS".) 
    12631283    ;; Same for Allegro. 
    1264     #+(and :lispworks (not :lispworks4)) 
     1284    #+(and :lispworks (not :lispworks4) (not :lispworks5)) 
    12651285    ,(multiple-value-bind (major minor) 
    12661286                          #-:lispworks-personal-edition 
    12671287                          (system::lispworks-version) 
     
    12771297                                         (find-package "SYSTEM"))) 
    12781298           (find-symbol "*CURRENT-WORKING-DIRECTORY*" 
    12791299                        (find-package "LW")))) 
    1280     #+:lispworks4 
     1300    #+(or :lispworks4 :lispworks5) 
    12811301    (hcl:get-working-directory) 
    12821302    ;; Home directory 
    12831303    #-sbcl 
    12841304    (mk::home-subdirectory "lisp/systems/") 
    12851305 
    12861306    ;; Global registry 
    1287     "/usr/local/lisp/Registry/") 
    1288   "Central directory of system definitions. May be either a single 
    1289    directory pathname, or a list of directory pathnames to be checked 
    1290    after the local directory.") 
     1307    #+unix (pathname "/usr/local/lisp/Registry/") 
     1308    ) 
     1309  "Central directory of system definitions. 
     1310May be either a single directory pathname, or a list of directory 
     1311pathnames to be checked after the local directory.") 
    12911312 
    12921313 
    12931314(defun add-registry-location (pathname) 
    12941315  "Adds a path to the central registry." 
    12951316  (pushnew pathname *central-registry* :test #'equal)) 
    12961317 
     1318 
     1319(defun registry-pathname (registry) 
     1320  "Return the pathname represented by the element of *CENTRAL-REGISTRY*." 
     1321  (typecase registry 
     1322    (string (pathname registry)) 
     1323    (pathname registry) 
     1324    (otherwise (pathname (eval registry))))) 
     1325 
     1326 
     1327(defun print-central-registry-directories (&optional (stream *standard-output*)) 
     1328  (dolist (registry *central-registry*) 
     1329    (print (registry-pathname registry) stream))) 
     1330 
     1331 
     1332(defun list-central-registry-directories () 
     1333  (mapcar #'registry-pathname *central-registry*)) 
     1334 
     1335 
    12971336(defvar *bin-subdir* ".bin/" 
    12981337  "The subdirectory of an AFS directory where the binaries are really kept.") 
    12991338 
     1339 
    13001340;;; These variables set up defaults for operate-on-system, and are used 
    13011341;;; for communication in lieu of parameter passing. Yes, this is bad, 
    13021342;;; but it keeps the interface small. Also, in the case of the -if-no-binary 
    13031343;;; variables, parameter passing would require multiple value returns 
    13041344;;; from some functions. Why make life complicated? 
     1345 
    13051346(defvar *tell-user-when-done* nil 
    13061347  "If T, system will print ...DONE at the end of an operation") 
     1348 
    13071349(defvar *oos-verbose* nil 
    13081350  "Operate on System Verbose Mode") 
     1351 
    13091352(defvar *oos-test* nil 
    13101353  "Operate on System Test Mode") 
     1354 
    13111355(defvar *load-source-if-no-binary* nil 
    13121356  "If T, system will try loading the source if the binary is missing") 
     1357 
    13131358(defvar *bother-user-if-no-binary* t 
    13141359  "If T, the system will ask the user whether to load the source if 
    13151360   the binary is missing") 
     1361 
    13161362(defvar *load-source-instead-of-binary* nil 
    13171363  "If T, the system will load the source file instead of the binary.") 
     1364 
    13181365(defvar *compile-during-load* :query 
    13191366  "If T, the system will compile source files during load if the 
    1320    binary file is missing. If :query, it will ask the user for 
    1321    permission first.") 
     1367binary file is missing. If :query, it will ask the user for 
     1368permission first.") 
     1369 
    13221370(defvar *minimal-load* nil 
    13231371  "If T, the system tries to avoid reloading files that were already loaded 
    1324    and up to date.") 
     1372and up to date.") 
    13251373 
    13261374(defvar *files-missing-is-an-error* t 
    13271375  "If both the source and binary files are missing, signal a continuable 
     
    13331381   or by another defsystem form.") 
    13341382 
    13351383;;; Particular to CMULisp 
     1384 
    13361385(defvar *compile-error-file-type* "err" 
    13371386  "File type of compilation error file in cmulisp") 
     1387 
    13381388(defvar *cmu-errors-to-terminal* t 
    13391389  "Argument to :errors-to-terminal in compile-file in cmulisp") 
     1390 
    13401391(defvar *cmu-errors-to-file* t 
    13411392  "If T, cmulisp will write an error file during compilation") 
    13421393 
     1394 
    13431395;;; ******************************** 
    13441396;;; Global Variables *************** 
    13451397;;; ******************************** 
     
    13561408    (pushnew :ibm-rt-pc *features*)) 
    13571409  ) 
    13581410 
     1411 
    13591412;;; *filename-extensions* is a cons of the source and binary extensions. 
    13601413(defvar *filename-extensions* 
    13611414  (car `(#+(and Symbolics Lispm)              ("lisp" . "bin") 
    13621415         #+(and dec common vax (not ultrix))  ("LSP"  . "FAS") 
    13631416         #+(and dec common vax ultrix)        ("lsp"  . "fas") 
    13641417         #+ACLPC                              ("lsp"  . "fsl") 
    1365          #+CLISP                              ("lsp" . "fas") 
     1418         #+CLISP                              ("lisp" . "fas") 
    13661419         #+KCL                                ("lsp"  . "o") 
    1367          #+ECL                                ("lsp"  . "so") 
     1420         ;;#+ECL                                ("lsp"  . "so") 
    13681421         #+IBCL                               ("lsp"  . "o") 
    13691422         #+Xerox                              ("lisp" . "dfasl") 
    13701423         ;; Lucid on Silicon Graphics 
     
    14021455 
    14031456         ;; Otherwise, 
    14041457         ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp"))))) 
    1405   "Filename extensions for Common Lisp. A cons of the form 
    1406    (Source-Extension . Binary-Extension). If the system is 
    1407    unknown (as in *features* not known), defaults to lisp and fasl.") 
     1458  "Filename extensions for Common Lisp. 
     1459A cons of the form (Source-Extension . Binary-Extension). If the 
     1460system is unknown (as in *features* not known), defaults to lisp and 
     1461fasl.") 
    14081462 
    14091463(defvar *system-extension* 
    14101464  ;; MS-DOS systems can only handle three character extensions. 
     
    14121466  #+ACLPC "sys" 
    14131467  "The filename extension to use with systems.") 
    14141468 
     1469 
    14151470;;; The above variables and code should be extended to allow a list of 
    14161471;;; valid extensions for each lisp implementation, instead of a single 
    14171472;;; extension. When writing a file, the first extension should be used. 
     
    14281483;;; Note that in any event, the toplevel system (defined with defsystem) 
    14291484;;; will have its dependencies delayed. Not having dependencies delayed 
    14301485;;; might be useful if we define several systems within one defsystem. 
     1486 
    14311487(defvar *system-dependencies-delayed* t 
    14321488  "If T, system dependencies are expanded at run time") 
    14331489 
     1490 
    14341491;;; Replace this with consp, dammit! 
    14351492(defun non-empty-listp (list) 
    14361493  (and list (listp list))) 
    14371494 
     1495 
    14381496;;; ******************************** 
    14391497;;; Component Operation Definition * 
    14401498;;; ******************************** 
    14411499(eval-when (:compile-toplevel :load-toplevel :execute) 
     1500 
    14421501(defvar *version-dir* nil 
    14431502  "The version subdir. bound in operate-on-system.") 
     1503 
    14441504(defvar *version-replace* nil 
    14451505  "The version replace. bound in operate-on-system.") 
     1506 
    14461507(defvar *version* nil 
    14471508  "Default version.")) 
    14481509 
    14491510(defvar *component-operations* (make-hash-table :test #'equal) 
    14501511  "Hash table of (operation-name function) pairs.") 
     1512 
    14511513(defun component-operation (name &optional operation) 
    14521514  (if operation 
    14531515      (setf (gethash name *component-operations*) operation) 
    14541516      (gethash name *component-operations*))) 
    14551517 
     1518 
    14561519;;; ******************************** 
    14571520;;; AFS @sys immitator ************* 
    14581521;;; ******************************** 
     
    14701533       (declare (ignore char arg)) 
    14711534       `(afs-binary-directory ,(read stream t nil t))))) 
    14721535 
     1536 
    14731537(defvar *find-irix-version-script* 
    14741538    "\"1,4 d\\ 
    14751539s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\ 
    14761540/./,$ d\\ 
    14771541\"") 
    14781542 
     1543 
    14791544(defun operating-system-version () 
    14801545  #+(and :sgi :excl) 
    14811546  (let* ((full-version (software-version)) 
     
    15171582  #-(or (and :excl :sgi) (and :cmu :sgi) (and :lispworks :irix)) 
    15181583  (software-type)) 
    15191584 
     1585 
    15201586(defun compiler-version () 
    15211587  #+:lispworks (concatenate 'string 
    15221588                "lispworks" " " (lisp-implementation-version)) 
     
    15441610  #+gclisp    "gclisp" 
    15451611  ) 
    15461612 
     1613 
    15471614(defun afs-binary-directory (root-directory) 
    15481615  ;; Function for obtaining the directory AFS's @sys feature would have 
    15491616  ;; chosen when we're not in AFS. This function is useful as the argument 
     
    15821649          root-directory 
    15831650          (and version-flag (translate-version *version*)))) 
    15841651 
     1652 
    15851653(defun null-string (s) 
    15861654  (when (stringp s) 
    15871655    (string-equal s ""))) 
    15881656 
     1657 
    15891658(defun ensure-trailing-slash (dir) 
    15901659  (if (and dir 
    15911660           (not (null-string dir)) 
     
    15991668      (concatenate 'string dir "/") 
    16001669      dir)) 
    16011670 
     1671 
    16021672(defun afs-component (machine software &optional lisp) 
    16031673  (format nil "~@[~A~]~@[_~A~]~@[_~A~]" 
    16041674            machine 
    16051675            (or software "mach") 
    16061676            lisp)) 
    16071677 
     1678 
    16081679(defvar *machine-type-alist* (make-hash-table :test #'equal) 
    16091680  "Hash table for retrieving the machine-type") 
     1681 
    16101682(defun machine-type-translation (name &optional operation) 
    16111683  (if operation 
    16121684      (setf (gethash (string-upcase name) *machine-type-alist*) operation) 
    16131685      (gethash (string-upcase name) *machine-type-alist*))) 
    16141686 
     1687 
    16151688(machine-type-translation "IBM RT PC"                        "rt") 
    16161689(machine-type-translation "DEC 3100"                         "pmax") 
    16171690(machine-type-translation "DEC VAX-11"                       "vax") 
     
    16521725 
    16531726(defvar *software-type-alist* (make-hash-table :test #'equal) 
    16541727  "Hash table for retrieving the software-type") 
     1728 
    16551729(defun software-type-translation (name &optional operation) 
    16561730  (if operation 
    16571731      (setf (gethash (string-upcase name) *software-type-alist*) operation) 
    16581732      (gethash (string-upcase name) *software-type-alist*))) 
    16591733 
     1734 
    16601735(software-type-translation "BSD UNIX"      "mach") ; "unix" 
    16611736(software-type-translation "Ultrix"        "mach") ; "ultrix" 
    16621737(software-type-translation "SunOS"         "SunOS") 
     
    16841759                           #+:lcl4.0 "4.0" 
    16851760                           #+(and :lcl3.0 (not :lcl4.0)) "3.0") 
    16861761 
     1762 
    16871763(defvar *compiler-type-alist* (make-hash-table :test #'equal) 
    16881764  "Hash table for retrieving the Common Lisp type") 
     1765 
    16891766(defun compiler-type-translation (name &optional operation) 
    16901767  (if operation 
    16911768      (setf (gethash (string-upcase name) *compiler-type-alist*) operation) 
    16921769    (gethash (string-upcase name) *compiler-type-alist*))) 
    16931770 
     1771 
    16941772(compiler-type-translation "lispworks 3.2.1"         "lispworks") 
    16951773(compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks") 
    16961774(compiler-type-translation "lispworks 4.2.0"         "lispworks") 
    16971775 
     1776 
    16981777#+allegro 
    16991778(eval-when (:compile-toplevel :load-toplevel :execute) 
    17001779  (unless (or (find :case-sensitive common-lisp:*features*) 
     
    17211800(compiler-type-translation "cmu 17e" "cmu") 
    17221801(compiler-type-translation "cmu 17d" "cmu") 
    17231802 
     1803 
    17241804;;; ******************************** 
    17251805;;; System Names ******************* 
    17261806;;; ******************************** 
    17271807 
    17281808;;; If you use strings for system names, be sure to use the same case 
    17291809;;; as it appears on disk, if the filesystem is case sensitive. 
     1810 
    17301811(defun canonicalize-system-name (name) 
    17311812  ;; Originally we were storing systems using GET. This meant that the 
    17321813  ;; name of a system had to be a symbol, so we interned the symbols 
     
    17391820      (intern (string-upcase (string name)) "KEYWORD"))||# 
    17401821  (if (stringp name) (string-upcase name) (string-upcase (string name)))) 
    17411822 
     1823 
    17421824(defvar *defined-systems* (make-hash-table :test #'equal) 
    17431825  "Hash table containing the definitions of all known systems.") 
    17441826 
     1827 
    17451828(defun get-system (name) 
    17461829  "Returns the definition of the system named NAME." 
    17471830  (gethash (canonicalize-system-name name) *defined-systems*)) 
    17481831 
     1832 
    17491833(defsetf get-system (name) (value) 
    17501834  `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value)) 
    17511835 
     1836 
    17521837(defun undefsystem (name) 
    17531838  "Removes the definition of the system named NAME." 
    1754   (setf (get-system name) nil)) 
     1839  (remhash (canonicalize-system-name name) *defined-systems*)) 
    17551840 
     1841 
    17561842(defun defined-systems () 
    17571843  "Returns a list of defined systems." 
    17581844  (let ((result nil)) 
     
    17621848             *defined-systems*) 
    17631849    result)) 
    17641850 
     1851 
     1852(defun defined-names-and-systems () 
     1853  "Returns a a-list of defined systems along with their names." 
     1854  (loop for sname being the hash-keys of *defined-systems* 
     1855        using (hash-value s) 
     1856        collect (cons sname s))) 
     1857 
     1858 
    17651859;;; ******************************** 
    17661860;;; Directory Pathname Hacking ***** 
    17671861;;; ******************************** 
     
    18261920         (rel-directory (directory-to-list (pathname-directory rel-dir))) 
    18271921         (rel-keyword (when (keywordp (car rel-directory)) 
    18281922                        (pop rel-directory))) 
    1829          #-(or :MCL :sbcl :clisp) (rel-file (file-namestring rel-dir)) 
     1923         ;; rtoy: Why should any Lisp want rel-file?  Shouldn't using 
     1924         ;; rel-name and rel-type work for every Lisp? 
     1925         #-(or :MCL :sbcl :clisp :cmu) (rel-file (file-namestring rel-dir)) 
    18301926         ;; Stig (July 2001); 
    18311927         ;; These values seems to help clisp as well 
    1832          #+(or :MCL :sbcl :clisp) (rel-name (pathname-name rel-dir)) 
    1833          #+(or :MCL :sbcl :clisp) (rel-type (pathname-type rel-dir)) 
     1928         #+(or :MCL :sbcl :clisp :cmu) (rel-name (pathname-name rel-dir)) 
     1929         #+(or :MCL :sbcl :clisp :cmu) (rel-type (pathname-type rel-dir)) 
    18341930         (directory nil)) 
    18351931 
    18361932    ;; TI Common Lisp pathnames can return garbage for file names because 
     
    18831979                    :directory 
    18841980                    directory 
    18851981                    :name 
    1886                     #-(or :sbcl :MCL :clisp) rel-file 
    1887                     #+(or :sbcl :MCL :clisp) rel-name 
     1982                    #-(or :sbcl :MCL :clisp :cmu) rel-file 
     1983                    #+(or :sbcl :MCL :clisp :cmu) rel-name 
    18881984 
    1889                     #+(or :sbcl :MCL :clisp) :type 
    1890                     #+(or :sbcl :MCL :clisp) rel-type 
     1985                    #+(or :sbcl :MCL :clisp :cmu) :type 
     1986                    #+(or :sbcl :MCL :clisp :cmu) rel-type 
    18911987                    )))) 
    18921988 
     1989 
    18931990(defun directory-to-list (directory) 
    18941991  ;; The directory should be a list, but nonstandard implementations have 
    18951992  ;; been known to use a vector or even a string. 
     
    19302027     nil "/baz/barf.lisp" 
    19312028     nil nil)) 
    19322029 
     2030 
    19332031(defun test-new-append-directories (&optional (test-dirs *append-dirs-tests*)) 
    19342032  (do* ((dir-list test-dirs (cddr dir-list)) 
    19352033        (abs-dir (car dir-list) (car dir-list)) 
     
    19382036    (format t "~&ABS: ~S ~18TREL: ~S ~41TResult: ~S" 
    19392037            abs-dir rel-dir (new-append-directories abs-dir rel-dir)))) 
    19402038 
     2039 
    19412040#|| 
    19422041<cl> (test-new-append-directories) 
    19432042 
     
    20012100       #-(or :VMS :macl1.3.2) 
    20022101       (new-append-directories absolute-directory relative-directory))))) 
    20032102 
     2103 
    20042104#+:logical-pathnames-mk 
    20052105(defun append-logical-directories-mk (absolute-dir relative-dir) 
    20062106  (lp:append-logical-directories absolute-dir relative-dir)) 
     
    20262126  (translate-logical-pathname 
    20272127   (merge-pathnames relative-dir absolute-dir))) 
    20282128 
     2129 
    20292130#| Old version 2002-03-02 
    20302131#+(and (and allegro-version>= (version>= 4 1)) 
    20312132       (not :logical-pathnames-mk)) 
     
    21132214  (pathname-logical-p namestring)) 
    21142215||# 
    21152216 
     2217 
     2218#|| This is incorrect, as it strives to keep strings around, when it 
     2219    shouldn't.  MERGE-PATHNAMES already DTRT. 
    21162220(defun append-logical-pnames (absolute relative) 
    21172221  (declare (type (or null string pathname) absolute relative)) 
    21182222  (let ((abs (if absolute 
     
    21292233      (setq abs (concatenate 'string abs ";"))) 
    21302234    ;; Return the concatenate pathnames 
    21312235    (concatenate 'string abs rel))) 
     2236||# 
    21322237 
     2238 
     2239(defun append-logical-pnames (absolute relative) 
     2240  (declare (type (or null string pathname) absolute relative)) 
     2241  (let ((abs (if absolute 
     2242                 (pathname absolute) 
     2243                 (make-pathname :directory (list :absolute) 
     2244                                :name nil 
     2245                                :type nil) 
     2246                 )) 
     2247        (rel (if relative 
     2248                 (pathname relative) 
     2249                 (make-pathname :directory (list :relative) 
     2250                                :name nil 
     2251                                :type nil) 
     2252                 )) 
     2253        ) 
     2254    ;; The following is messed up because CMUCL and LW use different 
     2255    ;; defaults for host (in particular LW uses NIL).  Thus 
     2256    ;; MERGE-PATHNAMES has legitimate different behaviors on both 
     2257    ;; implementations. Of course this is disgusting, but that is the 
     2258    ;; way it is and the rest tries to circumvent this crap. 
     2259    (etypecase abs 
     2260      (logical-pathname 
     2261       (etypecase rel 
     2262         (logical-pathname 
     2263          (namestring (merge-pathnames rel abs))) 
     2264         (pathname 
     2265          ;; The following potentially translates the logical pathname 
     2266          ;; very early, but we cannot avoid it. 
     2267          (namestring (merge-pathnames rel (translate-logical-pathname abs)))) 
     2268         )) 
     2269      (pathname 
     2270       (namestring (merge-pathnames rel abs))) 
     2271      ))) 
     2272 
    21332273#|| 
    21342274;;; This was a try at appending a subdirectory onto a directory. 
    21352275;;; It failed. We're keeping this around to prevent future mistakes 
     
    22102350;;; ******************************** 
    22112351;;; Component Defstruct ************ 
    22122352;;; ******************************** 
     2353 
    22132354(defvar *source-pathname-default* nil 
    22142355  "Default value of :source-pathname keyword in DEFSYSTEM. Set this to 
    22152356   \"\" to avoid having to type :source-pathname \"\" all the time.") 
     
    22172358(defvar *binary-pathname-default* nil 
    22182359  "Default value of :binary-pathname keyword in DEFSYSTEM.") 
    22192360 
    2220 ;;; Removed TIME slot, which has been made unnecessary by the new definition 
    2221 ;;; of topological-sort. 
    22222361 
    22232362(defstruct (topological-sort-node (:conc-name topsort-)) 
    22242363  (color :white :type (member :gray :black :white)) 
    2225   ;; time 
    22262364  ) 
    22272365 
     2366 
     2367(defparameter *component-evaluated-slots* 
     2368  '(:source-root-dir :source-pathname :source-extension 
     2369    :binary-root-dir :binary-pathname :binary-extension)) 
     2370 
     2371 
     2372(defparameter *component-form-slots* 
     2373  '(:initially-do :finally-do :compile-form :load-form)) 
     2374 
     2375 
    22282376(defstruct (component (:include topological-sort-node) 
    22292377                      (:print-function print-component)) 
    22302378  (type :file     ; to pacify the CMUCL compiler (:type is alway supplied) 
     
    22832431                                        ; one. 
    22842432  proclamations                         ; Compiler options, such as 
    22852433                                        ; '(optimize (safety 3)). 
    2286   initially-do                          ; Form to evaluate before the 
     2434  (initially-do (lambda () nil))        ; Form to evaluate before the 
    22872435                                        ; operation. 
    2288   finally-do                            ; Form to evaluate after the operation. 
    2289   compile-form                          ; For foreign libraries. 
    2290   load-form                             ; For foreign libraries. 
     2436  (finally-do (lambda () nil))          ; Form to evaluate after the operation. 
     2437  (compile-form (lambda () nil))        ; For foreign libraries. 
     2438  (load-form (lambda () nil))           ; For foreign libraries. 
    22912439 
    22922440  ;; load-time                          ; The file-write-date of the 
    22932441                                        ; binary/source file loaded. 
     
    23132461  (banner nil :type (or null string)) 
    23142462 
    23152463  (documentation nil :type (or null string)) ; Optional documentation slot 
     2464  (long-documentation nil :type (or null string)) ; Optional long documentation slot 
     2465 
     2466  ;; Added AUTHOR, MAINTAINER, VERSION and LICENCE slots. 
     2467  (author nil :type (or null string)) 
     2468  (licence nil :type (or null string)) 
     2469  (maintainer nil :type (or null string)) 
     2470  (version nil :type (or null string)) 
     2471 
     2472  ;; Added NON-REQUIRED-P slot.  Useful for optional items. 
     2473  (non-required-p nil :type boolean)    ; If T a missing file or 
     2474                                        ; sub-directory will not cause 
     2475                                        ; an error. 
    23162476  ) 
    23172477 
    23182478 
     
    23402500   (component :reader missing-component-component 
    23412501              :initarg :component) 
    23422502   ) 
    2343   (:default-initargs :component nil) 
     2503  #-gcl (:default-initargs :component nil) 
    23442504  (:report (lambda (mmc stream) 
    23452505             (format stream "MK:DEFSYSTEM: missing component ~S for ~S." 
    23462506                     (missing-component-name mmc) 
     
    23662526 
    23672527 
    23682528(defvar *file-load-time-table* (make-hash-table :test #'equal) 
    2369   "Hash table of file-write-dates for the system definitions and 
    2370    files in the system definitions.") 
     2529  "Hash table of file-write-dates for the system definitions and files in the system definitions.") 
     2530 
     2531 
    23712532(defun component-load-time (component) 
    23722533  (when component 
    23732534    (etypecase component 
     
    24452606;;; compute-system-path -- 
    24462607 
    24472608(defun compute-system-path (module-name definition-pname) 
    2448   (let* ((file-pathname 
    2449           (make-pathname :name (etypecase module-name 
    2450                                  (symbol (string-downcase 
    2451                                           (string module-name))) 
    2452                                  (string module-name)) 
     2609  (let* ((module-string-name 
     2610          (etypecase module-name 
     2611            (symbol (string-downcase 
     2612                     (string module-name))) 
     2613            (string module-name))) 
     2614 
     2615         (file-pathname 
     2616          (make-pathname :name module-string-name 
    24532617                         :type *system-extension*)) 
     2618 
    24542619         (lib-file-pathname 
    2455           (make-pathname :directory (list :relative module-name) 
    2456                          :name (etypecase module-name 
    2457                                  (symbol (string-downcase 
    2458                                           (string module-name))) 
    2459                                  (string module-name)) 
     2620          (make-pathname :directory (list :relative module-string-name) 
     2621                         :name module-string-name 
    24602622                         :type *system-extension*)) 
    24612623         ) 
    24622624    (or (when definition-pname          ; given pathname for system def 
     
    24662628        (cond (*central-registry* 
    24672629               (if (listp *central-registry*) 
    24682630                   (dolist (registry *central-registry*) 
    2469                      (let ((file (or (probe-file 
    2470                                       (append-directories (if (consp registry) 
    2471                                                               (eval registry) 
    2472                                                               registry) 
    2473                                                           file-pathname)) 
    2474                                      (probe-file 
    2475                                       (append-directories (if (consp registry) 
    2476                                                               (eval registry) 
    2477                                                               registry) 
    2478                                                           lib-file-pathname)) 
    2479                                      )) 
    2480                            ) 
     2631                     (let* ((reg-path (registry-pathname registry)) 
     2632                            (file (or (probe-file 
     2633                                       (append-directories 
     2634                                        reg-path file-pathname)) 
     2635                                      (probe-file 
     2636                                       (append-directories 
     2637                                        reg-path lib-file-pathname))))) 
    24812638                       (when file (return file)))) 
    24822639                   (or (probe-file (append-directories *central-registry* 
    24832640                                                       file-pathname)) 
     
    24972654  (let ((system (ignore-errors (find-system system-name :error)))) 
    24982655    (if system 
    24992656        (let ((system-def-pathname 
    2500                (make-pathname :type "system" 
    2501                               :defaults (pathname (component-full-pathname system :source)))) 
     2657               (make-pathname 
     2658                :type "system" 
     2659                :defaults (pathname (component-full-pathname system :source)))) 
    25022660              ) 
    25032661          (values system-def-pathname 
    25042662                  (probe-file system-def-pathname))) 
    25052663        (values nil nil)))) 
    2506           
    2507           
    25082664 
    25092665 
     2666 
     2667 
    25102668#| 
    25112669 
    2512 (defun compute-system-path (module-name definition-pname) 
     2670 (defun compute-system-path (module-name definition-pname) 
    25132671  (let* ((filename (format nil "~A.~A" 
    25142672                           (if (symbolp module-name) 
    25152673                               (string-downcase (string module-name)) 
     
    25232681               (if (listp *central-registry*) 
    25242682                   (dolist (registry *central-registry*) 
    25252683                     (let ((file (probe-file 
    2526                                   (append-directories (if (consp registry) 
    2527                                                           (eval registry) 
    2528                                                         registry) 
    2529                                                       filename)))) 
     2684                                  (append-directories 
     2685                                   (registry-pathname registry) filename)))) 
    25302686                       (when file (return file)))) 
    25312687                 (probe-file (append-directories *central-registry* 
    25322688                                                 filename)))) 
     
    25632719         (error 'missing-system :name system-name))) 
    25642720    (:load-or-nil 
    25652721     (let ((system (get-system system-name))) 
     2722       ;; (break "System ~S ~S." system-name system) 
    25662723       (or (unless *reload-systems-from-disk* system) 
    25672724           ;; If SYSTEM-NAME is a symbol, it will lowercase the 
    25682725           ;; symbol's string. 
     
    25702727           ;; string. So if case matters in the filename, use strings, not 
    25712728           ;; symbols, wherever the system is named. 
    25722729           (when (foreign-system-p system) 
    2573              (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM." system) 
     2730             (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM." 
     2731                   system) 
    25742732             (return-from find-system nil)) 
    25752733           (let ((path (compute-system-path system-name definition-pname))) 
    25762734             (when (and path 
     
    25922750    (:load 
    25932751     (or (unless *reload-systems-from-disk* (get-system system-name)) 
    25942752         (when (foreign-system-p (get-system system-name)) 
    2595            (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM." system-name) 
     2753           (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM." 
     2754                 (get-system system-name)) 
    25962755           (return-from find-system nil)) 
    25972756         (or (find-system system-name :load-or-nil definition-pname) 
    25982757             (error "Can't find system named ~s." system-name)))))) 
     
    26162775                    ~@[~&   Package: ~A~]~ 
    26172776                    ~&   Source: ~@[~A~] ~@[~A~] ~@[~A~]~ 
    26182777                    ~&   Binary: ~@[~A~] ~@[~A~] ~@[~A~]~ 
    2619                     ~@[~&   Depends On: ~A ~]~&   Components: ~{~15T~A~&~}" 
     2778                    ~@[~&   Depends On: ~A ~]~&   Components:~{~15T~A~&~}" 
    26202779            (component-type system) 
    26212780            (component-name system) 
    26222781            (component-host system) 
     
    26352794        (describe-system component stream recursive)))||# 
    26362795    system)) 
    26372796 
     2797 
    26382798(defun canonicalize-component-name (component) 
    26392799  ;; Within the component, the name is a string. 
    26402800  (if (typep (component-name component) 'string) 
     
    26462806    (setf (component-name component) 
    26472807          (string-downcase (string (component-name component)))))) 
    26482808 
     2809 
    26492810(defun component-pathname (component type) 
    26502811  (when component 
    26512812    (ecase type 
    26522813      (:source (component-source-pathname component)) 
    26532814      (:binary (component-binary-pathname component)) 
    26542815      (:error  (component-error-pathname component))))) 
     2816 
     2817 
    26552818(defun component-error-pathname (component) 
    26562819  (let ((binary (component-pathname component :binary))) 
    26572820    (new-file-type binary *compile-error-file-type*))) 
     2821 
    26582822(defsetf component-pathname (component type) (value) 
    26592823  `(when ,component 
    26602824     (ecase ,type 
    26612825       (:source (setf (component-source-pathname ,component) ,value)) 
    26622826       (:binary (setf (component-binary-pathname ,component) ,value))))) 
    26632827 
     2828 
    26642829(defun component-root-dir (component type) 
    26652830  (when component 
    26662831    (ecase type 
    26672832      (:source (component-source-root-dir component)) 
    26682833      ((:binary :error) (component-binary-root-dir component)) 
    26692834      ))) 
     2835 
    26702836(defsetf component-root-dir (component type) (value) 
    26712837  `(when ,component 
    26722838     (ecase ,type 
    26732839       (:source (setf (component-source-root-dir ,component) ,value)) 
    26742840       (:binary (setf (component-binary-root-dir ,component) ,value))))) 
    26752841 
     2842 
    26762843(defvar *source-pathnames-table* (make-hash-table :test #'equal) 
    26772844  "Table which maps from components to full source pathnames.") 
     2845 
     2846 
    26782847(defvar *binary-pathnames-table* (make-hash-table :test #'equal) 
    26792848  "Table which maps from components to full binary pathnames.") 
     2849 
     2850 
    26802851(defparameter *reset-full-pathname-table* t 
    2681   "If T, clears the full-pathname tables before each call to 
    2682    OPERATE-ON-SYSTEM. Setting this to NIL may yield faster performance 
    2683    after multiple calls to LOAD-SYSTEM and COMPILE-SYSTEM, but could 
    2684    result in changes to system and language definitions to not take 
    2685    effect, and so should be used with caution.") 
     2852  "If T, clears the full-pathname tables before each call to OPERATE-ON-SYSTEM. 
     2853Setting this to NIL may yield faster performance after multiple calls 
     2854to LOAD-SYSTEM and COMPILE-SYSTEM, but could result in changes to 
     2855system and language definitions to not take effect, and so should be 
     2856used with caution.") 
     2857 
     2858 
    26862859(defun clear-full-pathname-tables () 
    26872860  (clrhash *source-pathnames-table*) 
    26882861  (clrhash *binary-pathnames-table*)) 
    26892862 
     2863 
    26902864(defun component-full-pathname (component type &optional (version *version*)) 
    26912865  (when component 
    26922866    (case type 
     
    27052879      (otherwise 
    27062880       (component-full-pathname-i component type version))))) 
    27072881 
    2708 (defun component-full-pathname-i (component type &optional (version *version*) 
     2882 
     2883(defun component-full-pathname-i (component type 
     2884                                            &optional (version *version*) 
    27092885                                            &aux version-dir version-replace) 
    27102886  ;; If the pathname-type is :binary and the root pathname is null, 
    27112887  ;; distribute the binaries among the sources (= use :source pathname). 
     
    27152891      (multiple-value-setq (version-dir version-replace) 
    27162892        (translate-version version)) 
    27172893      (setq version-dir *version-dir* version-replace *version-replace*)) 
     2894  ;; (format *trace-output* "~&>>>> VERSION COMPUTED ~S ~S~%" version-dir version-replace) 
    27182895  (let ((pathname 
    27192896         (append-directories 
    27202897          (if version-replace 
     
    27402917    ;; :name argument to the MAKE-PATHNAME in the MERGE-PATHNAMES 
    27412918    ;; beacuse of possible null names (e.g. :defsystem components) 
    27422919    ;; causing problems with the subsequenct call to NAMESTRING. 
     2920    ;; (format *trace-output* "~&>>>> PATHNAME is ~S~%" pathname) 
     2921 
     2922    ;; 20050309 Marco Antoniotti 
     2923    ;; The treatment of PATHNAME-HOST and PATHNAME-DEVICE in the call 
     2924    ;; to MAKE-PATHNAME in the T branch is bogus.   COMPONENT-DEVICE 
     2925    ;; and COMPONENT-HOST must respect the ANSI definition, hence, 
     2926    ;; they cannot be PATHNAMEs.  The simplification of the code is 
     2927    ;; useful.  SCL compatibility may be broken, but I doubt it will. 
     2928 
     2929    ;; 20050310 Marco Antoniotti 
     2930    ;; After a suggestion by David Tolpin, the code is simplified even 
     2931    ;; more, and the logic should be now more clear: use the user 
     2932    ;; supplied pieces of the pathname if non nil. 
     2933 
     2934    ;; 20050613 Marco Antoniotti 
     2935    ;; Added COMPONENT-NAME extraction to :NAME part, in case the 
     2936    ;; PATHNAME-NAME is NIL. 
     2937 
    27432938    (cond ((pathname-logical-p pathname) ; See definition of test above. 
    27442939           (setf pathname 
    27452940                 (merge-pathnames pathname 
     
    27472942                                   :name (component-name component) 
    27482943                                   :type (component-extension component 
    27492944                                                              type)))) 
    2750            ;;(format t "new path = ~A~%" pathname) 
    27512945           (namestring (translate-logical-pathname pathname))) 
    27522946          (t 
    27532947           (namestring 
    2754             (make-pathname :host (when (component-host component) 
    2755                                    ;; MCL2.0b1 and ACLPC cause an error on 
    2756                                    ;; (pathname-host nil) 
    2757                                    (pathname-host (component-host component) 
    2758                                                   #+scl :case #+scl :common 
    2759                                                   )) 
     2948            (make-pathname :host (or (component-host component) 
     2949                                     (pathname-host pathname)) 
     2950 
    27602951                           :directory (pathname-directory pathname 
    2761                                                   #+scl :case #+scl :common 
    2762                                                   ) 
    2763                            ;; Use :directory instead of :defaults 
    2764                            :name (pathname-name pathname 
    2765                                                   #+scl :case #+scl :common 
    2766                                                   ) 
    2767                            :type #-scl (component-extension component type) 
    2768                                  #+scl (string-upcase 
    2769                                         (component-extension component type)) 
     2952                                                          #+scl :case 
     2953                                                          #+scl :common 
     2954                                                          ) 
     2955 
     2956                           :name (or (pathname-name pathname 
     2957                                                    #+scl :case 
     2958                                                    #+scl :common 
     2959                                                    ) 
     2960                                     (component-name component)) 
     2961 
     2962                           :type 
     2963                           #-scl (component-extension component type) 
     2964                           #+scl (string-upcase 
     2965                                  (component-extension component type)) 
     2966 
    27702967                           :device 
    27712968                           #+sbcl 
    27722969                           :unspecific 
    27732970                           #-(or :sbcl) 
    2774                            (let ((dev (component-device component))) 
    2775                              (if dev 
    2776                                  (pathname-device dev 
    2777                                                   #+scl :case #+scl :common 
    2778                                                   ) 
    2779                                  (pathname-device pathname 
    2780                                                   #+scl :case #+scl :common 
    2781                                                   ))) 
     2971                           (or (component-device component) 
     2972                               (pathname-device pathname 
     2973                                                #+scl :case 
     2974                                                #+scl :common 
     2975                                                )) 
    27822976                           ;; :version :newest 
    27832977                           )))))) 
    27842978 
    2785 ;;; What about CMU17 :device :unspecific in the above? 
    27862979 
     2980#-lispworks 
    27872981(defun translate-version (version) 
    27882982  ;; Value returns the version directory and whether it replaces 
    27892983  ;; the entire root (t) or is a subdirectory. 
     
    28032997         (values version t)) 
    28042998        (t (error "~&; Illegal version ~S" version)))) 
    28052999 
     3000 
     3001;;; Looks like LW has a bug in MERGE-PATHNAMES. 
     3002;;; 
     3003;;;  (merge-pathnames "" "LP:foo;bar;") ==> "LP:" 
     3004;;; 
     3005;;; Which is incorrect. 
     3006;;; The change here ensures that the result of TRANSLATE-VERSION is 
     3007;;; appropriate. 
     3008 
     3009#+lispworks 
     3010(defun translate-version (version) 
     3011  ;; Value returns the version directory and whether it replaces 
     3012  ;; the entire root (t) or is a subdirectory. 
     3013  ;; Version may be nil to signify no subdirectory, 
     3014  ;; a symbol, such as alpha, beta, omega, :alpha, mark, which 
     3015  ;; specifies a subdirectory of the root, or 
     3016  ;; a string, which replaces the root. 
     3017  (cond ((null version) 
     3018         (values (pathname "") nil)) 
     3019        ((symbolp version) 
     3020         (values (let ((sversion (string version))) 
     3021                   (if (find-if #'lower-case-p sversion) 
     3022                       (pathname sversion) 
     3023                       (pathname (string-downcase sversion)))) 
     3024                 nil)) 
     3025        ((stringp version) 
     3026         (values (pathname version) t)) 
     3027        (t (error "~&; Illegal version ~S" version)))) 
     3028 
     3029 
    28063030(defun component-extension (component type &key local) 
    28073031  (ecase type 
    28083032    (:source (or (component-source-extension component) 
    28093033                 (unless local 
    2810                    (default-source-extension component)))) ; system default 
     3034                   (default-source-extension component)) ; system default 
     3035                 ;; (and (component-language component)) 
     3036                 )) 
    28113037    (:binary (or (component-binary-extension component) 
    28123038                 (unless local 
    2813                    (default-binary-extension component)))) ; system default 
     3039                   (default-binary-extension component)) ; system default 
     3040                 ;; (and (component-language component)) 
     3041                 )) 
    28143042    (:error  *compile-error-file-type*))) 
     3043 
     3044 
    28153045(defsetf component-extension (component type) (value) 
    28163046  `(ecase ,type 
    28173047     (:source (setf (component-source-extension ,component) ,value)) 
    28183048     (:binary (setf (component-binary-extension ,component) ,value)) 
    28193049     (:error  (setf *compile-error-file-type* ,value)))) 
    28203050 
     3051 
    28213052;;; ******************************** 
    28223053;;; System Definition ************** 
    28233054;;; ******************************** 
     3055 
    28243056(defun create-component (type name definition-body &optional parent (indent 0)) 
    28253057  (let ((component (apply #'make-component 
    28263058                          :type type 
    28273059                          :name name 
    2828                           :indent indent definition-body))) 
     3060                          :indent indent 
     3061                          definition-body))) 
    28293062    ;; Set up :load-only attribute 
    28303063    (unless (find :load-only definition-body) 
    28313064      ;; If the :load-only attribute wasn't specified, 
     
    28683101 
    28693102    ;; Type specific setup: 
    28703103    (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem)) 
    2871       (setf (get-system name) component)) 
     3104      (setf (get-system name) component) 
     3105      #|(unless (component-language component) 
     3106        (setf (component-language component) :lisp))|#) 
    28723107 
    28733108    ;; Set up the component's pathname 
    28743109    (create-component-pathnames component parent) 
     
    28913126    component)) 
    28923127 
    28933128 
     3129;;; preprocess-component-definition -- 
     3130;;; New function introduced to manipulate the "evaluated" slots as per 
     3131;;; SDS' suggestions. 
     3132;;; 20050824 
     3133 
     3134(defun preprocess-component-definition (definition-body) 
     3135  `(list* ,@(loop for slot in *component-evaluated-slots* 
     3136                  for value = (getf definition-body slot) 
     3137                  when value 
     3138                    do (remf definition-body slot) 
     3139                    and nconc `(,slot ,value)) 
     3140          ,@(loop for slot in *component-form-slots* 
     3141                  for form = (getf definition-body slot) 
     3142                  do (remf definition-body slot) 
     3143                  nconc `(,slot (lambda () ,form))) 
     3144          ',definition-body)) 
     3145 
     3146 
    28943147;;; defsystem -- 
    28953148;;; The main macro. 
    28963149;;; 
     
    29053158  (unless (find :source-pathname definition-body) 
    29063159    (setf definition-body 
    29073160          (list* :source-pathname 
    2908                  '(when *load-pathname* 
    2909                         (make-pathname :name nil 
    2910                                        :type nil 
    2911                                        :defaults *load-pathname*)) 
     3161                 '(when #-gcl *load-pathname* #+gcl si::*load-pathname* 
     3162                    (make-pathname :name nil 
     3163                                   :type nil 
     3164                                   :defaults 
     3165                                   #-gcl *load-pathname* 
     3166                                   #+gcl si::*load-pathname* 
     3167                                   )) 
    29123168                 definition-body))) 
    2913   `(create-component :defsystem ',name ',definition-body nil 0)) 
     3169  `(create-component :defsystem ',name 
     3170                     ,(preprocess-component-definition definition-body) 
     3171                     nil 
     3172                     0)) 
    29143173 
     3174 
    29153175(defun create-component-pathnames (component parent) 
    29163176  ;; Set up language-specific defaults 
     3177 
    29173178  (setf (component-language component) 
    29183179        (or (component-language component) ; for local defaulting 
    29193180            (when parent                ; parent's default 
    29203181              (component-language parent)))) 
     3182 
    29213183  (setf (component-compiler component) 
    29223184        (or (component-compiler component) ; for local defaulting 
    29233185            (when parent                ; parent's default 
     
    29393201  (setf (component-pathname component :binary) 
    29403202        (eval (component-pathname component :binary))) 
    29413203 
     3204 
    29423205  ;; Pass along the host and devices 
    29433206  (setf (component-host component) 
    29443207        (or (component-host component) 
    2945             (when parent (component-host parent)))) 
     3208            (when parent (component-host parent)) 
     3209            (pathname-host *default-pathname-defaults*))) 
    29463210  (setf (component-device component) 
    29473211        (or (component-device component) 
    29483212            (when parent (component-device parent)))) 
    29493213 
    29503214  ;; Set up extension defaults 
    29513215  (setf (component-extension component :source) 
    2952         (or (component-extension component :source :local t) ; local default 
     3216        (or (component-extension component :source 
     3217                                 :local #| (component-language component) |# 
     3218                                 t 
     3219                                 ) ; local default 
     3220            (when (component-language component) 
     3221              (default-source-extension component)) 
    29533222            (when parent                ; parent's default 
    29543223              (component-extension parent :source)))) 
    29553224  (setf (component-extension component :binary) 
    2956         (or (component-extension component :binary  :local t) ; local default 
     3225        (or (component-extension component :binary 
     3226                                 :local #| (component-language component) |# 
     3227                                 t 
     3228                                 ) ; local default 
     3229            (when (component-language component) 
     3230              (default-binary-extension component)) 
    29573231            (when parent                ; parent's default 
    29583232              (component-extension parent :binary)))) 
    29593233 
     
    29633237  (generate-component-pathname component parent :source) 
    29643238  (generate-component-pathname component parent :binary)) 
    29653239 
    2966 ;; maybe file's inheriting of pathnames should be moved elsewhere? 
     3240 
     3241;;; generate-component-pathnames -- 
     3242;;; maybe file's inheriting of pathnames should be moved elsewhere? 
     3243 
    29673244(defun generate-component-pathname (component parent pathname-type) 
    29683245  ;; Pieces together a pathname for the component based on its component-type. 
    29693246  ;; Assumes source defined first. 
     
    30103287                 ;; When the binary-pathname is nil use source. 
    30113288                 (component-pathname component :source)) 
    30123289               (or (when (component-pathname component pathname-type) 
    3013 ;                    (pathname-name ) 
     3290                     ;; (pathname-name ) 
    30143291                     (component-pathname component pathname-type)) 
    30153292                   (component-name component))))) 
    30163293    ((:module :subsystem)                       ; Pathname relative to parent. 
     
    30593336                                                              indent)) 
    30603337                             definitions))))) 
    30613338||# 
    3062 ;; new version 
     3339 
     3340;;; new version 
    30633341(defun expand-component-components (component &optional (indent 0)) 
    30643342  (let ((definitions (component-components component))) 
    30653343    (if (eq (car definitions) :serial) 
     
    30693347        (setf (component-components component) 
    30703348              (expand-component-definitions definitions component indent))))) 
    30713349 
     3350 
    30723351(defun expand-component-definitions (definitions parent &optional (indent 0)) 
    30733352  (let ((components nil)) 
    30743353    (dolist (definition definitions) 
     
    30763355        (when new (push new components)))) 
    30773356    (nreverse components))) 
    30783357 
     3358 
    30793359(defun expand-serial-component-chain (definitions parent &optional (indent 0)) 
    30803360  (let ((previous nil) 
    30813361        (components nil)) 
     
    31013381   recognizes absolute pathnames and treats them as files of type 
    31023382   :private-file instead of type :file. Defaults to NIL, because I 
    31033383   haven't tested this.") 
     3384 
     3385 
    31043386(defun absolute-file-namestring-p (string) 
    31053387  ;; If a FILE namestring starts with a slash, or is a logical pathname 
    31063388  ;; as implied by the existence of a colon in the filename, assume it 
     
    31093391      (and (not (null-string string)) 
    31103392           (char= (char string 0) #\/)))) 
    31113393 
     3394 
    31123395(defun expand-component-definition (definition parent &optional (indent 0)) 
    31133396  ;; Should do some checking for malformed definitions here. 
    31143397  (cond ((null definition) nil) 
     
    31183401                  (absolute-file-namestring-p definition)) 
    31193402             ;; Special hack for Straz 
    31203403             (create-component :private-file definition nil parent indent) 
    3121            ;; Normal behavior 
    3122            (create-component :file definition nil parent indent))) 
     3404             ;; Normal behavior 
     3405             (create-component :file definition nil parent indent))) 
    31233406        ((and (listp definition) 
    31243407              (not (member (car definition) 
    31253408                           '(:defsystem :system :subsystem 
    3126                              :module :file :private-file)))) 
     3409                              :module :file :private-file)))) 
    31273410         ;; Lists whose first element is not a component type 
    31283411         ;; are assumed to be of type :file 
    31293412         (create-component :file 
    3130                            (car definition) 
    3131                            (cdr definition) 
     3413                           (first definition) 
     3414                           ;; (preprocess-component-definition (rest definition)) ; Not working. 
     3415                           (rest definition) 
    31323416                           parent 
    31333417                           indent)) 
    31343418        ((listp definition) 
    31353419         ;; Otherwise, it is (we hope) a normal form definition 
    3136          (create-component (car definition)   ; type 
    3137                            (cadr definition)  ; name 
    3138                            (cddr definition)  ; definition body 
     3420         (create-component (first definition)   ; type 
     3421                           (second definition)  ; name 
     3422 
     3423                           ;; definition body 
     3424                           ;; (preprocess-component-definition (cddr definition)) ; Not working. 
     3425                           (cddr definition) 
     3426 
    31393427                           parent             ; parent 
    31403428                           indent)            ; indent 
    31413429         ))) 
    31423430 
     3431 
    31433432(defun link-component-depends-on (components) 
    31443433  (dolist (component components) 
    31453434    (unless (and *system-dependencies-delayed* 
     
    31563445 
    31573446                    (component-depends-on component)))))) 
    31583447 
     3448 
    31593449;;; ******************************** 
    31603450;;; Topological Sort the Graph ***** 
    31613451;;; ******************************** 
     
    31643454;;; this version avoids the call to sort, in practice it isn't faster. It 
    31653455;;; does, however, eliminate the need to have a TIME slot in the 
    31663456;;; topological-sort-node defstruct. 
     3457 
    31673458(defun topological-sort (list &aux (sorted-list nil)) 
    31683459  (labels ((dfs-visit (znode) 
    3169               (setf (topsort-color znode) :gray) 
    3170               (unless (and *system-dependencies-delayed* 
    3171                            (eq (component-type znode) :system)) 
    3172                 (dolist (child (component-depends-on znode)) 
    3173                   (cond ((eq (topsort-color child) :white) 
    3174                         (dfs-visit child)) 
    3175                         ((eq (topsort-color child) :gray) 
    3176                         (format t "~&Detected cycle containing ~A" child))))) 
    3177               (setf (topsort-color znode) :black) 
    3178               (push znode sorted-list))) 
     3460             (setf (topsort-color znode) :gray) 
     3461             (unless (and *system-dependencies-delayed* 
     3462                          (eq (component-type znode) :system)) 
     3463               (dolist (child (component-depends-on znode)) 
     3464                 (cond ((eq (topsort-color child) :white) 
     3465                        (dfs-visit child)) 
     3466                       ((eq (topsort-color child) :gray) 
     3467                        (format t "~&Detected cycle containing ~A" child))))) 
     3468             (setf (topsort-color znode) :black) 
     3469             (push znode sorted-list))) 
    31793470    (dolist (znode list) 
    31803471      (setf (topsort-color znode) :white)) 
    31813472    (dolist (znode list) 
     
    32303521;; probably should remove the ",1" entirely. But AKCL 1.243 dies on it 
    32313522;; because of an AKCL bug. 
    32323523;; KGK suggests using an 8 instead, but 1 does nicely. 
     3524 
    32333525(defun prompt-string (component) 
    32343526  (format nil "; ~:[~;TEST:~]~V,1@T " 
    32353527          *oos-test* 
     
    32653557                    (format stream "~%~A  ~A" prompt content))))))) 
    32663558  (finish-output stream)) 
    32673559 
     3560 
    32683561(defun tell-user (what component &optional type no-dots force) 
    32693562  (when (or *oos-verbose* force) 
    32703563    (format-justified-string (prompt-string component) 
     
    32943587             (and *tell-user-when-done* 
    32953588                  (not no-dots)))))) 
    32963589 
     3590 
    32973591(defun tell-user-done (component &optional force no-dots) 
    32983592  ;; test is no longer really used, but we're leaving it in. 
    32993593  (when (and *tell-user-when-done* 
     
    33023596            (prompt-string component) (not no-dots)) 
    33033597    (finish-output *standard-output*))) 
    33043598 
     3599 
    33053600(defmacro with-tell-user ((what component &optional type no-dots force) &body body) 
    33063601  `(progn 
    33073602     (tell-user ,what ,component ,type ,no-dots ,force) 
    33083603     ,@body 
    33093604     (tell-user-done ,component ,force ,no-dots))) 
    33103605 
     3606 
    33113607(defun tell-user-no-files (component &optional force) 
    33123608  (when (or *oos-verbose* force) 
    33133609    (format-justified-string (prompt-string component) 
     
    33173613              (or *load-source-if-no-binary* *load-source-instead-of-binary*) 
    33183614              (component-full-pathname component :binary))))) 
    33193615 
     3616 
    33203617(defun tell-user-require-system (name parent) 
    33213618  (when *oos-verbose* 
    33223619    (format t "~&; ~:[~;TEST:~] - System ~A requires ~S" 
    33233620            *oos-test* (component-name parent) name) 
    33243621    (finish-output *standard-output*))) 
    33253622 
     3623 
    33263624(defun tell-user-generic (string) 
    33273625  (when *oos-verbose* 
    33283626    (format t "~&; ~:[~;TEST:~] - ~A" 
    33293627            *oos-test* string) 
    33303628    (finish-output *standard-output*))) 
    33313629 
     3630 
    33323631;;; ******************************** 
    33333632;;; Y-OR-N-P-WAIT ****************** 
    33343633;;; ******************************** 
     
    33533652     Lisps, this allows other processes to continue while we busy-wait. If 
    33543653     0, skips call to SLEEP.") 
    33553654 
     3655 
    33563656(defun internal-real-time-in-seconds () 
    33573657  (get-universal-time)) 
    33583658 
     3659 
    33593660(defun read-char-wait (&optional (timeout 20) input-stream 
    33603661                                 (eof-error-p t) eof-value 
    33613662                                 &aux peek) 
     
    33683669    (unless (zerop *sleep-amount*) 
    33693670      (sleep *sleep-amount*)))) 
    33703671 
     3672 
    33713673;;; Lots of lisps, especially those that run on top of UNIX, do not get 
    33723674;;; their input one character at a time, but a whole line at a time because 
    33733675;;; of the buffering done by the UNIX system. This causes y-or-n-p-wait 
     
    34223724       (y-or-n-p-wait #\y 10 "1? ") 
    34233725       (y-or-n-p-wait #\n 10 "2? ")) 
    34243726||# 
     3727 
     3728;;;=========================================================================== 
     3729;;; Running the operations. 
     3730 
     3731(defvar %%component%% nil) 
     3732 
     3733(export '(%%component%%)) ; Just a placeholder. Move it to the export list. 
     3734 
     3735 
     3736(defmacro with-special-component-vars ((c) &body forms) 
     3737  `(let ((%%component%% ,c)) 
     3738    (declare (special %%component%%)) 
     3739    ,@forms)) 
     3740 
     3741 
    34253742;;; ******************************** 
    34263743;;; Operate on System ************** 
    34273744;;; ******************************** 
     
    34663783  (declare #-(or :cltl2 :ansi-cl) (ignore override-compilation-unit)) 
    34673784  (unwind-protect 
    34683785      ;; Protect the undribble. 
    3469       (#+(or :cltl2 :ansi-cl) with-compilation-unit 
    3470          #+(or :cltl2 :ansi-cl) (:override override-compilation-unit) 
    3471          #-(or :cltl2 :ansi-cl) progn 
     3786      (#+(and (or :cltl2 :ansi-cl) (not :gcl)) with-compilation-unit 
     3787         #+(and (or :cltl2 :ansi-cl) (not :gcl)) (:override override-compilation-unit) 
     3788         #-(and (or :cltl2 :ansi-cl) (not :gcl)) progn 
    34723789        (when *reset-full-pathname-table* (clear-full-pathname-tables)) 
    34733790        (when dribble (dribble dribble)) 
    34743791        (when test (setq verbose t)) 
     
    35063823                (*load-source-instead-of-binary* load-source-instead-of-binary) 
    35073824                (*minimal-load* minimal-load) 
    35083825                (system (if (and (component-p name) 
    3509                                  (member (component-type name) '(:system :defsystem :subsystem))) 
     3826                                 (member (component-type name) 
     3827                                         '(:system :defsystem :subsystem))) 
    35103828                            name 
    35113829                            (find-system name :load)))) 
    35123830            #-(or CMU CLISP :sbcl :lispworks :cormanlisp scl) 
     
    35163834                     #-openmcl (optimize (inhibit-warnings 3))) 
    35173835            (unless (component-operation operation) 
    35183836              (error "Operation ~A undefined." operation)) 
     3837 
    35193838            (operate-on-component system operation force)))) 
    35203839    (when dribble (dribble)))) 
    35213840 
     
    36143933   :verbose verbose 
    36153934   :dribble dribble)) 
    36163935 
     3936 
     3937;;; ensure-external-system-def-loaded component -- 
     3938;;; Let's treat definition clauses of the form 
     3939;;; 
     3940;;;     (:system "name") 
     3941;;; i.e. 
     3942;;; 
     3943;;;     (:system "name" :components nil) 
     3944;;; 
     3945;;; in a special way. 
     3946;;; When encountered, MK:DEFSYSTEM tries to FIND-SYSTEM 
     3947;;; the system named "name" (by forcing a reload from disk). 
     3948;;; This may be more "natural". 
     3949 
     3950(defun ensure-external-system-def-loaded (component) 
     3951  (assert (member (component-type component) 
     3952                  '(:subsystem :system))) 
     3953  (when (null (component-components component)) 
     3954    (let* ((cname (component-name component))) 
     3955      (declare (ignorable cname)) 
     3956      ;; First we ensure that we reload the system definition. 
     3957      (undefsystem cname) 
     3958      (let* ((*reload-systems-from-disk* t) 
     3959             (system-component 
     3960              (find-system (component-name component) 
     3961                           :load 
     3962 
     3963                           ;; Let's not supply the def-pname 
     3964                           ;; yet. 
     3965                           #+not-yet 
     3966                           (merge-pathname 
     3967                            (make-pathname :name cname 
     3968                                           :type "system" 
     3969                                           :directory ()) 
     3970                            (component-full-pathname component 
     3971                                                     :source)) 
     3972 
     3973 
     3974                           )) 
     3975             ) 
     3976        ;; Now we have a problem. 
     3977        ;; We have just ensured that a system definition is 
     3978        ;; loaded, however, the COMPONENT at hand is different 
     3979        ;; from SYSTEM-COMPONENT. 
     3980        ;; To fix this problem we just use the following 
     3981        ;; kludge.  This should prevent re-entering in this 
     3982        ;; code branch, while actually preparing the COMPONENT 
     3983        ;; for operation. 
     3984        (setf (component-components component) 
     3985              (list system-component)) 
     3986        )))) 
     3987 
     3988 
    36173989(defun operate-on-component (component operation force &aux changed) 
    36183990  ;; Returns T if something changed and had to be compiled. 
    36193991  (let ((type (component-type component)) 
     
    36464018              (let ((package (find-package (component-package component)))) 
    36474019                (when package 
    36484020                  (setf *package* package))))) 
    3649           #+mk-original 
    3650           (when (eq type :defsystem)    ; maybe :system too? 
    3651             (operate-on-system-dependencies component operation force)) 
     4021 
     4022          ;; Marco Antoniotti 20040609 
     4023          ;; New feature.  Try to FIND-SYSTEM :system components if 
     4024          ;; they have no local :components definition. 
     4025          ;; OPERATE-ON-SYSTEM-DEPENDENCIES should still work as 
     4026          ;; advertised, given the small change made there. 
     4027 
     4028          (when (or (eq type :system) (eq type :subsystem)) 
     4029            (ensure-external-system-def-loaded component)) 
     4030 
    36524031          (when (or (eq type :defsystem) (eq type :system)) 
    36534032            (operate-on-system-dependencies component operation force)) 
    36544033 
     
    36564035          (when (component-proclamations component) 
    36574036            (tell-user-generic (format nil "Doing proclamations for ~A" 
    36584037                                       (component-name component))) 
    3659             (or *oos-test* 
    3660                 (proclaim (component-proclamations component)))) 
     4038            (unless *oos-test* 
     4039              (proclaim (component-proclamations component)))) 
    36614040 
    36624041          ;; Do any initial actions 
    36634042          (when (component-initially-do component) 
    36644043            (tell-user-generic (format nil "Doing initializations for ~A" 
    36654044                                       (component-name component))) 
    3666             (or *oos-test* 
    3667                 (eval (component-initially-do component)))) 
     4045            (unless *oos-test* 
     4046              (with-special-component-vars (component) 
     4047                 (let ((initially-do (component-initially-do component))) 
     4048                   (if (functionp initially-do) 
     4049                       (funcall initially-do) 
     4050                       (eval initially-do)))) 
     4051              )) 
    36684052 
    36694053          ;; If operation is :compile and load-only is T, this would change 
    36704054          ;; the operation to load. Only, this would mean that a module would 
     
    36924076          (when (component-finally-do component) 
    36934077            (tell-user-generic (format nil "Doing finalizations for ~A" 
    36944078                                       (component-name component))) 
    3695             (or *oos-test* 
    3696                 (eval (component-finally-do component)))) 
     4079            (unless *oos-test* 
     4080              (with-special-component-vars (component) 
     4081                 (let ((finally-do (component-finally-do component))) 
     4082                   (if (functionp finally-do) 
     4083                       (funcall finally-do) 
     4084                       (eval finally-do)))) 
     4085                )) 
    36974086 
    36984087          ;; add the banner if needed 
    36994088          #+(or cmu scl) 
     
    37374126        ;; to load it (needed since we may be depending on a lisp 
    37384127        ;; dependent package). 
    37394128        ;; Explores the system tree in a DFS manner. 
    3740         (cond ((and *operations-propagate-to-subsystems* 
    3741                     (not (listp system)) 
    3742                     ;; The subsystem is a defined system. 
    3743                     (find-system system :load-or-nil)) 
    3744                ;; Call OOS on it. Since *system-dependencies-delayed* is 
    3745                ;; T, the :depends-on slot is filled with the names of 
    3746                ;; systems, not defstructs. 
    3747                ;; Aside from system, operation, force, for everything else 
    3748                ;; we rely on the globals. 
    3749                (unless (and *providing-blocks-load-propagation* 
    3750                             ;; If *providing-blocks-load-propagation* is T, 
    3751                             ;; the system dependency must not exist in the 
    3752                             ;; *modules* for it to be loaded. Note that 
    3753                             ;; the dependencies are implicitly systems. 
    3754                             (find operation '(load :load)) 
    3755                             ;; (or (eq force :all) (eq force t)) 
    3756                             (find (canonicalize-system-name system) 
    3757                                   *modules* :test #'string-equal)) 
    3758                   
    3759                  (operate-on-system system operation :force force))) 
    37604129 
    3761               ((listp system) 
     4130        ;; Do not try to do anything with non system components. 
     4131        (cond ((and *operations-propagate-to-subsystems* 
     4132                    (not (listp system)) 
     4133                    (or (stringp system) (symbolp system)) 
     4134                    ;; The subsystem is a defined system. 
     4135                    (find-system system :load-or-nil)) 
     4136               ;; Call OOS on it. Since *system-dependencies-delayed* is 
     4137               ;; T, the :depends-on slot is filled with the names of 
     4138               ;; systems, not defstructs. 
     4139               ;; Aside from system, operation, force, for everything else 
     4140               ;; we rely on the globals. 
     4141               (unless (and *providing-blocks-load-propagation* 
     4142                            ;; If *providing-blocks-load-propagation* is T, 
     4143                            ;; the system dependency must not exist in the 
     4144                            ;; *modules* for it to be loaded. Note that 
     4145                            ;; the dependencies are implicitly systems. 
     4146                            (find operation '(load :load)) 
     4147                            ;; (or (eq force :all) (eq force t)) 
     4148                            (find (canonicalize-system-name system) 
     4149                                  *modules* :test #'string-equal)) 
     4150 
     4151                 (operate-on-system system operation :force force))) 
     4152 
     4153              ((listp system) 
    37624154               ;; If the SYSTEM is a list then its contents are as follows. 
    37634155               ;; 
    3764                ;;    (<name> <definition-pathname> <action> <version>) 
     4156               ;;    (<name> <definition-pathname> <action> &optional <version>) 
    37654157               ;; 
    3766                (tell-user-require-system 
    3767                 (cond ((and (null (first system)) (null (second system))) 
    3768                        (third system)) 
    3769                       (t system)) 
    3770                 component) 
    3771                (or *oos-test* (new-require (first system) 
    3772                                            nil 
    3773                                            (eval (second system)) 
    3774                                            (third system) 
    3775                                            (or (fourth system) 
    3776                                                *version*)))) 
    3777               (t 
    3778                (tell-user-require-system system component) 
    3779                (or *oos-test* (new-require system)))))))) 
    37804158 
     4159               (destructuring-bind (system-name definition-pathname action 
     4160                                                &optional version) 
     4161                   system 
     4162                 (tell-user-require-system 
     4163                  (if (and (null system-name) 
     4164                           (null definition-pathname)) 
     4165                      action 
     4166                      system) 
     4167                  component) 
     4168                 (or *oos-test* (new-require system-name 
     4169                                             nil 
     4170                                             (eval definition-pathname) 
     4171                                             action 
     4172                                             (or version *version*))))) 
     4173              ((and (component-p system) 
     4174                    (not (member (component-type system) 
     4175                                 '(:defsystem :subsystem :system)))) 
     4176               ;; Do nothing for non system components. 
     4177               ) 
     4178              (t 
     4179               (tell-user-require-system system component) 
     4180               (or *oos-test* (new-require system)))) 
     4181        )))) 
     4182 
    37814183;;; Modules can depend only on siblings. If a module should depend 
    37824184;;; on an uncle, then the parent module should depend on that uncle 
    37834185;;; instead. Likewise a module should depend on a sibling, not a niece 
     
    38154217            (push module changed))) 
    38164218        (case operation 
    38174219          ((compile :compile) 
    3818            (eval (component-compile-form component))) 
     4220           (with-special-component-vars (component) 
     4221             (let ((compile-form (component-compile-form component))) 
     4222               (if (functionp compile-form) 
     4223                   (funcall compile-form) 
     4224                   (eval compile-form))))) 
    38194225          ((load :load) 
    3820            (eval (component-load-form component)))))) 
     4226           (with-special-component-vars (component) 
     4227             (let ((load-form (component-load-form component))) 
     4228               (if (functionp load-form) 
     4229                   (funcall load-form) 
     4230                   (eval load-form))) 
     4231             ))))) 
    38214232  ;; This is only used as a boolean. 
    38224233  changed) 
    38234234 
     
    38474258                    (version *version*)) 
    38484259  ;; If the pathname is present, this behaves like the old require. 
    38494260  (unless (and module-name 
     4261               ;; madhu: Allegro cannot coerce pathnames to strings 
     4262               ;; via (string #p"foo") and module-name turns out to be 
     4263               ;; a pathname when REQUIRE is used internally to load 
     4264               ;; internal modules. 
     4265               #+allegro 
     4266               (and (pathnamep module-name) 
     4267                    (setq module-name (namestring module-name))) 
    38504268               (find (string module-name) 
    38514269                     *modules* :test #'string=)) 
    38524270    (handler-case 
     
    38804298               ||# 
    38814299               (error 'missing-system :name module-name))) 
    38824300      (missing-module (mmc) (signal mmc)) ; Resignal. 
     4301      ;; madhu 080902 a missing-system is incorrectly signalled when 
     4302      ;; mk:oos throws an error. 
     4303      #+nil 
    38834304      (error (e) 
    38844305             (declare (ignore e)) 
    38854306             ;; Signal a (maybe wrong) MISSING-SYSTEM. 
     
    39104331                         #+:lispworks 'system:::require 
    39114332                         #+(and :excl :allegro-v4.0) 'cltl1:require)) 
    39124333 
    3913   (let (#+(or :CCL :openmcl) (ccl:*warn-if-redefine-kernel* nil)) 
     4334  (let (#+:CCL (ccl:*warn-if-redefine-kernel* nil)) 
    39144335    ;; Note that lots of lisps barf if we redefine a function from 
    39154336    ;; the LISP package. So what we do is define a macro with an 
    39164337    ;; unused name, and use (setf macro-function) to redefine 
     
    39374358(unless *old-require* 
    39384359  (setf *old-require* 
    39394360        (symbol-function 
    3940          #-(or (and :excl :allegro-v4.0) :mcl :openmcl :sbcl :lispworks) 'lisp:require 
     4361         #-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require 
    39414362         #+(and :excl :allegro-v4.0) 'cltl1:require 
    39424363         #+:sbcl 'cl:require 
    39434364         #+:lispworks3.1 'common-lisp::require 
     
    39474368         )) 
    39484369 
    39494370  (unless *dont-redefine-require* 
    3950     (let (#+(or :mcl :openmcl (and :CCL (not :lispworks))) 
     4371    (let (#+(or :mcl (and :CCL (not :lispworks))) 
    39514372          (ccl:*warn-if-redefine-kernel* nil)) 
    39524373      #-(or (and allegro-version>= (version>= 4 1)) :lispworks) 
    39534374      (setf (symbol-function 
    3954              #-(or (and :excl :allegro-v4.0) :mcl :openmcl :sbcl :lispworks) 'lisp:require 
     4375             #-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require 
    39554376             #+(and :excl :allegro-v4.0) 'cltl1:require 
    39564377             #+:lispworks3.1 'common-lisp::require 
    39574378             #+:sbcl 'cl:require 
     
    39764397         (symbol-function 'new-require)))))) 
    39774398) 
    39784399 
     4400 
     4401;;; Well, let's add some more REQUIRE hacking; specifically for SBCL, 
     4402;;; and, eventually, for CMUCL. 
     4403 
     4404#+sbcl 
     4405(eval-when (:compile-toplevel :load-toplevel :execute) 
     4406 
     4407(defun sbcl-mk-defsystem-module-provider (name) 
     4408  ;; Let's hope things go smoothly. 
     4409    (let ((module-name (string-downcase (string name)))) 
     4410      (when (mk:find-system module-name :load-or-nil) 
     4411        (mk:load-system module-name 
     4412                        :compile-during-load t 
     4413                        :verbose nil)))) 
     4414 
     4415(pushnew 'sbcl-mk-defsystem-module-provider sb-ext:*module-provider-functions*) 
     4416) 
     4417 
     4418#+#.(cl:if (cl:and (cl:find-package "EXT") (cl:find-symbol "*MODULE-PROVIDER-FUNCTIONS*" "EXT")) '(and) '(or)) 
     4419(progn 
     4420  (defun cmucl-mk-defsystem-module-provider (name) 
     4421    (let ((module-name (string-downcase (string name)))) 
     4422      (when (mk:find-system module-name :load-or-nil) 
     4423        (mk:load-system module-name 
     4424                        :compile-during-load t 
     4425                        :verbose nil)))) 
     4426 
     4427  (pushnew 'cmucl-mk-defsystem-module-provider ext:*module-provider-functions*) 
     4428  ) 
     4429 
     4430 
     4431 
     4432 
    39794433;;; ******************************** 
    39804434;;; Language-Dependent Characteristics 
    39814435;;; ******************************** 
     
    41064560  (error "MK::RUN-UNIX-PROGRAM: this does not seem to be a UN*X system.") 
    41074561  ) 
    41084562 
     4563 
     4564;;; This is inspired by various versions - all very UNIX/Linux 
     4565;;; dependent - appearing in ASDF and UFFI.  The original versions and Copyrights 
     4566;;; are by Dan Barlow, Kevin Rosenberg and many others. 
     4567;;; This version should be more liberal. 
     4568 
     4569(defvar *default-shell* "/bin/sh") 
     4570 
     4571#+(or windows ms-windows win32) 
     4572(eval-when (:load-toplevel :execute) 
     4573  ;; Lets assume a "standard" Cygwin installation. 
     4574  (if (probe-file (pathname "C:\\cygwin\\bin\\sh.exe")) 
     4575      (setf *default-shell* "C:\\cygwin\\bin\\sh.exe") 
     4576      (setf *default-shell* nil))) 
     4577 
     4578 
     4579(defun run-shell-command (command-control-string 
     4580                          arguments 
     4581                          &key 
     4582                          (output *trace-output*) 
     4583                          (shell *default-shell*) 
     4584                          ) 
     4585   "Executes a shell 'command' in an underlying process. 
     4586RUN-SHELL-COMMAND interpolate ARGS into CONTROL-STRING as if by FORMAT, and 
     4587synchronously execute the result using a Bourne-compatible shell, with 
     4588output to *trace-output*.  Returns the shell's exit code." 
     4589 
     4590   (declare (ignorable shell)) 
     4591 
     4592  (let ((command (apply #'format nil command-control-string arguments))) 
     4593    #+sbcl 
     4594    (sb-impl::process-exit-code 
     4595     (sb-ext:run-program shell 
     4596                         (list "-c" command) 
     4597                         :input nil 
     4598                         :output output)) 
     4599 
     4600    #+(or cmu scl) 
     4601    (ext:process-exit-code 
     4602     (ext:run-program shell 
     4603                      (list "-c" command) 
     4604                      :input nil 
     4605                      :output output)) 
     4606 
     4607    #+allegro 
     4608    (excl:run-shell-command command :input nil :output output) 
     4609 
     4610    #+(and lispworks win32) 
     4611    (system:call-system-showing-output (format nil "cmd /c ~A" command) 
     4612                                       :output-stream output) 
     4613 
     4614    #+(and lispworks (not win32)) 
     4615    (system:call-system-showing-output command 
     4616                                       :shell-type shell 
     4617                                       :output-stream output) 
     4618 
     4619    #+clisp                             ;XXX not exactly *trace-output*, I know 
     4620    (ext:run-shell-command command :output :terminal :wait t) 
     4621 
     4622    #+openmcl 
     4623    (nth-value 1 
     4624               (ccl:external-process-status 
     4625                (ccl:run-program shell 
     4626                                 (list "-c" command) 
     4627                                 :input nil 
     4628                                 :output output 
     4629                                 :wait t))) 
     4630 
     4631    #-(or openmcl clisp lispworks allegro scl cmu sbcl) 
     4632    (error "RUN-SHELL-PROGRAM not implemented for this Lisp") 
     4633    )) 
     4634 
     4635 
    41094636#|| 
    41104637(defun c-compile-file (filename &rest args &key output-file error-file) 
    41114638  ;; gcc -c foo.c -o foo.o 
     
    42194746                fatal-error))))) 
    42204747 
    42214748 
     4749;;; C Language definitions. 
     4750 
    42224751(defun c-compile-file (filename &rest args 
    42234752                                &key 
    42244753                                (output-file t) 
     
    42784807          #+:allegro #'load 
    42794808          #+(or :cmu :scl) #'alien:load-foreign 
    42804809          #+:sbcl #'sb-alien:load-foreign 
    4281           #+(and :lispworks :unix (not :linux)) #'link-load:read-foreign-modules 
    4282           #+(and :lispworks (or (not :unix) :linux)) #'fli:register-module 
     4810          #+(and :lispworks :unix (not :linux) (not :macosx)) #'link-load:read-foreign-modules 
     4811          #+(and :lispworks :unix (or :linux :macosx)) #'fli:register-module 
     4812          #+(and :lispworks :win32) #'fli:register-module 
    42834813          #+(or :ecl :gcl :kcl) #'load ; should be enough. 
    42844814          #-(or :lucid 
    42854815                :allegro 
     
    42974827  :source-extension "c" 
    42984828  :binary-extension "o") 
    42994829 
    4300 #|| 
    4301 ;;; FDMM's changes, which we've replaced. 
    4302 (defvar *compile-file-function* #'cl-compile-file) 
    43034830 
    4304 #+(or :clos :pcl) 
    4305 (defmethod set-language ((lang (eql :common-lisp))) 
    4306   (setq *compile-file-function* #'cl-compile-file)) 
     4831;;; Fortran Language definitions. 
     4832;;; From Matlisp. 
    43074833 
    4308 #+(or :clos :pcl) 
    4309 (defmethod set-language ((lang (eql :scheme))) 
    4310   (setq *compile-file-function #'scheme-compile-file)) 
    4311 ||# 
     4834(export '(*fortran-compiler* *fortran-options*)) 
    43124835 
     4836(defparameter *fortran-compiler* "g77") 
     4837(defparameter *fortran-options* '("-O")) 
     4838 
     4839(defun fortran-compile-file (filename &rest args 
     4840                                      &key output-file error-file 
     4841                                      &allow-other-keys) 
     4842  (declare (ignore error-file args)) 
     4843  (let ((arg-list 
     4844         (append *fortran-options* 
     4845                 `("-c" ,filename ,@(if output-file `("-o" ,output-file)))))) 
     4846    (run-unix-program *fortran-compiler* arg-list))) 
     4847 
     4848 
     4849(mk:define-language :fortran 
     4850    :compiler #'fortran-compile-file 
     4851    :loader #'identity 
     4852    :source-extension "f" 
     4853    :binary-extension "o") 
     4854 
     4855 
     4856;;; AR support. 
     4857;; How to create a library (archive) of object files 
     4858 
     4859(export '(*ar-program* build-lib)) 
     4860 
     4861(defparameter *ar-program* "ar") 
     4862 
     4863(defun build-lib (libname directory) 
     4864  (let ((args (list "rv" (truename libname)))) 
     4865    (format t ";;; Building archive ~A~%" libname) 
     4866    (run-unix-program *ar-program* 
     4867                      (append args 
     4868                              (mapcar #'truename (directory directory)))))) 
     4869 
     4870 
    43134871;;; ******************************** 
    43144872;;; Component Operations *********** 
    43154873;;; ******************************** 
    43164874;;; Define :compile/compile and :load/load operations 
    4317 (eval-when (load eval) 
     4875(eval-when (:load-toplevel :execute) 
    43184876(component-operation :compile  'compile-and-load-operation) 
    43194877(component-operation 'compile  'compile-and-load-operation) 
    43204878(component-operation :load     'load-file-operation) 
    43214879(component-operation 'load     'load-file-operation) 
    43224880) 
    43234881 
     4882 
    43244883(defun compile-and-load-operation (component force) 
    43254884  ;; FORCE was CHANGED. this caused defsystem during compilation to only 
    43264885  ;; load files that it immediately compiled. 
     
    43354894        (and (load-file-operation component force) ; FORCE was CHANGED ??? 
    43364895             changed)))) 
    43374896 
     4897 
    43384898(defun unmunge-lucid (namestring) 
    43394899  ;; Lucid's implementation of COMPILE-FILE is non-standard, in that 
    43404900  ;; when the :output-file is a relative pathname, it tries to munge 
     
    43534913         ;; Ugly, but seems to fix the problem. 
    43544914         (concatenate 'string "./" namestring)))) 
    43554915 
     4916#+gcl 
     4917(defun ensure-directories-exist (arg0 &key verbose) 
     4918  (declare (ignore arg0 verbose)) 
     4919  ()) 
     4920 
     4921 
    43564922(defun compile-file-operation (component force) 
    43574923  ;; Returns T if the file had to be compiled. 
    43584924  (let ((must-compile 
     
    43624928              (or (find force '(:all :new-source-all t) :test #'eq) 
    43634929                  (and (find force '(:new-source :new-source-and-dependents) 
    43644930                             :test #'eq) 
    4365                        (needs-compilation component))))) 
     4931                       (needs-compilation component nil))))) 
    43664932        (source-pname (component-full-pathname component :source))) 
    43674933 
    43684934    (cond ((and must-compile (probe-file source-pname)) 
     
    43894955                          source-pname 
    43904956                          :output-file 
    43914957                          output-file 
    4392                           #+(or :cmu :scl) :error-file 
    4393                           #+(or :cmu :scl) (and *cmu-errors-to-file* 
    4394                                                 (component-full-pathname component 
    4395                                                                          :error)) 
    4396                           #+CMU 
     4958 
     4959                          #+(or :cmu :scl) 
     4960                          :error-file 
     4961 
     4962                          #+(or :cmu :scl) 
     4963                          (and *cmu-errors-to-file* 
     4964                               (component-full-pathname component :error)) 
     4965 
     4966                          #+cmu 
    43974967                          :error-output 
    4398                           #+CMU 
     4968                          #+cmu 
    43994969                          *cmu-errors-to-terminal* 
     4970 
    44004971                          (component-compiler-options component) 
    44014972                          )))) 
    44024973           must-compile) 
     
    44064977           nil) 
    44074978          (t nil)))) 
    44084979 
    4409 (defun needs-compilation (component) 
     4980 
     4981;;; compiled-file-p -- 
     4982;;; See CLOCC/PORT/sys.lisp:compiled-file-p 
     4983 
     4984(eval-when (:load-toplevel :execute :compile-toplevel) 
     4985  (when (find-package "PORT") 
     4986    (import (find-symbol "COMPILED-FILE-P" "PORT")))) 
     4987 
     4988(unless (fboundp 'compiled-file-p) 
     4989  (defun compiled-file-p (file-name) 
     4990    "Return T if the FILE-NAME is a filename designator for a valid compiled. 
     4991Signal an error when it is not a filename designator. 
     4992Return NIL when the file does not exist, or is not readable, 
     4993or does not contain valid compiled code." 
     4994    #+clisp 
     4995    (with-open-file (in file-name :direction :input :if-does-not-exist nil) 
     4996      (handler-bind ((error (lambda (c) (declare (ignore c)) 
     4997                                    (return-from compiled-file-p nil)))) 
     4998        (and in (char= #\( (peek-char nil in nil #\a)) 
     4999             (let ((form (read in nil nil))) 
     5000               (and (consp form) 
     5001                    (eq (car form) 'SYSTEM::VERSION) 
     5002                    (null (eval form))))))) 
     5003    #-clisp (declare (ignorable file-name)) 
     5004    #-clisp t)) 
     5005 
     5006 
     5007(defun needs-compilation (component force) 
    44105008  ;; If there is no binary, or it is older than the source 
    44115009  ;; file, then the component needs to be compiled. 
    44125010  ;; Otherwise we only need to recompile if it depends on a file that changed. 
     5011  (declare (ignore force)) 
    44135012  (let ((source-pname (component-full-pathname component :source)) 
    4414         (binary-pname (component-full-pathname component :binary))) 
     5013        (binary-pname (component-full-pathname component :binary))) 
    44155014    (and 
    44165015     ;; source must exist 
    44175016     (probe-file source-pname) 
    44185017     (or 
     5018      ;; We force recompilation. 
     5019      #|(find force '(:all :new-source-all) :test #'eq)|# 
    44195020      ;; no binary 
    44205021      (null (probe-file binary-pname)) 
    44215022      ;; old binary 
    44225023      (< (file-write-date binary-pname) 
    4423          (file-write-date source-pname)))))) 
     5024         (file-write-date source-pname)) 
     5025      ;; invalid binary 
     5026      (not (compiled-file-p binary-pname)))))) 
    44245027 
     5028 
    44255029(defun needs-loading (component &optional (check-source t) (check-binary t)) 
    44265030  ;; Compares the component's load-time against the file-write-date of 
    44275031  ;; the files on disk. 
     
    44575061         ;; needs-compilation has an implicit source-exists in it. 
    44585062         (needs-compilation (if (component-load-only component) 
    44595063                                source-needs-loading 
    4460                                 (needs-compilation component))) 
     5064                                (needs-compilation component force))) 
    44615065         (check-for-new-source 
    44625066          ;; If force is :new-source*, we're checking for files 
    44635067          ;; whose source is newer than the compiled versions. 
     
    44705074              (and load-binary (component-load-only component)) 
    44715075              (and check-for-new-source needs-compilation))) 
    44725076         (compile-and-load 
    4473           (and needs-compilation (or load-binary check-for-new-source) 
    4474                (compile-and-load-source-if-no-binary component)))) 
     5077          (and needs-compilation 
     5078               (or load-binary check-for-new-source) 
     5079               (compile-and-load-source-if-no-binary component))) 
     5080         ) 
    44755081    ;; When we're trying to minimize the files loaded to only those 
    44765082    ;; that need be, restrict the values of load-source and load-binary 
    44775083    ;; so that we only load the component if the files are newer than 
    44785084    ;; the load-time. 
    4479     (when *minimal-load* 
     5085    (when (and *minimal-load* 
     5086               (not (find force '(:all :new-source-all) 
     5087                          :test #'eq))) 
    44805088      (when load-source (setf load-source source-needs-loading)) 
    44815089      (when load-binary (setf load-binary binary-needs-loading))) 
    44825090 
     
    44975105                           (or *load-source-instead-of-binary* 
    44985106                               (component-load-only component) 
    44995107                               (not *compile-during-load*))) 
    4500                       (and load-binary (not binary-exists) 
     5108                      (and load-binary 
     5109                           (not binary-exists) 
    45015110                           (load-source-if-no-binary component)))) 
    45025111             ;; Load the source if the source exists and: 
    45035112             ;;   o  we're loading binary and it doesn't exist 
     
    45435152            (and (find force '(:new-source :new-source-and-dependents 
    45445153                                           :new-source-all) 
    45455154                       :test #'eq) 
    4546                  (needs-compilation component))) 
     5155                 (needs-compilation component nil))) 
    45475156    (let ((binary-pname (component-full-pathname component :binary))) 
    45485157      (when (probe-file binary-pname) 
    45495158        (with-tell-user ("Deleting binary"   component :binary) 
     
    45935202               (setq *compile-during-load* 
    45945203                     (y-or-n-p-wait 
    45955204                      #\y 30 
    4596                       "~A- Should I compile and load or not? " 
     5205                      "~A- Should I compile while loading the system? " 
    45975206                      prompt)))         ; was compile-source, then t 
    45985207             compile-source)) 
    45995208          (*compile-during-load*) 
     
    47595368     (when (setq changed 
    47605369                 (or (find force '(:all t) :test #'eq) 
    47615370                     (and (not (non-empty-listp force)) 
    4762                           (needs-compilation component)))) 
     5371                          (needs-compilation component nil)))) 
    47635372       (setq result 
    47645373             (list component)))) 
    47655374    ((:module :system :subsystem :defsystem) 
     
    47965405 
    47975406;;; Should this conditionalization be (or :mcl (and :CCL (not :lispworks)))? 
    47985407#| 
    4799 #+:ccl 
    4800 (defun edit-operation (component force) 
    4801   "Always returns nil, i.e. component not changed." 
    4802   (declare (ignore force)) 
    4803   ;; 
    4804   (let* ((full-pathname (make::component-full-pathname component :source)) 
    4805          (already-editing\? #+:mcl (dolist (w (CCL:windows :class 
    4806                                                            'fred-window)) 
    4807                                     (when (equal (CCL:window-filename w) 
    4808                                                  full-pathname) 
    4809                                       (return w))) 
    4810                            #-:mcl nil)) 
    4811     (if already-editing\? 
    4812       #+:mcl (CCL:window-select already-editing\?) #-:mcl nil 
    4813       (ed full-pathname))) 
    4814   nil) 
     5408                                     #+:ccl 
     5409                                     (defun edit-operation (component force) 
     5410"Always returns nil, i.e. component not changed." 
     5411(declare (ignore force)) 
     5412;; 
     5413(let* ((full-pathname (make::component-full-pathname component :source)) 
     5414(already-editing\? #+:mcl (dolist (w (CCL:windows :class 
     5415'fred-window)) 
     5416(when (equal (CCL:window-filename w) 
     5417full-pathname) 
     5418(return w))) 
     5419#-:mcl nil)) 
     5420(if already-editing\? 
     5421#+:mcl (CCL:window-select already-editing\?) #-:mcl nil 
     5422(ed full-pathname))) 
     5423nil) 
    48155424 
    4816 #+:allegro 
    4817 (defun edit-operation (component force) 
    4818   "Edit a component - always returns nil, i.e. component not changed." 
    4819   (declare (ignore force)) 
    4820   (let ((full-pathname (component-full-pathname component :source))) 
    4821     (ed full-pathname)) 
    4822   nil) 
     5425                                     #+:allegro 
     5426                                     (defun edit-operation (component force) 
     5427"Edit a component - always returns nil, i.e. component not changed." 
     5428(declare (ignore force)) 
     5429(let ((full-pathname (component-full-pathname component :source))) 
     5430(ed full-pathname)) 
     5431nil) 
    48235432 
    4824 #+(or :ccl :allegro) 
    4825 (make::component-operation :edit 'edit-operation) 
    4826 #+(or :ccl :allegro) 
    4827 (make::component-operation 'edit 'edit-operation) 
    4828 |# 
     5433                                     #+(or :ccl :allegro) 
     5434                                     (make::component-operation :edit 'edit-operation) 
     5435                                     #+(or :ccl :allegro) 
     5436                                     (make::component-operation 'edit 'edit-operation) 
     5437                                     |# 
    48295438 
    48305439;;; *** Hardcopy System *** 
    48315440(defparameter *print-command* "enscript -2Gr" ; "lpr"