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