Commit | Line | Data |
---|---|---|
beae6579 | 1 | ;; Common Lisp bindings for GTK+ v2.x |
2 | ;; Copyright 1999-2006 Espen S. Johnsen <espen@users.sf.net> | |
3 | ;; | |
4 | ;; Permission is hereby granted, free of charge, to any person obtaining | |
5 | ;; a copy of this software and associated documentation files (the | |
6 | ;; "Software"), to deal in the Software without restriction, including | |
7 | ;; without limitation the rights to use, copy, modify, merge, publish, | |
8 | ;; distribute, sublicense, and/or sell copies of the Software, and to | |
9 | ;; permit persons to whom the Software is furnished to do so, subject to | |
10 | ;; the following conditions: | |
11 | ;; | |
12 | ;; The above copyright notice and this permission notice shall be | |
13 | ;; included in all copies or substantial portions of the Software. | |
14 | ;; | |
15 | ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, | |
16 | ;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF | |
17 | ;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. | |
18 | ;; IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY | |
19 | ;; CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, | |
20 | ;; TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE | |
21 | ;; SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. | |
22 | ||
050b602e | 23 | ;; $Id: interface.lisp,v 1.10 2008-12-10 02:40:18 espen Exp $ |
beae6579 | 24 | |
25 | (in-package "GFFI") | |
26 | ||
27 | ||
28 | ;;;; Foreign function call interface | |
29 | ||
30 | (defvar *package-prefix* nil) | |
31 | ||
32 | (defun set-package-prefix (prefix &optional (package *package*)) | |
33 | (let ((package (find-package package))) | |
34 | (setq *package-prefix* (delete package *package-prefix* :key #'car)) | |
35 | (push (cons package prefix) *package-prefix*)) | |
36 | prefix) | |
37 | ||
38 | (defun package-prefix (&optional (package *package*)) | |
39 | (let ((package (find-package package))) | |
40 | (or | |
41 | (cdr (assoc package *package-prefix*)) | |
42 | (substitute #\_ #\- (string-downcase (package-name package)))))) | |
43 | ||
44 | (defun find-prefix-package (prefix) | |
45 | (or | |
46 | (car (rassoc (string-downcase prefix) *package-prefix* :test #'string=)) | |
47 | (find-package (string-upcase prefix)))) | |
48 | ||
49 | (defmacro use-prefix (prefix &optional (package *package*)) | |
50 | `(eval-when (:compile-toplevel :load-toplevel :execute) | |
51 | (set-package-prefix ,prefix ,package))) | |
52 | ||
53 | ||
54 | (defun default-alien-fname (lisp-name) | |
55 | (let* ((name (substitute #\_ #\- (string-downcase lisp-name))) | |
49ef0cdc | 56 | (start (position-if-not #'(lambda (char) (char= char #\%)) name)) |
57 | (end (if (string= "_p" name :start2 (- (length name) 2)) | |
58 | (- (length name) 2) | |
59 | (length name))) | |
60 | (stripped-name (subseq name start end)) | |
beae6579 | 61 | (prefix (package-prefix *package*))) |
62 | (if (or (not prefix) (string= prefix "")) | |
63 | stripped-name | |
64 | (format nil "~A_~A" prefix stripped-name)))) | |
65 | ||
66 | (defun default-alien-type-name (type-name) | |
67 | (let ((prefix (package-prefix *package*))) | |
68 | (apply | |
69 | #'concatenate | |
70 | 'string | |
71 | (mapcar | |
72 | #'string-capitalize | |
73 | (cons prefix (split-string (symbol-name type-name) :delimiter #\-)))))) | |
74 | ||
6dfb2039 RS |
75 | (defun split-alien-name (alien-name) |
76 | (let ((parts (split-string-if alien-name #'upper-case-p))) | |
77 | (do ((prefix (first parts) (concatenate 'string prefix (first rest))) | |
78 | (rest (rest parts) (cdr rest))) | |
79 | ((null rest) | |
80 | (error "Couldn't split alien name '~A' to find a registered prefix" | |
81 | alien-name)) | |
82 | (when (find-prefix-package prefix) | |
83 | (return (values (string-upcase (concatenate-strings rest #\-)) | |
84 | (find-prefix-package prefix))))))) | |
beae6579 | 85 | |
6dfb2039 RS |
86 | (defun default-type-name (alien-name) |
87 | (multiple-value-call #'intern (split-alien-name alien-name))) | |
beae6579 | 88 | |
89 | (defun in-arg-p (style) | |
90 | (find style '(:in :in/out :in/return :in-out :return))) | |
91 | ||
92 | (defun out-arg-p (style) | |
93 | (find style '(:out :in/out :in-out))) | |
94 | ||
95 | (defun return-arg-p (style) | |
96 | (find style '(:in/return :return))) | |
97 | ||
98 | (defmacro defbinding (name lambda-list return-type &rest args) | |
99 | (multiple-value-bind (lisp-name c-name) | |
100 | (if (atom name) | |
101 | (values name (default-alien-fname name)) | |
102 | (values-list name)) | |
103 | ||
104 | (let* ((lambda-list-supplied-p lambda-list) | |
105 | (lambda-list (unless (equal lambda-list '(nil)) lambda-list)) | |
2c708568 | 106 | (arg-types ()) |
107 | (aux-bindings ()) | |
beae6579 | 108 | (doc-string (when (stringp (first args)) (pop args))) |
109 | (parsed-args | |
110 | (mapcar | |
111 | #'(lambda (arg) | |
112 | (destructuring-bind | |
2c708568 | 113 | (expr type &optional (style :in) (out-type type)) |
114 | (if (atom arg) | |
115 | (list arg arg) | |
116 | arg) | |
beae6579 | 117 | (cond |
118 | ((find style '(:in-out :return)) | |
119 | (warn "Deprecated argument style: ~S" style)) | |
120 | ((not (find style '(:in :out :in/out :in/return))) | |
121 | (error "Bogus argument style: ~S" style))) | |
122 | (when (and | |
123 | (not lambda-list-supplied-p) | |
2c708568 | 124 | (namep expr) (in-arg-p style) |
125 | (not (find expr lambda-list))) | |
126 | (push expr lambda-list) | |
127 | (push type arg-types)) | |
beae6579 | 128 | (let ((aux (unless (or (not (in-arg-p style)) (namep expr)) |
129 | (gensym)))) | |
130 | (when aux | |
2c708568 | 131 | (push (list aux expr) aux-bindings)) |
beae6579 | 132 | (list |
133 | (cond | |
134 | ((and (namep expr) (not (in-arg-p style))) expr) | |
02198d7d | 135 | ((namep expr) |
136 | #-clisp(make-symbol (string expr)) | |
137 | ;; The above used to work in CLISP, but I'm | |
138 | ;; not sure exactly at which version it | |
139 | ;; broke. The following could potentially | |
140 | ;; cause variable capturing | |
141 | #+clisp(intern (format nil "~A-~A" (string expr) (gensym)))) | |
142 | (#-clisp(gensym) | |
143 | #+clisp(intern (string (gensym))))) | |
beae6579 | 144 | (or aux expr) type style out-type)))) |
145 | args))) | |
146 | ||
147 | (%defbinding c-name lisp-name | |
148 | (if lambda-list-supplied-p lambda-list (nreverse lambda-list)) | |
2c708568 | 149 | (not lambda-list-supplied-p) (nreverse arg-types) |
150 | aux-bindings return-type doc-string parsed-args)))) | |
beae6579 | 151 | |
152 | ||
153 | #+(or cmu sbcl) | |
154 | (defun foreign-funcall (cname args return-type) | |
155 | (let ((fparams (loop | |
156 | for (var expr type style out-type) in args | |
157 | collect (if (out-arg-p style) | |
158 | `(addr ,var) | |
159 | var))) | |
160 | (ftypes (loop | |
161 | for (var expr type style out-type) in args | |
162 | collect (if (out-arg-p style) | |
163 | `(* ,(alien-type out-type)) | |
164 | (alien-type out-type)))) | |
165 | (fname (make-symbol cname))) | |
166 | `(with-alien ((,fname (function ,(alien-type return-type) ,@ftypes) :extern ,cname)) | |
167 | (alien-funcall ,fname ,@fparams)))) | |
168 | ||
169 | #+clisp | |
170 | (defun foreign-funcall (cname args return-type) | |
171 | (let* ((fparams (loop | |
172 | for (var expr type style out-type) in args | |
173 | collect (if (out-arg-p style) | |
174 | `(ffi:c-var-address ,var) | |
175 | var))) | |
176 | (fargs (loop | |
177 | for (var expr type style out-type) in args | |
178 | collect (list var (if (out-arg-p style) | |
179 | 'ffi:c-pointer | |
180 | (alien-type out-type))))) | |
181 | (c-function `(ffi:c-function | |
182 | (:arguments ,@fargs) | |
183 | (:return-type ,(alien-type return-type)) | |
184 | (:language :stdc)))) | |
185 | `(funcall | |
186 | (load-time-value | |
4f2a8644 | 187 | (ffi::foreign-library-function |
188 | ,cname (ffi::foreign-library :default) #?(clisp>= 2 40)nil | |
beae6579 | 189 | nil (ffi:parse-c-type ',c-function))) |
190 | ,@fparams))) | |
191 | ||
192 | ||
193 | ;; TODO: check if in and out types (if different) translates to same | |
194 | ;; alien type | |
2c708568 | 195 | (defun %defbinding (cname lisp-name lambda-list declare-p arg-types aux-bindings return-type doc args) |
beae6579 | 196 | (let ((out (loop |
197 | for (var expr type style out-type) in args | |
198 | when (or (out-arg-p style) (return-arg-p style)) | |
199 | collect (from-alien-form out-type var))) | |
200 | (fcall (from-alien-form return-type | |
201 | (foreign-funcall cname args return-type)))) | |
202 | ||
203 | (labels ((create-wrapper (args body) | |
204 | (if args | |
205 | (destructuring-bind (var expr type style out-type) (first args) | |
206 | (declare (ignore out-type)) | |
207 | (alien-arg-wrapper type var expr style | |
208 | (create-wrapper (rest args) body))) | |
209 | body))) | |
2c708568 | 210 | `(progn |
211 | ,(when declare-p | |
212 | `(declaim | |
213 | (ftype | |
214 | (function | |
215 | ,(mapcar #'argument-type arg-types) | |
216 | (values | |
217 | ,@(when return-type (list (return-type return-type))) | |
218 | ,@(loop | |
219 | for (var expr type style out-type) in args | |
220 | when (out-arg-p style) | |
221 | collect (return-type out-type) | |
222 | when (return-arg-p style) | |
cab97f15 | 223 | collect (return-type type)))) |
224 | ,lisp-name))) | |
2c708568 | 225 | (defun ,lisp-name ,lambda-list |
beae6579 | 226 | ,doc |
2c708568 | 227 | (let ,aux-bindings |
beae6579 | 228 | ,(if return-type |
229 | (create-wrapper args `(values ,fcall ,@out)) | |
2c708568 | 230 | (create-wrapper args `(progn ,fcall (values ,@out)))))))))) |
beae6579 | 231 | |
232 | ||
233 | ||
234 | ;;;; Dynamic (runtime) bindings | |
235 | ||
236 | (defun mkbinding (name return-type &rest arg-types) | |
237 | #+cmu(declare (optimize (inhibit-warnings 3))) | |
238 | #+sbcl(declare (muffle-conditions compiler-note)) | |
239 | (let* ((c-function | |
240 | #+(or cmu sbcl) | |
241 | `(function ,@(mapcar #'alien-type (cons return-type arg-types))) | |
242 | #+clisp | |
243 | `(ffi:c-function | |
244 | (:arguments ,@(mapcar | |
245 | #'(lambda (type) | |
246 | (list (gensym) (alien-type type))) | |
247 | arg-types)) | |
248 | (:return-type ,(alien-type return-type)) | |
249 | (:language :stdc))) | |
250 | (foreign | |
251 | #+(or cmu sbcl) | |
252 | (handler-bind (#+sbcl(compiler-note #'(lambda (condition) | |
253 | (declare (ignore condition)) | |
254 | (muffle-warning)))) | |
255 | (%heap-alien | |
256 | (make-heap-alien-info | |
257 | :type (parse-alien-type c-function #+sbcl nil) | |
258 | :sap-form (let ((address (foreign-symbol-address name))) | |
259 | (etypecase address | |
260 | (integer (int-sap address)) | |
261 | (system-area-pointer address)))))) | |
262 | #+clisp | |
263 | (ffi::foreign-library-function name | |
4f2a8644 | 264 | (ffi::foreign-library :default) #?(clisp>= 2 40)nil |
beae6579 | 265 | nil (ffi:parse-c-type c-function))) |
266 | (return-value-translator (from-alien-function return-type))) | |
267 | (multiple-value-bind (arg-translators cleanup-funcs) | |
268 | (let ((translator/cleanup-pairs | |
269 | (mapcar | |
270 | #'(lambda (type) | |
271 | (multiple-value-list (to-alien-function type))) | |
272 | arg-types))) | |
273 | (values | |
274 | (mapcar #'first translator/cleanup-pairs) | |
275 | (mapcar #'second translator/cleanup-pairs))) | |
276 | #'(lambda (&rest args) | |
277 | (let ((translated-args (mapcar #'funcall arg-translators args))) | |
278 | (prog1 | |
279 | (funcall return-value-translator | |
280 | #+(or cmu sbcl)(apply #'alien-funcall foreign translated-args) | |
281 | #+clisp(apply foreign translated-args)) | |
282 | (mapc | |
283 | #'(lambda (cleanup arg translated-arg) | |
284 | (when cleanup | |
285 | (funcall cleanup arg translated-arg))) | |
286 | cleanup-funcs args translated-args))))))) | |
287 | ||
288 | ||
289 | ||
290 | ;;;; C Callbacks | |
291 | ||
292 | (defun callback-body (args return-type body) | |
293 | (labels ((create-wrappers (args body) | |
294 | (if args | |
295 | (destructuring-bind (var type) (first args) | |
296 | (callback-wrapper type var var | |
297 | (create-wrappers (rest args) body))) | |
298 | body)) | |
299 | (create-body (args body) | |
300 | (to-alien-form return-type | |
301 | (create-wrappers args `(progn ,@body))))) | |
302 | (if (and (consp (first body)) (eq (caar body) 'declare)) | |
303 | (let ((ignored (loop | |
304 | for declaration in (cdar body) | |
305 | when (eq (first declaration) 'ignore) | |
306 | nconc (rest declaration)))) | |
307 | `(,(first body) | |
308 | ,(create-body | |
309 | (remove-if #'(lambda (arg) | |
310 | (find (first arg) ignored)) | |
311 | args) | |
312 | (rest body)))) | |
313 | (list (create-body args body))))) | |
314 | ||
315 | ||
316 | #+(or cmu sbcl) | |
317 | (defmacro define-callback (name return-type args &body body) | |
318 | (let ((define-callback | |
319 | #+cmu'alien:def-callback | |
320 | #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback | |
c52ab022 | 321 | #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function) |
322 | (args (mapcar #'(lambda (arg) | |
323 | (if (atom arg) (list arg arg) arg)) | |
324 | args))) | |
beae6579 | 325 | `(progn |
326 | #+cmu(defparameter ,name nil) | |
327 | (,define-callback ,name | |
328 | #+(and sbcl alien-callbacks) ,(alien-type return-type) | |
329 | (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type) | |
330 | ,@(loop | |
331 | for (name type) in args | |
332 | collect `(,name ,(alien-type type)))) | |
333 | ,@(callback-body args return-type body))))) | |
334 | ||
335 | #+(or cmu sbcl) | |
336 | (defun callback-address (callback) | |
337 | #+cmu(alien::callback-trampoline callback) | |
338 | #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback) | |
339 | #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback)) | |
340 | ||
341 | #+sbcl | |
342 | (deftype callback () | |
343 | #-alien-callbacks'sb-alien:alien-function | |
344 | #+alien-callbacks'sb-alien:alien) | |
345 | ||
346 | ||
347 | ;;; The callback code for CLISP is based on code from CFFI | |
348 | ;;; Copyright (C) 2005, James Bielman <jamesjb@jamesjb.com> | |
349 | ;;; (C) 2005, Joerg Hoehle <hoehle@users.sourceforge.net> | |
350 | ||
351 | ||
352 | ;;; *CALLBACKS* contains the callbacks defined by the %DEFCALLBACK | |
353 | ;;; macro. The symbol naming the callback is the key, and the value | |
354 | ;;; is a list containing a Lisp function, the parsed CLISP FFI type of | |
355 | ;;; the callback, and a saved pointer that should not persist across | |
356 | ;;; saved images. | |
357 | #+clisp | |
358 | (progn | |
359 | (defvar *callbacks* (make-hash-table)) | |
360 | ||
361 | ;;; Return a CLISP FFI function type for a CFFI callback function | |
362 | ;;; given a return type and list of argument names and types. | |
363 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
364 | (defun callback-type (return-type arg-names arg-types) | |
365 | (ffi:parse-c-type | |
366 | `(ffi:c-function | |
367 | (:arguments ,@(mapcar (lambda (sym type) | |
368 | (list sym (alien-type type))) | |
369 | arg-names arg-types)) | |
370 | (:return-type ,(alien-type return-type)) | |
371 | (:language :stdc))))) | |
372 | ||
373 | ;;; Register and create a callback function. | |
374 | (defun register-callback (name function parsed-type) | |
375 | (setf (gethash name *callbacks*) | |
376 | (list function parsed-type | |
377 | (ffi:with-foreign-object (ptr 'ffi:c-pointer) | |
378 | ;; Create callback by converting Lisp function to foreign | |
379 | (setf (ffi:memory-as ptr parsed-type) function) | |
380 | (ffi:foreign-value ptr))))) | |
381 | ||
382 | ;;; Restore all saved callback pointers when restarting the Lisp | |
383 | ;;; image. This is pushed onto CUSTOM:*INIT-HOOKS*. | |
384 | ;;; Needs clisp > 2.35, bugfix 2005-09-29 | |
385 | (defun restore-callback-pointers () | |
386 | (maphash | |
387 | (lambda (name list) | |
388 | (register-callback name (first list) (second list))) | |
389 | *callbacks*)) | |
390 | ||
391 | ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run | |
392 | ;;; when an image is restarted. | |
393 | (eval-when (:load-toplevel :execute) | |
394 | (pushnew 'restore-callback-pointers custom:*init-hooks*)) | |
395 | ||
396 | ;;; Define a callback function NAME to run BODY with arguments | |
397 | ;;; ARG-NAMES translated according to ARG-TYPES and the return type | |
398 | ;;; translated according to RETTYPE. Obtain a pointer that can be | |
399 | ;;; passed to C code for this callback by calling %CALLBACK. | |
400 | (defmacro define-callback (name return-type args &body body) | |
c52ab022 | 401 | (let* ((args (mapcar #'(lambda (arg) |
402 | (if (atom arg) (list arg arg) arg)) | |
403 | args)) | |
404 | (arg-names (mapcar #'first args)) | |
405 | (arg-types (mapcar #'second args))) | |
beae6579 | 406 | `(progn |
407 | (defvar ,name ',name) | |
408 | (register-callback ',name | |
409 | (lambda ,arg-names ,@(callback-body args return-type body)) | |
410 | ,(callback-type return-type arg-names arg-types))))) | |
411 | ||
412 | ;;; Look up the name of a callback and return a pointer that can be | |
413 | ;;; passed to a C function. Signals an error if no callback is | |
414 | ;;; defined called NAME. | |
415 | (defun callback-address (name) | |
416 | (multiple-value-bind (list winp) (gethash name *callbacks*) | |
417 | (unless winp | |
418 | (error "Undefined callback: ~S" name)) | |
419 | (third list))) | |
420 | ||
421 | (deftype callback () 'symbol)) | |
422 | ||
423 | ||
424 | ||
425 | ;;;; Type expansion | |
426 | ||
427 | (defun type-expand-1 (form) | |
428 | #+(or cmu sbcl) | |
429 | (let ((def (cond ((symbolp form) | |
430 | #+cmu(kernel::info type expander form) | |
431 | #+sbcl(sb-impl::info :type :expander form)) | |
432 | ((and (consp form) (symbolp (car form))) | |
433 | #+cmu(kernel::info type expander (car form)) | |
434 | #+sbcl(sb-impl::info :type :expander (car form))) | |
435 | (t nil)))) | |
436 | (if def | |
437 | (values (funcall def (if (consp form) form (list form))) t) | |
438 | (values form nil))) | |
439 | #+clisp(ext:type-expand form t)) | |
440 | ||
441 | (defun type-expand-to (type form) | |
442 | (labels ((expand (form0) | |
443 | (if (eq (first (mklist form0)) type) | |
444 | form0 | |
445 | (multiple-value-bind (expanded-form expanded-p) | |
446 | (type-expand-1 form0) | |
447 | (if expanded-p | |
448 | (expand expanded-form) | |
449 | (error "~A can not be expanded to ~A" form type)))))) | |
450 | (expand form))) | |
451 | ||
050b602e | 452 | (defun type-equal-p (type1 type2) |
453 | (and (subtypep type1 type2) (subtypep type2 type1))) | |
beae6579 | 454 | |
455 | ||
456 | ;;;; Type methods | |
457 | ||
2c708568 | 458 | (defun find-type-method (name type-spec &optional (error-p t)) |
459 | (let ((type-methods (get name 'type-methods)) | |
460 | (specifier (if (atom type-spec) | |
461 | type-spec | |
462 | (first type-spec)))) | |
463 | (or | |
464 | (gethash specifier type-methods) | |
465 | (when error-p | |
466 | (error | |
467 | "No explicit type method for ~A when call width type specifier ~A found" | |
468 | name type-spec))))) | |
469 | ||
beae6579 | 470 | (defun find-next-type-method (name type-spec &optional (error-p t)) |
471 | (let ((type-methods (get name 'type-methods))) | |
472 | (labels ((search-method-in-cpl-order (classes) | |
473 | (when classes | |
474 | (or | |
475 | (gethash (class-name (first classes)) type-methods) | |
476 | (search-method-in-cpl-order (rest classes))))) | |
477 | (lookup-method (type-spec) | |
478 | (if (and (symbolp type-spec) (find-class type-spec nil)) | |
479 | (let ((class (find-class type-spec))) | |
584285fb | 480 | #?(or (sbcl>= 0 9 15) (featurep :clisp)) |
beae6579 | 481 | (unless (class-finalized-p class) |
482 | (finalize-inheritance class)) | |
483 | (search-method-in-cpl-order | |
484 | (rest (class-precedence-list class)))) | |
485 | (multiple-value-bind (expanded-type expanded-p) | |
486 | (type-expand-1 type-spec) | |
487 | (when expanded-p | |
488 | (or | |
489 | (let ((specifier (etypecase expanded-type | |
490 | (symbol expanded-type) | |
491 | (list (first expanded-type))))) | |
492 | (gethash specifier type-methods)) | |
493 | (lookup-method expanded-type)))))) | |
494 | (search-built-in-type-hierarchy (sub-tree) | |
495 | (when (subtypep type-spec (first sub-tree)) | |
496 | (or | |
497 | (search-nodes (cddr sub-tree)) | |
498 | (second sub-tree)))) | |
499 | (search-nodes (nodes) | |
500 | (loop | |
501 | for node in nodes | |
502 | as method = (search-built-in-type-hierarchy node) | |
503 | until method | |
504 | finally (return method)))) | |
505 | (or | |
506 | (lookup-method type-spec) | |
507 | ;; This is to handle unexpandable types whichs doesn't name a | |
508 | ;; class. It may cause infinite loops with illegal | |
509 | ;; call-next-method calls | |
b673a77b | 510 | (unless (or |
511 | (null type-spec) | |
512 | (and (symbolp type-spec) (find-class type-spec nil))) | |
beae6579 | 513 | (search-nodes (get name 'built-in-type-hierarchy))) |
514 | (when error-p | |
515 | (error "No next type method ~A for type specifier ~A" | |
516 | name type-spec)))))) | |
517 | ||
518 | (defun find-applicable-type-method (name type-spec &optional (error-p t)) | |
2c708568 | 519 | (or |
520 | (find-type-method name type-spec nil) | |
521 | (find-next-type-method name type-spec nil) | |
522 | (when error-p | |
523 | (error | |
524 | "No applicable type method for ~A when call width type specifier ~A" | |
525 | name type-spec)))) | |
526 | ||
beae6579 | 527 | |
528 | (defun insert-type-in-hierarchy (specifier function nodes) | |
529 | (cond | |
530 | ((let ((node (find specifier nodes :key #'first))) | |
531 | (when node | |
532 | (setf (second node) function) | |
533 | nodes))) | |
534 | ((let ((node | |
535 | (find-if | |
536 | #'(lambda (node) | |
537 | (subtypep specifier (first node))) | |
538 | nodes))) | |
539 | (when node | |
540 | (setf (cddr node) | |
541 | (insert-type-in-hierarchy specifier function (cddr node))) | |
542 | nodes))) | |
543 | ((let ((sub-nodes (remove-if-not | |
544 | #'(lambda (node) | |
545 | (subtypep (first node) specifier)) | |
546 | nodes))) | |
547 | (cons | |
548 | (list* specifier function sub-nodes) | |
549 | (nset-difference nodes sub-nodes)))))) | |
550 | ||
551 | (defun add-type-method (name specifier function) | |
552 | (setf (gethash specifier (get name 'type-methods)) function) | |
553 | (when (typep (find-class specifier nil) 'built-in-class) | |
554 | (setf (get name 'built-in-type-hierarchy) | |
555 | (insert-type-in-hierarchy specifier function | |
556 | (get name 'built-in-type-hierarchy))))) | |
557 | ||
558 | ||
559 | (defmacro define-type-generic (name lambda-list &optional documentation) | |
560 | (let ((type-spec (first lambda-list))) | |
561 | (if (or | |
562 | (not lambda-list) | |
563 | (find type-spec '(&optional &key &rest &allow-other-keys))) | |
564 | (error "A type generic needs at least one required argument") | |
565 | `(progn | |
566 | (unless (get ',name 'type-methods) | |
567 | (setf (get ',name 'type-methods) (make-hash-table)) | |
568 | (setf (get ',name 'built-in-type-hierarchy) ())) | |
569 | ,(if (intersection '(&optional &key &rest &allow-other-keys) lambda-list) | |
570 | (let ((args (make-symbol "ARGS"))) | |
571 | `(defun ,name (,type-spec &rest ,args) | |
572 | ,documentation | |
573 | (apply | |
574 | (find-applicable-type-method ',name ,type-spec) | |
575 | ,type-spec ,args))) | |
576 | `(defun ,name ,lambda-list | |
577 | ,documentation | |
578 | (funcall | |
579 | (find-applicable-type-method ',name ,type-spec) | |
580 | ,@lambda-list))))))) | |
581 | ||
582 | ||
583 | (defmacro define-type-method (name lambda-list &body body) | |
584 | (let ((specifier (cadar lambda-list)) | |
585 | (args (make-symbol "ARGS"))) | |
586 | `(progn | |
587 | (add-type-method ',name ',specifier | |
588 | #'(lambda (&rest ,args) | |
589 | (flet ((call-next-method (&rest args) | |
590 | (let ((next-method (find-next-type-method ',name ',specifier))) | |
591 | (apply next-method (or args ,args))))) | |
592 | (destructuring-bind (,(caar lambda-list) ,@(rest lambda-list)) ,args | |
593 | ,@body)))) | |
594 | ',name))) | |
595 | ||
596 | ||
597 | ;;; Rules for auto-exporting symbols | |
598 | ||
599 | (defexport defbinding (name &rest args) | |
600 | (declare (ignore args)) | |
601 | (if (symbolp name) | |
602 | name | |
603 | (first name))) | |
604 | ||
605 | (defexport define-type-generic (name &rest args) | |
606 | (declare (ignore args)) | |
607 | name) |