From 4153bb5e31f3332a7600142448fff4b6a510e715 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sat, 10 Jun 2006 04:12:32 +0000
Subject: [PATCH] Implement ERROR macros.

---
 v7/src/star-parser/matcher.scm | 11 +++++++++--
 v7/src/star-parser/parser.scm  | 11 +++++++++--
 2 files changed, 18 insertions(+), 4 deletions(-)

diff --git a/v7/src/star-parser/matcher.scm b/v7/src/star-parser/matcher.scm
index 7891dc6a4..64d62dcb5 100644
--- a/v7/src/star-parser/matcher.scm
+++ b/v7/src/star-parser/matcher.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: matcher.scm,v 1.34 2005/06/04 03:42:28 cph Exp $
+$Id: matcher.scm,v 1.35 2006/06/10 04:12:32 cph Exp $
 
-Copyright 2001,2002,2004,2005 Massachusetts Institute of Technology
+Copyright 2001,2002,2004,2005,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -138,6 +138,13 @@ USA.
     `(SEQ (N*N ,n ,expression)
 	  (*N ,(- m n) ,expression))))
 
+(define-*matcher-expander 'ERROR
+  (lambda (ptr msg . irritants)
+    (let ((v (generate-uninterned-symbol)))
+      `(SEXP (LAMBDA (,v)
+	       ,@(if ptr (list v) '())
+	       (PARSER-BUFFER-ERROR ,(or ptr v) ,msg ,@irritants))))))
+
 (define-matcher-preprocessor '(ALT SEQ)
   (lambda (expression external-bindings internal-bindings)
     `(,(car expression)
diff --git a/v7/src/star-parser/parser.scm b/v7/src/star-parser/parser.scm
index 005bbfc79..538b76de9 100644
--- a/v7/src/star-parser/parser.scm
+++ b/v7/src/star-parser/parser.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: parser.scm,v 1.35 2003/02/14 18:28:35 cph Exp $
+$Id: parser.scm,v 1.36 2006/06/10 04:12:32 cph Exp $
 
-Copyright 2001,2002,2003 Massachusetts Institute of Technology
+Copyright 2001,2002,2003,2006 Massachusetts Institute of Technology
 
 This file is part of MIT/GNU Scheme.
 
@@ -125,6 +125,13 @@ USA.
   (lambda (expression)
     `(SEQ ,expression (DISCARD-MATCHED))))
 
+(define-*parser-expander 'ERROR
+  (lambda (ptr msg . irritants)
+    (let ((v (generate-uninterned-symbol)))
+      `(SEXP (LAMBDA (,v)
+	       ,@(if ptr (list v) '())
+	       (PARSER-BUFFER-ERROR ,(or ptr v) ,msg ,@irritants))))))
+
 (define-parser-preprocessor '(ALT SEQ)
   (lambda (expression external-bindings internal-bindings)
     `(,(car expression)
-- 
2.25.1