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 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 name)))
  20     (t
  21      `(,(find-right-symbol :defmethod) ,name
  22         ,method-qualifier ,args ,@(wrap-body-for-return-star body name)))))
  23
  24 (cl:defmacro lambda* (args &body body)
  25   `(,(find-right-symbol :lambda)
  26      ,args ,@(wrap-body-for-return-star body)))
  27
  28 (cl:defmacro defmacro (name args &body body)
  29   `(,(find-right-symbol :defmacro)
  30      ,name ,args ,@(wrap-body-for-return-star body name)))
  31
  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)))
  35
  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)
  46     (values symbol)))
  47
  48 (cl:defun find-right-package (packages)
  49   (dolist (pkg (ensure-list packages) :common-lisp)
  50     (when (member pkg (package-use-list *package*)
  51                   :key #'package-name
  52                   :test #'string-equal)
  53       (return pkg))))
  54
  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)
  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))))))))