Forked from
cmucl / cmucl
10548 commits behind the upstream repository.
defmacro.lisp 14.50 KiB
;;; -*- Log: code.log; Mode: Lisp; Package: Lisp -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/defmacro.lisp,v 1.12 1991/02/08 13:31:57 ram Exp $")
;;;
;;; **********************************************************************
;;;
;;; Written by Blaine Burks.
;;;
(in-package "LISP")
;;;; Some variable definitions.
;;; Variables for amassing the results of parsing a defmacro. Declarations
;;; in DEFMACRO are the reason this isn't as easy as it sounds.
;;;
(defvar *arg-tests* ()
"A list of tests that do argument counting at expansion time.")
(defvar *system-lets* ()
"Let bindings that are done to make lambda-list parsing possible.")
(defvar *user-lets* ()
"Let bindings that the user has explicitly supplied.")
(defvar *default-default* nil
"Unsupplied optional and keyword arguments get this value defaultly.")
;;;; Stuff to parse DEFMACRO, MACROLET, DEFINE-SETF-METHOD, and DEFTYPE.
;;; PARSE-DEFMACRO returns, as multiple-values, a body, possibly a declare
;;; form to put where this code is inserted, and the documentation for the
;;; parsed body.
;;;
(defun parse-defmacro (lambda-list arg-list-name code name error-kind
&key (annonymousp nil)
(doc-string-allowed t)
((:environment env-arg-name))
((:default-default *default-default*))
(error-fun 'error))
"Returns as multiple-values a parsed body, any local-declarations that
should be made where this body is inserted, and a doc-string if there is
one."
(multiple-value-bind (body declarations documentation)
(parse-body code nil doc-string-allowed)
(let* ((*arg-tests* ())
(*user-lets* ())
(*system-lets* ()))
(multiple-value-bind
(env-arg-used minimum maximum)
(parse-defmacro-lambda-list lambda-list arg-list-name name
error-kind error-fun (not annonymousp)
nil env-arg-name)
(values
`(let* ,(nreverse *system-lets*)
,@*arg-tests*
(let* ,(nreverse *user-lets*)
,@declarations
,@body))
(if (and env-arg-name (not env-arg-used))
`((declare (ignore ,env-arg-name)))
nil)