Update of /project/movitz/cvsroot/movitz In directory common-lisp.net:/tmp/cvs-serv8352
Modified Files: assembly-syntax.lisp Log Message: Make assembly-macroexpand not barf on non-proper lists.
Date: Wed Apr 21 11:05:40 2004 Author: ffjeld
Index: movitz/assembly-syntax.lisp diff -u movitz/assembly-syntax.lisp:1.2 movitz/assembly-syntax.lisp:1.3 --- movitz/assembly-syntax.lisp:1.2 Mon Jan 19 06:23:41 2004 +++ movitz/assembly-syntax.lisp Wed Apr 21 11:05:39 2004 @@ -9,7 +9,7 @@ ;;;; Created at: Thu Nov 9 17:34:37 2000 ;;;; Distribution: See the accompanying file COPYING. ;;;; -;;;; $Id: assembly-syntax.lisp,v 1.2 2004/01/19 11:23:41 ffjeld Exp $ +;;;; $Id: assembly-syntax.lisp,v 1.3 2004/04/21 15:05:39 ffjeld Exp $ ;;;; ;;;;------------------------------------------------------------------
@@ -25,29 +25,21 @@ (setf (gethash symbol (assembly-macro-environment-expanders amenv)) expander))
-;;;(defun assembly-macroexpand (prg amenv) -;;; (cond -;;; ((and (consp prg) (symbolp (car prg))) -;;; (let ((expander (assembly-macro-expander (car prg) amenv))) -;;; (if expander -;;; (assembly-macroexpand (funcall expander prg) amenv) -;;; #0=(cons (assembly-macroexpand (car prg) amenv) -;;; (assembly-macroexpand (cdr prg) amenv))))) -;;; ((consp prg) #0#) -;;; (t prg))) - (defun assembly-macroexpand (prg amenv) - (loop for p in prg - as expander = (and (consp p) - (symbolp (car p)) - (assembly-macro-expander (car p) amenv)) - if expander - append (funcall expander p) - else if (consp p) - append (list (assembly-macroexpand p amenv)) - else append (list p))) - -;;;(defmacro with-assembly-syntax (&body body) -;;; `(let ((*readtable* (copy-readtable nil))) -;;; (set-dispatch-macro-character + (let* ((fix-tail nil) + (new-prg + (loop for (p . tail) on prg + as expander = (and (consp p) + (symbolp (car p)) + (assembly-macro-expander (car p) amenv)) + if expander + append (funcall expander p) + else if (consp p) + append (list (assembly-macroexpand p amenv)) + else append (list p) + unless (listp tail) + do (setf fix-tail tail)))) + (when fix-tail + (setf (cdr (last new-prg)) fix-tail)) + new-prg))