Flush occurrences of `make-named-tag'.

diff --git a/v7/src/runtime/lambda.scm b/v7/src/runtime/lambda.scm
index 8a1c40fec0bce4afdc0b5a47a1ea4692780f9235..580fa42a0fb5422f9c5226f2826127ee165d3213 100644 (file)
--- a/v7/src/runtime/lambda.scm
+++ b/v7/src/runtime/lambda.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 14.1 1988/06/13 11:46:39 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 14.2 1988/06/16 06:28:28 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -38,11 +38,6 @@ MIT in each case. |#
 (declare (usual-integrations))
 \f
 (define (initialize-package!)
-  (set! lambda-tag:internal-lambda (make-named-tag "INTERNAL-LAMBDA"))
-  (set! lambda-tag:internal-lexpr (make-named-tag "INTERNAL-LEXPR"))
-  (set! block-declaration-tag (make-named-tag "Block Declaration"))
-  (unparser/set-tagged-vector-method! block-declaration-tag
-    (unparser/standard-method 'BLOCK-DECLARATION))
   (lambda-body-procedures clambda/physical-body clambda/set-physical-body!
     (lambda (wrap-body! wrapper-components unwrap-body!
                        unwrapped-body set-unwrapped-body!)
@@ -412,18 +407,11 @@ MIT in each case. |#
 (define set-lambda-body!)
 (define lambda-bound)
 
-(define-integrable (make-block-declaration text)
-  (vector block-declaration-tag text))
+(define-integrable block-declaration-tag
+  (string->symbol "#[Block Declaration]"))
 
-(define (block-declaration? object)
-  (and (vector? object)
-       (not (zero? (vector-length object)))
-       (eq? (vector-ref object 0) block-declaration-tag)))
-
-(define-integrable (block-declaration-text block-declaration)
-  (vector-ref block-declaration 1))
-
-(define block-declaration-tag)
+(define-structure (block-declaration (named block-declaration-tag))
+  (text false read-only true))
 \f
 ;;;; Simple Lambda/Lexpr
 
@@ -471,8 +459,11 @@ MIT in each case. |#
 \f
 ;;;; Internal Lambda
 
-(define lambda-tag:internal-lambda)
-(define lambda-tag:internal-lexpr)
+(define-integrable lambda-tag:internal-lambda
+  (string->symbol "#[INTERNAL-LAMBDA]"))
+
+(define-integrable lambda-tag:internal-lexpr
+  (string->symbol "#[INTERNAL-LEXPR]"))
 
 (define-integrable (make-internal-lambda names body)
   (make-slambda lambda-tag:internal-lambda names body))

diff --git a/v7/src/runtime/scan.scm b/v7/src/runtime/scan.scm
index e6af8a3dffe4536a317266188c3267a5d05bf8a6..411429b5950fce8c5c719bcd0c6f64d4e08b8bb0 100644 (file)
--- a/v7/src/runtime/scan.scm
+++ b/v7/src/runtime/scan.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scan.scm,v 14.1 1988/06/13 11:50:55 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scan.scm,v 14.2 1988/06/16 06:28:56 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -53,10 +53,8 @@ MIT in each case. |#
 ;;; OPEN-BLOCK-COMPONENTS, will connect directly to SCAN-DEFINES and
 ;;; UNSCAN-DEFINES, respectively.
 
-(define (initialize-package!)
-  (set! open-block-tag (make-named-tag "OPEN-BLOCK")))
-
-(define open-block-tag)
+(define-integrable open-block-tag
+  (string->symbol "#[OPEN-BLOCK]"))
 
 (define-integrable sequence-2-type
   (ucode-type sequence-2))

diff --git a/v7/src/runtime/scode.scm b/v7/src/runtime/scode.scm
index 538e4483012b065560c41eb19293ca0c2b5edd1e..cf4fb7346bd0368d6570c077808fa1de03beaf2e 100644 (file)
--- a/v7/src/runtime/scode.scm
+++ b/v7/src/runtime/scode.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 14.1 1988/06/13 11:51:00 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 14.2 1988/06/16 06:29:20 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -38,8 +38,7 @@ MIT in each case. |#
 (declare (usual-integrations))
 \f
 (define (initialize-package!)
-  (set! scode-constant/type-vector (make-scode-constant/type-vector))
-  (set! declaration-tag (make-named-tag "DECLARATION")))
+  (set! scode-constant/type-vector (make-scode-constant/type-vector)))
 
 ;;;; Constant
 
@@ -116,6 +115,12 @@ MIT in each case. |#
 (define-integrable (intern string)
   (string->symbol (string-upcase string)))
 
+(define-integrable (symbol-hash symbol)
+  (string-hash (symbol->string symbol)))
+
+(define (symbol-append . symbols)
+  (string->symbol (apply string-append (map symbol->string symbols))))
+
 ;;;; Variable
 
 (define-integrable (make-variable name)
@@ -220,7 +225,8 @@ MIT in each case. |#
         (and (pair? text)
              (eq? (car text) declaration-tag)))))
 
-(define declaration-tag)
+(define-integrable declaration-tag
+  (string->symbol "#[DECLARATION]"))
 
 (define-integrable (declaration-text declaration)
   (cdr (comment-text declaration)))

diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm
index be3b3bf53c8234c264db44ad64984197fb843fc8..6e3d77337743f58f03a06b056fea56d0944d614e 100644 (file)
--- a/v7/src/runtime/syntax.scm
+++ b/v7/src/runtime/syntax.scm
@@ -1,6 +1,6 @@
 #| -*-Scheme-*-
 
-$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.1 1988/06/13 11:54:32 cph Exp $
+$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.2 1988/06/16 06:29:40 cph Exp $
 
 Copyright (c) 1988 Massachusetts Institute of Technology
 
@@ -40,18 +40,10 @@ MIT in each case. |#
 (define (initialize-package!)
   (set-fluid-let-type! 'SHALLOW)
   (enable-scan-defines!)
-  (set! lambda-tag:unnamed (make-named-tag "UNNAMED-PROCEDURE"))
-  (set! lambda-tag:let (make-named-tag "LET-PROCEDURE"))
-  (set! lambda-tag:fluid-let (make-named-tag "FLUID-LET-PROCEDURE"))
-  (set! lambda-tag:make-environment (make-named-tag "MAKE-ENVIRONMENT"))
   (set! system-global-syntax-table (make-system-global-syntax-table))
   (set! user-initial-syntax-table
        (make-syntax-table system-global-syntax-table)))
 
-(define lambda-tag:unnamed)
-(define lambda-tag:let)
-(define lambda-tag:fluid-let)
-(define lambda-tag:make-environment)
 (define system-global-syntax-table)
 (define user-initial-syntax-table)
 
@@ -347,6 +339,11 @@ MIT in each case. |#
                             (if (null? rest)
                                 undefined-conditional-branch
                                 (loop (car rest) (cdr rest))))))))
+
+(define (syntaxer/cond-=>-helper form1-result thunk2 thunk3)
+  (if form1-result
+      ((thunk2) form1-result)
+      (thunk3)))
 \f
 ;;;; Procedures
 
@@ -595,6 +592,18 @@ MIT in each case. |#
                     (make-scode-sequence
                      (append! (map make-definition names values)
                               (list body)))))
+
+(define-integrable lambda-tag:unnamed
+  (string->symbol "#[UNNAMED-PROCEDURE]"))
+
+(define-integrable lambda-tag:let
+  (string->symbol "#[LET-PROCEDURE]"))
+
+(define-integrable lambda-tag:fluid-let
+  (string->symbol "#[FLUID-LET-PROCEDURE]"))
+
+(define-integrable lambda-tag:make-environment
+  (string->symbol "#[MAKE-ENVIRONMENT]"))
 \f
 ;;;; Lambda List Parser