Undo the following revisions:
r3839 r3825 r3823 r3821 r3820 (undo only the changes in drscheme/private/debug.ss) r3792 r3791 They will be re-done after v352 is released svn: r3843
This commit is contained in:
Eli Barzilay
parent
b718411a75
commit
5099b078c6
|
|
@ -189,17 +189,14 @@ profile todo:
|
|||
[(begin expr ...)
|
||||
;; Found a `begin', so expand/eval each contained
|
||||
;; expression one at a time
|
||||
(let ([exprs (syntax->list #'(expr ...))]
|
||||
[last-one (list (void))])
|
||||
(let i-loop ()
|
||||
(cond
|
||||
[(null? exprs)
|
||||
(apply values last-one)]
|
||||
[else
|
||||
(let ([exp (car exprs)])
|
||||
(set! exprs (cdr exprs))
|
||||
(set! last-one (call-with-values (λ () (loop exp)) list))
|
||||
(i-loop))])))]
|
||||
(let i-loop ([exprs (syntax->list #'(expr ...))]
|
||||
[last-one (list (void))])
|
||||
(cond
|
||||
[(null? exprs) (apply values last-one)]
|
||||
[else (i-loop (cdr exprs)
|
||||
(call-with-values
|
||||
(λ () (loop (car exprs)))
|
||||
list))]))]
|
||||
[_else
|
||||
;; Not `begin', so proceed with normal expand and eval
|
||||
(let* ([annotated (annotate-top (expand-syntax top-e) #f)])
|
||||
|
|
|
|||
|
|
@ -172,11 +172,10 @@ TODO
|
|||
;; the highlight must be set after the error message, because inserting into the text resets
|
||||
;; the highlighting.
|
||||
(define (drscheme-error-display-handler msg exn)
|
||||
(let* ([cut-stack (if (and (exn? exn)
|
||||
(main-user-eventspace-thread?))
|
||||
(cut-out-top-of-stack exn)
|
||||
'())]
|
||||
[srclocs-stack (filter values (map cdr cut-stack))]
|
||||
(let* ([srclocs-stack
|
||||
(if (exn? exn)
|
||||
(filter values (map cdr (continuation-mark-set->context (exn-continuation-marks exn))))
|
||||
'())]
|
||||
[stack
|
||||
(filter
|
||||
values
|
||||
|
|
@ -192,16 +191,6 @@ TODO
|
|||
(if (null? stack)
|
||||
'()
|
||||
(list (car srclocs-stack))))])
|
||||
|
||||
;; for use in debugging the stack trace stuff
|
||||
#;
|
||||
(when (exn? exn)
|
||||
(print-struct #t)
|
||||
(for-each
|
||||
(λ (frame) (printf " ~s\n" frame))
|
||||
(continuation-mark-set->context (exn-continuation-marks exn)))
|
||||
(printf "\n"))
|
||||
|
||||
(unless (null? stack)
|
||||
(drscheme:debug:print-bug-to-stderr msg stack))
|
||||
(for-each drscheme:debug:display-srcloc-in-error src-locs)
|
||||
|
|
@ -220,79 +209,27 @@ TODO
|
|||
src-locs
|
||||
(filter (λ (x) (is-a? (car x) text%)) stack)))))))))
|
||||
|
||||
(define (main-user-eventspace-thread?)
|
||||
(let ([rep (current-rep)])
|
||||
(and rep
|
||||
(eq? (eventspace-handler-thread (send rep get-user-eventspace))
|
||||
(current-thread)))))
|
||||
|
||||
(define (cut-out-top-of-stack exn)
|
||||
(let ([initial-stack (continuation-mark-set->context (exn-continuation-marks exn))])
|
||||
(let loop ([stack (reverse initial-stack)]
|
||||
[hit-2? #f])
|
||||
(cond
|
||||
[(null? stack)
|
||||
(unless (exn:break? exn)
|
||||
;; give break exn's a free pass on this one.
|
||||
;; sometimes they get raised in a funny place.
|
||||
;; (see call-with-break-parameterization below)
|
||||
(fprintf (current-error-port) "ACK! didn't find drscheme's stackframe when filtering\n"))
|
||||
initial-stack]
|
||||
[else
|
||||
(let ([top (car stack)])
|
||||
(cond
|
||||
[(is-cut? top 'cut-stacktrace-above-here1)
|
||||
(if hit-2?
|
||||
(reverse (cdr stack))
|
||||
(begin
|
||||
(fprintf (current-error-port) "ACK! found 1 without 2\n")
|
||||
initial-stack))]
|
||||
[(is-cut? top 'cut-stacktrace-above-here2)
|
||||
(if hit-2?
|
||||
(reverse (cdr stack))
|
||||
(loop (cdr stack) #t))]
|
||||
[else
|
||||
(loop (cdr stack) hit-2?)]))]))))
|
||||
|
||||
;; is-cut? : any symbol -> boolean
|
||||
;; determines if this stack entry is really
|
||||
(define (is-cut? top sym)
|
||||
(and (pair? top)
|
||||
(let* ([fn-name (car top)]
|
||||
[srcloc (cdr top)]
|
||||
[source (and srcloc (srcloc-source srcloc))])
|
||||
(and (eq? fn-name sym)
|
||||
(path? source)
|
||||
(let loop ([path source]
|
||||
[pieces '(#"rep.ss" #"private" #"drscheme" #"collects")])
|
||||
(cond
|
||||
[(null? pieces) #t]
|
||||
[else
|
||||
(let-values ([(base name dir?) (split-path path)])
|
||||
(and (equal? (path->bytes name) (car pieces))
|
||||
(loop base (cdr pieces))))]))))))
|
||||
|
||||
;; drscheme-error-value->string-handler : TST number -> string
|
||||
(define (drscheme-error-value->string-handler x n)
|
||||
(let ([port (open-output-string)])
|
||||
|
||||
;; using a string port here means no snips allowed,
|
||||
;; even though this string may eventually end up
|
||||
;; displayed in a place where snips are allowed.
|
||||
(print x port)
|
||||
|
||||
(let* ([long-string (get-output-string port)])
|
||||
(close-output-port port)
|
||||
(if (<= (string-length long-string) n)
|
||||
long-string
|
||||
(let ([short-string (substring long-string 0 n)]
|
||||
[trim 3])
|
||||
(unless (n . <= . trim)
|
||||
(let loop ([i trim])
|
||||
(unless (i . <= . 0)
|
||||
(string-set! short-string (- n i) #\.)
|
||||
(loop (sub1 i)))))
|
||||
short-string)))))
|
||||
;; drscheme-error-value->string-handler : TST number -> string
|
||||
(define (drscheme-error-value->string-handler x n)
|
||||
(let ([port (open-output-string)])
|
||||
|
||||
;; using a string port here means no snips allowed,
|
||||
;; even though this string may eventually end up
|
||||
;; displayed in a place where snips are allowed.
|
||||
(print x port)
|
||||
|
||||
(let* ([long-string (get-output-string port)])
|
||||
(close-output-port port)
|
||||
(if (<= (string-length long-string) n)
|
||||
long-string
|
||||
(let ([short-string (substring long-string 0 n)]
|
||||
[trim 3])
|
||||
(unless (n . <= . trim)
|
||||
(let loop ([i trim])
|
||||
(unless (i . <= . 0)
|
||||
(string-set! short-string (- n i) #\.)
|
||||
(loop (sub1 i)))))
|
||||
short-string)))))
|
||||
|
||||
(define drs-bindings-keymap (make-object keymap:aug-keymap%))
|
||||
|
||||
|
|
@ -1023,8 +960,7 @@ TODO
|
|||
(λ () ; =User=, =Handler=, =No-Breaks=
|
||||
(let* ([settings (current-language-settings)]
|
||||
[lang (drscheme:language-configuration:language-settings-language settings)]
|
||||
[settings (drscheme:language-configuration:language-settings-settings settings)]
|
||||
[dummy-value (box #f)])
|
||||
[settings (drscheme:language-configuration:language-settings-settings settings)])
|
||||
(set! get-sexp/syntax/eof
|
||||
(if complete-program?
|
||||
(send lang front-end/complete-program port settings user-teachpack-cache)
|
||||
|
|
@ -1045,33 +981,19 @@ TODO
|
|||
(current-error-escape-k (λ ()
|
||||
(set! cleanup? #t)
|
||||
(k (void)))))
|
||||
|
||||
(λ ()
|
||||
(let loop ()
|
||||
(let ([sexp/syntax/eof
|
||||
;; this named thunk & application helps drscheme know to cut
|
||||
;; off part of the stack trace. (too bad not all of it ...)
|
||||
((rec cut-stacktrace-above-here1
|
||||
(λ ()
|
||||
(begin0 (get-sexp/syntax/eof)
|
||||
(void)))))])
|
||||
(let ([sexp/syntax/eof (get-sexp/syntax/eof)])
|
||||
(unless (eof-object? sexp/syntax/eof)
|
||||
(call-with-break-parameterization
|
||||
(get-user-break-parameterization)
|
||||
;; a break exn may be raised right at this point,
|
||||
;; in which case the stack won't be in a trimmable state
|
||||
;; so we don't complain (above) when we find an untrimmable
|
||||
;; break exn.
|
||||
(λ ()
|
||||
(call-with-values
|
||||
(rec cut-stacktrace-above-here1
|
||||
(λ ()
|
||||
(begin0 (eval-syntax sexp/syntax/eof)
|
||||
(void))))
|
||||
(λ ()
|
||||
(eval-syntax sexp/syntax/eof))
|
||||
(λ x (display-results x)))))
|
||||
(loop))))
|
||||
(set! cleanup? #t))
|
||||
|
||||
(λ ()
|
||||
(current-error-escape-k saved-error-escape-k)
|
||||
(when cleanup?
|
||||
|
|
@ -1152,11 +1074,10 @@ TODO
|
|||
(current-error-escape-k (λ ()
|
||||
(set! cleanup? #t)
|
||||
(k (void)))))
|
||||
(rec cut-stacktrace-above-here2
|
||||
(λ ()
|
||||
(thunk)
|
||||
; Breaks must be off!
|
||||
(set! cleanup? #t)))
|
||||
(λ ()
|
||||
(thunk)
|
||||
; Breaks must be off!
|
||||
(set! cleanup? #t))
|
||||
(λ ()
|
||||
(current-error-escape-k saved-error-escape-k)
|
||||
(when cleanup?
|
||||
|
|
@ -1391,12 +1312,12 @@ TODO
|
|||
(break-enabled break-ok?)
|
||||
(unless ub?
|
||||
(set! user-break-enabled 'user)))
|
||||
(λ ()
|
||||
(primitive-dispatch-handler eventspace))
|
||||
(λ ()
|
||||
(unless ub?
|
||||
(set! user-break-enabled (break-enabled)))
|
||||
(break-enabled #f))))
|
||||
(λ ()
|
||||
(primitive-dispatch-handler eventspace))
|
||||
(λ ()
|
||||
(unless ub?
|
||||
(set! user-break-enabled (break-enabled)))
|
||||
(break-enabled #f))))
|
||||
; Cleanup after dispatch
|
||||
(λ ()
|
||||
;; in principle, the line below might cause
|
||||
|
|
|
|||
|
|
@ -748,18 +748,18 @@
|
|||
(send dc draw-polygon points dx dy))
|
||||
(when (named-link? from-link)
|
||||
(let*-values ([(text-len h d v) (send dc get-text-extent (link-label from-link))]
|
||||
[(theta) (angle (- to-pt from-pt))]
|
||||
[(cx cy) (values (/ (+ from-x to-x) 2)
|
||||
(/ (+ from-y to-y) 2))]
|
||||
|
||||
;; ax, ay is the location of the beginning of the string
|
||||
;; offset from cx,cy by enough to make the string centered
|
||||
;; (but it doesn't seem to be quite right; i'm not sure why)
|
||||
[(ax ay) (values (- cx (* 1/2 text-len (cos theta)))
|
||||
(- cy (* 1/2 text-len (sin theta))))]
|
||||
|
||||
[(x y) (values (- ax (* h (cos theta)))
|
||||
(- ay (* h (sin theta))))]
|
||||
[(x) (/ (+ from-x to-x) 2)]
|
||||
[(y) (/ (+ from-y to-y) 2)]
|
||||
[(theta) (- (angle (- to-pt from-pt)))]
|
||||
[(flip?) #f #;(negative? (- to-x from-x))]
|
||||
[(text-angle)
|
||||
(if flip?
|
||||
(+ theta pi)
|
||||
theta)]
|
||||
[(x)
|
||||
(- x (* h (cos (if flip? (+ (- theta) pi) (- theta)))))]
|
||||
[(y)
|
||||
(- y (* h (sin (if flip? (+ (- theta) pi) (- theta)))))]
|
||||
[(sqr) (λ (x) (* x x))])
|
||||
(when (> (sqrt (+ (sqr (- to-x from-x)) (sqr (- to-y from-y)))) text-len)
|
||||
(send dc draw-text (link-label from-link)
|
||||
|
|
@ -767,7 +767,7 @@
|
|||
(+ dy y)
|
||||
#f
|
||||
0
|
||||
(- theta)))
|
||||
text-angle))
|
||||
))]))))))))
|
||||
(define (named-link? l) (link-label l))
|
||||
|
||||
|
|
|
|||
|
|
@ -552,15 +552,9 @@ add struct contracts for immutable structs?
|
|||
;; builds a begin expression for the entire contract and provide
|
||||
;; the first syntax object is used for source locations
|
||||
(define (code-for-one-id/new-name stx id ctrct user-rename-id)
|
||||
(with-syntax ([id-rename (a:mangle-id provide-stx
|
||||
"provide/contract-id"
|
||||
(or user-rename-id id))]
|
||||
[contract-id (a:mangle-id provide-stx
|
||||
"provide/contract-contract-id"
|
||||
(or user-rename-id id))]
|
||||
[pos-module-source (a:mangle-id provide-stx
|
||||
"provide/contract-pos-module-source"
|
||||
(or user-rename-id id))]
|
||||
(with-syntax ([id-rename (a:mangle-id provide-stx "provide/contract-id" id)]
|
||||
[contract-id (a:mangle-id provide-stx "provide/contract-contract-id" id)]
|
||||
[pos-module-source (a:mangle-id provide-stx "provide/contract-pos-module-source" id)]
|
||||
[pos-stx (datum->syntax-object provide-stx 'here)]
|
||||
[id id]
|
||||
[ctrct (syntax-property ctrct 'inferred-name id)]
|
||||
|
|
@ -827,40 +821,28 @@ add struct contracts for immutable structs?
|
|||
[else
|
||||
(loop ho-contracts (cons arg fc/predicates) (cdr args))]))]))])
|
||||
(let ([flat-contracts (map (λ (x) (if (flat-contract? x)
|
||||
x
|
||||
(flat-contract x)))
|
||||
fc/predicates)]
|
||||
[pred
|
||||
(cond
|
||||
[(null? fc/predicates) not]
|
||||
[else
|
||||
(let loop ([fst (car fc/predicates)]
|
||||
[rst (cdr fc/predicates)])
|
||||
(let ([fst-pred (if (flat-contract? fst)
|
||||
((flat-get fst) fst)
|
||||
fst)])
|
||||
(cond
|
||||
[(null? rst) fst-pred]
|
||||
[else
|
||||
(let ([r (loop (car rst) (cdr rst))])
|
||||
(λ (x) (or (fst-pred x) (r x))))])))])])
|
||||
x
|
||||
(flat-contract x)))
|
||||
fc/predicates)])
|
||||
(cond
|
||||
[(null? ho-contracts)
|
||||
(make-flat-or/c pred flat-contracts)]
|
||||
(make-flat-or/c flat-contracts)]
|
||||
[(null? (cdr ho-contracts))
|
||||
(make-or/c pred flat-contracts (car ho-contracts))]
|
||||
(make-or/c flat-contracts (car ho-contracts))]
|
||||
[else
|
||||
(make-multi-or/c flat-contracts ho-contracts)])))]))
|
||||
|
||||
(define-struct/prop or/c (pred flat-ctcs ho-ctc)
|
||||
(define-struct/prop or/c (flat-ctcs ho-ctc)
|
||||
((proj-prop (λ (ctc)
|
||||
(let ([c-proc ((proj-get (or/c-ho-ctc ctc)) (or/c-ho-ctc ctc))]
|
||||
[pred (or/c-pred ctc)])
|
||||
[predicates (map (λ (x) ((flat-get x) x))
|
||||
(or/c-flat-ctcs ctc))])
|
||||
(λ (pos-blame neg-blame src-info orig-str)
|
||||
(let ([partial-contract (c-proc pos-blame neg-blame src-info orig-str)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(pred val) val]
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(partial-contract val)])))))))
|
||||
|
||||
|
|
@ -888,6 +870,49 @@ add struct contracts for immutable structs?
|
|||
this-ctcs
|
||||
that-ctcs))))))))
|
||||
|
||||
(define (make-multi-or/c-proj pos-proj-get)
|
||||
(λ (ctc)
|
||||
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
|
||||
[c-procs (map (λ (x) ((pos-proj-get x) x)) ho-contracts)]
|
||||
[first-order-checks (map (λ (x) ((first-order-get x) x)) ho-contracts)]
|
||||
[predicates (map (λ (x) ((flat-get x) x))
|
||||
(multi-or/c-flat-ctcs ctc))])
|
||||
(λ (pos src-info orig-str)
|
||||
(let ([partial-contracts (map (λ (c-proc) (c-proc pos src-info orig-str)) c-procs)])
|
||||
(λ (val)
|
||||
(cond
|
||||
[(ormap (λ (pred) (pred val)) predicates)
|
||||
val]
|
||||
[else
|
||||
(let loop ([checks first-order-checks]
|
||||
[procs partial-contracts]
|
||||
[contracts ho-contracts]
|
||||
[candidate-proc #f]
|
||||
[candidate-contract #f])
|
||||
(cond
|
||||
[(null? checks)
|
||||
(if candidate-proc
|
||||
(candidate-proc val)
|
||||
(raise-contract-error val src-info pos orig-str
|
||||
"none of the branches of the or/c matched"))]
|
||||
[((car checks) val)
|
||||
(if candidate-proc
|
||||
(error 'or/c "two arguments, ~s and ~s, might both match ~s"
|
||||
(contract-name candidate-contract)
|
||||
(contract-name (car contracts))
|
||||
val)
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
(car procs)
|
||||
(car contracts)))]
|
||||
[else
|
||||
(loop (cdr checks)
|
||||
(cdr procs)
|
||||
(cdr contracts)
|
||||
candidate-proc
|
||||
candidate-contract)]))])))))))
|
||||
|
||||
(define (multi-or/c-proj ctc)
|
||||
(let* ([ho-contracts (multi-or/c-ho-ctcs ctc)]
|
||||
[c-procs (map (λ (x) ((proj-get x) x)) ho-contracts)]
|
||||
|
|
@ -936,8 +961,8 @@ add struct contracts for immutable structs?
|
|||
(apply build-compound-type-name
|
||||
'or/c
|
||||
(append
|
||||
(multi-or/c-flat-ctcs ctc)
|
||||
(reverse (multi-or/c-ho-ctcs ctc))))))
|
||||
(multi-or/c-ho-ctcs ctc)
|
||||
(multi-or/c-flat-ctcs ctc)))))
|
||||
(first-order-prop
|
||||
(λ (ctc)
|
||||
(let ([flats (map (λ (x) ((flat-get x) x)) (multi-or/c-flat-ctcs ctc))]
|
||||
|
|
@ -962,7 +987,7 @@ add struct contracts for immutable structs?
|
|||
this-ctcs
|
||||
that-ctcs))))))))
|
||||
|
||||
(define-struct/prop flat-or/c (pred flat-ctcs)
|
||||
(define-struct/prop flat-or/c (flat-ctcs)
|
||||
((proj-prop flat-proj)
|
||||
(name-prop (λ (ctc)
|
||||
(apply build-compound-type-name
|
||||
|
|
@ -977,7 +1002,11 @@ add struct contracts for immutable structs?
|
|||
(andmap contract-stronger?
|
||||
this-ctcs
|
||||
that-ctcs))))))
|
||||
(flat-prop (λ (ctc) (flat-or/c-pred ctc)))))
|
||||
(flat-prop (λ (ctc)
|
||||
(let ([preds
|
||||
(map (λ (x) ((flat-get x) x))
|
||||
(flat-or/c-flat-ctcs ctc))])
|
||||
(λ (x) (ormap (λ (p?) (p? x)) preds)))))))
|
||||
|
||||
(define false/c
|
||||
(flat-named-contract
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@
|
|||
("profj" "libs" "java" "util")))
|
||||
(define textbook-pls
|
||||
(list (list '("htdch-icon.png" "profj")
|
||||
"How to Design Classes"
|
||||
"How to Design Class Hierarchies"
|
||||
(string-constant experimental-languages)
|
||||
"ProfessorJ"
|
||||
"Beginner"))))
|
||||
|
|
|
|||
|
|
@ -1081,7 +1081,7 @@ the settings above should match r5rs
|
|||
(clear-definitions drs)
|
||||
(for-each fw:test:keystroke
|
||||
(string->list
|
||||
"(define (f n)\n(cond ((zero? n) (list))\n(else (cons n (f (- n 1))))))\n(f 200)"))
|
||||
"(define (f n)\n(cond ((zero? n) null)\n(else (cons n (f (- n 1))))))\n(f 200)"))
|
||||
(test "Constructor" #f #f
|
||||
(case-lambda
|
||||
[(x) (not (member #\newline (string->list x)))]
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
|
|
@ -4243,7 +4243,7 @@
|
|||
;; (at the end, becuase they are slow w/out .zo files)
|
||||
;;
|
||||
|
||||
(test/spec-passed
|
||||
(test/spec-passed
|
||||
'provide/contract1
|
||||
'(let ()
|
||||
(eval '(module contract-test-suite1 mzscheme
|
||||
|
|
@ -4417,19 +4417,6 @@
|
|||
[s-a 3])))
|
||||
(eval '(require n))))
|
||||
|
||||
(test/spec-passed
|
||||
'provide/contract11
|
||||
'(parameterize ([current-namespace (make-namespace)])
|
||||
(eval '(module m mzscheme
|
||||
(require (lib "contract.ss"))
|
||||
(define x 1)
|
||||
(provide/contract [rename x y integer?]
|
||||
[rename x z integer?])))
|
||||
(eval '(module n mzscheme
|
||||
(require m)
|
||||
(+ y z)))
|
||||
(eval '(require n))))
|
||||
|
||||
;; this test is broken, not sure why
|
||||
#|
|
||||
(test/spec-failed
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user