;;;; 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))
(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)))
(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)
;;; package: (runtime scode-scan)
(declare (usual-integrations))
-\f
+
;;; 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
;;; 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)))
\f
;;;; Scanning
;;; 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
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))
(receiver names
declarations
(cons-sequence expression body))))))
+
+(define (cons-sequence action sequence)
+ (make-scode-sequence (cons action (scode-sequence-actions sequence))))
\f
(define (unscan-defines names declarations body)
(if (null? declarations)
body*
- (&typed-pair-cons sequence-type
+ (&typed-pair-cons (ucode-type sequence)
(make-scode-block-declaration declarations)
body*))))
\f
(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?
;;;; 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
(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)))
(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
(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)))
\f
;;;; Stepper nodes
(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.
(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
projects / mit-scheme.git / commitdiff