mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-29 14:30:34 +02:00
2d602d28c3
https://srfi.schemers.org/srfi-197/srfi-197.html Add the key files from the upstream implementation. These files are the unmodified versions from the upstream repository https://github.com/scheme-requests-for-implementation/srfi-197.git as of this commit (final-5-g43eae09): commit 43eae0941e4c69b11b5609464b7d8827785c3897 Author: Arthur A. Gleckler <srfi@speechcode.com> Date: Sun Apr 20 20:30:25 2025 -0700 Regenerate landing page and README. except that the upstream LICENSE/MIT.txt referred to by the SPDX headers has been added to the top of srfi-197.scm and srfi-197.text, and srfi-197.scm has been reindented. srfi-197.html already includes its own copyright statement. srfi-197.scm is upstream srfi-197-syntax-case.scm, and was chosen instead of upstream srfi-197.scm because Guile doesn't currently handle syntax-rules with custom elipsis. For now add the html documentation as-is; convert it to texinfo later. * doc/ref/srfi-197.html: Add new file. * module/srfi/srfi-197.scm: Add new file (upstream srfi-197-syntax-case.scm). * test-suite/tests/srfi-197.test: Add new file (upstream test.scm).
204 lines
9 KiB
Scheme
204 lines
9 KiB
Scheme
;;;; SPDX-FileCopyrightText: 2020 Adam R. Nelson <adam@nels.onl>
|
|
;;;;
|
|
;;;; SPDX-License-Identifier: MIT
|
|
;;;;
|
|
;;;; MIT License
|
|
;;;;
|
|
;;;; Copyright (c) 2020 Adam R. Nelson <adam@nels.onl>
|
|
;;;;
|
|
;;;; Permission is hereby granted, free of charge, to any person
|
|
;;;; obtaining a copy of this software and associated documentation
|
|
;;;; files (the "Software"), to deal in the Software without
|
|
;;;; restriction, including without limitation the rights to use, copy,
|
|
;;;; modify, merge, publish, distribute, sublicense, and/or sell copies
|
|
;;;; of the Software, and to permit persons to whom the Software is
|
|
;;;; furnished to do so, subject to the following conditions:
|
|
;;;;
|
|
;;;; The above copyright notice and this permission notice shall be
|
|
;;;; included in all copies or substantial portions of the Software.
|
|
;;;;
|
|
;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
|
;;;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
|
;;;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
|
;;;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
|
|
;;;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
|
|
;;;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
|
|
;;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
|
;;;; SOFTWARE.
|
|
|
|
; A syntax-case implementation of SRFI 197.
|
|
; This should be functionally equivalent to srfi-197.scm,
|
|
; but it may be easier to read and understand.
|
|
|
|
(define (gentemp) (car (generate-temporaries '(x))))
|
|
|
|
(define (id=? x y) (and (identifier? x) (free-identifier=? x y)))
|
|
|
|
(define-syntax chain
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ initial-value (step ...) ...)
|
|
#'(chain initial-value _ (... ...) (step ...) ...))
|
|
((_ initial-value placeholder (step ...) ...)
|
|
#'(chain initial-value placeholder (... ...) (step ...) ...))
|
|
((_ initial-value placeholder ellipsis) (and (identifier? #'placeholder)
|
|
(identifier? #'ellipsis))
|
|
#'initial-value)
|
|
((_ initial-value placeholder ellipsis (step ...) rest ...)
|
|
(let loop ((vars '()) (out '()) (in #'(step ...)))
|
|
(syntax-case in ()
|
|
((u …) (and (id=? #'u #'placeholder) (id=? #'… #'ellipsis))
|
|
(let ((chain-rest-var (gentemp)))
|
|
#`(chain (let-values ((#,(if (null? vars)
|
|
chain-rest-var
|
|
#`(#,@(reverse vars) . #,chain-rest-var))
|
|
initial-value))
|
|
(apply #,@(reverse out) #,chain-rest-var))
|
|
placeholder
|
|
ellipsis
|
|
rest ...)))
|
|
((u … . _) (and (id=? #'u #'placeholder) (id=? #'… #'ellipsis))
|
|
(syntax-violation 'chain "_ ... only allowed at end" #'(step ...)))
|
|
((u . step-rest) (id=? #'u #'placeholder)
|
|
(let ((chain-var (gentemp)))
|
|
(loop (cons chain-var vars) (cons chain-var out) #'step-rest)))
|
|
((… . _) (id=? #'… #'ellipsis)
|
|
(syntax-violation 'chain "misplaced ..." #'(step ...)))
|
|
((x . step-rest)
|
|
(loop vars (cons #'x out) #'step-rest))
|
|
(()
|
|
(with-syntax ((result (reverse out)))
|
|
#`(chain
|
|
#,(cond
|
|
((null? vars)
|
|
#'(begin initial-value result))
|
|
((null? (cdr vars))
|
|
#`(let ((#,(car vars) initial-value)) result))
|
|
(else
|
|
#`(let-values ((#,(reverse vars) initial-value)) result)))
|
|
placeholder
|
|
ellipsis
|
|
rest ...)))))))))
|
|
|
|
(define-syntax chain-and
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ initial-value (step ...) ...)
|
|
#'(chain-and initial-value _ (step ...) ...))
|
|
((_ initial-value placeholder) (identifier? #'placeholder)
|
|
#'initial-value)
|
|
((_ initial-value placeholder (step ...) rest ...)
|
|
(let loop ((var #f) (out '()) (in #'(step ...)))
|
|
(syntax-case in ()
|
|
((u . step-rest) (id=? #'u #'placeholder)
|
|
(if var
|
|
(syntax-violation 'chain-and "only one _ allowed per step" #'(step ...))
|
|
(let ((chain-var (gentemp)))
|
|
(loop chain-var (cons chain-var out) #'step-rest))))
|
|
((x . step-rest)
|
|
(loop var (cons #'x out) #'step-rest))
|
|
(()
|
|
(with-syntax ((result (reverse out)))
|
|
#`(chain-and
|
|
#,(if var
|
|
#`(let ((#,var initial-value))
|
|
(and #,var result))
|
|
#'(and initial-value result))
|
|
placeholder
|
|
rest ...)))))))))
|
|
|
|
(define-syntax chain-when
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ initial-value (guard? (step ...)) ...)
|
|
#'(chain-when initial-value _ (guard? (step ...)) ...))
|
|
((_ initial-value placeholder) (identifier? #'placeholder)
|
|
#'initial-value)
|
|
((_ initial-value placeholder (guard? (step ...)) rest ...)
|
|
(let loop ((var #f) (out '()) (in #'(step ...)))
|
|
(syntax-case in ()
|
|
((u . step-rest) (id=? #'u #'placeholder)
|
|
(if var
|
|
(syntax-violation 'chain-when "only one _ allowed per step" #'(step ...))
|
|
(let ((chain-var (gentemp)))
|
|
(loop chain-var (cons chain-var out) #'step-rest))))
|
|
((x . step-rest)
|
|
(loop var (cons #'x out) #'step-rest))
|
|
(()
|
|
(with-syntax ((result (reverse out)))
|
|
#`(chain-when
|
|
#,(if var
|
|
#`(let ((#,var initial-value))
|
|
(if guard? result #,var))
|
|
#'(let ((chain-var initial-value))
|
|
(if guard? result chain-var)))
|
|
placeholder
|
|
rest ...)))))))))
|
|
|
|
(define-syntax chain-lambda
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ (step ...) ...)
|
|
#'(chain-lambda _ (... ...) (step ...) ...))
|
|
((_ placeholder (step ...) ...)
|
|
#'(chain-lambda placeholder (... ...) (step ...) ...))
|
|
((_ placeholder ellipsis (first-step ...) rest ...)
|
|
(let loop ((vars '()) (out '()) (in #'(first-step ...)))
|
|
(syntax-case in ()
|
|
((u …) (and (id=? #'u #'placeholder) (id=? #'… #'ellipsis))
|
|
(let ((chain-rest-var (gentemp)))
|
|
#`(lambda #,(if (null? vars)
|
|
chain-rest-var
|
|
#`(#,@vars . #,chain-rest-var))
|
|
(chain (apply #,@(reverse out) #,chain-rest-var) placeholder ellipsis rest ...))))
|
|
((u … . _) (and (id=? #'u #'placeholder) (id=? #'… #'ellipsis))
|
|
(syntax-violation 'chain-lambda "_ ... only allowed at end" #'(first-step ...)))
|
|
((u . step-rest) (id=? #'u #'placeholder)
|
|
(let ((chain-var (gentemp)))
|
|
(loop (cons chain-var vars) (cons chain-var out) #'step-rest)))
|
|
((… . _) (id=? #'… #'ellipsis)
|
|
(syntax-violation 'chain-lambda "misplaced ..." #'(first-step ...)))
|
|
((x . step-rest)
|
|
(loop vars (cons #'x out) #'step-rest))
|
|
(()
|
|
#`(lambda #,(reverse vars) (chain #,(reverse out) placeholder ellipsis rest ...)))))))))
|
|
|
|
(define-syntax nest
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ last) #'last)
|
|
((_ (step ...) ... last) #'(nest _ (step ...) ... last))
|
|
((_ placeholder (extra-step ...) ... (step ...) last)
|
|
(let loop ((arg #'last) (out '()) (in #'(step ...)))
|
|
(syntax-case in ()
|
|
((u . step-rest) (id=? #'u #'placeholder)
|
|
(if (eof-object? arg)
|
|
(syntax-violation 'nest "only one _ allowed per step" #'(step ...))
|
|
(loop (eof-object) (cons arg out) #'step-rest)))
|
|
((x . step-rest)
|
|
(loop arg (cons #'x out) #'step-rest))
|
|
(()
|
|
(if (eof-object? arg)
|
|
#`(nest placeholder (extra-step ...) ... #,(reverse out))
|
|
(syntax-violation 'nest "step must contain _" #'(step ...)))))))
|
|
((_ placeholder last) #'last))))
|
|
|
|
(define-syntax nest-reverse
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ first) #'first)
|
|
((_ first (step ...) ...) #'(nest-reverse first _ (step ...) ...))
|
|
((_ first placeholder (step ...) (extra-step ...) ...)
|
|
(let loop ((arg #'first) (out '()) (in #'(step ...)))
|
|
(syntax-case in ()
|
|
((u . step-rest) (id=? #'u #'placeholder)
|
|
(if (eof-object? arg)
|
|
(syntax-violation 'nest-reverse "only one _ allowed per step" #'(step ...))
|
|
(loop (eof-object) (cons arg out) #'step-rest)))
|
|
((x . step-rest)
|
|
(loop arg (cons #'x out) #'step-rest))
|
|
(()
|
|
(if (eof-object? arg)
|
|
#`(nest-reverse #,(reverse out) placeholder (extra-step ...) ...)
|
|
(syntax-violation 'nest-reverse "step must contain _" #'(step ...)))))))
|
|
((_ first placeholder) #'first))))
|