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,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 ()
......
......@@ -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"
......
This diff is collapsed.
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