Changeset 14069 in project


Ignore:
Timestamp:
04/04/09 05:12:47 (11 years ago)
Author:
Kon Lovett
Message:

Test. Sort of.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/expand-full/trunk/tests/run.scm

    r14068 r14069  
     1(require-extension expand-full)
     2
     3(define-syntax stream-match-pattern
     4  (syntax-rules (_)
     5    ((stream-match-pattern STRM () (BINDING ...) BODY)
     6     (and (stream-null? STRM) (let (BINDING ...) BODY)))
     7    ((stream-match-pattern STRM (_ . REST) (BINDING ...) BODY)
     8     (and (stream-pair? STRM)
     9          (let ((STRM (stream-cdr STRM)))
     10            (stream-match-pattern STRM REST (BINDING ...) BODY))))
     11    ((stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY)
     12     (and (stream-pair? STRM)
     13          (let ((temp (stream-car STRM)) (STRM (stream-cdr STRM)))
     14            (stream-match-pattern STRM REST ((VAR temp) BINDING ...) BODY))))
     15    ((stream-match-pattern STRM _ (BINDING ...) BODY)
     16     (let (BINDING ...) BODY))
     17    ((stream-match-pattern STRM VAR (BINDING ...) BODY)
     18     (let ((VAR STRM) BINDING ...) BODY))))
     19
     20(define-syntax stream-match-test
     21  (syntax-rules ()
     22    ((stream-match-test STRM (PATTERN FENDER EXPR))
     23     (stream-match-pattern STRM PATTERN () (and FENDER (list EXPR))))
     24    ((stream-match-test STRM (PATTERN EXPR))
     25     (stream-match-pattern STRM PATTERN () (list EXPR)))))
     26
     27(define-syntax stream-match
     28  (syntax-rules ()
     29    ((stream-match STRM-EXPR CLAUSE ...)
     30     (let ((strm STRM-EXPR))
     31       (cond ((not (stream? strm)) (error-invalid-stream 'stream-match strm))
     32             ((stream-match-test strm CLAUSE) => car) ...
     33             (else (error 'stream-match "pattern failure")))))))
     34
     35(ppexpand*
     36  '(stream-match yy
     37    (() (stream (stream x)))
     38    ((y . ys)
     39      (stream-append
     40        (stream (stream-cons x yy))
     41        (stream-map (lambda (z) (stream-cons y z))
     42                    (stream-intersperse ys x))))) )
Note: See TracChangeset for help on using the changeset viewer.