Skip to content
Snippets Groups Projects
Commit d98ce086 authored by Nikodemus Siivola's avatar Nikodemus Siivola
Browse files

implement PARSE-ORDINARY-LAMBDA-LIST

parent e94589dd
No related branches found
No related tags found
No related merge requests found
...@@ -78,3 +78,124 @@ arguments when given." ...@@ -78,3 +78,124 @@ arguments when given."
(push (pop body) decls) (push (pop body) decls)
(go :declarations))) (go :declarations)))
(values body (nreverse decls) doc))) (values body (nreverse decls) doc)))
(defun parse-ordinary-lambda-list (lambda-list)
"Parses an ordinary lambda-list, returning as multiple values:
1. Required parameters.
2. Optional parameter specifications, normalized into form (NAME INIT SUPPLIEDP)
where SUPPLIEDP is NIL if not present.
3. Name of the rest parameter, or NIL.
4. Keyword parameter specifications, normalized into form ((KEYWORD-NAME NAME) INIT SUPPLIEDP)
where SUPPLIEDP is NIL if not present.
5. Boolean indicating &ALLOW-OTHER-KEYS presence.
6. &AUX parameter specifications, normalized into form (NAME INIT).
Signals a PROGRAM-ERROR is the lambda-list is malformed."
(let ((state :required)
(allow-other-keys nil)
(auxp nil)
(required nil)
(optional nil)
(rest nil)
(keys nil)
(aux nil))
(labels ((fail (elt)
(simple-program-error "Misplaced ~S in ordinary lambda-list:~% ~S"
elt lambda-list))
(check-variable (elt what)
(unless (and (symbolp elt) (not (constantp elt)))
(simple-program-error "Invalid ~A ~S in ordinary lambda-list:~% ~S"
what elt lambda-list)))
(check-spec (spec what)
(destructuring-bind (init suppliedp) spec
(declare (ignore init))
(check-variable suppliedp what))))
(dolist (elt lambda-list)
(case elt
(&optional
(if (eq state :required)
(setf state elt)
(fail elt)))
(&rest
(if (member state '(:required &optional))
(setf state elt)
(progn
(break "state=~S" state)
(fail elt))))
(&key
(if (member state '(:required &optional :after-rest))
(setf state elt)
(fail elt)))
(&allow-other-keys
(if (eq state '&key)
(setf allow-other-keys t
state elt)
(fail elt)))
(&aux
(cond ((eq state '&rest)
(fail elt))
(auxp
(simple-program-error "Multiple ~S in ordinary lambda-list:~% ~S"
elt lambda-list))
(t
(setf auxp t
state elt))
))
(otherwise
(when (member elt '#.(set-difference lambda-list-keywords
'(&optional &rest &key &allow-other-keys &aux)))
(simple-program-error
"Bad lambda-list keyword ~S in ordinary lambda-list:~% ~S"
elt lambda-list))
(case state
(:required
(check-variable elt "required parameter")
(push elt required))
(&optional
(cond ((consp elt)
(destructuring-bind (name &rest tail) elt
(check-variable name "optional parameter")
(if (cdr tail)
(check-spec tail "optional-supplied-p parameter")
(setf elt (append elt '(nil))))))
(t
(check-variable elt "optional parameter")
(setf elt (cons elt '(nil nil)))))
(push elt optional))
(&rest
(check-variable elt "rest parameter")
(setf rest elt
state :after-rest))
(&key
(cond ((consp elt)
(destructuring-bind (var-or-kv &rest tail) elt
(cond ((consp var-or-kv)
(destructuring-bind (keyword var) var-or-kv
(unless (symbolp keyword)
(simple-program-error "Invalid keyword name ~S in ordinary ~
lambda-list:~% ~S"
keyword lambda-list))
(check-variable var "keyword parameter")))
(t
(check-variable var-or-kv "keyword parameter")
(setf var-or-kv (list (make-keyword var-or-kv) var-or-kv))))
(if (cdr tail)
(check-spec tail "keyword-supplied-p parameter")
(setf tail (append tail '(nil))))
(setf elt (cons var-or-kv tail))))
(t
(check-variable elt "keyword parameter")
(setf elt (list (list (make-keyword elt) elt) nil nil))))
(push elt keys))
(&aux
(if (consp elt)
(destructuring-bind (var &optional init) elt
(declare (ignore init))
(check-variable var "&aux parameter"))
(check-variable elt "&aux parameter"))
(push elt aux))
(t
(simple-program-error "Invalid ordinary lambda-list:~% ~S" lambda-list)))))))
(values (nreverse required) (nreverse optional) rest (nreverse keys)
allow-other-keys (nreverse aux))))
\ No newline at end of file
...@@ -114,6 +114,7 @@ ...@@ -114,6 +114,7 @@
;; Macros ;; Macros
#:once-only #:once-only
#:parse-body #:parse-body
#:parse-ordinary-lambda-list
#:with-gensyms #:with-gensyms
#:with-unique-names #:with-unique-names
;; Symbols ;; Symbols
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment