From 405ade476585c0e6e735ac11a5504d57d6bf4758 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 15 Apr 2009 03:18:11 +0000 Subject: [PATCH 01/79] svn: r14517 --- collects/framework/private/text.ss | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 63711e616a..391bf360b2 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -1170,7 +1170,11 @@ WARNING: printf is rebound in the body of the unit to always (set! clear-yellow void) (when (and searching-str (= (string-length searching-str) (- end start))) (when (do-search searching-str start end) - (set! clear-yellow (highlight-range start end "khaki" #f 'low 'ellipse)))) + (set! clear-yellow (highlight-range start end + (if (preferences:get 'framework:white-on-black?) + (make-object color% 50 50 5) + "khaki") + #f 'low 'ellipse)))) (end-edit-sequence)]))] [else (clear-yellow) From 4de8e2801657e3f7a58f9c520dd3f58fe9f4bd1e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 15 Apr 2009 07:50:14 +0000 Subject: [PATCH 02/79] Welcome to a new PLT day. svn: r14518 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 32a0fec69a..a83a3d051b 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "14apr2009") +#lang scheme/base (provide stamp) (define stamp "15apr2009") From 2c8c8638ac07937696b19e1479016391d8e4ced0 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Wed, 15 Apr 2009 14:09:35 +0000 Subject: [PATCH 03/79] Barebones interface for overriding default generators. svn: r14519 --- collects/redex/private/rg-test.ss | 87 +++++++++ collects/redex/private/rg.ss | 312 ++++++++++++++++++------------ 2 files changed, 270 insertions(+), 129 deletions(-) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index 04749ba050..6658379577 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -347,6 +347,10 @@ (test (generate-term lang (side-condition a (odd? (term a))) 5) 43) (test (raised-exn-msg exn:fail:redex? (generate-term lang c 5)) #rx"unable to generate") + (test (let/ec k + (generate-term lang (number_1 (side-condition any (k (term number_1)))) 5)) + 'number_1) + (test ; mismatch patterns work with side-condition failure/retry (generate-term/decisions lang e 5 0 @@ -840,6 +844,89 @@ (check-metafunction n (λ (_) #t) #:retries 42)) #rx"check-metafunction: unable .* in 42")) +;; custom generators +(let () + (define-language L + (x variable)) + + (test + (generate-term + L x_1 0 + #:custom (λ (pat sz i-h acc env att rec def) + (match pat + ['x (values 'x env)] + [_ (def acc)]))) + 'x) + (test + (let/ec k + (equal? + (generate-term + L (x x) 0 + #:custom (let ([once? #f]) + (λ (pat sz i-h acc env att rec def) + (match pat + ['x (if once? + (k #f) + (begin + (set! once? #t) + (values 'x env)))] + [_ (def acc)])))) + '(x x))) + #t) + + (test + (hash-ref + (let/ec k + (generate-term + L (x (x)) 0 + #:custom (λ (pat sz i-h acc env att rec def) + (match pat + [(struct binder ('x)) + (values 'y (hash-set env pat 'y))] + [(list (struct binder ('x))) (k env)] + [_ (def acc)])))) + (make-binder 'x)) + 'y) + + (test + (generate-term + L (in-hole hole 7) 0 + #:custom (λ (pat sz i-h acc env att rec def) + (match pat + [`(in-hole hole 7) + (rec 'hole #:contractum 7)] + [_ (def acc)]))) + 7) + + (test + (let/ec k + (generate-term + L any 10 + #:attempt 42 + #:custom (λ (pat sz i-h acc env att rec def) (k (list sz att))))) + '(10 42)) + + (test + (let/ec k + (generate-term + L x 10 + #:custom (λ (pat sz i-h acc env att rec def) + (match pat + ['x (rec 7 #:size 0)] + [7 (k sz)] + [_ (def att)])))) + 0) + + (test + (generate-term + L (q 7) 0 + #:custom (λ (pat sz i-h acc env att rec def) + (match pat + ['q (rec '(7 7) #:acc 8)] + [7 (values (or acc 7) env)] + [_ (def att)]))) + '((8 8) 7))) + ;; parse/unparse-pattern (let-syntax ([test-match (syntax-rules () [(_ p x) (test (match x [p #t] [_ #f]) #t)])]) (define-language lang (x variable)) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index e459984444..be8da98838 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -178,12 +178,12 @@ [parsed (parse-language lang)]) (make-rg-lang parsed lits (unique-chars lits) (find-base-cases parsed)))) -(define (generate lang decisions@ retries what) +(define (generate lang decisions@ user-gen retries what) (define-values/invoke-unit decisions@ (import) (export decisions^)) (define ((generate-nt lang base-cases generate pref-prods) - name cross? size attempt in-hole state) + name cross? size attempt in-hole env) (let*-values ([(term _) (generate/pred @@ -195,14 +195,12 @@ ((if cross? base-cases-cross base-cases-non-cross) base-cases)) ((next-non-terminal-decision) name cross? lang attempt pref-prods)))]) - (generate (max 0 (sub1 size)) attempt - (make-state #hash()) - in-hole (rhs-pattern rhs)))) + (generate (max 0 (sub1 size)) attempt empty-env in-hole (rhs-pattern rhs)))) (λ (_ env) (mismatches-satisfied? env)) size attempt)]) term)) - (define (generate-sequence ellipsis generate state length) + (define (generate-sequence ellipsis generate env length) (define (split-environment env) (foldl (λ (var seq-envs) (let ([vals (hash-ref env var #f)]) @@ -213,17 +211,17 @@ (define (merge-environments seq-envs) (foldl (λ (var env) (hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs))) - (state-env state) (ellipsis-vars ellipsis))) + env (ellipsis-vars ellipsis))) (let-values ([(seq envs) - (let recur ([envs (split-environment (state-env state))]) + (let recur ([envs (split-environment env)]) (if (null? envs) (values null null) (let*-values - ([(term state) (generate (make-state (car envs)) the-hole (ellipsis-pattern ellipsis))] + ([(term env) (generate (car envs) the-hole (ellipsis-pattern ellipsis))] [(terms envs) (recur (cdr envs))]) - (values (cons term terms) (cons (state-env state) envs)))))]) - (values seq (make-state (merge-environments envs))))) + (values (cons term terms) (cons env envs)))))]) + (values seq (merge-environments envs)))) (define (generate/pred name gen pred init-sz init-att) (let ([pre-threshold-incr @@ -244,9 +242,9 @@ name retries (if (= retries 1) "" "s")) - (let-values ([(term state) (gen size attempt)]) - (if (pred term (state-env state)) - (values term state) + (let-values ([(term env) (gen size attempt)]) + (if (pred term env) + (values term env) (retry (sub1 remaining) (if (incr-size? remaining) (add1 size) size) (+ attempt @@ -254,13 +252,13 @@ post-threshold-incr pre-threshold-incr))))))))) - (define (generate/prior name state generate) + (define (generate/prior name env generate) (let* ([none (gensym)] - [prior (hash-ref (state-env state) name none)]) + [prior (hash-ref env name none)]) (if (eq? prior none) - (let-values ([(term state) (generate)]) - (values term (set-env state name term))) - (values prior state)))) + (let-values ([(term env) (generate)]) + (values term (hash-set env name term))) + (values prior env)))) (define (mismatches-satisfied? env) (let ([groups (make-hasheq)]) @@ -276,10 +274,7 @@ (and (not (hash-ref prior val #f)) (hash-set! prior val #t))))))) - (define-struct state (env)) - (define new-state (make-state #hash())) - (define (set-env state name value) - (make-state (hash-set (state-env state) name value))) + (define empty-env #hash()) (define (bindings env) (make-bindings @@ -288,111 +283,139 @@ (cons (make-bind (binder-name key) val) bindings) bindings)))) - (define (generate-pat lang sexp pref-prods size attempt state in-hole pat) - (define recur (curry generate-pat lang sexp pref-prods size attempt)) - (define recur/pat (recur state in-hole)) + (define (generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat) + (define recur (curry generate-pat lang sexp pref-prods user-gen user-acc size attempt)) + (define recur/pat (recur env in-hole)) (define ((recur/pat/size-attempt pat) size attempt) - (generate-pat lang sexp pref-prods size attempt state in-hole pat)) + (generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat)) (define clang (rg-lang-clang lang)) (define gen-nt (generate-nt clang (rg-lang-base-cases lang) - (curry generate-pat lang sexp pref-prods) + (curry generate-pat lang sexp pref-prods user-gen user-acc) pref-prods)) - (match pat - [`number (values ((next-number-decision) attempt) state)] - [`natural (values ((next-natural-decision) attempt) state)] - [`integer (values ((next-integer-decision) attempt) state)] - [`real (values ((next-real-decision) attempt) state)] - [`(variable-except ,vars ...) - (generate/pred 'variable - (recur/pat/size-attempt 'variable) - (λ (var _) (not (memq var vars))) - size attempt)] - [`variable - (values ((next-variable-decision) - (rg-lang-chars lang) (rg-lang-lits lang) attempt) - state)] - [`variable-not-otherwise-mentioned - (generate/pred 'variable - (recur/pat/size-attempt 'variable) - (λ (var _) (not (memq var (compiled-lang-literals clang)))) - size attempt)] - [`(variable-prefix ,prefix) - (define (symbol-append prefix suffix) - (string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) - (let-values ([(term state) (recur/pat 'variable)]) - (values (symbol-append prefix term) state))] - [`string - (values ((next-string-decision) (rg-lang-chars lang) (rg-lang-lits lang) attempt) - state)] - [`(side-condition ,pat ,(? procedure? condition)) - (generate/pred (unparse-pattern pat) - (recur/pat/size-attempt pat) - (λ (_ env) (condition (bindings env))) - size attempt)] - [`(name ,(? symbol? id) ,p) - (let-values ([(term state) (recur/pat p)]) - (values term (set-env state (make-binder id) term)))] - [`hole (values in-hole state)] - [`(in-hole ,context ,contractum) - (let-values ([(term state) (recur/pat contractum)]) - (recur state term context))] - [`(hide-hole ,pattern) (recur state the-hole pattern)] - [`any - (let*-values ([(new-lang nt) ((next-any-decision) lang sexp)] - ; Don't use preferred productions for the sexp language. - [(pref-prods) (if (eq? new-lang lang) pref-prods #f)] - [(term _) (generate-pat new-lang sexp pref-prods size attempt new-state the-hole nt)]) - (values term state))] - [(? (is-nt? clang)) - (values (gen-nt pat #f size attempt in-hole state) state)] - [(struct binder ((and name (or (? (is-nt? clang) nt) (app (symbol-match named-nt-rx) (? (is-nt? clang) nt)))))) - (generate/prior pat state (λ () (values (gen-nt nt #f size attempt in-hole state) state)))] - [(struct binder ((or (? built-in? b) (app (symbol-match named-nt-rx) (? built-in? b))))) - (generate/prior pat state (λ () (recur/pat b)))] - [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? (is-nt? clang) nt))))) - (let ([term (gen-nt nt #f size attempt in-hole state)]) - (values term (set-env state pat term)))] - [(struct mismatch (name (app (symbol-match mismatch-nt-rx) (? symbol? (? built-in? b))))) - (let-values ([(term state) (recur/pat b)]) - (values term (set-env state pat term)))] - [`(cross ,(? symbol? cross-nt)) - (values (gen-nt cross-nt #t size attempt in-hole state) state)] - [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat state)] - [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest) - (let*-values ([(length) (let ([prior (hash-ref (state-env state) class #f)]) - (if prior prior ((next-sequence-decision) attempt)))] - [(seq state) (generate-sequence ellipsis recur state length)] - [(rest state) (recur (set-env (set-env state class length) name length) + (define (default-gen user-acc) + (match pat + [`number (values ((next-number-decision) attempt) env)] + [`natural (values ((next-natural-decision) attempt) env)] + [`integer (values ((next-integer-decision) attempt) env)] + [`real (values ((next-real-decision) attempt) env)] + [`(variable-except ,vars ...) + (generate/pred 'variable + (recur/pat/size-attempt 'variable) + (λ (var _) (not (memq var vars))) + size attempt)] + [`variable + (values ((next-variable-decision) + (rg-lang-chars lang) (rg-lang-lits lang) attempt) + env)] + [`variable-not-otherwise-mentioned + (generate/pred 'variable + (recur/pat/size-attempt 'variable) + (λ (var _) (not (memq var (compiled-lang-literals clang)))) + size attempt)] + [`(variable-prefix ,prefix) + (define (symbol-append prefix suffix) + (string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) + (let-values ([(term env) (recur/pat 'variable)]) + (values (symbol-append prefix term) env))] + [`string + (values ((next-string-decision) (rg-lang-chars lang) (rg-lang-lits lang) attempt) + env)] + [`(side-condition ,pat ,(? procedure? condition)) + (generate/pred (unparse-pattern pat) + (recur/pat/size-attempt pat) + (λ (_ env) (condition (bindings env))) + size attempt)] + [`(name ,(? symbol? id) ,p) + (let-values ([(term env) (recur/pat p)]) + (values term (hash-set env (make-binder id) term)))] + [`hole (values in-hole env)] + [`(in-hole ,context ,contractum) + (let-values ([(term env) (recur/pat contractum)]) + (recur env term context))] + [`(hide-hole ,pattern) (recur env the-hole pattern)] + [`any + (let*-values ([(new-lang nt) ((next-any-decision) lang sexp)] + ; Don't use preferred productions for the sexp language. + [(pref-prods) (if (eq? new-lang lang) pref-prods #f)] + [(term _) (generate-pat new-lang + sexp + pref-prods + user-gen + user-acc + size + attempt + empty-env + the-hole + nt)]) + (values term env))] + [(? (is-nt? clang)) + (values (gen-nt pat #f size attempt in-hole env) env)] + [(struct binder ((or (? (is-nt? clang) nt) + (app (symbol-match named-nt-rx) (? (is-nt? clang) nt))))) + (generate/prior pat env (λ () (recur/pat nt)))] + [(struct binder ((or (? built-in? b) + (app (symbol-match named-nt-rx) (? built-in? b))))) + (generate/prior pat env (λ () (recur/pat b)))] + [(struct mismatch (name (app (symbol-match mismatch-nt-rx) + (? symbol? (? (is-nt? clang) nt))))) + (let-values ([(term _) (recur/pat nt)]) + (values term (hash-set env pat term)))] + [(struct mismatch (name (app (symbol-match mismatch-nt-rx) + (? symbol? (? built-in? b))))) + (let-values ([(term _) (recur/pat b)]) + (values term (hash-set env pat term)))] + [`(cross ,(? symbol? cross-nt)) + (values (gen-nt cross-nt #t size attempt in-hole env) env)] + [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)] + [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest) + (let*-values ([(length) (let ([prior (hash-ref env class #f)]) + (if prior prior ((next-sequence-decision) attempt)))] + [(seq env) (generate-sequence ellipsis recur env length)] + [(rest env) (recur (hash-set (hash-set env class length) name length) in-hole rest)]) - (values (append seq rest) state))] - [(list-rest pat rest) - (let*-values - ([(pat-term state) (recur/pat pat)] - [(rest-term state) (recur state in-hole rest)]) - (values (cons pat-term rest-term) state))] - [else - (error what "unknown pattern ~s\n" pat)])) + (values (append seq rest) env))] + [(list-rest pat rest) + (let*-values + ([(pat-term env) (recur/pat pat)] + [(rest-term env) (recur env in-hole rest)]) + (values (cons pat-term rest-term) env))] + [else + (error what "unknown pattern ~s\n" pat)])) + + (user-gen + pat size in-hole user-acc env attempt + (λ (pat #:size [size size] #:contractum [in-hole in-hole] #:acc [user-acc user-acc] #:env [env env]) + (generate-pat lang sexp pref-prods user-gen user-acc size attempt env in-hole pat)) + default-gen)) (let ([rg-lang (prepare-lang lang)] [rg-sexp (prepare-lang sexp)]) (λ (pat) (let ([parsed (reassign-classes (parse-pattern pat lang 'top-level))]) (λ (size attempt) - (let-values ([(term state) + (let-values ([(term env) (generate/pred pat (λ (size attempt) (generate-pat - rg-lang rg-sexp ((next-pref-prods-decision) (rg-lang-clang rg-lang)) - size attempt new-state the-hole parsed)) + rg-lang + rg-sexp + ((next-pref-prods-decision) (rg-lang-clang rg-lang)) + user-gen + #f + size + attempt + empty-env + the-hole + parsed)) (λ (_ env) (mismatches-satisfied? env)) size attempt)]) - (values term (bindings (state-env state))))))))) + (values term (bindings env)))))))) (define-struct base-cases (cross non-cross)) @@ -658,22 +681,31 @@ (unless (reduction-relation? x) (raise-type-error 'redex-check "reduction-relation" x))) -(define-for-syntax (term-generator lang pat decisions@ retries what) +(define (defer-all pat size in-hole acc env att recur defer) + (defer acc)) + +(define-for-syntax (term-generator lang pat decisions@ custom retries what) (with-syntax ([pattern (rewrite-side-conditions/check-errs (language-id-nts lang what) what #t pat)]) - #`((generate #,lang #,decisions@ #,retries '#,what) `pattern))) + #`((generate #,lang #,decisions@ #,custom #,retries '#,what) `pattern))) (define-syntax (generate-term stx) (syntax-case stx () [(_ lang pat size . kw-args) - (with-syntax ([(attempt retries) + (with-syntax ([(attempt retries custom) (parse-kw-args `((#:attempt . 1) - (#:retries . ,#'default-retries)) + (#:retries . ,#'default-retries) + (#:custom . ,#'defer-all)) (syntax kw-args) stx)]) - (with-syntax ([generate (term-generator #'lang #'pat #'(generation-decisions) #'retries 'generate-term)]) + (with-syntax ([generate (term-generator #'lang + #'pat + #'(generation-decisions) + #'custom + #'retries + 'generate-term)]) (syntax/loc stx (let-values ([(term _) (generate size attempt)]) term))))] @@ -702,25 +734,35 @@ (let-values ([(names names/ellipses) (extract-names (language-id-nts #'lang 'redex-check) 'redex-check #t #'pat)] - [(attempts-stx source-stx retries-stx) + [(attempts-stx source-stx retries-stx custom-stx) (apply values (parse-kw-args `((#:attempts . ,#'default-check-attempts) (#:source . #f) - (#:retries . ,#'default-retries)) + (#:retries . ,#'default-retries) + (#:custom . ,#'defer-all)) (syntax kw-args) stx))]) (with-syntax ([(name ...) names] [(name/ellipses ...) names/ellipses] - [attempts attempts-stx] - [retries retries-stx] [show (show-message stx)]) (with-syntax ([property (syntax (λ (_ bindings) (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) property)))]) (quasisyntax/loc stx - (let ([att attempts] - [ret retries]) + (let ([att #,attempts-stx] + [ret #,retries-stx] + [custom (contract + (-> any/c natural-number/c any/c any/c hash? natural-number/c + (->* (any/c) + (#:size natural-number/c + #:contractum any/c + #:acc any/c + #:env hash?) + (values any/c hash?)) + (-> any/c (values any/c hash?)) + (values any/c hash?)) + #,custom-stx '+ '-)]) (assert-nat 'redex-check att) (assert-nat 'redex-check ret) (unsyntax @@ -739,14 +781,21 @@ (map rewrite-proc-lhs (reduction-relation-make-procs r)) (reduction-relation-srcs r) (reduction-relation-lang r)))])]) - (check-prop-srcs - lang pats srcs property random-decisions@ (max 1 (floor (/ att (length pats)))) ret + (check-prop-srcs + lang + pats + srcs + property + random-decisions@ + custom + (max 1 (floor (/ att (length pats)))) + ret 'redex-check show (test-match lang pat) (λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat)))) #`(check-prop - #,(term-generator #'lang #'pat #'random-decisions@ #'ret 'redex-check) + #,(term-generator #'lang #'pat #'random-decisions@ #'custom #'ret 'redex-check) property att show))) (void))))))])) @@ -793,9 +842,10 @@ [(_ name . kw-args) (identifier? #'name) (with-syntax ([m (metafunc/err #'name stx)] - [(attempts retries) + [(attempts retries custom) (parse-kw-args `((#:attempts . ,#'default-check-attempts) - (#:retries . ,#'default-retries)) + (#:retries . ,#'default-retries) + (#:custom . ,#'defer-all)) (syntax kw-args) stx)] [show (show-message stx)]) @@ -806,7 +856,7 @@ [att attempts]) (assert-nat 'check-metafunction-contract att) (check-prop - ((generate lang decisions@ retries 'check-metafunction-contract) + ((generate lang decisions@ custom retries 'check-metafunction-contract) (if dom dom '(any (... ...)))) (λ (t _) (with-handlers ([exn:fail:redex? (λ (_) #f)]) @@ -814,10 +864,10 @@ att show))))])) -(define (check-prop-srcs lang pats srcs prop decisions@ attempts retries what show +(define (check-prop-srcs lang pats srcs prop decisions@ custom attempts retries what show [match #f] [match-fail #f]) - (let ([lang-gen (generate lang decisions@ retries what)]) + (let ([lang-gen (generate lang decisions@ custom retries what)]) (when (for/and ([pat pats] [src srcs]) (check (lang-gen pat) @@ -839,9 +889,10 @@ (syntax-case stx () [(_ name property . kw-args) (with-syntax ([m (metafunc/err #'name stx)] - [(attempts retries) + [(attempts retries custom) (parse-kw-args `((#:attempts . , #'default-check-attempts) - (#:retries . ,#'default-retries)) + (#:retries . ,#'default-retries) + (#:custm . ,#'defer-all)) (syntax kw-args) stx)] [show (show-message stx)]) @@ -855,6 +906,7 @@ (metafunc-srcs m) (λ (term _) (property term)) (generation-decisions) + custom att ret 'check-metafunction @@ -867,10 +919,11 @@ (define-syntax (check-reduction-relation stx) (syntax-case stx () [(_ relation property . kw-args) - (with-syntax ([(attempts retries decisions@) + (with-syntax ([(attempts retries decisions@ custom) (parse-kw-args `((#:attempts . , #'default-check-attempts) (#:retries . ,#'default-retries) - (#:decisions . ,#'random-decisions@)) + (#:decisions . ,#'random-decisions@) + (#:custom . ,#'defer-all)) (syntax kw-args) stx)] [show (show-message stx)]) @@ -886,6 +939,7 @@ (reduction-relation-srcs rel) (λ (term _) (property term)) decisions@ + custom attempts retries 'check-reduction-relation From beeb832223b23f8582062963dddc5d98447721aa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Apr 2009 14:28:37 +0000 Subject: [PATCH 04/79] use Windows console for MrEd's initial stdout/stderr/stdin svn: r14520 --- src/mred/mred.cxx | 168 ++++++++++++++++++++++++++++++++++++++++--- src/mred/mred.h | 2 +- src/mred/mredmsw.cxx | 28 +------- 3 files changed, 164 insertions(+), 34 deletions(-) diff --git a/src/mred/mred.cxx b/src/mred/mred.cxx index cc6d86f247..76bbd4b911 100644 --- a/src/mred/mred.cxx +++ b/src/mred/mred.cxx @@ -1743,7 +1743,7 @@ static void MrEdSleep(float secs, void *fds) } #ifdef wx_msw - MrEdMSWSleep(secs, fds); + MrEdMSWSleep(secs, fds, mzsleep); #else # ifdef wx_mac MrEdMacSleep(secs, fds, mzsleep); @@ -2214,6 +2214,52 @@ static Scheme_Object *stdin_pipe; #if WCONSOLE_STDIO static HANDLE console_out; +static HANDLE console_in; +static Scheme_Object *console_inport; +static HWND console_hwnd; +static int has_stdio, stdio_kills_prog; +static HANDLE waiting_sema; + +typedef HWND (WINAPI* gcw_proc)(); + +static void HideConsole() +{ + +} + +static BOOL WINAPI ConsoleHandler(DWORD op) +{ + if (stdio_kills_prog) { + ReleaseSemaphore(waiting_sema, 1, NULL); + } else { + scheme_break_main_thread(); + scheme_signal_received(); + if ((op != CTRL_C_EVENT) + && (op != CTRL_BREAK_EVENT)) + HideConsole(); + } + return TRUE; +} + +static void WaitOnConsole() +{ + DWORD wrote; + + stdio_kills_prog = 1; + if (console_hwnd) { + AppendMenu(GetSystemMenu(console_hwnd, FALSE), + MF_STRING, + SC_CLOSE, + "Close"); + /* Un-gray the close box: */ + RedrawWindow(console_hwnd, NULL, NULL, + RDW_FRAME | RDW_INVALIDATE | RDW_UPDATENOW); + } + + WriteConsole(console_out, "\n[Exited]", 9, &wrote, NULL); + + WaitForSingleObject(waiting_sema, INFINITE); +} #else /* !WCONSOLE_STDIO */ @@ -2238,6 +2284,33 @@ static void MrEdSchemeMessages(char *msg, ...) if (!console_out) { AllocConsole(); console_out = GetStdHandle(STD_OUTPUT_HANDLE); + console_in = GetStdHandle(STD_INPUT_HANDLE); + has_stdio = 1; + waiting_sema = CreateSemaphore(NULL, 0, 1, NULL); + SetConsoleCtrlHandler(ConsoleHandler, TRUE); + + wxREGGLOB(console_inport); + console_inport = scheme_make_fd_input_port((int)console_in, scheme_intern_symbol("stdin"), 0, 0); + + { + HMODULE hm; + gcw_proc gcw; + + hm = LoadLibrary("kernel32.dll"); + if (hm) + gcw = (gcw_proc)GetProcAddress(hm, "GetConsoleWindow"); + else + gcw = NULL; + + if (gcw) + console_hwnd = gcw(); + } + + if (console_hwnd) { + EnableMenuItem(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE, + MF_BYCOMMAND | MF_GRAYED); + RemoveMenu(GetSystemMenu(console_hwnd, FALSE), SC_CLOSE, MF_BYCOMMAND); + } } #endif #if REDIRECT_STDIO @@ -2253,18 +2326,21 @@ static void MrEdSchemeMessages(char *msg, ...) #if WCONSOLE_STDIO if (!msg) { char *s; - long l; - DWORD wrote; + long l, d; + DWORD wrote; s = va_arg(args, char*); + d = va_arg(args, long); l = va_arg(args, long); - WriteConsole(console_out, s, l, &wrote, NULL); + WriteConsole(console_out, s XFORM_OK_PLUS d, l, &wrote, NULL); } else { - char buffer[2048]; + char *buffer; DWORD wrote; + buffer = (char *)malloc(5 * strlen(msg)); vsprintf(buffer, msg, args); WriteConsole(console_out, buffer, strlen(buffer), &wrote, NULL); + free(buffer); } #endif #if !WCONSOLE_STDIO @@ -2345,22 +2421,64 @@ static long mrconsole_get_string(Scheme_Input_Port *ip, Scheme_Object *pipe = (Scheme_Object *)ip->port_data; MrEdSchemeMessages(""); +#if WCONSOLE_STDIO + pipe = console_inport; +#endif + add_console_reading(); - result = scheme_get_byte_string("console get-string", pipe, buffer, offset, size, nonblock ? 2 : 0, 0, 0); + result = scheme_get_byte_string_unless("console get-string", pipe, + buffer, offset, size, + nonblock, 0, NULL, + unless); remove_console_reading(); return result; } +static Scheme_Object *mrconsole_progress_evt(Scheme_Input_Port *ip) +{ + Scheme_Object *pipe = (Scheme_Object *)ip->port_data; + MrEdSchemeMessages(""); + +#if WCONSOLE_STDIO + pipe = console_inport; +#endif + + return scheme_progress_evt(pipe); +} + +static int mrconsole_peeked_read(Scheme_Input_Port *ip, + long amount, + Scheme_Object *unless, + Scheme_Object *target_ch) +{ + Scheme_Object *pipe = (Scheme_Object *)ip->port_data; + MrEdSchemeMessages(""); + +#if WCONSOLE_STDIO + pipe = console_inport; +#endif + + return scheme_peeked_read(pipe, amount, unless, target_ch); +} + static int mrconsole_char_ready(Scheme_Input_Port *ip) { Scheme_Object *pipe = (Scheme_Object *)ip->port_data; MrEdSchemeMessages(""); + +#if WCONSOLE_STDIO + pipe = console_inport; +#endif + return scheme_char_ready(pipe); } static void mrconsole_close(Scheme_Input_Port *ip) { Scheme_Object *pipe = (Scheme_Object *)ip->port_data; +#if WCONSOLE_STDIO + pipe = console_inport; +#endif scheme_close_input_port(pipe); } @@ -2378,8 +2496,8 @@ static Scheme_Object *MrEdMakeStdIn(void) scheme_intern_symbol("mred-console"), CAST_GS mrconsole_get_string, NULL, - scheme_progress_evt_via_get, - scheme_peeked_read_via_get, + mrconsole_progress_evt, + mrconsole_peeked_read, CAST_IREADY mrconsole_char_ready, CAST_ICLOSE mrconsole_close, NULL, @@ -2898,6 +3016,20 @@ static Scheme_Env *setup_basic_env() return global_env; } +#if WCONSOLE_STDIO +static void MrEdExit(int v) +{ + if (has_stdio) { + WaitOnConsole(); + } + +#ifdef wx_msw + mred_clean_up_gdi_objects(); +#endif + scheme_immediate_exit(v); +} +#endif + wxFrame *MrEdApp::OnInit(void) { MrEdContext *mmc; @@ -3027,6 +3159,15 @@ wxFrame *MrEdApp::OnInit(void) mred_run_from_cmd_line(argc, argv, setup_basic_env); +#if WCONSOLE_STDIO + if (!wx_in_terminal) { + /* The only reason we get here is that a command-line error or + -h occured. In either case, stick around for the sake of the + console. */ + MrEdExit(1); + } +#endif + return NULL; } @@ -3052,6 +3193,10 @@ void MrEdApp::RealInit(void) initialized = 1; thread->on_kill = CAST_TOK on_main_killed; +#if WCONSOLE_STDIO + if (!wx_in_terminal) + scheme_exit = CAST_EXIT MrEdExit; +#endif #ifdef wx_xt if (wx_single_instance) { @@ -3525,6 +3670,13 @@ void wxDrop_Runtime(char **argv, int argc) #if defined(wx_mac) || defined(wx_msw) void wxDrop_Quit() { +#if WCONSOLE_STDIO + if (has_stdio) { + has_stdio = 0; + HideConsole(); + } +#endif + wxDo(wxs_app_quit_proc, 0, NULL); } #endif diff --git a/src/mred/mred.h b/src/mred/mred.h index cbd35c0aea..48c6053a97 100644 --- a/src/mred/mred.h +++ b/src/mred/mred.h @@ -110,7 +110,7 @@ extern "C" { } #ifdef wx_msw -void MrEdMSWSleep(float secs, void *fds); +void MrEdMSWSleep(float secs, void *fds, SLEEP_PROC_PTR mzsleep); MRED_EXTERN void mred_clean_up_gdi_objects(void); #endif diff --git a/src/mred/mredmsw.cxx b/src/mred/mredmsw.cxx index bc100a3ced..a6e3ccb121 100644 --- a/src/mred/mredmsw.cxx +++ b/src/mred/mredmsw.cxx @@ -845,7 +845,7 @@ int MrEdCheckForBreak(void) } } -void MrEdMSWSleep(float secs, void *fds) +void MrEdMSWSleep(float secs, void *fds, SLEEP_PROC_PTR mzsleep) { DWORD msecs; @@ -909,30 +909,8 @@ void MrEdMSWSleep(float secs, void *fds) } if (fds) { - win_extended_fd_set *r; - int num_handles, num_rhandles, *rps, result; - HANDLE *handles; - - scheme_collapse_win_fd(fds); /* merges */ - - r = (win_extended_fd_set *)fds; - - num_rhandles = SCHEME_INT_VAL(((win_extended_fd_set *)fds)->num_handles); - num_handles = SCHEME_INT_VAL(((win_extended_fd_set *)fds)->combined_len); - handles = ((win_extended_fd_set *)fds)->combined_wait_array; - rps = ((win_extended_fd_set *)fds)->repost_sema; - - result = MsgWaitForMultipleObjects(num_handles, handles, FALSE, - secs ? msecs : INFINITE, - QS_ALLINPUT); - - if ((result >= WAIT_OBJECT_0) && (result < WAIT_OBJECT_0 + num_rhandles)) { - result -= WAIT_OBJECT_0; - if (rps[result]) - ReleaseSemaphore(handles[result], 1, NULL); - } - - scheme_collapse_win_fd(fds); /* cleans up */ + scheme_add_fd_eventmask(fds, QS_ALLINPUT); + mzsleep(secs, fds); } else if (wxTheApp->keep_going) { MsgWaitForMultipleObjects(0, NULL, FALSE, secs ? msecs : INFINITE, From b7063fc563eba2bbacbf40a062cf29e2a3394030 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Wed, 15 Apr 2009 15:43:04 +0000 Subject: [PATCH 05/79] Fix error message in define/contract. svn: r14522 --- collects/scheme/private/contract.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index 52688c3f6e..5920e8a6e0 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -87,7 +87,7 @@ improve method arity mismatch contract violation error messages? define-stx)] [(_ name contract-expr) (raise-syntax-error 'define/contract - "no body after contract" + "expected a contract expression and a definition body, but found only one expression" define-stx)] [(_ name+arg-list contract #:freevars args . body) (identifier? #'args) From daf779d2306017414ea35e36050963bcc0300445 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Apr 2009 17:18:02 +0000 Subject: [PATCH 06/79] fix problem with free-id= cycles svn: r14524 --- src/mzscheme/src/env.c | 6 +- src/mzscheme/src/module.c | 2 +- src/mzscheme/src/schpriv.h | 2 +- src/mzscheme/src/stxobj.c | 148 +++++++++++++++++++++++++------------ 4 files changed, 104 insertions(+), 54 deletions(-) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index cb9819e962..fae5f8556b 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -2003,7 +2003,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec existing rename. */ if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode < 2)) { Scheme_Object *mod, *nm = id; - mod = scheme_stx_module_name(0, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL, + mod = scheme_stx_module_name(NULL, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL, NULL, NULL, NULL, NULL); if (mod /* must refer to env->module, otherwise there would have been an error before getting here */ @@ -2679,7 +2679,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, } src_find_id = find_id; - modidx = scheme_stx_module_name(0, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, + modidx = scheme_stx_module_name(NULL, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, NULL, NULL, NULL, NULL); /* Used out of context? */ @@ -2957,7 +2957,7 @@ int scheme_check_context(Scheme_Env *env, Scheme_Object *name, Scheme_Object *ok if (mod && SCHEME_TRUEP(mod) && NOT_SAME_OBJ(ok_modidx, mod)) { return 1; } else { - mod = scheme_stx_module_name(0, &id, scheme_make_integer(env->phase), NULL, NULL, NULL, + mod = scheme_stx_module_name(NULL, &id, scheme_make_integer(env->phase), NULL, NULL, NULL, NULL, NULL, NULL, NULL); if (SAME_OBJ(mod, scheme_undefined)) return 1; diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 09d108b91b..6ffc0eda7b 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -7304,7 +7304,7 @@ static Scheme_Object *extract_free_id_name(Scheme_Object *name, name2 = scheme_rename_transformer_id(SCHEME_PTR_VAL(v2)); id = name2; - mod = scheme_stx_module_name(0, &id, phase, + mod = scheme_stx_module_name(NULL, &id, phase, _implicit_nominal_mod, _implicit_nominal_name, _implicit_mod_phase, NULL, NULL, NULL, NULL); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 3cf8d558b9..67b9e3c28b 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -809,7 +809,7 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist); int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase); int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym); Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase); -Scheme_Object *scheme_stx_module_name(int recur, +Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *recur, Scheme_Object **name, Scheme_Object *phase, Scheme_Object **nominal_modidx, Scheme_Object **nominal_name, diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 2792830328..589e895744 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -88,6 +88,7 @@ static Scheme_Stx_Srcloc *empty_srcloc; static Scheme_Object *empty_simplified; static Scheme_Hash_Table *empty_hash_table; +static THREAD_LOCAL Scheme_Hash_Table *quick_hash_table; static THREAD_LOCAL Scheme_Object *last_phase_shift; @@ -570,6 +571,8 @@ void scheme_init_stx(Scheme_Env *env) REGISTER_SO(nominal_ipair_cache); + REGISTER_SO(quick_hash_table); + REGISTER_SO(last_phase_shift); REGISTER_SO(empty_hash_table); @@ -1930,10 +1933,29 @@ Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib) return scheme_add_rename(o, rib); } +static Scheme_Hash_Table *make_recur_table() +{ + if (quick_hash_table) { + GC_CAN_IGNORE Scheme_Hash_Table *t; + t = quick_hash_table; + quick_hash_table = NULL; + return t; + } else + return scheme_make_hash_table(SCHEME_hash_ptr); +} + +static void release_recur_table(Scheme_Hash_Table *free_id_recur) +{ + if (!free_id_recur->size && !quick_hash_table) { + quick_hash_table = free_id_recur; + } +} + static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, Scheme_Object *id, Scheme_Object *orig_id, - int *_sealed) + int *_sealed, + Scheme_Hash_Table *free_id_recur) { Scheme_Object *result; Scheme_Object *modname; @@ -1943,10 +1965,15 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, Scheme_Object *src_phase_index; Scheme_Object *nominal_src_phase; Scheme_Object *lex_env; + + if (scheme_hash_get(free_id_recur, id)) { + return id; + } + scheme_hash_set(free_id_recur, id, id); nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL); - modname = scheme_stx_module_name(1, + modname = scheme_stx_module_name(free_id_recur, &orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx, &nominal_name, &mod_phase, @@ -3939,7 +3966,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *a, Scheme_Object *orig_phase, int w_mod, Scheme_Object **get_names, Scheme_Object *skip_ribs, int *_binding_marks_skipped, - int *_depends_on_unsealed_rib, int depth, int get_free_id_info) + int *_depends_on_unsealed_rib, int depth, + Scheme_Hash_Table *free_id_recur) /* Module binding ignored if w_mod is 0. If module bound, result is module idx, and get_names[0] is set to source name, get_names[1] is set to the nominal source module, get_names[2] is set to @@ -4024,7 +4052,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (mresult_depends_unsealed) depends_on_unsealed_rib = 1; } else { - if (get_free_id_info && !SCHEME_VOIDP(result_free_rename)) { + if (free_id_recur && !SCHEME_VOIDP(result_free_rename)) { Scheme_Object *orig; int rib_dep = 0; orig = result_free_rename; @@ -4038,7 +4066,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, result = resolve_env(NULL, SCHEME_CAR(result_free_rename), phase, w_mod, get_names, NULL, _binding_marks_skipped, - &rib_dep, depth + 1, 1); + &rib_dep, depth + 1, free_id_recur); if (get_names && !get_names[1]) if (SCHEME_FALSEP(result) || SAME_OBJ(scheme_undefined, get_names[0])) get_names[1] = SCHEME_STX_VAL(SCHEME_CAR(result_free_rename)); @@ -4123,7 +4151,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, EXPLAIN(fprintf(stderr, "%d tl_id_sym\n", depth)); if (!bdg) { EXPLAIN(fprintf(stderr, "%d get bdg\n", depth)); - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, 0); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, NULL); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -4153,14 +4181,15 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, EXPLAIN(fprintf(stderr, "%d search %s\n", depth, scheme_write_to_string(glob_id, 0))); - if (get_free_id_info && mrn->free_id_renames) { + if (free_id_recur && mrn->free_id_renames) { rename = scheme_hash_get(mrn->free_id_renames, glob_id); if (rename && SCHEME_STXP(rename)) { int sealed; rename = extract_module_free_id_binding((Scheme_Object *)mrn, glob_id, rename, - &sealed); + &sealed, + free_id_recur); if (!sealed) mresult_depends_unsealed = 1; } @@ -4416,7 +4445,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (SCHEME_VOIDP(other_env)) { int rib_dep = 0; SCHEME_USE_FUEL(1); - other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, 0); + other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, NULL); { Scheme_Object *e; e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs, @@ -4449,7 +4478,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, top element of the stack and combine the two mappings, but the intermediate name may be needed (for other_env values that don't come from this stack). */ - if (get_free_id_info && !SCHEME_VOIDP(free_id_rename)) { + if (free_id_recur && !SCHEME_VOIDP(free_id_rename)) { /* Need to remember phase ad shifts for free-id=? rename: */ Scheme_Object *vec; vec = scheme_make_vector(4, NULL); @@ -4535,7 +4564,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } } -static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase, int use_free_id_renames) +static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase, + Scheme_Hash_Table *free_id_recur) /* Gets a module source name under the assumption that the identifier is not lexically renamed. This is used as a quick pre-test for free-identifier=?. We do have to look at lexical renames to check for @@ -4545,11 +4575,11 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ WRAP_POS wraps; Scheme_Object *result, *result_from; int is_in_module = 0, skip_other_mods = 0, sealed = STX_SEAL_ALL, floating_checked = 0; - int no_lexical = !use_free_id_renames; + int no_lexical = !free_id_recur; Scheme_Object *phase = orig_phase; Scheme_Object *bdg = NULL, *floating = NULL; - if (!use_free_id_renames + if (!free_id_recur && SAME_OBJ(phase, scheme_make_integer(0)) && ((Scheme_Stx *)a)->u.modinfo_cache) return ((Scheme_Stx *)a)->u.modinfo_cache; @@ -4568,7 +4598,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ if (!result) result = SCHEME_STX_VAL(a); - if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !use_free_id_renames) + if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !free_id_recur) ((Scheme_Stx *)a)->u.modinfo_cache = result; return result; @@ -4609,13 +4639,13 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ if (mrn->needs_unmarshal) { /* Use resolve_env to trigger unmarshal, so that we don't have to implement top/from shifts here: */ - resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, 0); + resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, NULL); } if (mrn->marked_names) { /* Resolve based on rest of wraps: */ if (!bdg) - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, 0); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, NULL); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -4634,14 +4664,15 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ } else glob_id = SCHEME_STX_VAL(a); - if (use_free_id_renames && mrn->free_id_renames) { + if (free_id_recur && mrn->free_id_renames) { rename = scheme_hash_get(mrn->free_id_renames, glob_id); if (rename && SCHEME_STXP(rename)) { int sealed; rename = extract_module_free_id_binding((Scheme_Object *)mrn, glob_id, rename, - &sealed); + &sealed, + free_id_recur); if (!sealed) sealed = 0; } @@ -4754,7 +4785,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ names[4] = NULL; names[5] = NULL; - modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, 1); + modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, free_id_recur); if (rib_dep) sealed = 0; @@ -4784,18 +4815,27 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym) { Scheme_Object *bsym; + Scheme_Hash_Table *free_id_recur; if (!a || !b) return (a == b); - if (SCHEME_STXP(b)) - bsym = get_module_src_name(b, phase, !asym); - else + if (SCHEME_STXP(b)) { + if (!asym) + free_id_recur = make_recur_table(); + else + free_id_recur = NULL; + bsym = get_module_src_name(b, phase, free_id_recur); + if (!asym) + release_recur_table(free_id_recur); + } else bsym = b; if (!asym) { - if (SCHEME_STXP(a)) - asym = get_module_src_name(a, phase, 1); - else + if (SCHEME_STXP(a)) { + free_id_recur = make_recur_table(); + asym = get_module_src_name(a, phase, free_id_recur); + release_recur_table(free_id_recur); + } else asym = a; } @@ -4805,9 +4845,14 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha if ((a == asym) || (b == bsym)) return 1; - - a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0, 1); - b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0, 1); + + free_id_recur = make_recur_table(); + a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur); + release_recur_table(free_id_recur); + + free_id_recur = make_recur_table(); + b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0, free_id_recur); + release_recur_table(free_id_recur); if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) a = scheme_module_resolve(a, 0); @@ -4826,12 +4871,12 @@ int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase) Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase) { if (SCHEME_STXP(a)) - return get_module_src_name(a, phase, 0); + return get_module_src_name(a, phase, NULL); else return a; } -Scheme_Object *scheme_stx_module_name(int recur, +Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *free_id_recur, Scheme_Object **a, Scheme_Object *phase, Scheme_Object **nominal_modidx, /* how it was imported */ Scheme_Object **nominal_name, /* imported as name */ @@ -4856,7 +4901,7 @@ Scheme_Object *scheme_stx_module_name(int recur, names[4] = NULL; names[5] = NULL; - modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, recur); + modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, free_id_recur); if (_sealed) *_sealed = !rib_dep; @@ -4902,8 +4947,8 @@ int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs) skip_ribs = SCHEME_CDR(skip_ribs); } - m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, 0); - m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, 0); + m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, NULL); + m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, NULL); return !SAME_OBJ(m1, m2); } @@ -4914,7 +4959,7 @@ Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a) if (SCHEME_STXP(a)) { Scheme_Object *r; - r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, 0); + r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, NULL); if (SCHEME_FALSEP(r)) r = check_floating_id(a); @@ -4946,13 +4991,13 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u if (!SAME_OBJ(asym, bsym)) return 0; - ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0, 0); + ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0, NULL); /* No need to module_resolve ae, because we ignored module renamings. */ if (uid) be = uid; else { - be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0, 0); + be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0, NULL); /* No need to module_resolve be, because we ignored module renamings. */ } @@ -4982,7 +5027,7 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) { scheme_explain_resolves++; - a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, 1); + a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, NULL); --scheme_explain_resolves; return a; } @@ -5379,16 +5424,19 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) Scheme_Object *nominal_src_phase; Scheme_Object *lex_env = NULL; Scheme_Object *vec, *phase; + Scheme_Hash_Table *free_id_recur; phase = SCHEME_CDR(id); id = SCHEME_CAR(id); nom2 = scheme_stx_property(id, nominal_id_symbol, NULL); - bind = scheme_stx_module_name(1, + free_id_recur = make_recur_table(); + bind = scheme_stx_module_name(free_id_recur, &id, phase, &nominal_modidx, &nominal_name, &mod_phase, &src_phase_index, &nominal_src_phase, &lex_env, NULL); + release_recur_table(free_id_recur); if (SCHEME_SYMBOLP(nom2)) nominal_name = nom2; @@ -5534,7 +5582,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab other_env = filter_cached_env(other_env, prec_ribs); if (SCHEME_VOIDP(other_env)) { int rib_dep; - other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, 0); + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL); if (rib_dep) { scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); return NULL; @@ -5707,7 +5755,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab other_env = filter_cached_env(other_env, prec_ribs); if (SCHEME_VOIDP(other_env)) { int rib_dep; - other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, 0); + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, NULL); if (rib_dep) { scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); return NULL; @@ -6119,15 +6167,16 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, if (mrn->free_id_renames->vals[i]) { if (SCHEME_STXP(mrn->free_id_renames->vals[i])) { int sealed; + Scheme_Hash_Table *free_id_recur; + + free_id_recur = make_recur_table(); b = extract_module_free_id_binding((Scheme_Object *)mrn, mrn->free_id_renames->keys[i], mrn->free_id_renames->vals[i], - &sealed); + &sealed, + free_id_recur); + release_recur_table(free_id_recur); if (!sealed) { - extract_module_free_id_binding((Scheme_Object *)mrn, - mrn->free_id_renames->keys[i], - mrn->free_id_renames->vals[i], - &sealed); scheme_signal_error("write: unsealed local-definition or module context" " found in syntax object"); } @@ -7800,7 +7849,7 @@ void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) if (SAME_OBJ(scheme_intern_symbol("y"), SCHEME_STX_VAL(stx))) { fprintf(stderr, "simplifying... %s\n", - scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, 0), + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL), NULL)); explain_simp = 1; } @@ -7818,7 +7867,7 @@ void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) if (explain_simp) { explain_simp = 0; fprintf(stderr, "simplified: %s\n", - scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, 0), + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, NULL), NULL)); } #endif @@ -8310,7 +8359,8 @@ Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) int skipped = -1; Scheme_Object *mod; - mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0, 1); + mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0, + scheme_make_hash_table(SCHEME_hash_ptr)); if ((skipped == -1) && SCHEME_FALSEP(mod)) { /* For top-level bindings, need to check the current environment's table, @@ -8436,7 +8486,7 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar phase = scheme_bin_plus(dphase, phase); } - m = scheme_stx_module_name(1, + m = scheme_stx_module_name(scheme_make_hash_table(SCHEME_hash_ptr), &a, phase, &nom_mod, &nom_a, From 0574391f0d7547c08a716df32bc973bcda848121 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Apr 2009 17:21:49 +0000 Subject: [PATCH 07/79] fix another problem with free-id= cycles svn: r14525 --- src/mzscheme/src/stxobj.c | 12 ++++++++---- 1 file changed, 8 insertions(+), 4 deletions(-) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 589e895744..942b31cfb9 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -4063,10 +4063,14 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, phase = scheme_bin_plus(phase, SCHEME_VEC_ELS(orig)[1]); if (get_names) get_names[1] = NULL; - result = resolve_env(NULL, SCHEME_CAR(result_free_rename), phase, - w_mod, get_names, - NULL, _binding_marks_skipped, - &rib_dep, depth + 1, free_id_recur); + result = SCHEME_CAR(result_free_rename); + if (!scheme_hash_get(free_id_recur, result)) { + scheme_hash_set(free_id_recur, result, scheme_true); + result = resolve_env(NULL, result, phase, + w_mod, get_names, + NULL, _binding_marks_skipped, + &rib_dep, depth + 1, free_id_recur); + } if (get_names && !get_names[1]) if (SCHEME_FALSEP(result) || SAME_OBJ(scheme_undefined, get_names[0])) get_names[1] = SCHEME_STX_VAL(SCHEME_CAR(result_free_rename)); From 119c69e1ad342ff802ab0f00ad566b8a19c410b6 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 15 Apr 2009 22:27:43 +0000 Subject: [PATCH 08/79] fix some problems and inefficiencies in saving and loading wxme streams svn: r14526 --- collects/browser/browser.scrbl | 7 +- collects/mred/private/wxme/cycle.ss | 2 + collects/mred/private/wxme/editor.ss | 23 ++-- collects/mred/private/wxme/snip.ss | 6 +- collects/mred/private/wxme/stream.ss | 169 ++++++++++++++---------- collects/scribblings/inside/ports.scrbl | 8 +- collects/tests/mred/wxme.ss | 9 +- 7 files changed, 123 insertions(+), 101 deletions(-) diff --git a/collects/browser/browser.scrbl b/collects/browser/browser.scrbl index 5a9df3288a..025d9a9bc0 100644 --- a/collects/browser/browser.scrbl +++ b/collects/browser/browser.scrbl @@ -8,6 +8,7 @@ browser/external browser/tool scheme/base + scheme/contract scheme/class scheme/gui/base net/url @@ -26,8 +27,8 @@ The @schememodname[browser] library provides the following procedures and classes for parsing and viewing HTML files. The @schememodname[browser/htmltext] library provides a simplified interface for rendering to a subclass of the MrEd @scheme[text%] -class. The [browser/external] library provides utilities for launching -an external browser (such as Firefox). +class. The @schememodname[browser/external] library provides utilities +for launching an external browser (such as Firefox). @section[#:tag "browser"]{Browser} @@ -80,7 +81,7 @@ examples). The Scheme code is executed through @scheme[eval]. The @(litchar "MZSCHEME") forms are disabled unless the web page is a @(litchar "file:") url that points into the @scheme[doc] collection. -@defproc[(open-url [url (or/c url? string? input-port?)]) void?]{ +@defproc[(open-url [url (or/c url? string? input-port?)]) (is-a?/c hyper-frame%)]{ Opens the given url in a vanilla browser frame and returns the frame. The frame is an instance of diff --git a/collects/mred/private/wxme/cycle.ss b/collects/mred/private/wxme/cycle.ss index 7bc9556321..ee30467e8d 100644 --- a/collects/mred/private/wxme/cycle.ss +++ b/collects/mred/private/wxme/cycle.ss @@ -25,3 +25,5 @@ (decl editor-put-file set-editor-put-file!) (decl popup-menu% set-popup-menu%!) + + diff --git a/collects/mred/private/wxme/editor.ss b/collects/mred/private/wxme/editor.ss index 086ba4441a..8df9606949 100644 --- a/collects/mred/private/wxme/editor.ss +++ b/collects/mred/private/wxme/editor.ss @@ -611,11 +611,8 @@ (and ;; Read headers (for/and ([i (in-range num-headers)]) - (let-boxes ([n 0] - [len 0]) - (begin - (send f get n) - (send f get-fixed len)) + (let ([n (send f get-exact)] + [len (send f get-fixed-exact)]) (and (send f ok?) (or (zero? len) (let ([sclass (send (send f get-s-scl) find-by-map-position f n)]) @@ -646,11 +643,10 @@ (let ([sclass (if (n . >= . 0) (send (send f get-s-scl) find-by-map-position f n) #f)]) ; -1 => unknown - (let-boxes ([len 0]) - (if (or (not sclass) - (not (send sclass get-s-required?))) - (send f get-fixed len) - (set-box! len -1)) + (let ([len (if (or (not sclass) + (not (send sclass get-s-required?))) + (send f get-fixed-exact) + -1)]) (and (send f ok?) (or (and (zero? len) accum) (and @@ -658,8 +654,7 @@ (let ([start (send f tell)]) (when (len . >= . 0) (send f set-boundary len)) - (let-boxes ([style-index 0]) - (send f get style-index) + (let ([style-index (send f get-exact)]) (let ([snip (send sclass read f)]) (and snip @@ -1337,7 +1332,7 @@ (editor-get-file "choose a file" (extract-parent) #f path)) (def/public (put-file [(make-or-false path-string?) dir] - [(make-or-false string?) suggested-name]) + [(make-or-false path-string?) suggested-name]) (editor-put-file "save file as" (extract-parent) dir suggested-name)) (def/public (set-load-overwrites-styles [any? b?]) @@ -1419,7 +1414,7 @@ (let ([sclass (snip->snipclass snip)]) (unless sclass (error 'write-snips-to-file "snip has no snipclass")) - (if (send f do-get-header-flag sclass) + (if (not (send f do-get-header-flag sclass)) (begin (send f put (send f do-map-position sclass)) (let ([header-start (send f tell)]) diff --git a/collects/mred/private/wxme/snip.ss b/collects/mred/private/wxme/snip.ss index 510e148d6a..6b2da06896 100644 --- a/collects/mred/private/wxme/snip.ss +++ b/collects/mred/private/wxme/snip.ss @@ -315,11 +315,9 @@ (s-read (make-object string-snip% 0) f)) (def/public (s-read [string-snip% snip] [editor-stream-in% f]) - (let-boxes ([flags 0]) - (send f get flags) + (let ([flags (send f get-exact)]) (let ([pos (send f tell)]) - (let-boxes ([count 0]) - (send f get count) + (let ([count (send f get-exact)]) (send f jump-to pos) (let ([count (if (count . < . 0) 10; this is a failure; we make up something diff --git a/collects/mred/private/wxme/stream.ss b/collects/mred/private/wxme/stream.ss index d5ed4bb417..85eb7d139a 100644 --- a/collects/mred/private/wxme/stream.ss +++ b/collects/mred/private/wxme/stream.ss @@ -99,7 +99,11 @@ (def/public (read-bytes [bytes? v] [exact-nonnegative-integer? [start 0]] [exact-nonnegative-integer? [end (bytes-length v)]]) - 0)) + 0) + (def/public (read-byte) + (let ([s (make-bytes 1)]) + (and (= 1 (read-bytes s 0 1)) + (bytes-ref s 0))))) (defclass editor-stream-out-base% object% (super-new) @@ -116,6 +120,8 @@ ;; ---------------------------------------- +(define mz:read-byte read-byte) + (defclass editor-stream-in-port-base% editor-stream-in-base% (init-field port) (super-new) @@ -137,7 +143,11 @@ (let ([r (read-bytes! v port start end)]) (if (eof-object? r) 0 - r)))) + r))) + + (def/override (read-byte) + (let ([v (mz:read-byte port)]) + (if (eof-object? v) #f v)))) (defclass editor-stream-in-file-base% editor-stream-in-port-base% (super-new)) @@ -182,6 +192,8 @@ ;; ---------------------------------------- +(define in-read-byte (generic editor-stream-in-base% read-byte)) + (defclass editor-stream-in% editor-stream% (init-rest args) @@ -216,48 +228,50 @@ (define (bad!) (set! is-bad? #t) 0) (if is-bad? 0 - (let ([s (make-bytes 1)]) - (let loop ([prev-byte 0]) - (if (not (= 1 (send f read-bytes s))) + (let loop ([prev-byte 0]) + (let ([b (send-generic f in-read-byte)]) + (if (not b) (bad!) - (let ([b (bytes-ref s 0)]) - (case (integer->char b) - [(#\#) - (let ([pos (send f tell)]) - (if (and (= 1 (send f read-bytes s)) - (= (bytes-ref s 0) (char->integer #\|))) - ;; skip to end of comment - (let cloop ([saw-bar? #f] - [saw-hash? #f] - [nesting 0]) - (if (not (= 1 (send f read-bytes s))) + (case (integer->char b) + [(#\#) + (let ([pos (send f tell)] + [b (send-generic f in-read-byte)]) + (if (and b + (= b (char->integer #\|))) + ;; skip to end of comment + (let cloop ([saw-bar? #f] + [saw-hash? #f] + [nesting 0]) + (let ([b (send-generic f in-read-byte)]) + (if (not b) (bad!) (cond - [(and saw-bar? (= (bytes-ref s 0) (char->integer #\#))) + [(and saw-bar? (= b (char->integer #\#))) (if (zero? nesting) (loop (char->integer #\space)) (cloop #f #f (sub1 nesting)))] - [(and saw-hash? (= (bytes-ref s 0) (char->integer #\|))) + [(and saw-hash? (= b (char->integer #\|))) (cloop #t #f (add1 nesting))] - [else (cloop (= (bytes-ref s 0) (char->integer #\|)) - (= (bytes-ref s 0) (char->integer #\#)) - nesting)]))) - (begin - (send f seek pos) - (char->integer #\#))))] - [(#\;) - ;; skip to end of comment - (let cloop () - (if (not (= 1 (send f read-bytes s))) + [else (cloop (= b (char->integer #\|)) + (= b (char->integer #\#)) + nesting)])))) + (begin + (send f seek pos) + (char->integer #\#))))] + [(#\;) + ;; skip to end of comment + (let cloop () + (let ([b (send-generic f in-read-byte)]) + (if (not b) (bad!) - (if (or (= (bytes-ref s 0) (char->integer #\newline)) - (= (bytes-ref s 0) (char->integer #\return))) + (if (or (= b (char->integer #\newline)) + (= b (char->integer #\return))) (loop (char->integer #\space)) - (cloop))))] - [else - (if (char-whitespace? (integer->char b)) - (loop b) - b)]))))))) + (cloop)))))] + [else + (if (char-whitespace? (integer->char b)) + (loop b) + b)])))))) (define/private (skip-whitespace [buf #f]) (let ([c (do-skip-whitespace)]) @@ -270,9 +284,8 @@ [(char-whitespace? (integer->char b)) #t] [(= b (char->integer #\#)) (let ([pos (send f tell)] - [s (make-bytes 1)]) - (send f read-bytes s) - (let ([d? (= (bytes-ref s 0) (char->integer #\|))]) + [b (send-generic f in-read-byte)]) + (let ([d? (= b (char->integer #\|))]) (send f seek (if d? (sub1 pos) pos)) d?))] [(= b (char->integer #\;)) @@ -284,36 +297,43 @@ (let ([c0 (skip-whitespace)]) (if (check-boundary) (if get-exact? 0 0.0) - (let* ([s (make-bytes 1)] - [l (cons (integer->char c0) - (let loop ([counter 50]) - (if (zero? counter) - null - (if (= 1 (send f read-bytes s)) - (let ([s (bytes-ref s 0)]) - (if (is-delim? s) - null - (cons (integer->char s) - (loop (sub1 counter))))) - null))))]) + (let* ([l + ;; As fast path, accum integer result + (let loop ([counter 50][c c0][v 0]) + (if (zero? counter) + null + (if (or (not c) + (is-delim? c)) + (or v null) + (let ([rest (loop (sub1 counter) + (send-generic f in-read-byte) + (and v + (c . >= . (char->integer #\0)) + (c . <= . (char->integer #\9)) + (+ (* v 10) (- c (char->integer #\0)))))]) + (if (exact-integer? rest) + rest + (cons (integer->char c) rest))))))]) (inc-item-count) - (let ([n (string->number (list->string l))]) + (let ([n (if (exact-integer? l) + l + (string->number (list->string l)))]) (cond - [(or (not n) - (not (real? n)) - (and get-exact? (not (exact-integer? n)))) - (set! is-bad? #t) - (if get-exact? 0 0.0)] - [get-exact? n] + [(and get-exact? (exact-integer? n)) n] + [(real? n) (exact->inexact n)] [else - (exact->inexact n)])))))) + (set! is-bad? #t) + (if get-exact? 0 0.0)])))))) (define/private (get-a-string limit recur?) (let* ([orig-len (if recur? (if (limit . < . 16) limit 16) - (get-exact))] + (let ([v (get-exact)]) + (if (check-boundary) + 0 + v)))] [buf (make-bytes 32)] [fail (lambda () (set! is-bad? #t) @@ -447,20 +467,22 @@ (success) (loop))))])))) + (def/public (get-fixed-exact) + (if (check-boundary) + 0 + (if (read-version . < . 8) + (let ([buf (make-bytes 4)]) + (send f read-bytes buf) + (integer-bytes->integer + buf + #t + (if (= read-version 1) + (system-big-endian?) + #t))) + (get-exact)))) + (def/public (get-fixed [box? vb]) - (let ([v (if (check-boundary) - 0 - (if (read-version . < . 8) - (let ([buf (make-bytes 4)]) - (send f read-bytes buf) - (integer-bytes->integer - buf - #t - (if (= read-version 1) - (system-big-endian?) - #t))) - (get-exact)))]) - (set-box! vb v))) + (set-box! vb (get-fixed-exact))) #| integer format specified by first byte: @@ -569,7 +591,7 @@ #t (cond [(and (pair? boundaries) - (items . > . (car boundaries))) + (items . >= . (car boundaries))) (set! is-bad? #t) (error 'editor-stream-in% "overread (caused by file corruption?; ~a vs ~a)" items (car boundaries))] @@ -647,6 +669,7 @@ (bytes-append spc (make-bytes (- 11 (string-length s)) (char->integer #\space)) (string->bytes/latin-1 s)))) + (set! col new-col) (set! items (add1 items))) this) diff --git a/collects/scribblings/inside/ports.scrbl b/collects/scribblings/inside/ports.scrbl index bb6ffc0f2d..4c8be45ac3 100644 --- a/collects/scribblings/inside/ports.scrbl +++ b/collects/scribblings/inside/ports.scrbl @@ -463,9 +463,9 @@ The functions are as follows. Called to obtain a progress event for the port, such as for @scheme[port-progress-evt]. This function can be @cpp{NULL} if the port does not support progress events. Use - @cpp{progress_evt_via_get} to obtain a default implementation, in + @cpp{scheme_progress_evt_via_get} to obtain a default implementation, in which case @var{peeked_read_fun} should be - @cpp{peeked_read_via_get}, and @var{get_bytes_fun} and + @cpp{scheme_peeked_read_via_get}, and @var{get_bytes_fun} and @var{peek_bytes_fun} should handle @var{unless} as described above.} @@ -477,9 +477,9 @@ The functions are as follows. Called to commit previously peeked bytes, just like the sixth argument to @scheme[make-input-port]. Use - @cpp{peeked_read_via_get} for the default implementation of + @cpp{scheme_peeked_read_via_get} for the default implementation of commits when @var{progress_evt_fun} is - @cpp{progress_evt_via_get}.} + @cpp{scheme_progress_evt_via_get}.} @subfunction[(int char_ready_fun [Scheme_Input_Port* port])]{ diff --git a/collects/tests/mred/wxme.ss b/collects/tests/mred/wxme.ss index 3870cd3b20..869d90c448 100644 --- a/collects/tests/mred/wxme.ss +++ b/collects/tests/mred/wxme.ss @@ -768,12 +768,15 @@ (expect (send fi2 tell) 10) (send fi2 jump-to 3) -(send fi2 set-boundary 5) +(send fi2 set-boundary 2) (expect (send fi2 get-unterminated-bytes) #"hi") (send fi2 jump-to 3) (expect (send fi2 ok?) #t) -(send fi2 set-boundary 4) -(expect (send fi2 get-unterminated-bytes) #"") +(expect (send fi2 tell) 3) +(send fi2 set-boundary 1) +(expect (with-handlers ([values (lambda (exn) #"")]) + (send fi2 get-unterminated-bytes)) + #"") (expect (send fi2 ok?) #f) ;; ---------------------------------------- From 7aadcfddfaa108b11e4f1508d9006cd9bbcc0748 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 16 Apr 2009 07:50:18 +0000 Subject: [PATCH 09/79] Welcome to a new PLT day. svn: r14527 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index a83a3d051b..90ce8ccd8f 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "15apr2009") +#lang scheme/base (provide stamp) (define stamp "16apr2009") From 0c2c04e168ef6caaec143099d96745a8112a8c1d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 16 Apr 2009 17:18:35 +0000 Subject: [PATCH 10/79] shrunk the height of the preferences window svn: r14528 --- collects/drscheme/private/main.ss | 10 +++- collects/framework/main.ss | 16 +++++- collects/framework/private/preferences.ss | 60 ++++++++++++++--------- collects/framework/private/sig.ss | 2 + 4 files changed, 63 insertions(+), 25 deletions(-) diff --git a/collects/drscheme/private/main.ss b/collects/drscheme/private/main.ss index 9068fe5f89..5748249977 100644 --- a/collects/drscheme/private/main.ss +++ b/collects/drscheme/private/main.ss @@ -226,6 +226,7 @@ null list?) + (drscheme:font:setup-preferences) (color-prefs:add-background-preferences-panel) (scheme:add-preferences-panel) @@ -233,6 +234,7 @@ (preferences:add-editor-checkbox-panel) (preferences:add-warnings-checkbox-panel) (preferences:add-scheme-checkbox-panel) +(preferences:add-general-checkbox-panel) (let ([make-check-box (λ (pref-sym string parent) @@ -245,7 +247,7 @@ (send checkbox get-value))))]) (preferences:add-callback pref-sym (λ (p v) (send q set-value v))) (send q set-value (preferences:get pref-sym))))]) - (preferences:add-to-editor-checkbox-panel + (preferences:add-to-general-checkbox-panel (λ (editor-panel) (make-check-box 'drscheme:open-in-tabs (string-constant open-files-in-tabs) @@ -264,7 +266,11 @@ (make-check-box 'drscheme:module-language-first-line-special? (string-constant ml-always-show-#lang-line) - editor-panel) + editor-panel))) + + (preferences:add-to-editor-checkbox-panel + (λ (editor-panel) + (void) ;; come back to this one. #; diff --git a/collects/framework/main.ss b/collects/framework/main.ss index 0f16c0fc9d..c85f5de883 100644 --- a/collects/framework/main.ss +++ b/collects/framework/main.ss @@ -198,6 +198,12 @@ @{Adds a preferences panel for configuring options related to editing.}) + (proc-doc/names + preferences:add-general-checkbox-panel + (-> void?) + () + @{Adds a catch-all preferences panel for options.}) + (proc-doc/names preferences:add-warnings-checkbox-panel (-> void?) @@ -232,7 +238,15 @@ (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) (proc) @{Saves @scheme[proc] until the preferences panel is created, when it - is called with the Echeme preferences panel to add new children to + is called with the editor preferences panel to add new children to + the panel.}) + + (proc-doc/names + preferences:add-to-general-checkbox-panel + (((is-a?/c vertical-panel%) . -> . void?) . -> . void?) + (proc) + @{Saves @scheme[proc] until the preferences panel is created, when it + is called with the general preferences panel to add new children to the panel.}) (proc-doc/names diff --git a/collects/framework/private/preferences.ss b/collects/framework/private/preferences.ss index 5bb3db1dde..c2a10f4065 100644 --- a/collects/framework/private/preferences.ss +++ b/collects/framework/private/preferences.ss @@ -227,8 +227,9 @@ the state transitions / contracts are: (super show on?)) (super-new))] [frame - (make-object frame-stashed-prefs% - (string-constant preferences))] + (new frame-stashed-prefs% + [label (string-constant preferences)] + [height 200])] [build-ppanel-tree (λ (ppanel tab-panel single-panel) (send tab-panel append (ppanel-name ppanel)) @@ -310,6 +311,11 @@ the state transitions / contracts are: (let ([old editor-panel-procs]) (λ (parent) (old parent) (f parent))))) + (define (add-to-general-checkbox-panel f) + (set! general-panel-procs + (let ([old general-panel-procs]) + (λ (parent) (old parent) (f parent))))) + (define (add-to-warnings-checkbox-panel f) (set! warnings-panel-procs (let ([old warnings-panel-procs]) @@ -317,6 +323,7 @@ the state transitions / contracts are: (define scheme-panel-procs void) (define editor-panel-procs void) + (define general-panel-procs void) (define warnings-panel-procs void) (define (add-checkbox-panel label proc) @@ -394,21 +401,8 @@ the state transitions / contracts are: (list (string-constant editor-prefs-panel-label) (string-constant general-prefs-panel-label)) (λ (editor-panel) - (make-recent-items-slider editor-panel) - (make-check editor-panel - 'framework:autosaving-on? - (string-constant auto-save-files) - values values) - (make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values) (make-check editor-panel 'framework:delete-forward? (string-constant map-delete-to-backspace) not not) - (make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values) - (make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values) - (make-check editor-panel - 'framework:display-line-numbers - (string-constant display-line-numbers) - values values) - (make-check editor-panel 'framework:auto-set-wrap? (string-constant wrap-words-in-editor-buffers) @@ -432,13 +426,7 @@ the state transitions / contracts are: 'framework:coloring-active (string-constant online-coloring-active) values values) - (unless (eq? (system-type) 'unix) - (make-check editor-panel - 'framework:print-output-mode - (string-constant automatically-to-ps) - (λ (b) - (if b 'postscript 'standard)) - (λ (n) (eq? 'postscript n)))) + (make-check editor-panel 'framework:anchored-search (string-constant find-anchor-based) @@ -454,6 +442,34 @@ the state transitions / contracts are: (editor-panel-procs editor-panel))))]) (add-editor-checkbox-panel))) + (define (add-general-checkbox-panel) + (letrec ([add-general-checkbox-panel + (λ () + (set! add-general-checkbox-panel void) + (add-checkbox-panel + (list (string-constant general-prefs-panel-label)) + (λ (editor-panel) + (make-recent-items-slider editor-panel) + (make-check editor-panel + 'framework:autosaving-on? + (string-constant auto-save-files) + values values) + (make-check editor-panel 'framework:backup-files? (string-constant backup-files) values values) + (make-check editor-panel 'framework:show-status-line (string-constant show-status-line) values values) + (make-check editor-panel 'framework:col-offsets (string-constant count-columns-from-one) values values) + (make-check editor-panel + 'framework:display-line-numbers + (string-constant display-line-numbers) + values values) + (unless (eq? (system-type) 'unix) + (make-check editor-panel + 'framework:print-output-mode + (string-constant automatically-to-ps) + (λ (b) + (if b 'postscript 'standard)) + (λ (n) (eq? 'postscript n)))))))]) + (add-general-checkbox-panel))) + (define (add-warnings-checkbox-panel) (letrec ([add-warnings-checkbox-panel (λ () diff --git a/collects/framework/private/sig.ss b/collects/framework/private/sig.ss index 32e5a03316..ec23b69f8f 100644 --- a/collects/framework/private/sig.ss +++ b/collects/framework/private/sig.ss @@ -74,10 +74,12 @@ add-font-panel add-editor-checkbox-panel + add-general-checkbox-panel add-warnings-checkbox-panel add-scheme-checkbox-panel add-to-editor-checkbox-panel + add-to-general-checkbox-panel add-to-warnings-checkbox-panel add-to-scheme-checkbox-panel From 709ad23400dab6a39cf3499be13896434414d2fa Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Apr 2009 19:01:20 +0000 Subject: [PATCH 11/79] performance improvements: class local-field access uses accessor with index built in (so the index is checked once); JIT partially inlines struct-field mutation svn: r14530 --- collects/mred/private/wxme/text.ss | 149 +++++------ collects/mred/private/wxme/undo.ss | 3 +- collects/scheme/private/class-internal.ss | 252 ++++++++++--------- src/mzscheme/src/jit.c | 289 +++++++++++++--------- 4 files changed, 381 insertions(+), 312 deletions(-) diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 9f14bf29be..2b297eaa49 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -384,7 +384,7 @@ (not (zero? how-close)) ((abs how-close) . > . between-threshold))]) (let ([snip (and onit? - (find-snip pos 'after))]) + (do-find-snip pos 'after))]) (and snip (let-boxes ([x 0.0] [y 0.0]) (get-snip-position-and-location snip #f x y) @@ -428,7 +428,7 @@ ((abs how-close) . > . between-threshold))]) (if onit? ;; we're in the snip's horizontal region... - (let ([snip (find-snip now 'after)]) + (let ([snip (do-find-snip now 'after)]) ;; ... but maybe the mouse is above or below it. (let-boxes ([top 0.0] [bottom 0.0] @@ -1332,7 +1332,7 @@ (let* ([gsnip (if (not did-one?) (begin (make-snipset start start) - (find-snip start 'after-or-none)) + (do-find-snip start 'after-or-none)) before-snip)] [before-snip (or before-snip gsnip)] [inserted-new-line? @@ -1534,7 +1534,7 @@ [(or (equal? c #\newline) (equal? c #\tab)) (let ([newline? (equal? c #\newline)]) (make-snipset (+ i start) (+ i start 1)) - (let ([snip (find-snip (+ i start) 'after)]) + (let ([snip (do-find-snip (+ i start) 'after)]) (if newline? ;; forced return - split the snip @@ -1611,7 +1611,7 @@ (when (eq? (mline-last-snip (snip->line snip)) snip) (set-mline-last-snip! (snip->line tabsnip) tabsnip)))))) - (let ([snip (find-snip (+ i start 1) 'after)]) + (let ([snip (do-find-snip (+ i start 1) 'after)]) (let ([i (add1 i)]) (loop (+ i start) (if (= i addlen) #f (string-snip-buffer snip)) @@ -1623,7 +1623,7 @@ [(cnt . > . MAX-COUNT-FOR-SNIP) ;; divide up snip, because it's too large: (make-snipset (+ i start) (+ i start)) - (let ([snip (find-snip (+ i start) 'after)]) + (let ([snip (do-find-snip (+ i start) 'after)]) (loop (+ i start) (string-snip-buffer snip) (add1 (string-snip-dtext snip)) @@ -1711,8 +1711,8 @@ (make-snipset start end) (set! revision-count (add1 revision-count)) - (let* ([start-snip (find-snip start 'before-or-none)] - [end-snip (find-snip end 'before)] + (let* ([start-snip (do-find-snip start 'before-or-none)] + [end-snip (do-find-snip end 'before)] [with-undo? (and with-undo? (zero? s-noundomode))] [rec (if with-undo? @@ -1956,8 +1956,8 @@ s-style-list)]) (set-common-copy-region-data! (get-region-data startp endp)) - (let ([start (find-snip startp 'after)] - [end (find-snip endp 'after-or-none)] + (let ([start (do-find-snip startp 'after)] + [end (do-find-snip endp 'after-or-none)] [wl? write-locked?] [fl? flow-locked?]) @@ -2050,7 +2050,7 @@ (let ([addpos (snip->count snip)]) (insert snip read-insert) (when data - (let ([snip (find-snip read-insert 'after)]) + (let ([snip (do-find-snip read-insert 'after)]) (set-snip-data snip data))) (set! read-insert (+ read-insert addpos)))) @@ -2300,8 +2300,8 @@ ((clickback-end c) . > . start) ;; we're in the right horizontal region, but maybe the mouse ;; is above or below the clickback - (let ([start (find-snip (clickback-start c) 'after)] - [end (find-snip (clickback-end c) 'before)]) + (let ([start (do-find-snip (clickback-start c) 'after)] + [end (do-find-snip (clickback-end c) 'before)]) (and start end (let-boxes ([top 0.0] @@ -2510,18 +2510,20 @@ (send s-style-list new-named-style "Standard" (send s-style-list basic-style)) (send mf ok?))))))] [(or (eq? format 'text) (eq? format 'text-force-cr)) - (let loop ([saved-cr? #f]) - (let ([l (read-string 256 f)]) - (unless (eof-object? l) - (let ([l2 (if (equal? l "") - l - (if (equal? #\return (string-ref l (sub1 (string-length l)))) - (substring l 0 (sub1 (string-length l))) - l))]) - (insert (regexp-replace* #rx"\r\n" - (if saved-cr? (string-append "\r" l2) l2) - "\n")) - (loop (not (eq? l l2))))))) + (let ([s (make-string 1024)]) + (let loop ([saved-cr? #f]) + (let ([len (read-string! s f)]) + (unless (eof-object? len) + (let* ([s1 (if (= len (string-length s)) + s + (substring s 0 len))] + [s2 (if (equal? #\return (string-ref s1 (sub1 len))) + (substring s1 0 (sub1 len)) + s1)]) + (insert (regexp-replace* #rx"\r\n" + (if saved-cr? (string-append "\r" s2) s2) + "\n")) + (loop (not (eq? s1 s2)))))))) #f])]) (when fileerr? @@ -2605,8 +2607,8 @@ len end) start)]) - (let ([start-snip (if (zero? len) #f (find-snip start 'after))] - [end-snip (if (zero? len) #f (find-snip end 'after-or-none))]) + (let ([start-snip (if (zero? len) #f (do-find-snip start 'after))] + [end-snip (if (zero? len) #f (do-find-snip end 'after-or-none))]) (and (do-write-headers-footers f #t) (write-snips-to-file f s-style-list #f start-snip end-snip #f this) (do-write-headers-footers f #f)))))) @@ -3524,7 +3526,7 @@ (cond [new-style new-style] [caret-style (send s-style-list find-or-create-style caret-style delta)] - [else (let ([gsnip (find-snip start 'before)]) + [else (let ([gsnip (do-find-snip start 'before)]) (send s-style-list find-or-create-style (snip->style gsnip) delta))])))] [else (set! write-locked? #t) @@ -3544,7 +3546,7 @@ (begin (set! initial-style-needed? #f) (values snips #f)) - (values (find-snip start 'after) (find-snip end 'after-or-none)))] + (values (do-find-snip start 'after) (do-find-snip end 'after-or-none)))] [(rec) (and (zero? s-noundomode) (make-object style-change-record% start end @@ -4007,8 +4009,6 @@ (set! write-locked? #t) (set! flow-locked? #t) - (set-box! a-ptr #f) - (set-box! b-ptr #f) (send snip split pos a-ptr b-ptr) (set! read-locked? #f) @@ -4071,7 +4071,8 @@ (splice-snip snip prev next) (set! snip-count (add1 snip-count)) (insert-snip snip ins-snip) - (extra snip) + (when extra + (extra snip)) (snip-set-admin snip snip-admin) (snip-set-admin ins-snip snip-admin) @@ -4084,11 +4085,11 @@ (let-values ([(snip s-pos) (find-snip/pos start 'after-or-none)]) (when snip (unless (= s-pos start) - (split-one start s-pos snip void))))) + (split-one start s-pos snip #f))))) (when (positive? end) (let-values ([(snip s-pos) (find-snip/pos end 'before)]) (unless (= (+ s-pos (snip->count snip)) end) - (split-one end s-pos snip void))))) + (split-one end s-pos snip #f))))) (define/private (insert-text-snip start style) (let* ([snip (on-new-string-snip)] @@ -4257,6 +4258,11 @@ #f snips)) + (define/private (do-find-snip p direction) + ;; BEWARE: `len' may not be up-to-date + (let-values ([(snip pos) (find-snip/pos p direction)]) + snip)) + (def/public (find-snip [exact-nonnegative-integer? p] [(symbol-in before-or-none before after after-or-none) direction] [maybe-box? [s-pos #f]]) @@ -4270,48 +4276,49 @@ (cond [(and (eq? direction 'before-or-none) (zero? p)) (values #f 0)] - [(and (eq? direction 'after-or-none) (p . >= . (let ([l (mline-last (unbox line-root-box))]) - (+ (mline-get-position l) - (mline-len l))))) - (values #f 0)] [else (let* ([line (mline-find-position (unbox line-root-box) p)] [pos (mline-get-position line)] [p (- p pos)]) + (if (and (eq? direction 'after-or-none) + (not (mline-next line)) + (p . >= . (mline-len line))) + ;; past the end: + (values #f 0) + ;; within the line: + (let-values ([(snip pos p) + (let ([snip (mline-snip line)]) + (if (and (zero? p) (snip->prev snip)) + ;; back up one: + (let ([snip (snip->prev snip)]) + (values snip + (- pos (snip->count snip)) + (+ p (snip->count snip)))) + (values snip pos p)))]) - (let-values ([(snip pos p) - (let ([snip (mline-snip line)]) - (if (and (zero? p) (snip->prev snip)) - ;; back up one: - (let ([snip (snip->prev snip)]) - (values snip - (- pos (snip->count snip)) - (+ p (snip->count snip)))) - (values snip pos p)))]) - - (let loop ([snip snip] - [pos pos] - [p p]) - (if snip - (let ([p (- p (snip->count snip))]) - (cond - [(or (and (eq? direction 'on) - (zero? p)) - (and (or (eq? direction 'before) - (eq? direction 'before-or-none)) - (p . <= . 0)) - (and (or (eq? direction 'after) - (eq? direction 'after-or-none)) - (p . < . 0))) - (values snip pos)] - [(and (eq? direction 'on) - (p . < . 0)) - (values #f 0)] - [else - (loop (snip->next snip) (+ pos (snip->count snip)) p)])) - (if (not (eq? direction 'after-or-none)) - (values last-snip (- pos (snip->count last-snip))) - (values #f 0))))))])) + (let loop ([snip snip] + [pos pos] + [p p]) + (if snip + (let ([p (- p (snip->count snip))]) + (cond + [(or (and (eq? direction 'on) + (zero? p)) + (and (or (eq? direction 'before) + (eq? direction 'before-or-none)) + (p . <= . 0)) + (and (or (eq? direction 'after) + (eq? direction 'after-or-none)) + (p . < . 0))) + (values snip pos)] + [(and (eq? direction 'on) + (p . < . 0)) + (values #f 0)] + [else + (loop (snip->next snip) (+ pos (snip->count snip)) p)])) + (if (not (eq? direction 'after-or-none)) + (values last-snip (- pos (snip->count last-snip))) + (values #f 0)))))))])) (def/public (find-next-non-string-snip [(make-or-false snip%) snip]) (if (or (and snip diff --git a/collects/mred/private/wxme/undo.ss b/collects/mred/private/wxme/undo.ss index 15f44fbdc3..053b3f82fe 100644 --- a/collects/mred/private/wxme/undo.ss +++ b/collects/mred/private/wxme/undo.ss @@ -4,7 +4,8 @@ "snip.ss" "snip-flags.ss") -(provide proc-record% +(provide change-record% + proc-record% unmodify-record% insert-record% insert-snip-record% diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index a9040846b5..bf852444a1 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -1131,6 +1131,8 @@ (if (null? l) null (cons pos (loop (add1 pos) (cdr l)))))] + [(local-field-accessor ...) (generate-temporaries (append field-names private-field-names))] + [(local-field-mutator ...) (generate-temporaries (append field-names private-field-names))] [(plain-init-name ...) (definify plain-init-names)] [(plain-init-name-localized ...) (map lookup-localize plain-init-names)] [(local-plain-init-name ...) (generate-temporaries plain-init-names)]) @@ -1164,9 +1166,9 @@ (quote the-obj) (quote-syntax local-field) (quote-syntax local-field-localized) - (quote-syntax local-accessor) - (quote-syntax local-mutator) - '(local-field-pos)) + (quote-syntax local-field-accessor) + (quote-syntax local-field-mutator) + '()) ... (make-rename-super-map (quote-syntax the-finder) (quote the-obj) @@ -1324,126 +1326,130 @@ rename-super-temp ... rename-super-extra-temp ... rename-inner-temp ... rename-inner-extra-temp ... method-accessor ...) ; for a local call that needs a dynamic lookup - (syntax-parameterize - ([this-param (make-this-map (quote-syntax this-id) - (quote-syntax the-finder) - (quote the-obj))]) - (let-syntaxes - mappings - (syntax-parameterize - ([super-param - (lambda (stx) - (syntax-case stx (rename-super-extra-orig ...) - [(_ rename-super-extra-orig . args) - (generate-super-call - stx - (quote-syntax the-finder) - (quote the-obj) - (quote-syntax rename-super-extra-temp) - (syntax args))] - ... - [(_ id . args) - (identifier? #'id) - (raise-syntax-error - #f - (string-append - "identifier for super call does not have an override, " - "override-final, overment, or inherit/super declaration") - stx - #'id)] - [_else - (raise-syntax-error - #f - "expected an identifier after the keyword" - stx)]))] - [inner-param - (lambda (stx) - (syntax-case stx (rename-inner-extra-orig ...) - [(_ default-expr rename-inner-extra-orig . args) - (generate-inner-call - stx - (quote-syntax the-finder) - (quote the-obj) - (syntax default-expr) - (quote-syntax rename-inner-extra-temp) - (syntax args))] - ... - [(_ default-expr id . args) - (identifier? #'id) - (raise-syntax-error - #f - (string-append - "identifier for inner call does not have a pubment, augment, " - "overment, or inherit/inner declaration") - stx - #'id)] - [(_) - (raise-syntax-error - #f - "expected a default-value expression after the keyword" - stx - #'id)] - [_else - (raise-syntax-error - #f - "expected an identifier after the keyword and default-value expression" - stx)]))]) - stx-def ... - (letrec ([private-temp private-method] - ... - [pubment-temp pubment-method] - ... - [public-final-temp public-final-method] - ...) - (values - (list pubment-temp ... public-final-temp ... . public-methods) - (list . override-methods) - (list . augride-methods) - ;; Initialization - #, ;; Attach srcloc (useful for profiling) - (quasisyntax/loc stx - (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) - (let-syntax ([the-finder (quote-syntax the-obj)]) - (syntax-parameterize - ([super-instantiate-param - (lambda (stx) - (syntax-case stx () - [(_ (arg (... ...)) (kw kwarg) (... ...)) - (with-syntax ([stx stx]) - (syntax (-instantiate super-go stx (the-obj si_c si_inited? - si_leftovers) - (list arg (... ...)) - (kw kwarg) (... ...))))]))] - [super-new-param - (lambda (stx) - (syntax-case stx () - [(_ (kw kwarg) (... ...)) - (with-syntax ([stx stx]) - (syntax (-instantiate super-go stx (the-obj si_c si_inited? - si_leftovers) - null - (kw kwarg) (... ...))))]))] - [super-make-object-param - (lambda (stx) - (let ([code - (quote-syntax - (lambda args - (super-go the-obj si_c si_inited? si_leftovers args null)))]) - (if (identifier? stx) - code - (datum->syntax - code - (cons code - (cdr (syntax-e stx)))))))]) - (letrec-syntaxes+values - ([(plain-init-name) (make-init-redirect - (quote-syntax set!) - (quote-syntax #%plain-app) - (quote-syntax local-plain-init-name) - (quote-syntax plain-init-name-localized))] ...) - ([(local-plain-init-name) undefined] ...) - (void) ; in case the body is empty - . exprs)))))))))))) + (let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos)] + ... + [local-field-mutator (make-struct-field-mutator local-mutator local-field-pos)] + ...) + (syntax-parameterize + ([this-param (make-this-map (quote-syntax this-id) + (quote-syntax the-finder) + (quote the-obj))]) + (let-syntaxes + mappings + (syntax-parameterize + ([super-param + (lambda (stx) + (syntax-case stx (rename-super-extra-orig ...) + [(_ rename-super-extra-orig . args) + (generate-super-call + stx + (quote-syntax the-finder) + (quote the-obj) + (quote-syntax rename-super-extra-temp) + (syntax args))] + ... + [(_ id . args) + (identifier? #'id) + (raise-syntax-error + #f + (string-append + "identifier for super call does not have an override, " + "override-final, overment, or inherit/super declaration") + stx + #'id)] + [_else + (raise-syntax-error + #f + "expected an identifier after the keyword" + stx)]))] + [inner-param + (lambda (stx) + (syntax-case stx (rename-inner-extra-orig ...) + [(_ default-expr rename-inner-extra-orig . args) + (generate-inner-call + stx + (quote-syntax the-finder) + (quote the-obj) + (syntax default-expr) + (quote-syntax rename-inner-extra-temp) + (syntax args))] + ... + [(_ default-expr id . args) + (identifier? #'id) + (raise-syntax-error + #f + (string-append + "identifier for inner call does not have a pubment, augment, " + "overment, or inherit/inner declaration") + stx + #'id)] + [(_) + (raise-syntax-error + #f + "expected a default-value expression after the keyword" + stx + #'id)] + [_else + (raise-syntax-error + #f + "expected an identifier after the keyword and default-value expression" + stx)]))]) + stx-def ... + (letrec ([private-temp private-method] + ... + [pubment-temp pubment-method] + ... + [public-final-temp public-final-method] + ...) + (values + (list pubment-temp ... public-final-temp ... . public-methods) + (list . override-methods) + (list . augride-methods) + ;; Initialization + #, ;; Attach srcloc (useful for profiling) + (quasisyntax/loc stx + (lambda (the-obj super-go si_c si_inited? si_leftovers init-args) + (let-syntax ([the-finder (quote-syntax the-obj)]) + (syntax-parameterize + ([super-instantiate-param + (lambda (stx) + (syntax-case stx () + [(_ (arg (... ...)) (kw kwarg) (... ...)) + (with-syntax ([stx stx]) + (syntax (-instantiate super-go stx (the-obj si_c si_inited? + si_leftovers) + (list arg (... ...)) + (kw kwarg) (... ...))))]))] + [super-new-param + (lambda (stx) + (syntax-case stx () + [(_ (kw kwarg) (... ...)) + (with-syntax ([stx stx]) + (syntax (-instantiate super-go stx (the-obj si_c si_inited? + si_leftovers) + null + (kw kwarg) (... ...))))]))] + [super-make-object-param + (lambda (stx) + (let ([code + (quote-syntax + (lambda args + (super-go the-obj si_c si_inited? si_leftovers args null)))]) + (if (identifier? stx) + code + (datum->syntax + code + (cons code + (cdr (syntax-e stx)))))))]) + (letrec-syntaxes+values + ([(plain-init-name) (make-init-redirect + (quote-syntax set!) + (quote-syntax #%plain-app) + (quote-syntax local-plain-init-name) + (quote-syntax plain-init-name-localized))] ...) + ([(local-plain-init-name) undefined] ...) + (void) ; in case the body is empty + . exprs))))))))))))) ;; Not primitive: #f)))))))))))))))) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 700c6f4af9..ce2e21c67a 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -142,6 +142,7 @@ static void *stack_cache_pop_code; static void *struct_pred_code, *struct_pred_multi_code; static void *struct_pred_branch_code; static void *struct_get_code, *struct_get_multi_code; +static void *struct_set_code, *struct_set_multi_code; static void *bad_app_vals_target; static void *app_values_slow_code, *app_values_multi_slow_code, *app_values_tail_slow_code; static void *finish_tail_call_code, *finish_tail_call_fixup_code; @@ -201,6 +202,9 @@ static void generate_non_tail_mark_pos_suffix(mz_jit_state *jitter); static void *generate_shared_call(int num_rands, mz_jit_state *old_jitter, int multi_ok, int is_tail, int direct_prim, int direct_native, int nontail_self); +static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter, + int order_matters, int skipped); + static int is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_state *jitter, int stack_start); static int lambda_has_been_jitted(Scheme_Native_Closure_Data *ndata); @@ -1492,31 +1496,36 @@ Scheme_Object *extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter, i return NULL; } -static int check_val_struct_prim(Scheme_Object *p) +static int check_val_struct_prim(Scheme_Object *p, int arity) { if (p && SCHEME_PRIMP(p)) { - if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_PRED) - return 1; - else if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER) - return 2; - else - return 0; - } else - return 0; + if (arity == 1) { + if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_PRED) + return 1; + else if (((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER) + return 2; + } else if (arity == 2) { + if ((((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_IS_STRUCT_OTHER) + && ((((Scheme_Primitive_Proc *)p)->pp.flags & SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK) + == SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER)) + return 3; + } + } + return 0; } -static int inlineable_struct_prim(Scheme_Object *o, mz_jit_state *jitter, int extra_push) +static int inlineable_struct_prim(Scheme_Object *o, mz_jit_state *jitter, int extra_push, int arity) { if (jitter->nc) { if (SAME_TYPE(SCHEME_TYPE(o), scheme_toplevel_type)) { Scheme_Object *p; p = extract_global(o, jitter->nc); p = ((Scheme_Bucket *)p)->val; - return check_val_struct_prim(p); + return check_val_struct_prim(p, arity); } else if (SAME_TYPE(SCHEME_TYPE(o), scheme_local_type)) { Scheme_Object *p; p = extract_closure_local(o, jitter, extra_push); - return check_val_struct_prim(p); + return check_val_struct_prim(p, arity); } } return 0; @@ -1528,23 +1537,24 @@ static int inlined_unary_prim(Scheme_Object *o, Scheme_Object *_app, mz_jit_stat && (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_UNARY_INLINED)) return 1; - if (inlineable_struct_prim(o, jitter, 1)) + if (inlineable_struct_prim(o, jitter, 1, 1)) return 1; return 0; } -static int inlined_binary_prim(Scheme_Object *o, Scheme_Object *_app) +static int inlined_binary_prim(Scheme_Object *o, Scheme_Object *_app, mz_jit_state *jitter) { - return (SCHEME_PRIMP(o) - && (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_BINARY_INLINED)); + return ((SCHEME_PRIMP(o) + && (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_BINARY_INLINED)) + || inlineable_struct_prim(o, jitter, 1, 2)); } static int inlined_nary_prim(Scheme_Object *o, Scheme_Object *_app) { return (SCHEME_PRIMP(o) - && (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_NARY_INLINED) - && (((Scheme_App_Rec *)_app)->num_args >= ((Scheme_Primitive_Proc *)o)->mina) + && (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_NARY_INLINED) + && (((Scheme_App_Rec *)_app)->num_args >= ((Scheme_Primitive_Proc *)o)->mina) && (((Scheme_App_Rec *)_app)->num_args <= ((Scheme_Primitive_Proc *)o)->mu.maxa)); } @@ -1670,7 +1680,7 @@ static int is_simple(Scheme_Object *obj, int depth, int just_markless, mz_jit_st } break; case scheme_application3_type: - if (inlined_binary_prim(((Scheme_App2_Rec *)obj)->rator, obj)) + if (inlined_binary_prim(((Scheme_App2_Rec *)obj)->rator, obj, jitter)) return 1; else if (just_markless) { return is_noncm(((Scheme_App3_Rec *)obj)->rator, jitter, depth, stack_start + 2); @@ -2603,7 +2613,9 @@ static int can_direct_native(Scheme_Object *p, int num_rands, long *extract_case static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands, mz_jit_state *jitter, int is_tail, int multi_ok, int no_call) -/* de-sync'd ok */ +/* de-sync'd ok + If no_call is 2, then rator is not necssarily evaluated. + If no_call is 1, then rator is left in V1 and arguments are on runstack. */ { int i, offset, need_safety = 0; int direct_prim = 0, need_non_tail = 0, direct_native = 0, direct_self = 0, nontail_self = 0; @@ -2840,7 +2852,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } if (reorder_ok) { - if (!no_call) { + if (no_call < 2) { generate(rator, jitter, 0, 0, JIT_V1); /* sync'd below */ } CHECK_LIMIT(); @@ -3893,42 +3905,33 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app } static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, - Scheme_Object *rator, Scheme_Object *rand, + Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2, jit_insn **for_branch, int branch_short, int multi_ok) /* de-sync'd ok; for branch, sync'd before */ { - mz_runstack_skipped(jitter, 1); - LOG_IT(("inlined struct op\n")); - generate(rator, jitter, 0, 0, JIT_R0); /* sync'd below */ - CHECK_LIMIT(); - - if (SAME_TYPE(scheme_local_type, SCHEME_TYPE(rand))) { - jit_movr_p(JIT_R1, JIT_R0); - generate(rand, jitter, 0, 0, JIT_R0); /* sync'd below */ - mz_runstack_unskipped(jitter, 1); + if (!rand2) { + generate_two_args(rator, rand, jitter, 1, 1); /* sync'd below */ + CHECK_LIMIT(); } else { - mz_runstack_unskipped(jitter, 1); - - mz_rs_dec(1); - CHECK_RUNSTACK_OVERFLOW(); - mz_runstack_pushed(jitter, 1); - mz_rs_str(JIT_R0); + Scheme_Object *args[3]; + args[0] = rator; + args[1] = rand; + args[2] = rand2; + generate_app(NULL, args, 2, jitter, 0, 0, 1); /* sync'd below */ CHECK_LIMIT(); - - generate_non_tail(rand, jitter, 0, 1); /* sync'd below */ - CHECK_LIMIT(); - + jit_movr_p(JIT_R0, JIT_V1); mz_rs_ldr(JIT_R1); - mz_rs_inc(1); - mz_runstack_popped(jitter, 1); + mz_rs_ldxi(JIT_V1, 1); + mz_rs_inc(2); /* sync'd below */ + mz_runstack_popped(jitter, 2); } - mz_rs_sync(); - /* R1 is [potential] predicate/getter, R0 is value */ + /* R0 is [potential] predicate/getter/setting, R1 is struct. + V1 is value for setting. */ if (for_branch) { for_branch[2] = jit_patchable_movi_p(JIT_V1, jit_forward()); @@ -3939,12 +3942,18 @@ static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, } else { (void)jit_calli(struct_pred_code); } - } else { + } else if (kind == 2) { if (multi_ok) { (void)jit_calli(struct_get_multi_code); } else { (void)jit_calli(struct_get_code); } + } else { + if (multi_ok) { + (void)jit_calli(struct_set_multi_code); + } else { + (void)jit_calli(struct_set_code); + } } return 1; @@ -3962,13 +3971,13 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in { int k; - k = inlineable_struct_prim(rator, jitter, 1); + k = inlineable_struct_prim(rator, jitter, 1, 1); if (k == 1) { - generate_inlined_struct_op(1, jitter, rator, app->rand, for_branch, branch_short, multi_ok); + generate_inlined_struct_op(1, jitter, rator, app->rand, NULL, for_branch, branch_short, multi_ok); scheme_direct_call_count++; return 1; } else if ((k == 2) && !for_branch) { - generate_inlined_struct_op(2, jitter, rator, app->rand, for_branch, branch_short, multi_ok); + generate_inlined_struct_op(2, jitter, rator, app->rand, NULL, for_branch, branch_short, multi_ok); scheme_direct_call_count++; return 1; } @@ -4377,7 +4386,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in return 0; } -static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter, int order_matters) +static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter, + int order_matters, int skipped) /* de-sync's rs. Results go into R0 and R1. If !order_matters, and if only the second is simple, then the arguments will be in reverse order. */ @@ -4389,7 +4399,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ if (!simple1) { if (simple2) { - mz_runstack_skipped(jitter, 2); + mz_runstack_skipped(jitter, skipped); generate_non_tail(rand1, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); @@ -4406,18 +4416,18 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ } else direction = -1; - mz_runstack_unskipped(jitter, 2); + mz_runstack_unskipped(jitter, skipped); } else { - mz_runstack_skipped(jitter, 2); + mz_runstack_skipped(jitter, skipped); generate_non_tail(rand1, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); - mz_runstack_unskipped(jitter, 2); + mz_runstack_unskipped(jitter, skipped); mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, 1); mz_rs_str(JIT_R0); - mz_runstack_skipped(jitter, 1); + mz_runstack_skipped(jitter, skipped-1); generate_non_tail(rand2, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); @@ -4425,12 +4435,12 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ jit_movr_p(JIT_R1, JIT_R0); mz_rs_ldr(JIT_R0); - mz_runstack_unskipped(jitter, 1); + mz_runstack_unskipped(jitter, skipped-1); mz_rs_inc(1); mz_runstack_popped(jitter, 1); } } else { - mz_runstack_skipped(jitter, 2); + mz_runstack_skipped(jitter, skipped); if (simple2) { generate(rand2, jitter, 0, 0, JIT_R1); /* no sync... */ @@ -4444,7 +4454,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ generate(rand1, jitter, 0, 0, JIT_R0); /* no sync... */ CHECK_LIMIT(); - mz_runstack_unskipped(jitter, 2); + mz_runstack_unskipped(jitter, skipped); } return direction; @@ -4462,7 +4472,7 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, r1 = app->rand1; r2 = app->rand2; - direction = generate_two_args(r1, r2, jitter, 1); + direction = generate_two_args(r1, r2, jitter, 1, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4604,6 +4614,14 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i { Scheme_Object *rator = app->rator; + if (!for_branch + && inlineable_struct_prim(rator, jitter, 1, 2)) { + generate_inlined_struct_op(3, jitter, rator, app->rand1, app->rand2, for_branch, branch_short, multi_ok); + scheme_direct_call_count++; + return 1; + } + + if (!SCHEME_PRIMP(rator)) return 0; @@ -4669,7 +4687,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i __END_SHORT_JUMPS__(branch_short); } else { /* Two complex expressions: */ - generate_two_args(a2, a1, jitter, 0); + generate_two_args(a2, a1, jitter, 0, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4762,7 +4780,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i && (SCHEME_INT_VAL(app->rand2) >= 0)); if (!simple) { - generate_two_args(app->rand1, app->rand2, jitter, 1); + generate_two_args(app->rand1, app->rand2, jitter, 1, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4816,7 +4834,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i LOG_IT(("inlined set-mcar!\n")); - generate_two_args(app->rand1, app->rand2, jitter, 1); + generate_two_args(app->rand1, app->rand2, jitter, 1, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4847,7 +4865,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i || IS_NAMED_PRIM(rator, "list*")) { LOG_IT(("inlined cons\n")); - generate_two_args(app->rand1, app->rand2, jitter, 1); + generate_two_args(app->rand1, app->rand2, jitter, 1, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4855,7 +4873,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i } else if (IS_NAMED_PRIM(rator, "mcons")) { LOG_IT(("inlined mcons\n")); - generate_two_args(app->rand1, app->rand2, jitter, 1); + generate_two_args(app->rand1, app->rand2, jitter, 1, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -4881,7 +4899,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i } else if (IS_NAMED_PRIM(rator, "list")) { LOG_IT(("inlined list\n")); - generate_two_args(app->rand1, app->rand2, jitter, 1); + generate_two_args(app->rand1, app->rand2, jitter, 1, 2); CHECK_LIMIT(); mz_rs_dec(1); @@ -5054,7 +5072,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int star = IS_NAMED_PRIM(rator, "list*"); if (c) - generate_app(app, NULL, c, jitter, 0, 0, 1); + generate_app(app, NULL, c, jitter, 0, 0, 2); CHECK_LIMIT(); mz_rs_sync(); @@ -5145,12 +5163,12 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, mz_runstack_unskipped(jitter, 1); c = 1; } else if (app3) { - generate_two_args(app3->rand1, app3->rand2, jitter, 1); /* sync'd below */ + generate_two_args(app3->rand1, app3->rand2, jitter, 1, 2); /* sync'd below */ c = 2; } else { c = app->num_args; if (c) - generate_app(app, NULL, c, jitter, 0, 0, 1); /* sync'd below */ + generate_app(app, NULL, c, jitter, 0, 0, 2); /* sync'd below */ } CHECK_LIMIT(); @@ -6652,6 +6670,36 @@ static int generate_function_getarg(mz_jit_state *jitter, int has_rest, int num_ return cnt; } +static int save_struct_temp(mz_jit_state *jitter) +{ +#ifdef MZ_USE_JIT_PPC + jit_movr_p(JIT_V(3), JIT_V1); +#endif +#ifdef MZ_USE_JIT_I386 +# ifdef X86_ALIGN_STACK + mz_set_local_p(JIT_V1, JIT_LOCAL3); +# else + jit_pushr_p(JIT_V1); +# endif +#endif + return 1; +} + +static int restore_struct_temp(mz_jit_state *jitter, int reg) +{ +#ifdef MZ_USE_JIT_PPC + jit_movr_p(reg, JIT_V(3)); +#endif +#ifdef MZ_USE_JIT_I386 +# ifdef X86_ALIGN_STACK + mz_get_local_p(reg, JIT_LOCAL3); +# else + jit_popr_p(reg); +# endif +#endif + return 1; +} + static int do_generate_common(mz_jit_state *jitter, void *_data) { int in, i, ii, iii; @@ -7399,11 +7447,12 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) __END_TINY_JUMPS__(1); } - /* *** struct_{pred,get}[_branch]_code *** */ - /* R1 is (potential) struct proc, R0 is (potential) struct */ - /* In branch mode, V1 is target address for false branch */ + /* *** struct_{pred,get,set}[_branch]_code *** */ + /* R0 is (potential) struct proc, R1 is (potential) struct. */ + /* In branch mode, V1 is target address for false branch. */ + /* In set mode, V1 is value to install. */ for (ii = 0; ii < 2; ii++) { - for (i = 0; i < 3; i++) { + for (i = 0; i < 4; i++) { void *code, *code_end; int kind, for_branch; jit_insn *ref, *ref2, *refslow, *bref1, *bref2, *bref3, *bref4, *bref5, *bref6, *bref8; @@ -7424,44 +7473,48 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) for_branch = 1; struct_pred_branch_code = jit_get_ip().ptr; /* Save target address for false branch: */ -#ifdef MZ_USE_JIT_PPC - jit_movr_p(JIT_V(3), JIT_V1); -#endif -#ifdef MZ_USE_JIT_I386 -# ifdef X86_ALIGN_STACK - mz_set_local_p(JIT_V1, JIT_LOCAL3); -# else - jit_pushr_p(JIT_V1); -# endif -#endif - } else { + save_struct_temp(jitter); + } else if (i == 2) { kind = 2; for_branch = 0; if (ii == 1) struct_get_multi_code = jit_get_ip().ptr; else struct_get_code = jit_get_ip().ptr; + } else { + kind = 3; + for_branch = 0; + if (ii == 1) + struct_set_multi_code = jit_get_ip().ptr; + else + struct_set_code = jit_get_ip().ptr; + /* Save value to install: */ + save_struct_temp(jitter); } mz_prolog(JIT_V1); __START_SHORT_JUMPS__(1); - ref = jit_bmci_ul(jit_forward(), JIT_R1, 0x1); + ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); CHECK_LIMIT(); /* Slow path: non-struct proc, or argument type is bad for a getter. */ refslow = _jit.x.pc; - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES((kind == 3) ? 2 : 1)); CHECK_RUNSTACK_OVERFLOW(); JIT_UPDATE_THREAD_RSPTR(); - jit_str_p(JIT_RUNSTACK, JIT_R0); - jit_movi_i(JIT_V1, 1); + jit_str_p(JIT_RUNSTACK, JIT_R1); + if (kind == 3) { + restore_struct_temp(jitter, JIT_V1); + jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_V1); + } + jit_movi_i(JIT_V1, ((kind == 3) ? 2 : 1)); jit_prepare(3); jit_pusharg_p(JIT_RUNSTACK); jit_pusharg_p(JIT_V1); - jit_pusharg_p(JIT_R1); + jit_pusharg_p(JIT_R0); if (ii == 1) { (void)mz_finish(_scheme_apply_multi_from_native); } else { @@ -7469,7 +7522,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) } jit_retval(JIT_R0); VALIDATE_RESULT(JIT_R0); - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES((kind == 3) ? 2 : 1)); JIT_UPDATE_THREAD_RSPTR(); if (!for_branch) { mz_epilog(JIT_V1); @@ -7484,24 +7537,29 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) /* Continue trying fast path: check proc */ mz_patch_branch(ref); - jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); (void)jit_bnei_i(refslow, JIT_R2, scheme_prim_type); - jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Primitive_Proc *)0x0)->pp.flags); - (void)jit_bmci_i(refslow, JIT_R2, ((kind == 1) - ? SCHEME_PRIM_IS_STRUCT_PRED - : SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)); + jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Primitive_Proc *)0x0)->pp.flags); + if (kind == 3) { + jit_andi_i(JIT_R2, JIT_R2, SCHEME_PRIM_STRUCT_OTHER_TYPE_MASK); + (void)jit_bnei_i(refslow, JIT_R2, SCHEME_PRIM_STRUCT_TYPE_INDEXED_SETTER); + } else { + (void)jit_bmci_i(refslow, JIT_R2, ((kind == 1) + ? SCHEME_PRIM_IS_STRUCT_PRED + : SCHEME_PRIM_IS_STRUCT_INDEXED_GETTER)); + } CHECK_LIMIT(); /* Check argument: */ if (kind == 1) { - bref1 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); - jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); + bref1 = jit_bmsi_ul(jit_forward(), JIT_R1, 0x1); + jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); __START_INNER_TINY__(1); ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); __END_INNER_TINY__(1); bref2 = jit_bnei_i(jit_forward(), JIT_R2, scheme_proc_struct_type); } else { - (void)jit_bmsi_ul(refslow, JIT_R0, 0x1); - jit_ldxi_s(JIT_R2, JIT_R0, &((Scheme_Object *)0x0)->type); + (void)jit_bmsi_ul(refslow, JIT_R1, 0x1); + jit_ldxi_s(JIT_R2, JIT_R1, &((Scheme_Object *)0x0)->type); __START_INNER_TINY__(1); ref2 = jit_beqi_i(jit_forward(), JIT_R2, scheme_structure_type); __END_INNER_TINY__(1); @@ -7514,15 +7572,15 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) CHECK_LIMIT(); /* Put argument struct type in R2, target struct type in V1 */ - jit_ldxi_p(JIT_R2, JIT_R0, &((Scheme_Structure *)0x0)->stype); - jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val); - if (kind == 2) { + jit_ldxi_p(JIT_R2, JIT_R1, &((Scheme_Structure *)0x0)->stype); + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); + if (kind >= 2) { jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); } CHECK_LIMIT(); /* common case: types are the same */ - if (kind == 2) { + if (kind >= 2) { __START_INNER_TINY__(1); bref8 = jit_beqr_p(jit_forward(), JIT_R2, JIT_V1); __END_INNER_TINY__(1); @@ -7542,13 +7600,13 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) /* Lookup argument type at target type depth, put it in R2: */ jit_lshi_ul(JIT_R2, JIT_V1, JIT_LOG_WORD_SIZE); jit_addi_p(JIT_R2, JIT_R2, &((Scheme_Struct_Type *)0x0)->parent_types); - jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Structure *)0x0)->stype); + jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Structure *)0x0)->stype); jit_ldxr_p(JIT_R2, JIT_V1, JIT_R2); CHECK_LIMIT(); /* Re-load target type into V1: */ - jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val); - if (kind == 2) { + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); + if (kind >= 2) { jit_ldxi_p(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->struct_type); } @@ -7575,16 +7633,7 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) mz_patch_branch(bref4); if (for_branch) { mz_patch_branch(bref5); -#ifdef MZ_USE_JIT_PPC - jit_movr_p(JIT_V1, JIT_V(3)); -#endif -#ifdef MZ_USE_JIT_I386 -# ifdef X86_ALIGN_STACK - mz_get_local_p(JIT_V1, JIT_LOCAL3); -# else - jit_popr_p(JIT_V1); -# endif -#endif + restore_struct_temp(jitter, JIT_V1); mz_epilog_without_jmp(); jit_jmpr(JIT_V1); } else { @@ -7598,11 +7647,17 @@ static int do_generate_common(mz_jit_state *jitter, void *_data) mz_patch_branch(bref8); __END_INNER_TINY__(1); /* Extract field */ - jit_ldxi_p(JIT_V1, JIT_R1, &((Scheme_Primitive_Closure *)0x0)->val); + jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Primitive_Closure *)0x0)->val); jit_ldxi_i(JIT_V1, JIT_V1, &((Struct_Proc_Info *)0x0)->field); jit_lshi_ul(JIT_V1, JIT_V1, JIT_LOG_WORD_SIZE); jit_addi_p(JIT_V1, JIT_V1, &((Scheme_Structure *)0x0)->slots); - jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1); + if (kind == 3) { + restore_struct_temp(jitter, JIT_R0); + jit_stxr_p(JIT_V1, JIT_R1, JIT_R0); + (void)jit_movi_p(JIT_R0, scheme_void); + } else { + jit_ldxr_p(JIT_R0, JIT_R1, JIT_V1); + } mz_epilog(JIT_V1); } CHECK_LIMIT(); From ce9d26492076373d71a52b706f182a56f319f499 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Apr 2009 19:20:44 +0000 Subject: [PATCH 12/79] don't let syntax-colorer thread get suspend while reading from the editor svn: r14531 --- collects/framework/private/color.ss | 18 +++++++++++++----- 1 file changed, 13 insertions(+), 5 deletions(-) diff --git a/collects/framework/private/color.ss b/collects/framework/private/color.ss index 80b64bd42d..a5b0526bbb 100644 --- a/collects/framework/private/color.ss +++ b/collects/framework/private/color.ss @@ -260,7 +260,11 @@ added get-regions (define/private (re-tokenize ls in in-start-pos enable-suspend) (let-values ([(lexeme type data new-token-start new-token-end) - (get-token in)]) + (begin + (enable-suspend #f) + (begin0 + (get-token in) + (enable-suspend #t)))]) (unless (eq? 'eof type) (enable-suspend #f) #; (printf "~a at ~a to ~a~n" lexeme (+ in-start-pos (sub1 new-token-start)) @@ -365,10 +369,14 @@ added get-regions (for-each (lambda (ls) (re-tokenize ls - (open-input-text-editor this - (lexer-state-current-pos ls) - (lexer-state-end-pos ls) - (λ (x) #f)) + (begin + (enable-suspend #f) + (begin0 + (open-input-text-editor this + (lexer-state-current-pos ls) + (lexer-state-end-pos ls) + (λ (x) #f)) + (enable-suspend #t))) (lexer-state-current-pos ls) enable-suspend)) lexer-states))))) From 4c30a65afd180d087ea022af1237737362b830cb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Apr 2009 21:06:34 +0000 Subject: [PATCH 13/79] better discovery of struct ref/mutators in lambda-lifted functions svn: r14532 --- src/mzscheme/src/jit.c | 44 +++++++++++++++++++++++++++++++++++++----- 1 file changed, 39 insertions(+), 5 deletions(-) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index ce2e21c67a..a430ec9e62 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -170,7 +170,9 @@ typedef struct { int local1_busy; int log_depth; int self_pos, self_closure_size, self_toplevel_pos; - int self_to_closure_delta; + int self_to_closure_delta, closure_to_args_delta; + int example_argc; + Scheme_Object **example_argv; void *self_restart_code; void *self_nontail_code; Scheme_Native_Closure *nc; /* for extract_globals and extract_closure_local, only */ @@ -1489,7 +1491,15 @@ Scheme_Object *extract_closure_local(Scheme_Object *obj, mz_jit_state *jitter, i if (pos >= jitter->self_pos - jitter->self_to_closure_delta) { pos -= (jitter->self_pos - jitter->self_to_closure_delta); if (pos < jitter->nc->code->u2.orig_code->closure_size) { + /* in the closure */ return jitter->nc->vals[pos]; + } else { + /* maybe an example argument... which is useful when + the enclosing function has been lifted, converting + a closure element into an argument */ + pos -= jitter->closure_to_args_delta; + if (pos < jitter->example_argc) + return jitter->example_argv[pos]; } } @@ -7773,6 +7783,8 @@ typedef struct { void *arity_code, *code, *tail_code, *code_end, **patch_depth; int max_extra, max_depth; Scheme_Native_Closure *nc; + int argc; + Scheme_Object **argv; } Generate_Closure_Data; static int do_generate_closure(mz_jit_state *jitter, void *_data) @@ -7780,12 +7792,16 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) Generate_Closure_Data *gdata = (Generate_Closure_Data *)_data; Scheme_Closure_Data *data = gdata->data; void *code, *tail_code, *code_end, *arity_code; - int i, r, cnt, has_rest, is_method, num_params; + int i, r, cnt, has_rest, is_method, num_params, to_args, argc; + Scheme_Object **argv; code = jit_get_ip().ptr; jitter->nc = gdata->nc; + argc = gdata->argc; + argv = gdata->argv; + generate_function_prolog(jitter, code, /* max_extra_pushed may be wrong the first time around, but it will be right the last time around */ @@ -7891,18 +7907,31 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) __END_SHORT_JUMPS__(cnt < 100); has_rest = 1; - } else + if (argc < (data->num_params - 1)) { + argv = NULL; + argc = 0; + } + } else { has_rest = 0; + if (argc != data->num_params) { + argv = NULL; + argc = 0; + } + } #ifdef JIT_PRECISE_GC /* Keeping the native-closure pointer on the runstack ensures that the code won't be GCed while we're running it. */ mz_pushr_p(JIT_R0); /* no sync */ + to_args = 0; +#else + to_args = 0; #endif /* Extract closure to runstack: */ cnt = data->closure_size; + to_args += cnt; if (cnt) { mz_rs_dec(cnt); CHECK_RUNSTACK_OVERFLOW(); @@ -7970,6 +7999,9 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) jitter->self_nontail_code = tail_code; jitter->self_to_closure_delta = jitter->self_pos; + jitter->closure_to_args_delta = to_args; + jitter->example_argc = argc; + jitter->example_argv = argv; /* Generate code for the body: */ jitter->need_set_rs = 1; @@ -8000,7 +8032,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) return 1; } -static void on_demand_generate_lambda(Scheme_Native_Closure *nc) +static void on_demand_generate_lambda(Scheme_Native_Closure *nc, int argc, Scheme_Object **argv) { Scheme_Native_Closure_Data *ndata = nc->code; Scheme_Closure_Data *data; @@ -8012,6 +8044,8 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc) gdata.data = data; gdata.nc = nc; + gdata.argc = argc; + gdata.argv = argv; scheme_delay_load_closure(data); @@ -8079,7 +8113,7 @@ static void on_demand() argc = MZ_RUNSTACK[1]; argv = (Scheme_Object **)MZ_RUNSTACK[2]; - on_demand_generate_lambda((Scheme_Native_Closure *)c); + on_demand_generate_lambda((Scheme_Native_Closure *)c, SCHEME_INT_VAL(argc), argv); } Scheme_Native_Closure_Data *scheme_generate_lambda(Scheme_Closure_Data *data, int clear_code_after_jit, From 7c80111b2c5dc33606926bc20d84ff7f8557c5f2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Apr 2009 21:23:28 +0000 Subject: [PATCH 14/79] fix bug in referenced-before-defn error message svn: r14533 --- src/mzscheme/src/error.c | 11 ++++++++++- 1 file changed, 10 insertions(+), 1 deletion(-) diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 1450a85917..5d8df60285 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -191,6 +191,7 @@ Scheme_Config *scheme_init_error_escape_proc(Scheme_Config *config) %Q = truncated-to-256 Scheme string %V = scheme_value %D = scheme value to display + %_ = skip %L = line number, -1 means no line %e = error number for strerror() @@ -258,6 +259,7 @@ static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, ch case 'D': case 'T': case 'Q': + case '_': ptrs[pp++] = mzVA_ARG(args, Scheme_Object*); break; default: @@ -446,6 +448,13 @@ static long sch_vsprintf(char *s, long maxlen, const char *msg, va_list args, ch tlen = dlen; } break; + case '_': + { + pp++; + t = ""; + tlen = 0; + } + break; case 'T': case 'Q': { @@ -1904,7 +1913,7 @@ void scheme_unbound_global(Scheme_Bucket *b) if (SCHEME_TRUEP(scheme_get_param(scheme_current_config(), MZCONFIG_ERROR_PRINT_SRCLOC))) errmsg = "reference to an identifier before its definition: %S in module: %D%s"; else - errmsg = "reference to an identifier before its definition: %S%s"; + errmsg = "reference to an identifier before its definition: %S%_%s"; if (SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase)) { sprintf(phase_buf, " phase: %ld", SCHEME_INT_VAL(((Scheme_Bucket_With_Home *)b)->home->phase)); From 09320cea1c89a649c2607f0305bf551e99713498 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 16 Apr 2009 21:24:42 +0000 Subject: [PATCH 15/79] tiny object-instantiation perf. tweak svn: r14534 --- collects/scheme/private/class-internal.ss | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index bf852444a1..62e702db81 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -2777,8 +2777,10 @@ ;; All unconsumed named-args must have #f ;; "name"s, otherwise an error is raised in ;; the leftovers checking. - (append (map (lambda (x) (cons #f x)) al) - named-args)] + (if (null? al) + named-args + (append (map (lambda (x) (cons #f x)) al) + named-args))] [else (obj-error 'instantiate "too many initialization arguments:~a~a" From 8aa8b938a0d60fdb8aa937670e1e00a882c291d0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 01:30:15 +0000 Subject: [PATCH 16/79] change margin-note to generate a blockquote insteda of a single paragraph svn: r14535 --- collects/scribble/html-render.ss | 2 +- collects/scribble/latex-render.ss | 8 ++++++-- collects/scribble/private/manual-style.ss | 13 +++++++++---- collects/scribble/scribble.css | 7 +++++++ collects/scribble/scribble.tex | 7 ++++--- collects/scribblings/scribble/config.scrbl | 13 ++++++++----- collects/scribblings/scribble/manual.scrbl | 2 +- collects/scribblings/scribble/struct.scrbl | 3 ++- 8 files changed, 38 insertions(+), 17 deletions(-) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 8888b06062..6be22c6091 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -1119,7 +1119,7 @@ (define/override (render-blockquote t part ri) `((blockquote ,(if (string? (blockquote-style t)) - `([class ,(blockquote-style t)]) + `([class ,(regexp-replace #rx"^[\\]" (blockquote-style t) "")]) `()) ,@(append-map (lambda (i) (render-block i part ri #f)) (blockquote-paragraphs t))))) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index 8f0a8c7428..35dc6155b8 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -403,10 +403,14 @@ (define/override (render-blockquote t part ri) (let ([kind (or (blockquote-style t) "quote")]) - (printf "\\begin{~a}" kind) + (if (regexp-match #rx"^[\\]" kind) + (printf "~a{" kind) + (printf "\\begin{~a}" kind)) (parameterize ([current-table-mode (list "blockquote" t)]) (render-flow (make-flow (blockquote-paragraphs t)) part ri #f)) - (printf "\\end{~a}" kind) + (if (regexp-match #rx"^[\\]" kind) + (printf "}") + (printf "\\end{~a}" kind)) null)) (define/override (render-other i part ri) diff --git a/collects/scribble/private/manual-style.ss b/collects/scribble/private/manual-style.ss index d4f0eba918..9f49153f4c 100644 --- a/collects/scribble/private/manual-style.ss +++ b/collects/scribble/private/manual-style.ss @@ -199,10 +199,15 @@ `(part ,(doc-prefix '(lib "scribblings/guide/guide.scrbl") "hash-lang")))) (define (margin-note . c) - (make-styled-paragraph - (list (make-element "refcolumn" - (list (make-element "refcontent" (decode-content c))))) - "refpara")) + (make-blockquote + "\\refpara" + (list + (make-blockquote + "refcolumn" + (list + (make-blockquote + "refcontent" + (flow-paragraphs (decode-flow c)))))))) (define void-const (schemeresultfont "#")) diff --git a/collects/scribble/scribble.css b/collects/scribble/scribble.css index 832ef53ba5..4c7f2b626f 100644 --- a/collects/scribble/scribble.css +++ b/collects/scribble/scribble.css @@ -152,9 +152,16 @@ table td { width: 13em; font-size: 85%; border: 0.5em solid #F5F5DC; + margin: 0 0 0 0; } .refcontent { + margin: 0 0 0 0; +} + +.refcontent p { + margin-top: 0; + margin-bottom: 0; } /* ---------------------------------------- */ diff --git a/collects/scribble/scribble.tex b/collects/scribble/scribble.tex index 9362008f1d..e346c5faed 100644 --- a/collects/scribble/scribble.tex +++ b/collects/scribble/scribble.tex @@ -42,8 +42,6 @@ \newcommand{\schemeopt}[1]{#1} \newcommand{\textsub}[1]{$_{\hbox{\textsmaller{#1}}}$} \newcommand{\textsuper}[1]{$^{\hbox{\textsmaller{#1}}}$} -\newcommand{\refcolumn}[1]{#1} -\newcommand{\refcontent}[1]{#1} \newcommand{\intextcolor}[2]{\textcolor{#1}{#2}} \newcommand{\intextrgbcolor}[2]{\textcolor[rgb]{#1}{#2}} \newcommand{\incolorbox}[2]{{\fboxrule=0pt\fboxsep=0pt\colorbox{#1}{#2}}} @@ -58,9 +56,12 @@ \newcommand{\noborder}[1]{#1} \newcommand{\imageleft}[1]{} % drop it \renewcommand{\smaller}[1]{\textsmaller{#1}} -\newcommand{\refpara}[1]{\marginpar{\raggedright \footnotesize #1}} \newcommand{\planetName}[1]{PLane\hspace{-0.1ex}T} +\newcommand{\refpara}[1]{\marginpar{\raggedright \footnotesize #1}} +\newenvironment{refcolumn}{}{} +\newenvironment{refcontent}{}{} + \newcommand{\titleAndEmptyVersion}[2]{\title{#1}\maketitle} \newcommand{\titleAndVersion}[2]{\title{#1\\{\normalsize Version #2}}\maketitle} diff --git a/collects/scribblings/scribble/config.scrbl b/collects/scribblings/scribble/config.scrbl index a27f064e1f..af22fb0779 100644 --- a/collects/scribblings/scribble/config.scrbl +++ b/collects/scribblings/scribble/config.scrbl @@ -43,12 +43,15 @@ When a string is uses as a style in an @scheme[element], @scheme[styled-paragraph], @scheme[table], @scheme[styled-itemization], or @scheme[blockquote], it corresponds to a CSS class for HTML output or a Tex macro/environment for Latex -output. In Latex output, the string is used as a macro name for a +output. In Latex output, the string is used as a command name for a @scheme[styled-paragraph] and an environment name for a -@scheme[table], @scheme[itemization], or @scheme[blockquote]. In -addition, for an itemization, the style string is suffixed with -@scheme["Item"] and used as a CSS class or Tex macro name to use for -the itemization's items (in place of @tt{item} in the case of Latex). +@scheme[table], @scheme[itemization], or @scheme[blockquote], except +that a @scheme[blockquote] style name that starts with @litchar{\} is +used (sans @litchar{\}) as a command instead of an environment. +In addition, for an itemization, the style string is +suffixed with @scheme["Item"] and used as a CSS class or Tex macro +name to use for the itemization's items (in place of @tt{item} in the +case of Latex). Scribble includes a number of predefined styles that are used by the exports of @scheme[scribble/manual], but they are not generally diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index ce2eb65ca3..145649a0aa 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -1141,7 +1141,7 @@ centered table with the @scheme[pre-flow] parsed by an inset command-line example (e.g., in typewriter font).} @defproc[(margin-note [pre-content any/c] ...) paragraph?]{Produces -a paragraph to be typeset in the margin instead of inlined.} +a @tech{blockquote} to be typeset in the margin instead of inlined.} @; ------------------------------------------------------------------------ @section[#:tag "index-entries"]{Index-Entry Descriptions} diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index 34b71f2cec..bc0a15666a 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -476,7 +476,8 @@ The @scheme[style] can be A @techlink{blockquote} has a style and a list of @tech{blocks}. The @scheme[style] field is normally a string that corresponds to a CSS -class for HTML output or Latex environment for Latex output (see +class for HTML output or Latex environment for Latex output where a +leading @litchar{\} in the style name is treated specially (see @secref["extra-style"]). } From d49e36d983abfbcedaa0735933c1dc3001635c73 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 01:46:19 +0000 Subject: [PATCH 17/79] fix margin-note typo svn: r14536 --- collects/scribblings/scribble/manual.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/scribble/manual.scrbl b/collects/scribblings/scribble/manual.scrbl index 145649a0aa..6057726ee4 100644 --- a/collects/scribblings/scribble/manual.scrbl +++ b/collects/scribblings/scribble/manual.scrbl @@ -1140,7 +1140,7 @@ centered table with the @scheme[pre-flow] parsed by @defproc[(commandline [pre-content any/c] ...) paragraph?]{Produces an inset command-line example (e.g., in typewriter font).} -@defproc[(margin-note [pre-content any/c] ...) paragraph?]{Produces +@defproc[(margin-note [pre-content any/c] ...) blockquote?]{Produces a @tech{blockquote} to be typeset in the margin instead of inlined.} @; ------------------------------------------------------------------------ From d33f47a625a9f9de156a099da85df1623a5fa3a2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 17 Apr 2009 07:50:19 +0000 Subject: [PATCH 18/79] Welcome to a new PLT day. svn: r14537 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 90ce8ccd8f..dda5a43ee5 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "16apr2009") +#lang scheme/base (provide stamp) (define stamp "17apr2009") From a99c653997d179f88a7a4909941be8bf59a79bfc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 11:12:13 +0000 Subject: [PATCH 19/79] doc scheme/gui editor-stream method updates svn: r14538 --- .../scribblings/gui/editor-stream-in-base-class.scrbl | 8 ++++++++ collects/scribblings/gui/editor-stream-in-class.scrbl | 10 ++++++++-- collects/scribblings/gui/editor-stream-out-class.scrbl | 3 ++- 3 files changed, 18 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/gui/editor-stream-in-base-class.scrbl b/collects/scribblings/gui/editor-stream-in-base-class.scrbl index ce4cfc8952..77d66c3abc 100644 --- a/collects/scribblings/gui/editor-stream-in-base-class.scrbl +++ b/collects/scribblings/gui/editor-stream-in-base-class.scrbl @@ -37,6 +37,14 @@ Reads bytes to fill the supplied byte string. The return value is the next call to @method[editor-stream-in-base% bad?] must return @scheme[#t].} +@defmethod[(read-byte) (or/c byte? #f)]{ + +Reads a single byte and return it, or returns @scheme[#f] if no more +bytes are available. The default implementation of this method uses +@method[editor-stream-in-base% read-bytes]. + +} + @defmethod[(seek [pos exact-nonnegative-integer?]) void?]{ diff --git a/collects/scribblings/gui/editor-stream-in-class.scrbl b/collects/scribblings/gui/editor-stream-in-class.scrbl index 25f0e9647b..5d67b067d8 100644 --- a/collects/scribblings/gui/editor-stream-in-class.scrbl +++ b/collects/scribblings/gui/editor-stream-in-class.scrbl @@ -54,12 +54,18 @@ Returns the next integer value in the stream. @defmethod[(get-fixed [v (box/c (and/c exact? integer?))]) (is-a?/c editor-stream-in%)]{ +@boxisfill[(scheme v) @elem{a fixed-size integer from the stream obtained through + @method[editor-stream-in% get-fixed-exact]}] + +} + +@defmethod[(get-fixed-exact) + (and/c exact? integer?)]{ + Gets a fixed-sized integer from the stream. See @method[editor-stream-out% put-fixed] for more information. Reading from a bad stream always gives @scheme[0]. -@boxisfill[(scheme v) @elem{the fixed-size integer from the stream}] - } @defmethod[(get-inexact) diff --git a/collects/scribblings/gui/editor-stream-out-class.scrbl b/collects/scribblings/gui/editor-stream-out-class.scrbl index d869eaf23a..30bdb2b4ec 100644 --- a/collects/scribblings/gui/editor-stream-out-class.scrbl +++ b/collects/scribblings/gui/editor-stream-out-class.scrbl @@ -86,7 +86,8 @@ Puts a fixed-sized integer into the stream. This method is needed fixed-size number. Numbers written to a stream with @method[editor-stream-out% put-fixed] - must be read with @method[editor-stream-in% get-fixed].} + must be read with @method[editor-stream-in% get-fixed-exact] + or @method[editor-stream-in% get-fixed].} @defmethod[(put-unterminated [v bytes?]) (is-a?/c editor-stream-out%)]{ From b07a536ae3606c3ca75c4f570d9878380fa6e2d3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 11:18:30 +0000 Subject: [PATCH 20/79] =?UTF-8?q?bind=20=CE=BB=20in=20HtDP=20Intermediate+?= =?UTF-8?q?Lambda=20and=20Advanced=20(patch=20from=20Todd=20O'Bryan)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit svn: r14539 --- collects/lang/htdp-advanced.ss | 1 + collects/lang/htdp-intermediate-lambda.ss | 1 + 2 files changed, 2 insertions(+) diff --git a/collects/lang/htdp-advanced.ss b/collects/lang/htdp-advanced.ss index 1e2bad565f..b36a3e4d1c 100644 --- a/collects/lang/htdp-advanced.ss +++ b/collects/lang/htdp-advanced.ss @@ -16,6 +16,7 @@ [advanced-define define] [advanced-define-struct define-struct] [advanced-lambda lambda] + [advanced-lambda λ] [advanced-app #%app] [beginner-top #%top] [intermediate-local local] diff --git a/collects/lang/htdp-intermediate-lambda.ss b/collects/lang/htdp-intermediate-lambda.ss index b5be5e7a43..338a803f47 100644 --- a/collects/lang/htdp-intermediate-lambda.ss +++ b/collects/lang/htdp-intermediate-lambda.ss @@ -12,6 +12,7 @@ [intermediate-lambda-define define] [intermediate-define-struct define-struct] [intermediate-lambda lambda] + [intermediate-lambda λ] [advanced-app #%app] [beginner-top #%top] [intermediate-local local] From e02aef66a4f78a33ec6f1969cef43546f9553b76 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 11:27:23 +0000 Subject: [PATCH 21/79] =?UTF-8?q?doc=20=CE=BB=20in=20HtDP=20Intm+Lam=20and?= =?UTF-8?q?=20Adv?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit svn: r14540 --- .../scribblings/htdp-langs/advanced.scrbl | 20 ++++++++++++++----- .../htdp-langs/intermediate-lambda.scrbl | 7 ++++++- 2 files changed, 21 insertions(+), 6 deletions(-) diff --git a/collects/scribblings/htdp-langs/advanced.scrbl b/collects/scribblings/htdp-langs/advanced.scrbl index 16cf810683..096116d584 100644 --- a/collects/scribblings/htdp-langs/advanced.scrbl +++ b/collects/scribblings/htdp-langs/advanced.scrbl @@ -4,18 +4,24 @@ "prim-ops.ss" (for-label lang/htdp-advanced)) -@(define-syntax-rule (bd intm-define intm-define-struct intm-lambda intm-local intm-letrec intm-let intm-let* intm-time) +@(define-syntax-rule (bdl intm-define intm-lambda) + (begin + (require (for-label lang/htdp-intermediate-lambda)) + (define intm-define (scheme define)) + (define intm-lambda (scheme lambda)))) +@(bdl intm-define intm-lambda) + +@(define-syntax-rule (bd intm-define-struct intm-local intm-letrec intm-let intm-let* intm-time) (begin (require (for-label lang/htdp-intermediate)) (define intm-define (scheme define)) (define intm-define-struct (scheme define-struct)) - (define intm-lambda (scheme lambda)) (define intm-local (scheme local)) (define intm-letrec (scheme letrec)) (define intm-let (scheme let)) (define intm-let* (scheme let*)) (define intm-time (scheme time)))) -@(bd intm-define intm-define-struct intm-lambda intm-local intm-letrec intm-let intm-let* intm-time) +@(bd intm-define-struct intm-local intm-letrec intm-let intm-let* intm-time) @(define-syntax-rule (bbd beg-define beg-define-struct beg-cond beg-if beg-and beg-or beg-check-expect beg-require) (begin @@ -36,7 +42,7 @@ @declare-exporting[lang/htdp-advanced] @schemegrammar*+qq[ -#:literals (define define-struct lambda cond else if and or empty true false require lib planet +#:literals (define define-struct lambda λ cond else if and or empty true false require lib planet local let let* letrec time begin begin0 set! delay shared recur when case unless check-expect check-within check-error) (check-expect check-within check-error require) @@ -53,6 +59,7 @@ (set! id expr) (delay expr) (lambda (id ...) expr) + (λ (id ...) expr) (local [definition ...] expr) (letrec ([id expr] ...) expr) (shared ([id expr] ...) expr) @@ -126,7 +133,10 @@ additional set of operations: @section[#:tag "advanced-lambda"]{@scheme[lambda]} -@defform[(lambda (id ...) expr)]{ +@deftogether[( +@defform[(lambda (id ...) expr)] +@defform[(λ (id ...) expr)] +)]{ The same as Intermediate with Lambda's @|intm-lambda|, except that a function is allowed to accept zero arguments.} diff --git a/collects/scribblings/htdp-langs/intermediate-lambda.scrbl b/collects/scribblings/htdp-langs/intermediate-lambda.scrbl index f3c63795ce..35218faadc 100644 --- a/collects/scribblings/htdp-langs/intermediate-lambda.scrbl +++ b/collects/scribblings/htdp-langs/intermediate-lambda.scrbl @@ -35,7 +35,7 @@ @declare-exporting[lang/htdp-intermediate-lambda] @schemegrammar*+qq[ -#:literals (define define-struct lambda cond else if and or empty true false require lib planet +#:literals (define define-struct lambda λ cond else if and or empty true false require lib planet local let let* letrec time check-expect check-within check-error) (check-expect check-within check-error require) [program (code:line def-or-expr ...)] @@ -47,6 +47,7 @@ (define id expr) (define-struct id (id ...))] [expr (lambda (id id ...) expr) + (λ (id id ...) expr) (local [definition ...] expr) (letrec ([id expr] ...) expr) (let ([id expr] ...) expr) @@ -97,6 +98,10 @@ for @scheme[lambda], since a @scheme[lambda] form is an expression.} Creates a function that takes as many arguments as given @scheme[id]s, and whose body is @scheme[expr].} +@defform[(λ (id id ...) expr)]{ + +The Greek letter @scheme[λ] is a synonym for @scheme[lambda].} + @; ---------------------------------------------------------------------- @section[#:tag "intermediate-lambda-call"]{Function Calls} From 7d61c67bab33f059d7c270685b46ff57eae5511c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 12:29:04 +0000 Subject: [PATCH 22/79] fix handling of define*-values between a syntax binding and a syntax-local-value svn: r14541 --- collects/scheme/package.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index cf091fc55b..ebaeb4b778 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -325,7 +325,7 @@ (let ([star? (free-identifier=? #'def #'-define*-values)] [ids (syntax->list #'(id ...))]) (let* ([def-ctx (if star? - (syntax-local-make-definition-context) + (syntax-local-make-definition-context (car def-ctxes)) (car def-ctxes))] [ids (if star? (map (add-package-context (list def-ctx)) ids) From e95edcc82d671c637f5042006c40f8f106ec5d92 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 12:43:37 +0000 Subject: [PATCH 23/79] margin note on Unix Scripts at docs for --script flag svn: r14542 --- collects/scribblings/reference/startup.scrbl | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/startup.scrbl b/collects/scribblings/reference/startup.scrbl index d52f96e153..c399259ade 100644 --- a/collects/scribblings/reference/startup.scrbl +++ b/collects/scribblings/reference/startup.scrbl @@ -138,7 +138,11 @@ flags: @item{@FlagFirst{p} @nonterm{file} @nonterm{u} @nonterm{path} : @scheme[require]s @scheme[(planet #, @nontermstr{file} - #, @nontermstr{user} #, @nontermstr{pkg})].} + #, @nontermstr{user} #, @nontermstr{pkg})]. + + @margin-note{Despite its name, @DFlag{script} is not usually + used for Unix scripts. See @guidesecref["scripts"] for more + information on scripts.}} @item{@FlagFirst{r} @nonterm{file} or @DFlagFirst{script} @nonterm{file} : @scheme[load]s @nonterm{file} as a From 99221c02bc0a630807ef991cbe578d451b0874d8 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 17 Apr 2009 15:20:47 +0000 Subject: [PATCH 24/79] pushing up limit svn: r14543 --- collects/web-server/scribblings/servlet-env.scrbl | 2 +- collects/web-server/servlet-env.ss | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/web-server/scribblings/servlet-env.scrbl b/collects/web-server/scribblings/servlet-env.scrbl index 3186e86075..ca3e325f24 100644 --- a/collects/web-server/scribblings/servlet-env.scrbl +++ b/collects/web-server/scribblings/servlet-env.scrbl @@ -120,7 +120,7 @@ and if @scheme[serve/servlet] is run in another module. (regexp-quote servlet-path)))] [#:stateless? stateless? boolean? #f] [#:stuffer stuffer (stuffer/c serializable? bytes?) default-stuffer] - [#:manager manager manager? (make-threshold-LRU-manager #f (* 1024 1024 64))] + [#:manager manager manager? (make-threshold-LRU-manager #f (* 128 1024 1024))] [#:servlet-namespace servlet-namespace (listof module-path?) empty] [#:server-root-path server-root-path path-string? default-server-root-path] [#:extra-files-paths extra-files-paths (listof path-string?) (list (build-path server-root-path "htdocs"))] diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index c2696af973..084bbd2301 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -94,7 +94,7 @@ (lambda (request) `(html (head (title "Page Has Expired.")) (body (p "Sorry, this page has expired. Please go back.")))) - (* 64 1024 1024))] + (* 128 1024 1024))] #:servlet-path [servlet-path "/servlets/standalone.ss"] From 39ba607413bab17e4d53a2db3e14b84d0be2a336 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 17 Apr 2009 17:33:38 +0000 Subject: [PATCH 25/79] double quotes svn: r14544 --- collects/scribblings/guide/contracts-simple-function.scrbl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/guide/contracts-simple-function.scrbl b/collects/scribblings/guide/contracts-simple-function.scrbl index 60f6ac2d79..592ca69f57 100644 --- a/collects/scribblings/guide/contracts-simple-function.scrbl +++ b/collects/scribblings/guide/contracts-simple-function.scrbl @@ -78,7 +78,7 @@ argument and for the result. When all you have, however, is a Scheme name, such as @scheme[create] or @scheme[deposit], you want to tell the reader what the name represents (a function) and, if it is a function (or some other complex value) what the pieces are supposed to be. This is why -we use a @scheme[->] to say "hey, expect this to be a function." +we use a @scheme[->] to say ``hey, expect this to be a function.'' So @scheme[->] says ``this is a contract for a function.'' What follows in a function contracts are contracts (sub-contracts if you wish) that tell @@ -93,8 +93,8 @@ number, and a boolean. Its result is an account. In short, the arrow @scheme[->] is a @italic{contract combinator}. Its purpose is to combine other contracts into a contract -that says "this is a function @italic{and} its arguments and its result are -like that." +that says ``this is a function @italic{and} its arguments and its result +are like that.'' @ctc-section[#:tag "dots"]{Infix Contract Notation} From 7838fec40e7c8cd56b6382076b05cd57394a0c33 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 17 Apr 2009 17:34:47 +0000 Subject: [PATCH 26/79] fixed typo -- using str instead of result svn: r14545 --- .../scribblings/guide/contracts-simple-function.scrbl | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/scribblings/guide/contracts-simple-function.scrbl b/collects/scribblings/guide/contracts-simple-function.scrbl index 592ca69f57..437f38647e 100644 --- a/collects/scribblings/guide/contracts-simple-function.scrbl +++ b/collects/scribblings/guide/contracts-simple-function.scrbl @@ -219,7 +219,7 @@ scheme (define (has-decimal? str) (define L (string-length str)) (and (>= L 3) - (char=? #\. (string-ref result (- L 3))))) + (char=? #\. (string-ref str (- L 3))))) (provide/contract (code:comment "convert a random number to a string") @@ -253,15 +253,15 @@ scheme (define (has-decimal? str) (define L (string-length str)) (and (>= L 3) - (char=? #\. (string-ref result (- L 3))))) + (char=? #\. (string-ref str (- L 3))))) (define (is-decimal-string? str) (define L (string-length str)) (and (has-decimal? str) (andmap digit-char? - (string->list (substring result 0 (- L 3)))) + (string->list (substring str 0 (- L 3)))) (andmap digit-char? - (string->list (substring result (- L 2) L))))) + (string->list (substring str (- L 2) L))))) (provide/contract ... From 59a38c0dada941af4c9e5e68067666c846bd047a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 17 Apr 2009 19:15:20 +0000 Subject: [PATCH 27/79] typo (PR10207) svn: r14546 --- collects/scribblings/reference/sequences.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/sequences.scrbl b/collects/scribblings/reference/sequences.scrbl index abf63cc2ab..609c5c7ee6 100644 --- a/collects/scribblings/reference/sequences.scrbl +++ b/collects/scribblings/reference/sequences.scrbl @@ -147,7 +147,7 @@ opposed to using @scheme[in] directly as a sequence to get bytes).} sequence?]{ Returns a sequence whose elements are the result of @scheme[(read-line -in mode)] until an end-of-line is encountered. Note that the default +in mode)] until an end-of-file is encountered. Note that the default mode is @scheme['any], whereas the default mode of @scheme[read-line] is @scheme['linefeed].} From c6a290492888aa110d7ad4aac7711c3509383324 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 22:48:56 +0000 Subject: [PATCH 28/79] fix typo (0 should be NULL) svn: r14547 --- src/mzscheme/src/eval.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index d007463d37..5febd2e7ac 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -6090,7 +6090,7 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) { /* Since the module has a rename for this id, it's certainly defined. */ } else { - modidx = scheme_stx_module_name(0, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, + modidx = scheme_stx_module_name(NULL, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, NULL, NULL, NULL, NULL); if (modidx) { /* If it's an access path, resolve it: */ From 4b3626c1560658fe3937019e001911c2a44aaff3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 17 Apr 2009 22:50:19 +0000 Subject: [PATCH 29/79] fix inverted argument default for editor<%> read-from-file method; better Check Sytax results on packages; added syntax/flatten-begin library svn: r14548 --- collects/mred/private/wxme/pasteboard.ss | 2 +- collects/mred/private/wxme/text.ss | 4 ++-- collects/scheme/package.ss | 15 +++++++++++---- collects/scheme/private/class-internal.ss | 5 +++-- collects/scribblings/gui/editor-intf.scrbl | 2 +- collects/scribblings/gui/text-class.scrbl | 2 +- collects/scribblings/reference/stx-props.scrbl | 6 +++--- collects/syntax/flatten-begin.ss | 13 +++++++++++++ collects/syntax/scribblings/flatten-begin.scrbl | 14 ++++++++++++++ .../syntax/scribblings/transformer-helpers.scrbl | 2 +- 10 files changed, 50 insertions(+), 15 deletions(-) create mode 100644 collects/syntax/flatten-begin.ss create mode 100644 collects/syntax/scribblings/flatten-begin.scrbl diff --git a/collects/mred/private/wxme/pasteboard.ss b/collects/mred/private/wxme/pasteboard.ss index 80b023d942..9402788f45 100644 --- a/collects/mred/private/wxme/pasteboard.ss +++ b/collects/mred/private/wxme/pasteboard.ss @@ -1913,7 +1913,7 @@ (do-write-headers-footers f #f))) (def/override (read-from-file [editor-stream-in% f] - [bool? [overwritestyle? #t]]) + [bool? [overwritestyle? #f]]) (if (or s-user-locked? (not (zero? write-locked))) #f diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 2b297eaa49..7a188effa0 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -2581,9 +2581,9 @@ (define/override (read-from-file . args) (case-args args - [([editor-stream-in% f] [exact-nonnegative-integer? start] [any? [overwritestyle? #t]]) + [([editor-stream-in% f] [exact-nonnegative-integer? start] [any? [overwritestyle? #f]]) (do-read-from-file f start overwritestyle?)] - [([editor-stream-in% f] [any? [overwritestyle? #t]]) + [([editor-stream-in% f] [any? [overwritestyle? #f]]) (do-read-from-file f 'start overwritestyle?)] (method-name 'text% 'read-from-file))) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index ebaeb4b778..469ce825f5 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -2,7 +2,8 @@ (require (for-syntax scheme/base syntax/kerncase syntax/boundmap - syntax/define)) + syntax/define + syntax/flatten-begin)) (provide define-package package-begin @@ -93,6 +94,12 @@ hidden) id))) +(define-for-syntax (move-props orig new) + (datum->syntax new + (syntax-e new) + orig + orig)) + (define-for-syntax (do-define-package stx exp-stx) (syntax-case exp-stx () [(_ pack-id mode exports form ...) @@ -293,7 +300,7 @@ (car def-ctxes)))]) (syntax-case expr (begin) [(begin . rest) - (loop (append (syntax->list #'rest) (cdr exprs)) + (loop (append (flatten-begin expr) (cdr exprs)) rev-forms def-ctxes)] [(def (id ...) rhs) @@ -315,7 +322,7 @@ (syntax-local-bind-syntaxes ids #'rhs def-ctx) (register-bindings! ids) (loop (cdr exprs) - (cons #`(define-syntaxes #,ids rhs) + (cons (move-props expr #`(define-syntaxes #,ids rhs)) rev-forms) (if star? (cons def-ctx def-ctxes) def-ctxes)))))] [(def (id ...) rhs) @@ -333,7 +340,7 @@ (syntax-local-bind-syntaxes ids #f def-ctx) (register-bindings! ids) (loop (cdr exprs) - (cons #`(define-values #,ids rhs) rev-forms) + (cons (move-props expr #`(define-values #,ids rhs)) rev-forms) (if star? (cons def-ctx def-ctxes) def-ctxes))))] [else (loop (cdr exprs) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 62e702db81..289dd7ff8e 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -11,6 +11,7 @@ syntax/name syntax/context syntax/define + syntax/flatten-begin syntax/private/boundmap mzlib/stxparam "classidmap.ss")) @@ -245,9 +246,9 @@ null (let ([e (expand (car l))]) (syntax-case e (begin define-syntaxes define-values) - [(begin expr ...) + [(begin . _) (loop (append - (syntax->list (syntax (expr ...))) + (flatten-begin e) (cdr l)))] [(define-syntaxes (id ...) rhs) (andmap identifier? (syntax->list #'(id ...))) diff --git a/collects/scribblings/gui/editor-intf.scrbl b/collects/scribblings/gui/editor-intf.scrbl index 2184550f83..99dc7b6fe3 100644 --- a/collects/scribblings/gui/editor-intf.scrbl +++ b/collects/scribblings/gui/editor-intf.scrbl @@ -1826,7 +1826,7 @@ See @method[editor<%> read-header-from-file]. @defmethod[(read-from-file [stream (is-a?/c editor-stream-in%)] - [overwrite-styles? any/c #t]) + [overwrite-styles? any/c #f]) boolean?]{ Reads new contents for the editor from a stream. The return value is diff --git a/collects/scribblings/gui/text-class.scrbl b/collects/scribblings/gui/text-class.scrbl index 3635683ed6..d0af7be3fd 100644 --- a/collects/scribblings/gui/text-class.scrbl +++ b/collects/scribblings/gui/text-class.scrbl @@ -1698,7 +1698,7 @@ Returns the paragraph number of the paragraph containing a given @techlink{posit @defmethod[#:mode extend (read-from-file [stream (is-a?/c editor-stream-in%)] [start (or/c exact-nonnegative-integer? (one/of 'start))] - [overwrite-styles? any/c #t]) + [overwrite-styles? any/c #f]) boolean?]{ New data is inserted at the @techlink{position} indicated by @scheme[start], or at diff --git a/collects/scribblings/reference/stx-props.scrbl b/collects/scribblings/reference/stx-props.scrbl index 8dd07e630d..d2dbc68450 100644 --- a/collects/scribblings/reference/stx-props.scrbl +++ b/collects/scribblings/reference/stx-props.scrbl @@ -54,17 +54,17 @@ MzScheme adds properties to expanded syntax (often using @item{When an internal @scheme[define-values] or @scheme[define-syntaxes] form is converted into a - @scheme[letrec-values+syntaxes] form (see @secref["intdef-body"]), + @scheme[letrec-syntaxes+values] form (see @secref["intdef-body"]), @scheme[syntax-track-origin] is applied to each generated binding clause. The second argument to @scheme[syntax-track-origin] is the converted form, and the third argument is the @scheme[define-values] or @scheme[define-syntaxes] keyword form the converted form.} - @item{When a @scheme[letrec-values+syntaxes] expression is fully + @item{When a @scheme[letrec-syntaxes+values] expression is fully expanded, syntax bindings disappear, and the result is either a @scheme[letrec-values] form (if the unexpanded form contained non-syntax bindings), or only the body of the - @scheme[letrec-values+syntaxes] form (wrapped with @scheme[begin] if + @scheme[letrec-syntaxes+values] form (wrapped with @scheme[begin] if the body contained multiple expressions). To record the disappeared syntax bindings, a property is added to the expansion result: an immutable list of identifiers from the disappeared bindings, as a diff --git a/collects/syntax/flatten-begin.ss b/collects/syntax/flatten-begin.ss new file mode 100644 index 0000000000..5cb4b0e5b5 --- /dev/null +++ b/collects/syntax/flatten-begin.ss @@ -0,0 +1,13 @@ +#lang scheme/base +(provide flatten-begin) + +(define (flatten-begin stx) + (let ([l (syntax->list stx)]) + (if l + (map (lambda (e) + (syntax-track-origin e stx (car l))) + (cdr l)) + (raise-syntax-error + #f + "bad syntax" + stx)))) diff --git a/collects/syntax/scribblings/flatten-begin.scrbl b/collects/syntax/scribblings/flatten-begin.scrbl new file mode 100644 index 0000000000..c3f93313b8 --- /dev/null +++ b/collects/syntax/scribblings/flatten-begin.scrbl @@ -0,0 +1,14 @@ +#lang scribble/doc +@(require "common.ss" + (for-label syntax/flatten-begin)) + +@title[#:tag "flatten-begin"]{Flattening @scheme[begin] Forms} + +@defmodule[syntax/flatten-begin] + +@defproc[(flatten-begin [stx syntax?]) (listof syntax?)]{ + +Extracts the sub-expressions from a @scheme[begin]-like form, +reporting an error if @scheme[stx] does not have the right shape +(i.e., a syntax list). The resulting syntax objects have annotations +transferred from @scheme[stx] using @scheme[syntax-track-origin].} diff --git a/collects/syntax/scribblings/transformer-helpers.scrbl b/collects/syntax/scribblings/transformer-helpers.scrbl index 6f8aa521cb..951c202743 100644 --- a/collects/syntax/scribblings/transformer-helpers.scrbl +++ b/collects/syntax/scribblings/transformer-helpers.scrbl @@ -6,6 +6,6 @@ @include-section["name.scrbl"] @include-section["context.scrbl"] @include-section["define.scrbl"] +@include-section["flatten-begin.scrbl"] @include-section["struct.scrbl"] @include-section["path-spec.scrbl"] - From 82b9ab8a53d955f3478d599e7ab234745fd9ec13 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Apr 2009 01:38:18 +0000 Subject: [PATCH 30/79] fix excessive redraw after changes within an editor svn: r14549 --- collects/mred/private/wxme/text.ss | 9 ++++----- 1 file changed, 4 insertions(+), 5 deletions(-) diff --git a/collects/mred/private/wxme/text.ss b/collects/mred/private/wxme/text.ss index 7a188effa0..eb78bee857 100644 --- a/collects/mred/private/wxme/text.ss +++ b/collects/mred/private/wxme/text.ss @@ -2560,7 +2560,6 @@ (when fileerr? (error (method-name 'text% 'save-port) "error writing editor content")) #t))) - (define/private (do-read-from-file f start overwritestyle?) (if write-locked? @@ -4722,9 +4721,9 @@ (cond [(not (= delayedscroll -1)) - (scroll-to-position/refresh delayedscroll delayedscrollateol? #f - delayedscrollend delayedscrollbias) - (set! refresh-all? #t)] + (when (scroll-to-position/refresh delayedscroll delayedscrollateol? #f + delayedscrollend delayedscrollbias) + (set! refresh-all? #t))] [delayedscrollbox? (set! delayedscrollbox? #f) (when (do-scroll-to delayedscrollsnip delayedscroll-x delayedscroll-y @@ -4735,7 +4734,7 @@ (send s-admin get-dc x y) (when (or (not (= origx x)) (not (= origy y))) (set! refresh-all? #t))) - + (let-boxes ([x 0.0] [y 0.0] [w 0.0] [h 0.0]) (send s-admin get-max-view x y w h) (let ([top y] From 32ceddfea021f3dde166a41f8a7b83a76d02091a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 18 Apr 2009 04:32:42 +0000 Subject: [PATCH 31/79] remove erroneous closing brace svn: r14550 --- collects/browser/browser.scrbl | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/browser/browser.scrbl b/collects/browser/browser.scrbl index 025d9a9bc0..4a1032c9b2 100644 --- a/collects/browser/browser.scrbl +++ b/collects/browser/browser.scrbl @@ -535,7 +535,6 @@ library.} Extends the given @scheme[text%] class with implementations of the @scheme[html-text<%>] methods. Hyperlinks are attached to clickbacks that use @net-send-url from @schememodname[net/sendurl]. - } } @defproc[(render-html-to-text [in input-port?] From 04a40605673728c80e7499583cb42f531439f640 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 18 Apr 2009 07:50:30 +0000 Subject: [PATCH 32/79] Welcome to a new PLT day. svn: r14551 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index dda5a43ee5..913941800f 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "17apr2009") +#lang scheme/base (provide stamp) (define stamp "18apr2009") From d93d37903b08d404506871ba86eb39b016a1cd9e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Apr 2009 13:08:54 +0000 Subject: [PATCH 33/79] better Exited message for Windows no-stdio console svn: r14552 --- src/mred/mred.cxx | 19 ++----------------- 1 file changed, 2 insertions(+), 17 deletions(-) diff --git a/src/mred/mred.cxx b/src/mred/mred.cxx index 76bbd4b911..b975326b7b 100644 --- a/src/mred/mred.cxx +++ b/src/mred/mred.cxx @@ -2222,11 +2222,6 @@ static HANDLE waiting_sema; typedef HWND (WINAPI* gcw_proc)(); -static void HideConsole() -{ - -} - static BOOL WINAPI ConsoleHandler(DWORD op) { if (stdio_kills_prog) { @@ -2234,9 +2229,6 @@ static BOOL WINAPI ConsoleHandler(DWORD op) } else { scheme_break_main_thread(); scheme_signal_received(); - if ((op != CTRL_C_EVENT) - && (op != CTRL_BREAK_EVENT)) - HideConsole(); } return TRUE; } @@ -2256,8 +2248,8 @@ static void WaitOnConsole() RDW_FRAME | RDW_INVALIDATE | RDW_UPDATENOW); } - WriteConsole(console_out, "\n[Exited]", 9, &wrote, NULL); - + WriteConsole(console_out, "\n[Exited. Close box or Ctrl-C closes the console.]\n", 51, &wrote, NULL); + WaitForSingleObject(waiting_sema, INFINITE); } @@ -3670,13 +3662,6 @@ void wxDrop_Runtime(char **argv, int argc) #if defined(wx_mac) || defined(wx_msw) void wxDrop_Quit() { -#if WCONSOLE_STDIO - if (has_stdio) { - has_stdio = 0; - HideConsole(); - } -#endif - wxDo(wxs_app_quit_proc, 0, NULL); } #endif From 699d1c2ea8405cc03cfcce0000145e341b8ea4d1 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Sat, 18 Apr 2009 17:19:19 +0000 Subject: [PATCH 34/79] Synch German string constants with latest. svn: r14553 --- collects/string-constants/german-string-constants.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/string-constants/german-string-constants.ss b/collects/string-constants/german-string-constants.ss index eb67b339f9..2280eb68d0 100644 --- a/collects/string-constants/german-string-constants.ss +++ b/collects/string-constants/german-string-constants.ss @@ -1152,6 +1152,7 @@ (stepper-next "Schritt >") (stepper-next-application "Applikation >|") (stepper-jump-to-end "Ende") + (stepper-jump "Springen zu ...") (debug-tool-button-name "Debugger") From c33870fa0418ba2ca479379960b4d240d65886a9 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 18 Apr 2009 17:53:56 +0000 Subject: [PATCH 35/79] PR 10209 svn: r14554 --- collects/slideshow/pict.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/slideshow/pict.ss b/collects/slideshow/pict.ss index 7c2fb925be..7b32fe8013 100644 --- a/collects/slideshow/pict.ss +++ b/collects/slideshow/pict.ss @@ -42,7 +42,7 @@ (list? p) (andmap pict? p)))) - (define (pin-line sz p + (define (pin-line p src src-find dest dest-find #:start-angle [sa #f] #:end-angle [ea #f] @@ -57,7 +57,7 @@ dest dest-find)) p lw col under?) (pin-curve* #f #f p src src-find dest dest-find - sa ea sp ep sz col lw under? #t))) + sa ea sp ep 0 col lw under? #t))) (define (pin-arrow-line sz p src src-find From 3b39cfc4b86707298b30dcbd562ceb88251b041c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 18 Apr 2009 18:15:33 +0000 Subject: [PATCH 36/79] fixed two uses of raise-type-error (PR 10208) svn: r14555 --- collects/scheme/dict.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scheme/dict.ss b/collects/scheme/dict.ss index 6648afbe29..e90cf849bb 100644 --- a/collects/scheme/dict.ss +++ b/collects/scheme/dict.ss @@ -150,7 +150,7 @@ [(dict-struct? d) ((get-dict-ref (dict-struct-ref d)) d key)] [else - (raise-type-error 'dict-ref 'dict 0 d key)])] + (raise-type-error 'dict-ref "dict" 0 d key)])] [(d key default) (cond [(hash? d) (hash-ref d key default)] @@ -170,7 +170,7 @@ [(dict-struct? d) ((get-dict-ref (dict-struct-ref d)) d key default)] [else - (raise-type-error 'dict-ref 'dict 0 d key default)])])) + (raise-type-error 'dict-ref "dict" 0 d key default)])])) (define (dict-set! d key val) (cond From ea861e346fc8a840ff5101da6ef37a58cc498dc9 Mon Sep 17 00:00:00 2001 From: John Clements Date: Sun, 19 Apr 2009 00:45:02 +0000 Subject: [PATCH 37/79] fixed typo in docs of fresh form svn: r14556 --- collects/redex/examples/church.ss | 22 +++++++--------------- collects/redex/redex.scrbl | 2 +- 2 files changed, 8 insertions(+), 16 deletions(-) diff --git a/collects/redex/examples/church.ss b/collects/redex/examples/church.ss index b3152a11b5..06aa2fa0ad 100644 --- a/collects/redex/examples/church.ss +++ b/collects/redex/examples/church.ss @@ -5,18 +5,17 @@ (define-language lang (e (lambda (x) e) - (let (x e) e) - (app e e) + (e e) (+ e e) number x) - (e-ctxt (lambda (x) e-ctxt) - a-ctxt) - (a-ctxt (let (x a-ctxt) e) - (app a-ctxt e) - (app x a-ctxt) + (ctxt (ctxt e) + (v ctxt) + (+ ctxt e) + (+ v ctxt) hole) (v (lambda (x) e) + number x) (x variable)) @@ -47,11 +46,4 @@ (subst (x_1 e_1 e_3)))] [(subst (x_1 e_1 number_1)) number_1]) -(traces reductions - '(let (plus (lambda (m) - (lambda (n) - (lambda (s) - (lambda (z) - (app (app m s) (app (app n s) z))))))) - (let (two (lambda (s) (lambda (z) (app s (app s z))))) - (app (app plus two) two)))) +(apply-reduction-relation reductions `(app (lambda (x) x) (lambda (x) x))) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index feebc5593b..122d6f7e88 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -857,7 +857,7 @@ terminate (it does terminate if the only infinite reduction paths are cyclic). error elsewhere. } @defidform[fresh]{ Recognized specially within - @scheme[reduction-relation]. A @scheme[-->] form is an + @scheme[reduction-relation]. A @scheme[fresh] form is an error elsewhere. } @defidform[with]{ Recognized specially within From 7334a89d6b584bd052404ac9ad53522c38c79573 Mon Sep 17 00:00:00 2001 From: John Clements Date: Sun, 19 Apr 2009 01:33:29 +0000 Subject: [PATCH 38/79] undid accidental change to church.ss svn: r14557 --- collects/redex/examples/church.ss | 22 +++++++++++++++------- 1 file changed, 15 insertions(+), 7 deletions(-) diff --git a/collects/redex/examples/church.ss b/collects/redex/examples/church.ss index 06aa2fa0ad..b3152a11b5 100644 --- a/collects/redex/examples/church.ss +++ b/collects/redex/examples/church.ss @@ -5,17 +5,18 @@ (define-language lang (e (lambda (x) e) - (e e) + (let (x e) e) + (app e e) (+ e e) number x) - (ctxt (ctxt e) - (v ctxt) - (+ ctxt e) - (+ v ctxt) + (e-ctxt (lambda (x) e-ctxt) + a-ctxt) + (a-ctxt (let (x a-ctxt) e) + (app a-ctxt e) + (app x a-ctxt) hole) (v (lambda (x) e) - number x) (x variable)) @@ -46,4 +47,11 @@ (subst (x_1 e_1 e_3)))] [(subst (x_1 e_1 number_1)) number_1]) -(apply-reduction-relation reductions `(app (lambda (x) x) (lambda (x) x))) +(traces reductions + '(let (plus (lambda (m) + (lambda (n) + (lambda (s) + (lambda (z) + (app (app m s) (app (app n s) z))))))) + (let (two (lambda (s) (lambda (z) (app s (app s z))))) + (app (app plus two) two)))) From eb17e0e260ef99895e91f362e7dfd1ff90bda167 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 19 Apr 2009 07:50:27 +0000 Subject: [PATCH 39/79] Welcome to a new PLT day. svn: r14558 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 913941800f..997ff6fa0b 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "18apr2009") +#lang scheme/base (provide stamp) (define stamp "19apr2009") From 434ec53b884f4fa72dec15a77014931b06922b76 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 19 Apr 2009 14:13:06 +0000 Subject: [PATCH 40/79] typed scheme tests keep failing svn: r14559 --- collects/tests/run-automated-tests.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index e72674ddd0..e9c8ce1f69 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -33,7 +33,7 @@ (define tests '([no-handler load "mzscheme/quiet.ss" (lib "scheme/init")] ;; [require "planet/lang.ss"] - [require "typed-scheme/run.ss"] + ;; [require "typed-scheme/run.ss"] [require "match/plt-match-tests.ss"] ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")] [require "lazy/main.ss"] From 5a4f15f5f981e30294197dba014057c8c9090223 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 19 Apr 2009 15:47:52 +0000 Subject: [PATCH 41/79] better GC support for medium-sized immobile objects svn: r14560 --- src/mzscheme/gc2/mem_account.c | 44 ++- src/mzscheme/gc2/newgc.c | 655 +++++++++++++++++++++++---------- src/mzscheme/gc2/newgc.h | 10 +- src/mzscheme/src/schpriv.h | 2 +- 4 files changed, 507 insertions(+), 204 deletions(-) diff --git a/src/mzscheme/gc2/mem_account.c b/src/mzscheme/gc2/mem_account.c index c9e9ba92e2..32d168f2d6 100644 --- a/src/mzscheme/gc2/mem_account.c +++ b/src/mzscheme/gc2/mem_account.c @@ -239,13 +239,26 @@ inline static unsigned long custodian_usage(NewGC*gc, void *custodian) inline static void BTC_memory_account_mark(NewGC *gc, mpage *page, void *ptr) { GCDEBUG((DEBUGOUTF, "BTC_memory_account_mark: %p/%p\n", page, ptr)); - if(page->big_page) { - struct objhead *info = (struct objhead *)(NUM(page->addr) + PREFIX_SIZE); + if(page->size_class) { + if(page->size_class > 1) { + /* big page */ + struct objhead *info = (struct objhead *)(NUM(page->addr) + PREFIX_SIZE); + + if(info->btc_mark == gc->old_btc_mark) { + info->btc_mark = gc->new_btc_mark; + account_memory(gc, gc->current_mark_owner, gcBYTES_TO_WORDS(page->size)); + push_ptr(ptr); + } + } else { + /* medium page */ + struct objhead *info = MED_OBJHEAD(ptr, page->size); - if(info->btc_mark == gc->old_btc_mark) { - info->btc_mark = gc->new_btc_mark; - account_memory(gc, gc->current_mark_owner, gcBYTES_TO_WORDS(page->size)); - push_ptr(ptr); + if(info->btc_mark == gc->old_btc_mark) { + info->btc_mark = gc->new_btc_mark; + account_memory(gc, gc->current_mark_owner, info->size); + ptr = PTR(NUM(info) + WORD_SIZE); + push_ptr(ptr); + } } } else { struct objhead *info = (struct objhead *)((char*)ptr - WORD_SIZE); @@ -315,9 +328,9 @@ int BTC_cust_box_mark(void *p) return gc->mark_table[btc_redirect_cust_box](p); } -inline static void mark_normal_obj(NewGC *gc, mpage *page, void *ptr) +inline static void mark_normal_obj(NewGC *gc, int type, void *ptr) { - switch(page->page_type) { + switch(type) { case PAGE_TAGGED: { /* we do not want to mark the pointers in a thread or custodian unless the object's owner is the current owner. In the case @@ -374,7 +387,6 @@ inline static void mark_acc_big_page(NewGC *gc, mpage *page) } } - static void btc_overmem_abort(NewGC *gc) { gc->kill_propagation_loop = 1; @@ -391,10 +403,16 @@ static void propagate_accounting_marks(NewGC *gc) page = pagemap_find_page(pagemap, p); set_backtrace_source(p, page->page_type); GCDEBUG((DEBUGOUTF, "btc_account: popped off page %p:%p, ptr %p\n", page, page->addr, p)); - if(page->big_page) - mark_acc_big_page(gc, page); - else - mark_normal_obj(gc, page, p); + if(page->size_class) { + if (page->size_class > 1) + mark_acc_big_page(gc, page); + else { + struct objhead *info = MED_OBJHEAD(p, page->size); + p = PTR(NUM(info) + WORD_SIZE); + mark_normal_obj(gc, info->type, p); + } + } else + mark_normal_obj(gc, page->page_type, p); } if(gc->kill_propagation_loop) reset_pointer_stack(); diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 5462977929..0387b84724 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -91,7 +91,6 @@ inline static int is_master_gc(NewGC *gc) { return (MASTERGC == gc); } - #include "msgprint.c" /*****************************************************************************/ @@ -364,7 +363,7 @@ inline static void pagemap_modify_with_size(PageMap pagemap, mpage *page, long s } inline static void pagemap_modify(PageMap pagemap, mpage *page, mpage *val) { - long size = page->big_page ? page->size : APAGE_SIZE; + long size = (page->size_class > 1) ? page->size : APAGE_SIZE; pagemap_modify_with_size(pagemap, page, size, val); } @@ -420,6 +419,8 @@ int GC_is_allocated(void *p) #endif #define PREFIX_SIZE (PREFIX_WSIZE * WORD_SIZE) +#define MED_OBJHEAD(p, bytesize) ((struct objhead *)(PTR(((((NUM(p) & (APAGE_SIZE - 1)) - PREFIX_SIZE) / bytesize) * bytesize) \ + + (NUM(p) & (~(APAGE_SIZE - 1))) + PREFIX_SIZE))) /* this is the maximum size of an object that will fit on a page, in words. the "- 3" is basically used as a fudge/safety factor, and has no real, @@ -437,7 +438,7 @@ int GC_is_allocated(void *p) gc->gen0.curr_alloc_page is the member of this list we are currently allocating on. The size count helps us trigger collection quickly when we're running out of space; see the test in allocate_big. - */ +*/ THREAD_LOCAL unsigned long GC_gen0_alloc_page_ptr = 0; THREAD_LOCAL unsigned long GC_gen0_alloc_page_end = 0; @@ -511,7 +512,7 @@ static void *allocate_big(size_t sizeb, int type) addr = malloc_pages(gc, round_to_apage_size(sizeb), APAGE_SIZE); bpage->addr = addr; bpage->size = sizeb; - bpage->big_page = 1; + bpage->size_class = 2; bpage->page_type = type; /* push new bpage onto GC->gen0.big_pages */ @@ -554,12 +555,86 @@ static void *allocate_big(size_t sizeb, int type) # endif #endif +static void *allocate_medium(size_t sizeb, int type) +{ + NewGC *gc; + int sz = 8, pos = 0, n; + void *addr, *p; + struct mpage *page; + struct objhead *info; + + if (sizeb > (1 << (LOG_APAGE_SIZE - 1))) + return allocate_big(sizeb, type); + + while (sz < sizeb) { + sz <<= 1; + pos++; + } + + sz += WORD_SIZE; /* add trailing word, in case pointer is to end */ + sz += WORD_SIZE; /* room for objhead */ + sz = ALIGN_BYTES_SIZE(sz); + + gc = GC_get_GC(); + while (1) { + page = gc->med_freelist_pages[pos]; + if (page) { + n = page->previous_size; + while (n < APAGE_SIZE) { + info = (struct objhead *)PTR(NUM(page->addr) + n); + if (info->dead) { + info->dead = 0; + info->type = type; + page->previous_size = (n + sz); + page->live_size += sz; + p = PTR(NUM(info) + WORD_SIZE); + memset(p, 0, sz - WORD_SIZE); + return p; + } + n += sz; + } + gc->med_freelist_pages[pos] = page->prev; + } else + break; + } + + page = malloc_mpage(); + addr = malloc_pages(gc, APAGE_SIZE, APAGE_SIZE); + page->addr = addr; + page->size = sz; + page->size_class = 1; + page->page_type = PAGE_BIG; + page->previous_size = PREFIX_SIZE; + page->live_size = sz; + + for (n = page->previous_size; (n + sz) <= APAGE_SIZE; n += sz) { + info = (struct objhead *)PTR(NUM(page->addr) + n); + info->dead = 1; + info->size = gcBYTES_TO_WORDS(sz); + } + + page->next = gc->med_pages[pos]; + if (page->next) + page->next->prev = page; + gc->med_pages[pos] = page; + gc->med_freelist_pages[pos] = page; + + pagemap_add(gc->page_maps, page); + + n = page->previous_size; + info = (struct objhead *)PTR(NUM(page->addr) + n); + info->dead = 0; + info->type = type; + + return PTR(NUM(info) + WORD_SIZE); +} + inline static struct mpage *gen0_create_new_mpage(NewGC *gc) { mpage *newmpage; newmpage = malloc_mpage(gc); newmpage->addr = malloc_dirty_pages(gc, GEN0_PAGE_SIZE, APAGE_SIZE); - newmpage->big_page = 0; + newmpage->size_class = 0; newmpage->size = PREFIX_SIZE; pagemap_add_with_size(gc->page_maps, newmpage, GEN0_PAGE_SIZE); @@ -721,9 +796,9 @@ void *GC_malloc_one_xtagged(size_t s) { return allocate(s, PAGE_XTAG void *GC_malloc_array_tagged(size_t s) { return allocate(s, PAGE_TARRAY); } void *GC_malloc_atomic(size_t s) { return allocate(s, PAGE_ATOMIC); } void *GC_malloc_atomic_uncollectable(size_t s) { void *p = ofm_malloc_zero(s); return p; } -void *GC_malloc_allow_interior(size_t s) { return allocate_big(s, PAGE_ARRAY); } +void *GC_malloc_allow_interior(size_t s) { return allocate_medium(s, PAGE_ARRAY); } void *GC_malloc_atomic_allow_interior(size_t s) { return allocate_big(s, PAGE_ATOMIC); } -void *GC_malloc_tagged_allow_interior(size_t s) { return allocate_big(s, PAGE_TAGGED); } +void *GC_malloc_tagged_allow_interior(size_t s) { return allocate_medium(s, PAGE_TAGGED); } void *GC_malloc_one_small_dirty_tagged(size_t s) { return fast_malloc_one_small_tagged(s, 1); } void *GC_malloc_one_small_tagged(size_t s) { return fast_malloc_one_small_tagged(s, 0); } void GC_free(void *p) {} @@ -822,14 +897,21 @@ inline static void reset_nursery(NewGC *gc) false if it isn't. This function assumes that you're talking, at this point, purely about the mark field of the object. It ignores things like the object not being one of our GC heap objects, being in a higher gen - than we're collectiong, not being a pointer at all, etc. */ + than we're collecting, not being a pointer at all, etc. */ inline static int marked(NewGC *gc, void *p) { struct mpage *page; if(!p) return 0; if(!(page = pagemap_find_page(gc->page_maps, p))) return 1; - if((NUM(page->addr) + page->previous_size) > NUM(p)) return 1; + if (page->size_class) { + if (page->size_class > 1) { + return (page->size_class > 2); + } + } else { + if((NUM(page->addr) + page->previous_size) > NUM(p)) + return 1; + } return ((struct objhead *)(NUM(p) - WORD_SIZE))->mark; } @@ -843,11 +925,11 @@ static int collections = 0; static void init_debug_file(void) { /* - char filename_buf[20]; - snprintf(filename_buf, 20, "gclog%d%d", (collections / 10), (collections % 10)); - dump = fopen(filename_buf, "a"); - collections += 1; - */ + char filename_buf[20]; + snprintf(filename_buf, 20, "gclog%d%d", (collections / 10), (collections % 10)); + dump = fopen(filename_buf, "a"); + collections += 1; + */ char *filename = ofm_malloc(8 * sizeof(char)); @@ -870,9 +952,9 @@ static void dump_region(void **start, void **end) { while(start < end) { fprintf(dump, "%.8lx: %.8lx %.8lx %.8lx %.8lx %.8lx %.8lx %.8lx %.8lx\n", - NUM(start), NUM(*start), NUM(*(start + 1)), NUM(*(start + 2)), - NUM(*(start + 3)), NUM(*(start + 4)), NUM(*(start + 5)), - NUM(*(start + 6)), NUM(*(start + 7))); + NUM(start), NUM(*start), NUM(*(start + 1)), NUM(*(start + 2)), + NUM(*(start + 3)), NUM(*(start + 4)), NUM(*(start + 5)), + NUM(*(start + 6)), NUM(*(start + 7))); start += 8; } fprintf(dump, "\n\n"); @@ -886,20 +968,20 @@ static void dump_heap(NewGC *gc) if(collections >= 0) { for(page = gc->gen0.pages; page; page = page->next) { fprintf(dump, "Generation 0 Page (%p:%p - %p, size %i):\n", - page, page->addr, PTR(NUM(page->addr) + GEN0_PAGE_SIZE), page->size); + page, page->addr, PTR(NUM(page->addr) + GEN0_PAGE_SIZE), page->size); dump_region(PPTR(NUM(page->addr) + PREFIX_SIZE), PPTR(NUM(page->addr) + page->size)); } for(page = gc->gen0.big_pages; page; page = page->next) { fprintf(dump, "Page %p:%p (gen %i, type %i, big %i, back %i, size %i)\n", - page, page->addr, page->generation, page->page_type, page->big_page, - page->back_pointers, page->size); + page, page->addr, page->generation, page->page_type, page->big_page, + page->back_pointers, page->size); dump_region(PPTR(NUM(page->addr) + PREFIX_SIZE), PPTR(NUM(page->addr) + page->size)); } for(i = 0; i < PAGE_TYPES; i++) for(page = gc->gen1_pages[i]; page; page = page->next) { fprintf(dump, "Page %p:%p (gen %i, type %i, big %i, back %i, size %i)\n", - page, page->addr, page->generation, page->page_type, page->big_page, - page->back_pointers, page->size); + page, page->addr, page->generation, page->page_type, page->big_page, + page->back_pointers, page->size); dump_region(PPTR(NUM(page->addr) + PREFIX_SIZE), PPTR(NUM(page->addr) + page->size)); } fprintf(dump, "STACK:\n"); @@ -953,7 +1035,7 @@ static void set_backtrace_source(void *source, int type) } static void record_backtrace(struct mpage *page, void *ptr) - /* ptr is after objhead */ +/* ptr is after objhead */ { unsigned long delta; @@ -963,7 +1045,7 @@ static void record_backtrace(struct mpage *page, void *ptr) } static void copy_backtrace_source(struct mpage *to_page, void *to_ptr, - struct mpage *from_page, void *from_ptr) + struct mpage *from_page, void *from_ptr) /* ptrs are at objhead */ { unsigned long to_delta, from_delta; @@ -976,12 +1058,16 @@ static void copy_backtrace_source(struct mpage *to_page, void *to_ptr, } static void *get_backtrace(struct mpage *page, void *ptr) - /* ptr is after objhead */ +/* ptr is after objhead */ { unsigned long delta; - if (page->big_page) - ptr = PTR((char *)page->addr + PREFIX_SIZE + WORD_SIZE); + if (page->size_class) { + if (page->size_class > 1) + ptr = PTR((char *)page->addr + PREFIX_SIZE + WORD_SIZE); + else + ptr = (char *)MED_OBJHEAD(ptr, page->size) + WORD_SIZE; + } delta = PPTR(ptr) - PPTR(page->addr); return page->backtrace[delta - 1]; @@ -1068,21 +1154,21 @@ static inline void *get_stack_base(NewGC *gc) { #include "roots.c" -#define traverse_roots(gcMUCK, set_bt_src) { \ - unsigned long j; \ - Roots *roots = &gc->roots; \ - if(roots->roots) { \ - sort_and_merge_roots(roots); \ - for(j = 0; j < roots->count; j += 2) { \ - void **start = (void**)roots->roots[j]; \ - void **end = (void**)roots->roots[j+1]; \ - while(start < end) { \ - set_bt_src(start, BT_ROOT); \ - gcMUCK(*start++); \ - } \ - } \ - } \ -} +#define traverse_roots(gcMUCK, set_bt_src) { \ + unsigned long j; \ + Roots *roots = &gc->roots; \ + if(roots->roots) { \ + sort_and_merge_roots(roots); \ + for(j = 0; j < roots->count; j += 2) { \ + void **start = (void**)roots->roots[j]; \ + void **end = (void**)roots->roots[j+1]; \ + while(start < end) { \ + set_bt_src(start, BT_ROOT); \ + gcMUCK(*start++); \ + } \ + } \ + } \ + } inline static void mark_roots(NewGC *gc) { @@ -1156,8 +1242,8 @@ inline static void check_finalizers(NewGC *gc, int level) struct finalizer *next = GC_resolve(work->next); GCDEBUG((DEBUGOUTF, - "CFNL: Level %i finalizer %p on %p queued for finalization.\n", - work->eager_level, work, work->p)); + "CFNL: Level %i finalizer %p on %p queued for finalization.\n", + work->eager_level, work, work->p)); set_backtrace_source(work, BT_FINALIZER); gcMARK(work->p); if(prev) prev->next = next; @@ -1170,8 +1256,8 @@ inline static void check_finalizers(NewGC *gc, int level) work = next; } else { GCDEBUG((DEBUGOUTF, "CFNL: Not finalizing %p (level %i on %p): %p / %i\n", - work, work->eager_level, work->p, pagemap_find_page(gc->page_maps, work->p), - marked(work->p))); + work, work->eager_level, work->p, pagemap_find_page(gc->page_maps, work->p), + marked(work->p))); prev = work; work = GC_resolve(work->next); } @@ -1186,8 +1272,8 @@ inline static void do_ordered_level3(NewGC *gc) for(temp = GC_resolve(gc->finalizers); temp; temp = GC_resolve(temp->next)) if(!marked(gc, temp->p)) { GCDEBUG((DEBUGOUTF, - "LVL3: %p is not marked. Marking payload (%p)\n", - temp, temp->p)); + "LVL3: %p is not marked. Marking payload (%p)\n", + temp, temp->p)); set_backtrace_source(temp, BT_FINALIZER); if(temp->tagged) mark_table[*(unsigned short*)temp->p](temp->p); if(!temp->tagged) GC_mark_xtagged(temp->p); @@ -1432,7 +1518,7 @@ static int designate_modified_gc(NewGC *gc, void *p) if(page) { if (!page->back_pointers) { page->mprotected = 0; - vm_protect_pages(page->addr, page->big_page ? round_to_apage_size(page->size) : APAGE_SIZE, 1); + vm_protect_pages(page->addr, (page->size_class > 1) ? round_to_apage_size(page->size) : APAGE_SIZE, 1); page->back_pointers = 1; return 1; } @@ -1545,9 +1631,9 @@ void GC_init_type_tags(int count, int pair, int mutable_pair, int weakbox, int e } void GC_construct_child_gc() { - NewGC *gc = MASTERGC; - NewGC *newgc = init_type_tags_worker(gc, 0, 0, 0, gc->weak_box_tag, gc->ephemeron_tag, gc->weak_array_tag, gc->cust_box_tag); - newgc->primoridal_gc = MASTERGC; + NewGC *gc = MASTERGC; + NewGC *newgc = init_type_tags_worker(gc, 0, 0, 0, gc->weak_box_tag, gc->ephemeron_tag, gc->weak_array_tag, gc->cust_box_tag); + newgc->primoridal_gc = MASTERGC; } static inline void save_globals_to_gc(NewGC *gc) { @@ -1592,7 +1678,7 @@ void GC_gcollect(void) } void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark, - Fixup_Proc fixup, int constant_Size, int atomic) + Fixup_Proc fixup, int constant_Size, int atomic) { NewGC *gc = GC_get_GC(); @@ -1655,48 +1741,61 @@ void GC_mark(const void *const_p) #endif } - if(page->big_page) { - /* This is a bigpage. The first thing we do is see if its been marked - previously */ - if(page->big_page != 1) { - GCDEBUG((DEBUGOUTF, "Not marking %p on big %p (already marked)\n", p, page)); - return; - } - /* in this case, it has not. So we want to mark it, first off. */ - page->big_page = 2; + if(page->size_class) { + if(page->size_class > 1) { + /* This is a bigpage. The first thing we do is see if its been marked + previously */ + if(page->size_class != 2) { + GCDEBUG((DEBUGOUTF, "Not marking %p on big %p (already marked)\n", p, page)); + return; + } + /* in this case, it has not. So we want to mark it, first off. */ + page->size_class = 3; - /* if this is in the nursery, we want to move it out of the nursery */ - if(!page->generation) { - page->generation = 1; + /* if this is in the nursery, we want to move it out of the nursery */ + if(!page->generation) { + page->generation = 1; - /* remove page */ - if(page->prev) page->prev->next = page->next; else - gc->gen0.big_pages = page->next; - if(page->next) page->next->prev = page->prev; + /* remove page */ + if(page->prev) page->prev->next = page->next; else + gc->gen0.big_pages = page->next; + if(page->next) page->next->prev = page->prev; - backtrace_new_page(gc, page); + backtrace_new_page(gc, page); - /* add to gen1 */ - page->next = gc->gen1_pages[PAGE_BIG]; - page->prev = NULL; - if(page->next) page->next->prev = page; - gc->gen1_pages[PAGE_BIG] = page; + /* add to gen1 */ + page->next = gc->gen1_pages[PAGE_BIG]; + page->prev = NULL; + if(page->next) page->next->prev = page; + gc->gen1_pages[PAGE_BIG] = page; - /* if we're doing memory accounting, then we need to make sure the - btc_mark is right */ + /* if we're doing memory accounting, then we need to make sure the + btc_mark is right */ #ifdef NEWGC_BTC_ACCOUNT - BTC_set_btc_mark(gc, PTR(NUM(page->addr) + PREFIX_SIZE)); + BTC_set_btc_mark(gc, PTR(NUM(page->addr) + PREFIX_SIZE)); #endif - } + } - page->marked_on = 1; - record_backtrace(page, PTR(NUM(page->addr) + PREFIX_SIZE + WORD_SIZE)); - GCDEBUG((DEBUGOUTF, "Marking %p on big page %p\n", p, page)); - /* Finally, we want to add this to our mark queue, so we can - propagate its pointers */ - push_ptr(p); - } - else { + page->marked_on = 1; + record_backtrace(page, PTR(NUM(page->addr) + PREFIX_SIZE + WORD_SIZE)); + GCDEBUG((DEBUGOUTF, "Marking %p on big page %p\n", p, page)); + /* Finally, we want to add this to our mark queue, so we can + propagate its pointers */ + push_ptr(p); + } else { + /* A medium page. */ + struct objhead *info = MED_OBJHEAD(p, page->size); + if (info->mark) { + GCDEBUG((DEBUGOUTF,"Not marking %p (already marked)\n", p)); + return; + } + info->mark = 1; + page->marked_on = 1; + p = PTR(NUM(info) + WORD_SIZE); + record_backtrace(page, p); + push_ptr(p); + } + } else { struct objhead *ohead = (struct objhead *)(NUM(p) - WORD_SIZE); if(ohead->mark) { @@ -1721,7 +1820,7 @@ void GC_mark(const void *const_p) record_backtrace(page, p); push_ptr(p); } else GCDEBUG((DEBUGOUTF, "Not marking %p (it's old; %p / %i)\n", - p, page, page->previous_size)); + p, page, page->previous_size)); } else { /* this is a generation 0 object. This means that we do have to do all of the above. Fun, fun, fun. */ @@ -1820,13 +1919,14 @@ static void propagate_marks(NewGC *gc) /* we can assume a lot here -- like it's a valid pointer with a page -- because we vet bad cases out in GC_mark, above */ - if(page->big_page) { - void **start = PPTR(NUM(page->addr) + PREFIX_SIZE + WORD_SIZE); - void **end = PPTR(NUM(page->addr) + page->size); + if(page->size_class) { + if(page->size_class > 1) { + void **start = PPTR(NUM(page->addr) + PREFIX_SIZE + WORD_SIZE); + void **end = PPTR(NUM(page->addr) + page->size); - set_backtrace_source(start, page->page_type); + set_backtrace_source(start, page->page_type); - switch(page->page_type) { + switch(page->page_type) { case PAGE_TAGGED: { unsigned short tag = *(unsigned short*)start; @@ -1840,22 +1940,24 @@ static void propagate_marks(NewGC *gc) case PAGE_ATOMIC: break; case PAGE_ARRAY: while(start < end) gcMARK(*(start++)); break; case PAGE_XTAGGED: GC_mark_xtagged(start); break; - case PAGE_TARRAY: { - unsigned short tag = *(unsigned short *)start; - end -= INSET_WORDS; - while(start < end) { - GC_ASSERT(mark_table[tag]); - start += mark_table[tag](start); - } - break; - } - } - } else { - struct objhead *info = (struct objhead *)(NUM(p) - WORD_SIZE); + case PAGE_TARRAY: + { + unsigned short tag = *(unsigned short *)start; + end -= INSET_WORDS; + while(start < end) { + GC_ASSERT(mark_table[tag]); + start += mark_table[tag](start); + } + break; + } + } + } else { + /* Medium page */ + struct objhead *info = (struct objhead *)(NUM(p) - WORD_SIZE); - set_backtrace_source(p, info->type); + set_backtrace_source(p, info->type); - switch(info->type) { + switch(info->type) { case PAGE_TAGGED: { unsigned short tag = *(unsigned short*)p; @@ -1863,24 +1965,46 @@ static void propagate_marks(NewGC *gc) mark_table[tag](p); break; } - case PAGE_ATOMIC: break; - case PAGE_ARRAY: { - void **start = p; - void **end = PPTR(info) + info->size; - while(start < end) gcMARK(*start++); - break; - } - case PAGE_TARRAY: { - void **start = p; - void **end = PPTR(info) + (info->size - INSET_WORDS); - unsigned short tag = *(unsigned short *)start; - while(start < end) { - GC_ASSERT(mark_table[tag]); - start += mark_table[tag](start); - } - break; - } - case PAGE_XTAGGED: GC_mark_xtagged(p); break; + case PAGE_ARRAY: + { + void **start = p; + void **end = PPTR(info) + info->size; + while(start < end) gcMARK(*start++); + break; + } + } + } + } else { + struct objhead *info = (struct objhead *)(NUM(p) - WORD_SIZE); + + set_backtrace_source(p, info->type); + + switch(info->type) { + case PAGE_TAGGED: + { + unsigned short tag = *(unsigned short*)p; + GC_ASSERT(mark_table[tag]); + mark_table[tag](p); + break; + } + case PAGE_ATOMIC: break; + case PAGE_ARRAY: { + void **start = p; + void **end = PPTR(info) + info->size; + while(start < end) gcMARK(*start++); + break; + } + case PAGE_TARRAY: { + void **start = p; + void **end = PPTR(info) + (info->size - INSET_WORDS); + unsigned short tag = *(unsigned short *)start; + while(start < end) { + GC_ASSERT(mark_table[tag]); + start += mark_table[tag](start); + } + break; + } + case PAGE_XTAGGED: GC_mark_xtagged(p); break; } } } @@ -1892,7 +2016,7 @@ void *GC_resolve(void *p) struct mpage *page = pagemap_find_page(gc->page_maps, p); struct objhead *info; - if(!page || page->big_page) + if(!page || page->size_class) return p; info = (struct objhead *)(NUM(p) - WORD_SIZE); @@ -1920,7 +2044,7 @@ void GC_fixup(void *pp) if((page = pagemap_find_page(gc->page_maps, p))) { struct objhead *info; - if(page->big_page) return; + if(page->size_class) return; info = (struct objhead *)(NUM(p) - WORD_SIZE); if(info->mark && info->moved) *(void**)pp = *(void**)p; @@ -1935,12 +2059,15 @@ void GC_fixup(void *pp) #ifdef MZ_GC_BACKTRACE # define trace_page_t struct mpage # define trace_page_type(page) (page)->page_type - static void *trace_pointer_start(struct mpage *page, void *p) { - if (page->big_page) +static void *trace_pointer_start(struct mpage *page, void *p) { + if (page->size_class) { + if (page->size_class > 1) return PTR(NUM(page->addr) + PREFIX_SIZE + WORD_SIZE); - else - return p; - } + else + return PTR(NUM(MED_OBJHEAD(p, page->size)) + WORD_SIZE); + } else + return p; +} # define TRACE_PAGE_TAGGED PAGE_TAGGED # define TRACE_PAGE_ARRAY PAGE_ARRAY # define TRACE_PAGE_TAGGED_ARRAY PAGE_TARRAY @@ -1948,7 +2075,7 @@ void GC_fixup(void *pp) # define TRACE_PAGE_XTAGGED PAGE_XTAGGED # define TRACE_PAGE_MALLOCFREE PAGE_TYPES # define TRACE_PAGE_BAD PAGE_TYPES -# define trace_page_is_big(page) (page)->big_page +# define trace_page_is_big(page) (page)->size_class # define trace_backpointer get_backtrace # include "backtrace.c" #else @@ -1960,12 +2087,12 @@ void GC_fixup(void *pp) #define MAX_DUMP_TAG 256 void GC_dump_with_traces(int flags, - GC_get_type_name_proc get_type_name, - GC_get_xtagged_name_proc get_xtagged_name, - GC_for_each_found_proc for_each_found, - short trace_for_tag, - GC_print_tagged_value_proc print_tagged_value, - int path_length_limit) + GC_get_type_name_proc get_type_name, + GC_get_xtagged_name_proc get_xtagged_name, + GC_for_each_found_proc for_each_found, + short trace_for_tag, + GC_print_tagged_value_proc print_tagged_value, + int path_length_limit) { NewGC *gc = GC_get_GC(); mpage *page; @@ -2045,15 +2172,15 @@ void GC_dump_with_traces(int flags, count++; } GCWARN((GCOUTF, "Generation 1 [%s]: %li bytes used in %li pages\n", - type_name[i], total_use, count)); + type_name[i], total_use, count)); } GCWARN((GCOUTF,"\n")); GCWARN((GCOUTF,"Current memory use: %li\n", GC_get_memory_use(NULL))); GCWARN((GCOUTF,"Peak memory use after a collection: %li\n", gc->peak_memory_use)); GCWARN((GCOUTF,"Allocated (+reserved) page sizes: %li (+%li)\n", - gc->used_pages * APAGE_SIZE, - vm_memory_allocated(gc->vm) - (gc->used_pages * APAGE_SIZE))); + gc->used_pages * APAGE_SIZE, + vm_memory_allocated(gc->vm) - (gc->used_pages * APAGE_SIZE))); GCWARN((GCOUTF,"# of major collections: %li\n", gc->num_major_collects)); GCWARN((GCOUTF,"# of minor collections: %li\n", gc->num_minor_collects)); GCWARN((GCOUTF,"# of installed finalizers: %i\n", gc->num_fnls)); @@ -2098,49 +2225,81 @@ void *GC_next_tagged_start(void *p) /* garbage collection */ /*****************************************************************************/ +static void reset_gen1_page(NewGC *gc, mpage *work) +{ + if (gc->generations_available && work->mprotected) { + work->mprotected = 0; + add_protect_page_range(gc->protect_range, work->addr, + (work->size_class > 1) ? round_to_apage_size(work->size) : APAGE_SIZE, + APAGE_SIZE, 1); + } +} + static void reset_gen1_pages_live_and_previous_sizes(NewGC *gc) { - Page_Range *protect_range = gc->protect_range; mpage *work; int i; GCDEBUG((DEBUGOUTF, "MAJOR COLLECTION - PREPPING PAGES - reset live_size, reset previous_size, unprotect.\n")); /* we need to make sure that previous_size for every page is reset, so we don't accidentally screw up the mark routine */ + for(i = 0; i < PAGE_TYPES; i++) { for(work = gc->gen1_pages[i]; work; work = work->next) { - if (gc->generations_available && work->mprotected) { - work->mprotected = 0; - add_protect_page_range(protect_range, work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, APAGE_SIZE, 1); - } + reset_gen1_page(gc, work); work->live_size = 0; work->previous_size = PREFIX_SIZE; } } - flush_protect_page_ranges(protect_range, 1); + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (work = gc->med_pages[i]; work; work = work->next) { + if (work->generation) { + reset_gen1_page(gc, work); + } + } + } + + flush_protect_page_ranges(gc->protect_range, 1); +} + +static void remove_gen1_page_from_pagemap(NewGC *gc, mpage *work) +{ + if (gc->generations_available && work->back_pointers && work->mprotected) { + work->mprotected = 0; + add_protect_page_range(gc->protect_range, work->addr, + (work->size_class > 1) ? round_to_apage_size(work->size) : APAGE_SIZE, + APAGE_SIZE, 1); + } + pagemap_remove(gc->page_maps, work); + work->added = 0; } static void remove_all_gen1_pages_from_pagemap(NewGC *gc) { - Page_Range *protect_range = gc->protect_range; - PageMap pagemap = gc->page_maps; mpage *work; int i; GCDEBUG((DEBUGOUTF, "MINOR COLLECTION - PREPPING PAGES - remove all gen1 pages from pagemap.\n")); + /* if we're not doing a major collection, then we need to remove all the pages in gc->gen1_pages[] from the page map */ + for(i = 0; i < PAGE_TYPES; i++) { for(work = gc->gen1_pages[i]; work; work = work->next) { - if (gc->generations_available && work->back_pointers && work->mprotected) { - work->mprotected = 0; - add_protect_page_range(protect_range, work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, APAGE_SIZE, 1); - } - pagemap_remove(pagemap, work); - work->added = 0; + remove_gen1_page_from_pagemap(gc, work); } } - flush_protect_page_ranges(protect_range, 1); + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (work = gc->med_pages[i]; work; work = work->next) { + if (work->generation) { + remove_gen1_page_from_pagemap(gc, work); + } + } + } + + flush_protect_page_ranges(gc->protect_range, 1); } static void mark_backpointers(NewGC *gc) @@ -2151,7 +2310,7 @@ static void mark_backpointers(NewGC *gc) PageMap pagemap = gc->page_maps; /* if this is not a full collection, then we need to mark any pointers - which point backwards into generation 0, since they're roots. */ + that point backwards into generation 0, since they're roots. */ for(i = 0; i < PAGE_TYPES; i++) { for(work = gc->gen1_pages[i]; work; work = work->next) { if(work->back_pointers) { @@ -2160,8 +2319,9 @@ static void mark_backpointers(NewGC *gc) work->marked_on = 1; work->previous_size = PREFIX_SIZE; pagemap_add(pagemap, work); - if(work->big_page) { - work->big_page = 2; + if(work->size_class) { + /* must be a big page */ + work->size_class = 3; push_ptr(PPTR(NUM(work->addr) + PREFIX_SIZE + sizeof(struct objhead))); } else { if(work->page_type != PAGE_ATOMIC) { @@ -2185,11 +2345,33 @@ static void mark_backpointers(NewGC *gc) work->previous_size = PREFIX_SIZE; } else { GCDEBUG((DEBUGOUTF,"Setting previous_size on %p to %i\n", work, - work->size)); + work->size)); work->previous_size = work->size; } } } + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (work = gc->med_pages[i]; work; work = work->next) { + if(work->back_pointers) { + void **start = PPTR(NUM(work->addr) + PREFIX_SIZE); + void **end = PPTR(NUM(work->addr) + APAGE_SIZE - work->size); + + work->marked_on = 1; + pagemap_add(pagemap, work); + + while(start <= end) { + struct objhead *info = (struct objhead *)start; + if(!info->dead) { + info->mark = 1; + /* This must be a push_ptr (see below) */ + push_ptr(start + 1); + } + start += info->size; + } + } + } + } } } @@ -2202,7 +2384,7 @@ struct mpage *allocate_compact_target(NewGC *gc, mpage *work) npage->previous_size = npage->size = PREFIX_SIZE; npage->generation = 1; npage->back_pointers = 0; - npage->big_page = 0; + npage->size_class = 0; npage->page_type = work->page_type; npage->marked_on = 1; backtrace_new_page(gc, npage); @@ -2244,7 +2426,7 @@ inline static void do_heap_compact(NewGC *gc) unsigned long avail; GCDEBUG((DEBUGOUTF, "Compacting page %p: new version at %p\n", - work, npage)); + work, npage)); if (npage == work) { /* Need to insert a page: */ @@ -2276,7 +2458,7 @@ inline static void do_heap_compact(NewGC *gc) } GCDEBUG((DEBUGOUTF,"Moving size %i object from %p to %p\n", - gcWORDS_TO_BYTES(info->size), start+1, newplace+1)); + gcWORDS_TO_BYTES(info->size), start+1, newplace+1)); memcpy(newplace, start, gcWORDS_TO_BYTES(info->size)); info->moved = 1; *(PPTR(NUM(start) + WORD_SIZE)) = PTR(NUM(newplace) + WORD_SIZE); @@ -2324,30 +2506,31 @@ static void repair_heap(NewGC *gc) if(page->marked_on) { page->has_new = 0; /* these are guaranteed not to be protected */ - if(page->big_page) { + if(page->size_class) { + /* since we get here via gen1_pages, it's a big page */ void **start = PPTR(NUM(page->addr) + PREFIX_SIZE + WORD_SIZE); void **end = PPTR(NUM(page->addr) + page->size); GCDEBUG((DEBUGOUTF, "Cleaning objs on page %p, starting with %p\n", - page, start)); - page->big_page = 1; /* remove the mark */ + page, start)); + page->size_class = 2; /* remove the mark */ switch(page->page_type) { - case PAGE_TAGGED: - fixup_table[*(unsigned short*)start](start); - break; - case PAGE_ATOMIC: break; - case PAGE_ARRAY: - while(start < end) gcFIXUP(*(start++)); - break; - case PAGE_XTAGGED: - GC_fixup_xtagged(start); - break; - case PAGE_TARRAY: { - unsigned short tag = *(unsigned short *)start; - end -= INSET_WORDS; - while(start < end) start += fixup_table[tag](start); - break; - } + case PAGE_TAGGED: + fixup_table[*(unsigned short*)start](start); + break; + case PAGE_ATOMIC: break; + case PAGE_ARRAY: + while(start < end) gcFIXUP(*(start++)); + break; + case PAGE_XTAGGED: + GC_fixup_xtagged(start); + break; + case PAGE_TARRAY: { + unsigned short tag = *(unsigned short *)start; + end -= INSET_WORDS; + while(start < end) start += fixup_table[tag](start); + break; + } } } else { void **start = PPTR(NUM(page->addr) + page->previous_size); @@ -2423,10 +2606,43 @@ static void repair_heap(NewGC *gc) } else GCDEBUG((DEBUGOUTF,"Not Cleaning page %p\n", page)); } } + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (page = gc->med_pages[i]; page; page = page->next) { + if (page->marked_on) { + void **start = PPTR(NUM(page->addr) + PREFIX_SIZE); + void **end = PPTR(NUM(page->addr) + APAGE_SIZE - page->size); + + while(start < end) { + struct objhead *info = (struct objhead *)start; + if(info->mark) { + switch(info->type) { + case PAGE_ARRAY: + { + void **tempend = (start++) + info->size; + while(start < tempend) gcFIXUP(*start++); + } + break; + case PAGE_TAGGED: + { + fixup_table[*(unsigned short*)(start+1)](start+1); + start += info->size; + } + break; + } + info->mark = 0; + } else { + info->dead = 1; + start += info->size; + } + } + } + } + } } static inline void gen1_free_mpage(PageMap pagemap, mpage *page) { - size_t real_page_size = page->big_page ? round_to_apage_size(page->size) : APAGE_SIZE; + size_t real_page_size = (page->size_class > 1) ? round_to_apage_size(page->size) : APAGE_SIZE; pagemap_remove(pagemap, page); free_backtrace(page); free_pages(GC, page->addr, real_page_size); @@ -2495,7 +2711,62 @@ static void clean_up_heap(NewGC *gc) } } } - + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + mpage *work; + mpage *prev = NULL, *next; + + for (work = gc->med_pages[i]; work; work = next) { + if (work->marked_on) { + void **start = PPTR(NUM(work->addr) + PREFIX_SIZE); + void **end = PPTR(NUM(work->addr) + APAGE_SIZE - work->size); + int non_dead = 0; + + while(start <= end) { + struct objhead *info = (struct objhead *)start; + if (!info->dead) { + non_dead++; + } + start += info->size; + } + + next = work->next; + if (non_dead) { + work->live_size = (work->size * non_dead); + memory_in_use += work->live_size; + work->previous_size = PREFIX_SIZE; + work->back_pointers = work->marked_on = 0; + work->generation = 1; + pagemap_add(pagemap, work); + prev = work; + } else { + /* free the page */ + if(prev) prev->next = next; else gc->med_pages[i] = next; + if(next) work->next->prev = prev; + if (work->mprotected) *(long *)0x0 = 1; + gen1_free_mpage(pagemap, work); + } + } else if (gc->gc_full || !work->generation) { + /* Page wasn't touched in full GC, or gen-0 not touched, + so we can free it. */ + next = work->next; + if(prev) prev->next = next; else gc->med_pages[i] = next; + if(next) work->next->prev = prev; + if (work->mprotected) *(long *)0x0 = 1; + gen1_free_mpage(pagemap, work); + } else { + /* not touched during minor gc */ + memory_in_use += work->live_size; + work->previous_size = PREFIX_SIZE; + next = work->next; + prev = work; + work->back_pointers = 0; + pagemap_add(pagemap, work); + } + } + gc->med_freelist_pages[i] = prev; + } + gc->memory_in_use = memory_in_use; cleanup_vacated_pages(gc); } @@ -2506,7 +2777,7 @@ static void protect_old_pages(NewGC *gc) struct mpage *page; int i; - for(i = 0; i < PAGE_TYPES; i++) + for(i = 0; i < PAGE_TYPES; i++) { if(i != PAGE_ATOMIC) for(page = gc->gen1_pages[i]; page; page = page->next) if(page->page_type != PAGE_ATOMIC) { @@ -2515,6 +2786,16 @@ static void protect_old_pages(NewGC *gc) add_protect_page_range(protect_range, page->addr, page->size, APAGE_SIZE, 0); } } + } + + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (page = gc->med_pages[i]; page; page = page->next) { + if (!page->mprotected) { + page->mprotected = 1; + add_protect_page_range(protect_range, page->addr, page->size, APAGE_SIZE, 0); + } + } + } flush_protect_page_ranges(protect_range, 0); } @@ -2822,7 +3103,7 @@ void GC_free_all(void) next = work->next; if (work->mprotected) - vm_protect_pages(work->addr, work->big_page ? round_to_apage_size(work->size) : APAGE_SIZE, 1); + vm_protect_pages(work->addr, (work->size_class > 1) ? round_to_apage_size(work->size) : APAGE_SIZE, 1); gen1_free_mpage(pagemap, work); } } diff --git a/src/mzscheme/gc2/newgc.h b/src/mzscheme/gc2/newgc.h index 435dae0d11..d29d636933 100644 --- a/src/mzscheme/gc2/newgc.h +++ b/src/mzscheme/gc2/newgc.h @@ -5,8 +5,8 @@ typedef struct mpage { struct mpage *next; struct mpage *prev; void *addr; - unsigned long previous_size; - unsigned long size; + unsigned long previous_size; /* for med page, points to place to search for available block */ + unsigned long size; /* big page size or med page element size */ unsigned char generation; /* unsigned char back_pointers :1; @@ -17,7 +17,7 @@ typedef struct mpage { unsigned char mprotected :1; */ unsigned char back_pointers ; - unsigned char big_page ; + unsigned char size_class ; /* 1 => med; 2 => big; 3 => big marked */ unsigned char page_type ; unsigned char marked_on ; unsigned char has_new ; @@ -92,6 +92,8 @@ typedef mpage ****PageMap; typedef mpage **PageMap; #endif +#define NUM_MED_PAGE_SIZES (((LOG_APAGE_SIZE - 1) - 3) + 1) + typedef struct NewGC { Gen0 gen0; Mark_Proc *mark_table; /* the table of mark procs */ @@ -101,6 +103,8 @@ typedef struct NewGC { struct mpage *gen1_pages[PAGE_TYPES]; Page_Range *protect_range; + struct mpage *med_pages[NUM_MED_PAGE_SIZES]; + struct mpage *med_freelist_pages[NUM_MED_PAGE_SIZES]; /* Finalization */ Fnl *run_queue; diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 67b9e3c28b..fd3e59f66a 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -1140,7 +1140,7 @@ typedef struct Scheme_Cont_Mark_Set { Scheme_Object *native_stack_trace; } Scheme_Cont_Mark_Set; -#define SCHEME_LOG_MARK_SEGMENT_SIZE 8 +#define SCHEME_LOG_MARK_SEGMENT_SIZE 6 #define SCHEME_MARK_SEGMENT_SIZE (1 << SCHEME_LOG_MARK_SEGMENT_SIZE) #define SCHEME_MARK_SEGMENT_MASK (SCHEME_MARK_SEGMENT_SIZE - 1) From 104dde2a08f6e96289ce2f825f4760bd52f58fba Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 19 Apr 2009 22:20:46 +0000 Subject: [PATCH 42/79] added back in support for the with-border? flag svn: r14561 --- .../framework/private/decorated-editor-snip.ss | 18 +++++++++++------- 1 file changed, 11 insertions(+), 7 deletions(-) diff --git a/collects/framework/private/decorated-editor-snip.ss b/collects/framework/private/decorated-editor-snip.ss index f495ee35a6..969e76c446 100644 --- a/collects/framework/private/decorated-editor-snip.ss +++ b/collects/framework/private/decorated-editor-snip.ss @@ -22,6 +22,9 @@ (define editor-snip:decorated-mixin (mixin ((class->interface editor-snip%)) (editor-snip:decorated<%>) + (init [with-border? #t]) + (define draw-border? with-border?) + ;; get-corner-bitmap : -> (union #f (is-a?/c bitmap%)) ;; returns the bitmap to be shown in the top right corner. (define/public (get-corner-bitmap) #f) @@ -152,13 +155,14 @@ (+ x (unbox bil) 2) (+ y (unbox bmt)))]))) - (send dc set-pen (get-pen)) - (send dc set-brush (get-brush)) - (send dc draw-rectangle - (+ x (unbox bil)) - (+ y (unbox bit)) - (max 0 (- (unbox bw) (unbox bil) (unbox bir))) - (max 0 (- (unbox bh) (unbox bit) (unbox bib)))) + (when draw-border? + (send dc set-pen (get-pen)) + (send dc set-brush (get-brush)) + (send dc draw-rectangle + (+ x (unbox bil)) + (+ y (unbox bit)) + (max 0 (- (unbox bw) (unbox bil) (unbox bir))) + (max 0 (- (unbox bh) (unbox bit) (unbox bib))))) (send dc set-pen old-pen) (send dc set-brush old-brush)))) From 9c0f6bc775226aa9bbbd96d16e978f20bc1b1103 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 20 Apr 2009 07:46:50 +0000 Subject: [PATCH 43/79] its typos svn: r14562 --- collects/scribblings/framework/scheme.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/framework/scheme.scrbl b/collects/scribblings/framework/scheme.scrbl index e7f1c5bd3a..3534b8a1d3 100644 --- a/collects/scribblings/framework/scheme.scrbl +++ b/collects/scribblings/framework/scheme.scrbl @@ -57,7 +57,7 @@ The result of this method is used to determine if the return key automatically tabs over to the correct position. - Override it to change it's behavior. + Override it to change its behavior. } @@ -199,7 +199,7 @@ } @defmethod*[(((mark-matching-parenthesis (pos exact-positive-integer)) void))]{ If the paren after @scheme[pos] is matched, this method - highlights it and it's matching counterpart in dark green. + highlights it and its matching counterpart in dark green. } @defmethod*[(((get-tab-size) exact-integer))]{ From 10421f6153c4124f24aabf049ba0da77333893b4 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 20 Apr 2009 07:50:20 +0000 Subject: [PATCH 44/79] Welcome to a new PLT day. svn: r14563 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 997ff6fa0b..88f7f6389b 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "19apr2009") +#lang scheme/base (provide stamp) (define stamp "20apr2009") From d9ae39c2182b5538d40138f71105598b5539847c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 20 Apr 2009 07:55:41 +0000 Subject: [PATCH 45/79] bar typos svn: r14564 --- collects/scribblings/framework/color.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index 59b53cdafa..b796f2ee0b 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -71,7 +71,7 @@ closing parenthesis, each closing symbol in pairs will be converted to a string and tried as a closing parenthesis. } - @defmethod*[(((stop-colorer (clear-colors boolean |#t|)) void))]{ + @defmethod*[(((stop-colorer (clear-colors boolean #t)) void))]{ Stops coloring and paren matching the buffer. @@ -106,7 +106,7 @@ entire text is brought up-to-date. It must not be called on a locked text. } - @defmethod*[(((thaw-colorer (recolor boolean |#t|) (retokenize boolean |#f|)) void))]{ + @defmethod*[(((thaw-colorer (recolor boolean #t) (retokenize boolean #f)) void))]{ Start coloring a frozen buffer again. From da4742700bbe8c680c0ef4ba7875d5b32b384005 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 20 Apr 2009 08:20:19 +0000 Subject: [PATCH 46/79] scheme expression typos svn: r14565 --- collects/scribblings/framework/color.scrbl | 54 +++++++++------------- 1 file changed, 23 insertions(+), 31 deletions(-) diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index b796f2ee0b..c158f7970a 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -12,7 +12,7 @@ Starts tokenizing the buffer for coloring and parenthesis matching. - token-sym-style will be passed the first return symbol from get-token + @scheme[token-sym-style] will be passed the first return symbol from @scheme[get-token] and should return the style-name that the token should be colored. get-token takes an input port and returns the next token as 5 values: @@ -22,11 +22,11 @@ component of the token and may be used as such in the future.} @item{ A symbol describing the type of the token. This symbol is transformed - into a style-name via the token-sym->style argument. The symbols - 'white-space and 'comment have special meaning and should always be + into a style-name via the @scheme[token-sym->style] argument. The symbols + @scheme['white-space] and @scheme['comment] have special meaning and should always be returned for white space and comment tokens respectively. The symbol @scheme['no-color] can be used to indicate that although the token is not white - space, it should not be colored. The symbol 'eof must be used to + space, it should not be colored. The symbol @scheme['eof] must be used to indicate when all the tokens have been consumed.} @item{ A symbol indicating how the token should be treated by the paren @@ -36,7 +36,7 @@ @item{ The ending position of the token.}] - get-token will usually be implemented with a lexer using the + @scheme[get-token] will usually be implemented with a lexer using the @scheme[parser-tools/lex] library. get-token must obey the following invariants: @itemize[ @@ -44,7 +44,7 @@ Every position in the buffer must be accounted for in exactly one token.} @item{ - The token returned by get-token must rely only on the contents of the + The token returned by @scheme[get-token] must rely only on the contents of the input port argument. This means that the tokenization of some part of the input cannot depend on earlier parts of the input.} @item{ @@ -57,14 +57,14 @@ the buffer look like: @verbatim{" 1 2 3"} would result in a single string token modifying previous tokens. To - handle these situations, get-token must treat the first line as a + handle these situations, @scheme[get-token] must treat the first line as a single token.}] @scheme[pairs] is a list of different kinds of matching parens. The second value returned by get-token is compared to this list to see how the paren matcher should treat the token. An example: Suppose pairs is @scheme['((|(| |)|) (|[| |]|) (begin end))]. This means that there - are three kinds of parens. Any token which has 'begin as its second + are three kinds of parens. Any token which has @scheme['begin] as its second return value will act as an open for matching tokens with 'end. Similarly any token with @scheme['|]|] will act as a closing match for tokens with @scheme['|[|]. When trying to correct a mismatched @@ -75,7 +75,7 @@ Stops coloring and paren matching the buffer. - If clear-colors is true all the text in the buffer will have it's + If @scheme[clear-colors] is true all the text in the buffer will have its style set to Standard. } @defmethod*[(((force-stop-colorer (stop? boolean?)) void))]{ @@ -83,7 +83,7 @@ Intended for debugging purposes only. - stop? determines whether the system is being forced to stop or allowed + @scheme[stop?] determines whether the system is being forced to stop or allowed to wake back up. } @defmethod*[(((is-stopped?) boolean?))]{ @@ -96,13 +96,11 @@ and @method[color:text<%> thaw-colorer]. - } @defmethod*[(((freeze-colorer) void))]{ Keep the text tokenized and paren matched, but stop altering the colors. - - freeze-colorer will not return until the coloring/tokenization of the + @scheme[freeze-colorer] will not return until the coloring/tokenization of the entire text is brought up-to-date. It must not be called on a locked text. } @@ -110,13 +108,13 @@ Start coloring a frozen buffer again. - If recolor? is @scheme[#t], the text is re-colored. If it is - @scheme[#f] the text is not recolored. When recolor? is @scheme[#t], - retokenize? controls how the text is recolored. @scheme[#f] causes + If @scheme[recolor?] is @scheme[#t], the text is re-colored. If it is + @scheme[#f] the text is not recolored. When @scheme[recolor?] is @scheme[#t], + @scheme[retokenize?] controls how the text is recolored. @scheme[#f] causes the text to be entirely re-colored before thaw-colorer returns using the existing tokenization. @scheme[#t] causes the entire text to be retokenized and recolored from scratch. This will happen in the - background after the call to thaw-colorer returns. + background after the call to @scheme[thaw-colorer] returns. } @defmethod*[(((reset-region (start natural-number?) (end (union (quote end) natural-number?))) void))]{ @@ -134,19 +132,16 @@ @defmethod*[(((skip-whitespace (position natural-number?) (direction (symbols (quote forward) (quote backward))) (comments? boolean?)) natural-number?))]{ Returns the next non-whitespace character. - Starts from position and skips whitespace in the direction indicated - by direction. If comments? is true, comments are skipped as well as + by direction. If @scheme[comments?] is true, comments are skipped as well as whitespace. skip-whitespace determines whitespaces and comments by - comparing the token type to 'white-space and 'comment. + comparing the token type to @scheme['white-space] and @scheme['comment]. Must only be called while the tokenizer is started. } @defmethod*[(((backward-match (position natural-number?) (cutoff natural-number?)) (union natural-number? false?)))]{ - - - Skip all consecutive whitespaces and comments (using skip-whitespace) + Skip all consecutive whitespaces and comments (using @scheme[skip-whitespace]) immediately preceding the position. If the token at this position is a close, return the position of the matching open, or @scheme[#f] if there is none. If the token was an open, return @scheme[#f]. For any @@ -163,9 +158,7 @@ } @defmethod*[(((forward-match (position natural-number?) (cutoff natural-number?)) (union natural-number? false?)))]{ - - - Skip all consecutive whitespaces and comments (using skip-whitespace) + Skip all consecutive whitespaces and comments (using @scheme[skip-whitespace]) immediately following position. If the token at this position is an open, return the position of the matching close, or @scheme[#f] if there is none. For any other token, return the end of that token. @@ -174,12 +167,11 @@ } @defmethod*[(((insert-close-paren (position natural-number?) (char char?) (flash? boolean?) (fixup? boolean?)) void))]{ - Position is the place to put the parenthesis and char is the - parenthesis to be added. If fixup? is true, the right kind of closing + parenthesis to be added. If @scheme[fixup?] is true, the right kind of closing parenthesis will be chosen from the pairs list kept last passed to - start-colorer, otherwise char will be inserted, even if it is not the - right kind. If flash? is true the matching open parenthesis will be + @scheme[start-colorer], otherwise char will be inserted, even if it is not the + right kind. If @scheme[flash?] is true the matching open parenthesis will be flashed. } @defmethod*[(((classify-position (position natural-number?)) symbol?))]{ @@ -218,7 +210,7 @@ @defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{ This mixin adds coloring functionality to the mode. - @defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) |scheme(λ (x) "Standard"))|) (matches (listof (list/c symbol? symbol?)) null))]{ + @defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) @scheme[(λ (x) "Standard")])|) (matches (listof (list/c symbol? symbol?)) null))]{ The arguments are passed to @method[color:text<%> start-colorer]. From f51f8c8b7fc94d4a51d2b33ca147fce9e3b1415a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 20 Apr 2009 13:14:40 +0000 Subject: [PATCH 47/79] avoid generating unnecessary struct-accessor and -mutator names svn: r14566 --- collects/scheme/private/class-internal.ss | 33 +++++++++++---------- collects/scribblings/reference/struct.scrbl | 10 ++++--- src/mzscheme/src/jit.c | 5 ++-- src/mzscheme/src/struct.c | 22 ++++++++++---- 4 files changed, 42 insertions(+), 28 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index 289dd7ff8e..a0831ca2d3 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -1327,9 +1327,9 @@ rename-super-temp ... rename-super-extra-temp ... rename-inner-temp ... rename-inner-extra-temp ... method-accessor ...) ; for a local call that needs a dynamic lookup - (let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos)] + (let ([local-field-accessor (make-struct-field-accessor local-accessor local-field-pos #f)] ... - [local-field-mutator (make-struct-field-mutator local-mutator local-field-pos)] + [local-field-mutator (make-struct-field-mutator local-mutator local-field-pos #f)] ...) (syntax-parameterize ([this-param (make-this-map (quote-syntax this-id) @@ -2102,9 +2102,9 @@ ;; Use public field names to name the accessors and mutators (let-values ([(inh-accessors inh-mutators) (values - (map (lambda (id) (make-class-field-accessor super id)) + (map (lambda (id) (make-class-field-accessor super id #f)) inherit-field-names) - (map (lambda (id) (make-class-field-mutator super id)) + (map (lambda (id) (make-class-field-mutator super id #f)) inherit-field-names))]) ;; -- Reset field table to register accessor and mutator info -- ;; There are more accessors and mutators than public fields... @@ -2959,7 +2959,7 @@ (loop (wrapper-object-wrapped loop-object))))))) - (define (class-field-X who which cwhich class name) + (define (class-field-X who which cwhich class name proc-field-name) (unless (class? class) (raise-type-error who "class" class)) (unless (symbol? name) @@ -2969,17 +2969,17 @@ (obj-error who "no such field: ~a~a" name (for-class (class-name class)))))]) - (which (cwhich (car p)) (cdr p) name))) + (which (cwhich (car p)) (cdr p) proc-field-name))) - (define (make-class-field-accessor class name) + (define (make-class-field-accessor class name keep-name?) (class-field-X 'class-field-accessor make-struct-field-accessor class-field-ref - class name)) + class name (and keep-name? name))) - (define (make-class-field-mutator class name) + (define (make-class-field-mutator class name keep-name?) (class-field-X 'class-field-mutator make-struct-field-mutator class-field-set! - class name)) + class name (and keep-name? name))) (define-struct generic (name applicable)) @@ -3060,7 +3060,7 @@ (define-syntaxes (class-field-accessor class-field-mutator generic/form) (let ([mk - (lambda (make targets) + (lambda (make targets extra-args) (lambda (stx) (syntax-case stx () [(_ class-expr name) @@ -3072,8 +3072,9 @@ stx name)) (with-syntax ([name (localize name)] - [make make]) - (syntax/loc stx (make class-expr `name))))] + [make make] + [extra-args extra-args]) + (syntax/loc stx (make class-expr `name . extra-args))))] [(_ class-expr) (raise-syntax-error #f @@ -3081,9 +3082,9 @@ targets) stx)])))]) (values - (mk (quote-syntax make-class-field-accessor) "class") - (mk (quote-syntax make-class-field-mutator) "class") - (mk (quote-syntax make-generic/proc) "class or interface")))) + (mk (quote-syntax make-class-field-accessor) "class" (list #'#t)) + (mk (quote-syntax make-class-field-mutator) "class" (list #'#t)) + (mk (quote-syntax make-generic/proc) "class or interface" null)))) (define-syntax (class-field-accessor-traced stx) (syntax-case stx () diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index 554580ed8c..b4bb35bf2e 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/collects/scribblings/reference/struct.scrbl @@ -237,7 +237,8 @@ The result of @scheme[make-struct-type] is five values: @defproc[(make-struct-field-accessor [accessor-proc struct-accessot-procedure?] [field-pos exact-nonnegative-integer?] - [field-name symbol?]) + [field-name (or/c symbol? #f) + (symbol->string (format "field~a" field-pos))]) procedure?]{ Returns a field accessor that is equivalent to @scheme[(lambda (s) @@ -245,13 +246,14 @@ Returns a field accessor that is equivalent to @scheme[(lambda (s) an @tech{accessor} returned by @scheme[make-struct-type]. The name of the resulting procedure for debugging purposes is derived from @scheme[field-name] and the name of @scheme[accessor-proc]'s -structure type. +structure type if @scheme[field-name] is a symbol. For examples, see @scheme[make-struct-type].} @defproc[(make-struct-field-mutator [mutator-proc struct-mutator-procedure?] [field-pos exact-nonnegative-integer?] - [field-name symbol?]) + [field-name (or/c symbol? #f) + (symbol->string (format "field~a" field-pos))]) procedure?]{ Returns a field mutator that is equivalent to @scheme[(lambda (s v) @@ -259,7 +261,7 @@ Returns a field mutator that is equivalent to @scheme[(lambda (s v) a @tech{mutator} returned by @scheme[make-struct-type]. The name of the resulting procedure for debugging purposes is derived from @scheme[field-name] and the name of @scheme[mutator-proc]'s -structure type. +structure type if @scheme[field-name] is a symbol. For examples, see @scheme[make-struct-type].} diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index a430ec9e62..9791eff342 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -2863,12 +2863,13 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ if (reorder_ok) { if (no_call < 2) { - generate(rator, jitter, 0, 0, JIT_V1); /* sync'd below */ + generate(rator, jitter, 0, 0, JIT_V1); /* sync'd below, or not */ } CHECK_LIMIT(); } - mz_rs_sync(); + if (!no_call) + mz_rs_sync(); END_JIT_DATA(20); diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index d3f23a65ab..1c86cd4b8e 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -2164,19 +2164,29 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter, pos = parse_pos(who, i, argv, argc); if (argc > 2) { - if (!SCHEME_SYMBOLP(argv[2])) { - scheme_wrong_type(who, "symbol", 2, argc, argv); - return NULL; + if (SCHEME_FALSEP(argv[2])) { + fieldstr = NULL; + fieldstrlen = 0; + } else { + if (!SCHEME_SYMBOLP(argv[2])) { + scheme_wrong_type(who, "symbol or #f", 2, argc, argv); + return NULL; + } + fieldstr = scheme_symbol_val(argv[2]); + fieldstrlen = SCHEME_SYM_LEN(argv[2]); } - fieldstr = scheme_symbol_val(argv[2]); - fieldstrlen = SCHEME_SYM_LEN(argv[2]); } else { sprintf(digitbuf, "field%d", (int)SCHEME_INT_VAL(argv[1])); fieldstr = digitbuf; fieldstrlen = strlen(fieldstr); } - if (getter) { + if (!fieldstr) { + if (getter) + name = "accessor"; + else + name = "mutator"; + } else if (getter) { name = (char *)GET_NAME((char *)i->struct_type->name, -1, fieldstr, fieldstrlen, 0); } else { From 7cee07e02da9dce5d9109b8dcfe9350fc0fe0aa9 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 20 Apr 2009 16:41:57 +0000 Subject: [PATCH 48/79] disable buggy medium-allocation code svn: r14567 --- src/mzscheme/gc2/newgc.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 0387b84724..23dd750e5d 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -563,6 +563,9 @@ static void *allocate_medium(size_t sizeb, int type) struct mpage *page; struct objhead *info; + /* TEMPORARILY DISABLE MEDIUM PAGES */ + return allocate_big(sizeb, type); + if (sizeb > (1 << (LOG_APAGE_SIZE - 1))) return allocate_big(sizeb, type); From 77ec85a66ba3751d2d8ebb3ab8d192cc09a80746 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 20 Apr 2009 17:02:27 +0000 Subject: [PATCH 49/79] Unbalance | was breaking build. Revert if fixed wrong svn: r14568 --- collects/scribblings/framework/color.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index c158f7970a..c4b8641b56 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -210,7 +210,7 @@ @defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{ This mixin adds coloring functionality to the mode. - @defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) @scheme[(λ (x) "Standard")])|) (matches (listof (list/c symbol? symbol?)) null))]{ + @defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) |@scheme[(λ (x) "Standard")])|) (matches (listof (list/c symbol? symbol?)) null))]{ The arguments are passed to @method[color:text<%> start-colorer]. From 943c743e04048aff874ee7ab0dd3eb4dd814d675 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 20 Apr 2009 19:45:51 +0000 Subject: [PATCH 50/79] restore medium-page GC support svn: r14569 --- src/mzscheme/gc2/newgc.c | 13 ++++--------- 1 file changed, 4 insertions(+), 9 deletions(-) diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 23dd750e5d..9b4f86061a 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -563,9 +563,6 @@ static void *allocate_medium(size_t sizeb, int type) struct mpage *page; struct objhead *info; - /* TEMPORARILY DISABLE MEDIUM PAGES */ - return allocate_big(sizeb, type); - if (sizeb > (1 << (LOG_APAGE_SIZE - 1))) return allocate_big(sizeb, type); @@ -583,7 +580,7 @@ static void *allocate_medium(size_t sizeb, int type) page = gc->med_freelist_pages[pos]; if (page) { n = page->previous_size; - while (n < APAGE_SIZE) { + while (n <= (APAGE_SIZE - sz)) { info = (struct objhead *)PTR(NUM(page->addr) + n); if (info->dead) { info->dead = 0; @@ -2367,7 +2364,7 @@ static void mark_backpointers(NewGC *gc) struct objhead *info = (struct objhead *)start; if(!info->dead) { info->mark = 1; - /* This must be a push_ptr (see below) */ + /* This must be a push_ptr (see above) */ push_ptr(start + 1); } start += info->size; @@ -2616,7 +2613,7 @@ static void repair_heap(NewGC *gc) void **start = PPTR(NUM(page->addr) + PREFIX_SIZE); void **end = PPTR(NUM(page->addr) + APAGE_SIZE - page->size); - while(start < end) { + while(start <= end) { struct objhead *info = (struct objhead *)start; if(info->mark) { switch(info->type) { @@ -2746,7 +2743,6 @@ static void clean_up_heap(NewGC *gc) /* free the page */ if(prev) prev->next = next; else gc->med_pages[i] = next; if(next) work->next->prev = prev; - if (work->mprotected) *(long *)0x0 = 1; gen1_free_mpage(pagemap, work); } } else if (gc->gc_full || !work->generation) { @@ -2755,7 +2751,6 @@ static void clean_up_heap(NewGC *gc) next = work->next; if(prev) prev->next = next; else gc->med_pages[i] = next; if(next) work->next->prev = prev; - if (work->mprotected) *(long *)0x0 = 1; gen1_free_mpage(pagemap, work); } else { /* not touched during minor gc */ @@ -2795,7 +2790,7 @@ static void protect_old_pages(NewGC *gc) for (page = gc->med_pages[i]; page; page = page->next) { if (!page->mprotected) { page->mprotected = 1; - add_protect_page_range(protect_range, page->addr, page->size, APAGE_SIZE, 0); + add_protect_page_range(protect_range, page->addr, APAGE_SIZE, APAGE_SIZE, 0); } } } From 8918328e8a06d4cc7973bd94cb6c436e286d0be1 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 20 Apr 2009 22:41:37 +0000 Subject: [PATCH 51/79] Infer on ((lambda add types for matchable? and match-equality-test svn: r14570 --- collects/typed-scheme/private/base-env.ss | 4 +++- collects/typed-scheme/typecheck/tc-app-unit.ss | 9 ++++++++- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 4fbde9fbb6..55b5b9ca54 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -9,7 +9,7 @@ (only-in '#%kernel [apply kernel:apply]) scheme/promise (only-in string-constants/private/only-once maybe-print-message) - (only-in scheme/match/runtime match:error)) + (only-in scheme/match/runtime match:error matchable? match-equality-test)) [raise (Univ . -> . (Un))] @@ -148,6 +148,8 @@ [(Sym B -Namespace (-> Univ)) Univ])] [match:error (Univ . -> . (Un))] +[match-equality-test (-Param (Univ Univ . -> . Univ) (Univ Univ . -> . Univ))] +[matchable? (make-pred-ty (Un -String -Bytes))] [display (cl-> [(Univ) -Void] [(Univ -Port) -Void])] [write (cl-> [(Univ) -Void] [(Univ -Port) -Void])] [print (cl-> [(Univ) -Void] [(Univ -Port) -Void])] diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index 63db7660b9..f3a951e8a7 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -21,7 +21,7 @@ (only-in scheme/private/class-internal make-object do-make-object))) (require (r:infer constraint-structs)) -(import tc-expr^ tc-lambda^ tc-dots^) +(import tc-expr^ tc-lambda^ tc-dots^ tc-let^) (export tc-app^) ;; comparators that inform the type system @@ -779,6 +779,13 @@ (match-let* ([ft (tc-expr #'f)] [(tc-result: t) (tc/funapp #'f #'(arg) ft (list (ret ty)) #f)]) (ret (Un (-val #f) t)))))] + ;; infer for ((lambda + [(#%plain-app (#%plain-lambda (x ...) . body) args ...) + (= (length (syntax->list #'(x ...))) + (length (syntax->list #'(args ...)))) + (tc/let-values/check #'((x) ...) #'(args ...) #'body + #'(let-values ([(x) args] ...) . body) + expected)] ;; default case [(#%plain-app f args ...) (tc/funapp #'f #'(args ...) (tc-expr #'f) (map tc-expr (syntax->list #'(args ...))) expected)])) From 6586dbcb793036a0d22bac104d1c91d779fad3b3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 21 Apr 2009 05:15:53 +0000 Subject: [PATCH 52/79] JIT correction for detecting struct mutator in closure svn: r14571 --- src/mzscheme/src/jit.c | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 9791eff342..31f70fe9a9 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -1557,7 +1557,7 @@ static int inlined_binary_prim(Scheme_Object *o, Scheme_Object *_app, mz_jit_sta { return ((SCHEME_PRIMP(o) && (SCHEME_PRIM_PROC_FLAGS(o) & SCHEME_PRIM_IS_BINARY_INLINED)) - || inlineable_struct_prim(o, jitter, 1, 2)); + || inlineable_struct_prim(o, jitter, 2, 2)); } static int inlined_nary_prim(Scheme_Object *o, Scheme_Object *_app) @@ -4626,7 +4626,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i Scheme_Object *rator = app->rator; if (!for_branch - && inlineable_struct_prim(rator, jitter, 1, 2)) { + && inlineable_struct_prim(rator, jitter, 2, 2)) { generate_inlined_struct_op(3, jitter, rator, app->rand1, app->rand2, for_branch, branch_short, multi_ok); scheme_direct_call_count++; return 1; From be15b146ed83b1be21a3eccf42f8ace316454b47 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 21 Apr 2009 14:56:42 +0000 Subject: [PATCH 53/79] Welcome to a new PLT day. svn: r14572 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 88f7f6389b..38fa49d58e 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "20apr2009") +#lang scheme/base (provide stamp) (define stamp "21apr2009") From b1b5fe481681aef76c06b8abf1abe4cc267533ec Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 21 Apr 2009 15:35:05 +0000 Subject: [PATCH 54/79] Add test for match improvements. Improve handling of inference for let loop. svn: r14573 --- collects/tests/typed-scheme/succeed/for-lists.ss | 6 ++++++ collects/tests/typed-scheme/succeed/match-tests.ss | 9 +++++++++ collects/typed-scheme/typecheck/tc-app-unit.ss | 7 ++++++- 3 files changed, 21 insertions(+), 1 deletion(-) create mode 100644 collects/tests/typed-scheme/succeed/for-lists.ss create mode 100644 collects/tests/typed-scheme/succeed/match-tests.ss diff --git a/collects/tests/typed-scheme/succeed/for-lists.ss b/collects/tests/typed-scheme/succeed/for-lists.ss new file mode 100644 index 0000000000..2cd0205886 --- /dev/null +++ b/collects/tests/typed-scheme/succeed/for-lists.ss @@ -0,0 +1,6 @@ +#lang typed-scheme + +(: f ((Listof Number) -> (Listof Number))) +(define (f x) + (for/lists (#{y : (Listof Number)}) ([e (in-list x)]) + e)) diff --git a/collects/tests/typed-scheme/succeed/match-tests.ss b/collects/tests/typed-scheme/succeed/match-tests.ss new file mode 100644 index 0000000000..3686d07c2f --- /dev/null +++ b/collects/tests/typed-scheme/succeed/match-tests.ss @@ -0,0 +1,9 @@ +#lang typed-scheme + +(require scheme/match) + +(match "abc" + [(regexp "^abc") 1]) + +(match (list 1 1) + [(list x x) 1]) diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index f3a951e8a7..698e3c9c36 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -811,7 +811,12 @@ (ret expected))] ;; special case when argument needs inference [_ - (let ([ts (map (compose generalize tc-expr/t) (syntax->list actuals))]) + (let ([ts (for/list ([ac (syntax->list actuals)] + [f (syntax->list args)]) + (or + (type-annotation f #:infer #t) + (generalize (tc-expr/t ac))))]) + (printf "case 2 ~a~n" ts) (tc/rec-lambda/check form args body lp ts expected) (ret expected))])) From 60325b670c25276dddcf904b801bbde922ca2302 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 21 Apr 2009 16:13:00 +0000 Subject: [PATCH 55/79] Fix handling of filters that refer to out-of-scope vars svn: r14574 --- .../typed-scheme/unit-tests/typecheck-tests.ss | 18 +++++++++--------- collects/typed-scheme/env/lexical-env.ss | 6 +++--- collects/typed-scheme/typecheck/tc-if-unit.ss | 6 ++++-- 3 files changed, 16 insertions(+), 14 deletions(-) diff --git a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss index ee5a483b99..ff39c7f171 100644 --- a/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/typecheck-tests.ss @@ -87,7 +87,7 @@ (+ 1 (car x)) 5)) N] - + (tc-e (if (let ([y 12]) y) 3 4) -Integer) (tc-e 3 -Integer) (tc-e "foo" -String) (tc-e (+ 3 4) -Integer) @@ -496,10 +496,10 @@ [tc-e (raise-type-error 'foo "bar" 7 (list 5)) (Un)] #;[tc-e - (let ((x '(1 3 5 7 9))) - (do: : Number ((x : (list-of Number) x (cdr x)) - (sum : Number 0 (+ sum (car x)))) - ((null? x) sum))) + (let ((x '(1 3 5 7 9))) + (do: : Number ((x : (list-of Number) x (cdr x)) + (sum : Number 0 (+ sum (car x)))) + ((null? x) sum))) N] @@ -541,10 +541,10 @@ [tc-e `(4 ,@'(3)) (-pair N (-lst N))] [tc-e - (let ((x '(1 3 5 7 9))) - (do: : Number ((x : (Listof Number) x (cdr x)) - (sum : Number 0 (+ sum (car x)))) - ((null? x) sum))) + (let ((x '(1 3 5 7 9))) + (do: : Number ((x : (Listof Number) x (cdr x)) + (sum : Number 0 (+ sum (car x)))) + ((null? x) sum))) N] [tc-e (if #f 1 'foo) (-val 'foo)] diff --git a/collects/typed-scheme/env/lexical-env.ss b/collects/typed-scheme/env/lexical-env.ss index 9ade4f0a67..659cd8b814 100644 --- a/collects/typed-scheme/env/lexical-env.ss +++ b/collects/typed-scheme/env/lexical-env.ss @@ -25,7 +25,7 @@ ;; find the type of identifier i, looking first in the lexical env, then in the top-level env ;; identifer -> Type -(define (lookup-type/lexical i) +(define (lookup-type/lexical i [fail #f]) (lookup (lexical-env) i (lambda (i) (lookup-type i (lambda () @@ -33,7 +33,7 @@ => (lambda (a) (-lst (substitute Univ (cdr a) (car a))))] - [else (lookup-fail i)])))))) + [else ((or fail lookup-fail) i)])))))) ;; refine the type of i in the lexical env ;; (identifier type -> type) identifier -> environment @@ -43,7 +43,7 @@ (define (update f k env) (parameterize ([current-orig-stx k]) - (let* ([v (lookup-type/lexical k)] + (let* ([v (lookup-type/lexical k (lambda _ Univ))] [new-v (f k v)] [new-env (extend env k new-v)]) new-env))) diff --git a/collects/typed-scheme/typecheck/tc-if-unit.ss b/collects/typed-scheme/typecheck/tc-if-unit.ss index 3c279453d8..e8537c6507 100644 --- a/collects/typed-scheme/typecheck/tc-if-unit.ss +++ b/collects/typed-scheme/typecheck/tc-if-unit.ss @@ -45,7 +45,8 @@ (syntax-rules () [(check-rest f v) (with-update-type/lexical f v (loop (cdr effs)))] - [(check-rest f t v) (check-rest (type-op f t) v)])) + [(check-rest f t v) + (check-rest (type-op f t) v)])) (if (null? effs) ;; base case (let* ([reachable? (not (unbox flag))]) @@ -83,7 +84,8 @@ ;; just replace the type of v with (-val #f) [(Var-False-Effect: v) (check-rest (lambda (_ old) (-val #f)) v)] ;; v cannot have type (-val #f) - [(Var-True-Effect: v) (check-rest *remove (-val #f) v)]))))) + [(Var-True-Effect: v) + (check-rest *remove (-val #f) v)]))))) ;; the main function (define (tc/if-twoarm tst thn els) From 4bc2ddaf9d73ad6865b3059b995a15389f56f39a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 21 Apr 2009 16:37:25 +0000 Subject: [PATCH 56/79] snip and editor-data class lists need to be eventspace-specific svn: r14575 --- collects/mred/mred.ss | 7 ++++++- collects/mred/private/wxme/snip.ss | 14 ++++++++++---- 2 files changed, 16 insertions(+), 5 deletions(-) diff --git a/collects/mred/mred.ss b/collects/mred/mred.ss index 0ba30ed867..de283d13ff 100644 --- a/collects/mred/mred.ss +++ b/collects/mred/mred.ss @@ -74,6 +74,11 @@ (namespace-require 'scheme/class)) ns)) + (define (make-eventspace) + (parameterize ([wx:the-snip-class-list (wx:make-the-snip-class-list)] + [wx:the-editor-data-class-list (wx:make-the-editor-data-class-list)]) + (wx:make-eventspace))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (define-syntax propagate @@ -139,7 +144,6 @@ is-color-display? key-event% keymap% - make-eventspace editor-admin% editor-set-x-selection-mode editor-snip-editor-admin<%> @@ -307,6 +311,7 @@ current-eventspace-has-standard-menus? current-eventspace-has-menu-root? eventspace-handler-thread + make-eventspace make-gui-namespace make-gui-empty-namespace file-creator-and-type diff --git a/collects/mred/private/wxme/snip.ss b/collects/mred/private/wxme/snip.ss index 6b2da06896..22b4c0daf5 100644 --- a/collects/mred/private/wxme/snip.ss +++ b/collects/mred/private/wxme/snip.ss @@ -26,6 +26,11 @@ get-the-snip-class-list get-the-editor-data-class-list the-editor-snip-class + + the-snip-class-list ;; parameter + make-the-snip-class-list + the-editor-data-class-list ;; parameter + make-the-editor-data-class-list (struct-out snip-class-link) (struct-out editor-data-class-link) @@ -1321,9 +1326,10 @@ (define (make-the-snip-class-list) (new standard-snip-class-list%)) -(define the-snip-class-list (make-the-snip-class-list)) +(define the-snip-class-list (make-parameter (make-the-snip-class-list))) + (define (get-the-snip-class-list) - the-snip-class-list) + (the-snip-class-list)) ;; ------------------------------------------------------------ @@ -1463,9 +1469,9 @@ (define (make-the-editor-data-class-list) (new editor-data-class-list%)) -(define the-editor-data-class-list (make-the-editor-data-class-list)) +(define the-editor-data-class-list (make-parameter (make-the-editor-data-class-list))) (define (get-the-editor-data-class-list) - the-editor-data-class-list) + (the-editor-data-class-list)) ;; ------------------------------------------------------------ From f86c9e3d857ad3aab1ad9ab03debb26e36792536 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 21 Apr 2009 16:39:13 +0000 Subject: [PATCH 57/79] fix backtrace to work with new medium-object pages svn: r14576 --- src/mzscheme/gc2/Makefile.in | 2 +- src/mzscheme/gc2/newgc.c | 56 +++++++++++++++++++++++++++++++++++- 2 files changed, 56 insertions(+), 2 deletions(-) diff --git a/src/mzscheme/gc2/Makefile.in b/src/mzscheme/gc2/Makefile.in index bdbf6a0a35..7208a49765 100644 --- a/src/mzscheme/gc2/Makefile.in +++ b/src/mzscheme/gc2/Makefile.in @@ -132,7 +132,7 @@ xsrc: xobjects: $(OBJS) main.@LTO@ -XFORMDEP = $(srcdir)/gc2.h $(srcdir)/xform.ss $(srcdir)/xform-mod.ss \ +XFORMDEP = $(srcdir)/gc2.h $(srcdir)/gc2_obj.h $(srcdir)/xform.ss $(srcdir)/xform-mod.ss \ $(srcdir)/precomp.c $(srcdir)/../src/schpriv.h $(srcdir)/../include/scheme.h \ $(srcdir)/../sconfig.h $(srcdir)/../uconfig.h $(srcdir)/../src/schemef.h \ $(srcdir)/../src/stypes.h diff --git a/src/mzscheme/gc2/newgc.c b/src/mzscheme/gc2/newgc.c index 9b4f86061a..129c030cad 100644 --- a/src/mzscheme/gc2/newgc.c +++ b/src/mzscheme/gc2/newgc.c @@ -1020,9 +1020,12 @@ static void backtrace_new_page(NewGC *gc, mpage *page) page->backtrace = (void **)malloc_pages(gc, APAGE_SIZE, APAGE_SIZE); } +# define backtrace_new_page_if_needed(gc, page) if (!page->backtrace) backtrace_new_page(gc, page) + static void free_backtrace(struct mpage *page) { - free_pages(GC, page->backtrace, APAGE_SIZE); + if (page->backtrace) + free_pages(GC, page->backtrace, APAGE_SIZE); } static void *bt_source; @@ -1082,6 +1085,7 @@ static void *get_backtrace(struct mpage *page, void *ptr) #else # define backtrace_new_page(gc, page) /* */ +# define backtrace_new_page_if_needed(gc, page) /* */ # define free_backtrace(page) /* */ # define set_backtrace_source(ptr, type) /* */ # define record_backtrace(page, ptr) /* */ @@ -1792,6 +1796,7 @@ void GC_mark(const void *const_p) info->mark = 1; page->marked_on = 1; p = PTR(NUM(info) + WORD_SIZE); + backtrace_new_page_if_needed(gc, page); record_backtrace(page, p); push_ptr(p); } @@ -2144,6 +2149,31 @@ void GC_dump_with_traces(int flags, } } } + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + for (page = gc->med_pages[i]; page; page = page->next) { + void **start = PPTR(NUM(page->addr) + PREFIX_SIZE); + void **end = PPTR(NUM(page->addr) + APAGE_SIZE - page->size); + + while(start <= end) { + struct objhead *info = (struct objhead *)start; + if (!info->dead) { + if (info->type == PAGE_TAGGED) { + unsigned short tag = *(unsigned short *)(start + 1); + if (tag < MAX_DUMP_TAG) { + counts[tag]++; + sizes[tag] += info->size; + } + if (tag == trace_for_tag) { + register_traced_object(start + 1); + if (for_each_found) + for_each_found(start + 1); + } + } + } + start += info->size; + } + } + } GCPRINT(GCOUTF, "Begin MzScheme3m\n"); for (i = 0; i < MAX_DUMP_TAG; i++) { @@ -2175,6 +2205,30 @@ void GC_dump_with_traces(int flags, type_name[i], total_use, count)); } + GCWARN((GCOUTF, "Generation 1 [medium]:")); + for (i = 0; i < NUM_MED_PAGE_SIZES; i++) { + if (gc->med_pages[i]) { + long count = 0, page_count = 0; + for (page = gc->med_pages[i]; page; page = page->next) { + void **start = PPTR(NUM(page->addr) + PREFIX_SIZE); + void **end = PPTR(NUM(page->addr) + APAGE_SIZE - page->size); + + page_count++; + + while(start <= end) { + struct objhead *info = (struct objhead *)start; + if (!info->dead) { + count += info->size; + } + start += info->size; + } + } + GCWARN((GCOUTF, " %li [%li/%li]", count, page_count, gc->med_pages[i]->size)); + } + } + GCWARN((GCOUTF, "\n")); + + GCWARN((GCOUTF,"\n")); GCWARN((GCOUTF,"Current memory use: %li\n", GC_get_memory_use(NULL))); GCWARN((GCOUTF,"Peak memory use after a collection: %li\n", gc->peak_memory_use)); From 932fe179f896831f73fe4c62b7f5a370fc1a4cf3 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 21 Apr 2009 16:44:41 +0000 Subject: [PATCH 58/79] drop a bad R6RS test (PR 10210) svn: r14577 --- collects/tests/r6rs/syntax-case.sls | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/r6rs/syntax-case.sls b/collects/tests/r6rs/syntax-case.sls index 696a2e98f3..a06279347d 100644 --- a/collects/tests/r6rs/syntax-case.sls +++ b/collects/tests/r6rs/syntax-case.sls @@ -216,7 +216,7 @@ (test (bound-identifier=? #'cons #'kons) #f) (test (free-identifier=? #'x #'x) #t) (test (free-identifier=? #'x #'y) #f) - (test (free-identifier=? #'cons #'kons) #t) + ;; (test (free-identifier=? #'cons #'kons) #t) ;; see PLT bug report #10210 (test (syntax->datum #'1) 1) (test (syntax->datum #'a) 'a) From 1edd4770f4f73daf82601a20d9e4c44854fee261 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 21 Apr 2009 17:43:33 +0000 Subject: [PATCH 59/79] remove debug printf svn: r14578 --- collects/typed-scheme/typecheck/tc-app-unit.ss | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index 698e3c9c36..e0a64c4c64 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -816,7 +816,6 @@ (or (type-annotation f #:infer #t) (generalize (tc-expr/t ac))))]) - (printf "case 2 ~a~n" ts) (tc/rec-lambda/check form args body lp ts expected) (ret expected))])) From 062008c7586ec2192d1a3b51f6a27402a8e7efb9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 21 Apr 2009 22:51:55 +0000 Subject: [PATCH 60/79] type for append-map svn: r14579 --- collects/typed-scheme/private/base-env.ss | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 55b5b9ca54..b6e34edfdb 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -571,6 +571,9 @@ (cl->* ((-lst a) . -> . (-lst a)) ((-lst a) (a a . -> . Univ) . -> . (-lst a))))] +[append-map + (-polydots (c a b) ((list ((list a) (b b) . ->... . (-lst c)) (-lst a)) + ((-lst b) b) . ->... .(-lst c)))] ;; scheme/tcp [tcp-listener? (make-pred-ty -TCP-Listener)] From ec615d48827ad39bff082e5e48d7194c3a5b9b4b Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 21 Apr 2009 23:41:50 +0000 Subject: [PATCH 61/79] add some function tests svn: r14580 --- collects/tests/honu/basic.honu | 42 ++++++++++++++++++++++++++++++---- 1 file changed, 38 insertions(+), 4 deletions(-) diff --git a/collects/tests/honu/basic.honu b/collects/tests/honu/basic.honu index b05716e989..90486092b1 100644 --- a/collects/tests/honu/basic.honu +++ b/collects/tests/honu/basic.honu @@ -13,7 +13,41 @@ obj test(t, a, b){ } } -var x = 3; -const y = 2; -test("x = 3", x, 3); -test("y = 2", y, 2); +obj test1(){ + var x = 3; + const y = 2; + test("x = 3", x, 3); + test("y = 2", y, 2); +} + +obj test2(){ + obj foo(){ + 1; + } + + obj x1(){ + obj x(){ + 2; + } + } + + (-> obj) x2(){ + obj x(){ + 3; + } + } + + /* + var anonymous_foo = obj x(){ + 2; + }; + */ + + var anonymous_foo = x2(); + + test("foo() = 1", foo(), 1); + test("anonymous_foo = 2", anonymous_foo(), 2); +} + +test1(); +test2(); From 2bd98fbdb2427e16cebaae66c305f72da19a8bb7 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Tue, 21 Apr 2009 23:49:34 +0000 Subject: [PATCH 62/79] fix one test, break another svn: r14581 --- collects/tests/honu/basic.honu | 8 ++++++-- 1 file changed, 6 insertions(+), 2 deletions(-) diff --git a/collects/tests/honu/basic.honu b/collects/tests/honu/basic.honu index 90486092b1..e5a22358cd 100644 --- a/collects/tests/honu/basic.honu +++ b/collects/tests/honu/basic.honu @@ -29,12 +29,14 @@ obj test2(){ obj x(){ 2; } + x; } - + (-> obj) x2(){ obj x(){ 3; } + x; } /* @@ -43,10 +45,12 @@ obj test2(){ }; */ - var anonymous_foo = x2(); + var anonymous_foo = x1(); + var x2_x = x2(); test("foo() = 1", foo(), 1); test("anonymous_foo = 2", anonymous_foo(), 2); + test("x2_x = 3", x2_x(), 3); } test1(); From 30bb8ed26322e9ef75e71b93747ab89e991561f5 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 22 Apr 2009 00:42:47 +0000 Subject: [PATCH 63/79] some slightly less-boring examples svn: r14582 --- collects/scribblings/guide/simple-data.scrbl | 13 ++- .../scribblings/guide/simple-syntax.scrbl | 92 ++++++++++--------- collects/scribblings/guide/welcome.scrbl | 58 ++++++------ 3 files changed, 85 insertions(+), 78 deletions(-) diff --git a/collects/scribblings/guide/simple-data.scrbl b/collects/scribblings/guide/simple-data.scrbl index 1272860289..933debcfdf 100644 --- a/collects/scribblings/guide/simple-data.scrbl +++ b/collects/scribblings/guide/simple-data.scrbl @@ -15,10 +15,9 @@ and imaginary numbers: @moreguide["numbers"]{numbers} @schemeblock[ -1 1.0 -1/2 0.5 -9999999999999999999999 1e+22 -1+2i 1.0+2.0i +1 3.14 +1/2 6.02e+23 +1+2i 9999999999999999999999 ] @defterm{Booleans} are @scheme[#t] for true and @scheme[#f] for @@ -36,8 +35,8 @@ appear in a string constant. @moreguide["strings"]{strings} @schemeblock[ -"hello world" -"A \"fancy\" string" +"Hello, world!" +"Benjamin \"Bugsy\" Siegel" "\u03BBx:(\u03BC\u03B1.\u03B1\u2192\u03B1).xx" ] @@ -49,5 +48,5 @@ difference between an input expression and a printed result. @examples[ (eval:alts (unsyntax (schemevalfont "1.0000")) 1.0000) -(eval:alts (unsyntax (schemevalfont "\"A \\u0022fancy\\u0022 string\"")) "A \u0022fancy\u0022 string") +(eval:alts (unsyntax (schemevalfont "\"Bugs \\u0022Figaro\\u0022 Bunny\"")) "Bugs \u0022Figaro\u0022 Bunny") ] diff --git a/collects/scribblings/guide/simple-syntax.scrbl b/collects/scribblings/guide/simple-syntax.scrbl index 924880fe0d..5d949d9b45 100644 --- a/collects/scribblings/guide/simple-syntax.scrbl +++ b/collects/scribblings/guide/simple-syntax.scrbl @@ -81,11 +81,11 @@ the last @nonterm{expr}. @defexamples[ #:eval ex-eval -(code:line (define five 5) (code:comment #, @t{defines @scheme[five] to be @scheme[5]})) +(code:line (define pie 3) (code:comment #, @t{defines @scheme[pie] to be @scheme[3]})) (code:line (define (piece str) (code:comment #, @t{defines @scheme[piece] as a function}) - (substring str 0 five)) (code:comment #, @t{of one argument})) -five -(piece "hello world") + (substring str 0 pie)) (code:comment #, @t{ of one argument})) +pie +(piece "key lime") ] Under the hood, a function definition is really the same as a @@ -100,8 +100,6 @@ piece substring ] -@; FIXME: check that everything says "procedure" and not "primitive" - A function definition can include multiple expressions for the function's body. In that case, only the value of the last expression is returned when the function is called. The other expressions are @@ -109,30 +107,30 @@ evaluated only for some side-effect, such as printing. @defexamples[ #:eval ex-eval -(define (greet name) - (printf "returning a greeting for ~a...\n" name) - (string-append "hello " name)) -(greet "universe") +(define (bake flavor) + (printf "pre-heating oven...\n") + (string-append flavor " pie")) +(bake "apple") ] -Scheme programmers prefer to avoid assignment statements. It's +Scheme programmers prefer to avoid side-effects. It's important, though, to understand that multiple expressions are allowed in a definition body, because it explains why the following -@scheme[nogreet] function simply returns its argument: +@scheme[nobake] function simply returns its argument: @def+int[ #:eval ex-eval -(define (nogreet name) - string-append "hello " name) -(nogreet "world") +(define (nobake flavor) + string-append flavor "jello") +(nobake "green") ] -Within @scheme[nogreet], there are no parentheses around -@scheme[string-append "hello " name], so they are three separate +Within @scheme[nobake], there are no parentheses around +@scheme[string-append flavor "jello"], so they are three separate expressions instead of one function-call expression. The expressions -@scheme[string-append] and @scheme["hello "] are evaluated, but the +@scheme[string-append] and @scheme[flavor] are evaluated, but the results are never used. Instead, the result of the function is just -the result of the expression @scheme[name]. +the result of the final expression, @scheme["jello"]. @; ---------------------------------------------------------------------- @section[#:tag "indentation"]{An Aside on Indenting Code} @@ -161,13 +159,14 @@ next line under the first argument, instead of under the @scheme[define] keyword: @schemeblock[ -(define (nogreet name - (string-append "hello " name))) +(define (halfbake flavor + (string-append flavor " creme brulee"))) ] -Furthermore, when an open parenthesis has no matching close -parenthesis in a program, both @exec{mzscheme} and DrScheme use the -source's indentation to suggest where it might be missing. +In this case, indentation helps highlight the mistake. In other cases, +where the indentation may be normal while an open parenthesis has no +matching close parenthesis; both @exec{mzscheme} and DrScheme use the +source's indentation to suggest where a parenthesis might be missing. @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @section{Identifiers} @@ -193,11 +192,11 @@ more examples: @schemeblock[ #, @schemeid[+] -#, @schemeid[Apple] +#, @schemeid[Hfuhruhurr] #, @schemeid[integer?] -#, @schemeid[call/cc] -#, @schemeid[call-with-composable-continuation] -#, @schemeid[x-1+3i] +#, @schemeid[pass/fail] +#, @schemeid[john-jacob-jingleheimer-schmidt] +#, @schemeid[a-b-c+1-2-3] ] @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -225,10 +224,10 @@ pre-defined names are hyperlinked to the reference manual. So, you can click on an identifier to get full details about its use. @interaction[ -(code:line (string-append "hello" " " "scheme") (code:comment #, @t{append strings})) -(code:line (substring "hello scheme" 6 12) (code:comment #, @t{extract a substring})) -(code:line (string-length "scheme") (code:comment #, @t{get a string's length})) -(code:line (string? "hello scheme") (code:comment #, @t{recognize strings})) +(code:line (string-append "rope" "twine" "yarn") (code:comment #, @t{append strings})) +(code:line (substring "corduroys" 0 4) (code:comment #, @t{extract a substring})) +(code:line (string-length "shoelace") (code:comment #, @t{get a string's length})) +(code:line (string? "c'est ne pas une string") (code:comment #, @t{recognize strings})) (string? 1) (code:line (sqrt 16) (code:comment #, @t{find a square root})) (sqrt -16) @@ -236,10 +235,11 @@ click on an identifier to get full details about its use. (code:line (- 2 1) (code:comment #, @t{subtract numbers})) (code:line (< 2 1) (code:comment #, @t{compare numbers})) (>= 2 1) -(code:line (number? "hello scheme") (code:comment #, @t{recognize numbers})) +(code:line (number? "c'est une number") (code:comment #, @t{recognize numbers})) (number? 1) -(code:line (equal? 1 "hello") (code:comment #, @t{compare anything})) -(equal? 1 1) +(code:line (equal? 6 "half dozen") (code:comment #, @t{compare anything})) +(equal? 6 6) +(equal? "half dozen" "half dozen") ] @;- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - @@ -403,7 +403,7 @@ expression: @def+int[ (define (double v) ((if (string? v) string-append +) v v)) -(double "hello") +(double "mnah") (double 5) ] @@ -581,9 +581,12 @@ each clause, the @nonterm{id} is bound to the result of the @nonterm{expr} for use in the body. @interaction[ -(let ([x 1] - [y 2]) - (format "adding ~s and ~s produces ~s" x y (+ x y))) +(let ([x (random 4)] + [o (random 4)]) + (cond + [(> x o) "X wins"] + [(> o x) "O wins"] + [else "cat's game"])) ] The bindings of a @scheme[let] form are available only in the body of @@ -592,10 +595,13 @@ other. The @scheme[let*] form, in contrast, allows later clauses to use earlier bindings: @interaction[ -(let* ([x 1] - [y 2] - [z (+ x y)]) - (format "adding ~s and ~s produces ~s" x y z)) +(let* ([x (random 4)] + [o (random 4)] + [diff (number->string (abs (- x o)))]) + (cond + [(> x o) (string-append "X wins by " diff)] + [(> o x) (string-append "O wins by " diff)] + [else "cat's game"])) ] @; ---------------------------------------------------------------------- diff --git a/collects/scribblings/guide/welcome.scrbl b/collects/scribblings/guide/welcome.scrbl index ef3b7316ee..e924f9b841 100644 --- a/collects/scribblings/guide/welcome.scrbl +++ b/collects/scribblings/guide/welcome.scrbl @@ -2,7 +2,8 @@ @(require scribble/manual scribble/eval scribble/bnf - "guide-utils.ss") + "guide-utils.ss" + (for-label scheme/enter)) @(define piece-eval (make-base-eval)) @@ -85,16 +86,16 @@ number: A string is also an expression that evaluates to itself. A string is written with double quotes at the start and end of the string: -@interaction["hello world"] +@interaction["Hello, world!"] Scheme uses parentheses to wrap larger expressions---almost any kind of expression, other than simple constants. For example, a function call is written: open parenthesis, function name, argument expression, and closing parenthesis. The following expression calls the built-in function @scheme[substring] with the arguments -@scheme["hello world"], @scheme[0], and @scheme[5]: +@scheme["the boy out of the country"], @scheme[4], and @scheme[7]: -@interaction[(substring "hello world" 0 5)] +@interaction[(substring "the boy out of the country" 4 7)] @; ---------------------------------------------------------------------- @section{Definitions and Interactions} @@ -104,9 +105,10 @@ using the @scheme[define] form, like this: @def+int[ #:eval piece-eval -(define (piece str) - (substring str 0 5)) -(piece "howdy universe") +(define (extract str) + (substring str 4 7)) +(extract "the boy out of the country") +(extract "the country out of the boy") ] Although you can evaluate the @scheme[define] form in the @tech{REPL}, @@ -118,29 +120,29 @@ top text area---called the @deftech{definitions area}---along with the @schememod[ scheme code:blank -(define (piece str) - (substring str 0 5)) +(define (extract str) + (substring str 4 7)) ] -If calling @scheme[(piece "howdy universe")] is part of the main -action of your program, that would go in the @tech{definitions area}, -too. But if it was just an example expression that you were using to -explore @scheme[piece], then you'd more likely leave the -@tech{definitions area} as above, click @onscreen{Run}, and then -evaluate @scheme[(piece "howdy universe")] in the @tech{REPL}. +If calling @scheme[(extract "the boy")] is part of the main action of +your program, that would go in the @tech{definitions area}, too. But +if it was just an example expression that you were using to explore +@scheme[extract], then you'd more likely leave the @tech{definitions +area} as above, click @onscreen{Run}, and then evaluate +@scheme[(extract "the boy")] in the @tech{REPL}. With @exec{mzscheme}, you'd save the above text in a file using your -favorite editor. If you save it as @filepath{piece.ss}, then after starting +favorite editor. If you save it as @filepath{extract.ss}, then after starting @exec{mzscheme} in the same directory, you'd evaluate the following sequence: @interaction[ #:eval piece-eval -(eval:alts (enter! "piece.ss") (void)) -(piece "howdy universe") +(eval:alts (enter! "extract.ss") (void)) +(extract "the gal out of the city") ] -The @scheme[enter!] function both loads the code and switches the +The @scheme[enter!] form both loads the code and switches the evaluation context to the inside of the module, just like DrScheme's @onscreen{Run} button. @@ -152,13 +154,13 @@ If your file (or @tech{definitions area} in DrScheme) contains @schememod[ scheme -(define (piece str) - (substring str 0 5)) +(define (extract str) + (substring str 4 7)) -(piece "howdy universe") +(extract "the cat out of the bag") ] -then it is a complete program that prints ``howdy'' when run. To +then it is a complete program that prints ``cat'' when run. To package this program as an executable, choose one of the following options: @@ -200,16 +202,16 @@ If you already know something about Scheme or Lisp, you might be tempted to put just @schemeblock[ -(define (piece str) - (substring str 0 5)) +(define (extract str) + (substring str 4 7)) ] -into @filepath{piece.scm} and run @exec{mzscheme} with +into @filepath{extract.scm} and run @exec{mzscheme} with @interaction[ #:eval piece-eval -(eval:alts (load "piece.scm") (void)) -(piece "howdy universe") +(eval:alts (load "extract.scm") (void)) +(extract "the dog out") ] That will work, because @exec{mzscheme} is willing to imitate a From cfec8d12de615a92d95729d10eae50f5e0ca5d3b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 22 Apr 2009 07:50:11 +0000 Subject: [PATCH 64/79] Welcome to a new PLT day. svn: r14583 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 38fa49d58e..e01dca0049 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "21apr2009") +#lang scheme/base (provide stamp) (define stamp "22apr2009") From 64b59f2b288871b1482da2c7e583037cce0abc7f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 22 Apr 2009 09:21:54 +0000 Subject: [PATCH 65/79] fix a subtle bug (canvas could be #f) svn: r14584 --- collects/framework/private/frame.ss | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/collects/framework/private/frame.ss b/collects/framework/private/frame.ss index b07f779714..e1db4bb9ab 100644 --- a/collects/framework/private/frame.ss +++ b/collects/framework/private/frame.ss @@ -2096,17 +2096,14 @@ (send (send find-edit get-canvas) focus)))) (define/public (unhide-search-and-toggle-focus) - (cond - [hidden? - (unhide-search #t)] - [(or (not text-to-search) - (send (send text-to-search get-canvas) has-focus?)) - (send find-edit set-position 0 (send find-edit last-position)) - (send find-canvas focus)] - [else - (let ([canvas (send text-to-search get-canvas)]) - (when canvas - (send canvas focus)))])) + (if hidden? + (unhide-search #t) + (let ([canvas (and text-to-search (send text-to-search get-canvas))]) + (cond + [(or (not text-to-search) (and canvas (send canvas has-focus?))) + (send find-edit set-position 0 (send find-edit last-position)) + (send find-canvas focus)] + [canvas (send canvas focus)])))) (define/public (search searching-direction) (unhide-search #f) From 43fe904fe5365496026d6021f9306661695f0981 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 22 Apr 2009 18:30:35 +0000 Subject: [PATCH 66/79] fix typos (incl PRs 10213, 10214) svn: r14585 --- collects/scribblings/framework/color.scrbl | 22 +++++++++++++++------- collects/scribblings/reference/pairs.scrbl | 4 ++-- 2 files changed, 17 insertions(+), 9 deletions(-) diff --git a/collects/scribblings/framework/color.scrbl b/collects/scribblings/framework/color.scrbl index c4b8641b56..50fb40889c 100644 --- a/collects/scribblings/framework/color.scrbl +++ b/collects/scribblings/framework/color.scrbl @@ -8,14 +8,20 @@ This interface describes how coloring is stopped and started for text that knows how to color itself. It also describes how to query the lexical and s-expression structure of the text. - @defmethod*[(((start-colorer (token-sym-style (-> symbol? string?)) (get-token (-> input-port? (values any? symbol? (union false? symbol?) natural-number? natural-number?))) (pairs (listof (list/p symbol? symbol?)))) void))]{ + @defmethod*[(((start-colorer (token-sym->style (-> symbol? string?)) + (get-token (-> input-port? (values any/c + symbol? + (or/c false? symbol?) + exact-nonnegative-integer? + exact-nonnegative-integer?))) + (pairs (listof (list/p symbol? symbol?)))) void))]{ Starts tokenizing the buffer for coloring and parenthesis matching. - @scheme[token-sym-style] will be passed the first return symbol from @scheme[get-token] + The @scheme[token-sym->style] argument will be passed the first return symbol from @scheme[get-token] and should return the style-name that the token should be colored. - get-token takes an input port and returns the next token as 5 values: + The @scheme[get-token] argument takes an input port and returns the next token as 5 values: @itemize[ @item{ An unused value. This value is intended to represent the textual @@ -36,7 +42,7 @@ @item{ The ending position of the token.}] - @scheme[get-token] will usually be implemented with a lexer using the + The @scheme[get-token] function will usually be implemented with a lexer using the @scheme[parser-tools/lex] library. get-token must obey the following invariants: @itemize[ @@ -60,12 +66,12 @@ handle these situations, @scheme[get-token] must treat the first line as a single token.}] - @scheme[pairs] is a list of different kinds of matching parens. The second + The @scheme[pairs] argument is a list of different kinds of matching parens. The second value returned by get-token is compared to this list to see how the paren matcher should treat the token. An example: Suppose pairs is @scheme['((|(| |)|) (|[| |]|) (begin end))]. This means that there are three kinds of parens. Any token which has @scheme['begin] as its second - return value will act as an open for matching tokens with 'end. + return value will act as an open for matching tokens with @scheme['end]. Similarly any token with @scheme['|]|] will act as a closing match for tokens with @scheme['|[|]. When trying to correct a mismatched closing parenthesis, each closing symbol in pairs will be converted to @@ -210,7 +216,9 @@ @defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{ This mixin adds coloring functionality to the mode. - @defconstructor[((get-token lexer default-lexer) (token-sym->style (token $rightarrow$ string) |@scheme[(λ (x) "Standard")])|) (matches (listof (list/c symbol? symbol?)) null))]{ + @defconstructor[((get-token lexer default-lexer) + (token-sym->style (symbol? . -> . string?) (λ (x) "Standard")) + (matches (listof (list/c symbol? symbol?)) null))]{ The arguments are passed to @method[color:text<%> start-colorer]. diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index c06b1bcfad..864b157752 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -146,7 +146,7 @@ must merely start with a chain of at least @scheme[pos] pairs.} @defproc*[([(append [lst list?] ...) list?] [(append [lst list?] ... [v any/c]) any/c])]{ -When given all list arguments, the result is a lists that contains all +When given all list arguments, the result is a list that contains all of the elements of the given lists in order. The last argument is used directly in the tail of the result. @@ -214,7 +214,7 @@ Similar to @scheme[map], except that applied to later elements of the @scheme[lst]s; more specifically, the application of @scheme[proc] to the last elements in the @scheme[lst]s is in tail position with respect to the - @scheme[andmap] call.} + @scheme[ormap] call.} ] From 3f803b2298fbeaadecb2da607edea01bb1826b46 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Wed, 22 Apr 2009 18:32:09 +0000 Subject: [PATCH 67/79] another doc fix (missed part of PR 10214) svn: r14586 --- collects/scribblings/reference/pairs.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index 864b157752..cc60d0af62 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -211,7 +211,7 @@ Similar to @scheme[map], except that @item{the result of the first applciation of @scheme[proc] to produces a value other than @scheme[#f], in which case @scheme[proc] is not - applied to later elements of the @scheme[lst]s; more specifically, + applied to later elements of the @scheme[lst]s; the application of @scheme[proc] to the last elements in the @scheme[lst]s is in tail position with respect to the @scheme[ormap] call.} From 904ab8ee0e78c1b5729afaeb7a528fe1aa0310d7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 23 Apr 2009 07:50:27 +0000 Subject: [PATCH 68/79] Welcome to a new PLT day. svn: r14587 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index e01dca0049..1a6dc87b5f 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "22apr2009") +#lang scheme/base (provide stamp) (define stamp "23apr2009") From 7d881a32bfee271bc894242939a8c095a721bc74 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 23 Apr 2009 14:57:51 +0000 Subject: [PATCH 69/79] svn: r14588 --- collects/redex/private/reduction-semantics.ss | 2 ++ 1 file changed, 2 insertions(+) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index 49610d1d13..7fdb50eb2c 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -1843,6 +1843,8 @@ (values (apply-reduction-relation red arg) #f)) (define (test-->>/procs red arg expected apply-red cycles-ok? srcinfo) + (unless (reduction-relation? red) + (error 'test--> "expected a reduction relation as first argument, got ~e" red)) (let-values ([(got got-cycle?) (apply-red red arg)]) (inc-tests) From 8f4ece0f9fa53a4fb5ade193657512ddf45c9d49 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 23 Apr 2009 16:17:48 +0000 Subject: [PATCH 70/79] typos svn: r14589 --- collects/scribblings/mzc/zo-parse.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/mzc/zo-parse.scrbl b/collects/scribblings/mzc/zo-parse.scrbl index f5b1c2ef81..60e53074a1 100644 --- a/collects/scribblings/mzc/zo-parse.scrbl +++ b/collects/scribblings/mzc/zo-parse.scrbl @@ -14,7 +14,7 @@ @defproc[(zo-parse [in input-port?]) compilation-top?]{ Parses a port (typically the result of opening a @filepath{.zo} file) -containing byte. Beware that the structure types used to represent the +containing bytecode. Beware that the structure types used to represent the bytecode are subject to frequent changes across PLT Scheme versons. The parsed bytecode is returned in a @scheme[compilation-top] @@ -23,7 +23,7 @@ structure will contain a @scheme[mod] structure. For a top-level sequence, it will normally contain a @scheme[seq] or @scheme[splice] structure with a list of top-level declarations and expressions. -The bytecode representation f an expression is closer to an +The bytecode representation of an expression is closer to an S-expression than a traditional, flat control string. For example, an @scheme[if] form is represented by a @scheme[branch] structure that has three fields: a test expression, a ``then'' expression, and an From 35830ba57e7bb5488920f64b941cb2fdef90565d Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 23 Apr 2009 20:41:17 +0000 Subject: [PATCH 71/79] removed duplicate text:ports<%> svn: r14590 --- collects/drscheme/private/rep.ss | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index 96bd20a34b..6a8dd409c9 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -84,8 +84,7 @@ TODO text:ports<%> editor:file<%> scheme:text<%> - color:text<%> - text:ports<%>) + color:text<%>) reset-highlighting highlight-errors highlight-errors/exn From 7924ec7ca2feefbf0965c141512fadec206e0641 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Fri, 24 Apr 2009 05:08:51 +0000 Subject: [PATCH 72/79] add example for matching-identifiers-in svn: r14591 --- collects/scribblings/reference/syntax.scrbl | 20 +++++++++++++++++++- 1 file changed, 19 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 856d6714f8..16b47a92b2 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -976,7 +976,25 @@ sets of imported identifiers. @defform[(matching-identifiers-in regexp require-spec)]{ Like @scheme[require-spec], but including only imports whose names match @scheme[regexp]. The @scheme[regexp] must be a literal regular - expression (see @secref["regexp"]).} + expression (see @secref["regexp"]). + +@defexamples[#:eval (syntax-eval) +(module zoo scheme/base + (provide tunafish swordfish blowfish + monkey lizard ant) + (define tunafish 1) + (define swordfish 2) + (define blowfish 3) + (define monkey 4) + (define lizard 5) + (define ant 6)) +(require scheme/require) +(require (matching-identifiers-in #rx"\\w*fish" 'zoo)) +tunafish +swordfish +blowfish +monkey +]} @defform[(subtract-in require-spec subtracted-spec ...)]{ Like @scheme[require-spec], but omitting those imports that would be From be1478345efc063580d985b06f83f5c8501ffc05 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 24 Apr 2009 07:50:19 +0000 Subject: [PATCH 73/79] Welcome to a new PLT day. svn: r14592 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 1a6dc87b5f..54124f6f93 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "23apr2009") +#lang scheme/base (provide stamp) (define stamp "24apr2009") From cd09b304979146601302ff5f76e63465320bb313 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 24 Apr 2009 14:59:09 +0000 Subject: [PATCH 74/79] (v4.1.5.5) repair interaction of provides redirected by a rename-transformer, certification of access to unexported variables, and protected exports; also get rid of kernel-reprovide special case in export handling, because a more general export-sharing technique subsumed the special case long ago svn: r14593 --- collects/compiler/zo-parse.ss | 7 +- collects/syntax/modresolve.ss | 3 + collects/tests/mzscheme/modprot.ss | 212 +++++++ collects/tests/mzscheme/mz-tests.ss | 1 + src/mzscheme/src/cstartup.inc | 328 +++++------ src/mzscheme/src/env.c | 20 +- src/mzscheme/src/error.c | 2 +- src/mzscheme/src/eval.c | 4 +- src/mzscheme/src/module.c | 877 +++++++++++++++------------- src/mzscheme/src/mzmark.c | 38 +- src/mzscheme/src/mzmarksrc.c | 16 +- src/mzscheme/src/schpriv.h | 15 +- src/mzscheme/src/schvers.h | 4 +- src/mzscheme/src/stxobj.c | 233 +++++--- src/mzscheme/src/stypes.h | 145 ++--- 15 files changed, 1135 insertions(+), 770 deletions(-) create mode 100644 collects/tests/mzscheme/modprot.ss diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index b4d4375997..538e065a4c 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -220,14 +220,14 @@ (match v [`(,name ,self-modidx ,lang-info ,functional? ,et-functional? ,rename ,max-let-depth ,dummy - ,prefix ,kernel-exclusion ,reprovide-kernel? + ,prefix ,indirect-provides ,num-indirect-provides ,indirect-syntax-provides ,num-indirect-syntax-provides ,indirect-et-provides ,num-indirect-et-provides ,protects ,et-protects ,provide-phase-count . ,rest) - (let ([phase-data (take rest (* 8 provide-phase-count))]) - (match (list-tail rest (* 8 provide-phase-count)) + (let ([phase-data (take rest (* 9 provide-phase-count))]) + (match (list-tail rest (* 9 provide-phase-count)) [`(,syntax-body ,body ,requires ,syntax-requires ,template-requires ,label-requires ,more-requires-count . ,more-requires) @@ -729,6 +729,7 @@ [read-accept-dot #t] [read-accept-infix-dot #t] [read-accept-quasiquote #t]) + (printf "~s\n" s) (read (open-input-bytes s))))] [(reference) (make-primval (read-compact-number cp))] diff --git a/collects/syntax/modresolve.ss b/collects/syntax/modresolve.ss index de53caf42b..fe5972a000 100644 --- a/collects/syntax/modresolve.ss +++ b/collects/syntax/modresolve.ss @@ -7,6 +7,9 @@ (cond [(path-string? relto) (if dir? (let-values ([(base n d?) (split-path relto)]) + (when d? + (error 'resolve-module-path-index + "given a directory path instead of a file path: ~e" relto)) (if (eq? base 'relative) (or (current-load-relative-directory) (current-directory)) base)) diff --git a/collects/tests/mzscheme/modprot.ss b/collects/tests/mzscheme/modprot.ss new file mode 100644 index 0000000000..64d03c0386 --- /dev/null +++ b/collects/tests/mzscheme/modprot.ss @@ -0,0 +1,212 @@ +(load-relative "loadtest.ss") + +(Section 'modprot) + +;; ============================================================ + +;; Use '#%kernel everywhere so we're only checking the directly +;; intended certifications and protections. + +(define zero + '(module zero '#%kernel + + (define-values (prot) 8) + + (#%provide (protect prot)))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define one + '(module one '#%kernel + (#%require 'zero + (for-syntax '#%kernel)) + + (define-values (unexp) 5) + (define-syntaxes (stx) + (lambda (stx) (quote-syntax 13))) + + (define-syntaxes (nab) + (lambda (stx) + (datum->syntax + stx + (list (quote-syntax define-syntaxes) + (cdr (syntax-e stx)) + (quote-syntax (make-rename-transformer (quote-syntax unexp))))))) + (define-syntaxes (pnab) + (lambda (stx) + (datum->syntax + stx + (list (quote-syntax define-syntaxes) + (cdr (syntax-e stx)) + (quote-syntax (make-rename-transformer (quote-syntax prot))))))) + (define-syntaxes (snab) + (lambda (xstx) + (datum->syntax + xstx + (list (quote-syntax define-syntaxes) + (cdr (syntax-e xstx)) + (quote-syntax (make-rename-transformer (quote-syntax stx))))))) + + (#%provide nab + pnab + snab))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define two/no-protect + '(module two '#%kernel + (#%require 'one) + + (define-values (normal) 10) + + (nab nabbed) + (pnab pnabbed) + (snab snabbed) + + (#%provide normal + nabbed + pnabbed + snabbed))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define two/protect + '(module two '#%kernel + (#%require 'one) + + (define-values (normal) 10) + + (nab nabbed) + (pnab pnabbed) + (snab snabbed) + + (#%provide (protect normal + nabbed + pnabbed + snabbed)))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define three/nabbed + '(module three '#%kernel + (#%module-begin + (#%require 'two) + (#%app printf "~s ~s\n" + (resolved-module-path-name + (module-path-index-resolve (car (identifier-binding (quote-syntax nabbed))))) + nabbed)))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define three/pnabbed + '(module three '#%kernel + (#%module-begin + (#%require 'two) + (#%app printf "~s ~s\n" + (resolved-module-path-name + (module-path-index-resolve (car (identifier-binding (quote-syntax pnabbed))))) + pnabbed)))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define three/snabbed + '(module three '#%kernel + (#%module-begin + (#%require 'two) + (#%app printf "~s ~s\n" + (resolved-module-path-name + (module-path-index-resolve (car (identifier-binding (quote-syntax snabbed))))) + snabbed)))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define three/normal + '(module three '#%kernel + (#%module-begin + (#%require 'two) + (#%app printf "~s ~s\n" + (resolved-module-path-name + (module-path-index-resolve (car (identifier-binding (quote-syntax normal))))) + normal)))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define (xeval e) + (eval + (if (bytes? e) + (parameterize ([read-accept-compiled #t]) + (read (open-input-bytes e))) + e))) + +(define (mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/normal + get-one-inspector get-three-inspector fail-pnab? fail-prot? fail-three? np-ok?) + (let ([try + (lambda (two three v) + (let ([ns (make-base-namespace)] + [p (open-output-bytes)]) + (parameterize ([current-namespace ns] + [current-output-port p]) + (xeval zero) + (parameterize ([current-code-inspector (get-one-inspector)]) + (xeval one) + (xeval two) + (parameterize ([current-code-inspector (get-three-inspector)]) + (with-handlers ([(lambda (x) fail-three?) + (lambda (exn) + (printf "~a\n" (exn-message exn)))]) + (xeval three)) + (with-handlers ([values (lambda (exn) + (printf "~a\n" (exn-message exn)))]) + (eval '(#%require 'three)))))) + (test #t regexp-match? + (if (byte-regexp? v) v (byte-regexp (string->bytes/utf-8 (format "~a\n" v)))) + (get-output-bytes p))))]) + (try two/no-protect three/nabbed (if (and fail-prot? (not np-ok?)) #rx#"unexported .* unexp" #rx#"one 5")) + (try two/no-protect three/pnabbed (if (and fail-pnab? (not np-ok?)) #rx#"protected .* prot" #rx#"zero 8")) + (try two/no-protect three/snabbed #rx#"one 13") + (try two/no-protect three/normal #rx#"two 10") + (try two/protect three/nabbed (if fail-prot? #rx#"unexported .* unexp" #rx#"one 5")) + (try two/protect three/pnabbed (if fail-pnab? #rx#"protected .* prot" #rx#"zero 8")) + (try two/protect three/snabbed (if (and fail-prot? np-ok?) #rx#"unexported .* stx" #rx#"one 13")) + (try two/protect three/normal (if fail-prot? #rx#"protected .* normal" #rx#"two 10")))) + +;; - - - - - - - - - - - - - - - - - - - - + +(define-values (zero-zo one-zo two/no-protect-zo two/protect-zo + three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/normal-zo) + (apply + values + (let ([ns (make-base-namespace)]) + (parameterize ([current-namespace ns]) + (map (lambda (c) + (let ([c (compile c)] + [p (open-output-bytes)]) + (write c p) + (eval c) + (get-output-bytes p))) + (list zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/normal)))))) + +;; - - - - - - - - - - - - - - - - - - - - + + +(mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/normal + current-code-inspector current-code-inspector #f #f #f #f) + +(mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/normal-zo + current-code-inspector current-code-inspector #f #f #f #f) + +(mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/normal-zo + make-inspector current-code-inspector #t #f #f #f) + +(mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed-zo three/normal + make-inspector current-code-inspector #t #f #t #f) + +(mp-try-all zero-zo one-zo two/no-protect-zo two/protect-zo three/nabbed-zo three/pnabbed-zo three/snabbed-zo three/normal-zo + current-code-inspector make-inspector #t #t #f #f) + +(mp-try-all zero one two/no-protect two/protect three/nabbed three/pnabbed three/snabbed three/normal + current-code-inspector make-inspector #t #t #t #t) + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(report-errs) diff --git a/collects/tests/mzscheme/mz-tests.ss b/collects/tests/mzscheme/mz-tests.ss index dfc0d5921f..07e8f7adc7 100644 --- a/collects/tests/mzscheme/mz-tests.ss +++ b/collects/tests/mzscheme/mz-tests.ss @@ -23,6 +23,7 @@ (load-relative "prompt.ss") (load-relative "will.ss") (load-relative "namespac.ss") +(load-relative "modprot.ss") (unless (or building-flat-tests? in-drscheme?) (load-relative "param.ss")) (load-relative "port.ss") diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index 106a7fda17..695378257d 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -1,10 +1,10 @@ { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,50,0,0,0,1,0,0,3,0,12,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,53,50,0,0,0,1,0,0,3,0,12,0, 17,0,20,0,27,0,40,0,47,0,51,0,58,0,63,0,68,0,72,0,78, 0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0, -177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,87,1,126,1,165, -1,234,1,42,2,130,2,194,2,199,2,219,2,110,3,130,3,181,3,247,3, -132,4,34,5,84,5,107,5,186,5,0,0,132,7,0,0,29,11,11,68,104, +177,0,179,0,193,0,1,1,27,1,35,1,43,1,53,1,89,1,128,1,167, +1,236,1,44,2,132,2,196,2,201,2,221,2,112,3,132,3,183,3,249,3, +134,4,36,5,86,5,109,5,188,5,0,0,135,7,0,0,29,11,11,68,104, 101,114,101,45,115,116,120,64,99,111,110,100,62,111,114,66,108,101,116,114,101, 99,72,112,97,114,97,109,101,116,101,114,105,122,101,66,117,110,108,101,115,115, 63,108,101,116,66,100,101,102,105,110,101,64,119,104,101,110,64,108,101,116,42, @@ -13,100 +13,100 @@ 98,101,103,105,110,63,115,116,120,61,115,70,108,101,116,45,118,97,108,117,101, 115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109, 98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, -45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,98, -10,35,11,8,165,228,94,159,2,15,35,35,159,2,14,35,35,16,20,2,3, -2,1,2,5,2,1,2,6,2,1,2,7,2,1,2,8,2,1,2,9,2, -1,2,10,2,1,2,4,2,1,2,11,2,1,2,12,2,1,97,36,11,8, -165,228,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2,2,2,1,2, -2,97,10,11,11,8,165,228,16,0,97,10,37,11,8,165,228,16,0,13,16, -4,35,29,11,11,2,1,11,18,16,2,99,64,104,101,114,101,8,31,8,30, -8,29,8,28,8,27,93,8,224,44,57,0,0,95,9,8,224,44,57,0,0, -2,1,27,248,22,135,4,23,196,1,249,22,128,4,80,158,38,35,251,22,75, -2,16,248,22,90,23,200,2,12,249,22,65,2,17,248,22,92,23,202,1,27, -248,22,135,4,23,196,1,249,22,128,4,80,158,38,35,251,22,75,2,16,248, -22,90,23,200,2,249,22,65,2,17,248,22,92,23,202,1,12,27,248,22,67, -248,22,135,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35,36,28, -248,22,73,248,22,67,23,195,2,248,22,66,193,249,22,128,4,80,158,38,35, -251,22,75,2,16,248,22,66,23,200,2,249,22,65,2,12,248,22,67,23,202, -1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11, -2,18,3,1,7,101,110,118,57,56,50,51,16,4,11,11,2,19,3,1,7, -101,110,118,57,56,50,52,93,8,224,45,57,0,0,95,9,8,224,45,57,0, -0,2,1,27,248,22,67,248,22,135,4,23,197,1,28,248,22,73,23,194,2, -20,15,159,36,35,36,28,248,22,73,248,22,67,23,195,2,248,22,66,193,249, -22,128,4,80,158,38,35,250,22,75,2,20,248,22,75,249,22,75,248,22,75, -2,21,248,22,66,23,202,2,251,22,75,2,16,2,21,2,21,249,22,65,2, -4,248,22,67,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8,28,8, -27,16,4,11,11,2,18,3,1,7,101,110,118,57,56,50,54,16,4,11,11, -2,19,3,1,7,101,110,118,57,56,50,55,93,8,224,46,57,0,0,95,9, -8,224,46,57,0,0,2,1,248,22,135,4,193,27,248,22,135,4,194,249,22, -65,248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,135,4,23, -197,1,249,22,128,4,80,158,38,35,28,248,22,53,248,22,129,4,248,22,66, -23,198,2,27,249,22,2,32,0,89,162,8,44,36,42,9,222,33,39,248,22, -135,4,248,22,90,23,200,2,250,22,75,2,22,248,22,75,249,22,75,248,22, -75,248,22,66,23,204,2,250,22,76,2,23,249,22,2,22,66,23,204,2,248, -22,92,23,206,2,249,22,65,248,22,66,23,202,1,249,22,2,22,90,23,200, -1,250,22,76,2,20,249,22,2,32,0,89,162,8,44,36,46,9,222,33,40, -248,22,135,4,248,22,66,201,248,22,67,198,27,248,22,135,4,194,249,22,65, -248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,135,4,23,197, -1,249,22,128,4,80,158,38,35,250,22,76,2,22,249,22,2,32,0,89,162, -8,44,36,46,9,222,33,42,248,22,135,4,248,22,66,201,248,22,67,198,27, -248,22,67,248,22,135,4,196,27,248,22,135,4,248,22,66,195,249,22,128,4, -80,158,39,35,28,248,22,73,195,250,22,76,2,20,9,248,22,67,199,250,22, -75,2,8,248,22,75,248,22,66,199,250,22,76,2,11,248,22,67,201,248,22, -67,202,27,248,22,67,248,22,135,4,23,197,1,27,249,22,1,22,79,249,22, -2,22,135,4,248,22,135,4,248,22,66,199,249,22,128,4,80,158,39,35,251, -22,75,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105,111,110, -45,109,97,114,107,2,24,250,22,76,1,23,101,120,116,101,110,100,45,112,97, -114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,99,111,110, -116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,45,102,105, -114,115,116,11,2,24,201,250,22,76,2,20,9,248,22,67,203,27,248,22,67, -248,22,135,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35,36,249, -22,128,4,80,158,38,35,27,248,22,135,4,248,22,66,23,198,2,28,249,22, -164,8,62,61,62,248,22,129,4,248,22,90,23,197,2,250,22,75,2,20,248, -22,75,249,22,75,21,93,2,25,248,22,66,199,250,22,76,2,3,249,22,75, -2,25,249,22,75,248,22,99,203,2,25,248,22,67,202,251,22,75,2,16,28, -249,22,164,8,248,22,129,4,248,22,66,23,201,2,64,101,108,115,101,10,248, -22,66,23,198,2,250,22,76,2,20,9,248,22,67,23,201,1,249,22,65,2, -3,248,22,67,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16,4,11, -11,2,18,3,1,7,101,110,118,57,56,52,57,16,4,11,11,2,19,3,1, -7,101,110,118,57,56,53,48,93,8,224,47,57,0,0,18,16,2,158,94,10, -64,118,111,105,100,8,47,95,9,8,224,47,57,0,0,2,1,27,248,22,67, -248,22,135,4,196,249,22,128,4,80,158,38,35,28,248,22,53,248,22,129,4, -248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,199,248,22,90,198,27, -248,22,129,4,248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,197,250, -22,76,2,23,248,22,67,199,248,22,67,202,159,35,20,103,159,35,16,1,11, -16,0,83,158,41,20,100,143,69,35,37,109,105,110,45,115,116,120,2,1,11, -10,11,10,35,80,158,35,35,20,103,159,35,16,0,16,0,11,11,16,1,2, -2,36,16,0,35,16,0,35,11,11,38,35,11,11,16,10,2,3,2,4,2, -5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,16,10,11,11,11,11, -11,11,11,11,11,11,16,10,2,3,2,4,2,5,2,6,2,7,2,8,2, -9,2,10,2,11,2,12,35,45,36,11,11,16,0,16,0,16,0,35,35,11, -11,11,16,0,16,0,16,0,35,35,16,11,16,5,2,2,20,15,159,35,35, -35,35,20,103,159,35,16,0,16,1,33,32,10,16,5,2,7,89,162,8,44, -36,52,9,223,0,33,33,35,20,103,159,35,16,1,2,2,16,0,11,16,5, -2,10,89,162,8,44,36,52,9,223,0,33,34,35,20,103,159,35,16,1,2, -2,16,0,11,16,5,2,12,89,162,8,44,36,52,9,223,0,33,35,35,20, -103,159,35,16,1,2,2,16,1,33,36,11,16,5,2,4,89,162,8,44,36, -55,9,223,0,33,37,35,20,103,159,35,16,1,2,2,16,1,33,38,11,16, -5,2,8,89,162,8,44,36,57,9,223,0,33,41,35,20,103,159,35,16,1, -2,2,16,0,11,16,5,2,5,89,162,8,44,36,52,9,223,0,33,43,35, -20,103,159,35,16,1,2,2,16,0,11,16,5,2,11,89,162,8,44,36,53, -9,223,0,33,44,35,20,103,159,35,16,1,2,2,16,0,11,16,5,2,6, -89,162,8,44,36,54,9,223,0,33,45,35,20,103,159,35,16,1,2,2,16, -0,11,16,5,2,3,89,162,8,44,36,57,9,223,0,33,46,35,20,103,159, -35,16,1,2,2,16,1,33,48,11,16,5,2,9,89,162,8,44,36,53,9, -223,0,33,49,35,20,103,159,35,16,1,2,2,16,0,11,16,0,94,2,14, -2,15,93,2,14,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 2045); +45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,97, +35,11,8,168,228,95,159,2,15,35,35,159,2,14,35,35,159,2,14,35,35, +16,20,2,3,2,1,2,5,2,1,2,6,2,1,2,7,2,1,2,8,2, +1,2,9,2,1,2,10,2,1,2,4,2,1,2,11,2,1,2,12,2,1, +97,36,11,8,168,228,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2, +2,2,1,2,2,96,11,11,8,168,228,16,0,96,37,11,8,168,228,16,0, +13,16,4,35,29,11,11,2,1,11,18,16,2,99,64,104,101,114,101,8,31, +8,30,8,29,8,28,8,27,93,8,224,47,57,0,0,95,9,8,224,47,57, +0,0,2,1,27,248,22,135,4,23,196,1,249,22,128,4,80,158,38,35,251, +22,75,2,16,248,22,90,23,200,2,12,249,22,65,2,17,248,22,92,23,202, +1,27,248,22,135,4,23,196,1,249,22,128,4,80,158,38,35,251,22,75,2, +16,248,22,90,23,200,2,249,22,65,2,17,248,22,92,23,202,1,12,27,248, +22,67,248,22,135,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35, +36,28,248,22,73,248,22,67,23,195,2,248,22,66,193,249,22,128,4,80,158, +38,35,251,22,75,2,16,248,22,66,23,200,2,249,22,65,2,12,248,22,67, +23,202,1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4, +11,11,2,18,3,1,7,101,110,118,57,56,49,54,16,4,11,11,2,19,3, +1,7,101,110,118,57,56,49,55,93,8,224,48,57,0,0,95,9,8,224,48, +57,0,0,2,1,27,248,22,67,248,22,135,4,23,197,1,28,248,22,73,23, +194,2,20,15,159,36,35,36,28,248,22,73,248,22,67,23,195,2,248,22,66, +193,249,22,128,4,80,158,38,35,250,22,75,2,20,248,22,75,249,22,75,248, +22,75,2,21,248,22,66,23,202,2,251,22,75,2,16,2,21,2,21,249,22, +65,2,4,248,22,67,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8, +28,8,27,16,4,11,11,2,18,3,1,7,101,110,118,57,56,49,57,16,4, +11,11,2,19,3,1,7,101,110,118,57,56,50,48,93,8,224,49,57,0,0, +95,9,8,224,49,57,0,0,2,1,248,22,135,4,193,27,248,22,135,4,194, +249,22,65,248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,135, +4,23,197,1,249,22,128,4,80,158,38,35,28,248,22,53,248,22,129,4,248, +22,66,23,198,2,27,249,22,2,32,0,89,162,8,44,36,42,9,222,33,39, +248,22,135,4,248,22,90,23,200,2,250,22,75,2,22,248,22,75,249,22,75, +248,22,75,248,22,66,23,204,2,250,22,76,2,23,249,22,2,22,66,23,204, +2,248,22,92,23,206,2,249,22,65,248,22,66,23,202,1,249,22,2,22,90, +23,200,1,250,22,76,2,20,249,22,2,32,0,89,162,8,44,36,46,9,222, +33,40,248,22,135,4,248,22,66,201,248,22,67,198,27,248,22,135,4,194,249, +22,65,248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,135,4, +23,197,1,249,22,128,4,80,158,38,35,250,22,76,2,22,249,22,2,32,0, +89,162,8,44,36,46,9,222,33,42,248,22,135,4,248,22,66,201,248,22,67, +198,27,248,22,67,248,22,135,4,196,27,248,22,135,4,248,22,66,195,249,22, +128,4,80,158,39,35,28,248,22,73,195,250,22,76,2,20,9,248,22,67,199, +250,22,75,2,8,248,22,75,248,22,66,199,250,22,76,2,11,248,22,67,201, +248,22,67,202,27,248,22,67,248,22,135,4,23,197,1,27,249,22,1,22,79, +249,22,2,22,135,4,248,22,135,4,248,22,66,199,249,22,128,4,80,158,39, +35,251,22,75,1,22,119,105,116,104,45,99,111,110,116,105,110,117,97,116,105, +111,110,45,109,97,114,107,2,24,250,22,76,1,23,101,120,116,101,110,100,45, +112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,21,95,1,27,99, +111,110,116,105,110,117,97,116,105,111,110,45,109,97,114,107,45,115,101,116,45, +102,105,114,115,116,11,2,24,201,250,22,76,2,20,9,248,22,67,203,27,248, +22,67,248,22,135,4,23,197,1,28,248,22,73,23,194,2,20,15,159,36,35, +36,249,22,128,4,80,158,38,35,27,248,22,135,4,248,22,66,23,198,2,28, +249,22,164,8,62,61,62,248,22,129,4,248,22,90,23,197,2,250,22,75,2, +20,248,22,75,249,22,75,21,93,2,25,248,22,66,199,250,22,76,2,3,249, +22,75,2,25,249,22,75,248,22,99,203,2,25,248,22,67,202,251,22,75,2, +16,28,249,22,164,8,248,22,129,4,248,22,66,23,201,2,64,101,108,115,101, +10,248,22,66,23,198,2,250,22,76,2,20,9,248,22,67,23,201,1,249,22, +65,2,3,248,22,67,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16, +4,11,11,2,18,3,1,7,101,110,118,57,56,52,50,16,4,11,11,2,19, +3,1,7,101,110,118,57,56,52,51,93,8,224,50,57,0,0,18,16,2,158, +94,10,64,118,111,105,100,8,47,95,9,8,224,50,57,0,0,2,1,27,248, +22,67,248,22,135,4,196,249,22,128,4,80,158,38,35,28,248,22,53,248,22, +129,4,248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,199,248,22,90, +198,27,248,22,129,4,248,22,66,197,250,22,75,2,26,248,22,75,248,22,66, +197,250,22,76,2,23,248,22,67,199,248,22,67,202,159,35,20,103,159,35,16, +1,11,16,0,83,158,41,20,100,144,69,35,37,109,105,110,45,115,116,120,2, +1,11,11,11,10,35,80,158,35,35,20,103,159,35,16,0,16,0,16,1,2, +2,36,16,0,35,16,0,35,11,11,38,35,11,11,11,16,10,2,3,2,4, +2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,16,10,11,11,11, +11,11,11,11,11,11,11,16,10,2,3,2,4,2,5,2,6,2,7,2,8, +2,9,2,10,2,11,2,12,35,45,36,11,11,11,16,0,16,0,16,0,35, +35,11,11,11,11,16,0,16,0,16,0,35,35,16,11,16,5,2,2,20,15, +159,35,35,35,35,20,103,159,35,16,0,16,1,33,32,10,16,5,2,7,89, +162,8,44,36,52,9,223,0,33,33,35,20,103,159,35,16,1,2,2,16,0, +11,16,5,2,10,89,162,8,44,36,52,9,223,0,33,34,35,20,103,159,35, +16,1,2,2,16,0,11,16,5,2,12,89,162,8,44,36,52,9,223,0,33, +35,35,20,103,159,35,16,1,2,2,16,1,33,36,11,16,5,2,4,89,162, +8,44,36,55,9,223,0,33,37,35,20,103,159,35,16,1,2,2,16,1,33, +38,11,16,5,2,8,89,162,8,44,36,57,9,223,0,33,41,35,20,103,159, +35,16,1,2,2,16,0,11,16,5,2,5,89,162,8,44,36,52,9,223,0, +33,43,35,20,103,159,35,16,1,2,2,16,0,11,16,5,2,11,89,162,8, +44,36,53,9,223,0,33,44,35,20,103,159,35,16,1,2,2,16,0,11,16, +5,2,6,89,162,8,44,36,54,9,223,0,33,45,35,20,103,159,35,16,1, +2,2,16,0,11,16,5,2,3,89,162,8,44,36,57,9,223,0,33,46,35, +20,103,159,35,16,1,2,2,16,1,33,48,11,16,5,2,9,89,162,8,44, +36,53,9,223,0,33,49,35,20,103,159,35,16,1,2,2,16,0,11,16,0, +94,2,14,2,15,93,2,14,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 2048); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,59,0,0,0,1,0,0,13,0,18,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,53,59,0,0,0,1,0,0,13,0,18,0, 35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226, 0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1, 199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100, 6,114,6,148,6,164,6,14,8,28,8,191,8,194,9,194,10,201,10,208,10, 215,10,90,11,103,11,58,12,160,12,173,12,195,12,147,13,51,14,123,15,131, -15,139,15,165,15,20,16,0,0,8,19,0,0,72,112,97,116,104,45,115,116, +15,139,15,165,15,20,16,0,0,9,19,0,0,72,112,97,116,104,45,115,116, 114,105,110,103,63,64,98,115,98,115,76,110,111,114,109,97,108,45,99,97,115, 101,45,112,97,116,104,74,45,99,104,101,99,107,45,114,101,108,112,97,116,104, 77,45,99,104,101,99,107,45,99,111,108,108,101,99,116,105,111,110,75,99,111, @@ -303,69 +303,69 @@ 175,3,23,202,1,28,192,192,35,249,22,153,5,23,197,1,83,158,39,20,97, 95,89,162,8,44,35,47,9,224,3,2,33,57,23,195,1,23,196,1,27,248, 22,138,5,23,195,1,248,80,159,38,53,36,193,159,35,20,103,159,35,16,1, -11,16,0,83,158,41,20,100,143,67,35,37,117,116,105,108,115,29,11,11,11, -11,10,10,42,80,158,35,35,20,103,159,37,16,17,2,1,2,2,2,3,2, +11,16,0,83,158,41,20,100,144,67,35,37,117,116,105,108,115,29,11,11,11, +11,11,10,42,80,158,35,35,20,103,159,37,16,17,2,1,2,2,2,3,2, 4,2,5,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14, 2,15,30,2,17,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105, 111,110,45,107,101,121,4,30,2,17,1,23,101,120,116,101,110,100,45,112,97, -114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,16,0,11,11,16,0, -35,16,0,35,16,4,2,5,2,4,2,2,2,8,39,11,11,38,35,11,11, -16,11,2,7,2,6,2,15,2,14,2,12,2,11,2,3,2,10,2,13,2, -9,2,1,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,7,2, -6,2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9,2,1,46,46, -36,11,11,16,0,16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35, -35,16,0,16,17,83,158,35,16,2,89,162,43,36,48,2,18,223,0,33,28, -80,159,35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,18,223,0,33, -29,80,159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,1,222, -33,30,80,159,35,35,36,83,158,35,16,2,249,22,161,6,7,92,7,92,80, -159,35,36,36,83,158,35,16,2,89,162,43,36,53,2,3,223,0,33,31,80, -159,35,37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,4,222,33, -32,80,159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2,5, -222,33,34,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2,6, -223,0,33,36,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39,51, -2,7,222,33,39,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43,38, -49,2,8,222,33,40,80,159,35,42,36,83,158,35,16,2,32,0,89,162,43, -37,52,2,9,222,33,41,80,159,35,43,36,83,158,35,16,2,32,0,89,162, -43,37,53,2,10,222,33,42,80,159,35,44,36,83,158,35,16,2,32,0,89, -162,43,36,43,2,11,222,33,43,80,159,35,45,36,83,158,35,16,2,83,158, -38,20,96,96,2,12,89,162,43,35,43,9,223,0,33,44,89,162,43,36,44, -9,223,0,33,45,89,162,43,37,54,9,223,0,33,46,80,159,35,46,36,83, -158,35,16,2,27,248,22,187,13,248,22,170,7,27,28,249,22,164,8,247,22, -178,7,2,20,6,1,1,59,6,1,1,58,250,22,143,7,6,14,14,40,91, -94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8, -44,37,47,2,13,223,0,33,49,80,159,35,47,36,83,158,35,16,2,83,158, -38,20,96,96,2,14,89,162,8,44,38,53,9,223,0,33,54,89,162,43,37, -46,9,223,0,33,55,89,162,43,36,45,9,223,0,33,56,80,159,35,48,36, -83,158,35,16,2,89,162,43,38,51,2,15,223,0,33,58,80,159,35,49,36, -94,29,94,2,16,68,35,37,107,101,114,110,101,108,11,29,94,2,16,69,35, -37,109,105,110,45,115,116,120,11,9,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 5011); +114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,16,0,16,0,35,16, +0,35,16,4,2,5,2,4,2,2,2,8,39,11,11,38,35,11,11,11,16, +11,2,7,2,6,2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9, +2,1,16,11,11,11,11,11,11,11,11,11,11,11,11,16,11,2,7,2,6, +2,15,2,14,2,12,2,11,2,3,2,10,2,13,2,9,2,1,46,46,36, +11,11,11,16,0,16,0,16,0,35,35,11,11,11,11,16,0,16,0,16,0, +35,35,16,0,16,17,83,158,35,16,2,89,162,43,36,48,2,18,223,0,33, +28,80,159,35,53,36,83,158,35,16,2,89,162,8,44,36,55,2,18,223,0, +33,29,80,159,35,52,36,83,158,35,16,2,32,0,89,162,43,36,44,2,1, +222,33,30,80,159,35,35,36,83,158,35,16,2,249,22,161,6,7,92,7,92, +80,159,35,36,36,83,158,35,16,2,89,162,43,36,53,2,3,223,0,33,31, +80,159,35,37,36,83,158,35,16,2,32,0,89,162,8,44,37,49,2,4,222, +33,32,80,159,35,38,36,83,158,35,16,2,32,0,89,162,8,44,38,50,2, +5,222,33,34,80,159,35,39,36,83,158,35,16,2,89,162,8,45,37,47,2, +6,223,0,33,36,80,159,35,40,36,83,158,35,16,2,32,0,89,162,43,39, +51,2,7,222,33,39,80,159,35,41,36,83,158,35,16,2,32,0,89,162,43, +38,49,2,8,222,33,40,80,159,35,42,36,83,158,35,16,2,32,0,89,162, +43,37,52,2,9,222,33,41,80,159,35,43,36,83,158,35,16,2,32,0,89, +162,43,37,53,2,10,222,33,42,80,159,35,44,36,83,158,35,16,2,32,0, +89,162,43,36,43,2,11,222,33,43,80,159,35,45,36,83,158,35,16,2,83, +158,38,20,96,96,2,12,89,162,43,35,43,9,223,0,33,44,89,162,43,36, +44,9,223,0,33,45,89,162,43,37,54,9,223,0,33,46,80,159,35,46,36, +83,158,35,16,2,27,248,22,187,13,248,22,170,7,27,28,249,22,164,8,247, +22,178,7,2,20,6,1,1,59,6,1,1,58,250,22,143,7,6,14,14,40, +91,94,126,97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162, +8,44,37,47,2,13,223,0,33,49,80,159,35,47,36,83,158,35,16,2,83, +158,38,20,96,96,2,14,89,162,8,44,38,53,9,223,0,33,54,89,162,43, +37,46,9,223,0,33,55,89,162,43,36,45,9,223,0,33,56,80,159,35,48, +36,83,158,35,16,2,89,162,43,38,51,2,15,223,0,33,58,80,159,35,49, +36,94,29,94,2,16,68,35,37,107,101,114,110,101,108,11,29,94,2,16,69, +35,37,109,105,110,45,115,116,120,11,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 5012); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,8,0,0,0,1,0,0,6,0,19,0, -34,0,48,0,62,0,76,0,111,0,0,0,1,1,0,0,65,113,117,111,116, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,53,8,0,0,0,1,0,0,6,0,19,0, +34,0,48,0,62,0,76,0,115,0,0,0,6,1,0,0,65,113,117,111,116, 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37, 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122, 11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35, -37,107,101,114,110,101,108,11,98,10,35,11,8,171,230,97,159,2,2,35,35, -159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,16, -0,159,35,20,103,159,35,16,1,11,16,0,83,158,41,20,100,143,69,35,37, -98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11,42,42,42,35,80, -158,35,35,20,103,159,35,16,0,16,0,11,11,16,0,35,16,0,35,16,0, -35,11,11,38,35,11,11,16,0,16,0,16,0,35,35,36,11,11,16,0,16, -0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,0,99, -2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105,103,110,11,2,4, -2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101,11,9,9,9,35, -0}; - EVAL_ONE_SIZED_STR((char *)expr, 294); +37,107,101,114,110,101,108,11,97,35,11,8,174,230,98,159,2,2,35,35,159, +2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,159,2, +6,35,35,16,0,159,35,20,103,159,35,16,1,11,16,0,83,158,41,20,100, +144,69,35,37,98,117,105,108,116,105,110,29,11,11,11,11,11,18,96,11,42, +42,42,35,80,158,35,35,20,103,159,35,16,0,16,0,16,0,35,16,0,35, +16,0,35,11,11,38,35,11,11,11,16,0,16,0,16,0,35,35,36,11,11, +11,16,0,16,0,16,0,35,35,11,11,11,11,16,0,16,0,16,0,35,35, +16,0,16,0,99,2,6,2,5,29,94,2,1,69,35,37,102,111,114,101,105, +103,110,11,2,4,2,3,2,2,29,94,2,1,67,35,37,112,108,97,99,101, +11,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 299); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,52,0,0,0,1,0,0,11,0,38,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,53,52,0,0,0,1,0,0,11,0,38,0, 44,0,57,0,71,0,93,0,119,0,131,0,149,0,169,0,181,0,197,0,220, 0,0,1,5,1,10,1,15,1,24,1,29,1,60,1,64,1,72,1,81,1, 89,1,192,1,237,1,1,2,30,2,61,2,117,2,127,2,174,2,184,2,191, 2,78,4,91,4,110,4,229,4,241,4,137,5,151,5,17,6,23,6,37,6, -64,6,149,6,151,6,217,6,172,12,231,12,9,13,0,0,144,15,0,0,70, +64,6,149,6,151,6,217,6,172,12,231,12,9,13,0,0,145,15,0,0,70, 100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,117,108,116,45,108, 111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,65,113,117,111,116, 101,29,94,2,3,67,35,37,117,116,105,108,115,11,29,94,2,3,68,35,37, @@ -525,8 +525,8 @@ 33,42,89,162,43,38,48,9,223,1,33,43,89,162,43,39,8,30,9,225,2, 3,0,33,49,208,87,95,248,22,152,4,248,80,159,37,49,37,247,22,188,11, 248,22,190,4,80,159,36,36,37,248,22,179,12,80,159,36,41,36,159,35,20, -103,159,35,16,1,11,16,0,83,158,41,20,100,143,66,35,37,98,111,111,116, -29,11,11,11,11,10,10,36,80,158,35,35,20,103,159,39,16,19,2,1,2, +103,159,35,16,1,11,16,0,83,158,41,20,100,144,66,35,37,98,111,111,116, +29,11,11,11,11,11,10,36,80,158,35,35,20,103,159,39,16,19,2,1,2, 2,30,2,4,72,112,97,116,104,45,115,116,114,105,110,103,63,10,30,2,4, 75,112,97,116,104,45,97,100,100,45,115,117,102,102,105,120,7,30,2,5,1, 20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,45,107,101,121, @@ -535,26 +535,26 @@ 2,12,2,13,2,14,30,2,4,69,45,102,105,110,100,45,99,111,108,0,30, 2,4,76,110,111,114,109,97,108,45,99,97,115,101,45,112,97,116,104,6,30, 2,4,79,112,97,116,104,45,114,101,112,108,97,99,101,45,115,117,102,102,105, -120,9,2,15,16,0,11,11,16,0,35,16,0,35,16,11,2,9,2,10,2, -7,2,8,2,11,2,12,2,2,2,6,2,1,2,14,2,13,46,11,11,38, -35,11,11,16,1,2,15,16,1,11,16,1,2,15,36,36,36,11,11,16,0, -16,0,16,0,35,35,11,11,11,16,0,16,0,16,0,35,35,16,0,16,16, -83,158,35,16,2,89,162,43,36,44,9,223,0,33,23,80,159,35,57,36,83, -158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,159,35,56,36,83,158, -35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,223,0,33,25,80, -159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,105,116,104,45,100, -105,114,223,0,33,26,80,159,35,54,36,83,158,35,16,2,248,22,178,7,69, -115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,35,16,2,89,162, -43,37,59,2,2,223,0,33,35,80,159,35,36,36,83,158,35,16,2,32,0, -89,162,8,44,36,41,2,6,222,192,80,159,35,41,36,83,158,35,16,2,247, -22,126,80,159,35,42,36,83,158,35,16,2,247,22,125,80,159,35,43,36,83, -158,35,16,2,247,22,61,80,159,35,44,36,83,158,35,16,2,248,22,18,74, -109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,35,45,36,83,158, -35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,35,47,83,158,35, -16,2,32,0,89,162,43,37,44,2,13,222,33,41,80,159,35,48,36,83,158, -35,16,2,89,162,8,44,36,44,2,14,223,0,33,50,80,159,35,49,36,83, -158,35,16,2,89,162,43,35,43,2,15,223,0,33,51,80,159,35,53,36,95, -29,94,2,3,68,35,37,107,101,114,110,101,108,11,29,94,2,3,69,35,37, -109,105,110,45,115,116,120,11,2,4,9,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 4109); +120,9,2,15,16,0,16,0,35,16,0,35,16,11,2,9,2,10,2,7,2, +8,2,11,2,12,2,2,2,6,2,1,2,14,2,13,46,11,11,38,35,11, +11,11,16,1,2,15,16,1,11,16,1,2,15,36,36,36,11,11,11,16,0, +16,0,16,0,35,35,11,11,11,11,16,0,16,0,16,0,35,35,16,0,16, +16,83,158,35,16,2,89,162,43,36,44,9,223,0,33,23,80,159,35,57,36, +83,158,35,16,2,89,162,43,36,44,9,223,0,33,24,80,159,35,56,36,83, +158,35,16,2,89,162,43,36,48,67,103,101,116,45,100,105,114,223,0,33,25, +80,159,35,55,36,83,158,35,16,2,89,162,43,37,48,68,119,105,116,104,45, +100,105,114,223,0,33,26,80,159,35,54,36,83,158,35,16,2,248,22,178,7, +69,115,111,45,115,117,102,102,105,120,80,159,35,35,36,83,158,35,16,2,89, +162,43,37,59,2,2,223,0,33,35,80,159,35,36,36,83,158,35,16,2,32, +0,89,162,8,44,36,41,2,6,222,192,80,159,35,41,36,83,158,35,16,2, +247,22,126,80,159,35,42,36,83,158,35,16,2,247,22,125,80,159,35,43,36, +83,158,35,16,2,247,22,61,80,159,35,44,36,83,158,35,16,2,248,22,18, +74,109,111,100,117,108,101,45,108,111,97,100,105,110,103,80,159,35,45,36,83, +158,35,16,2,11,80,158,35,46,83,158,35,16,2,11,80,158,35,47,83,158, +35,16,2,32,0,89,162,43,37,44,2,13,222,33,41,80,159,35,48,36,83, +158,35,16,2,89,162,8,44,36,44,2,14,223,0,33,50,80,159,35,49,36, +83,158,35,16,2,89,162,43,35,43,2,15,223,0,33,51,80,159,35,53,36, +95,29,94,2,3,68,35,37,107,101,114,110,101,108,11,29,94,2,3,69,35, +37,109,105,110,45,115,116,120,11,2,4,9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 4110); } diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index fae5f8556b..d9dd2994b8 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -1180,6 +1180,7 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo) env->mod_phase, NULL, NULL, + NULL, 0); } } @@ -2004,7 +2005,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode < 2)) { Scheme_Object *mod, *nm = id; mod = scheme_stx_module_name(NULL, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL, - NULL, NULL, NULL, NULL); + NULL, NULL, NULL, NULL, NULL); if (mod /* must refer to env->module, otherwise there would have been an error before getting here */ && NOT_SAME_OBJ(nm, sym)) @@ -2527,7 +2528,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, int j = 0, p = 0, modpos, skip_stops = 0, module_self_reference = 0; Scheme_Bucket *b; Scheme_Object *val, *modidx, *modname, *src_find_id, *find_global_id, *mod_defn_phase; - Scheme_Object *find_id_sym = NULL; + Scheme_Object *find_id_sym = NULL, *rename_insp = NULL; Scheme_Env *genv; long phase; @@ -2680,7 +2681,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, src_find_id = find_id; modidx = scheme_stx_module_name(NULL, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, - NULL, NULL, NULL, NULL); + NULL, NULL, NULL, NULL, &rename_insp); /* Used out of context? */ if (SAME_OBJ(modidx, scheme_undefined)) { @@ -2765,9 +2766,10 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, val = scheme_module_syntax(modname, env->genv, find_id); if (val && !(flags & SCHEME_NO_CERT_CHECKS)) scheme_check_accessible_in_module(genv, env->insp, in_modidx, - find_id, src_find_id, certs, NULL, -2, 0, - NULL, - env->genv); + find_id, src_find_id, certs, NULL, rename_insp, + -2, 0, + NULL, NULL, + env->genv, NULL); } else { /* Only try syntax table if there's not an explicit (later) variable mapping: */ @@ -2790,8 +2792,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, pos = 0; else pos = scheme_check_accessible_in_module(genv, env->insp, in_modidx, - find_id, src_find_id, certs, NULL, -1, 1, - _protected, env->genv); + find_id, src_find_id, certs, NULL, rename_insp, -1, 1, + _protected, NULL, env->genv, NULL); modpos = SCHEME_INT_VAL(pos); } else modpos = -1; @@ -2958,7 +2960,7 @@ int scheme_check_context(Scheme_Env *env, Scheme_Object *name, Scheme_Object *ok return 1; } else { mod = scheme_stx_module_name(NULL, &id, scheme_make_integer(env->phase), NULL, NULL, NULL, - NULL, NULL, NULL, NULL); + NULL, NULL, NULL, NULL, NULL); if (SAME_OBJ(mod, scheme_undefined)) return 1; } diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 5d8df60285..ce5b889df5 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -1610,7 +1610,7 @@ static void do_wrong_syntax(const char *where, phase = scheme_current_thread->current_local_env->genv->phase; else phase = 0; scheme_stx_module_name(0, &first, scheme_make_integer(phase), &mod, &nomwho, - NULL, NULL, NULL, NULL, NULL); + NULL, NULL, NULL, NULL, NULL, NULL); } } } else { diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 5febd2e7ac..3552cff5e0 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -1788,7 +1788,7 @@ static Scheme_Object *link_module_variable(Scheme_Object *modidx, if (check_access && !SAME_OBJ(menv, env)) { varname = scheme_check_accessible_in_module(menv, insp, NULL, varname, NULL, NULL, - insp, pos, 0, NULL, env); + insp, NULL, pos, 0, NULL, NULL, env, NULL); } } @@ -6091,7 +6091,7 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co /* Since the module has a rename for this id, it's certainly defined. */ } else { modidx = scheme_stx_module_name(NULL, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, - NULL, NULL, NULL, NULL); + NULL, NULL, NULL, NULL, NULL); if (modidx) { /* If it's an access path, resolve it: */ if (env->genv->module diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 6ffc0eda7b..b0c90a7843 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -217,7 +217,7 @@ typedef void (*Check_Func)(Scheme_Object *prnt_name, Scheme_Object *name, int isval, void *data, Scheme_Object *e, Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *to_phase, Scheme_Object *src_phase_index, - Scheme_Object *nominal_export_phase); + Scheme_Object *nominal_export_phase, Scheme_Object *in_insp); static void parse_requires(Scheme_Object *form, Scheme_Object *base_modidx, Scheme_Env *env, @@ -245,13 +245,11 @@ static int compute_reprovides(Scheme_Hash_Table *all_provided, Scheme_Env *genv, Scheme_Object *all_rt_defs, Scheme_Object *all_rt_defs_out, Scheme_Object *all_et_defs, Scheme_Object *all_et_defs_out, - Scheme_Object **_exclude_hint, const char *matching_form, Scheme_Object *all_mods, Scheme_Object *all_phases); static char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, Scheme_Module_Exports *me, Scheme_Env *genv, - int reprovide_kernel, Scheme_Object *form, char **_phase1_protects); static Scheme_Object **compute_indirects(Scheme_Env *genv, @@ -268,7 +266,7 @@ static Scheme_Object *do_namespace_require(Scheme_Env *env, int argc, Scheme_Obj static Scheme_Object *default_module_resolver(int argc, Scheme_Object **argv); static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, char *exets, - Scheme_Object **exsnoms, + Scheme_Object **exsnoms, Scheme_Object **exinsps, int start, int count, int do_uninterned); #define MODCHAIN_TABLE(p) ((Scheme_Hash_Table *)(SCHEME_VEC_ELS(p)[0])) @@ -479,7 +477,7 @@ void scheme_finish_kernel(Scheme_Env *env) rn = scheme_make_module_rename(scheme_make_integer(0), mzMOD_RENAME_NORMAL, NULL); for (i = kernel->me->rt->num_provides; i--; ) { scheme_extend_module_rename(rn, kernel_modidx, exs[i], exs[i], kernel_modidx, exs[i], - 0, scheme_make_integer(0), NULL, 0); + 0, scheme_make_integer(0), NULL, NULL, 0); } scheme_seal_module_rename(rn, STX_SEAL_ALL); @@ -613,8 +611,13 @@ Scheme_Object *scheme_sys_wraps_phase(Scheme_Object *phase) rn = scheme_make_module_rename(phase, mzMOD_RENAME_NORMAL, NULL); /* Add a module mapping for all kernel provides: */ - scheme_extend_module_rename_with_kernel(rn, kernel_modidx); - + scheme_extend_module_rename_with_shared(rn, kernel_modidx, + kernel->me->rt, + scheme_make_integer(p), + scheme_make_integer(0), + scheme_null, + 1); + scheme_seal_module_rename(rn, STX_SEAL_ALL); w = scheme_datum_to_syntax(kernel_symbol, scheme_false, scheme_false, 0, 0); @@ -863,8 +866,6 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], srcname = name; srcmname = modname; } else { - try_again: - /* Before starting, check whether the name is provided */ count = srcm->me->rt->num_provides; if (position >= 0) { @@ -930,12 +931,6 @@ static Scheme_Object *_dynamic_require(int argc, Scheme_Object *argv[], srcname = srcm->me->rt->provide_src_names[i]; } - if ((position < 0) && (i == count) && srcm->me->rt->reprovide_kernel) { - /* Check kernel. */ - srcm = kernel; - goto try_again; - } - if (i == count) { if (indirect_ok) { /* Try indirect provides: */ @@ -2180,13 +2175,13 @@ static int do_add_simple_require_renames(Scheme_Object *rn, int can_override) { int i, saw_mb, numvals; - Scheme_Object **exs, **exss, **exsns, *midx, *info, *vec, *nml, *mark_src; + Scheme_Object **exs, **exss, **exsns, *midx, *info, *vec, *nml, *mark_src, **exinsps; char *exets; int with_shared = 1; saw_mb = 0; - if (!pt->num_provides && !pt->reprovide_kernel) + if (!pt->num_provides) return 0; if (with_shared) { @@ -2205,6 +2200,7 @@ static int do_add_simple_require_renames(Scheme_Object *rn, exsns = pt->provide_src_names; exss = pt->provide_srcs; exets = pt->provide_src_phases; + exinsps = pt->provide_insps; numvals = pt->num_var_provides; for (i = pt->num_provides; i--; ) { if (exss && !SCHEME_FALSEP(exss[i])) @@ -2213,13 +2209,14 @@ static int do_add_simple_require_renames(Scheme_Object *rn, midx = idx; if (!with_shared) { scheme_extend_module_rename(rn, midx, exs[i], exsns[i], idx, exs[i], - exets ? exets[i] : 0, src_phase_index, pt->phase_index, 1); + exets ? exets[i] : 0, src_phase_index, pt->phase_index, + exinsps ? exinsps[i] : NULL, 1); } if (SAME_OBJ(exs[i], module_begin_symbol)) saw_mb = 1; if (required) { - vec = scheme_make_vector(9, NULL); + vec = scheme_make_vector(10, NULL); nml = scheme_make_pair(idx, scheme_null); SCHEME_VEC_ELS(vec)[0] = nml; SCHEME_VEC_ELS(vec)[1] = midx; @@ -2229,38 +2226,11 @@ static int do_add_simple_require_renames(Scheme_Object *rn, SCHEME_VEC_ELS(vec)[5] = orig_src; SCHEME_VEC_ELS(vec)[6] = mark_src; SCHEME_VEC_ELS(vec)[7] = (can_override ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : 0; + SCHEME_VEC_ELS(vec)[8] = exets ? scheme_make_integer(exets[i]) : scheme_false; + SCHEME_VEC_ELS(vec)[9] = exets ? exinsps[i] : scheme_false; scheme_hash_set(required, exs[i], vec); } } - - if (pt->reprovide_kernel) { - if (!with_shared) { - scheme_extend_module_rename_with_kernel(rn, idx); - } - saw_mb = 1; - - if (required) { - exs = kernel->me->rt->provides; - numvals = kernel->me->rt->num_var_provides; - for (i = kernel->me->rt->num_provides; i--; ) { - if (!SAME_OBJ(pt->kernel_exclusion, exs[i])) { - vec = scheme_make_vector(9, NULL); - nml = scheme_make_pair(idx, scheme_null); - SCHEME_VEC_ELS(vec)[0] = nml; - SCHEME_VEC_ELS(vec)[1] = kernel_modidx; - SCHEME_VEC_ELS(vec)[2] = exs[i]; - SCHEME_VEC_ELS(vec)[3] = ((i < numvals) ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[4] = exs[i]; - SCHEME_VEC_ELS(vec)[5] = orig_src; - SCHEME_VEC_ELS(vec)[6] = mark_src; - SCHEME_VEC_ELS(vec)[7] = (can_override ? scheme_true : scheme_false); - SCHEME_VEC_ELS(vec)[8] = scheme_make_integer(0); - scheme_hash_set(required, exs[i], vec); - } - } - } - } if (!with_shared) { info = cons(idx, cons(marshal_phase_index, @@ -2391,19 +2361,19 @@ void scheme_prep_namespace_rename(Scheme_Env *menv) if (SCHEME_FALSEP(m->me->rt->provide_srcs[i])) { name = m->me->rt->provides[i]; scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, - scheme_make_integer(0), NULL, 0); + scheme_make_integer(0), NULL, NULL, 0); } } /* Local, not provided: */ for (i = 0; i < m->num_indirect_provides; i++) { name = m->indirect_provides[i]; scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, - scheme_make_integer(0), NULL, 0); + scheme_make_integer(0), NULL, NULL, 0); } for (i = 0; i < m->num_indirect_syntax_provides; i++) { name = m->indirect_syntax_provides[i]; scheme_extend_module_rename(one_rn, m->self_modidx, name, name, m->self_modidx, name, 0, - scheme_make_integer(0), NULL, 0); + scheme_make_integer(0), NULL, NULL, 0); } one_rn = scheme_get_module_rename_from_set(rns, scheme_make_integer(1), 1); @@ -3236,9 +3206,10 @@ Scheme_Env *scheme_module_access(Scheme_Object *name, Scheme_Env *env, int rev_m } static void check_certified(Scheme_Object *stx, Scheme_Object *certs, - Scheme_Object *insp, Scheme_Object *in_modidx, + Scheme_Object *prot_insp, Scheme_Object *insp, + Scheme_Object *rename_insp, Scheme_Object *in_modidx, Scheme_Env *env, Scheme_Object *symbol, - int var, int prot) + int var, int prot, int *_would_complain) { int need_cert = 1; Scheme_Object *midx; @@ -3250,8 +3221,20 @@ static void check_certified(Scheme_Object *stx, Scheme_Object *certs, if (need_cert && insp) need_cert = scheme_module_protected_wrt(env->insp, insp); + if (need_cert && rename_insp) { + if (SCHEME_PAIRP(rename_insp)) { + /* First inspector of pair protects second */ + if (!prot_insp + || scheme_module_protected_wrt(SCHEME_CAR(rename_insp), prot_insp)) { + rename_insp = NULL; + } else + rename_insp = SCHEME_CDR(rename_insp); + } + if (rename_insp) + need_cert = scheme_module_protected_wrt(env->insp, rename_insp); + } - if (need_cert && in_modidx) { + if (need_cert && in_modidx && midx) { /* If we're currently executing a macro expander in this module, then allow the access under any cirsumstances. This is mostly useful for syntax-local-value and local-expand. */ @@ -3262,24 +3245,30 @@ static void check_certified(Scheme_Object *stx, Scheme_Object *certs, } if (need_cert) { - /* For error, if stx is no more specific than symbol, drop symbol. */ - if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) { - symbol = stx; - stx = NULL; + if (_would_complain) { + *_would_complain = 1; + } else { + /* For error, if stx is no more specific than symbol, drop symbol. */ + if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) { + symbol = stx; + stx = NULL; + } + scheme_wrong_syntax("compile", stx, symbol, + "access from an uncertified context to %s %s from module: %D", + prot ? "protected" : "unexported", + var ? "variable" : "syntax", + env->module->modname); } - scheme_wrong_syntax("compile", stx, symbol, - "access from an uncertified context to %s %s from module: %D", - prot ? "protected" : "unexported", - var ? "variable" : "syntax", - env->module->modname); } } Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *prot_insp, Scheme_Object *in_modidx, Scheme_Object *symbol, Scheme_Object *stx, - Scheme_Object *certs, Scheme_Object *unexp_insp, - int position, int want_pos, int *_protected, - Scheme_Env *from_env) + Scheme_Object *certs, Scheme_Object *unexp_insp, + Scheme_Object *rename_insp, + int position, int want_pos, + int *_protected, int *_unexported, + Scheme_Env *from_env, int *_would_complain) /* Returns the actual name when !want_pos, needed in case of uninterned names. Otherwise, returns a position value on success. If position < -1, then merely checks for protected syntax. @@ -3288,8 +3277,11 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object certifictions in stx+certs, access implied by {prot_,unexp_}insp, or access implied by in_modidx. For unexported access, either stx+certs or unexp_insp must be - supplied (not both). For unprotected access, both prot_insp - and stx+certs should be supplied. */ + supplied (not both), and prot_insp should be supplied + (for protected re-exports of unexported). + For unprotected access, both prot_insp and stx+certs + should be supplied. In either case, rename_insp + is optionally allowed. */ { Scheme_Module_Phase_Exports *pt; @@ -3375,12 +3367,12 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object && provide_protects[position]) { if (_protected) *_protected = 1; - check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1); + check_certified(stx, certs, prot_insp, prot_insp, rename_insp, in_modidx, env, symbol, 1, 1, _would_complain); } } if (need_cert) - check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0); + check_certified(stx, certs, prot_insp, unexp_insp, rename_insp, in_modidx, env, symbol, 1, 0, _would_complain); if (want_pos) return scheme_make_integer(position); @@ -3426,7 +3418,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object && provide_protects[SCHEME_INT_VAL(pos)]) { if (_protected) *_protected = 1; - check_certified(stx, certs, prot_insp, in_modidx, env, symbol, 1, 1); + check_certified(stx, certs, prot_insp, prot_insp, rename_insp, in_modidx, env, symbol, 1, 1, _would_complain); } if ((position >= -1) @@ -3434,7 +3426,9 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object /* unexported var -- need cert */ if (_protected) *_protected = 1; - check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 1, 0); + if (_unexported) + *_unexported = 1; + check_certified(stx, certs, prot_insp, unexp_insp, rename_insp, in_modidx, env, symbol, 1, 0, _would_complain); } if (want_pos) @@ -3445,12 +3439,19 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object if (position < -1) { /* unexported syntax -- need cert */ - check_certified(stx, certs, unexp_insp, in_modidx, env, symbol, 0, 0); + if (_unexported) + *_unexported = 1; + check_certified(stx, certs, prot_insp, unexp_insp, rename_insp, in_modidx, env, symbol, 0, 0, _would_complain); return NULL; } } } + if (_would_complain) { + *_would_complain = 1; + return NULL; + } + /* For error, if stx is no more specific than symbol, drop symbol. */ if (stx && SAME_OBJ(SCHEME_STX_SYM(stx), symbol)) { symbol = stx; @@ -4329,7 +4330,7 @@ void scheme_finish_primitive_module(Scheme_Env *env) m->me->rt->num_provides = count; m->me->rt->num_var_provides = count; - qsort_provides(exs, NULL, NULL, NULL, NULL, NULL, 0, count, 1); + qsort_provides(exs, NULL, NULL, NULL, NULL, NULL, NULL, 0, count, 1); env->running = 1; } @@ -4631,13 +4632,39 @@ static void eval_exptime(Scheme_Object *names, int count, /* module */ /**********************************************************************/ +static Scheme_Object **declare_insps(int n, Scheme_Object **insps, Scheme_Object *insp) +{ + int i; + Scheme_Object **naya, *v; + + for (i = 0; i < n; i++) { + if (insps[i] && SCHEME_PAIRP(insps[i])) + break; + } + if (i >= n) + return insps; + + insp = scheme_make_inspector(insp); + + naya = MALLOC_N(Scheme_Object*, n); + for (i = 0; i < n; i++) { + v = insps[i]; + if (v && SCHEME_PAIRP(v)) { + v = cons(insp, SCHEME_CDR(v)); + } + naya[i] = v; + } + + return naya; +} + static Scheme_Object * module_execute(Scheme_Object *data) { Scheme_Module *m; Scheme_Env *env; Scheme_Env *old_menv; - Scheme_Object *prefix, *insp; + Scheme_Object *prefix, *insp, **rt_insps, **et_insps; m = MALLOC_ONE_TAGGED(Scheme_Module); memcpy(m, data, sizeof(Scheme_Module)); @@ -4682,6 +4709,40 @@ module_execute(Scheme_Object *data) } } + if (m->me->rt->provide_insps) + rt_insps = declare_insps(m->me->rt->num_provides, m->me->rt->provide_insps, insp); + else + rt_insps = NULL; + if (m->me->et->provide_insps) + et_insps = declare_insps(m->me->et->num_provides, m->me->et->provide_insps, insp); + else + et_insps = NULL; + + if (!SAME_OBJ(rt_insps, m->me->rt->provide_insps) + || !SAME_OBJ(et_insps, m->me->et->provide_insps)) { + /* have to clone m->me, etc. */ + Scheme_Module_Exports *naya_me; + Scheme_Module_Phase_Exports *pt; + + naya_me = MALLOC_ONE_TAGGED(Scheme_Module_Exports); + memcpy(naya_me, m->me, sizeof(Scheme_Module_Exports)); + m->me = naya_me; + + if (!SAME_OBJ(rt_insps, m->me->rt->provide_insps)) { + pt = MALLOC_ONE_TAGGED(Scheme_Module_Phase_Exports); + memcpy(pt, m->me->rt, sizeof(Scheme_Module_Phase_Exports)); + m->me->rt = pt; + pt->provide_insps = rt_insps; + } + + if (!SAME_OBJ(rt_insps, m->me->et->provide_insps)) { + pt = MALLOC_ONE_TAGGED(Scheme_Module_Phase_Exports); + memcpy(pt, m->me->et, sizeof(Scheme_Module_Phase_Exports)); + m->me->et = pt; + pt->provide_insps = et_insps; + } + } + m->insp = insp; scheme_hash_set(env->module_registry, m->modname, (Scheme_Object *)m); scheme_hash_set(env->export_registry, m->modname, (Scheme_Object *)m->me); @@ -5313,12 +5374,7 @@ static Scheme_Object *do_module(Scheme_Object *form, Scheme_Comp_Env *env, scheme_prepare_exp_env(menv); /* For each provide in iim, add a module rename to fm */ - if (SAME_OBJ(iim, kernel)) { - scheme_extend_module_rename_with_kernel(rn, kernel_modidx); - saw_mb = 1; - } else { - saw_mb = add_simple_require_renames(NULL, rn_set, NULL, iim, iidx, scheme_make_integer(0), NULL, 1); - } + saw_mb = add_simple_require_renames(NULL, rn_set, NULL, iim, iidx, scheme_make_integer(0), NULL, 1); if (rec[drec].comp) benv = scheme_new_comp_env(menv, env->insp, SCHEME_MODULE_FRAME); @@ -5523,7 +5579,7 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, int isval, void *tables, Scheme_Object *e, Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *phase, Scheme_Object *src_phase_index, - Scheme_Object *nominal_export_phase) + Scheme_Object *nominal_export_phase, Scheme_Object *in_insp) { Scheme_Bucket_Table *toplevel, *syntax; Scheme_Hash_Table *required; @@ -5611,7 +5667,7 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, } /* Remember require: */ - vec = scheme_make_vector(9, NULL); + vec = scheme_make_vector(10, NULL); nml = scheme_make_pair(nominal_modidx, scheme_null); SCHEME_VEC_ELS(vec)[0] = nml; SCHEME_VEC_ELS(vec)[1] = modidx; @@ -5622,6 +5678,7 @@ static void check_require_name(Scheme_Object *prnt_name, Scheme_Object *name, SCHEME_VEC_ELS(vec)[6] = (mark_src ? mark_src : scheme_false); SCHEME_VEC_ELS(vec)[7] = scheme_false; SCHEME_VEC_ELS(vec)[8] = scheme_make_integer(exet); + SCHEME_VEC_ELS(vec)[9] = in_insp; scheme_hash_set(required, name, vec); } @@ -5690,7 +5747,7 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id, scheme_add_global_symbol(name, scheme_undefined, env->genv); /* Add a renaming: */ - scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); + scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, NULL, 0); id = scheme_add_rename(*_id, rn); *_id = id; @@ -5803,7 +5860,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Object *post_ex_rn, *post_ex_et_rn; /* renames for ids introduced by expansion */ Scheme_Object *post_ex_rn_set; /* phase -> post_ex_rn-like rename */ Scheme_Hash_Table *tables; /* phase -> (vector toplevels requires syntaxes) */ - Scheme_Object *exclude_hint = scheme_false, *lift_data; + Scheme_Object *lift_data; Scheme_Object **exis, **et_exis, **exsis; Scheme_Object *lift_ctx; Scheme_Object *lifted_reqs = scheme_null, *req_data; @@ -5811,7 +5868,6 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, char *exps, *et_exps; int *all_simple_renames; int maybe_has_lifts = 0; - int reprovide_kernel; Scheme_Object *redef_modname; Scheme_Object *observer; @@ -6098,10 +6154,10 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, /* Add a renaming: */ if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { - scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); + scheme_extend_module_rename(post_ex_rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, NULL, 0); *all_simple_renames = 0; } else - scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, 0); + scheme_extend_module_rename(rn, self_modidx, name, name, self_modidx, name, 0, NULL, NULL, NULL, 0); vars = SCHEME_STX_CDR(vars); } @@ -6183,12 +6239,12 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, if (!SAME_OBJ(SCHEME_STX_VAL(orig_name), name)) { scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name, - for_stx ? 1 : 0, NULL, NULL, 0); + for_stx ? 1 : 0, NULL, NULL, NULL, 0); *all_simple_renames = 0; use_post_ex = 1; } else scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name, - for_stx ? 1 : 0, NULL, NULL, 0); + for_stx ? 1 : 0, NULL, NULL, NULL, 0); count++; } @@ -6493,60 +6549,19 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_ALL); /* Compute provides for re-provides and all-defs-out: */ - reprovide_kernel = compute_reprovides(all_provided, - all_reprovided, - env->genv->module, - tables, - env->genv, - all_defs, all_defs_out, - all_et_defs, all_et_defs_out, - &exclude_hint, - "require", NULL, NULL); - - /* Ad hoc optimization: some early modules are everything from kernel except - #%module_begin */ - if ((reprovide_kernel == (kernel->me->rt->num_provides - 1)) - && SCHEME_FALSEP(exclude_hint)) { - exclude_hint = scheme_make_pair(module_begin_symbol, scheme_null); - exclude_hint = scheme_datum_to_syntax(exclude_hint, scheme_false, scheme_top_stx, 0, 0); - } - - /* Re-providing all of the kernel without prefixing? */ - if (reprovide_kernel) { - if ((reprovide_kernel == (kernel->me->rt->num_provides - 1)) - && SCHEME_TRUEP(exclude_hint)) { - if (SCHEME_STX_PAIRP(exclude_hint) && SCHEME_NULLP(SCHEME_STX_CDR(exclude_hint))) { - Scheme_Object *n; - - exclude_hint = SCHEME_STX_CAR(exclude_hint); - exclude_hint = SCHEME_STX_VAL(exclude_hint); - n = scheme_hash_get(provided, exclude_hint); - if (n) { - /* may be a single shadowed exclusion, now bound to exclude_hint... */ - n = SCHEME_CAR(n); - if (SCHEME_STXP(n)) - n = scheme_tl_id_sym(env->genv, n, NULL, -1, NULL, NULL); - n = scheme_hash_get(required, n); - if (n && !SAME_OBJ(SCHEME_VEC_ELS(n)[1], kernel_modidx)) { - /* there is a single shadowed exclusion. */ - } else - reprovide_kernel = 0; - } else - reprovide_kernel = 0; - } else - reprovide_kernel = 0; - } else if (reprovide_kernel != kernel->me->rt->num_provides) - reprovide_kernel = 0; - else - exclude_hint = scheme_false; - } - /* If reprovide_kernel is non-zero, we re-provide all of it */ + (void)compute_reprovides(all_provided, + all_reprovided, + env->genv->module, + tables, + env->genv, + all_defs, all_defs_out, + all_et_defs, all_et_defs_out, + "require", NULL, NULL); /* Compute provide arrays */ exps = compute_provide_arrays(all_provided, tables, env->genv->module->me, env->genv, - reprovide_kernel, form, &et_exps); /* Compute indirect provides (which is everything at the top-level): */ @@ -6585,14 +6600,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, result = scheme_null; - /* kernel re-export info: */ - if (reprovide_kernel) { - if (exclude_hint) - result = scheme_make_pair(exclude_hint, result); - else - result = scheme_make_pair(scheme_true, result); - } else - result = scheme_make_pair(scheme_false, result); + /* kernel re-export info (always #f): */ + result = scheme_make_pair(scheme_false, result); /* Indirect provides */ a = scheme_null; @@ -6607,24 +6616,6 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, e = scheme_null; - if (reprovide_kernel) { - if (!j) { - i = kernel->me->rt->num_var_provides; - top = kernel->me->rt->num_provides; - } else { - i = 0; - top = kernel->me->rt->num_var_provides; - } - - for (; i < top; i++) { - if (!SAME_OBJ(kernel->me->rt->provides[i], exclude_hint)) { - a = scheme_make_pair(kernel->me->rt->provides[i], kernel->me->rt->provides[i]); - a = scheme_make_pair(kernel_modidx, a); - e = scheme_make_pair(a, e); - } - } - } - if (!j) { i = exvcount; top = excount; @@ -6669,9 +6660,6 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, env->genv->module->provide_protects = exps; env->genv->module->et_provide_protects = et_exps; - env->genv->module->me->rt->reprovide_kernel = reprovide_kernel; - env->genv->module->me->rt->kernel_exclusion = exclude_hint; - env->genv->module->indirect_provides = exis; env->genv->module->num_indirect_provides = exicount; @@ -6750,7 +6738,6 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, Scheme_Env *_genv, Scheme_Object *all_rt_defs, Scheme_Object *all_rt_defs_out, Scheme_Object *all_et_defs, Scheme_Object *all_et_defs_out, - Scheme_Object **_exclude_hint, const char *matching_form, Scheme_Object *all_mods, /* a phase list to use for all mods */ Scheme_Object *all_phases) /* a module-path list for all phases */ @@ -6759,7 +6746,6 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, Scheme_Object *reprovided, *tvec; int i, k, z; Scheme_Object *rx, *provided_list, *phase, *req_phase; - int reprovide_kernel = 0; Scheme_Object *all_defs, *all_defs_out; Scheme_Env *genv; @@ -6846,7 +6832,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, "cannot provide from a module without a matching `%s'", matching_form); } else { - return -1; + return 0; } } @@ -6942,11 +6928,6 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, ree = SCHEME_CDR(SCHEME_CAR(rx)); exns = SCHEME_CDR(ree); - if (SAME_OBJ(modidx, kernel_modidx)) - if (!SCHEME_STX_NULLP(exns)) { - if (SAME_OBJ(phase, scheme_make_integer(0)) && _exclude_hint) - *_exclude_hint = exns; - } } else { ree = NULL; exns = scheme_null; @@ -6997,10 +6978,6 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, provided_list = scheme_make_pair(name, provided_list); scheme_hash_set(all_provided, req_phase, provided_list); } - - if (SAME_OBJ(phase, scheme_make_integer(0))) - if (SAME_OBJ(modidx, kernel_modidx) && SAME_OBJ(outname, srcname)) - reprovide_kernel++; } } } @@ -7096,7 +7073,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, } } - return reprovide_kernel; + return 1; } static Scheme_Object **compute_indirects(Scheme_Env *genv, @@ -7167,7 +7144,7 @@ static Scheme_Object **compute_indirects(Scheme_Env *genv, exicount = count; - qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1); + qsort_provides(exis, NULL, NULL, NULL, NULL, NULL, NULL, 0, exicount, 1); *_count = exicount; return exis; @@ -7216,10 +7193,10 @@ Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bind tables, genv, NULL, NULL, NULL, NULL, - NULL, NULL, + NULL, all_mods, all_phases); - if (v < 0) { + if (!v) { return scheme_false; } else { l = scheme_null; @@ -7279,7 +7256,8 @@ static Scheme_Object *extract_free_id_name(Scheme_Object *name, Scheme_Object **_implicit_src_name, Scheme_Object **_implicit_mod_phase, Scheme_Object **_implicit_nominal_name, - Scheme_Object **_implicit_nominal_mod) + Scheme_Object **_implicit_nominal_mod, + Scheme_Object **_implicit_insp) { *_implicit = 0; @@ -7300,29 +7278,72 @@ static Scheme_Object *extract_free_id_name(Scheme_Object *name, v2 = scheme_lookup_in_table(genv->syntax, (const char *)name); if (v2 && scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(v2))) { Scheme_Object *name2; - Scheme_Object *mod, *id; + Scheme_Object *mod, *id, *rename_insp = NULL; + Scheme_Object *mod_phase = NULL; name2 = scheme_rename_transformer_id(SCHEME_PTR_VAL(v2)); id = name2; + + if (_implicit_mod_phase) mod_phase = *_implicit_mod_phase; mod = scheme_stx_module_name(NULL, &id, phase, _implicit_nominal_mod, _implicit_nominal_name, - _implicit_mod_phase, - NULL, NULL, NULL, NULL); + &mod_phase, + NULL, NULL, NULL, NULL, &rename_insp); + if (_implicit_mod_phase) *_implicit_mod_phase = mod_phase; + if (mod && SAME_TYPE(SCHEME_TYPE(mod), scheme_module_index_type)) { if (SCHEME_FALSEP(((Scheme_Modidx *)mod)->path)) { /* keep looking locally */ name = name2; SCHEME_USE_FUEL(1); } else { - /* free-id=? equivalence to a name that is not necessarily imported explicitly */ - if (_implicit_src) { - *_implicit_src = mod; - *_implicit_src_name = id; - name2 = scheme_stx_property(name2, nominal_id_symbol, NULL); - if (SCHEME_SYMBOLP(name2)) - *_implicit_nominal_name = name2; + /* free-id=? equivalence to a name that is not necessarily imported explicitly. */ + int would_complain = 0, is_prot = 0, is_unexp = 0; + + if (!SCHEME_FALSEP(phase)) { + /* Check whether reference is certified, and ignore it if not: */ + Scheme_Env *menv; + Scheme_Object *modname; + + modname = scheme_module_resolve(mod, 1); + menv = scheme_module_access(modname, genv, SCHEME_INT_VAL(mod_phase)); + if (!menv) + would_complain = 1; + else { + scheme_check_accessible_in_module(menv, menv->module->insp, mod, + SCHEME_STX_VAL(name2), name2, + NULL, NULL, rename_insp, + -1, 0, + &is_prot, &is_unexp, genv, &would_complain); + if (would_complain && (!is_prot && !is_unexp)) { + /* Must be unexported syntax */ + is_prot = is_unexp = would_complain = 0; + scheme_check_accessible_in_module(menv, menv->module->insp, mod, + SCHEME_STX_VAL(name2), name2, + NULL, NULL, rename_insp, + -2, 0, + &is_prot, &is_unexp, genv, &would_complain); + } + } + } + + + if (!would_complain) { + if (_implicit_src) { + *_implicit_src = mod; + *_implicit_src_name = id; + if (is_prot || is_unexp) { + if (rename_insp) + *_implicit_insp = rename_insp; + else + *_implicit_insp = genv->module->insp; + } + name2 = scheme_stx_property(name2, nominal_id_symbol, NULL); + if (SCHEME_SYMBOLP(name2)) + *_implicit_nominal_name = name2; + } + *_implicit = 1; } - *_implicit = 1; break; } } else @@ -7339,18 +7360,18 @@ static Scheme_Object *extract_free_id_name(Scheme_Object *name, char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, Scheme_Module_Exports *me, Scheme_Env *genv, - int reprovide_kernel, Scheme_Object *form, char **_phase1_protects) { int i, count, z, implicit; - Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase; + Scheme_Object **exs, **exsns, **exss, **exsnoms, **exinsps, *phase; Scheme_Hash_Table *provided, *required; char *exps, *exets, *phase0_exps = NULL, *phase1_exps = NULL; int excount, exvcount; Scheme_Module_Phase_Exports *pt; Scheme_Object *implicit_src, *implicit_src_name, *implicit_mod_phase; Scheme_Object *implicit_nominal_name, *implicit_nominal_mod; + Scheme_Object *implicit_insp; for (z = 0; z < all_provided->size; z++) { provided = (Scheme_Hash_Table *)all_provided->vals[z]; @@ -7384,13 +7405,11 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table count++; } - if (SAME_OBJ(phase, scheme_make_integer(0))) - count -= reprovide_kernel; - exs = MALLOC_N(Scheme_Object *, count); exsns = MALLOC_N(Scheme_Object *, count); exss = MALLOC_N(Scheme_Object *, count); exsnoms = MALLOC_N(Scheme_Object *, count); + exinsps = MALLOC_N(Scheme_Object *, count); exps = MALLOC_N_ATOMIC(char, count); exets = MALLOC_N_ATOMIC(char, count); memset(exets, 0, count); @@ -7408,7 +7427,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table name = extract_free_id_name(name, phase, genv, 1, &implicit, NULL, NULL, NULL, - NULL, NULL); + NULL, NULL, NULL); if (!implicit && genv @@ -7441,24 +7460,19 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table scheme_wrong_syntax("module", NULL, name, "cannot protect imported identifier with re-provide"); } if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[3])) { - /* If this is a kernel re-provide, don't provide after all. */ - if ((reprovide_kernel && SAME_OBJ(phase, scheme_make_integer(0))) - && SAME_OBJ(SCHEME_VEC_ELS(v)[1], kernel_modidx) - && SAME_OBJ(provided->keys[i], SCHEME_VEC_ELS(v)[2])) { - /* skip */ - } else { - Scheme_Object *noms; - exs[count] = provided->keys[i]; - exsns[count] = SCHEME_VEC_ELS(v)[2]; - exss[count] = SCHEME_VEC_ELS(v)[1]; - noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); - exsnoms[count] = noms; - exps[count] = protected; - if (SAME_OBJ(SCHEME_VEC_ELS(v)[8], scheme_make_integer(1))) - exets[count] = 1; - - count++; - } + Scheme_Object *noms; + exs[count] = provided->keys[i]; + exsns[count] = SCHEME_VEC_ELS(v)[2]; + exss[count] = SCHEME_VEC_ELS(v)[1]; + noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); + exsnoms[count] = noms; + exps[count] = protected; + if (SAME_OBJ(SCHEME_VEC_ELS(v)[8], scheme_make_integer(1))) + exets[count] = 1; + if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[9])) + exinsps[count] = SCHEME_VEC_ELS(v)[9]; + + count++; } } else { /* Not defined! */ @@ -7481,7 +7495,8 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table name = extract_free_id_name(name, phase, genv, 0, &implicit, &implicit_src, &implicit_src_name, &implicit_mod_phase, - &implicit_nominal_name, &implicit_nominal_mod); + &implicit_nominal_name, &implicit_nominal_mod, + &implicit_insp); if (!implicit && genv @@ -7495,33 +7510,34 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table exps[count] = protected; count++; } else if (implicit) { - /* We record all free-id=?-based exprts as synatx, even though they may be values. */ + /* We record all free-id=?-based exprts as syntax, even though they may be values. */ Scheme_Object *noms; exs[count] = provided->keys[i]; exsns[count] = implicit_src_name; exss[count] = implicit_src; noms = adjust_for_rename(exs[count], implicit_nominal_name, cons(implicit_nominal_mod, scheme_null)); exsnoms[count] = noms; - exps[count] = protected; + exps[count] = protected; + if (implicit_insp) { + if (protected) { + implicit_insp = cons(genv->insp, implicit_insp); + } + exinsps[count] = implicit_insp; + } count++; } else if ((v = scheme_hash_get(required, name))) { /* Required */ if (SCHEME_FALSEP(SCHEME_VEC_ELS(v)[3])) { - /* If this is a kernel re-provide, don't provide after all. */ - if ((reprovide_kernel && SAME_OBJ(phase, scheme_make_integer(0))) - && SAME_OBJ(SCHEME_VEC_ELS(v)[1], kernel_modidx) - && SAME_OBJ(provided->keys[i], SCHEME_VEC_ELS(v)[2])) { - /* skip */ - } else { - Scheme_Object *noms; - exs[count] = provided->keys[i]; - exsns[count] = SCHEME_VEC_ELS(v)[2]; - exss[count] = SCHEME_VEC_ELS(v)[1]; - noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); - exsnoms[count] = noms; - exps[count] = protected; - count++; - } + Scheme_Object *noms; + exs[count] = provided->keys[i]; + exsns[count] = SCHEME_VEC_ELS(v)[2]; + exss[count] = SCHEME_VEC_ELS(v)[1]; + noms = adjust_for_rename(exs[count], SCHEME_VEC_ELS(v)[4], SCHEME_VEC_ELS(v)[0]); + exsnoms[count] = noms; + exps[count] = protected; + if (SCHEME_TRUEP(SCHEME_VEC_ELS(v)[9])) + exinsps[count] = SCHEME_VEC_ELS(v)[9]; + count++; } } } @@ -7538,17 +7554,16 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table exsnoms = NULL; } - /* Sort provide array for variables: interned followed by - uninterned, alphabetical within each. This is important for - having a consistent provide arrays. */ - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, 0, exvcount, 1); + /* Discard exinsps if there are no inspectors */ + for (i = 0; i < excount; i++) { + if (exinsps[i]) + break; + } + if (i >= excount) { + exinsps = NULL; + } - pt->num_provides = excount; - pt->num_var_provides = exvcount; - pt->provides = exs; - pt->provide_src_names = exsns; - pt->provide_srcs = exss; - pt->provide_nominal_srcs = exsnoms; + /* Discard exets if all 0 */ if (exets) { for (i = 0; i < excount; i++) { if (exets[i]) @@ -7557,6 +7572,19 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table if (i >= excount) exets = NULL; } + + /* Sort provide array for variables: interned followed by + uninterned, alphabetical within each. This is important for + having a consistent provide arrays. */ + qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exinsps, 0, exvcount, 1); + + pt->num_provides = excount; + pt->num_var_provides = exvcount; + pt->provides = exs; + pt->provide_src_names = exsns; + pt->provide_srcs = exss; + pt->provide_nominal_srcs = exsnoms; + pt->provide_insps = exinsps; pt->provide_src_phases = exets; if (SAME_OBJ(phase, scheme_make_integer(0))) @@ -7574,11 +7602,11 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table /* Helper: */ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Object **exss, char *exps, char *exets, - Scheme_Object **exsnoms, + Scheme_Object **exsnoms, Scheme_Object **exinsps, int start, int count, int do_uninterned) { int i, j; - Scheme_Object *tmp_ex, *tmp_exsn, *tmp_exs, *tmp_exsnom, *pivot; + Scheme_Object *tmp_ex, *tmp_exsn, *tmp_exs, *tmp_exsnom, *tmp_exinsp, *pivot; char tmp_exp, tmp_exet; if (do_uninterned) { @@ -7620,6 +7648,13 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob exsnoms[j] = tmp_exsnom; } + if (exinsps) { + tmp_exinsp = exinsps[i]; + + exinsps[i] = exinsps[j]; + + exinsps[j] = tmp_exinsp; + } j--; /* Skip over uninterns already at the end: */ @@ -7633,8 +7668,8 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob } /* Sort interned and uninterned separately: */ - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, 0, j + 1, 0); - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, j + 1, count - j - 1, 0); + qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exinsps, 0, j + 1, 0); + qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exinsps, j + 1, count - j - 1, 0); } else { j = start; while (count > 1) { @@ -7666,7 +7701,6 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob exets[k] = exets[j]; exets[j] = tmp_exet; } - if (exsnoms) { tmp_exsnom = exsnoms[k]; @@ -7674,6 +7708,13 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob exsnoms[j] = tmp_exsnom; } + if (exinsps) { + tmp_exinsp = exinsps[k]; + + exinsps[k] = exinsps[j]; + + exinsps[j] = tmp_exinsp; + } j++; } @@ -7687,8 +7728,8 @@ static void qsort_provides(Scheme_Object **exs, Scheme_Object **exsns, Scheme_Ob } if (count > 1) { - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, start, j - start, 0); - qsort_provides(exs, exsns, exss, exps, exets, exsnoms, j, count - (j - start), 0); + qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exinsps, start, j - start, 0); + qsort_provides(exs, exsns, exss, exps, exets, exsnoms, exinsps, j, count - (j - start), 0); } } } @@ -8255,9 +8296,9 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ { int j, var_count; Scheme_Object *orig_idx = idx, *to_phase; - Scheme_Object **exs, **exsns, **exss, *context_marks = scheme_null; + Scheme_Object **exs, **exsns, **exss, *context_marks = scheme_null, **exinsps; char *exets; - int is_kern, has_context, save_marshal_info = 0; + int has_context, save_marshal_info = 0; Scheme_Object *nominal_modidx, *one_exn, *prnt_iname, *name, *rn, *ename = orig_ename; Scheme_Hash_Table *orig_onlys; int k, skip_rename, do_copy_vars; @@ -8316,14 +8357,6 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ to_phase = NULL; if (pt) { - is_kern = (SAME_OBJ(idx, kernel_modidx) - && !exns - && !onlys - && !prefix - && !iname - && !unpack_kern - && !has_context); - one_exn = NULL; nominal_modidx = idx; @@ -8344,7 +8377,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ && !exns && !prefix && !orig_ename - && (pt->num_provides || pt->reprovide_kernel) + && pt->num_provides && !do_copy_vars) { /* Simple "import everything" whose mappings can be shared via the exporting module: */ if (!pt->src_modidx) @@ -8354,150 +8387,134 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ } else skip_rename = 0; - while (1) { /* loop to handle kernel re-provides... */ - int break_if_iname_null = !!iname; - - exs = pt->provides; - exsns = pt->provide_src_names; - exss = pt->provide_srcs; - exets = pt->provide_src_phases; - var_count = pt->num_var_provides; - - for (j = pt->num_provides; j--; ) { - Scheme_Object *modidx; - - if (orig_ename) { - if (!SAME_OBJ(SCHEME_STX_VAL(orig_ename), exs[j])) - continue; /* we don't want this one. */ - } else if (onlys) { - name = scheme_hash_get(orig_onlys, exs[j]); - if (!name) - continue; /* we don't want this one. */ - mark_src = name; - { - Scheme_Object *l; - l = scheme_stx_extract_marks(mark_src); - has_context = !SCHEME_NULLP(l); - } - /* Remove to indicate that it's been imported: */ - scheme_hash_set(onlys, exs[j], NULL); - } else { - if (exns) { - Scheme_Object *l, *a; - for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { - a = SCHEME_STX_CAR(l); - if (SCHEME_STXP(a)) - a = SCHEME_STX_VAL(a); - if (SAME_OBJ(a, exs[j])) - break; - } - if (!SCHEME_STX_NULLP(l)) - continue; /* we don't want this one. */ - } - - if (one_exn) { - if (SAME_OBJ(one_exn, exs[j])) - continue; /* we don't want this one. */ - } - } - - modidx = ((exss && !SCHEME_FALSEP(exss[j])) - ? scheme_modidx_shift(exss[j], me->src_modidx, idx) - : idx); + exs = pt->provides; + exsns = pt->provide_src_names; + exss = pt->provide_srcs; + exets = pt->provide_src_phases; + exinsps = pt->provide_insps; + var_count = pt->num_var_provides; - if (!iname) - iname = exs[j]; - - if (SCHEME_SYM_WEIRDP(iname)) { - /* This shouldn't happen. In case it does, don't import a - gensym or parallel symbol. The former is useless. The - latter is supposed to be module-specific, and it could - collide with local module-specific ids. */ - iname = NULL; - continue; - } - - if (prefix) - iname = scheme_symbol_append(prefix, iname); - - prnt_iname = iname; - if (has_context) { - /* The `require' expression has a set of marks in its - context, which means that we need to generate a name. */ - iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0); - iname = scheme_tl_id_sym(orig_env, iname, scheme_false, skip_rename ? 3 : 2, to_phase, NULL); - if (all_simple) - *all_simple = 0; - } - - if (ck) - ck(prnt_iname, iname, nominal_modidx, exs[j], modidx, exsns[j], exets ? exets[j] : 0, - (j < var_count), - data, cki, form, err_src, mark_src, to_phase, src_phase_index, pt->phase_index); - - if (!is_kern) { - int done; - - if (do_copy_vars && (j < var_count)) { - Scheme_Env *menv; - Scheme_Object *val, *modname; - Scheme_Bucket *b; - modname = scheme_module_resolve(modidx, 1); - menv = scheme_module_access(modname, orig_env, 0); - val = scheme_lookup_in_table(menv->toplevel, (char *)exsns[j]); - b = scheme_global_bucket(iname, orig_env); - scheme_set_global_bucket(((copy_vars == 2) - ? "namespace-require/constant" - : "namespace-require/copy"), - b, val, 1); - if (copy_vars == 2) { - ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; - done = 0; - } else { - scheme_shadow(orig_env, iname, 1); - done = 1; - } - } else - done = 0; - - if (done) { - } else if (!for_unmarshal || !has_context) { - if (!skip_rename) { - if (!save_marshal_info && !has_context && can_save_marshal) - save_marshal_info = 1; - - scheme_extend_module_rename(rn, - modidx, iname, exsns[j], nominal_modidx, exs[j], - exets ? exets[j] : 0, - src_phase_index, - pt->phase_index, - (for_unmarshal || (!has_context && can_save_marshal)) ? 1 : 0); - } - } - } - - iname = NULL; + for (j = pt->num_provides; j--; ) { + Scheme_Object *modidx; - if (ename) { - ename = NULL; - break; + if (orig_ename) { + if (!SAME_OBJ(SCHEME_STX_VAL(orig_ename), exs[j])) + continue; /* we don't want this one. */ + } else if (onlys) { + name = scheme_hash_get(orig_onlys, exs[j]); + if (!name) + continue; /* we don't want this one. */ + mark_src = name; + { + Scheme_Object *l; + l = scheme_stx_extract_marks(mark_src); + has_context = !SCHEME_NULLP(l); + } + /* Remove to indicate that it's been imported: */ + scheme_hash_set(onlys, exs[j], NULL); + } else { + if (exns) { + Scheme_Object *l, *a; + for (l = exns; SCHEME_STX_PAIRP(l); l = SCHEME_STX_CDR(l)) { + a = SCHEME_STX_CAR(l); + if (SCHEME_STXP(a)) + a = SCHEME_STX_VAL(a); + if (SAME_OBJ(a, exs[j])) + break; + } + if (!SCHEME_STX_NULLP(l)) + continue; /* we don't want this one. */ + } + + if (one_exn) { + if (SAME_OBJ(one_exn, exs[j])) + continue; /* we don't want this one. */ + } + } + + modidx = ((exss && !SCHEME_FALSEP(exss[j])) + ? scheme_modidx_shift(exss[j], me->src_modidx, idx) + : idx); + + if (!iname) + iname = exs[j]; + + if (SCHEME_SYM_WEIRDP(iname)) { + /* This shouldn't happen. In case it does, don't import a + gensym or parallel symbol. The former is useless. The + latter is supposed to be module-specific, and it could + collide with local module-specific ids. */ + iname = NULL; + continue; + } + + if (prefix) + iname = scheme_symbol_append(prefix, iname); + + prnt_iname = iname; + if (has_context) { + /* The `require' expression has a set of marks in its + context, which means that we need to generate a name. */ + iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0); + iname = scheme_tl_id_sym(orig_env, iname, scheme_false, skip_rename ? 3 : 2, to_phase, NULL); + if (all_simple) + *all_simple = 0; + } + + if (ck) + ck(prnt_iname, iname, nominal_modidx, exs[j], modidx, exsns[j], exets ? exets[j] : 0, + (j < var_count), + data, cki, form, err_src, mark_src, to_phase, src_phase_index, pt->phase_index, + exinsps ? exinsps[j] : scheme_false); + + { + int done; + + if (do_copy_vars && (j < var_count)) { + Scheme_Env *menv; + Scheme_Object *val, *modname; + Scheme_Bucket *b; + modname = scheme_module_resolve(modidx, 1); + menv = scheme_module_access(modname, orig_env, 0); + val = scheme_lookup_in_table(menv->toplevel, (char *)exsns[j]); + b = scheme_global_bucket(iname, orig_env); + scheme_set_global_bucket(((copy_vars == 2) + ? "namespace-require/constant" + : "namespace-require/copy"), + b, val, 1); + if (copy_vars == 2) { + ((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED; + done = 0; + } else { + scheme_shadow(orig_env, iname, 1); + done = 1; + } + } else + done = 0; + + if (done) { + } else if (!for_unmarshal || !has_context) { + if (!skip_rename) { + if (!save_marshal_info && !has_context && can_save_marshal) + save_marshal_info = 1; + + scheme_extend_module_rename(rn, + modidx, iname, exsns[j], nominal_modidx, exs[j], + exets ? exets[j] : 0, + src_phase_index, + pt->phase_index, + exinsps ? exinsps[j] : NULL, + (for_unmarshal || (!has_context && can_save_marshal)) ? 1 : 0); + } } } - if (is_kern && !skip_rename) - scheme_extend_module_rename_with_kernel(rn, nominal_modidx); - - if (break_if_iname_null && !iname) - break; - - if (pt->reprovide_kernel) { - idx = kernel_modidx; - one_exn = pt->kernel_exclusion; - me = kernel->me; - pt = kernel->me->rt; - is_kern = !prefix && !unpack_kern && !ename && !has_context && !onlys; - } else + iname = NULL; + + if (ename) { + ename = NULL; break; + } } if (save_marshal_info) { @@ -9028,7 +9045,7 @@ static void check_dup_require(Scheme_Object *prnt_name, Scheme_Object *name, int isval, void *ht, Scheme_Object *e, Scheme_Object *form, Scheme_Object *err_src, Scheme_Object *mark_src, Scheme_Object *to_phase, Scheme_Object *src_phase_index, - Scheme_Object *nominal_export_phase) + Scheme_Object *nominal_export_phase, Scheme_Object *in_insp) { Scheme_Object *i; @@ -9328,6 +9345,20 @@ static Scheme_Object *write_module(Scheme_Object *obj) v = scheme_false; l = cons(v, l); + if (pt->provide_insps) { + v = scheme_make_vector(count, scheme_false); + for (i = 0; i < count; i++) { + if (pt->provide_insps[i]) { + if (SCHEME_PAIRP(pt->provide_insps[i])) + SCHEME_VEC_ELS(v)[i] = scheme_void; + else + SCHEME_VEC_ELS(v)[i] = scheme_true; + } + } + } else + v = scheme_false; + l = cons(v, l); + l = cons(pt->phase_index, l); cnt++; } @@ -9393,9 +9424,6 @@ static Scheme_Object *write_module(Scheme_Object *obj) } l = cons(v, l); - l = cons(m->me->rt->reprovide_kernel ? scheme_true : scheme_false, l); - l = cons(m->me->rt->kernel_exclusion, l); - l = cons((Scheme_Object *)m->prefix, l); l = cons(m->dummy, l); @@ -9439,8 +9467,8 @@ static int check_requires_ok(Scheme_Object *l) static Scheme_Object *read_module(Scheme_Object *obj) { Scheme_Module *m; - Scheme_Object *ie, *nie; - Scheme_Object *eesp, *esp, *esn, *esph, *es, *esnom, *e, *nve, *ne, **v; + Scheme_Object *ie, *nie, *insp; + Scheme_Object *eesp, *esp, *esn, *esph, *es, *esnom, *einsp, *e, *nve, *ne, **v; Scheme_Module_Exports *me; Scheme_Module_Phase_Exports *pt; char *ps, *sps; @@ -9501,13 +9529,6 @@ static Scheme_Object *read_module(Scheme_Object *obj) m->prefix = (Resolve_Prefix *)SCHEME_CAR(obj); obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); - me->rt->kernel_exclusion = SCHEME_CAR(obj); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); - me->rt->reprovide_kernel = SCHEME_TRUEP(SCHEME_CAR(obj)); - obj = SCHEME_CDR(obj); - if (!SCHEME_PAIRP(obj)) return_NULL(); ie = SCHEME_CAR(obj); obj = SCHEME_CDR(obj); @@ -9604,6 +9625,10 @@ static Scheme_Object *read_module(Scheme_Object *obj) scheme_hash_set(me->other_phases, phase, (Scheme_Object *)pt); } + if (!SCHEME_PAIRP(obj)) return_NULL(); + einsp = SCHEME_CAR(obj); + obj = SCHEME_CDR(obj); + if (!SCHEME_PAIRP(obj)) return_NULL(); esph = SCHEME_CAR(obj); obj = SCHEME_CDR(obj); @@ -9678,6 +9703,24 @@ static Scheme_Object *read_module(Scheme_Object *obj) } } pt->provide_src_phases = sps; + + if (SCHEME_FALSEP(einsp)) { + pt->provide_insps = NULL; + } else { + if (!SCHEME_VECTORP(einsp) || (SCHEME_VEC_SIZE(einsp) != count)) return_NULL(); + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + v = MALLOC_N(Scheme_Object *, count); + for (i = 0; i < count; i++) { + if (SCHEME_TRUEP(SCHEME_VEC_ELS(einsp)[i])) { + if (SCHEME_VOIDP(SCHEME_VEC_ELS(einsp)[i])) { + e = cons(scheme_false, insp); + v[i] = e; + } else + v[i] = insp; + } + } + pt->provide_insps = v; + } } count = me->rt->num_provides; diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 277bcb6bda..80985c8c22 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -2465,6 +2465,7 @@ static int module_phase_exports_val_MARK(void *p) { gcMARK(m->provide_src_names); gcMARK(m->provide_nominal_srcs); gcMARK(m->provide_src_phases); + gcMARK(m->provide_insps); gcMARK(m->kernel_exclusion); gcMARK(m->kernel_exclusion2); @@ -2487,6 +2488,7 @@ static int module_phase_exports_val_FIXUP(void *p) { gcFIXUP(m->provide_src_names); gcFIXUP(m->provide_nominal_srcs); gcFIXUP(m->provide_src_phases); + gcFIXUP(m->provide_insps); gcFIXUP(m->kernel_exclusion); gcFIXUP(m->kernel_exclusion2); @@ -5043,7 +5045,6 @@ static int mark_rename_table_MARK(void *p) { gcMARK(rn->nomarshal_ht); gcMARK(rn->unmarshal_info); gcMARK(rn->shared_pes); - gcMARK(rn->plus_kernel_nominal_source); gcMARK(rn->set_identity); gcMARK(rn->marked_names); gcMARK(rn->free_id_renames); @@ -5058,7 +5059,6 @@ static int mark_rename_table_FIXUP(void *p) { gcFIXUP(rn->nomarshal_ht); gcFIXUP(rn->unmarshal_info); gcFIXUP(rn->shared_pes); - gcFIXUP(rn->plus_kernel_nominal_source); gcFIXUP(rn->set_identity); gcFIXUP(rn->marked_names); gcFIXUP(rn->free_id_renames); @@ -5216,6 +5216,40 @@ static int lex_rib_FIXUP(void *p) { #define lex_rib_IS_CONST_SIZE 1 +static int mark_free_id_info_SIZE(void *p) { + return + gcBYTES_TO_WORDS((sizeof(Scheme_Vector) + + ((8 - 1) * sizeof(Scheme_Object *)))); +} + +static int mark_free_id_info_MARK(void *p) { + Scheme_Vector *vec = (Scheme_Vector *)p; + int i; + for (i = 8; i--; ) + gcMARK(vec->els[i]); + + return + gcBYTES_TO_WORDS((sizeof(Scheme_Vector) + + ((8 - 1) * sizeof(Scheme_Object *)))); +} + +static int mark_free_id_info_FIXUP(void *p) { + Scheme_Vector *vec = (Scheme_Vector *)p; + int i; + for (i = 8; i--; ) + gcFIXUP(vec->els[i]); + + return + gcBYTES_TO_WORDS((sizeof(Scheme_Vector) + + ((8 - 1) * sizeof(Scheme_Object *)))); +} + +#define mark_free_id_info_IS_ATOMIC 0 +#define mark_free_id_info_IS_CONST_SIZE 0 + + + + #endif /* STXOBJ */ /**********************************************************************/ diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index d19fb7c89c..a93a9e4384 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -990,6 +990,7 @@ module_phase_exports_val { gcMARK(m->provide_src_names); gcMARK(m->provide_nominal_srcs); gcMARK(m->provide_src_phases); + gcMARK(m->provide_insps); gcMARK(m->kernel_exclusion); gcMARK(m->kernel_exclusion2); @@ -2070,7 +2071,6 @@ mark_rename_table { gcMARK(rn->nomarshal_ht); gcMARK(rn->unmarshal_info); gcMARK(rn->shared_pes); - gcMARK(rn->plus_kernel_nominal_source); gcMARK(rn->set_identity); gcMARK(rn->marked_names); gcMARK(rn->free_id_renames); @@ -2133,6 +2133,20 @@ lex_rib { gcBYTES_TO_WORDS(sizeof(Scheme_Lexical_Rib)); } +mark_free_id_info { + mark: + Scheme_Vector *vec = (Scheme_Vector *)p; + int i; + for (i = 8; i--; ) + gcMARK(vec->els[i]); + + size: + gcBYTES_TO_WORDS((sizeof(Scheme_Vector) + + ((8 - 1) * sizeof(Scheme_Object *)))); +} + + + END stxobj; /**********************************************************************/ diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index fd3e59f66a..385e3f4e9d 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -779,14 +779,14 @@ Scheme_Object* scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *mod Scheme_Object *locname, Scheme_Object *exname, Scheme_Object *nominal_src, Scheme_Object *nominal_ex, int mod_phase, Scheme_Object *src_phase_index, - Scheme_Object *nom_export_phase, int drop_for_marshal); + Scheme_Object *nom_export_phase, Scheme_Object *insp, + int mode); void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, struct Scheme_Module_Phase_Exports *pt, Scheme_Object *unmarshal_phase_index, Scheme_Object *src_phase_index, Scheme_Object *marks, int save_unmarshal); -void scheme_extend_module_rename_with_kernel(Scheme_Object *rn, Scheme_Object *nominal_src); void scheme_save_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info); void scheme_do_module_rename_unmarshal(Scheme_Object *rn, Scheme_Object *info, Scheme_Object *modidx_shift_from, Scheme_Object *modidx_shift_to, @@ -817,7 +817,8 @@ Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *recur, Scheme_Object **src_phase_index, Scheme_Object **nominal_src_phase, Scheme_Object **lex_env, - int *_sealed); + int *_sealed, + Scheme_Object **rename_insp); Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a); int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx); @@ -2653,10 +2654,10 @@ typedef struct Scheme_Module_Phase_Exports Scheme_Object **provide_src_names; /* symbols (original internal names) */ Scheme_Object **provide_nominal_srcs; /* import source if re-exported; NULL or array of lists */ char *provide_src_phases; /* NULL, or src phase for for-syntax import */ + Scheme_Object **provide_insps; /* inspectors for re-provided protected/unexported */ int num_provides; int num_var_provides; /* non-syntax listed first in provides */ - int reprovide_kernel; /* if true, extend provides with kernel's */ Scheme_Object *kernel_exclusion; /* we allow up to two exns, but they must be shadowed */ Scheme_Object *kernel_exclusion2; @@ -2729,9 +2730,11 @@ int scheme_module_export_position(Scheme_Object *modname, Scheme_Env *env, Schem Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object *prot_insp, Scheme_Object *in_modidx, Scheme_Object *symbol, Scheme_Object *stx, - Scheme_Object *certs, Scheme_Object *unexp_insp, + Scheme_Object *certs, Scheme_Object *unexp_insp, + Scheme_Object *rename_insp, int position, int want_pos, - int *_protected, Scheme_Env *from_env); + int *_protected, int *_unexported, + Scheme_Env *from_env, int *_would_complain); Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Scheme_Object *name); Scheme_Object *scheme_modidx_shift(Scheme_Object *modidx, diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index a58c15b25f..3f88efcb15 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.5.4" +#define MZSCHEME_VERSION "4.1.5.5" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 5 -#define MZSCHEME_VERSION_W 4 +#define MZSCHEME_VERSION_W 5 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 942b31cfb9..0046a1e5f0 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -71,6 +71,9 @@ static Scheme_Object *syntax_recertify(int argc, Scheme_Object **argv); static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active); +static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj); +static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj); + static Scheme_Object *source_symbol; /* uninterned! */ static Scheme_Object *share_symbol; /* uninterned! */ static Scheme_Object *origin_symbol; @@ -130,16 +133,16 @@ XFORM_NONGCING static int prefab_p(Scheme_Object *o) typedef struct Module_Renames { Scheme_Object so; /* scheme_rename_table_type */ - char plus_kernel, kind, needs_unmarshal; + char kind, needs_unmarshal; char sealed; /* 1 means bound won't change; 2 means unbound won't change, either */ Scheme_Object *phase; - Scheme_Object *plus_kernel_nominal_source; Scheme_Object *set_identity; Scheme_Hash_Table *ht; /* localname -> modidx OR (cons modidx exportname) OR (cons modidx nominal_modidx) OR (list* modidx exportname nominal_modidx_plus_phase nominal_exportname) OR - (list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) + (list* modidx mod-phase exportname nominal_modidx_plus_phase nominal_exportname) OR + (cons insp localname) nominal_modix_plus_phase -> nominal_modix | (cons nominal_modix import_phase_plus_nominal_phase) import_phase_plus_nominal_phase -> import-phase-index | (cons import-phase-index nom-phase) */ Scheme_Hash_Table *nomarshal_ht; /* like ht, but dropped on marshal */ @@ -218,6 +221,14 @@ static Module_Renames *krn; #define SCHEME_MODIDXP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) +static int is_rename_inspector_info(Scheme_Object *v) +{ + return (SAME_TYPE(SCHEME_TYPE(v), scheme_inspector_type) + || (SCHEME_PAIRP(v) + && SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(v)), scheme_inspector_type) + && SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(v)), scheme_inspector_type))); +} + /* Wraps: A wrap is a list of wrap-elems and wrap-chunks. A wrap-chunk is a @@ -242,11 +253,11 @@ static Module_Renames *krn; (cons (cons )) => free-id=? renaming to on match - A wrap-elem (vector ... ...) is also a lexical rename - var resolved: sym or (cons ), - where is module/lexical binding info: - (cons #f) => top-level binding - (cons ) => lexical binding - (vector ...) => module-binding + bool var resolved: sym or (cons ), + where is module/lexical binding info: + (cons #f) => top-level binding + (cons ) => lexical binding + (free-eq-info ...) => module-binding where the variables have already been resolved and filtered (no mark or lexical-env comparison needed with the remaining wraps) @@ -586,6 +597,9 @@ void scheme_init_stx(Scheme_Env *env) SCHEME_SET_IMMUTABLE(no_nested_inactive_certs); REGISTER_SO(unsealed_dependencies); + + scheme_install_type_writer(scheme_free_id_info_type, write_free_id_info_prefix); + scheme_install_type_reader(scheme_free_id_info_type, read_free_id_info_prefix); } /*========================================================================*/ @@ -1355,15 +1369,6 @@ static void check_not_sealed(Module_Renames *mrn) scheme_signal_error("internal error: attempt to change sealed module rename"); } -void scheme_extend_module_rename_with_kernel(Scheme_Object *mrn, Scheme_Object *nominal_mod) -{ - /* Don't use on a non-module namespace, where renames may need - to be removed... */ - check_not_sealed((Module_Renames *)mrn); - ((Module_Renames *)mrn)->plus_kernel = 1; - ((Module_Renames *)mrn)->plus_kernel_nominal_source = nominal_mod; -} - static Scheme_Object *phase_to_index(Scheme_Object *phase) { return phase; @@ -1378,6 +1383,7 @@ Scheme_Object *scheme_extend_module_rename(Scheme_Object *mrn, int mod_phase, /* phase of source defn */ Scheme_Object *src_phase_index, /* nominal import phase */ Scheme_Object *nom_phase, /* nominal export phase */ + Scheme_Object *insp, /* inspector for re-export */ int mode) /* 1 => can be reconstructed from unmarshal info 2 => free-id=? renaming 3 => return info */ @@ -1432,6 +1438,9 @@ Scheme_Object *scheme_extend_module_rename(Scheme_Object *mrn, elem = CONS(scheme_make_integer(mod_phase), elem); elem = CONS(modname, elem); } + + if (insp) + elem = CONS(insp, elem); if (mode == 1) { if (!((Module_Renames *)mrn)->nomarshal_ht) { @@ -1500,11 +1509,6 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest, check_not_sealed((Module_Renames *)dest); - if (((Module_Renames *)src)->plus_kernel) { - ((Module_Renames *)dest)->plus_kernel = 1; - ((Module_Renames *)dest)->plus_kernel_nominal_source = ((Module_Renames *)src)->plus_kernel_nominal_source; - } - if (do_pes) { if (!SCHEME_NULLP(((Module_Renames *)src)->shared_pes)) { Scheme_Object *first = NULL, *last = NULL, *pr, *l; @@ -1562,6 +1566,14 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest, if (hts->vals[i]) { v = hts->vals[i]; if (old_midx) { + Scheme_Object *insp = NULL; + + if (SCHEME_PAIRP(v) && is_rename_inspector_info(SCHEME_CAR(v))) { + insp = SCHEME_CAR(v); + v = SCHEME_CDR(v); + } else + insp = NULL; + /* Shift the modidx part */ if (SCHEME_PAIRP(v)) { if (SCHEME_PAIRP(SCHEME_CDR(v))) { @@ -1600,6 +1612,9 @@ static void do_append_module_rename(Scheme_Object *src, Scheme_Object *dest, /* modidx */ v = scheme_modidx_shift(v, old_midx, new_midx); } + + if (insp) + v = CONS(insp, v); } scheme_hash_set(ht, hts->keys[i], v); if (drop_ht) @@ -1701,12 +1716,6 @@ void scheme_list_module_rename(Scheme_Object *set, Scheme_Hash_Table *ht) for (i = pt->num_provides; i--; ) { scheme_hash_set(ht, pt->provides[i], scheme_false); } - if (pt->reprovide_kernel) - scheme_list_module_rename((Scheme_Object *)krn, ht); - } - - if (src->plus_kernel) { - scheme_list_module_rename((Scheme_Object *)krn, ht); } } @@ -1965,6 +1974,7 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, Scheme_Object *src_phase_index; Scheme_Object *nominal_src_phase; Scheme_Object *lex_env; + Scheme_Object *rename_insp; if (scheme_hash_get(free_id_recur, id)) { return id; @@ -1980,7 +1990,8 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, &src_phase_index, &nominal_src_phase, &lex_env, - _sealed); + _sealed, + &rename_insp); if (SCHEME_SYMBOLP(nom2)) nominal_name = nom2; @@ -1999,6 +2010,7 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, SCHEME_INT_VAL(mod_phase), /* phase of source defn */ src_phase_index, /* nominal import phase */ nominal_src_phase, /* nominal export phase */ + rename_insp, 3); if (*_sealed) { @@ -3710,7 +3722,7 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, Scheme_Object *pr, *idx, *pos, *src, *best_match = NULL; Scheme_Module_Phase_Exports *pt; Scheme_Hash_Table *ht; - int i, phase, best_match_len = -1, skip; + int i, phase, best_match_len = -1, skip = 0; Scheme_Object *marks_cache = NULL; for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { @@ -3771,6 +3783,7 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, if (SCHEME_PAIRP(get_names[4])) /* skip over marks, if any */ get_names[4] = SCHEME_CDR(get_names[4]); get_names[5] = pt->phase_index; + get_names[6] = (pt->provide_insps ? pt->provide_insps[i] : NULL); } if (SCHEME_FALSEP(src)) { @@ -3782,34 +3795,6 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, best_match = src; } } - } else if (pt->reprovide_kernel) { - Scheme_Object *kpr; - kpr = scheme_hash_get(krn->ht, glob_id); - if (kpr) { - /* Found it, maybe. Check marks. */ - int mark_len, skip; - mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth, &skip); - if (mark_len > best_match_len) { - /* Marks match and improve on previously found match. Build suitable rename: */ - best_match_len = mark_len; - if (_skipped) *_skipped = skip; - - if (get_orig_name) - best_match = glob_id; - else { - if (get_names) { - idx = SCHEME_CAR(SCHEME_CAR(kpr)); - get_names[0] = glob_id; - get_names[1] = idx; - get_names[2] = glob_id; - get_names[3] = scheme_make_integer(0); - get_names[4] = pt->phase_index; - get_names[5] = scheme_make_integer(0); - } - best_match = scheme_get_kernel_modidx(); - } - } - } } } @@ -3973,7 +3958,9 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, get_names[1] is set to the nominal source module, get_names[2] is set to the nominal source module's export, get_names[3] is set to the phase of the source definition, and get_names[4] is set to the nominal import phase index, - and get_names[5] is set to the nominal export phase. + and get_names[5] is set to the nominal export phase; get_names[6] is set to + an inspector/pair if one applies for a re-export of a protected or unexported, NULL or + #f otherwise. If lexically bound, result is env id, and a get_names[0] is set to scheme_undefined; get_names[1] is set if a free-id=? rename provides a different name for the bindig. If neither, result is #f and get_names[0] is either unchanged or NULL; get_names[1] @@ -3981,7 +3968,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, { WRAP_POS wraps; Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs; - Scheme_Object *mresult = scheme_false; + Scheme_Object *mresult = scheme_false, *mresult_insp; Scheme_Object *modidx_shift_to = NULL, *modidx_shift_from = NULL; Scheme_Object *rename_stack[QUICK_STACK_SIZE]; int stack_pos = 0, no_lexical = 0; @@ -4080,7 +4067,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, result = SCHEME_CDR(result_free_rename); if (get_names) get_names[0] = scheme_undefined; - } else if (SCHEME_VECTORP(result_free_rename)) { + } else if (SAME_OBJ(SCHEME_TYPE(result_free_rename), scheme_free_id_info_type)) { result = SCHEME_VEC_ELS(result_free_rename)[0]; if (get_names) { get_names[0] = SCHEME_VEC_ELS(result_free_rename)[1]; @@ -4089,6 +4076,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, get_names[3] = SCHEME_VEC_ELS(result_free_rename)[4]; get_names[4] = SCHEME_VEC_ELS(result_free_rename)[5]; get_names[5] = SCHEME_VEC_ELS(result_free_rename)[6]; + get_names[6] = SCHEME_VEC_ELS(result_free_rename)[7]; } } else { if (get_names) @@ -4203,10 +4191,6 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, rename = scheme_hash_get(mrn->ht, glob_id); if (!rename && mrn->nomarshal_ht) rename = scheme_hash_get(mrn->nomarshal_ht, glob_id); - if (!rename && mrn->plus_kernel) { - rename = scheme_hash_get(krn->ht, glob_id); - nominal = mrn->plus_kernel_nominal_source; - } get_names_done = 0; if (!rename) { EXPLAIN(fprintf(stderr, "%d in pes\n", depth)); @@ -4231,6 +4215,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, /* match; set mresult, which is used in the case of no lexical capture: */ mresult_skipped = skipped; + + mresult_insp = NULL; if (SCHEME_BOXP(rename)) { /* This should only happen for mappings from free_id_renames */ @@ -4244,9 +4230,14 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } mresult = SCHEME_CDR(mresult); } else { - if (SCHEME_PAIRP(rename)) + if (SCHEME_PAIRP(rename)) { mresult = SCHEME_CAR(rename); - else + if (is_rename_inspector_info(mresult)) { + mresult_insp = mresult; + rename = SCHEME_CDR(rename); + mresult = SCHEME_CAR(rename); + } + } else mresult = rename; if (modidx_shift_from) @@ -4314,6 +4305,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (!get_names[5]) { get_names[5] = get_names[3]; } + get_names[6] = mresult_insp; } if (modidx_shift_from && !no_shift) { @@ -4686,8 +4678,6 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ rename = scheme_hash_get(mrn->ht, glob_id); if (!rename && mrn->nomarshal_ht) rename = scheme_hash_get(mrn->nomarshal_ht, glob_id); - if (!rename && mrn->plus_kernel) - rename = scheme_hash_get(krn->ht, glob_id); if (!rename) result = search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1, 0, NULL); @@ -4780,7 +4770,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ if (SCHEME_PAIRP(renames)) { /* Has a relevant-looking free-id mapping. Give up on the "fast" traversal. */ - Scheme_Object *modname, *names[6]; + Scheme_Object *modname, *names[7]; int rib_dep; names[0] = NULL; @@ -4788,6 +4778,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ names[3] = scheme_make_integer(0); names[4] = NULL; names[5] = NULL; + names[6] = NULL; modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, free_id_recur); if (rib_dep) @@ -4888,7 +4879,8 @@ Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *free_id_recur, Scheme_Object **src_phase_index, /* phase level of import from nominal modidx */ Scheme_Object **nominal_src_phase, /* phase level of export from nominal modidx */ Scheme_Object **lex_env, - int *_sealed) + int *_sealed, + Scheme_Object **insp) /* If module bound, result is module idx, and a is set to source name. If lexically bound, result is scheme_undefined, a is unchanged, and nominal_name is NULL or a free_id=? renamed id. @@ -4904,6 +4896,7 @@ Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *free_id_recur, names[3] = scheme_make_integer(0); names[4] = NULL; names[5] = NULL; + names[6] = NULL; modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, free_id_recur); @@ -4928,6 +4921,8 @@ Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *free_id_recur, *src_phase_index = names[4]; if (nominal_src_phase) *nominal_src_phase = names[5]; + if (insp) + *insp = names[6]; return modname; } } else { @@ -5427,7 +5422,7 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) Scheme_Object *src_phase_index; Scheme_Object *nominal_src_phase; Scheme_Object *lex_env = NULL; - Scheme_Object *vec, *phase; + Scheme_Object *vec, *phase, *insp; Scheme_Hash_Table *free_id_recur; phase = SCHEME_CDR(id); @@ -5439,7 +5434,7 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) bind = scheme_stx_module_name(free_id_recur, &id, phase, &nominal_modidx, &nominal_name, &mod_phase, &src_phase_index, &nominal_src_phase, - &lex_env, NULL); + &lex_env, NULL, &insp); release_recur_table(free_id_recur); if (SCHEME_SYMBOLP(nom2)) @@ -5452,7 +5447,8 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) else if (SAME_OBJ(bind, scheme_undefined)) return CONS(nominal_name, lex_env); else { - vec = scheme_make_vector(7, NULL); + vec = scheme_make_vector(8, NULL); + vec->type = scheme_free_id_info_type; SCHEME_VEC_ELS(vec)[0] = bind; SCHEME_VEC_ELS(vec)[1] = id; SCHEME_VEC_ELS(vec)[2] = nominal_modidx; @@ -5460,6 +5456,7 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) SCHEME_VEC_ELS(vec)[4] = mod_phase; SCHEME_VEC_ELS(vec)[5] = src_phase_index; SCHEME_VEC_ELS(vec)[6] = nominal_src_phase; + SCHEME_VEC_ELS(vec)[7] = (insp ? insp : scheme_false); return vec; } } @@ -6211,7 +6208,15 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, for (i = ht->size, j = 0; i--; ) { if (ht->vals[i]) { SCHEME_VEC_ELS(l)[j++] = ht->keys[i]; - SCHEME_VEC_ELS(l)[j++] = ht->vals[i]; + fil = ht->vals[i]; + if (SCHEME_PAIRP(fil) && is_rename_inspector_info(SCHEME_CAR(fil))) { + /* use 1 or 2 to indicate inspector info */ + if (SCHEME_PAIRP(SCHEME_CAR(fil))) + fil = CONS(scheme_make_integer(2), SCHEME_CDR(fil)); + else + fil = CONS(scheme_make_integer(1), SCHEME_CDR(fil)); + } + SCHEME_VEC_ELS(l)[j++] = fil; } } @@ -6258,10 +6263,6 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, l = CONS(mrn->set_identity, l); l = CONS((mrn->kind == mzMOD_RENAME_MARKED) ? scheme_true : scheme_false, l); l = CONS(mrn->phase, l); - if (mrn->plus_kernel) { - l = CONS(scheme_true,l); - /* FIXME: plus-kernel nominal omitted */ - } local_key = scheme_marshal_lookup(mt, a); if (local_key) @@ -6784,7 +6785,7 @@ static int ok_phase_index(Scheme_Object *o) { static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Table *ht, int lex_ok) { int count, i; - Scheme_Object *key, *p; + Scheme_Object *key, *p0, *p; if (!SCHEME_VECTORP(a)) return_NULL; count = SCHEME_VEC_SIZE(a); @@ -6792,10 +6793,22 @@ static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Tabl for (i = 0; i < count; i+= 2) { key = SCHEME_VEC_ELS(a)[i]; - p = SCHEME_VEC_ELS(a)[i+1]; + p0 = SCHEME_VEC_ELS(a)[i+1]; if (!SCHEME_SYMBOLP(key)) return_NULL; + p = p0; + if (SCHEME_PAIRP(p) && SCHEME_INTP(SCHEME_CAR(p))) { + /* reconstruct inspector info */ + Scheme_Object *insp; + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + if (!SAME_OBJ(scheme_make_integer(1), SCHEME_CAR(p))) { + insp = CONS(scheme_make_inspector(insp), insp); + } + p = SCHEME_CDR(p0); + p0 = CONS(insp, p); + } + if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { /* Ok */ } else if (SCHEME_PAIRP(p)) { @@ -6869,7 +6882,7 @@ static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Tabl } else return_NULL; - scheme_hash_set(ht, key, p); + scheme_hash_set(ht, key, p0); } return scheme_true; @@ -6963,9 +6976,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, v = SCHEME_CDR(v); if (!SCHEME_SYMBOLP(v) && !SCHEME_FALSEP(v)) return_NULL; - } else if (SCHEME_VECTORP(v)) { - if (SCHEME_VEC_SIZE(v) != 7) - return_NULL; + } else if (SAME_TYPE(SCHEME_TYPE(v), scheme_free_id_info_type)) { if (!SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[0]) || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[1]) || !SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[2]) @@ -7000,7 +7011,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, Scheme_Object *mns; Module_Renames *mrn; Scheme_Object *p, *key; - int plus_kernel, kind; + int kind; Scheme_Object *phase, *set_identity; if (!SCHEME_PAIRP(a)) return_NULL; @@ -7008,10 +7019,8 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, /* Convert list to rename table: */ if (SAME_OBJ(SCHEME_CAR(a), scheme_true)) { - plus_kernel = 1; - a = SCHEME_CDR(a); - } else - plus_kernel = 0; + scheme_signal_error("leftover plus-kernel"); + } if (!SCHEME_PAIRP(a)) return_NULL; phase = SCHEME_CAR(a); @@ -7031,7 +7040,6 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, a = SCHEME_CDR(a); mrn = (Module_Renames *)scheme_make_module_rename(phase, kind, NULL); - mrn->plus_kernel = plus_kernel; mrn->set_identity = set_identity; if (!SCHEME_PAIRP(a)) return_NULL; @@ -8498,6 +8506,7 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar &src_phase_index, &nominal_src_phase, NULL, + NULL, NULL); if (!m) @@ -8771,6 +8780,47 @@ Scheme_Object *scheme_explode_syntax(Scheme_Object *stx, Scheme_Hash_Table *ht) /**********************************************************************/ +static Scheme_Object *write_free_id_info_prefix(Scheme_Object *obj) +{ + Scheme_Object *vec; + int i; + + vec = scheme_make_vector(8, NULL); + for (i = 0; i < 8; i++) { + SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i]; + } + if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) + SCHEME_VEC_ELS(vec)[7] = scheme_true; + + return vec; +} + +static Scheme_Object *read_free_id_info_prefix(Scheme_Object *obj) +{ + Scheme_Object *vec, *insp; + int i; + + if (!SCHEME_VECTORP(obj) + || (SCHEME_VEC_SIZE(obj) != 8)) + return NULL; + + vec = scheme_make_vector(8, NULL); + for (i = 0; i < 8; i++) { + SCHEME_VEC_ELS(vec)[i] = SCHEME_VEC_ELS(obj)[i]; + } + + if (SCHEME_TRUEP(SCHEME_VEC_ELS(vec)[7])) { + insp = scheme_get_param(scheme_current_config(), MZCONFIG_CODE_INSPECTOR); + SCHEME_VEC_ELS(vec)[7] = insp; + } + + vec->type = scheme_free_id_info_type; + + return vec; +} + +/**********************************************************************/ + #ifdef MZ_PRECISE_GC START_XFORM_SKIP; @@ -8786,6 +8836,7 @@ static void register_traversers(void) GC_REG_TRAV(scheme_wrap_chunk_type, mark_wrapchunk); GC_REG_TRAV(scheme_certifications_type, mark_cert); GC_REG_TRAV(scheme_lexical_rib_type, lex_rib); + GC_REG_TRAV(scheme_free_id_info_type, mark_free_id_info); } END_XFORM_SKIP; diff --git a/src/mzscheme/src/stypes.h b/src/mzscheme/src/stypes.h index 047b103b70..1cb9de0bcc 100644 --- a/src/mzscheme/src/stypes.h +++ b/src/mzscheme/src/stypes.h @@ -167,84 +167,85 @@ enum { scheme_module_phase_exports_type, /* 149 */ scheme_logger_type, /* 150 */ scheme_log_reader_type, /* 151 */ + scheme_free_id_info_type, /* 152 */ #ifdef MZTAG_REQUIRED - _scheme_last_normal_type_, /* 152 */ + _scheme_last_normal_type_, /* 153 */ - scheme_rt_weak_array, /* 153 */ + scheme_rt_weak_array, /* 154 */ - scheme_rt_comp_env, /* 154 */ - scheme_rt_constant_binding, /* 155 */ - scheme_rt_resolve_info, /* 156 */ - scheme_rt_optimize_info, /* 157 */ - scheme_rt_compile_info, /* 158 */ - scheme_rt_cont_mark, /* 159 */ - scheme_rt_saved_stack, /* 160 */ - scheme_rt_reply_item, /* 161 */ - scheme_rt_closure_info, /* 162 */ - scheme_rt_overflow, /* 163 */ - scheme_rt_overflow_jmp, /* 164 */ - scheme_rt_meta_cont, /* 165 */ - scheme_rt_dyn_wind_cell, /* 166 */ - scheme_rt_dyn_wind_info, /* 167 */ - scheme_rt_dyn_wind, /* 168 */ - scheme_rt_dup_check, /* 169 */ - scheme_rt_thread_memory, /* 170 */ - scheme_rt_input_file, /* 171 */ - scheme_rt_input_fd, /* 172 */ - scheme_rt_oskit_console_input, /* 173 */ - scheme_rt_tested_input_file, /* 174 */ - scheme_rt_tested_output_file, /* 175 */ - scheme_rt_indexed_string, /* 176 */ - scheme_rt_output_file, /* 177 */ - scheme_rt_load_handler_data, /* 178 */ - scheme_rt_pipe, /* 179 */ - scheme_rt_beos_process, /* 180 */ - scheme_rt_system_child, /* 181 */ - scheme_rt_tcp, /* 182 */ - scheme_rt_write_data, /* 183 */ - scheme_rt_tcp_select_info, /* 184 */ - scheme_rt_namespace_option, /* 185 */ - scheme_rt_param_data, /* 186 */ - scheme_rt_will, /* 187 */ - scheme_rt_struct_proc_info, /* 188 */ - scheme_rt_linker_name, /* 189 */ - scheme_rt_param_map, /* 190 */ - scheme_rt_finalization, /* 191 */ - scheme_rt_finalizations, /* 192 */ - scheme_rt_cpp_object, /* 193 */ - scheme_rt_cpp_array_object, /* 194 */ - scheme_rt_stack_object, /* 195 */ - scheme_rt_preallocated_object, /* 196 */ - scheme_thread_hop_type, /* 197 */ - scheme_rt_srcloc, /* 198 */ - scheme_rt_evt, /* 199 */ - scheme_rt_syncing, /* 200 */ - scheme_rt_comp_prefix, /* 201 */ - scheme_rt_user_input, /* 202 */ - scheme_rt_user_output, /* 203 */ - scheme_rt_compact_port, /* 204 */ - scheme_rt_read_special_dw, /* 205 */ - scheme_rt_regwork, /* 206 */ - scheme_rt_buf_holder, /* 207 */ - scheme_rt_parameterization, /* 208 */ - scheme_rt_print_params, /* 209 */ - scheme_rt_read_params, /* 210 */ - scheme_rt_native_code, /* 211 */ - scheme_rt_native_code_plus_case, /* 212 */ - scheme_rt_jitter_data, /* 213 */ - scheme_rt_module_exports, /* 214 */ - scheme_rt_delay_load_info, /* 215 */ - scheme_rt_marshal_info, /* 216 */ - scheme_rt_unmarshal_info, /* 217 */ - scheme_rt_runstack, /* 218 */ - scheme_rt_sfs_info, /* 219 */ - scheme_rt_validate_clearing, /* 220 */ - scheme_rt_rb_node, /* 221 */ + scheme_rt_comp_env, /* 155 */ + scheme_rt_constant_binding, /* 156 */ + scheme_rt_resolve_info, /* 157 */ + scheme_rt_optimize_info, /* 158 */ + scheme_rt_compile_info, /* 159 */ + scheme_rt_cont_mark, /* 160 */ + scheme_rt_saved_stack, /* 161 */ + scheme_rt_reply_item, /* 162 */ + scheme_rt_closure_info, /* 163 */ + scheme_rt_overflow, /* 164 */ + scheme_rt_overflow_jmp, /* 165 */ + scheme_rt_meta_cont, /* 166 */ + scheme_rt_dyn_wind_cell, /* 167 */ + scheme_rt_dyn_wind_info, /* 168 */ + scheme_rt_dyn_wind, /* 169 */ + scheme_rt_dup_check, /* 170 */ + scheme_rt_thread_memory, /* 171 */ + scheme_rt_input_file, /* 172 */ + scheme_rt_input_fd, /* 173 */ + scheme_rt_oskit_console_input, /* 174 */ + scheme_rt_tested_input_file, /* 175 */ + scheme_rt_tested_output_file, /* 176 */ + scheme_rt_indexed_string, /* 177 */ + scheme_rt_output_file, /* 178 */ + scheme_rt_load_handler_data, /* 179 */ + scheme_rt_pipe, /* 180 */ + scheme_rt_beos_process, /* 181 */ + scheme_rt_system_child, /* 182 */ + scheme_rt_tcp, /* 183 */ + scheme_rt_write_data, /* 184 */ + scheme_rt_tcp_select_info, /* 185 */ + scheme_rt_namespace_option, /* 186 */ + scheme_rt_param_data, /* 187 */ + scheme_rt_will, /* 188 */ + scheme_rt_struct_proc_info, /* 189 */ + scheme_rt_linker_name, /* 190 */ + scheme_rt_param_map, /* 191 */ + scheme_rt_finalization, /* 192 */ + scheme_rt_finalizations, /* 193 */ + scheme_rt_cpp_object, /* 194 */ + scheme_rt_cpp_array_object, /* 195 */ + scheme_rt_stack_object, /* 196 */ + scheme_rt_preallocated_object, /* 197 */ + scheme_thread_hop_type, /* 198 */ + scheme_rt_srcloc, /* 199 */ + scheme_rt_evt, /* 200 */ + scheme_rt_syncing, /* 201 */ + scheme_rt_comp_prefix, /* 202 */ + scheme_rt_user_input, /* 203 */ + scheme_rt_user_output, /* 204 */ + scheme_rt_compact_port, /* 205 */ + scheme_rt_read_special_dw, /* 206 */ + scheme_rt_regwork, /* 207 */ + scheme_rt_buf_holder, /* 208 */ + scheme_rt_parameterization, /* 209 */ + scheme_rt_print_params, /* 210 */ + scheme_rt_read_params, /* 211 */ + scheme_rt_native_code, /* 212 */ + scheme_rt_native_code_plus_case, /* 213 */ + scheme_rt_jitter_data, /* 214 */ + scheme_rt_module_exports, /* 215 */ + scheme_rt_delay_load_info, /* 216 */ + scheme_rt_marshal_info, /* 217 */ + scheme_rt_unmarshal_info, /* 218 */ + scheme_rt_runstack, /* 219 */ + scheme_rt_sfs_info, /* 220 */ + scheme_rt_validate_clearing, /* 221 */ + scheme_rt_rb_node, /* 222 */ #endif - scheme_place_type, /* 222 */ - scheme_engine_type, /* 223 */ + scheme_place_type, /* 223 */ + scheme_engine_type, /* 224 */ _scheme_last_type_ }; From 733a9567c0934e1e7972dc3cdd19fa51fdb5167c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 24 Apr 2009 15:09:21 +0000 Subject: [PATCH 75/79] document r6rs non-conformance: several #% names are implicited imported svn: r14594 --- collects/r6rs/scribblings/r6rs.scrbl | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/collects/r6rs/scribblings/r6rs.scrbl b/collects/r6rs/scribblings/r6rs.scrbl index d7977b8ff6..7a1206a377 100644 --- a/collects/r6rs/scribblings/r6rs.scrbl +++ b/collects/r6rs/scribblings/r6rs.scrbl @@ -360,6 +360,11 @@ several known ways: instead of @|r6rs| bindings. In particular, @scheme[=>], @scheme[else], @scheme[_], and @scheme[...] are not bound.} + @item{Bindings for @schemeidfont{#%datum}, @schemeidfont{#%app}, + @schemeidfont{#%top}, and @schemeidfont{#%top-interaction} are + imported into every library and program, and at every phase + level for which the library or program has imports.} + ] From 6df0ac6f5163ff82130cfeee1f2c9d0990eaed13 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 24 Apr 2009 15:49:24 +0000 Subject: [PATCH 76/79] fix accidental commit of debugging printf svn: r14595 --- collects/compiler/zo-parse.ss | 1 - 1 file changed, 1 deletion(-) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 538e065a4c..bb76d1fb8b 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -729,7 +729,6 @@ [read-accept-dot #t] [read-accept-infix-dot #t] [read-accept-quasiquote #t]) - (printf "~s\n" s) (read (open-input-bytes s))))] [(reference) (make-primval (read-compact-number cp))] From 2439b4cb75c3b92179d764fb7dbe6f8c932a0f9f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 24 Apr 2009 17:34:49 +0000 Subject: [PATCH 77/79] fix zo-parse problem with graphs in literal data svn: r14596 --- collects/compiler/zo-parse.ss | 14 ++++++++++++-- 1 file changed, 12 insertions(+), 2 deletions(-) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index bb76d1fb8b..6660c45300 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -729,7 +729,7 @@ [read-accept-dot #t] [read-accept-infix-dot #t] [read-accept-quasiquote #t]) - (read (open-input-bytes s))))] + (read/recursive (open-input-bytes s))))] [(reference) (make-primval (read-compact-number cp))] [(small-list small-proper-list) @@ -837,7 +837,17 @@ [(box) (box (read-compact cp))] [(quote) - (make-reader-graph (read-compact cp))] + (make-reader-graph + ;; Nested escapes need to share graph references. So get inside the + ;; read where `read/recursive' can be used: + (let ([rt (current-readtable)]) + (parameterize ([current-readtable (make-readtable + #f + #\x 'terminating-macro + (lambda args + (parameterize ([current-readtable rt]) + (read-compact cp))))]) + (read (open-input-bytes #"x")))))] [(symref) (let* ([l (read-compact-number cp)] [v (vector-ref (cport-symtab cp) l)]) From b741225899a60aed4dc335c365970a7bb69efa58 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 24 Apr 2009 18:27:12 +0000 Subject: [PATCH 78/79] fix wong-sized local array svn: r14597 --- src/mzscheme/src/stxobj.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 0046a1e5f0..a012173ea4 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -4888,7 +4888,7 @@ Scheme_Object *scheme_stx_module_name(Scheme_Hash_Table *free_id_recur, and nominal_name is NULL or a free_id=? renamed id. */ { if (SCHEME_STXP(*a)) { - Scheme_Object *modname, *names[6]; + Scheme_Object *modname, *names[7]; int rib_dep; names[0] = NULL; From 4bc8e35d394f846501ae54c70a169c511711cea3 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Fri, 24 Apr 2009 21:22:24 +0000 Subject: [PATCH 79/79] add example for subtract-in svn: r14599 --- collects/scribblings/reference/syntax.scrbl | 24 ++++++++++++++++++++- 1 file changed, 23 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 16b47a92b2..7d5c629922 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -998,7 +998,29 @@ monkey @defform[(subtract-in require-spec subtracted-spec ...)]{ Like @scheme[require-spec], but omitting those imports that would be - imported by one of the @scheme[subtracted-spec]s.} + imported by one of the @scheme[subtracted-spec]s. + +@defexamples[#:eval (syntax-eval) +(module earth scheme + (provide land sea air) + (define land 1) + (define sea 2) + (define air 3)) + +(module mars scheme + (provide aliens) + (define aliens 4)) + +(module solar-system scheme + (require 'earth 'mars) + (provide (all-from-out 'earth) + (all-from-out 'mars))) + +(require scheme/require) +(require (subtract-in 'solar-system 'earth)) +land +aliens +]} @defform[(filtered-in proc-expr require-spec)]{ The @scheme[proc-expr] should evaluate to a single-argument procedure, which is applied on