Index: asdf.lisp =================================================================== --- asdf.lisp (revision 15495) +++ asdf.lisp (working copy) @@ -1,5 +1,5 @@ ;;; -*- 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 . @@ -50,7 +50,7 @@ (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,8 +71,8 @@ (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,6 +86,8 @@ ;;; 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,7 +118,7 @@ ;; "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,7 +230,6 @@ :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,7 +304,7 @@ #:*compile-file-warnings-behaviour* #:*compile-file-failure-behaviour* #:*resolve-symlinks* - #:*require-asdf-operator* + #:*load-system-operation* #:*asdf-verbose* #:*verbose-out* @@ -362,16 +363,17 @@ #: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,7 +389,7 @@ #: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,6 +421,16 @@ (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,6 +462,7 @@ (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,7 +672,7 @@ ;; 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,8 +754,9 @@ (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,7 +863,7 @@ ((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,7 +891,7 @@ (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,13 +2464,9 @@ (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,9 +2499,15 @@ (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,7 +2548,13 @@ (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,11 +2758,11 @@ (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,8 +2774,8 @@ (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,6 +3118,17 @@ #+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,7 +3140,7 @@ #+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,7 +3230,7 @@ (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,13 +3265,14 @@ (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,7 +3306,7 @@ (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,8 +3322,9 @@ (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,16 +3339,25 @@ (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,13 +3367,8 @@ (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,10 +3379,7 @@ ((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,10 +3504,8 @@ (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,7 +3732,8 @@ #+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,11 +3910,12 @@ (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,11 +3990,11 @@ (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,7 +4197,7 @@ 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,6 +4228,8 @@ (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,23 +4238,17 @@ `(: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,51 +4394,56 @@ (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,10 +4455,10 @@ (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,6 +4466,7 @@ #+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,6 +4486,21 @@ (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*) Index: README-OpenMCL.txt =================================================================== --- README-OpenMCL.txt (revision 15495) +++ README-OpenMCL.txt (working copy) @@ -1,46 +1,28 @@ 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: -. 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: +. +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: -. It was written by and -is maintained by Daniel Barlow. +To automatically download libraries, we recommend +you use quicklisp +or 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 . -Most Linux distributions offer GnuPG through their packaging system; -further information on GnuPG is available at . - - +"defsystem.lisp" is part of the clocc project on SourceForge: +. +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. Index: defsystem.lisp =================================================================== --- defsystem.lisp (revision 15495) +++ defsystem.lisp (working copy) @@ -1,7 +1,7 @@ ;;; -*- Mode: Lisp; Package: make -*- ;;; -*- Mode: CLtL; Syntax: Common-Lisp -*- -;;; DEFSYSTEM 3.4 Interim. +;;; DEFSYSTEM 3.6 Interim. ;;; defsystem.lisp -- @@ -28,10 +28,10 @@ ;;; 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,7 +835,7 @@ ;;; ******************************** ;;; 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,7 +864,6 @@ #-(or :CMU :vms :mcl - :openmcl :lispworks :clisp :gcl @@ -1013,7 +1012,7 @@ #+: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,58 +1107,65 @@ ;;; 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,24 +1190,32 @@ (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,6 +1227,7 @@ ;;; 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,15 +1239,18 @@ "~/")) 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,6 +1258,7 @@ (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,13 +1274,14 @@ #+: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 ;; 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,51 +1297,79 @@ (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,13 +1381,17 @@ 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,15 +1408,16 @@ (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,9 +1455,10 @@ ;; 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,6 +1466,7 @@ #+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,31 +1483,39 @@ ;;; 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,12 +1533,14 @@ (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,6 +1582,7 @@ #-(or (and :excl :sgi) (and :cmu :sgi) (and :lispworks :irix)) (software-type)) + (defun compiler-version () #+:lispworks (concatenate 'string "lispworks" " " (lisp-implementation-version)) @@ -1544,6 +1610,7 @@ #+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,10 +1649,12 @@ 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,19 +1668,23 @@ (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,11 +1725,13 @@ (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,17 +1759,21 @@ #+: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,12 +1800,14 @@ (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,20 +1820,25 @@ (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,6 +1848,14 @@ *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,11 +1920,13 @@ (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,13 +1979,14 @@ :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,6 +2027,7 @@ 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,6 +2036,7 @@ (format t "~&ABS: ~S ~18TREL: ~S ~41TResult: ~S" abs-dir rel-dir (new-append-directories abs-dir rel-dir)))) + #|| (test-new-append-directories) @@ -2001,6 +2100,7 @@ #-(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,6 +2126,7 @@ (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,6 +2214,9 @@ (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,7 +2233,43 @@ (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,6 +2350,7 @@ ;;; ******************************** ;;; 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,14 +2358,21 @@ (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,11 +2431,11 @@ ; 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,6 +2461,18 @@ (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,7 +2500,7 @@ (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,8 +2526,9 @@ (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,18 +2606,19 @@ ;;; 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,18 +2628,13 @@ (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,19 +2654,20 @@ (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,10 +2681,8 @@ (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,6 +2719,7 @@ (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,7 +2727,8 @@ ;; 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,7 +2750,8 @@ (: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,7 +2775,7 @@ ~@[~& 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,6 +2794,7 @@ (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,47 +2806,61 @@ (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,7 +2879,9 @@ (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,6 +2891,7 @@ (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,6 +2917,24 @@ ;; :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,43 +2942,42 @@ :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,29 +2997,68 @@ (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,7 +3101,9 @@ ;; 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,6 +3126,24 @@ 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,19 +3158,28 @@ (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,21 +3201,33 @@ (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,7 +3237,10 @@ (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,7 +3287,7 @@ ;; 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,7 +3336,8 @@ 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,6 +3347,7 @@ (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,6 +3355,7 @@ (when new (push new components)))) (nreverse components))) + (defun expand-serial-component-chain (definitions parent &optional (indent 0)) (let ((previous nil) (components nil)) @@ -3101,6 +3381,8 @@ 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,6 +3391,7 @@ (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,28 +3401,34 @@ (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,6 +3445,7 @@ (component-depends-on component)))))) + ;;; ******************************** ;;; Topological Sort the Graph ***** ;;; ******************************** @@ -3164,18 +3454,19 @@ ;;; 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,6 +3521,7 @@ ;; 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,6 +3557,7 @@ (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,6 +3587,7 @@ (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,12 +3596,14 @@ (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,18 +3613,21 @@ (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,9 +3652,11 @@ 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,6 +3669,7 @@ (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,6 +3724,21 @@ (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,9 +3783,9 @@ (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,7 +3823,8 @@ (*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,6 +3834,7 @@ #-openmcl (optimize (inhibit-warnings 3))) (unless (component-operation operation) (error "Operation ~A undefined." operation)) + (operate-on-component system operation force)))) (when dribble (dribble)))) @@ -3614,6 +3933,59 @@ :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,9 +4018,16 @@ (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,15 +4035,20 @@ (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,8 +4076,13 @@ (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,47 +4126,60 @@ ;; 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. ;; - ;; ( ) + ;; ( &optional ) ;; - (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,9 +4217,18 @@ (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,6 +4258,13 @@ (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,6 +4298,9 @@ ||# (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,7 +4331,7 @@ #+: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,7 +4358,7 @@ (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,11 +4368,11 @@ )) (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,6 +4397,39 @@ (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,6 +4560,79 @@ (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,6 +4746,8 @@ fatal-error))))) +;;; C Language definitions. + (defun c-compile-file (filename &rest args &key (output-file t) @@ -4278,8 +4807,9 @@ #+: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,30 +4827,59 @@ :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,6 +4894,7 @@ (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,6 +4913,12 @@ ;; 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,7 +4928,7 @@ (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,14 +4955,19 @@ 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,22 +4977,55 @@ 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,7 +5061,7 @@ ;; 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,13 +5074,17 @@ (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,7 +5105,8 @@ (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,7 +5152,7 @@ (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,7 +5202,7 @@ (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,7 +5368,7 @@ (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,36 +5405,36 @@ ;;; 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"