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

fix define-primitive' and porvide-primitive' to check binding

Browse Source 
Closes PR 12031
This commit is contained in:
Matthew Flatt 2011-07-09 08:52:29 -06:00
parent 8271f7b182
commit 584a96a4e0
2 changed files with 41 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

54
collects/lang/prim.rkt
View File

@ -23,31 +23,35 @@
(with-syntax ([impl #'(let ([name (lambda argv
(apply implementation argv))])
name)])
#'(define-syntax name
(fo:make-first-order
(lambda (stx)
(with-syntax ([tagged-impl (stepper-syntax-property
(stepper-syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
'stepper-prim-name
(quote-syntax name))])
(syntax-case stx ()
[(_ . body)
;; HACK: we disable all checks if #%app is not beginner-app
(not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
(syntax/loc stx (tagged-impl . body))]
[_
;; HACK: see above
(not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
(syntax/loc stx tagged-impl)]
[(id . args)
(syntax/loc stx (#%plain-app tagged-impl . args))]
[_
(raise-syntax-error
#f
"expected a function call, but there is no open parenthesis before this function"
stx)])))
((syntax-local-certifier #t)
#'impl))))]))
#'(begin
;; Make sure that `implementation' is bound:
(define-values () (begin implementation (values)))
;; Bind `name':
(define-syntax name
(fo:make-first-order
(lambda (stx)
(with-syntax ([tagged-impl (stepper-syntax-property
(stepper-syntax-property (quote-syntax impl) 'stepper-skip-completely #t)
'stepper-prim-name
(quote-syntax name))])
(syntax-case stx ()
[(_ . body)
;; HACK: we disable all checks if #%app is not beginner-app
(not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
(syntax/loc stx (tagged-impl . body))]
[_
;; HACK: see above
(not (module-identifier=? #'beginner-app (datum->syntax-object stx '#%app)))
(syntax/loc stx tagged-impl)]
[(id . args)
(syntax/loc stx (#%plain-app tagged-impl . args))]
[_
(raise-syntax-error
#f
"expected a function call, but there is no open parenthesis before this function"
stx)])))
((syntax-local-certifier #t)
#'impl)))))]))
(define-syntax (define-higher-order-primitive stx)
(define (is-proc-arg? arg)

12
collects/tests/htdp-lang/prim.rkt Normal file
View File

@ -0,0 +1,12 @@
#lang racket/base
(define (check-bad form)
(with-handlers ([exn:fail? (lambda (exn)
(define msg (exn-message exn))
(unless (regexp-match #rx"unbound identifier.*y$" msg)
(raise exn)))])
(expand form)
(error 'check-bad "failed: ~v" form)))
(check-bad `(,#'module m racket/base (require lang/prim) (define-primitive x y)))
(check-bad `(,#'module m racket/base (require lang/prim) (provide-primitive y)))