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

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

bump ver, re-flow

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