From acf83c430b9f45ae96b60032ed31cd808dc08939 Mon Sep 17 00:00:00 2001 From: Joe Marshall Date: Thu, 9 Jun 2011 14:31:40 -0700 Subject: [PATCH] Remove limits on expansion of cons* and list. Improve apply expansion. --- src/sf/usiexp.scm | 49 ++++++++++------------------------------------- 1 file changed, 10 insertions(+), 39 deletions(-) diff --git a/src/sf/usiexp.scm b/src/sf/usiexp.scm index a6be682ac..190b3f369 100644 --- a/src/sf/usiexp.scm +++ b/src/sf/usiexp.scm @@ -302,16 +302,11 @@ USA. ;;;; N-ary List Operations -(define sf:enable-flatten-apply? #t) - (define (apply*-expansion expr operands block) - (cond ((< (length operands) 2) #f) - ((length=? operands 2) - (if (and (manifest-argument-list? (second operands)) - (noisy-test sf:enable-flatten-apply? "flatten-apply")) - (combination/make expr block (first operands) (flatten-operands (second operands))) - (make-combination expr block (ucode-primitive apply) operands))) - ((< (length operands) 10) + (cond ((length=? operands 2) + (make-combination expr block (ucode-primitive apply) operands)) + ((not (pair? operands)) #f) + ((pair? (cdr operands)) (apply*-expansion expr (list (car operands) @@ -319,30 +314,8 @@ USA. block)) (else #f))) -;;; If an argument constructs a null-terminated list, we flatten -;;; the call to apply. -(define (manifest-argument-list? expr) - (or (constant-eq? expr '()) - (and (combination? expr) - (let ((operator (combination/operator expr)) - (operands (combination/operands expr))) - (and (or (constant-eq? operator (ucode-primitive cons)) - (eq? (global-ref? operator) 'cons)) - (pair? operands) - (pair? (cdr operands)) - (null? (cddr operands)) - (manifest-argument-list? (second operands))))))) - -(define (flatten-operands operands) - (unfold (lambda (operands) (constant-eq? operands '())) - (lambda (operands) (first (combination/operands operands))) - (lambda (operands) (second (combination/operands operands))) - operands)) - (define (cons*-expansion expr operands block) - (if (< -1 (length operands) 9) - (cons*-expansion-loop expr block operands) - #f)) + (cons*-expansion-loop expr block operands)) (define (cons*-expansion-loop expr block rest) (if (null? (cdr rest)) @@ -354,16 +327,14 @@ USA. (cons*-expansion-loop #f block (cdr rest)))))) (define (list-expansion expr operands block) - (if (< (length operands) 9) - (list-expansion-loop expr block operands) - #f)) + (list-expansion-loop expr block operands)) (define (list-expansion-loop expr block rest) - (if (null? rest) - (constant/make (and expr (object/scode expr)) '()) - (make-combination expr block (ucode-primitive cons) + (cond ((pair? rest) (make-combination expr block (ucode-primitive cons) (list (car rest) - (list-expansion-loop #f block (cdr rest)))))) + (list-expansion-loop #f block (cdr rest))))) + ((null? rest) (constant/make (and expr (object/scode expr)) '())) + (else (error "Improper list.")))) (define (values-expansion expr operands block) (let ((block (block/make block #t '()))) -- 2.25.1