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

fix struct/c for the case that the selectors are not available at the use site.

Browse Source 
closes PR 12854
This commit is contained in:
Robby Findler 2012-06-20 11:22:12 -05:00
parent da652c4774
commit f38024d4ed
2 changed files with 33 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

12
collects/racket/contract/private/struct-dc.rkt
View File

@ -1,7 +1,7 @@
#lang racket/base
(provide (rename-out [-struct/dc struct/dc])
struct/c)
(provide (rename-out [-struct/dc struct/dc]
[-struct/c struct/c]))
(require (for-syntax racket/base
racket/list
@ -958,13 +958,13 @@
'(expected "a struct of type ~a")
what))
(define-syntax (struct/c stx)
(define-syntax (-struct/c stx)
(syntax-case stx ()
[(_ . args)
(with-syntax ([x (syntax/loc stx (do-struct/c . args))])
(with-syntax ([x (syntax/loc stx (struct/c . args))])
(syntax/loc stx (#%expression x)))]))
(define-syntax (do-struct/c stx)
(define-syntax (struct/c stx)
(syntax-case stx ()
[(_ struct-name args ...)
(and (identifier? (syntax struct-name))
@ -993,7 +993,7 @@
(define strip-reg (regexp (format "^~a-" (regexp-quote (symbol->string (syntax-e #'struct-name))))))
(define (selector-id->field sel)
(datum->syntax #'struct-name
(datum->syntax sel
(string->symbol (regexp-replace strip-reg (symbol->string (syntax-e sel)) ""))))
(do-struct/dc

27
collects/tests/racket/contract-test.rktl
View File

@ -14004,6 +14004,33 @@ so that propagation occurs.
(provide (contract-out garbage))
(λ)))
#rx"contract-out")
(test/pos-blame
'contract-struct/c-1
'(begin
(eval '(module contract-struct/c-1a racket/base
(struct s (field))
(provide s)))
(eval '(module contract-struct/c-1b racket/base
(require 'contract-struct/c-1a racket/contract)
(contract (struct/c s boolean?)
(s 1)
'pos 'neg)))
(eval '(require 'contract-struct/c-1b))))
(test/spec-passed
'contract-struct/c-2
'(begin
(eval '(module contract-struct/c-2a racket/base
(struct s (field))
(provide s)))
(eval '(module contract-struct/c-2b racket/base
(require 'contract-struct/c-2a racket/contract)
(contract (struct/c s any/c)
(s 1)
'pos 'neg)))
(eval '(require 'contract-struct/c-2b))))
;
;