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

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

;;;

(import typed-modules)

(module stack

(;export
  (make-stack : (-> (struct stack)))
  (list->stack : (list -> (struct stack)))
  (stack? : (* -> boolean))
  (stack-empty? : ((struct stack) -> boolean))
  (stack-count : ((struct stack) -> fixnum))
  (stack-peek : ((struct stack) #!optional fixnum -> *))
  (stack-empty! : ((struct stack) -> undefined))
  (stack-poke! : ((struct stack) * #!optional fixnum -> undefined))
  (stack-push! : ((struct stack) #!rest list -> undefined))
  (stack-cut! : ((struct stack) fixnum #!optional fixnum -> list))
  (stack-pop! : ((struct stack) -> *))
  (stack->list : ((struct stack) -> list))
  (stack-fold : ((struct stack) procedure * -> *))
  (stack-map : ((struct stack) procedure -> list))
  (stack-for-each : ((struct stack) procedure -> undefined)) )

(import
  scheme
  (only chicken
    void
    declare
    define-inline
    define-constant
    define-for-syntax
    include
    optional let-optionals  ;due to #!optional implementation
    unless when
    define-record-printer
    define-reader-ctor))

(import
  (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))
  obj )

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

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

;;;

(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)
	(%stack-empty? (%check-stack 'stack-empty? stk)) )

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

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

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

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

(define (stack-push! stk #!rest ls)
	(unless (%null? ls) (%stack-push! (%check-stack '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)
	(%list-copy (%stack-list (%check-stack 'stack->list stk))) )

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

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

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

;;; Read/Print Syntax

(define-constant SRFI-10-FORMAT "#,(~A )")

(define-record-printer (stack stk out)
  (with-output-to-port out
    (lambda ()
      (display "#,")
      (display "(")
      (display "stack ")
      (display " ")
      (display (%stack-list stk))
      (display ")") ) ) )

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

) ;module stack