Auto-repair arithmetic shift alias
ober
25d3598cfc4996a5834e036747ca08683fa5b1ef
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -4355,6 +4355,52 @@ (+ idx (string-length old-str)) (string-length content)))))) +(def (repair-symbol-boundary-before? content idx) + (or (= idx 0) + (let ((ch (string-ref content (- idx 1)))) + (or (char-whitespace? ch) + (memq ch '(#\( #\[ #\{ #\' #\` #\, #\")))))) + +(def (repair-symbol-boundary-after? content idx) + (or (>= idx (string-length content)) + (let ((ch (string-ref content idx))) + (or (char-whitespace? ch) + (memq ch '(#\) #\] #\} #\' #\" #\;)))))) + +(def (find-symbol-occurrence content symbol) + (let ((symbol-len (string-length symbol))) + (let loop ((start 0)) + (let ((idx (find-substring-from content symbol start))) + (cond + ((not idx) #f) + ((and (repair-symbol-boundary-before? content idx) + (repair-symbol-boundary-after? content (+ idx symbol-len))) + idx) + (else + (loop (+ idx symbol-len)))))))) + +(def (replace-symbol-occurrences content old-str new-str) + (let ((old-len (string-length old-str))) + (let loop ((start 0) (acc '()) (changed? #f)) + (let ((idx (find-substring-from content old-str start))) + (cond + ((not idx) + (and changed? + (apply string-append + (reverse + (cons (substring content start (string-length content)) + acc))))) + ((and (repair-symbol-boundary-before? content idx) + (repair-symbol-boundary-after? content (+ idx old-len))) + (loop (+ idx old-len) + (cons new-str + (cons (substring content start idx) acc)) + #t)) + (else + (loop (+ idx old-len) + (cons (substring content start (+ idx old-len)) acc) + changed?))))))) + (def (replace-line content line-no new-line) (let loop ((lines (string-split content #\newline)) (i 1) @@ -4485,6 +4531,11 @@ (let loop ((patterns *forbidden-jerboa-patterns*)) (cond ((null? patterns) #f) + ((string=? (caar patterns) "arithmetic-shift") + (let ((idx (find-symbol-occurrence content "arithmetic-shift"))) + (if idx + (cons idx (cdar patterns)) + (loop (cdr patterns))))) ((find-substring-from content (caar patterns) 0) => (lambda (idx) (cons idx (cdar patterns)))) (else (loop (cdr patterns)))))) @@ -4545,6 +4596,23 @@ (autoclose-candidate-syntax-sane? candidate path) candidate)))) +(def (auto-compat-full-ss-content path content) + (and (source-ss-path? path) + (string-contains content "arithmetic-shift") + (let ((candidate + (replace-symbol-occurrences content + "arithmetic-shift" + "bitwise-arithmetic-shift"))) + (and candidate + (not (jerboa-syntax-guard-message path candidate)) + candidate)))) + +(def (auto-full-ss-content path content) + (let* ((balanced (auto-balance-full-ss-content path content)) + (base (or balanced content)) + (compat (auto-compat-full-ss-content path base))) + (or compat balanced))) + (def (auto-balance-repair-message path original-content) (let ((report (balance-report original-content path))) (cond @@ -4555,6 +4623,15 @@ (else " after appending minimal delimiter suffix")))) +(def (auto-full-ss-repair-message path original-content final-content) + (string-append + (if (and final-content + (not (string=? original-content final-content)) + (string-contains original-content "arithmetic-shift") + (string-contains final-content "bitwise-arithmetic-shift")) + " after applying Jerboa compatibility alias repair" + (auto-balance-repair-message path original-content)))) + (def (jerboa-syntax-guard-message path content) (and (source-ss-path? path) (parameterize ((current-guard-content content)) @@ -5077,9 +5154,9 @@ (reject-incomplete-ss-create path new-content "replacement snippets")) (else - (let* ((balanced-content - (auto-balance-full-ss-content path new-content)) - (final-content (or balanced-content new-content)) + (let* ((auto-content + (auto-full-ss-content path new-content)) + (final-content (or auto-content new-content)) (dir (path-directory p))) (when (and dir (not (equal? dir "")) (not (file-exists? dir))) (mkdir-p dir)) @@ -5089,8 +5166,9 @@ (string-append "wrote " path " (" (number->string (string-length final-content)) " bytes)" - (if balanced-content - (auto-balance-repair-message path new-content) + (if auto-content + (auto-full-ss-repair-message + path new-content final-content) ""))))))) ((not (file-exists? p)) (raise-recoverable-tool-error @@ -5168,10 +5246,10 @@ (let ((msg (partial-overwrite-error path old content))) (when msg (raise-recoverable-tool-error msg 'edit))))) - (let* ((balanced-content + (let* ((auto-content (and (not (file-exists? p)) - (auto-balance-full-ss-content path content))) - (final-content (or balanced-content content))) + (auto-full-ss-content path content))) + (final-content (or auto-content content))) (if (file-exists? p) (if required-full-rewrite? (guard-jerboa-syntax-required-rewrite! cwd path final-content) @@ -5182,8 +5260,9 @@ (string-append "wrote " path " (" (number->string (string-length final-content)) " bytes)" - (if balanced-content - (auto-balance-repair-message path content) + (if auto-content + (auto-full-ss-repair-message + path content final-content) ""))))))))) ) --- a/test/run.ss +++ b/test/run.ss @@ -7314,6 +7314,52 @@ [else (loop (cdr ys))])))) (safe-delete-test-file! target-path)) +(let* ([vr-dir "/tmp"] + [target "jcode-verified-arithmetic-shift-alias.ss"] + [target-path (string-append vr-dir "/" target)] + [bad "(import (jerboa prelude))\n(define (double n) (arithmetic-shift n 1))\n"] + [slurp (lambda (p) (call-with-input-file p (lambda (i) (get-string-all i))))]) + (safe-delete-test-file! target-path) + (let* ([scope (parse-write-scope target)] + [tool-results '()] + [wf (coding-workflow + (string-append "grep -q bitwise-arithmetic-shift " target) + vr-dir + (list (cons 'write-scope scope)))] + [resp (scripted-responder + (list + (list + (make-wtool-call + "write" + (list (cons "path" target) + (cons "content" bad)) + #f)) + (list (make-wtool-call "verify" '() #f)) + (list (make-wtool-call "done" '(("summary" . "shift-alias-ok")) #f))))] + [result (parameterize ((current-write-scope scope)) + (run-workflow wf "repair arithmetic-shift alias" resp + (list (cons 'max-iterations 6) + (cons 'max-tool-errors 0) + (cons 'on-message + (lambda (m) + (when (equal? (message-role m) "tool") + (set! tool-results + (cons (message-content m) tool-results))))))))]) + (check! "verified-run: arithmetic-shift alias auto-repairs to done" + result "shift-alias-ok") + (check-pred! "verified-run: arithmetic-shift alias writes compatible symbol" + (slurp target-path) + (lambda (s) + (and (str-contains? s "bitwise-arithmetic-shift") + (not (str-contains? s "(arithmetic-shift"))))) + (check-pred! "verified-run: arithmetic-shift alias reports automatic repair" + (reverse tool-results) + (lambda (xs) + (and (pair? xs) + (str-contains? (car xs) + "Jerboa compatibility alias repair"))))) + (safe-delete-test-file! target-path)) + (let* ([vr-dir "/tmp"] [target "jcode-verified-replace-range.ss"] [target-path (string-append vr-dir "/" target)]