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

;;;; stack.scm
;;;; Kon Lovett, Mar '09

;;;; Stack data structure (LIFO queue) where the value is mutable,
;;;; rather than usual pattern of the variable.

;; Issues
;;
;; - All operations inlined & primitive due to high-performance nature.

(declare
  (usual-integrations)
  (disable-interrupts)
  (fixnum)
  (inline)
  (local)
  (no-procedure-checks)
  (no-bound-checks)
  (bound-to-procedure
    ##sys#signal-hook
    ##sys#check-range
    ##sys#check-list
    ##sys#check-exact) )

;;;

(include "chicken-primitive-object-inlines")


;;; Stack Support

(define-inline (%make-stack)
  (%make-structure 'stack '() 0) )

(define-inline (%stack? obj)
  (%structure-instance? obj 'stack) )

;; Stack List

(define-inline (%stack-list stk)
  (%structure-ref stk 1) )

(define-inline (%stack-list-set! stk ls)
  (%structure-set!/maybe-immediate stk 1 ls) )

(define-inline (%stack-list-empty? stk)
  (%null? (%stack-list stk)) )

(define-inline (%stack-list-empty! stk)
  (%structure-set!/immediate stk 1 '()) )

;; Stack Count

(define-inline (%stack-count stk)
  (%structure-ref stk 2) )

(define-inline (%stack-count-set! stk cnt)
  (%structure-set!/immediate stk 2 cnt) )

(define-inline (%stack-count-inc! stk cnt)
  (%stack-count-set! stk (%fx+ (%stack-count stk) cnt)) )

(define-inline (%stack-count-dec! stk cnt)
  (%stack-count-set! stk (%fx- (%stack-count stk) cnt)) )

;; Stack Operations

(define-inline (%stack-empty? stk)
  (%stack-list-empty? stk) )

(define-inline (%stack-empty! stk)
  (%stack-count-set! stk 0)
  (%stack-list-empty! stk) )

(define-inline (%stack-pop! stk)
  (%stack-count-dec! stk 1)
        (let ([ls (%stack-list stk)])
                (%stack-list-set! stk (%cdr ls))
                (%car ls) ) )

(define-inline (%stack-push-1! stk obj)
  (%stack-count-inc! stk 1)
        (%stack-list-set! stk (%cons obj (%stack-list stk))) )

(define-inline (%stack-push! stk ls)
  (if (%null? (%cdr ls)) (%stack-push-1! stk (%car ls))
            (%list-for-each-1 (lambda (x) (%stack-push-1! stk x)) ls) ) )

(define-inline (%stack-node-ref loc stk idx)
  (let ([pr (%list-pair-ref (%stack-list stk) idx)])
                (if (not (%null? pr)) pr
                          (##sys#signal-hook #:bounds-error loc "out of range" idx 0 (%stack-count stk)) ) ) )


;;; Helpers

(define-inline (%check-index loc obj from to)
        (##sys#check-range obj from to loc) )

(define-inline (%check-stack loc obj)
        (unless (%stack? obj)
          (##sys#signal-hook #:type-error loc "bad argument type - not a stack" obj) ) )

(define-inline (%check-list loc obj)
  (##sys#check-list obj loc) )

(define-inline (%check-stack-underflow loc stk)
        (when (%stack-empty? stk)
          (##sys#signal-hook #:limit-error loc "stack underflow" stk) ) )

(define-inline (%check-exact loc obj)
  (##sys#check-exact obj loc) )


;;;

(module stack (;export
        make-stack
        list->stack
        stack?
        stack-empty?
        stack-count
        stack-peek
        stack-empty!
        stack-poke!
        stack-push!
        stack-cut!
        stack-pop!
        stack->list
        stack-fold
        stack-map
        stack-for-each)

(import
  scheme
  (only chicken
    optional                ;due to #!optional implementation
    let-optionals           ;due to #!optional implementation
    unless when
    define-record-printer)
  (only ports
    with-output-to-port) )

(define (make-stack)
        (%make-stack) )

(define (list->stack ls)
  (%check-list 'list->stack ls)
        (let ([stk (%make-stack)])
    (%stack-count-set! stk (%length ls))
    (%stack-list-set! stk (%list-copy ls))
    stk ) )

(define (stack? obj)
        (%stack? obj) )

(define (stack-empty? stk)
  (%check-stack 'stack-empty? stk)
        (%stack-empty? stk) )

(define (stack-count stk)
  (%check-stack 'stack-count stk)
        (%stack-count stk) )

(define (stack-peek stk #!optional (idx 0))
  (%check-stack 'stack-peek stk)
        (%car (%stack-node-ref 'stack-peek stk idx)) )

(define (stack-empty! stk)
  (%check-stack 'stack-empty! stk)
        (%stack-empty! stk) )

(define (stack-poke! stk obj #!optional (idx 0))
  (%check-stack 'stack-poke! stk)
        (%set-car!/maybe-immediate (%stack-node-ref 'stack-poke! stk idx) obj) )

(define (stack-push! stk #!rest ls)
  (%check-stack 'stack-push! stk)
        (unless (%null? ls) (%stack-push! stk ls)) )

(define (stack-cut! stk start #!optional (end (%stack-count stk)))
  (%check-stack 'stack-cut! stk)
  (%check-exact 'stack-cut! start)
  (%check-exact 'stack-cut! end)
  (%check-index 'stack-cut! start 0 end)
  (%check-index 'stack-cut! end start (%fx+ (%stack-count stk) 1))
  (let ([cnt (%fx- end start)])
    (%stack-count-dec! stk cnt)
    ; From the top?
    (if (%fx= 0 start)
        ;then removing leading elements
        (let* ([spr (%stack-list stk)]
               [epr (%list-pair-ref spr (%fx- cnt 1))]
               [ls spr])
          (%stack-list-set! stk (%cdr epr))
          (%set-cdr!/immediate epr '())
          ls )
        ;else removing interior elements
        (let* ([spr (%stack-node-ref 'stack-cut! stk (%fx- start 1))]
               [epr (%list-pair-ref spr cnt)]
               [ls (%cdr spr)])
          (%set-cdr!/maybe-immediate spr (%cdr epr))
          (%set-cdr!/immediate epr '())
          ls ) ) ) )

(define (stack-pop! stk)
  (%check-stack 'stack-pop! stk)
        (%check-stack-underflow 'stack-pop! stk)
        (%stack-pop! stk) )

(define (stack->list stk)
  (%check-stack 'stack->list stk)
        (%list-copy (%stack-list stk)) )

(define (stack-fold stk func init)
  (%check-stack 'stack-fold stk)
        (%list-fold-1 func init (%stack-list stk)) )

(define (stack-map stk func)
  (%check-stack 'stack-map stk)
        (%list-map-1 func (%stack-list stk)) )

(define (stack-for-each stk proc)
  (%check-stack 'stack-for-each stk)
        (%list-for-each-1 proc (%stack-list stk)) )

;;; Read/Print Syntax

(define-record-printer (stack stk out)
  (with-output-to-port out
    (lambda ()
      (display "#<stack")
      (display " count = ") (display (%stack-count stk))
      (display ">") ) ) )

) ;module stack