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
|
; Part of Scheme 48 1.9. See file COPYING for notices and license.
; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
; package -> template
(define (compile-package package)
(let ((template (compile-forms ((get-optimizer
(package-optimizer-names package))
(expand-package package)
package)
(package-name package)
(package-uid package))))
(link! template package #t) ; #t means warn about undefined variables
template))
; First we map down the FORMS+FILES, adding the filenames to ENV and
; scanning the forms. Then we walk down the list of scanned forms and
; expand all the macros.
;
; All of the reversing in the second step makes it so that we process the
; forms in there original order, to keep any errors or warnings in as
; appropriate an order as possible, and then return them in their original
; order.
(define (expand-package package)
(let ((env (package->environment package)))
(call-with-values
(lambda ()
(package-source package))
(lambda (forms+files transforms needs-primitives?)
(for-each (lambda (name)
(define-usual-transform env name))
transforms)
(let ((scanned+envs
(map (lambda (forms+file)
(let ((filename (car forms+file))
(forms (cdr forms+file)))
(let ((env (bind-source-file-name filename env)))
(cons env
(scan-forms forms env)))))
(if needs-primitives?
`((#f . ,(define-primitives env))
. ,forms+files)
forms+files))))
(reverse
(fold (lambda (scanned+env expanded)
(let ((env (car scanned+env)))
(fold (lambda (form expanded)
(cons (delay (expand-scanned-form form env))
expanded))
(cdr scanned+env)
expanded)))
scanned+envs
'())))))))
; NAME is the name of one of the usual Scheme macros (AND, OR, COND, and so
; forth). This adds the appropriate transform to ENV.
(define (define-usual-transform env name)
(comp-env-define! env
name
syntax-type
(make-transform/macro (usual-transform name)
(extract-package-from-comp-env env)
syntax-type
`(usual-transform ',name)
name)))
; This adds definitions of all operators to ENV and returns a list of forms
; that define the closed-compiled versions of those operators that have such.
; It also adds a definition of ALL-OPERATORS to a vector of all the primitive
; operators, mostly for later use by the debugger to identify which primop
; caused an exception.
(define (define-primitives env)
(table-walk (lambda (name op)
(let ((type (operator-type op)))
(if (not (eq? (operator-type op) 'leaf))
(comp-env-define! env name (operator-type op) op))))
operators-table)
(comp-env-define! env 'all-operators vector-type)
(let ((all-operators-node (expand 'all-operators env))
(vector-set!-node (make-node operator/literal (get-primop 'vector-set!)))
(procs '())
(index 0))
(define (make-define-primitive-node name env)
(make-node operator/define
`(define ,(expand name env)
,(make-node operator/primitive-procedure
`(primitive-procedure ,name)))))
(define (make-register-primitive name index env)
(make-node operator/call
(cons vector-set!-node
(list all-operators-node
(make-node operator/literal index)
(expand name env)))))
(walk-primops (lambda (name type primop)
(comp-env-define! env name type primop)
(set! procs
(cons (make-define-primitive-node name env)
(cons
(make-register-primitive name index env)
procs)))
(set! index (+ 1 index))))
(set! procs
(cons
(make-node
operator/define
`(define ,all-operators-node
,(make-node operator/call
(cons (make-node operator/literal
(get-primop 'make-vector))
(list (make-node operator/literal
index))))))
procs))
procs))
|
