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