home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / sources.lha / sources / comp / primops / vaxarith.t < prev    next >
Encoding:
Text File  |  1988-02-05  |  10.1 KB  |  281 lines
  1. (herald vaxarith
  2.         (env (make-empty-early-binding-locale 'nil) 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 'jneq))
  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 'jgeq))
  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 'jneq))
  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 'jgeq))
  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-fixnum-binop node 'add t nil))
  114.     ((primop.simplify self node)
  115.      (simplify-fixnum-add node))
  116.     ((primop.rep-wants self)
  117.      '(* *))
  118.     ((primop.type self node)
  119.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  120.  
  121. (define-constant fixnum-logior
  122.   (primop fixnum-logior ()
  123.     ((primop.generate self node)
  124.      (generate-fixnum-binop node 'or t nil))
  125.     ((primop.simplify self node)
  126.      (simplify-fixnum-logior node))
  127.     ((primop.rep-wants self)
  128.      '(* *))
  129.     ((primop.type self node)
  130.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  131.  
  132. (define-constant fixnum-logxor
  133.   (primop fixnum-logxor ()
  134.     ((primop.generate self node)
  135.      (generate-fixnum-binop node 'xor t nil))
  136.     ((primop.simplify self node)
  137.      (simplify-fixnum-logxor node))
  138.     ((primop.rep-wants self)
  139.      '(* *))
  140.     ((primop.type self node)
  141.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  142.  
  143. (define-constant (fixnum-logand x y)
  144.   (fixnum-logandc x (fixnum-lognot y)))
  145.                                 
  146. (define-constant (fixnum-lognot x)
  147.    (fixnum-logxor x -1))                                      
  148.  
  149. (define-constant (fixnum-negate x)
  150.   (fixnum-subtract 0 x))
  151.  
  152. (define-constant fixnum-subtract
  153.   (primop fixnum-subtract ()
  154.     ((primop.generate self node)
  155.      (generate-fixnum-binop node 'sub nil nil))
  156.     ((primop.simplify self node)
  157.      (simplify-fixnum-subtract node))
  158.     ((primop.rep-wants self)
  159.      '(* *))
  160.     ((primop.type self node)
  161.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  162.  
  163. (define-constant fixnum-multiply
  164.   (primop fixnum-multiply ()
  165.     ((primop.generate self node)
  166.      (generate-fixnum-binop node 'mul t t))
  167.     ((primop.rep-wants self) '(rep/integer rep/integer))
  168.     ((primop.simplify self node)
  169.      (simplify-fixnum-multiply node))
  170.     ((primop.type self node)
  171.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  172.  
  173. (define-constant fixnum-divide
  174.   (primop fixnum-divide ()
  175.     ((primop.generate self node)
  176.      (generate-fixnum-binop node 'div nil t))
  177.     ((primop.simplify self node)
  178.      (simplify-fixnum-divide node))
  179.     ((primop.type self node)
  180.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  181.                         
  182. (define-constant (fixnum-ashr x y)
  183.   (fixnum-ash x (fixnum-subtract 0 y)))
  184.  
  185. (define-constant (fixnum-ashl x y) (fixnum-ash x y))
  186.  
  187. (define-constant fixnum-ash
  188.   (primop fixnum-ash ()
  189.     ((primop.generate self node)
  190.      (generate-fixnum-binop node 'ash nil t))
  191.     ((primop.rep-wants self)
  192.      '(* rep/integer))
  193.     ((primop.arg-specs self)
  194.      '(scratch scratch))
  195.     ((primop.type self node)
  196.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  197.  
  198. (define-constant fixnum-logandc
  199.   (primop fixnum-logandc ()
  200.     ((primop.generate self node)
  201.      (generate-fixnum-binop node 'andc nil nil))
  202.     ((primop.rep-wants self)
  203.      '(* *))
  204.     ((primop.type self node)
  205.      '#[type (proc #f (proc #f fixnum) fixnum fixnum)])))
  206.  
  207. (define-constant (fixnum-remainder x y)
  208.   (fixnum-subtract x (fixnum-multiply (fixnum-divide x y) y)))
  209.  
  210. (define-constant fixnum-add-with-overflow
  211.   (primop fixnum-add-with-overflow ()
  212.     ((primop.values-returned self) 1)                               
  213.     ((primop.generate self node)
  214.      (generate-op-with-overflow node 'add))
  215.     ((primop.presimplify self node)
  216.      (presimplify-to-funny-conditional node 1))
  217.     ((primop.conditional? self) t)
  218.     ((primop.make-closed self) primop/undefined-effect)
  219.     ((primop.conditional-type self node)
  220.      '#[type (proc #f (proc #f fixnum) (proc #f fixnum) top fixnum fixnum)])
  221.     ((primop.type self node)
  222.      '#[type (proc #f (proc #f boolean fixnum) fixnum fixnum)])))
  223.  
  224. (define-constant fixnum-multiply-with-overflow
  225.   (primop fixnum-multiply-with-overflow ()
  226.     ((primop.values-returned self) 1)                               
  227.     ((primop.generate self node)
  228.      (generate-op-with-overflow node 'multiply))
  229.     ((primop.presimplify self node)
  230.      (presimplify-to-funny-conditional node 1))
  231.     ((primop.conditional? self) t)
  232.     ((primop.make-closed self) primop/undefined-effect)
  233.     ((primop.conditional-type self node)
  234.      '#[type (proc #f (proc #f fixnum) (proc #f fixnum) top fixnum fixnum)])
  235.     ((primop.type self node)
  236.      '#[type (proc #f (proc #f boolean fixnum) fixnum fixnum)])))
  237.       
  238. (define-constant fixnum-subtract-with-overflow
  239.   (primop fixnum-subtract-with-overflow ()
  240.     ((primop.values-returned self) 1)                               
  241.     ((primop.generate self node)
  242.      (generate-op-with-overflow node 'subtract))
  243.     ((primop.presimplify self node)
  244.      (presimplify-to-funny-conditional node 1))
  245.     ((primop.conditional? self) t)
  246.     ((primop.make-closed self) primop/undefined-effect)
  247.     ((primop.conditional-type self node)
  248.      '#[type (proc #f (proc #f fixnum) (proc #f fixnum) top fixnum fixnum)])
  249.     ((primop.type self node)
  250.      '#[type (proc #f (proc #f boolean fixnum) fixnum fixnum)])))
  251.       
  252. (define-constant two-fixnums
  253.   (primop two-fixnums ()
  254.     ((primop.values-returned self) 2)                               
  255.     ((primop.generate self node)
  256.      (generate-two-fixnums node nil))
  257.     ((primop.presimplify self node)
  258.      (presimplify-to-funny-conditional node 2))
  259.     ((primop.conditional? self) t)
  260.     ((primop.make-closed self) primop/undefined-effect)
  261.     ((primop.conditional-type self node)
  262.      '#[type (proc #f (proc #f fixnum fixnum) (proc #f fixnum fixnum) 
  263.           top top top)])
  264.     ((primop.type self node)
  265.      '#[type (proc #f (proc #f boolean fixnum fixnum) top top)])))
  266.  
  267. (define-constant two-fixnums-for-compare?
  268.   (primop two-fixnums-for-compare? ()
  269.     ((primop.generate self node)
  270.      (generate-two-fixnums node t))
  271.     ((primop.presimplify self node)
  272.      (presimplify-to-conditional node))
  273.     ((primop.make-closed self) primop/undefined-effect)
  274.     ((primop.conditional? self) t)
  275.     ((primop.conditional-type self node)
  276.      '#[type (proc #f (proc #f) (proc #f) top top top)])
  277.     ((primop.type self node)
  278.      '#[type (proc #f (proc #f boolean) top top)])))
  279.  
  280.  
  281.