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



; *** Symbol table ***


(import (rnrs exceptions)
	(srfi srfi-1)
	(srfi srfi-13)
	(th-scheme-utilities stdutils)
	(th-scheme-utilities hrecord))


(define gl-i-symtbl-size 10000)


(define-hrecord-type <environment> () toplevel? parent ht al)


(define-hrecord-type <pure-proc-env> (<environment>))


(define s-symbol? symbol?)


(define s-symbol
  (lambda (name)
    (cond
     ((symbol? name) name)
     ((string? name) (string->symbol name))
     (else (raise 'type-error)))))


; eq? vertaa Schemen symbolit oikein (R4RS)
(define s-symbol=? eq?)


(define target-symbol? symbol?)


(define target-symbol
  (lambda (name)
    (cond
     ((symbol? name) name)
     ((string? name) (string->symbol name))
     (else (raise 'type-error)))))


(define target-symbol=? eq?)


(define symbol-s->t identity)


(define (s-symbol-inquire symbols sym)
  (assq sym symbols))

(define (s-symbol-associate symbols sym location)
  (if (and (not-null? sym) (s-symbol-inquire symbols sym))
      (raise 'duplicate-binding)
      (cons (cons sym location) symbols)))


;; (define s-symbol-remove! (alist-remover s-symbol=?))


(define (get-symbol symtbl sym)
  (if (hfield-ref symtbl 'toplevel?)
      (symbol-hash-ref (hfield-ref symtbl 'ht) sym)
      (let ((x (s-symbol-inquire (hfield-ref symtbl 'al) sym)))
	(if x
	    (cdr x)
	    (let ((par (hfield-ref symtbl 'parent)))
	      (if (not-null? par)
		  (get-symbol par sym)
		  #f))))))


(define (symbol-exists? symtbl sym)
  (if (get-symbol symtbl sym) #t #f))


(define (symbol-exists-deepest? symtbl sym)
  (if (hfield-ref symtbl 'toplevel?)
      (symbol-hash-ref (hfield-ref symtbl 'ht) sym)
      (let ((x (s-symbol-inquire (hfield-ref symtbl 'al) sym)))
	(if x #t #f))))


(define (add-symbol! symtbl sym location)
  (assert (symbol? sym))
  (if (hfield-ref symtbl 'toplevel?)
      (symbol-hash-set! (hfield-ref symtbl 'ht) sym location)
      (hfield-set! symtbl 'al
		   (s-symbol-associate
		    (hfield-ref symtbl 'al) sym location)))
  '())


(define (make-global-environment i-size)
  (make-hrecord <environment> #t '() (make-hash-table i-size) '()))


(define (clone-symbol-hashtable ht)
  (assert (hash-table? ht))
  (let ((ht-new (make-hash-table gl-i-symtbl-size)))
    (hash-for-each
     (lambda (sym-key obj-value)
       (hashx-set! symbol-hash symbol-assoc ht-new sym-key obj-value))
     ht)
    ht-new))


(define (clone-environment env)
  (let* ((ht-old (hfield-ref env 'ht))
	 (ht-new (if (not-null? ht-old)
		     (clone-symbol-hashtable ht-old)
		     '())))
    (make-hrecord <environment> 
		  (hfield-ref env 'toplevel?)
		  (hfield-ref env 'parent)
		  ht-new
		  (hfield-ref env 'al))))


(define (make-environment env-parent al-bindings)
  (make-hrecord <environment> #f env-parent '() al-bindings))

(define (make-pure-proc-env env-parent al-bindings)
  (make-hrecord <pure-proc-env> #f env-parent '() al-bindings))


(define global-builtins-symtbl (make-global-environment gl-i-symtbl-size))
