From d593fe4a781f59345d9d298f468c00aa6b811599 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Tue, 19 Dec 2017 17:48:15 -0300 Subject: [PATCH 1/2] Check that first argument of map is a procedure in cp02 expansion to raise the same error that the non expanded version cp0.ss original commit: cf10634c29c5f873e1e77b1868dd58071650dba3 --- LOG | 3 +++ s/cp0.ss | 45 +++++++++++++++++++++++++++++---------------- 2 files changed, 32 insertions(+), 16 deletions(-) diff --git a/LOG b/LOG index fc9f64c523..3de72b986f 100644 --- a/LOG +++ b/LOG @@ -763,4 +763,7 @@ to use define-who instead of repeating 'substring-fill! in all the error messages. 5_4.ss, 5_6.ss +- Check that first argument of map is a procedure in cp02 expansion + to raise the same error that the non expanded version + cp0.ss diff --git a/s/cp0.ss b/s/cp0.ss index df254dacfa..16f2c295bb 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -3588,6 +3588,9 @@ (lambda (?p ?ls ?ls* lvl map? ctxt sc wd name moi) ; (map/for-each proc (list a11 a12 ... a1m) (list a21 a22 ... a2m) ... (list an1 an2 ... anm)) => ; (let ([p proc]) + ; (if (procedure? p) + ; (void) + ; ($oops 'map/for-each "~s is not a procedure" p)) ; (let ([t11 a11] ... [t1m a1m]) ; ... ; (let ([tn1 an1] ... [tnm anm]) @@ -3605,22 +3608,32 @@ e**)]) (residualize-seq (list* ?p ?ls ?ls*) '() ctxt) (build-let (list p) (list (value-visit-operand! ?p)) - (let f ([t** temp**] [e** (reverse e**)] [ls* (cons ?ls ?ls*)]) - (if (null? t**) - (let ([results - (let ([preinfo (app-preinfo ctxt)]) - (let g ([t** temp**]) - (if (null? (car t**)) - '() - (cons `(call ,preinfo (ref #f ,p) - ,(map (lambda (t*) (build-ref (car t*))) t**) ...) - (g (map cdr t**))))))]) - (if map? - (build-primcall lvl 'list results) - (make-seq* ctxt results))) - (non-result-exp (value-visit-operand! (car ls*)) - (build-let (car t**) (car e**) - (f (cdr t**) (cdr e**) (cdr ls*))))))))) + (let ([main + (let f ([t** temp**] [e** (reverse e**)] [ls* (cons ?ls ?ls*)]) + (if (null? t**) + (let ([results + (let ([preinfo (app-preinfo ctxt)]) + (let g ([t** temp**]) + (if (null? (car t**)) + '() + (cons `(call ,preinfo (ref #f ,p) + ,(map (lambda (t*) (build-ref (car t*))) t**) ...) + (g (map cdr t**))))))]) + (if map? + (build-primcall lvl 'list results) + (make-seq* ctxt results))) + (non-result-exp (value-visit-operand! (car ls*)) + (build-let (car t**) (car e**) + (f (cdr t**) (cdr e**) (cdr ls*))))))]) + (if (fx= lvl 2) + (make-seq ctxt + `(if ,(build-primcall 2 'procedure? (list `(ref #f ,p))) + ,void-rec + ,(build-primcall 3 '$oops (list `(quote ,(if map? 'map 'for-each)) + `(quote "~s is not a procedure") + `(ref #f ,p)))) + main) + main))))) (nanopass-case (Lsrc Expr) (result-exp (value-visit-operand! (car ls*))) [(quote ,d) (and (list? d) (loop (cdr ls*) (cons (map (lambda (x) `(quote ,x)) d) e**) all-quoted?))] From eb9d65d88c21e0d8ceedeb554906ed16d1b04861 Mon Sep 17 00:00:00 2001 From: Gustavo Massaccesi Date: Wed, 20 Dec 2017 11:26:57 -0300 Subject: [PATCH 2/2] avoid building the result list in a map that is called for effect cp0.ss # Conflicts: # s/cp0.ss original commit: 12353c17917f0979e72740592891ce928b40963f --- LOG | 2 ++ s/cp0.ss | 23 +++++++++++++---------- 2 files changed, 15 insertions(+), 10 deletions(-) diff --git a/LOG b/LOG index 3de72b986f..eeff52e0d7 100644 --- a/LOG +++ b/LOG @@ -766,4 +766,6 @@ - Check that first argument of map is a procedure in cp02 expansion to raise the same error that the non expanded version cp0.ss +- avoid building the result list in a map that is called for effect + cp0.ss diff --git a/s/cp0.ss b/s/cp0.ss index 16f2c295bb..3ceea44923 100644 --- a/s/cp0.ss +++ b/s/cp0.ss @@ -3619,7 +3619,7 @@ (cons `(call ,preinfo (ref #f ,p) ,(map (lambda (t*) (build-ref (car t*))) t**) ...) (g (map cdr t**))))))]) - (if map? + (if (and map? (not (eq? ctxt 'effect))) (build-primcall lvl 'list results) (make-seq* ctxt results))) (non-result-exp (value-visit-operand! (car ls*)) @@ -3696,15 +3696,18 @@ (build-lambda (cons p ls*) (let f ([n n] [ls* ls*] [ropnd* '()]) (if (fx= n 1) - (build-primcall 3 'list - (reverse - (cons - `(call ,(app-preinfo ctxt) (ref #f ,p) - ,(map (lambda (x) - (build-primcall 3 'car - (list (build-ref x)))) - ls*) ...) - ropnd*))) + (let ([opnd* + (reverse + (cons + `(call ,(app-preinfo ctxt) (ref #f ,p) + ,(map (lambda (x) + (build-primcall 3 'car + (list (build-ref x)))) + ls*) ...) + ropnd*))]) + (if (eq? ctxt 'effect) + (make-seq* ctxt opnd*) + (build-primcall 3 'list opnd*))) (let ([tls* (map (lambda (x) (cp0-make-temp #t)) ls*)]) (build-let tls* (map (lambda (x)