;;; 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)
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*))))
(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)
~mdw / sod / blobdiff