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

Last change on this file since 39694 was 39694, checked in by Kon Lovett, 2 months ago

remove "primitives", use record-variants, add hof tests, new test runner

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