Commit ebf543ca authored by Francois-Rene Rideau's avatar Francois-Rene Rideau

1.0.14: Add :console argument, be nicer to allegro

Do the right thing when an ALLEGRO variable is defined,
and we're running under Windows, and we want a console.
parent 5134c735
(defpackage :lisp-invocation/allegro-variants (uiop:define-package :lisp-invocation/allegro-variants
(:use :common-lisp :fare-utils :uiop :lisp-invocation/lisp-invocation) (: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)) (:export #:all-allegro-variants #:current-lisp-variant))
(in-package :lisp-invocation/allegro-variants) (in-package :lisp-invocation/allegro-variants)
...@@ -16,7 +20,67 @@ locations, you may simply specify the Allegro install directories using these va ...@@ -16,7 +20,67 @@ locations, you may simply specify the Allegro install directories using these va
ALLEGRODIR, and ALLEGROSDIR. 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 "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 and environment variables. The returned list is made up of argument lists for
REGISTER-LISP-IMPLEMENTATION." REGISTER-LISP-IMPLEMENTATION."
...@@ -24,7 +88,6 @@ 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. ;; so that we may have console I/O on the existing stdin and stdout, that we may capture.
(while-collecting (c) (while-collecting (c)
(loop (loop
:with windowsp = (os-windows-p)
:for (smpvar smpname smpfullname) :in `(("" "" "") ("S" :_s " (SMP)")) :do :for (smpvar smpname smpfullname) :in `(("" "" "") ("S" :_s " (SMP)")) :do
(loop (loop
:for (bitsvar bitsname bitsfullname) :in '(("" "" "") ("64" "_64" " (64-bit words)")) :for (bitsvar bitsname bitsfullname) :in '(("" "" "") ("64" "_64" " (64-bit words)"))
...@@ -38,27 +101,30 @@ REGISTER-LISP-IMPLEMENTATION." ...@@ -38,27 +101,30 @@ REGISTER-LISP-IMPLEMENTATION."
:for fullname = (strcat "Allegro CL" :for fullname = (strcat "Allegro CL"
casefullname charfullname bitsfullname smpfullname) casefullname charfullname bitsfullname smpfullname)
:for executable = (format nil "~(~alisp~a~)" caseexe charname) :for executable = (format nil "~(~alisp~a~)" caseexe charname)
:for build = (when windowsp (if (emptyp charfullname) "buildi" "build"))
:for (exepath imgpath) = (if windowsp :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")) (subpathname dir executable :type "dxl"))
(list (subpathname dir executable) nil)) :do (list (subpathname dir executable) nil)) :do
(c `(,allegro-variant (c `(allegro-implementation
:fullname ,fullname ,allegro-variant
:name ,(native-namestring exepath) :fullname ,fullname
:default-image ,(native-namestring imgpath) :name ,(native-namestring exepath)
:feature :allegro ;; do we want a more discriminating feature expression? :default-image ,(native-namestring imgpath)
:flags ("-qq") :build ,build
:eval-flag "-e" :feature :allegro ;; do we want a more discriminating feature expression?
:load-flag "-L" :flags ("-qq")
;; :quit-flags ("-kill") :eval-flag "-e"
:arguments-end "--" :load-flag "-L"
:image-flag "-I" ;; :quit-flags ("-kill")
:image-executable-p nil :arguments-end "--"
:standalone-executable nil :image-flag "-I"
:argument-control t :image-executable-p nil
:disable-debugger ("-batch") ; see also -#D -#C -#! :standalone-executable nil
:quit-format "(excl:exit ~A :quiet t)" :argument-control 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))")))))))) :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 () (defun current-lisp-variant ()
......
...@@ -13,7 +13,7 @@ ...@@ -13,7 +13,7 @@
(error "ASDF 3.1.2 required")) (error "ASDF 3.1.2 required"))
(defsystem "lisp-invocation" (defsystem "lisp-invocation"
:version "1.0.13" :version "1.0.14"
:author ("Francois-Rene Rideau") :author ("Francois-Rene Rideau")
:maintainer "Francois-Rene Rideau" :maintainer "Francois-Rene Rideau"
:licence "MIT" :licence "MIT"
......
...@@ -5,9 +5,12 @@ ...@@ -5,9 +5,12 @@
(:nicknames :lisp-invocation) (:nicknames :lisp-invocation)
(:use :cl :uiop) (:use :cl :uiop)
(:export (:export
#:lisp-implementation
#:simple-lisp-implementation
#:define-lisp-implementation #:define-lisp-implementation
#:get-lisp-implementation #:get-lisp-implementation
#:ensure-path-executable #:ensure-path-executable
#:lisp-implementation-implementation-type
#:lisp-implementation-fullname #:lisp-implementation-fullname
#:lisp-implementation-name #:lisp-implementation-name
#:lisp-implementation-feature #:lisp-implementation-feature
...@@ -25,6 +28,7 @@ ...@@ -25,6 +28,7 @@
#:lisp-implementation-invoker #:lisp-implementation-invoker
#:lisp-environment-variable-name #:lisp-environment-variable-name
#:lisp-invocation-arglist #:lisp-invocation-arglist
#:lisp-implementation-invocation-arglist
#:invoke-lisp #:invoke-lisp-directly #:invoke-lisp-via-script #:invoke-lisp #:invoke-lisp-directly #:invoke-lisp-via-script
#:register-lisp-implementation #:register-lisp-implementation
#:register-lisp-implementation* #:register-lisp-implementation*
...@@ -36,36 +40,43 @@ ...@@ -36,36 +40,43 @@
(defvar *lisp-implementations* (make-hash-table :test 'equal) (defvar *lisp-implementations* (make-hash-table :test 'equal)
"Dictionary of known Lisp implementations") "Dictionary of known Lisp implementations")
(defstruct (lisp-implementation) (defclass lisp-implementation ()
identifiers ;; the first also names the environment variable for the lisp-path, as per cl-launch (;; the first also names the environment variable for the lisp-path, as per cl-launch
fullname (identifiers :initarg :identifiers :reader lisp-implementation-identifiers)))
name
feature (defmethod lisp-implementation-implementation-type ((impl lisp-implementation))
environment-variable (first (lisp-implementation-identifiers impl)))
flags
eval-flag (defclass simple-lisp-implementation (lisp-implementation)
load-flag ((fullname :initarg :fullname :reader lisp-implementation-fullname)
arguments-end (name :initarg :name :reader lisp-implementation-name)
image-flag (feature :initarg :feature :reader lisp-implementation-feature)
image-executable-p (environment-variable :initform nil :initarg :environment-variable :reader lisp-implementation-environment-variable)
default-image (flags :initarg :flags :reader lisp-implementation-flags)
standalone-executable (eval-flag :initarg :eval-flag :reader lisp-implementation-eval-flag)
argument-control (load-flag :initarg :load-flag :reader lisp-implementation-load-flag)
disable-debugger (arguments-end :initarg :arguments-end :reader lisp-implementation-arguments-end)
directory-variable (image-flag :initarg :image-flag :reader lisp-implementation-image-flag)
;; fasl-type cfasl-type (image-executable-p :initarg :image-executable-p :reader lisp-implementation-image-executable-p)
invoker (default-image :initform nil :initarg :default-image :reader lisp-implementation-default-image)
quit-format (standalone-executable :initarg :standalone-executable :reader lisp-implementation-standalone-executable)
dump-format) (argument-control :initarg :argument-control :reader lisp-implementation-argument-control)
(disable-debugger :initarg :disable-debugger :reader lisp-implementation-disable-debugger)
(defmacro define-lisp-implementation (key () &rest keys) (directory-variable :initform nil :initarg :directory-variable :reader lisp-implementation-directory-variable)
`(apply 'register-lisp-implementation ',key ',keys)) ;; fasl-type cfasl-type
(invoker :initform nil :initarg :invoker :reader lisp-implementation-invoker)
(defun register-lisp-implementation (identifiers &rest keys) (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 "Register the lisp implementation identified by the IDENTIFIERS argument (a
keyword or list of keywords), with given option KEYS." keyword or list of keywords), with given option KEYS."
(let* ((identifiers (ensure-list identifiers)) (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) (dolist (id identifiers)
(assert (keywordp id)) (assert (keywordp id))
(setf (gethash id *lisp-implementations*) implementation)))) (setf (gethash id *lisp-implementations*) implementation))))
...@@ -75,8 +86,6 @@ keyword or list of keywords), with given option KEYS." ...@@ -75,8 +86,6 @@ keyword or list of keywords), with given option KEYS."
followed by a plist of keywords and arguments." followed by a plist of keywords and arguments."
(apply 'register-lisp-implementation x)) (apply 'register-lisp-implementation x))
(defun get-lisp-implementation (&optional (implementation-type (implementation-type))) (defun get-lisp-implementation (&optional (implementation-type (implementation-type)))
(or (gethash implementation-type *lisp-implementations*) (or (gethash implementation-type *lisp-implementations*)
(error "Unknown Lisp implementation type ~S" implementation-type))) (error "Unknown Lisp implementation type ~S" implementation-type)))
...@@ -97,8 +106,14 @@ followed by a plist of keywords and arguments." ...@@ -97,8 +106,14 @@ followed by a plist of keywords and arguments."
(when (eq suffix t) (setf prefix "_OPTIONS")) (when (eq suffix t) (setf prefix "_OPTIONS"))
(format nil "~@[~A~]~:@(~A~)~@[~A~]" prefix name suffix))) (format nil "~@[~A~]~:@(~A~)~@[~A~]" prefix name suffix)))
(defun lisp-invocation-arglist (defun lisp-invocation-arglist (&rest keys &key implementation-type &allow-other-keys)
(&key (implementation-type (implementation-type)) (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-path
(lisp-flags :default) (lisp-flags :default)
(image-path nil image-path-p) (image-path nil image-path-p)
...@@ -106,43 +121,48 @@ followed by a plist of keywords and arguments." ...@@ -106,43 +121,48 @@ followed by a plist of keywords and arguments."
eval eval
arguments arguments
debugger debugger
cross-compile) cross-compile
(with-slots (name flags disable-debugger load-flag eval-flag console)
image-flag default-image image-executable-p standalone-executable (declare (ignore console))
arguments-end argument-control) (nest
(get-lisp-implementation implementation-type) (with-slots (name flags disable-debugger load-flag eval-flag
(unless image-path-p (setf image-path default-image)) image-flag default-image image-executable-p standalone-executable
(append arguments-end argument-control)
(when (or (null image-path) (not image-executable-p)) implementation)
(ensure-list (let ((implementation-type (lisp-implementation-implementation-type implementation)))
(or (unless image-path-p (setf image-path default-image)))
(when (consp lisp-path) lisp-path) (append
(ensure-path-executable lisp-path) (when (or (null image-path) (not image-executable-p))
(getenvp (lisp-environment-variable-name (ensure-list
:type implementation-type :prefix (when cross-compile "X"))) (or
name))) (when (consp lisp-path) lisp-path)
(when (and image-path (not image-executable-p)) (ensure-path-executable lisp-path)
(list image-flag)) (getenvp (lisp-environment-variable-name
(when image-path :type implementation-type
(list :prefix (when cross-compile "X")))
(if image-executable-p name)))
(ensure-path-executable image-path) (when (and image-path (not image-executable-p))
image-path))) (list image-flag))
(if (eq lisp-flags :default) (when image-path
flags (list
lisp-flags) (if image-executable-p
(unless debugger (ensure-path-executable image-path)
disable-debugger) image-path)))
(mapcan (if load-flag (if (eq lisp-flags :default)
(lambda (x) (list load-flag (native-namestring x))) flags
(lambda (x) (list eval-flag (format nil "(load ~S)" (native-namestring x))))) lisp-flags)
(ensure-list load)) (unless debugger
(when eval disable-debugger)
(list eval-flag eval)) (mapcan (if load-flag
(when arguments (lambda (x) (list load-flag (native-namestring x)))
(unless argument-control (lambda (x) (list eval-flag (format nil "(load ~S)" (native-namestring x)))))
(error "Can't reliably pass arguments to Lisp implementation ~A" implementation-type)) (ensure-list load))
(cons arguments-end arguments))))) (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))) (defun lisp-invoker (&optional (implementation-type (implementation-type)))
(or (lisp-implementation-invoker (get-lisp-implementation implementation-type)) (or (lisp-implementation-invoker (get-lisp-implementation implementation-type))
...@@ -154,6 +174,7 @@ followed by a plist of keywords and arguments." ...@@ -154,6 +174,7 @@ followed by a plist of keywords and arguments."
lisp-path lisp-path
(lisp-flags :default) (lisp-flags :default)
image-path image-path
console
load load
eval eval
arguments arguments
...@@ -161,8 +182,8 @@ followed by a plist of keywords and arguments." ...@@ -161,8 +182,8 @@ followed by a plist of keywords and arguments."
cross-compile cross-compile
(run-program 'run-program) (run-program 'run-program)
run-program-args) run-program-args)
(declare (ignore lisp-path lisp-flags image-path load eval arguments debugger cross-compile (declare (ignore lisp-path lisp-flags image-path console load eval arguments debugger
run-program run-program-args)) cross-compile run-program run-program-args))
(apply (lisp-invoker implementation-type) (apply (lisp-invoker implementation-type)
keys)) keys))
...@@ -172,6 +193,7 @@ followed by a plist of keywords and arguments." ...@@ -172,6 +193,7 @@ followed by a plist of keywords and arguments."
lisp-path lisp-path
(lisp-flags :default) (lisp-flags :default)
image-path image-path
console
load load
eval eval
arguments arguments
...@@ -180,7 +202,7 @@ followed by a plist of keywords and arguments." ...@@ -180,7 +202,7 @@ followed by a plist of keywords and arguments."
(run-program 'run-program) (run-program 'run-program)
run-program-args) run-program-args)
(declare (ignore implementation-type lisp-path lisp-flags image-path (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 run-program
(apply 'lisp-invocation-arglist (remove-plist-keys '(:run-program :run-program-args) keys)) (apply 'lisp-invocation-arglist (remove-plist-keys '(:run-program :run-program-args) keys))
run-program-args)) run-program-args))
...@@ -191,6 +213,7 @@ followed by a plist of keywords and arguments." ...@@ -191,6 +213,7 @@ followed by a plist of keywords and arguments."
lisp-path lisp-path
lisp-flags lisp-flags
image-path image-path
console
load load
eval eval
arguments arguments
...@@ -199,7 +222,7 @@ followed by a plist of keywords and arguments." ...@@ -199,7 +222,7 @@ followed by a plist of keywords and arguments."
(run-program 'run-program) (run-program 'run-program)
run-program-args) run-program-args)
(declare (ignore implementation-type lisp-path lisp-flags image-path debugger cross-compile (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") (with-temporary-file (:stream s :pathname p :type "lisp")
(when arguments (when arguments
(format s "(unless (find-package :uiop/image) (defpackage :uiop/image (:use :cl)))~%~ (format s "(unless (find-package :uiop/image) (defpackage :uiop/image (:use :cl)))~%~
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment