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

Rackety

Browse Source
This commit is contained in:
Robby Findler 2014-07-13 22:31:22 -05:00
parent 8f0c0f5405
commit c7dd72ab4b
1 changed files with 297 additions and 285 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

560
pkgs/drracket-pkgs/drracket/drracket/private/debug.rkt
View File

@ -315,7 +315,8 @@ profile todo:
(oe annotated))])))))]) (oe annotated))])))))])
debug-tool-eval-handler)) debug-tool-eval-handler))
;; make-debug-error-display-handler : (string (union TST exn) -> void) -> string (union TST exn) -> void ;; make-debug-error-display-handler :
;; (string (union TST exn) -> void) -> string (union TST exn) -> void
;; adds in the bug icon, if there are contexts to display ;; adds in the bug icon, if there are contexts to display
(define (make-debug-error-display-handler orig-error-display-handler) (define (make-debug-error-display-handler orig-error-display-handler)
(define (debug-error-display-handler msg exn) (define (debug-error-display-handler msg exn)
@ -346,8 +347,10 @@ profile todo:
(map cdr (filter cdr (cut-stack-at-checkpoint exn))) (map cdr (filter cdr (cut-stack-at-checkpoint exn)))
'())] '())]
[port-name-matches-cache (make-hasheq)] [port-name-matches-cache (make-hasheq)]
[stack1-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache)) stack1)] [stack1-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache))
[stack2-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache)) stack2)] stack1)]
[stack2-editions (map (λ (x) (srcloc->edition/pair defs ints x port-name-matches-cache))
stack2)]
[src-locs (cond [src-locs (cond
[(exn:srclocs? exn) [(exn:srclocs? exn)
((exn:srclocs-accessor exn) exn)] ((exn:srclocs-accessor exn) exn)]
@ -358,8 +361,9 @@ profile todo:
[(pair? stack2) [(pair? stack2)
(list (car stack2))] (list (car stack2))]
[else '()])] [else '()])]
[src-locs-edition (and (pair? src-locs) [src-locs-edition
(srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))]) (and (pair? src-locs)
(srcloc->edition/pair defs ints (car src-locs) port-name-matches-cache))])
(print-planet-icon-to-stderr exn) (print-planet-icon-to-stderr exn)
(unless (exn:fail:user? exn) (unless (exn:fail:user? exn)
@ -506,7 +510,8 @@ profile todo:
(install-pkg (install-pkg
tlw tlw
(lambda (thunk) (lambda (thunk)
(parameterize ([error-display-handler drracket:init:original-error-display-handler]) (parameterize ([error-display-handler
drracket:init:original-error-display-handler])
(thunk))) (thunk)))
#:package-to-offer pkg))) #:package-to-offer pkg)))
(eprintf " ") (eprintf " ")
@ -526,7 +531,11 @@ profile todo:
(when note% (when note%
(let ([note (new note%)]) (let ([note (new note%)])
(send note set-stacks cms1 cms2) (send note set-stacks cms1 cms2)
(send note set-callback (λ (snp) (show-backtrace-window/edition-pairs/two msg cms1 editions1 cms2 editions2 defs ints))) (send note set-callback
(λ (snp) (show-backtrace-window/edition-pairs/two msg
cms1 editions1
cms2 editions2
defs ints)))
(write-special note (current-error-port)) (write-special note (current-error-port))
(display #\space (current-error-port))))))) (display #\space (current-error-port)))))))
@ -810,7 +819,10 @@ profile todo:
(cond (cond
[(and (< n (vector-length di-vec)) [(and (< n (vector-length di-vec))
(< n (+ index how-many-at-once))) (< n (+ index how-many-at-once)))
(show-frame ec text (vector-ref di-vec n) (vector-ref editions-vec n) (vector-ref skip-counts n) defs ints) (show-frame ec text (vector-ref di-vec n)
(vector-ref editions-vec n)
(vector-ref skip-counts n)
defs ints)
(loop (+ n 1))] (loop (+ n 1))]
[else [else
(set! index n)])) (set! index n)]))
@ -881,7 +893,8 @@ profile todo:
[else [else
(define di2 (car dis)) (define di2 (car dis))
(define edition2 (car editions)) (define edition2 (car editions))
(define-values (res-dis res-editions skip-counts) (loop di2 edition2 (cdr dis) (cdr editions))) (define-values (res-dis res-editions skip-counts)
(loop di2 edition2 (cdr dis) (cdr editions)))
(if (equal? di di2) (if (equal? di di2)
(values res-dis res-editions (cons (+ (car skip-counts) 1) (cdr skip-counts))) (values res-dis res-editions (cons (+ (car skip-counts) 1) (cdr skip-counts)))
(values (cons di res-dis) (values (cons di res-dis)
@ -959,66 +972,66 @@ profile todo:
;; -> ;; ->
;; void ;; void
(define (insert-context editor-canvas text file start span defs ints) (define (insert-context editor-canvas text file start span defs ints)
(let-values ([(from-text close-text) (define-values (from-text close-text)
(cond (cond
[(and ints (send ints port-name-matches? file)) [(and ints (send ints port-name-matches? file))
(values ints void)] (values ints void)]
[(and defs (send defs port-name-matches? file)) [(and defs (send defs port-name-matches? file))
(values defs void)] (values defs void)]
[(path? file) [(path? file)
(let ([file (with-handlers ((exn:fail? (λ (x) #f))) (define file
(normal-case-path (normalize-path file)))]) (with-handlers ((exn:fail? (λ (x) #f)))
(if file (normal-case-path (normalize-path file))))
(cond (cond
[(send (group:get-the-frame-group) [(not file) (values #f void)]
locate-file [(send (group:get-the-frame-group)
file) locate-file
=> file)
(λ (frame) =>
(cond (λ (frame)
[(is-a? frame drracket:unit:frame%) (cond
(let loop ([tabs (send frame get-tabs)]) [(is-a? frame drracket:unit:frame%)
(cond (let loop ([tabs (send frame get-tabs)])
[(null? tabs) (values #f void)] (cond
[else [(null? tabs) (values #f void)]
(let* ([tab (car tabs)] [else
[defs (send tab get-defs)]) (let* ([tab (car tabs)]
(if (with-handlers ((exn:fail? (λ (x) #f))) [defs (send tab get-defs)])
(equal? (normalize-path (normal-case-path (send defs get-filename))) (if (with-handlers ((exn:fail? (λ (x) #f)))
file)) (equal?
(values defs void) (normalize-path (normal-case-path (send defs get-filename)))
(loop (cdr tabs))))]))] file))
[(is-a? frame frame:editor<%>) (values defs void)
(values (send frame get-editor) void)] (loop (cdr tabs))))]))]
[else (values #f void)]))] [(is-a? frame frame:editor<%>)
[(path? file) (values (send frame get-editor) void)]
(let ([text (new text:basic%)]) [else (values #f void)]))]
(if (send text load-file file) [(path? file)
(values text (let ([text (new text:basic%)])
(λ () (send text on-close))) (if (send text load-file file)
(values #f (λ () (void)))))] (values text
[else (λ () (send text on-close)))
(values #f void)]) (values #f (λ () (void)))))]
(values #f void)))] [else
[(is-a? file editor<%>) (values #f void)])]
(values file void)] [(is-a? file editor<%>)
[else (values file void)]
(values #f void)])]) [else (values #f void)]))
(when from-text (when from-text
(let* ([finish (+ start span -1)] (let* ([finish (+ start span -1)]
[context-text (copy/highlight-text from-text start finish)]) [context-text (copy/highlight-text from-text start finish)])
(send context-text lock #t) (send context-text lock #t)
(send context-text hide-caret #t) (send context-text hide-caret #t)
(send text insert " ") (send text insert " ")
(let ([snip (make-object editor-snip% context-text)]) (let ([snip (make-object editor-snip% context-text)])
(send snip use-style-background #t) (send snip use-style-background #t)
(send editor-canvas add-wide-snip snip) (send editor-canvas add-wide-snip snip)
(let ([p (send text last-position)]) (let ([p (send text last-position)])
(send text insert snip p p) (send text insert snip p p)
(send text insert #\newline) (send text insert #\newline)
(when (preferences:get 'framework:white-on-black?) (when (preferences:get 'framework:white-on-black?)
(send text change-style white-on-black-style p (+ p 1)))))) (send text change-style white-on-black-style p (+ p 1))))))
(close-text)))) (close-text)))
(define white-on-black-style (make-object style-delta%)) (define white-on-black-style (make-object style-delta%))
(define stupid-internal-define-syntax1 (send white-on-black-style set-delta-foreground "white")) (define stupid-internal-define-syntax1 (send white-on-black-style set-delta-foreground "white"))
@ -1308,7 +1321,8 @@ profile todo:
[span (syntax-span stx)]) [span (syntax-span stx)])
(and pos (and pos
span span
(hash-ref! port-name-cache src (λ () (send (get-defs) port-name-matches? src))) (hash-ref! port-name-cache src
(λ () (send (get-defs) port-name-matches? src)))
(list (mcar covered?) (list (mcar covered?)
(make-srcloc (get-defs) #f #f pos span))))))))] (make-srcloc (get-defs) #f #f pos span))))))))]
@ -1563,7 +1577,10 @@ profile todo:
(prof-info-time info))))))) (prof-info-time info)))))))
(void)) (void))
(define (get-color-value/pref val max-val drracket:profile:low-color drracket:profile:high-color drracket:profile:scale) (define (get-color-value/pref val max-val
drracket:profile:low-color
drracket:profile:high-color
drracket:profile:scale)
(let* ([adjust (let* ([adjust
(case drracket:profile:scale (case drracket:profile:scale
[(sqrt) sqrt] [(sqrt) sqrt]
@ -1834,70 +1851,68 @@ profile todo:
(unless profile-gui-constructed? (unless profile-gui-constructed?
(set! profile-gui-constructed? #t) (set! profile-gui-constructed? #t)
(begin-container-sequence) (begin-container-sequence)
(let () (set! profile-info-panel (instantiate horizontal-panel% ()
(define _2 (parent profile-info-outer-panel)
(set! profile-info-panel (instantiate horizontal-panel% () (stretchable-height #f)))
(parent profile-info-outer-panel) (define profile-left-side (instantiate vertical-panel% (profile-info-panel)))
(stretchable-height #f)))) (set! profile-info-editor-canvas
(define profile-left-side (instantiate vertical-panel% (profile-info-panel))) (new canvas:basic%
(define _3 (parent profile-info-panel)
(set! profile-info-editor-canvas (new canvas:basic% (editor (send (get-current-tab) get-profile-info-text))))
(parent profile-info-panel) (define profile-message (instantiate message% ()
(editor (send (get-current-tab) get-profile-info-text))))) (label (string-constant profiling))
(define profile-message (instantiate message% () (parent profile-left-side)))
(label (string-constant profiling)) (set! profile-choice (new radio-box%
(parent profile-left-side))) (label #f)
(define _4 (parent profile-left-side)
(set! profile-choice (instantiate radio-box% () (callback
(label #f) (λ (x y)
(parent profile-left-side) (define mode
(callback (profile-selection->mode
(λ (x y) (send profile-choice get-selection)))
(let ([mode (profile-selection->mode (send profile-choice get-selection))]) (preferences:set 'drracket:profile-how-to-count mode)
(preferences:set 'drracket:profile-how-to-count mode) (send (get-current-tab) set-sort-mode mode)
(send (get-current-tab) set-sort-mode mode) (send (get-current-tab) refresh-profile)))
(send (get-current-tab) refresh-profile)))) (choices (list (string-constant profiling-time)
(choices (list (string-constant profiling-time) (string-constant profiling-number)))))
(string-constant profiling-number)))))) (send profile-choice set-selection
(define _1 (case (preferences:get 'drracket:profile-how-to-count)
(send profile-choice set-selection [(time) 0]
(case (preferences:get 'drracket:profile-how-to-count) [(count) 1]))
[(time) 0] (define update-profile-button
[(count) 1]))) (instantiate button% ()
(define update-profile-button (label (string-constant profiling-update))
(instantiate button% () (parent profile-left-side)
(label (string-constant profiling-update)) (callback
(parent profile-left-side) (λ (x y)
(callback (send (get-current-tab) refresh-profile)))))
(λ (x y) (define hide-profile-button
(send (get-current-tab) refresh-profile))))) (instantiate button% ()
(define hide-profile-button (label (string-constant profiling-hide-profile))
(instantiate button% () (parent profile-left-side)
(label (string-constant profiling-hide-profile)) (callback
(parent profile-left-side) (λ (x y)
(callback (send (get-current-tab) hide-profile)))))
(λ (x y) (send profile-choice set-selection
(send (get-current-tab) hide-profile))))) (profile-mode->selection (preferences:get 'drracket:profile-how-to-count)))
(send profile-choice set-selection
(profile-mode->selection (preferences:get 'drracket:profile-how-to-count)))
(send profile-left-side stretchable-width #f) (send profile-left-side stretchable-width #f)
(let ([wid (max (send update-profile-button get-width) (let ([wid (max (send update-profile-button get-width)
(send hide-profile-button get-width) (send hide-profile-button get-width)
(send profile-choice get-width) (send profile-choice get-width)
(send profile-message get-width))]) (send profile-message get-width))])
(send update-profile-button min-width wid) (send update-profile-button min-width wid)
(send hide-profile-button min-width wid) (send hide-profile-button min-width wid)
(send profile-choice min-width wid)) (send profile-choice min-width wid))
(send profile-left-side set-alignment 'left 'center) (send profile-left-side set-alignment 'left 'center)
;; hide profiling info initially, but reflow the container ;; hide profiling info initially, but reflow the container
;; so that the invisible children get the right size. ;; so that the invisible children get the right size.
(send this reflow-container) (send this reflow-container)
(send profile-info-outer-panel change-children (send profile-info-outer-panel change-children
(λ (l) (λ (l)
(remq profile-info-panel l)))) (remq profile-info-panel l)))
(end-container-sequence))))) (end-container-sequence)))))
(define (profile-selection->mode sel) (define (profile-selection->mode sel)
@ -1949,156 +1964,150 @@ profile todo:
(lock #f) (lock #f)
(erase) (erase)
(clear-old-results) (clear-old-results)
(let* (;; must copy them here in case the program is still running (define infos '())
;; and thus updating them. (let loop ([profile-info profile-info])
[infos '()] (cond
[_ (let loop ([profile-info profile-info]) [(null? profile-info) (void)]
(cond [else
[(null? profile-info) (void)] (let ([ht (car profile-info)])
[else (hash-for-each
(let ([ht (car profile-info)]) ht
(hash-for-each (λ (key val)
ht (when (any-info? val)
(λ (key val) (set! infos (cons (copy-prof-info val) infos))))))
(when (any-info? val) (loop (cdr profile-info))]))
(set! infos (cons (copy-prof-info val) infos))))))
(loop (cdr profile-info))]))]
;; each editor that gets some highlighting is put ;; each editor that gets some highlighting is put
;; into this table and an edit sequence is begun for it. ;; into this table and an edit sequence is begun for it.
;; after all ranges are updated, the edit sequences are all closed. ;; after all ranges are updated, the edit sequences are all closed.
[in-edit-sequence (make-hasheq)] (define in-edit-sequence (make-hasheq))
[clear-highlight void] (define clear-highlight void)
[max-value (extract-maximum infos)] (define max-value (extract-maximum infos))
[port-name-matches-cache (make-hasheq)] (define port-name-matches-cache (make-hasheq))
[show-highlight (define (show-highlight info)
(λ (info) (define expr (prof-info-expr info))
(let* ([expr (prof-info-expr info)] (define src
[src (and (syntax-source expr) (and (syntax-source expr)
definitions-text definitions-text
(hash-ref! port-name-matches-cache (hash-ref! port-name-matches-cache
(syntax-source expr) (syntax-source expr)
(λ () (send definitions-text port-name-matches? (syntax-source expr)))))] (λ () (send definitions-text port-name-matches? (syntax-source expr))))))
[pos (syntax-position expr)] (define pos (syntax-position expr))
[span (syntax-span expr)]) (define span (syntax-span expr))
(when (and (is-a? src text:basic<%>) (when (and (is-a? src text:basic<%>)
(number? pos) (number? pos)
(number? span)) (number? span))
(unless (hash-ref in-edit-sequence src (λ () #f)) (unless (hash-ref in-edit-sequence src (λ () #f))
(hash-set! in-edit-sequence src #t) (hash-set! in-edit-sequence src #t)
(send src begin-edit-sequence #t #f)) (send src begin-edit-sequence #t #f))
(let* ([color (get-color-value (let* ([color (get-color-value
(if (eq? (preferences:get 'drracket:profile-how-to-count) 'time) (if (eq? (preferences:get 'drracket:profile-how-to-count) 'time)
(prof-info-time info) (prof-info-time info)
(prof-info-num info)) (prof-info-num info))
max-value)] max-value)]
[clr (send src highlight-range (- pos 1) (+ pos span -1) color)]) [clr (send src highlight-range (- pos 1) (+ pos span -1) color)])
(let ([old-thnk clear-highlight]) (let ([old-thnk clear-highlight])
(set! clear-highlight (set! clear-highlight
(λ () (λ ()
(clr) (clr)
(old-thnk))))))))] (old-thnk)))))))
[smaller-range? (define (smaller-range? x y)
(λ (x y) (let ([x-span (syntax-span (prof-info-expr x))]
(let ([x-span (syntax-span (prof-info-expr x))] [y-span (syntax-span (prof-info-expr y))])
[y-span (syntax-span (prof-info-expr y))]) (if (and x-span y-span)
(if (and x-span y-span) (< x-span y-span)
(< x-span y-span) #f)))
#f)))]
[show-line (define (show-line info newline? highlight-line?)
(λ (info newline? highlight-line?) (let* ([expr (prof-info-expr info)]
(let* ([expr (prof-info-expr info)] [expr-src (syntax-source expr)]
[expr-src (syntax-source expr)] [count (prof-info-num info)]
[count (prof-info-num info)] [time (prof-info-time info)]
[time (prof-info-time info)] [name (prof-info-name info)])
[name (prof-info-name info)]) (when newline? (send src-loc-editor insert "\n"))
(when newline? (send src-loc-editor insert "\n")) (when highlight-line? (small-blank-line src-loc-editor))
(when highlight-line? (small-blank-line src-loc-editor)) (let ([before (send src-loc-editor last-position)])
(let ([before (send src-loc-editor last-position)]) (insert-profile-src-loc src-loc-editor expr name)
(insert-profile-src-loc src-loc-editor expr name) (let ([after (send src-loc-editor last-position)])
(let ([after (send src-loc-editor last-position)]) (cond
(cond [(string? expr-src)
[(string? expr-src) (send src-loc-editor change-style (gui-utils:get-clickback-delta) before after)
(send src-loc-editor change-style (gui-utils:get-clickback-delta) before after) (let ([after (send src-loc-editor last-position)])
(let ([after (send src-loc-editor last-position)]) (send src-loc-editor set-clickback
(send src-loc-editor set-clickback before after
before after (λ (text start end)
(λ (text start end) (open-file-and-goto-position expr-src (syntax-position expr)))))]
(open-file-and-goto-position expr-src (syntax-position expr)))))] [(is-a? expr-src editor:basic<%>)
[(is-a? expr-src editor:basic<%>) (send src-loc-editor change-style (gui-utils:get-clickback-delta) before after)
(send src-loc-editor change-style (gui-utils:get-clickback-delta) before after) (send src-loc-editor set-clickback
(send src-loc-editor set-clickback before after
before after (λ (text start end)
(λ (text start end) (let ([window (send expr-src get-top-level-window)]
(let ([window (send expr-src get-top-level-window)] [pos (syntax-position expr)])
[pos (syntax-position expr)]) (when window (send window show #t))
(when window (send window show #t)) (when pos (send expr-src set-position (- pos 1)))
(when pos (send expr-src set-position (- pos 1))) (send expr-src set-caret-owner #f 'global))))]
(send expr-src set-caret-owner #f 'global))))] [else (void)])))
[else (void)])))
(when newline? (send time-editor insert "\n")) (when newline? (send time-editor insert "\n"))
(when highlight-line? (small-blank-line time-editor)) (when highlight-line? (small-blank-line time-editor))
(send time-editor insert (format "~a" time)) (send time-editor insert (format "~a" time))
(send time-editor set-paragraph-alignment (send time-editor last-paragraph) 'right) (send time-editor set-paragraph-alignment (send time-editor last-paragraph) 'right)
(when newline? (send count-editor insert "\n")) (when newline? (send count-editor insert "\n"))
(when highlight-line? (small-blank-line count-editor)) (when highlight-line? (small-blank-line count-editor))
(send count-editor insert (format "~a" count)) (send count-editor insert (format "~a" count))
(send count-editor set-paragraph-alignment (send count-editor last-paragraph) 'right)))] (send count-editor set-paragraph-alignment (send count-editor last-paragraph) 'right)))
[bigger-value? (define (bigger-value? x y)
(λ (x y) (let ([sel (if (eq? 'count (preferences:get 'drracket:profile-how-to-count))
(let ([sel (if (eq? 'count (preferences:get 'drracket:profile-how-to-count)) prof-info-num
prof-info-num prof-info-time)])
prof-info-time)]) (> (sel x) (sel y))))
(> (sel x) (sel y))))]
[cleanup-editor (define (cleanup-editor ed)
(λ (ed) (let* ([ed-admin (send ed get-admin)]
(let* ([ed-admin (send ed get-admin)] [snip (send ed-admin get-snip)]
[snip (send ed-admin get-snip)] [bl (box 0)]
[bl (box 0)] [br (box 0)])
[br (box 0)]) (get-snip-location snip bl #f #f)
(get-snip-location snip bl #f #f) (get-snip-location snip br #f #t)
(get-snip-location snip br #f #t) (let ([w (+ (- (unbox br) (unbox bl)) 4)])
(let ([w (+ (- (unbox br) (unbox bl)) 4)]) (send ed set-max-width w)
(send ed set-max-width w) (send ed set-min-width w)))
(send ed set-min-width w))) (send ed hide-caret #t)
(send ed hide-caret #t) (send ed lock #t))
(send ed lock #t))]
[top-infos (top 100 (sort infos bigger-value?))]) (define top-infos (top 100 (sort infos bigger-value?)))
(for-each show-highlight top-infos) (for-each show-highlight top-infos)
(initialize-editors) (initialize-editors)
(let loop ([infos top-infos] (let loop ([infos top-infos]
[newline? #f] [newline? #f]
[highlight-counter 0]) [highlight-counter 0])
(cond (cond
[(null? infos) (void)] [(null? infos) (void)]
[else [else
(show-line (car infos) newline? (and newline? (zero? highlight-counter))) (show-line (car infos) newline? (and newline? (zero? highlight-counter)))
(loop (cdr infos) #t (modulo (+ highlight-counter 1) 2))])) (loop (cdr infos) #t (modulo (+ highlight-counter 1) 2))]))
(cleanup-editor count-editor) (cleanup-editor count-editor)
(cleanup-editor time-editor) (cleanup-editor time-editor)
(cleanup-editor src-loc-editor) (cleanup-editor src-loc-editor)
(hash-for-each (hash-for-each
in-edit-sequence in-edit-sequence
(λ (key val) (λ (key val)
(send key end-edit-sequence))) (send key end-edit-sequence)))
(set! clear-old-results (set! clear-old-results
(λ () (λ ()
(hash-for-each (hash-for-each
in-edit-sequence in-edit-sequence
(λ (key val) (send key begin-edit-sequence #t #f))) (λ (key val) (send key begin-edit-sequence #t #f)))
(clear-highlight) (clear-highlight)
(hash-for-each (hash-for-each
in-edit-sequence in-edit-sequence
(λ (key val) (send key end-edit-sequence))) (λ (key val) (send key end-edit-sequence)))
(set! clear-old-results void)))) (set! clear-old-results void)))
(lock #t) (lock #t)
(end-edit-sequence) (end-edit-sequence)
(let ([canvas (get-canvas)]) (let ([canvas (get-canvas)])
@ -2311,7 +2320,10 @@ profile todo:
(let loop ([n 0]) (let loop ([n 0])
(when (n . <= . w) (when (n . <= . w)
(send pen set-color (send pen set-color
(get-color-value/pref n w drracket:profile:low-color drracket:profile:high-color drracket:profile:scale)) (get-color-value/pref n w
drracket:profile:low-color
drracket:profile:high-color
drracket:profile:scale))
(send dc set-pen pen) (send dc set-pen pen)
(send dc draw-line n 0 n h) (send dc draw-line n 0 n h)
(send dc set-pen dummy-pen) (send dc set-pen dummy-pen)