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

working on the namespace errors due to the structure values coming from another module.

Browse Source
This commit is contained in:
Danny Yoo 2011-10-03 16:31:23 -04:00
parent 1699c33bdc
commit fcc1c10632
8 changed files with 499 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
cs019/cs019-pre-base.rkt
View File

@ -9,10 +9,12 @@
cs019-when
cs019-unless
cs019-set!
cs019-case)
cs019-case
cs019-local)
(define-syntax cs019-define advanced-define/proc)
(define-syntax cs019-lambda advanced-lambda/proc)
(define-syntaxes (cs019-when cs019-unless) (values advanced-when/proc advanced-unless/proc))
(define-syntax cs019-set! advanced-set!/proc)
(define-syntax cs019-case advanced-case/proc)
(define-syntax cs019-case advanced-case/proc)
(define-syntax cs019-local intermediate-local/proc)

6
cs019/cs019.rkt
View File

@ -13,7 +13,8 @@
[cs019-define define]
[cs019-when when]
[cs019-unless unless]
[cs019-case case]))
[cs019-case case]
[cs019-local local]))
(require "private/sigs-patched.rkt")
(provide [all-from-out "private/sigs-patched.rkt"])
@ -44,7 +45,8 @@
define
lambda
unless
when)
when
local)
string-ith
replicate

23
cs019/firstorder.rkt Normal file
View File

@ -0,0 +1,23 @@
(module firstorder mzscheme
(provide make-first-order
first-order->higher-order)
(define-values (struct:fo make-first-order fo? fo-get fo-set!)
(make-struct-type 'procedure #f 2 0 #f null (current-inspector) 0))
(define fo-proc-id (make-struct-field-accessor fo-get 1))
(define (first-order->higher-order id)
(let ([v (syntax-local-value id (lambda () #f))])
(if (or (fo? v)
(and (set!-transformer? v)
(fo? (set!-transformer-procedure v))))
(syntax-property
(syntax-local-introduce
(fo-proc-id (if (fo? v) v (set!-transformer-procedure v))))
'disappeared-use
(syntax-local-introduce id))
id))))

99
cs019/rewrite-error-message.rkt Executable file
View File

@ -0,0 +1,99 @@
#lang scheme/base
(require mzlib/etc
mzlib/list
(for-syntax "firstorder.rkt"
scheme/base))
(provide rewrite-contract-error-message
reraise-rewriten-lookup-error-message
get-rewriten-error-message
plural
raise-not-bound-error
argcount-error-message)
(define (reraise-rewriten-lookup-error-message e id was-in-app-position)
(let ([var-or-function (if was-in-app-position "function" "variable")])
(raise-syntax-error
#f
(format "this ~a is not defined" var-or-function)
id)))
(define (exn-needs-rewriting? exn)
(exn:fail:contract? exn))
(define (ensure-number n-or-str)
(if (string? n-or-str) (string->number n-or-str) n-or-str))
(define (plural n)
(if (> (ensure-number n) 1) "s" ""))
(define (raise-not-bound-error id)
(if (syntax-property id 'was-in-app-position)
(raise-syntax-error
#f
"this function is not defined"
id)
(raise-syntax-error
#f
"this variable is not defined"
id)))
(define (argcount-error-message arity found [at-least #f])
(define arity:n (ensure-number arity))
(define found:n (ensure-number found))
(define fn-is-large (> arity:n found:n))
(format "expects ~a~a~a argument~a, but found ~a~a"
(if at-least "at least " "")
(if (or (= arity:n 0) fn-is-large) "" "only ")
(if (= arity:n 0) "no" arity:n) (plural arity:n)
(if (and (not (= found:n 0)) fn-is-large) "only " "")
(if (= found:n 0) "none" found:n)))
(define (rewrite-contract-error-message msg)
(define replacements
(list (list #rx"procedure application: expected procedure, given: (.*) \\(no arguments\\)"
(lambda (all one)
(format "function call: expected a function after the open parenthesis, but received ~a" one)))
(list #rx"procedure application: expected procedure, given: (.*); arguments were:.*"
(lambda (all one)
(format "function call: expected a function after the open parenthesis, but received ~a" one)))
(list #rx"expects argument of type (<([^>]+)>)"
(lambda (all one two) (format "expects a ~a" two)))
(list #rx"expected argument of type (<([^>]+)>)"
(lambda (all one two) (format "expects a ~a" two)))
(list #rx"expects type (<([^>]+)>)"
(lambda (all one two) (format "expects a ~a" two)))
(list #px"expects at least (\\d+) argument.?, given (\\d+)(: .*)?"
(lambda (all one two three) (argcount-error-message one two #t)))
(list #px"expects (\\d+) argument.?, given (\\d+)(: .*)?"
(lambda (all one two three) (argcount-error-message one two)))
(list #rx"^procedure "
(lambda (all) ""))
(list #rx", given: "
(lambda (all) ", given "))
(list #rx"; other arguments were:.*"
(lambda (all) ""))
(list #rx"expects a (struct:)"
(lambda (all one) "expects a "))
(list #rx"list or cyclic list"
(lambda (all) "list"))
(list (regexp-quote "given #(struct:object:image% ...)")
(lambda (all) "given an image"))
(list (regexp-quote "given #(struct:object:image-snip% ...)")
(lambda (all) "given an image"))
(list (regexp-quote "given #(struct:object:cache-image-snip% ...)")
(lambda (all) "given an image"))
(list (regexp-quote "#(struct:object:image% ...)")
(lambda (all) "(image)"))
(list (regexp-quote "#(struct:object:image-snip% ...)")
(lambda (all) "(image)"))
(list (regexp-quote "#(struct:object:cache-image-snip% ...)")
(lambda (all) "(image)"))))
(for/fold ([msg msg]) ([repl. replacements])
(regexp-replace* (first repl.) msg (second repl.))))
(define (get-rewriten-error-message exn)
(if (exn-needs-rewriting? exn)
(rewrite-contract-error-message (exn-message exn))
(exn-message exn)))

14
cs019/teach-runtime.rkt Normal file
View File

@ -0,0 +1,14 @@
#lang s-exp "../lang/base.rkt"
(provide check-not-undefined)
;; Wrapped around uses of local-bound variables:
(define (check-not-undefined name val)
(if (eq? val undefined)
(raise
(make-exn:fail:contract:variable
(format "local variable used before its definition: ~a" name)
(current-continuation-marks)
name))
val))
(define undefined (letrec ([x x]) x))

190
cs019/teach.rkt
View File

@ -1,8 +1,12 @@
#lang racket/base
(require (for-template "../lang/base.rkt")
(for-template "teach-runtime.rkt")
"teachhelp.rkt"
stepper/private/shared
racket/list
syntax/context
syntax/kerncase
syntax/stx)
@ -11,7 +15,19 @@
advanced-when/proc
advanced-unless/proc
advanced-set!/proc advanced-set!-continue/proc
advanced-case/proc)
advanced-case/proc
intermediate-local/proc)
;; verify-boolean is inserted to check for boolean results:
(define (verify-boolean b where)
(if (or (eq? b #t) (eq? b #f))
b
(raise
(make-exn:fail:contract
(format "~a: question result is not true or false: ~e" where b)
(current-continuation-marks)))))
;; A consistent pattern for stepper-skipto:
@ -269,6 +285,178 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; local
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define (intermediate-local/proc stx)
(ensure-expression
stx
(lambda ()
(syntax-case stx ()
[(_ (definition ...) . exprs)
(let ([defns (syntax->list (syntax (definition ...)))]
;; The following context value lets teaching-language definition
;; forms know that it's ok to expand in this internal
;; definition context.
[int-def-ctx (build-expand-context (make-expanding-for-intermediate-local))])
(let* ([partly-expand (lambda (d)
(local-expand
d
int-def-ctx
(kernel-form-identifier-list)))]
[partly-expanded-defns
(map partly-expand defns)]
[flattened-defns
(let loop ([l partly-expanded-defns][origs defns])
(apply
append
(map (lambda (d orig)
(syntax-case d (begin define-values define-syntaxes)
;; we don't have to check for ill-formed `define-values'
;; or `define-syntaxes', because only macros can generate
;; them
[(begin defn ...)
(let ([l (map partly-expand (syntax->list (syntax (defn ...))))])
(loop l l))]
[(define-values . _)
(list d)]
[(define-syntaxes . _)
(list d)]
[_else
(teach-syntax-error
'local
stx
orig
"expected a definition, but found ~a"
(something-else orig))]))
l origs)))]
[val-defns
(apply
append
(map (lambda (partly-expanded)
(syntax-case partly-expanded (define-values)
[(define-values (id ...) expr)
(list partly-expanded)]
[_else
null]))
flattened-defns))]
[stx-defns
(apply
append
(map (lambda (partly-expanded)
(syntax-case partly-expanded (define-syntaxes)
[(define-syntaxes (id ...) expr)
(list partly-expanded)]
[_else
null]))
flattened-defns))]
[get-ids (lambda (l)
(apply
append
(map (lambda (partly-expanded)
(syntax-case partly-expanded ()
[(_ (id ...) expr)
(syntax->list (syntax (id ...)))]))
l)))]
[val-ids (get-ids val-defns)]
[stx-ids (get-ids stx-defns)])
(let ([dup (check-duplicate-identifier (append val-ids stx-ids))])
(when dup
(teach-syntax-error
'local
stx
dup
"~a was defined locally more than once"
(syntax-e dup)))
(let ([exprs (syntax->list (syntax exprs))])
(check-single-expression 'local
"after the local definitions"
stx
exprs
(append val-ids stx-ids)))
(with-syntax ([((d-v (def-id ...) def-expr) ...) val-defns]
[(stx-def ...) stx-defns])
(with-syntax ([(((tmp-id def-id/prop) ...) ...)
;; Generate tmp-ids that at least look like the defined
;; ids, for the purposes of error reporting, etc.:
(map (lambda (def-ids)
(map (lambda (def-id)
(list
(stepper-syntax-property
(datum->syntax
#f
(string->uninterned-symbol
(symbol->string (syntax-e def-id))))
'stepper-orig-name
def-id)
(syntax-property
def-id
'bind-as-variable
#t)))
(syntax->list def-ids)))
(syntax->list (syntax ((def-id ...) ...))))])
(with-syntax ([(mapping ...)
(let ([mappers
(syntax->list
(syntax
((define-syntaxes (def-id/prop ...)
(values
(make-undefined-check
(quote-syntax check-not-undefined)
(quote-syntax tmp-id))
...))
...)))])
(map syntax-track-origin
mappers
val-defns
(syntax->list (syntax (d-v ...)))))])
(stepper-syntax-property
(quasisyntax/loc stx
(let ()
(#%stratified-body
(define #,(gensym) 1) ; this ensures that the expansion of 'local' looks
; roughly the same, even if the local has no defs.
mapping ...
stx-def ...
(define-values (tmp-id ...) def-expr)
...
. exprs)))
'stepper-hint
'comes-from-local)))))))]
[(_ def-non-seq . __)
(teach-syntax-error
'local
stx
(syntax def-non-seq)
"expected at least one definition (in square brackets) after local, but found ~a"
(something-else (syntax def-non-seq)))]
[(_)
(teach-syntax-error
'local
stx
#f
"expected at least one definition (in square brackets) after local, but nothing's there")]
[_else (bad-use-error 'local stx)]))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; define (beginner)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

7
lang/kernel.rkt
View File

@ -201,7 +201,12 @@
exn:fail
struct:exn:fail
prop:exn:srclocs)
prop:exn:srclocs
;; needed for cs019-local
#%stratified-body
)
(define (-identity x) x)

160
tests/more-tests/basics-cs019.rkt Executable file
View File

@ -0,0 +1,160 @@
#lang planet dyoo/whalesong/cs019
(define-struct f (x))
(define-struct g (a b))
(check-expect (build-list 5 add1) (list 1 2 3 4 5))
(check-expect (make-g 1 2) (make-g 1 2))
(check-expect (make-g 'b empty) (make-g 'b empty))
(define i (open-image-url "http://racket-lang.org/logo.png"))
(check-expect (image-height i) 85)
(check-expect (image-width i) 88)
;; Whalesong currently has no support for hashes.
;(define ht (hash))
;(define ht2 (hash-set ht "x" 10))
;(check-expect(hash-ref ht2 "x") 10)
;(check-error (hash-ref ht "x") "hash-ref: no value found for key: \"x\"")
;; INSERTION SORT
(define: (isort [l : (Listof: Number$)]) -> (Listof: Number$)
(cond
[(empty? l) l]
[(cons? l) (insert (first l)
(isort (rest l)))]))
(define: (insert [e : Number$] [l : (Listof: Number$)]) -> (Listof: Number$)
(cond
[(empty? l) (cons e l)]
[(cons? l) (if (<= e (first l))
(cons e l)
(cons (first l)
(insert e (rest l))))]))
(check-expect (isort (list 3 1 2 4)) (list 1 2 3 4))
;; TREE ZIP
;(struct: None ())
;(struct: (a) Some ([v : a]))
;(define-type (Opt a) (U None (Some a)))
(define-struct: None ())
(define-struct: Some ([v : Any$]))
(define Opt$ (or: None$ Some$))
;(struct: (a) Node ([value : a] [kids : (Listof (Tree a))]) #:transparent)
;(struct: MtNode () #:transparent)
;(define-type Tree (All (a) (U (Node a) MtNode)))
(define-struct: Node ([value : Any$] [kids : (Listof: Tree$)]))
(define-struct: MtNode ())
(define Tree$ (or: Node$ MtNode$))
;(struct: (a) BackPtr ([n : (Node a)] [p : Integer]) #:transparent)
;(struct: (a) Cursor ([below : (Tree a)] [above : (Listof (BackPtr a))]) #:transparent)
(define-struct: BackPtr ([n : Node$] [p : (Sig: integer?)]))
(define-struct: Cursor ([below : Tree$] [above : (Listof: BackPtr$)]))
(define Opt-Cursor$ (Sig: (lambda (v)
(or (None? v)
(and (Some? v)
(Cursor? (Some-v v)))))))
;(: find (All (a) ((Tree a) (a -> Boolean) -> (Cursor a))))
(define: (find [t : Tree$] [p : (Any$ -> Boolean$)]) -> Cursor$
(local
[
;(: find-helper (All (a) ((Tree a) (Listof (BackPtr a)) -> (Opt (Cursor a)))))
(define: (find-helper [t : Tree$] [above : (Listof: BackPtr$)]) -> Opt-Cursor$
(cond
[(MtNode? t) (make-None)]
[(Node? t)
(if (p (Node-value t))
(make-Some (make-Cursor t above))
(let ([v (search-kids (Node-kids t) 0 t above)])
(if (Some? v) v (make-None))))]))
; (: search-kids (All (a) ((Listof (Tree a))
; Integer
; (Node a)
; (Listof (BackPtr a)) -> (Opt (Cursor a)))))
(define: (search-kids [kids : (Listof: Tree$)]
[n : (Sig: integer?)]
[first-above : Node$]
[rest-above : (Listof: BackPtr$)]) -> Opt-Cursor$
(cond
[(empty? kids) (make-None)]
[(cons? kids)
(let ([v (find-helper (first kids)
(cons (make-BackPtr first-above n) rest-above))])
(if (Some? v)
v
(search-kids (rest kids) (add1 n) first-above rest-above)))]))
]
(let ([v (find-helper t empty)])
(if (None? v) (error 'find "no such node") (Some-v v)))))
;(: down (All (a) ((Cursor a) Integer -> (Cursor a))))
(define: (down [c : Cursor$] [n : (Sig: integer?)]) -> Cursor$
(let ([v (Cursor-below c)])
(cond
[(MtNode? v) (error 'down "impossible to go down")]
[(Node? v)
(if (empty? (Node-kids v))
(error 'down "impossible to go down")
(make-Cursor (list-ref (Node-kids v) n)
(cons (make-BackPtr v n) (Cursor-above c))))])))
;(: replace (All (a) ((Cursor a) (Tree a) -> (Cursor a))))
(define: (replace [c : Any$] [t : Tree$]) -> Cursor$
(make-Cursor t (Cursor-above c)))
;(: reconstruct/1 (All (a) ((BackPtr a) (Tree a) -> (Node a))))
(define: (reconstruct/1 [one-up : BackPtr$] [replace-with : Tree$]) -> Node$
(let ([node (BackPtr-n one-up)]
[posn (BackPtr-p one-up)])
(let ([val (Node-value node)]
[kids (Node-kids node)])
(make-Node val
(build-list (length kids)
(lambda: ([i : (Sig: integer?)]) -> Tree$
(if (= i posn)
replace-with
(list-ref kids i))))))))
;(: up (All (a) ((Cursor a) -> (Cursor a))))
(define: (up [c : Cursor$]) -> Cursor$
(if (empty? (Cursor-above c))
(error 'up "impossible to go up")
(make-Cursor (reconstruct/1 (first (Cursor-above c))
(Cursor-below c))
(rest (Cursor-above c)))))
;(: ->tree (All (a) ((Cursor a) -> (Tree a))))
(define: (->tree [c : Cursor$]) -> Tree$
(if (empty? (Cursor-above c))
(Cursor-below c)
(->tree (up c))))
(define T (make-Node 7 (list (make-Node 3 empty) (make-MtNode) (make-Node 5 empty))))
(define c0 (find T (lambda: ([n : (Sig: integer?)]) -> Boolean$ (= n 3))))
(define c2 (find T (lambda: ([n : (Sig: integer?)]) -> Boolean$ (= n 5))))
(define c3 (replace (down (up c0) 1) T) )
(define c4 (replace (down (replace (down (up c0) 1) T) 0) (make-MtNode)))
(check-expect T (->tree c0))
(check-expect T (->tree c2))
(check-expect (->tree c3)
(make-Node 7
(list (make-Node 3 empty)
(make-Node 7 (list (make-Node 3 empty)
(make-MtNode)
(make-Node 5 empty)))
(make-Node 5 empty))))
(check-expect (->tree c4)
(make-Node 7
(list (make-Node 3 empty)
(make-Node 7 (list (make-MtNode)
(make-MtNode)
(make-Node 5 empty)))
(make-Node 5 empty))))