diff --git a/test/script-support.lisp b/test/script-support.lisp index 39731bbe5fa446370d53a333d336d4f92151aafe..e2c9d6a8f8ca49facbdcdec92ee10813392a2f82 100644 --- a/test/script-support.lisp +++ b/test/script-support.lisp @@ -35,6 +35,8 @@ Some constraints: (in-package :asdf-test) +#+(and ecl (not ecl-bytecmp)) (require :cmp) + (declaim (optimize (speed 2) (safety #-gcl 3 #+gcl 0) #-(or allegro gcl genera) (debug 3) #+(or cmu scl) (c::brevity 2))) (proclaim '(optimize (speed #-gcl 2 #+gcl 1) (safety #-gcl 3 #+gcl 0) #-(or allegro gcl genera) (debug 3) diff --git a/tools/asdf-tools.asd b/tools/asdf-tools.asd index 661d45709dd1911855ec17caf90ab155ccda57a4..a913542718ac87f1b473e1378b5f34cbf66b20f8 100644 --- a/tools/asdf-tools.asd +++ b/tools/asdf-tools.asd @@ -2,7 +2,7 @@ :description "tools to build, test, maintain and release ASDF itself" :depends-on ((:version "asdf" "3.1.2") (:version "inferior-shell" "2.0.2") - (:version "lisp-invocation" "1.0.2") + (:version "lisp-invocation/all" "1.0.5") (:version "cl-ppcre" "2.0.4") (:version "optima.ppcre" "1.0") (:feature :sbcl "sb-introspect")) @@ -12,8 +12,7 @@ (:file "main" :depends-on ("failure")) (:file "pathnames" :depends-on ("package")) (:file "version" :depends-on ("failure")) - (:file "invoke-lisp" :depends-on ("package")) - (:file "test-environment" :depends-on ("pathnames" "invoke-lisp" "main")) + (:file "test-environment" :depends-on ("pathnames" "main")) (:file "build" :depends-on ("test-environment")) (:file "git" :depends-on ("test-environment")) (:file "test-basic" :depends-on ("test-environment")) diff --git a/tools/failure.lisp b/tools/failure.lisp index 1960e5fecfc198f9f6d35ffbf6fd1fef77172b5c..f7bd488e2bd80793915f298e4637ce938e472bfe 100644 --- a/tools/failure.lisp +++ b/tools/failure.lisp @@ -138,7 +138,7 @@ (failure-if failurep (make-failures))))) (defun run-command (fun &rest args) - (let ((results (multiple-value-list (with-failure-context () (apply fun (rest args)))))) + (let ((results (multiple-value-list (with-failure-context () (apply fun args))))) ;; Don't print anything on success for regular commands, otherwise print all values returned. (if (failurep results) (let ((failures (failure-failures results))) diff --git a/tools/invoke-lisp.lisp b/tools/invoke-lisp.lisp deleted file mode 100644 index 3790c90557b7c3960e263db1c2eb1993393cfa76..0000000000000000000000000000000000000000 --- a/tools/invoke-lisp.lisp +++ /dev/null @@ -1,242 +0,0 @@ -(in-package :asdf-tools) - -#| -Supported test lisp implementations include: - allegro, abcl, ccl, clisp, cmucl, ecl, gcl, lispworks, mkcl, sbcl, scl and xcl. -Non supported are: - cormancl, lispworks-personal-edition, mcl, genera - -CCL is Clozure CL; (R)MCL is not supported. -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. - -To configure the lisp implementations with which to run the tests, -you may export environment variables to override the defaults: -ASDF_TEST_LISPS and ASDF_UPGRADE_TEST_LISPS can each be a string of space-separated names -amongst the above implementation names. -You may also explicitly specify the same variables with the respective l= and u= arguments. -Individual test commands only use the first (preferred) provided implementation; -other test commands (named test-all-FOO) iterate over all implementations. - -Similarly, you can configure which scripts to tests with ASDF_TEST_SCRIPTS or t= -and which systems to test loading with ASDF_TEST_SYSTEMS or s= - -|# -(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))")))))))) - -(defun register-lisp-implementation* (x) - "Register the lisp implementation described by the list X, which consists of a name -followed by a plist of keywords and arguments." - (apply 'register-lisp-implementation x)) - -(map () 'register-lisp-implementation* (all-allegro-variants)) - -(defun all-ecl-variants () - "Return a list of possible ECL variants with or without bytecode compiler" - (loop - :for (ecl-variant extraname flags) :in - '((:ecl "" ("-load" "sys:cmp")) - (:ecl_bytecodes " (using bytecodes compiler)" ("-eval" "(ext::install-bytecodes-compiler)"))) - :for fullname = (strcat "Embeddable Common-Lisp" extraname) :collect - `(,ecl-variant - :fullname ,fullname - :name "ecl" - :feature :ecl - :environment-variable "ECL" - :flags ("-norc" ,@flags) - :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. - -(map () 'register-lisp-implementation* (all-ecl-variants)) - -(defun acceptable-eval-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 acceptable-eval-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-eval-string (forms &optional s) - "Given a 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. -Output S is as specified as per WITH-OUTPUT. -FORMS may be a preformatted string, 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 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 - (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))))))) diff --git a/tools/main.lisp b/tools/main.lisp index 75d078a36ce2a9ba74fae68a975f88addc8ca77b..334ed9865c401b31e5480a43a3cb4bd23271441e 100644 --- a/tools/main.lisp +++ b/tools/main.lisp @@ -96,7 +96,7 @@ based on a list of targets" ;;; NB: For access control, you could check that only exported symbols are used as entry points. (defun process-arguments (args) (if-let ((fun (and args (find-command (first args))))) - (run-command fun (rest args)) + (apply 'run-command fun (rest args)) (progn (if args (format t "Command ~A not found~%" (first args)) diff --git a/tools/package.lisp b/tools/package.lisp index 5d1f9c6bc6ce428fd6ce9fef2749f8f31aa41b7e..3ab41210c6de1b7fcc795f7f4d5578064949eee8 100644 --- a/tools/package.lisp +++ b/tools/package.lisp @@ -1,6 +1,6 @@ (defpackage :asdf-tools (:use :common-lisp :uiop :asdf - :fare-utils :inferior-shell :lisp-invocation :cl-ppcre :optima :optima.ppcre) + :fare-utils :inferior-shell :lisp-invocation :lisp-invocation/non-special :cl-ppcre :optima :optima.ppcre) (:export ;; TODO: export stuff ;; failure #:with-failure-context #:success #:failure #:success-if #:failure-if #:fail! diff --git a/tools/test-environment.lisp b/tools/test-environment.lisp index 0acaf83f88e79f5152a797bfba1f40fd9a74b0f7..fd6eccc8bde252974bcc531e0da288700b9eba25 100644 --- a/tools/test-environment.lisp +++ b/tools/test-environment.lisp @@ -1,6 +1,18 @@ (in-package :asdf-tools) ;;; Testing +#| +To configure the lisp implementations with which to run the tests, +you may export environment variables to override the defaults: +ASDF_TEST_LISPS and ASDF_UPGRADE_TEST_LISPS can each be a string of space-separated names +amongst the above implementation names. +You may also explicitly specify the same variables with the respective l= and u= arguments. +Individual test commands only use the first (preferred) provided implementation; +other test commands (named test-all-FOO) iterate over all implementations. + +Similarly, you can configure which scripts to tests with ASDF_TEST_SCRIPTS or t= +and which systems to test loading with ASDF_TEST_SYSTEMS or s= +|# (defparameter *test-lisps* :default "The list of lisp implementations to use for tests")