From 6041c17f98926de88a9c2d43f80d4b4f293c5050 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Thu, 16 Jun 1988 06:29:40 +0000 Subject: [PATCH] Flush occurrences of `make-named-tag'. --- v7/src/runtime/lambda.scm | 29 ++++++++++------------------- v7/src/runtime/scan.scm | 8 +++----- v7/src/runtime/scode.scm | 14 ++++++++++---- v7/src/runtime/syntax.scm | 27 ++++++++++++++++++--------- 4 files changed, 41 insertions(+), 37 deletions(-) diff --git a/v7/src/runtime/lambda.scm b/v7/src/runtime/lambda.scm index 8a1c40fec..580fa42a0 100644 --- 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)) (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)) ;;;; Simple Lambda/Lexpr @@ -471,8 +459,11 @@ MIT in each case. |# ;;;; 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 e6af8a3df..411429b59 100644 --- 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 538e44830..cf4fb7346 100644 --- 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)) (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 be3b3bf53..6e3d77337 100644 --- 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))) ;;;; 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]")) ;;;; Lambda List Parser -- 2.25.1