Skip to content
Snippets Groups Projects
Commit 2e30cabb authored by Francois-Rene Rideau's avatar Francois-Rene Rideau
Browse files

1.0.5: import functionality from asdf-tools

Also, require ASDF 3.1.2 and use package-inferred-system.
Move implementations database to a separate file
Import from asdf-tools (in asdf branch minimakefile) support for
Allegro variants and for composing strings of non-special characters.
parent 66185bc5
No related branches found
No related tags found
No related merge requests found
(defpackage :lisp-invocation/allegro-variants
(:use :common-lisp :fare-utils :uiop :lisp-invocation/lisp-invocation))
(in-package :lisp-invocation/allegro-variants)
#|
Allegro is supported in the following flavors:
allegro, allegro8, allegromodern, allegromodern8,
allegro_s, allegro8_s, allegromodern_s, allegromodern8_s (SMP variants)
allegro_64, allegro8_64, allegromodern_64, allegromodern8_64 (64-bit variants),
allegro_64_s, allegro8_64_s, allegromodern_64_s, allegromodern8_64_s, (SMP, 64-bit variants)
Allegro CL is a special case: instead of setting environment variables for the specific runtime
locations, you may simply specify the Allegro install directories using these variables:
ALLEGRO64DIR, ALLEGRO64SDIR (64-bit Allegro and SMP Allegro, respectively),
ALLEGRODIR, and ALLEGROSDIR.
|#
(defun all-allegro-variants ()
"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."
(while-collecting (c)
(loop :for (smpvar smpname smpfullname) :in `(("" "" "") ("S" :_s " (SMP)")) :do
(loop
:for (bitsvar bitsname bitsfullname) :in '(("" "" "") ("64" "_64" " (64-bit words)"))
:for dirvar = (format nil "~:@(ALLEGRO~A~A~)" bitsvar smpvar)
:for dir = (getenv-pathname dirvar :want-absolute t :ensure-directory t) :do
(loop :for (charname charfullname) :in '(("" "") ("8" " (8-bit chars)")) :do
(loop
:for (caseexe casename casefullname) :in
'(("a" "" "") ("m" :modern " (modern syntax)"))
:for allegro-variant = (conc-keyword :allegro casename charname bitsname smpname)
:for fullname = (strcat "Allegro CL"
casefullname charfullname bitsfullname smpfullname)
:for executable = (format nil "~(~alisp~a~)" caseexe charname) :do
(c `(,allegro-variant
:fullname ,fullname
:name ,(native-namestring (subpathname dir executable))
: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 -#!
,@(when (and (os-windows-p)
(not (getenvp "ALLEGRO_NOISY")))
'("+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))"))))))))
(map () 'register-lisp-implementation* (all-allegro-variants))
(defpackage :lisp-invocation/implementations
(:use :common-lisp :uiop :lisp-invocation/lisp-invocation))
(in-package :lisp-invocation/implementations)
#|
Supported test lisp implementations include:
allegro (acl), abcl, ccl (clozure), clasp, clisp, cmucl (cmu),
ecl, ecl_bytecodes, gcl, lispworks, mkcl, sbcl, scl, xcl.
Not really supported are:
corman (cormanlisp), lispworks-personal-edition
Not supported at all are:
mcl (rmcl), genera
|#
(define-lisp-implementation :abcl ()
:fullname "Armed Bear Common Lisp"
:name "abcl"
:feature :abcl
:flags ("--noinform" "--noinit" "--nosystem")
:eval-flag "--eval"
:load-flag "--load"
:arguments-end "--"
:image-flag nil
:image-executable-p t
:standalone-executable nil
:argument-control t
:disable-debugger ("--batch") ;; ???
:quit-format "(ext:quit :status ~A)"
:dump-format nil)
(define-lisp-implementation (:allegro :acl) ()
:fullname "Allegro CL"
:name "alisp"
:feature :allegro
:flags ("-qq") ; -q only ? on windows, +c ? On Allegro 5 and earlier, -Q and/or -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))")
(define-lisp-implementation (:ccl :clozure) () ;; demand 1.4 or later.
:fullname "Clozure Common Lisp"
;; formerly OpenMCL, forked from MCL, formerly Macintosh Common Lisp, nee Coral Common Lisp
;; Random note: (finish-output) is essential for ccl, that won't do it by default,
;; unlike the other lisp implementations tested.
:name "ccl"
:feature :clozure
:flags ("--no-init" "--quiet")
:eval-flag "--eval" ; -e
:load-flag "--load"
:image-flag "--image-name" ; -I
:image-executable-p t
:standalone-executable t
:arguments-end "--"
:argument-control t ;; must be fixed now, but double-checking needed.
:disable-debugger ("--batch")
:directory-variable "CCL_DEFAULT_DIRECTORY"
:quit-format "(let ((x ~A)) (finish-output *standard-output*) (finish-output *error-output*) (ccl:quit x))"
:dump-format "(save-application ~S :prepend-kernel t)")
(define-lisp-implementation :clasp ()
:fullname "CLASP"
:name "clasp"
:feature :clasp
:flags () ;; ("-norc")
:eval-flag "-eval" ; -e ???
:load-flag "-load"
:image-flag nil
:image-executable-p t
:arguments-end "--"
:argument-control t ;; must be fixed now, but double-checking needed.
:disable-debugger ()
:quit-format "(si:quit ~A)"
:dump-format nil) ;; Cannot dump with CLASP. Link instead.
(define-lisp-implementation :clisp ()
:fullname "GNU CLISP"
:name "clisp"
:feature :clisp
:flags ("-norc" "--quiet" "--quiet" "-ansi") ;; don't use -I, for it induces extra prompt outputs.
:eval-flag "-x"
:load-flag "-i"
:arguments-end "--"
:image-executable-p t
:image-flag "-M"
:standalone-executable t ;; requires clisp 2.48 or later
:argument-control t ;; *BUT* even a standalone-executable always accepts --clisp-x and such.
:disable-debugger ("-on-error" "exit") ;; otherwise, -on-error debug
:quit-format "(ext:quit ~A)"
:dump-format "(ext:saveinitmem ~S :quiet t :executable t)")
(define-lisp-implementation (:cmucl :cmu) ()
:fullname "CMU CL"
:name "cmucl"
:feature :cmu
:flags ("-quiet" "-noinit")
:eval-flag "-eval"
:load-flag "-load"
:arguments-end "--"
:image-executable-p t
:image-flag "-core"
:argument-control t
:disable-debugger ("-batch")
:quit-format "(unix:unix-exit ~A)"
:dump-format "(extensions:save-lisp ~S :executable t)")
(define-lisp-implementation (:corman :cormanlisp) () ;; someone please add more complete support
:fullname "Corman Lisp"
:name () ;; There's a clconsole.exe, but what are the options?
:feature :cormanlisp
:quit-format "(win:exitprocess ~A)")
(define-lisp-implementation :ecl () ;; demand 10.4.2 or later.
:fullname "Embeddable Common-Lisp"
:name "ecl"
:feature :ecl
:flags ("-norc")
:eval-flag "-eval" ; -e
:load-flag "-load"
:image-flag nil
:image-executable-p t
:arguments-end "--"
:argument-control t ;; must be fixed now, but double-checking needed.
:disable-debugger ()
:quit-format "(si:quit ~A)"
:dump-format nil) ;; Cannot dump with ECL. Link instead.
(define-lisp-implementation :ecl_bytecodes () ;; ECL using its bytecode compiler.
:fullname "Embeddable Common-Lisp (using bytecodes compiler)"
:flags ("-norc" "-eval" "(ext::install-bytecodes-compiler)")
:name "ecl"
:feature (:and :ecl :ecl-bytecmp)
:environment-variable "ECL"
:eval-flag "-eval" ; -e
:load-flag "-load"
:image-flag nil
:image-executable-p t
:arguments-end "--"
:argument-control t ;; must be fixed now, but double-checking needed.
:disable-debugger ()
:quit-format "(si:quit ~A)"
:dump-format nil) ;; Cannot dump with ECL. Link instead.
(define-lisp-implementation :gcl () ;; Demand 2.8.0, if it is ever released. In ANSI mode.
:fullname "GNU Common Lisp"
:name "gcl" ;; On debian, we might have to export GCL_ANSI=t to ensure the ANSI variant is used.
:feature :gcl
:flags ()
:eval-flag "-eval" ; -e
:load-flag "-load"
:image-flag nil
:image-executable-p t
:arguments-end "--" ;; -f ?
:disable-debugger ("-batch")
:quit-format "(lisp:quit ~A)"
:dump-format "(progn (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) (si::save-system ~A))")
(define-lisp-implementation (:lispworks :lw) ()
:fullname "LispWorks"
:name "lispworks-console" ;; This assumes you dumped a proper image for batch processing...
;; If you have a licensed copy of lispworks,
;; you can obtain the "lispworks" binary with, e.g.
;; echo '(hcl:save-image "lispworks-console" :environment nil)' > /tmp/build.lisp ;
;; ./lispworks-6-0-0-x86-linux -siteinit - -init - -build /tmp/build.lisp
;; Note that you also need to copy the license file to
;; .../lispworks/lib/6-1-0-0/config/lwlicense
;; and/or the same directory as your binary,
;; for it to work on dumped binaries in all locations, with, e.g.
;; (system::copy-file ".../lwlicense" (make-pathname :name "lwlicense" :type nil :defaults filename))
:feature :lispworks
:flags ("-site-init" "-" "-init" "-")
:eval-flag "-eval"
:load-flag "-build" ;; Is -load what we want? See also -build as magic load.
:arguments-end nil ; What's the deal with THIS? "--"
:image-flag nil
:image-executable-p t
:standalone-executable t
:argument-control t
:disable-debugger ()
:invoker invoke-lisp-via-script
:quit-format "(lispworks:quit :status ~A :confirm nil :return nil :ignore-errors-p t)"
:dump-format "(lispworks:deliver 'xcvb-driver:resume ~A 0 :interface nil)") ; "(hcl:save-image ~A :environment nil)"
(define-lisp-implementation :lispworks-personal ()
:fullname "LispWorks Personal Edition"
:name () ;; In LispWorks Personal, the slave worker executes you!
:feature :lispworks-personal-edition)
(define-lisp-implementation :mkcl ()
:fullname "ManKai Common-Lisp"
:name "mkcl"
:feature :mkcl
:flags ("-norc")
:eval-flag "-eval" ; -e
:load-flag "-load"
:image-flag nil
:image-executable-p t
:arguments-end "--"
:argument-control t ;; must be fixed now, but double-checking needed.
:disable-debugger ()
:quit-format "(mk-ext:quit :exit-code ~A)"
:dump-format nil) ;; Cannot dump with ECL. Link instead.
(define-lisp-implementation :sbcl ()
:fullname "Steel Bank Common Lisp"
:name "sbcl"
:feature :sbcl
:flags ("--noinform" "--no-userinit" "--no-sysinit") ;; minimize non-determinism form user's env
:eval-flag "--eval" ;; Note: SBCL's eval can only handle one form per argument.
:load-flag "--load"
:arguments-end "--end-toplevel-options"
:image-flag "--core"
:image-executable-p t
:standalone-executable t ;; requires sbcl 1.0.21.24 or later.
:argument-control t
:disable-debugger ("--disable-debugger")
:directory-variable "SBCL_HOME"
:quit-format "(let ((exit (find-symbol \"EXIT\" :sb-ext)) (quit (find-symbol \"QUIT\" :sb-ext)) (code ~A)) (cond (exit (funcall exit :code code)) (quit (funcall quit :unix-status code))))"
:dump-format "(sb-ext:save-lisp-and-die ~S :executable t)")
(define-lisp-implementation :scl ()
:fullname "Scieneer Common Lisp" ; use 1.3.9 or later
:name "scl"
:feature :scl
:flags ("-quiet" "-noinit")
:eval-flag "-eval"
:load-flag "-load"
:arguments-end "--"
:image-flag "-core"
:argument-control nil ;; cmucl will always scan all the arguments for -eval... EVIL!
:disable-debugger ("-batch")
:quit-format "(unix:unix-exit ~A)"
:dump-format "(extensions:save-lisp ~S)")
(define-lisp-implementation :xcl ()
:fullname "XCL"
:name "xcl"
:feature :xcl
:flags ("--no-userinit" "--no-siteinit" "--noinform")
:eval-flag "--eval"
:load-flag "--load"
:arguments-end "--"
:image-flag nil
:image-executable-p nil
:standalone-executable nil
:disable-debugger ()
:quit-format "(ext:quit :status ~A)"
:dump-format nil)
...@@ -9,7 +9,11 @@ ...@@ -9,7 +9,11 @@
;;; ;;; ;;; ;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defsystem :lisp-invocation (unless (or #+asdf3.1 (version<= "3.1.2" (asdf-version)))
(error "ASDF 3.1.2 required"))
(defsystem "lisp-invocation"
:version "1.0.5"
:author ("Francois-Rene Rideau") :author ("Francois-Rene Rideau")
:maintainer "Francois-Rene Rideau" :maintainer "Francois-Rene Rideau"
:licence "MIT" :licence "MIT"
...@@ -17,6 +21,11 @@ ...@@ -17,6 +21,11 @@
:long-description "lisp-invocation allows you to portably execute Lisp code :long-description "lisp-invocation allows you to portably execute Lisp code
as subprocesses of a current Lisp process. as subprocesses of a current Lisp process.
All known command-line accessible Common Lisp implementations are supported." All known command-line accessible Common Lisp implementations are supported."
:version "1.0.4" :class package-inferred-system
:depends-on (#-asdf3.1 (:version "uiop" "3.1.2")) :depends-on ("lisp-invocation/lisp-invocation" "lisp-invocation/implementations"))
:components ((:file "lisp-invocation")))
(defsystem "lisp-invocation/all"
:version (:read-file-form "lisp-invocation.asd" :at (1 3))
:depends-on ("lisp-invocation"
"lisp-invocation/non-special"
"lisp-invocation/allegro-variants"))
;;; Lisp implementations ;;; Lisp implementations
#+xcvb (module (:build-depends-on ("/asdf"))) #+xcvb (module (:build-depends-on ("/asdf")))
(defpackage :lisp-invocation (uiop:define-package :lisp-invocation/lisp-invocation
(:nicknames :lisp-invocation)
(:use :cl :uiop) (:use :cl :uiop)
(:export (:export
#:define-lisp-implementation #:define-lisp-implementation
...@@ -26,6 +27,7 @@ ...@@ -26,6 +27,7 @@
#:lisp-invocation-arglist #:lisp-invocation-arglist
#:invoke-lisp #:invoke-lisp
#:register-lisp-implementation #:register-lisp-implementation
#:register-lisp-implementation*
#:quit-form #:quit-form
#:save-image-form)) #:save-image-form))
...@@ -58,241 +60,25 @@ ...@@ -58,241 +60,25 @@
(defmacro define-lisp-implementation (key () &rest keys) (defmacro define-lisp-implementation (key () &rest keys)
`(apply 'register-lisp-implementation ',key ',keys)) `(apply 'register-lisp-implementation ',key ',keys))
(defun register-lisp-implementation (key &rest keys) (defun register-lisp-implementation (identifiers &rest keys)
(let* ((identifiers (ensure-list key)) "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-lisp-implementation :identifiers identifiers keys)))
(dolist (id identifiers) (dolist (id identifiers)
(assert (keywordp id))
(setf (gethash id *lisp-implementations*) implementation)))) (setf (gethash id *lisp-implementations*) implementation))))
(defun get-lisp-implementation (&optional (implementation-type (implementation-type))) (defun register-lisp-implementation* (x)
(or (gethash implementation-type *lisp-implementations*) "Register the lisp implementation described by the list X, which consists of a name
(error "Unknown Lisp implementation type ~S" implementation-type))) followed by a plist of keywords and arguments."
(apply 'register-lisp-implementation x))
(define-lisp-implementation :abcl ()
:fullname "Armed Bear Common Lisp"
:name "abcl"
:feature :abcl
:flags ("--noinform" "--noinit" "--nosystem")
:eval-flag "--eval"
:load-flag "--load"
:arguments-end "--"
:image-flag nil
:image-executable-p t
:standalone-executable nil
:argument-control t
:disable-debugger ("--batch") ;; ???
:quit-format "(ext:quit :status ~A)"
:dump-format nil)
(define-lisp-implementation (:allegro :acl) ()
:fullname "Allegro CL"
:name "alisp"
:feature :allegro
:flags ("-qq") ; -q only ? on windows, +c ? On Allegro 5 and earlier, -Q and/or -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))")
(define-lisp-implementation (:ccl :clozure) () ;; demand 1.4 or later.
:fullname "Clozure Common Lisp"
;; formerly OpenMCL, forked from MCL, formerly Macintosh Common Lisp, nee Coral Common Lisp
;; Random note: (finish-output) is essential for ccl, that won't do it by default,
;; unlike the other lisp implementations tested.
:name "ccl"
:feature :clozure
:flags ("--no-init" "--quiet")
:eval-flag "--eval" ; -e
:load-flag "--load"
:image-flag "--image-name" ; -I
:image-executable-p t
:standalone-executable t
:arguments-end "--"
:argument-control t ;; must be fixed now, but double-checking needed.
:disable-debugger ("--batch")
:directory-variable "CCL_DEFAULT_DIRECTORY"
:quit-format "(let ((x ~A)) (finish-output *standard-output*) (finish-output *error-output*) (ccl:quit x))"
:dump-format "(save-application ~S :prepend-kernel t)")
(define-lisp-implementation :ecl () ;; Not actually tested
:fullname "CLASP"
:name "clasp"
:feature :clasp
:flags () ;; ("-norc")
:eval-flag "-eval" ; -e ???
:load-flag "-load"
:image-flag nil
:image-executable-p t
:arguments-end "--"
:argument-control t ;; must be fixed now, but double-checking needed.
:disable-debugger ()
:quit-format "(si:quit ~A)"
:dump-format nil) ;; Cannot dump with CLASP. Link instead.
(define-lisp-implementation :clisp ()
:fullname "GNU CLISP"
:name "clisp"
:feature :clisp
:flags ("-norc" "--quiet" "--quiet" "-ansi") ;; don't use -I, for it induces extra prompt outputs.
:eval-flag "-x"
:load-flag "-i"
:arguments-end "--"
:image-executable-p t
:image-flag "-M"
:standalone-executable t ;; requires clisp 2.48 or later
:argument-control t ;; *BUT* even a standalone-executable always accepts --clisp-x and such.
:disable-debugger ("-on-error" "exit") ;; otherwise, -on-error debug
:quit-format "(ext:quit ~A)"
:dump-format "(ext:saveinitmem ~S :quiet t :executable t)")
(define-lisp-implementation (:cmucl :cmu) ()
:fullname "CMU CL"
:name "cmucl"
:feature :cmu
:flags ("-quiet" "-noinit")
:eval-flag "-eval"
:load-flag "-load"
:arguments-end "--"
:image-executable-p t
:image-flag "-core"
:argument-control t
:disable-debugger ("-batch")
:quit-format "(unix:unix-exit ~A)"
:dump-format "(extensions:save-lisp ~S :executable t)")
(define-lisp-implementation (:corman :cormanlisp) () ;; someone please add more complete support
:fullname "Corman Lisp"
:name () ;; There's a clconsole.exe, but what are the options?
:feature :cormanlisp
:quit-format "(win:exitprocess ~A)")
(define-lisp-implementation :ecl () ;; demand 10.4.2 or later.
:fullname "Embeddable Common-Lisp"
:name "ecl"
:feature :ecl
:flags ("-norc")
:eval-flag "-eval" ; -e
:load-flag "-load"
:image-flag nil
:image-executable-p t
:arguments-end "--"
:argument-control t ;; must be fixed now, but double-checking needed.
:disable-debugger ()
:quit-format "(si:quit ~A)"
:dump-format nil) ;; Cannot dump with ECL. Link instead.
(define-lisp-implementation :gcl () ;; Demand 2.8.0, if it is ever released. In ANSI mode. (defun get-lisp-implementation (&optional (implementation-type (implementation-type)))
:fullname "GNU Common Lisp" (or (gethash implementation-type *lisp-implementations*)
:name "gcl" ;; On debian, we might have to export GCL_ANSI=t to ensure the ANSI variant is used. (error "Unknown Lisp implementation type ~S" implementation-type)))
:feature :gcl
:flags ()
:eval-flag "-eval" ; -e
:load-flag "-load"
:image-flag nil
:image-executable-p t
:arguments-end "--" ;; -f ?
:disable-debugger ("-batch")
:quit-format "(lisp:quit ~A)"
:dump-format "(progn (si::set-hole-size 500) (si::gbc nil) (si::sgc-on t) (si::save-system ~A))")
(define-lisp-implementation (:lispworks :lw) ()
:fullname "LispWorks"
:name "lispworks-console" ;; This assumes you dumped a proper image for batch processing...
;; If you have a licensed copy of lispworks,
;; you can obtain the "lispworks" binary with, e.g.
;; echo '(hcl:save-image "lispworks-console" :environment nil)' > /tmp/build.lisp ;
;; ./lispworks-6-0-0-x86-linux -siteinit - -init - -build /tmp/build.lisp
;; Note that you also need to copy the license file to
;; .../lispworks/lib/6-1-0-0/config/lwlicense
;; and/or the same directory as your binary,
;; for it to work on dumped binaries in all locations, with, e.g.
;; (system::copy-file ".../lwlicense" (make-pathname :name "lwlicense" :type nil :defaults filename))
:feature :lispworks
:flags ("-site-init" "-" "-init" "-")
:eval-flag "-eval"
:load-flag "-build" ;; Is -load what we want? See also -build as magic load.
:arguments-end nil ; What's the deal with THIS? "--"
:image-flag nil
:image-executable-p t
:standalone-executable t
:argument-control t
:disable-debugger ()
:invoker invoke-lisp-via-script
:quit-format "(lispworks:quit :status ~A :confirm nil :return nil :ignore-errors-p t)"
:dump-format "(lispworks:deliver 'xcvb-driver:resume ~A 0 :interface nil)") ; "(hcl:save-image ~A :environment nil)"
(define-lisp-implementation :lispworks-personal ()
:fullname "LispWorks Personal Edition"
:name () ;; In LispWorks Personal, the slave worker executes you!
:feature :lispworks-personal-edition)
(define-lisp-implementation :mkcl ()
:fullname "ManKai Common-Lisp"
:name "mkcl"
:feature :mkcl
:flags ("-norc")
:eval-flag "-eval" ; -e
:load-flag "-load"
:image-flag nil
:image-executable-p t
:arguments-end "--"
:argument-control t ;; must be fixed now, but double-checking needed.
:disable-debugger ()
:quit-format "(mk-ext:quit :exit-code ~A)"
:dump-format nil) ;; Cannot dump with ECL. Link instead.
(define-lisp-implementation :sbcl ()
:fullname "Steel Bank Common Lisp"
:name "sbcl"
:feature :sbcl
:flags ("--noinform" "--no-userinit" "--no-sysinit") ;; minimize non-determinism form user's env
:eval-flag "--eval" ;; Note: SBCL's eval can only handle one form per argument.
:load-flag "--load"
:arguments-end "--end-toplevel-options"
:image-flag "--core"
:image-executable-p t
:standalone-executable t ;; requires sbcl 1.0.21.24 or later.
:argument-control t
:disable-debugger ("--disable-debugger")
:directory-variable "SBCL_HOME"
:quit-format "(let ((exit (find-symbol \"EXIT\" :sb-ext)) (quit (find-symbol \"QUIT\" :sb-ext)) (code ~A)) (cond (exit (funcall exit :code code)) (quit (funcall quit :unix-status code))))"
:dump-format "(sb-ext:save-lisp-and-die ~S :executable t)")
(define-lisp-implementation :scl ()
:fullname "Scieneer Common Lisp" ; use 1.3.9 or later
:name "scl"
:feature :scl
:flags ("-quiet" "-noinit")
:eval-flag "-eval"
:load-flag "-load"
:arguments-end "--"
:image-flag "-core"
:argument-control nil ;; cmucl will always scan all the arguments for -eval... EVIL!
:disable-debugger ("-batch")
:quit-format "(unix:unix-exit ~A)"
:dump-format "(extensions:save-lisp ~S)")
(define-lisp-implementation :xcl ()
:fullname "XCL"
:name "xcl"
:feature :xcl
:flags ("--no-userinit" "--no-siteinit" "--noinform")
:eval-flag "--eval"
:load-flag "--load"
:arguments-end "--"
:image-flag nil
:image-executable-p nil
:standalone-executable nil
:disable-debugger ()
:quit-format "(ext:quit :status ~A)"
:dump-format nil)
(defun ensure-path-executable (x) (defun ensure-path-executable (x)
(when x (when x
......
(defpackage :lisp-invocation/non-special
(:use :common-lisp :uiop)
(:export
#:compose-non-special-string #:compose-copy-paste-string))
(in-package :lisp-invocation/non-special)
(defun non-special-character-p (character)
"Is this character acceptable in an eval form, even when used under Windows?"
(let ((code (char-code character)))
(and (< 32 code 127) (not (find character "'\\\"")))))
(defun non-special-symbol-character-p (character)
"Is this character acceptable as part of a symbol in an eval form, even when used under Windows?"
(let ((code (char-code character))) ;; assumes uppercase.
;; No "modern" syntax accepted on the test master, though it can be used on the slave.
(and (< 32 code 91) (not (find character "'\\\":;")))))
(defun need-escape-within-pipe-p (character)
"Does this character need to be escaped when within symbol pipe notation?"
(or (eql character #\|) (eql character #\\)))
(defun print-string-in-pipes (string &optional s)
"Print a symbol |escaped| between pipes with the given STRING as its name, to the output S"
(with-output (s)
(princ "|" s)
(let ((string (string string)))
(if (some 'need-escape-within-pipe-p string)
(loop :for c :across string :do
(when (need-escape-within-pipe-p c) (princ #\\ s))
(princ c s))
(princ string s)))
(princ "|" s)))
(defun compose-non-special-string (forms &optional s)
"Given some FORMS, compose a string suitable to be passed for evaluation
to a Lisp implementation from the shell command-line with e.g. sbcl --eval or equivalent.
The string will contain no special character (space, dollars, quotes, double quotes)
so that it can be passed as a single argument
in a command-line, without causing munging by a Unix or Windows shell (assuming it's either
quoted or double-quoted).
Output S is as specified as per WITH-OUTPUT.
FORMS may be a preformatted string (assumed to not contain special characters), or
a list of forms, where each form is either a preformatted string,
or a LIST that specifies a program."
(etypecase forms
;; at the toplevel, a string mean "this is pre-formatted", you know what to pass to --eval
(string
(output-string forms s))
(list
(with-standard-io-syntax
(let ((*package* (find-package :cl)))
(with-output (s)
(labels
((p (x) (princ x s)) ;; princ
(w (x) (write x :stream s :case :downcase)) ;; write
(c (x) ;; form that evaluates into a character
(p "(code-char`") (p (char-code x)) (p ")"))
(sym (x) ;; print a symbol
;; check that only good characters are used in a symbol;
;; TODO: if not, go through a string (ugh!)
(assert (every 'acceptable-eval-symbol-character-p (package-name (symbol-package x))))
(assert (every 'acceptable-eval-symbol-character-p (symbol-name x)))
(w x))
(s (x) ;; form that evaluates into a string
(if (every 'acceptable-eval-character-p x)
(progn ;; simple string literal
(p "(string`") (print-string-in-pipes x s) (p ")"))
(progn
(p "(format()(string`|~{~a~}|)`(")
(loop
:with end = (length x)
:for start = 0 :then (if position (1+ position) end)
:for morep = (< start end)
:for position = (and morep
(position-if-not 'acceptable-eval-character-p x
:start start))
:while morep
:do (when (or (null position) (< start position))
(print-string-in-pipes (subseq x start position) s))
(when position
(p ",") (c (char x position))))
(p "))"))))
(n (x) ;; is it the easy case where no space is needed in the list?
(loop :for (a . d) :on x :do
(cond
((null d) (return t))
((atom d) (return nil))
((or (typep a '(or null character string cons))
(and (typep (car d) 'list) (n (car d)))))
(t (return nil)))))
(f (x) ;; top-level function to print a form without spaces, ' " \
(etypecase x
(null (p "()"))
(symbol (sym x))
(real (w x))
(character (p "#.") (c x))
(string (progn (p "#.") (s x)))
(cons
(if (n x)
(progn (p "(") (map () #'f x) (p ")"))
(progn (p "#.`") (b x))))))
(b (x) ;; print a form that, when inside a backquote, evaluates to the form we want
(etypecase x
(null (p "()"))
(symbol (sym x))
(real (w x))
(character (p ",") (c x))
(string (progn (p ",") (s x)))
(cons
(p "(")
(loop :for (a . d) :on x :do
(b a)
(cond
((null d)) ;; Done: d is a close paren
((typep a '(or null character string cons))) ;; Done: a ends with )
((atom d)
(p ",@") ;; NB: we rely on ,@ being the same as ., in practice
(typecase d
(character (c d))
(string (s d))
(real (w d))
((or keyword (eql t)) (sym d))
(t (p "`") (b d))))
((typep (car d) '(or list character string))) ;; Done: d starts with , or (
((typep (car d) '(or real keyword boolean)) ;; insert a , before constant
(p ","))
((typep (car d) 'symbol)
(p ",`")) ;; insert a ,` before variable symbol
(t (error "foo"))))
(p ")")))))
(p "(quote(")
(loop :for form :in forms :do
(p "#.")
(etypecase form
(string (p form)) ;; forms directly under the top-level can be preformatted, too
(list (f form))))
(p "))"))))))))
(defun compose-copy-paste-string (forms &optional s)
"Given the same input as for COMPOSE-NON-SPECIAL-STRING, output the very same FORMS
in a human-readable form that can be copy-pasted and edited onto a Common Lisp REPL."
(etypecase forms
(string (output-string forms s))
(list (format s "~{~A~%~}"
(with-standard-io-syntax
(let ((*package* (find-package :cl))
(*print-case* :downcase))
(mapcar (lambda (x)
(typecase x (string x)
(t (write-to-string x))))
forms)))))))
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment