syntax-errors now give source information in their error message.
This commit is contained in:
parent
a725292a4d
commit
917754e28e
|
@ -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)
|
||||||
|
|
|
@ -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
|
||||||
|
|
|
@ -1 +1 @@
|
||||||
1267
|
1268
|
||||||
|
|
|
@ -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))
|
||||||
|
|
|
@ -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)))
|
||||||
|
|
||||||
|
|
|
@ -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
|
||||||
|
|
Loading…
Reference in New Issue