Function proclamations are also used to deduce the argument types and automatically generate type checks.

src/CHANGELOG

@@ -89,6 +89,9 @@ ECL 10.5.1:
 
  - ECL exports a new feature, :C++, when it is built with a C++ compiler.
 
+ - Function proclamations and declarations are also used to deduce the type
+   of their arguments.
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***

src/cmp/cmpenv-fun.lsp

@@ -73,17 +73,22 @@
       (warn "In (DECLARE (FTYPE ...)): ~s is not a valid function name" fname))
   env)
 
-(defun get-arg-types (fname &optional (env *cmp-env*))
+(defun get-arg-types (fname &optional (env *cmp-env*) (may-be-global t))
   (let ((x (cmp-env-search-ftype fname env)))
     (if x
-        (values (first x) t)
-        (sys:get-sysprop fname 'PROCLAIMED-ARG-TYPES))))
+        (values x t)
+        (when may-be-global
+          (let ((fun (cmp-env-search-function fname env)))
+            (when (or (null fun) (and (fun-p fun) (fun-global fun)))
+              (sys:get-sysprop fname 'PROCLAIMED-ARG-TYPES)))))))
 
 (defun get-return-type (fname &optional (env *cmp-env*))
   (let ((x (cmp-env-search-ftype fname env)))
     (if x
 	(values (second x) t)
-	(sys:get-sysprop fname 'PROCLAIMED-RETURN-TYPE))))
+        (let ((fun (cmp-env-search-function fname env)))
+          (when (or (null fun) (and (fun-p fun) (fun-global fun)))
+            (sys:get-sysprop fname 'PROCLAIMED-RETURN-TYPE))))))
 
 (defun get-local-arg-types (fun &optional (env *cmp-env*))
   (let ((x (cmp-env-search-ftype (fun-name fun))))

src/cmp/cmpenv-proclaim.lsp

@@ -110,11 +110,13 @@
 	      (when ok
 		(proclaim-var type (rest decl))
 		t)))
+           ((maybe-add-policy decl *cmp-env-root*))            
 	   ((let ((proclaimer (get-sysprop (car decl) :proclaim)))
 	      (when (functionp proclaimer)
 		(mapc proclaimer (rest decl))
 		t)))
 	   (t
+            (break)
 	    (warn "Unknown declaration specifier ~s" decl-name))))))
 
 (defun proclaim-var (type vl)

src/cmp/cmplam.lsp

@@ -85,11 +85,11 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
 	 (*cmp-env* (setf (fun-cmp-env fun) (cmp-env-mark CB/LB)))
 	 (setjmps *setjmps*)
 	 (decl (si::process-declarations (rest lambda-list-and-body)))
+	 (global (and (assoc 'SI::C-GLOBAL decl) (setf (fun-global fun) T)))
+	 (no-entry (assoc 'SI::C-LOCAL decl))
 	 (lambda-expr (c1lambda-expr lambda-list-and-body
 				     (si::function-block-name name)))
 	 (children (fun-child-funs fun))
-	 (global (and (assoc 'SI::C-GLOBAL decl) 'T))
-	 (no-entry (assoc 'SI::C-LOCAL decl))
 	 cfun exported minarg maxarg)
     (when (and no-entry (policy-debug-ihs-frame))
       (setf no-entry nil)
@@ -115,7 +115,6 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
 	(multiple-value-setq (minarg maxarg)
 	  (lambda-form-allowed-nargs lambda-expr)))
     (setf (fun-cfun fun) cfun
-	  (fun-global fun) global
 	  (fun-exported fun) exported
 	  (fun-closure fun) nil
 	  (fun-minarg fun) minarg
@@ -227,7 +226,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
     ;; arguments, have to be applied to the body. At the same time, we
     ;; replace &aux variables with a LET* form that defines them.
     (let* ((declarations other-decls)
-           (type-checks (extract-lambda-type-checks requireds optionals
+           (type-checks (extract-lambda-type-checks block-name requireds optionals
                                                     keywords ts other-decls))
            (type-check-forms (car type-checks))
            (let-vars (loop for spec on (nconc (cdr type-checks) aux-vars)
@@ -435,7 +434,7 @@ The function thus belongs to the type of functions that ecl_make_cfun accepts."
     ;; which is what we do here.
     (let ((va-arg-loc (if simple-varargs 'VA-ARG 'CL-VA-ARG)))
       ;; counter for optionals
-      (wt "{int i=" nreq ";")
+      (wt-nl "{int i=" nreq ";")
       (do ((opt optionals (cdddr opt)))
 	  ((endp opt))
 	(wt-nl "if (i >= narg) {")

src/cmp/cmptype-prop.lsp

@@ -71,7 +71,7 @@
       (setf lambda-list (append lambda-list (list '&rest var))
             body (list* `(declare (ignorable ,var)) body))))
   `(setf (gethash ',fname *p0-dispatch-table*)
-         #'(ext:lambda-block ,fname ,lambda-list ,@body)))
+         #'(lambda ,lambda-list ,@body)))
 
 (defun copy-type-propagator (orig dest-list)
   (loop with function = (gethash orig *p0-dispatch-table*)

src/cmp/cmptype.lsp

@@ -56,42 +56,89 @@
 ;; TYPE CHECKING
 ;;
 
-(defun extract-lambda-type-checks (requireds optionals keywords ts other-decls)
+(defun lambda-type-check-associate (fname requireds optionals keywords global-fun-p)
+  (multiple-value-bind (arg-types found)
+      (get-arg-types fname *cmp-env* global-fun-p)
+    (if found
+        (multiple-value-bind (req-types opt-types rest-flag key-flag
+                                        key-types allow-other-keys)
+            (si::process-lambda-list arg-types 'ftype)
+          (nconc 
+           (loop for var in requireds
+              for type in (rest req-types)
+              collect (cons var type))
+           (loop for optional in optionals by #'cdddr
+              for type in (rest opt-types) by #'cdddr
+              collect (cons optional type))
+           (loop for key-list on keywords by #'cddddr
+              for keyword = (first key-list)
+              for key-var = (second key-list)
+              for type = (loop for key-list on (rest key-types) by #'cddr
+                            when (eq keyword (first key-list))
+                            return (second key-list)
+                            finally (return t))
+              collect (cons key-var type))))
+        (nconc
+         (loop for var in requireds
+            collect (cons var t))
+         (loop for optional in optionals by #'cdddr
+            collect (cons optional t))
+         (loop for key-list on keywords by #'cddddr
+            for key-var = (second key-list)
+            collect (cons key-var t))))))
+
+(defun lambda-type-check-precise (assoc-list ts)
+  (loop for record in assoc-list
+     for var = (car record)
+     for type = (assoc (var-name var) ts)
+     when type
+     do
+     ;; Instead of trusting the global proclamation, we set a check based
+     ;; on the local declaration, without type merging.
+       (rplacd record (cdr type))
+       #+(or)
+       (rplacd record (type-and (cdr record) (cdr type))))
+  assoc-list)
+
+(defun extract-lambda-type-checks (fname requireds optionals keywords ts other-decls)
   ;; We generate automatic type checks for function arguments that
   ;; are declared These checks can be deactivated by appropriate
   ;; safety settings which are checked by ASSERT-TYPE. Note
   ;; that not all type declarations can be checked (take for instance
   ;; (type (function (t t) t) foo)) We let the macro do the job.
-  (when (policy-check-arguments-type)
-    (loop with type-checks = (append (loop for spec on optionals by #'cdddr
-                                        collect (first spec))
-                                     (loop for spec on keywords by #'cddddr
-                                        collect (second spec))
-                                     requireds)
-       for var in type-checks
-       for name = (var-name var)
-       for type = (cdr (assoc name ts))
-       for checked = (and type
-                          (loop for decl in other-decls
-                             never (and (consp decl)
-                                        (eq (first decl)
-                                            'si::no-check-type)
-                                        (member name (rest decl)))))
-       when checked
-       collect `(assert-type-if-known ,name ,type) into checks
-       ;; We remove assumption about types, which will be checked later
-       when checked
-       do (setf (var-type var) T)
-       ;; And we add additional variables with proclaimed types
-       when (and checked (not (eq (var-kind var) 'SPECIAL)))
-       nconc `(,name (the ,type ,name)) into new-auxs
-       finally
-         (progn
-           (when checks
-             (cmpnote "In ~:[an anonymous function~;function ~:*~A~], checking types of argument~@[s~]~{ ~A~}."
-                      (fun-name *current-function*)
-                      (mapcar #'second checks)))
-           (return (cons checks new-auxs))))))
+  (loop with policy-check-type = (policy-check-arguments-type)
+     with checks = '()
+     with new-auxs = '()
+     with global-fun-p = (member '(si::c-global) other-decls :test #'equal)
+     with type-checks = (lambda-type-check-precise
+                         (lambda-type-check-associate fname requireds
+                                                      optionals keywords
+                                                      global-fun-p)
+                         ts)
+     for (var . type) in type-checks
+     for name = (var-name var)
+     ;; Non trivial types are the only ones we care about
+     unless (eq type t)
+     do (if (and policy-check-type
+                 (loop for decl in other-decls
+                    never (and (consp decl)
+                               (eq (first decl)
+                                   'si::no-check-type)
+                               (member name (rest decl)))))
+            ;; We remove assumption about types, which will be checked
+            ;; later due to this assertion...
+            (setf (var-type var) t
+                  checks (list* `(assert-type-if-known ,name ,type) checks)
+                  new-auxs (list* `(the ,type ,name) name new-auxs))
+            ;; Or simply enforce the variable's type.
+            (setf (var-type var) (type-and (var-type var) type)))
+     finally
+       (progn
+         (when checks
+           (cmpnote "In ~:[an anonymous function~;function ~:*~A~], checking types of argument~@[s~]~{ ~A~}."
+                    (fun-name *current-function*)
+                    (mapcar #'second checks)))
+         (return (cons (nreverse checks) (nreverse new-auxs))))))
 
 (defun type-error-check (value type)
   (case type