source: project/release/5/srfi-41/trunk/streams-queue.scm @ 39713

Last change on this file since 39713 was 39713, checked in by Kon Lovett, 2 months ago

remove "primitives", replace inline type checks

File size: 1.5 KB
Line 
1;;;; streams-queue.scm  -*- Scheme -*-
2;;;; Kon Lovett, Feb '19
3;;;; Kon Lovett, Aug '10
4
5;;;; From "samples.ss"
6;;;; Provides a functional queue abstraction using streams.
7
8(module streams-queue
9
10(;export
11  ;original
12  queue-null
13  queue-null?
14  queue-cons
15  queue-head
16  queue-tail
17  ;extras
18  make-queue
19  queue)
20
21(import scheme
22  (chicken base)
23  (chicken fixnum)
24  (chicken type)
25  (chicken syntax)
26  (only type-checks check-pair)
27  streams)
28
29;;;
30
31(define (finalize-queue f r)
32  (if (fx< (stream-length r) (stream-length f))
33    (cons f r)
34    (cons (stream-append f (stream-reverse r)) stream-null) ) )
35
36;;;
37
38(define queue-null
39  (cons stream-null stream-null) )
40
41(define (queue-null? x)
42  (and (pair? x) (stream-null (car x))) )
43
44(define (queue-cons q x)
45  (check-pair 'queue-cons q 'queue)
46  (finalize-queue (car q) (stream-cons x (cdr q))) )
47
48(define (queue-head q)
49  (check-pair 'queue-head q 'queue)
50  (if (stream-null? (car q))
51    (error 'queue-head "empty queue")
52    (stream-car (car q)) ) )
53
54(define (queue-tail q)
55  (check-pair 'queue-tail q 'queue)
56  (if (stream-null? (car q))
57    (error 'queue-tail "empty queue")
58    (finalize-queue (stream-cdr (car q)) (cdr q)) ) )
59
60;;
61
62; l 1 2 3 => q 3 2 1
63(define (make-queue ls)
64  (let loop ((ls ls) (q queue-null))
65    (if (null? ls) q
66      (loop (cdr ls) (queue-cons q (car ls))) ) ) )
67
68; 1 2 3 => q 3 2 1
69(define (queue . rest) (apply make-queue rest))
70
71) ;streams-queue
Note: See TracBrowser for help on using the repository browser.