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,14 +101,17 @@ REGISTER-LISP-IMPLEMENTATION." ...@@ -38,14 +101,17 @@ 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
,allegro-variant
:fullname ,fullname :fullname ,fullname
:name ,(native-namestring exepath) :name ,(native-namestring exepath)
:default-image ,(native-namestring imgpath) :default-image ,(native-namestring imgpath)
:build ,build
:feature :allegro ;; do we want a more discriminating feature expression? :feature :allegro ;; do we want a more discriminating feature expression?
:flags ("-qq") :flags ("-qq")
:eval-flag "-e" :eval-flag "-e"
......
...@@ -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)
(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 ;; fasl-type cfasl-type
invoker (invoker :initform nil :initarg :invoker :reader lisp-implementation-invoker)
quit-format (quit-format :initarg :quit-format :reader lisp-implementation-quit-format)
dump-format) (dump-format :initarg :dump-format :reader lisp-implementation-dump-format)))
(defmacro define-lisp-implementation (key () &rest keys) (defmacro define-lisp-implementation (key (&optional class) &rest keys)
`(apply 'register-lisp-implementation ',key ',keys)) `(apply 'register-lisp-implementation ',class ',key ',keys))
(defun register-lisp-implementation (identifiers &rest 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,12 +121,16 @@ followed by a plist of keywords and arguments." ...@@ -106,12 +121,16 @@ followed by a plist of keywords and arguments."
eval eval
arguments arguments
debugger debugger
cross-compile) cross-compile
console)
(declare (ignore console))
(nest
(with-slots (name flags disable-debugger load-flag eval-flag (with-slots (name flags disable-debugger load-flag eval-flag
image-flag default-image image-executable-p standalone-executable image-flag default-image image-executable-p standalone-executable
arguments-end argument-control) arguments-end argument-control)
(get-lisp-implementation implementation-type) implementation)
(unless image-path-p (setf image-path default-image)) (let ((implementation-type (lisp-implementation-implementation-type implementation)))
(unless image-path-p (setf image-path default-image)))
(append (append
(when (or (null image-path) (not image-executable-p)) (when (or (null image-path) (not image-executable-p))
(ensure-list (ensure-list
...@@ -119,7 +138,8 @@ followed by a plist of keywords and arguments." ...@@ -119,7 +138,8 @@ followed by a plist of keywords and arguments."
(when (consp lisp-path) lisp-path) (when (consp lisp-path) lisp-path)
(ensure-path-executable lisp-path) (ensure-path-executable lisp-path)
(getenvp (lisp-environment-variable-name (getenvp (lisp-environment-variable-name
:type implementation-type :prefix (when cross-compile "X"))) :type implementation-type
:prefix (when cross-compile "X")))
name))) name)))
(when (and image-path (not image-executable-p)) (when (and image-path (not image-executable-p))
(list image-flag)) (list image-flag))
...@@ -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