;;;----- 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
;;; Program environment things.
(export 'exit)
-(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))
+(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning
+ sb-ext:compiler-note))
+ (defun exit (&optional (code 0) &key abrupt)
+ "End program, returning CODE to the caller."
+ (declare (type (unsigned-byte 32) code)
+ )
+ #.(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*))
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)
(export '(option optionp make-option
opt-short-name opt-long-name opt-tag opt-negated-tag
opt-arg-name opt-arg-optional-p opt-documentation))
-(defstruct (option
- (:predicate optionp)
- (:conc-name opt-)
- (:print-function
- (lambda (o s k)
- (declare (ignore k))
- (print-unreadable-object (o s :type t)
- (format s "~@[-~C, ~]~@[--~A~]~
+(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
+ (defstruct (option
+ (:predicate optionp)
+ (:conc-name opt-)
+ (:print-function
+ (lambda (o s k)
+ (declare (ignore k))
+ (print-unreadable-object (o s :type t)
+ (format s "~@[-~C, ~]~@[--~A~]~
~*~@[~2:*~:[=~A~;[=~A]~]~]~
~@[ ~S~]"
- (opt-short-name o)
- (opt-long-name o)
- (opt-arg-optional-p o)
- (opt-arg-name o)
- (opt-documentation o)))))
- (:constructor %make-option)
- (: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))))
- "Describes a command-line option. Slots:
+ (opt-short-name o)
+ (opt-long-name o)
+ (opt-arg-optional-p o)
+ (opt-arg-name o)
+ (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)
+ &aux (%documentation
+ documentation))))
+ "Describes a command-line option. Slots:
LONG-NAME The option's long name. If this is null, the `option' is
just a banner to be printed in the program's help text.
wrapped. If nil, the option is omitted from the help
text.
- 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)))
+ 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))))
+(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)
RADIX may be nil to allow radix prefixes, or an integer between 2 and 36.
An option-parse-error is signalled if the ARG is not a valid integer, or
if it is not between MIN and MAX (either of which may be nil if no lower
- resp. upper bound is wanted)."
+ or upper bound is wanted)."
(multiple-value-bind (v end) (parse-c-integer arg :radix radix)
(unless (and v (>= end (length arg)))
(option-parse-error "Bad integer `~A'" arg))
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))
- "Prints STRING to a pretty-printed STREAM, breaking it at whitespace and
+(locally (declare #+sbcl (sb-ext:muffle-conditions style-warning))
+ (defun print-text (string
+ &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."
- (let ((i start)
- (nest 0)
- (splitp nil))
- (flet ((emit ()
- (write-string string stream :start start :end i)
- (setf start i)))
- (unless end (setf end (length string)))
- (loop
- (unless (< i end)
- (emit)
- (return))
- (let ((ch (char string i)))
- (cond ((char= ch #\newline)
- (emit)
- (incf start)
- (pprint-newline :mandatory stream))
- ((whitespace-char-p ch)
- (when (zerop nest)
- (setf splitp t)))
- (t
- (when splitp
- (emit)
- (pprint-newline :fill stream))
- (setf splitp nil)
- (case ch
- (#\[ (incf nest))
- (#\] (when (plusp nest) (decf nest))))))
- (incf i))))))
+ (let ((i start)
+ (nest 0)
+ (splitp nil))
+ (flet ((emit ()
+ (write-string string stream :start start :end i)
+ (setf start i)))
+ (unless end (setf end (length string)))
+ (loop
+ (unless (< i end)
+ (emit)
+ (return))
+ (let ((ch (char string i)))
+ (cond ((char= ch #\newline)
+ (emit)
+ (incf start)
+ (pprint-newline :mandatory stream))
+ ((whitespace-char-p ch)
+ (when (zerop nest)
+ (setf splitp t)))
+ (t
+ (when splitp
+ (emit)
+ (pprint-newline :fill stream))
+ (setf splitp nil)
+ (case ch
+ (#\[ (incf nest))
+ (#\] (when (plusp nest) (decf nest))))))
+ (incf i)))))))
(export 'simple-usage)
(defun simple-usage (opts &optional mandatory-args)
(dolist (o opts)
(let ((doc (opt-documentation o)))
(cond ((not o))
- ((not (opt-long-name o))
+ ((not (or (opt-short-name o)
+ (opt-long-name o)))
(when newlinep
(terpri stream)
(setf newlinep nil))
(pprint-logical-block (stream nil)
(print-text doc stream))
(terpri stream))
- (t
+ (doc
(setf newlinep t)
(pprint-logical-block (stream nil :prefix " ")
- (format stream "~:[ ~;-~:*~C,~] --~A"
+ (format stream "~:[ ~;-~:*~C~:[~;,~]~:*~]~@[ --~A~]"
(opt-short-name o)
(opt-long-name o))
(when (opt-arg-name o)
- (format stream "~:[=~A~;[=~A]~]"
+ (format stream
+ "~:[~;[~]~:[~0@*~:[ ~;~]~*~;=~]~A~0@*~:[~;]~]"
(opt-arg-optional-p o)
+ (opt-long-name o)
(opt-arg-name o)))
(write-string " " stream)
(pprint-tab :line 30 1 stream)
~mdw / sod / blobdiff