suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

I'd like a better way of handling export contracts (some of the work that

Browse Source 
should be doable at compile time is being done at run time), but at least
this works for now and gives us a chance to play around with it.

svn: r12763
This commit is contained in:
Stevie Strickland 2008-12-10 17:19:39 +00:00
parent 90ad3f9221
commit 56854a84bd
2 changed files with 27 additions and 12 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/private/unit-compiletime.ss
View File

@ -46,7 +46,7 @@
;; (make-var-info bool bool identifier) ;; (make-var-info bool bool identifier)
(define-struct var-info (syntax? [exported? #:mutable] id)) (define-struct var-info (syntax? [exported? #:mutable] id [ctc #:mutable]))
(define-syntax define-struct/proc (define-syntax define-struct/proc
(syntax-rules () (syntax-rules ()

37
collects/mzlib/unit.ss
View File

@ -454,8 +454,8 @@
(define-for-syntax (make-import-unboxing var loc ctc name) (define-for-syntax (make-import-unboxing var loc ctc name)
(if ctc (if ctc
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (let ([#,var (unbox #,loc)]) (quote-syntax (let ([#,var (contract #,ctc (unbox #,loc) 'cant-happen '#,name)])
(contract #,ctc #,var 'cant-happen '#,name)))) #,var)))
(quasisyntax/loc (error-syntax) (quasisyntax/loc (error-syntax)
(quote-syntax (unbox #,loc))))) (quote-syntax (unbox #,loc)))))
@ -505,6 +505,8 @@
(map (lambda (x) (generate-temporaries (car x))) import-sigs)] (map (lambda (x) (generate-temporaries (car x))) import-sigs)]
[((eloc ...) ...) [((eloc ...) ...)
(map (lambda (x) (generate-temporaries (car x))) export-sigs)] (map (lambda (x) (generate-temporaries (car x))) export-sigs)]
[((ectc ...) ...)
(map cadddr export-sigs)]
[((import-key import-super-keys ...) ...) [((import-key import-super-keys ...) ...)
(map tagged-info->keys import-tagged-infos)] (map tagged-info->keys import-tagged-infos)]
[((export-key ...) ...) [((export-key ...) ...)
@ -559,6 +561,7 @@
(int-ivar ... ...) (int-ivar ... ...)
(int-evar ... ...) (int-evar ... ...)
(eloc ... ...) (eloc ... ...)
(ectc ... ...)
. body))))) . body)))))
(unit-export ((export-key ...) (vector-immutable eloc ...)) ...)))))) (unit-export ((export-key ...) (vector-immutable eloc ...)) ...))))))
import-tagged-sigids import-tagged-sigids
@ -574,7 +577,7 @@
(define-syntax (unit-body stx) (define-syntax (unit-body stx)
(syntax-case stx () (syntax-case stx ()
((_ err-stx ivars evars elocs body ...) ((_ err-stx ivars evars elocs ectcs body ...)
(parameterize ((error-syntax #'err-stx)) (parameterize ((error-syntax #'err-stx))
(let* ([expand-context (generate-expand-context)] (let* ([expand-context (generate-expand-context)]
[def-ctx (syntax-local-make-definition-context)] [def-ctx (syntax-local-make-definition-context)]
@ -646,7 +649,8 @@
table id table id
(make-var-info (module-identifier=? #'dv (quote-syntax define-syntaxes)) (make-var-info (module-identifier=? #'dv (quote-syntax define-syntaxes))
#f #f
id))) id
#'#f)))
(syntax->list #'(id ...)))] (syntax->list #'(id ...)))]
[_ (void)]))) [_ (void)])))
[_ (void)])) [_ (void)]))
@ -657,7 +661,7 @@
;; Mark exported names and ;; Mark exported names and
;; check that all exported names are defined (as var): ;; check that all exported names are defined (as var):
(for-each (for-each
(lambda (name loc) (lambda (name loc ctc)
(let ([v (bound-identifier-mapping-get defined-names-table (let ([v (bound-identifier-mapping-get defined-names-table
name name
(lambda () #f))]) (lambda () #f))])
@ -665,9 +669,11 @@
(raise-stx-err (format "undefined export ~a" (syntax-e name)))) (raise-stx-err (format "undefined export ~a" (syntax-e name))))
(when (var-info-syntax? v) (when (var-info-syntax? v)
(raise-stx-err "cannot export syntax from a unit" name)) (raise-stx-err "cannot export syntax from a unit" name))
(set-var-info-exported?! v loc))) (set-var-info-exported?! v loc)
(set-var-info-ctc! v ctc)))
local-evars local-evars
(syntax->list #'elocs)) (syntax->list #'elocs)
(syntax->list #'ectcs))
;; Check that none of the imports are defined ;; Check that none of the imports are defined
(for-each (for-each
@ -704,8 +710,15 @@
(let ([ids (syntax->list #'ids)] (let ([ids (syntax->list #'ids)]
[do-one [do-one
(lambda (id tmp name) (lambda (id tmp name)
(let ([export-loc (let ([unit-name
(syntax-local-infer-name (error-syntax))]
[export-loc
(var-info-exported? (var-info-exported?
(bound-identifier-mapping-get
defined-names-table
id))]
[ctc
(var-info-ctc
(bound-identifier-mapping-get (bound-identifier-mapping-get
defined-names-table defined-names-table
id))]) id))])
@ -715,7 +728,9 @@
(quasisyntax/loc defn-or-expr (quasisyntax/loc defn-or-expr
(set-box! #,export-loc (set-box! #,export-loc
#,(if name #,(if name
#`(let ([#,name #,tmp]) #`(let ([#,name (if #,ctc
(contract #,ctc #,tmp '#,unit-name 'cant-happen)
#,tmp)])
#,name) #,name)
tmp)))) tmp))))
(else (else
@ -1224,8 +1239,8 @@
(map (map
(lambda (i iv c) (lambda (i iv c)
(if c (if c
#`(let ([#,iv (unbox (vector-ref #,ov #,i))]) #`(let ([#,iv (contract #,c (unbox (vector-ref #,ov #,i)) 'cant-happen (#%variable-reference))])
(contract #,c #,iv 'cant-happen (#%variable-reference))) #,iv)
#`(unbox (vector-ref #,ov #,i)))) #`(unbox (vector-ref #,ov #,i))))
(iota (length (car os))) (iota (length (car os)))
(map car (car os)) (map car (car os))