137 lines
5.6 KiB
Scheme
137 lines
5.6 KiB
Scheme
(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))
|
|
|
|
;; 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-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
|
|
"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)))
|
|
(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)))
|
|
|
|
|