From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 26 Jun 2001 21:16:46 +0000 (+0000)
Subject: Lots of hair to allow explicit character-set specifications to be
X-Git-Tag: 20090517-FFI~2699
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=ab7146ba68d84ed13f93997b04c1240bc62ce2cc;p=mit-scheme.git

Lots of hair to allow explicit character-set specifications to be
compiled at load time rather than at run time.
---

diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index aa91bb11d..b29b94fa4 100644
--- a/v7/src/star-parser/matcher.scm
+++ b/v7/src/star-parser/matcher.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: matcher.scm,v 1.3 2001/06/26 21:02:04 cph Exp $
+;;; $Id: matcher.scm,v 1.4 2001/06/26 21:16:44 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -40,13 +40,11 @@
 (define (generate-matcher-code expression)
   (with-canonical-matcher-expression expression
     (lambda (expression)
-      (with-buffer-name
-	(lambda ()
-	  (compile-matcher-expression
-	   expression
-	   (no-pointers)
-	   (simple-backtracking-continuation `#T)
-	   (simple-backtracking-continuation `#F)))))))
+      (compile-matcher-expression
+       expression
+       (no-pointers)
+       (simple-backtracking-continuation `#T)
+       (simple-backtracking-continuation `#F)))))
 
 (define (compile-matcher-expression expression pointers if-succeed if-fail)
   (cond ((and (pair? expression)
@@ -82,10 +80,11 @@
 					    internal-bindings)))
       (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
 			   (cdr external-bindings))
-		      (receiver
-		       (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
-					    (cdr internal-bindings))
-				       expression))))))
+	(with-buffer-name
+	  (lambda ()
+	    (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
+				 (cdr internal-bindings))
+	      (receiver expression))))))))
 
 (define (canonicalize-matcher-expression expression
 					 external-bindings internal-bindings)
diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm
index 9c5c3bc89..07d61e8ec 100644
--- a/v7/src/star-parser/parser.scm
+++ b/v7/src/star-parser/parser.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: parser.scm,v 1.3 2001/06/26 21:02:06 cph Exp $
+;;; $Id: parser.scm,v 1.4 2001/06/26 21:16:46 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -40,17 +40,15 @@
 (define (generate-parser-code expression)
   (with-canonical-parser-expression expression
     (lambda (expression)
-      (with-buffer-name
-	(lambda ()
-	  (compile-parser-expression
-	   expression
-	   (no-pointers)
-	   (lambda (pointers result)
-	     (handle-pending-backtracking pointers
-	       (lambda (pointers)
-		 pointers
-		 result)))
-	   (simple-backtracking-continuation `#F)))))))
+      (compile-parser-expression
+       expression
+       (no-pointers)
+       (lambda (pointers result)
+	 (handle-pending-backtracking pointers
+	   (lambda (pointers)
+	     pointers
+	     result)))
+       (simple-backtracking-continuation `#F)))))
 
 (define (compile-parser-expression expression pointers if-succeed if-fail)
   (cond ((and (pair? expression)
@@ -122,10 +120,11 @@
     (let ((expression (do-expression expression)))
       (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
 			   (cdr external-bindings))
-		      (receiver
-		       (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
-					    (cdr internal-bindings))
-				       expression))))))
+	(with-buffer-name
+	  (lambda ()
+	    (maybe-make-let (map (lambda (b) (list (cdr b) (car b)))
+				 (cdr internal-bindings))
+	      (receiver expression))))))))
 
 ;;;; Parsers