From 2dc04032a1ee29408a6ed438a48008fdd562d40a Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Tue, 7 Feb 2012 10:42:30 -0800 Subject: [PATCH] Add selectors for OPEN-BLOCKs, rewrite unscan-defines in direct style. --- src/runtime/runtime.pkg | 4 + src/runtime/scan.scm | 191 ++++++++++++++++++++++++++-------------- 2 files changed, 127 insertions(+), 68 deletions(-) diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg index b02226455..7eabfa002 100644 --- a/src/runtime/runtime.pkg +++ b/src/runtime/runtime.pkg @@ -3715,7 +3715,11 @@ USA. (parent (runtime)) (export () make-open-block + open-block-actions open-block-components + open-block-declarations + open-block-definitions + open-block-names open-block? scan-defines unscan-defines)) diff --git a/src/runtime/scan.scm b/src/runtime/scan.scm index 88a6f7b6f..b07a100cd 100644 --- a/src/runtime/scan.scm +++ b/src/runtime/scan.scm @@ -70,20 +70,20 @@ USA. ((scan-loop expression receiver) '() '() null-sequence)) (define (scan-loop expression receiver) - (cond ((object-type? sequence-type expression) - (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))))) + (cond ((open-block? expression) ; must come before SEQUENCE? clause + (scan-loop + (%open-block-actions expression) + (lambda (names declarations body) + (receiver (append (%open-block-names expression) names) + (append (%open-block-declarations expression) declarations) + body)))) + ((sequence? expression) + ;; Build the sequence from the tail-end first so that the + ;; null-sequence shows up in the tail and is detected by + ;; cons-sequence. + (scan-loop (sequence-immediate-second expression) + (scan-loop (sequence-immediate-first expression) + receiver))) ((definition? expression) (definition-components expression (lambda (name value) @@ -105,72 +105,127 @@ USA. (cons-sequence expression body)))))) (define (unscan-defines names declarations body) - (unscan-loop names body - (lambda (names* body*) - (if (not (null? names*)) - (error "Extraneous auxiliaries -- get a wizard" - 'UNSCAN-DEFINES - names*)) - (if (null? declarations) - body* - (&typed-pair-cons sequence-type - (make-block-declaration declarations) - body*))))) - -(define (unscan-loop names body receiver) - (cond ((not (pair? names)) - (receiver '() body)) - ((assignment? body) - (assignment-components body - (lambda (name value) - (if (eq? name (car names)) - (receiver (cdr names) - (make-definition name value)) - (receiver names - body))))) - ((object-type? sequence-type body) - (unscan-loop names (&pair-car body) - (lambda (names* body*) - (unscan-loop names* (&pair-cdr body) - (lambda (names** body**) - (receiver names** - (&typed-pair-cons sequence-type - body* - body**))))))) - (else - (receiver names - body)))) + + (define (unscan-loop names body) + (cond ((not (pair? names)) + (values '() body)) + + ((assignment? body) + (assignment-components body + (lambda (name value) + (if (eq? name (car names)) + (values (cdr names) (make-definition name value)) + (values names body))))) + + ((sequence? body) + (let ((head (sequence-immediate-first body)) + (tail (sequence-immediate-second body))) + + (receive (names1 unscanned-head) (unscan-loop names head) + (receive (names2 unscanned-tail) (unscan-loop names1 tail) + (values names2 + ;; Only cons a new sequence if something changed. + (if (and (eq? head unscanned-head) + (eq? tail unscanned-tail)) + body + (&typed-pair-cons + sequence-type + unscanned-head unscanned-tail))))))) + + (else + (values names body)))) + + (receive (names* body*) (unscan-loop names body) + (if (not (null? names*)) + (error "Extraneous auxiliaries -- get a wizard" + 'UNSCAN-DEFINES + names*)) + + (if (null? declarations) + body* + (&typed-pair-cons + sequence-type + (make-block-declaration declarations) + body*)))) ;;;; Open Block -(define (make-open-block names declarations body) +(define (make-open-block names declarations actions) (if (and (null? names) (null? declarations)) - body + actions (&typed-pair-cons sequence-type - (vector open-block-tag names declarations) + (make-open-block-descriptor names declarations) (&typed-pair-cons sequence-type - (if (null? names) - '() - (make-sequence - (map (lambda (name) - (make-definition name (make-unassigned-reference-trap))) - names))) - body)))) + (make-open-block-definitions names) + actions)))) (define (open-block? object) - (and (object-type? sequence-type object) - (vector? (&pair-car object)) - (eq? (vector-ref (&pair-car object) 0) open-block-tag))) + (and (sequence? object) + (open-block-descriptor? (sequence-immediate-first object)) + (sequence? (sequence-immediate-second object)))) -(define-guarantee open-block "SCode open-block") +(define (open-block-actions open-block) + (guarantee-open-block open-block 'OPEN-BLOCK-ACTIONS) + (%open-block-actions open-block)) + +(define (open-block-declarations open-block) + (guarantee-open-block open-block 'OPEN-BLOCK-DECLARATIONS) + (%open-block-declarations open-block)) + +(define (open-block-definitions open-block) + (guarantee-open-block open-block 'OPEN-BLOCK-DEFINITIONS) + (%open-block-definitions open-block)) + +(define (open-block-names open-block) + (guarantee-open-block open-block 'OPEN-BLOCK-NAMES) + (%open-block-names open-block)) (define (open-block-components open-block receiver) (guarantee-open-block open-block 'OPEN-BLOCK-COMPONENTS) - (if (object-type? sequence-type open-block) - (receiver (vector-ref (&pair-car open-block) 1) - (vector-ref (&pair-car open-block) 2) - (&pair-cdr (&pair-cdr open-block))) - (error:not-open-block open-block 'open-block-components))) \ No newline at end of file + (let ((descriptor (sequence-immediate-first open-block))) + (receiver (%open-block-descriptor-names descriptor) + (%open-block-descriptor-declarations descriptor) + (%open-block-actions open-block)))) + +(define (make-open-block-definitions names) + (let ((definitions + (map (lambda (name) + (make-definition name (make-unassigned-reference-trap))) + names))) + (if (null? definitions) + '() + (make-sequence definitions)))) + +(define-guarantee open-block "SCode open-block") + +(define (%open-block-descriptor open-block) + (sequence-immediate-first open-block)) + +(define (%open-block-actions open-block) + (sequence-immediate-second (sequence-immediate-second open-block))) + +(define (%open-block-declarations open-block) + (%open-block-descriptor-declarations (%open-block-descriptor open-block))) + +(define (%open-block-definitions open-block) + (sequence-immediate-first (sequence-immediate-second open-block))) + +(define (%open-block-names open-block) + (%open-block-descriptor-names (%open-block-descriptor open-block))) + +(define (make-open-block-descriptor names declarations) + (vector open-block-tag names declarations)) + +(define (open-block-descriptor? object) + (and (vector? object) + (not (zero? (vector-length object))) + (eq? (vector-ref object 0) open-block-tag))) + +(define (%open-block-descriptor-names descriptor) + (vector-ref descriptor 1)) + +(define (%open-block-descriptor-declarations descriptor) + (vector-ref descriptor 2)) \ No newline at end of file -- 2.25.1