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 14ad219726e8655027a5630522767570f379e901..182ac58e91d6365582c3332d4af783e5791de197 100644 (file)
--- 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))
 \f
 (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