.
original commit: 659d75b6dc63fcd4bca6c4e198d50b5131e0b671
This commit is contained in:
Matthew Flatt
parent
7513365c37
commit
f567f89be6
|
|
@ -75,7 +75,7 @@
|
|||
. body))
|
||||
. rest))))]
|
||||
[_else (raise-syntax-error
|
||||
(quote-syntax awk)
|
||||
#f
|
||||
"bad range"
|
||||
stx
|
||||
body)]))]
|
||||
|
|
@ -153,7 +153,7 @@
|
|||
[else (void)])
|
||||
. rest)))]
|
||||
[_else (raise-syntax-error
|
||||
(quote-syntax awk)
|
||||
#f
|
||||
"bad / ... / clause"
|
||||
stx
|
||||
(car l))]))]
|
||||
|
|
@ -164,7 +164,7 @@
|
|||
[else (void)])
|
||||
. rest)))])))]
|
||||
[_else (raise-syntax-error
|
||||
(quote-syntax awk)
|
||||
#f
|
||||
"bad clause"
|
||||
stx
|
||||
(car l))]))))])
|
||||
|
|
|
|||
|
|
@ -36,24 +36,24 @@
|
|||
(when (and (identifier? (stx-car s))
|
||||
(identifier? (stx-car s2)))
|
||||
(raise-syntax-error
|
||||
'class*/names
|
||||
"extra forms following this, super-instantiate, and super-make-object"
|
||||
#f
|
||||
"extra forms following identifiers for this, super-instantiate, and super-make-object"
|
||||
stx)))))))))])
|
||||
(unless (identifier? this-id)
|
||||
(raise-syntax-error
|
||||
'class*/names
|
||||
#f
|
||||
"not an identifier for `this'"
|
||||
stx
|
||||
this-id))
|
||||
(unless (identifier? super-instantiate-id)
|
||||
(raise-syntax-error
|
||||
'class*/names
|
||||
#f
|
||||
"not an identifier for `super-instantiate'"
|
||||
stx
|
||||
super-instantiate-id))
|
||||
(unless (identifier? super-make-object-id)
|
||||
(raise-syntax-error
|
||||
'class*/names
|
||||
#f
|
||||
"not an identifier for `super-make-object'"
|
||||
stx
|
||||
super-make-object-id))
|
||||
|
|
@ -95,13 +95,12 @@
|
|||
(cdr l)))]
|
||||
[(begin . _)
|
||||
(raise-syntax-error
|
||||
'class*
|
||||
#f
|
||||
"ill-formed begin expression"
|
||||
e
|
||||
stx)]
|
||||
e)]
|
||||
[_else (cons e (loop (cdr l)))])))))]
|
||||
[bad (lambda (msg expr)
|
||||
(raise-syntax-error 'class* msg stx expr))]
|
||||
(raise-syntax-error #f msg stx expr))]
|
||||
[class-name (let ([s (syntax-local-name)])
|
||||
(if (syntax? s)
|
||||
(syntax-e s)
|
||||
|
|
@ -842,7 +841,10 @@
|
|||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (arg (... ...)) (kw kwarg) (... ...))
|
||||
(syntax (-instantiate super-id _ #f (list arg (... ...)) (kw kwarg) (... ...)))]))])
|
||||
(with-syntax ([stx stx])
|
||||
(syntax (-instantiate super-id stx #f
|
||||
(list arg (... ...))
|
||||
(kw kwarg) (... ...))))]))])
|
||||
(let ([super-make-object-id
|
||||
(lambda args
|
||||
(super-id #f args null))])
|
||||
|
|
@ -895,7 +897,7 @@
|
|||
[_else
|
||||
(identifier? (syntax name))
|
||||
(raise-syntax-error
|
||||
who
|
||||
#f
|
||||
"expected an identifier and expression"
|
||||
stx
|
||||
binding)]))
|
||||
|
|
@ -935,7 +937,7 @@
|
|||
(and (identifier? (stx-car ids))
|
||||
(loop (stx-cdr ids)))]
|
||||
[else (raise-syntax-error
|
||||
who
|
||||
#f
|
||||
"bad identifier"
|
||||
stx
|
||||
ids)])))
|
||||
|
|
@ -949,12 +951,12 @@
|
|||
(and (stx-pair? (syntax d))
|
||||
(identifier? (stx-car (syntax d)))))
|
||||
(raise-syntax-error
|
||||
who
|
||||
#f
|
||||
"bad syntax (wrong number of parts)"
|
||||
stx)]
|
||||
[(_ d . __)
|
||||
(raise-syntax-error
|
||||
who
|
||||
#f
|
||||
"bad syntax (no identifier for definition)"
|
||||
stx
|
||||
(syntax d))])))])
|
||||
|
|
@ -1342,14 +1344,14 @@
|
|||
(for-each
|
||||
(lambda (v)
|
||||
(unless (identifier? v)
|
||||
(raise-syntax-error 'interface
|
||||
(raise-syntax-error #f
|
||||
"not an identifier"
|
||||
stx
|
||||
v)))
|
||||
vars)
|
||||
(let ([dup (check-duplicate-identifier vars)])
|
||||
(when dup
|
||||
(raise-syntax-error 'interface
|
||||
(raise-syntax-error #f
|
||||
"duplicate name"
|
||||
stx
|
||||
dup)))
|
||||
|
|
@ -1484,20 +1486,21 @@
|
|||
(define-syntax instantiate
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(form class (arg ...) . x)
|
||||
(syntax (-instantiate do-make-object form class (list arg ...) . x))])))
|
||||
[(form class (arg ...) . x)
|
||||
(with-syntax ([stx stx])
|
||||
(syntax (-instantiate do-make-object stx class (list arg ...) . x)))])))
|
||||
|
||||
;; Helper; used by instantiate and super-instantiate
|
||||
(define-syntax -instantiate
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ do-make-object form class args (kw arg) ...)
|
||||
[(_ do-make-object orig-stx class args (kw arg) ...)
|
||||
(andmap identifier? (syntax->list (syntax (kw ...))))
|
||||
(syntax (do-make-object class
|
||||
args
|
||||
(list (cons 'kw arg)
|
||||
...)))]
|
||||
[(_ super-make-object form class args kwarg ...)
|
||||
[(_ super-make-object orig-stx class args kwarg ...)
|
||||
;; some kwarg must be bad:
|
||||
(for-each (lambda (kwarg)
|
||||
(syntax-case kwarg ()
|
||||
|
|
@ -1506,13 +1509,15 @@
|
|||
'ok]
|
||||
[(kw arg)
|
||||
(raise-syntax-error
|
||||
(syntax-e (syntax form))
|
||||
#f
|
||||
"by-name argument does not start with an identifier"
|
||||
(syntax orig-stx)
|
||||
kwarg)]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
(syntax-e (syntax form))
|
||||
#f
|
||||
"ill-formed by-name argument"
|
||||
(syntax orig-stx)
|
||||
kwarg)]))
|
||||
(syntax->list (syntax (kwarg ...))))])))
|
||||
|
||||
|
|
@ -1662,7 +1667,7 @@
|
|||
(begin
|
||||
(unless (identifier? (syntax name))
|
||||
(raise-syntax-error
|
||||
'send
|
||||
#f
|
||||
"method name is not an identifier"
|
||||
stx
|
||||
(syntax name)))
|
||||
|
|
@ -1781,12 +1786,12 @@
|
|||
[names (syntax->list (syntax (id ...)))])
|
||||
(for-each (lambda (id name)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error 'with-method
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for binding"
|
||||
stx
|
||||
id))
|
||||
(unless (identifier? name)
|
||||
(raise-syntax-error 'with-method
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for method name"
|
||||
stx
|
||||
name)))
|
||||
|
|
@ -1816,7 +1821,7 @@
|
|||
'ok]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
'with-method
|
||||
#f
|
||||
"binding clause is not of the form (identifier (object-expr method-identifier))"
|
||||
stx
|
||||
clause)]))
|
||||
|
|
@ -1824,16 +1829,16 @@
|
|||
;; If we get here, the body must be bad
|
||||
(if (stx-null? (syntax body))
|
||||
(raise-syntax-error
|
||||
'with-method
|
||||
#f
|
||||
"empty body"
|
||||
stx)
|
||||
(raise-syntax-error
|
||||
'with-method
|
||||
#f
|
||||
"bad syntax (illegal use of `.')"
|
||||
stx)))]
|
||||
[(_ x . rest)
|
||||
(raise-syntax-error
|
||||
'with-method
|
||||
#f
|
||||
"not a binding sequence"
|
||||
stx
|
||||
(syntax x))])))
|
||||
|
|
|
|||
|
|
@ -11,7 +11,7 @@
|
|||
(lambda (msg . detail)
|
||||
(apply
|
||||
raise-syntax-error
|
||||
'command-line
|
||||
#f
|
||||
msg
|
||||
stx
|
||||
detail))])
|
||||
|
|
|
|||
|
|
@ -151,7 +151,7 @@
|
|||
(begin
|
||||
(when needs-default?
|
||||
(raise-syntax-error
|
||||
'opt-lambda
|
||||
#f
|
||||
"default value missing"
|
||||
stx
|
||||
(syntax id)))
|
||||
|
|
@ -168,13 +168,13 @@
|
|||
. rest)))]
|
||||
[(bad . rest)
|
||||
(raise-syntax-error
|
||||
'opt-lambda
|
||||
#f
|
||||
"not an identifier or identifier with default"
|
||||
stx
|
||||
(syntax bad))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'opt-lambda
|
||||
#f
|
||||
"bad identifier sequence"
|
||||
stx
|
||||
(syntax args))]))])
|
||||
|
|
@ -202,20 +202,20 @@
|
|||
(lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
'local
|
||||
#f
|
||||
"not an identifier for definition"
|
||||
stx
|
||||
id)))
|
||||
(syntax->list (syntax (id ...))))]
|
||||
[(define-values . rest)
|
||||
(raise-syntax-error
|
||||
'local
|
||||
#f
|
||||
"ill-formed definition"
|
||||
stx
|
||||
d)]
|
||||
[_else
|
||||
(raise-syntax-error
|
||||
'local
|
||||
#f
|
||||
"not a definition"
|
||||
stx
|
||||
defn)])
|
||||
|
|
@ -231,7 +231,7 @@
|
|||
(let ([dup (check-duplicate-identifier ids)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
'local
|
||||
#f
|
||||
"duplicate identifier"
|
||||
stx
|
||||
dup)))
|
||||
|
|
@ -245,7 +245,7 @@
|
|||
body ...))))))]
|
||||
[(_ x body1 body ...)
|
||||
(raise-syntax-error
|
||||
'local
|
||||
#f
|
||||
"not a definition sequence"
|
||||
stx
|
||||
(syntax x))])))
|
||||
|
|
@ -265,7 +265,7 @@
|
|||
(begin
|
||||
(unless (identifier? (syntax name))
|
||||
(raise-syntax-error
|
||||
'rec
|
||||
#f
|
||||
"not an identifier"
|
||||
stx
|
||||
(syntax name)))
|
||||
|
|
@ -293,7 +293,7 @@
|
|||
(when (and (identifier? (car tests))
|
||||
(module-identifier=? (quote-syntax else) (car tests)))
|
||||
(raise-syntax-error
|
||||
'evcase
|
||||
#f
|
||||
"else is not in last clause"
|
||||
stx
|
||||
(car tests)))
|
||||
|
|
@ -311,7 +311,7 @@
|
|||
(syntax-case s ()
|
||||
[(t a ...)
|
||||
(raise-syntax-error
|
||||
'evcase
|
||||
#f
|
||||
"invalid clause"
|
||||
stx
|
||||
s)]))
|
||||
|
|
@ -336,7 +336,7 @@
|
|||
(let ([clauses (syntax->list (syntax (clause ...)))]
|
||||
[bad (lambda (c n)
|
||||
(raise-syntax-error
|
||||
'let+
|
||||
#f
|
||||
(format "illegal use of ~a for a clause" n)
|
||||
stx
|
||||
c))]
|
||||
|
|
@ -376,7 +376,7 @@
|
|||
[(vals . __) (bad clause "vals")]
|
||||
[(recs . __) (bad clause"recs")]
|
||||
[(_ . __) (bad clause "_")]
|
||||
[_else (raise-syntax-error 'let+ "bad clause" stx clause)]))
|
||||
[_else (raise-syntax-error #f "bad clause" stx clause)]))
|
||||
clauses)
|
||||
;; result
|
||||
(let loop ([clauses clauses])
|
||||
|
|
|
|||
|
|
@ -40,14 +40,14 @@
|
|||
;; Current directory
|
||||
[(current-directory)]
|
||||
[else (raise-syntax-error
|
||||
'include
|
||||
#f
|
||||
"can't determine a base path"
|
||||
stx)])))])
|
||||
;; Open the included file
|
||||
(let ([p (with-handlers ([not-break-exn?
|
||||
(lambda (exn)
|
||||
(raise-syntax-error
|
||||
'include
|
||||
#f
|
||||
(format
|
||||
"can't open include file (~a)"
|
||||
(if (exn? exn)
|
||||
|
|
@ -63,7 +63,7 @@
|
|||
(let ([r (with-handlers ([not-break-exn?
|
||||
(lambda (exn)
|
||||
(raise-syntax-error
|
||||
'include
|
||||
#f
|
||||
(format
|
||||
"read error (~a)"
|
||||
(if (exn? exn)
|
||||
|
|
|
|||
|
|
@ -42,13 +42,13 @@
|
|||
|
||||
(define undef-sig-error
|
||||
(lambda (who expr what)
|
||||
(syntax-error who expr
|
||||
(syntax-error #f expr
|
||||
"signature not defined"
|
||||
what)))
|
||||
|
||||
(define not-a-sig-error
|
||||
(lambda (who expr what)
|
||||
(syntax-error who expr
|
||||
(syntax-error #f expr
|
||||
"not a signature"
|
||||
what)))
|
||||
|
||||
|
|
@ -120,7 +120,7 @@
|
|||
(syntax-case (syntax something) ()
|
||||
[:
|
||||
(literal? :)
|
||||
(syntax-error who expr
|
||||
(syntax-error #f expr
|
||||
"misplaced `:'"
|
||||
(syntax something))]
|
||||
[id
|
||||
|
|
@ -141,13 +141,13 @@
|
|||
(and (identifier? (syntax name))
|
||||
(identifier? (syntax super)))]
|
||||
[_else #f])))
|
||||
(syntax-error who expr
|
||||
(syntax-error #f expr
|
||||
"struct name is not an identifier" ;; " or a parenthesized name--super sequence of identifiers"
|
||||
name))
|
||||
(for-each
|
||||
(lambda (fld)
|
||||
(unless (identifier? fld)
|
||||
(syntax-error who expr
|
||||
(syntax-error #f expr
|
||||
"field name is not an identifier"
|
||||
fld)))
|
||||
fields)
|
||||
|
|
@ -173,7 +173,7 @@
|
|||
(loop rest (cons (syntax name) names)
|
||||
no-set? no-sel?)]
|
||||
[else
|
||||
(syntax-error who expr
|
||||
(syntax-error #f expr
|
||||
"bad struct omission"
|
||||
(car omissions))]))))]
|
||||
[(name super-name) (if (identifier? name)
|
||||
|
|
@ -204,7 +204,7 @@
|
|||
struct-accum)))))]
|
||||
[(struct . _)
|
||||
(literal? struct)
|
||||
(syntax-error who expr
|
||||
(syntax-error #f expr
|
||||
"bad `struct' clause form"
|
||||
(syntax something))]
|
||||
[(unit name : sig)
|
||||
|
|
@ -216,7 +216,7 @@
|
|||
struct-accum))]
|
||||
[(unit . _)
|
||||
(literal? unit)
|
||||
(syntax-error who expr
|
||||
(syntax-error #f expr
|
||||
"bad `unit' clause form"
|
||||
(syntax something))]
|
||||
[(open sig)
|
||||
|
|
@ -227,13 +227,13 @@
|
|||
(append (signature-structs s) struct-accum)))]
|
||||
[(open . _)
|
||||
(literal? open)
|
||||
(syntax-error who expr
|
||||
(syntax-error #f expr
|
||||
"bad `open' clause form"
|
||||
(syntax something))]
|
||||
[else
|
||||
(syntax-error who expr "improper signature clause type"
|
||||
(syntax-error #f expr "improper signature clause type"
|
||||
(syntax something))])]
|
||||
[_else (syntax-error who expr "ill-formed signature"
|
||||
[_else (syntax-error #f expr "ill-formed signature"
|
||||
body)]))])
|
||||
(check-unique (map
|
||||
(lambda (elem)
|
||||
|
|
@ -243,7 +243,7 @@
|
|||
[else (signature-name elem)]))
|
||||
elems)
|
||||
(lambda (name)
|
||||
(syntax-error who expr
|
||||
(syntax-error #f expr
|
||||
"duplicate name in signature"
|
||||
name)))
|
||||
(make-signature (stx->sym name)
|
||||
|
|
@ -495,7 +495,7 @@
|
|||
(lambda (var)
|
||||
(let ([renamed (do-rename var renames)])
|
||||
(unless (memq renamed vars)
|
||||
(syntax-error who expr
|
||||
(syntax-error #f expr
|
||||
(format
|
||||
"signature \"~s\" requires variable \"~s\"~a"
|
||||
(signature-src sig)
|
||||
|
|
@ -505,7 +505,7 @@
|
|||
(format " renamed \"~s\"" renamed)))))))
|
||||
(signature-vars sig))
|
||||
(unless (null? (signature-subsigs sig))
|
||||
(syntax-error who expr
|
||||
(syntax-error #f expr
|
||||
(format
|
||||
"signature \"~s\" requires sub-units"
|
||||
(signature-src sig)))))))
|
||||
|
|
@ -515,7 +515,7 @@
|
|||
(let ([bad
|
||||
(lambda (why . rest)
|
||||
(apply
|
||||
syntax-error who expr
|
||||
syntax-error #f expr
|
||||
(format (if really-import?
|
||||
"bad `import' clause~a"
|
||||
"bad linkage specification~a")
|
||||
|
|
@ -546,11 +546,11 @@
|
|||
(lambda (expr body sig user-stx-forms dv-stx begin-stx)
|
||||
(let ([body (stx->list body)])
|
||||
(unless body
|
||||
(syntax-error 'unit/sig expr "illegal use of `.'"))
|
||||
(syntax-error #f expr "illegal use of `.'"))
|
||||
(unless (and (pair? body)
|
||||
(stx-pair? (car body))
|
||||
(eq? 'import (syntax-e (stx-car (car body)))))
|
||||
(syntax-error 'unit/sig expr
|
||||
(syntax-error #f expr
|
||||
"expected `import' clause"))
|
||||
(let* ([imports (parse-imports 'unit/sig #t #t expr (stx-cdr (car body)))]
|
||||
[imported-names (flatten-signatures imports)]
|
||||
|
|
@ -563,11 +563,11 @@
|
|||
(values (map syntax-object->datum (cdr (stx->list (car body)))) (cdr body))
|
||||
(values null body))])
|
||||
(unless renames
|
||||
(syntax-error 'unit/sig expr "illegal use of `.'" (car body)))
|
||||
(syntax-error #f expr "illegal use of `.'" (car body)))
|
||||
;; Check renames:
|
||||
(let ([bad
|
||||
(lambda (why sub)
|
||||
(syntax-error 'unit/sig expr
|
||||
(syntax-error #f expr
|
||||
(format "bad `rename' clause~a" why)
|
||||
sub))])
|
||||
(for-each
|
||||
|
|
@ -584,7 +584,7 @@
|
|||
renames))
|
||||
(check-unique (map car renames)
|
||||
(lambda (name)
|
||||
(syntax-error 'unit/sig expr
|
||||
(syntax-error #f expr
|
||||
"id renamed twice"
|
||||
name)))
|
||||
(let* ([renamed-internals (map car renames)]
|
||||
|
|
@ -613,7 +613,7 @@
|
|||
;; (make-struct-stx-decls sig #f #f src-stx #t)
|
||||
null))]
|
||||
[(and (null? pre-lines) (not port) (not (pair? lines)))
|
||||
(syntax-error 'unit/sig expr "improper body list form")]
|
||||
(syntax-error #f expr "improper body list form")]
|
||||
[else
|
||||
(let-values ([(line) (let ([s (cond
|
||||
[(pair? pre-lines) (car pre-lines)]
|
||||
|
|
@ -651,7 +651,7 @@
|
|||
(cons line body)
|
||||
(append (syntax->list (syntax (id ...))) vars))]
|
||||
[else
|
||||
(syntax-error 'unit/sig expr
|
||||
(syntax-error #f expr
|
||||
"improper `define-values' clause form"
|
||||
line)])]
|
||||
[(and (stx-pair? line)
|
||||
|
|
@ -659,7 +659,7 @@
|
|||
(module-identifier=? (stx-car line) begin-stx))
|
||||
(let ([line-list (stx->list line)])
|
||||
(unless line-list
|
||||
(syntax-error 'unit/sig expr
|
||||
(syntax-error #f expr
|
||||
"improper `begin' clause form"
|
||||
line))
|
||||
(loop (append (cdr line-list) rest-pre-lines)
|
||||
|
|
@ -689,12 +689,12 @@
|
|||
(let* ([imports (parse-imports 'compound-unit/sig #f #t expr (syntax imports))])
|
||||
(let ([link-list (syntax->list (syntax links))])
|
||||
(unless link-list
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
"improper `link' clause form"
|
||||
(syntax links)))
|
||||
(let* ([bad
|
||||
(lambda (why sub)
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
(format "bad `link' element~a" why)
|
||||
sub))]
|
||||
[links
|
||||
|
|
@ -759,7 +759,7 @@
|
|||
(with-handlers ([exn:unit?
|
||||
(lambda (exn)
|
||||
(syntax-error
|
||||
'compound-unit/sig expr
|
||||
#f expr
|
||||
(exn-message exn)))])
|
||||
(verify-signature-match
|
||||
'compound-unit/sig #f
|
||||
|
|
@ -777,7 +777,7 @@
|
|||
sig))]
|
||||
[(or (not (stx-pair? p))
|
||||
(not (identifier? (stx-car p))))
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
path)]
|
||||
[(memq (syntax-e (stx-car p)) (signature-vars sig))
|
||||
(if (and (stx-null? (stx-cdr p)) (not use-sig))
|
||||
|
|
@ -789,7 +789,7 @@
|
|||
(symbol->string id-nopath)))
|
||||
id-nopath)])
|
||||
(var-k base id id-nopath))
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
(format
|
||||
"bad `~a' path: \"~a\" is a variable"
|
||||
clause
|
||||
|
|
@ -809,7 +809,7 @@
|
|||
s
|
||||
(stx-cdr p)))]
|
||||
[else
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
(format
|
||||
"bad `~a' path: \"~a\" not found"
|
||||
clause
|
||||
|
|
@ -844,7 +844,7 @@
|
|||
(syntax->list (syntax (elem1 elem ...))))
|
||||
(values path #f)]
|
||||
[else
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
(format
|
||||
"bad `~a' path"
|
||||
clause)
|
||||
|
|
@ -868,7 +868,7 @@
|
|||
sig
|
||||
(stx-cdr p))))]
|
||||
[else
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
(format
|
||||
"bad `~a' path: \"~a\" not found"
|
||||
clause
|
||||
|
|
@ -876,16 +876,16 @@
|
|||
path)]))))])
|
||||
(check-unique (map link-name links)
|
||||
(lambda (name)
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
(format "duplicate sub-unit tag \"~s\"" name))))
|
||||
(check-unique (map signature-name imports)
|
||||
(lambda (name)
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
(format "duplicate import identifier \"~s\"" name))))
|
||||
(check-unique (append (map signature-name imports)
|
||||
(map link-name links))
|
||||
(lambda (name)
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
(format
|
||||
"name \"~s\" is both import and sub-unit identifier"
|
||||
name))))
|
||||
|
|
@ -914,7 +914,7 @@
|
|||
links)
|
||||
(let ([export-list (syntax->list (syntax exports))])
|
||||
(unless export-list
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
"improper `export' clause form"
|
||||
(syntax exports)))
|
||||
(let* ([upath? (lambda (p)
|
||||
|
|
@ -939,14 +939,14 @@
|
|||
(literal? open)
|
||||
(begin
|
||||
(unless (spath? (syntax spath))
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
"bad `open' sub-clause of `export'"
|
||||
export))
|
||||
(flatten-path 'export
|
||||
(syntax spath)
|
||||
(lambda (base var var-nopath)
|
||||
(syntax-error
|
||||
'compound-unit/sig expr
|
||||
#f expr
|
||||
"`open' sub-clause path is a variable"
|
||||
(car export)))
|
||||
(lambda (base last name sig)
|
||||
|
|
@ -959,7 +959,7 @@
|
|||
(flatten-signature name sig)
|
||||
(flatten-signature #f sig))))
|
||||
(syntax-error
|
||||
'compound-unit/sig expr
|
||||
#f expr
|
||||
"cannot export imported variables"
|
||||
export)))))]
|
||||
[(var (upath vname) . exname)
|
||||
|
|
@ -973,7 +973,7 @@
|
|||
(and (stx-pair? exname)
|
||||
(identifier? (stx-car exname))
|
||||
(stx-null? (stx-cdr exname)))))
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
"bad `var' sub-clause of `export'"
|
||||
export))
|
||||
(flatten-path 'export
|
||||
|
|
@ -991,12 +991,12 @@
|
|||
(list var var-nopath)
|
||||
(list var (syntax-e (stx-car exname))))))
|
||||
(syntax-error
|
||||
'compound-unit/sig expr
|
||||
#f expr
|
||||
"cannot export imported variables"
|
||||
export)))
|
||||
(lambda (base last name var)
|
||||
(syntax-error
|
||||
'compound-unit/sig expr
|
||||
#f expr
|
||||
"`var' sub-clause path specifies a unit"
|
||||
export))))]
|
||||
[(unit spath . exname)
|
||||
|
|
@ -1008,14 +1008,14 @@
|
|||
(and (stx-pair? exname)
|
||||
(identifier? (stx-car exname))
|
||||
(stx-null? (stx-cdr exname)))))
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
"bad `unit' sub-clause of `export'"
|
||||
export))
|
||||
(flatten-path 'export
|
||||
spath
|
||||
(lambda (base var var-nopath)
|
||||
(syntax-error
|
||||
'compound-unit/sig expr
|
||||
#f expr
|
||||
"`unit' sub-clause path is a variable"
|
||||
export))
|
||||
(lambda (base last name sig)
|
||||
|
|
@ -1038,11 +1038,11 @@
|
|||
(syntax-e (stx-car exname))))
|
||||
sig)))))
|
||||
(syntax-error
|
||||
'compound-unit/sig expr
|
||||
#f expr
|
||||
"cannot export imported variables"
|
||||
export)))))]
|
||||
[_else
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
(format
|
||||
"bad `export' sub-clause")
|
||||
export)]))
|
||||
|
|
@ -1057,7 +1057,7 @@
|
|||
append
|
||||
(map sig-explode-pair-sigpart exports)))
|
||||
(lambda (name)
|
||||
(syntax-error 'compound-unit/sig expr
|
||||
(syntax-error #f expr
|
||||
"name is exported twice"
|
||||
name)))
|
||||
(values (map link-name links)
|
||||
|
|
@ -1090,7 +1090,7 @@
|
|||
interned-vectors)
|
||||
interned-vectors))))))]
|
||||
[_else (raise-syntax-error
|
||||
'compound-unit/sig
|
||||
#f
|
||||
"bad syntax"
|
||||
expr)])))
|
||||
|
||||
|
|
|
|||
|
|
@ -157,7 +157,7 @@
|
|||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
'trace
|
||||
#f
|
||||
"not an identifier"
|
||||
stx
|
||||
id)))
|
||||
|
|
@ -224,7 +224,7 @@
|
|||
(for-each (lambda (id)
|
||||
(unless (identifier? id)
|
||||
(raise-syntax-error
|
||||
'untrace
|
||||
#f
|
||||
"not an identifier"
|
||||
stx
|
||||
id)))
|
||||
|
|
|
|||
|
|
@ -44,7 +44,7 @@
|
|||
(let ([check-id (lambda (v)
|
||||
(unless (identifier? v)
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
#f
|
||||
"import is not an identifier"
|
||||
stx
|
||||
v)))]
|
||||
|
|
@ -55,7 +55,7 @@
|
|||
[(lid eid) (and (identifier? (syntax lid))
|
||||
(identifier? (syntax eid))) 'ok]
|
||||
[else (raise-syntax-error
|
||||
'unit
|
||||
#f
|
||||
"export is not an identifier or renamed identifier"
|
||||
stx
|
||||
v)]))]
|
||||
|
|
@ -83,7 +83,7 @@
|
|||
(for-each (lambda (name)
|
||||
(when (hash-table-get ht (syntax-e name) (lambda () #f))
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
#f
|
||||
"duplicate export"
|
||||
stx
|
||||
name))
|
||||
|
|
@ -113,9 +113,8 @@
|
|||
(let ([l (syntax->list (syntax l))])
|
||||
(unless l
|
||||
(raise-syntax-error
|
||||
'begin
|
||||
#f
|
||||
"bad syntax (illegal use of `.')"
|
||||
stx
|
||||
defn-or-expr))
|
||||
(expand-all l))]
|
||||
[else (list defn-or-expr)]))
|
||||
|
|
@ -140,9 +139,9 @@
|
|||
(for-each (lambda (i)
|
||||
(unless (identifier? i)
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
#f
|
||||
"not an identifier in definition"
|
||||
stx
|
||||
defn-or-expr
|
||||
i)))
|
||||
l)
|
||||
(let ([key (if (module-identifier=? (syntax dv) (quote-syntax define-syntaxes))
|
||||
|
|
@ -151,15 +150,13 @@
|
|||
(map (lambda (id) (cons key id)) l)))]
|
||||
[(define-values . l)
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
#f
|
||||
"bad definition form"
|
||||
stx
|
||||
defn-or-expr)]
|
||||
[(define-syntaxes . l)
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
#f
|
||||
"bad syntax definition form"
|
||||
stx
|
||||
defn-or-expr)]
|
||||
[else null]))
|
||||
all-expanded))]
|
||||
|
|
@ -172,7 +169,7 @@
|
|||
(append imported-names all-defined-names))])
|
||||
(when name
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
#f
|
||||
"variable imported and/or defined twice"
|
||||
stx
|
||||
name)))
|
||||
|
|
@ -195,12 +192,12 @@
|
|||
(let ([stx-v (hash-table-get stx-ht (syntax-e n) (lambda () null))])
|
||||
(if (ormap (lambda (i) (bound-identifier=? i n)) stx-v)
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
#f
|
||||
"cannot export syntax from a unit"
|
||||
stx
|
||||
n)
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
#f
|
||||
"exported variable is not defined"
|
||||
stx
|
||||
n))))))
|
||||
|
|
@ -368,14 +365,14 @@
|
|||
(let ([check-id (lambda (v)
|
||||
(unless (identifier? v)
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"import is not an identifier"
|
||||
stx
|
||||
v)))]
|
||||
[check-tag (lambda (v)
|
||||
(unless (identifier? v)
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"tag is not an identifier"
|
||||
stx
|
||||
v)))]
|
||||
|
|
@ -386,14 +383,14 @@
|
|||
(for-each (lambda (v)
|
||||
(unless (identifier? v)
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"non-identifier in linkage"
|
||||
stx
|
||||
v)))
|
||||
(syntax->list v))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"ill-formed linkage"
|
||||
stx
|
||||
v)]))]
|
||||
|
|
@ -403,7 +400,7 @@
|
|||
(begin
|
||||
(unless (identifier? (syntax tag))
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"export tag is not an identifier"
|
||||
stx
|
||||
(syntax tag)))
|
||||
|
|
@ -415,19 +412,19 @@
|
|||
(begin
|
||||
(unless (identifier? (syntax iid))
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"export internal name is not an identifier"
|
||||
stx
|
||||
(syntax iid)))
|
||||
(unless (identifier? (syntax eid))
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"export internal name is not an identifier"
|
||||
stx
|
||||
(syntax eid))))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
(format "ill-formed export with tag ~a"
|
||||
(syntax-e (syntax tag)))
|
||||
stx
|
||||
|
|
@ -435,7 +432,7 @@
|
|||
(syntax->list (syntax (ex ...)))))]
|
||||
[else
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"ill-formed export"
|
||||
stx
|
||||
v)]))]
|
||||
|
|
@ -452,7 +449,7 @@
|
|||
(let ([dup (check-duplicate-identifier imports)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"duplicate import"
|
||||
stx
|
||||
dup)))
|
||||
|
|
@ -460,7 +457,7 @@
|
|||
(let ([dup (check-duplicate-identifier tags)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"duplicate tag"
|
||||
stx
|
||||
dup)))
|
||||
|
|
@ -472,7 +469,7 @@
|
|||
(bound-identifier=? t (syntax tag)))
|
||||
tags)
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"linkage tag is not bound"
|
||||
stx
|
||||
(syntax tag)))]
|
||||
|
|
@ -480,7 +477,7 @@
|
|||
(bound-identifier=? i (syntax id)))
|
||||
imports)
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"no imported identified for linkage"
|
||||
stx
|
||||
(syntax id)))]))]
|
||||
|
|
@ -491,7 +488,7 @@
|
|||
(bound-identifier=? t (syntax tag)))
|
||||
tags)
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"export tag is not bound"
|
||||
stx
|
||||
(syntax tag)))]))])
|
||||
|
|
@ -516,7 +513,7 @@
|
|||
(let ([dup (check-duplicate-identifier export-names)])
|
||||
(when dup
|
||||
(raise-syntax-error
|
||||
'compound-unit
|
||||
#f
|
||||
"duplicate export"
|
||||
stx
|
||||
dup)))
|
||||
|
|
@ -753,9 +750,7 @@
|
|||
[(_ exports unite . prefix+imports)
|
||||
(let* ([badsyntax (lambda (s why)
|
||||
(raise-syntax-error
|
||||
(if global?
|
||||
'namespace-variable-bind/invoke-unit
|
||||
'define-values/invoke-unit)
|
||||
#f
|
||||
(format "bad syntax (~a)" why)
|
||||
stx
|
||||
s))]
|
||||
|
|
|
|||
|
|
@ -253,7 +253,7 @@
|
|||
'define-values/invoke-unit/sig)]
|
||||
[badsyntax (lambda (s why)
|
||||
(raise-syntax-error
|
||||
formname
|
||||
#f
|
||||
(format "bad syntax (~a)" why)
|
||||
(syntax orig)
|
||||
s))])
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user