;; -*-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 assoc-list-impl)


  (import (standard-library list-utilities))

  
  (define-param-method make-assoc-list (%key %value)
		       (((eq-pred? (:procedure (%key %key) <boolean> pure))
			 (dummy %value))
			(:assoc-list %key %value) pure)
    (create (:assoc-list %key %value) null eq-pred?))


  (define-static-param-virtual-method gen-assoc (%key %value)
    (((al (:assoc-list %key %value)) (obj-key %key))
     (:maybe %value)
     pure)
    (let ((obj-assoc (assoc-general obj-key (field-ref al 'l-contents)
				    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-virtual-method gen-assoc-set! (%key %value)
    (((al (:assoc-list %key %value))
      (obj-key %key)
      (obj-value %value))
     <none>
     nonpure)
    (let ((obj-assoc (gen-assoc al obj-key)))
      (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)))
	    (field-set! al 'l-contents
			(cons binding (field-ref al 'l-contents))))))))
