From cceec4ccd7f15d8c3e179f55ba02221db63c5a64 Mon Sep 17 00:00:00 2001 From: Danny Yoo Date: Fri, 13 May 2011 14:35:41 -0400 Subject: [PATCH] rewriting paths to be relative to a directory --- dead/README | 1 - dead/experiment.rkt | 20 --------- dead/relooper.rkt | 104 -------------------------------------------- path-rewriter.rkt | 76 ++++++++++++++++++++++++++++++++ 4 files changed, 76 insertions(+), 125 deletions(-) delete mode 100644 dead/README delete mode 100644 dead/experiment.rkt delete mode 100644 dead/relooper.rkt create mode 100644 path-rewriter.rkt diff --git a/dead/README b/dead/README deleted file mode 100644 index f9e0dc8..0000000 --- a/dead/README +++ /dev/null @@ -1 +0,0 @@ -This holds file that may be dead code. \ No newline at end of file diff --git a/dead/experiment.rkt b/dead/experiment.rkt deleted file mode 100644 index 02b8b47..0000000 --- a/dead/experiment.rkt +++ /dev/null @@ -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))))) - diff --git a/dead/relooper.rkt b/dead/relooper.rkt deleted file mode 100644 index 940e229..0000000 --- a/dead/relooper.rkt +++ /dev/null @@ -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])) \ No newline at end of file diff --git a/path-rewriter.rkt b/path-rewriter.rkt new file mode 100644 index 0000000..fc20bba --- /dev/null +++ b/path-rewriter.rkt @@ -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]))]))) \ No newline at end of file