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@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)))))