Commit 2ef8b05d authored by jjgarcia's avatar jjgarcia
Browse files

Added support for long double types in the compiler

parent 860d38f2
......@@ -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))))
......
......@@ -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)
......
......@@ -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)
......
......@@ -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)
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment