Suppress redundant type checks in generated pattern matching code.

diff --git a/src/compiler/base/pmlook.scm b/src/compiler/base/pmlook.scm
index 6e1bf30f1da70815351bab053ebe791f379d0ca9..52c31d5d04b99d927a97b86881ee59cac21fbf00 100644 (file)
--- a/src/compiler/base/pmlook.scm
+++ b/src/compiler/base/pmlook.scm
@@ -108,17 +108,19 @@ USA.
        (r-null?   (close-syntax 'NULL? environment))
        (r-pair?   (close-syntax 'PAIR? environment))
        (r-quote   (close-syntax 'QUOTE environment)))
-    (let descend ((pattern pattern)
+    (let descend ((top-level #t)
+                 (pattern pattern)
                  (body `(,body ,@(pattern-variables pattern))))
       (if (pair? pattern)
          (if (eq? (car pattern) pattern-variable-tag)
              `(,r-lambda (,(cdr pattern)) ,body)
              (let ((instance (generate-uninterned-symbol)))
                `(,r-lambda (,instance)
+                           ,@(if top-level `((,r-declare (NO-TYPE-CHECKS))) '())
                            (,r-and (,r-pair? ,instance)
-                                   (,(descend (car pattern)
-                                           `(,(descend (cdr pattern) body)
-                                             (,r-cdr ,instance)))
+                                   (,(descend #f (car pattern)
+                                              `(,(descend #f (cdr pattern) body)
+                                                (,r-cdr ,instance)))
                                     (,r-car ,instance))))))
          (let ((instance (generate-uninterned-symbol)))
            `(,r-lambda (,instance)

diff --git a/src/compiler/base/pmpars.scm b/src/compiler/base/pmpars.scm
index fd15e959856fe72d58cbb35e0670c1af9f41ffc3..641c46f1bca7361f8c34c7e68726b57df1c9c7a8 100644 (file)
--- a/src/compiler/base/pmpars.scm
+++ b/src/compiler/base/pmpars.scm
@@ -108,7 +108,7 @@ USA.
                                     environment)
             environment))))
 
-(define compile-pattern-matchers? #f)
+(define compile-pattern-matchers? #t)
 
 (define (make-rule-matcher pattern expression environment)
   ;; PATTERN-LOOKUP-2 and the compiled matchers require that there
@@ -144,7 +144,9 @@ USA.
                                 ,@qualifiers
                                 (,r-lambda () ,body)))))
       `(,r-lambda ,outer-vars
-         (,(close-syntax 'DECLARE environment) (INTEGRATE ,@outer-vars))
+         (,(close-syntax 'DECLARE environment)
+          (INTEGRATE ,@outer-vars)
+          (TYPE-CHECKS))
          ,(if (and (null? inner-vars)
                    (null? xforms))
               qualified-body