source: project/release/5/yasos/tags/1.7/stacks.scm @ 36340

Last change on this file since 36340 was 36340, checked in by iraikov, 4 months ago

yasos release 1.7

File size: 2.8 KB
Line 
1
2(module yasos-stacks
3        (make-stack make-ra-stack ra-stack? stack? state down push! top pop! clear! empty? size show protocol)
4        (import scheme (chicken base) (chicken format)
5                (except yasos object object-with-ancestors))
6
7;;; stack interface
8(define-predicate stack?)
9(define-operation (pop! obj))
10(define-operation (top obj))
11(define-operation (push! obj x))
12(define-operation (empty? obj))
13(define-operation (clear! obj))
14(define-operation (state obj))
15
16;;; stack implementation with vectors
17;;; (to allow a random access child)
18(define (make-stack)
19  (let ((vec (vector 1 2))) ;'#(pos len data ...)
20    (operations ()
21      ((stack? self) #t)
22      ((empty? self)
23       (= (vector-ref vec 0) 1))
24      ((size self)
25       (- (vector-ref vec 0) 1))
26      ((show self . optional-arg)
27       (if (null? optional-arg)
28         (show self #t)
29         (format (car optional-arg)
30                 "#,~s~%"
31                 (let loop ((k 0) (result '()))
32                   (if (= k (size self))
33                     (cons 'stack (reverse result))
34                     (loop (+ k 1)
35                           (cons (vector-ref vec (+ k 2))
36                                 result)))))))
37      ((state self) ; needed for inheritance
38       (lambda () vec))
39      ((top self)
40       (if (empty? self)
41         (error 'top "stack empty")
42         (vector-ref vec (vector-ref vec 0))))
43      ((push! self x)
44       ;; update pos
45       (vector-set! vec 0 (+ (vector-ref vec 0) 1))
46       ;; stack full?
47       (when (= (vector-ref vec 0) (vector-ref vec 1))
48         ;; update len
49         (vector-set! vec 1 (* 2 (vector-ref vec 1)))
50         ;; update vec
51         (set! vec (vector-resize vec (vector-ref vec 1) #f)))
52       ;; store new value
53       (vector-set! vec (vector-ref vec 0) x))
54      ((pop! self)
55       (if (empty? self)
56         (error 'pop! "stack empty")
57         (vector-set! vec 0 (- (vector-ref vec 0) 1))))
58      ((clear! self)
59       (set! (vector-ref vec 0) 1)))))
60                 
61;;; ra-stack interface
62(define-predicate ra-stack?)
63(define-operation (down obj k))
64
65;;; random-access stack implementation
66(define (make-ra-stack)
67  (operations ((stack (make-stack)))
68    ((ra-stack? self) #t)
69    ((show self . optional-arg)
70     (if (null? optional-arg)
71       (show self #t)
72       (format (car optional-arg)
73               "#,~s~%"
74               (let loop ((k 0) (result '()))
75                 (if (= k (size self))
76                   (cons 'ra-stack (reverse result))
77                   (loop (+ k 1)
78                         (cons (vector-ref ((state self)) (+ k 2))
79                               result)))))))
80    ((down self k)
81     (let ((vec ((state self))))
82       (if (and (integer? k) (< -1 k (size self)))
83         (vector-ref vec (- (vector-ref vec 0) k))
84         (error 'down "out of range" k))))))
85
86) ; module stacks
Note: See TracBrowser for help on using the repository browser.