source: project/release/4/signal-diagram/tags/3.4/expr-utils.scm @ 30918

Last change on this file since 30918 was 30918, checked in by Ivan Raikov, 6 years ago

signal-diagram release 3.4

File size: 6.1 KB
Line 
1;;       
2;;
3;; Utility procedures for manipulating arithmetic expressions.
4;;
5;; Copyright 2008-2013 Ivan Raikov and the Okinawa Institute of Science and Technology
6;;
7;; This program is free software: you can redistribute it and/or
8;; modify it under the terms of the GNU General Public License as
9;; published by the Free Software Foundation, either version 3 of the
10;; License, or (at your option) any later version.
11;;
12;; This program is distributed in the hope that it will be useful, but
13;; WITHOUT ANY WARRANTY; without even the implied warranty of
14;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
15;; General Public License for more details.
16;;
17;; A full copy of the GPL license can be found at
18;; <http://www.gnu.org/licenses/>.
19;;
20
21
22(define symbolic-constants `(false true random.normal random.uniform random.poisson))
23
24
25(define (sexp->value sexp)
26  (cond
27        ((and (pair? sexp) (eq? 'if (car sexp)))
28         (V:Ifv (sexp->value (cadr sexp)) 
29                (sexp->value (caddr sexp))
30                (sexp->value (cadddr sexp))))
31        ((and (pair? sexp) (symbol? (car sexp)))
32         (V:Op (car sexp) (map sexp->value (cdr sexp))))
33        ((number? sexp)
34         (V:C (exact->inexact sexp)))
35        ((symbol? sexp)
36         (V:Var sexp))
37        ((null? sexp)
38         (V:Var 'null))
39        (else
40         (error 'sexp->value "invalid value s-expression" sexp)))
41  )
42
43
44(define (function->expr name fd)
45  (let ((r (sexp->value (function-body fd))))
46    (if (pair? (function-formals fd))
47        (B:Val name (V:Fn (function-formals fd) (E:Ret r)))
48        (B:Val name r))
49    ))
50
51
52(define (prim->expr name fd)
53  (let ((r (sexp->value (prim-body fd))))
54    (if (null? (prim-formals fd))
55        (B:Val name r)
56        (B:Val name (V:Fn (append (prim-formals fd) (lset-difference eq? (prim-states fd) (prim-formals fd))) (E:Ret r)))
57        )
58    ))
59
60(define (prim->init name fd)
61  (let ((r (sexp->value (prim-init fd))))
62    (B:Val name r)
63    ))
64
65
66(define (enum-freevars expr bnds ax)
67  (cond ((pair? expr)
68         (case (car expr)
69           ((if) (let ((es (cdr expr))) 
70                   (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es)))
71           ((let)
72            (let ((lbnds (cadr expr))
73                  (body (caddr expr)))
74              (let ((bnds1 (append (map first lbnds) bnds)))
75                (enum-freevars body bnds1 
76                               (fold (lambda (x ax) (enum-freevars x bnds ax)) ax
77                                     (map second lbnds))))))
78           (else
79            (let ((s (car expr)) (es (cdr expr)))
80              (if (symbol? s)  (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es) ax)))
81           ))
82        (else
83         (let ((id expr))
84           (if (and (symbol? id) (not (member id bnds)))  (cons id ax) ax)))))
85
86
87#|
88
89
90(define (enum-bnds expr ax)
91  (match expr
92         (('if . es)        (fold enum-bnds ax es))
93         (('let bnds body)  (enum-bnds body (append (map car bnds) (fold enum-bnds ax (map cadr bnds)))))
94         ((s . es)          (if (symbol? s)  (fold enum-bnds ax es) ax))
95         (else ax)))
96
97
98(define (enum-freevars expr bnds ax)
99  (match expr
100         (('if . es) 
101          (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es))
102         (('let lbnds body) 
103          (let ((bnds1 (append (map first lbnds) bnds)))
104            (enum-freevars body bnds1
105             (fold (lambda (x ax) (enum-freevars x bnds ax)) ax
106                   (map second lbnds)))))
107         ((s . es)    (if (symbol? s)  (fold (lambda (x ax) (enum-freevars x bnds ax)) ax es) ax))
108         (id          (if (and (symbol? id) (not (member id bnds)))  (cons id ax) ax))))
109
110
111(define (if-convert expr)
112  (match expr
113         (('if c t e)
114          (let ((r (gensym "if")))
115            `(let ((,r (if ,(if-convert c) ,(if-convert t) ,(if-convert e)))) 
116               ,r)))
117         (('let bs e)
118          `(let ,(map (lambda (b) `(,(car b) ,(if-convert (cadr b)))) bs) ,(if-convert e)))
119         ((f . es)
120          (cons f (map if-convert es)))
121         ((? atom? ) expr)))
122
123         
124(define (let-enum expr ax)
125  (match expr
126         (('let ((x ('if c t e))) y)
127          (let ((ax (fold let-enum ax (list c ))))
128            (if (eq? x y)  (append ax (list (list x `(if ,c ,t ,e)))) ax)))
129
130         (('let bnds body)  (append ax bnds))
131
132         (('if c t e)  (let-enum c ax))
133
134         ((f . es)  (fold let-enum ax es))
135
136         (else ax)))
137
138
139(define (let-elim expr)
140  (match expr
141         (('let ((x ('if c t e))) y)
142          (if (eq? x y)  y expr))
143
144         (('let bnds body) body)
145
146         (('if c t e)  `(if ,(let-elim c) ,(let-lift t) ,(let-lift e)))
147
148         ((f . es)  `(,f . ,(map let-elim es)))
149
150         (else expr)))
151 
152
153(define (let-lift expr)
154  (define (fbnds bnds)
155    (let ((bnds0
156           (fold (lambda (b ax)
157                   (let ((bexpr  (cadr b)))
158                     (match bexpr
159                            (('let bnds expr) (append bnds ax))
160                            (else (append (let-enum bexpr (list)) ax)))))
161                 '() bnds)))
162      bnds0))
163  (let ((expr1
164         (match expr
165                (('let bnds expr)
166                 (let ((bnds0 (fbnds bnds))
167                       (expr1
168                        `(let  ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds)
169                           ,(let-lift expr))))
170                     (if (null? bnds0) expr1 `(let ,bnds0 ,expr1))))
171
172                (else
173                 (let ((bnds (let-enum expr (list))))
174                   (if (null? bnds)
175                       (let-elim expr)
176                       (let ((bnds0 (fbnds bnds))
177                             (expr1 `(let ,(map (lambda (b) (list (car b) (let-elim (cadr b)))) bnds)
178                                       ,(let-elim expr))))
179                         (if (null? bnds0) expr1 `(let ,bnds0 ,expr1))))))
180                )))
181    (if (equal? expr expr1) expr1
182        (let-lift expr1))))
183
184
185(define (lookup-def k lst . rest)
186  (let-optionals rest ((default #f))
187    (let ((k (->string k)))
188     (let recur ((kv #f) (lst lst))
189       (if (or kv (null? lst))
190        (if (not kv) default
191            (match kv ((k v) v) (else (cdr kv))))
192        (let ((kv (car lst)))
193          (recur (and (string=? (->string (car kv)) k) kv)
194                 (cdr lst)) ))))))
195
196
197(define (subst-term t subst k)
198  (assert (every symbol? (map car subst)))
199  (match t
200         (('if c t e)
201          `(if ,(k c subst) ,(k t subst) ,(k e subst)))
202                 
203         (('let bs e)
204          (let ((r `(let ,(map (lambda (b) `(,(car b) ,(k (cadr b) subst))) bs) ,(k e subst))))
205            (k r subst)))
206                 
207         ((f . es)
208          (cons (k f subst) (map (lambda (e) (k e subst)) es)))
209         
210         ((? symbol? )  (lookup-def t subst t))
211         
212         ((? atom? ) t)))
213   
214
215(define (binding? t)
216  (and (list? t) (eq? 'let (car t)) (cdr t)))
217
218(define (bind ks vs e) `(let ,(zip ks vs) ,e))
219
220(define (canonicalize-expr expr)
221  (let ((subst-convert  (subst-driver (lambda (x) (and (symbol? x) x)) binding? identity bind subst-term)))
222    (let* ((expr1 (if-convert expr))
223           (expr2 (subst-convert expr1 subst-empty))
224           (expr3 (let-lift expr2)))
225      expr3)))
226
227|#
Note: See TracBrowser for help on using the repository browser.