org.armedbear.lisp.parse-lambda-list.lisp Maven / Gradle / Ivy
Go to download
Show more of this group Show more artifacts with this name
Show all versions of abcl Show documentation
Show all versions of abcl Show documentation
Common Lisp implementation running on the JVM
;;; parse-lambda-list.lisp
;;;
;;; Copyright (C) 2003-2005 Peter Graves
;;; $Id$
;;;
;;; This program is free software; you can redistribute it and/or
;;; modify it under the terms of the GNU General Public License
;;; as published by the Free Software Foundation; either version 2
;;; of the License, or (at your option) any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with this program; if not, write to the Free Software
;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
;;;
;;; As a special exception, the copyright holders of this library give you
;;; permission to link this library with independent modules to produce an
;;; executable, regardless of the license terms of these independent
;;; modules, and to copy and distribute the resulting executable under
;;; terms of your choice, provided that you also meet, for each linked
;;; independent module, the terms and conditions of the license of that
;;; module. An independent module is a module which is not derived from
;;; or based on this library. If you modify this library, you may extend
;;; this exception to your version of the library, but you are not
;;; obligated to do so. If you do not wish to do so, delete this
;;; exception statement from your version.
;;; Adapted from SBCL.
(in-package "SYSTEM")
(require '#:collect)
;;; Break something like a lambda list (but not necessarily actually a
;;; lambda list, e.g. the representation of argument types which is
;;; used within an FTYPE specification) into its component parts. We
;;; return 10 values:
;;; 1. a list of the required args;
;;; 2. a list of the &OPTIONAL arg specs;
;;; 3. true if a &REST arg was specified;
;;; 4. the &REST arg;
;;; 5. true if &KEY args are present;
;;; 6. a list of the &KEY arg specs;
;;; 7. true if &ALLOW-OTHER-KEYS was specified.;
;;; 8. true if any &AUX is present (new in SBCL vs. CMU CL);
;;; 9. a list of the &AUX specifiers;
;;; 10. true if any lambda list keyword is present (only for
;;; PARSE-LAMBDA-LIST-LIKE-THING).
;;;
;;; The top level lambda list syntax is checked for validity, but the
;;; arg specifiers are just passed through untouched. If something is
;;; wrong, we signal an error.
(defun parse-lambda-list-like-thing (list)
(collect ((required)
(optional)
(keys)
(aux))
(let ((restp nil)
(rest nil)
(keyp nil)
(auxp nil)
(allowp nil)
(state :required))
(declare (type (member :allow-other-keys :aux
:key
:optional
:post-rest
:required :rest)
state))
(dolist (arg list)
(if (and (symbolp arg)
(let ((name (symbol-name (the symbol arg))))
(and (plusp (length name))
(char= (char name 0) #\&))))
(case arg
(&optional
(unless (eq state :required)
(error "misplaced &OPTIONAL in lambda list: ~S" list))
(setq state :optional))
(&rest
(unless (member state '(:required :optional))
(error "misplaced &REST in lambda list: ~S" list))
(setq state :rest))
(&key
(unless (member state
'(:required :optional :post-rest))
(error "misplaced &KEY in lambda list: ~S" list))
(setq keyp t
state :key))
(&allow-other-keys
(unless (eq state ':key)
(error "misplaced &ALLOW-OTHER-KEYS in lambda list: ~S" list))
(setq allowp t
state :allow-other-keys))
(&aux
(when (eq state :rest)
(error "misplaced &AUX in lambda list: ~S" list))
(setq auxp t
state :aux))
;; FIXME: I don't think ANSI says this is an error. (It
;; should certainly be good for a STYLE-WARNING,
;; though.)
(t
(error "unknown &KEYWORD in lambda list: ~S" arg)))
(case state
(:required (required arg))
(:optional (optional arg))
(:rest
(setq restp t
rest arg
state :post-rest))
(:key (keys arg))
(:aux (aux arg))
(t
(error "found garbage in lambda list when expecting a keyword: ~S"
arg)))))
(when (eq state :rest)
(error "&REST without rest variable"))
(values (required) (optional) restp rest keyp (keys) allowp auxp (aux)
(neq state :required)))))
;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument
;;; really *is* a lambda list, not just a "lambda-list-like thing", so
;;; can barf on things which're illegal as arguments in lambda lists
;;; even if they could conceivably be legal in not-quite-a-lambda-list
;;; weirdosities
(defun parse-lambda-list (lambda-list)
;; Classify parameters without checking their validity individually.
(multiple-value-bind (required optional restp rest keyp keys allowp auxp aux)
(parse-lambda-list-like-thing lambda-list)
;; Check validity of parameters.
(flet ((need-symbol (x why)
(unless (symbolp x)
(error "~A is not a symbol: ~S" why x))))
(dolist (i required)
(need-symbol i "Required argument"))
(dolist (i optional)
(typecase i
(symbol)
(cons
(destructuring-bind (var &optional init-form supplied-p) i
(declare (ignore init-form supplied-p))
(need-symbol var "&OPTIONAL parameter name")))
(t
(error "&OPTIONAL parameter is not a symbol or cons: ~S" i))))
(when restp
(need-symbol rest "&REST argument"))
(when keyp
(dolist (i keys)
(typecase i
(symbol)
(cons
(destructuring-bind (var-or-kv &optional init-form supplied-p) i
(declare (ignore init-form supplied-p))
(if (consp var-or-kv)
(destructuring-bind (keyword-name var) var-or-kv
(declare (ignore keyword-name))
(need-symbol var "&KEY parameter name"))
(need-symbol var-or-kv "&KEY parameter name"))))
(t
(error "&KEY parameter is not a symbol or cons: ~S" i))))))
;; Voila.
(values required optional restp rest keyp keys allowp auxp aux)))