diff --git a/collects/drracket/private/debug.rkt b/collects/drracket/private/debug.rkt index 6d7b865cc5..6c0e4b9f2d 100644 --- a/collects/drracket/private/debug.rkt +++ b/collects/drracket/private/debug.rkt @@ -27,7 +27,6 @@ profile todo: racket/match mrlib/include-bitmap images/compile-time - syntax/rect (for-syntax images/icons/misc images/icons/style images/icons/control images/logos) (for-syntax racket/base)) @@ -304,13 +303,9 @@ profile todo: [(pair? stack2) (list (car stack2))] [else '()])] - [srcloc-rects (cond - [(and (exn:srcloc-rects? exn) - (exn:srclocs? exn)) ;; only look at the rects when the exn has srclocs - ((exn:srcloc-rects-accessor exn) exn)] - [else #f])] [src-locs-edition (and (pair? src-locs) (srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))]) + (print-planet-icon-to-stderr exn) (unless (exn:fail:user? exn) (unless (exn:fail:syntax? exn) @@ -331,12 +326,9 @@ profile todo: (λ () ;; need to make sure that the user's eventspace is still the same ;; and still running here? - (send ints highlight-errors - src-locs - (if (null? stack1) - stack2 - stack1) - srcloc-rects))))))) + (send ints highlight-errors src-locs (if (null? stack1) + stack2 + stack1)))))))) (define (srcloc->edition/pair defs ints srcloc [port-name-matches-cache #f]) (let ([src (srcloc-source srcloc)]) diff --git a/collects/drracket/private/eval.rkt b/collects/drracket/private/eval.rkt index 1fb1c07f71..c8cebc7c06 100644 --- a/collects/drracket/private/eval.rkt +++ b/collects/drracket/private/eval.rkt @@ -185,8 +185,7 @@ (define to-be-copied-module-specs (list ''#%foreign '(lib "mzlib/pconvert-prop.rkt") - '(lib "planet/terse-info.rkt") - '(lib "syntax/rect.rkt"))) + '(lib "planet/terse-info.rkt"))) ;; ensure that they are all here. (for-each (λ (x) (dynamic-require x #f)) to-be-copied-module-specs) diff --git a/collects/drracket/private/rep.rkt b/collects/drracket/private/rep.rkt index dff0557957..32eaf570ba 100644 --- a/collects/drracket/private/rep.rkt +++ b/collects/drracket/private/rep.rkt @@ -23,7 +23,6 @@ TODO racket/port racket/set - syntax/rect string-constants setup/xref racket/gui/base @@ -544,66 +543,10 @@ TODO ;; error-ranges : (union false? (cons srcloc (listof srcloc))) (define error-ranges #f) (define/public (get-error-ranges) error-ranges) - (define/public (set-error-ranges srclocs [srcloc-rects #f]) - (define candidate-srclocs - (and srclocs - (not (null? srclocs)) - (cleanup-locs srclocs))) - (cond - [(and candidate-srclocs srcloc-rects) - (set! error-ranges - (apply - append - (for/list ([srcloc (in-list candidate-srclocs)]) - (define pending-range-start #f) - (define pending-range-end #f) - (define srclocs '()) - (for ([pos (in-range (srcloc-position srcloc) - (+ (srcloc-position srcloc) - (srcloc-span srcloc)))]) - (define keep-pos? - (for/or ([srcloc-rect (in-list srcloc-rects)] - #:when (equal? (srcloc-rect-source srcloc-rect) - (srcloc-source range))) - (pos-in-rect? pos srcloc-rect))) - - (when keep-pos? - (cond - [(not pending-range-start) - (set! pending-range-start pos) - (set! pending-range-end pos)] - [(= (+ pending-range-end 1) pos) - (set! pending-range-end pos)] - [else - (set! srclocs (cons (srcloc (srcloc-source srcloc) - #f #f - pending-range-start - (- pending-range-end pending-range-start)) - srclocs)) - (set! pending-range-start pos) - (set! pending-range-end pos)]))) - srclocs)))] - [else - (set! error-ranges candidate-srclocs)])) - - (define/private (pos-in-rect? pos srcloc-rect) - (define src (srcloc-rect-source srcloc-rect)) - (define height (srcloc-rect-height srcloc-rect)) - (define width (srcloc-rect-width srcloc-rect)) - (cond - [(is-a? src text%) - (define start-para (send src position-paragraph (srcloc-rect-pos srcloc-rect))) - (define para-offset (- (srcloc-rect-pos srcloc-rect) start-para)) - (let loop ([this-line-start (srcloc-rect-pos srcloc-rect)] - [y 0]) - (cond - [(= y height) #f] - [(<= this-line-start pos (+ this-line-start width)) #t] - [else - (loop (+ (send src paragraph-start-position (+ start-para y)) para-offset) - (+ y 1))]))] - [else #f])) - + (define/public (set-error-ranges ranges) + (set! error-ranges (and ranges + (not (null? ranges)) + (cleanup-locs ranges)))) (define clear-error-highlighting void) (define/public (reset-error-ranges) (set-error-ranges #f) @@ -627,12 +570,11 @@ TODO ;; =Kernel= =handler= ;; highlight-errors : (listof srcloc) ;; (union #f (listof srcloc)) - ;; (union #f (listof srcloc-rect)) ;; -> (void) - (define/public (highlight-errors raw-locs [raw-error-arrows #f] [srcloc-rects #f]) + (define/public (highlight-errors raw-locs [raw-error-arrows #f]) (clear-error-highlighting) (when definitions-text (send definitions-text set-error-arrows #f)) - (set-error-ranges raw-locs srcloc-rects) + (set-error-ranges raw-locs) (define locs (or (get-error-ranges) '())) ;; calling set-error-range cleans up the locs (define error-arrows (and raw-error-arrows (cleanup-locs raw-error-arrows))) @@ -685,7 +627,7 @@ TODO (send tlw ensure-defs-shown)))) (send first-file set-caret-owner (get-focus-snip) 'global)))) - + ;; unlike highlight-error just above, this function does not change ;; what the currently noted errors locations are, it just highlights ;; one of them. diff --git a/collects/racket/contract/private/provide.rkt b/collects/racket/contract/private/provide.rkt index d6c2b7526a..bf4ee4ae39 100644 --- a/collects/racket/contract/private/provide.rkt +++ b/collects/racket/contract/private/provide.rkt @@ -23,10 +23,14 @@ "guts.rkt" "misc.rkt" "exists.rkt" - "opt.rkt" syntax/location syntax/srcloc) +(define-syntax (verify-contract stx) + (syntax-case stx () + [(_ name x) (a:known-good-contract? #'x) #'x] + [(_ name x) #'(coerce-contract name x)])) + (define-for-syntax (self-ctor-transformer orig stx) (with-syntax ([orig orig]) (syntax-case stx () @@ -358,10 +362,12 @@ #t))] [mutator-ids (reverse (list-ref the-struct-info 4))] ;; (listof (union #f identifier)) [field-contract-ids (map (λ (field-name field-contract) - (a:mangle-id provide-stx - "provide/contract-field-contract" - field-name - struct-name)) + (if (a:known-good-contract? field-contract) + field-contract + (a:mangle-id provide-stx + "provide/contract-field-contract" + field-name + struct-name))) field-names field-contracts)] [struct:struct-name @@ -513,9 +519,11 @@ [(field-contract-id-definitions ...) (filter values (map (λ (field-contract-id field-contract) - (with-syntax ([field-contract-id field-contract-id] - [field-contract field-contract]) - #'(define field-contract-id (opt/c field-contract #:error-name provide/contract)))) + (if (a:known-good-contract? field-contract) + #f + (with-syntax ([field-contract-id field-contract-id] + [field-contract field-contract]) + #'(define field-contract-id (verify-contract 'provide/contract field-contract))))) field-contract-ids field-contracts))] [(field-contracts ...) field-contracts] @@ -715,14 +723,17 @@ (define (code-for-one-id/new-name stx id reflect-id ctrct/no-prop user-rename-id [mangle-for-maker? #f] [provide? #t]) - (let ([ex-id (or reflect-id id)] + (let ([no-need-to-check-ctrct? (a:known-good-contract? ctrct/no-prop)] + [ex-id (or reflect-id id)] [ctrct (syntax-property ctrct/no-prop 'racket/contract:contract-on-boundary (gensym 'provide/contract-boundary))]) (with-syntax ([id-rename (id-for-one-id user-rename-id reflect-id id mangle-for-maker?)] - [contract-id (a:mangle-id provide-stx - "provide/contract-contract-id" - (or user-rename-id ex-id))] + [contract-id (if no-need-to-check-ctrct? + ctrct + (a:mangle-id provide-stx + "provide/contract-contract-id" + (or user-rename-id ex-id)))] [pos-stx (datum->syntax id 'here)] [id id] [ex-id ex-id] @@ -740,10 +751,11 @@ (quasisyntax/loc stx (begin - (define contract-id - ;; let is here to give the right name. - (let ([ex-id (opt/c ctrct #:error-name provide/contract)]) - ex-id)) + #,@(if no-need-to-check-ctrct? + (list) + (list #'(define contract-id + (let ([ex-id ctrct]) ;; let is here to give the right name. + (verify-contract 'provide/contract ex-id))))) (define-syntax id-rename (make-provide/contract-transformer (quote-syntax contract-id) (a:update-loc diff --git a/collects/racket/contract/region.rkt b/collects/racket/contract/region.rkt index a7d98625c3..e7b770173d 100644 --- a/collects/racket/contract/region.rkt +++ b/collects/racket/contract/region.rkt @@ -19,14 +19,14 @@ "private/arrow.rkt" "private/base.rkt" "private/guts.rkt" - "private/misc.rkt" - "private/opt.rkt") + "private/misc.rkt") ;; These are useful for all below. -(define-syntax (add-opt-contract stx) +(define-syntax (verify-contract stx) (syntax-case stx () - [(_ x) #'(opt/c x #:error-name with-contract)])) + [(_ name x) (a:known-good-contract? #'x) #'x] + [(_ name x) #'(coerce-contract name x)])) @@ -688,14 +688,14 @@ (with-syntax ([new-stx (add-context #'(syntax-parameterize ([current-contract-region (λ (stx) #'blame-stx)]) (let-values ([(res ...) (let () . body)]) - (values (contract (add-opt-contract rc.ctc) + (values (contract (verify-contract 'with-contract rc.ctc) res blame-stx blame-id) ...))))]) (syntax/loc stx (let () (define-values (free-ctc-id ...) - (values (add-opt-contract free-ctc) ...)) + (values (verify-contract 'with-contract free-ctc) ...)) (define blame-id (current-contract-region)) (define-values () @@ -757,7 +757,7 @@ (syntax/loc stx (begin (define-values (free-ctc-id ...) - (values (add-opt-contract free-ctc) ...)) + (values (verify-contract 'with-contract free-ctc) ...)) (define blame-id (current-contract-region)) (define-values () @@ -787,7 +787,7 @@ ext-id (contract ctc-id true-p blame-stx blame-id (quote ext-id) (quote-srcloc ext-id)) ctc-id - (add-opt-contract ctc)) + (verify-contract 'with-contract ctc)) ...) blame-stx . diff --git a/collects/syntax/rect.rkt b/collects/syntax/rect.rkt deleted file mode 100644 index 2c361dcd13..0000000000 --- a/collects/syntax/rect.rkt +++ /dev/null @@ -1,24 +0,0 @@ -#lang racket/base -(provide (struct-out exn:fail:syntax/rects) - (struct-out exn:fail:read/rects) - (struct-out exn:fail:read:eof/rects) - (struct-out exn:fail:read:non-char/rects) - (struct-out srcloc-rect) - prop:exn:srcloc-rects - exn:srcloc-rects? - exn:srcloc-rects-accessor) - -(define-values (prop:exn:srcloc-rects exn:srcloc-rects? exn:srcloc-rects-accessor) - (make-struct-type-property 'exn:srcloc-rects)) - -(struct exn:fail:syntax/rects exn:fail:syntax (rects) - #:property prop:exn:srcloc-rects (λ (x) (exn:fail:syntax/rects-rects x))) - -(struct exn:fail:read/rects exn:fail:read (rects) - #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read/rects-rects x))) -(struct exn:fail:read:eof/rects exn:fail:read:eof (rects) - #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:eof/rects-rects x))) -(struct exn:fail:read:non-char/rects exn:fail:read:non-char (rects) - #:property prop:exn:srcloc-rects (λ (x) (exn:fail:read:non-char/rects-rects x))) - -(struct srcloc-rect (source pos width height) #:transparent)