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 13fdd228190511a9c3895bbba6e0ed417c9a5991..243808d7f72d1c911194fe61653dba97616261ea 100644 (file)
--- 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))
 \f
 ;;;; 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 ced6ab5fb9f238b3d48b3327f7ca4981d03b90f1..4fd4e2c7ca1de837d63fa5edad7131893a722a94 100644 (file)
--- 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))
 \f
 ;;;; 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