!42 Massive update on 20240901

goldfish/liii/base.scm

@@ -15,7 +15,33 @@
 ;
 
 (define-library (liii base)
-(export == != display* in? let1 compose identity)
+(import (scheme base))
+(export
+  ; (scheme base) defined by R7RS
+  let-values
+  define-record-type
+  square
+  ; String
+  string-copy
+  ; Vector
+  vector->string
+  string->vector
+  vector-copy
+  vector-copy!
+  ; Input and Output
+  call-with-port port? binary-port? textual-port?
+  input-port-open? output-port-open?
+  open-binary-input-file open-binary-output-file
+  close-port
+  eof-object
+  ; Control flow
+  string-map vector-map string-for-each vector-for-each
+  ; Exception
+  raise guard read-error? file-error?
+
+  ; Extra routines for (liii base)
+  == != display* in? let1 compose identity typed-lambda
+)
 (begin
 
 (define == equal?)
@@ -51,6 +77,26 @@
       (lambda (x)
         ((car fs) ((apply compose (cdr fs)) x)))))
 
+; 0 clause BSD, from S7 repo stuff.scm
+(define-macro (typed-lambda args . body)
+  ; (typed-lambda ((var [type])...) ...)
+  (if (symbol? args)
+      (apply lambda args body)
+      (let ((new-args (copy args)))
+        (do ((p new-args (cdr p)))
+            ((not (pair? p)))
+          (if (pair? (car p))
+              (set-car! p (caar p))))
+        `(lambda ,new-args
+           ,@(map (lambda (arg)
+                    (if (pair? arg)
+                        `(unless (,(cadr arg) ,(car arg))
+                           (error 'type-error
+                             "~S is not ~S~%" ',(car arg) ',(cadr arg)))
+                        (values)))
+                  args)
+           ,@body))))
+
 ) ; end of begin
 ) ; end of define-library
 

goldfish/liii/list.scm

@@ -55,19 +55,16 @@
 (define (flatmap f seq)
   (fold-right append () (map f seq)))
 
-; the opposite of null-list?
 (define (not-null-list? l)
   (cond ((pair? l)
          (or (null? (cdr l)) (pair? (cdr l))))
         ((null? l) #f)
         (else
          (error 'type-error "type mismatch"))))
 
-; no exception version of null-list?
 (define (list-null? l)
   (and (not (pair? l)) (null? l)))
 
-; no exception version of not-null-list?
 (define (list-not-null? l)
   (and (pair? l)
        (or (null? (cdr l)) (pair? (cdr l)))))

goldfish/liii/queue.scm

@@ -0,0 +1,83 @@
+;
+; Copyright (C) 2024 The Goldfish Scheme Authors
+;
+; Licensed under the Apache License, Version 2.0 (the "License");
+; you may not use this file except in compliance with the License.
+; You may obtain a copy of the License at
+;
+; http://www.apache.org/licenses/LICENSE-2.0
+;
+; Unless required by applicable law or agreed to in writing, software
+; distributed under the License is distributed on an "AS IS" BASIS, WITHOUT
+; WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. See the
+; License for the specific language governing permissions and limitations
+; under the License.
+;
+
+(define-library (liii queue)
+(import (liii list)
+        (liii base)
+        (srfi srfi-9)
+        (liii error))
+(export
+  queue
+  queue? queue-empty?
+  queue-size queue-front queue-back
+  queue-pop! queue-push!
+  queue->list)
+(begin
+
+(define-record-type :queue
+  (make-queue data)
+  queue?
+  (data get-data set-data!))
+
+(define (%queue-assert-type q)
+  (when (not (queue? q))
+    (type-error "Parameter q is not a queue")))
+
+(define (%queue-assert-value q)
+  (when (queue-empty? q)
+    (value-error "q must be non-empty")))
+
+(define (queue . l)
+  (if (null? l)
+      (make-queue '())
+      (make-queue l)))
+
+(define (queue-empty? q)
+  (%queue-assert-type q)
+  (null? (get-data q)))
+
+(define (queue-size q)
+  (%queue-assert-type q)
+  (length (get-data q)))
+
+(define (queue-front q)
+  (%queue-assert-type q)
+  (%queue-assert-value q)
+  (first (get-data q)))
+
+(define (queue-back q)
+  (%queue-assert-type q)
+  (%queue-assert-value q)
+  (last (get-data q)))
+
+(define (queue-push! q x)
+  (%queue-assert-type q)
+  (let1 data (get-data q)
+    (set-data! q (append data (list x)))))
+
+(define (queue-pop! q)
+  (%queue-assert-type q)
+  (%queue-assert-value q)
+  (let1 data (get-data q)
+    (set-data! q (cdr data))
+    (car data)))
+
+(define (queue->list q)
+  (get-data q))
+
+) ; end of begin
+) ; end of library
+

goldfish/liii/stack.scm

@@ -21,7 +21,9 @@
 (export
  stack
  stack? stack-empty?
- stack-top stack-push! stack-pop!
+ stack-size stack-top
+ stack-push! stack-pop!
+ stack->list
 )
 (begin
 
@@ -33,6 +35,7 @@
 (define (%stack-check-parameter st)
   (when (not (stack? st))
     (error 'type-error "Parameter st is not a stack")))
+
 (define (stack . l)
   (if (null? l)
       (make-stack '())
@@ -42,6 +45,10 @@
   (%stack-check-parameter st)
   (null? (get-data st)))
 
+(define (stack-size st)
+  (%stack-check-parameter st)
+  (length (get-data st)))
+
 (define (stack-top st)
   (%stack-check-parameter st)
   (car (get-data st)))
@@ -58,6 +65,10 @@
     (set-data! st (cdr data))
     (car data)))
 
+(define (stack->list st)
+  (%stack-check-parameter st)
+  (get-data st))
+
 ) ; end of begin
 ) ; end of library
 

goldfish/scheme/base.scm

@@ -17,6 +17,7 @@
 (define-library (scheme base)
 (export
   let-values
+  define-record-type
   square
   ; String
   string-copy
@@ -70,6 +71,39 @@
                 vars)))
         ,@body)))
 
+; 0-clause BSD by Bill Schottstaedt from S7 source repo: r7rs.scm
+(define-macro (define-record-type type make ? . fields)
+  (let ((obj (gensym))
+        (typ (gensym)) ; this means each call on this macro makes a new type
+        (args (map (lambda (field)
+                     (values (list 'quote (car field))
+                             (let ((par (memq (car field) (cdr make))))
+                               (and (pair? par) (car par)))))
+                   fields)))
+    `(begin
+       (define (,? ,obj)
+         (and (let? ,obj)
+              (eq? (let-ref ,obj ',typ) ',type)))
+
+       (define ,make 
+         (inlet ',typ ',type ,@args))
+
+       ,@(map
+          (lambda (field)
+            (when (pair? field)
+              (if (null? (cdr field))
+                  (values)
+                  (if (null? (cddr field))
+                      `(define (,(cadr field) ,obj)
+                         (let-ref ,obj ',(car field)))
+                      `(begin
+                         (define (,(cadr field) ,obj)
+                           (let-ref ,obj ',(car field)))
+                         (define (,(caddr field) ,obj val)
+                           (let-set! ,obj ',(car field) val)))))))
+          fields)
+       ',type)))
+
 (define (square x) (* x x))
 
 (define (string-copy str . start_end)

goldfish/srfi/srfi-1.scm

@@ -109,6 +109,8 @@
         (lp (cdr lis) (if (pred (car lis)) (+ i 1) i)))))
 
 (define (fold f initial l)
+  (when (not (procedure? f))
+    (error 'type-error "The first param must be a procedure"))
   (if (null? l)
       initial
       (fold f

goldfish/srfi/srfi-125.scm

@@ -15,6 +15,7 @@
 ;
 
 (define-library (srfi srfi-125)
+(import (srfi srfi-1))
 (export
   make-hash-table, hash-table, hash-table-unfold, alist->hash-table
   hash-table? hash-table-contains? hash-table-empty? hash-table=?
@@ -27,6 +28,12 @@
 )
 (begin
 
+(define (assert-hash-table-type ht f)
+  (when (not (hash-table? ht))
+    (error 'type-error f "this parameter must be typed as hash-table")))
+
+(define hash-table-set-s7 hash-table-set!)
+
 (define (hash-table-contains? ht key)
   (not (not (hash-table-ref ht key))))
 
@@ -36,8 +43,50 @@
 (define (hash-table=? ht1 ht2)
   (equal? ht1 ht2))
 
+(define-macro (hash-table-ref/default ht key default)
+  `(or (hash-table-ref ,ht ,key)
+        ,default))
+
+(define (hash-table-set! ht . rest)
+  (assert-hash-table-type ht hash-table-set!)
+  (let1 len (length rest)
+    (when (or (odd? len) (zero? len))
+      (error 'wrong-number-of-args len "but must be even and non-zero"))
+
+    (hash-table-set-s7 ht (car rest) (cadr rest))
+    (when (> len 2)
+          (apply hash-table-set! (cons ht (cddr rest))))))
+
+(define (hash-table-delete! ht key . keys)
+  (assert-hash-table-type ht hash-table-delete!)
+  (let1 all-keys (cons key keys)
+    (length
+      (filter
+        (lambda (x)
+          (if (hash-table-contains? ht x)
+              (begin
+                (hash-table-set-s7 ht x #f)
+                #t)
+              #f))
+        all-keys))))
+
+(define (hash-table-update! ht key value)
+  (hash-table-set! ht key value))
+
+(define (hash-table-clear! ht)
+  (for-each
+    (lambda (key)
+      (hash-table-set! ht key #f))
+    (hash-table-keys ht)))
+
 (define hash-table-size hash-table-entries)
 
+(define (hash-table-keys ht)
+  (map car (map values ht)))
+
+(define (hash-table-values ht)
+  (map cdr (map values ht)))
+
 (define (hash-table->alist table)
   (map values table))
 

goldfish/srfi/srfi-9.scm

@@ -1,42 +1,6 @@
-; 0-clause BSD
-; Bill Schottstaedt
-; from S7 source repo: r7rs.scm
-
 (define-library (srfi srfi-9)
+(import (scheme base))
 (export define-record-type)              
 (begin
-
-(define-macro (define-record-type type make ? . fields)
-  (let ((obj (gensym))
-        (typ (gensym)) ; this means each call on this macro makes a new type
-        (args (map (lambda (field)
-                     (values (list 'quote (car field))
-                             (let ((par (memq (car field) (cdr make))))
-                               (and (pair? par) (car par)))))
-                   fields)))
-    `(begin
-       (define (,? ,obj)
-         (and (let? ,obj)
-              (eq? (let-ref ,obj ',typ) ',type)))
-
-       (define ,make 
-         (inlet ',typ ',type ,@args))
-
-       ,@(map
-          (lambda (field)
-            (when (pair? field)
-              (if (null? (cdr field))
-                  (values)
-                  (if (null? (cddr field))
-                      `(define (,(cadr field) ,obj)
-                         (let-ref ,obj ',(car field)))
-                      `(begin
-                         (define (,(cadr field) ,obj)
-                           (let-ref ,obj ',(car field)))
-                         (define (,(caddr field) ,obj val)
-                           (let-set! ,obj ',(car field) val)))))))
-          fields)
-       ',type)))
-
 ) ; end of begin
 ) ; end of define-library

tests/liii/base-test.scm

@@ -44,5 +44,13 @@
 (check-true ((compose not zero?) 1))
 (check-false ((compose not zero?) 0))
 
+(define add3
+  (typed-lambda
+    ((i integer?) (x real?) z)
+    (+ i x z)))
+
+(check (add3 1 2 3) => 6)
+(check-catch 'type-error (add3 1.2 2 3))
+
 (check-report)