source: project/release/4/varsubst/trunk/varsubst.scm @ 27288

Last change on this file since 27288 was 27288, checked in by Ivan Raikov, 8 years ago

varsubst: use string->symbol for symbols produced by gensym

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