;;;; 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.

;;;

(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
      declare
      define-inline
      define-constant
      define-for-syntax
      include
      optional let-optionals  ;due to #!optional implementation
      unless when
      define-record-printer
      define-reader-ctor)
    (only ports with-output-to-port)
    (only type-errors define-error-type error-list error-fixnum))

  (require-library ports type-errors)

  (declare
    (bound-to-procedure
      ##sys#signal-hook ) )

  (include "chicken-primitive-object-inlines")
  (include "inline-type-checks")

;; Stack Support

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

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

(define-inline (%valid-stack? obj)
  (and #;(%stack? obj)
       (%fx= 3 (%structure-length obj))
       (%list? (%stack-list obj)) ) )

;; Stack List

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

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

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

(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 (%pair? pr) pr
			  (error-outside-range loc idx 0 (%stack-count stk)) ) ) )

;; Helpers


(define-inline (%check-stack loc obj)
  (unless (%stack? obj) (error-stack loc obj))
  (unless (%valid-stack? obj) (error-corrupted-stack loc obj)) )

(define-inline (%check-stack-underflow loc stk)
  (when (%stack-empty? stk) (error-stack-underflow loc stk)) )

(define-inline (%check-fixnum-index loc lfx fx hfx)
  (unless (%fxclosed-left? lfx fx hfx) (error-outside-range loc fx lfx hfx)) )

;;;

(define-error-type stack)

(define (error-corrupted-stack loc obj)
  (##sys#signal-hook #:runtime-error loc "stack corrupted" obj) )

(define (error-stack-underflow loc stk)
  (##sys#signal-hook #:limit-error loc "stack underflow" stk) )

(define (error-outside-range loc obj low high)
  (##sys#signal-hook #:bounds-error loc "out of range" obj low high) )

;;;

(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!/mutate (%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-fixnum 'stack-cut! start)
  (%check-fixnum 'stack-cut! end)
  (%check-fixnum-index 'stack-cut! 0 start end)
  (%check-fixnum-index 'stack-cut! start end (%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!/mutate 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 (%stack-list stk))
      (display #\)) ) ) )

(define-reader-ctor 'stack list->stack)

) ;module stack