From d9919fa312482550cd5f6fd90caf4a856111d73c Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@jjgr-2.local>
Date: Fri, 27 Feb 2009 20:05:40 +0100
Subject: [PATCH] Ignore TYPE declarations that contain a function type, even
 if it is a DEFTYPE'd one.

---
 src/CHANGELOG       |  5 +++++
 src/cmp/cmplam.lsp  |  5 ++++-
 src/cmp/cmptype.lsp | 26 +++++++++++++++++++-------
 3 files changed, 28 insertions(+), 8 deletions(-)

diff --git a/src/CHANGELOG b/src/CHANGELOG
index d4aa0cf32..d1fb2df91 100644
--- a/src/CHANGELOG
+++ b/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      
diff --git a/src/cmp/cmplam.lsp b/src/cmp/cmplam.lsp
index 08fe6993f..2154533bd 100644
--- a/src/cmp/cmplam.lsp
+++ b/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))
diff --git a/src/cmp/cmptype.lsp b/src/cmp/cmptype.lsp
index 66e67c426..f2042330c 100644
--- a/src/cmp/cmptype.lsp
+++ b/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