2003-02-11 19:15:11 -05:00
|
|
|
; Copyright (c) 2003 RT Happe <rthappe at web de>
|
|
|
|
|
; See the file COPYING distributed with the Scheme Untergrund Library
|
2003-02-12 18:26:41 -05:00
|
|
|
; See README for documentation.
|
2003-02-11 19:15:11 -05:00
|
|
|
|
|
|
|
|
(define-syntax assert
|
|
|
|
|
(syntax-rules ()
|
|
|
|
|
((assert ?x)
|
|
|
|
|
(if (not ?x) (error "Assertion failed" '?x)))
|
|
|
|
|
((assert ?tag ?x)
|
|
|
|
|
(if (not ?x) (error (format #f "~a -- assertion failed" ?tag)
|
|
|
|
|
'?x)))))
|
|
|
|
|
|
|
|
|
|
|
2003-02-12 18:26:41 -05:00
|
|
|
;; RECEIVE/NAME is a multiple values analogue of named LET.
|
2003-02-11 19:15:11 -05:00
|
|
|
(define-syntax receive/name
|
|
|
|
|
(syntax-rules ()
|
|
|
|
|
((_ ?tag ?tuple ?call ?body0 ?body1 ...)
|
|
|
|
|
(letrec ((proc
|
|
|
|
|
(lambda ?tuple
|
|
|
|
|
(let-syntax
|
|
|
|
|
((?tag (syntax-rules ()
|
|
|
|
|
((?tag ?e)
|
|
|
|
|
(call-with-values (lambda () ?e)
|
|
|
|
|
(lambda ?tuple (proc . ?tuple))))
|
|
|
|
|
((?tag . ?args)
|
|
|
|
|
(proc . ?args)))))
|
|
|
|
|
?body0 ?body1 ...))))
|
|
|
|
|
(call-with-values (lambda () ?call) proc)))))
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
;; dispatch on type of the first argument
|
|
|
|
|
;; [ should we support a default clause (else ?proc) ? ]
|
|
|
|
|
(define-syntax gen-dispatch
|
|
|
|
|
(syntax-rules ()
|
|
|
|
|
((_ () ?x0 . ?rest)
|
|
|
|
|
#f)
|
|
|
|
|
((_ ((?pred ?proc) ...) ?x0 . ?rest)
|
|
|
|
|
(cond ((?pred ?x0) (?proc ?x0 . ?rest))
|
|
|
|
|
...
|
|
|
|
|
(else (error "unsupported input type" ?x0))))))
|
