From 9905c1c89a726126833f374945a9475afea3fb0e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 11 Oct 2020 11:39:57 -0600 Subject: [PATCH] cs: fix `srcloc->string` as relative to `current-directory-for-user` --- pkgs/racket-test-core/tests/racket/read.rktl | 10 +++ racket/src/cs/rumble/bytes.ss | 10 +-- racket/src/cs/schemified/io.scm | 67 ++++++++++++++++++-- racket/src/io/path/user-relative.rkt | 27 ++++++++ racket/src/io/srcloc/main.rkt | 9 +-- 5 files changed, 108 insertions(+), 15 deletions(-) create mode 100644 racket/src/io/path/user-relative.rkt diff --git a/pkgs/racket-test-core/tests/racket/read.rktl b/pkgs/racket-test-core/tests/racket/read.rktl index a993e2f606..9ccefe5004 100644 --- a/pkgs/racket-test-core/tests/racket/read.rktl +++ b/pkgs/racket-test-core/tests/racket/read.rktl @@ -1478,6 +1478,16 @@ srcloc-line (lambda (s v) v))) (err/rt-test (srcloc->string 1)) +(let ([go (lambda (adjust) + (parameterize ([current-directory-for-user (adjust (build-path (car (filesystem-root-list)) "Users" "robby"))]) + (test + "tmp.rkt:1:2" + srcloc->string + (srcloc (build-path (car (filesystem-root-list)) "Users" "robby" "tmp.rkt") + 1 2 3 4))))]) + (go values) + (go path->directory-path)) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Make sure that a module load triggered by `#lang` or `#reader` is in ;; a root namespace, including the call to the loaded function diff --git a/racket/src/cs/rumble/bytes.ss b/racket/src/cs/rumble/bytes.ss index 496e862ef8..10e1489a54 100644 --- a/racket/src/cs/rumble/bytes.ss +++ b/racket/src/cs/rumble/bytes.ss @@ -114,8 +114,8 @@ (define-bytes-compare bytes=? bytevector=?) (define (do-bytes? a b) - (let ([alen (bytes-length a)] - [blen (bytes-length b)]) + (let ([alen (bytevector-length a)] + [blen (bytevector-length b)]) (let loop ([i 0]) (cond [(= i alen) #f] @@ -193,4 +193,4 @@ (bytevector-copy! bstr start c 0 len) c)] [(bstr start) - (subbytes bstr start (bytes-length bstr))])) + (subbytes bstr start (if (bytes? bstr) (bytevector-length bstr) 0))])) diff --git a/racket/src/cs/schemified/io.scm b/racket/src/cs/schemified/io.scm index 6835dea591..53cb82ad84 100644 --- a/racket/src/cs/schemified/io.scm +++ b/racket/src/cs/schemified/io.scm @@ -33157,6 +33157,61 @@ (lambda () (error-value->string-handler procz1)))) (define effect_2767 (begin (void (install-error-value->string-handler!)) (void))) +(define relative-to-user-directory + (lambda (p_0) + (let ((dir_0 (current-directory-for-user$1))) + (let ((dir-bs_0 (|#%app| path-bytes dir_0))) + (let ((p-bs_0 (|#%app| path-bytes p_0))) + (let ((dir-len_0 (unsafe-bytes-length dir-bs_0))) + (let ((p-len_0 (unsafe-bytes-length p-bs_0))) + (if (if (< dir-len_0 p-len_0) + (begin + (letrec* + ((for-loop_0 + (|#%name| + for-loop + (lambda (result_0 pos_0) + (begin + (if (< pos_0 dir-len_0) + (let ((result_1 + (let ((result_1 + (let ((app_0 + (unsafe-bytes-ref + dir-bs_0 + pos_0))) + (eq? + app_0 + (unsafe-bytes-ref + p-bs_0 + pos_0))))) + (values result_1)))) + (if (if (not + (let ((x_0 (list pos_0))) + (not result_1))) + #t + #f) + (for-loop_0 result_1 (+ pos_0 1)) + result_1)) + result_0)))))) + (for-loop_0 #t 0))) + #f) + (letrec* + ((loop_0 + (|#%name| + loop + (lambda (i_0) + (begin + (if (if (< i_0 p-len_0) + (let ((app_0 (unsafe-bytes-ref p-bs_0 i_0))) + (is-sep? app_0 (|#%app| path-convention p_0))) + #f) + (loop_0 (fx+ i_0 1)) + (let ((app_0 (subbytes p-bs_0 i_0))) + (path1.1 + app_0 + (|#%app| path-convention p_0))))))))) + (loop_0 dir-len_0)) + p_0)))))))) (define 1/srcloc->string (|#%name| srcloc->string @@ -33175,7 +33230,7 @@ (1/format "~a::~s" app_0 (srcloc-position s_0)))) #f)))))) (define adjust-path - (lambda (p_0) (let ((dir_0 (current-directory-for-user$1))) p_0))) + (lambda (p_0) (if (is-path? p_0) (relative-to-user-directory p_0) p_0))) (define struct:logger (make-record-type-descriptor* 'logger #f #f #f #f 11 2047)) (define effect_2192 @@ -35925,11 +35980,11 @@ 'subprocess "(or/c (and/c output-port? file-stream-port?) #f 'stdout)" stderr_0)) - (let ((lr3711 unsafe-undefined) + (let ((lr3723 unsafe-undefined) (group_0 unsafe-undefined) (command_0 unsafe-undefined) (exact/args_0 unsafe-undefined)) - (set! lr3711 + (set! lr3723 (call-with-values (lambda () (if (path-string? group/command_0) @@ -35984,9 +36039,9 @@ ((group_1 command_1 exact/args_1) (vector group_1 command_1 exact/args_1)) (args (raise-binding-result-arity-error 3 args))))) - (set! group_0 (unsafe-vector*-ref lr3711 0)) - (set! command_0 (unsafe-vector*-ref lr3711 1)) - (set! exact/args_0 (unsafe-vector*-ref lr3711 2)) + (set! group_0 (unsafe-vector*-ref lr3723 0)) + (set! command_0 (unsafe-vector*-ref lr3723 1)) + (set! exact/args_0 (unsafe-vector*-ref lr3723 2)) (call-with-values (lambda () (if (if (pair? exact/args_0) diff --git a/racket/src/io/path/user-relative.rkt b/racket/src/io/path/user-relative.rkt new file mode 100644 index 0000000000..68f813e360 --- /dev/null +++ b/racket/src/io/path/user-relative.rkt @@ -0,0 +1,27 @@ +#lang racket/base +(require racket/fixnum + "path.rkt" + "parameter.rkt" + "sep.rkt") + +(provide relative-to-user-directory) + +(define (relative-to-user-directory p) + (define dir (current-directory-for-user)) + (define dir-bs (path-bytes dir)) + (define p-bs (path-bytes p)) + (define dir-len (bytes-length dir-bs)) + (define p-len (bytes-length p-bs)) + (cond + [(and (dir-len . < . p-len) + (for/and ([i (in-range dir-len)]) + (eq? (bytes-ref dir-bs i) + (bytes-ref p-bs i)))) + (let loop ([i dir-len]) + (cond + [(and (i . < . p-len) + (is-sep? (bytes-ref p-bs i) (path-convention p))) + (loop (fx+ i 1))] + [else + (path (subbytes p-bs i) (path-convention p))]))] + [else p])) diff --git a/racket/src/io/srcloc/main.rkt b/racket/src/io/srcloc/main.rkt index eaa852d38c..200a9753f0 100644 --- a/racket/src/io/srcloc/main.rkt +++ b/racket/src/io/srcloc/main.rkt @@ -1,7 +1,8 @@ #lang racket/base (require "../common/check.rkt" "../format/main.rkt" - "../path/parameter.rkt") + "../path/path.rkt" + "../path/user-relative.rkt") (provide srcloc->string) @@ -21,6 +22,6 @@ (srcloc-position s))]))) (define (adjust-path p) - (define dir (current-directory-for-user)) - ;; FIXME - p) + (cond + [(is-path? p) (relative-to-user-directory p)] + [else p]))