repos / cl-unification / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra
Minor changes (added COPYING information and other minutiae).
Annotate for file substitutions.lisp
2007-11-09 mantoniotti 1 ;;;; -*- Mode: Lisp -*-
2004-11-17 mantoniotti 2
2007-11-09 mantoniotti 3 ;;;; substitutions.lisp --
13:35:55 ' 4 ;;;; General CL structures unifier.
' 5 ;;;; Substitution definitions. Mostly a rehash of the usual SICP stuff.
2004-11-17 mantoniotti 6
2011-04-02 mantoniotti 7 ;;;; See file COPYING for copyright licensing information.
04:05:18 ' 8
2004-11-17 mantoniotti 9 (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
22:19:54 ' 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
2007-05-21 mantoniotti 29 (defun (setf binding-variable) (v b)
12:33:05 ' 30 (declare (type binding b))
' 31 (setf (car b) v))
' 32
' 33
2004-11-17 mantoniotti 34 (defun binding-value (b)
22:19:54 ' 35 (declare (type binding b))
' 36 (cdr b))
' 37
' 38
2007-05-21 mantoniotti 39 (defun (setf binding-value) (v b)
12:33:05 ' 40 (declare (type binding b))
' 41 (setf (cdr b) v))
' 42
' 43
2009-04-15 mantoniotti 44 (defun bindings-values (bindings) (mapcar #'cdr bindings))
10:17:48 ' 45
' 46 (defun bindings-keys (bindings) (mapcar #'car bindings))
' 47
' 48
2007-05-21 mantoniotti 49
2004-11-17 mantoniotti 50 (define-condition unification-variable-unbound (unbound-variable)
22:19:54 ' 51 ()
' 52 )
' 53
' 54 (define-condition unification-failure (simple-error)
' 55 ())
' 56
' 57
' 58 ;;;---------------------------------------------------------------------------
' 59 ;;; Frames.
' 60
2009-04-15 mantoniotti 61 (defstruct (frame (:constructor make-frame (&optional bindings)))
2004-11-17 mantoniotti 62 (bindings () :type bindings))
22:19:54 ' 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
2009-04-15 mantoniotti 82 (defun frame-variables (frame)
10:17:48 ' 83 (mapcar 'binding-variable (frame-bindings frame)))
' 84
' 85
' 86 (defun frame-values (frame)
' 87 (mapcar 'binding-value (frame-bindings frame)))
' 88
2004-11-17 mantoniotti 89
22:19:54 ' 90 ;;;---------------------------------------------------------------------------
' 91 ;;; Environments.
' 92
2007-11-09 mantoniotti 93 (defstruct (environment (:print-object print-environment)
13:35:55 ' 94 (:copier nil))
2004-11-17 mantoniotti 95 (frames () :type list))
22:19:54 ' 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)
2011-04-02 mantoniotti 118 (declare (type environment env))
2004-11-17 mantoniotti 119 (make-environment :frames (copy-list (environment-frames env))))
22:19:54 ' 120
2011-04-02 mantoniotti 121 (defun make-shared-environment (env &optional (pushp nil))
04:01:24 ' 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 (defun pop-frame (env)
' 132 (declare (type environment env))
' 133 (pop (environment-frames env)))
' 134
2004-11-17 mantoniotti 135
2010-02-04 pix 136 (defun make-expanded-environment (base-env)
07:32:18 ' 137 (make-environment :frames (cons (make-frame) (environment-frames base-env))))
' 138
2009-04-15 mantoniotti 139 (defun empty-environment-p (env)
2004-11-17 mantoniotti 140 (declare (type environment env))
2009-04-15 mantoniotti 141 (let ((env-frames (environment-frames env)))
10:17:48 ' 142 (declare (type list env-frames))
' 143 (and (= 1 (list-length env-frames))
' 144 (empty-frame-p (first env-frames)))))
2004-11-17 mantoniotti 145
22:19:54 ' 146 (defparameter *null-environment* (make-empty-environment))
' 147
' 148
' 149 (defun find-variable-value (variable &optional (env *null-environment*) errorp)
' 150 (declare (type environment env))
' 151 (labels ((find-var-value (frames)
' 152 (cond (frames
' 153 (multiple-value-bind (val foundp)
' 154 (find-variable-value-in-frame variable (first frames))
' 155 (if foundp
' 156 (values val t)
' 157 (find-var-value (rest frames)))))
' 158 (errorp
' 159 (error 'unification-variable-unbound :variable variable))
' 160 (t (values nil nil))))
' 161 )
' 162 (find-var-value (environment-frames env))))
' 163
' 164
' 165
2009-04-15 mantoniotti 166 (defun extend-environment (var pat &optional (env (make-empty-environment)))
2004-11-17 mantoniotti 167 (let ((first-frame (first-frame env)))
22:19:54 ' 168 (setf (frame-bindings first-frame)
' 169 (extend-bindings var pat (frame-bindings first-frame)))
' 170 env))
' 171
' 172
2009-04-15 mantoniotti 173 (defun fill-environment (vars pats &optional (env (make-empty-environment)))
10:17:48 ' 174 (map nil (lambda (v p) (extend-environment v p env)) vars pats)
' 175 env)
' 176
' 177
' 178 (defun fill-environment* (vars-pats &optional (env (make-empty-environment)))
' 179 (loop for (v . p) in vars-pats do (extend-environment v p env))
' 180 env)
' 181
' 182
' 183 (declaim (inline v?))
2010-02-07 pix 184 (declaim (ftype (function (symbol &optional environment boolean)
07:40:23 ' 185 (values t boolean))
' 186 find-variable-value)
' 187 (ftype (function (symbol environment &optional boolean)
2009-04-15 mantoniotti 188 (values t boolean))
10:17:48 ' 189 v?))
' 190
2008-07-13 mantoniotti 191 (defun v? (s env &optional (plain-symbol-p nil))
13:10:48 ' 192 (find-variable-value (if plain-symbol-p
' 193 (make-var-name s)
' 194 s)
' 195 env))
2009-04-15 mantoniotti 196
10:17:48 ' 197
' 198 (defun environment-variables (env)
' 199 (mapcan #'frame-variables (environment-frames env)))
' 200
' 201 (defun environment-values (env)
' 202 (mapcan #'frame-values (environment-frames env)))
' 203
' 204
2011-03-29 mantoniotti 205 ;;;---------------------------------------------------------------------------
22:59:37 ' 206 ;;; Simple debugging.
2008-07-13 mantoniotti 207
2011-03-29 mantoniotti 208 (defun dump-frame (f &optional (out *standard-output*))
22:59:37 ' 209 (declare (type frame f))
' 210 (loop for (var . value) in (frame-bindings f)
2011-04-02 mantoniotti 211 do (format out "~&~A~VT= ~A~%" var 8 value))
2011-03-29 mantoniotti 212 )
22:59:37 ' 213
' 214 (defun dump-environment (env &optional (out *standard-output*))
' 215 (declare (type environment env))
2011-04-02 mantoniotti 216 (if (empty-environment-p env)
04:01:24 ' 217 (format out ">>> Empty unify environment ~S.~%" env)
' 218 (loop initially (format out ">>> Dumping unify environment ~S.~%" env)
' 219 for fr in (environment-frames env)
' 220 for fr-n downfrom (list-length (environment-frames env))
' 221 do (format out ">>> Frame ~D:~%" fr-n)
' 222 do (dump-frame fr out)
' 223 do (terpri out)
' 224 )))
2008-07-13 mantoniotti 225
2007-11-09 mantoniotti 226 ;;;; end of file -- substitutions.lisp --
There once was a man from Nantucket…