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