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

Allow specifying arbitary expressions in a signature declaration.

Browse Source 
Fixes PR 11282
This commit is contained in:
Mike Sperber 2010-10-08 13:12:18 +02:00
parent 1e44fc8e43
commit 38cf78e213
2 changed files with 57 additions and 58 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
collects/deinprogramm/signature/module-begin.rkt
View File

@ -3,10 +3,11 @@
(provide module-begin)
(require deinprogramm/define-record-procedures
deinprogramm/signature/signature
deinprogramm/signature/signature-syntax)
(require (for-syntax scheme/base)
(for-syntax mzlib/list)
(for-syntax racket/list)
(for-syntax syntax/boundmap)
(for-syntax syntax/kerncase))
@ -40,32 +41,31 @@
(lambda (lostx)
(let* ((table (make-bound-identifier-mapping))
(non-signatures
(filter (lambda (maybe)
(syntax-case maybe (:)
((: ?id ?sig)
(begin
(when (not (identifier? #'?id))
(raise-syntax-error #f
"Nach dem : sollte ein Bezeichner stehen; da steht was anderes."
#'?id))
(cond
((bound-identifier-mapping-get table #'?id (lambda () #f))
=> (lambda (old-sig-stx)
(unless (equal? (syntax->datum old-sig-stx)
(syntax->datum #'?sig))
(raise-syntax-error #f
"Zweite Signaturdeklaration für denselben Namen."
maybe))))
(else
(bound-identifier-mapping-put! table #'?id #'?sig)))
#f))
((: ?id)
(raise-syntax-error #f "Bei dieser Signaturdeklaration fehlt die Signatur" maybe))
((: ?id ?sig ?stuff0 ?stuff1 ...)
(raise-syntax-error #f "In der :-Form werden ein Name und eine Signatur erwartet; da steht noch mehr"
(syntax/loc #'?stuff0
(?stuff0 ?stuff1 ...))))
(_ #t)))
(filter-map (lambda (maybe)
(syntax-case maybe (:)
((: ?exp ?sig)
(not (identifier? #'?exp))
#'(apply-signature/blame (signature ?sig) ?exp))
((: ?id ?sig)
(begin
(cond
((bound-identifier-mapping-get table #'?id (lambda () #f))
=> (lambda (old-sig-stx)
(unless (equal? (syntax->datum old-sig-stx)
(syntax->datum #'?sig))
(raise-syntax-error #f
"Zweite Signaturdeklaration für denselben Namen."
maybe))))
(else
(bound-identifier-mapping-put! table #'?id #'?sig)))
#f))
((: ?id)
(raise-syntax-error #f "Bei dieser Signaturdeklaration fehlt die Signatur" maybe))
((: ?id ?sig ?stuff0 ?stuff1 ...)
(raise-syntax-error #f "In der :-Form werden ein Name und eine Signatur erwartet; da steht noch mehr"
(syntax/loc #'?stuff0
(?stuff0 ?stuff1 ...))))
(_ maybe)))
lostx)))
(values table non-signatures))))

61
collects/lang/private/teach-module-begin.rkt
View File

@ -6,10 +6,11 @@
(module-begin intermediate-module-begin)
(module-begin advanced-module-begin)))
(require lang/private/signature-syntax)
(require deinprogramm/signature/signature
lang/private/signature-syntax)
(require (for-syntax scheme/base)
(for-syntax mzlib/list)
(for-syntax racket/list)
(for-syntax syntax/boundmap)
(for-syntax syntax/kerncase))
@ -45,35 +46,33 @@
(lambda (lostx)
(let* ((table (make-bound-identifier-mapping))
(non-signatures
(filter (lambda (maybe)
(syntax-case maybe (:)
((: ?id ?sig)
(begin
(when (not (identifier? #'?id))
(raise-syntax-error #f
"Something that's not an identifier after the :"
#'?id))
(let ((real-id (first-order->higher-order #'?id)))
(cond
((bound-identifier-mapping-get table real-id (lambda () #f))
=> (lambda (old-sig-stx)
(unless (equal? (syntax->datum old-sig-stx)
(syntax->datum #'?sig))
(raise-syntax-error #f
"Second signature declaration for the same name."
maybe))))
(else
(bound-identifier-mapping-put! table real-id #'?sig)))
#f)))
((: ?id)
(raise-syntax-error #f "Signature declaration is missing a signature." maybe))
((: ?id ?sig ?stuff0 ?stuff1 ...)
(raise-syntax-error #f "The : form expects a name and a signature; there is more."
(syntax/loc #'?stuff0
(?stuff0 ?stuff1 ...))))
(_ #t)))
lostx)))
(filter-map (lambda (maybe)
(syntax-case maybe (:)
((: ?exp ?sig)
(not (identifier? #'?exp))
#'(apply-signature/blame (signature ?sig) ?exp))
((: ?id ?sig)
(begin
(let ((real-id (first-order->higher-order #'?id)))
(cond
((bound-identifier-mapping-get table real-id (lambda () #f))
=> (lambda (old-sig-stx)
(unless (equal? (syntax->datum old-sig-stx)
(syntax->datum #'?sig))
(raise-syntax-error #f
"Second signature declaration for the same name."
maybe))))
(else
(bound-identifier-mapping-put! table real-id #'?sig)))
#f)))
((: ?id)
(raise-syntax-error #f "Signature declaration is missing a signature." maybe))
((: ?id ?sig ?stuff0 ?stuff1 ...)
(raise-syntax-error #f "The : form expects a name and a signature; there is more."
(syntax/loc #'?stuff0
(?stuff0 ?stuff1 ...))))
(_ maybe)))
lostx)))
(values table non-signatures))))
(define local-expand-stop-list