From 7b60ec46a9b2039de4e2ae8718e601c5dc68d248 Mon Sep 17 00:00:00 2001 From: Abdulaziz Ghuloum Date: Mon, 30 Mar 2009 12:28:30 +0300 Subject: [PATCH] Non-system procedures now print with source-position. E.g., you now get # or # instead of plain # or #. --- scheme/ikarus.compiler.ss | 63 +++++++++++++++++++++++--------------- scheme/ikarus.writer.ss | 27 +++++++++++----- scheme/psyntax.builders.ss | 8 +++-- scheme/psyntax.expander.ss | 18 ++++++----- 4 files changed, 74 insertions(+), 42 deletions(-) diff --git a/scheme/ikarus.compiler.ss b/scheme/ikarus.compiler.ss index 57bad20..b6913ca 100644 --- a/scheme/ikarus.compiler.ss +++ b/scheme/ikarus.compiler.ss @@ -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) diff --git a/scheme/ikarus.writer.ss b/scheme/ikarus.writer.ss index 331c002..0aed44a 100644 --- a/scheme/ikarus.writer.ss +++ b/scheme/ikarus.writer.ss @@ -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* "#string name) p #f) - (write-char* ">" p))] - [else (write-char* "#" p)])) + (write-char* "#" p)) (define (write-port x p) (write-char* "#<" p) (write-char* (if (output-port? x) "output" "input") p) diff --git a/scheme/psyntax.builders.ss b/scheme/psyntax.builders.ss index 7559a86..ae72390 100644 --- a/scheme/psyntax.builders.ss +++ b/scheme/psyntax.builders.ss @@ -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 diff --git a/scheme/psyntax.expander.ss b/scheme/psyntax.expander.ss index 2d10627..251dd5b 100644 --- a/scheme/psyntax.expander.ss +++ b/scheme/psyntax.expander.ss @@ -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