From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 2 Jul 2001 19:21:57 +0000 (+0000)
Subject: Don't lift Scheme expressions up to the top of the procedure; evaluate
X-Git-Tag: 20090517-FFI~2677
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=aca181a4462c3df1af27dd3b5bbfaea1699180d1;p=mit-scheme.git

Don't lift Scheme expressions up to the top of the procedure; evaluate
them in place.  Eliminate DEFAULT in favor of new VALUES.
---

diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index 13fdd2281..243808d7f 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.10 2001/07/02 18:20:08 cph Exp $
+;;; $Id: matcher.scm,v 1.11 2001/07/02 19:21:54 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -119,39 +119,38 @@
 
 (define-matcher-preprocessor '(CHAR CHAR-CI NOT-CHAR NOT-CHAR-CI)
   (lambda (expression external-bindings internal-bindings)
-    external-bindings
-    `(,(car expression)
-      ,(handle-complex-expression (check-1-arg expression)
-				  internal-bindings))))
+    external-bindings internal-bindings
+    (check-1-arg expression)
+    expression))
 
 (define-matcher-preprocessor 'STRING
   (lambda (expression external-bindings internal-bindings)
-    external-bindings
+    external-bindings internal-bindings
     (let ((string (check-1-arg expression)))
       (if (and (string? string) (fix:= (string-length string) 1))
 	  `(CHAR ,(string-ref string 0))
-	  `(STRING ,(handle-complex-expression string internal-bindings))))))
+	  expression))))
 
 (define-matcher-preprocessor 'STRING-CI
   (lambda (expression external-bindings internal-bindings)
-    external-bindings
+    external-bindings internal-bindings
     (let ((string (check-1-arg expression)))
       (if (and (string? string) (fix:= (string-length string) 1))
 	  `(CHAR-CI ,(string-ref string 0))
-	  `(STRING-CI
-	    ,(handle-complex-expression string internal-bindings))))))
+	  expression))))
 
 (define-matcher-preprocessor 'ALPHABET
   (lambda (expression external-bindings internal-bindings)
-    `(,(car expression)
-      ,(let ((arg (check-1-arg expression)))
-	 (if (string? arg)
-	     (handle-complex-expression
+    internal-bindings
+    (let ((arg (check-1-arg expression)))
+      (if (string? arg)
+	  `(,(car expression)
+	    ,(handle-complex-expression
 	      (if (string-prefix? "^" arg)
 		  `(RE-COMPILE-CHAR-SET ,(string-tail arg 1) #T)
 		  `(RE-COMPILE-CHAR-SET ,arg #F))
-	      external-bindings)
-	     (handle-complex-expression arg internal-bindings))))))
+	      external-bindings))
+	  expression))))
 
 (define-matcher-preprocessor 'WITH-POINTER
   (lambda (expression external-bindings internal-bindings)
@@ -163,8 +162,9 @@
 
 (define-matcher-preprocessor 'SEXP
   (lambda (expression external-bindings internal-bindings)
-    external-bindings
-    (handle-complex-expression (check-1-arg expression) internal-bindings)))
+    external-bindings internal-bindings
+    (check-1-arg expression)
+    expression))
 
 ;;;; Compiler
 
@@ -209,10 +209,12 @@
 		       (if arity
 			   (cdr expression)
 			   (list (cdr expression)))))))
-	((symbol? expression)
+	((or (symbol? expression)
+	     (and (pair? expression) (eq? (car expression) 'SEXP)))
 	 (handle-pending-backtracking pointer
 	   (lambda (pointer)
-	     `(IF (,expression ,*buffer-name*)
+	     `(IF (,(if (pair? expression) (cadr expression) expression)
+		   ,*buffer-name*)
 		  ,(call-with-unknown-pointer if-succeed)
 		  ,(if-fail pointer)))))
 	(else
diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm
index ced6ab5fb..4fd4e2c7c 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.14 2001/07/02 18:20:17 cph Exp $
+;;; $Id: parser.scm,v 1.15 2001/07/02 19:21:57 cph Exp $
 ;;;
 ;;; Copyright (c) 2001 Massachusetts Institute of Technology
 ;;;
@@ -124,7 +124,7 @@
 				      external-bindings
 				      internal-bindings))))
 
-(define-parser-preprocessor '(DEFAULT TRANSFORM ELEMENT-TRANSFORM ENCAPSULATE)
+(define-parser-preprocessor '(TRANSFORM ELEMENT-TRANSFORM ENCAPSULATE)
   (lambda (expression external-bindings internal-bindings)
     (check-2-args expression)
     `(,(car expression) ,(cadr expression)
@@ -142,8 +142,14 @@
 
 (define-parser-preprocessor 'SEXP
   (lambda (expression external-bindings internal-bindings)
-    external-bindings
-    (handle-complex-expression (check-1-arg expression) internal-bindings)))
+    external-bindings internal-bindings
+    (check-1-arg expression)
+    expression))
+
+(define-parser-preprocessor 'VALUES
+  (lambda (expression external-bindings internal-bindings)
+    external-bindings internal-bindings
+    expression))
 
 ;;;; Compiler
 
@@ -184,10 +190,13 @@
 		       (if arity
 			   (cdr expression)
 			   (list (cdr expression)))))))
-	((symbol? expression)
+	((or (symbol? expression)
+	     (and (pair? expression) (eq? (car expression) 'SEXP)))
 	 (handle-pending-backtracking pointer
 	   (lambda (pointer)
-	     (with-variable-binding `(,expression ,*buffer-name*)
+	     (with-variable-binding
+		 `(,(if (pair? expression) (cadr expression) expression)
+		   ,*buffer-name*)
 	       (lambda (result)
 		 `(IF ,result
 		      ,(call-with-unknown-pointer
@@ -241,11 +250,9 @@
     (lambda (pointer) (if-succeed pointer `(VECTOR)))
     if-fail))
 
-(define-parser (default value expression)
+(define-parser (values . expressions)
   if-fail
-  (compile-parser-expression expression pointer if-succeed
-    (lambda (pointer)
-      (if-succeed pointer `(VECTOR ,value)))))
+  (if-succeed pointer `(VECTOR ,@expressions)))
 
 (define-parser (transform transform expression)
   (compile-parser-expression expression pointer