suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cs: fix srcloc->string as relative to current-directory-for-user

Browse Source
This commit is contained in:
Matthew Flatt 2020-10-11 11:39:57 -06:00
parent 59e31e700d
commit 9905c1c89a
5 changed files with 108 additions and 15 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
pkgs/racket-test-core/tests/racket/read.rktl
View File

@ -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

10
racket/src/cs/rumble/bytes.ss
View File

@ -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) (if (= i blen)
@ -131,8 +131,8 @@
[else #f]))]))))
(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))]))

67
racket/src/cs/schemified/io.scm
View File

@ -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)

27
racket/src/io/path/user-relative.rkt Normal file
View File

@ -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]))

9
racket/src/io/srcloc/main.rkt
View File

@ -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]))