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