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

.

Browse Source 
original commit: 1e6ac0c8a82f44bdcad256f31e68850f37917c32
This commit is contained in:
Matthew Flatt 2000-05-30 23:01:44 +00:00
parent 77ff01e352
commit 325eb2b1e9
42 changed files with 7005 additions and 6383 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/mzlib/shared.ss Normal file
View File

@ -0,0 +1,14 @@
(begin-elaboration-time
(require-library "functios.ss"))
(begin-elaboration-time
(require-library "invoke.ss"))
(begin-elaboration-time
(define-values/invoke-unit (shared)
(require-library "sharedr.ss")))
(define-macro shared shared)

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

Binary file not shown.

687
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
([(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,187 @@
; 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
(begin
(printf "debug-info: ~n~a~n"
(make-debug-info-app (binding-set-union tail-bound binding-list)
(binding-set-union free-bindings-inner binding-list)
'let-body))
(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
([(bindings) (z:define-values-form-vars expr)]
[(_1) (map utils:check-for-keyword bindings)]
[(binding-names) (map z:binding-var bindings)]
; 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)]
[(free-bindings) (remq* bindings free-bindings-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)]
[(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)]
[else
(values `(#%define-values ,var-names
(values `(#%define-values ,binding-names
,annotated-val)
free-vars)]))]
free-bindings)]))]
[(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
([(v) (translate-varref (z:set!-form-var expr))]
[(annotated-body rhs-free-bindings)
(non-tail-recur (z:set!-form-val expr))]
[(free-bindings) (binding-set-union (list (z:set!-form-var expr)) 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 +673,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 +718,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 +750,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 +764,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 +787,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 +798,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 +807,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 +816,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 +842,6 @@
null))]
[else
(print-struct #t)
(e:internal-error
expr
"stepper:annotate/inner: unknown object to annotate, ~a~n"
@ -869,5 +858,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)])))))

4
collects/stepper/model.ss
View File

@ -174,9 +174,9 @@
(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)

64
collects/stepper/reconstructr.ss
View File

@ -85,8 +85,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,30 +136,27 @@
(or (z:lambda-varref? expr)
(let ([var (z:varref-var expr)])
(with-handlers
();[exn:variable? (lambda args (printf "c~n") #f)])
([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")
(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))))])
(printf "past lookup-binding~n")
(and (procedure? val)
(not (continuation? val))
(eq? var
(closure-record-name
(closure-table-lookup val (lambda () #f)))))))))))
(and (z:app? expr)
(printf "into app~n")
(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 +177,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 +199,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,14 +407,15 @@
(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])
@ -436,8 +438,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 +456,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 +502,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)))]
@ -573,10 +572,9 @@
(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 (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)]
[reduct (rectify-source-expr body mark-list null)]

106
collects/stepper/sharedr.ss
View File

@ -24,68 +24,62 @@
; 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)])
(printf "looked up name: ~a~n" name)
(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 +93,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

19
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

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)

441
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
--------
@ -618,109 +626,112 @@ 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 +751,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"))

20
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.206 2000/05/28 03:47:31 shriram Exp $
(unit/sig zodiac:scheme-main^
(import zodiac:misc^ zodiac:structures^
@ -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?)))

2
notes/drscheme/HISTORY
View File

@ -21,8 +21,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

2
src/configure vendored
View File

@ -2073,7 +2073,7 @@ if test "${enable_wbuild}" = "yes" ; then
WBUILD="$WBUILD -p . \$(srcdir)/x/wbuild/wbuild.cfg"
else
MAKE_WBUILD=
WBUILD="sh \$(PLTSRCDIR)/wxxt/src/XWidgets/dummy.wbuild"
WBUILD="bash \$(PLTSRCDIR)/wxxt/src/XWidgets/dummy.wbuild"
fi
############## platform tests ################

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)

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

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

@ -711,7 +711,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 +1258,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;
@ -1273,7 +1272,7 @@ void wxMediaBuffer::Print(Bool interactive, Bool fitToPage, int WXUNUSED_X(outpu
wxDC *dc;
void *data;
dc = new wxPostScriptDC(interactive);
dc = new wxPostScriptDC(interactive, parent);
if (dc->Ok()) {
dc->StartDoc("Printing buffer");
@ -1300,7 +1299,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

2
src/mzscheme/configure.in
View File

@ -150,7 +150,7 @@ if test "${enable_wbuild}" = "yes" ; then
WBUILD="$WBUILD -p . \$(srcdir)/x/wbuild/wbuild.cfg"
else
MAKE_WBUILD=
WBUILD="sh \$(PLTSRCDIR)/wxxt/src/XWidgets/dummy.wbuild"
WBUILD="bash \$(PLTSRCDIR)/wxxt/src/XWidgets/dummy.wbuild"
fi
############## platform tests ################

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':

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