got check syntax mostly working again
svn: r7815
This commit is contained in:
Robby Findler
parent
fbda5f9996
commit
5af14c4902
|
|
@ -154,8 +154,7 @@
|
|||
(frame%))
|
||||
|
||||
(define-signature drscheme:eval^
|
||||
(editor->port-name
|
||||
expand-program
|
||||
(expand-program
|
||||
expand-program/multiple
|
||||
traverse-program/multiple
|
||||
build-user-eventspace/custodian
|
||||
|
|
|
|||
|
|
@ -23,16 +23,6 @@
|
|||
[prefix drscheme:unit: drscheme:unit^])
|
||||
(export drscheme:eval^)
|
||||
|
||||
(define (editor->port-name txt)
|
||||
(let* ([b (box #f)]
|
||||
[n (send txt get-filename b)])
|
||||
(cond
|
||||
[(or (unbox b) (not n))
|
||||
(if (is-a? txt drscheme:unit:definitions-text<%>)
|
||||
(send txt get-port-name-identifier)
|
||||
'unknown)]
|
||||
[else n])))
|
||||
|
||||
(define (traverse-program/multiple language-settings
|
||||
init
|
||||
kill-termination)
|
||||
|
|
@ -54,7 +44,7 @@
|
|||
[start (drscheme:language:text/pos-start input)]
|
||||
[end (drscheme:language:text/pos-end input)]
|
||||
[text-port (open-input-text-editor text start end values
|
||||
(editor->port-name text))])
|
||||
(send text get-port-name))])
|
||||
(port-count-lines! text-port)
|
||||
(let* ([line (send text position-paragraph start)]
|
||||
[column (- start (send text paragraph-start-position line))]
|
||||
|
|
|
|||
|
|
@ -91,9 +91,7 @@ module browser threading seems wrong.
|
|||
get-tab
|
||||
get-next-settings
|
||||
after-set-next-settings
|
||||
set-needs-execution-message
|
||||
get-port-name-identifier
|
||||
port-name-matches?))
|
||||
set-needs-execution-message))
|
||||
|
||||
(define-struct teachpack-callbacks
|
||||
(get-names ;; settings -> (listof string)
|
||||
|
|
@ -404,21 +402,6 @@ module browser threading seems wrong.
|
|||
(define/public (get-tab) tab)
|
||||
(define/public (set-tab t) (set! tab t))
|
||||
|
||||
(define port-name-identifier #f)
|
||||
(define/public (get-port-name-identifier)
|
||||
(unless port-name-identifier
|
||||
(set! port-name-identifier (gensym 'unsaved-editor)))
|
||||
port-name-identifier)
|
||||
(define/public (port-name-matches? id)
|
||||
(let ([filename (get-filename)])
|
||||
(or (and (path? id)
|
||||
(path? filename)
|
||||
(equal? (normal-case-path (normalize-path (get-filename)))
|
||||
(normal-case-path (normalize-path id))))
|
||||
(and (symbol? port-name-identifier)
|
||||
(symbol? id)
|
||||
(equal? port-name-identifier id)))))
|
||||
|
||||
(inherit get-surrogate set-surrogate)
|
||||
(define/public (set-current-mode mode)
|
||||
(let ([surrogate (drscheme:modes:mode-surrogate mode)])
|
||||
|
|
@ -2078,7 +2061,7 @@ module browser threading seems wrong.
|
|||
|
||||
(let ([start 0])
|
||||
(send definitions-text split-snip start)
|
||||
(let* ([name (drscheme:eval:editor->port-name definitions-text)]
|
||||
(let* ([name (send definitions-text get-port-name)]
|
||||
[text-port (open-input-text-editor definitions-text start 'end values name)])
|
||||
(port-count-lines! text-port)
|
||||
(let* ([line (send definitions-text position-paragraph start)]
|
||||
|
|
|
|||
|
|
@ -18,17 +18,18 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
|
||||
(require string-constants/string-constant
|
||||
(lib "unit.ss")
|
||||
(lib "contract.ss")
|
||||
(lib "tool.ss" "drscheme")
|
||||
(lib "class.ss")
|
||||
(lib "list.ss")
|
||||
(lib "toplevel.ss" "syntax")
|
||||
(lib "boundmap.ss" "syntax")
|
||||
(lib "bitmap-label.ss" "mrlib")
|
||||
(prefix-in drscheme:arrow: (lib "arrow.ss" "drscheme"))
|
||||
(prefix-in fw: (lib "framework.ss" "framework"))
|
||||
(lib "mred.ss" "mred"))
|
||||
scheme/unit
|
||||
scheme/contract
|
||||
scheme/class
|
||||
drscheme/tool
|
||||
mzlib/list
|
||||
syntax/toplevel
|
||||
syntax/boundmap
|
||||
mrlib/bitmap-label
|
||||
(prefix-in drscheme:arrow: drscheme/arrow)
|
||||
(prefix-in fw: framework/framework)
|
||||
mred/mred
|
||||
(for-syntax scheme/base))
|
||||
(provide tool@)
|
||||
|
||||
(define o (current-output-port))
|
||||
|
|
@ -236,10 +237,10 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
;; compare-bindings : (list text number number) (list text number number) -> boolean
|
||||
(define (compare-bindings l1 l2)
|
||||
(let ([start-text (first l1)]
|
||||
[start-left (second l1)]
|
||||
[end-text (first l2)]
|
||||
[end-left (second l2)])
|
||||
(let ([start-text (list-ref l1 0)]
|
||||
[start-left (list-ref l1 1)]
|
||||
[end-text (list-ref l2 0)]
|
||||
[end-left (list-ref l2 1)])
|
||||
(let-values ([(sx sy) (find-dc-location start-text start-left)]
|
||||
[(ex ey) (find-dc-location end-text end-left)])
|
||||
(cond
|
||||
|
|
@ -666,7 +667,7 @@ If the namespace does not, they are colored the unbound color.
|
|||
[arrows (filter arrow? vec-ents)]
|
||||
[def-links (filter def-link? vec-ents)]
|
||||
[var-arrows (filter var-arrow? arrows)]
|
||||
[add-menus (map cdr (filter cons? vec-ents))])
|
||||
[add-menus (map cdr (filter pair? vec-ents))])
|
||||
(unless (null? arrows)
|
||||
(make-object menu-item%
|
||||
(string-constant cs-tack/untack-arrow)
|
||||
|
|
@ -772,8 +773,8 @@ If the namespace does not, they are colored the unbound color.
|
|||
[(null? arrows) (jump-to (car orig-arrows))]
|
||||
[else (let ([arrow (car arrows)])
|
||||
(cond
|
||||
[(and (object=? txt (first arrow))
|
||||
(<= (second arrow) pos (third arrow)))
|
||||
[(and (object=? txt (list-ref arrow 0))
|
||||
(<= (list-ref arrow 1) pos (list-ref arrow 2)))
|
||||
(jump-to (if (null? (cdr arrows))
|
||||
(car orig-arrows)
|
||||
(cadr arrows)))]
|
||||
|
|
@ -781,9 +782,9 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
;; jump-to : (list text number number) -> void
|
||||
(define/private (jump-to to-arrow)
|
||||
(let ([end-text (first to-arrow)]
|
||||
[end-pos-left (second to-arrow)]
|
||||
[end-pos-right (third to-arrow)])
|
||||
(let ([end-text (list-ref to-arrow 0)]
|
||||
[end-pos-left (list-ref to-arrow 1)]
|
||||
[end-pos-right (list-ref to-arrow 2)])
|
||||
(send end-text set-position end-pos-left end-pos-right)
|
||||
(send end-text set-caret-owner #f 'global)))
|
||||
|
||||
|
|
@ -1596,8 +1597,8 @@ If the namespace does not, they are colored the unbound color.
|
|||
(add-id varrefs sexp))]
|
||||
[_
|
||||
(begin
|
||||
#;
|
||||
(printf "unknown stx: ~e (datum: ~e) (source: ~e)~n"
|
||||
|
||||
(printf "unknown stx: ~e datum: ~e source: ~e\n"
|
||||
sexp
|
||||
(and (syntax? sexp)
|
||||
(syntax->datum sexp))
|
||||
|
|
@ -2274,10 +2275,25 @@ If the namespace does not, they are colored the unbound color.
|
|||
|
||||
;; find-source : definitions-text source -> editor or false
|
||||
(define (find-source-editor stx)
|
||||
(printf "looking for ~s ~s\n" (syntax-source stx) (syntax->datum stx))
|
||||
(let ([defs-text (get-defs-text)])
|
||||
(and defs-text
|
||||
(send defs-text port-name-matches? (syntax-source stx))
|
||||
defs-text)))
|
||||
(let txt-loop ([text defs-text])
|
||||
(cond
|
||||
[(and (is-a? text fw:text:basic<%>)
|
||||
(send text port-name-matches? (syntax-source stx)))
|
||||
text]
|
||||
[else
|
||||
(let snip-loop ([snip (send text find-first-snip)])
|
||||
(cond
|
||||
[(not snip)
|
||||
#f]
|
||||
[(and (is-a? snip editor-snip%)
|
||||
(send snip get-editor))
|
||||
(or (txt-loop (send snip get-editor))
|
||||
(snip-loop (send snip next)))]
|
||||
[else
|
||||
(snip-loop (send snip next))]))])))))
|
||||
|
||||
;; get-defs-text : -> text or false
|
||||
(define (get-defs-text)
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
(require (lib "string-constant.ss" "string-constants")
|
||||
(lib "class.ss")
|
||||
(lib "match.ss")
|
||||
scheme/file
|
||||
"sig.ss"
|
||||
"../gui-utils.ss"
|
||||
"../preferences.ss"
|
||||
|
|
@ -53,7 +54,9 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
get-fixed-style
|
||||
set-styles-fixed
|
||||
move/copy-to-edit
|
||||
initial-autowrap-bitmap))
|
||||
initial-autowrap-bitmap
|
||||
get-port-name
|
||||
port-name-matches?))
|
||||
|
||||
(define basic-mixin
|
||||
(mixin (editor:basic<%> (class->interface text%)) (basic<%>)
|
||||
|
|
@ -63,7 +66,27 @@ WARNING: printf is rebound in the body of the unit to always
|
|||
delete find-snip invalidate-bitmap-cache
|
||||
set-file-format get-file-format
|
||||
get-style-list is-modified? change-style set-modified
|
||||
position-location get-extent)
|
||||
position-location get-extent get-filename)
|
||||
|
||||
(define port-name-identifier #f)
|
||||
(define/public (get-port-name)
|
||||
(let* ([b (box #f)]
|
||||
[n (get-filename b)])
|
||||
(cond
|
||||
[(or (unbox b) (not n))
|
||||
(unless port-name-identifier
|
||||
(set! port-name-identifier (gensym 'unsaved-editor)))
|
||||
port-name-identifier]
|
||||
[else n])))
|
||||
(define/public (port-name-matches? id)
|
||||
(let ([filename (get-filename)])
|
||||
(or (and (path? id)
|
||||
(path? filename)
|
||||
(equal? (normal-case-path (normalize-path (get-filename)))
|
||||
(normal-case-path (normalize-path id))))
|
||||
(and (symbol? port-name-identifier)
|
||||
(symbol? id)
|
||||
(equal? port-name-identifier id)))))
|
||||
|
||||
(define highlight-pen #f)
|
||||
(define highlight-brush #f)
|
||||
|
|
|
|||
|
|
@ -23,7 +23,7 @@
|
|||
"read: bad syntax: empty scheme box")
|
||||
txt line col pos 1)))
|
||||
(let ([stx (read-syntax
|
||||
text
|
||||
(send text get-port-name)
|
||||
(open-input-text-editor text 0 (send text last-position)))])
|
||||
(when (eof-object? stx)
|
||||
(raise-read-error
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user