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

some Racket-y (102); arrows and renaming for define-struct in teaching languages; need to find and run lang tests

Browse Source
This commit is contained in:
Matthias Felleisen 2014-08-01 08:59:57 -04:00
parent a57734d7ae
commit e430753b6c
1 changed files with 3027 additions and 2924 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

127
pkgs/htdp-pkgs/htdp-lib/lang/private/teach.rkt
View File

@ -32,7 +32,7 @@
;; reporting. As always, avoid using `local-expand' if there's no ;; reporting. As always, avoid using `local-expand' if there's no
;; error. ;; error.
(module teach mzscheme #lang mzscheme
(require mzlib/etc (require mzlib/etc
mzlib/list mzlib/list
mzlib/math mzlib/math
@ -74,6 +74,15 @@
stepper/private/syntax-property stepper/private/syntax-property
test-engine/racket-tests) 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 ;; run-time helpers
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@ -329,7 +338,8 @@
assign)] assign)]
[made-up (gensym)] [made-up (gensym)]
[defn defn]) [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) ...))) (syntax (define made-up (lambda () (advanced-set! name 10) ...)))
'stepper-skip-completely 'stepper-skip-completely
#t)]) #t)])
@ -635,7 +645,7 @@
'define 'define
stx stx
(syntax non-name) (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)))] (something-else/kw (syntax non-name)))]
;; Missing name: ;; Missing name:
[(_) [(_)
@ -657,7 +667,8 @@
#`(define (#,#'name x) #`(define (#,#'name x)
(begin (begin
(send (send (get-test-engine) get-info) add-wish-call (quote #,#'name)) (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)] (current-continuation-marks) (quote #,#'name) x)))) #'lambda)]
[(_ name default-value) [(_ name default-value)
(define/proc #t #f (define/proc #t #f
@ -951,7 +962,85 @@
(values #,signature-name #,parametric-signature-name proc-name ...))) (values #,signature-name #,parametric-signature-name proc-name ...)))
'stepper-black-box-expr 'stepper-black-box-expr
stx))))]) 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 (quasisyntax/loc stx
(begin (begin
#,(stepper-syntax-property #,(stepper-syntax-property
@ -967,7 +1056,7 @@
[(self . args) [(self . args)
(raise-syntax-error (raise-syntax-error
#f #f
"expected a function after the open parenthesis, but found a structure name" EXPECTED-FUNCTION-NAME
stx stx
#'self)] #'self)]
[_ #'#,signature-name]))) [_ #'#,signature-name])))
@ -975,12 +1064,15 @@
(make-info (lambda () compile-info)))) (make-info (lambda () compile-info))))
'stepper-skip-completely 'stepper-skip-completely
#t) #t)
#,defn0))]) #,defn0))]
(check-definitions-new 'define-struct [defn (check-definitions-new 'define-struct
stx stx
(list* name parametric-signature-name to-define-names) (list* name parametric-signature-name to-define-names)
defn 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) [(_ name_ something . rest)
(teach-syntax-error (teach-syntax-error
'define-struct 'define-struct
@ -2631,7 +2723,7 @@
'match 'match
stx stx
#f #f
"expected a pattern--answer clause after the expression following `match', but nothing's there")] EXPECTED-MATCH-PATTERN)]
[(_ v-expr clause ...) [(_ v-expr clause ...)
(let ([clauses (syntax->list (syntax (clause ...)))]) (let ([clauses (syntax->list (syntax (clause ...)))])
(for-each (for-each
@ -2677,7 +2769,18 @@
qqp]))] qqp]))]
[check-and-translate-p [check-and-translate-p
(λ (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 [beginner-true
(syntax/loc p (syntax/loc p
#t)] #t)]
@ -3095,4 +3198,4 @@
(or (boolean? x) (or (boolean? x)
(property? x)))))) (property? x))))))
)