Fix for define-property-function-case, added define-simple-property-functions
This commit is contained in:
parent
544c7b27ee
commit
0c9af860c7
2 changed files with 17 additions and 3 deletions
|
@ -34,7 +34,8 @@
|
|||
#:define-simple-property-function
|
||||
#:resolve-function
|
||||
#:define-primitive-property-consumer
|
||||
#:define-property-function-case)
|
||||
#:define-property-function-case
|
||||
#:define-simple-property-functions)
|
||||
;; special.lisp
|
||||
(:export
|
||||
#:define-single-arg-selector
|
||||
|
|
|
@ -98,7 +98,7 @@ for example for when you encounter an item you don't want to read."
|
|||
(cons ,property (nreverse ,propvals)))
|
||||
NIL))))
|
||||
|
||||
(defmacro define-property-function-case (property (args) &rest function-clauses)
|
||||
(defmacro define-property-function-case (property (args) &body function-clauses)
|
||||
"Defines a CONSUME-ITEM method for PROPERTY that has special handling for property-functions.
|
||||
|
||||
FUNCTION-CLAUSES ::= function-clause*
|
||||
|
@ -119,8 +119,21 @@ You can use (RETURN) in a clause body to stop reading values altogether."
|
|||
(let* ((,args (cdr ,next))
|
||||
(,result
|
||||
(cond ,@(loop for (func . forms) in function-clauses
|
||||
collect `((string-equal (car ,next) ,func) ,@forms)))))
|
||||
for alternatives = (if (listp func) func (list func))
|
||||
collect `((or ,@(loop for alt in alternatives
|
||||
collect `(string-equal (car ,next) ,(string alt))))
|
||||
,@forms)))))
|
||||
(if ,result
|
||||
(progn (push ,result propvals) (advance ,readable))
|
||||
(return))))
|
||||
(T (push (consume ,readable) ,propvals))))))
|
||||
|
||||
(defmacro define-simple-property-functions (property &rest funcspecs)
|
||||
(let ((arglist (gensym "ARGLIST")))
|
||||
`(define-property-function-case ,property (,arglist)
|
||||
,@(loop for (name args) in funcspecs
|
||||
do (assert (loop for key in '(&key &optional &rest &allow-other-keys)
|
||||
never (find key args)) () "Only required arguments are allowed.")
|
||||
collect `(,name (destructuring-bind ,args ,arglist
|
||||
(format NIL ,(format NIL "~(~a~)(~{~*~~a~^,~})" name args)
|
||||
,@(loop for arg in args collect `(resolve ,arg)))))))))
|
||||
|
|
Loading…
Reference in a new issue