Newer
Older
;;; -*- Mode: Lisp ; Base: 10 ; Syntax: ANSI-Common-Lisp -*-
;;;;; Fare's stuff for CLOS and its MOP
; This file contains enough to generate matchers of instances of classes
; known at macro-expansion-time.
#+xcvb (module (:depends-on ("packages" "matcher")))
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
(in-package :fare-clos-match)
(defgeneric class-initarg-to-slot (class))
(defmethod class-initarg-to-slot ((class standard-class))
(loop
with hash = (make-hash-table)
with slots = (compute-slots class)
for slot in slots
do (loop for initarg in (slot-definition-initargs slot)
do (setf (gethash initarg hash) slot))
finally (return #'(lambda (x) (gethash x hash)))))
;)
(defun simple-load-form (&rest rest)
(mvbind (vars lforms iforms)
(values (mapcar #'(lambda (x) (declare (ignore x)) (gensym)) rest)
(mapcar2 #'make-load-form rest))
`(let ,(mapcar #'list vars lforms)
,@iforms
(values ,@vars))))
#-gcl
(define-macro-matcher instance
#'(lambda (class &rest arglist)
(let ((initarg-to-slot (class-initarg-to-slot (find-class class)))
(*form (gensym))
(matchers '())
(var-lists '()))
(mapc #'(lambda (x)
(let* ((initarg (car x))
(pat (cdr x))
(slot (funcall initarg-to-slot initarg))
(slotname (slot-definition-name slot)))
(mvbind (matcher vars) (pattern-matcher pat)
(push `(funcall ,matcher
(slot-value ,*form ',slotname))
;; I don't dare use slot-value-using-class,
;; because the matched object's class
;; may be a subclass of class
matchers)
(push vars var-lists))))
(plist->alist arglist))
(values
`#'(lambda (,*form)
`(m%and (typep ,',*form ',',class)
,,@(nreverse matchers)))
(merge-matcher-variables var-lists)))))
#|
(load "fare")
(load "matcher")
(load "fare-clos")
(in-package :fare-clos)
(defclass foo ()
((x :initarg :x :accessor foo-x)
(y :initarg :y :accessor foo-y)))
(defclass bar (foo)
((z :initarg :z :accessor bar-z)))
(setf (symbol-function 'baz) (class-initarg-to-slot (find-class 'bar)))
(TTEST*
((ifmatch (instance foo :x x :y y) (make-instance 'foo :x 1 :y 2) (list x y))
:result '(1 2))
((ifmatch (instance foo :x x :y y) (make-instance 'bar :x 1 :y 2 :z 3)
(list x y))
:result '(1 2))
((ifmatch (slot* (x a) (z b)) (make-instance 'bar :x 1 :y 2 :z 3)
(list a b))
:result '(1 3))
((ifmatch (accessor* (foo-x a) (bar-z b)) (make-instance 'bar :x 1 :y 2 :z 3)
(list a b))
:result '(1 3)))
|#