blob: a001b6272ee46f26665f575eaa42bfc3a590576b (
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
|
;;; This file deals with entities in import / export lists
;;; This resolves an entity with the export table of a
;;; module. It returns either a group, the symbol 'error, or the symbol
;;; 'not-found. When force-error? is true, signal an error when
;;; the module is not found & return 'error.
(define (locate-entity/export-table entity mod force-error?)
(let* ((name (entity-name entity))
(group (table-entry (module-export-table mod) name)))
(if (eq? group '#f)
(if (not force-error?)
'not-found
(signal-entity-not-found name (module-name mod)))
(let ((def (group-definition group)))
(cond ((is-type? 'entity-var entity)
group)
((is-type? 'entity-con entity)
(cond ((algdata? def)
(strip-constructors group))
((synonym? def)
(signal-synonym-needs-dots name (module-name mod)))
(else
(signal-wrong-definition
"type constructor" name (module-name mod)))))
((is-type? 'entity-abbreviated entity)
(cond ((algdata? def)
(cond ((hidden-constructors? group)
(if force-error?
(signal-abstract-type
name (module-name mod))
'not-found))
(else
group)))
((or (class? def) (synonym? def))
group)
(else
(signal-wrong-definition
"class or datatype" name (module-name mod)))))
((is-type? 'entity-class entity)
(if (class? def)
(match-constituents group (entity-class-methods entity)
entity "method")
(signal-wrong-definition "class" name (module-name mod))))
((is-type? 'entity-datatype entity)
(if (algdata? def)
(match-constituents group
(entity-datatype-constructors entity)
entity "constructor")
(signal-wrong-definition
"data type" name (module-name mod))))
(else
(error "Bad entity ~s." entity))
)))))
(define (match-constituents group names entity what)
(check-duplicates names entity)
(dolist (n-d (cdr group))
(when (not (memq (tuple-2-1 n-d) names))
(signal-extra-constituent entity (tuple-2-1 n-d) what)))
(dolist (name names)
(when (not (assq name (cdr group)))
(signal-missing-constituent entity name what)))
group)
;;; The following routine locates an entity in the current module.
;;; It may return 'error, 'not-found, or a group.
(define (locate-entity entity)
(let* ((name (entity-name entity))
(def (resolve-toplevel-name name)))
(cond ((eq? def '#f)
'not-found)
((is-type? 'entity-var entity)
(if (method-var? def)
(signal-export-method-var name)
(make-group name def)))
((is-type? 'entity-con entity)
(cond ((algdata? def)
(make-group name def))
((synonym? def)
(signal-synonym-needs-dots name *module-name*))
(else
(signal-wrong-definition
"type constructor" name *module-name*))))
((is-type? 'entity-abbreviated entity)
(cond ((algdata? def)
(require-complete-algdata
(gather-algdata-group name def)))
((synonym? def)
(make-group name def))
((class? def)
(gather-class-group name def))
(else
(signal-wrong-definition
"type constructor or class" name *module-name*))))
((is-type? 'entity-class entity)
(if (class? def)
(match-group-names
(gather-class-group name def)
(entity-class-methods entity)
entity
"method")
(signal-wrong-definition "class" name *module-name*)))
((is-type? 'entity-datatype entity)
(if (algdata? def)
(match-group-names
(require-complete-algdata (gather-algdata-group name def))
(entity-datatype-constructors entity)
entity "constructor")
(signal-wrong-definition "data type" name *module-name*)))
(else
(error "Bad entity ~s." entity)))))
(define (require-complete-algdata group)
(if (hidden-constructors? group)
'not-found
group))
(define (match-group-names group names entity what)
(when (not (eq? group 'not-found))
(match-constituents group names entity what))
group)
|
