diff --git a/collects/mzlib/traceldr.ss b/collects/mzlib/traceldr.ss deleted file mode 100644 index 542cb0f1..00000000 --- a/collects/mzlib/traceldr.ss +++ /dev/null @@ -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))))) - diff --git a/collects/mzlib/transcr.ss b/collects/mzlib/transcr.ss deleted file mode 100644 index 94061ab1..00000000 --- a/collects/mzlib/transcr.ss +++ /dev/null @@ -1,8 +0,0 @@ - -(require-library "transcru.ss") - -(begin-elaboration-time - (require-library "invoke.ss")) - -(define-values/invoke-unit/sig mzlib:transcript^ - mzlib:transcript@) diff --git a/collects/mzscheme/include/schvers.h b/collects/mzscheme/include/schvers.h index 79f7b6c1..5ef8fecf 100644 --- a/collects/mzscheme/include/schvers.h +++ b/collects/mzscheme/include/schvers.h @@ -5,4 +5,4 @@ # define SPECIAL_TAG "" #endif -#define VERSION "102/13" SPECIAL_TAG +#define VERSION "102" SPECIAL_TAG diff --git a/collects/mzscheme/include/sconfig.h b/collects/mzscheme/include/sconfig.h index 609e044d..e0e79056 100644 --- a/collects/mzscheme/include/sconfig.h +++ b/collects/mzscheme/include/sconfig.h @@ -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 */ /***********************/ diff --git a/collects/srpersist/lib/win32/i386/srpmain.dll b/collects/srpersist/lib/win32/i386/srpmain.dll index 9b9dc211..0f2cdfef 100644 Binary files a/collects/srpersist/lib/win32/i386/srpmain.dll and b/collects/srpersist/lib/win32/i386/srpmain.dll differ diff --git a/collects/stepper/annotater.ss b/collects/stepper/annotater.ss index 08c78127..6d092f87 100644 --- a/collects/stepper/annotater.ss +++ b/collects/stepper/annotater.ss @@ -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)] diff --git a/collects/stepper/doc.txt b/collects/stepper/doc.txt index 7829a9f7..caaabc93 100644 --- a/collects/stepper/doc.txt +++ b/collects/stepper/doc.txt @@ -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. diff --git a/collects/stepper/marks.ss b/collects/stepper/marks.ss index 85daf4d4..c9505695 100644 --- a/collects/stepper/marks.ss +++ b/collects/stepper/marks.ss @@ -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)]))))) diff --git a/collects/stepper/model.ss b/collects/stepper/model.ss index 9ada3efe..98e1f588 100644 --- a/collects/stepper/model.ss +++ b/collects/stepper/model.ss @@ -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 diff --git a/collects/stepper/reconstructr.ss b/collects/stepper/reconstructr.ss index 9c0e907d..40a00f4a 100644 --- a/collects/stepper/reconstructr.ss +++ b/collects/stepper/reconstructr.ss @@ -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)))) ) diff --git a/collects/stepper/sig.ss b/collects/stepper/sig.ss index b4dc61d6..e69dd278 100644 --- a/collects/stepper/sig.ss +++ b/collects/stepper/sig.ss @@ -46,7 +46,7 @@ mark-binding-varref expose-mark display-mark - find-var-binding)) + lookup-var-binding)) (define-signature stepper:client-procs^ (read-getter diff --git a/collects/stepper/utils.ss b/collects/stepper/utils.ss index b73fbad2..ced7662c 100644 --- a/collects/stepper/utils.ss +++ b/collects/stepper/utils.ss @@ -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)) diff --git a/collects/stepper/view-controller.ss b/collects/stepper/view-controller.ss index fcce2515..8daff856 100644 --- a/collects/stepper/view-controller.ss +++ b/collects/stepper/view-controller.ss @@ -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))))) \ No newline at end of file + (stepper-wrapper frame settings))))) diff --git a/collects/zodiac/doc.txt b/collects/zodiac/doc.txt index 69498350..40455fc1 100644 --- a/collects/zodiac/doc.txt +++ b/collects/zodiac/doc.txt @@ -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: + + : + + 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 diff --git a/collects/zodiac/invoke.ss b/collects/zodiac/invoke.ss index 9a174891..e3fa1be8 100644 --- a/collects/zodiac/invoke.ss +++ b/collects/zodiac/invoke.ss @@ -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) diff --git a/collects/zodiac/link.ss b/collects/zodiac/link.ss index b13f4ddb..6a83aca9 100644 --- a/collects/zodiac/link.ss +++ b/collects/zodiac/link.ss @@ -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))) diff --git a/collects/zodiac/link2.ss b/collects/zodiac/link2.ss new file mode 100644 index 00000000..d36be821 --- /dev/null +++ b/collects/zodiac/link2.ss @@ -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))) diff --git a/collects/zodiac/quasi.ss b/collects/zodiac/quasi.ss index 76eaefa6..466634e9 100644 --- a/collects/zodiac/quasi.ss +++ b/collects/zodiac/quasi.ss @@ -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) diff --git a/collects/zodiac/reader.ss b/collects/zodiac/reader.ss index 31eaf5d6..85ab7390 100644 --- a/collects/zodiac/reader.ss +++ b/collects/zodiac/reader.ss @@ -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. diff --git a/collects/zodiac/scanner.ss b/collects/zodiac/scanner.ss index 094a8dec..157a1918 100644 --- a/collects/zodiac/scanner.ss +++ b/collects/zodiac/scanner.ss @@ -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. diff --git a/collects/zodiac/scanparm.ss b/collects/zodiac/scanparm.ss index 266bb6da..f174056d 100644 --- a/collects/zodiac/scanparm.ss +++ b/collects/zodiac/scanparm.ss @@ -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 diff --git a/collects/zodiac/scm-core.ss b/collects/zodiac/scm-core.ss index 84bb6a25..610bc2a2 100644 --- a/collects/zodiac/scm-core.ss +++ b/collects/zodiac/scm-core.ss @@ -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)) diff --git a/collects/zodiac/scm-hanc.ss b/collects/zodiac/scm-hanc.ss index f71cc282..5482338f 100644 --- a/collects/zodiac/scm-hanc.ss +++ b/collects/zodiac/scm-hanc.ss @@ -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)) diff --git a/collects/zodiac/scm-main.ss b/collects/zodiac/scm-main.ss index a9ac7202..d93ecccf 100644 --- a/collects/zodiac/scm-main.ss +++ b/collects/zodiac/scm-main.ss @@ -1,4 +1,4 @@ -; $Id: scm-main.ss,v 1.204 2000/03/05 21:15:52 clements Exp $ +; $Id: scm-main.ss,v 1.205 2000/04/30 22:31:01 clements Exp $ (unit/sig zodiac:scheme-main^ (import zodiac:misc^ zodiac:structures^ @@ -190,7 +190,7 @@ '(expr))) (define parse-expr - (lambda (who expr bodies env attributes vocab source) + (lambda (who-str kwd:who expr bodies env attributes vocab source) ;; Do internal definition parsing (let*-values (((internal-define-vocab) @@ -199,12 +199,16 @@ ((definitions parsed-first-term rest-terms bindings) (let loop ((seen null) (rest bodies) (prev #f) (bindings null) (vars-seen null)) (if (null? rest) - (static-error prev - (if (null? seen) - (static-error expr (format "Malformed ~a" who)) - (if (null? (cdr seen)) - "Internal definition not followed by expression" - "Internal definitions not followed by expression"))) + (static-error + "internal definition" 'term:internal-def-not-foll-by-expr + prev + (if (null? seen) + (static-error + who-str kwd:who + expr "malformed expression") + (if (null? (cdr seen)) + "internal definition not followed by expression" + "internal definitions not followed by expression"))) (let ((first (car rest))) (let* ((internal? (get-internal-define-status attributes)) (_ (set-internal-define-status attributes #t)) @@ -222,9 +226,12 @@ (lambda (v) (when (memq (z:read-object v) vars-seen) - (static-error v - "Duplicate internally defined identifier ~a" - (z:read-object v)))) + (static-error + "internal definition" + 'term:duplicate-internal-def + v + "duplicate definition for identifier ~a" + (z:read-object v)))) def-vars) (extend-env new-vars+marks env) (loop (cons e-first seen) @@ -283,7 +290,9 @@ (define (make-lambda-error-micro who) (lambda (expr env attributes vocab) - (static-error expr (format "~a allowed only in a definition" who)))) + (static-error + "lambda" 'term:case/lambda-only-in-def + expr "allowed only in a definition"))) (define (make-case-lambda-micro begin? arglist-decls-vocab) (let* ((kwd `(else)) @@ -315,7 +324,8 @@ (as-nested attributes (lambda () - (parse-expr "case-lambda" expr body env attributes vocab expr)))) + (parse-expr "case-lambda" 'kwd:case-lambda + expr body env attributes vocab expr)))) (retract-env (map car arg-vars+marks) env)))) args bodies))) (create-case-lambda-form @@ -323,7 +333,9 @@ (map cdr arglists+exprs) expr))))) (else - (static-error expr "Malformed case-lambda")))))) + (static-error + "case-lambda" 'kwd:case-lambda + expr "malformed expression")))))) (define beginner+lambda-vocabulary (create-vocabulary 'beginner+lambda-vocabulary @@ -359,7 +371,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 lambda"))))) + (static-error + "lambda" 'kwd:lambda + expr "malformed expression"))))) (add-primitivized-macro-form 'lambda @@ -394,7 +408,9 @@ (m&e (pat:make-match&env in-pattern kwd))) (lambda (expr env attributes vocab) (unless (at-internal-define? attributes) - (static-error expr "Invalid position for internal definition")) + (static-error + "internal definition" 'term:define-internal-invalid-posn + expr "invalid position")) (cond ((pat:match-against m&e expr env) => @@ -406,14 +422,17 @@ (let ((r (resolve var env vocab))) (when (or (micro-resolution? r) (macro-resolution? r)) - (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) (make-internal-definition vars val)))) (else (static-error expr - "Malformed internal definition")))))) + "internal definition" 'kwd:define + "malformed definition")))))) (add-primitivized-micro-form 'begin internal-define-vocab-delta (let* ((kwd '()) @@ -430,8 +449,9 @@ (let* ((exprs (pat:pexpand '(expr ...) p-env kwd))) (make-internal-begin exprs)))) (else - (static-error expr - "Malformed internal begin"))) + (static-error + "internal begin" 'kwd:begin + expr "malformed expression"))) ;; Chain to regular begin: (begin-micro expr env attributes vocab))))) @@ -455,7 +475,9 @@ (expand-expr (car bodies) env attributes vocab))) (if (and (not top?) (null? bodies)) - (static-error expr "Malformed begin") + (static-error + "begin" 'kwd:begin + expr "malformed expression") (as-nested attributes (lambda () @@ -465,7 +487,9 @@ bodies) expr)))))))) (else - (static-error expr "Malformed begin")))))) + (static-error + "begin" 'kwd:begin + expr "malformed expression")))))) (add-primitivized-micro-form 'begin advanced-vocabulary begin-micro) (add-primitivized-micro-form 'begin scheme-vocabulary begin-micro) @@ -497,7 +521,9 @@ (cons first rest) expr))))))) (else - (static-error expr "Malformed begin0")))))) + (static-error + "begin0" 'kwd:begin0 + expr "malformed expression")))))) (add-primitivized-micro-form 'begin0 advanced-vocabulary begin0-micro) (add-primitivized-micro-form 'begin0 scheme-vocabulary begin0-micro) @@ -514,7 +540,9 @@ => (lambda (p-env) (unless one-arm-ok? - (static-error expr "If must have an else clause")) + (static-error + "if" 'term:if-must-have-else + expr "must have an else clause")) (as-nested attributes (lambda () @@ -544,7 +572,9 @@ env attributes vocab))) (create-if-form test-exp then-exp else-exp expr)))))) (else - (static-error expr "Malformed if")))))) + (static-error + "if" 'kwd:if + expr "malformed expression")))))) (add-primitivized-micro-form 'if beginner-vocabulary (make-if-micro #f)) (add-primitivized-micro-form 'if advanced-vocabulary (make-if-micro #t)) @@ -573,7 +603,9 @@ env attributes vocab))) (create-with-continuation-mark-form key-exp val-exp body-exp expr)))))) (else - (static-error expr "Malformed with-continuation-mark")))))) + (static-error + "with-continuation-mark" 'kwd:with-continuation-mark + expr "malformed expression")))))) (add-primitivized-micro-form 'with-continuation-mark scheme-vocabulary with-continuation-mark-micro) @@ -606,16 +638,21 @@ (null? (cddr v))) (loop (cadr v) (string-append "'" prefix))] [else (values v prefix)]))]) - (static-error expr "Misuse of quote: '~a~s is not a symbol" prefix v))) - (static-error expr "Malformed quote"))) - (static-error expr "Malformed quote")))) + (static-error + "quote" 'term:quote-not-on-symbol + expr "misused: '~a~s is not a symbol" prefix v))) + (static-error + "quote" 'kwd:quote + expr "malformed expression"))) + (static-error + "quote" 'kwd:quote + expr "malformed expression")))) (add-primitivized-micro-form 'quote beginner-vocabulary (make-quote-micro #f)) (add-primitivized-micro-form 'quote intermediate-vocabulary (make-quote-micro #t)) (add-primitivized-micro-form 'quote scheme-vocabulary (make-quote-micro #t)) - ;; This second variable is no longer being used - (define (make-set!-micro dont-mutate-lexical-varrefs?) + (define (make-set!-micro dont-mutate-lambda-varrefs?) (let* ((kwd '()) (in-pattern `(_ var val)) (m&e (pat:make-match&env in-pattern kwd))) @@ -632,8 +669,15 @@ (expand-expr (pat:pexpand 'val p-env kwd) env attributes vocab))))) + (when (and (lambda-varref? id-expr) + dont-mutate-lambda-varrefs?) + (static-error + "set!" 'term:set!-no-mutate-lambda-bound + expr "cannot mutate procedure-bound identifiers")) (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! advanced-vocabulary @@ -667,17 +711,19 @@ (make-origin 'micro expr)) env attributes vocab))))) (else - (static-error expr "Malformed set!-values")))))) + (static-error + "set!-values" 'kwd:set!-values + expr "malformed expression")))))) (add-primitivized-micro-form 'set!-values advanced-vocabulary set!-values-micro) (add-primitivized-micro-form 'set!-values scheme-vocabulary set!-values-micro) (define (make-local-extract-vocab) (create-vocabulary 'local-extract-vocab #f - "Invalid expression for local clause" - "Invalid expression for local clause" - "Invalid expression for local clause" - "Invalid expression for local clause")) + "invalid expression for local clause" + "invalid expression for local clause" + "invalid expression for local clause" + "invalid expression for local clause")) (define nobegin-local-extract-vocab (make-local-extract-vocab)) (define full-local-extract-vocab (make-local-extract-vocab)) @@ -721,7 +767,9 @@ (syntax-car expr)) (set-top-level-status attributes top-level?) (set-internal-define-status attributes internal?)))) - (static-error expr "Malformed local")))))) + (static-error + "local" 'kwd:local + expr "malformed expression")))))) (add-primitivized-micro-form 'local @@ -755,13 +803,25 @@ (out-pattern-1 `(define-values (fun) (lambda args ,@(get-expr-pattern begin?)))) (in-pattern-2 `(_ var val)) (out-pattern-2 `(define-values (var) val)) + (in-pattern-3 `(_ (fun . args) b0 b1 ...)) ;; for error reporting + (in-pattern-4 `(_ (fun . args))) ;; for error reporting (m&e-1 (pat:make-match&env in-pattern-1 kwd)) - (m&e-2 (pat:make-match&env in-pattern-2 kwd))) + (m&e-2 (pat:make-match&env in-pattern-2 kwd)) + (m&e-3 (pat:make-match&env in-pattern-3 kwd)) + (m&e-4 (pat:make-match&env in-pattern-4 kwd))) (values (lambda (expr env) (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env) - (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) - (static-error expr "Malformed define"))) + (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) + (or (and (not begin?) + (or (pat:match-against m&e-3 expr env) + (pat:match-against m&e-4 expr env)) + (static-error + "define" 'term:define-illegal-implicit-begin + expr "body must have exactly one expression")) + (static-error + "define" 'kwd:define + expr "malformed definition")))) (lambda (expr env attributes vocab) (cond ((pat:match-against m&e-1 expr env) @@ -780,7 +840,9 @@ (valid-syntactic-id? var) (cons (list var) val)))) (else - (static-error expr "Malformed define in local clause"))))))) + (static-error + "local define" 'kwd:define + expr "malformed definition"))))))) (define-values (nobegin-define-form nobegin-local-define-form) (make-define-forms #f)) @@ -805,10 +867,15 @@ (lambda (internal-ok? handler) (lambda (expr env attributes vocab) (unless (at-top-level? attributes) - (static-error expr + (static-error + "definition" (if internal-ok? - "Invalid position for internal definition" - "Invalid definition: must be at the top level"))) + 'term:invalid-intl-defn-posn + 'term:def-not-at-top-level) + expr + (if internal-ok? + "invalid position for internal definition" + "must be at the top level"))) (cond ((pat:match-against m&e-1 expr env) => @@ -823,8 +890,10 @@ (handler expr env attributes vocab vars val))))) out))) - (else (static-error expr - "Malformed define-values"))))))) + (else (static-error + "define-values" 'kwd:define-values + expr + "malformed definition"))))))) (let ([make-dv-micro (lambda (internal-ok? use-beg-lambda-vocab?) (define-values-helper @@ -876,15 +945,21 @@ (let* ((type (pat:pexpand 'type tsp-env '())) (super (pat:pexpand 'super tsp-env '()))) (and (or (z:symbol? type) - (static-error type "Not an identifier")) + (static-error + "structure definition" 'term:struct-not-id + type "not an identifier")) (values type super))))) ((z:symbol? type-spec) (values type-spec #f)) (else - (static-error type-spec "Invalid specification"))) + (static-error + "super-structure definition" 'term:super-struct-invalid + type-spec "invalid specification"))) (begin (unless (z:symbol? type-spec) - (static-error type-spec "Not an identifier")) + (static-error + "super-structure definition" 'term:super-struct-not-id + type-spec "not an identifier")) (values type-spec #f)))))) (define (make-struct-micro allow-supertype?) @@ -907,7 +982,9 @@ fields expr))))) (else - (static-error expr "Malformed struct")))))) + (static-error + "struct" 'kwd:struct + expr "malformed definition")))))) (add-primitivized-micro-form 'struct beginner-vocabulary (make-struct-micro #f)) (add-primitivized-micro-form 'struct advanced-vocabulary (make-struct-micro #t)) @@ -960,7 +1037,9 @@ (handler expr env attributes vocab names struct-expr))))) (else - (static-error expr "Malformed define-struct"))))))) + (static-error + "define-struct" 'kwd:define-struct + expr "malformed definition"))))))) (let ([top-level-handler (lambda (expr env attributes vocab names struct-expr) (expand-expr @@ -993,10 +1072,14 @@ (add-primitivized-macro-form 'define-structure intermediate-vocabulary (lambda (expr env) (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error expr "Malformed define-structure")))) + (static-error + "define-structure" 'kwd:define-structure + expr "malformed definition")))) (let ([int-ds-macro (lambda (expr env) (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error expr "Malformed define-structure")))]) + (static-error + "define-structure" 'kwd:define-structure + expr "malformed definition")))]) (add-primitivized-macro-form 'define-structure nobegin-local-extract-vocab int-ds-macro) (add-primitivized-macro-form 'define-structure full-local-extract-vocab int-ds-macro))) @@ -1013,7 +1096,9 @@ (lambda (p-env) (handler expr env attributes vocab p-env))) (else - (static-error expr "Malformed let-struct"))))))) + (static-error + "let-struct" 'kwd:let-struct + expr "malformed expression"))))))) (ls-core (lambda (expr env attributes vocab p-env) (let* ((fields (pat:pexpand '(fields ...) p-env kwd)) @@ -1083,19 +1168,21 @@ (pat:extend-penv 'fun-copy fun-copy p-env) kwd)) (or (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) - (static-error expr "Malformed let"))))))) + (static-error + "let" 'kwd:let + expr "malformed expression"))))))) (add-primitivized-macro-form 'let intermediate-vocabulary (make-let-macro #f #f)) -; (add-primitivized-macro-form 'let -; advanced-vocabulary -; (make-let-macro #t #t)) + (add-primitivized-macro-form 'let + advanced-vocabulary + (make-let-macro #f #t)) (add-primitivized-macro-form 'let scheme-vocabulary (make-let-macro #t #t)) ; Turtle Macros for Robby (let ([add-patterned-macro - (lambda (formname in-pattern out-pattern) + (lambda (formname form-string kwd:form-name in-pattern out-pattern) (add-macro-form formname intermediate-vocabulary @@ -1103,15 +1190,16 @@ (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 - (format "Malformed ~a" formname)))))))]) - (add-patterned-macro 'tprompt + (static-error + form-string kwd:form-name + expr "malformed expression"))))))]) + (add-patterned-macro 'tprompt "tprompt" 'kwd:tprompt '(tprompt E ...) '(tpromptfn (lambda () E ...))) - (add-patterned-macro 'split + (add-patterned-macro 'split "split" 'kwd:split '(split E ...) '(splitfn (lambda () E ...))) - (add-patterned-macro 'split* + (add-patterned-macro 'split* "split*" 'kwd:split* '(split* E ...) '(split*fn (list (lambda () E) ...)))) @@ -1126,7 +1214,9 @@ (lambda (expr env) (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env) (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) - (static-error expr "Malformed let*"))))) + (static-error + "let*" 'kwd:let* + expr "malformed expression"))))) (add-primitivized-macro-form 'let* intermediate-vocabulary @@ -1145,31 +1235,42 @@ (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 delay"))))) + (static-error + "delay" 'kwd:delay + expr "malformed expression"))))) (add-primitivized-macro-form 'delay advanced-vocabulary delay-macro) (add-primitivized-macro-form 'delay scheme-vocabulary delay-macro) - (define time-macro - (let* ((kwd '()) - (in-pattern '(_ e0 e1 ...)) - (out-pattern '(let-values (((v cpu user gc) - (#%time-apply (lambda (dont-care) - e0 - e1 ...) - (#%cons (#%quote dont-care) #%null)))) - (#%begin - (#%printf - "cpu time: ~s real time: ~s gc time: ~s~n" - cpu user gc) - (#%apply #%values v)))) - (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 time"))))) + (define (make-time-macro begin?) + (let* ((kwd '()) + (in-pattern + (if begin? + '(_ e0 e1 ...) + '(_ e0))) + (out-pattern + `(let-values (((v cpu user gc) + (#%time-apply (lambda (dont-care) + ,@(if begin? + '(e0 e1 ...) + '(e0))) + (#%cons (#%quote dont-care) #%null)))) + (#%begin + (#%printf + "cpu time: ~s real time: ~s gc time: ~s~n" + cpu user gc) + (#%apply #%values v)))) + (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 + "time" 'kwd:time + expr "malformed expression"))))) - (add-primitivized-macro-form 'time intermediate-vocabulary time-macro) - (add-primitivized-macro-form 'time scheme-vocabulary time-macro) + (add-primitivized-macro-form 'time intermediate-vocabulary + (make-time-macro #f)) + (add-primitivized-macro-form 'time scheme-vocabulary + (make-time-macro #t)) (define break-list (lambda (elements counter) @@ -1218,12 +1319,14 @@ (cons head (loop (cdr var-lists) tail))))) expanded-vals - (parse-expr "let-values" expr body env - attributes vocab expr) + (parse-expr "let-values" 'kwd:let-values + expr body env attributes vocab expr) expr) (retract-env new-vars env)))))))) (else - (static-error expr "Malformed let-values")))))) + (static-error + "let-values" 'kwd:let-values + expr "malformed expression")))))) (add-primitivized-micro-form 'let-values intermediate-vocabulary @@ -1249,7 +1352,9 @@ (lambda (expr env) (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env) (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) - (static-error expr "Malformed let*-values"))))) + (static-error + "let*-values" 'kwd:let*-values + expr "malformed expression"))))) (add-primitivized-macro-form 'let*-values intermediate-vocabulary @@ -1305,12 +1410,15 @@ (as-nested attributes (lambda () - (parse-expr "letrec-values" expr body env attributes vocab expr))) + (parse-expr "letrec-values" 'kwd:letrec-values + expr body env attributes vocab expr))) expr)) (_ (retract-env new-vars env))) result)))) (else - (static-error expr "Malformed letrec-values")))))) + (static-error + "letrec-values" 'kwd:letrec-values + expr "malformed expression")))))) (add-primitivized-micro-form 'letrec-values intermediate-vocabulary @@ -1329,7 +1437,9 @@ (out-pattern `(letrec-values (((v) e) ...) ,@(get-expr-pattern begin?)))) (lambda (expr env) (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error expr "Malformed letrec"))))) + (static-error + "letrec" 'kwd:letrec + expr "malformed expression"))))) (add-primitivized-macro-form 'letrec intermediate-vocabulary @@ -1371,7 +1481,9 @@ (and (not one-or-zero-ok?) (pat:match-and-rewrite expr m&e-3 out-pattern-3 kwd env)) (pat:match-and-rewrite expr m&e-4 out-pattern-4 kwd env) - (static-error expr "Malformed or"))))))) + (static-error + "or" 'kwd:or + expr "malformed expression"))))))) (add-primitivized-macro-form 'or beginner-vocabulary (make-or-macro #t #f)) (add-primitivized-macro-form 'or advanced-vocabulary (make-or-macro #f #f)) @@ -1386,7 +1498,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 nor"))))) + (static-error + "nor" 'kwd:nor + expr "malformed expression"))))) (define (make-and-macro boolean-result? one-or-zero-ok?) (let* ((kwd '()) @@ -1412,7 +1526,9 @@ (and (not one-or-zero-ok?) (pat:match-and-rewrite expr m&e-3 out-pattern-3 kwd env)) (pat:match-and-rewrite expr m&e-4 out-pattern-4 kwd env) - (static-error expr "Malformed and"))))) + (static-error + "and" 'kwd:and + expr "malformed expression"))))) (add-primitivized-macro-form 'and beginner-vocabulary (make-and-macro #t #f)) (add-primitivized-macro-form 'and advanced-vocabulary (make-and-macro #f #f)) @@ -1427,7 +1543,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 nand"))))) + (static-error + "nand" 'kwd:nand + expr "malformed expression"))))) (define recur-macro (let* ((kwd '()) @@ -1436,7 +1554,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 recur"))))) + (static-error + "recur" 'kwd:recur + expr "malformed expression"))))) (add-primitivized-macro-form 'recur advanced-vocabulary recur-macro) (add-on-demand-form 'macro 'recur common-vocabulary recur-macro) @@ -1457,7 +1577,9 @@ (dup-symbol looper) p-env) kwd)))) - (static-error expr "Malformed rec")))))) + (static-error + "rec" 'kwd:rec + expr "malformed expression")))))) (add-primitivized-macro-form 'rec advanced-vocabulary rec-macro) (add-on-demand-form 'macro 'rec common-vocabulary rec-macro) @@ -1465,7 +1587,7 @@ (define-struct cond-clause (text question answer else? =>? or?)) (define (make-cond-clause-vocab) - (let([qa-error-msg "Clause is not in question-answer format"]) + (let([qa-error-msg "clause is not in question-answer format"]) (create-vocabulary 'cond-clause-vocab #f qa-error-msg ; symbol qa-error-msg ; literal @@ -1515,7 +1637,9 @@ ((pat:match-against m&e-2 expr env) => (lambda (p-env) - (static-error expr "=> not followed by exactly one receiver"))) + (static-error + "cond" 'term:cond-=>-not-foll-by-1-rcvr + expr "=> not followed by exactly one receiver"))) ((pat:match-against m&e-5 expr env) => (lambda (p-env) @@ -1527,7 +1651,9 @@ (let ((question (pat:pexpand 'question p-env kwd)) (answer (pat:pexpand get-pattern-4 p-env kwd))) (make-cond-clause expr question answer #f #f #f)))) - (else (static-error expr "Clause is not in question-answer format")))))) + (else (static-error + "cond" 'term:cond-clause-not-in-q/a-fmt + expr "clause is not in question-answer format")))))) (add-list-micro nobegin-cond-clause-vocab (make-cond-list-micro #f #f)) (add-list-micro full-cond-clause-vocab (make-cond-list-micro #t #t)) @@ -1574,7 +1700,9 @@ ((cond-clause-else? first) (if (null? rest) (cond-clause-answer first) - (static-error (cond-clause-text first) + (static-error + "cond" 'term:cond-else-only-in-last + (cond-clause-text first) "else allowed only in last position"))) ((cond-clause-or? first) `(or ,(cond-clause-question first) @@ -1588,7 +1716,9 @@ (make-origin 'micro expr)) env attributes vocab)))))) (else - (static-error expr "Malformed cond")))))) + (static-error + "cond" 'kwd:cond + expr "malformed expression")))))) (add-primitivized-micro-form 'cond beginner-vocabulary (make-cond-micro nobegin-cond-clause-vocab #f)) (add-primitivized-micro-form 'cond scheme-vocabulary (make-cond-micro full-cond-clause-vocab #t)) @@ -1621,7 +1751,9 @@ (pat:match-and-rewrite expr m&e-2 out-pattern-2-signal-error kwd-2 env)) (pat:match-and-rewrite expr m&e-3 out-pattern-3 kwd-2 env) - (static-error expr "Malformed case"))))) + (static-error + "case" 'kwd:case + expr "malformed expression"))))) (add-primitivized-macro-form 'case advanced-vocabulary case-macro) (add-primitivized-macro-form 'case scheme-vocabulary case-macro) @@ -1659,9 +1791,13 @@ out-pattern-2-signal-error kwd-2 env)) (let ((penv (pat:match-against m&e-3 expr env))) (if penv - (static-error expr "else used before last evcase branch") + (static-error + "evcase" 'kwd:evcase + expr "else used before last branch") (or (pat:match-and-rewrite expr m&e-4 out-pattern-4 kwd-4 env) - (static-error expr "Malformed evcase")))))))) + (static-error + "evcase" 'kwd:evcase + expr "malformed expression")))))))) (add-primitivized-macro-form 'evcase advanced-vocabulary evcase-macro) (add-on-demand-form 'macro 'evcase common-vocabulary evcase-macro) @@ -1673,7 +1809,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 when"))))) + (static-error + "when" 'kwd:when + expr "malformed expression"))))) (add-primitivized-macro-form 'when advanced-vocabulary when-macro) @@ -1686,26 +1824,33 @@ (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 unless"))))) + (static-error + "unless" 'kwd:unless + expr "malformed expression"))))) (add-primitivized-macro-form 'unless advanced-vocabulary unless-macro) (add-primitivized-macro-form 'unless scheme-vocabulary unless-macro) (let ((rewriter - (lambda (call/cc the-kwd kwd-text) + (lambda (call/cc the-kwd kwd-text kwd:the-kwd) (let* ((kwd '()) (in-pattern `(_ var ,@(get-expr-pattern #t))) (out-pattern `(,call/cc (lambda (var) ,@(get-expr-pattern #t)))) (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 - (string-append "Malformed " kwd-text)))))))) - (add-primitivized-macro-form 'let/cc advanced-vocabulary (rewriter '#%call/cc 'let/cc "let/cc")) - (add-primitivized-macro-form 'let/cc scheme-vocabulary (rewriter '#%call/cc 'let/cc "let/cc")) + (static-error + kwd-text kwd:the-kwd + expr "malformed expression"))))))) + (add-primitivized-macro-form 'let/cc advanced-vocabulary + (rewriter '#%call/cc 'let/cc "let/cc" 'kwd:let/cc)) + (add-primitivized-macro-form 'let/cc scheme-vocabulary + (rewriter '#%call/cc 'let/cc "let/cc" 'kwd:let/cc)) - (add-primitivized-macro-form 'let/ec advanced-vocabulary (rewriter '#%call/ec 'let/ec "let/ec")) - (add-primitivized-macro-form 'let/ec scheme-vocabulary (rewriter '#%call/ec 'let/ec "let/ec"))) + (add-primitivized-macro-form 'let/ec advanced-vocabulary + (rewriter '#%call/ec 'let/ec "let/ec" 'kwd:let/ec)) + (add-primitivized-macro-form 'let/ec scheme-vocabulary + (rewriter '#%call/ec 'let/ec "let/ec" 'kwd:let/ec))) (define do-macro (let* ((in-kwd '()) @@ -1754,8 +1899,10 @@ ,(pat:pexpand 'init p-env vis-kwd) ,(pat:pexpand 'var p-env vis-kwd)))) (else - (static-error vis - "Malformed var-init-step")))) + (static-error + "do" 'kwd:do + vis + "malformed var-init-step")))) var-init-steps))) (let ((vars (map car normalized-var-init-steps)) (inits (map cadr normalized-var-init-steps)) @@ -1772,7 +1919,9 @@ #f (make-origin 'macro expr))))))) (else - (static-error expr "Malformed do")))))) + (static-error + "do" 'kwd:do + expr "malformed expression")))))) (add-primitivized-macro-form 'do advanced-vocabulary do-macro) (add-primitivized-macro-form 'do scheme-vocabulary do-macro) @@ -1812,7 +1961,9 @@ (make-origin 'macro expr)) env attributes vocab))))) (else - (static-error expr "Malformed fluid-let")))))) + (static-error + "fluid-let" 'kwd:fluid-let + expr "malformed expression")))))) (add-primitivized-micro-form 'fluid-let advanced-vocabulary fluid-let-macro) (add-primitivized-micro-form 'fluid-let scheme-vocabulary fluid-let-macro) @@ -1842,8 +1993,9 @@ ,@(map (lambda (save pz) `(let ([x ,save]) - (set! ,save (,pz)) - (,pz x))) + (begin + (set! ,save (,pz)) + (,pz x)))) saves pzs)))) (#%dynamic-wind ,swap @@ -1853,7 +2005,9 @@ #f (make-origin 'micro expr)) env attributes vocab)) - (static-error expr "Malformed parameterize")))))) + (static-error + "parameterize" 'kwd:parameterize + expr "malformed expression")))))) (add-primitivized-micro-form 'parameterize advanced-vocabulary parameterize-micro) (add-primitivized-micro-form 'parameterize scheme-vocabulary parameterize-micro) @@ -1862,7 +2016,7 @@ (let* ((kwd '()) (in-pattern-1 `(_ () ,@(get-expr-pattern begin?))) (out-pattern-1 (if (not begin?) - 'b + 'expr `(let-values () ,@(get-expr-pattern begin?)))) (in-pattern-2 `(_ ((pred handler) ...) ,@(get-expr-pattern begin?))) (out-pattern-2 @@ -1893,7 +2047,9 @@ (lambda (expr env) (or (pat:match-and-rewrite expr m&e-1 out-pattern-1 kwd env) (pat:match-and-rewrite expr m&e-2 out-pattern-2 kwd env) - (static-error expr "Malformed with-handlers"))))) + (static-error + "with-handlers" 'kwd:with-handlers + expr "malformed expression"))))) (add-primitivized-macro-form 'with-handlers advanced-vocabulary @@ -1926,7 +2082,9 @@ (macro-handler (pat:pexpand 'macro-handler p-env kwd))) (valid-syntactic-id? macro-name) (unless (get-top-level-status attributes) - (static-error expr "Only supported at top-level")) + (static-error + "define-macro" 'kwd:define-macro + expr "only supported at top-level")) (let* ((real-name (sexp->raw macro-name))) (let ([on-demand (get-on-demand-form real-name vocab)]) (if on-demand @@ -1944,7 +2102,9 @@ 'define-macro)) (cache-table (make-hash-table))) (unless (procedure? real-handler) - (static-error expr "Expander is not a procedure")) + (static-error + "define-macro" 'kwd:define-macro + expr "expander is not a procedure")) (add-user-macro-form real-name vocab (lambda (m-expr m-env) @@ -1957,7 +2117,9 @@ '() #f (make-origin 'micro expr)) env attributes vocab))))) (else - (static-error expr "Malformed define-macro")))))) + (static-error + "define-macro" 'kwd:define-macro + expr "malformed definition")))))) (add-primitivized-micro-form 'let-macro common-vocabulary (let* ((kwd '()) @@ -1984,7 +2146,9 @@ 'let-macro)) (cache-table (make-hash-table))) (unless (procedure? real-handler) - (static-error expr "Expander is not a procedure")) + (static-error + "let-macro" 'kwd:let-macro + expr "expander is not a procedure")) (let ((extended-vocab (create-vocabulary 'user-macro-extended-vocab vocab))) @@ -2001,10 +2165,12 @@ #f (make-origin 'micro expr)) env attributes extended-vocab)))))) (else - (static-error expr "Malformed let-macro")))))) + (static-error + "let-macro" 'kwd:let-macro + expr "malformed expression")))))) (let ((b-e/c-t - (lambda (kwd-symbol kwd-string phase-string on-demand?) + (lambda (kwd-symbol kwd:kwd-symbol kwd-string phase-string on-demand?) (let ([micro (let* ((kwd '()) (in-pattern '(_ e0 e1 ...)) (m&e (pat:make-match&env in-pattern kwd))) @@ -2019,10 +2185,13 @@ (structurize-syntax (with-handlers ((exn? (lambda (exn) - (static-error expr - "Exception at ~a time: ~a" - phase-string - (exn-message exn))))) + (static-error + kwd-string + kwd:kwd-symbol + expr + "exception at ~a time: ~a" + phase-string + (exn-message exn))))) (m3-elaboration-evaluator (let ([top-level? (get-top-level-status attributes)] [internal? (get-internal-define-status attributes)]) @@ -2045,31 +2214,37 @@ '() #f (make-origin 'micro expr)) env attributes vocab)))) (else - (static-error expr - (string-append "Malformed " kwd-string))))))]) + (static-error + kwd-string kwd:kwd-symbol + expr + "malformed expression")))))]) (add-micro-form kwd-symbol full-vocabulary micro) (if on-demand? (add-on-demand-form 'micro kwd-symbol scheme-vocabulary micro) (add-micro-form kwd-symbol scheme-vocabulary micro)))))) - (b-e/c-t 'begin-construction-time "begin-construction-time" "construction" #t) - (b-e/c-t 'begin-elaboration-time "begin-elaboration-time" "elaboration" #f)) + (b-e/c-t 'begin-construction-time 'kwd:begin-construction-time + "begin-construction-time" "construction" #t) + (b-e/c-t 'begin-elaboration-time 'kwd:begin-elaboration-time + "begin-elaboration-time" "elaboration" #f)) (define unquote-micro (lambda (expr env) - (static-error expr "Unquote outside quasiquote"))) + (static-error + "unquote" 'kwd:unquote + expr "outside quasiquote"))) (add-primitivized-macro-form 'unquote intermediate-vocabulary unquote-micro) (add-primitivized-macro-form 'unquote scheme-vocabulary unquote-micro) (define unquote-splicing-micro (lambda (expr env) - (static-error expr "Unquote-splicing outside quasiquote"))) + (static-error + "unquote-splicing" 'kwd:unquote-splicing + expr "outside quasiquote"))) (add-primitivized-macro-form 'unquote-splicing intermediate-vocabulary unquote-splicing-micro) (add-primitivized-macro-form 'unquote-splicing scheme-vocabulary unquote-splicing-micro) (include "quasi.ss") -; (include "shared.ss") - (define reference-file-macro (let* ((kwd '()) (in-pattern '(_ filename)) @@ -2090,9 +2265,13 @@ #f (make-origin 'macro expr)) env attributes vocab) - (static-error filename "Does not yield a filename")))))) + (static-error + "reference-file" 'kwd:reference-file + filename "Does not yield a filename")))))) (else - (static-error expr "Malformed reference-file")))))) + (static-error + "reference-file" 'kwd:reference-file + expr "Malformed reference-file")))))) (add-primitivized-micro-form 'reference-file beginner-vocabulary reference-file-macro) (add-on-demand-form 'micro 'reference-file common-vocabulary reference-file-macro) @@ -2117,19 +2296,25 @@ collections))))) (unless (and (quote-form? f) (z:string? (quote-form-expr f))) - (static-error filename "Does not yield a filename")) + (static-error + "require-library" 'kwd:require-library + 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 + "require-library" 'kwd:require-library + collection "Does not yield a string"))) cs collections) (let ((raw-f (z:read-object (quote-form-expr f))) (raw-cs (map (lambda (c) (z:read-object (quote-form-expr c))) cs))) (unless (relative-path? raw-f) - (static-error f + (static-error + "require-library" 'kwd:require-library + f "Library path ~s must be a relative path" raw-f)) (expand-expr @@ -2141,7 +2326,9 @@ (make-origin 'micro expr)) env attributes vocab)))))) (else - (static-error expr "Malformed require-library")))))) + (static-error + "require-library" 'kwd-require-library + expr "Malformed require-library")))))) (add-primitivized-micro-form 'require-library beginner-vocabulary require-library-micro) (add-primitivized-micro-form 'require-library scheme-vocabulary require-library-micro) @@ -2166,20 +2353,29 @@ collections))))) (unless (and (quote-form? f) (z:string? (quote-form-expr f))) - (static-error filename "Does not yield a filename")) + (static-error + "require-relative-library" + 'kwd:require-relative-library + 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 + "require-relative-library" + 'kwd:require-relative-library + collection "Does not yield a string"))) cs collections) (let ((raw-f (z:read-object (quote-form-expr f))) (raw-cs (map (lambda (c) (z:read-object (quote-form-expr c))) cs))) (unless (relative-path? raw-f) - (static-error f - "Library path ~s must be a relative path" + (static-error + "require-relative-library" + 'kwd:require-relative-library + f + "library path ~s must be a relative path" raw-f)) (expand-expr (structurize-syntax @@ -2190,63 +2386,77 @@ (make-origin 'micro expr)) env attributes vocab)))))) (else - (static-error expr "Malformed require-relative-library")))))) + (static-error + "require-relative-library" 'kwd:require-relative-library + expr "malformed expression")))))) (add-primitivized-micro-form 'require-relative-library beginner-vocabulary require-relative-library-micro) (add-primitivized-micro-form 'require-relative-library scheme-vocabulary require-relative-library-micro) - (add-macro-form 'define-constructor beginner-vocabulary + (add-on-demand-form 'micro 'define-constructor beginner-vocabulary (let* ((kwd '()) (in-pattern '(_ sym modes ...)) (m&e (pat:make-match&env in-pattern kwd)) (out-pattern '(#%void))) (lambda (expr env) (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error expr "Malformed define-constructor"))))) + (static-error + "define-constructor" 'kwd:define-constructor + expr "malformed definition"))))) - (add-macro-form 'define-type beginner-vocabulary + (add-on-demand-form 'macro 'define-type beginner-vocabulary (let* ((kwd '()) (in-pattern '(_ sym type)) (m&e (pat:make-match&env in-pattern kwd)) (out-pattern '(#%void))) (lambda (expr env) (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error expr "Malformed define-type"))))) + (static-error + "define-type" 'kwd:define-type + expr "malformed definition"))))) - (add-macro-form ': beginner-vocabulary + (add-on-demand-form 'macro ': beginner-vocabulary (let* ((kwd '()) (in-pattern '(_ expr type)) (m&e (pat:make-match&env in-pattern kwd)) (out-pattern 'expr)) (lambda (expr env) (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error expr "Malformed :"))))) + (static-error + ":" 'kwd:: + expr "malformed declaration"))))) - (add-macro-form 'type: beginner-vocabulary + (add-on-demand-form 'macro 'type: beginner-vocabulary (let* ((kwd '()) (in-pattern '(_ type attr ...)) (out-pattern '(#%void)) (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 type:"))))) + (static-error + "type:" 'kwd:type: + expr "malformed declaration"))))) - (add-macro-form 'mrspidey:control beginner-vocabulary + (add-on-demand-form 'macro 'mrspidey:control beginner-vocabulary (let* ((kwd '()) (in-pattern '(_ para val)) (m&e (pat:make-match&env in-pattern kwd)) (out-pattern '(#%void))) (lambda (expr env) (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error expr "Malformed st:control"))))) + (static-error + "mrspidey:control" 'kwd:mrspidey:control + expr "malformed declaration"))))) - (add-macro-form 'polymorphic beginner-vocabulary + (add-on-demand-form 'macro 'polymorphic beginner-vocabulary (let* ((kwd '()) (in-pattern '(_ body)) (m&e (pat:make-match&env in-pattern kwd)) (out-pattern 'body)) (lambda (expr env) (or (pat:match-and-rewrite expr m&e out-pattern kwd env) - (static-error expr "Malformed polymorphic"))))) + (static-error + "polymorphic" 'kwd:polymorpic + expr "malformed declaration"))))) ) diff --git a/collects/zodiac/scm-obj.ss b/collects/zodiac/scm-obj.ss index b3776957..bc8f325c 100644 --- a/collects/zodiac/scm-obj.ss +++ b/collects/zodiac/scm-obj.ss @@ -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) diff --git a/collects/zodiac/scm-ou.ss b/collects/zodiac/scm-ou.ss index 4d2dd58a..c14fe2af 100644 --- a/collects/zodiac/scm-ou.ss +++ b/collects/zodiac/scm-ou.ss @@ -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)))))))) diff --git a/collects/zodiac/scm-spdy.ss b/collects/zodiac/scm-spdy.ss index 07877778..11ec8303 100644 --- a/collects/zodiac/scm-spdy.ss +++ b/collects/zodiac/scm-spdy.ss @@ -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 '()) diff --git a/collects/zodiac/scm-unit.ss b/collects/zodiac/scm-unit.ss index 6fe18a3b..06646fc0 100644 --- a/collects/zodiac/scm-unit.ss +++ b/collects/zodiac/scm-unit.ss @@ -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) diff --git a/collects/zodiac/x.ss b/collects/zodiac/x.ss index a03827ce..38e5bcc5 100644 --- a/collects/zodiac/x.ss +++ b/collects/zodiac/x.ss @@ -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 diff --git a/notes/drscheme/HISTORY b/notes/drscheme/HISTORY index b0fe0c84..3ed14543 100644 --- a/notes/drscheme/HISTORY +++ b/notes/drscheme/HISTORY @@ -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 () --- 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 diff --git a/notes/mred/HISTORY b/notes/mred/HISTORY index 17b16dd8..106806e2 100644 --- a/notes/mred/HISTORY +++ b/notes/mred/HISTORY @@ -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 diff --git a/notes/mzscheme/HISTORY b/notes/mzscheme/HISTORY index ed9ca255..a04591eb 100644 --- a/notes/mzscheme/HISTORY +++ b/notes/mzscheme/HISTORY @@ -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 flag to MzScheme, which loads code embedded in the - executable from file position to . 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 diff --git a/notes/stepper/DESIGN-NOTES b/notes/stepper/DESIGN-NOTES index b74ee18c..2a3cb36d 100644 --- a/notes/stepper/DESIGN-NOTES +++ b/notes/stepper/DESIGN-NOTES @@ -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. + diff --git a/src/configure b/src/configure index 23709140..2a7680f6 100755 --- a/src/configure +++ b/src/configure @@ -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 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 <&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 <&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 <&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 <&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 <&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 <&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 <&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 <&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 <&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 <&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 <&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 <&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 <&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 <&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 <&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 <&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 <&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 <&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 diff --git a/src/mred/mred.cxx b/src/mred/mred.cxx index 366dbdfb..a9475f82 100644 --- a/src/mred/mred.cxx +++ b/src/mred/mred.cxx @@ -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) diff --git a/src/mred/wxme/wx_medio.cxx b/src/mred/wxme/wx_medio.cxx index 2cc45f13..b46fea18 100644 --- a/src/mred/wxme/wx_medio.cxx +++ b/src/mred/wxme/wx_medio.cxx @@ -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; diff --git a/src/mred/wxme/wx_snip.cxx b/src/mred/wxme/wx_snip.cxx index b1e4e4df..36b1a130 100644 --- a/src/mred/wxme/wx_snip.cxx +++ b/src/mred/wxme/wx_snip.cxx @@ -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) diff --git a/src/mred/wxs/wxs_mede.xc b/src/mred/wxs/wxs_mede.xc index 505311d9..0ed23f7f 100644 --- a/src/mred/wxs/wxs_mede.xc +++ b/src/mred/wxs/wxs_mede.xc @@ -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); diff --git a/src/mred/wxs/wxs_misc.cxx b/src/mred/wxs/wxs_misc.cxx index c089f88d..e25e808e 100644 --- a/src/mred/wxs/wxs_misc.cxx +++ b/src/mred/wxs/wxs_misc.cxx @@ -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)); diff --git a/src/mred/wxs/wxs_misc.xc b/src/mred/wxs/wxs_misc.xc index 358a0b14..1a3636ac 100644 --- a/src/mred/wxs/wxs_misc.xc +++ b/src/mred/wxs/wxs_misc.xc @@ -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!); diff --git a/src/mysterx/myspage/eventqueue.cxx b/src/mysterx/myspage/eventqueue.cxx index 4df2926e..041dcae4 100644 --- a/src/mysterx/myspage/eventqueue.cxx +++ b/src/mysterx/myspage/eventqueue.cxx @@ -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; } diff --git a/src/mysterx/mysterx.cxx b/src/mysterx/mysterx.cxx index 97937a52..e6b77d64 100644 --- a/src/mysterx/mysterx.cxx +++ b/src/mysterx/mysterx.cxx @@ -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(""); - scheme_register_extension_global(&mx_com_object_type,sizeof(mx_com_object_type)); mx_com_type_type = scheme_make_type(""); - scheme_register_extension_global(&mx_com_type_type,sizeof(mx_com_type_type)); mx_browser_type = scheme_make_type(""); - scheme_register_extension_global(&mx_browser_type,sizeof(mx_browser_type)); mx_document_type = scheme_make_type(""); - scheme_register_extension_global(&mx_document_type,sizeof(mx_document_type)); mx_element_type = scheme_make_type(""); - scheme_register_extension_global(&mx_element_type,sizeof(mx_element_type)); mx_event_type = scheme_make_type(""); - scheme_register_extension_global(&mx_event_type,sizeof(mx_event_type)); mx_com_cy_type = scheme_make_type(""); - scheme_register_extension_global(&mx_com_cy_type,sizeof(mx_com_cy_type)); mx_com_date_type = scheme_make_type(""); - scheme_register_extension_global(&mx_com_date_type,sizeof(mx_com_date_type)); mx_com_boolean_type = scheme_make_type(""); - scheme_register_extension_global(&mx_com_boolean_type,sizeof(mx_com_boolean_type)); mx_com_scode_type = scheme_make_type(""); - scheme_register_extension_global(&mx_com_scode_type,sizeof(mx_com_scode_type)); mx_com_variant_type = scheme_make_type(""); - scheme_register_extension_global(&mx_com_variant_type,sizeof(mx_com_variant_type)); mx_com_iunknown_type = scheme_make_type(""); - scheme_register_extension_global(&mx_com_iunknown_type,sizeof(mx_com_iunknown_type)); mx_com_pointer_type = scheme_make_type(""); - scheme_register_extension_global(&mx_com_pointer_type,sizeof(mx_com_pointer_type)); mx_com_array_type = scheme_make_type(""); - scheme_register_extension_global(&mx_com_array_type,sizeof(mx_com_array_type)); mx_com_omit_type = scheme_make_type(""); - scheme_register_extension_global(&mx_com_omit_type,sizeof(mx_com_omit_type)); mx_com_typedesc_type = scheme_make_type(""); - 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; diff --git a/src/mzcom/mzcom.cxx b/src/mzcom/mzcom.cxx index a330aadb..069f4977 100644 --- a/src/mzcom/mzcom.cxx +++ b/src/mzcom/mzcom.cxx @@ -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) diff --git a/src/mzcom/mzcom.idl b/src/mzcom/mzcom.idl index 2bba4785..f9bf98af 100644 --- a/src/mzcom/mzcom.idl +++ b/src/mzcom/mzcom.idl @@ -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(); }; [ diff --git a/src/mzcom/mzobj.cxx b/src/mzcom/mzobj.cxx index 4212ca35..8e074118 100644 --- a/src/mzcom/mzobj.cxx +++ b/src/mzcom/mzobj.cxx @@ -1,22 +1,34 @@ // mzobj.cxx : Implementation of CMzObj -#include "resource.h" - #include "stdafx.h" +#include "resource.h" +#ifdef _ATL_STATIC_REGISTRY +#include +#include +#endif +#include + #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; +} diff --git a/src/mzcom/mzobj.h b/src/mzcom/mzobj.h index 0a6e297d..ca4fd9ba 100644 --- a/src/mzcom/mzobj.h +++ b/src/mzcom/mzobj.h @@ -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_ + diff --git a/src/mzcom/stdafx.cxx b/src/mzcom/stdafx.cxx deleted file mode 100644 index a5eea178..00000000 --- a/src/mzcom/stdafx.cxx +++ /dev/null @@ -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 -#include -#endif - -#include diff --git a/src/mzcom/stdafx.h b/src/mzcom/stdafx.h index 76cdef1d..478cbb02 100644 --- a/src/mzcom/stdafx.h +++ b/src/mzcom/stdafx.h @@ -29,6 +29,7 @@ public: bool bActivity; }; extern CExeModule _Module; + #include //{{AFX_INSERT_LOCATION}} diff --git a/src/mzscheme/configure.in b/src/mzscheme/configure.in index bbe9548c..6ae8c6fe 100644 --- a/src/mzscheme/configure.in +++ b/src/mzscheme/configure.in @@ -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= diff --git a/src/mzscheme/sconfig.h b/src/mzscheme/sconfig.h index e377e59b..e0e79056 100644 --- a/src/mzscheme/sconfig.h +++ b/src/mzscheme/sconfig.h @@ -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 diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 79f7b6c1..5ef8fecf 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -5,4 +5,4 @@ # define SPECIAL_TAG "" #endif -#define VERSION "102/13" SPECIAL_TAG +#define VERSION "102" SPECIAL_TAG diff --git a/src/srpersist/srpersist.cxx b/src/srpersist/srpersist.cxx index 5f9f49f7..d36246d3 100644 --- a/src/srpersist/srpersist.cxx +++ b/src/srpersist/srpersist.cxx @@ -6726,29 +6726,6 @@ void initTypes(void) { sql_op_parms_type = scheme_make_type(""); sql_guid_type = scheme_make_type(""); sql_paramlength_type = scheme_make_type(""); - - 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) { diff --git a/src/srpersist/srpersist.h b/src/srpersist/srpersist.h index a399e647..66f73bc1 100644 --- a/src/srpersist/srpersist.h +++ b/src/srpersist/srpersist.h @@ -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; } \ diff --git a/src/worksp/mzcom/mzcom.dsp b/src/worksp/mzcom/mzcom.dsp index af37039e..2fb9da67 100644 --- a/src/worksp/mzcom/mzcom.dsp +++ b/src/worksp/mzcom/mzcom.dsp @@ -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 diff --git a/src/worksp/mzcom/mzcom.dsw b/src/worksp/mzcom/mzcom.dsw index f5251c7e..43c89b16 100644 --- a/src/worksp/mzcom/mzcom.dsw +++ b/src/worksp/mzcom/mzcom.dsw @@ -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> diff --git a/src/worksp/mzcom/mzcom.h b/src/worksp/mzcom/mzcom.h new file mode 100644 index 00000000..30effdf3 --- /dev/null +++ b/src/worksp/mzcom/mzcom.h @@ -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 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 +#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 diff --git a/src/worksp/mzcom/mzcom.mak b/src/worksp/mzcom/mzcom.mak index 61bfdd45..fbe88aa8 100644 --- a/src/worksp/mzcom/mzcom.mak +++ b/src/worksp/mzcom/mzcom.mak @@ -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) diff --git a/src/worksp/mzcom/mzcom.rc b/src/worksp/mzcom/mzcom.rc index 346a4a57..5de803a6 100644 --- a/src/worksp/mzcom/mzcom.rc +++ b/src/worksp/mzcom/mzcom.rc @@ -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 + diff --git a/src/worksp/mzcom/mzcom.rgs b/src/worksp/mzcom/mzcom.rgs new file mode 100644 index 00000000..75eb2170 --- /dev/null +++ b/src/worksp/mzcom/mzcom.rgs @@ -0,0 +1,11 @@ +HKCR +{ + NoRemove AppID + { + {A604CB9D-2AB5-11D4-B6D3-0060089002FE} = s 'MzCOM' + 'MzCOM.EXE' + { + val AppID = s {A604CB9D-2AB5-11D4-B6D3-0060089002FE} + } + } +} diff --git a/src/wxcommon/PSDC.cxx b/src/wxcommon/PSDC.cxx index efa22dee..a2743c64 100644 --- a/src/wxcommon/PSDC.cxx +++ b/src/wxcommon/PSDC.cxx @@ -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) diff --git a/src/wxcommon/PSDC.h b/src/wxcommon/PSDC.h index b853d1c2..a5204ba9 100644 --- a/src/wxcommon/PSDC.h +++ b/src/wxcommon/PSDC.h @@ -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();