File: theme-d-symbol-table.scm

package info (click to toggle)
theme-d 1.4.0-1
  • links: PTS, VCS
  • area: main
  • in suites: bullseye, sid
  • size: 12,784 kB
  • sloc: lisp: 47,684; sh: 4,200; makefile: 455; ansic: 319
file content (136 lines) | stat: -rw-r--r-- 3,106 bytes parent folder | download
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
;; 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))