Ignore TYPE declarations that contain a function type, even if it is a DEFTYPE'd one.

src/CHANGELOG

@@ -81,6 +81,11 @@ ECL 9.1.0:
 
  - EXT:SETENV now ensures that strings are null terminated.
 
+ - For high safety settings, ECL produces a CHECK-TYPE for each declaration
+   at the beginning of a function. If the declaration has a function type,
+   these checks were wrong, for TYPEP cannot take an arbitrary function type
+   as argument.
+
 * Visible changes:
 
  - New function (EXT:HEAP-SIZE &optional NEW-MAX-HEAP-SIZE) can change the      

src/cmp/cmplam.lsp

@@ -232,7 +232,10 @@ The function thus belongs to the type of functions that cl_make_cfun accepts."
 	    do (push `(type ,type ,var) declarations))
       ;; We generate automatic type checks for function arguments that
       ;; are declared These checks can be deactivated by appropriate
-      ;; safety settings which are checked by OPTIONAL-CHECK-TYPE
+      ;; safety settings which are checked by OPTIONAL-CHECK-TYPE. Note
+      ;; that not all type declarations can be checked (take for instance
+      ;; (type (function (t t) t) foo)) We let OPTIONAL-CHECK-TYPE do the
+      ;; job.
       ;;
       (let* ((pairs (loop for var in type-checks
 		       nconc (let* ((name (var-name var))

src/cmp/cmptype.lsp

@@ -440,13 +440,25 @@
 ;;
 
 (defun remove-function-types (type)
-  (if (atom type)
-      type
-      (case (first type)
-	((OR AND NOT)
-	 (cons (first type) (loop for i in (rest type) collect (remove-function-types i))))
-	(FUNCTION 'FUNCTION)
-	(otherwise type))))
+  ;; We replace this type by an approximate one that contains no function
+  ;; types. This function may not produce the best approximation. Hence,
+  ;; it is only used for optional type checks where we do not want to pass
+  ;; TYPEP a complex type.
+  (flet ((simplify-type (type)
+           (cond ((subtypep type '(NOT FUNCTION))
+                  type)
+                 ((subtypep type 'FUNCTION)
+                  'FUNCTION)
+                 (t
+                  T))))
+    (if (atom type)
+        (simplify-type type)
+        (case (first type)
+          ((OR AND NOT)
+           (cons (first type)
+                 (loop for i in (rest type) collect (remove-function-types i))))
+          (FUNCTION 'FUNCTION)
+          (otherwise (simplify-type type))))))
 
 (defmacro optional-check-type (&whole whole var-name type &environment env)
   "Generates a type check that is only activated for the appropriate