1230 lines
36 KiB
Racket
1230 lines
36 KiB
Racket
(module sigutil mzscheme
|
|
;; Used by unitsig.rkt
|
|
;; (needs an overhaul, too)
|
|
|
|
(require syntax/stx
|
|
syntax/struct
|
|
syntax/context)
|
|
|
|
(require "sigmatch.rkt")
|
|
(require "../unit200.rkt")
|
|
(require (only racket/base filter sort))
|
|
|
|
(define-struct signature (name ; sym
|
|
src ; sym
|
|
elems ; list of syms and signatures
|
|
ctxs ; list of stx
|
|
structs)) ; list of struct-infos
|
|
(define-struct parsed-unit (imports renames vars import-vars body stx-checks))
|
|
|
|
(define-struct struct-def (name super-name names))
|
|
|
|
(define-struct sigdef (content interned))
|
|
(define (make-sig x) (make-sigdef x #f))
|
|
(provide make-sig)
|
|
|
|
(define inline-sig-name '<unnamed>)
|
|
|
|
(define-syntax literal?
|
|
(lambda (expr)
|
|
(syntax-case expr ()
|
|
[(_ a)
|
|
(syntax (eq? (syntax-e (syntax a)) 'a))])))
|
|
|
|
(define (stx->sym s)
|
|
(if (syntax? s) (syntax-e s) s))
|
|
|
|
(define syntax-error
|
|
(case-lambda
|
|
[(who expr msg sub)
|
|
(raise-syntax-error who msg expr sub)]
|
|
[(who expr msg)
|
|
(raise-syntax-error who msg expr)]))
|
|
|
|
(define undef-sig-error
|
|
(lambda (who expr what)
|
|
(syntax-error #f expr
|
|
"signature not defined"
|
|
what)))
|
|
|
|
(define not-a-sig-error
|
|
(lambda (who expr what)
|
|
(syntax-error #f expr
|
|
"not a signature"
|
|
what)))
|
|
|
|
(define rename-signature
|
|
(lambda (sig name main-ctx)
|
|
(make-signature name
|
|
(signature-src sig)
|
|
(signature-elems sig)
|
|
(if main-ctx
|
|
(map (lambda (ctx) (or ctx main-ctx)) (signature-ctxs sig))
|
|
(signature-ctxs sig))
|
|
(signature-structs sig))))
|
|
|
|
(define intern-signature
|
|
(lambda (name desc)
|
|
(let ([elems (vector->list (car desc))])
|
|
(make-signature
|
|
name
|
|
name
|
|
(map
|
|
(lambda (elem)
|
|
(cond
|
|
[(symbol? elem) elem]
|
|
[(and (pair? elem) (symbol? (car elem)))
|
|
(intern-signature (car elem) (cdr elem))]
|
|
[else (error "intern failed")]))
|
|
elems)
|
|
(map (lambda (elem) #f) elems)
|
|
(map
|
|
(lambda (elem)
|
|
(make-struct-def (vector-ref elem 0)
|
|
(vector-ref elem 1)
|
|
(cddr (vector->list elem))))
|
|
(vector->list (cdr desc)))))))
|
|
|
|
(define get-sig
|
|
(lambda (who expr name sigid main-ctx)
|
|
(if (not (identifier? sigid))
|
|
(parse-signature who expr
|
|
(if name
|
|
name
|
|
inline-sig-name)
|
|
sigid
|
|
main-ctx)
|
|
(let ([v (syntax-local-value sigid (lambda () #f))])
|
|
(unless v
|
|
(undef-sig-error who expr sigid))
|
|
(unless (sigdef? v)
|
|
(not-a-sig-error who expr sigid))
|
|
(unless (sigdef-interned v)
|
|
(set-sigdef-interned! v (intern-signature (syntax-e sigid) (sigdef-content v))))
|
|
(let ([s (sigdef-interned v)])
|
|
(if name
|
|
(rename-signature s (stx->sym name) (and main-ctx sigid))
|
|
s))))))
|
|
|
|
(define check-unique
|
|
(lambda (names error-k)
|
|
(let ([dup (check-duplicate-identifier
|
|
(map (lambda (n)
|
|
(if (syntax? n)
|
|
n
|
|
(datum->syntax-object #f n #f)))
|
|
names))])
|
|
(when dup
|
|
(error-k dup)))))
|
|
|
|
(define parse-signature
|
|
(lambda (who expr name body main-ctx)
|
|
(let-values ([(elems ctxs struct-defs)
|
|
(let loop ([body body][accum null][ctx-accum null][struct-accum null])
|
|
(syntax-case body ()
|
|
[() (values (reverse accum) (reverse ctx-accum) (reverse struct-accum))]
|
|
[(something . rest)
|
|
(syntax-case (syntax something) ()
|
|
[:
|
|
(literal? :)
|
|
(syntax-error #f expr
|
|
"misplaced `:'"
|
|
(syntax something))]
|
|
[id
|
|
(identifier? (syntax id))
|
|
(loop
|
|
(syntax rest)
|
|
(cons (syntax id) accum)
|
|
(cons (syntax id) ctx-accum)
|
|
struct-accum)]
|
|
[(struct name (field ...) omission ...)
|
|
(literal? struct)
|
|
(let ([name (syntax name)]
|
|
[fields (syntax->list (syntax (field ...)))]
|
|
[omissions (syntax->list (syntax (omission ...)))])
|
|
(unless (or (identifier? name)
|
|
;; >>> disabled the `(name super)' case for now <<<
|
|
(and #f (syntax-case name ()
|
|
[(name super)
|
|
(and (identifier? (syntax name))
|
|
(identifier? (syntax super)))]
|
|
[_else #f])))
|
|
(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 #f expr
|
|
"field name is not an identifier"
|
|
fld)))
|
|
fields)
|
|
(let-values ([(omit-names
|
|
omit-setters?
|
|
omit-selectors?)
|
|
(let loop ([omissions omissions]
|
|
[names null]
|
|
[no-set? #f]
|
|
[no-sel? #f])
|
|
(if (null? omissions)
|
|
(values names no-set? no-sel?)
|
|
(let ([rest (cdr omissions)])
|
|
(syntax-case (car omissions) ()
|
|
[-selectors
|
|
(literal? -selectors)
|
|
(loop rest names no-sel? #t)]
|
|
[-setters
|
|
(literal? -setters)
|
|
(loop rest names #t no-set?)]
|
|
[(- name)
|
|
(and (literal? -) (identifier? (syntax name)))
|
|
(loop rest (cons (syntax name) names)
|
|
no-set? no-sel?)]
|
|
[else
|
|
(syntax-error #f expr
|
|
"bad struct omission"
|
|
(car omissions))]))))]
|
|
[(name super-name) (if (identifier? name)
|
|
(values name #f)
|
|
(values (stx-car name)
|
|
(stx-car (stx-cdr name))))])
|
|
(letrec ([names (build-struct-names
|
|
name fields
|
|
omit-selectors? omit-setters?)]
|
|
[filter
|
|
(lambda (names)
|
|
(cond
|
|
[(null? names) null]
|
|
[(ormap (lambda (x) (eq? (syntax-e (car names))
|
|
(syntax-e x)))
|
|
omit-names)
|
|
(filter (cdr names))]
|
|
[else (cons (car names) (filter (cdr names)))]))])
|
|
(let ([elems (if (null? omit-names)
|
|
names
|
|
(filter names))])
|
|
(loop (syntax rest)
|
|
(append
|
|
elems
|
|
accum)
|
|
(append
|
|
(map (lambda (elem) name) elems)
|
|
ctx-accum)
|
|
(cons (make-struct-def (syntax-e name)
|
|
(and super-name (syntax-e super-name))
|
|
names)
|
|
struct-accum))))))]
|
|
[(struct . _)
|
|
(literal? struct)
|
|
(syntax-error #f expr
|
|
"bad `struct' clause form"
|
|
(syntax something))]
|
|
[(unit name : sig)
|
|
(and (literal? unit)
|
|
(identifier? (syntax name)))
|
|
(let ([s (get-sig who expr (syntax name) (syntax sig) (and main-ctx (syntax sig)))])
|
|
(loop (syntax rest)
|
|
(cons s accum)
|
|
(cons (syntax name) ctx-accum)
|
|
struct-accum))]
|
|
[(unit . _)
|
|
(literal? unit)
|
|
(syntax-error #f expr
|
|
"bad `unit' clause form"
|
|
(syntax something))]
|
|
[(open sig)
|
|
(literal? open)
|
|
(let ([s (get-sig who expr #f (syntax sig) (and main-ctx (syntax sig)))])
|
|
(loop (syntax rest)
|
|
(append (signature-elems s) accum)
|
|
(append
|
|
(map (lambda (e ctx)
|
|
(or ctx (syntax sig)))
|
|
(signature-elems s)
|
|
(signature-ctxs s))
|
|
ctx-accum)
|
|
(append (signature-structs s) struct-accum)))]
|
|
[(open . _)
|
|
(literal? open)
|
|
(syntax-error #f expr
|
|
"bad `open' clause form"
|
|
(syntax something))]
|
|
[else
|
|
(syntax-error #f expr "improper signature clause type"
|
|
(syntax something))])]
|
|
[_else (syntax-error #f expr "ill-formed signature"
|
|
body)]))])
|
|
(check-unique (map
|
|
(lambda (elem)
|
|
(cond
|
|
[(symbol? elem) elem]
|
|
[(identifier? elem) (syntax-e elem)]
|
|
[else (signature-name elem)]))
|
|
elems)
|
|
(lambda (name)
|
|
(syntax-error #f expr
|
|
"duplicate name in signature"
|
|
name)))
|
|
(let ([sorted (sort-signature-elems (map cons
|
|
(map (lambda (id)
|
|
(if (identifier? id)
|
|
(syntax-e id)
|
|
id))
|
|
elems)
|
|
(if main-ctx
|
|
(map (lambda (ctx) (or ctx main-ctx)) ctxs)
|
|
(map (lambda (id) #f) ctxs))))])
|
|
(make-signature (stx->sym name)
|
|
(stx->sym name)
|
|
(map car sorted)
|
|
(map cdr sorted)
|
|
struct-defs)))))
|
|
|
|
(define (intern-vector intern-box v)
|
|
(if (and intern-box
|
|
(equal? #() (cdr v))
|
|
(andmap symbol? (vector->list (car v))))
|
|
(or (ormap (lambda (i)
|
|
(and (equal? (car v) (caadr i))
|
|
(list 'unquote (car i))))
|
|
(unbox intern-box))
|
|
(let ([name (car (generate-temporaries '(idvec)))])
|
|
(set-box! intern-box
|
|
(cons (list name v)
|
|
(unbox intern-box)))
|
|
(list 'unquote name)))
|
|
v))
|
|
|
|
(define explode-sig
|
|
(lambda (sig intern-box)
|
|
(intern-vector
|
|
intern-box
|
|
(cons
|
|
(list->vector
|
|
(map
|
|
(lambda (v)
|
|
(if (symbol? v)
|
|
v
|
|
(cons
|
|
(signature-name v)
|
|
(explode-sig v intern-box))))
|
|
(signature-elems sig)))
|
|
(list->vector
|
|
(map
|
|
(lambda (v)
|
|
(list->vector (list* (struct-def-name v)
|
|
(struct-def-super-name v)
|
|
(struct-def-names v))))
|
|
(signature-structs sig)))))))
|
|
|
|
(define explode-named-sig
|
|
(lambda (s intern-box)
|
|
(cons
|
|
(cond
|
|
[(signature-name s)]
|
|
[(signature-src s)]
|
|
[else inline-sig-name])
|
|
(explode-sig s intern-box))))
|
|
|
|
(define explode-named-sigs
|
|
(lambda (sigs intern-box)
|
|
(map (lambda (sig) (explode-named-sig sig intern-box)) sigs)))
|
|
|
|
(define sort-signature-elems
|
|
(lambda (elems)
|
|
(map car
|
|
(sort (map (lambda (ip)
|
|
(let ([i (car ip)])
|
|
(cons ip (symbol->string
|
|
(if (symbol? i) i (signature-name i))))))
|
|
elems)
|
|
;; Less-than; put subs at front
|
|
(lambda (a b)
|
|
(if (symbol? (caar a))
|
|
(if (symbol? (caar b))
|
|
(string<? (cdr a) (cdr b))
|
|
#f)
|
|
(if (symbol? (caar b))
|
|
#t
|
|
(string<? (cdr a) (cdr b)))))))))
|
|
|
|
(define flatten-signature
|
|
(lambda (id sig main-ctx)
|
|
(apply
|
|
append
|
|
(map
|
|
(lambda (elem ctx)
|
|
(if (symbol? elem)
|
|
(let ([sym
|
|
(if id
|
|
(string->symbol (string-append id ":" (symbol->string elem)))
|
|
elem)])
|
|
(list
|
|
(if main-ctx
|
|
(datum->syntax-object (or ctx main-ctx) sym)
|
|
sym)))
|
|
(flatten-signature (let* ([n (signature-name elem)]
|
|
[s (if n
|
|
(symbol->string n)
|
|
#f)])
|
|
(if (and id s)
|
|
(string-append id ":" s)
|
|
(or id s)))
|
|
elem
|
|
(or ctx main-ctx))))
|
|
(signature-elems sig)
|
|
(signature-ctxs sig)))))
|
|
|
|
(define flatten-signatures
|
|
(lambda (sigs main-ctx)
|
|
(apply append (map (lambda (s)
|
|
(let* ([name (signature-name s)]
|
|
[id (if name
|
|
(symbol->string name)
|
|
#f)])
|
|
(flatten-signature id s main-ctx)))
|
|
sigs))))
|
|
|
|
(define signature-parts
|
|
(lambda (q?)
|
|
(lambda (sig)
|
|
(let loop ([elems (signature-elems sig)])
|
|
(cond
|
|
[(null? elems) null]
|
|
[(q? (car elems)) (cons (car elems) (loop (cdr elems)))]
|
|
[else (loop (cdr elems))])))))
|
|
(define signature-vars (signature-parts symbol?))
|
|
(define signature-subsigs (signature-parts signature?))
|
|
|
|
(define do-rename
|
|
(lambda (export-name renames)
|
|
(let loop ([renames renames])
|
|
(cond
|
|
[(null? renames) export-name]
|
|
[(eq? (cadar renames) export-name)
|
|
(caar renames)]
|
|
[else (loop (cdr renames))]))))
|
|
|
|
(define (make-struct-stx-decls sig prefix init-prefix? src-stx check?)
|
|
;; If check? is #f, generates a syntax definition for <name> for
|
|
;; each <name> struct form in `sig'. Used for imports.
|
|
;; If check? is #t, generates an empty syntax "definition" that has
|
|
;; the side-effect of checking <name> against its expected shape.
|
|
;; CURRENTLY, check? is always #f.
|
|
(let ([signame (and init-prefix?
|
|
(signature-name sig))])
|
|
(append
|
|
(apply
|
|
append
|
|
(map (lambda (s)
|
|
(make-struct-stx-decls s
|
|
(if signame
|
|
(format "~a~a:"
|
|
(or prefix "")
|
|
signame)
|
|
prefix)
|
|
#t
|
|
src-stx
|
|
check?))
|
|
(filter signature? (signature-elems sig))))
|
|
(map (lambda (si)
|
|
(let ([names (struct-def-names si)]
|
|
[pfx (lambda (s)
|
|
`(quote-syntax
|
|
,(let ([id (string->symbol
|
|
(format "~a~a~a"
|
|
(or prefix "")
|
|
(if signame
|
|
(format "~a:" signame)
|
|
"")
|
|
(if (syntax? s)
|
|
(syntax-e s)
|
|
s)))])
|
|
(datum->syntax-object src-stx id))))])
|
|
(let* ([name (pfx (struct-def-name si))]
|
|
[check (if check?
|
|
(lambda (l)
|
|
`(verify-struct-shape ,name ,l))
|
|
values)])
|
|
`(define-syntaxes (,@(if check? null (list (cadr name))))
|
|
,(check
|
|
`(list ,(pfx (car names))
|
|
,(pfx (cadr names))
|
|
,(pfx (caddr names))
|
|
;; trailing #fs below mean that we don't know whether we have all the fields:
|
|
(list
|
|
,@(map pfx (every-other (cdddr names)))
|
|
#f)
|
|
(list
|
|
,@(map pfx (every-other (if (null? (cdddr names)) null (cddddr names))))
|
|
#f)
|
|
#f))))))
|
|
(signature-structs sig)))))
|
|
|
|
;; Could be called at expansion time from the result of a `unit/sig' expansion.
|
|
;; NOT CURRENTLY USED.
|
|
(define (verify-struct-shape name shape)
|
|
(let ([v (syntax-local-value name (lambda () #f))]
|
|
[n (length (list-ref shape 3))])
|
|
(unless (and (list? v)
|
|
(= (length v) 5)
|
|
(identifier? (car v))
|
|
(module-identifier=? (car v) (car shape))
|
|
(identifier? (cadr v))
|
|
(module-identifier=? (cadr v) (cadr shape))
|
|
(identifier? (caddr v))
|
|
(module-identifier=? (caddr v) (caddr shape))
|
|
(list? (list-ref v 3))
|
|
(= (length (list-ref v 3)) n)
|
|
(andmap identifier? (list-ref v 3))
|
|
(andmap module-identifier=? (list-ref v 3) (list-ref shape 3))
|
|
(list? (list-ref v 4))
|
|
(= (length (list-ref v 4)) n)
|
|
(andmap identifier? (list-ref v 4))
|
|
(andmap module-identifier=? (list-ref v 4) (list-ref shape 4)))
|
|
(raise-syntax-error
|
|
'unit/sig
|
|
(format "struct definition for `~a' within the unit does not match the export signature (~a)"
|
|
(let ([s (symbol->string (syntax-e name))])
|
|
(substring s 0 (- (string-length s) 2)))
|
|
;; Say why:
|
|
(cond
|
|
[(not v) "definition is missing or does not use `define-struct'"]
|
|
[(not (and (list? v)
|
|
(= (length v) 5)
|
|
(identifier? (car v))
|
|
(identifier? (cadr v))
|
|
(identifier? (caddr v))
|
|
(list? (list-ref v 3))
|
|
(andmap identifier? (list-ref v 3))
|
|
(list? (list-ref v 4))
|
|
(andmap identifier? (list-ref v 4))
|
|
(= (length (list-ref v 4)) (length (list-ref v 3)))))
|
|
"compile-time struct information is stragely malformed"]
|
|
[(not (< (length (list-ref v 3)) n))
|
|
"extra fields in definition"]
|
|
[(not (> (length (list-ref v 3)) n))
|
|
"missing fields in definition"]
|
|
[else
|
|
"different field names or order"]))))
|
|
;; Return 0 values to context
|
|
(values)))
|
|
|
|
|
|
(define (every-other l)
|
|
(let loop ([l l][r null])
|
|
(cond
|
|
[(null? l) r]
|
|
[(null? (cdr l)) (cons (car l) r)]
|
|
[else (loop (cddr l) (cons (car l) r))])))
|
|
|
|
;; ------------------------------------------------------------
|
|
|
|
(define check-signature-unit-body
|
|
(lambda (sig a-unit renames who expr)
|
|
(let ([vars (map syntax-e (parsed-unit-vars a-unit))])
|
|
(for-each
|
|
(lambda (var)
|
|
(let ([renamed (let ([s (do-rename var renames)])
|
|
(if (syntax? s)
|
|
(syntax-e s)
|
|
s))])
|
|
(unless (memq renamed vars)
|
|
(syntax-error #f expr
|
|
(format
|
|
"signature \"~s\" requires variable \"~s\"~a"
|
|
(signature-src sig)
|
|
var
|
|
(if (eq? var renamed)
|
|
""
|
|
(format " renamed \"~s\"" renamed)))))))
|
|
(signature-vars sig))
|
|
(unless (null? (signature-subsigs sig))
|
|
(syntax-error #f expr
|
|
(format
|
|
"signature \"~s\" requires sub-units"
|
|
(signature-src sig)))))))
|
|
|
|
(define parse-imports
|
|
(lambda (who untagged-legal? really-import? expr clause keep-ctx?)
|
|
(let ([bad
|
|
(lambda (why . rest)
|
|
(apply
|
|
syntax-error #f expr
|
|
(format (if really-import?
|
|
"bad `import' clause~a"
|
|
"bad linkage specification~a")
|
|
why)
|
|
rest))])
|
|
(let ([clause (stx->list clause)])
|
|
(unless (stx-list? clause)
|
|
(bad ""))
|
|
(map
|
|
(lambda (item)
|
|
(syntax-case item ()
|
|
[id
|
|
(and (identifier? (syntax id))
|
|
untagged-legal?)
|
|
(rename-signature (get-sig who expr #f item (and keep-ctx? (syntax id))) #f (syntax id))]
|
|
[(id : sig)
|
|
(and (identifier? (syntax id))
|
|
(literal? :))
|
|
(get-sig who expr (syntax id) (syntax sig) (and keep-ctx? (syntax sig)))]
|
|
[any
|
|
untagged-legal?
|
|
(rename-signature (get-sig who expr #f item (and keep-ctx? (syntax any))) #f (syntax any))]
|
|
[_else
|
|
(bad "" item)]))
|
|
clause)))))
|
|
|
|
(define parse-unit
|
|
(lambda (expr body sig user-stx-forms dv-stx ds-stx begin-stx)
|
|
(let ([body (stx->list body)])
|
|
(unless body
|
|
(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 #f expr
|
|
"expected `import' clause"))
|
|
(let* ([imports (parse-imports 'unit/sig #t #t expr (stx-cdr (car body)) #t)]
|
|
[imported-names (flatten-signatures imports #f)]
|
|
[exported-names (flatten-signature #f sig #f)]
|
|
[def-ctx (syntax-local-make-definition-context)]
|
|
[body (cdr body)])
|
|
(let-values ([(renames body)
|
|
(if (and (stx-pair? body)
|
|
(stx-pair? (car body))
|
|
(eq? 'rename (syntax-e (stx-car (car body)))))
|
|
(values (map (lambda (p)
|
|
(list (stx-car p)
|
|
(syntax-e (stx-car (stx-cdr p)))))
|
|
(cdr (stx->list
|
|
(let ([rn (car body)])
|
|
;; Use internal-definition-context-apply ??
|
|
(local-expand rn
|
|
'expression
|
|
(list (stx-car rn))
|
|
def-ctx)))))
|
|
(cdr body))
|
|
(values null body))])
|
|
(unless renames
|
|
(syntax-error #f expr "illegal use of `.'" (car body)))
|
|
;; Check renames:
|
|
(let ([bad
|
|
(lambda (why sub)
|
|
(syntax-error #f expr
|
|
(format "bad `rename' clause~a" why)
|
|
sub))])
|
|
(for-each
|
|
(lambda (id)
|
|
(syntax-case id ()
|
|
[(iid eid)
|
|
(begin
|
|
(unless (identifier? (syntax iid))
|
|
(bad ": original name is not an identifier" (syntax iid)))
|
|
(unless (identifier? (syntax eid))
|
|
(bad ": new name is not an identifier" (syntax eid))))]
|
|
[else
|
|
(bad "" id)]))
|
|
renames))
|
|
(check-unique (map car renames)
|
|
(lambda (name)
|
|
(syntax-error #f expr
|
|
"id renamed twice"
|
|
name)))
|
|
(let* ([renamed-internals (map car renames)]
|
|
[swapped-renames (map (lambda (s) (cons (cadr s) (car s))) renames)]
|
|
[filtered-exported-names
|
|
(if (null? renames) ;; an optimization
|
|
exported-names
|
|
(let loop ([e exported-names])
|
|
(if (null? e)
|
|
e
|
|
(if (ormap (lambda (rn) (eq? (car rn) (car e)))
|
|
swapped-renames)
|
|
(loop (cdr e))
|
|
(cons (car e) (loop (cdr e)))))))]
|
|
[local-vars (map (lambda (s)
|
|
(datum->syntax-object expr s))
|
|
(append renamed-internals filtered-exported-names imported-names))]
|
|
[expand-context (generate-expand-context)]
|
|
[import-stxes (apply append (map (lambda (i)
|
|
(map
|
|
(lambda (d)
|
|
(datum->syntax-object expr d))
|
|
(make-struct-stx-decls i #f #t expr #f)))
|
|
imports))]
|
|
[import-vars
|
|
(let ([vars (map (lambda (sym) (datum->syntax-object expr sym expr))
|
|
(flatten-signatures imports 'must-have-ctx))])
|
|
;; Treat imported names like internal definitions:
|
|
(syntax-local-bind-syntaxes vars #f def-ctx)
|
|
(cdr (syntax->list (local-expand #`(stop #,@vars)
|
|
'expression
|
|
(list #'stop)
|
|
def-ctx))))])
|
|
(let loop ([pre-lines null][lines (append import-stxes body)][port #f][port-name #f][body null][vars null])
|
|
(cond
|
|
[(and (null? pre-lines) (not port) (null? lines))
|
|
(internal-definition-context-seal def-ctx)
|
|
(make-parsed-unit imports
|
|
renames
|
|
vars
|
|
import-vars
|
|
body
|
|
(lambda (src-stx)
|
|
;; Disabled until we have a mechanism for declaring precise information in signatures:
|
|
;; (make-struct-stx-decls sig #f #f src-stx #t)
|
|
null))]
|
|
[(and (null? pre-lines) (not port) (not (pair? lines)))
|
|
(syntax-error #f expr "improper body list form")]
|
|
[else
|
|
(let-values ([(line) (let ([s (cond
|
|
[(pair? pre-lines) (car pre-lines)]
|
|
[port (read-syntax port-name port)]
|
|
[else (car lines)])])
|
|
(if (eof-object? s)
|
|
s
|
|
(local-expand s
|
|
expand-context
|
|
(append
|
|
user-stx-forms
|
|
local-vars)
|
|
def-ctx)))]
|
|
[(rest-pre-lines)
|
|
(if (null? pre-lines)
|
|
null
|
|
(cdr pre-lines))]
|
|
[(rest-lines)
|
|
(if (and (null? pre-lines) (not port))
|
|
(cdr lines)
|
|
lines)])
|
|
(cond
|
|
[(and (null? pre-lines)
|
|
port
|
|
(eof-object? line))
|
|
(values lines body vars)]
|
|
[(and (stx-pair? line)
|
|
(identifier? (stx-car line))
|
|
(module-identifier=? (stx-car line) dv-stx))
|
|
(syntax-case line ()
|
|
[(_ (id ...) rhs)
|
|
(let ([ids (syntax->list #'(id ...))])
|
|
(for-each (lambda (id)
|
|
(unless (identifier? #'id)
|
|
(syntax-error #f id "not an identifier" line)))
|
|
ids)
|
|
(syntax-local-bind-syntaxes ids #f def-ctx)
|
|
(loop rest-pre-lines
|
|
rest-lines
|
|
port
|
|
port-name
|
|
(cons line body)
|
|
(append ids vars)))]
|
|
[else
|
|
(syntax-error #f expr
|
|
"improper `define-values' clause form"
|
|
line)])]
|
|
[(and (stx-pair? line)
|
|
(identifier? (stx-car line))
|
|
(module-identifier=? (stx-car line) ds-stx))
|
|
(syntax-case line ()
|
|
[(_ (id ...) rhs)
|
|
(let ([ids (syntax->list #'(id ...))])
|
|
(for-each (lambda (id)
|
|
(unless (identifier? #'id)
|
|
(syntax-error #f id "not an identifier" line)))
|
|
ids)
|
|
(with-syntax ([rhs (local-transformer-expand
|
|
#'rhs
|
|
'expression
|
|
null)])
|
|
(syntax-local-bind-syntaxes ids #'rhs def-ctx)
|
|
(loop rest-pre-lines
|
|
rest-lines
|
|
port
|
|
port-name
|
|
(cons line body)
|
|
vars)))]
|
|
[else
|
|
(syntax-error #f expr
|
|
"improper `define-syntaxes' clause form"
|
|
line)])]
|
|
[(and (stx-pair? line)
|
|
(identifier? (stx-car line))
|
|
(module-identifier=? (stx-car line) begin-stx))
|
|
(let ([line-list (stx->list line)])
|
|
(unless line-list
|
|
(syntax-error #f expr
|
|
"improper `begin' clause form"
|
|
line))
|
|
(loop (append (cdr line-list) rest-pre-lines)
|
|
rest-lines
|
|
port
|
|
port-name
|
|
body
|
|
vars))]
|
|
[else
|
|
(loop rest-pre-lines
|
|
rest-lines
|
|
port
|
|
port-name
|
|
(cons line body)
|
|
vars)]))]))))))))
|
|
|
|
(define-struct link (name sig expr links))
|
|
(define-struct sig-explode-pair (sigpart exploded))
|
|
|
|
(define parse-compound-unit
|
|
(lambda (expr body)
|
|
(syntax-case body ()
|
|
[((import . imports)
|
|
(link . links)
|
|
(export . exports))
|
|
(and (literal? import) (literal? link) (literal? export))
|
|
(let* ([imports (parse-imports 'compound-unit/sig #f #t expr (syntax imports) #f)])
|
|
(let ([link-list (syntax->list (syntax links))])
|
|
(unless link-list
|
|
(syntax-error #f expr
|
|
"improper `link' clause form"
|
|
(syntax links)))
|
|
(let* ([bad
|
|
(lambda (why sub)
|
|
(syntax-error #f expr
|
|
(format "bad `link' element~a" why)
|
|
sub))]
|
|
[links
|
|
(map
|
|
(lambda (line)
|
|
(syntax-case line ()
|
|
[(tag : sig (expr linkage ...))
|
|
(literal? :)
|
|
(begin
|
|
(unless (identifier? (syntax tag))
|
|
(bad ": link tag is not an identifier" line))
|
|
(make-link (syntax-e (syntax tag))
|
|
(get-sig 'compound-unit/sig (syntax expr) #f (syntax sig) #f)
|
|
(syntax expr)
|
|
(syntax->list (syntax (linkage ...)))))]
|
|
[(tag . x)
|
|
(not (identifier? (syntax tag)))
|
|
(bad ": tag is not an identifier" (syntax tag))]
|
|
[(tag : sig (expr linkage ...) . rest)
|
|
(literal? :)
|
|
(bad ": extra expressions in sub-clause" line)]
|
|
[(tag : sig (expr . rest))
|
|
(literal? :)
|
|
(bad ": illegal use of `.' in linkages" line)]
|
|
[(tag : sig)
|
|
(literal? :)
|
|
(bad ": expected a unit expression and its linkages" line)]
|
|
[(tag : sig . e)
|
|
(literal? :)
|
|
(bad ": unit expression and its linkages not parenthesized" line)]
|
|
[(tag :)
|
|
(literal? :)
|
|
(bad ": expected a signature" line)]
|
|
[(tag)
|
|
(bad ": expected `:'" line)]
|
|
[_else
|
|
(bad "" line)]))
|
|
link-list)]
|
|
[in-sigs imports]
|
|
[find-link
|
|
(lambda (name links)
|
|
(let loop ([links links])
|
|
(cond
|
|
[(null? links) #f]
|
|
[(eq? name (link-name (car links)))
|
|
(car links)]
|
|
[else (loop (cdr links))])))]
|
|
[find-sig
|
|
(lambda (name sigs)
|
|
(let loop ([sigs sigs])
|
|
(cond
|
|
[(null? sigs) #f]
|
|
[(and (signature? (car sigs))
|
|
(eq? name (signature-name (car sigs))))
|
|
(car sigs)]
|
|
[else (loop (cdr sigs))])))]
|
|
[flatten-path
|
|
(lambda (clause path var-k unit-k)
|
|
(letrec ([check-sig
|
|
(lambda (sig use-sig)
|
|
(when use-sig
|
|
(with-handlers ([exn:fail:unit?
|
|
(lambda (exn)
|
|
(syntax-error
|
|
#f expr
|
|
(exn-message exn)))])
|
|
(alt-verify-signature-match
|
|
'compound-unit/sig #f
|
|
(format "signature ~s" (signature-src use-sig))
|
|
(explode-sig use-sig #f)
|
|
(format "signature ~s" (signature-src sig))
|
|
(explode-sig sig #f)))))]
|
|
[flatten-subpath
|
|
(lambda (base last use-sig name sig p)
|
|
(cond
|
|
[(stx-null? p)
|
|
(check-sig sig use-sig)
|
|
(unit-k base last name (if use-sig
|
|
use-sig
|
|
sig))]
|
|
[(or (not (stx-pair? p))
|
|
(not (identifier? (stx-car p))))
|
|
(syntax-error #f expr
|
|
path)]
|
|
[(memq (syntax-e (stx-car p)) (signature-vars sig))
|
|
(if (and (stx-null? (stx-cdr p)) (not use-sig))
|
|
(let* ([id-nopath (syntax-e (stx-car p))]
|
|
[id (if name
|
|
(string->symbol
|
|
(string-append name
|
|
":"
|
|
(symbol->string id-nopath)))
|
|
id-nopath)])
|
|
(var-k base id id-nopath))
|
|
(syntax-error #f expr
|
|
(format
|
|
"bad `~a' path: \"~a\" is a variable"
|
|
clause
|
|
(syntax-e (stx-car p)))
|
|
path))]
|
|
[(find-sig (syntax-e (stx-car p)) (signature-elems sig))
|
|
=>
|
|
(lambda (s)
|
|
(flatten-subpath base
|
|
(syntax-e (stx-car p))
|
|
use-sig
|
|
(let ([n (symbol->string
|
|
(signature-name s))])
|
|
(if name
|
|
(string-append name ":" n)
|
|
n))
|
|
s
|
|
(stx-cdr p)))]
|
|
[else
|
|
(syntax-error #f expr
|
|
(format
|
|
"bad `~a' path: \"~a\" not found"
|
|
clause
|
|
(syntax-e (stx-car p)))
|
|
path)]))])
|
|
(let-values ([(p use-sig)
|
|
(syntax-case path ()
|
|
[_
|
|
(identifier? path)
|
|
(values (list path) #f)]
|
|
[(name : sig)
|
|
(and (identifier? (syntax name))
|
|
(literal? :))
|
|
(values (list (syntax name))
|
|
(get-sig 'compound-unit/sig expr
|
|
#f
|
|
(syntax sig)
|
|
#f))]
|
|
[((elem ...) : sig)
|
|
(and (andmap (lambda (s)
|
|
(and (identifier? s)
|
|
(not (eq? (syntax-e s) ':))))
|
|
(syntax->list (syntax (elem ...))))
|
|
(literal? :))
|
|
(values (syntax (elem ...))
|
|
(get-sig 'compound-unit/sig expr
|
|
#f
|
|
(syntax sig)
|
|
#f))]
|
|
[(elem1 elem ...)
|
|
(andmap (lambda (s)
|
|
(and (identifier? s)
|
|
(not (eq? (syntax-e s) ':))))
|
|
(syntax->list (syntax (elem1 elem ...))))
|
|
(values path #f)]
|
|
[else
|
|
(syntax-error #f expr
|
|
(format
|
|
"bad `~a' path"
|
|
clause)
|
|
path)])])
|
|
(cond
|
|
[(find-link (syntax-e (stx-car p)) links)
|
|
=> (lambda (link)
|
|
(flatten-subpath (link-name link)
|
|
(syntax-e (stx-car p))
|
|
use-sig
|
|
#f
|
|
(link-sig link)
|
|
(stx-cdr p)))]
|
|
[(find-sig (syntax-e (stx-car p)) in-sigs)
|
|
=> (lambda (sig)
|
|
(let ([s (symbol->string (signature-name sig))])
|
|
(flatten-subpath #f
|
|
(syntax-e (stx-car p))
|
|
use-sig
|
|
s
|
|
sig
|
|
(stx-cdr p))))]
|
|
[else
|
|
(syntax-error #f expr
|
|
(format
|
|
"bad `~a' path: \"~a\" not found"
|
|
clause
|
|
(syntax-e (stx-car p)))
|
|
path)]))))])
|
|
(check-unique (map link-name links)
|
|
(lambda (name)
|
|
(syntax-error #f expr
|
|
(format "duplicate sub-unit tag \"~s\"" name))))
|
|
(check-unique (map signature-name imports)
|
|
(lambda (name)
|
|
(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 #f expr
|
|
(format
|
|
"name \"~s\" is both import and sub-unit identifier"
|
|
name))))
|
|
;; Expand `link' clause using signatures
|
|
(for-each
|
|
(lambda (link)
|
|
(set-link-links!
|
|
link
|
|
(map
|
|
(lambda (link)
|
|
(flatten-path 'link link
|
|
(lambda (base var var-nopath)
|
|
(make-sig-explode-pair
|
|
var
|
|
(list
|
|
(if base
|
|
(list base var)
|
|
var))))
|
|
(lambda (base last id sig)
|
|
(make-sig-explode-pair
|
|
(rename-signature sig last #f)
|
|
(if base
|
|
(list (cons base (flatten-signature id sig #f)))
|
|
(flatten-signature id sig #f))))))
|
|
(link-links link))))
|
|
links)
|
|
(let ([export-list (syntax->list (syntax exports))])
|
|
(unless export-list
|
|
(syntax-error #f expr
|
|
"improper `export' clause form"
|
|
(syntax exports)))
|
|
(let* ([upath? (lambda (p)
|
|
(or (identifier? p)
|
|
(and (stx-list? p)
|
|
(andmap identifier? (stx->list p)))))]
|
|
[spath? (lambda (p)
|
|
(syntax-case p ()
|
|
[(name : sig)
|
|
(and (literal? :)
|
|
(upath? (syntax name))
|
|
(or (identifier? (syntax sig))
|
|
(parse-signature 'compound-unit/sig expr #f (syntax sig) #f)))
|
|
#t]
|
|
[_else
|
|
(upath? p)]))]
|
|
[exports
|
|
(map
|
|
(lambda (export)
|
|
(syntax-case export ()
|
|
[(open spath)
|
|
(literal? open)
|
|
(begin
|
|
(unless (spath? (syntax spath))
|
|
(syntax-error #f expr
|
|
"bad `open' sub-clause of `export'"
|
|
export))
|
|
(flatten-path 'export
|
|
(syntax spath)
|
|
(lambda (base var var-nopath)
|
|
(syntax-error
|
|
#f expr
|
|
"`open' sub-clause path is a variable"
|
|
(car export)))
|
|
(lambda (base last name sig)
|
|
(if base
|
|
(make-sig-explode-pair
|
|
(signature-elems sig)
|
|
(cons base
|
|
(map
|
|
list
|
|
(flatten-signature name sig #f)
|
|
(flatten-signature #f sig #f))))
|
|
(syntax-error
|
|
#f expr
|
|
"cannot export imported variables"
|
|
export)))))]
|
|
[(var (upath vname) . exname)
|
|
(literal? var)
|
|
(let ([upath (syntax upath)]
|
|
[vname (syntax vname)]
|
|
[exname (syntax exname)])
|
|
(unless (and (upath? upath)
|
|
(identifier? vname)
|
|
(or (stx-null? exname)
|
|
(and (stx-pair? exname)
|
|
(identifier? (stx-car exname))
|
|
(stx-null? (stx-cdr exname)))))
|
|
(syntax-error #f expr
|
|
"bad `var' sub-clause of `export'"
|
|
export))
|
|
(flatten-path 'export
|
|
(if (identifier? upath)
|
|
(list upath vname)
|
|
(append (stx->list upath) (list vname)))
|
|
(lambda (base var var-nopath)
|
|
(if base
|
|
(make-sig-explode-pair
|
|
(list (if (stx-null? exname)
|
|
var-nopath
|
|
(syntax-e (stx-car exname))))
|
|
(list base
|
|
(if (stx-null? exname)
|
|
(list var var-nopath)
|
|
(list var (syntax-e (stx-car exname))))))
|
|
(syntax-error
|
|
#f expr
|
|
"cannot export imported variables"
|
|
export)))
|
|
(lambda (base last name var)
|
|
(syntax-error
|
|
#f expr
|
|
"`var' sub-clause path specifies a unit"
|
|
export))))]
|
|
[(unit spath . exname)
|
|
(literal? unit)
|
|
(let ([spath (syntax spath)]
|
|
[exname (syntax exname)])
|
|
(unless (and (spath? spath)
|
|
(or (stx-null? exname)
|
|
(and (stx-pair? exname)
|
|
(identifier? (stx-car exname))
|
|
(stx-null? (stx-cdr exname)))))
|
|
(syntax-error #f expr
|
|
"bad `unit' sub-clause of `export'"
|
|
export))
|
|
(flatten-path 'export
|
|
spath
|
|
(lambda (base var var-nopath)
|
|
(syntax-error
|
|
#f expr
|
|
"`unit' sub-clause path is a variable"
|
|
export))
|
|
(lambda (base last name sig)
|
|
(if base
|
|
(make-sig-explode-pair
|
|
(list (rename-signature
|
|
sig
|
|
(if (stx-null? exname)
|
|
last
|
|
(syntax-e (stx-car exname)))
|
|
#f))
|
|
(let ([flat (flatten-signature name sig #f)])
|
|
(cons base
|
|
(map
|
|
list
|
|
flat
|
|
(flatten-signature
|
|
(symbol->string
|
|
(if (stx-null? exname)
|
|
last
|
|
(syntax-e (stx-car exname))))
|
|
sig
|
|
#f)))))
|
|
(syntax-error
|
|
#f expr
|
|
"cannot export imported variables"
|
|
export)))))]
|
|
[_else
|
|
(syntax-error #f expr
|
|
(format
|
|
"bad `export' sub-clause")
|
|
export)]))
|
|
export-list)]
|
|
[interned-vectors (box null)])
|
|
(check-unique (map
|
|
(lambda (s)
|
|
(if (signature? s)
|
|
(signature-name s)
|
|
s))
|
|
(apply
|
|
append
|
|
(map sig-explode-pair-sigpart exports)))
|
|
(lambda (name)
|
|
(syntax-error #f expr
|
|
"name is exported twice"
|
|
name)))
|
|
(values (map link-name links)
|
|
(map link-expr links)
|
|
(map (lambda (link) (explode-sig (link-sig link) interned-vectors)) links)
|
|
(map
|
|
(lambda (link)
|
|
(map (lambda (sep)
|
|
(explode-named-sig (sig-explode-pair-sigpart sep) interned-vectors))
|
|
(link-links link)))
|
|
links)
|
|
(flatten-signatures imports #f)
|
|
(map (lambda (link)
|
|
(apply
|
|
append
|
|
(map
|
|
sig-explode-pair-exploded
|
|
(link-links link))))
|
|
links)
|
|
(map sig-explode-pair-exploded exports)
|
|
(explode-named-sigs imports interned-vectors)
|
|
(explode-sig
|
|
(let ([elems (apply
|
|
append
|
|
(map sig-explode-pair-sigpart exports))])
|
|
(make-signature
|
|
'dummy
|
|
'dummy
|
|
elems
|
|
(map (lambda (x) #f) elems)
|
|
null))
|
|
interned-vectors)
|
|
interned-vectors))))))]
|
|
[_else (raise-syntax-error
|
|
#f
|
|
"bad syntax"
|
|
expr)])))
|
|
|
|
(define parse-invoke-vars
|
|
(lambda (who rest expr)
|
|
(parse-imports who #t #f expr rest #f)))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(provide parse-unit
|
|
parse-compound-unit
|
|
parse-invoke-vars
|
|
|
|
parsed-unit-renames
|
|
parsed-unit-imports
|
|
parsed-unit-import-vars
|
|
parsed-unit-body
|
|
parsed-unit-stx-checks
|
|
parsed-unit-vars
|
|
|
|
make-struct-stx-decls
|
|
verify-struct-shape
|
|
|
|
signature-vars
|
|
signature-structs
|
|
do-rename
|
|
get-sig
|
|
explode-sig
|
|
explode-named-sigs
|
|
check-signature-unit-body
|
|
flatten-signature
|
|
flatten-signatures
|
|
struct-def-name))
|