odds and ends

2003-02-12 00:15:11 +00:00 · 2003-02-12 00:15:11 +00:00 · d6ac20424e
parent a6505ef990
commit d6ac20424e
2 changed files with 113 additions and 0 deletions
--- a/s48/krims/krims.scm
+++ b/s48/krims/krims.scm
@ -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))))))
--- a/s48/krims/packages.scm
+++ b/s48/krims/packages.scm
@ -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)))