Commit 2fceea52 authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

Add CLASP support

Based on a contribution by Christian Shafmeister.
parent 99feb369
......@@ -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*)
......
......@@ -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)
......
......@@ -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
......
......@@ -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
......
......@@ -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:") ())
......
......@@ -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:")
......
(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);
......
......@@ -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*)
......
(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);
......
(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);
......
......@@ -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 "
......
......@@ -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)))))))
......
......@@ -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."))
......@@ -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))
......
......@@ -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)))
......@@ -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))
......
......@@ -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))
......
......@@ -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*