Changeset 8493 in project


Ignore:
Timestamp:
02/16/08 01:17:34 (12 years ago)
Author:
Kon Lovett
Message:

Use of inline, UPPERCASE macro arg names. Added arg to error.

Location:
release/3/srfi-41
Files:
6 edited

Legend:

Unmodified
Added
Removed
  • release/3/srfi-41/tags/1.0/srfi-41-support.scm

    r8342 r8493  
    6767;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (streams primitive)
    6868
    69 (define-record-type srfi-41-stream
     69(define-record-type stream
    7070  (##srfi-41#make-stream box)
    7171  stream?
    72   (box stream-promise stream-promise!))
     72  (box stream-promise stream-promise-set!))
    7373
    7474(define (##srfi-41#stream-eager expr)
    75   (##srfi-41#make-stream
    76     (cons 'eager expr)))
     75  (##srfi-41#make-stream (cons 'eager expr)))
    7776
    7877(define (stream-force promise)
     
    8584                     (begin (set-car! content (car (stream-promise promise*)))
    8685                            (set-cdr! content (cdr (stream-promise promise*)))
    87                             (stream-promise! promise* content)))
     86                            (stream-promise-set! promise* content)))
    8887                 (stream-force promise))))))
    8988
    9089(define stream-null (##srfi-41#stream-delay (cons 'stream 'null)))
    9190
    92 (define-record-type srfi-41-stream-pare
     91(define-record-type stream-pare
    9392  (##srfi-41#make-stream-pare kar kdr)
    9493  stream-pare?
     
    105104
    106105(define (stream-car strm)
    107   (cond ((not (stream? strm)) (error 'stream-car "non-stream"))
    108         ((stream-null? strm) (error 'stream-car "null stream"))
     106  (cond ((not (stream? strm)) (error 'stream-car "non-stream" strm))
     107        ((stream-null? strm) (error 'stream-car "null stream" strm))
    109108        (else (stream-force (stream-kar (stream-force strm))))))
    110109
    111110(define (stream-cdr strm)
    112   (cond ((not (stream? strm)) (error 'stream-cdr "non-stream"))
    113         ((stream-null? strm) (error 'stream-cdr "null stream"))
     111  (cond ((not (stream? strm)) (error 'stream-cdr "non-stream" strm))
     112        ((stream-null? strm) (error 'stream-cdr "null stream" strm))
    114113        (else (stream-kdr (stream-force strm)))))
    115114
    116115;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (streams derived)
    117116
    118 (define (exists pred? . lists)
    119   (and (not (null? (car lists)))
    120        (or (apply pred? (map car lists))
    121            (apply exists pred? (map cdr lists)))))
     117(define-inline ($exists pred? . lists)
     118  (let loop ([lists lists])
     119    (and (not (null? (car lists)))
     120         (or (apply pred? (map car lists))
     121             (loop (map cdr lists)) ) ) ) )
    122122
    123123(define (list->stream objs)
     
    128128          (stream-cons (car objs) (list->stream (cdr objs))))))
    129129  (if (not (list? objs))
    130       (error 'list->stream "non-list argument")
     130      (error 'list->stream "non-list argument" objs)
    131131      (list->stream objs)))
    132132
     
    140140  (let ((p (if (null? port) (current-input-port) (car port))))
    141141    (if (not (input-port? p))
    142         (error 'port->stream "non-input-port argument")
     142        (error 'port->stream "non-input-port argument" p)
    143143        (port->stream p))))
    144144
     
    146146  (let ((n (if (= 1 (length args)) #f (car args)))
    147147        (strm (if (= 1 (length args)) (car args) (cadr args))))
    148     (cond ((not (stream? strm)) (error 'stream->list "non-stream argument"))
    149           ((and n (not (integer? n))) (error 'stream->list "non-integer count"))
    150           ((and n (negative? n)) (error 'stream->list "negative count"))
     148    (cond ((not (stream? strm)) (error 'stream->list "non-stream argument" strm))
     149          ((and n (not (integer? n))) (error 'stream->list "non-integer count" n))
     150          ((and n (negative? n)) (error 'stream->list "negative count" n))
    151151          (else (let loop ((n (if n n -1)) (strm strm))
    152152                  (if (or (zero? n) (stream-null? strm))
     
    162162                               (stream-append (cons (stream-cdr (car strms)) (cdr strms))))))))
    163163  (cond ((null? strms) stream-null)
    164         ((exists (lambda (x) (not (stream? x))) strms)
    165           (error 'stream-append "non-stream argument"))
     164        (($exists (lambda (x) (not (stream? x))) strms)
     165          (error 'stream-append "non-stream argument" strms))
    166166        (else (stream-append strms))))
    167167
     
    171171      (cond ((stream-null? strms) stream-null)
    172172            ((not (stream? (stream-car strms)))
    173               (error 'stream-concat "non-stream object in input stream"))
     173              (error 'stream-concat "non-stream object in input stream" strms))
    174174            ((stream-null? (stream-car strms))
    175175              (stream-concat (stream-cdr strms)))
     
    179179                      (stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms))))))))
    180180  (if (not (stream? strms))
    181       (error 'stream-concat "non-stream argument")
     181      (error 'stream-concat "non-stream argument" strms)
    182182      (stream-concat strms)))
    183183
     
    195195          strm
    196196          (stream-drop (- n 1) (stream-cdr strm)))))
    197   (cond ((not (integer? n)) (error 'stream-drop "non-integer argument"))
    198         ((negative? n) (error 'stream-drop "negative argument"))
    199         ((not (stream? strm)) (error 'stream-drop "non-stream argument"))
     197  (cond ((not (integer? n)) (error 'stream-drop "non-integer argument" n))
     198        ((negative? n) (error 'stream-drop "negative argument" n))
     199        ((not (stream? strm)) (error 'stream-drop "non-stream argument" strm))
    200200        (else (stream-drop n strm))))
    201201
     
    206206          (stream-drop-while (stream-cdr strm))
    207207          strm)))
    208   (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument"))
    209         ((not (stream? strm)) (error 'stream-drop-while "non-stream argument"))
     208  (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument" pred?))
     209        ((not (stream? strm)) (error 'stream-drop-while "non-stream argument" strm))
    210210        (else (stream-drop-while strm))))
    211211
     
    217217              (stream-cons (stream-car strm) (stream-filter (stream-cdr strm))))
    218218            (else (stream-filter (stream-cdr strm))))))
    219   (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument"))
    220         ((not (stream? strm)) (error 'stream-filter "non-stream argument"))
     219  (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument" pred?))
     220        ((not (stream? strm)) (error 'stream-filter "non-stream argument" strm))
    221221        (else (stream-filter strm))))
    222222
    223223(define (stream-fold proc base strm)
    224   (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument"))
    225         ((not (stream? strm)) (error 'stream-fold "non-stream argument"))
     224  (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument" proc))
     225        ((not (stream? strm)) (error 'stream-fold "non-stream argument" strm))
    226226        (else (let loop ((base base) (strm strm))
    227227                (if (stream-null? strm)
     
    231231(define (stream-for-each proc . strms)
    232232  (define (stream-for-each strms)
    233     (if (not (exists stream-null? strms))
     233    (if (not ($exists stream-null? strms))
    234234        (begin (apply proc (map stream-car strms))
    235235               (stream-for-each (map stream-cdr strms)))))
    236   (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument"))
    237         ((null? strms) (error 'stream-for-each "no stream arguments"))
    238         ((exists (lambda (x) (not (stream? x))) strms)
    239           (error 'stream-for-each "non-stream argument"))
     236  (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument" proc))
     237        ((null? strms) (error 'stream-for-each "no stream arguments" strms))
     238        (($exists (lambda (x) (not (stream? x))) strms)
     239          (error 'stream-for-each "non-stream argument" strms))
    240240        (else (stream-for-each strms))))
    241241
     
    245245      (stream-cons first (stream-from (+ first delta) delta))))
    246246  (let ((delta (if (null? step) 1 (car step))))
    247     (cond ((not (number? first)) (error 'stream-from "non-numeric starting number"))
    248           ((not (number? delta)) (error 'stream-from "non-numeric step size"))
     247    (cond ((not (number? first)) (error 'stream-from "non-numeric starting number" first))
     248          ((not (number? delta)) (error 'stream-from "non-numeric step size" delta))
    249249          (else (stream-from first delta)))))
    250250
     
    254254      (stream-cons base (stream-iterate (proc base)))))
    255255  (if (not (procedure? proc))
    256       (error 'stream-iterate "non-procedural argument")
     256      (error 'stream-iterate "non-procedural argument" proc)
    257257      (stream-iterate base)))
    258258
    259259(define (stream-length strm)
    260260  (if (not (stream? strm))
    261       (error 'stream-length "non-stream argument")
     261      (error 'stream-length "non-stream argument" strm)
    262262      (let loop ((len 0) (strm strm))
    263263        (if (stream-null? strm)
     
    268268  (define stream-map
    269269    (stream-lambda (strms)
    270       (if (exists stream-null? strms)
     270      (if ($exists stream-null? strms)
    271271          stream-null
    272272          (stream-cons (apply proc (map stream-car strms))
    273273                       (stream-map (map stream-cdr strms))))))
    274   (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument"))
    275         ((null? strms) (error 'stream-map "no stream arguments"))
    276         ((exists (lambda (x) (not (stream? x))) strms)
    277           (error 'stream-map "non-stream argument"))
     274  (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument" proc))
     275        ((null? strms) (error 'stream-map "no stream arguments" strms))
     276        (($exists (lambda (x) (not (stream? x))) strms)
     277          (error 'stream-map "non-stream argument" strms))
    278278        (else (stream-map strms))))
    279279
     
    284284          (stream-cons first (stream-range (+ first delta) past delta lt?))
    285285          stream-null)))
    286   (cond ((not (number? first)) (error 'stream-range "non-numeric starting number"))
    287         ((not (number? past)) (error 'stream-range "non-numeric ending number"))
     286  (cond ((not (number? first)) (error 'stream-range "non-numeric starting number" first))
     287        ((not (number? past)) (error 'stream-range "non-numeric ending number" past))
    288288        (else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
    289289                (if (not (number? delta))
    290                     (error 'stream-range "non-numeric step size")
     290                    (error 'stream-range "non-numeric step size" delta)
    291291                    (let ((lt? (if (< 0 delta) < >)))
    292292                      (stream-range first past delta lt?)))))))
    293293
    294294(define (stream-ref strm n)
    295   (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument"))
    296         ((not (integer? n)) (error 'stream-ref "non-integer argument"))
    297         ((negative? n) (error 'stream-ref "negative argument"))
     295  (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument" strm))
     296        ((not (integer? n)) (error 'stream-ref "non-integer argument" n))
     297        ((negative? n) (error 'stream-ref "negative argument" n))
    298298        (else (let loop ((strm strm) (n n))
    299                 (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream"))
     299                (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream" strm))
    300300                      ((zero? n) (stream-car strm))
    301301                      (else (loop (stream-cdr strm) (- n 1))))))))
     
    308308          (stream-reverse (stream-cdr strm) (stream-cons (stream-car strm) rev)))))
    309309  (if (not (stream? strm))
    310       (error 'stream-reverse "non-stream argument")
     310      (error 'stream-reverse "non-stream argument" strm)
    311311      (stream-reverse strm stream-null)))
    312312
     
    317317          (stream base)
    318318          (stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm))))))
    319   (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument"))
    320         ((not (stream? strm)) (error 'stream-scan "non-stream argument"))
     319  (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument" proc))
     320        ((not (stream? strm)) (error 'stream-scan "non-stream argument" strm))
    321321        (else (stream-scan base strm))))
    322322
     
    327327          stream-null
    328328          (stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm))))))
    329   (cond ((not (stream? strm)) (error 'stream-take "non-stream argument"))
    330         ((not (integer? n)) (error 'stream-take "non-integer argument"))
    331         ((negative? n) (error 'stream-take "negative argument"))
     329  (cond ((not (stream? strm)) (error 'stream-take "non-stream argument" strm))
     330        ((not (integer? n)) (error 'stream-take "non-integer argument" n))
     331        ((negative? n) (error 'stream-take "negative argument" n))
    332332        (else (stream-take n strm))))
    333333
     
    339339              (stream-cons (stream-car strm) (stream-take-while (stream-cdr strm))))
    340340            (else stream-null))))
    341   (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument"))
    342         ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument"))
     341  (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument" strm))
     342        ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument" pred?))
    343343        (else (stream-take-while strm))))
    344344
     
    349349          (stream-cons (mapper base) (stream-unfold (generator base)))
    350350          stream-null)))
    351   (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper"))
    352         ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?"))
    353         ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator"))
     351  (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper" mapper))
     352        ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?" pred?))
     353        ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator" generator))
    354354        (else (stream-unfold base))))
    355355
     
    375375                (result-stream->output-stream (stream-cdr result-stream) i))
    376376              ((null? result) stream-null)
    377               (else (error 'stream-unfolds "can't happen"))))))
     377              (else (error 'stream-unfolds "cannot happen" result))))))
    378378  (define (result-stream->output-streams result-stream)
    379379    (let loop ((i (len-values gen seed)) (outputs '()))
     
    382382          (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs)))))
    383383  (if (not (procedure? gen))
    384       (error 'stream-unfolds "non-procedural argument")
     384      (error 'stream-unfolds "non-procedural argument" gen)
    385385      (result-stream->output-streams (unfold-result-stream gen seed))))
    386386
     
    388388  (define stream-zip
    389389    (stream-lambda (strms)
    390       (if (exists stream-null? strms)
     390      (if ($exists stream-null? strms)
    391391          stream-null
    392392          (stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms))))))
    393   (cond ((null? strms) (error 'stream-zip "no stream arguments"))
    394         ((exists (lambda (x) (not (stream? x))) strms)
    395           (error 'stream-zip "non-stream argument"))
     393  (cond ((null? strms) (error 'stream-zip "no stream arguments" strms))
     394        (($exists (lambda (x) (not (stream? x))) strms)
     395          (error 'stream-zip "non-stream argument" strms))
    396396        (else (stream-zip strms))))
  • release/3/srfi-41/tags/1.0/srfi-41.scm

    r8342 r8493  
    2020(cond-expand
    2121
    22   (syntax-case
     22  [syntax-case
    2323
    2424    (define-syntax ##srfi-41#stream-lazy
    2525      (syntax-rules ()
    26         ((##srfi-41#stream-lazy expr)
    27           (##srfi-41#make-stream
    28             (cons 'lazy (lambda () expr))))))
     26        ((##srfi-41#stream-lazy EXPR)
     27         (##srfi-41#make-stream (cons 'lazy (lambda () EXPR))))))
    2928
    3029    (define-syntax ##srfi-41#stream-delay
    3130      (syntax-rules ()
    32         ((##srfi-41#stream-delay expr)
    33           (##srfi-41#stream-lazy (##srfi-41#stream-eager expr)))))
     31        ((##srfi-41#stream-delay EXPR)
     32         (##srfi-41#stream-lazy (##srfi-41#stream-eager EXPR)))))
    3433
    3534    (define-syntax stream-cons
    3635      (syntax-rules ()
    37         ((stream-cons obj strm)
    38           (##srfi-41#stream-eager (##srfi-41#make-stream-pare (##srfi-41#stream-delay obj) (##srfi-41#stream-lazy strm))))))
     36        ((stream-cons OBJ STRM)
     37         (##srfi-41#stream-eager
     38          (##srfi-41#make-stream-pare (##srfi-41#stream-delay OBJ)
     39                                      (##srfi-41#stream-lazy STRM))))))
    3940
    4041    (define-syntax stream-lambda
    4142      (syntax-rules ()
    42         ((stream-lambda formals body0 body1 ...)
    43           (lambda formals (##srfi-41#stream-lazy (let () body0 body1 ...)))))) )
    44 
    45   (else
    46 
    47     (define-macro (##srfi-41#stream-lazy expr)
    48       `(##srfi-41#make-stream
    49          (cons 'lazy (lambda () ,expr))))
    50 
    51     (define-macro (##srfi-41#stream-delay expr)
    52       `(##srfi-41#stream-lazy (##srfi-41#stream-eager ,expr)))
    53 
    54     (define-macro (stream-cons obj strm)
    55       `(##srfi-41#stream-eager (##srfi-41#make-stream-pare (##srfi-41#stream-delay ,obj) (##srfi-41#stream-lazy ,strm))))
    56  
    57     (define-macro (stream-lambda formals . body)
    58       `(lambda ,formals (##srfi-41#stream-lazy (let () ,@body)))) ) )
     43        ((stream-lambda FORMALS BODY0 BODY1 ...)
     44         (lambda FORMALS (##srfi-41#stream-lazy (let () BODY0 BODY1 ...)))))) ]
     45
     46  [else
     47
     48    (define-macro (##srfi-41#stream-lazy EXPR)
     49      `(##srfi-41#make-stream (cons 'lazy (lambda () ,EXPR))) )
     50
     51    (define-macro (##srfi-41#stream-delay EXPR)
     52      `(##srfi-41#stream-lazy (##srfi-41#stream-eager ,EXPR)) )
     53
     54    (define-macro (stream-cons OBJ STRM)
     55      `(##srfi-41#stream-eager
     56        (##srfi-41#make-stream-pare (##srfi-41#stream-delay ,OBJ)
     57                                    (##srfi-41#stream-lazy ,STRM))) )
     58
     59    (define-macro (stream-lambda FORMALS . BODY)
     60      `(lambda ,FORMALS (##srfi-41#stream-lazy (let () ,@BODY))) ) ] )
    5961
    6062;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (streams derived)
     
    6264(cond-expand
    6365
    64   (syntax-case
     66  [syntax-case
    6567
    6668    (define-syntax define-stream
    6769      (syntax-rules ()
    68         ((define-stream (name . formal) body0 body1 ...)
    69           (define name (stream-lambda formal body0 body1 ...)))))
     70        ((define-stream (NAME . FORMAL) BODY0 BODY1 ...)
     71         (define NAME (stream-lambda FORMAL BODY0 BODY1 ...)))))
    7072
    7173    (define-syntax stream
    7274      (syntax-rules ()
    73         ((stream) stream-null)
    74         ((stream x y ...) (stream-cons x (stream y ...)))))
     75        ((stream)
     76         stream-null)
     77        ((stream X Y ...)
     78         (stream-cons X (stream Y ...)))))
    7579
    7680    (define-syntax stream-let
    7781      (syntax-rules ()
    78         ((stream-let tag ((name val) ...) body1 body2 ...)
    79          ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))))
     82        ((stream-let TAG ((NAME VAL) ...) BODY0 BODY1 ...)
     83         ((letrec ((TAG (stream-lambda (NAME ...) BODY0 BODY1 ...))) TAG) VAL ...))))
    8084
    8185    (define-syntax stream-match
    8286      (syntax-rules ()
    83         ((stream-match strm-expr clause ...)
    84           (let ((strm strm-expr))
    85             (cond ((not (stream? strm)) (error 'stream-match "non-stream argument"))
    86                   ((stream-match-test strm clause) => car) ...
    87                   (else (error 'stream-match "pattern failure")))))))
     87        ((stream-match STRM-EXPR CLAUSE ...)
     88         (let ((strm STRM-EXPR))
     89           (cond ((not (stream? strm)) (error 'stream-match "non-stream argument"))
     90                 ((stream-match-test strm CLAUSE) => car) ...
     91                 (else (error 'stream-match "pattern failure")))))))
    8892
    8993    (define-syntax stream-match-test
    9094      (syntax-rules ()
    91         ((stream-match-test strm (pattern fender expr))
    92           (stream-match-pattern strm pattern () (and fender (list expr))))
    93         ((stream-match-test strm (pattern expr))
    94           (stream-match-pattern strm pattern () (list expr)))))
     95        ((stream-match-test STRM (PATTERN FENDER EXPR))
     96         (stream-match-pattern STRM PATTERN () (and FENDER (list EXPR))))
     97        ((stream-match-test STRM (PATTERN EXPR))
     98         (stream-match-pattern STRM PATTERN () (list EXPR)))))
    9599
    96100    (define-syntax stream-match-pattern
     
    100104               (free-identifier=? x (syntax _))))
    101105        (syntax-case x ()
    102           ((stream-match-pattern strm () (binding ...) body)
    103             (syntax (and (stream-null? strm) (let (binding ...) body))))
    104           ((stream-match-pattern strm (w? . rest) (binding ...) body)
    105             (wildcard? #'w?)
    106             (syntax (and (stream-pair? strm)
    107                          (let ((strm (stream-cdr strm)))
    108                            (stream-match-pattern strm rest (binding ...) body)))))
    109           ((stream-match-pattern strm (var . rest) (binding ...) body)
    110             (syntax (and (stream-pair? strm)
    111                          (let ((temp (stream-car strm)) (strm (stream-cdr strm)))
    112                            (stream-match-pattern strm rest ((var temp) binding ...) body)))))
    113           ((stream-match-pattern strm w? (binding ...) body)
    114             (wildcard? #'w?)
    115             (syntax (let (binding ...) body)))
    116           ((stream-match-pattern strm var (binding ...) body)
    117             (syntax (let ((var strm) binding ...) body))))))
     106          ((stream-match-pattern STRM () (BINDING ...) BODY)
     107           (syntax (and (stream-null? STRM) (let (BINDING ...) BODY))))
     108          ((stream-match-pattern STRM (W? . REST) (BINDING ...) BODY)
     109           (wildcard? #'W?)
     110           (syntax (and (stream-pair? STRM)
     111                        (let ((STRM (stream-cdr STRM)))
     112                          (stream-match-pattern STRM REST (BINDING ...) BODY)))))
     113          ((stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY)
     114           (syntax (and (stream-pair? STRM)
     115                        (let ((temp (stream-car STRM)) (STRM (stream-cdr STRM)))
     116                          (stream-match-pattern STRM REST ((VAR temp) BINDING ...) BODY)))))
     117          ((stream-match-pattern STRM W? (BINDING ...) BODY)
     118           (wildcard? #'W?)
     119           (syntax (let (BINDING ...) BODY)))
     120          ((stream-match-pattern STRM VAR (BINDING ...) BODY)
     121           (syntax (let ((VAR STRM) BINDING ...) BODY))))))
    118122
    119123    (define-syntax stream-of
    120124      (syntax-rules ()
    121         ((stream-of expr rest ...)
    122           (stream-of-aux expr stream-null rest ...))))
     125        ((stream-of EXPR REST ...)
     126         (stream-of-aux EXPR stream-null REST ...))))
    123127
    124128    (define-syntax stream-of-aux
    125129      (syntax-rules (in is)
    126         ((stream-of-aux expr base)
    127           (stream-cons expr base))
    128         ((stream-of-aux expr base (var in stream) rest ...)
    129           (stream-let loop ((strm stream))
    130             (if (stream-null? strm)
    131                 base
    132                 (let ((var (stream-car strm)))
    133                   (stream-of-aux expr (loop (stream-cdr strm)) rest ...)))))
    134         ((stream-of-aux expr base (var is exp) rest ...)
    135           (let ((var exp)) (stream-of-aux expr base rest ...)))
    136         ((stream-of-aux expr base pred? rest ...)
    137           (if pred? (stream-of-aux expr base rest ...) base)))) )
    138 
    139   (else
    140 
    141     (define-macro (define-stream head . body)
    142       `(define ,(car head) (stream-lambda ,(cdr head) ,@body)))
    143 
    144     (define-macro (stream . objs)
    145       (let loop ([objs objs])
     130        ((stream-of-aux EXPR BASE)
     131         (stream-cons EXPR BASE))
     132        ((stream-of-aux EXPR BASE (VAR in STREAM) REST ...)
     133         (stream-let loop ((strm STREAM))
     134           (if (stream-null? strm)
     135               BASE
     136               (let ((VAR (stream-car strm)))
     137                 (stream-of-aux EXPR (loop (stream-cdr strm)) REST ...)))))
     138        ((stream-of-aux EXPR BASE (VAR is EXP) REST ...)
     139         (let ((VAR EXP)) (stream-of-aux EXPR BASE REST ...)))
     140        ((stream-of-aux EXPR BASE PRED? REST ...)
     141         (if PRED? (stream-of-aux EXPR BASE REST ...) BASE)))) ]
     142
     143  [else
     144
     145    (define-macro (define-stream HEAD . BODY)
     146      `(define ,(car HEAD) (stream-lambda ,(cdr HEAD) ,@BODY)) )
     147
     148    (define-macro (stream . OBJS)
     149      (let loop ([objs OBJS])
    146150        (if (null? objs)
    147151            'stream-null
    148             `(stream-cons ,(car objs) ,(loop (cdr objs))))))
    149 
    150     (define-macro (stream-let tag head . body)
     152            `(stream-cons ,(car objs) ,(loop (cdr objs))) ) ) )
     153
     154    (define-macro (stream-let TAG HEAD . BODY)
    151155      (let-values ([(names vals)
    152                     (let loop ([head head]
     156                    (let loop ([head HEAD]
    153157                               [names '()] [vals '()])
    154158                      (if (null? head)
     
    156160                          (let ([def (car head)])
    157161                            (loop (cdr head)
    158                                   (cons (car def) names) (cons (cadr def) vals)))))])
    159         `((letrec ((,tag (stream-lambda (,@names) ,@body))) ,tag) ,@vals)))
    160 
    161     (define-macro (stream-match strm-expr . clauses)
     162                                  (cons (car def) names) (cons (cadr def) vals)) ) ) ) ] )
     163        `((letrec ((,TAG (stream-lambda (,@names) ,@BODY))) ,TAG) ,@vals)) )
     164
     165    (define-macro (stream-match STRM-EXPR . CLAUSES)
    162166      (let ([strm (gensym)])
    163         `(let ((,strm ,strm-expr))
     167        `(let ((,strm ,STRM-EXPR))
    164168           (cond ((not (stream? ,strm)) (error 'stream-match "non-stream argument"))
    165                  ,@(let loop ([clauses clauses])
     169                 ,@(let loop ([clauses CLAUSES])
    166170                     (if (null? clauses)
    167171                         '()
    168172                         (cons `((stream-match-test ,strm ,(car clauses)) => car)
    169173                               (loop (cdr clauses)))))
    170                  (else (error 'stream-match "pattern failure"))))))
    171 
    172     (define-macro (stream-match-test strm clause)
    173       (cond [(= 3 (length clause))
    174             `(stream-match-pattern ,strm ,(car clause) ()
    175                                    (and ,(cadr clause) (list ,(caddr clause))))]
    176             [(= 2 (length clause))
    177              `(stream-match-pattern ,strm ,(car clause) () (list ,(cadr clause)))]
     174                 (else (error 'stream-match "pattern failure"))))) )
     175
     176    (define-macro (stream-match-test STRM CLAUSE)
     177      (cond [(= 3 (length CLAUSE))
     178            `(stream-match-pattern ,STRM ,(car CLAUSE) ()
     179                                   (and ,(cadr CLAUSE) (list ,(caddr CLAUSE)))) ]
     180            [(= 2 (length CLAUSE))
     181             `(stream-match-pattern ,STRM ,(car CLAUSE) () (list ,(cadr CLAUSE))) ]
    178182            [else
    179              (syntax-error 'stream-match "invalid clause" clause)]))
    180 
    181     (define-macro (stream-match-pattern strm patt bindings body)
     183             (syntax-error 'stream-match "invalid clause" CLAUSE) ] ) )
     184
     185    (define-macro (stream-match-pattern STRM patt bindings BODY)
    182186      (cond [(null? patt)
    183              `(and (stream-null? ,strm) (let ,bindings ,body))]
     187             `(and (stream-null? ,STRM) (let ,bindings ,BODY)) ]
    184188            [(pair? patt)
    185189             (cond [(symbol? (car patt))
    186190                    (if (eq? '_ (car patt))
    187                         `(and (stream-pair? ,strm)
    188                               (let ((,strm (stream-cdr ,strm)))
    189                                 (stream-match-pattern ,strm ,(cdr patt) ,bindings ,body)))
     191                        `(and (stream-pair? ,STRM)
     192                              (let ((,STRM (stream-cdr ,STRM)))
     193                                (stream-match-pattern ,STRM ,(cdr patt) ,bindings ,BODY)))
    190194                        (let ([temp (gensym)])
    191                           `(and (stream-pair? ,strm)
    192                                 (let ((,temp (stream-car ,strm))
    193                                       (,strm (stream-cdr ,strm)))
    194                                   (stream-match-pattern ,strm ,(cdr patt)
     195                          `(and (stream-pair? ,STRM)
     196                                (let ((,temp (stream-car ,STRM))
     197                                      (,STRM (stream-cdr ,STRM)))
     198                                  (stream-match-pattern ,STRM ,(cdr patt)
    195199                                                        ((,(car patt) ,temp) ,@bindings)
    196                                                         ,body)))))]
     200                                                        ,BODY))) ) ) ]
    197201                   [else
    198                     (syntax-error 'stream-match "invalid complex pattern" patt)])]
     202                    (syntax-error 'stream-match "invalid complex pattern" patt) ] ) ]
    199203            [(symbol? patt)
    200204             (if (eq? '_ patt)
    201                  `(let ,bindings ,body)
    202                  `(let ((,patt ,strm) ,@bindings) ,body))]
     205                 `(let ,bindings ,BODY)
     206                 `(let ((,patt ,STRM) ,@bindings) ,BODY))]
    203207            [else
    204              (syntax-error 'stream-match "invalid atomic pattern" patt)]))
    205 
    206     (define-macro (stream-of expr . rest)
    207       `(stream-of-aux ,expr stream-null ,@rest))
    208 
    209     (define-macro (stream-of-aux expr base . quals)
    210       (if (null? quals)
    211           `(stream-cons ,expr ,base)
    212           (let ([pred (car quals)]
    213                 [rest (cdr quals)])
     208             (syntax-error 'stream-match "invalid atomic pattern" patt)] ) )
     209
     210    (define-macro (stream-of EXPR . REST)
     211      `(stream-of-aux ,EXPR stream-null ,@REST) )
     212
     213    (define-macro (stream-of-aux EXPR BASE . QUALS)
     214      (if (null? QUALS)
     215          `(stream-cons ,EXPR ,BASE)
     216          (let ([pred (car QUALS)]
     217                [rest (cdr QUALS)])
    214218            (if (and (pair? pred)
    215219                     (= 3 (length pred))
     
    222226                     `(stream-let ,loop ((,strm ,(caddr pred)))
    223227                        (if (stream-null? ,strm)
    224                             ,base
     228                            ,BASE
    225229                            (let ((,(car pred) (stream-car ,strm)))
    226                               (stream-of-aux ,expr (,loop (stream-cdr ,strm)) ,@rest)))))]
     230                              (stream-of-aux ,EXPR (,loop (stream-cdr ,strm)) ,@rest)))) ) ]
    227231                  [(is)
    228232                   `(let ((,(car pred) ,(caddr pred)))
    229                       (stream-of-aux ,expr ,base ,@rest))])
    230                 `(if ,pred (stream-of-aux ,expr ,base ,@rest) ,base))))) ) )
     233                      (stream-of-aux ,EXPR ,BASE ,@rest)) ] )
     234                `(if ,pred (stream-of-aux ,EXPR ,BASE ,@rest) ,BASE) ) ) ) ) ] )
  • release/3/srfi-41/tags/1.0/tests/run.scm

    r8342 r8493  
    3535            (display "returned: ") (display ex?r) (newline))))))
    3636
    37 (define (error s x) (string-append (symbol->string s) ": " x))
     37(define (error s x . r)
     38  (string-append (symbol->string s) ": " x) )
    3839
    3940(define strm123 (stream 1 2 3))
     
    365366
    366367#|
    367 (define-constant SIZE 10 #;10000000)
     368(define-constant SIZE 10000000)
    368369
    369370(print "Times3 Test - Please wait. No output means \"passed\".")
     
    377378(time (stream-ref (traverse (stream-from 0)) SIZE))
    378379
    379 (print "Reference Test - Please wait. No output means \"passed\".")
     380(print "Traverse Test (with stream head held) - Please wait. No output means \"passed\".")
    380381(define strm (traverse (stream-from 0)))
    381382(time (stream-ref strm SIZE))
  • release/3/srfi-41/trunk/srfi-41-support.scm

    r8342 r8493  
    6767;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (streams primitive)
    6868
    69 (define-record-type srfi-41-stream
     69(define-record-type stream
    7070  (##srfi-41#make-stream box)
    7171  stream?
    72   (box stream-promise stream-promise!))
     72  (box stream-promise stream-promise-set!))
    7373
    7474(define (##srfi-41#stream-eager expr)
    75   (##srfi-41#make-stream
    76     (cons 'eager expr)))
     75  (##srfi-41#make-stream (cons 'eager expr)))
    7776
    7877(define (stream-force promise)
     
    8584                     (begin (set-car! content (car (stream-promise promise*)))
    8685                            (set-cdr! content (cdr (stream-promise promise*)))
    87                             (stream-promise! promise* content)))
     86                            (stream-promise-set! promise* content)))
    8887                 (stream-force promise))))))
    8988
    9089(define stream-null (##srfi-41#stream-delay (cons 'stream 'null)))
    9190
    92 (define-record-type srfi-41-stream-pare
     91(define-record-type stream-pare
    9392  (##srfi-41#make-stream-pare kar kdr)
    9493  stream-pare?
     
    105104
    106105(define (stream-car strm)
    107   (cond ((not (stream? strm)) (error 'stream-car "non-stream"))
    108         ((stream-null? strm) (error 'stream-car "null stream"))
     106  (cond ((not (stream? strm)) (error 'stream-car "non-stream" strm))
     107        ((stream-null? strm) (error 'stream-car "null stream" strm))
    109108        (else (stream-force (stream-kar (stream-force strm))))))
    110109
    111110(define (stream-cdr strm)
    112   (cond ((not (stream? strm)) (error 'stream-cdr "non-stream"))
    113         ((stream-null? strm) (error 'stream-cdr "null stream"))
     111  (cond ((not (stream? strm)) (error 'stream-cdr "non-stream" strm))
     112        ((stream-null? strm) (error 'stream-cdr "null stream" strm))
    114113        (else (stream-kdr (stream-force strm)))))
    115114
    116115;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (streams derived)
    117116
    118 (define (exists pred? . lists)
    119   (and (not (null? (car lists)))
    120        (or (apply pred? (map car lists))
    121            (apply exists pred? (map cdr lists)))))
     117(define-inline ($exists pred? . lists)
     118  (let loop ([lists lists])
     119    (and (not (null? (car lists)))
     120         (or (apply pred? (map car lists))
     121             (loop (map cdr lists)) ) ) ) )
    122122
    123123(define (list->stream objs)
     
    128128          (stream-cons (car objs) (list->stream (cdr objs))))))
    129129  (if (not (list? objs))
    130       (error 'list->stream "non-list argument")
     130      (error 'list->stream "non-list argument" objs)
    131131      (list->stream objs)))
    132132
     
    140140  (let ((p (if (null? port) (current-input-port) (car port))))
    141141    (if (not (input-port? p))
    142         (error 'port->stream "non-input-port argument")
     142        (error 'port->stream "non-input-port argument" p)
    143143        (port->stream p))))
    144144
     
    146146  (let ((n (if (= 1 (length args)) #f (car args)))
    147147        (strm (if (= 1 (length args)) (car args) (cadr args))))
    148     (cond ((not (stream? strm)) (error 'stream->list "non-stream argument"))
    149           ((and n (not (integer? n))) (error 'stream->list "non-integer count"))
    150           ((and n (negative? n)) (error 'stream->list "negative count"))
     148    (cond ((not (stream? strm)) (error 'stream->list "non-stream argument" strm))
     149          ((and n (not (integer? n))) (error 'stream->list "non-integer count" n))
     150          ((and n (negative? n)) (error 'stream->list "negative count" n))
    151151          (else (let loop ((n (if n n -1)) (strm strm))
    152152                  (if (or (zero? n) (stream-null? strm))
     
    162162                               (stream-append (cons (stream-cdr (car strms)) (cdr strms))))))))
    163163  (cond ((null? strms) stream-null)
    164         ((exists (lambda (x) (not (stream? x))) strms)
    165           (error 'stream-append "non-stream argument"))
     164        (($exists (lambda (x) (not (stream? x))) strms)
     165          (error 'stream-append "non-stream argument" strms))
    166166        (else (stream-append strms))))
    167167
     
    171171      (cond ((stream-null? strms) stream-null)
    172172            ((not (stream? (stream-car strms)))
    173               (error 'stream-concat "non-stream object in input stream"))
     173              (error 'stream-concat "non-stream object in input stream" strms))
    174174            ((stream-null? (stream-car strms))
    175175              (stream-concat (stream-cdr strms)))
     
    179179                      (stream-cons (stream-cdr (stream-car strms)) (stream-cdr strms))))))))
    180180  (if (not (stream? strms))
    181       (error 'stream-concat "non-stream argument")
     181      (error 'stream-concat "non-stream argument" strms)
    182182      (stream-concat strms)))
    183183
     
    195195          strm
    196196          (stream-drop (- n 1) (stream-cdr strm)))))
    197   (cond ((not (integer? n)) (error 'stream-drop "non-integer argument"))
    198         ((negative? n) (error 'stream-drop "negative argument"))
    199         ((not (stream? strm)) (error 'stream-drop "non-stream argument"))
     197  (cond ((not (integer? n)) (error 'stream-drop "non-integer argument" n))
     198        ((negative? n) (error 'stream-drop "negative argument" n))
     199        ((not (stream? strm)) (error 'stream-drop "non-stream argument" strm))
    200200        (else (stream-drop n strm))))
    201201
     
    206206          (stream-drop-while (stream-cdr strm))
    207207          strm)))
    208   (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument"))
    209         ((not (stream? strm)) (error 'stream-drop-while "non-stream argument"))
     208  (cond ((not (procedure? pred?)) (error 'stream-drop-while "non-procedural argument" pred?))
     209        ((not (stream? strm)) (error 'stream-drop-while "non-stream argument" strm))
    210210        (else (stream-drop-while strm))))
    211211
     
    217217              (stream-cons (stream-car strm) (stream-filter (stream-cdr strm))))
    218218            (else (stream-filter (stream-cdr strm))))))
    219   (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument"))
    220         ((not (stream? strm)) (error 'stream-filter "non-stream argument"))
     219  (cond ((not (procedure? pred?)) (error 'stream-filter "non-procedural argument" pred?))
     220        ((not (stream? strm)) (error 'stream-filter "non-stream argument" strm))
    221221        (else (stream-filter strm))))
    222222
    223223(define (stream-fold proc base strm)
    224   (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument"))
    225         ((not (stream? strm)) (error 'stream-fold "non-stream argument"))
     224  (cond ((not (procedure? proc)) (error 'stream-fold "non-procedural argument" proc))
     225        ((not (stream? strm)) (error 'stream-fold "non-stream argument" strm))
    226226        (else (let loop ((base base) (strm strm))
    227227                (if (stream-null? strm)
     
    231231(define (stream-for-each proc . strms)
    232232  (define (stream-for-each strms)
    233     (if (not (exists stream-null? strms))
     233    (if (not ($exists stream-null? strms))
    234234        (begin (apply proc (map stream-car strms))
    235235               (stream-for-each (map stream-cdr strms)))))
    236   (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument"))
    237         ((null? strms) (error 'stream-for-each "no stream arguments"))
    238         ((exists (lambda (x) (not (stream? x))) strms)
    239           (error 'stream-for-each "non-stream argument"))
     236  (cond ((not (procedure? proc)) (error 'stream-for-each "non-procedural argument" proc))
     237        ((null? strms) (error 'stream-for-each "no stream arguments" strms))
     238        (($exists (lambda (x) (not (stream? x))) strms)
     239          (error 'stream-for-each "non-stream argument" strms))
    240240        (else (stream-for-each strms))))
    241241
     
    245245      (stream-cons first (stream-from (+ first delta) delta))))
    246246  (let ((delta (if (null? step) 1 (car step))))
    247     (cond ((not (number? first)) (error 'stream-from "non-numeric starting number"))
    248           ((not (number? delta)) (error 'stream-from "non-numeric step size"))
     247    (cond ((not (number? first)) (error 'stream-from "non-numeric starting number" first))
     248          ((not (number? delta)) (error 'stream-from "non-numeric step size" delta))
    249249          (else (stream-from first delta)))))
    250250
     
    254254      (stream-cons base (stream-iterate (proc base)))))
    255255  (if (not (procedure? proc))
    256       (error 'stream-iterate "non-procedural argument")
     256      (error 'stream-iterate "non-procedural argument" proc)
    257257      (stream-iterate base)))
    258258
    259259(define (stream-length strm)
    260260  (if (not (stream? strm))
    261       (error 'stream-length "non-stream argument")
     261      (error 'stream-length "non-stream argument" strm)
    262262      (let loop ((len 0) (strm strm))
    263263        (if (stream-null? strm)
     
    268268  (define stream-map
    269269    (stream-lambda (strms)
    270       (if (exists stream-null? strms)
     270      (if ($exists stream-null? strms)
    271271          stream-null
    272272          (stream-cons (apply proc (map stream-car strms))
    273273                       (stream-map (map stream-cdr strms))))))
    274   (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument"))
    275         ((null? strms) (error 'stream-map "no stream arguments"))
    276         ((exists (lambda (x) (not (stream? x))) strms)
    277           (error 'stream-map "non-stream argument"))
     274  (cond ((not (procedure? proc)) (error 'stream-map "non-procedural argument" proc))
     275        ((null? strms) (error 'stream-map "no stream arguments" strms))
     276        (($exists (lambda (x) (not (stream? x))) strms)
     277          (error 'stream-map "non-stream argument" strms))
    278278        (else (stream-map strms))))
    279279
     
    284284          (stream-cons first (stream-range (+ first delta) past delta lt?))
    285285          stream-null)))
    286   (cond ((not (number? first)) (error 'stream-range "non-numeric starting number"))
    287         ((not (number? past)) (error 'stream-range "non-numeric ending number"))
     286  (cond ((not (number? first)) (error 'stream-range "non-numeric starting number" first))
     287        ((not (number? past)) (error 'stream-range "non-numeric ending number" past))
    288288        (else (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
    289289                (if (not (number? delta))
    290                     (error 'stream-range "non-numeric step size")
     290                    (error 'stream-range "non-numeric step size" delta)
    291291                    (let ((lt? (if (< 0 delta) < >)))
    292292                      (stream-range first past delta lt?)))))))
    293293
    294294(define (stream-ref strm n)
    295   (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument"))
    296         ((not (integer? n)) (error 'stream-ref "non-integer argument"))
    297         ((negative? n) (error 'stream-ref "negative argument"))
     295  (cond ((not (stream? strm)) (error 'stream-ref "non-stream argument" strm))
     296        ((not (integer? n)) (error 'stream-ref "non-integer argument" n))
     297        ((negative? n) (error 'stream-ref "negative argument" n))
    298298        (else (let loop ((strm strm) (n n))
    299                 (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream"))
     299                (cond ((stream-null? strm) (error 'stream-ref "beyond end of stream" strm))
    300300                      ((zero? n) (stream-car strm))
    301301                      (else (loop (stream-cdr strm) (- n 1))))))))
     
    308308          (stream-reverse (stream-cdr strm) (stream-cons (stream-car strm) rev)))))
    309309  (if (not (stream? strm))
    310       (error 'stream-reverse "non-stream argument")
     310      (error 'stream-reverse "non-stream argument" strm)
    311311      (stream-reverse strm stream-null)))
    312312
     
    317317          (stream base)
    318318          (stream-cons base (stream-scan (proc base (stream-car strm)) (stream-cdr strm))))))
    319   (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument"))
    320         ((not (stream? strm)) (error 'stream-scan "non-stream argument"))
     319  (cond ((not (procedure? proc)) (error 'stream-scan "non-procedural argument" proc))
     320        ((not (stream? strm)) (error 'stream-scan "non-stream argument" strm))
    321321        (else (stream-scan base strm))))
    322322
     
    327327          stream-null
    328328          (stream-cons (stream-car strm) (stream-take (- n 1) (stream-cdr strm))))))
    329   (cond ((not (stream? strm)) (error 'stream-take "non-stream argument"))
    330         ((not (integer? n)) (error 'stream-take "non-integer argument"))
    331         ((negative? n) (error 'stream-take "negative argument"))
     329  (cond ((not (stream? strm)) (error 'stream-take "non-stream argument" strm))
     330        ((not (integer? n)) (error 'stream-take "non-integer argument" n))
     331        ((negative? n) (error 'stream-take "negative argument" n))
    332332        (else (stream-take n strm))))
    333333
     
    339339              (stream-cons (stream-car strm) (stream-take-while (stream-cdr strm))))
    340340            (else stream-null))))
    341   (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument"))
    342         ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument"))
     341  (cond ((not (stream? strm)) (error 'stream-take-while "non-stream argument" strm))
     342        ((not (procedure? pred?)) (error 'stream-take-while "non-procedural argument" pred?))
    343343        (else (stream-take-while strm))))
    344344
     
    349349          (stream-cons (mapper base) (stream-unfold (generator base)))
    350350          stream-null)))
    351   (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper"))
    352         ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?"))
    353         ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator"))
     351  (cond ((not (procedure? mapper)) (error 'stream-unfold "non-procedural mapper" mapper))
     352        ((not (procedure? pred?)) (error 'stream-unfold "non-procedural pred?" pred?))
     353        ((not (procedure? generator)) (error 'stream-unfold "non-procedural generator" generator))
    354354        (else (stream-unfold base))))
    355355
     
    375375                (result-stream->output-stream (stream-cdr result-stream) i))
    376376              ((null? result) stream-null)
    377               (else (error 'stream-unfolds "can't happen"))))))
     377              (else (error 'stream-unfolds "cannot happen" result))))))
    378378  (define (result-stream->output-streams result-stream)
    379379    (let loop ((i (len-values gen seed)) (outputs '()))
     
    382382          (loop (- i 1) (cons (result-stream->output-stream result-stream i) outputs)))))
    383383  (if (not (procedure? gen))
    384       (error 'stream-unfolds "non-procedural argument")
     384      (error 'stream-unfolds "non-procedural argument" gen)
    385385      (result-stream->output-streams (unfold-result-stream gen seed))))
    386386
     
    388388  (define stream-zip
    389389    (stream-lambda (strms)
    390       (if (exists stream-null? strms)
     390      (if ($exists stream-null? strms)
    391391          stream-null
    392392          (stream-cons (map stream-car strms) (stream-zip (map stream-cdr strms))))))
    393   (cond ((null? strms) (error 'stream-zip "no stream arguments"))
    394         ((exists (lambda (x) (not (stream? x))) strms)
    395           (error 'stream-zip "non-stream argument"))
     393  (cond ((null? strms) (error 'stream-zip "no stream arguments" strms))
     394        (($exists (lambda (x) (not (stream? x))) strms)
     395          (error 'stream-zip "non-stream argument" strms))
    396396        (else (stream-zip strms))))
  • release/3/srfi-41/trunk/srfi-41.scm

    r8342 r8493  
    2020(cond-expand
    2121
    22   (syntax-case
     22  [syntax-case
    2323
    2424    (define-syntax ##srfi-41#stream-lazy
    2525      (syntax-rules ()
    26         ((##srfi-41#stream-lazy expr)
    27           (##srfi-41#make-stream
    28             (cons 'lazy (lambda () expr))))))
     26        ((##srfi-41#stream-lazy EXPR)
     27         (##srfi-41#make-stream (cons 'lazy (lambda () EXPR))))))
    2928
    3029    (define-syntax ##srfi-41#stream-delay
    3130      (syntax-rules ()
    32         ((##srfi-41#stream-delay expr)
    33           (##srfi-41#stream-lazy (##srfi-41#stream-eager expr)))))
     31        ((##srfi-41#stream-delay EXPR)
     32         (##srfi-41#stream-lazy (##srfi-41#stream-eager EXPR)))))
    3433
    3534    (define-syntax stream-cons
    3635      (syntax-rules ()
    37         ((stream-cons obj strm)
    38           (##srfi-41#stream-eager (##srfi-41#make-stream-pare (##srfi-41#stream-delay obj) (##srfi-41#stream-lazy strm))))))
     36        ((stream-cons OBJ STRM)
     37         (##srfi-41#stream-eager
     38          (##srfi-41#make-stream-pare (##srfi-41#stream-delay OBJ)
     39                                      (##srfi-41#stream-lazy STRM))))))
    3940
    4041    (define-syntax stream-lambda
    4142      (syntax-rules ()
    42         ((stream-lambda formals body0 body1 ...)
    43           (lambda formals (##srfi-41#stream-lazy (let () body0 body1 ...)))))) )
    44 
    45   (else
    46 
    47     (define-macro (##srfi-41#stream-lazy expr)
    48       `(##srfi-41#make-stream
    49          (cons 'lazy (lambda () ,expr))))
    50 
    51     (define-macro (##srfi-41#stream-delay expr)
    52       `(##srfi-41#stream-lazy (##srfi-41#stream-eager ,expr)))
    53 
    54     (define-macro (stream-cons obj strm)
    55       `(##srfi-41#stream-eager (##srfi-41#make-stream-pare (##srfi-41#stream-delay ,obj) (##srfi-41#stream-lazy ,strm))))
    56  
    57     (define-macro (stream-lambda formals . body)
    58       `(lambda ,formals (##srfi-41#stream-lazy (let () ,@body)))) ) )
     43        ((stream-lambda FORMALS BODY0 BODY1 ...)
     44         (lambda FORMALS (##srfi-41#stream-lazy (let () BODY0 BODY1 ...)))))) ]
     45
     46  [else
     47
     48    (define-macro (##srfi-41#stream-lazy EXPR)
     49      `(##srfi-41#make-stream (cons 'lazy (lambda () ,EXPR))) )
     50
     51    (define-macro (##srfi-41#stream-delay EXPR)
     52      `(##srfi-41#stream-lazy (##srfi-41#stream-eager ,EXPR)) )
     53
     54    (define-macro (stream-cons OBJ STRM)
     55      `(##srfi-41#stream-eager
     56        (##srfi-41#make-stream-pare (##srfi-41#stream-delay ,OBJ)
     57                                    (##srfi-41#stream-lazy ,STRM))) )
     58
     59    (define-macro (stream-lambda FORMALS . BODY)
     60      `(lambda ,FORMALS (##srfi-41#stream-lazy (let () ,@BODY))) ) ] )
    5961
    6062;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (streams derived)
     
    6264(cond-expand
    6365
    64   (syntax-case
     66  [syntax-case
    6567
    6668    (define-syntax define-stream
    6769      (syntax-rules ()
    68         ((define-stream (name . formal) body0 body1 ...)
    69           (define name (stream-lambda formal body0 body1 ...)))))
     70        ((define-stream (NAME . FORMAL) BODY0 BODY1 ...)
     71         (define NAME (stream-lambda FORMAL BODY0 BODY1 ...)))))
    7072
    7173    (define-syntax stream
    7274      (syntax-rules ()
    73         ((stream) stream-null)
    74         ((stream x y ...) (stream-cons x (stream y ...)))))
     75        ((stream)
     76         stream-null)
     77        ((stream X Y ...)
     78         (stream-cons X (stream Y ...)))))
    7579
    7680    (define-syntax stream-let
    7781      (syntax-rules ()
    78         ((stream-let tag ((name val) ...) body1 body2 ...)
    79          ((letrec ((tag (stream-lambda (name ...) body1 body2 ...))) tag) val ...))))
     82        ((stream-let TAG ((NAME VAL) ...) BODY0 BODY1 ...)
     83         ((letrec ((TAG (stream-lambda (NAME ...) BODY0 BODY1 ...))) TAG) VAL ...))))
    8084
    8185    (define-syntax stream-match
    8286      (syntax-rules ()
    83         ((stream-match strm-expr clause ...)
    84           (let ((strm strm-expr))
    85             (cond ((not (stream? strm)) (error 'stream-match "non-stream argument"))
    86                   ((stream-match-test strm clause) => car) ...
    87                   (else (error 'stream-match "pattern failure")))))))
     87        ((stream-match STRM-EXPR CLAUSE ...)
     88         (let ((strm STRM-EXPR))
     89           (cond ((not (stream? strm)) (error 'stream-match "non-stream argument"))
     90                 ((stream-match-test strm CLAUSE) => car) ...
     91                 (else (error 'stream-match "pattern failure")))))))
    8892
    8993    (define-syntax stream-match-test
    9094      (syntax-rules ()
    91         ((stream-match-test strm (pattern fender expr))
    92           (stream-match-pattern strm pattern () (and fender (list expr))))
    93         ((stream-match-test strm (pattern expr))
    94           (stream-match-pattern strm pattern () (list expr)))))
     95        ((stream-match-test STRM (PATTERN FENDER EXPR))
     96         (stream-match-pattern STRM PATTERN () (and FENDER (list EXPR))))
     97        ((stream-match-test STRM (PATTERN EXPR))
     98         (stream-match-pattern STRM PATTERN () (list EXPR)))))
    9599
    96100    (define-syntax stream-match-pattern
     
    100104               (free-identifier=? x (syntax _))))
    101105        (syntax-case x ()
    102           ((stream-match-pattern strm () (binding ...) body)
    103             (syntax (and (stream-null? strm) (let (binding ...) body))))
    104           ((stream-match-pattern strm (w? . rest) (binding ...) body)
    105             (wildcard? #'w?)
    106             (syntax (and (stream-pair? strm)
    107                          (let ((strm (stream-cdr strm)))
    108                            (stream-match-pattern strm rest (binding ...) body)))))
    109           ((stream-match-pattern strm (var . rest) (binding ...) body)
    110             (syntax (and (stream-pair? strm)
    111                          (let ((temp (stream-car strm)) (strm (stream-cdr strm)))
    112                            (stream-match-pattern strm rest ((var temp) binding ...) body)))))
    113           ((stream-match-pattern strm w? (binding ...) body)
    114             (wildcard? #'w?)
    115             (syntax (let (binding ...) body)))
    116           ((stream-match-pattern strm var (binding ...) body)
    117             (syntax (let ((var strm) binding ...) body))))))
     106          ((stream-match-pattern STRM () (BINDING ...) BODY)
     107           (syntax (and (stream-null? STRM) (let (BINDING ...) BODY))))
     108          ((stream-match-pattern STRM (W? . REST) (BINDING ...) BODY)
     109           (wildcard? #'W?)
     110           (syntax (and (stream-pair? STRM)
     111                        (let ((STRM (stream-cdr STRM)))
     112                          (stream-match-pattern STRM REST (BINDING ...) BODY)))))
     113          ((stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY)
     114           (syntax (and (stream-pair? STRM)
     115                        (let ((temp (stream-car STRM)) (STRM (stream-cdr STRM)))
     116                          (stream-match-pattern STRM REST ((VAR temp) BINDING ...) BODY)))))
     117          ((stream-match-pattern STRM W? (BINDING ...) BODY)
     118           (wildcard? #'W?)
     119           (syntax (let (BINDING ...) BODY)))
     120          ((stream-match-pattern STRM VAR (BINDING ...) BODY)
     121           (syntax (let ((VAR STRM) BINDING ...) BODY))))))
    118122
    119123    (define-syntax stream-of
    120124      (syntax-rules ()
    121         ((stream-of expr rest ...)
    122           (stream-of-aux expr stream-null rest ...))))
     125        ((stream-of EXPR REST ...)
     126         (stream-of-aux EXPR stream-null REST ...))))
    123127
    124128    (define-syntax stream-of-aux
    125129      (syntax-rules (in is)
    126         ((stream-of-aux expr base)
    127           (stream-cons expr base))
    128         ((stream-of-aux expr base (var in stream) rest ...)
    129           (stream-let loop ((strm stream))
    130             (if (stream-null? strm)
    131                 base
    132                 (let ((var (stream-car strm)))
    133                   (stream-of-aux expr (loop (stream-cdr strm)) rest ...)))))
    134         ((stream-of-aux expr base (var is exp) rest ...)
    135           (let ((var exp)) (stream-of-aux expr base rest ...)))
    136         ((stream-of-aux expr base pred? rest ...)
    137           (if pred? (stream-of-aux expr base rest ...) base)))) )
    138 
    139   (else
    140 
    141     (define-macro (define-stream head . body)
    142       `(define ,(car head) (stream-lambda ,(cdr head) ,@body)))
    143 
    144     (define-macro (stream . objs)
    145       (let loop ([objs objs])
     130        ((stream-of-aux EXPR BASE)
     131         (stream-cons EXPR BASE))
     132        ((stream-of-aux EXPR BASE (VAR in STREAM) REST ...)
     133         (stream-let loop ((strm STREAM))
     134           (if (stream-null? strm)
     135               BASE
     136               (let ((VAR (stream-car strm)))
     137                 (stream-of-aux EXPR (loop (stream-cdr strm)) REST ...)))))
     138        ((stream-of-aux EXPR BASE (VAR is EXP) REST ...)
     139         (let ((VAR EXP)) (stream-of-aux EXPR BASE REST ...)))
     140        ((stream-of-aux EXPR BASE PRED? REST ...)
     141         (if PRED? (stream-of-aux EXPR BASE REST ...) BASE)))) ]
     142
     143  [else
     144
     145    (define-macro (define-stream HEAD . BODY)
     146      `(define ,(car HEAD) (stream-lambda ,(cdr HEAD) ,@BODY)) )
     147
     148    (define-macro (stream . OBJS)
     149      (let loop ([objs OBJS])
    146150        (if (null? objs)
    147151            'stream-null
    148             `(stream-cons ,(car objs) ,(loop (cdr objs))))))
    149 
    150     (define-macro (stream-let tag head . body)
     152            `(stream-cons ,(car objs) ,(loop (cdr objs))) ) ) )
     153
     154    (define-macro (stream-let TAG HEAD . BODY)
    151155      (let-values ([(names vals)
    152                     (let loop ([head head]
     156                    (let loop ([head HEAD]
    153157                               [names '()] [vals '()])
    154158                      (if (null? head)
     
    156160                          (let ([def (car head)])
    157161                            (loop (cdr head)
    158                                   (cons (car def) names) (cons (cadr def) vals)))))])
    159         `((letrec ((,tag (stream-lambda (,@names) ,@body))) ,tag) ,@vals)))
    160 
    161     (define-macro (stream-match strm-expr . clauses)
     162                                  (cons (car def) names) (cons (cadr def) vals)) ) ) ) ] )
     163        `((letrec ((,TAG (stream-lambda (,@names) ,@BODY))) ,TAG) ,@vals)) )
     164
     165    (define-macro (stream-match STRM-EXPR . CLAUSES)
    162166      (let ([strm (gensym)])
    163         `(let ((,strm ,strm-expr))
     167        `(let ((,strm ,STRM-EXPR))
    164168           (cond ((not (stream? ,strm)) (error 'stream-match "non-stream argument"))
    165                  ,@(let loop ([clauses clauses])
     169                 ,@(let loop ([clauses CLAUSES])
    166170                     (if (null? clauses)
    167171                         '()
    168172                         (cons `((stream-match-test ,strm ,(car clauses)) => car)
    169173                               (loop (cdr clauses)))))
    170                  (else (error 'stream-match "pattern failure"))))))
    171 
    172     (define-macro (stream-match-test strm clause)
    173       (cond [(= 3 (length clause))
    174             `(stream-match-pattern ,strm ,(car clause) ()
    175                                    (and ,(cadr clause) (list ,(caddr clause))))]
    176             [(= 2 (length clause))
    177              `(stream-match-pattern ,strm ,(car clause) () (list ,(cadr clause)))]
     174                 (else (error 'stream-match "pattern failure"))))) )
     175
     176    (define-macro (stream-match-test STRM CLAUSE)
     177      (cond [(= 3 (length CLAUSE))
     178            `(stream-match-pattern ,STRM ,(car CLAUSE) ()
     179                                   (and ,(cadr CLAUSE) (list ,(caddr CLAUSE)))) ]
     180            [(= 2 (length CLAUSE))
     181             `(stream-match-pattern ,STRM ,(car CLAUSE) () (list ,(cadr CLAUSE))) ]
    178182            [else
    179              (syntax-error 'stream-match "invalid clause" clause)]))
    180 
    181     (define-macro (stream-match-pattern strm patt bindings body)
     183             (syntax-error 'stream-match "invalid clause" CLAUSE) ] ) )
     184
     185    (define-macro (stream-match-pattern STRM patt bindings BODY)
    182186      (cond [(null? patt)
    183              `(and (stream-null? ,strm) (let ,bindings ,body))]
     187             `(and (stream-null? ,STRM) (let ,bindings ,BODY)) ]
    184188            [(pair? patt)
    185189             (cond [(symbol? (car patt))
    186190                    (if (eq? '_ (car patt))
    187                         `(and (stream-pair? ,strm)
    188                               (let ((,strm (stream-cdr ,strm)))
    189                                 (stream-match-pattern ,strm ,(cdr patt) ,bindings ,body)))
     191                        `(and (stream-pair? ,STRM)
     192                              (let ((,STRM (stream-cdr ,STRM)))
     193                                (stream-match-pattern ,STRM ,(cdr patt) ,bindings ,BODY)))
    190194                        (let ([temp (gensym)])
    191                           `(and (stream-pair? ,strm)
    192                                 (let ((,temp (stream-car ,strm))
    193                                       (,strm (stream-cdr ,strm)))
    194                                   (stream-match-pattern ,strm ,(cdr patt)
     195                          `(and (stream-pair? ,STRM)
     196                                (let ((,temp (stream-car ,STRM))
     197                                      (,STRM (stream-cdr ,STRM)))
     198                                  (stream-match-pattern ,STRM ,(cdr patt)
    195199                                                        ((,(car patt) ,temp) ,@bindings)
    196                                                         ,body)))))]
     200                                                        ,BODY))) ) ) ]
    197201                   [else
    198                     (syntax-error 'stream-match "invalid complex pattern" patt)])]
     202                    (syntax-error 'stream-match "invalid complex pattern" patt) ] ) ]
    199203            [(symbol? patt)
    200204             (if (eq? '_ patt)
    201                  `(let ,bindings ,body)
    202                  `(let ((,patt ,strm) ,@bindings) ,body))]
     205                 `(let ,bindings ,BODY)
     206                 `(let ((,patt ,STRM) ,@bindings) ,BODY))]
    203207            [else
    204              (syntax-error 'stream-match "invalid atomic pattern" patt)]))
    205 
    206     (define-macro (stream-of expr . rest)
    207       `(stream-of-aux ,expr stream-null ,@rest))
    208 
    209     (define-macro (stream-of-aux expr base . quals)
    210       (if (null? quals)
    211           `(stream-cons ,expr ,base)
    212           (let ([pred (car quals)]
    213                 [rest (cdr quals)])
     208             (syntax-error 'stream-match "invalid atomic pattern" patt)] ) )
     209
     210    (define-macro (stream-of EXPR . REST)
     211      `(stream-of-aux ,EXPR stream-null ,@REST) )
     212
     213    (define-macro (stream-of-aux EXPR BASE . QUALS)
     214      (if (null? QUALS)
     215          `(stream-cons ,EXPR ,BASE)
     216          (let ([pred (car QUALS)]
     217                [rest (cdr QUALS)])
    214218            (if (and (pair? pred)
    215219                     (= 3 (length pred))
     
    222226                     `(stream-let ,loop ((,strm ,(caddr pred)))
    223227                        (if (stream-null? ,strm)
    224                             ,base
     228                            ,BASE
    225229                            (let ((,(car pred) (stream-car ,strm)))
    226                               (stream-of-aux ,expr (,loop (stream-cdr ,strm)) ,@rest)))))]
     230                              (stream-of-aux ,EXPR (,loop (stream-cdr ,strm)) ,@rest)))) ) ]
    227231                  [(is)
    228232                   `(let ((,(car pred) ,(caddr pred)))
    229                       (stream-of-aux ,expr ,base ,@rest))])
    230                 `(if ,pred (stream-of-aux ,expr ,base ,@rest) ,base))))) ) )
     233                      (stream-of-aux ,EXPR ,BASE ,@rest)) ] )
     234                `(if ,pred (stream-of-aux ,EXPR ,BASE ,@rest) ,BASE) ) ) ) ) ] )
  • release/3/srfi-41/trunk/tests/run.scm

    r8382 r8493  
    3535            (display "returned: ") (display ex?r) (newline))))))
    3636
    37 (define (error s x) (string-append (symbol->string s) ": " x))
     37(define (error s x . r)
     38  (string-append (symbol->string s) ": " x) )
    3839
    3940(define strm123 (stream 1 2 3))
Note: See TracChangeset for help on using the changeset viewer.