home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / comp / primops / sparith.t < prev    next >
Encoding:
Text File  |  1989-06-30  |  9.7 KB  |  279 lines
  1. (herald sparith
  2.   (env (*value orbit-env 'base-early-binding-env) primops))
  3.  
  4. ;;; Copyright (c) 1985 Yale University
  5. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  6. ;;; This material was developed by the T Project at the Yale University Computer 
  7. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  8. ;;; and to use it for any purpose is granted, subject to the following restric-
  9. ;;; tions and understandings.
  10. ;;; 1. Any copy made of this software must include this copyright notice in full.
  11. ;;; 2. Users of this software agree to make their best efforts (a) to return
  12. ;;;    to the T Project at Yale any improvements or extensions that they make,
  13. ;;;    so that these may be included in future releases; and (b) to inform
  14. ;;;    the T Project of noteworthy uses of this software.
  15. ;;; 3. All materials developed as a consequence of the use of this software
  16. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  17. ;;;    of acknowledging credit in academic research.
  18. ;;; 4. Yale has made no warrantee or representation that the operation of
  19. ;;;    this software will be error-free, and Yale is under no obligation to
  20. ;;;    provide any services, by way of maintenance, update, or otherwise.
  21. ;;; 5. In conjunction with products arising from the use of this material,
  22. ;;;    there shall be no use of the name of the Yale University nor of any
  23. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  24. ;;;    without prior written consent from Yale in each case.
  25. ;;;
  26.  
  27. ;;; Copyright (c) 1985 David Kranz
  28.  
  29. (define-constant fixnum-equal?
  30.   (primop fixnum-equal? ()
  31.     ((primop.generate self node)
  32.      (fixnum-comparator node jump-op/jn=))
  33.     ((primop.presimplify self node)
  34.      (presimplify-to-conditional node))
  35.     ((primop.make-closed self)
  36.      (make-closed-conditional self))
  37.     ((primop.conditional? self) t)
  38.     ((primop.conditional-type self node)
  39.      '#[type (proc #f (proc #f) (proc #f) top fixnum fixnum)])
  40.     ((primop.type self node)
  41.      '#[type (proc #f (proc #f boolean) fixnum fixnum)])))
  42.  
  43. (define-constant fixnum-less?
  44.   (primop fixnum-less? ()
  45.     ((primop.generate self node)
  46.      (fixnum-comparator node jump-op/j>=))
  47.     ((primop.presimplify self node)
  48.      (presimplify-to-conditional node))
  49.     ((primop.make-closed self)
  50.      (make-closed-conditional self))
  51.     ((primop.conditional? self) t)
  52.     ((primop.conditional-type self node)
  53.      '#[type (proc #f (proc #f) (proc #f) top fixnum fixnum)])
  54.     ((primop.type self node)
  55.      '#[type (proc #f (proc #f boolean) fixnum fixnum)])))
  56.  
  57. (define-constant char=
  58.   (primop char= ()
  59.     ((primop.generate self node)
  60.      (character-comparator node jump-op/jn=))
  61.     ((primop.presimplify self node)
  62.      (presimplify-to-conditional node))
  63.     ((primop.conditional? self) t)
  64.     ((primop.make-closed self)
  65.      (make-closed-conditional self))
  66.     ((primop.conditional-type self node)
  67.      '#[type (proc #f (proc #f) (proc #f) top char char)])
  68.     ((primop.type self node)
  69.      '#[type (proc #f (proc #f boolean) char char)])))
  70.  
  71. (define-constant char<
  72.   (primop char< ()
  73.     ((primop.generate self node)
  74.      (character-comparator node jump-op/j>=))
  75.     ((primop.presimplify self node)
  76.      (presimplify-to-conditional node))
  77.     ((primop.make-closed self)
  78.      (make-closed-conditional self))
  79.     ((primop.conditional? self) t)
  80.     ((primop.conditional-type self node)
  81.      '#[type (proc #f (proc #f) (proc #f) top char char)])
  82.     ((primop.type self node)
  83.      '#[type (proc #f (proc #f boolean) char char)])))
  84.  
  85. (define-constant char->ascii
  86.   (primop char->ascii ()
  87.     ((primop.generate self node)
  88.      (generate-char->ascii node))
  89.     ((primop.rep-wants self)
  90.      '(rep/char))
  91.     ((primop.arg-specs self)
  92.      '(scratch))
  93.     ((primop.type self node)
  94.      '#[type (proc #f (proc #f fixnum) char)])))
  95.  
  96. (define-constant ascii->char
  97.   (primop ascii->char ()
  98.     ((primop.generate self node)
  99.      (generate-ascii->char node))
  100.     ((primop.rep-wants self)
  101.      '(rep/integer))
  102.     ((primop.arg-specs self)
  103.      '(scratch))
  104.     ((primop.type self node)
  105.      '#[type (proc #f (proc #f char) fixnum)])))
  106.  
  107. ;;; ARITHMETIC
  108. ;;;===========================================================================
  109.  
  110. (define-constant fixnum-add
  111.   (primop fixnum-add ()
  112.     ((primop.generate self node)
  113.      (generate-numeric-op node 'add))
  114.     ((primop.simplify self node)
  115.      (simplify-fixnum-add node))
  116.     ((primop.type self node)
  117.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  118.  
  119. (define-constant fixnum-subtract
  120.   (primop fixnum-subtract ()
  121.     ((primop.generate self node)
  122.      (generate-numeric-op node 'sub))
  123.     ((primop.simplify self node)
  124.      (simplify-fixnum-subtract node))
  125.     ((primop.type self node)
  126.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  127. #|
  128. (define-constant fixnum-multiply
  129.   (primop fixnum-multiply ()
  130.     ((primop.generate self node)
  131.      (generate-numeric-op node 'mul))
  132.     ((primop.simplify self node)
  133.      (simplify-fixnum-multiply node))
  134.     ((primop.type self node)
  135.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  136.  
  137. (define-constant fixnum-divide
  138.   (primop fixnum-divide ()
  139.     ((primop.generate self node)
  140.      (generate-numeric-op node 'div))
  141.     ((primop.simplify self node)
  142.      (simplify-fixnum-divide node))
  143.     ((primop.type self node)
  144.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  145.  
  146. (define-constant fixnum-remainder
  147.   (primop fixnum-remainder ()
  148.     ((primop.generate self node)
  149.      (generate-numeric-op node 'rem))
  150.     ((primop.type self node)
  151.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  152. |#
  153. (define-foreign %fixnum-multiply ("fxmul" (in rep/pointer) (in rep/integer))
  154.   rep/pointer)
  155.  
  156. (define-foreign %fixnum-divide ("fxdiv" (in rep/pointer) (in rep/pointer))
  157.   rep/integer)
  158.  
  159. (define-foreign %fixnum-remainder ("fxrem" (in rep/pointer) (in rep/pointer))
  160.   rep/pointer)
  161.  
  162. (define (fixnum-multiply x y)
  163.   (if (two-fixnums? x y)
  164.       (%fixnum-multiply x y)
  165.       (error "Non-fixnum argument to FIXNUM-MULTIPLY ~s,~s" x y)))
  166.  
  167. (define (fixnum-divide x y)
  168.   (if (two-fixnums? x y)
  169.       (%fixnum-divide x y)
  170.       (error "Non-fixnum argument to FIXNUM-DIVIDE ~s,~s" x y)))
  171.  
  172. (define (fixnum-remainder x y)
  173.   (if (two-fixnums? x y)
  174.       (%fixnum-remainder x y)
  175.       (error "Non-fixnum argument to FIXNUM-REMAINDER ~s,~s" x y)))
  176.  
  177. (define-constant fixnum-logior
  178.   (primop fixnum-logior ()
  179.     ((primop.generate self node)
  180.      (generate-numeric-op node 'or))
  181.     ((primop.simplify self node)
  182.      (simplify-fixnum-logior node))
  183.     ((primop.type self node)
  184.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  185.  
  186. (define-constant fixnum-logxor
  187.   (primop fixnum-logxor ()
  188.     ((primop.generate self node)
  189.      (generate-numeric-op node 'xor))
  190.     ((primop.simplify self node)
  191.      (simplify-fixnum-logxor node))
  192.     ((primop.type self node)
  193.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  194.  
  195. (define-constant fixnum-logand
  196.   (primop fixnum-logand ()
  197.     ((primop.generate self node)
  198.      (generate-numeric-op node 'and))
  199.     ((primop.simplify self node)
  200.      (simplify-fixnum-logand node))
  201.     ((primop.type self node)
  202.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  203.  
  204. (define-constant (fixnum-lognot x)
  205.    (fixnum-logxor x -1))                                      
  206.  
  207. (define-constant (fixnum-negate x)
  208.   (fixnum-subtract 0 x))
  209.  
  210.  
  211.  
  212. (define-constant (fixnum-ash integer amount)
  213.   (if (fixnum-less? amount 0) 
  214.       (fixnum-ashr integer (fixnum-subtract 0 amount))
  215.       (fixnum-ashl integer amount)))
  216.                                     
  217. (define-constant fixnum-ashl
  218.  (primop fixnum-ashl ()
  219.     ((primop.generate self node)
  220.      (generate-numeric-op node 'ashl))
  221.     ((primop.simplify self node)
  222.      (simplify-fixnum-shift node fixnum-ashl))
  223.     ((primop.type self node)
  224.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  225.                                     
  226. (define-constant fixnum-ashr
  227.  (primop fixnum-ashr ()
  228.     ((primop.generate self node)
  229.      (generate-numeric-op node 'ashr))
  230.     ((primop.simplify self node)
  231.      (simplify-fixnum-shift node fixnum-ashr))
  232.     ((primop.type self node)
  233.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  234.  
  235. (define-constant fixnum-add-with-overflow
  236.   (primop fixnum-add-with-overflow ()
  237.     ((primop.values-returned self) 1)                               
  238.     ((primop.generate self node)
  239.      (generate-op-with-overflow node 'add))
  240.     ((primop.presimplify self node)
  241.      (presimplify-to-funny-conditional node 1))
  242.     ((primop.conditional? self) t)
  243.     ((primop.make-closed self) primop/undefined-effect)
  244.     ((primop.conditional-type self node)
  245.      '#[type (proc #f (proc #f fixnum) (proc #f fixnum) top fixnum fixnum)])
  246.     ((primop.type self node)
  247.      '#[type (proc #f (proc #f boolean fixnum) fixnum fixnum)])))
  248.  
  249. (define-constant fixnum-subtract-with-overflow
  250.   (primop fixnum-subtract-with-overflow ()
  251.     ((primop.values-returned self) 1)                               
  252.     ((primop.generate self node)
  253.      (generate-op-with-overflow node 'subtract))
  254.     ((primop.presimplify self node)
  255.      (presimplify-to-funny-conditional node 1))
  256.     ((primop.conditional? self) t)
  257.     ((primop.make-closed self) primop/undefined-effect)
  258.     ((primop.conditional-type self node)
  259.      '#[type (proc #f (proc #f fixnum) (proc #f fixnum) top fixnum fixnum)])
  260.     ((primop.type self node)
  261.      '#[type (proc #f (proc #f boolean fixnum) fixnum fixnum)])))
  262.  
  263. (define-constant two-fixnums?
  264.   (primop two-fixnums? ()
  265.     ((primop.generate self node)
  266.      (generate-two-fixnums node))
  267.     ((primop.presimplify self node)
  268.      (presimplify-to-conditional node))
  269.     ((primop.make-closed self) primop/undefined-effect)
  270.     ((primop.conditional? self) t)
  271.     ((primop.conditional-type self node)
  272.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  273.     ((primop.type self node)
  274.      '#[type (proc #f (proc #f boolean) top top)])))
  275.  
  276.  
  277.  
  278.  
  279.