src/base/return-star.lisp

   1 ;;;; -*- Mode: Lisp; indent-tabs-mode: nil -*-
   2 ;;;
   3 ;;; --- RETURN* wrappers.
   4 ;;;
   5
   6 (in-package :iolib/base)
   7
   8 (cl:defmacro defun (name args &body body)
   9   `(,(find-right-symbol :defun :series)
  10      ,name ,args ,@(wrap-body-for-return-star body name)))
  11
  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
  19     (t
  20      `(,(find-right-symbol :defmethod) ,name
  21         ,args ,(car body) ,@(wrap-body-for-return-star (cdr body) name)))))
  22
  23 (cl:defmacro lambda* (args &body body)
  24   `(,(find-right-symbol :lambda)
  25      ,args ,@(wrap-body-for-return-star body)))
  26
  27 (cl:defmacro defmacro (name args &body body)
  28   `(,(find-right-symbol :defmacro)
  29      ,name ,args ,@(wrap-body-for-return-star body name)))
  30
  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)))
  34
  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)))
  46
  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))))
  53
  54 (cl:defun wrap-body-for-return-star (body &optional block-name)
  55   (flet ((block-name (block)
  56            (etypecase block
  57              (cons (destructuring-bind (kind block-name) block
  58                      (assert (eql 'setf kind))
  59                      (check-type block-name symbol)
  60                      block-name))
  61              (symbol block))))
  62     (multiple-value-bind (body declarations docstring)
  63         (parse-body body :documentation t)
  64       (with-gensyms (value)
  65         (remove-if
  66          #'null
  67          `(,docstring
  68            ,@declarations
  69            ,(if block-name
  70                 `(macrolet ((return* (,value) `(return-from ,',(block-name block-name) ,,value)))
  71                    ,@body)
  72                 (with-gensyms (block)
  73                   `(block ,block
  74                      (macrolet ((return* (value) `(return-from ,',block ,value)))
  75                        ,@body))))))))))