From 856ade927926b381d1c60e7f017ebce3a9d371f1 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Mon, 29 Jan 2018 21:43:28 -0800 Subject: [PATCH] Rename block-declaration -> scode-block-declaration and move to "scode". --- src/cref/anfile.scm | 2 +- src/runtime/lambda.scm | 12 +++--------- src/runtime/runtime.pkg | 6 +++--- src/runtime/scan.scm | 11 +++++------ src/runtime/scode.scm | 17 +++++++++++++++++ src/runtime/syntax-output.scm | 4 ++-- src/runtime/unsyn.scm | 8 ++++---- 7 files changed, 35 insertions(+), 25 deletions(-) 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))) -- 2.25.1