← Back to branch summary

~ubuntu-branches/ubuntu/hardy/texmacs/hardy

« back to all changes in this revision

Viewing changes to TeXmacs/progs/kernel/drd/drd-bind.scm

  • Committer: Bazaar Package Importer
  • Author(s): Ralf Treinen
  • Date: 2004-04-19 20:34:00 UTC
  • Revision ID: james.westby@ubuntu.com-20040419203400-g4e34ih0315wcn8v
Tags: upstream-1.0.3-R2
Import upstream version 1.0.3-R2

Show diffs side-by-side

added added

removed removed

Lines of Context:
TeXmacs/progs/kernel/drd/drd-bind.scm
 
1
 
 
2
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
3
;;
 
4
;; MODULE      : drd-bind.scm
 
5
;; DESCRIPTION : binding variables to values
 
6
;; COPYRIGHT   : (C) 2002  Joris van der Hoeven
 
7
;;
 
8
;; This software falls under the GNU general public license and comes WITHOUT
 
9
;; ANY WARRANTY WHATSOEVER. See the file $TEXMACS_PATH/LICENSE for details.
 
10
;; If you don't have this file, write to the Free Software Foundation, Inc.,
 
11
;; 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
 
12
;;
 
13
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
14
 
 
15
(texmacs-module (kernel drd drd-bind)
 
16
  (:export
 
17
    free-variable free-variable?
 
18
    bind-var bind-unify
 
19
    bind-substitute bind-substitute! bind-expand))
 
20
 
 
21
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
22
;; Is an expression a free variable?
 
23
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
24
 
 
25
(define (free-variable name)
 
26
  (list 'quote name))
 
27
 
 
28
(define (free-variable? expr)
 
29
  "Is the expression @expr a free variable?"
 
30
  (and (list? expr) (= (length expr) 2) (== (car expr) 'quote)))
 
31
 
 
32
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
33
;; Binding variables
 
34
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
35
 
 
36
(define (bind-var var val bl)
 
37
  "Force a binding of variable @var to @val in @bl."
 
38
  (list (acons var val bl)))
 
39
 
 
40
(define (bind-unify var val bl)
 
41
  "Bind variable @var to @val in @bl and unify if the binding already exists."
 
42
  (if (free-variable? val)
 
43
      (let* ((var2 (cadr val))
 
44
             (val2 (assoc-ref bl var2)))
 
45
        (if val2 (bind-unify var val2 bl)
 
46
            (let ((old-val (assoc-ref bl var)))
 
47
              (cond (old-val (bind-unify var2 old-val bl))
 
48
                    ((== var var2) (list bl))
 
49
                    ((and (number? var2)
 
50
                          (or (not (number? var)) (< var var2)))
 
51
                     (bind-var var2 (free-variable var) bl))
 
52
                    (else (bind-var var val bl))))))
 
53
      (let ((old-val (assoc-ref bl var)))
 
54
        (cond ((not old-val) (bind-var var val bl))
 
55
              ((free-variable? old-val)
 
56
               (bind-unify (cadr old-val) val bl))
 
57
              (else (unify (list val) (list old-val) bl))))))
 
58
 
 
59
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
60
;; Substitution
 
61
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
62
 
 
63
(define (bind-substitute expr bl)
 
64
  "Substitute bindings @bl in expression @expr."
 
65
  ;; does full substitution if the bindings have been expanded
 
66
  (cond ((or (null? expr) (not (pair? expr))) expr)
 
67
        ((free-variable? expr)
 
68
         (let ((val (assoc-ref bl (cadr expr))))
 
69
           (if val val expr)))
 
70
        (else (cons (bind-substitute (car expr) bl)
 
71
                    (bind-substitute (cdr expr) bl)))))
 
72
 
 
73
(define (bind-substitute! expr bl)
 
74
  "In place substitution of bindings @bl in expression @expr."
 
75
  (if (pair? expr)
 
76
      (begin
 
77
        (if (free-variable? (car expr))
 
78
            (let ((val (assoc-ref bl (cadar expr))))
 
79
              (if val (set-car! expr val)))
 
80
            (bind-substitute! (car expr) bl))
 
81
        (if (free-variable? (cdr expr))
 
82
            (let ((val (assoc-ref bl (caddr expr))))
 
83
              (if val (set-cdr! expr val)))
 
84
            (bind-substitute! (cdr expr) bl)))))
 
85
 
 
86
(define (bind-expand bl2)
 
87
  "Recursively substitute the bindings @bl2 in its own values."
 
88
  (let ((bl (copy-tree bl2)))
 
89
       ; FIXME: would be better to have a cycle-safe copy
 
90
    (for-each (lambda (x) (bind-substitute! x bl)) bl)
 
91
    bl))