Changeset 13214

Timestamp:

Nov 18, 2009, 11:17:43 AM (15 years ago)

Author:

gz

Message:

Extend find-ftype-decl so it can get different decls depending on the actual args, and made it do so in a few cases (including aref/uvref, so nx-form-type doesn't have to special-case them anymore).

Location:

branches/working-0711/ccl

Files:

• . (modified) (1 prop)
• compiler/nx-basic.lisp (modified) (1 diff)
• compiler/nx0.lisp (modified) (3 diffs)

branches/working-0711/ccl/compiler/nx-basic.lisp

@@ -352 +352 @@
     (if decl (%cdr decl) t)))
 
-(defun nx-declared-result-type (sym &optional (env *nx-lexical-environment*))
+(defun nx-declared-result-type (sym &optional (env *nx-lexical-environment*) args)
   (when (symbolp (setq sym (maybe-setf-function-name sym)))
-    (let* ((ftype (find-ftype-decl sym env))
-           (ctype (if (typep ftype 'ctype) ftype (specifier-type-if-known ftype env))))
+    (let* ((ftype (find-ftype-decl sym env args))
+           (ctype (and ftype (if (typep ftype 'ctype) ftype (specifier-type-if-known ftype env)))))
       (unless (or (null ctype)
                   (not (function-ctype-p ctype))

branches/working-0711/ccl/compiler/nx0.lisp

@@ -1985 +1985 @@
         (ftype nil)
         (def nil))
-    (setq ftype (find-ftype-decl sym env))
+    (setq ftype (find-ftype-decl sym env args spread-p))
     (setq def (nx1-find-call-def sym env global-only))
     (when ftype
@@ -2015 +2015 @@
     (values errors-p typed-args result-type)))
 
-(defun find-ftype-decl (sym &optional (env *nx-lexical-environment*))
+(defun known-ftype-for-call (sym args spread-p env)
+  ;; Find ftype based on actual arguments.
+  ;; This should be more general, but for now just pick off some special cases..
+  (when (and args (or (not spread-p) (cdr args)))
+    (cond ((or (eq sym 'aref) (eq sym 'uvref))
+           (let* ((atype (nx-form-type (car args) env))
+                  (a-ctype (specifier-type atype)))
+             (when (array-ctype-p a-ctype)
+               ;; No point declaring the type of an arg whose type we already know
+               `(function (t &rest integer) ,(type-specifier (array-ctype-specialized-element-type
+                                                                  a-ctype))))))
+          ((eq sym 'error)
+           (let ((condition (car args)))
+             (cond ((nx-form-typep condition 'condition env)
+                    '(function (t) *))
+                   ((nx-form-typep condition 'symbol env)
+                    ;; TODO: might be able to figure out actual initargs...
+                    `(function (t &key &allow-other-keys) *))
+                   (t nil))))
+          ((eq sym 'cerror)
+           (when (and (cdr args) (or (not spread-p) (cddr args)))
+             (let ((condition (cadr args)))
+               (cond ((nx-form-typep condition 'condition env)
+                      `(function (string t &rest t) *))
+                     ((nx-form-typep condition 'symbol env)
+                      `(function (string t &key &allow-other-keys) *))
+                     (t `(function (string t &rest t) *))))))
+          (t nil))))
+
+(defun find-ftype-decl (sym &optional (env *nx-lexical-environment*) (args :unknown) spread-p)
   (setq sym (maybe-setf-function-name 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))))
+    for lexenv = env then (lexenv.parent-env lexenv) until (listp lexenv)
+    do (dolist (fdecl (lexenv.fdecls lexenv))
+         (when (and (eq (car fdecl) sym)
+                    (eq (car (%cdr fdecl)) 'ftype))
+           (return-from find-ftype-decl (%cddr fdecl))))
+    do (when (and (istruct-typep lexenv 'lexical-environment)
+                  (assq sym (lexenv.functions lexenv)))
+         (return-from find-ftype-decl nil)))
+  (or (proclaimed-ftype sym)
+      (and (listp args)
+           (known-ftype-for-call sym args spread-p env))))
 
 (defun nx1-analyze-ftyped-call (ftype sym arglist spread-p env)
@@ -2634 +2665 @@
                       #+no (and (memq (car form) *logical-ops*)
                            (grovel-logical-form form env))
-                      (nx-declared-result-type (%car form) env)
-                      ;; Sort of the right idea, but this should be done
-                      ;; in a more general way.
-                      (when (or (eq (car form) 'aref)
-                                (eq (car form) 'uvref))
-                        (let* ((atype (nx-form-type (cadr form) env))
-                               (a-ctype (specifier-type atype)))
-                          (when (array-ctype-p a-ctype)
-                            (type-specifier (array-ctype-specialized-element-type
-                                             a-ctype)))))
+                      (nx-declared-result-type (%car form) env (%cdr form))
                       t))))
             t))