From 2ef8b05d4b791b4fdceaf0d3cd120143aa1df910 Mon Sep 17 00:00:00 2001
From: jjgarcia <jjgarcia>
Date: Sat, 2 Aug 2008 18:30:48 +0000
Subject: [PATCH] Added support for long double types in the compiler

---
 src/cmp/cmpct.lsp  |  3 +++
 src/cmp/cmpffi.lsp | 22 ++++++++++++++++------
 src/cmp/cmploc.lsp |  4 +++-
 src/cmp/cmpwt.lsp  |  2 ++
 4 files changed, 24 insertions(+), 7 deletions(-)

diff --git a/src/cmp/cmpct.lsp b/src/cmp/cmpct.lsp
index 1468b51f4..23f6cbf05 100644
--- a/src/cmp/cmpct.lsp
+++ b/src/cmp/cmpct.lsp
@@ -34,6 +34,9 @@
    ((typep val 'SINGLE-FLOAT)
     (make-c1form* 'LOCATION :type 'SINGLE-FLOAT
 		  :args (list 'SINGLE-FLOAT-VALUE val (add-object val))))
+   ((typep val 'LONG-FLOAT)
+    (make-c1form* 'LOCATION :type 'LONG-FLOAT
+		  :args (list 'LONG-FLOAT-VALUE val (add-object val))))
    (always
     (make-c1form* 'LOCATION :type (object-type val)
 		  :args (list 'VV (add-object val))))
diff --git a/src/cmp/cmpffi.lsp b/src/cmp/cmpffi.lsp
index 3edd8061c..a936a25dc 100644
--- a/src/cmp/cmpffi.lsp
+++ b/src/cmp/cmpffi.lsp
@@ -30,6 +30,7 @@
     :cl-index ((integer 0 #.most-positive-fixnum) "cl_index")
     :float (single-float "float")
     :double (double-float "double")
+    #+:long-float :long-double #+:long-float (long-float "long double")
     :char (base-char "char")
     :unsigned-char (base-char "char")
     :wchar (character "cl_index")
@@ -104,6 +105,7 @@
 	   (CHARACTER-VALUE (type-of (code-char (second loc))))
 	   (DOUBLE-FLOAT-VALUE 'DOUBLE-FLOAT)
 	   (SINGLE-FLOAT-VALUE 'SINGLE-FLOAT)
+	   (LONG-FLOAT-VALUE 'LONG-FLOAT)
 	   (C-INLINE (let ((type (first (second loc))))
 		       (if (lisp-type-p type) type (rep-type->lisp-type type))))
 	   (BIND (var-type (second loc)))
@@ -121,6 +123,7 @@
 	   (CHARACTER-VALUE (if (<= (second loc) 255) :char :wchar))
 	   (DOUBLE-FLOAT-VALUE :double)
 	   (SINGLE-FLOAT-VALUE :float)
+	   (LONG-FLOAT-VALUE :long-double)
 	   (C-INLINE (let ((type (first (second loc))))
 		       (if (lisp-type-p type) (lisp-type->rep-type type) type)))
 	   (BIND (var-rep-type (second loc)))
@@ -148,7 +151,7 @@
 	((:int :long :byte :fixnum)
 	 (case loc-rep-type
 	   ((:int :unsigned-int :long :unsigned-long :byte :unsigned-byte :fixnum
-		  :float :double)
+		  :float :double :long-double)
 	    (wt "((" (rep-type-name dest-rep-type) ")" loc ")"))
 	   ((:object)
 	    (ensure-valid-object-type dest-type)
@@ -162,7 +165,7 @@
 	((:unsigned-int :unsigned-long :unsigned-byte)
 	 (case loc-rep-type
 	   ((:int :unsigned-int :long :unsigned-long :byte :unsigned-byte :fixnum
-		  :float :double)
+		  :float :double :long-double)
 	    (wt "((" (rep-type-name dest-rep-type) ")" loc ")"))
 	   ((:object)
 	    (ensure-valid-object-type dest-type)
@@ -182,23 +185,26 @@
 	    (wt "ecl_char_code(" loc ")"))
 	   (otherwise
 	    (coercion-error))))
-	((:float :double)
+	((:float :double :long-double)
 	 (case loc-rep-type
 	   ((:int :unsigned-int :long :unsigned-long :byte :unsigned-byte :fixnum
-		  :float :double)
+		  :float :double :long-double)
 	    (wt "((" (rep-type-name dest-rep-type) ")" loc ")"))
 	   ((:object)
 	    ;; We relax the check a bit, because it is valid in C to coerce
 	    ;; between floats of different types.
 	    (ensure-valid-object-type 'FLOAT)
-	    (wt (if (eq loc-rep-type :float) "ecl_to_float(" "ecl_to_double(")
+	    (wt (ecase dest-rep-type
+		  (:float "ecl_to_float(")
+		  (:double "ecl_to_double(")
+		  (:long-double "ecl_to_long_double("))
 		loc ")"))
 	   (otherwise
 	    (coercion-error))))
 	((:bool)
 	 (case loc-rep-type
 	   ((:int :unsigned-int :long :unsigned-long :byte :unsigned-byte :fixnum
-		  :float :double :char :unsigned-char :wchar)
+		  :float :double :long-double :char :unsigned-char :wchar)
 	    (wt "1"))
 	   ((:object)
 	    (wt "(" loc ")!=Cnil"))
@@ -220,6 +226,10 @@
 	    (if (and (consp loc) (eq (first loc) 'DOUBLE-FLOAT-VALUE))
 		(wt (third loc)) ;; VV index
 		(wt "ecl_make_doublefloat(" loc ")")))
+	   ((:long-double)
+	    (if (and (consp loc) (eq (first loc) 'LONG-FLOAT-VALUE))
+		(wt (third loc)) ;; VV index
+		(wt "make_longfloat(" loc ")")))
 	   ((:bool)
 	    (wt "((" loc ")?Ct:Cnil)"))
 	   ((:char :unsigned-char :wchar)
diff --git a/src/cmp/cmploc.lsp b/src/cmp/cmploc.lsp
index b6bdef197..7c4e9da71 100644
--- a/src/cmp/cmploc.lsp
+++ b/src/cmp/cmploc.lsp
@@ -38,6 +38,7 @@
 ;;;	( MAKE-CCLOSURE cfun )
 ;;;	( FIXNUM-VALUE fixnum-value )
 ;;;	( CHARACTER-VALUE character-code )
+;;;	( LONG-FLOAT-VALUE long-float-value vv )
 ;;;	( DOUBLE-FLOAT-VALUE double-float-value vv )
 ;;;	( SINGLE-FLOAT-VALUE single-float-value vv )
 ;;;	( STACK-POINTER index )	retrieve a value from the stack
@@ -133,7 +134,7 @@
 (defun last-call-p ()
   (member *exit*
           '(RETURN RETURN-FIXNUM RETURN-CHARACTER RETURN-SINGLE-FLOAT
-            RETURN-DOUBLE-FLOAT RETURN-OBJECT)))
+            RETURN-DOUBLE-FLOAT RETURN-LONG-FLOAT RETURN-OBJECT)))
 
 (defun wt-car (loc) (wt "CAR(" loc ")"))
 
@@ -200,6 +201,7 @@
 (put-sysprop 'CADR 'WT-LOC #'wt-cadr)
 (put-sysprop 'FIXNUM-VALUE 'WT-LOC #'wt-number)
 (put-sysprop 'CHARACTER-VALUE 'WT-LOC #'wt-character)
+(put-sysprop 'LONG-FLOAT-VALUE 'WT-LOC #'wt-number)
 (put-sysprop 'DOUBLE-FLOAT-VALUE 'WT-LOC #'wt-number)
 (put-sysprop 'SINGLE-FLOAT-VALUE 'WT-LOC #'wt-number)
 (put-sysprop 'VALUE 'WT-LOC #'wt-value)
diff --git a/src/cmp/cmpwt.lsp b/src/cmp/cmpwt.lsp
index 1b2c6de5b..41bbb99b9 100644
--- a/src/cmp/cmpwt.lsp
+++ b/src/cmp/cmpwt.lsp
@@ -57,6 +57,8 @@
      (princ form *compiler-output1*))
     ((or DOUBLE-FLOAT SINGLE-FLOAT)
      (format *compiler-output1* "~10,,,,,,'eG" form))
+    (LONG-FLOAT
+     (format *compiler-output1* "~,,,,,,'eEl" form))
     (VAR (wt-var form))
     (t (wt-loc form)))
   nil)