;;;----- Licensing notice ---------------------------------------------------
;;;
-;;; This file is part of the Sensble Object Design, an object system for C.
+;;; This file is part of the Sensible Object Design, an object system for C.
;;;
;;; SOD is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
(defun exit (&optional (code 0) &key abrupt)
"End program, returning CODE to the caller."
(declare (type (unsigned-byte 32) code))
- #+sbcl (sb-ext:exit :code code :abort abrupt)
- #+cmu (if abrupt
- (unix::void-syscall ("_exit" c-call:int) code)
- (ext:quit code))
- #+clisp (funcall (if abrupt #'ext:quit #'ext:exit) code)
- #+ecl (ext:quit code)
-
- #-(or sbcl cmu clisp ecl)
- (progn
- (unless (zerop code)
- (format *error-output*
- "~&Exiting unsuccessfully with code ~D.~%" code))
- (abort)))
+ #.(car '(#+sbcl (sb-ext:exit :code code :abort abrupt)
+ #+cmu (if abrupt
+ (unix::void-syscall ("_exit" c-call:int) code)
+ (ext:quit code))
+ #+clisp (funcall (if abrupt #'ext:quit #'ext:exit) code)
+ #+ecl (ext:quit code)
+ (unless (zerop code)
+ (format *error-output*
+ "~&Exiting unsuccessfully with code ~D.~%" code))))
+ (abort))
(export '(*program-name* *command-line*))
(defvar *program-name* "<unknown>"
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>"))
+ (let ((uiop-package (find-package :uiop))
+ (cll-package (find-package :cl-launch)))
+ (cons (or (and uiop-package
+ (funcall (intern "ARGV0" uiop-package)))
+ (and cll-package
+ (some (intern "GETENV" cll-package)
+ (list "__CL_ARGV0" "CL_LAUNCH_FILE")))
+ #+sbcl (car sb-ext:*posix-argv*)
+ #+cmu (car ext:*command-line-strings*)
+ #+clisp (aref (ext:argv) 0)
+ #+ecl (ext:argv 0)
+ "sod")
+ (cond (uiop-package
+ (funcall (intern "COMMAND-LINE-ARGUMENTS"
+ uiop-package)))
+ (cll-package
+ (symbol-value (intern "*ARGUMENTS*" cll-package)))
+ (t #.(or (car '(#+sbcl (cdr sb-ext:*posix-argv*)
+ #+cmu (cdr ext:*command-line-strings*)
+ #+clisp (coerce (subseq (ext:argv) 8)
+ 'list)
+ #+ecl (loop for i from 1
+ below (ext:argc)
+ collect (ext:argv i))))
+ (error "Unsupported Lisp"))))))
*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)
(opt-long-name o)
(opt-arg-optional-p o)
(opt-arg-name o)
- (opt-documentation o)))))
- (:constructor %make-option)
+ (opt-%documentation o)))))
+ (:constructor %make-option
+ (&key long-name tag negated-tag short-name
+ arg-name arg-optional-p documentation
+ &aux (%documentation documentation)))
(:constructor make-option
(long-name short-name
&optional arg-name
&key (tag (intern (string-upcase long-name) :keyword))
negated-tag
arg-optional-p
- doc (documentation doc))))
+ doc (documentation doc)
+ &aux (%documentation documentation))))
"Describes a command-line option. Slots:
LONG-NAME The option's long name. If this is null, the `option' is
wrapped. If nil, the option is omitted from the help
text.
- Usually, one won't use make-option, but use the option macro instead."
+ Usually, one won't use `make-option', but use the `option' macro instead."
(long-name nil :type (or null string))
(tag nil :type t)
(negated-tag nil :type t)
(short-name nil :type (or null character))
(arg-name nil :type (or null string))
(arg-optional-p nil :type t)
- (documentation nil :type (or null string)))
+ (%documentation nil :type (or null string)))
+(define-access-wrapper opt-documentation opt-%documentation)
(export '(option-parser option-parser-p make-option-parser
op-options op-non-option op-long-only-p op-numeric-p
negated-numeric-p
long-only-p
&aux (args (cons nil argstmp))
+ (%options options)
(next args)
(negated-p (or negated-numeric-p
(some #'opt-negated-tag
still allowed, and may be cuddled as usual. The default is
nil."
(args nil :type list)
- (options nil :type list)
+ (%options nil :type list)
(non-option :skip :type (or function (member :skip :stop :return)))
(next nil :type list)
(short-opt nil :type (or null string))
(numeric-p nil :type t)
(negated-numeric-p nil :type t)
(negated-p nil :type t))
+(define-access-wrapper op-options op-%options)
(export 'option-parse-error)
(define-condition option-parse-error (error simple-condition)
,@docs ,@decls
(declare (ignorable ,arg))
(with-locatives ,var
- ,@body))
+ (block ,name ,@body)))
',name))))
(defun parse-c-integer (string &key radix (start 0) end)
"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)
Option macros should produce a list of expressions producing one option
structure each."
- `(progn
- (setf (get ',name 'optmacro) (lambda ,args ,@body))
- ',name))
+ (multiple-value-bind (docs decls body) (parse-body body)
+ `(progn
+ (setf (get ',name 'optmacro) (lambda ,args
+ ,@docs ,@decls
+ (block ,name ,@body)))
+ ',name)))
(export 'parse-option-form)
(eval-when (:compile-toplevel :load-toplevel :execute)
;;; Support stuff for help and usage messages.
(defun print-text (string
- &optional
- (stream *standard-output*)
- &key
- (start 0)
- (end nil))
+ &optional (stream *standard-output*)
+ &key (start 0) (end nil))
"Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
newlines in the obvious way. Stuff between square brackets is not broken:
this makes usage messages work better."
;;;--------------------------------------------------------------------------
;;; 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