1 ;;; -*- Mode: Lisp -*- 2 3 ;;; lambda-list-parsing.lisp -- 4 5 ;;;; See file COPYING for copyright licensing information. 6 7 (in-package "UNIFY") 8 9 10 (declaim (inline type-is-t-p)) 11 12 (defun type-is-t-p (type-spec) 13 (nth-value 0 (and (subtypep type-spec t) (subtypep t type-spec)))) 14 15 16 (declaim (inline type-specifier-p)) 17 18 (defun type-specifier-p (x) 19 (nth-value 0 (ignore-errors (subtypep x t)))) 20 21 (defun normalize-lambda-list (lambda-list) 22 (mapcar (lambda (lambda-element) 23 (etypecase lambda-element 24 (symbol lambda-element) 25 (cons (first lambda-element)))) 26 lambda-list)) 27 28 29 (defstruct lambda-var-info 30 (name nil :read-only t) 31 (type t :read-only t) 32 ) 33 34 (defstruct (optional-lambda-var-info (:include lambda-var-info)) 35 (default-value nil :read-only t) 36 (name-for-supplied-indicator nil :read-only t) 37 ) 38 39 (defstruct (aux-lambda-var-info (:include optional-lambda-var-info))) 40 41 (defstruct (key-lambda-var-info (:include optional-lambda-var-info)) 42 (keyword-name nil :read-only t) 43 ) 44 45 (defstruct (rest-lambda-var-info (:include lambda-var-info) 46 (:constructor make-rest-lambda-var-info (&key 47 name 48 (type 'list) 49 (element-type t)))) 50 (element-type t :read-only t) 51 ) 52 53 ;;; The next function is really implementation-dependent, give the 54 ;;; definition of LAMBDA-LIST-KEYWORDS. 55 56 57 (define-condition lambda-list-parsing-error (program-error) 58 ((item :reader lambda-list-parsing-error-item 59 :initarg :item) 60 ) 61 (:report (lambda (llpe stream) 62 (format stream "Error while parsing an extended lambda-list (at ~S.)" 63 (lambda-list-parsing-error-item llpe)))) 64 ) 65 66 67 (defun symbol-or-cons-p (x) 68 (or (symbolp x) (consp x))) 69 70 71 (defun parse-extended-ordinary-lambda-list (lambda-list 72 &key 73 (ordinary-variable-test #'symbolp) 74 (optional-variable-test #'symbol-or-cons-p) 75 (rest-variable-test #'symbolp) 76 (key-variable-test #'symbol-or-cons-p) 77 (aux-variable-test #'symbol-or-cons-p) 78 ) 79 (let ((vars ()) 80 (optionals ()) 81 (keywords ()) 82 (rest ()) 83 (auxiliary ()) 84 ) 85 (labels ((parse-named-arguments (lambda-list &aux (head (first lambda-list))) 86 (cond ((null lambda-list) nil) 87 ((and (symbolp head) 88 (member head lambda-list-keywords)) 89 (case head 90 (&optional (parse-optional-arguments (rest lambda-list))) 91 (&key (parse-keyword-arguments (rest lambda-list))) 92 (&aux (parse-auxiliary-arguments (rest lambda-list))) 93 (&rest (parse-rest-arguments (rest lambda-list))) 94 (otherwise 95 (warn "Keyword ~A is implementation dependent.~@ 96 The parsing may not work properly." 97 head) 98 (skip-until-next-lambda-list-keyword (rest lambda-list)) 99 )) 100 ) 101 ((funcall ordinary-variable-test head) 102 (push head vars) 103 (parse-named-arguments (rest lambda-list))) 104 (t (error 'lambda-list-parsing-error :item head)) 105 )) 106 107 (parse-optional-arguments (lambda-list &aux (head (first lambda-list))) 108 (cond ((null lambda-list) nil) 109 ((and (symbolp head) 110 (member head lambda-list-keywords)) 111 (case head 112 (&optional (error 'lambda-list-parsing-error :item head)) 113 (&key (parse-keyword-arguments (rest lambda-list))) 114 (&aux (parse-auxiliary-arguments (rest lambda-list))) 115 (&rest (parse-rest-arguments (rest lambda-list))) 116 (otherwise 117 (warn "Keyword ~A is implementation dependent.~@ 118 The parsing may not work properly." 119 head) 120 (skip-until-next-lambda-list-keyword (rest lambda-list)) 121 )) 122 ) 123 ((funcall optional-variable-test head) 124 (push head optionals) 125 (parse-optional-arguments (rest lambda-list))) 126 (t (error 'lambda-list-parsing-error :item head)) 127 )) 128 129 (parse-keyword-arguments (lambda-list &aux (head (first lambda-list))) 130 (cond ((null lambda-list) nil) 131 ((and (symbolp head) 132 (member head lambda-list-keywords)) 133 (case head 134 (&optional (error 'lambda-list-parsing-error :item head)) 135 (&key (error 'lambda-list-parsing-error :item head)) 136 (&aux (parse-auxiliary-arguments (rest lambda-list))) 137 (&rest (parse-rest-arguments (rest lambda-list))) 138 (&allow-other-keys 139 (unless (or (null (rest lambda-list)) 140 (eql (cadr lambda-list) '&aux)) 141 (error 'lambda-list-parsing-error :item head)) 142 (skip-until-next-lambda-list-keyword (rest lambda-list))) 143 (otherwise 144 (warn "Keyword ~A is implementation dependent.~@ 145 The parsing may not work properly." 146 head) 147 (skip-until-next-lambda-list-keyword (rest lambda-list)) 148 )) 149 ) 150 ((funcall key-variable-test head) 151 (push head keywords) 152 (parse-keyword-arguments (rest lambda-list))) 153 (t (error 'lambda-list-parsing-error :item head)) 154 )) 155 156 (parse-rest-arguments (lambda-list &aux (head (first lambda-list))) 157 (cond ((null lambda-list) nil) 158 ((consp head) 159 (push head rest) 160 ;; Error checking here. 161 (parse-rest-arguments (rest lambda-list))) 162 ((and (symbolp head) 163 (member head lambda-list-keywords)) 164 (case head 165 (&optional (error 'lambda-list-parsing-error :item head)) 166 (&key (parse-keyword-arguments (rest lambda-list))) 167 (&aux (parse-auxiliary-arguments (rest lambda-list))) 168 (&rest (error 'lambda-list-parsing-error :item head)) 169 (otherwise 170 (warn "Keyword ~A is implementation dependent.~@ 171 The parsing may not work properly." 172 head) 173 (skip-until-next-lambda-list-keyword (rest lambda-list)) 174 )) 175 ) 176 ((funcall rest-variable-test head) 177 (push head rest) 178 (parse-rest-arguments (rest lambda-list))) 179 (t (error 'lambda-list-parsing-error :item head)) 180 )) 181 182 (parse-auxiliary-arguments (lambda-list &aux (head (first lambda-list))) 183 (cond ((null lambda-list) nil) 184 ((and (symbolp head) 185 (member head lambda-list-keywords)) 186 (case head 187 (&optional (error 'lambda-list-parsing-error :item head)) 188 (&key (error 'lambda-list-parsing-error :item head)) 189 (&aux (error 'lambda-list-parsing-error :item head)) 190 (&rest (error 'lambda-list-parsing-error :item head)) 191 (otherwise 192 (warn "Keyword ~A is implementation dependent.~@ 193 The parsing may not work properly." 194 head) 195 (skip-until-next-lambda-list-keyword (rest lambda-list)) 196 )) 197 ) 198 ((funcall aux-variable-test head) 199 (push head auxiliary) 200 (parse-auxiliary-arguments (rest lambda-list))) 201 (t (error 'lambda-list-parsing-error :item head)) 202 )) 203 204 (skip-until-next-lambda-list-keyword (lambda-list 205 &aux (head (first lambda-list))) 206 (cond ((null lambda-list) nil) 207 ((and (symbolp head) 208 (member head lambda-list-keywords)) 209 (case head 210 (&optional (parse-optional-arguments (rest lambda-list))) 211 (&key (parse-keyword-arguments (rest lambda-list))) 212 (&aux (parse-auxiliary-arguments (rest lambda-list))) 213 (&rest (parse-rest-arguments (rest lambda-list))) 214 (otherwise 215 (warn "Keyword ~A is implementation dependent.~@ 216 The parsing may not work properly." 217 head) 218 (skip-until-next-lambda-list-keyword (rest lambda-list)) 219 )) 220 ) 221 ((symbol-or-cons-p head) 222 (skip-until-next-lambda-list-keyword (rest lambda-list))) 223 )) 224 ) 225 (parse-named-arguments lambda-list) 226 (values (nreverse vars) 227 (nreverse optionals) 228 (nreverse keywords) 229 (nreverse rest) 230 (nreverse auxiliary)) 231 ))) 232 233 234 (defun parse-var-type-info (var) 235 (etypecase var 236 (symbol (make-lambda-var-info :name var)) 237 (cons (make-lambda-var-info :name (first var) :type (second var))))) 238 239 240 (defun parse-optional-var-type-info (var) 241 (etypecase var 242 (symbol (make-optional-lambda-var-info :name var)) 243 (cons (etypecase (first var) 244 (symbol (if (second var) ; special case (foo nil) and (foo) 245 (make-optional-lambda-var-info 246 :name (first var) 247 :type (or (and (constantp (second var)) (type-of (second var))) 248 t)) 249 (make-optional-lambda-var-info :name (first var)))) 250 (cons (make-optional-lambda-var-info 251 :name (caar var) 252 :type (cadar var) 253 :default-value (cadr var))) 254 )) 255 )) 256 257 258 (defun parse-auxiliary-var-type-info (var) 259 (parse-optional-var-type-info var)) 260 261 (defun parse-rest-var-type-info (var) ; See the FUNCTION type ANSI spec for an explanation. 262 (etypecase var 263 (symbol (make-rest-lambda-var-info :name var)) 264 (cons (make-rest-lambda-var-info :name (first var) :element-type (second var))))) 265 266 267 (defun parse-key-var-type-info (var) 268 (etypecase var 269 (symbol (make-key-lambda-var-info :name var)) 270 (cons (destructuring-bind (var &optional (init-value nil init-value-supplied-p)) 271 var 272 (let ((init-value-type 273 (if init-value-supplied-p 274 (or (and (constantp init-value) (type-of init-value)) 275 t) 276 t)) 277 ) 278 (etypecase var 279 (symbol (make-key-lambda-var-info :name var 280 :type init-value-type 281 :default-value init-value)) 282 283 (cons (destructuring-bind (kwd var) 284 var 285 (etypecase var 286 (symbol 287 (make-key-lambda-var-info :name var 288 :default-value init-value 289 :type init-value-type 290 :keyword-name kwd)) 291 (cons 292 (make-key-lambda-var-info :name (first var) 293 :default-value init-value 294 :type (second var) 295 :keyword-name kwd)))) 296 )) 297 ))) 298 )) 299 300 301 ;;; end of file -- lambda-list-parsing.lisp --