From d6ac20424ea964fff902df451cd7662dd6693d21 Mon Sep 17 00:00:00 2001 From: Rolf-Thomas Happe Date: Wed, 12 Feb 2003 00:15:11 +0000 Subject: [PATCH] odds and ends --- s48/krims/krims.scm | 88 ++++++++++++++++++++++++++++++++++++++++++ s48/krims/packages.scm | 25 ++++++++++++ 2 files changed, 113 insertions(+) create mode 100644 s48/krims/krims.scm create mode 100644 s48/krims/packages.scm diff --git a/s48/krims/krims.scm b/s48/krims/krims.scm new file mode 100644 index 0000000..1a4f9fc --- /dev/null +++ b/s48/krims/krims.scm @@ -0,0 +1,88 @@ +; Copyright (c) 2003 RT Happe +; 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 ) +; [ 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)))))) diff --git a/s48/krims/packages.scm b/s48/krims/packages.scm new file mode 100644 index 0000000..15628fe --- /dev/null +++ b/s48/krims/packages.scm @@ -0,0 +1,25 @@ +; Copyright (c) 2003 RT Happe +; 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)))