;;;----- 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
(,bodyfunc))))))))
(export 'parse-body)
-(defun parse-body (body)
+(defun parse-body (body &key (docp t) (declp t))
"Parse the BODY into a docstring, declarations and the body forms.
These are returned as three lists, so that they can be spliced into a
macro expansion easily. The declarations are consolidated into a single
- `declare' form."
+ `declare' form. If DOCP is nil then a docstring is not permitted; if
+ DECLP is nil, then declarations are not permitted."
(let ((decls nil)
(doc nil))
(loop
(cond ((null body) (return))
- ((and (consp (car body)) (eq (caar body) 'declare))
+ ((and declp (consp (car body)) (eq (caar body) 'declare))
(setf decls (append decls (cdr (pop body)))))
- ((and (stringp (car body)) (not doc) (cdr body))
+ ((and docp (stringp (car body)) (not doc) (cdr body))
(setf doc (pop body)))
(t (return))))
(values (and doc (list doc))
(and decls (list (cons 'declare decls)))
body)))
+;;;--------------------------------------------------------------------------
+;;; 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))))
+
;;;--------------------------------------------------------------------------
;;; Anaphorics.
"If COND, evaluate BODY as a progn with `it' bound to the value of COND."
`(let ((it ,cond)) (when it ,@body)))
+(export 'aand)
+(defmacro aand (&rest forms)
+ "Like `and', but anaphoric.
+
+ Each FORM except the first is evaluated with `it' bound to the value of
+ the previous one. If there are no forms, then the result it `t'; if there
+ is exactly one, then wrapping it in `aand' is pointless."
+ (labels ((doit (first rest)
+ (if (null rest)
+ first
+ `(let ((it ,first))
+ (if it ,(doit (car rest) (cdr rest)) nil)))))
+ (if (null forms)
+ 't
+ (doit (car forms) (cdr forms)))))
+
(export 'acond)
(defmacro acond (&body clauses &environment env)
"Like COND, but with `it' bound to the value of the condition.
except where overridden by INITARGS."
(apply #'copy-instance-using-class (class-of object) object initargs))
+(export '(generic-function-methods method-specializers
+ eql-specializer eql-specializer-object))
+
;;;--------------------------------------------------------------------------
;;; List utilities.
(export 'mappend)
(defun mappend (function list &rest more-lists)
- "Like a nondestructive MAPCAN.
+ "Like a nondestructive `mapcan'.
Map FUNCTION over the the corresponding elements of LIST and MORE-LISTS,
and return the result of appending all of the resulting lists."
(reduce #'append (apply #'mapcar function list more-lists) :from-end t))
+(export 'distinguished-point-shortest-paths)
+(defun distinguished-point-shortest-paths (root neighbours-func)
+ "Moderately efficient shortest-paths-from-root computation.
+
+ The ROOT is a distinguished vertex in a graph. The NEIGHBOURS-FUNC
+ accepts a VERTEX as its only argument, and returns a list of conses (V .
+ C) for each of the VERTEX's neighbours, indicating that there is an edge
+ from VERTEX to V, with cost C.
+
+ The return value is a list of entries (COST . REV-PATH) for each vertex
+ reachable from the ROOT; the COST is the total cost of the shortest path,
+ and REV-PATH is the path from the ROOT, in reverse order -- so the first
+ element is the vertex itself and the last element is the ROOT.
+
+ The NEIGHBOURS-FUNC is called at most N times, and may take O(N) time to
+ produce its output list. The computation as a whole takes O(N^2) time,
+ where N is the number of vertices in the graph, assuming there is at most
+ one edge between any pair of vertices."
+
+ ;; This is a listish version of Dijkstra's shortest-path algorithm. It
+ ;; could be made more efficient by using a fancy priority queue rather than
+ ;; a linear search for finding the nearest live element (see below), but it
+ ;; still runs pretty well.
+
+ (let ((map (make-hash-table))
+ (dead nil)
+ (live (list (list 0 root))))
+ (setf (gethash root map) (cons :live (car live)))
+ (loop
+ ;; The dead list contains a record, in output format (COST . PATH), for
+ ;; each vertex whose shortest path has been finally decided. The live
+ ;; list contains a record for the vertices of current interest, also in
+ ;; output format; the COST for a live record shows the best cost for a
+ ;; path using only dead vertices.
+ ;;
+ ;; Each time through here, we pull an item off the live list and
+ ;; push it onto the dead list, so we do at most N iterations total.
+
+ ;; If there are no more live items, then we're done; the remaining
+ ;; vertices, if any, are unreachable from the ROOT.
+ (when (null live) (return))
+
+ ;; Find the closest live vertex to the root. The linear scan through
+ ;; the live list costs at most N time.
+ (let* ((best (reduce (lambda (x y) (if (< (car x) (car y)) x y)) live))
+ (best-cost (car best))
+ (best-path (cdr best))
+ (best-vertex (car best-path)))
+
+ ;; Remove the chosen vertex from the LIVE list, and add the
+ ;; appropriate record to the dead list. We must have the shortest
+ ;; path to this vertex now: we have the shortest path using currently
+ ;; dead vertices; any other path must use at least one live vertex,
+ ;; and, by construction, the path through any such vertex must be
+ ;; further than the path we already have.
+ ;;
+ ;; Removal from the live list uses a linear scan which costs N time.
+ (setf live (delete best live))
+ (push best dead)
+ (setf (car (gethash best-vertex map)) :dead)
+
+ ;; Work through the chosen vertex's neighbours, adding each of them
+ ;; to the live list if they're not already there. If a neighbour is
+ ;; already live, and we find a shorter path to it through our chosen
+ ;; vertex, then update the neighbour's record.
+ ;;
+ ;; The chosen vertex obviously has at most N neighbours. There's no
+ ;; more looping in here, so performance is as claimed.
+ (dolist (neigh (funcall neighbours-func best-vertex))
+ (let* ((neigh-vertex (car neigh))
+ (neigh-cost (+ best-cost (cdr neigh)))
+ (neigh-record (gethash neigh-vertex map)))
+ (cond ((null neigh-record)
+ ;; If the neighbour isn't known, then now's the time to
+ ;; make a fresh live record for it.
+ (let ((new-record (list* :live neigh-cost
+ neigh-vertex best-path)))
+ (push (cdr new-record) live)
+ (setf (gethash neigh-vertex map) new-record)))
+ ((and (eq (car neigh-record) :live)
+ (< neigh-cost (cadr neigh-record)))
+ ;; If the neighbour is live, and we've found a better path
+ ;; to it, then update its record.
+ (setf (cadr neigh-record) neigh-cost
+ (cdddr neigh-record) best-path)))))))
+ dead))
+
(export '(inconsistent-merge-error merge-error-candidates))
(define-condition inconsistent-merge-error (error)
((candidates :initarg :candidates
:reader merge-error-candidates))
(:documentation
- "Reports an inconsistency in the arguments passed to MERGE-LISTS.")
+ "Reports an inconsistency in the arguments passed to `merge-lists'.")
(:report (lambda (condition stream)
- (format stream "Merge inconsistency: failed to decide among ~A."
+ (format stream "Merge inconsistency: failed to decide between ~
+ ~{~#[~;~A~;~A and ~A~:;~
+ ~@{~A, ~#[~;and ~A~]~}~]~}"
(merge-error-candidates condition)))))
(export 'merge-lists)
-(defun merge-lists (lists &key pick (test #'eql))
+(defun merge-lists (lists &key pick (test #'eql) (present #'identity))
"Return a merge of the given LISTS.
- The resulting LIST contains the items of the given lists, with duplicates
+ The resulting list contains the items of the given LISTS, with duplicates
removed. The order of the resulting list is consistent with the orders of
the input LISTS in the sense that if A precedes B in some input list then
A will also precede B in the output list. If the lists aren't consistent
(e.g., some list contains A followed by B, and another contains B followed
- by A) then an error of type INCONSISTENT-MERGE-ERROR is signalled.
+ by A) then an error of type `inconsistent-merge-error' is signalled. The
+ offending items are filtered for presentation through the PRESENT function
+ before being attached to the condition, so as to produce a more useful
+ diagnostic message.
Item equality is determined by TEST.
If there is an ambiguity at any point -- i.e., a choice between two or
more possible next items to emit -- then PICK is called to arbitrate.
PICK is called with two arguments: the list of candidate next items, and
- the current output list. It should return one of the candidate items. If
- PICK is omitted then an arbitrary choice is made.
+ the current output list. It should return one of the candidate items.
+ The order of the candidates in the list given to the PICK function
+ reflects their order in the input LISTS: item A will precede item B in the
+ candidates list if and only if an occurrence of A appears in an earlier
+ input list than any occurrence of item B. (This completely determines the
+ order of the candidates: it is not possible that two candidates appear in
+ the same input list would resolve the ambiguity between them.) If PICK is
+ omitted then the item chosen is the one appearing in the earliest of the
+ input lists: i.e., effectively, the default PICK function is
+
+ (lambda (candidates output-so-far)
+ (declare (ignore output-so-far))
+ (car candidates))
The primary use of this function is in computing class precedence lists.
By building the input lists and selecting the PICK function appropriately,
a variety of different CPL algorithms can be implemented."
- (do* ((lb (make-list-builder)))
- ((null lists) (lbuild-list lb))
+ (do ((lb (make-list-builder)))
+ ((null lists) (lbuild-list lb))
;; The candidate items are the ones at the front of the input lists.
;; Gather them up, removing duplicates. If a candidate is somewhere in
;; one of the other lists other than at the front then we reject it. If
;; we've just rejected everything, then we can make no more progress and
;; the input lists were inconsistent.
- (let* ((candidates (delete-duplicates (mapcar #'car lists) :test test))
+ (let* ((candidates (delete-duplicates (mapcar #'car lists)
+ :test test :from-end t))
(leasts (remove-if (lambda (item)
(some (lambda (list)
(member item (cdr list) :test test))
candidates))
(winner (cond ((null leasts)
(error 'inconsistent-merge-error
- :candidates candidates))
+ :candidates (mapcar present candidates)))
((null (cdr leasts))
(car leasts))
(pick
cat-names cat-vars)
,@body))))
+(export 'partial-order-minima)
+(defun partial-order-minima (items order)
+ "Return a list of minimal items according to the non-strict partial ORDER.
+
+ The ORDER function describes the partial order: (funcall ORDER X Y) should
+ return true if X precedes or is equal to Y in the order."
+ (reduce (lambda (tops this)
+ (let ((new nil) (keep t))
+ (dolist (top tops)
+ (cond ((funcall order top this)
+ (setf keep nil)
+ (push top new))
+ ((not (funcall order this top))
+ (push top new))))
+ (nreverse (if keep (cons this new) new))))
+ items
+ :initial-value nil))
+
;;;--------------------------------------------------------------------------
;;; Strings and characters.
(multiple-value-call func-b (apply func-a args)))))
(reduce #'compose1 more-functions :initial-value function)))
+;;;--------------------------------------------------------------------------
+;;; Variables.
+
+(export 'defvar-unbound)
+(defmacro defvar-unbound (var doc)
+ "Make VAR a special variable with documentation DOC, but leave it unbound."
+ `(eval-when (:compile-toplevel :load-toplevel :execute)
+ (defvar ,var)
+ (setf (documentation ',var 'variable) ',doc)
+ ',var))
+
;;;--------------------------------------------------------------------------
;;; Symbols.
(defun symbolicate (&rest symbols)
"Return a symbol named after the concatenation of the names of the SYMBOLS.
- The symbol is interned in the current *PACKAGE*. Trad."
+ The symbol is interned in the current `*package*'. Trad."
(intern (apply #'concatenate 'string (mapcar #'symbol-name symbols))))
;;;--------------------------------------------------------------------------
((object stream &rest args) &body body)
"Print helper for usually-unreadable objects.
- If *PRINT-ESCAPE* is set then print OBJECT unreadably using BODY.
+ If `*print-escape*' is set then print OBJECT unreadably using BODY.
Otherwise just print using BODY."
(with-gensyms (print)
`(flet ((,print () ,@body))
(,print))
(,print)))))
+(export 'print-ugly-stuff)
+(defun print-ugly-stuff (stream func)
+ "Print not-pretty things to the stream underlying STREAM.
+
+ The Lisp pretty-printing machinery, notably `pprint-logical-block', may
+ interpose additional streams between its body and the original target
+ stream. This makes it difficult to make use of the underlying stream's
+ special features, whatever they might be."
+
+ ;; This is unpleasant. Hacky hacky.
+ #.(or #+sbcl '(if (typep stream 'sb-pretty:pretty-stream)
+ (let ((target (sb-pretty::pretty-stream-target stream)))
+ (pprint-newline :mandatory stream)
+ (funcall func target))
+ (funcall func stream))
+ #+cmu '(if (typep stream 'pp:pretty-stream)
+ (let ((target (pp::pretty-stream-target stream)))
+ (pprint-newline :mandatory stream)
+ (funcall func target))
+ (funcall func stream))
+ '(funcall func stream)))
+
;;;--------------------------------------------------------------------------
;;; Iteration macros.
(once-only (:environment env seq start end)
(with-gensyms ((ivar "INDEX-") (endvar "END-") (bodyfunc "BODY-"))
-
- (flet ((loopguts (indexp listp endvar)
- ;; Build a DO-loop to do what we want.
- (let* ((do-vars nil)
- (end-condition (if endvar
- `(>= ,ivar ,endvar)
- `(endp ,seq)))
- (item (if listp
- `(car ,seq)
- `(aref ,seq ,ivar)))
- (body-call `(,bodyfunc ,item)))
- (when listp
- (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
- do-vars))
- (when indexp
- (push `(,ivar ,start (1+ ,ivar)) do-vars))
- (when indexvar
- (setf body-call (append body-call (list ivar))))
- `(do ,do-vars (,end-condition) ,body-call))))
-
- `(block nil
- (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
- (tagbody ,@body)))
+ (multiple-value-bind (docs decls body) (parse-body body :docp nil)
+ (declare (ignore docs))
+
+ (flet ((loopguts (indexp listp endvar)
+ ;; Build a DO-loop to do what we want.
+ (let* ((do-vars nil)
+ (end-condition (if endvar
+ `(>= ,ivar ,endvar)
+ `(endp ,seq)))
+ (item (if listp
+ `(car ,seq)
+ `(aref ,seq ,ivar)))
+ (body-call `(,bodyfunc ,item)))
+ (when listp
+ (push `(,seq (nthcdr ,start ,seq) (cdr ,seq))
+ do-vars))
+ (when indexp
+ (push `(,ivar ,start (1+ ,ivar)) do-vars))
+ (when indexvar
+ (setf body-call (append body-call (list ivar))))
+ `(do ,do-vars (,end-condition) ,body-call))))
+
+ `(block nil
+ (flet ((,bodyfunc (,var ,@(and indexvar `(,indexvar)))
+ ,@decls
+ (tagbody ,@body)))
(etypecase ,seq
(vector
(let ((,endvar (or ,end (length ,seq))))
(list
(if ,end
,(loopguts t t end)
- ,(loopguts indexvar t nil))))))))))
+ ,(loopguts indexvar t nil)))))))))))
+
+;;;--------------------------------------------------------------------------
+;;; Structure accessor hacks.
+
+(export 'define-access-wrapper)
+(defmacro define-access-wrapper (from to &key read-only)
+ "Make (FROM THING) work like (TO THING).
+
+ If not READ-ONLY, then also make (setf (FROM THING) VALUE) work like
+ (setf (TO THING) VALUE).
+
+ This is mostly useful for structure slot accessors where the slot has to
+ be given an unpleasant name to avoid it being an external symbol."
+ `(progn
+ (declaim (inline ,from ,@(and (not read-only) `((setf ,from)))))
+ (defun ,from (object)
+ (,to object))
+ ,@(and (not read-only)
+ `((defun (setf ,from) (value object)
+ (setf (,to object) value))))))
+
+;;;--------------------------------------------------------------------------
+;;; Condition and error utilities.
+
+(export 'designated-condition)
+(defun designated-condition (default-type datum arguments
+ &key allow-pointless-arguments)
+ "Return the condition designated by DATUM and ARGUMENTS.
+
+ DATUM and ARGUMENTS together are a `condition designator' of (some
+ supertype of) DEFAULT-TYPE; return the condition so designated."
+ (typecase datum
+ (condition
+ (unless (or allow-pointless-arguments (null arguments))
+ (error "Argument list provided with specific condition"))
+ datum)
+ (symbol
+ (apply #'make-condition datum arguments))
+ ((or string function)
+ (make-condition default-type
+ :format-control datum
+ :format-arguments arguments))
+ (t
+ (error "Unexpected condition designator datum ~S" datum))))
+
+(export 'simple-control-error)
+(define-condition simple-control-error (control-error simple-error)
+ ())
+
+(export 'invoke-associated-restart)
+(defun invoke-associated-restart (restart condition &rest arguments)
+ "Invoke the active RESTART associated with CONDITION, with the ARGUMENTS.
+
+ Find an active restart designated by RESTART; if CONDITION is not nil,
+ then restrict the search to restarts associated with CONDITION, and
+ restarts not associated with any condition. If no such restart is found
+ then signal an error of type `control-error'; otherwise invoke the restart
+ with the given ARGUMENTS."
+ (apply #'invoke-restart
+ (or (find-restart restart condition)
+ (error 'simple-control-error
+ :format-control "~:[Restart ~S is not active~;~
+ No active `~(~A~)' restart~]~
+ ~@[ for condition ~S~]"
+ :format-arguments (list (symbolp restart)
+ restart
+ condition)))
+ arguments))
;;;--------------------------------------------------------------------------
;;; CLOS hacking.
(setf (slot-value ,instance ,slot)
(progn ,@value)))))
+(export 'define-on-demand-slot)
+(defmacro define-on-demand-slot (class slot (instance) &body body)
+ "Defines a slot which computes its initial value on demand.
+
+ Sets up the named SLOT of CLASS to establish its value as the implicit
+ progn BODY, by defining an appropriate method on `slot-unbound'."
+ (multiple-value-bind (docs decls body) (parse-body body)
+ (with-gensyms (classvar slotvar)
+ `(defmethod slot-unbound
+ (,classvar (,instance ,class) (,slotvar (eql ',slot)))
+ ,@docs ,@decls
+ (declare (ignore ,classvar))
+ (setf (slot-value ,instance ',slot) (block ,slot ,@body))))))
+
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff