Mutable stack implementation in Racket

stack-test.rkt

#lang racket/base

(require rackunit
         racket/match
         "stack.rkt")

; Create stack
(make-stack test-stack)

; Is it a stack?
(check-pred stack? test-stack)

; Is it empty?
(check-equal? (test-stack-size) 0)

; Does popping an empty stack invalidate its contract?
(check-exn exn:fail:contract? (lambda () (test-stack-pop!)))

; Let's push in some stuff...
(define data '("foo" 'bar 123 #t '(1 2 3)))

(letrec ([push-from-list (lambda (data-list [stack-size 0])
                           (match data-list
                             ['()
                              (check-equal? (test-stack-size) stack-size)]
                             [(cons head tail)
                              (let ([new-size (add1 stack-size)])
                                (check-equal? (test-stack-push! head) new-size)
                                (push-from-list tail new-size))]))])
  (push-from-list data))

; Is the stack non-empty?
(check-false (test-stack-empty?))

; Now let's pop them out...
(define popped
  (letrec ([pop-into-list (lambda (output)
                            (if (test-stack-empty?)
                              output
                              (pop-into-list (cons (test-stack-pop!) output))))])
  (pop-into-list '())))

; ...and check they're the same
(check-equal? popped data)

; Is the stack empty?
(check-true (test-stack-empty?))

stack.rkt

(module stack racket
  (module stack-implementation racket
    (struct stack (size buffer) #:mutable)

    ;; size :: stack -> integer
    (define (size stack) (stack-size stack))

    ;; non-empty-stack? :: stack -> boolean
    (define (non-empty-stack? stack)
      (and (stack? stack)
           (not (empty? (stack-buffer stack)))))

    ;; push! :: stack -> any (new item) -> integer (size)
    (define (push! stack item)
      (set-stack-buffer! stack
        (cons item (stack-buffer stack)))

      (set-stack-size! stack (add1 (stack-size stack)))

      (stack-size stack))

    ;; pop! :: (non-empty) stack -> any (head)
    (define (pop! stack)
      (let ([head (car (stack-buffer stack))]
            [tail (cdr (stack-buffer stack))])

        (set-stack-buffer! stack tail)
        (set-stack-size! stack (sub1 (stack-size stack)))

        head))

    ;; make
    (define-syntax-rule (make name)
      (define name (stack 0 '())))

    (provide make
             stack?
             (contract-out
               [size  (-> stack?            integer?)]
               [push! (-> stack? any/c      integer?)]
               [pop!  (-> non-empty-stack?  any/c)])))

  (require 'stack-implementation
           (for-syntax racket/syntax))
  
  ;; make-stack
  ;  Defines a stack under the specified symbol <name>
  ;  Plus defines <name>-size, <name>-empty?, <name>-push! and <name>-pop!
  (define-syntax (make-stack stx)
    (syntax-case stx ()
      [(_ name)
        (with-syntax ([(size-fn empty-fn push-fn pop-fn)
                       (map (lambda (fn) (format-id stx "~a-~a" #'name fn))
                            '("size" "empty?" "push!" "pop!"))])
          #'(begin
              (make name)
              (define (size-fn)      (size name))
              (define (empty-fn)     (zero? (size-fn)))
              (define (push-fn item) (push! name item))
              (define (pop-fn)       (pop!  name))))]))

  (provide make-stack
           stack?
           (prefix-out stack- size)
           (prefix-out stack- push!)
           (prefix-out stack- pop!)))