Skip to content
Snippets Groups Projects
Commit 080ba947 authored by ram's avatar ram
Browse files

Use ASSERT-DEFINITION-TYPE in local FTYPE declarations.

In global FTYPE declarations, ignore declarations on slot accessors.
parent 7d79a3b7
No related branches found
No related tags found
No related merge requests found
...@@ -7,7 +7,7 @@ ...@@ -7,7 +7,7 @@
;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;; ;;;
(ext:file-comment (ext:file-comment
"$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.56 1991/11/05 14:38:43 ram Exp $") "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/ir1tran.lisp,v 1.57 1991/11/08 15:24:33 ram Exp $")
;;; ;;;
;;; ********************************************************************** ;;; **********************************************************************
;;; ;;;
...@@ -762,22 +762,22 @@ ...@@ -762,22 +762,22 @@
;;; being bound, we must also deal with declarations that constrain the type of ;;; being bound, we must also deal with declarations that constrain the type of
;;; lexically apparent functions. ;;; lexically apparent functions.
;;; ;;;
;;; [### In the non-pervasive case, we should propagate type constraints into
;;; the function getting the declaration. We should also think about checking
;;; for incompatible declarations and possibly intersecting the declared
;;; types.]
;;;
(defun process-ftype-declaration (spec res names fvars) (defun process-ftype-declaration (spec res names fvars)
(declare (list spec names fvars) (type lexenv res)) (declare (list spec names fvars) (type lexenv res))
(let ((type (specifier-type spec))) (let ((type (specifier-type spec)))
(collect ((res nil cons)) (collect ((res nil cons))
(dolist (name names) (dolist (name names)
(let ((found (find name fvars :key #'leaf-name))) (let ((found (find name fvars :key #'leaf-name)))
(if found (cond
(setf (leaf-type found) type) (found
(res (cons (find-lexically-apparent-function (setf (leaf-type found) type)
name "in a function type declaration") (assert-definition-type found type
type))))) :warning-function #'compiler-note
:where "FTYPE declaration"))
(t
(res (cons (find-lexically-apparent-function
name "in a function type declaration")
type))))))
(if (res) (if (res)
(make-lexenv :default res :type-restrictions (res)) (make-lexenv :default res :type-restrictions (res))
res)))) res))))
...@@ -2517,6 +2517,7 @@ ...@@ -2517,6 +2517,7 @@
(let ((var (gethash (define-function-name name) *free-functions*))) (let ((var (gethash (define-function-name name) *free-functions*)))
(etypecase var (etypecase var
(null) (null)
(slot-accessor)
(global-var (global-var
(let ((new (copy-global-var var)) (let ((new (copy-global-var var))
(name (leaf-name var))) (name (leaf-name var)))
......
0% Loading or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment