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
parent
1d25a3db07
commit
7b60ec46a9
|
|
@ -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)])
|
||||
(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*))]))]
|
||||
[else '()]))
|
||||
[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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -57,12 +57,14 @@
|
|||
(define build-lambda
|
||||
(lambda (ae vars exp)
|
||||
(if-wants-case-lambda
|
||||
`(case-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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
(syntax-match x ()
|
||||
[(_ (_ . fmls) . body*)
|
||||
(let-values (((fmls body)
|
||||
(chi-lambda-clause fmls fmls body* r mr)))
|
||||
(build-lambda no-source fmls body))))
|
||||
(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
|
||||
|
|
|
|||
Loading…
Reference in New Issue