From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 18 Dec 2001 20:47:46 +0000 (+0000)
Subject: Extend syntax-table abstraction so that it works on environments as
X-Git-Tag: 20090517-FFI~2388
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d6e41a473b6a04b710d0e0ac8d28e82f47924c60;p=mit-scheme.git

Extend syntax-table abstraction so that it works on environments as
well as syntax tables.
---

diff --git a/v7/src/runtime/syntab.scm b/v7/src/runtime/syntab.scm
index 14ad21972..182ac58e9 100644
--- a/v7/src/runtime/syntab.scm
+++ b/v7/src/runtime/syntab.scm
@@ -1,8 +1,8 @@
 #| -*-Scheme-*-
 
-$Id: syntab.scm,v 14.5 1999/01/02 06:19:10 cph Exp $
+$Id: syntab.scm,v 14.6 2001/12/18 20:47:46 cph Exp $
 
-Copyright (c) 1988-1999 Massachusetts Institute of Technology
+Copyright (c) 1988-1999, 2001 Massachusetts Institute of Technology
 
 This program is free software; you can redistribute it and/or modify
 it under the terms of the GNU General Public License as published by
@@ -16,7 +16,8 @@ General Public License for more details.
 
 You should have received a copy of the GNU General Public License
 along with this program; if not, write to the Free Software
-Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
+USA.
 |#
 
 ;;;; Syntax Table
@@ -25,55 +26,63 @@ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
 (declare (usual-integrations))
 
 (define-structure (syntax-table (constructor %make-syntax-table)
+				(predicate %syntax-table?)
 				(conc-name syntax-table/))
   alist
-  (parent false read-only true))
+  (%parent #f read-only #t))
+
+(define (syntax-table? object)
+  (or (%syntax-table? object)
+      (interpreter-environment? object)))
 
 (define (make-syntax-table #!optional parent)
   (%make-syntax-table '()
 		      (if (default-object? parent)
-			  false
+			  #f
 			  (guarantee-syntax-table parent 'MAKE-SYNTAX-TABLE))))
 
 (define (guarantee-syntax-table table procedure)
-  (if (not (syntax-table? table))
-      (error:wrong-type-argument table "syntax table" procedure))
-  table)
+  (cond ((%syntax-table? table) table)
+	((interpreter-environment? table) (environment-syntax-table table))
+	(else (error:wrong-type-argument table "syntax table" procedure))))
+
+(define (syntax-table/parent table)
+  (syntax-table/%parent (guarantee-syntax-table table 'SYNTAX-TABLE/PARENT)))
 
 (define (syntax-table/ref table name)
-  (guarantee-syntax-table table 'SYNTAX-TABLE/REF)
-  (let loop ((table table))
+  (let loop ((table (guarantee-syntax-table table 'SYNTAX-TABLE/REF)))
     (and table
 	 (let ((entry (assq name (syntax-table/alist table))))
 	   (if entry
 	       (cdr entry)
-	       (loop (syntax-table/parent table)))))))
+	       (loop (syntax-table/%parent table)))))))
 
 (define syntax-table-ref
   syntax-table/ref)
 
 (define (syntax-table/define table name transform)
-  (guarantee-syntax-table table 'SYNTAX-TABLE/DEFINE)
-  (let ((entry (assq name (syntax-table/alist table))))
-    (if entry
-	(set-cdr! entry transform)
-	(set-syntax-table/alist! table
-				 (cons (cons name transform)
-				       (syntax-table/alist table))))))
+  (let ((table (guarantee-syntax-table table 'SYNTAX-TABLE/DEFINE)))
+    (let ((entry (assq name (syntax-table/alist table))))
+      (if entry
+	  (set-cdr! entry transform)
+	  (set-syntax-table/alist! table
+				   (cons (cons name transform)
+					 (syntax-table/alist table)))))))
 
 (define syntax-table-define
   syntax-table/define)
 
 (define (syntax-table/defined-names table)
-  (map car (syntax-table/alist table)))
+  (map car
+       (syntax-table/alist
+	(guarantee-syntax-table table 'SYNTAX-TABLE/DEFINED-NAMES))))
 
 (define (syntax-table/copy table)
-  (guarantee-syntax-table table 'SYNTAX-TABLE/COPY)
-  (let loop ((table table))
+  (let loop ((table (guarantee-syntax-table table 'SYNTAX-TABLE/COPY)))
     (and table
 	 (%make-syntax-table (alist-copy (syntax-table/alist table))
-			     (loop (syntax-table/parent table))))))
+			     (loop (syntax-table/%parent table))))))
 
 (define (syntax-table/extend table alist)
-  (guarantee-syntax-table table 'SYNTAX-TABLE/EXTEND)
-  (%make-syntax-table (alist-copy alist) table))
\ No newline at end of file
+  (%make-syntax-table (alist-copy alist)
+		      (guarantee-syntax-table table 'SYNTAX-TABLE/EXTEND)))
\ No newline at end of file