conservatory
/
ikarus
4
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

* arguments to expanded let now get proper procedure names so that 

(let ((f (lambda (x) x))) f) prints as #<procedure f>.
This commit is contained in:
Abdulaziz Ghuloum 2007-10-10 05:06:31 -04:00
parent ca27d8e626
commit 82eb606715
3 changed files with 28 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

BIN
src/ikarus.boot
View File

Binary file not shown.

30
src/ikarus.compiler.ss
View File

@ -156,6 +156,21 @@
(error 'recordize "unbound ~s" x)))
(define (lexical x)
(getprop x *cookie*))
(define (get-fmls x args)
(define (matching? fmls args)
(cond
[(null? fmls) (null? args)]
[(pair? fmls) (and (pair? args) (matching? (cdr fmls) (cdr args)))]
[else #t]))
(cond
[(and (pair? x) (eq? (car x) 'case-lambda))
(let f ([cls* (cdr x)])
(cond
[(null? cls*) '()]
[(matching? (caar cls*) args)
(caar cls*)]
[else (f (cdr cls*))]))]
[else '()]))
(define (E x ctxt)
(cond
[(pair? x)
@ -221,10 +236,17 @@
(let ([var (cadr x)])
(make-primref var))]
[else
;;; should annotate expanded let.
(make-funcall
(E (car x) #f)
(map (lambda (x) (E x #f)) (cdr x)))])]
(let ([names (get-fmls (car x) (cdr x))])
(make-funcall
(E (car x) #f)
(let f ([arg* (cdr x)] [names names])
(cond
[(pair? names)
(cons
(E (car arg*) (car names))
(f (cdr arg*) (cdr names)))]
[else
(map (lambda (x) (E x #f)) arg*)]))))])]
[(symbol? x)
(or (lexical x)
(make-funcall

4
src/makefile.ss
View File

@ -935,8 +935,8 @@
[find i r ls]
[fold-left r ls]
[fold-right r ls]
[for-all r ls]
[exists r ls]
[for-all i r ls]
[exists i r ls]
[member i r ls se]
[memp i r ls]
[memq i r ls se]