1;;; parse-lambda-list.lisp 2;;; 3;;; Copyright (C) 2003-2005 Peter Graves 4;;; $Id$ 5;;; 6;;; This program is free software; you can redistribute it and/or 7;;; modify it under the terms of the GNU General Public License 8;;; as published by the Free Software Foundation; either version 2 9;;; of the License, or (at your option) any later version. 10;;; 11;;; This program is distributed in the hope that it will be useful, 12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 13;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 14;;; GNU General Public License for more details. 15;;; 16;;; You should have received a copy of the GNU General Public License 17;;; along with this program; if not, write to the Free Software 18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 19;;; 20;;; As a special exception, the copyright holders of this library give you 21;;; permission to link this library with independent modules to produce an 22;;; executable, regardless of the license terms of these independent 23;;; modules, and to copy and distribute the resulting executable under 24;;; terms of your choice, provided that you also meet, for each linked 25;;; independent module, the terms and conditions of the license of that 26;;; module. An independent module is a module which is not derived from 27;;; or based on this library. If you modify this library, you may extend 28;;; this exception to your version of the library, but you are not 29;;; obligated to do so. If you do not wish to do so, delete this 30;;; exception statement from your version. 31 32;;; Adapted from SBCL. 33 34(in-package "SYSTEM") 35 36(require '#:collect) 37 38;;; Break something like a lambda list (but not necessarily actually a 39;;; lambda list, e.g. the representation of argument types which is 40;;; used within an FTYPE specification) into its component parts. We 41;;; return 10 values: 42;;; 1. a list of the required args; 43;;; 2. a list of the &OPTIONAL arg specs; 44;;; 3. true if a &REST arg was specified; 45;;; 4. the &REST arg; 46;;; 5. true if &KEY args are present; 47;;; 6. a list of the &KEY arg specs; 48;;; 7. true if &ALLOW-OTHER-KEYS was specified.; 49;;; 8. true if any &AUX is present (new in SBCL vs. CMU CL); 50;;; 9. a list of the &AUX specifiers; 51;;; 10. true if any lambda list keyword is present (only for 52;;; PARSE-LAMBDA-LIST-LIKE-THING). 53;;; 54;;; The top level lambda list syntax is checked for validity, but the 55;;; arg specifiers are just passed through untouched. If something is 56;;; wrong, we signal an error. 57 58(defun parse-lambda-list-like-thing (list) 59 (collect ((required) 60 (optional) 61 (keys) 62 (aux)) 63 (let ((restp nil) 64 (rest nil) 65 (keyp nil) 66 (auxp nil) 67 (allowp nil) 68 (state :required)) 69 (declare (type (member :allow-other-keys :aux 70 :key 71 :optional 72 :post-rest 73 :required :rest) 74 state)) 75 (dolist (arg list) 76 (if (and (symbolp arg) 77 (let ((name (symbol-name (the symbol arg)))) 78 (and (plusp (length name)) 79 (char= (char name 0) #\&)))) 80 (case arg 81 (&optional 82 (unless (eq state :required) 83 (error "misplaced &OPTIONAL in lambda list: ~S" list)) 84 (setq state :optional)) 85 (&rest 86 (unless (member state '(:required :optional)) 87 (error "misplaced &REST in lambda list: ~S" list)) 88 (setq state :rest)) 89 (&key 90 (unless (member state 91 '(:required :optional :post-rest)) 92 (error "misplaced &KEY in lambda list: ~S" list)) 93 (setq keyp t 94 state :key)) 95 (&allow-other-keys 96 (unless (eq state ':key) 97 (error "misplaced &ALLOW-OTHER-KEYS in lambda list: ~S" list)) 98 (setq allowp t 99 state :allow-other-keys)) 100 (&aux 101 (when (eq state :rest) 102 (error "misplaced &AUX in lambda list: ~S" list)) 103 (setq auxp t 104 state :aux)) 105 ;; FIXME: I don't think ANSI says this is an error. (It 106 ;; should certainly be good for a STYLE-WARNING, 107 ;; though.) 108 (t 109 (error "unknown &KEYWORD in lambda list: ~S" arg))) 110 (case state 111 (:required (required arg)) 112 (:optional (optional arg)) 113 (:rest 114 (setq restp t 115 rest arg 116 state :post-rest)) 117 (:key (keys arg)) 118 (:aux (aux arg)) 119 (t 120 (error "found garbage in lambda list when expecting a keyword: ~S" 121 arg))))) 122 (when (eq state :rest) 123 (error "&REST without rest variable")) 124 125 (values (required) (optional) restp rest keyp (keys) allowp auxp (aux) 126 (neq state :required))))) 127 128;;; like PARSE-LAMBDA-LIST-LIKE-THING, except our LAMBDA-LIST argument 129;;; really *is* a lambda list, not just a "lambda-list-like thing", so 130;;; can barf on things which're illegal as arguments in lambda lists 131;;; even if they could conceivably be legal in not-quite-a-lambda-list 132;;; weirdosities 133(defun parse-lambda-list (lambda-list) 134 ;; Classify parameters without checking their validity individually. 135 (multiple-value-bind (required optional restp rest keyp keys allowp auxp aux) 136 (parse-lambda-list-like-thing lambda-list) 137 ;; Check validity of parameters. 138 (flet ((need-symbol (x why) 139 (unless (symbolp x) 140 (error "~A is not a symbol: ~S" why x)))) 141 (dolist (i required) 142 (need-symbol i "Required argument")) 143 (dolist (i optional) 144 (typecase i 145 (symbol) 146 (cons 147 (destructuring-bind (var &optional init-form supplied-p) i 148 (declare (ignore init-form supplied-p)) 149 (need-symbol var "&OPTIONAL parameter name"))) 150 (t 151 (error "&OPTIONAL parameter is not a symbol or cons: ~S" i)))) 152 (when restp 153 (need-symbol rest "&REST argument")) 154 (when keyp 155 (dolist (i keys) 156 (typecase i 157 (symbol) 158 (cons 159 (destructuring-bind (var-or-kv &optional init-form supplied-p) i 160 (declare (ignore init-form supplied-p)) 161 (if (consp var-or-kv) 162 (destructuring-bind (keyword-name var) var-or-kv 163 (declare (ignore keyword-name)) 164 (need-symbol var "&KEY parameter name")) 165 (need-symbol var-or-kv "&KEY parameter name")))) 166 (t 167 (error "&KEY parameter is not a symbol or cons: ~S" i)))))) 168 169 ;; Voila. 170 (values required optional restp rest keyp keys allowp auxp aux))) 171