source: project/release/4/stack/trunk/stack.scm @ 13527

Last change on this file since 13527 was 13527, checked in by Kon Lovett, 11 years ago

Save.

File size: 5.8 KB
Line 
1;;;; stack.scm
2;;;; Kon Lovett, Mar '09
3
4;;;; Stack data structure (LIFO queue) where the value is mutable,
5;;;; rather than usual pattern of the variable.
6
7;; Issues
8;;
9;; - All operations inlined & primitive due to high-performance nature.
10
11(declare
12  (usual-integrations)
13  (disable-interrupts)
14  (fixnum)
15  (inline)
16  (local)
17  (no-procedure-checks)
18  (no-bound-checks)
19  (bound-to-procedure
20    ##sys#error-hook
21    ##sys#signal-hook
22    ##sys#check-range
23    ##sys#check-list
24    ##sys#check-exact) )
25
26;;;
27
28(include "chicken-primitive-object-inlines")
29
30
31;;; Stack Support
32
33(define-inline (%make-stack)
34  (%make-structure 'stack '() 0) )
35
36;; Stack List
37
38(define-inline (%stack-list stk)
39  (%structure-ref stk 1) )
40
41(define-inline (%stack-list-set! stk ls)
42  (%structure-set!/maybe-immediate stk 1 ls) )
43
44(define-inline (%stack-list-empty? stk)
45  (%null? (%stack-list stk)) )
46
47(define-inline (%stack-list-empty! stk)
48  (%structure-set!/immediate stk 1 '()) )
49
50;; Stack Count
51
52(define-inline (%stack-count stk)
53  (%structure-ref stk 2) )
54
55(define-inline (%stack-count-set! stk cnt)
56  (%structure-set!/immediate stk 2 ls) )
57
58(define-inline (%stack-count-inc! stk cnt)
59  (%stack-count-set! stk (%fx+ (%stack-count stk) cnt)) )
60
61(define-inline (%stack-count-dec! stk cnt)
62  (%stack-count-set! stk (%fx- (%stack-count stk) cnt)) )
63
64;; Stack Operations
65
66(define-inline (%stack-empty? stk)
67  (%stack-list-empty? stk) )
68
69(define-inline (%stack-empty! stk)
70  (%stack-count-set! stk 0)
71  (%stack-list-empty! stk) )
72
73(define-inline (%stack-pop! stk)
74  (%stack-count-dec! stk 1)
75        (let ([ls (%stack-list stk)])
76                (%stack-list-set! stk (%cdr ls))
77                (%car ls) ) )
78
79(define-inline (%stack-push-1! stk obj)
80  (%stack-count-inc! stk 1)
81        (%stack-list-set! stk (%cons obj (%stack-list stk))) )
82
83(define-inline (%stack-push! stk ls)
84  (if (%null (%cdr ls)) (%stack-push-1! stk (%car ls))
85            (%list-for-each-1 (lambda (x) (%stack-push-1! stk x)) ls) ) )
86
87(define-inline (%list-stack-node-ref loc ls idx)
88  (let ([pr (%list-pair-ref ls idx)])
89                (if (not (%null pr)) pr
90                          (##sys#error-hook
91                           (foreign-value "C_OUT_OF_RANGE_ERROR" int) loc
92                           idx 0 (%stack-count stk)) ) ) )
93
94(define-inline (%stack-node-ref loc stk idx)
95  (%list-stack-node-ref loc (%stack-list stk) idx) )
96
97
98;;; Helpers
99
100(define-inline (%check-index loc obj from to)
101        (##sys#check-range obj from to loc) )
102
103(define-inline (%check-stack loc obj)
104        (unless (%stack? obj)
105          (##sys#signal-hook #:type-error loc "bad argument type - not a stack" obj) ) )
106
107(define-inline (%check-list loc obj)
108  (##sys#check-list obj loc) )
109
110(define-inline (%check-non-empty-stack loc stk)
111        (when (%stack-empty? stk)
112          (##sys#signal-hook #:limit-error loc "stack underflow" stk) ) )
113
114(define-inline (%check-exact loc obj)
115  (##sys#check-exact obj loc) )
116
117
118;;;
119
120(module mailbox (;export
121        make-stack
122        list->stack
123        stack-empty?
124        stack-count
125        stack-peek
126        stack-empty!
127        stack-poke!
128        stack-push!
129        stack-cut!
130        stack-pop!
131        stack->list
132        stack-fold
133        stack-map
134        stack-for-each)
135
136(import
137  scheme
138  (only chicken
139    optional                ;due to #!optional implementation
140    let-optionals           ;due to #!optional implementation
141    unless when
142    define-record-printer)
143  (only ports
144    with-output-to-port) )
145
146(define (make-stack)
147        (%make-stack) )
148
149(define (list->stack ls)
150  (%check-list 'list->stack ls)
151        (let ([stk (%make-stack)])
152    (%stack-count-set! stk (%length ls))
153    (%stack-list-set! stk (%list-copy ls))
154    stk ) )
155
156(define (stack-empty? stk)
157  (%check-stack 'stack-empty? stk)
158        (%stack-empty? stk) )
159
160(define (stack-count stk)
161  (%check-stack 'stack-count stk)
162        (%stack-count stk) )
163
164(define (stack-peek stk #!optional (idx 0))
165  (%check-stack 'stack-peek stk)
166        (%car (%stack-node-ref 'stack-peek stk idx)) )
167
168(define (stack-empty! stk)
169  (%check-stack 'stack-empty! stk)
170        (%stack-empty! stk) )
171
172(define (stack-poke! stk obj #!optional (idx 0))
173  (%check-stack 'stack-poke! stk)
174        (%set-car!/maybe-immediate (%stack-node-ref 'stack-poke! stk idx) obj) )
175
176(define (stack-push! stk !#rest ls)
177  (%check-stack 'stack-push! stk)
178        (unless (%null ls) (%stack-push! stk ls)) )
179
180(define (stack-cut! stk start #!optional (end (%stack-count stk)))
181  (%check-stack 'stack-cut! stk)
182  (%check-exact 'stack-cut! start)
183  (%check-exact 'stack-cut! end)
184  (%check-index 'stack-cut! start 0 end)
185  (%check-index 'stack-cut! end start (%fx+ (%stack-count stk) 1))
186  (let ([cnt (%fx- end start)])
187    (%stack-count-dec! stk cnt)
188    ; From the top?
189    (if (%fx= 0 start)
190        ;then removing leading elements
191        (let* ([spr (%stack-list stk)]
192               [epr (%list-stack-node-ref 'stack-cut! spr (%fx- cnt 1))]
193               [ls spr])
194          (%stack-list-set! stk (%cdr epr))
195          (%set-cdr!/immediate! epr '())
196          ls )
197        ;else removing interior elements
198        (let* ([spr (%stack-node-ref 'stack-cut! stk (%fx- start 1))]
199               [epr (%list-stack-node-ref 'stack-cut! spr (%fx- cnt 1))]
200               [ls (%cdr spr)])
201          (%set-cdr!/maybe-immediate spr (%cdr epr))
202          (%set-cdr!/immediate! epr '())
203          ls ) ) ) )
204
205(define (stack-pop! stk)
206  (%check-stack 'stack-pop! stk)
207        (%check-non-empty-stack 'stack-pop! stk)
208        (stack-pop*! stk) )
209
210(define (stack->list stk)
211  (%check-stack 'stack->list stk)
212        (%list-copy (%stack-list stk)) )
213
214(define (stack-fold stk func init)
215  (%check-stack 'stack-fold stk)
216        (%list-fold-1 func init (%stack-list stk)) )
217
218(define (stack-map stk func)
219  (%check-stack 'stack-map stk)
220        (%list-map-1 func (%stack-list stk)) )
221
222(define (stack-for-each stk proc)
223  (%check-stack 'stack-for-each stk)
224        (%list-for-each-1 proc (%stack-list stk)) )
225
226;;; Read/Print Syntax
227
228(define-record-printer (stack stk out)
229  (with-output-to-port out
230    (lambda ()
231      (display "#<stack ")
232      (display " count = ") (display (%stack-count stk))
233      (display ">") ) ) )
234
235) ;module stack
Note: See TracBrowser for help on using the repository browser.