home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / primops / genarith.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  5.7 KB  |  194 lines
  1. (herald genarith
  2.   (env tsys (t3_primops open) (t3_primops aliases)))
  3.  
  4. (define-constant (add . args)         
  5.   (iterate loop ((args args) (res '0))
  6.     (if (null? args)
  7.         res
  8.         (loop (cdr args) (%add (car args) res)))))
  9.  
  10. (declare simplifier add
  11.   (lambda (call)
  12.     (let ((args (cdr (call-args call))))
  13.       (cond ((null? args)
  14.              (replace-call-with-value call (create-literal-node '0))
  15.              '#t)
  16.             ((null? (cdr args))  ; (+ 'a) => 'a in compiled code - no checking
  17.              (replace-call-with-value call (detach (car args)))
  18.              '#t)
  19.             (else
  20.              (n-ary->binary call '%add))))))
  21.  
  22. (define-constant (%add x y)
  23.   (let ((generic (lambda (x y) (%%add x y))))
  24.     (receive (ok? arg1 arg2)
  25.              (two-fixnums x y)
  26.       (if ok?
  27.           (receive (over? result)
  28.                    (fixnum-add-with-overflow arg1 arg2)
  29.             (if over? (generic x y) result))
  30.           (generic x y)))))
  31.  
  32. ;;; SUBTRACT
  33.  
  34. (define-constant (subtract x y)
  35.   (let ((generic (lambda (x y) (%%subtract x y))))
  36.     (receive (ok? arg1 arg2)
  37.              (two-fixnums x y)
  38.       (if ok?
  39.           (receive (over? result)
  40.                    (fixnum-subtract-with-overflow arg1 arg2)
  41.             (if over? (generic x y) result))
  42.           (generic x y)))))
  43.  
  44. ;;; MULTIPLY
  45.  
  46. (define-constant (multiply . args)    ; must be CONSTANT to get simplifier
  47.   (iterate loop ((args args) (res '1))
  48.     (if (null? args)
  49.         res
  50.         (loop (cdr args) (%multiply (car args) res)))))
  51.  
  52. (declare simplifier multiply
  53.   (lambda (call)
  54.     (let ((args (cdr (call-args call))))
  55.       (cond ((null? args)
  56.              (replace-call-with-value call (create-literal-node '1))
  57.              '#t)
  58.             ((null? (cdr args))  ; (* 'a) => 'a in compiled code - no checking
  59.              (replace-call-with-value call (detach (car args)))
  60.              '#t)
  61.             (else
  62.              (n-ary->binary call '%multiply)))))) 
  63.  
  64. (define-constant (%multiply x y)
  65.   (let ((generic (lambda (x y) (%%multiply x y))))
  66.     (receive (ok? arg1 arg2)
  67.              (two-fixnums x y)
  68.       (if ok?
  69.           (receive (over? result)
  70.                    (fixnum-multiply-with-overflow arg1 arg2)
  71.             (if over? (generic x y) result))
  72.           (generic x y)))))
  73.  
  74. ;;; DIVIDE
  75.  
  76. (define-constant fixnum-remainder-with-hack
  77.   (primop fixnum-remainder-with-hack ()
  78.     ((primop.generate self node)
  79.      (generate-hack-dr node 'remainder))
  80.     ((primop.make-closed self) primop/undefined-effect)
  81.     ((primop.type self node)
  82.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  83.  
  84.  
  85. (define-constant (remainder x y)
  86.   (receive (ok? arg1 arg2)
  87.            (two-fixnums x y)
  88.     (if ok?
  89.         (fixnum-remainder-with-hack arg1 arg2)   ; no overflow possible
  90.         (%%remainder x y))))
  91.  
  92. (define-constant (logand x y)
  93.   (receive (ok? arg1 arg2)
  94.            (two-fixnums x y)
  95.     (if ok?
  96.         (fixnum-logand arg1 arg2)   ; no overflow possible
  97.         (%%logand x y))))
  98.  
  99. (define-constant (logior x y)
  100.   (receive (ok? arg1 arg2)
  101.            (two-fixnums x y)
  102.     (if ok?
  103.         (fixnum-logior arg1 arg2)   ; no overflow possible
  104.         (%%logior x y))))
  105.  
  106. (define-constant (logxor x y)
  107.   (receive (ok? arg1 arg2)
  108.            (two-fixnums x y)
  109.     (if ok?
  110.         (fixnum-logxor arg1 arg2)   ; no overflow possible
  111.         (%%logxor x y))))
  112.  
  113. (define-constant (lognot x)
  114.   (logxor x -1))
  115.  
  116. ;;; LESS?
  117.  
  118. (define-constant (less? x y)
  119.   (if (two-fixnums-for-compare? x y)
  120.       (fx< x y)
  121.       (%%less? x y)))
  122.  
  123. ;;; NUMBER-EQUAL?
  124.  
  125. (define-constant (number-equal? x y)
  126.   (if (two-fixnums-for-compare? x y)
  127.       (fx= x y)
  128.       (%%equal? x y)))
  129.  
  130. ;;; Thousands of random ways to call the above
  131.  
  132. (define-constant (negate x) (subtract 0 x))
  133.  
  134. (define-constant + add)
  135.  
  136. (define-constant (- x . y)            ; must be CONSTANT to get simplifier
  137.   (cond ((null? y) (negate x))
  138.         ((null? (cdr y)) (subtract x (car y)))
  139.         (else (error "wrong number of arguments to procedure~%  ~S"
  140.              `(- ,x . ,y)))))
  141.  
  142. (declare simplifier -
  143.   (lambda (call)
  144.     (let ((args (cdr (call-args call))))
  145.       (cond ((null? args)
  146.              (user-message 'warning "- called with no arguments" '#f)
  147.              '#f)       ; Error at runtime
  148.             ((null? (cdr args))
  149.              (replace (call-proc call)
  150.                       (create-reference-node (get-system-variable 'negate)))
  151.              '#t)
  152.             ((null? (cddr args))
  153.              (replace (call-proc call)
  154.                       (create-reference-node (get-system-variable 'subtract))))
  155.             (else
  156.              (user-message 'warning "more than two arguments in a call to -" '#f)
  157.              '#f)))))   ; Error at runtime
  158.  
  159.  
  160. (define-constant * multiply)
  161.  
  162. (define-constant (add1      x) (%add     x 1))
  163. (define-constant (subtract1 x) (subtract x 1))
  164.  
  165. (define-constant  1+ add1)
  166. (define-constant -1+ subtract1)
  167. (define-constant (=1? x) (= x 1))
  168.  
  169. (define-constant (not-less? x y)         (not (less? x y)))
  170. (define-constant (number-not-equal? x y) (not (number-equal? x y)))
  171. (define-constant (greater? x y)          (less? y x))
  172. (define-constant (not-greater? x y)      (not (less? y x)))
  173.  
  174. (define-constant <  less?)
  175. (define-constant <= not-greater?)
  176. (define-constant =  number-equal?)
  177. (define-constant N= number-not-equal?)
  178. (define-constant >  greater?)
  179. (define-constant >= not-less?)
  180.  
  181. (define-constant (negative? x)     (< x 0))
  182. (define-constant (zero? x)         (= x 0))
  183. (define-constant (positive? x)     (> x 0))
  184. (define-constant (not-negative? x) (>= x 0))
  185. (define-constant (not-zero? x)     (N= x 0))
  186. (define-constant (not-positive? x) (<= x 0))
  187.  
  188. (define-constant <0?  negative?)
  189. (define-constant =0?  zero?)
  190. (define-constant >0?  positive?)
  191. (define-constant >=0? not-negative?)
  192. (define-constant n=0? not-zero?)
  193. (define-constant <=0? not-positive?)
  194.