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)
(: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,14 +101,17 @@ 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
(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"
......
......@@ -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"
......
......@@ -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
(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
quit-format
dump-format)
(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 () &rest keys)
`(apply 'register-lisp-implementation ',key ',keys))
(defmacro define-lisp-implementation (key (&optional class) &rest 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
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,12 +121,16 @@ followed by a plist of keywords and arguments."
eval
arguments
debugger
cross-compile)
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)
(get-lisp-implementation implementation-type)
(unless image-path-p (setf image-path default-image))
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
......@@ -119,7 +138,8 @@ followed by a plist of keywords and arguments."
(when (consp lisp-path) lisp-path)
(ensure-path-executable lisp-path)
(getenvp (lisp-environment-variable-name
:type implementation-type :prefix (when cross-compile "X")))
:type implementation-type
:prefix (when cross-compile "X")))
name)))
(when (and image-path (not image-executable-p))
(list image-flag))
......@@ -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)))~%~
......
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