"Bind `it' to result of COND when evaluating THEN or ELSE."
`(let ((it ,cond))
(if it ,then ,@(and else (list else)))))
+
(defmacro aif2 (cond then &optional else)
"Bind `it' to first value of COND; switch on second."
(let ((tmp (gensym)))
"Bind `it' to result of COND when evaluating BODY."
`(let ((it ,cond))
(when it ,@body)))
+
(defmacro awhen2 (cond &body body)
"Bind `it' to first value of COND; switch on second."
(let ((tmp (gensym)))
(defmacro asetf (&rest pairs &environment env)
"Set PLACE to value of FORM; in FORM, `it' is bound to current value of
-PLACE."
+ PLACE."
(labels ((foo (pairs)
(when pairs
(let ((place (car pairs))
(defmacro acond (&rest clauses)
"Like `cond', but in each clause the consequent has `it' bound to the value
-of its guard."
+ of its guard."
(labels ((foo (clauses)
(when clauses
(let ((tmp (gensym))
(defmacro collecting (vars &body body)
"Collect items into lists. The VARS are a list of collection variables --
-their values are unspecified, except that they may be passed to `collect' and
-`collect-tail' If VARS is empty then *collecting-anon-list-name* is used.
-VARS may be an atom instead of a singleton list. The form produces multiple
-values, one for each list constructed."
+ their values are unspecified, except that they may be passed to `collect'
+ and `collect-tail' If VARS is empty then *collecting-anon-list-name* is
+ used. VARS may be an atom instead of a singleton list. The form produces
+ multiple values, one for each list constructed."
(cond ((null vars) (setf vars (list *collecting-anon-list-name*)))
((atom vars) (setf vars (list vars))))
`(let ,(mapcar (lambda (v) `(,v (make-collector))) vars)
(defmacro with-collection (vars collection &body body)
"Collect items into lists VARS according to the form COLLECTION; then
-evaluate BODY with VARS bound to those lists."
+ evaluate BODY with VARS bound to those lists."
`(multiple-value-bind
- ,(listify vars)
+ ,(listify vars)
(collecting ,vars ,collection)
,@body))
(defmacro collect (x &optional (name *collecting-anon-list-name*))
"Add item X to the `collecting' list NAME (or *collecting-anon-list-name*
-by default)."
+ by default)."
(with-gensyms tmp
`(let ((,tmp (cons ,x nil)))
(setf (cddr ,name) ,tmp)
(defmacro collect-tail (x &optional (name *collecting-anon-list-name*))
"Make item X be the tail of `collecting' list NAME (or
-*collecting-anon-list-name* by default). It is an error to continue trying
-to add stuff to the list."
+ *collecting-anon-list-name* by default). It is an error to continue
+ trying to add stuff to the list."
`(progn
(setf (cddr ,name) ,x)
(setf (cdr ,name) nil)))
(defun factorial (n)
"Compute a factorial. This is a little bit optimized: we try to multiply
-values which are similar in size."
+ values which are similar in size."
(when (minusp n)
(error "negative factorial argument ~A" n))
(let ((stack nil))
(defstruct (operator (:predicate operatorp)
(:conc-name op-))
"An operator object. The name serves mainly for documentation. The left
-and right precedences control operator stacking behaviour. The function is
-called when this operator is popped off the stack.
-
-If the left precedence is not nil, then operators currently on the stack
-whose /right/-precedence is greater than or equal to this operator's
-/left/-precedence are popped before this operator can be pushed. If the
-right precedence is nil, then this operator is not in fact pushed, but
-processed immediately."
+ and right precedences control operator stacking behaviour. The function
+ is called when this operator is popped off the stack.
+
+ If the left precedence is not nil, then operators currently on the stack
+ whose /right/-precedence is greater than or equal to this operator's
+ /left/-precedence are popped before this operator can be pushed. If the
+ right precedence is nil, then this operator is not in fact pushed, but
+ processed immediately."
(name nil :type symbol)
(lprec nil :type (or fixnum null))
(rprec nil :type (or fixnum null))
"The current token. Could be any Lisp object.")
(defvar *paren-depth* 0
"Depth of parentheses in the current `parse-infix'. Used to override the
-minprec restriction.")
+ minprec restriction.")
;;;--------------------------------------------------------------------------
;;; The tokenizer.
(defun flushops (prec)
"Flush out operators on the operator stack with precedecnce higher than or
-equal to PREC. This is used when a new operator is pushed, to ensure that
-higher-precedence operators snarf their arguments."
+ equal to PREC. This is used when a new operator is pushed, to ensure that
+ higher-precedence operators snarf their arguments."
(loop
(when (null *opstk*)
(return))
(defun pushop (op)
"Push the operator OP onto the stack. If the operator has a
-left-precedence, then operators with higher precedence are flushed (see
-`flushops'). If the operator has no left-precedence, the operator is invoked immediately."
+ left-precedence, then operators with higher precedence are flushed (see
+ `flushops'). If the operator has no left-precedence, the operator is
+ invoked immediately."
(let ((lp (op-lprec op)))
(when lp
(flushops lp)))
(defun infix-done ()
"Signal that `parse-infix' has reached the end of an expression. This is
-primarily used by the `)' handler function if it finds there are no
-parentheses."
+ primarily used by the `)' handler function if it finds there are no
+ parentheses."
(throw 'infix-done nil))
(defun parse-infix (&optional minprec)
"Parses an infix expression and return the resulting Lisp form. This is
-the heart of the whole thing.
+ the heart of the whole thing.
-Expects a token to be ready in *token*; leaves *token* as the first token
-which couldn't be parsed.
+ Expects a token to be ready in *token*; leaves *token* as the first token
+ which couldn't be parsed.
-The syntax parsed by this function doesn't fit nicely into a BNF, since we
-parsing is effected by the precedences of the various operators. We have
-low-precedence prefix operators such as `not', for example."
+ The syntax parsed by this function doesn't fit nicely into a BNF, since we
+ parsing is effected by the precedences of the various operators. We have
+ low-precedence prefix operators such as `not', for example."
(flet ((lookup (items)
(dolist (item items (values nil nil))
(let ((op (get *token* (car item))))
(defmacro defopfunc (op kind &body body)
"Defines a magical operator. The operator's name is the symbol OP. The
-KIND must be one of the symbols `infix', `prefix' or `postfix'. The body is
-evaluated when the operator is parsed, and must either push appropriate
-things on the operator stack or do its own parsing and push a result on the
-value stack."
+ KIND must be one of the symbols `infix', `prefix' or `postfix'. The body
+ is evaluated when the operator is parsed, and must either push appropriate
+ things on the operator stack or do its own parsing and push a result on
+ the value stack."
`(progn
(setf (get ',op ',kind)
(lambda () ,@body))
(defmacro definfix (op prec &body body)
"Defines an infix operator. The operator's name is the symbol OP. The
-operator's precedence is specified by PREC, which may be one of the
-following:
+ operator's precedence is specified by PREC, which may be one of the
+ following:
- * PREC -- equivalent to (:lassoc PREC)
- * (:lassoc PREC) -- left-associative with precedence PREC
- * (:rassoc PREC) -- right-associative with precedence PREC
- * (LPREC . RPREC) -- independent left- and right-precedences
- * (LPREC RPREC) -- synonym for the dotted form
+ * PREC -- equivalent to (:lassoc PREC)
+ * (:lassoc PREC) -- left-associative with precedence PREC
+ * (:rassoc PREC) -- right-associative with precedence PREC
+ * (LPREC . RPREC) -- independent left- and right-precedences
+ * (LPREC RPREC) -- synonym for the dotted form
-In fact, (:lassoc PREC) is the same as (PREC . PREC), and (:rassoc PREC) is
-the same as (PREC . (1- PREC)).
+ In fact, (:lassoc PREC) is the same as (PREC . PREC), and (:rassoc PREC)
+ is the same as (PREC . (1- PREC)).
-The BODY is evaluated when the operator's arguments are fully resolved. It
-should pop off two arguments and push one result. Nobody will check that
-this is done correctly."
+ The BODY is evaluated when the operator's arguments are fully resolved.
+ It should pop off two arguments and push one result. Nobody will check
+ that this is done correctly."
(multiple-value-bind
(lprec rprec)
(flet ((bad ()
',op)))
(defmacro defprefix (op prec &body body)
"Defines a prefix operator. The operator's name is the symbol OP. The
-operator's (right) precedence is PREC. The body is evaluated with the
-operator's argument is fully determined. It should pop off one argument and
-push one result."
+ operator's (right) precedence is PREC. The body is evaluated with the
+ operator's argument is fully determined. It should pop off one argument
+ and push one result."
(do-defunary 'prefix op prec body))
(defmacro defpostfix (op prec &body body)
"Defines a postfix operator. The operator's name is the symbol OP. The
-operator's (left) precedence is PREC. The body is evaluated with the
-operator's argument is fully determined. It should pop off one argument and
-push one result."
+ operator's (left) precedence is PREC. The body is evaluated with the
+ operator's argument is fully determined. It should pop off one argument
+ and push one result."
(do-defunary 'postfix op prec body))
;;;--------------------------------------------------------------------------
(defun delim (delim &key (requiredp t))
"Parse DELIM, and read the next token. Returns t if the DELIM was found,
-or nil if not (and requiredp was nil)."
+ or nil if not (and requiredp was nil)."
(cond ((eq *token* delim) (get-token) t)
(requiredp (error "expected `~(~A~)'; found ~S" delim *token*))
(t nil)))
(defun errfunc (&rest args)
"Returns a function which reports an error. Useful when constructing
-operators by hand."
+ operators by hand."
(lambda () (apply #'error args)))
(defun binop-apply (name)
"Apply the Lisp binop NAME to the top two items on the value stack; i.e.,
-if the top two items are Y and X, then we push (NAME X Y)."
+ if the top two items are Y and X, then we push (NAME X Y)."
(let ((y (popval)) (x (popval)))
(pushval (list name x y))))
(defun binop-apply-append (name)
"As for `binop-apply' but if the second-from-top item on the stack has the
-form (NAME SOMETHING ...) then fold the top item into the form rather than
-buidling another."
+ form (NAME SOMETHING ...) then fold the top item into the form rather than
+ buidling another."
(let ((y (popval)) (x (popval)))
(pushval (if (and (consp x) (eq (car x) name))
(append x (list y))
(defun unop-apply (name)
"Apply the Lisp unop NAME to the top item on the value stack; i.e., if the
-top item is X, then push (NAME X)."
+ top item is X, then push (NAME X)."
(pushval (list name (popval))))
+
(defun unop-apply-toggle (name)
"As for `unop-apply', but if the top item has the form (NAME X) already,
-then push just X."
+ then push just X."
(let ((x (popval)))
(pushval (if (and (consp x)
(eq (car x) name)
(defun strip-progn (form)
"Return a version of FORM suitable for putting somewhere where there's an
-implicit `progn'. If FORM has the form (PROGN . FOO) then return FOO,
-otherwise return (FORM)."
+ implicit `progn'. If FORM has the form (PROGN . FOO) then return FOO,
+ otherwise return (FORM)."
(if (and (consp form)
(eq (car form) 'progn))
(cdr form)
(defun push-paren (right)
"Pushes a funny parenthesis operator. Since this operator has no left
-precedence, and very low right precedence, it is pushed over any stack of
-operators and can only be popped by magic or end-of-file. In the latter
-case, cause an error."
+ precedence, and very low right precedence, it is pushed over any stack of
+ operators and can only be popped by magic or end-of-file. In the latter
+ case, cause an error."
(pushop (make-operator :name right
:lprec nil :rprec -1000
:func (errfunc "missing `~A'" right)))
(defun pop-paren (right)
"Pops a parenthesis. If there are no parentheses, maybe they belong to the
-caller's syntax. Otherwise, pop off operators above the current funny
-parenthesis operator, and then remove it."
+ caller's syntax. Otherwise, pop off operators above the current funny
+ parenthesis operator, and then remove it."
(when (zerop *paren-depth*)
(infix-done))
(flushops -999)
(defopfunc if operand
"Parse an `if' form. Syntax:
- IF ::= `if' CONDITION `then' CONSEQUENCE [`else' ALTERNATIVE]
+ IF ::= `if' CONDITION `then' CONSEQUENCE [`else' ALTERNATIVE]
-We parse this into an `if' where sensible, or into a `cond' if we see an
-`else if' pair. The usual `dangling else' rule is followed."
+ We parse this into an `if' where sensible, or into a `cond' if we see an
+ `else if' pair. The usual `dangling else' rule is followed."
(get-token)
(let (cond cons)
(setf cond (parse-infix))
(defun do-letlike (kind)
"Parse a `let' form. Syntax:
- LET ::= `let' | `let*' VARS `in' EXPR
- VARS ::= VAR | VARS `,' VAR
- VAR ::= NAME [`=' VALUE]
+ LET ::= `let' | `let*' VARS `in' EXPR
+ VARS ::= VAR | VARS `,' VAR
+ VAR ::= NAME [`=' VALUE]
-Translates into the obvious Lisp code."
+ Translates into the obvious Lisp code."
(let ((clauses nil) name value)
(get-token)
(loop
(defun read-infix (&optional (*stream* *standard-input*) &key (delim eof))
"Reads an infix expression from STREAM and returns the corresponding Lisp.
-Requires the expression to be delimited properly by DELIM (by default
-end-of-file)."
+ Requires the expression to be delimited properly by DELIM (by default
+ end-of-file)."
(let (*token*)
(prog2
(get-token)
(defun install-infix-reader (&optional (char #\$))
"Installs a macro character `$ INFIX... $' for translating infix notation
-to Lisp forms. You also want to (use-package :infix-keywords) if you do
-this."
+ to Lisp forms. You also want to (use-package :infix-keywords) if you do
+ this."
(let ((delim (intern (string #\$) 'infix-keywords)))
(set-macro-character char (lambda (stream ch)
(declare (ignore ch))
(defmacro compile-time-defun (name args &body body)
"Define a function which can be used by macros during the compilation
-process."
+ process."
`(eval-when (:compile-toplevel :load-toplevel)
(defun ,name ,args ,@body)))
(defun stringify (str)
"Return a string representation of STR. Strings are returned unchanged;
-symbols are converted to their names (unqualified!). Other objects are
-converted to their print representations."
+ symbols are converted to their names (unqualified!). Other objects are
+ converted to their print representations."
(typecase str
(string str)
(symbol (symbol-name str))
(compile-time-defun fix-pair (x &optional (y nil defaultp))
"Return two values extracted from X. It works as follows:
- (A) -> A, Y
- (A B) -> A, B
- (A B . C) -> error
- (A . B) -> A, B
- A -> A, Y
-where Y defaults to A if not specified."
+ (A) -> A, Y
+ (A B) -> A, B
+ (A B . C) -> error
+ (A . B) -> A, B
+ A -> A, Y
+ where Y defaults to A if not specified."
(do-fix-pair x y defaultp))
(compile-time-defun pairify (x &optional (y nil defaultp))
(declaim (ftype (function nil ()) slot-unitialized))
(defun slot-uninitialized ()
"A function which signals an error. Can be used as an initializer form in
-structure definitions without doom ensuing."
+ structure definitions without doom ensuing."
(error "No initializer for slot."))
(compile-time-defun parse-body (body)
"Given a BODY (a list of forms), parses it into three sections: a
-docstring, a list of declarations (forms beginning with the symbol `declare')
-and the body forms. The result is returned as three lists (even the
-docstring), suitable for interpolation into a backquoted list using `@,'."
+ docstring, a list of declarations (forms beginning with the symbol
+ `declare') and the body forms. The result is returned as three lists
+ (even the docstring), suitable for interpolation into a backquoted list
+ using `@,'."
(multiple-value-bind
(doc body)
(if (and (consp body)
(defmacro let*/gensyms (binds &body body)
"A macro helper. BINDS is a list of binding pairs (VAR VALUE), where VALUE
-defaults to VAR. The result is that BODY is evaluated in a context where
-each VAR is bound to a gensym, and in the final expansion, each of those
-gensyms will be bound to the corresponding VALUE."
+ defaults to VAR. The result is that BODY is evaluated in a context where
+ each VAR is bound to a gensym, and in the final expansion, each of those
+ gensyms will be bound to the corresponding VALUE."
(labels ((more (binds)
(let ((tmp (gensym "TMP")) (bind (car binds)))
`((let ((,tmp ,(cadr bind))
(defmacro case2 (vform &body clauses)
"VFORM is a form which evaluates to two values, SCRUTINEE and ARGUMENT.
-The CLAUSES have the form (CASES ([VAR]) FORMS...), where a standard `case'
-clause has the form (CASES FORMS...). The `case2' form evaluates the VFORM,
-and compares the SCRUTINEE to the various CASES, in order, just like `case'.
-If there is a match, then the corresponding FORMs are evaluated with VAR (if
-specified) bound to the value of ARGUMENT."
+ The CLAUSES have the form (CASES ([VAR]) FORMS...), where a standard
+ `case' clause has the form (CASES FORMS...). The `case2' form evaluates
+ the VFORM, and compares the SCRUTINEE to the various CASES, in order, just
+ like `case'. If there is a match, then the corresponding FORMs are
+ evaluated with VAR (if specified) bound to the value of ARGUMENT."
(do-case2-like 'case vform clauses))
(defmacro ecase2 (vform &body clauses)
(defmacro with-places ((&key environment) places &body body)
"A hairy helper, for writing setf-like macros. PLACES is a list of binding
-pairs (VAR PLACE), where PLACE defaults to VAR. The result is that BODY is
-evaluated in a context where each VAR is bound to a gensym, and in the final
-expansion, each of those gensyms will be bound to a symbol-macro capable of
-reading or setting the value of the corresponding PLACE."
+ pairs (VAR PLACE), where PLACE defaults to VAR. The result is that BODY
+ is evaluated in a context where each VAR is bound to a gensym, and in the
+ final expansion, each of those gensyms will be bound to a symbol-macro
+ capable of reading or setting the value of the corresponding PLACE."
(if (null places)
`(progn ,@body)
(let*/gensyms (environment)
(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."
+ 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)
(defmacro with-locatives (locs &body body)
"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."
+ 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 #'pairify (listify locs)))
(let ((tt (mapcar (lambda (l) (declare (ignore l)) (gensym)) locs))
(ll (mapcar #'cadr locs))
(documentation doc))))
"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.
+ 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.
-TAG The value to be returned if this option is encountered. If
- this is a function, instead, the function is called with the
- option's argument or nil.
+ TAG The value to be returned if this option is encountered. If
+ this is a function, instead, the function is called with the
+ option's argument or nil.
-NEGATED-TAG As for TAG, but used if the negated form of the option is
- found. If this is nil (the default), the option cannot be
- negated.
+ NEGATED-TAG As for TAG, but used if the negated form of the option is
+ found. If this is nil (the default), the option cannot be
+ negated.
-SHORT-NAME The option's short name. This must be a single character, or
- nil if the option has no short name.
+ SHORT-NAME The option's short name. This must be a single character, or
+ nil if the option has no short name.
-ARG-NAME The name of the option's argument, a string. If this is nil,
- the option doesn't accept an argument. The name is shown in
- the help text.
+ ARG-NAME The name of the option's argument, a string. If this is nil,
+ the option doesn't accept an argument. The name is shown in
+ the help text.
-ARG-OPTIONAL-P If non-nil, the option's argument is optional. This is
- ignored unless ARG-NAME is non-null.
+ ARG-OPTIONAL-P
+ If non-nil, the option's argument is optional. This is
+ ignored unless ARG-NAME is non-null.
-DOCUMENTATION The help text for this option. It is automatically
- line-wrapped. If nil, the option is omitted from the help
- text.
+ DOCUMENTATION
+ The help text for this option. It is automatically line-
+ 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)
options))))))
"An option parser object. Slots:
-ARGS The arguments to be parsed. Usually this will be
- *command-line-strings*.
+ ARGS The arguments to be parsed. Usually this will be
+ *command-line-strings*.
-OPTIONS List of option structures describing the acceptable options.
+ OPTIONS List of option structures describing the acceptable options.
-NON-OPTION Behaviour when encountering a non-option argument. The
- default is :skip. Allowable values are:
- :skip -- pretend that it appeared after the option
- arguments; this is the default behaviour of GNU getopt
- :stop -- stop parsing options, leaving the remaining
- command line unparsed
- :return -- return :non-option and the argument word
+ NON-OPTION Behaviour when encountering a non-option argument. The
+ default is :skip. Allowable values are:
+ :skip -- pretend that it appeared after the option
+ arguments; this is the default behaviour of GNU getopt
+ :stop -- stop parsing options, leaving the remaining
+ command line unparsed
+ :return -- return :non-option and the argument word
-NUMERIC-P Non-nil tag (as for options) if numeric options (e.g., -43)
- are to be allowed. The default is nil. (Anomaly: the
- keyword for this argument is :numericp.)
+ NUMERIC-P Non-nil tag (as for options) if numeric options (e.g., -43)
+ are to be allowed. The default is nil. (Anomaly: the
+ keyword for this argument is :numericp.)
-NEGATED-NUMERIC-P
- Non-nil tag (as for options) if numeric options (e.g., -43)
- can be negated. This is not the same thing as a negative
- numeric option!
+ NEGATED-NUMERIC-P
+ Non-nil tag (as for options) if numeric options (e.g., -43)
+ can be negated. This is not the same thing as a negative
+ numeric option!
-LONG-ONLY-P A misnomer inherited from GNU getopt. Whether to allow
- long options to begin with a single dash. Short options are
- still allowed, and may be cuddled as usual. The default is
- nil."
+ LONG-ONLY-P A misnomer inherited from GNU getopt. Whether to allow
+ long options to begin with a single dash. Short options are
+ still allowed, and may be cuddled as usual. The default is
+ nil."
(args nil :type list)
(options nil :type list)
(non-option :skip :type (or function (member :skip :stop :return)))
(define-condition option-parse-error (error simple-condition)
()
- (:documentation "Indicates an error found while parsing options. Probably
-not that useful."))
+ (:documentation
+ "Indicates an error found while parsing options. Probably not that
+ useful."))
(defun option-parse-error (msg &rest args)
"Signal an option-parse-error with the given message and arguments."
(defun option-parse-next (op)
"The main option-parsing function. OP is an option-parser object,
-initialized appropriately. Returns two values, OPT and ARG: OPT is the tag
-of the next option read, and ARG is the argument attached to it, or nil if
-there was no argument. If there are no more options, returns nil twice.
-Options whose TAG is a function aren't returned; instead, the tag function is
-called, with the option argument (or nil) as the only argument. It is safe
-for tag functions to throw out of option-parse-next, if they desparately need
-to. (This is the only way to actually get option-parse-next to return a
-function value, should that be what you want.)
-
-While option-parse-next is running, there is a restart `skip-option' which
-moves on to the next option. Error handlers should use this to resume after
-parsing errors."
+ initialized appropriately. Returns two values, OPT and ARG: OPT is the
+ tag of the next option read, and ARG is the argument attached to it, or
+ nil if there was no argument. If there are no more options, returns nil
+ twice. Options whose TAG is a function aren't returned; instead, the tag
+ function is called, with the option argument (or nil) as the only
+ argument. It is safe for tag functions to throw out of option-parse-next,
+ if they desparately need to. (This is the only way to actually get
+ option-parse-next to return a function value, should that be what you
+ want.)
+
+ While option-parse-next is running, there is a restart `skip-option' which
+ moves on to the next option. Error handlers should use this to resume
+ after parsing errors."
(loop
(labels ((ret (opt &optional arg)
(return-from option-parse-next (values opt arg)))
(defmacro option-parse-try (&body body)
"Report errors encountered while parsing options, and continue struggling
-along. Also establishes a restart `stop-parsing'. Returns t if parsing
-completed successfully, or nil if errors occurred."
+ along. Also establishes a restart `stop-parsing'. Returns t if parsing
+ completed successfully, or nil if errors occurred."
(with-gensyms (retcode)
`(let ((,retcode t))
(restart-case
(&rest args)
&body body)
"Define an option handler function NAME. Option handlers update a
-generalized variable, which may be referred to as VAR in the BODY, based on
-some parameters (the ARGS) and the value of an option-argument named ARG."
+ generalized variable, which may be referred to as VAR in the BODY, based
+ on some parameters (the ARGS) and the value of an option-argument named
+ ARG."
(let ((func (intern (format nil "OPTHANDLER/~:@(~A~)" name))))
`(progn
(setf (get ',name 'opthandler) ',func)
(defun parse-c-integer (string &key radix (start 0) end)
"Parse STRING, or at least the parts of it between START and END, according
-to the standard C rules. Well, almost: the 0 and 0x prefixes are accepted,
-but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS is accepted,
-for any radix between 2 and 36. Prefixes are only accepted if RADIX is nil.
-Returns two values: the integer parsed (or nil if there wasn't enough for a
-sensible parse), and the index following the characters of the integer."
+ to the standard C rules. Well, almost: the 0 and 0x prefixes are
+ accepted, but so too are 0o (Haskell) and 0b (original); also RADIX_DIGITS
+ is accepted, for any radix between 2 and 36. Prefixes are only accepted
+ if RADIX is nil. Returns two values: the integer parsed (or nil if there
+ wasn't enough for a sensible parse), and the index following the
+ characters of the integer."
(unless end (setf end (length string)))
(labels ((simple (i r goodp sgn)
(multiple-value-bind
(defun invoke-option-handler (handler loc arg args)
"Call the HANDLER function, giving it LOC to update, the option-argument
-ARG, and the remaining ARGS."
+ ARG, and the remaining ARGS."
(apply (if (functionp handler) handler
(fdefinition (get handler 'opthandler)))
loc
(defopthandler inc (var) (&optional max (step 1))
"Increments VAR by STEP (defaults to 1), but not greater than MAX (default
-nil for no maximum). No errors are signalled."
+ nil for no maximum). No errors are signalled."
(incf var step)
(when (>= var max)
(setf var max)))
(defopthandler dec (var) (&optional min (step 1))
"Decrements VAR by STEP (defaults to 1), but not less than MIN (default nil
-for no maximum). No errors are signalled."
+ for no maximum). No errors are signalled."
(decf var step)
(when (<= var min)
(setf var min)))
(defopthandler read (var arg) ()
"Stores in VAR the Lisp object found by reading the ARG. Evaluation is
-forbidden while reading ARG. If there is an error during reading, an error
-of type option-parse-error is signalled."
+ forbidden while reading ARG. If there is an error during reading, an
+ error of type option-parse-error is signalled."
(handler-case
(let ((*read-eval* nil))
(multiple-value-bind (x end) (read-from-string arg t)
(defopthandler int (var arg) (&key radix min max)
"Stores in VAR the integer read from the ARG. Integers are parsed
-according to C rules, which is normal in Unix; the 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)."
+ according to C rules, which is normal in Unix; the 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)."
(multiple-value-bind (v end) (parse-c-integer arg :radix radix)
(unless (and v (>= end (length arg)))
(option-parse-error "Bad integer `~A'" arg))
(defopthandler list (var arg) (&optional handler &rest handler-args)
"Collect ARGs in a list at VAR. ARGs are translated by the HANDLER first,
-if specified. If not, it's as if you asked for `string'."
+ if specified. If not, it's as if you asked for `string'."
(when handler
(invoke-option-handler handler (locf arg) arg handler-args))
(setf var (nconc var (list arg))))
(defmacro defoptmacro (name args &body body)
"Defines an option macro NAME. Option macros should produce a list of
-expressions producing one option structure each."
+ expressions producing one option structure each."
`(progn
(setf (get ',name 'optmacro) (lambda ,args ,@body))
',name))
(compile-time-defun parse-option-form (form)
"Does the heavy lifting for parsing an option form. See the docstring for
-the `option' macro for details of the syntax."
+ the `option' macro for details of the syntax."
(flet ((doc (form)
(cond ((stringp form) form)
((null (cdr form)) (car form))
(defmacro options (&rest optlist)
"More convenient way of initializing options. The OPTLIST is a list of
-OPTFORMS. Each OPTFORM is one of the following:
+ OPTFORMS. Each OPTFORM is one of the following:
- STRING
- A banner to print.
+ STRING A banner to print.
- SYMBOL or (SYMBOL STUFF...)
- If SYMBOL is an optform macro, the result of invoking it.
+ SYMBOL or (SYMBOL STUFF...)
+ If SYMBOL is an optform macro, the result of invoking it.
- (...)
- A full option-form. See below.
+ (...) A full option-form. See below.
-Full option-forms are as follows.
+ Full option-forms are as follows.
- KEYWORD or FUNCTION
- If no TAG is set yet, then as a TAG; otherwise as the NEGATED-TAG.
+ KEYWORD or FUNCTION
+ If no TAG is set yet, then as a TAG; otherwise as the
+ NEGATED-TAG.
- STRING (or SYMBOL or RATIONAL)
- If no LONG-NAME seen yet, then the LONG-NAME. For symbols and rationals,
- the item is converted to a string and squashed to lower-case.
+ STRING (or SYMBOL or RATIONAL)
+ If no LONG-NAME seen yet, then the LONG-NAME. For symbols
+ and rationals, the item is converted to a string and squashed
+ to lower-case.
- CHARACTER
- The SHORT-NAME.
+ CHARACTER The SHORT-NAME.
- STRING or (STRING STUFF...)
- If no DOCUMENTATION set yet, then the DOCUMENTATION string, as for
- (:DOC STRING STUFF...)
+ STRING or (STRING STUFF...)
+ If no DOCUMENTATION set yet, then the DOCUMENTATION string,
+ as for (:DOC STRING STUFF...)
- (:DOC STRING STUFF...)
- The DOCUMENATION string. With no STUFF, STRING is used as is; otherwise
- the documentation string is computed by (format nil STRING STUFF...).
+ (:DOC STRING STUFF...)
+ The DOCUMENATION string. With no STUFF, STRING is used as
+ is;otherwise the documentation string is computed by (format
+ nil STRING STUFF...).
- (:ARG NAME)
- Set the ARG-NAME.
+ (:ARG NAME) Set the ARG-NAME.
- (:OPT-ARG NAME)
- Set the ARG-NAME, and also set ARG-OPTIONAL-P.
+ (:OPT-ARG NAME)
+ Set the ARG-NAME, and also set ARG-OPTIONAL-P.
- (HANDLER VAR ARGS...)
- If no TAG is set yet, attach the HANDLER to this option, giving it ARGS.
- Otherwise, set the NEGATED-TAG."
+ (HANDLER VAR ARGS...)
+ If no TAG is set yet, attach the HANDLER to this option,
+ giving it ARGS. Otherwise, set the NEGATED-TAG."
`(list ,@(mapcan (lambda (form)
(multiple-value-bind
(sym args)
(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."
+ 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))
(defun simple-usage (opts &optional mandatory-args)
"Build a simple usage list from a list of options, and (optionally)
-mandatory argument names."
+ mandatory argument names."
(let (short-simple long-simple short-arg long-arg)
(dolist (o opts)
(cond ((not (and (opt-documentation o)
(defun show-usage (prog usage &optional (stream *standard-output*))
"Basic usage-showing function. PROG is the program name, probably from
-*command-line-strings*. USAGE is a list of possible usages of the program,
-each of which is a list of items to be supplied by the user. In simple
-cases, a single string is sufficient."
+ *command-line-strings*. USAGE is a list of possible usages of the
+ program, each of which is a list of items to be supplied by the user. In
+ simple cases, a single string is sufficient."
(pprint-logical-block (stream nil :prefix "Usage: ")
(dolist (u (listify usage))
(pprint-logical-block (stream nil :prefix (format nil "~A " prog))
(defun show-help (prog ver usage opts &optional (stream *standard-output*))
"Basic help-showing function. PROG is the program name, probably from
-*command-line-strings*. VER is the program's version number. USAGE is a
-list of the possible usages of the program, each of which may be a list of
-items to be supplied. OPTS is the list of supported options, as provided to
-the options parser. STREAM is the stream to write on."
+ *command-line-strings*. VER is the program's version number. USAGE is a
+ list of the possible usages of the program, each of which may be a list of
+ items to be supplied. OPTS is the list of supported options, as provided
+ to the options parser. STREAM is the stream to write on."
(format stream "~A, version ~A~2%" prog ver)
(show-usage prog usage stream)
(terpri stream)
(defun sanity-check-option-list (opts)
"Check the option list OPTS for basic sanity. Reused short and long option
-names are diagnosed. Maybe other problems will be reported later. Returns a
-list of warning strings."
+ names are diagnosed. Maybe other problems will be reported later.
+ Returns a list of warning strings."
(let ((problems nil)
(longs (make-hash-table :test #'equal))
(shorts (make-hash-table)))
usage full-usage
options)
"Sets up all the required things a program needs to have to parse options
-and respond to them properly."
+ and respond to them properly."
(when program-name (setf *program-name* program-name))
(when help (setf *help* help))
(when version (setf *version* version))
(full-usage (setf *usage* full-usage))))
(defmacro do-options ((&key (parser '(make-option-parser))) &body clauses)
+ "Handy all-in-one options parser macro. PARSER defaults to a new options
+ parser using the preset default options structure. The CLAUSES are
+ `case2'-like clauses to match options, and must be exhaustive. If there
+ is a clause (nil (REST) FORMS...) then the FORMS are evaluated after
+ parsing is done with REST bound to the remaining command-line arguments."
(with-gensyms (tparser)
`(let ((,tparser ,parser))
(loop
(defun fresh-file-name (base tag)
"Return a fresh file name constructed from BASE and TAG in the current
-directory. Do not assume that this filename will be good by the time you try
-to create the file."
+ directory. Do not assume that this filename will be good by the time you
+ try to create the file."
(let ((name (format nil "~A.~A-~X"
base tag (random most-positive-fixnum))))
(if (probe-file name) (fresh-file-name base tag) name)))
(defun safely-open-output-stream (safe file &rest open-args)
"Create an output stream which will be named FILE when SAFE is committed.
-Other OPEN-ARGS are passed to open."
+ Other OPEN-ARGS are passed to open."
(let* ((new (fresh-file-name file "new"))
(stream (apply #'open
new
(defun rename-file-without-moaning (old new)
"Rename OLD to NEW, ignoring errors, and without doing any stupid name
-mangling."
+ mangling."
(with-errno-handlers ()
(sys-rename old new)
(ENOENT nil)))
(defun safely-bail (safe)
"Abort the operations in SAFE, unwinding all the things that have been
-done. Streams are closed, new files are removed."
+ done. Streams are closed, new files are removed."
(dolist (stream (safely-streams safe))
(close stream :abort t))
(safely-unwind (safely-trail safe))
(defun safely-commit (safe)
"Commit SAFE. The files deleted by safely-delete-file are deleted; the
-files created by safely-open-output-stream are renamed over the old versions,
-if any. If a problem occurs during this stage, everything is rewound and no
-changes are made."
+ files created by safely-open-output-stream are renamed over the old
+ versions, if any. If a problem occurs during this stage, everything is
+ rewound and no changes are made."
(let ((trail (safely-trail safe))
(revert nil)
(cleanup nil))
(defmacro safely ((safe &key) &body body)
"Do stuff within the BODY safely. If BODY completes without errors, the
-SAFE is committed; otherwise it's bailed."
+ SAFE is committed; otherwise it's bailed."
`(let ((,safe (make-safely)))
(unwind-protect
(progn
(defmacro safely-writing ((stream file &rest open-args) &body body)
"Simple macro for writing a single file safely. STREAM is opened onto a
-temporary file, and if BODY completes, it is renamed to FILE."
+ temporary file, and if BODY completes, it is renamed to FILE."
(with-gensyms safe
`(safely (,safe)
(let ((,stream (apply #'safely-open-output-stream
(defun join-strings (del strs)
"Join together the strings STRS with DEL between them. All the arguments
-are first converted to strings, as if by `stringify'. Otherwise, this is
-like Perl's join operator."
+ are first converted to strings, as if by `stringify'. Otherwise, this is
+ like Perl's join operator."
(setf del (stringify del))
(with-output-to-string (s)
(when strs
(defun str-next-word (string &key quotedp start end)
"Extract a whitespace-delimited word from STRING, returning it and the
-index to continue parsing from. If no word is found, return nil twice. If
-QUOTEDP, then allow quoting and backslashifying; otherwise don't. The START
-and END arguments limit the portion of the string to be processed; the
-default to 0 and nil (end of string), as usual."
+ index to continue parsing from. If no word is found, return nil twice.
+ If QUOTEDP, then allow quoting and backslashifying; otherwise don't. The
+ START and END arguments limit the portion of the string to be processed;
+ the default to 0 and nil (end of string), as usual."
(unless start (setf start 0))
(unless end (setf end (length string)))
(let ((i start)
(defun str-split-words (string &key quotedp start end max)
"Break STRING into words, like str-next-word does, returning the list of
-the individual words. If QUOTEDP, then allow quoting and backslashifying;
-otherwise don't. No more than MAX `words' are returned: if the maximum is
-hit, then the last `word' is unbroken, and may still contain quotes and
-escape characters. The START and END arguments limit the portion of the
-string to be processed in the usual way."
+ the individual words. If QUOTEDP, then allow quoting and backslashifying;
+ otherwise don't. No more than MAX `words' are returned: if the maximum is
+ hit, then the last `word' is unbroken, and may still contain quotes and
+ escape characters. The START and END arguments limit the portion of the
+ string to be processed in the usual way."
(when (equal max 0)
(return-from str-split-words nil))
(let ((l nil) (n 0))
#+cmu
(defun exit (&optional (code 0))
"Polite way to end a program. If running in an interactive Lisp, just
-return to the top-level REPL."
+ return to the top-level REPL."
(if *batch-mode*
(throw 'lisp::%end-of-the-world code)
(progn
#+cmu
(defun hard-exit (&optional (code 0))
"Stops the program immediately in its tracks. Does nothing else. Use
-after fork, for example, to avoid flushing buffers."
+ after fork, for example, to avoid flushing buffers."
(declare (type (unsigned-byte 32) code))
(unix::void-syscall ("_exit" c-call:int) code))
(defmacro with-buffer ((var len) &body body)
"Evaluate BODY with VAR bound to a pointer (a SAP, if you must know) to a
-buffer of LEN bytes."
+ buffer of LEN bytes."
(with-gensyms lenvar
`(let ((,lenvar ,len)
(,var nil))
errstring)
form &rest clauses)
"Evaluate FORM but trap Unix errors according to CLAUSES. Each clause has
-the form of a `case' clause, but may contain symbolic errno names as well as
-numbers."
+ the form of a `case' clause, but may contain symbolic errno names as well
+ as numbers."
(flet ((fix (sw)
(cond ((eq sw t) 't)
((atom sw) (list (errno-value sw)))
(defun syscall* (name func &rest args)
"Call Unix system call FUNC, passing it ARGS. If it returns an error,
-signal the unix-error condition, with NAME and ARGS."
+ signal the unix-error condition, with NAME and ARGS."
(multiple-value-call (lambda (rc &rest stuff)
(unless rc
(error 'unix-error
(apply func args)))
(defmacro syscall (func &rest args)
"Call Unix system call FUNC, passing it ARGS. If it returns an error,
-signal the unix-error condition, with FUNC and ARGS."
- `(syscall* ',func #',func ,@args))
+ signal the unix-error condition, with FUNC and ARGS."
+ `(syscall* ',func
+ #',func ,@args))
(macrolet ((doit (doc slots)
`(defstruct (stat (:predicate statp)
,doc
,@slots)))
(doit
- "Structure representing all the useful information `stat' returns about
-a file."
+ "Structure representing all the useful information `stat' returns about a
+ file."
(dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks)))
(defun sys-stat (file)
"Return information about FILE in a structure rather than as inconvenient
-multiple values."
+ multiple values."
(multiple-value-call
(lambda (rc &rest results)
(unless rc
(defmacro with-unix-open ((fd file how &optional (mode #o666)) &body body)
"Evaluate BODY with FD bound to a file descriptor obtained from a Unix
-`open' syscall with arguments FILE, HOW and MODE. Close the file descriptor
-when BODY is done."
+ `open' syscall with arguments FILE, HOW and MODE. Close the file
+ descriptor when BODY is done."
`(let (,fd)
(unwind-protect
(progn
(defun copy-file (from to &optional (how 0))
"Make a copy of the file FROM called TO. The copy has the same permissions
-and timestamps (except for ctime) and attempts to have the same owner and
-group as the original."
+ and timestamps (except for ctime) and attempts to have the same owner and
+ group as the original."
(let ((st (sys-stat from)))
(with-unix-open (in from unix:O_RDONLY)
(with-unix-open (out
~mdw / lisp / commitdiff