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

racket/generic: fix generated contract name

Browse Source
This commit is contained in:
Asumu Takikawa 2012-06-25 21:41:50 -04:00
parent 552d6de953
commit 46e66978ee
1 changed files with 8 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/racket/private/generic.rkt
View File

@ -168,7 +168,7 @@
(syntax-case stx () (syntax-case stx ()
[(_ name name? accessor (generic generic-idx) ...) [(_ name name? accessor (generic generic-idx) ...)
(with-syntax ([name/c (format-id #'name "~a/c" #'name)]) (with-syntax ([name/c (format-id #'name "~a/c" #'name)])
#'(define-syntax (name/c stx) #`(define-syntax (name/c stx)
(syntax-case stx () (syntax-case stx ()
[(_ [method-id ctc] (... ...)) [(_ [method-id ctc] (... ...))
(andmap (λ (id) (and (identifier? id) (andmap (λ (id) (and (identifier? id)
@ -177,6 +177,7 @@
(member (syntax-e id) (list 'generic ...)))) (member (syntax-e id) (list 'generic ...))))
(syntax->list #'(method-id (... ...)))) (syntax->list #'(method-id (... ...))))
#'(make-generic-instance/c #'(make-generic-instance/c
(quote #,(syntax-e #'name/c))
name? name?
accessor accessor
(list 'method-id (... ...)) (list 'method-id (... ...))
@ -185,7 +186,7 @@
(list (cons 'generic generic-idx) ...)))])))])) (list (cons 'generic generic-idx) ...)))])))]))
;; make a generic instance contract ;; make a generic instance contract
(define (make-generic-instance/c name? accessor ids ctc-args method-map) (define (make-generic-instance/c name name? accessor ids ctc-args method-map)
(define ctcs (coerce-contracts 'generic-instance/c ctc-args)) (define ctcs (coerce-contracts 'generic-instance/c ctc-args))
;; map method table indices to ids & projections ;; map method table indices to ids & projections
(define id+ctc-map (define id+ctc-map
@ -194,10 +195,10 @@
(cons id (contract-projection ctc))))) (cons id (contract-projection ctc)))))
(cond [(andmap chaperone-contract? ctcs) (cond [(andmap chaperone-contract? ctcs)
(chaperone-generic-instance/c (chaperone-generic-instance/c
name? ids ctcs accessor id+ctc-map method-map)] name name? ids ctcs accessor id+ctc-map method-map)]
[else [else
(impersonator-generic-instance/c (impersonator-generic-instance/c
name? ids ctcs accessor id+ctc-map method-map)])) name name? ids ctcs accessor id+ctc-map method-map)]))
(define (generic-instance/c-name ctc) (define (generic-instance/c-name ctc)
(define method-names (define method-names
@ -205,7 +206,7 @@
(base-generic-instance/c-ids ctc) (base-generic-instance/c-ids ctc)
(base-generic-instance/c-ctcs ctc))) (base-generic-instance/c-ctcs ctc)))
(apply build-compound-type-name (apply build-compound-type-name
(cons 'generic-instance/c method-names))) (cons (base-generic-instance/c-name ctc) method-names)))
;; redirect for use with chaperone-vector ;; redirect for use with chaperone-vector
(define ((method-table-redirect ctc blame) vec idx val) (define ((method-table-redirect ctc blame) vec idx val)
@ -252,6 +253,7 @@
(vector-ref method-table (hash-ref method-map id))))] (vector-ref method-table (hash-ref method-map id))))]
[else #f])) [else #f]))
;; name - for building ctc name
;; name? - for first-order checks ;; name? - for first-order checks
;; ids - for method names (used to build the ctc name) ;; ids - for method names (used to build the ctc name)
;; ctcs - for the contract name ;; ctcs - for the contract name
@ -259,7 +261,7 @@
;; id+ctc-map - for chaperoning the method table vector ;; id+ctc-map - for chaperoning the method table vector
;; method-map - for first-order checks ;; method-map - for first-order checks
(struct base-generic-instance/c (struct base-generic-instance/c
(name? ids ctcs accessor id+ctc-map method-map)) (name name? ids ctcs accessor id+ctc-map method-map))
(struct chaperone-generic-instance/c base-generic-instance/c () (struct chaperone-generic-instance/c base-generic-instance/c ()
#:property prop:chaperone-contract #:property prop:chaperone-contract