Changeset 12515

Timestamp:

Aug 1, 2009, 3:50:08 PM (10 years ago)

Author:

gz

Message:

ftypes - r12467/r12500/r12512/r12514 from trunk

Location:

branches/working-0711/ccl

Files:

• compiler/nx-basic.lisp (modified) (4 diffs)
• compiler/nx.lisp (modified) (1 diff)
• compiler/nx0.lisp (modified) (15 diffs)
• compiler/nx1.lisp (modified) (7 diffs)
• level-1/l1-clos-boot.lisp (modified) (1 diff)
• level-1/l1-typesys.lisp (modified) (5 diffs)
• level-1/l1-utils.lisp (modified) (1 diff)
• level-1/sysutils.lisp (modified) (1 diff)
• lib/format.lisp (modified) (2 diffs)

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

@@ -205 +205 @@
 (%include "ccl:compiler;lambda-list.lisp")
 
-
+#-BOOTSTRAPPED (unless (fboundp 'types-disjoint-p)
+                 (fset 'types-disjoint-p (lambda (t1 t2 &optional env) t1 t2 env nil)))
 
 
@@ -352 +353 @@
                      (assq sym *nx-proclaimed-types*))))
     (if decl (%cdr decl) t)))
+
+(defun nx-declared-result-type (sym &optional (env *nx-lexical-environment*))
+  (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))))
+      (unless (or (null ctype)
+                  (not (function-ctype-p ctype))
+                  (eq *wild-type* (function-ctype-returns ctype)))
+        (let ((result-type (type-specifier (single-value-type (function-ctype-returns ctype)))))
+          (and (neq result-type 't) result-type))))))
 
 (defmacro define-declaration (decl-name lambda-list &body body &environment env)
@@ -598 +609 @@
        (destructuring-bind (badguy goodguys)
            (cdr reason)
-         (format stream "the keyword argument ~s is not one of ~s, which are recognized~&  by " badguy goodguys))))
+         (format stream "the keyword argument~:[ ~s is~;s~{ ~s~^~#[~; and~:;,~]~} are~] not one of ~s, which are recognized~&  by "
+                 (consp badguy) badguy goodguys))))
     (format stream
             (ecase (compiler-warning-warning-type condition)       
+              (:ftype-mismatch "the FTYPE declaration of ~s")
               (:global-mismatch "the current global definition of ~s")
               (:environment-mismatch "the definition of ~s visible in the current compilation unit.")
@@ -621 +634 @@
     (:environment-mismatch . report-compile-time-argument-mismatch)
     (:lexical-mismatch . report-compile-time-argument-mismatch)    
+    (:ftype-mismatch . report-compile-time-argument-mismatch)
     (:type . "Type declarations violated in ~S")
     (:type-conflict . "Conflicting type declarations for ~S")

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

@@ -203 +203 @@
     (:lexical-mismatch . invalid-arguments)
     (:environment-mismatch . invalid-arguments)
+    (:ftype-mismatch . invalid-arguments)
     (:ignore . style-warning)
     (:result-ignored . style-warning)

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

@@ -739 +739 @@
                     (rplacd (cdr decl) merged-type))))
               (push decl env-vdecls)))))
-      (when fdecls (setf (lexenv.fdecls env) (merge-decls fdecls (lexenv.vdecls env))))
+      (when fdecls (setf (lexenv.fdecls env) (merge-decls fdecls (lexenv.fdecls env))))
       (when mdecls (setf (lexenv.mdecls env) (merge-decls mdecls (lexenv.mdecls env))))
       (setq *nx-inlined-self* (and (nx-self-calls-inlineable env) 
@@ -816 +816 @@
 (defnxdecl ftype (pending decl env &aux whined)
   (destructuring-bind (type &rest fnames) (%cdr decl)
-    (if (specifier-type-if-known type env)
-      (dolist (s fnames)
-        (if (or (symbolp s) (setf-function-name-p s))
-            (nx-new-fdecl pending s 'ftype type)
-            (unless (shiftf whined t) (nx-bad-decls decl))))
-      (nx1-whine :unknown-type-in-declaration type))))
+    (let ((ctype (specifier-type-if-known type env)))
+      (if (null ctype)
+        (nx1-whine :unknown-type-in-declaration type)
+        (if (types-disjoint-p ctype (specifier-type 'function))
+          (nx-bad-decls decl)
+          (dolist (s fnames)
+            (if (or (symbolp s) (setf-function-name-p s))
+              (nx-new-fdecl pending s 'ftype type)
+              (unless (shiftf whined t) (nx-bad-decls decl)))))))))
 
 (defnxdecl settable (pending decl env)
@@ -1846 +1849 @@
         (push warning (afunc-warnings p))))))
 
-(defun nx1-type-intersect (form type1 type2 &optional env)
-  (declare (ignore env)) ; use it when deftype records info in env.  Fix this then ...
-  (let* ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1)))
-         (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2)))
+(defun nx1-type-intersect (form type1 type2 &optional (env *nx-lexical-environment*))
+  (let* ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1 env)))
+         (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2 env)))
          (intersection (type-intersection ctype1 ctype2)))
-    (if (eq intersection *empty-type*)
+    (when (eq intersection *empty-type*)
       (let ((type1 (if (typep type1 'ctype)
                      (type-specifier type1)
@@ -1860 +1862 @@
         (nx1-whine :type-conflict form type1 type2)))
     (type-specifier intersection)))
-                 
-
 
 (defun nx-declared-notinline-p (sym env)
@@ -1900 +1900 @@
   (nx1-typed-call (car args) (%cdr args)))
 
-(defun nx1-typed-call (sym args)
-  (multiple-value-bind (type errors-p) (nx1-call-result-type sym args)
-    (let ((form (nx1-call sym args nil nil errors-p)))
-      (if (eq type t)
+(defun nx1-typed-call (fn args &optional spread-p)
+  (let ((global-only nil)
+        (errors-p nil)
+        (result-type t))
+    (when (and (acode-p fn) (eq (acode-operator fn) (%nx1-operator immediate)))
+      (multiple-value-bind (valid name) (valid-function-name-p (%cadr fn))
+        (when valid
+          (setq fn name global-only t))))
+    (when (non-nil-symbol-p fn)
+      (multiple-value-setq (errors-p args result-type)
+        (nx1-check-typed-call fn args spread-p global-only)))
+    (setq result-type (nx1-type-intersect fn *nx-form-type* result-type))
+    (let ((form (nx1-call fn args spread-p global-only errors-p)))
+      (if (eq result-type t)
         form
-        (make-acode (%nx1-operator typed-form) type form)))))
+        (make-acode (%nx1-operator typed-form) result-type form)))))
 
 (defvar *format-arg-functions* '((format . 1) (format-to-string . 1) (error . 0) (warn . 0)
@@ -1918 +1928 @@
                                  (compiler-bug . 0)))
 
-;;; Wimpy.
-(defun nx1-call-result-type (sym &optional (args nil args-p) spread-p global-only)
-  (let* ((env *nx-lexical-environment*)
-         (global-def nil)
-         (lexenv-def nil)
-         (defenv-def nil)
-         (somedef nil)
-         (whined nil))
-    (when (and sym 
-               (symbolp sym)
-               (not (find-ftype-decl sym env))
-               (or global-only
-                   (not (setq lexenv-def (nth-value 1 (nx-lexical-finfo sym)))))
-               (null (setq defenv-def (retrieve-environment-function-info sym env)))
-               (neq sym *nx-global-function-name*)
-               (not (functionp (setq global-def (fboundp sym)))))
-      (if args-p
-        (nx1-whine :undefined-function sym args spread-p)
-        (nx1-whine :undefined-function sym))
-      (setq whined t))
-    (when (and args-p
-               (not spread-p)
-               (setq somedef (unless lexenv-def (cdr (assq sym *format-arg-functions*))))
-               (setq somedef (nthcdr somedef args))
-               (stringp (car somedef)))
-      (when (nx1-check-format-call (car somedef) (cdr somedef) env)
-        (setq whined t)))
-    (when (and args-p (setq somedef (or lexenv-def defenv-def (if (typep global-def 'function) global-def))))
-      (multiple-value-bind (deftype reason)
-          (nx1-check-call-args somedef args spread-p)
-        (when deftype
-          (nx1-whine deftype sym reason args spread-p)
-          (setq whined t))))
-    (values (nx-target-type *nx-form-type*) whined)))
-
-(defun find-ftype-decl (sym env)
+(defun nx1-find-call-def (sym &optional (env *nx-lexical-environment*) (global-only nil))
+  (and (or (and (not global-only) (nth-value 1 (nx-lexical-finfo sym)))
+           (retrieve-environment-function-info sym env)
+           (let ((def (fboundp sym)))
+             (and (functionp def) def)))))
+
+(defun nx1-check-typed-call (sym args &optional spread-p global-only)
+  (let ((env *nx-lexical-environment*)
+        (result-type t)
+        (typed-args args)
+        (errors-p nil)
+        (ftype nil)
+        (def nil))
+    (setq ftype (find-ftype-decl sym env))
+    (setq def (nx1-find-call-def sym env global-only))
+    (when ftype
+      (multiple-value-setq (typed-args result-type errors-p)
+        (nx1-analyze-ftyped-call ftype sym args spread-p env)))
+    (when (and def (not errors-p))
+      (multiple-value-bind (deftype reason) (nx1-check-call-args def args spread-p)
+        (when deftype
+          (nx1-whine deftype sym reason args spread-p)
+          (setq errors-p t))))
+    (unless (or def ftype (eq sym *nx-global-function-name*))
+      (nx1-whine :undefined-function sym args spread-p)
+      (setq errors-p t))
+    (unless errors-p
+      (let* ((format-args (and (not spread-p)
+                               (not (typep def 'afunc))
+                               (let* ((n (cdr (assq sym *format-arg-functions*))))
+                                 (and n (nthcdr n typed-args)))))
+             (control (pop format-args)))
+        (when (and (consp control)
+                   (eq (%car control) 'the)
+                   (consp (%cdr control))
+                   (consp (%cddr control)))
+          (setq control (%caddr control)))
+        (when (stringp (setq control (nx-transform control env)))
+          (when (nx1-check-format-call control format-args env)
+            (setq errors-p t)))))
+
+    (values errors-p typed-args result-type)))
+
+(defun find-ftype-decl (sym &optional (env *nx-lexical-environment*))
   (setq sym (maybe-setf-function-name sym))
   (loop 
@@ -1960 +1978 @@
                    (proclaimed-ftype sym))))
     (dolist (fdecl (lexenv.fdecls env))
-      (declare (list fdecl))
       (when (and (eq (car fdecl) sym)
-                 (eq (car (the list (cdr fdecl))) 'ftype))
-        (return-from find-ftype-decl (cdr (the list (cdr fdecl))))))
+                 (eq (car (%cdr fdecl)) 'ftype))
+        (return-from find-ftype-decl (%cddr fdecl))))
     (setq env (lexenv.parent-env env))))
+
+(defun nx1-analyze-ftyped-call (ftype sym arglist spread-p env)
+  (let ((ctype (if (typep ftype 'ctype) ftype (specifier-type ftype)))
+        (result-type t)
+        (errors-p nil))
+    (unless (or (null ctype) (not (function-ctype-p ctype)))
+      (unless (function-ctype-wild-args ctype)
+        (let ((req (args-ctype-required ctype))
+              (opt (args-ctype-optional ctype))
+              (rest (args-ctype-rest ctype))
+              (keyp (args-ctype-keyp ctype))
+              (aokp (or spread-p (args-ctype-allowp ctype)))
+              (keys (args-ctype-keywords ctype))
+              (typed-arglist nil)
+              (key-type nil)
+              (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))
+                 (whine (&rest reason)
+                   (nx1-whine :ftype-mismatch sym reason arglist spread-p)
+                   (setq errors-p t)))
+            (declare (dynamic-extent #'collect-type #'whine))
+            (loop for arg in arglist as i below nargs
+                  do (cond
+                       (req (collect-type arg (pop req)))
+                       (opt (collect-type arg (pop opt)))
+                       (rest (collect-type arg rest))
+                       (key-type (collect-type arg (shiftf key-type nil)))
+                       (keyp (if (nx-form-constant-p arg env)
+                               (let* ((key (nx-form-constant-value arg env))
+                                      (ki (find key keys :key #'key-name)))
+                                 (when (eq key :allow-other-keys) (setq aokp t))
+                                 (if ki
+                                   (setq key-type (key-info-type ki))
+                                   (unless aokp (push key bad-keys))))
+                               (setq aokp t))
+                             (collect-type arg nil)
+                             (unless key-type (setq key-type *universal-type*)))
+                       (t (return (whine :toomany
+                                         nargs
+                                         (+ (length (args-ctype-required ctype))
+                                            (length (args-ctype-optional ctype)))))))
+                  finally (cond (spread-p (collect-type arg nil))
+                                (req (whine :toofew
+                                            nargs
+                                            (length (args-ctype-required ctype))))
+                                (key-type (whine :odd-keywords 
+                                                 (nthcdr
+                                                  (+ (length (args-ctype-required ctype))
+                                                     (length (args-ctype-optional ctype)))
+                                                  arglist)))
+                                (bad-keys (whine :unknown-keyword
+                                                 (if (cdr bad-keys)
+                                                   (nreverse bad-keys)
+                                                   (car bad-keys))
+                                                 (map 'list #'key-name keys)))))
+            (unless errors-p
+              (setq arglist (nreverse typed-arglist))))))
+      (setq result-type (type-specifier (single-value-type (function-ctype-returns ctype)))))
+    (values arglist (nx-target-type result-type) errors-p)))
+
 
 (defun innermost-lfun-bits-keyvect (def)
@@ -1996 +2079 @@
                                 (if (lambda-expression-p lambda-form)
                                   (encode-lambda-list (cadr lambda-form))))))
-      (when bits
-        (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
-        (let* ((nargs (length arglist))
-               (minargs (if spread-p (1- nargs) nargs))
-               (maxargs (if spread-p nil nargs))
-               (required (ldb $lfbits-numreq bits))
-               (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
-                      nil
-                      (+ required (ldb $lfbits-numopt bits)))))
-          ;; If the (apparent) number of args in the call doesn't
-          ;; match the definition, complain.  If "spread-p" is true,
-          ;; we can only be sure of the case when more than the
-          ;; required number of args have been supplied.
-          (if (or (if (and (not spread-p) (< minargs required))
-                    (setq reason `(:toofew ,minargs ,required)))
-                  (if (and max (or (> minargs max)) (if maxargs (> maxargs max)))
-                    (setq reason (list :toomany (if (> minargs max) minargs maxargs) max)))
-                  (setq reason (nx1-find-bogus-keywords arglist spread-p bits keyvect)))
-            (values deftype reason)))))))
-
-(defun nx1-find-bogus-keywords (args spread-p bits keyvect)
+      (setq reason (nx1-check-call-bits bits keyvect arglist spread-p))
+      (when reason
+        (values deftype reason)))))
+
+(defun nx1-check-call-bits (bits keyvect arglist spread-p)
+  (when bits
+    (unless (typep bits 'fixnum) (error "Bug: Bad bits ~s!" bits))
+    (let* ((env *nx-lexical-environment*)
+           (nargs (length arglist))
+           (minargs (if spread-p (1- nargs) nargs))
+           (required (ldb $lfbits-numreq bits))
+           (max (if (logtest (logior (ash 1 $lfbits-rest-bit) (ash 1 $lfbits-restv-bit) (ash 1 $lfbits-keys-bit)) bits)
+                  nil
+                  (+ required (ldb $lfbits-numopt bits)))))
+      ;; If the (apparent) number of args in the call doesn't
+      ;; match the definition, complain.  If "spread-p" is true,
+      ;; we can only be sure of the case when more than the
+      ;; required number of args have been supplied.
+      (or (and (not spread-p)
+               (< minargs required)
+               `(:toofew ,minargs ,required))
+          (and max
+               (> minargs max)
+               (list :toomany nargs max))
+          (nx1-find-bogus-keywords arglist spread-p bits keyvect env)))))
+
+(defun nx1-find-bogus-keywords (args spread-p bits keyvect env)
   (declare (fixnum bits))
   (when (logbitp $lfbits-aok-bit bits)
@@ -2022 +2111 @@
   (when (and (logbitp $lfbits-keys-bit bits) 
              (not spread-p))     ; Can't be sure, last argform may contain :allow-other-keys
-    (do* ((key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
+    (do* ((bad-keys nil)
+          (key-values (nthcdr (+ (ldb $lfbits-numreq bits)  (ldb $lfbits-numopt bits)) args))
           (key-args key-values  (cddr key-args)))
-         ((null key-args))
-      (if (null (cdr key-args))
-        (return (list :odd-keywords key-values))
-        (when keyvect
-          (let* ((keyword (%car key-args)))
-            (unless (constantp keyword)
-              (return nil))
-            (unless (eq keyword :allow-other-keys)
-              (unless (position (nx-unquote keyword) keyvect)                
-                (return (list :unknown-keyword
-                              (nx-unquote keyword)
-                              (coerce keyvect 'list)))))))))))
+         ((null key-args)
+          (when (and keyvect bad-keys)
+            (list :unknown-keyword
+                  (if (cdr bad-keys) (nreverse bad-keys) (%car bad-keys))
+                  (coerce keyvect 'list))))
+      (unless (cdr key-args)
+        (return (list :odd-keywords key-values)))
+      (when keyvect
+        (let* ((keyword (%car key-args)))
+          (unless (nx-form-constant-p keyword env)
+            (return nil))
+          (setq keyword (nx-form-constant-value keyword env))
+          (if (eq keyword :allow-other-keys)
+            (setq keyvect nil)
+            (unless (position keyword keyvect)
+              (push keyword bad-keys))))))))
 
 ;;; we can save some space by going through subprims to call "builtin"
@@ -2068 +2162 @@
 (defun nx1-call (sym args &optional spread-p global-only inhibit-inline)
   (nx1-verify-length args 0 nil)
+  (when (and (acode-p sym) (eq (acode-operator sym) (%nx1-operator immediate)))
+    (multiple-value-bind (valid name) (valid-function-name-p (%cadr sym))
+      (when valid
+        (setq global-only t sym name))))
   (let ((args-in-regs (if spread-p 1 (backend-num-arg-regs *target-backend*))))
     (if (nx-self-call-p sym global-only)
@@ -2413 +2511 @@
 (defun nx-form-type (form &optional (env *nx-lexical-environment*))
   (if (nx-form-constant-p form env)
-    (type-of (nx-form-constant-value form env))
+    ;(type-of (nx-form-constant-value form env))
+    `(member ,(nx-form-constant-value form env))
     (if (and (consp form)          ; Kinda bogus now, but require-type
              (eq (%car form) 'require-type) ; should be special some day
@@ -2425 +2524 @@
               (destructuring-bind (typespec val) (%cdr form)
                 (declare (ignore val))
-                (let* ((ctype (values-specifier-type typespec)))
-                  (if (typep ctype 'values-ctype)
-                    (let* ((req (values-ctype-required ctype)))
-                      (if req
-                        (nx-target-type (type-specifier (car req)))
-                        '*))
-                    (nx-target-type (type-specifier ctype)))))
+                (nx-target-type (type-specifier (single-value-type (values-specifier-type typespec)))))
               (if (eq (%car form) 'setq)
-                (nx-declared-type (cadr form) env)
+                (let* ((args (%cdr form))
+                       (n (length args)))
+                  (if (and (evenp n)
+                           (> n 0)
+                           (setq args (nthcdr (- n 2) args))
+                           (non-nil-symbol-p (car args)))
+                    (nx1-type-intersect (%car args)
+                                        (nx-declared-type (%car args) env)
+                                        (nx-form-type (%cadr args) env)
+                                        env)
+                    t))
                 (let* ((op (gethash (%car form) *nx1-operators*)))
                   (or (and op (cdr (assq op *nx-operator-result-types*)))
@@ -2441 +2544 @@
                       (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.
@@ -2453 +2557 @@
             t))
         t))))
+
 
 (defparameter *numeric-ops* '(+ -  / * +-2 --2 *-2 /-2))
@@ -2588 +2693 @@
 (defun nx1-func-name (gizmo)
   (and (consp gizmo)
-       (or (eq (%car gizmo) 'function) (eq (%car gizmo) 'quote))
+       (eq (%car gizmo) 'function)
        (consp (%cdr gizmo))
        (null (%cddr gizmo))
-       (nth-value 1 (valid-function-name-p (%cadr gizmo)))))
+       (if (lambda-expression-p (%cadr gizmo))
+         (%cadr gizmo)
+         (nth-value 1 (valid-function-name-p (%cadr gizmo))))))
 
 ; distinguish between program errors & incidental ones.

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

@@ -28 +28 @@
            (let* ((ctype (handler-case (values-specifier-type (nx-target-type typespec) env)
                            (parse-unknown-type (c)
-                                               (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
-                                               nil)
+                             (nx1-whine :unknown-type-in-declaration (parse-unknown-type-specifier c))
+                             nil)
                            (program-error (c)
-                                          (nx1-whine :invalid-type typespec c)
-                                          nil))))
-             (if (or (null ctype) (typep ctype 'values-ctype))
+                              (nx1-whine :invalid-type typespec c)
+                              nil))))
+             (if (null ctype)
                '*
                (if (typep ctype 'function-ctype)
                  'function
-                 (nx-target-type (type-specifier ctype)))))))
+                 (nx-target-type (type-specifier (single-value-type ctype))))))))
     (let* ((typespec (typespec-for-the typespec))
            (*nx-form-type* typespec)
            (transformed (nx-transform form env)))
-      (when (and (nx-form-constant-p transformed env)
-                 (not (typep (nx-form-constant-value transformed env) typespec)))
-        (nx1-whine :type call)
-        (setq typespec t))
       (flet ((fold-the ()
                (do* ()
@@ -63 +59 @@
           (when (eq transformed last)
             (return)))
+        (when (and (nx-form-constant-p transformed env)
+                   (not (typep (nx-form-constant-value transformed env) typespec)))
+          (nx1-whine :type call)
+          (setq typespec t))
+        (setq typespec (nx-target-type
+                        (or (nx1-type-intersect call
+                                                typespec
+                                                (typespec-for-the (nx-form-type transformed env)))
+                            t)))
         (make-acode
          (%nx1-operator typed-form)
@@ -1160 +1165 @@
 
 
-
-
-                          
-
-(defnx1 nx1-apply ((apply)) (&whole call fn arg &rest args &aux (orig args) (spread-p t))
-  (if (null (%car (last (push arg args))))
-    (setq spread-p nil args (butlast args)))
-  (let ((name (nx1-func-name fn))
-        (global nil)
-        (result-type t))
-    (when name
-      (setq global (eq (%car fn) 'quote)
-            result-type (nx1-call-result-type name args spread-p global))
-      (if global (setq name (nx1-form fn))))
-    (if name
-      (unless global
-        (let*  ((afunc (nth-value 1 (nx-lexical-finfo name))))
-          (when (and afunc (eq afunc *nx-call-next-method-function*))
-            (setq name (if (or arg orig) 
-                         '%call-next-method-with-args
-                         '%call-next-method)
-                         global t
-                         args (cons (var-name *nx-next-method-var*) args)))))
-      (setq name (nx1-form fn)))
-    (let* ((form (nx1-call name args spread-p global)))
-      (if (eq result-type t)
-        form
-        (make-acode (%nx1-operator typed-form) result-type form)))))
-
-(defnx1 nx1-%apply-lexpr ((%apply-lexpr)) (&whole call fn arg &rest args &aux (orig args))
-  (push arg args)
-  (let ((name (nx1-func-name fn))
-        (global nil))
-    (if name
-      (if (eq (%car fn) 'quote)
-        (setq global t name (nx1-form fn))
-        (let*  ((afunc (nth-value 1 (nx-lexical-finfo name))))
-          (when (and afunc (eq afunc *nx-call-next-method-function*))
-            (setq name (if (or arg orig) 
-                         '%call-next-method-with-args
-                         '%call-next-method)
-                  global t
-                  args (cons (var-name *nx-next-method-var*) args)))))
-      (setq name (nx1-form fn)))
-    (nx1-call name args 0 global)))
-
+(defnx1 nx1-apply ((apply)) (&whole call fn arg &rest args &environment env)
+  (let ((last (%car (last (push arg args)))))
+    (if (and (nx-form-constant-p last env)
+             (null (nx-form-constant-value last env)))
+      (nx1-form (let ((new `(funcall ,fn ,@(butlast args))))
+                  (nx-note-source-transformation call new)
+                  new))
+      (nx1-apply-fn fn args t))))
+
+(defnx1 nx1-%apply-lexpr ((%apply-lexpr)) (fn arg &rest args)
+  (nx1-apply-fn fn (cons arg args) 0))
+
+(defun nx1-apply-fn (fn args spread)
+  (let* ((sym (nx1-func-name fn))
+         (afunc (and (non-nil-symbol-p sym) (nth-value 1 (nx-lexical-finfo sym)))))
+    (when (and afunc (eq afunc *nx-call-next-method-function*))
+      (setq fn (let ((new (list 'quote (if (or (car args) (cdr args))
+                                         '%call-next-method-with-args
+                                         '%call-next-method))))
+                 (nx-note-source-transformation fn new)
+                 new)
+            sym nil
+            args (cons (var-name *nx-next-method-var*) args)))
+    (nx1-typed-call (if (non-nil-symbol-p sym) sym (nx1-form fn)) args spread)))
 
 
@@ -1281 +1264 @@
              (setq symbol (cadr sym))
              (symbolp symbol))
-      (progn
-        (nx1-call-result-type symbol)   ; misnamed.  Checks for (un-)definedness.
+      (let ((env *nx-lexical-environment*))
+        (unless (or (nx1-find-call-def symbol env)
+                    (find-ftype-decl symbol env)
+                    (eq symbol *nx-global-function-name*))
+          (nx1-whine :undefined-function symbol))
         (make-acode (%nx1-default-operator) symbol))
       (make-acode (%nx1-operator call) (nx1-immediate '%function) (list nil (list sym))))))
@@ -1499 +1485 @@
      (nx1-form value))))
 
-(defnx1 nx1-funcall ((funcall)) (func &rest args &environment env)
-  (let ((name func))
-    (if (and (consp name)
-             (eq (%car name) 'function)
-             (consp (%cdr name))
-             (null (%cddr name))
-             (or
-              (if (symbolp (setq name (%cadr name)))
-                (or (not (macro-function name *nx-lexical-environment*))
-                    (nx-error "Can't funcall macro function ~s ." name)))
-              (and (consp name) 
-                   (or (when (eq (%car name) 'lambda)
-                         (nx-note-source-transformation func name)
-                         t)
-                       (setq name (nx-need-function-name name))))))
-      (nx1-form (cons name args))  ; This picks up call-next-method evil.
-      (let* ((result-type t))
-        (when (and (nx-form-constant-p func env)
-                   (or (typep (setq name (nx-form-constant-value func env)) 'symbol)
-                       (setq name (valid-function-name-p name))))
-          (setq result-type (nx1-call-result-type name args nil t)))
-        (let* ((form (nx1-call (nx1-form func) args nil t)))
-          (if (eq result-type t)
-            form
-            (make-acode (%nx1-operator typed-form) result-type form)))))))
+(defnx1 nx1-funcall ((funcall)) (&whole call func &rest args &environment env)
+  (let ((name (nx1-func-name func)))
+    (if (or (null name)
+            (and (symbolp name) (macro-function name env)))
+      (nx1-typed-call (nx1-form func) args nil)
+      (progn
+        (when (consp name) ;; lambda expression
+          (nx-note-source-transformation func name))
+        ;; This picks up call-next-method evil.
+        (nx1-form (let ((new-form (cons name args)))
+                    (nx-note-source-transformation call new-form)
+                    new-form))))))
 
 (defnx1 nx1-multiple-value-call multiple-value-call (value-form &rest args)
@@ -1529 +1502 @@
               (nx1-form value-form)
               (nx1-formlist args)))
-
-#|
-(defun nx1-call-name (fn &aux (name (nx1-func-name fn)))
-  (if (and name (or (eq (%car fn) 'quote) (null (nx-lexical-finfo name))))
-    (make-acode (%nx1-operator immediate) name)
-    (or name (nx1-form fn))))
-|#
 
 (defnx1 nx1-compiler-let compiler-let (bindings &body forms)
@@ -2039 +2005 @@
 
 (defnx1 nx1-x86-lap-function (x86-lap-function) (name bindings &body body)
-  (declare (ftype (function (t t t t)) %define-x86-lap-function))
+  (declare (ftype (function (t t t)) %define-x86-lap-function))
   (require "X86-LAP")
   (setf (afunc-lfun *nx-current-function*) 

branches/working-0711/ccl/level-1/l1-clos-boot.lisp

@@ -2533 +2533 @@
 )
 
-;; Stub to prevent errors when the user doesn't define types
-(defun type-intersect (type1 type2)
-  (cond ((and (null type1) (null type2))
-         nil)
-        ((equal type1 type2)
-         type1)
-        ((subtypep type1 type2)
-         type1)
-        ((subtypep type2 type1)
-         type2)
-        (t `(and ,type1 ,type2))
-        ;(t (error "type-intersect not implemented yet."))
-        ))
-
 (defun %add-direct-methods (method)
   (dolist (spec (%method-specializers method))

branches/working-0711/ccl/level-1/l1-typesys.lisp

@@ -724 +724 @@
 
 
+(define-type-method (function :complex-intersection) (type1 type2)
+  (declare (type function-ctype type2))
+  (let ((function (specifier-type 'function)))
+    (if (eq type1 function)
+      type2
+      (type-intersection2 type1 function))))
+
+
+
 ;;; ### Not very real, but good enough for redefining transforms according to
 ;;; type:
@@ -1222 +1231 @@
 ;;; value (trying not to return a hairy type).
 (defun type-approx-intersection2 (type1 type2)
+  (declare (type ctype type1 type2))
   (cond ((type-intersection2 type1 type2))
         ((hairy-ctype-p type1) type2)
@@ -1266 +1276 @@
 (defun simplify-intersections (types)
   (when types
-    (multiple-value-bind (first rest)
-        (if (intersection-ctype-p (car types))
-            (values (car (intersection-ctype-types (car types)))
-                    (append (cdr (intersection-ctype-types (car types)))
+    (let ((first (if (typep (car types) 'ctype)
+                   (%car types)
+                   (specifier-type (%car types)))))
+      (multiple-value-bind (first rest)
+          (if (intersection-ctype-p first)
+            (values (car (intersection-ctype-types first))
+                    (append (cdr (intersection-ctype-types first))
                             (cdr types)))
-            (values (car types) (cdr types)))
-      (let ((rest (simplify-intersections rest)) u)
-        (dolist (r rest (cons first rest))
-          (when (setq u (type-intersection2 first r))
-            (return (simplify-intersections (nsubstitute u r rest)))))))))
+            (values first (cdr types)))
+        (let ((rest (simplify-intersections rest)) u)
+          (dolist (r rest (cons first rest))
+            (when (setq u (type-intersection2 first r))
+              (return (simplify-intersections (nsubstitute u r rest))))))))))
 
 (defun type-intersection2 (type1 type2)
@@ -1295 +1308 @@
         ((let ((function (specifier-type 'function)))
            (or (and (function-ctype-p type1)
-                    (not (or (function-ctype-p type2) (eq function type2)))
+                    (not (function-ctype-p type2))
+                    (neq function type2)
                     (csubtypep type2 function)
                     (not (csubtypep function type2)))
                (and (function-ctype-p type2)
-                    (not (or (function-ctype-p type1) (eq function type1)))
+                    (not (function-ctype-p type1))
+                    (neq function type1)
                     (csubtypep type1 function)
                     (not (csubtypep function type1)))))
@@ -3544 +3559 @@
            (> (count-if #'class-ctype-p (intersection-ctype-types type1)) 1))
       (values nil nil)
-      (invoke-complex-subtypep-arg1-method type1 class2 nil t)))
+      (if (function-ctype-p type1)
+        (csubtypep (specifier-type 'function) class2)
+        (invoke-complex-subtypep-arg1-method type1 class2 nil t))))
 
 (define-type-method (class :complex-subtypep-arg1) (type1 type2)

branches/working-0711/ccl/level-1/l1-utils.lisp

@@ -571 +571 @@
   ;; Do not signal anything about unknown types though -- it should be ok to have forward
   ;; references here, before anybody needs the info.
-  (specifier-type ftype)
+  (let* ((ctype (specifier-type ftype)))
+    ;; If know enough to complain now, do so.
+    (when (types-disjoint-p ctype (specifier-type 'function))
+      (bad-proclaim-spec `(ftype ,ftype ,@names))))
   (dolist (name names)
     (setf (gethash (maybe-setf-function-name name) *nx-proclaimed-ftypes*) ftype)))

branches/working-0711/ccl/level-1/sysutils.lisp

@@ -345 +345 @@
   (csubtypep (specifier-type type1 env) (specifier-type type2 env)))
 
+(defun types-disjoint-p (type1 type2 &optional env)
+  ;; Return true if types are guaranteed to be disjoint, nil if not disjoint or unknown.
+  (let ((ctype1 (if (typep type1 'ctype) type1 (specifier-type type1 env)))
+        (ctype2 (if (typep type2 'ctype) type2 (specifier-type type2 env))))
+    (eq *empty-type* (type-intersection ctype1 ctype2))))
 
 

branches/working-0711/ccl/lib/format.lisp

@@ -2246 +2246 @@
 (defun nx-could-be-type (form type &optional transformed &aux (env *nx-lexical-environment*))
   (unless transformed (setq form (nx-transform form env)))
-  (if (constantp form)
-    (typep (eval-constant form) type env)
-    (multiple-value-bind (win-p sure-p) (subtypep (nx-form-type form env) `(not ,type) env)
-      (not (and win-p sure-p)))))
+  (if (nx-form-constant-p form env)
+    (typep (nx-form-constant-value form env) type env)
+    (not (types-disjoint-p (nx-form-type form env) type env))))
 
 (defun format-require-type (form type &optional description)
@@ -2382 +2381 @@
          ;; Would need to extend :undefined-function warnings to handle previously-undefined package.
          (when sym
-           (when (nth-value 1 (nx1-call-result-type sym (list* '*standard-output* arg colon atsign parms)))
+           (when (nx1-check-typed-call sym (list* '*standard-output* arg colon atsign parms))
              ;; Whined, just get out now.
              (throw 'format-error nil))))))