83 lines
2.3 KiB
Racket
83 lines
2.3 KiB
Racket
(module teachhelp mzscheme
|
|
(require "firstorder.rkt"
|
|
"rewrite-error-message.rkt"
|
|
stepper/private/shared)
|
|
|
|
(require-for-syntax stepper/private/shared)
|
|
|
|
(provide make-undefined-check
|
|
make-first-order-function)
|
|
|
|
(define (make-undefined-check check-proc tmp-id)
|
|
(let ([set!-stx (datum->syntax-object check-proc 'set!)])
|
|
(make-set!-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(set! id expr)
|
|
(module-identifier=? (syntax set!) set!-stx)
|
|
(with-syntax ([tmp-id tmp-id])
|
|
(syntax/loc stx (set! tmp-id expr)))]
|
|
[(id . args)
|
|
(datum->syntax-object
|
|
check-proc
|
|
(cons (stepper-syntax-property
|
|
(datum->syntax-object
|
|
check-proc
|
|
(list check-proc
|
|
(list 'quote (syntax id))
|
|
tmp-id))
|
|
'stepper-skipto
|
|
(append skipto/cdr
|
|
skipto/third))
|
|
(syntax args))
|
|
stx)]
|
|
[id
|
|
(stepper-syntax-property
|
|
(datum->syntax-object
|
|
check-proc
|
|
(list check-proc
|
|
(list 'quote (syntax id))
|
|
tmp-id)
|
|
stx)
|
|
'stepper-skipto
|
|
(append skipto/cdr
|
|
skipto/third))])))))
|
|
#;
|
|
(define (appropriate-use what)
|
|
(case what
|
|
[(constructor)
|
|
"called with values for the structure fields"]
|
|
[(selector)
|
|
"applied to a structure to get the field value"]
|
|
[(predicate procedure)
|
|
"applied to arguments"]))
|
|
|
|
(define (make-first-order-function what arity orig-id app)
|
|
(make-set!-transformer
|
|
(make-first-order
|
|
(lambda (stx)
|
|
(syntax-case stx (set!)
|
|
[(set! . _) (raise-syntax-error
|
|
#f stx #f
|
|
"internal error: assignment to first-order function")]
|
|
[id
|
|
(identifier? #'id)
|
|
(raise-syntax-error
|
|
#f
|
|
(format "expected a function call, but there is no open parenthesis before this function")
|
|
stx
|
|
#f)]
|
|
[(id . rest)
|
|
(let ([found (length (syntax->list #'rest))])
|
|
(unless (= found arity)
|
|
(raise-syntax-error
|
|
#f
|
|
(argcount-error-message arity found)
|
|
stx
|
|
#f))
|
|
(datum->syntax-object
|
|
app
|
|
(list* app (datum->syntax-object orig-id (syntax-e orig-id) #'id #'id) #'rest)
|
|
stx stx))]))
|
|
(syntax-local-introduce orig-id)))))
|