Skip to content
Snippets Groups Projects
Commit f127ffb8 authored by Robert P. Goldman's avatar Robert P. Goldman
Browse files

Patch from Jean-Claude Beaudoin adding MKCL support.

parent 52bce047
No related branches found
No related tags found
No related merge requests found
Showing with 173 additions and 32 deletions
......@@ -60,7 +60,9 @@ all_lisp := $(header_lisp) $(driver_lisp) $(defsystem_lisp)
# Making ASDF itself should be our first, default, target:
build/asdf.lisp: $(all_lisp)
mkdir -p build
rm -f $@
cat $(all_lisp) > $@
chmod -w $@ # try to prevent accidental editing.
# This quickly locates such mistakes as unbalanced parentheses:
load: build/asdf.lisp
......@@ -120,6 +122,7 @@ clean:
fi; \
done
rm -rf build/ LICENSE test/try-reloading-dependency.asd test/hello-world-example asdf.lisp
rm -rf test/hello-world-example.exe test/mkcl_*.dll # needed only on MS-Windows
rm -rf .pc/ build-stamp debian/patches/ debian/debhelper.log debian/cl-asdf/ # debian crap
${MAKE} -C doc clean
......
......@@ -26,9 +26,7 @@
((build-args :initarg :args :initform nil :accessor bundle-op-build-args)
(name-suffix :initarg :name-suffix :initform nil)
(bundle-type :initform :no-output-file :reader bundle-type)
#+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)
#+mkcl (do-fasb :initarg :do-fasb :initform t :reader bundle-op-do-fasb-p)
#+mkcl (do-static-library :initarg :do-static-library :initform t :reader bundle-op-do-static-library-p)))
#+ecl (lisp-files :initform nil :accessor bundle-op-lisp-files)))
(defclass monolithic-op (operation) ()
(:documentation "A MONOLITHIC operation operates on a system *and all of its
......@@ -47,6 +45,20 @@ itself.")) ;; operation on a system and its dependencies
((prologue-code :accessor prologue-code)
(epilogue-code :accessor epilogue-code)))
#+mkcl
(defclass program (bundle-system)
(
(prologue-code :initarg :prologue-code :initform nil :accessor prologue-code)
(epilogue-code :initarg :epilogue-code :initform nil :accessor epilogue-code)
(prefix-lisp-object-files :initarg :prefix-lisp-object-files
:initform nil :accessor program-prefix-lisp-object-files)
(postfix-lisp-object-files :initarg :postfix-lisp-object-files
:initform nil :accessor program-postfix-lisp-object-files)
(object-files :initarg :object-files
:initform nil :accessor program-object-files)
(extra-build-args :initarg :extra-build-args
:initform nil :accessor program-extra-build-args)))
(defmethod prologue-code ((x t)) nil)
(defmethod epilogue-code ((x t)) nil)
......@@ -77,7 +89,7 @@ itself.")) ;; operation on a system and its dependencies
((bundle-type :initform :fasl)))
(defclass prepare-fasl-op (sideway-operation)
((sideway-operation :initform #+ecl 'load-fasl-op #-ecl 'load-op :allocation :class)))
((sideway-operation :initform #+(or ecl mkcl) 'load-fasl-op #-(or ecl mkcl) 'load-op :allocation :class)))
(defclass lib-op (link-op gather-op non-propagating-operation)
((bundle-type :initform :lib))
......@@ -123,7 +135,7 @@ itself.")) ;; operation on a system and its dependencies
(defclass image-op (monolithic-bundle-op selfward-operation
#+ecl link-op #+(or ecl mkcl) gather-op)
((bundle-type :initform :image)
(selfward-operation :initform '(#-ecl load-op) :allocation :class))
(selfward-operation :initform '(#-(or ecl mkcl) load-op) :allocation :class))
(:documentation "create an image file from the system and its dependencies"))
(defclass program-op (image-op)
......@@ -139,8 +151,9 @@ itself.")) ;; operation on a system and its dependencies
((member :dll :lib :shared-library :static-library :program :object :program)
(compile-file-type :type bundle-type))
((member :image) "image")
((eql :dll) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
((member :lib :static-library) (cond ((os-unix-p) "a") ((os-windows-p) "lib")))
((member :dll :shared-library) (cond ((os-macosx-p) "dylib") ((os-unix-p) "so") ((os-windows-p) "dll")))
((member :lib :static-library) (cond ((os-unix-p) "a")
((os-windows-p) (if (featurep '(:or :mingw32 :mingw64)) "a" "lib"))))
((eql :program) (cond ((os-unix-p) nil) ((os-windows-p) "exe")))))
(defun bundle-output-files (o c)
......@@ -189,14 +202,14 @@ 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" #-ecl "--system")))) ; . no good for Logical Pathnames
(if (operation-monolithic-p instance) "--all-systems" #-(or ecl mkcl) "--system")))) ; . no good for Logical Pathnames
(when (typep instance 'monolithic-bundle-op)
(destructuring-bind (&key lisp-files prologue-code epilogue-code
(destructuring-bind (&key #-mkcl 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 epilogue-code prologue-code)))
#-(or ecl mkcl) (assert (null (or lisp-files epilogue-code prologue-code)))
#+ecl (setf (bundle-op-lisp-files instance) lisp-files)))
(setf (bundle-op-build-args instance)
(remove-plist-keys
......@@ -208,7 +221,9 @@ itself.")) ;; operation on a system and its dependencies
(declare (ignorable type))
(or #+ecl (or (equalp type (compile-file-type :type :object))
(equalp type (compile-file-type :type :static-library)))
#+mkcl (equalp type (compile-file-type :fasl-p nil))
#+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"))
#+(or abcl allegro clisp clozure cmu lispworks sbcl scl xcl) (equalp type (compile-file-type)))))
(defgeneric* (trivial-system-p) (component))
......@@ -344,7 +359,15 @@ itself.")) ;; operation on a system and its dependencies
nil)
(defmethod component-depends-on ((o monolithic-lib-op) (c prebuilt-system))
nil))
nil)
#+mkcl
(defmethod perform ((o fasl-op) (c prebuilt-system))
nil)
#+mkcl
(defmethod output-files ((o lib-op) (c prebuilt-system))
(list (prebuilt-system-static-library c))))
;;;
......@@ -361,6 +384,7 @@ itself.")) ;; operation on a system and its dependencies
(library (second inputs))
(asd (first (output-files o s)))
(name (if (and fasl asd) (pathname-name asd) (return-from perform)))
(version (component-version s))
(dependencies
(if (operation-monolithic-p o)
(remove-if-not 'builtin-system-p
......@@ -388,8 +412,9 @@ itself.")) ;; operation on a system and its dependencies
(machine-type)
(software-version))
(let ((*package* (find-package :asdf-user)))
(pprint `(defsystem ,name
(pprint `(asdf/defsystem:defsystem ,name
:class prebuilt-system
:version ,version
:depends-on ,depends-on
:components ((:compiled-file ,(pathname-name fasl)))
,@(when library `(:lib ,(file-namestring library))))
......@@ -430,7 +455,7 @@ itself.")) ;; operation on a system and its dependencies
(asdf:load-system :precompiled-asdf-utils)
|#
#+(or ecl mkcl)
#+ecl
(with-upgradability ()
(defun uiop-library-file ()
(or (and (find-system :uiop nil)
......@@ -447,8 +472,10 @@ itself.")) ;; operation on a system and its dependencies
(and (system-source-directory :asdf)
(plan-operates-on-p plan '("asdf"))))
(pushnew (uiop-library-file) files :test 'pathname-equal))
files))
files)))
#+(or ecl mkcl)
(with-upgradability ()
(defun register-pre-built-system (name)
(register-system (make-instance 'system :name (coerce-name name) :source-file nil))))
......@@ -477,14 +504,28 @@ itself.")) ;; operation on a system and its dependencies
#+mkcl
(with-upgradability ()
(defmethod perform ((o dll-op) (s system))
(apply #'compiler::build-shared-library (output-file o s)
:lisp-object-files (input-files o s) (bundle-op-build-args o)))
(defmethod perform ((o lib-op) (s system))
(apply #'compiler::build-static-library (output-file o c)
(apply #'compiler::build-static-library (output-file o s)
:lisp-object-files (input-files o s) (bundle-op-build-args o)))
(defmethod perform ((o basic-fasl-op) (s system))
(apply #'compiler::build-bundle (output-file o c) ;; second???
(apply #'compiler::build-bundle (output-file o s)
:lisp-object-files (input-files o s) (bundle-op-build-args o)))
(defmethod perform ((o program-op) (s system))
(apply #'compiler::build-program (output-file o s)
:lisp-object-files (append (program-prefix-lisp-object-files s)
(input-files o s)
(program-postfix-lisp-object-files s))
:object-files (program-object-files s)
:prologue-code (prologue-code s)
:epilogue-code (epilogue-code s)
(program-extra-build-args s)))
(defun bundle-system (system &rest args &key force (verbose t) version &allow-other-keys)
(declare (ignore force verbose version))
(apply #'operate 'deliver-asd-op system args)))
......
......@@ -20,7 +20,7 @@
#+(or ecl mkcl)
(progn
(pushnew '("fasb" . si::load-binary) si:*load-hooks* :test 'equal :key 'car)
(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)
......
......@@ -155,8 +155,8 @@ system names to pathnames of .asd files")
(defun wrapping-source-registry ()
`(:source-registry
#+(or ecl sbcl) (:tree ,(resolve-symlinks* (lisp-implementation-directory)))
#+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
:inherit-configuration
#+mkcl (:tree ,(translate-logical-pathname "CONTRIB:"))
#+cmu (:tree #p"modules:")
#+scl (:tree #p"file://modules/")))
(defun default-source-registry ()
......
......@@ -9,3 +9,13 @@ int sample_function()
return 42;
}
")
#+mkcl
(ffi:clines "
extern MKCL_DLLEXPORT int sample_function(void);
int sample_function(void)
{
return 42;
}
")
(defpackage :test-asdf/dll-user (:use)) ;; dummy, for package-system dependencies.
(in-package :test-package)
#+(and mkcl windows)
(ffi:clines "extern __declspec(dllimport) int sample_function(void);")
#-(and mkcl windows)
(ffi:clines "extern int sample_function(void);")
(ffi:def-function "sample_function" () :returning :int)
;; Example executable program
#-mkcl
(defsystem :hello-world-example
:build-operation program-op
:entry-point "hello:entry-point"
:depends-on (:uiop)
:components ((:file "hello")))
#+mkcl
(defsystem :hello-world-example
:class asdf/bundle::program
:build-operation program-op
:entry-point "hello:entry-point"
:depends-on (:uiop)
:components ((:file "hello"))
:prefix-lisp-object-files #.(list (namestring (truename (translate-logical-pathname #P"SYS:cmp.a"))))
:extra-build-args #.(or #-windows '(:use-mkcl-shared-libraries nil))
:epilogue-code (progn
(setq uiop/image:*image-dumped-p* :executable)
(uiop/image:restore-image :entry-point (read-from-string "hello:entry-point"))))
......@@ -12,4 +12,5 @@
t)
(defun entry-point ()
(apply 'main *command-line-arguments*))
(apply 'main *command-line-arguments*)
#+mkcl (quit))
......@@ -2,7 +2,7 @@
#+lispworks (lispworks:load-all-patches)
(load (make-pathname :name "script-support" :defaults *load-pathname*))
(load-asdf)
#+ecl (require :cmp)
#+(or 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*)
......
......@@ -9,3 +9,13 @@ int always_7()
return 7;
}
")
#+mkcl
(ffi:clines "
extern MKCL_DLLEXPORT int always_7(void);
int always_7(void)
{
return 7;
}
")
......@@ -9,3 +9,13 @@ int always_42()
return 6*always_7();
}
")
#+mkcl
(ffi:clines "
extern MKCL_DLLEXPORT int always_42(void);
int always_42(void)
{
return 6*always_7();
}
")
......@@ -142,6 +142,9 @@ Some constraints:
(cond
((equal x y)
(format t "~S and~% ~S both evaluate to same path:~% ~S~%" qx qy x))
#+mkcl
((acall :pathname-equal x y)
(format t "~S and ~S evaluate to functionaly equivalent paths, respectively:~% ~S~%and~% ~S~%" qx qy x y))
((acall :pathname-equal x y)
(warn "These two expressions yield pathname-equal yet not equal path~%~
the first expression ~S yields this:~% ~S~% ~S~%
......
......@@ -61,3 +61,23 @@
(si:load-foreign-module (first (output-files 'monolithic-dll-op :test-asdf/monodll)))
(operate 'load-op :test-asdf/monodll-user)
(assert-equal (test-package::always-42) 42))
;;; Test DLL-op and monolithic-dll-op on MKCL.
#+mkcl
(progn
(require 'sockets) ;; Test the pre-compiled system feature
(operate 'dll-op :test-asdf/dll-test)
(let ((dll (first (output-files 'dll-op :test-asdf/dll-test))))
(si:load-foreign-module dll)
(let* ( #+windows (compiler::*builder-default-libraries* (list (namestring dll))))
(operate 'load-op :test-asdf/dll-user)))
(assert (= (test-package::sample-function) 42))
(let* #+windows ((lib (first (output-files (operate 'lib-op :test-asdf/monodll-1) :test-asdf/monodll-1)))
(compiler::*builder-default-libraries* (list (namestring lib))))
#-windows ()
(operate 'monolithic-dll-op :test-asdf/monodll))
(let ((dll (first (output-files 'monolithic-dll-op :test-asdf/monodll))))
(si:load-foreign-module dll)
(let* ( #+windows (compiler::*builder-default-libraries* (list (namestring dll))))
(operate 'load-op :test-asdf/monodll-user)))
(assert-equal (test-package::always-42) 42))
......@@ -2,7 +2,7 @@
(DBG :foo (current-lisp-file-pathname))
(unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks sbcl) t
(unless (or #+(or clisp clozure (and ecl (not ecl-bytecmp)) lispworks mkcl sbcl) t
#+cmu nil ;; uncomment if you have 32-bit gcc support - or can autodetect
#+clisp (version-satisfies
(first (split-string (lisp-implementation-version) :separator " "))
......@@ -13,6 +13,8 @@
(defparameter exe (output-file (make-operation 'program-op) (find-system :hello-world-example)))
(assert (absolute-pathname-p exe))
#-mkcl
(progn
;; Try to load lisp-invocation from xcvb
(setf *central-registry*
(list *asdf-directory* ;; be sure that *OUR* asdf is first of any possible ASDF
......@@ -35,7 +37,23 @@
(symbol-call :lisp-invocation :lisp-invocation-arglist
:load (native-namestring (subpathname *test-directory* "make-hello-world.lisp")))
:output t :error-output :output :input nil))
0)
0))
#+mkcl
(progn
(operate 'program-op :hello-world-example)
#+windows
(let*
((dll-orig (merge-pathnames (make-pathname :name (mkcl:str+ "mkcl_" (lisp-implementation-version)) :type "dll")
(si::self-truename)))
(exe (car (asdf::output-files 'program-op :hello-world-example)))
(exe-dir (make-pathname :name nil :type nil :defaults exe))
(dll-dest (merge-pathnames exe-dir dll-orig)))
;; make sure mkcl-X.X.X.dll is the same directory as the executable
(copy-file dll-orig dll-dest)))
(assert (probe-file* exe))
(assert-equal (run-program `(,(native-namestring exe)) :output :lines)
......
......@@ -30,7 +30,7 @@
;;;; Early meta-level tweaks
#+(or abcl allegro clisp cmu ecl mkcl clozure lispworks sbcl scl)
#+(or abcl allegro 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.
......
......@@ -13,3 +13,5 @@
:uiop/os :uiop/pathname :uiop/stream :uiop/filesystem :uiop/image
:uiop/run-program :uiop/lisp-build
:uiop/configuration :uiop/backward-driver))
#+mkcl (provide :uiop)
......@@ -598,7 +598,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 lispworks sbcl scl xcl)
#-(or abcl allegro clisp clozure cmu cormanlisp digitool ecl gcl 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))
......
......@@ -118,7 +118,7 @@ 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))
#+ecl
#+(or ecl mkcl)
(let* ((top (si:ihs-top))
(repeats (if count (min top count) top))
(backtrace (loop :for ihs :from 0 :below top
......@@ -233,9 +233,10 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die"
#+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 sbcl scl xcl)
#-(or abcl allegro 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)))
......@@ -266,7 +267,7 @@ Otherwise, return NIL."
;; NB: not currently available on ABCL, Corman, Genera, MCL, MKCL
(or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl)
(first (raw-command-line-arguments))
#+ecl (si:argv 0)))
#+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"))))
......
......@@ -62,16 +62,17 @@ This can help you produce more deterministic output for FASLs."))
"Optimization settings saved by PROCLAIM-OPTIMIZATION-SETTINGS")
(defun get-optimization-settings ()
"Get current compiler optimization settings, ready to PROCLAIM again"
#-(or clisp clozure cmu ecl sbcl scl)
#-(or clisp clozure cmu ecl mkcl sbcl scl)
(warn "~S does not support ~S. Please help me fix that." 'get-optimization-settings (implementation-type))
#+clozure (ccl:declaration-information 'optimize nil)
#+(or clisp cmu ecl sbcl scl)
#+(or clisp cmu ecl mkcl sbcl scl)
(let ((settings '(speed space safety debug compilation-speed #+(or cmu scl) c::brevity)))
#.`(loop :for x :in settings
,@(or #+ecl '(:for v :in '(c::*speed* c::*space* c::*safety* c::*debug*))
#+mkcl '(:for v :in '(si::*speed* si::*space* si::*safety* si::*debug*))
#+(or cmu scl) '(:for f :in '(c::cookie-speed c::cookie-space c::cookie-safety c::cookie-debug c::cookie-cspeed c::cookie-brevity)))
:for y = (or #+clisp (gethash x system::*optimize*)
#+(or ecl) (symbol-value v)
#+(or ecl mkcl) (symbol-value v)
#+(or cmu scl) (funcall f c::*default-cookie*)
#+sbcl (cdr (assoc x sb-c::*policy*)))
:when y :collect (list x y))))
......
......@@ -49,7 +49,7 @@ keywords explicitly."
(defun os-windows-p ()
"Is the underlying operating system Microsoft Windows?"
(or #+abcl (featurep :windows)
#+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32)) t))
#+(and (not (or abcl unix cygwin darwin)) (or win32 windows mswindows mingw32 mingw64)) t))
(defun os-genera-p ()
"Is the underlying operating system Genera (running on a Symbolics Lisp Machine)?"
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment