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

Last change on this file since 38630 was 38630, checked in by Kon Lovett, 5 months ago

remove redundant local, add -strict-types, reflow for wide

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