1
2
3
4
5
6
7
8
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
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
|
;;;; An implementation of a kind of generic function. This is not
;;;; terribly CLOSy, as it does not support inheritance. What we have
;;;; is a multiple-dispatch method selection routine that works on
;;;; arbitrary types. Some effort has been made to emulate CLOS's
;;;; primary method selection.
(in-package :def)
(defvar *genfuns* (make-hash-table :test #'eq)
"Mapping from symbol names to GENFUN instances.")
(defclass genfun ()
((name
:reader genfun-name
:initarg :name
:type symbol)
(methods
:accessor genfun-methods
:type (or null cons)
:initform nil
:documentation
"A sorted association list, keyed by TYPE SPECIFIER, storing
S-EXPRESSIONS representing the method implementation for that
type. This list is sorted in topological order according the
natural order on the type keys.")
(lambda-list
:reader genfun-lambda-list
:initarg :lambda-list
:type (or null cons)
:documentation
"The lambda list for this generic function")
(docstring
:reader genfun-docstring
:initarg :docstring
:type (or null string))))
(defun type-specifier-p (thing)
(ignore-errors
(typep nil thing)
t))
(deftype lambda-list-option-term ()
'(member cl:&rest cl:&aux cl:&optional cl:&key))
(defun expand-generic-function-def (generic)
(let ((vars
(method-sig-vars (genfun-lambda-list generic)))
(types
(gensym "TYPES-")))
`(defun ,(genfun-name generic) ,(genfun-lambda-list generic)
,(genfun-docstring generic)
(let ((,types (mapcar #'type-of (list ,@vars))))
(cond
,@(loop :for (signature . body) :in (genfun-methods generic)
:collect `((every #'subtypep ,types ',signature) ,@body) :into clauses
:finally
(return (nconc clauses
(list
`(t (error "No implementation of ~s for ~s"
',(genfun-name generic)
,types)))))))))))
(defun method-signature (lambda-list)
(loop
:for param :in lambda-list
:until (typep param 'lambda-list-option-term)
:when (and (listp param) (= 2 (length param)))
:do (assert (type-specifier-p (second param)) ()
"~s is not a valid type-specifier"
(second param))
:and :collect (second param)
:else
:collect 't))
(defun method-sig-vars (gen-lambda-list)
(loop :for x :in gen-lambda-list
:until (typep x 'lambda-list-option-term)
:collect x))
(defun sig-before-p (sig1 sig2)
(let* ((before (mapcar #'subtypep sig1 sig2))
(after (mapcar #'subtypep sig2 sig1)))
(or (every #'identity before)
(and (find 't before) (find 't after)
(< (position 't before) (position 't after))))))
(defun add-meth (gen spec)
(with-slots (methods) gen
(push spec methods)
(setf methods (sort methods #'sig-before-p :key #'car))))
(defun method-lambda-list-matches-generic (mll gll)
(and (= (length mll) (length gll))
(loop :for m :in mll
:for g :in gll
:for mvar := (if (consp m) (first m) m)
:for gvar := (if (consp g) (first g) g)
:always (string-equal mvar gvar))))
(defmacro generic (name lambda-list &optional docstring)
"Define a generic function with optional docstring"
(expand-generic-function-def
(setf (gethash name *genfuns*)
(make-instance 'genfun
:name name
:lambda-list lambda-list
:docstring docstring))))
(defmacro method (name lambda-list &body body)
"Define a method on the generic function called NAME, which must exist already."
(let ((gen (gethash name *genfuns*)))
(unless gen
(error "Unknown GENFUN named ~s" name))
(unless (method-lambda-list-matches-generic lambda-list (genfun-lambda-list gen))
(error "Method lambda-list ~s does not match generic function ~s"
lambda-list (genfun-lambda-list gen)))
(let* ((sig
(method-signature lambda-list))
(bound
(assoc sig (genfun-methods gen) :test #'equalp)))
(if bound
(rplacd bound body)
(add-meth gen (cons sig body)))
(expand-generic-function-def gen))))
|
