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

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

Added primitive inlines.

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