Ticket #1028: tools.diff

asdf.lisp

@@ -1 +1 @@
 ;;; -*- mode: Common-Lisp; Base: 10 ; Syntax: ANSI-Common-Lisp ; coding: utf-8 -*-
-;;; This is ASDF 2.23: Another System Definition Facility.
+;;; This is ASDF 2.26: Another System Definition Facility.
 ;;;
 ;;; Feedback, bug reports, and patches are all welcome:
 ;;; please mail to <asdf-devel@common-lisp.net>.
@@ -50 +50 @@
 (cl:in-package :common-lisp-user)
 #+genera (in-package :future-common-lisp-user)
 
-#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
+#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
 (error "ASDF is not supported on your implementation. Please help us port it.")
 
 ;;;; Create and setup packages in a way that is compatible with hot-upgrade.
@@ -71 +71 @@
             (and (= system::*gcl-major-version* 2)
                  (< system::*gcl-minor-version* 7)))
     (pushnew :gcl-pre2.7 *features*))
-  #+(or abcl (and allegro ics) (and clisp unicode) clozure (and cmu unicode)
-        (and ecl unicode) lispworks (and sbcl sb-unicode) scl)
+  #+(or abcl (and allegro ics) (and (or clisp cmu ecl mkcl) unicode)
+        clozure lispworks (and sbcl sb-unicode) scl)
   (pushnew :asdf-unicode *features*)
   ;;; make package if it doesn't exist yet.
   ;;; DEFPACKAGE may cause errors on discrepancies, so we avoid it.
@@ -86 +86 @@
   ;;; except that the defun has to be in package asdf.
   #+ecl (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t))
   #+ecl (unless (use-ecl-byte-compiler-p) (require :cmp))
+  #+mkcl (require :cmp)
+  #+mkcl (setq clos::*redefine-class-in-place* t) ;; Make sure we have strict ANSI class redefinition semantics
 
   ;;; Package setup, step 2.
   (defvar *asdf-version* nil)
@@ -116 +118 @@
          ;; "2.345.6" would be a development version in the official upstream
          ;; "2.345.0.7" would be your seventh local modification of official release 2.345
          ;; "2.345.6.7" would be your seventh local modification of development version 2.345.6
-         (asdf-version "2.23")
+         (asdf-version "2.26")
          (existing-asdf (find-class 'component nil))
          (existing-version *asdf-version*)
          (already-there (equal asdf-version existing-version)))
@@ -228 +230 @@
                    :redefined-functions ',redefined-functions)))
           (pkgdcl
            :asdf
-           :nicknames (:asdf-utilities) ;; DEPRECATED! Do not use, for backward compatibility only.
            :use (:common-lisp)
            :redefined-functions
            (#:perform #:explain #:output-files #:operation-done-p
@@ -303 +304 @@
             #:*compile-file-warnings-behaviour*
             #:*compile-file-failure-behaviour*
             #:*resolve-symlinks*
-            #:*require-asdf-operator*
+            #:*load-system-operation*
             #:*asdf-verbose*
             #:*verbose-out*
 
@@ -362 +363 @@
             #:user-source-registry-directory
             #:system-source-registry-directory
 
-            ;; Utilities
+            ;; Utilities: please use asdf-utils instead
+            #|
             ;; #:aif #:it
-            #:appendf #:orf
+            ;; #:appendf #:orf
             #:length=n-p
             #:remove-keys #:remove-keyword
-            #:first-char #:last-char #:ends-with
+            #:first-char #:last-char #:string-suffix-p
             #:coerce-name
             #:directory-pathname-p #:ensure-directory-pathname
             #:absolute-pathname-p #:ensure-pathname-absolute #:pathname-root
-            #:getenv #:getenv-pathname #:getenv-pathname
+            #:getenv #:getenv-pathname #:getenv-pathnames
             #:getenv-absolute-directory #:getenv-absolute-directories
             #:probe-file*
             #:find-symbol* #:strcat
@@ -387 +389 @@
             #:while-collecting
             #:*wild* #:*wild-file* #:*wild-directory* #:*wild-inferiors*
             #:*wild-path* #:wilden
-            #:directorize-pathname-host-device
+            #:directorize-pathname-host-device|#
             )))
         #+genera (import 'scl:boolean :asdf)
         (setf *asdf-version* asdf-version
@@ -419 +421 @@
 (defparameter +asdf-methods+
   '(perform-with-restarts perform explain output-files operation-done-p))
 
+(defvar *load-system-operation* 'load-op
+  "Operation used by ASDF:LOAD-SYSTEM. By default, ASDF:LOAD-OP.
+You may override it with e.g. ASDF:LOAD-FASL-OP from asdf-bundle,
+or ASDF:LOAD-SOURCE-OP if your fasl loading is somehow broken.")
+
+(defvar *compile-op-compile-file-function* 'compile-file*
+  "Function used to compile lisp files.")
+
+
+
 #+allegro
 (eval-when (:compile-toplevel :execute)
   (defparameter *acl-warn-save*
@@ -450 +462 @@
 (progn
   (deftype logical-pathname () nil)
   (defun make-broadcast-stream () *error-output*)
+  (defun translate-logical-pathname (x) x)
   (defun file-namestring (p)
     (setf p (pathname p))
     (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p))))
@@ -659 +672 @@
          ;; Giving :unspecific as argument to make-pathname is not portable.
          ;; See CLHS make-pathname and 19.2.2.2.3.
          ;; We only use it on implementations that support it,
-         #+(or abcl allegro clozure cmu gcl genera lispworks sbcl scl xcl) :unspecific
+         #+(or abcl allegro clozure cmu gcl genera lispworks mkcl sbcl scl xcl) :unspecific
          #+(or clisp ecl #|These haven't been tested:|# cormanlisp mcl) nil))
     (destructuring-bind (name &optional (type unspecific))
         (split-string filename :max 2 :separator ".")
@@ -741 +754 @@
           (let ((value (_getenv name)))
             (unless (ccl:%null-ptr-p value)
               (ccl:%get-cstring value))))
+  #+mkcl (#.(or (find-symbol* 'getenv :si) (find-symbol* 'getenv :mk-ext)) x)
   #+sbcl (sb-ext:posix-getenv x)
-  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl sbcl scl xcl)
+  #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl)
   (error "~S is not supported on your implementation" 'getenv))
 
 (defun* directory-pathname-p (pathname)
@@ -849 +863 @@
       ((zerop i) (return (null l)))
       ((not (consp l)) (return nil)))))
 
-(defun* ends-with (s suffix)
+(defun* string-suffix-p (s suffix)
   (check-type s string)
   (check-type suffix string)
   (let ((start (- (length s) (length suffix))))
@@ -877 +891 @@
     (null nil)
     (string (probe-file* (parse-namestring p)))
     (pathname (unless (wild-pathname-p p)
-                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks sbcl scl)
+                #.(or #+(or allegro clozure cmu cormanlisp ecl lispworks mkcl sbcl scl)
                       '(probe-file p)
                       #+clisp (aif (find-symbol* '#:probe-pathname :ext)
                                    `(ignore-errors (,it p)))
@@ -2450 +2464 @@
         (funcall (ensure-function hook) thunk)
         (funcall thunk))))
 
-(defvar *compile-op-compile-file-function* 'compile-file*
-  "Function used to compile lisp files.")
-
 ;;; perform is required to check output-files to find out where to put
 ;;; its answers, in case it has been overridden for site policy
 (defmethod perform ((operation compile-op) (c cl-source-file))
-  #-:broken-fasl-loader
   (let ((source-file (component-pathname c))
         ;; on some implementations, there are more than one output-file,
         ;; but the first one should always be the primary fasl that gets loaded.
@@ -2489 +2499 @@
 
 (defmethod output-files ((operation compile-op) (c cl-source-file))
   (declare (ignorable operation))
-  (let ((p (lispize-pathname (component-pathname c))))
-    #-broken-fasl-loader (list (compile-file-pathname p))
-    #+broken-fasl-loader (list p)))
+  (let* ((p (lispize-pathname (component-pathname c)))
+         (f (compile-file-pathname ;; fasl
+             p #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))
+         #+mkcl (o (compile-file-pathname p :fasl-p nil))) ;; object file
+    #+ecl (if (use-ecl-byte-compiler-p)
+              (list f)
+              (list (compile-file-pathname p :type :object) f))
+    #+mkcl (list o f)
+    #-(or ecl mkcl) (list f)))
 
 (defmethod perform ((operation compile-op) (c static-file))
   (declare (ignorable operation c))
@@ -2532 +2548 @@
         (perform (make-sub-operation c o c 'compile-op) c)))))
 
 (defmethod perform ((o load-op) (c cl-source-file))
-  (map () #'load (input-files o c)))
+  (map () #'load
+       #-(or ecl mkcl)
+       (input-files o c)
+       #+(or ecl mkcl)
+       (loop :for i :in (input-files o c)
+             :unless (string= (pathname-type i) "fas")
+             :collect (compile-file-pathname (lispize-pathname i)))))
 
 (defmethod perform ((operation load-op) (c static-file))
   (declare (ignorable operation c))
@@ -2736 +2758 @@
   (setf (documentation 'operate 'function)
         operate-docstring))
 
-(defun* load-system (system &rest args &key force verbose version &allow-other-keys)
+(defun* load-system (system &rest keys &key force verbose version &allow-other-keys)
   "Shorthand for `(operate 'asdf:load-op system)`.
 See OPERATE for details."
   (declare (ignore force verbose version))
-  (apply 'operate 'load-op system args)
+  (apply 'operate *load-system-operation* system keys)
   t)
 
 (defun* load-systems (&rest systems)
@@ -2752 +2774 @@
 (defun loaded-systems ()
   (remove-if-not 'component-loaded-p (registered-systems)))
 
-(defun require-system (s)
-  (load-system s :force-not (loaded-systems)))
+(defun require-system (s &rest keys &key &allow-other-keys)
+  (apply 'load-system s :force-not (loaded-systems) keys))
 
 (defun* compile-system (system &rest args &key force verbose version
                        &allow-other-keys)
@@ -3096 +3118 @@
     #+mcl
     (ccl::with-cstrs ((%command command)) (_system %command))
 
+    #+mkcl
+    ;; This has next to no chance of working on basic Windows!
+    ;; Your best hope is that Cygwin or MSYS is somewhere in the PATH.
+    (multiple-value-bind (io process exit-code)
+        (apply #'mkcl:run-program #+windows "sh" #-windows "/bin/sh"
+                                  (list "-c" command)
+                                  :input nil :output t #|*verbose-out*|# ;; will be *verbose-out* when we support it
+                                  #-windows '(:search nil))
+      (declare (ignore io process))
+      exit-code)
+
     #+sbcl
     (sb-ext:process-exit-code
      (apply 'sb-ext:run-program
@@ -3107 +3140 @@
     #+xcl
     (ext:run-shell-command command)
 
-    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl sbcl scl xcl)
+    #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mcl mkcl sbcl scl xcl)
     (error "RUN-SHELL-COMMAND not implemented for this Lisp")))
 
 #+clisp
@@ -3197 +3230 @@
 (defun implementation-type ()
   (first-feature
    '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) :cmu
-     :ecl :gcl (:lw :lispworks) :mcl :sbcl :scl :symbolics :xcl)))
+     :ecl :gcl (:lw :lispworks) :mcl :mkcl :sbcl :scl :symbolics :xcl)))
 
 (defun operating-system ()
   (first-feature
@@ -3232 +3265 @@
     (car ; as opposed to OR, this idiom prevents some unreachable code warning
      (list
       #+allegro
-      (format nil "~A~A~@[~A~]"
+      (format nil "~A~@[~A~]~@[~A~]~@[~A~]"
               excl::*common-lisp-version-number*
-              ;; ANSI vs MoDeRn - thanks to Robert Goldman and Charley Cox
-              (if (eq excl:*current-case-mode* :case-sensitive-lower) "M" "A")
+              ;; M means "modern", as opposed to ANSI-compatible mode (which I consider default)
+              (and (eq excl:*current-case-mode* :case-sensitive-lower) "M")
               ;; Note if not using International ACL
               ;; see http://www.franz.com/support/documentation/8.1/doc/operators/excl/ics-target-case.htm
-              (excl:ics-target-case (:-ics "8")))
+              (excl:ics-target-case (:-ics "8"))
+              (and (member :smp *features*) "S"))
       #+armedbear (format nil "~a-fasl~a" s system::*fasl-version*)
       #+clisp
       (subseq s 0 (position #\space s)) ; strip build information (date, etc.)
@@ -3272 +3306 @@
 
 (defun* hostname ()
   ;; Note: untested on RMCL
-  #+(or abcl clozure cmucl ecl genera lispworks mcl sbcl scl xcl) (machine-instance)
+  #+(or abcl clozure cmucl ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance)
   #+cormanlisp "localhost" ;; is there a better way? Does it matter?
   #+allegro (excl.osi:gethostname)
   #+clisp (first (split-string (machine-instance) :separator " "))
@@ -3288 +3322 @@
 (defun* user-homedir ()
   (truenamize
    (pathname-directory-pathname
+    #+cormanlisp (ensure-directory-pathname (user-homedir-pathname))
     #+mcl (current-user-homedir-pathname)
-    #-mcl (user-homedir-pathname))))
+    #-(or cormanlisp mcl) (user-homedir-pathname))))
 
 (defun* ensure-pathname* (x want-absolute want-directory fmt &rest args)
   (when (plusp (length x))
@@ -3304 +3339 @@
   (loop :for dir :in (split-string
                       x :separator (string (inter-directory-separator)))
         :collect (apply 'ensure-pathname* dir want-absolute want-directory fmt args)))
-(defun getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x)))
+(defun* getenv-pathname (x &key want-absolute want-directory &aux (s (getenv x)))
   (ensure-pathname* s want-absolute want-directory "from (getenv ~S)" x))
-(defun getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x)))
+(defun* getenv-pathnames (x &key want-absolute want-directory &aux (s (getenv x)))
   (and (plusp (length s))
        (split-pathnames* s want-absolute want-directory "from (getenv ~S) = ~S" x s)))
-(defun getenv-absolute-directory (x)
+(defun* getenv-absolute-directory (x)
   (getenv-pathname x :want-absolute t :want-directory t))
-(defun getenv-absolute-directories (x)
+(defun* getenv-absolute-directories (x)
   (getenv-pathnames x :want-absolute t :want-directory t))
 
+(defun* get-folder-path (folder)
+  (or ;; this semi-portably implements a subset of the functionality of lispworks' sys:get-folder-path
+   #+(and lispworks mswindows) (sys:get-folder-path folder)
+   ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
+   (ecase folder
+    (:local-appdata (getenv-absolute-directory "LOCALAPPDATA"))
+    (:appdata (getenv-absolute-directory "APPDATA"))
+    (:common-appdata (or (getenv-absolute-directory "ALLUSERSAPPDATA")
+                         (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))))))
 
 (defun* user-configuration-directories ()
   (let ((dirs
@@ -3323 +3367 @@
                 (loop :for dir :in (getenv-absolute-directories "XDG_CONFIG_DIRS")
                   :collect (subpathname* dir "common-lisp/"))))
            ,@(when (os-windows-p)
-               `(,(subpathname* (or #+lispworks (sys:get-folder-path :local-appdata)
-                                    (getenv-absolute-directory "LOCALAPPDATA"))
-                               "common-lisp/config/")
-                 ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\AppData
-                 ,(subpathname* (or #+lispworks (sys:get-folder-path :appdata)
-                                    (getenv-absolute-directory "APPDATA"))
-                                "common-lisp/config/")))
+               `(,(subpathname* (get-folder-path :local-appdata) "common-lisp/config/")
+                 ,(subpathname* (get-folder-path :appdata) "common-lisp/config/")))
            ,(subpathname (user-homedir) ".config/common-lisp/"))))
     (remove-duplicates (remove-if-not #'absolute-pathname-p dirs)
                        :from-end t :test 'equal)))
@@ -3340 +3379 @@
     ((os-windows-p)
      (aif
       ;; read-windows-registry HKEY_LOCAL_MACHINE\SOFTWARE\Microsoft\Windows\CurrentVersion\Explorer\User Shell Folders\Common AppData
-      (subpathname* (or #+lispworks (sys:get-folder-path :common-appdata)
-                        (getenv-absolute-directory "ALLUSERSAPPDATA")
-                        (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/"))
-                    "common-lisp/config/")
+      (subpathname* (get-folder-path :common-appdata) "common-lisp/config/")
       (list it)))))
 
 (defun* in-first-directory (dirs x &key (direction :input))
@@ -3468 +3504 @@
     (or
      (try (getenv-absolute-directory "XDG_CACHE_HOME") "common-lisp" :implementation)
      (when (os-windows-p)
-       (try (or #+lispworks (sys:get-folder-path :local-appdata)
-                (getenv-absolute-directory "LOCALAPPDATA")
-                #+lispworks (sys:get-folder-path :appdata)
-                (getenv-absolute-directory "APPDATA"))
+       (try (or (get-folder-path :local-appdata)
+                (get-folder-path :appdata))
             "common-lisp" "cache" :implementation))
      '(:home ".cache" "common-lisp" :implementation))))
 
@@ -3698 +3732 @@
     #+sbcl ,(let ((h (getenv-pathname "SBCL_HOME" :want-directory t)))
               (when h `((,(truenamize h) ,*wild-inferiors*) ())))
     ;; The below two are not needed: no precompiled ASDF system there
-    #+ecl (,(translate-logical-pathname "SYS:**;*.*") ())
+    #+(or ecl mkcl) (,(translate-logical-pathname "SYS:**;*.*") ())
+    #+mkcl (,(translate-logical-pathname "CONTRIB:") ())
     ;; #+clozure ,(ignore-errors (list (wilden (let ((*default-pathname-defaults* #p"")) (truename #p"ccl:"))) ()))
     ;; All-import, here is where we want user stuff to be:
     :inherit-configuration
@@ -3875 +3910 @@
   (if (absolute-pathname-p output-file)
       ;; what cfp should be doing, w/ mp* instead of mp
       (let* ((type (pathname-type (apply 'compile-file-pathname "x.lisp" keys)))
-             (defaults (make-pathname
-                        :type type :defaults (merge-pathnames* input-file))))
-        (merge-pathnames* output-file defaults))
+             (defaults (make-pathname
+                        :type type :defaults (merge-pathnames* input-file))))
+        (merge-pathnames* output-file defaults))
       (apply-output-translations
-       (apply 'compile-file-pathname input-file keys))))
+       (apply 'compile-file-pathname input-file
+              (if output-file keys (remove-keyword :output-file keys))))))
 
 (defun* tmpize-pathname (x)
   (make-pathname
@@ -3954 +3990 @@
      (default-toplevel-directory
          (subpathname (user-homedir) ".fasls/")) ;; Use ".cache/common-lisp/" instead ???
      (include-per-user-information nil)
-     (map-all-source-files (or #+(or ecl clisp) t nil))
+     (map-all-source-files (or #+(or clisp ecl mkcl) t nil))
      (source-to-target-mappings nil))
-  #+(or ecl clisp)
+  #+(or clisp ecl mkcl)
   (when (null map-all-source-files)
-    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on ECL and CLISP"))
+    (error "asdf:enable-asdf-binary-locations-compatibility doesn't support :map-all-source-files nil on CLISP, ECL and MKCL"))
   (let* ((fasl-type (pathname-type (compile-file-pathname "foo.lisp")))
          (mapped-files (if map-all-source-files *wild-file*
                            (make-pathname :type fasl-type :defaults *wild-file*)))
@@ -4161 +4197 @@
                       string))
              (setf inherit t)
              (push ':inherit-configuration directives))
-            ((ends-with s "//") ;; TODO: allow for doubling of separator even outside Unix?
+            ((string-suffix-p s "//") ;; TODO: allow for doubling of separator even outside Unix?
              (push `(:tree ,(check (subseq s 0 (- (length s) 2)))) directives))
             (t
              (push `(:directory ,(check s)) directives))))
@@ -4192 +4228 @@
 
 (defun* wrapping-source-registry ()
   `(:source-registry
+    #+ecl (:tree ,(translate-logical-pathname "SYS:"))
+    #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
     #+sbcl (:tree ,(truenamize (getenv-pathname "SBCL_HOME" :want-directory t)))
     :inherit-configuration
     #+cmu (:tree #p"modules:")
@@ -4200 +4238 @@
   `(:source-registry
     #+sbcl (:directory ,(subpathname (user-homedir) ".sbcl/systems/"))
     (:directory ,(default-directory))
-      ,@(loop :for dir :in
-          `(,@(when (os-unix-p)
-                `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
-                       (subpathname (user-homedir) ".local/share/"))
-                  ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
-                        '("/usr/local/share" "/usr/share"))))
-            ,@(when (os-windows-p)
-                `(,(or #+lispworks (sys:get-folder-path :local-appdata)
-                       (getenv-absolute-directory "LOCALAPPDATA"))
-                  ,(or #+lispworks (sys:get-folder-path :appdata)
-                       (getenv-absolute-directory "APPDATA"))
-                  ,(or #+lispworks (sys:get-folder-path :common-appdata)
-                       (getenv-absolute-directory "ALLUSERSAPPDATA")
-                       (subpathname* (getenv-absolute-directory "ALLUSERSPROFILE") "Application Data/")))))
-          :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
-          :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
-      :inherit-configuration))
+    ,@(loop :for dir :in
+        `(,@(when (os-unix-p)
+              `(,(or (getenv-absolute-directory "XDG_DATA_HOME")
+                     (subpathname (user-homedir) ".local/share/"))
+                ,@(or (getenv-absolute-directories "XDG_DATA_DIRS")
+                      '("/usr/local/share" "/usr/share"))))
+          ,@(when (os-windows-p)
+              (mapcar 'get-folder-path '(:local-appdata :appdata :common-appdata))))
+        :collect `(:directory ,(subpathname* dir "common-lisp/systems/"))
+        :collect `(:tree ,(subpathname* dir "common-lisp/source/")))
+    :inherit-configuration))
 (defun* user-source-registry (&key (direction :input))
   (in-user-configuration-directory *source-registry-file* :direction direction))
 (defun* system-source-registry (&key (direction :input))
@@ -4362 +4394 @@
   (clear-output-translations))
 
 
-;;; ECL support for COMPILE-OP / LOAD-OP
+;;; ECL and MKCL support for COMPILE-OP / LOAD-OP
 ;;;
-;;; In ECL, these operations produce both FASL files and the
-;;; object files that they are built from. Having both of them allows
-;;; us to later on reuse the object files for bundles, libraries,
-;;; standalone executables, etc.
+;;; In ECL and MKCL, these operations produce both
+;;; FASL files and the object files that they are built from.
+;;; Having both of them allows us to later on reuse the object files
+;;; for bundles, libraries, standalone executables, etc.
 ;;;
 ;;; This has to be in asdf.lisp and not asdf-ecl.lisp, or else it becomes
 ;;; a problem for asdf on ECL to compile asdf-ecl.lisp after loading asdf.lisp.
 ;;;
-#+ecl
+;;; Also, register-pre-built-system.
+
+#+(or ecl mkcl)
 (progn
-  (setf *compile-op-compile-file-function* 'ecl-compile-file)
+  (defun register-pre-built-system (name)
+    (register-system (make-instance 'system :name (coerce-name name) :source-file nil)))
 
-  (defun ecl-compile-file (input-file &rest keys &key &allow-other-keys)
-    (if (use-ecl-byte-compiler-p)
-        (apply 'compile-file* input-file keys)
-        (multiple-value-bind (object-file flags1 flags2)
-            (apply 'compile-file* input-file :system-p t keys)
-          (values (and object-file
-                       (c::build-fasl (compile-file-pathname object-file :type :fasl)
-                                      :lisp-files (list object-file))
-                       object-file)
-                  flags1
-                  flags2))))
+  #+(or (and ecl win32) (and mkcl windows))
+  (unless (assoc "asd" #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal)
+    (appendf #+ecl ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source))))
 
-  (defmethod output-files ((operation compile-op) (c cl-source-file))
-    (declare (ignorable operation))
-    (let* ((p (lispize-pathname (component-pathname c)))
-           (f (compile-file-pathname p :type :fasl)))
-      (if (use-ecl-byte-compiler-p)
-          (list f)
-          (list (compile-file-pathname p :type :object) f))))
+  (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions*
+        (loop :for f :in #+ecl ext:*module-provider-functions*
+          #+mkcl mk-ext::*module-provider-functions*
+          :unless (eq f 'module-provide-asdf)
+          :collect #'(lambda (name)
+                       (let ((l (multiple-value-list (funcall f name))))
+                         (and (first l) (register-pre-built-system (coerce-name name)))
+                         (values-list l)))))
 
-  (defmethod perform ((o load-op) (c cl-source-file))
-    (map () #'load
-         (loop :for i :in (input-files o c)
-           :unless (string= (pathname-type i) "fas")
-               :collect (compile-file-pathname (lispize-pathname i))))))
+  (setf *compile-op-compile-file-function* 'compile-file-keeping-object)
 
-;;;; -----------------------------------------------------------------
-;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL and SBCL
+  (defun compile-file-keeping-object (input-file &rest keys &key &allow-other-keys)
+    (#+ecl if #+ecl (use-ecl-byte-compiler-p) #+ecl (apply 'compile-file* input-file keys)
+     #+mkcl progn
+     (multiple-value-bind (object-file flags1 flags2)
+         (apply 'compile-file* input-file
+                #+ecl :system-p #+ecl t #+mkcl :fasl-p #+mkcl nil keys)
+       (values (and object-file
+                    (compiler::build-fasl
+                     (compile-file-pathname object-file
+                                            #+ecl :type #+ecl :fasl #+mkcl :fasl-p #+mkcl t)
+                     #+ecl :lisp-files #+mkcl :lisp-object-files (list object-file))
+                    object-file)
+               flags1
+               flags2)))))
+
+;;;; -----------------------------------------------------------------------
+;;;; Hook into REQUIRE for ABCL, CLISP, ClozureCL, CMUCL, ECL, MKCL and SBCL
 ;;;;
-(defvar *require-asdf-operator* 'load-op)
-
 (defun* module-provide-asdf (name)
   (handler-bind
       ((style-warning #'muffle-warning)
@@ -4418 +4455 @@
     (let ((*verbose-out* (make-broadcast-stream))
           (system (find-system (string-downcase name) nil)))
       (when system
-        (operate *require-asdf-operator* system :verbose nil :force-not (loaded-systems))
+        (require-system system :verbose nil)
         t))))
 
-#+(or abcl clisp clozure cmu ecl sbcl)
+#+(or abcl clisp clozure cmu ecl mkcl sbcl)
 (let ((x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom))))
   (when x
     (eval `(pushnew 'module-provide-asdf
@@ -4429 +4466 @@
             #+clisp ,x
             #+clozure ccl:*module-provider-functions*
             #+(or cmu ecl) ext:*module-provider-functions*
+            #+mkcl mk-ext:*module-provider-functions*
             #+sbcl sb-ext:*module-provider-functions*))))
 
 
@@ -4448 +4486 @@
 (when *load-verbose*
   (asdf-message ";; ASDF, version ~a~%" (asdf-version)))
 
+#+mkcl
+(progn
+  (defvar *loading-asdf-bundle* nil)
+  (unless *loading-asdf-bundle*
+    (let ((*central-registry*
+           (cons (translate-logical-pathname #P"CONTRIB:asdf-bundle;") *central-registry*))
+          (*loading-asdf-bundle* t))
+      (clear-system :asdf-bundle) ;; we hope to force a reload.
+      (multiple-value-bind (result bundling-error)
+          (ignore-errors (asdf:oos 'asdf:load-op :asdf-bundle))
+        (unless result
+          (format *error-output*
+                  "~&;;; ASDF: Failed to load package 'asdf-bundle'!~%;;; ASDF: Reason is: ~A.~%"
+                  bundling-error))))))
+
 #+allegro
 (eval-when (:compile-toplevel :execute)
   (when (boundp 'excl:*warn-on-nested-reader-conditionals*)

README-OpenMCL.txt

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

defsystem.lisp

@@ -1 +1 @@
 ;;; -*- Mode: Lisp; Package: make -*-
 ;;; -*- Mode: CLtL; Syntax: Common-Lisp -*-
 
-;;; DEFSYSTEM 3.4 Interim.
+;;; DEFSYSTEM 3.6 Interim.
 
 ;;; defsystem.lisp --
 
@@ -28 +28 @@
 ;;; Originally written by Mark Kantrowitz, School of Computer Science,
 ;;; Carnegie Mellon University, October 1989.
 
-;;; MK:DEFSYSTEM 3.3 Interim
+;;; MK:DEFSYSTEM 3.6 Interim
 ;;;
 ;;; Copyright (c) 1989 - 1999 Mark Kantrowitz. All rights reserved.
-;;;               1999 - 2004 Mark Kantrowitz and Marco Antoniotti. All
+;;;               1999 - 2005 Mark Kantrowitz and Marco Antoniotti. All
 ;;;                           rights reserved.
 
 ;;; Use, copying, modification, merging, publishing, distribution
@@ -835 +835 @@
 ;;; ********************************
 ;;; Let's be smart about CLtL2 compatible Lisps:
 (eval-when (compile load eval)
-  #+(or (and allegro-version>= (version>= 4 0)) :mcl :openmcl :sbcl)
+  #+(or (and allegro-version>= (version>= 4 0)) :mcl :sbcl)
   (pushnew :cltl2 *features*))
 
 ;;; ********************************
@@ -864 +864 @@
 #-(or :CMU
       :vms
       :mcl
-      :openmcl
       :lispworks
       :clisp
       :gcl
@@ -1013 +1012 @@
 
 #+:lispworks
 (defpackage "MAKE" (:nicknames "MK") (:use "COMMON-LISP")
-            (:import-from system *modules* provide require)
+            (:import-from "SYSTEM" *modules* provide require)
             (:export "DEFSYSTEM" "COMPILE-SYSTEM" "LOAD-SYSTEM"
                      "DEFINE-LANGUAGE" "*MULTIPLE-LISP-SUPPORT*"))
 
@@ -1108 +1107 @@
 ;;; then a succeeding export as well.
 
 (eval-when (compile load eval)
-   (defvar *special-exports* nil)
-   (defvar *exports* nil)
-   (defvar *other-exports* nil)
+  (defvar *special-exports* nil)
+  (defvar *exports* nil)
+  (defvar *other-exports* nil)
 
-   (export (setq *exports*
-                 '(operate-on-system
-                   oos
-                   afs-binary-directory afs-source-directory
-                   files-in-system)))
-   (export (setq *special-exports*
-                 '()))
-   (export (setq *other-exports*
-                 '(*central-registry*
-                   *bin-subdir*
+  (export (setq *exports*
+                '(operate-on-system
+                  oos
+                  afs-binary-directory afs-source-directory
+                  files-in-system)))
+  (export (setq *special-exports*
+                '()))
+  (export (setq *other-exports*
+                '(*central-registry*
+                  *bin-subdir*
 
-                   add-registry-location
-                   find-system
-                   defsystem compile-system load-system hardcopy-system
+                  add-registry-location
+                  list-central-registry-directories
+                  print-central-registry-directories
+                  find-system
+                  defsystem compile-system load-system hardcopy-system
 
-                   system-definition-pathname
+                  system-definition-pathname
 
-                   missing-component
-                   missing-component-name
-                   missing-component-component
-                   missing-module
-                   missing-system
+                  missing-component
+                  missing-component-name
+                  missing-component-component
+                  missing-module
+                  missing-system
 
-                   register-foreign-system
+                  register-foreign-system
 
-                   machine-type-translation
-                   software-type-translation
-                   compiler-type-translation
-                   ;; require
-                   define-language
-                   allegro-make-system-fasl
-                   files-which-need-compilation
-                   undefsystem
-                   defined-systems
-                   describe-system clean-system edit-system ;hardcopy-system
-                   system-source-size make-system-tag-table
-                   *defsystem-version*
-                   *compile-during-load*
-                   *minimal-load*
-                   *dont-redefine-require*
-                   *files-missing-is-an-error*
-                   *reload-systems-from-disk*
-                   *source-pathname-default*
-                   *binary-pathname-default*
-                   *multiple-lisp-support*
-                   ))))
+                  machine-type-translation
+                  software-type-translation
+                  compiler-type-translation
+                  ;; require
+                  define-language
+                  allegro-make-system-fasl
+                  files-which-need-compilation
+                  undefsystem
+                  defined-systems
+                  describe-system clean-system edit-system ;hardcopy-system
+                  system-source-size make-system-tag-table
+                  *defsystem-version*
+                  *compile-during-load*
+                  *minimal-load*
+                  *dont-redefine-require*
+                  *files-missing-is-an-error*
+                  *reload-systems-from-disk*
+                  *source-pathname-default*
+                  *binary-pathname-default*
+                  *multiple-lisp-support*
 
+                  run-unix-program
+                  *default-shell*
+                  run-shell-command
+                  )))
+  )
 
+
 ;;; We import these symbols into the USER package to make them
 ;;; easier to use. Since some lisps have already defined defsystem
 ;;; in the user package, we may have to shadowing-import it.
@@ -1184 +1190 @@
   (pushnew :pcl *modules*)
   (pushnew :pcl *features*))
 
+
 ;;; ********************************
 ;;; Defsystem Version **************
 ;;; ********************************
-(defparameter *defsystem-version* "3.3 Interim, 2002-06-13"
-  "Current version number/date for Defsystem.")
+(defparameter *defsystem-version* "3.6 Interim, 2008-12-18"
+  "Current version number/date for MK:DEFSYSTEM.")
 
+
 ;;; ********************************
 ;;; Customizable System Parameters *
 ;;; ********************************
 
-(defvar *dont-redefine-require* nil
-  "If T, prevents the redefinition of REQUIRE. This is useful for
-   lisps that treat REQUIRE specially in the compiler.")
+(defvar *dont-redefine-require*
+  #+cmu (if (find-symbol "*MODULE-PROVIDER-FUNCTIONS*" "EXT") t nil)
+  #+(or clisp sbcl) t
+  #+allegro t
+  #-(or cmu sbcl clisp allegro) nil
+  "If T, prevents the redefinition of REQUIRE.
+This is useful for lisps that treat REQUIRE specially in the compiler.")
 
+
 (defvar *multiple-lisp-support* t
   "If T, afs-binary-directory will try to return a name dependent
-   on the particular lisp compiler version being used.")
+on the particular lisp compiler version being used.")
 
+
 ;;; home-subdirectory --
 ;;; HOME-SUBDIRECTORY is used only in *central-registry* below.
 ;;; Note that CMU CL 17e does not understand the ~/ shorthand for home
@@ -1213 +1227 @@
 ;;; it is UNIX dependent.
 ;;; I added the kludgy #+cormalisp (v 1.5) one, since it is missing
 ;;; the ANSI USER-HOMEDIR-PATHNAME function.
+
 #-cormanlisp
 (defun home-subdirectory (directory)
   (concatenate 'string
@@ -1224 +1239 @@
               "~/"))
         directory))
 
+
 #+cormanlisp
 (defun home-subdirectory (directory)
   (declare (type string directory))
   (concatenate 'string "C:\\" directory))
 
+
 ;;; The following function is available for users to add
 ;;;   (setq mk:*central-registry* (defsys-env-search-path))
 ;;; to Lisp init files in order to use the value of the DEFSYSPATH
 ;;; instead of directly coding it in the file.
+
 #+:allegro
 (defun defsys-env-search-path ()
   "This function grabs the value of the DEFSYSPATH environment variable
@@ -1240 +1258 @@
   (remove-duplicates (split-string (sys:getenv "DEFSYSPATH") :item #\:)
                      :test #'string-equal))
 
+
 ;;; Change this variable to set up the location of a central
 ;;; repository for system definitions if you want one.
 ;;; This is a defvar to allow users to change the value in their
@@ -1255 +1274 @@
     #+:LUCID     (working-directory)
     #+ACLPC      (current-directory)
     #+:allegro   (excl:current-directory)
+    #+:clisp     (ext:default-directory)
     #+:sbcl      (progn *default-pathname-defaults*)
     #+(or :cmu :scl)       (ext:default-directory)
     ;; *** Marco Antoniotti <marcoxa@icsi.berkeley.edu>
     ;; Somehow it is better to qualify default-directory in CMU with
     ;; the appropriate package (i.e. "EXTENSIONS".)
     ;; Same for Allegro.
-    #+(and :lispworks (not :lispworks4))
+    #+(and :lispworks (not :lispworks4) (not :lispworks5))
     ,(multiple-value-bind (major minor)
                           #-:lispworks-personal-edition
                           (system::lispworks-version)
@@ -1277 +1297 @@
                                          (find-package "SYSTEM")))
            (find-symbol "*CURRENT-WORKING-DIRECTORY*"
                         (find-package "LW"))))
-    #+:lispworks4
+    #+(or :lispworks4 :lispworks5)
     (hcl:get-working-directory)
     ;; Home directory
     #-sbcl
     (mk::home-subdirectory "lisp/systems/")
 
     ;; Global registry
-    "/usr/local/lisp/Registry/")
-  "Central directory of system definitions. May be either a single
-   directory pathname, or a list of directory pathnames to be checked
-   after the local directory.")
+    #+unix (pathname "/usr/local/lisp/Registry/")
+    )
+  "Central directory of system definitions.
+May be either a single directory pathname, or a list of directory
+pathnames to be checked after the local directory.")
 
 
 (defun add-registry-location (pathname)
   "Adds a path to the central registry."
   (pushnew pathname *central-registry* :test #'equal))
 
+
+(defun registry-pathname (registry)
+  "Return the pathname represented by the element of *CENTRAL-REGISTRY*."
+  (typecase registry
+    (string (pathname registry))
+    (pathname registry)
+    (otherwise (pathname (eval registry)))))
+
+
+(defun print-central-registry-directories (&optional (stream *standard-output*))
+  (dolist (registry *central-registry*)
+    (print (registry-pathname registry) stream)))
+
+
+(defun list-central-registry-directories ()
+  (mapcar #'registry-pathname *central-registry*))
+
+
 (defvar *bin-subdir* ".bin/"
   "The subdirectory of an AFS directory where the binaries are really kept.")
 
+
 ;;; These variables set up defaults for operate-on-system, and are used
 ;;; for communication in lieu of parameter passing. Yes, this is bad,
 ;;; but it keeps the interface small. Also, in the case of the -if-no-binary
 ;;; variables, parameter passing would require multiple value returns
 ;;; from some functions. Why make life complicated?
+
 (defvar *tell-user-when-done* nil
   "If T, system will print ...DONE at the end of an operation")
+
 (defvar *oos-verbose* nil
   "Operate on System Verbose Mode")
+
 (defvar *oos-test* nil
   "Operate on System Test Mode")
+
 (defvar *load-source-if-no-binary* nil
   "If T, system will try loading the source if the binary is missing")
+
 (defvar *bother-user-if-no-binary* t
   "If T, the system will ask the user whether to load the source if
    the binary is missing")
+
 (defvar *load-source-instead-of-binary* nil
   "If T, the system will load the source file instead of the binary.")
+
 (defvar *compile-during-load* :query
   "If T, the system will compile source files during load if the
-   binary file is missing. If :query, it will ask the user for
-   permission first.")
+binary file is missing. If :query, it will ask the user for
+permission first.")
+
 (defvar *minimal-load* nil
   "If T, the system tries to avoid reloading files that were already loaded
-   and up to date.")
+and up to date.")
 
 (defvar *files-missing-is-an-error* t
   "If both the source and binary files are missing, signal a continuable
@@ -1333 +1381 @@
    or by another defsystem form.")
 
 ;;; Particular to CMULisp
+
 (defvar *compile-error-file-type* "err"
   "File type of compilation error file in cmulisp")
+
 (defvar *cmu-errors-to-terminal* t
   "Argument to :errors-to-terminal in compile-file in cmulisp")
+
 (defvar *cmu-errors-to-file* t
   "If T, cmulisp will write an error file during compilation")
 
+
 ;;; ********************************
 ;;; Global Variables ***************
 ;;; ********************************
@@ -1356 +1408 @@
     (pushnew :ibm-rt-pc *features*))
   )
 
+
 ;;; *filename-extensions* is a cons of the source and binary extensions.
 (defvar *filename-extensions*
   (car `(#+(and Symbolics Lispm)              ("lisp" . "bin")
          #+(and dec common vax (not ultrix))  ("LSP"  . "FAS")
          #+(and dec common vax ultrix)        ("lsp"  . "fas")
          #+ACLPC                              ("lsp"  . "fsl")
-         #+CLISP                              ("lsp"  . "fas")
+         #+CLISP                              ("lisp" . "fas")
          #+KCL                                ("lsp"  . "o")
-         #+ECL                                ("lsp"  . "so")
+         ;;#+ECL                                ("lsp"  . "so")
          #+IBCL                               ("lsp"  . "o")
          #+Xerox                              ("lisp" . "dfasl")
          ;; Lucid on Silicon Graphics
@@ -1402 +1455 @@
 
          ;; Otherwise,
          ("lisp" . ,(pathname-type (compile-file-pathname "foo.lisp")))))
-  "Filename extensions for Common Lisp. A cons of the form
-   (Source-Extension . Binary-Extension). If the system is
-   unknown (as in *features* not known), defaults to lisp and fasl.")
+  "Filename extensions for Common Lisp.
+A cons of the form (Source-Extension . Binary-Extension). If the
+system is unknown (as in *features* not known), defaults to lisp and
+fasl.")
 
 (defvar *system-extension*
   ;; MS-DOS systems can only handle three character extensions.
@@ -1412 +1466 @@
   #+ACLPC "sys"
   "The filename extension to use with systems.")
 
+
 ;;; The above variables and code should be extended to allow a list of
 ;;; valid extensions for each lisp implementation, instead of a single
 ;;; extension. When writing a file, the first extension should be used.
@@ -1428 +1483 @@
 ;;; Note that in any event, the toplevel system (defined with defsystem)
 ;;; will have its dependencies delayed. Not having dependencies delayed
 ;;; might be useful if we define several systems within one defsystem.
+
 (defvar *system-dependencies-delayed* t
   "If T, system dependencies are expanded at run time")
 
+
 ;;; Replace this with consp, dammit!
 (defun non-empty-listp (list)
   (and list (listp list)))
 
+
 ;;; ********************************
 ;;; Component Operation Definition *
 ;;; ********************************
 (eval-when (:compile-toplevel :load-toplevel :execute)
+
 (defvar *version-dir* nil
   "The version subdir. bound in operate-on-system.")
+
 (defvar *version-replace* nil
   "The version replace. bound in operate-on-system.")
+
 (defvar *version* nil
   "Default version."))
 
 (defvar *component-operations* (make-hash-table :test #'equal)
   "Hash table of (operation-name function) pairs.")
+
 (defun component-operation (name &optional operation)
   (if operation
       (setf (gethash name *component-operations*) operation)
       (gethash name *component-operations*)))
 
+
 ;;; ********************************
 ;;; AFS @sys immitator *************
 ;;; ********************************
@@ -1470 +1533 @@
        (declare (ignore char arg))
        `(afs-binary-directory ,(read stream t nil t)))))
 
+
 (defvar *find-irix-version-script*
     "\"1,4 d\\
 s/^[^M]*IRIX Execution Environment 1, *[a-zA-Z]* *\\([^ ]*\\)/\\1/p\\
 /./,$ d\\
 \"")
 
+
 (defun operating-system-version ()
   #+(and :sgi :excl)
   (let* ((full-version (software-version))
@@ -1517 +1582 @@
   #-(or (and :excl :sgi) (and :cmu :sgi) (and :lispworks :irix))
   (software-type))
 
+
 (defun compiler-version ()
   #+:lispworks (concatenate 'string
                 "lispworks" " " (lisp-implementation-version))
@@ -1544 +1610 @@
   #+gclisp    "gclisp"
   )
 
+
 (defun afs-binary-directory (root-directory)
   ;; Function for obtaining the directory AFS's @sys feature would have
   ;; chosen when we're not in AFS. This function is useful as the argument
@@ -1582 +1649 @@
           root-directory
           (and version-flag (translate-version *version*))))
 
+
 (defun null-string (s)
   (when (stringp s)
     (string-equal s "")))
 
+
 (defun ensure-trailing-slash (dir)
   (if (and dir
            (not (null-string dir))
@@ -1599 +1668 @@
       (concatenate 'string dir "/")
       dir))
 
+
 (defun afs-component (machine software &optional lisp)
   (format nil "~@[~A~]~@[_~A~]~@[_~A~]"
             machine
             (or software "mach")
             lisp))
 
+
 (defvar *machine-type-alist* (make-hash-table :test #'equal)
   "Hash table for retrieving the machine-type")
+
 (defun machine-type-translation (name &optional operation)
   (if operation
       (setf (gethash (string-upcase name) *machine-type-alist*) operation)
       (gethash (string-upcase name) *machine-type-alist*)))
 
+
 (machine-type-translation "IBM RT PC"                        "rt")
 (machine-type-translation "DEC 3100"                         "pmax")
 (machine-type-translation "DEC VAX-11"                       "vax")
@@ -1652 +1725 @@
 
 (defvar *software-type-alist* (make-hash-table :test #'equal)
   "Hash table for retrieving the software-type")
+
 (defun software-type-translation (name &optional operation)
   (if operation
       (setf (gethash (string-upcase name) *software-type-alist*) operation)
       (gethash (string-upcase name) *software-type-alist*)))
 
+
 (software-type-translation "BSD UNIX"      "mach") ; "unix"
 (software-type-translation "Ultrix"        "mach") ; "ultrix"
 (software-type-translation "SunOS"         "SunOS")
@@ -1684 +1759 @@
                            #+:lcl4.0 "4.0"
                            #+(and :lcl3.0 (not :lcl4.0)) "3.0")
 
+
 (defvar *compiler-type-alist* (make-hash-table :test #'equal)
   "Hash table for retrieving the Common Lisp type")
+
 (defun compiler-type-translation (name &optional operation)
   (if operation
       (setf (gethash (string-upcase name) *compiler-type-alist*) operation)
     (gethash (string-upcase name) *compiler-type-alist*)))
 
+
 (compiler-type-translation "lispworks 3.2.1"         "lispworks")
 (compiler-type-translation "lispworks 3.2.60 beta 6" "lispworks")
 (compiler-type-translation "lispworks 4.2.0"         "lispworks")
 
+
 #+allegro
 (eval-when (:compile-toplevel :load-toplevel :execute)
   (unless (or (find :case-sensitive common-lisp:*features*)
@@ -1721 +1800 @@
 (compiler-type-translation "cmu 17e" "cmu")
 (compiler-type-translation "cmu 17d" "cmu")
 
+
 ;;; ********************************
 ;;; System Names *******************
 ;;; ********************************
 
 ;;; If you use strings for system names, be sure to use the same case
 ;;; as it appears on disk, if the filesystem is case sensitive.
+
 (defun canonicalize-system-name (name)
   ;; Originally we were storing systems using GET. This meant that the
   ;; name of a system had to be a symbol, so we interned the symbols
@@ -1739 +1820 @@
       (intern (string-upcase (string name)) "KEYWORD"))||#
   (if (stringp name) (string-upcase name) (string-upcase (string name))))
 
+
 (defvar *defined-systems* (make-hash-table :test #'equal)
   "Hash table containing the definitions of all known systems.")
 
+
 (defun get-system (name)
   "Returns the definition of the system named NAME."
   (gethash (canonicalize-system-name name) *defined-systems*))
 
+
 (defsetf get-system (name) (value)
   `(setf (gethash (canonicalize-system-name ,name) *defined-systems*) ,value))
 
+
 (defun undefsystem (name)
   "Removes the definition of the system named NAME."
-  (setf (get-system name) nil))
+  (remhash (canonicalize-system-name name) *defined-systems*))
 
+
 (defun defined-systems ()
   "Returns a list of defined systems."
   (let ((result nil))
@@ -1762 +1848 @@
              *defined-systems*)
     result))
 
+
+(defun defined-names-and-systems ()
+  "Returns a a-list of defined systems along with their names."
+  (loop for sname being the hash-keys of *defined-systems*
+        using (hash-value s)
+        collect (cons sname s)))
+
+
 ;;; ********************************
 ;;; Directory Pathname Hacking *****
 ;;; ********************************
@@ -1826 +1920 @@
          (rel-directory (directory-to-list (pathname-directory rel-dir)))
          (rel-keyword (when (keywordp (car rel-directory))
                         (pop rel-directory)))
-         #-(or :MCL :sbcl :clisp) (rel-file (file-namestring rel-dir))
+         ;; rtoy: Why should any Lisp want rel-file?  Shouldn't using
+         ;; rel-name and rel-type work for every Lisp?
+         #-(or :MCL :sbcl :clisp :cmu) (rel-file (file-namestring rel-dir))
          ;; Stig (July 2001);
          ;; These values seems to help clisp as well
-         #+(or :MCL :sbcl :clisp) (rel-name (pathname-name rel-dir))
-         #+(or :MCL :sbcl :clisp) (rel-type (pathname-type rel-dir))
+         #+(or :MCL :sbcl :clisp :cmu) (rel-name (pathname-name rel-dir))
+         #+(or :MCL :sbcl :clisp :cmu) (rel-type (pathname-type rel-dir))
          (directory nil))
 
     ;; TI Common Lisp pathnames can return garbage for file names because
@@ -1883 +1979 @@
                     :directory
                     directory
                     :name
-                    #-(or :sbcl :MCL :clisp) rel-file
-                    #+(or :sbcl :MCL :clisp) rel-name
+                    #-(or :sbcl :MCL :clisp :cmu) rel-file
+                    #+(or :sbcl :MCL :clisp :cmu) rel-name
 
-                    #+(or :sbcl :MCL :clisp) :type
-                    #+(or :sbcl :MCL :clisp) rel-type
+                    #+(or :sbcl :MCL :clisp :cmu) :type
+                    #+(or :sbcl :MCL :clisp :cmu) rel-type
                     ))))
 
+
 (defun directory-to-list (directory)
   ;; The directory should be a list, but nonstandard implementations have
   ;; been known to use a vector or even a string.
@@ -1930 +2027 @@
      nil "/baz/barf.lisp"
      nil nil))
 
+
 (defun test-new-append-directories (&optional (test-dirs *append-dirs-tests*))
   (do* ((dir-list test-dirs (cddr dir-list))
         (abs-dir (car dir-list) (car dir-list))
@@ -1938 +2036 @@
     (format t "~&ABS: ~S ~18TREL: ~S ~41TResult: ~S"
             abs-dir rel-dir (new-append-directories abs-dir rel-dir))))
 
+
 #||
 <cl> (test-new-append-directories)
 
@@ -2001 +2100 @@
        #-(or :VMS :macl1.3.2)
        (new-append-directories absolute-directory relative-directory)))))
 
+
 #+:logical-pathnames-mk
 (defun append-logical-directories-mk (absolute-dir relative-dir)
   (lp:append-logical-directories absolute-dir relative-dir))
@@ -2026 +2126 @@
   (translate-logical-pathname
    (merge-pathnames relative-dir absolute-dir)))
 
+
 #| Old version 2002-03-02
 #+(and (and allegro-version>= (version>= 4 1))
        (not :logical-pathnames-mk))
@@ -2113 +2214 @@
   (pathname-logical-p namestring))
 ||#
 
+
+#|| This is incorrect, as it strives to keep strings around, when it
+    shouldn't.  MERGE-PATHNAMES already DTRT.
 (defun append-logical-pnames (absolute relative)
   (declare (type (or null string pathname) absolute relative))
   (let ((abs (if absolute
@@ -2129 +2233 @@
       (setq abs (concatenate 'string abs ";")))
     ;; Return the concatenate pathnames
     (concatenate 'string abs rel)))
+||#
 
+
+(defun append-logical-pnames (absolute relative)
+  (declare (type (or null string pathname) absolute relative))
+  (let ((abs (if absolute
+                 (pathname absolute)
+                 (make-pathname :directory (list :absolute)
+                                :name nil
+                                :type nil)
+                 ))
+        (rel (if relative
+                 (pathname relative)
+                 (make-pathname :directory (list :relative)
+                                :name nil
+                                :type nil)
+                 ))
+        )
+    ;; The following is messed up because CMUCL and LW use different
+    ;; defaults for host (in particular LW uses NIL).  Thus
+    ;; MERGE-PATHNAMES has legitimate different behaviors on both
+    ;; implementations. Of course this is disgusting, but that is the
+    ;; way it is and the rest tries to circumvent this crap.
+    (etypecase abs
+      (logical-pathname
+       (etypecase rel
+         (logical-pathname
+          (namestring (merge-pathnames rel abs)))
+         (pathname
+          ;; The following potentially translates the logical pathname
+          ;; very early, but we cannot avoid it.
+          (namestring (merge-pathnames rel (translate-logical-pathname abs))))
+         ))
+      (pathname
+       (namestring (merge-pathnames rel abs)))
+      )))
+
 #||
 ;;; This was a try at appending a subdirectory onto a directory.
 ;;; It failed. We're keeping this around to prevent future mistakes
@@ -2210 +2350 @@
 ;;; ********************************
 ;;; Component Defstruct ************
 ;;; ********************************
+
 (defvar *source-pathname-default* nil
   "Default value of :source-pathname keyword in DEFSYSTEM. Set this to
    \"\" to avoid having to type :source-pathname \"\" all the time.")
@@ -2217 +2358 @@
 (defvar *binary-pathname-default* nil
   "Default value of :binary-pathname keyword in DEFSYSTEM.")
 
-;;; Removed TIME slot, which has been made unnecessary by the new definition
-;;; of topological-sort.
 
 (defstruct (topological-sort-node (:conc-name topsort-))
   (color :white :type (member :gray :black :white))
-  ;; time
   )
 
+
+(defparameter *component-evaluated-slots*
+  '(:source-root-dir :source-pathname :source-extension
+    :binary-root-dir :binary-pathname :binary-extension))
+
+
+(defparameter *component-form-slots*
+  '(:initially-do :finally-do :compile-form :load-form))
+
+
 (defstruct (component (:include topological-sort-node)
                       (:print-function print-component))
   (type :file     ; to pacify the CMUCL compiler (:type is alway supplied)
@@ -2283 +2431 @@
                                         ; one.
   proclamations                         ; Compiler options, such as
                                         ; '(optimize (safety 3)).
-  initially-do                          ; Form to evaluate before the
+  (initially-do (lambda () nil))        ; Form to evaluate before the
                                         ; operation.
-  finally-do                            ; Form to evaluate after the operation.
-  compile-form                          ; For foreign libraries.
-  load-form                             ; For foreign libraries.
+  (finally-do (lambda () nil))          ; Form to evaluate after the operation.
+  (compile-form (lambda () nil))        ; For foreign libraries.
+  (load-form (lambda () nil))           ; For foreign libraries.
 
   ;; load-time                          ; The file-write-date of the
                                         ; binary/source file loaded.
@@ -2313 +2461 @@
   (banner nil :type (or null string))
 
   (documentation nil :type (or null string)) ; Optional documentation slot
+  (long-documentation nil :type (or null string)) ; Optional long documentation slot
+
+  ;; Added AUTHOR, MAINTAINER, VERSION and LICENCE slots.
+  (author nil :type (or null string))
+  (licence nil :type (or null string))
+  (maintainer nil :type (or null string))
+  (version nil :type (or null string))
+
+  ;; Added NON-REQUIRED-P slot.  Useful for optional items.
+  (non-required-p nil :type boolean)    ; If T a missing file or
+                                        ; sub-directory will not cause
+                                        ; an error.
   )
 
 
@@ -2340 +2500 @@
    (component :reader missing-component-component
               :initarg :component)
    )
-  (:default-initargs :component nil)
+  #-gcl (:default-initargs :component nil)
   (:report (lambda (mmc stream)
              (format stream "MK:DEFSYSTEM: missing component ~S for ~S."
                      (missing-component-name mmc)
@@ -2366 +2526 @@
 
 
 (defvar *file-load-time-table* (make-hash-table :test #'equal)
-  "Hash table of file-write-dates for the system definitions and
-   files in the system definitions.")
+  "Hash table of file-write-dates for the system definitions and files in the system definitions.")
+
+
 (defun component-load-time (component)
   (when component
     (etypecase component
@@ -2445 +2606 @@
 ;;; compute-system-path --
 
 (defun compute-system-path (module-name definition-pname)
-  (let* ((file-pathname
-          (make-pathname :name (etypecase module-name
-                                 (symbol (string-downcase
-                                          (string module-name)))
-                                 (string module-name))
+  (let* ((module-string-name
+          (etypecase module-name
+            (symbol (string-downcase
+                     (string module-name)))
+            (string module-name)))
+
+         (file-pathname
+          (make-pathname :name module-string-name
                          :type *system-extension*))
+
          (lib-file-pathname
-          (make-pathname :directory (list :relative module-name)
-                         :name (etypecase module-name
-                                 (symbol (string-downcase
-                                          (string module-name)))
-                                 (string module-name))
+          (make-pathname :directory (list :relative module-string-name)
+                         :name module-string-name
                          :type *system-extension*))
          )
     (or (when definition-pname          ; given pathname for system def
@@ -2466 +2628 @@
         (cond (*central-registry*
                (if (listp *central-registry*)
                    (dolist (registry *central-registry*)
-                     (let ((file (or (probe-file
-                                      (append-directories (if (consp registry)
-                                                              (eval registry)
-                                                              registry)
-                                                          file-pathname))
-                                     (probe-file
-                                      (append-directories (if (consp registry)
-                                                              (eval registry)
-                                                              registry)
-                                                          lib-file-pathname))
-                                     ))
-                           )
+                     (let* ((reg-path (registry-pathname registry))
+                            (file (or (probe-file
+                                       (append-directories
+                                        reg-path file-pathname))
+                                      (probe-file
+                                       (append-directories
+                                        reg-path lib-file-pathname)))))
                        (when file (return file))))
                    (or (probe-file (append-directories *central-registry*
                                                        file-pathname))
@@ -2497 +2654 @@
   (let ((system (ignore-errors (find-system system-name :error))))
     (if system
         (let ((system-def-pathname
-               (make-pathname :type "system"
-                              :defaults (pathname (component-full-pathname system :source))))
+               (make-pathname
+                :type "system"
+                :defaults (pathname (component-full-pathname system :source))))
               )
           (values system-def-pathname
                   (probe-file system-def-pathname)))
         (values nil nil))))
-         
-         
 
 
+
+
 #|
 
-(defun compute-system-path (module-name definition-pname)
+ (defun compute-system-path (module-name definition-pname)
   (let* ((filename (format nil "~A.~A"
                            (if (symbolp module-name)
                                (string-downcase (string module-name))
@@ -2523 +2681 @@
                (if (listp *central-registry*)
                    (dolist (registry *central-registry*)
                      (let ((file (probe-file
-                                  (append-directories (if (consp registry)
-                                                          (eval registry)
-                                                        registry)
-                                                      filename))))
+                                  (append-directories
+                                   (registry-pathname registry) filename))))
                        (when file (return file))))
                  (probe-file (append-directories *central-registry*
                                                  filename))))
@@ -2563 +2719 @@
          (error 'missing-system :name system-name)))
     (:load-or-nil
      (let ((system (get-system system-name)))
+       ;; (break "System ~S ~S." system-name system)
        (or (unless *reload-systems-from-disk* system)
            ;; If SYSTEM-NAME is a symbol, it will lowercase the
            ;; symbol's string.
@@ -2570 +2727 @@
            ;; string. So if case matters in the filename, use strings, not
            ;; symbols, wherever the system is named.
            (when (foreign-system-p system)
-             (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM." system)
+             (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM."
+                   system)
              (return-from find-system nil))
            (let ((path (compute-system-path system-name definition-pname)))
              (when (and path
@@ -2592 +2750 @@
     (:load
      (or (unless *reload-systems-from-disk* (get-system system-name))
          (when (foreign-system-p (get-system system-name))
-           (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM." system-name)
+           (warn "Foreign system ~S cannot be reloaded by MK:DEFSYSTEM."
+                 (get-system system-name))
            (return-from find-system nil))
          (or (find-system system-name :load-or-nil definition-pname)
              (error "Can't find system named ~s." system-name))))))
@@ -2616 +2775 @@
                     ~@[~&   Package: ~A~]~
                     ~&   Source: ~@[~A~] ~@[~A~] ~@[~A~]~
                     ~&   Binary: ~@[~A~] ~@[~A~] ~@[~A~]~
-                    ~@[~&   Depends On: ~A ~]~&   Components: ~{~15T~A~&~}"
+                    ~@[~&   Depends On: ~A ~]~&   Components:~{~15T~A~&~}"
             (component-type system)
             (component-name system)
             (component-host system)
@@ -2635 +2794 @@
         (describe-system component stream recursive)))||#
     system))
 
+
 (defun canonicalize-component-name (component)
   ;; Within the component, the name is a string.
   (if (typep (component-name component) 'string)
@@ -2646 +2806 @@
     (setf (component-name component)
           (string-downcase (string (component-name component))))))
 
+
 (defun component-pathname (component type)
   (when component
     (ecase type
       (:source (component-source-pathname component))
       (:binary (component-binary-pathname component))
       (:error  (component-error-pathname component)))))
+
+
 (defun component-error-pathname (component)
   (let ((binary (component-pathname component :binary)))
     (new-file-type binary *compile-error-file-type*)))
+
 (defsetf component-pathname (component type) (value)
   `(when ,component
      (ecase ,type
        (:source (setf (component-source-pathname ,component) ,value))
        (:binary (setf (component-binary-pathname ,component) ,value)))))
 
+
 (defun component-root-dir (component type)
   (when component
     (ecase type
       (:source (component-source-root-dir component))
       ((:binary :error) (component-binary-root-dir component))
       )))
+
 (defsetf component-root-dir (component type) (value)
   `(when ,component
      (ecase ,type
        (:source (setf (component-source-root-dir ,component) ,value))
        (:binary (setf (component-binary-root-dir ,component) ,value)))))
 
+
 (defvar *source-pathnames-table* (make-hash-table :test #'equal)
   "Table which maps from components to full source pathnames.")
+
+
 (defvar *binary-pathnames-table* (make-hash-table :test #'equal)
   "Table which maps from components to full binary pathnames.")
+
+
 (defparameter *reset-full-pathname-table* t
-  "If T, clears the full-pathname tables before each call to
-   OPERATE-ON-SYSTEM. Setting this to NIL may yield faster performance
-   after multiple calls to LOAD-SYSTEM and COMPILE-SYSTEM, but could
-   result in changes to system and language definitions to not take
-   effect, and so should be used with caution.")
+  "If T, clears the full-pathname tables before each call to OPERATE-ON-SYSTEM.
+Setting this to NIL may yield faster performance after multiple calls
+to LOAD-SYSTEM and COMPILE-SYSTEM, but could result in changes to
+system and language definitions to not take effect, and so should be
+used with caution.")
+
+
 (defun clear-full-pathname-tables ()
   (clrhash *source-pathnames-table*)
   (clrhash *binary-pathnames-table*))
 
+
 (defun component-full-pathname (component type &optional (version *version*))
   (when component
     (case type
@@ -2705 +2879 @@
       (otherwise
        (component-full-pathname-i component type version)))))
 
-(defun component-full-pathname-i (component type &optional (version *version*)
+
+(defun component-full-pathname-i (component type
+                                            &optional (version *version*)
                                             &aux version-dir version-replace)
   ;; If the pathname-type is :binary and the root pathname is null,
   ;; distribute the binaries among the sources (= use :source pathname).
@@ -2715 +2891 @@
       (multiple-value-setq (version-dir version-replace)
         (translate-version version))
       (setq version-dir *version-dir* version-replace *version-replace*))
+  ;; (format *trace-output* "~&>>>> VERSION COMPUTED ~S ~S~%" version-dir version-replace)
   (let ((pathname
          (append-directories
           (if version-replace
@@ -2740 +2917 @@
     ;; :name argument to the MAKE-PATHNAME in the MERGE-PATHNAMES
     ;; beacuse of possible null names (e.g. :defsystem components)
     ;; causing problems with the subsequenct call to NAMESTRING.
+    ;; (format *trace-output* "~&>>>> PATHNAME is ~S~%" pathname)
+
+    ;; 20050309 Marco Antoniotti
+    ;; The treatment of PATHNAME-HOST and PATHNAME-DEVICE in the call
+    ;; to MAKE-PATHNAME in the T branch is bogus.   COMPONENT-DEVICE
+    ;; and COMPONENT-HOST must respect the ANSI definition, hence,
+    ;; they cannot be PATHNAMEs.  The simplification of the code is
+    ;; useful.  SCL compatibility may be broken, but I doubt it will.
+
+    ;; 20050310 Marco Antoniotti
+    ;; After a suggestion by David Tolpin, the code is simplified even
+    ;; more, and the logic should be now more clear: use the user
+    ;; supplied pieces of the pathname if non nil.
+
+    ;; 20050613 Marco Antoniotti
+    ;; Added COMPONENT-NAME extraction to :NAME part, in case the
+    ;; PATHNAME-NAME is NIL.
+
     (cond ((pathname-logical-p pathname) ; See definition of test above.
            (setf pathname
                  (merge-pathnames pathname
@@ -2747 +2942 @@
                                    :name (component-name component)
                                    :type (component-extension component
                                                               type))))
-           ;;(format t "new path = ~A~%" pathname)
            (namestring (translate-logical-pathname pathname)))
           (t
            (namestring
-            (make-pathname :host (when (component-host component)
-                                   ;; MCL2.0b1 and ACLPC cause an error on
-                                   ;; (pathname-host nil)
-                                   (pathname-host (component-host component)
-                                                  #+scl :case #+scl :common
-                                                  ))
+            (make-pathname :host (or (component-host component)
+                                     (pathname-host pathname))
+
                            :directory (pathname-directory pathname
-                                                  #+scl :case #+scl :common
-                                                  )
-                           ;; Use :directory instead of :defaults
-                           :name (pathname-name pathname
-                                                  #+scl :case #+scl :common
-                                                  )
-                           :type #-scl (component-extension component type)
-                                 #+scl (string-upcase
-                                        (component-extension component type))
+                                                          #+scl :case
+                                                          #+scl :common
+                                                          )
+
+                           :name (or (pathname-name pathname
+                                                    #+scl :case
+                                                    #+scl :common
+                                                    )
+                                     (component-name component))
+
+                           :type
+                           #-scl (component-extension component type)
+                           #+scl (string-upcase
+                                  (component-extension component type))
+
                            :device
                            #+sbcl
                            :unspecific
                            #-(or :sbcl)
-                           (let ((dev (component-device component)))
-                             (if dev
-                                 (pathname-device dev
-                                                  #+scl :case #+scl :common
-                                                  )
-                                 (pathname-device pathname
-                                                  #+scl :case #+scl :common
-                                                  )))
+                           (or (component-device component)
+                               (pathname-device pathname
+                                                #+scl :case
+                                                #+scl :common
+                                                ))
                            ;; :version :newest
                            ))))))
 
-;;; What about CMU17 :device :unspecific in the above?
 
+#-lispworks
 (defun translate-version (version)
   ;; Value returns the version directory and whether it replaces
   ;; the entire root (t) or is a subdirectory.
@@ -2803 +2997 @@
          (values version t))
         (t (error "~&; Illegal version ~S" version))))
 
+
+;;; Looks like LW has a bug in MERGE-PATHNAMES.
+;;;
+;;;  (merge-pathnames "" "LP:foo;bar;") ==> "LP:"
+;;;
+;;; Which is incorrect.
+;;; The change here ensures that the result of TRANSLATE-VERSION is
+;;; appropriate.
+
+#+lispworks
+(defun translate-version (version)
+  ;; Value returns the version directory and whether it replaces
+  ;; the entire root (t) or is a subdirectory.
+  ;; Version may be nil to signify no subdirectory,
+  ;; a symbol, such as alpha, beta, omega, :alpha, mark, which
+  ;; specifies a subdirectory of the root, or
+  ;; a string, which replaces the root.
+  (cond ((null version)
+         (values (pathname "") nil))
+        ((symbolp version)
+         (values (let ((sversion (string version)))
+                   (if (find-if #'lower-case-p sversion)
+                       (pathname sversion)
+                       (pathname (string-downcase sversion))))
+                 nil))
+        ((stringp version)
+         (values (pathname version) t))
+        (t (error "~&; Illegal version ~S" version))))
+
+
 (defun component-extension (component type &key local)
   (ecase type
     (:source (or (component-source-extension component)
                  (unless local
-                   (default-source-extension component)))) ; system default
+                   (default-source-extension component)) ; system default
+                 ;; (and (component-language component))
+                 ))
     (:binary (or (component-binary-extension component)
                  (unless local
-                   (default-binary-extension component)))) ; system default
+                   (default-binary-extension component)) ; system default
+                 ;; (and (component-language component))
+                 ))
     (:error  *compile-error-file-type*)))
+
+
 (defsetf component-extension (component type) (value)
   `(ecase ,type
      (:source (setf (component-source-extension ,component) ,value))
      (:binary (setf (component-binary-extension ,component) ,value))
      (:error  (setf *compile-error-file-type* ,value))))
 
+
 ;;; ********************************
 ;;; System Definition **************
 ;;; ********************************
+
 (defun create-component (type name definition-body &optional parent (indent 0))
   (let ((component (apply #'make-component
                           :type type
                           :name name
-                          :indent indent definition-body)))
+                          :indent indent
+                          definition-body)))
     ;; Set up :load-only attribute
     (unless (find :load-only definition-body)
       ;; If the :load-only attribute wasn't specified,
@@ -2868 +3101 @@
 
     ;; Type specific setup:
     (when (or (eq type :defsystem) (eq type :system) (eq type :subsystem))
-      (setf (get-system name) component))
+      (setf (get-system name) component)
+      #|(unless (component-language component)
+        (setf (component-language component) :lisp))|#)
 
     ;; Set up the component's pathname
     (create-component-pathnames component parent)
@@ -2891 +3126 @@
     component))
 
 
+;;; preprocess-component-definition --
+;;; New function introduced to manipulate the "evaluated" slots as per
+;;; SDS' suggestions.
+;;; 20050824
+
+(defun preprocess-component-definition (definition-body)
+  `(list* ,@(loop for slot in *component-evaluated-slots*
+                  for value = (getf definition-body slot)
+                  when value
+                    do (remf definition-body slot)
+                    and nconc `(,slot ,value))
+          ,@(loop for slot in *component-form-slots*
+                  for form = (getf definition-body slot)
+                  do (remf definition-body slot)
+                  nconc `(,slot (lambda () ,form)))
+          ',definition-body))
+
+
 ;;; defsystem --
 ;;; The main macro.
 ;;;
@@ -2905 +3158 @@
   (unless (find :source-pathname definition-body)
     (setf definition-body
           (list* :source-pathname
-                 '(when *load-pathname*
-                        (make-pathname :name nil
-                                       :type nil
-                                       :defaults *load-pathname*))
+                 '(when #-gcl *load-pathname* #+gcl si::*load-pathname*
+                    (make-pathname :name nil
+                                   :type nil
+                                   :defaults
+                                   #-gcl *load-pathname*
+                                   #+gcl si::*load-pathname*
+                                   ))
                  definition-body)))
-  `(create-component :defsystem ',name ',definition-body nil 0))
+  `(create-component :defsystem ',name
+                     ,(preprocess-component-definition definition-body)
+                     nil
+                     0))
 
+
 (defun create-component-pathnames (component parent)
   ;; Set up language-specific defaults
+
   (setf (component-language component)
         (or (component-language component) ; for local defaulting
             (when parent                ; parent's default
               (component-language parent))))
+
   (setf (component-compiler component)
         (or (component-compiler component) ; for local defaulting
             (when parent                ; parent's default
@@ -2939 +3201 @@
   (setf (component-pathname component :binary)
         (eval (component-pathname component :binary)))
 
+
   ;; Pass along the host and devices
   (setf (component-host component)
         (or (component-host component)
-            (when parent (component-host parent))))
+            (when parent (component-host parent))
+            (pathname-host *default-pathname-defaults*)))
   (setf (component-device component)
         (or (component-device component)
             (when parent (component-device parent))))
 
   ;; Set up extension defaults
   (setf (component-extension component :source)
-        (or (component-extension component :source :local t) ; local default
+        (or (component-extension component :source
+                                 :local #| (component-language component) |#
+                                 t
+                                 ) ; local default
+            (when (component-language component)
+              (default-source-extension component))
             (when parent                ; parent's default
               (component-extension parent :source))))
   (setf (component-extension component :binary)
-        (or (component-extension component :binary  :local t) ; local default
+        (or (component-extension component :binary
+                                 :local #| (component-language component) |#
+                                 t
+                                 ) ; local default
+            (when (component-language component)
+              (default-binary-extension component))
             (when parent                ; parent's default
               (component-extension parent :binary))))
 
@@ -2963 +3237 @@
   (generate-component-pathname component parent :source)
   (generate-component-pathname component parent :binary))
 
-;; maybe file's inheriting of pathnames should be moved elsewhere?
+
+;;; generate-component-pathnames --
+;;; maybe file's inheriting of pathnames should be moved elsewhere?
+
 (defun generate-component-pathname (component parent pathname-type)
   ;; Pieces together a pathname for the component based on its component-type.
   ;; Assumes source defined first.
@@ -3010 +3287 @@
                  ;; When the binary-pathname is nil use source.
                  (component-pathname component :source))
                (or (when (component-pathname component pathname-type)
-;                    (pathname-name )
+                     ;; (pathname-name )
                      (component-pathname component pathname-type))
                    (component-name component)))))
     ((:module :subsystem)                       ; Pathname relative to parent.
@@ -3059 +3336 @@
                                                               indent))
                              definitions)))))
 ||#
-;; new version
+
+;;; new version
 (defun expand-component-components (component &optional (indent 0))
   (let ((definitions (component-components component)))
     (if (eq (car definitions) :serial)
@@ -3069 +3347 @@
         (setf (component-components component)
               (expand-component-definitions definitions component indent)))))
 
+
 (defun expand-component-definitions (definitions parent &optional (indent 0))
   (let ((components nil))
     (dolist (definition definitions)
@@ -3076 +3355 @@
         (when new (push new components))))
     (nreverse components)))
 
+
 (defun expand-serial-component-chain (definitions parent &optional (indent 0))
   (let ((previous nil)
         (components nil))
@@ -3101 +3381 @@
    recognizes absolute pathnames and treats them as files of type
    :private-file instead of type :file. Defaults to NIL, because I
    haven't tested this.")
+
+
 (defun absolute-file-namestring-p (string)
   ;; If a FILE namestring starts with a slash, or is a logical pathname
   ;; as implied by the existence of a colon in the filename, assume it
@@ -3109 +3391 @@
       (and (not (null-string string))
            (char= (char string 0) #\/))))
 
+
 (defun expand-component-definition (definition parent &optional (indent 0))
   ;; Should do some checking for malformed definitions here.
   (cond ((null definition) nil)
@@ -3118 +3401 @@
                   (absolute-file-namestring-p definition))
              ;; Special hack for Straz
              (create-component :private-file definition nil parent indent)
-           ;; Normal behavior
-           (create-component :file definition nil parent indent)))
+             ;; Normal behavior
+             (create-component :file definition nil parent indent)))
         ((and (listp definition)
               (not (member (car definition)
                            '(:defsystem :system :subsystem
-                             :module :file :private-file))))
+                              :module :file :private-file))))
          ;; Lists whose first element is not a component type
          ;; are assumed to be of type :file
          (create-component :file
-                           (car definition)
-                           (cdr definition)
+                           (first definition)
+                           ;; (preprocess-component-definition (rest definition)) ; Not working.
+                           (rest definition)
                            parent
                            indent))
         ((listp definition)
          ;; Otherwise, it is (we hope) a normal form definition
-         (create-component (car definition)   ; type
-                           (cadr definition)  ; name
-                           (cddr definition)  ; definition body
+         (create-component (first definition)   ; type
+                           (second definition)  ; name
+
+                           ;; definition body
+                           ;; (preprocess-component-definition (cddr definition)) ; Not working.
+                           (cddr definition)
+
                            parent             ; parent
                            indent)            ; indent
          )))
 
+
 (defun link-component-depends-on (components)
   (dolist (component components)
     (unless (and *system-dependencies-delayed*
@@ -3156 +3445 @@
 
                     (component-depends-on component))))))
 
+
 ;;; ********************************
 ;;; Topological Sort the Graph *****
 ;;; ********************************
@@ -3164 +3454 @@
 ;;; this version avoids the call to sort, in practice it isn't faster. It
 ;;; does, however, eliminate the need to have a TIME slot in the
 ;;; topological-sort-node defstruct.
+
 (defun topological-sort (list &aux (sorted-list nil))
   (labels ((dfs-visit (znode)
-              (setf (topsort-color znode) :gray)
-              (unless (and *system-dependencies-delayed*
-                           (eq (component-type znode) :system))
-                (dolist (child (component-depends-on znode))
-                  (cond ((eq (topsort-color child) :white)
-                         (dfs-visit child))
-                        ((eq (topsort-color child) :gray)
-                         (format t "~&Detected cycle containing ~A" child)))))
-              (setf (topsort-color znode) :black)
-              (push znode sorted-list)))
+             (setf (topsort-color znode) :gray)
+             (unless (and *system-dependencies-delayed*
+                          (eq (component-type znode) :system))
+               (dolist (child (component-depends-on znode))
+                 (cond ((eq (topsort-color child) :white)
+                        (dfs-visit child))
+                       ((eq (topsort-color child) :gray)
+                        (format t "~&Detected cycle containing ~A" child)))))
+             (setf (topsort-color znode) :black)
+             (push znode sorted-list)))
     (dolist (znode list)
       (setf (topsort-color znode) :white))
     (dolist (znode list)
@@ -3230 +3521 @@
 ;; probably should remove the ",1" entirely. But AKCL 1.243 dies on it
 ;; because of an AKCL bug.
 ;; KGK suggests using an 8 instead, but 1 does nicely.
+
 (defun prompt-string (component)
   (format nil "; ~:[~;TEST:~]~V,1@T "
           *oos-test*
@@ -3265 +3557 @@
                     (format stream "~%~A  ~A" prompt content)))))))
   (finish-output stream))
 
+
 (defun tell-user (what component &optional type no-dots force)
   (when (or *oos-verbose* force)
     (format-justified-string (prompt-string component)
@@ -3294 +3587 @@
              (and *tell-user-when-done*
                   (not no-dots))))))
 
+
 (defun tell-user-done (component &optional force no-dots)
   ;; test is no longer really used, but we're leaving it in.
   (when (and *tell-user-when-done*
@@ -3302 +3596 @@
             (prompt-string component) (not no-dots))
     (finish-output *standard-output*)))
 
+
 (defmacro with-tell-user ((what component &optional type no-dots force) &body body)
   `(progn
      (tell-user ,what ,component ,type ,no-dots ,force)
      ,@body
      (tell-user-done ,component ,force ,no-dots)))
 
+
 (defun tell-user-no-files (component &optional force)
   (when (or *oos-verbose* force)
     (format-justified-string (prompt-string component)
@@ -3317 +3613 @@
               (or *load-source-if-no-binary* *load-source-instead-of-binary*)
               (component-full-pathname component :binary)))))
 
+
 (defun tell-user-require-system (name parent)
   (when *oos-verbose*
     (format t "~&; ~:[~;TEST:~] - System ~A requires ~S"
             *oos-test* (component-name parent) name)
     (finish-output *standard-output*)))
 
+
 (defun tell-user-generic (string)
   (when *oos-verbose*
     (format t "~&; ~:[~;TEST:~] - ~A"
             *oos-test* string)
     (finish-output *standard-output*)))
 
+
 ;;; ********************************
 ;;; Y-OR-N-P-WAIT ******************
 ;;; ********************************
@@ -3353 +3652 @@
      Lisps, this allows other processes to continue while we busy-wait. If
      0, skips call to SLEEP.")
 
+
 (defun internal-real-time-in-seconds ()
   (get-universal-time))
 
+
 (defun read-char-wait (&optional (timeout 20) input-stream
                                  (eof-error-p t) eof-value
                                  &aux peek)
@@ -3368 +3669 @@
     (unless (zerop *sleep-amount*)
       (sleep *sleep-amount*))))
 
+
 ;;; Lots of lisps, especially those that run on top of UNIX, do not get
 ;;; their input one character at a time, but a whole line at a time because
 ;;; of the buffering done by the UNIX system. This causes y-or-n-p-wait
@@ -3422 +3724 @@
        (y-or-n-p-wait #\y 10 "1? ")
        (y-or-n-p-wait #\n 10 "2? "))
 ||#
+
+;;;===========================================================================
+;;; Running the operations.
+
+(defvar %%component%% nil)
+
+(export '(%%component%%)) ; Just a placeholder. Move it to the export list.
+
+
+(defmacro with-special-component-vars ((c) &body forms)
+  `(let ((%%component%% ,c))
+    (declare (special %%component%%))
+    ,@forms))
+
+
 ;;; ********************************
 ;;; Operate on System **************
 ;;; ********************************
@@ -3466 +3783 @@
   (declare #-(or :cltl2 :ansi-cl) (ignore override-compilation-unit))
   (unwind-protect
       ;; Protect the undribble.
-      (#+(or :cltl2 :ansi-cl) with-compilation-unit
-         #+(or :cltl2 :ansi-cl) (:override override-compilation-unit)
-         #-(or :cltl2 :ansi-cl) progn
+      (#+(and (or :cltl2 :ansi-cl) (not :gcl)) with-compilation-unit
+         #+(and (or :cltl2 :ansi-cl) (not :gcl)) (:override override-compilation-unit)
+         #-(and (or :cltl2 :ansi-cl) (not :gcl)) progn
         (when *reset-full-pathname-table* (clear-full-pathname-tables))
         (when dribble (dribble dribble))
         (when test (setq verbose t))
@@ -3506 +3823 @@
                 (*load-source-instead-of-binary* load-source-instead-of-binary)
                 (*minimal-load* minimal-load)
                 (system (if (and (component-p name)
-                                 (member (component-type name) '(:system :defsystem :subsystem)))
+                                 (member (component-type name)
+                                         '(:system :defsystem :subsystem)))
                             name
                             (find-system name :load))))
             #-(or CMU CLISP :sbcl :lispworks :cormanlisp scl)
@@ -3516 +3834 @@
                      #-openmcl (optimize (inhibit-warnings 3)))
             (unless (component-operation operation)
               (error "Operation ~A undefined." operation))
+
             (operate-on-component system operation force))))
     (when dribble (dribble))))
 
@@ -3614 +3933 @@
    :verbose verbose
    :dribble dribble))
 
+
+;;; ensure-external-system-def-loaded component --
+;;; Let's treat definition clauses of the form
+;;;
+;;;     (:system "name")
+;;; i.e.
+;;;
+;;;     (:system "name" :components nil)
+;;;
+;;; in a special way.
+;;; When encountered, MK:DEFSYSTEM tries to FIND-SYSTEM
+;;; the system named "name" (by forcing a reload from disk).
+;;; This may be more "natural".
+
+(defun ensure-external-system-def-loaded (component)
+  (assert (member (component-type component)
+                  '(:subsystem :system)))
+  (when (null (component-components component))
+    (let* ((cname (component-name component)))
+      (declare (ignorable cname))
+      ;; First we ensure that we reload the system definition.
+      (undefsystem cname)
+      (let* ((*reload-systems-from-disk* t)
+             (system-component
+              (find-system (component-name component)
+                           :load
+
+                           ;; Let's not supply the def-pname
+                           ;; yet.
+                           #+not-yet
+                           (merge-pathname
+                            (make-pathname :name cname
+                                           :type "system"
+                                           :directory ())
+                            (component-full-pathname component
+                                                     :source))
+
+
+                           ))
+             )
+        ;; Now we have a problem.
+        ;; We have just ensured that a system definition is
+        ;; loaded, however, the COMPONENT at hand is different
+        ;; from SYSTEM-COMPONENT.
+        ;; To fix this problem we just use the following
+        ;; kludge.  This should prevent re-entering in this
+        ;; code branch, while actually preparing the COMPONENT
+        ;; for operation.
+        (setf (component-components component)
+              (list system-component))
+        ))))
+
+
 (defun operate-on-component (component operation force &aux changed)
   ;; Returns T if something changed and had to be compiled.
   (let ((type (component-type component))
@@ -3646 +4018 @@
               (let ((package (find-package (component-package component))))
                 (when package
                   (setf *package* package)))))
-          #+mk-original
-          (when (eq type :defsystem)    ; maybe :system too?
-            (operate-on-system-dependencies component operation force))
+
+          ;; Marco Antoniotti 20040609
+          ;; New feature.  Try to FIND-SYSTEM :system components if
+          ;; they have no local :components definition.
+          ;; OPERATE-ON-SYSTEM-DEPENDENCIES should still work as
+          ;; advertised, given the small change made there.
+
+          (when (or (eq type :system) (eq type :subsystem))
+            (ensure-external-system-def-loaded component))
+
           (when (or (eq type :defsystem) (eq type :system))
             (operate-on-system-dependencies component operation force))
 
@@ -3656 +4035 @@
           (when (component-proclamations component)
             (tell-user-generic (format nil "Doing proclamations for ~A"
                                        (component-name component)))
-            (or *oos-test*
-                (proclaim (component-proclamations component))))
+            (unless *oos-test*
+              (proclaim (component-proclamations component))))
 
           ;; Do any initial actions
           (when (component-initially-do component)
             (tell-user-generic (format nil "Doing initializations for ~A"
                                        (component-name component)))
-            (or *oos-test*
-                (eval (component-initially-do component))))
+            (unless *oos-test*
+              (with-special-component-vars (component)
+                 (let ((initially-do (component-initially-do component)))
+                   (if (functionp initially-do)
+                       (funcall initially-do)
+                       (eval initially-do))))
+              ))
 
           ;; If operation is :compile and load-only is T, this would change
           ;; the operation to load. Only, this would mean that a module would
@@ -3692 +4076 @@
           (when (component-finally-do component)
             (tell-user-generic (format nil "Doing finalizations for ~A"
                                        (component-name component)))
-            (or *oos-test*
-                (eval (component-finally-do component))))
+            (unless *oos-test*
+              (with-special-component-vars (component)
+                 (let ((finally-do (component-finally-do component)))
+                   (if (functionp finally-do)
+                       (funcall finally-do)
+                       (eval finally-do))))
+                ))
 
           ;; add the banner if needed
           #+(or cmu scl)
@@ -3737 +4126 @@
         ;; to load it (needed since we may be depending on a lisp
         ;; dependent package).
         ;; Explores the system tree in a DFS manner.
-        (cond ((and *operations-propagate-to-subsystems*
-                    (not (listp system))
-                    ;; The subsystem is a defined system.
-                    (find-system system :load-or-nil))
-               ;; Call OOS on it. Since *system-dependencies-delayed* is
-               ;; T, the :depends-on slot is filled with the names of
-               ;; systems, not defstructs.
-               ;; Aside from system, operation, force, for everything else
-               ;; we rely on the globals.
-               (unless (and *providing-blocks-load-propagation*
-                            ;; If *providing-blocks-load-propagation* is T,
-                            ;; the system dependency must not exist in the
-                            ;; *modules* for it to be loaded. Note that
-                            ;; the dependencies are implicitly systems.
-                            (find operation '(load :load))
-                            ;; (or (eq force :all) (eq force t))
-                            (find (canonicalize-system-name system)
-                                  *modules* :test #'string-equal))
-                 
-                 (operate-on-system system operation :force force)))
 
-              ((listp system)
+        ;; Do not try to do anything with non system components.
+        (cond ((and *operations-propagate-to-subsystems*
+                    (not (listp system))
+                    (or (stringp system) (symbolp system))
+                    ;; The subsystem is a defined system.
+                    (find-system system :load-or-nil))
+               ;; Call OOS on it. Since *system-dependencies-delayed* is
+               ;; T, the :depends-on slot is filled with the names of
+               ;; systems, not defstructs.
+               ;; Aside from system, operation, force, for everything else
+               ;; we rely on the globals.
+               (unless (and *providing-blocks-load-propagation*
+                            ;; If *providing-blocks-load-propagation* is T,
+                            ;; the system dependency must not exist in the
+                            ;; *modules* for it to be loaded. Note that
+                            ;; the dependencies are implicitly systems.
+                            (find operation '(load :load))
+                            ;; (or (eq force :all) (eq force t))
+                            (find (canonicalize-system-name system)
+                                  *modules* :test #'string-equal))
+
+                 (operate-on-system system operation :force force)))
+
+              ((listp system)
                ;; If the SYSTEM is a list then its contents are as follows.
                ;;
-               ;;    (<name> <definition-pathname> <action> <version>)
+               ;;    (<name> <definition-pathname> <action> &optional <version>)
                ;;
-               (tell-user-require-system
-                (cond ((and (null (first system)) (null (second system)))
-                       (third system))
-                      (t system))
-                component)
-               (or *oos-test* (new-require (first system)
-                                           nil
-                                           (eval (second system))
-                                           (third system)
-                                           (or (fourth system)
-                                               *version*))))
-              (t
-               (tell-user-require-system system component)
-               (or *oos-test* (new-require system))))))))
 
+               (destructuring-bind (system-name definition-pathname action
+                                                &optional version)
+                   system
+                 (tell-user-require-system
+                  (if (and (null system-name)
+                           (null definition-pathname))
+                      action
+                      system)
+                  component)
+                 (or *oos-test* (new-require system-name
+                                             nil
+                                             (eval definition-pathname)
+                                             action
+                                             (or version *version*)))))
+              ((and (component-p system)
+                    (not (member (component-type system)
+                                 '(:defsystem :subsystem :system))))
+               ;; Do nothing for non system components.
+               )
+              (t
+               (tell-user-require-system system component)
+               (or *oos-test* (new-require system))))
+        ))))
+
 ;;; Modules can depend only on siblings. If a module should depend
 ;;; on an uncle, then the parent module should depend on that uncle
 ;;; instead. Likewise a module should depend on a sibling, not a niece
@@ -3815 +4217 @@
             (push module changed)))
         (case operation
           ((compile :compile)
-           (eval (component-compile-form component)))
+           (with-special-component-vars (component)
+             (let ((compile-form (component-compile-form component)))
+               (if (functionp compile-form)
+                   (funcall compile-form)
+                   (eval compile-form)))))
           ((load :load)
-           (eval (component-load-form component))))))
+           (with-special-component-vars (component)
+             (let ((load-form (component-load-form component)))
+               (if (functionp load-form)
+                   (funcall load-form)
+                   (eval load-form)))
+             )))))
   ;; This is only used as a boolean.
   changed)
 
@@ -3847 +4258 @@
                     (version *version*))
   ;; If the pathname is present, this behaves like the old require.
   (unless (and module-name
+               ;; madhu: Allegro cannot coerce pathnames to strings
+               ;; via (string #p"foo") and module-name turns out to be
+               ;; a pathname when REQUIRE is used internally to load
+               ;; internal modules.
+               #+allegro
+               (and (pathnamep module-name)
+                    (setq module-name (namestring module-name)))
                (find (string module-name)
                      *modules* :test #'string=))
     (handler-case
@@ -3880 +4298 @@
                ||#
                (error 'missing-system :name module-name)))
       (missing-module (mmc) (signal mmc)) ; Resignal.
+      ;; madhu 080902 a missing-system is incorrectly signalled when
+      ;; mk:oos throws an error.
+      #+nil
       (error (e)
              (declare (ignore e))
              ;; Signal a (maybe wrong) MISSING-SYSTEM.
@@ -3910 +4331 @@
                          #+:lispworks 'system:::require
                          #+(and :excl :allegro-v4.0) 'cltl1:require))
 
-  (let (#+(or :CCL :openmcl) (ccl:*warn-if-redefine-kernel* nil))
+  (let (#+:CCL (ccl:*warn-if-redefine-kernel* nil))
     ;; Note that lots of lisps barf if we redefine a function from
     ;; the LISP package. So what we do is define a macro with an
     ;; unused name, and use (setf macro-function) to redefine
@@ -3937 +4358 @@
 (unless *old-require*
   (setf *old-require*
         (symbol-function
-         #-(or (and :excl :allegro-v4.0) :mcl :openmcl :sbcl :lispworks) 'lisp:require
+         #-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require
          #+(and :excl :allegro-v4.0) 'cltl1:require
          #+:sbcl 'cl:require
          #+:lispworks3.1 'common-lisp::require
@@ -3947 +4368 @@
          ))
 
   (unless *dont-redefine-require*
-    (let (#+(or :mcl :openmcl (and :CCL (not :lispworks)))
+    (let (#+(or :mcl (and :CCL (not :lispworks)))
           (ccl:*warn-if-redefine-kernel* nil))
       #-(or (and allegro-version>= (version>= 4 1)) :lispworks)
       (setf (symbol-function
-             #-(or (and :excl :allegro-v4.0) :mcl :openmcl :sbcl :lispworks) 'lisp:require
+             #-(or (and :excl :allegro-v4.0) :mcl :sbcl :lispworks) 'lisp:require
              #+(and :excl :allegro-v4.0) 'cltl1:require
              #+:lispworks3.1 'common-lisp::require
              #+:sbcl 'cl:require
@@ -3976 +4397 @@
          (symbol-function 'new-require))))))
 )
 
+
+;;; Well, let's add some more REQUIRE hacking; specifically for SBCL,
+;;; and, eventually, for CMUCL.
+
+#+sbcl
+(eval-when (:compile-toplevel :load-toplevel :execute)
+
+(defun sbcl-mk-defsystem-module-provider (name)
+  ;; Let's hope things go smoothly.
+    (let ((module-name (string-downcase (string name))))
+      (when (mk:find-system module-name :load-or-nil)
+        (mk:load-system module-name
+                        :compile-during-load t
+                        :verbose nil))))
+
+(pushnew 'sbcl-mk-defsystem-module-provider sb-ext:*module-provider-functions*)
+)
+
+#+#.(cl:if (cl:and (cl:find-package "EXT") (cl:find-symbol "*MODULE-PROVIDER-FUNCTIONS*" "EXT")) '(and) '(or))
+(progn
+  (defun cmucl-mk-defsystem-module-provider (name)
+    (let ((module-name (string-downcase (string name))))
+      (when (mk:find-system module-name :load-or-nil)
+        (mk:load-system module-name
+                        :compile-during-load t
+                        :verbose nil))))
+
+  (pushnew 'cmucl-mk-defsystem-module-provider ext:*module-provider-functions*)
+  )
+
+
+
+
 ;;; ********************************
 ;;; Language-Dependent Characteristics
 ;;; ********************************
@@ -4106 +4560 @@
   (error "MK::RUN-UNIX-PROGRAM: this does not seem to be a UN*X system.")
   )
 
+
+;;; This is inspired by various versions - all very UNIX/Linux
+;;; dependent - appearing in ASDF and UFFI.  The original versions and Copyrights
+;;; are by Dan Barlow, Kevin Rosenberg and many others.
+;;; This version should be more liberal.
+
+(defvar *default-shell* "/bin/sh")
+
+#+(or windows ms-windows win32)
+(eval-when (:load-toplevel :execute)
+  ;; Lets assume a "standard" Cygwin installation.
+  (if (probe-file (pathname "C:\\cygwin\\bin\\sh.exe"))
+      (setf *default-shell* "C:\\cygwin\\bin\\sh.exe")
+      (setf *default-shell* nil)))
+
+
+(defun run-shell-command (command-control-string
+                          arguments
+                          &key
+                          (output *trace-output*)
+                          (shell *default-shell*)
+                          )
+   "Executes a shell 'command' in an underlying process.
+RUN-SHELL-COMMAND interpolate ARGS into CONTROL-STRING as if by FORMAT, and
+synchronously execute the result using a Bourne-compatible shell, with
+output to *trace-output*.  Returns the shell's exit code."
+
+   (declare (ignorable shell))
+
+  (let ((command (apply #'format nil command-control-string arguments)))
+    #+sbcl
+    (sb-impl::process-exit-code
+     (sb-ext:run-program shell
+                         (list "-c" command)
+                         :input nil
+                         :output output))
+
+    #+(or cmu scl)
+    (ext:process-exit-code
+     (ext:run-program shell
+                      (list "-c" command)
+                      :input nil
+                      :output output))
+
+    #+allegro
+    (excl:run-shell-command command :input nil :output output)
+
+    #+(and lispworks win32)
+    (system:call-system-showing-output (format nil "cmd /c ~A" command)
+                                       :output-stream output)
+
+    #+(and lispworks (not win32))
+    (system:call-system-showing-output command
+                                       :shell-type shell
+                                       :output-stream output)
+
+    #+clisp                             ;XXX not exactly *trace-output*, I know
+    (ext:run-shell-command command :output :terminal :wait t)
+
+    #+openmcl
+    (nth-value 1
+               (ccl:external-process-status
+                (ccl:run-program shell
+                                 (list "-c" command)
+                                 :input nil
+                                 :output output
+                                 :wait t)))
+
+    #-(or openmcl clisp lispworks allegro scl cmu sbcl)
+    (error "RUN-SHELL-PROGRAM not implemented for this Lisp")
+    ))
+
+
 #||
 (defun c-compile-file (filename &rest args &key output-file error-file)
   ;; gcc -c foo.c -o foo.o
@@ -4219 +4746 @@
                 fatal-error)))))
 
 
+;;; C Language definitions.
+
 (defun c-compile-file (filename &rest args
                                 &key
                                 (output-file t)
@@ -4278 +4807 @@
           #+:allegro #'load
           #+(or :cmu :scl) #'alien:load-foreign
           #+:sbcl #'sb-alien:load-foreign
-          #+(and :lispworks :unix (not :linux)) #'link-load:read-foreign-modules
-          #+(and :lispworks (or (not :unix) :linux)) #'fli:register-module
+          #+(and :lispworks :unix (not :linux) (not :macosx)) #'link-load:read-foreign-modules
+          #+(and :lispworks :unix (or :linux :macosx)) #'fli:register-module
+          #+(and :lispworks :win32) #'fli:register-module
           #+(or :ecl :gcl :kcl) #'load ; should be enough.
           #-(or :lucid
                 :allegro
@@ -4297 +4827 @@
   :source-extension "c"
   :binary-extension "o")
 
-#||
-;;; FDMM's changes, which we've replaced.
-(defvar *compile-file-function* #'cl-compile-file)
 
-#+(or :clos :pcl)
-(defmethod set-language ((lang (eql :common-lisp)))
-  (setq *compile-file-function* #'cl-compile-file))
+;;; Fortran Language definitions.
+;;; From Matlisp.
 
-#+(or :clos :pcl)
-(defmethod set-language ((lang (eql :scheme)))
-  (setq *compile-file-function #'scheme-compile-file))
-||#
+(export '(*fortran-compiler* *fortran-options*))
 
+(defparameter *fortran-compiler* "g77")
+(defparameter *fortran-options* '("-O"))
+
+(defun fortran-compile-file (filename &rest args
+                                      &key output-file error-file
+                                      &allow-other-keys)
+  (declare (ignore error-file args))
+  (let ((arg-list
+         (append *fortran-options*
+                 `("-c" ,filename ,@(if output-file `("-o" ,output-file))))))
+    (run-unix-program *fortran-compiler* arg-list)))
+
+
+(mk:define-language :fortran
+    :compiler #'fortran-compile-file
+    :loader #'identity
+    :source-extension "f"
+    :binary-extension "o")
+
+
+;;; AR support.
+;; How to create a library (archive) of object files
+
+(export '(*ar-program* build-lib))
+
+(defparameter *ar-program* "ar")
+
+(defun build-lib (libname directory)
+  (let ((args (list "rv" (truename libname))))
+    (format t ";;; Building archive ~A~%" libname)
+    (run-unix-program *ar-program*
+                      (append args
+                              (mapcar #'truename (directory directory))))))
+
+
 ;;; ********************************
 ;;; Component Operations ***********
 ;;; ********************************
 ;;; Define :compile/compile and :load/load operations
-(eval-when (load eval)
+(eval-when (:load-toplevel :execute)
 (component-operation :compile  'compile-and-load-operation)
 (component-operation 'compile  'compile-and-load-operation)
 (component-operation :load     'load-file-operation)
 (component-operation 'load     'load-file-operation)
 )
 
+
 (defun compile-and-load-operation (component force)
   ;; FORCE was CHANGED. this caused defsystem during compilation to only
   ;; load files that it immediately compiled.
@@ -4335 +4894 @@
         (and (load-file-operation component force) ; FORCE was CHANGED ???
              changed))))
 
+
 (defun unmunge-lucid (namestring)
   ;; Lucid's implementation of COMPILE-FILE is non-standard, in that
   ;; when the :output-file is a relative pathname, it tries to munge
@@ -4353 +4913 @@
          ;; Ugly, but seems to fix the problem.
          (concatenate 'string "./" namestring))))
 
+#+gcl
+(defun ensure-directories-exist (arg0 &key verbose)
+  (declare (ignore arg0 verbose))
+  ())
+
+
 (defun compile-file-operation (component force)
   ;; Returns T if the file had to be compiled.
   (let ((must-compile
@@ -4362 +4928 @@
               (or (find force '(:all :new-source-all t) :test #'eq)
                   (and (find force '(:new-source :new-source-and-dependents)
                              :test #'eq)
-                       (needs-compilation component)))))
+                       (needs-compilation component nil)))))
         (source-pname (component-full-pathname component :source)))
 
     (cond ((and must-compile (probe-file source-pname))
@@ -4389 +4955 @@
                           source-pname
                           :output-file
                           output-file
-                          #+(or :cmu :scl) :error-file
-                          #+(or :cmu :scl) (and *cmu-errors-to-file*
-                                                (component-full-pathname component
-                                                                         :error))
-                          #+CMU
+
+                          #+(or :cmu :scl)
+                          :error-file
+
+                          #+(or :cmu :scl)
+                          (and *cmu-errors-to-file*
+                               (component-full-pathname component :error))
+
+                          #+cmu
                           :error-output
-                          #+CMU
+                          #+cmu
                           *cmu-errors-to-terminal*
+
                           (component-compiler-options component)
                           ))))
            must-compile)
@@ -4406 +4977 @@
            nil)
           (t nil))))
 
-(defun needs-compilation (component)
+
+;;; compiled-file-p --
+;;; See CLOCC/PORT/sys.lisp:compiled-file-p
+
+(eval-when (:load-toplevel :execute :compile-toplevel)
+  (when (find-package "PORT")
+    (import (find-symbol "COMPILED-FILE-P" "PORT"))))
+
+(unless (fboundp 'compiled-file-p)
+  (defun compiled-file-p (file-name)
+    "Return T if the FILE-NAME is a filename designator for a valid compiled.
+Signal an error when it is not a filename designator.
+Return NIL when the file does not exist, or is not readable,
+or does not contain valid compiled code."
+    #+clisp
+    (with-open-file (in file-name :direction :input :if-does-not-exist nil)
+      (handler-bind ((error (lambda (c) (declare (ignore c))
+                                    (return-from compiled-file-p nil))))
+        (and in (char= #\( (peek-char nil in nil #\a))
+             (let ((form (read in nil nil)))
+               (and (consp form)
+                    (eq (car form) 'SYSTEM::VERSION)
+                    (null (eval form)))))))
+    #-clisp (declare (ignorable file-name))
+    #-clisp t))
+
+
+(defun needs-compilation (component force)
   ;; If there is no binary, or it is older than the source
   ;; file, then the component needs to be compiled.
   ;; Otherwise we only need to recompile if it depends on a file that changed.
+  (declare (ignore force))
   (let ((source-pname (component-full-pathname component :source))
-        (binary-pname (component-full-pathname component :binary)))
+        (binary-pname (component-full-pathname component :binary)))
     (and
      ;; source must exist
      (probe-file source-pname)
      (or
+      ;; We force recompilation.
+      #|(find force '(:all :new-source-all) :test #'eq)|#
       ;; no binary
       (null (probe-file binary-pname))
       ;; old binary
       (< (file-write-date binary-pname)
-         (file-write-date source-pname))))))
+         (file-write-date source-pname))
+      ;; invalid binary
+      (not (compiled-file-p binary-pname))))))
 
+
 (defun needs-loading (component &optional (check-source t) (check-binary t))
   ;; Compares the component's load-time against the file-write-date of
   ;; the files on disk.
@@ -4457 +5061 @@
          ;; needs-compilation has an implicit source-exists in it.
          (needs-compilation (if (component-load-only component)
                                 source-needs-loading
-                                (needs-compilation component)))
+                                (needs-compilation component force)))
          (check-for-new-source
           ;; If force is :new-source*, we're checking for files
           ;; whose source is newer than the compiled versions.
@@ -4470 +5074 @@
               (and load-binary (component-load-only component))
               (and check-for-new-source needs-compilation)))
          (compile-and-load
-          (and needs-compilation (or load-binary check-for-new-source)
-               (compile-and-load-source-if-no-binary component))))
+          (and needs-compilation
+               (or load-binary check-for-new-source)
+               (compile-and-load-source-if-no-binary component)))
+         )
     ;; When we're trying to minimize the files loaded to only those
     ;; that need be, restrict the values of load-source and load-binary
     ;; so that we only load the component if the files are newer than
     ;; the load-time.
-    (when *minimal-load*
+    (when (and *minimal-load*
+               (not (find force '(:all :new-source-all)
+                          :test #'eq)))
       (when load-source (setf load-source source-needs-loading))
       (when load-binary (setf load-binary binary-needs-loading)))
 
@@ -4497 +5105 @@
                            (or *load-source-instead-of-binary*
                                (component-load-only component)
                                (not *compile-during-load*)))
-                      (and load-binary (not binary-exists)
+                      (and load-binary
+                           (not binary-exists)
                            (load-source-if-no-binary component))))
              ;; Load the source if the source exists and:
              ;;   o  we're loading binary and it doesn't exist
@@ -4543 +5152 @@
             (and (find force '(:new-source :new-source-and-dependents
                                            :new-source-all)
                        :test #'eq)
-                 (needs-compilation component)))
+                 (needs-compilation component nil)))
     (let ((binary-pname (component-full-pathname component :binary)))
       (when (probe-file binary-pname)
         (with-tell-user ("Deleting binary"   component :binary)
@@ -4593 +5202 @@
                (setq *compile-during-load*
                      (y-or-n-p-wait
                       #\y 30
-                      "~A- Should I compile and load or not? "
+                      "~A- Should I compile while loading the system? "
                       prompt)))         ; was compile-source, then t
              compile-source))
           (*compile-during-load*)
@@ -4759 +5368 @@
      (when (setq changed
                  (or (find force '(:all t) :test #'eq)
                      (and (not (non-empty-listp force))
-                          (needs-compilation component))))
+                          (needs-compilation component nil))))
        (setq result
              (list component))))
     ((:module :system :subsystem :defsystem)
@@ -4796 +5405 @@
 
 ;;; Should this conditionalization be (or :mcl (and :CCL (not :lispworks)))?
 #|
-#+:ccl
-(defun edit-operation (component force)
-  "Always returns nil, i.e. component not changed."
-  (declare (ignore force))
-  ;;
-  (let* ((full-pathname (make::component-full-pathname component :source))
-         (already-editing\? #+:mcl (dolist (w (CCL:windows :class
-                                                           'fred-window))
-                                    (when (equal (CCL:window-filename w)
-                                                 full-pathname)
-                                      (return w)))
-                           #-:mcl nil))
-    (if already-editing\?
-      #+:mcl (CCL:window-select already-editing\?) #-:mcl nil
-      (ed full-pathname)))
-  nil)
+                                     #+:ccl
+                                     (defun edit-operation (component force)
+"Always returns nil, i.e. component not changed."
+(declare (ignore force))
+;;
+(let* ((full-pathname (make::component-full-pathname component :source))
+(already-editing\? #+:mcl (dolist (w (CCL:windows :class
+'fred-window))
+(when (equal (CCL:window-filename w)
+full-pathname)
+(return w)))
+#-:mcl nil))
+(if already-editing\?
+#+:mcl (CCL:window-select already-editing\?) #-:mcl nil
+(ed full-pathname)))
+nil)
 
-#+:allegro
-(defun edit-operation (component force)
-  "Edit a component - always returns nil, i.e. component not changed."
-  (declare (ignore force))
-  (let ((full-pathname (component-full-pathname component :source)))
-    (ed full-pathname))
-  nil)
+                                     #+:allegro
+                                     (defun edit-operation (component force)
+"Edit a component - always returns nil, i.e. component not changed."
+(declare (ignore force))
+(let ((full-pathname (component-full-pathname component :source)))
+(ed full-pathname))
+nil)
 
-#+(or :ccl :allegro)
-(make::component-operation :edit 'edit-operation)
-#+(or :ccl :allegro)
-(make::component-operation 'edit 'edit-operation)
-|#
+                                     #+(or :ccl :allegro)
+                                     (make::component-operation :edit 'edit-operation)
+                                     #+(or :ccl :allegro)
+                                     (make::component-operation 'edit 'edit-operation)
+                                     |#
 
 ;;; *** Hardcopy System ***
 (defparameter *print-command* "enscript -2Gr" ; "lpr"