From: Mark Wooding <mdw@distorted.org.uk>
Date: Fri, 15 Apr 2016 13:55:06 +0000 (+0100)
Subject: Merge slippers:src/lisp
X-Git-Url: https://git.distorted.org.uk/~mdw/lisp/commitdiff_plain/209dc75acf6ca1b236324bbad404070a88f99851?hp=-c

Merge slippers:src/lisp

* slippers:src/lisp:
  sys-base.lisp: Support for newer `uiop'-based `cl-launch'.
  sys-base.lisp: Use not-deprecated function for quitting SBCL.
---

209dc75acf6ca1b236324bbad404070a88f99851
diff --combined sys-base.lisp
index 4f52ec8,60bc8a4..4a90b93
--- a/sys-base.lisp
+++ b/sys-base.lisp
@@@ -1,5 -1,7 +1,5 @@@
  ;;; -*-lisp-*-
  ;;;
 -;;; $Id$
 -;;;
  ;;; Basic system-specific stuff
  ;;;
  ;;; (c) 2005 Mark Wooding
@@@ -39,11 -41,16 +39,16 @@@
  (defun set-command-line-arguments ()
    (setf *command-line*
  	(or (when (member :cl-launch *features*)
- 	      (let* ((cll-package (find-package :cl-launch))
- 		     (name (funcall (intern "GETENV" cll-package)
- 				    "CL_LAUNCH_FILE"))
- 		     (args (symbol-value (intern "*ARGUMENTS*"
- 						 cll-package))))
+ 	      (let* ((uiop-package (find-package :uiop))
+ 		     (cll-package (find-package :cl-launch))
+ 		     (name (some (intern "GETENV"
+ 					 (or uiop-package cll-package))
+ 				 (list "__CL_ARGV0" "CL_LAUNCH_FILE")))
+ 		     (args (symbol-value
+ 			    (if uiop-package
+ 				(intern "*COMMAND-LINE-ARGUMENTS*"
+ 					uiop-package)
+ 				(intern "*ARGUMENTS*" cll-package)))))
  		(if name
  		    (cons name args)
  		    args)))
@@@ -51,7 -58,7 +56,7 @@@
  	    #+sbcl sb-ext:*posix-argv*
  	    #+ecl (loop from i below (ext:argc) collect (ext:argv i))
  	    #+clisp (loop with argv = (ext:argv)
 -		          for i from 7 below (length argv)
 +			  for i from 7 below (length argv)
  			  collect (aref argv i))
  	    '("<unknown-lisp>" "--" "<unknown-script>")))
    (setf *program-name* (pathname-name (car *command-line*))))