diff --git a/collects/2htdp/private/syn-aux.rkt b/collects/2htdp/private/syn-aux.rkt index e91f9e31a4..8cf43796fe 100644 --- a/collects/2htdp/private/syn-aux.rkt +++ b/collects/2htdp/private/syn-aux.rkt @@ -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) + ([(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) diff --git a/collects/2htdp/private/world.rkt b/collects/2htdp/private/world.rkt index 94556e269d..162947c86a 100644 --- a/collects/2htdp/private/world.rkt +++ b/collects/2htdp/private/world.rkt @@ -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"))])]) diff --git a/collects/2htdp/universe.rkt b/collects/2htdp/universe.rkt index 28ae05bdd6..cac34c0d35 100644 --- a/collects/2htdp/universe.rkt +++ b/collects/2htdp/universe.rkt @@ -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))]))])) ;