suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

mzc -e repairs

Browse Source 
svn: r9669
This commit is contained in:
Matthew Flatt 2008-05-05 22:32:16 +00:00
parent 0371d1eb7f
commit 3451dff783
9 changed files with 91 additions and 62 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/compiler/private/analyze.ss
View File

@ -845,7 +845,7 @@
(when (compiler:option:debug) (when (compiler:option:debug)
(zodiac:print-start! (debug:get-port) ast) (zodiac:print-start! (debug:get-port) ast)
(newline (debug:get-port))) (newline (debug:get-port)))
(cond (cond
;;----------------------------------------------------------------- ;;-----------------------------------------------------------------

20
collects/compiler/private/driver.ss
View File

@ -73,7 +73,10 @@
dynext/compile-sig dynext/compile-sig
dynext/link-sig dynext/link-sig
dynext/file-sig dynext/file-sig
setup/dirs) setup/dirs
(only scheme/base
define-namespace-anchor
namespace-anchor->empty-namespace))
(require "../sig.ss" (require "../sig.ss"
"sig.ss" "sig.ss"
@ -82,6 +85,8 @@
(provide driver@) (provide driver@)
(define-namespace-anchor anchor)
(define-unit driver@ (define-unit driver@
(import (prefix compiler:option: compiler:option^) (import (prefix compiler:option: compiler:option^)
compiler:library^ compiler:library^
@ -250,8 +255,13 @@
opt-expanded))))) opt-expanded)))))
exprs))))) 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 has-prefix? #f)
(define (eval-compile-prefix prefix) (define (eval-compile-prefix prefix)
@ -701,7 +711,7 @@
(parameterize ([current-namespace elaborate-namespace] (parameterize ([current-namespace elaborate-namespace]
[current-load-relative-directory input-directory] [current-load-relative-directory input-directory]
[compile-enforce-module-constants #f]) [compile-enforce-module-constants #f])
(let ([sources+bytecodes+magics (let ([sources+bytecodes+magics
(map (lambda (src) (map (lambda (src)
(let-values ([(src bytecode magic-sym) (let-values ([(src bytecode magic-sym)
(top-level-to-core src (top-level-to-core src
@ -715,7 +725,7 @@
bytecode magic-sym))) bytecode magic-sym)))
(block-source s:file-block))]) (block-source s:file-block))])
(set-block-source! s:file-block (map car sources+bytecodes+magics)) (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 compile
(map cadr sources+bytecodes+magics))) (map cadr sources+bytecodes+magics)))
(set-block-magics! s:file-block (map caddr sources+bytecodes+magics)))))]) (set-block-magics! s:file-block (map caddr sources+bytecodes+magics)))))])

5
collects/compiler/private/library.ss
View File

@ -319,5 +319,6 @@
(and v (namespace-variable-value v #t #f ns))) (and v (namespace-variable-value v #t #f ns)))
(define (kernel-modname? modname) (define (kernel-modname? modname)
(equal? ''#%kernel (let-values ([(name base) (module-path-index-split modname)]) (and modname
name))))) (equal? ''#%kernel (let-values ([(name base) (module-path-index-split modname)])
name))))))

2
collects/compiler/private/zlayer.ss
View File

@ -94,7 +94,7 @@
(zodiac:set-begin0-form-bodies! ast (cons v (cdr (zodiac:begin0-form-bodies ast)))))) (zodiac:set-begin0-form-bodies! ast (cons v (cdr (zodiac:begin0-form-bodies ast))))))
(define zodiac:set-begin0-form-rest! (define zodiac:set-begin0-form-rest!
(lambda (ast v) (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)))) v))))
;;---------------------------------------------------------------------------- ;;----------------------------------------------------------------------------

11
collects/compiler/src2src.ss
View File

@ -11,7 +11,8 @@
syntax/kerncase syntax/kerncase
syntax/primitives syntax/primitives
mzlib/etc mzlib/etc
mzlib/list) mzlib/list
(for-syntax scheme/base))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Optimizer ;; Optimizer
@ -594,7 +595,7 @@
(super-instantiate ((void) stx)) (super-instantiate ((void) stx))
(inherit-field src-stx cert-stxes) (inherit-field src-stx cert-stxes)
(define/override (sexpr) (quote-syntax (void))) (define/override (sexpr) (quote-syntax (#%plain-app void)))
(define/override (simplify ctx) (define/override (simplify ctx)
(if (eq? 'bool (context-need ctx)) (if (eq? 'bool (context-need ctx))
@ -1814,7 +1815,11 @@
[(#%require . i) (make-object require/provide% stx)] [(#%require . i) (make-object require/provide% stx)]
[(#%provide 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 (make-parse #f))
(define parse-top (make-parse #t)) (define parse-top (make-parse #t))

71
collects/compiler/to-core.ss
View File

@ -2,7 +2,8 @@
(require syntax/kerncase (require syntax/kerncase
syntax/stx syntax/stx
mzlib/list mzlib/list
syntax/boundmap) syntax/boundmap
(for-syntax scheme/base))
(provide top-level-to-core) (provide top-level-to-core)
@ -141,7 +142,7 @@
;; inteferes with the 0-values hack at the top level ;; inteferes with the 0-values hack at the top level
cvted cvted
#`(let-values ([ids #,cvted]) #`(let-values ([ids #,cvted])
(values . ids))))]))) (#%plain-app values . ids))))])))
(filter (lambda (x) (not (is-run-time? x))) decls))] (filter (lambda (x) (not (is-run-time? x))) decls))]
[rt-converted [rt-converted
(map (lambda (stx) (map (lambda (stx)
@ -161,7 +162,7 @@
(if (need-thunk? #'rhs) (if (need-thunk? #'rhs)
#`(lambda () #,converted) #`(lambda () #,converted)
#`(let-values ([ids #,converted]) #`(let-values ([ids #,converted])
(values . ids))))] (#%plain-app values . ids))))]
[else [else
#`(lambda () #`(lambda ()
#,(convert stx #f #,(convert stx #f
@ -170,22 +171,26 @@
in-module? in-module?
simple-constant? stop-properties))])) simple-constant? stop-properties))]))
(filter is-run-time? decls))] (filter is-run-time? decls))]
[ct-rhs #`((let ([magic (car (cons '#,magic-sym 2))]) [ct-rhs #`(#%plain-app
(if (symbol? magic) (let-values ([(magic) (#%plain-app car (#%plain-app cons '#,magic-sym 2))])
(lambda (x) (vector (if (#%plain-app symbol? magic)
#,@(map (lambda (stx) (#%plain-lambda (x)
(syntax-case stx () (#%plain-app
[(def (id) . _) vector
#'void] #,@(map (lambda (stx)
[(def (id ...) . _) (syntax-case stx ()
(with-syntax ([(v ...) (map (lambda (x) #f) [(def (id) . _)
(syntax->list #'(id ...)))]) #'void]
[(def (id ...) . _)
#`(lambda () (values v ...)))])) (with-syntax ([(v ...) (map (lambda (x) #f)
(filter (lambda (x) (not (is-run-time? x))) decls)))) (syntax->list #'(id ...)))])
(car magic)))
(vector #,@(vars-sequence ct-vars)))] #`(#%plain-lambda () (#%plain-app values v ...)))]))
[rt-rhs #`((cdr '#,magic-sym) (vector #,@(vars-sequence rt-vars)))] (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 + [just-one-ct? (>= 1 (apply +
(map (lambda (decl) (map (lambda (decl)
(syntax-case decl (define-syntaxes define-values-for-syntax) (syntax-case decl (define-syntaxes define-values-for-syntax)
@ -204,12 +209,13 @@
[_else 1])) [_else 1]))
decls)))]) decls)))])
(values (values
#`(cons (lambda (#,compile-time) #`(#%plain-app
cons (#%plain-lambda (#,compile-time)
#,@(extract-vars ct-vars compile-time extract-stx) #,@(extract-vars ct-vars compile-time extract-stx)
(vector #,@ct-converted)) (#%plain-app vector #,@ct-converted))
(lambda (#,run-time) (#%plain-lambda (#,run-time)
#,@(extract-vars rt-vars run-time extract-stx) #,@(extract-vars rt-vars run-time extract-stx)
(vector #,@rt-converted))) (#%plain-app vector #,@rt-converted)))
#`(;; Lift require and require-for-syntaxes to the front, so they're ready for #`(;; Lift require and require-for-syntaxes to the front, so they're ready for
;; variable references ;; variable references
#,@(filter (lambda (decl) #,@(filter (lambda (decl)
@ -245,26 +251,29 @@
[(#%provide . _) [(#%provide . _)
(car decls)] (car decls)]
[(#%require . _) [(#%require . _)
#'(void)] #'(#%plain-app void)]
[(define-values (id ...) rhs) [(define-values (id ...) rhs)
#`(define-values (id ...) #`(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) (if (need-thunk? #'rhs)
#`(#,lookup) #`(#%plain-app #,lookup)
lookup)))] lookup)))]
[else [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)))] (loop (cdr decls) ct-pos (add1 rt-pos)))]
[else [else
(cons (syntax-case (car decls) (define-syntaxes define-values-for-syntax) (cons (syntax-case (car decls) (define-syntaxes define-values-for-syntax)
[(define-syntaxes (id ...) . rhs) [(define-syntaxes (id ...) . rhs)
#`(define-syntaxes (id ...) #`(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 (id ...) . rhs)
#`(define-values-for-syntax () #`(define-values-for-syntax ()
(begin (begin
(set!-values (id ...) ((vector-ref #,(if just-one-ct? ct-rhs compile-time) #,ct-pos))) (set!-values (id ...)
(values)))]) (#%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))]))) (loop (cdr decls) (add1 ct-pos) rt-pos))])))
magic-sym)))) magic-sym))))

8
collects/tests/mzscheme/makeflat.ss
View File

@ -25,7 +25,7 @@
(define line-count 0) (define line-count 0)
(define file-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-eval (current-eval))
(define old-namespace (current-namespace)) (define old-namespace (current-namespace))
@ -35,7 +35,7 @@
(define (flat-pp v) (define (flat-pp v)
(parameterize ([print-hash-table #t]) (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)) (set! line-count (add1 line-count))
(when (>= line-count lines-per-file) (when (>= line-count lines-per-file)
(set! line-count 0) (set! line-count 0)
@ -44,7 +44,7 @@
(set! flatp (set! flatp
(open-output-file (open-output-file
(format "flat~a.ss" file-count) (format "flat~a.ss" file-count)
'replace)))) #:exists 'replace))))
(define error-test (define error-test
(case-lambda (case-lambda
@ -57,7 +57,7 @@
[(define-syntax . _) #t] [(define-syntax . _) #t]
[(define-syntaxes . _) #t] [(define-syntaxes . _) #t]
[_else #f])) [_else #f]))
(let ([dexpr (syntax-object->datum expr)]) (let ([dexpr (syntax->datum expr)])
(flat-pp (flat-pp
`(thunk-error-test (lambda () ,dexpr) `(thunk-error-test (lambda () ,dexpr)
(quote-syntax ,dexpr) (quote-syntax ,dexpr)

18
collects/tests/mzscheme/makeflats.ss
View File

@ -1,14 +1,16 @@
(define flat-number 0) (define flat-number 0)
(for-each (lambda (f) (for-each (lambda (f)
(parameterize ([current-namespace (make-base-namespace)]) (let ([ns (current-namespace)])
(set! flat-number (add1 flat-number)) (parameterize ([current-namespace (make-base-namespace)])
(eval (set! flat-number (add1 flat-number))
`(begin (namespace-attach-module ns 'scheme)
(require-for-syntax mzscheme) (namespace-require 'scheme)
(define flat-load ,f) (eval
(define flat-number ,(format "-~a" flat-number)) `(begin
(load-relative "makeflat.ss"))))) (define flat-load ,f)
(define flat-number ,(format "-~a" flat-number))
(load-relative "makeflat.ss"))))))
'("basic.ss" '("basic.ss"
"unicode.ss" "unicode.ss"
"read.ss" "read.ss"

16
collects/tests/mzscheme/runflats.ss
View File

@ -1,12 +1,14 @@
(for-each (lambda (f) (for-each (lambda (f)
(when (regexp-match "^flat-[0-9]+[.]ss$" (path->string f)) (when (regexp-match "^flat-[0-9]+[.]ss$" (path->string f))
(parameterize ([current-namespace (make-base-namespace)] (let ([ns (current-namespace)])
[exit-handler void]) (parameterize ([current-namespace (make-base-namespace)]
(eval [exit-handler void])
`(begin (namespace-attach-module ns 'scheme)
(require-for-syntax mzscheme) (namespace-require 'scheme)
(define quiet-load ,(path->string f)) (eval
(load-relative "quiet.ss")))))) `(begin
(define quiet-load ,(path->string f))
(load-relative "quiet.ss")))))))
(directory-list)) (directory-list))