Add or fix docstrings of syscalls.
[iolib.git] / base / return-star.lisp
blob9c83c5cee30d9ad6abc7687f0762e10822c605b1
1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; indent-tabs-mode: nil -*-
2 ;;;
3 ;;; --- RETURN* wrappers.
4 ;;;
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 args &body body)
13 (cond
14 ;; no method qualifier, this is actually the lambda-list
15 ((listp args)
16 `(,(find-right-symbol :defmethod)
17 ,name ,args ,@(wrap-body-for-return-star body name)))
18 ;; args is the method qualifier
20 `(,(find-right-symbol :defmethod) ,name
21 ,args ,(car body) ,@(wrap-body-for-return-star (cdr body) name)))))
23 (cl:defmacro lambda* (args &body body)
24 `(,(find-right-symbol :lambda)
25 ,args ,@(wrap-body-for-return-star body)))
27 (cl:defmacro defmacro (name args &body body)
28 `(,(find-right-symbol :defmacro)
29 ,name ,args ,@(wrap-body-for-return-star body name)))
31 (cl:defmacro define-compiler-macro (name args &body body)
32 `(,(find-right-symbol :define-compiler-macro)
33 ,name ,args ,@(wrap-body-for-return-star body name)))
35 (cl:defun find-right-symbol (name &rest packages)
36 (multiple-value-bind (symbol foundp)
37 (if (eql (find-symbol (string name) *package*)
38 (find-symbol (string name) :iolib.base))
39 ;; NAME has been imported from IOLIB.UTILS, so we must
40 ;; find a default somewhere else, defaulting to the CL package
41 (find-symbol (string name) (find-right-package packages))
42 ;; use the symbol named NAME from the *PACKAGE* or CL
43 (find-symbol (string name) (find-right-package (package-name *package*))))
44 (assert foundp (symbol) "Couldn't find any symbol as default for ~S" name)
45 (values symbol)))
47 (cl:defun find-right-package (packages)
48 (dolist (pkg (ensure-list packages) :common-lisp)
49 (when (member pkg (package-use-list *package*)
50 :key #'package-name
51 :test #'string-equal)
52 (return pkg))))
54 (cl:defun wrap-body-for-return-star (body &optional block-name)
55 (multiple-value-bind (body declarations docstring)
56 (parse-body body :documentation t)
57 (with-gensyms (value)
58 (remove-if
59 #'null
60 `(,docstring
61 ,@declarations
62 ,(if block-name
63 `(macrolet ((return* (,value) `(return-from ,',block-name ,,value)))
64 ,@body)
65 (with-gensyms (block-name)
66 `(block ,block-name
67 (macrolet ((return* (value) `(return-from ,',block-name ,value)))
68 ,@body)))))))))