diff --git a/compiler/ir1tran.lisp b/compiler/ir1tran.lisp index 8f82186b0add880c6f5150376a8ccb94502e7310..6f462d69f6ca8650f3c1b9f5e4c9a8a0e15dfda8 100644 --- a/compiler/ir1tran.lisp +++ b/compiler/ir1tran.lisp @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.155 2003/06/02 16:29:23 emarsden Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.156 2003/06/08 11:43:45 gerd Exp $") ;;; ;;; ********************************************************************** ;;; @@ -542,7 +542,6 @@ ;;;; IR1-CONVERT, macroexpansion and special-form dispatching. - (declaim (start-block ir1-convert ir1-convert-progn-body ir1-convert-combination-args reference-leaf reference-constant)) @@ -932,21 +931,30 @@ (find-free-variable var-name)))) (etypecase var (leaf - (let* ((old-type (or (lexenv-find var type-restrictions) - (leaf-type var))) - (int (if (or (function-type-p type) - (function-type-p old-type)) - type - (type-intersection old-type type)))) - (cond ((eq int *empty-type*) - (unless (policy nil (= brevity 3)) - (compiler-warning - "Conflicting type declarations ~S and ~S for ~S." - (type-specifier old-type) (type-specifier type) - var-name))) - (bound-var (setf (leaf-type bound-var) int)) - (t - (restr (cons var int)))))) + (flet ((process (var bound-var) + (let* ((old-type (or (lexenv-find var type-restrictions) + (leaf-type var))) + (int (if (or (function-type-p type) + (function-type-p old-type)) + type + (type-intersection old-type type)))) + (cond ((eq int *empty-type*) + (unless (policy nil (= brevity 3)) + (compiler-warning + "Conflicting type declarations ~ + ~S and ~S for ~S." + (type-specifier old-type) + (type-specifier type) + var-name))) + (bound-var + (setf (leaf-type bound-var) int)) + (t + (restr (cons var int))))))) + (process var bound-var) + (when (lambda-var-p var) + (let ((special (lambda-var-specvar var))) + (when special + (process special nil)))))) (cons (assert (eq (car var) 'MACRO)) (new-vars `(,var-name . (MACRO . (the ,(first decl)