From: Chris Hanson <org/chris-hanson/cph>
Date: Tue, 30 Jan 2018 05:43:28 +0000 (-0800)
Subject: Rename block-declaration -> scode-block-declaration and move to "scode".
X-Git-Tag: mit-scheme-pucked-x11-0.3.1~7^2~286
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=856ade927926b381d1c60e7f017ebce3a9d371f1;p=mit-scheme.git

Rename block-declaration -> scode-block-declaration and move to "scode".
---

diff --git a/src/cref/anfile.scm b/src/cref/anfile.scm
index 273604c3e..c038c3ecf 100644
--- a/src/cref/anfile.scm
+++ b/src/cref/anfile.scm
@@ -46,7 +46,7 @@ USA.
   (if (null? expressions)
       (values '() '())
       (let ((rest (lambda () (sort-expressions (cdr expressions)))))
-	(if (block-declaration? (car expressions))
+	(if (scode-block-declaration? (car expressions))
 	    (rest)
 	    (receive (definitions others) (rest)
 	      (if (scode-definition? (car expressions))
diff --git a/src/runtime/lambda.scm b/src/runtime/lambda.scm
index 36776749f..abba9e13a 100644
--- a/src/runtime/lambda.scm
+++ b/src/runtime/lambda.scm
@@ -423,7 +423,7 @@ USA.
   (let ((body*
 	 (if (null? declarations)
 	     body
-	     (make-scode-sequence (list (make-block-declaration declarations)
+	     (make-scode-sequence (list (make-scode-block-declaration declarations)
 					body)))))
     (cond ((and (< (length required) 256)
 		(< (length optional) 256)
@@ -443,9 +443,9 @@ USA.
       (let ((actions
 	     (and (scode-sequence? body)
 		  (scode-sequence-actions body))))
-	(if (and actions (block-declaration? (car actions)))
+	(if (and actions (scode-block-declaration? (car actions)))
 	    (receiver name required optional rest auxiliary
-		      (block-declaration-text (car actions))
+		      (scode-block-declaration-text (car actions))
 		      (make-scode-sequence (cdr actions)))
 	    (receiver name required optional rest auxiliary '() body))))))
 
@@ -469,12 +469,6 @@ USA.
 (define lambda-unwrap-body!)
 (define lambda-immediate-body)
 (define lambda-names-vector)
-
-(define-structure (block-declaration
-		   (type vector)
-		   (named ((ucode-primitive string->symbol)
-			   "#[Block Declaration]")))
-  (text #f read-only #t))
 
 ;;;; Simple Lambda
 (define (slambda-arity slambda offset)
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d69099c57..e117f38cc 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -2804,9 +2804,6 @@ USA.
   (files "lambda")
   (parent (runtime))
   (export ()
-	  block-declaration-text
-	  block-declaration?
-	  make-block-declaration
 	  make-scode-lambda
 	  scode-lambda-body
 	  scode-lambda-bound
@@ -3894,6 +3891,7 @@ USA.
 	  make-scode-absolute-reference
 	  make-scode-access
 	  make-scode-assignment
+	  make-scode-block-declaration
 	  make-scode-combination
 	  make-scode-comment
 	  make-scode-conditional
@@ -3915,6 +3913,8 @@ USA.
 	  scode-assignment-name
 	  scode-assignment-value
 	  scode-assignment?
+	  scode-block-declaration-text
+	  scode-block-declaration?
 	  scode-combination-operands
 	  scode-combination-operator
 	  scode-combination?
diff --git a/src/runtime/scan.scm b/src/runtime/scan.scm
index 9a8fc012d..adf54347e 100644
--- a/src/runtime/scan.scm
+++ b/src/runtime/scan.scm
@@ -91,10 +91,10 @@ USA.
 		       declarations
 		       (cons-sequence (make-scode-assignment name value)
 				      body)))))
-	((block-declaration? expression)
+	((scode-block-declaration? expression)
 	 (lambda (names declarations body)
 	   (receiver names
-		     (append (block-declaration-text expression)
+		     (append (scode-block-declaration-text expression)
 			     declarations)
 		     body)))
 	(else
@@ -141,10 +141,9 @@ USA.
 
     (if (null? declarations)
 	body*
-	(&typed-pair-cons
-	 sequence-type
-	 (make-block-declaration declarations)
-	 body*))))
+	(&typed-pair-cons sequence-type
+			  (make-scode-block-declaration declarations)
+			  body*))))
 
 ;;;; Open Block
 
diff --git a/src/runtime/scode.scm b/src/runtime/scode.scm
index cf166fa66..d5b461907 100644
--- a/src/runtime/scode.scm
+++ b/src/runtime/scode.scm
@@ -350,6 +350,23 @@ USA.
 (define (scode-disjunction-alternative disjunction)
   (guarantee scode-disjunction? disjunction 'scode-disjunction-alternative)
   (map-reference-trap (lambda () (system-pair-cdr disjunction))))
+
+;;;; Declaration
+
+(define (make-scode-block-declaration text)
+  (vector block-declaration-marker text))
+
+(define (scode-block-declaration? object)
+  (and (vector? object)
+       (fix:= 2 (vector-length object))
+       (eq? block-declaration-marker (vector-ref object 0))))
+
+(define (scode-block-declaration-text declaration)
+  (guarantee scode-block-declaration? declaration 'scode-block-declaration-text)
+  (vector-ref declaration 1))
+
+(define block-declaration-marker
+  '|#[Block Declaration]|)
 
 ;;;; Lambda
 
diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm
index d2fd6ff77..680a7772f 100644
--- a/src/runtime/syntax-output.scm
+++ b/src/runtime/syntax-output.scm
@@ -121,7 +121,7 @@ USA.
   (scan-defines (let ((declarations (apply append declarations)))
 		  (if (pair? declarations)
 		      (make-scode-sequence
-		       (list (make-block-declaration declarations)
+		       (list (make-scode-block-declaration declarations)
 			     body))
 		      body))
 		make-scode-open-block))
@@ -137,7 +137,7 @@ USA.
 			 make-scode-open-block))))
     (if (pair? declarations)
 	(make-scode-open-block
-	 (cons (make-block-declaration declarations)
+	 (cons (make-scode-block-declaration declarations)
 	       (if (pair? expressions)
 		   expressions
 		   (list (output/unspecific)))))
diff --git a/src/runtime/unsyn.scm b/src/runtime/unsyn.scm
index 58b78ba03..0b4ca33ba 100644
--- a/src/runtime/unsyn.scm
+++ b/src/runtime/unsyn.scm
@@ -212,10 +212,10 @@ USA.
 
 (define (unsyntax-sequence-object environment seq)
   (let loop ((actions (scode-sequence-actions seq)))
-    (if (and (block-declaration? (car actions))
+    (if (and (scode-block-declaration? (car actions))
 	     (pair? (cdr actions)))
 	`(BEGIN
-	  (DECLARE ,@(block-declaration-text (car actions)))
+	  (DECLARE ,@(scode-block-declaration-text (car actions)))
 	  ,@(loop (cdr actions)))
 	`(BEGIN
 	  ,@(unsyntax-sequence-actions environment seq)))))
@@ -399,9 +399,9 @@ USA.
 (define (unsyntax-lambda-body-sequence environment body)
   (if (scode-sequence? body)
       (let ((actions (scode-sequence-actions body)))
-	(if (and (block-declaration? (car actions))
+	(if (and (scode-block-declaration? (car actions))
 		 (pair? (cdr actions)))
-	    `((DECLARE ,@(block-declaration-text (car actions)))
+	    `((DECLARE ,@(scode-block-declaration-text (car actions)))
 	      ,@(unsyntax-sequence environment
 				   (make-scode-sequence (cdr actions))))
 	    (unsyntax-sequence environment body)))