source: project/release/5/stack/tags/3.0.3/stack.scm @ 38502

Last change on this file since 38502 was 38502, checked in by Kon Lovett, 4 months ago

rel 3.0.3

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