;;; 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)
"Increments VAR by STEP (defaults to 1), but not greater than MAX (default
nil for no maximum). No errors are signalled."
(incf var step)
- (when (>= var max)
+ (when (and max (>= var max))
(setf var max)))
(export 'dec)
"Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
for no maximum). No errors are signalled."
(decf var step)
- (when (<= var min)
+ (when (and min (<= var min))
(setf var min)))
(export 'read)
;;;--------------------------------------------------------------------------
;;; Full program descriptions.
+(export '(*help* *version* *usage*))
(defvar *help* nil "Help text describing the program.")
(defvar *version* "<unreleased>" "The program's version number.")
(defvar *usage* nil "A usage summary string")
~mdw / sod / blobdiff