Changeset 39713 in project


Ignore:
Timestamp:
03/14/21 22:29:44 (6 weeks ago)
Author:
Kon Lovett
Message:

remove "primitives", replace inline type checks

Location:
release/5/srfi-41/trunk
Files:
2 deleted
5 edited

Legend:

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

    r39709 r39713  
    6363  (srfi 23)
    6464  (only (srfi-1) any)
    65   streams-primitive
    66   (only type-errors
    67     error-number error-procedure
    68     error-natural-integer
    69     error-input-port error-list))
    70 
    71 (define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
    72 
    73 (include-relative "inline-type-checks")
    74 
    75 (include-relative "streams-inlines")
     65  (only type-checks
     66    check-number check-procedure
     67    check-natural-integer
     68    check-input-port check-list)
     69  streams-primitive)
    7670
    7771;;;
     72
     73(define-inline (%check-streams loc strms #!optional argnam)
     74  (when (null? strms) (error loc "no stream arguments" strms))
     75  (for-each (cut check-stream loc <> argnam) strms)
     76  strms )
    7877
    7978;;fx-inlines.scm
     
    187186      (stream-cons (car objs) (list->stream$ (cdr objs))) ) )
    188187  ;
    189   (list->stream$ (%check-list 'list->stream objects 'objects)) )
     188  (list->stream$ (check-list 'list->stream objects 'objects)) )
    190189
    191190(define (stream->list . args)
    192191  (let* ((count (and (fx< 1 (length args))
    193                      (%check-natural-integer 'stream->list (car args) 'count)))
     192                     (check-natural-integer 'stream->list (car args) 'count)))
    194193         (strm (if count (cadr args) (car args)))
    195194         (count (or count -1)) )
    196     (let loop ((n count) (strm (%check-stream 'stream->list strm 'stream)))
     195    (let loop ((n count) (strm (check-stream 'stream->list strm 'stream)))
    197196      (if (or (fxzero? n) (stream-null? strm)) '()
    198197        (cons (stream-car strm) (loop (fxsub1 n) (stream-cdr strm))) ) ) ) )
     
    206205  ;
    207206  (let ((port (if (null? port) (current-input-port) (car port))))
    208     (port->stream$ (%check-input-port 'port->stream port 'port))) )
     207    (port->stream$ (check-input-port 'port->stream port 'port))) )
    209208
    210209(define (stream-length strm)
    211   (let loop ((len 0) (strm (%check-stream 'stream-length strm 'stream)))
     210  (let loop ((len 0) (strm (check-stream 'stream-length strm 'stream)))
    212211    (if (stream-null? strm) len
    213212      (loop (fxadd1 len) (stream-cdr strm)) ) ) )
    214213
    215214(define (stream-ref strm index)
    216   (let loop ((strm (%check-stream 'stream-ref strm 'stream))
    217              (n (%check-natural-integer 'stream-ref index 'index)))
     215  (let loop ((strm (check-stream 'stream-ref strm 'stream))
     216             (n (check-natural-integer 'stream-ref index 'index)))
    218217    (cond
    219218      ((stream-null? strm)
     
    230229      (stream-reverse$ (stream-cdr strm) (stream-cons (stream-car strm) rev)) ) )
    231230  ;
    232   (stream-reverse$ (%check-stream 'stream-reverse strm 'stream) stream-null) )
     231  (stream-reverse$ (check-stream 'stream-reverse strm 'stream) stream-null) )
    233232
    234233(define (stream-append . strms)
     
    266265              (stream-cdr strm)))) ) ) )
    267266  ;
    268   (stream-concat$ (%check-stream 'stream-concat strm 'stream)) )
     267  (stream-concat$ (check-stream 'stream-concat strm 'stream)) )
    269268
    270269(define (stream-drop count strm)
     
    275274  ;
    276275  (stream-drop$
    277     (%check-natural-integer 'stream-drop count 'count)
    278     (%check-stream 'stream-drop strm 'stream)) )
     276    (check-natural-integer 'stream-drop count 'count)
     277    (check-stream 'stream-drop strm 'stream)) )
    279278
    280279(define (stream-drop-while predicate? strm)
     
    284283      (stream-drop-while$ (stream-cdr strm)) ) )
    285284  ;
    286   (%check-procedure 'stream-drop-while predicate? 'predicate?)
    287   (stream-drop-while$ (%check-stream 'stream-drop-while strm 'stream)) )
     285  (check-procedure 'stream-drop-while predicate? 'predicate?)
     286  (stream-drop-while$ (check-stream 'stream-drop-while strm 'stream)) )
    288287
    289288(define (stream-take count strm)
     
    296295  ;
    297296  (stream-take$
    298     (%check-natural-integer 'stream-take count 'count)
    299     (%check-stream 'stream-take strm 'stream)) )
     297    (check-natural-integer 'stream-take count 'count)
     298    (check-stream 'stream-take strm 'stream)) )
    300299
    301300(define (stream-take-while predicate? strm)
     
    310309        stream-null ) ) )
    311310  ;
    312   (%check-procedure 'stream-take-while predicate? 'predicate?)
    313   (stream-take-while$ (%check-stream 'stream-take-while strm 'stream)) )
     311  (check-procedure 'stream-take-while predicate? 'predicate?)
     312  (stream-take-while$ (check-stream 'stream-take-while strm 'stream)) )
    314313
    315314(define (stream-filter predicate? strm)
     
    324323        (stream-filter$ (stream-cdr strm)) ) ) )
    325324  ;
    326   (%check-procedure 'stream-filter predicate? 'predicate?)
    327   (stream-filter$ (%check-stream 'stream-filter strm 'stream)) )
     325  (check-procedure 'stream-filter predicate? 'predicate?)
     326  (stream-filter$ (check-stream 'stream-filter strm 'stream)) )
    328327
    329328(define (stream-scan function base strm)
     
    335334        (stream-scan$ (function base (stream-car strm)) (stream-cdr strm))) ) )
    336335  ;
    337   (%check-procedure 'stream-scan function 'function)
    338   (stream-scan$ base (%check-stream 'stream-scan strm 'stream)) )
     336  (check-procedure 'stream-scan function 'function)
     337  (stream-scan$ base (check-stream 'stream-scan strm 'stream)) )
    339338
    340339(define (stream-fold function base . strms)
     
    346345        (map stream-cdr strms)) ) )
    347346  ;
    348   (%check-procedure 'stream-fold function 'function)
     347  (check-procedure 'stream-fold function 'function)
    349348  (stream-folder base (%check-streams 'stream-fold strms 'stream)) )
    350349
     
    356355      (stream-for-eacher (map stream-cdr strms)) ) )
    357356  ;
    358   (%check-procedure 'stream-for-each procedure 'procedure)
     357  (check-procedure 'stream-for-each procedure 'procedure)
    359358  (stream-for-eacher (%check-streams 'stream-for-each strms 'stream)) )
    360359
     
    368367        (stream-map$ (map stream-cdr strms))) ) )
    369368  ;
    370   (%check-procedure 'stream-map function 'function)
     369  (check-procedure 'stream-map function 'function)
    371370  (stream-map$ (%check-streams 'stream-map strms 'stream)) )
    372371
     
    378377  (let ((delta (if (null? step) 1 (car step))))
    379378    (stream-from$
    380       (%check-number 'stream-from first 'first)
    381       (%check-number 'stream-from delta 'delta)) ) )
     379      (check-number 'stream-from first 'first)
     380      (check-number 'stream-from delta 'delta)) ) )
    382381
    383382(define (stream-iterate function base)
     
    386385    (stream-cons base (stream-iterate$ (function base))) )
    387386  ;
    388   (%check-procedure 'stream-iterate function 'function)
     387  (check-procedure 'stream-iterate function 'function)
    389388  (stream-iterate$ base) )
    390389
     
    395394      (stream-cons first (stream-range$ (fx+ first delta) past delta lt?)) ) )
    396395  ;
    397   (%check-number 'stream-range first 'first)
    398   (%check-number 'stream-range past 'past)
     396  (check-number 'stream-range first 'first)
     397  (check-number 'stream-range past 'past)
    399398  (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
    400     (%check-number 'stream-range delta 'delta)
     399    (check-number 'stream-range delta 'delta)
    401400    (let ((lt? (if (< 0 delta) < >)))
    402401      (stream-range$ first past delta lt?) ) ) )
     
    408407      (stream-cons (mapper base) (stream-unfold$ (generator base))) ) )
    409408  ;
    410   (%check-procedure 'stream-unfold mapper 'mapper)
    411   (%check-procedure 'stream-unfold predicate? 'predicate?)
    412   (%check-procedure 'stream-unfold generator 'generator)
     409  (check-procedure 'stream-unfold mapper 'mapper)
     410  (check-procedure 'stream-unfold predicate? 'predicate?)
     411  (check-procedure 'stream-unfold generator 'generator)
    413412  (stream-unfold$ base) )
    414413
     
    445444        (loop (fxsub1 i) (cons (result-stream->output-stream result-stream i) outputs)) ) ) )
    446445  ;
    447   (%check-procedure 'stream-unfolds generator 'generator)
     446  (check-procedure 'stream-unfolds generator 'generator)
    448447  (result-stream->output-strms (unfold-result-stream seed)) )
    449448
  • release/5/srfi-41/trunk/streams-math.scm

    r39709 r39713  
    4141  streams-utils)
    4242
    43 (define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
    44 
    45 (include-relative "streams-inlines")
    46 
    4743;;; Section Combinators
    4844
     
    5248
    5349(define (stream-max strm)
    54   (stream-fold-one max (%check-stream 'stream-max strm 'stream)) )
     50  (stream-fold-one max (check-stream 'stream-max strm 'stream)) )
    5551
    5652(define (stream-min strm)
    57   (stream-fold-one min (%check-stream 'stream-min strm 'stream)) )
     53  (stream-fold-one min (check-stream 'stream-min strm 'stream)) )
    5854
    5955(define stream-sum (left-section stream-fold + 0))
  • release/5/srfi-41/trunk/streams-primitive.scm

    r39709 r39713  
    2323  stream-null
    2424  stream-null?
    25   (stream-cons $make-stream-pair$)
     25  stream-cons
    2626  stream-pair?
    2727  stream-car
     
    4949  record-variants)
    5050
    51 (define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
    52 
    53 (include "streams-inlines")
    54 
    5551;;;
    5652
     
    5955(define-record-type-variant stream (unsafe unchecked inline)
    6056  (%make-stream prom)
    61   ($stream?)  ;ignore since %stream? conflicts with predefined inline
     57  (%stream?)
    6258  (prom %stream-promise %stream-promise-set!) )
    63 
    64 (define-check+error-type stream %stream?)
    6559
    6660(define-inline (stream-tagged-pair? obj)
     
    7973(define-inline (make-stream-eager-box obj) (make-stream-box 'eager obj))
    8074
     75(define-inline (stream-lazy-box? obj) (eq? 'lazy (stream-box-tag obj)))
     76(define-inline (stream-eager-box? obj) (eq? 'eager (stream-box-tag obj)))
     77
    8178(define-inline (check-stream-box loc obj)
    8279  (unless (stream-tagged-pair? obj)
     
    8481  obj )
    8582
     83(define (stream-print obj out)
     84  (display "#<" out)
     85  (let ((promise (%stream-promise obj)))
     86    (cond
     87      ((stream-eager-box? promise)  (display "eager stream" out))
     88      ((stream-lazy-box? promise)   (display "lazy stream" out))
     89      (else
     90        (display "unknown stream " out) (display promise out)) ) )
     91  (display ">" out) )
     92
    8693;;;
    8794
     
    103110    (($stream-delay$ ?expr)
    104111      ($stream-lazy$ ($stream-eager$ ?expr)) ) ) )
     112
     113;;;
     114
     115(define (stream? obj) (%stream? obj))
     116
     117(define-check+error-type stream)
    105118
    106119(define (stream-force prom)
     
    127140          (stream-force prom) ) ) ) ) )
    128141
    129 ;;;
    130 
    131 (define (stream? obj) (%stream? obj))
    132 
    133142(define stream-null ($stream-delay$ (cons 'stream 'null)))
    134143
     
    173182          (error-stream-pair loc val 'stream)) ) ) ) )
    174183
     184(define (stream-pair-print obj out)
     185  (display "#<" out)
     186  (display (%stream-car obj) out)
     187  (display " " out)
     188  (display (%stream-cdr obj) out)
     189  (display ">" out) )
     190
    175191(define-syntax stream-cons
    176192  (syntax-rules ()
     
    187203  (%stream-cdr (checked-stream-pair 'stream-cdr strm)) )
    188204
     205;;;
     206
     207(set! (record-printer stream) stream-print)
     208
     209(set! (record-printer stream-pair) stream-pair-print)
     210
    189211) ;module streams-primitive
  • release/5/srfi-41/trunk/streams-queue.scm

    r39711 r39713  
    2929;;;
    3030
    31 (define-inline (finalize-queue f r)
     31(define (finalize-queue f r)
    3232  (if (fx< (stream-length r) (stream-length f))
    3333    (cons f r)
  • release/5/srfi-41/trunk/streams-utils.scm

    r39709 r39713  
    5151  (chicken type)
    5252  (chicken syntax)
    53   streams
    54   (only type-errors
    55     error-list error-procedure
    56     error-string error-natural-integer))
    57 
    58 (define-inline (%structure-instance? x s) (##core#inline "C_i_structurep" x s))
    59 
    60 (include-relative "inline-type-checks")
    61 
    62 (include-relative "streams-inlines")
     53  (only type-checks
     54    check-list check-procedure
     55    check-string check-natural-integer)
     56  streams)
    6357
    6458;;;
     59
     60(define-inline (%check-streams loc strms #!optional argnam)
     61  (when (null? strms) (error loc "no stream arguments" strms))
     62  (for-each (cut check-stream loc <> argnam) strms)
     63  strms )
    6564
    6665;(append xs args) = (reverse (append (reverse args) (reverse xs)))
     
    7069
    7170(define-stream (stream-intersperse yy x)
    72   (stream-match (%check-stream 'stream-intersperse yy 'stream)
     71  (stream-match (check-stream 'stream-intersperse yy 'stream)
    7372    (()
    7473      (stream (stream x)) )
     
    7978
    8079(define-stream (stream-permutations xs)
    81   (if (stream-null? (%check-stream 'stream-permutations xs 'stream))
     80  (if (stream-null? (check-stream 'stream-permutations xs 'stream))
    8281    (stream (stream))
    8382    (stream-concat
     
    8786
    8887(define-stream (file->stream filename #!optional (reader read-char))
    89   (%check-procedure 'file->streams reader 'reader)
    90   (let ((port (open-input-file (%check-string 'file->streams filename 'filename))))
     88  (check-procedure 'file->streams reader 'reader)
     89  (let ((port (open-input-file (check-string 'file->streams filename 'filename))))
    9190    (stream-let loop ((item (reader port)))
    9291      (if (eof-object? item)
     
    9594
    9695(define (stream-split count strm)
    97   (%check-stream 'stream-split strm 'stream)
    98   (%check-natural-integer 'stream-split count 'count)
     96  (check-stream 'stream-split strm 'stream)
     97  (check-natural-integer 'stream-split count 'count)
    9998  (values (stream-take count strm) (stream-drop count strm)))
    10099
    101100(define-stream (stream-unique eql? strm)
    102   (%check-procedure 'stream-unique eql? 'equivalence)
    103   (stream-let loop ((strm (%check-stream 'stream-unique strm 'stream)))
     101  (check-procedure 'stream-unique eql? 'equivalence)
     102  (stream-let loop ((strm (check-stream 'stream-unique strm 'stream)))
    104103    (if (stream-null? strm)
    105104      stream-null
     
    109108
    110109(define (stream-fold-one func strm)
    111   (%check-stream 'stream-fold-one strm 'stream)
     110  (check-stream 'stream-fold-one strm 'stream)
    112111  (stream-fold
    113     (%check-procedure 'stream-fold-one func 'function)
     112    (check-procedure 'stream-fold-one func 'function)
    114113    (stream-car strm)
    115114    (stream-cdr strm)) )
    116115
    117116(define-stream (stream-member eql? item strm)
    118   (%check-procedure 'stream-member eql? 'equivalence)
    119   (stream-let loop ((strm (%check-stream 'stream-member strm 'stream)))
     117  (check-procedure 'stream-member eql? 'equivalence)
     118  (stream-let loop ((strm (check-stream 'stream-member strm 'stream)))
    120119    (cond
    121120      ((stream-null? strm)
     
    139138              (stream-cons x (stream-merge$ xs yy))))) ) ) )
    140139  ;
    141   (%check-procedure 'stream-merge lt? 'less-than)
     140  (check-procedure 'stream-merge lt? 'less-than)
    142141  (stream-let loop ((strms (%check-streams 'stream-merge strms 'stream)))
    143142    (cond
     
    150149
    151150(define (stream-partition pred? strm)
    152   (%check-procedure 'stream-partition pred? 'predicate)
     151  (check-procedure 'stream-partition pred? 'predicate)
    153152  (stream-unfolds
    154153    (lambda (s)
     
    159158            (values d (list a) #f)
    160159            (values d #f (list a)) ) ) ) )
    161     (%check-stream 'stream-partition strm 'stream)) )
     160    (check-stream 'stream-partition strm 'stream)) )
    162161
    163162(define-stream (stream-finds eql? item strm)
    164   (%check-procedure 'stream-finds eql? 'equivalence)
     163  (check-procedure 'stream-finds eql? 'equivalence)
    165164  (stream-of
    166165    (car x)
    167     (x in (stream-zip (stream-from 0) (%check-stream 'stream-finds strm 'stream)))
     166    (x in (stream-zip (stream-from 0) (check-stream 'stream-finds strm 'stream)))
    168167    (eql? item (cadr x))) )
    169168
    170169(define (stream-find eql? item strm)
    171   (%check-stream 'stream-find strm 'stream)
    172   (%check-procedure 'stream-find eql? 'equivalence)
     170  (check-stream 'stream-find strm 'stream)
     171  (check-procedure 'stream-find eql? 'equivalence)
    173172  (stream-car (stream-append (stream-finds eql? item strm) (stream #f))) )
    174173
    175174(define-stream (stream-remove pred? strm)
    176   (%check-procedure 'stream-remove pred? 'predicate)
    177   (stream-filter (complement pred?) (%check-stream 'stream-remove strm 'stream)) )
     175  (check-procedure 'stream-remove pred? 'predicate)
     176  (stream-filter (complement pred?) (check-stream 'stream-remove strm 'stream)) )
    178177
    179178(define (stream-every pred? strm)
    180   (%check-procedure 'stream-every pred? 'predicate)
    181   (let loop ((strm (%check-stream 'stream-every strm 'stream)))
     179  (check-procedure 'stream-every pred? 'predicate)
     180  (let loop ((strm (check-stream 'stream-every strm 'stream)))
    182181    (cond
    183182      ((stream-null? strm)
     
    189188
    190189(define (stream-any pred? strm)
    191   (%check-procedure 'stream-any pred? 'predicate)
    192   (let loop ((strm (%check-stream 'stream-any strm 'stream)))
     190  (check-procedure 'stream-any pred? 'predicate)
     191  (let loop ((strm (check-stream 'stream-any strm 'stream)))
    193192    (cond
    194193      ((stream-null? strm)
     
    200199
    201200(define (stream-and strm)
    202   (let loop ((strm (%check-stream 'stream-and strm 'stream)))
     201  (let loop ((strm (check-stream 'stream-and strm 'stream)))
    203202    (cond
    204203      ((stream-null? strm)
     
    210209
    211210(define (stream-or strm)
    212   (%check-stream 'stream-or strm 'stream)
     211  (check-stream 'stream-or strm 'stream)
    213212  (let loop ((strm strm))
    214213    (cond
     
    221220
    222221(define (stream-fold-right func base strm)
    223   (%check-procedure 'stream-fold-right func 'function)
    224   (let loop ((strm (%check-stream 'stream-fold-right strm 'stream)))
     222  (check-procedure 'stream-fold-right func 'function)
     223  (let loop ((strm (check-stream 'stream-fold-right strm 'stream)))
    225224    (if (stream-null? strm)
    226225      base
     
    228227
    229228(define (stream-fold-right-one func strm)
    230   (%check-procedure 'stream-fold-right-one func 'function)
    231   (let loop ((strm (%check-stream 'stream-fold-right-one strm 'stream)))
     229  (check-procedure 'stream-fold-right-one func 'function)
     230  (let loop ((strm (check-stream 'stream-fold-right-one strm 'stream)))
    232231    (stream-match strm
    233232      ((x) x )
     
    235234
    236235(define (stream-assoc key dict #!optional (eql? equal?))
    237   (%check-procedure 'stream-assoc eql? 'equivalence)
    238   (let loop ((dict (%check-stream 'stream-assoc dict 'stream)))
     236  (check-procedure 'stream-assoc eql? 'equivalence)
     237  (let loop ((dict (check-stream 'stream-assoc dict 'stream)))
    239238    (cond
    240239      ((stream-null? dict)
     
    247246; May never return
    248247(define (stream-equal? eql? xs ys)
    249   (let loop ((xs (%check-stream 'stream-equal? xs 'stream1))
    250              (ys (%check-stream 'stream-equal? ys 'stream2)))
     248  (let loop ((xs (check-stream 'stream-equal? xs 'stream1))
     249             (ys (check-stream 'stream-equal? ys 'stream2)))
    251250    (cond
    252251      ((and (stream-null? xs) (stream-null? ys))
     
    260259
    261260(define-stream (stream-quick-sort lt? strm)
    262   (%check-procedure 'stream-quick-sort lt? 'less-than)
    263   (let loop ((strm (%check-stream 'stream-quick-sort strm 'stream)))
     261  (check-procedure 'stream-quick-sort lt? 'less-than)
     262  (let loop ((strm (check-stream 'stream-quick-sort strm 'stream)))
    264263    (if (stream-null? strm)
    265264      stream-null
     
    281280          (stream-cons x strm) ) ) ) )
    282281  ;
    283   (%check-procedure 'stream-insertion-sort lt? 'less-than)
    284   (stream-fold insert$ stream-null (%check-stream 'stream-insertion-sort strm 'stream)) )
     282  (check-procedure 'stream-insertion-sort lt? 'less-than)
     283  (stream-fold insert$ stream-null (check-stream 'stream-insertion-sort strm 'stream)) )
    285284
    286285(define-stream (stream-merge-sort lt? strm)
    287   (%check-procedure 'stream-merge-sort lt? 'less-than)
    288   (let loop ((strm (%check-stream 'stream-merge-sort strm 'stream)))
     286  (check-procedure 'stream-merge-sort lt? 'less-than)
     287  (let loop ((strm (check-stream 'stream-merge-sort strm 'stream)))
    289288    (let ((n (quotient (stream-length strm) 2)))
    290289      (if (zero? n)
     
    293292
    294293(define (stream-maximum lt? strm)
    295   (%check-procedure 'stream-maximum lt? 'less-than)
     294  (check-procedure 'stream-maximum lt? 'less-than)
    296295  (stream-fold-one
    297296    (lambda (x y) (if (lt? x y) y x))
    298     (%check-stream 'stream-maximum strm 'stream)) )
     297    (check-stream 'stream-maximum strm 'stream)) )
    299298
    300299(define (stream-minimum lt? strm)
    301   (%check-procedure 'stream-minimum lt? 'less-than)
     300  (check-procedure 'stream-minimum lt? 'less-than)
    302301  (stream-fold-one
    303302    (lambda (x y) (if (lt? x y) x y))
    304     (%check-stream 'stream-minimum strm 'stream)) )
     303    (check-stream 'stream-minimum strm 'stream)) )
    305304
    306305;; Lazy binary-tree "same fringe"
     
    317316        (stream-cons (car tree) (flatten (cdr tree))) ) ) )
    318317  ;
    319   (let loop ((t1 (flatten (%check-list 'same-fringe? tree1 'tree1)))
    320              (t2 (flatten (%check-list 'same-fringe? tree2 'tree2))))
     318  (let loop ((t1 (flatten (check-list 'same-fringe? tree1 'tree1)))
     319             (t2 (flatten (check-list 'same-fringe? tree2 'tree2))))
    321320    (cond
    322321      ((and (stream-null? t1) (stream-null? t2))
Note: See TracChangeset for help on using the changeset viewer.