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

Last change on this file since 34140 was 34140, checked in by Kon Lovett, 3 years ago

add csc test, add static

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