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

Non-system procedures now print with source-position. E.g., 

you now get #<procedure foo [nnn of file.ss]> or
#<procedure [nnn of file.ss]>  instead of plain #<procedure foo>
or #<procedure>.
This commit is contained in:
Abdulaziz Ghuloum 2009-03-30 12:28:30 +03:00
parent 1d25a3db07
commit 7b60ec46a9
4 changed files with 74 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
scheme/ikarus.compiler.ss
View File

@ -256,15 +256,19 @@
[(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 (get-cls* x)
(if (pair? x)
(case (car x)
[(case-lambda) (cdr x)]
[(annotated-case-lambda) (cddr x)]
[else '()])
'()))
(let f ([cls* (get-cls* x)])
(cond
[(null? cls*) '()]
[(matching? (caar cls*) args)
(caar cls*)]
[else (f (cdr cls*))])))
(define (make-global-set! lhs rhs)
(make-funcall (make-primref '$init-symbol-value!)
(list (make-constant lhs) rhs)))
@ -283,6 +287,22 @@
(begin e e* ...)
rest))]))])
#'(let ([t val]) body))])))
(define (E-clambda-clause* cls* ctxt)
(map
(let ([ctxt (if (pair? ctxt) (car ctxt) #f)])
(lambda (cls)
(let ([fml* (car cls)] [body (cadr cls)])
(let ([nfml* (gen-fml* fml*)])
(let ([body (E body ctxt)])
(ungen-fml* fml*)
(make-clambda-case
(make-case-info
(gensym)
(properize nfml*)
(list? fml*))
body))))))
cls*))
(define (E x ctxt)
(cond
[(pair? x)
@ -342,23 +362,18 @@
(ungen-fml* lhs*)
expr))))]
[(case-lambda)
(let ([cls*
(map
(let ([ctxt (if (pair? ctxt) (car ctxt) #f)])
(lambda (cls)
(let ([fml* (car cls)] [body (cadr cls)])
(let ([nfml* (gen-fml* fml*)])
(let ([body (E body ctxt)])
(ungen-fml* fml*)
(make-clambda-case
(make-case-info
(gensym)
(properize nfml*)
(list? fml*))
body))))))
(cdr x))])
(let ([cls* (E-clambda-clause* (cdr x) ctxt)])
(make-clambda (gensym) cls* #f #f
(and (symbol? ctxt) ctxt)))]
[(annotated-case-lambda)
(let ([ae (cadr x)])
(let ([cls* (E-clambda-clause* (cddr x) ctxt)])
(make-clambda (gensym) cls* #f #f
(cons
(and (symbol? ctxt) ctxt)
(if (annotation? ae)
(annotation-source ae)
#f)))))]
[(lambda)
(E `(case-lambda ,(cdr x)) ctxt)]
[(foreign-call)

27
scheme/ikarus.writer.ss
View File

@ -556,14 +556,25 @@
(write-char (string-ref x i) p)
(f x p (fx+ i 1) n))))
(define (write-procedure x p)
(cond
[(let ([name (procedure-annotation x)])
(and (symbol? name) name)) =>
(lambda (name)
(write-char* "#<procedure " p)
(write-string (symbol->string name) p #f)
(write-char* ">" p))]
[else (write-char* "#<procedure>" p)]))
(write-char* "#<procedure" p)
(let-values ([(name src)
(let ([ae (procedure-annotation x)])
(if (pair? ae)
(values (car ae) (cdr ae))
(if (symbol? ae)
(values ae #f)
(values #f #f))))])
(when (symbol? name)
(write-char* " " p)
(display name p))
(when (pair? src)
(let ([file (car src)] [char (cdr src)])
(write-char* " [char " p)
(display char p)
(write-char* " of " p)
(display file p)
(write-char* "]" p))))
(write-char* ">" p))
(define (write-port x p)
(write-char* "#<" p)
(write-char* (if (output-port? x) "output" "input") p)

8
scheme/psyntax.builders.ss
View File

@ -57,12 +57,14 @@
(define build-lambda
(lambda (ae vars exp)
(if-wants-case-lambda
`(case-lambda (,vars ,exp))
`(lambda ,vars ,exp))))
(build-case-lambda ae (list vars) (list exp))
`(lambda ,vars ,exp))))
(define build-case-lambda
(if-wants-case-lambda
(lambda (ae vars* exp*)
`(case-lambda . ,(map list vars* exp*)))
(if ae
`(annotated-case-lambda ,ae . ,(map list vars* exp*))
`(case-lambda . ,(map list vars* exp*))))
(lambda (ae vars* exp*)
(define (build-error ae)
(build-application ae

18
scheme/psyntax.expander.ss
View File

@ -873,7 +873,7 @@
((_ (id . fmls) b b* ...) (id? id)
(begin
(verify-formals fmls x)
(values id (cons 'defun (cons fmls (cons b b*))))))
(values id (cons 'defun x))))
((_ id val) (id? id)
(values id (cons 'expr val)))
((_ id) (id? id)
@ -1061,7 +1061,7 @@
(let-values (((fmls* body*)
(chi-lambda-clause* e fmls*
(map cons b* b**) r mr)))
(build-case-lambda no-source fmls* body*))))))
(build-case-lambda (syntax-annotation e) fmls* body*))))))
(define lambda-transformer
(lambda (e r mr)
@ -1070,7 +1070,7 @@
(let-values (((fmls body)
(chi-lambda-clause e fmls
(cons b b*) r mr)))
(build-lambda no-source fmls body))))))
(build-lambda (syntax-annotation e) fmls body))))))
(define bless
(lambda (x)
@ -2874,10 +2874,11 @@
(values (cons a a*) (cons b b*))))))))
(define (chi-defun x r mr)
(let ((fmls (car x)) (body* (cdr x)))
(let-values (((fmls body)
(chi-lambda-clause fmls fmls body* r mr)))
(build-lambda no-source fmls body))))
(syntax-match x ()
[(_ (_ . fmls) . body*)
(let-values (((fmls body)
(chi-lambda-clause fmls fmls body* r mr)))
(build-lambda (syntax-annotation x) fmls body))]))
(define chi-rhs
(lambda (rhs r mr)
@ -3918,6 +3919,9 @@
(and (annotation? x)
(annotation-source x)))))
(define (syntax-annotation x)
(if (stx? x) (stx-expr x) x))
(define (assertion-error expr pos)
(raise
(condition