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,8 +32,8 @@
|
|||
;; reporting. As always, avoid using `local-expand' if there's no
|
||||
;; error.
|
||||
|
||||
(module teach mzscheme
|
||||
(require mzlib/etc
|
||||
#lang mzscheme
|
||||
(require mzlib/etc
|
||||
mzlib/list
|
||||
mzlib/math
|
||||
mzlib/pconvert-prop
|
||||
|
|
@ -55,9 +55,9 @@
|
|||
beginner-equal? beginner-equal~? teach-equal?
|
||||
advanced-cons advanced-list*))
|
||||
|
||||
(require "rewrite-error-message.rkt")
|
||||
(require "rewrite-error-message.rkt")
|
||||
|
||||
(require-for-syntax "teachhelp.rkt"
|
||||
(require-for-syntax "teachhelp.rkt"
|
||||
"rewrite-error-message.rkt"
|
||||
"teach-shared.rkt"
|
||||
"rewrite-error-message.rkt"
|
||||
|
|
@ -74,12 +74,21 @@
|
|||
stepper/private/syntax-property
|
||||
test-engine/racket-tests)
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; run-time helpers
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
(define-for-syntax EXPECTED-HEADER
|
||||
"expected a variable name, or a function name and its variables (in parentheses), but found ~a")
|
||||
|
||||
;; verify-boolean is inserted to check for boolean results:
|
||||
(define (verify-boolean b where)
|
||||
(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
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
;; verify-boolean is inserted to check for boolean results:
|
||||
(define (verify-boolean b where)
|
||||
(if (or (eq? b #t) (eq? b #f))
|
||||
b
|
||||
(raise
|
||||
|
|
@ -87,34 +96,34 @@
|
|||
(format "~a: question result is not true or false: ~e" where b)
|
||||
(current-continuation-marks)))))
|
||||
|
||||
(define (identifier-is-bound? id)
|
||||
(define (identifier-is-bound? id)
|
||||
(or (identifier-binding id)
|
||||
;; identifier-binding returns #f for variable bound at the top-level,
|
||||
;; check explicitly:
|
||||
(and (namespace-variable-value (syntax-e id) #t (lambda () #f)) #t)))
|
||||
|
||||
;; Wrapped around top-level definitions to disallow re-definition:
|
||||
(define (check-top-level-not-defined who id)
|
||||
;; Wrapped around top-level definitions to disallow re-definition:
|
||||
(define (check-top-level-not-defined who id)
|
||||
(when (identifier-is-bound? id)
|
||||
(raise-syntax-error #f "this name was defined previously and cannot be re-defined" id)))
|
||||
|
||||
(define (top/check-defined id)
|
||||
(define (top/check-defined id)
|
||||
(namespace-variable-value (syntax-e id) #t (lambda () (raise-not-bound-error id))))
|
||||
|
||||
;; For quasiquote and shared:
|
||||
(require (rename "teachprims.rkt" the-cons advanced-cons))
|
||||
(require (only "teachprims.rkt" cyclic-list?))
|
||||
;; For quasiquote and shared:
|
||||
(require (rename "teachprims.rkt" the-cons advanced-cons))
|
||||
(require (only "teachprims.rkt" cyclic-list?))
|
||||
|
||||
;; Referenced to ensure that evaluating `lambda' always
|
||||
;; produces a new closure (instead of using a closure
|
||||
;; that's allocated once)
|
||||
(define make-lambda-generative 5)
|
||||
;; Referenced to ensure that evaluating `lambda' always
|
||||
;; produces a new closure (instead of using a closure
|
||||
;; that's allocated once)
|
||||
(define make-lambda-generative 5)
|
||||
|
||||
;; A consistent pattern for stepper-skipto:
|
||||
(define-for-syntax (stepper-ignore-checker stx)
|
||||
;; A consistent pattern for stepper-skipto:
|
||||
(define-for-syntax (stepper-ignore-checker stx)
|
||||
(stepper-syntax-property stx 'stepper-skipto '(syntax-e cdr syntax-e cdr car)))
|
||||
|
||||
(define-for-syntax (map-with-index proc . lists)
|
||||
(define-for-syntax (map-with-index proc . lists)
|
||||
(let loop ([i 0] [lists lists] [rev-result '()])
|
||||
(if (null? (car lists))
|
||||
(reverse rev-result)
|
||||
|
|
@ -122,8 +131,8 @@
|
|||
(map cdr lists)
|
||||
(cons (apply proc i (map car lists)) rev-result)))))
|
||||
|
||||
;; build-struct-names is hard to handle
|
||||
(define-for-syntax (make-struct-names name fields stx)
|
||||
;; build-struct-names is hard to handle
|
||||
(define-for-syntax (make-struct-names name fields stx)
|
||||
(apply (lambda (struct: constructor predicate . rest)
|
||||
(let loop ([rest rest]
|
||||
[getters '()]
|
||||
|
|
@ -135,11 +144,11 @@
|
|||
(cons (cadr rest) setters)))))
|
||||
(build-struct-names name fields #f #f stx)))
|
||||
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; syntax implementations
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
;; syntax implementations
|
||||
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
||||
|
||||
(define-syntax define-syntax-set/provide
|
||||
(define-syntax define-syntax-set/provide
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ (id ...) defn ...)
|
||||
|
|
@ -159,14 +168,14 @@
|
|||
defn ...))))])))
|
||||
|
||||
|
||||
;; The implementation of form X is defined below as X/proc. The
|
||||
;; reason for this is to allow the implementation of Y to re-use the
|
||||
;; implementation of X (expanding to a use of X would mangle syntax
|
||||
;; error messages), while preserving the binding of X as the one for
|
||||
;; the syntax definition (so that quasiquote can recognize unquote,
|
||||
;; etc.).
|
||||
;; The implementation of form X is defined below as X/proc. The
|
||||
;; reason for this is to allow the implementation of Y to re-use the
|
||||
;; implementation of X (expanding to a use of X would mangle syntax
|
||||
;; error messages), while preserving the binding of X as the one for
|
||||
;; the syntax definition (so that quasiquote can recognize unquote,
|
||||
;; etc.).
|
||||
|
||||
(define-syntax-set/provide (beginner-define
|
||||
(define-syntax-set/provide (beginner-define
|
||||
beginner-define-struct
|
||||
beginner-lambda
|
||||
beginner-app beginner-app-continue
|
||||
|
|
@ -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)]
|
||||
|
|
@ -2854,10 +2957,10 @@
|
|||
;; The main implementation
|
||||
(shared/proc stx make-check-cdr))))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Utilities for `define-struct':
|
||||
;; ----------------------------------------
|
||||
;; Utilities for `define-struct':
|
||||
|
||||
(define (make-equal-hash generic-access field-count)
|
||||
(define (make-equal-hash generic-access field-count)
|
||||
(lambda (r recur)
|
||||
(let loop ((i 0)
|
||||
(factor 1)
|
||||
|
|
@ -2868,7 +2971,7 @@
|
|||
(* factor 33)
|
||||
(+ hash (* factor (recur (generic-access r i)))))))))
|
||||
|
||||
(define (make-equal2-hash generic-access field-count)
|
||||
(define (make-equal2-hash generic-access field-count)
|
||||
(lambda (r recur)
|
||||
(let loop ((i 0)
|
||||
(factor 1)
|
||||
|
|
@ -2880,22 +2983,22 @@
|
|||
(+ hash (* factor
|
||||
(recur (generic-access r (- field-count i 1))))))))))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Extend quote forms to work with `match':
|
||||
;; ----------------------------------------
|
||||
;; Extend quote forms to work with `match':
|
||||
|
||||
(provide beginner-quote
|
||||
(provide beginner-quote
|
||||
intermediate-quote
|
||||
intermediate-quasiquote)
|
||||
|
||||
(define-match-expander beginner-quote
|
||||
(define-match-expander beginner-quote
|
||||
(syntax-local-value #'beginner-quote/expr)
|
||||
(syntax-local-value #'beginner-quote/expr))
|
||||
|
||||
(define-match-expander intermediate-quote
|
||||
(define-match-expander intermediate-quote
|
||||
(syntax-local-value #'intermediate-quote/expr)
|
||||
(syntax-local-value #'intermediate-quote/expr))
|
||||
|
||||
(define-match-expander intermediate-quasiquote
|
||||
(define-match-expander intermediate-quasiquote
|
||||
;; Match expander:
|
||||
(let ([qq (syntax-local-value #'intermediate-quasiquote/expr)])
|
||||
(lambda (stx)
|
||||
|
|
@ -2932,7 +3035,7 @@
|
|||
;; Expression expander:
|
||||
(syntax-local-value #'intermediate-quasiquote/expr))
|
||||
|
||||
(define-match-expander the-cons/matchable
|
||||
(define-match-expander the-cons/matchable
|
||||
;; For match (no cdr check needed for deconstruction):
|
||||
(lambda (stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -3095,4 +3198,4 @@
|
|||
(or (boolean? x)
|
||||
(property? x))))))
|
||||
|
||||
)
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user