From d4d8ea1cf4762a7a19f843aa368fd5dc78439dbd Mon Sep 17 00:00:00 2001 From: Matt Birkholz Date: Mon, 8 Apr 2013 15:39:17 -0700 Subject: [PATCH] Finish replacing type code SEQUENCE-2 with SEQUENCE. Hack runtime.sf to inform older hosts about new type code. --- src/compiler/fggen/canon.scm | 2 +- src/compiler/fggen/fggen.scm | 2 +- src/runtime/codwlk.scm | 2 +- src/runtime/prgcop.scm | 4 ++-- src/runtime/runtime.sf | 8 ++++++++ src/runtime/scan.scm | 2 +- src/runtime/scomb.scm | 4 ++-- src/runtime/unpars.scm | 3 +-- src/runtime/utabs.scm | 4 +--- 9 files changed, 18 insertions(+), 13 deletions(-) diff --git a/src/compiler/fggen/canon.scm b/src/compiler/fggen/canon.scm index dae64f82d..c6c701448 100644 --- a/src/compiler/fggen/canon.scm +++ b/src/compiler/fggen/canon.scm @@ -869,7 +869,7 @@ ARBITRARY: The expression may be executed more than once. It (standard-entry the-environment) (dispatch-entry combination canonicalize/combination) (dispatch-entries (lambda lexpr extended-lambda) canonicalize/lambda) - (dispatch-entry sequence-2 canonicalize/sequence)) + (dispatch-entry sequence 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 5b0393a6d..3efed1d39 100644 --- a/src/compiler/fggen/fggen.scm +++ b/src/compiler/fggen/fggen.scm @@ -990,7 +990,7 @@ USA. (standard-entry the-environment) (standard-entry variable) (dispatch-entries (lambda lexpr extended-lambda) generate/lambda) - (dispatch-entry sequence-2 generate/sequence) + (dispatch-entry sequence generate/sequence) (dispatch-entry combination generate/combination) (dispatch-entry comment generate/comment)) (named-lambda (generate/expression block continuation context expression) diff --git a/src/runtime/codwlk.scm b/src/runtime/codwlk.scm index 92342fc0e..54680342f 100644 --- a/src/runtime/codwlk.scm +++ b/src/runtime/codwlk.scm @@ -120,7 +120,7 @@ USA. (EXTENDED-LAMBDA ,walk/extended-lambda) ((LAMBDA LEXPR) ,walk/lambda) (QUOTATION ,walk/quotation) - (SEQUENCE-2 ,walk/sequence) + (SEQUENCE ,walk/sequence) (THE-ENVIRONMENT ,walk/the-environment) (VARIABLE ,walk/variable))) table))) diff --git a/src/runtime/prgcop.scm b/src/runtime/prgcop.scm index b98839f17..d89f2b310 100644 --- a/src/runtime/prgcop.scm +++ b/src/runtime/prgcop.scm @@ -227,8 +227,8 @@ USA. typed)) (define (copy-SEQUENCE-object obj) - (if (object-type? (ucode-type SEQUENCE-2) obj) - (%%copy-pair (ucode-type SEQUENCE-2) obj) + (if (object-type? (ucode-type SEQUENCE) obj) + (%%copy-pair (ucode-type SEQUENCE) obj) (error "copy-SEQUENCE-object: Unknown type" obj))) (define (copy-COMBINATION-object obj) diff --git a/src/runtime/runtime.sf b/src/runtime/runtime.sf index 9cb0e8233..f6d36ad32 100644 --- a/src/runtime/runtime.sf +++ b/src/runtime/runtime.sf @@ -24,6 +24,14 @@ USA. |# +;; Temporarily: ensure host knows new type code SEQUENCE. Older hosts +;; have an equivalent SEQUENCE-2 and type-aliases. +(if (not (microcode-type/name->code 'sequence)) + (let ((env (->environment '(runtime microcode-tables)))) + (set! (access type-aliases env) + (cons '(sequence-2 sequence) + (access type-aliases env))))) + (load-option '*PARSER) ;for url.scm (fluid-let ((sf/default-syntax-table (->environment '(RUNTIME)))) (sf-conditionally "char") diff --git a/src/runtime/scan.scm b/src/runtime/scan.scm index b795dc9ac..6b0243843 100644 --- a/src/runtime/scan.scm +++ b/src/runtime/scan.scm @@ -49,7 +49,7 @@ USA. ((ucode-primitive string->symbol) "#[open-block]")) (define-integrable sequence-type - (ucode-type sequence-2)) + (ucode-type sequence)) (define null-sequence '(NULL-SEQUENCE)) diff --git a/src/runtime/scomb.scm b/src/runtime/scomb.scm index ebf03b6be..53eed8607 100644 --- a/src/runtime/scomb.scm +++ b/src/runtime/scomb.scm @@ -33,10 +33,10 @@ USA. ;;;; Sequence (define-integrable (%make-sequence first second) - (&typed-pair-cons (ucode-type sequence-2) first second)) + (&typed-pair-cons (ucode-type sequence) first second)) (define-integrable (sequence? object) - (object-type? (ucode-type sequence-2) object)) + (object-type? (ucode-type sequence) object)) (define-integrable (%sequence-immediate-first sequence) (&pair-car sequence)) (define-integrable (%sequence-immediate-second sequence) (&pair-cdr sequence)) diff --git a/src/runtime/unpars.scm b/src/runtime/unpars.scm index 016ca0986..cd39c1520 100644 --- a/src/runtime/unpars.scm +++ b/src/runtime/unpars.scm @@ -295,8 +295,7 @@ USA. (EXTENDED-PROCEDURE . PROCEDURE) (PRIMITIVE . PRIMITIVE-PROCEDURE) (LEXPR . LAMBDA) - (EXTENDED-LAMBDA . LAMBDA) - (SEQUENCE-2 . SEQUENCE))) + (EXTENDED-LAMBDA . LAMBDA))) (define (unparse/false object) (if (eq? object #f) diff --git a/src/runtime/utabs.scm b/src/runtime/utabs.scm index a49e34977..b9c0243cf 100644 --- a/src/runtime/utabs.scm +++ b/src/runtime/utabs.scm @@ -168,8 +168,7 @@ USA. (define (microcode-return/code-limit) (vector-length (vector-ref (get-fixed-objects-vector) returns-slot))) -(define returns-aliases - '((sequence-continue sequence-2-second))) +(define returns-aliases '()) (define errors-slot) @@ -257,7 +256,6 @@ USA. (BIGNUM BIG-FIXNUM) (PROMISE DELAYED) (FIXNUM ADDRESS POSITIVE-FIXNUM NEGATIVE-FIXNUM) - (SEQUENCE SEQUENCE-2) (STRING CHARACTER-STRING VECTOR-8B) (HUNK3-A UNMARKED-HISTORY) (TRIPLE HUNK3 HUNK3-B MARKED-HISTORY) -- 2.25.1