Showing the changes to test/ast (3 of 18 files). Show all
Unified · Split
| @@ -12,7 +12,7 @@ · 11 unmodified lines | |||
| 12 | (def (index-of item lst start) | 12 | (def (index-of item lst start) |
| 13 | (cond ((not lst) nil) | 13 | (cond ((not lst) nil) |
| 14 | ((eq? item (car lst)) start) | 14 | ((eq? item (car lst)) start) |
| 15 | (#t (index-of item (cdr lst) (+ start 1))))) | 15 | (else (index-of item (cdr lst) (+ start 1))))) |
| 16 | 16 | ||
| 17 | (def (each f l) | 17 | (def (each f l) |
| 18 | (if (not l) l | 18 | (if (not l) l |
| @@ -31,15 +31,15 @@ · 12 unmodified lines | |||
| 31 | (let ((new-t (map (lambda (e) (maptree-post f e)) tr))) | 31 | (let ((new-t (map (lambda (e) (maptree-post f e)) tr))) |
| 32 | (f new-t)))) | 32 | (f new-t)))) |
| 33 | 33 | ||
| 34 | (def (foldtree-pre f t zero) | 34 | (def (foldtree-pre f tr zero) |
| 35 | (if (not (cons? t)) | 35 | (if (not (cons? tr)) |
| 36 | (f t zero) | 36 | (f tr zero) |
| 37 | (foldl t (lambda (e state) (foldtree-pre f e state)) (f t zero)))) | 37 | (foldl tr (lambda (e state) (foldtree-pre f e state)) (f tr zero)))) |
| 38 | 38 | ||
| 39 | (def (foldtree-post f t zero) | 39 | (def (foldtree-post f tr zero) |
| 40 | (if (not (cons? t)) | 40 | (if (not (cons? tr)) |
| 41 | (f t zero) | 41 | (f tr zero) |
| 42 | (f t (foldl t (lambda (e state) (foldtree-post f e state)) zero)))) | 42 | (f tr (foldl tr (lambda (e state) (foldtree-post f e state)) zero)))) |
| 43 | 43 | ||
| 44 | ; general tree transformer | 44 | ; general tree transformer |
| 45 | ; folds in preorder (foldtree-pre), maps in postorder (maptree-post) | 45 | ; folds in preorder (foldtree-pre), maps in postorder (maptree-post) |
| @@ -48,39 +48,39 @@ · 2 unmodified lines | |||
| 48 | ; approach. | 48 | ; approach. |
| 49 | ; (mapper tree state) - should return transformed tree given current state | 49 | ; (mapper tree state) - should return transformed tree given current state |
| 50 | ; (folder tree state) - should return new state | 50 | ; (folder tree state) - should return new state |
| 51 | (def (map&fold t zero mapper folder) | 51 | (def (map&fold tr zero mapper folder) |
| 52 | (let ((head (and (cons? t) (car t)))) | 52 | (let ((head (and (cons? tr) (car tr)))) |
| 53 | (cond ((eq? head 'quote) | 53 | (cond |
| 54 | t) | 54 | ((eq? head 'quote) tr) |
| 55 | ((or (eq? head 'the) (eq? head 'meta)) | 55 | ((or (eq? head 'the) (eq? head 'meta)) |
| 56 | (list head | 56 | (list head |
| 57 | (cadr t) | 57 | (cadr tr) |
| 58 | (map&fold (caddr t) zero mapper folder))) | 58 | (map&fold (caddr tr) zero mapper folder))) |
| 59 | (else | 59 | (else |
| 60 | (let ((new-s (folder t zero))) | 60 | (let ((new-s (folder tr zero))) |
| 61 | (mapper | 61 | (mapper |
| 62 | (if (cons? t) | 62 | (if (cons? tr) |
| 63 | ; head symbol is a tag; never transform it | 63 | ; head symbol is a tag; never transform it |
| 64 | (cons (car t) | 64 | (cons (car tr) |
| 65 | (map (lambda (e) (map&fold e new-s mapper folder)) | 65 | (map (lambda (e) (map&fold e new-s mapper folder)) |
| 66 | (cdr t))) | 66 | (cdr tr))) |
| 67 | t) | 67 | tr) |
| 68 | new-s)))))) | 68 | new-s)))))) |
| 69 | 69 | ||
| 70 | ; convert to proper list, i.e. remove "dots", and append | 70 | ; convert to proper list, i.e. remove "dots", and append |
| 71 | (def (append.2 l tail) | 71 | (def (append.2 l tail) |
| 72 | (cond ((not l) tail) | 72 | (cond ((not l) tail) |
| 73 | ((atom? l) (cons l tail)) | 73 | ((atom? l) (cons l tail)) |
| 74 | (#t (cons (car l) (append.2 (cdr l) tail))))) | 74 | (else (cons (car l) (append.2 (cdr l) tail))))) |
| 75 | 75 | ||
| 76 | ; transform code by calling (f expr env) on each subexpr, where | 76 | ; transform code by calling (f expr env) on each subexpr, where |
| 77 | ; env is a list of lexical variables in effect at that point. | 77 | ; env is a list of lexical variables in effect at that point. |
| 78 | (def (lexical-walk f t) | 78 | (def (lexical-walk f tr) |
| 79 | (map&fold t () f | 79 | (map&fold tr () f |
| 80 | (lambda (tree state) | 80 | (lambda (tree state) |
| 81 | (if (and (eq? (car t) 'lambda) | 81 | (if (and (eq? (car tr) 'lambda) |
| 82 | (cons? (cdr t))) | 82 | (cons? (cdr tr))) |
| 83 | (append.2 (cadr t) state) | 83 | (append.2 (cadr tr) state) |
| 84 | state)))) | 84 | state)))) |
| 85 | 85 | ||
| 86 | ; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e) | 86 | ; collapse forms like (&& (&& (&& (&& a b) c) d) e) to (&& a b c d e) |
| @@ -118,7 +118,7 @@ · 31 unmodified lines | |||
| 118 | (map (lambda (se) (lvc- se newenv)) | 118 | (map (lambda (se) (lvc- se newenv)) |
| 119 | (cddr e)))) | 119 | (cddr e)))) |
| 120 | (map (lambda (se) (lvc- se env)) e))))) | 120 | (map (lambda (se) (lvc- se env)) e))))) |
| 121 | (#t e))) | 121 | (else e))) |
| 122 | (def (lexical-var-conversion e) | 122 | (def (lexical-var-conversion e) |
| 123 | (lvc- e ())) | 123 | (lvc- e ())) |
| 124 | 124 | ||
| @@ -137,19 +137,19 @@ · 12 unmodified lines | |||
| 137 | (map&fold e | 137 | (map&fold e |
| 138 | () | 138 | () |
| 139 | ; mapper: replace symbol if unbound | 139 | ; mapper: replace symbol if unbound |
| 140 | (lambda (t env) | 140 | (lambda (te env) |
| 141 | (if (symbol? t) | 141 | (if (symbol? te) |
| 142 | (let ((found (assq t transl))) | 142 | (let ((found (assq te transl))) |
| 143 | (if (and found | 143 | (if (and found |
| 144 | (not (memq t env))) | 144 | (not (memq te env))) |
| 145 | (cdr found) | 145 | (cdr found) |
| 146 | t)) | 146 | te)) |
| 147 | t)) | 147 | te)) |
| 148 | ; folder: add locals to environment if entering a new scope | 148 | ; folder: add locals to environment if entering a new scope |
| 149 | (lambda (t env) | 149 | (lambda (te env) |
| 150 | (if (and (cons? t) (or (eq? (car t) 'let) | 150 | (if (and (cons? te) (or (eq? (car te) 'let) |
| 151 | (eq? (car t) 'lambda))) | 151 | (eq? (car te) 'lambda))) |
| 152 | (append (cadr t) env) | 152 | (append (cadr te) env) |
| 153 | env)))) | 153 | env)))) |
| 154 | 154 | ||
| 155 | ; flatten op with any associativity | 155 | ; flatten op with any associativity |
| @@ -4,7 +4,7 @@ · 3 unmodified lines | |||
| 4 | 4 | ||
| 5 | (def (unique lst) | 5 | (def (unique lst) |
| 6 | (if (not lst) | 6 | (if (not lst) |
| 7 | () | 7 | nil |
| 8 | (cons (car lst) | 8 | (cons (car lst) |
| 9 | (filter (lambda (x) (not (eq? x (car lst)))) | 9 | (filter (lambda (x) (not (eq? x (car lst)))) |
| 10 | (unique (cdr lst)))))) | 10 | (unique (cdr lst)))))) |
| @@ -20,7 +20,7 @@ · 9 unmodified lines | |||
| 20 | ; p is an expression in the following pattern language: | 20 | ; p is an expression in the following pattern language: |
| 21 | ; | 21 | ; |
| 22 | ; _ match anything, not captured | 22 | ; _ match anything, not captured |
| 23 | ; <func> any scheme function; matches if (func expr) returns #t | 23 | ; <func> any scheme function; matches if (func expr) returns T |
| 24 | ; <var> match anything and capture as <var>. future occurrences of <var> in the pattern | 24 | ; <var> match anything and capture as <var>. future occurrences of <var> in the pattern |
| 25 | ; must match the same thing. | 25 | ; must match the same thing. |
| 26 | ; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the | 26 | ; (head <p1> <p2> etc) match an s-expr with 'head' matched literally, and the rest of the |
| @@ -41,7 +41,7 @@ · 14 unmodified lines | |||
| 41 | (def (match- p expr state) | 41 | (def (match- p expr state) |
| 42 | (cond ((symbol? p) | 42 | (cond ((symbol? p) |
| 43 | (cond ((eq? p '_) state) | 43 | (cond ((eq? p '_) state) |
| 44 | (#t | 44 | (else |
| 45 | (let ((capt (assq p state))) | 45 | (let ((capt (assq p state))) |
| 46 | (if capt | 46 | (if capt |
| 47 | (and (equal? expr (cdr capt)) state) | 47 | (and (equal? expr (cdr capt)) state) |
| @@ -57,13 +57,13 @@ · 9 unmodified lines | |||
| 57 | (and (match- (caddr p) expr state) | 57 | (and (match- (caddr p) expr state) |
| 58 | (cons (cons (cadr p) expr) state))) | 58 | (cons (cons (cadr p) expr) state))) |
| 59 | ((eq? (car p) '-$) ; greedy alternation for toplevel pattern | 59 | ((eq? (car p) '-$) ; greedy alternation for toplevel pattern |
| 60 | (match-alt (cdr p) () (list expr) state nil 1)) | 60 | (match-alt (cdr p) nil (list expr) state nil 1)) |
| 61 | (#t | 61 | (else |
| 62 | (and (cons? expr) | 62 | (and (cons? expr) |
| 63 | (equal? (car p) (car expr)) | 63 | (equal? (car p) (car expr)) |
| 64 | (match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) | 64 | (match-seq (cdr p) (cdr expr) state (length (cdr expr))))))) |
| 65 | 65 | ||
| 66 | (#t | 66 | (else |
| 67 | (and (equal? p expr) state)))) | 67 | (and (equal? p expr) state)))) |
| 68 | 68 | ||
| 69 | ; match an alternation | 69 | ; match an alternation |
| @@ -95,17 +95,17 @@ · 25 unmodified lines | |||
| 95 | (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1) | 95 | (match-star- p prest (cdr expr) state var (- min 1) (- max 1) (- L 1) |
| 96 | (cons (car expr) sofar)))) | 96 | (cons (car expr) sofar)))) |
| 97 | ; otherwise, must match either 0 or between 1 and max subexpressions | 97 | ; otherwise, must match either 0 or between 1 and max subexpressions |
| 98 | (#t | 98 | (else |
| 99 | (or (match-star- p prest expr state var 0 0 L sofar) | 99 | (or (match-star- p prest expr state var 0 0 L sofar) |
| 100 | (match-star- p prest expr state var 1 max L sofar))))) | 100 | (match-star- p prest expr state var 1 max L sofar))))) |
| 101 | (def (match-star p prest expr state var min max L) | 101 | (def (match-star p prest expr state var min max L) |
| 102 | (match-star- p prest expr state var min max L ())) | 102 | (match-star- p prest expr state var min max L nil)) |
| 103 | 103 | ||
| 104 | ; match sequences of expressions | 104 | ; match sequences of expressions |
| 105 | (def (match-seq p expr state L) | 105 | (def (match-seq p expr state L) |
| 106 | (cond ((not state) nil) | 106 | (cond ((not state) nil) |
| 107 | ((not p) (if (not expr) state nil)) | 107 | ((not p) (if (not expr) state nil)) |
| 108 | (#t | 108 | (else |
| 109 | (let ((subp (car p)) | 109 | (let ((subp (car p)) |
| 110 | (var nil)) | 110 | (var nil)) |
| 111 | (if (and (cons? subp) | 111 | (if (and (cons? subp) |
| @@ -113,7 +113,7 @@ · 1 unmodified line | |||
| 113 | (begin (set! var (cadr subp)) | 113 | (begin (set! var (cadr subp)) |
| 114 | (set! subp (caddr subp))) | 114 | (set! subp (caddr subp))) |
| 115 | nil) | 115 | nil) |
| 116 | (let ((head (if (cons? subp) (car subp) ()))) | 116 | (let ((head (if (cons? subp) (car subp) nil))) |
| 117 | (cond ((eq? subp '...) | 117 | (cond ((eq? subp '...) |
| 118 | (match-star '_ (cdr p) expr state var 0 L L)) | 118 | (match-star '_ (cdr p) expr state var 0 L L)) |
| 119 | ((eq? head '-*) | 119 | ((eq? head '-*) |
| @@ -124,7 +124,7 @@ · 4 unmodified lines | |||
| 124 | (match-star (cadr subp) (cdr p) expr state var 0 1 L)) | 124 | (match-star (cadr subp) (cdr p) expr state var 0 1 L)) |
| 125 | ((eq? head '-$) | 125 | ((eq? head '-$) |
| 126 | (match-alt (cdr subp) (cdr p) expr state var L)) | 126 | (match-alt (cdr subp) (cdr p) expr state var L)) |
| 127 | (#t | 127 | (else |
| 128 | (and (cons? expr) | 128 | (and (cons? expr) |
| 129 | (match-seq (cdr p) (cdr expr) | 129 | (match-seq (cdr p) (cdr expr) |
| 130 | (match- (car p) (car expr) state) | 130 | (match- (car p) (car expr) state) |
| @@ -140,10 +140,10 @@ · 9 unmodified lines | |||
| 140 | 140 | ||
| 141 | ((cons? p) | 141 | ((cons? p) |
| 142 | (if (eq? (car p) '-/) | 142 | (if (eq? (car p) '-/) |
| 143 | () | 143 | nil |
| 144 | (unique (apply append (map patargs- (cdr p)))))) | 144 | (unique (apply append (map patargs- (cdr p)))))) |
| 145 | 145 | ||
| 146 | (#t ()))) | 146 | (else nil))) |
| 147 | (def (patargs p) | 147 | (def (patargs p) |
| 148 | (cons '__ (patargs- p))) | 148 | (cons '__ (patargs- p))) |
| 149 | 149 | ||
| @@ -14,7 +14,7 @@ · 13 unmodified lines | |||
| 14 | 14 | ||
| 15 | (def (func-argnames f) | 15 | (def (func-argnames f) |
| 16 | (let ((argl (cadr f))) | 16 | (let ((argl (cadr f))) |
| 17 | (if (eq? argl '*r-null*) () | 17 | (if (eq? argl '*r-null*) nil |
| 18 | (map cadr argl)))) | 18 | (map cadr argl)))) |
| 19 | 19 | ||
| 20 | ; transformations | 20 | ; transformations |
| @@ -49,7 +49,7 @@ · 28 unmodified lines | |||
| 49 | (<<- (r-call f lhs ...) rhs)) | 49 | (<<- (r-call f lhs ...) rhs)) |
| 50 | (let ((g (if (cons? rhs) (r-gensym) rhs)) | 50 | (let ((g (if (cons? rhs) (r-gensym) rhs)) |
| 51 | (op (car __))) | 51 | (op (car __))) |
| 52 | `(r-block ,@(if (cons? rhs) `((ref= ,g ,rhs)) ()) | 52 | `(r-block ,@(if (cons? rhs) `((ref= ,g ,rhs)) nil) |
| 53 | (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g)) | 53 | (,op ,lhs (r-call ,(symconcat f '<-) ,@(cddr (cadr __)) ,g)) |
| 54 | ,g))) | 54 | ,g))) |
| 55 | e)) | 55 | e)) |
| @@ -80,14 +80,14 @@ · 24 unmodified lines | |||
| 80 | e)) | 80 | e)) |
| 81 | 81 | ||
| 82 | (def (find-assigned-vars n) | 82 | (def (find-assigned-vars n) |
| 83 | (let ((vars ())) | 83 | (let ((vars nil)) |
| 84 | (maptree-pre (lambda (s) | 84 | (maptree-pre (lambda (s) |
| 85 | (if (not (cons? s)) s | 85 | (if (not (cons? s)) s |
| 86 | (cond ((eq? (car s) 'lambda) ()) | 86 | (cond ((eq? (car s) 'lambda) nil) |
| 87 | ((eq? (car s) '<-) | 87 | ((eq? (car s) '<-) |
| 88 | (set! vars (list-adjoin (cadr s) vars)) | 88 | (set! vars (list-adjoin (cadr s) vars)) |
| 89 | (cddr s)) | 89 | (cddr s)) |
| 90 | (#t s)))) | 90 | (else s)))) |
| 91 | n) | 91 | n) |
| 92 | vars)) | 92 | vars)) |
| 93 | 93 | ||
| @@ -96,7 +96,7 @@ · 2 unmodified lines | |||
| 96 | (maptree-post (lambda (n) | 96 | (maptree-post (lambda (n) |
| 97 | (if (and (cons? n) (eq? (car n) 'lambda)) | 97 | (if (and (cons? n) (eq? (car n) 'lambda)) |
| 98 | (let ((vars (find-assigned-vars (cddr n)))) | 98 | (let ((vars (find-assigned-vars (cddr n)))) |
| 99 | `(lambda ,(cadr n) (let ,(map (lambda (v) (list v ())) | 99 | `(lambda ,(cadr n) (let ,(map (lambda (v) (list v nil)) |
| 100 | vars) | 100 | vars) |
| 101 | ,@(cddr n)))) | 101 | ,@(cddr n)))) |
| 102 | n)) | 102 | n)) |