source: project/release/5/stack/trunk/stack.scm @ 35980

Last change on this file since 35980 was 35980, checked in by kon, 12 months ago

C5 initial

File size: 7.3 KB
Line 
1;;;; stack.scm
2;;;; Kon Lovett, May '17
3;;;; Kon Lovett, Mar '09
4
5;;;; Stack data structure (LIFO queue) where the value is mutable,
6;;;; rather than usual pattern of the variable.
7
8;; Issues
9;;
10;; - All operations inlined & primitive due to high-performance nature.
11
12(declare
13  (disable-interrupts)
14  (bound-to-procedure ##sys#signal-hook))
15
16(module stack
17
18(;export
19  make-stack
20  list->stack
21  stack->list
22  stack?
23  stack-empty?
24  stack-count
25  stack-peek
26  stack-empty!
27  stack-poke!
28  stack-push!
29  stack-cut!
30  stack-pop!
31  stack-map
32  stack-map
33  stack-for-each
34  stack-literal-form)
35
36(import scheme
37  (srfi 10)
38  (chicken base)
39  (chicken fixnum)
40  (chicken type)
41  (only (chicken port) with-output-to-port)
42  (only (chicken format) format)
43  (only type-errors define-error-type error-list error-fixnum))
44
45(include "chicken-primitive-object-inlines")
46(include "inline-type-checks")
47
48#| chicken
49warning
50:
51void
52declare
53define-inline
54define-constant
55define-for-syntax
56include
57optional let-optionals  ;due to #!optional implementation
58unless when
59define-record-printer
60define-reader-ctor
61|#
62
63;; Stack Support
64
65(define-inline (%make-stack)
66        (%make-structure 'stack '() 0) )
67
68(define-inline (%stack? obj)
69        (%structure-instance? obj 'stack) )
70
71(define-inline (%valid-stack? obj)
72  (and
73    #;(%stack? obj)
74    (%fx= 3 (%structure-length obj))
75    (%list? (%stack-list obj)) ) )
76
77;; Stack List
78
79(define-inline (%stack-list stk)
80  (%structure-ref stk 1) )
81
82(define-inline (%stack-list-empty? stk)
83        (%null? (%stack-list stk)) )
84
85(define-inline (%stack-list-set! stk ls)
86        (%structure-set! stk 1 ls) )
87
88(define-inline (%stack-list-empty! stk)
89        (%structure-set!/immediate stk 1 '()) )
90
91;; Stack Count
92
93(define-inline (%stack-count stk)
94        (%structure-ref stk 2) )
95
96(define-inline (%stack-count-set! stk cnt)
97        (%structure-set!/immediate stk 2 cnt) )
98
99(define-inline (%stack-count-inc! stk cnt)
100        (%stack-count-set! stk (%fx+ (%stack-count stk) cnt)) )
101
102(define-inline (%stack-count-dec! stk cnt)
103        (%stack-count-set! stk (%fx- (%stack-count stk) cnt)) )
104
105;; Stack Operations
106
107(define-inline (%stack-empty? stk)
108        (%stack-list-empty? stk))
109
110(define-inline (%stack-empty! stk)
111  (%stack-count-set! stk 0)
112  (%stack-list-empty! stk) )
113
114(define-inline (%stack-pop! stk)
115  (%stack-count-dec! stk 1)
116        (let ((ls (%stack-list stk)))
117                (%stack-list-set! stk (%cdr ls))
118                (%car ls) ) )
119
120(define-inline (%stack-push/1! stk obj)
121  (%stack-count-inc! stk 1)
122        (%stack-list-set! stk (%cons obj (%stack-list stk))) )
123
124(define-inline (%stack-push! stk ls)
125  (if (%null? (%cdr ls))
126    (%stack-push/1! stk (%car ls))
127    (%list-for-each/1 (lambda (x) (%stack-push/1! stk x)) ls) ) )
128
129(define-inline (%stack-node-ref loc stk idx)
130  (let ((pr (%list-pair-ref (%stack-list stk) idx)))
131                (if (%pair? pr)
132                  pr
133      (error-outside-range loc idx 0 (%stack-count stk)) ) ) )
134
135;; Helpers
136
137(define-inline (%check-stack loc obj)
138  (unless (%stack? obj) (error-stack loc obj))
139  (unless (%valid-stack? obj) (error-corrupted-stack loc obj))
140  obj )
141
142(define-inline (%check-stack-underflow loc stk)
143  (when (%stack-empty? stk) (error-stack-underflow loc stk))
144  stk )
145
146(define-inline (%check-fixnum-index loc lfx fx hfx)
147  (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx))
148  (void) )
149
150;;;
151
152(define-error-type stack)
153
154(define (error-corrupted-stack loc obj)
155  (##sys#signal-hook #:runtime-error loc "stack corrupted" obj) )
156
157(define (error-stack-underflow loc stk)
158  (##sys#signal-hook #:limit-error loc "stack underflow" stk) )
159
160(define (error-outside-range loc obj low high)
161  (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )
162
163;;;
164
165(: make-stack (-> (struct stack)))
166;
167(define (make-stack)
168  (%make-stack) )
169
170(: list->stack (list -> (struct stack)))
171;
172(define (list->stack ls)
173  (%check-list 'list->stack ls)
174        (let ((stk (%make-stack)))
175    (%stack-count-set! stk (%length ls))
176    (%stack-list-set! stk (%list-copy ls))
177    stk ) )
178
179(: stack? (* -> boolean))
180;
181(define (stack? obj) (%stack? obj))
182
183(: stack-empty? ((struct stack) -> boolean))
184;
185(define (stack-empty? stk)
186        (%stack-empty? (%check-stack 'stack-empty? stk)) )
187
188(: stack-count ((struct stack) -> fixnum))
189;
190(define (stack-count stk)
191        (%stack-count (%check-stack 'stack-count stk)) )
192
193(: stack-peek ((struct stack) #!optional fixnum -> *))
194;
195(define (stack-peek stk #!optional (idx 0))
196        (%car (%stack-node-ref 'stack-peek (%check-stack 'stack-peek stk) idx)) )
197
198(: stack-empty! ((struct stack) -> undefined))
199;
200(define (stack-empty! stk)
201        (%stack-empty! (%check-stack 'stack-empty! stk)) )
202
203(: stack-poke! ((struct stack) * #!optional fixnum -> undefined))
204;
205(define (stack-poke! stk obj #!optional (idx 0))
206        (%set-car!/mutate (%stack-node-ref 'stack-poke! (%check-stack 'stack-poke! stk) idx) obj) )
207
208(: stack-push! ((struct stack) #!rest * -> undefined))
209;
210(define (stack-push! stk #!rest ls)
211        (unless (%null? ls) (%stack-push! (%check-stack 'stack-push! stk) ls)) )
212
213(: stack-cut! ((struct stack) fixnum #!optional fixnum -> list))
214;
215(define (stack-cut! stk start #!optional (end (%stack-count stk)))
216  (%check-stack 'stack-cut! stk)
217  (%check-fixnum 'stack-cut! start)
218  (%check-fixnum 'stack-cut! end)
219  (%check-fixnum-index 'stack-cut! 0 start end)
220  (%check-fixnum-index 'stack-cut! start end (%fx+ (%stack-count stk) 1))
221  (let ((cnt (%fx- end start)))
222    (%stack-count-dec! stk cnt)
223    ; From the top?
224    (if (%fx= 0 start)
225      ;then removing leading elements
226      (let* ((spr (%stack-list stk))
227             (epr (%list-pair-ref spr (%fx- cnt 1)))
228             (ls spr))
229        (%stack-list-set! stk (%cdr epr))
230        (%set-cdr!/immediate epr '())
231        ls )
232      ;else removing interior elements
233      (let* ((spr (%stack-node-ref 'stack-cut! stk (%fx- start 1)))
234             (epr (%list-pair-ref spr cnt))
235             (ls (%cdr spr)))
236        (%set-cdr!/mutate spr (%cdr epr))
237        (%set-cdr!/immediate epr '())
238        ls ) ) ) )
239
240(: stack-pop! ((struct stack) -> *))
241;
242(define (stack-pop! stk)
243  (%check-stack 'stack-pop! stk)
244        (%check-stack-underflow 'stack-pop! stk)
245        (%stack-pop! stk) )
246
247(: stack->list ((struct stack) -> list))
248;
249(define (stack->list stk)
250        (%list-copy (%stack-list (%check-stack 'stack->list stk))) )
251
252(: stack-fold ((struct stack) procedure * -> *))
253;
254(define (stack-fold stk func init)
255        (%list-fold/1 func init (%stack-list (%check-stack 'stack-fold stk))) )
256
257(: stack-map ((struct stack) procedure -> list))
258;
259(define (stack-map stk func)
260        (%list-map/1 func (%stack-list (%check-stack 'stack-map stk))) )
261
262(: stack-for-each ((struct stack) procedure -> undefined))
263;
264(define (stack-for-each stk proc)
265        (%list-for-each/1 proc (%stack-list (%check-stack 'stack-for-each stk))) )
266
267;;; Read/Print Syntax
268
269(define-record-printer (stack stk out)
270  (format out (stack-literal-format) (%stack-list stk)) )
271
272(define-reader-ctor 'stack list->stack)
273
274(define stack-literal-form
275  (make-parameter 'srfi-10
276    (lambda (x)
277      (case x
278        ((SRFI-10 srfi-10)
279          'srfi-10 )
280        ((UNREAD unread)
281          'unread )
282        (else
283          (warning 'stack-literal-format "invalid form symbol; 'srfi-10 or 'unread" x)
284          (stack-literal-format))))))
285
286(define-constant SRFI-10-FORMAT "#,(stack ~A)")
287(define-constant UNREAD-FORMAT "#<stack ~A>")
288
289(define (stack-literal-format)
290  (case (stack-literal-form)
291    ((srfi-10)
292      SRFI-10-FORMAT )
293    (else
294      UNREAD-FORMAT ) ) )
295
296) ;module stack
Note: See TracBrowser for help on using the repository browser.