;; -*-theme-*-

;; Copyright (C) 2015  Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3,
;; see file doc/LGPL-3.

(define-body (examples hash-table)


  (import (standard-library list-utilities))

  
  (define-param-proc make-hash-table (%key %value)
		     (((hash (:procedure (%key <integer>) <integer> pure))
		       (eq-pred? (:procedure (%key %key) <boolean> pure))
		       (i-size <integer>))
		      (:hash-table %key %value) pure)
    (let ((v-l (make-mutable-vector
		(:uniform-list (:pair %key (:singleton %value)))
		i-size
		null)))
      (make (:hash-table %key %value) v-l i-size hash eq-pred?)))


  (define-static-param-method gen-assoc (%key %value)
    (((al (:hash-table %key %value)) (obj-key %key))
     (:maybe %value)
     pure)
    (let* ((i-index ((field-ref al 'hash) obj-key (field-ref al 'i-size)))
	   (l-assoc (mutable-vector-ref (field-ref al 'v-l-contents) i-index))
	   (obj-assoc (assoc-general obj-key l-assoc
				     null (field-ref al 'eq-pred?))))
      (if (not-null? obj-assoc)
	  (let ((obj1 (cast (:pair %key (:singleton %value)) obj-assoc)))
	    (singleton-get-element (cdr obj1)))
	  null)))


  (define-static-param-method gen-assoc-set! (%key %value)
    (((al (:hash-table %key %value))
      (obj-key %key)
      (obj-value %value))
     <none>
     nonpure)
    (let* ((i-index ((field-ref al 'hash) obj-key (field-ref al 'i-size)))
	   (v-l-contents (field-ref al 'v-l-contents))
	   (l-assoc (mutable-vector-ref v-l-contents i-index))
	   (obj-assoc (assoc-general obj-key l-assoc
				     null (field-ref al 'eq-pred?))))
      (if (not-null? obj-assoc)
	  (let ((obj1 (cast (:pair %key (:singleton %value)) obj-assoc)))
	    (singleton-set-element! (cdr obj1) obj-value))
	  (let* ((sgt (make-singleton obj-value))
		 (binding (cons obj-key sgt)))
	    (mutable-vector-set! v-l-contents i-index
				 (cons binding l-assoc)))))))
