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)))
  11
  12 (cl:defmacro defmethod (name method-qualifier args &body body)
  13   (cond
  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)))
  20     (t
  21      `(,(find-right-symbol :defmethod) ,name
  22         ,method-qualifier ,args ,@(wrap-body-for-return-star body)))))
  23
  24 (cl:defmacro defmacro (name args &body body)
  25   `(,(find-right-symbol :defmacro)
  26      ,name ,args ,@(wrap-body-for-return-star body)))
  27
  28 (cl:defmacro define-compiler-macro (name args &body body)
  29   `(,(find-right-symbol :define-compiler-macro)
  30      ,name ,args ,@(wrap-body-for-return-star body)))
  31
  32 (cl:defun find-right-symbol (name &rest packages)
  33   (multiple-value-bind (symbol foundp)
  34       (if (eql (find-symbol (string name) *package*)
  35                (find-symbol (string name) :iolib.base))
  36           ;; NAME has been imported from IOLIB.UTILS, so we must
  37           ;; find a default somewhere else, defaulting to the CL package
  38           (find-symbol (string name) (find-right-package packages))
  39           ;; use the symbol named NAME from the *PACKAGE* or CL
  40           (find-symbol (string name) (find-right-package (package-name *package*))))
  41     (assert foundp (symbol) "Couldn't find any symbol as default for ~S" name)
  42     (values symbol)))
  43
  44 (cl:defun find-right-package (packages)
  45   (dolist (pkg (ensure-list packages) :common-lisp)
  46     (when (member pkg (package-use-list *package*)
  47                   :key #'package-name
  48                   :test #'string-equal)
  49       (return pkg))))
  50
  51 (cl:defun wrap-body-for-return-star (body)
  52   (multiple-value-bind (body declarations docstring)
  53       (parse-body body :documentation t)
  54     (with-gensyms (return-star-block)
  55       (remove-if
  56        #'null
  57        `(,docstring
  58          ,@declarations
  59          (block ,return-star-block
  60            (macrolet
  61                ((return* (value)
  62                   `(return-from ,',return-star-block ,value)))
  63              ,@body)))))))