[movitz-cvs] CVS update: movitz/parse.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz
In directory common-lisp.net:/tmp/cvs-serv29832

Modified Files:
	parse.lisp 
Log Message:
Cleaned up parsing functions and translate-program a bit, so it
should now work more reliably, also on CLisp.

Date: Thu Dec  9 15:09:59 2004
Author: ffjeld

Index: movitz/parse.lisp
diff -u movitz/parse.lisp:1.4 movitz/parse.lisp:1.5
--- movitz/parse.lisp:1.4	Wed Nov 24 11:02:59 2004
+++ movitz/parse.lisp	Thu Dec  9 15:09:58 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Nov 24 16:49:17 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: parse.lisp,v 1.4 2004/11/24 10:02:59 ffjeld Exp $
+;;;; $Id: parse.lisp,v 1.5 2004/12/09 14:09:58 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -23,24 +23,20 @@
 (defun parse-declarations-and-body (forms &optional (declare-symbol 'muerte.cl::declare))
   "From the list of FORMS, return first the list of non-declaration forms, ~
    second the list of declaration-specifiers."
-  (loop for form on forms
-      while (declare-form-p (car form) declare-symbol)
-      append (cdar form) into declarations
-      finally (return (values form declarations))))
+  (loop for declaration-form = (when (declare-form-p (car forms) declare-symbol)
+				 (pop forms))
+     while declaration-form
+     append (cdr declaration-form) into declarations
+     finally (return (values forms 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."
-  (loop for rest-forms on forms
-      with docstring = nil
-      if (declare-form-p (first rest-forms) declare-symbol)
-      append (cdar rest-forms) into declarations
-      else if (and (null docstring)
-		   (not (endp (rest rest-forms)))
-		   (stringp (first rest-forms)))
-      do (setf docstring (first rest-forms))
-      else do (loop-finish)
-      finally (return (values rest-forms declarations docstring))))
+  (let ((docstring (when (and (cdr forms) (stringp (car forms)))
+		     (pop forms))))
+    (multiple-value-bind (body declarations)
+	(parse-declarations-and-body forms declare-symbol)
+      (values body declarations docstring))))
 
 (defun unfold-circular-list (list)
   "If LIST is circular (through cdr), return (a copy of) the non-circular portion of LIST, and the index (in LIST) of the cons-cell pointed to by (cdr (last LIST))."
@@ -54,11 +50,7 @@
 				cdr-index)))))
 
 (defun symbol-package-fix-cl (symbol)
-  *package*
-  #+ignore
-  (if (eq (find-package :cl) (symbol-package symbol))
-      (find-package :muerte.cl)
-    (symbol-package symbol)))
+  *package*)
 
 (eval-when (:execute :compile-toplevel :load-toplevel)
   (defun muerte::translate-program 
@@ -71,12 +63,18 @@
     (setf from-package (find-package from-package))
     (setf to-package (find-package to-package))
     (flet ((translate-symbol (s)
-	     (multiple-value-bind (symbol status)
-		 (find-symbol (symbol-name s) to-package)
-	       (if (eq :external status) symbol s))))
+	     (if (not (eq s (find-symbol (symbol-name s) from-package)))
+                 s
+	       (multiple-value-bind (symbol status)
+		   (find-symbol (symbol-name s) to-package)
+		 (when (or (and (find-symbol (symbol-name s) to-package)
+				(not (find-symbol (symbol-name s) from-package)))
+			   (and (find-symbol (symbol-name s) from-package)
+				(not (find-symbol (symbol-name s) to-package))))
+		   (error "blurgh ~S" s))
+		 (or symbol s) #+ignore (if (eq :external status) symbol s)))))
       (cond
-       ((and (symbolp program)		; single symbol?
-	     (eq (symbol-package program) from-package))
+       ((symbolp program)		; single symbol?
 	(translate-symbol program))
        ((simple-vector-p program)
 	(map 'vector
@@ -96,22 +94,6 @@
 	    (setf (cdr (last translated-program))
 	      (nthcdr cdr-index translated-program))
 	    translated-program)))
-       #+ignore ((and (eq quote-symbol (car program)) ; triple-quote?
-		      (consp (cadr program))
-		      (eq quote-symbol (caadr program))
-		      (consp (cadadr program))
-		      (eq quote-symbol (car (cadadr program))))
-		 (cons (translate-symbol (car program))
-		       (muerte::translate-program (rest program) from-package to-package
-							 :when when
-							 :remove-double-quotes-p remove-double-quotes-p
-							 :quote-symbol quote-symbol)))
-       #+ignore ((and (eq quote-symbol (car program)) ; double-quote?
-		      (consp (cadr program))
-		      (eq quote-symbol (caadr program)))
-		 (if remove-double-quotes-p
-		     (cadadr program)
-		   program))		; .. then don't mess with it.
        ((and (eq :translate-when (first program))
 	     (or (string= t (second program))
 		 (and when (eq when (second program)))))
@@ -119,8 +101,7 @@
        ((and (eq :translate-when (first program))
 	     (eq nil (second program)))
 	(third program))
-       ((and (symbolp (car program))
-	     (eq (symbol-package (car program)) from-package))
+       ((symbolp (car program))
 	(cons (translate-symbol (car program))
 	      (muerte::translate-program (cdr program) from-package to-package
 					 :when when
@@ -139,7 +120,11 @@
 		(muerte::translate-program (cdr program) from-package to-package
 					   :when when
 					   :remove-double-quotes-p remove-double-quotes-p
-					   :quote-symbol quote-symbol)))))))
+					   :quote-symbol quote-symbol))))))
+  (defun muerte::movitz-program (program)
+    (translate-program program :common-lisp :muerte.cl))
+  (defun muerte::host-program (program)
+    (translate-program program :muerte.cl :common-lisp)))
 
 (defun decode-normal-lambda-list (lambda-list &optional host-symbols-p)
   "3.4.1 Ordinary Lambda Lists.