From 83a18a658ac925b589d36e37ae150ec986d5eba8 Mon Sep 17 00:00:00 2001
From: Rose Hogenson <rhogenson@posteo.net>
Date: Fri, 5 Aug 2022 21:04:49 -0700
Subject: Add more of the standard library.

---
 lib/scheme/base/10-define.csc  |   7 +-
 lib/scheme/base/30-if.csc      |  29 ++++++++-
 lib/scheme/base/40-values.csc  | 125 +++++++++++++++++++++++++++++++++++
 lib/scheme/base/50-records.csc |  83 ++++++++++++++++++++++++
 lib/scheme/base/60-list.csc    | 144 +++++++++++++++++++++++++++++++++++++++++
 5 files changed, 385 insertions(+), 3 deletions(-)
 create mode 100644 lib/scheme/base/40-values.csc
 create mode 100644 lib/scheme/base/50-records.csc
 create mode 100644 lib/scheme/base/60-list.csc

(limited to 'lib/scheme/base')

diff --git a/lib/scheme/base/10-define.csc b/lib/scheme/base/10-define.csc
index d110268..a4f254e 100644
--- a/lib/scheme/base/10-define.csc
+++ b/lib/scheme/base/10-define.csc
@@ -1,9 +1,12 @@
 (export
   define
-  define-syntax)
+  define-syntax
+  set!)
 (import (only (csc builtins)
           builtin-define
-          define-syntax))
+          define-syntax
+          lambda
+          set!))
 (begin
 
 
diff --git a/lib/scheme/base/30-if.csc b/lib/scheme/base/30-if.csc
index 09012fa..6262f5a 100644
--- a/lib/scheme/base/30-if.csc
+++ b/lib/scheme/base/30-if.csc
@@ -1,5 +1,6 @@
 (export
   and
+  case-lambda
   cond
   if
   or
@@ -73,4 +74,30 @@
     (syntax-rules ()
       ((unless test result1 result2 ...)
         (if (not test)
-          (begin result1 result2 ...))))))
+          (begin result1 result2 ...)))))
+
+
+  (define-syntax case-lambda
+    (syntax-rules ()
+      ((case-lambda (params body0 ...) ...)
+        (lambda args
+          (let ((len (length args)))
+            (let-syntax
+              ((cl (syntax-rules ::: ()
+                     ((cl)
+                       (error "no matching clause"))
+                     ((cl ((p :::) . body) . rest)
+                       (if (= len (length ’(p :::)))
+                         (apply (lambda (p :::)
+                                  . body)
+                                args)
+                         (cl . rest)))
+                    ((cl ((p ::: . tail) . body)
+                         . rest)
+                      (if (>= len (length ’(p :::)))
+                        (apply
+                          (lambda (p ::: . tail)
+                            . body)
+                          args)
+                        (cl . rest))))))
+              (cl (params body0 ...) ...))))))))
diff --git a/lib/scheme/base/40-values.csc b/lib/scheme/base/40-values.csc
new file mode 100644
index 0000000..3a175a5
--- /dev/null
+++ b/lib/scheme/base/40-values.csc
@@ -0,0 +1,125 @@
+(export
+  apply
+  call-with-current-continuation
+  call-with-values
+  call/cc
+  define-values
+  let*-values
+  let-values
+  values)
+(import (only (csc builtins)
+          call-builtin))
+(begin
+
+
+  (define (call-with-current-continuation proc)
+    (call-builtin call-with-current-continuation proc))
+
+
+  (define call/cc call-with-current-continuation)
+
+
+  (define (call-with-values producer consumer)
+    (call-builtin call-with-values producer consumer))
+
+
+  (define (values . things)
+    (call-with-current-continuation
+      (lambda (cont) (apply cont things))))
+
+
+  (define-syntax let-values
+    (syntax-rules ()
+      ((let-values (binding ...) body0 body1 ...)
+        (let-values "bind"
+          (binding ...) () (begin body0 body1 ...)))
+
+      ((let-values "bind" () tmps body)
+        (let tmps body))
+
+      ((let-values "bind" ((b0 e0)
+           binding ...) tmps body)
+        (let-values "mktmp" b0 e0 ()
+           (binding ...) tmps body))
+
+      ((let-values "mktmp" () e0 args
+           bindings tmps body)
+        (call-with-values
+          (lambda () e0)
+          (lambda args
+            (let-values "bind"
+                bindings tmps body))))
+
+      ((let-values "mktmp" (a . b) e0 (arg ...)
+           bindings (tmp ...) body)
+        (let-values "mktmp" b e0 (arg ... x)
+            bindings (tmp ... (a x)) body))
+
+      ((let-values "mktmp" a e0 (arg ...)
+           bindings (tmp ...) body)
+        (call-with-values
+          (lambda () e0)
+          (lambda (arg ... . x)
+            (let-values "bind"
+                bindings (tmp ... (a x)) body))))))
+
+
+  (define-syntax let*-values
+    (syntax-rules ()
+      ((let*-values () body0 body1 ...)
+        (let () body0 body1 ...))
+
+      ((let*-values (binding0 binding1 ...)
+           body0 body1 ...)
+        (let-values (binding0)
+          (let*-values (binding1 ...)
+            body0 body1 ...)))))
+
+
+  (define-syntax define-values
+    (syntax-rules ()
+      ((define-values () expr)
+        (define dummy
+          (call-with-values (lambda () expr)
+                            (lambda args #f))))
+      ((define-values (var) expr)
+        (define var expr))
+      ((define-values (var0 var1 ... varn) expr)
+        (begin
+          (define var0
+            (call-with-values (lambda () expr)
+                              list))
+          (define var1
+            (let ((v (cadr var0)))
+              (set-cdr! var0 (cddr var0))
+              v)) ...
+          (define varn
+            (let ((v (cadr var0)))
+              (set! var0 (car var0))
+              v))))
+      ((define-values (var0 var1 ... . varn) expr)
+        (begin
+          (define var0
+            (call-with-values (lambda () expr)
+                              list))
+          (define var1
+            (let ((v (cadr var0)))
+              (set-cdr! var0 (cddr var0))
+              v)) ...
+          (define varn
+            (let ((v (cdr var0)))
+              (set! var0 (car var0))
+              v))))
+      ((define-values var expr)
+        (define var
+          (call-with-values (lambda () expr)
+                            list)))))
+
+
+  (define (apply proc arg1 . args)
+    (define args*
+      (let loop ((args (cons arg1 args)))
+        (if (null? (cdr args))
+          (car args)
+          (cons (car args) (loop (cdr args))))))
+    (call-builtin apply proc (list->vector args*))))
diff --git a/lib/scheme/base/50-records.csc b/lib/scheme/base/50-records.csc
new file mode 100644
index 0000000..d7fa8d1
--- /dev/null
+++ b/lib/scheme/base/50-records.csc
@@ -0,0 +1,83 @@
+(export
+  define-record-type)
+(import (only (csc builtins)
+          call-builtin))
+(begin
+
+
+  ; There are a few builtin types such as vector, which uses type code 0. We'll
+  ; start at 10 to give some room for more in the future.
+  (define *next-type-id* 10)
+
+
+  (define-syntax macro-length
+    (syntax-rules ()
+      ((macro-length ()) 0)
+      ((macro-length (x xs ...))
+        (+ 1 (macro-length (xs ...))))))
+
+
+  (define-syntax set-arguments
+    (syntax-rules ()
+      ((set-arguments _ _)
+        #f)
+      ((set-arguments r n field1 field2 ...)
+        (begin
+          (call-builtin poke field1 r n)
+          (set-arguments r (+ 1 n) field2 ...)))))
+
+
+  (define-syntax define-selectors
+    (syntax-rules ()
+      ((define-selectors (selectors ...))
+        (values selectors ...))
+      ((define-selectors (selectors ...) (field getter) selector ...)
+        (define-selectors (selectors ... (lambda (r)
+                                           (call-builtin peek r field)))
+          selector ...))
+      ((define-selectors (selectors ...) (field getter setter) selector ...)
+        (define-selectors (selectors ... (lambda (r)
+                                           (call-builtin peek r field))
+                                         (lambda (r val)
+                                           (call-builtin poke val r field)))
+          selector ...))))
+
+
+  (define-syntax enumerate-fields
+    (syntax-rules ()
+      ((enumerate-fields _ selectors)
+        (define-selectors selectors))
+      ((enumerate-fields n selectors field1 field2 ...)
+        (begin
+          (define field1 n)
+          (enumerate-fields (+ 1 n) selectors field2 ...)))))
+
+
+  (define-syntax selector-names
+    (syntax-rules ()
+      ((selector-names selectors (field ...) (name ...))
+        (define-values (name ...)
+          (enumerate-fields 1 selectors field ...)))
+      ((selector-names selectors fields (names ...) (_ getter) selector ...)
+        (selector-names selectors fields (names ... getter) selector ...))
+      ((selector-names selectors fields (names ...) (_ getter setter) selector ...)
+        (selector-names selectors fields (names ... getter setter) selector ...))))
+
+
+  (define-syntax define-record-type
+    (syntax-rules ()
+      ((define-record-type _
+         (constructor field ...)
+         pred
+         selectors ...)
+        (define type-id
+          (let ((id *next-type-id*))
+            (set! *next-type-id* (call-builtin + 1 *next-type-id*))))
+        (define (pred r)
+          (call-builtin eq? type-id (call-builtin peek r 0)))
+        (define (constructor field ...)
+          (define r (call-builtin alloc (macro-length (field ...))))
+          (call-builtin poke type-id r 0)
+          (set-arguments r 1 field ...)
+          r)
+        (selector-names (selectors ...) (field ...) () selectors ...)))))
diff --git a/lib/scheme/base/60-list.csc b/lib/scheme/base/60-list.csc
new file mode 100644
index 0000000..cbfc12a
--- /dev/null
+++ b/lib/scheme/base/60-list.csc
@@ -0,0 +1,144 @@
+(export
+  append
+  caar
+  cadr
+  car
+  cdar
+  cddr
+  cdr
+  cons
+  length
+  list
+  list-copy
+  list-ref
+  list-set!
+  list-tail
+  list?
+  make-list
+  null?
+  pair?
+  reverse
+  set-car!
+  set-cdr!)
+(import (only (csc builtins)
+          call-builtin))
+(begin
+
+
+  (define-record-type <pair>
+    (cons x y)
+    pair?
+    (x car set-car!)
+    (y cdr set-cdr!))
+
+
+  (define (caar pair)
+    (car (car pair)))
+
+
+  (define (cadr pair)
+    (car (cdr pair)))
+
+
+  (define (cdar pair)
+    (cdr (car pair)))
+
+
+  (define (cddr pair)
+    (cdr (cdr pair)))
+
+
+  (define (null? obj)
+    (call-builtin eq? obj '()))
+
+
+  (define (list? obj)
+    (cond
+      ((null? obj) #t)
+      ((not (pair? obj)) #f)
+      (else
+        (let loop ((tortoise obj)
+                   (hare (cdr obj)))
+          (cond
+            ((null? hare) #t)
+            ((not (pair? hare)) #f)
+            ((null? (cdr hare)) #t)
+            ((not (pair? (cdr hare))) #f)
+            ((eq? tortoise hare) #f)  ; cycle detected
+            (else
+              (loop (cdr tortoise)
+                    (cddr hare))))))))
+
+
+  (define make-list
+    (case-lambda
+      ((k)
+        (make-list k #f))
+      ((k fill)
+        (let loop ((k k)
+                   (acc '()))
+          (if (zero? k)
+            acc
+            (loop (- k 1) (cons fill acc)))))))
+
+
+  (define (list . args)
+    args)
+
+
+  (define (length l)
+    (let loop ((l l)
+               (n 0))
+      (if (null? l)
+        n
+        (loop (cdr l) (+ 1 n)))))
+
+
+  (define (append2 l1 l2)
+    (let loop ((l1 l1))
+      (if (null? l1)
+        l2
+        (cons (car l1) (loop (cdr l1))))))
+
+
+  (define (append . ls)
+    (let loop ((ls ls))
+      (cond
+        ((null? ls) '())
+        ((null? (cdr ls))
+          (car ls))
+        (else
+          (append2 (car ls)
+                   (loop (cdr ls)))))))
+
+
+  (define (reverse l)
+    (let loop ((l l)
+               (acc '()))
+      (if (null? l)
+        acc
+        (loop (cdr l) (cons (car l) acc)))))
+
+
+  (define (list-tail l k)
+    (if (zero? k)
+      l
+      (list-tail (cdr l) (- k 1))))
+
+
+  (define (list-ref l k)
+    (car (list-tail l k)))
+
+
+  (define (list-set! l k obj)
+    (let loop ((l l)
+               (k k))
+      (if (zero? k)
+        (set-car! l obj)
+        (loop (cdr l) (- k 1)))))
+
+
+  (define (list-copy obj)
+    (if (pair? l)
+      (cons (car l) (list-copy (cdr l)))
+      l)))
-- 
cgit v1.3.1