syntax-errors now give source information in their error message.

This commit is contained in:
Abdulaziz Ghuloum 2007-12-19 19:05:23 -05:00
parent a725292a4d
commit 917754e28e
6 changed files with 156 additions and 82 deletions

View File

@ -48,12 +48,12 @@
(lambda (x) (lambda (x)
(define (read-file) (define (read-file)
(let ([p (open-input-file x)]) (let ([p (open-input-file x)])
(let ([x (read-initial p)]) (let ([x (read-script-annotated p)])
(if (eof-object? x) (if (eof-object? x)
(begin (close-input-port p) '()) (begin (close-input-port p) '())
(cons x (cons x
(let f () (let f ()
(let ([x (read p)]) (let ([x (read-annotated p)])
(cond (cond
[(eof-object? x) [(eof-object? x)
(close-input-port p) (close-input-port p)

View File

@ -1315,6 +1315,12 @@
(define (read-as-comment p) (define (read-as-comment p)
(begin (read-expr p '() void) (void))) (begin (read-expr p '() void) (void)))
(define (return-annotated x)
(cond
[(and (annotation? x) (eof-object? (annotation-expression x)))
(eof-object)]
[else x]))
(define my-read (define my-read
(lambda (p) (lambda (p)
(let-values ([(expr expr^ locs k) (read-expr p '() void)]) (let-values ([(expr expr^ locs k) (read-expr p '() void)])
@ -1340,28 +1346,32 @@
expr)])))) expr)]))))
(define read-annotated (define read-annotated
(lambda (p) (case-lambda
(let-values ([(expr expr^ locs k) (read-expr p '() void)]) [(p)
(cond (unless (input-port? p)
[(null? locs) expr^] (error 'read-annotated "not an input port" p))
[else (let-values ([(expr expr^ locs k) (read-expr p '() void)])
(for-each reduce-loc! locs) (cond
(k) [(null? locs) (return-annotated expr^)]
(if (loc? expr) [else
(loc-value^ expr) (for-each reduce-loc! locs)
expr^)])))) (k)
(if (loc? expr)
(loc-value^ expr)
(return-annotated expr^))]))]
[() (read-annotated (current-input-port))]))
(define read-script-annotated (define read-script-annotated
(lambda (p) (lambda (p)
(let-values ([(expr expr^ locs k) (read-expr-script-initial p '() void)]) (let-values ([(expr expr^ locs k) (read-expr-script-initial p '() void)])
(cond (cond
[(null? locs) expr^] [(null? locs) (return-annotated expr^)]
[else [else
(for-each reduce-loc! locs) (for-each reduce-loc! locs)
(k) (k)
(if (loc? expr) (if (loc? expr)
(loc-value^ expr) (loc-value^ expr)
expr^)])))) (return-annotated expr^))]))))
(define read-token (define read-token
(case-lambda (case-lambda

View File

@ -1 +1 @@
1267 1268

View File

@ -17,7 +17,9 @@
(library (psyntax compat) (library (psyntax compat)
(export define-record make-parameter parameterize format gensym (export define-record make-parameter parameterize format gensym
eval-core symbol-value set-symbol-value! eval-core symbol-value set-symbol-value!
file-options-spec make-struct-type) file-options-spec make-struct-type read-annotated
annotation? annotation-expression annotation-source
annotation-stripped)
(import (import
(only (ikarus compiler) eval-core) (only (ikarus compiler) eval-core)
(ikarus)) (ikarus))

View File

@ -200,7 +200,16 @@
;;; Now to syntax objects which are records defined like: ;;; Now to syntax objects which are records defined like:
(define-record stx (expr mark* subst*) (define-record stx (expr mark* subst*)
(lambda (x p) (lambda (x p)
(display "#<syntax " p) (display "#<syntax" p)
(let ([expr (stx-expr x)])
(when (annotation? expr)
(let ([src (annotation-source expr)])
(when (pair? src)
(display "@char " p)
(display (cdr src) p)
(display " of file " p)
(display (car src) p)))))
(display " " p)
(write (stx->datum x) p) (write (stx->datum x) p)
(display ">" p))) (display ">" p)))
@ -336,9 +345,12 @@
;;; now are some deconstructors and predicates for syntax objects. ;;; now are some deconstructors and predicates for syntax objects.
(define syntax-kind? (define syntax-kind?
(lambda (x p?) (lambda (x p?)
(if (stx? x) (cond
(syntax-kind? (stx-expr x) p?) [(stx? x) (syntax-kind? (stx-expr x) p?)]
(p? x)))) [(annotation? x)
(syntax-kind? (annotation-expression x) p?)]
[else (p? x)])))
(define syntax-vector->list (define syntax-vector->list
(lambda (x) (lambda (x)
(cond (cond
@ -346,6 +358,8 @@
(let ((ls (syntax-vector->list (stx-expr x))) (let ((ls (syntax-vector->list (stx-expr x)))
(m* (stx-mark* x)) (s* (stx-subst* x))) (m* (stx-mark* x)) (s* (stx-subst* x)))
(map (lambda (x) (mkstx x m* s*)) ls))) (map (lambda (x) (mkstx x m* s*)) ls)))
[(annotation? x)
(syntax-vector->list (annotation-expression x))]
((vector? x) (vector->list x)) ((vector? x) (vector->list x))
(else (assertion-violation 'syntax-vector->list "not a syntax vector" x))))) (else (assertion-violation 'syntax-vector->list "not a syntax vector" x)))))
(define syntax-pair? (define syntax-pair?
@ -360,11 +374,22 @@
(and (syntax-pair? x) (syntax-list? (syntax-cdr x)))))) (and (syntax-pair? x) (syntax-list? (syntax-cdr x))))))
(define syntax-car (define syntax-car
(lambda (x) (lambda (x)
(if (stx? x) (cond
(mkstx (syntax-car (stx-expr x)) (stx-mark* x) (stx-subst* x)) [(stx? x)
(if (pair? x) (mkstx (syntax-car (stx-expr x)) (stx-mark* x) (stx-subst* x))]
(car x) [(annotation? x)
(assertion-violation 'syntax-car "not a pair" x))))) (syntax-car (annotation-expression x))]
[(pair? x) (car x)]
[else (assertion-violation 'syntax-car "not a pair" x)])))
(define syntax-cdr
(lambda (x)
(cond
[(stx? x)
(mkstx (syntax-cdr (stx-expr x)) (stx-mark* x) (stx-subst* x))]
[(annotation? x)
(syntax-cdr (annotation-expression x))]
[(pair? x) (cdr x)]
[else (assertion-violation 'syntax-cdr "not a pair" x)])))
(define syntax->list (define syntax->list
(lambda (x) (lambda (x)
(if (syntax-pair? x) (if (syntax-pair? x)
@ -372,23 +397,16 @@
(if (syntax-null? x) (if (syntax-null? x)
'() '()
(assertion-violation 'syntax->list "invalid argument" x))))) (assertion-violation 'syntax->list "invalid argument" x)))))
(define syntax-cdr
(lambda (x)
(if (stx? x)
(mkstx (syntax-cdr (stx-expr x)) (stx-mark* x) (stx-subst* x))
(if (pair? x)
(cdr x)
(assertion-violation 'syntax-cdr "not a pair" x)))))
(define id? (define id?
(lambda (x) (syntax-kind? x symbol?))) (lambda (x) (syntax-kind? x symbol?)))
(define id->sym (define id->sym
(lambda (x) (lambda (x)
(if (stx? x) (cond
(id->sym (stx-expr x)) [(stx? x) (id->sym (stx-expr x))]
(if (symbol? x) [(annotation? x) (annotation-expression x)]
x [(symbol? x) x]
(assertion-violation 'id->sym "not an id" x))))) [else (assertion-violation 'id->sym "not an id" x)])))
;;; Two lists of marks are considered the same if they have the ;;; Two lists of marks are considered the same if they have the
;;; same length and the corresponding marks on each are eq?. ;;; same length and the corresponding marks on each are eq?.
@ -445,10 +463,13 @@
(define strip (define strip
(lambda (x m*) (lambda (x m*)
(if (top-marked? m*) (if (top-marked? m*)
x (if (annotation? x)
(annotation-stripped x)
x)
(let f ((x x)) (let f ((x x))
(cond (cond
((stx? x) (strip (stx-expr x) (stx-mark* x))) ((stx? x) (strip (stx-expr x) (stx-mark* x)))
[(annotation? x) (annotation-stripped x)]
((pair? x) ((pair? x)
(let ((a (f (car x))) (d (f (cdr x)))) (let ((a (f (car x))) (d (f (cdr x))))
(if (and (eq? a (car x)) (eq? d (cdr x))) (if (and (eq? a (car x)) (eq? d (cdr x)))
@ -1963,6 +1984,8 @@
((stx? e) ((stx? e)
(let-values (((m* s*) (join-wraps m* s* e))) (let-values (((m* s*) (join-wraps m* s* e)))
(match-each (stx-expr e) p m* s*))) (match-each (stx-expr e) p m* s*)))
[(annotation? e)
(match-each (annotation-expression e) p m* s*)]
(else #f)))) (else #f))))
(define match-each+ (define match-each+
(lambda (e x-pat y-pat z-pat m* s* r) (lambda (e x-pat y-pat z-pat m* s* r)
@ -1984,6 +2007,8 @@
((stx? e) ((stx? e)
(let-values (((m* s*) (join-wraps m* s* e))) (let-values (((m* s*) (join-wraps m* s* e)))
(f (stx-expr e) m* s*))) (f (stx-expr e) m* s*)))
[(annotation? e)
(f (annotation-expression e) m* s*)]
(else (values '() y-pat (match e z-pat m* s* r))))))) (else (values '() y-pat (match e z-pat m* s* r)))))))
(define match-each-any (define match-each-any
(lambda (e m* s*) (lambda (e m* s*)
@ -1995,6 +2020,8 @@
((stx? e) ((stx? e)
(let-values (((m* s*) (join-wraps m* s* e))) (let-values (((m* s*) (join-wraps m* s* e)))
(match-each-any (stx-expr e) m* s*))) (match-each-any (stx-expr e) m* s*)))
[(annotation? e)
(match-each-any (annotation-expression e) m* s*)]
(else #f)))) (else #f))))
(define match-empty (define match-empty
(lambda (p r) (lambda (p r)
@ -2065,6 +2092,8 @@
((stx? e) ((stx? e)
(let-values (((m* s*) (join-wraps m* s* e))) (let-values (((m* s*) (join-wraps m* s* e)))
(match (stx-expr e) p m* s* r))) (match (stx-expr e) p m* s* r)))
[(annotation? e)
(match (annotation-expression e) p m* s* r)]
(else (match* e p m* s* r))))) (else (match* e p m* s* r)))))
(match e p '() '() '()))) (match e p '() '() '())))
@ -2168,13 +2197,14 @@
(syntax-match e () (syntax-match e ()
((_ expr (keys ...) clauses ...) ((_ expr (keys ...) clauses ...)
(begin (begin
(unless (for-all (lambda (x) (and (id? x) (not (ellipsis? x)))) keys) (unless (for-all (lambda (x) (and (id? x) (not (ellipsis? x)))) keys)
(stx-error e "invalid literals")) (stx-error e "invalid literals"))
(let ((x (gen-lexical 'tmp))) (let ((x (gen-lexical 'tmp)))
(let ((body (gen-syntax-case x keys clauses r mr))) (let ((body (gen-syntax-case x keys clauses r mr)))
(build-application no-source (build-application no-source
(build-lambda no-source (list x) body) (build-lambda no-source (list x) body)
(list (chi-expr expr r mr))))))))))) (list (chi-expr expr r mr)))))))))))
(define syntax-transformer (define syntax-transformer
(let () (let ()
(define gen-syntax (define gen-syntax
@ -2942,18 +2972,20 @@
(let ((id* (map (lambda (x) (mkstx x top-mark* '())) ext*))) (let ((id* (map (lambda (x) (mkstx x top-mark* '())) ext*)))
(unless (valid-bound-ids? id*) (unless (valid-bound-ids? id*)
(assertion-violation 'expander "invalid exports" (find-dups id*)))) (assertion-violation 'expander "invalid exports" (find-dups id*))))
(values int* ext*)) (values (map syntax->datum int*) (map syntax->datum ext*)))
(else (else
(syntax-match (car exp*) () (syntax-match (car exp*) ()
((rename (i* e*) ...) ((rename (i* e*) ...)
(begin (begin
(unless (and (eq? rename 'rename) (for-all symbol? i*) (unless (and (eq? (syntax->datum rename) 'rename)
(for-all symbol? e*)) (for-all id? i*)
(for-all id? e*))
(assertion-violation 'expander "invalid export specifier" (car exp*))) (assertion-violation 'expander "invalid export specifier" (car exp*)))
(f (cdr exp*) (append i* int*) (append e* ext*)))) (f (cdr exp*) (append i* int*) (append e* ext*))))
(ie (ie
(begin (begin
(unless (symbol? ie) (assertion-violation 'expander "invalid export" ie)) (unless (id? ie)
(assertion-violation 'expander "invalid export" ie))
(f (cdr exp*) (cons ie int*) (cons ie ext*))))))))) (f (cdr exp*) (cons ie int*) (cons ie ext*)))))))))
;;; given a library name, like (foo bar (1 2 3)), ;;; given a library name, like (foo bar (1 2 3)),
@ -2963,11 +2995,15 @@
(define (parse x) (define (parse x)
(syntax-match x () (syntax-match x ()
[((v* ...)) [((v* ...))
(for-all (lambda (x) (and (integer? x) (exact? x))) v*) (for-all
(values '() v*)] (lambda (x)
[(x . rest) (symbol? x) (let ([x (syntax->datum x)])
(and (integer? x) (exact? x))))
v*)
(values '() (map syntax->datum v*))]
[(x . rest) (id? x)
(let-values ([(x* v*) (parse rest)]) (let-values ([(x* v*) (parse rest)])
(values (cons x x*) v*))] (values (cons (id->sym x) x*) v*))]
[() (values '() '())] [() (values '() '())]
[_ (stx-error spec "invalid library name")])) [_ (stx-error spec "invalid library name")]))
(let-values (((name* ver*) (parse spec))) (let-values (((name* ver*) (parse spec)))
@ -2983,7 +3019,9 @@
(export exp* ...) (export exp* ...)
(import imp* ...) (import imp* ...)
b* ...) b* ...)
(and (eq? export 'export) (eq? import 'import) (eq? library 'library)) (and (eq? (syntax->datum export) 'export)
(eq? (syntax->datum import) 'import)
(eq? (syntax->datum library) 'library))
(values name* exp* imp* b*)) (values name* exp* imp* b*))
(_ (stx-error e "malformed library"))))) (_ (stx-error e "malformed library")))))
@ -3050,37 +3088,38 @@
(and (integer? x) (exact? x) (>= x 0))) (and (integer? x) (exact? x) (>= x 0)))
(define (subversion-pred x*) (define (subversion-pred x*)
(syntax-match x* () (syntax-match x* ()
[n (subversion? n) [n (subversion? (syntax->datum n))
(lambda (x) (= x n))] (lambda (x) (= x (syntax->datum n)))]
[(p? sub* ...) (eq? p? 'and) [(p? sub* ...) (eq? (syntax->datum p?) 'and)
(let ([p* (map subversion-pred sub*)]) (let ([p* (map subversion-pred sub*)])
(lambda (x) (lambda (x)
(for-all (lambda (p) (p x)) p*)))] (for-all (lambda (p) (p x)) p*)))]
[(p? sub* ...) (eq? p? 'or) [(p? sub* ...) (eq? (syntax->datum p?) 'or)
(let ([p* (map subversion-pred sub*)]) (let ([p* (map subversion-pred sub*)])
(lambda (x) (lambda (x)
(exists (lambda (p) (p x)) p*)))] (exists (lambda (p) (p x)) p*)))]
[(p? sub) (eq? p? 'not) [(p? sub) (eq? (syntax->datum p?) 'not)
(let ([p (subversion-pred sub)]) (let ([p (subversion-pred sub)])
(lambda (x) (lambda (x)
(not (p x))))] (not (p x))))]
[(p? n) (and (eq? p? '<=) (subversion? n)) [(p? n)
(lambda (x) (<= x n))] (and (eq? (syntax->datum p?) '<=) (subversion? (syntax->datum n)))
[(p? n) (and (eq? p? '>=) (subversion? n)) (lambda (x) (<= x (syntax->datum n)))]
(lambda (x) (>= x n))] [(p? n) (and (eq? (syntax->datum p?) '>=) (subversion? n))
(lambda (x) (>= x (syntax->datum n)))]
[_ (assertion-violation 'import "invalid sub-version spec" x* spec)])) [_ (assertion-violation 'import "invalid sub-version spec" x* spec)]))
(define (version-pred x*) (define (version-pred x*)
(syntax-match x* () (syntax-match x* ()
[() (lambda (x) #t)] [() (lambda (x) #t)]
[(c ver* ...) (eq? c 'and) [(c ver* ...) (eq? (syntax->datum c) 'and)
(let ([p* (map version-pred ver*)]) (let ([p* (map version-pred ver*)])
(lambda (x) (lambda (x)
(for-all (lambda (p) (p x)) p*)))] (for-all (lambda (p) (p x)) p*)))]
[(c ver* ...) (eq? c 'or) [(c ver* ...) (eq? (syntax->datum c) 'or)
(let ([p* (map version-pred ver*)]) (let ([p* (map version-pred ver*)])
(lambda (x) (lambda (x)
(exists (lambda (p) (p x)) p*)))] (exists (lambda (p) (p x)) p*)))]
[(c ver) (eq? c 'not) [(c ver) (eq? (syntax->datum c) 'not)
(let ([p (version-pred ver)]) (let ([p (version-pred ver)])
(lambda (x) (not (p x))))] (lambda (x) (not (p x))))]
[(sub* ...) [(sub* ...)
@ -3098,46 +3137,49 @@
(syntax-match x () (syntax-match x ()
[((version-spec* ...)) [((version-spec* ...))
(values '() (version-pred version-spec*))] (values '() (version-pred version-spec*))]
[(x . x*) (symbol? x) [(x . x*) (id? x)
(let-values ([(name pred) (f x*)]) (let-values ([(name pred) (f x*)])
(values (cons x name) pred))] (values (cons (id->sym x) name) pred))]
[() (values '() (lambda (x) #t))] [() (values '() (lambda (x) #t))]
[_ (stx-error spec "invalid import spec")]))) [_ (stx-error spec "invalid import spec")])))
(define (get-import spec) (define (get-import spec)
(syntax-match spec () (syntax-match spec ()
((rename isp (old* new*) ...) ((rename isp (old* new*) ...)
(and (eq? rename 'rename) (and (eq? (syntax->datum rename) 'rename)
(for-all symbol? old*) (for-all id? old*)
(for-all symbol? new*)) (for-all id? new*))
(let ((subst (get-import isp))) (let ((subst (get-import isp))
[old* (map id->sym old*)]
[new* (map id->sym new*)])
;;; rewrite this to eliminate find* and rem* and merge ;;; rewrite this to eliminate find* and rem* and merge
(let ((old-label* (find* old* subst))) (let ((old-label* (find* old* subst)))
(let ((subst (rem* old* subst))) (let ((subst (rem* old* subst)))
;;; FIXME: make sure map is valid ;;; FIXME: make sure map is valid
(merge-substs (map cons new* old-label*) subst))))) (merge-substs (map cons new* old-label*) subst)))))
((except isp sym* ...) ((except isp sym* ...)
(and (eq? except 'except) (for-all symbol? sym*)) (and (eq? (syntax->datum except) 'except) (for-all id? sym*))
(let ((subst (get-import isp))) (let ((subst (get-import isp)))
(rem* sym* subst))) (rem* (map id->sym sym*) subst)))
((only isp sym* ...) ((only isp sym* ...)
(and (eq? only 'only) (for-all symbol? sym*)) (and (eq? (syntax->datum only) 'only) (for-all id? sym*))
(let ((subst (get-import isp))) (let ((subst (get-import isp))
[sym* (map id->sym sym*)])
(let ((sym* (remove-dups sym*))) (let ((sym* (remove-dups sym*)))
(let ((lab* (find* sym* subst))) (let ((lab* (find* sym* subst)))
(map cons sym* lab*))))) (map cons sym* lab*)))))
((prefix isp p) ((prefix isp p)
(and (eq? prefix 'prefix) (symbol? p)) (and (eq? (syntax->datum prefix) 'prefix) (id? p))
(let ((subst (get-import isp))) (let ((subst (get-import isp))
(prefix (symbol->string (id->sym p))))
(map (map
(lambda (x) (lambda (x)
(cons (cons
(string->symbol (string->symbol
(string-append (string-append prefix
(symbol->string p)
(symbol->string (car x)))) (symbol->string (car x))))
(cdr x))) (cdr x)))
subst))) subst)))
((library (spec* ...)) (eq? library 'library) ((library (spec* ...)) (eq? (syntax->datum library) 'library)
;;; FIXME: versioning stuff ;;; FIXME: versioning stuff
(let-values ([(name pred) (parse-library-name spec*)]) (let-values ([(name pred) (parse-library-name spec*)])
(when (null? name) (when (null? name)
@ -3155,7 +3197,7 @@
((imp-collector) lib) ((imp-collector) lib)
(library-subst lib)))) (library-subst lib))))
((x x* ...) ((x x* ...)
(not (memq x '(rename except only prefix library))) (not (memq (syntax->datum x) '(rename except only prefix library)))
(get-import `(library (,x . ,x*)))) (get-import `(library (,x . ,x*))))
(spec (assertion-violation 'import "invalid import spec" spec)))) (spec (assertion-violation 'import "invalid import spec" spec))))
(define (add-imports! imp h) (define (add-imports! imp h)
@ -3303,9 +3345,11 @@
(define (parse-top-level-program e*) (define (parse-top-level-program e*)
(syntax-match e* () (syntax-match e* ()
(((import imp* ...) b* ...) (eq? import 'import) (((import imp* ...) b* ...)
(eq? (syntax->datum import) 'import)
(values imp* b*)) (values imp* b*))
(((import . x) . y) (eq? import 'import) (((import . x) . y)
(eq? (syntax->datum import) 'import)
(assertion-violation 'expander (assertion-violation 'expander
"invalid syntax of top-level program")) "invalid syntax of top-level program"))
(_ (_
@ -3528,6 +3572,21 @@
(assertion-violation 'bound-identifier=? "not an identifier" y)) (assertion-violation 'bound-identifier=? "not an identifier" y))
(assertion-violation 'bound-identifier=? "not an identifier" x)))) (assertion-violation 'bound-identifier=? "not an identifier" x))))
(define (extract-position-condition x)
(define-condition-type &source-information &condition
make-source-condition source-condition?
(file-name source-filename)
(character source-character))
(if (stx? x)
(let ([x (stx-expr x)])
(if (annotation? x)
(let ([src (annotation-source x)])
(if (pair? src)
(make-source-condition (car src) (cdr src))
(condition)))
(condition)))
(condition)))
(define syntax-error (define syntax-error
(lambda (x . args) (lambda (x . args)
(unless (for-all string? args) (unless (for-all string? args)
@ -3539,8 +3598,9 @@
"invalid syntax" "invalid syntax"
(apply string-append args))) (apply string-append args)))
(make-syntax-violation (make-syntax-violation
(stx->datum x) (syntax->datum x)
'none))))) #f)
(extract-position-condition x)))))
(define syntax-violation (define syntax-violation
(case-lambda (case-lambda
@ -3568,7 +3628,8 @@
(make-message-condition msg) (make-message-condition msg)
(make-syntax-violation (make-syntax-violation
(syntax->datum form) (syntax->datum form)
(syntax->datum subform)))))])) (syntax->datum subform))
(extract-position-condition form))))]))
(define identifier? (lambda (x) (id? x))) (define identifier? (lambda (x) (id? x)))

View File

@ -148,7 +148,8 @@
(lambda (x) (lambda (x)
(let ((file-name ((file-locator) x))) (let ((file-name ((file-locator) x)))
(and (string? file-name) (and (string? file-name)
(with-input-from-file file-name read)))) (with-input-from-file file-name
read-annotated))))
(lambda (f) (lambda (f)
(if (procedure? f) (if (procedure? f)
f f