odds and ends
This commit is contained in:
Rolf-Thomas Happe
parent
a6505ef990
commit
d6ac20424e
|
|
@ -0,0 +1,88 @@
|
||||||
|
; Copyright (c) 2003 RT Happe <rthappe at web de>
|
||||||
|
; See the file COPYING distributed with the Scheme Untergrund Library
|
||||||
|
|
||||||
|
; Odds and Ends
|
||||||
|
; that haven't found a natural place, yet.
|
||||||
|
;
|
||||||
|
; Synopses
|
||||||
|
;
|
||||||
|
; (assert [id] exp) ; syntax
|
||||||
|
; If not EXP signal an error with suitable message. The optional
|
||||||
|
; ID may be any printable object, e.g. a symbol naming the enclosing
|
||||||
|
; procedure. [ This could be done with a procedure, but ASSERT being
|
||||||
|
; a macro, we can redefine it as the trivial form that doesn't evaluate
|
||||||
|
; its parameters. ]
|
||||||
|
;
|
||||||
|
; (receive/name loop formals exp form0 ...) ; syntax
|
||||||
|
; Bind LOOP to a macro wrapped around the procedure LUP with parameter
|
||||||
|
; list FORMALS and body FORM0 ... so that
|
||||||
|
; * (LOOP multi-valued-expression) calls LUP with the values of
|
||||||
|
; multi-valued-expression , and
|
||||||
|
; * (LOOP exp0 ...) becomes (LUP exp0 ...)
|
||||||
|
;
|
||||||
|
; (gen-dispatch ((predicate action) ...) e0 e1 ... en) ; syntax
|
||||||
|
; Dispatch action on type of first argument E0: feed E0 ... EN to the
|
||||||
|
; first action such that the PREDICATE holds for E0. Signal an error
|
||||||
|
; if nothing goes.
|
||||||
|
|
||||||
|
|
||||||
|
(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)))))
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
; RECEIVE/NAME is a multiple values analogue of named LET.
|
||||||
|
; Syntax: (receive/name <identifier> <formals> <expression> <body>)
|
||||||
|
; [ non-terminals as in R5RS ]
|
||||||
|
; Semantics: (receive/name loop (x y) exp0 ; yes, it's a special case
|
||||||
|
; ... (loop exp1) ...)
|
||||||
|
; is eqv to
|
||||||
|
; (receive (x y) exp0
|
||||||
|
; (let lup ((x x) (y y))
|
||||||
|
; ... (receive (x y) exp1
|
||||||
|
; (lup x y)) ...))
|
||||||
|
;
|
||||||
|
; And (receive/name loop (x y) exp0
|
||||||
|
; ... (loop exp1 exp1) ...)
|
||||||
|
; is eqv to
|
||||||
|
; (receive (x y) exp0
|
||||||
|
; (let lup ((x x) (y y))
|
||||||
|
; ... (lup exp1 exp2) ...))
|
||||||
|
;
|
||||||
|
; Absurd example:
|
||||||
|
; (define (shove n xs) (values (- n 1) (cons n xs)))
|
||||||
|
; (receive/name loop (n xs) (values 7 '())
|
||||||
|
; (if (= n 0)
|
||||||
|
; (display xs)
|
||||||
|
; (loop (shove n xs))))
|
||||||
|
(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))))))
|
||||||
|
|
@ -0,0 +1,25 @@
|
||||||
|
; Copyright (c) 2003 RT Happe <rthappe at web de>
|
||||||
|
; See the file COPYING distributed with the Scheme Untergrund Library
|
||||||
|
|
||||||
|
;; odds and ends
|
||||||
|
(define-structure krims
|
||||||
|
(export (assert :syntax)
|
||||||
|
(receive/name :syntax)
|
||||||
|
(gen-dispatch :syntax))
|
||||||
|
(open srfi-28 ; format
|
||||||
|
srfi-23 ; error
|
||||||
|
scheme)
|
||||||
|
(files krims))
|
||||||
|
|
||||||
|
;; srfi-9 + define-record-discloser
|
||||||
|
(define-structure srfi-9+
|
||||||
|
(export (define-record-type :syntax)
|
||||||
|
define-record-discloser)
|
||||||
|
(open scheme-level-2
|
||||||
|
(with-prefix define-record-types sys:))
|
||||||
|
(begin
|
||||||
|
(define-syntax define-record-type
|
||||||
|
(syntax-rules ()
|
||||||
|
((define-record-type type-name . stuff)
|
||||||
|
(sys:define-record-type type-name type-name . stuff))))
|
||||||
|
(define define-record-discloser sys:define-record-discloser)))
|
||||||
Loading…
Reference in New Issue