1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
3 ;;; --- RETURN* wrappers.
6 (in-package :iolib.base
)
8 (cl:defmacro defun
(name args
&body body
)
9 `(,(find-right-symbol :defun
:series
)
10 ,name
,args
,@(wrap-body-for-return-star body name
)))
12 (cl:defmacro defmethod
(name method-qualifier args
&body body
)
14 ;; no method qualifier, this is actually the lambda-list
15 ((listp method-qualifier
)
16 (setf body
(cons args body
)
17 args method-qualifier
)
18 `(,(find-right-symbol :defmethod
)
19 ,name
,args
,@(wrap-body-for-return-star body name
)))
21 `(,(find-right-symbol :defmethod
) ,name
22 ,method-qualifier
,args
,@(wrap-body-for-return-star body name
)))))
24 (cl:defmacro lambda
* (args &body body
)
25 `(,(find-right-symbol :lambda
)
26 ,args
,@(wrap-body-for-return-star body
)))
28 (cl:defmacro defmacro
(name args
&body body
)
29 `(,(find-right-symbol :defmacro
)
30 ,name
,args
,@(wrap-body-for-return-star body name
)))
32 (cl:defmacro define-compiler-macro
(name args
&body body
)
33 `(,(find-right-symbol :define-compiler-macro
)
34 ,name
,args
,@(wrap-body-for-return-star body name
)))
36 (cl:defun
find-right-symbol (name &rest packages
)
37 (multiple-value-bind (symbol foundp
)
38 (if (eql (find-symbol (string name
) *package
*)
39 (find-symbol (string name
) :iolib.base
))
40 ;; NAME has been imported from IOLIB.UTILS, so we must
41 ;; find a default somewhere else, defaulting to the CL package
42 (find-symbol (string name
) (find-right-package packages
))
43 ;; use the symbol named NAME from the *PACKAGE* or CL
44 (find-symbol (string name
) (find-right-package (package-name *package
*))))
45 (assert foundp
(symbol) "Couldn't find any symbol as default for ~S" name
)
48 (cl:defun
find-right-package (packages)
49 (dolist (pkg (ensure-list packages
) :common-lisp
)
50 (when (member pkg
(package-use-list *package
*)
55 (cl:defun
wrap-body-for-return-star (body &optional block-name
)
56 (multiple-value-bind (body declarations docstring
)
57 (parse-body body
:documentation t
)
63 `(macrolet ((return* (value) `(return-from ,',block-name
,value
)))
65 (with-gensyms (block-name)
67 (macrolet ((return* (value) `(return-from ,',block-name
,value
)))