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