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

Since not always the compiler macros are applied, we are forced to have type propagators that handle the 1, 2 and more argument cases for +, *, / and -.

Browse source
This commit is contained in:
Juan Jose Garcia Ripoll 2009-07-08 23:03:13 +02:00
parent 759fa298ab
commit 03afa98d41
1 changed files with 23 additions and 28 deletions
Download patch file Download diff file Expand all files Collapse all files

51
src/cmp/cmpnum.lsp
View file

@ -77,35 +77,30 @@
(when (and (null t2-eq) (type>= i t2))
(setf t2-eq i output i)))))
(defun prod/plus-propagator (op1 op2)
(multiple-value-bind (result-type op1-type op2-type)
(maximum-number-type (c1form-primary-type op1)
(c1form-primary-type op2))
(when (and (eq op1-type 'FIXNUM)
(eq op2-type 'FIXNUM))
(setf result-type 'INTEGER))
(values (list op1-type op2-type) result-type)))
(defun arithmetic-propagator (op1 others integer-result)
(loop with op1-type = (c1form-primary-type op1)
with result-type = (maximum-number-type op1-type op1-type)
with arg-types = (list (setf op1-type result-type))
for op2 in others
for op2-type = (c1form-primary-type op2)
do (progn
(multiple-value-setq (result-type op1-type op2-type)
(maximum-number-type op1-type op2-type))
(when (and (or (eq op1-type 'FIXNUM) (eq op1-type 'INTEGER))
(or (eq op2-type 'FIXNUM) (eq op2-type 'INTEGER)))
(setf result-type integer-result))
(setf arg-types (cons op2-type arg-types)
op1-type result-type))
finally (return (values (nreverse arg-types) result-type))))
(def-type-propagator * (fname op1 op2)
(prod/plus-propagator op1 op2))
(def-type-propagator * (fname op1 &rest others)
(arithmetic-propagator op1 others 'integer))
(def-type-propagator + (fname op1 op2)
(prod/plus-propagator op1 op2))
(def-type-propagator + (fname op1 &rest others)
(arithmetic-propagator op1 others 'integer))
(def-type-propagator - (fname op1 &optional (op2 nil op2-p))
(let* ((t1 (c1form-primary-type op1))
(t2 (if op2-p (c1form-primary-type op2) t1)))
(values (if op2-p (list t1 t2) (list t1))
(maximum-number-type t1 t2))))
(def-type-propagator - (fname op1 &rest others)
(arithmetic-propagator op1 others 'integer))
(def-type-propagator / (fname op1 &optional (op2 nil op2-p))
(multiple-value-bind (output t1 t2)
(let ((t1 (c1form-primary-type op1)))
(if op2-p
(maximum-number-type t1 (c1form-primary-type op2))
(maximum-number-type 'FIXNUM t1)))
(when (and (member t1 '(FIXNUM INTEGER))
(member t2 '(FIXNUM INTEGER)))
(setf output 'RATIONAL))
(values (if op2-p (list t1 t2) (list t1))
output)))
(def-type-propagator / (fname op1 &rest others)
(arithmetic-propagator op1 others 'rational))