blob: 231e27da41bf12e976e713fe2423edab2105ac81 (
about) (
plain)
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
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
;;; This file has some random utilities dealing with instances.
;;; Right now, this is a linear search off the class.
(define (lookup-instance alg-def class-def)
(let ((res (lookup-instance-1 alg-def (class-instances class-def))))
(if (and (eq? res '#f) (algdata-real-tuple? alg-def))
(lookup-possible-tuple-instances alg-def class-def)
res)))
(define (lookup-instance-1 alg-def instances)
(cond ((null? instances)
'#f)
((eq? (instance-algdata (car instances)) alg-def)
(if (instance-ok? (car instances))
(car instances)
'#f))
(else
(lookup-instance-1 alg-def (cdr instances)))))
(define (lookup-possible-tuple-instances alg-def class-def)
(cond ((eq? class-def (core-symbol "Eq"))
(get-tuple-eq-instance alg-def))
((eq? class-def (core-symbol "Ord"))
(get-tuple-ord-instance alg-def))
((eq? class-def (core-symbol "Ix"))
(get-tuple-ix-instance alg-def))
((eq? class-def (core-symbol "Text"))
(get-tuple-text-instance alg-def))
((eq? class-def (core-symbol "Binary"))
(get-tuple-binary-instance alg-def))
(else '#f)))
(define *saved-eq-instances* '())
(define *saved-ord-instances* '())
(define *saved-ix-instances* '())
(define *saved-text-instances* '())
(define *saved-binary-instances* '())
(define (get-tuple-eq-instance tpl)
(let ((res (assq tpl *saved-eq-instances*)))
(if (not (eq? res '#f))
(tuple-2-2 res)
(let ((inst (make-tuple-instance
tpl (core-symbol "Eq") (core-symbol "tupleEqDict"))))
(push (tuple tpl inst) *saved-eq-instances*)
inst))))
(define (get-tuple-ord-instance tpl)
(let ((res (assq tpl *saved-ord-instances*)))
(if (not (eq? res '#f))
(tuple-2-2 res)
(let ((inst (make-tuple-instance
tpl (core-symbol "Ord") (core-symbol "tupleOrdDict"))))
(push (tuple tpl inst) *saved-ord-instances*)
inst))))
(define (get-tuple-ix-instance tpl)
(let ((res (assq tpl *saved-ix-instances*)))
(if (not (eq? res '#f))
(tuple-2-2 res)
(let ((inst (make-tuple-instance
tpl (core-symbol "Ix") (core-symbol "tupleIxDict"))))
(push (tuple tpl inst) *saved-ix-instances*)
inst))))
(define (get-tuple-text-instance tpl)
(let ((res (assq tpl *saved-text-instances*)))
(if (not (eq? res '#f))
(tuple-2-2 res)
(let ((inst (make-tuple-instance
tpl (core-symbol "Text") (core-symbol "tupleTextDict"))))
(push (tuple tpl inst) *saved-text-instances*)
inst))))
(define (get-tuple-binary-instance tpl)
(let ((res (assq tpl *saved-binary-instances*)))
(if (not (eq? res '#f))
(tuple-2-2 res)
(let ((inst (make-tuple-instance
tpl (core-symbol "Binary")
(core-symbol "tupleBinaryDict"))))
(push (tuple tpl inst) *saved-binary-instances*)
inst))))
(define (make-tuple-instance algdata class dict)
(let* ((size (tuple-size algdata))
(tyvars (gen-symbols size))
(context (map (lambda (tyvar)
(**context (**class/def class) tyvar))
tyvars))
(sig (**tycon/def algdata (map (lambda (x) (**tyvar x)) tyvars)))
(gcontext (gtype-context (ast->gtype context sig))))
(make instance
(algdata algdata)
(tyvars tyvars)
(class class)
(context context)
(gcontext gcontext)
(methods '())
(dictionary dict)
(ok? '#t)
(special? '#t))))
;;; I know these are somewhere else too ...
(define (tuple-size alg)
(con-arity (car (algdata-constrs alg))))
(define (gen-symbols n)
(gen-symbols-1 n '(|a| |b| |c| |d| |e| |f| |g| |h| |i| |j| |k| |l| |m|
|n| |o| |p| |q| |r| |s| |t| |u| |v| |w| |x| |y| |z|)))
(define (gen-symbols-1 n vars)
(if (eqv? n 0)
'()
(if (null? vars)
(cons (string->symbol (format '#f "x~A" n))
(gen-symbols-1 (1- n) '()))
(cons (car vars) (gen-symbols-1 (1- n) (cdr vars))))))
;;; This handles the dynamic linking of instances into classes
(define (link-instances modules)
(dolist (m modules)
;; clear out any instances sitting around from old compiles
(dolist (class (module-class-defs m))
(setf (class-instances class) '())))
(dolist (m modules)
(dolist (inst (module-instance-defs m))
(link-instance inst)))
)
(define (link-instance inst) ; links an instance into the associated class
(push inst (class-instances (instance-class inst))))
;;; This creates a new instance object and installs it.
(predefine (make-new-var name)) ; in tdecl/tdecl-utils.scm
(define (new-instance class algdata tyvars)
(let* ((dict-name
(string-append "dict-"
(symbol->string (print-name class)) "-"
(symbol->string (print-name algdata))))
(inst (make instance (algdata algdata)
(tyvars tyvars)
(class class)
(gcontext '())
(context '())
(dictionary (make-new-var dict-name)))))
(link-instance inst)
inst))
|
