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

class and mzc -k fixes

Browse Source 
svn: r7724
This commit is contained in:
Matthew Flatt 2007-11-14 16:24:48 +00:00
parent c46aacc0a3
commit 6056159ad7
5 changed files with 47 additions and 38 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

8
collects/compiler/compiler-unit.ss
View File

@ -22,6 +22,7 @@
syntax/toplevel
syntax/moddep
scheme/namespace
syntax/namespace-reflect
mzlib/list
@ -168,7 +169,12 @@
(printf " [output to \"~a\"]~n" dest))
(define (compile-zos prefix)
(let ([n (if prefix (make-namespace) (current-namespace))])
(let ([n (if prefix
(let ([ns (make-base-namespace)])
(parameterize ([current-namespace ns])
(namespace-require 'scheme/base)
ns))
(current-namespace))])
(when prefix
(eval prefix n))
(lambda (source-files destination-directory)

45
collects/compiler/main.ss
View File

@ -32,7 +32,8 @@
(lib "link.ss" "dynext")
(lib "pack.ss" "setup")
(lib "getinfo.ss" "setup")
(lib "dirs.ss" "setup"))
(lib "dirs.ss" "setup")
scheme/namespace)
(define dest-dir (make-parameter #f))
(define auto-dest-dir (make-parameter #f))
@ -424,9 +425,11 @@
(error 'mzc "prefix files not allowed with -m or --module"))
#f)
`(begin
,(if (compiler:option:assume-primitives) '(require mzscheme) '(void))
(require scheme)
,(if (compiler:option:assume-primitives)
'(void)
'(namespace-require/copy 'scheme))
(require (lib "cffi.ss" "compiler"))
(require-for-syntax mzscheme)
,@(map (lambda (s) `(load ,s)) prefixes)
(void)))))))
(list "file/directory/collection" "file/directory/sub-collection")))
@ -483,7 +486,7 @@
'auto
(dest-dir)))]
[(make-zo)
(let ([n (make-namespace)]
(let ([n (make-base-namespace)]
[mc (dynamic-require '(lib "mzlib/cm.ss")
'managed-compile-zo)]
[cnh (dynamic-require '(lib "mzlib/cm.ss")
@ -493,23 +496,23 @@
[cnh (lambda (p)
(set! did-one? #t)
(printf " making ~s~n" (path->string p)))])
(map (lambda (file)
(unless (file-exists? file)
(error 'mzc "file does not exist: ~a" file))
(set! did-one? #f)
(let ([name (extract-base-filename/ss file 'mzc)])
(printf "\"~a\":~n" file)
(mc file)
(let ([dest (append-zo-suffix
(let-values ([(base name dir?) (split-path name)])
(build-path (if (symbol? base) 'same base)
"compiled" name)))])
(printf " [~a \"~a\"]~n"
(if did-one?
"output to"
"already up-to-date at")
dest))))
source-files)))]
(for-each (lambda (file)
(unless (file-exists? file)
(error 'mzc "file does not exist: ~a" file))
(set! did-one? #f)
(let ([name (extract-base-filename/ss file 'mzc)])
(printf "\"~a\":~n" file)
(mc file)
(let ([dest (append-zo-suffix
(let-values ([(base name dir?) (split-path name)])
(build-path (if (symbol? base) 'same base)
"compiled" name)))])
(printf " [~a \"~a\"]~n"
(if did-one?
"output to"
"already up-to-date at")
dest))))
source-files)))]
[(collection-extension)
(compiler-warning)
(apply compile-collection-extension source-files)]

3
collects/mzlib/private/class-internal.ss
View File

@ -130,6 +130,7 @@
(append
(kernel-form-identifier-list)
(list
(quote-syntax #%app) ; scheme/base app, as opposed to #%plain-app
(quote-syntax -init)
(quote-syntax init-rest)
(quote-syntax -field)
@ -1314,7 +1315,7 @@
(letrec-syntaxes+values
([(plain-init-name) (make-init-redirect
(quote-syntax set!)
(quote-syntax #%app)
(quote-syntax #%plain-app)
(quote-syntax local-plain-init-name)
(quote-syntax plain-init-name-localized))] ...)
([(local-plain-init-name) undefined] ...)

2
collects/mzlib/private/classidmap.ss
View File

@ -328,7 +328,7 @@
(with-syntax ([object object-stx]
[method method-proc-stx]
[app (if rest-arg? (qstx apply) (qstx #%app))]
[app (if rest-arg? (qstx apply) (qstx #%plain-app))]
[args args-stx])
(if traced?
(with-syntax ([(mth obj) (generate-temporaries

27
collects/tests/mred/draw.ss
View File

@ -1,5 +1,4 @@
(require (lib "class100.ss"))
#lang scheme/gui
(define manual-chinese? #f)
@ -65,8 +64,6 @@
(send c set-editor e)
(send f show #t)))
(define pi (atan 0 -1))
(define star
(list (make-object point% 30 0)
(make-object point% 48 60)
@ -215,6 +212,7 @@
[clock-start #f]
[clock-end #f]
[clock-clip? #f]
[do-clock #f]
[use-bitmap? #f]
[use-bad? #f]
[depth-one? #f]
@ -286,15 +284,15 @@
[otfg (send dc get-text-foreground)]
[otbg (send dc get-text-background)]
[obm (send dc get-text-mode)])
(if (positive? flevel)
(send dc set-font
(make-object font%
10 'decorative
'normal
(if (> flevel 1)
'bold
'normal)
#t)))
(when (positive? flevel)
(send dc set-font
(make-object font%
10 'decorative
'normal
(if (> flevel 1)
'bold
'normal)
#t)))
(send dc set-pen pens)
(send dc set-brush brusht)
@ -1146,7 +1144,7 @@
(set! smoothing (list-ref '(unsmoothed smoothed aligned)
(send self get-selection)))
(send canvas refresh)))
(make-object button% "Clock" hp2.5 (lambda (b e) (clock #f)))
(make-object button% "Clock" hp2.5 (lambda (b e) (do-clock #f)))
(make-object choice% #f
'("MrEd XOR" "PLT Middle" "PLT ^ MrEd" "MrEd ^ PLT" "MrEd ^ MrEd"
"MrEd~" "MrEd ^ MrEd~" "M^M~ Opaque" "M^M~ Red"
@ -1212,6 +1210,7 @@
(set! clock-start #f)
(set! clock-end #f)
(send canvas refresh))))])
(set! do-clock clock)
(make-object button% "Clip Clock" hp3 (lambda (b e) (clock #t)))
(make-object slider% "Alpha" 0 10 hp4
(lambda (s e)