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)
(zodiac:print-start! (debug:get-port) ast)
(newline (debug:get-port)))
(cond
;;-----------------------------------------------------------------

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

@ -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)))))])

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

@ -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))))))

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))))))
(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))))
;;----------------------------------------------------------------------------

11
collects/compiler/src2src.ss
View File

@ -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))

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

@ -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))))

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

@ -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)

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

@ -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"

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

@ -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))