aboutsummaryrefslogtreecommitdiff
path: root/prescheme-nim-local/lib
diff options
context:
space:
mode:
Diffstat (limited to 'prescheme-nim-local/lib')
-rw-r--r--prescheme-nim-local/lib/ps-string.scm25
-rw-r--r--prescheme-nim-local/lib/ps-utils.scm32
-rw-r--r--prescheme-nim-local/lib/ps-vector.scm204
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))
generated by cgit v1.2.3 (git 2.47.1) at 2025-04-29 23:46:53 +0000