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

racket/fasl: repair for pair current-write-relative-directory

Browse Source
This commit is contained in:
Matthew Flatt 2018-07-09 15:54:28 -06:00
parent 8411b403e5
commit 7bfe967e87
2 changed files with 52 additions and 10 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
pkgs/racket-test-core/tests/racket/fasl.rktl
View File

@ -101,7 +101,9 @@
(test (srcloc (path->string (build-path root 'same)) 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path root 'same) 1 2 3 4)))) (test (srcloc (path->string (build-path root 'same)) 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path root 'same) 1 2 3 4))))
(test (srcloc ".../a/b" 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path (current-directory) "a" "b") 1 2 3 4))))) (test (srcloc ".../a/b" 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path (current-directory) "a" "b") 1 2 3 4)))))
(let* ([rel-p (build-path "nested" "data.rktd")] (let* ([file-p (build-path "data.rktd")]
[dir-p (build-path "nested")]
[rel-p (build-path dir-p file-p)]
[p (build-path (current-directory) rel-p)]) [p (build-path (current-directory) rel-p)])
(define-values (bstr srcloc-bstr) (define-values (bstr srcloc-bstr)
(parameterize ([current-write-relative-directory (current-directory)]) (parameterize ([current-write-relative-directory (current-directory)])
@ -113,7 +115,30 @@
(test (srcloc rel-p 10 20 30 40) fasl->s-exp srcloc-bstr)) (test (srcloc rel-p 10 20 30 40) fasl->s-exp srcloc-bstr))
(parameterize ([current-load-relative-directory (current-directory)]) (parameterize ([current-load-relative-directory (current-directory)])
(test p fasl->s-exp bstr) (test p fasl->s-exp bstr)
(test (srcloc p 10 20 30 40) fasl->s-exp srcloc-bstr))) (test (srcloc p 10 20 30 40) fasl->s-exp srcloc-bstr))
;; Try a pair for `current-write-relative-directory`
(let* ([alt-rel-p (build-path "alternate" "bytes.rktd")]
[alt-p (build-path (current-directory) alt-rel-p)])
(define-values (bstr srcloc-bstr bstr2 srcloc-bstr2)
(parameterize ([current-write-relative-directory (cons (build-path (current-directory) dir-p)
(current-directory))])
(values
(s-exp->fasl p)
(s-exp->fasl (srcloc p 10 20 30 40))
(s-exp->fasl alt-p)
(s-exp->fasl (srcloc alt-p 10 20 30 40)))))
(parameterize ([current-load-relative-directory #f])
(test file-p fasl->s-exp bstr)
(test (srcloc file-p 10 20 30 40) fasl->s-exp srcloc-bstr)
(test (build-path 'up alt-rel-p) fasl->s-exp bstr2)
(test (srcloc (build-path 'up alt-rel-p) 10 20 30 40) fasl->s-exp srcloc-bstr2))
(parameterize ([current-load-relative-directory (build-path (current-directory) dir-p)])
(test p fasl->s-exp bstr)
(test (srcloc p 10 20 30 40) fasl->s-exp srcloc-bstr)
(let ([up-alt-p (build-path (current-directory) dir-p 'up alt-rel-p)])
(test up-alt-p fasl->s-exp bstr2)
(test (srcloc up-alt-p 10 20 30 40) fasl->s-exp srcloc-bstr2)))))
(test (srcloc ".../a" 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path 'up "a") 1 2 3 4))) (test (srcloc ".../a" 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path 'up "a") 1 2 3 4)))
(test (srcloc ".../a" 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path 'same "a") 1 2 3 4))) (test (srcloc ".../a" 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path 'same "a") 1 2 3 4)))

33
racket/collects/racket/fasl.rkt
View File

@ -126,19 +126,36 @@
[(prefab-struct-key v) [(prefab-struct-key v)
(loop (struct->vector v))] (loop (struct->vector v))]
[else (void)])) [else (void)]))
(define exploded-wrt-dir 'not-ready) (define exploded-base-dir 'not-ready)
(define exploded-wrt-rel-dir 'not-ready)
(define (path->relative-path-elements v) (define (path->relative-path-elements v)
(when (and (eq? exploded-wrt-dir 'not-ready) (when (and (eq? exploded-base-dir 'not-ready)
(path? v)) (path? v))
(define wrt-dir (current-write-relative-directory)) (define wr-dir (current-write-relative-directory))
(set! exploded-wrt-dir (and wrt-dir (explode-path wrt-dir)))) (define wrt-dir (and wr-dir (if (pair? wr-dir) (car wr-dir) wr-dir)))
(and exploded-wrt-dir (define base-dir (and wr-dir (if (pair? wr-dir) (cdr wr-dir) wr-dir)))
(set! exploded-base-dir (and base-dir (explode-path base-dir)))
(set! exploded-wrt-rel-dir
(if (eq? base-dir wrt-dir)
'()
(list-tail (explode-path wrt-dir)
(length exploded-base-dir)))))
(and exploded-base-dir
(path? v) (path? v)
(let ([exploded (explode-path v)]) (let ([exploded (explode-path v)])
(and (for/and ([wrt-p (in-list exploded-wrt-dir)] (and (for/and ([base-p (in-list exploded-base-dir)]
[p (in-list exploded)]) [p (in-list exploded)])
(equal? wrt-p p)) (equal? base-p p))
(list-tail exploded (length exploded-wrt-dir)))))) (let loop ([exploded-wrt-rel-dir exploded-wrt-rel-dir ]
[rel (list-tail exploded (length exploded-base-dir))])
(cond
[(null? exploded-wrt-rel-dir) rel]
[(and (pair? rel)
(equal? (car rel) (car exploded-wrt-rel-dir)))
(loop (cdr exploded-wrt-rel-dir) (cdr rel))]
[else (append (for/list ([p (in-list exploded-wrt-rel-dir)])
'up)
rel)]))))))
(define (treat-immutable? v) (or (not keep-mutable?) (immutable? v))) (define (treat-immutable? v) (or (not keep-mutable?) (immutable? v)))
;; The fasl formal prefix: ;; The fasl formal prefix:
(write-bytes fasl-prefix o) (write-bytes fasl-prefix o)