diff --git a/src/util-kwargs.scm b/src/util-kwargs.scm deleted file mode 100644 index d17943e..0000000 --- a/src/util-kwargs.scm +++ /dev/null @@ -1,134 +0,0 @@ -;; -;; util-kwargs.scm -;; -;; Syntax infrastructure for kwargs procedure definitions. -;; -;; ISC License -;; -;; Copyright 2023 Dominik Pantůček -;; -;; 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 ...))))) - - )