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) | |
f1cd62bb RS |
99 | "This defines a foreign function call. NAME should either be a symbol or a |
100 | list (LISP-SYM STRING). The lisp function will be given the name of the lisp | |
101 | symbol and the foreign function name is either the string given or automatically | |
102 | generated using DEFAULT-ALIEN-FNAME. | |
103 | ||
104 | If LAMBDA-LIST is nil, the lambda list for the generated lisp function is | |
105 | automatically computed from the input arguments as described below. If it is | |
106 | non-nil, it gives the lambda list for the function. To manually specify an empty | |
107 | lambda list, pass (NIL) which gets recognised as a special value. | |
108 | ||
109 | RETURN-TYPE should be a valid type. | |
110 | ||
111 | A normal element of ARGS is a list matching | |
112 | ||
113 | (EXPR TYPE &OPTIONAL (STYLE :IN) (OUT-TYPE TYPE)) | |
114 | ||
115 | however a shorthand form for an input parameter with name the same as its type | |
116 | is that you can just give the atom TYPE as an argument. The lambda-list for the | |
117 | function is the list of all input arguments, although if an EXPR is repeated, it | |
118 | will only appear once. To add a constant argument, define one with STYLE :IN and | |
119 | EXPR the value it should take. | |
120 | ||
121 | To give the binding a docstring, pass a string as the first element of ARGS." | |
beae6579 | 122 | (multiple-value-bind (lisp-name c-name) |
123 | (if (atom name) | |
124 | (values name (default-alien-fname name)) | |
125 | (values-list name)) | |
126 | ||
127 | (let* ((lambda-list-supplied-p lambda-list) | |
128 | (lambda-list (unless (equal lambda-list '(nil)) lambda-list)) | |
2c708568 | 129 | (arg-types ()) |
130 | (aux-bindings ()) | |
beae6579 | 131 | (doc-string (when (stringp (first args)) (pop args))) |
132 | (parsed-args | |
133 | (mapcar | |
134 | #'(lambda (arg) | |
135 | (destructuring-bind | |
2c708568 | 136 | (expr type &optional (style :in) (out-type type)) |
137 | (if (atom arg) | |
138 | (list arg arg) | |
139 | arg) | |
beae6579 | 140 | (cond |
141 | ((find style '(:in-out :return)) | |
142 | (warn "Deprecated argument style: ~S" style)) | |
143 | ((not (find style '(:in :out :in/out :in/return))) | |
144 | (error "Bogus argument style: ~S" style))) | |
145 | (when (and | |
146 | (not lambda-list-supplied-p) | |
2c708568 | 147 | (namep expr) (in-arg-p style) |
148 | (not (find expr lambda-list))) | |
149 | (push expr lambda-list) | |
150 | (push type arg-types)) | |
beae6579 | 151 | (let ((aux (unless (or (not (in-arg-p style)) (namep expr)) |
152 | (gensym)))) | |
153 | (when aux | |
2c708568 | 154 | (push (list aux expr) aux-bindings)) |
beae6579 | 155 | (list |
156 | (cond | |
157 | ((and (namep expr) (not (in-arg-p style))) expr) | |
02198d7d | 158 | ((namep expr) |
159 | #-clisp(make-symbol (string expr)) | |
160 | ;; The above used to work in CLISP, but I'm | |
161 | ;; not sure exactly at which version it | |
162 | ;; broke. The following could potentially | |
163 | ;; cause variable capturing | |
164 | #+clisp(intern (format nil "~A-~A" (string expr) (gensym)))) | |
165 | (#-clisp(gensym) | |
166 | #+clisp(intern (string (gensym))))) | |
beae6579 | 167 | (or aux expr) type style out-type)))) |
168 | args))) | |
169 | ||
170 | (%defbinding c-name lisp-name | |
171 | (if lambda-list-supplied-p lambda-list (nreverse lambda-list)) | |
2c708568 | 172 | (not lambda-list-supplied-p) (nreverse arg-types) |
173 | aux-bindings return-type doc-string parsed-args)))) | |
beae6579 | 174 | |
175 | ||
176 | #+(or cmu sbcl) | |
177 | (defun foreign-funcall (cname args return-type) | |
178 | (let ((fparams (loop | |
179 | for (var expr type style out-type) in args | |
180 | collect (if (out-arg-p style) | |
181 | `(addr ,var) | |
182 | var))) | |
183 | (ftypes (loop | |
184 | for (var expr type style out-type) in args | |
185 | collect (if (out-arg-p style) | |
186 | `(* ,(alien-type out-type)) | |
187 | (alien-type out-type)))) | |
188 | (fname (make-symbol cname))) | |
189 | `(with-alien ((,fname (function ,(alien-type return-type) ,@ftypes) :extern ,cname)) | |
190 | (alien-funcall ,fname ,@fparams)))) | |
191 | ||
192 | #+clisp | |
193 | (defun foreign-funcall (cname args return-type) | |
194 | (let* ((fparams (loop | |
195 | for (var expr type style out-type) in args | |
196 | collect (if (out-arg-p style) | |
197 | `(ffi:c-var-address ,var) | |
198 | var))) | |
199 | (fargs (loop | |
200 | for (var expr type style out-type) in args | |
201 | collect (list var (if (out-arg-p style) | |
202 | 'ffi:c-pointer | |
203 | (alien-type out-type))))) | |
204 | (c-function `(ffi:c-function | |
205 | (:arguments ,@fargs) | |
206 | (:return-type ,(alien-type return-type)) | |
207 | (:language :stdc)))) | |
208 | `(funcall | |
209 | (load-time-value | |
4f2a8644 | 210 | (ffi::foreign-library-function |
211 | ,cname (ffi::foreign-library :default) #?(clisp>= 2 40)nil | |
beae6579 | 212 | nil (ffi:parse-c-type ',c-function))) |
213 | ,@fparams))) | |
214 | ||
215 | ||
216 | ;; TODO: check if in and out types (if different) translates to same | |
217 | ;; alien type | |
2c708568 | 218 | (defun %defbinding (cname lisp-name lambda-list declare-p arg-types aux-bindings return-type doc args) |
beae6579 | 219 | (let ((out (loop |
220 | for (var expr type style out-type) in args | |
221 | when (or (out-arg-p style) (return-arg-p style)) | |
222 | collect (from-alien-form out-type var))) | |
223 | (fcall (from-alien-form return-type | |
224 | (foreign-funcall cname args return-type)))) | |
225 | ||
226 | (labels ((create-wrapper (args body) | |
227 | (if args | |
228 | (destructuring-bind (var expr type style out-type) (first args) | |
229 | (declare (ignore out-type)) | |
230 | (alien-arg-wrapper type var expr style | |
231 | (create-wrapper (rest args) body))) | |
232 | body))) | |
2c708568 | 233 | `(progn |
234 | ,(when declare-p | |
235 | `(declaim | |
236 | (ftype | |
237 | (function | |
238 | ,(mapcar #'argument-type arg-types) | |
239 | (values | |
240 | ,@(when return-type (list (return-type return-type))) | |
241 | ,@(loop | |
242 | for (var expr type style out-type) in args | |
243 | when (out-arg-p style) | |
244 | collect (return-type out-type) | |
245 | when (return-arg-p style) | |
cab97f15 | 246 | collect (return-type type)))) |
247 | ,lisp-name))) | |
2c708568 | 248 | (defun ,lisp-name ,lambda-list |
beae6579 | 249 | ,doc |
2c708568 | 250 | (let ,aux-bindings |
beae6579 | 251 | ,(if return-type |
252 | (create-wrapper args `(values ,fcall ,@out)) | |
2c708568 | 253 | (create-wrapper args `(progn ,fcall (values ,@out)))))))))) |
beae6579 | 254 | |
255 | ||
256 | ||
257 | ;;;; Dynamic (runtime) bindings | |
258 | ||
259 | (defun mkbinding (name return-type &rest arg-types) | |
260 | #+cmu(declare (optimize (inhibit-warnings 3))) | |
261 | #+sbcl(declare (muffle-conditions compiler-note)) | |
262 | (let* ((c-function | |
263 | #+(or cmu sbcl) | |
264 | `(function ,@(mapcar #'alien-type (cons return-type arg-types))) | |
265 | #+clisp | |
266 | `(ffi:c-function | |
267 | (:arguments ,@(mapcar | |
268 | #'(lambda (type) | |
269 | (list (gensym) (alien-type type))) | |
270 | arg-types)) | |
271 | (:return-type ,(alien-type return-type)) | |
272 | (:language :stdc))) | |
273 | (foreign | |
274 | #+(or cmu sbcl) | |
275 | (handler-bind (#+sbcl(compiler-note #'(lambda (condition) | |
276 | (declare (ignore condition)) | |
277 | (muffle-warning)))) | |
278 | (%heap-alien | |
279 | (make-heap-alien-info | |
280 | :type (parse-alien-type c-function #+sbcl nil) | |
281 | :sap-form (let ((address (foreign-symbol-address name))) | |
282 | (etypecase address | |
283 | (integer (int-sap address)) | |
284 | (system-area-pointer address)))))) | |
285 | #+clisp | |
286 | (ffi::foreign-library-function name | |
4f2a8644 | 287 | (ffi::foreign-library :default) #?(clisp>= 2 40)nil |
beae6579 | 288 | nil (ffi:parse-c-type c-function))) |
289 | (return-value-translator (from-alien-function return-type))) | |
290 | (multiple-value-bind (arg-translators cleanup-funcs) | |
291 | (let ((translator/cleanup-pairs | |
292 | (mapcar | |
293 | #'(lambda (type) | |
294 | (multiple-value-list (to-alien-function type))) | |
295 | arg-types))) | |
296 | (values | |
297 | (mapcar #'first translator/cleanup-pairs) | |
298 | (mapcar #'second translator/cleanup-pairs))) | |
299 | #'(lambda (&rest args) | |
300 | (let ((translated-args (mapcar #'funcall arg-translators args))) | |
301 | (prog1 | |
302 | (funcall return-value-translator | |
303 | #+(or cmu sbcl)(apply #'alien-funcall foreign translated-args) | |
304 | #+clisp(apply foreign translated-args)) | |
305 | (mapc | |
306 | #'(lambda (cleanup arg translated-arg) | |
307 | (when cleanup | |
308 | (funcall cleanup arg translated-arg))) | |
309 | cleanup-funcs args translated-args))))))) | |
310 | ||
311 | ||
312 | ||
313 | ;;;; C Callbacks | |
314 | ||
315 | (defun callback-body (args return-type body) | |
316 | (labels ((create-wrappers (args body) | |
317 | (if args | |
318 | (destructuring-bind (var type) (first args) | |
319 | (callback-wrapper type var var | |
320 | (create-wrappers (rest args) body))) | |
321 | body)) | |
322 | (create-body (args body) | |
323 | (to-alien-form return-type | |
324 | (create-wrappers args `(progn ,@body))))) | |
325 | (if (and (consp (first body)) (eq (caar body) 'declare)) | |
326 | (let ((ignored (loop | |
327 | for declaration in (cdar body) | |
328 | when (eq (first declaration) 'ignore) | |
329 | nconc (rest declaration)))) | |
330 | `(,(first body) | |
331 | ,(create-body | |
332 | (remove-if #'(lambda (arg) | |
333 | (find (first arg) ignored)) | |
334 | args) | |
335 | (rest body)))) | |
336 | (list (create-body args body))))) | |
337 | ||
338 | ||
339 | #+(or cmu sbcl) | |
340 | (defmacro define-callback (name return-type args &body body) | |
341 | (let ((define-callback | |
342 | #+cmu'alien:def-callback | |
343 | #+(and sbcl alien-callbacks)'sb-alien::define-alien-callback | |
c52ab022 | 344 | #+(and sbcl (not alien-callbacks))'sb-alien:define-alien-function) |
345 | (args (mapcar #'(lambda (arg) | |
346 | (if (atom arg) (list arg arg) arg)) | |
347 | args))) | |
beae6579 | 348 | `(progn |
349 | #+cmu(defparameter ,name nil) | |
350 | (,define-callback ,name | |
351 | #+(and sbcl alien-callbacks) ,(alien-type return-type) | |
352 | (#+(or cmu (and sbcl (not alien-callbacks))),(alien-type return-type) | |
353 | ,@(loop | |
354 | for (name type) in args | |
355 | collect `(,name ,(alien-type type)))) | |
356 | ,@(callback-body args return-type body))))) | |
357 | ||
358 | #+(or cmu sbcl) | |
359 | (defun callback-address (callback) | |
360 | #+cmu(alien::callback-trampoline callback) | |
361 | #+(and sbcl (not alien-callbacks))(sb-alien:alien-function-sap callback) | |
362 | #+(and sbcl alien-callbacks)(sb-alien:alien-sap callback)) | |
363 | ||
364 | #+sbcl | |
365 | (deftype callback () | |
366 | #-alien-callbacks'sb-alien:alien-function | |
367 | #+alien-callbacks'sb-alien:alien) | |
368 | ||
369 | ||
370 | ;;; The callback code for CLISP is based on code from CFFI | |
371 | ;;; Copyright (C) 2005, James Bielman <jamesjb@jamesjb.com> | |
372 | ;;; (C) 2005, Joerg Hoehle <hoehle@users.sourceforge.net> | |
373 | ||
374 | ||
375 | ;;; *CALLBACKS* contains the callbacks defined by the %DEFCALLBACK | |
376 | ;;; macro. The symbol naming the callback is the key, and the value | |
377 | ;;; is a list containing a Lisp function, the parsed CLISP FFI type of | |
378 | ;;; the callback, and a saved pointer that should not persist across | |
379 | ;;; saved images. | |
380 | #+clisp | |
381 | (progn | |
382 | (defvar *callbacks* (make-hash-table)) | |
383 | ||
384 | ;;; Return a CLISP FFI function type for a CFFI callback function | |
385 | ;;; given a return type and list of argument names and types. | |
386 | (eval-when (:compile-toplevel :load-toplevel :execute) | |
387 | (defun callback-type (return-type arg-names arg-types) | |
388 | (ffi:parse-c-type | |
389 | `(ffi:c-function | |
390 | (:arguments ,@(mapcar (lambda (sym type) | |
391 | (list sym (alien-type type))) | |
392 | arg-names arg-types)) | |
393 | (:return-type ,(alien-type return-type)) | |
394 | (:language :stdc))))) | |
395 | ||
396 | ;;; Register and create a callback function. | |
397 | (defun register-callback (name function parsed-type) | |
398 | (setf (gethash name *callbacks*) | |
399 | (list function parsed-type | |
400 | (ffi:with-foreign-object (ptr 'ffi:c-pointer) | |
401 | ;; Create callback by converting Lisp function to foreign | |
402 | (setf (ffi:memory-as ptr parsed-type) function) | |
403 | (ffi:foreign-value ptr))))) | |
404 | ||
405 | ;;; Restore all saved callback pointers when restarting the Lisp | |
406 | ;;; image. This is pushed onto CUSTOM:*INIT-HOOKS*. | |
407 | ;;; Needs clisp > 2.35, bugfix 2005-09-29 | |
408 | (defun restore-callback-pointers () | |
409 | (maphash | |
410 | (lambda (name list) | |
411 | (register-callback name (first list) (second list))) | |
412 | *callbacks*)) | |
413 | ||
414 | ;;; Add RESTORE-CALLBACK-POINTERS to the lists of functions to run | |
415 | ;;; when an image is restarted. | |
416 | (eval-when (:load-toplevel :execute) | |
417 | (pushnew 'restore-callback-pointers custom:*init-hooks*)) | |
418 | ||
419 | ;;; Define a callback function NAME to run BODY with arguments | |
420 | ;;; ARG-NAMES translated according to ARG-TYPES and the return type | |
421 | ;;; translated according to RETTYPE. Obtain a pointer that can be | |
422 | ;;; passed to C code for this callback by calling %CALLBACK. | |
423 | (defmacro define-callback (name return-type args &body body) | |
c52ab022 | 424 | (let* ((args (mapcar #'(lambda (arg) |
425 | (if (atom arg) (list arg arg) arg)) | |
426 | args)) | |
427 | (arg-names (mapcar #'first args)) | |
428 | (arg-types (mapcar #'second args))) | |
beae6579 | 429 | `(progn |
430 | (defvar ,name ',name) | |
431 | (register-callback ',name | |
432 | (lambda ,arg-names ,@(callback-body args return-type body)) | |
433 | ,(callback-type return-type arg-names arg-types))))) | |
434 | ||
435 | ;;; Look up the name of a callback and return a pointer that can be | |
436 | ;;; passed to a C function. Signals an error if no callback is | |
437 | ;;; defined called NAME. | |
438 | (defun callback-address (name) | |
439 | (multiple-value-bind (list winp) (gethash name *callbacks*) | |
440 | (unless winp | |
441 | (error "Undefined callback: ~S" name)) | |
442 | (third list))) | |
443 | ||
444 | (deftype callback () 'symbol)) | |
445 | ||
446 | ||
447 | ||
448 | ;;;; Type expansion | |
449 | ||
f28952df RS |
450 | ;; A hack to make the TYPE-EXPAND code for SBCL work. |
451 | #?+(pkg-config:sbcl>= 1 0 35 15) | |
452 | (sb-ext:without-package-locks | |
453 | (setf (symbol-function 'sb-kernel::type-expand) | |
454 | (lambda (form) (typexpand form)))) | |
455 | ||
beae6579 | 456 | (defun type-expand-1 (form) |
457 | #+(or cmu sbcl) | |
458 | (let ((def (cond ((symbolp form) | |
459 | #+cmu(kernel::info type expander form) | |
460 | #+sbcl(sb-impl::info :type :expander form)) | |
461 | ((and (consp form) (symbolp (car form))) | |
462 | #+cmu(kernel::info type expander (car form)) | |
463 | #+sbcl(sb-impl::info :type :expander (car form))) | |
464 | (t nil)))) | |
465 | (if def | |
466 | (values (funcall def (if (consp form) form (list form))) t) | |
467 | (values form nil))) | |
468 | #+clisp(ext:type-expand form t)) | |
469 | ||
470 | (defun type-expand-to (type form) | |
471 | (labels ((expand (form0) | |
472 | (if (eq (first (mklist form0)) type) | |
473 | form0 | |
474 | (multiple-value-bind (expanded-form expanded-p) | |
475 | (type-expand-1 form0) | |
476 | (if expanded-p | |
477 | (expand expanded-form) | |
478 | (error "~A can not be expanded to ~A" form type)))))) | |
479 | (expand form))) | |
480 | ||
050b602e | 481 | (defun type-equal-p (type1 type2) |
482 | (and (subtypep type1 type2) (subtypep type2 type1))) | |
beae6579 | 483 | |
484 | ||
485 | ;;;; Type methods | |
486 | ||
2c708568 | 487 | (defun find-type-method (name type-spec &optional (error-p t)) |
488 | (let ((type-methods (get name 'type-methods)) | |
489 | (specifier (if (atom type-spec) | |
490 | type-spec | |
491 | (first type-spec)))) | |
492 | (or | |
493 | (gethash specifier type-methods) | |
494 | (when error-p | |
495 | (error | |
496 | "No explicit type method for ~A when call width type specifier ~A found" | |
497 | name type-spec))))) | |
498 | ||
beae6579 | 499 | (defun find-next-type-method (name type-spec &optional (error-p t)) |
500 | (let ((type-methods (get name 'type-methods))) | |
501 | (labels ((search-method-in-cpl-order (classes) | |
502 | (when classes | |
503 | (or | |
504 | (gethash (class-name (first classes)) type-methods) | |
505 | (search-method-in-cpl-order (rest classes))))) | |
506 | (lookup-method (type-spec) | |
507 | (if (and (symbolp type-spec) (find-class type-spec nil)) | |
508 | (let ((class (find-class type-spec))) | |
584285fb | 509 | #?(or (sbcl>= 0 9 15) (featurep :clisp)) |
beae6579 | 510 | (unless (class-finalized-p class) |
511 | (finalize-inheritance class)) | |
512 | (search-method-in-cpl-order | |
513 | (rest (class-precedence-list class)))) | |
514 | (multiple-value-bind (expanded-type expanded-p) | |
515 | (type-expand-1 type-spec) | |
516 | (when expanded-p | |
517 | (or | |
518 | (let ((specifier (etypecase expanded-type | |
519 | (symbol expanded-type) | |
520 | (list (first expanded-type))))) | |
521 | (gethash specifier type-methods)) | |
522 | (lookup-method expanded-type)))))) | |
523 | (search-built-in-type-hierarchy (sub-tree) | |
524 | (when (subtypep type-spec (first sub-tree)) | |
525 | (or | |
526 | (search-nodes (cddr sub-tree)) | |
527 | (second sub-tree)))) | |
528 | (search-nodes (nodes) | |
529 | (loop | |
530 | for node in nodes | |
531 | as method = (search-built-in-type-hierarchy node) | |
532 | until method | |
533 | finally (return method)))) | |
534 | (or | |
535 | (lookup-method type-spec) | |
536 | ;; This is to handle unexpandable types whichs doesn't name a | |
537 | ;; class. It may cause infinite loops with illegal | |
538 | ;; call-next-method calls | |
b673a77b | 539 | (unless (or |
540 | (null type-spec) | |
541 | (and (symbolp type-spec) (find-class type-spec nil))) | |
beae6579 | 542 | (search-nodes (get name 'built-in-type-hierarchy))) |
543 | (when error-p | |
544 | (error "No next type method ~A for type specifier ~A" | |
545 | name type-spec)))))) | |
546 | ||
547 | (defun find-applicable-type-method (name type-spec &optional (error-p t)) | |
2c708568 | 548 | (or |
549 | (find-type-method name type-spec nil) | |
550 | (find-next-type-method name type-spec nil) | |
551 | (when error-p | |
552 | (error | |
553 | "No applicable type method for ~A when call width type specifier ~A" | |
554 | name type-spec)))) | |
555 | ||
beae6579 | 556 | |
557 | (defun insert-type-in-hierarchy (specifier function nodes) | |
558 | (cond | |
559 | ((let ((node (find specifier nodes :key #'first))) | |
560 | (when node | |
561 | (setf (second node) function) | |
562 | nodes))) | |
563 | ((let ((node | |
564 | (find-if | |
565 | #'(lambda (node) | |
566 | (subtypep specifier (first node))) | |
567 | nodes))) | |
568 | (when node | |
569 | (setf (cddr node) | |
570 | (insert-type-in-hierarchy specifier function (cddr node))) | |
571 | nodes))) | |
572 | ((let ((sub-nodes (remove-if-not | |
573 | #'(lambda (node) | |
574 | (subtypep (first node) specifier)) | |
575 | nodes))) | |
576 | (cons | |
577 | (list* specifier function sub-nodes) | |
578 | (nset-difference nodes sub-nodes)))))) | |
579 | ||
580 | (defun add-type-method (name specifier function) | |
581 | (setf (gethash specifier (get name 'type-methods)) function) | |
582 | (when (typep (find-class specifier nil) 'built-in-class) | |
583 | (setf (get name 'built-in-type-hierarchy) | |
584 | (insert-type-in-hierarchy specifier function | |
585 | (get name 'built-in-type-hierarchy))))) | |
586 | ||
587 | ||
588 | (defmacro define-type-generic (name lambda-list &optional documentation) | |
589 | (let ((type-spec (first lambda-list))) | |
590 | (if (or | |
591 | (not lambda-list) | |
592 | (find type-spec '(&optional &key &rest &allow-other-keys))) | |
593 | (error "A type generic needs at least one required argument") | |
594 | `(progn | |
595 | (unless (get ',name 'type-methods) | |
596 | (setf (get ',name 'type-methods) (make-hash-table)) | |
597 | (setf (get ',name 'built-in-type-hierarchy) ())) | |
598 | ,(if (intersection '(&optional &key &rest &allow-other-keys) lambda-list) | |
599 | (let ((args (make-symbol "ARGS"))) | |
600 | `(defun ,name (,type-spec &rest ,args) | |
601 | ,documentation | |
602 | (apply | |
603 | (find-applicable-type-method ',name ,type-spec) | |
604 | ,type-spec ,args))) | |
605 | `(defun ,name ,lambda-list | |
606 | ,documentation | |
607 | (funcall | |
608 | (find-applicable-type-method ',name ,type-spec) | |
609 | ,@lambda-list))))))) | |
610 | ||
611 | ||
612 | (defmacro define-type-method (name lambda-list &body body) | |
613 | (let ((specifier (cadar lambda-list)) | |
614 | (args (make-symbol "ARGS"))) | |
615 | `(progn | |
616 | (add-type-method ',name ',specifier | |
617 | #'(lambda (&rest ,args) | |
618 | (flet ((call-next-method (&rest args) | |
619 | (let ((next-method (find-next-type-method ',name ',specifier))) | |
620 | (apply next-method (or args ,args))))) | |
621 | (destructuring-bind (,(caar lambda-list) ,@(rest lambda-list)) ,args | |
622 | ,@body)))) | |
623 | ',name))) | |
624 | ||
625 | ||
626 | ;;; Rules for auto-exporting symbols | |
627 | ||
628 | (defexport defbinding (name &rest args) | |
629 | (declare (ignore args)) | |
630 | (if (symbolp name) | |
631 | name | |
632 | (first name))) | |
633 | ||
634 | (defexport define-type-generic (name &rest args) | |
635 | (declare (ignore args)) | |
636 | name) |