X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fmacros.lisp;h=baec9382f55a137527920f67e64986d3539e491e;hb=dea9bd5c1afe23d9e061c60db654b88187ba9a5e;hp=e2fc870b75824c306607dc71883b85caa1c09b19;hpb=f5133ab2ffcddbcdb330cbbceff3af8d66673ce8;p=sbcl.git

diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp
index e2fc870..baec938 100644
--- a/src/pcl/macros.lisp
+++ b/src/pcl/macros.lisp
@@ -44,42 +44,6 @@
 
 (/show "done with DECLAIM DECLARATION")
 
-;;; FIXME: This looks like SBCL's PARSE-BODY, and should be shared.
-(eval-when (:compile-toplevel :load-toplevel :execute)
-
-(defun extract-declarations (body &optional environment)
-  ;;(declare (values documentation declarations body))
-  (let (documentation
-        declarations
-        form)
-    (when (and (stringp (car body))
-               (cdr body))
-      (setq documentation (pop body)))
-    (block outer
-      (loop
-        (when (null body) (return-from outer nil))
-        (setq form (car body))
-        (when (block inner
-                (loop (cond ((not (listp form))
-                             (return-from outer nil))
-                            ((eq (car form) 'declare)
-                             (return-from inner t))
-                            (t
-                             (multiple-value-bind (newform macrop)
-                                  (macroexpand-1 form environment)
-                               (if (or (not (eq newform form)) macrop)
-                                   (setq form newform)
-                                 (return-from outer nil)))))))
-          (pop body)
-          (dolist (declaration (cdr form))
-            (push declaration declarations)))))
-    (values documentation
-            (and declarations `((declare ,.(nreverse declarations))))
-            body)))
-) ; EVAL-WHEN
-
-(/show "done with EVAL-WHEN (..) DEFUN EXTRACT-DECLARATIONS")
-
 (defun get-declaration (name declarations &optional default)
   (dolist (d declarations default)
     (dolist (form (cdr d))
@@ -88,18 +52,14 @@
 
 (/show "pcl/macros.lisp 85")
 
-(defmacro doplist ((key val) plist &body body &environment env)
-  (multiple-value-bind (doc decls bod)
-      (extract-declarations body env)
-    (declare (ignore doc))
-    `(let ((.plist-tail. ,plist) ,key ,val)
-       ,@decls
-       (loop (when (null .plist-tail.) (return nil))
-	     (setq ,key (pop .plist-tail.))
-	     (when (null .plist-tail.)
-	       (error "malformed plist, odd number of elements"))
-	     (setq ,val (pop .plist-tail.))
-	     (progn ,@bod)))))
+(defmacro doplist ((key val) plist &body body)
+  `(let ((.plist-tail. ,plist) ,key ,val)
+     (loop (when (null .plist-tail.) (return nil))
+	   (setq ,key (pop .plist-tail.))
+	   (when (null .plist-tail.)
+	     (error "malformed plist, odd number of elements"))
+	   (setq ,val (pop .plist-tail.))
+	   (progn ,@body))))
 
 (/show "pcl/macros.lisp 101")
 
@@ -256,66 +216,4 @@
 
 (defsetf slot-value set-slot-value)
 
-(defun misplaced-lambda-list-keyword (lambda-list keyword)
-  (error "Lambda list keyword ~S is misplaced in ~S." keyword lambda-list))
-
-(defmacro process-lambda-list (lambda-list &rest clauses)
-  ;; (process-lambda-list '(a b &optional (c 1))
-  ;;                      (&required)
-  ;;                      ((&optional (print "Started processing optional arguments"))
-  ;;                       (format "Optional argument: ~S~%" it))
-  ;;                      (&rest (print "Rest")))
-  (let ((clauses (loop for clause in clauses
-                    collect
-                      (cond ((symbolp (car clause))
-                             `(,(car clause) nil . ,(cdr clause)))
-                            ((consp (car clause))
-                             `(,(caar clause) ,(cdar clause) . ,(cdr clause)))
-                            (t (error "Invalid clause format: ~S." clause)))))
-        (ll (gensym "LL"))
-        (state (gensym "STATE"))
-        (restp (gensym "RESTP"))
-        (check-state (gensym "CHECK-STATE")))
-    `(let ((,ll ,lambda-list)
-           (,state '&required)
-           (,restp nil))
-       (dolist (it ,ll)
-         (flet ((,check-state (possible)
-                  (unless (memq ,state possible)
-                    (misplaced-lambda-list-keyword ,ll it))))
-           (cond ((memq it lambda-list-keywords)
-                  (case it
-                    (&optional (,check-state '(&required))
-                               ,@(cadr (assoc '&optional clauses)))
-                    (&rest (,check-state '(&required &optional))
-                           ,@(cadr (assoc '&rest clauses)))
-                    (&key (,check-state '(&required &optional &rest))
-                          (when (and (eq ,state '&rest)
-                                     (not ,restp))
-                            (error "Omitted &REST variable in ~S." ,ll))
-                          ,@(cadr (assoc '&key clauses)))
-                    (&allow-other-keys (,check-state '(&key))
-                                       ,@(cadr (assoc '&allow-other-keys clauses)))
-                    (&aux (when (and (eq ,state '&rest)
-                                     (not ,restp))
-                            (error "Omitted &REST variable in ~S." ,ll))
-                          ,@(cadr (assoc '&aux clauses)))
-                    (t (error "Unsupported lambda list keyword ~S in ~S."
-                              it ,ll)))
-                  (setq ,state it))
-                 (t (case ,state
-                      (&required ,@(cddr (assoc '&required clauses)))
-                      (&optional ,@(cddr (assoc '&optional clauses)))
-                      (&rest (when ,restp
-                               (error "Too many variables after &REST in ~S." ,ll))
-                             (setq ,restp t)
-                             ,@(cddr (assoc '&rest clauses)))
-                      (&key ,@(cddr (assoc '&key clauses)))
-                      (&allow-other-keys (error "Variable ~S after &ALLOW-OTHER-KEY in ~S."
-                                                it ,ll))
-                      (&aux ,@(cddr (assoc '&aux clauses))))))))
-       (when (and (eq ,state '&rest)
-                  (not ,restp))
-         (error "Omitted &REST variable in ~S." ,ll)))))
-
 (/show "finished with pcl/macros.lisp")