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

tools: clean up and document invoke-lisp a bit more

parent bf95a863
No related branches found
No related tags found
No related merge requests found
...@@ -33,68 +33,70 @@ and which systems to test loading with ASDF_TEST_SYSTEMS or s= ...@@ -33,68 +33,70 @@ and which systems to test loading with ASDF_TEST_SYSTEMS or s=
"Return a list of possible Allegro variants based on built-in information "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 and environment variables. The returned list is made up of argument lists for
REGISTER-LISP-IMPLEMENTATION." REGISTER-LISP-IMPLEMENTATION."
(loop (while-collecting (c)
:with results (loop :for (smpvar smpname smpfullname) :in `(("" "" "") ("S" :_s " (SMP)")) :do
:for (smpvar smpname smpfullname) :in `(("" "" "") ("S" :_s " (SMP)")) :do
(loop (loop
:for (bitsvar bitsname bitsfullname) :in '(("" "" "") ("64" "_64" " (64-bit words)")) :for (bitsvar bitsname bitsfullname) :in '(("" "" "") ("64" "_64" " (64-bit words)"))
:for dirvar = (format nil "~:@(ALLEGRO~A~A~)" bitsvar smpvar) :for dirvar = (format nil "~:@(ALLEGRO~A~A~)" bitsvar smpvar)
:for dir = (getenv-pathname dirvar :want-absolute t :ensure-directory t) :do :for dir = (getenv-pathname dirvar :want-absolute t :ensure-directory t) :do
(loop :for (charname charfullname) :in '(("" "") ("8" " (8-bit chars)")) :do (loop :for (charname charfullname) :in '(("" "") ("8" " (8-bit chars)")) :do
(loop :for (caseexe casename casefullname) :in '(("a" "" "") ("m" :modern " (modern syntax)")) (loop
:for allegro-variant = (conc-keyword :allegro casename charname bitsname smpname) :for (caseexe casename casefullname) :in
:for fullname = (strcat "Allegro CL" '(("a" "" "") ("m" :modern " (modern syntax)"))
casefullname charfullname bitsfullname smpfullname) :for allegro-variant = (conc-keyword :allegro casename charname bitsname smpname)
:for executable = (format nil "~(~alisp~a~)" caseexe charname) :for fullname = (strcat "Allegro CL"
:do casefullname charfullname bitsfullname smpfullname)
(push :for executable = (format nil "~(~alisp~a~)" caseexe charname) :do
`(,allegro-variant (c `(,allegro-variant
:fullname ,fullname :fullname ,fullname
:name ,(native-namestring (subpathname dir executable)) :name ,(native-namestring (subpathname dir executable))
:feature :allegro ;; do we want a more discriminating feature expression? :feature :allegro ;; do we want a more discriminating feature expression?
:flags '("-qq") :flags '("-qq")
:eval-flag "-e" :eval-flag "-e"
:load-flag "-L" :load-flag "-L"
;; :quit-flags ("-kill") ;; :quit-flags ("-kill")
:arguments-end "--" :arguments-end "--"
:image-flag "-I" :image-flag "-I"
:image-executable-p nil :image-executable-p nil
:standalone-executable nil :standalone-executable nil
:argument-control t :argument-control t
:disable-debugger ,`("-batch" ; see also -#D -#C -#! :disable-debugger ("-batch" ; see also -#D -#C -#!
,@(when (and (os-windows-p) (not (getenvp "ALLEGRO_NOISY"))) ,@(when (and (os-windows-p)
'("+c"))) (not (getenvp "ALLEGRO_NOISY")))
:quit-format "(excl:exit ~A :quiet t)" '("+c")))
: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))") results)))) :quit-format "(excl:exit ~A :quiet t)"
:finally (return results))) :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 register-lisp-implementation* (x)
"Register the lisp implementation described a list X of a name followed by a plist"
(apply 'register-lisp-implementation x))
(mapc #'(lambda (x) (apply 'register-lisp-implementation x)) (all-allegro-variants)) (map () 'register-lisp-implementation* (all-allegro-variants))
(defun all-ecl-variants () (defun all-ecl-variants ()
"Return a list of possible ECL variants with or withotu bytecode compiler"
(loop (loop
:for (ecl-variant extraname flags) :in :for (ecl-variant extraname flags) :in
'((:ecl "" ("-load" "sys:cmp")) '((:ecl "" ("-load" "sys:cmp"))
(:ecl_bytecodes " (using bytecodes compiler)" ("-eval" "(ext::install-bytecodes-compiler)"))) (:ecl_bytecodes " (using bytecodes compiler)" ("-eval" "(ext::install-bytecodes-compiler)")))
:for fullname = (strcat "Embeddable Common-Lisp" extraname) :for fullname = (strcat "Embeddable Common-Lisp" extraname) :collect
:collecting `(,ecl-variant
`( :fullname ,fullname
,ecl-variant :name "ecl"
:fullname ,fullname :feature :ecl
:name "ecl" :environment-variable "ECL"
:feature :ecl :flags ("-norc" ,@flags)
:environment-variable "ECL" :eval-flag "-eval" ; -e
:flags ,`("-norc" ,@flags) :load-flag "-load"
:eval-flag "-eval" ; -e :image-flag nil
:load-flag "-load" :image-executable-p t
:image-flag nil :arguments-end "--"
:image-executable-p t :argument-control t ;; must be fixed now, but double-checking needed.
:arguments-end "--" :disable-debugger ()
:argument-control t ;; must be fixed now, but double-checking needed. :quit-format "(si:quit ~A)"
:disable-debugger () :dump-format nil))) ;; Cannot dump with ECL. Link instead.
:quit-format "(si:quit ~A)"
:dump-format nil))) ;; Cannot dump with ECL. Link instead.
(mapc #'(lambda (x) (apply 'register-lisp-implementation x)) (all-ecl-variants)) (map () 'register-lisp-implementation* (all-ecl-variants))
(defun acceptable-eval-character-p (character) (defun acceptable-eval-character-p (character)
"Is this character acceptable in an eval form, even when used under Windows?" "Is this character acceptable in an eval form, even when used under Windows?"
...@@ -112,6 +114,7 @@ REGISTER-LISP-IMPLEMENTATION." ...@@ -112,6 +114,7 @@ REGISTER-LISP-IMPLEMENTATION."
(or (eql character #\|) (eql character #\\))) (or (eql character #\|) (eql character #\\)))
(defun print-string-in-pipes (string &optional s) (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) (with-output (s)
(princ "|" s) (princ "|" s)
(let ((string (string string))) (let ((string (string string)))
...@@ -223,6 +226,9 @@ a preformatted string, or a LIST that specifies a program." ...@@ -223,6 +226,9 @@ a preformatted string, or a LIST that specifies a program."
(p "))")))))))) (p "))"))))))))
(defun compose-copy-paste-string (forms &optional s) (defun compose-copy-paste-string (forms &optional s)
"Given FORMS to execute, specified as either a S-expression or a pre-formatted string,
output to S some text without spaces or shell-special characters that will evaluate
to the same form"
(etypecase forms (etypecase forms
(string (output-string forms s)) (string (output-string forms s))
(list (format s "~{~A~%~}" (list (format s "~{~A~%~}"
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Please register or to comment