From b31723d35dba8cc4f26e1629e454f08289e18d97 Mon Sep 17 00:00:00 2001
From: Juan Jose Garcia Ripoll <jjgarcia@JJGR.(none)>
Date: Sat, 13 Sep 2008 00:16:52 +0200
Subject: [PATCH] FTYPE now accepts user defined function types (Josh Elsasser)

---
 src/CHANGELOG      |  3 +++
 src/cmp/cmpenv.lsp | 32 ++++++++++++++++++--------------
 2 files changed, 21 insertions(+), 14 deletions(-)

diff --git a/src/CHANGELOG b/src/CHANGELOG
index 74909644f..da42c684b 100644
--- a/src/CHANGELOG
+++ b/src/CHANGELOG
@@ -90,6 +90,9 @@ ECL 8.9.0:
 
  - When a SETF place is a macro, it has to be expanded with MACROEXPAND-1.
 
+ - In FTYPE proclamations and declarations, the type may now be a user defined
+   function type (Josh Elsasser).
+
 ;;; Local Variables: ***
 ;;; mode:text ***
 ;;; fill-column:79 ***
diff --git a/src/cmp/cmpenv.lsp b/src/cmp/cmpenv.lsp
index 9cbd2f246..02472e1ee 100644
--- a/src/cmp/cmpenv.lsp
+++ b/src/cmp/cmpenv.lsp
@@ -206,13 +206,15 @@
          (proclaim-var (second decl) (cddr decl))
          (error "Syntax error in proclamation ~s" decl)))
     (FTYPE
-     (let (ftype)
-       (cond ((and (consp (cdr decl))
-		   (consp (setf ftype (second decl)))
-		   (eq (first ftype) 'FUNCTION))
-	      (dolist (v (cddr decl))
-		(add-function-proclamation v (rest ftype))))
-	     (t (error "Syntax error in proclamation ~a" decl)))))
+     (if (atom (rest decl))
+	 (error "Syntax error in proclamation ~a" decl)
+	 (multiple-value-bind (type-name args)
+	     (si::normalize-type (second decl))
+	   (if (eq type-name 'FUNCTION)
+	       (dolist (v (cddr decl))
+		 (add-function-proclamation v args))
+	       (error "In an FTYPE proclamation, found ~A which is not a function type."
+		      (second decl))))))
     (INLINE
      (dolist (fun (cdr decl))
        (if (si::valid-function-name-p fun)
@@ -399,13 +401,15 @@
 	       (COMPILATION-SPEED)
 	       (t (cmpwarn "The OPTIMIZE quality ~s is unknown." (car x))))))))
       (FTYPE
-       (let (ftype)
-	 (cond ((and (consp (cdr decl))
-		     (consp (setq ftype (second decl)))
-		     (eq (first ftype) 'FUNCTION))
-		(dolist (v (cddr decl))
-		  (add-function-declaration v (second ftype) (cddr ftype))))
-	       (t (cmpwarn "Syntax error in declaration ~s" decl)))))
+       (if (atom (rest decl))
+	   (cmpwarn "Syntax error in declaration ~a" decl)
+	   (multiple-value-bind (type-name args)
+	       (si::normalize-type (second decl))
+	     (if (eq type-name 'FUNCTION)
+		 (dolist (v (cddr decl))
+		   (add-function-declaration v (first args) (rest args)))
+		 (cmpwarn "In an FTYPE declaration, found ~A which is not a function type."
+			  (second decl))))))
       (INLINE
        (push decl dl)
        (dolist (fun (cdr decl))