387c8b210f
* Fix contracts for signatures and units so that references to other signature members work appropriately. * Add text about signature and unit contracts to the Guide. svn: r13562
148 lines
5.1 KiB
Scheme
148 lines
5.1 KiB
Scheme
#lang scheme/base
|
|
|
|
(require (for-syntax scheme/base
|
|
syntax/boundmap
|
|
"unit-compiletime.ss"
|
|
"unit-syntax.ss")
|
|
mzlib/contract)
|
|
|
|
(provide (for-syntax build-key
|
|
check-duplicate-sigs
|
|
check-unit-ie-sigs
|
|
iota
|
|
process-unit-import
|
|
process-unit-export
|
|
tagged-info->keys
|
|
id->contract-src-info
|
|
get-member-bindings))
|
|
|
|
(provide equal-hash-table
|
|
unit-export)
|
|
|
|
(define-for-syntax (iota n)
|
|
(let loop ((n n)
|
|
(acc null))
|
|
(cond
|
|
((= n 0) acc)
|
|
(else (loop (sub1 n) (cons (sub1 n) acc))))))
|
|
|
|
;; id->contract-src-info : identifier -> syntax
|
|
;; constructs the last argument to the contract, given an identifier
|
|
(define-for-syntax (id->contract-src-info id)
|
|
#`(list (make-srcloc (quote-syntax #,id)
|
|
#,(syntax-line id)
|
|
#,(syntax-column id)
|
|
#,(syntax-position id)
|
|
#,(syntax-span id))
|
|
#,(format "~s" (syntax->datum id))))
|
|
|
|
(define-syntax-rule (equal-hash-table [k v] ...)
|
|
(make-immutable-hash (list (cons k v) ...)))
|
|
|
|
(define-for-syntax (get-member-bindings member-table sig blame)
|
|
(for/list ([i (in-list (map car (car sig)))]
|
|
[c (in-list (cadddr sig))])
|
|
(let ([add-ctc
|
|
(λ (v stx)
|
|
(if c
|
|
#`(let ([v/c ((car #,stx))])
|
|
(contract (let ([#,v #,c]) #,v)
|
|
(car v/c) (cdr v/c) #,blame
|
|
#,(id->contract-src-info v)))
|
|
#`((car #,stx))))])
|
|
#`[#,i
|
|
(make-set!-transformer
|
|
(λ (stx)
|
|
(syntax-case stx (set!)
|
|
[x
|
|
(identifier? #'x)
|
|
#'#,(add-ctc i (bound-identifier-mapping-get
|
|
member-table
|
|
i))]
|
|
[(x . y)
|
|
#'(#,(add-ctc i (bound-identifier-mapping-get
|
|
member-table
|
|
i)) . y)])))])))
|
|
|
|
(define-syntax (unit-export stx)
|
|
(syntax-case stx ()
|
|
((_ ((esig ...) elocs) ...)
|
|
(with-syntax ((((kv ...) ...)
|
|
(map
|
|
(lambda (esigs eloc)
|
|
(map
|
|
(lambda (esig) #`(#,esig #,eloc))
|
|
(syntax->list esigs)))
|
|
(syntax->list #'((esig ...) ...))
|
|
(syntax->list #'(elocs ...)))))
|
|
#'(equal-hash-table kv ... ...)))))
|
|
|
|
;; check-duplicate-sigs : (listof (cons symbol siginfo)) (listof syntax-object)
|
|
;; (listof (cons symbol siginfo)) (listof syntax-object) ->
|
|
(define-for-syntax (check-duplicate-sigs tagged-siginfos sources tagged-deps dsources)
|
|
(define import-idx (make-hash))
|
|
(for-each
|
|
(lambda (tinfo s)
|
|
(define key (cons (car tinfo)
|
|
(car (siginfo-ctime-ids (cdr tinfo)))))
|
|
(when (hash-ref import-idx key #f)
|
|
(raise-stx-err "duplicate import signature" s))
|
|
(hash-set! import-idx key #t))
|
|
tagged-siginfos
|
|
sources)
|
|
(for-each
|
|
(lambda (dep s)
|
|
(unless (hash-ref import-idx
|
|
(cons (car dep)
|
|
(car (siginfo-ctime-ids (cdr dep))))
|
|
#f)
|
|
(raise-stx-err "initialization dependency on unknown import" s)))
|
|
tagged-deps
|
|
dsources))
|
|
|
|
(define-for-syntax (check-unit-ie-sigs import-sigs export-sigs)
|
|
(let ([dup (check-duplicate-identifier
|
|
(apply append (map sig-int-names import-sigs)))])
|
|
(when dup
|
|
(raise-stx-err
|
|
(format "~a is imported by multiple signatures" (syntax-e dup)))))
|
|
|
|
(let ([dup (check-duplicate-identifier
|
|
(apply append (map sig-int-names export-sigs)))])
|
|
(when dup
|
|
(raise-stx-err (format "~a is exported by multiple signatures"
|
|
(syntax-e dup)))))
|
|
|
|
(let ([dup (check-duplicate-identifier
|
|
(append
|
|
(apply append (map sig-int-names import-sigs))
|
|
(apply append (map sig-int-names export-sigs))))])
|
|
(when dup
|
|
(raise-stx-err (format "import ~a is exported" (syntax-e dup))))))
|
|
|
|
(define-for-syntax (process-unit-import/export process)
|
|
(lambda (s)
|
|
(define x1 (syntax->list s))
|
|
(define x2 (map process x1))
|
|
(values x1 x2 (map car x2) (map cadr x2) (map caddr x2))))
|
|
|
|
(define-for-syntax process-unit-import
|
|
(process-unit-import/export process-tagged-import))
|
|
|
|
(define-for-syntax process-unit-export
|
|
(process-unit-import/export process-tagged-export))
|
|
|
|
;; build-key : (or symbol #f) identifier -> syntax-object
|
|
(define-for-syntax (build-key tag i)
|
|
(if tag
|
|
#`(cons '#,tag #,i)
|
|
i))
|
|
|
|
;; tagged-info->keys : (cons (or symbol #f) siginfo) -> (listof syntax-object)
|
|
(define-for-syntax (tagged-info->keys tagged-info)
|
|
(define tag (car tagged-info))
|
|
(map (lambda (rid)
|
|
(build-key tag (syntax-local-introduce rid)))
|
|
(siginfo-rtime-ids (cdr tagged-info))))
|
|
|