(,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))
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.
(export 'it)
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.
(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))))))
;;;--------------------------------------------------------------------------
;;; 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) (progn ,@body))))))
+
;;;----- That's all, folks --------------------------------------------------
~mdw / sod / blobdiff