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

.

Browse Source 
original commit: c61f236664a77b3fa8bb125499f2610996b8434b
This commit is contained in:
Matthew Flatt 2000-05-28 16:27:32 +00:00
parent 7a30577958
commit 8c7c450f29
61 changed files with 3271 additions and 1779 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

49
collects/mzlib/traceldr.ss
View File

@ -1,49 +0,0 @@
(unit/sig
()
(import)
(let ([load (current-load)]
[load-extension (current-load-extension)]
[ep (current-error-port)]
[tab ""])
(let ([mk-chain
(lambda (load)
(lambda (filename)
(fprintf ep
"~aloading ~a at ~a~n"
tab filename (current-process-milliseconds))
(begin0
(let ([s tab])
(dynamic-wind
(lambda () (set! tab (string-append " " tab)))
(lambda ()
(if (regexp-match "_loader" filename)
(let ([f (load filename)])
(lambda (sym)
(fprintf ep
"~atrying ~a's ~a~n" tab filename sym)
(let ([loader (f sym)])
(and loader
(lambda ()
(fprintf ep
"~astarting ~a's ~a at ~a~n"
tab filename sym
(current-process-milliseconds))
(let ([s tab])
(begin0
(dynamic-wind
(lambda () (set! tab (string-append " " tab)))
(lambda () (loader))
(lambda () (set! tab s)))
(fprintf ep
"~adone ~a's ~a at ~a~n"
tab filename sym
(current-process-milliseconds)))))))))
(load filename)))
(lambda () (set! tab s))))
(fprintf ep
"~adone ~a at ~a~n"
tab filename (current-process-milliseconds)))))])
(current-load (mk-chain load))
(current-load-extension (mk-chain load-extension)))))

8
collects/mzlib/transcr.ss
View File

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

2
collects/mzscheme/include/schvers.h
View File

@ -5,4 +5,4 @@
# define SPECIAL_TAG ""
#endif
#define VERSION "102/13" SPECIAL_TAG
#define VERSION "102" SPECIAL_TAG

19
collects/mzscheme/include/sconfig.h
View File

@ -233,6 +233,9 @@ int scheme_solaris_semaphore_try_down(void *);
# if defined(__mc68000__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "m68k-linux"
# endif
# if defined(__alpha__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "alpha-linux"
# endif
# ifndef SCHEME_PLATFORM_LIBRARY_SUBPATH
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "unknown-linux"
# endif
@ -249,6 +252,10 @@ int scheme_solaris_semaphore_try_down(void *);
# define STACK_GROWS_DOWN
# if defined(__alpha)
# define SIXTY_FOUR_BIT_INTEGERS
# endif
# define USE_IEEE_FP_PREDS
# define USE_EXPLICT_FP_FORM_CHECK
@ -403,7 +410,7 @@ int scheme_solaris_semaphore_try_down(void *);
# define BSTRING_INCLUDE
# define DEFEAT_FP_COMP_OPTIMIZATION
# define POW_HANDLES_INF_CORRECTLY
# define FMOD_CAN_RETURN_NEG_ZERO
# define NO_INLINE_KEYWORD
@ -490,7 +497,7 @@ int scheme_sproc_semaphore_try_down(void *);
/************** ALPHA/OSF1 with gcc ****************/
#if defined(__alpha)
#if defined(__digital__) && defined(__unix__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "alpha-osf1"
@ -520,6 +527,7 @@ int scheme_sproc_semaphore_try_down(void *);
# define STACK_GROWS_UP
# define SOME_FDS_ARE_NOT_SELECTABLE
# define USE_FCNTL_O_NONBLOCK
# define USE_SYSCALL_GETRUSAGE
@ -527,6 +535,7 @@ int scheme_sproc_semaphore_try_down(void *);
# define USE_IEEE_FP_PREDS
# define USE_EXPLICT_FP_FORM_CHECK
# define ZERO_MINUS_ZERO_IS_POS_ZERO
# define LOG_ZERO_ISNT_NEG_INF
# define NO_INLINE_KEYWORD
@ -1208,6 +1217,12 @@ int scheme_pthread_semaphore_try_down(void *);
/* TRIG_ZERO_NEEDS_SIGN_CHECK defines versions of tan, sin, atan, and
asin that preserve the sign of a zero argument. */
/* FMOD_CAN_RETURN_NEG_ZERO is fmod() on positive numbers can produce
a negative zero. */
/* LOG_ZERO_ISNT_NEG_INF defines a version of log that checks for an
inexact zero argument and return negative infinity. */
/***********************/
/* Stack Maniuplations */
/***********************/

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

Binary file not shown.

29
collects/stepper/annotater.ss
View File

@ -191,6 +191,10 @@
`(#%begin (,(make-break 'normal)) ,expr)
expr))
(define (double-break-wrap expr)
(if break
`(#%begin (,(make-break 'double)) ,expr)))
(define (simple-wcm-break-wrap debug-info expr)
(simple-wcm-wrap debug-info (break-wrap expr)))
@ -275,7 +279,9 @@
[define-values-recur (lambda (expr) (annotate/inner expr tail-bound #f #f))]
[non-tail-recur (lambda (expr) (annotate/inner expr null #f #f))]
[lambda-body-recur (lambda (expr) (annotate/inner expr 'all #t #f))]
[let-body-recur (lambda (expr vars) (annotate/inner expr (var-set-union tail-bound vars) #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))]
[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))]
@ -438,7 +444,7 @@
(let+ ([val bodies (z:begin-form-bodies expr)]
[val (values annotated-bodies free-vars)
(dual-map (lambda (expr)
(annotate/inner expr 'all #f #t))
(annotate/inner expr 'all #f #t))
bodies)])
(values `(#%begin ,@annotated-bodies)
(apply var-set-union free-vars)))
@ -487,6 +493,15 @@
; e3))))
;
; let me know if you can do it in less.
; another irritating point: the mark and the break that must go immediately
; around the body. Irritating because they will be instantly replaced by
; the mark and the break produced by the annotated body itself. However,
; they're necessary, because the body may not contain free references to
; all of the variables defined in the let, and thus their values are not
; known otherwise.
; whoops! hold the phone. I think I can get away with a break before, and
; 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)]
@ -534,11 +549,11 @@
[val inner-let-values
`(#%let-values ,inner-transference ,annotated-body)]
[val middle-begin
`(#%begin ,@set!-clauses ,inner-let-values)]
`(#%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)
'none)
'let-body)
middle-begin)]
[val whole-thing
`(#%let-values ,outer-dummy-initialization ,wrapped-begin)])
@ -578,17 +593,17 @@
var-sets
annotated-vals)]
[val middle-begin
`(#%begin ,@set!-clauses ,annotated-body)]
`(#%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)
'none)
'let-body)
middle-begin)]
[val whole-thing
`(#%letrec-values ,outer-initialization ,wrapped-begin)])
(values whole-thing free-vars-outer))))]
[(z:define-values-form? expr)
[(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)]

11
collects/stepper/doc.txt
View File

@ -1,15 +1,14 @@
What is the _Foot_?
What is the _Stepper_?
The Foot is a "stepper," which means that it proceeds through the
DrScheme includes an "algebraic stepper," a tool which proceeds through the
evaluation of a set of definitions and expressions, one step at a time.
This evaluation shows the user how DrScheme evaluates expressions and
definitions, and can help in debugging programs. Currently, the Foot is
available only in the "Beginner" language level.
definitions, and can help in debugging programs. Currently, the Stepper is
available in the "Beginner" and "Intermediate" language levels.
How do I use the Foot?
How do I use the Stepper?
The Foot operates on the contents of the frontmost DrScheme window. A click
The Stepper operates on the contents of the frontmost DrScheme window. A click
on the "Step" button brings up the stepper window. The stepper window has
three boxes; each one is separated by a blue horizontal line.

8
collects/stepper/marks.ss
View File

@ -67,18 +67,18 @@
(printf " ~a : ~a~n" (car binding-pair) (cadr binding-pair)))
(caddr exposed))))
(define (find-var-binding mark-list var)
(define (lookup-var-binding mark-list var)
(if (null? mark-list)
; must be a primitive
(error 'find-var-binding "variable not found in environment: ~a" var)
(error 'lookup-var-binding "variable not found in environment: ~a" var)
; (error var "no binding found for variable.")
(let* ([bindings (mark-bindings (car mark-list))]
[matches (filter (lambda (mark-var)
(eq? var (z:varref-var (mark-binding-varref mark-var))))
bindings)])
(cond [(null? matches)
(find-var-binding (cdr mark-list) var)]
(lookup-var-binding (cdr mark-list) var)]
[(> (length matches) 1)
(error 'find-var-binding "more than one variable binding found for var: ~a" var)]
(error 'lookup-var-binding "more than one variable binding found for var: ~a" var)]
[else ; (length matches) = 1
(car matches)])))))

28
collects/stepper/model.ss
View File

@ -205,10 +205,7 @@
(send-to-drscheme-eventspace
(lambda ()
(let* ([reconstruct-pair
(r:reconstruct-current current-expr
mark-list
break-kind
returned-value-list)]
(r:reconstruct-current current-expr mark-list break-kind returned-value-list)]
[reconstructed (car reconstruct-pair)]
[redex (cadr reconstruct-pair)])
(finish-thunk reconstructed redex)))))])
@ -222,10 +219,9 @@
(continue-user-computation)))
(suspend-user-computation))]
[(result-break)
(when (if (not (null? returned-value-list))
(not (r:skip-redex-step? mark-list))
(and (not (eq? held-expr no-sexp))
(not (r:skip-result-step? mark-list))))
(when (not (or (r:skip-redex-step? mark-list)
(and (null? returned-value-list)
(eq? held-expr no-sexp))))
(reconstruct-helper
(lambda (reconstructed reduct)
; ; this invariant (contexts should be the same)
@ -246,7 +242,21 @@
(set! held-expr no-sexp)
(set! held-redex no-sexp)
(i:receive-result result))))
(suspend-user-computation))])))
(suspend-user-computation))]
[(double)
; a double-break occurs at the beginning of a let's body.
(send-to-drscheme-eventspace
(lambda ()
(let* ([reconstruct-quadruple
(r:reconstruct-current current-expr mark-list)])
(set! finished-exprs (append finished-exprs (caddr reconstruct-quadruple)))
(when (not (eq? held-expr no-expr))
(e:internal-error 'break-reconstruction
"held-expr not empty when a double-break occurred"))
(i:receive-result (apply make-before-after-result
finished-exprs
reconstruct-quadruple)))))
(suspend-user-computation)])))
(define (handle-exception exn)
(if held-expr

232
collects/stepper/reconstructr.ss
View File

@ -62,6 +62,32 @@
(define comes-from-or?
(make-check-raw-first-symbol 'or))
; the lifted-names table maps bindings to numbers. the number,
; essentially, is how we avoid clashes. So, if a binding with
; the original name "foo" is associated with the number "2",
; the lifted name will be "~foo~2". Note that you _need_
; that second tilde; otherwise there could be an overlap,
; e.g. (foo 12) => ~foo12, (foo1 2) => ~foo12.
(define lifted-names-table (make-hash-table-weak))
(define (insert-lifted-name binding)
(let* ([binding-name (z:binding-orig-name binding)]
[matching (filter
(lambda (key&val) (eq? (car key&val) binding-name))
(hash-table-map lifted-names-table (lambda (key val) (list (z:binding-orig-name key) val))))]
[matching-nums (map cadr matching)]
[free-num (let loop ([try-index 0])
(if (memq try-index matching-nums)
(loop (+ try-index 1))
try-index))])
(hash-table-put! lifted-names-table binding free-num)
(string->symbol (string-append "~" binding-name "~" (num->string free-num)))))
(define (lookup-lifted-name binding)
(string->symbol (string-append "~" (z:binding-orig-name binding) "~"
(num->string (hash-table-get lifted-names-table binding)))))
(define (rectify-value val)
(let ([closure-record (closure-table-lookup val (lambda () #f))])
(cond
@ -103,7 +129,7 @@
(and (pair? mark-list)
(let ([expr (mark-source (car mark-list))])
(or (and (z:varref? expr)
(or (z:bound-varref? expr)
(or (z:lambda-varref? expr)
(let ([var (z:varref-var expr)])
(with-handlers
([exn:variable? (lambda args #f)])
@ -152,17 +178,21 @@
(not (z:if-form? expr))
(comes-from-cond? expr))
(in-inserted-else-clause (cdr mark-list))))))
(define (rectify-source-expr expr mark-list lexically-bound-vars)
(let ([recur (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-vars))])
; rectify-source-expr (z:parsed (ListOf Mark) (ListOf z:binding) -> sexp)
(define (rectify-source-expr expr mark-list lexically-bound-bindings)
(let ([recur (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-bindings))])
(cond [(z:varref? expr)
(cond [(memq (z:varref-var expr) lexically-bound-vars)
(z:binding-orig-name (z:bound-varref-binding expr))]
(cond [(z:bound-varref? expr)
(let ([binding (z:bound-varref-binding expr)])
(if (memq binding lexically-bound-bindings)
(z:binding-orig-name binding)
(if (z:lambda-binding? expr)
(rectify-value (mark-binding-value (lookup-var-binding (z:varref-var expr))))
(lookup-lifted-name binding))))]
[(z:top-level-varref? expr)
(z:varref-var expr)]
[else
(rectify-value (mark-binding-value (find-var-binding mark-list
(z:varref-var expr))))])]
(z:varref-var expr)])]
[(z:app? expr)
(map recur (cons (z:app-fun expr) (z:app-args expr)))]
@ -181,11 +211,11 @@
[(z:if-form? expr)
(cond
[(comes-from-cond? expr)
`(cond ,@(rectify-cond-clauses (z:zodiac-start expr) expr mark-list lexically-bound-vars))]
`(cond ,@(rectify-cond-clauses (z:zodiac-start expr) expr mark-list lexically-bound-bindings))]
[(comes-from-and? expr)
`(and ,@(rectify-and-clauses (z:zodiac-start expr) expr mark-list lexically-bound-vars))]
`(and ,@(rectify-and-clauses (z:zodiac-start expr) expr mark-list lexically-bound-bindings))]
[(comes-from-or? expr)
`(or ,@(rectify-or-clauses (z:zodiac-start expr) expr mark-list lexically-bound-vars))]
`(or ,@(rectify-or-clauses (z:zodiac-start expr) expr mark-list lexically-bound-bindings))]
[else
`(if ,(recur (z:if-form-test expr))
,(recur (z:if-form-then expr))
@ -203,6 +233,18 @@
; `(quote ,raw)])
)]
[(z:let-values-form? expr)
(let* ([bindings (z:let-values-form-vars expr)]
[binding-names (map (lambda (b-list) (map z:binding-orig-name b-list)) bindings)]
[right-sides (map recur (z:let-values-vorm-vals expr))]
[must-be-values? (ormap (lambda (n-list) (not (= (length n-list) 1))) binding-names)]
[rectified-body (rectify-source-expr (z:let-values-form-body expr)
mark-list
(apply append lexically-bound-bindings bindings))])
(if must-be-values?
`(let-values ,(map list binding-names right-sides) ,rectified-body)
`(let ,(map list (map car binding-names) right-sides) ,rectified-body)))]
[(z:case-lambda-form? expr)
(let* ([arglists (z:case-lambda-form-args expr)]
[bodies (z:case-lambda-form-bodies expr)]
@ -211,16 +253,12 @@
(utils:improper-map z:binding-orig-name
(utils:arglist->ilist arglist)))
arglists)]
[var-form-arglists
(map (lambda (arglist)
(map z:binding-var (z:arglist-vars arglist)))
arglists)]
[var-form-arglists (map z:arglist-vars arglists)]
[o-form-bodies
(map (lambda (body var-form-arglist)
(rectify-source-expr body
mark-list
(append var-form-arglist
lexically-bound-vars)))
(append var-form-arglist lexically-bound-bindings)))
bodies
var-form-arglists)])
(cond [(or (comes-from-lambda? expr) (comes-from-define? expr))
@ -240,27 +278,27 @@
; these macro unwinders (and, or) are specific to beginner level
(define (rectify-and-clauses and-source expr mark-list lexically-bound-vars)
(let ([rectify-source (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-vars))])
(define (rectify-and-clauses and-source expr mark-list lexically-bound-bindings)
(let ([rectify-source (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-bindings))])
(if (and (z:if-form? expr) (equal? and-source (z:zodiac-start expr)))
(cons (rectify-source (z:if-form-test expr))
(rectify-and-clauses and-source (z:if-form-then expr) mark-list lexically-bound-vars))
(rectify-and-clauses and-source (z:if-form-then expr) mark-list lexically-bound-bindings))
null)))
(define (rectify-or-clauses or-source expr mark-list lexically-bound-vars)
(let ([rectify-source (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-vars))])
(define (rectify-or-clauses or-source expr mark-list lexically-bound-bindings)
(let ([rectify-source (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-bindings))])
(if (and (z:if-form? expr) (equal? or-source (z:zodiac-start expr)))
(cons (rectify-source (z:if-form-test expr))
(rectify-or-clauses or-source (z:if-form-else expr) mark-list lexically-bound-vars))
(rectify-or-clauses or-source (z:if-form-else expr) mark-list lexically-bound-bindings))
null)))
(define (rectify-cond-clauses cond-source expr mark-list lexically-bound-vars)
(let ([rectify-source (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-vars))])
(define (rectify-cond-clauses cond-source expr mark-list lexically-bound-bindings)
(let ([rectify-source (lambda (expr) (rectify-source-expr expr mark-list lexically-bound-bindings))])
(if (equal? cond-source (z:zodiac-start expr))
(if (z:if-form? expr)
(cons (list (rectify-source (z:if-form-test expr))
(rectify-source (z:if-form-then expr)))
(rectify-cond-clauses cond-source (z:if-form-else expr) mark-list lexically-bound-vars))
(rectify-cond-clauses cond-source (z:if-form-else expr) mark-list lexically-bound-bindings))
null)
`((else ,(rectify-source expr))))))
@ -348,7 +386,7 @@
,(rectify-source-top-marks val))]))
so-far))
(define (reconstruct-inner mark-list so-far)
(define (rectify-inner mark-list so-far)
(let ([rectify-source-current-marks
(lambda (expr)
(rectify-source-expr expr mark-list null))])
@ -445,68 +483,35 @@
; let-values
; [(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)]
; [val dummy-var-list (build-list (length var-set-list) (lambda (x) (get-arg-varref x)))]
; [val rhs-vals (map (lambda (arg-sym)
; (mark-binding-value (find-var-binding mark-list arg-sym)))
; arg-temp-syms)]
; [val rhs-list
; (let loop ([var-sets var-sets] [rhs-vals rhs-vals] [rhs-sources vals])
; (if (eq? (car rhs-vals) *undefined*)
; (map rectify-source-current-marks rhs-sources)
; (let*-values ([first-set (car var-sets)]
; [(set-vals remaining) (list-partition rhs-vals (length first-set))])
; (cons
; (case (length first-set)
; ((0) `(values))
; ((1) (car set-vals))
; (else `(values ,@set-vals)))
; (loop (cdr var-sets) remaining (cdr rhs-sources))))))]
;
; [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)])
; (if cheap-wrap?
; (let ([bindings
; (map (lambda (vars val)
; `(,(map utils:get-binding-name vars) ,val))
; var-sets
; annotated-vals)])
; (values (expr-cheap-wrap `(#%let-values ,bindings ,annotated-body)) free-vars))
; (let+ (
; [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 *undefined*))))])]
; [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))])]
; ; time to work from the inside out again
; [val inner-let-values
; `(#%let-values ,inner-transference ,annotated-body)]
; [val middle-begin
; `(#%begin ,@set!-clauses ,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)
; 'none)
; middle-begin)]
; [val whole-thing
; `(#%let-values ,outer-dummy-initialization ,wrapped-begin)])
; (values whole-thing free-vars))))]
[(z:let-values-form? expr)
(let+ ([val binding-sets (z:let-values-form-vars expr)]
[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 vals (z:let-values-form-vals expr)]
[val dummy-var-list (build-list (length binding-list) (lambda (x) (get-arg-varref x)))]
[val rhs-vals (map (lambda (arg-sym)
(mark-binding-value (find-var-binding mark-list arg-sym)))
arg-temp-syms)]
[val rhs-list
(let loop ([binding-sets binding-sets] [rhs-vals rhs-vals] [rhs-sources vals])
(cond [(null? binding-sets) null]
[(eq? (car rhs-vals) *undefined*)
(cons so-far
(map rectify-source-current-marks (cdr rhs-sources)))]
[else
(let*-values ([first-set (car binding-sets)]
[(set-vals remaining) (list-partition rhs-vals (length first-set))])
(cons
(case (length first-set)
((0) `(values))
((1) (car set-vals))
(else `(values ,@set-vals)))
(loop (cdr binding-sets) remaining (cdr rhs-sources))))]))]
[val rectified-body (rectify-source-expr 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)))]
; define-values : define's don't get marks, so they can't occur here
@ -524,7 +529,7 @@
(define (current-def-rectifier so-far mark-list first)
(if (null? mark-list)
(rectify-top-level expr so-far)
(let ([reconstructed (reconstruct-inner mark-list so-far)])
(let ([reconstructed (rectify-inner mark-list so-far)])
(current-def-rectifier
(if first
(begin
@ -534,7 +539,26 @@
(cdr mark-list)
#f))))
(define (rectify-let-values-step)
(let* ([source-expr (mark-source (car mark-list))])
(unless (z:let-values-form? source-expr)
(e:internal-error "double-step not inside let-values."))
(let* ([redex (rectify-inner expr mark-list #f)]
[binding-sets (z:let-values-form-vars expr)]
[binding-list (apply append binding-sets)]
[reduct (rectify-source-expr (z:let-values-form-body expr) mark-list binding-list)]
[binding-names (map z:binding-orig-name binding-names)]
[new-names (insert-lifted-names binding-names)]
[dummy-var-list (build-list (length binding-list) (lambda (x) (get-arg-varref x)))]
[rhs-vals (map (lambda (arg-sym)
(mark-binding-value (find-var-binding mark-list arg-sym)))
arg-temp-syms)]
[before-step (current-def-rectifier redex (cdr mark-list) #f)]
[after-step (current-def-rectifier reduct (cdr mark-list) #f)]
[new-defines (map (lambda (name val) `(define ,name ,val)) new-names rhs-vals)])
(list before-step redex new-defines after-step reduct))))
; (define (confusable-value? val)
; (not (or (number? val)
; (boolean? val)
@ -542,15 +566,19 @@
; (symbol? val))))
(define answer
(if (eq? break-kind 'result-break)
(let* ([innermost (if (null? returned-value-list)
(rectify-source-expr (mark-source (car mark-list)) mark-list null)
(rectify-value (car returned-value-list)))]
[current-def (current-def-rectifier highlight-placeholder (cdr mark-list) #f)])
(list current-def innermost))
(begin
(let ([current-def (current-def-rectifier nothing-so-far mark-list #t)])
(list current-def redex)))))
(case break-kind
((result-break)
(let* ([innermost (if (null? returned-value-list)
(rectify-source-expr (mark-source (car mark-list)) mark-list null)
(rectify-value (car returned-value-list)))]
[current-def (current-def-rectifier highlight-placeholder (cdr mark-list) #f)])
(list current-def innermost)))
((normal-break)
(begin
(let ([current-def (current-def-rectifier nothing-so-far mark-list #t)])
(list current-def redex))))
((double-break)
(rectify-let))))
)

2
collects/stepper/sig.ss
View File

@ -46,7 +46,7 @@
mark-binding-varref
expose-mark
display-mark
find-var-binding))
lookup-var-binding))
(define-signature stepper:client-procs^
(read-getter

2
collects/stepper/utils.ss
View File

@ -45,7 +45,7 @@
(let ([gdv (global-defined-value real-id)])
(or (syntax? gdv)
(macro? gdv)))))
(e:static-error id "Invalid use of keyword ~s" real-id))))))
(e:static-error id "keyword: invalid use of keyword ~s" real-id))))))
(define check-for-keyword (check-for-keyword/both #t))
(define check-for-syntax-or-macro-keyword (check-for-keyword/both #f))

4
collects/stepper/view-controller.ss
View File

@ -382,7 +382,7 @@
(define beginner-level-name "Beginning Student")
(define (stepper-go frame)
(let ([settings (f:preferences:get 'drscheme:settings)])
(let ([settings (f:preferences:get 'drscheme:language:settings-preferences-symbol)])
(if #f ; (not (string=? (d:basis:setting-name settings) beginner-level-name))
(message-box "Stepper"
(format (string-append "Language level is set to \"~a\".~n"
@ -391,4 +391,4 @@
beginner-level-name)
#f
'(ok))
(stepper-wrapper frame settings)))))
(stepper-wrapper frame settings)))))

683
collects/zodiac/doc.txt
View File

@ -1,6 +1,8 @@
_Zodiac_
--------
Using _Zodiac_
--------------
==============
The top-level way:
@ -17,6 +19,7 @@ The unit/sig way:
Link time:
(require-library-unit/sig "link.ss" "zodiac")
(require-library-unit/sig "link2.ss" "zodiac") ; see "Error Handlers" below
Imports:
zodiac:interface^ ; see "Error Handlers" below
mzlib:pretty-print^
@ -80,19 +83,75 @@ Handler Parameters
Error Handlers
--------------
There are two interfaces to the error handler procedures. Programmers
choose the one they want by using link.ss or link2.ss, as appropriate.
Zodiac relies on two error handlers that are provided by its
> zodiac:interface^
import:
> internal-error - for when things go wrong in zodiac that should
never go wrong
> static-error - for input errors during read or expand.
> static-error - for input errors during read or expand
A zodiac error handler takes a zodiac AST followed by format-style
arguments. For example:
Implementors of these procedures are expected to ensure that the
procedures never return. internal-error has the same interface in
both link.ss and link2.ss:
internal-error: where fmt-spec . args
where -- a zodiac AST
fmt-spec -- a format-style string
args -- arguments for the format string
Sample implementation:
(define (internal-error where fmt-spec . args)
(printf "Internal error at: ~s~n" where) ; or, pull location out of `where'
(apply error 'internal-error fmt-spec args))
static-error has two different interfaces. In link.ss:
static-error: where fmt-spec . args
where -- a zodiac AST
fmt-spec -- a format-style string
args -- arguments for the format string
Sample implementation:
(define (static-error where fmt-spec . args)
(printf "Static error at: ~s~n" where) ; or, pull location out of `where'
(apply error 'static-error fmt-spec args))
In link2.ss:
static-error: link-text link-tag source-term fmt-spec . args
link-text -- a string reporting the major information about the
error; typically, this will be turned into a hyperlink
by a user interface
link-tag -- a tag specifying the nature of the error; typically,
this will be used by the user interface to look up a
database and generate a URL for the hyperlink
fmt-spec -- a format-style string for information not in link-text
args -- arguments for the format string
Producers of error messages assume that the information in these
arguments will be used in the following manner:
<link-text>: <fmt-spec-with-args-replaced>
Implementors may use them in any way they wish, so long as they keep
in mind that the error producer has made the above presumption.
Producers of errors *cannot* assume that the link-tag will be used
(since the implementor may not have access to a hypertext medium),
and must therefore provide enough useful information in the
link-text and fmt-spec arguments.
Sample implementation:
(define (static-error link-text link-tag where fmt-spec . args)
(printf "Error at: ~s~n" where) ; or, pull location out of `where'
(apply error 'syntax-error fmt-spec args))
(apply error 'syntax-error
(string-append link-text ": " fmt-spec)
args))
Example
-------
@ -193,3 +252,617 @@ source-who value 'non-source. Of course, the location field of
"non-source" syntax still matches the syntax to a particular source
expression. Similarly, the nested `if' in the expansion of `cons'
contains a manufactured `if' expression.
Error Tags
==========
These are the tags generated by Zodiac to report static-error's.
kwd Tags
--------
The following tags are prefixed with "kwd:", as in,
kwd:lambda
They correspond exclusively to forms built into the language.
case-lambda lambda define-internal begin-internal begin begin0 if
with-continuation-mark quote set!-values local define local-define
define-values struct define-struct define-structure let-struct let
let* delay time let-values let*-values letrec-values letrec or nor
and nand recur rec cond case evcase when unless let/cc let/ec do
fluid-let parameterize with-handlers define-macro let-macro unquote
unquote-splicing quasiquote 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 define-values global-define-values
polymorphic mrspidey:control : type: define-type define-constructor
reference-file require-library require-relative-library
require-library-unit require-unit require-unit/sig
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 set! define-values require-unit
require-unit/sig require-library-unit require-library-unit/sig
require-relative-library-unit require-relative-library-unit/sig
Pre-Parsing Tags
----------------
> read:syntax-error
Any syntax error during the reading phase.
> scan:syntax-error
Any syntax error during the scanning phase.
term Tags
---------
The following tags are used to denote syntactic errors while parsing
programs.
> term:internal-def-not-foll-by-expr
Internal definition must be followed by an expression. A sequence
of nothing but internal definitions is invalid (since this must
translate into the letrec family, which needs a body).
> term:duplicate-interal-def
Each name can be defined only once internally.
> term:case/lambda-only-in-def
At lower language levels, procedures may only be declared
immediately within a definition.
> term:define-internal-invalid-posn
Not at a legal internal define position.
> term:define-illegal-implicit-begin
A definition body has multiple body terms. This is illegal at lower
language levels.
> term:if-must-have-else
At lower language levels, if's must be two-armed.
> term:quote-not-on-symbol
At lower language levels, quote can only be used on symbols.
> term:struct-not-id
The field names in a structure must be valid identifiers.
> term:super-struct-invalid
Invalid super-structure declaration syntax.
> term:super-struct-not-id
Structure name declaration not an identifier when declaring a
super-structure.
> term:cond-else-only-in-last
The `else' clause in a cond must be the last such clause.
> term:cond-clause-not-in-q/a-fmt
The cond clause is not of the proper shape.
> term:cond-=>-not-foll-by-1-rcvr
The => clause of a cond must be followed by one expression, which
evaluates to a receiver function.
> term:signature-out-of-context
A name, bound to a signature, is used a context where it isn't
legal.
> term:keyword-out-of-context
A name, bound to a keyword, is used in a context where it isn't
legal.
> term:empty-combination
Use of the empty combination. Illegal at lower language levels.
> term:app-first-term-not-var
First term after parenthesis is a complex expression, not a variable
reference. Illegal at lower language levels.
> term:app-first-term-lambda-bound
First term after parenthesis is a lambda-bound identifier. Illegal
at lower language levels.
> term:expected-an-identifier
Attempt to use a syntactic non-identifier in a context that expected
one.
> term:repeated-identifier
Attempt to use the same identifier twice in a context that allows
only unique uses.
> term:invalid-identifier
Attempt to use a non-identifier in an identifier context.
> term:arglist-after-init-value-spec
Attempt to provide arguments without initial values following
arguments that have initial values in an argument list
specification.
> term:arglist-after-catch-all-arg
Attempt to provide arguments after a catch-all argument.
> term:arglist-invalid-init-value
Attempt to provide an initial value specification in an illegal
position.
> term:arglist-invalid-init-var-decl
Invalid initial value specification syntax.
> term:arglist-last-arg-no-init
Attempt to provide an initial value in the last position of an
argument list with a catch-all argument.
> term:arglist-invalid-syntax
Invalid argument list syntax.
> term:proc-arity->=-1
Attempt to define a procedure with arity < 1. Illegal at lower
language levels.
> term:unit-double-export
Attempt to export the same name twice from a signed unit.
> term:duplicate-signature
Attempt to duplicately define a signature's name.
> term:unbound-sig-name
Attempt to refer to an signature name that hasn't been bound.
> term:signature-no-sub-unit
Attempt to refer to a sub-unit not contained in a signature.
> term:signature-no-var
Attempt to refer to a name not contained in a signature.
> term:unit-link-unbound-tag
Attempt to use an unbound tag in a unit linkage specification.
> term:unit-link-duplicate-tag
Attempt to define the same link name twice.
> term:unit-link-self-import-tag
Attempt to create a self-import in unit linkage.
> term:unit-link-path-malformed
Invalid linkage path syntax.
> term:unit-duplicate-import
Attempt to import the same name twice.
> term:unit-duplicate-export
Attempt to export the same name twice.
> term:unit-import-exported
Attempt to export a name that has been imported.
> term:unit-defined-imported
Attempt to define an imported name.
> term:unit-redefined-import
Attempt to re-define an imported name within a unit.
> term:unit-export-not-defined
Attempt to export a name that has not been defined from a unit.
> term:unit-duplicate-definition
Attempt to define the same name twice within a unit.
> term:signature-not-matching
Attempt to match non-matching signatures.
> term:signature-struct-illegal-omit-name
Attempt to omit an invalid name from a signature.
> term:unit-export
Invalid unit export syntax.
> term:c-unit-linkage
Invalid linkage clause syntax.
> term:c-unit-export
Invalid export clause syntax.
> term:c-unit-not-import
Use of a non-imported identifier in a compound-unit linkage.
> term:c-unit-invalid-tag
The use of a tag in a compound-unit linkage that is not
syntactically correct.
> term:signature-invalid-struct-omit
An invalid structure omission specification in a signature.
> term:signature-malformed-omit-clause
An invalid omission specification in a signature.
> term:signature-malformed-open-clause
An invalid open clause in a signature.
> term:signature-malformed-unit-clause
An invalid unit clause in a signature.
> term:signature-ambiguous-:
Use of : in signature ambiguous.
> term:no-unit-exports
Attempt to specify sub-signatures in a signed unit's export.
> term:invalid-pos-symbol
Invalid symbol expression syntax.
> term:invalid-pos-literal
Invalid literal expression syntax.
> term:invalid-pos-list
Invalid list expression syntax.
> term:invalid-pos-ilist
Invalid improper list expression syntax.
> term:macro-error
Any error during the evaluation of a macro application.
> term:invalid-ivar-decl
Invalid instance variable declaration syntax.
> term:invalid-ivar-clause
Invalid instance variable declaration syntax.
> term:set!-no-mutate-lambda-bound
Attempt to mutate a lambda-bound variable. Illegal at lower
language levels.
> term:no-set!-inherited/renamed
Attempt to mutate an inherited or renamed identifier in a class.
> term:unit-unbound-id
Unbound identifier in a unit.
> term:def-not-at-top-level
Attempted internal definition. Illegal at lower language levels.
> term:invalid-intl-defn-posn
Internal definition in an invalid position.
> term:cannot-bind-kwd
Attempt to re-define a keyword, in a unit or at the top-level.
> term:no-set!-imported
Attempt to mutate an imported identifier in a unit.
Tags and Language Levels
========================
This documents the language level at which each tag can appear.
kwd: Tags
---------
If these are inserted at some language level, they are automatically
present at all subsequent language levels.
common:
define-macro
let-macro
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
intermediate:
local
define-structure
let-struct
let
let*
time
let-values
let*-values
letrec-values
letrec
unquote
unquote-splicing
quasiquote
advanced:
begin
begin0
set!
set!-values
delay
recur
rec
case
evcase
when
unless
let/cc
let/ec
do
fluid-let
parameterize
with-handlers
scheme:
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
term: Tags
---------
term tags are not automatically inherited by advanced levels, since
they sometimes designate an error corresponding to a restriction at a
certainl language level. Thus, the tags are explicitly listed for
each level at which they occur. Paradoxically, a tag can appear in a
more advanced level but not in a less advanced one. This is typically
because the advanced level has introduced or activated a feature not
allowed in a lower level (where an attempt to use it might merely
result in a syntax error), and its misuse is flagged by this tag.
do not occur (fallbacks that are never fallen back to):
invalid-pos-symbol
invalid-pos-literal
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
intermediate:
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
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-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:
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

28
collects/zodiac/invoke.ss
View File

@ -1,4 +1,4 @@
; $Id: invoke.ss,v 1.40 1999/05/27 15:48:55 mflatt Exp $
; $Id: invoke.ss,v 1.41 1999/06/01 16:55:18 mflatt Exp $
(begin-elaboration-time
(require-library "cores.ss"))
@ -63,13 +63,27 @@
e)))])
(read-eval-print-loop))))
(define zodiac:see (zodiac:make-see
(lambda (in)
(zodiac:scheme-expand-program (list in)))))
(define zodiac:see
(zodiac:make-see
(lambda (in)
(zodiac:scheme-expand-program (list in)))))
(define zodiac:see-parsed (zodiac:make-see
(lambda (in)
(zodiac:scheme-expand-program (list in)))))
(define zodiac:see-parsed
(lambda ()
((zodiac:make-see
(lambda (in)
(zodiac:scheme-expand-program (list in))))
#f)))
(define zodiac:see
(opt-lambda ((print-as-sexp? #t) (vocab zodiac:scheme-vocabulary))
((zodiac:make-see
(lambda (in)
(zodiac:scheme-expand-program
(list in)
(zodiac:make-attributes)
vocab)))
print-as-sexp?)))
(define zodiac:spidey-see (zodiac:make-see
(lambda (in)

98
collects/zodiac/link.ss
View File

@ -1,80 +1,30 @@
; $Id: link.ss,v 1.16 1999/02/02 19:33:14 mflatt Exp $
; $Id: link.ss,v 1.17 2000/01/02 23:28:25 robby Exp $
(compound-unit/sig
(compound-unit/sig
(import
(INTERFACE : zodiac:interface^)
(PRETTY : mzlib:pretty-print^)
(MZLIB-FILE : mzlib:file^))
(link
[MISC : zodiac:misc^
((require-relative-library-unit/sig "misc.ss") PRETTY)]
[TOP-STRUCTS : zodiac:structures^
((require-relative-library-unit/sig "basestr.ss"))]
[SCAN-STRUCTS : zodiac:scanner-structs^
((require-relative-library-unit/sig "scanstr.ss")
TOP-STRUCTS)]
[READ-STRUCTS : zodiac:reader-structs^
((require-relative-library-unit/sig "readstr.ss")
TOP-STRUCTS)]
[SCAN-PARMS : zodiac:scanner-parameters^
((require-relative-library-unit/sig "scanparm.ss")
TOP-STRUCTS)]
[SCAN-CODE : zodiac:scanner-code^
((require-relative-library-unit/sig "scanner.ss")
TOP-STRUCTS SCAN-STRUCTS READ-STRUCTS
SCAN-PARMS INTERFACE)]
[READ-CODE : zodiac:reader-code^
((require-relative-library-unit/sig "reader.ss")
TOP-STRUCTS SCAN-STRUCTS READ-STRUCTS
SCAN-PARMS INTERFACE SCAN-CODE)]
[SEXP : zodiac:sexp^
((require-relative-library-unit/sig "sexp.ss")
MISC TOP-STRUCTS READ-STRUCTS INTERFACE
SCHEME-MAIN)]
[PATTERN : zodiac:pattern^
((require-relative-library-unit/sig "pattern.ss")
MISC SEXP READ-STRUCTS SCHEME-CORE)]
[EXPANDER : zodiac:expander^
((require-relative-library-unit/sig "x.ss")
MISC SEXP TOP-STRUCTS READ-STRUCTS
SCHEME-CORE INTERFACE)]
[CORRELATE : zodiac:correlate^
((require-relative-library-unit/sig "corelate.ss")
TOP-STRUCTS)]
[BACK-PROTOCOL : zodiac:back-protocol^
((require-relative-library-unit/sig "back.ss")
MISC INTERFACE)]
[SCHEME-CORE : zodiac:scheme-core^
((require-relative-library-unit/sig "scm-core.ss")
TOP-STRUCTS MISC SEXP READ-STRUCTS
BACK-PROTOCOL EXPANDER INTERFACE PATTERN)]
[SCHEME-MAIN : zodiac:scheme-main^
((require-relative-library-unit/sig "scm-main.ss")
MISC TOP-STRUCTS SCAN-PARMS
READ-STRUCTS READ-CODE SEXP
PATTERN SCHEME-CORE BACK-PROTOCOL EXPANDER INTERFACE)]
[SCHEME-SPIDEY : zodiac:scheme-mrspidey^
((require-relative-library-unit/sig "scm-spdy.ss")
MISC TOP-STRUCTS SCAN-PARMS READ-STRUCTS READ-CODE SEXP PATTERN
SCHEME-CORE SCHEME-MAIN BACK-PROTOCOL EXPANDER INTERFACE
MZLIB-FILE)]
[SCHEME-OBJ : zodiac:scheme-objects^
((require-relative-library-unit/sig "scm-obj.ss")
MISC TOP-STRUCTS READ-STRUCTS SEXP
PATTERN SCHEME-CORE SCHEME-MAIN BACK-PROTOCOL EXPANDER INTERFACE)]
[SCHEME-UNIT : zodiac:scheme-units^
((require-relative-library-unit/sig "scm-unit.ss")
MISC TOP-STRUCTS SCAN-PARMS READ-STRUCTS READ-CODE SEXP
PATTERN SCHEME-CORE SCHEME-MAIN SCHEME-OBJ BACK-PROTOCOL EXPANDER INTERFACE)]
[SCHEME-OBJ+UNIT : zodiac:scheme-objects+units^
((require-relative-library-unit/sig "scm-ou.ss")
MISC TOP-STRUCTS READ-STRUCTS SEXP PATTERN EXPANDER INTERFACE
SCHEME-CORE SCHEME-MAIN SCHEME-OBJ SCHEME-UNIT)])
(export (open TOP-STRUCTS) (open SCAN-PARMS)
(open READ-STRUCTS) (open READ-CODE)
(open SEXP) (open PATTERN) (open CORRELATE) (open BACK-PROTOCOL)
(open EXPANDER)
(open SCHEME-CORE) (open SCHEME-MAIN)
(open SCHEME-OBJ) (open SCHEME-UNIT)
(open SCHEME-OBJ+UNIT)
(open SCHEME-SPIDEY)))
[NEW-INTERFACE : zodiac:interface^
((unit/sig zodiac:interface^
(import (real : zodiac:interface^))
(define static-error
(case-lambda
[(link-text link-tag source-term fmt-spec . args)
(apply real:static-error
source-term
(string-append link-text ": " fmt-spec)
args)]
[(where fmt-spec . args)
(real:internal-error where
"static-error interface has changed: called with ~s, ~s"
fmt-spec args)]))
(define internal-error real:internal-error))
INTERFACE)]
[REAL-LINKER : zodiac:system^
((require-relative-library-unit/sig "link2.ss")
NEW-INTERFACE
PRETTY
MZLIB-FILE)])
(export (open REAL-LINKER)))

80
collects/zodiac/link2.ss Normal file
View File

@ -0,0 +1,80 @@
; $Id: link.ss,v 1.17 2000/01/02 23:28:25 robby Exp $
(compound-unit/sig
(import
(INTERFACE : zodiac:interface^)
(PRETTY : mzlib:pretty-print^)
(MZLIB-FILE : mzlib:file^))
(link
[MISC : zodiac:misc^
((require-relative-library-unit/sig "misc.ss") PRETTY)]
[TOP-STRUCTS : zodiac:structures^
((require-relative-library-unit/sig "basestr.ss"))]
[SCAN-STRUCTS : zodiac:scanner-structs^
((require-relative-library-unit/sig "scanstr.ss")
TOP-STRUCTS)]
[READ-STRUCTS : zodiac:reader-structs^
((require-relative-library-unit/sig "readstr.ss")
TOP-STRUCTS)]
[SCAN-PARMS : zodiac:scanner-parameters^
((require-relative-library-unit/sig "scanparm.ss")
TOP-STRUCTS)]
[SCAN-CODE : zodiac:scanner-code^
((require-relative-library-unit/sig "scanner.ss")
TOP-STRUCTS SCAN-STRUCTS READ-STRUCTS
SCAN-PARMS INTERFACE)]
[READ-CODE : zodiac:reader-code^
((require-relative-library-unit/sig "reader.ss")
TOP-STRUCTS SCAN-STRUCTS READ-STRUCTS
SCAN-PARMS INTERFACE SCAN-CODE)]
[SEXP : zodiac:sexp^
((require-relative-library-unit/sig "sexp.ss")
MISC TOP-STRUCTS READ-STRUCTS INTERFACE
SCHEME-MAIN)]
[PATTERN : zodiac:pattern^
((require-relative-library-unit/sig "pattern.ss")
MISC SEXP READ-STRUCTS SCHEME-CORE)]
[EXPANDER : zodiac:expander^
((require-relative-library-unit/sig "x.ss")
MISC SEXP TOP-STRUCTS READ-STRUCTS
SCHEME-CORE INTERFACE)]
[CORRELATE : zodiac:correlate^
((require-relative-library-unit/sig "corelate.ss")
TOP-STRUCTS)]
[BACK-PROTOCOL : zodiac:back-protocol^
((require-relative-library-unit/sig "back.ss")
MISC INTERFACE)]
[SCHEME-CORE : zodiac:scheme-core^
((require-relative-library-unit/sig "scm-core.ss")
TOP-STRUCTS MISC SEXP READ-STRUCTS
BACK-PROTOCOL EXPANDER INTERFACE PATTERN)]
[SCHEME-MAIN : zodiac:scheme-main^
((require-relative-library-unit/sig "scm-main.ss")
MISC TOP-STRUCTS SCAN-PARMS
READ-STRUCTS READ-CODE SEXP
PATTERN SCHEME-CORE BACK-PROTOCOL EXPANDER INTERFACE)]
[SCHEME-SPIDEY : zodiac:scheme-mrspidey^
((require-relative-library-unit/sig "scm-spdy.ss")
MISC TOP-STRUCTS SCAN-PARMS READ-STRUCTS READ-CODE SEXP PATTERN
SCHEME-CORE SCHEME-MAIN BACK-PROTOCOL EXPANDER INTERFACE
MZLIB-FILE)]
[SCHEME-OBJ : zodiac:scheme-objects^
((require-relative-library-unit/sig "scm-obj.ss")
MISC TOP-STRUCTS READ-STRUCTS SEXP
PATTERN SCHEME-CORE SCHEME-MAIN BACK-PROTOCOL EXPANDER INTERFACE)]
[SCHEME-UNIT : zodiac:scheme-units^
((require-relative-library-unit/sig "scm-unit.ss")
MISC TOP-STRUCTS SCAN-PARMS READ-STRUCTS READ-CODE SEXP
PATTERN SCHEME-CORE SCHEME-MAIN SCHEME-OBJ BACK-PROTOCOL EXPANDER INTERFACE)]
[SCHEME-OBJ+UNIT : zodiac:scheme-objects+units^
((require-relative-library-unit/sig "scm-ou.ss")
MISC TOP-STRUCTS READ-STRUCTS SEXP PATTERN EXPANDER INTERFACE
SCHEME-CORE SCHEME-MAIN SCHEME-OBJ SCHEME-UNIT)])
(export (open TOP-STRUCTS) (open SCAN-PARMS)
(open READ-STRUCTS) (open READ-CODE)
(open SEXP) (open PATTERN) (open CORRELATE) (open BACK-PROTOCOL)
(open EXPANDER)
(open SCHEME-CORE) (open SCHEME-MAIN)
(open SCHEME-OBJ) (open SCHEME-UNIT)
(open SCHEME-OBJ+UNIT)
(open SCHEME-SPIDEY)))

20
collects/zodiac/quasi.ss
View File

@ -1,4 +1,4 @@
; $Id: quasi.ss,v 1.9 1999/02/04 14:32:53 mflatt Exp $
; $Id: quasi.ss,v 1.10 1999/06/13 21:41:25 mflatt Exp $
; Fix the null? in qq-normalize.
@ -65,13 +65,15 @@
body
(qq-list x (sub1 level))))))
((pat:match-against qq-m&e-2 x env)
(static-error x
"unquote takes exactly one expression"))
(static-error
"unquote" 'kwd:unquote x
"takes exactly one expression"))
((pat:match-against qq-m&e-3 x env)
(qq-list x (add1 level)))
((pat:match-against qq-m&e-4 x env)
(static-error x
"invalid context for unquote-splicing inside quasiquote"))
(static-error
"unquote-splicing" 'kwd:unquote-splicing x
"invalid context inside quasiquote"))
((pat:match-against qq-m&e-5 x env)
=>
(lambda (p-env)
@ -93,8 +95,9 @@
'()))
(qq-normalize q-rest rest))))))))
((pat:match-against qq-m&e-6 x env)
(static-error x
"unquote-splicing takes exactly one expression"))
(static-error
"unquote-splicing" 'kwd:unquote-splicing x
"takes exactly one expression"))
(else
(qq-list x level))))
((z:vector? x)
@ -114,7 +117,8 @@
template)
expr env attributes vocab))))
(else
(static-error expr "Malformed quasiquote"))))))
(static-error
"quasiquote" 'kwd:quasiquote expr "malformed expression"))))))
(add-primitivized-micro-form 'quasiquote intermediate-vocabulary quasiquote-micro)
(add-primitivized-micro-form 'quasiquote scheme-vocabulary quasiquote-micro)

14
collects/zodiac/reader.ss
View File

@ -1,6 +1,6 @@
;;
;; zodiac:reader-code@
;; $Id: reader.ss,v 1.6 1999/02/04 14:32:54 mflatt Exp $
;; $Id: reader.ss,v 1.7 1999/03/12 17:22:30 mflatt Exp $
;;
;; Zodiac Reader July 96
;; mwk, plt group, Rice university.
@ -10,10 +10,6 @@
;; scalar (symbol, number, string, boolean, char)
;; sequence (list, vector, improper-list)
;; eof
;;
;; In case of error, we invoke static-error (or internal-error)
;; with args: zodiac-obj fmt-string . args
;;
(unit/sig zodiac:reader-code^
@ -66,7 +62,13 @@
(lambda (how)
(make-origin 'reader how)))
(define z:r-s-e (lambda x (apply report:static-error x)))
(define z:r-s-e
(lambda args
(apply report:static-error
"syntax error"
'read:syntax-error
args)))
(define z:int-error (lambda x (apply report:internal-error x)))
;; pack-quote into zodiac structure.

21
collects/zodiac/scanner.ss
View File

@ -1,6 +1,6 @@
;;
;; zodiac:scanner-code@
;; $Id: scanner.ss,v 1.13 1999/10/26 18:47:02 shriram Exp $
;; $Id: scanner.ss,v 1.14 2000/03/24 14:50:29 clements Exp $
;;
;; Zodiac Scanner July 96.
;; mwk, plt group, Rice university.
@ -10,10 +10,6 @@
;; scalar (symbol, number, string, boolean, char)
;; token (anything else)
;; eof
;;
;; In case of error, we invoke static-error (or internal-error)
;; with args: token (type 'error) message (string).
;;
;;
;; Imports: make- constructors and parameters.
@ -348,18 +344,21 @@
(case-lambda
[(str)
(report:static-error
(z:token error-tag z:void start-loc (prev-loc))
str)]
"syntax error" 'scan:syntax-error
(z:token error-tag z:void start-loc (prev-loc))
str)]
[(str text)
(report:static-error
(z:token error-tag z:void start-loc (prev-loc))
(format str (text->string text)))])]
"syntax error" 'scan:syntax-error
(z:token error-tag z:void start-loc (prev-loc))
(format str (text->string text)))])]
[z:eof-error
(lambda (str)
(report:static-error
(z:token error-tag z:void start-loc (prev-loc))
(format "unexpected end of file inside ~a" str)))]
"syntax error" 'scan:syntax-error
(z:token error-tag z:void start-loc (prev-loc))
(format "unexpected end of file inside ~a" str)))]
;;
;; States in the scanner.

18
collects/zodiac/scanparm.ss
View File

@ -1,6 +1,6 @@
;;
;; zodiac:scanner-parameters@
;; $Id: scanparm.ss,v 1.5 1997/12/03 19:20:21 robby Exp $
;; $Id: scanparm.ss,v 1.7 2000/05/26 15:47:33 clements Exp $
;;
;; Scanner/Reader Parameters.
;;
@ -51,8 +51,20 @@
(define scan:newline-list (list newline return))
(define scan:tab-list (list tab))
(define scan:whitespace-list
(list space tab newline vtab page return))
(define scan:whitespace-list
(let loop ((n 0))
(if (> n 255) '()
(if (char-whitespace? (integer->char n))
(cons n (loop (+ n 1)))
(loop (+ n 1))))))
;; Old definition:
; (define scan:whitespace-list
; (list space tab newline vtab page return))
;; removed because this list depends on platform (eg,
;; char 202 is the non-breakable whitespace on the Mac);
;; char-whitespace? helps us stay platform-independent
(define scan:delim-list
(append scan:whitespace-list

193
collects/zodiac/scm-core.ss
View File

@ -1,4 +1,4 @@
; $Id: scm-core.ss,v 1.57 2000/03/24 14:50:29 clements Exp $
; $Id: scm-core.ss,v 1.59 2000/04/30 22:37:34 clements Exp $
(unit/sig zodiac:scheme-core^
(import zodiac:structures^ zodiac:misc^ zodiac:sexp^
@ -170,17 +170,17 @@
(when sig-space
(unless (get-attribute attributes 'delay-sig-name-check?)
(when (hash-table-get sig-space (z:symbol-orig-name expr) (lambda () #f))
(static-error
expr
"Invalid use of signature name ~s" (z:symbol-orig-name expr)))))))
(static-error
"signature" 'term:signature-out-of-context expr
"invalid use of signature name ~s" (z:symbol-orig-name expr)))))))
(define ensure-not-macro/micro
(lambda (expr env vocab attributes)
(let ((r (resolve expr env vocab)))
(if (or (macro-resolution? r) (micro-resolution? r))
(static-error
expr
"Invalid use of keyword ~s" (z:symbol-orig-name expr))
(static-error
"keyword" 'term:keyword-out-of-context expr
"invalid use of keyword ~s" (z:symbol-orig-name expr))
r))))
(define process-top-level-resolution
@ -216,32 +216,39 @@
(else
(internal-error expr "Invalid resolution in core: ~s" r))))))
(define (make-list-micro null-ok? lexvar-ok? expr-ok?)
(define (make-list-micro null-ok? lambda-bound-ok? expr-ok?)
(lambda (expr env attributes vocab)
(let ((contents (expose-list expr)))
(if (null? contents)
(if null-ok?
(expand-expr (structurize-syntax `(quote ,expr) expr)
env attributes vocab)
(static-error expr "Empty combination is a syntax error"))
(static-error
"illegal term" 'term:empty-combination expr
"empty combination is not valid syntax"))
(as-nested
attributes
(lambda ()
(let ((bodies
(map
(lambda (e)
(expand-expr e env attributes vocab))
contents)))
(when (or (and (not lexvar-ok?)
(not (top-level-varref? (car bodies))))
(and (not expr-ok?)
(not (varref? (car bodies)))))
(static-error expr
"First term after parenthesis is illegal in an application"))
(create-app (car bodies) (cdr bodies) expr))))))))
(map
(lambda (e)
(expand-expr e env attributes vocab))
contents)))
(when (and (not lambda-bound-ok?)
(lambda-varref? (car bodies)))
(static-error
"illegal application" 'term:app-first-term-lambda-bound
expr
"first term in application is a function-bound identifier"))
(when (and (not expr-ok?)
(not (varref? (car bodies))))
(static-error
"illegal application" 'term:app-first-term-not-var
expr
"first term in application must be a function name"))
(create-app (car bodies) (cdr bodies) expr))))))))
(add-list-micro beginner-vocabulary (make-list-micro #f #f #f))
(add-list-micro intermediate-vocabulary (make-list-micro #f #t #f))
(add-list-micro advanced-vocabulary (make-list-micro #f #t #t))
(add-list-micro scheme-vocabulary (make-list-micro #t #t #t))
@ -378,7 +385,9 @@
(define valid-syntactic-id?
(lambda (id)
(or (z:symbol? id)
(static-error id "~s is not an identifier" (sexp->raw id)))))
(static-error
"not an identifier" 'term:expected-an-identifier id
"~s" (sexp->raw id)))))
(define valid-syntactic-id/s?
(lambda (ids)
@ -388,8 +397,9 @@
(let ((first (car ids)) (rest (cdr ids)))
(if (valid-syntactic-id? first)
(cons (z:read-object first) (valid-syntactic-id/s? rest))
(static-error first "~e is not an identifier"
(sexp->raw first)))))
(static-error
"not an identifier" 'term:expected-an-identifier first
"~e" (sexp->raw first)))))
(else (internal-error ids "Illegal to check validity of id/s")))))
(define distinct-valid-syntactic-id/s?
@ -399,12 +409,15 @@
(or (null? ids)
(if (symbol? (car ids))
(if (memq (car ids) (cdr ids))
(static-error (list-ref input-ids index)
"Identifier ~s repeated" (car ids))
(static-error
"identifier" 'term:repeated-identifier
(list-ref input-ids index)
"~s repeated" (car ids))
(loop (cdr ids) (add1 index)))
(let ((erroneous (list-ref input-ids index)))
(static-error erroneous "~e is not an identifier"
(sexp->raw erroneous)))))))))
(static-error
"not an identifier" 'term:expected-an-identifier
erroneous "~e" (sexp->raw erroneous)))))))))
(define syntactic-id/s->ids
(lambda (ids)
@ -414,15 +427,17 @@
((z:symbol? ids) (list ids))
((pair? ids) ids)
((null? ids) ids)
(else (static-error ids "~e is not an identifier"
(sexp->raw ids))))))
(else (static-error
"not an identifier" 'term:expected-an-identifier ids
"~e" (sexp->raw ids))))))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define valid-id?
(lambda (id)
(or (binding? id)
(static-error id "Invalid identifier"))))
(static-error
"identifier" 'term:invalid-identifier id "invalid"))))
(define valid-id/s?
(lambda (ids)
@ -432,7 +447,8 @@
(let ((first (car ids)) (rest (cdr ids)))
(if (valid-id? first)
(cons (binding-orig-name first) (valid-id/s? rest))
(static-error first "Invalid identifier"))))
(static-error
"identifier" 'term:invalid-identifier first "invalid"))))
(else (internal-error ids "Illegal to check validity of id/s")))))
(define distinct-valid-id/s?
@ -442,9 +458,9 @@
(or (null? ids)
(if (memq (car ids) (cdr ids))
(let ((v (list-ref input-ids index)))
(static-error v
"Repeated identifier ~e"
(car ids)))
(static-error
"identifier" 'term:repeated-identifier v
"~e repeated" (car ids)))
(loop (cdr ids) (add1 index))))))))
(define id/s->ids
@ -455,8 +471,8 @@
((z:symbol? ids) (list ids))
((pair? ids) ids)
((null? ids) ids)
(else (static-error ids "Invalid identifier")))))
(else (static-error
"identifier" 'term:invalid-identifier ids "invalid")))))
; ----------------------------------------------------------------------
@ -475,10 +491,10 @@
(define optarglist-decl-entry-parser-vocab
(create-vocabulary 'optarglist-decl-entry-parser-vocab #f
"Invalid argument list entry"
"Invalid argument list entry"
"Invalid argument list entry"
"Invalid argument list entry"))
"malformed argument list entry"
"malformed argument list entry"
"malformed argument list entry"
"malformed argument list entry"))
(add-sym-micro optarglist-decl-entry-parser-vocab
(lambda (expr env attributes vocab)
@ -486,13 +502,15 @@
(case (unbox status-holder)
((proper improper) (void))
((proper/defaults)
(static-error expr
"Appears after initial value specifications"))
(static-error
"argument list" 'term:arglist-after-init-value-spec expr
"appears after initial value specifications"))
((improper/defaults)
(set-box! status-holder 'improper/done))
((improper/done)
(static-error expr
"Appears past catch-all argument"))
(static-error
"argument list" 'term:arglist-after-catch-all-arg expr
"appears past catch-all argument"))
(else (internal-error (unbox status-holder)
"Invalid in optarglist-decl-entry-parser-vocab sym"))))
(make-optarglist-entry
@ -508,8 +526,9 @@
((proper) (set-box! status-holder 'proper/defaults))
((improper) (set-box! status-holder 'improper/defaults))
((proper/defaults improper/defaults) (void))
((improper/done) (static-error expr
"Invalid default value specification"))
((improper/done) (static-error
"argument list" 'term:arglist-invalid-init-value
expr "invalid default value specification"))
(else (internal-error (unbox status-holder)
"Invalid in optarglist-decl-entry-parser-vocab list"))))
(cond
@ -523,14 +542,16 @@
(create-lexical-binding+marks var)
val))))
(else
(static-error expr "Invalid init-var declaration"))))))
(static-error
"argument list" 'term:arglist-invalid-init-var-decl
expr "invalid init-var declaration"))))))
(define optarglist-decls-vocab
(create-vocabulary 'optarglist-decls-vocab #f
"Invalid argument list entry"
"Invalid argument list entry"
"Invalid argument list entry"
"Invalid argument list entry"))
"malformed argument list entry"
"malformed argument list entry"
"malformed argument list entry"
"malformed argument list entry"))
(add-sym-micro optarglist-decls-vocab
(lambda (expr env attributes vocab)
@ -563,8 +584,10 @@
(let loop ((result result) (exprs expr-list))
(if (null? (cdr result))
(when (initialized-optarglist-entry? (car result))
(static-error (car exprs)
"Last argument must not have an initial value"))
(static-error
"argument list" 'term:arglist-last-arg-no-init
(car exprs)
"last argument must not have an initial value"))
(loop (cdr result) (cdr exprs))))
(make-ilist-optarglist result)))))
@ -635,10 +658,10 @@
(define paroptarglist-decl-entry-parser-vocab
(create-vocabulary 'paroptarglist-decl-entry-parser-vocab #f
"Invalid argument list entry"
"Invalid argument list entry"
"Invalid argument list entry"
"Invalid argument list entry"))
"malformed argument list entry"
"malformed argument list entry"
"malformed argument list entry"
"malformed argument list entry"))
(add-sym-micro paroptarglist-decl-entry-parser-vocab
(lambda (expr env attributes vocab)
@ -646,13 +669,15 @@
(case (unbox status-holder)
((proper improper) (void))
((proper/defaults)
(static-error expr
"Appears after initial value specifications"))
(static-error
"argument list" 'term:arglist-after-init-value-spec expr
"appears after initial value specifications"))
((improper/defaults)
(set-box! status-holder 'improper/done))
((improper/done)
(static-error expr
"Appears past catch-all argument"))
(static-error
"argument list" 'term:arglist-after-catch-all-arg expr
"appears past catch-all argument"))
(else (internal-error (unbox status-holder)
"Invalid in paroptarglist-decl-entry-parser-vocab sym"))))
(make-paroptarglist-entry
@ -668,8 +693,10 @@
((proper) (set-box! status-holder 'proper/defaults))
((improper) (set-box! status-holder 'improper/defaults))
((proper/defaults improper/defaults) (void))
((improper/done) (static-error expr
"Invalid default value specification"))
((improper/done) (static-error
"argument list" 'term:arglist-invalid-init-value
expr
"invalid default value specification"))
(else (internal-error (unbox status-holder)
"Invalid in paroptarglist-decl-entry-parser-vocab list"))))
(cond
@ -683,14 +710,16 @@
(create-lexical-binding+marks var)
val))))
(else
(static-error expr "Invalid init-var declaration"))))))
(static-error
"argument list" 'term:arglist-invalid-init-var-decl
expr "invalid init-var declaration"))))))
(define paroptarglist-decls-vocab
(create-vocabulary 'paroptarglist-decls-vocab #f
"Invalid argument list entry"
"Invalid argument list entry"
"Invalid argument list entry"
"Invalid argument list entry"))
"malformed argument list entry"
"malformed argument list entry"
"malformed argument list entry"
"malformed argument list entry"))
(add-sym-micro paroptarglist-decls-vocab
(lambda (expr env attributes vocab)
@ -723,8 +752,10 @@
(let loop ((result result) (exprs expr-list))
(if (null? (cdr result))
(when (initialized-paroptarglist-entry? (car result))
(static-error (car exprs)
"Last argument must not have an initial value"))
(static-error
"argument list" 'term:arglist-last-arg-no-init
(car exprs)
"last argument must not have an initial value"))
(loop (cdr result) (cdr exprs))))
(make-ilist-paroptarglist result)))))
@ -794,10 +825,10 @@
(define (make-arglist-decls-vocab)
(create-vocabulary 'arglist-decls-vocab #f
"Invalid argument list entry"
"Invalid argument list entry"
"Invalid argument list entry"
"Invalid argument list entry"))
"malformed argument list entry"
"malformed argument list entry"
"malformed argument list entry"
"malformed argument list entry"))
; note: the only difference between the lambda-<> vocabs and the <> vocabs
; is that the lambda-<> vocabs use create-lambda-binding+marks instead
@ -821,7 +852,9 @@
(binding-constructor expr)))))
(let ([m (lambda (expr env attributes vocab)
(static-error expr "Invalid argument list syntax"))])
(static-error
"argument list" 'term:arglist-invalid-syntax expr
"invalid syntax"))])
(add-sym-micro proper-vocab m)
(add-sym-micro nonempty-vocab m))
@ -831,7 +864,9 @@
(let ((contents (expose-list expr)))
(when (and (not null-ok?)
(null? contents))
(static-error expr "All procedures must take at least one argument"))
(static-error
"application" 'term:proc-arity->=-1 expr
"all procedures must take at least one argument"))
(make-list-arglist
(map binding-constructor contents)))))])
(add-list-micro nonempty-vocab (make-arg-list-micro #f))
@ -839,7 +874,9 @@
(add-list-micro full-vocab (make-arg-list-micro #t)))
(let ([m (lambda (expr env attributes vocab)
(static-error expr "Invalid argument list syntax"))])
(static-error
"argument list" 'term:arglist-invalid-syntax expr
"invalid syntax"))])
(add-ilist-micro proper-vocab m)
(add-ilist-micro nonempty-vocab m))

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

@ -1,4 +1,4 @@
; $Id: scm-hanc.ss,v 1.63 1999/05/21 12:53:26 mflatt Exp $
; $Id: scm-hanc.ss,v 1.64 1999/05/23 17:31:24 mflatt Exp $
(define-struct signature-element (source))
(define-struct (name-element struct:signature-element) (name))
@ -29,17 +29,16 @@
(signs (map car sign:rest)))
(unless (null? in)
(if (memq (car signs) (cdr signs))
(static-error (car in)
"Name \"~s\" is exported twice"
(car signs))
(static-error
"unit" 'term:unit-double-export (car in)
"name \"~s\" is exported twice" (car signs))
(loop (cdr in) (cdr signs)))))
(let loop ((in in:names)
(signs sign:names))
(unless (null? in)
(if (memq (car signs) (cdr signs))
(static-error (car in)
"Name \"~s\" is exported twice"
(car signs))
(static-error 'term:unit-double-export (car in)
"name \"~s\" is exported twice" (car signs))
(loop (cdr in) (cdr signs))))))
(let ((in (car in:all)) (sign (car sign:all)))
(if (or (symbol? sign) (z:symbol? sign))
@ -72,8 +71,10 @@
(else
(internal-error first "Invalid unit element")))))
(when (memq first-name seen)
(static-error (signature-element-source first)
"Duplicate signature entry: ~s" first-name))
(static-error
"signature" 'term:duplicate-signature
(signature-element-source first)
"duplicate entry: ~s" first-name))
(loop (cons first-name seen) (cdr rest))))))
(letrec
((split
@ -190,11 +191,13 @@
(let ((entry
(hash-table-get sig-space (z:read-object name)
(lambda ()
(static-error name "Unbound signature name: ~s"
(z:read-object name))))))
(static-error
"signature" 'term:unbound-sig-name name
"unbound name: ~s" (z:read-object name))))))
entry)
(static-error name "Unbound signature name: ~s"
(z:read-object name))))))
(static-error
"signature" 'term:unbound-sig-name name
"unbound name: ~s" (z:read-object name))))))
(define extract-sub-unit-signature
(lambda (signature indices)
@ -204,7 +207,9 @@
(raw-first (z:read-object first)))
(let loop ((elements (signature-elements signature)))
(if (null? elements)
(static-error first "No such sub-unit in signature")
(static-error
"signature" 'term:signature-no-sub-unit first
"no such sub-unit")
(if (unit-element? (car elements))
(if (eq? raw-first (unit-element-id (car elements)))
(extract-sub-unit-signature
@ -249,7 +254,9 @@
(lambda (table tag)
(cu/s-tag-table-lookup table tag
(lambda ()
(static-error tag "Unbound tag")))))
(static-error
"unit linkage" 'term:unit-link-unbound-tag tag
"unbound tag")))))
(define cu/s-tag-table-lookup/internal-error
(lambda (table tag)
@ -261,10 +268,10 @@
(define sig-vocab
(create-vocabulary 'sig-vocab #f
"Invalid signature expression"
"Invalid signature expression"
"Invalid signature expression"
"Invalid signature expression"))
"malformed signature expression"
"malformed signature expression"
"malformed signature expression"
"malformed signature expression"))
(add-sym-micro sig-vocab
(lambda (expr env attributes vocab)
@ -283,10 +290,10 @@
(define sig-element-vocab
(create-vocabulary 'sig-element-vocab #f
"Invalid signature element"
"Invalid signature element"
"Invalid signature element"
"Invalid signature element"))
"malformed signature element"
"malformed signature element"
"malformed signature element"
"malformed signature element"))
(add-sym-micro sig-element-vocab
(lambda (expr env attributes vocab)
@ -321,8 +328,11 @@
(let ((first (car omits)))
(when (z:symbol? first)
(unless (memq (z:read-object first) generated-names)
(static-error first
"Name not generated; illegal to omit")))
(static-error
"structs in signature"
'term:signature-struct-illegal-omit-name
first
"name not generated; illegal to omit")))
(loop (cdr omits)))))
(let ((real-omits
(let loop ((omits omit-names))
@ -338,20 +348,24 @@
(cons (make-name-element expr (car names))
(loop (cdr names))))))))))))
(else
(static-error expr "Malformed struct clause"))))))
(static-error
"struct" 'kwd:signature-struct expr
"malformed clause"))))))
(define signature-struct-omission-checker-vocab
(create-vocabulary 'signature-struct-omission-checker-vocab #f
"Invalid signature structure omission declaration"
"Invalid signature structure omission declaration"
"Invalid signature structure omission declaration"
"Invalid signature structure omission declaration"))
"malformed signature structure omission declaration"
"malformed signature structure omission declaration"
"malformed signature structure omission declaration"
"malformed signature structure omission declaration"))
(add-sym-micro signature-struct-omission-checker-vocab
(lambda (expr env attributes vocab)
(let ((raw-expr (z:read-object expr)))
(unless (memq raw-expr '(-selectors -setters))
(static-error expr "Invalid omission specifier"))
(static-error
"structs in signature" 'term:signature-invalid-struct-omit
expr "invalid omission specifier"))
raw-expr)))
(add-micro-form '- signature-struct-omission-checker-vocab
@ -367,7 +381,9 @@
(valid-syntactic-id? var)
(structurize-syntax (z:read-object var) expr))))
(else
(static-error expr "Malformed omission specifier"))))))
(static-error
"structs in signature" 'term:signature-malformed-omit-clause
expr "malformed omission specifier"))))))
(add-micro-form 'open sig-element-vocab
(let* ((kwd '(open))
@ -383,7 +399,9 @@
(signature-elements
(expand-expr sig env attributes sig-vocab)))))
(else
(static-error expr "Malformed open clause"))))))
(static-error
"structs in signature" 'term:signature-malformed-open-clause
expr "malformed open clause"))))))
(add-micro-form 'unit sig-element-vocab
(let* ((kwd '(unit :))
@ -400,16 +418,18 @@
(list (make-unit-element expr (z:read-object id)
(expand-expr sig env attributes sig-vocab))))))
(else
(static-error expr "Malformed unit clause"))))))
(static-error
"structs in signature" 'term:signature-malformed-unit-clause
expr "Malformed unit clause"))))))
; --------------------------------------------------------------------
(define u/s-prim-imports-vocab
(create-vocabulary 'u/s-prim-imports-vocab #f
"Invalid imports declaration"
"Invalid imports declaration"
"Invalid imports declaration"
"Invalid imports declaration"))
"malformed imports declaration"
"malformed imports declaration"
"malformed imports declaration"
"malformed imports declaration"))
(add-sym-micro u/s-prim-imports-vocab
(lambda (expr env attributes vocab)
@ -436,7 +456,9 @@
(expand-expr sig env attributes sig-vocab))
(z:read-object id)))))
((pat:match-against m&e-2 expr env)
(static-error expr "Ambiguous : in signature"))
(static-error
"signature" 'term:signature-ambiguous-:
expr "ambiguous : in signature"))
(else
(convert-to-prim-format
(signature-elements
@ -483,10 +505,10 @@
(define u/s-sign-imports-vocab
(create-vocabulary 'u/s-sign-imports-vocab #f
"Invalid signature imports declaration"
"Invalid signature imports declaration"
"Invalid signature imports declaration"
"Invalid signature imports declaration"))
"malformed signature imports declaration"
"malformed signature imports declaration"
"malformed signature imports declaration"
"malformed signature imports declaration"))
(add-sym-micro u/s-sign-imports-vocab
(lambda (expr env attributes vocab)
@ -512,7 +534,9 @@
(signature-exploded
(expand-expr sig env attributes sig-vocab))))))
((pat:match-against m&e-2 expr env)
(static-error expr "Ambiguous : in signature"))
(static-error
"signature" 'term:signature-ambiguous-:
expr "ambiguous : in signature"))
(else
(cons immediate-signature-name
(explode-signature-elements
@ -537,7 +561,9 @@
'()
(let ((first (car sig-names)))
(when (unit-element? first)
(static-error source "Unit exports not allowed"))
(static-error
"unit" 'term:no-unit-exports source
"unit exports not allowed"))
(let ((name (name-element-name first)))
(cons
(let ((entry (hash-table-get table name (lambda () #f))))
@ -550,10 +576,10 @@
(define u/s-sign-exports-vocab
(create-vocabulary 'u/s-sign-exports-vocab #f
"Invalid signature exports declaration"
"Invalid signature exports declaration"
"Invalid signature exports declaration"
"Invalid signature exports declaration"))
"malformed signature exports declaration"
"malformed signature exports declaration"
"malformed signature exports declaration"
"malformed signature exports declaration"))
(add-sym-micro u/s-sign-exports-vocab
(lambda (expr env attributes vocab)
@ -577,7 +603,9 @@
(signature-exploded
(expand-expr sig env attributes sig-vocab)))))
((pat:match-against m&e-2 expr env)
(static-error expr "Ambiguous : in signature"))
(static-error
"signature" 'term:signature-ambiguous-: expr
"ambiguous : in signature"))
(else
(explode-signature-elements
(signature-elements
@ -604,7 +632,9 @@
(structurize-syntax `(,'quote ,elements) expr '(-1))
env attributes vocab)))))
(else
(static-error expr "Malformed signature->symbols"))))))
(static-error
"signature->symbols" 'kwd:signature->symbols
expr "malformed expression"))))))
(add-primitivized-micro-form 'signature->symbols full-vocabulary signature->symbols-micro)
(add-on-demand-form 'micro 'signature->symbols common-vocabulary signature->symbols-micro)
@ -622,7 +652,9 @@
(sig (pat:pexpand 'sig p-env kwd)))
(valid-syntactic-id? name)
(unless (get-top-level-status attributes)
(static-error expr "Only supported at top-level"))
(static-error
"define-signature" 'kwd:define-signature
expr "only supported at top-level"))
(let ((elements
(signature-elements
(expand-expr sig env attributes sig-vocab))))
@ -632,7 +664,9 @@
#f (z:make-origin 'micro expr))
env attributes vocab))))
(else
(static-error expr "Malformed define-signature"))))))
(static-error
"define-signature" 'kwd:define-signature
expr "malformed definition"))))))
(add-primitivized-micro-form 'define-signature full-vocabulary define-signature-micro)
(add-primitivized-micro-form 'define-signature scheme-vocabulary define-signature-micro)
@ -678,7 +712,9 @@
(lambda ()
(pop-signature name attributes old-value)))))))
(else
(static-error expr "Malformed let-signature"))))))
(static-error
"let-signature" 'kwd:let-signature
expr "malformed expression"))))))
(add-primitivized-micro-form 'let-signature full-vocabulary let-signature-micro)
(add-primitivized-micro-form 'let-signature scheme-vocabulary let-signature-micro)
@ -697,17 +733,22 @@
(lambda (p-env)
(let ((filename (pat:pexpand 'filename p-env kwd)))
(unless (z:string? filename)
(static-error filename "File name must be a string"))
(static-error
"include" 'kwd:unit-include
filename "file name must be a string"))
(let ((raw-filename (z:read-object filename)))
(let-values (((base name dir?) (split-path raw-filename)))
(when dir?
(static-error filename "Cannot include a directory"))
(static-error
"include" 'kwd:unit-include
filename "cannot include a directory"))
(let* ((original-directory (current-load-relative-directory))
(p (with-handlers
((exn:i/o:filesystem?
(lambda (exn)
(static-error filename
"Unable to open file ~s: ~a" raw-filename exn))))
(static-error
"include" 'kwd:unit-include filename
"unable to open file ~s: ~a" raw-filename exn))))
(open-input-file
(if (and original-directory
(not (complete-path? raw-filename)))
@ -754,7 +795,9 @@
(lambda ()
(close-input-port p))))))))))
(else
(static-error expr "Malformed include"))))))
(static-error
"include" 'kwd:unit-include
expr "malformed expression"))))))
(define unit/sig-micro
(let* ((kwd-1 '(import rename))
@ -834,7 +877,9 @@
(z:make-origin 'micro expr))
env attributes vocab)))
(else
(static-error expr "Malformed unit/sig"))))))
(static-error
"unit/sig" 'kwd:unit/sig
expr "malformed expression"))))))
(add-primitivized-micro-form 'unit/sig full-vocabulary unit/sig-micro)
@ -844,10 +889,10 @@
(define cu/s-imports-record-tag-sigs-vocab
(create-vocabulary 'cu/s-imports-record-tag-sigs-vocab #f
"Invalid import clause"
"Invalid import clause"
"Invalid import clause"
"Invalid import clause"))
"malformed import clause"
"malformed import clause"
"malformed import clause"
"malformed import clause"))
(add-list-micro cu/s-imports-record-tag-sigs-vocab
(let* ((kwd '(:))
@ -863,18 +908,21 @@
(valid-syntactic-id? tag)
(let ((table (extract-cu/s-tag-table attributes)))
(when (cu/s-tag-table-lookup table tag)
(static-error tag
"Duplicate tag definition"))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig tag
"duplicate link tag definition"))
(cu/s-tag-table-put/import table tag sig env attributes)))))
(else
(static-error expr "Malformed compound-unit/sig import clause"))))))
(static-error
"compound unit/sig" 'kwd:compound-unit/sig expr
"malformed import clause"))))))
(define cu/s-sign-imports-vocab
(create-vocabulary 'cu/s-sign-imports-vocab #f
"Invalid import clause"
"Invalid import clause"
"Invalid import clause"
"Invalid import clause"))
"malformed import clause"
"malformed import clause"
"malformed import clause"
"malformed import clause"))
(add-list-micro cu/s-sign-imports-vocab
(let* ((kwd '(:))
@ -892,14 +940,16 @@
(tag-table-entry-signature
(cu/s-tag-table-lookup/internal-error table tag))))))))
(else
(static-error expr "Malformed compound-unit/sig import clause"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig expr
"malformed import clause"))))))
(define cu/s-link-imports-vocab
(create-vocabulary 'cu/s-link-imports-vocab #f
"Invalid link imports declaration"
"Invalid link imports declaration"
"Invalid link imports declaration"
"Invalid link imports declaration"))
"malformed link imports declaration"
"malformed link imports declaration"
"malformed link imports declaration"
"malformed link imports declaration"))
(add-list-micro cu/s-link-imports-vocab
(let* ((kwd '(:))
@ -918,16 +968,18 @@
(cu/s-tag-table-lookup/internal-error table tag)))
(z:read-object tag))))))
(else
(static-error expr "Malformed compound-unit/sig import clause"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig expr
"malformed import clause"))))))
; --------------------------------------------------------------------
(define cu/s-link-record-tag-sigs-vocab
(create-vocabulary 'cu/s-link-record-tag-sigs-vocab #f
"Invalid link clause"
"Invalid link clause"
"Invalid link clause"
"Invalid link clause"))
"malformed link clause"
"malformed link clause"
"malformed link clause"
"malformed link clause"))
(add-list-micro cu/s-link-record-tag-sigs-vocab
(let* ((kwd '(:))
@ -943,18 +995,22 @@
(valid-syntactic-id? tag)
(let ((table (extract-cu/s-tag-table attributes)))
(when (cu/s-tag-table-lookup table tag)
(static-error tag
"Duplicate tag definition"))
(static-error
"unit linkage" 'term:unit-link-duplicate-tag
tag
"duplicate link tag name"))
(cu/s-tag-table-put/link table tag sig env attributes)))))
(else
(static-error expr "Malformed compound-unit/sig link clause"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig
expr "malformed link clause"))))))
(define cu/s-link-exports-vocab
(create-vocabulary 'cu/s-link-exports-vocab #f
"Invalid link export declaration"
"Invalid link export declaration"
"Invalid link export declaration"
"Invalid link export declaration"))
"malformed link export declaration"
"malformed link export declaration"
"malformed link export declaration"
"malformed link export declaration"))
(add-list-micro cu/s-link-exports-vocab
(let* ((kwd '(:))
@ -971,14 +1027,16 @@
(tag-table-entry-signature
(cu/s-tag-table-lookup/internal-error table tag)))))))
(else
(static-error expr "Malformed compound-unit/sig link clause"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig
expr "malformed link clause"))))))
(define cu/s-link-tags-vocab
(create-vocabulary 'cu/s-link-tags-vocab #f
"Invalid link tag declaration"
"Invalid link tag declaration"
"Invalid link tag declaration"
"Invalid link tag declaration"))
"malformed link tag declaration"
"malformed link tag declaration"
"malformed link tag declaration"
"malformed link tag declaration"))
(add-list-micro cu/s-link-tags-vocab
(let* ((kwd '(:))
@ -992,14 +1050,16 @@
(let ((tag (pat:pexpand 'tag p-env kwd)))
tag)))
(else
(static-error expr "Malformed compound-unit/sig link clause"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig
expr "malformed link clause"))))))
(define cu/s-link-exprs-vocab
(create-vocabulary 'cu/s-link-exprs-vocab #f
"Invalid link expression"
"Invalid link expression"
"Invalid link expression"
"Invalid link expression"))
"malformed link expression"
"malformed link expression"
"malformed link expression"
"malformed link expression"))
(add-list-micro cu/s-link-exprs-vocab
(let* ((kwd '(:))
@ -1013,14 +1073,16 @@
(let ((expr (pat:pexpand 'expr p-env kwd)))
expr)))
(else
(static-error expr "Malformed compound-unit/sig link clause"))))))
(static-error
"compound-unit/sig" 'kwd:compount-unit/sig
expr "malformed link clause"))))))
(define cu/s-link-linking-sigs-vocab
(create-vocabulary 'cu/s-link-linking-sigs-vocab #f
"Invalid link clause"
"Invalid link clause"
"Invalid link clause"
"Invalid link clause"))
"malformed link clause"
"malformed link clause"
"malformed link clause"
"malformed link clause"))
(add-list-micro cu/s-link-linking-sigs-vocab
(let* ((kwd '(:))
@ -1040,7 +1102,9 @@
cu/s-unit-path-linkage-vocab))
path-elts))))
(else
(static-error expr "Malformed compound-unit/sig link clause"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig
expr "malformed link clause"))))))
(define cu/s-check-self-import
(lambda (tag attributes)
@ -1048,14 +1112,16 @@
(when (eq? (z:read-object tag)
(get-attribute attributes cu/s-this-link-attr
(lambda () (internal-error tag "No this-link attribute"))))
(static-error tag "Self import of tag ~s" (z:read-object tag))))))
(static-error
"unit linkage" 'term:unit-link-self-import-tag tag
"self import of tag ~s" (z:read-object tag))))))
(define cu/s-link-prim-unit-names-vocab
(create-vocabulary 'cu/s-link-prim-unit-names-vocab #f
"Invalid link clause"
"Invalid link clause"
"Invalid link clause"
"Invalid link clause"))
"malformed link clause"
"malformed link clause"
"malformed link clause"
"malformed link clause"))
(add-list-micro cu/s-link-prim-unit-names-vocab
(let* ((kwd '(:))
@ -1074,7 +1140,9 @@
cu/s-unit-path-prim-links-vocab))
path-elts)))))
(else
(static-error expr "Malformed compound-unit/sig link clause"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig
expr "malformed link clause"))))))
; --------------------------------------------------------------------
@ -1119,8 +1187,9 @@
(with-handlers
((exn:unit?
(lambda (exn)
(static-error expr
(exn-message exn)))))
(static-error
"signature matching" 'term:signature-not-matching
expr (exn-message exn)))))
(verify-signature-match 'compound-unit/sig
#f
(format "signature ~s" (signature-name small-sig))
@ -1143,8 +1212,9 @@
(with-handlers
((exn:unit?
(lambda (exn)
(static-error expr
(exn-message exn)))))
(static-error
"signature matching" 'term:signature-not-matching
expr (exn-message exn)))))
(verify-signature-match 'compound-unit/sig
#f
(format "signature ~s" (signature-name small-sig))
@ -1167,14 +1237,16 @@
(extract-sub-unit-signature initial-sig ids)))
final-sig)))))
(else
(static-error expr "Malformed unit path element"))))))
(static-error
"unit linkage" 'kwd:unit-link-path-malformed
expr "malformed unit path element"))))))
(define cu/s-unit-path-linkage-vocab
(create-vocabulary 'cu/s-unit-path-linkage-vocab #f
"Invalid linkage"
"Invalid linkage"
"Invalid linkage"
"Invalid linkage"))
"malformed linkage"
"malformed linkage"
"malformed linkage"
"malformed linkage"))
(add-sym-micro cu/s-unit-path-linkage-vocab
(lambda (expr env attributes vocab)
@ -1217,8 +1289,9 @@
(with-handlers
((exn:unit?
(lambda (exn)
(static-error expr
(exn-message exn)))))
(static-error
"signature matching" 'term:signature-not-matching
expr (exn-message exn)))))
(verify-signature-match 'compound-unit/sig
#f
(format "signature ~s" (signature-name small-sig))
@ -1243,8 +1316,9 @@
(with-handlers
((exn:unit?
(lambda (exn)
(static-error expr
(exn-message exn)))))
(static-error
"signature matching" 'term:signature-not-matching
expr (exn-message exn)))))
(verify-signature-match 'compound-unit/sig
#f
(format "signature ~s" (signature-name small-sig))
@ -1270,14 +1344,16 @@
(cons (z:read-object tag)
(signature-exploded final-sig)))))))
(else
(static-error expr "Malformed unit path element"))))))
(static-error
"unit linkage" 'kwd:unit-link-path-malformed
expr "malformed unit path element"))))))
(define cu/s-unit-path-prim-links-vocab
(create-vocabulary 'cu/s-unit-path-prim-links-vocab #f
"Invalid linkage"
"Invalid linkage"
"Invalid linkage"
"Invalid linkage"))
"malformed linkage"
"malformed linkage"
"malformed linkage"
"malformed linkage"))
(add-sym-micro cu/s-unit-path-prim-links-vocab
(lambda (expr env attributes vocab)
@ -1388,7 +1464,9 @@
(internal-error tag-table-entry
"Illegal tag-table entry")))))))))
(else
(static-error expr "Malformed unit path element"))))))
(static-error
"unit linkage" 'kwd:unit-link-path-malformed
expr "malformed unit path element"))))))
(define cu/s-unit-path-tag+build-prefix-vocab
(create-vocabulary 'cu/s-unit-path-tag+build-prefix-vocab))
@ -1448,7 +1526,9 @@
(cons ":"
(loop (cdr ids))))))))))))
(else
(static-error expr "Malformed unit path element"))))))
(static-error
"unit linkage" 'kwd:unit-link-path-malformed
expr "malformed unit path element"))))))
(define cu/s-unit-path-tag-vocab
(create-vocabulary 'cu/s-unit-path-tag-vocab))
@ -1496,7 +1576,9 @@
(ids (pat:pexpand '(id ...) p-env kwd)))
(z:read-object tag))))
(else
(static-error expr "Malformed unit path element"))))))
(static-error
"unit linkage" 'kwd:unit-link-path-malformed
expr "malformed unit path element"))))))
(define cu/s-build-link-names
(opt-lambda (signature (prefix-string ""))
@ -1542,17 +1624,19 @@
(let ((raw-var (z:read-object variable)))
(let loop ((elements (signature-elements sig)))
(if (null? elements)
(static-error variable "No such identifier in signature")
(static-error
"signature" 'term:signature-no-var variable
"no such identifier")
(or (and (name-element? (car elements))
(eq? raw-var (name-element-name (car elements))))
(loop (cdr elements))))))))
(define cu/s-prim-export-vocab
(create-vocabulary 'cu/s-prim-export-vocab #f
"Invalid export declaration"
"Invalid export declaration"
"Invalid export declaration"
"Invalid export declaration"))
"malformed export declaration"
"malformed export declaration"
"malformed export declaration"
"malformed export declaration"))
; Returns a fully-formed export element of the form
; (tag (internal-name external-name))
@ -1609,7 +1693,9 @@
(z:read-object variable))
external)))))))
(else
(static-error expr "Malformed var export"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig
expr "malformed var export"))))))
(add-micro-form 'open cu/s-prim-export-vocab
(let* ((kwd '(open))
@ -1635,7 +1721,9 @@
(convert-to-prim-format
(signature-elements final-sig))))))))
(else
(static-error expr "Malformed open export"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig
expr "malformed open export"))))))
(add-micro-form 'unit cu/s-prim-export-vocab
(let* ((kwd '(unit))
@ -1680,7 +1768,9 @@
(convert-to-prim-format (signature-elements final-sig)
(z:read-object variable))))))))
(else
(static-error expr "Malformed unit export"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig
expr "malformed unit export"))))))
(define cu/s-export-sign-vocab
(create-vocabulary 'cu/s-export-sign-vocab))
@ -1707,7 +1797,9 @@
(external (pat:pexpand 'external-variable p-env kwd)))
(list external))))
(else
(static-error expr "Malformed var export"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig
expr "malformed var export"))))))
(add-micro-form 'open cu/s-export-sign-vocab
(let* ((kwd '(open))
@ -1724,7 +1816,9 @@
cu/s-unit-path-extract-final-sig-vocab)))
(signature-exploded final-sig)))))
(else
(static-error expr "Malformed open export"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig
expr "malformed open export"))))))
(add-micro-form 'unit cu/s-export-sign-vocab
(let* ((kwd '(unit))
@ -1760,7 +1854,9 @@
(list (cons (z:read-object variable)
(signature-exploded final-sig)))))))
(else
(static-error expr "Malformed unit export"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig
expr "malformed unit export"))))))
; --------------------------------------------------------------------
@ -1869,7 +1965,9 @@
(z:make-origin 'micro expr))
env attributes vocab))))))
(else
(static-error expr "Malformed compound-unit/sig"))))))
(static-error
"compound-unit/sig" 'kwd:compound-unit/sig
expr "malformed expression"))))))
(add-primitivized-micro-form 'compound-unit/sig full-vocabulary compound-unit/sig-micro)
(add-primitivized-micro-form 'compound-unit/sig scheme-vocabulary compound-unit/sig-micro)
@ -1879,10 +1977,10 @@
(define iu/s-linkage-vocab
(create-vocabulary 'iu/s-linkage-vocab #f
"Invalid linkage declaration"
"Invalid linkage declaration"
"Invalid linkage declaration"
"Invalid linkage declaration"))
"malformed linkage declaration"
"malformed linkage declaration"
"malformed linkage declaration"
"malformed linkage declaration"))
(add-sym-micro iu/s-linkage-vocab
(lambda (expr env attributes vocab)
@ -1907,7 +2005,9 @@
(signature-exploded
(expand-expr in:sig env attributes sig-vocab))))))
((pat:match-against m&e-2 expr env)
(static-error expr "Ambiguous : in signature"))
(static-error
"signature" 'term:signature-ambiguous-: expr
"ambiguous : in signature"))
(else
(cons immediate-signature-name
(signature-exploded
@ -1915,10 +2015,10 @@
(define iu/s-imports-vocab
(create-vocabulary 'iu/s-imports-vocab #f
"Invalid import declaration"
"Invalid import declaration"
"Invalid import declaration"
"Invalid import declaration"))
"malformed import declaration"
"malformed import declaration"
"malformed import declaration"
"malformed import declaration"))
(add-sym-micro iu/s-imports-vocab
(lambda (expr env attributes vocab)
@ -1943,7 +2043,9 @@
(expand-expr in:sig env attributes sig-vocab))
(z:read-object in:id)))))
((pat:match-against m&e-2 expr env)
(static-error expr "Ambiguous : in signature"))
(static-error
"signature" 'term:signature-ambiguous-: expr
"ambiguous : in signature"))
(else
(convert-to-prim-format
(signature-elements
@ -1996,7 +2098,9 @@
in:expr in:linkage
expr env attributes vocab))))
(else
(static-error expr "Malformed invoke-unit/sig"))))))
(static-error
"invoke-unit/sig" 'kwd:invoke-unit/sig
expr "malformed expression"))))))
(add-primitivized-micro-form 'invoke-unit/sig full-vocabulary invoke-unit/sig-micro)
(add-primitivized-micro-form 'invoke-unit/sig scheme-vocabulary invoke-unit/sig-micro)
@ -2036,7 +2140,9 @@
(z:make-origin 'micro expr))
env attributes vocab))))
(else
(static-error expr "Malformed unit->unit/sig"))))))
(static-error
"unit->unit/sig" 'kwd:unit->unit/sig
expr "malformed expression"))))))
(add-primitivized-micro-form 'unit->unit/sig full-vocabulary unit->unit/sig-micro)
(add-primitivized-micro-form 'unit->unit/sig scheme-vocabulary unit->unit/sig-micro)
@ -2088,10 +2194,17 @@
(m&e (pat:make-match&env in-pattern kwd))
(m&e2 (pat:make-match&env in-pattern2 kwd))
(badsyntax (lambda (expr why)
(static-error expr
(format "Malformed ~adefine-values/invoke-unit/sig~a"
(if global? "global-" "")
why)))))
(static-error
(if global?
"global-define-values"
"define-values")
(if global?
'kwd:global-define-values
'kwd:define-values)
expr
(format "Malformed ~adefine-values/invoke-unit/sig~a"
(if global? "global-" "")
why)))))
(lambda (expr env attributes vocab)
(let ([doit (lambda (p-env prefix?)
(let ((in:export (pat:pexpand 'export p-env kwd))

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

File diff suppressed because it is too large Load Diff

176
collects/zodiac/scm-obj.ss
View File

@ -1,4 +1,4 @@
; $Id: scm-obj.ss,v 1.43 1999/05/20 22:36:52 mflatt Exp $
; $Id: scm-obj.ss,v 1.44 1999/05/21 12:53:29 mflatt Exp $
(unit/sig zodiac:scheme-objects^
(import zodiac:misc^ (z : zodiac:structures^) (z : zodiac:reader-structs^)
@ -111,7 +111,9 @@
variables
expr)))))
(else
(static-error expr "Malformed interface"))))))
(static-error
"interface" 'kwd:interface
expr "malformed declaration"))))))
(add-primitivized-micro-form 'interface full-vocabulary interface-micro)
(add-primitivized-micro-form 'interface scheme-vocabulary interface-micro)
@ -122,6 +124,8 @@
(lambda (expr env attributes vocab)
(let ((r (resolve expr env vocab)))
(cond
((lambda-binding? r)
(create-lambda-varref r expr))
((lexical-binding? r)
(create-lexical-varref r expr))
((top-level-resolution? r)
@ -142,8 +146,9 @@
((superinit-binding? r)
(create-superinit-varref r expr))
((or (macro-resolution? r) (micro-resolution? r))
(static-error expr
"Invalid use of keyword ~s" (z:symbol-orig-name expr)))
(static-error
"keyword" 'term:keyword-out-of-context expr
"invalid use of keyword ~s" (z:symbol-orig-name expr)))
(else
(internal-error expr "Invalid resolution in obj: ~s" r))))))
@ -171,24 +176,24 @@
(define ivar-decls-vocab
(create-vocabulary 'ivar-decls-vocab #f
"Invalid ivar declaration"
"Invalid ivar declaration"
"Invalid ivar declaration"
"Invalid ivar declaration"))
"malformed ivar declaration"
"malformed ivar declaration"
"malformed ivar declaration"
"malformed ivar declaration"))
(define public-ivar-decl-entry-parser-vocab
(create-vocabulary 'public-ivar-decl-entry-parser-vocab #f
"Invalid public declaration"
"Invalid public declaration"
"Invalid public declaration"
"Invalid public declaration"))
"malformed public declaration"
"malformed public declaration"
"malformed public declaration"
"malformed public declaration"))
(define override-ivar-decl-entry-parser-vocab
(create-vocabulary 'override-ivar-decl-entry-parser-vocab #f
"Invalid override declaration"
"Invalid override declaration"
"Invalid override declaration"
"Invalid override declaration"))
"malformed override declaration"
"malformed override declaration"
"malformed override declaration"
"malformed override declaration"))
(add-sym-micro public-ivar-decl-entry-parser-vocab
(lambda (expr env attributes vocab)
@ -237,7 +242,9 @@
var
(make-void-init-expr expr)))))
(else
(static-error expr (format "Invalid ~a ivar declaration" kind-str)))))))
(static-error
"ivar" 'term:invalid-ivar-decl
expr (format "malformed ~a declaration" kind-str)))))))
(let* ((kwd `(,kind-sym))
(in-pattern `(,kind-sym ivar-decl ...))
@ -258,7 +265,9 @@
(map cadr decls)
(map caddr decls)))))
(else
(static-error expr (format "Invalid ~a clause" kind-str))))))))
(static-error
"ivar" 'term:invalid-ivar-clause
expr (format "malformed ~a clause" kind-str))))))))
(mk-public/override-micro 'public "public"
public-ivar-decl-entry-parser-vocab
@ -274,10 +283,10 @@
(define private-ivar-decl-entry-parser-vocab
(create-vocabulary 'private-ivar-decl-entry-parser-vocab #f
"Invalid private declaration"
"Invalid private declaration"
"Invalid private declaration"
"Invalid private declaration"))
"malformed private declaration"
"malformed private declaration"
"malformed private declaration"
"malformed private declaration"))
(add-sym-micro private-ivar-decl-entry-parser-vocab
(lambda (expr env attributes vocab)
@ -307,7 +316,9 @@
(cons (create-private-binding+marks var)
(make-void-init-expr expr)))))
(else
(static-error expr "Invalid ivar declaration"))))))
(static-error
"ivar" 'term:invalid-ivar-decl
expr "malformed declaration"))))))
(let* ((kwd '(private))
(in-pattern '(private ivar-decl ...))
@ -327,16 +338,18 @@
(map car decls)
(map cdr decls)))))
(else
(static-error expr "Invalid private clause"))))))
(static-error
"private" 'kwd:class-private
expr "malformed declaration"))))))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define inherit-ivar-decl-entry-parser-vocab
(create-vocabulary 'inherit-ivar-decl-entry-parser-vocab #f
"Invalid inherit declaration"
"Invalid inherit declaration"
"Invalid inherit declaration"
"Invalid inherit declaration"))
"malformed inherit declaration"
"malformed inherit declaration"
"malformed inherit declaration"
"malformed inherit declaration"))
(add-sym-micro inherit-ivar-decl-entry-parser-vocab
(lambda (expr env attributes vocab)
@ -361,7 +374,9 @@
(create-inherit-binding+marks internal-var)
var))))
(else
(static-error expr "Invalid ivar declaration"))))))
(static-error
"ivar" 'term:invalid-ivar-decl
expr "malformed declaration"))))))
(let* ((kwd '(inherit))
(in-pattern '(inherit ivar-decl ...))
@ -381,16 +396,18 @@
(map car decls)
(map cdr decls)))))
(else
(static-error expr "Invalid inherit clause"))))))
(static-error
"inherit" 'kwd:class-inherit
expr "malformed declaration"))))))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
(define rename-ivar-decl-entry-parser-vocab
(create-vocabulary 'rename-ivar-decl-entry-parser-vocab #f
"Invalid rename declaration"
"Invalid rename declaration"
"Invalid rename declaration"
"Invalid rename declaration"))
"malformed rename declaration"
"malformed rename declaration"
"malformed rename declaration"
"malformed rename declaration"))
(add-list-micro rename-ivar-decl-entry-parser-vocab
(let* ((kwd '())
@ -407,7 +424,9 @@
(valid-syntactic-id? inherited-var)
(cons (create-rename-binding+marks var) inherited-var))))
(else
(static-error expr "Invalid ivar declaration"))))))
(static-error
"ivar" 'term:invalid-ivar-decl
expr "malformed declaration"))))))
(let* ((kwd '(rename))
(in-pattern '(rename ivar-decl ...))
@ -427,7 +446,9 @@
(map car decls)
(map cdr decls)))))
(else
(static-error expr "Invalid rename clause"))))))
(static-error
"rename" 'kwd:class-rename
expr "malformed declaration"))))))
; - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
@ -443,7 +464,9 @@
(make-sequence-entry
(pat:pexpand '(expr ...) p-env kwd))))
(else
(static-error expr "Invalid sequence clause"))))))
(static-error
"sequence" 'kwd:class-sequence
expr "malformed declaration"))))))
; ----------------------------------------------------------------------
@ -477,7 +500,9 @@
(z:make-origin 'micro expr))
env attributes vocab))))
(else
(static-error expr "Malformed class"))))))
(static-error
"class" 'kwd:class
expr "malformed expression"))))))
(add-primitivized-micro-form 'class full-vocabulary class-micro)
(add-primitivized-micro-form 'class scheme-vocabulary class-micro)
@ -512,18 +537,13 @@
(z:make-origin 'micro expr))
env attributes vocab))))
(else
(static-error expr "Malformed class*"))))))
(static-error
"class*" 'kwd:class*
expr "malformed expression"))))))
(add-primitivized-micro-form 'class* full-vocabulary class*-micro)
(add-primitivized-micro-form 'class* scheme-vocabulary class*-micro)
(define flag-non-supervar
(lambda (super env)
(unless (supervar-binding?
(resolve-in-env (z:read-object super)
(z:symbol-marks super) env))
(static-error super "Not a superclass reference"))))
(define class*/names-micro
(let* ((kwd '())
(in-pattern `(kwd (this super-init)
@ -669,7 +689,9 @@
env)
result))))))))))
(else
(static-error expr "Malformed class*/names"))))))
(static-error
"class*/names" 'kwd:class*/names
expr "malformed expression"))))))
(add-primitivized-micro-form 'class*/names full-vocabulary class*/names-micro)
@ -700,7 +722,9 @@
(z:make-origin 'micro expr))
env attributes vocab))))))
(else
(static-error expr "Malformed ivar"))))))
(static-error
"ivar" 'kwd:ivar
expr "malformed expression"))))))
(add-primitivized-micro-form 'ivar full-vocabulary ivar-micro)
(add-primitivized-micro-form 'ivar scheme-vocabulary ivar-micro)
@ -712,7 +736,9 @@
(m&e (pat:make-match&env in-pattern kwd)))
(lambda (expr env)
(or (pat:match-and-rewrite expr m&e out-pattern kwd env)
(static-error expr "Malformed send")))))
(static-error
"send" 'kwd:send
expr "malformed expression")))))
(add-primitivized-macro-form 'send full-vocabulary send-macro)
(add-primitivized-macro-form 'send scheme-vocabulary send-macro)
@ -726,22 +752,42 @@
...)))
(lambda (expr env)
(or (pat:match-and-rewrite expr m&e out-pattern kwd env)
(static-error expr "Malformed send*")))))
(static-error
"send*" 'kwd:send*
expr "malformed expression")))))
(add-primitivized-macro-form 'send* full-vocabulary send*-macro)
(add-on-demand-form 'macro 'send* common-vocabulary send*-macro)
(define make-generic-macro
(let* ((kwd '())
(in-pattern '(_ class name))
(m&e (pat:make-match&env in-pattern kwd))
(out-pattern '(#%make-generic/proc class (quote name))))
(lambda (expr env)
(or (pat:match-and-rewrite expr m&e out-pattern kwd env)
(static-error expr "Malformed make-generic")))))
(define make-generic-micro
(let* ((kwd '())
(in-pattern '(_ ci name))
(m&e (pat:make-match&env in-pattern kwd)))
(lambda (expr env attributes vocab)
(cond
((pat:match-against m&e expr env)
=>
(lambda (p-env)
(let ((ci (pat:pexpand 'ci p-env kwd))
(name (pat:pexpand 'name p-env kwd)))
(valid-syntactic-id? name)
(as-nested
attributes
(lambda ()
(expand-expr
(structurize-syntax
`(#%make-generic/proc ,ci (quote ,name))
expr '(-1)
#f
(z:make-origin 'micro expr))
env attributes vocab))))))
(else
(static-error
"make-generic" 'kwd:make-generic
expr "malformed expression"))))))
(add-primitivized-macro-form 'make-generic full-vocabulary make-generic-macro)
(add-primitivized-macro-form 'make-generic scheme-vocabulary make-generic-macro)
(add-primitivized-micro-form 'make-generic full-vocabulary make-generic-micro)
(add-primitivized-micro-form 'make-generic scheme-vocabulary make-generic-micro)
; ----------------------------------------------------------------------
@ -763,10 +809,14 @@
env attributes vocab)))))
(when (or (inherit-varref? id-expr)
(rename-varref? id-expr))
(static-error var-p
"Cannot mutate inherited or renamed variables"))
(static-error
"set!" 'term:no-set!-inherited/renamed
var-p
"cannot mutate inherited or renamed variables"))
(create-set!-form id-expr expr-expr expr))
(static-error expr "Malformed set!"))))))
(static-error
"set!" 'kwd:set!
expr "malformed expression"))))))
(add-primitivized-micro-form 'set! full-vocabulary set!-micro)
(add-primitivized-micro-form 'set! scheme-vocabulary set!-micro)

10
collects/zodiac/scm-ou.ss
View File

@ -1,4 +1,4 @@
; $Id: scm-ou.ss,v 1.17 1999/02/02 19:33:15 mflatt Exp $
; $Id: scm-ou.ss,v 1.18 1999/04/07 22:38:04 mflatt Exp $
(unit/sig zodiac:scheme-objects+units^
(import zodiac:misc^ (z : zodiac:structures^) (z : zodiac:reader-structs^)
@ -12,6 +12,8 @@
(lambda (expr env attributes vocab)
(let loop ((r (resolve expr env vocab)))
(cond
((lambda-binding? r)
(create-lambda-varref r expr))
((lexical-binding? r)
(create-lexical-varref r expr))
((top-level-resolution? r)
@ -35,9 +37,9 @@
(if (and (inside-unit? attributes)
(check-export expr attributes))
(loop top-level-resolution)
(static-error
expr
"Invalid use of keyword ~a" (z:symbol-orig-name expr))))
(static-error
"keyword" 'term:keyword-out-of-context expr
"invalid use of keyword ~s" (z:symbol-orig-name expr))))
(else
(internal-error expr "Invalid resolution in ou: ~s" r))))))))

166
collects/zodiac/scm-spdy.ss
View File

@ -1,4 +1,4 @@
; $Id: scm-spdy.ss,v 1.42 1999/01/16 15:47:07 mflatt Exp $
; $Id: scm-spdy.ss,v 1.43 1999/03/15 14:35:40 mflatt Exp $
(unit/sig zodiac:scheme-mrspidey^
(import zodiac:misc^ (z : zodiac:structures^)
@ -71,7 +71,7 @@
; --------------------------------------------------------------------
(define mrspidey-vocabulary
(create-vocabulary 'mrspidey-vocabulary full-vocabulary))
(create-vocabulary 'mrspidey-vocabulary scheme-vocabulary))
; --------------------------------------------------------------------
@ -89,7 +89,9 @@
(expand-expr p-expr env attributes vocab)
expr))))
(else
(static-error expr "Malformed poly"))))))
(static-error
"polymorphic" 'kwd:polymorphic
expr "malformed definition"))))))
(add-primitivized-micro-form ': mrspidey-vocabulary
(let* ((kwd '())
@ -107,7 +109,9 @@
(sexp->raw type)
expr))))
(else
(static-error expr "Malformed :"))))))
(static-error
":" 'kwd::
expr "malformed declaration"))))))
(add-primitivized-micro-form 'type: mrspidey-vocabulary
(let* ((kwd '())
@ -125,7 +129,9 @@
(map sexp->raw attrs)
expr))))
(else
(static-error expr "Malformed type:"))))))
(static-error
"type:" 'kwd:type:
expr "malformed declaration"))))))
(add-primitivized-micro-form 'mrspidey:control mrspidey-vocabulary
(let* ((kwd '())
@ -143,7 +149,9 @@
(sexp->raw val)
expr))))
(else
(static-error expr "Malformed mrspidey:control"))))))
(static-error
"mrspidey:control" 'kwd:mrspidey:control
expr "malformed declaration"))))))
(add-primitivized-micro-form 'define-type mrspidey-vocabulary
(let* ((kwd '())
@ -162,7 +170,9 @@
(sexp->raw type)
expr))))
(else
(static-error expr "Malformed define-type"))))))
(static-error
"define-type" 'kwd:define-type
expr "malformed definition"))))))
(add-primitivized-micro-form 'define-constructor mrspidey-vocabulary
(let* ((kwd '())
@ -181,14 +191,18 @@
; I have no idea what (assert-syn def ...) does.
(map (lambda (mode)
(unless (z:boolean? mode)
(static-error mode "Malformed mode")))
(static-error
"define-constructor" 'kwd:define-constructor
mode "malformed mode")))
modes)
(create-define-constructor-form
(z:read-object sym)
(map sexp->raw modes)
expr))))
(else
(static-error expr "Malformed define-constructor"))))))
(static-error
"define-constructor" 'kwd:define-constructor
expr "malformed definition"))))))
(add-primitivized-micro-form 'reference-file mrspidey-vocabulary
(let* ((kwd '())
@ -207,15 +221,20 @@
(let-values (((base name dir?)
(split-path raw-filename)))
(when dir?
(static-error file
"Cannot include a directory"))
(static-error
"reference-file" 'kwd:reference-file
file
"cannot include a directory"))
(let* ((original-directory
(current-load-relative-directory))
(p (with-handlers
((exn:i/o:filesystem?
(lambda (exn)
(static-error file
"Unable to open file ~a"
(static-error
"reference-file"
'kwd:reference-file
file
"unable to open file ~a"
raw-filename))))
(open-input-file
(if (complete-path? raw-filename)
@ -254,7 +273,9 @@
(cons input
(loop)))))))
(if (null? code)
(static-error expr "Empty file")
(static-error
"reference-file" 'kwd:reference-file
expr "empty file")
(expand-expr
(structurize-syntax
`(begin ,@code)
@ -263,12 +284,16 @@
(lambda ()
(current-load-relative-directory original-directory)
(close-input-port p))))))
(static-error file "Does not yield a filename"))))))
(static-error
"reference-file" 'kwd:reference-file
file "does not yield a filename"))))))
(else
(static-error expr "Malformed reference-file"))))))
(static-error
"reference-file" 'kwd:reference-file
expr "malformed expression"))))))
(define reference-library/relative-maker
(lambda (form-name make-raw-filename)
(lambda (form-name kwd:form-name make-raw-filename)
(let* ((kwd '())
(in-pattern '(_ filename collections ...))
(m&e (pat:make-match&env in-pattern kwd)))
@ -285,12 +310,16 @@
collections)))
(unless (and (quote-form? f)
(z:string? (quote-form-expr f)))
(static-error filename "Does not yield a filename"))
(static-error
(symbol->string form-name) kwd:form-name
filename "does not yield a filename"))
(for-each
(lambda (c collection)
(unless (and (quote-form? c)
(z:string? (quote-form-expr c)))
(static-error collection "Does not yield a string")))
(static-error
(symbol->string form-name) kwd:form-name
collection "does not yield a string")))
cs collections)
(let* ((raw-f (z:read-object (quote-form-expr f)))
(raw-cs (map (lambda (c)
@ -299,16 +328,22 @@
(raw-filename
(if (relative-path? raw-f)
(or (make-raw-filename raw-f raw-cs expr)
(static-error filename
"No such library file found"))
(static-error f
"Library path ~s must be a relative path"
(static-error
(symbol->string form-name) kwd:form-name
filename
"no such library file found"))
(static-error
(symbol->string form-name) kwd:form-name
f
"library path ~s must be a relative path"
raw-f))))
(let-values (((base name dir?)
(split-path raw-filename)))
(when dir?
(static-error filename
"Cannot include a directory"))
(static-error
(symbol->string form-name) kwd:form-name
filename
"cannot include a directory"))
(let ((original-directory
(current-load-relative-directory))
(original-collections
@ -316,8 +351,11 @@
(p (with-handlers
((exn:i/o:filesystem?
(lambda (exn)
(static-error filename
"Unable to open file ~a"
(static-error
(symbol->string form-name)
kwd:form-name
filename
"unable to open file ~a"
raw-filename))))
(open-input-file raw-filename))))
(dynamic-wind
@ -347,7 +385,10 @@
(cons input
(loop)))))))
(if (null? code)
(static-error expr "Empty file")
(static-error
(symbol->string form-name)
kwd:form-name
expr "empty file")
(expand-expr
(structurize-syntax
`(begin ,@code)
@ -360,25 +401,31 @@
original-collections)
(close-input-port p))))))))))
(else
(static-error expr (string-append "Malformed "
(symbol->string form-name)))))))))
(static-error
(symbol->string form-name) kwd:form-name
expr
(string-append "malformed expression"))))))))
(add-primitivized-micro-form 'require-library mrspidey-vocabulary
(reference-library/relative-maker 'require-library
'kwd:require-library
(lambda (raw-f raw-cs expr)
(apply mzlib:find-library raw-f raw-cs))))
(add-primitivized-micro-form 'require-relative-library mrspidey-vocabulary
(reference-library/relative-maker 'require-relative-library
'kwd:require-relative-library
(lambda (raw-f raw-cs expr)
(apply mzlib:find-library raw-f
(append (or (current-require-relative-collection)
(static-error expr
"No current collection for library \"~a\"" raw-f))
(static-error
"require-relative-library" 'kwd:require-relative-library
expr
"no current collection for library \"~a\"" raw-f))
raw-cs)))))
(define reference-unit-maker
(lambda (form-name signed?)
(lambda (form-name kwd:form-name signed?)
(add-primitivized-micro-form form-name mrspidey-vocabulary
(let* ((kwd '())
(in-pattern `(_ file))
@ -402,15 +449,19 @@
'exp
signed?
expr)
(static-error file "Does not yield a filename"))))))
(static-error
(symbol->string form-name) kwd:form-name
file "does not yield a filename"))))))
(else
(static-error expr "Malformed ~a" form-name))))))))
(static-error
(symbol->string form-name) kwd:form-name
expr "malformed expression"))))))))
(reference-unit-maker 'require-unit #f)
(reference-unit-maker 'require-unit/sig #t)
(reference-unit-maker 'require-unit 'kwd:require-unit #f)
(reference-unit-maker 'require-unit/sig 'kwd:require-unit/sig #t)
(define reference-library-unit-maker
(lambda (form-name sig? relative?)
(lambda (form-name kwd:form-name sig? relative?)
(add-primitivized-micro-form form-name mrspidey-vocabulary
(let* ((kwd '())
(in-pattern '(_ filename collections ...))
@ -429,13 +480,17 @@
collections)))
(unless (and (quote-form? f)
(z:string? (quote-form-expr f)))
(static-error filename "Does not yield a filename"))
(static-error
(symbol->string form-name) kwd:form-name
filename "does not yield a filename"))
(for-each
(lambda (c collection)
(unless (and (quote-form? c)
(z:string? (quote-form-expr c)))
(static-error collection
"Does not yield a string")))
(static-error
(symbol->string form-name) kwd:form-name
collection
"does not yield a string")))
cs collections)
(let ((raw-f (z:read-object (quote-form-expr f)))
(raw-cs (map (lambda (c)
@ -443,8 +498,10 @@
(quote-form-expr c)))
cs)))
(unless (relative-path? raw-f)
(static-error f
"Library path ~s must be a relative path"
(static-error
(symbol->string form-name) kwd:form-name
f
"library path ~s must be a relative path"
raw-f))
(create-reference-unit-form
(structurize-syntax
@ -455,8 +512,10 @@
null)
raw-cs)
raw-cs))
(static-error expr
"Unable to locate library ~a in collection path ~a"
(static-error
(symbol->string form-name) kwd:form-name
expr
"unable to locate library ~a in collection path ~a"
raw-f
(if (null? raw-cs) "mzlib" raw-cs)))
(or (current-load-relative-directory)
@ -466,13 +525,18 @@
sig?
expr))))))
(else
(static-error expr
(string-append "Malformed ~a" form-name)))))))))
(static-error
(symbol->string form-name) kwd:form-name
expr "malformed expression"))))))))
(reference-library-unit-maker 'require-library-unit #f #f)
(reference-library-unit-maker 'require-library-unit/sig #t #f)
(reference-library-unit-maker 'require-relative-library-unit #f #t)
(reference-library-unit-maker 'require-relative-library-unit/sig #t #t)
(reference-library-unit-maker 'require-library-unit
'kwd:require-library-unit #f #f)
(reference-library-unit-maker 'require-library-unit/sig
'kwd:require-library-unit/sig #t #f)
(reference-library-unit-maker 'require-relative-library-unit
'kwd:require-relative-library-unit #f #t)
(reference-library-unit-maker 'require-relative-library-unit/sig
'kwd:require-relative-library-unit/sig #t #t)
' (add-primitivized-micro-form 'references-unit-imports mrspidey-vocabulary
(let* ((kwd '())

311
collects/zodiac/scm-unit.ss
View File

@ -1,4 +1,4 @@
; $Id: scm-unit.ss,v 1.86 1999/05/21 12:53:30 mflatt Exp $
; $Id: scm-unit.ss,v 1.87 2000/01/10 22:51:12 clements Exp $
(unit/sig zodiac:scheme-units^
(import zodiac:misc^ (z : zodiac:structures^)
@ -118,9 +118,11 @@
(unless (null? unresolveds)
(let ([id (unresolved-id (car unresolveds))])
(check-for-signature-name id attributes)
(static-error (unresolved-id (car unresolveds))
"Unbound unit identifier ~a"
(z:read-object id)))))
(static-error
"unit" 'term:unit-unbound-id
(unresolved-id (car unresolveds))
"unbound identifier ~a"
(z:read-object id)))))
(put-attribute attributes 'unresolved-unit-vars
(cons (append unresolveds (car left-unresolveds))
(cdr left-unresolveds)))))))
@ -146,7 +148,9 @@
(hash-table-put! id-table id-name
(make-link-id id)))
((link-id? entry)
(static-error id "Duplicate link name"))
(static-error
"unit linkage" 'term:unit-link-duplicate-tag
id "duplicate link tag name"))
(else
(internal-error entry "Invalid in register-links"))))))
ids)))
@ -191,13 +195,17 @@
(hash-table-put! id-table id-name
(make-import-id id)))
((import-id? entry)
(static-error id "Duplicate import identifier ~a" id-name))
(static-error
"unit" 'term:unit-duplicate-import
id "duplicate import identifier ~a" id-name))
((export-id? entry)
(static-error id "Exported identifier ~a being imported"
id-name))
(static-error
"unit" 'term:unit-import-exported
id "exported identifier ~a being imported" id-name))
((internal-id? entry)
(static-error id
"Defined identifier ~a being imported" id-name))
(static-error
"unit" 'term:unit-defined-imported
id "defined identifier ~a being imported" id-name))
(else
(internal-error entry
"Invalid in register-import/export")))))))
@ -215,15 +223,19 @@
(hash-table-put! id-table id-name
(make-internal-id id)))
((import-id? entry)
(static-error id "Redefined imported identifier ~a" id-name))
(static-error
"unit" 'term:unit-redefined-import
id "redefined imported identifier ~a" id-name))
((export-id? entry)
(if (export-id-defined? entry)
(static-error id "Redefining exported identifier ~a"
id-name)
(static-error
"unit" 'term:unit-duplicate-definition
id "redefining exported identifier ~a" id-name)
(set-export-id-defined?! entry #t)))
((internal-id? entry)
(static-error id "Duplicate internal definition for ~a"
id-name))
(static-error
"unit" 'term:unit-duplicate-definition
id "duplicate internal definition for ~a" id-name))
(else
(internal-error entry
"Invalid entry in register-definitions"))))))
@ -240,10 +252,13 @@
(hash-table-put! id-table id-name
(make-export-id id #f)))
((import-id? entry)
(static-error id "Imported identifier ~a being exported"
id-name))
(static-error
"unit" 'term:unit-import-exported
id "imported identifier ~a being exported" id-name))
((export-id? entry)
(static-error id "Duplicate export identifier ~a" id-name))
(static-error
"unit" 'term:unit-duplicate-export
id "duplicate export identifier ~a" id-name))
((internal-id? entry)
(internal-error entry
"Should not have had an internal-id in register-export"))
@ -259,15 +274,18 @@
(lambda () #f))))
(cond
((not entry)
(static-error id "Exported identifier ~a not defined"
id-name))
(static-error
"unit" 'term:unit-export-not-defined
id "Exported identifier ~a not defined" id-name))
((import-id? entry)
(static-error id "Imported identifier ~a being exported"
id-name))
(static-error
"unit" 'term:unit-import-exported
id "imported identifier ~a being exported" id-name))
((export-id? entry)
(unless (export-id-defined? entry)
(static-error id "Exported identifier ~a not defined"
id-name)))
(static-error
"unit" 'term:unit-export-not-defined
id "exported identifier ~a not defined" id-name)))
((internal-id? entry)
(internal-error entry
"Should not have had an internal-id in verify-export"))
@ -318,10 +336,10 @@
(define c/imports-vocab
(create-vocabulary 'c/imports-vocab #f
"Invalid import declaration"
"Invalid import declaration"
"Invalid import declaration"
"Invalid import declaration"))
"malformed import declaration"
"malformed import declaration"
"malformed import declaration"
"malformed import declaration"))
(add-sym-micro c/imports-vocab
(lambda (expr env attributes vocab)
@ -332,10 +350,10 @@
(define unit-register-exports-vocab
(create-vocabulary 'unit-register-exports-vocab #f
"Invalid export declaration"
"Invalid export declaration"
"Invalid export declaration"
"Invalid export declaration"))
"malformed export declaration"
"malformed export declaration"
"malformed export declaration"
"malformed export declaration"))
(add-sym-micro unit-register-exports-vocab
(lambda (expr env attributes vocab)
@ -356,16 +374,18 @@
(valid-syntactic-id? external)
(register-export internal attributes))))
(else
(static-error expr "Malformed export declaration"))))))
(static-error
"unit export" 'term:unit-export
expr "malformed declaration"))))))
;; ----------------------------------------------------------------------
(define unit-generate-external-names-vocab
(create-vocabulary 'unit-generate-external-names-vocab #f
"Invalid export declaration"
"Invalid export declaration"
"Invalid export declaration"
"Invalid export declaration"))
"malformed export declaration"
"malformed export declaration"
"malformed export declaration"
"malformed export declaration"))
(add-sym-micro unit-generate-external-names-vocab
(lambda (expr env attributes vocab)
@ -382,16 +402,18 @@
(lambda (p-env)
(pat:pexpand 'external-id p-env kwd)))
(else
(static-error expr "Malformed export declaration"))))))
(static-error
"unit export" 'term:unit-export
expr "malformed declaration"))))))
;; --------------------------------------------------------------------
(define unit-verify-exports-vocab
(create-vocabulary 'unit-verify-exports-vocab #f
"Invalid export declaration"
"Invalid export declaration"
"Invalid export declaration"
"Invalid export declaration"))
"malformed export declaration"
"malformed export declaration"
"malformed export declaration"
"malformed export declaration"))
(add-sym-micro unit-verify-exports-vocab
(lambda (expr env attributes vocab)
@ -417,7 +439,9 @@
(cons (process-unit-top-level-resolution internal attributes)
external)))))
(else
(static-error expr "Malformed export declaration"))))))
(static-error
"unit export" 'term:unit-export
expr "malformed declaration"))))))
; ----------------------------------------------------------------------
@ -604,7 +628,9 @@
expr))))
(lambda () (put-attribute attributes 'top-levels old-top-level))))))
(else
(static-error expr "Malformed unit"))))))
(static-error
"unit" 'kwd:unit
expr "malformed expression"))))))
(add-primitivized-micro-form 'unit full-vocabulary unit-micro)
(add-primitivized-micro-form 'unit scheme-vocabulary unit-micro)
@ -613,18 +639,19 @@
(define c-unit-link-import-vocab
(create-vocabulary 'c-unit-link-import-vocab #f
"Invalid link import declaration"
"Invalid link import declaration"
"Invalid link import declaration"
"Invalid link import declaration"))
"malformed link import declaration"
"malformed link import declaration"
"malformed link import declaration"
"malformed link import declaration"))
(add-sym-micro c-unit-link-import-vocab
(lambda (expr env attributes vocab)
(if (check-import expr attributes)
(list (expand-expr expr env attributes
(get-c-unit-vocab-attribute attributes)))
(static-error expr "~a: Not an imported identifier"
(z:read-object expr)))))
(static-error
"compound-unit linkage" 'term:c-unit-not-import
expr "~a: not an imported identifier" (z:read-object expr)))))
(add-list-micro c-unit-link-import-vocab
(let* ((kwd '())
@ -641,18 +668,21 @@
(when (eq? (z:read-object tag)
(get-c-unit-current-link-tag-attribute
attributes))
(static-error expr "Self-import of tag ~a"
(z:read-object tag))))
(static-error
"compound-unit linkage" 'term:unit-link-self-import-tag
expr "self-import of tag ~a" (z:read-object tag))))
(map (lambda (id) (cons tag id)) ids))))
(else
(static-error expr "Invalid link syntax"))))))
(static-error
"compound-unit linkage" 'term:c-unit-linkage
expr "invalid syntax"))))))
(define c-unit-link-body-vocab
(create-vocabulary 'c-unit-link-body-vocab #f
"Invalid link body declaration"
"Invalid link body declaration"
"Invalid link body declaration"
"Invalid link body declaration"))
"malformed link body declaration"
"malformed link body declaration"
"malformed link body declaration"
"malformed link body declaration"))
(add-list-micro c-unit-link-body-vocab
(let* ((kwd '())
@ -675,14 +705,16 @@
c-unit-link-import-vocab))
imported-vars)))))
(else
(static-error expr "Invalid linkage body"))))))
(static-error
"compound-unit linkage" 'term:c-unit-linkage
expr "malformed body"))))))
(define c-unit-exports-vocab
(create-vocabulary 'c-unit-exports-vocab #f
"Invalid unit export declaration"
"Invalid unit export declaration"
"Invalid unit export declaration"
"Invalid unit export declaration"))
"malformed unit export declaration"
"malformed unit export declaration"
"malformed unit export declaration"
"malformed unit export declaration"))
(add-sym-micro c-unit-exports-vocab
(lambda (expr env attributes vocab)
@ -703,14 +735,16 @@
(valid-syntactic-id? external-id)
(cons internal-id external-id))))
(else
(static-error expr "Invalid export clause"))))))
(static-error
"compound-unit" 'term:c-unit-export
expr "malformed export clause"))))))
(define c-unit-export-clause-vocab
(create-vocabulary 'c-unit-export-clause-vocab #f
"Invalid export clause declaration"
"Invalid export clause declaration"
"Invalid export clause declaration"
"Invalid export clause declaration"))
"malformed export clause declaration"
"malformed export clause declaration"
"malformed export clause declaration"
"malformed export clause declaration"))
(add-list-micro c-unit-export-clause-vocab
(let* ((kwd '())
@ -730,9 +764,13 @@
(expand-expr e env attributes
c-unit-exports-vocab)))
exports)
(static-error tag "Not a valid tag")))))
(static-error
"compound-unit" 'term:c-unit-invalid-tag
tag "not a valid tag")))))
(else
(static-error expr "Invalid export clause"))))))
(static-error
"compound-unit" 'term:c-unit-export
expr "malformed export clause"))))))
(define compound-unit-micro
(let* ((kwd `(import link export))
@ -792,10 +830,16 @@
(if (z:symbol? arg)
(when (not (memq (z:read-object arg)
raw-link-clauses))
(static-error arg
"Not a valid tag"))
(static-error arg
"Tag must be a symbol"))))
(static-error
"compound-unit"
'term:c-unit-invalid-tag
arg
"not a valid tag"))
(static-error
"compound-unit"
'term:c-unit-invalid-tag
arg
"tag must be a symbol"))))
(loop (cdr args)))))))))
in:link-tags in:link-bodies))
(proc:export-clauses
@ -814,7 +858,9 @@
proc:export-clauses
expr)))))
(else
(static-error expr "Malformed compound-unit"))))))
(static-error
"compound-unit" 'kwd:compound-unit
expr "malformed expression"))))))
(add-primitivized-micro-form 'compound-unit full-vocabulary compound-unit-micro)
(add-primitivized-micro-form 'compound-unit scheme-vocabulary compound-unit-micro)
@ -848,7 +894,9 @@
var-exprs
expr)))))
(else
(static-error expr "Malformed invoke-unit"))))))
(static-error
"invoke-unit" 'kwd:invoke-unit
expr "malformed expression"))))))
(add-primitivized-micro-form 'invoke-unit full-vocabulary invoke-unit-micro)
(add-primitivized-micro-form 'invoke-unit scheme-vocabulary invoke-unit-micro)
@ -905,8 +953,10 @@
(lambda (handler)
(lambda (expr env attributes vocab)
(unless (at-top-level? attributes)
(static-error expr
"Invalid definition: must be at the top level"))
(static-error
"definition" 'term:def-not-at-top-level
expr
"must be at the top level"))
(cond
((pat:match-against m&e-1 expr env)
=>
@ -924,8 +974,11 @@
(when (or (micro-resolution? r)
(macro-resolution? r))
(unless (check-export var attributes)
(static-error var
"Cannot bind keyword ~s"
(static-error
"keyword"
'term:cannot-bind-kwd
var
"cannot bind keyword ~s"
(z:symbol-orig-name var))))))
vars))
(out (handler expr env attributes
@ -933,7 +986,9 @@
(set-top-level-status attributes
top-level?)
out)))
(else (static-error expr "Malformed define-values")))))))
(else (static-error
"define-values" 'kwd:define-values
expr "malformed definition")))))))
(add-primitivized-micro-form 'define-values unit-clauses-vocab-delta
(define-values-helper
@ -952,10 +1007,10 @@
(define define-values-id-parse-vocab
(create-vocabulary 'define-values-id-parse-vocab #f
"Invalid in identifier position"
"Invalid in identifier position"
"Invalid in identifier position"
"Invalid in identifier position"))
"malformed in identifier position"
"malformed in identifier position"
"malformed in identifier position"
"malformed in identifier position"))
(add-sym-micro define-values-id-parse-vocab
(let ((top-level-resolution (make-top-level-resolution 'dummy #f)))
@ -997,10 +1052,14 @@
(pat:pexpand 'val p-env kwd)
env attributes vocab)))
(when (check-import var-p attributes)
(static-error var-p "Mutating imported identifier"))
(static-error
"set!" 'term:no-set!-imported
var-p "cannot mutate imported identifier"))
(set-top-level-status attributes top-level?)
(create-set!-form id-expr expr-expr expr))
(static-error expr "Malformed set!"))))))
(static-error
"set!" 'kwd:set!
expr "malformed expression"))))))
(define process-unit-top-level-resolution
(lambda (expr attributes)
@ -1016,19 +1075,22 @@
(lambda (expr env attributes vocab)
(let loop ((r (resolve expr env vocab)))
(cond
((or (macro-resolution? r) (micro-resolution? r))
(if (check-export expr attributes)
((or (macro-resolution? r) (micro-resolution? r))
(if (check-export expr attributes)
(loop top-level-resolution)
(static-error expr
"Invalid use of keyword ~a" (z:symbol-orig-name expr))))
((lexical-binding? r)
(create-lexical-varref r expr))
((top-level-resolution? r)
(check-for-signature-name expr attributes)
(process-unit-top-level-resolution expr attributes))
(else
(internal-error expr "Invalid resolution in unit delta: ~s"
r)))))))
(static-error
"keyword" 'term:keyword-out-of-context expr
"invalid use of keyword ~s" (z:symbol-orig-name expr))))
((lambda-binding? r)
(create-lambda-varref r expr))
((lexical-binding? r)
(create-lexical-varref r expr))
((top-level-resolution? r)
(check-for-signature-name expr attributes)
(process-unit-top-level-resolution expr attributes))
(else
(internal-error expr "Invalid resolution in unit delta: ~s"
r)))))))
; --------------------------------------------------------------------
@ -1037,7 +1099,7 @@
; --------------------------------------------------------------------
(define reference-unit-maker
(lambda (form-name sig?)
(lambda (form-name form-name-str kwd:form-name sig?)
(let ([micro
(let* ((kwd '())
(in-pattern `(_ filename))
@ -1072,18 +1134,22 @@
#f
(z:make-origin 'micro expr))
env attributes vocab)
(static-error filename
"Does not yield a filename"))))))
(static-error
form-name-str kwd:form-name
filename "does not yield a filename"))))))
(else
(static-error expr "Malformed ~a" form-name)))))])
(static-error
form-name-str kwd:form-name
expr "malformed expression")))))])
(add-primitivized-micro-form form-name full-vocabulary micro)
(add-on-demand-form 'micro form-name common-vocabulary micro))))
(reference-unit-maker 'require-unit #f)
(reference-unit-maker 'require-unit/sig #t)
(reference-unit-maker 'require-unit "require-unit" 'kwd:require-unit #f)
(reference-unit-maker 'require-unit/sig
"require-unit/sig" 'kwd:require-unit/sig #t)
(define reference-library-unit-maker
(lambda (form-name sig? relative?)
(lambda (form-name form-name-str kwd:form-name sig? relative?)
(let ([micro
(let* ((kwd '())
(in-pattern '(_ filename collections ...))
@ -1102,13 +1168,16 @@
collections)))
(unless (and (quote-form? f)
(z:string? (quote-form-expr f)))
(static-error filename "Does not yield a filename"))
(static-error
form-name-str kwd:form-name
filename "does not yield a filename"))
(for-each
(lambda (c collection)
(unless (and (quote-form? c)
(z:string? (quote-form-expr c)))
(static-error collection
"Does not yield a string")))
(static-error
form-name-str kwd:form-name
collection "does not yield a string")))
cs collections)
(let ((raw-f (z:read-object (quote-form-expr f)))
(raw-cs (map (lambda (c)
@ -1116,9 +1185,11 @@
(quote-form-expr c)))
cs)))
(unless (relative-path? raw-f)
(static-error f
"Library path ~s must be a relative path"
raw-f))
(static-error
form-name-str kwd:form-name
f
"library path ~s must be a relative path"
raw-f))
(expand-expr
(structurize-syntax
`(let ((result (,(if relative?
@ -1145,15 +1216,21 @@
(z:make-origin 'micro expr))
env attributes vocab))))))
(else
(static-error expr
(string-append "Malformed ~a" form-name))))))])
(static-error
form-name-str kwd:form-name
expr "malformed expression")))))])
(add-primitivized-micro-form form-name full-vocabulary micro)
(add-on-demand-form 'micro form-name common-vocabulary micro))))
(reference-library-unit-maker 'require-library-unit #f #f)
(reference-library-unit-maker 'require-library-unit/sig #t #f)
(reference-library-unit-maker 'require-relative-library-unit #f #t)
(reference-library-unit-maker 'require-relative-library-unit/sig #t #t)
(reference-library-unit-maker 'require-library-unit
"require-library-unit" 'kwd:require-library-unit #f #f)
(reference-library-unit-maker 'require-library-unit/sig
"require-library-unit/sig" 'kwd:require-library-unit/sig #t #f)
(reference-library-unit-maker 'require-relative-library-unit
"require-relative-library-unit" 'kwd:require-relative-library-unit #f #t)
(reference-library-unit-maker 'require-relative-library-unit/sig
"require-relative-library-unit/sig"
'kwd:require-relative-library-unit/sig #t #t)
(define (reset-unit-attributes attr)
(put-attribute attr 'c-unit-link-import/body-vocab null)

39
collects/zodiac/x.ss
View File

@ -1,4 +1,4 @@
; $Id: x.ss,v 1.52 1999/05/31 11:19:39 mflatt Exp $
; $Id: x.ss,v 1.53 1999/07/09 18:44:34 mflatt Exp $
(unit/sig zodiac:expander^
(import
@ -34,16 +34,16 @@
(opt-lambda (name (root #f)
(symbol-error (if root
(vocabulary-record-symbol-error root)
"Symbol invalid in this position"))
"symbol invalid in this position"))
(literal-error (if root
(vocabulary-record-literal-error root)
"Literal invalid in this position"))
"literal invalid in this position"))
(list-error (if root
(vocabulary-record-list-error root)
"List invalid in this position"))
"list invalid in this position"))
(ilist-error (if root
(vocabulary-record-ilist-error root)
"Improper-list syntax invalid in this position")))
"improper-list syntax invalid in this position")))
(let ((h (make-hash-table)))
(self-subexpr-vocab
(make-vocabulary-record
@ -159,6 +159,7 @@
; (pretty-print (sexp->raw expr)) (newline)
; (printf "top-level-status: ~s~n" (get-top-level-status attributes))
; (printf "Expanding~n") (pretty-print expr) (newline)
; (printf "Expanding~n") (pretty-print (sexp->raw expr)) (newline)
; (printf "Expanding~n") (display expr) (newline) (newline)
; (printf "in ~s~n" (get-vocabulary-name vocab))
; (printf "in vocabulary~n") (print-env vocab)
@ -175,7 +176,9 @@
(sym-expander
(internal-error expr "Invalid sym expander ~s" sym-expander))
(else
(static-error expr
(static-error
"symbol syntax" 'term:invalid-pos-symbol
expr
(vocabulary-record-symbol-error vocab))))))
((or (z:scalar? expr) ; "literals" = scalars - symbols
(z:vector? expr))
@ -188,7 +191,9 @@
(internal-error expr
"Invalid lit expander ~s" lit-expander))
(else
(static-error expr
(static-error
"literal syntax" 'term:invalid-pos-literal
expr
(vocabulary-record-literal-error vocab))))))
((z:list? expr)
(let ((invoke-list-expander
@ -202,7 +207,9 @@
(internal-error expr
"Invalid list expander ~s" list-expander))
(else
(static-error expr
(static-error
"list syntax" 'term:invalid-pos-list
expr
(vocabulary-record-list-error vocab)))))))
(contents (expose-list expr)))
(if (null? contents)
@ -214,7 +221,10 @@
((macro-resolution? r)
(with-handlers ((exn:user?
(lambda (exn)
(static-error expr
(static-error
"macro error"
'term:macro-error
expr
(exn-message exn)))))
(let* ((rewriter (macro-resolution-rewriter r))
(m (new-mark))
@ -223,10 +233,9 @@
rewritten expr (list m)
#f
(make-origin 'macro
expr)))
(expanded (expand-expr structurized env
attributes vocab)))
expanded)))
expr))))
(expand-expr structurized env
attributes vocab))))
((micro-resolution? r)
((micro-resolution-rewriter r)
expr env attributes (vocabulary-record-subexpr-vocab vocab)))
@ -243,7 +252,9 @@
(internal-error expr
"Invalid ilist expander ~s" ilist-expander))
(else
(static-error expr
(static-error
"improper list syntax" 'term:invalid-pos-ilist
expr
(vocabulary-record-ilist-error vocab))))))
(else
(internal-error expr

71
notes/drscheme/HISTORY
View File

@ -1,5 +1,76 @@
Version 102:
102d10:
102d10.
PRS:
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
1428: setup -c deletes files for all platforms
1424: long (list ...) displays don't display correctly
1405: memory usage box should be read only
1398: Downloading doc files requires restart
1377: replacing by empty string loops
1330: killing repl, then check-syntax hangs
1144: match docs not setup right in Help Desk
737: mred:preferences library too global
599: mac: can't double click to open files while mred starts up
406: bad error message for sixlib op
FUNCTIONALITY CHANGES
- the framework now imports a definition of the preferences
file location. Use this to have a separate preferences file
for each different application.
- do not use 'drscheme:settings anymore to get the current
language settings from drscheme. Now, use
drscheme:language:settings-preferences-symbol
(which is bound to the right symbol) instead.
- setup plt's ``clean'' info.ss flag does not recur
into subdirectories anymore.
MINOR CHANGES AND BUG FIXES
- Added Replace and Find again to edit menu
- changed `h' shortcut to find and replace again. show keybindings
has no shortcut anymore.
* Moved the filename and (define ...) popups to the left, swapping with
the Save button. (The popups in the middle of space look strange.)
* Merged the Project menu with the File menu.
* Changed the "Configure Language" menu item in the project window to
"Choose Language", to match the menu item in the file window.
* Add "..." to "Open Project" menu item.
* Got rid of "Insert Lambda". It's not nearly useful enough to be
worth all the bugs it creates. (Try inserting a lambda by itself and
hit return --- nothing happens. Try (<lambda>) --- bad selection for
the error message.)
* Give windows for untitled files/projects unique names: "Untitled 1",
"Untitled 2", etc.
* Fix multiple adjacent separators in the project window's File and
Edit menus.
* Dropped the old "platform independent" file dialogs, and use
get-file-list for projects.
* Disabled "Keybindings" menu item when not applicable.
102d9:
NEW DIRECTORY: plt/collects/defaults

175
notes/mred/HISTORY
View File

@ -1,176 +1,3 @@
Version 102/13:
* Fixed MrEd2k bugs.
Version 102/12:
* X: Fixed list-box scrolling. (PR 1435)
* Windows/MacOS: Made stdio window accept input for the initial input
port (for `read', etc.).
* Windows: Fixed many MDI problems.
* Added an optional string-offset argument to dc<%>'s get-text-extent
and draw-text.
* Changed code for MrEd2k so that it does not rely on interior
pointers.
Version 102/11:
* Added `get-file-list', which gives the user a dialog for selecting
multiple existing files (using the platform-specific dialog, where
possible).
* Added `on-superwindow-show' and `on-superwindow-enable' to
window<%>.
* Added `on-message' to top-level-window<%>, and added the procedure
`send-message-to-window', which calls the `on-message' method of a
top-level window at a particular screen location.
* Fixed `draw-bitmap' in post-script-dc%.
* Fixed post-script-dc% to use PS `curveto' command for splines.
* Fixed text editor printing to break up lines that are longer than
a page on scroll boundaries. (This is particularly relevant
for printing editors containing embedded editors.)
* X: Fixed choice item bug when the user pops up the choice and doesn't
select anything. (PR 1426)
Version 102/10:
* X: Changed dialogs to use the icon of the dialog's parent (if any).
Version 102/9:
* X: Fixed list-box% to handle arbitrarily many list items. (PR 1342)
* Added pop-down callback initialization argument to popup-menu%, and
added the 'menu-popdown and 'menu-popdown-none event types to
control-event%. The callback is invoked with a 'menu-popdown event
after the callback for a selected item in a popup menu. If the menu
is dismissed with no item is selected, the callback is incoked with
a 'menu-popdown-none event.
* Added `on-demand' to menu-item-container<%> and
labelled-menu-item<%> for building menu content on demand. The
`on-demand' method of a menu bar is called when the user clicks on
the menu bar, before the click is handled by the menu bar. The
`on-demand' method of a popup menu is called before the menu is
popped up. The default implementation of `on-demand' in a menu item
container calls the `on-demand' method of all of its labelled menu
items (which includes submenus).
* Windows: fixed `get-font-from-user' when a parent frame is provided.
(PR 1371)
Version 102/8:
* Changed pen% width from integer to real number (still between
0 and 255). Non-integral widths are used for post-script-dc%
drawing.
Version 102/7:
* Added `{get,set}-align-top-line' methods to editor-snip%.
* Added `get-top-line-base' method to text%.
* Fixed button disabling so that it pops the button back up if the
user is in the middle of a click (PR 1333). Also fixed event
dispatching in the case that `on-subwindow-{event,char}' disables
the target (in which case the event shouldn't be dispatched).
Version 102/6:
* Fixed pasting and file-loading with objects that use a style other
than the default one.
Version 102/5:
[No notable changes]
Version 102/4:
* Fixed page scrolling in editors, I think. (Rewrote it, actually.)
Please report any scrolling behavior that doesn't seem right. (PR
1174 et al.)
* Fixed copying for editor-snip%s, incorporating and extending
Robby's fixes. (PRs 1304 and 1305)
* Hijacked `on-change' method of editor<%>, which wasn't doing anything
useful, to serve a new purpose.
The new `on-change' is called whenever any change occurs to an
editor that affects the way it is drawn or the values reported for
the location/size of any snip. The `on-change' method is called
just before the editor calls its administrator's `needs-update'
method to refresh the editor's display. The editor is locked for
writing and reflowing during the call to `on-change'.
(Enables a fix for PR 1171)
* Added an initializer to string-snip% that accepts a string.
* Added `call-clickback' method to text%.
* Editor reading/writing/cuting/pasting used to rely on global
state. Consequently, only one editor could be read/written/etc. at
a time, and exceptions raised during the read/write/etc. (e.g., by
a mischevious snip object) could kill reading/writing/etc. for all
editors in the system. This is fixed; all state resides in the
stream, now. (PR 1201 et al.)
* Removed `read-done' and `write-done' from snip-class%.
* Moved `reading-version' from snip-class-list% to snip-class%.
* Fixed `get-file' and `put-file' interpretation of directory
argument: filename is internally normalized (changing '/' to `\',
etc.). (PR 1238)
* X: Fixed input of keypad characters and dead characters, such as
accent marks. (comp.lang.scheme and PR 1263)
Version 102/3:
* MrEd2k works.
Version 102/2:
* Changed the interaction of face and familiy settings in a font for
drawing text. Only one [little-used] method changed its interface
(`get-font-id' in font-name-directory<%>), but the meaning of the
`family' settings in font% and style-delta% objects
changed. Essentially, the family is orthogonal to the face setting,
and it's used whenever an appopriate font can't be found for the
face name.
the main consquence of the change is that PS printing can be fixed
DrScheme. The style Scheme text just needs to have the 'modern
family in addition to the user-selected face string.
* Removed `get-afm-name' and `set-afm-name' from
font-name-directory<%>, and changed post-script-dc% to use the
PostScript font name as the AFM file name (prefixed with the AFM
directory and suffixed with ".afm").
* Fixed PRs 1286 and 1287 (list-box% problems).
Version 102/1:
* Fixed some PS problems (roundoff error with regions), and made
`get-text-extent' return a useful value for the vertical space above
a font.
----------------------------------------------------------------------
Version 102: ??, 2000
Changed the interaction of face and familiy settings in a font for
@ -178,6 +5,8 @@ Changed the interaction of face and familiy settings in a font for
Removed get-afm-name and set-afm-name from font-name-directory<%>,
and changed post-script-dc% to use the PostScript font name as the
AFM file name
Added get-margin and set-margin to ps-setup%; post-script-dc% uses
the margins to shrink its paper size and offset its output
Changed pen%'s width from integer to real number (used for PS)
Added on-superwindow-show and on-superwindow-enable to window<%>
Added get-file-list procedure

320
notes/mzscheme/HISTORY
View File

@ -1,323 +1,3 @@
Version 102/13:
* Added `provide-library', which lets the programmer install a
library-loading procedure for an arbitrary library (if it is not
already loaded).
* Changed `find-executable-path' to accept #f as its second argument,
and fixed the documentation.
* Unix: Fixed 'truncate/replace flag to `open-output-file' et al.
(Bug introduced in 102/10.)
* Windows: `normal-case-path' removes trailing spaces from a filename
(because the Windows API does).
* Windows: MzScheme recognizes special filenames like "LPT1" as
"files" that might block on I/O (except "NUL", which never
blocks). The `file-exists?' primitive reports #t for all of these
"files", which can be prefixed with any path - even a non-existent
one - and/or postfixed with any file extension or with a single
colon!!!
* Inside MzScheme: scheme_basic_env(), if called more than once,
resets all threads, parameters, ports, namespaces, and
finalizations. (Useful to MzCOM.)
* Code maintenance: split some source files, adding builtin.c,
network.c, numarith.c, numcomp.c, numstr.c, objclass.c, portfun.c,
and unitsig.c.
Version 102/12:
* Fixed return vaue of `random-seed' (bug introduced in 102/9 or
so). (PR 1434)
* Fixed handling of file output ports on exit: file is flushed and
closed. (Bug introduced in 102/10.)
* Changed code for MzScheme2k so that it does not rely on interior
pointers.
Version 102/11:
* Added `interface->ivar-names', which takes an interface and returns
a list of symbols for the interface's ivar names.
* Added 'update to the set of flags for `open-output-file' et al.
'update mode opens an existing file without truncating it, and
allows overwriting of the file's existing data, especially in
combination with `file-position'.
* Fixed a bug in interface checking. In an `interface' expression, an
ivar declaration for some name was allowed when a superinterface
already contained the ivar name through a derivation
requirement. It now raises an exception.
* Added -k <n> <m> flag to MzScheme, which loads code embedded in the
executable from file position <n> to <m>. This flag will be useful
for creating stand-alone executables by appending code to the
normal MzScheme/MrEd executable. Details in a forthcoming mzc
update. (This is something of a hack, but I think it will be
useful.)
* Fixed `arithmetic-shift' for a -32 shift argument. (PR 1421)
* Inside MzScheme:
- Not all import ports keep line counts anymore (it's wasteful for
programs using block I/O on binary data, and it's mostly useful
only with `load'). -1 returned from scheme_tell_line() indicates
that line counts are not ketp. scheme_count_lines() enables
line-counting for an input port. Note that there's no MzScheme
primitive that provides line information.
Version 102/10:
* Switched to `configure'-based Makefiles (autoconf). See
plt/src/README, and use plt/src/configure.
* Added `process[*]/ports', which is like `process[*]', but it takes
three file-stream ports to use for the subprocess's stdio streams:
an input port for the process's stdin, and output ports for the
process's stdout and stderr.
If #f is provided for one of the streams, then `process[*]/ports'
makes a pipe and return the other end for the corresponding stream,
as for `process[*]'. But when a port is provided for a particular
stream, `process[*]/ports' does not create the corresponding pipe,
and instead use the given port, returning #f for that stream.
If a provided port is not a file-stream port (created by
`open-input-file' or `process[*][/file-ports]', or one of the
original stdio ports), then an exception would be raised.
* Added `file-stream-port?', useful with `process[*]/ports' and
`file-position' (which requires a file-stream port for changing the
position).
* Changed `read-string!' to `read-string-avail!', which reads only as
many characters as are immediately ready, blocking only if no chars
are available. (The old `read-string!' can be efficiently
implemented with the new one.)
In the current `read-string!' (and `read-string'), characters can
be lost if the read gets a few and then encounters a read
error. The `read-string-avail!' procedure does not have this
problem, because an error after reading at least one character is
treated like blocking. (The error will be ignored, to be triggered
on the next read.)
* Added `read-string-avail!/enable-break', to be used in a context
where breaks are disabled. The guarantee is that either the read
gets all the characters it can and returns, or it raises an
exception (possibly a break exception) without reading any
characters.
* Added `write-string-avail' and `write-string-avail/enable-break',
which are analogous to `read-string-avail!' and
`read-string-avail!/enable-break'.
The return value in the non-exception case is the number of chars
that could be written (and flushed) immediately. If no characters
can be written, it blocks until at least one can be.
As with `read-string-avail!', an error after writing at least one
character is treated like blocking. (Output mechanisms like `write'
and `display' can still fumble characters.)
The `write-string-avail' procedure works on all output port types,
but it is not especially effective for FILE*-based ports (like most
ports in Windows and MacOS); to guarantee succesful flushing, only
one character can be writte. The procedure is especially effective
for TCP and fd-based ports (like most ports in Unix, now).
* Unix: changed MzScheme's `open-input-file' and `open-output-file'
(etc.) to use fd-based ports instead of FILE*-based ports. This
change gives MzScheme finer control over input and output; it makes
sense now that fd-based ports have been tested for a few months.
* Fixed regexp to work with `-' as the last character in a `[...]'
pattern. (The bug was introduced in 102/8.) (PR 1381)
* Fixed a bug in `open-output-file' that could cause a file-exists
failure even when the 'truncate or 'replace flag is spcified. (PR
1309)
* Fixed the error-handling subsystem to properly handle error
messages containing a non-terminating nul character (e.g., due to
including in an error message a string argument that contained a
nul).
* Inside MzScheme:
- Added scheme_register_static(), which is like
scheme_register_extension_global(), but it only registers the
given location if the collector does not know how to find static
variables anyway. (This is true for precise GC, Senora GC on
many platforms, and the regular GC under Windows when a flag is
set as described below).
- Provided a way to fix the GC--thread problems under Windows. If
an embedding application is willing to explicitly register its
static variables with scheme_register_static(), then set the
GC_use_registered_statics variable to 1 before calling a
MzScheme or GC function. Then, then collector will not try to
scan all active pages to find globals (which can crash if a
separate Windows thread unmaps a page while the collector is
running), and instead only collect from the registered static
variable locations.
The standalone versions of MzScheme and MrEd for Windows both
use this new GC mechanism.
- Changed scheme_get_chars to include a new last argument: an
offset into the string.
- Added embedding-settable function scheme_console_output, which
is used to report errors that were not handled correctly by the
normal mechanisms.
- Restricted the format string accepted by scheme_signal_error,
scheme_raise_exn, and scheme_warning, but also added format
directives to handle non-terminating nul characters in strings.
* Added `mergesort' to MzLib's function.ss.
Version 102/9:
* Added immutable strings and pairs, with `string->immutable-string'
and `pair->immutable-pair'. A string generated by `read' is now
immutable, but pairs from `read' are still mutable.
The strings and lists available from parameters like
`current-directory' and `current-library-collection-paths' are now
immutable, which motivated the change. Otherwise, a thread might
change the current directory of a different thread by mutating the
string returned by `current-directory'. Similar problems could
occur via mutations to strings returned by GUI objects in MrEd.
* Changed `time-apply' to return four values --- including the gc
time --- and changed its arguments to be like `apply', where the
new second argument to `time-apply' is a list of arguments to
supply to the function that is the first argument to
`time-apply'. (The generalization that allows a number of non-list
argument followed by a list is not supported by `time-apply'.)
The `time' syntactic form is unchanged (but its expansion is
different).
* Added 'exec-file flag to `find-system-path', which returns the path
of the current executable as started by the OS. (The same path is
initially bound to `program' in MzScheme and MrEd.)
* Fixed .zo writing to use indices for built-in primitives (as in
53), instead of names (as, due to a bug, in 101). This fix shrinks
the size of a .zo file by 20% on average.
* Fixed missing `volatile' annotations, which were needed to make
MzScheme work with gcc 2.95.2 on Sparc.
Version 102/8:
* (angle 0.0) is 0, and (angle -0.0) is pi. This is consistent with
the distinction between 0.0+0i and 0.0+0.0i, and with the notion of
0.0 as "infinitesimally small". Also, fixed (angle +nan.0).
* (expt 0 x) raises divide-by-zero if x is negative (instead of
returning 0), and returns +nan.0 if x is +nan.0.
* Fixed `regexp' and friends to work on strings (patterns and
targets) that contain null characters. (PR 1350)
* Added `tcp-addresses', which takes a TCP port and returns two
strings: the connection's local address and the connection's peer's
address.
Version 102/7:
* Fixed interaction of `peek-char' and `file-position' (PR 1318).
* Fixed `close-output-port' so that it flushes stream ports (stdout,
stderr, and process ports).
* Fixed `custodian-shutdown-all' to force-close a blocking output
stream (unflushed data is lost).
* Replaced 'generic-failure as a `detail' in `exn:i/o:filesystem'
with #f. Could change to a list later, if there is still strong
interest.
Version 102/6:
[No changes]
Version 102/5:
* `with-input-from-file' and `with-output-to-file' close the port
when control leaves the dynamic extent of the call (either
normally, through an exception, or through a general continuation
jump).
* Added a `detail' field to `exn:i/o:filesystem'. This is a
compromise between the version 53 exn system, which was too
detailed, and the version 101 system, which doesn't provide enough
information (e.g., to implement `make-temporary-file').
The value of the `detail' field is currently either
'ill-formed-path, 'already-exists, 'wrong-version, or
'generic-failure. This set may be expanded in the future, such that
some generic failures turn into specific failures.
* Changed output to stdout, stderr, and process ports to use
non-blocking mode while actively writing only. This avoids clashes
among Unix programs that use the same output device, because
setting a descriptor to non-blocking sometimes means making the
entire asscoaited device non-blocking (for all programs, for both
input and output!).
* Added `square' to functio.ss.
Version 102/4:
* Fixed number reader to allow +inf.0, -inf.0, and +nan.0 in complex
constants. For example, +inf.0-inf.0i is now a legal constant. To
some degree, this fix was necessary to ensure that all printable
numbers are readable, and has been on my queue for a long time.
* To simplify (in a way) MzScheme's number syntax, fixed bugs in
number reader for hexadecimal numbers containing `.' and/or
`s'/`l'-based exponents. Prompted by PR 823.
This change supports some interesting number representations, to
say the least. One of my favorites is `#e#x+e.s+e@-e.l-e'.
* Found and fixed some subtle bugs in detecting exact-zero cases
(such as 0@7.0) and in reporting divide-by-zero cases (such as
1/0@0).
Version 102/3:
* Precise GC fixes
Version 102/2:
* Fixed `kill-thread' on a thread that hasn't performed any work,
yet.
* Fixed scheme_make_integer_value() on the boundary case (2^31).
* MzScheme2k: fixed numerous bugs.
Version 102/1:
* Added `read-decimal-as-inexact' parameter, which controls how
numbers containg a decimal or exponent are interpreted by `read' and
`string->number' when an explicit exactness tag is not present. The
default is #t, which means parse as inexact (normal behavior). #f
means parse as exact.
Version 102, ??, 2000
Switched to configure-based makefiles (autoconf)
with-input-from-file and with-output-to-file close the port when

20
notes/stepper/DESIGN-NOTES
View File

@ -482,5 +482,25 @@ Okay, time to do units. Compound units are dead easy. Just wrap them in a wcm
(define c c)
...)
************
Well, I still haven't written the code to annotate units, so it's a damn good thing
I wrote down the transformation. I'm here today (thank you very much) to talk about
annotation schemes.
I just (okay, a month ago --- it's now 2000-05-23) folded aries into the stepper. the
upshot of this is that aries now supports two different annotation modes: "cheap-wrap,"
which is what aries used to do, and the regular annotation, used for the algebraic
stepper.
However, I'm beginning to see a need for a third annotation, to be used for (non-
algebraic) debugging. In particular, much of the bulk involved in annotating the
program source is due to the strict algebraic nature of the stepper. For instance,
I'm now annotating lets. The actual step taken by the let is after the evaluation
of all bindings. So we need a break there. However, the body expression is
_also_ going to have a mark and a break around it, for the "result-break" of the
let. I thought I could leave out the outer break, but it doesn't work. Actually,
maybe I could leave out the inner one. Gee whiz. This stuff is really complicated.

145
src/configure vendored
View File

@ -1039,11 +1039,14 @@ fi
if test "$AS" = '' ; then
AS=as
as_was_set=no
else
as_was_set=yes
fi
# Extract the first word of "ranlib", so it can be a program name with args.
set dummy ranlib; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:1047: checking for $ac_word" >&5
echo "configure:1050: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_prog_RANLIB'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@ -1084,7 +1087,7 @@ fi
# Extract the first word of "perl", so it can be a program name with args.
set dummy perl; ac_word=$2
echo $ac_n "checking for $ac_word""... $ac_c" 1>&6
echo "configure:1088: checking for $ac_word" >&5
echo "configure:1091: checking for $ac_word" >&5
if eval "test \"`echo '$''{'ac_cv_path_PERL'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
@ -1119,7 +1122,7 @@ if test "${enable_mred}" = "yes" ; then
# Uses ac_ vars as temps to allow command line to override cache and checks.
# --without-x overrides everything else, but does not touch the cache.
echo $ac_n "checking for X""... $ac_c" 1>&6
echo "configure:1123: checking for X" >&5
echo "configure:1126: checking for X" >&5
# Check whether --with-x or --without-x was given.
if test "${with_x+set}" = set; then
@ -1181,12 +1184,12 @@ if test "$ac_x_includes" = NO; then
# First, try using that file with no special directory specified.
cat > conftest.$ac_ext <<EOF
#line 1185 "configure"
#line 1188 "configure"
#include "confdefs.h"
#include <$x_direct_test_include>
EOF
ac_try="$ac_cpp conftest.$ac_ext >/dev/null 2>conftest.out"
{ (eval echo configure:1190: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
{ (eval echo configure:1193: \"$ac_try\") 1>&5; (eval $ac_try) 2>&5; }
ac_err=`grep -v '^ *+' conftest.out`
if test -z "$ac_err"; then
rm -rf conftest*
@ -1255,14 +1258,14 @@ if test "$ac_x_libraries" = NO; then
ac_save_LIBS="$LIBS"
LIBS="-l$x_direct_test_library $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1259 "configure"
#line 1262 "configure"
#include "confdefs.h"
int main() {
${x_direct_test_function}()
; return 0; }
EOF
if { (eval echo configure:1266: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1269: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
LIBS="$ac_save_LIBS"
# We can link X programs with no special library path.
@ -1368,17 +1371,17 @@ else
case "`(uname -sr) 2>/dev/null`" in
"SunOS 5"*)
echo $ac_n "checking whether -R must be followed by a space""... $ac_c" 1>&6
echo "configure:1372: checking whether -R must be followed by a space" >&5
echo "configure:1375: checking whether -R must be followed by a space" >&5
ac_xsave_LIBS="$LIBS"; LIBS="$LIBS -R$x_libraries"
cat > conftest.$ac_ext <<EOF
#line 1375 "configure"
#line 1378 "configure"
#include "confdefs.h"
int main() {
; return 0; }
EOF
if { (eval echo configure:1382: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1385: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
ac_R_nospace=yes
else
@ -1394,14 +1397,14 @@ rm -f conftest*
else
LIBS="$ac_xsave_LIBS -R $x_libraries"
cat > conftest.$ac_ext <<EOF
#line 1398 "configure"
#line 1401 "configure"
#include "confdefs.h"
int main() {
; return 0; }
EOF
if { (eval echo configure:1405: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1408: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
ac_R_space=yes
else
@ -1433,7 +1436,7 @@ rm -f conftest*
# libraries were built with DECnet support. And karl@cs.umb.edu says
# the Alpha needs dnet_stub (dnet does not exist).
echo $ac_n "checking for dnet_ntoa in -ldnet""... $ac_c" 1>&6
echo "configure:1437: checking for dnet_ntoa in -ldnet" >&5
echo "configure:1440: checking for dnet_ntoa in -ldnet" >&5
ac_lib_var=`echo dnet'_'dnet_ntoa | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@ -1441,7 +1444,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-ldnet $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1445 "configure"
#line 1448 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@ -1452,7 +1455,7 @@ int main() {
dnet_ntoa()
; return 0; }
EOF
if { (eval echo configure:1456: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1459: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@ -1474,7 +1477,7 @@ fi
if test $ac_cv_lib_dnet_dnet_ntoa = no; then
echo $ac_n "checking for dnet_ntoa in -ldnet_stub""... $ac_c" 1>&6
echo "configure:1478: checking for dnet_ntoa in -ldnet_stub" >&5
echo "configure:1481: checking for dnet_ntoa in -ldnet_stub" >&5
ac_lib_var=`echo dnet_stub'_'dnet_ntoa | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@ -1482,7 +1485,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-ldnet_stub $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1486 "configure"
#line 1489 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@ -1493,7 +1496,7 @@ int main() {
dnet_ntoa()
; return 0; }
EOF
if { (eval echo configure:1497: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1500: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@ -1522,12 +1525,12 @@ fi
# The nsl library prevents programs from opening the X display
# on Irix 5.2, according to dickey@clark.net.
echo $ac_n "checking for gethostbyname""... $ac_c" 1>&6
echo "configure:1526: checking for gethostbyname" >&5
echo "configure:1529: checking for gethostbyname" >&5
if eval "test \"`echo '$''{'ac_cv_func_gethostbyname'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1531 "configure"
#line 1534 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char gethostbyname(); below. */
@ -1550,7 +1553,7 @@ gethostbyname();
; return 0; }
EOF
if { (eval echo configure:1554: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1557: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_gethostbyname=yes"
else
@ -1571,7 +1574,7 @@ fi
if test $ac_cv_func_gethostbyname = no; then
echo $ac_n "checking for gethostbyname in -lnsl""... $ac_c" 1>&6
echo "configure:1575: checking for gethostbyname in -lnsl" >&5
echo "configure:1578: checking for gethostbyname in -lnsl" >&5
ac_lib_var=`echo nsl'_'gethostbyname | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@ -1579,7 +1582,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lnsl $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1583 "configure"
#line 1586 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@ -1590,7 +1593,7 @@ int main() {
gethostbyname()
; return 0; }
EOF
if { (eval echo configure:1594: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1597: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@ -1620,12 +1623,12 @@ fi
# -lsocket must be given before -lnsl if both are needed.
# We assume that if connect needs -lnsl, so does gethostbyname.
echo $ac_n "checking for connect""... $ac_c" 1>&6
echo "configure:1624: checking for connect" >&5
echo "configure:1627: checking for connect" >&5
if eval "test \"`echo '$''{'ac_cv_func_connect'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1629 "configure"
#line 1632 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char connect(); below. */
@ -1648,7 +1651,7 @@ connect();
; return 0; }
EOF
if { (eval echo configure:1652: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1655: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_connect=yes"
else
@ -1669,7 +1672,7 @@ fi
if test $ac_cv_func_connect = no; then
echo $ac_n "checking for connect in -lsocket""... $ac_c" 1>&6
echo "configure:1673: checking for connect in -lsocket" >&5
echo "configure:1676: checking for connect in -lsocket" >&5
ac_lib_var=`echo socket'_'connect | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@ -1677,7 +1680,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lsocket $X_EXTRA_LIBS $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1681 "configure"
#line 1684 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@ -1688,7 +1691,7 @@ int main() {
connect()
; return 0; }
EOF
if { (eval echo configure:1692: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1695: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@ -1712,12 +1715,12 @@ fi
# gomez@mi.uni-erlangen.de says -lposix is necessary on A/UX.
echo $ac_n "checking for remove""... $ac_c" 1>&6
echo "configure:1716: checking for remove" >&5
echo "configure:1719: checking for remove" >&5
if eval "test \"`echo '$''{'ac_cv_func_remove'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1721 "configure"
#line 1724 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char remove(); below. */
@ -1740,7 +1743,7 @@ remove();
; return 0; }
EOF
if { (eval echo configure:1744: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1747: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_remove=yes"
else
@ -1761,7 +1764,7 @@ fi
if test $ac_cv_func_remove = no; then
echo $ac_n "checking for remove in -lposix""... $ac_c" 1>&6
echo "configure:1765: checking for remove in -lposix" >&5
echo "configure:1768: checking for remove in -lposix" >&5
ac_lib_var=`echo posix'_'remove | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@ -1769,7 +1772,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lposix $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1773 "configure"
#line 1776 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@ -1780,7 +1783,7 @@ int main() {
remove()
; return 0; }
EOF
if { (eval echo configure:1784: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1787: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@ -1804,12 +1807,12 @@ fi
# BSDI BSD/OS 2.1 needs -lipc for XOpenDisplay.
echo $ac_n "checking for shmat""... $ac_c" 1>&6
echo "configure:1808: checking for shmat" >&5
echo "configure:1811: checking for shmat" >&5
if eval "test \"`echo '$''{'ac_cv_func_shmat'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
else
cat > conftest.$ac_ext <<EOF
#line 1813 "configure"
#line 1816 "configure"
#include "confdefs.h"
/* System header to define __stub macros and hopefully few prototypes,
which can conflict with char shmat(); below. */
@ -1832,7 +1835,7 @@ shmat();
; return 0; }
EOF
if { (eval echo configure:1836: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1839: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_func_shmat=yes"
else
@ -1853,7 +1856,7 @@ fi
if test $ac_cv_func_shmat = no; then
echo $ac_n "checking for shmat in -lipc""... $ac_c" 1>&6
echo "configure:1857: checking for shmat in -lipc" >&5
echo "configure:1860: checking for shmat in -lipc" >&5
ac_lib_var=`echo ipc'_'shmat | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@ -1861,7 +1864,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lipc $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1865 "configure"
#line 1868 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@ -1872,7 +1875,7 @@ int main() {
shmat()
; return 0; }
EOF
if { (eval echo configure:1876: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1879: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@ -1905,7 +1908,7 @@ fi
# libraries we check for below, so use a different variable.
# --interran@uluru.Stanford.EDU, kb@cs.umb.edu.
echo $ac_n "checking for IceConnectionNumber in -lICE""... $ac_c" 1>&6
echo "configure:1909: checking for IceConnectionNumber in -lICE" >&5
echo "configure:1912: checking for IceConnectionNumber in -lICE" >&5
ac_lib_var=`echo ICE'_'IceConnectionNumber | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@ -1913,7 +1916,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lICE $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1917 "configure"
#line 1920 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@ -1924,7 +1927,7 @@ int main() {
IceConnectionNumber()
; return 0; }
EOF
if { (eval echo configure:1928: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1931: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@ -1959,7 +1962,7 @@ else
fi
echo $ac_n "checking for cos in -lm""... $ac_c" 1>&6
echo "configure:1963: checking for cos in -lm" >&5
echo "configure:1966: checking for cos in -lm" >&5
ac_lib_var=`echo m'_'cos | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@ -1967,7 +1970,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-lm $LIBS"
cat > conftest.$ac_ext <<EOF
#line 1971 "configure"
#line 1974 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@ -1978,7 +1981,7 @@ int main() {
cos()
; return 0; }
EOF
if { (eval echo configure:1982: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:1985: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@ -2006,7 +2009,7 @@ else
fi
echo $ac_n "checking for dlopen in -ldl""... $ac_c" 1>&6
echo "configure:2010: checking for dlopen in -ldl" >&5
echo "configure:2013: checking for dlopen in -ldl" >&5
ac_lib_var=`echo dl'_'dlopen | sed 'y%./+-%__p_%'`
if eval "test \"`echo '$''{'ac_cv_lib_$ac_lib_var'+set}'`\" = set"; then
echo $ac_n "(cached) $ac_c" 1>&6
@ -2014,7 +2017,7 @@ else
ac_save_LIBS="$LIBS"
LIBS="-ldl $LIBS"
cat > conftest.$ac_ext <<EOF
#line 2018 "configure"
#line 2021 "configure"
#include "confdefs.h"
/* Override any gcc2 internal prototype to avoid an error. */
/* We use char because int might match the return type of a gcc2
@ -2025,7 +2028,7 @@ int main() {
dlopen()
; return 0; }
EOF
if { (eval echo configure:2029: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
if { (eval echo configure:2032: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest; then
rm -rf conftest*
eval "ac_cv_lib_$ac_lib_var=yes"
else
@ -2075,13 +2078,22 @@ fi
############## platform tests ################
if test -x "/bin/uname" ; then
UNAME=/bin/uname
elif test -x "/usr/bin/uname" ; then
UNAME=/usr/bin/uname
else
echo configure: cannot find uname
exit 1
fi
# for flags we don't want to use in config tests:
EXTRALIBS=
OS=`uname -s`
OS=`$UNAME -s`
case $OS in
SunOS)
case `uname -r` in
case `$UNAME -r` in
5.*)
if test "${enable_osthreads}" = "yes" ; then
OPTIONS="${OPTIONS} -DSOLARIS_THREADS"
@ -2147,7 +2159,19 @@ case $OS in
fi
;;
*)
echo "Warning: Unknown OS"
;;
esac
MACH=`$UNAME -m`
case "$MACH" in
alpha)
if test "$CC" = "gcc" ; then
if test "$as_was_set" = "no" ; then
AS="gcc -c -x assembler-with-cpp"
fi
fi
;;
*)
;;
esac
@ -2163,7 +2187,6 @@ if test "${enable_sgcdebug}" = "yes" ; then
OPTIONS="$OPTIONS -DSGC_STD_DEBUGGING=1"
fi
############## C++ grunge ################
MROPTIONS=
@ -2180,12 +2203,12 @@ cross_compiling=$ac_cv_prog_cxx_cross
msg="whether new and new[] are different"
echo $ac_n "checking $msg""... $ac_c" 1>&6
echo "configure:2184: checking $msg" >&5
echo "configure:2207: checking $msg" >&5
if test "$cross_compiling" = yes; then
{ echo "configure: error: can not run test program while cross compiling" 1>&2; exit 1; }
else
cat > conftest.$ac_ext <<EOF
#line 2189 "configure"
#line 2212 "configure"
#include "confdefs.h"
#ifdef __cplusplus
extern "C" void exit(int);
@ -2198,7 +2221,7 @@ extern "C" void exit(int);
return (new C) == (new C[10]);
}
EOF
if { (eval echo configure:2202: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null
if { (eval echo configure:2225: \"$ac_link\") 1>&5; (eval $ac_link) 2>&5; } && test -s conftest && (./conftest; exit) 2>/dev/null
then
different=yes
else
@ -2219,16 +2242,16 @@ fi
# then try adding -fpermissive
if test "$CC" = "gcc" ; then
echo $ac_n "checking whether need to use -fpermissive""... $ac_c" 1>&6
echo "configure:2223: checking whether need to use -fpermissive" >&5
echo "configure:2246: checking whether need to use -fpermissive" >&5
cat > conftest.$ac_ext <<EOF
#line 2225 "configure"
#line 2248 "configure"
#include "confdefs.h"
#include "X11/Intrinsic.h"
int main() {
; return 0; }
EOF
if { (eval echo configure:2232: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
if { (eval echo configure:2255: \"$ac_compile\") 1>&5; (eval $ac_compile) 2>&5; }; then
rm -rf conftest*
addperm=no
else

28
src/mred/mred.cxx
View File

@ -2313,6 +2313,34 @@ void *wxOutOfMemory()
{
MrEdOutOfMemory();
return NULL;
}
static void (*mr_save_oom)(void);
static jmp_buf oom_buf;
static void not_so_much_memory(void)
{
scheme_longjmp(oom_buf, 1);
}
void *wxMallocAtomicIfPossible(size_t s)
{
void *v;
if (s < 5000)
return scheme_malloc_atomic(s);
mr_save_oom = GC_out_of_memory;
if (!scheme_setjmp(oom_buf)) {
GC_out_of_memory = not_so_much_memory;
v = scheme_malloc_atomic(s);
} else {
v = NULL;
}
GC_out_of_memory = mr_save_oom;
return v;
}
static const char *CallSchemeExpand(const char *filename)

9
src/mred/wxme/wx_medio.cxx
View File

@ -393,8 +393,7 @@ wxMediaStreamIn *wxMediaStreamIn::GetFixed(long *v)
return this;
}
extern "C" void *scheme_malloc_fail_ok(void *(*f)(size_t), size_t);
extern "C" void *GC_malloc_atomic(size_t);
extern void *wxMallocAtomicIfPossible(size_t s);
char *wxMediaStreamIn::GetString(long *n)
{
@ -411,8 +410,7 @@ char *wxMediaStreamIn::GetString(long *n)
Typecheck(st_STRING);
#if 1
r = (char *)scheme_malloc_fail_ok(GC_malloc_atomic, m);
r = (char *)wxMallocAtomicIfPossible(m);
if (!r) {
wxmeError("String too large (out of memory) reading stream.");
bad = 1;
@ -420,9 +418,6 @@ char *wxMediaStreamIn::GetString(long *n)
*n = 0;
return NULL;
}
#else
r = new char[m];
#endif
if (f->Read(r, m) != m) {
bad = 1;

40
src/mred/wxme/wx_snip.cxx
View File

@ -70,7 +70,10 @@ static void memmove(char *dest, char *src, long size)
#define ALWAYSZERO(x) if (x) *x = 0;
extern void *wxMallocAtomicIfPossible(size_t s);
#define STRALLOC(n) new WXGC_ATOMIC char[n]
#define TRY_STRALLOC(n) (char *)wxMallocAtomicIfPossible(n)
#define STRFREE(s) /* empty */
/***************************************************************/
@ -478,6 +481,9 @@ wxSnip *TextSnipClass::Read(wxTextSnip *snip, wxMediaStreamIn *f)
f->Get(&count);
f->JumpTo(pos);
if (count < 0)
count = 10; /* This is a failure. We make up something. */
snip->Read(count, f);
snip->flags = flags;
@ -915,9 +921,25 @@ void wxTextSnip::Read(long len, wxMediaStreamIn *f)
return;
if (allocated < len) {
allocated = 2 * len;
long l = 2 * len;
if (l < 0) {
Read(100, f);
return;
}
STRFREE(buffer);
buffer = STRALLOC(allocated + 1);
if (l > 500) {
buffer = TRY_STRALLOC(l + 1);
if (!buffer) {
Read(100, f);
return;
}
} else
buffer = STRALLOC(l + 1);
allocated = l;
if (!buffer)
Read(10, f);
}
dtext = 0;
@ -1113,7 +1135,7 @@ wxSnip *ImageSnipClass::Read(wxMediaStreamIn *f)
long len;
f->GetFixed(&len);
if (len) {
if ((len > 0) && f->Ok()) {
char *fname;
FILE *fi;
char buffer[IMG_MOVE_BUF_SIZE + 1];
@ -1127,6 +1149,9 @@ wxSnip *ImageSnipClass::Read(wxMediaStreamIn *f)
while (len--) {
c = IMG_MOVE_BUF_SIZE + 1;
f->Get(&c, buffer);
if (!f->Ok())
break;
c = fwrite(buffer, 1, c, fi);
}
@ -1603,6 +1628,15 @@ wxSnip *MediaSnipClass::Read(wxMediaStreamIn *f)
else
media = wxsMakeMediaPasteboard();
if (lm < 0) lm = 0;
if (tm < 0) tm = 0;
if (rm < 0) rm = 0;
if (bm < 0) bm = 0;
if (li < 0) li = 0;
if (ti < 0) ti = 0;
if (ri < 0) ri = 0;
if (bi < 0) bi = 0;
snip = wxsMakeMediaSnip(media, border, lm, tm, rm, bm, li, ti, ri, bi,
w, W, h, H);
if (tightFit)

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

@ -205,7 +205,7 @@
@MACRO checkNull = if (!x0) x0 = &_x0;
@ "get-tabs" : float[]/bReturnList[float.0] GetTabs(nnint?=NULL,float?=NULL,bool?=NULL); : : /checkNull/
@ "get-tabs" : float[]/bReturnList[float.0]///push GetTabs(nnint?=NULL,float?=NULL,bool?=NULL); : : /checkNull/
@ "set-tabs" : void SetTabs(float[]/bList/ubList/cList///push,-int,float=wxTAB_WIDTH,bool=TRUE); : : /glueListSet[float.0.0.1.METHODNAME("text%","set-tabs")]//
@ v "can-insert?" : bool CanInsert(nnlong,nnlong);

59
src/mred/wxs/wxs_misc.cxx
View File

@ -1028,6 +1028,30 @@ static Scheme_Object *os_wxPrintSetupDatacopy(Scheme_Object *obj, int n, Scheme
return scheme_void;
}
static Scheme_Object *os_wxPrintSetupDataSetMargin(Scheme_Object *obj, int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
REMEMBER_VAR_STACK();
objscheme_check_valid(obj);
nnfloat x0;
nnfloat x1;
SETUP_VAR_STACK_REMEMBERED(2);
VAR_STACK_PUSH(0, p);
VAR_STACK_PUSH(1, obj);
x0 = WITH_VAR_STACK(objscheme_unbundle_nonnegative_float(p[0], "set-margin in ps-setup%"));
x1 = WITH_VAR_STACK(objscheme_unbundle_nonnegative_float(p[1], "set-margin in ps-setup%"));
WITH_VAR_STACK(((wxPrintSetupData *)((Scheme_Class_Object *)obj)->primdata)->SetMargin(x0, x1));
return scheme_void;
}
@ -1307,6 +1331,37 @@ static Scheme_Object *os_wxPrintSetupDataSetPrinterCommand(Scheme_Object *obj, i
return scheme_void;
}
static Scheme_Object *os_wxPrintSetupDataGetMargin(Scheme_Object *obj, int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
REMEMBER_VAR_STACK();
objscheme_check_valid(obj);
nnfloat _x0;
nnfloat* x0 = &_x0;
nnfloat _x1;
nnfloat* x1 = &_x1;
Scheme_Object *sbox_tmp;
SETUP_VAR_STACK_REMEMBERED(2);
VAR_STACK_PUSH(0, p);
VAR_STACK_PUSH(1, obj);
*x0 = (sbox_tmp = WITH_VAR_STACK(objscheme_unbox(p[0], "get-margin in ps-setup%")), WITH_VAR_STACK(objscheme_unbundle_nonnegative_float(sbox_tmp, "get-margin in ps-setup%"", extracting boxed argument")));
*x1 = (sbox_tmp = WITH_VAR_STACK(objscheme_unbox(p[1], "get-margin in ps-setup%")), WITH_VAR_STACK(objscheme_unbundle_nonnegative_float(sbox_tmp, "get-margin in ps-setup%"", extracting boxed argument")));
WITH_VAR_STACK(((wxPrintSetupData *)((Scheme_Class_Object *)obj)->primdata)->GetMargin(x0, x1));
if (n > 0)
WITH_VAR_STACK(objscheme_set_box(p[0], WITH_VAR_STACK(scheme_make_double(_x0))));
if (n > 1)
WITH_VAR_STACK(objscheme_set_box(p[1], WITH_VAR_STACK(scheme_make_double(_x1))));
return scheme_void;
}
static Scheme_Object *os_wxPrintSetupDataGetEditorMargin(Scheme_Object *obj, int n, Scheme_Object *p[])
{
WXS_USE_ARGUMENT(n) WXS_USE_ARGUMENT(p)
@ -1627,9 +1682,10 @@ void objscheme_setup_wxPrintSetupData(void *env)
wxREGGLOB(os_wxPrintSetupData_class);
os_wxPrintSetupData_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "ps-setup%", "object%", os_wxPrintSetupData_ConstructScheme, 25));
os_wxPrintSetupData_class = WITH_VAR_STACK(objscheme_def_prim_class(env, "ps-setup%", "object%", os_wxPrintSetupData_ConstructScheme, 27));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxPrintSetupData_class, "copy-from", os_wxPrintSetupDatacopy, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxPrintSetupData_class, "set-margin", os_wxPrintSetupDataSetMargin, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxPrintSetupData_class, "set-editor-margin", os_wxPrintSetupDataSetEditorMargin, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxPrintSetupData_class, "set-level-2", os_wxPrintSetupDataSetLevel2, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxPrintSetupData_class, "set-afm-path", os_wxPrintSetupDataSetAFMPath, 1, 1));
@ -1642,6 +1698,7 @@ void objscheme_setup_wxPrintSetupData(void *env)
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxPrintSetupData_class, "set-preview-command", os_wxPrintSetupDataSetPrintPreviewCommand, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxPrintSetupData_class, "set-file", os_wxPrintSetupDataSetPrinterFile, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxPrintSetupData_class, "set-command", os_wxPrintSetupDataSetPrinterCommand, 1, 1));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxPrintSetupData_class, "get-margin", os_wxPrintSetupDataGetMargin, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxPrintSetupData_class, "get-editor-margin", os_wxPrintSetupDataGetEditorMargin, 2, 2));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxPrintSetupData_class, "get-level-2", os_wxPrintSetupDataGetLevel2, 0, 0));
WITH_VAR_STACK(scheme_add_method_w_arity(os_wxPrintSetupData_class, "get-afm-path", os_wxPrintSetupDataGetAFMPath, 0, 0));

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

@ -143,6 +143,7 @@ void check_ps_mode(int v, Scheme_Object *p)
@ "get-afm-path" : nstring GetAFMPath();
@ "get-level-2" : bool GetLevel2();
@ "get-editor-margin" : void GetEditorMargin(nnlong*,nnlong*);
@ "get-margin" : void GetMargin(nnfloat*,nnfloat*);
@ "set-command" : void SetPrinterCommand(string);
@ "set-file" : void SetPrinterFile(npathname);
@ -156,6 +157,7 @@ void check_ps_mode(int v, Scheme_Object *p)
@ "set-afm-path" : void SetAFMPath(nstring);
@ "set-level-2" : void SetLevel2(bool);
@ "set-editor-margin" : void SetEditorMargin(nnlong,nnlong);
@ "set-margin" : void SetMargin(nnfloat,nnfloat);
@ "copy-from" : void copy(wxPrintSetupData!);

11
src/mysterx/myspage/eventqueue.cxx
View File

@ -102,17 +102,6 @@ STDMETHODIMP CEventQueue::GetReaderSemaphore(int *pReadSem) {
STDMETHODIMP CEventQueue::set_extension_table(int p) {
scheme_extension_table = (Scheme_Extension_Table *)p;
scheme_register_extension_global(&_Module,sizeof(_Module));
scheme_register_extension_global(&eventMap,sizeof(eventMap));
scheme_register_extension_global((void *)&IID_IDHTMLPage,sizeof(IID_IDHTMLPage));
scheme_register_extension_global((void *)&IID_IDHTMLPageUI,sizeof(IID_IDHTMLPageUI));
scheme_register_extension_global((void *)&IID_IEvent,sizeof(IID_IEvent));
scheme_register_extension_global((void *)&IID_IEventQueue,sizeof(IID_IEventQueue));
scheme_register_extension_global((void *)&LIBID_MYSPAGELib,sizeof(LIBID_MYSPAGELib));
scheme_register_extension_global((void *)&CLSID_DHTMLPage,sizeof(CLSID_DHTMLPage));
scheme_register_extension_global((void *)&CLSID_Event,sizeof(CLSID_Event));
scheme_register_extension_global((void *)&CLSID_EventQueue,sizeof(CLSID_EventQueue));
return S_OK;
}

55
src/mysterx/mysterx.cxx
View File

@ -644,7 +644,7 @@ Scheme_Object *mx_unit_init(Scheme_Object **boxes,Scheme_Object **anchors,
anchors[i] = boxes[i];
}
mx_omit_obj = (Scheme_Object *)scheme_malloc_uncollectable(sizeof(MX_OMIT));
mx_omit_obj = (Scheme_Object *)scheme_malloc(sizeof(MX_OMIT));
mx_omit_obj->type = mx_com_omit_type;
SCHEME_ENVBOX_VAL(boxes[sizeray(mxPrims)]) = mx_omit_obj;
@ -2029,14 +2029,6 @@ VARTYPE getVarTypeFromElemDesc(ELEMDESC *pElemDesc) {
}
Scheme_Object *newTypeSymbol(char *s) {
Scheme_Object *retval;
retval = scheme_intern_symbol(s);
scheme_register_extension_global(retval,sizeof(Scheme_Object));
return retval;
}
Scheme_Object *elemDescToSchemeType(ELEMDESC *pElemDesc,BOOL ignoreByRef,BOOL isOpt) {
static char buff[256];
char *s;
@ -4200,62 +4192,25 @@ Scheme_Object *scheme_initialize(Scheme_Env *env) {
// globals in mysterx.cxx
scheme_register_extension_global(&AtlWndProc,sizeof(AtlWndProc));
scheme_register_extension_global(&hIcon,sizeof(hIcon));
scheme_register_extension_global(&browserHwndMutex,sizeof(browserHwndMutex));
scheme_register_extension_global(&createHwndSem,sizeof(createHwndSem));
scheme_register_extension_global(&eventSinkMutex,sizeof(eventSinkMutex));
scheme_register_extension_global((void *)&emptyClsId,sizeof(emptyClsId));
scheme_register_extension_global(&mx_unit,sizeof(mx_unit));
scheme_register_extension_global(&typeTable,sizeof(typeTable));
scheme_register_extension_global(&myssink_table,sizeof(myssink_table));
scheme_register_extension_global(&objectAttributes,sizeof(objectAttributes));
scheme_register_extension_global(&controlAttributes,sizeof(controlAttributes));
scheme_register_extension_global(&mxPrims,sizeof(mxPrims));
// globals in browser.cxx
scheme_register_extension_global(&browserHwnd,sizeof(browserHwnd));
scheme_register_extension_global(&styleOptions,sizeof(styleOptions));
// globals in comtypes.cxx
scheme_register_extension_global(&mx_omit_obj,sizeof(mx_omit_obj));
mx_com_object_type = scheme_make_type("<com-object>");
scheme_register_extension_global(&mx_com_object_type,sizeof(mx_com_object_type));
mx_com_type_type = scheme_make_type("<com-type>");
scheme_register_extension_global(&mx_com_type_type,sizeof(mx_com_type_type));
mx_browser_type = scheme_make_type("<mx-browser>");
scheme_register_extension_global(&mx_browser_type,sizeof(mx_browser_type));
mx_document_type = scheme_make_type("<mx-document>");
scheme_register_extension_global(&mx_document_type,sizeof(mx_document_type));
mx_element_type = scheme_make_type("<mx-element>");
scheme_register_extension_global(&mx_element_type,sizeof(mx_element_type));
mx_event_type = scheme_make_type("<mx-event>");
scheme_register_extension_global(&mx_event_type,sizeof(mx_event_type));
mx_com_cy_type = scheme_make_type("<com-currency>");
scheme_register_extension_global(&mx_com_cy_type,sizeof(mx_com_cy_type));
mx_com_date_type = scheme_make_type("<com-date>");
scheme_register_extension_global(&mx_com_date_type,sizeof(mx_com_date_type));
mx_com_boolean_type = scheme_make_type("<com-bool>");
scheme_register_extension_global(&mx_com_boolean_type,sizeof(mx_com_boolean_type));
mx_com_scode_type = scheme_make_type("<com-scode>");
scheme_register_extension_global(&mx_com_scode_type,sizeof(mx_com_scode_type));
mx_com_variant_type = scheme_make_type("<com-variant>");
scheme_register_extension_global(&mx_com_variant_type,sizeof(mx_com_variant_type));
mx_com_iunknown_type = scheme_make_type("<com-iunknown>");
scheme_register_extension_global(&mx_com_iunknown_type,sizeof(mx_com_iunknown_type));
mx_com_pointer_type = scheme_make_type("<com-pointer>");
scheme_register_extension_global(&mx_com_pointer_type,sizeof(mx_com_pointer_type));
mx_com_array_type = scheme_make_type("<com-array>");
scheme_register_extension_global(&mx_com_array_type,sizeof(mx_com_array_type));
mx_com_omit_type = scheme_make_type("<com-omit>");
scheme_register_extension_global(&mx_com_omit_type,sizeof(mx_com_omit_type));
mx_com_typedesc_type = scheme_make_type("<com-typedesc>");
scheme_register_extension_global(&mx_com_typedesc_type,sizeof(mx_com_typedesc_type));
// globals in htmlevent.cxx
scheme_register_extension_global(&eventNames,sizeof(eventNames));
hr = CoInitialize(NULL);
@ -4265,13 +4220,9 @@ Scheme_Object *scheme_initialize(Scheme_Env *env) {
return scheme_false;
}
// make type hash table uncollectable
scheme_register_extension_global(typeTable,TYPE_TBL_SIZE * sizeof(MX_TYPE_TBL_ENTRY *));
// export prims + omit value
mx_unit = (Scheme_Unit *)scheme_malloc_uncollectable(sizeof(Scheme_Unit));
mx_unit = (Scheme_Unit *)scheme_malloc(sizeof(Scheme_Unit));
mx_unit->type = scheme_unit_type;
mx_unit->num_imports = 0;
mx_unit->num_exports = sizeray(mxPrims) + 1;

8
src/mzcom/mzcom.cxx
View File

@ -13,9 +13,10 @@
#include "MzCOM_i.c"
#include "mzobj.h"
const DWORD dwTimeOut = 5000; // time for EXE to be idle before shutting down
const DWORD dwPause = 1000; // time to wait for threads to finish up
// time for EXE to be idle before shutting down
#define dwTimeOut (5000)
// time to wait for threads to finish up
#define dwPause (1000)
HINSTANCE globHinst;
@ -80,7 +81,6 @@ BEGIN_OBJECT_MAP(ObjectMap)
OBJECT_ENTRY(CLSID_MzObj, CMzObj)
END_OBJECT_MAP()
LPCTSTR FindOneOf(LPCTSTR p1, LPCTSTR p2)
{
while (p1 != NULL && *p1 != NULL)

1
src/mzcom/mzcom.idl
View File

@ -17,6 +17,7 @@ import "ocidl.idl";
{
[id(1), helpstring("method Eval")] HRESULT Eval(BSTR input,[out,retval]BSTR *output);
[id(2), helpstring("method About")] HRESULT About();
[id(3), helpstring("method Reset")] HRESULT Reset();
};
[

161
src/mzcom/mzobj.cxx
View File

@ -1,22 +1,34 @@
// mzobj.cxx : Implementation of CMzObj
#include "resource.h"
#include "stdafx.h"
#include "resource.h"
#ifdef _ATL_STATIC_REGISTRY
#include <statreg.h>
#include <statreg.cpp>
#endif
#include <atlimpl.cpp>
#include "mzcom.h"
#include "mzobj.h"
static THREAD_GLOBALS tg;
static Scheme_Env *env;
static BOOL *pErrorState;
static OLECHAR *wideError;
static HANDLE evalLoopSems[2];
static HANDLE exitSem;
static Scheme_Object *exn_catching_apply;
static Scheme_Object *exn_p;
static Scheme_Object *exn_message;
static void ErrorBox(char *s) {
::MessageBox(NULL,s,"MzCOM",MB_OK);
}
static Scheme_Object *_apply_thunk_catch_exceptions(Scheme_Object *f,
Scheme_Object **exn) {
Scheme_Object *v;
@ -76,7 +88,7 @@ OLECHAR *wideStringFromSchemeObj(Scheme_Object *obj,char *fmt,int fmtlen) {
len = strlen(s);
wideString = (OLECHAR *)scheme_malloc((len + 1) * sizeof(OLECHAR));
MultiByteToWideChar(CP_ACP,(DWORD)0,s,len,wideString,len + 1);
wideString[len] = '\0';
wideString[len] = L'\0';
return wideString;
}
@ -85,44 +97,21 @@ void exitHandler(int) {
ExitThread(0);
}
DWORD WINAPI evalLoop(LPVOID args) {
UINT len;
char *narrowInput;
Scheme_Object *outputObj;
OLECHAR *outputBuffer;
mz_jmp_buf saveBuff;
THREAD_GLOBALS *pTg;
HANDLE readSem;
HANDLE writeSem;
BSTR **ppInput;
BSTR *pOutput;
HRESULT *pHr;
void setupSchemeEnv(void) {
char *wrapper;
char exeBuff[260];
// make sure all MzScheme calls in this thread
GC_use_registered_statics = 1;
scheme_exit = exitHandler;
pTg = (THREAD_GLOBALS *)args;
ppInput = pTg->ppInput;
pOutput = pTg->pOutput;
pHr = pTg->pHr;
readSem = pTg->readSem;
writeSem = pTg->writeSem;
pErrorState = pTg->pErrorState;
env = scheme_basic_env();
if (env == NULL) {
::MessageBox(NULL,"Can't create Scheme environment","MzCOM",MB_OK);
ErrorBox("Can't create Scheme environment");
ExitThread(0);
}
}
scheme_dont_gc_ptr(env);
scheme_register_static(&env,sizeof(env));
scheme_register_static(&exn_catching_apply,sizeof(exn_catching_apply));
scheme_register_static(&exn_p,sizeof(exn_p));
scheme_register_static(&exn_message,sizeof(exn_message));
// set up exception trapping
@ -154,11 +143,51 @@ DWORD WINAPI evalLoop(LPVOID args) {
"(#%lambda () (#%find-executable-path mzcom-exe \"..\")) "
"(#%lambda () \"c:\\plt\\collects\") "
")) #%null)))",
env);
env);
}
DWORD WINAPI evalLoop(LPVOID args) {
UINT len;
char *narrowInput;
Scheme_Object *outputObj;
OLECHAR *outputBuffer;
THREAD_GLOBALS *pTg;
HANDLE readSem;
HANDLE writeSem;
HANDLE resetSem;
HANDLE resetDoneSem;
BSTR **ppInput;
BSTR *pOutput;
HRESULT *pHr;
// make sure all MzScheme calls in this thread
GC_use_registered_statics = 1;
setupSchemeEnv();
scheme_exit = exitHandler;
pTg = (THREAD_GLOBALS *)args;
ppInput = pTg->ppInput;
pOutput = pTg->pOutput;
pHr = pTg->pHr;
readSem = pTg->readSem;
writeSem = pTg->writeSem;
resetSem = pTg->resetSem;
resetDoneSem = pTg->resetDoneSem;
pErrorState = pTg->pErrorState;
while (1) {
WaitForSingleObject(readSem,INFINITE);
if (WaitForMultipleObjects(2,evalLoopSems,FALSE,INFINITE) ==
WAIT_OBJECT_0 + 1) {
// reset semaphore signalled
setupSchemeEnv();
ReleaseSemaphore(resetDoneSem,1,NULL);
continue;
}
len = SysStringLen(**ppInput);
@ -188,8 +217,6 @@ DWORD WINAPI evalLoop(LPVOID args) {
*pHr = S_OK;
}
memcpy(&scheme_error_buf,&saveBuff,sizeof(mz_jmp_buf));
ReleaseSemaphore(writeSem,1,NULL);
}
@ -198,13 +225,13 @@ DWORD WINAPI evalLoop(LPVOID args) {
}
void CMzObj::startMzThread(void) {
static THREAD_GLOBALS tg;
tg.pHr = &hr;
tg.ppInput = &globInput;
tg.pOutput = &globOutput;
tg.readSem = readSem;
tg.writeSem = writeSem;
tg.resetSem = resetSem;
tg.resetDoneSem = resetDoneSem;
tg.pErrorState = &errorState;
threadHandle = CreateThread(NULL,0,evalLoop,(LPVOID)&tg,0,&threadId);
@ -212,7 +239,7 @@ void CMzObj::startMzThread(void) {
CMzObj::CMzObj(void) {
lastOutput = NULL;
inputMutex = NULL;
readSem = NULL;
threadId = NULL;
@ -220,33 +247,49 @@ CMzObj::CMzObj(void) {
inputMutex = CreateSemaphore(NULL,1,1,NULL);
if (inputMutex == NULL) {
MessageBox(NULL,"Can't create input mutex","MzCOM",MB_OK);
ErrorBox("Can't create input mutex");
return;
}
readSem = CreateSemaphore(NULL,0,1,NULL);
if (readSem == NULL) {
MessageBox(NULL,"Can't create read semaphore","MzCOM",MB_OK);
ErrorBox("Can't create read semaphore");
return;
}
writeSem = CreateSemaphore(NULL,0,1,NULL);
if (writeSem == NULL) {
MessageBox(NULL,"Can't create write semaphore","MzCOM",MB_OK);
ErrorBox("Can't create write semaphore");
return;
}
exitSem = CreateSemaphore(NULL,0,1,NULL);
if (exitSem == NULL) {
MessageBox(NULL,"Can't create exit semaphore","MzCOM",MB_OK);
ErrorBox("Can't create exit semaphore");
return;
}
evalSems[0] = writeSem;
evalSems[1] = exitSem;
resetSem = CreateSemaphore(NULL,0,1,NULL);
if (resetSem == NULL) {
ErrorBox("Can't create reset semaphore");
return;
}
resetDoneSem = CreateSemaphore(NULL,0,1,NULL);
if (resetSem == NULL) {
ErrorBox("Can't create reset-done semaphore");
return;
}
evalLoopSems[0] = readSem;
evalLoopSems[1] = resetSem;
evalDoneSems[0] = writeSem;
evalDoneSems[1] = exitSem;
startMzThread();
}
@ -269,6 +312,10 @@ void CMzObj::killMzThread(void) {
CMzObj::~CMzObj(void) {
if (lastOutput) {
SysFreeString(lastOutput);
}
killMzThread();
if (readSem) {
@ -318,23 +365,30 @@ BOOL CMzObj::testThread(void) {
/////////////////////////////////////////////////////////////////////////////
// CMzObj
STDMETHODIMP CMzObj::Eval(BSTR input, BSTR *output) {
if (!testThread()) {
return E_ABORT;
}
WaitForSingleObject(inputMutex,INFINITE);
if (lastOutput) {
SysFreeString(lastOutput);
lastOutput = NULL;
}
globInput = &input;
// allow evaluator to read
ReleaseSemaphore(readSem,1,NULL);
// wait until evaluator done or eval thread terminated
if (WaitForMultipleObjects(2,evalSems,FALSE,INFINITE) ==
if (WaitForMultipleObjects(2,evalDoneSems,FALSE,INFINITE) ==
WAIT_OBJECT_0 + 1) {
RaiseError(L"Scheme terminated evaluator");
return E_FAIL;
}
*output = globOutput;
lastOutput = *output = globOutput;
ReleaseSemaphore(inputMutex,1,NULL);
if (errorState) {
@ -367,3 +421,12 @@ STDMETHODIMP CMzObj::About() {
return S_OK;
}
STDMETHODIMP CMzObj::Reset() {
if (!testThread()) {
return E_ABORT;
}
ReleaseSemaphore(resetSem,1,NULL);
WaitForSingleObject(resetDoneSem,INFINITE);
return S_OK;
}

9
src/mzcom/mzobj.h
View File

@ -13,6 +13,8 @@ typedef struct {
HRESULT *pHr;
HANDLE readSem;
HANDLE writeSem;
HANDLE resetSem;
HANDLE resetDoneSem;
BOOL *pErrorState;
BOOL *pResetFlag;
} THREAD_GLOBALS;
@ -36,9 +38,12 @@ class ATL_NO_VTABLE CMzObj :
HANDLE inputMutex;
HANDLE readSem;
HANDLE writeSem;
HANDLE evalSems[2];
HANDLE resetSem;
HANDLE resetDoneSem;
HANDLE evalDoneSems[2];
BSTR *globInput;
BSTR globOutput;
BSTR lastOutput;
DWORD threadId;
HANDLE threadHandle;
BOOL errorState;
@ -70,8 +75,10 @@ END_CONNECTION_POINT_MAP()
// IMzObj
public:
STDMETHOD(Reset)(void);
STDMETHOD(About)(void);
STDMETHOD(Eval)(BSTR input,/*[out,retval]*/BSTR *output);
};
#endif //__MZOBJ_H_

12
src/mzcom/stdafx.cxx
View File

@ -1,12 +0,0 @@
// stdafx.cpp : source file that includes just the standard includes
// stdafx.pch will be the pre-compiled header
// stdafx.obj will contain the pre-compiled type information
#include "stdafx.h"
#ifdef _ATL_STATIC_REGISTRY
#include <statreg.h>
#include <statreg.cpp>
#endif
#include <atlimpl.cpp>

1
src/mzcom/stdafx.h
View File

@ -29,6 +29,7 @@ public:
bool bActivity;
};
extern CExeModule _Module;
#include <atlcom.h>
//{{AFX_INSERT_LOCATION}}

31
src/mzscheme/configure.in
View File

@ -99,6 +99,9 @@ AC_PROG_CPP
AC_PROG_CXX
if test "$AS" = '' ; then
AS=as
as_was_set=no
else
as_was_set=yes
fi
AC_PROG_RANLIB
if test "$AR" = '' ; then
@ -152,13 +155,22 @@ fi
############## platform tests ################
if test -x "/bin/uname" ; then
UNAME=/bin/uname
elif test -x "/usr/bin/uname" ; then
UNAME=/usr/bin/uname
else
echo configure: cannot find uname
exit 1
fi
# for flags we don't want to use in config tests:
EXTRALIBS=
OS=`uname -s`
OS=`$UNAME -s`
case $OS in
SunOS)
case `uname -r` in
case `$UNAME -r` in
5.*)
if test "${enable_osthreads}" = "yes" ; then
OPTIONS="${OPTIONS} -DSOLARIS_THREADS"
@ -224,7 +236,19 @@ case $OS in
fi
;;
*)
echo "Warning: Unknown OS"
;;
esac
MACH=`$UNAME -m`
case "$MACH" in
alpha)
if test "$CC" = "gcc" ; then
if test "$as_was_set" = "no" ; then
AS="gcc -c -x assembler-with-cpp"
fi
fi
;;
*)
;;
esac
@ -240,7 +264,6 @@ if test "${enable_sgcdebug}" = "yes" ; then
OPTIONS="$OPTIONS -DSGC_STD_DEBUGGING=1"
fi
############## C++ grunge ################
MROPTIONS=

2
src/mzscheme/sconfig.h
View File

@ -233,7 +233,7 @@ int scheme_solaris_semaphore_try_down(void *);
# if defined(__mc68000__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "m68k-linux"
# endif
# if defined(__alpha)
# if defined(__alpha__)
# define SCHEME_PLATFORM_LIBRARY_SUBPATH "alpha-linux"
# endif
# ifndef SCHEME_PLATFORM_LIBRARY_SUBPATH

2
src/mzscheme/src/schvers.h
View File

@ -5,4 +5,4 @@
# define SPECIAL_TAG ""
#endif
#define VERSION "102/13" SPECIAL_TAG
#define VERSION "102" SPECIAL_TAG

91
src/srpersist/srpersist.cxx
View File

@ -6726,29 +6726,6 @@ void initTypes(void) {
sql_op_parms_type = scheme_make_type("<sql-op-parms>");
sql_guid_type = scheme_make_type("<sql-guid>");
sql_paramlength_type = scheme_make_type("<sql-paramlength>");
register_global(sql_date_type);
register_global(sql_decimal_type);
register_global(sql_pointer_type);
register_global(sql_time_type);
register_global(sql_timestamp_type);
register_global(sql_return_type);
register_global(sql_henv_type);
register_global(sql_hdbc_type);
register_global(sql_hstmt_type);
register_global(sql_hdesc_type);
register_global(sql_boxed_uint_type);
register_global(sql_buffer_type);
register_global(sql_length_type);
register_global(sql_indicator_type);
register_global(sql_row_status_type);
register_global(sql_array_status_type);
register_global(sql_binding_offset_type);
register_global(sql_rows_processed_type);
register_global(sql_octet_length_type);
register_global(sql_op_parms_type);
register_global(sql_guid_type);
register_global(sql_paramlength_type);
}
void initExns(Scheme_Env *env) {
@ -6780,12 +6757,12 @@ void initExns(Scheme_Env *env) {
exnNameCount += name_count;
}
register_global(withInfoFuns);
register_global(noDataFuns);
register_global(invalidHandleFuns);
register_global(errorFuns);
register_global(needDataFuns);
register_global(stillExecutingFuns);
scheme_register_extension_global(&withInfoFuns,sizeof(withInfoFuns));
scheme_register_extension_global(&noDataFuns,sizeof(noDataFuns));
scheme_register_extension_global(&invalidHandleFuns,sizeof(invalidHandleFuns));
scheme_register_extension_global(&errorFuns,sizeof(errorFuns));
scheme_register_extension_global(&needDataFuns,sizeof(needDataFuns));
scheme_register_extension_global(&stillExecutingFuns,sizeof(stillExecutingFuns));
}
void initStructs(void) {
@ -6808,24 +6785,42 @@ void initStructs(void) {
structNameCount += name_count;
}
register_global(numericStructFuns);
register_global(dateStructFuns);
register_global(timeStructFuns);
register_global(timeStampStructFuns);
register_global(guidStructFuns);
register_global(yearIntervalStructFuns);
register_global(monthIntervalStructFuns);
register_global(dayIntervalStructFuns);
register_global(hourIntervalStructFuns);
register_global(minuteIntervalStructFuns);
register_global(secondIntervalStructFuns);
register_global(yearToMonthIntervalStructFuns);
register_global(dayToHourIntervalStructFuns);
register_global(dayToMinuteIntervalStructFuns);
register_global(dayToSecondIntervalStructFuns);
register_global(hourToMinuteIntervalStructFuns);
register_global(hourToSecondIntervalStructFuns);
register_global(minuteToSecondIntervalStructFuns);
scheme_register_extension_global(&numericStructFuns,
sizeof(numericStructFuns));
scheme_register_extension_global(&dateStructFuns,
sizeof(dateStructFuns));
scheme_register_extension_global(&timeStructFuns,
sizeof(timeStructFuns));
scheme_register_extension_global(&timeStampStructFuns,
sizeof(timeStampStructFuns));
scheme_register_extension_global(&guidStructFuns,
sizeof(guidStructFuns));
scheme_register_extension_global(&yearIntervalStructFuns,
sizeof(yearIntervalStructFuns));
scheme_register_extension_global(&monthIntervalStructFuns,
sizeof(monthIntervalStructFuns));
scheme_register_extension_global(&dayIntervalStructFuns,
sizeof(dayIntervalStructFuns));
scheme_register_extension_global(&hourIntervalStructFuns,
sizeof(hourIntervalStructFuns));
scheme_register_extension_global(&minuteIntervalStructFuns,
sizeof(minuteIntervalStructFuns));
scheme_register_extension_global(&secondIntervalStructFuns,
sizeof(secondIntervalStructFuns));
scheme_register_extension_global(&yearToMonthIntervalStructFuns,
sizeof(yearToMonthIntervalStructFuns));
scheme_register_extension_global(&dayToHourIntervalStructFuns,
sizeof(dayToHourIntervalStructFuns));
scheme_register_extension_global(&dayToMinuteIntervalStructFuns,
sizeof(dayToMinuteIntervalStructFuns));
scheme_register_extension_global(&dayToSecondIntervalStructFuns,
sizeof(dayToSecondIntervalStructFuns));
scheme_register_extension_global(&hourToMinuteIntervalStructFuns,
sizeof(hourToMinuteIntervalStructFuns));
scheme_register_extension_global(&hourToSecondIntervalStructFuns,
sizeof(hourToSecondIntervalStructFuns));
scheme_register_extension_global(&minuteToSecondIntervalStructFuns,
sizeof(minuteToSecondIntervalStructFuns));
}
Scheme_Object *schemeObjectFromString(char *s,Scheme_Env *env) {
@ -6834,7 +6829,7 @@ Scheme_Object *schemeObjectFromString(char *s,Scheme_Env *env) {
void initGlobals(Scheme_Env *env) {
scheme_raise = schemeObjectFromString("raise",env);
register_global(scheme_raise);
scheme_register_extension_global(&scheme_raise,sizeof(scheme_raise));
}
void sortConsts(void) {

1
src/srpersist/srpersist.h
View File

@ -1,7 +1,6 @@
/* srpersist.h */
#define sizeray(x) (sizeof(x)/sizeof(*x))
#define register_global(x) scheme_register_extension_global(&x,sizeof(x))
#define sql_return(v,retcode,f) if (retcode == success) \
{ return v; } \

24
src/worksp/mzcom/mzcom.dsp
View File

@ -43,7 +43,7 @@ RSC=rc.exe
# PROP Ignore_Export_Lib 0
# PROP Target_Dir ""
# ADD BASE CPP /nologo /W3 /Gm /ZI /Od /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /Yu"stdafx.h" /FD /GZ /c
# ADD CPP /nologo /MT /W3 /Gm /ZI /Od /I "..\..\..\collects\mzscheme\include" /I "..\..\mzcom" /I "." /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /YX /FD /GZ /c
# ADD CPP /nologo /MTd /W3 /Gm /ZI /Od /I "..\..\..\collects\mzscheme\include" /I "..\..\mzcom" /I "." /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /YX /FD /GZ /c
# ADD BASE RSC /l 0x409 /d "_DEBUG"
# ADD RSC /l 0x409 /i ".\..\mzcom" /d "_DEBUG"
BSC32=bscmake.exe
@ -51,12 +51,12 @@ BSC32=bscmake.exe
# ADD BSC32 /nologo
LINK32=link.exe
# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /debug /machine:I386 /pdbtype:sept
# ADD LINK32 libcmtd.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib wsock32.lib mzsrc.lib gc.lib /nologo /subsystem:windows /debug /machine:I386 /nodefaultlib:"libcmt.lib" /pdbtype:sept /libpath:"..\mzsrc\Release" /libpath:"..\gc\Release"
# ADD LINK32 libcmtd.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib wsock32.lib mzsrc.lib gc.lib /nologo /subsystem:windows /debug /machine:I386 /nodefaultlib:"libcmt.lib" /out:"../../../collects/mzcom/mzcom.exe" /pdbtype:sept /libpath:"..\mzsrc\Debug" /libpath:"..\gc\Debug"
# SUBTRACT LINK32 /pdb:none
# Begin Custom Build - Performing registration
OutDir=.\Debug
TargetPath=.\Debug\MzCOM.exe
InputPath=.\Debug\MzCOM.exe
TargetPath=\plt\collects\mzcom\mzcom.exe
InputPath=\plt\collects\mzcom\mzcom.exe
SOURCE="$(InputPath)"
"$(OutDir)\regsvr32.trg" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
@ -80,7 +80,7 @@ SOURCE="$(InputPath)"
# PROP Ignore_Export_Lib 0
# PROP Target_Dir ""
# ADD BASE CPP /nologo /W3 /O1 /I "../../mzscheme/include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /D "_ATL_MIN_CRT" /Yu"stdafx.h" /FD /c
# ADD CPP /nologo /MT /W3 /O1 /I "..\..\..\collects\mzscheme\include" /I "..\..\mzcom" /I "." /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /YX /FD /c
# ADD CPP /nologo /MT /W3 /O1 /I "..\..\mzcom" /I "." /I "..\..\..\collects\mzscheme\include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /YX /FD /c
# ADD BASE RSC /l 0x409 /d "NDEBUG"
# ADD RSC /l 0x409 /i "..\..\mzcom" /d "NDEBUG"
BSC32=bscmake.exe
@ -88,12 +88,12 @@ BSC32=bscmake.exe
# ADD BSC32 /nologo
LINK32=link.exe
# ADD BASE LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib /nologo /subsystem:windows /machine:I386
# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib wsock32.lib mzsrc.lib gc.lib /nologo /subsystem:windows /machine:I386 /libpath:"..\mzsrc\Release" /libpath:"..\gc\Release"
# ADD LINK32 kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib wsock32.lib mzsrc.lib gc.lib /nologo /subsystem:windows /machine:I386 /out:"../../../collects/mzcom/mzcom.exe" /libpath:"..\mzsrc\Release" /libpath:"..\gc\Release"
# SUBTRACT LINK32 /pdb:none
# Begin Custom Build - Performing registration
OutDir=.\Release
TargetPath=.\Release\MzCOM.exe
InputPath=.\Release\MzCOM.exe
TargetPath=\plt\collects\mzcom\mzcom.exe
InputPath=\plt\collects\mzcom\mzcom.exe
SOURCE="$(InputPath)"
"$(OutDir)\regsvr32.trg" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
@ -131,9 +131,13 @@ SOURCE=..\..\mzcom\mzcom.idl
!IF "$(CFG)" == "MzCOM - Win32 Debug"
# ADD MTL /tlb "./mzcom.tlb"
# SUBTRACT MTL /Oicf
!ELSEIF "$(CFG)" == "MzCOM - Win32 Release"
# PROP Intermediate_Dir "Release"
# ADD MTL /tlb "./mzcom.tlb"
!ENDIF
@ -153,10 +157,6 @@ SOURCE=..\..\mzcom\mzobj.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mzcom\stdafx.cxx
# End Source File
# Begin Source File
SOURCE=..\..\mzcom\stdafx.h
# End Source File
# End Group

24
src/worksp/mzcom/mzcom.dsw
View File

@ -15,6 +15,30 @@ Package=<4>
###############################################################################
Project: "gc"=..\gc\gc.dsp - Package Owner=<4>
Package=<5>
{{{
}}}
Package=<4>
{{{
}}}
###############################################################################
Project: "mzsrc"=..\mzsrc\mzsrc.dsp - Package Owner=<4>
Package=<5>
{{{
}}}
Package=<4>
{{{
}}}
###############################################################################
Global:
Package=<5>

382
src/worksp/mzcom/mzcom.h Normal file
View File

@ -0,0 +1,382 @@
/* this ALWAYS GENERATED file contains the definitions for the interfaces */
/* File created by MIDL compiler version 5.01.0164 */
/* at Thu May 25 13:43:33 2000
*/
/* Compiler settings for D:\plt\src\mzcom\mzcom.idl:
Os (OptLev=s), W1, Zp8, env=Win32, ms_ext, c_ext
error checks: allocation ref bounds_check enum stub_data
*/
//@@MIDL_FILE_HEADING( )
/* verify that the <rpcndr.h> version is high enough to compile this file*/
#ifndef __REQUIRED_RPCNDR_H_VERSION__
#define __REQUIRED_RPCNDR_H_VERSION__ 440
#endif
#include "rpc.h"
#include "rpcndr.h"
#ifndef __RPCNDR_H_VERSION__
#error this stub requires an updated version of <rpcndr.h>
#endif // __RPCNDR_H_VERSION__
#ifndef COM_NO_WINDOWS_H
#include "windows.h"
#include "ole2.h"
#endif /*COM_NO_WINDOWS_H*/
#ifndef __mzcom_h__
#define __mzcom_h__
#ifdef __cplusplus
extern "C"{
#endif
/* Forward Declarations */
#ifndef __IMzObj_FWD_DEFINED__
#define __IMzObj_FWD_DEFINED__
typedef interface IMzObj IMzObj;
#endif /* __IMzObj_FWD_DEFINED__ */
#ifndef ___IMzObjEvents_FWD_DEFINED__
#define ___IMzObjEvents_FWD_DEFINED__
typedef interface _IMzObjEvents _IMzObjEvents;
#endif /* ___IMzObjEvents_FWD_DEFINED__ */
#ifndef __MzObj_FWD_DEFINED__
#define __MzObj_FWD_DEFINED__
#ifdef __cplusplus
typedef class MzObj MzObj;
#else
typedef struct MzObj MzObj;
#endif /* __cplusplus */
#endif /* __MzObj_FWD_DEFINED__ */
/* header files for imported files */
#include "oaidl.h"
#include "ocidl.h"
void __RPC_FAR * __RPC_USER MIDL_user_allocate(size_t);
void __RPC_USER MIDL_user_free( void __RPC_FAR * );
#ifndef __IMzObj_INTERFACE_DEFINED__
#define __IMzObj_INTERFACE_DEFINED__
/* interface IMzObj */
/* [unique][helpstring][dual][uuid][object] */
EXTERN_C const IID IID_IMzObj;
#if defined(__cplusplus) && !defined(CINTERFACE)
MIDL_INTERFACE("A604CBA8-2AB5-11D4-B6D3-0060089002FE")
IMzObj : public IDispatch
{
public:
virtual /* [helpstring][id] */ HRESULT STDMETHODCALLTYPE Eval(
BSTR input,
/* [retval][out] */ BSTR __RPC_FAR *output) = 0;
virtual /* [helpstring][id] */ HRESULT STDMETHODCALLTYPE About( void) = 0;
virtual /* [helpstring][id] */ HRESULT STDMETHODCALLTYPE Reset( void) = 0;
};
#else /* C style interface */
typedef struct IMzObjVtbl
{
BEGIN_INTERFACE
HRESULT ( STDMETHODCALLTYPE __RPC_FAR *QueryInterface )(
IMzObj __RPC_FAR * This,
/* [in] */ REFIID riid,
/* [iid_is][out] */ void __RPC_FAR *__RPC_FAR *ppvObject);
ULONG ( STDMETHODCALLTYPE __RPC_FAR *AddRef )(
IMzObj __RPC_FAR * This);
ULONG ( STDMETHODCALLTYPE __RPC_FAR *Release )(
IMzObj __RPC_FAR * This);
HRESULT ( STDMETHODCALLTYPE __RPC_FAR *GetTypeInfoCount )(
IMzObj __RPC_FAR * This,
/* [out] */ UINT __RPC_FAR *pctinfo);
HRESULT ( STDMETHODCALLTYPE __RPC_FAR *GetTypeInfo )(
IMzObj __RPC_FAR * This,
/* [in] */ UINT iTInfo,
/* [in] */ LCID lcid,
/* [out] */ ITypeInfo __RPC_FAR *__RPC_FAR *ppTInfo);
HRESULT ( STDMETHODCALLTYPE __RPC_FAR *GetIDsOfNames )(
IMzObj __RPC_FAR * This,
/* [in] */ REFIID riid,
/* [size_is][in] */ LPOLESTR __RPC_FAR *rgszNames,
/* [in] */ UINT cNames,
/* [in] */ LCID lcid,
/* [size_is][out] */ DISPID __RPC_FAR *rgDispId);
/* [local] */ HRESULT ( STDMETHODCALLTYPE __RPC_FAR *Invoke )(
IMzObj __RPC_FAR * This,
/* [in] */ DISPID dispIdMember,
/* [in] */ REFIID riid,
/* [in] */ LCID lcid,
/* [in] */ WORD wFlags,
/* [out][in] */ DISPPARAMS __RPC_FAR *pDispParams,
/* [out] */ VARIANT __RPC_FAR *pVarResult,
/* [out] */ EXCEPINFO __RPC_FAR *pExcepInfo,
/* [out] */ UINT __RPC_FAR *puArgErr);
/* [helpstring][id] */ HRESULT ( STDMETHODCALLTYPE __RPC_FAR *Eval )(
IMzObj __RPC_FAR * This,
BSTR input,
/* [retval][out] */ BSTR __RPC_FAR *output);
/* [helpstring][id] */ HRESULT ( STDMETHODCALLTYPE __RPC_FAR *About )(
IMzObj __RPC_FAR * This);
/* [helpstring][id] */ HRESULT ( STDMETHODCALLTYPE __RPC_FAR *Reset )(
IMzObj __RPC_FAR * This);
END_INTERFACE
} IMzObjVtbl;
interface IMzObj
{
CONST_VTBL struct IMzObjVtbl __RPC_FAR *lpVtbl;
};
#ifdef COBJMACROS
#define IMzObj_QueryInterface(This,riid,ppvObject) \
(This)->lpVtbl -> QueryInterface(This,riid,ppvObject)
#define IMzObj_AddRef(This) \
(This)->lpVtbl -> AddRef(This)
#define IMzObj_Release(This) \
(This)->lpVtbl -> Release(This)
#define IMzObj_GetTypeInfoCount(This,pctinfo) \
(This)->lpVtbl -> GetTypeInfoCount(This,pctinfo)
#define IMzObj_GetTypeInfo(This,iTInfo,lcid,ppTInfo) \
(This)->lpVtbl -> GetTypeInfo(This,iTInfo,lcid,ppTInfo)
#define IMzObj_GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId) \
(This)->lpVtbl -> GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId)
#define IMzObj_Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr) \
(This)->lpVtbl -> Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr)
#define IMzObj_Eval(This,input,output) \
(This)->lpVtbl -> Eval(This,input,output)
#define IMzObj_About(This) \
(This)->lpVtbl -> About(This)
#define IMzObj_Reset(This) \
(This)->lpVtbl -> Reset(This)
#endif /* COBJMACROS */
#endif /* C style interface */
/* [helpstring][id] */ HRESULT STDMETHODCALLTYPE IMzObj_Eval_Proxy(
IMzObj __RPC_FAR * This,
BSTR input,
/* [retval][out] */ BSTR __RPC_FAR *output);
void __RPC_STUB IMzObj_Eval_Stub(
IRpcStubBuffer *This,
IRpcChannelBuffer *_pRpcChannelBuffer,
PRPC_MESSAGE _pRpcMessage,
DWORD *_pdwStubPhase);
/* [helpstring][id] */ HRESULT STDMETHODCALLTYPE IMzObj_About_Proxy(
IMzObj __RPC_FAR * This);
void __RPC_STUB IMzObj_About_Stub(
IRpcStubBuffer *This,
IRpcChannelBuffer *_pRpcChannelBuffer,
PRPC_MESSAGE _pRpcMessage,
DWORD *_pdwStubPhase);
/* [helpstring][id] */ HRESULT STDMETHODCALLTYPE IMzObj_Reset_Proxy(
IMzObj __RPC_FAR * This);
void __RPC_STUB IMzObj_Reset_Stub(
IRpcStubBuffer *This,
IRpcChannelBuffer *_pRpcChannelBuffer,
PRPC_MESSAGE _pRpcMessage,
DWORD *_pdwStubPhase);
#endif /* __IMzObj_INTERFACE_DEFINED__ */
#ifndef __MZCOMLib_LIBRARY_DEFINED__
#define __MZCOMLib_LIBRARY_DEFINED__
/* library MZCOMLib */
/* [helpstring][version][uuid] */
EXTERN_C const IID LIBID_MZCOMLib;
#ifndef ___IMzObjEvents_DISPINTERFACE_DEFINED__
#define ___IMzObjEvents_DISPINTERFACE_DEFINED__
/* dispinterface _IMzObjEvents */
/* [helpstring][uuid] */
EXTERN_C const IID DIID__IMzObjEvents;
#if defined(__cplusplus) && !defined(CINTERFACE)
MIDL_INTERFACE("A604CBA9-2AB5-11D4-B6D3-0060089002FE")
_IMzObjEvents : public IDispatch
{
};
#else /* C style interface */
typedef struct _IMzObjEventsVtbl
{
BEGIN_INTERFACE
HRESULT ( STDMETHODCALLTYPE __RPC_FAR *QueryInterface )(
_IMzObjEvents __RPC_FAR * This,
/* [in] */ REFIID riid,
/* [iid_is][out] */ void __RPC_FAR *__RPC_FAR *ppvObject);
ULONG ( STDMETHODCALLTYPE __RPC_FAR *AddRef )(
_IMzObjEvents __RPC_FAR * This);
ULONG ( STDMETHODCALLTYPE __RPC_FAR *Release )(
_IMzObjEvents __RPC_FAR * This);
HRESULT ( STDMETHODCALLTYPE __RPC_FAR *GetTypeInfoCount )(
_IMzObjEvents __RPC_FAR * This,
/* [out] */ UINT __RPC_FAR *pctinfo);
HRESULT ( STDMETHODCALLTYPE __RPC_FAR *GetTypeInfo )(
_IMzObjEvents __RPC_FAR * This,
/* [in] */ UINT iTInfo,
/* [in] */ LCID lcid,
/* [out] */ ITypeInfo __RPC_FAR *__RPC_FAR *ppTInfo);
HRESULT ( STDMETHODCALLTYPE __RPC_FAR *GetIDsOfNames )(
_IMzObjEvents __RPC_FAR * This,
/* [in] */ REFIID riid,
/* [size_is][in] */ LPOLESTR __RPC_FAR *rgszNames,
/* [in] */ UINT cNames,
/* [in] */ LCID lcid,
/* [size_is][out] */ DISPID __RPC_FAR *rgDispId);
/* [local] */ HRESULT ( STDMETHODCALLTYPE __RPC_FAR *Invoke )(
_IMzObjEvents __RPC_FAR * This,
/* [in] */ DISPID dispIdMember,
/* [in] */ REFIID riid,
/* [in] */ LCID lcid,
/* [in] */ WORD wFlags,
/* [out][in] */ DISPPARAMS __RPC_FAR *pDispParams,
/* [out] */ VARIANT __RPC_FAR *pVarResult,
/* [out] */ EXCEPINFO __RPC_FAR *pExcepInfo,
/* [out] */ UINT __RPC_FAR *puArgErr);
END_INTERFACE
} _IMzObjEventsVtbl;
interface _IMzObjEvents
{
CONST_VTBL struct _IMzObjEventsVtbl __RPC_FAR *lpVtbl;
};
#ifdef COBJMACROS
#define _IMzObjEvents_QueryInterface(This,riid,ppvObject) \
(This)->lpVtbl -> QueryInterface(This,riid,ppvObject)
#define _IMzObjEvents_AddRef(This) \
(This)->lpVtbl -> AddRef(This)
#define _IMzObjEvents_Release(This) \
(This)->lpVtbl -> Release(This)
#define _IMzObjEvents_GetTypeInfoCount(This,pctinfo) \
(This)->lpVtbl -> GetTypeInfoCount(This,pctinfo)
#define _IMzObjEvents_GetTypeInfo(This,iTInfo,lcid,ppTInfo) \
(This)->lpVtbl -> GetTypeInfo(This,iTInfo,lcid,ppTInfo)
#define _IMzObjEvents_GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId) \
(This)->lpVtbl -> GetIDsOfNames(This,riid,rgszNames,cNames,lcid,rgDispId)
#define _IMzObjEvents_Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr) \
(This)->lpVtbl -> Invoke(This,dispIdMember,riid,lcid,wFlags,pDispParams,pVarResult,pExcepInfo,puArgErr)
#endif /* COBJMACROS */
#endif /* C style interface */
#endif /* ___IMzObjEvents_DISPINTERFACE_DEFINED__ */
EXTERN_C const CLSID CLSID_MzObj;
#ifdef __cplusplus
class DECLSPEC_UUID("A3B0AF9E-2AB0-11D4-B6D2-0060089002FE")
MzObj;
#endif
#endif /* __MZCOMLib_LIBRARY_DEFINED__ */
/* Additional Prototypes for ALL interfaces */
unsigned long __RPC_USER BSTR_UserSize( unsigned long __RPC_FAR *, unsigned long , BSTR __RPC_FAR * );
unsigned char __RPC_FAR * __RPC_USER BSTR_UserMarshal( unsigned long __RPC_FAR *, unsigned char __RPC_FAR *, BSTR __RPC_FAR * );
unsigned char __RPC_FAR * __RPC_USER BSTR_UserUnmarshal(unsigned long __RPC_FAR *, unsigned char __RPC_FAR *, BSTR __RPC_FAR * );
void __RPC_USER BSTR_UserFree( unsigned long __RPC_FAR *, BSTR __RPC_FAR * );
/* end of Additional Prototypes */
#ifdef __cplusplus
}
#endif
#endif

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

@ -33,51 +33,46 @@ RSC=rc.exe
OUTDIR=.\Debug
INTDIR=.\Debug
# Begin Custom Macros
OutDir=.\Debug
# End Custom Macros
ALL : "$(OUTDIR)\MzCOM.exe" ".\Debug\regsvr32.trg"
ALL : "..\..\..\collects\mzcom\mzcom.exe" ".\Debug\regsvr32.trg"
CLEAN :
-@erase "$(INTDIR)\mzcom.obj"
-@erase "$(INTDIR)\mzcom.res"
-@erase "$(INTDIR)\mzcom.tlb"
-@erase "$(INTDIR)\mzobj.obj"
-@erase "$(INTDIR)\stdafx.obj"
-@erase "$(INTDIR)\vc60.idb"
-@erase "$(INTDIR)\vc60.pdb"
-@erase "$(OUTDIR)\MzCOM.exe"
-@erase "$(OUTDIR)\MzCOM.ilk"
-@erase "$(OUTDIR)\MzCOM.pdb"
-@erase "$(OUTDIR)\mzcom.pdb"
-@erase "..\..\..\collects\mzcom\mzcom.exe"
-@erase "..\..\..\collects\mzcom\mzcom.ilk"
-@erase ".\mzcom.tlb"
-@erase ".\Debug\regsvr32.trg"
"$(OUTDIR)" :
if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"
CPP_PROJ=/nologo /MT /W3 /Gm /ZI /Od /I "..\..\..\collects\mzscheme\include" /I "..\..\mzcom" /I "." /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /Fp"$(INTDIR)\MzCOM.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /GZ /c
CPP_PROJ=/nologo /MTd /W3 /Gm /ZI /Od /I "..\..\..\collects\mzscheme\include" /I "..\..\mzcom" /I "." /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /Fp"$(INTDIR)\MzCOM.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /GZ /c
RSC_PROJ=/l 0x409 /fo"$(INTDIR)\mzcom.res" /i ".\..\mzcom" /d "_DEBUG"
BSC32=bscmake.exe
BSC32_FLAGS=/nologo /o"$(OUTDIR)\MzCOM.bsc"
BSC32_SBRS= \
LINK32=link.exe
LINK32_FLAGS=libcmtd.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib wsock32.lib mzsrc.lib gc.lib /nologo /subsystem:windows /incremental:yes /pdb:"$(OUTDIR)\MzCOM.pdb" /debug /machine:I386 /nodefaultlib:"libcmt.lib" /out:"$(OUTDIR)\MzCOM.exe" /pdbtype:sept /libpath:"..\mzsrc\Release" /libpath:"..\gc\Release"
LINK32_FLAGS=libcmtd.lib kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib wsock32.lib mzsrc.lib gc.lib /nologo /subsystem:windows /incremental:yes /pdb:"$(OUTDIR)\mzcom.pdb" /debug /machine:I386 /nodefaultlib:"libcmt.lib" /out:"../../../collects/mzcom/mzcom.exe" /pdbtype:sept /libpath:"..\mzsrc\Debug" /libpath:"..\gc\Debug"
LINK32_OBJS= \
"$(INTDIR)\mzcom.obj" \
"$(INTDIR)\mzobj.obj" \
"$(INTDIR)\stdafx.obj" \
"$(INTDIR)\mzcom.res"
"$(OUTDIR)\MzCOM.exe" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS)
"..\..\..\collects\mzcom\mzcom.exe" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS)
$(LINK32) @<<
$(LINK32_FLAGS) $(LINK32_OBJS)
<<
OutDir=.\Debug
TargetPath=.\Debug\MzCOM.exe
InputPath=.\Debug\MzCOM.exe
TargetPath=\plt\collects\mzcom\mzcom.exe
InputPath=\plt\collects\mzcom\mzcom.exe
SOURCE="$(InputPath)"
"$(OUTDIR)\regsvr32.trg" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
@ -93,48 +88,43 @@ SOURCE="$(InputPath)"
OUTDIR=.\Release
INTDIR=.\Release
# Begin Custom Macros
OutDir=.\Release
# End Custom Macros
ALL : "$(OUTDIR)\MzCOM.exe" "$(OUTDIR)\mzcom.tlb" ".\Release\regsvr32.trg"
ALL : "..\..\..\collects\mzcom\mzcom.exe" ".\Release\regsvr32.trg"
CLEAN :
-@erase "$(INTDIR)\mzcom.obj"
-@erase "$(INTDIR)\mzcom.res"
-@erase "$(INTDIR)\stdafx.obj"
-@erase "$(INTDIR)\vc60.idb"
-@erase "$(OUTDIR)\MzCOM.exe"
-@erase ".\Release\mzcom.tlb"
-@erase "..\..\..\collects\mzcom\mzcom.exe"
-@erase ".\mzcom.tlb"
-@erase ".\Release\mzobj.obj"
-@erase ".\Release\regsvr32.trg"
"$(OUTDIR)" :
if not exist "$(OUTDIR)/$(NULL)" mkdir "$(OUTDIR)"
CPP_PROJ=/nologo /MT /W3 /O1 /I "..\..\..\collects\mzscheme\include" /I "..\..\mzcom" /I "." /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /Fp"$(INTDIR)\MzCOM.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /c
CPP_PROJ=/nologo /MT /W3 /O1 /I "..\..\mzcom" /I "." /I "..\..\..\collects\mzscheme\include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /Fp"$(INTDIR)\MzCOM.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /c
RSC_PROJ=/l 0x409 /fo"$(INTDIR)\mzcom.res" /i "..\..\mzcom" /d "NDEBUG"
BSC32=bscmake.exe
BSC32_FLAGS=/nologo /o"$(OUTDIR)\MzCOM.bsc"
BSC32_SBRS= \
LINK32=link.exe
LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib wsock32.lib mzsrc.lib gc.lib /nologo /subsystem:windows /incremental:no /pdb:"$(OUTDIR)\MzCOM.pdb" /machine:I386 /out:"$(OUTDIR)\MzCOM.exe" /libpath:"..\mzsrc\Release" /libpath:"..\gc\Release"
LINK32_FLAGS=kernel32.lib user32.lib gdi32.lib winspool.lib comdlg32.lib advapi32.lib shell32.lib ole32.lib oleaut32.lib uuid.lib odbc32.lib odbccp32.lib wsock32.lib mzsrc.lib gc.lib /nologo /subsystem:windows /incremental:no /pdb:"$(OUTDIR)\mzcom.pdb" /machine:I386 /out:"../../../collects/mzcom/mzcom.exe" /libpath:"..\mzsrc\Release" /libpath:"..\gc\Release"
LINK32_OBJS= \
"$(INTDIR)\mzcom.obj" \
".\Release\mzobj.obj" \
"$(INTDIR)\stdafx.obj" \
"$(INTDIR)\mzcom.res"
"$(OUTDIR)\MzCOM.exe" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS)
"..\..\..\collects\mzcom\mzcom.exe" : "$(OUTDIR)" $(DEF_FILE) $(LINK32_OBJS)
$(LINK32) @<<
$(LINK32_FLAGS) $(LINK32_OBJS)
<<
OutDir=.\Release
TargetPath=.\Release\MzCOM.exe
InputPath=.\Release\MzCOM.exe
TargetPath=\plt\collects\mzcom\mzcom.exe
InputPath=\plt\collects\mzcom\mzcom.exe
SOURCE="$(InputPath)"
"$(OUTDIR)\regsvr32.trg" : $(SOURCE) "$(INTDIR)" "$(OUTDIR)"
@ -194,7 +184,7 @@ SOURCE=..\..\mzcom\mzcom.cxx
!IF "$(CFG)" == "MzCOM - Win32 Debug"
CPP_SWITCHES=/nologo /MT /W3 /Gm /ZI /Od /I "..\..\..\collects\mzscheme\include" /I "..\..\mzcom" /I "." /I "../../mzscheme/include ../worksp/mzcom" /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /Fp"$(INTDIR)\MzCOM.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /GZ /c
CPP_SWITCHES=/nologo /MTd /W3 /Gm /ZI /Od /I "..\..\..\collects\mzscheme\include" /I "..\..\mzcom" /I "." /I "../../mzscheme/include ../worksp/mzcom" /D "WIN32" /D "_DEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /Fp"$(INTDIR)\MzCOM.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /GZ /c
"$(INTDIR)\mzcom.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) @<<
@ -204,7 +194,7 @@ CPP_SWITCHES=/nologo /MT /W3 /Gm /ZI /Od /I "..\..\..\collects\mzscheme\include"
!ELSEIF "$(CFG)" == "MzCOM - Win32 Release"
CPP_SWITCHES=/nologo /MT /W3 /O1 /I "..\..\..\collects\mzscheme\include" /I "..\..\mzcom" /I "." /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /Fp"$(INTDIR)\MzCOM.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /c
CPP_SWITCHES=/nologo /MT /W3 /O1 /I "..\..\mzcom" /I "." /I "..\..\..\collects\mzscheme\include" /D "WIN32" /D "NDEBUG" /D "_WINDOWS" /D "_MBCS" /D "_ATL_STATIC_REGISTRY" /Fp"$(INTDIR)\MzCOM.pch" /YX /Fo"$(INTDIR)\\" /Fd"$(INTDIR)\\" /FD /c
"$(INTDIR)\mzcom.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) @<<
@ -218,9 +208,9 @@ SOURCE=..\..\mzcom\mzcom.idl
!IF "$(CFG)" == "MzCOM - Win32 Debug"
MTL_SWITCHES=/tlb "$(OUTDIR)\mzcom.tlb"
MTL_SWITCHES=/tlb "./mzcom.tlb"
"$(INTDIR)\mzcom.tlb" : $(SOURCE) "$(INTDIR)"
".\mzcom.tlb" : $(SOURCE) "$(INTDIR)"
$(MTL) @<<
$(MTL_SWITCHES) $(SOURCE)
<<
@ -228,9 +218,9 @@ MTL_SWITCHES=/tlb "$(OUTDIR)\mzcom.tlb"
!ELSEIF "$(CFG)" == "MzCOM - Win32 Release"
MTL_SWITCHES=/tlb "$(OUTDIR)\mzcom.tlb"
MTL_SWITCHES=/tlb "./mzcom.tlb"
"$(INTDIR)\mzcom.tlb" : $(SOURCE)
".\mzcom.tlb" : $(SOURCE)
$(MTL) @<<
$(MTL_SWITCHES) $(SOURCE)
<<
@ -256,15 +246,9 @@ SOURCE=..\..\mzcom\mzobj.cxx
!ENDIF
SOURCE=..\..\mzcom\stdafx.cxx
"$(INTDIR)\stdafx.obj" : $(SOURCE) "$(INTDIR)"
$(CPP) $(CPP_PROJ) $(SOURCE)
SOURCE=.\mzcom.rc
"$(INTDIR)\mzcom.res" : $(SOURCE) "$(INTDIR)" "$(INTDIR)\mzcom.tlb"
"$(INTDIR)\mzcom.res" : $(SOURCE) "$(INTDIR)" ".\mzcom.tlb"
$(RSC) $(RSC_PROJ) $(SOURCE)

21
src/worksp/mzcom/mzcom.rc
View File

@ -68,17 +68,21 @@ VS_VERSION_INFO VERSIONINFO
BEGIN
BLOCK "StringFileInfo"
BEGIN
BLOCK "040904B0"
BLOCK "040904b0"
BEGIN
VALUE "Comments", "\0"
VALUE "CompanyName", "\0"
VALUE "FileDescription", "MzCOM Module\0"
VALUE "FileVersion", "1, 0, 0, 1\0"
VALUE "InternalName", "MzCOM\0"
VALUE "LegalCopyright", "Copyright 2000 PLT (Paul Steckler)\0"
VALUE "LegalTrademarks", "\0"
VALUE "OLESelfRegister", "\0"
VALUE "OriginalFilename", "MzCOM.EXE\0"
VALUE "PrivateBuild", "\0"
VALUE "ProductName", "MzCOM Module\0"
VALUE "ProductVersion", "102, 0, 0, 1\0"
VALUE "OLESelfRegister", "\0"
VALUE "SpecialBuild", "\0"
END
END
BLOCK "VarFileInfo"
@ -95,7 +99,7 @@ END
// REGISTRY
//
IDR_MzCOM REGISTRY MOVEABLE PURE "MzCOM.rgs"
IDR_MZCOM REGISTRY MOVEABLE PURE "MzCOM.rgs"
IDR_MZOBJ REGISTRY DISCARDABLE "MzObj.rgs"
/////////////////////////////////////////////////////////////////////////////
@ -163,3 +167,14 @@ END
/////////////////////////////////////////////////////////////////////////////
#ifndef APSTUDIO_INVOKED
/////////////////////////////////////////////////////////////////////////////
//
// Generated from the TEXTINCLUDE 3 resource.
//
1 TYPELIB "MzCOM.tlb"
/////////////////////////////////////////////////////////////////////////////
#endif // not APSTUDIO_INVOKED

11
src/worksp/mzcom/mzcom.rgs Normal file
View File

@ -0,0 +1,11 @@
HKCR
{
NoRemove AppID
{
{A604CB9D-2AB5-11D4-B6D3-0060089002FE} = s 'MzCOM'
'MzCOM.EXE'
{
val AppID = s {A604CB9D-2AB5-11D4-B6D3-0060089002FE}
}
}
}

34
src/wxcommon/PSDC.cxx
View File

@ -297,9 +297,11 @@ Bool wxPostScriptDC::Create(Bool interactive)
landscape = 1;
else
landscape = 0;
wxThePrintSetupData->GetMargin(&paper_margin_x, &paper_margin_y);
} else {
paper_x = paper_y = 0;
paper_x_scale = paper_y_scale = 1;
paper_margin_x = paper_margin_y = 0;
landscape = 0;
}
@ -311,11 +313,14 @@ Bool wxPostScriptDC::Create(Bool interactive)
paper_h = tmp;
}
paper_w -= (paper_margin_x * 2);
paper_h -= (paper_margin_y * 2);
paper_w /= paper_x_scale;
if (!paper_w)
if (paper_w <= 0)
paper_w = 1;
paper_h /= paper_y_scale;
if (!paper_h)
if (paper_h <= 0)
paper_h = 1;
return ok;
@ -1313,7 +1318,7 @@ void wxPostScriptDC::TryColour(wxColour *src, wxColour *dest)
else
dest->Set(0, 0, 0);
} else
*dest = *src;
dest->CopyFrom(src);
}
static const char *wxPostScriptHeaderEllipse = "\
@ -1413,15 +1418,15 @@ void wxPostScriptDC::EndDoc (void)
// coordinate system, thus we have to convert the values.
// If we're landscape, our sense of "x" and "y" is reversed.
if (landscape) {
llx = min_y * paper_y_scale + paper_y;
lly = min_x * paper_x_scale + paper_x;
urx = max_y * paper_y_scale + paper_y;
ury = max_x * paper_x_scale + paper_x;
llx = min_y * paper_y_scale + paper_y + paper_margin_y;
lly = min_x * paper_x_scale + paper_x + paper_margin_x;
urx = max_y * paper_y_scale + paper_y + paper_margin_y;
ury = max_x * paper_x_scale + paper_x + paper_margin_x;
} else {
llx = min_x * paper_x_scale + paper_x;
lly = paper_h * paper_y_scale - (max_y * paper_y_scale) + paper_y;
urx = max_x * paper_x_scale + paper_x;
ury = paper_h * paper_y_scale - (min_y * paper_y_scale) + paper_y;
llx = min_x * paper_x_scale + paper_x + paper_margin_x;
lly = paper_h * paper_y_scale - (max_y * paper_y_scale) + paper_y + paper_margin_y;
urx = max_x * paper_x_scale + paper_x + paper_margin_x;
ury = paper_h * paper_y_scale - (min_y * paper_y_scale) + paper_y + paper_margin_y;
}
// The Adobe specifications call for integers; we round as to make
@ -1486,8 +1491,8 @@ void wxPostScriptDC::StartPage (void)
return;
pstream->Out("%%Page: "); pstream->Out(page_number++); pstream->Out("\n");
pstream->Out((paper_x + (landscape ? (paper_h * paper_y_scale) : 0)));
pstream->Out(" "); pstream->Out(paper_y); pstream->Out(" translate\n");
pstream->Out((paper_x + paper_margin_x + (landscape ? (paper_h * paper_y_scale) : 0)));
pstream->Out(" "); pstream->Out(paper_y + paper_margin_y); pstream->Out(" translate\n");
if (landscape) {
pstream->Out(paper_y_scale); pstream->Out(" "); pstream->Out(paper_x_scale); pstream->Out(" scale\n");
pstream->Out("90 rotate\n");
@ -2077,7 +2082,8 @@ wxPrintSetupData::wxPrintSetupData(void)
print_colour = TRUE;
print_level_2 = TRUE;
printer_file = NULL;
emargin_v = emargin_h = 36;
emargin_v = emargin_h = 20;
ps_margin_v = ps_margin_h = 16;
}
wxPrintSetupData::~wxPrintSetupData(void)

6
src/wxcommon/PSDC.h
View File

@ -63,6 +63,7 @@ class wxPostScriptDC: public wxDC
float clipx, clipy, clipw, cliph;
float paper_x, paper_y, paper_w, paper_h, paper_x_scale, paper_y_scale;
float paper_margin_x, paper_margin_y;
Bool landscape, resetFont, level2ok;
char *afm_path;
@ -217,6 +218,8 @@ public:
{ print_level_2 = l2; }
void SetEditorMargin(long x, long y)
{ emargin_h = x; emargin_v = y; }
void SetMargin(float x, float y)
{ ps_margin_h = x; ps_margin_v = y; }
inline char *GetPrinterCommand(void)
{ return printer_command; }
@ -244,6 +247,8 @@ public:
{ return print_level_2; }
void GetEditorMargin(long *x, long *y)
{ *x = emargin_h; *y = emargin_v; }
void GetMargin(float *x, float *y)
{ *x = ps_margin_h; *y = ps_margin_v; }
private:
friend class wxPostScriptDC;
@ -263,6 +268,7 @@ private:
Bool print_colour;
Bool print_level_2;
long emargin_h, emargin_v;
float ps_margin_h, ps_margin_v;
};
extern wxPrintSetupData *wxGetThePrintSetupData();