3 files changed, 261 insertions, 0 deletions
diff --git a/prescheme-nim-local/lib/ps-string.scm b/prescheme-nim-local/lib/ps-string.scm
new file mode 100644
index 0000000..6e72793
--- /dev/null
+++ b/prescheme-nim-local/lib/ps-string.scm
@@ -0,0 +1,25 @@
+;;; ps-string: string utilities for Pre-Scheme
+
+(define (string-copy! target offset source start end)
+  (do ((tgt offset (+ tgt 1))
+       (src start (+ src 1)))
+      ((= src end))
+    (string-set! target tgt (string-ref source src)))
+  (unspecific))
+
+(define (string-append a b)
+  (let* ((len-a (string-length a))
+         (len-b (string-length b))
+         (target (make-string (+ len-a len-b))))
+    (string-copy! target 0 a 0 len-a)
+    (string-copy! target len-a b 0 len-b)
+    target))
+
+(define (string-repeat source n)
+  (let* ((len (string-length source))
+         (total (* len n))
+         (target (make-string total)))
+    (do ((ix 0 (+ ix len)))
+        ((= ix total))
+      (string-copy! target ix source 0 len))
+    target))
diff --git a/prescheme-nim-local/lib/ps-utils.scm b/prescheme-nim-local/lib/ps-utils.scm
new file mode 100644
index 0000000..574bb04
--- /dev/null
+++ b/prescheme-nim-local/lib/ps-utils.scm
@@ -0,0 +1,32 @@
+;;; ps-utils --- Utilities for Pre-Scheme
+
+(define-syntax when
+  (syntax-rules ()
+    ((_ condition consequent ...)
+     (if condition
+         (begin consequent ...)))))
+
+(define-syntax unless
+  (syntax-rules ()
+    ((_ condition antecedent ...)
+     (if (not condition)
+         (begin antecedent ...)))))
+
+(define-syntax define-wrapper-type
+  (lambda (exp rename compare)
+    (define (symbol-append . args)
+      (string->symbol
+       (apply string-append (map (lambda (s)
+                                   (if (string? s) s (symbol->string s)))
+                                 args))))
+    (let* ((name (cadr exp))
+           (type-id (symbol-append ":" name))
+           (constructor (rename (symbol-append "make-" name)))
+           (%begin (rename 'begin))
+           (%define-record-type (rename 'define-record-type))
+           (%define-external (rename 'define-external)))
+      `(,%define-record-type ,name ,type-id
+        (,constructor)))))
+
+(define (zero? n) (= n 0))
+(define (one? n) (= n 1))
diff --git a/prescheme-nim-local/lib/ps-vector.scm b/prescheme-nim-local/lib/ps-vector.scm
new file mode 100644
index 0000000..369040f
--- /dev/null
+++ b/prescheme-nim-local/lib/ps-vector.scm
@@ -0,0 +1,204 @@
+;;; ps-vector: vector utilities for Pre-Scheme
+;;;
+;;; These routines are based on SRFI-43 for Scheme, with some
+;;; adjustments to account for the limitations of Pre-Scheme.
+;;;
+;;; Pre-Scheme's native vectors don't support vector-length at runtime,
+;;; so we take an additional length argument, as is common practice in C.
+;;;
+;;; Pre-Scheme doesn't support variadic functions, so we have a variant
+;;; for each arity, as you might do in C.  It should be possible to
+;;; generate these with a macro, but that's not yet implemented.
+
+;;; vector-unfold
+
+(define-syntax vector-unfold
+  (syntax-rules ()
+    ((_ proc len)
+     (vector-unfold0 proc len))
+    ((_ proc len seed)
+     (vector-unfold1 proc len seed))
+    ((_ proc len seed1 seed2)
+     (vector-unfold2 proc len seed1 seed2))
+    ((_ proc len seed1 seed2 seed3)
+     (vector-unfold3 proc len seed1 seed2 seed3))))
+
+(define (vector-unfold0 proc len)
+  ;; FIXME get proc's return type without calling it
+  (let ((result (make-vector len (proc 0))))
+    (let loop ((i 0))
+      (if (= i len)
+          result
+          (begin
+            (vector-set! result i (proc i))
+            (loop (+ i 1)))))))
+
+(define (vector-unfold1 proc len seed)
+  (let ((result (receive (val next)
+                    (proc 0 seed)
+                  (make-vector len val))))
+    (let loop ((i 0) (seed seed))
+      (if (= i len)
+          result
+          (receive (val next)
+              (proc i seed)
+            (vector-set! result i val)
+            (loop (+ i 1) next))))))
+
+(define (vector-unfold2 proc len seed1 seed2)
+  (let ((result (receive (val next1 next2)
+                    (proc 0 seed1 seed2)
+                  (make-vector len val))))
+    (let loop ((i 0) (seed1 seed1) (seed2 seed2))
+      (if (= i len)
+          result
+          (receive (val next1 next2)
+              (proc i seed1 seed2)
+            (vector-set! result i val)
+            (loop (+ i 1) next1 next2))))))
+
+(define (vector-unfold3 proc len seed1 seed2 seed3)
+  (let ((result (receive (val next1 next2 next3)
+                    (proc 0 seed1 seed2 seed3)
+                  (make-vector len val))))
+    (let loop ((i 0) (seed1 seed1) (seed2 seed2) (seed3 seed3))
+      (if (= i len)
+          result
+          (receive (val next1 next2 next3)
+              (proc i seed1 seed2 seed3)
+            (vector-set! result i val)
+            (loop (+ i 1) next1 next2 next3))))))
+
+;;; vector-fold
+
+(define-syntax vector-fold
+  (syntax-rules ()
+    ((_ proc init vec len)
+     (vector-fold1 proc init vec len))
+    ((_ proc init vec1 len1 vec2 len2)
+     (vector-fold2 proc init vec1 len1 vec2 len2))
+    ((_ proc init vec1 len1 vec2 len2 vec3 len3)
+     (vector-fold3 proc init vec1 len1 vec2 len2 vec3 len3))))
+
+(define (vector-fold1 proc init vec len)
+  (let loop ((i 0) (result init))
+    (if (= i len)
+        result
+        (loop (+ i 1) (proc i result (vector-ref vec i))))))
+
+(define (vector-fold2 proc init vec1 len1 vec2 len2)
+  (let ((len (min len1 len2)))
+    (let loop ((i 0) (result init))
+      (if (= i len)
+          result
+          (loop (+ i 1) (proc i result
+                              (vector-ref vec1 i)
+                              (vector-ref vec2 i)))))))
+
+(define (vector-fold3 proc init vec1 len1 vec2 len2 vec3 len3)
+  (let ((len (min len1 len2 len3)))
+    (let loop ((i 0) (result init))
+      (if (= i len)
+          result
+          (loop (+ i 1) (proc i result
+                              (vector-ref vec1 i)
+                              (vector-ref vec2 i)
+                              (vector-ref vec3 i)))))))
+
+;;; vector-map!
+
+(define-syntax vector-map!
+  (syntax-rules ()
+    ((_ proc vec len)
+     (vector-map1! proc vec len))
+    ((_ proc vec1 len1 vec2 len2)
+     (vector-map2! proc vec1 len1 vec2 len2))
+    ((_ proc vec1 len1 vec2 len2 vec3 len3)
+     (vector-map3! proc vec1 len1 vec2 len2 vec3 len3))))
+
+(define (vector-map1! proc vec len)
+  (vector-fold (lambda (i vec val)
+                 (vector-set! vec i (proc i val))
+                 vec)
+               vec vec len))
+
+(define (vector-map2! proc vec1 len1 vec2 len2)
+  (vector-fold (lambda (i vec val1 val2)
+                 (vector-set! vec i (proc i val1 val2))
+                 vec)
+               vec1 vec1 len1 vec2 len2))
+
+(define (vector-map3! proc vec1 len1 vec2 len2 vec3 len3)
+  (vector-fold (lambda (i vec val1 val2 val3)
+                 (vector-set! vec i (proc i val1 val2 val3))
+                 vec)
+               vec1 vec1 len1 vec2 len2 vec3 len3))
+
+;;; vector-map1
+
+(define-syntax vector-map
+  (syntax-rules ()
+    ((_ proc vec len)
+     (vector-map1 proc vec len))
+    ((_ proc vec1 len1 vec2 len2)
+     (vector-map2 proc vec1 len1 vec2 len2))
+    ((_ proc vec1 len1 vec2 len2 vec3 len3)
+     (vector-map3 proc vec1 len1 vec2 len2 vec3 len3))))
+
+(define (vector-map1 proc vec len)
+  ;; FIXME get proc's return type without calling it
+  (let ((res (make-vector len (proc 0 (vector-ref vec 0)))))
+    (vector-fold (lambda (i res val)
+                   (vector-set! res i (proc i val))
+                   res)
+                 res vec len)))
+
+(define (vector-map2 proc vec1 len1 vec2 len2)
+  (let* ((len (min len1 len2))
+         (res (make-vector len (proc 0
+                                     (vector-ref vec1 0)
+                                     (vector-ref vec2 0)))))
+    (vector-fold (lambda (i res val1 val2)
+                   (vector-set! res i (proc i val1 val2))
+                   res)
+                 res vec1 len1 vec2 len2)))
+
+(define (vector-map3 proc vec1 len1 vec2 len2 vec3 len3)
+  (let* ((len (min len1 len2 len3))
+         (res (make-vector len (proc 0
+                                     (vector-ref vec1 0)
+                                     (vector-ref vec2 0)
+                                     (vector-ref vec3 0)))))
+    (vector-fold (lambda (i res val1 val2 val3)
+                   (vector-set! res i (proc i val1 val2 val3))
+                   res)
+                 res vec1 len1 vec2 len2 vec3 len3)))
+
+;;; vector-for-each
+
+(define-syntax vector-for-each
+  (syntax-rules ()
+    ((_ proc vec len)
+     (vector-for-each1 proc vec len))
+    ((_ proc vec1 len1 vec2 len2)
+     (vector-for-each2 proc vec1 len1 vec2 len2))
+    ((_ proc vec1 len1 vec2 len2 vec3 len3)
+     (vector-for-each3 proc vec1 len1 vec2 len2 vec3 len3))))
+
+(define (vector-for-each1 proc vec len)
+  (vector-fold (lambda (i res val)
+                 (proc i val)
+                 res)
+               (unspecific) vec len))
+
+(define (vector-for-each2 proc vec1 len1 vec2 len2)
+  (vector-fold (lambda (i res val1 val2)
+                 (proc i val1 val2)
+                 res)
+               (unspecific) vec1 len1 vec2 len2))
+
+(define (vector-for-each3 proc vec1 len1 vec2 len2 vec3 len3)
+  (vector-fold (lambda (i res val1 val2 val3)
+                 (proc i val1 val2 val3)
+                 res)
+               (unspecific) vec1 len1 vec2 len2 vec3 len3))