Repair self-test flag aliases
ober
dfe5ea97b42f8147a65d1ac789f3294bc9276305
--- a/src/jcode/core/verified-run.ss +++ b/src/jcode/core/verified-run.ss @@ -1731,26 +1731,35 @@ path start-line end-line start-line 'command-line " [(member \"--self-test\" raw-command-line)")) - (let* ((start-index - (definition-start-index content "self-test?")) - (end-index - (and start-index - (form-end-index content start-index))) - (definition - (and end-index - (substring content start-index end-index)))) - (and definition - (string-contains definition "--self-test") - (not (string-contains definition "member")) - (let ((start-line - (line-number-at-index content start-index)) - (end-line - (line-number-at-index - content (max start-index (- end-index 1))))) - (make-required-range-repair - path start-line end-line start-line - 'command-line - "(def self-test?\n (member \"--self-test\" raw-command-line))")))))))))) + (let loop ((names '("self-test?" "self-test-mode?" + "self-test-mode"))) + (if (null? names) + #f + (let* ((name (car names)) + (start-index + (definition-start-index content name)) + (end-index + (and start-index + (form-end-index content start-index))) + (definition + (and end-index + (substring content start-index end-index)))) + (if (and definition + (string-contains definition "--self-test") + (not (string-contains definition "member"))) + (let ((start-line + (line-number-at-index content start-index)) + (end-line + (line-number-at-index + content + (max start-index (- end-index 1))))) + (make-required-range-repair + path start-line end-line start-line + 'command-line + (format + "(def ~a\n (member \"--self-test\" raw-command-line))" + name))) + (loop (cdr names)))))))))))) (def (piece-shapes-index-repair detail cwd) (and (string-contains detail "Exception in vector-ref:") --- a/test/run.ss +++ b/test/run.ss @@ -3475,6 +3475,45 @@ (safe-delete-test-file! target-path)) (let* ([vr-dir "/tmp"] + [target "jcode-local-self-test-flag-alias-auto-repair.ss"] + [target-path (string-append vr-dir "/" target)] + [initial + (string-append + "(import (jerboa prelude))\n" + "(def raw-command-line (command-line))\n" + "(def args (cdr raw-command-line))\n" + "(def self-test-mode? (and (pair? args) (string=? \"--self-test\" (car args))))\n" + "(if self-test-mode? (display \"self\") (display \"interactive\"))\n")] + [responder + (scripted-responder + (list (list (make-wtool-call "verify" '() #f))))] + [verify-command + (string-append + "if grep -q '(car args)' " target + "; then echo 'FAIL: self-test command failed'; echo 'self-test timed out after 20s'; echo 'FAIL: self-test did not write a non-empty screenshot'; exit 1; fi")]) + (safe-delete-test-file! target-path) + (call-with-output-file target-path + (lambda (p) (display initial p)) 'replace) + (let ([result + (verified-run responder "repair self-test mode flag alias" + (list + (cons 'cwd vr-dir) + (cons 'verify-command verify-command) + (cons 'write-scope (parse-write-scope target)) + (cons 'local-model? #t) + (cons 'max-iterations 5) + (cons 'max-tool-errors 2)))]) + (check! "verified-run: automatic self-test flag alias repair verifies" + result "VERIFIED: exit 0\n")) + (check-pred! "verified-run: self-test flag alias keeps predicate name" + (call-with-input-file target-path (lambda (p) (get-string-all p))) + (lambda (s) + (and (str-contains? s + "(def self-test-mode?\n (member \"--self-test\" raw-command-line))") + (not (str-contains? s "(car args)"))))) + (safe-delete-test-file! target-path)) + + (let* ([vr-dir "/tmp"] [target "jcode-local-self-test-game-over-auto-repair.ss"] [target-path (string-append vr-dir "/" target)] [initial