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

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???
parent 88eda692
No related branches found
No related tags found
No related merge requests found
...@@ -106,6 +106,10 @@ ...@@ -106,6 +106,10 @@
*** `#5(1 ,@`(2 3)))` returns #(1 2 3), *** `#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). 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: ** XCL has bad bugs:
*** make-pathname doesn't handle :type nil properly and *** make-pathname doesn't handle :type nil properly and
has massive lossage in logical-pathname support. has massive lossage in logical-pathname support.
......
...@@ -59,5 +59,4 @@ It notably doesn't work on: ...@@ -59,5 +59,4 @@ It notably doesn't work on:
(ensure-directories-exist (translate-logical-pathname fasl)) (ensure-directories-exist (translate-logical-pathname fasl))
(compile-file (subpathname *asdf-dir* "build/asdf.lisp") :output-file fasl))) (compile-file (subpathname *asdf-dir* "build/asdf.lisp") :output-file fasl)))
(trace compile-file*) (uiop:writeln (multiple-value-list (install-asdf-as-module)))
(install-asdf-as-module)
...@@ -58,8 +58,9 @@ ...@@ -58,8 +58,9 @@
'parse-unix-namestring 'parse-unix-namestring
(remove-if 'emptyp (remove-if 'emptyp
(split-string ;; NB: assumes GNU make (split-string ;; NB: assumes GNU make
(run-program `("make" "--quiet" "--no-print-directory" ,target) (run-program `("make" "-C" ,(native-namestring *asdf-directory*)
:output :string :error-output t :directory *asdf-directory*) "--quiet" "--no-print-directory" ,target)
:output :string :error-output t)
:separator #(#\space #\newline #\return #\tab))))) :separator #(#\space #\newline #\return #\tab)))))
(defmacro compare-files (system target) (defmacro compare-files (system target)
......
...@@ -240,7 +240,7 @@ ...@@ -240,7 +240,7 @@
#-non-base-chars-exist-p #-non-base-chars-exist-p
(progn (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))) (assert (typep *last-char* 'base-char)))
(defun basify (s) (coerce s 'base-string)) (defun basify (s) (coerce s 'base-string))
......
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
(:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os) (:use :uiop/common-lisp :uiop/package :uiop/utility :uiop/pathname :uiop/stream :uiop/os)
(:export (:export
#:*image-dumped-p* #:raw-command-line-arguments #:*command-line-arguments* #:*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* #:*lisp-interaction*
#:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition #:*fatal-conditions* #:fatal-condition-p #:handle-fatal-condition
#:call-with-fatal-condition-handler #:with-fatal-condition-handler #:call-with-fatal-condition-handler #:with-fatal-condition-handler
...@@ -242,19 +242,27 @@ depending on whether *LISP-INTERACTION* is set, enter debugger or die" ...@@ -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. "Extract user arguments from command-line invocation of current process.
Assume the calling conventions of a generated script that uses -- Assume the calling conventions of a generated script that uses --
if we are not called from a directly executable image." if we are not called from a directly executable image."
(declare (ignorable arguments)) (block nil
#+abcl arguments #+abcl (return arguments)
;; LispWorks command-line processing isn't transparent to the user, and ;; SBCL and Allegro already separate user arguments from implementation arguments.
;; we need to rely on cl-launch or some other script to set it for us. #-(or sbcl allegro)
#+lispworks *command-line-arguments* (unless (eq *image-dumped-p* :executable)
#-(or abcl lispworks) ;; LispWorks command-line processing isn't transparent to the user
(let* (#-(or sbcl allegro) ;; unless you create a standalone executable; in that case,
(arguments ;; we rely on cl-launch or some other script to set the arguments for us.
(if (eq *image-dumped-p* :executable) #+lispworks (return *command-line-arguments*)
arguments ;; On other implementations, on non-standalone executables,
(member "--" arguments :test 'string-equal)))) ;; 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))) (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 () (defun setup-command-line-arguments ()
(setf *command-line-arguments* (command-line-arguments))) (setf *command-line-arguments* (command-line-arguments)))
......
...@@ -196,6 +196,7 @@ Returns two values: \(A B C\) and \(1 2 3\)." ...@@ -196,6 +196,7 @@ Returns two values: \(A B C\) and \(1 2 3\)."
;;; Characters ;;; Characters
(with-upgradability () ;; base-char != character on ECL, LW, SBCL, Genera. LW also has SIMPLE-CHAR. (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))) (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*))) (when +non-base-chars-exist-p+ (pushnew :non-base-chars-exist-p *features*)))
(with-upgradability () (with-upgradability ()
......
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