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