Mon May 21 12:33:05 UTC 2007 mantoniotti
* See previous message.
diff -rN -u old-cl-unification-1/apply-substitution.lisp new-cl-unification-1/apply-substitution.lisp
--- old-cl-unification-1/apply-substitution.lisp 2013-07-21 20:00:00.000000000 +0000
+++ new-cl-unification-1/apply-substitution.lisp 2013-07-21 20:00:00.000000000 +0000
@@ -9,72 +9,29 @@
;;;---------------------------------------------------------------------------
;;; Substitution application.
-;;; apply-substitution --
-;;;
-;;; EXCLUDE-VARS are variables that will just pass through (a list for
-;;; the time being).
+(defgeneric apply-substitution (substitution item))
-(defgeneric apply-substitution (substitution item &optional exclude-vars))
-
-(defmethod apply-substitution ((s environment) (n number) &optional exclude-vars)
- (declare (ignore exclude-vars))
- n)
-
-
-(defmethod apply-substitution ((substitution environment) (s symbol)
- &optional (exclude-vars ()))
- (declare (type list exclude-vars))
+(defmethod apply-substitution ((substitution environment) (s symbol))
(cond ((variable-any-p s) s)
((variablep s)
- (if (member s exclude-vars :test #'eq)
- s
- (multiple-value-bind (val foundp)
- (find-variable-value s substitution)
- (cond (foundp (apply-substitution substitution val exclude-vars))
- (t (warn "~S is a free variable in the current environment."
- s)
- s))))
- )
+ (multiple-value-bind (val foundp)
+ (find-variable-value s substitution)
+ (cond (foundp val)
+ (t (warn "~S is a free variable in the current environment." s)
+ s))))
(t s)))
-(defmethod apply-substitution ((substitution environment) (l cons)
- &optional (exclude-vars ()))
- (declare (type list exclude-vars))
- (cons (apply-substitution substitution (first l) exclude-vars)
- (apply-substitution substitution (rest l) exclude-vars)))
+(defmethod apply-substitution ((substitution environment) (l cons))
+ (cons (apply-substitution substitution (first l))
+ (apply-substitution substitution (rest l))))
-
-(defmethod apply-substitution ((substitution environment) (l null)
- &optional exclude-vars)
- (declare (ignore exclude-vars))
+(defmethod apply-substitution ((substitution environment) (l null))
'())
+(export '(apply-substitution))
-;;; compose-substitions --
-;;; The definition is a direct translation of TPL's definition at page 318.
-;;; Usually these are done by directly composing and currying
-;;; functions in ML/Haskell derivatives, but that is just being "lazy".
-;;; The current definition may be too "eager", but the "correct"
-;;; semantics should be preserved.
-
-(defun compose-substitutions (env2 env1) ; note the order.
- (declare (type environment env2 env1))
-
- (loop for env1-frame in (environment-frames env1)
- collect
- (loop for (var . term) in (frame-bindings env1-frame)
- collect (make-binding var (apply-substitution env2 term))
- into result-bindings
- finally (return (make-frame result-bindings)))
- into frames
- finally (return (make-environment :frames frames))))
-
-
-
-
-;;; ground-term --
(defun ground-term (term &optional (substitution (make-empty-environment)))
(apply-substitution substitution term))
diff -rN -u old-cl-unification-1/match-block.lisp new-cl-unification-1/match-block.lisp
--- old-cl-unification-1/match-block.lisp 2013-07-21 20:00:00.000000000 +0000
+++ new-cl-unification-1/match-block.lisp 2013-07-21 20:00:00.000000000 +0000
@@ -10,7 +10,7 @@
(defmacro match ((template object
&key
- (substitution (make-empty-environment))
+ (substitution '(make-empty-environment))
(errorp t)
(error-value nil))
&body forms)
@@ -39,7 +39,7 @@
)
`(block nil
(handler-case
- (let* ((,env-var (unify ',template ,object ,substitution))
+ (let* ((,env-var (unify ,template ,object ,substitution))
,@(generate-var-bindings)
)
(declare (ignorable ,@(mapcar #'first (generate-var-bindings))))
@@ -49,7 +49,7 @@
(unification-failure (uf)
(if ,errorp
- (signal uf)
+ (error uf)
,error-value))
)))))
@@ -155,7 +155,7 @@
<form> and <forms> are regular Common Lisp forms.
<template> is a unification template.
-The full syntax of MATCHING is
+The full syntax of MATCH-CASE is
match-case <object> (&key errorp default-substitution) <clauses>
@@ -163,7 +163,7 @@
present in the template are bound lexically. Note that both variable
names '?FOO' and 'FOO' are bound for convenience.
-The values returned by the MATCHING form are those of the last form in
+The values returned by the MATCH-CASE form are those of the last form in
the first clause that satisfies the match test.
If ERRORP is non-NIL then if none of the regular clauses matches, then
@@ -188,7 +188,7 @@
)
(labels ((generate-matchers (clauses)
(if (null clauses)
- otherwise-clause
+ `(progn ,@(rest otherwise-clause))
(destructuring-bind (pattern &rest body)
(car clauses)
`(handler-case (match (,pattern ,object-var)
diff -rN -u old-cl-unification-1/substitutions.lisp new-cl-unification-1/substitutions.lisp
--- old-cl-unification-1/substitutions.lisp 2013-07-21 20:00:00.000000000 +0000
+++ new-cl-unification-1/substitutions.lisp 2013-07-21 20:00:00.000000000 +0000
@@ -24,11 +24,22 @@
(declare (type binding b))
(car b))
+(defun (setf binding-variable) (v b)
+ (declare (type binding b))
+ (setf (car b) v))
+
+
(defun binding-value (b)
(declare (type binding b))
(cdr b))
+(defun (setf binding-value) (v b)
+ (declare (type binding b))
+ (setf (cdr b) v))
+
+
+
(define-condition unification-variable-unbound (unbound-variable)
()
)
diff -rN -u old-cl-unification-1/unification-package.lisp new-cl-unification-1/unification-package.lisp
--- old-cl-unification-1/unification-package.lisp 2013-07-21 20:00:00.000000000 +0000
+++ new-cl-unification-1/unification-package.lisp 2013-07-21 20:00:00.000000000 +0000
@@ -14,7 +14,8 @@
"*UNIFY-STRING-CASE-INSENSITIVE-P*"
"UNIFY"
"FIND-VARIABLE-VALUE"
- "MAKE-EMPTY-ENVIRONMENT")
+ "MAKE-EMPTY-ENVIRONMENT"
+ "APPLY-SUBSTITUTION")
(:export
"MATCH"
"MATCHING"
diff -rN -u old-cl-unification-1/unification.asd new-cl-unification-1/unification.asd
--- old-cl-unification-1/unification.asd 2013-07-21 20:00:00.000000000 +0000
+++ new-cl-unification-1/unification.asd 2013-07-21 20:00:00.000000000 +0000
@@ -12,6 +12,7 @@
(:file "lambda-list-parsing")
(:file "templates-hierarchy")
(:file "unifier")
- (:file "match-block")))
+ (:file "match-block")
+ (:file "apply-substitution")))
;;; end of file -- unification.asd --