source: project/release/3/varsubst/trunk/varsubst.scm @ 12681

Last change on this file since 12681 was 12681, checked in by Ivan Raikov, 13 years ago

Using string comparison, because equal? fails on the same symbols sometimes.

File size: 2.5 KB
Line 
1
2;;
3;; Generalized variable substitution semantics.
4;;
5;; Copyright 2008 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-extension varsubst)
23
24
25(require-extension srfi-1)
26
27(define subst? list?)
28
29(define subst-empty (list))
30(define subst-empty? null?)
31
32(define (subst-includes? k subst)
33  (and (subst? subst) (any (lambda (p) 
34                             (equal? (->string k) (->string (car p)))) subst)))
35
36(define (subst-lookup k subst)
37  (and (subst? subst)
38       (let ((v (find (lambda (p) (equal? (->string k) (->string (car p)))) subst)))
39         (cadr v))))
40
41(define (subst-extend k v subst)
42  (and (subst? subst) (cons (list k v) subst)))
43
44(define (subst-map proc subst)
45  (and (subst? subst)
46       (map (lambda (p) (list (car p) (proc (cadr p)))) subst)))
47
48;; compose a new substitution and an existing substitution environment
49(define (subst-compose a v subst var subst-term)
50  (if (subst-includes? a subst)
51      (let* ((v1 (subst-lookup a subst))
52             (tsubst  (subst-extend a (var v) subst-empty)))
53        (let* ((subst1 (subst-map (lambda (t) (subst-term t tsubst)) subst))
54               (subst2 (subst-extend a (var v) subst1)))
55          (subst-extend v v1 subst2)))
56      (subst-extend a (var v) subst)))
57
58(define (subst-driver var? bind? var bind subst-term . rest)
59  (let-optionals rest ((prefix "v"))
60   (letrec
61       ((k (lambda (t subst)
62             (cond ((var? t)  => (lambda (a) 
63                                   (if (subst-includes? a subst) (subst-lookup a subst) t)))
64                   ((bind? t) =>
65                    (lambda (be) 
66                      (let ((bnds (car be)) (expr (cadr be)))
67                        (let-values (((as us) (unzip2 bnds)))
68                          (let* ((vs (list-tabulate (length as) (lambda (x) (gensym prefix))))
69                                 (ksubst-term  (lambda (t tsubst) (subst-term t tsubst k)))
70                                 (subst1 (fold (lambda (a v subst) (subst-compose a v subst var ksubst-term)) 
71                                               subst as vs)))
72                            (bind vs (map (lambda (u) (subst-term u  subst1 k)) us) (subst-term expr subst1 k)))))))
73                   (else (subst-term t subst k))))))
74     k)))
Note: See TracBrowser for help on using the repository browser.