1; Part of Scheme 48 1.9.  See file COPYING for notices and license.
2
3; Authors: Richard Kelsey, Jonathan Rees, Mike Sperber
4
5; package -> template
6
7(define (compile-package package)
8  (let ((template (compile-forms ((get-optimizer
9				     (package-optimizer-names package))
10				    (expand-package package)
11				    package)
12				 (package-name package)
13				 (package-uid package))))
14    (link! template package #t)		; #t means warn about undefined variables
15    template))
16
17; First we map down the FORMS+FILES, adding the filenames to ENV and
18; scanning the forms.  Then we walk down the list of scanned forms and
19; expand all the macros.
20;
21; All of the reversing in the second step makes it so that we process the
22; forms in there original order, to keep any errors or warnings in as
23; appropriate an order as possible, and then return them in their original
24; order.
25
26(define (expand-package package)
27  (let ((env (package->environment package)))
28    (call-with-values
29     (lambda ()
30       (package-source package))
31     (lambda (forms+files transforms needs-primitives?)
32       (for-each (lambda (name)
33		   (define-usual-transform env name))
34		 transforms)
35       (let ((scanned+envs
36	      (map (lambda (forms+file)
37		     (let ((filename (car forms+file))
38			   (forms (cdr forms+file)))
39		       (let ((env (bind-source-file-name filename env)))
40			 (cons env
41			       (scan-forms forms env)))))
42		   (if needs-primitives?
43		       `((#f . ,(define-primitives env))
44			 . ,forms+files)
45		       forms+files))))
46	 (reverse
47	  (fold (lambda (scanned+env expanded)
48		  (let ((env (car scanned+env)))
49		    (fold (lambda (form expanded)
50			    (cons (delay (expand-scanned-form form env))
51				  expanded))
52			  (cdr scanned+env)
53			  expanded)))
54		scanned+envs
55		'())))))))
56
57; NAME is the name of one of the usual Scheme macros (AND, OR, COND, and so
58; forth).  This adds the appropriate transform to ENV.
59
60(define (define-usual-transform env name)
61  (comp-env-define! env
62		    name
63		    syntax-type
64		    (make-transform/macro (usual-transform name)
65					  (extract-package-from-comp-env env)
66					  syntax-type
67					  `(usual-transform ',name)
68					  name)))
69
70; This adds definitions of all operators to ENV and returns a list of forms
71; that define the closed-compiled versions of those operators that have such.
72; It also adds a definition of ALL-OPERATORS to a vector of all the primitive
73; operators, mostly for later use by the debugger to identify which primop
74; caused an exception.
75
76(define (define-primitives env)
77  (table-walk (lambda (name op)
78		(let ((type (operator-type op)))
79		  (if (not (eq? (operator-type op) 'leaf))
80		      (comp-env-define! env name (operator-type op) op))))
81	      operators-table)
82
83  (comp-env-define! env 'all-operators vector-type)
84
85  (let ((all-operators-node (expand 'all-operators env))
86	(vector-set!-node (make-node operator/literal (get-primop 'vector-set!)))
87	(procs '())
88	(index 0))
89
90    (define (make-define-primitive-node name env)
91      (make-node operator/define
92		 `(define ,(expand name env)
93		    ,(make-node operator/primitive-procedure
94				`(primitive-procedure ,name)))))
95
96    (define (make-register-primitive name index env)
97      (make-node operator/call
98		 (cons vector-set!-node
99		       (list all-operators-node
100			     (make-node operator/literal index)
101			     (expand name env)))))
102
103    (walk-primops (lambda (name type primop)
104		    (comp-env-define! env name type primop)
105		    (set! procs
106			  (cons (make-define-primitive-node name env)
107				(cons
108				 (make-register-primitive name index env)
109				 procs)))
110		    (set! index (+ 1 index))))
111
112    (set! procs
113	  (cons
114	   (make-node
115	    operator/define
116	    `(define ,all-operators-node
117	       ,(make-node operator/call
118			   (cons (make-node operator/literal
119					    (get-primop 'make-vector))
120				 (list (make-node operator/literal
121						  index))))))
122	   procs))
123
124    procs))
125
126