repos / cl-unification / annotate_shade
summary | shortlog | log | tree | commit | commitdiff | headdiff | annotate | headblob | headfilediff | filehistory
normal | plain | shade | zebra
Changed some environment functions and improved the DUMP-* ones.
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
22:19:54 ' 7 (in-package "CL.EXT.DACF.UNIFICATION") ; DACF = Data And Control Flow.
' 8
' 9 ;;;---------------------------------------------------------------------------
' 10 ;;; Bindings.
' 11
' 12 (deftype binding () 'cons)
' 13
' 14 (deftype bindings () 'list) ; An A-LIST.
' 15
' 16 (defun make-binding (variable value)
' 17 (cons variable value))
' 18
' 19 (defun extend-bindings (variable value bindings)
' 20 (acons variable value bindings))
' 21
' 22
' 23 (defun binding-variable (b)
' 24 (declare (type binding b))
' 25 (car b))
' 26
2007-05-21 mantoniotti 27 (defun (setf binding-variable) (v b)
12:33:05 ' 28 (declare (type binding b))
' 29 (setf (car b) v))
' 30
' 31
2004-11-17 mantoniotti 32 (defun binding-value (b)
22:19:54 ' 33 (declare (type binding b))
' 34 (cdr b))
' 35
' 36
2007-05-21 mantoniotti 37 (defun (setf binding-value) (v b)
12:33:05 ' 38 (declare (type binding b))
' 39 (setf (cdr b) v))
' 40
' 41
2009-04-15 mantoniotti 42 (defun bindings-values (bindings) (mapcar #'cdr bindings))
10:17:48 ' 43
' 44 (defun bindings-keys (bindings) (mapcar #'car bindings))
' 45
' 46
2007-05-21 mantoniotti 47
2004-11-17 mantoniotti 48 (define-condition unification-variable-unbound (unbound-variable)
22:19:54 ' 49 ()
' 50 )
' 51
' 52 (define-condition unification-failure (simple-error)
' 53 ())
' 54
' 55
' 56 ;;;---------------------------------------------------------------------------
' 57 ;;; Frames.
' 58
2009-04-15 mantoniotti 59 (defstruct (frame (:constructor make-frame (&optional bindings)))
2004-11-17 mantoniotti 60 (bindings () :type bindings))
22:19:54 ' 61
' 62 (defun empty-frame-p (f)
' 63 (declare (type frame f))
' 64 (null (frame-bindings f)))
' 65
' 66
' 67 (defun find-variable-binding-in-frame (v f)
' 68 (declare (type frame f))
' 69 (assoc v (frame-bindings f)))
' 70
' 71
' 72 (defun find-variable-value-in-frame (v f)
' 73 (declare (type frame f))
' 74 (let ((b (find-variable-binding-in-frame v f)))
' 75 (declare (type (or null binding) b))
' 76 (if b
' 77 (values (cdr b) t)
' 78 (values nil nil))))
' 79
2009-04-15 mantoniotti 80 (defun frame-variables (frame)
10:17:48 ' 81 (mapcar 'binding-variable (frame-bindings frame)))
' 82
' 83
' 84 (defun frame-values (frame)
' 85 (mapcar 'binding-value (frame-bindings frame)))
' 86
2004-11-17 mantoniotti 87
22:19:54 ' 88 ;;;---------------------------------------------------------------------------
' 89 ;;; Environments.
' 90
2007-11-09 mantoniotti 91 (defstruct (environment (:print-object print-environment)
13:35:55 ' 92 (:copier nil))
2004-11-17 mantoniotti 93 (frames () :type list))
22:19:54 ' 94
' 95 (defun print-environment (env stream)
' 96 (if *print-readably*
' 97 (format stream "#S(ENVIRONMENT FRAMES ~S)"
' 98 (environment-frames env))
' 99 (print-unreadable-object (env stream :type nil :identity t)
' 100 (format stream "~:[~;EMPTY ~]UNIFY ENVIRONMENT: ~D frame~:P"
' 101 (empty-environment-p env)
' 102 (list-length (environment-frames env))))))
' 103
' 104 (deftype substitution () 'environment)
' 105
' 106 (defun substitution-p (x) (environment-p x))
' 107
' 108 (defun first-frame (env)
' 109 (first (environment-frames env)))
' 110
' 111
' 112 (defun make-empty-environment ()
' 113 (make-environment :frames (list (make-frame))))
' 114
' 115 (defun copy-environment (env)
2011-04-02 mantoniotti 116 (declare (type environment env))
2004-11-17 mantoniotti 117 (make-environment :frames (copy-list (environment-frames env))))
22:19:54 ' 118
2011-04-02 mantoniotti 119 (defun make-shared-environment (env &optional (pushp nil))
04:01:24 ' 120 (declare (type environment env))
' 121 (make-environment :frames (if pushp
' 122 (cons (make-frame) (environment-frames env))
' 123 (environment-frames env))))
' 124
' 125 (defun push-frame (env)
' 126 (declare (type environment env))
' 127 (push (make-frame) (environment-frames env)))
' 128
' 129 (defun pop-frame (env)
' 130 (declare (type environment env))
' 131 (pop (environment-frames env)))
' 132
2004-11-17 mantoniotti 133
2010-02-04 pix 134 (defun make-expanded-environment (base-env)
07:32:18 ' 135 (make-environment :frames (cons (make-frame) (environment-frames base-env))))
' 136
2009-04-15 mantoniotti 137 (defun empty-environment-p (env)
2004-11-17 mantoniotti 138 (declare (type environment env))
2009-04-15 mantoniotti 139 (let ((env-frames (environment-frames env)))
10:17:48 ' 140 (declare (type list env-frames))
' 141 (and (= 1 (list-length env-frames))
' 142 (empty-frame-p (first env-frames)))))
2004-11-17 mantoniotti 143
22:19:54 ' 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
2009-04-15 mantoniotti 164 (defun extend-environment (var pat &optional (env (make-empty-environment)))
2004-11-17 mantoniotti 165 (let ((first-frame (first-frame env)))
22:19:54 ' 166 (setf (frame-bindings first-frame)
' 167 (extend-bindings var pat (frame-bindings first-frame)))
' 168 env))
' 169
' 170
2009-04-15 mantoniotti 171 (defun fill-environment (vars pats &optional (env (make-empty-environment)))
10:17:48 ' 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?))
2010-02-07 pix 182 (declaim (ftype (function (symbol &optional environment boolean)
07:40:23 ' 183 (values t boolean))
' 184 find-variable-value)
' 185 (ftype (function (symbol environment &optional boolean)
2009-04-15 mantoniotti 186 (values t boolean))
10:17:48 ' 187 v?))
' 188
2008-07-13 mantoniotti 189 (defun v? (s env &optional (plain-symbol-p nil))
13:10:48 ' 190 (find-variable-value (if plain-symbol-p
' 191 (make-var-name s)
' 192 s)
' 193 env))
2009-04-15 mantoniotti 194
10:17:48 ' 195
' 196 (defun environment-variables (env)
' 197 (mapcan #'frame-variables (environment-frames env)))
' 198
' 199 (defun environment-values (env)
' 200 (mapcan #'frame-values (environment-frames env)))
' 201
' 202
2011-03-29 mantoniotti 203 ;;;---------------------------------------------------------------------------
22:59:37 ' 204 ;;; Simple debugging.
2008-07-13 mantoniotti 205
2011-03-29 mantoniotti 206 (defun dump-frame (f &optional (out *standard-output*))
22:59:37 ' 207 (declare (type frame f))
' 208 (loop for (var . value) in (frame-bindings f)
2011-04-02 mantoniotti 209 do (format out "~&~A~VT= ~A~%" var 8 value))
2011-03-29 mantoniotti 210 )
22:59:37 ' 211
' 212 (defun dump-environment (env &optional (out *standard-output*))
' 213 (declare (type environment env))
2011-04-02 mantoniotti 214 (if (empty-environment-p env)
04:01:24 ' 215 (format out ">>> Empty unify environment ~S.~%" env)
' 216 (loop initially (format out ">>> Dumping unify environment ~S.~%" env)
' 217 for fr in (environment-frames env)
' 218 for fr-n downfrom (list-length (environment-frames env))
' 219 do (format out ">>> Frame ~D:~%" fr-n)
' 220 do (dump-frame fr out)
' 221 do (terpri out)
' 222 )))
2008-07-13 mantoniotti 223
2007-11-09 mantoniotti 224 ;;;; end of file -- substitutions.lisp --
There once was a man from Nantucket…