[Openmcl-cvs-notifications] r12530 - in /trunk/source: compiler/nx0.lisp level-1/l1-streams.lisp

[gz at clozure.com]

Author: gz
Date: Tue Aug  4 12:38:46 2009
New Revision: 12530

Log:
Merge fixes in ftype support (r12525, r12529)

Modified:
    trunk/source/compiler/nx0.lisp
    trunk/source/level-1/l1-streams.lisp

Modified: trunk/source/compiler/nx0.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/nx0.lisp (original)
+++ trunk/source/compiler/nx0.lisp Tue Aug  4 12:38:46 2009
@@ -683,8 +683,8 @@
                       (integerp (%cadr acode-expression))))
            (%cadr acode-expression)))))
 =

-(defun specifier-type-if-known (typespec &optional env &key whine)
-  (handler-case (specifier-type typespec env)
+(defun specifier-type-if-known (typespec &optional env &key whine values)
+  (handler-case (if values (values-specifier-type typespec env) (specifier=
-type typespec env))
     (parse-unknown-type (c) =

       (when (and whine *compiler-warn-on-undefined-type-references*)
 	(nx1-whine :undefined-type typespec))
@@ -1972,14 +1972,15 @@
 =

 (defun find-ftype-decl (sym &optional (env *nx-lexical-environment*))
   (setq sym (maybe-setf-function-name sym))
-  (loop =

-    (when (listp env)
-      (return (and (symbolp sym)
-                   (proclaimed-ftype sym))))
+  (loop
+    (when (listp env) (return  (proclaimed-ftype sym)))
     (dolist (fdecl (lexenv.fdecls env))
       (when (and (eq (car fdecl) sym)
                  (eq (car (%cdr fdecl)) 'ftype))
         (return-from find-ftype-decl (%cddr fdecl))))
+    (when (and (istruct-typep env 'lexical-environment)
+               (assq sym (lexenv.functions env)))
+      (return-from find-ftype-decl nil))
     (setq env (lexenv.parent-env env))))
 =

 (defun nx1-analyze-ftyped-call (ftype sym arglist spread-p env)
@@ -1999,11 +2000,16 @@
 	      (bad-keys nil)
 	      (nargs (if spread-p (1- (length arglist)) (length arglist))))
 	  (flet ((collect-type (arg type)
-		   (push (if (and type (neq type *universal-type*) (neq type *wild-type*=
))
-			   `(the ,(type-specifier type) ,arg)
-			   arg)
-			 typed-arglist))
-		 (key-name (x) (key-info-name x))
+		   (push (if (and type
+                                  (neq type *universal-type*)
+                                  (neq type *wild-type*)
+                                  (setq type (type-specifier type))
+                                  ;; Don't record unknown types, just caus=
es spurious warnings.
+                                  (specifier-type-if-known type env :value=
s t))
+                             `(the ,type ,arg)
+                             arg)
+                         typed-arglist))
+                 (key-name (x) (key-info-name x))
 		 (whine (&rest reason)
 		   (nx1-whine :ftype-mismatch sym reason arglist spread-p)
 		   (setq errors-p t)))

Modified: trunk/source/level-1/l1-streams.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-streams.lisp (original)
+++ trunk/source/level-1/l1-streams.lisp Tue Aug  4 12:38:46 2009
@@ -345,7 +345,7 @@
 (defmethod interactive-stream-p ((stream stream)) nil)
 =

 (defmethod stream-clear-input ((x t))
-  (report-bad-arg x 'stream))
+  (report-bad-arg x 'input-stream))
 =

 (defmethod stream-clear-input ((stream input-stream)) nil)
 =