From 2fceea5208b849226c95be32c096f6d8638b8a5f Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Thu, 12 Mar 2015 02:40:32 -0400 Subject: [PATCH] Add CLASP support Based on a contribution by Christian Shafmeister. --- backward-interface.lisp | 6 +-- bundle.lisp | 57 +++++++++++---------- footer.lisp | 16 +++--- lisp-action.lisp | 10 ++-- output-translations.lisp | 2 +- source-registry.lisp | 2 +- test/dll-test.lisp | 4 +- test/make-hello-world.lisp | 2 +- test/monodll-1.lisp | 4 +- test/monodll.lisp | 4 +- test/run-tests.sh | 4 ++ test/script-support.lisp | 16 +++--- test/test-compile-file-failure.lisp | 2 +- tools/install-asdf.lisp | 38 +++++++------- uiop/backward-driver.lisp | 4 +- uiop/common-lisp.lisp | 14 ++++-- uiop/filesystem.lisp | 10 ++-- uiop/image.lisp | 77 +++++++++++++++-------------- uiop/lisp-build.lisp | 54 +++++++++++--------- uiop/os.lisp | 22 +++++---- uiop/package.lisp | 2 +- uiop/pathname.lisp | 2 +- uiop/run-program.lisp | 26 +++++----- uiop/stream.lisp | 6 +-- uiop/utility.lisp | 12 ++--- 25 files changed, 216 insertions(+), 180 deletions(-) diff --git a/backward-interface.lisp b/backward-interface.lisp index cce317e4..ba5e9aba 100644 --- a/backward-interface.lisp +++ b/backward-interface.lisp @@ -86,15 +86,15 @@ processed in order by OPERATE.")) (default-toplevel-directory (subpathname (user-homedir-pathname) ".fasls/")) ;; Use ".cache/common-lisp/" instead ??? (include-per-user-information nil) - (map-all-source-files (or #+(or clisp ecl mkcl) t nil)) + (map-all-source-files (or #+(or clasp clisp ecl mkcl) t nil)) (source-to-target-mappings nil) (file-types `(,(compile-file-type) "build-report" - #+ecl (compile-file-type :type :object) + #+(or clasp ecl) (compile-file-type :type :object) #+mkcl (compile-file-type :fasl-p nil) #+clisp "lib" #+sbcl "cfasl" #+sbcl "sbcl-warnings" #+clozure "ccl-warnings"))) - #+(or clisp ecl mkcl) + #+(or clasp 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 CLISP, ECL and MKCL")) (let* ((patterns (if map-all-source-files (list *wild-file*) diff --git a/bundle.lisp b/bundle.lisp index f09d0e94..72f4a6ef 100644 --- a/bundle.lisp +++ b/bundle.lisp @@ -26,7 +26,7 @@ ((build-args :initarg :args :initform nil :accessor extra-build-args) (name-suffix :initarg :name-suffix :initform nil) (bundle-type :initform :no-output-file :reader bundle-type) - #+ecl (lisp-files :initform nil :accessor extra-object-files))) + #+(or clasp ecl) (lisp-files :initform nil :accessor extra-object-files))) (defclass monolithic-op (operation) () (:documentation "A MONOLITHIC operation operates on a system *and all of its @@ -89,16 +89,18 @@ itself.")) ;; operation on a system and its dependencies ((bundle-type :initform :fasl))) (defclass prepare-bundle-op (sideway-operation) - ((sideway-operation :initform #+(or ecl mkcl) 'load-bundle-op #-(or ecl mkcl) 'load-op - :allocation :class))) + ((sideway-operation + :initform #+(or clasp ecl mkcl) 'load-bundle-op #-(or clasp ecl mkcl) 'load-op + :allocation :class))) (defclass lib-op (link-op gather-op non-propagating-operation) ((bundle-type :initform :lib)) (:documentation "compile the system and produce linkable (.a) library for it.")) (defclass compile-bundle-op (basic-compile-bundle-op selfward-operation - #+(or ecl mkcl) link-op #-ecl gather-op) - ((selfward-operation :initform '(prepare-bundle-op #+ecl lib-op) :allocation :class))) + #+(or clasp ecl mkcl) link-op #-(or clasp ecl) gather-op) + ((selfward-operation :initform '(prepare-bundle-op #+(or clasp ecl) lib-op) + :allocation :class))) (defclass load-bundle-op (basic-load-op selfward-operation) ((selfward-operation :initform '(prepare-bundle-op compile-bundle-op) :allocation :class))) @@ -113,18 +115,19 @@ itself.")) ;; operation on a system and its dependencies (:documentation "compile the system and produce dynamic (.so/.dll) library for it.")) (defclass deliver-asd-op (basic-compile-op selfward-operation) - ((selfward-operation :initform '(compile-bundle-op #+(or ecl mkcl) lib-op) :allocation :class)) + ((selfward-operation :initform '(compile-bundle-op #+(or clasp ecl mkcl) lib-op) :allocation :class)) (:documentation "produce an asd file for delivering the system as a single fasl")) (defclass monolithic-deliver-asd-op (monolithic-bundle-op deliver-asd-op) - ((selfward-operation :initform '(monolithic-compile-bundle-op #+(or ecl mkcl) monolithic-lib-op) - :allocation :class)) + ((selfward-operation + :initform '(monolithic-compile-bundle-op #+(or clasp ecl mkcl) monolithic-lib-op) + :allocation :class)) (:documentation "produce fasl and asd files for combined system and dependencies.")) (defclass monolithic-compile-bundle-op (monolithic-bundle-op basic-compile-bundle-op - #+(or ecl mkcl) link-op gather-op non-propagating-operation) - ((gather-op :initform #+(or ecl mkcl) 'lib-op #-(or ecl mkcl) 'compile-bundle-op :allocation :class)) + #+(or clasp ecl mkcl) link-op gather-op non-propagating-operation) + ((gather-op :initform #+(or clasp ecl mkcl) 'lib-op #-(or clasp ecl mkcl) 'compile-bundle-op :allocation :class)) (:documentation "Create a single fasl for the system and its dependencies.")) (defclass monolithic-load-bundle-op (monolithic-bundle-op load-bundle-op) @@ -139,9 +142,9 @@ itself.")) ;; operation on a system and its dependencies (:documentation "Create a single dynamic (.so/.dll) library for the system and its dependencies.")) (defclass image-op (monolithic-bundle-op selfward-operation - #+(or ecl mkcl) link-op #+(or ecl mkcl) gather-op) + #+(or clasp ecl mkcl) link-op #+(or clasp ecl mkcl) gather-op) ((bundle-type :initform :image) - (selfward-operation :initform '(#-(or ecl mkcl) load-op) :allocation :class)) + (selfward-operation :initform '(#-(or clasp ecl mkcl) load-op) :allocation :class)) (:documentation "create an image file from the system and its dependencies")) (defclass program-op (image-op) @@ -152,8 +155,8 @@ itself.")) ;; operation on a system and its dependencies (etypecase bundle-type ((eql :no-output-file) nil) ;; should we error out instead? ((or null string) bundle-type) - ((eql :fasl) #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb") - #+ecl + ((eql :fasl) #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb") + #+(or clasp ecl) ((member :dll :lib :shared-library :static-library :program :object :program) (compile-file-type :type bundle-type)) ((member :image) #-allegro "image" #+allegro "dxl") @@ -175,7 +178,7 @@ itself.")) ;; operation on a system and its dependencies (defmethod output-files ((o bundle-op) (c system)) (bundle-output-files o c)) - #-(or ecl mkcl) + #-(or clasp ecl mkcl) (progn (defmethod perform ((o image-op) (c system)) (dump-image (output-file o c) :executable (typep o 'program-op))) @@ -183,7 +186,7 @@ itself.")) ;; operation on a system and its dependencies (setf *image-entry-point* (ensure-function (component-entry-point c))))) (defclass compiled-file (file-component) - ((type :initform #-(or ecl mkcl) (compile-file-type) #+(or ecl mkcl) "fasb"))) + ((type :initform #-(or clasp ecl mkcl) (compile-file-type) #+(or clasp ecl mkcl) "fasb"))) (defclass precompiled-system (system) ((build-pathname :initarg :fasl))) @@ -209,15 +212,16 @@ itself.")) ;; operation on a system and its dependencies (unless name-suffix-p (setf (slot-value instance 'name-suffix) (unless (typep instance 'program-op) - (if (operation-monolithic-p instance) "--all-systems" #-(or ecl mkcl) "--system")))) ; . no good for Logical Pathnames + ;; "." is no good separator for Logical Pathnames, so we use "--" + (if (operation-monolithic-p instance) "--all-systems" #-(or clasp ecl mkcl) "--system")))) (when (typep instance 'monolithic-bundle-op) (destructuring-bind (&key lisp-files prologue-code epilogue-code &allow-other-keys) (operation-original-initargs instance) (setf (prologue-code instance) prologue-code (epilogue-code instance) epilogue-code) - #-ecl (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code))) - #+ecl (setf (extra-object-files instance) lisp-files))) + #-(or clasp ecl) (assert (null (or lisp-files #-mkcl epilogue-code #-mkcl prologue-code))) + #+(or clasp ecl) (setf (extra-object-files instance) lisp-files))) (setf (extra-build-args instance) (remove-plist-keys '(:type :monolithic :name-suffix :epilogue-code :prologue-code :lisp-files @@ -227,8 +231,8 @@ itself.")) ;; operation on a system and its dependencies (defun bundlable-file-p (pathname) (let ((type (pathname-type pathname))) (declare (ignorable type)) - (or #+ecl (or (equalp type (compile-file-type :type :object)) - (equalp type (compile-file-type :type :static-library))) + (or #+(or clasp ecl) (or (equalp type (compile-file-type :type :object)) + (equalp type (compile-file-type :type :static-library))) #+mkcl (or (equalp type (compile-file-type :fasl-p nil)) #+(or unix mingw32 mingw64) (equalp type "a") ;; valid on Unix and MinGW #+(and windows (not (or mingw32 mingw64))) (equalp type "lib")) @@ -427,7 +431,7 @@ itself.")) ;; operation on a system and its dependencies s) (terpri s))))) - #-(or ecl mkcl) + #-(or clasp ecl mkcl) (defmethod perform ((o basic-compile-bundle-op) (c system)) (let* ((input-files (input-files o c)) (fasl-files (remove (compile-file-type) input-files :key #'pathname-type :test-not #'equalp)) @@ -461,26 +465,29 @@ itself.")) ;; operation on a system and its dependencies (asdf:load-system :precompiled-asdf-utils) |# -#+(or ecl mkcl) +#+(or clasp ecl mkcl) (with-upgradability () ;; I think that Juanjo intended for this to be, ;; but beware the weird bug in test-xach-update-bug.script, ;; and also it makes mkcl fail test-logical-pathname.script, ;; and ecl fail test-bundle.script. - ;;(unless (or #+ecl (use-ecl-byte-compiler-p)) + ;;(unless (or #+(or clasp ecl) (use-ecl-byte-compiler-p)) ;; (setf *load-system-operation* 'load-bundle-op)) (defun uiop-library-pathname () + #+clasp (probe-file* (compile-file-pathname "sys:uiop" :output-type :object)) #+ecl (or (probe-file* (compile-file-pathname "sys:uiop" :type :lib)) ;; new style (probe-file* (compile-file-pathname "sys:uiop" :type :object))) ;; old style #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;uiop")) (defun asdf-library-pathname () + #+clasp (probe-file* (compile-file-pathname "sys:asdf" :output-type :object)) #+ecl (or (probe-file* (compile-file-pathname "sys:asdf" :type :lib)) ;; new style (probe-file* (compile-file-pathname "sys:asdf" :type :object))) ;; old style #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:contrib;asdf")) (defun compiler-library-pathname () + #+clasp (compile-file-pathname "sys:cmp" :output-type :lib) #+ecl (compile-file-pathname "sys:cmp" :type :lib) #+mkcl (make-pathname :type (bundle-pathname-type :lib) :defaults #p"sys:cmp")) @@ -525,7 +532,7 @@ itself.")) ;; operation on a system and its dependencies (when programp `(:entry-point ,(component-entry-point c)))))))) #+(and (not asdf-use-unsafe-mac-bundle-op) - (or (and ecl darwin) + (or (and clasp ecl darwin) (and abcl darwin (not abcl-bundle-op-supported)))) (defmethod perform :before ((o basic-compile-bundle-op) (c component)) (unless (featurep :asdf-use-unsafe-mac-bundle-op) diff --git a/footer.lisp b/footer.lisp index f78a7635..4af91c0a 100644 --- a/footer.lisp +++ b/footer.lisp @@ -8,27 +8,27 @@ (in-package :asdf/footer) ;;;; Hook ASDF into the implementation's REQUIRE and other entry points. -#+(or abcl clisp clozure cmu ecl mkcl sbcl) +#+(or abcl clasp clisp clozure cmu ecl mkcl sbcl) (with-upgradability () (if-let (x (and #+clisp (find-symbol* '#:*module-provider-functions* :custom nil))) (eval `(pushnew 'module-provide-asdf #+abcl sys::*module-provider-functions* + #+(or clasp cmu ecl) ext:*module-provider-functions* #+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*))) - #+(or ecl mkcl) + #+(or clasp ecl mkcl) (progn (pushnew '("fasb" . si::load-binary) si::*load-hooks* :test 'equal :key 'car) - #+(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)))) + #+(or (and clasp windows) (and ecl win32) (and mkcl windows)) + (unless (assoc "asd" #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* :test 'equal) + (appendf #+(or clasp ecl) ext:*load-hooks* #+mkcl si::*load-hooks* '(("asd" . si::load-source)))) - (setf #+ecl ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* - (loop :for f :in #+ecl ext:*module-provider-functions* + (setf #+(or clasp ecl) ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* + (loop :for f :in #+(or clasp ecl) ext:*module-provider-functions* #+mkcl mk-ext::*module-provider-functions* :collect (if (eq f 'module-provide-asdf) f diff --git a/lisp-action.lisp b/lisp-action.lisp index 0622c42e..992cb8e6 100644 --- a/lisp-action.lisp +++ b/lisp-action.lisp @@ -87,8 +87,8 @@ (destructuring-bind (output-file &optional + #+(or clasp ecl mkcl) object-file #+clisp lib-file - #+(or ecl mkcl) object-file warnings-file) outputs (call-with-around-compile-hook c #'(lambda (&rest flags) @@ -98,7 +98,7 @@ :warnings-file warnings-file (append #+clisp (list :lib-file lib-file) - #+(or ecl mkcl) (list :object-file object-file) + #+(or clasp ecl mkcl) (list :object-file object-file) flags (compile-op-flags o)))))) (check-lisp-compile-results output warnings-p failure-p "~/asdf-action::format-action/" (list (cons o c)))))) @@ -123,8 +123,12 @@ (defun lisp-compilation-output-files (o c) (let* ((i (first (input-files o c))) (f (compile-file-pathname - i #+mkcl :fasl-p #+mkcl t #+ecl :type #+ecl :fasl))) + i #+clasp :output-type #+ecl :type #+(or clasp ecl) :fasl + #+mkcl :fasl-p #+mkcl t))) `(,f ;; the fasl is the primary output, in first position + #+clasp + ,@(unless nil ;; was (use-ecl-byte-compiler-p) + `(,(compile-file-pathname i :output-type :object))) #+clisp ,@`(,(make-pathname :type "lib" :defaults f)) #+ecl diff --git a/output-translations.lisp b/output-translations.lisp index 205d4d2e..c5d87217 100644 --- a/output-translations.lisp +++ b/output-translations.lisp @@ -139,7 +139,7 @@ and the order is by decreasing length of namestring of the source pathname.") `(:output-translations ;; Some implementations have precompiled ASDF systems, ;; so we must disable translations for implementation paths. - #+(or #|clozure|# ecl mkcl sbcl) + #+(or clasp #|clozure|# ecl mkcl sbcl) ,@(let ((h (resolve-symlinks* (lisp-implementation-directory)))) (when h `(((,h ,*wild-path*) ())))) #+mkcl (,(translate-logical-pathname "CONTRIB:") ()) diff --git a/source-registry.lisp b/source-registry.lisp index e6b51dee..3e6a1624 100644 --- a/source-registry.lisp +++ b/source-registry.lisp @@ -175,7 +175,7 @@ after having found a .asd file? True by default.") (defun wrapping-source-registry () `(:source-registry - #+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) + #+(or clasp ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory))) :inherit-configuration #+mkcl (:tree ,(translate-logical-pathname "CONTRIB:")) #+cmu (:tree #p"modules:") diff --git a/test/dll-test.lisp b/test/dll-test.lisp index ab2a3e36..5326b043 100644 --- a/test/dll-test.lisp +++ b/test/dll-test.lisp @@ -1,6 +1,6 @@ (defpackage :test-asdf/dll-test (:use)) ;; dummy, for package-inferred-system dependencies. -#+ecl +#+(and ecl (not clasp)) (ffi:clines " extern int sample_function(); @@ -10,6 +10,8 @@ int sample_function() } ") +#+clasp (leave-test "Doesn't work on CLASP yet" 0) + #+mkcl (ffi:clines " extern MKCL_DLLEXPORT int sample_function(void); diff --git a/test/make-hello-world.lisp b/test/make-hello-world.lisp index bcaa6e03..749583fc 100644 --- a/test/make-hello-world.lisp +++ b/test/make-hello-world.lisp @@ -2,7 +2,7 @@ #+lispworks (lispworks:load-all-patches) (load (make-pathname :name "script-support" :defaults *load-pathname*)) (load-asdf) -#+(or ecl mkcl) (require :cmp) +#+(or clasp ecl mkcl) (require :cmp) (asdf-test::register-directory asdf-test::*asdf-directory*) ;; we need UIOP, and ECL can dump. (asdf-test::register-directory asdf-test::*uiop-directory*) diff --git a/test/monodll-1.lisp b/test/monodll-1.lisp index 6251610d..e1eb9d29 100644 --- a/test/monodll-1.lisp +++ b/test/monodll-1.lisp @@ -1,6 +1,6 @@ (defpackage :test-asdf/monodll-1 (:use)) ;; dummy, for package-inferred-system dependencies. -#+ecl +#+(and ecl (not clasp)) (ffi:clines " extern int always_7(); @@ -10,6 +10,8 @@ int always_7() } ") +#+clasp (leave-test "Not supported by CLASP yet" 0) + #+mkcl (ffi:clines " extern MKCL_DLLEXPORT int always_7(void); diff --git a/test/monodll.lisp b/test/monodll.lisp index 8e00be0c..cd32e790 100644 --- a/test/monodll.lisp +++ b/test/monodll.lisp @@ -1,6 +1,6 @@ (defpackage :test-asdf/monodll (:use :test-asdf/monodll-1)) ;; dummy, for package-inferred-system dependencies. -#+ecl +#+(and ecl (not clasp)) (ffi:clines " extern int always_42(); @@ -10,6 +10,8 @@ int always_42() } ") +#+clasp (leave-test "Not supported by CLASP yet" 0) + #+mkcl (ffi:clines " extern MKCL_DLLEXPORT int always_42(void); diff --git a/test/run-tests.sh b/test/run-tests.sh index 37b88001..4cf4a05f 100755 --- a/test/run-tests.sh +++ b/test/run-tests.sh @@ -229,6 +229,10 @@ case "$lisp" in flags="--no-init --quiet" nodebug="--batch" eval="--eval" ;; + clasp) + command="${CLASP:-clasp}" + flags="" + eval="" ;; clisp) command="${CLISP:-clisp}" flags="-norc --silent -ansi -I " diff --git a/test/script-support.lisp b/test/script-support.lisp index 2a8b9236..705d780d 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -204,12 +204,12 @@ Some constraints: (:case-sensitive-lower :mlisp) (:case-insensitive-upper :alisp)) #+armedbear :abcl + #+(or clasp ecl) (or #+ecl-bytecmp :ecl_bytecodes :ecl) #+clisp :clisp #+clozure :ccl #+cmu :cmucl #+corman :cormanlisp #+digitool :mcl - #+ecl (or #+ecl-bytecmp :ecl_bytecodes :ecl) #+gcl :gcl #+lispworks :lispworks #+mkcl :mkcl @@ -284,11 +284,11 @@ Some constraints: (finish-outputs*) #+(or abcl xcl) (ext:quit :status code) #+allegro (excl:exit code :quiet t) + #+(or clasp ecl) (si:quit code) #+clisp (ext:quit code) #+clozure (ccl:quit code) #+cormanlisp (win32:exitprocess code) #+(or cmu scl) (unix:unix-exit code) - #+ecl (si:quit code) #+gcl (system:quit code) #+genera (error "You probably don't want to Halt the Machine. (code: ~S)" code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) @@ -299,7 +299,7 @@ Some constraints: (cond (exit `(,exit :code code :abort t)) (quit* `(,quit* :unix-status code :recklessly-p t)))) - #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) @@ -386,15 +386,15 @@ is bound, write a message and exit on an error. If (defun call-with-asdf-conditions (thunk &optional verbose) (declare (ignorable verbose)) - (handler-bind (#+sbcl - ((or sb-c::simple-compiler-note sb-kernel:redefinition-warning) - #'muffle-warning) - #+(and ecl (not ecl-bytecmp)) + (handler-bind (#+(and ecl (not ecl-bytecmp)) ((or c::compiler-note c::compiler-debug-note c::compiler-warning) ;; ECL emits more serious warnings than it should. #'muffle-warning) #+mkcl ((or compiler:compiler-note) #'muffle-warning) + #+sbcl + ((or sb-c::simple-compiler-note sb-kernel:redefinition-warning) + #'muffle-warning) #-(or cmu scl) ;; style warnings shouldn't abort the compilation [2010/02/03:rpg] (style-warning @@ -436,7 +436,7 @@ is bound, write a message and exit on an error. If ;; CMUCL: ? ;; ECL 11.1.1 has spurious warnings, same with XCL 0.0.0.291. ;; SCL has no warning but still raises the warningp flag since 2.20.15 (?) - #+(or clisp cmu ecl scl xcl) (good :expected-style-warnings) + #+(or clasp clisp cmu ecl scl xcl) (good :expected-style-warnings) (and upgradep (good :unexpected-style-warnings)) (bad :unexpected-style-warnings))) (t (good :success))))))) diff --git a/test/test-compile-file-failure.lisp b/test/test-compile-file-failure.lisp index 4e2d7557..d75aba5b 100644 --- a/test/test-compile-file-failure.lisp +++ b/test/test-compile-file-failure.lisp @@ -6,6 +6,6 @@ ;; Work around: #+(and ecl ecl-bytecmp) (when (and (eq asdf:*compile-file-failure-behaviour* :error) - #+ecl (equal (compile-file-type) "fasc")) + #+(or clasp ecl) (equal (compile-file-type) "fasc")) (error 'compile-file-error :description "faking it")) (warn "Warning.")) diff --git a/tools/install-asdf.lisp b/tools/install-asdf.lisp index f3e7a335..0c94cd35 100755 --- a/tools/install-asdf.lisp +++ b/tools/install-asdf.lisp @@ -54,16 +54,16 @@ It notably doesn't work on: (defun module-directory () #+allegro #p"sys:code;" + #+(or clasp ecl mkcl) #p"sys:" #+clisp (subpathname custom:*lib-directory* "asdf/") #+clozure #p"ccl:tools;" #+cmu #p"modules:asdf/" - #+(or ecl mkcl) #p"sys:" #+gcl (subpathname system:*system-directory* "../modules/") #+lispworks (system:lispworks-dir "load-on-demand/utilities/") #+sbcl (subpathname (sb-int:sbcl-homedir-pathname) "contrib/") #+scl #p"file://modules/" #+xcl ext:*xcl-home* - #-(or allegro clisp clozure cmu ecl gcl lispworks mkcl sbcl scl xcl) + #-(or allegro clasp clisp clozure cmu ecl gcl lispworks mkcl sbcl scl xcl) (error "module-directory not implemented on ~A" (implementation-type))) (defun module-fasl (name) @@ -76,17 +76,17 @@ It notably doesn't work on: (t -1))))) (first (sort (directory (merge-pathnames* (strcat name ".*") (module-directory))) #'> :key #'pathname-key))) - #+(or clisp clozure cmu ecl gcl lispworks mkcl sbcl scl xcl) + #+(or clasp clisp clozure cmu ecl gcl lispworks mkcl sbcl scl xcl) (compile-file-pathname (subpathname (truename (module-directory)) name :type "lisp")) - #-(or allegro clisp clozure cmu ecl gcl lispworks mkcl sbcl scl xcl) + #-(or allegro clasp clisp clozure cmu ecl gcl lispworks mkcl sbcl scl xcl) (error "Not implemented on ~A" (implementation-type))) (defun uiop-module-fasl () (module-fasl "uiop")) (defun asdf-module-fasl () (module-fasl "asdf")) (defun object-file (name &optional (type :object)) - #-(or ecl mkcl) (progn name type (assert nil)) - #+ecl (compile-file-pathname name :type type) + #-(or clasp ecl mkcl) (progn name type (assert nil)) + #+(or clasp ecl) (compile-file-pathname name :type type) #+mkcl (make-pathname :defaults name :type (bundle-pathname-type type))) (defun call-with-file-replacement (file thunk) @@ -105,14 +105,14 @@ It notably doesn't work on: (nest (let* ((asdf.lisp (system-relative-pathname :uiop "../build/asdf.lisp")) (asdf.fasl (asdf-module-fasl)) - #+(or ecl mkcl) (asdf.o (object-file asdf.fasl :object)) - #+(or ecl mkcl) (asdf.a (object-file asdf.fasl :lib)))) + #+(or clasp ecl mkcl) (asdf.o (object-file asdf.fasl :object)) + #+(or clasp ecl mkcl) (asdf.a (object-file asdf.fasl :lib)))) (with-file-replacement (asdf.fasl)) - #+(or ecl mkcl) (with-file-replacement (asdf.o)) - #+(or ecl mkcl) (with-file-replacement (asdf.a)) + #+(or clasp ecl mkcl) (with-file-replacement (asdf.o)) + #+(or clasp ecl mkcl) (with-file-replacement (asdf.a)) (progn (compile-file* asdf.lisp :output-file asdf.fasl - #+(or ecl mkcl) :object-file #+(or ecl mkcl) asdf.o) + #+(or clasp ecl mkcl) :object-file #+(or clasp ecl mkcl) asdf.o) #+(or ecl mkcl) (create-image asdf.a (list asdf.o) :kind :lib)))) @@ -122,7 +122,7 @@ It notably doesn't work on: (operate 'compile-bundle-op "uiop") (rename-file-overwriting-target (first (output-files 'compile-bundle-op "uiop")) uiop.fasl) (load uiop.fasl)) - #+(or ecl mkcl) + #+(or clasp ecl mkcl) (let ((uiop.a (object-file asdf.fasl :lib))) (with-file-replacement (uiop.a) (operate 'lib-op "uiop") @@ -130,12 +130,12 @@ It notably doesn't work on: (nest (let* ((asdf.fasl (asdf-module-fasl)) (asdf.lisp (make-pathname :type "lisp" :defaults asdf.fasl)) - #+(or ecl mkcl) (asdf.o (object-file asdf.fasl :object)) - #+(or ecl mkcl) (asdf.a (object-file asdf.fasl :lib)))) + #+(or clasp ecl mkcl) (asdf.o (object-file asdf.fasl :object)) + #+(or clasp ecl mkcl) (asdf.a (object-file asdf.fasl :lib)))) (with-file-replacement (asdf.lisp)) (with-file-replacement (asdf.fasl)) - #+(or ecl mkcl) (with-file-replacement (asdf.o)) - #+(or ecl mkcl) (with-file-replacement (asdf.a)) + #+(or clasp ecl mkcl) (with-file-replacement (asdf.o)) + #+(or clasp ecl mkcl) (with-file-replacement (asdf.a)) (progn (with-output-file (o asdf.lisp :if-exists :rename-and-delete :if-does-not-exist :create) (println "(cl:require \"uiop\")" o) @@ -143,13 +143,13 @@ It notably doesn't work on: (with-input-file (i (component-pathname c)) (copy-stream-to-stream i o)))) (compile-file* asdf.lisp :output-file asdf.fasl - #+(or ecl mkcl) :object-file #+(or ecl mkcl) asdf.o) - #+(or ecl mkcl) + #+(or clasp ecl mkcl) :object-file #+(or clasp ecl mkcl) asdf.o) + #+(or clasp ecl mkcl) (create-image asdf.a (list asdf.o) :kind :lib))))) #+(or sbcl mkcl) (progn (install-uiop-and-asdf-as-modules) (quit)) -#+(or allegro clisp clozure cmu ecl gcl lispworks scl xcl) +#+(or allegro clasp clisp clozure cmu ecl gcl lispworks scl xcl) (progn (install-asdf-as-module) (quit)) #+(or abcl cormanlisp genera mcl mocl) (die 2 "Not supported on ~A" (implementation-type)) diff --git a/uiop/backward-driver.lisp b/uiop/backward-driver.lisp index c58a0489..35b7fabf 100644 --- a/uiop/backward-driver.lisp +++ b/uiop/backward-driver.lisp @@ -10,7 +10,7 @@ :uiop/configuration) (:export #:coerce-pathname #:component-name-to-pathname-components - #+(or ecl mkcl) #:compile-file-keeping-object + #+(or clasp ecl mkcl) #:compile-file-keeping-object )) (in-package :uiop/backward-driver) @@ -37,5 +37,5 @@ unix-style-namestring)) (values relabs path filename))) - #+(or ecl mkcl) + #+(or clasp ecl mkcl) (defun compile-file-keeping-object (&rest args) (apply #'compile-file* args))) diff --git a/uiop/common-lisp.lisp b/uiop/common-lisp.lisp index 514ee388..f1789234 100644 --- a/uiop/common-lisp.lisp +++ b/uiop/common-lisp.lisp @@ -22,7 +22,7 @@ #+mcl (:shadow #:user-homedir-pathname)) (in-package :uiop/common-lisp) -#-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) +#-(or abcl allegro clasp 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.") ;; (declaim (optimize (speed 1) (debug 3) (safety 3))) ; DON'T: trust implementation defaults. @@ -30,12 +30,12 @@ ;;;; Early meta-level tweaks -#+(or abcl allegro clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl) +#+(or abcl allegro clasp clisp cmu ecl mkcl clozure lispworks mkcl sbcl scl) (eval-when (:load-toplevel :compile-toplevel :execute) ;; Check for unicode at runtime, so that a hypothetical FASL compiled with unicode ;; but loaded in a non-unicode setting (e.g. on Allegro) won't tell a lie. (when (and #+allegro (member :ics *features*) - #+(or clisp cmu ecl mkcl) (member :unicode *features*) + #+(or clasp clisp cmu ecl mkcl) (member :unicode *features*) #+sbcl (member :sb-unicode *features*)) (pushnew :asdf-unicode *features*))) @@ -48,6 +48,11 @@ (setf excl:*warn-on-nested-reader-conditionals* nil)) (setf *print-readably* nil)) +#+clasp +(eval-when (:load-toplevel :compile-toplevel :execute) + (setf *load-verbose* nil) + (defun use-ecl-byte-compiler-p () nil)) + #+clozure (in-package :ccl) #+(and clozure windows-target) ;; See http://trac.clozure.com/ccl/ticket/1117 (eval-when (:load-toplevel :compile-toplevel :execute) @@ -61,7 +66,6 @@ (external-process-%status proc)))))) #+clozure (in-package :uiop/common-lisp) - #+cormanlisp (eval-when (:load-toplevel :compile-toplevel :execute) (deftype logical-pathname () nil) @@ -74,7 +78,7 @@ (setf p (pathname p)) (format nil "~@[~A~]~@[.~A~]" (pathname-name p) (pathname-type p)))) -#+ecl +#+(and ecl (not clasp)) (eval-when (:load-toplevel :compile-toplevel :execute) (setf *load-verbose* nil) (defun use-ecl-byte-compiler-p () (and (member :ecl-bytecmp *features*) t)) diff --git a/uiop/filesystem.lisp b/uiop/filesystem.lisp index b825018e..a8b6f2da 100644 --- a/uiop/filesystem.lisp +++ b/uiop/filesystem.lisp @@ -543,11 +543,11 @@ NILs." (defun lisp-implementation-directory (&key truename) "Where are the system files of the current installation of the CL implementation?" (declare (ignorable truename)) - #+(or clozure ecl gcl mkcl sbcl) + #+(or clasp clozure ecl gcl mkcl sbcl) (let ((dir (ignore-errors #+clozure #p"ccl:" - #+(or ecl mkcl) #p"SYS:" + #+(or clasp ecl mkcl) #p"SYS:" #+gcl system::*system-directory* #+sbcl (if-let (it (find-symbol* :sbcl-homedir-pathname :sb-int nil)) (funcall it) @@ -585,7 +585,7 @@ in an atomic way if the implementation allows." (symbol-call :posix :copy-file source target :method :rename)) #-clisp (rename-file source target - #+(or clozure ecl) :if-exists #+clozure :rename-and-delete #+ecl t)) + #+(or clasp clozure ecl) :if-exists #+clozure :rename-and-delete #+(or clasp ecl) t)) (defun delete-file-if-exists (x) "Delete a file X if it already exists" @@ -605,7 +605,7 @@ in an atomic way if the implementation allows." #+scl (error "~@<Error deleting ~S: ~A~@:>" directory-pathname (unix:get-unix-error-msg errno)))) #+cormanlisp (win32:delete-directory directory-pathname) - #+ecl (si:rmdir directory-pathname) + #+(or clasp ecl) (si:rmdir directory-pathname) #+genera (fs:delete-directory directory-pathname) #+lispworks (lw:delete-directory directory-pathname) #+mkcl (mkcl:rmdir directory-pathname) @@ -613,7 +613,7 @@ in an atomic way if the implementation allows." `(,dd directory-pathname) ;; requires SBCL 1.0.44 or later `(progn (require :sb-posix) (symbol-call :sb-posix :rmdir directory-pathname))) #+xcl (symbol-call :uiop :run-program `("rmdir" ,(native-namestring directory-pathname))) - #-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmu cormanlisp digitool ecl gcl genera lispworks mkcl sbcl scl xcl) (error "~S not implemented on ~S" 'delete-empty-directory (implementation-type))) ; genera (defun delete-directory-tree (directory-pathname &key (validate nil validatep) (if-does-not-exist :error)) diff --git a/uiop/image.lisp b/uiop/image.lisp index ff40573b..a34c7b35 100644 --- a/uiop/image.lisp +++ b/uiop/image.lisp @@ -65,11 +65,11 @@ This is designed to abstract away the implementation specific quit forms." (finish-outputs)) #+(or abcl xcl) (ext:quit :status code) #+allegro (excl:exit code :quiet t) + #+(or clasp ecl) (si:quit code) #+clisp (ext:quit code) #+clozure (ccl:quit code) #+cormanlisp (win32:exitprocess code) #+(or cmu scl) (unix:unix-exit code) - #+ecl (si:quit code) #+gcl (system:quit code) #+genera (error "~S: You probably don't want to Halt Genera. (code: ~S)" 'quit code) #+lispworks (lispworks:quit :status code :confirm nil :return nil :ignore-errors-p t) @@ -80,7 +80,7 @@ This is designed to abstract away the implementation specific quit forms." (cond (exit `(,exit :code code :abort (not finish-output))) (quit `(,quit :unix-status code :recklessly-p (not finish-output))))) - #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S called with exit code ~S but there's no quitting on this implementation" 'quit code)) (defun die (code format &rest arguments) @@ -107,6 +107,15 @@ This is designed to abstract away the implementation specific quit forms." :from-read-eval-print-loop nil :count (or count t) :all t)) + #+(or clasp ecl mkcl) + (let* ((top (si:ihs-top)) + (repeats (if count (min top count) top)) + (backtrace (loop :for ihs :from 0 :below top + :collect (list (si::ihs-fun ihs) + (si::ihs-env ihs))))) + (loop :for i :from 0 :below repeats + :for frame :in (nreverse backtrace) :do + (safe-format! stream "~&~D: ~S~%" i frame))) #+clisp (system::print-backtrace :out stream :limit count) #+(or clozure mcl) @@ -118,15 +127,6 @@ This is designed to abstract away the implementation specific quit forms." (let ((debug:*debug-print-level* *print-level*) (debug:*debug-print-length* *print-length*)) (debug:backtrace (or count most-positive-fixnum) stream)) - #+(or ecl mkcl) - (let* ((top (si:ihs-top)) - (repeats (if count (min top count) top)) - (backtrace (loop :for ihs :from 0 :below top - :collect (list (si::ihs-fun ihs) - (si::ihs-env ihs))))) - (loop :for i :from 0 :below repeats - :for frame :in (nreverse backtrace) :do - (safe-format! stream "~&~D: ~S~%" i frame))) #+gcl (let ((*debug-io* stream)) (ignore-errors @@ -226,17 +226,17 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die" "Find what the actual command line for this process was." #+abcl ext:*command-line-argument-list* ; Use 1.0.0 or later! #+allegro (sys:command-line-arguments) ; default: :application t + #+(or clasp ecl) (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) #+clisp (coerce (ext:argv) 'list) #+clozure ccl:*command-line-argument-list* #+(or cmu scl) extensions:*command-line-strings* - #+ecl (loop :for i :from 0 :below (si:argc) :collect (si:argv i)) #+gcl si:*command-args* #+(or genera mcl) nil #+lispworks sys:*line-arguments-list* #+mkcl (loop :for i :from 0 :below (mkcl:argc) :collect (mkcl:argv i)) #+sbcl sb-ext:*posix-argv* #+xcl system:*argv* - #-(or abcl allegro clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmu ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "raw-command-line-arguments not implemented yet")) (defun command-line-arguments (&optional (arguments (raw-command-line-arguments))) @@ -267,7 +267,7 @@ Otherwise, return NIL." ;; NB: not currently available on ABCL, Corman, Genera, MCL (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl) (first (raw-command-line-arguments)) - #+ecl (si:argv 0) #+mkcl (mkcl:argv 0))) + #+(or clasp ecl) (si:argv 0) #+mkcl (mkcl:argv 0))) (t ;; argv[0] is the name of the interpreter. ;; The wrapper script can export __CL_ARGV0. cl-launch does as of 4.0.1.8. (getenvp "__CL_ARGV0")))) @@ -427,37 +427,38 @@ or COMPRESSION on SBCL, and APPLICATION-TYPE on SBCL/Windows." ;; Is it meaningful to run these in the current environment? ;; only if we also track the object files that constitute the "current" image, ;; and otherwise simulate dump-image, including quitting at the end. - #-(or ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image) - #+(or ecl mkcl) + #-(or clasp ecl mkcl) (error "~S not implemented for your implementation (yet)" 'create-image) + #+(or clasp ecl mkcl) (let ((epilogue-code - (if no-uiop - epilogue-code - (let ((forms - (append - (when epilogue-code `(,epilogue-code)) - (when postludep `((setf *image-postlude* ',postlude))) - (when preludep `((setf *image-prelude* ',prelude))) - (when entry-point-p `((setf *image-entry-point* ',entry-point))) - (case kind - ((:image) - (setf kind :program) ;; to ECL, it's just another program. - `((setf *image-dumped-p* t) - (si::top-level #+ecl t) (quit))) - ((:program) - `((setf *image-dumped-p* :executable) - (shell-boolean-exit - (restore-image)))))))) - (when forms `(progn ,@forms)))))) - #+ecl (check-type kind (member :dll :lib :static-library :program :object :fasl)) - (apply #+ecl 'c::builder #+ecl kind + (if no-uiop + epilogue-code + (let ((forms + (append + (when epilogue-code `(,epilogue-code)) + (when postludep `((setf *image-postlude* ',postlude))) + (when preludep `((setf *image-prelude* ',prelude))) + (when entry-point-p `((setf *image-entry-point* ',entry-point))) + (case kind + ((:image) + (setf kind :program) ;; to ECL, it's just another program. + `((setf *image-dumped-p* t) + (si::top-level #+(or clasp ecl) t) (quit))) + ((:program) + `((setf *image-dumped-p* :executable) + (shell-boolean-exit + (restore-image)))))))) + (when forms `(progn ,@forms)))))) + #+(or clasp ecl) (check-type kind (member :dll :lib :static-library :program :object :fasl)) + (apply #+clasp 'cmp:builder #+clasp kind + #+(or ecl (not clasp)) 'c::builder #+(or ecl (not clasp)) kind #+mkcl (ecase kind ((:dll) 'compiler::build-shared-library) ((:lib :static-library) 'compiler::build-static-library) ((:fasl) 'compiler::build-bundle) ((:program) 'compiler::build-program)) (pathname destination) - #+ecl :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+ecl extra-object-files) - #+ecl :init-name #+ecl (c::compute-init-name (or output-name destination) :kind kind) + #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files (append lisp-object-files #+(or clasp ecl) extra-object-files) + #+(or clasp ecl) :init-name #+(or clasp ecl) (c::compute-init-name (or output-name destination) :kind kind) (append (when prologue-code `(:prologue-code ,prologue-code)) (when epilogue-code `(:epilogue-code ,epilogue-code)) diff --git a/uiop/lisp-build.lisp b/uiop/lisp-build.lisp index 6b105a44..8a664d21 100644 --- a/uiop/lisp-build.lisp +++ b/uiop/lisp-build.lisp @@ -67,26 +67,27 @@ This can help you produce more deterministic output for FASLs.")) #+clozure '(ccl::*nx-speed* ccl::*nx-space* ccl::*nx-safety* ccl::*nx-debug* ccl::*nx-cspeed*) #+(or cmu scl) '(c::*default-cookie*) - #+ecl (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*)) + #+(and ecl (not clasp)) (unless (use-ecl-byte-compiler-p) '(c::*speed* c::*space* c::*safety* c::*debug*)) + #+clasp '() #+gcl '(compiler::*speed* compiler::*space* compiler::*compiler-new-safety* compiler::*debug*) #+lispworks '(compiler::*optimization-level*) #+mkcl '(si::*speed* si::*space* si::*safety* si::*debug*) #+sbcl '(sb-c::*policy*))) (defun get-optimization-settings () "Get current compiler optimization settings, ready to PROCLAIM again" - #-(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl) (warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type)) - #+(or abcl allegro clisp clozure cmu ecl lispworks mkcl sbcl scl xcl) + #+(or abcl allegro clasp clisp clozure cmu ecl lispworks mkcl sbcl scl xcl) (let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity))) #.`(loop #+(or allegro clozure) ,@'(:with info = #+allegro (sys:declaration-information 'optimize) #+clozure (ccl:declaration-information 'optimize nil)) :for x :in settings - ,@(or #+(or abcl ecl gcl mkcl xcl) '(:for v :in +optimization-variables+)) + ,@(or #+(or abcl clasp ecl gcl mkcl xcl) '(:for v :in +optimization-variables+)) :for y = (or #+(or allegro clozure) (second (assoc x info)) ; normalize order #+clisp (gethash x system::*optimize* 1) - #+(or abcl ecl mkcl xcl) (symbol-value v) + #+(or abcl clasp ecl mkcl xcl) (symbol-value v) #+(or cmu scl) (slot-value c::*default-cookie* (case x (compilation-speed 'c::cspeed) (otherwise x))) @@ -610,8 +611,8 @@ possibly in a different process. Otherwise just call THUNK." (defun compile-file-type (&rest keys) "pathname TYPE for lisp FASt Loading files" (declare (ignorable keys)) - #-(or ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) - #+(or ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys))) + #-(or clasp ecl mkcl) (load-time-value (pathname-type (compile-file-pathname "foo.lisp"))) + #+(or clasp ecl mkcl) (pathname-type (apply 'compile-file-pathname "foo" keys))) (defun call-around-hook (hook function) "Call a HOOK around the execution of FUNCTION" @@ -636,7 +637,7 @@ possibly in a different process. Otherwise just call THUNK." (defun* (compile-file*) (input-file &rest keys &key (compile-check *compile-check*) output-file warnings-file - #+clisp lib-file #+(or ecl mkcl) object-file #+sbcl emit-cfasl + #+clisp lib-file #+(or clasp ecl mkcl) object-file #+sbcl emit-cfasl &allow-other-keys) "This function provides a portable wrapper around COMPILE-FILE. It ensures that the OUTPUT-FILE value is only returned and @@ -656,21 +657,23 @@ If WARNINGS-FILE is defined, deferred warnings are saved to that file. On ECL or MKCL, it creates both the linkable object and loadable fasl files. On implementations that erroneously do not recognize standard keyword arguments, it will filter them appropriately." - #+ecl (when (and object-file (equal (compile-file-type) (pathname object-file))) + #+(or clasp ecl) (when (and object-file (equal (compile-file-type) (pathname object-file))) (format t "Whoa, some funky ASDF upgrade switched ~S calling convention for ~S and ~S~%" 'compile-file* output-file object-file) (rotatef output-file object-file)) (let* ((keywords (remove-plist-keys `(:output-file :compile-check :warnings-file - #+clisp :lib-file #+(or ecl mkcl) :object-file) keys)) + #+clisp :lib-file #+(or clasp ecl mkcl) :object-file) keys)) (output-file (or output-file (apply 'compile-file-pathname* input-file :output-file output-file keywords))) - #+ecl + #+(or clasp ecl) (object-file (unless (use-ecl-byte-compiler-p) (or object-file - (compile-file-pathname output-file :type :object)))) + #+ecl(compile-file-pathname output-file :type :object) + #+clasp (compile-file-pathname output-file :output-type :object) + ))) #+mkcl (object-file (or object-file @@ -690,14 +693,18 @@ it will filter them appropriately." (with-enough-pathname (input-file :defaults *base-build-directory*) (with-saved-deferred-warnings (warnings-file :source-namestring (namestring input-file)) (with-muffled-compiler-conditions () - (or #-(or ecl mkcl) + (or #-(or clasp ecl mkcl) (apply 'compile-file input-file :output-file tmp-file #+sbcl (if emit-cfasl (list* :emit-cfasl tmp-cfasl keywords) keywords) #-sbcl keywords) #+ecl (apply 'compile-file input-file :output-file - (if object-file - (list* object-file :system-p t keywords) - (list* tmp-file keywords))) + (if object-file + (list* object-file :system-p t keywords) + (list* tmp-file keywords))) + #+clasp (apply 'compile-file input-file :output-file + (if object-file + (list* object-file :output-type :object #|:system-p t|# keywords) + (list* tmp-file keywords))) #+mkcl (apply 'compile-file input-file :output-file object-file :fasl-p nil keywords))))) (cond @@ -707,20 +714,22 @@ it will filter them appropriately." (and (check-flag failure-p *compile-file-failure-behaviour*) (check-flag warnings-p *compile-file-warnings-behaviour*))) (progn - #+(or ecl mkcl) - (when (and #+ecl object-file) + #+(or clasp ecl mkcl) + (when (and #+(or clasp ecl) object-file) (setf output-truename - (compiler::build-fasl - tmp-file #+ecl :lisp-files #+mkcl :lisp-object-files - (list object-file)))) + (compiler::build-fasl tmp-file + #+(or clasp ecl) :lisp-files #+mkcl :lisp-object-files + (list object-file)))) (or (not compile-check) - (apply compile-check input-file :output-file tmp-file keywords)))) + (apply compile-check input-file :output-file #+clasp output-file #+ecl tmp-file keywords)))) (delete-file-if-exists output-file) (when output-truename + #+clasp (when output-truename (rename-file-overwriting-target tmp-file output-truename)) #+clisp (when lib-file (rename-file-overwriting-target tmp-lib lib-file)) #+sbcl (when cfasl-file (rename-file-overwriting-target tmp-cfasl cfasl-file)) (rename-file-overwriting-target output-truename output-file) (setf output-truename (truename output-file))) + #+clasp (delete-file-if-exists tmp-file) #+clisp (delete-file-if-exists tmp-lib)) (t ;; error or failed check (delete-file-if-exists output-truename) @@ -779,4 +788,3 @@ it will filter them appropriately." (scm:concatenate-system output :fasls-to-concatenate)) (loop :for f :in fasls :do (ignore-errors (delete-file f))) (ignore-errors (lispworks:delete-system :fasls-to-concatenate)))))) - diff --git a/uiop/os.lisp b/uiop/os.lisp index a00119bf..1c5a9d92 100644 --- a/uiop/os.lisp +++ b/uiop/os.lisp @@ -82,7 +82,7 @@ that is neither Unix, nor Windows, nor Genera, nor even old MacOS.~%Now you port Beware: may return empty string if a variable is present but empty; use getenvp to return NIL in such a case." (declare (ignorable x)) - #+(or abcl clisp ecl xcl) (ext:getenv x) + #+(or abcl clasp clisp ecl xcl) (ext:getenv x) #+allegro (sys:getenv x) #+clozure (ccl:getenv x) #+cmu (unix:unix-getenv x) @@ -106,7 +106,7 @@ use getenvp to return NIL in such a case." (ccl:%get-cstring value)))) #+mkcl (#.(or (find-symbol* 'getenv :si nil) (find-symbol* 'getenv :mk-ext nil)) x) #+sbcl (sb-ext:posix-getenv x) - #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mcl mkcl sbcl scl xcl) (error "~S is not supported on your implementation" 'getenv)) @@ -151,7 +151,7 @@ then returning the non-empty string value of the variable" "The type of Lisp implementation used, as a short UIOP-standardized keyword" (first-feature '(:abcl (:acl :allegro) (:ccl :clozure) :clisp (:corman :cormanlisp) - (:cmu :cmucl :cmu) :ecl :gcl + (:cmu :cmucl :cmu) :clasp :ecl :gcl (:lwpe :lispworks-personal-edition) (:lw :lispworks) :mcl :mkcl :sbcl :scl (:smbx :symbolics) :xcl))) @@ -217,9 +217,11 @@ then returning the non-empty string value of the variable" #+scl (format nil "~A~A" s ;; ANSI upper case vs lower case. (ecase ext:*case-mode* (:upper "") (:lower "l"))) - #+ecl (format nil "~A~@[-~A~]" s - (let ((vcs-id (ext:lisp-implementation-vcs-id))) - (subseq vcs-id 0 (min (length vcs-id) 8)))) + #+clasp (format nil "~A-~A" + s (core:lisp-implementation-id)) + #+(and ecl (not clasp)) (format nil "~A~@[-~A~]" s + (let ((vcs-id (ext:lisp-implementation-vcs-id))) + (subseq vcs-id 0 (min (length vcs-id) 8)))) #+gcl (subseq s (1+ (position #\space s))) #+genera (multiple-value-bind (major minor) (sct:get-system-version "System") @@ -245,7 +247,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie (defun hostname () "return the hostname of the current host" ;; Note: untested on RMCL - #+(or abcl clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) + #+(or abcl clasp clozure cmu ecl genera lispworks mcl mkcl sbcl scl xcl) (machine-instance) #+cormanlisp "localhost" ;; is there a better way? Does it matter? #+allegro (symbol-call :excl.osi :gethostname) #+clisp (first (split-string (machine-instance) :separator " ")) @@ -274,7 +276,7 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie #+(or cmu scl) (#+cmu parse-unix-namestring* #+scl lisp::parse-unix-namestring (strcat (nth-value 1 (unix:unix-current-directory)) "/")) #+cormanlisp (pathname (pl::get-current-directory)) ;; Q: what type does it return? - #+ecl (ext:getcwd) + #+(or clasp ecl) (ext:getcwd) #+gcl (let ((*default-pathname-defaults* #p"")) (truename #p"")) #+genera *default-pathname-defaults* ;; on a Lisp OS, it *is* canonical! #+lispworks (hcl:get-working-directory) @@ -293,13 +295,13 @@ suitable for use as a directory name to segregate Lisp FASLs, C dynamic librarie #+(or cmu scl) (unix:unix-chdir (ext:unix-namestring x)) #+cormanlisp (unless (zerop (win32::_chdir (namestring x))) (error "Could not set current directory to ~A" x)) - #+ecl (ext:chdir x) + #+(or clasp ecl) (ext:chdir x) #+gcl (system:chdir x) #+genera (setf *default-pathname-defaults* x) #+lispworks (hcl:change-directory x) #+mkcl (mk-ext:chdir x) #+sbcl (progn (require :sb-posix) (symbol-call :sb-posix :chdir (sb-ext:native-namestring x))) - #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl) + #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl genera lispworks mkcl sbcl scl) (error "chdir not supported on your implementation")))) diff --git a/uiop/package.lisp b/uiop/package.lisp index 58d8e67a..8f7b0547 100644 --- a/uiop/package.lisp +++ b/uiop/package.lisp @@ -734,7 +734,7 @@ UNINTERN -- Remove symbols here from PACKAGE." (let ((ensure-form `(apply 'ensure-package ',(parse-define-package-form package clauses)))) `(progn - #+(or ecl gcl mkcl) (defpackage ,package (:use)) + #+(or clasp ecl gcl mkcl) (defpackage ,package (:use)) (eval-when (:compile-toplevel :load-toplevel :execute) ,ensure-form)))) diff --git a/uiop/pathname.lisp b/uiop/pathname.lisp index fac687d0..19cbf132 100644 --- a/uiop/pathname.lisp +++ b/uiop/pathname.lisp @@ -92,7 +92,7 @@ by the underlying implementation's MAKE-PATHNAME and other primitives" ;; This will be :unspecific if supported, or NIL if not. (defparameter *unspecific-pathname-type* #+(or abcl allegro clozure cmu genera lispworks sbcl scl) :unspecific - #+(or clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil + #+(or clasp clisp ecl mkcl gcl xcl #|These haven't been tested:|# cormanlisp mcl) nil "Unspecific type component to use with the underlying implementation's MAKE-PATHNAME") (defun make-pathname* (&rest keys &key (directory nil) diff --git a/uiop/run-program.lisp b/uiop/run-program.lisp index c622339d..1e43cd0c 100644 --- a/uiop/run-program.lisp +++ b/uiop/run-program.lisp @@ -378,8 +378,8 @@ argument to pass to the internal RUN-PROGRAM" ((eql :interactive) #+allegro nil #+clisp :terminal - #+(or clozure cmu ecl mkcl sbcl scl) t) - #+(or allegro clozure cmu ecl lispworks mkcl sbcl scl) + #+(or clasp clozure cmu ecl mkcl sbcl scl) t) + #+(or allegro clasp clozure cmu ecl lispworks mkcl sbcl scl) ((eql :output) (if (eq role :error-output) :output @@ -447,8 +447,8 @@ It returns a process-info plist with possible keys: #+os-windows (string (run 'ext:run-shell-command %command)) (list (run 'ext:run-program (car %command) :arguments (cdr %command))))) - #+(or clozure cmu ecl mkcl sbcl scl) - (#-(or ecl mkcl) progn #+(or ecl mkcl) multiple-value-list + #+(or clasp clozure cmu ecl mkcl sbcl scl) + (#-(or clasp ecl mkcl) progn #+(or clasp ecl mkcl) multiple-value-list (apply '#+(or cmu ecl scl) ext:run-program #+clozure ccl:run-program #+sbcl sb-ext:run-program #+mkcl mk-ext:run-program @@ -526,8 +526,8 @@ It returns a process-info plist with possible keys: #+clozure (ccl:external-process-error-stream process*) #+(or cmu scl) (ext:process-error process*) #+sbcl (sb-ext:process-error process*)))) - #+(or ecl mkcl) - (destructuring-bind #+ecl (stream code process) #+mkcl (stream process code) process* + #+(or clasp ecl mkcl) + (destructuring-bind #+(or clasp ecl) (stream code process) #+mkcl (stream process code) process* (let ((mode (+ (if (eq input :stream) 1 0) (if (eq output :stream) 2 0)))) (cond ((zerop mode)) @@ -552,7 +552,7 @@ It returns a process-info plist with possible keys: (declare (ignorable process)) #+(or allegro lispworks) process #+clozure (ccl::external-process-pid process) - #+ecl (si:external-process-pid process) + #+(or clasp ecl) (si:external-process-pid process) #+(or cmu scl) (ext:process-pid process) #+mkcl (mkcl:process-id process) #+sbcl (sb-ext:process-pid process) @@ -565,13 +565,13 @@ It returns a process-info plist with possible keys: ;; 1- wait #+clozure (ccl::external-process-wait process) #+(or cmu scl) (ext:process-wait process) - #+(and ecl os-unix) (ext:external-process-wait process) + #+(and (or clasp ecl) os-unix) (ext:external-process-wait process) #+sbcl (sb-ext:process-wait process) ;; 2- extract result #+allegro (sys:reap-os-subprocess :pid process :wait t) #+clozure (nth-value 1 (ccl:external-process-status process)) #+(or cmu scl) (ext:process-exit-code process) - #+ecl (nth-value 1 (ext:external-process-status process)) + #+(or clasp ecl) (nth-value 1 (ext:external-process-status process)) #+lispworks (if-let ((stream (or (getf process-info :input-stream) (getf process-info :output-stream) @@ -773,7 +773,7 @@ It returns a process-info plist with possible keys: #+(or allegro clozure cmu (and lispworks os-unix) sbcl scl) (%wait-process-result (apply '%run-program (%normalize-system-command command) :wait t keys)) - #+(or abcl cormanlisp clisp ecl gcl genera (and lispworks os-windows) mkcl xcl) + #+(or abcl clasp clisp cormanlisp ecl gcl genera (and lispworks os-windows) mkcl xcl) (let ((%command (%redirected-system-command command input output error-output directory))) #+(and lispworks os-windows) (system:call-system %command :current-directory directory :wait t) @@ -785,7 +785,7 @@ It returns a process-info plist with possible keys: (with-current-directory ((unless (os-unix-p) directory)) #+abcl (ext:run-shell-command %command) #+cormanlisp (win32:system %command) - #+ecl (let ((*standard-input* *stdin*) + #+(or clasp ecl) (let ((*standard-input* *stdin*) (*standard-output* *stdout*) (*error-output* *stderr*)) (ext:system %command)) @@ -872,11 +872,11 @@ RUN-PROGRAM returns 3 values: 2- either 0 if the subprocess exited with success status, or an indication of failure via the EXIT-CODE of the process" (declare (ignorable ignore-error-status)) - #-(or abcl allegro clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl) + #-(or abcl allegro clasp clisp clozure cmu cormanlisp ecl gcl lispworks mcl mkcl sbcl scl xcl) (error "RUN-PROGRAM not implemented for this Lisp") (flet ((default (x xp output) (cond (xp x) ((eq output :interactive) :interactive)))) (apply (if (or force-shell - #+(or clisp ecl) (or (not ignore-error-status) t) + #+(or clasp clisp ecl) (or (not ignore-error-status) t) #+clisp (eq error-output :interactive) #+(or abcl clisp) (eq :error-output :output) #+(and lispworks os-unix) (%interactivep input output error-output) diff --git a/uiop/stream.lisp b/uiop/stream.lisp index db7ae94e..9a6ceef2 100644 --- a/uiop/stream.lisp +++ b/uiop/stream.lisp @@ -46,7 +46,7 @@ (setf *stdin* #.(or #+clozure 'ccl::*stdin* #+(or cmu scl) 'system:*stdin* - #+ecl 'ext::+process-standard-input+ + #+(or clasp ecl) 'ext::+process-standard-input+ #+sbcl 'sb-sys:*stdin* '*standard-input*))) @@ -57,7 +57,7 @@ (setf *stdout* #.(or #+clozure 'ccl::*stdout* #+(or cmu scl) 'system:*stdout* - #+ecl 'ext::+process-standard-output+ + #+(or clasp ecl) 'ext::+process-standard-output+ #+sbcl 'sb-sys:*stdout* '*standard-output*))) @@ -69,7 +69,7 @@ #.(or #+allegro 'excl::*stderr* #+clozure 'ccl::*stderr* #+(or cmu scl) 'system:*stderr* - #+ecl 'ext::+process-error-output+ + #+(or clasp ecl) 'ext::+process-error-output+ #+sbcl 'sb-sys:*stderr* '*error-output*))) diff --git a/uiop/utility.lisp b/uiop/utility.lisp index e9dd0ca0..6bc4ff47 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -7,9 +7,9 @@ (:use :uiop/common-lisp :uiop/package) ;; import and reexport a few things defined in :uiop/common-lisp (:import-from :uiop/common-lisp #:compatfmt #:loop* #:frob-substrings - #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) + #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix) (:export #:compatfmt #:loop* #:frob-substrings #:compatfmt - #+ecl #:use-ecl-byte-compiler-p #+mcl #:probe-posix) + #+(or clasp ecl) #:use-ecl-byte-compiler-p #+mcl #:probe-posix) (:export ;; magic helper to define debugging functions: #:uiop-debug #:load-uiop-debug-utility #:*uiop-debug-utility* @@ -72,9 +72,9 @@ `(progn ;; We usually try to do it only for the functions that need it, ;; which happens in asdf/upgrade - however, for ECL, we need this hammer. - ,@(when (or supersede #+ecl t) + ,@(when (or supersede #+(or clasp ecl) t) `((undefine-function ',name))) - ,@(when (and #+ecl (symbolp name)) ; fails for setf functions on ecl + ,@(when (and #+(or clasp ecl) (symbolp name)) ; fails for setf functions on ecl `((declaim (notinline ,name)))) (,',def ,name ,formals ,@rest)))))) (defdef defgeneric* defgeneric) @@ -548,10 +548,10 @@ with later being determined by a lexicographical comparison of minor numbers." #+clisp 'system::$format-control #+clozure 'ccl::format-control #+(or cmu scl) 'conditions::format-control - #+(or ecl mkcl) 'si::format-control + #+(or clasp ecl mkcl) 'si::format-control #+(or gcl lispworks) 'conditions::format-string #+sbcl 'sb-kernel:format-control - #-(or abcl allegro clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil + #-(or abcl allegro clasp clisp clozure cmu ecl gcl lispworks mkcl sbcl scl) nil "Name of the slot for FORMAT-CONTROL in simple-condition") (defun match-condition-p (x condition) -- GitLab