[movitz-cvs] CVS update: movitz/losp/muerte/read.lisp

[Frode Vatvedt Fjeld]

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

Modified Files:
	read.lisp 
Log Message:
Moved un-backquote to read.lisp.

Date: Wed Jul 21 07:15:43 2004
Author: ffjeld

Index: movitz/losp/muerte/read.lisp
diff -u movitz/losp/muerte/read.lisp:1.5 movitz/losp/muerte/read.lisp:1.6
--- movitz/losp/muerte/read.lisp:1.5	Thu Jul  8 06:38:15 2004
+++ movitz/losp/muerte/read.lisp	Wed Jul 21 07:15:43 2004
@@ -10,7 +10,7 @@
 ;;;; Author:        Frode Vatvedt Fjeld <frodef at acm.org>
 ;;;; Created at:    Wed Oct 17 21:50:42 2001
 ;;;;                
-;;;; $Id: read.lisp,v 1.5 2004/07/08 13:38:15 ffjeld Exp $
+;;;; $Id: read.lisp,v 1.6 2004/07/21 14:15:43 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -314,3 +314,55 @@
 ;;;      (error 'end-of-file :stream stream))
 ;;;     (t eof-value))))
 
+
+(defun un-backquote (form level)
+  "Dont ask.."
+  (declare (notinline un-backquote))
+  (assert (not (minusp level)))
+  (values
+   (typecase form
+     (null nil)
+     (list
+      (case (car form)
+	(backquote-comma
+	 (cadr form))
+	(t (cons 'append
+		 (loop for sub-form-head on form
+		     as sub-form = (and (consp sub-form-head)
+					(car sub-form-head))
+		     collecting
+		       (cond
+			((atom sub-form-head)
+			 (list 'quote sub-form-head))
+			((atom sub-form)
+			 (list 'quote (list sub-form)))
+			(t (case (car sub-form)
+			     (muerte::movitz-backquote
+			      (list 'list
+				    (list 'list (list 'quote 'muerte::movitz-backquote)
+					  (un-backquote-xxx (cadr sub-form) (1+ level)))))
+			     (backquote-comma
+			      (cond
+			       ((= 0 level)
+				(list 'list (cadr sub-form)))
+			       ((and (listp (cadr sub-form))
+				     (eq 'backquote-comma-at (caadr sub-form)))
+				(list 'append
+				      (list 'mapcar
+					    '(lambda (x) (list 'backquote-comma x))
+					    (cadr (cadr sub-form)))))
+			       (t (list 'list
+					(list 'list
+					      (list 'quote 'backquote-comma)
+					      (un-backquote-xxx (cadr sub-form) (1- level)))))))
+			     (backquote-comma-at
+			      (if (= 0 level)
+				  (cadr sub-form)
+				(list 'list
+				      (list 'list
+					    (list 'quote 'backquote-comma-at)
+					    (un-backquote-xxx (cadr sub-form) (1- level))))))
+			     (t (list 'list (un-backquote-xxx sub-form level)))))))))))
+     (array
+      (error "Array backquote not implemented."))
+     (t (list 'quote form)))))