From 3451dff7831a5aab9c7274fbe532c4ec2d1e9089 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 5 May 2008 22:32:16 +0000 Subject: [PATCH] mzc -e repairs svn: r9669 --- collects/compiler/private/analyze.ss | 2 +- collects/compiler/private/driver.ss | 20 ++++++-- collects/compiler/private/library.ss | 5 +- collects/compiler/private/zlayer.ss | 2 +- collects/compiler/src2src.ss | 11 +++-- collects/compiler/to-core.ss | 71 ++++++++++++++++------------ collects/tests/mzscheme/makeflat.ss | 8 ++-- collects/tests/mzscheme/makeflats.ss | 18 +++---- collects/tests/mzscheme/runflats.ss | 16 ++++--- 9 files changed, 91 insertions(+), 62 deletions(-) diff --git a/collects/compiler/private/analyze.ss b/collects/compiler/private/analyze.ss index 0e918064f2..b2a5bff96f 100644 --- a/collects/compiler/private/analyze.ss +++ b/collects/compiler/private/analyze.ss @@ -845,7 +845,7 @@ (when (compiler:option:debug) (zodiac:print-start! (debug:get-port) ast) (newline (debug:get-port))) - + (cond ;;----------------------------------------------------------------- diff --git a/collects/compiler/private/driver.ss b/collects/compiler/private/driver.ss index de2939c76a..ab578989f1 100644 --- a/collects/compiler/private/driver.ss +++ b/collects/compiler/private/driver.ss @@ -73,7 +73,10 @@ dynext/compile-sig dynext/link-sig dynext/file-sig - setup/dirs) + setup/dirs + (only scheme/base + define-namespace-anchor + namespace-anchor->empty-namespace)) (require "../sig.ss" "sig.ss" @@ -82,6 +85,8 @@ (provide driver@) + (define-namespace-anchor anchor) + (define-unit driver@ (import (prefix compiler:option: compiler:option^) compiler:library^ @@ -250,8 +255,13 @@ opt-expanded))))) exprs))))) - (define elaborate-namespace (make-namespace)) - + (define elaborate-namespace + (let ([ns (make-namespace)]) + (namespace-attach-module (namespace-anchor->empty-namespace anchor) + 'scheme/base + ns) + ns)) + (define has-prefix? #f) (define (eval-compile-prefix prefix) @@ -701,7 +711,7 @@ (parameterize ([current-namespace elaborate-namespace] [current-load-relative-directory input-directory] [compile-enforce-module-constants #f]) - (let ([sources+bytecodes+magics + (let ([sources+bytecodes+magics (map (lambda (src) (let-values ([(src bytecode magic-sym) (top-level-to-core src @@ -715,7 +725,7 @@ bytecode magic-sym))) (block-source s:file-block))]) (set-block-source! s:file-block (map car sources+bytecodes+magics)) - (set-block-bytecodes! s:file-block + (set-block-bytecodes! s:file-block (map compile (map cadr sources+bytecodes+magics))) (set-block-magics! s:file-block (map caddr sources+bytecodes+magics)))))]) diff --git a/collects/compiler/private/library.ss b/collects/compiler/private/library.ss index 73ac6dc47c..bab172cd03 100644 --- a/collects/compiler/private/library.ss +++ b/collects/compiler/private/library.ss @@ -319,5 +319,6 @@ (and v (namespace-variable-value v #t #f ns))) (define (kernel-modname? modname) - (equal? ''#%kernel (let-values ([(name base) (module-path-index-split modname)]) - name))))) + (and modname + (equal? ''#%kernel (let-values ([(name base) (module-path-index-split modname)]) + name)))))) diff --git a/collects/compiler/private/zlayer.ss b/collects/compiler/private/zlayer.ss index 53300a9a82..b1564cc34f 100644 --- a/collects/compiler/private/zlayer.ss +++ b/collects/compiler/private/zlayer.ss @@ -94,7 +94,7 @@ (zodiac:set-begin0-form-bodies! ast (cons v (cdr (zodiac:begin0-form-bodies ast)))))) (define zodiac:set-begin0-form-rest! (lambda (ast v) - (zodiac:set-begin0-form-bodies! ast (cons (car (zodiac:begin0-form-bodies ast)) + (zodiac:set-begin0-form-bodies! ast (list (car (zodiac:begin0-form-bodies ast)) v)))) ;;---------------------------------------------------------------------------- diff --git a/collects/compiler/src2src.ss b/collects/compiler/src2src.ss index b52a2b1d3b..c8d0a8af1f 100644 --- a/collects/compiler/src2src.ss +++ b/collects/compiler/src2src.ss @@ -11,7 +11,8 @@ syntax/kerncase syntax/primitives mzlib/etc - mzlib/list) + mzlib/list + (for-syntax scheme/base)) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Optimizer @@ -594,7 +595,7 @@ (super-instantiate ((void) stx)) (inherit-field src-stx cert-stxes) - (define/override (sexpr) (quote-syntax (void))) + (define/override (sexpr) (quote-syntax (#%plain-app void))) (define/override (simplify ctx) (if (eq? 'bool (context-need ctx)) @@ -1814,7 +1815,11 @@ [(#%require . i) (make-object require/provide% stx)] [(#%provide i ...) (make-object require/provide% stx)] - [else (error 'parse "unknown expression: ~a" (syntax->datum stx))]))) + [(#%expression e) + (parse (syntax e) env trans? in-module? tables)] + + [else + (error 'parse "unknown expression: ~a" (syntax->datum stx))]))) (define parse (make-parse #f)) (define parse-top (make-parse #t)) diff --git a/collects/compiler/to-core.ss b/collects/compiler/to-core.ss index 256061bfc2..700df91932 100644 --- a/collects/compiler/to-core.ss +++ b/collects/compiler/to-core.ss @@ -2,7 +2,8 @@ (require syntax/kerncase syntax/stx mzlib/list - syntax/boundmap) + syntax/boundmap + (for-syntax scheme/base)) (provide top-level-to-core) @@ -141,7 +142,7 @@ ;; inteferes with the 0-values hack at the top level cvted #`(let-values ([ids #,cvted]) - (values . ids))))]))) + (#%plain-app values . ids))))]))) (filter (lambda (x) (not (is-run-time? x))) decls))] [rt-converted (map (lambda (stx) @@ -161,7 +162,7 @@ (if (need-thunk? #'rhs) #`(lambda () #,converted) #`(let-values ([ids #,converted]) - (values . ids))))] + (#%plain-app values . ids))))] [else #`(lambda () #,(convert stx #f @@ -170,22 +171,26 @@ in-module? simple-constant? stop-properties))])) (filter is-run-time? decls))] - [ct-rhs #`((let ([magic (car (cons '#,magic-sym 2))]) - (if (symbol? magic) - (lambda (x) (vector - #,@(map (lambda (stx) - (syntax-case stx () - [(def (id) . _) - #'void] - [(def (id ...) . _) - (with-syntax ([(v ...) (map (lambda (x) #f) - (syntax->list #'(id ...)))]) - - #`(lambda () (values v ...)))])) - (filter (lambda (x) (not (is-run-time? x))) decls)))) - (car magic))) - (vector #,@(vars-sequence ct-vars)))] - [rt-rhs #`((cdr '#,magic-sym) (vector #,@(vars-sequence rt-vars)))] + [ct-rhs #`(#%plain-app + (let-values ([(magic) (#%plain-app car (#%plain-app cons '#,magic-sym 2))]) + (if (#%plain-app symbol? magic) + (#%plain-lambda (x) + (#%plain-app + vector + #,@(map (lambda (stx) + (syntax-case stx () + [(def (id) . _) + #'void] + [(def (id ...) . _) + (with-syntax ([(v ...) (map (lambda (x) #f) + (syntax->list #'(id ...)))]) + + #`(#%plain-lambda () (#%plain-app values v ...)))])) + (filter (lambda (x) (not (is-run-time? x))) decls)))) + (#%plain-app car magic))) + (#%plain-app vector #,@(vars-sequence ct-vars)))] + [rt-rhs #`(#%plain-app (#%plain-app cdr '#,magic-sym) + (#%plain-app vector #,@(vars-sequence rt-vars)))] [just-one-ct? (>= 1 (apply + (map (lambda (decl) (syntax-case decl (define-syntaxes define-values-for-syntax) @@ -204,12 +209,13 @@ [_else 1])) decls)))]) (values - #`(cons (lambda (#,compile-time) + #`(#%plain-app + cons (#%plain-lambda (#,compile-time) #,@(extract-vars ct-vars compile-time extract-stx) - (vector #,@ct-converted)) - (lambda (#,run-time) - #,@(extract-vars rt-vars run-time extract-stx) - (vector #,@rt-converted))) + (#%plain-app vector #,@ct-converted)) + (#%plain-lambda (#,run-time) + #,@(extract-vars rt-vars run-time extract-stx) + (#%plain-app vector #,@rt-converted))) #`(;; Lift require and require-for-syntaxes to the front, so they're ready for ;; variable references #,@(filter (lambda (decl) @@ -245,26 +251,29 @@ [(#%provide . _) (car decls)] [(#%require . _) - #'(void)] + #'(#%plain-app void)] [(define-values (id ...) rhs) #`(define-values (id ...) - #,(let ([lookup #`(vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos)]) + #,(let ([lookup #`(#%plain-app vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos)]) (if (need-thunk? #'rhs) - #`(#,lookup) + #`(#%plain-app #,lookup) lookup)))] [else - #`((vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos))]) + #`(#%plain-app (#%plain-app vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos))]) (loop (cdr decls) ct-pos (add1 rt-pos)))] [else (cons (syntax-case (car decls) (define-syntaxes define-values-for-syntax) [(define-syntaxes (id ...) . rhs) #`(define-syntaxes (id ...) - ((vector-ref #,(if just-one-ct? ct-rhs compile-time) #,ct-pos)))] + (#%plain-app (#%plain-app vector-ref #,(if just-one-ct? ct-rhs compile-time) #,ct-pos)))] [(define-values-for-syntax (id ...) . rhs) #`(define-values-for-syntax () (begin - (set!-values (id ...) ((vector-ref #,(if just-one-ct? ct-rhs compile-time) #,ct-pos))) - (values)))]) + (set!-values (id ...) + (#%plain-app + (#%plain-app vector-ref #,(if just-one-ct? ct-rhs compile-time) + #,ct-pos))) + (#%plain-app values)))]) (loop (cdr decls) (add1 ct-pos) rt-pos))]))) magic-sym)))) diff --git a/collects/tests/mzscheme/makeflat.ss b/collects/tests/mzscheme/makeflat.ss index 6b091c40c3..aa9b73c9cb 100644 --- a/collects/tests/mzscheme/makeflat.ss +++ b/collects/tests/mzscheme/makeflat.ss @@ -25,7 +25,7 @@ (define line-count 0) (define file-count 0) -(define flatp (open-output-file (format "flat~a.ss" flat-number) 'replace)) +(define flatp (open-output-file (format "flat~a.ss" flat-number) #:exists 'replace)) (define old-eval (current-eval)) (define old-namespace (current-namespace)) @@ -35,7 +35,7 @@ (define (flat-pp v) (parameterize ([print-hash-table #t]) - (pretty-print (if (syntax? v) (syntax-object->datum v) v) flatp)) + (pretty-print (if (syntax? v) (syntax->datum v) v) flatp)) (set! line-count (add1 line-count)) (when (>= line-count lines-per-file) (set! line-count 0) @@ -44,7 +44,7 @@ (set! flatp (open-output-file (format "flat~a.ss" file-count) - 'replace)))) + #:exists 'replace)))) (define error-test (case-lambda @@ -57,7 +57,7 @@ [(define-syntax . _) #t] [(define-syntaxes . _) #t] [_else #f])) - (let ([dexpr (syntax-object->datum expr)]) + (let ([dexpr (syntax->datum expr)]) (flat-pp `(thunk-error-test (lambda () ,dexpr) (quote-syntax ,dexpr) diff --git a/collects/tests/mzscheme/makeflats.ss b/collects/tests/mzscheme/makeflats.ss index 0c040bb58f..d4145c883d 100644 --- a/collects/tests/mzscheme/makeflats.ss +++ b/collects/tests/mzscheme/makeflats.ss @@ -1,14 +1,16 @@ (define flat-number 0) (for-each (lambda (f) - (parameterize ([current-namespace (make-base-namespace)]) - (set! flat-number (add1 flat-number)) - (eval - `(begin - (require-for-syntax mzscheme) - (define flat-load ,f) - (define flat-number ,(format "-~a" flat-number)) - (load-relative "makeflat.ss"))))) + (let ([ns (current-namespace)]) + (parameterize ([current-namespace (make-base-namespace)]) + (set! flat-number (add1 flat-number)) + (namespace-attach-module ns 'scheme) + (namespace-require 'scheme) + (eval + `(begin + (define flat-load ,f) + (define flat-number ,(format "-~a" flat-number)) + (load-relative "makeflat.ss")))))) '("basic.ss" "unicode.ss" "read.ss" diff --git a/collects/tests/mzscheme/runflats.ss b/collects/tests/mzscheme/runflats.ss index 02f8838f27..4380a79676 100644 --- a/collects/tests/mzscheme/runflats.ss +++ b/collects/tests/mzscheme/runflats.ss @@ -1,12 +1,14 @@ (for-each (lambda (f) (when (regexp-match "^flat-[0-9]+[.]ss$" (path->string f)) - (parameterize ([current-namespace (make-base-namespace)] - [exit-handler void]) - (eval - `(begin - (require-for-syntax mzscheme) - (define quiet-load ,(path->string f)) - (load-relative "quiet.ss")))))) + (let ([ns (current-namespace)]) + (parameterize ([current-namespace (make-base-namespace)] + [exit-handler void]) + (namespace-attach-module ns 'scheme) + (namespace-require 'scheme) + (eval + `(begin + (define quiet-load ,(path->string f)) + (load-relative "quiet.ss"))))))) (directory-list))