Implement foreign definitions

src/Control/Apply.ss

@@ -2,11 +2,12 @@
 
 (library (Control.Apply foreign)
   (export arrayApply)
-  (import (only (rnrs base) define lambda error))
+  (import (only (rnrs base) define lambda)
+          (prefix (purs runtime srfi :214) srfi:214:))
 
   (define arrayApply
     (lambda (fs)
       (lambda (xs)
-        (error #f "Control.Apply:arrayApply not implemented."))))
+        (srfi:214:flexvector-map (lambda (f x) (f x)) fs xs))))
 
 )

src/Control/Bind.ss

@@ -2,11 +2,20 @@
 
 (library (Control.Bind foreign)
   (export arrayBind)
-  (import (only (rnrs base) define lambda error))
+  (import (only (rnrs base) define lambda if = + begin let)
+          (prefix (purs runtime lib) rt:)
+          (prefix (purs runtime srfi :214) srfi:214:))
 
   (define arrayBind
     (lambda (arr)
       (lambda (f)
-        (error #f "Control.Bind:arrayBind not implemented."))))
+        (let ([len (rt:array-length arr)]
+              [result (srfi:214:flexvector)])
+          (let loop ([i 0])
+            (if (= i len)
+              result
+              (begin
+                (srfi:214:flexvector-append! result (f (rt:array-ref arr i)))
+                (loop (+ i 1)))))))))
 
 )

src/Data/Bounded.ss

@@ -4,15 +4,16 @@
   (export topInt bottomInt
           topChar bottomChar
           topNumber bottomNumber)
-  (import (only (rnrs base) define quote))
+  (import (only (rnrs base) define quote integer->char)
+          (chezscheme))
 
-  (define topInt 'Data.Bounded:topInt-NOT-DEFINED)
-  (define bottomInt 'Data.Bounded:bottomInt-NOT-DEFINED)
+  (define topInt (most-positive-fixnum))
+  (define bottomInt (most-negative-fixnum))
 
-  (define topChar 'Data.Bounded:topChar-NOT-DEFINED)
-  (define bottomChar 'Data.Bounded:bottomChar-NOT-DEFINED)
+  (define topChar (integer->char 65535))
+  (define bottomChar (integer->char 0))
 
-  (define topNumber 'Data.Bounded:topNumber-NOT-DEFINED)
-  (define bottomNumber 'Data.Bounded:bottomNumber-NOT-DEFINED)
+  (define topNumber +inf.0)
+  (define bottomNumber -inf.0)
 
 )

src/Data/Eq.ss

@@ -7,37 +7,38 @@
           eqCharImpl
           eqStringImpl
           eqArrayImpl)
-  (import (only (rnrs base) define lambda error))
+  (import (chezscheme))
+  (import (only (rnrs base) define lambda)
+          (prefix (purs runtime srfi :214) srfi:214:))
 
   (define eqBooleanImpl
     (lambda (r1)
       (lambda (r2)
-        (error #f "Data.Eq:eqBooleanImpl not implemented."))))
+        (eq? r1 r2))))
 
   (define eqIntImpl
     (lambda (r1)
       (lambda (r2)
-        (error #f "Data.Eq:eqIntImpl not implemented."))))
+        (= r1 r2))))
 
   (define eqNumberImpl
     (lambda (r1)
       (lambda (r2)
-        (error #f "Data.Eq:eqNumberImpl not implemented."))))
+        (= r1 r2))))
 
   (define eqCharImpl
     (lambda (r1)
       (lambda (r2)
-        (error #f "Data.Eq:eqCharImpl not implemented."))))
+        (char=? r1 r2))))
 
   (define eqStringImpl
     (lambda (r1)
       (lambda (r2)
-        (error #f "Data.Eq:eqStringImpl not implemented."))))
+        (string=? r1 r2))))
 
   (define eqArrayImpl
     (lambda (f)
       (lambda (xs)
         (lambda (ys)
-          (error #f "Data.Eq:eqArrayImpl is not implemented.")))))
-
+          (srfi:214:flexvector=? (lambda (x y) ((f x) y)) xs ys)))))
 )

src/Data/EuclideanRing.ss

@@ -5,24 +5,28 @@
           intDiv
           intMod
           numDiv)
-  (import (only (rnrs base) define lambda error))
+  (import (only (rnrs base) define lambda if)
+          (chezscheme))
 
   (define intDegree
     (lambda (x)
-      (error #f "Data.EuclideanRing:intDegree not implemented")))
+      (fxmin (fxabs x) (most-positive-fixnum))))
 
   (define intDiv
     (lambda (x)
       (lambda (y)
-        (error #f "Data.EuclideanRing:intDiv not implemented"))))
+        (if (fx= y 0)
+          0
+          (fx/ x y)))))
 
   (define intMod
     (lambda (x)
       (lambda (y)
-        (error #f "Data.EuclideanRing:intMod not implemented"))))
+        (if (fx= y 0) 0
+          (fxmod x y)))))
 
   (define numDiv
     (lambda (n1)
       (lambda (n2)
-        (error #f "Data.EuclideanRing:numDiv not implemented"))))
+        (fl/ n1 n2))))
 )

src/Data/Functor.ss

@@ -2,11 +2,12 @@
 
 (library (Data.Functor foreign)
   (export arrayMap)
-  (import (only (rnrs base) define lambda error))
+  (import (only (rnrs base) define lambda)
+          (prefix (purs runtime srfi :214) srfi:214:))
 
   (define arrayMap
     (lambda (f)
       (lambda (arr)
-        (error #f "Data.Functor:arrayMap not implemented."))))
+        (srfi:214:flexvector-map f arr))))
 
 )

src/Data/HeytingAlgebra.ss

@@ -4,21 +4,18 @@
   (export boolConj
           boolDisj
           boolNot)
-  (import (only (rnrs base) define lambda error))
+  (import (only (rnrs base) define lambda and or not))
 
   (define boolConj 
     (lambda (b1)
       (lambda (b2)
-        (error #f "Data.HeytingAlgebra:boolConj not implemented."))))
+        (and b1 b2))))
 
   (define boolDisj
     (lambda (b1)
       (lambda (b2)
-        (error #f "Data.HeytingAlgebra:boolDisj not implemented."))))
+        (or b1 b2))))
 
-  (define boolNot
-    (lambda (b1)
-      (lambda (b2)
-        (error #f "Data.HeytingAlgebra:boolNot not implemented."))))
+  (define boolNot not)
 
 )

src/Data/Ord.ss

@@ -7,52 +7,77 @@
           ordStringImpl
           ordCharImpl
           ordArrayImpl)
-  (import (only (rnrs base) define lambda error))
+  (import (chezscheme))
+  (import (only (rnrs base) define lambda)
+          (prefix (purs runtime srfi :214) srfi:214:))
 
   (define ordBooleanImpl
     (lambda (lt)
       (lambda (eq)
         (lambda (gt)
           (lambda (x)
             (lambda (y)
-              (error #f "Data.Ord:ordBooleanImpl not implemented.")))))))
+              (if (and (not x) y)
+                  lt
+                  (if (eq? x y) eq gt))))))))
 
   (define ordIntImpl
     (lambda (lt)
       (lambda (eq)
         (lambda (gt)
           (lambda (x)
             (lambda (y)
-              (error #f "Data.Ord:ordIntImpl not implemented.")))))))
+              (if (< x y)
+                  lt
+                  (if (= x y) eq gt))))))))
 
   (define ordNumberImpl
     (lambda (lt)
       (lambda (eq)
         (lambda (gt)
           (lambda (x)
             (lambda (y)
-              (error #f "Data.Ord:ordNumberImpl not implemented.")))))))
+              (if (< x y)
+                  lt
+                  (if (= x y) eq gt))))))))
 
   (define ordStringImpl
     (lambda (lt)
       (lambda (eq)
         (lambda (gt)
           (lambda (x)
             (lambda (y)
-              (error #f "Data.Ord:ordStringImpl not implemented.")))))))
+              (if (string<? x y)
+                  lt
+                  (if (string=? x y) eq gt))))))))
 
   (define ordCharImpl
     (lambda (lt)
       (lambda (eq)
         (lambda (gt)
           (lambda (x)
             (lambda (y)
-              (error #f "Data.Ord:ordCharImpl not implemented.")))))))
+              (if (char<? x y)
+                  lt
+                  (if (char=? x y) eq gt))))))))
 
   (define ordArrayImpl
     (lambda (f)
       (lambda (xs)
         (lambda (ys)
-          (error #f "Data.Ord:ordArrayImpl not implemented.")))))
-
+          (let ([xlen (srfi:214:flexvector-length xs)]
+                [ylen (srfi:214:flexvector-length ys)])
+             (let loop ([xsi 0]
+                        [ysi 0])
+               (if (or (= xsi xlen) (= ysi ylen))
+                 (cond
+                   [(= xlen ylen) 0]
+                   [(> xlen ylen) -1]
+                   (else 1))
+                 (let ([o ((f (srfi:214:flexvector-ref xs xsi)) (srfi:214:flexvector-ref ys ysi))])
+                   (if (not (fx=? o 0))
+                     o
+                     (loop
+                       (+ xsi 1)
+                       (+ ysi 1)))))))))))
 )

src/Data/Ring.ss

@@ -3,16 +3,17 @@
 (library (Data.Ring foreign)
   (export intSub
           numSub)
-  (import (only (rnrs base) define lambda error))
+  (import (only (rnrs base) define lambda)
+          (chezscheme))
 
   (define intSub
     (lambda (x)
       (lambda (y)
-        (error #f "Data.Ring:intSub not implemented."))))
+        (fx- x y))))
 
   (define numSub
     (lambda (x)
       (lambda (y)
-        (error #f "Data.Ring:numSub not implemented."))))
+        (fl- x y))))
 
 )

src/Data/Semigroup.ss

@@ -3,7 +3,8 @@
 (library (Data.Semigroup foreign)
   (export concatString
           concatArray)
-  (import (only (rnrs base) define lambda error string-append))
+  (import (only (rnrs base) define lambda string-append)
+          (prefix (purs runtime srfi :214) srfi:214:))
 
   (define concatString
     (lambda (s1)
@@ -13,6 +14,6 @@
   (define concatArray
     (lambda (xs)
       (lambda (ys)
-        (error #f "Data.Semigroup:concatArray not implemented."))))
+        (srfi:214:flexvector-append xs ys))))
 
 )

src/Data/Show.ss

@@ -8,11 +8,11 @@
           showArrayImpl
           cons
           join)
-  (import (only (rnrs base) define lambda let* quote begin if set!
-                            + - < >=
-                            error number->string string-append
-                            vector-ref vector-length)
-          (only (rnrs control) do))
+  (import (only (rnrs base) define lambda let + = cond else if 
+                            string number->string string-append)
+          (only (chezscheme) format)
+          (prefix (purs runtime lib) rt:)
+          (prefix (purs runtime srfi :214) srfi:214:))
 
   (define showIntImpl
     (lambda (n)
@@ -24,34 +24,37 @@
 
   (define showCharImpl
     (lambda (c)
-      (error #f "Data.Show:showCharImpl not implemented.")))
+      (format "~s" c)))
 
   (define showStringImpl
     (lambda (s)
-      (error #f "Data.Show:showStringImpl not implemented.")))
+      (format "~s" s)))
+
+  (define (string-join xs separator)
+    (let ([len (rt:array-length xs)])
+      (cond
+        [(= len 0) ""]
+        [(= len 1) (rt:array-ref xs 0)]
+        (else
+          (let recur ([i 1]
+                      [buffer (rt:array-ref xs 0)])
+            (if (= len i)
+              buffer
+              (recur (+ i 1) (string-append buffer separator (rt:array-ref xs i)))))))))
 
   (define showArrayImpl
     (lambda (f)
       (lambda (xs)
-        (let* ([buffer  "["]
-               [append! (lambda (str) (set! buffer (string-append buffer str)))])
-          (do ([i 0 (+ i 1)])
-              ((>= i (vector-length xs)) '())
-            (begin 
-              (append! (f (vector-ref xs i)))
-              (if (< i (- (vector-length xs) 1))
-                  (append! ","))))
-          (append! "]")
-          buffer))))
+        (string-append "[" (string-join (srfi:214:flexvector-map f xs) ",") "]"))))
 
   (define cons
     (lambda (head)
       (lambda (tail)
-        (error #f "Data.Show:cons not implemented."))))
+        (srfi:214:flexvector-append (rt:make-array head) tail))))
 
   (define join
     (lambda (separator)
       (lambda (xs)
-        (error #f "Data.Show:join not implemented."))))
+        (string-join xs separator))))
 
 )