;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Andersson tree implementation
;;;
;;; (c) 2006 Straylight/Edgeware
;;; Package.
(defpackage #:aa-tree
- (:use #:common-lisp #:mdw.base)
- (:export #:make-aa-tree #:aa-tree-p #:aa-tree-key<
- #:getaa #:updateaa #:mapaa #:doaa #:aa-tree-iterator #:remaa))
+ (:use #:common-lisp #:mdw.base))
(in-package #:aa-tree)
;;;--------------------------------------------------------------------------
(deftype tree-node () 'simple-vector)
+(export '(make-aa-tree aa-tree aa-tree-p aa-tree-key<))
(defstruct (aa-tree
(:predicate treep)
(:constructor make-aa-tree
(do ((need (ash size 1) (ash need 1)))
((>= need want) (setf (tree-stack tree) (make-array need)))))))
+(export 'getaa)
(defun getaa (tree key &optional default)
"Look up the given KEY in an Andersson TREE; if the KEY was found, return
the corresponding data and t, otherwise return DEFAULT and nil."
(cond (node (setf (node-data node) data))
(t (fixup-insert tree stack sp (make-tree-node key data)) data))))
+(export 'updateaa)
(defun updateaa (tree key func)
"Search TREE for an item with the given KEY. If it was found, call FUNC
with arguments of the node's data and t, and store its result as the
(fixup-insert tree stack sp (make-tree-node key data))
data)))))
+(export 'remaa)
(defun remaa (tree key)
"Deletes the node with the given KEY from an Andersson TREE. Returns t if
the node was found and deleted, or nil if it wasn't there to begin with."
;; Store the new root.
(setf (tree-root tree) node)))))
+(export 'aa-tree-iterator)
(defun aa-tree-iterator (tree)
"Returns a tree iterator function for TREE. The function returns three
values. For each node in the tree, it returns t, the key and the value;
(pushleft (node-right node))
(values t (node-key node) (node-data node)))))))))))
+(export 'mapaa)
(defun mapaa (func tree)
"Apply FUNC to each key and value in the TREE."
(labels ((walk (node)
(walk (tree-root tree))
nil))
+(export 'doaa)
(defmacro doaa ((key value tree &optional result) &body body)
"Iterate over the items of TREE; for each one, bind KEY to its key and
VALUE to the associated data, and evaluate BODY, which is an implicit
;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Anaphoric extensions
;;;
;;; (c) 2005 Straylight/Edgeware
;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Collecting things into lists
;;;
;;; (c) 2005 Straylight/Edgeware
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(defpackage #:collect
- (:use #:common-lisp #:mdw.base)
- (:export #:make-collector #:collected
- #:collecting #:with-collection
- #:collect #:collect-tail
- #:collect-append #:collect-nconc))
+ (:use #:common-lisp #:mdw.base))
(in-package collect)
(eval-when (:compile-toplevel :load-toplevel)
(defvar *collecting-anon-list-name* (gensym)
"The default name for anonymous `collecting' lists."))
+(export 'make-collector)
(defun make-collector (&optional list)
"Return a new collector object whose initial contents is LIST. Note that
LIST will be destroyed if anything else is collected."
(let ((head (cons nil list)))
(setf (car head) (if list (last list) head))))
+(export 'collected)
(defmacro collected (&optional (name *collecting-anon-list-name*))
"Return the current list collected into the collector NAME (or
*collecting-anon-list-name* by default)."
`(the list (cdr ,name)))
+(export 'collecting)
(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
+ 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*)))
,@body
(values ,@(mapcar (lambda (v) `(collected ,v)) vars))))
+(export 'with-collection)
(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."
`(multiple-value-bind
- ,(listify vars)
+ ,(listify vars)
(collecting ,vars ,collection)
,@body))
+(export 'collect)
(defmacro collect (x &optional (name *collecting-anon-list-name*))
"Add item X to the `collecting' list NAME (or *collecting-anon-list-name*
by default)."
(setf (cdar ,name) ,new)
(setf (car ,name) ,new))))
+(export 'collect-tail)
(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
(setf (cdar ,name) ,x)
(setf (car ,name) nil)))
+(export 'collect-append)
(defmacro collect-append (list &optional (name *collecting-anon-list-name*))
"Append LIST to the tail of `collecting' list NAME. This obviously
involves copying LIST."
`(dolist (,item ,list)
(collect ,item ,name))))
+(export 'collect-nconc)
(defmacro collect-nconc (list &optional (name *collecting-anon-list-name*))
"Attach LIST to the tail of `collecting' list NAME. This will involve
destroying LIST if anything else gets collected afterwards."
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(defpackage #:dep
- (:use #:common-lisp #:queue #:weak)
- (:export #:dep #:depp #:make-dep #:dep-goodp #:dep-name
- #:with-deps-frozen
- #:install-dep-syntax
- #:dep-value #:dep-make-bad #:dep-bad #:dep-try
- #:dep-add-listener))
+ (:use #:common-lisp #:queue #:weak))
(in-package #:dep)
;;;--------------------------------------------------------------------------
;;;--------------------------------------------------------------------------
;;; Data structures.
+(export '(dep depp dep-name))
(defstruct (dep (:predicate depp)
(:constructor %make-dep))
"There are two kinds of `dep', though we use the same object type for both.
value of a bad dep results in a throw of `bad-dep'. Badness propagates
automatically during recomputation phases."
(%value .bad. :type t)
- (name nil :type t)
- (value-function nil :type (or function null))
- (value-predicate #'eql :type function)
+ (name nil :type t :read-only t)
+ (value-function nil :type (or function null) :read-only t)
+ (value-predicate #'eql :type function :read-only t)
(%flags 0 :type (unsigned-byte 8))
(generation *generation* :type list)
(listeners nil :type list)
(pushnew dep (dep-dependencies *evaluating-dep*)))
(force-dep-value dep))
+(export 'dep-value)
(declaim (inline dep-value))
(defun dep-value (dep)
"Retrieve the current value from DEP."
(throw 'dep-bad .bad.)
value)))
+(export 'dep-goodp)
(defun dep-goodp (dep)
"Answer whether DEP is good."
(when (eq *state* :recomputing)
(force-dep-value dep))
(not (eq (dep-%value dep) .bad.)))
+(export 'dep-try)
(defmacro dep-try (expr &body body)
"Evaluate EXPR. If it throws DEP-BAD then evaluate BODY instead."
(let ((block-name (gensym "TRY")))
(return-from ,block-name ,expr))
,@body)))
+(export 'dep-bad)
(defun dep-bad ()
"Call from a value-function: indicates that the dep should marked as bad."
(throw 'dep-bad nil))
(return))
(funcall (dequeue *delayed-operations*))))))))
+(export 'with-deps-frozen)
(defmacro with-deps-frozen ((&key delay) &body body)
"Evaluate BODY in the :FROZEN state.
(propagate-to-dependents dep)))
value)
+(export 'dep-make-bad)
(defun dep-make-bad (dep)
"Mark DEP as being bad."
(setf (dep-value dep) .bad.))
+(export 'dep-add-listener)
(defun dep-add-listener (dep func)
"Add a listener function FUNC to the DEP. The FUNC is called each time the
DEP's value (or good/bad state) changes. It is called with no arguments,
and its return value is ignored."
(push func (dep-listeners dep)))
+(export 'make-dep)
(defun make-dep (&rest args)
"Create a new DEP object. There are two basic argument forms:
(enqueue dep *pending-deps*)))
dep))))
+(export 'install-dep-syntax)
(defun install-dep-syntax (&optional (readtable *readtable*))
"Installs into the given READTABLE some syntactic shortcuts:
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(defpackage #:mdw.factorial
- (:use #:common-lisp)
- (:export #:factorial))
+ (:use #:common-lisp))
(in-package #:mdw.factorial)
+(export 'factorial)
(defun factorial (n)
- "Compute a factorial. This is a little bit optimized: we try to multiply
- values which are similar in size."
+ "Compute a factorial."
+
+ ;; This is a little bit optimized: we try to multiply values which are
+ ;; similar in size.
(when (minusp n)
(error "negative factorial argument ~A" n))
- (let ((stack nil))
- (do ((i 2 (1+ i)))
- ((> i n))
- (let ((f i))
- (loop
- (unless stack (return))
- (let ((top (car stack)))
- (when (< f top) (return))
- (setf f (* f top))
- (pop stack)))
- (push f stack)))
- (do ((stack stack (cdr stack))
- (a 1 (* a (car stack))))
- ((null stack) a))))
+ (do ((i 2 (1+ i))
+ (stack nil (do ((s stack (cdr s))
+ (f i (* f (car s))))
+ ((or (null s) (< f (car s)))
+ (cons f s)))))
+ ((> i n)
+ (do ((s stack (cdr s))
+ (a 1 (* a (car s))))
+ ((null s) a)))))
;;;----- That's all, folks --------------------------------------------------
;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Heap data structure; useful for priority queues and suchlike
;;;
;;; (c) 2006 Straylight/Edgeware
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(defpackage #:heap
- (:use #:common-lisp)
- (:export #:make-heap #:heap-count #:heap-empty-p
- #:heap-insert #:heap-head #:heap-remove
- #:heap-sort))
+ (:use #:common-lisp))
(in-package #:heap)
;;;--------------------------------------------------------------------------
;;;--------------------------------------------------------------------------
;;; High-level heap things
+(export '(heap heapp))
(defstruct (heap (:predicate heapp) (:constructor %make-heap))
"Data structure for a heap."
(v (make-array 16) :type vector)
(n 0 :type index)
- (key #'identity :type function)
- (compare #'<= :type function))
+ (key #'identity :type function :read-only t)
+ (compare #'<= :type function :read-only t))
+(export 'make-heap)
(defun make-heap
(&key (compare #'<=) (key #'identity)
(type 't) (init-size 16) (contents nil contentsp))
:initial-value 0))
(%make-heap :compare compare :key key :n n :v v))))
+(export 'heap-count)
(defun heap-count (heap)
"Return the number of elements in HEAP."
(declare (type heap heap))
(heap-n heap))
+(export 'heap-empty-p)
(defun heap-empty-p (heap)
"True if HEAP is empty."
(declare (type heap heap))
(zerop (heap-count heap)))
+(export 'heap-insert)
(defun heap-insert (heap item)
"Insert ITEM into the HEAP."
(declare (type heap heap))
(upheap v (heap-key heap) (heap-compare heap) n item)
(setf (heap-n heap) (1+ n))))
+(export 'heap-head)
(defun heap-head (heap)
"Peep at the head item on HEAP."
(declare (type heap heap))
(assert (not (heap-empty-p heap)))
(aref (heap-v heap) 0))
+(export 'heap-remove)
(defun heap-remove (heap)
"Remove the head item from HEAP and return it."
(declare (type heap heap))
(setf (heap-n heap) n)
(downheap v (heap-key heap) (heap-compare heap) n (aref v n)))))
+(export 'heap-sort)
(defun heap-sort (items compare &key (key #'identity))
"Return the ITEMS, least-first, as sorted by the ordering COMPARE."
(let ((heap (make-heap :compare compare :contents items :key key)))
#:bind))
(defpackage #:infix
- (:use #:common-lisp #:infix-keywords)
- (:export #:operator #:operatorp
- #:*token* #:get-token #:*get-token*
- #:pushval #:popval #:flushops #:pushop
- #:infix-done #:parse-infix
- #:defopfunc #:definfix #:defprefix #:defpostfix
- #:infix #:prefix #:postfix #:operand
- #:delim #:errfunc
- #:binop-apply #:binop-apply-append
- #:unop-apply #:unop-apply-toggle
- #:strip-progn
- #:read-infix #:install-infix-reader))
+ (:use #:common-lisp #:infix-keywords))
(in-package #:infix)
;;;--------------------------------------------------------------------------
;;; Data structures.
+(export '(operator operatorp
+ op-name op-lprec op-rprec op-func))
(defstruct (operator (:predicate operatorp)
(:conc-name op-))
"An operator object. The name serves mainly for documentation. The left
/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))
- (func (lambda () nil) :type #-ecl (function () t) #+ecl function))
+ (name nil :type symbol :read-only t)
+ (lprec nil :type (or fixnum null) :read-only t)
+ (rprec nil :type (or fixnum null) :read-only t)
+ (func (lambda () nil)
+ :type #-ecl (function () t) #+ecl function
+ :read-only t))
;;;--------------------------------------------------------------------------
;;; Global parser state.
"Value stack. Contains (partially constructed) Lisp forms.")
(defvar *opstk* nil
"Operator stack. Contains operator objects.")
+(export '*token*)
(defvar *token* nil
"The current token. Could be any Lisp object.")
(defvar *paren-depth* 0
((#\newline) (go top))
(t (go comment)))))))
+(export '*get-token*)
(defvar *get-token* #'default-get-token
"The current tokenizing function.")
+(export 'get-token)
(defun get-token ()
"Read a token, and store it in *token*. Indirects via *get-token*."
(funcall *get-token*))
;;;--------------------------------------------------------------------------
;;; Stack manipulation.
+(export 'pushval)
(defun pushval (val)
"Push VAL onto the value stack."
(push val *valstk*))
+(export 'popval)
(defun popval ()
"Pop a value off the value stack and return it."
(pop *valstk*))
+(export 'flushops)
(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
(pop *opstk*)
(funcall (op-func head)))))
+(export 'pushop)
(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
;;;--------------------------------------------------------------------------
;;; The main parser.
+(export 'infix-done)
(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."
(throw 'infix-done nil))
+(export 'parse-infix)
(defun parse-infix (&optional minprec)
"Parses an infix expression and return the resulting Lisp form. This is
the heart of the whole thing.
;;;--------------------------------------------------------------------------
;;; Machinery for defining operators.
+(export 'defopfunc)
(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
(lambda () ,@body))
',op))
+(export 'definfix)
(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
(postfix :lprec)) ,prec
:func (lambda () ,@body)))
',op)))
+
+(export 'defprefix)
(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."
(do-defunary 'prefix op prec body))
+
+(export 'defpostfix)
(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
;;;--------------------------------------------------------------------------
;;; Infrastructure for operator definitions.
+(export 'delim)
(defun delim (delim &optional (requiredp t))
"Parse DELIM, and read the next token. Returns t if the DELIM was found,
or nil if not (and REQUIREDP was nil)."
(requiredp (error "expected `~(~A~)'; found ~S" delim *token*))
(t nil)))
+(export 'errfunc)
(defun errfunc (&rest args)
"Returns a function which reports an error. Useful when constructing
operators by hand."
(lambda () (apply #'error args)))
+(export 'binop-apply)
(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)."
(let ((y (popval)) (x (popval)))
(pushval (list name x y))))
+(export 'binop-apply-append)
(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
(append x (list y))
(list name x y)))))
+(export 'unop-apply)
(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)."
(pushval (list name (popval))))
+(export 'unop-apply-toggle)
(defun unop-apply-toggle (name)
"As for `unop-apply', but if the top item has the form (NAME X) already,
then push just X."
(cadr x)
(list name x)))))
+(export 'strip-progn)
(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,
(cdr form)
(list form)))
+(export 'parse-expr-list)
(defun parse-expr-list ()
"Parse a list of expressions separated by commas."
(let ((stuff nil))
(return)))
(nreverse stuff)))
+(export 'parse-ident-list)
(defun parse-ident-list ()
"Parse a list of symbols separated by commas."
(let ((stuff nil))
;;;--------------------------------------------------------------------------
;;; Parentheses, for grouping and function-calls.
+(export 'push-paren)
(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
(incf *paren-depth*)
(get-token))
+(export 'pop-paren)
(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
;;;--------------------------------------------------------------------------
;;; User-interface stuff.
+(export 'read-infix)
(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
(unless (eq *token* delim)
(error "expected ~S; found ~S" delim *token*)))))
+(export 'install-infix-reader)
(defun install-infix-reader
(&optional (start #\{) (end #\}) &key dispatch (readtable *readtable*))
"Installs a macro character `{ INFIX... }' for translating infix notation
(func nontermp)
(get-macro-character end readtable)
(and func (not nontermp))))
- (set-macro-character end (lambda (noise)
+ (set-macro-character end (lambda (&rest noise)
(declare (ignore noise))
(error "Unexpected `~C'." end))
nil readtable)))))
;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Basic definitions
;;;
;;; (c) 2005 Mark Wooding
;;;--------------------------------------------------------------------------
;;; Generating symbols.
+(export 'symbolicate)
+(defun symbolicate (&rest names)
+ "Return a symbol constructued by concatenating the NAMES.
+
+ The NAMES are coerced to strings, using the `string' function, so they may
+ be strings, characters, or symbols. The resulting symbol is interned in
+ the current `*package*'."
+ (intern (apply #'concatenate 'string (mapcar #'string names))))
+
(export 'with-gensyms)
(defmacro with-gensyms (syms &body body)
"Everyone's favourite macro helper."
;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Useful bits of MOP hacking
;;;
;;; (c) 2006 Straylight/Edgeware
(:use #:common-lisp #:mdw.base
#+(or cmu clisp) #:mop
#+sbcl #:sb-mop
- #+ecl #:clos)
- (:export #:copy-instance #:copy-instance-using-class
- #:with-slot-variables
- #:compatible-class
- #:initargs-for-effective-slot #:make-effective-slot
- #:filtered-slot-class-mixin
- #:filtered-direct-slot-definition
- #:filtered-effective-slot-definition
- #:predicate-class-mixin
- #:abstract-class-mixin #:instantiate-abstract-class
- #:singleton-class-mixin
- #:mdw-class #:abstract-class #:singleton-class
- #:print-object-with-slots))
+ #+ecl #:clos))
(in-package #:mdw.mop)
;;;--------------------------------------------------------------------------
;;; Copying instances.
+(export 'copy-instance-using-class)
(defgeneric copy-instance-using-class (class object &rest initargs)
(:documentation
"Does the donkey-work behind copy-instance."))
(apply #'shared-initialize new nil initargs)
new))
+(export 'copy-instance)
(defun copy-instance (object &rest initargs)
"Make a copy of OBJECT, modifying it by setting slots as requested by
INITARGS."
;;;--------------------------------------------------------------------------
;;; Handy macros.
+(export 'with-slot-variables)
(defmacro with-slot-variables (slots instance &body body)
"A copy-out-and-write-back variant of with-slots.
;;;--------------------------------------------------------------------------
;;; Basic stuff.
+(export 'compatible-class)
(defclass compatible-class (standard-class)
()
(:documentation
;;;--------------------------------------------------------------------------
;;; Utilities for messing with slot options.
+(export 'initargs-for-effective-slot)
(defgeneric initargs-for-effective-slot (class direct-slots)
(:documentation
"Missing functionality from the MOP: given a class and its direct slots
direct-slots)))
:allocation (slot-definition-allocation (car direct-slots)))))
+(export 'make-effective-slot)
(defun make-effective-slot (class initargs)
- "Construct an effectie slot definition for a slot on the class, given the
+ "Construct an effective slot definition for a slot on the class, given the
required arguments."
(apply #'make-instance
(apply #'effective-slot-definition-class class initargs)
;;;--------------------------------------------------------------------------
;;; Filterered slots.
+(export 'filtered-slot-class-mixin)
(defclass filtered-slot-class-mixin (compatible-class)
()
(:documentation
(defgeneric slot-definition-filter (slot)
(:method ((slot slot-definition)) nil))
+(export 'filtered-direct-slot-definition)
(defclass filtered-direct-slot-definition
(standard-direct-slot-definition)
((filter :initarg :filter :reader slot-definition-filter)))
+(export 'filtered-effective-slot-definition)
(defclass filtered-effective-slot-definition
(standard-effective-slot-definition)
((filter :initarg :filter :accessor slot-definition-filter)))
;;;--------------------------------------------------------------------------
;;; Predicates.
+(export 'predicate-class-mixin)
(defclass predicate-class-mixin (compatible-class)
((predicates :type list :initarg :predicate :initform nil
:documentation "Predicate generic function to create."))
;;;--------------------------------------------------------------------------
;;; Abstract classes.
+(export 'abstract-class-mixin)
(defclass abstract-class-mixin (compatible-class)
()
(:documentation
"Confusingly enough, a concrete metaclass for abstract classes. This
class has a `make-instance' implementation which signals an error."))
+(export '(instantiate-abstract-class instantiate-abstract-class-class))
(define-condition instantiate-abstract-class (error)
((class :reader instantiate-abstract-class-class :initarg :class
:documentation "The class someone attempted to instantiate."))
;;;--------------------------------------------------------------------------
;;; Singleton classes.
+(export 'singleton-class-mixin)
(defclass singleton-class-mixin (compatible-class)
((instance :initform nil :type (or null standard-object)))
(:documentation
;;;--------------------------------------------------------------------------
;;; Useful classes.
+(export 'mdw-class)
(defclass mdw-class (filtered-slot-class-mixin
predicate-class-mixin
compatible-class)
metaclass for all your classes if you don't use any of its fancy
features."))
+(export 'abstract-class)
(defclass abstract-class (mdw-class abstract-class-mixin) ())
+
+(export 'singleton-class)
(defclass singleton-class (mdw-class singleton-class-mixin) ())
;;;--------------------------------------------------------------------------
;;; Printing things.
+(export 'print-object-with-slots)
(defun print-object-with-slots (obj stream)
"Prints objects in a pleasant way. Not too clever about circularity."
(let ((class (class-of obj))
;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Option parser, standard issue
;;;
;;; (c) 2005 Straylight/Edgeware
;;; Packages.
(defpackage #:optparse
- (:use #:common-lisp #:mdw.base #:mdw.sys-base)
- (:export #:exit #:*program-name* #:*command-line*
- #:moan #:die
- #:option #:optionp #:make-option
- #:opt-short-name #:opt-long-name #:opt-tag #:opt-negated-tag
- #:opt-arg-name #:opt-arg-optional-p #:opt-documentation
- #:option-parser #:make-option-parser #:option-parser-p
- #:op-options #:op-non-option #:op-long-only-p #:op-numeric-p
- #:op-negated-numeric-p #:op-negated-p
- #:option-parse-error
- #:option-parse-remainder #:option-parse-next #:option-parse-try
- #:with-unix-error-reporting #:option-parse-return
- #:defopthandler #:invoke-option-handler
- #:set #:clear #:inc #:dec #:read #:int #:string
- #:keyword #:list
- #:parse-option-form #:options
- #:simple-usage #:show-usage #:show-version #:show-help
- #:sanity-check-option-list
- #:*help* #:*version* #:*usage* #:*options*
- #:do-options #:help-options
- #:define-program #:do-usage #:die-usage))
+ (:use #:common-lisp #:mdw.base #:mdw.sys-base))
(in-package #:optparse)
+;; Re-export symbols from sys-base.
+(export '(exit *program-name* *command-line*))
+
;;;--------------------------------------------------------------------------
;;; Standard error-reporting functions.
+(export 'moan)
(defun moan (msg &rest args)
"Report an error message in the usual way."
(format *error-output* "~&~A: ~?~%" *program-name* msg args))
+(export 'die)
(defun die (&rest args)
"Report an error message and exit."
(apply #'moan args)
;;;--------------------------------------------------------------------------
;;; The main option parser.
+(export '*options*)
(defvar *options* nil)
+(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-)
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)))
-
+ (long-name nil :type (or null string) :read-only t)
+ (tag nil :type t :read-only t)
+ (negated-tag nil :type t :read-only t)
+ (short-name nil :type (or null character) :read-only t)
+ (arg-name nil :type (or null string) :read-only t)
+ (arg-optional-p nil :type t :read-only t)
+ (documentation nil :type (or null string)) :read-only t)
+
+(export '(option-parser option-parser-p make-option-parser
+ op-options op-non-option op-long-only-p
+ op-numeric-p op-negated-numeric-p op-negated-p))
(defstruct (option-parser
(:conc-name op-)
(:constructor make-option-parser
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)))
+ (options nil :type list :read-only t)
+ (non-option :skip :type (or function (member :skip :stop :return))
+ :read-only t)
(next nil :type list)
(short-opt nil :type (or null string))
(short-opt-index 0 :type fixnum)
(short-opt-neg-p nil :type t)
- (long-only-p nil :type t)
- (numeric-p nil :type t)
- (negated-numeric-p nil :type t)
- (negated-p nil :type t))
+ (long-only-p nil :type t :read-only t)
+ (numeric-p nil :type t :read-only t)
+ (negated-numeric-p nil :type t :read-only t)
+ (negated-p nil :type t) :read-only t)
+(export 'option-parse-error)
(define-condition option-parse-error (error simple-condition)
()
(:documentation
:format-control msg
:format-arguments args)))
+(export 'option-parse-remainder)
(defun option-parse-remainder (op)
"Returns the unparsed remainder of the command line."
(cdr (op-args op)))
+(export 'option-parse-return)
(defun option-parse-return (tag &optional argument)
"Should be called from an option handler: forces a return from the
immediately enclosing `option-parse-next' with the given TAG and
ARGUMENT."
(throw 'option-parse-return (values tag argument)))
+(export 'option-parse-next)
(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
(op-short-opt-index op) 1
(op-short-opt-neg-p op) negp))))))))))))))
+(export 'option-parse-try)
(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
(setf ,retcode nil)))
,retcode)))
+(export 'with-unix-error-reporting)
(defmacro with-unix-error-reporting ((&key) &body body)
"Evaluate BODY with errors reported in the standard Unix fashion."
(with-gensyms (cond)
;;;--------------------------------------------------------------------------
;;; Standard option handlers.
+(export 'defopthandler)
(defmacro defopthandler (name (var &optional (arg (gensym)))
(&rest args)
&body body)
(t
(get-radix start radix +1)))))
+(export 'invoke-option-handler)
(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."
;;;--------------------------------------------------------------------------
;;; Built-in option handlers.
+(export 'set)
(defopthandler set (var) (&optional (value t))
"Sets VAR to VALUE; defaults to t."
(setf var value))
+(export 'clear)
(defopthandler clear (var) (&optional (value nil))
"Sets VAR to VALUE; defaults to nil."
(setf var value))
+(export 'inc)
(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."
(when (>= var max)
(setf var max)))
+(export 'dec)
(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."
(when (<= var min)
(setf var min)))
+(export 'read)
(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 (cond)
(option-parse-error (format nil "~A" cond)))))
+(export 'int)
(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
arg min max))
(setf var v)))
+(export 'string)
(defopthandler string (var arg) ()
"Stores ARG in VAR, just as it is."
(setf var arg))
+(export 'keyword)
(defopthandler keyword (var arg) (&optional (valid t))
"Converts ARG into a keyword. If VALID is t, then any ARG string is
acceptable: the argument is uppercased and interned in the keyword
"~{~%~8T~(~A~)~}")
arg matches)))))))
+(export 'list)
(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'."
;;;--------------------------------------------------------------------------
;;; Option descriptions.
+(export 'defoptmacro)
(defmacro defoptmacro (name args &body body)
"Defines an option macro NAME. Option macros should produce a list of
expressions producing one option structure each."
(setf (get ',name 'optmacro) (lambda ,args ,@body))
',name))
+(export 'parse-option-form)
(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."
,@(and negated-tag `(:negated-tag ,negated-tag))
,@(and doc `(:documentation ,doc))))))))
+(export 'options)
(defmacro options (&rest optlist)
"More convenient way of initializing options. The OPTLIST is a list of
OPTFORMS. Each OPTFORM is one of the following:
(#\] (when (plusp nest) (decf nest))))))
(incf i))))))
+(export 'simple-usage)
(defun simple-usage (opts &optional mandatory-args)
"Build a simple usage list from a list of options, and (optionally)
mandatory argument names."
:key #'opt-long-name)))
(listify mandatory-args)))))
+(export 'show-usage)
(defun show-usage (prog usage &optional (stream *standard-output*))
"Basic usage-showing function. PROG is the program name, probably from
*command-line*. USAGE is a list of possible usages of the program, each
(print-text doc stream))
(terpri stream)))))))
+(export 'show-help)
(defun show-help (prog ver usage opts &optional (stream *standard-output*))
"Basic help-showing function. PROG is the program name, probably from
*command-line*. VER is the program's version number. USAGE is a list of
(terpri stream)
(show-options-help opts stream))
+(export 'sanity-check-options-list)
(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.
;;;--------------------------------------------------------------------------
;;; Full program descriptions.
+(export '(*help* *version* *usage))
(defvar *help* nil)
(defvar *version* "<unreleased>")
(defvar *usage* nil)
+(export 'do-usage)
(defun do-usage (&optional (stream *standard-output*))
(show-usage *program-name* *usage* stream))
+(export 'die-usage)
(defun die-usage ()
(do-usage *error-output*)
(exit 1))
(do-usage)
(exit 0))
+(export 'help-options)
(defoptmacro help-options (&key (short-help #\h)
(short-version #\v)
(short-usage #\u))
(,@(shortform short-usage) "usage" #'opt-usage
("Show a very brief usage summary for ~A." *program-name*))))))
+(export 'define-program)
(defun define-program (&key
(program-name nil progp)
(help nil helpp)
(usagep (setf *usage* (simple-usage *options* usage)))
(fullp (setf *usage* full-usage))))
+(export 'do-options)
(defmacro do-options ((&key (parser '(make-option-parser)))
&body clauses)
"Handy all-in-one options parser macro. PARSER defaults to a new options
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(defpackage #:queue
- (:use #:common-lisp)
- (:export #:make-queue #:queue-emptyp #:enqueue #:pushqueue #:dequeue))
+ (:use #:common-lisp))
(in-package #:queue)
+(export 'make-queue)
(defun make-queue ()
"Make a new queue object."
;; A queue is just a cons cell. The cdr is the head of the list of items
(let ((q (cons nil nil)))
(setf (car q) q)))
+(export 'queue-emptyp)
(defun queue-emptyp (q)
"Answer whether the queue Q is empty."
(null (cdr q)))
+(export 'enqueue)
(defun enqueue (x q)
"Enqueue the object X into the queue Q."
(let ((c (cons x nil)))
(setf (cdr (car q)) c
(car q) c)))
+(export 'pushqueue)
(defun pushqueue (x q)
"Push the object X onto the front of the queue Q."
(let* ((first (cdr q))
(setf (cdr q) new)
(unless first (setf (car q) new))))
+(export 'dequeue)
(defun dequeue (q)
"Remove and return the object at the head of the queue Q."
(if (queue-emptyp q)
;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Safely modify collections of files
;;;
;;; (c) 2005 Straylight/Edgeware
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(defpackage #:safely
- (:use #:common-lisp #:mdw.base)
- (:export #:safely #:safely-close #:safely-delete-file
- #:safely-open-output-stream #:safely-bail #:safely-commit
- #:safely-writing))
+ (:use #:common-lisp #:mdw.base))
(in-package #:safely)
#+(or cmu sbcl)
(declare (ignore as-file))
(unix-namestring pathname nil)))
-(defstruct (safely (:predicate safelyp))
+(export '(safely safelyp make-safely))
+(defstruct (safely (:predicate safelyp) (:constructor make-safely ()))
"Stores information about how to commit or undo safe writes."
(streams nil)
(trail nil))
+(export 'safely-close)
(defun safely-close (safe stream)
"Make sure that STREAM is closed when SAFE is finished."
(push stream (safely-streams safe)))
+(export 'safely-delete-file)
(defun safely-delete-file (safe file)
"Delete FILE when SAFE is committed."
(push `(:delete ,file) (safely-trail safe)))
(when ret
(return (values new ret)))))))
+(export 'safely-open-output-stream)
(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."
(setf (safely-streams safe) nil)
(setf (safely-trail safe) nil))
+(export 'safely-bail)
(defun safely-bail (safe)
"Abort the operations in SAFE, unwinding all the things that have been
done. Streams are closed, new files are removed."
(return copy))))))
(close output)))))
+(export 'safely-commit)
(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
(safely-unwind cleanup)
(safely-reset safe))))
+;; The symbol `safely' is already exported.
(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."
(when ,safe
(safely-bail ,safe)))))
+(export 'safely-writing)
(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."
;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; String utilities of various kinds
;;;
;;; (c) 2005 Straylight/Edgeware
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(defpackage #:mdw.str
- (:use #:common-lisp #:mdw.base)
- (:export #:join-strings #:str-next-word #:str-split-words
- #:str-beginsp #:str-endsp))
+ (:use #:common-lisp #:mdw.base))
(in-package #:mdw.str)
+(export 'join-strings)
(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
(return))
(princ del s)))))
+(export 'str-next-word)
(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.
:initial-contents w)
i)))
+(export 'str-split-words)
(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;
(incf n)))
(nreverse l)))
+(export 'str-beginsp)
(declaim (inline str-beginsp))
(defun str-beginsp (string prefix &key (start1 0) end1 (start2 0) end2)
"Returns true if STRING (or the appropriate substring of it) begins with
:start1 start1 :end1 (+ start1 prelen)
:start2 start2 :end2 end2))))
+(export 'str-endsp)
(declaim (inline str-endsp))
(defun str-endsp (string suffix &key (start1 0) end1 (start2 0) end2)
"Returns true if STRING (or the appropriate substring of it) ends with
;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Basic system-specific stuff
;;;
;;; (c) 2005 Mark Wooding
(defun exit (&optional (code 0))
"Polite way to end a program."
#+(or cmu ecl) (ext:quit code)
- #+sbcl (sb-ext:quit :unix-status code)
+ #+sbcl (sb-ext:exit :code code)
#-(or cmu ecl sbcl)
(progn
(unless (zerop code)
after fork, for example, to avoid flushing buffers."
(declare (type (unsigned-byte 32) code))
#+cmu (unix::void-syscall ("_exit" c-call:int) code)
- #+sbcl (sb-ext:quit :unix-status code :recklessly-p t)
+ #+sbcl (sb-ext:exit :code code :abort t)
#+(or clisp ecl) (ext:quit code))
;;;----- That's all, folks --------------------------------------------------
;;; -*-lisp-*-
;;;
-;;; $Id$
-;;;
;;; Unix system call stuff
;;;
;;; (c) 2005 Straylight/Edgeware
;;; Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
(defpackage #:mdw.unix
- (:use #:common-lisp #:mdw.base #:collect)
- (:export #:unix-error #:errno-value #:with-errno-handlers
- #:syscall #:syscall*
- #:stat #:sys-stat
- #:sys-open #:sys-close #:sys-read #:sys-write
- #:sys-chown #:sys-fchown #:sys-chmod #:sys-fchmod
- #:sys-utimes #:sys-unlink #:sys-rename
- #:sys-gettimeofday #:sys-gethostname
- #:with-unix-open #:copy-file))
+ (:use #:common-lisp #:mdw.base #:collect))
(in-package #:mdw.unix)
(defmacro with-buffer ((var len) &body body)
,@body)
(when ,var (system:deallocate-system-memory ,var ,lenvar))))))
+(export '(unix-error unix-error-func unix-error-args unix-error-errno))
(define-condition unix-error (error)
((func :initform 'unknown :initarg :func :reader unix-error-func)
(args :initform nil :initarg :args :reader unix-error-args)
(unix-error-errno c))))
(:documentation "Reports an error from a Unix system call."))
+(export 'errno-value)
(compile-time-defun errno-value (err)
- "Returns the numeric value corresponding to an errno name."
- (etypecase err
- (integer err)
- (symbol (symbol-value (intern (symbol-name err) :unix)))))
+ "Returns the numeric value corresponding to an errno name."
+ (etypecase err
+ (integer err)
+ (symbol (symbol-value (intern (symbol-name err) :unix)))))
+(export 'with-errno-handlers)
(defmacro with-errno-handlers ((&key cond
(errno (gensym))
errstring)
clauses
labels)))))))))
+(export 'syscall*)
(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."
:errno (car stuff)))
(apply #'values rc stuff))
(apply func args)))
+
+(export 'syscall)
(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))
+(export '(stat statp))
(macrolet ((doit (doc slots)
- `(defstruct (stat (:predicate statp)
- (:conc-name st-)
- (:constructor %make-stat-boa ,slots))
- ,doc
- ,@slots)))
+ `(progn
+ (export ',(mapcar (lambda (slot) (symbolicate 'st- slot))
+ slots))
+ (defstruct (stat (:predicate statp)
+ (:conc-name st-)
+ (:constructor %make-stat-boa ,slots))
+ ,doc
+ ,@slots))))
(doit
- "Structure representing all the useful information `stat' returns about a
- file."
- (dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks)))
+ "Structure representing all the useful information `stat' returns about a
+ file."
+ (dev ino mode nlink uid gid rdev size atime mtime ctime blksize blocks)))
+
+(export 'sys-stat)
(defun sys-stat (file)
"Return information about FILE in a structure rather than as inconvenient
multiple values."
(unix:unix-stat file)))
(defmacro defsyscall (name)
- (let ((sysname (intern (format nil "SYS-~:@(~A~)" name)))
- (unixname (intern (format nil "UNIX-~:@(~A~)" name) :unix)))
- `(defun ,sysname (&rest args)
- (apply #'syscall* ',sysname #',unixname args))))
+ (let ((sysname (symbolicate 'sys- name))
+ (unixname (let ((*package* (find-package :unix)))
+ (symbolicate 'unix- name))))
+ `(progn
+ (export ',sysname)
+ (defun ,sysname (&rest args)
+ (apply #'syscall* ',sysname #',unixname args)))))
(macrolet ((defsys (&rest names)
`(progn ,@(mapcar (lambda (name)
unlink rename
gethostname gettimeofday))
+(export 'with-unix-open)
(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
,@body)
(when ,fd (sys-close ,fd)))))
+(export 'copy-file)
(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
~mdw / lisp / commitdiff