Guard unquoted Jerboa vector literals
ober
48208a0acd8f425ebb23fc5c3eb3c0c94cbb82aa
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -5408,6 +5408,83 @@ (format "missing whitespace after ~a. Write (~a arg ...), not (~aarg ...)" name name name)))))))))))) +(def (skip-sharp-vector-datum content sharp-index) + (let ((n (string-length content))) + (and (< (+ sharp-index 1) n) + (char=? (string-ref content sharp-index) #\#) + (char=? (string-ref content (+ sharp-index 1)) #\() + (let loop ((i (+ sharp-index 1)) + (depth 0) + (in-string? #f) + (escape? #f) + (in-comment? #f)) + (cond + ((>= i n) #f) + (else + (let* ((ch (string-ref content i)) + (newline? (char=? ch #\newline))) + (cond + (in-comment? + (loop (+ i 1) depth #f #f + (and (not newline?) in-comment?))) + (in-string? + (cond + (escape? (loop (+ i 1) depth #t #f #f)) + ((char=? ch #\\) (loop (+ i 1) depth #t #t #f)) + ((char=? ch #\") (loop (+ i 1) depth #f #f #f)) + (else (loop (+ i 1) depth #t #f #f)))) + ((char=? ch #\;) + (loop (+ i 1) depth #f #f #t)) + ((char=? ch #\") + (loop (+ i 1) depth #t #f #f)) + ((open-delim? ch) + (loop (+ i 1) (+ depth 1) #f #f #f)) + ((close-delim? ch) + (let ((next-depth (- depth 1))) + (if (<= next-depth 0) + (+ i 1) + (loop (+ i 1) next-depth #f #f #f)))) + (else + (loop (+ i 1) depth #f #f #f)))))))))) + +(def (unquoted-vector-literal-hit content) + (let ((n (string-length content))) + (let loop ((i 0) (in-string? #f) (escape? #f) (in-comment? #f)) + (cond + ((>= i n) #f) + (else + (let* ((ch (string-ref content i)) + (newline? (char=? ch #\newline))) + (cond + (in-comment? + (loop (+ i 1) #f #f (and (not newline?) in-comment?))) + (in-string? + (cond + (escape? (loop (+ i 1) #t #f #f)) + ((char=? ch #\\) (loop (+ i 1) #t #t #f)) + ((char=? ch #\") (loop (+ i 1) #f #f #f)) + (else (loop (+ i 1) #t #f #f)))) + ((char=? ch #\;) + (loop (+ i 1) #f #f #t)) + ((char=? ch #\") + (loop (+ i 1) #t #f #f)) + ((and (char=? ch #\') + (< (+ i 2) n) + (char=? (string-ref content (+ i 1)) #\#) + (char=? (string-ref content (+ i 2)) #\()) + (let ((after (skip-sharp-vector-datum content (+ i 1)))) + (if after + (loop after #f #f #f) + (loop (+ i 1) #f #f #f)))) + ((and (char=? ch #\#) + (< (+ i 1) n) + (char=? (string-ref content (+ i 1)) #\() + (or (= i 0) + (not (char=? (string-ref content (- i 1)) #\')))) + (cons i "unquoted vector literal syntax #(...) is not valid Jerboa. Use (vector ...) for runtime vectors, or quote constant data as '#(...).")) + (else + (loop (+ i 1) #f #f #f))))))))) + (def (balance-ok-text? report) (string-prefix? "Balance OK:" report)) @@ -5505,6 +5582,8 @@ => (lambda (hit) (format-guard path (car hit) (cdr hit)))) ((find-call-spacing-error content) => (lambda (hit) (format-guard path (car hit) (cdr hit)))) + ((unquoted-vector-literal-hit content) + => (lambda (hit) (format-guard path (car hit) (cdr hit)))) ((balance-guard-message path content) => (lambda (msg) msg)) (else #f))))) --- a/test/run.ss +++ b/test/run.ss @@ -7082,6 +7082,73 @@ (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] + [target "jcode-inline-vector-literal-guard.ss"] + [target-path (string-append vr-dir "/" target)] + [bad + (string-append + "(import (jerboa prelude))\n" + "(define (fallback-color type)\n" + " (if type (vector 1 2 3 255) #(30 30 30 255)))\n" + "(displayln \"ok\")\n")] + [good + (string-append + "(import (jerboa prelude))\n" + "(define (fallback-color type)\n" + " (if type (vector 1 2 3 255) (vector 30 30 30 255)))\n" + "(displayln \"ok\")\n")] + [tool-results '()] + [resp + (scripted-responder + (list + (list + (make-wtool-call "write" + (list (cons "path" target) + (cons "content" bad)) + #f)) + (list + (make-wtool-call "balance" + (list (cons "path" target)) + #f)) + (list + (make-wtool-call "write" + (list (cons "path" target) + (cons "content" good)) + #f)) + (list (make-wtool-call "done" + '(("summary" . "inline-vector-literal-guard-ok")) + #f))))]) + (safe-delete-test-file! target-path) + (let ([result + (verified-run resp "repair inline unquoted vector literal" + (list + (cons 'cwd vr-dir) + (cons 'verify-command + (string-append "grep -q '(vector 30 30 30 255)' " target)) + (cons 'write-scope (parse-write-scope target)) + (cons 'local-model? #t) + (cons 'max-iterations 8) + (cons 'max-tool-errors 2) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results)))))))]) + (check! "verified-run: inline vector literal guard recovers" + result "VERIFIED: exit 0\n") + (check-pred! "verified-run: inline vector literal guard explains repair" + (reverse tool-results) + (lambda (xs) + (and (pair? xs) + (str-contains? (car xs) "unquoted vector literal syntax") + (str-contains? (car xs) "(vector ...)")))) + (check-pred! "verified-run: inline vector literal guard wrote repaired source" + (call-with-input-file target-path (lambda (p) (get-string-all p))) + (lambda (s) + (and (str-contains? s "(vector 30 30 30 255)") + (not (str-contains? s "#(30")))))) + (safe-delete-test-file! target-path)) + + (let* ([vr-dir "/tmp"] [target "jcode-invalid-defstruct-diagnosis.ss"] [target-path (string-append vr-dir "/" target)] [bad-source "(import (jerboa prelude))\n(defstruct game\n board\n score)\n\n(define (next) 2)\n"])