suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Merge branch '17-12-Map-Error' of https://github.com/gus-massa/ChezScheme into gus-massa-17-12-Map-Error

Browse Source 
original commit: 154ed6a4113b3f440e9d5a8348270d2ca1ace807
This commit is contained in:
Andy Keep 2018-01-13 12:28:11 -05:00
commit 1a35e17a60
2 changed files with 46 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

5
LOG
View File

@ -774,3 +774,8 @@
5_3.ss, 5_3.ms, fl.ms, root-experr*, patch*
- fix bug in date->time-utc caused by incorrect use of difftime in Windows
stats.c, date.ms, release_notes.stex
- 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

66
s/cp0.ss
View File

@ -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 (and map? (not (eq? ctxt 'effect)))
(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?))]
@ -3683,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)