Changeset 14192 in project


Ignore:
Timestamp:
04/08/09 18:57:09 (12 years ago)
Author:
Kon Lovett
Message:

Update.

Location:
release/4/srfi-41
Files:
1 added
9 edited

Legend:

Unmodified
Added
Removed

  • release/4/srfi-41/tags/1.0.0/chicken-primitive-object-inlines.scm

    r14178 r14192  
    690690      (loop (%cdr ls)) ) ) )
    691691
     692(define-inline (%list/1 obj) (%cons obj '()))
     693
     694(define-inline (%list . objs)
     695  (let loop ((objs objs))
     696    (if (%null? objs) '()
     697        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     698
    692699(define-inline (%make-list n e)
    693700  (let loop ((n n) (ls '()))
    … …  
    704711    (if (%fxzero? n) ls
    705712        (loop (%cdr ls) (%fxsub1 n)) ) ) )
     713
     714(define-inline (%any/1 pred? ls)
     715  (let loop ((ls ls))
     716    (and (not (%null? ls))
     717         (or (pred? (%car ls))
     718             (loop (%cdr ls)) ) ) ) )
     719
     720(define-inline (%list-length ls0)
     721  (let loop ((ls ls0) (n 0))
     722    (if (%null? ls) n
     723        (loop (%cdr ls) (%fxadd1 n)) ) ) )
    706724
    707725;; Structure (wordblock)
    … …  
    738756
    739757(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    740 (define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
    741 (define-inline (%port-class port) (%wordblock-ref? port 2))
    742 (define-inline (%port-name port) (%wordblock-ref? port 3))
    743 (define-inline (%port-row port) (%wordblock-ref? port 4))
    744 (define-inline (%port-column port) (%wordblock-ref? port 5))
    745 (define-inline (%port-eof? port) (%wordblock-ref? port 6))
    746 (define-inline (%port-type port) (%wordblock-ref? port 7))
    747 (define-inline (%port-closed? port) (%wordblock-ref? port 8))
    748 (define-inline (%port-data port) (%wordblock-ref? port 9))
    749 
    750 (define-inline (%input-port? x) (and (%port x) (%port-input-mode? x)))
    751 (define-inline (%output-port? x) (and (%port x) (not (%port-input-mode? x))))
     758(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
     759(define-inline (%port-class port) (%wordblock-ref port 2))
     760(define-inline (%port-name port) (%wordblock-ref port 3))
     761(define-inline (%port-row port) (%wordblock-ref port 4))
     762(define-inline (%port-column port) (%wordblock-ref port 5))
     763(define-inline (%port-eof? port) (%wordblock-ref port 6))
     764(define-inline (%port-type port) (%wordblock-ref port 7))
     765(define-inline (%port-closed? port) (%wordblock-ref port 8))
     766(define-inline (%port-data port) (%wordblock-ref port 9))
     767
     768(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
     769(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
    752770
    753771(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))

  • release/4/srfi-41/trunk/chicken-primitive-object-inlines.scm

    r14176 r14192  
    690690      (loop (%cdr ls)) ) ) )
    691691
     692(define-inline (%list/1 obj) (%cons obj '()))
     693
     694(define-inline (%list . objs)
     695  (let loop ((objs objs))
     696    (if (%null? objs) '()
     697        (%cons (%car objs) (loop (%cdr objs)) ) ) ) )
     698
    692699(define-inline (%make-list n e)
    693700  (let loop ((n n) (ls '()))
    … …  
    704711    (if (%fxzero? n) ls
    705712        (loop (%cdr ls) (%fxsub1 n)) ) ) )
     713
     714(define-inline (%any/1 pred? ls)
     715  (let loop ((ls ls))
     716    (and (not (%null? ls))
     717         (or (pred? (%car ls))
     718             (loop (%cdr ls)) ) ) ) )
     719
     720(define-inline (%list-length ls0)
     721  (let loop ((ls ls0) (n 0))
     722    (if (%null? ls) n
     723        (loop (%cdr ls) (%fxadd1 n)) ) ) )
    706724
    707725;; Structure (wordblock)
    … …  
    738756
    739757(define-inline (%port-filep port) (%peek-unsigned-integer port 0))
    740 (define-inline (%port-input-mode? port) (%wordblock-ref? port 1))
    741 (define-inline (%port-class port) (%wordblock-ref? port 2))
    742 (define-inline (%port-name port) (%wordblock-ref? port 3))
    743 (define-inline (%port-row port) (%wordblock-ref? port 4))
    744 (define-inline (%port-column port) (%wordblock-ref? port 5))
    745 (define-inline (%port-eof? port) (%wordblock-ref? port 6))
    746 (define-inline (%port-type port) (%wordblock-ref? port 7))
    747 (define-inline (%port-closed? port) (%wordblock-ref? port 8))
    748 (define-inline (%port-data port) (%wordblock-ref? port 9))
    749 
    750 (define-inline (%input-port? x) (and (%port x) (%port-input-mode? x)))
    751 (define-inline (%output-port? x) (and (%port x) (not (%port-input-mode? x))))
     758(define-inline (%port-input-mode? port) (%wordblock-ref port 1))
     759(define-inline (%port-class port) (%wordblock-ref port 2))
     760(define-inline (%port-name port) (%wordblock-ref port 3))
     761(define-inline (%port-row port) (%wordblock-ref port 4))
     762(define-inline (%port-column port) (%wordblock-ref port 5))
     763(define-inline (%port-eof? port) (%wordblock-ref port 6))
     764(define-inline (%port-type port) (%wordblock-ref port 7))
     765(define-inline (%port-closed? port) (%wordblock-ref port 8))
     766(define-inline (%port-data port) (%wordblock-ref port 9))
     767
     768(define-inline (%input-port? x) (and (%port? x) (%port-input-mode? x)))
     769(define-inline (%output-port? x) (and (%port? x) (not (%port-input-mode? x))))
    752770
    753771(define-inline (%port-filep-set! port fp) (%poke-integer port 0 fp))

  • release/4/srfi-41/trunk/srfi-41.meta

    r14176 r14192  
    1212  "tests"
    1313  "chicken-primitive-object-inlines.scm"
     14  "streams-inlines.scm"
    1415  "streams-primitive.scm"
    1516  "streams-derived.scm"

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

    r14176 r14192  
    2626
    2727(include "chicken-primitive-object-inlines")
     28(include "streams-inlines")
     29(include "inline-type-checks")
    2830
    2931;;;
    30 
    31 (define-inline (%any/1 pred? ls)
    32   (let loop ((ls ls))
    33     (and (not (%null? ls))
    34          (or (pred? (%car ls))
    35              (loop (%cdr ls)) ) ) ) )
    3632
    3733(define-inline (%check-streams loc strms nam)
    3834  (when (%any/1 not-stream? strms)
    3935    (error-stream loc strms nam) ) )
    40 
    41 ;;;
    4236
    4337(module streams-derived (;export
    … …  
    6155  stream-zip
    6256  ;; WTF
    63   $stream-match-pattern$
    64   $stream-match-test$)
     57  $$stream-match-pattern
     58  $$stream-match-test)
    6559
    6660(import scheme chicken
    6761  #;srfi-9 #;srfi-23
    6862  streams-primitive
    69   (only type-checks
    70     check-number check-procedure check-cardinal-integer check-input-port check-list))
    71 
    72 (require-library #;srfi-9 #;srfi-23 streams-primitive type-checks)
     63  (only type-errors
     64    error-number error-procedure error-cardinal-integer error-input-port error-list))
     65
     66(require-library #;srfi-9 #;srfi-23 streams-primitive type-errors)
    7367
    7468;;;
    7569
    76 (define (not-stream? obj) (not (stream? obj)))
     70(define (not-stream? obj) (%not-stream? obj))
    7771
    7872;;;
    … …  
    8175  (syntax-rules ()
    8276    ((define-stream (NAME . FORMAL) BODY0 BODY1 ...)
    83      (define NAME (stream-lambda FORMAL BODY0 BODY1 ...)))))
     77     (define NAME (stream-lambda FORMAL BODY0 BODY1 ...)) ) ) )
    8478
    8579(define-syntax stream
    8680  (syntax-rules ()
    8781    ((stream) stream-null)
    88     ((stream X Y ...) (stream-cons X (stream Y ...)))))
     82    ((stream X Y ...) (stream-cons X (stream Y ...)) ) ) )
    8983
    9084(define-syntax stream-let
    9185  (syntax-rules ()
    9286    ((stream-let TAG ((NAME VAL) ...) BODY0 BODY1 ...)
    93      ((letrec ((TAG (stream-lambda (NAME ...) BODY0 BODY1 ...))) TAG) VAL ...))))
     87     ((letrec ((TAG (stream-lambda (NAME ...) BODY0 BODY1 ...))) TAG) VAL ...) ) ) )
    9488
    9589;FIXME - this forces use of `_' identifier
    96 (define-syntax $stream-match-pattern$
     90(define-syntax $$stream-match-pattern
    9791  (syntax-rules (_)
    9892
    99     (($stream-match-pattern$ STRM () (BINDING ...) BODY)
     93    (($$stream-match-pattern STRM () (BINDING ...) BODY)
    10094     (and (stream-null? STRM)
    101           (let (BINDING ...) BODY)))
    102 
    103     (($stream-match-pattern$ STRM (_ . REST) (BINDING ...) BODY)
     95          (let (BINDING ...) BODY)) )
     96
     97    (($$stream-match-pattern STRM (_ . REST) (BINDING ...) BODY)
    10498     (and (stream-pair? STRM)
    10599          (let ((strm (stream-cdr STRM)))
    106             ($stream-match-pattern$ strm REST (BINDING ...) BODY))))
    107 
    108     (($stream-match-pattern$ STRM (VAR . REST) (BINDING ...) BODY)
     100            ($$stream-match-pattern strm REST (BINDING ...) BODY))) )
     101
     102    (($$stream-match-pattern STRM (VAR . REST) (BINDING ...) BODY)
    109103     (and (stream-pair? STRM)
    110104          (let ((temp (stream-car STRM))
    111105                (strm (stream-cdr STRM)))
    112             ($stream-match-pattern$ strm REST ((VAR temp) BINDING ...) BODY))))
    113 
    114     (($stream-match-pattern$ STRM _ (BINDING ...) BODY)
    115      (let (BINDING ...) BODY))
    116 
    117     (($stream-match-pattern$ STRM VAR (BINDING ...) BODY)
    118      (let ((VAR STRM) BINDING ...) BODY))))
    119 
    120 (define-syntax $stream-match-test$
     106            ($$stream-match-pattern strm REST ((VAR temp) BINDING ...) BODY))) )
     107
     108    (($$stream-match-pattern STRM _ (BINDING ...) BODY)
     109     (let (BINDING ...) BODY) )
     110
     111    (($$stream-match-pattern STRM VAR (BINDING ...) BODY)
     112     (let ((VAR STRM) BINDING ...) BODY) ) ) )
     113
     114(define-syntax $$stream-match-test
    121115  (syntax-rules ()
    122116
    123     (($stream-match-test$ STRM (PATTERN FENDER EXPR))
    124      ($stream-match-pattern$ STRM PATTERN () (and FENDER (list EXPR))))
    125 
    126     (($stream-match-test$ STRM (PATTERN EXPR))
    127      ($stream-match-pattern$ STRM PATTERN () (list EXPR)))))
     117    (($$stream-match-test STRM (PATTERN FENDER EXPR))
     118     ($$stream-match-pattern STRM PATTERN () (and FENDER (list EXPR))) )
     119
     120    (($$stream-match-test STRM (PATTERN EXPR))
     121     ($$stream-match-pattern STRM PATTERN () (list EXPR)) ) ) )
    128122
    129123(define-syntax stream-match
    … …  
    132126     (let ((strm STRM-EXPR))
    133127       (cond ((not (stream? strm)) (error-stream 'stream-match strm 'stream))
    134              (($stream-match-test$ strm CLAUSE) => car) ...
    135              (else (##sys#signal-hook #:error 'stream-match "no matching pattern")))))))
     128             (($$stream-match-test strm CLAUSE) => car) ...
     129             (else (##sys#signal-hook #:error 'stream-match "no matching pattern")))) ) ) )
    136130
    137131(define-syntax stream-of
    … …  
    139133
    140134    ((stream-of "aux" EXPR BASE)
    141      (stream-cons EXPR BASE))
     135     (stream-cons EXPR BASE) )
    142136
    143137    ((stream-of "aux" EXPR BASE (VAR in STREAM) REST ...)
    … …  
    145139       (if (stream-null? strm) BASE
    146140           (let ((VAR (stream-car strm)))
    147              (stream-of "aux" EXPR (loop (stream-cdr strm)) REST ...)))))
     141             (stream-of "aux" EXPR (loop (stream-cdr strm)) REST ...)))) )
    148142
    149143    ((stream-of "aux" EXPR BASE (VAR is EXP) REST ...)
    150      (let ((VAR EXP)) (stream-of "aux" EXPR BASE REST ...)))
     144     (let ((VAR EXP)) (stream-of "aux" EXPR BASE REST ...)) )
    151145
    152146    ((stream-of "aux" EXPR BASE PRED? REST ...)
    153      (if PRED? (stream-of "aux" EXPR BASE REST ...) BASE))
     147     (if PRED? (stream-of "aux" EXPR BASE REST ...) BASE) )
    154148
    155149    ((stream-of EXPR REST ...)
    156      (stream-of "aux" EXPR stream-null REST ...))))
     150     (stream-of "aux" EXPR stream-null REST ...) ) ) )
    157151
    158152;;
    159153
     154(define stream-constant
     155  (stream-lambda objs
     156    (cond ((%null? objs)
     157            stream-null )
     158          ((%null? (%cdr objs))
     159            (stream-cons (%car objs) (stream-constant (%car objs))) )
     160          (else
     161            (stream-cons (%car objs)
     162                         (apply stream-constant (append (%cdr objs) (%list/1 (%car objs))))) ) ) ) )
     163
    160164(define (list->stream objects)
    161165
    162166  (define-stream (list->stream$ objs)
    163     (if (null? objs) stream-null
    164         (stream-cons (car objs) (list->stream$ (cdr objs))) ) )
    165 
    166   (check-list 'list->stream objects 'objects)
     167    (if (%null? objs) stream-null
     168        (stream-cons (%car objs) (list->stream$ (%cdr objs))) ) )
     169
     170  (%check-list 'list->stream objects 'objects)
    167171  (list->stream$ objects) )
    168172
    169173(define (stream->list . args)
    170   (let ((length (if (= 1 (length args)) #f (car args)))
    171         (streem (if (= 1 (length args)) (car args) (cadr args))))
    172     (check-stream 'stream->list streem 'stream)
    173     (when length (check-cardinal-integer 'stream->list length 'length))
    174     (let loop ((n (or length -1)) (strm streem))
    175       (if (or (zero? n) (stream-null? strm)) '()
    176           (cons (stream-car strm) (loop (sub1 n) (stream-cdr strm))) ) ) ) )
     174  (let* ((count (and (%fx< 1 (%list-length args)) (%car args)))
     175         (streem (if count (%cadr args) (%car args))))
     176    (%check-stream 'stream->list streem 'stream)
     177    (when count (%check-cardinal-integer 'stream->list count 'count))
     178    (let loop ((n (or count -1)) (strm streem))
     179      (if (or (%fxzero? n) (stream-null? strm)) '()
     180          (%cons (stream-car strm) (loop (%fxsub1 n) (stream-cdr strm))) ) ) ) )
    177181
    178182(define (port->stream . port)
    … …  
    180184  (define-stream (port->stream$ p)
    181185    (let ((c (read-char p)))
    182       (if (eof-object? c) stream-null
     186      (if (%eof-object? c) stream-null
    183187          (stream-cons c (port->stream$ p)) ) )  )
    184188
    185   (let ((port (if (null? port) (current-input-port) (car port))))
    186     (check-input-port 'port->stream port 'port)
     189  (let ((port (if (%null? port) (current-input-port) (%car port))))
     190    (%check-input-port 'port->stream port 'port)
    187191    (port->stream$ port)) )
    188192
    189193(define (stream-length streem)
    190   (check-stream 'stream-length streem 'stream)
     194  (%check-stream 'stream-length streem 'stream)
    191195  (let loop ((len 0) (strm streem))
    192196    (if (stream-null? strm) len
    193         (loop (add1 len) (stream-cdr strm)) ) ) )
     197        (loop (%fxadd1 len) (stream-cdr strm)) ) ) )
    194198
    195199(define (stream-ref streem index)
    196   (check-stream 'stream-ref streem 'stream)
    197   (check-cardinal-integer 'stream-ref index 'index)
     200  (%check-stream 'stream-ref streem 'stream)
     201  (%check-cardinal-integer 'stream-ref index 'index)
    198202  (let loop ((strm streem) (n index))
    199203    (cond ((stream-null? strm)
    200            (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm index))
    201           ((zero? n)
    202            (stream-car strm))
    203           (else
    204            (loop (stream-cdr strm) (sub1 n)) ) ) ) )
     204            (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm index) )
     205          ((%fxzero? n)
     206            (stream-car strm) )
     207          (else
     208            (loop (stream-cdr strm) (%fxsub1 n)) ) ) ) )
    205209
    206210(define (stream-reverse streem)
    … …  
    210214        (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev)) ) )
    211215
    212   (check-stream 'stream-reverse streem 'stream)
     216  (%check-stream 'stream-reverse streem 'stream)
    213217  (stream-reverse$ streem stream-null) )
    214218
    … …  
    216220
    217221  (define-stream (stream-append$ strms)
    218     (cond ((null? (cdr strms)) (car strms))
    219           ((stream-null? (car strms)) (stream-append$ (cdr strms)))
    220           (else (stream-cons (stream-car (car strms))
    221                              (stream-append$
    222                               (cons (stream-cdr (car strms)) (cdr strms)))) ) ) )
    223 
    224   (if (null? streems) stream-null
     222    (cond ((%null? (%cdr strms))
     223            (%car strms) )
     224          ((stream-null? (%car strms))
     225            (stream-append$ (%cdr strms)) )
     226          (else
     227            (stream-cons (stream-car (%car strms))
     228                         (stream-append$ (%cons (stream-cdr (%car strms)) (%cdr strms)))) ) ) )
     229
     230  (if (%null? streems) stream-null
    225231      (begin
    226232        (%check-streams 'stream-append streems 'stream)
    … …  
    231237  (define-stream (stream-concat$ strm)
    232238    (cond ((stream-null? strm)
    233            stream-null)
     239            stream-null )
    234240          ((not (stream? (stream-car strm)))
    235            (error-stream 'stream-concat strm))
     241            (error-stream 'stream-concat strm) )
    236242          ((stream-null? (stream-car strm))
    237            (stream-concat$ (stream-cdr strm)))
    238           (else
    239            (stream-cons (stream-car (stream-car strm))
    240                         (stream-concat$
    241                          (stream-cons (stream-cdr (stream-car strm))
    242                                       (stream-cdr strm)))) ) ) )
    243 
    244   (check-stream 'stream-concat streem 'stream)
     243            (stream-concat$ (stream-cdr strm)) )
     244          (else
     245            (stream-cons (stream-car (stream-car strm))
     246                         (stream-concat$ (stream-cons (stream-cdr (stream-car strm))
     247                                                      (stream-cdr strm)))) ) ) )
     248
     249  (%check-stream 'stream-concat streem 'stream)
    245250  (stream-concat$ streem) )
    246251
    247 (define stream-constant
    248   (stream-lambda objs
    249     (cond ((null? objs) stream-null)
    250           ((null? (cdr objs)) (stream-cons (car objs) (stream-constant (car objs))))
    251           (else (stream-cons (car objs)
    252                              (apply stream-constant (append (cdr objs) (list (car objs))))) ) ) ) )
    253 
    254252(define (stream-drop count streem)
    255253
    256254  (define-stream (stream-drop$ n strm)
    257     (if (or (zero? n) (stream-null? strm)) strm
    258         (stream-drop$ (sub1 n) (stream-cdr strm)) ) )
    259 
    260   (check-stream 'stream-drop streem 'stream)
    261   (check-cardinal-integer 'stream-drop count 'count)
     255    (if (or (%fxzero? n) (stream-null? strm)) strm
     256        (stream-drop$ (%fxsub1 n) (stream-cdr strm)) ) )
     257
     258  (%check-stream 'stream-drop streem 'stream)
     259  (%check-cardinal-integer 'stream-drop count 'count)
    262260  (stream-drop$ count streem) )
    263261
    … …  
    268266        (stream-drop-while$ (stream-cdr strm)) ) )
    269267
    270   (check-procedure 'stream-drop-while predicate? 'predicate?)
    271   (check-stream 'stream-drop-while streem 'stream)
     268  (%check-procedure 'stream-drop-while predicate? 'predicate?)
     269  (%check-stream 'stream-drop-while streem 'stream)
    272270  (stream-drop-while$ streem) )
    273271
    … …  
    275273
    276274  (define-stream (stream-take$ n strm)
    277     (if (or (stream-null? strm) (zero? n)) stream-null
    278         (stream-cons (stream-car strm) (stream-take$ (sub1 n) (stream-cdr strm))) ) )
    279 
    280   (check-stream 'stream-take streem 'stream)
    281   (check-cardinal-integer 'stream-take count 'count)
     275    (if (or (stream-null? strm) (%fxzero? n)) stream-null
     276        (stream-cons (stream-car strm) (stream-take$ (%fxsub1 n) (stream-cdr strm))) ) )
     277
     278  (%check-stream 'stream-take streem 'stream)
     279  (%check-cardinal-integer 'stream-take count 'count)
    282280  (stream-take$ count streem) )
    283281
    … …  
    286284 (define-stream (stream-take-while$ strm)
    287285    (cond ((stream-null? strm)
    288            stream-null)
     286            stream-null )
    289287          ((predicate? (stream-car strm))
    290            (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))))
    291           (else
    292            stream-null ) ) )
    293 
    294   (check-procedure 'stream-take-while predicate? 'predicate?)
    295   (check-stream 'stream-take-while streem 'stream)
     288            (stream-cons (stream-car strm) (stream-take-while$ (stream-cdr strm))) )
     289          (else
     290            stream-null ) ) )
     291
     292  (%check-procedure 'stream-take-while predicate? 'predicate?)
     293  (%check-stream 'stream-take-while streem 'stream)
    296294  (stream-take-while$ streem) )
    297295
    … …  
    300298  (define-stream (stream-filter$ strm)
    301299    (cond ((stream-null? strm)
    302            stream-null)
     300            stream-null )
    303301          ((predicate? (stream-car strm))
    304            (stream-cons (stream-car strm) (stream-filter$ (stream-cdr strm))))
    305           (else
    306            (stream-filter$ (stream-cdr strm)) ) ) )
    307 
    308   (check-procedure 'stream-filter predicate? 'predicate?)
    309   (check-stream 'stream-filter streem 'stream)
     302            (stream-cons (stream-car strm) (stream-filter$ (stream-cdr strm))) )
     303          (else
     304            (stream-filter$ (stream-cdr strm)) ) ) )
     305
     306  (%check-procedure 'stream-filter predicate? 'predicate?)
     307  (%check-stream 'stream-filter streem 'stream)
    310308  (stream-filter$ streem) )
    311309
    … …  
    317315                    (stream-scan$ (function base (stream-car strm)) (stream-cdr strm))) ) )
    318316
    319   (check-procedure 'stream-scan function 'function)
    320   (check-stream 'stream-scan streem 'stream)
     317  (%check-procedure 'stream-scan function 'function)
     318  (%check-stream 'stream-scan streem 'stream)
    321319  (stream-scan$ base streem) )
    322320
    … …  
    325323  (define (stream-folder base strms)
    326324    (if (%any/1 stream-null? strms) base
    327         (stream-folder (apply function base (map stream-car strms))
    328                        (map stream-cdr strms)) ) )
    329 
    330   (check-procedure 'stream-fold function 'function)
    331   (let ((streems (cons streem streems)))
     325        (stream-folder (apply function base (%list-map/1 stream-car strms))
     326                       (%list-map/1 stream-cdr strms)) ) )
     327
     328  (%check-procedure 'stream-fold function 'function)
     329  (let ((streems (%cons streem streems)))
    332330    (%check-streams 'stream-fold streems 'stream)
    333331    (stream-folder base streems) ) )
    … …  
    335333(define (stream-for-each procedure streem . streems)
    336334
    337   (define (stream-for-each$ strms)
     335  (define (stream-for-eacher strms)
    338336    (unless (%any/1 stream-null? strms)
    339       (apply procedure (map stream-car strms))
    340       (stream-for-each$ (map stream-cdr strms)) ) )
    341 
    342   (check-procedure 'stream-for-each procedure 'procedure)
    343   (let ((streems (cons streem streems)))
     337      (apply procedure (%list-map/1 stream-car strms))
     338      (stream-for-eacher (%list-map/1 stream-cdr strms)) ) )
     339
     340  (%check-procedure 'stream-for-each procedure 'procedure)
     341  (let ((streems (%cons streem streems)))
    344342    (%check-streams 'stream-for-each streems 'stream)
    345     (stream-for-each$ streems) ) )
     343    (stream-for-eacher streems) ) )
    346344
    347345(define (stream-map function streem . streems)
    … …  
    350348  (define-stream (stream-map$ strms)
    351349    (if (%any/1 stream-null? strms) stream-null
    352         (stream-cons (apply function (map stream-car strms))
    353                      (stream-map$ (map stream-cdr strms))) ) )
    354 
    355   (check-procedure 'stream-map function 'function)
    356   (let ((streems (cons streem streems)))
     350        (stream-cons (apply function (%list-map/1 stream-car strms))
     351                     (stream-map$ (%list-map/1 stream-cdr strms))) ) )
     352
     353  (%check-procedure 'stream-map function 'function)
     354  (let ((streems (%cons streem streems)))
    357355    (%check-streams 'stream-map streems 'stream)
    358356    (stream-map$ streems) ) )
    … …  
    361359
    362360  (define-stream (stream-from$ first delta)
    363     (stream-cons first (stream-from$ (+ first delta) delta)) )
    364 
    365   (let ((delta (if (null? step) 1 (car step))))
    366     (check-number 'stream-from first 'first)
    367     (check-number 'stream-from delta 'delta)
     361    (stream-cons first (stream-from$ (%fx+ first delta) delta)) )
     362
     363  (let ((delta (if (%null? step) 1 (%car step))))
     364    (%check-number 'stream-from first 'first)
     365    (%check-number 'stream-from delta 'delta)
    368366    (stream-from$ first delta) ) )
    369367
    … …  
    373371    (stream-cons base (stream-iterate$ (function base))) )
    374372
    375   (check-procedure 'stream-iterate function 'function)
     373  (%check-procedure 'stream-iterate function 'function)
    376374  (stream-iterate$ base) )
    377375
    … …  
    380378  (define-stream (stream-range$ first past delta lt?)
    381379    (if (not (lt? first past)) stream-null
    382         (stream-cons first (stream-range$ (+ first delta) past delta lt?)) ) )
    383 
    384   (check-number 'stream-range first 'first)
    385   (check-number 'stream-range past 'past)
    386   (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
    387     (check-number 'stream-range delta 'delta)
     380        (stream-cons first (stream-range$ (%fx+ first delta) past delta lt?)) ) )
     381
     382  (%check-number 'stream-range first 'first)
     383  (%check-number 'stream-range past 'past)
     384  (let ((delta (cond ((%pair? step) (%car step)) ((< first past) 1) (else -1))))
     385    (%check-number 'stream-range delta 'delta)
    388386    (let ((lt? (if (< 0 delta) < >)))
    389387      (stream-range$ first past delta lt?) ) ) )
    … …  
    395393        (stream-cons (mapper base) (stream-unfold$ (generator base))) ) )
    396394
    397   (check-procedure 'stream-unfold mapper 'mapper)
    398   (check-procedure 'stream-unfold predicate? 'predicate?)
    399   (check-procedure 'stream-unfold generator 'generator)
     395  (%check-procedure 'stream-unfold mapper 'mapper)
     396  (%check-procedure 'stream-unfold predicate? 'predicate?)
     397  (%check-procedure 'stream-unfold generator 'generator)
    400398  (stream-unfold$ base) )
    401399
    … …  
    405403    (call-with-values
    406404      (lambda () (generator seed))
    407       (lambda vs (sub1 (length vs)))) )
     405      (lambda vs (%fxsub1 (length vs)))) )
    408406
    409407  (define-stream (unfold-result-stream seed)
    … …  
    414412
    415413  (define-stream (result-stream->output-stream result-stream i)
    416     (let ((result (list-ref (stream-car result-stream) (sub1 i))))
    417       (cond ((pair? result)
    418              (stream-cons (car result)
    419                           (result-stream->output-stream (stream-cdr result-stream) i)))
     414    (let ((result (%list-ref (stream-car result-stream) (%fxsub1 i))))
     415      (cond ((%pair? result)
     416             (stream-cons (%car result)
     417                          (result-stream->output-stream (stream-cdr result-stream) i)) )
    420418            ((not result)
    421              (result-stream->output-stream (stream-cdr result-stream) i))
    422             ((null? result)
    423              stream-null)
     419             (result-stream->output-stream (stream-cdr result-stream) i) )
     420            ((%null? result)
     421             stream-null )
    424422            (else
    425423             (##sys#signal-hook #:runtime-error 'stream-unfolds "cannot happen" result) ) ) ) )
    … …  
    427425  (define (result-stream->output-streams result-stream)
    428426    (let loop ((i (len-values)) (outputs '()))
    429       (if (zero? i) (apply values outputs)
    430           (loop (sub1 i) (cons (result-stream->output-stream result-stream i) outputs)) ) ) )
    431 
    432   (check-procedure 'stream-unfolds generator 'generator)
     427      (if (%fxzero? i) (apply values outputs)
     428          (loop (%fxsub1 i) (%cons (result-stream->output-stream result-stream i) outputs)) ) ) )
     429
     430  (%check-procedure 'stream-unfolds generator 'generator)
    433431  (result-stream->output-streams (unfold-result-stream seed)) )
    434432
    … …  
    437435  (define-stream (stream-zip$ strms)
    438436    (if (%any/1 stream-null? strms) stream-null
    439         (stream-cons (map stream-car strms)
    440                      (stream-zip$ (map stream-cdr strms))) ) )
    441 
    442   (let ((streems (cons streem streems)))
     437        (stream-cons (%list-map/1 stream-car strms)
     438                     (stream-zip$ (%list-map/1 stream-cdr strms))) ) )
     439
     440  (let ((streems (%cons streem streems)))
    443441    (%check-streams 'stream-zip streems 'stream)
    444442    (stream-zip$ streems) ) )

  • release/4/srfi-41/trunk/streams-math.scm

    r14140 r14192  
    2222  (no-procedure-checks) )
    2323
     24(include "chicken-primitive-object-inlines")
     25(include "streams-inlines")
     26
     27;;;
     28
    2429(module streams-math (;export
    25   stream-sum
    2630  stream-max
    2731  stream-min
     32  stream-sum
    2833  odd-numbers-stream
    2934  even-numbers-stream
     35  cardinal-numbers-stream
    3036  natural-numbers-stream
    3137  prime-numbers-stream
    … …  
    3844;;;
    3945
    40 (define stream-sum (left-section stream-fold + 0))
     46(define (stream-max streem)
     47  (%check-stream 'stream-max streem 'stream)
     48  (stream-fold-one max streem) )
    4149
    42 (define (stream-max strm) (stream-fold-one max strm))
     50(define (stream-min streem)
     51  (%check-stream 'stream-min streem 'stream)
     52  (stream-fold-one min streem) )
    4353
    44 (define (stream-min strm) (stream-fold-one min strm))
     54(define (stream-sum) (left-section stream-fold + 0))
    4555
    46 (define odd-numbers-stream (stream-from 1 2))
     56(define (odd-numbers-stream) (stream-from 1 2))
    4757
    48 (define even-numbers-stream (stream-from 0 2))
     58(define (even-numbers-stream) (stream-from 0 2))
    4959
    50 (define natural-numbers-stream (stream-iterate add1 0))
     60(define (cardinal-numbers-stream) (stream-iterate add1 0))
    5161
    52 (define prime-numbers-stream
    53   (let ()
    54     (define-stream (next base mult strm)
    55       (let ((first (stream-car strm))
    56             (rest (stream-cdr strm)))
    57         (cond ((< first mult)
    58                (stream-cons first (next base mult rest)))
    59               ((< mult first)
    60                (next base (+ base mult) strm))
    61               (else
    62                (next base (+ base mult) rest)))))
    63     (define-stream (sift base strm)
    64       (next base (+ base base) strm))
    65     (define-stream (sieve strm)
    66       (let ((first (stream-car strm))
    67             (rest (stream-cdr strm)))
    68         (stream-cons first (sieve (sift first rest)))))
    69     (sieve (stream-from 2))))
     62(define (natural-numbers-stream) (stream-iterate add1 1))
     63
     64(define (prime-numbers-stream)
     65
     66  (define-stream (next$ base mult strm)
     67    (let ((first (stream-car strm))
     68          (rest (stream-cdr strm)))
     69      (cond ((< first mult)
     70              (stream-cons first (next$ base mult rest)) )
     71            ((< mult first)
     72              (next$ base (+ base mult) strm) )
     73            (else
     74              (next$ base (+ base mult) rest) ) ) ) )
     75
     76  (define-stream (sift$ base strm)
     77    (next$ base (+ base base) strm) )
     78
     79  (define-stream (sieve$ strm)
     80    (let ((first (stream-car strm))
     81          (rest (stream-cdr strm)))
     82      (stream-cons first (sieve$ (sift$ first rest))) ) )
     83
     84  (sieve$ (stream-from 2)) )
    7085
    7186;; http://www.research.att.com/~njas/sequences/A051037
    7287
    73 (define hamming-sequence-stream
     88(define (hamming-sequence-stream)
    7489  (stream-cons 1
    7590   (stream-unique =
    … …  
    7792     (stream-map (left-section * 2) hamming-sequence-stream)
    7893     (stream-map (left-section * 3) hamming-sequence-stream)
    79      (stream-map (left-section * 5) hamming-sequence-stream)))))
     94     (stream-map (left-section * 5) hamming-sequence-stream)))) )
    8095
    8196) ;module streams-math

  • release/4/srfi-41/trunk/streams-primitive.scm

    r14176 r14192  
    2424
    2525(include "chicken-primitive-object-inlines")
     26(include "streams-inlines")
    2627
    2728;;;
    2829
     30(define-inline (%make-stream-box tag obj) (%cons tag obj))
     31(define-inline (%stream-box-tag box) (%car box))
     32(define-inline (%stream-box-value box) (%cdr box))
     33(define-inline (%stream-box-tag-set! box tag) (%set-car!/immediate box tag))
     34(define-inline (%stream-box-value-set! box val) (%set-cdr! box val))
     35
     36(define-inline (%make-stream-lazy thunk) (%make-stream (%make-stream-box 'lazy thunk)))
     37(define-inline (%make-stream-eager obj) (%make-stream (%make-stream-box 'eager obj)))
     38
    2939(define-inline (%make-stream prm) (%make-structure 'stream prm))
    30 (define-inline (%stream? obj) (%structure-instance? obj 'stream))
     40;;(define-inline (%stream? obj) (%structure-instance? obj 'stream)) ;from "streams-inlines.scm"
    3141(define-inline (%stream-promise strm) (%structure-ref strm 1))
    3242(define-inline (%stream-promise-set! strm obj) (%structure-set! strm 1 obj))
    … …  
    6171  check-stream-occupied error-stream-occupied
    6272  ;; WTF
    63   ($$stream-lazy $$make-lazy-stream)
     73  ($$stream-lazy $$make-stream-lazy)
    6474  ($$stream-delay $$stream-eager)
    6575  $$make-stream
    66   $$make-lazy-stream
     76  $$make-stream-lazy
    6777  $$stream-eager
    6878  $$make-stream-pare)
    … …  
    7686;;;
    7787
     88(define-check+error-type stream)
     89(define-check+error-type stream-occupied)
     90(define-error-type stream-pair)
     91
     92;;;
     93
    7894(define ($$make-stream prm) (%make-stream prm))
    7995(define (stream? obj) (%stream? obj))
    8096
    81 (define-check+error-type stream)
    82 
    83 (define ($$make-lazy-stream thunk) (%make-stream (%cons 'lazy thunk)))
     97(define ($$make-stream-lazy thunk) (%make-stream-lazy thunk))
    8498
    8599(define-syntax $$stream-lazy
    86100  (syntax-rules ()
    87     ((_ EXPR) ($$make-lazy-stream (lambda () EXPR)) ) ) )
     101    ((_ EXPR) ($$make-stream-lazy (lambda () EXPR)) ) ) )
    88102
    89 (define ($$stream-eager obj) (%make-stream (%cons 'eager obj)))
     103(define ($$stream-eager obj) (%make-stream-eager obj))
    90104
    91105(define-syntax $$stream-delay
    … …  
    93107    ((_ EXPR) ($$stream-lazy ($$stream-eager EXPR)) ) ) )
    94108
     109(define ($$make-stream-pare kar kdr) (%make-stream-pare kar kdr))
     110
     111;;;
     112
    95113(define (stream-force promise)
    96114  (let ((content (%stream-promise promise)))
    97     (case (%car content)
     115    (case (%stream-box-tag content)
    98116      ((eager)
    99         (%cdr content) )
     117        (%stream-box-value content) )
    100118      ((lazy)
    101         (let* ((promise* ((%cdr content)))
     119        (let* ((promise* ((%stream-box-value content)))
    102120               (content  (%stream-promise promise)))
    103           (unless (%eq? 'eager (%car content))
     121          (unless (%eq? 'eager (%stream-box-tag content))
    104122            (let ((prm (%stream-promise promise*)))
    105               (%set-car!/immediate content (%car prm))
    106               (%set-cdr! content (%cdr prm)) )
     123              (%stream-box-tag-set! content (%stream-box-tag prm))
     124              (%stream-box-value-set! content (%stream-box-value prm)) )
    107125            (%stream-promise-set! promise* content) )
    108126         (stream-force promise) ) ) ) ) )
    … …  
    113131(define (stream-occupied? obj) (and (%stream? obj) (not (%stream-null? obj))))
    114132
    115 (define-check+error-type stream-occupied)
    116 
    117 (define ($$make-stream-pare kar kdr) (%make-stream-pare kar kdr))
    118 
    119133(define-syntax stream-cons
    120134  (syntax-rules ()
    … …  
    123137
    124138(define (stream-pair? obj) (and (%stream? obj) (%stream-pare? (stream-force obj))))
    125 
    126 (define-error-type stream-pair)
    127139
    128140(define (stream-car streem)

  • release/4/srfi-41/trunk/streams-utils.scm

    r14140 r14192  
    2222  (local)
    2323  (no-procedure-checks) ) 
     24
     25(include "chicken-primitive-object-inlines")
     26(include "streams-inlines")
     27(include "inline-type-checks")
     28
     29;;;
     30
     31(define-inline (%check-streams loc strms nam)
     32  (when (%any/1 not-stream? strms)
     33    (error-stream loc strms nam) ) )
    2434
    2535(module streams-utils (;export
    … …  
    5060  stream-minimum)
    5161
    52 (import scheme chicken (only data-structures complement right-section) streams)
    53 
    54 (require-library streams)
     62(import scheme chicken
     63  (only data-structures complement right-section)
     64  streams
     65  (only type-errors error-procedure error-string error-cardinal-integer))
     66
     67(require-library streams type-errors)
    5568
    5669;;;
    5770
     71(define (not-stream? obj) (%not-stream? obj))
     72
     73;;;
     74
    5875(define-stream (stream-intersperse yy x)
     76  (%check-stream 'stream-intersperse yy 'stream)
    5977  (stream-match yy
    60     (()
    61      (stream (stream x)))
     78    (() (stream (stream x)))
    6279    ((y . ys)
    63      (stream-append (stream (stream-cons x yy))
    64                     (stream-map (lambda (z) (stream-cons y z))
    65                                 (stream-intersperse ys x))))))
     80      (stream-append (stream (stream-cons x yy))
     81                     (stream-map (lambda (z) (stream-cons y z))
     82                                 (stream-intersperse ys x))) ) ) )
    6683
    6784(define-stream (stream-permutations xs)
     85  (%check-stream 'stream-permutations xs 'stream)
    6886  (if (stream-null? xs) (stream (stream))
    69       (stream-concat
    70        (stream-map (right-section stream-intersperse (stream-car xs))
    71                    (stream-permutations (stream-cdr xs))))))
     87      (stream-concat (stream-map (right-section stream-intersperse (stream-car xs))
     88                                 (stream-permutations (stream-cdr xs)))) ) )
    7289
    7390(define-stream (file->stream filename #!optional (reader read-char))
     91  (%check-string 'file->streams filename 'filename)
     92  (%check-procedure 'file->streams reader 'reader)
    7493  (let ((port (open-input-file filename)))
    7594    (stream-let loop ((obj (reader port)))
    7695      (if (eof-object? obj) (begin (close-input-port port) stream-null)
    77           (stream-cons obj (loop (reader port)))))))
    78 
    79 (define (stream-split n strm)
    80   (values (stream-take n strm) (stream-drop n strm)))
     96          (stream-cons obj (loop (reader port))) ) ) ) )
     97
     98(define (stream-split count strm)
     99  (%check-stream 'stream-split strm 'stream)
     100  (%check-cardinal-integer 'stream-split count 'count)
     101  (values (stream-take count strm) (stream-drop count strm)))
    81102
    82103(define-stream (stream-unique eql? strm)
    83   (if (stream-null? strm) stream-null
    84       (stream-cons (stream-car strm)
    85                    (stream-unique
    86                     eql?
    87                     (stream-drop-while (lambda (x) (eql? (stream-car strm) x)) strm)))))
     104  (%check-stream 'stream-unique strm 'stream)
     105  (%check-procedure 'stream-unique eql? 'equivalence)
     106  (stream-let loop ((strm strm))
     107    (if (stream-null? strm) stream-null
     108        (stream-cons (stream-car strm)
     109                     (loop (stream-drop-while (lambda (x) (eql? (stream-car strm) x)) strm))) ) ) )
    88110
    89111(define (stream-fold-one func strm)
    90   (stream-fold func (stream-car strm) (stream-cdr strm)))
     112  (%check-stream 'stream-fold-one strm 'stream)
     113  (%check-procedure 'stream-fold-one func 'function)
     114  (stream-fold func (stream-car strm) (stream-cdr strm)) )
    91115
    92116(define-stream (stream-member eql? obj strm)
     117  (%check-stream 'stream-member strm 'stream)
     118  (%check-procedure 'stream-member eql? 'equivalence)
    93119  (stream-let loop ((strm strm))
    94120    (cond ((stream-null? strm)          #f)
    95121          ((eql? obj (stream-car strm)) strm)
    96           (else (loop (stream-cdr strm))))))
     122          (else (loop (stream-cdr strm)) ) ) ) )
    97123
    98124(define-stream (stream-merge lt? . strms)
    99   (define-stream (merge-stream xx yy)
     125
     126  (define-stream (stream-merge$ xx yy)
    100127    (stream-match xx
    101       (()
    102        yy)
     128      (() yy )
    103129      ((x . xs)
    104        (stream-match yy
    105          (()
    106           xx)
    107          ((y . ys)
    108           (if (lt? y x) (stream-cons y (merge-stream xx ys))
    109               (stream-cons x (merge-stream xs yy))))))))
     130        (stream-match yy
     131          (() xx )
     132          ((y . ys)
     133            (if (lt? y x) (stream-cons y (stream-merge$ xx ys))
     134                (stream-cons x (stream-merge$ xs yy))))) ) ) )
     135
     136  (%check-procedure 'stream-merge lt? 'less-than)
     137  (%check-streams 'stream-merge strms 'stream)
    110138  (stream-let loop ((strms strms))
    111139    (cond ((null? strms)        stream-null)
    112           ((null? (cdr strms))  (car strms))
    113           (else (merge-stream (car strms) (apply stream-merge lt? (cdr strms)))))))
     140          ((null? (%cdr strms)) (%car strms))
     141          (else (stream-merge$ (%car strms) (apply stream-merge lt? (%cdr strms))) ) ) ) )
    114142
    115143(define (stream-partition pred? strm)
     144  (%check-stream 'stream-partition strm 'stream)
     145  (%check-procedure 'stream-partition pred? 'predicate)
    116146  (stream-unfolds
    117147   (lambda (s)
    … …  
    120150               (d (stream-cdr s)))
    121151           (if (pred? a) (values d (list a) #f)
    122                (values d #f (list a))))))
    123    strm))
     152               (values d #f (list a)) ) ) ) )
     153   strm) )
    124154
    125155(define-stream (stream-finds eql? obj strm)
    126   (stream-of (car x)
     156  (%check-stream 'stream-finds strm 'stream)
     157  (%check-procedure 'stream-finds eql? 'equivalence)
     158  (stream-of (%car x)
    127159             (x in (stream-zip (stream-from 0) strm))
    128              (eql? obj (cadr x))))
     160             (eql? obj (%cadr x))) )
    129161
    130162(define (stream-find eql? obj strm)
    131   (stream-car (stream-append (stream-finds eql? obj strm) (stream #f))))
     163  (%check-stream 'stream-find strm 'stream)
     164  (%check-procedure 'stream-find eql? 'equivalence)
     165  (stream-car (stream-append (stream-finds eql? obj strm) (stream #f))) )
    132166
    133167(define-stream (stream-remove pred? strm)
    134   (stream-filter (complement pred?) strm))
     168  (%check-stream 'stream-remove strm 'stream)
     169  (%check-procedure 'stream-remove pred? 'predicate)
     170  (stream-filter (complement pred?) strm) )
    135171
    136172(define (stream-every pred? strm)
     173  (%check-stream 'stream-every strm 'stream)
     174  (%check-procedure 'stream-every pred? 'predicate)
    137175  (let loop ((strm strm))
    138176    (cond ((stream-null? strm)              #t)
    139177          ((not (pred? (stream-car strm)))  #f)
    140           (else (loop (stream-cdr strm))))))
     178          (else (loop (stream-cdr strm)) ) ) ) )
    141179
    142180(define (stream-any pred? strm)
     181  (%check-stream 'stream-any strm 'stream)
     182  (%check-procedure 'stream-any pred? 'predicate)
    143183  (let loop ((strm strm))
    144184    (cond ((stream-null? strm)        #f)
    145185          ((pred? (stream-car strm))  #t)
    146           (else (loop (stream-cdr strm))))))
     186          (else (loop (stream-cdr strm)) ) ) ) )
    147187
    148188(define (stream-and strm)
     189  (%check-stream 'stream-and strm 'stream)
    149190  (let loop ((strm strm))
    150191    (cond ((stream-null? strm)      #t)
    151192          ((not (stream-car strm))  #f)
    152           (else (loop (stream-cdr strm))))))
     193          (else (loop (stream-cdr strm)) ) ) ) )
    153194
    154195(define (stream-or strm)
     196  (%check-stream 'stream-or strm 'stream)
    155197  (let loop ((strm strm))
    156198    (cond ((stream-null? strm)  #f)
    157199          ((stream-car strm)    #t)
    158           (else (loop (stream-cdr strm))))))
     200          (else (loop (stream-cdr strm)) ) ) ) )
    159201
    160202(define (stream-fold-right func base strm)
    161   (let loop ((base base) (strm strm))
     203  (%check-stream 'stream-fold-right strm 'stream)
     204  (%check-procedure 'stream-fold-right func 'function)
     205  (let loop ((strm strm))
    162206    (if (stream-null? strm) base
    163         (func (stream-car strm) (loop base (stream-cdr strm))))))
     207        (func (stream-car strm) (loop (stream-cdr strm))) ) ) )
    164208
    165209(define (stream-fold-right-one func strm)
    166   (stream-match strm
    167     ((x)
    168      x)
    169     ((x . xs)
    170      (func x (stream-fold-right-one func xs)))))
    171 
    172 (define (stream-assoc key dict)
    173     (cond ((stream-null? dict)                  #f)
    174           ((equal? key (car (stream-car dict))) (stream-car dict))
    175           (else (stream-assoc key (stream-cdr dict)))))
     210  (%check-stream 'stream-fold-right-one strm 'stream)
     211  (%check-procedure 'stream-fold-right-one func 'function)
     212  (let loop ((strm strm))
     213    (stream-match strm
     214      ((x) x )
     215      ((x . xs) (func x (loop xs)) ) ) ) )
     216
     217(define (stream-assoc key dict #!optional (eql? equal?))
     218  (%check-stream 'stream-assoc dict 'stream)
     219  (%check-procedure 'stream-assoc eql? 'equivalence)
     220  (let loop ((dict dict))
     221    (cond ((stream-null? dict) #f)
     222          ((eql? key (%car (stream-car dict))) (stream-car dict) )
     223          (else (loop (stream-cdr dict)) ) ) ) )
    176224
    177225(define (stream-equal? eql? xs ys)
    178   (cond ((and (stream-null? xs) (stream-null? ys))    #t)
    179         ((or (stream-null? xs) (stream-null? ys))     #f)
    180         ((not (eql? (stream-car xs) (stream-car ys))) #f)
    181         (else (stream-equal? eql? (stream-cdr xs) (stream-cdr ys)))))
     226  (%check-stream 'stream-equal? xs 'stream1)
     227  (%check-stream 'stream-equal? ys 'stream2)
     228  (let loop ((xs xs) (ys ys))
     229    (cond ((and (stream-null? xs) (stream-null? ys))    #t)
     230          ((or (stream-null? xs) (stream-null? ys))     #f)
     231          ((not (eql? (stream-car xs) (stream-car ys))) #f)
     232          (else (loop (stream-cdr xs) (stream-cdr ys)) ) ) ) )
    182233
    183234(define-stream (stream-quick-sort lt? strm)
     235  (%check-stream 'stream-quick-sort strm 'stream)
     236  (%check-procedure 'stream-quick-sort lt? 'less-than)
    184237  (let loop ((strm strm))
    185238    (if (stream-null? strm) stream-null
    … …  
    188241          (stream-append (loop (stream-filter (lambda (u) (lt? u x)) xs))
    189242                         (stream x)
    190                          (loop (stream-filter (lambda (u) (not (lt? u x))) xs)))))))
     243                         (loop (stream-filter (lambda (u) (not (lt? u x))) xs))) ) ) ) )
    191244
    192245(define-stream (stream-insertion-sort lt? strm)
    193   (define-stream (insert strm x)
     246
     247  (define-stream (insert$ strm x)
    194248    (stream-match strm
    195249      (()
    196        (stream x))
     250        (stream x) )
    197251      ((y . ys)
    198        (if (lt? y x) (stream-cons y (insert ys x))
    199            (stream-cons x strm)))))
    200   (stream-fold insert stream-null strm))
     252        (if (lt? y x) (stream-cons y (insert$ ys x))
     253            (stream-cons x strm) ) ) ) )
     254
     255  (%check-stream 'stream-insertion-sort strm 'stream)
     256  (%check-procedure 'stream-insertion-sort lt? 'less-than)
     257  (stream-fold insert$ stream-null strm) )
    201258
    202259(define-stream (stream-merge-sort lt? strm)
     260  (%check-stream 'stream-merge-sort strm 'stream)
     261  (%check-procedure 'stream-merge-sort lt? 'less-than)
    203262  (let loop ((strm strm))
    204263    (let ((n (quotient (stream-length strm) 2)))
    205264      (if (zero? n) strm
    206           (stream-merge lt? (loop (stream-take n strm)) (loop (stream-drop n strm)))))))
     265          (stream-merge lt? (loop (stream-take n strm)) (loop (stream-drop n strm))) ) ) ) )
    207266
    208267(define (stream-maximum lt? strm)
    209   (stream-fold-one (lambda (x y) (if (lt? x y) y x)) strm))
     268  (%check-stream 'stream-maximum strm 'stream)
     269  (%check-procedure 'stream-maximum lt? 'less-than)
     270  (stream-fold-one (lambda (x y) (if (lt? x y) y x)) strm) )
    210271
    211272(define (stream-minimum lt? strm)
    212   (stream-fold-one (lambda (x y) (if (lt? x y) x y)) strm))
     273  (%check-stream 'stream-minimum strm 'stream)
     274  (%check-procedure 'stream-minimum lt? 'less-than)
     275  (stream-fold-one (lambda (x y) (if (lt? x y) x y)) strm) )
    213276
    214277) ;module streams-utils

  • release/4/srfi-41/trunk/streams.scm

    r14140 r14192  
    2323  stream-iterate stream-length stream-let stream-map stream-match
    2424  stream-of stream-range stream-ref stream-reverse stream-scan stream-take
    25   stream-take-while stream-unfold stream-unfolds stream-zip)
     25  stream-take-while stream-unfold stream-unfolds stream-zip
     26  ;; Extras
     27  stream-occupied?
     28  ;; Common errors
     29  check-stream error-stream
     30  check-stream-occupied error-stream-occupied)
    2631
    2732(import scheme chicken streams-primitive streams-derived)
    28 
    2933(require-library streams-primitive streams-derived)
    3034

  • release/4/srfi-41/trunk/tests/run.scm

    r14176 r14192  
    2424    ((tester descrip expr result)
    2525      (let ((val (handle-exceptions exp
    26 (begin
    27 #;(apply print ((condition-property-accessor 'exn 'location) exp) " : " ((condition-property-accessor 'exn 'message) exp) " : " ((condition-property-accessor 'exn 'arguments) exp))
    2826                     (string-append
    2927                       (symbol->string ((condition-property-accessor 'exn 'location) exp))
    3028                       ": " ((condition-property-accessor 'exn 'message) exp))
    31 )
    3229                   expr ) ) )
    3330        (unless (equal? val result)
    … …  
    122119  ; stream->list
    123120  (tester (stream->list '()) "stream->list: bad `stream' argument type - expected a stream")
    124   (tester (stream->list "four" strm123) "stream->list: bad `length' argument type - expected a cardinal-integer")
    125   (tester (stream->list -1 strm123) "stream->list: bad `length' argument type - expected a cardinal-integer")
     121  (tester (stream->list "four" strm123) "stream->list: bad `count' argument type - expected a cardinal-integer")
     122  (tester (stream->list -1 strm123) "stream->list: bad `count' argument type - expected a cardinal-integer")
    126123  (tester (stream->list (stream)) '())
    127124  (tester (stream->list strm123) '(1 2 3))
    … …  
    364361;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; leak tests
    365362
    366 (define-constant SIZE 1000)
     363(define-constant SIZE 1000000)
    367364
    368365;;
Note: See TracChangeset for help on using the changeset viewer.