From cba8e0d079778689de3caf6d50e897350dc2b3b0 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Tue, 13 Jan 2009 02:47:26 +0000 Subject: [PATCH 1/7] doc request: 10022; fixed svn: r13085 --- collects/lang/private/beginner-funs.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/lang/private/beginner-funs.ss b/collects/lang/private/beginner-funs.ss index 83562ce7e0..6db345a023 100644 --- a/collects/lang/private/beginner-funs.ss +++ b/collects/lang/private/beginner-funs.ss @@ -32,18 +32,18 @@ ((beginner-* *) (num num num ... -> num) "to compute the product of all of the input numbers") ((beginner-/ /) (num num num ... -> num) - "to divide the first by the second (and all following) number(s);" + "to divide the first by the second (and all following) number(s); try (/ 3 4) and (/ 3 2 2)" " only the first number can be zero.") (max (real real ... -> real) "to determine the largest number") (min (real real ... -> real) "to determine the smallest number") (quotient (int int -> int) - "to compute the quotient of two integers") + "to divide the first integer into the second; try (quotient 3 4) and (quotient 4 3)") (remainder (int int -> int) - "to compute the remainder of dividing the first by the second integer") + "to determine the remainder of dividing the first by the second integer") (modulo (int int -> int) - "to compute first number modulo second number") + "to find the remainder of the division of the first number by the second; try (modulo 4 3) (modulo 4 -3)") (sqr (num -> num) "to compute the square of a number") (sqrt (num -> num) From ccfc18829f73c166dda296e882879640bfa51e74 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 13 Jan 2009 05:57:01 +0000 Subject: [PATCH 2/7] stxclass: added call to internal-definition-seal in lib added static-of stxclass ported class-iop from macros planet package svn: r13086 --- .../macro-debugger/stxclass/private/lib.ss | 14 ++ .../macro-debugger/stxclass/private/rep.ss | 4 +- .../macro-debugger/stxclass/private/util.ss | 1 + collects/macro-debugger/util/class-ct.ss | 73 ++++++ collects/macro-debugger/util/class-iop.ss | 224 ++++++++++++++++++ 5 files changed, 315 insertions(+), 1 deletion(-) create mode 100644 collects/macro-debugger/util/class-ct.ss create mode 100644 collects/macro-debugger/util/class-iop.ss diff --git a/collects/macro-debugger/stxclass/private/lib.ss b/collects/macro-debugger/stxclass/private/lib.ss index 98f5654c4d..9dcc870013 100644 --- a/collects/macro-debugger/stxclass/private/lib.ss +++ b/collects/macro-debugger/stxclass/private/lib.ss @@ -69,6 +69,20 @@ #:pattern 'static #:reason "not an identifier")))) +(define-basic-syntax-class (static-of name pred) + ([value 0]) + (lambda (x name pred) + (let/ec escape + (define (bad) + (escape (fail-sc x + #:pattern 'name + #:reason (format "not bound as ~a" name)))) + (if (identifier? x) + (let ([value (syntax-local-value x bad)]) + (unless (pred value) (bad)) + (list value)) + (bad))))) + (define-basic-syntax-class struct-name ([descriptor 0] [constructor 0] diff --git a/collects/macro-debugger/stxclass/private/rep.ss b/collects/macro-debugger/stxclass/private/rep.ss index de868a0766..5e58646c4e 100644 --- a/collects/macro-debugger/stxclass/private/rep.ss +++ b/collects/macro-debugger/stxclass/private/rep.ss @@ -185,7 +185,9 @@ [args (cdr p)]) (unless (equal? (length (sc-inputs stxclass)) (length args)) (raise-syntax-error 'syntax-class - "too few arguments for syntax class" + (format "too few arguments for syntax class ~a (expected ~s)" + (sc-name stxclass) + (length (sc-inputs stxclass))) id)) (values id stxclass args (ssc? stxclass))))] [else (values id #f null #f)])) diff --git a/collects/macro-debugger/stxclass/private/util.ss b/collects/macro-debugger/stxclass/private/util.ss index efa24ed302..2b951dbd32 100644 --- a/collects/macro-debugger/stxclass/private/util.ss +++ b/collects/macro-debugger/stxclass/private/util.ss @@ -214,6 +214,7 @@ [_ (loop (stx-cdr x) (cons ee ex) #t)]))] [(stx-null? x) + (internal-definition-context-seal intdef) (reverse ex)])))) diff --git a/collects/macro-debugger/util/class-ct.ss b/collects/macro-debugger/util/class-ct.ss new file mode 100644 index 0000000000..473acbacfc --- /dev/null +++ b/collects/macro-debugger/util/class-ct.ss @@ -0,0 +1,73 @@ +#lang scheme/base +(require (for-template scheme/base + scheme/class) + macro-debugger/stxclass/stxclass) + +(provide static-interface? + make-static-interface + static-interface-dynamic + static-interface-members + + make-checked-binding + checked-binding? + checked-binding-dynamic + checked-binding-iface + + checked-binding + static-interface) + +(define-struct static-interface (dynamic members) + #:omit-define-syntaxes + #:property prop:procedure + (lambda (self stx) + (syntax-case stx () + [(ifname . args) + (datum->syntax stx (cons #'(#%expression ifname) #'args) stx)] + [ifname + (identifier? #'ifname) + (static-interface-dynamic self)]))) + +(define-struct raw-checked-binding (dynamic iface) + #:omit-define-syntaxes + #:property prop:procedure + (lambda (self stx) + (syntax-case stx (set!) + [(set! var expr) + #`(let ([newval expr]) + (unless (is-a? newval #,(static-interface-dynamic + (raw-checked-binding-iface self))) + (error 'check "interface check failed on: ~e" newval)) + (set! #,(raw-checked-binding-dynamic self) newval))] + [(var . args) + (datum->syntax stx (cons #'(#%expression var) #'args) stx)] + [var + (identifier? #'var) + (raw-checked-binding-dynamic self)] + [else + (raise-syntax-error #f "oops" stx)]))) + +(define (make-checked-binding dynamic iface) + (make-set!-transformer + (make-raw-checked-binding dynamic iface))) + +(define (checked-binding? x) + (and (set!-transformer? x) + (raw-checked-binding? (set!-transformer-procedure x)))) + +(define (checked-binding-dynamic x) + (raw-checked-binding-dynamic (set!-transformer-procedure x))) + +(define (checked-binding-iface x) + (raw-checked-binding-iface (set!-transformer-procedure x))) + +;; Syntax + +(define-syntax-class static-interface + (pattern x + #:declare x (static-of 'static-interface static-interface?) + #:with value #'x.value)) + +(define-syntax-class checked-binding + (pattern x + #:declare x (static-of 'checked-binding checked-binding?) + #:with value #'x.value)) diff --git a/collects/macro-debugger/util/class-iop.ss b/collects/macro-debugger/util/class-iop.ss new file mode 100644 index 0000000000..5985a795e3 --- /dev/null +++ b/collects/macro-debugger/util/class-iop.ss @@ -0,0 +1,224 @@ +#lang scheme/base +(require scheme/class + (for-syntax scheme/base + macro-debugger/stxclass/stxclass + ;; "stx.ss" + "class-ct.ss")) +(provide define-interface + define-interface/dynamic + + send: + send*: + send/apply: + + define: + lambda: + init: + init-private:) + +;; Configuration +(define-for-syntax warn-on-dynamic-interfaces? #f) +(define-for-syntax warn-on-dynamic-object-check-generation? #f) +(define-for-syntax warn-on-dynamic-object-check? #f) +(define-for-syntax define-dotted-names #f) + +;; define-interface SYNTAX +;; (define-interface NAME (IDENTIFIER ...)) +;; Defines NAME as an interface. +(define-syntax (define-interface stx) + (syntax-parse stx + [(_ name:id (mname:id ...)) + #'(define-interface/dynamic name + (let ([name (interface () mname ...)]) name) + (mname ...))])) + +;; define-interface/dynamic SYNTAX +;; (define-interface/dynamic NAME EXPR (IDENTIFIER ...)) +;; Defines NAME as a static interface containing the names listed. +;; The EXPR is used as the dynamic componenent of the interface, and +;; it should contain a superset of the names listed. +(define-syntax (define-interface/dynamic stx) + (syntax-parse stx + [(_ name:id dynamic-interface:expr (mname:id ...)) + (with-syntax ([(dynamic-name) (generate-temporaries #'(name))]) + #'(begin (define dynamic-name + (let ([dynamic-name dynamic-interface]) + (for-each + (lambda (m) + (unless (method-in-interface? m dynamic-name) + (error 'name "dynamic interface missing method '~s'" m))) + '(mname ...)) + dynamic-name)) + (define-syntax name + (make-static-interface #'dynamic-name '(mname ...)))))])) + +;; Checked send + +(define-syntax (send: stx) + (syntax-parse stx + [(send: obj:expr iface:static-interface method:id . args) + #`(begin (check-method<-interface method iface) + #,(syntax/loc stx + (send (check-object<:interface send: obj iface) + method . args)))])) + +(define-syntax (send*: stx) + (syntax-parse stx + [(send*: obj:expr iface:static-interface (method:id . args) ...) + #`(begin (check-method<-interface method iface) ... + #,(syntax/loc stx + (send* (check-object<:interface send*: obj iface) + (method . args) ...)))])) + +(define-syntax (send/apply: stx) + (syntax-parse stx + [(send/apply: obj:expr iface:static-interface method:id . args) + #`(begin (check-method<-interface method iface) + #,(syntax/loc stx + (send/apply (check-object<:interface send/apply obj iface) + method . args)))])) + +;; + +;; check-method<-interface SYNTAX +(define-syntax (check-method<-interface stx) + (syntax-parse stx + [(check-method<-interface method:id iface:static-interface) + (let ([si #'iface.value]) + (unless (member (syntax-e #'method) (static-interface-members si)) + (raise-syntax-error 'checked-send + "method not in static interface" + #'method)) + #''okay)] + [(check-method<-interface method:id iface:expr) + (begin (when warn-on-dynamic-interfaces? + (printf "dynamic interface check: ~s,~s: method: ~a~n" + (syntax-source #'method) + (syntax-line #'method) + (syntax-e #'method))) + #`(let ([ifc iface]) + (unless (method-in-interface? 'method ifc) + (error 'checked-send + "interface does not contain method '~a': ~e" + 'method + ifc))))])) + +;; check-object<:interface SYNTAX +(define-syntax (check-object<:interface stx) + (syntax-parse stx + [(_ for-whom obj:checked-binding iface:static-interface) + (if (eq? (checked-binding-iface #'obj.value) #'iface.value) + #'obj + (syntax/loc stx + (check-object<:interface for-whom (#%expression obj) (#%expression iface))))] + [(_ for-whom obj:expr iface:expr) + (begin + (when warn-on-dynamic-object-check-generation? + (printf "dynamic object check: ~s,~s~n" + (syntax-source #'obj) + (syntax-line #'obj))) + #'(dynamic:check-object<:interface 'for-whom obj iface))])) + +(define (dynamic:check-object<:interface for-whom obj iface) + (unless (is-a? obj iface) + (error for-whom "interface check failed on: ~e" obj)) + (let-syntax ([x (lambda (stx) + (if warn-on-dynamic-object-check? + #'(printf "dynamic: object check passed~n") + #'(void)))]) + x) + obj) + +;; + +(define-syntax (define: stx) + (syntax-parse stx + [(_ name:id iface:static-interface expr) + (let ([si #'iface.value]) + (with-syntax ([(name-internal) (generate-temporaries #'(name))] + [(method ...) (static-interface-members si)] + [(name.method ...) + (map (lambda (m) + (datum->syntax #'name + (string->symbol (format "~a.~a" (syntax-e #'name) m)))) + (static-interface-members si))]) + #`(begin (define name-internal + (check-object<:interface define: expr iface)) + (define-syntax name + (make-checked-binding + #'name-internal + (syntax-local-value #'iface))) + #,(if define-dotted-names + #'(begin + (define-syntax name.method + (syntax-rules () + [(name.method . args) + (send: name iface method . args)])) + ...) + #'(begin)))))] + [(_ (f:id . args) . body) + #'(define f (lambda: args . body))])) + +(define-syntax (lambda: stx) + ;; FIXME: rewrite as stxclass + (define (arg->define stx temp) + (syntax-case stx () + [(arg : iface) + (and (identifier? #'arg) + (eq? ': (syntax-e #':))) + #`(define: arg iface #,temp)] + [arg + (identifier? #'arg) + #`(define-syntax arg (make-rename-transformer #'#,temp))])) + (syntax-parse stx + [(_ (arg ...) . body) + (let ([temporaries (generate-temporaries #'(arg ...))]) + (with-syntax ([(temp ...) temporaries] + [(checked-definition ...) + (map arg->define + (syntax->list #'(arg ...)) + temporaries)]) + #'(lambda (temp ...) + (let () + checked-definition ... + (let () . body)))))])) + +(define-syntax (init: stx) + (syntax-parse stx + [(_ (name:id iface:static-interface) ...) + #'(begin (init1: name iface) ...)])) + +(define-syntax (init1: stx) + (syntax-parse stx + [(_ name:id iface:static-interface) + (with-syntax ([(name-internal) (generate-temporaries #'(name))]) + #'(begin (init (name name-internal)) + (void (check-object<:interface init: name-internal iface)) + (define-syntax name + (make-checked-binding + #'name-internal + (syntax-local-value #'iface)))))])) + +(define-syntax (init-private stx) + (syntax-parse stx + [(init-private form ...) + #'(begin (init-private1 form) ...)])) + +(define-syntax (init-private1 stx) + (syntax-parse stx + [(init-private1 id:id) + (with-syntax ([(id-internal) (generate-temporaries #'(id))]) + #'(begin (init (id-internal id)) + (define id id-internal)))])) + +(define-syntax (init-private: stx) + (syntax-parse stx + [(_ (name:id iface:static-interface) ...) + #'(begin (init-private1: name iface) ...)])) + +(define-syntax (init-private1: stx) + (syntax-parse stx + [(_ name:id iface:static-interface) + (with-syntax ([(id-internal) (generate-temporaries #'(id))]) + #'(begin (init (id-internal name)) + (define: name iface id-internal)))])) From 0acce3ead75e0619c74db211c0347481ba4ebdff Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 13 Jan 2009 08:50:18 +0000 Subject: [PATCH 3/7] Welcome to a new PLT day. svn: r13087 --- collects/repos-time-stamp/stamp.ss | 2 +- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 70606307e7..3d67f16d03 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "12jan2009") +#lang scheme/base (provide stamp) (define stamp "13jan2009") diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 2e9bb4a4bf..90a7aa6a77 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Tue, 13 Jan 2009 20:32:13 +0000 Subject: [PATCH 4/7] stxclass: turn off debugging printing svn: r13091 --- collects/macro-debugger/stxclass/private/parse.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/macro-debugger/stxclass/private/parse.ss b/collects/macro-debugger/stxclass/private/parse.ss index 967678ba77..c178bb0150 100644 --- a/collects/macro-debugger/stxclass/private/parse.ss +++ b/collects/macro-debugger/stxclass/private/parse.ss @@ -74,7 +74,7 @@ (with-syntax ([k k] [x x] [p p] [reason reason] [fc-expr (frontier->expr fc)]) #`(let ([failcontext fc-expr]) - (printf "failed: reason=~s, p=~s\n fc=~s\n" reason p failcontext) + #;(printf "failed: reason=~s, p=~s\n fc=~s\n" reason p failcontext) (k x p 'reason failcontext)))) ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK) From 3b8c1640745e810b044a62188930834345fdfeca Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Tue, 13 Jan 2009 20:36:16 +0000 Subject: [PATCH 5/7] macro stepper: changed syntax browser classes to use iop -- This line, and those below, will be ignored-- M macro-debugger/syntax-browser/properties.ss M macro-debugger/syntax-browser/display.ss M macro-debugger/syntax-browser/widget.ss M macro-debugger/syntax-browser/controller.ss M macro-debugger/syntax-browser/interfaces.ss M macro-debugger/syntax-browser/frame.ss M macro-debugger/util/class-iop.ss svn: r13092 --- .../syntax-browser/controller.ss | 5 +- .../macro-debugger/syntax-browser/display.ss | 45 ++-- .../macro-debugger/syntax-browser/frame.ss | 8 +- .../syntax-browser/interfaces.ss | 214 +++++++++--------- .../syntax-browser/properties.ss | 9 +- .../macro-debugger/syntax-browser/widget.ss | 20 +- collects/macro-debugger/util/class-iop.ss | 79 +++---- 7 files changed, 189 insertions(+), 191 deletions(-) diff --git a/collects/macro-debugger/syntax-browser/controller.ss b/collects/macro-debugger/syntax-browser/controller.ss index 19451d6c0e..35241584ec 100644 --- a/collects/macro-debugger/syntax-browser/controller.ss +++ b/collects/macro-debugger/syntax-browser/controller.ss @@ -1,6 +1,7 @@ #lang scheme/base (require scheme/class + macro-debugger/util/class-iop "interfaces.ss" "partition.ss" "../util/notify.ss") @@ -31,7 +32,7 @@ (super-new) (listen-selected-syntax (lambda (new-value) - (for-each (lambda (display) (send display refresh)) + (for-each (lambda (display) (send: display display<%> refresh)) displays))))) ;; mark-manager-mixin @@ -62,7 +63,7 @@ (new partition% (relation (cdr name+proc))))))) (listen-secondary-partition (lambda (p) - (for-each (lambda (d) (send d refresh)) + (for-each (lambda (d) (send: d display<%> refresh)) displays))) (super-new))) diff --git a/collects/macro-debugger/syntax-browser/display.ss b/collects/macro-debugger/syntax-browser/display.ss index 06e04ff2ed..d0645e402b 100644 --- a/collects/macro-debugger/syntax-browser/display.ss +++ b/collects/macro-debugger/syntax-browser/display.ss @@ -3,6 +3,7 @@ (require scheme/class scheme/gui scheme/match + macro-debugger/util/class-iop "pretty-printer.ss" "interfaces.ss" "util.ss") @@ -17,7 +18,7 @@ (define output-port (open-output-string/count-lines)) (define range (pretty-print-syntax stx output-port - (send controller get-primary-partition) + (send: controller controller<%> get-primary-partition) (send config get-colors) (send config get-suffix-option) columns)) @@ -42,13 +43,14 @@ ;; add-clickbacks : text% range% controller<%> number -> void (define (add-clickbacks text range controller insertion-point) - (for ([range (send range all-ranges)]) + (for ([range (send: range range<%> all-ranges)]) (let ([stx (range-obj range)] [start (range-start range)] [end (range-end range)]) (send text set-clickback (+ insertion-point start) (+ insertion-point end) (lambda (_1 _2 _3) - (send controller set-selected-syntax stx)))))) + (send: controller selection-manager<%> + set-selected-syntax stx)))))) ;; set-standard-font : text% config number number -> void (define (set-standard-font text config start end) @@ -81,7 +83,9 @@ (begin-edit-sequence) (change-style unhighlight-d start-position end-position)) (apply-extra-styles) - (let ([selected-syntax (send controller get-selected-syntax)]) + (let ([selected-syntax + (send: controller selection-manager<%> + get-selected-syntax)]) (apply-secondary-partition-styles selected-syntax) (apply-selection-styles selected-syntax)) (send* text @@ -126,9 +130,11 @@ (let ([delta (new style-delta%)]) (send delta set-delta-foreground color) delta)) - (define color-styles (list->vector (map color-style (send config get-colors)))) + (define color-styles + (list->vector (map color-style (send config get-colors)))) (define overflow-style (color-style "darkgray")) - (define color-partition (send controller get-primary-partition)) + (define color-partition + (send: controller mark-manager<%> get-primary-partition)) (define offset start-position) (for-each (lambda (range) @@ -139,12 +145,12 @@ (primary-style stx color-partition color-styles overflow-style) (+ offset start) (+ offset end)))) - (send range all-ranges))) + (send: range range<%> all-ranges))) ;; primary-style : syntax partition (vector-of style-delta%) style-delta% ;; -> style-delta% (define/private (primary-style stx partition color-vector overflow) - (let ([n (send partition get-partition stx)]) + (let ([n (send: partition partition<%> get-partition stx)]) (cond [(< n (vector-length color-vector)) (vector-ref color-vector n)] [else @@ -157,7 +163,7 @@ ;; Applies externally-added styles (such as highlighting) (define/private (apply-extra-styles) (for ([(stx style-deltas) extra-styles]) - (for ([r (send range get-ranges stx)]) + (for ([r (send: range range<%> get-ranges stx)]) (for ([style-delta style-deltas]) (restyle-range r style-delta))))) @@ -166,23 +172,25 @@ ;; in the same partition in blue. (define/private (apply-secondary-partition-styles selected-syntax) (when (identifier? selected-syntax) - (let ([partition (send controller get-secondary-partition)]) + (let ([partition + (send: controller secondary-partition<%> + get-secondary-partition)]) (when partition - (for-each (lambda (id) - (when (send partition same-partition? selected-syntax id) - (draw-secondary-connection id))) - (send range get-identifier-list)))))) + (for ([id (send: range range<%> get-identifier-list)]) + (when (send: partition partition<%> + same-partition? selected-syntax id) + (draw-secondary-connection id))))))) ;; apply-selection-styles : syntax -> void ;; Styles subterms eq to the selected syntax (define/private (apply-selection-styles selected-syntax) - (let ([rs (send range get-ranges selected-syntax)]) - (for-each (lambda (r) (restyle-range r select-highlight-d)) rs))) + (for ([r (send: range range<%> get-ranges selected-syntax)]) + (restyle-range r select-highlight-d))) ;; draw-secondary-connection : syntax -> void (define/private (draw-secondary-connection stx2) - (let ([rs (send range get-ranges stx2)]) - (for-each (lambda (r) (restyle-range r select-sub-highlight-d)) rs))) + (for ([r (send range get-ranges stx2)]) + (restyle-range r select-sub-highlight-d))) ;; restyle-range : (cons num num) style-delta% -> void (define/private (restyle-range r style) @@ -258,4 +266,3 @@ (define select-sub-highlight-d (highlight-style-delta subselection-color #f)) (define unhighlight-d (highlight-style-delta "white" #f)) - diff --git a/collects/macro-debugger/syntax-browser/frame.ss b/collects/macro-debugger/syntax-browser/frame.ss index 87519bccc6..b5a8489066 100644 --- a/collects/macro-debugger/syntax-browser/frame.ss +++ b/collects/macro-debugger/syntax-browser/frame.ss @@ -1,4 +1,3 @@ - #lang scheme/base (require scheme/class scheme/gui @@ -20,10 +19,9 @@ ;; browse-syntaxes : (list-of syntax) -> void (define (browse-syntaxes stxs) (let ((w (make-syntax-browser))) - (for-each (lambda (stx) - (send w add-syntax stx) - (send w add-separator)) - stxs))) + (for ([stx stxs]) + (send w add-syntax stx) + (send w add-separator)))) ;; make-syntax-browser : -> syntax-browser<%> (define (make-syntax-browser) diff --git a/collects/macro-debugger/syntax-browser/interfaces.ss b/collects/macro-debugger/syntax-browser/interfaces.ss index d01315eee8..49096d579d 100644 --- a/collects/macro-debugger/syntax-browser/interfaces.ss +++ b/collects/macro-debugger/syntax-browser/interfaces.ss @@ -1,165 +1,165 @@ #lang scheme/base -(require scheme/class) +(require scheme/class + macro-debugger/util/class-iop) (provide (all-defined-out)) ;; displays-manager<%> -(define displays-manager<%> - (interface () - ;; add-syntax-display : display<%> -> void - add-syntax-display +(define-interface displays-manager<%> + (;; add-syntax-display : display<%> -> void + add-syntax-display - ;; remove-all-syntax-displays : -> void - remove-all-syntax-displays)) + ;; remove-all-syntax-displays : -> void + remove-all-syntax-displays)) ;; selection-manager<%> -(define selection-manager<%> - (interface () - ;; selected-syntax : syntax/#f - set-selected-syntax - get-selected-syntax - listen-selected-syntax - )) +(define-interface selection-manager<%> + (;; selected-syntax : syntax/#f + set-selected-syntax + get-selected-syntax + listen-selected-syntax)) ;; mark-manager<%> ;; Manages marks, mappings from marks to colors -(define mark-manager<%> - (interface () - ;; get-primary-partition : -> partition - get-primary-partition)) +(define-interface mark-manager<%> + (;; get-primary-partition : -> partition + get-primary-partition)) ;; secondary-partition<%> -(define secondary-partition<%> - (interface (displays-manager<%>) - ;; get-secondary-partition : -> partition<%> - get-secondary-partition +(define-interface secondary-partition<%> + (;; get-secondary-partition : -> partition<%> + get-secondary-partition - ;; set-secondary-partition : partition<%> -> void - set-secondary-partition + ;; set-secondary-partition : partition<%> -> void + set-secondary-partition - ;; listen-secondary-partition : (partition<%> -> void) -> void - listen-secondary-partition + ;; listen-secondary-partition : (partition<%> -> void) -> void + listen-secondary-partition - ;; get-identifier=? : -> (cons string procedure) - get-identifier=? + ;; get-identifier=? : -> (cons string procedure) + get-identifier=? - ;; set-identifier=? : (cons string procedure) -> void - set-identifier=? + ;; set-identifier=? : (cons string procedure) -> void + set-identifier=? - ;; listen-identifier=? : ((cons string procedure) -> void) -> void - listen-identifier=?)) + ;; listen-identifier=? : ((cons string procedure) -> void) -> void + listen-identifier=?)) ;; controller<%> -(define controller<%> +(define-interface/dynamic controller<%> (interface (displays-manager<%> selection-manager<%> mark-manager<%> - secondary-partition<%>))) + secondary-partition<%>)) + (add-syntax-display + remove-all-syntax-displays + set-selected-syntax + get-selected-syntax + listen-selected-syntax + get-primary-partition + get-secondary-partition + set-secondary-partition + listen-secondary-partition + get-identifier=? + set-identifier=? + listen-identifier=?)) + ;; host<%> -(define host<%> - (interface () - ;; get-controller : -> controller<%> - get-controller - - ;; add-keymap : text snip - add-keymap - )) +(define-interface host<%> + (;; get-controller : -> controller<%> + get-controller + ;; add-keymap : text snip + add-keymap)) ;; display<%> -(define display<%> - (interface () - ;; refresh : -> void - refresh +(define-interface display<%> + (;; refresh : -> void + refresh - ;; highlight-syntaxes : (list-of syntax) color -> void - highlight-syntaxes + ;; highlight-syntaxes : (list-of syntax) color -> void + highlight-syntaxes - ;; get-start-position : -> number - get-start-position + ;; underline-syntaxes : (listof syntax) -> void + underline-syntaxes - ;; get-end-position : -> number - get-end-position + ;; get-start-position : -> number + get-start-position - ;; get-range : -> range<%> - get-range)) + ;; get-end-position : -> number + get-end-position + + ;; get-range : -> range<%> + get-range)) ;; range<%> -(define range<%> - (interface () - ;; get-ranges : datum -> (list-of (cons number number)) - get-ranges +(define-interface range<%> + (;; get-ranges : datum -> (list-of (cons number number)) + get-ranges - ;; all-ranges : (list-of Range) - ;; Sorted outermost-first - all-ranges + ;; all-ranges : (list-of Range) + ;; Sorted outermost-first + all-ranges + + ;; get-identifier-list : (list-of identifier) + get-identifier-list)) - ;; get-identifier-list : (list-of identifier) - get-identifier-list)) ;; A Range is (make-range datum number number) (define-struct range (obj start end)) ;; syntax-prefs<%> -(define syntax-prefs<%> - (interface () - pref:width - pref:height - pref:props-percentage - pref:props-shown?)) +(define-interface syntax-prefs<%> + (pref:width + pref:height + pref:props-percentage + pref:props-shown?)) ;; widget-hooks<%> -(define widget-hooks<%> - (interface () - ;; setup-keymap : -> void - setup-keymap +(define-interface widget-hooks<%> + (;; setup-keymap : -> void + setup-keymap - ;; shutdown : -> void - shutdown - )) + ;; shutdown : -> void + shutdown)) ;; keymap-hooks<%> -(define keymap-hooks<%> - (interface () - ;; make-context-menu : -> context-menu<%> - make-context-menu +(define-interface keymap-hooks<%> + (;; make-context-menu : -> context-menu<%> + make-context-menu - ;; get-context-menu% : -> class - get-context-menu%)) + ;; get-context-menu% : -> class + get-context-menu%)) ;; context-menu-hooks<%> -(define context-menu-hooks<%> - (interface () - add-edit-items - after-edit-items - add-selection-items - after-selection-items - add-partition-items - after-partition-items)) +(define-interface context-menu-hooks<%> + (add-edit-items + after-edit-items + add-selection-items + after-selection-items + add-partition-items + after-partition-items)) ;;---------- ;; Convenience widget, specialized for displaying stx and not much else -(define syntax-browser<%> - (interface () - add-syntax - add-text - add-separator - erase-all - select-syntax - get-text - )) +(define-interface syntax-browser<%> + (add-syntax + add-text + add-separator + erase-all + select-syntax + get-text)) -(define partition<%> - (interface () - ;; get-partition : any -> number - get-partition +(define-interface partition<%> + (;; get-partition : any -> number + get-partition - ;; same-partition? : any any -> number - same-partition? + ;; same-partition? : any any -> number + same-partition? - ;; count : -> number - count)) + ;; count : -> number + count)) diff --git a/collects/macro-debugger/syntax-browser/properties.ss b/collects/macro-debugger/syntax-browser/properties.ss index ab1a3c8270..2d84de30cf 100644 --- a/collects/macro-debugger/syntax-browser/properties.ss +++ b/collects/macro-debugger/syntax-browser/properties.ss @@ -2,6 +2,7 @@ #lang scheme/base (require scheme/class scheme/gui + macro-debugger/util/class-iop "interfaces.ss" "util.ss" "../util/mpi.ss") @@ -24,10 +25,10 @@ (field (text (new text%))) (field (pdisplayer (new properties-displayer% (text text)))) - (send controller listen-selected-syntax - (lambda (stx) - (set! selected-syntax stx) - (refresh))) + (send: controller selection-manager<%> listen-selected-syntax + (lambda (stx) + (set! selected-syntax stx) + (refresh))) (super-new) ;; get-mode : -> symbol diff --git a/collects/macro-debugger/syntax-browser/widget.ss b/collects/macro-debugger/syntax-browser/widget.ss index 29559e1c89..d7eba23053 100644 --- a/collects/macro-debugger/syntax-browser/widget.ss +++ b/collects/macro-debugger/syntax-browser/widget.ss @@ -6,6 +6,7 @@ scheme/list scheme/match syntax/boundmap + macro-debugger/util/class-iop "interfaces.ss" "controller.ss" "display.ss" @@ -119,7 +120,8 @@ (let ([display (internal-add-syntax stx)] [definite-table (make-hasheq)]) (for-each (lambda (hi-stxs hi-color) - (send display highlight-syntaxes hi-stxs hi-color)) + (send: display display<%> + highlight-syntaxes hi-stxs hi-color)) hi-stxss hi-colors) (for ([definite definites]) @@ -128,20 +130,20 @@ (for ([shifted-definite (hash-ref shift-table definite null)]) (hash-set! definite-table shifted-definite #t)))) (when alpha-table - (let ([range (send display get-range)] - [start (send display get-start-position)]) + (let ([range (send: display display<%> get-range)] + [start (send: display display<%> get-start-position)]) (let* ([binders0 (module-identifier-mapping-map alpha-table (lambda (k v) k))] [binders (apply append (map get-binders binders0))]) - (send display underline-syntaxes binders)) - (for ([id (send range get-identifier-list)]) + (send: display display<%> underline-syntaxes binders)) + (for ([id (send: range range<%> get-identifier-list)]) (define definite? (hash-ref definite-table id #f)) (when #f ;; DISABLED (add-binding-billboard start range id definite?)) (for ([binder (get-binders id)]) - (for ([binder-r (send range get-ranges binder)]) - (for ([id-r (send range get-ranges id)]) + (for ([binder-r (send: range range<%> get-ranges binder)]) + (for ([id-r (send: range range<%> get-ranges id)]) (add-binding-arrow start binder-r id-r definite?))))))) (void))) @@ -169,7 +171,7 @@ (+ start (cdr id-r)) (string-append "from " (mpi->string src-mod)) (if definite? "blue" "purple"))) - (send range get-ranges id))] + (send: range range<%> get-ranges id))] [_ (void)])) (define/public (add-separator) @@ -182,7 +184,7 @@ (with-unlock -text (send -text erase) (send -text delete-all-drawings)) - (send controller remove-all-syntax-displays)) + (send: controller displays-manager<%> remove-all-syntax-displays)) (define/public (get-text) -text) diff --git a/collects/macro-debugger/util/class-iop.ss b/collects/macro-debugger/util/class-iop.ss index 5985a795e3..bf63c9ddf1 100644 --- a/collects/macro-debugger/util/class-iop.ss +++ b/collects/macro-debugger/util/class-iop.ss @@ -2,7 +2,6 @@ (require scheme/class (for-syntax scheme/base macro-debugger/stxclass/stxclass - ;; "stx.ss" "class-ct.ss")) (provide define-interface define-interface/dynamic @@ -19,7 +18,6 @@ ;; Configuration (define-for-syntax warn-on-dynamic-interfaces? #f) (define-for-syntax warn-on-dynamic-object-check-generation? #f) -(define-for-syntax warn-on-dynamic-object-check? #f) (define-for-syntax define-dotted-names #f) ;; define-interface SYNTAX @@ -52,57 +50,44 @@ (define-syntax name (make-static-interface #'dynamic-name '(mname ...)))))])) +;; Helper + +(begin-for-syntax + (define (check-method-in-interface for-whom method si) + (unless (member (syntax-e method) (static-interface-members si)) + (raise-syntax-error for-whom + "method not in static interface" + method)))) + ;; Checked send (define-syntax (send: stx) (syntax-parse stx [(send: obj:expr iface:static-interface method:id . args) - #`(begin (check-method<-interface method iface) - #,(syntax/loc stx - (send (check-object<:interface send: obj iface) - method . args)))])) + (begin (check-method-in-interface 'send: #'method #'iface.value) + (syntax/loc stx + (send (check-object<:interface send: obj iface) + method . args)))])) (define-syntax (send*: stx) (syntax-parse stx [(send*: obj:expr iface:static-interface (method:id . args) ...) - #`(begin (check-method<-interface method iface) ... - #,(syntax/loc stx - (send* (check-object<:interface send*: obj iface) - (method . args) ...)))])) + (begin (for ([method (syntax->list #'(method ...))]) + (check-method-in-interface 'send*: method #'iface.value)) + (syntax/loc stx + (send* (check-object<:interface send*: obj iface) + (method . args) ...)))])) (define-syntax (send/apply: stx) (syntax-parse stx [(send/apply: obj:expr iface:static-interface method:id . args) - #`(begin (check-method<-interface method iface) - #,(syntax/loc stx - (send/apply (check-object<:interface send/apply obj iface) - method . args)))])) + (begin (check-method-in-interface 'send/apply: #'method #'iface.value) + (syntax/loc stx + (send/apply (check-object<:interface send/apply obj iface) + method . args)))])) ;; -;; check-method<-interface SYNTAX -(define-syntax (check-method<-interface stx) - (syntax-parse stx - [(check-method<-interface method:id iface:static-interface) - (let ([si #'iface.value]) - (unless (member (syntax-e #'method) (static-interface-members si)) - (raise-syntax-error 'checked-send - "method not in static interface" - #'method)) - #''okay)] - [(check-method<-interface method:id iface:expr) - (begin (when warn-on-dynamic-interfaces? - (printf "dynamic interface check: ~s,~s: method: ~a~n" - (syntax-source #'method) - (syntax-line #'method) - (syntax-e #'method))) - #`(let ([ifc iface]) - (unless (method-in-interface? 'method ifc) - (error 'checked-send - "interface does not contain method '~a': ~e" - 'method - ifc))))])) - ;; check-object<:interface SYNTAX (define-syntax (check-object<:interface stx) (syntax-parse stx @@ -110,7 +95,9 @@ (if (eq? (checked-binding-iface #'obj.value) #'iface.value) #'obj (syntax/loc stx - (check-object<:interface for-whom (#%expression obj) (#%expression iface))))] + (check-object<:interface for-whom + (#%expression obj) + (#%expression iface))))] [(_ for-whom obj:expr iface:expr) (begin (when warn-on-dynamic-object-check-generation? @@ -122,11 +109,6 @@ (define (dynamic:check-object<:interface for-whom obj iface) (unless (is-a? obj iface) (error for-whom "interface check failed on: ~e" obj)) - (let-syntax ([x (lambda (stx) - (if warn-on-dynamic-object-check? - #'(printf "dynamic: object check passed~n") - #'(void)))]) - x) obj) ;; @@ -183,14 +165,21 @@ checked-definition ... (let () . body)))))])) + +;; FIXME: unsafe due to mutation +(define-syntax (init-field: stx) + (syntax-parse stx + [(_ (name:id iface:static-interface) ...) + #'(begin (init1: init-field name iface) ...)])) + (define-syntax (init: stx) (syntax-parse stx [(_ (name:id iface:static-interface) ...) - #'(begin (init1: name iface) ...)])) + #'(begin (init1: init name iface) ...)])) (define-syntax (init1: stx) (syntax-parse stx - [(_ name:id iface:static-interface) + [(_ init name:id iface:static-interface) (with-syntax ([(name-internal) (generate-temporaries #'(name))]) #'(begin (init (name name-internal)) (void (check-object<:interface init: name-internal iface)) From 5ca04f34977ec3b1be4c424909e3351332300839 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 13 Jan 2009 20:50:36 +0000 Subject: [PATCH 6/7] Randomized testing forms no longer report exceptions as counterexamples or return #t when unable to find a counterexample. svn: r13094 --- collects/redex/private/rg-test.ss | 94 ++++++++++++++---------- collects/redex/private/rg.ss | 116 ++++++++++++++++-------------- 2 files changed, 117 insertions(+), 93 deletions(-) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index 08393a1a2d..b6f562decd 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -495,11 +495,12 @@ #:var (list (λ _ 'x) (λ _ 'y)))) (term (λ (x) (hole y))))) -;; current-output : (-> (-> any) string) -(define (current-output thunk) +;; output : (-> (-> void) string) +(define (output thunk) (let ([p (open-output-string)]) (parameterize ([current-output-port p]) - (thunk)) + (unless (void? (thunk)) + (error 'output "expected void result"))) (begin0 (get-output-string p) (close-output-port p)))) @@ -510,28 +511,38 @@ (d 5) (e e 4) (n number)) - (test (current-output (λ () (redex-check lang d #f))) + (test (output (λ () (redex-check lang d #f))) "counterexample found after 1 attempts:\n5\n") - (test (redex-check lang d #t) #t) - (test (redex-check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2) #t) - (test (redex-check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2) #t) - (test (current-output (λ () (redex-check lang (d e) #f))) + (test (output (λ () (redex-check lang d #t))) "") + (test (output (λ () (redex-check lang (d e) (and (eq? (term d) 5) (eq? (term e) 4)) #:attempts 2))) + "") + (test (output (λ () (redex-check lang (d ...) (zero? (modulo (foldl + 0 (term (d ...))) 5)) #:attempts 2))) + "") + (test (output (λ () (redex-check lang (d e) #f))) "counterexample found after 1 attempts:\n(5 4)\n") - (test (current-output (λ () (redex-check lang d (error 'pred-raised)))) - "counterexample found after 1 attempts:\n5\n") + (let* ([p (open-output-string)] + [m (parameterize ([current-error-port p]) + (with-handlers ([exn:fail? exn-message]) + (redex-check lang d (error 'pred-raised)) + 'no-exn-raised))]) + (test m "error: pred-raised") + (test (get-output-string p) #rx"checking 5 raises.*\n$") + (close-output-port p)) (test (parameterize ([check-randomness (make-random 0 0)]) - (redex-check lang n (eq? 42 (term n)) - #:attempts 1 - #:source (reduction-relation lang (--> 42 x)))) - #t) - (test (current-output + (output + (λ () + (redex-check lang n (eq? 42 (term n)) + #:attempts 1 + #:source (reduction-relation lang (--> 42 x)))))) + "") + (test (output (λ () (parameterize ([check-randomness (make-random 0 0)]) (redex-check lang n (eq? 42 (term n)) #:attempts 1 #:source (reduction-relation lang (--> 0 x z)))))) "counterexample found (z) after 1 attempts:\n0\n") - (test (current-output + (test (output (λ () (parameterize ([check-randomness (make-random 1)]) (redex-check lang d (eq? 42 (term n)) @@ -539,19 +550,23 @@ #:source (reduction-relation lang (--> 0 x z)))))) "counterexample found after 1 attempts:\n5\n") (test (let ([r (reduction-relation lang (--> 0 x z))]) - (redex-check lang n (number? (term n)) - #:attempts 10 - #:source r)) - #t) + (output + (λ () + (redex-check lang n (number? (term n)) + #:attempts 10 + #:source r)))) + "") (let () (define-metafunction lang [(mf 0) 0] [(mf 42) 0]) (test (parameterize ([check-randomness (make-random 0 1)]) - (redex-check lang (n) (eq? 42 (term n)) - #:attempts 1 - #:source mf)) - #t)) + (output + (λ () + (redex-check lang (n) (eq? 42 (term n)) + #:attempts 1 + #:source mf)))) + "")) (let () (define-language L) (test (with-handlers ([exn:fail? exn-message]) @@ -601,21 +616,21 @@ [(i any ...) (any ...)]) ;; Dom(f) < Ctc(f) - (test (current-output + (test (output (λ () (parameterize ([generation-decisions (decisions #:num (list (λ _ 2) (λ _ 5)))]) (check-metafunction-contract f)))) "counterexample found after 1 attempts:\n(5)\n") ;; Rng(f) > Codom(f) - (test (current-output + (test (output (λ () (parameterize ([generation-decisions (decisions #:num (list (λ _ 3)))]) (check-metafunction-contract f)))) "counterexample found after 1 attempts:\n(3)\n") ;; LHS matches multiple ways - (test (current-output + (test (output (λ () (parameterize ([generation-decisions (decisions #:num (list (λ _ 1) (λ _ 1)) @@ -623,9 +638,9 @@ (check-metafunction-contract g)))) "counterexample found after 1 attempts:\n(1 1)\n") ;; OK -- generated from Dom(h) - (test (check-metafunction-contract h) #t) + (test (output (λ () (check-metafunction-contract h))) "") ;; OK -- generated from pattern (any ...) - (test (check-metafunction-contract i #:attempts 5) #t)) + (test (output (λ () (check-metafunction-contract i #:attempts 5))) "")) ;; check-reduction-relation (let () @@ -653,11 +668,11 @@ (reverse '((+ (+)) 0)))) (let ([S (reduction-relation L (--> 1 2 name) (--> 3 4))]) - (test (check-reduction-relation S (λ (x) #t) #:attempts 1) #t) - (test (current-output + (test (output (λ () (check-reduction-relation S (λ (x) #t) #:attempts 1))) "") + (test (output (λ () (check-reduction-relation S (λ (x) #f)))) "counterexample found after 1 attempts with name:\n1\n") - (test (current-output + (test (output (λ () (check-reduction-relation S (curry eq? 1)))) "counterexample found after 1 attempts with unnamed:\n3\n")) @@ -671,11 +686,13 @@ with [(--> (9 a) b) (==> a b)])]) - (test (check-reduction-relation - T (curry equal? '(9 4)) - #:attempts 1 - #:decisions (decisions #:num (build-list 5 (λ (x) (λ _ x))))) - #t))) + (test (output + (λ () + (check-reduction-relation + T (curry equal? '(9 4)) + #:attempts 1 + #:decisions (decisions #:num (build-list 5 (λ (x) (λ _ x))))))) + ""))) ; check-metafunction (let () @@ -688,7 +705,8 @@ (check-metafunction m (λ (t) (set! generated (cons t generated))) #:attempts 1) generated) (reverse '((1) (2))))) - (test (current-output (λ () (check-metafunction m (curry eq? 1)))) + (test (output (λ () (check-metafunction m (λ (_) #t)))) "") + (test (output (λ () (check-metafunction m (curry eq? 1)))) #rx"counterexample found after 1 attempts with clause #1") (test (with-handlers ([exn:fail:contract? exn-message]) (check-metafunction m #t #:attempts 'NaN)) diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index 3b700c2424..c293b00359 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -680,41 +680,41 @@ To do a better job of not generating programs with free variables, (quasisyntax/loc stx (let ([att attempts]) (assert-nat 'redex-check att) - (or (check-property - (cons (list #,(term-generator #'lang #'pat #'random-decisions 'redex-check) #f) - (let ([lang-gen (generate lang (random-decisions lang))]) - #,(if (not source-stx) - #'null - #`(let-values - ([(pats srcs src-lang) - #,(cond [(and (identifier? source-stx) (metafunc source-stx)) - => - (λ (m) #`(values (metafunc-proc-lhs-pats #,m) - (metafunc-srcs #,m) - (metafunc-proc-lang #,m)))] - [else - #`(let ([r #,source-stx]) - (unless (reduction-relation? r) - (raise-type-error 'redex-check "reduction-relation" r)) - (values - (map rewrite-proc-lhs (reduction-relation-make-procs r)) - (reduction-relation-srcs r) - (reduction-relation-lang r)))])]) - (unless (eq? src-lang lang) - (error 'redex-check "language for secondary source must match primary pattern's language")) - (zip (map lang-gen pats) srcs))))) - #,(and source-stx #'(test-match lang pat)) - (λ (generated) (error 'redex-check "~s does not match ~s" generated 'pat)) - (λ (_ bindings) - (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) - property)) - att - (λ (term attempt source port) - (fprintf port "counterexample found~aafter ~a attempts:\n" - (if source (format " (~a) " source) " ") attempt) - (pretty-print term port)) - (check-randomness)) - (void))))))])) + (check-property + (cons (list #,(term-generator #'lang #'pat #'random-decisions 'redex-check) #f) + (let ([lang-gen (generate lang (random-decisions lang))]) + #,(if (not source-stx) + #'null + #`(let-values + ([(pats srcs src-lang) + #,(cond [(and (identifier? source-stx) (metafunc source-stx)) + => + (λ (m) #`(values (metafunc-proc-lhs-pats #,m) + (metafunc-srcs #,m) + (metafunc-proc-lang #,m)))] + [else + #`(let ([r #,source-stx]) + (unless (reduction-relation? r) + (raise-type-error 'redex-check "reduction-relation" r)) + (values + (map rewrite-proc-lhs (reduction-relation-make-procs r)) + (reduction-relation-srcs r) + (reduction-relation-lang r)))])]) + (unless (eq? src-lang lang) + (error 'redex-check "language for secondary source must match primary pattern's language")) + (zip (map lang-gen pats) srcs))))) + #,(and source-stx #'(test-match lang pat)) + (λ (generated) (error 'redex-check "~s does not match ~s" generated 'pat)) + (λ (_ bindings) + (term-let ([name/ellipses (lookup-binding bindings 'name)] ...) + property)) + att + (λ (term attempt source port) + (fprintf port "counterexample found~aafter ~a attempts:\n" + (if source (format " (~a) " source) " ") attempt) + (pretty-print term port)) + (check-randomness)) + (void)))))])) (define (check-property gens-srcs match match-fail property attempts display [random random]) (let loop ([remaining attempts]) @@ -729,7 +729,11 @@ To do a better job of not generating programs with free variables, [(term bindings) (generator (attempt->size attempt) attempt)]) (if (andmap (λ (bindings) - (with-handlers ([exn:fail? (λ (_) #f)]) + (with-handlers ([exn:fail? (λ (exn) + (fprintf (current-error-port) + "checking ~s raises ~s\n" + term exn) + (raise exn))]) (property term bindings))) (cond [(and match (match term)) => (curry map (compose make-bindings match-bindings))] @@ -758,11 +762,14 @@ To do a better job of not generating programs with free variables, (list (list ((generate lang (decisions lang)) (if dom dom '(any (... ...)))) #f)) #f #f - (λ (t _) (begin (term (name ,@t)) #t)) + (λ (t _) + (with-handlers ([exn:fail:redex? (λ (_) #f)]) + (begin (term (name ,@t)) #t))) att (λ (term attempt _ port) (fprintf port "counterexample found after ~a attempts:\n" attempt) - (pretty-print term port))))))])) + (pretty-print term port))) + (void))))])) (define (check-property-many lang pats srcs prop decisions attempts) (let ([lang-gen (generate lang (decisions lang))]) @@ -777,7 +784,8 @@ To do a better job of not generating programs with free variables, (λ (term attempt source port) (fprintf port "counterexample found after ~a attempts with ~a:\n" attempt source) - (pretty-print term port)))))) + (pretty-print term port)))) + (void))) (define (metafunc-srcs m) (build-list (length (metafunc-proc-lhs-pats m)) @@ -792,14 +800,13 @@ To do a better job of not generating programs with free variables, (syntax/loc stx (let ([att attempts]) (assert-nat 'check-metafunction att) - (or (check-property-many - (metafunc-proc-lang m) - (metafunc-proc-lhs-pats m) - (metafunc-srcs m) - property - (generation-decisions) - att) - (void)))))])) + (check-property-many + (metafunc-proc-lang m) + (metafunc-proc-lhs-pats m) + (metafunc-srcs m) + property + (generation-decisions) + att))))])) (define (reduction-relation-srcs r) (map (λ (proc) (or (rewrite-proc-name proc) 'unnamed)) @@ -809,14 +816,13 @@ To do a better job of not generating programs with free variables, relation property #:decisions [decisions random-decisions] #:attempts [attempts default-check-attempts]) - (or (check-property-many - (reduction-relation-lang relation) - (map rewrite-proc-lhs (reduction-relation-make-procs relation)) - (reduction-relation-srcs relation) - property - decisions - attempts) - (void))) + (check-property-many + (reduction-relation-lang relation) + (map rewrite-proc-lhs (reduction-relation-make-procs relation)) + (reduction-relation-srcs relation) + property + decisions + attempts)) (define-signature decisions^ (next-variable-decision From 678f6773aa38160f27eb16a1cdc56f7fabdd9e77 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 13 Jan 2009 23:28:34 +0000 Subject: [PATCH 7/7] fix problem in local-expand and references to not-yet-bound identifiers svn: r13097 --- src/mzscheme/src/env.c | 6 +++++- src/mzscheme/src/eval.c | 8 ++++---- src/mzscheme/src/schpriv.h | 1 + src/mzscheme/src/stxobj.c | 20 +++++++++++--------- 4 files changed, 21 insertions(+), 14 deletions(-) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 90aff15d8e..bd1794bbc6 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -2609,7 +2609,9 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, if (SCHEME_FALSEP(val)) { /* Corresponds to a run-time binding (but will be replaced later through a renaming to a different binding) */ - return NULL; + if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL) + return scheme_make_local(scheme_local_type, 0, 0); + return NULL; } if (!(flags & SCHEME_ENV_CONSTANTS_OK)) { @@ -2647,6 +2649,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, "identifier used out of context"); + if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL) + return scheme_make_local(scheme_local_type, 0, 0); return NULL; } } diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 17d1ae7b7b..e69111e3d3 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -5379,7 +5379,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, ? SCHEME_RESOLVE_MODIDS : 0) + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? SCHEME_OUT_OF_CONTEXT_OK + ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) : 0), rec[drec].certs, env->in_modidx, &menv, &protected, &lexical_binding_id); @@ -5486,7 +5486,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, ? SCHEME_RESOLVE_MODIDS : 0) + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? SCHEME_OUT_OF_CONTEXT_OK + ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) : 0), erec1.certs, env->in_modidx, &menv, NULL, NULL); @@ -5572,7 +5572,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK + SCHEME_DONT_MARK_USE + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? SCHEME_OUT_OF_CONTEXT_OK + ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) : 0), rec[drec].certs, env->in_modidx, &menv, NULL, NULL); @@ -5615,7 +5615,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, + SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK + SCHEME_DONT_MARK_USE + ((!rec[drec].comp && (rec[drec].depth == -2)) - ? SCHEME_OUT_OF_CONTEXT_OK + ? (SCHEME_OUT_OF_CONTEXT_OK | SCHEME_OUT_OF_CONTEXT_LOCAL) : 0), rec[drec].certs, env->in_modidx, &menv, NULL, NULL); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index ccd049a4ca..6f5ec3e0fc 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -2350,6 +2350,7 @@ int *scheme_env_get_flags(Scheme_Comp_Env *frame, int start, int count); #define SCHEME_RESOLVE_MODIDS 1024 #define SCHEME_NO_CERT_CHECKS 2048 #define SCHEME_REFERENCING 4096 +#define SCHEME_OUT_OF_CONTEXT_LOCAL 8192 Scheme_Hash_Table *scheme_map_constants_to_globals(void); diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index d7726bdbff..41c26b2ec4 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -3109,6 +3109,14 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx) return scheme_false; } +#define EXPLAIN_RESOLVE 0 +#if EXPLAIN_RESOLVE +static int explain_resolves = 1; +# define EXPLAIN(x) if (explain_resolves) { x; } +#else +# define EXPLAIN(x) /* empty */ +#endif + static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env) /* Compares the marks in two wraps lists. A result of 2 means that the result depended on a barrier env. For a rib-based renaming, we need @@ -3273,6 +3281,7 @@ static int same_marks(WRAP_POS *_awl, WRAP_POS *_bwl, Scheme_Object *barrier_env /* Done if both reached the end: */ if (WRAP_POS_END_P(awl) && WRAP_POS_END_P(bwl)) { + EXPLAIN(fprintf(stderr, " %d vs. %d marks\n", a_mark_cnt, b_mark_cnt)); if (a_mark_cnt == b_mark_cnt) { while (a_mark_cnt--) { if (!SAME_OBJ(a_mark_stack[a_mark_cnt], b_mark_stack[a_mark_cnt])) @@ -3364,14 +3373,6 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks) } } -#define EXPLAIN_RESOLVE 0 -#if EXPLAIN_RESOLVE -static int explain_resolves = 0; -# define EXPLAIN(x) if (explain_resolves) { x; } -#else -# define EXPLAIN(x) /* empty */ -#endif - static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache, int depth) { int l1, l2; @@ -3898,8 +3899,9 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, is_rib = NULL; } - EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d%s\n", depth, is_rib ? 1 : 0, + EXPLAIN(fprintf(stderr, "%d lexical rename (%d) %d %s%s\n", depth, is_rib ? 1 : 0, SCHEME_VEC_SIZE(rename), + SCHEME_SYMBOLP(SCHEME_VEC_ELS(rename)[0]) ? SCHEME_SYM_VAL(SCHEME_VEC_ELS(rename)[0]) : "", SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1]) ? "" : " hash")); c = SCHEME_RENAME_LEN(rename);