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