From 9501414cc8e3331906c3e3566a125235d3b3204e Mon Sep 17 00:00:00 2001
From: David Lichteblau <david@lichteblau.com>
Date: Sun, 18 Mar 2007 21:03:03 +0100
Subject: [PATCH] recursion detection

---
 TEST       | 10 +++++-----
 parse.lisp | 54 ++++++++++++++++++++++++++++++++++++++++++------------
 2 files changed, 47 insertions(+), 17 deletions(-)

diff --git a/TEST b/TEST
index 0dde743..064a0e2 100644
--- a/TEST
+++ b/TEST
@@ -1,4 +1,4 @@
-001:  FAIL: didn't detect invalid schema
+001:  PASS: RNG-ERROR
 002:  PASS: RNG-ERROR
 003:  PASS: RNG-ERROR
 004:  PASS: RNG-ERROR
@@ -206,14 +206,14 @@
 204:  PASS: RNG-ERROR
 205:  PASS: RNG-ERROR
 206:  PASS: RNG-ERROR
-207:  FAIL: didn't detect invalid schema
+207:  PASS: RNG-ERROR
 208:  PASS
 209:  PASS
 210:  PASS
-211:  FAIL: didn't detect invalid schema
+211:  PASS: RNG-ERROR
 212:  PASS
 213:  PASS
-214:  FAIL: didn't detect invalid schema
+214:  PASS: RNG-ERROR
 215:  PASS
 216:  PASS
 217:  PASS
@@ -373,4 +373,4 @@
 371:  FAIL: didn't detect invalid schema
 372:  PASS
 373:  PASS
-Passed 244/373 tests.
+Passed 248/373 tests.
diff --git a/parse.lisp b/parse.lisp
index 5c37718..3830c6e 100644
--- a/parse.lisp
+++ b/parse.lisp
@@ -46,16 +46,20 @@
     (invoke-with-klacks-handler
      (lambda ()
        (klacks:find-event source :start-element)
-       (let ((*datatype-library* "")
-	     (*namespace-uri* "")
-	     (*entity-resolver* entity-resolver)
-	     (*external-href-stack* '())
-	     (*include-uri-stack* '())
-	     (*grammar* (make-grammar nil)))
+       (let* ((*datatype-library* "")
+	      (*namespace-uri* "")
+	      (*entity-resolver* entity-resolver)
+	      (*external-href-stack* '())
+	      (*include-uri-stack* '())
+	      (*grammar* (make-grammar nil))
+	      (result (p/pattern source)))
+	 (unless result
+	   (rng-error nil "empty grammar"))
 	 (setf (grammar-start *grammar*)
-	       (make-definition :name :start :child (p/pattern source)))
+	       (make-definition :name :start :child result))
 	 (check-pattern-definitions source *grammar*)
-	 (defn-child (grammar-start *grammar*))))
+	 (check-recursion result 0)
+	 result))
       source)))
 
 
@@ -94,12 +98,15 @@
 	    (:include pattern)
 	    (:conc-name "PATTERN-")
 	    (:constructor make-ref (target)))
+  crdepth
   target)
 
-(defstruct (empty (:include pattern) (:conc-name "PATTERN-")))
-(defstruct (text (:include pattern) (:conc-name "PATTERN-")))
+(defstruct (%leaf (:include pattern)))
 
-(defstruct (%typed-pattern (:include pattern) (:conc-name "PATTERN-"))
+(defstruct (empty (:include %leaf) (:conc-name "PATTERN-")))
+(defstruct (text (:include %leaf) (:conc-name "PATTERN-")))
+
+(defstruct (%typed-pattern (:include %leaf) (:conc-name "PATTERN-"))
   datatype-library
   type)
 
@@ -111,7 +118,7 @@
   params
   except)
 
-(defstruct (not-allowed (:include pattern) (:conc-name "PATTERN-")))
+(defstruct (not-allowed (:include %leaf) (:conc-name "PATTERN-")))
 
 
 ;;;; non-pattern
@@ -923,6 +930,29 @@
 ;;;    erfolgt und Namen dann bereits aufgeloest sind.  Wir benennen
 ;;;    dafuer beim Serialisieren um.
 
+(defmethod check-recursion ((pattern element) depth)
+  (check-recursion (pattern-child pattern) (1+ depth)))
+
+(defmethod check-recursion ((pattern ref) depth)
+  (when (eql (pattern-crdepth pattern) depth)
+    (rng-error nil "infinite recursion in ~A"
+	       (defn-name (pattern-target pattern))))
+  (when (null (pattern-crdepth pattern))
+    (setf (pattern-crdepth pattern) depth)
+    (check-recursion (defn-child (pattern-target pattern)) depth)
+    (setf (pattern-crdepth pattern) t)))
+
+(defmethod check-recursion ((pattern %parent) depth)
+  (check-recursion (pattern-child pattern) depth))
+
+(defmethod check-recursion ((pattern %combination) depth)
+  (check-recursion (pattern-a pattern) depth)
+  (check-recursion (pattern-b pattern) depth))
+
+(defmethod check-recursion ((pattern %leaf) depth)
+  (declare (ignore depth)))
+
+
 ;;;; tests
 
 (defun run-tests (&optional (p "/home/david/src/lisp/cxml-rng/spec-split/*"))
-- 
2.11.4.GIT