home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 2 / Apprentice-Release2.iso / Tools / Languages / MacHaskell 2.2 / runtime / prims.scm < prev    next >
Encoding:
Text File  |  1994-09-27  |  19.3 KB  |  610 lines  |  [TEXT/CCL2]
  1. ;;; prims.scm -- definitions for primitives
  2. ;;;
  3. ;;; author :  Sandra Loosemore
  4. ;;; date   :  9 Jun 1992
  5. ;;;
  6. ;;; WARNING!!!  This file contains Common-Lisp specific code.
  7. ;;;
  8.  
  9.  
  10. ;;; Helper stuff
  11.  
  12. (define-integrable (is-fixnum? x)
  13.   (lisp:typep x 'lisp:fixnum))
  14.  
  15. (define-integrable (is-integer? x)
  16.   (lisp:typep x 'lisp:integer))
  17.  
  18. (define-integrable (is-single-float? x)
  19.   (lisp:typep x 'lisp:single-float))
  20.  
  21. (define-integrable (is-double-float? x)
  22.   (lisp:typep x 'lisp:double-float))
  23.  
  24. (define-syntax (the-fixnum x)
  25.   `(lisp:the lisp:fixnum ,x))
  26.  
  27. (define-syntax (the-integer x)
  28.   `(lisp:the lisp:integer ,x))
  29.  
  30. (define-syntax (the-single-float x)
  31.   `(lisp:the lisp:single-float ,x))
  32.  
  33. (define-syntax (the-double-float x)
  34.   `(lisp:the lisp:double-float ,x))
  35.  
  36. (define-syntax (make-haskell-tuple2 x y)
  37.   `(make-tuple (box ,x) (box ,y)))
  38.  
  39. ;;; Abort
  40. ;;; *** Should probably do something other than just signal an error.
  41.  
  42. (define (prim.abort s)
  43.   (haskell-runtime-error s))
  44.  
  45. (define (haskell-string->list s)
  46.   (if (null? s)
  47.       '()
  48.       (cons (integer->char (force (car s)))
  49.         (haskell-string->list (force (cdr s))))))
  50.  
  51. ;;; Char
  52.  
  53. (define-syntax (prim.char-to-int c)
  54.   `(the-fixnum ,c))
  55.  
  56. (define-syntax (prim.int-to-char i)
  57.   `(the-fixnum ,i))
  58.  
  59. (define-syntax (prim.eq-char i1 i2)
  60.   `(= (the-fixnum ,i1) (the-fixnum ,i2)))
  61. (define-syntax (prim.not-eq-char i1 i2)
  62.   `(not (= (the-fixnum ,i1) (the-fixnum ,i2))))
  63. (define-syntax (prim.le-char i1 i2)
  64.   `(<= (the-fixnum ,i1) (the-fixnum ,i2)))
  65. (define-syntax (prim.not-le-char i1 i2)
  66.   `(> (the-fixnum ,i1) (the-fixnum ,i2)))
  67. (define-syntax (prim.not-lt-char i1 i2)
  68.   `(>= (the-fixnum ,i1) (the-fixnum ,i2)))
  69. (define-syntax (prim.lt-char i1 i2)
  70.   `(< (the-fixnum ,i1) (the-fixnum ,i2)))
  71.  
  72. (define-integrable prim.max-char 255)
  73.  
  74.  
  75. ;;; Floating
  76.  
  77. (define-syntax (prim.eq-float f1 f2)
  78.   `(= (the-single-float ,f1) (the-single-float ,f2)))
  79. (define-syntax (prim.not-eq-float f1 f2)
  80.   `(not (= (the-single-float ,f1) (the-single-float ,f2))))
  81. (define-syntax (prim.le-float f1 f2)
  82.   `(<= (the-single-float ,f1) (the-single-float ,f2)))
  83. (define-syntax (prim.not-le-float f1 f2)
  84.   `(> (the-single-float ,f1) (the-single-float ,f2)))
  85. (define-syntax (prim.not-lt-float f1 f2)
  86.   `(>= (the-single-float ,f1) (the-single-float ,f2)))
  87. (define-syntax (prim.lt-float f1 f2)
  88.   `(< (the-single-float ,f1) (the-single-float ,f2)))
  89.  
  90. (define-syntax (prim.eq-double f1 f2)
  91.   `(= (the-double-float ,f1) (the-double-float ,f2)))
  92. (define-syntax (prim.not-eq-double f1 f2)
  93.   `(not (= (the-double-float ,f1) (the-double-float ,f2))))
  94. (define-syntax (prim.le-double f1 f2)
  95.   `(<= (the-double-float ,f1) (the-double-float ,f2)))
  96. (define-syntax (prim.not-le-double f1 f2)
  97.   `(> (the-double-float ,f1) (the-double-float ,f2)))
  98. (define-syntax (prim.not-lt-double f1 f2)
  99.   `(>= (the-double-float ,f1) (the-double-float ,f2)))
  100. (define-syntax (prim.lt-double f1 f2)
  101.   `(< (the-double-float ,f1) (the-double-float ,f2)))
  102.  
  103. (define-syntax (prim.float-max f1 f2)
  104.   `(the-single-float (max (the-single-float ,f1) (the-single-float ,f2))))
  105. (define-syntax (prim.float-min f1 f2)
  106.   `(the-single-float (min (the-single-float ,f1) (the-single-float ,f2))))
  107.  
  108. (define-syntax (prim.double-max f1 f2)
  109.   `(the-double-float (max (the-double-float ,f1) (the-double-float ,f2))))
  110. (define-syntax (prim.double-min f1 f2)
  111.   `(the-double-float (min (the-double-float ,f1) (the-double-float ,f2))))
  112.  
  113. (define-syntax (prim.plus-float f1 f2)
  114.   `(the-single-float (+ (the-single-float ,f1) (the-single-float ,f2))))
  115. (define-syntax (prim.minus-float f1 f2) 
  116.   `(the-single-float (- (the-single-float ,f1) (the-single-float ,f2))))
  117. (define-syntax (prim.mul-float f1 f2)
  118.   `(the-single-float (* (the-single-float ,f1) (the-single-float ,f2))))
  119. (define-syntax (prim.div-float f1 f2)
  120.   `(the-single-float (/ (the-single-float ,f1) (the-single-float ,f2))))
  121.  
  122. (define-syntax (prim.plus-double f1 f2)
  123.   `(the-double-float (+ (the-double-float ,f1) (the-double-float ,f2))))
  124. (define-syntax (prim.minus-double f1 f2) 
  125.   `(the-double-float (- (the-double-float ,f1) (the-double-float ,f2))))
  126. (define-syntax (prim.mul-double f1 f2)
  127.   `(the-double-float (* (the-double-float ,f1) (the-double-float ,f2))))
  128. (define-syntax (prim.div-double f1 f2)
  129.   `(the-double-float (/ (the-double-float ,f1) (the-double-float ,f2))))
  130.  
  131.  
  132. (define-syntax (prim.neg-float f)
  133.   `(the-single-float (- (the-single-float ,f))))
  134.  
  135. (define-syntax (prim.neg-double f)
  136.   `(the-double-float (- (the-double-float ,f))))
  137.  
  138. (define-syntax (prim.abs-float f)
  139.   `(the-single-float (lisp:abs (the-single-float ,f))))
  140.  
  141. (define-syntax (prim.abs-double f)
  142.   `(the-double-float (lisp:abs (the-double-float ,f))))
  143.  
  144.  
  145. (define-syntax (prim.exp-float f)
  146.   `(the-single-float (lisp:exp (the-single-float ,f))))
  147. (define-syntax (prim.log-float f)
  148.   `(the-single-float (lisp:log (the-single-float ,f))))
  149. (define-syntax (prim.sqrt-float f)
  150.   `(the-single-float (lisp:sqrt (the-single-float ,f))))
  151. (define-syntax (prim.sin-float f)
  152.   `(the-single-float (lisp:sin (the-single-float ,f))))
  153. (define-syntax (prim.cos-float f)
  154.   `(the-single-float (lisp:cos (the-single-float ,f))))
  155. (define-syntax (prim.tan-float f)
  156.   `(the-single-float (lisp:tan (the-single-float ,f))))
  157. (define-syntax (prim.asin-float f)
  158.   `(the-single-float (lisp:asin (the-single-float ,f))))
  159. (define-syntax (prim.acos-float f)
  160.   `(the-single-float (lisp:acos (the-single-float ,f))))
  161. (define-syntax (prim.atan-float f)
  162.   `(the-single-float (lisp:atan (the-single-float ,f))))
  163. (define-syntax (prim.sinh-float f)
  164.   `(the-single-float (lisp:sinh (the-single-float ,f))))
  165. (define-syntax (prim.cosh-float f)
  166.   `(the-single-float (lisp:cosh (the-single-float ,f))))
  167. (define-syntax (prim.tanh-float f)
  168.   `(the-single-float (lisp:tanh (the-single-float ,f))))
  169. (define-syntax (prim.asinh-float f)
  170.   `(the-single-float (lisp:asinh (the-single-float ,f))))
  171. (define-syntax (prim.acosh-float f)
  172.   `(the-single-float (lisp:acosh (the-single-float ,f))))
  173. (define-syntax (prim.atanh-float f)
  174.   `(the-single-float (lisp:atanh (the-single-float ,f))))
  175. (define-syntax (prim.atan2-float f1 f2)
  176.   `(the-single-float
  177.      (lisp:atan (the-single-float ,f1) (the-single-float ,f2))))
  178.  
  179.  
  180. (define-syntax (prim.exp-double f)
  181.   `(the-double-float (lisp:exp (the-double-float ,f))))
  182. (define-syntax (prim.log-double f)
  183.   `(the-double-float (lisp:log (the-double-float ,f))))
  184. (define-syntax (prim.sqrt-double f)
  185.   `(the-double-float (lisp:sqrt (the-double-float ,f))))
  186. (define-syntax (prim.sin-double f)
  187.   `(the-double-float (lisp:sin (the-double-float ,f))))
  188. (define-syntax (prim.cos-double f)
  189.   `(the-double-float (lisp:cos (the-double-float ,f))))
  190. (define-syntax (prim.tan-double f)
  191.   `(the-double-float (lisp:tan (the-double-float ,f))))
  192. (define-syntax (prim.asin-double f)
  193.   `(the-double-float (lisp:asin (the-double-float ,f))))
  194. (define-syntax (prim.acos-double f)
  195.   `(the-double-float (lisp:acos (the-double-float ,f))))
  196. (define-syntax (prim.atan-double f)
  197.   `(the-double-float (lisp:atan (the-double-float ,f))))
  198. (define-syntax (prim.sinh-double f)
  199.   `(the-double-float (lisp:sinh (the-double-float ,f))))
  200. (define-syntax (prim.cosh-double f)
  201.   `(the-double-float (lisp:cosh (the-double-float ,f))))
  202. (define-syntax (prim.tanh-double f)
  203.   `(the-double-float (lisp:tanh (the-double-float ,f))))
  204. (define-syntax (prim.asinh-double f)
  205.   `(the-double-float (lisp:asinh (the-double-float ,f))))
  206. (define-syntax (prim.acosh-double f)
  207.   `(the-double-float (lisp:acosh (the-double-float ,f))))
  208. (define-syntax (prim.atanh-double f)
  209.   `(the-double-float (lisp:atanh (the-double-float ,f))))
  210. (define-syntax (prim.atan2-double f1 f2)
  211.   `(the-double-float
  212.      (lisp:atan (the-double-float ,f1) (the-double-float ,f2))))
  213.  
  214.  
  215. (define-integrable prim.pi-float (lisp:coerce lisp:pi 'lisp:single-float))
  216.  
  217. (define-integrable prim.pi-double (lisp:coerce lisp:pi 'lisp:double-float))
  218.  
  219.  
  220. ;;; Assumes rationals are represented as a 2-tuple of integers
  221.  
  222. (define (prim.rational-to-float x)
  223.   (let ((n (tuple-select 2 0 x))
  224.     (d (tuple-select 2 1 x)))
  225.     (if (eqv? d 0)
  226.     (haskell-runtime-error "Divide by 0.")
  227.     (prim.rational-to-float-aux n d))))
  228.  
  229. (define (prim.rational-to-float-aux n d)
  230.   (declare (type integer n d))
  231.   (/ (lisp:coerce n 'lisp:single-float)
  232.      (lisp:coerce d 'lisp:single-float)))
  233.  
  234. (define (prim.rational-to-double x)
  235.   (let ((n (tuple-select 2 0 x))
  236.     (d (tuple-select 2 1 x)))
  237.     (if (eqv? d 0)
  238.     (haskell-runtime-error "Divide by 0.")
  239.     (prim.rational-to-double-aux n d))))
  240.  
  241. (define (prim.rational-to-double-aux n d)
  242.   (declare (type integer n d))
  243.   (/ (lisp:coerce n 'lisp:double-float)
  244.      (lisp:coerce d 'lisp:double-float)))
  245.  
  246. (define (prim.float-to-rational x)
  247.   (let ((r  (lisp:rational (the lisp:single-float x))))
  248.     (declare (type rational r))
  249.     (make-tuple (lisp:numerator r) (lisp:denominator r))))
  250.  
  251. (define (prim.double-to-rational x)
  252.   (let ((r  (lisp:rational (the lisp:double-float x))))
  253.     (declare (type rational r))
  254.     (make-tuple (lisp:numerator r) (lisp:denominator r))))
  255.  
  256.  
  257. (define-integrable prim.float-1 (lisp:coerce 1.0 'lisp:single-float))
  258. (define-integrable prim.double-1 (lisp:coerce 1.0 'lisp:double-float))
  259.  
  260. (define-integrable prim.float-digits
  261.   (lisp:float-digits prim.float-1))
  262.  
  263. (define-integrable prim.double-digits
  264.   (lisp:float-digits prim.double-1))
  265.  
  266. (define-integrable prim.float-radix
  267.   (lisp:float-radix prim.float-1))
  268.  
  269. (define-integrable prim.double-radix
  270.   (lisp:float-radix prim.double-1))
  271.  
  272.  
  273. ;;; Sometimes least-positive-xxx-float is denormalized.
  274.  
  275. (define-integrable prim.float-min-exp
  276.   (multiple-value-bind (m e)
  277.       (lisp:decode-float
  278.         #+lucid lcl:least-positive-normalized-single-float
  279.     #-lucid lisp:least-positive-single-float)
  280.     (declare (ignore m))
  281.     e))
  282.  
  283. (define-integrable prim.double-min-exp
  284.   (multiple-value-bind (m e)
  285.       (lisp:decode-float
  286.         #+lucid lcl:least-positive-normalized-double-float
  287.     #-lucid lisp:least-positive-double-float)
  288.     (declare (ignore m))
  289.     e))
  290.  
  291. (define-integrable prim.float-max-exp
  292.   (multiple-value-bind (m e)
  293.       (lisp:decode-float lisp:most-positive-single-float)
  294.     (declare (ignore m))
  295.     e))
  296.  
  297. (define-integrable prim.double-max-exp
  298.   (multiple-value-bind (m e)
  299.       (lisp:decode-float lisp:most-positive-double-float)
  300.     (declare (ignore m))
  301.     e))
  302.  
  303. (define-integrable (prim.float-range x)
  304.   (declare (ignore x))
  305.   (make-haskell-tuple2 prim.float-min-exp prim.float-max-exp))
  306.  
  307. (define-integrable (prim.double-range x)
  308.   (declare (ignore x))
  309.   (make-haskell-tuple2 prim.double-min-exp prim.double-max-exp))
  310.  
  311.  
  312. ;;; *** I'm not sure if these are correct.  Should the exponent value
  313. ;;; *** be taken as the value that lisp:integer-decode-float returns,
  314. ;;; *** or as the value that lisp:decode-float returns?  (They're
  315. ;;; *** not the same because the significand is scaled differently.)
  316. ;;; *** I'm guessing that Haskell's model is to use the actual numbers
  317. ;;; *** that are in the bit fields 
  318.  
  319. ;;; jcp - I removed this since Haskell requires an integer instead of a
  320. ;;; fractional mantissa.  My theory is that integer-decode-float returns
  321. ;;; what Haskell wants without fiddling (except sign reattachment)
  322.  
  323. (define (exponent-adjustment m)
  324.   (if (eqv? prim.float-radix 2)
  325.       ;; the usual case -- e.g. IEEE floating point
  326.       (lisp:integer-length m)
  327.       (lisp:ceiling (lisp:log m prim.float-radix))))
  328.  
  329. (define (prim.decode-float f)
  330.   (multiple-value-bind (m e s)
  331.       (lisp:integer-decode-float (the-single-float f))
  332.     (make-haskell-tuple2 (* (the-integer m) (the-fixnum s))
  333.              (the-fixnum e))))
  334.  
  335. (define (prim.decode-double f)
  336.   (multiple-value-bind (m e s)
  337.       (lisp:integer-decode-float (the-double-float f))
  338.     (make-haskell-tuple2 (* (the-integer m) (the-fixnum s))
  339.              (the-fixnum e))))
  340.  
  341. (define (prim.encode-float m e)
  342.   (lisp:scale-float (lisp:coerce m 'lisp:single-float) (the-fixnum e)))
  343.  
  344. (define (prim.encode-double m e)
  345.   (lisp:scale-float (lisp:coerce m 'lisp:double-float) (the-fixnum e)))
  346.  
  347.  
  348. ;;; Integral
  349.  
  350. (define-syntax (prim.eq-int i1 i2)
  351.   `(= (the-fixnum ,i1) (the-fixnum ,i2)))
  352. (define-syntax (prim.not-eq-int i1 i2)
  353.   `(not (= (the-fixnum ,i1) (the-fixnum ,i2))))
  354. (define-syntax (prim.le-int i1 i2)
  355.   `(<= (the-fixnum ,i1) (the-fixnum ,i2)))
  356. (define-syntax (prim.not-le-int i1 i2)
  357.   `(> (the-fixnum ,i1) (the-fixnum ,i2)))
  358. (define-syntax (prim.not-lt-int i1 i2)
  359.   `(>= (the-fixnum ,i1) (the-fixnum ,i2)))
  360. (define-syntax (prim.lt-int i1 i2)
  361.   `(< (the-fixnum ,i1) (the-fixnum ,i2)))
  362. (define-syntax (prim.int-max i1 i2)
  363.   `(the-fixnum (max (the-fixnum ,i1) (the-fixnum ,i2))))
  364. (define-syntax (prim.int-min i1 i2)
  365.   `(the-fixnum (min (the-fixnum ,i1) (the-fixnum ,i2))))
  366.  
  367. (define-syntax (prim.eq-integer i1 i2)
  368.   `(= (the-integer ,i1) (the-integer ,i2)))
  369. (define-syntax (prim.not-eq-integer i1 i2)
  370.   `(not (= (the-integer ,i1) (the-integer ,i2))))
  371. (define-syntax (prim.le-integer i1 i2)
  372.   `(<= (the-integer ,i1) (the-integer ,i2)))
  373. (define-syntax (prim.not-le-integer i1 i2)
  374.   `(> (the-integer ,i1) (the-integer ,i2)))
  375. (define-syntax (prim.not-lt-integer i1 i2)
  376.   `(>= (the-integer ,i1) (the-integer ,i2)))
  377. (define-syntax (prim.lt-integer i1 i2)
  378.   `(< (the-integer ,i1) (the-integer ,i2)))
  379. (define-syntax (prim.integer-max i1 i2)
  380.   `(the-integer (max (the-integer ,i1) (the-integer ,i2))))
  381. (define-syntax (prim.integer-min i1 i2)
  382.   `(the-integer (min (the-integer ,i1) (the-integer ,i2))))
  383.  
  384.  
  385. (define-syntax (prim.plus-int i1 i2)
  386.   `(the-fixnum (+ (the-fixnum ,i1) (the-fixnum ,i2))))
  387. (define-syntax (prim.minus-int i1 i2)
  388.   `(the-fixnum (- (the-fixnum ,i1) (the-fixnum ,i2))))
  389. (define-syntax (prim.mul-int i1 i2)
  390.   `(the-fixnum (* (the-fixnum ,i1) (the-fixnum ,i2))))
  391. (define-syntax (prim.neg-int i)
  392.   `(the-fixnum (- (the-fixnum ,i))))
  393. (define-syntax (prim.abs-int i)
  394.   `(the-fixnum (lisp:abs (the-fixnum ,i))))
  395.  
  396. (define-integrable prim.minint lisp:most-negative-fixnum)
  397. (define-integrable prim.maxint lisp:most-positive-fixnum)
  398.  
  399. (define-syntax (prim.plus-integer i1 i2)
  400.   `(the-integer (+ (the-integer ,i1) (the-integer ,i2))))
  401. (define-syntax (prim.minus-integer i1 i2)
  402.   `(the-integer (- (the-integer ,i1) (the-integer ,i2))))
  403. (define-syntax (prim.mul-integer i1 i2)
  404.   `(the-integer (* (the-integer ,i1) (the-integer ,i2))))
  405. (define-syntax (prim.neg-integer i)
  406.   `(the-integer (- (the-integer ,i))))
  407. (define-syntax (prim.abs-integer i)
  408.   `(the-integer (lisp:abs (the-integer ,i))))
  409.  
  410.  
  411. (define (prim.div-rem-int i1 i2)
  412.   (multiple-value-bind (q r)
  413.       (lisp:truncate (the-fixnum i1) (the-fixnum i2))
  414.     (make-tuple (box (the-fixnum q)) (box (the-fixnum r)))))
  415.  
  416. (define (prim.div-rem-integer i1 i2)
  417.   (multiple-value-bind (q r)
  418.       (lisp:truncate (the-integer i1) (the-integer i2))
  419.     (make-tuple (box (the-integer q)) (box (the-integer r)))))
  420.  
  421. (define (prim.integer-to-int i)
  422.   (if (is-fixnum? i)
  423.       (the-fixnum i)
  424.       (haskell-runtime-error "Integer -> Int overflow.")))
  425.  
  426. (define-syntax (prim.int-to-integer i)
  427.   i)
  428.  
  429. ;;; Binary
  430.  
  431. (define prim.nullbin '())
  432.  
  433. (define (prim.is-null-bin x)
  434.   (null? x))
  435.  
  436. (define (prim.show-bin-int i b)
  437.   (cons i b))
  438.  
  439. (define (prim.show-bin-integer i b)
  440.   (cons i b))
  441.  
  442. (define (prim.show-bin-float f b)
  443.   (cons f b))
  444.  
  445. (define (prim.show-bin-double f b)
  446.   (cons f b))
  447.  
  448. (define (prim.bin-read-error)
  449.   (haskell-runtime-error "Error: attempt to read from an incompatible Bin."))
  450.  
  451. (define (prim.read-bin-int b)
  452.   (if (or (null? b) (not (is-fixnum? (car b))))
  453.       (prim.bin-read-error)
  454.       (make-haskell-tuple2 (car b) (cdr b))))
  455.  
  456. (define (prim.read-bin-integer b)
  457.   (if (or (null? b) (not (is-integer? (car b))))
  458.       (prim.bin-read-error)
  459.       (make-haskell-tuple2 (car b) (cdr b))))
  460.  
  461. (define (prim.read-bin-float b)
  462.   (if (or (null? b) (not (is-single-float? (car b))))
  463.       (prim.bin-read-error)
  464.       (make-haskell-tuple2 (car b) (cdr b))))
  465.  
  466. (define (prim.read-bin-double b)
  467.   (if (or (null? b) (not (is-double-float? (car b))))
  468.       (prim.bin-read-error)
  469.       (make-haskell-tuple2 (car b) (cdr b))))
  470.  
  471. (define (prim.read-bin-small-int b m)
  472.   (if (or (null? b)
  473.       (not (is-fixnum? (car b)))
  474.       (> (the-fixnum (car b)) (the-fixnum m)))
  475.       (prim.bin-read-error)
  476.       (make-haskell-tuple2 (car b) (cdr b))))
  477.  
  478. (define (prim.append-bin x y)
  479.   (append x y))
  480.  
  481.  
  482. ;;; String primitives
  483.  
  484. ;;; Calls to prim.string-eq are generated by the CFN to pattern match
  485. ;;; against string constants.  So normally one of the arguments will be
  486. ;;; a constant string.  Treat this case specially to avoid consing up
  487. ;;; a haskell string whenever it's called.
  488. ;;; This function is strict in both its arguments.
  489.  
  490. (define-syntax (prim.string-eq s1 s2)
  491.   (cond ((and (pair? s1)
  492.           (eq? (car s1) 'make-haskell-string))
  493.      `(prim.string-eq-inline ,(cadr s1) 0 ,(string-length (cadr s1)) ,s2))
  494.     ((and (pair? s2)
  495.           (eq? (car s2) 'make-haskell-string))
  496.      `(prim.string-eq-inline ,(cadr s2) 0 ,(string-length (cadr s2)) ,s1))
  497.     (else
  498.      `(prim.string-eq-notinline ,s1 ,s2))))
  499.  
  500. (define (prim.string-eq-inline lisp-string i n haskell-string)
  501.   (declare (type fixnum i n))
  502.   (cond ((eqv? i n)
  503.      ;; Reached end of Lisp string constant -- better be at the end
  504.      ;; of the Haskell string, too.
  505.      (if (null? haskell-string) '#t '#f))
  506.     ((null? haskell-string)
  507.      ;; The Haskell string is too short.
  508.      '#f)
  509.     ((eqv? (the fixnum (char->integer (string-ref lisp-string i)))
  510.            (the fixnum (force (car haskell-string))))
  511.      ;; Next characters match, recurse
  512.      (prim.string-eq-inline
  513.        lisp-string (the fixnum (+ i 1)) n (force (cdr haskell-string))))
  514.     (else
  515.      ;; No match
  516.      '#f)))
  517.  
  518. (define (prim.string-eq-notinline s1 s2)
  519.   (cond ((null? s1)
  520.      ;; Reached end of first string.
  521.      (if (null? s2) '#t '#f))
  522.     ((null? s2)
  523.      ;; Second string too short.
  524.      '#f)
  525.     ((eqv? (the fixnum (force (car s1))) (the fixnum (force (car s2))))
  526.      (prim.string-eq-notinline (force (cdr s1)) (force (cdr s2))))
  527.     (else
  528.      '#f)))
  529.  
  530.   
  531. ;;; List primitives
  532.  
  533.  
  534. ;;; The first argument is strict and the second is a delay.
  535.  
  536. (define-syntax (prim.append l1 l2)
  537.   (cond ((and (pair? l1)
  538.           (eq? (car l1) 'make-haskell-string))
  539.      `(make-haskell-string-tail ,(cadr l1) ,l2))
  540.     ((equal? l1 ''())
  541.      `(force ,l2))
  542.     ((equal? l2 '(box '()))
  543.      l1)
  544.     ;; *** could also look for
  545.     ;; *** (append (cons x (box y)) z) => (cons x (box (append y z)))
  546.     ;; *** but I don't think this happens very often anyway
  547.     (else
  548.      `(prim.append-aux ,l1 ,l2))))
  549.  
  550. (define (prim.append-aux l1 l2)
  551.   (cond ((null? l1)
  552.      (force l2))
  553.     ((and (forced? l2) (eq? (unbox l2) '()))
  554.      ;; Appending nil is identity.
  555.      l1)
  556.     ((forced? (cdr l1))
  557.      ;; Append eagerly if the tail of the first list argument has 
  558.          ;; already been forced.
  559.      (cons (car l1)
  560.            (if (null? (unbox (cdr l1)))
  561.            l2  ; don't force this!!
  562.            (box (prim.append-aux (unbox (cdr l1)) l2)))))
  563.     (else
  564.      (cons (car l1) (delay (prim.append-aux (force (cdr l1)) l2))))
  565.     ))
  566.  
  567.  
  568. ;;; Both arguments are forced here.  Have to be careful not to call
  569. ;;; recursively with an argument of 0.
  570. ;;; *** This is no longer used.
  571.  
  572. (define (prim.take n l)
  573.   (declare (type fixnum n))
  574.   (cond ((not (pair? l))
  575.      '())
  576.     ((eqv? n 1)
  577.      ;; Only one element to take.
  578.      (cons (car l) (box '())))
  579.     ((forced? (cdr l))
  580.      ;; Take eagerly if the tail of the list has already been forced.
  581.      (cons (car l) (box (prim.take (- n 1) (unbox (cdr l))))))
  582.     (else
  583.      (cons (car l) (delay (prim.take (- n 1) (force (cdr l))))))
  584.     ))
  585.       
  586.  
  587. ;;; The optimizer gets rid of all first-order calls to these functions.
  588.  
  589. (define (prim.foldr k z l)
  590.   ;; k and z are nonstrict, l is strict
  591.   (if (null? l)
  592.       (force z)
  593.       (funcall (force k)
  594.            (car l)
  595.            (delay (prim.foldr k z (force (cdr l)))))))
  596.  
  597. (define (prim.build g)
  598.   ;; g is strict
  599.   (funcall g
  600.        (box (function cons-constructor))
  601.        (box '())))
  602.  
  603.  
  604. ;;; The code generator is supposed to inline all calls to this one.
  605. ;;; Both arguments are strict.
  606.  
  607. (define (prim.strict2 x y)
  608.   (declare (ignore x))
  609.   y)
  610.