some Racket-y (102); arrows and renaming for define-struct in teaching languages; need to find and run lang tests
This commit is contained in:
Matthias Felleisen
parent
a57734d7ae
commit
e430753b6c
|
|
@ -32,7 +32,7 @@
|
|||
;; reporting. As always, avoid using `local-expand' if there's no
|
||||
;; error.
|
||||
|
||||
(module teach mzscheme
|
||||
#lang mzscheme
|
||||
(require mzlib/etc
|
||||
mzlib/list
|
||||
mzlib/math
|
||||
|
|
@ -74,6 +74,15 @@
|
|||
stepper/private/syntax-property
|
||||
test-engine/racket-tests)
|
||||
|
||||
(define-for-syntax EXPECTED-HEADER
|
||||
"expected a variable name, or a function name and its variables (in parentheses), but found ~a")
|
||||
|
||||
(define-for-syntax EXPECTED-MATCH-PATTERN
|
||||
"expected a pattern--answer clause after the expression following `match', but nothing's there")
|
||||
|
||||
(define-for-syntax EXPECTED-FUNCTION-NAME
|
||||
"expected a function after the open parenthesis, but found a structure name")
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; run-time helpers
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
|
@ -329,7 +338,8 @@
|
|||
assign)]
|
||||
[made-up (gensym)]
|
||||
[defn defn])
|
||||
(with-syntax ([made-up-defn (stepper-syntax-property
|
||||
(with-syntax ([made-up-defn
|
||||
(stepper-syntax-property
|
||||
(syntax (define made-up (lambda () (advanced-set! name 10) ...)))
|
||||
'stepper-skip-completely
|
||||
#t)])
|
||||
|
|
@ -635,7 +645,7 @@
|
|||
'define
|
||||
stx
|
||||
(syntax non-name)
|
||||
"expected a variable name, or a function name and its variables (in parentheses), but found ~a"
|
||||
EXPECTED-HEADER
|
||||
(something-else/kw (syntax non-name)))]
|
||||
;; Missing name:
|
||||
[(_)
|
||||
|
|
@ -657,7 +667,8 @@
|
|||
#`(define (#,#'name x)
|
||||
(begin
|
||||
(send (send (get-test-engine) get-info) add-wish-call (quote #,#'name))
|
||||
(raise (exn:fail:wish (format "wished for function ~a not implemented" (quote #,#'name))
|
||||
(raise (exn:fail:wish
|
||||
(format "wished for function ~a not implemented" (quote #,#'name))
|
||||
(current-continuation-marks) (quote #,#'name) x)))) #'lambda)]
|
||||
[(_ name default-value)
|
||||
(define/proc #t #f
|
||||
|
|
@ -951,7 +962,85 @@
|
|||
(values #,signature-name #,parametric-signature-name proc-name ...)))
|
||||
'stepper-black-box-expr
|
||||
stx))))])
|
||||
(let ([defn
|
||||
;; --------------------------------------------------------------------------------
|
||||
(define struct-name-size (string-length (symbol->string (syntax-e #'name_))))
|
||||
(define struct-name/locally-introduced (syntax-local-introduce #'name_))
|
||||
|
||||
(define struct-name-to-maker-directive
|
||||
(vector (syntax-local-introduce constructor-name)
|
||||
5
|
||||
struct-name-size
|
||||
struct-name/locally-introduced
|
||||
0
|
||||
struct-name-size))
|
||||
|
||||
(define struct-name-to-predicate-directive
|
||||
(vector (syntax-local-introduce predicate-name)
|
||||
0
|
||||
struct-name-size
|
||||
struct-name/locally-introduced
|
||||
0
|
||||
struct-name-size))
|
||||
|
||||
(define (struct->selector-directive selector)
|
||||
(define selector-name/locally-introduced (syntax-local-introduce selector))
|
||||
(vector selector-name/locally-introduced
|
||||
0
|
||||
struct-name-size
|
||||
struct-name/locally-introduced
|
||||
0
|
||||
struct-name-size))
|
||||
|
||||
(define (field->selector-directive field selector)
|
||||
(define field-name/locally-introduced (syntax-local-introduce field))
|
||||
(define field-name-size (string-length (symbol->string (syntax-e field))))
|
||||
(define selector-name/locally-introduced (syntax-local-introduce selector))
|
||||
(vector selector-name/locally-introduced
|
||||
(+ struct-name-size 1)
|
||||
field-name-size
|
||||
field-name/locally-introduced
|
||||
0
|
||||
field-name-size))
|
||||
|
||||
(define (struct->setter-directive setter)
|
||||
(define setter-name/locally-introduced (syntax-local-introduce setter))
|
||||
(vector setter-name/locally-introduced
|
||||
;; set-name_-field!
|
||||
;; 012|--->|
|
||||
(string-length "set-")
|
||||
struct-name-size
|
||||
struct-name/locally-introduced
|
||||
0
|
||||
struct-name-size))
|
||||
|
||||
(define (field->setter-directive field setter)
|
||||
(define field-name/locally-introduced (syntax-local-introduce field))
|
||||
(define field-name-size (string-length (symbol->string (syntax-e field))))
|
||||
(define setter-name/locally-introduced (syntax-local-introduce setter))
|
||||
(vector setter-name/locally-introduced
|
||||
;; set-name_-field!
|
||||
;; 012|4...X|--->
|
||||
(+ (string-length "set-") struct-name-size 1)
|
||||
field-name-size
|
||||
field-name/locally-introduced
|
||||
0
|
||||
field-name-size))
|
||||
|
||||
(define signature-name-directive #f)
|
||||
(define parametric-signature-name-directive #f)
|
||||
|
||||
(define all-directives
|
||||
(list* signature-name-directive
|
||||
parametric-signature-name-directive
|
||||
struct-name-to-maker-directive
|
||||
struct-name-to-predicate-directive
|
||||
(map field->selector-directive fields getter-names)
|
||||
(map struct->selector-directive getter-names)
|
||||
(map field->setter-directive fields setter-names)
|
||||
(map struct->setter-directive setter-names)))
|
||||
|
||||
;; --------------------------------------------------------------------------------
|
||||
(let* ([defn
|
||||
(quasisyntax/loc stx
|
||||
(begin
|
||||
#,(stepper-syntax-property
|
||||
|
|
@ -967,7 +1056,7 @@
|
|||
[(self . args)
|
||||
(raise-syntax-error
|
||||
#f
|
||||
"expected a function after the open parenthesis, but found a structure name"
|
||||
EXPECTED-FUNCTION-NAME
|
||||
stx
|
||||
#'self)]
|
||||
[_ #'#,signature-name])))
|
||||
|
|
@ -975,12 +1064,15 @@
|
|||
(make-info (lambda () compile-info))))
|
||||
'stepper-skip-completely
|
||||
#t)
|
||||
#,defn0))])
|
||||
(check-definitions-new 'define-struct
|
||||
#,defn0))]
|
||||
[defn (check-definitions-new 'define-struct
|
||||
stx
|
||||
(list* name parametric-signature-name to-define-names)
|
||||
defn
|
||||
(and setters? bind-names))))))))]
|
||||
(and setters? bind-names))]
|
||||
[defn (syntax-property defn 'disappeared-use (list (syntax-local-introduce #'name_)))]
|
||||
[defn (syntax-property defn 'sub-range-binders all-directives)])
|
||||
defn))))))]
|
||||
[(_ name_ something . rest)
|
||||
(teach-syntax-error
|
||||
'define-struct
|
||||
|
|
@ -2631,7 +2723,7 @@
|
|||
'match
|
||||
stx
|
||||
#f
|
||||
"expected a pattern--answer clause after the expression following `match', but nothing's there")]
|
||||
EXPECTED-MATCH-PATTERN)]
|
||||
[(_ v-expr clause ...)
|
||||
(let ([clauses (syntax->list (syntax (clause ...)))])
|
||||
(for-each
|
||||
|
|
@ -2677,7 +2769,18 @@
|
|||
qqp]))]
|
||||
[check-and-translate-p
|
||||
(λ (p)
|
||||
(syntax-case p (struct posn beginner-true beginner-false empty intermediate-quote intermediate-quasiquote advanced-cons list advanced-list* vector box)
|
||||
(syntax-case p (struct
|
||||
posn
|
||||
beginner-true
|
||||
beginner-false
|
||||
empty
|
||||
intermediate-quote
|
||||
intermediate-quasiquote
|
||||
advanced-cons
|
||||
list
|
||||
advanced-list*
|
||||
vector
|
||||
box)
|
||||
[beginner-true
|
||||
(syntax/loc p
|
||||
#t)]
|
||||
|
|
@ -3095,4 +3198,4 @@
|
|||
(or (boolean? x)
|
||||
(property? x))))))
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user