rewriting paths to be relative to a directory
This commit is contained in:
Danny Yoo
parent
75f37c661c
commit
cceec4ccd7
|
|
@ -1 +0,0 @@
|
|||
This holds file that may be dead code.
|
||||
|
|
@ -1,20 +0,0 @@
|
|||
#lang racket/base
|
||||
(require compiler/decompile
|
||||
compiler/zo-parse)
|
||||
|
||||
;; A little bit of code to see how Racket really compiles code.
|
||||
|
||||
(require scheme/pretty)
|
||||
|
||||
(provide try)
|
||||
|
||||
(define (try e)
|
||||
(let ([out (open-output-bytes)])
|
||||
(write (parameterize ([current-namespace (make-base-namespace)])
|
||||
(compile e))
|
||||
out)
|
||||
(let ([inp (open-input-bytes (get-output-bytes out))])
|
||||
|
||||
(pretty-print
|
||||
(zo-parse inp)))))
|
||||
|
||||
|
|
@ -1,104 +0,0 @@
|
|||
#lang typed/racket/base
|
||||
|
||||
(require "sets.rkt"
|
||||
racket/list
|
||||
racket/match)
|
||||
|
||||
|
||||
;; What's the input?
|
||||
;; What's the output?
|
||||
|
||||
;; A label has a name and ends with a branch.
|
||||
(define-struct: label ([name : Symbol]
|
||||
[code : Any]
|
||||
[branch : Branch]
|
||||
;; The values below will be initialized.
|
||||
[inlabels : (Setof label)]
|
||||
[outlabels : (Setof label)]
|
||||
[inlabels* : (Setof label)]
|
||||
[outlabels* : (Setof label)])
|
||||
#:transparent)
|
||||
|
||||
|
||||
(: new-label (Symbol Branch -> label))
|
||||
;; Creates a label that's fairly uninitialized.
|
||||
(define (new-label a-name a-branch)
|
||||
(make-label a-name #f a-branch (new-seteq) (new-seteq) (new-seteq) (new-seteq)))
|
||||
|
||||
|
||||
;; A branch is either simple, or branching.
|
||||
(define-type Branch (U Symbol ;; simple, direct branch
|
||||
#f ;; leaf
|
||||
branching))
|
||||
(define-struct: branching ([consequent : Symbol]
|
||||
[alternative : Symbol])
|
||||
#:transparent)
|
||||
|
||||
|
||||
|
||||
|
||||
;; A soup is a set of labels.
|
||||
(define-struct: soup ([labels : (HashTable Symbol label)])
|
||||
#:transparent)
|
||||
|
||||
(: new-soup ((Listof label) -> soup))
|
||||
;; Constructs a new soup.
|
||||
(define (new-soup labels)
|
||||
(let: ([ht : (HashTable Symbol label) (make-hash)])
|
||||
;; First install the labels.
|
||||
(for-each (lambda: ([l : label])
|
||||
(hash-set! ht (label-name l) l))
|
||||
labels)
|
||||
;; Next, initialize the in and out edges.
|
||||
(let: ([a-soup : soup (make-soup ht)])
|
||||
(for-each (lambda: ([l : label])
|
||||
(match (label-branch l)
|
||||
[(and n (? symbol?))
|
||||
(set-insert! (label-outlabels l) (soup-lookup a-soup n))
|
||||
(set-insert! (label-inlabels (soup-lookup a-soup n))
|
||||
l)]
|
||||
['#f
|
||||
(void)]
|
||||
[(struct branching (c a))
|
||||
(set-insert! (label-outlabels l) (soup-lookup a-soup c))
|
||||
(set-insert! (label-outlabels l) (soup-lookup a-soup a))
|
||||
|
||||
(set-insert! (label-inlabels (soup-lookup a-soup c))
|
||||
l)
|
||||
(set-insert! (label-inlabels (soup-lookup a-soup a))
|
||||
l)]))
|
||||
labels)
|
||||
a-soup)))
|
||||
|
||||
|
||||
(: soup-lookup (soup Symbol -> label))
|
||||
(define (soup-lookup a-soup a-name)
|
||||
(hash-ref (soup-labels a-soup) a-name))
|
||||
|
||||
|
||||
;; What is a sample Soup?
|
||||
(define a-soup (new-soup (list
|
||||
(new-label 'ENTRY 'e2)
|
||||
(new-label 'e2 (make-branching 'e5 'e12))
|
||||
(new-label 'e5 'e9)
|
||||
(new-label 'e9 'e2)
|
||||
(new-label 'e12 #f))))
|
||||
|
||||
|
||||
|
||||
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
|
||||
|
||||
(define-type Block (U basic-block
|
||||
loop-block
|
||||
multiple-block))
|
||||
|
||||
(define-struct: basic-block ([label : label]
|
||||
[next : Block]))
|
||||
|
||||
(define-struct: loop-block ([inner : Block]
|
||||
[next : Block]))
|
||||
|
||||
(define-struct: multiple-block ([handled : (Listof Block)]
|
||||
[next : Block]))
|
||||
76
path-rewriter.rkt
Normal file
76
path-rewriter.rkt
Normal file
|
|
@ -0,0 +1,76 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/path
|
||||
racket/contract
|
||||
racket/list)
|
||||
|
||||
|
||||
|
||||
(provide/contract [rewrite-path (complete-path? . -> . (or/c symbol? false/c))]
|
||||
[current-root-path parameter?])
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define current-root-path
|
||||
(make-parameter (current-directory)))
|
||||
|
||||
|
||||
;; The path rewriter takes paths and provides a canonical symbol for it.
|
||||
;; Paths located within collects get remapped to collects/....
|
||||
|
||||
|
||||
;; rewrite-path: complete-path -> (symbol #f)
|
||||
(define (rewrite-path a-path)
|
||||
(cond
|
||||
[(within-collects? a-path)
|
||||
(string->symbol
|
||||
(string-append "collects/"
|
||||
(path->string
|
||||
(find-relative-path collects a-path))))]
|
||||
[(within-root? a-path)
|
||||
(string->symbol
|
||||
(string-append "root/"
|
||||
(path->string
|
||||
(find-relative-path (current-root-path) a-path))))]
|
||||
[else
|
||||
#f]))
|
||||
|
||||
|
||||
(define collects
|
||||
(normalize-path
|
||||
(let ([p (find-system-path 'collects-dir)])
|
||||
(cond
|
||||
[(relative-path? p)
|
||||
(find-executable-path (find-system-path 'exec-file)
|
||||
(find-system-path 'collects-dir))]
|
||||
[else
|
||||
p]))))
|
||||
|
||||
|
||||
|
||||
(define (within-root? a-path)
|
||||
(within? (current-root-path) a-path))
|
||||
|
||||
|
||||
(define (within-collects? a-path)
|
||||
(within? collects a-path))
|
||||
|
||||
|
||||
;; within?: normalized-path normalized-path -> boolean
|
||||
;; Produces true if a-path is within the base.
|
||||
(define (within? base a-path)
|
||||
(let ([rp (find-relative-path base a-path)])
|
||||
(cond
|
||||
[(equal? rp a-path)
|
||||
#f]
|
||||
[else
|
||||
(let ([chunks (explode-path rp)])
|
||||
(cond
|
||||
[(empty? chunks)
|
||||
#t]
|
||||
[(eq? (first chunks) 'up)
|
||||
#f]
|
||||
[else
|
||||
#t]))])))
|
||||
Loading…
Reference in New Issue
Block a user