X-Git-Url: https://git.distorted.org.uk/~mdw/sod/blobdiff_plain/9ec578d9fe450b7e7f9030dc9d930185593aa991..437938912d93089d7716a119363e49db5a57cba8:/src/optparse.lisp

diff --git a/src/optparse.lisp b/src/optparse.lisp
index fc46ba4..a2ac290 100644
--- a/src/optparse.lisp
+++ b/src/optparse.lisp
@@ -24,7 +24,7 @@
 ;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
 (cl:defpackage #:optparse
-  (:use #:common-lisp #:sod-utilities))
+  (:use #:common-lisp #:cl-launch #:sod-utilities))
 
 (cl:in-package #:optparse)
 
@@ -62,21 +62,13 @@
    Set `*command-line*' and `*program-name*'."
 
   (setf *command-line*
-	(or (when (member :cl-launch *features*)
-	      (let* ((cllpkg (find-package :cl-launch))
-		     (name (funcall (intern "GETENV" cllpkg)
-				    "CL_LAUNCH_FILE"))
-		     (args (symbol-value (intern "*ARGUMENTS*" cllpkg))))
-		(if name
-		    (cons name args)
-		    args)))
-	    #+sbcl sb-ext:*posix-argv*
-	    #+cmu ext:*command-line-strings*
-	    #+clisp (loop with argv = (ext:argv)
-			  for i from 7 below (length argv)
-			  collect (aref argv i))
-	    #+ecl (loop from i below (ext:argc) collect (ext:argv i))
-	    '("<unknown-script>"))
+	(cons (or (getenv "CL_LAUNCH_FILE")
+		  #+sbcl (car sb-ext:*posix-argv*)
+		  #+cmu (car ext:*command-line-strings*)
+		  #+clisp (aref (ext:argv) 0)
+		  #+ecl (ext:argv 0)
+		  #-(or sbcl cmu clisp ecl) "sod")
+	      *arguments*)
 
 	*program-name* (pathname-name (car *command-line*))))
 
@@ -121,66 +113,6 @@
   (do-case2-like 'ecase vform clauses))
 
 ;;;--------------------------------------------------------------------------
-;;; Locatives.
-
-(export '(loc locp))
-(defstruct (loc (:predicate locp) (:constructor make-loc (reader writer)))
-  "Locative data type.  See `locf' and `ref'."
-  (reader nil :type function)
-  (writer nil :type function))
-
-(export 'locf)
-(defmacro locf (place &environment env)
-  "Slightly cheesy locatives.
-
-   (locf PLACE) returns an object which, using the `ref' function, can be
-   used to read or set the value of PLACE.  It's cheesy because it uses
-   closures rather than actually taking the address of something.  Also,
-   unlike Zetalisp, we don't overload `car' to do our dirty work."
-  (multiple-value-bind
-      (valtmps valforms newtmps setform getform)
-      (get-setf-expansion place env)
-    `(let* (,@(mapcar #'list valtmps valforms))
-       (make-loc (lambda () ,getform)
-		 (lambda (,@newtmps) ,setform)))))
-
-(export 'ref)
-(declaim (inline ref (setf ref)))
-(defun ref (loc)
-  "Fetch the value referred to by a locative."
-  (funcall (loc-reader loc)))
-(defun (setf ref) (new loc)
-  "Store a new value in the place referred to by a locative."
-  (funcall (loc-writer loc) new))
-
-(export 'with-locatives)
-(defmacro with-locatives (locs &body body)
-  "Evaluate BODY with implicit locatives.
-
-   LOCS is a list of items of the form (SYM [LOC-EXPR]), where SYM is a
-   symbol and LOC-EXPR evaluates to a locative.  If LOC-EXPR is omitted, it
-   defaults to SYM.  As an abbreviation for a common case, LOCS may be a
-   symbol instead of a list.
-
-   The BODY is evaluated in an environment where each SYM is a symbol macro
-   which expands to (ref LOC-EXPR) -- or, in fact, something similar which
-   doesn't break if LOC-EXPR has side-effects.  Thus, references, including
-   `setf' forms, fetch or modify the thing referred to by the LOC-EXPR.
-   Useful for covering over where something uses a locative."
-  (setf locs (mapcar (lambda (item)
-		       (cond ((atom item) (list item item))
-			     ((null (cdr item)) (list (car item) (car item)))
-			     (t item)))
-		     (if (listp locs) locs (list locs))))
-  (let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
-	(ll (mapcar #'cadr locs))
-	(ss (mapcar #'car locs)))
-    `(let (,@(mapcar (lambda (tmp loc) `(,tmp ,loc)) tt ll))
-       (symbol-macrolet (,@(mapcar (lambda (sym tmp)
-				     `(,sym (ref ,tmp))) ss tt))
-	 ,@body))))
-
-;;;--------------------------------------------------------------------------
 ;;; Standard error-reporting functions.
 
 (export 'moan)