From a6ca5ab263ca049f9425beb3d9fd931a2e560006 Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Fri, 20 Jan 2012 10:42:10 -0800 Subject: [PATCH] Remove SEQUENCE-3 from Scheme code. --- src/compiler/fggen/canon.scm | 2 +- src/compiler/fggen/fggen.scm | 33 +++++------------ src/runtime/codwlk.scm | 2 +- src/runtime/conpar.scm | 2 - src/runtime/framex.scm | 11 ++---- src/runtime/prgcop.scm | 9 ++--- src/runtime/scan.scm | 71 ++++++++---------------------------- src/runtime/unpars.scm | 3 +- 8 files changed, 35 insertions(+), 98 deletions(-) diff --git a/src/compiler/fggen/canon.scm b/src/compiler/fggen/canon.scm index 9ca9833b2..f5a1c946e 100644 --- a/src/compiler/fggen/canon.scm +++ b/src/compiler/fggen/canon.scm @@ -874,7 +874,7 @@ ARBITRARY: The expression may be executed more than once. It primitive-combination-3) canonicalize/combination) (dispatch-entries (lambda lexpr extended-lambda) canonicalize/lambda) - (dispatch-entries (sequence-2 sequence-3) canonicalize/sequence)) + (dispatch-entry sequence-2 canonicalize/sequence)) (named-lambda (canonicalize/expression expression bound context) ((vector-ref dispatch-vector (object-type expression)) expression bound context)))) \ No newline at end of file diff --git a/src/compiler/fggen/fggen.scm b/src/compiler/fggen/fggen.scm index afebe531d..e711e4190 100644 --- a/src/compiler/fggen/fggen.scm +++ b/src/compiler/fggen/fggen.scm @@ -501,30 +501,17 @@ USA. ;;;; Combinators (define (generate/sequence block continuation context expression) - (let ((join (scfg*ctype->ctype! continuation))) - (let ((do-action - (lambda (action continuation-type) - (generate/subproblem/effect block continuation context - action continuation-type expression))) - (do-result - (lambda (expression) - (generate/expression block continuation context expression)))) - ;; These are done in a funny way to enforce processing in sequence order. + (if (object-type? (ucode-type sequence-2) expression) + ;; This is done in a funny way to enforce processing in sequence order. ;; In this way, compile-by-procedures compiles in a predictable order. - (cond ((object-type? (ucode-type sequence-2) expression) - (let ((first (do-action (&pair-car expression) 'SEQUENCE-2-SECOND))) - (join first - (do-result (&pair-cdr expression))))) - ((object-type? (ucode-type sequence-3) expression) - (let ((first (do-action (&triple-first expression) 'SEQUENCE-3-SECOND))) - (join - first - (let ((second (do-action (&triple-second expression) 'SEQUENCE-3-THIRD))) - (join - second - (do-result (&triple-third expression))))))) - (else - (error "Not a sequence" expression)))))) + (let ((first (generate/subproblem/effect + block continuation context + (&pair-car expression) 'SEQUENCE-2-SECOND + expression))) + ((scfg*ctype->ctype! continuation) + first + (generate/expression block continuation context (&pair-cdr expression)))) + (error "Not a sequence" expression))) (define (generate/conditional block continuation context expression) (scode/conditional-components expression diff --git a/src/runtime/codwlk.scm b/src/runtime/codwlk.scm index f318359d3..86349f316 100644 --- a/src/runtime/codwlk.scm +++ b/src/runtime/codwlk.scm @@ -123,7 +123,7 @@ USA. (DISJUNCTION ,walk/disjunction) ((LAMBDA LEXPR EXTENDED-LAMBDA) ,walk/lambda) (QUOTATION ,walk/quotation) - ((SEQUENCE-2 SEQUENCE-3) ,walk/sequence) + (SEQUENCE-2 ,walk/sequence) (THE-ENVIRONMENT ,walk/the-environment) (VARIABLE ,walk/variable))) table))) diff --git a/src/runtime/conpar.scm b/src/runtime/conpar.scm index abcf00095..8b2e34d67 100644 --- a/src/runtime/conpar.scm +++ b/src/runtime/conpar.scm @@ -811,8 +811,6 @@ USA. (standard-subproblem 'ASSIGNMENT-CONTINUE 3) (standard-subproblem 'DEFINITION-CONTINUE 3) (standard-subproblem 'SEQUENCE-2-SECOND 3) - (standard-subproblem 'SEQUENCE-3-SECOND 3) - (standard-subproblem 'SEQUENCE-3-THIRD 3) (standard-subproblem 'CONDITIONAL-DECIDE 3) (standard-subproblem 'DISJUNCTION-DECIDE 3) (standard-subproblem 'COMBINATION-1-PROCEDURE 3) diff --git a/src/runtime/framex.scm b/src/runtime/framex.scm index f0d7fdec3..563ae539a 100644 --- a/src/runtime/framex.scm +++ b/src/runtime/framex.scm @@ -230,11 +230,8 @@ USA. ((ASSIGNMENT-CONTINUE DEFINITION-CONTINUE) (win &pair-cdr)) - ((SEQUENCE-3-SECOND - CONDITIONAL-DECIDE) + ((CONDITIONAL-DECIDE) (win &triple-first)) - ((SEQUENCE-3-THIRD) - (win &triple-second)) ((COMBINATION-OPERAND) (values expression @@ -283,11 +280,9 @@ USA. (record-method 'COMBINATION-1-PROCEDURE method) (record-method 'DEFINITION-CONTINUE method)) (let ((method (method/standard &triple-first))) - (record-method 'CONDITIONAL-DECIDE method) - (record-method 'SEQUENCE-3-SECOND method)) + (record-method 'CONDITIONAL-DECIDE method)) (let ((method (method/standard &triple-second))) - (record-method 'COMBINATION-2-PROCEDURE method) - (record-method 'SEQUENCE-3-THIRD method)) + (record-method 'COMBINATION-2-PROCEDURE method)) (let ((method (method/standard &triple-third))) (record-method 'COMBINATION-2-FIRST-OPERAND method) (record-method 'PRIMITIVE-COMBINATION-2-FIRST-OPERAND method)) diff --git a/src/runtime/prgcop.scm b/src/runtime/prgcop.scm index bf9c7c16f..0550a2dc4 100644 --- a/src/runtime/prgcop.scm +++ b/src/runtime/prgcop.scm @@ -227,12 +227,9 @@ USA. typed)) (define (copy-SEQUENCE-object obj) - (cond ((object-type? (ucode-type SEQUENCE-2) obj) - (%%copy-pair (ucode-type SEQUENCE-2) obj)) - ((object-type? (ucode-type SEQUENCE-3) obj) - (%%copy-triple (ucode-type SEQUENCE-3) obj)) - (else - (error "copy-SEQUENCE-object: Unknown type" obj)))) + (if (object-type? (ucode-type SEQUENCE-2) obj) + (%%copy-pair (ucode-type SEQUENCE-2) obj) + (error "copy-SEQUENCE-object: Unknown type" obj))) (define (copy-COMBINATION-object obj) (cond ((object-type? (ucode-type combination) obj) diff --git a/src/runtime/scan.scm b/src/runtime/scan.scm index 447f4358b..88a6f7b6f 100644 --- a/src/runtime/scan.scm +++ b/src/runtime/scan.scm @@ -48,19 +48,16 @@ USA. (define-integrable open-block-tag ((ucode-primitive string->symbol) "#[open-block]")) -(define-integrable sequence-2-type +(define-integrable sequence-type (ucode-type sequence-2)) -(define-integrable sequence-3-type - (ucode-type sequence-3)) - (define null-sequence '(NULL-SEQUENCE)) (define (cons-sequence action seq) (if (eq? seq null-sequence) action - (&typed-pair-cons sequence-2-type action seq))) + (&typed-pair-cons sequence-type action seq))) ;;;; Scanning @@ -73,7 +70,7 @@ USA. ((scan-loop expression receiver) '() '() null-sequence)) (define (scan-loop expression receiver) - (cond ((object-type? sequence-2-type expression) + (cond ((object-type? sequence-type expression) (let ((first (&pair-car expression))) (if (and (vector? first) (not (zero? (vector-length first))) @@ -87,21 +84,6 @@ USA. (scan-loop (&pair-cdr expression) (scan-loop first receiver))))) - ((object-type? sequence-3-type expression) - (let ((first (&triple-first expression))) - (if (and (vector? first) - (not (zero? (vector-length first))) - (eq? (vector-ref first 0) open-block-tag)) - (scan-loop - (&triple-third expression) - (lambda (names declarations body) - (receiver (append (vector-ref first 1) names) - (append (vector-ref first 2) declarations) - body))) - (scan-loop (&triple-third expression) - (scan-loop (&triple-second expression) - (scan-loop first - receiver)))))) ((definition? expression) (definition-components expression (lambda (name value) @@ -131,7 +113,7 @@ USA. names*)) (if (null? declarations) body* - (&typed-pair-cons sequence-2-type + (&typed-pair-cons sequence-type (make-block-declaration declarations) body*))))) @@ -146,29 +128,15 @@ USA. (make-definition name value)) (receiver names body))))) - ((object-type? sequence-2-type 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-2-type + (&typed-pair-cons sequence-type body* body**))))))) - ((object-type? sequence-3-type body) - (unscan-loop names (&triple-first body) - (lambda (names* body*) - (unscan-loop names* (&triple-second body) - (lambda (names** body**) - (unscan-loop names** (&triple-third body) - (lambda (names*** body***) - (receiver names*** - (&typed-pair-cons sequence-2-type - body* - (&typed-pair-cons - sequence-2-type - body** - body***)))))))))) (else (receiver names body)))) @@ -180,10 +148,10 @@ USA. (null? declarations)) body (&typed-pair-cons - sequence-2-type + sequence-type (vector open-block-tag names declarations) (&typed-pair-cons - sequence-2-type + sequence-type (if (null? names) '() (make-sequence @@ -193,23 +161,16 @@ USA. body)))) (define (open-block? object) - (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)))) + (and (object-type? sequence-type object) + (vector? (&pair-car object)) + (eq? (vector-ref (&pair-car 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) - (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 + (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 diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index 12ee4225b..7c6bf1d56 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -299,8 +299,7 @@ USA. (PRIMITIVE-COMBINATION-1 . COMBINATION) (PRIMITIVE-COMBINATION-2 . COMBINATION) (PRIMITIVE-COMBINATION-3 . COMBINATION) - (SEQUENCE-2 . SEQUENCE) - (SEQUENCE-3 . SEQUENCE))) + (SEQUENCE-2 . SEQUENCE))) (define (unparse/false object) (if (eq? object #f) -- 2.25.1