From ebf543ca17422dfbb51609f5b6d35a98c5f07449 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <fare@tunes.org> Date: Sun, 5 Feb 2017 22:21:57 -0500 Subject: [PATCH] 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. --- allegro-variants.lisp | 108 +++++++++++++++++++++------ lisp-invocation.asd | 2 +- lisp-invocation.lisp | 167 ++++++++++++++++++++++++------------------ 3 files changed, 183 insertions(+), 94 deletions(-) diff --git a/allegro-variants.lisp b/allegro-variants.lisp index 3a8d9a7..998b25d 100644 --- a/allegro-variants.lisp +++ b/allegro-variants.lisp @@ -1,5 +1,9 @@ -(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 () diff --git a/lisp-invocation.asd b/lisp-invocation.asd index 1599047..75a3932 100644 --- a/lisp-invocation.asd +++ b/lisp-invocation.asd @@ -13,7 +13,7 @@ (error "ASDF 3.1.2 required")) (defsystem "lisp-invocation" - :version "1.0.13" + :version "1.0.14" :author ("Francois-Rene Rideau") :maintainer "Francois-Rene Rideau" :licence "MIT" diff --git a/lisp-invocation.lisp b/lisp-invocation.lisp index dc21b99..f311b33 100644 --- a/lisp-invocation.lisp +++ b/lisp-invocation.lisp @@ -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)))~%~ -- GitLab