move '#%utils implementation into "collects/racket/private".
For now, this copies the code of "startup.rktl". The intent is that "startup.rktl" will go away with a new bootstrap process.
This commit is contained in:
Matthew Flatt
parent
94c636fe2b
commit
c1c427a281
507
racket/collects/racket/private/collect.rkt
Normal file
507
racket/collects/racket/private/collect.rkt
Normal file
|
|
@ -0,0 +1,507 @@
|
||||||
|
(module collect '#%kernel
|
||||||
|
(#%require '#%paramz ; for `exception-handler-key`
|
||||||
|
"qq-and-or.rkt"
|
||||||
|
"define-et-al.rkt"
|
||||||
|
"cond.rkt"
|
||||||
|
"path.rkt"
|
||||||
|
"path-list.rkt"
|
||||||
|
"reading-param.rkt"
|
||||||
|
"config.rkt")
|
||||||
|
|
||||||
|
(#%provide find-col-file
|
||||||
|
collection-path
|
||||||
|
collection-file-path
|
||||||
|
find-library-collection-paths
|
||||||
|
find-library-collection-links)
|
||||||
|
|
||||||
|
(define-values (-check-relpath)
|
||||||
|
(lambda (who s)
|
||||||
|
(unless (path-string? s)
|
||||||
|
(raise-argument-error who "path-string?" s))
|
||||||
|
(unless (relative-path? s)
|
||||||
|
(raise-arguments-error who
|
||||||
|
"invalid relative path"
|
||||||
|
"path" s))))
|
||||||
|
|
||||||
|
(define-values (-check-collection)
|
||||||
|
(lambda (who collection collection-path)
|
||||||
|
(-check-relpath who collection)
|
||||||
|
(for-each (lambda (p) (-check-relpath who p)) collection-path)))
|
||||||
|
|
||||||
|
(define-values (-check-fail)
|
||||||
|
(lambda (who fail)
|
||||||
|
(unless (and (procedure? fail)
|
||||||
|
(procedure-arity-includes? fail 1))
|
||||||
|
(raise-argument-error who "(any/c . -> . any)" fail))))
|
||||||
|
|
||||||
|
(define-values (collection-path)
|
||||||
|
(lambda (fail collection collection-path)
|
||||||
|
(-check-collection 'collection-path collection collection-path)
|
||||||
|
(-check-fail 'collection-path fail)
|
||||||
|
(find-col-file fail
|
||||||
|
collection collection-path
|
||||||
|
#f
|
||||||
|
#f)))
|
||||||
|
|
||||||
|
(define-values (collection-file-path)
|
||||||
|
(lambda (fail check-compiled? file-name collection collection-path)
|
||||||
|
(-check-relpath 'collection-file-path file-name)
|
||||||
|
(-check-collection 'collection-file-path collection collection-path)
|
||||||
|
(-check-fail 'collection-file-path fail)
|
||||||
|
(find-col-file fail
|
||||||
|
collection collection-path
|
||||||
|
file-name
|
||||||
|
check-compiled?)))
|
||||||
|
|
||||||
|
(define-values (get-config-table)
|
||||||
|
(lambda (d)
|
||||||
|
(let ([p (and d (build-path d "config.rktd"))])
|
||||||
|
(or (and p
|
||||||
|
(file-exists? p)
|
||||||
|
(with-input-from-file p
|
||||||
|
(lambda ()
|
||||||
|
(let ([v (call-with-default-reading-parameterization read)])
|
||||||
|
(and (hash? v)
|
||||||
|
v)))))
|
||||||
|
#hash()))))
|
||||||
|
|
||||||
|
(define-values (get-installation-name)
|
||||||
|
(lambda (config-table)
|
||||||
|
(hash-ref config-table
|
||||||
|
'installation-name
|
||||||
|
(version))))
|
||||||
|
|
||||||
|
(define-values (coerce-to-path)
|
||||||
|
(lambda (p)
|
||||||
|
(cond
|
||||||
|
[(string? p) (collects-relative-path->complete-path (string->path p))]
|
||||||
|
[(bytes? p) (collects-relative-path->complete-path (bytes->path p))]
|
||||||
|
[(path? p) (collects-relative-path->complete-path p)]
|
||||||
|
[else p])))
|
||||||
|
|
||||||
|
(define-values (collects-relative-path->complete-path)
|
||||||
|
(lambda (p)
|
||||||
|
(cond
|
||||||
|
[(complete-path? p) p]
|
||||||
|
[else
|
||||||
|
(path->complete-path p (or (find-main-collects)
|
||||||
|
;; If we get here, then something is configured wrong,
|
||||||
|
;; and making up paths relative to the current directory
|
||||||
|
;; is not great --- but we have to come up with some
|
||||||
|
;; path at this point.
|
||||||
|
(current-directory)))])))
|
||||||
|
|
||||||
|
(define-values (add-config-search)
|
||||||
|
(lambda (ht key orig-l)
|
||||||
|
(let ([l (hash-ref ht key #f)])
|
||||||
|
(if l
|
||||||
|
(let loop ([l l])
|
||||||
|
(cond
|
||||||
|
[(null? l) null]
|
||||||
|
[(not (car l)) (append orig-l (loop (cdr l)))]
|
||||||
|
[else (cons (coerce-to-path (car l)) (loop (cdr l)))]))
|
||||||
|
orig-l))))
|
||||||
|
|
||||||
|
(define-values (find-library-collection-links)
|
||||||
|
(lambda ()
|
||||||
|
(let* ([ht (get-config-table (find-main-config))]
|
||||||
|
[lf (coerce-to-path
|
||||||
|
(or (hash-ref ht 'links-file #f)
|
||||||
|
(build-path (or (hash-ref ht 'share-dir #f)
|
||||||
|
(build-path 'up "share"))
|
||||||
|
"links.rktd")))])
|
||||||
|
(append
|
||||||
|
;; `#f' means `current-library-collection-paths':
|
||||||
|
(list #f)
|
||||||
|
;; user-specific
|
||||||
|
(if (and (use-user-specific-search-paths)
|
||||||
|
(use-collection-link-paths))
|
||||||
|
(list (build-path (find-system-path 'addon-dir)
|
||||||
|
(get-installation-name ht)
|
||||||
|
"links.rktd"))
|
||||||
|
null)
|
||||||
|
;; installation-wide:
|
||||||
|
(if (use-collection-link-paths)
|
||||||
|
(add-config-search
|
||||||
|
ht
|
||||||
|
'links-search-files
|
||||||
|
(list lf))
|
||||||
|
null)))))
|
||||||
|
|
||||||
|
;; map from link-file names to cached information:
|
||||||
|
(define-values (links-cache) (make-weak-hash))
|
||||||
|
|
||||||
|
;; used for low-level except abort below:
|
||||||
|
(define-values (stamp-prompt-tag) (make-continuation-prompt-tag 'stamp))
|
||||||
|
|
||||||
|
(define-values (file->stamp)
|
||||||
|
(lambda (path old-stamp)
|
||||||
|
;; Using just the file's modification date almost works as a stamp,
|
||||||
|
;; but 1-second granularity isn't fine enough. A stamp is therefore
|
||||||
|
;; the file content paired with a filesystem-change event (where
|
||||||
|
;; supported), and the event lets us recycle the old stamp almost
|
||||||
|
;; always.
|
||||||
|
(cond
|
||||||
|
[(and old-stamp
|
||||||
|
(cdr old-stamp)
|
||||||
|
(not (sync/timeout 0 (cdr old-stamp))))
|
||||||
|
old-stamp]
|
||||||
|
[else
|
||||||
|
(call-with-continuation-prompt
|
||||||
|
(lambda ()
|
||||||
|
(with-continuation-mark
|
||||||
|
exception-handler-key
|
||||||
|
(lambda (exn)
|
||||||
|
(abort-current-continuation
|
||||||
|
stamp-prompt-tag
|
||||||
|
(if (exn:fail:filesystem? exn)
|
||||||
|
(lambda () #f)
|
||||||
|
(lambda () (raise exn)))))
|
||||||
|
(let ([dir-evt
|
||||||
|
(and (vector-ref (system-type 'fs-change) 2) ; 'low-latency ?
|
||||||
|
(let loop ([path path])
|
||||||
|
(let-values ([(base name dir?) (split-path path)])
|
||||||
|
(and (path? base)
|
||||||
|
(if (directory-exists? base)
|
||||||
|
(filesystem-change-evt base (lambda () #f))
|
||||||
|
(loop base))))))])
|
||||||
|
(if (not (file-exists? path))
|
||||||
|
(cons #f dir-evt)
|
||||||
|
(let ([evt (and (vector-ref (system-type 'fs-change) 2) ; 'low-latency ?
|
||||||
|
(filesystem-change-evt path (lambda () #f)))])
|
||||||
|
(when dir-evt (filesystem-change-evt-cancel dir-evt))
|
||||||
|
(cons
|
||||||
|
(let ([p (open-input-file path)])
|
||||||
|
(dynamic-wind
|
||||||
|
void
|
||||||
|
(lambda ()
|
||||||
|
(let ([bstr (read-bytes 8192 p)])
|
||||||
|
(if (and (bytes? bstr)
|
||||||
|
((bytes-length bstr) . >= . 8192))
|
||||||
|
(apply
|
||||||
|
bytes-append
|
||||||
|
(cons
|
||||||
|
bstr
|
||||||
|
(let loop ()
|
||||||
|
(let ([bstr (read-bytes 8192 p)])
|
||||||
|
(if (eof-object? bstr)
|
||||||
|
null
|
||||||
|
(cons bstr (loop)))))))
|
||||||
|
bstr)))
|
||||||
|
(lambda () (close-input-port p))))
|
||||||
|
evt))))))
|
||||||
|
stamp-prompt-tag)])))
|
||||||
|
|
||||||
|
(define-values (no-file-stamp?)
|
||||||
|
(lambda (a)
|
||||||
|
(or (not a)
|
||||||
|
(not (car a)))))
|
||||||
|
|
||||||
|
(define-values (get-linked-collections)
|
||||||
|
(lambda (links-path)
|
||||||
|
;; Use/save information in `links-cache', relying on filesystem-change events
|
||||||
|
;; or a copy of the file to detect when the cache is stale.
|
||||||
|
(call-with-escape-continuation
|
||||||
|
(lambda (esc)
|
||||||
|
(define-values (make-handler)
|
||||||
|
(lambda (ts)
|
||||||
|
(lambda (exn)
|
||||||
|
(if (exn:fail? exn)
|
||||||
|
(let ([l (current-logger)])
|
||||||
|
(when (log-level? l 'error)
|
||||||
|
(log-message l 'error
|
||||||
|
(format
|
||||||
|
"error reading collection links file ~s: ~a"
|
||||||
|
links-path
|
||||||
|
(exn-message exn))
|
||||||
|
(current-continuation-marks))))
|
||||||
|
(void))
|
||||||
|
(when ts
|
||||||
|
(hash-set! links-cache links-path (cons ts #hasheq())))
|
||||||
|
(if (exn:fail? exn)
|
||||||
|
(esc (make-hasheq))
|
||||||
|
;; re-raise the exception (which is probably a break)
|
||||||
|
exn))))
|
||||||
|
(with-continuation-mark
|
||||||
|
exception-handler-key
|
||||||
|
(make-handler #f)
|
||||||
|
(let* ([links-stamp+cache (hash-ref links-cache links-path '(#f . #hasheq()))]
|
||||||
|
[a-links-stamp (car links-stamp+cache)]
|
||||||
|
[ts (file->stamp links-path a-links-stamp)])
|
||||||
|
(if (not (equal? ts a-links-stamp))
|
||||||
|
(with-continuation-mark
|
||||||
|
exception-handler-key
|
||||||
|
(make-handler ts)
|
||||||
|
(call-with-default-reading-parameterization
|
||||||
|
(lambda ()
|
||||||
|
(let ([v (if (no-file-stamp? ts)
|
||||||
|
null
|
||||||
|
(let ([p (open-input-file links-path 'binary)])
|
||||||
|
(dynamic-wind
|
||||||
|
void
|
||||||
|
(lambda ()
|
||||||
|
(begin0
|
||||||
|
(read p)
|
||||||
|
(unless (eof-object? (read p))
|
||||||
|
(error "expected a single S-expression"))))
|
||||||
|
(lambda () (close-input-port p)))))])
|
||||||
|
(unless (and (list? v)
|
||||||
|
(andmap (lambda (p)
|
||||||
|
(and (list? p)
|
||||||
|
(or (= 2 (length p))
|
||||||
|
(= 3 (length p)))
|
||||||
|
(or (string? (car p))
|
||||||
|
(eq? 'root (car p))
|
||||||
|
(eq? 'static-root (car p)))
|
||||||
|
(path-string? (cadr p))
|
||||||
|
(or (null? (cddr p))
|
||||||
|
(regexp? (caddr p)))))
|
||||||
|
v))
|
||||||
|
(error "ill-formed content"))
|
||||||
|
(let ([ht (make-hasheq)]
|
||||||
|
[dir (let-values ([(base name dir?) (split-path links-path)])
|
||||||
|
base)])
|
||||||
|
(for-each
|
||||||
|
(lambda (p)
|
||||||
|
(when (or (null? (cddr p))
|
||||||
|
(regexp-match? (caddr p) (version)))
|
||||||
|
(let ([dir (simplify-path
|
||||||
|
(path->complete-path (cadr p) dir))])
|
||||||
|
(cond
|
||||||
|
[(eq? (car p) 'static-root)
|
||||||
|
;; multi-collection, constant content:
|
||||||
|
(for-each
|
||||||
|
(lambda (sub)
|
||||||
|
(when (directory-exists? (build-path dir sub))
|
||||||
|
(let ([k (string->symbol (path->string sub))])
|
||||||
|
(hash-set! ht k (cons dir (hash-ref ht k null))))))
|
||||||
|
(directory-list dir))]
|
||||||
|
[(eq? (car p) 'root)
|
||||||
|
;; multi-collection, dynamic content:
|
||||||
|
;; Add directory to the #f mapping, and also
|
||||||
|
;; add to every existing table element (to keep
|
||||||
|
;; the choices in order)
|
||||||
|
(unless (hash-ref ht #f #f)
|
||||||
|
(hash-set! ht #f null))
|
||||||
|
(hash-for-each
|
||||||
|
ht
|
||||||
|
(lambda (k v)
|
||||||
|
(hash-set! ht k (cons dir v))))]
|
||||||
|
[else
|
||||||
|
;; single collection:
|
||||||
|
(let ([s (string->symbol (car p))])
|
||||||
|
(hash-set! ht s (cons (box dir)
|
||||||
|
(hash-ref ht s null))))]))))
|
||||||
|
v)
|
||||||
|
;; reverse all lists:
|
||||||
|
(hash-for-each
|
||||||
|
ht
|
||||||
|
(lambda (k v) (hash-set! ht k (reverse v))))
|
||||||
|
;; save table & file content:
|
||||||
|
(hash-set! links-cache links-path (cons ts ht))
|
||||||
|
ht)))))
|
||||||
|
(cdr links-stamp+cache))))))))
|
||||||
|
|
||||||
|
(define-values (normalize-collection-reference)
|
||||||
|
(lambda (collection collection-path)
|
||||||
|
;; make sure that `collection' is a top-level collection name,
|
||||||
|
(cond
|
||||||
|
[(string? collection)
|
||||||
|
(let ([m (regexp-match-positions #rx"/+" collection)])
|
||||||
|
(if m
|
||||||
|
(cond
|
||||||
|
[(= (caar m) (sub1 (string-length collection)))
|
||||||
|
(values (substring collection 0 (caar m)) collection-path)]
|
||||||
|
[else
|
||||||
|
(values (substring collection 0 (caar m))
|
||||||
|
(cons (substring collection (cdar m))
|
||||||
|
collection-path))])
|
||||||
|
(values collection collection-path)))]
|
||||||
|
[else
|
||||||
|
(let-values ([(base name dir?) (split-path collection)])
|
||||||
|
(if (eq? base 'relative)
|
||||||
|
(values name collection-path)
|
||||||
|
(normalize-collection-reference base (cons name collection-path))))])))
|
||||||
|
|
||||||
|
(define-values (find-col-file)
|
||||||
|
(lambda (fail collection collection-path file-name check-compiled?)
|
||||||
|
(let-values ([(collection collection-path)
|
||||||
|
(normalize-collection-reference collection collection-path)])
|
||||||
|
(let ([all-paths (let ([sym (string->symbol
|
||||||
|
(if (path? collection)
|
||||||
|
(path->string collection)
|
||||||
|
collection))])
|
||||||
|
(let loop ([l (current-library-collection-links)])
|
||||||
|
(cond
|
||||||
|
[(null? l) null]
|
||||||
|
[(not (car l))
|
||||||
|
;; #f is the point where we try the old parameter:
|
||||||
|
(append
|
||||||
|
(current-library-collection-paths)
|
||||||
|
(loop (cdr l)))]
|
||||||
|
[(hash? (car l))
|
||||||
|
;; A hash table maps a collection-name symbol
|
||||||
|
;; to a list of paths. We need to wrap each path
|
||||||
|
;; in a box, because that's how the code below
|
||||||
|
;; knows that it's a single collection's directory.
|
||||||
|
;; A hash table can also map #f to a list of paths
|
||||||
|
;; for directories that hold collections.
|
||||||
|
(append
|
||||||
|
(map box (hash-ref (car l) sym null))
|
||||||
|
(hash-ref (car l) #f null)
|
||||||
|
(loop (cdr l)))]
|
||||||
|
[else
|
||||||
|
(let ([ht (get-linked-collections (car l))])
|
||||||
|
(append
|
||||||
|
;; Table values are lists of paths and (box path)s,
|
||||||
|
;; where a (box path) is a collection directory
|
||||||
|
;; (instead of a directory containing collections).
|
||||||
|
(hash-ref ht sym null)
|
||||||
|
(hash-ref ht #f null)
|
||||||
|
(loop (cdr l))))])))])
|
||||||
|
(define-values (done)
|
||||||
|
(lambda (p)
|
||||||
|
(if file-name (build-path p file-name) p)))
|
||||||
|
(define-values (*build-path-rep)
|
||||||
|
(lambda (p c)
|
||||||
|
(if (path? p)
|
||||||
|
(build-path p c)
|
||||||
|
;; box => from links table for c
|
||||||
|
(unbox p))))
|
||||||
|
(define-values (*directory-exists?)
|
||||||
|
(lambda (orig p)
|
||||||
|
(if (path? orig)
|
||||||
|
(directory-exists? p)
|
||||||
|
;; orig is box => from links table
|
||||||
|
#t)))
|
||||||
|
(define-values (to-string) (lambda (p) (if (path? p) (path->string p) p)))
|
||||||
|
(let cloop ([paths all-paths] [found-col #f])
|
||||||
|
(if (null? paths)
|
||||||
|
(if found-col
|
||||||
|
(done found-col)
|
||||||
|
(let ([rest-coll
|
||||||
|
(if (null? collection-path)
|
||||||
|
""
|
||||||
|
(apply
|
||||||
|
string-append
|
||||||
|
(let loop ([cp collection-path])
|
||||||
|
(if (null? (cdr cp))
|
||||||
|
(list (to-string (car cp)))
|
||||||
|
(list* (to-string (car cp)) "/" (loop (cdr cp)))))))])
|
||||||
|
(define-values (filter)
|
||||||
|
(lambda (f l)
|
||||||
|
(if (null? l)
|
||||||
|
null
|
||||||
|
(if (f (car l))
|
||||||
|
(cons (car l) (filter f (cdr l)))
|
||||||
|
(filter f (cdr l))))))
|
||||||
|
(fail
|
||||||
|
(format "collection not found\n collection: ~s\n in collection directories:~a~a"
|
||||||
|
(if (null? collection-path)
|
||||||
|
(to-string collection)
|
||||||
|
(string-append (to-string collection) "/" rest-coll))
|
||||||
|
(apply
|
||||||
|
string-append
|
||||||
|
(map (lambda (p)
|
||||||
|
(format "\n ~a ~a" " " p))
|
||||||
|
(let ([len (length all-paths)]
|
||||||
|
[clen (length (current-library-collection-paths))])
|
||||||
|
(if ((- len clen) . < . 5)
|
||||||
|
all-paths
|
||||||
|
(append (current-library-collection-paths)
|
||||||
|
(list (format "... [~a additional linked and package directories]"
|
||||||
|
(- len clen))))))))
|
||||||
|
(if (ormap box? all-paths)
|
||||||
|
(format "\n sub-collection: ~s\n in parent directories:~a"
|
||||||
|
rest-coll
|
||||||
|
(apply
|
||||||
|
string-append
|
||||||
|
(map (lambda (p)
|
||||||
|
(format "\n ~a" (unbox p)))
|
||||||
|
(filter box? all-paths))))
|
||||||
|
"")))))
|
||||||
|
(let ([dir (*build-path-rep (car paths) collection)])
|
||||||
|
(if (*directory-exists? (car paths) dir)
|
||||||
|
(let ([cpath (apply build-path dir collection-path)])
|
||||||
|
(if (if (null? collection-path)
|
||||||
|
#t
|
||||||
|
(directory-exists? cpath))
|
||||||
|
(if file-name
|
||||||
|
(if (or (file-exists?/maybe-compiled cpath file-name
|
||||||
|
check-compiled?)
|
||||||
|
(let ([alt-file-name
|
||||||
|
(let* ([file-name (if (path? file-name)
|
||||||
|
(path->string file-name)
|
||||||
|
file-name)]
|
||||||
|
[len (string-length file-name)])
|
||||||
|
(and (len . >= . 4)
|
||||||
|
(string=? ".rkt" (substring file-name (- len 4)))
|
||||||
|
(string-append (substring file-name 0 (- len 4)) ".ss")))])
|
||||||
|
(and alt-file-name
|
||||||
|
(file-exists?/maybe-compiled cpath alt-file-name
|
||||||
|
check-compiled?))))
|
||||||
|
(done cpath)
|
||||||
|
;; Look further for specific file, but remember
|
||||||
|
;; first found directory
|
||||||
|
(cloop (cdr paths) (or found-col cpath)))
|
||||||
|
;; Just looking for dir; found it:
|
||||||
|
(done cpath))
|
||||||
|
;; sub-collection not here; try next instance
|
||||||
|
;; of the top-level collection
|
||||||
|
(cloop (cdr paths) found-col)))
|
||||||
|
(cloop (cdr paths) found-col)))))))))
|
||||||
|
|
||||||
|
(define-values (file-exists?/maybe-compiled)
|
||||||
|
(lambda (dir path check-compiled?)
|
||||||
|
(or (file-exists? (build-path dir path))
|
||||||
|
(and check-compiled?
|
||||||
|
(let ([try-path (path-add-extension path #".zo")]
|
||||||
|
[modes (use-compiled-file-paths)]
|
||||||
|
[roots (current-compiled-file-roots)])
|
||||||
|
(ormap (lambda (d)
|
||||||
|
(ormap (lambda (mode)
|
||||||
|
(file-exists?
|
||||||
|
(let ([p (build-path dir mode try-path)])
|
||||||
|
(cond
|
||||||
|
[(eq? d 'same) p]
|
||||||
|
[(relative-path? d) (build-path p d)]
|
||||||
|
[else (reroot-path p d)]))))
|
||||||
|
modes))
|
||||||
|
roots))))))
|
||||||
|
|
||||||
|
(define-values (find-library-collection-paths)
|
||||||
|
(case-lambda
|
||||||
|
[() (find-library-collection-paths null null)]
|
||||||
|
[(extra-collects-dirs) (find-library-collection-paths extra-collects-dirs null)]
|
||||||
|
[(extra-collects-dirs post-collects-dirs)
|
||||||
|
(let ([user-too? (use-user-specific-search-paths)]
|
||||||
|
[cons-if (lambda (f r) (if f (cons f r) r))]
|
||||||
|
[config-table (get-config-table (find-main-config))])
|
||||||
|
(path-list-string->path-list
|
||||||
|
(if user-too?
|
||||||
|
(let ([c (environment-variables-ref (current-environment-variables)
|
||||||
|
#"PLTCOLLECTS")])
|
||||||
|
(if c
|
||||||
|
(bytes->string/locale c #\?)
|
||||||
|
""))
|
||||||
|
"")
|
||||||
|
(add-config-search
|
||||||
|
config-table
|
||||||
|
'collects-search-dirs
|
||||||
|
(cons-if
|
||||||
|
(and user-too?
|
||||||
|
(build-path (find-system-path 'addon-dir)
|
||||||
|
(get-installation-name config-table)
|
||||||
|
"collects"))
|
||||||
|
(let loop ([l (append
|
||||||
|
extra-collects-dirs
|
||||||
|
(list (find-system-path 'collects-dir))
|
||||||
|
post-collects-dirs)])
|
||||||
|
(if (null? l)
|
||||||
|
null
|
||||||
|
(let* ([collects-path (car l)]
|
||||||
|
[v (exe-relative-path->complete-path collects-path)])
|
||||||
|
(if v
|
||||||
|
(cons (simplify-path (path->complete-path v (current-directory)))
|
||||||
|
(loop (cdr l)))
|
||||||
|
(loop (cdr l))))))))))])))
|
||||||
43
racket/collects/racket/private/config.rkt
Normal file
43
racket/collects/racket/private/config.rkt
Normal file
|
|
@ -0,0 +1,43 @@
|
||||||
|
(module config '#%kernel
|
||||||
|
(#%require '#%paramz ; for cache-configuration
|
||||||
|
"cond.rkt"
|
||||||
|
"qq-and-or.rkt"
|
||||||
|
"executable-path.rkt")
|
||||||
|
|
||||||
|
(#%provide find-main-collects
|
||||||
|
find-main-config
|
||||||
|
|
||||||
|
exe-relative-path->complete-path)
|
||||||
|
|
||||||
|
(define-values (find-main-collects)
|
||||||
|
(lambda ()
|
||||||
|
;; Recorded once and for all (per place), which helps avoid
|
||||||
|
;; sandbox problems:
|
||||||
|
(cache-configuration
|
||||||
|
0
|
||||||
|
(lambda ()
|
||||||
|
(exe-relative-path->complete-path (find-system-path 'collects-dir))))))
|
||||||
|
|
||||||
|
(define-values (find-main-config)
|
||||||
|
(lambda ()
|
||||||
|
;; Also recorded once and for all (per place):
|
||||||
|
(cache-configuration
|
||||||
|
1
|
||||||
|
(lambda ()
|
||||||
|
(exe-relative-path->complete-path (find-system-path 'config-dir))))))
|
||||||
|
|
||||||
|
(define-values (exe-relative-path->complete-path)
|
||||||
|
(lambda (collects-path)
|
||||||
|
(cond
|
||||||
|
[(complete-path? collects-path) (simplify-path collects-path)]
|
||||||
|
[(absolute-path? collects-path)
|
||||||
|
;; This happens only under Windows; add a drive
|
||||||
|
;; specification to make the path complete
|
||||||
|
(let ([exec (path->complete-path
|
||||||
|
(find-executable-path (find-system-path 'exec-file))
|
||||||
|
(find-system-path 'orig-dir))])
|
||||||
|
(let-values ([(base name dir?) (split-path exec)])
|
||||||
|
(simplify-path (path->complete-path collects-path base))))]
|
||||||
|
[else
|
||||||
|
(let ([p (find-executable-path (find-system-path 'exec-file) collects-path #t)])
|
||||||
|
(and p (simplify-path p)))]))))
|
||||||
62
racket/collects/racket/private/executable-path.rkt
Normal file
62
racket/collects/racket/private/executable-path.rkt
Normal file
|
|
@ -0,0 +1,62 @@
|
||||||
|
(module path-list '#%kernel
|
||||||
|
(#%require "qq-and-or.rkt"
|
||||||
|
"cond.rkt"
|
||||||
|
"define-et-al.rkt"
|
||||||
|
"path.rkt"
|
||||||
|
"path-list.rkt")
|
||||||
|
|
||||||
|
(#%provide find-executable-path)
|
||||||
|
|
||||||
|
(define-values (find-executable-path)
|
||||||
|
(case-lambda
|
||||||
|
[(program libpath reverse?)
|
||||||
|
(unless (path-string? program)
|
||||||
|
(raise-argument-error 'find-executable-path "path-string?" program))
|
||||||
|
(unless (or (not libpath) (and (path-string? libpath)
|
||||||
|
(relative-path? libpath)))
|
||||||
|
(raise-argument-error 'find-executable-path "(or/c #f (and/c path-string? relative-path?))" libpath))
|
||||||
|
(letrec ([found-exec
|
||||||
|
(lambda (exec-name)
|
||||||
|
(if libpath
|
||||||
|
(let-values ([(base name isdir?) (split-path exec-name)])
|
||||||
|
(let ([next
|
||||||
|
(lambda ()
|
||||||
|
(let ([resolved (resolve-path exec-name)])
|
||||||
|
(cond
|
||||||
|
[(equal? resolved exec-name) #f]
|
||||||
|
[(relative-path? resolved)
|
||||||
|
(found-exec (build-path base resolved))]
|
||||||
|
[else (found-exec resolved)])))])
|
||||||
|
(or (and reverse? (next))
|
||||||
|
(if (path? base)
|
||||||
|
(let ([lib (build-path base libpath)])
|
||||||
|
(and (or (directory-exists? lib)
|
||||||
|
(file-exists? lib))
|
||||||
|
lib))
|
||||||
|
#f)
|
||||||
|
(and (not reverse?) (next)))))
|
||||||
|
exec-name))])
|
||||||
|
(if (and (relative-path? program)
|
||||||
|
(let-values ([(base name dir?) (split-path program)])
|
||||||
|
(eq? base 'relative)))
|
||||||
|
(let ([paths-str (environment-variables-ref (current-environment-variables)
|
||||||
|
#"PATH")]
|
||||||
|
[win-add (lambda (s) (if (eq? (system-type) 'windows)
|
||||||
|
(cons (bytes->path #".") s)
|
||||||
|
s))])
|
||||||
|
(let loop ([paths (win-add
|
||||||
|
(if paths-str
|
||||||
|
(path-list-string->path-list (bytes->string/locale paths-str #\?)
|
||||||
|
null)
|
||||||
|
null))])
|
||||||
|
(if (null? paths)
|
||||||
|
#f
|
||||||
|
(let* ([base (path->complete-path (car paths))]
|
||||||
|
[name (build-path base program)])
|
||||||
|
(if (file-exists? name)
|
||||||
|
(found-exec name)
|
||||||
|
(loop (cdr paths)))))))
|
||||||
|
(let ([p (path->complete-path program)])
|
||||||
|
(and (file-exists? p) (found-exec p)))))]
|
||||||
|
[(program libpath) (find-executable-path program libpath #f)]
|
||||||
|
[(program) (find-executable-path program #f #f)])))
|
||||||
35
racket/collects/racket/private/load.rkt
Normal file
35
racket/collects/racket/private/load.rkt
Normal file
|
|
@ -0,0 +1,35 @@
|
||||||
|
(module load '#%kernel
|
||||||
|
(#%require "qq-and-or.rkt"
|
||||||
|
"more-scheme.rkt"
|
||||||
|
"define-et-al.rkt"
|
||||||
|
"executable-path.rkt")
|
||||||
|
|
||||||
|
(#%provide load/use-compiled
|
||||||
|
embedded-load)
|
||||||
|
|
||||||
|
(define-values (load/use-compiled)
|
||||||
|
(lambda (f) ((current-load/use-compiled) f #f)))
|
||||||
|
|
||||||
|
;; used for the -k command-line argument:
|
||||||
|
(define-values (embedded-load)
|
||||||
|
(lambda (start end str)
|
||||||
|
(let* ([s (if str
|
||||||
|
str
|
||||||
|
(let* ([sp (find-system-path 'exec-file)]
|
||||||
|
[exe (find-executable-path sp #f)]
|
||||||
|
[start (or (string->number start) 0)]
|
||||||
|
[end (or (string->number end) 0)])
|
||||||
|
(with-input-from-file exe
|
||||||
|
(lambda ()
|
||||||
|
(file-position (current-input-port) start)
|
||||||
|
(read-bytes (max 0 (- end start)))))))]
|
||||||
|
[p (open-input-bytes s)])
|
||||||
|
(let loop ()
|
||||||
|
(let ([e (parameterize ([read-accept-compiled #t]
|
||||||
|
[read-accept-reader #t]
|
||||||
|
[read-accept-lang #t]
|
||||||
|
[read-on-demand-source #t])
|
||||||
|
(read p))])
|
||||||
|
(unless (eof-object? e)
|
||||||
|
((current-eval) e)
|
||||||
|
(loop))))))))
|
||||||
|
|
@ -3,8 +3,9 @@
|
||||||
;; #%misc : file utilities, etc. - remaining functions
|
;; #%misc : file utilities, etc. - remaining functions
|
||||||
|
|
||||||
(module misc '#%kernel
|
(module misc '#%kernel
|
||||||
(#%require '#%utils ; built into racket
|
(#%require "small-scheme.rkt" "define.rkt" "path.rkt" "old-path.rkt"
|
||||||
"small-scheme.rkt" "define.rkt" "path.rkt"
|
"path-list.rkt" "executable-path.rkt" "collect.rkt"
|
||||||
|
"reading-param.rkt" "load.rkt"
|
||||||
(for-syntax '#%kernel "qq-and-or.rkt" "stx.rkt" "stxcase-scheme.rkt" "stxcase.rkt"))
|
(for-syntax '#%kernel "qq-and-or.rkt" "stx.rkt" "stxcase-scheme.rkt" "stxcase.rkt"))
|
||||||
|
|
||||||
;; -------------------------------------------------------------------------
|
;; -------------------------------------------------------------------------
|
||||||
|
|
|
||||||
70
racket/collects/racket/private/old-path.rkt
Normal file
70
racket/collects/racket/private/old-path.rkt
Normal file
|
|
@ -0,0 +1,70 @@
|
||||||
|
;; Old variants of `path-replace-extension` and
|
||||||
|
;; `path-add-extension` that do the wrong thing with
|
||||||
|
;; file names that start "."
|
||||||
|
(module path '#%kernel
|
||||||
|
(#%require "qq-and-or.rkt" "define-et-al.rkt")
|
||||||
|
|
||||||
|
(#%provide path-replace-suffix
|
||||||
|
path-add-suffix)
|
||||||
|
|
||||||
|
(define-values (path-string?)
|
||||||
|
(lambda (s)
|
||||||
|
(or (path? s)
|
||||||
|
(and (string? s)
|
||||||
|
(or (relative-path? s)
|
||||||
|
(absolute-path? s))))))
|
||||||
|
|
||||||
|
(define-values (check-suffix-call)
|
||||||
|
(lambda (s sfx who)
|
||||||
|
(unless (or (path-for-some-system? s)
|
||||||
|
(path-string? s))
|
||||||
|
(raise-argument-error who "(or/c path-for-some-system? path-string?)" 0 s sfx))
|
||||||
|
(unless (or (string? sfx) (bytes? sfx))
|
||||||
|
(raise-argument-error who "(or/c string? bytes?)" 1 s sfx))
|
||||||
|
(let-values ([(base name dir?) (split-path s)])
|
||||||
|
(when (not base)
|
||||||
|
(raise-mismatch-error who "cannot add a suffix to a root path: " s))
|
||||||
|
(values base name))))
|
||||||
|
|
||||||
|
(define-values (path-adjust-suffix)
|
||||||
|
(lambda (name sep rest-bytes s sfx)
|
||||||
|
(let-values ([(base name) (check-suffix-call s sfx name)])
|
||||||
|
(-define bs (path-element->bytes name))
|
||||||
|
(-define finish
|
||||||
|
(lambda (i sep i2)
|
||||||
|
(bytes->path-element
|
||||||
|
(let ([res (bytes-append
|
||||||
|
(subbytes bs 0 i)
|
||||||
|
sep
|
||||||
|
(rest-bytes bs i2)
|
||||||
|
(if (string? sfx)
|
||||||
|
(string->bytes/locale sfx (char->integer #\?))
|
||||||
|
sfx))])
|
||||||
|
(if (zero? (bytes-length res))
|
||||||
|
(raise-arguments-error 'path-replace-suffix
|
||||||
|
"removing suffix makes path element empty"
|
||||||
|
"given path" s)
|
||||||
|
res))
|
||||||
|
(if (path-for-some-system? s)
|
||||||
|
(path-convention-type s)
|
||||||
|
(system-path-convention-type)))))
|
||||||
|
(let ([new-name (letrec-values ([(loop)
|
||||||
|
(lambda (i)
|
||||||
|
(if (zero? i)
|
||||||
|
(finish (bytes-length bs) #"" (bytes-length bs))
|
||||||
|
(let-values ([(i) (sub1 i)])
|
||||||
|
(if (eq? (char->integer #\.) (bytes-ref bs i))
|
||||||
|
(finish i sep (add1 i))
|
||||||
|
(loop i)))))])
|
||||||
|
(loop (bytes-length bs)))])
|
||||||
|
(if (path-for-some-system? base)
|
||||||
|
(build-path base new-name)
|
||||||
|
new-name)))))
|
||||||
|
|
||||||
|
(define-values (path-replace-suffix)
|
||||||
|
(lambda (s sfx)
|
||||||
|
(path-adjust-suffix 'path-replace-suffix #"" (lambda (bs i) #"") s sfx)))
|
||||||
|
|
||||||
|
(define-values (path-add-suffix)
|
||||||
|
(lambda (s sfx)
|
||||||
|
(path-adjust-suffix 'path-add-suffix #"_" subbytes s sfx))))
|
||||||
33
racket/collects/racket/private/path-list.rkt
Normal file
33
racket/collects/racket/private/path-list.rkt
Normal file
|
|
@ -0,0 +1,33 @@
|
||||||
|
(module path-list '#%kernel
|
||||||
|
(#%require "qq-and-or.rkt" "define-et-al.rkt")
|
||||||
|
|
||||||
|
(#%provide path-list-string->path-list)
|
||||||
|
|
||||||
|
(define-values (path-list-string->path-list)
|
||||||
|
(let ((r (byte-regexp (string->bytes/utf-8
|
||||||
|
(let ((sep (if (eq? (system-type) 'windows)
|
||||||
|
";"
|
||||||
|
":")))
|
||||||
|
(format "([^~a]*)~a(.*)" sep sep)))))
|
||||||
|
(cons-path (lambda (default s l)
|
||||||
|
(let ([s (if (eq? (system-type) 'windows)
|
||||||
|
(regexp-replace* #rx#"\"" s #"")
|
||||||
|
s)])
|
||||||
|
(if (bytes=? s #"")
|
||||||
|
(append default l)
|
||||||
|
(cons (bytes->path s)
|
||||||
|
l))))))
|
||||||
|
(lambda (s default)
|
||||||
|
(unless (or (bytes? s)
|
||||||
|
(string? s))
|
||||||
|
(raise-argument-error 'path-list-string->path-list "(or/c bytes? string?)" s))
|
||||||
|
(unless (and (list? default)
|
||||||
|
(andmap path? default))
|
||||||
|
(raise-argument-error 'path-list-string->path-list "(listof path?)" default))
|
||||||
|
(let loop ([s (if (string? s)
|
||||||
|
(string->bytes/utf-8 s)
|
||||||
|
s)])
|
||||||
|
(let ([m (regexp-match r s)])
|
||||||
|
(if m
|
||||||
|
(cons-path default (cadr m) (loop (caddr m)))
|
||||||
|
(cons-path default s null))))))))
|
||||||
|
|
@ -1,11 +1,11 @@
|
||||||
;; Old variants of `path-replace-extension` and
|
|
||||||
;; `path-add-extension` that do the wrong thing with
|
|
||||||
;; file names that start "."
|
|
||||||
(module path '#%kernel
|
(module path '#%kernel
|
||||||
(#%require '#%min-stx)
|
(#%require "qq-and-or.rkt" "cond.rkt" "define-et-al.rkt")
|
||||||
|
|
||||||
(#%provide path-replace-suffix
|
(#%provide path-string?
|
||||||
path-add-suffix)
|
normal-case-path
|
||||||
|
path-replace-extension
|
||||||
|
path-add-extension
|
||||||
|
reroot-path)
|
||||||
|
|
||||||
(define-values (path-string?)
|
(define-values (path-string?)
|
||||||
(lambda (s)
|
(lambda (s)
|
||||||
|
|
@ -14,7 +14,38 @@
|
||||||
(or (relative-path? s)
|
(or (relative-path? s)
|
||||||
(absolute-path? s))))))
|
(absolute-path? s))))))
|
||||||
|
|
||||||
(define-values (check-suffix-call)
|
(define-values (bsbs) (string #\u5C #\u5C))
|
||||||
|
|
||||||
|
(define-values (normal-case-path)
|
||||||
|
(lambda (s)
|
||||||
|
(unless (or (path-for-some-system? s)
|
||||||
|
(path-string? s))
|
||||||
|
(raise-argument-error 'normal-path-case "(or/c path-for-some-system? path-string?)" s))
|
||||||
|
(cond
|
||||||
|
[(if (path-for-some-system? s)
|
||||||
|
(eq? (path-convention-type s) 'windows)
|
||||||
|
(eq? (system-type) 'windows))
|
||||||
|
(let ([str (if (string? s) s (bytes->string/locale (path->bytes s)))])
|
||||||
|
(if (regexp-match? #rx"^[\u5C][\u5C][?][\u5C]" str)
|
||||||
|
(if (string? s)
|
||||||
|
(string->path s)
|
||||||
|
s)
|
||||||
|
(let ([s (string-locale-downcase str)])
|
||||||
|
(bytes->path
|
||||||
|
(string->bytes/locale
|
||||||
|
(regexp-replace* #rx"/"
|
||||||
|
(if (regexp-match? #rx"[/\u5C][. ]+[/\u5C]*$" s)
|
||||||
|
;; Just "." or ".." in last path element - don't remove
|
||||||
|
s
|
||||||
|
(regexp-replace* #rx"\u5B .\u5D+([/\u5C]*)$" s "\u005C1"))
|
||||||
|
bsbs))
|
||||||
|
'windows))))]
|
||||||
|
[(string? s) (string->path s)]
|
||||||
|
[else s])))
|
||||||
|
|
||||||
|
;; ----------------------------------------
|
||||||
|
|
||||||
|
(define-values (check-extension-call)
|
||||||
(lambda (s sfx who)
|
(lambda (s sfx who)
|
||||||
(unless (or (path-for-some-system? s)
|
(unless (or (path-for-some-system? s)
|
||||||
(path-string? s))
|
(path-string? s))
|
||||||
|
|
@ -23,28 +54,23 @@
|
||||||
(raise-argument-error who "(or/c string? bytes?)" 1 s sfx))
|
(raise-argument-error who "(or/c string? bytes?)" 1 s sfx))
|
||||||
(let-values ([(base name dir?) (split-path s)])
|
(let-values ([(base name dir?) (split-path s)])
|
||||||
(when (not base)
|
(when (not base)
|
||||||
(raise-mismatch-error who "cannot add a suffix to a root path: " s))
|
(raise-mismatch-error who "cannot add an extension to a root path: " s))
|
||||||
(values base name))))
|
(values base name))))
|
||||||
|
|
||||||
(define-values (path-adjust-suffix)
|
(define-values (path-adjust-extension)
|
||||||
(lambda (name sep rest-bytes s sfx)
|
(lambda (name sep rest-bytes s sfx)
|
||||||
(let-values ([(base name) (check-suffix-call s sfx name)])
|
(let-values ([(base name) (check-extension-call s sfx name)])
|
||||||
(define bs (path-element->bytes name))
|
(-define bs (path-element->bytes name))
|
||||||
(define finish
|
(-define finish
|
||||||
(lambda (i sep i2)
|
(lambda (i sep i2)
|
||||||
(bytes->path-element
|
(bytes->path-element
|
||||||
(let ([res (bytes-append
|
(bytes-append
|
||||||
(subbytes bs 0 i)
|
(subbytes bs 0 i)
|
||||||
sep
|
sep
|
||||||
(rest-bytes bs i2)
|
(rest-bytes bs i2)
|
||||||
(if (string? sfx)
|
(if (string? sfx)
|
||||||
(string->bytes/locale sfx (char->integer #\?))
|
(string->bytes/locale sfx (char->integer #\?))
|
||||||
sfx))])
|
sfx))
|
||||||
(if (zero? (bytes-length res))
|
|
||||||
(raise-arguments-error 'path-replace-suffix
|
|
||||||
"removing suffix makes path element empty"
|
|
||||||
"given path" s)
|
|
||||||
res))
|
|
||||||
(if (path-for-some-system? s)
|
(if (path-for-some-system? s)
|
||||||
(path-convention-type s)
|
(path-convention-type s)
|
||||||
(system-path-convention-type)))))
|
(system-path-convention-type)))))
|
||||||
|
|
@ -53,7 +79,8 @@
|
||||||
(if (zero? i)
|
(if (zero? i)
|
||||||
(finish (bytes-length bs) #"" (bytes-length bs))
|
(finish (bytes-length bs) #"" (bytes-length bs))
|
||||||
(let-values ([(i) (sub1 i)])
|
(let-values ([(i) (sub1 i)])
|
||||||
(if (eq? (char->integer #\.) (bytes-ref bs i))
|
(if (and (not (zero? i))
|
||||||
|
(eq? (char->integer #\.) (bytes-ref bs i)))
|
||||||
(finish i sep (add1 i))
|
(finish i sep (add1 i))
|
||||||
(loop i)))))])
|
(loop i)))))])
|
||||||
(loop (bytes-length bs)))])
|
(loop (bytes-length bs)))])
|
||||||
|
|
@ -61,10 +88,65 @@
|
||||||
(build-path base new-name)
|
(build-path base new-name)
|
||||||
new-name)))))
|
new-name)))))
|
||||||
|
|
||||||
(define-values (path-replace-suffix)
|
(define-values (path-replace-extension)
|
||||||
(lambda (s sfx)
|
(lambda (s sfx)
|
||||||
(path-adjust-suffix 'path-replace-suffix #"" (lambda (bs i) #"") s sfx)))
|
(path-adjust-extension 'path-replace-extension #"" (lambda (bs i) #"") s sfx)))
|
||||||
|
|
||||||
(define-values (path-add-suffix)
|
(define-values (path-add-extension)
|
||||||
(lambda (s sfx)
|
(lambda (s sfx)
|
||||||
(path-adjust-suffix 'path-add-suffix #"_" subbytes s sfx))))
|
(path-adjust-extension 'path-add-extension #"_" subbytes s sfx)))
|
||||||
|
|
||||||
|
;; ----------------------------------------
|
||||||
|
|
||||||
|
|
||||||
|
|
||||||
|
(define-values (reroot-path)
|
||||||
|
(lambda (p root)
|
||||||
|
(unless (or (path-string? p) (path-for-some-system? p))
|
||||||
|
(raise-argument-error 'reroot-path "(or/c path-string? path-for-some-system?)" 0 p root))
|
||||||
|
(unless (or (path-string? root) (path-for-some-system? root))
|
||||||
|
(raise-argument-error 'reroot-path "(or/c path-string? path-for-some-system?)" 1 p root))
|
||||||
|
(-define conv (if (path-for-some-system? p)
|
||||||
|
(path-convention-type p)
|
||||||
|
(system-path-convention-type)))
|
||||||
|
(unless (or (complete-path? p)
|
||||||
|
(eq? (system-path-convention-type) conv))
|
||||||
|
(raise-arguments-error 'reroot-path
|
||||||
|
"path is not complete and not the platform's convention"
|
||||||
|
"path" p
|
||||||
|
"platform convention type" (system-path-convention-type)))
|
||||||
|
(unless (eq? (if (path-for-some-system? root)
|
||||||
|
(path-convention-type root)
|
||||||
|
(system-path-convention-type))
|
||||||
|
conv)
|
||||||
|
(raise-arguments-error 'reroot-path
|
||||||
|
"given paths use different conventions"
|
||||||
|
"path" p
|
||||||
|
"root path" root))
|
||||||
|
(-define c-p (normal-case-path (cleanse-path (if (complete-path? p)
|
||||||
|
p
|
||||||
|
(path->complete-path p)))))
|
||||||
|
(-define bstr (path->bytes c-p))
|
||||||
|
(cond
|
||||||
|
[(eq? conv 'unix)
|
||||||
|
(if (bytes=? bstr #"/")
|
||||||
|
(if (path-for-some-system? root)
|
||||||
|
root
|
||||||
|
(string->path root))
|
||||||
|
(build-path root (bytes->path (subbytes (path->bytes c-p) 1) conv)))]
|
||||||
|
[(eq? conv 'windows)
|
||||||
|
(build-path
|
||||||
|
root
|
||||||
|
(bytes->path
|
||||||
|
(cond
|
||||||
|
((regexp-match? #rx"^\\\\\\\\[?]\\\\[a-z]:" bstr)
|
||||||
|
(bytes-append #"\\\\?\\REL\\" (subbytes bstr 4 5) #"\\" (subbytes bstr 6)))
|
||||||
|
((regexp-match? #rx"^\\\\\\\\[?]\\\\UNC\\\\" bstr)
|
||||||
|
(bytes-append #"\\\\?\\REL\\" (subbytes bstr 4)))
|
||||||
|
((regexp-match? #rx"^\\\\\\\\[?]\\\\UNC\\\\" bstr)
|
||||||
|
(bytes-append #"\\\\?\\REL\\" (subbytes bstr 4)))
|
||||||
|
((regexp-match? #rx"^\\\\\\\\" bstr)
|
||||||
|
(bytes-append #"UNC\\" (subbytes bstr 2)))
|
||||||
|
((regexp-match? #rx"^[a-z]:" bstr)
|
||||||
|
(bytes-append (subbytes bstr 0 1) (subbytes bstr 2))))
|
||||||
|
conv))]))))
|
||||||
|
|
|
||||||
29
racket/collects/racket/private/reading-param.rkt
Normal file
29
racket/collects/racket/private/reading-param.rkt
Normal file
|
|
@ -0,0 +1,29 @@
|
||||||
|
(module reading-params '#%kernel
|
||||||
|
(#%require "more-scheme.rkt" "qq-and-or.rkt")
|
||||||
|
(#%provide call-with-default-reading-parameterization)
|
||||||
|
|
||||||
|
(define-values (call-with-default-reading-parameterization)
|
||||||
|
(lambda (thunk)
|
||||||
|
(if (and (procedure? thunk)
|
||||||
|
(procedure-arity-includes? thunk 0))
|
||||||
|
(parameterize ([read-case-sensitive #t]
|
||||||
|
[read-square-bracket-as-paren #t]
|
||||||
|
[read-curly-brace-as-paren #t]
|
||||||
|
[read-square-bracket-with-tag #f]
|
||||||
|
[read-curly-brace-with-tag #f]
|
||||||
|
[read-accept-box #t]
|
||||||
|
[read-accept-compiled #f]
|
||||||
|
[read-accept-bar-quote #t]
|
||||||
|
[read-accept-graph #t]
|
||||||
|
[read-decimal-as-inexact #t]
|
||||||
|
[read-cdot #f]
|
||||||
|
[read-accept-dot #t]
|
||||||
|
[read-accept-infix-dot #t]
|
||||||
|
[read-accept-quasiquote #t]
|
||||||
|
[read-accept-reader #f]
|
||||||
|
[read-accept-lang #t]
|
||||||
|
[current-readtable #f])
|
||||||
|
(thunk))
|
||||||
|
(raise-argument-error 'call-with-default-reading-parameterization
|
||||||
|
"(procedure-arity-includes/c 0)"
|
||||||
|
thunk)))))
|
||||||
Loading…
Reference in New Issue
Block a user