blob: 07722dd268c2e4cf4dae290e66423567a1329baa (
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
|
;;; File: top-definitions.scm
;;; Description: This creates definitions for all top level (exportable)
;;; object in a module.
(define (create-top-definitions)
(dolist (decl (module-decls *module*))
(if (eq? (module-type *module*) 'interface)
(when (signdecl? decl)
(create-var-definitions decl (signdecl-vars decl)))
(when (valdef? decl)
(create-var-definitions
decl (collect-pattern-vars (valdef-lhs decl))))))
(dolist (algdata (module-algdatas *module*))
(create-alg-definitions algdata))
(dolist (synonym (module-synonyms *module*))
(create-syn-definitions synonym))
(dolist (class (module-classes *module*))
(create-class-definitions class)))
;;; ------------------------------------------------------------------------
;;; creation of definitions
;;; ------------------------------------------------------------------------
(define (create-var-definitions decl vars)
(remember-context decl
(dolist (v vars)
(let* ((var-name (var-ref-name v))
(def (create-top-definition var-name 'var)))
(setf (var-ref-var v) def)
(push def (module-vars *module*))
(add-new-group var-name def)))))
;;; This also creates definitions for the constructors
(define (create-alg-definitions algdata)
(remember-context algdata
(with-slots data-decl (simple constrs) algdata
(let* ((alg-name (tycon-name simple))
(def (create-top-definition alg-name 'algdata)))
(setf (tycon-def simple) def)
(let ((constr-group
(map (lambda (constr)
(let* ((con-ref (constr-constructor constr))
(con-name (con-ref-name con-ref))
(con-def (create-top-definition con-name 'con)))
(setf (con-ref-con con-ref) con-def)
(tuple con-name con-def)))
constrs)))
(setf (algdata-constrs def) (map (function tuple-2-2) constr-group))
(setf (tycon-def-arity def) (length (tycon-args simple)))
(add-new-group alg-name def constr-group))))))
(define (create-class-definitions class-decl)
(remember-context class-decl
(with-slots class-decl (class decls) class-decl
(let* ((class-name (class-ref-name class))
(class-def (create-top-definition class-name 'class)))
(setf (class-ref-class class) class-def)
(let ((method-group
(concat
(map
(lambda (decl)
(if (is-type? 'signdecl decl)
(remember-context decl
(map (lambda (method-var)
(let* ((var-name (var-ref-name method-var))
(def (create-top-definition
var-name 'method-var)))
(setf (method-var-class def) class-def)
(setf (method-var-default def) '#f)
(setf (var-ref-var method-var) def)
(tuple var-name def)))
(signdecl-vars decl)))
'()))
decls))))
(setf (class-method-vars class-def)
(map (function tuple-2-2) method-group))
(add-new-group class-name class-def method-group))))))
(define (create-syn-definitions synonym-decl)
(remember-context synonym-decl
(let* ((simple (synonym-decl-simple synonym-decl))
(syn-name (tycon-name simple))
(def (create-top-definition syn-name 'synonym)))
(setf (tycon-def simple) def)
(setf (tycon-def-arity def) (length (tycon-args simple)))
(add-new-group syn-name def))))
(define (add-new-group name def . others)
(when (memq *module* (module-exported-modules *module*))
(export-group (cons (tuple name def)
(if (null? others)
'()
(car others))))))
|