From d98ce0862e93c8082d1f3589f6cef9dd4e8837b3 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola <nikodemus@random-state.net> Date: Mon, 7 Jul 2008 11:55:06 +0300 Subject: [PATCH] implement PARSE-ORDINARY-LAMBDA-LIST --- macros.lisp | 121 +++++++++++++++++++++++++++++++++++++++++++++++++++ package.lisp | 1 + 2 files changed, 122 insertions(+) diff --git a/macros.lisp b/macros.lisp index f314448..309788b 100644 --- a/macros.lisp +++ b/macros.lisp @@ -78,3 +78,124 @@ arguments when given." (push (pop body) decls) (go :declarations))) (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 diff --git a/package.lisp b/package.lisp index d2924a4..51a1bef 100644 --- a/package.lisp +++ b/package.lisp @@ -114,6 +114,7 @@ ;; Macros #:once-only #:parse-body + #:parse-ordinary-lambda-list #:with-gensyms #:with-unique-names ;; Symbols -- GitLab