Skip to content
GitLab
Menu
Projects
Groups
Snippets
Loading...
Help
Help
Support
Community forum
Keyboard shortcuts
?
Submit feedback
Contribute to GitLab
Sign in / Register
Toggle navigation
Menu
Open sidebar
ecl
ecl
Commits
2ef8b05d
Commit
2ef8b05d
authored
Aug 02, 2008
by
jjgarcia
Browse files
Added support for long double types in the compiler
parent
860d38f2
Changes
4
Hide whitespace changes
Inline
Side-by-side
src/cmp/cmpct.lsp
View file @
2ef8b05d
...
...
@@ -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))))
...
...
src/cmp/cmpffi.lsp
View file @
2ef8b05d
...
...
@@ -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)
...
...
src/cmp/cmploc.lsp
View file @
2ef8b05d
...
...
@@ -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)
...
...
src/cmp/cmpwt.lsp
View file @
2ef8b05d
...
...
@@ -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)
...
...
Write
Preview
Markdown
is supported
0%
Try again
or
attach a new file
.
Attach a file
Cancel
You are about to add
0
people
to the discussion. Proceed with caution.
Finish editing this message first!
Cancel
Please
register
or
sign in
to comment