mirrors/ecl
1
Fork 0
mirror of https://gitlab.com/embeddable-common-lisp/ecl.git synced 2026-01-11 11:42:51 -08:00
Code Issues Projects Releases Packages Wiki Activity

Added support for long double types in the compiler

Browse source
This commit is contained in:
jjgarcia 2008-08-02 18:30:48 +00:00
parent 860d38f2bb
commit 2ef8b05d4b
4 changed files with 24 additions and 7 deletions
Download patch file Download diff file Expand all files Collapse all files

3
src/cmp/cmpct.lsp
View file

@ -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))))

22
src/cmp/cmpffi.lsp
View file

@ -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)

4
src/cmp/cmploc.lsp
View file

@ -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)

2
src/cmp/cmpwt.lsp
View file

@ -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)