From d90a8f04d729e6edd173d436dd9888a5e5d9629e Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Sun, 14 Mar 2010 19:04:47 -0700 Subject: [PATCH] Recognize open-blocks even if they appear in a sequence-2. --- src/runtime/scan.scm | 37 ++++++++++++++++++++++++++++--------- 1 file changed, 28 insertions(+), 9 deletions(-) diff --git a/src/runtime/scan.scm b/src/runtime/scan.scm index 34223f91d..d4a870e73 100644 --- a/src/runtime/scan.scm +++ b/src/runtime/scan.scm @@ -79,9 +79,19 @@ USA. (define (scan-loop expression receiver) (cond ((object-type? sequence-2-type expression) - (scan-loop (&pair-cdr expression) - (scan-loop (&pair-car expression) - receiver))) + (let ((first (&pair-car expression))) + (if (and (vector? first) + (not (zero? (vector-length first))) + (eq? (vector-ref first 0) open-block-tag)) + (scan-loop + (&pair-cdr (&pair-cdr expression)) + (lambda (names declarations body) + (receiver (append (vector-ref first 1) names) + (append (vector-ref first 2) declarations) + body))) + (scan-loop (&pair-cdr expression) + (scan-loop first + receiver))))) ((object-type? sequence-3-type expression) (let ((first (&triple-first expression))) (if (and (vector? first) @@ -184,14 +194,23 @@ USA. body))) (define (open-block? object) - (and (object-type? sequence-3-type object) - (vector? (&triple-first object)) - (eq? (vector-ref (&triple-first object) 0) open-block-tag))) + (or (and (object-type? sequence-2-type object) + (vector? (&pair-car object)) + (eq? (vector-ref (&pair-car object) 0) open-block-tag)) + (and (object-type? sequence-3-type object) + (vector? (&triple-first object)) + (eq? (vector-ref (&triple-first object) 0) open-block-tag)))) (define-guarantee open-block "SCode open-block") (define (open-block-components open-block receiver) (guarantee-open-block open-block 'OPEN-BLOCK-COMPONENTS) - (receiver (vector-ref (&triple-first open-block) 1) - (vector-ref (&triple-first open-block) 2) - (&triple-third open-block))) \ No newline at end of file + (cond ((object-type? sequence-2-type open-block) + (receiver (vector-ref (&pair-car open-block) 1) + (vector-ref (&pair-car open-block) 2) + (&pair-cdr (&pair-cdr open-block)))) + ((object-type? sequence-3-type open-block) + (receiver (vector-ref (&triple-first open-block) 1) + (vector-ref (&triple-first open-block) 2) + (&triple-third open-block))) + (else (error:not-open-block open-block 'open-block-components)))) \ No newline at end of file -- 2.25.1