Moving unit system from mzscheme->scheme/base, reformatting and small changes
as necessary. Ran the quiet testsuite, unit tests, and setup-plt, all good. svn: r17582
This commit is contained in:
Stevie Strickland
parent
d846d22b9e
commit
73d68593af
File diff suppressed because it is too large
Load Diff
|
|
@ -1,136 +1,135 @@
|
|||
(module unit-runtime mzscheme
|
||||
(require-for-syntax "unit-syntax.ss")
|
||||
(provide define-syntax/err-param
|
||||
undefined (rename make-a-unit make-unit) unit-import-sigs unit-export-sigs unit-go unit? unit-deps
|
||||
check-unit check-no-imports check-sigs check-deps check-helper)
|
||||
|
||||
(define-syntax define-syntax/err-param
|
||||
(syntax-rules ()
|
||||
((_ (name arg) body)
|
||||
(define-syntax (name arg)
|
||||
(parameterize ((error-syntax arg))
|
||||
body)))))
|
||||
|
||||
;; initial value
|
||||
(define undefined (letrec ([x x]) x))
|
||||
#lang scheme/base
|
||||
|
||||
;; for named structures
|
||||
(define insp (current-inspector))
|
||||
(require (for-syntax "unit-syntax.ss" scheme/base))
|
||||
(provide define-syntax/err-param
|
||||
undefined (rename-out [make-a-unit make-unit]) unit-import-sigs unit-export-sigs unit-go unit? unit-deps
|
||||
check-unit check-no-imports check-sigs check-deps check-helper)
|
||||
|
||||
;; (make-unit (listof (cons symbol symbol)) (listof (cons symbol symbol)) (listof nat) thunk)
|
||||
;; Runtime representation of a unit
|
||||
(define-struct unit (import-sigs export-sigs deps go))
|
||||
|
||||
;; For units with inferred names, generate a struct that prints using the name:
|
||||
(define (make-naming-constructor type name)
|
||||
(let-values ([(struct: make- ? -accessor -mutator)
|
||||
(make-struct-type name type 0 0 #f null insp)])
|
||||
make-))
|
||||
|
||||
;; Make a unit value (call by the macro expansion of `unit')
|
||||
(define (make-a-unit name num-imports exports deps go)
|
||||
((if name
|
||||
(make-naming-constructor
|
||||
struct:unit
|
||||
(string->symbol (format "unit:~a" name)))
|
||||
make-unit)
|
||||
num-imports exports deps go))
|
||||
(define-syntax define-syntax/err-param
|
||||
(syntax-rules ()
|
||||
((_ (name arg) body)
|
||||
(define-syntax (name arg)
|
||||
(parameterize ((error-syntax arg))
|
||||
body)))))
|
||||
|
||||
;; check-unit : X symbol ->
|
||||
;; ensure that u is a unit value
|
||||
(define (check-unit u name)
|
||||
(unless (unit? u)
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(format "~a: result of unit expression was not a unit: ~e" name u)
|
||||
(current-continuation-marks)))))
|
||||
|
||||
;; check-helper : (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
;; symbol symbol ->
|
||||
;; ensure that the unit's signatures match the expected signatures.
|
||||
(define (check-helper sub-sig super-sig name import?)
|
||||
(define t (make-hash-table 'equal))
|
||||
(let loop ([i (sub1 (vector-length sub-sig))])
|
||||
(when (>= i 0)
|
||||
(let ([v (cdr (vector-ref sub-sig i))])
|
||||
(let loop ([j (sub1 (vector-length v))])
|
||||
(when (>= j 0)
|
||||
(let ([vj (vector-ref v j)])
|
||||
(hash-table-put! t vj
|
||||
(if (hash-table-get t vj #f)
|
||||
'amb
|
||||
#t)))
|
||||
(loop (sub1 j)))))
|
||||
(loop (sub1 i))))
|
||||
(let loop ([i (sub1 (vector-length super-sig))])
|
||||
(when (>= i 0)
|
||||
(let* ([v0 (vector-ref (cdr (vector-ref super-sig i)) 0)]
|
||||
[r (hash-table-get t v0 #f)])
|
||||
(when (or (eq? r 'amb) (not r))
|
||||
(let ([tag (if (pair? v0) (car v0) #f)]
|
||||
[sub-name (car (vector-ref super-sig i))]
|
||||
[err-str (if r
|
||||
;; initial value
|
||||
(define undefined (letrec ([x x]) x))
|
||||
|
||||
;; for named structures
|
||||
(define insp (current-inspector))
|
||||
|
||||
;; (make-unit (listof (cons symbol symbol)) (listof (cons symbol symbol)) (listof nat) thunk)
|
||||
;; Runtime representation of a unit
|
||||
(define-struct unit (import-sigs export-sigs deps go))
|
||||
|
||||
;; For units with inferred names, generate a struct that prints using the name:
|
||||
(define (make-naming-constructor type name)
|
||||
(let-values ([(struct: make- ? -accessor -mutator)
|
||||
(make-struct-type name type 0 0 #f null insp)])
|
||||
make-))
|
||||
|
||||
;; Make a unit value (call by the macro expansion of `unit')
|
||||
(define (make-a-unit name num-imports exports deps go)
|
||||
((if name
|
||||
(make-naming-constructor
|
||||
struct:unit
|
||||
(string->symbol (format "unit:~a" name)))
|
||||
make-unit)
|
||||
num-imports exports deps go))
|
||||
|
||||
;; check-unit : X symbol ->
|
||||
;; ensure that u is a unit value
|
||||
(define (check-unit u name)
|
||||
(unless (unit? u)
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(format "~a: result of unit expression was not a unit: ~e" name u)
|
||||
(current-continuation-marks)))))
|
||||
|
||||
;; check-helper : (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
;; symbol symbol ->
|
||||
;; ensure that the unit's signatures match the expected signatures.
|
||||
(define (check-helper sub-sig super-sig name import?)
|
||||
(define t (make-hash))
|
||||
(let loop ([i (sub1 (vector-length sub-sig))])
|
||||
(when (>= i 0)
|
||||
(let ([v (cdr (vector-ref sub-sig i))])
|
||||
(let loop ([j (sub1 (vector-length v))])
|
||||
(when (>= j 0)
|
||||
(let ([vj (vector-ref v j)])
|
||||
(hash-set! t vj
|
||||
(if (hash-ref t vj #f)
|
||||
'amb
|
||||
#t)))
|
||||
(loop (sub1 j)))))
|
||||
(loop (sub1 i))))
|
||||
(let loop ([i (sub1 (vector-length super-sig))])
|
||||
(when (>= i 0)
|
||||
(let* ([v0 (vector-ref (cdr (vector-ref super-sig i)) 0)]
|
||||
[r (hash-ref t v0 #f)])
|
||||
(when (or (eq? r 'amb) (not r))
|
||||
(let ([tag (if (pair? v0) (car v0) #f)]
|
||||
[sub-name (car (vector-ref super-sig i))]
|
||||
[err-str (if r
|
||||
"supplies multiple times"
|
||||
"does not supply")])
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(cond
|
||||
[(and import? tag)
|
||||
(format "~a: unit argument expects an import for tag ~a with signature ~a, which this usage context ~a"
|
||||
name
|
||||
tag
|
||||
sub-name
|
||||
err-str)]
|
||||
[import?
|
||||
(format "~a: unit argument expects an untagged import with signature ~a, which this usage context ~a"
|
||||
name
|
||||
sub-name
|
||||
err-str)]
|
||||
[tag
|
||||
(format "~a: this usage context expects a unit with an export for tag ~a with signature ~a, which the given unit ~a"
|
||||
name
|
||||
tag
|
||||
sub-name
|
||||
err-str)]
|
||||
[else
|
||||
(format "~a: this usage context expects a unit with an untagged export with signature ~a, which the given unit ~a"
|
||||
name
|
||||
sub-name
|
||||
err-str)])
|
||||
(current-continuation-marks))))))
|
||||
(loop (sub1 i)))))
|
||||
|
||||
;; check-deps : (hash-tableof (cons symbol (or symbol #f)) (cons symbol symbol)) unit symbol ->
|
||||
;; The hash table keys are the tag and runtime signature id
|
||||
;; The values are the name of the signature and the linkage
|
||||
(define (check-deps dep-table unit name)
|
||||
(for-each
|
||||
(λ (dep)
|
||||
(let ([r (hash-table-get dep-table dep #f)])
|
||||
(when r
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(if (car dep)
|
||||
(format "~a: initialization dependent signature ~a with tag ~a is supplied from a later unit with link ~a"
|
||||
name (car r) (car dep) (cdr r))
|
||||
(format "~a: untagged initialization dependent signature ~a is supplied from a later unit with link ~a"
|
||||
name (car r) (cdr r)))
|
||||
(cond
|
||||
[(and import? tag)
|
||||
(format "~a: unit argument expects an import for tag ~a with signature ~a, which this usage context ~a"
|
||||
name
|
||||
tag
|
||||
sub-name
|
||||
err-str)]
|
||||
[import?
|
||||
(format "~a: unit argument expects an untagged import with signature ~a, which this usage context ~a"
|
||||
name
|
||||
sub-name
|
||||
err-str)]
|
||||
[tag
|
||||
(format "~a: this usage context expects a unit with an export for tag ~a with signature ~a, which the given unit ~a"
|
||||
name
|
||||
tag
|
||||
sub-name
|
||||
err-str)]
|
||||
[else
|
||||
(format "~a: this usage context expects a unit with an untagged export with signature ~a, which the given unit ~a"
|
||||
name
|
||||
sub-name
|
||||
err-str)])
|
||||
(current-continuation-marks))))))
|
||||
(unit-deps unit)))
|
||||
|
||||
;; check-no-imports : unit symbol ->
|
||||
;; ensures that the unit has no imports
|
||||
(define (check-no-imports unit name)
|
||||
(check-helper (vector) (unit-import-sigs unit) name #t))
|
||||
|
||||
;; check-sigs : unit
|
||||
;; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
;; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
;; symbol ->
|
||||
;; ensures that unit has the given signatures
|
||||
(define (check-sigs unit expected-imports expected-exports name)
|
||||
(check-helper expected-imports (unit-import-sigs unit) name #t)
|
||||
(check-helper (unit-export-sigs unit) expected-exports name #f)))
|
||||
(loop (sub1 i)))))
|
||||
|
||||
|
||||
;; check-deps : (hash-tableof (cons symbol (or symbol #f)) (cons symbol symbol)) unit symbol ->
|
||||
;; The hash table keys are the tag and runtime signature id
|
||||
;; The values are the name of the signature and the linkage
|
||||
(define (check-deps dep-table unit name)
|
||||
(for-each
|
||||
(λ (dep)
|
||||
(let ([r (hash-ref dep-table dep #f)])
|
||||
(when r
|
||||
(raise
|
||||
(make-exn:fail:contract
|
||||
(if (car dep)
|
||||
(format "~a: initialization dependent signature ~a with tag ~a is supplied from a later unit with link ~a"
|
||||
name (car r) (car dep) (cdr r))
|
||||
(format "~a: untagged initialization dependent signature ~a is supplied from a later unit with link ~a"
|
||||
name (car r) (cdr r)))
|
||||
(current-continuation-marks))))))
|
||||
(unit-deps unit)))
|
||||
|
||||
;; check-no-imports : unit symbol ->
|
||||
;; ensures that the unit has no imports
|
||||
(define (check-no-imports unit name)
|
||||
(check-helper (vector) (unit-import-sigs unit) name #t))
|
||||
|
||||
;; check-sigs : unit
|
||||
;; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
;; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
||||
;; symbol ->
|
||||
;; ensures that unit has the given signatures
|
||||
(define (check-sigs unit expected-imports expected-exports name)
|
||||
(check-helper expected-imports (unit-import-sigs unit) name #t)
|
||||
(check-helper (unit-export-sigs unit) expected-exports name #f))
|
||||
|
|
|
|||
|
|
@ -1,286 +1,284 @@
|
|||
(module unit-syntax mzscheme
|
||||
(require syntax/stx)
|
||||
(require-for-template "unit-keywords.ss")
|
||||
|
||||
(provide (all-defined))
|
||||
|
||||
(define error-syntax (make-parameter #f))
|
||||
(define raise-stx-err
|
||||
(case-lambda
|
||||
((msg) (raise-syntax-error #f msg (error-syntax)))
|
||||
((msg stx) (raise-syntax-error #f msg (error-syntax) stx))))
|
||||
#lang scheme/base
|
||||
|
||||
;; check-id: syntax-object -> identifier
|
||||
(define (check-id id)
|
||||
(unless (identifier? id)
|
||||
(raise-stx-err "not an identifier" id))
|
||||
id)
|
||||
(require syntax/stx)
|
||||
(require (for-template "unit-keywords.ss"))
|
||||
|
||||
;; checked-syntax->list : syntax-object -> (listof syntax-object)
|
||||
(define (checked-syntax->list s)
|
||||
(define l (syntax->list s))
|
||||
(unless (or (stx-pair? s) (stx-null? s))
|
||||
(raise-stx-err "bad syntax (not a list)" s))
|
||||
(unless l
|
||||
(raise-stx-err "bad syntax (illegal use of `.')" s))
|
||||
l)
|
||||
(provide (all-defined-out))
|
||||
|
||||
;; check-tagged : (syntax-object -> X) -> syntax-object -> (cons (or symbol #f) X)
|
||||
(define (check-tagged check)
|
||||
(λ (o)
|
||||
(syntax-case o (tag)
|
||||
((tag . s)
|
||||
(syntax-case #'s ()
|
||||
((sym spec)
|
||||
(begin
|
||||
(unless (symbol? (syntax-e #'sym))
|
||||
(raise-stx-err "tag must be a symbol" #'sym))
|
||||
(cons (syntax-e #'sym) (check #'spec))))
|
||||
(_ (raise-stx-err "expected (tag <identifier> <syntax>)" #'s))))
|
||||
(_
|
||||
(cons #f (check o))))))
|
||||
(define error-syntax (make-parameter #f))
|
||||
(define raise-stx-err
|
||||
(case-lambda
|
||||
((msg) (raise-syntax-error #f msg (error-syntax)))
|
||||
((msg stx) (raise-syntax-error #f msg (error-syntax) stx))))
|
||||
|
||||
;; check-tagged-:-clause : syntax-object -> (cons identifier identifier)
|
||||
;; ensures that clause matches (a : b) or (a : (tag t b))
|
||||
(define (check-tagged-:-clause clause)
|
||||
(checked-syntax->list clause)
|
||||
(syntax-case* clause (:) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
((a : b)
|
||||
(identifier? #'a)
|
||||
(let ([p ((check-tagged check-id) #'b)])
|
||||
(cons (car p) (cons #'a (cdr p)))))
|
||||
(_ (raise-stx-err
|
||||
"expected syntax matching (<identifier> : <identifier>) or (<identifier> : (tag <identifier> <identifier>))"
|
||||
clause))))
|
||||
|
||||
(define check-tagged-id (check-tagged check-id))
|
||||
;; check-id: syntax-object -> identifier
|
||||
(define (check-id id)
|
||||
(unless (identifier? id)
|
||||
(raise-stx-err "not an identifier" id))
|
||||
id)
|
||||
|
||||
;; check-spec-syntax : syntax-object boolean (syntax-object -> boolean) ->
|
||||
;; ensures that s matches spec.
|
||||
;; tag-spec ::= spec
|
||||
;; | (tag symbol spec)
|
||||
;; spec ::= prim-spec
|
||||
;; | (prefix identifier spec)
|
||||
;; | (rename spec (identifier identifier) ...)
|
||||
;; | (only spec identifier ...) only if import? is true
|
||||
;; | (except spec identifier ...) only if import? is true
|
||||
(define (check-tagged-spec-syntax s import? prim-spec?)
|
||||
((check-tagged (λ (s) (check-spec-syntax s import? prim-spec?))) s))
|
||||
|
||||
(define (check-spec-syntax s import? prim-spec?)
|
||||
(unless (prim-spec? s)
|
||||
(let ((ie (if import? 'import 'export)))
|
||||
(unless (stx-pair? s)
|
||||
(raise-stx-err (format "bad ~a spec" ie) s))
|
||||
(checked-syntax->list s)
|
||||
(syntax-case s (prefix rename)
|
||||
((key . x)
|
||||
(or (module-identifier=? #'key #'only)
|
||||
(module-identifier=? #'key #'except))
|
||||
(begin
|
||||
(unless import?
|
||||
(raise-stx-err
|
||||
"bad export-spec keyword"
|
||||
#'key))
|
||||
(syntax-case #'x ()
|
||||
(()
|
||||
(raise-stx-err (format "missing ~a-spec argument" ie)
|
||||
s))
|
||||
((s y ...)
|
||||
(begin
|
||||
(for-each check-id (syntax->list #'(y ...)))
|
||||
(check-spec-syntax #'s import? prim-spec?))))))
|
||||
((prefix)
|
||||
(raise-stx-err (format "missing prefix identifier and ~a spec" ie)
|
||||
s))
|
||||
((prefix x)
|
||||
(begin
|
||||
(check-id #'x)
|
||||
(raise-stx-err (format "missing ~a spec" ie) s)))
|
||||
((prefix x y)
|
||||
(begin
|
||||
(check-id #'x)
|
||||
(check-spec-syntax #'y import? prim-spec?)))
|
||||
((prefix . _)
|
||||
(raise-stx-err "too many arguments" s))
|
||||
((rename)
|
||||
(raise-stx-err (format "missing ~a spec" ie) s))
|
||||
((rename sub-s clause ...)
|
||||
(begin
|
||||
(for-each
|
||||
(lambda (c)
|
||||
(syntax-case c ()
|
||||
((a b)
|
||||
(begin
|
||||
(check-id #'a)
|
||||
(check-id #'b)))
|
||||
((a . b)
|
||||
(begin
|
||||
(checked-syntax->list c)
|
||||
(raise-stx-err "bad rename clause" c)))
|
||||
(_
|
||||
(raise-stx-err "bad rename clause" c))))
|
||||
(syntax->list #'(clause ...)))
|
||||
(check-spec-syntax #'sub-s import? prim-spec?)))
|
||||
((k . x)
|
||||
(raise-stx-err (format "bad ~a-spec keyword" ie) #'k))))))
|
||||
|
||||
;; check-unit-syntax : syntax-object -> syntax-object
|
||||
;; ensures that stx matches ((import i ...) (export e ...) b ...)
|
||||
;; or ((import i ...) (export e ...) (init-depend id ...) b ...)
|
||||
;; and returns syntax that matches the latter
|
||||
(define (check-unit-syntax stx)
|
||||
(syntax-case stx (import export init-depend)
|
||||
(((import . isig) (export . esig) (init-depend . id) . body)
|
||||
(begin
|
||||
(checked-syntax->list (stx-car stx))
|
||||
(checked-syntax->list (stx-car (stx-cdr stx)))
|
||||
(checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))
|
||||
(checked-syntax->list #'body)
|
||||
stx))
|
||||
(((import . isig) (export . esig) . body)
|
||||
(begin
|
||||
(checked-syntax->list (stx-car stx))
|
||||
(checked-syntax->list (stx-car (stx-cdr stx)))
|
||||
(checked-syntax->list #'body)
|
||||
(syntax/loc stx
|
||||
((import . isig) (export . esig) (init-depend) . body))))
|
||||
(()
|
||||
(raise-stx-err "missing import and export clauses"))
|
||||
(((import . isig))
|
||||
(raise-stx-err "missing export clause"))
|
||||
(((import . isig) e . rest)
|
||||
(raise-stx-err "export clause must start with keyword \"export\"" #'e))
|
||||
((i . rest)
|
||||
(raise-stx-err "import clause must start with keyword \"import\"" #'i))))
|
||||
|
||||
|
||||
;; check-unit-body-syntax : syntax-object -> syntax-object
|
||||
;; ensures that stx matches (exp (import i ...) (export e ...))
|
||||
;; or (exp (import i ...) (export e ...) (init-depend id ...))
|
||||
;; and returns syntax that matches the latter
|
||||
(define (check-unit-body-syntax stx)
|
||||
(checked-syntax->list stx)
|
||||
(syntax-case stx (import export init-depend)
|
||||
((exp (import . isig) (export . esig) (init-depend . id))
|
||||
(begin
|
||||
(checked-syntax->list (stx-car (stx-cdr stx)))
|
||||
(checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))
|
||||
(checked-syntax->list (stx-car (stx-cdr (stx-cdr (stx-cdr stx)))))
|
||||
stx))
|
||||
((exp (import . isig) (export . esig))
|
||||
(begin
|
||||
(checked-syntax->list (stx-car (stx-cdr stx)))
|
||||
(checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))
|
||||
(syntax/loc stx
|
||||
(exp (import . isig) (export . esig) (init-depend)))))
|
||||
(()
|
||||
(raise-stx-err "missing expression, import and export clauses"))
|
||||
((exp)
|
||||
(raise-stx-err "missing import and export clauses"))
|
||||
((exp (import . isig))
|
||||
(raise-stx-err "missing export clause"))
|
||||
((exp i e id extra . rest)
|
||||
(raise-stx-err "too many clauses" stx))
|
||||
((exp (import . isig) (export . esig) id)
|
||||
(raise-stx-err "init-depend clause must start with keyword \"init-depend\"" #'id))
|
||||
((exp (import . isig) e . rest)
|
||||
(raise-stx-err "export clause must start with keyword \"export\"" #'e))
|
||||
((exp i . rest)
|
||||
(raise-stx-err "import clause must start with keyword \"import\"" #'i))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; check-link-line-syntax : syntax-object ->
|
||||
;; ensures that l matches ((x ...) u y ...)
|
||||
(define (check-link-line-syntax l)
|
||||
(unless (stx-pair? l)
|
||||
(raise-stx-err "bad linking line" l))
|
||||
(checked-syntax->list l)
|
||||
(syntax-case l ()
|
||||
(((x ...) u y ...) (void))
|
||||
(((x ...))
|
||||
(raise-stx-err "missing unit expression" l))
|
||||
((x . y)
|
||||
(begin
|
||||
(unless (stx-pair? #'x)
|
||||
(raise-stx-err "bad export list" #'x))
|
||||
(checked-syntax->list #'x)))))
|
||||
|
||||
;; check-compound-syntax : syntax-object -> syntax-object
|
||||
;; ensures that clauses has exactly one clause matching each of
|
||||
;; (import i ...), (export e ...), and (link i ...), in any order.
|
||||
;; returns #'((i ...) (e ...) (l ...))
|
||||
(define (check-compound-syntax c)
|
||||
(define clauses (checked-syntax->list c))
|
||||
(define im #f)
|
||||
(define ex #f)
|
||||
(define li #f)
|
||||
(for-each
|
||||
(lambda (clause)
|
||||
(syntax-case clause (import export link)
|
||||
((import i ...)
|
||||
;; checked-syntax->list : syntax-object -> (listof syntax-object)
|
||||
(define (checked-syntax->list s)
|
||||
(define l (syntax->list s))
|
||||
(unless (or (stx-pair? s) (stx-null? s))
|
||||
(raise-stx-err "bad syntax (not a list)" s))
|
||||
(unless l
|
||||
(raise-stx-err "bad syntax (illegal use of `.')" s))
|
||||
l)
|
||||
|
||||
;; check-tagged : (syntax-object -> X) -> syntax-object -> (cons (or symbol #f) X)
|
||||
(define (check-tagged check)
|
||||
(λ (o)
|
||||
(syntax-case o (tag)
|
||||
((tag . s)
|
||||
(syntax-case #'s ()
|
||||
((sym spec)
|
||||
(begin
|
||||
(when im
|
||||
(raise-stx-err "multiple import clauses" clause))
|
||||
(set! im (syntax->list #'(i ...)))))
|
||||
((export e ...)
|
||||
(begin
|
||||
(when ex
|
||||
(raise-stx-err "multiple export clauses" clause))
|
||||
(set! ex (syntax->list #'(e ...)))))
|
||||
((link l ...)
|
||||
(begin
|
||||
(when li
|
||||
(raise-stx-err "duplicate link clauses" clause))
|
||||
(set! li (syntax->list #'(l ...)))))
|
||||
((x . y)
|
||||
(begin
|
||||
(checked-syntax->list clause)
|
||||
(raise-stx-err "bad compound-unit clause keyword" #'x)))
|
||||
(_
|
||||
(raise-stx-err "expected import, export, or link clause" clause))))
|
||||
clauses)
|
||||
(unless im
|
||||
(raise-stx-err "missing import clause"))
|
||||
(unless ex
|
||||
(raise-stx-err "missing export clause"))
|
||||
(unless li
|
||||
(raise-stx-err "missing link clause" ))
|
||||
#`(#,im #,ex #,li))
|
||||
(unless (symbol? (syntax-e #'sym))
|
||||
(raise-stx-err "tag must be a symbol" #'sym))
|
||||
(cons (syntax-e #'sym) (check #'spec))))
|
||||
(_ (raise-stx-err "expected (tag <identifier> <syntax>)" #'s))))
|
||||
(_
|
||||
(cons #f (check o))))))
|
||||
|
||||
;; check-def-syntax : syntax-object ->
|
||||
;; d must be a syntax-pair
|
||||
;; ensures that d matches (_ (x ...) e)
|
||||
(define (check-def-syntax d)
|
||||
(unless (syntax->list d)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax (illegal use of `.')"
|
||||
d))
|
||||
(syntax-case d ()
|
||||
((_ params expr)
|
||||
(let ((l (syntax->list #'params)))
|
||||
(unless l
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad variable list"
|
||||
d #'params))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(unless (identifier? x)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier"
|
||||
d x)))
|
||||
l)))
|
||||
(_
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "bad syntax (has ~a parts after keyword)"
|
||||
(sub1 (length (syntax->list d))))
|
||||
d))))
|
||||
)
|
||||
;; check-tagged-:-clause : syntax-object -> (cons identifier identifier)
|
||||
;; ensures that clause matches (a : b) or (a : (tag t b))
|
||||
(define (check-tagged-:-clause clause)
|
||||
(checked-syntax->list clause)
|
||||
(syntax-case* clause (:) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||
((a : b)
|
||||
(identifier? #'a)
|
||||
(let ([p ((check-tagged check-id) #'b)])
|
||||
(cons (car p) (cons #'a (cdr p)))))
|
||||
(_ (raise-stx-err
|
||||
"expected syntax matching (<identifier> : <identifier>) or (<identifier> : (tag <identifier> <identifier>))"
|
||||
clause))))
|
||||
|
||||
;(load "test-unit-syntax.ss")
|
||||
(define check-tagged-id (check-tagged check-id))
|
||||
|
||||
;; check-spec-syntax : syntax-object boolean (syntax-object -> boolean) ->
|
||||
;; ensures that s matches spec.
|
||||
;; tag-spec ::= spec
|
||||
;; | (tag symbol spec)
|
||||
;; spec ::= prim-spec
|
||||
;; | (prefix identifier spec)
|
||||
;; | (rename spec (identifier identifier) ...)
|
||||
;; | (only spec identifier ...) only if import? is true
|
||||
;; | (except spec identifier ...) only if import? is true
|
||||
(define (check-tagged-spec-syntax s import? prim-spec?)
|
||||
((check-tagged (λ (s) (check-spec-syntax s import? prim-spec?))) s))
|
||||
|
||||
(define (check-spec-syntax s import? prim-spec?)
|
||||
(unless (prim-spec? s)
|
||||
(let ((ie (if import? 'import 'export)))
|
||||
(unless (stx-pair? s)
|
||||
(raise-stx-err (format "bad ~a spec" ie) s))
|
||||
(checked-syntax->list s)
|
||||
(syntax-case s (prefix rename)
|
||||
((key . x)
|
||||
(or (free-identifier=? #'key #'only)
|
||||
(free-identifier=? #'key #'except))
|
||||
(begin
|
||||
(unless import?
|
||||
(raise-stx-err
|
||||
"bad export-spec keyword"
|
||||
#'key))
|
||||
(syntax-case #'x ()
|
||||
(()
|
||||
(raise-stx-err (format "missing ~a-spec argument" ie)
|
||||
s))
|
||||
((s y ...)
|
||||
(begin
|
||||
(for-each check-id (syntax->list #'(y ...)))
|
||||
(check-spec-syntax #'s import? prim-spec?))))))
|
||||
((prefix)
|
||||
(raise-stx-err (format "missing prefix identifier and ~a spec" ie)
|
||||
s))
|
||||
((prefix x)
|
||||
(begin
|
||||
(check-id #'x)
|
||||
(raise-stx-err (format "missing ~a spec" ie) s)))
|
||||
((prefix x y)
|
||||
(begin
|
||||
(check-id #'x)
|
||||
(check-spec-syntax #'y import? prim-spec?)))
|
||||
((prefix . _)
|
||||
(raise-stx-err "too many arguments" s))
|
||||
((rename)
|
||||
(raise-stx-err (format "missing ~a spec" ie) s))
|
||||
((rename sub-s clause ...)
|
||||
(begin
|
||||
(for-each
|
||||
(lambda (c)
|
||||
(syntax-case c ()
|
||||
((a b)
|
||||
(begin
|
||||
(check-id #'a)
|
||||
(check-id #'b)))
|
||||
((a . b)
|
||||
(begin
|
||||
(checked-syntax->list c)
|
||||
(raise-stx-err "bad rename clause" c)))
|
||||
(_
|
||||
(raise-stx-err "bad rename clause" c))))
|
||||
(syntax->list #'(clause ...)))
|
||||
(check-spec-syntax #'sub-s import? prim-spec?)))
|
||||
((k . x)
|
||||
(raise-stx-err (format "bad ~a-spec keyword" ie) #'k))))))
|
||||
|
||||
;; check-unit-syntax : syntax-object -> syntax-object
|
||||
;; ensures that stx matches ((import i ...) (export e ...) b ...)
|
||||
;; or ((import i ...) (export e ...) (init-depend id ...) b ...)
|
||||
;; and returns syntax that matches the latter
|
||||
(define (check-unit-syntax stx)
|
||||
(syntax-case stx (import export init-depend)
|
||||
(((import . isig) (export . esig) (init-depend . id) . body)
|
||||
(begin
|
||||
(checked-syntax->list (stx-car stx))
|
||||
(checked-syntax->list (stx-car (stx-cdr stx)))
|
||||
(checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))
|
||||
(checked-syntax->list #'body)
|
||||
stx))
|
||||
(((import . isig) (export . esig) . body)
|
||||
(begin
|
||||
(checked-syntax->list (stx-car stx))
|
||||
(checked-syntax->list (stx-car (stx-cdr stx)))
|
||||
(checked-syntax->list #'body)
|
||||
(syntax/loc stx
|
||||
((import . isig) (export . esig) (init-depend) . body))))
|
||||
(()
|
||||
(raise-stx-err "missing import and export clauses"))
|
||||
(((import . isig))
|
||||
(raise-stx-err "missing export clause"))
|
||||
(((import . isig) e . rest)
|
||||
(raise-stx-err "export clause must start with keyword \"export\"" #'e))
|
||||
((i . rest)
|
||||
(raise-stx-err "import clause must start with keyword \"import\"" #'i))))
|
||||
|
||||
|
||||
;; check-unit-body-syntax : syntax-object -> syntax-object
|
||||
;; ensures that stx matches (exp (import i ...) (export e ...))
|
||||
;; or (exp (import i ...) (export e ...) (init-depend id ...))
|
||||
;; and returns syntax that matches the latter
|
||||
(define (check-unit-body-syntax stx)
|
||||
(checked-syntax->list stx)
|
||||
(syntax-case stx (import export init-depend)
|
||||
((exp (import . isig) (export . esig) (init-depend . id))
|
||||
(begin
|
||||
(checked-syntax->list (stx-car (stx-cdr stx)))
|
||||
(checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))
|
||||
(checked-syntax->list (stx-car (stx-cdr (stx-cdr (stx-cdr stx)))))
|
||||
stx))
|
||||
((exp (import . isig) (export . esig))
|
||||
(begin
|
||||
(checked-syntax->list (stx-car (stx-cdr stx)))
|
||||
(checked-syntax->list (stx-car (stx-cdr (stx-cdr stx))))
|
||||
(syntax/loc stx
|
||||
(exp (import . isig) (export . esig) (init-depend)))))
|
||||
(()
|
||||
(raise-stx-err "missing expression, import and export clauses"))
|
||||
((exp)
|
||||
(raise-stx-err "missing import and export clauses"))
|
||||
((exp (import . isig))
|
||||
(raise-stx-err "missing export clause"))
|
||||
((exp i e id extra . rest)
|
||||
(raise-stx-err "too many clauses" stx))
|
||||
((exp (import . isig) (export . esig) id)
|
||||
(raise-stx-err "init-depend clause must start with keyword \"init-depend\"" #'id))
|
||||
((exp (import . isig) e . rest)
|
||||
(raise-stx-err "export clause must start with keyword \"export\"" #'e))
|
||||
((exp i . rest)
|
||||
(raise-stx-err "import clause must start with keyword \"import\"" #'i))))
|
||||
|
||||
|
||||
|
||||
|
||||
;; check-link-line-syntax : syntax-object ->
|
||||
;; ensures that l matches ((x ...) u y ...)
|
||||
(define (check-link-line-syntax l)
|
||||
(unless (stx-pair? l)
|
||||
(raise-stx-err "bad linking line" l))
|
||||
(checked-syntax->list l)
|
||||
(syntax-case l ()
|
||||
(((x ...) u y ...) (void))
|
||||
(((x ...))
|
||||
(raise-stx-err "missing unit expression" l))
|
||||
((x . y)
|
||||
(begin
|
||||
(unless (stx-pair? #'x)
|
||||
(raise-stx-err "bad export list" #'x))
|
||||
(checked-syntax->list #'x)))))
|
||||
|
||||
;; check-compound-syntax : syntax-object -> syntax-object
|
||||
;; ensures that clauses has exactly one clause matching each of
|
||||
;; (import i ...), (export e ...), and (link i ...), in any order.
|
||||
;; returns #'((i ...) (e ...) (l ...))
|
||||
(define (check-compound-syntax c)
|
||||
(define clauses (checked-syntax->list c))
|
||||
(define im #f)
|
||||
(define ex #f)
|
||||
(define li #f)
|
||||
(for-each
|
||||
(lambda (clause)
|
||||
(syntax-case clause (import export link)
|
||||
((import i ...)
|
||||
(begin
|
||||
(when im
|
||||
(raise-stx-err "multiple import clauses" clause))
|
||||
(set! im (syntax->list #'(i ...)))))
|
||||
((export e ...)
|
||||
(begin
|
||||
(when ex
|
||||
(raise-stx-err "multiple export clauses" clause))
|
||||
(set! ex (syntax->list #'(e ...)))))
|
||||
((link l ...)
|
||||
(begin
|
||||
(when li
|
||||
(raise-stx-err "duplicate link clauses" clause))
|
||||
(set! li (syntax->list #'(l ...)))))
|
||||
((x . y)
|
||||
(begin
|
||||
(checked-syntax->list clause)
|
||||
(raise-stx-err "bad compound-unit clause keyword" #'x)))
|
||||
(_
|
||||
(raise-stx-err "expected import, export, or link clause" clause))))
|
||||
clauses)
|
||||
(unless im
|
||||
(raise-stx-err "missing import clause"))
|
||||
(unless ex
|
||||
(raise-stx-err "missing export clause"))
|
||||
(unless li
|
||||
(raise-stx-err "missing link clause" ))
|
||||
#`(#,im #,ex #,li))
|
||||
|
||||
;; check-def-syntax : syntax-object ->
|
||||
;; d must be a syntax-pair
|
||||
;; ensures that d matches (_ (x ...) e)
|
||||
(define (check-def-syntax d)
|
||||
(unless (syntax->list d)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad syntax (illegal use of `.')"
|
||||
d))
|
||||
(syntax-case d ()
|
||||
((_ params expr)
|
||||
(let ((l (syntax->list #'params)))
|
||||
(unless l
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"bad variable list"
|
||||
d #'params))
|
||||
(for-each
|
||||
(lambda (x)
|
||||
(unless (identifier? x)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"not an identifier"
|
||||
d x)))
|
||||
l)))
|
||||
(_
|
||||
(raise-syntax-error
|
||||
#f
|
||||
(format "bad syntax (has ~a parts after keyword)"
|
||||
(sub1 (length (syntax->list d))))
|
||||
d))))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
syntax/boundmap
|
||||
"unit-compiletime.ss"
|
||||
"unit-syntax.ss")
|
||||
mzlib/contract)
|
||||
scheme/contract/base)
|
||||
|
||||
(provide (for-syntax build-key
|
||||
check-duplicate-sigs
|
||||
|
|
|
|||
|
|
@ -1,36 +1,35 @@
|
|||
#lang scheme/base
|
||||
|
||||
(module unitidmap mzscheme
|
||||
;; Help Desk binding info:
|
||||
(define (binding binder bound stx)
|
||||
stx
|
||||
;; This 'bound-in-source is no longer needed
|
||||
#;
|
||||
(syntax-property
|
||||
stx
|
||||
'bound-in-source
|
||||
(cons binder (syntax-local-introduce bound))))
|
||||
|
||||
;; Help Desk binding info:
|
||||
(define (binding binder bound stx)
|
||||
stx
|
||||
;; This 'bound-in-source is no longer needed
|
||||
#;
|
||||
(syntax-property
|
||||
stx
|
||||
'bound-in-source
|
||||
(cons binder (syntax-local-introduce bound))))
|
||||
(define (make-id-mapper unbox-stx the-binder)
|
||||
(let ([set!-stx (datum->syntax unbox-stx 'set! #f)])
|
||||
(make-set!-transformer
|
||||
(lambda (sstx)
|
||||
(cond
|
||||
[(identifier? sstx)
|
||||
(binding the-binder sstx
|
||||
unbox-stx)]
|
||||
[(free-identifier=? set!-stx (car (syntax-e sstx)))
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"cannot set! imported or exported variables"
|
||||
sstx)]
|
||||
[else
|
||||
(binding
|
||||
the-binder (car (syntax-e sstx))
|
||||
(datum->syntax
|
||||
sstx
|
||||
(cons unbox-stx (cdr (syntax-e sstx)))
|
||||
sstx))])))))
|
||||
|
||||
(define (make-id-mapper unbox-stx the-binder)
|
||||
(let ([set!-stx (datum->syntax-object unbox-stx 'set! #f)])
|
||||
(make-set!-transformer
|
||||
(lambda (sstx)
|
||||
(cond
|
||||
[(identifier? sstx)
|
||||
(binding the-binder sstx
|
||||
unbox-stx)]
|
||||
[(module-identifier=? set!-stx (car (syntax-e sstx)))
|
||||
(raise-syntax-error
|
||||
'unit
|
||||
"cannot set! imported or exported variables"
|
||||
sstx)]
|
||||
[else
|
||||
(binding
|
||||
the-binder (car (syntax-e sstx))
|
||||
(datum->syntax-object
|
||||
sstx
|
||||
(cons unbox-stx (cdr (syntax-e sstx)))
|
||||
sstx))])))))
|
||||
|
||||
(provide make-id-mapper))
|
||||
(provide make-id-mapper)
|
||||
|
||||
|
|
|
|||
|
|
@ -1,26 +1,27 @@
|
|||
(module unit-exptime mzscheme
|
||||
(require "private/unit-syntax.ss"
|
||||
"private/unit-compiletime.ss")
|
||||
#lang scheme/base
|
||||
|
||||
(provide unit-static-signatures
|
||||
signature-members)
|
||||
(require "private/unit-syntax.ss"
|
||||
"private/unit-compiletime.ss")
|
||||
|
||||
(define (unit-static-signatures name err-stx)
|
||||
(parameterize ((error-syntax err-stx))
|
||||
(let ((ui (lookup-def-unit name)))
|
||||
(values (apply list (unit-info-import-sig-ids ui))
|
||||
(apply list (unit-info-export-sig-ids ui))))))
|
||||
(provide unit-static-signatures
|
||||
signature-members)
|
||||
|
||||
(define (signature-members name err-stx)
|
||||
(parameterize ((error-syntax err-stx))
|
||||
(let ([s (lookup-signature name)])
|
||||
(values
|
||||
;; extends:
|
||||
(and (pair? (cdr (siginfo-names (signature-siginfo s))))
|
||||
(cadr (siginfo-names (signature-siginfo s))))
|
||||
;; vars
|
||||
(apply list (signature-vars s))
|
||||
;; defined vars
|
||||
(apply list (apply append (map car (signature-val-defs s))))
|
||||
;; defined stxs
|
||||
(apply list (apply append (map car (signature-stx-defs s)))))))))
|
||||
(define (unit-static-signatures name err-stx)
|
||||
(parameterize ((error-syntax err-stx))
|
||||
(let ((ui (lookup-def-unit name)))
|
||||
(values (apply list (unit-info-import-sig-ids ui))
|
||||
(apply list (unit-info-export-sig-ids ui))))))
|
||||
|
||||
(define (signature-members name err-stx)
|
||||
(parameterize ((error-syntax err-stx))
|
||||
(let ([s (lookup-signature name)])
|
||||
(values
|
||||
;; extends:
|
||||
(and (pair? (cdr (siginfo-names (signature-siginfo s))))
|
||||
(cadr (siginfo-names (signature-siginfo s))))
|
||||
;; vars
|
||||
(apply list (signature-vars s))
|
||||
;; defined vars
|
||||
(apply list (apply append (map car (signature-val-defs s))))
|
||||
;; defined stxs
|
||||
(apply list (apply append (map car (signature-stx-defs s))))))))
|
||||
|
|
|
|||
File diff suppressed because it is too large
Load Diff
Loading…
Reference in New Issue
Block a user