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

diff --git a/src/cref/anfile.scm b/src/cref/anfile.scm
index 273604c3ee1b4ac54029b95004433852e7cf0252..c038c3ecf10165a99096e7a1e60e166a04873be9 100644 (file)
--- 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 36776749f337656d9008f90ecca2d8ff71ee25c8..abba9e13af49db5d674d04f3fa4c47302f54963a 100644 (file)
--- 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))
 \f
 ;;;; Simple Lambda
 (define (slambda-arity slambda offset)

diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index d69099c57948bc57bd73a90b760807575790ebcc..e117f38cced047f10d5e0e5b10f7585515714dbe 100644 (file)
--- 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 9a8fc012dccdbf326008715796f9d12ca2926ec5..adf54347e2b1f1637e81356966e16ebd1d286255 100644 (file)
--- 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*))))
 \f
 ;;;; Open Block
 

diff --git a/src/runtime/scode.scm b/src/runtime/scode.scm
index cf166fa6660266b65d26f7ff69a603b52e43b56c..d5b4619078caac55e40e9adc0e7029b578a6fe9c 100644 (file)
--- 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]|)
 \f
 ;;;; Lambda
 

diff --git a/src/runtime/syntax-output.scm b/src/runtime/syntax-output.scm
index d2fd6ff7796ecf088b02895ecd25224815b0ace9..680a7772faddb399821dfb161da475413dbc8520 100644 (file)
--- 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 58b78ba03f39c49100ef9b67a3da79925ffe0168..0b4ca33bafa6decb82ccb3c521636e022acf249b 100644 (file)
--- 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)))