/usr/share/racket/collects/syntax/toplevel.rkt is in racket-common 6.7-3.
This file is owned by root:root, with mode 0o644.
The actual contents of the file can be viewed below.
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 | (module toplevel racket/base
(require "kerncase.rkt"
racket/undefined)
(provide eval-compile-time-part-of-top-level
eval-compile-time-part-of-top-level/compile
expand-top-level-with-compile-time-evals
expand-syntax-top-level-with-compile-time-evals
expand-syntax-top-level-with-compile-time-evals/flatten)
;; eval-compile-time-part-of-top-level/compile : syntax -> (listof compiled-expression)
(define (eval-compile-time-part-of-top-level/compile expr)
(map (lambda (e) (compile-and-eval-compile-time-part e #t))
(flatten-out-begins expr)))
(define (eval-compile-time-part-of-top-level stx)
(for-each (lambda (e) (compile-and-eval-compile-time-part e #f))
(flatten-out-begins stx)))
(define (expand-top-level-with-compile-time-evals stx)
(expand-syntax-top-level-with-compile-time-evals
(namespace-syntax-introduce stx)))
;; expand-syntax-top-level-with-compile-time-evals/flatten : syntax -> (listof syntax)
(define (expand-syntax-top-level-with-compile-time-evals/flatten stx)
(let loop ([stx stx])
(let ([e (expand-syntax-to-top-form stx)])
(syntax-case e (begin)
[(begin expr ...)
(apply append (map loop (syntax->list (syntax (expr ...)))))]
[else
(let ([e (expand-syntax e)])
(compile-and-eval-compile-time-part e #f)
(list e))]))))
(define (expand-syntax-top-level-with-compile-time-evals stx)
(let ([e (expand-syntax-to-top-form stx)])
(syntax-case e (begin)
[(begin expr ...)
(with-syntax ([(expr ...)
;;left-to-right part of this map is important:
(map expand-syntax-top-level-with-compile-time-evals
(syntax->list (syntax (expr ...))))]
[(beg . _) e])
(datum->syntax e (syntax-e (syntax (beg expr ...))) e e))]
[else
(let ([e (expand-syntax e)])
(compile-and-eval-compile-time-part e #f)
e)])))
;; compile-and-eval-compile-time-part : syntax boolean -> (union syntax compiled-expression)
;; compiles the syntax it receives as an argument and evaluates the compile-time part of it.
;; result depends on second argument. If #t, returns compiled expressions
;; if #f, returns void (and doesn't do any extra compilation)
;; pre: there are no top-level begins in stx.
(define (compile-and-eval-compile-time-part stx compile?)
(let ([eval/compile (lambda (stx)
(let ([compiled (compile-syntax stx)])
(eval compiled)
(when compile?
compiled)))])
(kernel-syntax-case stx #f
[(#%require req ...)
(begin0
(when compile? (compile-syntax stx))
(for-each (lambda (req) (namespace-require/expansion-time (syntax->datum req)))
(syntax->list (syntax (req ...)))))]
[(module . _)
(eval/compile stx)]
[(define-syntaxes . _)
(eval/compile stx)]
[(begin-for-syntax . _)
(eval/compile stx)]
[(define-values (id ...) . _)
(begin0
(when compile? (compile-syntax stx))
(for-each (lambda (id)
(with-syntax ([id id])
(eval-syntax (syntax (define-values (id) undefined)))))
(syntax->list (syntax (id ...)))))]
[_else
(when compile? (compile-syntax stx))])))
;; flatten-out-begins : syntax -> (listof syntax)
;; flattens out the begins in a top-level expression,
;; into multiple expressions
(define (flatten-out-begins expr)
(let loop ([expr expr])
(let ([expr (expand-syntax-to-top-form expr)])
(syntax-case expr (begin)
[(begin expr ...)
(apply append (map loop (syntax->list (syntax (expr ...)))))]
[else
(list expr)])))))
|