From 15b373a52bd01caefe294966cd47e27a5cc72060 Mon Sep 17 00:00:00 2001 From: Francois-Rene Rideau <tunes@google.com> Date: Sat, 1 Mar 2014 16:13:39 -0500 Subject: [PATCH] Define and export uiop:argv0, for the sake of a portable buildapp-like dispatched entry. Fix some issues with SCL: * it doesn't like run-program from a modified directory? * it somehow pushes :non-base-chars-exist-p even though +non-base-chars-exist-p+ is NIL??? --- TODO | 4 ++++ bin/install-asdf-as-module | 3 +-- test/test-sysdef-asdf.script | 5 +++-- test/test-utilities.script | 2 +- uiop/image.lisp | 32 ++++++++++++++++++++------------ uiop/utility.lisp | 1 + 6 files changed, 30 insertions(+), 17 deletions(-) diff --git a/TODO b/TODO index 6f328292..1a907bac 100644 --- a/TODO +++ b/TODO @@ -106,6 +106,10 @@ *** `#5(1 ,@`(2 3)))` returns #(1 2 3), rather than #(1 2 3 2 3 2 3 2 3) or even better #(1 2 3 3 3). +** SCL has bugs: +*** it doesn't like run-program from a modified directory? +*** it somehow pushes :non-base-chars-exist-p even though +non-base-chars-exist-p+ is NIL??? + ** XCL has bad bugs: *** make-pathname doesn't handle :type nil properly and has massive lossage in logical-pathname support. diff --git a/bin/install-asdf-as-module b/bin/install-asdf-as-module index 39df30a2..a04588bf 100644 --- a/bin/install-asdf-as-module +++ b/bin/install-asdf-as-module @@ -59,5 +59,4 @@ It notably doesn't work on: (ensure-directories-exist (translate-logical-pathname fasl)) (compile-file (subpathname *asdf-dir* "build/asdf.lisp") :output-file fasl))) -(trace compile-file*) -(install-asdf-as-module) +(uiop:writeln (multiple-value-list (install-asdf-as-module))) diff --git a/test/test-sysdef-asdf.script b/test/test-sysdef-asdf.script index 8af5ae09..337acf81 100644 --- a/test/test-sysdef-asdf.script +++ b/test/test-sysdef-asdf.script @@ -58,8 +58,9 @@ 'parse-unix-namestring (remove-if 'emptyp (split-string ;; NB: assumes GNU make - (run-program `("make" "--quiet" "--no-print-directory" ,target) - :output :string :error-output t :directory *asdf-directory*) + (run-program `("make" "-C" ,(native-namestring *asdf-directory*) + "--quiet" "--no-print-directory" ,target) + :output :string :error-output t) :separator #(#\space #\newline #\return #\tab))))) (defmacro compare-files (system target) diff --git a/test/test-utilities.script b/test/test-utilities.script index 7c495761..49708b0c 100644 --- a/test/test-utilities.script +++ b/test/test-utilities.script @@ -240,7 +240,7 @@ #-non-base-chars-exist-p (progn - (assert (base-string-p (make-string 10 :element-type 'character))) + (assert (base-string-p (make-string 10 :element-type 'character :initial-element *last-char*))) (assert (typep *last-char* 'base-char))) (defun basify (s) (coerce s 'base-string)) diff --git a/uiop/image.lisp b/uiop/image.lisp index 292786c9..bb044a2c 100644 --- a/uiop/image.lisp +++ b/uiop/image.lisp @@ -7,7 +7,7 @@ (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os) (:export #:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* - #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments + #:command-line-arguments #:raw-command-line-arguments #:setup-command-line-arguments #:argv0 #:*lisp-interaction* #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition #:call-with-fatal-condition-handler #:with-fatal-condition-handler @@ -242,19 +242,27 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die" "Extract user arguments from command-line invocation of current process. Assume the calling conventions of a generated script that uses -- if we are not called from a directly executable image." - (declare (ignorable arguments)) - #+abcl arguments - ;; LispWorks command-line processing isn't transparent to the user, and - ;; we need to rely on cl-launch or some other script to set it for us. - #+lispworks *command-line-arguments* - #-(or abcl lispworks) - (let* (#-(or sbcl allegro) - (arguments - (if (eq *image-dumped-p* :executable) - arguments - (member "--" arguments :test 'string-equal)))) + (block nil + #+abcl (return arguments) + ;; SBCL and Allegro already separate user arguments from implementation arguments. + #-(or sbcl allegro) + (unless (eq *image-dumped-p* :executable) + ;; LispWorks command-line processing isn't transparent to the user + ;; unless you create a standalone executable; in that case, + ;; we rely on cl-launch or some other script to set the arguments for us. + #+lispworks (return *command-line-arguments*) + ;; On other implementations, on non-standalone executables, + ;; we trust cl-launch or whichever script starts the program + ;; to use -- as a delimiter between implementation arguments and user arguments. + #-lispworks (setf arguments (member "--" arguments :test 'string-equal))) (rest arguments))) + (defun argv0 () + ;; Not available on ABCL, Genera, MCL. + (or #+(or allegro clisp clozure cmu gcl lispworks sbcl scl xcl) + (first (raw-command-line-arguments)) + #+ecl (si:argv 0))) + (defun setup-command-line-arguments () (setf *command-line-arguments* (command-line-arguments))) diff --git a/uiop/utility.lisp b/uiop/utility.lisp index 48dd4759..a9c42272 100644 --- a/uiop/utility.lisp +++ b/uiop/utility.lisp @@ -196,6 +196,7 @@ Returns two values: \(A B C\) and \(1 2 3\)." ;;; Characters (with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR. (defconstant +non-base-chars-exist-p+ (not (subtypep 'character 'base-char))) + #-scl ;; In SCL, all characters seem to be 16-bit base-char, but this flag gets set somehow??? (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*))) (with-upgradability () -- GitLab