| Paste number 91129: | Two macros and a wrapper function |
| Pasted by: | sebyte |
| When: | 8 months, 3 days ago |
| Share: | Tweet this! | http://paste.lisp.org/+1YBD |
| Channel: | #lisp |
| Paste contents: |
;;; In this simple example we can see how the arguments to wrapper
;;; function FOOW are appended to form a single list which is then
;;; passed to the macro FOO.
(defmacro foo (arg)
`(mapcar (lambda (x) (1+ (1+ x))) ,arg))
;;; => FOO
(defun foow (a b)
(foo (append a b)))
;;; => FOOW
(foow '(1) '(2))
;;; => (3 4)
;;; However, the two macros below compile perfectly well (and can be
;;; tested by macroexpanding the direct calls to them immediately
;;; below their definitions) but when it comes to compiling the
;;; wrapper function MAKE-INDEXED-SLOT-QUERY-TOOLS at the bottom of
;;; this page, an error occurs:
;;;
;;; "value INDEXED-SLOTS is not of the expected type LIST.
;;; [Condition of type TYPE-ERROR]"
;;;
;;; This has me completely stumped, especially given that this error
;;; is happening at load time, not run time.
(defmacro %make-single-query-tools (pclasses indexed-slots &optional arg)
(let ((gs (gensym)) rv)
(mapc (lambda (pclass)
(mapc (lambda (s)
(push
;; result code
`(setf (fdefinition
,(intern (concat (if arg "" "%") (symbol-name pclass)
"S-BY-" (symbol-name s))))
(lambda (,gs)
(get-instances-by-value ',pclass ',s ,gs)))
rv))
indexed-slots))
pclasses)
(push 'progn rv)
rv))
;(%make-single-query-tools (person student) (id first-name last-name))
;(%make-single-query-tools (person student) (id first-name last-name) t)
(defmacro %make-multi-query-tools (pclasses indexed-slots)
(let ((psuperclass (car pclasses)) (gs (gensym)) rv)
(mapc (lambda (indexed-slot)
(push
;; result code
`(setf (fdefinition
,(intern (concat (symbol-name psuperclass)
"S-BY-"
(symbol-name indexed-slot))))
(lambda (,gs)
(delete nil
;; inner loop
,(let (rv)
(mapc (lambda (pclass)
(push
;; inner result code
`(,(intern (concat "%" (symbol-name pclass) "S-BY-"
(symbol-name indexed-slot)))
,gs)
rv))
pclasses)
(push 'append rv)
rv)
)))
rv))
indexed-slots)
(push 'progn rv)
rv))
;(%make-multi-query-tools (person student) (id first-name last-name))
(defun make-indexed-slot-query-tools (pclass psubclasses indexed-slots)
(if (null psubclasses)
(%make-single-query-tools (list pclass) indexed-slots t)
(progn (%make-single-query-tools (append pclass psubclasses) indexed-slots)
(%make-multi-query-tools (append pclass psubclasses) indexed-slots))))
;(make-indexed-slot-query-tools person () (id height weight))
Annotations for this paste:
| Annotation number 1: | correction |
| Pasted by: | sebyte |
| When: | 8 months, 3 days ago |
| Share: | Tweet this! | http://paste.lisp.org/+1YBD/1 |
| Paste contents: |
Please ignore the very last line above (its inclusion was a mistake)