Changeset 14054 in project


Ignore:
Timestamp:
04/03/09 06:43:06 (11 years ago)
Author:
Kon Lovett
Message:

Save.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • release/4/srfi-41/trunk/streams-derived.scm

    r14052 r14054  
    8484     ((letrec ((TAG (stream-lambda (NAME ...) BODY0 BODY1 ...))) TAG) VAL ...))))
    8585
     86#;
    8687(define-syntax stream-match-pattern
    8788  (lambda (x)
     
    107108       #'(let ((VAR STRM) BINDING ...) BODY)))))
    108109
     110#;
     111(define-syntax stream-match-pattern
     112  (lambda (form r c)
     113    (let (($stream-null? (r 'stream-null?))
     114          ($let (r 'let))
     115          ($stream-pair? (r 'stream-pair?))
     116          ($stream-car (r 'stream-car))
     117          ($stream-cdr (r 'stream-cdr))
     118          ($stream-match-pattern (r 'stream-match-pattern)))
     119     
     120) ) )
     121
     122(define-syntax stream-match-pattern
     123  (syntax-rules ()
     124    ((stream-match-pattern STRM () (BINDING ...) BODY)
     125     (and (stream-null? STRM) (let (BINDING ...) BODY)))
     126    ((stream-match-pattern STRM (_ . REST) (BINDING ...) BODY)
     127     (and (stream-pair? STRM)
     128          (let ((STRM (stream-cdr STRM)))
     129            (stream-match-pattern STRM REST (BINDING ...) BODY))))
     130    ((stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY)
     131     (and (stream-pair? STRM)
     132          (let ((temp (stream-car STRM)) (STRM (stream-cdr STRM)))
     133            (stream-match-pattern STRM REST ((VAR temp) BINDING ...) BODY))))
     134    ((stream-match-pattern STRM _ (BINDING ...) BODY)
     135     (let (BINDING ...) BODY))
     136    ((stream-match-pattern STRM VAR (BINDING ...) BODY)
     137     (let ((VAR STRM) BINDING ...) BODY))))
     138
    109139(define-syntax stream-match-test
    110140  (syntax-rules ()
     
    122152             (else (error 'stream-match "pattern failure")))))))
    123153
     154#;
    124155(define-syntax stream-of-aux
    125156  (syntax-rules (in is)
     
    138169(define-syntax stream-of
    139170  (syntax-rules ()
     171    ((stream-of "aux" EXPR BASE)
     172     (stream-cons EXPR BASE))
     173    ((stream-of "aux" EXPR BASE (VAR in STREAM) REST ...)
     174     (stream-let loop ((strm STREAM))
     175       (if (stream-null? strm) BASE
     176           (let ((VAR (stream-car strm)))
     177             (stream-of "aux" EXPR (loop (stream-cdr strm)) REST ...)))))
     178    ((stream-of "aux" EXPR BASE (VAR is EXP) REST ...)
     179     (let ((VAR EXP)) (stream-of "aux" EXPR BASE REST ...)))
     180    ((stream-of "aux" EXPR BASE PRED? REST ...)
     181     (if PRED? (stream-of "aux" EXPR BASE REST ...) BASE))
    140182    ((stream-of EXPR REST ...)
    141      (stream-of-aux EXPR stream-null REST ...))))
     183     (stream-of "aux" EXPR stream-null REST ...))))
    142184
    143185(define (list->stream objs)
Note: See TracChangeset for help on using the changeset viewer.