draft of R7RS libraries

5 files changed, 252 insertions, 60 deletions

diff --git a/README.md b/README.md
index 58e0273..641ebfb 100644
--- a/README.md
+++ b/README.md
@@ -7,18 +7,23 @@
 >
 > -- Revisedⁿ Reports on the Algorithmic Language Scheme (n ≥ 3, 1986–)
 
-This is a library that exports interfaces similar to the R7RS, except
-everything is call-by-need and not call-by-value: there is no need to
-explictly use `delay` or `delay-force` (in most scenarios). Procedures
-can be written in ways that look almost identical to regular Scheme. The
-procedures return promises which can be forced by non-lazy code. Hence
-lazy and non-lazy code can co-exist.
+HaScheme is a pure, call-by-need dialect of Scheme (R7RS), embedded within
+Scheme itself. Procedures in HaScheme can be written in ways that look
+identical to regular Scheme. These procedures return promises which can
+be forced by non-lazy code. Hence lazy and non-lazy code can co-exist.
 
 *Every* procedure in HaScheme is lazy. Values are forced in conditionals,
 or explicitly using `seq`. This allows for the call-by-value semantics
 of Scheme to be turned into call-by-need semantics without any syntactic
 cruft.
 
+Why use this?
+
+1. To have fun playing around with functional infinite data structures.
+2. To embed lazy and pure algorithms into impure Scheme with ease.
+3. To show those dirty Haskellers that you don't need no stinkin'
+   static type system.
+
 ## Fun (or Pain) with Laziness
 
 You need to be careful with lazy functions because they can cause
diff --git a/lib/hascheme/base.scm b/lib/hascheme/base.scm
index 12bcf76..5df19df 100644
--- a/lib/hascheme/base.scm
+++ b/lib/hascheme/base.scm
@@ -17,7 +17,7 @@
     ((x) x)
     ((x . y) (force x) (apply seq y))))
 
-(define (! x) (seq x x))
+(define ! force)
 
 (define cond*
   (case-lambda
@@ -43,48 +43,155 @@
 (define error
   (r7rs:lambda formals (delay (r7rs:apply error formals))))
 
+(r7rs:define (make-finite-list list)
+             (let loop ((list (! list))
+                        (acc '()))
+               (if (null? list)
+                   (reverse acc)
+                   (loop (! (cdr list)) (cons (car list) acc)))))
+
 ;;; Equivalence procedures
 
 (define-wrappers-from-strict
-    ((eq? x y) r7rs:eq?)
+    ;; Equivalence procedures
+  ((eq? x y) r7rs:eq?)
   ((eqv? x y) r7rs:eqv?)
-  ((equal? x y) r7rs:equal?))
-
-;;; Numbers
-
-(define-wrappers-from-strict
-    (+ r7rs:+)
-  (- r7rs:-)
-  (* r7rs:*)
+  ((equal? x y) r7rs:equal?)
+  ;; Numbers
+  ((number? x) r7rs:number?)
+  ((complex? x) (r7rs:complex?))
+  ((real? x) r7rs:real?)
+  ((rational? x) r7rs:rational?)
+  ((integer? x) r7rs:integer?)
+  ((exact? x) r7rs:exact?)
+  ((inexact? x) r7rs:inexact?)
+  ((exact-integer? x) r7rs:exact-integer?)
   ((negative? x) r7rs:negative?)
   ((positive? x) r7rs:positive?)
-  ((zero? x) r7rs:zero?))
-
-(define-binary-wrapper (= r7rs:=))
-
-;;; Booleans
-
-(define-wrappers-from-strict
-    ((boolean? x) r7rs:boolean?)
-  ((not x) r7rs:not))
-
-(define-binary-wrapper (boolean=? r7rs:boolean=?))
-
-;;; Lists and pairs
-
-(define-wrappers-from-strict
-    ((car x) r7rs:car)
+  ((zero? x) r7rs:zero?)
+  ((odd? x) r7rs:odd?)
+  ((even? x) r7rs:even?)
+  (max r7rs:max)
+  (min r7rs:min)
+  (+ r7rs:+)
+  (- r7rs:-)
+  (* r7rs:*)
+  (/ r7rs:/)
+  ((abs x) r7rs:abs)
+  ((floor/ x y) r7rs:floor/)
+  ((floor-quotient x y) r7rs:floor-quotient)
+  ((floor-remainder x y) r7rs:floor-remainder)
+  ((truncate/ x y) r7rs:truncate)
+  ((truncate-quotient x y) r7rs:truncate-quotient)
+  ((truncate-remainder x y) r7rs:truncate-remainder)
+  ((quotient x y) r7rs:quotient)
+  ((remainder x y) r7rs:remainder)
+  ((modulo x y) r7rs:modulo)
+  (gcd r7rs:gcd)
+  (lcm r7rs:lcm)
+  ((numerator x) r7rs:numerator)
+  ((denominator x) r7rs:denominator)
+  ((floor x) r7rs:floor)
+  ((ceiling x) r7rs:ceiling)
+  ((truncate x) r7rs:truncate)
+  ((round x) r7rs:round)
+  ((rationalize x y) r7rs:rationalize)
+  ((square x) r7rs:square)
+  ((exact-integer-sqrt x) r7rs:exact-integer-sqrt)
+  ((expt x y) r7rs:expt)
+  ((inexact x) r7rs:inexact)
+  ((exact x) r7rs:exact)
+  (number->string r7rs:number->string)
+  (string->number r7rs:string->number)
+  ;; Booleans
+  ((boolean? x) r7rs:boolean?)
+  ((not x) r7rs:not)
+  ;; Lists and pairs
+  ((car x) r7rs:car)
   ((cdr x) r7rs:cdr)
   ((null? x) r7rs:null?)
-  ((pair? x) r7rs:pair?))
+  ((pair? x) r7rs:pair?)
+  ;; Symbols
+  ((symbol? x) r7rs:symbol?)
+  ((symbol->string x) r7rs:symbol->string)
+  ((string->symbol x) r7rs:string->symbol)
+  ;; Chars
+  ((char? x) r7rs:char?)
+  ((char->integer c) r7rs:char->integer)
+  ((integer->char c) r7rs:integer->char)
+  ;; Strings
+  ((string? x) r7rs:string?)
+  (make-string r7rs:make-string)
+  (string r7rs:string)
+  ((string-length s) r7rs:string-length)
+  ((string-ref s k) r7rs:string-ref)
+  ((substring string start end) r7rs:substring)
+  (string-append r7rs:string-append)
+  (string->list r7rs:string->list)
+  (string-copy r7rs:string-copy)
+  ;; Vectors
+  ((vector? k) r7rs:vector?)
+  ((vector-length k) r7rs:vector-length)
+  ((vector-ref k n) r7rs:vector-ref)
+  (vector->string r7rs:vector->string)
+  (string->vector r7rs:string->vector)
+  (vector-copy r7rs:vector-copy)
+  (vector-append r7rs:vector-append)
+  ;; Bytevectors
+  ((bytevector? k) r7rs:bytevector?)
+  (make-bytevector r7rs:make-bytevector)
+  (bytevector r7rs:bytevector)
+  ((bytevector-length x) r7rs:bytevector-length)
+  (bytevector-copy r7rs:bytevector-copy)
+  (bytevector-append r7rs:bytevector-append)
+  (utf8->string r7rs:utf8->string)
+  (string->utf8 r7rs:string->utf8)
+  ;; Control feature
+  ((procedure? x) r7rs:procedure?)
+  (string-map r7rs:string-map)
+  ;; Exceptions (very limited)
+  ((error-object? x) r7rs:error-object)
+  ((error-object-message x) r7rs:error-message-object)
+  ((error-object-irritants x) r7rs:error-object-irritants)
+  ((read-error? x) r7rs:read-error?)
+  ((file-error? x) r7rs:file-error?))
+
+(define-binary-wrapper
+    ;; Numbers
+  (= r7rs:=)
+  (< r7rs:<)
+  (> r7rs:>)
+  (= r7rs:=)
+  (= r7rs:=)
+  (boolean=? r7rs:boolean=?)
+  ;; Symbols
+  (symbol=? r7rs:symbol=?)
+  ;; Chars
+  (char=? r7rs:char=?)
+  (char<? r7rs:char<?)
+  (char<=? r7rs:char<=?)
+  (char>? r7rs:char>?)
+  (char>=? r7rs:char>=?)
+  ;; Strings
+  (string=? r7rs:string=?)
+  (string<? r7rs:string<?)
+  (string<=? r7rs:string<=?)
+  (string>? r7rs:string>?)
+  (string>=? r7rs:string>=?))
 
 (define-wrappers-for-lazy
-    ((cons x y) r7rs:cons)
-  (list r7rs:list))
+    ;;; Lists and pairs
+  ((cons x y) r7rs:cons)
+  (list r7rs:list)
+  (vector r7rs:vector)
+  (values r7rs:values))
+
+;;; Lists and pairs
 
 (define (list-traverse x path)
   (cond*
    (null? path) x
+   (not (pair? x)) (error "not a pair" x)
    (eq? (car path) 'a) (list-traverse (car x) (cdr path))
    (eq? (cdr path) 'd) (list-traverse (cdr x) (cdr path))
    #t (error "invalid path" x path)))
@@ -100,26 +207,33 @@
    (pair? x) (list? (cdr x))
    #t #f))
 
+(define (ensure-exact-positive-integer n k)
+  (if (not (and (exact-integer? k) (positive? k)))
+      (error "not an exact integer" k)
+      #t))
+
 (define make-list
   (case-lambda
     ((k) (make-list k #f))
     ((k fill)
-     (let loop ((k k))
-       (if (zero? k)
-           '()
-           (cons fill (loop (- k 1))))))))
+     (seq (ensure-exact-positive-integer k)
+          (let loop ((k k))
+            (if (zero? k)
+                '()
+                (cons fill (loop (- k 1)))))))))
 
 (define (list-tabulate n proc)
-  (let loop ((i 0))
-    (if (= i n)
-        '()
-        (cons (proc i) (loop (+ i 1))))))
+  (seq (ensure-exact-positive-integer n)
+       (let loop ((i 0))
+         (if (= i n)
+             '()
+             (cons (proc i) (loop (+ i 1)))))))
 
 (define (length list)
   (let loop ((list list)
              (i 0))
     (cond*
-     (pair? list) (loop (cdr list) (+ i 1))
+     (pair? list) (loop (cdr list) (! (+ i 1)))
      (null? list) i
      #t (error "not a list" list))))
 
@@ -136,16 +250,18 @@
 
 (define (reverse x)
   (let loop ((x x) (a '()))
-    (if (null? x)
-        a
-        (loop (cdr x) (cons (car x) a)))))
+    (cond*
+     (null? x) a
+     (pair? x) (loop (cdr x) (cons (car x) a))
+     #t (error "not a pair" x))))
 
 (define (list-tail list n)
-  (cond*
-   (negative? n) (error "invalid n" list n)
-   (zero? n) list
-   #t (seq (cdr list)
-           (list-tail (cdr list) (- n 1)))))
+  (seq (ensure-exact-positive-integer n)
+       (let loop ((list list) (n n))
+         (if (zero? n)
+             list
+             (let ((x (! (cdr list))))
+               (list-tail x (- n 1)))))))
 
 (define (list-ref list n)
   (car (list-tail list n)))
@@ -157,6 +273,7 @@
      (let loop ((list list))
        (cond*
         (null? list) #f
+        (not (pair? list) (error "not a pair" list))
         (equal? (car list) obj) list
         #t (loop (cdr list)))))))
 
@@ -170,21 +287,28 @@
      (let loop ((list list))
        (cond*
         (null? list) #f
+        (not (pair? list) (error "not a pair" list))
         (equal? (caar list) obj) (car list)
         #t (loop (cdr list)))))))
 
 (define (assq obj list) (assoc obj list eq?))
 (define (assv obj list) (assoc obj list eqv?))
-
-;;; Symbols
-
-(define-wrappers-from-strict ((symbol? x) r7rs:symbol?)
-  ((symbol->string x) r7rs:symbol->string)
-  ((string->symbol x) r7rs:string->symbol))
-(define-binary-wrapper (symbol=? r7rs:symbol=?))
-
 (define (map1 f list)
   (if (null? list)
       '()
       (cons (f (car list)) (map1 f (cdr list)))))
 
+;;; list->string
+
+(define (list->string list) (r7rs:list->string (make-finite-list list)))
+
+;;; Vectors
+
+(define make-vector
+  (case-lambda
+    ((k) (make-vector k #f))
+    ((k fill) (r7rs:make-vector (! k) fill))))
+
+(define (list->vector list)
+  (r7rs:list->vector (make-finite-list list)))
+
diff --git a/lib/hascheme/char.sld b/lib/hascheme/char.sld
new file mode 100644
index 0000000..f589c1b
--- /dev/null
+++ b/lib/hascheme/char.sld
@@ -0,0 +1,32 @@
+(define-library (hascheme char)
+  (import (hascheme base) (hascheme internal)
+          (prefix (scheme char) r7rs:))
+  (export char-ci=? char-ci<? char-ci<=? char-ci>? char-ci>=?
+          char-alphabetic? char-numeric? char-whitespace? char-upper-case?
+          char-lower-case? digit-value char-upcase char-downcase char-foldcase
+          string-ci=? string-ci<? string-ci<=? string-ci>? string-ci>=?
+          )
+  (begin
+    (define-binary-wrapper
+        (char-ci=? r7rs:char-ci=?)
+      (char-ci<? r7rs:char-ci<?)
+      (char-ci<=? r7rs:char-ci<=?)
+      (char-ci>? r7rs:char-ci>?)
+      (char-ci>=? r7rs:char-ci>=?)
+      (string-ci=? r7rs:string-ci=?)
+      (string-ci<? r7rs:string-ci<?)
+      (string-ci<=? r7rs:string-ci<=?)
+      (string-ci>? r7rs:string-ci>?)
+      (string-ci>=? r7rs:string-ci>=?))
+    (define-wrapper-from-strict ((char-alphabetic? x) r7rs:char-alphabetic?)
+      ((char-numeric? x) r7rs:char-numeric?)
+      ((char-whitespace? x) r7rs:char-whitespace?)
+      ((char-upper-case? x) r7rs:char-upper-case?)
+      ((char-lower-case? x) r7rs:char-lower-case?)
+      ((digit-value x) r7rs:digit-value)
+      ((char-upcase x) r7rs:char-upcase)
+      ((char-downcase x) r7rs:char-downcase)
+      ((char-foldcase x) r7rs:char-foldcase)
+      ((string-upcase x) r7rs:string-upcase)
+      ((string-downcase x) r7rs:string-downcase)
+      ((string-foldcase x) r7rs:string-foldcase))))
\ No newline at end of file
diff --git a/lib/hascheme/complex.sld b/lib/hascheme/complex.sld
new file mode 100644
index 0000000..5a5b676
--- /dev/null
+++ b/lib/hascheme/complex.sld
@@ -0,0 +1,12 @@
+(define-library (hascheme complex)
+  (import (hascheme base) (hascheme internal)
+          (prefix (hascheme complex) r7rs:))
+  (begin
+    (define-wrappers-from-strict
+        ;; Numbers
+      ((make-rectangular x y) r7rs:make-rectangular)
+      ((make-polar x y) r7rs:make-polar)
+      ((real-part x) r7rs:real-part)
+      ((imag-part x) r7rs:imag-part)
+      ((magnitude x) r7rs:magnitude)
+      ((angle x) r7rs:angle))))
\ No newline at end of file
diff --git a/lib/hascheme/inexact.sld b/lib/hascheme/inexact.sld
new file mode 100644
index 0000000..07b6927
--- /dev/null
+++ b/lib/hascheme/inexact.sld
@@ -0,0 +1,19 @@
+(define-library (hascheme inexact)
+  (import (hascheme base) (hascheme internal)
+          (prefix (scheme inexact) r7rs:))
+  (export)
+  (begin
+    (define-wrappers-from-strict
+        ;; Numbers
+      ((finite? x) r7rs:finite?)
+      ((infinite? x) r7rs:infinite?)
+      ((nan? x) r7rs:nan?)
+      ((exp z) r7rs:exp)
+      (log r7rs:log)
+      ((sin x) r7rs:sin)
+      ((cos x) r7rs:cos)
+      ((tan x) r7rs:tan)
+      ((asin x) r7rs:asin)
+      ((acos x) r7rs:acos)
+      (atan r7rs:atan)
+      (sqrt r7rs:sqrt))))
\ No newline at end of file