When dealing with compiler-macros, ECL may enter an infinite loop.

This commit is contained in:
jjgarcia 2003-03-11 14:56:48 +00:00
parent c972e21255
commit e10ee7808b
3 changed files with 28 additions and 3 deletions

View file

@ -1194,6 +1194,9 @@ ECLS 0.9
- DESTRUCTURING-BIND fails to interpret &WHOLE arguments.
- The compiler might get into an infinite loop when dealing with
compiler-macros.
* Errors of the interpreter:
- CASE should use EQL to compare objects, not EQ.

View file

@ -86,8 +86,12 @@
(funcall fd args)))
((setq fd (macro-function fname))
(c1expr (cmp-expand-macro fd fname args)))
((setq fd (compiler-macro-function fname))
(c1expr (funcall fd (cons fname args) nil)))
((and (setq fd (compiler-macro-function fname))
(let ((success nil))
(multiple-value-setq (fd success)
(cmp-expand-compiler-macro fd fname args))
success))
(c1expr fd))
((and (setq fd (get fname 'SYS::STRUCTURE-ACCESS))
(inline-possible fname)
;;; Structure hack.
@ -95,8 +99,9 @@
(sys::fixnump (cdr fd))
(not (endp args))
(endp (cdr args)))
(print args *standard-output*)(terpri *standard-output*)
(case (car fd)
(VECTOR (c1expr `(svref ,(car args) ,(cdr fd)))) ; Beppe
(VECTOR (c1expr `(svref ,(car args) ,(cdr fd)))) ; Beppe3
(LIST (c1expr `(sys:list-nth ,(cdr fd) ,(car args))))
(t (c1structure-ref1 (car args) (car fd) (cdr fd)))
)

View file

@ -131,6 +131,23 @@
~%;;; You are recommended to compile again.~%"
fname)))))
(defun cmp-expand-compiler-macro (fd fname args &aux env (throw-flag t))
(dolist (v *funs*)
(when (consp v) (push v env)))
(when env (setq env (cons nil (nreverse env))))
(let ((form (cons fname args)))
(unwind-protect
(let ((new-form (cmp-toplevel-eval `(funcall *macroexpand-hook* ',fd ',form ',env))))
(setq throw-flag nil)
(values new-form (not (eql new-form form))))
(when throw-flag
(let ((*print-case* :upcase))
(print-current-form)
(format t
"~&;;; The macro form (~s ...) was not expanded successfully.~
~%;;; You are recommended to compile again.~%"
fname))))))
(defun cmp-toplevel-eval (form)
(let*
#-:CCL