add cond-values
This commit is contained in:
parent
63621689a1
commit
97b7b105d4
|
@ -0,0 +1,158 @@
|
||||||
|
;;; 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.
|
||||||
|
|
||||||
|
;;; 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=> x)
|
||||||
|
(after ((when (pair? x)))
|
||||||
|
(values (car x) (cdr x))))
|
||||||
|
|
||||||
|
(define (assq=> 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))))))
|
Loading…
Reference in New Issue