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

Check that first argument of map is a procedure in cp02 expansion

Browse Source 
to raise the same error that the non expanded version
  cp0.ss

original commit: cf10634c29c5f873e1e77b1868dd58071650dba3
This commit is contained in:
Gustavo Massaccesi 2017-12-19 17:48:15 -03:00
parent f1b9fc95da
commit d593fe4a78
2 changed files with 32 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
LOG
View File

@ -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

45
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 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?))]