39 lines
1.4 KiB
Scheme
39 lines
1.4 KiB
Scheme
(define-syntax define-opt
|
|
(syntax-rules (optional)
|
|
((define-opt (name . bindings) . bodies)
|
|
(define-opt "seek-optional" bindings () ((name . bindings) . bodies)))
|
|
|
|
((define-opt "seek-optional" ((optional . _opt-bindings))
|
|
(reqd ...) ((name . _bindings) . _bodies))
|
|
(define (name reqd ... . _rest)
|
|
(letrec-syntax
|
|
((handle-opts
|
|
(syntax-rules ()
|
|
((_ rest bodies (var init))
|
|
(let ((var (if (null? rest) init
|
|
(if (null? (cdr rest)) (car rest)
|
|
(error "extra rest" rest)))))
|
|
. bodies))
|
|
((_ rest bodies var) (handle-opts rest bodies (var #f)))
|
|
((_ rest bodies (var init) . other-vars)
|
|
(let ((var (if (null? rest) init (car rest)))
|
|
(new-rest (if (null? rest) '() (cdr rest))))
|
|
(handle-opts new-rest bodies . other-vars)))
|
|
((_ rest bodies var . other-vars)
|
|
(handle-opts rest bodies (var #f) . other-vars))
|
|
((_ rest bodies) ; no optional args, unlikely
|
|
(let ((_ (or (null? rest) (error "extra rest" rest))))
|
|
. bodies)))))
|
|
(handle-opts _rest _bodies . _opt-bindings))))
|
|
|
|
((define-opt "seek-optional" (x . rest) (reqd ...) form)
|
|
(define-opt "seek-optional" rest (reqd ... x) form))
|
|
|
|
((define-opt "seek-optional" not-a-pair reqd form)
|
|
(define . form)) ; No optional found, regular define
|
|
|
|
((define-opt name body) ; Just the definition for 'name',
|
|
(define name body)) ; for compatibilibility with define
|
|
))
|
|
|