Commit ad6a35f9 authored by Juan Jose Garcia Ripoll's avatar Juan Jose Garcia Ripoll
Browse files

Implemented type propagation for *, +, - and /

parent 52c7aba6
......@@ -14,28 +14,32 @@
(in-package "COMPILER")
(defun simplify-arithmetic (operator args whole)
(let ((l (length args)))
(cond ((every #'numberp args)
(apply operator args))
((> l 2)
(simplify-arithmetic
operator
(list* (simplify-arithmetic operator (list (first args) (second args)) nil)
(cddr args))
nil))
((= l 2)
(or whole (list* operator args)))
((= l 1)
(if (or (eq operator '*) (eq operator '+))
(first args)
(or whole (list* operator args))))
((eq operator '*)
1)
((eq operator '+)
0)
(t
(error 'simple-program-error :format-error "Wrong number of arguments for operator ~a in ~a"
:format-arguments (list operators (or whole (list* operator args))))))))
(if (every #'numberp args)
(apply operator args)
(let ((l (length args)))
(cond ((> l 2)
(simplify-arithmetic
operator
(list* (simplify-arithmetic operator
(list (first args) (second args))
nil)
(cddr args))
nil))
((= l 2)
(or whole (list* operator args)))
((= l 1)
(if (or (eq operator '*) (eq operator '+))
(first args)
(or whole (list* operator args))))
((eq operator '*)
1)
((eq operator '+)
0)
(t
(error 'simple-program-error
:format-error "Wrong number of arguments for operator ~a in ~a"
:format-arguments (list operators (or whole
(list* operator args)))))))))
(define-compiler-macro * (&whole all &rest args)
(simplify-arithmetic '* args all))
......@@ -49,3 +53,61 @@
(define-compiler-macro - (&whole all &rest args)
(simplify-arithmetic '- args all))
;;;
;;; The following are type propagators for arithmetic operations. Note
;;; that some of they have become binary operators.
;;;
(defun maximum-number-type (t1 t2)
(let ((t1-eq nil)
(t2-eq nil)
(output nil))
(dolist (i '(FIXNUM INTEGER RATIONAL
#+short-float SHORT-FLOAT SINGLE-FLOAT
DOUBLE-FLOAT #+long-float LONG-FLOAT FLOAT REAL
COMPLEX NUMBER)
(values (if (and t1-eq t2-eq output)
output
t)
t1 t2))
(when (and (null t1-eq) (type>= i t1))
(setf t1-eq i)
(if (equalp t1 t2)
(setf t2-eq i))
(setf output t1-eq))
(when (and (null t2-eq) (type>= i t2))
(setf t2-eq i)
(setf output t1-eq)))))
(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)))
(def-type-propagator * (fname op1 op2)
(prod/plus-propagator op1 op2))
(def-type-propagator + (fname op1 op2)
(prod/plus-propagator op1 op2))
(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 &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)))
Supports Markdown
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