1(module toplevel racket/base
2  (require "kerncase.rkt"
3           racket/undefined)
4
5  (provide eval-compile-time-part-of-top-level
6           eval-compile-time-part-of-top-level/compile
7           expand-top-level-with-compile-time-evals
8           expand-syntax-top-level-with-compile-time-evals
9           expand-syntax-top-level-with-compile-time-evals/flatten)
10
11  ;; eval-compile-time-part-of-top-level/compile : syntax -> (listof compiled-expression)
12  (define (eval-compile-time-part-of-top-level/compile expr)
13    (map (lambda (e) (compile-and-eval-compile-time-part e #t))
14         (flatten-out-begins expr)))
15
16  (define (eval-compile-time-part-of-top-level stx)
17    (for-each (lambda (e) (compile-and-eval-compile-time-part e #f))
18              (flatten-out-begins stx)))
19
20  (define (expand-top-level-with-compile-time-evals stx)
21    (expand-syntax-top-level-with-compile-time-evals
22     (namespace-syntax-introduce stx)))
23
24  ;; expand-syntax-top-level-with-compile-time-evals/flatten : syntax -> (listof syntax)
25  (define (expand-syntax-top-level-with-compile-time-evals/flatten stx)
26    (let loop ([stx stx])
27      (let ([e (expand-syntax-to-top-form stx)])
28        (syntax-case e (begin)
29          [(begin expr ...)
30           (apply append (map loop (syntax->list (syntax (expr ...)))))]
31          [else
32           (let ([e (expand-syntax e)])
33             (compile-and-eval-compile-time-part e #f)
34             (list e))]))))
35
36  (define (expand-syntax-top-level-with-compile-time-evals stx)
37    (let ([e (expand-syntax-to-top-form stx)])
38      (syntax-case e (begin)
39        [(begin expr ...)
40         (with-syntax ([(expr ...)
41                        ;;left-to-right part of this map is important:
42                        (map expand-syntax-top-level-with-compile-time-evals
43                             (syntax->list (syntax (expr ...))))]
44                       [(beg . _) e])
45           (datum->syntax e (syntax-e (syntax (beg expr ...))) e e))]
46        [else
47         (let ([e (expand-syntax e)])
48           (compile-and-eval-compile-time-part e #f)
49           e)])))
50
51  ;; compile-and-eval-compile-time-part : syntax boolean -> (union syntax compiled-expression)
52  ;; compiles the syntax it receives as an argument and evaluates the compile-time part of it.
53  ;; result depends on second argument. If #t, returns compiled expressions
54  ;; if #f, returns void (and doesn't do any extra compilation)
55  ;; pre: there are no top-level begins in stx.
56  (define (compile-and-eval-compile-time-part stx compile?)
57    (let ([eval/compile (lambda (stx)
58                          (let ([compiled (compile-syntax stx)])
59                            (eval compiled)
60                            (when compile?
61                              compiled)))])
62      (kernel-syntax-case stx #f
63        [(#%require req ...)
64	 (begin0
65	  (when compile? (compile-syntax stx))
66	  (for-each (lambda (req) (namespace-require/expansion-time (syntax->datum req)))
67		    (syntax->list (syntax (req ...)))))]
68        [(module . _)
69         (eval/compile stx)]
70        [(define-syntaxes . _)
71         (eval/compile stx)]
72        [(begin-for-syntax . _)
73         (eval/compile stx)]
74        [(define-values (id ...) . _)
75	 (begin0
76	  (when compile? (compile-syntax stx))
77	  (for-each (lambda (id)
78		      (with-syntax ([id id])
79			(eval-syntax (syntax (define-values (id) undefined)))))
80		    (syntax->list (syntax (id ...)))))]
81        [_else
82         (when compile? (compile-syntax stx))])))
83
84  ;; flatten-out-begins : syntax -> (listof syntax)
85  ;; flattens out the begins in a top-level expression,
86  ;; into multiple expressions
87  (define (flatten-out-begins expr)
88    (let loop ([expr expr])
89      (let ([expr (expand-syntax-to-top-form expr)])
90	(syntax-case expr (begin)
91	  [(begin expr ...)
92	   (apply append (map loop (syntax->list (syntax (expr ...)))))]
93	  [else
94	   (list expr)])))))
95