;;; -*- Mode: Scheme -*-

;;;; Silly Mock-Up Hash Maps for Scheme48
;;;; (Not an example of the stubber; just needed by unix-fd.scm.)

;;; Copyright (c) 2009, Taylor R. Campbell
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; * Redistributions of source code must retain the above copyright
;;;   notice, this list of conditions and the following disclaimer.
;;;
;;; * Redistributions in binary form must reproduce the above copyright
;;;   notice, this list of conditions and the following disclaimer in
;;;   the documentation and/or other materials provided with the
;;;   distribution.
;;;
;;; * Neither the names of the authors nor the names of contributors
;;;   may be used to endorse or promote products derived from this
;;;   software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY
;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

;;; All that are implemented here are fake tail-weak integer-keyed hash
;;; maps.  `Fake' because even if some datum is reclaimed by the
;;; garbage collector, its entry may remain in the hash map occupying
;;; space uselessly.  Also, not all important operations are provided
;;; -- only those needed for unix-fd.scm are defined here.

(define false-token (list 'FALSE))

(define (canonicalize datum)
  (if (not datum)
      false-token
      datum))

(define (decanonicalize canonical-datum)
  (if (eq? canonical-datum false-token)
      #f
      canonical-datum))

(define (make-tail-weak-integer-hash-map)
  (make-integer-table))

(define (with-hash-map-locked hash-map procedure)
  hash-map                              ;ignore
  (with-interrupts-inhibited procedure))

(define (hash-map/update! hash-map key if-found if-not-found)
  (define (replace datum*)
    (hash-map/insert! hash-map key datum*))
  (define (delete)
    (hash-map/delete! hash-map key))
  (define (insert datum*)
    (hash-map/insert! hash-map key datum*))
  (hash-map/search hash-map key
    (lambda (datum)
      (if-found datum replace delete))
    (lambda ()
      (if-not-found insert))))

(define (hash-map/intern! hash-map key generator)
  (hash-map/update! hash-map key
    (lambda (datum replace delete)
      replace delete                    ;ignore
      datum)
    (lambda (insert)
      (let ((datum (generator)))
        (insert datum)
        datum))))

(define (hash-map/insert! hash-map key datum)
  (with-hash-map-locked hash-map
    (lambda ()
      (table-set! hash-map key (make-weak-pointer (canonicalize datum))))))

(define (hash-map/delete! hash-map key)
  (with-hash-map-locked hash-map
    (lambda ()
      (table-set! hash-map key #f))))

(define (hash-map/search hash-map key if-found if-not-found)
  (let ((weak-pointer (table-ref hash-map key)))
    (if weak-pointer
        (let ((canonical-datum (weak-pointer-ref weak-pointer)))
          (if canonical-datum
              (if-found (decanonicalize canonical-datum))
              (begin
                (hash-map/delete! hash-map key)
                (if-not-found))))
        (if-not-found))))

(define (hash-map/lookup hash-map key default)
  (hash-map/search hash-map key values (lambda () default)))