December 2009 - cl-unification-cvs@common-lisp.net

[cl-unification-cvs] CVS cl-unification
by mantoniotti 17 Dec '09

17 Dec '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv26456 Modified Files: ChangeLog Log Message: ChangeLog updated. --- /project/cl-unification/cvsroot/cl-unification/ChangeLog 2009/04/17 22:44:17 1.7 +++ /project/cl-unification/cvsroot/cl-unification/ChangeLog 2009/12/17 17:02:42 1.8 @@ -1,3 +1,35 @@ +2009-12-17 author <author(a)paniscia.local> + + * lib-dependent/cl-ppcre-template.asd: Initial checkin. + + * lib-dependent/cl-ppcre-template.lisp: + Patched to use Cl-PPCRE:SCAN-TO-STRINGS (thanks to Pixel // pinterface [a] gmail dot com). + + * unifier.lisp: Minor cosmetic changes. + + * unification-package.lisp: Exported MATCHF-CASE. + + * templates-hierarchy.lisp: + Fixed a couple of problems with some accessors in the NUMBER, + STRUCTURE-OBJECT and STANDARD-OBJECT templates. + + * match-block.lisp: Added MATCHF* macros. + +2009-04-18 author <author(a)paniscia.local> + + * ChangeLog: ChangeLog updated. + + * cl-unification.system, cl-unification.asd: + System definitions files (.asd and .system) modified in order to make + dependency form CL-PPCRE optional. + + * lib-dependent/cl-ppcre-template.system: File added. + + * lib-dependent/cl-ppcre-template.lisp: + Removed REQUIRE of CL-PPCRE. Too brittle. + + * cl-unification-lib.asd: File added. + 2009-04-18 author <author(a)Macintosh-9.local> * cl-unification.system, cl-unification.asd:

1 0

[cl-unification-cvs] CVS cl-unification/lib-dependent
by mantoniotti 17 Dec '09

17 Dec '09

Update of /project/cl-unification/cvsroot/cl-unification/lib-dependent In directory cl-net:/tmp/cvs-serv25442 Added Files: cl-ppcre-template.asd Log Message: Initial checkin. --- /project/cl-unification/cvsroot/cl-unification/lib-dependent/cl-ppcre-template.asd 2009/12/17 17:00:58 NONE +++ /project/cl-unification/cvsroot/cl-unification/lib-dependent/cl-ppcre-template.asd 2009/12/17 17:00:58 1.1 ;;;; -*- Mode: Lisp -*- ;;;; cl-ppcre-template.asd -- ;;;; ASDF system file. (asdf:defsystem cl-ppcre-template :author "Marco Antoniotti" :components ((:file "cl-ppcre-template")) :depends-on (cl-ppcre cl-unification)) ;;;; end of file -- cl-ppcre-template.asd --

1 0

[cl-unification-cvs] CVS cl-unification/lib-dependent
by mantoniotti 17 Dec '09

17 Dec '09

Update of /project/cl-unification/cvsroot/cl-unification/lib-dependent In directory cl-net:/tmp/cvs-serv20396 Modified Files: cl-ppcre-template.lisp Log Message: Patched to use Cl-PPCRE:SCAN-TO-STRINGS (thanks to Pixel // pinterface [a] gmail dot com). --- /project/cl-unification/cvsroot/cl-unification/lib-dependent/cl-ppcre-template.lisp 2009/04/17 22:40:29 1.2 +++ /project/cl-unification/cvsroot/cl-unification/lib-dependent/cl-ppcre-template.lisp 2009/12/17 16:57:45 1.3 @@ -120,13 +120,10 @@ (type (or null (integer 0 #.most-positive-fixnum)) end)) (let ((end (or end (length s)))) (declare (type (integer 0 #.most-positive-fixnum) end)) - (multiple-value-bind (m-start m-end r-starts r-ends) - (cl-ppcre:scan (scanner re-t) s :start start :end end) - ;; Maybe SCAN-TO-STRINGS would be simpler to use... - (declare (type (integer 0 #.most-positive-fixnum) m-start m-end) - (type (vector (integer 0 #.most-positive-fixnum)) r-starts r-ends)) - (unless (and (= start m-start) (= m-end end)) + (multiple-value-bind (matched-p strings) + (cl-ppcre:scan-to-strings (scanner re-t) s :start start :end end) + (unless matched-p (error 'unification-failure :format-control "String ~S cannot be matched against ~ regular expression ~S." @@ -135,9 +132,7 @@ (let ((vars (variables re-t))) (if (null vars) env - (loop for r-start across r-starts - for r-end across r-ends - for r-string of-type string = (subseq s r-start r-end) + (loop for r-string of-type string across strings for v in vars for result-env = (var-unify v r-string env) then (var-unify v r-string result-env)

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 17 Dec '09

17 Dec '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv18834 Modified Files: unifier.lisp Log Message: Minor cosmetic changes. --- /project/cl-unification/cvsroot/cl-unification/unifier.lisp 2009/04/15 10:14:24 1.6 +++ /project/cl-unification/cvsroot/cl-unification/unifier.lisp 2009/12/17 16:44:46 1.7 @@ -225,14 +225,16 @@ (defgeneric untyped-unify (a b &optional env)) -(defmethod untyped-unify ((as list) (bs vector) &optional (env (make-empty-environment))) +(defmethod untyped-unify ((as list) (bs vector) + &optional (env (make-empty-environment))) (loop for a in as for b across bs for mgu = (unify a b env) then (unify a b mgu) finally (return mgu))) -(defmethod untyped-unify ((as vector) (bs list) &optional (env (make-empty-environment))) +(defmethod untyped-unify ((as vector) (bs list) + &optional (env (make-empty-environment))) (untyped-unify bs as env)) (defmethod untyped-unify ((a t) (b t) &optional (env (make-empty-environment))) @@ -449,7 +451,7 @@ (setf env (unify (subseq a n-vars (+ n-vars n-optionals)) optionals env))) (when (and rest (>= ll (+ n-vars n-optionals))) (setf env (unify (subseq a (+ n-vars n-optionals)) (first rest) env))) - (when keys (warn "Sorry mathcing of keywords ~S not yet implemented." keys)) + (when keys (warn "Sorry matching of keywords ~S not yet implemented." keys)) env ))))

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 17 Dec '09

17 Dec '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv18747 Modified Files: unification-package.lisp Log Message: Exported MATCHF-CASE. --- /project/cl-unification/cvsroot/cl-unification/unification-package.lisp 2009/04/17 07:53:58 1.6 +++ /project/cl-unification/cvsroot/cl-unification/unification-package.lisp 2009/12/17 16:43:51 1.7 @@ -41,7 +41,9 @@ "MATCH" "MATCHF" "MATCHING" - "MATCH-CASE") + "MATCH-CASE" + "MATCHF-CASE" + ) (:export "UNIFY*"

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 17 Dec '09

17 Dec '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv18677 Modified Files: templates-hierarchy.lisp Log Message: Fixed a couple of problems with some accessors in the NUMBER, STRUCTURE-OBJECT and STANDARD-OBJECT templates. --- /project/cl-unification/cvsroot/cl-unification/templates-hierarchy.lisp 2009/04/15 10:18:59 1.5 +++ /project/cl-unification/cvsroot/cl-unification/templates-hierarchy.lisp 2009/12/17 16:43:12 1.6 @@ -407,6 +407,23 @@ (cons (second spec))))) +(defun number-template-numeric-type (x) + (declare (type number-template x)) + (let ((n (number-template-number x))) + (if (numberp n) + (type-of n) + (first (template-spec x))))) + +(defun number-template-numeric-class (x) + (declare (type number-template x)) + (let ((n (number-template-number x))) + (if (numberp n) + (class-of n) + (find-class (first (template-spec x)))))) + + + + ;;; Sequence Templates. ;;; Specification is ;;; @@ -493,11 +510,19 @@ ;;; Structure and Standard Object Templates. +(defun structure-object-template-class (x) + (and (structure-object-template-p x) + (first (template-spec x)))) + (defun structure-object-template-slots (x) (and (structure-object-template-p x) (rest (template-spec x)))) +(defun standard-object-template-class (x) + (and (standard-object-template-p x) + (first (template-spec x)))) + (defun standard-object-template-slots (x) (and (standard-object-template-p x) (rest (template-spec x))))

1 0

[cl-unification-cvs] CVS cl-unification
by mantoniotti 17 Dec '09

17 Dec '09

Update of /project/cl-unification/cvsroot/cl-unification In directory cl-net:/tmp/cvs-serv18479 Modified Files: match-block.lisp Log Message: Added MATCHF* macros. --- /project/cl-unification/cvsroot/cl-unification/match-block.lisp 2009/04/15 10:16:24 1.9 +++ /project/cl-unification/cvsroot/cl-unification/match-block.lisp 2009/12/17 16:41:38 1.10 @@ -303,6 +303,68 @@ (let ((,object-var ,object)) ,(generate-matchers non-otherwise-clauses)))))) + +(defmacro matchf-case ((object &key errorp default-substitution match-case-named) + &rest clauses) + "MATCHF-CASE sets up a CASE-like environment for multiple template matching clauses. + +The syntax of MATCHF-CASE comprises a number of clauses of the form + + <clause> ::= <regular-clause> | <default-clause> + <regular-clause> ::= (<template> &body <forms>) + <default-clause> ::= (t &body <forms>) + | (otherwise &body <forms>) +<form> and <forms> are regular Common Lisp forms. +<template> is a unification template. + +The full syntax of MATCHF-CASE is + + matchf-case <object> (&key errorp default-substitution) <clauses> + +Each clause evaluates its forms in an environment where the variables +present in the template are bound lexically. Note that both variable +names '?FOO' and 'FOO' are bound for convenience. + +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 +an error of type UNIFICATION-NON-EXAUSTIVE is signalled, regardless of +any default clause. Otherwise, the default clause behaves as a +standard CASE default clause. The default value of ERRORP is NIL. + +MATCHF-CASE behaves like MATCH-CASE, but the patterns are not +evaluated (i.e., it relies on MATCHF instead of MATCH to construct the +macro expansion. +" + (declare (ignore default-substitution)) ; For the time being. + (let* ((object-var (gensym "OBJECT-VAR-")) + (otherwise-clause-present-p + (member (caar (last clauses)) '(t otherwise))) + (non-otherwise-clauses + (if otherwise-clause-present-p + (butlast clauses) + clauses)) + (otherwise-clause + (if otherwise-clause-present-p + (first (last clauses)) + (when errorp + `(t (error 'unification-non-exhaustive + :format-control "Non exhaustive matching."))))) + ) + (labels ((generate-matchers (clauses) + (if (null clauses) + `(progn ,@(rest otherwise-clause)) + (destructuring-bind (pattern &rest body) + (car clauses) + `(handler-case (matchf (,pattern ,object-var) + ,@body) + (unification-failure () + ,(generate-matchers (cdr clauses)))))))) + `(block ,match-case-named + (let ((,object-var ,object)) + ,(generate-matchers non-otherwise-clauses)))))) + ;;;;--------------------------------------------------------------------------- ;;;; Testing.

1 0