From aca181a4462c3df1af27dd3b5bbfaea1699180d1 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 2 Jul 2001 19:21:57 +0000
Subject: [PATCH] Don't lift Scheme expressions up to the top of the procedure;
evaluate them in place. Eliminate DEFAULT in favor of new VALUES.
---
v7/src/star-parser/matcher.scm | 42 ++++++++++++++++++----------------
v7/src/star-parser/parser.scm | 27 ++++++++++++++--------
2 files changed, 39 insertions(+), 30 deletions(-)
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
--
2.25.1