From: Chris Hanson Date: Sun, 4 Nov 2018 04:55:19 +0000 (-0700) Subject: Allow sequences to contain zero elements. X-Git-Tag: mit-scheme-pucked-10.1.2~16^2~122 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=2f4d0373c12e2e6707f35c25cf37b8f23fdf4485;p=mit-scheme.git Allow sequences to contain zero elements. --- diff --git a/src/compiler/fggen/fggen.scm b/src/compiler/fggen/fggen.scm index fab7c23cb..779468d97 100644 --- a/src/compiler/fggen/fggen.scm +++ b/src/compiler/fggen/fggen.scm @@ -503,21 +503,25 @@ USA. ;;;; Combinators (define (generate/sequence block continuation context expression) - (if (scode/sequence? 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. - (let ((first-action - (generate/subproblem/effect - block continuation context - (car (scode/sequence-actions expression)) - 'SEQUENCE-CONTINUE - expression))) - ((scfg*ctype->ctype! continuation) - first-action - (generate/expression - block continuation context - (scode/make-sequence (cdr (scode/sequence-actions expression)))))) - (error "Not a sequence" expression))) + (if (not (scode/sequence? expression)) + (error "Not a sequence:" expression)) + (let ((actions (scode/sequence-actions expression))) + (if (pair? actions) + (let loop ((actions actions)) + (let ((action (car actions)) + (rest (cdr actions))) + (if (pair? rest) + ;; This is done in a funny way to enforce processing in sequence + ;; order. In this way, compile-by-procedures compiles in a + ;; predictable order. + (let ((first-action + (generate/subproblem/effect block continuation context + action 'sequence-continue + expression))) + ((scfg*ctype->ctype! continuation) first-action (loop rest))) + (generate/expression block continuation context action)))) + (continue/rvalue-constant block continuation + (make-constant unspecific))))) (define (generate/conditional block continuation context expression) (let ((predicate (scode/conditional-predicate expression)) diff --git a/src/runtime/lambda.scm b/src/runtime/lambda.scm index c42ad2fb7..f4ffd75a0 100644 --- a/src/runtime/lambda.scm +++ b/src/runtime/lambda.scm @@ -444,7 +444,8 @@ USA. (let ((actions (and (scode-sequence? body) (scode-sequence-actions body)))) - (if (and actions (scode-block-declaration? (car actions))) + (if (and (pair? actions) + (scode-block-declaration? (car actions))) (receiver name required optional rest auxiliary (scode-block-declaration-text (car actions)) (make-scode-sequence (cdr actions))) diff --git a/src/runtime/library-scode.scm b/src/runtime/library-scode.scm index f80cab872..af7ae84a8 100644 --- a/src/runtime/library-scode.scm +++ b/src/runtime/library-scode.scm @@ -124,7 +124,9 @@ USA. (let ((scode (strip-comments scode))) (or (scode-library? scode) (and (scode-sequence? scode) - (every scode-library? (scode-sequence-actions scode)))))) + (let ((actions (scode-sequence-actions scode))) + (and (pair? actions) + (every scode-library? actions))))))) (register-predicate! r7rs-scode-file? 'r7rs-scode-file) (define (r7rs-scode-file-libraries scode) diff --git a/src/runtime/scan.scm b/src/runtime/scan.scm index 27f2667b3..63be31543 100644 --- a/src/runtime/scan.scm +++ b/src/runtime/scan.scm @@ -28,7 +28,7 @@ USA. ;;; package: (runtime scode-scan) (declare (usual-integrations)) - + ;;; Scanning of internal definitions is necessary to reduce the number ;;; of "real auxiliary" variables in the system. These bindings are ;;; maintained in alists by the microcode, and cannot be compiled as @@ -41,17 +41,6 @@ USA. ;;; The Open Block abstraction can be used to store scanned definitions in code, ;;; which is extremely useful for code analysis and transformation. - -(define-integrable sequence-type - (ucode-type sequence)) - -(define null-sequence - '(null-sequence)) - -(define (cons-sequence action seq) - (if (eq? seq null-sequence) - action - (&typed-pair-cons sequence-type action seq))) ;;;; Scanning @@ -61,7 +50,7 @@ USA. ;;; EQUAL? list. (define (scan-defines expression receiver) - ((scan-loop expression receiver) '() '() null-sequence)) + ((scan-loop expression receiver) '() '() (make-scode-sequence '()))) (define (scan-loop expression receiver) (cond ((scode-open-block? expression) ;must come before SCODE-SEQUENCE? clause @@ -74,7 +63,7 @@ USA. body)))) ((scode-sequence? expression) ;; Build the sequence from the tail-end first so that the - ;; null-sequence shows up in the tail and is detected by + ;; empty sequence shows up in the tail and is detected by ;; cons-sequence. (let loop ((actions (scode-sequence-actions expression)) @@ -102,6 +91,9 @@ USA. (receiver names declarations (cons-sequence expression body)))))) + +(define (cons-sequence action sequence) + (make-scode-sequence (cons action (scode-sequence-actions sequence)))) (define (unscan-defines names declarations body) @@ -141,7 +133,7 @@ USA. (if (null? declarations) body* - (&typed-pair-cons sequence-type + (&typed-pair-cons (ucode-type sequence) (make-scode-block-declaration declarations) body*)))) @@ -162,7 +154,8 @@ USA. (define (scode-open-block? object) (and (scode-sequence? object) (let ((actions (scode-sequence-actions object))) - (and (open-block-descriptor? (car actions)) + (and (pair? actions) + (open-block-descriptor? (car actions)) (let ((names (%open-block-descriptor-names (car actions)))) (and (fix:> (length (cdr actions)) (length names)) (every %open-block-definition-named? diff --git a/src/runtime/scode.scm b/src/runtime/scode.scm index 037023ae1..63fc9d81f 100644 --- a/src/runtime/scode.scm +++ b/src/runtime/scode.scm @@ -242,28 +242,39 @@ USA. ;;;; Sequence (define (make-scode-sequence actions) - (guarantee non-empty-list? actions 'make-sequence) - (let loop ((actions actions)) - (if (pair? (cdr actions)) - (system-pair-cons (ucode-type sequence) - (unmap-reference-trap (car actions)) - (unmap-reference-trap (loop (cdr actions)))) - (car actions)))) + (guarantee list? actions 'make-sequence) + (let ((actions (append-map scode-sequence-actions actions))) + (if (pair? actions) + (let loop ((actions actions)) + (if (pair? (cdr actions)) + (system-pair-cons (ucode-type sequence) + (unmap-reference-trap (car actions)) + (unmap-reference-trap (loop (cdr actions)))) + (car actions))) + (empty-sequence)))) (define (scode-sequence? object) (object-type? (ucode-type sequence) object)) (register-predicate! scode-sequence? 'scode-sequence) (define (scode-sequence-actions expression) - (if (scode-sequence? expression) - (append-map scode-sequence-actions - (list (map-reference-trap - (lambda () - (system-pair-car expression))) - (map-reference-trap - (lambda () - (system-pair-cdr expression))))) - (list expression))) + (cond ((not (scode-sequence? expression)) (list expression)) + ((sequence-empty? expression) '()) + (else + (append-map scode-sequence-actions + (list (map-reference-trap + (lambda () + (system-pair-car expression))) + (map-reference-trap + (lambda () + (system-pair-cdr expression)))))))) + +(define (empty-sequence) + (system-pair-cons (ucode-type sequence) #!unspecific #!unspecific)) + +(define (sequence-empty? sequence) + (and (eq? #!unspecific (system-pair-car sequence)) + (eq? #!unspecific (system-pair-cdr sequence)))) ;;;; Combination diff --git a/src/runtime/unsyn.scm b/src/runtime/unsyn.scm index 1269001a6..66e511f01 100644 --- a/src/runtime/unsyn.scm +++ b/src/runtime/unsyn.scm @@ -232,7 +232,8 @@ USA. (define (unsyntax-sequence-object environment seq) (let ((actions (scode-sequence-actions seq))) - (if (and (scode-block-declaration? (car actions)) + (if (and (pair? actions) + (scode-block-declaration? (car actions)) (pair? (cdr actions))) `(begin (declare ,@(scode-block-declaration-text (car actions))) @@ -421,7 +422,8 @@ USA. (define (unsyntax-lambda-body-sequence environment body) (if (scode-sequence? body) (let ((actions (scode-sequence-actions body))) - (if (and (scode-block-declaration? (car actions)) + (if (and (pair? actions) + (scode-block-declaration? (car actions)) (pair? (cdr actions))) `((declare ,@(scode-block-declaration-text (car actions))) ,@(unsyntax-sequence-for-splicing diff --git a/src/runtime/ystep.scm b/src/runtime/ystep.scm index 3c717f781..5ffe6e084 100644 --- a/src/runtime/ystep.scm +++ b/src/runtime/ystep.scm @@ -284,7 +284,9 @@ USA. (or (eq? f1 (scode-conditional-consequent f2)) (eq? f1 (scode-conditional-alternative f2)))) ((scode-sequence? f2) - (eq? f1 (car (last-pair (scode-sequence-actions f2))))) + (let ((actions (scode-sequence-actions f2))) + (and (pair? actions) + (eq? f1 (car (last-pair actions)))))) (else #f))) ;;;; Stepper nodes diff --git a/src/sf/object.scm b/src/sf/object.scm index ada608a27..32d133ee6 100644 --- a/src/sf/object.scm +++ b/src/sf/object.scm @@ -593,9 +593,12 @@ USA. (cons action filtered))) '() (sequence/collect-actions '() actions)))) - (if (null? (cdr filtered-actions)) - (car filtered-actions) - (sequence/%make scode filtered-actions)))) + (cond ((not (pair? filtered-actions)) + (constant/make unspecific unspecific)) + ((not (pair? (cdr filtered-actions))) + (car filtered-actions)) + (else + (sequence/%make scode filtered-actions))))) ;; Done specially so we can tweak the print method. ;; This makes debugging an awful lot easier. diff --git a/src/sf/xform.scm b/src/sf/xform.scm index e3c88c70d..78fa6d361 100644 --- a/src/sf/xform.scm +++ b/src/sf/xform.scm @@ -324,10 +324,15 @@ USA. (define (transform/sequence block environment expression) ;; Don't remove references from sequences here. We want them ;; to signal ignored variables. - (sequence/%make - expression - (transform/expressions block environment - (scode-sequence-actions expression)))) + (let ((actions + (transform/expressions block environment + (scode-sequence-actions expression)))) + (cond ((not (pair? actions)) + (transform/constant block environment unspecific)) + ((not (pair? (cdr actions))) + (car actions)) + (else + (sequence/%make expression actions))))) (define (transform/the-environment block environment expression) environment ; ignored