Changeset 39707 in project


Ignore:
Timestamp:
03/14/21 20:38:40 (5 weeks ago)
Author:
Kon Lovett
Message:

partial primitive removal

Location:
release/5/srfi-41/trunk
Files:
6 edited

Legend:

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

    r39706 r39707  
    5858(import scheme
    5959  (chicken base)
     60  (chicken fixnum)
    6061  (srfi 9)
    6162  (srfi 23)
     63  (only (srfi-1) any)
    6264  streams-primitive
    6365  (only type-errors
     
    6769
    6870(include-relative "chicken-primitive-object-inlines")
     71(include-relative "inline-type-checks")
     72
    6973(include-relative "streams-inlines")
    70 (include-relative "inline-type-checks")
     74
     75;;;
     76
     77;;fx-inlines.scm
     78
     79(define (fxzero? n) (fx= 0 n))
     80(define (fxadd1 n) (fx+ n 1))
     81(define (fxsub1 n) (fx- n 1))
    7182
    7283;;;
     
    159170  (stream-lambda objs
    160171    (cond
    161       ((%null? objs)
     172      ((null? objs)
    162173        stream-null )
    163       ((%null? (%cdr objs))
    164         (stream-cons (%car objs) (stream-constant (%car objs))) )
     174      ((null? (cdr objs))
     175        (stream-cons (car objs) (stream-constant (car objs))) )
    165176      (else
    166177        (stream-cons
    167           (%car objs)
    168           (apply stream-constant (append (%cdr objs) (%list/1 (%car objs))))) ) ) ) )
     178          (car objs)
     179          (apply stream-constant (append (cdr objs) (list (car objs))))) ) ) ) )
    169180
    170181(define (list->stream objects)
    171182  ;
    172183  (define-stream (list->stream$ objs)
    173     (if (%null? objs) stream-null
    174       (stream-cons (%car objs) (list->stream$ (%cdr objs))) ) )
     184    (if (null? objs) stream-null
     185      (stream-cons (car objs) (list->stream$ (cdr objs))) ) )
    175186  ;
    176187  (list->stream$ (%check-list 'list->stream objects 'objects)) )
    177188
    178189(define (stream->list . args)
    179   (let* ((count (and (%fx< 1 (%list-length args))
    180                      (%check-natural-integer 'stream->list (%car args) 'count)))
    181          (strm (if count (%cadr args) (%car args)))
     190  (let* ((count (and (fx< 1 (length args))
     191                     (%check-natural-integer 'stream->list (car args) 'count)))
     192         (strm (if count (cadr args) (car args)))
    182193         (count (or count -1)) )
    183194    (let loop ((n count) (strm (%check-stream 'stream->list strm 'stream)))
    184       (if (or (%fxzero? n) (stream-null? strm)) '()
    185         (%cons (stream-car strm) (loop (%fxsub1 n) (stream-cdr strm))) ) ) ) )
     195      (if (or (fxzero? n) (stream-null? strm)) '()
     196        (cons (stream-car strm) (loop (fxsub1 n) (stream-cdr strm))) ) ) ) )
    186197
    187198(define (port->stream . port)
     
    189200  (define-stream (port->stream$ p)
    190201    (let ((c (read-char p)))
    191       (if (%eof-object? c) stream-null
     202      (if (eof-object? c) stream-null
    192203        (stream-cons c (port->stream$ p)) ) )  )
    193204  ;
    194   (let ((port (if (%null? port) (current-input-port) (%car port))))
     205  (let ((port (if (null? port) (current-input-port) (car port))))
    195206    (port->stream$ (%check-input-port 'port->stream port 'port))) )
    196207
     
    198209  (let loop ((len 0) (strm (%check-stream 'stream-length strm 'stream)))
    199210    (if (stream-null? strm) len
    200       (loop (%fxadd1 len) (stream-cdr strm)) ) ) )
     211      (loop (fxadd1 len) (stream-cdr strm)) ) ) )
    201212
    202213(define (stream-ref strm index)
     
    206217      ((stream-null? strm)
    207218        (##sys#signal-hook #:bounds-error 'stream-ref "beyond end of stream" strm index) )
    208       ((%fxzero? n)
     219      ((fxzero? n)
    209220        (stream-car strm) )
    210221      (else
    211         (loop (stream-cdr strm) (%fxsub1 n)) ) ) ) )
     222        (loop (stream-cdr strm) (fxsub1 n)) ) ) ) )
    212223
    213224(define (stream-reverse strm)
     
    223234  (define-stream (stream-append$ strms)
    224235    (cond
    225       ((%null? (%cdr strms))
    226         (%car strms) )
    227       ((stream-null? (%car strms))
    228         (stream-append$ (%cdr strms)) )
     236      ((null? (cdr strms))
     237        (car strms) )
     238      ((stream-null? (car strms))
     239        (stream-append$ (cdr strms)) )
    229240      (else
    230241        (stream-cons
    231           (stream-car (%car strms))
    232           (stream-append$ (%cons (stream-cdr (%car strms)) (%cdr strms)))) ) ) )
    233   ;
    234   (if (%null? strms) stream-null
     242          (stream-car (car strms))
     243          (stream-append$ (cons (stream-cdr (car strms)) (cdr strms)))) ) ) )
     244  ;
     245  (if (null? strms) stream-null
    235246    (stream-append$ (%check-streams 'stream-append strms 'stream)) ) )
    236247
     
    258269  ;
    259270  (define-stream (stream-drop$ n strm)
    260     (if (or (%fxzero? n) (stream-null? strm)) strm
    261       (stream-drop$ (%fxsub1 n) (stream-cdr strm)) ) )
     271    (if (or (fxzero? n) (stream-null? strm)) strm
     272      (stream-drop$ (fxsub1 n) (stream-cdr strm)) ) )
    262273  ;
    263274  (stream-drop$
     
    277288  ;
    278289  (define-stream (stream-take$ n strm)
    279     (if (or (stream-null? strm) (%fxzero? n)) stream-null
     290    (if (or (stream-null? strm) (fxzero? n)) stream-null
    280291      (stream-cons
    281292        (stream-car strm)
    282         (stream-take$ (%fxsub1 n) (stream-cdr strm))) ) )
     293        (stream-take$ (fxsub1 n) (stream-cdr strm))) ) )
    283294  ;
    284295  (stream-take$
     
    328339  ;
    329340  (define (stream-folder base strms)
    330     (if (%list-any/1 stream-null? strms) base
     341    (if (any stream-null? strms) base
    331342      (stream-folder
    332         (apply function base (%list-map/1 stream-car strms))
    333         (%list-map/1 stream-cdr strms)) ) )
     343        (apply function base (map stream-car strms))
     344        (map stream-cdr strms)) ) )
    334345  ;
    335346  (%check-procedure 'stream-fold function 'function)
     
    339350  ;
    340351  (define (stream-for-eacher strms)
    341     (unless (%list-any/1 stream-null? strms)
    342       (apply procedure (%list-map/1 stream-car strms))
    343       (stream-for-eacher (%list-map/1 stream-cdr strms)) ) )
     352    (unless (any stream-null? strms)
     353      (apply procedure (map stream-car strms))
     354      (stream-for-eacher (map stream-cdr strms)) ) )
    344355  ;
    345356  (%check-procedure 'stream-for-each procedure 'procedure)
     
    350361  ; not tail-recursive to avoid `stream-reverse'
    351362  (define-stream (stream-map$ strms)
    352     (if (%list-any/1 stream-null? strms) stream-null
     363    (if (any stream-null? strms) stream-null
    353364      (stream-cons
    354         (apply function (%list-map/1 stream-car strms))
    355         (stream-map$ (%list-map/1 stream-cdr strms))) ) )
     365        (apply function (map stream-car strms))
     366        (stream-map$ (map stream-cdr strms))) ) )
    356367  ;
    357368  (%check-procedure 'stream-map function 'function)
     
    361372  ;
    362373  (define-stream (stream-from$ first delta)
    363     (stream-cons first (stream-from$ (%fx+ first delta) delta)) )
    364   ;
    365   (let ((delta (if (%null? step) 1 (%car step))))
     374    (stream-cons first (stream-from$ (fx+ first delta) delta)) )
     375  ;
     376  (let ((delta (if (null? step) 1 (car step))))
    366377    (stream-from$
    367378      (%check-number 'stream-from first 'first)
     
    380391  (define-stream (stream-range$ first past delta lt?)
    381392    (if (not (lt? first past)) stream-null
    382       (stream-cons first (stream-range$ (%fx+ first delta) past delta lt?)) ) )
     393      (stream-cons first (stream-range$ (fx+ first delta) past delta lt?)) ) )
    383394  ;
    384395  (%check-number 'stream-range first 'first)
    385396  (%check-number 'stream-range past 'past)
    386   (let ((delta (cond ((%pair? step) (%car step)) ((< first past) 1) (else -1))))
     397  (let ((delta (cond ((pair? step) (car step)) ((< first past) 1) (else -1))))
    387398    (%check-number 'stream-range delta 'delta)
    388399    (let ((lt? (if (< 0 delta) < >)))
     
    405416    (call-with-values
    406417      (lambda () (generator seed))
    407       (lambda vs (%fxsub1 (%length vs)))) )
     418      (lambda vs (fxsub1 (length vs)))) )
    408419  ;
    409420  (define-stream (unfold-result-stream seed)
     
    414425  ;
    415426  (define-stream (result-stream->output-stream result-stream i)
    416     (let ((result (%list-ref (stream-car result-stream) (%fxsub1 i))))
     427    (let ((result (list-ref (stream-car result-stream) (fxsub1 i))))
    417428      (cond
    418         ((%pair? result)
     429        ((pair? result)
    419430          (stream-cons
    420             (%car result)
     431            (car result)
    421432            (result-stream->output-stream (stream-cdr result-stream) i)) )
    422433        ((not result)
    423434          (result-stream->output-stream (stream-cdr result-stream) i) )
    424         ((%null? result)
     435        ((null? result)
    425436          stream-null )
    426437        (else
     
    429440  (define (result-stream->output-strms result-stream)
    430441    (let loop ((i (len-values)) (outputs '()))
    431       (if (%fxzero? i) (apply values outputs)
    432         (loop (%fxsub1 i) (%cons (result-stream->output-stream result-stream i) outputs)) ) ) )
     442      (if (fxzero? i) (apply values outputs)
     443        (loop (fxsub1 i) (cons (result-stream->output-stream result-stream i) outputs)) ) ) )
    433444  ;
    434445  (%check-procedure 'stream-unfolds generator 'generator)
     
    438449  ;
    439450  (define-stream (stream-zip$ strms)
    440     (if (%list-any/1 stream-null? strms) stream-null
     451    (if (any stream-null? strms) stream-null
    441452      (stream-cons
    442         (%list-map/1 stream-car strms)
    443         (stream-zip$ (%list-map/1 stream-cdr strms))) ) )
     453        (map stream-car strms)
     454        (stream-zip$ (map stream-cdr strms))) ) )
    444455  ;
    445456  (stream-zip$ (%check-streams 'stream-zip strms 'stream)) )
  • release/5/srfi-41/trunk/streams-inlines.scm

    r38514 r39707  
    1212
    1313(define-inline (%check-streams loc strms #!optional argnam)
    14   (when (%null? strms) (error loc "no stream arguments" strms))
    15   (%list-for-each/1 (cut %check-stream loc <> argnam) strms)
     14  (when (null? strms) (error loc "no stream arguments" strms))
     15  (for-each (cut %check-stream loc <> argnam) strms)
    1616  strms )
  • release/5/srfi-41/trunk/streams-primitive.scm

    r39705 r39707  
    4949
    5050(include "chicken-primitive-object-inlines")
     51
    5152(include "streams-inlines")
    5253
     
    6465(define-inline (stream-tagged-pair? obj)
    6566  (and
    66     (%pair? obj)
    67     (let ((tag (%car obj)))
    68       (or (%eq? 'lazy tag) (%eq? 'eager tag)) ) ) )
     67    (pair? obj)
     68    (let ((tag (car obj)))
     69      (or (eq? 'lazy tag) (eq? 'eager tag)) ) ) )
    6970
    70 (define-inline (make-stream-box tag obj) (%cons tag obj))
    71 (define-inline (stream-box-tag box) (%car box))
    72 (define-inline (stream-box-value box) (%cdr box))
    73 (define-inline (stream-box-tag-set! box tag) (%set-car!/immediate box tag))
    74 (define-inline (stream-box-value-set! box val) (%set-cdr! box val))
     71(define-inline (make-stream-box tag obj) (cons tag obj))
     72(define-inline (stream-box-tag box) (car box))
     73(define-inline (stream-box-value box) (cdr box))
     74(define-inline (stream-box-tag-set! box tag) (set-car! box tag))
     75(define-inline (stream-box-value-set! box val) (set-cdr! box val))
    7576
    7677(define-inline (make-stream-lazy-box obj) (make-stream-box 'lazy obj))
     
    129130(define (stream? obj) (%stream? obj))
    130131
    131 (define stream-null ($stream-delay$ (%cons 'stream 'null)))
     132(define stream-null ($stream-delay$ (cons 'stream 'null)))
    132133
    133134(define-inline (*stream-null? strm)
  • release/5/srfi-41/trunk/streams-queue.scm

    r39706 r39707  
    2121(import scheme
    2222  (chicken base)
     23  (chicken fixnum)
    2324  (chicken type)
    2425  streams
     
    2627
    2728(include-relative "chicken-primitive-object-inlines")
     29(include-relative "inline-type-checks")
     30
    2831(include-relative "streams-inlines")
    29 (include-relative "inline-type-checks")
    3032
    3133;;;
    3234
    3335(define-inline (finalize-queue f r)
    34   (if (%fx< (stream-length r) (stream-length f))
    35     (%cons f r)
    36     (%cons (stream-append f (stream-reverse r)) stream-null) ) )
     36  (if (fx< (stream-length r) (stream-length f))
     37    (cons f r)
     38    (cons (stream-append f (stream-reverse r)) stream-null) ) )
    3739
    3840;;;
    3941
    4042(define queue-null
    41   (%cons stream-null stream-null) )
     43  (cons stream-null stream-null) )
    4244
    4345(define (queue-null? x)
    44   (and (%pair? x) (stream-null (%car x))) )
     46  (and (pair? x) (stream-null (car x))) )
    4547
    4648(define (queue-cons q x)
    4749  (%check-pair 'queue-cons q 'queue)
    48   (finalize-queue (%car q) (stream-cons x (%cdr q))) )
     50  (finalize-queue (car q) (stream-cons x (cdr q))) )
    4951
    5052(define (queue-head q)
    5153  (%check-pair 'queue-head q 'queue)
    52   (if (stream-null? (%car q))
     54  (if (stream-null? (car q))
    5355    (error 'queue-head "empty queue")
    54     (stream-car (%car q)) ) )
     56    (stream-car (car q)) ) )
    5557
    5658(define (queue-tail q)
    5759  (%check-pair 'queue-tail q 'queue)
    58   (if (stream-null? (%car q))
     60  (if (stream-null? (car q))
    5961    (error 'queue-tail "empty queue")
    60     (finalize-queue (stream-cdr (%car q)) (%cdr q)) ) )
     62    (finalize-queue (stream-cdr (car q)) (cdr q)) ) )
    6163
    6264;;
     
    6567(define (make-queue ls)
    6668  (let loop ((ls ls) (q queue-null))
    67     (if (%null? ls) q
    68       (loop (%cdr ls) (queue-cons q (%car ls))) ) ) )
     69    (if (null? ls) q
     70      (loop (cdr ls) (queue-cons q (car ls))) ) ) )
    6971
    7072; 1 2 3 => q 3 2 1
  • release/5/srfi-41/trunk/streams-utils.scm

    r39706 r39707  
    5656
    5757(include-relative "chicken-primitive-object-inlines")
     58(include-relative "inline-type-checks")
     59
    5860(include-relative "streams-inlines")
    59 (include-relative "inline-type-checks")
    6061
    6162;;;
    6263
    63 (: right-section ((procedure (#!rest) *) #!rest -> (procedure (#!rest) *)))
    64 
    65 ;
    66 (define (right-section fn . args)
    67   ;(append xs args) = (reverse (append (reverse args) (reverse xs)))
    68   (lambda xs (apply fn (append xs args))) )
     64;(append xs args) = (reverse (append (reverse args) (reverse xs)))
     65(define (right-section fn . args) (lambda xs (apply fn (append xs args))))
    6966
    7067;;;
     
    145142      ((null? strms)
    146143        stream-null )
    147       ((null? (%cdr strms))
    148         (%car strms) )
    149       (else
    150         (stream-merge$ (%car strms) (apply stream-merge lt? (%cdr strms))) ) ) ) )
     144      ((null? (cdr strms))
     145        (car strms) )
     146      (else
     147        (stream-merge$ (car strms) (apply stream-merge lt? (cdr strms))) ) ) ) )
    151148
    152149(define (stream-partition pred? strm)
     
    165162  (%check-procedure 'stream-finds eql? 'equivalence)
    166163  (stream-of
    167     (%car x)
     164    (car x)
    168165    (x in (stream-zip (stream-from 0) (%check-stream 'stream-finds strm 'stream)))
    169     (eql? item (%cadr x))) )
     166    (eql? item (cadr x))) )
    170167
    171168(define (stream-find eql? item strm)
     
    241238      ((stream-null? dict)
    242239        #f )
    243       ((eql? key (%car (stream-car dict)))
     240      ((eql? key (car (stream-car dict)))
    244241        (stream-car dict) )
    245242      (else
     
    311308  (define-stream (flatten tree)
    312309    (cond
    313       ((%null? tree)
     310      ((null? tree)
    314311        stream-null )
    315       ((%pair? (%car tree) )
    316         (stream-append (flatten (%car tree)) (flatten (%cdr tree))))
    317       (else
    318         (stream-cons (%car tree) (flatten (%cdr tree))) ) ) )
     312      ((pair? (car tree) )
     313        (stream-append (flatten (car tree)) (flatten (cdr tree))))
     314      (else
     315        (stream-cons (car tree) (flatten (cdr tree))) ) ) )
    319316  ;
    320317  (let loop ((t1 (flatten (%check-list 'same-fringe? tree1 'tree1)))
  • release/5/srfi-41/trunk/streams.scm

    r39706 r39707  
    2323  (chicken platform))
    2424
    25 (import streams-primitive)
    26 (reexport streams-primitive)
    27 
    28 (import streams-derived)
    29 (reexport streams-derived)
     25(import streams-primitive streams-derived)
     26(reexport streams-primitive streams-derived)
    3027
    3128(register-feature! 'streams)
Note: See TracChangeset for help on using the changeset viewer.