362 lines
9.1 KiB
Scheme
362 lines
9.1 KiB
Scheme
;;
|
|
;; 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))))
|
|
|
|
)
|