From 8bab6de9c9487c24b5d4f79cf8b2615d1985b417 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Tue, 2 Jun 1992 19:42:04 +0000 Subject: [PATCH] In FUNCTION-CONTINUATION-TN, always annotate with the derived type (function), even if it isn't proven. --- compiler/ltn.lisp | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/compiler/ltn.lisp b/compiler/ltn.lisp index 28e3b26fb..e0761fc3c 100644 --- a/compiler/ltn.lisp +++ b/compiler/ltn.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ltn.lisp,v 1.31 1992/03/11 21:23:48 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ltn.lisp,v 1.32 1992/06/02 19:42:04 ram Exp $") ;;; ;;; ********************************************************************** ;;; @@ -163,16 +163,19 @@ (defun annotate-function-continuation (cont policy &optional (delay t)) (declare (type continuation cont) (type policies policy)) (unless (policy-safe-p policy) (flush-type-check cont)) - (let* ((ptype (primitive-type - (if (member (continuation-type-check cont) '(:deleted nil)) - (continuation-type cont) - (single-value-type (continuation-proven-type cont))))) + (let* ((ptype (primitive-type (continuation-type cont))) + (tn-ptype (if (member (continuation-type-check cont) '(:deleted nil)) + ptype + (primitive-type + (single-value-type + (continuation-proven-type cont))))) (info (make-ir2-continuation ptype))) (setf (continuation-info cont) info) (let ((name (continuation-function-name cont t))) (if (and delay name) (setf (ir2-continuation-kind info) :delayed) - (setf (ir2-continuation-locs info) (list (make-normal-tn ptype)))))) + (setf (ir2-continuation-locs info) + (list (make-normal-tn tn-ptype)))))) (undefined-value)) @@ -802,8 +805,7 @@ (funcall frob "Argument primitive types:~% ~S" (mapcar #'(lambda (x) (primitive-type-name - (ir2-continuation-primitive-type - (continuation-info x)))) + (continuation-ptype x))) (combination-args call))) (funcall frob "Argument type assertions:~% ~S" (mapcar #'(lambda (x) -- GitLab