Remove old util-kwargs.
This commit is contained in:
parent
d6be9ece08
commit
64ec7f3d69
1 changed files with 0 additions and 134 deletions
|
@ -1,134 +0,0 @@
|
||||||
;;
|
|
||||||
;; util-kwargs.scm
|
|
||||||
;;
|
|
||||||
;; Syntax infrastructure for kwargs procedure definitions.
|
|
||||||
;;
|
|
||||||
;; ISC License
|
|
||||||
;;
|
|
||||||
;; Copyright 2023 Dominik Pantůček <dominik.pantucek@trustica.cz>
|
|
||||||
;;
|
|
||||||
;; Permission to use, copy, modify, and/or distribute this software
|
|
||||||
;; for any purpose with or without fee is hereby granted, provided
|
|
||||||
;; that the above copyright notice and this permission notice appear
|
|
||||||
;; in all copies.
|
|
||||||
;;
|
|
||||||
;; THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL
|
|
||||||
;; WARRANTIES WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED
|
|
||||||
;; WARRANTIES OF MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE
|
|
||||||
;; AUTHOR BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR
|
|
||||||
;; CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS
|
|
||||||
;; OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT,
|
|
||||||
;; NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN
|
|
||||||
;; CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.
|
|
||||||
;;
|
|
||||||
|
|
||||||
(declare (unit util-kwargs))
|
|
||||||
|
|
||||||
(module
|
|
||||||
util-kwargs
|
|
||||||
(
|
|
||||||
define-kwproc
|
|
||||||
let-kwargs*
|
|
||||||
let-kwargs**
|
|
||||||
split-kwargs
|
|
||||||
)
|
|
||||||
(import scheme
|
|
||||||
(chicken base)
|
|
||||||
(chicken keyword))
|
|
||||||
|
|
||||||
;; Splits arguments into two lists: the kw-args and non-kw-args
|
|
||||||
(define (split-kwargs args)
|
|
||||||
(let loop ((args args)
|
|
||||||
(kw-args '())
|
|
||||||
(non-kw-args '()))
|
|
||||||
(if (null? args)
|
|
||||||
(values kw-args
|
|
||||||
(reverse non-kw-args))
|
|
||||||
(if (keyword? (car args))
|
|
||||||
(if (null? (cdr args))
|
|
||||||
(error 'split-kwargs "missing keyword pair" (car args))
|
|
||||||
(loop (cddr args)
|
|
||||||
(cons (car args)
|
|
||||||
(cons (cadr args)
|
|
||||||
kw-args))
|
|
||||||
non-kw-args))
|
|
||||||
(loop (cdr args)
|
|
||||||
kw-args
|
|
||||||
(cons (car args) non-kw-args))))))
|
|
||||||
|
|
||||||
;; Parses all the variants of keyword and positional arguments in the
|
|
||||||
;; list.
|
|
||||||
(define-syntax let-kwargs**
|
|
||||||
(syntax-rules ()
|
|
||||||
;; End, without rest
|
|
||||||
((_ name
|
|
||||||
(kw-args non-kw-args)
|
|
||||||
()
|
|
||||||
expr ...)
|
|
||||||
(if (null? non-kw-args)
|
|
||||||
(let ()
|
|
||||||
expr ...)
|
|
||||||
(error 'name "too many arguments" non-kw-args)))
|
|
||||||
;; Explicit default for kw-arg
|
|
||||||
((_ name
|
|
||||||
(kw-args non-kw-args)
|
|
||||||
((kw binding) . rest)
|
|
||||||
expr ...)
|
|
||||||
(let-kwargs** name
|
|
||||||
(kw-args non-kw-args)
|
|
||||||
((kw binding #f) . rest)
|
|
||||||
expr ...))
|
|
||||||
;; A kw-args with default
|
|
||||||
((_ name
|
|
||||||
(kw-args non-kw-args)
|
|
||||||
((kw binding default) . rest)
|
|
||||||
expr ...)
|
|
||||||
(let ((binding (get-keyword kw kw-args (lambda () default))))
|
|
||||||
(let-kwargs** name
|
|
||||||
(kw-args non-kw-args)
|
|
||||||
rest
|
|
||||||
expr ...)))
|
|
||||||
;; Positional argument
|
|
||||||
((_ name
|
|
||||||
(kw-args non-kw-args)
|
|
||||||
(binding . rest)
|
|
||||||
expr ...)
|
|
||||||
(let ((binding (if (null? non-kw-args)
|
|
||||||
(error 'name "not enough arguments" non-kw-args)
|
|
||||||
(car non-kw-args)))
|
|
||||||
(cdr-non-kw-args (cdr non-kw-args)))
|
|
||||||
(let-kwargs** name
|
|
||||||
(kw-args cdr-non-kw-args)
|
|
||||||
rest
|
|
||||||
expr ...)))
|
|
||||||
;; Rest argument
|
|
||||||
((_ name
|
|
||||||
(kw-args non-kw-args)
|
|
||||||
rest
|
|
||||||
expr ...)
|
|
||||||
(let ((rest non-kw-args))
|
|
||||||
expr ...))))
|
|
||||||
|
|
||||||
;; Simple wrapper to separate the kw/non-kw lists and pass it on to
|
|
||||||
;; further parsing
|
|
||||||
(define-syntax let-kwargs*
|
|
||||||
(syntax-rules ()
|
|
||||||
((_ name
|
|
||||||
((binding . rest) args)
|
|
||||||
expr ...)
|
|
||||||
(let-values (((kw-args non-kw-args) (split-kwargs args)))
|
|
||||||
(let-kwargs** name
|
|
||||||
(kw-args non-kw-args)
|
|
||||||
(binding . rest)
|
|
||||||
expr ...)))))
|
|
||||||
|
|
||||||
;; Convenience syntax for defining kwargs functions
|
|
||||||
(define-syntax define-kwproc
|
|
||||||
(syntax-rules ()
|
|
||||||
((_ (name . argspec) expr ...)
|
|
||||||
(define (name . args)
|
|
||||||
(let-kwargs* name
|
|
||||||
(argspec args)
|
|
||||||
expr ...)))))
|
|
||||||
|
|
||||||
)
|
|
Loading…
Add table
Add a link
Reference in a new issue