-
Notifications
You must be signed in to change notification settings - Fork 3
/
Copy pathcx-layered-function-macros.lisp
133 lines (118 loc) · 6.14 KB
/
cx-layered-function-macros.lisp
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
125
126
127
128
129
130
131
132
133
(in-package :contextl)
(defun parse-method-body (form body)
(let* ((in-layerp (member (car body) '(:in-layer :in) :test #'eq))
(layer-spec (if in-layerp (cadr body) 't)))
(when (consp layer-spec)
(unless (null (cddr layer-spec))
(error "Incorrect :in-layer specification in ~S." form)))
(loop with layer = (if (atom layer-spec)
layer-spec
(cadr layer-spec))
with layer-arg = (if (atom layer-spec)
(gensym "LAYER-ARG-")
(car layer-spec))
for tail = (if in-layerp (cddr body) body) then (cdr tail)
until (listp (car tail))
collect (car tail) into qualifiers
finally
(loop for qualifier in qualifiers
when (member qualifier '(:in-layer :in) :test #'eq)
do (error "Incorrect occurrence of ~S in ~S. Must occur before qualifiers." qualifier form))
(return (values layer-arg layer qualifiers (car tail) (cdr tail))))))
(defun prepare-layer (layer)
(if (symbolp layer)
(defining-layer layer)
layer))
(defun prepare-layered-method-body (name form layer-arg body)
(loop for tail = body then (cdr tail)
for (first . rest) = tail
while tail
while (or (and rest (stringp first))
(and (consp first) (eq (car first) 'declare)))
count (stringp first) into nof-seen-strings
collect first into declarations
finally
(when (> nof-seen-strings 1)
(warn "Too many documentation strings in ~S." form))
(return `(,@declarations
(block ,(plain-function-name name)
(flet ((call-next-layered-method (&rest args)
(if args
(apply #'call-next-method ,layer-arg args)
(call-next-method))))
(declare (inline call-next-layered-method)
(ignorable (function call-next-layered-method)))
,@tail))))))
(defun parse-gf-lambda-list (lambda-list)
(loop for entry in lambda-list
for lambda-list-keyword = (member entry lambda-list-keywords)
until lambda-list-keyword
collect entry into required-parameters
finally (return (values required-parameters lambda-list-keyword))))
(defclass layered-function (standard-generic-function) ()
(:metaclass funcallable-standard-class)
(:default-initargs :method-class (find-class 'layered-method)))
(defmethod print-object ((object layered-function) stream)
(print-unreadable-object (object stream :type t :identity t)
(princ (lf-caller-name (generic-function-name object)) stream)))
(defun layered-function-definer (name)
(fdefinition (lf-definer-name name)))
(defgeneric layered-function-argument-precedence-order (function)
(:method ((function layered-function)) (butlast (generic-function-argument-precedence-order function))))
(defgeneric layered-function-lambda-list (function)
(:method ((function layered-function)) (rest (generic-function-lambda-list function))))
(defun lfmakunbound (name)
(fmakunbound (lf-definer-name name))
(fmakunbound name))
(defclass layered-method (standard-method) ())
(defgeneric layered-method-lambda-list (method)
(:method ((method layered-method)) (rest (method-lambda-list method))))
(defgeneric layered-method-specializers (method)
(:method ((method layered-method)) (rest (method-specializers method))))
(defmacro define-layered-function (name (&rest args) &body options)
(let ((definer (lf-definer-name name))
(documentation (assoc :documentation options)))
(with-unique-names (layer-arg rest-arg)
`(progn
(defgeneric ,definer (,layer-arg ,@args)
,@(unless (member :generic-function-class options :key #'car)
'((:generic-function-class layered-function)))
(:argument-precedence-order
,@(let ((argument-precedence-order (assoc :argument-precedence-order options)))
(if argument-precedence-order
(cdr argument-precedence-order)
(required-args args)))
,layer-arg)
,@(loop for option in (remove :argument-precedence-order options :key #'car)
if (eq (car option) :method)
collect (multiple-value-bind
(layer-arg layer qualifiers args method-body)
(parse-method-body option (cdr option))
`(:method ,@qualifiers ((,layer-arg ,(prepare-layer layer)) ,@args)
,@(prepare-layered-method-body name option layer-arg method-body)))
else if (not (eq (car option) :documentation)) collect option))
(declaim (inline ,name))
,(multiple-value-bind
(required-parameters lambda-list-keyword)
(parse-gf-lambda-list args)
(if lambda-list-keyword
`(defun ,name (,@required-parameters &rest ,rest-arg)
(declare (optimize (speed 3) (debug 0) (safety 0)
(compilation-speed 0)))
,@(when documentation (list (cadr documentation)))
(apply #',definer (layer-context-prototype *active-context*) ,@required-parameters ,rest-arg))
`(defun ,name (,@required-parameters)
(declare (optimize (speed 3) (debug 0) (safety 0)
(compilation-speed 0)))
,@(when documentation (list (cadr documentation)))
(funcall #',definer (layer-context-prototype *active-context*) ,@required-parameters))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(bind-lf-names ',name))
#',definer))))
(defmacro define-layered-method (&whole form name &body body)
(multiple-value-bind
(layer-arg layer qualifiers args method-body)
(parse-method-body form body)
`(defmethod ,(lf-definer-name name)
,@qualifiers ((,layer-arg ,(prepare-layer layer)) ,@args)
,@(prepare-layered-method-body name form layer-arg method-body))))