;;; Stacks

(printf "stacks.s Fri May 28 10:59:47 1993~%")

(define make-stack
  (lambda (size) 
    (list '*stack -1 -1 (make-vector size))))

;; (stack-push v1 ... vn s) -- returns modified stack

(define stack-push
  (lambda l
    (let ((n (- (length l) 1))
          (s (car (last-pair l))))
      (let ((a (cadddr s))
            (sp (cadr s)))
        (let loop ((p (+ sp n))
                   (l l)
                   (count n))
          (if (zero? count)
            ;; nothing more to put on stack, so set sp and return the
            ;; stack object
            (begin
              (set-car! (cdr s) (+ sp n))
              s)
            ;; otherwise, put first elt of l on the stack, counting
            ;; down from eventual top
            (begin
              (vector-set! a p (car l))
              (loop (- p 1) (cdr l) (- count 1)))))))))

;; (stack-pop s n (lambda (v1 ... vn s) ...))  -- inverse of stack-push
;; maybe n should be number of lambda-items rather than number of v's.

(define stack-pop
  (lambda (count s rcvr)
    (let ((a (cadddr s))
          (sp (cadr s)))
      (let loop ((l (list s))           ; output list
                 (n count)              ; number of output values to
                                        ; be retrieved
                 (p (- sp count -1))); stack pointer, starting from bottom
        (if (zero? n)
          (begin
            (set-car! (cdr s) (- sp count))       ; set the sp
            (apply rcvr l))
          (loop 
            (cons (vector-ref a p) l)
            (- n 1)
            (+ p 1)))))))

;;; ****************

;;; primitive interface

(define stack-ref
  (lambda (s ptr)
    (vector-ref (cadddr s) ptr)))

(define stack->sp
  (lambda (s)
    (cadr s)))

(define stack->bp
  (lambda (s)
    (caddr s)))

(define stack-set-bp
  (lambda (bp s)
    (set-car! (cddr s) bp)
    s))

(define stack-set-sp
  (lambda (sp s)
    (set-car! (cdr s) sp)
    s))

;;; ****************************************************************

;;; vk and ak interface

(define vk->ak
  (lambda (vk)
    (stack-set-bp (stack->sp vk) vk)))

(define ak->bp stack->bp)
(define ak->vk (lambda (ak) ak))     ; just forget the bp