From mantoniotti at common-lisp.net  Thu Dec 17 16:41:38 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Thu, 17 Dec 2009 11:41:38 -0500
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1NLJQ2-0004o6-Fz@common-lisp.net>

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)
+				      , at body)
+		        (unification-failure ()
+			  ,(generate-matchers (cdr clauses))))))))
+      `(block ,match-case-named
+         (let ((,object-var ,object))
+           ,(generate-matchers non-otherwise-clauses))))))
+
 ;;;;---------------------------------------------------------------------------
 ;;;; Testing.
 




From mantoniotti at common-lisp.net  Thu Dec 17 16:43:12 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Thu, 17 Dec 2009 11:43:12 -0500
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1NLJRY-0004rI-Ml@common-lisp.net>

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))))




From mantoniotti at common-lisp.net  Thu Dec 17 16:43:51 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Thu, 17 Dec 2009 11:43:51 -0500
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1NLJSB-0004sR-Sx@common-lisp.net>

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*"




From mantoniotti at common-lisp.net  Thu Dec 17 16:44:46 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Thu, 17 Dec 2009 11:44:46 -0500
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1NLJT4-0004tp-6c@common-lisp.net>

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
         ))))
 




From mantoniotti at common-lisp.net  Thu Dec 17 16:57:45 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Thu, 17 Dec 2009 11:57:45 -0500
Subject: [cl-unification-cvs] CVS cl-unification/lib-dependent
Message-ID: <E1NLJfd-0005J1-F2@common-lisp.net>

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)




From mantoniotti at common-lisp.net  Thu Dec 17 17:00:58 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Thu, 17 Dec 2009 12:00:58 -0500
Subject: [cl-unification-cvs] CVS cl-unification/lib-dependent
Message-ID: <E1NLJik-0006cS-9K@common-lisp.net>

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 --



From mantoniotti at common-lisp.net  Thu Dec 17 17:02:42 2009
From: mantoniotti at common-lisp.net (mantoniotti)
Date: Thu, 17 Dec 2009 12:02:42 -0500
Subject: [cl-unification-cvs] CVS cl-unification
Message-ID: <E1NLJkQ-0006t0-5I@common-lisp.net>

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 at 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 at 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 at Macintosh-9.local>
 
 	* cl-unification.system, cl-unification.asd: