;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;;  ClassicJava: an implementation of the ClassicJava programming language
;;  store.ss: Implementation of a functional store.
;;  Copyright (C) 2005  Richard Cobbe
;;
;; This store is implemented as an alist(-ish), but note that store-update
;; (functionally) replaces the value in the existing alist rather than
;; returning a longer alist.  This is helpful for debugging and testing.
;;
;; =================================================================
;;
;;  This library is free software; you can redistribute it and/or modify it
;;  under the terms of the GNU Lesser General Public License as published by
;;  the Free Software Foundation; either version 2.1 of the License, or (at
;;  your option) any later version.
;;
;;  This library is distributed in the hope that it will be useful, but WITHOUT
;;  ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;;  FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
;;  License for more details.
;;
;;  You should have received a copy of the GNU Lesser General Public License
;;  along with this library; if not, write to the Free Software Foundation,
;;  Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module store mzscheme

  (require (lib "contract.ss")
           (lib "etc.ss")
           (planet "inspector.ss" ("dherman" "inspector.plt" 1 0)))

  (with-public-inspector
   (define-struct store (top contents)))
  ;; (Store X) ::= (make-store Number (Listof (List Number X)))

  ;; store-alloc :: (Store X) X -> Number (Store X)
  ;; allocates & inits new entry in store; returns new location and new store
  (define store-alloc
    (lambda (store new-val)
      (let* ([addr (store-top store)]
             [next-top (add1 addr)])
        (values addr
                (make-store next-top (cons (list addr new-val)
                                           (store-contents store)))))))

  ;; store-ref :: (Store X) Number -> X
  ;; looks up value at locn in store; invokes FK if bad address.
  ;; Default fk raises exn:application:mismatch.
  (define store-ref
    (opt-lambda (store locn [fk (lambda ()
                                  (raise (make-exn:fail:contract
                                          (format
                                           "address ~a not in domain of store"
                                           locn)
                                          (current-continuation-marks))))])
      (let loop ([entries (store-contents store)])
        (cond
          [(null? entries) (fk)]
          [(= locn (caar entries)) (cadar entries)]
          [else (loop (cdr entries))]))))

  ;; store-update :: (Store X) Number X -> (Store X)
  ;; Updates store at locn.  If locn invalid, raises exn:application:mismatch.
  (define store-update
    (lambda (store locn val)
      (make-store (store-top store)
                  (let loop ([entries (store-contents store)])
                    (cond
                      [(null? entries)
                       (raise (make-exn:fail:contract
                               (format
                                "attempted to update address (~a) not in store"
                                locn)
                               (current-continuation-marks)))]
                      [(= locn (caar entries))
                       (cons (list locn val) (cdr entries))]
                      [else (cons (car entries) (loop (cdr entries)))])))))

  (define empty-store (make-store 0 null))

  ;; create-store :: (List Number X)* -> (Store X)
  ;; Creates a store from a sequence of address/value lists.
  (define create-store
    (lambda entries
      (let ([max-addr (apply max (cons -1 (map car entries)))])
        (make-store (add1 max-addr) entries))))

  ;; builds a store out of a list of address/value pairs (much like the
  ;; hash-table macro in etc.ss).
  (define-syntax build-store
    (syntax-rules ()
      [(_ (addr value) ...)
       (create-store (list addr value) ...)]))

  ;; (Store X) -> (AList Number X))
  ;; converts store to alist for display
  (define store->alist
    (lambda (store)
      (map (lambda (entry) (cons (car entry) (cadr entry)))
           (store-contents store))))

  (provide/contract
   [store-alloc     (-> store? any/c (values number? store?))]
   [store-ref       (opt->* (store? number?)
                            ((-> any))
                            any)]
   [store-update    (-> store? number? any/c store?)]
   [empty-store     store?]
   [store?          (-> any/c boolean?)]
   [store->alist    (-> store? (listof (cons/c number? any/c)))])

  (provide [rename build-store store]))