Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv27503

Modified Files: substitutions.lisp Log Message: Added some functionality to extract all variables and/or all values from an environment or a frame.

--- /project/cl-unification/cvsroot/cl-unification/substitutions.lisp 2008/07/13 13:10:48 1.4 +++ /project/cl-unification/cvsroot/cl-unification/substitutions.lisp 2009/04/15 10:17:48 1.5 @@ -39,6 +39,11 @@ (setf (cdr b) v))

+(defun bindings-values (bindings) (mapcar #'cdr bindings)) + +(defun bindings-keys (bindings) (mapcar #'car bindings)) + +

(define-condition unification-variable-unbound (unbound-variable) () @@ -51,7 +56,7 @@ ;;;--------------------------------------------------------------------------- ;;; Frames.

-(defstruct frame +(defstruct (frame (:constructor make-frame (&optional bindings))) (bindings () :type bindings))

(defun empty-frame-p (f) @@ -72,6 +77,13 @@ (values (cdr b) t) (values nil nil))))

+(defun frame-variables (frame) + (mapcar 'binding-variable (frame-bindings frame))) + + +(defun frame-values (frame) + (mapcar 'binding-value (frame-bindings frame))) +

;;;--------------------------------------------------------------------------- ;;; Environments. @@ -106,10 +118,12 @@ (defun make-shared-environment (env) (make-environment :frames (environment-frames env)))

-(defun empty-environment-p (env &aux (env-frames (environment-frames env))) +(defun empty-environment-p (env) (declare (type environment env)) - (and (= 1 (list-length env-frames)) - (empty-frame-p (first env-frames)))) + (let ((env-frames (environment-frames env))) + (declare (type list env-frames)) + (and (= 1 (list-length env-frames)) + (empty-frame-p (first env-frames)))))

(defparameter *null-environment* (make-empty-environment))

@@ -131,19 +145,43 @@

-(defun extend-environment (var pat env) +(defun extend-environment (var pat &optional (env (make-empty-environment))) (let ((first-frame (first-frame env))) (setf (frame-bindings first-frame) (extend-bindings var pat (frame-bindings first-frame))) env))

+(defun fill-environment (vars pats &optional (env (make-empty-environment))) + (map nil (lambda (v p) (extend-environment v p env)) vars pats) + env) + + +(defun fill-environment* (vars-pats &optional (env (make-empty-environment))) + (loop for (v . p) in vars-pats do (extend-environment v p env)) + env) + + +(declaim (inline v?)) +(declaim (ftype (function (symbol environment &optional boolean) + (values t boolean)) + find-variable-value + v?)) + (defun v? (s env &optional (plain-symbol-p nil)) (find-variable-value (if plain-symbol-p (make-var-name s) s) env)) - + + +(defun environment-variables (env) + (mapcan #'frame-variables (environment-frames env))) + +(defun environment-values (env) + (mapcan #'frame-values (environment-frames env))) + +

;;;; end of file -- substitutions.lisp --