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

making the stepper (mostly) happy

Browse Source
This commit is contained in:
Matthias Felleisen 2010-10-12 18:10:02 -04:00
parent 27e722f27b
commit 8fb58bb74e
3 changed files with 35 additions and 42 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

55
collects/2htdp/private/syn-aux.rkt
View File

@ -22,19 +22,14 @@
(syntax-parse stx #:literals (DEFAULT)
[(_ the-list super-list define-create
(kw:identifier
(~optional kw-alt:identifier
#:defaults ((kw-alt #'kw #;(datum->syntax stx (gensym)))))
(~optional kw-alt:identifier #:defaults ((kw-alt #'kw)))
(~optional (~seq DEFAULT default:expr))
coerce:expr) ...)
(let* ([defs (attribute default)])
#`(begin
;; define and create list of keywords and associated values
(define-for-syntax the-list
(append super-list
(list (list #'kw #'kw-alt (coerce ''kw) default)
#;
(list #'kw-alt #'kw (coerce ''kw-alt) default))
...))
(list* (list #'kw #'kw-alt (coerce ''kw) default) ... super-list))
;; define and provide keywords
(provide (rename-out (kw kw-alt) ...))
(provide kw ...)
@ -43,11 +38,15 @@
(raise-syntax-error 'kw "used out of context" x))
...))
;; a macro for creating functions that instantiate the proper object
;; (define-create para ...) :: additional parameters for the new func
(define-syntax (define-create stx)
(syntax-case stx ()
[(_ para (... ...))
(let*-values
([(kwds defs)
(values (map car the-list) '())
#;
(let L ([the-list the-list][kwds '()][defs '()])
(if (null? the-list)
(values kwds defs)
@ -61,32 +60,16 @@
(L (cdr the-list)
(list* kw0 kw1 kwds)
(list* def def defs))))))]
;; the defaults list defs is no longer needed
[(args) (lambda (para*)
(append
para*
(foldr (lambda (x d rst)
(define k (string->keyword
(symbol->string
(syntax-e x))))
;; This 'if' doesn't work because
;; I don't know how to use 'attribute'
;; properly here and have default values
;; for everything. big-bang and universe
;; check already that defaults are provided.
(if d
(append (list k `(,x ,d)) rst)
(append (list k x) rst)))
'()
kwds
defs)))]
(append para* (foldr cons '() kwds)))]
[(body) (lambda (para*)
(map (lambda (x) `(,x ,x)) (append para* kwds)))])
(let ([para* (syntax->list #'(para (... ...)))])
#`(lambda (%)
(lambda #,(args para*)
(lambda #,(args para*)
(lambda ()
(define o (new % #,@(body para*)))
o)))))]))))]))
(new % #,@(body para*)))))))]))))]))
#|
transform the clauses into the initial arguments specification
@ -107,6 +90,20 @@
(define spec (clauses-use-kwd (syntax->list clauses) ->rec? msg kwds))
(duplicates? tag spec)
(not-a-clause tag stx state0 kwds)
(map (lambda (s)
(define kw (first s))
(define kw-alt (second s))
(define r
(let loop ([spec spec])
(cond
[(null? spec) #false]
[(or (free-identifier=? (caar spec) kw)
(free-identifier=? (caar spec) kw-alt))
(syntax->list (cdar spec))]
[else (loop (cdr spec))])))
(if r ((third s) r) (fourth s)))
Spec)
#;
(apply append
(map (lambda (x)
(define kw (car x))
@ -186,14 +183,14 @@
(lambda (p)
(syntax-case p ()
[(_ x) #`(proc> #,tag (f2h x) arity)]
[_ (err tag p)])))]
[_ (displayln p) (err tag p)])))]
[(_ arity except extra)
(lambda (tag)
(lambda (p)
(syntax-case p ()
[(_ x) #`(proc> #,tag (f2h x) arity)]
extra
[_ (err tag p)])))]))
[_ (displayln p) (err tag p)])))]))
(define (err spec p . xtras)
(raise-syntax-error (cadr spec)

4
collects/2htdp/private/world.rkt
View File

@ -64,13 +64,13 @@
(on-release K) ;; World KeyEvent -> World
(on-mouse K) ;; World Nat Nat MouseEvent -> World
(on-receive #f) ;; (U #f (World S-expression -> World))
(on-draw #f)
(to-draw #f) ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat))
(on-draw #f) ;; (U #f (World -> Scene) (list (World -> Scene) Nat Nat))
(stop-when False) ;; World -> Boolean
(record? #f)) ;; Boolean
;; -----------------------------------------------------------------------
(field
[to-draw on-draw]
[world
(new checked-cell% [msg "World"] [value0 world0] [ok? check-with]
[display (and state (or name "your world program's state"))])])

16
collects/2htdp/universe.rkt
View File

@ -311,19 +311,15 @@
[(universe) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u) (raise-syntax-error #f "not a legal universe description" stx)]
[(universe u bind ...)
(let*
([args (->args 'universe stx #'u #'(bind ...) UniSpec void "universe")]
[domain (map (lambda (x)
(if (keyword? x)
(string->symbol (keyword->string x))
x))
args)])
(let* ([args
(->args 'universe stx #'u #'(bind ...) UniSpec void "universe")]
[dom (map (compose car syntax->datum) (syntax->list #'(bind ...)))])
(cond
[(not (memq 'on-new domain))
[(not (memq 'on-new dom))
(raise-syntax-error #f "missing on-new clause" stx)]
[(not (memq 'on-msg domain))
[(not (memq 'on-msg dom))
(raise-syntax-error #f "missing on-msg clause" stx)]
[else ; (and (memq #'on-new domain) (memq #'on-msg domain))
[else ; (and (memq #'on-new dom) (memq #'on-msg dom))
#`(run-it ((new-universe universe%) u #,@args))]))]))
;