From 13c68fc3fa2f48ad59574885a8b46d7844459dfc Mon Sep 17 00:00:00 2001 From: Peter McGoron Date: Fri, 18 Oct 2024 12:48:01 -0400 Subject: [PATCH] factor into libraries --- cond-values.scm => cond-values-impl.scm | 28 ------------------ cond-values.r7rs.scm | 23 +++++++++++++++ values-lib.r7rs.scm | 20 +++++++++++++ values-lib.scm | 38 +++++++++++++++++++++++++ 4 files changed, 81 insertions(+), 28 deletions(-) rename cond-values.scm => cond-values-impl.scm (83%) create mode 100644 cond-values.r7rs.scm create mode 100644 values-lib.r7rs.scm create mode 100644 values-lib.scm diff --git a/cond-values.scm b/cond-values-impl.scm similarity index 83% rename from cond-values.scm rename to cond-values-impl.scm index 099536c..e0b4889 100644 --- a/cond-values.scm +++ b/cond-values-impl.scm @@ -11,8 +11,6 @@ ;;; 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 @@ -159,29 +157,3 @@ (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))))) diff --git a/cond-values.r7rs.scm b/cond-values.r7rs.scm new file mode 100644 index 0000000..22c7f8a --- /dev/null +++ b/cond-values.r7rs.scm @@ -0,0 +1,23 @@ +;;; 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. + +(cond-expand + (chicken (import r7rs))) + +(define-library (mcgoron.com cond-values) + (import (scheme base)) + (export after cond-values + define-record-type/destructor + pair-d assq-d + length* length-at-least) + (import "cond-values.scm")) diff --git a/values-lib.r7rs.scm b/values-lib.r7rs.scm new file mode 100644 index 0000000..df50d04 --- /dev/null +++ b/values-lib.r7rs.scm @@ -0,0 +1,20 @@ +;;; 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. + +(cond-expand + (chicken (import r7rs))) + +(define-library (mcgoron.com values-lib) + (import (scheme base) srfi-1) + (export map-values any-values) + (import "values-lib.scm")) diff --git a/values-lib.scm b/values-lib.scm new file mode 100644 index 0000000..79e8d98 --- /dev/null +++ b/values-lib.scm @@ -0,0 +1,38 @@ +;;; 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. + +;;; 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)))))