From 90c5019e537363bfd8b65d31a4e31ef24fa2c839 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 25 Sep 2025 19:58:37 -0500 Subject: [PATCH] make check syntax investigate more identifiers Specifically identifiers that it finds inside origin fields are treated as if they themselves were in the original program, so their orgin fields (etc) are all checked --- .../tests/check-syntax/syncheck-direct.rkt | 49 +++++++++++++++++++ .../drracket/private/syncheck/traversals.rkt | 44 ++++++++++------- 2 files changed, 74 insertions(+), 19 deletions(-) diff --git a/drracket-tool-test/tests/check-syntax/syncheck-direct.rkt b/drracket-tool-test/tests/check-syntax/syncheck-direct.rkt index 1982399b1..1da407f43 100644 --- a/drracket-tool-test/tests/check-syntax/syncheck-direct.rkt +++ b/drracket-tool-test/tests/check-syntax/syncheck-direct.rkt @@ -517,6 +517,55 @@ '((66 77) (92 95)) ;; sketchy; should we eliminate? '((85 88) (92 95)))) +(let () + (define prefix + (string-append + "#lang racket/base\n" + "(require (for-syntax racket/base))\n" + "(define-syntax (m stx)\n" + " (syntax-case stx ()\n" + " [(_ x y)\n" + " (syntax-property\n" + " #'(void)\n" + " 'disappeared-use\n" + " (syntax-property\n" + " (syntax-local-introduce #'x)\n" + " 'disappeared-use\n" + " (syntax-local-introduce #'y)))]))\n")) + + ;; drop all the arrows in the prefix, and + ;; adjust the arrows after the prefix to + ;; treat the end of the prefix as position 0. + (define (remove-prefix set) + (define new-set + + (for/set ([e (in-set set)]) + (define new + (match e + [(list (list start-left start-right) + (list end-left end-right)) + (list (list (- start-left (string-length prefix)) + (- start-right (string-length prefix))) + (list (- end-left (string-length prefix)) + (- end-right (string-length prefix))))])) + (and (0 . <= . (list-ref (list-ref new 0) 0)) + (0 . <= . (list-ref (list-ref new 0) 0)) + new))) + (set-remove new-set #f)) + + (check-equal? + (remove-prefix + (get-binding-arrows + (string-append + prefix + "\n" + "(define f 1)\n" + "(define g 1)\n" + "(m f g)\n"))) + (set '((9 10) (30 31)) + '((22 23) (32 33))))) + + ; ; ; diff --git a/drracket-tool-text-lib/drracket/private/syncheck/traversals.rkt b/drracket-tool-text-lib/drracket/private/syncheck/traversals.rkt index e103395f9..7df126888 100644 --- a/drracket-tool-text-lib/drracket/private/syncheck/traversals.rkt +++ b/drracket-tool-text-lib/drracket/private/syncheck/traversals.rkt @@ -265,20 +265,22 @@ (+ level level-of-enclosing-module))] [binders (lookup-phase-to-mapping phase-to-binders (+ level level-of-enclosing-module))] - [tops (lookup-phase-to-mapping phase-to-tops (+ level level-of-enclosing-module))] - [collect-general-info - (λ (stx) - (add-origins stx varrefs level-of-enclosing-module) - (add-disappeared-bindings stx binders sub-identifier-binding-directives varrefs - level level-of-enclosing-module mods) - (add-disappeared-uses stx varrefs sub-identifier-binding-directives - level level-of-enclosing-module mods) - (add-mouse-over-tooltips stx) - (add-sub-range-binders stx - sub-identifier-binding-directives - level - level-of-enclosing-module - mods))]) + [tops (lookup-phase-to-mapping phase-to-tops (+ level level-of-enclosing-module))]) + + (define (collect-general-info stx) + (add-origins stx varrefs level-of-enclosing-module collect-general-info) + (add-disappeared-bindings stx binders sub-identifier-binding-directives varrefs + level level-of-enclosing-module mods + collect-general-info) + (add-disappeared-uses stx varrefs sub-identifier-binding-directives + level level-of-enclosing-module mods + collect-general-info) + (add-mouse-over-tooltips stx) + (add-sub-range-binders stx + sub-identifier-binding-directives + level + level-of-enclosing-module + mods)) (define (collect-nested-general-info stx) (let loop ([stx stx]) @@ -399,7 +401,7 @@ [(set! var e) (begin (annotate-raw-keyword stx-obj varrefs level-of-enclosing-module) - (add-origins (list-ref (syntax->list stx-obj) 1) varrefs level-of-enclosing-module) + (add-origins (list-ref (syntax->list stx-obj) 1) varrefs level-of-enclosing-module collect-general-info) ;; tops are used here because a binding free use of a set!'d variable ;; is treated just the same as (#%top . x). (add-id varsets (syntax var) level-of-enclosing-module) @@ -714,7 +716,8 @@ disappeared-uses level level-of-enclosing-module - mods) + mods + collect-general-info) (define prop (syntax-property stx 'disappeared-binding)) (when prop (let loop ([prop prop]) @@ -723,7 +726,7 @@ (loop (car prop)) (loop (cdr prop))] [(identifier? prop) - (add-origins prop disappeared-uses level-of-enclosing-module) + (collect-general-info prop) (add-binders prop binders #f @@ -739,7 +742,8 @@ sub-identifier-binding-directives level level-of-enclosing-module - mods) + mods + collect-general-info) (define prop (syntax-property stx 'disappeared-use)) (when prop (let loop ([prop prop]) @@ -748,6 +752,7 @@ (loop (car prop)) (loop (cdr prop))] [(identifier? prop) + (collect-general-info prop) (add-sub-range-binders prop sub-identifier-binding-directives level @@ -1388,13 +1393,14 @@ (values cleaned-up-path rkt-submods))) ;; add-origins : syntax? id-set exact-integer? -> void -(define (add-origins stx id-set level-of-enclosing-module) +(define (add-origins stx id-set level-of-enclosing-module collect-general-info) (let loop ([ct (syntax-property stx 'origin)]) (match ct [(cons hd tl) (loop hd) (loop tl)] [(? identifier?) + (collect-general-info ct) (add-id id-set ct level-of-enclosing-module)] [_ (void)])))