57 lines
2.0 KiB
Scheme
57 lines
2.0 KiB
Scheme
;;;; Definitions of macros
|
|
|
|
;;; From SRFI 8
|
|
(define-syntax receive
|
|
(syntax-rules ()
|
|
((receive formals expression body ...)
|
|
(call-with-values (lambda () expression)
|
|
(lambda formals body ...)))))
|
|
|
|
;;; Shivers-compatible let-optionals*
|
|
;;; This version from Scheme-48 1.9.2,
|
|
;;; using error instead of assertion-violation
|
|
(define-syntax let-optionals*
|
|
(syntax-rules ()
|
|
((let-optionals* arg (opt-clause ...) body ...)
|
|
(let ((rest arg))
|
|
(%let-optionals* rest (opt-clause ...) body ...)))))
|
|
|
|
(define-syntax %let-optionals*
|
|
(syntax-rules ()
|
|
((%let-optionals* arg (((var ...) xparser) opt-clause ...) body ...)
|
|
(call-with-values (lambda () (xparser arg))
|
|
(lambda (rest var ...)
|
|
(%let-optionals* rest (opt-clause ...) body ...))))
|
|
|
|
((%let-optionals* arg ((var default) opt-clause ...) body ...)
|
|
(call-with-values (lambda () (if (null? arg) (values default '())
|
|
(values (car arg) (cdr arg))))
|
|
(lambda (var rest)
|
|
(%let-optionals* rest (opt-clause ...) body ...))))
|
|
|
|
((%let-optionals* arg ((var default test) opt-clause ...) body ...)
|
|
(call-with-values (lambda ()
|
|
(if (null? arg) (values default '())
|
|
(let ((var (car arg)))
|
|
(if test (values var (cdr arg))
|
|
(error "arg failed LET-OPT test" var)))))
|
|
(lambda (var rest)
|
|
(%let-optionals* rest (opt-clause ...) body ...))))
|
|
|
|
((%let-optionals* arg ((var default test supplied?) opt-clause ...) body ...)
|
|
(call-with-values (lambda ()
|
|
(if (null? arg) (values default #f '())
|
|
(let ((var (car arg)))
|
|
(if test (values var #t (cdr arg))
|
|
(error "arg failed LET-OPT test" var)))))
|
|
(lambda (var supplied? rest)
|
|
(%let-optionals* rest (opt-clause ...) body ...))))
|
|
|
|
((%let-optionals* arg (rest) body ...)
|
|
(let ((rest arg)) body ...))
|
|
|
|
((%let-optionals* arg () body ...)
|
|
(if (null? arg) (begin body ...)
|
|
(error "Too many arguments in let-opt" arg)))))
|
|
|