suzanne.soy/hyper-literate
1
0
Fork 0
Code Issues 4 Pull Requests 1 Actions Packages Projects Releases Wiki Activity

...

Browse Source 
original commit: c08748fcbcf882ca05f6754391d4ace5f009b361
This commit is contained in:
Robby Findler 2000-06-01 18:38:07 +00:00
parent 0120d9f015
commit cc5712aab2
70 changed files with 7507 additions and 7674 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
collects/help/help.ss
View File

@ -1,4 +1,6 @@
(require-library "errortrace.ss" "errortrace") (error-print-width 180)
(when (getenv "MREDDEBUG")
(require-library "errortrace.ss" "errortrace")
(error-print-width 180))
#|
TODO:
* demonstrate setup-plt launcher

8
collects/net/base64.ss Normal file
View File

@ -0,0 +1,8 @@
(require-relative-library "base64s.ss")
(begin-elaboration-time
(require-library "invoke.ss"))
(define-values/invoke-unit/sig mzlib:base64^
(require-relative-library "base64r.ss"))

68
collects/net/base64r.ss Normal file
View File

@ -0,0 +1,68 @@
(unit/sig mzlib:base64^
(import)
(define (base64-encode src)
; Always includes a terminator
(let* ([len (string-length src)]
[new-len (let ([l (add1 (ceiling (* len 8/6)))])
; Break l into 72-character lines.
; Insert CR/LF between each line.
(+ l (* (quotient l 72) 2)))]
[dest (make-string new-len #\0)]
[char-map (list->vector
(let ([each-char (lambda (s e)
(let loop ([l null][i (char->integer e)])
(if (= i (char->integer s))
(cons s l)
(loop (cons (integer->char i)
l)
(sub1 i)))))])
(append
(each-char #\A #\Z)
(each-char #\a #\z)
(each-char #\0 #\9)
(list #\+ #\/))))])
(let loop ([bits 0][v 0][col 0][srcp 0][destp 0])
(cond
[(= col 72)
; Insert CRLF
(string-set! dest destp #\return)
(string-set! dest (add1 destp) #\linefeed)
(loop bits
v
0
srcp
(+ destp 2))]
[(and (= srcp len)
(<= bits 6))
; That's all, folks.
; Write the last few bits.
(begin
(string-set! dest destp (vector-ref char-map (arithmetic-shift v (- 6 bits))))
(add1 destp))
(if (= col 71)
; Have to write CRLF before terminator
(begin
(string-set! dest (+ destp 1) #\return)
(string-set! dest (+ destp 2) #\linefeed)
(string-set! dest (+ destp 3) #\=))
(string-set! dest (add1 destp) #\=))
dest]
[(< bits 6)
; Need more bits.
(loop (+ bits 8)
(bitwise-ior (arithmetic-shift v 8)
(char->integer (string-ref src srcp)))
col
(add1 srcp)
destp)]
[else
; Write a char.
(string-set! dest destp (vector-ref char-map (arithmetic-shift v (- 6 bits))))
(loop (- bits 6)
(bitwise-and v (sub1 (arithmetic-shift 1 (- bits 6))))
(add1 col)
srcp
(add1 destp))])))))

3
collects/net/base64s.ss Normal file
View File

@ -0,0 +1,3 @@
(define-signature mzlib:base64^
(base64-encode))

8
collects/net/cgi.ss Normal file
View File

@ -0,0 +1,8 @@
(require-library "cgiu.ss" "net")
(begin-elaboration-time
(require-library "invoke.ss"))
(define-values/invoke-unit/sig mzlib:cgi^
mzlib:cgi@)

BIN
collects/srpersist/lib/win32/i386/srpmain.dll
View File

Binary file not shown.

685
collects/stepper/annotater.ss
View File

@ -30,31 +30,22 @@
(let+ ([val (values a b) (apply f (map car lsts))]
[val (values a-rest b-rest) (apply dual-map f (map cdr lsts))])
(values (cons a a-rest) (cons b b-rest)))))
; var-set-union takes some lists of varrefs where no element appears twice in one list, and
; binding-set-union takes some lists of bindings where no element appears twice in one list, and
; forms a new list which is the union of the sets.
; varref-remove* removes the varrefs in a-set from the varrefs in b-set
(define (varref-remove* a-set b-set)
(remove* a-set
b-set
(lambda (a-var b-var)
(eq? (z:varref-var a-var)
(z:varref-var b-var)))))
(define (varref-set-pair-union a-set b-set)
(define (binding-set-pair-union a-set b-set)
(cond [(or (eq? a-set 'all) (eq? b-set 'all)) 'all]
[else (append a-set (varref-remove* a-set b-set))]))
[else (append a-set (remq* a-set b-set))]))
(define var-set-union
(define binding-set-union
(lambda args
(foldl varref-set-pair-union
(foldl binding-set-pair-union
null
args)))
(define (var-set-intersect a-set b-set)
(varref-remove* (varref-remove* a-set b-set) b-set))
(define (binding-set-intersect a-set b-set)
(remq* (remq* a-set b-set) b-set))
(define never-undefined? never-undefined-getter)
(define (mark-never-undefined parsed) (never-undefined-setter parsed #t))
@ -68,7 +59,7 @@
(define (closure-key-maker closure)
closure)
; paroptarglist-> ilist and arglist->ilist are used to recreate
; mzscheme sexp syntax from the parsed zodiac form, so that the
; resulting expression can be fed to mzscheme.
@ -82,33 +73,24 @@
; translate-varref : returns the name the varref will get in the final output
(define (translate-varref expr)
(if (or (z:top-level-varref? expr) (not (z:parsed-back expr))) ; top level or extra-bogus varrefs
(if (z:top-level-varref? expr) ; top level varrefs
(z:varref-var expr)
(utils:get-binding-name (z:bound-varref-binding expr))))
; bindings->varrefs : turn a list of bindings into a list of bogus varrefs
(define (bindings->varrefs bindings)
(map create-bogus-bound-varref
(map z:binding-var bindings)
bindings))
(get-binding-name (z:bound-varref-binding expr))))
; make-debug-info builds the thunk which will be the mark at runtime. It contains
; a source expression (in the parsed zodiac format) and a set of z:varref/value pairs.
;((z:parsed (union (list-of z:varref) 'all) (list-of z:varref) (list-of z:varref) symbol) ->
; a source expression (in the parsed zodiac format) and a set of z:binding/value pairs.
;((z:parsed (union (list-of z:binding) 'all) (list-of z:binding) symbol) ->
; debug-info)
(define (make-debug-info source tail-bound free-vars label)
(let* ([kept-vars (if (eq? tail-bound 'all)
free-vars
(var-set-intersect tail-bound ; the order of these arguments is important if
; the tail-bound varrefs don't have bindings
free-vars))]
[real-kept-vars (filter z:bound-varref? kept-vars)]
(define (make-debug-info source tail-bound free-bindings label)
(let* ([kept-bindings (if (eq? tail-bound 'all)
free-bindings
(binding-set-intersect tail-bound
free-bindings))]
[var-clauses (map (lambda (x)
(let ([var (translate-varref x)])
(let ([var (get-binding-name x)])
(list var x)))
real-kept-vars)])
kept-bindings)])
(make-full-mark source label var-clauses)))
; cheap-wrap for non-debugging annotation
@ -124,8 +106,8 @@
; wrap-struct-form
(define (wrap-struct-form names annotated)
(let* ([arg-temps (build-list (length names) get-arg-varref)]
[arg-temp-syms (map z:varref-var arg-temps)]
(let* ([arg-temps (build-list (length names) get-arg-binding)]
[arg-temp-syms (map z:binding-var arg-temps)]
[struct-proc-names (cdr names)]
[closure-records (map (lambda (proc-name) `(,make-closure-record
(#%quote ,proc-name)
@ -193,7 +175,8 @@
(define (double-break-wrap expr)
(if break
`(#%begin (,(make-break 'double-break)) ,expr)))
`(#%begin (,(make-break 'double-break)) ,expr)
expr))
(define (simple-wcm-break-wrap debug-info expr)
(simple-wcm-wrap debug-info (break-wrap expr)))
@ -233,7 +216,7 @@
((z:vector? expr)
(search-exprs (vector->list object))) ; can source exprs be here?
((z:improper-list? expr)
(search-exprs (search-exprs object))) ; can source exprs be here?
(search-exprs (search-exprs object))) ; can source exprs be here? (is this a bug?)
(else (e:static-error "unknown expression type in sequence" expr)))))
(else (e:static-error "unknown read type" expr))))))))
@ -253,9 +236,9 @@
; annotate/inner takes
; a) a zodiac expression to annotate
; b) a list of all varrefs s.t. this expression is tail w.r.t. their bindings
; b) a list of all findins which this expression is tail w.r.t.
; or 'all to indicate that this expression is tail w.r.t. _all_ bindings.
; c) a list of bound-varrefs of 'floating' variables; i.e. lexical bindings NO: TAKEN OUT
; c) a list of varrefs of 'floating' variables; i.e. lexical bindings NO: TAKEN OUT
; whose value must be captured in order to reconstruct outer expressions.
; Necessitated by 'unit', useful for 'letrec*-values'.
; d) a boolean indicating whether this expression will be the r.h.s. of a reduction
@ -281,12 +264,12 @@
[lambda-body-recur (lambda (expr) (annotate/inner expr 'all #t #f))]
; note: no pre-break for the body of a let; it's handled by the break for the
; let itself.
[let-body-recur (lambda (expr vars) (annotate/inner expr (var-set-union tail-bound vars) #f #f))]
[let-body-recur (lambda (expr bindings) (annotate/inner expr (binding-set-union tail-bound bindings) #f #f))]
[cheap-wrap-recur (lambda (expr) (let-values ([(ann _) (non-tail-recur expr)]) ann))]
[make-debug-info-normal (lambda (free-vars)
(make-debug-info expr tail-bound free-vars 'none))]
[make-debug-info-app (lambda (tail-bound free-vars label)
(make-debug-info expr tail-bound free-vars label))]
[make-debug-info-normal (lambda (free-bindings)
(make-debug-info expr tail-bound free-bindings 'none))]
[make-debug-info-app (lambda (tail-bound free-bindings label)
(make-debug-info expr tail-bound free-bindings label))]
[wcm-wrap (if pre-break?
wcm-pre-break-wrap
simple-wcm-wrap)]
@ -297,7 +280,7 @@
; find the source expression and associate it with the parsed expression
(when (and red-exprs (not cheap-wrap?))
(set-expr-read! expr (find-read-expr expr)))
(set-expr-read! expr (find-read-expr expr)))
(cond
@ -315,8 +298,10 @@
[truly-top-level? (and (z:top-level-varref? expr) (not (utils:is-unit-bound? expr)))]
[_ (when truly-top-level?
(utils:check-for-syntax-or-macro-keyword expr))]
[free-vars (list expr)]
[debug-info (make-debug-info-normal free-vars)]
[free-bindings (if (z:bound-varref? expr)
(list (z:bound-varref-binding expr))
null)]
[debug-info (make-debug-info-normal free-bindings)]
[annotated (if (and maybe-undef? (utils:signal-undefined))
`(#%if (#%eq? ,v ,utils:the-undefined-value)
(#%raise (,utils:make-undefined
@ -329,54 +314,56 @@
(if (or (and maybe-undef? (utils:signal-undefined)) truly-top-level?)
(expr-cheap-wrap annotated)
annotated)
(wcm-break-wrap debug-info (return-value-wrap annotated))) free-vars))]
(wcm-break-wrap debug-info (return-value-wrap annotated))) free-bindings))]
[(z:app? expr)
(let+ ([val sub-exprs (cons (z:app-fun expr) (z:app-args expr))]
[val (values annotated-sub-exprs free-vars-sub-exprs)
(dual-map non-tail-recur sub-exprs)]
[val free-vars (apply var-set-union free-vars-sub-exprs)])
(let*-values
([(sub-exprs) (cons (z:app-fun expr) (z:app-args expr))]
[(annotated-sub-exprs free-bindings-sub-exprs)
(dual-map non-tail-recur sub-exprs)]
[(free-bindings) (apply binding-set-union free-bindings-sub-exprs)])
(if cheap-wrap?
(values (expr-cheap-wrap annotated-sub-exprs) free-vars)
(let+ ([val arg-temps (build-list (length sub-exprs) get-arg-varref)]
[val arg-temp-syms (map z:varref-var arg-temps)]
[val let-clauses `((,arg-temp-syms
(#%values ,@(map (lambda (x) `(#%quote ,*unevaluated*)) arg-temps))))]
[val set!-list (map (lambda (arg-symbol annotated-sub-expr)
`(#%set! ,arg-symbol ,annotated-sub-expr))
arg-temp-syms annotated-sub-exprs)]
[val new-tail-bound (var-set-union tail-bound arg-temps)]
[val app-debug-info (make-debug-info-app new-tail-bound arg-temps 'called)]
[val annotate-app? (let ([fun-exp (z:app-fun expr)])
(and (z:top-level-varref? fun-exp)
(non-annotated-proc? fun-exp)))]
[val final-app (break-wrap (simple-wcm-wrap app-debug-info
(if annotate-app?
(return-value-wrap arg-temp-syms)
arg-temp-syms)))]
[val debug-info (make-debug-info-app new-tail-bound
(var-set-union free-vars arg-temps)
'not-yet-called)]
[val let-body (wcm-wrap debug-info `(#%begin ,@set!-list ,final-app))]
[val let-exp `(#%let-values ,let-clauses ,let-body)])
(values let-exp free-vars))))]
(values (expr-cheap-wrap annotated-sub-exprs) free-bindings)
(let* ([arg-temps (build-list (length sub-exprs) get-arg-binding)]
[arg-temp-syms (map z:binding-var arg-temps)]
[let-clauses `((,arg-temp-syms
(#%values ,@(map (lambda (x) `(#%quote ,*unevaluated*)) arg-temps))))]
[set!-list (map (lambda (arg-symbol annotated-sub-expr)
`(#%set! ,arg-symbol ,annotated-sub-expr))
arg-temp-syms annotated-sub-exprs)]
[new-tail-bound (binding-set-union tail-bound arg-temps)]
[app-debug-info (make-debug-info-app new-tail-bound arg-temps 'called)]
[annotate-app? (let ([fun-exp (z:app-fun expr)])
(and (z:top-level-varref? fun-exp)
(non-annotated-proc? fun-exp)))]
[final-app (break-wrap (simple-wcm-wrap app-debug-info
(if annotate-app?
(return-value-wrap arg-temp-syms)
arg-temp-syms)))]
[debug-info (make-debug-info-app new-tail-bound
(binding-set-union free-bindings arg-temps)
'not-yet-called)]
[let-body (wcm-wrap debug-info `(#%begin ,@set!-list ,final-app))]
[let-exp `(#%let-values ,let-clauses ,let-body)])
(values let-exp free-bindings))))]
[(z:struct-form? expr)
(let ([super-expr (z:struct-form-super expr)]
[raw-type (utils:read->raw (z:struct-form-type expr))]
[raw-fields (map utils:read->raw (z:struct-form-fields expr))])
(if super-expr
(let+ ([val (values annotated-super-expr free-vars-super-expr)
(non-tail-recur super-expr)]
[val annotated
`(#%struct
,(list raw-type annotated-super-expr)
,raw-fields)]
[val debug-info (make-debug-info-normal free-vars-super-expr)])
(values (if cheap-wrap?
(expr-cheap-wrap annotated)
(wcm-wrap debug-info annotated))
free-vars-super-expr))
(let*-values
([(annotated-super-expr free-bindings-super-expr)
(non-tail-recur super-expr)]
[(annotated)
`(#%struct
,(list raw-type annotated-super-expr)
,raw-fields)]
[(debug-info) (make-debug-info-normal free-bindings-super-expr)])
(values (if cheap-wrap?
(expr-cheap-wrap annotated)
(wcm-wrap debug-info annotated))
free-bindings-super-expr))
(let ([annotated `(#%struct ,raw-type ,raw-fields)])
(values (if cheap-wrap?
(expr-cheap-wrap annotated)
@ -384,53 +371,44 @@
null))))]
[(z:if-form? expr)
(let+ ([val (values annotated-test free-vars-test)
(non-tail-recur (z:if-form-test expr))]
[val (values annotated-then free-vars-then)
(tail-recur (z:if-form-then expr))]
[val (values annotated-else free-vars-else)
(tail-recur (z:if-form-else expr))]
[val free-vars (var-set-union free-vars-test
free-vars-then
free-vars-else)]
[val inner-annotated `(#%if ,if-temp
,annotated-then
,annotated-else)]
[val annotated-2 (if (utils:signal-not-boolean)
`(#%if (#%boolean? ,if-temp)
,inner-annotated
(#%raise (,utils:make-not-boolean
(#%format ,utils:not-boolean-error-format
,if-temp)
(#%current-continuation-marks)
,if-temp)))
inner-annotated)])
(let*-values
([(annotated-test free-bindings-test)
(non-tail-recur (z:if-form-test expr))]
[(annotated-then free-bindings-then)
(tail-recur (z:if-form-then expr))]
[(annotated-else free-bindings-else)
(tail-recur (z:if-form-else expr))]
[(free-bindings) (binding-set-union free-bindings-test
free-bindings-then
free-bindings-else)]
[(if-temp-sym) (z:binding-var if-temp)]
[(inner-annotated) `(#%if ,if-temp-sym
,annotated-then
,annotated-else)]
[(annotated-2) (if (utils:signal-not-boolean)
`(#%if (#%boolean? ,if-temp-sym)
,inner-annotated
(#%raise (,utils:make-not-boolean
(#%format ,utils:not-boolean-error-format
,if-temp-sym)
(#%current-continuation-marks)
,if-temp-sym)))
inner-annotated)])
(if cheap-wrap?
(values
(expr-cheap-wrap (if (utils:signal-not-boolean)
`(#%let ((,if-temp ,annotated-test)) ,annotated-2)
`(#%let ((,if-temp-sym ,annotated-test)) ,annotated-2)
`(#%if ,annotated-test ,annotated-then ,annotated-else)))
free-vars)
(let+ ([val annotated `(#%begin
(#%set! ,if-temp ,annotated-test)
,(break-wrap
(if (utils:signal-not-boolean)
`(#%if (#%boolean? ,if-temp)
,inner-annotated
(#%raise (,utils:make-not-boolean
(#%format ,utils:not-boolean-error-format
,if-temp)
(#%current-continuation-marks)
,if-temp)))
inner-annotated)))]
[val if-temp-varref-list (list (create-bogus-bound-varref if-temp #f))]
[val debug-info (make-debug-info-app (var-set-union tail-bound if-temp-varref-list)
(var-set-union free-vars if-temp-varref-list)
'none)]
[val wcm-wrapped (wcm-wrap debug-info annotated)]
[val outer-annotated `(#%let ((,if-temp (#%quote ,*unevaluated*))) ,wcm-wrapped)])
(values outer-annotated free-vars))))]
free-bindings)
(let* ([annotated `(#%begin
(#%set! ,if-temp-sym ,annotated-test)
,(break-wrap annotated-2))]
[debug-info (make-debug-info-app (binding-set-union tail-bound (list if-temp))
(binding-set-union free-bindings (list if-temp))
'none)]
[wcm-wrapped (wcm-wrap debug-info annotated)]
[outer-annotated `(#%let ((,if-temp-sym (#%quote ,*unevaluated*))) ,wcm-wrapped)])
(values outer-annotated free-bindings))))]
[(z:quote-form? expr)
(let ([annotated `(#%quote ,(utils:read->raw (z:quote-form-expr expr)))])
@ -441,40 +419,43 @@
[(z:begin-form? expr)
(if top-level?
(let+ ([val bodies (z:begin-form-bodies expr)]
[val (values annotated-bodies free-vars)
(dual-map (lambda (expr)
(annotate/inner expr 'all #f #t))
bodies)])
(let*-values
([(bodies) (z:begin-form-bodies expr)]
[(annotated-bodies free-bindings)
(dual-map (lambda (expr)
(annotate/inner expr 'all #f #t))
bodies)])
(values `(#%begin ,@annotated-bodies)
(apply var-set-union free-vars)))
(let+ ([val bodies (z:begin-form-bodies expr)]
[val (values all-but-last-body last-body-list)
(list-partition bodies (- (length bodies) 1))]
[val last-body (car last-body-list)]
[val (values annotated-a free-vars-a)
(dual-map non-tail-recur all-but-last-body)]
[val (values annotated-final free-vars-final)
(tail-recur last-body)]
[val free-vars (apply var-set-union free-vars-final free-vars-a)]
[val debug-info (make-debug-info-normal free-vars)]
[val annotated `(#%begin ,@(append annotated-a (list annotated-final)))])
(apply binding-set-union free-bindings)))
(let*-values
([(bodies) (z:begin-form-bodies expr)]
[(all-but-last-body last-body-list)
(list-partition bodies (- (length bodies) 1))]
[(last-body) (car last-body-list)]
[(annotated-a free-bindings-a)
(dual-map non-tail-recur all-but-last-body)]
[(annotated-final free-bindings-final)
(tail-recur last-body)]
[(free-bindings) (apply binding-set-union free-bindings-final free-bindings-a)]
[(debug-info) (make-debug-info-normal free-bindings)]
[(annotated) `(#%begin ,@(append annotated-a (list annotated-final)))])
(values (if cheap-wrap?
(expr-cheap-wrap annotated)
(wcm-wrap debug-info annotated))
free-vars)))]
free-bindings)))]
[(z:begin0-form? expr)
(let+ ([val bodies (z:begin0-form-bodies expr)]
[val (values annotated-bodies free-vars-lists)
(dual-map non-tail-recur bodies)]
[val free-vars (apply var-set-union free-vars-lists)]
[val debug-info (make-debug-info-normal free-vars)]
[val annotated `(#%begin0 ,@annotated-bodies)])
(let*-values
([(bodies) (z:begin0-form-bodies expr)]
[(annotated-bodies free-bindings-lists)
(dual-map non-tail-recur bodies)]
[(free-bindings) (apply binding-set-union free-bindings-lists)]
[(debug-info) (make-debug-info-normal free-bindings)]
[(annotated) `(#%begin0 ,@annotated-bodies)])
(values (if cheap-wrap?
(expr-cheap-wrap annotated)
(wcm-wrap debug-info annotated))
free-vars))]
free-bindings))]
; gott in himmel! this transformation is complicated. Just for the record,
; here's a sample transformation:
@ -504,179 +485,185 @@
; a mark after, so only one of each. groovy, eh?
[(z:let-values-form? expr)
(let+ ([val var-sets (z:let-values-form-vars expr)]
[val var-set-list (apply append var-sets)]
[val vals (z:let-values-form-vals expr)]
[_ (for-each utils:check-for-keyword var-set-list)]
[_ (for-each mark-never-undefined var-set-list)]
[val (values annotated-vals free-vars-vals)
(dual-map non-tail-recur vals)]
[val (values annotated-body free-vars-body)
(let-body-recur (z:let-values-form-body expr)
(bindings->varrefs var-set-list))]
[val free-vars (apply var-set-union (varref-remove* (bindings->varrefs var-set-list) free-vars-body)
free-vars-vals)])
(let*-values
([(binding-sets) (z:let-values-form-vars expr)]
[(binding-set-list) (apply append binding-sets)]
[(vals) (z:let-values-form-vals expr)]
[(_1) (for-each utils:check-for-keyword binding-set-list)]
[(_2) (for-each mark-never-undefined binding-set-list)]
[(annotated-vals free-bindings-vals)
(dual-map non-tail-recur vals)]
[(annotated-body free-bindings-body)
(let-body-recur (z:let-values-form-body expr) binding-set-list)]
[(free-bindings) (apply binding-set-union (remq* binding-set-list free-bindings-body)
free-bindings-vals)])
(if cheap-wrap?
(let ([bindings
(map (lambda (vars val)
`(,(map utils:get-binding-name vars) ,val))
var-sets
(map (lambda (bindings val)
`(,(map get-binding-name bindings) ,val))
binding-sets
annotated-vals)])
(values (expr-cheap-wrap `(#%let-values ,bindings ,annotated-body)) free-vars))
(let+ ([val dummy-var-sets
(let ([counter 0])
(map (lambda (var-set)
(map (lambda (var)
(begin0
(get-arg-varref counter)
(set! counter (+ counter 1))))
var-set))
var-sets))]
[val dummy-var-list (apply append dummy-var-sets)]
[val outer-dummy-initialization
`([,(map z:varref-var dummy-var-list)
(#%values ,@(build-list (length dummy-var-list)
(lambda (_) `(#%quote ,*unevaluated*))))])]
[val set!-clauses
(map (lambda (dummy-var-set val)
`(#%set!-values ,(map z:varref-var dummy-var-set) ,val))
dummy-var-sets
annotated-vals)]
[val inner-transference
`([,(map utils:get-binding-name var-set-list)
(values ,@(map z:varref-var dummy-var-list))])]
(values (expr-cheap-wrap `(#%let-values ,bindings ,annotated-body)) free-bindings))
(let* ([dummy-binding-sets
(let ([counter 0])
(map (lambda (binding-set)
(map (lambda (binding)
(begin0
(get-arg-binding counter)
(set! counter (+ counter 1))))
binding-set))
binding-sets))]
[dummy-binding-list (apply append dummy-binding-sets)]
[outer-dummy-initialization
`([,(map z:binding-var dummy-binding-list)
(#%values ,@(build-list (length dummy-binding-list)
(lambda (_) `(#%quote ,*unevaluated*))))])]
[set!-clauses
(map (lambda (dummy-binding-set val)
`(#%set!-values ,(map z:binding-var dummy-binding-set) ,val))
dummy-binding-sets
annotated-vals)]
[inner-transference
`([,(map get-binding-name binding-set-list)
(values ,@(map z:binding-var dummy-binding-list))])]
; time to work from the inside out again
[val inner-let-values
`(#%let-values ,inner-transference ,annotated-body)]
[val middle-begin
`(#%begin ,@set!-clauses ,(double-break-wrap inner-let-values))]
[val wrapped-begin
(wcm-wrap (make-debug-info-app (var-set-union tail-bound dummy-var-list)
(var-set-union free-vars dummy-var-list)
'let-body)
middle-begin)]
[val whole-thing
`(#%let-values ,outer-dummy-initialization ,wrapped-begin)])
(values whole-thing free-vars))))]
[inner-let-values
`(#%let-values ,inner-transference ,annotated-body)]
[middle-begin
`(#%begin ,@set!-clauses ,(double-break-wrap inner-let-values))]
[wrapped-begin
(wcm-wrap (make-debug-info-app (binding-set-union tail-bound dummy-binding-list)
(binding-set-union free-bindings dummy-binding-list)
'let-body)
middle-begin)]
[whole-thing
`(#%let-values ,outer-dummy-initialization ,wrapped-begin)])
(values whole-thing free-bindings))))]
[(z:letrec-values-form? expr)
(let+ ([val var-sets (z:letrec-values-form-vars expr)]
[val var-set-list (apply append var-sets)]
[val var-set-list-varrefs (bindings->varrefs var-set-list)]
[val var-set-list-binding-names (map utils:get-binding-name var-set-list)]
[val vals (z:letrec-values-form-vals expr)]
[_ (when (andmap z:case-lambda-form? vals)
(for-each mark-never-undefined var-set-list))] ; we could be more aggressive about this.
[_ (for-each utils:check-for-keyword var-set-list)]
[val (values annotated-vals free-vars-vals)
(dual-map non-tail-recur vals)]
[val (values annotated-body free-vars-body)
(let-body-recur (z:letrec-values-form-body expr)
var-set-list-varrefs)]
[val free-vars-inner (apply var-set-union free-vars-body free-vars-vals)]
[val free-vars-outer (varref-remove* var-set-list-varrefs free-vars-inner)])
(let*-values
([(binding-sets) (z:letrec-values-form-vars expr)]
[(binding-list) (apply append binding-sets)]
[(binding-names) (map get-binding-name binding-list)]
[(vals) (z:letrec-values-form-vals expr)]
[(_1) (when (andmap z:case-lambda-form? vals)
(for-each mark-never-undefined binding-list))] ; we could be more aggressive about this.
[(_2) (for-each utils:check-for-keyword binding-list)]
[(annotated-vals free-bindings-vals)
(dual-map non-tail-recur vals)]
[(annotated-body free-bindings-body)
(let-body-recur (z:letrec-values-form-body expr)
binding-list)]
[(free-bindings-inner) (apply binding-set-union free-bindings-body free-bindings-vals)]
[(free-bindings-outer) (remq* binding-list free-bindings-inner)])
(if cheap-wrap?
(let ([bindings
(map (lambda (vars val)
`(,(map utils:get-binding-name vars)
(map (lambda (bindings val)
`(,(map get-binding-name bindings)
,val))
var-sets
binding-sets
annotated-vals)])
(values (expr-cheap-wrap `(#%letrec-values ,bindings ,annotated-body))
free-vars-outer))
(let+ ([val outer-initialization
`((,var-set-list-binding-names
(values ,@var-set-list-binding-names)))]
[val set!-clauses
(map (lambda (var-set val)
`(#%set!-values ,(map utils:get-binding-name var-set) ,val))
var-sets
annotated-vals)]
[val middle-begin
`(#%begin ,@set!-clauses ,(double-break-wrap annotated-body))]
[val wrapped-begin
(wcm-wrap (make-debug-info-app (var-set-union tail-bound var-set-list-varrefs)
(var-set-union free-vars-inner var-set-list-varrefs)
'let-body)
middle-begin)]
[val whole-thing
`(#%letrec-values ,outer-initialization ,wrapped-begin)])
(values whole-thing free-vars-outer))))]
free-bindings-outer))
(let* ([outer-initialization
`((,binding-names (#%values ,@binding-names)))]
[set!-clauses
(map (lambda (binding-set val)
`(#%set!-values ,(map get-binding-name binding-set) ,val))
binding-sets
annotated-vals)]
[middle-begin
`(#%begin ,@set!-clauses ,(double-break-wrap annotated-body))]
[wrapped-begin
(wcm-wrap (make-debug-info-app (binding-set-union tail-bound binding-list)
(binding-set-union free-bindings-inner binding-list)
'let-body)
middle-begin)]
[whole-thing
`(#%letrec-values ,outer-initialization ,wrapped-begin)])
(values whole-thing free-bindings-outer))))]
[(z:define-values-form? expr)
(let+ ([val vars (z:define-values-form-vars expr)]
[val _ (map utils:check-for-keyword vars)]
[val var-names (map z:varref-var vars)]
; NB: this next recurrence is NOT really tail, but we cannot
; mark define-values itself, so we mark the sub-expr as
; if it was in tail posn (i.e., we must hold on to
; bindings).
[val val (z:define-values-form-val expr)]
[val (values annotated-val free-vars-val)
(define-values-recur val)]
[val free-vars (varref-remove* vars free-vars-val)])
(let*-values
([(vars) (z:define-values-form-vars expr)]
[(_1) (map utils:check-for-keyword vars)]
[(binding-names) (map z:varref-var vars)]
; NB: this next recurrence is NOT really tail, but we cannot
; mark define-values itself, so we mark the sub-expr as
; if it was in tail posn (i.e., we must hold on to
; bindings).
[(val) (z:define-values-form-val expr)]
[(annotated-val free-bindings-val)
(define-values-recur val)])
(cond [(and (z:case-lambda-form? val) (not cheap-wrap?))
(values `(#%define-values ,var-names
(values `(#%define-values ,binding-names
(#%let ((,closure-temp ,annotated-val))
(,update-closure-record-name ,closure-temp (#%quote ,(car var-names)))
(,update-closure-record-name ,closure-temp (#%quote ,(car binding-names)))
,closure-temp))
free-vars)]
free-bindings-val)]
[(z:struct-form? val)
(values `(#%define-values ,var-names
,(wrap-struct-form var-names annotated-val))
free-vars)]
(values `(#%define-values ,binding-names
,(wrap-struct-form binding-names annotated-val))
free-bindings-val)]
[else
(values `(#%define-values ,var-names
(values `(#%define-values ,binding-names
,annotated-val)
free-vars)]))]
free-bindings-val)]))]
[(z:set!-form? expr)
(utils:check-for-keyword (z:set!-form-var expr))
(let+ ([val v (translate-varref (z:set!-form-var expr))]
[val (values annotated-body rhs-free-vars)
(non-tail-recur (z:set!-form-val expr))]
[val free-vars (var-set-union (list (z:set!-form-var expr)) rhs-free-vars)]
[val debug-info (make-debug-info-normal free-vars)]
[val annotated `(#%set! ,v ,annotated-body)])
(utils:check-for-keyword (z:set!-form-var expr))
(let*-values
([(var) (z:set!-form-var expr)]
[(v) (translate-varref var)]
[(annotated-body rhs-free-bindings)
(non-tail-recur (z:set!-form-val expr))]
[(free-bindings) (binding-set-union (if (z:top-level-varref? var)
null
(list (z:bound-varref-binding var)))
rhs-free-bindings)]
[(debug-info) (make-debug-info-normal free-bindings)]
[(annotated) `(#%set! ,v ,annotated-body)])
(values (if cheap-wrap?
(expr-cheap-wrap annotated)
(wcm-wrap (make-debug-info-normal free-vars) annotated))
free-vars))]
(wcm-wrap (make-debug-info-normal free-bindings) annotated))
free-bindings))]
[(z:case-lambda-form? expr)
(let+ ([val (values annotated-cases free-vars-cases)
(dual-map
(lambda (arglist body)
(let ([var-list (bindings->varrefs (z:arglist-vars arglist))]
[args (utils:arglist->ilist arglist)])
(utils:improper-foreach utils:check-for-keyword args)
(utils:improper-foreach mark-never-undefined args)
(let+ ([val (values annotated free-vars)
(lambda-body-recur body)]
[val new-free-vars (varref-remove* var-list free-vars)]
[val new-annotated (list (utils:improper-map utils:get-binding-name args)
annotated)])
(values new-annotated new-free-vars))))
(z:case-lambda-form-args expr)
(z:case-lambda-form-bodies expr))]
[val annotated-case-lambda (cons '#%case-lambda annotated-cases)]
[val new-free-vars (apply var-set-union free-vars-cases)]
[val closure-info (make-debug-info-app 'all new-free-vars 'none)]
[val wrapped-annotated (wcm-wrap (make-debug-info-normal null)
annotated-case-lambda)]
[val hash-wrapped `(#%let ([,closure-temp ,wrapped-annotated])
(,closure-table-put! (,closure-key-maker ,closure-temp)
(,make-closure-record
#f
,closure-info
#f))
,closure-temp)])
(let*-values
([(annotated-cases free-bindings-cases)
(dual-map
(lambda (arglist body)
(let ([binding-list (z:arglist-vars arglist)]
[args (utils:arglist->ilist arglist)])
(utils:improper-foreach utils:check-for-keyword args)
(utils:improper-foreach mark-never-undefined args)
(let*-values
([(annotated free-bindings)
(lambda-body-recur body)]
[(new-free-bindings) (remq* binding-list free-bindings)]
[(new-annotated) (list (utils:improper-map get-binding-name args)
annotated)])
(values new-annotated new-free-bindings))))
(z:case-lambda-form-args expr)
(z:case-lambda-form-bodies expr))]
[(annotated-case-lambda) (cons '#%case-lambda annotated-cases)]
[(new-free-bindings) (apply binding-set-union free-bindings-cases)]
[(closure-info) (make-debug-info-app 'all new-free-bindings 'none)]
[(wrapped-annotated) (wcm-wrap (make-debug-info-normal null)
annotated-case-lambda)]
[(hash-wrapped) `(#%let ([,closure-temp ,wrapped-annotated])
(,closure-table-put! (,closure-key-maker ,closure-temp)
(,make-closure-record
#f
,closure-info
#f))
,closure-temp)])
(values (if cheap-wrap?
annotated-case-lambda
hash-wrapped)
new-free-vars))]
new-free-bindings))]
; the annotation for w-c-m is insufficient for
; debugging: there must be an intermediate let & set!s to
@ -684,43 +671,44 @@
; value.
[(z:with-continuation-mark-form? expr)
(let+ ([val (values annotated-key free-vars-key)
(non-tail-recur (z:with-continuation-mark-form-key expr))]
[val (values annotated-val free-vars-val)
(non-tail-recur (z:with-continuation-mark-form-val expr))]
[val (values annotated-body free-vars-body)
(non-tail-recur (z:with-continuation-mark-form-body expr))]
[val free-vars (var-set-union free-vars-key free-vars-val free-vars-body)]
[val debug-info (make-debug-info-normal free-vars)]
[val annotated `(#%with-continuation-mark
,annotated-key
,annotated-val
,annotated-body)])
(let*-values
([(annotated-key free-bindings-key)
(non-tail-recur (z:with-continuation-mark-form-key expr))]
[(annotated-val free-bindings-val)
(non-tail-recur (z:with-continuation-mark-form-val expr))]
[(annotated-body free-bindings-body)
(non-tail-recur (z:with-continuation-mark-form-body expr))]
[(free-bindings) (binding-set-union free-bindings-key free-bindings-val free-bindings-body)]
[(debug-info) (make-debug-info-normal free-bindings)]
[(annotated) `(#%with-continuation-mark
,annotated-key
,annotated-val
,annotated-body)])
(values (if cheap-wrap?
(expr-cheap-wrap annotated)
(wcm-wrap debug-info annotated))
free-vars))]
free-bindings))]
[(not cheap-wrap?)
(e:static-error "cannot annotate units or classes except in cheap-wrap mode")]
[(z:unit-form? expr)
(let+ ([val imports (z:unit-form-imports expr)]
[val exports (map (lambda (export)
(list (translate-varref (car export))
(z:read-object (cdr export))))
(z:unit-form-exports expr))]
[val clauses (map annotate/top-level (z:unit-form-clauses expr))])
(for-each utils:check-for-keyword imports)
(let* ([imports (z:unit-form-imports expr)]
[exports (map (lambda (export)
(list (translate-varref (car export))
(z:read-object (cdr export))))
(z:unit-form-exports expr))]
[clauses (map annotate/top-level (z:unit-form-clauses expr))])
(for-each utils:check-for-keyword imports)
(values
`(#%unit
(import ,@(map utils:get-binding-name imports))
(import ,@(map get-binding-name imports))
(export ,@exports)
,@clauses)
null))]
[(z:compound-unit-form? expr)
(let ((imports (map utils:get-binding-name
(let ((imports (map get-binding-name
(z:compound-unit-form-imports expr)))
(links (z:compound-unit-form-links expr))
(exports (z:compound-unit-form-exports expr)))
@ -728,15 +716,15 @@
((links
(map
(lambda (link-clause)
(let+ ([val tag (utils:read->raw (car link-clause))]
[val sub-unit (cheap-wrap-recur (cadr link-clause))]
[val imports
(map (lambda (import)
(if (z:lexical-varref? import)
(translate-varref import)
`(,(utils:read->raw (car import))
,(utils:read->raw (cdr import)))))
(cddr link-clause))])
(let* ([tag (utils:read->raw (car link-clause))]
[sub-unit (cheap-wrap-recur (cadr link-clause))]
[imports
(map (lambda (import)
(if (z:lexical-varref? import)
(translate-varref import)
`(,(utils:read->raw (car import))
,(utils:read->raw (cdr import)))))
(cddr link-clause))])
`(,tag (,sub-unit ,@imports))))
links))
(exports
@ -760,8 +748,8 @@
null)]
[(z:interface-form? expr)
(let ((vars (z:interface-form-variables expr)))
(for-each utils:check-for-keyword vars)
(let ([vars (z:interface-form-variables expr)])
(for-each utils:check-for-keyword vars)
(values
(expr-cheap-wrap
`(#%interface ,(map cheap-wrap-recur
@ -774,10 +762,10 @@
(lambda (element)
(if (pair? element)
(and (utils:check-for-keyword (car element))
(list (utils:get-binding-name (car element))
(list (get-binding-name (car element))
(cheap-wrap-recur (cdr element))))
(and (utils:check-for-keyword element)
(utils:get-binding-name element))))]
(get-binding-name element))))]
[paroptarglist->ilist
(lambda (paroptarglist)
(cond
@ -797,8 +785,8 @@
(values
(expr-cheap-wrap
`(#%class*/names
(,(utils:get-binding-name (z:class*/names-form-this expr))
,(utils:get-binding-name (z:class*/names-form-super-init expr)))
(,(get-binding-name (z:class*/names-form-this expr))
,(get-binding-name (z:class*/names-form-super-init expr)))
,(cheap-wrap-recur (z:class*/names-form-super-expr expr))
,(map cheap-wrap-recur (z:class*/names-form-interfaces expr))
,(paroptarglist->ilist (z:class*/names-form-init-vars expr))
@ -808,7 +796,7 @@
((z:public-clause? clause)
`(public
,@(map (lambda (internal export expr)
`((,(utils:get-binding-name internal)
`((,(get-binding-name internal)
,(utils:read->raw export))
,(cheap-wrap-recur expr)))
(z:public-clause-internals clause)
@ -817,7 +805,7 @@
((z:override-clause? clause)
`(override
,@(map (lambda (internal export expr)
`((,(utils:get-binding-name internal)
`((,(get-binding-name internal)
,(utils:read->raw export))
,(cheap-wrap-recur expr)))
(z:override-clause-internals clause)
@ -826,21 +814,21 @@
((z:private-clause? clause)
`(private
,@(map (lambda (internal expr)
`(,(utils:get-binding-name internal)
`(,(get-binding-name internal)
,(cheap-wrap-recur expr)))
(z:private-clause-internals clause)
(z:private-clause-exprs clause))))
((z:inherit-clause? clause)
`(inherit
,@(map (lambda (internal inherited)
`(,(utils:get-binding-name internal)
`(,(get-binding-name internal)
,(utils:read->raw inherited)))
(z:inherit-clause-internals clause)
(z:inherit-clause-imports clause))))
((z:rename-clause? clause)
`(rename
,@(map (lambda (internal import)
`(,(utils:get-binding-name internal)
`(,(get-binding-name internal)
,(utils:read->raw import)))
(z:rename-clause-internals clause)
(z:rename-clause-imports clause))))
@ -852,7 +840,6 @@
null))]
[else
(print-struct #t)
(e:internal-error
expr
"stepper:annotate/inner: unknown object to annotate, ~a~n"
@ -869,5 +856,7 @@
(annotate/top-level expr))
parsed-exprs)])
(values annotated-exprs
struct-proc-names)))))
struct-proc-names))))
)

31
collects/stepper/marks.ss
View File

@ -34,17 +34,9 @@
(define (mark-binding-value mark-binding)
(car mark-binding))
(define (mark-binding-varref mark-binding)
(define (mark-binding-binding mark-binding)
(cadr mark-binding))
(define (original-name varref)
(if (z:top-level-varref? varref)
(z:varref-var varref)
(let ([binding (z:bound-varref-binding varref)])
(if binding
(z:binding-orig-name binding)
(z:varref-var varref))))) ; this happens for application temps
(define (expose-mark mark)
(let ([source (mark-source mark)]
[label (mark-label mark)]
@ -52,7 +44,7 @@
(list source
label
(map (lambda (binding)
(list (original-name (mark-binding-varref binding))
(list (z:binding-orig-name (mark-binding-binding binding))
(mark-binding-value binding)))
bindings))))
@ -67,23 +59,16 @@
(printf " ~a : ~a~n" (car binding-pair) (cadr binding-pair)))
(caddr exposed))))
(define (lookup-var-binding mark-list var)
(printf "entering lookup-var-binding~n")
(define (lookup-binding mark-list binding)
(if (null? mark-list)
; must be a primitive
(begin
(printf "going into error~n")
(error 'lookup-var-binding "variable not found in environment: ~a" var))
; (error var "no binding found for variable.")
(error 'lookup-binding "variable not found in environment: ~a" binding)
(let* ([bindings (mark-bindings (car mark-list))]
[_ (printf "bindings: ~a~n" bindings)]
[matches (filter (lambda (mark-var)
(eq? var (z:varref-var (mark-binding-varref mark-var))))
[matches (filter (lambda (b)
(eq? binding (mark-binding-binding b)))
bindings)])
(printf "matches length: ~a~n" (length matches))
(cond [(null? matches)
(lookup-var-binding (cdr mark-list) var)]
(lookup-binding (cdr mark-list) binding)]
[(> (length matches) 1)
(error 'lookup-var-binding "more than one variable binding found for var: ~a" var)]
(error 'lookup-binding "more than one variable binding found for binding: ~a" binding)]
[else ; (length matches) = 1
(car matches)])))))

10
collects/stepper/model.ss
View File

@ -170,13 +170,12 @@
(z:scheme-expand new-expr 'previous user-vocabulary))))])
(let*-values ([(annotated-list envs) (a:annotate (list new-expr) (list new-parsed) packaged-envs break #f)]
[(annotated) (car annotated-list)])
(printf "annotated:~n~a~n" annotated)
(set! packaged-envs envs)
(set! current-expr new-parsed)
(check-for-repeated-names new-parsed exception-handler)
(current-exception-handler exception-handler)
(let ([expression-result
(user-primitive-eval annotated)])
(parameterize ([current-exception-handler exception-handler])
(user-primitive-eval annotated))])
(send-to-drscheme-eventspace
(lambda ()
(add-finished-expr expression-result)
@ -212,16 +211,13 @@
(finish-thunk reconstructed redex)))))])
(case break-kind
[(normal-break)
(printf "entering normal-break~n")
(when (not (r:skip-redex-step? mark-list))
(printf "not skipping step~n")
(reconstruct-helper
(lambda (reconstructed redex)
(set! held-expr reconstructed)
(set! held-redex redex)
(continue-user-computation)))
(suspend-user-computation))
(printf "finished normal-break~n")]
(suspend-user-computation))]
[(result-break)
(when (not (or (r:skip-redex-step? mark-list)
(and (null? returned-value-list)

85
collects/stepper/reconstructr.ss
View File

@ -8,6 +8,8 @@
[s : stepper:model^]
stepper:shared^)
(define the-undefined-value (letrec ([x x]) x))
(define nothing-so-far (gensym "nothing-so-far-"))
(define memoized-read->raw
@ -85,8 +87,12 @@
(string->symbol (string-append "~" (symbol->string binding-name) "~" (number->string free-num)))))
(define (lookup-lifted-name binding)
(string->symbol (string-append "~" (symbol->string (z:binding-orig-name binding)) "~"
(number->string (hash-table-get lifted-names-table binding)))))
(cond [(hash-table-get lifted-names-table binding (lambda () #f)) =>
(lambda (binding-number)
(string->symbol (string-append "~" (symbol->string (z:binding-orig-name binding)) "~"
(number->string binding-number))))]
[else ; the user is about to get the undefined value in a letrec...
(z:binding-orig-name binding)]))
(define (rectify-value val)
(let ([closure-record (closure-table-lookup val (lambda () #f))])
@ -132,21 +138,13 @@
(or (z:lambda-varref? expr)
(let ([var (z:varref-var expr)])
(with-handlers
();[exn:variable? (lambda args (printf "c~n") #f)])
(printf "a~n")
(or (and (printf "a.5~n")
(s:check-pre-defined-var var)
(printf "result: ~a~n" (s:check-pre-defined-var var))
(printf "b~n")
([exn:variable? (lambda args #f)])
(or (and (s:check-pre-defined-var var)
(or (procedure? (s:global-lookup var))
(eq? var 'empty)))
(let ([val (if (z:top-level-varref? expr)
(s:global-lookup var)
(begin
(printf "fkjd~n")
(printf "~a~n" (lookup-var-binding mark-list var))
(lookup-var-binding mark-list var)))])
(printf "past lookup-var-binding~n")
(lookup-binding mark-list (z:bound-varref-binding expr)))])
(and (procedure? val)
(not (continuation? val))
(eq? var
@ -154,8 +152,7 @@
(closure-table-lookup val (lambda () #f)))))))))))
(and (z:app? expr)
(let ([fun-val (mark-binding-value
(lookup-var-binding mark-list
(z:varref-var (get-arg-varref 0))))])
(lookup-binding mark-list (get-arg-binding 0)))])
(and (procedure? fun-val)
(procedure-arity-includes?
fun-val
@ -176,7 +173,7 @@
(in-inserted-else-clause mark-list)))))
(define (second-arg-is-list? mark-list)
(let ([arg-val (mark-binding-value (lookup-var-binding mark-list (z:varref-var (get-arg-varref 2))))])
(let ([arg-val (mark-binding-value (lookup-binding mark-list (get-arg-binding 2)))])
(list? arg-val)))
(define (in-inserted-else-clause mark-list)
@ -198,7 +195,7 @@
(if (memq binding lexically-bound-bindings)
(z:binding-orig-name binding)
(if (z:lambda-binding? binding)
(rectify-value (mark-binding-value (lookup-var-binding mark-list (z:varref-var expr))))
(rectify-value (mark-binding-value (lookup-binding mark-list (z:bound-varref-binding expr))))
(lookup-lifted-name binding))))]
[(z:top-level-varref? expr)
(z:varref-var expr)])]
@ -406,19 +403,22 @@
(lambda (expr)
(rectify-source-expr expr mark-list null))]
[rectify-let
(lambda (binding-sets letrec? vals body)
(lambda (letrec? binding-sets vals body)
(let+ ([val binding-list (apply append binding-sets)]
[val binding-names (map (lambda (set) (map z:binding-orig-name set)) binding-sets)]
[val must-be-values? (ormap (lambda (n-list) (not (= (length n-list) 1))) binding-sets)]
[val dummy-var-list (build-list (length binding-list)
(lambda (x) (z:varref-var (get-arg-varref x))))]
[val rhs-vals (map (lambda (arg-sym)
(mark-binding-value (lookup-var-binding mark-list arg-sym)))
[val dummy-var-list (if letrec?
binding-list
(build-list (length binding-list) get-arg-binding))]
[val rhs-vals (map (lambda (arg-binding)
(mark-binding-value (lookup-binding mark-list arg-binding)))
dummy-var-list)]
[val rhs-list
(let loop ([binding-sets binding-sets] [rhs-vals rhs-vals] [rhs-sources vals])
(cond [(null? binding-sets) null]
[(eq? (car rhs-vals) *unevaluated*)
[(eq? (car rhs-vals) (if letrec?
the-undefined-value
*unevaluated*))
(cons so-far
(map (lambda (expr)
(rectify-source-expr expr mark-list (if letrec?
@ -436,8 +436,10 @@
(loop (cdr binding-sets) remaining (cdr rhs-sources))))]))]
[val rectified-body (rectify-source-expr body mark-list binding-list)])
(if must-be-values?
`(let-values ,(map list binding-names rhs-list) ,rectified-body)
`(let ,(map list (map car binding-names) rhs-list) ,rectified-body))))]
`(,(if letrec? 'letrec-values 'let-values)
,(map list binding-names rhs-list) ,rectified-body)
`(,(if letrec? 'letrec 'let)
,(map list (map car binding-names) rhs-list) ,rectified-body))))]
[top-mark (car mark-list)]
[expr (mark-source top-mark)])
(cond
@ -452,16 +454,12 @@
[(z:app? expr)
(let* ([sub-exprs (cons (z:app-fun expr) (z:app-args expr))]
[arg-temps (build-list (length sub-exprs) get-arg-varref)]
[arg-temp-syms (map z:varref-var arg-temps)]
[arg-vals (map (lambda (arg-sym)
(mark-binding-value (lookup-var-binding mark-list arg-sym)))
arg-temp-syms)])
[arg-temps (build-list (length sub-exprs) get-arg-binding)]
[arg-vals (map (lambda (arg-temp)
(mark-binding-value (lookup-binding mark-list arg-temp)))
arg-temps)])
(case (mark-label (car mark-list))
((not-yet-called)
; (printf "length of mark-list: ~s~n" (length mark-list))
; (printf "mark has binding for third arg: ~s~n"
; (lookup-var-binding (list (car mark-list)) (z:varref:var
(letrec
([split-lists
(lambda (exprs vals)
@ -502,8 +500,7 @@
[(z:if-form? expr)
(let ([test-exp (if (eq? so-far nothing-so-far)
(rectify-source-current-marks
(create-bogus-bound-varref if-temp #f))
(rectify-value (mark-binding-value (lookup-binding mark-list if-temp)))
so-far)])
(cond [(comes-from-cond? expr)
(let* ([clause (list test-exp (rectify-source-current-marks (z:if-form-then expr)))]
@ -569,18 +566,19 @@
(cdr mark-list)
#f))))
(define (let-style-abstraction binding-sets body)
(define (let-style-abstraction letrec? binding-sets body)
(let* ([redex (rectify-inner mark-list #f)]
[binding-list (apply append binding-sets)]
[new-names (map insert-lifted-name binding-list)]
[dummy-var-list (build-list (length binding-list) (lambda (x)
(z:varref-var (get-arg-varref x))))]
[rhs-vals (map (lambda (arg-sym)
(mark-binding-value (lookup-var-binding mark-list arg-sym)))
[dummy-var-list (if letrec?
binding-list
(build-list (length binding-list) get-arg-binding))]
[rhs-vals (map (lambda (arg-temp)
(mark-binding-value (lookup-binding mark-list arg-temp)))
dummy-var-list)]
[before-step (current-def-rectifier redex (cdr mark-list) #f)]
[before-step (current-def-rectifier highlight-placeholder (cdr mark-list) #f)]
[reduct (rectify-source-expr body mark-list null)]
[after-step (current-def-rectifier reduct (cdr mark-list) #f)]
[after-step (current-def-rectifier highlight-placeholder (cdr mark-list) #f)]
[new-defines (map (lambda (name val) `(define ,name ,val)) new-names rhs-vals)])
(list new-defines before-step redex after-step reduct)))
@ -588,13 +586,14 @@
(define (rectify-let-values-step)
(let* ([source-expr (mark-source (car mark-list))])
(apply let-style-abstraction
(z:letrec-values-form? source-expr)
(map (lambda (accessor) (accessor source-expr))
(cond [(z:let-values-form? source-expr)
(list z:let-values-form-vars
z:let-values-form-body)]
[(z:letrec-values-form? source-expr)
(list z:letrec-values-form-vars
z:let-values-form-body)])))))
z:letrec-values-form-body)])))))
; (define (confusable-value? val)

105
collects/stepper/sharedr.ss
View File

@ -24,68 +24,61 @@
; the closure record is placed in the closure table
(define-struct closure-record (name mark constructor?))
; bogus-varref is used so that we can create legal zodiac varrefs for temporary variables
(define (create-bogus-bound-varref name binding)
(z:make-bound-varref #f #f #f #f name binding))
(define (create-bogus-top-level-varref name)
(z:make-top-level-varref #f #f #f #f name))
; gensyms needed by many modules:
; no-sexp is used to indicate no sexpression for display.
; e.g., on an error message, there's no sexp.
(define no-sexp (gensym "no-sexp-"))
; *unevaluated* is the value assigned to temps before they are evaluated.
(define *unevaluated* (gensym "unevaluated-"))
; if-temp : uninterned-symbol
(define if-temp (gensym "if-temp-"))
; struct-flag : uninterned symbol
(define struct-flag (gensym "struct-flag-"))
; bogus-binding is used so that we can create legal zodiac bindings for temporary variables
; highlight-placeholder : uninterned symbol
(define highlight-placeholder (gensym "highlight-placeholder"))
(define (create-bogus-binding name)
(let* ([gensymed-name (gensym name)]
[binding (z:make-lexical-binding #f #f #f (z:make-empty-back-box)
gensymed-name name)])
(set-new-binding-name! binding gensymed-name)
binding))
; make-gensym-source creates a pool of gensyms, indexed by arbitrary keys. These gensyms
; not eq? to any other symbols, but a client can always get the same symbol by
; invoking the resulting procedure with the same key (numbers work well). make-gensym-source
; also takes a string which will be part of the printed representation of the symbol;
; this makes debugging easier.
; make-gensym-source : (string -> (key -> symbol))
; make-binding-source creates a pool of bindings, indexed by arbitrary keys. These bindings
; not eq? to any other bindings, but a client can always get the same binding by
; invoking the resulting procedure with the same key (numbers work well). make-binding-source
; also takes a string which will be part of the printed representation of the binding's
; name; this makes debugging easier.
; make-gensym-source : (string -> (key -> binding))
(define (make-gensym-source id-string)
(define (make-binding-source id-string)
(let ([assoc-table (make-hash-table-weak)])
(lambda (key)
(let ([maybe-fetch (hash-table-get assoc-table key (lambda () #f))])
(or maybe-fetch
(begin
(let ([new-sym (gensym (string-append id-string (format "~a" key) "-"))])
(hash-table-put! assoc-table key new-sym)
new-sym)))))))
(let* ([new-binding (create-bogus-binding
(string-append id-string (format "~a" key) "-"))])
(hash-table-put! assoc-table key new-binding)
new-binding)))))))
; get-arg-varref maintains a list of gensyms associated with the non-negative
; get-binding-name extracts the S-expression name for a binding. Zodiac
; creates a unique, gensym'd symbol for each binding, but the name is
; unreadable. Here, we create a new gensym, but the name of the generated
; symbol prints in the same way as the original symbol.
(define (get-binding-name binding)
(let ([name (lookup-new-binding-name binding)])
(or name
(let* ([orig-name (z:binding-orig-name binding)]
[name (string->uninterned-symbol (symbol->string orig-name))])
(set-new-binding-name! binding name)
name))))
(define-values (lookup-new-binding-name set-new-binding-name!)
(let-values ([(getter setter) (z:register-client 'new-name (lambda () #f))])
(values
(lambda (parsed) (getter (z:parsed-back parsed)))
(lambda (parsed n) (setter (z:parsed-back parsed) n)))))
; get-arg-binding maintains a list of bindings associated with the non-negative
; integers. These symbols are used in the elaboration of applications; the nth
; in the application is evaluated and stored in a variable whose name is the nth
; gensym supplied by get-arg-symbol.
(define get-arg-varref
(let ([gensym-source (make-gensym-source "arg")])
(lambda (arg-num)
(create-bogus-bound-varref (gensym-source arg-num) #f))))
(define get-arg-binding
(make-binding-source "arg"))
; top-level-exp-gensym-source hands out gensyms for the expressions which are not top-level
; defines. these expressions' results are bound to variables named by these gensyms. Note that
; this implementation depends on putting exprs in hash tables and thus on non-copying
; garbage collection.
(define top-level-exp-gensym-source
(make-gensym-source "top-level-exp"))
; test cases: (returns #t on success)
#| (let ([arg3 (get-arg-symbol 3)]
[arg2 (get-arg-symbol 2)]
@ -99,6 +92,24 @@
(not (eq? arg1 arg2p))))
|#
; gensyms needed by many modules:
; no-sexp is used to indicate no sexpression for display.
; e.g., on an error message, there's no sexp.
(define no-sexp (gensym "no-sexp-"))
; *unevaluated* is the value assigned to temps before they are evaluated.
(define *unevaluated* (gensym "unevaluated-"))
; if-temp : uninterned-symbol
(define if-temp (create-bogus-binding "if-temp-"))
; struct-flag : uninterned symbol
(define struct-flag (gensym "struct-flag-"))
; highlight-placeholder : uninterned symbol
(define highlight-placeholder (gensym "highlight-placeholder"))
; list-partition takes a list and a number, and returns two lists; the first one contains the
; first n elements of the list, and the second contains the remainder. If n is greater than
; the length of the list, the exn:application:mismatch exception is raised.

19
collects/stepper/sig.ss
View File

@ -1,9 +1,5 @@
(define-signature stepper:cogen-utils^
(get-binding-name
lookup-new-binding-name
set-new-binding-name!
check-for-keyword
(check-for-keyword
check-for-syntax-or-macro-keyword
the-undefined-value
@ -43,10 +39,10 @@
mark-bindings
mark-label
mark-binding-value
mark-binding-varref
mark-binding-binding
expose-mark
display-mark
lookup-var-binding))
lookup-binding))
(define-signature stepper:client-procs^
(read-getter
@ -73,18 +69,19 @@
(struct before-error-result (finished-exprs exp redex err-msg))
(struct error-result (finished-exprs err-msg))
(struct finished-result (finished-exprs))
get-binding-name
;lookup-new-binding-name
;set-new-binding-name!
list-take
list-partition
(struct closure-record (name mark constructor?))
create-bogus-bound-varref
create-bogus-top-level-varref
;create-bogus-binding
*unevaluated*
no-sexp
if-temp
struct-flag
highlight-placeholder
get-arg-varref
top-level-exp-gensym-source
get-arg-binding
expr-read
set-expr-read!
flatten-take

22
collects/stepper/utils.ss
View File

@ -3,25 +3,6 @@
[e : zodiac:interface^])
; get-binding-name extracts the S-expression name for a binding. Zodiac
; creates a unique, gensym'd symbol for each binding, but the name is
; unreadable. Here, we create a new gensym, but the name of the generated
; symbol prints in the same way as the original symbol.
(define (get-binding-name binding)
(let ([name (lookup-new-binding-name binding)])
(or name
(let* ([orig-name (z:binding-orig-name binding)]
[name (string->uninterned-symbol (symbol->string orig-name))])
(set-new-binding-name! binding name)
name))))
(define-values (lookup-new-binding-name set-new-binding-name!)
(let-values ([(getter setter) (z:register-client 'new-name (lambda () #f))])
(values
(lambda (parsed) (getter (z:parsed-back parsed)))
(lambda (parsed n) (setter (z:parsed-back parsed) n)))))
; check whether the supplied id is a keyword. if the id is a syntax or
; macro keyword, issue an error. If disallow-procedures? is true, then
; we issue an error for _any_ use of a keyword. These procedures are used
@ -45,7 +26,8 @@
(let ([gdv (global-defined-value real-id)])
(or (syntax? gdv)
(macro? gdv)))))
(e:static-error id "keyword: invalid use of keyword ~s" real-id))))))
(e:static-error "keyword" 'term:keyword-out-of-context
id "invalid use of keyword ~s" real-id))))))
(define check-for-keyword (check-for-keyword/both #t))
(define check-for-syntax-or-macro-keyword (check-for-keyword/both #f))

54
collects/tests/drscheme/repl-test.ss
View File

@ -12,7 +12,7 @@
"syntax error: missing close paren"
(vector 0 1)
"read: expected a ')'; started at position 1 in "
"read: expected a ')'; started at position 1, line 1 in "
"read: expected a ')'; started at position 1 in "
#t
#f)
(make-test "."
@ -21,7 +21,7 @@
"syntax error: can't use `.' outside list"
(vector 0 1)
"read: illegal use of \".\" at position 1 in "
"read: illegal use of \".\" at position 1, line 1 in "
"read: illegal use of \".\" at position 1 in "
#t
#f)
(make-test "(lambda ())"
@ -136,7 +136,7 @@
(format "1~n2~nsyntax error: missing close paren")
(vector 4 5)
(format "1~n2~nread: expected a ')'; started at position 5 in ")
(format "read: expected a ')'; started at position 5, line 1 in ")
(format "read: expected a ')'; started at position 5 in ")
#t
#f)
(make-test "1 2 . 3 4"
@ -145,7 +145,7 @@
(format "1~n2~nsyntax error: can't use `.' outside list")
(vector 4 5)
(format "1~n2~nread: illegal use of \".\" at position 5 in ")
(format "read: illegal use of \".\" at position 5, line 1 in ")
(format "read: illegal use of \".\" at position 5 in ")
#t
#f)
(make-test "1 2 x 3 4"
@ -473,18 +473,38 @@
(printf "FAILED: repl in edit-sequence")
(escape)))))))))
(define run-test-in-language-level
(lambda (raw?)
(let ([level (if raw? "Graphical without Debugging (MrEd)" "Graphical (MrEd)")])
(printf "running ~a tests~n" level)
(set-language-level! level)
(fw:test:new-window definitions-canvas)
(fw:test:menu-select "Edit" "Select All")
(fw:test:menu-select "Edit" (if (eq? (system-type) 'macos)
"Clear"
"Delete"))
(do-execute drscheme-frame)
(let/ec escape (for-each (run-test (get-int-pos) escape raw?) test-data)))))
(define (run-test-in-language-level raw?)
(let ([level (if raw? "Graphical without Debugging (MrEd)" "Graphical (MrEd)")]
[drs (wait-for-drscheme-frame)])
(printf "running ~a tests~n" level)
(set-language-level! level)
(fw:test:new-window definitions-canvas)
(clear-definitions drscheme-frame)
(do-execute drscheme-frame)
(let/ec escape (for-each (run-test (get-int-pos) escape raw?) test-data))))
(define (kill-tests)
(let ([drs (wait-for-drscheme-frame)])
(clear-definitions drs)
(do-execute drs)
(fw:test:menu-select "Scheme" "Kill")
(let ([win (wait-for-new-frame drs)])
(fw:test:button-push "Ok")
(let ([drs2 (wait-for-new-frame win)])
(unless (eq? drs2 drs)
(error 'kill-tests "expected original drscheme frame to come back to the front"))))
(type-in-definitions drs "(kill-thread (current-thread))")
(do-execute drs #f)
(let ([win (wait-for-new-frame drs)])
(fw:test:button-push "Ok")
(let ([drs2 (wait-for-new-frame win)])
(unless (eq? drs2 drs)
(error 'kill-tests "expected original drscheme frame to come back to the front"))))))
(run-test-in-language-level #f)
(run-test-in-language-level #t)
(run-test-in-language-level #f)
(kill-tests)

20
collects/tests/mzscheme/unit.ss
View File

@ -411,6 +411,26 @@
(define define-values 10)
define-values))))
; Check set! of shadowed variable:
(test #t unit? (unit
(import x)
(export)
(let ([x 10])
(set! x 5))))
(test #t unit? (unit
(import x)
(export)
(class object% ()
(public
[x 10])
(sequence
(set! x 5)))))
(syntax-test '(let ([x 10])
(unit
(import x)
(export)
(set! x 5))))
; Especially for zodiac:
(test '(b c 10 b a (c a b) (c b a) (c . c) (a) #t
(nested-b a b c) (a 2 b) (10 b c) (cl-unit-a 12 c))

4
collects/userspce/info.ss
View File

@ -14,7 +14,9 @@
(require-library "params.ss" "userspce")
(require-library "sig.ss" "userspce"))]
[(compile-omit-files) (list "sig.ss" "errors.ss" "params.ss" "ricedefs.ss"
"launcher-bootstrap.ss")]
"launcher-bootstrap.ss"
"launcher-bootstrap-mred.ss"
"launcher-bootstrap-mzscheme.ss")]
[(compile-elaboration-zos) (list "sig.ss")]
[else (failure)]))])
userspace-info)

5
collects/userspce/init-namespacer.ss
View File

@ -23,7 +23,8 @@
(define (build-gdvs exploded)
(let ([flattened (exploded->flattened exploded)])
(map
(lambda (x) `(global-defined-value ',x ,x))
(lambda (x)
`(global-defined-value ',x ,x))
flattened)))
(define core-flat@ (require-library-unit/sig "coreflatr.ss"))
@ -148,7 +149,7 @@
#t
#f))
(define namespace-thunk void)
(define namespace-thunk (build-namespace-thunk null))
(define init-namespace (lambda () (namespace-thunk)))
(define (teachpack-changed v)

12
collects/userspce/init-paramr.ss
View File

@ -533,7 +533,17 @@
(recur)])))])
(apply values (process-file/zodiac filename process-sexps #t)))]
[else
(primitive-load filename)])))
(call-with-input-file filename
(lambda (port)
(let loop ([last-vals (list (void))])
(let ([r (read port)])
(if (eof-object? r)
(apply values last-vals)
(call-with-values
(lambda () (eval r))
(lambda x
(apply (intermediate-values-during-load) x)
(loop x))))))))])))
;; drscheme-eval : sexp ->* TST
(define (drscheme-eval-handler sexp)

22
collects/userspce/interface.ss
View File

@ -27,24 +27,16 @@
(with-continuation-mark
aries:w-c-m-key
(aries:make-zodiac-mark object)
(let ([kwd? (init-substring? "kwd:" (symbol->string link-tag))])
(case zodiac-phase
[(expander)
(if kwd?
(make-exn:zodiac-syntax string
(current-continuation-marks)
#f
link-tag)
(make-exn:syntax string
(current-continuation-marks)
#f))]
(make-exn:zodiac-syntax string
(current-continuation-marks)
#f
link-tag)]
[(reader)
(if kwd?
(make-exn:zodiac-read
string (current-continuation-marks) #f link-tag)
(make-exn:read
string (current-continuation-marks) #f))]
[else (make-exn:user string (current-continuation-marks))])))))
(make-exn:zodiac-read
string (current-continuation-marks) #f link-tag)]
[else (make-exn:user string (current-continuation-marks))]))))
;; report-error : symbol -> (+ zodiac:zodiac zodiac:eof zodiac:period) string (listof TST) ->* ALPHA
;; escapes

60
collects/userspce/launcher-bootstrap-mred.ss Normal file
View File

@ -0,0 +1,60 @@
(let* ([main-unit
(let ([settings settings]
[teachpacks teachpacks]
[filename filename]
[mred@ mred@])
(unit/sig drscheme-jr:settings^
(import [prims : prims^]
[basis : plt:basis^]
[mzlib : mzlib:core^]
mred^)
(basis:teachpack-changed teachpacks)
(define show-banner? #f)
(define repl? #f)
(define user-eventspace #f)
(define (run-in-new-user-thread thunk)
(set! user-eventspace (make-eventspace))
(parameterize ([current-eventspace user-eventspace])
(let ([thread #f]
[sema (make-semaphore 0)])
(queue-callback (lambda ()
(set! thread (current-thread))
(semaphore-post sema)))
(semaphore-wait sema)
(queue-callback
(lambda ()
(thunk)))
thread)))
(define (number-open-windows)
(parameterize ([current-eventspace user-eventspace])
(length (get-top-level-windows))))
(define (load-and-repl-done)
(if (= 0 (number-open-windows))
(exit)
(thread
(rec f
(lambda ()
(sleep 1/2)
(if (= 0 (number-open-windows))
(exit)
(f)))))))
(define (initialize-userspace)
;; add mred to the namespace
(global-define-values/invoke-unit/sig mred^ mred@))
(define setting (apply basis:make-setting (cdr (vector->list settings))))
(define startup-file filename)))])
(compound-unit/sig
(import [prims : prims^]
[basis : plt:basis^]
[mzlib : mzlib:core^])
(link [mred : mred^ (mred@)]
[main : drscheme-jr:settings^ (main-unit prims basis mzlib mred)])
(export (open main))))

22
collects/userspce/launcher-bootstrap-mzscheme.ss Normal file
View File

@ -0,0 +1,22 @@
(let ([settings settings]
[teachpacks teachpacks]
[filename filename])
(unit/sig drscheme-jr:settings^
(import [prims : prims^]
[basis : plt:basis^]
[mzlib : mzlib:core^])
(basis:teachpack-changed teachpacks)
(define show-banner? #f)
(define repl? #f)
(define (run-in-new-user-thread thunk)
(thread thunk))
(define (load-and-repl-done)
(exit))
(define (initialize-userspace) (void))
(define setting (apply basis:make-setting (cdr (vector->list settings))))
(define startup-file filename)))

50
collects/userspce/launcher-bootstrap.ss
View File

@ -2,51 +2,9 @@
;; a text when the file begins with WXME so that mred saved
;; files still load properly.
(require-library "errortrace.ss" "errortrace")
(require-library "core.ss" "drscheme-jr")
(define main-unit
(let ([settings settings]
[teachpacks teachpacks]
[filename filename]
[mred@ mred@])
(unit/sig drscheme-jr:settings^
(import [prims : prims^]
[basis : plt:basis^]
[mzlib : mzlib:core^]
mred^)
(basis:teachpack-changed teachpacks)
(define show-banner? #f)
(define repl? #f)
(define (run-in-new-user-thread thunk)
(parameterize ([current-eventspace (make-eventspace)])
(let ([thread #f]
[sema (make-semaphore 0)])
(queue-callback (lambda ()
(set! thread (current-thread))
(semaphore-post sema)))
(semaphore-wait sema)
(queue-callback
thunk)
thread)))
(define (initialize-userspace)
;; add mred to the namespace
(global-define-values/invoke-unit/sig mred^ mred@))
(define setting (apply basis:make-setting (cdr (vector->list settings))))
(define startup-file filename))))
(define go
(make-go
(compound-unit/sig
(import [prims : prims^]
[basis : plt:basis^]
[mzlib : mzlib:core^])
(link [mred : mred^ (mred@)]
[main : drscheme-jr:settings^ (main-unit prims basis mzlib mred)])
(export (open main)))))
(go)
((make-go
(if (defined? 'mred@)
(load-relative "launcher-bootstrap-mred.ss")
(load-relative "launcher-bootstrap-mzscheme.ss"))))

452
collects/zodiac/doc.txt
View File

@ -1,3 +1,4 @@
(#|
_Zodiac_
--------
@ -256,7 +257,14 @@ contains a manufactured `if' expression.
Error Tags
==========
These are the tags generated by Zodiac to report static-error's.
These are the tags generated by Zodiac to report static-error's.
Using the scheme primitive `read' on this file produces a list of lists of
symbols. The symbols are the kwd: and term: tags for the language
levels. There are nine elements in the outer list. The first five list the
common, beginning, intermediate, advanced, and full scheme language levels
kwd: tags, respectively, and the last four list the beginning intermediate,
advanced, and full scheme langauge levels term: tags.
kwd Tags
--------
@ -612,115 +620,129 @@ Tags and Language Levels
This documents the language level at which each tag can appear.
Misc Tags
----------
These tags can appear at any language level:
|#(
read:syntax-error
scan:syntax-error
#|
kwd: Tags
---------
If these are inserted at some language level, they are automatically
present at all subsequent language levels.
common:
common: |#
define-macro
let-macro
kwd:define-macro
kwd:let-macro
beginner:
)#| beginner: |#(
case-lambda
lambda
if
quote
define
define-values
struct
define-struct
or
nor
and
nand
cond
require-library
require-relative-library
reference-file
polymorphic
mrspidey:control
:
type:
define-type
define-constructor
kwd:case-lambda
kwd:lambda
kwd:if
kwd:quote
kwd:define
kwd:define-values
kwd:struct
kwd:define-struct
kwd:or
kwd:nor
kwd:and
kwd:nand
kwd:cond
kwd:require-library
kwd:require-relative-library
kwd:reference-file
kwd:polymorphic
kwd:mrspidey:control
kwd::
kwd:type:
kwd:define-type
kwd:define-constructor
intermediate:
local
define-structure
let-struct
let
let*
time
let-values
let*-values
letrec-values
letrec
unquote
unquote-splicing
quasiquote
)#| intermediate: |#(
advanced:
kwd:local
kwd:define-structure
kwd:let-struct
kwd:let
kwd:let*
kwd:time
kwd:let-values
kwd:let*-values
kwd:letrec-values
kwd:letrec
kwd:unquote
kwd:unquote-splicing
kwd:quasiquote
begin
begin0
set!
set!-values
delay
recur
rec
case
evcase
when
unless
let/cc
let/ec
do
fluid-let
parameterize
with-handlers
scheme:
)#| advanced: |#(
with-continuation-mark
unit
compound-unit
invoke-unit
signature-struct
signature->symbols
define-signature
let-signature
unit-include
unit/sig
compound-unit
compound-unit/sig
invoke-unit/sig
unit->unit/sig
global-define-values
require-library-unit
require-unit
require-unit/sig
require-library-unit
require-library-unit/sig
require-relative-library-unit
require-relative-library-unit/sig
interface
class-private
class-inherit
class-rename
class-sequence
class
class*
class*/names
ivar
send
send*
make-generic
kwd:begin
kwd:begin0
kwd:set!
kwd:set!-values
kwd:delay
kwd:recur
kwd:rec
kwd:case
kwd:evcase
kwd:when
kwd:unless
kwd:let/cc
kwd:let/ec
kwd:do
kwd:fluid-let
kwd:parameterize
kwd:with-handlers
)#| full scheme: |#(
kwd:with-continuation-mark
kwd:unit
kwd:compound-unit
kwd:invoke-unit
kwd:signature-struct
kwd:signature->symbols
kwd:define-signature
kwd:let-signature
kwd:unit-include
kwd:unit/sig
kwd:compound-unit
kwd:compound-unit/sig
kwd:invoke-unit/sig
kwd:unit->unit/sig
kwd:global-define-values
kwd:require-library-unit
kwd:require-unit
kwd:require-unit/sig
kwd:require-library-unit
kwd:require-library-unit/sig
kwd:require-relative-library-unit
kwd:require-relative-library-unit/sig
kwd:interface
kwd:class-private
kwd:class-inherit
kwd:class-rename
kwd:class-sequence
kwd:class
kwd:class*
kwd:class*/names
kwd:ivar
kwd:send
kwd:send*
kwd:make-generic
)#|
term: Tags
---------
@ -740,129 +762,133 @@ do not occur (fallbacks that are never fallen back to):
invalid-pos-list
invalid-pos-ilist
beginner:
internal-def-not-foll-by-expr
duplicate-interal-def
case/lambda-only-in-def
define-internal-invalid-posn
define-illegal-implicit-begin
if-must-have-else
quote-not-on-symbol
cond-else-only-in-last
cond-clause-not-in-q/a-fmt
cond-=>-not-foll-by-1-rcvr
keyword-out-of-context
empty-combination
app-first-term-not-var
app-first-term-lambda-bound
expected-an-identifier
repeated-identifier
invalid-identifier
proc-arity->=-1
set!-no-mutate-lambda-bound
def-not-at-top-level
cannot-bind-kwd
macro-error
beginner: |#(
intermediate:
term:internal-def-not-foll-by-expr ;; *
term:duplicate-interal-def ;; *
term:case/lambda-only-in-def
term:define-internal-invalid-posn ;; *
term:define-illegal-implicit-begin
term:if-must-have-else
term:quote-not-on-symbol
term:cond-else-only-in-last
term:cond-clause-not-in-q/a-fmt
term:cond-=>-not-foll-by-1-rcvr
term:keyword-out-of-context
term:empty-combination
term:app-first-term-not-var
term:app-first-term-lambda-bound
term:expected-an-identifier
term:repeated-identifier
term:invalid-identifier
term:proc-arity->=-1
term:set!-no-mutate-lambda-bound ;; *
term:def-not-at-top-level
term:cannot-bind-kwd
term:macro-error
internal-def-not-foll-by-expr
duplicate-interal-def
define-internal-invalid-posn
define-illegal-implicit-begin
if-must-have-else
cond-else-only-in-last
cond-clause-not-in-q/a-fmt
cond-=>-not-foll-by-1-rcvr
keyword-out-of-context
empty-combination
app-first-term-not-var
app-first-term-lambda-bound
expected-an-identifier
repeated-identifier
invalid-identifier
proc-arity->=-1
set!-no-mutate-lambda-bound
def-not-at-top-level
cannot-bind-kwd
macro-error
)#| intermediate: |#(
advanced:
term:internal-def-not-foll-by-expr ;; *
term:duplicate-interal-def ;; *
term:define-internal-invalid-posn ;; *
term:define-illegal-implicit-begin
term:if-must-have-else
term:cond-else-only-in-last
term:cond-clause-not-in-q/a-fmt
term:cond-=>-not-foll-by-1-rcvr
term:keyword-out-of-context
term:empty-combination
term:app-first-term-not-var
term:app-first-term-lambda-bound
term:expected-an-identifier
term:repeated-identifier
term:invalid-identifier
term:proc-arity->=-1
term:set!-no-mutate-lambda-bound ;; *
term:def-not-at-top-level
term:cannot-bind-kwd
term:macro-error
internal-def-not-foll-by-expr
duplicate-interal-def
define-internal-invalid-posn
struct-not-id
super-struct-invalid
super-struct-not-id
cond-else-only-in-last
cond-clause-not-in-q/a-fmt
cond-=>-not-foll-by-1-rcvr
keyword-out-of-context
empty-combination
expected-an-identifier
repeated-identifier
invalid-identifier
def-not-at-top-level
cannot-bind-kwd
macro-error
scheme:
)#| advanced: |#(
internal-def-not-foll-by-expr
duplicate-interal-def
define-internal-invalid-posn
struct-not-id
super-struct-invalid
super-struct-not-id
cond-else-only-in-last
cond-=>-not-foll-by-1-rcvr
keyword-out-of-context
expected-an-identifier
repeated-identifier
invalid-identifier
signature-out-of-context
unit-double-export
duplicate-signature
unbound-sig-name
signature-no-sub-unit
signature-no-var
unit-link-unbound-tag
unit-link-duplicate-tag
unit-link-self-import-tag
unit-link-path-malformed
unit-duplicate-import
unit-duplicate-export
unit-import-exported
unit-defined-imported
unit-redefined-import
unit-export-not-defined
unit-duplicate-definition
signature-not-matching
signature-struct-illegal-omit-name
unit-export
c-unit-linkage
c-unit-export
c-unit-not-import
c-unit-invalid-tag
signature-invalid-struct-omit
signature-malformed-omit-clause
signature-malformed-open-clause
signature-malformed-unit-clause
signature-ambiguous-:
no-unit-exports
no-set!-inherited/renamed
no-set!-imported
unit-unbound-id
arglist-after-init-value-spec
arglist-after-catch-all-arg
arglist-invalid-init-value
arglist-invalid-init-var-decl
arglist-last-arg-no-init
arglist-invalid-syntax
invalid-ivar-decl
invalid-ivar-clause
invalid-intl-defn-posn
cannot-bind-kwd
macro-error
term:internal-def-not-foll-by-expr ;; *
term:duplicate-interal-def ;; *
term:define-internal-invalid-posn ;; *
term:struct-not-id
term:super-struct-invalid
term:super-struct-not-id
term:cond-else-only-in-last
term:cond-clause-not-in-q/a-fmt
term:cond-=>-not-foll-by-1-rcvr
term:keyword-out-of-context
term:empty-combination
term:expected-an-identifier
term:repeated-identifier
term:invalid-identifier
term:def-not-at-top-level
term:cannot-bind-kwd
term:macro-error
)#| full scheme: |#(
term:internal-def-not-foll-by-expr
term:duplicate-interal-def
term:define-internal-invalid-posn
term:struct-not-id
term:super-struct-invalid
term:super-struct-not-id
term:cond-else-only-in-last
term:cond-=>-not-foll-by-1-rcvr
term:keyword-out-of-context
term:expected-an-identifier
term:repeated-identifier
term:invalid-identifier
term:signature-out-of-context
term:unit-double-export
term:duplicate-signature
term:unbound-sig-name
term:signature-no-sub-unit
term:signature-no-var
term:unit-link-unbound-tag
term:unit-link-duplicate-tag
term:unit-link-self-import-tag
term:unit-link-path-malformed
term:unit-duplicate-import
term:unit-duplicate-export
term:unit-import-exported
term:unit-defined-imported
term:unit-redefined-import
term:unit-export-not-defined
term:unit-duplicate-definition
term:signature-not-matching
term:signature-struct-illegal-omit-name
term:unit-export
term:c-unit-linkage
term:c-unit-export
term:c-unit-not-import
term:c-unit-invalid-tag
term:signature-invalid-struct-omit
term:signature-malformed-omit-clause
term:signature-malformed-open-clause
term:signature-malformed-unit-clause
term:signature-ambiguous-:
term:no-unit-exports
term:no-set!-inherited/renamed
term:no-set!-imported
term:unit-unbound-id
term:arglist-after-init-value-spec
term:arglist-after-catch-all-arg
term:arglist-invalid-init-value
term:arglist-invalid-init-var-decl
term:arglist-last-arg-no-init
term:arglist-invalid-syntax
term:invalid-ivar-decl
term:invalid-ivar-clause
term:invalid-intl-defn-posn
term:cannot-bind-kwd
term:macro-error
))

19
collects/zodiac/invoke.ss
View File

@ -1,4 +1,4 @@
; $Id: invoke.ss,v 1.41 1999/06/01 16:55:18 mflatt Exp $
; $Id: invoke.ss,v 1.42 2000/05/28 03:47:30 shriram Exp $
(begin-elaboration-time
(require-library "cores.ss"))
@ -10,18 +10,19 @@
(define zodiac:default-interface@
(unit/sig zodiac:interface^
(import)
(define default-error-handler
(lambda (keyword)
(define internal-error
(lambda (where fmt-spec . args)
(printf "Error at: ~s~n" where)
(apply error keyword fmt-spec args))))
(define internal-error
(default-error-handler 'internal-error))
(define static-error
(default-error-handler 'syntax-error))))
(apply error 'internal-error fmt-spec args)))
(define (static-error link-text link-tag where fmt-spec . args)
(printf "Error tag: ~s~n" link-tag)
(printf "Error at: ~s~n" where)
(apply error 'static-error
(string-append link-text ": " fmt-spec)
args))))
(define zodiac:system@
(require-library-unit/sig "link.ss" "zodiac"))
(require-library-unit/sig "link2.ss" "zodiac"))
(begin-elaboration-time
(require-library "invoke.ss"))

5
collects/zodiac/scm-hanc.ss
View File

@ -1,4 +1,4 @@
; $Id: scm-hanc.ss,v 1.64 1999/05/23 17:31:24 mflatt Exp $
; $Id: scm-hanc.ss,v 1.65 2000/05/28 03:47:31 shriram Exp $
(define-struct signature-element (source))
(define-struct (name-element struct:signature-element) (name))
@ -37,7 +37,8 @@
(signs sign:names))
(unless (null? in)
(if (memq (car signs) (cdr signs))
(static-error 'term:unit-double-export (car in)
(static-error
"unit" 'term:unit-double-export (car in)
"name \"~s\" is exported twice" (car signs))
(loop (cdr in) (cdr signs))))))
(let ((in (car in:all)) (sign (car sign:all)))

40
collects/zodiac/scm-main.ss
View File

@ -1,4 +1,4 @@
; $Id: scm-main.ss,v 1.205 2000/04/30 22:31:01 clements Exp $
; $Id: scm-main.ss,v 1.208 2000/05/31 18:55:21 shriram Exp $
(unit/sig zodiac:scheme-main^
(import zodiac:misc^ zodiac:structures^
@ -430,8 +430,8 @@
vars)
(make-internal-definition vars val))))
(else
(static-error expr
"internal definition" 'kwd:define
(static-error
"internal definition" 'kwd:define expr
"malformed definition"))))))
(add-primitivized-micro-form 'begin internal-define-vocab-delta
@ -1065,24 +1065,6 @@
(add-primitivized-micro-form 'define-struct full-local-extract-vocab
(make-ds-micro internal-handler #t)))))
(let* ((kwd '())
(in-pattern '(_ (type-spec fields ...)))
(out-pattern '(define-struct type-spec (fields ...)))
(m&e (pat:make-match&env in-pattern kwd)))
(add-primitivized-macro-form 'define-structure intermediate-vocabulary
(lambda (expr env)
(or (pat:match-and-rewrite expr m&e out-pattern kwd env)
(static-error
"define-structure" 'kwd:define-structure
expr "malformed definition"))))
(let ([int-ds-macro (lambda (expr env)
(or (pat:match-and-rewrite expr m&e out-pattern kwd env)
(static-error
"define-structure" 'kwd:define-structure
expr "malformed definition")))])
(add-primitivized-macro-form 'define-structure nobegin-local-extract-vocab int-ds-macro)
(add-primitivized-macro-form 'define-structure full-local-extract-vocab int-ds-macro)))
(define (make-let-struct-micro begin? allow-supertype?)
(let* ((kwd '())
(in-pattern `(_ type-spec (fields ...) ,@(get-expr-pattern begin?)))
@ -1979,9 +1961,19 @@
(let* ((params (pat:pexpand '(param ...) p-env kwd))
(vals (pat:pexpand '(value ...) p-env kwd))
(body (pat:pexpand body p-env kwd))
(pzs (map generate-name params))
(saves (map generate-name params))
(swap (generate-name (structurize-syntax 'swap expr '(-1)))))
;; The following two have this strange code
;; because generate-name expects a z:symbol,
;; but the param can be an arbitrary expression,
;; not just the name of a parameter
(pzs (map generate-name
(map (lambda (param)
(structurize-syntax 'pz param '(-1)))
params)))
(saves (map generate-name
(map (lambda (param)
(structurize-syntax 'save param '(-1)))
params)))
(swap (generate-name (structurize-syntax 'swap expr '(-1)))))
(expand-expr
(structurize-syntax
(if (null? params)

13
notes/drscheme/HISTORY
View File

@ -11,6 +11,17 @@ Version 102:
MINOR CHANGES AND BUG FIXES
- added parents for these dialogs:
Keybindings
Choose Language...
Add Teachpack...
Create Launcher -> "you must save before creating a launcher" message box
"The thread has been killed" message box
"Uncaught Error"
Break, Break -> "do you want to kill it?" message box
Click unbound id in DrScheme -> "nothing found for <id>" message box
- Only the platform-specific dialogs are used in drscheme now, on
all platforms. The preference has been removed from the dialog.
@ -21,8 +32,8 @@ Version 102:
1461: Kill menu problems
1460: Help Desk has empty preferences
1459: search menu items work on empty search text
1455: project windows never leave `Windows' menu
1456: teachpacks don't add
1455: project windows never leave `Windows' menu
1428: setup -c deletes files for all platforms
1424: long (list ...) displays don't display correctly
1405: memory usage box should be read only

1
notes/mysterx/HISTORY
View File

@ -35,6 +35,7 @@ fixed GC-related problems with COM
event handlers
fixed error text formatting bug when
COM methods returned an error code
improved Makefiles
DHTML test code added,
plt/tests/mysterx/dhtmltests.ss

106
src/README
View File

@ -40,8 +40,8 @@ below.
Compiling for MacOS
========================================================================
Unpack the Compactor archive plt:src:cw.cpt to plt:src:cw and then
see `ABOUT MzScheme' and `ABOUT MrEd' in that folder.
Unpack the Stuffit archive plt:src:cw.sit.hqz to plt:src:cw, and then
see `README' in that folder.
========================================================================
Compiling for Unix (including Linux), Cygwin, or BeOS
@ -131,3 +131,105 @@ see `ABOUT MzScheme' and `ABOUT MrEd' in that folder.
the .zo files, too, but add -n to the end of the command to skip
the .zo-compiling step. Afterwards, `plt/Setup PLT.exe' and
`plt/mzc.exe' work.
========================================================================
Compiling the OSKit-based kernel
========================================================================
To build the OSKit-based MzScheme kernel, run the configure script
with the --enable-oskit or --enable-smalloskit flag. The result of
compiling will be `mzscheme.multiboot' in the `mzscheme' build
directory. It is a kernel in multiboot format.
Before building the MzScheme kernel, you must first install OSKit,
which is available from the Flux Research Group at Utah:
http://www.cs.utah.edu/projects/flux/oskit/
By default, configure assumes that OSKit is installed in
/usr/local. To specify a different location for OSKit, define the
OSKHOME environment variable.
For simplicity, the MzScheme kernel uses SGC rather than Boehm's
conservative garbage collector.
The --enable-smalloskit configuration produces a kernel without
networking or filesystem support. The kernel created by
--enable--oskit accepts filesystem and networking configuration
information on its multiboot command line via the --fs and --net
flags:
--fs <drive> <partition> : mounts the given partition as the root
directory. For example, to mount the seventh parition on main disk,
supply: --fs hda f. Many filesystem formats are supported,
including EXT2, MSDOS, and VFAT (all of the ones supported by
Linux; see OSKit for details). The standard kernel can only mount
one filesystem per run; hack main.c to get more.
--net <address> <netmask> <gateway> : initializes ethernet support
for MzScheme's TCP primitives. Example: --net 128.42.6.101
255.255.255.0 128.42.6.254. Many types of ethernet cards are
supported (the ones supported by FreeBSD; see OSKit for details).
Each of --fs and --net should be used once at most. The --fs and --net
flags must appear before any other command-line arguments, which are
handled by MzScheme in the usual way.
To access a filesystem or the network from non-multiboot kernels
(e.g., a LILO-compatible kernel), you must hardwire filesystem and
networking parameters in oskglue.inc when compiling the kernel; see
oskglue.inc for details (grep for `hardwire').
========================================================================
Additional Compilation Notes
========================================================================
Garbage Collector
-----------------
The conservative garbage collector distributed with MzScheme (in the
gc directory) has been modified slightly from Boehm's standard
distribution. Mostly, the change modify the way that object
finalization is handled.
Precise GC
----------
MzScheme and MrEd can be compiled to an experimental form that uses
precise garbage collection (as opposed to "conservation garbage
collection") on some Unix platforms, including Linux, FreeBSD, and
Solaris. The precisely-collected forms are called MzScheme2k and
MrEd2k, repsectively.
To build MzScheme2k and MrEd2k, run `gnumake 2k'. Building MzScheme2k
and MrEd2k first builds the normal MzScheme and MrEd executables, and
uses them to build the 2k versions.
Configuration Options
---------------------
By default, MzScheme is compiled:
* without image dumps (since the application will probably be linked
dynamically);
* without using any OS-specific threads; and
* without support for single-precision floating point numbers.
These options can be modified by setting flags in mzscheme/sconfig.h.
MrEd works only *without* OS-specific threads.
Modifying MzScheme
------------------
If you modify MzScheme and change any primitive syntax or the
collection of built-in identifers, be sure to turn off
USE_COMPILED_MACROS in schminc.h. Otherwise, MzScheme won't start.
See schminc.h for details.
Guile Compatibility Library
---------------------------
In the mzscheme/ directory, `make libguile' produces a libguile.a
library that implements the high-level guile interface. See
mzscheme/libguile/README.

9
src/mred/Make.env.in
View File

@ -51,13 +51,10 @@ LDLIBS = @X_PRE_LIBS@ -lXaw -lXmu -lXt -lX11 -lXext @X_EXTRA_LIBS@ @LIBS@
########################## Advanced #############################
# If you want to generate plt/src/wxxt/XWidget/xw*.c files from
# plt/src/wxxt/XWidget/*.w files, you must set WBUILD:
#WBUILD = /usr/local/bin/wbuild --no-init-file -i XWidgets
# -c XWidgets -d XWidgets -p . /usr/local/lib/wbuild.cfg
GCDIRECTORY = @GCDIR@
WBUILD = @WBUILD@
########################## Derived #############################
# Use _xt
@ -68,8 +65,6 @@ OBJSUFF = o
SRCSUFF = cc
GUI = -Dwx_xt
WBUILD = @WBUILD@
WXINC = $(PLTSRCDIR)/wxxt/src/AIAI-include -I$(PLTSRCDIR)/wxxt/src
WXLIB = $(PLTSRCDIR)/wxxt/lib/libwx$(GUISUFFIX).a
NOGCINC = -I$(WXINC) -I$(PLTSRCDIR)/mred/wxme/ -I$(PLTSRCDIR)/mzscheme/include/ $(COMPPATHS)

9
src/mred/mred.cxx
View File

@ -1809,16 +1809,17 @@ static void MrEdSchemeMessages(char *msg, ...)
#if WINDOW_STDIO
if (!msg) {
char *s;
long l;
long d, l;
s = va_arg(args, char*);
d = va_arg(args, long);
l = va_arg(args, long);
if (!ioFrame->beginEditSeq) {
ioFrame->media->BeginEditSequence();
ioFrame->beginEditSeq = 1;
}
ioFrame->media->Insert(l, s, ioFrame->endpos);
ioFrame->media->Insert(l, s + d, ioFrame->endpos);
ioFrame->endpos += l;
if (l != 1 || s[0] == '\n') {
@ -1862,7 +1863,7 @@ static void MrEdSchemeMessages(char *msg, ...)
static void MrEdSchemeMessagesOutput(char *s, long l)
{
MrEdSchemeMessages(NULL, s, l);
MrEdSchemeMessages(NULL, s, 0, l);
}
#endif
@ -1919,7 +1920,7 @@ static Scheme_Object *MrEdMakeStdIn(void)
static void stdout_write(char *s, long d, long l, Scheme_Output_Port*)
{
#if WINDOW_STDIO || WCONSOLE_STDIO
MrEdSchemeMessages(NULL, s, l);
MrEdSchemeMessages(NULL, s, d, l);
#else
static FILE *out = NULL;

6
src/mred/mredmsw.cxx
View File

@ -38,6 +38,8 @@ typedef struct LeaveEvent {
struct LeaveEvent *next;
} LeaveEvent;
# define WM_MRED_LEAVE (WM_USER + 0x111)
void MrEdInitFirstContext(MrEdContext *c)
{
}
@ -157,7 +159,7 @@ static BOOL CALLBACK CheckWindow(HWND wnd, LPARAM param)
if (info->remove) {
info->wnd = wnd;
info->c_return = c;
info->msg->message = WM_USER + 1;
info->msg->message = WM_MRED_LEAVE;
info->msg->lParam = (long)c->queued_leaves;
c->queued_leaves = c->queued_leaves->next;
}
@ -221,7 +223,7 @@ int MrEdGetNextEvent(int check_only, int current_only,
void MrEdDispatchEvent(MSG *msg)
{
if (msg->message == WM_USER + 1) {
if (msg->message == WM_MRED_LEAVE) {
/* Queued leave event */
LeaveEvent *e = (LeaveEvent *)msg->lParam;
wxDoLeaveEvent(e->wnd, e->x, e->y, e->flags);

2
src/mred/wrap/export.ss
View File

@ -63,6 +63,8 @@
register-collecting-blit
unregister-collecting-blit
bitmap-dc%
post-script-dc%
printer-dc%
current-text-keymap-initializer
sleep/yield
get-window-text-extent

2
src/mred/wrap/import.ss
View File

@ -35,6 +35,8 @@
register-collecting-blit
unregister-collecting-blit
bitmap-dc%
post-script-dc%
printer-dc%
shortcut-visible-in-label?
in-atomic-region
set-editor-snip-maker

53
src/mred/wrap/macros.ss
View File

@ -22,26 +22,47 @@
`(lambda (,x ,y ,z) (as-entry (lambda () (,f ,x ,y ,z)))))))
(define-macro entry-point-0-1
(lambda (f)
(let ([x (gensym)])
`(case-lambda
[() (as-entry ,f)]
[(,x) (as-entry (lambda () (,f ,x)))]))))
(lambda (l)
(let ([f (gensym)]
[x (gensym)])
`(let ([,f ,l])
(case-lambda
[() (as-entry ,f)]
[(,x) (as-entry (lambda () (,f ,x)))])))))
(define-macro entry-point-1-2
(lambda (f)
(let ([x (gensym)]
(lambda (l)
(let ([f (gensym)]
[x (gensym)]
[y (gensym)])
`(case-lambda
[(,x) (as-entry (lambda () (,f ,x)))]
[(,x ,y) (as-entry (lambda () (,f ,x ,y)))]))))
`(let ([,f ,l])
(case-lambda
[(,x) (as-entry (lambda () (,f ,x)))]
[(,x ,y) (as-entry (lambda () (,f ,x ,y)))])))))
(define-macro entry-point-1-2-3
(lambda (f)
(let ([x (gensym)]
(lambda (l)
(let ([f (gensym)]
[x (gensym)]
[y (gensym)]
[z (gensym)])
`(case-lambda
[(,x) (as-entry (lambda () (,f ,x)))]
[(,x ,y) (as-entry (lambda () (,f ,x ,y)))]
[(,x ,y ,z) (as-entry (lambda () (,f ,x ,y ,z)))]))))
`(let ([,f ,l])
(case-lambda
[(,x) (as-entry (lambda () (,f ,x)))]
[(,x ,y) (as-entry (lambda () (,f ,x ,y)))]
[(,x ,y ,z) (as-entry (lambda () (,f ,x ,y ,z)))])))))
(define-macro entry-point-0-1-2-3-4
(lambda (l)
(let ([f (gensym)]
[x (gensym)]
[y (gensym)]
[z (gensym)]
[w (gensym)])
`(let ([,f ,l])
(case-lambda
[() (as-entry (lambda () (,f)))]
[(,x) (as-entry (lambda () (,f ,x)))]
[(,x ,y) (as-entry (lambda () (,f ,x ,y)))]
[(,x ,y ,z) (as-entry (lambda () (,f ,x ,y ,z)))]
[(,x ,y ,z ,w) (as-entry (lambda () (,f ,x ,y ,z ,w)))])))))

44
src/mred/wrap/mred.ss
View File

@ -1661,7 +1661,8 @@
get-keymap get-style-list)
(rename [super-on-display-size on-display-size]
[super-get-view-size get-view-size]
[super-copy-self-to copy-self-to])
[super-copy-self-to copy-self-to]
[super-print print])
(private
[canvases null]
[active-canvas #f]
@ -1748,6 +1749,22 @@
(< 0 new-width))
(as-exit (lambda () (set-max-width new-width)))))))))]
[print
(let ([sp (lambda (x y z f)
;; let super method report z errors:
(let ([zok? (memq z '(standard postscript))])
(when zok?
(check-top-level-parent/false '(method editor<%> print) f))
(let ([p (and zok? f (mred->wx f))])
(as-exit (lambda () (super-print x y z p))))))])
(entry-point-0-1-2-3-4
(case-lambda
[() (sp #t #t 'standard #f)]
[(x) (sp x #t 'standard #f)]
[(x y) (sp x y 'standard #f)]
[(x y z) (sp x y z #f)]
[(x y z f) (sp x y z f)])))]
[on-new-box
(entry-point-1
(lambda (type)
@ -4524,12 +4541,15 @@
(define _
(begin
(check-string/false 'get-ps-setup-from-user message)
(check-top-level-parent/false 'get-ps-setup-from-user parent)
(unless (is-a? parent wx:window%)
(check-top-level-parent/false 'get-ps-setup-from-user parent))
(check-instance 'get-ps-setup-from-user wx:ps-setup% 'ps-setup% #t pss-in)
(check-style 'get-ps-setup-from-user #f null style)))
(define pss (or pss-in (wx:current-ps-setup)))
(define f (make-object dialog% "PostScript Setup" parent))
(define f (make-object dialog% "PostScript Setup" (if (is-a? parent wx:window%)
(wx->mred parent)
parent)))
(define papers
'("A4 210 x 297 mm" "A3 297 x 420 mm" "Letter 8 1/2 x 11 in" "Legal 8 1/2 x 14 in"))
(define p (make-object horizontal-pane% f))
@ -5035,6 +5055,24 @@
(when bm
(set-bitmap bm)))))
(define post-script-dc%
(class wx:post-script-dc% ([i? #t][parent #f])
(sequence
(check-top-level-parent/false '(constructor post-script-dc) parent)
(as-entry
(lambda ()
(let ([p (and parent (mred->wx parent))])
(as-exit (lambda () (super-init i? p)))))))))
(define printer-dc%
(class wx:printer-dc% ([parent #f])
(sequence
(check-top-level-parent/false '(constructor printer-dc) parent)
(as-entry
(lambda ()
(let ([p (and parent (mred->wx parent))])
(as-exit (lambda () (super-init p)))))))))
(define (find-item-frame item)
(let loop ([i item])
(let ([p (send i get-parent)])

2
src/mred/wrap/propgate.ss
View File

@ -56,8 +56,6 @@
pen%
pen-list%
point%
post-script-dc%
printer-dc%
ps-setup%
read-editor-global-footer
read-editor-global-header

1
src/mred/wxme/wx_madm.h
View File

@ -15,6 +15,7 @@ class wxMediaAdmin : public wxObject
private:
friend class wxMediaCanvas;
friend class wxMediaEdit;
friend class wxMediaBuffer;
friend class wxCanvasMediaAdmin;
int standard; /* Used to recognize standard display. Hack. */

23
src/mred/wxme/wx_mbuf.cxx
View File

@ -29,6 +29,9 @@
# include "wx_cmdlg.h"
#endif
#include "wx_print.h"
#ifdef wx_xt
# include "wx_types.h"
#endif
#include "wx_media.h"
#ifndef OLD_WXWINDOWS
@ -711,7 +714,6 @@ Bool wxMediaBuffer::ReadHeaderFromFile(wxMediaStreamIn *, char *headerName)
Bool wxMediaBuffer::ReadFooterFromFile(wxMediaStreamIn *, char *headerName)
{
char buffer[256];
int i;
sprintf(buffer, "Unknown header data: \"%.100s\"."
" The file will be loaded anyway.", headerName);
@ -1259,7 +1261,7 @@ void wxMediaPrintout::OnEndDocument()
# define WXUNUSED_X(x) x
#endif
void wxMediaBuffer::Print(Bool interactive, Bool fitToPage, int WXUNUSED_X(output_mode))
void wxMediaBuffer::Print(Bool interactive, Bool fitToPage, int WXUNUSED_X(output_mode), wxWindow *parent)
{
int ps;
@ -1269,11 +1271,24 @@ void wxMediaBuffer::Print(Bool interactive, Bool fitToPage, int WXUNUSED_X(outpu
ps = 1;
#endif
if (!parent) {
if (admin && (admin->standard > 0)) {
wxWindow *w = ((wxCanvasMediaAdmin *)admin)->GetCanvas();
while (w && !wxSubType(w->__type, wxTYPE_FRAME)
&& !wxSubType(w->__type, wxTYPE_DIALOG_BOX))
w = w->GetParent();
if (w)
parent = w;
}
}
if (ps) {
wxDC *dc;
void *data;
dc = new wxPostScriptDC(interactive);
dc = new wxPostScriptDC(interactive, parent);
if (dc->Ok()) {
dc->StartDoc("Printing buffer");
@ -1300,7 +1315,7 @@ void wxMediaBuffer::Print(Bool interactive, Bool fitToPage, int WXUNUSED_X(outpu
wxPrinter *p = new wxPrinter();
wxPrintout *o = new wxMediaPrintout(this, fitToPage);
p->Print(NULL, o, interactive);
p->Print(parent, o, interactive);
DELETE_OBJ o;
DELETE_OBJ p;

2
src/mred/wxme/wx_medad.h
View File

@ -262,7 +262,7 @@ class wxMediaBuffer : public wxObject
virtual void InvalidateBitmapCache(float x=0.0, float y=0.0,
float w=-1.0, float h=-1.0) = 0;
void Print(Bool interactive=TRUE, Bool fit=FALSE, int output_mode = 0);
void Print(Bool interactive=TRUE, Bool fit=FALSE, int output_mode = 0, wxWindow *parent = NULL);
virtual void *BeginPrint(wxDC *dc, Bool fit) = 0;
virtual void EndPrint(wxDC*, void*) = 0;
virtual void PrintToDC(wxDC *dc, int page = -1) = 0;

10336
src/mred/wxs/cwrap.inc
View File

File diff suppressed because it is too large Load Diff

1256
src/mred/wxs/wrap.inc
View File

File diff suppressed because it is too large Load Diff

58
src/mred/wxs/wxs_dc.cxx
View File

@ -1667,7 +1667,7 @@ static Scheme_Object *os_wxMemoryDCSelectObject(Scheme_Object *obj, int n, Sche
x0 = WITH_VAR_STACK(objscheme_unbundle_wxBitmap(p[0], "set-bitmap in bitmap-dc%", 1));
if (x0) { if (!x0->Ok()) WITH_VAR_STACK(scheme_arg_mismatch(METHODNAME("memory-dc","set-bitmap"), "bad bitmap: ", p[0])); if (BM_SELECTED(x0)) WITH_VAR_STACK(scheme_arg_mismatch(METHODNAME("memory-dc","set-bitmap"), "bitmap is already installed into a bitmap-dc%: ", p[0])); if (BM_IN_USE(x0)) WITH_VAR_STACK(scheme_arg_mismatch(METHODNAME("memory-dc","set-bitmap"), "bitmap is currently installed as a control label or pen/brush stipple: ", p[0])); }
if (x0) { if (!x0->Ok()) WITH_VAR_STACK(scheme_arg_mismatch(METHODNAME("memory-dc%","set-bitmap"), "bad bitmap: ", p[0])); if (BM_SELECTED(x0)) WITH_VAR_STACK(scheme_arg_mismatch(METHODNAME("memory-dc%","set-bitmap"), "bitmap is already installed into a bitmap-dc%: ", p[0])); if (BM_IN_USE(x0)) WITH_VAR_STACK(scheme_arg_mismatch(METHODNAME("memory-dc%","set-bitmap"), "bitmap is currently installed as a control label or pen/brush stipple: ", p[0])); }
WITH_VAR_STACK(((wxMemoryDC *)((Scheme_Class_Object *)obj)->primdata)->SelectObject(x0));
@ -1847,7 +1847,7 @@ class wxMemoryDC *objscheme_unbundle_wxMemoryDC(Scheme_Object *obj, const char *
class os_wxPostScriptDC : public wxPostScriptDC {
public:
os_wxPostScriptDC CONSTRUCTOR_ARGS((Bool x0 = TRUE));
os_wxPostScriptDC CONSTRUCTOR_ARGS((Bool x0 = TRUE, class wxWindow* x1 = NULL));
~os_wxPostScriptDC();
#ifdef MZ_PRECISE_GC
void gcMark();
@ -1866,8 +1866,8 @@ void os_wxPostScriptDC::gcFixup() {
static Scheme_Object *os_wxPostScriptDC_class;
os_wxPostScriptDC::os_wxPostScriptDC CONSTRUCTOR_ARGS((Bool x0))
CONSTRUCTOR_INIT(: wxPostScriptDC(x0))
os_wxPostScriptDC::os_wxPostScriptDC CONSTRUCTOR_ARGS((Bool x0, class wxWindow* x1))
CONSTRUCTOR_INIT(: wxPostScriptDC(x0, x1))
{
}
@ -1883,24 +1883,30 @@ static Scheme_Object *os_wxPostScriptDC_ConstructScheme(Scheme_Object *obj, int
os_wxPostScriptDC *realobj INIT_NULLED_OUT;
REMEMBER_VAR_STACK();
Bool x0;
class wxWindow* x1 INIT_NULLED_OUT;
SETUP_VAR_STACK_PRE_REMEMBERED(3);
SETUP_VAR_STACK_PRE_REMEMBERED(4);
VAR_STACK_PUSH(0, p);
VAR_STACK_PUSH(1, obj);
VAR_STACK_PUSH(2, realobj);
VAR_STACK_PUSH(3, x1);
if ((n > 1))
WITH_VAR_STACK(scheme_wrong_count("initialization in post-script-dc%", 0, 1, n, p));
if ((n > 2))
WITH_VAR_STACK(scheme_wrong_count("initialization in post-script-dc%", 0, 2, n, p));
if (n > 0) {
x0 = WITH_VAR_STACK(objscheme_unbundle_bool(p[0], "initialization in post-script-dc%"));
} else
x0 = TRUE;
if (n > 1) {
x1 = WITH_VAR_STACK(objscheme_unbundle_wxWindow(p[1], "initialization in post-script-dc%", 1));
} else
x1 = NULL;
realobj = WITH_VAR_STACK(new os_wxPostScriptDC CONSTRUCTOR_ARGS((x0)));
if (x1 && !wxSubType(((wxObject *)x1)->__type, wxTYPE_FRAME) && !wxSubType(((wxObject *)x1)->__type, wxTYPE_DIALOG_BOX)) scheme_wrong_type(METHODNAME("post-script-dc%","initialization"), "frame or dialog box", 1, n, p);
realobj = WITH_VAR_STACK(new os_wxPostScriptDC CONSTRUCTOR_ARGS((x0, x1)));
#ifdef MZ_PRECISE_GC
WITH_VAR_STACK(realobj->gcInit_wxPostScriptDC(x0));
WITH_VAR_STACK(realobj->gcInit_wxPostScriptDC(x0, x1));
#endif
realobj->__gc_external = (void *)obj;
objscheme_note_creation(obj);
@ -1995,10 +2001,10 @@ END_XFORM_SKIP;
class basePrinterDC : public wxObject
{
public:
basePrinterDC();
basePrinterDC(wxWindow *w);
};
basePrinterDC::basePrinterDC()
basePrinterDC::basePrinterDC(wxWindow *)
{
scheme_raise_exn(MZEXN_MISC_UNSUPPORTED,
"%s",
@ -2010,10 +2016,10 @@ basePrinterDC::basePrinterDC()
class basePrinterDC : public wxPrinterDC
{
public:
basePrinterDC();
basePrinterDC(wxWindow *w);
};
basePrinterDC::basePrinterDC()
basePrinterDC::basePrinterDC(wxWindow *w)
: wxPrinterDC( )
{
}
@ -2030,7 +2036,7 @@ START_XFORM_SKIP;
class os_basePrinterDC : public basePrinterDC {
public:
os_basePrinterDC CONSTRUCTOR_ARGS(());
os_basePrinterDC CONSTRUCTOR_ARGS((class wxWindow* x0 = NULL));
~os_basePrinterDC();
#ifdef MZ_PRECISE_GC
void gcMark();
@ -2049,8 +2055,8 @@ void os_basePrinterDC::gcFixup() {
static Scheme_Object *os_basePrinterDC_class;
os_basePrinterDC::os_basePrinterDC CONSTRUCTOR_ARGS(())
CONSTRUCTOR_INIT(: basePrinterDC())
os_basePrinterDC::os_basePrinterDC CONSTRUCTOR_ARGS((class wxWindow* x0))
CONSTRUCTOR_INIT(: basePrinterDC(x0))
{
}
@ -2065,20 +2071,26 @@ static Scheme_Object *os_basePrinterDC_ConstructScheme(Scheme_Object *obj, int n
PRE_VAR_STACK_PUSH(0, obj);
os_basePrinterDC *realobj INIT_NULLED_OUT;
REMEMBER_VAR_STACK();
class wxWindow* x0 INIT_NULLED_OUT;
SETUP_VAR_STACK_PRE_REMEMBERED(3);
SETUP_VAR_STACK_PRE_REMEMBERED(4);
VAR_STACK_PUSH(0, p);
VAR_STACK_PUSH(1, obj);
VAR_STACK_PUSH(2, realobj);
VAR_STACK_PUSH(3, x0);
if (n != 0)
WITH_VAR_STACK(scheme_wrong_count("initialization in printer-dc%", 0, 0, n, p));
if ((n > 1))
WITH_VAR_STACK(scheme_wrong_count("initialization in printer-dc%", 0, 1, n, p));
if (n > 0) {
x0 = WITH_VAR_STACK(objscheme_unbundle_wxWindow(p[0], "initialization in printer-dc%", 1));
} else
x0 = NULL;
realobj = WITH_VAR_STACK(new os_basePrinterDC CONSTRUCTOR_ARGS(()));
if (x0 && !wxSubType(((wxObject *)x0)->__type, wxTYPE_FRAME) && !wxSubType(((wxObject *)x0)->__type, wxTYPE_DIALOG_BOX)) scheme_wrong_type(METHODNAME("printer-dc%","initialization"), "frame or dialog box", 0, n, p);
realobj = WITH_VAR_STACK(new os_basePrinterDC CONSTRUCTOR_ARGS((x0)));
#ifdef MZ_PRECISE_GC
WITH_VAR_STACK(realobj->gcInit_basePrinterDC());
WITH_VAR_STACK(realobj->gcInit_basePrinterDC(x0));
#endif
realobj->__gc_external = (void *)obj;
objscheme_note_creation(obj);

2
src/mred/wxs/wxs_dc.h
View File

@ -36,12 +36,14 @@ void objscheme_setup_wxMemoryDC(void *env);
int objscheme_istype_wxMemoryDC(Scheme_Object *obj, const char *stop, int nullOK);
Scheme_Object *objscheme_bundle_wxMemoryDC(class wxMemoryDC *realobj);
class wxMemoryDC *objscheme_unbundle_wxMemoryDC(Scheme_Object *obj, const char *where, int nullOK);
extern class wxWindow *objscheme_unbundle_wxWindow(Scheme_Object *, const char *, int);
#endif
void objscheme_setup_wxPostScriptDC(void *env);
#ifndef WXS_SETUP_ONLY
int objscheme_istype_wxPostScriptDC(Scheme_Object *obj, const char *stop, int nullOK);
Scheme_Object *objscheme_bundle_wxPostScriptDC(class wxPostScriptDC *realobj);
class wxPostScriptDC *objscheme_unbundle_wxPostScriptDC(Scheme_Object *obj, const char *where, int nullOK);
extern class wxWindow *objscheme_unbundle_wxWindow(Scheme_Object *, const char *, int);
#endif
void objscheme_setup_basePrinterDC(void *env);
#ifndef WXS_SETUP_ONLY

14
src/mred/wxs/wxs_dc.xc
View File

@ -192,7 +192,7 @@ static void* MyGetSize(wxDC *dc)
@ "get-pixel" : bool GetPixel(float,float,wxColour^)
@ "set-pixel" : void SetPixel(float,float,wxColour^)
@ "set-bitmap" : void SelectObject(wxBitmap^); : : /CHECKOKFORDC[0.METHODNAME("memory-dc","set-bitmap")]
@ "set-bitmap" : void SelectObject(wxBitmap^); : : /CHECKOKFORDC[0.METHODNAME("memory-dc%","set-bitmap")]
@ "get-bitmap" : wxBitmap^ GetObject();
@END
@ -203,7 +203,7 @@ static void* MyGetSize(wxDC *dc)
@INCLUDE wxs_dorf.xci
@CREATOR (bool=TRUE)
@CREATOR (bool=TRUE,wxWindow^=NULL) : : /DLGORFRAME[1.METHODNAME("post-script-dc%","initialization")]
@END
@ -216,10 +216,10 @@ END_XFORM_SKIP;
class basePrinterDC : public wxObject
{
public:
basePrinterDC();
basePrinterDC(wxWindow *w);
};
basePrinterDC::basePrinterDC()
basePrinterDC::basePrinterDC(wxWindow *)
{
scheme_raise_exn(MZEXN_MISC_UNSUPPORTED,
"%s",
@ -231,10 +231,10 @@ basePrinterDC::basePrinterDC()
class basePrinterDC : public wxPrinterDC
{
public:
basePrinterDC();
basePrinterDC(wxWindow *w);
};
basePrinterDC::basePrinterDC()
basePrinterDC::basePrinterDC(wxWindow *w)
: wxPrinterDC( )
{
}
@ -249,7 +249,7 @@ START_XFORM_SKIP;
@CLASSID wxTYPE_DC_PRINTER
@CREATOR ();
@CREATOR (wxWindow^=NULL); : : /DLGORFRAME[0.METHODNAME("printer-dc%","initialization")]
@END

12
src/mred/wxs/wxs_medi.cxx
View File

@ -2151,10 +2151,12 @@ static Scheme_Object *os_wxMediaBufferPrint(Scheme_Object *obj, int n, Scheme_O
Bool x0;
Bool x1;
int x2;
class wxWindow* x3 INIT_NULLED_OUT;
SETUP_VAR_STACK_REMEMBERED(2);
SETUP_VAR_STACK_REMEMBERED(3);
VAR_STACK_PUSH(0, p);
VAR_STACK_PUSH(1, obj);
VAR_STACK_PUSH(2, x3);
if (n > 0) {
@ -2169,9 +2171,13 @@ static Scheme_Object *os_wxMediaBufferPrint(Scheme_Object *obj, int n, Scheme_O
x2 = WITH_VAR_STACK(unbundle_symset_printMethod(p[2], "print in editor<%>"));
} else
x2 = 0;
if (n > 3) {
x3 = WITH_VAR_STACK(objscheme_unbundle_wxWindow(p[3], "print in editor<%>", 1));
} else
x3 = NULL;
WITH_VAR_STACK(((wxMediaBuffer *)((Scheme_Class_Object *)obj)->primdata)->Print(x0, x1, x2));
WITH_VAR_STACK(((wxMediaBuffer *)((Scheme_Class_Object *)obj)->primdata)->Print(x0, x1, x2, x3));
@ -4988,7 +4994,7 @@ void objscheme_setup_wxMediaBuffer(void *env)
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaBuffer_class, "get-focus-snip", os_wxMediaBufferGetFocusSnip, 0, 0));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaBuffer_class, "end-write-header-footer-to-file", os_wxMediaBufferEndWriteHeaderFooterToFile, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaBuffer_class, "begin-write-header-footer-to-file", os_wxMediaBufferBeginWriteHeaderFooterToFile, 3, 3));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaBuffer_class, "print", os_wxMediaBufferPrint, 0, 3));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaBuffer_class, "print", os_wxMediaBufferPrint, 0, 4));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaBuffer_class, "insert-image", os_wxMediaBufferInsertImage, 0, 4));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaBuffer_class, "insert-box", os_wxMediaBufferInsertBox, 0, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxMediaBuffer_class, "get-filename", os_wxMediaBufferGetFilename, 0, 1));

1
src/mred/wxs/wxs_medi.h
View File

@ -28,6 +28,7 @@ extern class wxMediaBuffer *objscheme_unbundle_wxMediaBuffer(Scheme_Object *, co
extern Scheme_Object *objscheme_bundle_wxSnip(class wxSnip *);
extern class wxMediaStreamOut *objscheme_unbundle_wxMediaStreamOut(Scheme_Object *, const char *, int);
extern class wxMediaStreamOut *objscheme_unbundle_wxMediaStreamOut(Scheme_Object *, const char *, int);
extern class wxWindow *objscheme_unbundle_wxWindow(Scheme_Object *, const char *, int);
extern class wxCursor *objscheme_unbundle_wxCursor(Scheme_Object *, const char *, int);
extern class wxStyleList *objscheme_unbundle_wxStyleList(Scheme_Object *, const char *, int);
extern Scheme_Object *objscheme_bundle_wxStyleList(class wxStyleList *);

2
src/mred/wxs/wxs_medi.xc
View File

@ -148,7 +148,7 @@ static void *wxbDCToBuffer(wxMediaBuffer *b, float x, float y)
@ "insert-box" : void InsertBox(SYM[bufferType]=wxEDIT_BUFFER);
@ "insert-image" : void InsertImage(nstring=NULL,SYM[bitmapType]=0,bool=FALSE,bool=TRUE);
@ "print" : void Print(bool=TRUE,bool=TRUE,SYM[printMethod]=0);
@ "print" : void Print(bool=TRUE,bool=TRUE,SYM[printMethod]=0,wxWindow^=NULL); : : /DLGORFRAME[3.METHODNAME("editor<%>","print")]
@ "begin-write-header-footer-to-file" : bool BeginWriteHeaderFooterToFile(wxMediaStreamOut!,string,long*);
@ "end-write-header-footer-to-file" : bool EndWriteHeaderFooterToFile(wxMediaStreamOut!,long);

35
src/mysterx/Makefile
View File

@ -1,33 +1,26 @@
# Makefile for mysterx.dll, myspage.dll, myssink.dll
# If you get errors about a missing file atlbase.h,
# check the value of the environment variable INCLUDE.
# The subdirectory ATL beneath the Visual C++ directory
# needs to be in the list of INCLUDE directories.
# For example, if Visual Studio 6 is installed at the root of
# the C: drive, that directory would be
# C:\Microsoft Visual Studio\VC98\ATL
# See README for compilation instructions
# The Microsoft HTML Help Workshop must be installed to
# build mysterx.dll. The files are on the Visual Studio
# CD.
# The code for mx_element_focus in htmlutil.cxx uses the
# COM interface IHTMLElement2. That interface is defined
# in MsHTML.h in recent versions of the Platform SDK (more
# recent than the VC++6 release. If you don't have such a
# Platform SDK, comment out the code in the body of that
# function.
MZC="..\..\mzc"
HTMLHELP="C:\Program Files\HTML Help Workshop"
SHELL32="C:\Program Files\Microsoft Visual Studio\VC98"
REGSVR32="C:\Windows\System\REGSVR32"
NEWMSHTML=1
all :
cd myspage
nmake /f myspage.mak
nmake MZC=$(MZC) HTMLHELP=$(HTMLHELP) SHELL32=$(SHELL32) \
REGSVR32=$(REGSVR32) /f myspage.mak
cd ../mysc
nmake /f mysc.mak
nmake MZC=$(MZC) HTMLHELP=$(HTMLHELP) SHELL32=$(SHELL32) \
REGSVR32=$(REGSVR32) /f mysc.mak
cd ../myssink
nmake /f myssink.mak
nmake MZC=$(MZC) HTMLHELP=$(HTMLHELP) SHELL32=$(SHELL32) \
REGSVR32=$(REGSVR32) /f myssink.mak
cd ..
nmake /f mysterx.mak
nmake MZC=$(MZC) HTMLHELP=$(HTMLHELP) SHELL32=$(SHELL32) \
REGSVR32=$(REGSVR32) NEWMSHTML=$(NEWMSHTML) /f mysterx.mak
clean :
cd myspage

36
src/mysterx/README
View File

@ -9,5 +9,41 @@ gets rid of existing binaries, while
compiles all the binaries.
In the Makefile, there are several variables to set:
o MZC - path to the mzc compiler
o HTMLHELP - directory for MS Help Workshop
o SHELL32 - directory containing LIB/SHELL32.LIB
and related header files
o REGSVR32 - path to the REGSVR32 utility
o NEWMSHTML - either 0 or 1, depending on
on the version of MSHTML.H used (see below)
You may need to change these according to your local
installation before compiling. The REGSVR32 utility
is ordinarily located in the Windows\SYSTEM directory
under Windows 95/98, and in the WINNT\System32 directory
under Windows NT/2000.
If you get errors about a missing file atlbase.h,
check the value of the environment variable INCLUDE.
The subdirectory ATL beneath the Visual C++ directory
needs to be in the list of INCLUDE directories.
For example, if Visual Studio 6 is installed at the root of
the C: drive, that directory would be
C:\Microsoft Visual Studio\VC98\ATL
The Microsoft HTML Help Workshop must be installed to
build mysterx.dll. The files are on the Visual Studio
CD in the directory HTMLHELP in the file HTMLHELP.EXE. Run
that program to install the files. Alternatively, Help
Workshop may be downloaded from the Web, at
http://msdn.microsoft.com/library/tools/htmlhelp/wkshp/download_main.htm
The code for mx_element_focus in htmlutil.cxx uses the
COM interface IHTMLElement2. That interface is defined
in MSHTML.H in recent versions of the Platform SDK (more
recent than the VC++6 release). If you don't have such a
Platform SDK, set the variable NEWMSHTML to 0 in Makefile
(or comment out the code in the body of that function).

4
src/mysterx/htmlutil.cxx
View File

@ -181,6 +181,8 @@ Scheme_Object *mx_element_focus(int argc,Scheme_Object **argv) {
// if recent Platform SDK not available, comment out code
// from HERE
#if NEWMSHTML
HRESULT hr;
IHTMLElement *pIHTMLElement;
IHTMLElement2 *pIHTMLElement2;
@ -202,6 +204,8 @@ Scheme_Object *mx_element_focus(int argc,Scheme_Object **argv) {
pIHTMLElement2->Release();
#endif
// to HERE
return scheme_void;

4
src/mysterx/mysc/mysc.mak
View File

@ -1,4 +1,4 @@
# mysterx.mak
# mysc.mak
all : mysc.lib
@ -15,8 +15,6 @@ CPP_FLAGS=/I"../../../collects/mzscheme/include" /I"$(SHELL32)\Include" \
.cxx.obj::
$(CPP) $(CPP_FLAGS) $<
MZC="C:\Program Files\PLT\mzc"
LINK32=$(MZC)
LINK32_LIBS= \
kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib \

5
src/mysterx/myspage/myspage.mak
View File

@ -1,7 +1,7 @@
# myspage.mak
CPP=cl.exe
CPP_FLAGS=/I"F:/SBN/Include" /I"../../../collects/mzscheme/include" /MT /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "_ATL_STATIC_REGISTRY" /D "_ATL_MIN_CRT" /c
CPP_FLAGS=/I"$(SHELL32)/Include" /I"../../../collects/mzscheme/include" /MT /W3 /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_USRDLL" /D "_ATL_STATIC_REGISTRY" /D "_ATL_MIN_CRT" /c
.cxx.obj::
$(CPP) $(CPP_FLAGS) $<
@ -10,10 +10,9 @@ MTL=midl.exe
MTL_SWITCHES=/tlb ".\myspage.tlb" /h "myspage.h" /iid "myspage_i.c" /Oicf
RSC=rc.exe
RSC_PROJ=/l 0x409 /fo"myspage.res"
REGSVR32=regsvr32
LINK32=link.exe
LINK32_FLAGS=d:\plt\collects\mzscheme\lib\win32\i386\msvc\mzdyn.obj kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib f:\SBN\Lib\shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /incremental:no /machine:I386 /def:myspage.def /out:myspage.dll
LINK32_FLAGS=..\..\..\collects\mzscheme\lib\win32\i386\msvc\mzdyn.obj kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib "$(SHELL32)\Lib\shell32.lib" ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /dll /incremental:no /machine:I386 /def:myspage.def /out:myspage.dll
DEF_FILE= myspage.def
LINK32_OBJS= dhtmlpage.obj event.obj eventqueue.obj myspage.obj stdafx.obj \
myspage.res

3
src/mysterx/myssink/myssink.mak
View File

@ -7,10 +7,9 @@ MTL=midl.exe
MTL_SWITCHES=/tlb myssink.tlb /h myssink.h /iid myssink_i.c /Oicf
RSC=rc.exe
RSC_PROJ=/l 0x409 /fo"myssink.res"
REGSVR32=regsvr32
LINK32=link.exe
LINK32_FLAGS=d:\plt\collects\mzscheme\lib\win32\i386\msvc\mzdyn.obj kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib \
LINK32_FLAGS=..\..\..\collects\mzscheme\lib\win32\i386\msvc\mzdyn.obj kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib \
..\mysc\mysc.lib \
/nologo /subsystem:windows /dll /incremental:no /machine:I386 /def:myssink.def /out:myssink.dll
DEF_FILE=myssink.def

9
src/mysterx/mysterx.mak
View File

@ -11,22 +11,17 @@ clean :
-@erase mysterx.obj
-@erase mxmain.dll
HTMLHELP=C:\Program Files\HTML Help Workshop
SHELL32=F:\SBN
CPP=cl.exe
CPP_FLAGS=/I"../../collects/mzscheme/include" /I"./myspage" /I"./mysc" /I"./myssink" /I"$(SHELL32)\Include" \
/I"$(HTMLHELP)\include" /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /c
/I"$(HTMLHELP)\include" /MT /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_CONSOLE" /D "_MBCS" /D"NEWMSHTML=$(NEWMSHTML)" /c
.cxx.obj::
$(CPP) $(CPP_FLAGS) $<
MZC="D:\plt\mzc"
LINK32=$(MZC)
LINK32_LIBS= \
kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib \
advapi32.lib $(SHELL32)\LIB\shell32.lib ole32.lib oleaut32.lib \
advapi32.lib "$(SHELL32)\LIB\shell32.lib" ole32.lib oleaut32.lib \
uuid.lib "$(HTMLHELP)\lib\htmlhelp.lib" \
mysc\mysc.lib

13
src/mzcom/mzcom.cxx
View File

@ -1,16 +1,11 @@
// MzCOM.cpp : Implementation of WinMain
// Note: Proxy/Stub Information
// To build a separate proxy/stub DLL,
// run nmake -f MzCOMps.mk in the project directory.
// mzcom.cxx : Implementation of WinMain
#include "stdafx.h"
#include "resource.h"
#include <initguid.h>
#include "mzcom.h"
#include "MzCOM_i.c"
#include "mzcom_i.c"
#include "mzobj.h"
// time for EXE to be idle before shutting down
@ -34,12 +29,12 @@ LONG CExeModule::Unlock()
if (l == 0)
{
bActivity = true;
SetEvent(hEventShutdown); // tell monitor that we transitioned to zero
SetEvent(hEventShutdown);
}
return l;
}
//Monitors the shutdown event
// Monitors the shutdown event
void CExeModule::MonitorShutdown()
{
while (1)

13
src/mzcom/mzobj.cxx
View File

@ -239,7 +239,6 @@ void CMzObj::startMzThread(void) {
CMzObj::CMzObj(void) {
lastOutput = NULL;
inputMutex = NULL;
readSem = NULL;
threadId = NULL;
@ -312,10 +311,6 @@ void CMzObj::killMzThread(void) {
CMzObj::~CMzObj(void) {
if (lastOutput) {
SysFreeString(lastOutput);
}
killMzThread();
if (readSem) {
@ -366,17 +361,11 @@ BOOL CMzObj::testThread(void) {
// CMzObj
STDMETHODIMP CMzObj::Eval(BSTR input, BSTR *output) {
if (!testThread()) {
return E_ABORT;
}
WaitForSingleObject(inputMutex,INFINITE);
if (lastOutput) {
SysFreeString(lastOutput);
lastOutput = NULL;
}
globInput = &input;
// allow evaluator to read
ReleaseSemaphore(readSem,1,NULL);
@ -388,7 +377,7 @@ STDMETHODIMP CMzObj::Eval(BSTR input, BSTR *output) {
return E_FAIL;
}
lastOutput = *output = globOutput;
*output = globOutput;
ReleaseSemaphore(inputMutex,1,NULL);
if (errorState) {

1
src/mzcom/mzobj.h
View File

@ -43,7 +43,6 @@ class ATL_NO_VTABLE CMzObj :
HANDLE evalDoneSems[2];
BSTR *globInput;
BSTR globOutput;
BSTR lastOutput;
DWORD threadId;
HANDLE threadHandle;
BOOL errorState;

78
src/mzscheme/README
View File

@ -5,81 +5,3 @@ information on compiling it.
Compiled binaries, documentation, and up-to-date information about
MzScheme are at:
http://www.cs.rice.edu/CS/PLT/packages/mzscheme/
========================================================================
Compiling the OSKit-based kernel
========================================================================
To build the OSKit-based MzScheme kernel, run the configure script
with the --enable-oskit or --enable-smalloskit flag. The result will
be `mzscheme.multiboot' in the `mzscheme' build directory. It is a
kernel in multiboot format.
Before building the MzScheme kernel, you must first install OSKit,
which is available from the Flux Research Group at Utah:
http://www.cs.utah.edu/projects/flux/oskit/
By default, configure assumes that OSKit is installed in
/usr/local. To specify a different location for OSKit, define the
OSKHOME environment variable.
For simplicity, the MzScheme kernel uses SGC rather than Boehm's
conservative garbage collector.
The --enable-smalloskit configuration produces a kernel without
networking or filesystem support. The kernel created by
--enable--oskit accepts filesystem and networking configuration
information on its multiboot command line via the --fs and --net
flags:
--fs <drive> <partition> : mounts the given partition as the root
directory. For example, to mount the seventh parition on main disk,
supply: --fs hda f. Many filesystem formats are supported,
including EXT2, MSDOS, and VFAT (all of the ones supported by
Linux; see OSKit for details). The standard kernel can only mount
one filesystem per run; hack main.c to get more.
--net <address> <netmask> <gateway> : initializes ethernet support
for MzScheme's TCP primitives. Example: --net 128.42.6.101
255.255.255.0 128.42.6.254. Many types of ethernet cards are
supported (the ones supported by FreeBSD; see OSKit for details).
Each of --fs and --net should be used once at most. The --fs and --net
flags must appear before any other command-line arguments, which are
handled by MzScheme in the usual way.
To access a filesystem or the network from non-multiboot kernels
(e.g., a LILO-compatible kernel), you must hardwire filesystem and
networking parameters in oskglue.inc when compiling the kernel; see
oskglue.inc for details (grep for `hardwire').
========================================================================
General Compilation Notes
========================================================================
By default, MzScheme is compiled:
* without image dumps (since the application will probably be linked
dynamically);
* without using any OS-specific threads; and
* without support for single-precision floating point numbers.
The conservative garbage collector distributed with MzScheme (in the
gc directory) has been modified slightly from Boehm's standard
distribution.
If you modify MzScheme and change any primitive syntax or the
collection of built-in identifers, be sure to turn off
USE_COMPILED_MACROS in schminc.h. Otherwise, MzScheme won't start.
See schminc.h for details.
========================================================================
Miscellaneous
========================================================================
See plt/collects/mzscheme/examples/ for some example extensions.
`make libguile' produces a libguile.a library that implements the
high-level guile interface. See libguile/README.

4
src/mzscheme/src/dynext.c
View File

@ -294,7 +294,7 @@ static Scheme_Object *do_load_extension(const char *filename, Scheme_Env *env)
scheme_raise_exn(MZEXN_I_O_FILESYSTEM,
scheme_make_string(filename),
fail_err_symbol,
"load-extension: could not load \"%s\" (%e)",
"load-extension: could not load \"%s\" (%E)",
filename, GetLastError());
handle = (void *)dl;
@ -307,7 +307,7 @@ static Scheme_Object *do_load_extension(const char *filename, Scheme_Env *env)
scheme_raise_exn(MZEXN_I_O_FILESYSTEM,
scheme_make_string(filename),
fail_err_symbol,
"load-extension: \"%s\" is not an extension (%e)",
"load-extension: \"%s\" is not an extension (%E)",
filename, err);
}

42
src/mzscheme/src/error.c
View File

@ -22,6 +22,9 @@
*/
#include "schpriv.h"
#ifdef DOS_FILE_SYSTEM
# include <windows.h>
#endif
/* globals */
void (*scheme_console_printf)(char *str, ...);
@ -121,7 +124,8 @@ void scheme_init_format_procedure(Scheme_Env *env)
%V = scheme_value
%L = line number, -1 means no line
%e = error number
%e = error number for strerror()
%E = error number for platform-specific error string
*/
static long scheme_vsprintf(char *s, long maxlen, const char *msg, va_list args)
@ -160,6 +164,7 @@ static long scheme_vsprintf(char *s, long maxlen, const char *msg, va_list args)
(void)va_arg(args2, long);
break;
case 'e':
case 'E':
(void)va_arg(args2, int);
break;
case 'S':
@ -254,17 +259,44 @@ static long scheme_vsprintf(char *s, long maxlen, const char *msg, va_list args)
}
}
break;
case 'e':
case 'e':
case 'E':
{
int en;
en = va_arg(args, int);
if (en) {
t = strerror(en);
char *es;
#ifdef DOS_FILE_SYSTEM
char mbuf[256];
if (type == 'E') {
if (FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM, NULL,
en, MAKELANGID(LANG_NEUTRAL, SUBLANG_DEFAULT),
mbuf, 255, NULL)) {
int i;
es = mbuf;
/* Remove newlines: */
for (i = strlen(es) - 1; i > 0; i--) {
if (isspace(es[i]))
es[i] = 0;
else
break;
}
} else
es = NULL;
} else
es = NULL;
if (!es)
#endif
es = strerror(en);
tlen = strlen(es) + 24;
t = (const char *)scheme_malloc_atomic(tlen);
sprintf((char *)t, "%s; errno=%d", es, en);
tlen = strlen(t);
} else {
t = "-1";
tlen = 2;
t = "errno=?";
tlen = 7;
}
}
break;
case 'S':

5
src/mzscheme/src/file.c
View File

@ -3448,6 +3448,9 @@ static Scheme_Object *collpaths_gen_p(int argc, Scheme_Object **argv, int rel)
if (rel && !scheme_is_relative_path(SCHEME_STR_VAL(s),
SCHEME_STRTAG_VAL(s)))
return NULL;
if (!rel && !scheme_is_complete_path(SCHEME_STR_VAL(s),
SCHEME_STRTAG_VAL(s)))
return NULL;
v = SCHEME_CDR(v);
}
@ -3491,7 +3494,7 @@ static Scheme_Object *current_library_collection_paths(int argc, Scheme_Object *
return scheme_param_config("current-library-collection-paths",
scheme_make_integer(MZCONFIG_COLLECTION_PATHS),
argc, argv,
-1, collpaths_p, "list of strings", 1);
-1, collpaths_p, "list of complete path strings", 1);
}
static Scheme_Object *collpaths_rel_p(int argc, Scheme_Object **argv)

9
src/mzscheme/src/network.c
View File

@ -1415,7 +1415,7 @@ static Scheme_Object *tcp_connect(int argc, Scheme_Object *argv[])
dest_host = MALLOC_ONE_ATOMIC(struct hostInfo);
if ((errNo = tcp_addr(address, dest_host))) {
errpart = 1;
errmsg = " host not found";
errmsg = "; host not found";
goto tcp_error;
}
@ -1510,6 +1510,7 @@ static Scheme_Object *tcp_connect(int argc, Scheme_Object *argv[])
status = WSAGetLastError();
inprogress = (status == WSAEWOULDBLOCK);
errno = status;
#endif
scheme_file_open_count++;
@ -1563,14 +1564,14 @@ static Scheme_Object *tcp_connect(int argc, Scheme_Object *argv[])
#else
errid = 0;
#endif
errmsg = " host not found";
errmsg = "; host not found";
}
#endif
#ifdef USE_TCP
scheme_raise_exn(MZEXN_I_O_TCP,
"tcp-connect: connection to %s, port %d failed (%d%s%d%s)",
address, origid, errpart, ":", errid, errmsg);
"tcp-connect: connection to %s, port %d failed%s (at step %d: %E)",
address, origid, errmsg, errpart, errid);
#else
scheme_raise_exn(MZEXN_MISC_UNSUPPORTED,
"tcp-connect: not supported on this platform");

2
src/worksp/mzcom/mzcom.h
View File

@ -2,7 +2,7 @@
/* File created by MIDL compiler version 5.01.0164 */
/* at Thu May 25 13:43:33 2000
/* at Wed May 31 11:50:51 2000
*/
/* Compiler settings for D:\plt\src\mzcom\mzcom.idl:
Os (OptLev=s), W1, Zp8, env=Win32, ms_ext, c_ext

109
src/worksp/mzcom/mzcom.mak
View File

@ -25,16 +25,12 @@ NULL=
NULL=nul
!ENDIF
CPP=cl.exe
MTL=midl.exe
RSC=rc.exe
!IF "$(CFG)" == "MzCOM - Win32 Debug"
OUTDIR=.\Debug
INTDIR=.\Debug
ALL : "..\..\..\collects\mzcom\mzcom.exe" ".\Debug\regsvr32.trg"
ALL : "..\..\..\collects\mzcom\mzcom.exe" ".\mzcom.tlb" ".\Debug\regsvr32.trg"
CLEAN :
@ -52,7 +48,42 @@ CLEAN :
"$(OUTDIR)" :
if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"
CPP=cl.exe
CPP_PROJ=/nologo /MTd /W3 /Gm /ZI /Od /I "..\..\..\collects\mzscheme\include" /I "..\..\mzcom" /I "." /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /Fp"$(INTDIR)\MzCOM.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /GZ /c
.c{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.c{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
MTL=midl.exe
MTL_PROJ=
RSC=rc.exe
RSC_PROJ=/l 0x409 /fo"$(INTDIR)\mzcom.res" /i ".\..\mzcom" /d "_DEBUG"
BSC32=bscmake.exe
BSC32_FLAGS=/nologo /o"$(OUTDIR)\MzCOM.bsc"
@ -104,7 +135,42 @@ CLEAN :
"$(OUTDIR)" :
if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"
CPP=cl.exe
CPP_PROJ=/nologo /MT /W3 /O1 /I "..\..\mzcom" /I "." /I "..\..\..\collects\mzscheme\include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /Fp"$(INTDIR)\MzCOM.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /c
.c{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.c{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
MTL=midl.exe
MTL_PROJ=
RSC=rc.exe
RSC_PROJ=/l 0x409 /fo"$(INTDIR)\mzcom.res" /i "..\..\mzcom" /d "NDEBUG"
BSC32=bscmake.exe
BSC32_FLAGS=/nologo /o"$(OUTDIR)\MzCOM.bsc"
@ -138,37 +204,6 @@ SOURCE="$(InputPath)"
!ENDIF
.c{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.c{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
MTL_PROJ=
!IF "$(NO_EXTERNAL_DEPS)" != "1"
!IF EXISTS("MzCOM.dep")
@ -248,7 +283,7 @@ SOURCE=..\..\mzcom\mzobj.cxx
SOURCE=.\mzcom.rc
"$(INTDIR)\mzcom.res" : $(SOURCE) "$(INTDIR)" ".\mzcom.tlb"
"$(INTDIR)\mzcom.res" : $(SOURCE) "$(INTDIR)"
$(RSC) $(RSC_PROJ) $(SOURCE)

15
src/worksp/starters/resource.h
View File

@ -1,15 +0,0 @@
//{{NO_DEPENDENCIES}}
// Microsoft Developer Studio generated include file.
// Used by Script2.rc
//
// Next default values for new objects
//
#ifdef APSTUDIO_INVOKED
#ifndef APSTUDIO_READONLY_SYMBOLS
#define _APS_NEXT_RESOURCE_VALUE 101
#define _APS_NEXT_COMMAND_VALUE 40001
#define _APS_NEXT_CONTROL_VALUE 1000
#define _APS_NEXT_SYMED_VALUE 101
#endif
#endif

71
src/worksp/starters/start.rc
View File

@ -1,71 +0,0 @@
//Microsoft Developer Studio generated resource script.
//
#include "resource.h"
/////////////////////////////////////////////////////////////////////////////
//
// Icon
//
// Icon with lowest ID value placed first to ensure application icon
// remains consistent on all systems.
#ifdef MRSTART
APPLICATION ICON DISCARDABLE "mrstart.ico"
#endif
#ifdef MZSTART
APPLICATION ICON DISCARDABLE "mzstart.ico"
#endif
/////////////////////////////////////////////////////////////////////////////
//
// Version
//
VS_VERSION_INFO VERSIONINFO
FILEVERSION 1,0,0,1
PRODUCTVERSION 1,0,0,1
FILEFLAGSMASK 0x3fL
#ifdef _DEBUG
FILEFLAGS 0x1L
#else
FILEFLAGS 0x0L
#endif
FILEOS 0x40004L
FILETYPE 0x1L
FILESUBTYPE 0x0L
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904b0"
BEGIN
VALUE "CompanyName", "Rice University\0"
#ifdef MRSTART
VALUE "FileDescription", "MrEd Launcher\0"
#endif
#ifdef MZSTART
VALUE "FileDescription", "MzScheme Launcher\0"
#endif
VALUE "FileVersion", "1, 0, 0, 1\0"
#ifdef MRSTART
VALUE "InternalName", "mrstart\0"
#endif
#ifdef MZSTART
VALUE "InternalName", "mzstart\0"
#endif
VALUE "LegalCopyright", "Copyright © 1996-99\0"
#ifdef MRSTART
VALUE "OriginalFilename", "MrStart.exe\0"
VALUE "ProductName", "Rice University MrEd Launcher\0"
#endif
#ifdef MZSTART
VALUE "OriginalFilename", "MzStart.exe\0"
VALUE "ProductName", "Rice University MzScheme Launcher\0"
#endif
VALUE "ProductVersion", "1, 0, 0, 1\0"
END
END
BLOCK "VarFileInfo"
BEGIN
VALUE "Translation", 0x409, 1200
END
END

349
src/worksp/wxs/wxs.dsp
View File

@ -1,349 +0,0 @@
# Microsoft Developer Studio Project File - Name="wxs" - Package Owner=<4>
# Microsoft Developer Studio Generated Build File, Format Version 6.00
# ** DO NOT EDIT **
# TARGTYPE "Win32 (x86) Static Library" 0x0104
CFG=wxs - Win32 Release
!MESSAGE This is not a valid makefile. To build this project using NMAKE,
!MESSAGE use the Export Makefile command and run
!MESSAGE
!MESSAGE NMAKE /f "wxs.mak".
!MESSAGE
!MESSAGE You can specify a configuration when running NMAKE
!MESSAGE by defining the macro CFG on the command line. For example:
!MESSAGE
!MESSAGE NMAKE /f "wxs.mak" CFG="wxs - Win32 Release"
!MESSAGE
!MESSAGE Possible choices for configuration are:
!MESSAGE
!MESSAGE "wxs - Win32 Release" (based on "Win32 (x86) Static Library")
!MESSAGE "wxs - Win32 Debug" (based on "Win32 (x86) Static Library")
!MESSAGE "wxs - Win32 SGC" (based on "Win32 (x86) Static Library")
!MESSAGE
# Begin Project
# PROP AllowPerConfigDependencies 0
# PROP Scc_ProjName ""
# PROP Scc_LocalPath ""
CPP=cl.exe
RSC=rc.exe
!IF "$(CFG)" == "wxs - Win32 Release"
# PROP BASE Use_MFC 0
# PROP BASE Use_Debug_Libraries 0
# PROP BASE Output_Dir ".\Release"
# PROP BASE Intermediate_Dir ".\Release"
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
# PROP Use_Debug_Libraries 0
# PROP Output_Dir ".\Release"
# PROP Intermediate_Dir ".\Release"
# PROP Target_Dir ""
# ADD BASE CPP /nologo /W3 /GX /O2 /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /YX /c
# ADD CPP /nologo /MT /W3 /Zi /O2 /I "..\..\mzscheme\gc" /I "..\..\wxwindow\include\base" /I "..\..\wxwindow\include\msw" /I "..\..\mzscheme\include" /I "..\..\mred\wxme" /I "..\..\mzscheme\utils" /I "..\..\wxwindow\contrib\fafa" /D "NDEBUG" /D "__STDC__" /D "WIN32" /D "_WINDOWS" /D "__WINDOWS__" /YX"wx.h" /FD /c
# ADD BASE RSC /l 0x409
# ADD RSC /l 0x409
BSC32=bscmake.exe
# ADD BASE BSC32 /nologo
# ADD BSC32 /nologo
LIB32=link.exe -lib
# ADD BASE LIB32 /nologo
# ADD LIB32 /nologo
!ELSEIF "$(CFG)" == "wxs - Win32 Debug"
# PROP BASE Use_MFC 0
# PROP BASE Use_Debug_Libraries 1
# PROP BASE Output_Dir ".\Debug"
# PROP BASE Intermediate_Dir ".\Debug"
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
# PROP Use_Debug_Libraries 1
# PROP Output_Dir ".\Debug"
# PROP Intermediate_Dir ".\Debug"
# PROP Target_Dir ""
# ADD BASE CPP /nologo /W3 /GX /Z7 /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /YX /c
# ADD CPP /nologo /MTd /W3 /Gm /ZI /Od /I "..\..\mzscheme\gc" /I "..\..\wxwindow\include\base" /I "..\..\wxwindow\include\msw" /I "..\..\mzscheme\include" /I "..\..\mred\wxme" /I "..\..\mzscheme\utils" /I "..\..\wxwindow\contrib\fafa" /D "__DEBUG" /D "__STDC__" /D "WIN32" /D "_WINDOWS" /D "__WINDOWS__" /YX"wx.h" /FD /c
# ADD BASE RSC /l 0x409
# ADD RSC /l 0x409
BSC32=bscmake.exe
# ADD BASE BSC32 /nologo
# ADD BSC32 /nologo
LIB32=link.exe -lib
# ADD BASE LIB32 /nologo
# ADD LIB32 /nologo
!ELSEIF "$(CFG)" == "wxs - Win32 SGC"
# PROP BASE Use_MFC 0
# PROP BASE Use_Debug_Libraries 1
# PROP BASE Output_Dir ".\wxs___Wi"
# PROP BASE Intermediate_Dir ".\wxs___Wi"
# PROP BASE Target_Dir ""
# PROP Use_MFC 0
# PROP Use_Debug_Libraries 1
# PROP Output_Dir ".\SGC"
# PROP Intermediate_Dir ".\SGC"
# PROP Target_Dir ""
# ADD BASE CPP /nologo /W3 /Gm /Zi /Od /I "..\..\wxwindow\include\base" /I "..\..\wxwindow\include\msw" /I "..\..\mzscheme\include" /I "..\..\mzscheme\gc" /I "..\..\mred\wxme" /I "..\..\mzscheme\utils" /D "__DEBUG" /D "__STDC__" /D "WIN32" /D "_WINDOWS" /D "WXS_CANT_ASSIGN_STRUCTURES" /D "WINNT" /D "__WINDOWS__" /D "WXME_FOR_MRED" /YX /c
# ADD CPP /nologo /MTd /W3 /Gm /ZI /Od /I "..\..\mzscheme\sgc" /I "..\..\wxwindow\include\base" /I "..\..\wxwindow\include\msw" /I "..\..\mzscheme\include" /I "..\..\mred\wxme" /I "..\..\mzscheme\utils" /I "..\..\wxwindow\contrib\fafa" /D "__DEBUG" /D "__STDC__" /D "WIN32" /D "_WINDOWS" /D "__WINDOWS__" /D "USE_SENORA_GC" /YX"wx.h" /FD /c
# ADD BASE RSC /l 0x409
# ADD RSC /l 0x409
BSC32=bscmake.exe
# ADD BASE BSC32 /nologo
# ADD BSC32 /nologo
LIB32=link.exe -lib
# ADD BASE LIB32 /nologo
# ADD LIB32 /nologo
!ENDIF
# Begin Target
# Name "wxs - Win32 Release"
# Name "wxs - Win32 Debug"
# Name "wxs - Win32 SGC"
# Begin Group "Source Files"
# PROP Default_Filter "cpp;c;cxx;rc;def;r;odl;idl;hpj;bat;for;f90"
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_BMAP.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_BUTN.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_CHCE.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_CKBX.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_CNVS.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_DC.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_EVNT.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_FRAM.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_GAGE.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_GDI.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_GLOB.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_ITEM.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_LBOX.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_MADM.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_MEDE.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_MEDI.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_MENU.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_MIO.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_MISC.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_MPB.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_OBJ.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_PANL.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_RADO.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_SLID.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_SNIP.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_STYL.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXS_WIN.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\WXSCHEME.cxx
# End Source File
# End Group
# Begin Group "Header Files"
# PROP Default_Filter "h;hpp;hxx;hm;inl;fi;fd"
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_bmap.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_butn.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_chce.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_ckbx.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_cnvs.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_dc.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_evnt.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_fram.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_gage.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_gdi.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_glob.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_item.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_lbox.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_madm.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_mede.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_medi.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_menu.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_mio.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_misc.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_mpb.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_obj.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_panl.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_rado.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_slid.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_snip.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_styl.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_text.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxs_win.h
# End Source File
# Begin Source File
SOURCE=..\..\mred\Wxs\wxscheme.h
# End Source File
# End Group
# Begin Group "Resource Files"
# PROP Default_Filter "ico;cur;bmp;dlg;rc2;rct;bin;cnt;rtf;gif;jpg;jpeg;jpe"
# End Group
# End Target
# End Project

29
src/worksp/wxs/wxs.dsw
View File

@ -1,29 +0,0 @@
Microsoft Developer Studio Workspace File, Format Version 6.00
# WARNING: DO NOT EDIT OR DELETE THIS WORKSPACE FILE!
###############################################################################
Project: "wxs"=.\wxs.dsp - Package Owner=<4>
Package=<5>
{{{
}}}
Package=<4>
{{{
}}}
###############################################################################
Global:
Package=<5>
{{{
}}}
Package=<3>
{{{
}}}
###############################################################################

578
src/worksp/wxs/wxs.mak
View File

@ -1,578 +0,0 @@
# Microsoft Developer Studio Generated NMAKE File, Based on wxs.dsp
!IF "$(CFG)" == ""
CFG=wxs - Win32 Release
!MESSAGE No configuration specified. Defaulting to wxs - Win32 Release.
!ENDIF
!IF "$(CFG)" != "wxs - Win32 Release" && "$(CFG)" != "wxs - Win32 Debug" && "$(CFG)" != "wxs - Win32 SGC"
!MESSAGE Invalid configuration "$(CFG)" specified.
!MESSAGE You can specify a configuration when running NMAKE
!MESSAGE by defining the macro CFG on the command line. For example:
!MESSAGE
!MESSAGE NMAKE /f "wxs.mak" CFG="wxs - Win32 Release"
!MESSAGE
!MESSAGE Possible choices for configuration are:
!MESSAGE
!MESSAGE "wxs - Win32 Release" (based on "Win32 (x86) Static Library")
!MESSAGE "wxs - Win32 Debug" (based on "Win32 (x86) Static Library")
!MESSAGE "wxs - Win32 SGC" (based on "Win32 (x86) Static Library")
!MESSAGE
!ERROR An invalid configuration is specified.
!ENDIF
!IF "$(OS)" == "Windows_NT"
NULL=
!ELSE
NULL=nul
!ENDIF
!IF "$(CFG)" == "wxs - Win32 Release"
OUTDIR=.\Release
INTDIR=.\Release
# Begin Custom Macros
OutDir=.\Release
# End Custom Macros
ALL : "$(OUTDIR)\wxs.lib"
CLEAN :
-@erase "$(INTDIR)\vc60.idb"
-@erase "$(INTDIR)\vc60.pdb"
-@erase "$(INTDIR)\WXS_BMAP.obj"
-@erase "$(INTDIR)\WXS_BUTN.obj"
-@erase "$(INTDIR)\WXS_CHCE.obj"
-@erase "$(INTDIR)\WXS_CKBX.obj"
-@erase "$(INTDIR)\WXS_CNVS.obj"
-@erase "$(INTDIR)\WXS_DC.obj"
-@erase "$(INTDIR)\WXS_EVNT.obj"
-@erase "$(INTDIR)\WXS_FRAM.obj"
-@erase "$(INTDIR)\WXS_GAGE.obj"
-@erase "$(INTDIR)\WXS_GDI.obj"
-@erase "$(INTDIR)\WXS_GLOB.obj"
-@erase "$(INTDIR)\WXS_ITEM.obj"
-@erase "$(INTDIR)\WXS_LBOX.obj"
-@erase "$(INTDIR)\WXS_MADM.obj"
-@erase "$(INTDIR)\WXS_MEDE.obj"
-@erase "$(INTDIR)\WXS_MEDI.obj"
-@erase "$(INTDIR)\WXS_MENU.obj"
-@erase "$(INTDIR)\WXS_MIO.obj"
-@erase "$(INTDIR)\WXS_MISC.obj"
-@erase "$(INTDIR)\WXS_MPB.obj"
-@erase "$(INTDIR)\WXS_OBJ.obj"
-@erase "$(INTDIR)\WXS_PANL.obj"
-@erase "$(INTDIR)\WXS_RADO.obj"
-@erase "$(INTDIR)\WXS_SLID.obj"
-@erase "$(INTDIR)\WXS_SNIP.obj"
-@erase "$(INTDIR)\WXS_STYL.obj"
-@erase "$(INTDIR)\WXS_WIN.obj"
-@erase "$(INTDIR)\WXSCHEME.obj"
-@erase "$(OUTDIR)\wxs.lib"
"$(OUTDIR)" :
if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"
CPP=cl.exe
CPP_PROJ=/nologo /MT /W3 /Zi /O2 /I "..\..\mzscheme\gc" /I "..\..\wxwindow\include\base" /I "..\..\wxwindow\include\msw" /I "..\..\mzscheme\include" /I "..\..\mred\wxme" /I "..\..\mzscheme\utils" /I "..\..\wxwindow\contrib\fafa" /D "NDEBUG" /D "__STDC__" /D "WIN32" /D "_WINDOWS" /D "__WINDOWS__" /Fp"$(INTDIR)\wxs.pch" /YX"wx.h" /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /c
.c{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.c{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
RSC=rc.exe
BSC32=bscmake.exe
BSC32_FLAGS=/nologo /o"$(OUTDIR)\wxs.bsc"
BSC32_SBRS= \
LIB32=link.exe -lib
LIB32_FLAGS=/nologo /out:"$(OUTDIR)\wxs.lib"
LIB32_OBJS= \
"$(INTDIR)\WXS_BMAP.obj" \
"$(INTDIR)\WXS_BUTN.obj" \
"$(INTDIR)\WXS_CHCE.obj" \
"$(INTDIR)\WXS_CKBX.obj" \
"$(INTDIR)\WXS_CNVS.obj" \
"$(INTDIR)\WXS_DC.obj" \
"$(INTDIR)\WXS_EVNT.obj" \
"$(INTDIR)\WXS_FRAM.obj" \
"$(INTDIR)\WXS_GAGE.obj" \
"$(INTDIR)\WXS_GDI.obj" \
"$(INTDIR)\WXS_GLOB.obj" \
"$(INTDIR)\WXS_ITEM.obj" \
"$(INTDIR)\WXS_LBOX.obj" \
"$(INTDIR)\WXS_MADM.obj" \
"$(INTDIR)\WXS_MEDE.obj" \
"$(INTDIR)\WXS_MEDI.obj" \
"$(INTDIR)\WXS_MENU.obj" \
"$(INTDIR)\WXS_MIO.obj" \
"$(INTDIR)\WXS_MISC.obj" \
"$(INTDIR)\WXS_MPB.obj" \
"$(INTDIR)\WXS_OBJ.obj" \
"$(INTDIR)\WXS_PANL.obj" \
"$(INTDIR)\WXS_RADO.obj" \
"$(INTDIR)\WXS_SLID.obj" \
"$(INTDIR)\WXS_SNIP.obj" \
"$(INTDIR)\WXS_STYL.obj" \
"$(INTDIR)\WXS_WIN.obj" \
"$(INTDIR)\WXSCHEME.obj"
"$(OUTDIR)\wxs.lib" : "$(OUTDIR)" $(DEF_FILE) $(LIB32_OBJS)
$(LIB32) @<<
$(LIB32_FLAGS) $(DEF_FLAGS) $(LIB32_OBJS)
<<
!ELSEIF "$(CFG)" == "wxs - Win32 Debug"
OUTDIR=.\Debug
INTDIR=.\Debug
# Begin Custom Macros
OutDir=.\Debug
# End Custom Macros
ALL : "$(OUTDIR)\wxs.lib"
CLEAN :
-@erase "$(INTDIR)\vc60.idb"
-@erase "$(INTDIR)\vc60.pdb"
-@erase "$(INTDIR)\WXS_BMAP.obj"
-@erase "$(INTDIR)\WXS_BUTN.obj"
-@erase "$(INTDIR)\WXS_CHCE.obj"
-@erase "$(INTDIR)\WXS_CKBX.obj"
-@erase "$(INTDIR)\WXS_CNVS.obj"
-@erase "$(INTDIR)\WXS_DC.obj"
-@erase "$(INTDIR)\WXS_EVNT.obj"
-@erase "$(INTDIR)\WXS_FRAM.obj"
-@erase "$(INTDIR)\WXS_GAGE.obj"
-@erase "$(INTDIR)\WXS_GDI.obj"
-@erase "$(INTDIR)\WXS_GLOB.obj"
-@erase "$(INTDIR)\WXS_ITEM.obj"
-@erase "$(INTDIR)\WXS_LBOX.obj"
-@erase "$(INTDIR)\WXS_MADM.obj"
-@erase "$(INTDIR)\WXS_MEDE.obj"
-@erase "$(INTDIR)\WXS_MEDI.obj"
-@erase "$(INTDIR)\WXS_MENU.obj"
-@erase "$(INTDIR)\WXS_MIO.obj"
-@erase "$(INTDIR)\WXS_MISC.obj"
-@erase "$(INTDIR)\WXS_MPB.obj"
-@erase "$(INTDIR)\WXS_OBJ.obj"
-@erase "$(INTDIR)\WXS_PANL.obj"
-@erase "$(INTDIR)\WXS_RADO.obj"
-@erase "$(INTDIR)\WXS_SLID.obj"
-@erase "$(INTDIR)\WXS_SNIP.obj"
-@erase "$(INTDIR)\WXS_STYL.obj"
-@erase "$(INTDIR)\WXS_WIN.obj"
-@erase "$(INTDIR)\WXSCHEME.obj"
-@erase "$(OUTDIR)\wxs.lib"
"$(OUTDIR)" :
if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"
CPP=cl.exe
CPP_PROJ=/nologo /MTd /W3 /Gm /ZI /Od /I "..\..\mzscheme\gc" /I "..\..\wxwindow\include\base" /I "..\..\wxwindow\include\msw" /I "..\..\mzscheme\include" /I "..\..\mred\wxme" /I "..\..\mzscheme\utils" /I "..\..\wxwindow\contrib\fafa" /D "__DEBUG" /D "__STDC__" /D "WIN32" /D "_WINDOWS" /D "__WINDOWS__" /Fp"$(INTDIR)\wxs.pch" /YX"wx.h" /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /c
.c{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.c{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
RSC=rc.exe
BSC32=bscmake.exe
BSC32_FLAGS=/nologo /o"$(OUTDIR)\wxs.bsc"
BSC32_SBRS= \
LIB32=link.exe -lib
LIB32_FLAGS=/nologo /out:"$(OUTDIR)\wxs.lib"
LIB32_OBJS= \
"$(INTDIR)\WXS_BMAP.obj" \
"$(INTDIR)\WXS_BUTN.obj" \
"$(INTDIR)\WXS_CHCE.obj" \
"$(INTDIR)\WXS_CKBX.obj" \
"$(INTDIR)\WXS_CNVS.obj" \
"$(INTDIR)\WXS_DC.obj" \
"$(INTDIR)\WXS_EVNT.obj" \
"$(INTDIR)\WXS_FRAM.obj" \
"$(INTDIR)\WXS_GAGE.obj" \
"$(INTDIR)\WXS_GDI.obj" \
"$(INTDIR)\WXS_GLOB.obj" \
"$(INTDIR)\WXS_ITEM.obj" \
"$(INTDIR)\WXS_LBOX.obj" \
"$(INTDIR)\WXS_MADM.obj" \
"$(INTDIR)\WXS_MEDE.obj" \
"$(INTDIR)\WXS_MEDI.obj" \
"$(INTDIR)\WXS_MENU.obj" \
"$(INTDIR)\WXS_MIO.obj" \
"$(INTDIR)\WXS_MISC.obj" \
"$(INTDIR)\WXS_MPB.obj" \
"$(INTDIR)\WXS_OBJ.obj" \
"$(INTDIR)\WXS_PANL.obj" \
"$(INTDIR)\WXS_RADO.obj" \
"$(INTDIR)\WXS_SLID.obj" \
"$(INTDIR)\WXS_SNIP.obj" \
"$(INTDIR)\WXS_STYL.obj" \
"$(INTDIR)\WXS_WIN.obj" \
"$(INTDIR)\WXSCHEME.obj"
"$(OUTDIR)\wxs.lib" : "$(OUTDIR)" $(DEF_FILE) $(LIB32_OBJS)
$(LIB32) @<<
$(LIB32_FLAGS) $(DEF_FLAGS) $(LIB32_OBJS)
<<
!ELSEIF "$(CFG)" == "wxs - Win32 SGC"
OUTDIR=.\SGC
INTDIR=.\SGC
# Begin Custom Macros
OutDir=.\SGC
# End Custom Macros
ALL : "$(OUTDIR)\wxs.lib"
CLEAN :
-@erase "$(INTDIR)\vc60.idb"
-@erase "$(INTDIR)\vc60.pdb"
-@erase "$(INTDIR)\WXS_BMAP.obj"
-@erase "$(INTDIR)\WXS_BUTN.obj"
-@erase "$(INTDIR)\WXS_CHCE.obj"
-@erase "$(INTDIR)\WXS_CKBX.obj"
-@erase "$(INTDIR)\WXS_CNVS.obj"
-@erase "$(INTDIR)\WXS_DC.obj"
-@erase "$(INTDIR)\WXS_EVNT.obj"
-@erase "$(INTDIR)\WXS_FRAM.obj"
-@erase "$(INTDIR)\WXS_GAGE.obj"
-@erase "$(INTDIR)\WXS_GDI.obj"
-@erase "$(INTDIR)\WXS_GLOB.obj"
-@erase "$(INTDIR)\WXS_ITEM.obj"
-@erase "$(INTDIR)\WXS_LBOX.obj"
-@erase "$(INTDIR)\WXS_MADM.obj"
-@erase "$(INTDIR)\WXS_MEDE.obj"
-@erase "$(INTDIR)\WXS_MEDI.obj"
-@erase "$(INTDIR)\WXS_MENU.obj"
-@erase "$(INTDIR)\WXS_MIO.obj"
-@erase "$(INTDIR)\WXS_MISC.obj"
-@erase "$(INTDIR)\WXS_MPB.obj"
-@erase "$(INTDIR)\WXS_OBJ.obj"
-@erase "$(INTDIR)\WXS_PANL.obj"
-@erase "$(INTDIR)\WXS_RADO.obj"
-@erase "$(INTDIR)\WXS_SLID.obj"
-@erase "$(INTDIR)\WXS_SNIP.obj"
-@erase "$(INTDIR)\WXS_STYL.obj"
-@erase "$(INTDIR)\WXS_WIN.obj"
-@erase "$(INTDIR)\WXSCHEME.obj"
-@erase "$(OUTDIR)\wxs.lib"
"$(OUTDIR)" :
if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"
CPP=cl.exe
CPP_PROJ=/nologo /MTd /W3 /Gm /ZI /Od /I "..\..\mzscheme\sgc" /I "..\..\wxwindow\include\base" /I "..\..\wxwindow\include\msw" /I "..\..\mzscheme\include" /I "..\..\mred\wxme" /I "..\..\mzscheme\utils" /I "..\..\wxwindow\contrib\fafa" /D "__DEBUG" /D "__STDC__" /D "WIN32" /D "_WINDOWS" /D "__WINDOWS__" /D "USE_SENORA_GC" /Fp"$(INTDIR)\wxs.pch" /YX"wx.h" /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /c
.c{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.obj::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.c{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cpp{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
.cxx{$(INTDIR)}.sbr::
$(CPP) @<<
$(CPP_PROJ) $<
<<
RSC=rc.exe
BSC32=bscmake.exe
BSC32_FLAGS=/nologo /o"$(OUTDIR)\wxs.bsc"
BSC32_SBRS= \
LIB32=link.exe -lib
LIB32_FLAGS=/nologo /out:"$(OUTDIR)\wxs.lib"
LIB32_OBJS= \
"$(INTDIR)\WXS_BMAP.obj" \
"$(INTDIR)\WXS_BUTN.obj" \
"$(INTDIR)\WXS_CHCE.obj" \
"$(INTDIR)\WXS_CKBX.obj" \
"$(INTDIR)\WXS_CNVS.obj" \
"$(INTDIR)\WXS_DC.obj" \
"$(INTDIR)\WXS_EVNT.obj" \
"$(INTDIR)\WXS_FRAM.obj" \
"$(INTDIR)\WXS_GAGE.obj" \
"$(INTDIR)\WXS_GDI.obj" \
"$(INTDIR)\WXS_GLOB.obj" \
"$(INTDIR)\WXS_ITEM.obj" \
"$(INTDIR)\WXS_LBOX.obj" \
"$(INTDIR)\WXS_MADM.obj" \
"$(INTDIR)\WXS_MEDE.obj" \
"$(INTDIR)\WXS_MEDI.obj" \
"$(INTDIR)\WXS_MENU.obj" \
"$(INTDIR)\WXS_MIO.obj" \
"$(INTDIR)\WXS_MISC.obj" \
"$(INTDIR)\WXS_MPB.obj" \
"$(INTDIR)\WXS_OBJ.obj" \
"$(INTDIR)\WXS_PANL.obj" \
"$(INTDIR)\WXS_RADO.obj" \
"$(INTDIR)\WXS_SLID.obj" \
"$(INTDIR)\WXS_SNIP.obj" \
"$(INTDIR)\WXS_STYL.obj" \
"$(INTDIR)\WXS_WIN.obj" \
"$(INTDIR)\WXSCHEME.obj"
"$(OUTDIR)\wxs.lib" : "$(OUTDIR)" $(DEF_FILE) $(LIB32_OBJS)
$(LIB32) @<<
$(LIB32_FLAGS) $(DEF_FLAGS) $(LIB32_OBJS)
<<
!ENDIF
!IF "$(NO_EXTERNAL_DEPS)" != "1"
!IF EXISTS("wxs.dep")
!INCLUDE "wxs.dep"
!ELSE
!MESSAGE Warning: cannot find "wxs.dep"
!ENDIF
!ENDIF
!IF "$(CFG)" == "wxs - Win32 Release" || "$(CFG)" == "wxs - Win32 Debug" || "$(CFG)" == "wxs - Win32 SGC"
SOURCE=..\..\mred\Wxs\WXS_BMAP.cxx
"$(INTDIR)\WXS_BMAP.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_BUTN.cxx
"$(INTDIR)\WXS_BUTN.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_CHCE.cxx
"$(INTDIR)\WXS_CHCE.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_CKBX.cxx
"$(INTDIR)\WXS_CKBX.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_CNVS.cxx
"$(INTDIR)\WXS_CNVS.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_DC.cxx
"$(INTDIR)\WXS_DC.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_EVNT.cxx
"$(INTDIR)\WXS_EVNT.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_FRAM.cxx
"$(INTDIR)\WXS_FRAM.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_GAGE.cxx
"$(INTDIR)\WXS_GAGE.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_GDI.cxx
"$(INTDIR)\WXS_GDI.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_GLOB.cxx
"$(INTDIR)\WXS_GLOB.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_ITEM.cxx
"$(INTDIR)\WXS_ITEM.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_LBOX.cxx
"$(INTDIR)\WXS_LBOX.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_MADM.cxx
"$(INTDIR)\WXS_MADM.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_MEDE.cxx
"$(INTDIR)\WXS_MEDE.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_MEDI.cxx
"$(INTDIR)\WXS_MEDI.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_MENU.cxx
"$(INTDIR)\WXS_MENU.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_MIO.cxx
"$(INTDIR)\WXS_MIO.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_MISC.cxx
"$(INTDIR)\WXS_MISC.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_MPB.cxx
"$(INTDIR)\WXS_MPB.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_OBJ.cxx
"$(INTDIR)\WXS_OBJ.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_PANL.cxx
"$(INTDIR)\WXS_PANL.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_RADO.cxx
"$(INTDIR)\WXS_RADO.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_SLID.cxx
"$(INTDIR)\WXS_SLID.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_SNIP.cxx
"$(INTDIR)\WXS_SNIP.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_STYL.cxx
"$(INTDIR)\WXS_STYL.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXS_WIN.cxx
"$(INTDIR)\WXS_WIN.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=..\..\mred\Wxs\WXSCHEME.cxx
"$(INTDIR)\WXSCHEME.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
!ENDIF