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 defines all core symbols.
;;; Core symbols are stored in global variables. The core-symbol
;;; macro just turns a string into a variable name.
(define-syntax (core-symbol str)
(make-core-symbol-name str))
(define (make-core-symbol-name str)
(string->symbol (string-append "*core-" str "*")))
(define (symbol->core-var name)
(make-core-symbol-name (symbol->string name)))
(define (get-core-var-names vars type)
(let ((res (assq type vars)))
(if (eq? res '#f)
'()
(map (function string->symbol) (tuple-2-2 res)))))
;;; This is just used to create a define for each var without a
;;; value.
(define-syntax (define-core-variables)
`(begin
,@(define-core-variables-1 *haskell-prelude-vars*)
,@(define-core-variables-1 *haskell-noncore-vars*)))
(define (define-core-variables-1 vars)
(concat (map (lambda (ty)
(map (function init-core-symbol)
(get-core-var-names vars ty)))
'(classes methods types constructors synonyms values))))
(define (init-core-symbol sym)
`(define ,(symbol->core-var sym) '()))
(define-syntax (create-core-globals)
`(begin
(begin ,@(create-core-defs *haskell-prelude-vars* '#t))
(begin ,@(create-core-defs *haskell-noncore-vars* '#f))))
(define (create-core-defs defs prelude-core?)
`(,@(map (lambda (x) (define-core-value x prelude-core?))
(get-core-var-names defs 'values))
,@(map (lambda (x) (define-core-method x prelude-core?))
(get-core-var-names defs 'methods))
,@(map (lambda (x) (define-core-synonym x prelude-core?))
(get-core-var-names defs 'synonyms))
,@(map (lambda (x) (define-core-class x prelude-core?))
(get-core-var-names defs 'classes))
,@(map (lambda (x) (define-core-type x prelude-core?))
(get-core-var-names defs 'types))
,@(map (lambda (x) (define-core-constr x prelude-core?))
(get-core-var-names defs 'constructors))))
(define (define-core-value name pc?)
`(setf ,(symbol->core-var name)
(make-core-value-definition ',name ',pc?)))
(define (make-core-value-definition name pc?)
(install-core-sym
(make var (name name) (module '|*Core|) (unit '|*Core|))
name
pc?))
(define (define-core-method name pc?)
`(setf ,(symbol->core-var name)
(make-core-method-definition ',name ',pc?)))
(define (make-core-method-definition name pc?)
(install-core-sym
(make method-var (name name) (module '|*Core|) (unit '|*Core|))
name
pc?))
(define (define-core-class name pc?)
`(setf ,(symbol->core-var name)
(make-core-class-definition ',name ',pc?)))
(define (make-core-class-definition name pc?)
(install-core-sym
(make class (name name) (module '|*Core|) (unit '|*Core|))
name
pc?))
(define (define-core-synonym name pc?)
`(setf ,(symbol->core-var name)
(make-core-synonym-definition ',name ',pc?)))
(define (make-core-synonym-definition name pc?)
(install-core-sym
(make synonym (name name) (module '|*Core|) (unit '|*Core|))
name
pc?))
(define (define-core-type name pc?)
`(setf ,(symbol->core-var name)
(make-core-type-definition ',name ',pc?)))
(define (make-core-type-definition name pc?)
(install-core-sym
(make algdata (name name) (module '|*Core|) (unit '|*Core|))
name
pc?))
(define (define-core-constr name pc?)
`(setf ,(symbol->core-var name)
(make-core-constr-definition ',name ',pc?)))
(define (make-core-constr-definition name pc?)
(setf name (add-con-prefix/symbol name))
(install-core-sym
(make con (name name) (module '|*Core|) (unit '|*Core|))
name
pc?))
(define (install-core-sym def name preludecore?)
(setf (def-core? def) '#t)
(when preludecore?
(setf (def-prelude? def) '#t))
(setf (table-entry (dynamic *core-symbols*) name) def)
(when preludecore?
(setf (table-entry (dynamic *prelude-core-symbols*) name) def))
def)
|
