base/return-star.lisp

   1 ;;;; -*- Mode: Lisp; Syntax: ANSI-Common-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   (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)))))))))