Remove old util-kwargs, replace with Racket-compatible define*/lambda* forms.
This commit is contained in:
parent
d24526b765
commit
963d3069e9
6 changed files with 399 additions and 52 deletions
362
src/racket-kwargs.scm
Normal file
362
src/racket-kwargs.scm
Normal file
|
|
@ -0,0 +1,362 @@
|
|||
;;
|
||||
;; racket-kwargs.scm
|
||||
;;
|
||||
;; CHICKEN Scheme version of Racket define/lambda for procedures with
|
||||
;; mandatory and optional keyword arguments as well as positional and
|
||||
;; optional arguments anywhere in the argument list. The only
|
||||
;; limiation being that mandatory positional argument must not be
|
||||
;; specified after any optional positional argument.
|
||||
;;
|
||||
;; 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 racket-kwargs))
|
||||
|
||||
(module
|
||||
racket-kwargs
|
||||
(
|
||||
lambda*
|
||||
define*
|
||||
)
|
||||
|
||||
(import scheme
|
||||
(chicken base)
|
||||
(chicken keyword)
|
||||
(chicken syntax)
|
||||
(chicken format))
|
||||
|
||||
(begin-for-syntax
|
||||
(import (chicken keyword)))
|
||||
|
||||
;; Splits arguments into two lists: the kw-args and non-kw-args. This
|
||||
;; procedure is used during run-time to parse the procedure arguments
|
||||
;; and supply values to the argument bindings. The keyword arguments
|
||||
;; are returned in reverse order, the positional arguments are
|
||||
;; returned in the same order as given.
|
||||
(define-syntax split-kwargs
|
||||
(syntax-rules ()
|
||||
((_ name 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 'name
|
||||
"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))))))))
|
||||
|
||||
;; Conditional expansion if given term is an identifier - taken from
|
||||
;; SRFI-57 sample implementation:
|
||||
;; https://srfi.schemers.org/srfi-57/srfi-57-1.2.html
|
||||
(define-syntax if-id?
|
||||
(syntax-rules ()
|
||||
((_ (x . y) sk fk) fk)
|
||||
((_ #(x ...) sk fk) fk)
|
||||
((_ x sk fk)
|
||||
(let-syntax ((test (syntax-rules ()
|
||||
((test x sk* fk*) sk*)
|
||||
((test non-x sk* fk*) fk*))))
|
||||
(test foo sk fk)))))
|
||||
|
||||
;; Conditional expansion for quoted symbols.
|
||||
(define-syntax if-symbol?
|
||||
(syntax-rules (quote)
|
||||
((_ (quote (x . y)) sk fk) fk)
|
||||
((_ (quote x) sk fk)
|
||||
(let-syntax ((test (syntax-rules ()
|
||||
((test x sk* fk*) sk*)
|
||||
((test non-x sk* fk*) fk*))))
|
||||
(test x sk fk)))
|
||||
((_ x sk fk) fk)))
|
||||
|
||||
;; Conditional expansion if keyword is given.
|
||||
(define-syntax if-keyword?
|
||||
(ir-macro-transformer
|
||||
(lambda (e i c)
|
||||
(if (keyword? (cadr e))
|
||||
(caddr e)
|
||||
(cadddr e)))))
|
||||
|
||||
;; Conditional expansion for list expressions
|
||||
(define-syntax if-list?
|
||||
(syntax-rules ()
|
||||
((_ (w x ...) t f)
|
||||
(if-symbol? (w x ...) f t))
|
||||
((_ x t f) f)))
|
||||
|
||||
;; Expansion-time conditional expansion based on boolean constant.
|
||||
(define-syntax if-true?
|
||||
(syntax-rules ()
|
||||
((_ #f t f) f)
|
||||
((_ #t t f) t)))
|
||||
|
||||
;; Allows extracting file:line information from within syntax-rules
|
||||
;; templates.
|
||||
(define-syntax expansion-line
|
||||
(er-macro-transformer
|
||||
(lambda (e i c)
|
||||
(get-line-number e))))
|
||||
|
||||
;; Creates one binding without default value from non-kw-args list
|
||||
;; and resumes argument processing.
|
||||
(define-syntax let-id-arg*
|
||||
(syntax-rules ()
|
||||
((_ name
|
||||
seen-opt?
|
||||
(kws nkws)
|
||||
(id . rest)
|
||||
all-kws
|
||||
body ...)
|
||||
(if-true? seen-opt?
|
||||
(begin-for-syntax
|
||||
(syntax-error
|
||||
(let ((el (expansion-line id)))
|
||||
(format "~A~A~A - positional argument after optional: ~A"
|
||||
(or el "")
|
||||
(if el " " "")
|
||||
'name 'id))))
|
||||
(if (null? nkws)
|
||||
(error "not enough arguments given" 'name)
|
||||
(let ((id (car nkws)))
|
||||
(let-args** name
|
||||
seen-opt?
|
||||
(kws (cdr nkws))
|
||||
rest
|
||||
all-kws
|
||||
body ...)))))))
|
||||
|
||||
;; Creates one binding with default value.
|
||||
(define-syntax let-idd-arg*
|
||||
(syntax-rules ()
|
||||
((_ name
|
||||
seen-opt?
|
||||
(kws nkws)
|
||||
((id def) . rest)
|
||||
all-kws
|
||||
body ...)
|
||||
(let ((id (if (null? nkws)
|
||||
def
|
||||
(car nkws))))
|
||||
(let-args** name
|
||||
#t
|
||||
(kws (if (null? nkws)
|
||||
nkws
|
||||
(cdr nkws)))
|
||||
rest
|
||||
all-kws
|
||||
body ...)))))
|
||||
|
||||
;; Create bindings for mandatory and optional keyword arguments.
|
||||
(define-syntax let-kw-arg*
|
||||
(syntax-rules ()
|
||||
((_ name
|
||||
seen-opt?
|
||||
(kws nkws)
|
||||
(kw (id def) . rest)
|
||||
(all-kws ...)
|
||||
body ...)
|
||||
(let ((id (get-keyword kw kws (lambda () def))))
|
||||
(let-args** name
|
||||
seen-opt?
|
||||
(kws nkws)
|
||||
rest
|
||||
(kw all-kws ...)
|
||||
body ...)))
|
||||
((_ name
|
||||
seen-opt?
|
||||
(kws nkws)
|
||||
(kw (id . restd) . rest)
|
||||
(all-kws ...)
|
||||
body ...)
|
||||
(begin-for-syntax
|
||||
(syntax-error
|
||||
(let ((el (expansion-line name)))
|
||||
(format "~A~A~A - wrong keyword argument syntax: ~A ~A"
|
||||
(or el "")
|
||||
(if el " " "")
|
||||
'name kw '(id . restd))))))
|
||||
((_ name
|
||||
seen-opt?
|
||||
(kws nkws)
|
||||
(kw id . rest)
|
||||
(all-kws ...)
|
||||
body ...)
|
||||
(let ((id (get-keyword kw kws (lambda ()
|
||||
(error 'name "missing kw argument"
|
||||
kw)))))
|
||||
(let-args** name
|
||||
seen-opt?
|
||||
(kws nkws)
|
||||
rest
|
||||
(kw all-kws ...)
|
||||
body ...)))
|
||||
((_ name
|
||||
seen-opt?
|
||||
(kws nkws)
|
||||
(kw)
|
||||
(all-kws ...)
|
||||
body ...)
|
||||
(begin-for-syntax
|
||||
(syntax-error
|
||||
(let ((el (expansion-line name)))
|
||||
(format "~A~A~A - missing keyword argument syntax: ~A"
|
||||
(or el "")
|
||||
(if el " " "")
|
||||
'name kw)))))))
|
||||
|
||||
;; Checks whether only defined keywords are used.
|
||||
(define-syntax check-kws
|
||||
(syntax-rules ()
|
||||
((_ name (all-kws ...) kw-args)
|
||||
(let ((kws-list (list all-kws ...)))
|
||||
(let loop ((kws (let kloop ((kw-args kw-args)
|
||||
(res '()))
|
||||
(if (null? kw-args)
|
||||
res
|
||||
(kloop (cddr kw-args)
|
||||
(cons (car kw-args) res))))))
|
||||
(when (not (null? kws))
|
||||
(if (not (memq (car kws) kws-list))
|
||||
(error 'name "unknown keyword argument" (car kws))
|
||||
(loop (cdr kws)))))))))
|
||||
|
||||
;; Converts argument specifications into set of nested let bindings.
|
||||
(define-syntax let-args**
|
||||
(syntax-rules ()
|
||||
;; End, without rest
|
||||
((_ name
|
||||
seen-opt?
|
||||
(kw-args non-kw-args)
|
||||
()
|
||||
all-kws
|
||||
body ...)
|
||||
(if (null? non-kw-args)
|
||||
(let ()
|
||||
(check-kws name all-kws kw-args)
|
||||
body ...)
|
||||
(error 'name "too many arguments" non-kw-args)))
|
||||
;; Dispatch to appropriate sub-syntax
|
||||
((_ name
|
||||
seen-opt?
|
||||
(kw-args non-kw-args)
|
||||
(expr . rest)
|
||||
all-kws
|
||||
body ...)
|
||||
(if-list? expr
|
||||
(let-idd-arg* name
|
||||
seen-opt?
|
||||
(kw-args non-kw-args)
|
||||
(expr . rest)
|
||||
all-kws
|
||||
body ...)
|
||||
(if-id? expr
|
||||
(let-id-arg* name
|
||||
seen-opt?
|
||||
(kw-args non-kw-args)
|
||||
(expr . rest)
|
||||
all-kws
|
||||
body ...)
|
||||
(if-keyword? expr
|
||||
(let-kw-arg* name
|
||||
seen-opt?
|
||||
(kw-args non-kw-args)
|
||||
(expr . rest)
|
||||
all-kws
|
||||
body ...)
|
||||
(begin-for-syntax
|
||||
(syntax-error
|
||||
(let ((el (expansion-line name)))
|
||||
(format
|
||||
"~A~A~A - keyword, identifier or list required: ~A~A"
|
||||
(or el "")
|
||||
(if el " " "")
|
||||
'name
|
||||
(if-symbol? expr
|
||||
"'"
|
||||
"")
|
||||
expr))))))))
|
||||
;; End of the argspec with rest binding
|
||||
((_ name
|
||||
seen-opt?
|
||||
(kw-args non-kw-args)
|
||||
rest
|
||||
all-kws
|
||||
body ...)
|
||||
(let ((rest non-kw-args))
|
||||
(check-kws name all-kws kw-args)
|
||||
body ...))))
|
||||
|
||||
;; The outermost expression of the lambda* syntax that uses split
|
||||
;; keyword/non-keyword argument lists as source for keyword argument
|
||||
;; values lookup and positional arguments consumption.
|
||||
(define-syntax let-args*
|
||||
(syntax-rules ()
|
||||
((_ name
|
||||
(argspecs args)
|
||||
body ...)
|
||||
(let-values (((kw-args non-kw-args) (split-kwargs name args)))
|
||||
(let-args** name
|
||||
#f
|
||||
(kw-args non-kw-args)
|
||||
argspecs
|
||||
()
|
||||
body ...)))))
|
||||
|
||||
;; Named lambda-like syntax that creates a procedure that handles
|
||||
;; positional and keyword arguments separately, creating the
|
||||
;; procedure in a way that introduces appropriate bindings for the
|
||||
;; body ... expressions.
|
||||
(define-syntax lambda**
|
||||
(syntax-rules ()
|
||||
((_ (name . argspecs) body ...)
|
||||
(lambda args
|
||||
(let-args* name
|
||||
(argspecs args)
|
||||
body ...)))))
|
||||
|
||||
;; This is a wrapper around lambda** that omits
|
||||
;; actual name for error reporting.
|
||||
(define-syntax lambda*
|
||||
(syntax-rules ()
|
||||
((_ argspecs body ...)
|
||||
(lambda** (lambda* . argspecs) body ...))))
|
||||
|
||||
;; Simple wrapper that behaves like define syntax but for lambda form
|
||||
;; it uses lambda* syntax.
|
||||
(define-syntax define*
|
||||
(syntax-rules ()
|
||||
((_ (name . argspecs) body ...)
|
||||
(define name
|
||||
(lambda** (name . argspecs)
|
||||
body ...)))
|
||||
((_ i v)
|
||||
(define i v))))
|
||||
|
||||
)
|
||||
Loading…
Add table
Add a link
Reference in a new issue