Skip to content
Snippets Groups Projects

Compare revisions

Changes are shown as if the source revision was being merged into the target revision. Learn more about comparing revisions.

Source

Select target project
No results found

Target

Select target project
  • qitab/lisp-invocation
1 result
Show changes
Commits on Source (2)
(defpackage :lisp-invocation/allegro-variants
(uiop:define-package :lisp-invocation/allegro-variants
(:use :common-lisp :fare-utils :uiop :lisp-invocation/lisp-invocation)
(:import-from #:lisp-invocation ;; slot names
#:name #:flags #:disable-debugger #:load-flag #:eval-flag
#:image-flag #:default-image #:image-executable-p #:standalone-executable
#:arguments-end #:argument-control)
(:export #:all-allegro-variants #:current-lisp-variant))
(in-package :lisp-invocation/allegro-variants)
......@@ -16,7 +20,67 @@ locations, you may simply specify the Allegro install directories using these va
ALLEGRODIR, and ALLEGROSDIR.
|#
(defun all-allegro-variants ()
(defclass allegro-implementation (simple-lisp-implementation)
((build :initarg :build :reader allegro-implementation-build)))
(defmethod lisp-implementation-invocation-arglist
((implementation allegro-implementation)
&key
lisp-path
(lisp-flags :default)
(image-path nil image-path-p)
load
eval
arguments
debugger
cross-compile
console)
(nest
(if (not (and console (allegro-implementation-build implementation)))
(call-next-method))
(with-slots (name flags disable-debugger load-flag eval-flag
image-flag default-image image-executable-p standalone-executable build
arguments-end argument-control)
implementation)
(let* ((implementation-type (lisp-implementation-implementation-type implementation))
(envexe (getenv-pathname (lisp-environment-variable-name
:type implementation-type :prefix (when cross-compile "X")))))
(unless image-path-p
(setf image-path (if envexe
(native-namestring (make-pathname :defaults envexe :type "dxl"))
default-image))))
(append
(when (or (null image-path) (not image-executable-p))
(ensure-list
(or
(when lisp-path (ensure-list lisp-path))
(ensure-path-executable lisp-path)
(when envexe (ensure-path-executable (make-pathname :name build :defaults envexe)))
name)))
(when (and image-path (not image-executable-p))
(list image-flag))
(when image-path
(list
(if image-executable-p
(ensure-path-executable image-path)
image-path)))
(if (eq lisp-flags :default)
flags
lisp-flags)
(unless debugger
disable-debugger)
(mapcan (if load-flag
(lambda (x) (list load-flag (native-namestring x)))
(lambda (x) (list eval-flag (format nil "(load ~S)" (native-namestring x)))))
(ensure-list load))
(when eval
(list eval-flag eval))
(when arguments
(unless argument-control
(error "Can't reliably pass arguments to Lisp implementation ~A" implementation-type))
(cons arguments-end arguments)))))
(defun all-allegro-variants (&optional (windowsp (os-windows-p)))
"Return a list of possible Allegro variants based on built-in information
and environment variables. The returned list is made up of argument lists for
REGISTER-LISP-IMPLEMENTATION."
......@@ -24,7 +88,6 @@ REGISTER-LISP-IMPLEMENTATION."
;; so that we may have console I/O on the existing stdin and stdout, that we may capture.
(while-collecting (c)
(loop
:with windowsp = (os-windows-p)
:for (smpvar smpname smpfullname) :in `(("" "" "") ("S" :_s " (SMP)")) :do
(loop
:for (bitsvar bitsname bitsfullname) :in '(("" "" "") ("64" "_64" " (64-bit words)"))
......@@ -38,27 +101,30 @@ REGISTER-LISP-IMPLEMENTATION."
:for fullname = (strcat "Allegro CL"
casefullname charfullname bitsfullname smpfullname)
:for executable = (format nil "~(~alisp~a~)" caseexe charname)
:for build = (when windowsp (if (emptyp charfullname) "buildi" "build"))
:for (exepath imgpath) = (if windowsp
(list (subpathname dir (if (emptyp charfullname) "buildi.exe" "build.exe"))
(list (subpathname dir (strcat build ".exe"))
(subpathname dir executable :type "dxl"))
(list (subpathname dir executable) nil)) :do
(c `(,allegro-variant
:fullname ,fullname
:name ,(native-namestring exepath)
:default-image ,(native-namestring imgpath)
:feature :allegro ;; do we want a more discriminating feature expression?
:flags ("-qq")
:eval-flag "-e"
:load-flag "-L"
;; :quit-flags ("-kill")
:arguments-end "--"
:image-flag "-I"
:image-executable-p nil
:standalone-executable nil
:argument-control t
:disable-debugger ("-batch") ; see also -#D -#C -#!
:quit-format "(excl:exit ~A :quiet t)"
:dump-format "(progn (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) (excl:dumplisp :name ~A :suppress-allegro-cl-banner t))"))))))))
(c `(allegro-implementation
,allegro-variant
:fullname ,fullname
:name ,(native-namestring exepath)
:default-image ,(native-namestring imgpath)
:build ,build
:feature :allegro ;; do we want a more discriminating feature expression?
:flags ("-qq")
:eval-flag "-e"
:load-flag "-L"
;; :quit-flags ("-kill")
:arguments-end "--"
:image-flag "-I"
:image-executable-p nil
:standalone-executable nil
:argument-control t
:disable-debugger ("-batch") ; see also -#D -#C -#!
:quit-format "(excl:exit ~A :quiet t)"
:dump-format "(progn (sys:resize-areas :global-gc t :pack-heap t :sift-old-areas t :tenure t) (excl:dumplisp :name ~A :suppress-allegro-cl-banner t))"))))))))
(defun current-lisp-variant ()
......
......@@ -71,9 +71,9 @@ Not supported at all are:
:fullname "CLASP"
:name "clasp"
:feature :clasp
:flags () ;; ("-norc")
:eval-flag "-eval" ; -e ???
:load-flag "-load"
:flags ("--norc" "--noinit")
:eval-flag "--eval"
:load-flag "--load" ;; ???
:image-flag nil
:image-executable-p t
:arguments-end "--"
......
......@@ -13,7 +13,7 @@
(error "ASDF 3.1.2 required"))
(defsystem "lisp-invocation"
:version "1.0.12"
:version "1.0.14"
:author ("Francois-Rene Rideau")
:maintainer "Francois-Rene Rideau"
:licence "MIT"
......
......@@ -5,9 +5,12 @@
(:nicknames :lisp-invocation)
(:use :cl :uiop)
(:export
#:lisp-implementation
#:simple-lisp-implementation
#:define-lisp-implementation
#:get-lisp-implementation
#:ensure-path-executable
#:lisp-implementation-implementation-type
#:lisp-implementation-fullname
#:lisp-implementation-name
#:lisp-implementation-feature
......@@ -25,6 +28,7 @@
#:lisp-implementation-invoker
#:lisp-environment-variable-name
#:lisp-invocation-arglist
#:lisp-implementation-invocation-arglist
#:invoke-lisp #:invoke-lisp-directly #:invoke-lisp-via-script
#:register-lisp-implementation
#:register-lisp-implementation*
......@@ -36,36 +40,43 @@
(defvar *lisp-implementations* (make-hash-table :test 'equal)
"Dictionary of known Lisp implementations")
(defstruct (lisp-implementation)
identifiers ;; the first also names the environment variable for the lisp-path, as per cl-launch
fullname
name
feature
environment-variable
flags
eval-flag
load-flag
arguments-end
image-flag
image-executable-p
default-image
standalone-executable
argument-control
disable-debugger
directory-variable
;; fasl-type cfasl-type
invoker
quit-format
dump-format)
(defmacro define-lisp-implementation (key () &rest keys)
`(apply 'register-lisp-implementation ',key ',keys))
(defun register-lisp-implementation (identifiers &rest keys)
(defclass lisp-implementation ()
(;; the first also names the environment variable for the lisp-path, as per cl-launch
(identifiers :initarg :identifiers :reader lisp-implementation-identifiers)))
(defmethod lisp-implementation-implementation-type ((impl lisp-implementation))
(first (lisp-implementation-identifiers impl)))
(defclass simple-lisp-implementation (lisp-implementation)
((fullname :initarg :fullname :reader lisp-implementation-fullname)
(name :initarg :name :reader lisp-implementation-name)
(feature :initarg :feature :reader lisp-implementation-feature)
(environment-variable :initform nil :initarg :environment-variable :reader lisp-implementation-environment-variable)
(flags :initarg :flags :reader lisp-implementation-flags)
(eval-flag :initarg :eval-flag :reader lisp-implementation-eval-flag)
(load-flag :initarg :load-flag :reader lisp-implementation-load-flag)
(arguments-end :initarg :arguments-end :reader lisp-implementation-arguments-end)
(image-flag :initarg :image-flag :reader lisp-implementation-image-flag)
(image-executable-p :initarg :image-executable-p :reader lisp-implementation-image-executable-p)
(default-image :initform nil :initarg :default-image :reader lisp-implementation-default-image)
(standalone-executable :initarg :standalone-executable :reader lisp-implementation-standalone-executable)
(argument-control :initarg :argument-control :reader lisp-implementation-argument-control)
(disable-debugger :initarg :disable-debugger :reader lisp-implementation-disable-debugger)
(directory-variable :initform nil :initarg :directory-variable :reader lisp-implementation-directory-variable)
;; fasl-type cfasl-type
(invoker :initform nil :initarg :invoker :reader lisp-implementation-invoker)
(quit-format :initarg :quit-format :reader lisp-implementation-quit-format)
(dump-format :initarg :dump-format :reader lisp-implementation-dump-format)))
(defmacro define-lisp-implementation (key (&optional class) &rest keys)
`(apply 'register-lisp-implementation ',class ',key ',keys))
(defun register-lisp-implementation (class identifiers &rest keys)
"Register the lisp implementation identified by the IDENTIFIERS argument (a
keyword or list of keywords), with given option KEYS."
(let* ((identifiers (ensure-list identifiers))
(implementation (apply #'make-lisp-implementation :identifiers identifiers keys)))
(implementation (apply #'make-instance (or class 'simple-lisp-implementation)
:identifiers identifiers keys)))
(dolist (id identifiers)
(assert (keywordp id))
(setf (gethash id *lisp-implementations*) implementation))))
......@@ -75,8 +86,6 @@ keyword or list of keywords), with given option KEYS."
followed by a plist of keywords and arguments."
(apply 'register-lisp-implementation x))
(defun get-lisp-implementation (&optional (implementation-type (implementation-type)))
(or (gethash implementation-type *lisp-implementations*)
(error "Unknown Lisp implementation type ~S" implementation-type)))
......@@ -97,8 +106,14 @@ followed by a plist of keywords and arguments."
(when (eq suffix t) (setf prefix "_OPTIONS"))
(format nil "~@[~A~]~:@(~A~)~@[~A~]" prefix name suffix)))
(defun lisp-invocation-arglist
(&key (implementation-type (implementation-type))
(defun lisp-invocation-arglist (&rest keys &key implementation-type &allow-other-keys)
(apply 'lisp-implementation-invocation-arglist
(get-lisp-implementation implementation-type)
(remove-plist-key :implementation-type keys)))
(defmethod lisp-implementation-invocation-arglist
((implementation simple-lisp-implementation)
&key
lisp-path
(lisp-flags :default)
(image-path nil image-path-p)
......@@ -106,43 +121,48 @@ followed by a plist of keywords and arguments."
eval
arguments
debugger
cross-compile)
(with-slots (name flags disable-debugger load-flag eval-flag
image-flag default-image image-executable-p standalone-executable
arguments-end argument-control)
(get-lisp-implementation implementation-type)
(unless image-path-p (setf image-path default-image))
(append
(when (or (null image-path) (not image-executable-p))
(ensure-list
(or
(when (consp lisp-path) lisp-path)
(ensure-path-executable lisp-path)
(getenvp (lisp-environment-variable-name
:type implementation-type :prefix (when cross-compile "X")))
name)))
(when (and image-path (not image-executable-p))
(list image-flag))
(when image-path
(list
(if image-executable-p
(ensure-path-executable image-path)
image-path)))
(if (eq lisp-flags :default)
flags
lisp-flags)
(unless debugger
disable-debugger)
(mapcan (if load-flag
(lambda (x) (list load-flag (native-namestring x)))
(lambda (x) (list eval-flag (format nil "(load ~S)" (native-namestring x)))))
(ensure-list load))
(when eval
(list eval-flag eval))
(when arguments
(unless argument-control
(error "Can't reliably pass arguments to Lisp implementation ~A" implementation-type))
(cons arguments-end arguments)))))
cross-compile
console)
(declare (ignore console))
(nest
(with-slots (name flags disable-debugger load-flag eval-flag
image-flag default-image image-executable-p standalone-executable
arguments-end argument-control)
implementation)
(let ((implementation-type (lisp-implementation-implementation-type implementation)))
(unless image-path-p (setf image-path default-image)))
(append
(when (or (null image-path) (not image-executable-p))
(ensure-list
(or
(when (consp lisp-path) lisp-path)
(ensure-path-executable lisp-path)
(getenvp (lisp-environment-variable-name
:type implementation-type
:prefix (when cross-compile "X")))
name)))
(when (and image-path (not image-executable-p))
(list image-flag))
(when image-path
(list
(if image-executable-p
(ensure-path-executable image-path)
image-path)))
(if (eq lisp-flags :default)
flags
lisp-flags)
(unless debugger
disable-debugger)
(mapcan (if load-flag
(lambda (x) (list load-flag (native-namestring x)))
(lambda (x) (list eval-flag (format nil "(load ~S)" (native-namestring x)))))
(ensure-list load))
(when eval
(list eval-flag eval))
(when arguments
(unless argument-control
(error "Can't reliably pass arguments to Lisp implementation ~A" implementation-type))
(cons arguments-end arguments)))))
(defun lisp-invoker (&optional (implementation-type (implementation-type)))
(or (lisp-implementation-invoker (get-lisp-implementation implementation-type))
......@@ -154,6 +174,7 @@ followed by a plist of keywords and arguments."
lisp-path
(lisp-flags :default)
image-path
console
load
eval
arguments
......@@ -161,8 +182,8 @@ followed by a plist of keywords and arguments."
cross-compile
(run-program 'run-program)
run-program-args)
(declare (ignore lisp-path lisp-flags image-path load eval arguments debugger cross-compile
run-program run-program-args))
(declare (ignore lisp-path lisp-flags image-path console load eval arguments debugger
cross-compile run-program run-program-args))
(apply (lisp-invoker implementation-type)
keys))
......@@ -172,6 +193,7 @@ followed by a plist of keywords and arguments."
lisp-path
(lisp-flags :default)
image-path
console
load
eval
arguments
......@@ -180,7 +202,7 @@ followed by a plist of keywords and arguments."
(run-program 'run-program)
run-program-args)
(declare (ignore implementation-type lisp-path lisp-flags image-path
load eval arguments debugger cross-compile))
console load eval arguments debugger cross-compile))
(apply run-program
(apply 'lisp-invocation-arglist (remove-plist-keys '(:run-program :run-program-args) keys))
run-program-args))
......@@ -191,6 +213,7 @@ followed by a plist of keywords and arguments."
lisp-path
lisp-flags
image-path
console
load
eval
arguments
......@@ -199,7 +222,7 @@ followed by a plist of keywords and arguments."
(run-program 'run-program)
run-program-args)
(declare (ignore implementation-type lisp-path lisp-flags image-path debugger cross-compile
run-program run-program-args))
console run-program run-program-args))
(with-temporary-file (:stream s :pathname p :type "lisp")
(when arguments
(format s "(unless (find-package :uiop/image) (defpackage :uiop/image (:use :cl)))~%~
......