cond-values: add with example

1 files changed, 187 insertions, 0 deletions

diff --git a/cond-values.scm b/cond-values.scm
new file mode 100644
index 0000000..099536c
--- /dev/null
+++ b/cond-values.scm
@@ -0,0 +1,187 @@
+;;; Copyright 2024 Peter McGoron
+;;; 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.
+
+(import srfi-1)
+
+;;; AFTER executes a body after multiple tests.
+;;; 
+;;; The form of the syntax is
+;;; (AFTER (BINDING ...) BODY ...)
+;;; 
+;;; where BODY ... is a Scheme body. Each BINDING is evaluated in order,
+;;; where BINDING is
+;;; 
+;;; (VALUE => FORMAL): FORMAL is a LAMBDA formal and VALUE is a something
+;;; that returns multiple values. If VALUE evaluates to no values, the
+;;; test fails and the entire AFTER form returns no values.
+;;; 
+;;; (WHEN TEST): Evaluates TEST. If TEST is #F then the entire AFTER form
+;;; returns no values.
+;;; 
+;;; If all BINDINGs pass, then BODY is executed and its return value is
+;;; the return of AFTER.
+(define-syntax after
+  (syntax-rules (when let =>)
+    ((after ((let value => formal) conditionals ...) body ...)
+     (call-with-values (lambda () value)
+       (lambda returned
+         (if (null? returned)
+             (values)
+             (apply (lambda formal (after (conditionals ...) body ...))
+                    returned)))))
+    ((after ((let formal value ...) conditionals ...) body ...)
+     (after ((let (begin value ...) => formal) conditionals ...)
+       body ...))
+    ((after ((when boolean) conditionals ...) body ...)
+     (if boolean
+         (after (conditionals ...) body ...)
+         (values)))
+    ((after () body ...)
+     (begin body ...))))
+
+(define-syntax apply-after
+  (syntax-rules ()
+    ((apply-after value receiver)
+     (after ((let value => formal))
+       (apply receiver formal)))))
+
+;;; (COND-VALUES CLAUSE ...) is like COND, but it tests for empty VALUES
+;;; instead of #F.
+;;; 
+;;; Each CLAUSE is:
+;;; 
+;;; (BODY ...): Executes BODY. If BODY returns no values, then try the
+;;; rest of the clauses. If BODY returns values, those values are the
+;;; return values of COND-VALUES.
+;;; (ELSE BODY ...): Must occur at the end. Executes BODY and returns
+;;; whatever BODY returns.
+;;; 
+;;; If there is no ELSE clause and all CLAUSEs fail, COND-VALUES returns
+;;; no values.
+(define-syntax cond-values
+  (syntax-rules (else)
+    ((cond-values (else body ...))
+     (begin body ...))
+    ((cond-values value rest ...)
+     (call-with-values (lambda () value)
+       (lambda returned
+         (if (null? returned)
+             (cond-values rest ...)
+             (apply values returned)))))
+    ((cond-values) (values))))
+
+;;; (DEFINE-RECORD-TYPE/DESTRUCTOR TYPENAME
+;;;   (CSTR FIELDS ...)
+;;;   PREDICATE?
+;;;   DESTRUCTOR
+;;;   (FIELD GETTER SETTER ...)
+;;;   ...)
+;;; 
+;;; creates an SRFI-9/R7RS record type. The syntax is the same, except
+;;; that after the PREDICATE field and before the getter/setter fields
+;;; is an identifier, DESTRUCTOR.
+;;; 
+;;; This macro defines a procedure (DESTRUCTOR RECORD) that returns each
+;;; field of RECORD as values, or no values if RECORD is not a TYPENAME
+;;; record.
+(define-syntax define-record-type/destructor
+  (syntax-rules ()
+    ((define-record-type/destructor typename
+       (cstr fields ...)
+       predicate?
+       destructor
+       (field getter setter ...)
+       ...)
+     (begin
+       (define-record-type typename
+         (cstr fields ...)
+         predicate?
+         (field getter setter ...)
+         ...)
+       (define (destructor record)
+         (after ((when (predicate? record)))
+           (values (getter record) ...)))))))
+
+;;; ;;;;;;;;;;;;;
+;;; Helper functions
+;;; ;;;;;;;;;;;;;
+
+;;; Returns the CAR and CDR of X as values when X is a pair, and no values
+;;; otherwise.
+(define (pair-d x)
+  (after ((when (pair? x)))
+    (values (car x) (cdr x))))
+
+(define (assq-d val alist)
+  (let ((pair (assq val alist)))
+    (after ((when (pair? pair)))
+      (cdr pair))))
+
+;;; Returns the list as values when WHOLE-LIST has length NUM, and no
+;;; values otherwise.
+(define (length* whole-list num)
+  (when (<= num 0)
+    (error "invalid number" 'length* whole-list num))
+
+  (let length* ((lst whole-list)
+                (num num))
+    (cond-values
+      (after ((when (null? lst))
+        (when (= num 0)))
+        (apply values whole-list))
+      (after ((when (pair? lst))
+             (when (> num 0)))
+        (length* (cdr lst) (- num 1))))))
+
+;;; Returns the list as values when WHOLE-LIST has at least length NUM,
+;;; and no values otherwise.
+(define (length-at-least whole-list num)
+  (when (<= num 0)
+    (error "invalid number" 'length-at-least whole-list num))
+
+  (let length-at-least ((lst whole-list)
+                        (num num))
+    (cond-values
+      (after ((when (= num 0))
+              (when (or (null? lst)
+                        (pair? lst))))
+        (apply values whole-list))
+      (after ((when (> num 0))
+              (when (pair? lst)))
+        (length-at-least (cdr lst) (- num 1))))))
+
+;;; Helper function.
+(define (null-cdr? lst) (null? (cdr lst)))
+
+;;; MAP-VALUES returns (VALUES L1 L2 ...), where L1 is the first
+;;; value returned from (F (CAR LST)), (F (CADR LST)), ... and so on.
+(define (map-values f . lists)
+  (define (null-cdr? lst) (null? (cdr lst)))
+  (let-values ((new-values (apply f (map car lists))))
+    (if (any null-cdr? lists)
+        (apply values (map list new-values))
+        (let-values ((returned (apply map-values f (map cdr lists))))
+          (apply values (map cons new-values returned))))))
+
+;;; (ANY-VALUES F (A1 A2 ...) (B1 B2 ...) ...) runs
+;;; (F A1 B1 ...) and checks if there any returned values. If there are
+;;; none, runs (F A2 B2 ...), and so on.
+;;; 
+;;; If any of the lists end, then ANY-VALUES returns no values.
+(define (any-values f . lists)
+  (after ((when (not (null? lists)))
+          (when (all pair? lists)))
+    (let-values ((returned (apply f (map car lists))))
+      (if (null? returned)
+          (apply any-values f (map cdr lists))
+          (apply values returned)))))