684 lines
22 KiB
Scheme
684 lines
22 KiB
Scheme
;; pre-compilation scan
|
|
;; (c) 1996-1997 Sebastian Good
|
|
;; (c) 1997-2001 PLT
|
|
|
|
; Notes mutability of lexical variables.
|
|
; Performs a few very-high-level optimizations, such as
|
|
; throwing away constant expressions in a begin.
|
|
; Performs a few ad hoc optimizations, like (+ x 1)
|
|
; => (add1 x)
|
|
; Normalizes the expression forms:
|
|
; - begin/begin0: flattened as much as possible; empty
|
|
; and one-expression begins are eliminated
|
|
; - ((lambda (x1 ... xn) e) a1 ... an1) => let expression
|
|
; - (define-values () e) => (let-values [() e] (void))
|
|
; (After this phase, a zodiac:top-level-varref is always
|
|
; a global variable.)
|
|
; Infers names for closures and interfaces. (Do this early so
|
|
; that elaboration doesn't mangle the names.)
|
|
; Detects global varrefs to built-in primitives.
|
|
; Detects known immutability of signature vectors produced by */sig
|
|
; forms
|
|
; Lambdas that are really c-lambdas are converted to quote forms
|
|
; containing c-lambda records
|
|
; Applications that are really c-declares are converted to voids
|
|
; Converts define-for-syntax to define-syntaxes (where id module
|
|
; phase distinguishes them in the end)
|
|
|
|
;;; Annotatitons: ----------------------------------------------
|
|
;; binding - `binding-properties' structure
|
|
;; (this is temporary; the next phase will change the
|
|
;; annotation)
|
|
;; varref - empty set of varref attrributes, except that
|
|
;; the varref:primitive attribute can be added, and
|
|
;; the varref:in-module attribute can be added
|
|
;; quote - 'immutable for known immutable quoted vars
|
|
;; lambda - an inferred name (temporary)
|
|
;; module - a module-info record
|
|
;; define-[for-]syntax - in-mod?, wrap RHS with
|
|
;; (for-syntax-in-env (lambda () ...))
|
|
;;; ------------------------------------------------------------
|
|
|
|
(module prephase mzscheme
|
|
(require (lib "unitsig.ss"))
|
|
|
|
(require (lib "zodiac-sig.ss" "syntax"))
|
|
|
|
(require "sig.ss")
|
|
(require "../sig.ss")
|
|
|
|
(provide prephase@)
|
|
(define prephase@
|
|
(unit/sig
|
|
compiler:prephase^
|
|
(import (compiler:option : compiler:option^)
|
|
compiler:library^
|
|
compiler:cstructs^
|
|
(zodiac : zodiac^)
|
|
compiler:zlayer^
|
|
compiler:driver^)
|
|
|
|
(define-struct binding-properties (mutable? unit-i/e? ivar? anchor known-val))
|
|
|
|
(define (prephase:init-binding-properties! binding mutable? unit-i/e? ivar?)
|
|
(set-annotation! binding (make-binding-properties mutable? unit-i/e? ivar? #f #f)))
|
|
|
|
(define (prephase:set-mutable! binding mutable?)
|
|
(set-binding-properties-mutable?! (get-annotation binding) mutable?))
|
|
(define (prephase:set-binding-anchor! binding a)
|
|
(set-binding-properties-anchor! (get-annotation binding) a))
|
|
|
|
(define (prephase:is-mutable? binding)
|
|
(let ([p (get-annotation binding)])
|
|
(and p (binding-properties-mutable? p))))
|
|
(define (prephase:is-ivar? binding)
|
|
(let ([p (get-annotation binding)])
|
|
(and p (binding-properties-ivar? p))))
|
|
(define (prephase:binding-anchor binding)
|
|
(let ([p (get-annotation binding)])
|
|
(and p (binding-properties-anchor p))))
|
|
|
|
;; Used in analyze to temporarily store known-value information for
|
|
;; let[rec] bindings
|
|
(define (prephase:known-val binding)
|
|
(let ([p (get-annotation binding)])
|
|
(and p (binding-properties-known-val p))))
|
|
(define (prephase:set-known-val! binding v)
|
|
(let ([p (get-annotation binding)])
|
|
(if p
|
|
(set-binding-properties-known-val! p v)
|
|
(begin
|
|
(prephase:init-binding-properties! binding #f #f #f)
|
|
(prephase:set-known-val! binding v)))))
|
|
|
|
;; what can be thrown away in a begin?
|
|
(define prephase:dead-expression?
|
|
(one-of zodiac:bound-varref? zodiac:quote-form?
|
|
zodiac:case-lambda-form?))
|
|
|
|
;; what can be ``pushed''?: (begin0 x ...) => (begin ... x)
|
|
(define prephase:begin0-pushable?
|
|
(one-of zodiac:case-lambda-form? zodiac:quote-form?))
|
|
|
|
;; returns a true value if the symbol refers to a primitive function.
|
|
(define prephase:primitive-name?
|
|
(lambda (ast)
|
|
(let ([m (zodiac:top-level-varref-module ast)])
|
|
(or (eq? '#%kernel m)
|
|
(and (box? m)
|
|
(eq? '#%kernel (unbox m)))))))
|
|
|
|
(define (preprocess:adhoc-app-optimization ast prephase-it)
|
|
(let ([fun (zodiac:app-fun ast)])
|
|
(and (zodiac:top-level-varref? fun)
|
|
(prephase:primitive-name? fun)
|
|
(let ([name (zodiac:varref-var fun)]
|
|
[args (zodiac:app-args ast)]
|
|
[new-fun (lambda (newname)
|
|
(prephase-it
|
|
(zodiac:make-top-level-varref
|
|
;; FIXME?: wrong syntax
|
|
(zodiac:zodiac-stx fun)
|
|
(make-empty-box)
|
|
newname
|
|
'#%kernel
|
|
(box '())
|
|
#f
|
|
#f
|
|
#f)))])
|
|
(case name
|
|
[(void) (if (null? args)
|
|
(prephase-it (zodiac:make-special-constant 'void))
|
|
#f)]
|
|
[(list) (if (null? args)
|
|
(prephase-it (zodiac:make-special-constant 'null))
|
|
#f)]
|
|
[(+ -) (when (and (= 2 (length args))
|
|
(zodiac:quote-form? (cadr args))
|
|
(equal? 1 (syntax-e (zodiac:zodiac-stx (zodiac:quote-form-expr (cadr args))))))
|
|
(let ([newname (if (eq? name '+) 'add1 'sub1)])
|
|
(zodiac:set-app-fun! ast (new-fun newname))
|
|
(zodiac:set-app-args! ast (list (car args)))))
|
|
#f] ; always return #f => use the (possibly mutated) ast
|
|
[(verify-linkage-signature-match)
|
|
;; Important optimization for compound-unit/sig: mark signature-defining vectors
|
|
;; as immutable
|
|
(when (= 5 (length args))
|
|
;; Mark 1st, 2nd, 4th, and 5th as 'immutable quotes
|
|
(let ([mark (lambda (qf)
|
|
(when (zodiac:quote-form? qf)
|
|
(set-annotation! qf 'immutable)))])
|
|
(mark (list-ref args 0))
|
|
(mark (list-ref args 1))
|
|
(mark (list-ref args 3))
|
|
(mark (list-ref args 4))))
|
|
#f]
|
|
[else #f])))))
|
|
|
|
(define for-syntax-slot (box #f))
|
|
|
|
;;----------------------------------------------------------------------------
|
|
;; PREPHASE MAIN FUNCTION
|
|
;;
|
|
(define prephase!
|
|
(letrec ([prephase!
|
|
(lambda (ast in-mod? need-val? name)
|
|
(when (compiler:option:debug)
|
|
(zodiac:print-start! (debug:get-port) ast)
|
|
(newline (debug:get-port)))
|
|
(cond
|
|
;;----------------------------------------------------------
|
|
;; CONSTANTS
|
|
;;
|
|
[(zodiac:quote-form? ast) ast]
|
|
|
|
;;----------------------------------------------------------
|
|
;; VARIABLE REFERENCES
|
|
;;
|
|
;; set up all varrefs with an attribute set
|
|
;; note all varrefs to primitives
|
|
;; change unit-bound `top-levels' to lexicals
|
|
;;
|
|
[(zodiac:varref? ast)
|
|
|
|
(set-annotation! ast (varref:empty-attributes))
|
|
|
|
(when (zodiac:top-level-varref? ast)
|
|
(when (prephase:primitive-name? ast)
|
|
(varref:add-attribute! ast varref:primitive))
|
|
(when in-mod?
|
|
(varref:add-attribute! ast varref:in-module)))
|
|
|
|
ast]
|
|
|
|
;;----------------------------------------------------------
|
|
;; LAMBDA EXPRESSIONS
|
|
;;
|
|
[(zodiac:case-lambda-form? ast)
|
|
;; Check for 'mzc-cffi attribute:
|
|
(if (syntax-property (zodiac:zodiac-stx ast) 'mzc-cffi)
|
|
|
|
;; A C glue function. Change to a quote so it gets treated atomically
|
|
(let* ([quote-expr (cadr
|
|
(zodiac:begin-form-bodies (car (zodiac:case-lambda-form-bodies ast))))]
|
|
[elems (syntax-e (zodiac:zodiac-stx (zodiac:quote-form-expr quote-expr)))]
|
|
[fname (syntax-e (car elems))]
|
|
[sname (syntax-e (cadr elems))]
|
|
[arity (syntax-e (caddr elems))]
|
|
[body (syntax-e (cadddr elems))])
|
|
(register-c-lambda-function fname body)
|
|
(zodiac:make-quote-form
|
|
(zodiac:zodiac-stx ast)
|
|
(zodiac:parsed-back ast)
|
|
(zodiac:make-zread
|
|
(datum->syntax-object
|
|
#f
|
|
(make-c-lambda fname sname body arity)
|
|
#f))))
|
|
|
|
;; Normal lambda
|
|
(let ([args (zodiac:case-lambda-form-args ast)]
|
|
[bodies (zodiac:case-lambda-form-bodies ast)])
|
|
(for-each
|
|
(lambda (args)
|
|
(for-each (lambda (b) (prephase:init-binding-properties! b #f #f #f))
|
|
(zodiac:arglist-vars args)))
|
|
args)
|
|
(let ([ast (zodiac:make-case-lambda-form
|
|
(zodiac:zodiac-stx ast)
|
|
(zodiac:parsed-back ast)
|
|
args
|
|
(begin-map (lambda (e) (prephase! e in-mod? #f #f))
|
|
(lambda (e) (prephase! e in-mod? #t #f))
|
|
bodies))])
|
|
(set-annotation! ast name)
|
|
ast)))]
|
|
|
|
;;----------------------------------------------------------
|
|
;; LET EXPRESSIONS
|
|
;;
|
|
[(zodiac:let-values-form? ast)
|
|
(for-each
|
|
(lambda (l)
|
|
(for-each (lambda (b) (prephase:init-binding-properties! b #f #f #f))
|
|
l))
|
|
(zodiac:let-values-form-vars ast))
|
|
(zodiac:set-let-values-form-vals!
|
|
ast
|
|
(map (lambda (e name) (prephase! e in-mod? #t name))
|
|
(zodiac:let-values-form-vals ast)
|
|
(zodiac:let-values-form-vars ast)))
|
|
(zodiac:set-let-values-form-body!
|
|
ast
|
|
(prephase! (zodiac:let-values-form-body ast) in-mod? need-val? name))
|
|
ast]
|
|
|
|
;;-----------------------------------------------------------
|
|
;; LETREC EXPRESSIONS
|
|
;;
|
|
[(zodiac:letrec-values-form? ast)
|
|
(for-each (lambda (l)
|
|
(for-each (lambda (b)
|
|
(prephase:init-binding-properties! b #f #f #f))
|
|
l))
|
|
(zodiac:letrec-values-form-vars ast))
|
|
(zodiac:set-letrec-values-form-vals!
|
|
ast
|
|
(map (lambda (e name) (prephase! e in-mod? #t name))
|
|
(zodiac:letrec-values-form-vals ast)
|
|
(zodiac:letrec-values-form-vars ast)))
|
|
(zodiac:set-letrec-values-form-body!
|
|
ast
|
|
(prephase!
|
|
(zodiac:letrec-values-form-body ast)
|
|
in-mod?
|
|
need-val?
|
|
name))
|
|
|
|
;; ????? Obsolete? ????
|
|
;; this will mark the letrec so it is NOT retraversed by
|
|
;; a possible future call to a-normalize! (the mutating version)
|
|
;; (set-annotation! ast #f)
|
|
|
|
ast]
|
|
|
|
;;-----------------------------------------------------------
|
|
;; IF EXPRESSIONS
|
|
;;
|
|
[(zodiac:if-form? ast)
|
|
(zodiac:set-if-form-test!
|
|
ast
|
|
(prephase! (zodiac:if-form-test ast) in-mod? #t #f))
|
|
(zodiac:set-if-form-then!
|
|
ast
|
|
(prephase! (zodiac:if-form-then ast) in-mod? need-val? name))
|
|
(zodiac:set-if-form-else!
|
|
ast
|
|
(prephase! (zodiac:if-form-else ast) in-mod? need-val? name))
|
|
|
|
;; Ad hoc optimization: (if (not x) y z) => (if x z y)
|
|
(let ([test (zodiac:if-form-test ast)])
|
|
(when (and (zodiac:app? test)
|
|
(zodiac:top-level-varref? (zodiac:app-fun test))
|
|
(eq? 'not (zodiac:varref-var (zodiac:app-fun test)))
|
|
(prephase:primitive-name? (zodiac:app-fun test))
|
|
(= 1 (length (zodiac:app-args test))))
|
|
(let ([then (zodiac:if-form-then ast)]
|
|
[else (zodiac:if-form-else ast)])
|
|
(zodiac:set-if-form-test! ast (car (zodiac:app-args test)))
|
|
(zodiac:set-if-form-then! ast else)
|
|
(zodiac:set-if-form-else! ast then))))
|
|
|
|
ast]
|
|
|
|
;;-----------------------------------------------------------
|
|
;; BEGIN EXPRESSIONS
|
|
;;
|
|
;; flatten, throw away dead values
|
|
;;
|
|
[(zodiac:begin-form? ast)
|
|
(let ([bodies (zodiac:begin-form-bodies ast)])
|
|
(if (null? bodies)
|
|
; must be a top-level begin...
|
|
(zodiac:make-special-constant 'void)
|
|
|
|
; Normal begin
|
|
(begin
|
|
(begin-map! (lambda (e) (prephase! e in-mod? #f #f))
|
|
(lambda (e) (prephase! e in-mod? need-val? name))
|
|
bodies)
|
|
(let ([final-bodies
|
|
(let loop ([bodies bodies])
|
|
(cond
|
|
; last expr in begin, finished
|
|
[(null? (cdr bodies)) bodies]
|
|
|
|
; flatten begins
|
|
[(zodiac:begin-form? (car bodies))
|
|
(loop (append! (zodiac:begin-form-bodies (car bodies))
|
|
(cdr bodies)))]
|
|
|
|
; flatten begin0s, too
|
|
[(zodiac:begin0-form? (car bodies))
|
|
(loop (append! (zodiac:begin0-form-bodies (car bodies))
|
|
(cdr bodies)))]
|
|
|
|
; throw away dead values if possible
|
|
[(prephase:dead-expression? (car bodies))
|
|
(loop (cdr bodies))]
|
|
|
|
; otherwise
|
|
[else (cons (car bodies) (loop (cdr bodies)))]))])
|
|
(if (null? (cdr final-bodies))
|
|
(car final-bodies)
|
|
(begin
|
|
(zodiac:set-begin-form-bodies! ast final-bodies)
|
|
ast))))))]
|
|
|
|
;;-----------------------------------------------------------
|
|
;; BEGIN0 EXPRESSIONS
|
|
;;
|
|
;; the 1st place is special -- the rest is just a begin
|
|
;; do our begin rewrites, then transform to a general form
|
|
;; if necessary
|
|
;;
|
|
;; if the value isn't going to be used, then the whole thing
|
|
;; is a begin
|
|
;;
|
|
[(zodiac:begin0-form? ast)
|
|
(if (not need-val?)
|
|
|
|
;; The value is ignored anyway - make it a begin
|
|
(prephase!
|
|
(zodiac:make-begin-form (zodiac:zodiac-stx ast)
|
|
(zodiac:parsed-back ast)
|
|
(zodiac:begin0-form-bodies ast))
|
|
in-mod?
|
|
#f
|
|
#f)
|
|
|
|
(let ([ast
|
|
(let ([make-begin
|
|
(lambda (bodies)
|
|
(zodiac:make-begin-form (zodiac:zodiac-stx ast)
|
|
(zodiac:parsed-back ast)
|
|
bodies))]
|
|
[bodies (zodiac:begin0-form-bodies ast)])
|
|
|
|
; simplify the first position
|
|
(set-car! bodies (prephase! (car bodies) in-mod? need-val? name))
|
|
|
|
; then simplify the begin0
|
|
(cond
|
|
|
|
; (begin0 M) --> M
|
|
[(null? (cdr bodies)) (car bodies)]
|
|
|
|
; (begin0 <push> ...) --> (begin ... <push>))
|
|
[(prephase:begin0-pushable? (car bodies))
|
|
(prephase!
|
|
(make-begin (append (cdr bodies) (list (car bodies))))
|
|
in-mod?
|
|
need-val?
|
|
name)]
|
|
|
|
; (begin0 M ...) --> (begin0 M (begin ...))
|
|
[else
|
|
(set-cdr!
|
|
(zodiac:begin0-form-bodies ast)
|
|
(list (prephase! (make-begin (cdr bodies)) in-mod? #f #f)))
|
|
ast]
|
|
|
|
))])
|
|
(if (zodiac:begin0-form? ast)
|
|
ast ; (prephase:convert-begin0 ast)
|
|
ast)))]
|
|
|
|
|
|
|
|
|
|
;;-----------------------------------------------------------
|
|
;; SET! EXPRESSIONS
|
|
;;
|
|
;; Mark lexical bindings as mutable
|
|
;;
|
|
[(zodiac:set!-form? ast)
|
|
(zodiac:set-set!-form-var! ast
|
|
(prephase!
|
|
(zodiac:set!-form-var ast)
|
|
in-mod?
|
|
#t
|
|
#f))
|
|
(let ([target (zodiac:set!-form-var ast)])
|
|
(when (zodiac:bound-varref? target)
|
|
(prephase:set-mutable!
|
|
(zodiac:bound-varref-binding target) #t))
|
|
|
|
(zodiac:set-set!-form-val! ast
|
|
(prephase!
|
|
(zodiac:set!-form-val ast)
|
|
in-mod?
|
|
#t
|
|
(zodiac:set!-form-var ast)))
|
|
ast)]
|
|
|
|
;;-----------------------------------------------------------
|
|
;; DEFINE EXPRESSIONS
|
|
;;
|
|
;;
|
|
[(zodiac:define-values-form? ast)
|
|
|
|
(if (null? (zodiac:define-values-form-vars ast))
|
|
|
|
;; (define-values () e) => (let-values [() e] (void))
|
|
(zodiac:make-let-values-form
|
|
(zodiac:zodiac-stx ast)
|
|
(zodiac:parsed-back ast)
|
|
(list null)
|
|
(list (prephase! (zodiac:define-values-form-val ast) in-mod? #t #f))
|
|
(zodiac:make-special-constant 'void))
|
|
|
|
;; Normal prephase
|
|
(begin
|
|
(zodiac:set-define-values-form-vars!
|
|
ast
|
|
(map (lambda (e) (prephase! e in-mod? #t #f))
|
|
(zodiac:define-values-form-vars ast)))
|
|
(zodiac:set-define-values-form-val!
|
|
ast
|
|
(prephase! (zodiac:define-values-form-val ast) in-mod? #t (zodiac:define-values-form-vars ast)))
|
|
ast))]
|
|
|
|
;;----------------------------------------------------------
|
|
;; DEFINE-SYNTAX or DEFINE-FOR-SYNTAX
|
|
;;
|
|
[(or (zodiac:define-syntaxes-form? ast)
|
|
(zodiac:define-for-syntax-form? ast))
|
|
(let ([get-names (if (zodiac:define-for-syntax-form? ast)
|
|
zodiac:define-for-syntax-form-names
|
|
zodiac:define-syntaxes-form-names)]
|
|
[get-expr (if (zodiac:define-for-syntax-form? ast)
|
|
zodiac:define-for-syntax-form-expr
|
|
zodiac:define-syntaxes-form-expr)])
|
|
(let ([ast
|
|
(zodiac:make-define-syntaxes-form
|
|
(zodiac:zodiac-stx ast)
|
|
(zodiac:parsed-back ast)
|
|
(map (lambda (e) (prephase! e in-mod? #t #f))
|
|
(get-names ast))
|
|
(prephase! (zodiac:make-app
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(zodiac:make-top-level-varref
|
|
for-syntax-in-env-stx
|
|
(make-empty-box)
|
|
'for-syntax-in-env
|
|
#f
|
|
for-syntax-slot
|
|
#t
|
|
#f
|
|
#f)
|
|
(list
|
|
(zodiac:make-case-lambda-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(list (zodiac:make-list-arglist null))
|
|
(list (get-expr ast)))))
|
|
in-mod?
|
|
#t (get-names ast)))])
|
|
(set-annotation! ast in-mod?)
|
|
ast))]
|
|
|
|
;;-----------------------------------------------------------
|
|
;; APPLICATIONS
|
|
;;
|
|
;; check for unsupported syntactic forms that end up
|
|
;; looking like applications
|
|
;;
|
|
;; We'll hack in a rewrite here that turns
|
|
;; ((lambda (x*) M) y*) -> (let ([x y]*) M)
|
|
;;
|
|
[(zodiac:app? ast)
|
|
;; Check for 'mzc-cffi attribute:
|
|
(if (syntax-property (zodiac:zodiac-stx ast) 'mzc-cffi)
|
|
|
|
;; Really a c-declare
|
|
(let* ([quote-expr (caddr (zodiac:app-args ast))]
|
|
[str (syntax-e (zodiac:zodiac-stx (zodiac:quote-form-expr quote-expr)))])
|
|
(register-c-declaration str)
|
|
;; return a void
|
|
(zodiac:make-quote-form (zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(zodiac:make-zread
|
|
(datum->syntax-object #f (void) #f))))
|
|
|
|
(let ([process-normally
|
|
(lambda ()
|
|
(zodiac:set-app-fun!
|
|
ast
|
|
(prephase! (zodiac:app-fun ast) in-mod? #t #f))
|
|
(let ([adhoc (preprocess:adhoc-app-optimization
|
|
ast
|
|
(lambda (x)
|
|
(prephase! x in-mod? #t #f)))])
|
|
(if adhoc
|
|
(prephase! adhoc in-mod? need-val? name)
|
|
(begin
|
|
(zodiac:set-app-args!
|
|
ast
|
|
(map (lambda (e) (prephase! e in-mod? #t #f))
|
|
(zodiac:app-args ast)))
|
|
ast))))])
|
|
|
|
(if (and (zodiac:case-lambda-form? (zodiac:app-fun ast))
|
|
(not (syntax-property (zodiac:zodiac-stx (zodiac:app-fun ast)) 'mzc-cffi))
|
|
(= 1 (length (zodiac:case-lambda-form-args
|
|
(zodiac:app-fun ast))))
|
|
(zodiac:list-arglist?
|
|
(car (zodiac:case-lambda-form-args
|
|
(zodiac:app-fun ast)))))
|
|
|
|
;; optimize to let
|
|
(let* ([L (zodiac:app-fun ast)]
|
|
[args (zodiac:app-args ast)]
|
|
[ids (zodiac:arglist-vars
|
|
(car (zodiac:case-lambda-form-args L)))]
|
|
[body (car (zodiac:case-lambda-form-bodies L))]
|
|
[ok? (= (length ids) (length args))])
|
|
(unless ok?
|
|
((if (compiler:option:stupid) compiler:warning compiler:error)
|
|
ast
|
|
"wrong number of arguments to literal function"))
|
|
(if (not ok?)
|
|
(process-normally)
|
|
(prephase!
|
|
(zodiac:make-let-values-form
|
|
(zodiac:zodiac-stx ast)
|
|
(zodiac:parsed-back ast)
|
|
(map list ids)
|
|
args
|
|
body)
|
|
in-mod?
|
|
need-val?
|
|
name)))
|
|
|
|
;; don't optimize
|
|
(process-normally))))]
|
|
|
|
;;-----------------------------------------------------------
|
|
;; WITH-CONTINUATION-MARK
|
|
;;
|
|
[(zodiac:with-continuation-mark-form? ast)
|
|
|
|
(zodiac:set-with-continuation-mark-form-key!
|
|
ast
|
|
(prephase! (zodiac:with-continuation-mark-form-key ast) in-mod? #t #f))
|
|
|
|
(zodiac:set-with-continuation-mark-form-val!
|
|
ast
|
|
(prephase! (zodiac:with-continuation-mark-form-val ast) in-mod? #t #f))
|
|
|
|
(zodiac:set-with-continuation-mark-form-body!
|
|
ast
|
|
(prephase! (zodiac:with-continuation-mark-form-body ast) in-mod? need-val? name))
|
|
|
|
ast]
|
|
|
|
;;-----------------------------------------------------------
|
|
;; REQUIRE/PROVIDE
|
|
;;
|
|
[(zodiac:require/provide-form? ast)
|
|
;; Change to namespace[-transformer]-require calls:
|
|
(let-values ([(elems proc)
|
|
(syntax-case (zodiac:zodiac-stx ast) (require require-for-syntax)
|
|
[(require . elem)
|
|
(values (syntax->list (syntax elem))
|
|
'namespace-require)]
|
|
[(require-for-syntax . elem)
|
|
(values (syntax->list (syntax elem))
|
|
'namespace-transformer-require)])])
|
|
(let ([proc (zodiac:make-top-level-varref
|
|
(datum->syntax-object
|
|
#f
|
|
'namespace-require
|
|
(zodiac:zodiac-stx ast))
|
|
(make-empty-box)
|
|
proc
|
|
'#%kernel
|
|
(box '())
|
|
#f
|
|
#f
|
|
#f)])
|
|
|
|
(prephase!
|
|
(zodiac:make-begin-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(map (lambda (elem)
|
|
(zodiac:make-app
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
proc
|
|
(list (zodiac:make-quote-form
|
|
(zodiac:zodiac-stx ast)
|
|
(make-empty-box)
|
|
(zodiac:make-zread
|
|
elem)))))
|
|
elems))
|
|
in-mod? need-val? name)))]
|
|
|
|
;;-----------------------------------------------------------
|
|
;; QUOTE-SYNTAX
|
|
;;
|
|
[(zodiac:quote-syntax-form? ast)
|
|
ast]
|
|
|
|
;;-----------------------------------------------------------
|
|
;; MODULE
|
|
;;
|
|
[(zodiac:module-form? ast)
|
|
|
|
(let-values ([(mi smi) (make-module-invokes
|
|
(zodiac:module-form-self-path-index ast))])
|
|
(set-annotation! ast (make-module-info mi smi #f)))
|
|
|
|
(zodiac:set-module-form-body!
|
|
ast
|
|
(prephase! (zodiac:module-form-body ast)
|
|
#t #f #f))
|
|
(zodiac:set-module-form-syntax-body!
|
|
ast
|
|
(prephase! (zodiac:module-form-syntax-body ast)
|
|
#t #f #f))
|
|
ast]
|
|
|
|
|
|
;;-----------------------------------------------------------
|
|
;; Unsupported forms
|
|
;;
|
|
[else (compiler:fatal-error
|
|
ast
|
|
(format "unsupported syntactic form ~a" ast))
|
|
ast]))])
|
|
prephase!)))))
|