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
|
#lang scheme/base
|
||||||
(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))
|
|
||||||
|
|
||||||
;; for named structures
|
(require (for-syntax "unit-syntax.ss" scheme/base))
|
||||||
(define insp (current-inspector))
|
(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)
|
(define-syntax define-syntax/err-param
|
||||||
;; Runtime representation of a unit
|
(syntax-rules ()
|
||||||
(define-struct unit (import-sigs export-sigs deps go))
|
((_ (name arg) body)
|
||||||
|
(define-syntax (name arg)
|
||||||
;; For units with inferred names, generate a struct that prints using the name:
|
(parameterize ((error-syntax arg))
|
||||||
(define (make-naming-constructor type name)
|
body)))))
|
||||||
(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 ->
|
;; initial value
|
||||||
;; ensure that u is a unit value
|
(define undefined (letrec ([x x]) x))
|
||||||
(define (check-unit u name)
|
|
||||||
(unless (unit? u)
|
;; for named structures
|
||||||
(raise
|
(define insp (current-inspector))
|
||||||
(make-exn:fail:contract
|
|
||||||
(format "~a: result of unit expression was not a unit: ~e" name u)
|
;; (make-unit (listof (cons symbol symbol)) (listof (cons symbol symbol)) (listof nat) thunk)
|
||||||
(current-continuation-marks)))))
|
;; Runtime representation of a unit
|
||||||
|
(define-struct unit (import-sigs export-sigs deps go))
|
||||||
;; check-helper : (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
|
||||||
; (vectorof (cons symbol (vectorof (cons symbol symbol)))))
|
;; For units with inferred names, generate a struct that prints using the name:
|
||||||
;; symbol symbol ->
|
(define (make-naming-constructor type name)
|
||||||
;; ensure that the unit's signatures match the expected signatures.
|
(let-values ([(struct: make- ? -accessor -mutator)
|
||||||
(define (check-helper sub-sig super-sig name import?)
|
(make-struct-type name type 0 0 #f null insp)])
|
||||||
(define t (make-hash-table 'equal))
|
make-))
|
||||||
(let loop ([i (sub1 (vector-length sub-sig))])
|
|
||||||
(when (>= i 0)
|
;; Make a unit value (call by the macro expansion of `unit')
|
||||||
(let ([v (cdr (vector-ref sub-sig i))])
|
(define (make-a-unit name num-imports exports deps go)
|
||||||
(let loop ([j (sub1 (vector-length v))])
|
((if name
|
||||||
(when (>= j 0)
|
(make-naming-constructor
|
||||||
(let ([vj (vector-ref v j)])
|
struct:unit
|
||||||
(hash-table-put! t vj
|
(string->symbol (format "unit:~a" name)))
|
||||||
(if (hash-table-get t vj #f)
|
make-unit)
|
||||||
'amb
|
num-imports exports deps go))
|
||||||
#t)))
|
|
||||||
(loop (sub1 j)))))
|
;; check-unit : X symbol ->
|
||||||
(loop (sub1 i))))
|
;; ensure that u is a unit value
|
||||||
(let loop ([i (sub1 (vector-length super-sig))])
|
(define (check-unit u name)
|
||||||
(when (>= i 0)
|
(unless (unit? u)
|
||||||
(let* ([v0 (vector-ref (cdr (vector-ref super-sig i)) 0)]
|
(raise
|
||||||
[r (hash-table-get t v0 #f)])
|
(make-exn:fail:contract
|
||||||
(when (or (eq? r 'amb) (not r))
|
(format "~a: result of unit expression was not a unit: ~e" name u)
|
||||||
(let ([tag (if (pair? v0) (car v0) #f)]
|
(current-continuation-marks)))))
|
||||||
[sub-name (car (vector-ref super-sig i))]
|
|
||||||
[err-str (if r
|
;; 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"
|
"supplies multiple times"
|
||||||
"does not supply")])
|
"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
|
(raise
|
||||||
(make-exn:fail:contract
|
(make-exn:fail:contract
|
||||||
(if (car dep)
|
(cond
|
||||||
(format "~a: initialization dependent signature ~a with tag ~a is supplied from a later unit with link ~a"
|
[(and import? tag)
|
||||||
name (car r) (car dep) (cdr r))
|
(format "~a: unit argument expects an import for tag ~a with signature ~a, which this usage context ~a"
|
||||||
(format "~a: untagged initialization dependent signature ~a is supplied from a later unit with link ~a"
|
name
|
||||||
name (car r) (cdr r)))
|
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))))))
|
(current-continuation-marks))))))
|
||||||
(unit-deps unit)))
|
(loop (sub1 i)))))
|
||||||
|
|
||||||
;; 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)))
|
|
||||||
|
|
||||||
|
;; 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
|
#lang scheme/base
|
||||||
(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))))
|
|
||||||
|
|
||||||
;; check-id: syntax-object -> identifier
|
(require syntax/stx)
|
||||||
(define (check-id id)
|
(require (for-template "unit-keywords.ss"))
|
||||||
(unless (identifier? id)
|
|
||||||
(raise-stx-err "not an identifier" id))
|
|
||||||
id)
|
|
||||||
|
|
||||||
;; checked-syntax->list : syntax-object -> (listof syntax-object)
|
(provide (all-defined-out))
|
||||||
(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 error-syntax (make-parameter #f))
|
||||||
(define (check-tagged check)
|
(define raise-stx-err
|
||||||
(λ (o)
|
(case-lambda
|
||||||
(syntax-case o (tag)
|
((msg) (raise-syntax-error #f msg (error-syntax)))
|
||||||
((tag . s)
|
((msg stx) (raise-syntax-error #f msg (error-syntax) stx))))
|
||||||
(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))))))
|
|
||||||
|
|
||||||
;; check-tagged-:-clause : syntax-object -> (cons identifier identifier)
|
;; check-id: syntax-object -> identifier
|
||||||
;; ensures that clause matches (a : b) or (a : (tag t b))
|
(define (check-id id)
|
||||||
(define (check-tagged-:-clause clause)
|
(unless (identifier? id)
|
||||||
(checked-syntax->list clause)
|
(raise-stx-err "not an identifier" id))
|
||||||
(syntax-case* clause (:) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
id)
|
||||||
((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-spec-syntax : syntax-object boolean (syntax-object -> boolean) ->
|
;; checked-syntax->list : syntax-object -> (listof syntax-object)
|
||||||
;; ensures that s matches spec.
|
(define (checked-syntax->list s)
|
||||||
;; tag-spec ::= spec
|
(define l (syntax->list s))
|
||||||
;; | (tag symbol spec)
|
(unless (or (stx-pair? s) (stx-null? s))
|
||||||
;; spec ::= prim-spec
|
(raise-stx-err "bad syntax (not a list)" s))
|
||||||
;; | (prefix identifier spec)
|
(unless l
|
||||||
;; | (rename spec (identifier identifier) ...)
|
(raise-stx-err "bad syntax (illegal use of `.')" s))
|
||||||
;; | (only spec identifier ...) only if import? is true
|
l)
|
||||||
;; | (except spec identifier ...) only if import? is true
|
|
||||||
(define (check-tagged-spec-syntax s import? prim-spec?)
|
;; check-tagged : (syntax-object -> X) -> syntax-object -> (cons (or symbol #f) X)
|
||||||
((check-tagged (λ (s) (check-spec-syntax s import? prim-spec?))) s))
|
(define (check-tagged check)
|
||||||
|
(λ (o)
|
||||||
(define (check-spec-syntax s import? prim-spec?)
|
(syntax-case o (tag)
|
||||||
(unless (prim-spec? s)
|
((tag . s)
|
||||||
(let ((ie (if import? 'import 'export)))
|
(syntax-case #'s ()
|
||||||
(unless (stx-pair? s)
|
((sym spec)
|
||||||
(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 ...)
|
|
||||||
(begin
|
(begin
|
||||||
(when im
|
(unless (symbol? (syntax-e #'sym))
|
||||||
(raise-stx-err "multiple import clauses" clause))
|
(raise-stx-err "tag must be a symbol" #'sym))
|
||||||
(set! im (syntax->list #'(i ...)))))
|
(cons (syntax-e #'sym) (check #'spec))))
|
||||||
((export e ...)
|
(_ (raise-stx-err "expected (tag <identifier> <syntax>)" #'s))))
|
||||||
(begin
|
(_
|
||||||
(when ex
|
(cons #f (check o))))))
|
||||||
(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 ->
|
;; check-tagged-:-clause : syntax-object -> (cons identifier identifier)
|
||||||
;; d must be a syntax-pair
|
;; ensures that clause matches (a : b) or (a : (tag t b))
|
||||||
;; ensures that d matches (_ (x ...) e)
|
(define (check-tagged-:-clause clause)
|
||||||
(define (check-def-syntax d)
|
(checked-syntax->list clause)
|
||||||
(unless (syntax->list d)
|
(syntax-case* clause (:) (lambda (x y) (eq? (syntax-e x) (syntax-e y)))
|
||||||
(raise-syntax-error
|
((a : b)
|
||||||
#f
|
(identifier? #'a)
|
||||||
"bad syntax (illegal use of `.')"
|
(let ([p ((check-tagged check-id) #'b)])
|
||||||
d))
|
(cons (car p) (cons #'a (cdr p)))))
|
||||||
(syntax-case d ()
|
(_ (raise-stx-err
|
||||||
((_ params expr)
|
"expected syntax matching (<identifier> : <identifier>) or (<identifier> : (tag <identifier> <identifier>))"
|
||||||
(let ((l (syntax->list #'params)))
|
clause))))
|
||||||
(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))))
|
|
||||||
)
|
|
||||||
|
|
||||||
;(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
|
syntax/boundmap
|
||||||
"unit-compiletime.ss"
|
"unit-compiletime.ss"
|
||||||
"unit-syntax.ss")
|
"unit-syntax.ss")
|
||||||
mzlib/contract)
|
scheme/contract/base)
|
||||||
|
|
||||||
(provide (for-syntax build-key
|
(provide (for-syntax build-key
|
||||||
check-duplicate-sigs
|
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 (make-id-mapper unbox-stx the-binder)
|
||||||
(define (binding binder bound stx)
|
(let ([set!-stx (datum->syntax unbox-stx 'set! #f)])
|
||||||
stx
|
(make-set!-transformer
|
||||||
;; This 'bound-in-source is no longer needed
|
(lambda (sstx)
|
||||||
#;
|
(cond
|
||||||
(syntax-property
|
[(identifier? sstx)
|
||||||
stx
|
(binding the-binder sstx
|
||||||
'bound-in-source
|
unbox-stx)]
|
||||||
(cons binder (syntax-local-introduce bound))))
|
[(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)
|
(provide make-id-mapper)
|
||||||
(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))
|
|
||||||
|
|
||||||
|
|
|
||||||
|
|
@ -1,26 +1,27 @@
|
||||||
(module unit-exptime mzscheme
|
#lang scheme/base
|
||||||
(require "private/unit-syntax.ss"
|
|
||||||
"private/unit-compiletime.ss")
|
|
||||||
|
|
||||||
(provide unit-static-signatures
|
(require "private/unit-syntax.ss"
|
||||||
signature-members)
|
"private/unit-compiletime.ss")
|
||||||
|
|
||||||
(define (unit-static-signatures name err-stx)
|
(provide unit-static-signatures
|
||||||
(parameterize ((error-syntax err-stx))
|
signature-members)
|
||||||
(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)
|
(define (unit-static-signatures name err-stx)
|
||||||
(parameterize ((error-syntax err-stx))
|
(parameterize ((error-syntax err-stx))
|
||||||
(let ([s (lookup-signature name)])
|
(let ((ui (lookup-def-unit name)))
|
||||||
(values
|
(values (apply list (unit-info-import-sig-ids ui))
|
||||||
;; extends:
|
(apply list (unit-info-export-sig-ids ui))))))
|
||||||
(and (pair? (cdr (siginfo-names (signature-siginfo s))))
|
|
||||||
(cadr (siginfo-names (signature-siginfo s))))
|
(define (signature-members name err-stx)
|
||||||
;; vars
|
(parameterize ((error-syntax err-stx))
|
||||||
(apply list (signature-vars s))
|
(let ([s (lookup-signature name)])
|
||||||
;; defined vars
|
(values
|
||||||
(apply list (apply append (map car (signature-val-defs s))))
|
;; extends:
|
||||||
;; defined stxs
|
(and (pair? (cdr (siginfo-names (signature-siginfo s))))
|
||||||
(apply list (apply append (map car (signature-stx-defs 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