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

Fix fasl bug in Racket 7.0 beta! (#2178)

Browse Source 
* Fix fasl bug in Racket 7.0 beta

The following program causes racket to error in Racket 7.

(parameterize ([current-write-relative-directory (build-path "/" "a")])
  (s-exp->fasl (build-path "/")))

This bug appears to have been introduced in Racket 7, and not in
Racket 6.x.

* Fix another bug where 'same was put through path-element->bytes

* "/" => (car (root-paths-list))

This is for windows where simply "/" is not a complete path.

* Add similar tests to serialize library.

* Better error message when relative-directory is a bad pair

Before it would give an internal list-tail error, now it returns
a proper bad argument error.

* Better tests, and improved common case
This commit is contained in:
Leif Andersen 2018-07-21 14:46:44 -04:00 committed by GitHub
parent ebb7c0ea82
commit eaaede9c2c
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
3 changed files with 70 additions and 5 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -145,4 +145,18 @@
(test (srcloc ".../a/.." 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path "a" 'up) 1 2 3 4)))
(test (srcloc ".../a/." 1 2 3 4) fasl->s-exp (s-exp->fasl (srcloc (build-path "a" 'same) 1 2 3 4)))
(let ([root (car (filesystem-root-list))])
(test
root
'longer-relative
(parameterize ([current-write-relative-directory (build-path root "a")])
(fasl->s-exp (s-exp->fasl root))))
(test
(build-path 'same)
'this-dir-path
(parameterize ([current-write-relative-directory root]
[current-load-relative-directory #f])
(fasl->s-exp (s-exp->fasl (build-path root 'same))))))
(report-errs)

36
pkgs/racket-test-core/tests/racket/serialize.rktl
View File

@ -710,4 +710,40 @@
;; ----------------------------------------
(let ([root (car (filesystem-root-list))])
(test
root
'longer-relative
(deserialize (serialize root #:relative-directory (build-path root "a"))))
(test
(build-path 'same)
'this-dir-path
(parameterize ([current-load-relative-directory #f])
(deserialize (serialize (build-path root 'same) #:relative-directory root)))))
;; ----------------------------------------
(let ()
(define (test-relative data rel)
(test
'right-error
'non-base-dir
(with-handlers ([exn:fail:contract?
(λ (e)
(if (string-prefix?
(exn-message e)
(string-append "serialize: relative-directory pair's first"
" path does not extend second path"))
'right-error
'wrong-error))])
(serialize data
#:relative-directory rel))))
(test-relative (string->path "/x") (cons "/x" "/x/y"))
(test-relative (string->path "/x") (cons "/x/z" "/x/y")))
;; ----------------------------------------
(report-errs)

25
racket/collects/racket/private/relative-path.rkt
View File

@ -36,23 +36,38 @@
(when (and (eq? exploded-base-dir 'not-ready)
(path? v))
(define wrt-dir (and wr-dir (if (pair? wr-dir) (car wr-dir) wr-dir)))
(define exploded-wrt-dir (explode-path 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)))))
(cond
[(eq? base-dir wrt-dir) '()]
[else
(define exploded-wrt-dir (explode-path wrt-dir))
(define base-len (length exploded-base-dir))
(when who
(unless (and
((length exploded-wrt-dir) . >= . base-len)
(for/and ([a (in-list exploded-wrt-dir)]
[b (in-list exploded-base-dir)])
(equal? a b)))
(raise-arguments-error who
"relative-directory pair's first path does not extend second path"
"first path" wrt-dir
"second path" base-dir)))
(list-tail exploded-wrt-dir base-len)])))
(and exploded-base-dir
(path? v)
(let ([exploded (explode-path v)])
(and (for/and ([base-p (in-list exploded-base-dir)]
[p (in-list exploded)])
(equal? base-p p))
((length exploded) . >= . (length exploded-base-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) (map path-element->bytes rel)]
[(null? exploded-wrt-rel-dir) (for/list ([p (in-list rel)])
(if (path? p) (path-element->bytes p) p))]
[(and (pair? rel)
(equal? (car rel) (car exploded-wrt-rel-dir)))
(loop (cdr exploded-wrt-rel-dir) (cdr rel))]