Skip to content

Commit 758faab

Browse files
digikar99digikar99
committed
[int] simplify defpolymorph define-polymorphic-function and refactor
1 parent aac14d6 commit 758faab

File tree

11 files changed

+514
-607
lines changed

11 files changed

+514
-607
lines changed

‎src/dispatch.lisp‎

Lines changed: 117 additions & 143 deletions
Original file line numberDiff line numberDiff line change
@@ -44,30 +44,19 @@ At compile-time *COMPILER-MACRO-EXPANDING-P* is bound to non-NIL."
4444
(setq documentation (constant-form-value documentation env)))
4545
(when docp (check-type documentation string))
4646
(let* ((*name* name)
47-
(*environment* env)
4847
(untyped-lambda-list (normalize-untyped-lambda-list untyped-lambda-list))
49-
(untyped-lambda-list (if (member '&key untyped-lambda-list)
50-
(let* ((key-position (position '&key untyped-lambda-list)))
51-
(append (subseq untyped-lambda-list 0 key-position)
52-
'(&key)
53-
(sort (subseq untyped-lambda-list (1+ key-position))
54-
#'string<
55-
:key (lambda (param)
56-
(if (and (listp param)
57-
(null (cddr param)))
58-
(car param)
59-
param)))))
60-
untyped-lambda-list)))
48+
(untyped-lambda-list (sort-untyped-lambda-list untyped-lambda-list)))
6149
`(progn
6250
(eval-when (:compile-toplevel :load-toplevel :execute)
63-
,(when overwrite
64-
`(undefine-polymorphic-function ',name))
51+
,(when overwrite `(undefine-polymorphic-function ',name))
6552
(register-polymorphic-function ',name ',untyped-lambda-list ,documentation
6653
,default
6754
:source #+sbcl (sb-c:source-location) #-sbcl nil
6855
:declaration ,dispatch-declaration)
69-
#+sbcl (sb-c:defknown ,name * * nil :overwrite-fndb-silently t))
70-
(fdefinition ',name))))
56+
#+sbcl (sb-c:defknown ,name * * nil :overwrite-fndb-silently t)
57+
,(when (fboundp 'pf-compiler-macro)
58+
`(setf (compiler-macro-function ',name) #'pf-compiler-macro))
59+
(fdefinition ',name)))))
7160

7261
(defun extract-declarations (body &key documentation)
7362
"Returns two values: DECLARATIONS and remaining BODY
@@ -118,7 +107,99 @@ If DOCUMENTATION is non-NIL, returns three values: DECLARATIONS and remaining BO
118107
existing-effective-type-list)
119108
(undefpolymorph name existing-type-list))))
120109

121-
(defmacro defpolymorph (name typed-lambda-list return-type
110+
(defun expand-defpolymorph-lite
111+
(name typed-lambda-list return-type body env)
112+
(destructuring-bind
113+
(name &rest keys
114+
&key invalidate-pf (static-dispatch-name nil static-dispatch-name-p)
115+
&allow-other-keys)
116+
(if (typep name 'function-name)
117+
(list name)
118+
name)
119+
(declare (type function-name name)
120+
(optimize debug))
121+
(remf keys :invalidate-pf)
122+
(remf keys :static-dispatch-name)
123+
(assert (null keys) ()
124+
"The only legal options for DEFPOLYMORPH are:~% STATIC-DISPATCH-NAME and INVALIDATE-PF~%Did you intend to polymorphic-functions instead of polymorphic-functions-lite?")
125+
(let+ ((block-name (blockify-name name))
126+
(*environment* env)
127+
((&values unsorted-typed-lambda-list ignorable-list)
128+
(normalize-typed-lambda-list typed-lambda-list))
129+
(typed-lambda-list (sort-typed-lambda-list unsorted-typed-lambda-list))
130+
(untyped-lambda-list (untyped-lambda-list typed-lambda-list))
131+
(pf-lambda-list (may-be-pf-lambda-list name untyped-lambda-list))
132+
(parameters (make-polymorph-parameters-from-lambda-lists
133+
pf-lambda-list typed-lambda-list))
134+
(lambda-list-type (lambda-list-type typed-lambda-list :typed t))
135+
((&values param-list type-list effective-type-list)
136+
(polymorph-effective-lambda-list parameters))
137+
((&values declarations body doc)
138+
(extract-declarations body :documentation t))
139+
(static-dispatch-name
140+
(if static-dispatch-name-p
141+
static-dispatch-name
142+
(make-or-retrieve-static-dispatch-name name type-list)))
143+
(lambda-declarations (lambda-declarations parameters))
144+
((&values ensure-type-form return-type)
145+
(ensure-type-form return-type block-name body
146+
:variable
147+
(remove-duplicates
148+
(remove-if
149+
#'null
150+
(mapcar #'third
151+
(rest lambda-declarations))))
152+
:declare
153+
(remove-duplicates
154+
(rest lambda-declarations)
155+
:test #'equal)))
156+
(lambda-body
157+
`(list-named-lambda (polymorph ,name ,type-list)
158+
,(symbol-package block-name)
159+
,param-list
160+
(declare (ignorable ,@ignorable-list))
161+
,lambda-declarations
162+
,declarations
163+
,ensure-type-form))
164+
;; LAMBDA-BODY contains the ENSURE-TYPE-FORM that performs
165+
;; run time checks on the return types.
166+
(ftype-proclaimation
167+
(ftype-proclaimation
168+
static-dispatch-name effective-type-list return-type env)))
169+
170+
`(eval-when (:compile-toplevel :load-toplevel :execute)
171+
172+
(unless (and (fboundp ',name)
173+
(typep (function ,name) 'polymorphic-function))
174+
(define-polymorphic-function ,name ,untyped-lambda-list))
175+
176+
(setf (fdefinition ',static-dispatch-name) ,lambda-body)
177+
,ftype-proclaimation
178+
(register-polymorph ',name nil
179+
',doc
180+
',typed-lambda-list
181+
',type-list
182+
',effective-type-list
183+
nil
184+
nil
185+
',return-type
186+
nil
187+
',static-dispatch-name
188+
',lambda-list-type
189+
',(run-time-applicable-p-form parameters)
190+
nil
191+
#+sbcl (sb-c:source-location))
192+
,(when invalidate-pf
193+
`(invalidate-polymorphic-function-lambda (fdefinition ',name)))
194+
',name))))
195+
196+
;;; CLHS recommends that
197+
;;; Macros intended for use in top level forms should be written so that
198+
;;; side-effects are done by the forms in the macro expansion. The
199+
;;; macro-expander itself should not do the side-effects.
200+
;;; Reference: http://clhs.lisp.se/Body/s_eval_w.htm
201+
202+
(defmacro defpolymorph (&whole whole name typed-lambda-list return-type
122203
&body body &environment env)
123204
" Expects OPTIONAL or KEY args to be in the form
124205
@@ -135,136 +216,29 @@ If DOCUMENTATION is non-NIL, returns three values: DECLARATIONS and remaining BO
135216
- If INVALIDATE-PF is non-NIL then the associated polymorphic-function
136217
is forced to recompute its dispatching after this polymorph is defined.
137218
"
138-
(destructuring-bind (name
139-
&key
140-
(static-dispatch-name nil static-dispatch-name-p)
141-
invalidate-pf)
142-
(if (typep name 'function-name)
143-
(list name)
144-
name)
145-
(declare (type function-name name)
146-
(optimize debug))
147-
(let+ ((block-name (blockify-name name))
148-
(*environment* env)
149-
((&values unsorted-typed-lambda-list ignorable-list)
150-
(normalize-typed-lambda-list typed-lambda-list))
151-
(typed-lambda-list (if (member '&key unsorted-typed-lambda-list)
152-
(let ((key-position
153-
(position '&key
154-
unsorted-typed-lambda-list)))
155-
(append (subseq unsorted-typed-lambda-list
156-
0 key-position)
157-
'(&key)
158-
(sort (subseq unsorted-typed-lambda-list
159-
(1+ key-position))
160-
#'string<
161-
:key #'caar)))
162-
unsorted-typed-lambda-list))
163-
(untyped-lambda-list (untyped-lambda-list typed-lambda-list))
164-
(pf-lambda-list (if (and (fboundp name)
165-
(typep (fdefinition name) 'polymorphic-function))
166-
(mapcar (lambda (elt)
167-
(if (atom elt) elt (first elt)))
168-
(polymorphic-function-lambda-list
169-
(fdefinition name)))
170-
untyped-lambda-list))
171-
(parameters (make-polymorph-parameters-from-lambda-lists
172-
pf-lambda-list typed-lambda-list))
173-
(lambda-list-type (lambda-list-type typed-lambda-list :typed t)))
174-
(declare (type typed-lambda-list typed-lambda-list))
175-
176-
;; USE OF INTERN BELOW:
177-
;; We do want STATIC-DISPATCH-NAME symbol collision to actually take place
178-
;; when type lists of two polymorphs are "equivalent".
179-
;; (Credits to phoe for pointing out in the issue at
180-
;; https://github.com/digikar99/polymorphic-functions/issues/3)
181-
;; Consider a file A to be
182-
;; compiled before restarting a lisp image, and file B after the
183-
;; restart. The use of GENTEMP meant that two "separate" compilations of
184-
;; the same polymorph in the two files, could result in different
185-
;; STATIC-DISPATCH-NAMEs. If the two files were then loaded
186-
;; simultaneously, and the polymorphs static-dispatched at some point,
187-
;; then there remained the possibility that different static-dispatches
188-
;; could be using "different versions" of the polymorph.
189-
;; Thus, we actually do want collisions to take place so that a same
190-
;; deterministic/latest version of the polymorph is called; therefore we
191-
;; use INTERN.
192-
(let+ (((&values param-list type-list effective-type-list)
193-
(polymorph-effective-lambda-list parameters))
194-
((&values declarations body doc)
195-
(extract-declarations body :documentation t))
196-
(static-dispatch-name
197-
(if static-dispatch-name-p
198-
static-dispatch-name
199-
(let* ((p-old
200-
(and (fboundp name)
201-
(typep (fdefinition name)
202-
'polymorphic-function)
203-
(find-polymorph name type-list)))
204-
(old-name
205-
(when p-old
206-
(polymorph-static-dispatch-name
207-
p-old))))
208-
(if old-name
209-
old-name
210-
(let ((*package* (find-package
211-
'#:polymorphic-functions.nonuser)))
212-
(intern (write-to-string
213-
`(polymorph ,name ,type-list))
214-
'#:polymorphic-functions.nonuser))))))
215-
(lambda-declarations (lambda-declarations parameters))
216-
(lambda-body
217-
`(list-named-lambda (polymorph ,name ,type-list)
218-
,(symbol-package block-name)
219-
,param-list
220-
(declare (ignorable ,@ignorable-list))
221-
,lambda-declarations
222-
,declarations
223-
,(multiple-value-bind (form form-return-type)
224-
(ensure-type-form return-type
225-
`(block ,block-name
226-
(locally ,@body))
227-
env)
228-
(setq return-type form-return-type)
229-
form))))
230-
`(eval-when (:compile-toplevel :load-toplevel :execute)
231-
(unless (and (fboundp ',name)
232-
(typep (function ,name) 'polymorphic-function))
233-
(define-polymorphic-function ,name ,untyped-lambda-list))
234-
(setf (fdefinition ',static-dispatch-name) ,lambda-body)
235-
,(let* ((ftype (ftype-for-static-dispatch static-dispatch-name
236-
effective-type-list
237-
return-type
238-
env))
239-
(proclaimation
240-
`(proclaim ',ftype)))
241-
(if optim-debug
242-
proclaimation
243-
`(handler-bind ((warning #'muffle-warning))
244-
,proclaimation)))
245-
(register-polymorph ',name nil
246-
',doc
247-
',typed-lambda-list
248-
',type-list
249-
',effective-type-list
250-
nil
251-
nil
252-
',return-type
253-
nil
254-
',static-dispatch-name
255-
',lambda-list-type
256-
',(run-time-applicable-p-form parameters)
257-
,(compiler-applicable-p-lambda-body parameters)
258-
#+sbcl (sb-c:source-location))
259-
,(when invalidate-pf
260-
`(invalidate-polymorphic-function-lambda (fdefinition ',name)))
261-
',name)))))
219+
(if (fboundp 'pf-compiler-macro)
220+
(uiop:symbol-call '#:polymorphic-functions
221+
'#:expand-defpolymorph-full
222+
whole name typed-lambda-list return-type body env)
223+
(expand-defpolymorph-lite name typed-lambda-list return-type body env)))
262224

263225
(defun undefpolymorph (name type-list)
264226
"Remove the POLYMORPH associated with NAME with TYPE-LIST"
227+
;; FIXME: Undefining polymorphs can also lead to polymorph call ambiguity.
228+
;; One (expensive) solution is to insert afresh the type lists of all polymorphs
229+
;; to resolve it.
230+
#+sbcl
231+
(let ((info (sb-c::fun-info-or-lose name))
232+
(ctype (sb-c::specifier-type (list 'function type-list '*))))
233+
(setf (sb-c::fun-info-transforms info)
234+
(remove-if (curry #'sb-c::type= ctype)
235+
(sb-c::fun-info-transforms info)
236+
:key #'sb-c::transform-type)))
265237
(remove-polymorph name type-list)
266238
(update-polymorphic-function-lambda (fdefinition name) t))
267239

268240
(defun undefine-polymorphic-function (name)
269241
"Remove the POLYMORPH(-WRAPPER) defined by DEFINE-POLYMORPH"
270-
(fmakunbound name))
242+
(fmakunbound name)
243+
#+sbcl (sb-c::undefine-fun-name name)
244+
(setf (compiler-macro-function name) nil))

0 commit comments

Comments
 (0)