/[cl-unification]/cl-unification/substitutions.lisp
ViewVC logotype

Contents of /cl-unification/substitutions.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.8 - (show annotations)
Wed Mar 2 21:43:19 2011 UTC (3 years, 1 month ago) by mantoniotti
Branch: MAIN
CVS Tags: HEAD
Changes since 1.7: +2 -1 lines
Fixed typo.  Double definition of PUSH-FRAME.

Marco
1 ;;;; -*- Mode: Lisp -*-
2
3 ;;;; substitutions.lisp --
4 ;;;; General CL structures unifier.
5 ;;;; Substitution definitions. Mostly a rehash of the usual SICP stuff.
6
7 ;;;; See file COPYING for copyright licensing information.
8
9 (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
10
11 ;;;---------------------------------------------------------------------------
12 ;;; Bindings.
13
14 (deftype binding () 'cons)
15
16 (deftype bindings () 'list) ; An A-LIST.
17
18 (defun make-binding (variable value)
19 (cons variable value))
20
21 (defun extend-bindings (variable value bindings)
22 (acons variable value bindings))
23
24
25 (defun binding-variable (b)
26 (declare (type binding b))
27 (car b))
28
29 (defun (setf binding-variable) (v b)
30 (declare (type binding b))
31 (setf (car b) v))
32
33
34 (defun binding-value (b)
35 (declare (type binding b))
36 (cdr b))
37
38
39 (defun (setf binding-value) (v b)
40 (declare (type binding b))
41 (setf (cdr b) v))
42
43
44 (defun bindings-values (bindings) (mapcar #'cdr bindings))
45
46 (defun bindings-keys (bindings) (mapcar #'car bindings))
47
48
49
50 (define-condition unification-variable-unbound (unbound-variable)
51 ()
52 )
53
54 (define-condition unification-failure (simple-error)
55 ())
56
57
58 ;;;---------------------------------------------------------------------------
59 ;;; Frames.
60
61 (defstruct (frame (:constructor make-frame (&optional bindings)))
62 (bindings () :type bindings))
63
64 (defun empty-frame-p (f)
65 (declare (type frame f))
66 (null (frame-bindings f)))
67
68
69 (defun find-variable-binding-in-frame (v f)
70 (declare (type frame f))
71 (assoc v (frame-bindings f)))
72
73
74 (defun find-variable-value-in-frame (v f)
75 (declare (type frame f))
76 (let ((b (find-variable-binding-in-frame v f)))
77 (declare (type (or null binding) b))
78 (if b
79 (values (cdr b) t)
80 (values nil nil))))
81
82 (defun frame-variables (frame)
83 (mapcar 'binding-variable (frame-bindings frame)))
84
85
86 (defun frame-values (frame)
87 (mapcar 'binding-value (frame-bindings frame)))
88
89
90 ;;;---------------------------------------------------------------------------
91 ;;; Environments.
92
93 (defstruct (environment (:print-object print-environment)
94 (:copier nil))
95 (frames () :type list))
96
97 (defun print-environment (env stream)
98 (if *print-readably*
99 (format stream "#S(ENVIRONMENT FRAMES ~S)"
100 (environment-frames env))
101 (print-unreadable-object (env stream :type nil :identity t)
102 (format stream "~:[~;EMPTY ~]UNIFY ENVIRONMENT: ~D frame~:P"
103 (empty-environment-p env)
104 (list-length (environment-frames env))))))
105
106 (deftype substitution () 'environment)
107
108 (defun substitution-p (x) (environment-p x))
109
110 (defun first-frame (env)
111 (first (environment-frames env)))
112
113
114 (defun make-empty-environment ()
115 (make-environment :frames (list (make-frame))))
116
117 (defun copy-environment (env)
118 (declare (type environment env))
119 (make-environment :frames (copy-list (environment-frames env))))
120
121 (defun make-shared-environment (env &optional (pushp nil))
122 (declare (type environment env))
123 (make-environment :frames (if pushp
124 (cons (make-frame) (environment-frames env))
125 (environment-frames env))))
126
127 (defun push-frame (env)
128 (declare (type environment env))
129 (push (make-frame) (environment-frames env)))
130
131
132 (defun pop-frame (env)
133 (declare (type environment env))
134 (pop (environment-frames env)))
135
136
137 (defun empty-environment-p (env)
138 (declare (type environment env))
139 (let ((env-frames (environment-frames env)))
140 (declare (type list env-frames))
141 (and (= 1 (list-length env-frames))
142 (empty-frame-p (first env-frames)))))
143
144 (defparameter *null-environment* (make-empty-environment))
145
146
147 (defun find-variable-value (variable &optional (env *null-environment*) errorp)
148 (declare (type environment env))
149 (labels ((find-var-value (frames)
150 (cond (frames
151 (multiple-value-bind (val foundp)
152 (find-variable-value-in-frame variable (first frames))
153 (if foundp
154 (values val t)
155 (find-var-value (rest frames)))))
156 (errorp
157 (error 'unification-variable-unbound :variable variable))
158 (t (values nil nil))))
159 )
160 (find-var-value (environment-frames env))))
161
162
163
164 (defun extend-environment (var pat &optional (env (make-empty-environment)))
165 (let ((first-frame (first-frame env)))
166 (setf (frame-bindings first-frame)
167 (extend-bindings var pat (frame-bindings first-frame)))
168 env))
169
170
171 (defun fill-environment (vars pats &optional (env (make-empty-environment)))
172 (map nil (lambda (v p) (extend-environment v p env)) vars pats)
173 env)
174
175
176 (defun fill-environment* (vars-pats &optional (env (make-empty-environment)))
177 (loop for (v . p) in vars-pats do (extend-environment v p env))
178 env)
179
180
181 (declaim (inline v?))
182 (declaim (ftype (function (symbol environment &optional boolean)
183 (values t boolean))
184 find-variable-value
185 v?))
186
187 (defun v? (s env &optional (plain-symbol-p nil))
188 (find-variable-value (if plain-symbol-p
189 (make-var-name s)
190 s)
191 env))
192
193
194 (defun environment-variables (env)
195 (mapcan #'frame-variables (environment-frames env)))
196
197 (defun environment-values (env)
198 (mapcan #'frame-values (environment-frames env)))
199
200
201 ;;;---------------------------------------------------------------------------
202 ;;; Simple debugging.
203
204 (defun dump-frame (f &optional (out *standard-output*))
205 (declare (type frame f))
206 (loop for (var . value) in (frame-bindings f)
207 do (format out "~&~A~VT= ~A~%" var 8 value))
208 )
209
210 (defun dump-environment (env &optional (out *standard-output*))
211 (declare (type environment env))
212 (if (empty-environment-p env)
213 (format out ">>> Empty unify environment ~S.~%" env)
214 (loop initially (format out ">>> Dumping unify environment ~S.~%" env)
215 for fr in (environment-frames env)
216 for fr-n downfrom (list-length (environment-frames env))
217 do (format out ">>> Frame ~D:~%" fr-n)
218 do (dump-frame fr out)
219 do (terpri out)
220 )))
221
222 ;;;; end of file -- substitutions.lisp --

  ViewVC Help
Powered by ViewVC 1.1.5