[movitz-cvs] CVS movitz/losp/muerte

[ffjeld]

Update of /project/movitz/cvsroot/movitz/losp/muerte
In directory clnet:/tmp/cvs-serv18531

Modified Files:
	eval.lisp 
Log Message:
Fix parse-docstring-declarations-and-body. Fix bug in decode-keyword-formal.


--- /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp	2008/04/27 08:38:01	1.33
+++ /project/movitz/cvsroot/movitz/losp/muerte/eval.lisp	2008/04/27 16:14:10	1.34
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Fri Oct 19 21:15:12 2001
 ;;;;                
-;;;; $Id: eval.lisp,v 1.33 2008/04/27 08:38:01 ffjeld Exp $
+;;;; $Id: eval.lisp,v 1.34 2008/04/27 16:14:10 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -149,11 +149,6 @@
 	((multiple-value-prog1)
 	 (multiple-value-prog1 (eval-form (cadr form) env)
 	   (eval-progn (cddr form) env)))
-	((destructuring-bind)
-	 (eval-progn (cdddr form)
-		     (make-destructuring-env (cadr form)
-					     (eval-form (caddr form) env)
-					     env)))
 	((catch)
 	 (catch (eval-form (second form) env)
 	   (eval-progn (cddr form) env)))
@@ -234,6 +229,26 @@
     (dolist (d (cdar p))
       (push d declarations))))
 
+(defun parse-docstring-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare))
+  "From the list of FORMS, return first the non-declarations forms, second the declarations, ~
+   and third the documentation string."
+  (let ((docstring nil))
+    (do (declarations docstring)
+	((endp forms)
+	 (values nil
+		 declarations
+		 docstring))
+      (cond
+	((typep (car forms)
+		'(cons (eql declare)))
+	 (setf declarations (append declarations (cdr (pop forms)))))
+	((and (stringp (car forms))
+	      (cdr forms))
+	 (setf docstring (pop forms)))
+	(t (return (values forms
+			   declarations
+			   docstring)))))))
+
 (defun parse-docstring-declarations-and-body (forms &optional (declare 'declare))
   "From the list of FORMS, return first the list of non-declaration forms, ~
 second the list of declaration-specifiers, third any docstring."
@@ -241,9 +256,9 @@
   (if (or (not (cdr forms))
 	  (not (stringp (car forms))))
       (parse-declarations-and-body forms)
-    (multiple-value-call #'values
-      (parse-declarations-and-body (cdr forms))
-      (car forms))))
+      (multiple-value-call #'values
+	(parse-declarations-and-body (cdr forms))
+	(car forms))))
 
 (defun compute-function-block-name (function-name)
   (cond
@@ -290,7 +305,9 @@
 Return the variable, keyword, init-fom, and supplied-p-parameter."
   (cond
    ((symbolp formal)
-    (values formal formal nil nil))
+    (values formal
+	    (intern (symbol-name formal) :keyword)
+	    nil nil))
    ((symbolp (car formal))
     (values (car formal)
 	    (intern (symbol-name (car formal)) :keyword)
@@ -302,8 +319,8 @@
 	      (caddr formal)))))
 
 (defun make-destructuring-env (pattern values env &key (recursive-p t)
-							      (environment-p nil)
-							      (whole-p t))
+			       (environment-p nil)
+			       (whole-p t))
   (let (env-var)
     (when (and whole-p (eq '&whole (car pattern)))
       (push (cons (cadr pattern) values)
@@ -381,12 +398,12 @@
 	 (push (cons (cdr pp) values)
 	       env))
        finally
-	 (when (and values (member state '(requireds optionals)))
-	   (simple-program-error "Too many arguments.")))
+       (when (and values (member state '(requireds optionals)))
+	 (simple-program-error "Too many arguments.")))
     (if (and environment-p env-var)
 	(cons (cons env-var env)
 	      env)
-      env)))
+	env)))
 
 (defun eval-let (var-specs declarations-and-body env)
   (let (special-vars
@@ -579,7 +596,8 @@
     (values (if (not name)
 		function
 	      (setf (symbol-function name) function))
-	    t nil)))
+	    nil
+	    nil)))
 
 (defun macroexpand-1 (form &optional env)
   (if (atom form)