diff --git a/collects/2htdp/private/world.ss b/collects/2htdp/private/world.ss index 061ec0e117..c80468939f 100644 --- a/collects/2htdp/private/world.ss +++ b/collects/2htdp/private/world.ss @@ -181,7 +181,7 @@ (when live (cond [(and (<= 0 x width) (<= 0 y height)) (pmouse x y me)] - [(memq me '(leave enter)) (pmouse x y me)] + [(member me '("leave" "enter")) (pmouse x y me)] [else (void)])))) (parent frame) (editor visible) diff --git a/collects/2htdp/tests/mouse-evt.ss b/collects/2htdp/tests/mouse-evt.ss new file mode 100644 index 0000000000..8e3740dc86 --- /dev/null +++ b/collects/2htdp/tests/mouse-evt.ss @@ -0,0 +1,45 @@ +#lang scheme + +(require 2htdp/universe) +(require htdp/image) +(require test-engine/scheme-tests) + +(define-struct posn (x y) #:transparent) + +(define world1 (make-posn 50 50)) +(define world-in (make-posn 100 100)) +(define world-out (make-posn 250 250)) + +(define mt (empty-scene 500 500)) +(define sq (rectangle 10 10 'solid 'black)) + +(define (draw a-world) + (cond + [(equal? a-world world1) + (place-image (text "move mouse in to canvas" 11 'red) 10 10 + (place-image sq (posn-x a-world) (posn-y a-world) mt))] + [(equal? a-world world-in) + (place-image (text "move mouse out of canvas" 11 'red) 10 10 + (place-image sq (posn-x a-world) (posn-y a-world) mt))] + [else + (place-image sq (posn-x a-world) (posn-y a-world) mt)])) + +(check-expect (mouse-handler 'w 100 100 "leave") (make-posn 250 250)) + +(define (mouse-handler w x y me) + (cond + [(string=? "button-down" me) w] + [(string=? "button-up" me) w] + [(string=? "drag" me) w] + [(string=? "move" me) w] + [(string=? "enter" me) world-in] + [(string=? "leave" me) world-out])) + +(define (out? w) (equal? world-out w)) + +(define (main w) + (big-bang world1 (on-draw draw) (stop-when out?) (on-mouse mouse-handler))) + +(test) + +(main 0) diff --git a/collects/drscheme/private/drsig.ss b/collects/drscheme/private/drsig.ss index 4645b8a393..3131312b0f 100644 --- a/collects/drscheme/private/drsig.ss +++ b/collects/drscheme/private/drsig.ss @@ -83,17 +83,16 @@ (module-language<%>)) (define-signature drscheme:module-language^ extends drscheme:module-language-cm^ (add-module-language - module-language-name module-language-put-file-mixin)) -(define-signature drscheme:module-langauge-tools-cm^ +(define-signature drscheme:module-language-tools-cm^ (frame-mixin frame<%> tab-mixin tab<%> definitions-text-mixin definitions-text<%>)) -(define-signature drscheme:module-language-tools^ extends drscheme:module-langauge-tools-cm^ +(define-signature drscheme:module-language-tools^ extends drscheme:module-language-tools-cm^ ()) (define-signature drscheme:get-collection-cm^ ()) diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss index 68af30ed1b..b4e127dace 100644 --- a/collects/drscheme/private/language-configuration.ss +++ b/collects/drscheme/private/language-configuration.ss @@ -1,20 +1,18 @@ -#lang mzscheme - (require mzlib/unit +#lang scheme/base + (require scheme/unit mrlib/hierlist - mzlib/class - mzlib/contract - mzlib/kw - mzlib/string - mzlib/struct + scheme/class + scheme/contract + scheme/string + scheme/list "drsig.ss" + macro-debugger/capability string-constants mred framework - mzlib/list - mzlib/etc - mzlib/file setup/getinfo - syntax/toplevel) + syntax/toplevel + (only-in mzlib/struct make-->vector)) (define original-output (current-output-port)) (define (printfo . args) (apply fprintf original-output args)) @@ -59,7 +57,7 @@ ;; only allows addition on phase2 ;; effect: updates `languages' (define add-language - (opt-lambda (language [front? #f]) + (λ (language [front? #f]) (drscheme:tools:only-in-phase 'drscheme:language:add-language 'phase2) (for-each @@ -105,7 +103,7 @@ initial-language-position) x)) (get-languages)) - (first (get-languages)))]) + (list-ref (get-languages) 0))]) (make-language-settings lang (send lang default-settings)))) ;; type language-settings = (make-language-settings (instanceof language<%>) settings) @@ -138,7 +136,7 @@ ;; as the defaults in the dialog and the output language setting is the user's choice ;; todo: when button is clicked, ensure language is selected (define language-dialog - (opt-lambda (show-welcome? language-settings-to-show [parent #f]) + (λ (show-welcome? language-settings-to-show [parent #f]) (define ret-dialog% (class dialog% (define/override (on-subwindow-char receiver evt) @@ -250,7 +248,7 @@ ;; as the defaults in the dialog and the output language setting is the user's choice ;; if re-center is a dialog, when the show details button is clicked, the dialog is recenterd. (define fill-language-dialog - (opt-lambda (parent show-details-parent language-settings-to-show + (λ (parent show-details-parent language-settings-to-show [re-center #f] [ok-handler void]) ; en/disable button, execute it @@ -258,8 +256,8 @@ (let ([request-lang-to-show (language-settings-language language-settings-to-show)]) (cond [(equal? initial-language-position (send request-lang-to-show get-language-position)) - (values (first (get-languages)) - (send (first (get-languages)) default-settings)) + (values (list-ref (get-languages) 0) + (send (list-ref (get-languages) 0) default-settings)) (values #f #f)] [else (values request-lang-to-show (language-settings-settings language-settings-to-show))]))) @@ -347,6 +345,8 @@ cached-fringe) (define/override (on-select i) + (when i + (set! most-recent-languages-hier-list-selection i)) (cond [(and i (is-a? i hieritem-language<%>)) (something-selected i)] @@ -363,7 +363,9 @@ (ok-handler 'execute))) (super-new [parent parent]) ;; do this so we can expand/collapse languages on a single click - (send this on-click-always #t))) + (inherit on-click-always allow-deselect) + (on-click-always #t) + (allow-deselect #t))) (define outermost-panel (make-object horizontal-pane% parent)) (define languages-choice-panel (new vertical-panel% @@ -386,7 +388,8 @@ [parent in-source-discussion-panel] [stretchable-width #f] [min-width 32])) - (define stupid-internal-definition-syntax1 (add-discussion in-source-discussion-panel)) + (define in-source-discussion-editor-canvas (add-discussion in-source-discussion-panel)) + (define most-recent-languages-hier-list-selection #f) (define use-chosen-language-rb (new radio-box% [label #f] @@ -394,12 +397,9 @@ [parent languages-choice-panel] [callback (λ (this-rb evt) - (let ([i (send languages-hier-list get-selected)]) - (cond - [(and i (is-a? i hieritem-language<%>)) - (something-selected i)] - [else - (non-language-selected)])) + (when most-recent-languages-hier-list-selection + (send languages-hier-list select + most-recent-languages-hier-list-selection)) (send use-language-in-source-rb set-selection #f))])) (define languages-hier-list-panel (new horizontal-panel% [parent languages-choice-panel])) (define languages-hier-list-spacer (new horizontal-panel% @@ -409,7 +409,7 @@ (define languages-hier-list (new selectable-hierlist% [parent languages-hier-list-panel] - [style '(no-border no-hscroll hide-vscroll transparent)])) + [style '(no-border no-hscroll auto-vscroll transparent)])) (define details-outer-panel (make-object vertical-pane% outermost-panel)) (define details/manual-parent-panel (make-object vertical-panel% details-outer-panel)) (define details-panel (make-object panel:single% details/manual-parent-panel)) @@ -421,7 +421,7 @@ (define no-details-panel (make-object vertical-panel% details-panel)) - (define languages-table (make-hash-table)) + (define languages-table (make-hasheq)) (define languages (get-languages)) ;; selected-language : (union (instanceof language<%>) #f) @@ -460,7 +460,7 @@ (define (module-language-selected) ;; need to deselect things in the languages-hier-list at this point. - ;(send languages-hier-list select #f) + (send languages-hier-list select #f) (send use-chosen-language-rb set-selection #f) (send use-language-in-source-rb set-selection 0) (ok-handler 'enable) @@ -522,7 +522,7 @@ positions numbers)) (when (null? (cdr positions)) - (unless (equal? positions (list drscheme:module-language:module-language-name)) + (unless (equal? positions (list (string-constant module-language-name))) (error 'drscheme:language "Only the module language may be at the top level. Other languages must have at least two levels"))) @@ -593,7 +593,7 @@ (get/set-settings (send language default-settings))]))))) (cond - [(equal? positions (list drscheme:module-language:module-language-name)) + [(equal? positions (list (string-constant module-language-name))) (set! module-language*language language) (set! module-language*get-language-details-panel get-language-details-panel) (set! module-language*get/set-settings get/set-settings)] @@ -629,14 +629,14 @@ [else (let* ([position (car positions)] [number (car numbers)] [sub-ht/sub-hier-list - (hash-table-get + (hash-ref ht (string->symbol position) (λ () (if first? (let* ([item (send hier-list new-item number-mixin)] - [x (list (make-hash-table) hier-list item)]) - (hash-table-put! ht (string->symbol position) x) + [x (list (make-hasheq) hier-list item)]) + (hash-set! ht (string->symbol position) x) (send item set-number number) (send item set-allow-selection #f) (let* ([editor (send item get-editor)] @@ -651,14 +651,14 @@ (if second-number (compose second-number-mixin number-mixin) number-mixin))] - [x (list (make-hash-table) new-list #f)]) + [x (list (make-hasheq) new-list #f)]) (send new-list set-number number) (when second-number (send new-list set-second-number second-number)) (send new-list set-allow-selection #t) (send new-list open) (send (send new-list get-editor) insert position) - (hash-table-put! ht (string->symbol position) x) + (hash-set! ht (string->symbol position) x) x))))]) (cond [first? @@ -905,6 +905,7 @@ (do-construct-details)) (update-show/hide-details) (send languages-hier-list focus) + (size-discussion-canvas in-source-discussion-editor-canvas) (values (λ () selected-language) (λ () @@ -918,10 +919,8 @@ [horizontal-inset 0] [vertical-inset 0] [parent p] - [style '(no-border auto-vscroll no-hscroll transparent)] + [style '(no-border no-vscroll no-hscroll transparent)] [editor t])]) - (send c set-line-count 3) - (send t set-styles-sticky #f) (send t set-autowrap-bitmap #f) (let* ([size-sd (make-object style-delta% 'change-size (send normal-control-font get-point-size))] @@ -947,37 +946,20 @@ (send t hide-caret #t) (send t auto-wrap #t) - (send t lock #t))) + (send t lock #t) + (send c accept-tab-focus #f) + (send c allow-tab-exit #t) + c)) - (define panel-background-editor-canvas% - (class editor-canvas% - (inherit get-dc get-client-size) - (define/override (on-paint) - (let-values ([(cw ch) (get-client-size)]) - (let* ([dc (get-dc)] - [old-pen (send dc get-pen)] - [old-brush (send dc get-brush)]) - (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel)) - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send dc draw-rectangle 0 0 cw ch) - (send dc set-pen old-pen) - (send dc set-brush old-brush))) - (super on-paint)) - (super-new))) - - (define panel-background-text% - (class text% - (define/override (on-paint before? dc left top right bottom dx dy draw-caret) - (when before? - (let ([old-pen (send dc get-pen)] - [old-brush (send dc get-brush)]) - (send dc set-brush (send the-brush-list find-or-create-brush (get-panel-background) 'panel)) - (send dc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) - (send dc draw-rectangle (+ dx left) (+ dy top) (- right left) (- bottom top)) - (send dc set-pen old-pen) - (send dc set-brush old-brush))) - (super on-paint before? dc left top right bottom dx dy draw-caret)) - (super-new))) + (define (size-discussion-canvas canvas) + (let ([t (send canvas get-editor)]) + + (let ([by (box 0)]) + (send t position-location + (send t line-end-position (send t last-line)) + #f + by) + (send canvas min-height (+ (ceiling (inexact->exact (unbox by))) 24))))) (define section-style-delta (make-object style-delta% 'change-bold)) (send section-style-delta set-delta-foreground "medium blue") @@ -1234,9 +1216,9 @@ (format "uncaught exception: ~s" x))) read-syntax/namespace-introduce)]) (contract - (opt-> () - (any/c port?) - (or/c syntax? eof-object?)) + (->* () + (any/c port?) + (or/c syntax? eof-object?)) (dynamic-require (cond [(string? reader-spec) @@ -1289,7 +1271,7 @@ (regexp-split #rx"/" str)))) (define read-syntax/namespace-introduce - (opt-lambda (source-name-v [input-port (current-input-port)]) + (λ (source-name-v [input-port (current-input-port)]) (let ([v (read-syntax source-name-v input-port)]) (if (syntax? v) (namespace-syntax-introduce v) @@ -1351,6 +1333,15 @@ (define-struct (simple-settings+assume drscheme:language:simple-settings) (no-redef?)) (define simple-settings+assume->vector (make-->vector simple-settings+assume)) + (define (macro-stepper-mixin %) + (class % + (super-new) + (define/augment (capability-value key) + (cond + [(eq? key macro-stepper-capability-key) #t] + [else (inner (drscheme:language:get-capability-default key) + capability-value key)])))) + (define (assume-mixin %) (class % (define/override (default-settings) @@ -1415,7 +1406,7 @@ (run-in-user-thread (λ () (namespace-require 'errortrace/errortrace-key) - (namespace-transformer-require 'errortrace/errortrace-key)))) + (namespace-require '(for-syntax errortrace/errortrace-key))))) (super-new))) (define (r5rs-mixin %) @@ -1464,7 +1455,9 @@ (cond [(eq? key 'drscheme:autocomplete-words) (get-all-manual-keywords)] - [else (drscheme:language:get-capability-default key)])) + [else (inner + (drscheme:language:get-capability-default key) + capability-value key)])) (define/override (create-executable setting parent program-filename) (let ([executable-fn (drscheme:language:put-executable @@ -1507,7 +1500,7 @@ (list -200 3) #t (string-constant pretty-big-scheme-one-line-summary) - (λ (%) (assume-mixin (add-errortrace-key-mixin %))))) + (λ (%) (macro-stepper-mixin (assume-mixin (add-errortrace-key-mixin %)))))) (add-language (make-simple '(lib "r5rs/lang.ss") "plt:r5rs" @@ -1516,7 +1509,7 @@ (list -200 -1000) #f (string-constant r5rs-one-line-summary) - (lambda (%) (r5rs-mixin (assume-mixin (add-errortrace-key-mixin %)))))) + (lambda (%) (r5rs-mixin (macro-stepper-mixin (assume-mixin (add-errortrace-key-mixin %))))))) (add-language (make-simple 'mzscheme @@ -1546,7 +1539,8 @@ (define/augment (capability-value v) (case v [(drscheme:check-syntax-button) #f] - [else (drscheme:language:get-capability-default v)])) + [else (inner (drscheme:language:get-capability-default v) + capability-value v)])) (super-new))) @@ -1765,13 +1759,12 @@ 'normal 'normal)) - (define/kw (get-font #:key - (point-size (send default-font get-point-size)) - (family (send default-font get-family)) - (style (send default-font get-style)) - (weight (send default-font get-weight)) - (underlined (send default-font get-underlined)) - (smoothing (send default-font get-smoothing))) + (define (get-font #:point-size [point-size (send default-font get-point-size)] + #:family (family (send default-font get-family)) + #:style (style (send default-font get-style)) + #:weight (weight (send default-font get-weight)) + #:underlined (underlined (send default-font get-underlined)) + #:smoothing (smoothing (send default-font get-smoothing))) (send the-font-list find-or-create-font point-size family @@ -1822,7 +1815,7 @@ (new canvas-message% (parent panel2) (label (string-constant start-with-before))) (new canvas-message% (parent panel2) - (label (car (last-pair lang))) + (label (last lang)) (color (send the-color-database find-color "blue")) (callback (λ () (change-current-lang-to lang))) (font (get-font #:underlined #t))) diff --git a/collects/drscheme/private/module-language.ss b/collects/drscheme/private/module-language.ss index be1b0ab6da..ebefb4a619 100644 --- a/collects/drscheme/private/module-language.ss +++ b/collects/drscheme/private/module-language.ss @@ -13,6 +13,7 @@ framework string-constants planet/config + macro-debugger/capability "drsig.ss" "rep.ss") @@ -53,8 +54,6 @@ (define default-full-trace? #t) (define default-auto-text "#lang scheme\n") - (define module-language-name "Determine langauge from source") - ;; module-mixin : (implements drscheme:language:language<%>) ;; -> (implements drscheme:language:language<%>) (define (module-mixin %) @@ -62,21 +61,32 @@ (inherit get-language-name) (define/public (get-users-language-name defs-text) - (let* ([i (open-input-text-editor defs-text)] - [l (with-handlers ((exn:fail? (λ (x) '?))) - (read-language i (lambda () '?)))]) - (if (eq? '? l) - (get-language-name) - (regexp-replace #rx".*#(?:!|lang ) *" - (send defs-text get-text 0 (file-position i)) - "")))) - + (let ([defs-port (open-input-text-editor defs-text)]) + (with-handlers ((exn:fail? (λ (x) (void)))) + (let/ec k + (let ([orig-security (current-security-guard)]) + (parameterize ([current-security-guard + (make-security-guard + orig-security + (lambda (what path modes) #t) + (lambda (what host port mode) (k (void))))]) + (read-language defs-port (λ () (void))) + (void))))) + (let* ([str (send defs-text get-text 0 (file-position defs-port))] + [pos (regexp-match-positions #rx"#(?:!|lang )" str)]) + (cond + [(not pos) + (get-language-name)] + [else + (substring str (cdr (car pos)) (string-length str))])))) + (define/override (use-namespace-require/copy?) #f) (define/augment (capability-value key) (cond [(eq? key 'drscheme:autocomplete-words) (drscheme:language-configuration:get-all-manual-keywords)] + [(eq? key macro-stepper-capability-key) #t] [else (drscheme:language:get-capability-default key)])) ;; config-panel : as in super class @@ -342,7 +352,7 @@ (super-new [module #f] - [language-position (list module-language-name)] + [language-position (list (string-constant module-language-name))] [language-numbers (list -32768)]))) ;; can be called with #f to just kill the repl (in case we want to kill it diff --git a/collects/drscheme/tool-lib.ss b/collects/drscheme/tool-lib.ss index 20bbba2a76..25cd2ad39d 100644 --- a/collects/drscheme/tool-lib.ss +++ b/collects/drscheme/tool-lib.ss @@ -1167,7 +1167,7 @@ all of the names in the tools library, for use defining keybindings contract?) (s) @{Returns the contract for a given capability, which was specified - when @scheme[drscheme:langauge:register-capability] was called.}) + when @scheme[drscheme:language:register-capability] was called.}) ; diff --git a/collects/framework/private/editor.ss b/collects/framework/private/editor.ss index d76cd944d0..3c0b3537f7 100644 --- a/collects/framework/private/editor.ss +++ b/collects/framework/private/editor.ss @@ -350,7 +350,7 @@ (send style set-delta delta) (send standard-style-list new-named-style "Standard" (send standard-style-list find-or-create-style - (send standard-style-list find-named-style "Basic") + (send standard-style-list basic-style) delta))))) (let ([delta (make-object style-delta%)] diff --git a/collects/framework/private/text.ss b/collects/framework/private/text.ss index 8f3f76e4c4..e03702d6a8 100644 --- a/collects/framework/private/text.ss +++ b/collects/framework/private/text.ss @@ -771,7 +771,7 @@ WARNING: printf is rebound in the body of the unit to always (define/private (get-font) (let* ([style-list (get-style-list)] [std (or (send style-list find-named-style "Standard") - (send style-list find-named-style "Basic"))]) + (send style-list basic-style))]) (send std get-font))) (super-new))) @@ -2395,13 +2395,13 @@ WARNING: printf is rebound in the body of the unit to always (let ([style-list (get-style-list)]) (or (send style-list find-named-style sd) (send style-list find-named-style "Standard") - (send style-list find-named-style "Basic")))] + (send style-list basic-style)))] [sd (let* ([style-list (get-style-list)] [std (send style-list find-named-style "Standard")]) (if std (send style-list find-or-create-style std sd) - (let ([basic (send style-list find-named-style "Basic")]) + (let ([basic (send style-list basic-style)]) (send style-list find-or-create-style basic sd))))]))] [out-style (add-standard (get-out-style-delta))] [err-style (add-standard (get-err-style-delta))] diff --git a/collects/framework/test.ss b/collects/framework/test.ss index 860fe61b8a..1fe661a34d 100644 --- a/collects/framework/test.ss +++ b/collects/framework/test.ss @@ -205,8 +205,9 @@ (λ (window) (let ([frame (get-active-frame)]) (let loop ([window window]) - (cond [(null? window) #f] - [(eq? window frame) #t] + (cond [(not window) #f] + [(null? window) #f] ;; is this test needed? + [(eq? window frame) #t] [else (loop (send window get-parent))]))))) ;; diff --git a/collects/honu/main.ss b/collects/honu/main.ss index c45f275fa8..432aa38935 100644 --- a/collects/honu/main.ss +++ b/collects/honu/main.ss @@ -2,6 +2,8 @@ (require "private/honu-typed-scheme.ss" ;; "private/honu.ss" + "private/parse.ss" + "private/literals.ss" "private/macro.ss") (provide (rename-out (#%dynamic-honu-module-begin #%module-begin) diff --git a/collects/honu/private/honu-typed-scheme.ss b/collects/honu/private/honu-typed-scheme.ss index 62c9ba0d6f..a6ac03ad77 100644 --- a/collects/honu/private/honu-typed-scheme.ss +++ b/collects/honu/private/honu-typed-scheme.ss @@ -11,7 +11,9 @@ "contexts.ss" "util.ss" "ops.ss" + "parse.ss" ) + "literals.ss" ;; "typed-utils.ss" ) @@ -20,92 +22,11 @@ (provide (all-defined-out)) -;; macro for defining literal tokens that can be used in macros -(define-syntax-rule (define-literal name ...) - (begin - (define-syntax name (lambda (stx) - (raise-syntax-error 'name - "this is a literal and cannot be used outside a macro"))) - ...)) - -(define-literal honu-return) -(define-literal semicolon) -(define-literal honu-+ honu-* honu-/ honu-- honu-|| honu-% - honu-= honu-+= honu--= honu-*= honu-/= honu-%= - honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>= - honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->= - honu-? honu-: honu-comma) ;; (define-syntax (\; stx) (raise-syntax-error '\; "out of context" stx)) (begin-for-syntax -(define-values (prop:honu-transformer honu-transformer? honu-transformer-ref) - (make-struct-type-property 'honu-transformer)) - - -(define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!) - (make-struct-type 'honu-trans #f 1 0 #f - (list (list prop:honu-transformer #t)) - (current-inspector) 0)) - -(define (make-honu-transformer proc) - (unless (and (procedure? proc) - (procedure-arity-includes? proc 2)) - (raise-type-error - 'define-honu-syntax - "procedure (arity 2)" - proc)) - (make-honu-trans proc)) - - - -(define operator? - (let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")]) - (lambda (stx) - (and (identifier? stx) - (let ([str (symbol->string (syntax-e stx))]) - (and (positive? (string-length str)) - (memq (string-ref str 0) sym-chars))))))) - -;; returns a transformer or #f -(define (get-transformer stx) - ;; if its an identifier and bound to a transformer return it - (define (bound-transformer stx) - (and (stx-pair? stx) - (identifier? (stx-car stx)) - (let ([v (syntax-local-value (stx-car stx) (lambda () #f))]) - (and (honu-transformer? v) v)))) - (define (special-transformer stx) - (and (stx-pair? stx) - (let ([first (stx-car stx)]) - (cond - [(and (stx-pair? first) - (identifier? (stx-car first)) - (delim-identifier=? #'#%parens (stx-car first))) - ;; If the stx-car is a list with just one operator symbol, - ;; try using the operator as a transformer - (let ([l (cdr (stx->list first))]) - (let loop ([l l]) - (cond - [(null? l) #f] - [(operator? (car l)) - (if (ormap operator? (cdr l)) - #f - (let ([v (syntax-local-value (car l) (lambda () #f))]) - (and (honu-transformer? v) - v)))] - [else (loop (cdr l))])))] - [(and (stx-pair? first) - (identifier? (stx-car first)) - (free-identifier=? #'#%angles (stx-car first))) - (let ([v (syntax-local-value (stx-car first) (lambda () #f))]) - (and (honu-transformer? v) v))] - [else #f])))) - ;; (printf "~a bound transformer? ~a\n" stx (bound-transformer stx)) - (or (bound-transformer stx) - (special-transformer stx))) - ;; these functions use parse-block-one ;; (define parse-a-tail-expr #f) ;; (define parse-an-expr #f) @@ -358,159 +279,6 @@ x(2) |# - -(define (parse-block-one/2 stx context) - (define (parse-one stx context) - (define-syntax-class block - [pattern (#%braces statement ...) - #:with result #'(honu-unparsed-begin statement ...)]) - (define-syntax-class function - [pattern (type:id name:id (#%parens args ...) body:block . rest) - #:with result #'(define (name args ...) - body.result)]) - - (define (syntax-object-position mstart end) - (if (stx-null? end) - (length (syntax->list mstart)) - (let loop ([start mstart] - [count 0]) - ;; (printf "Checking ~a vs ~a\n" start end) - (cond - [(stx-null? start) (raise-syntax-error 'honu-macro "the `rest' syntax returned by a honu macro did not return objects at the same syntactic nesting level as the head of the pattern. this is probably because it returned syntax from some inner nesting level such as (if (x + 1 2) more-stuff) where `rest' was (+ 1 2) instead of `more-stuff'" end mstart)] - [(eq? (stx-car start) (stx-car end)) count] - ;; [(equal? start end) count] - [else (loop (stx-cdr start) (add1 count))])))) - - (define-primitive-splicing-syntax-class (expr) - #:attrs (result) - #:description "expr" - (lambda (stx fail) - (cond - [(stx-null? stx) (fail)] - [(get-transformer stx) => (lambda (transformer) - (let-values ([(used rest) - (transformer stx context)]) - (list rest (syntax-object-position stx rest) - used)))] - - [else (syntax-case stx () - [(f . rest) (list #'rest 1 #'f)])]))) - - #; - (define-splicing-syntax-class expr - [pattern (~seq f ...) #:with result]) - - (define-splicing-syntax-class call - #:literals (honu-comma) - [pattern (~seq e:expr (#%parens (~seq arg:ternary (~optional honu-comma)) ...)) - #:with call #'(e.result arg.result ...)]) - (define-splicing-syntax-class expression-last - [pattern (~seq call:call) #:with result #'call.call] - [pattern (~seq x:number) #:with result #'x] - [pattern (~seq e:expr) #:with result #'e.result] - ) - - (define-syntax-rule (define-infix-operator name next [operator reducer] ...) - (begin - (define-syntax-class operator-class - #:literals (operator ...) - (pattern operator #:attr func reducer) - ...) - (define-splicing-syntax-class name - (pattern (~seq (~var left next) - (~optional (~seq (~var op operator-class) (~var right name)))) - #:with result - (cond [(attribute right) - ((attribute op.func) #'left.result #'right.result)] - [else - #'left.result]))))) - - ;; (infix-operators ([honu-* ...] - ;; [honu-- ...]) - ;; ([honu-+ ...] - ;; [honu-- ...])) - ;; Where operators defined higher in the table have higher precedence. - (define-syntax (infix-operators stx) - (define (create-stuff names operator-stuff) - (define make (syntax-lambda (expression next-expression operator-stuff) - #; - (printf "Make infix ~a ~a\n" (syntax->datum #'expression) (syntax->datum #'next-expression)) - (with-syntax ([(ops ...) #'operator-stuff]) - #'(define-infix-operator expression next-expression ops ...)))) - (for/list ([name1 (drop-last names)] - [name2 (cdr names)] - [operator operator-stuff]) - (make name1 name2 operator))) - (syntax-case stx () - [(_ first last operator-stuff ...) - (with-syntax ([(name ...) (generate-temporaries #'(operator-stuff ...))]) - (with-syntax ([(result ...) (create-stuff (cons #'first - (append - (drop-last (syntax->list #'(name ...))) - (list #'last))) - - (syntax->list #'(operator-stuff ...)))]) - #'(begin - result ...)))])) - - ;; infix operators in the appropriate precedence level - ;; things defined lower in the table have a higher precedence. - ;; the first set of operators is `expression-1' - (splicing-let-syntax ([sl (make-rename-transformer #'syntax-lambda)]) - (infix-operators expression-1 expression-last - ([honu-= (sl (left right) #'(= left right))] - [honu-+= (sl (left right) #'(+ left right))] - [honu--= (sl (left right) #'(- left right))] - [honu-*= (sl (left right) #'(* left right))] - [honu-/= (sl (left right) #'(/ left right))] - [honu-%= (sl (left right) #'(modulo left right))] - [honu-&= (sl (left right) #'(+ left right))] - [honu-^= (sl (left right) #'(+ left right))] - [honu-\|= (sl (left right) #'(+ left right))] - [honu-<<= (sl (left right) #'(+ left right))] - [honu->>= (sl (left right) #'(+ left right))] - [honu->>>= (sl (left right) #'(+ left right))]) - ([honu-|| (sl (left right) #'(+ left right))]) - ([honu->> (sl (left right) #'(+ left right))] - [honu-<< (sl (left right) #'(+ left right))] - [honu->>> (sl (left right) #'(+ left right))] - [honu-< (sl (left right) #'(< left right))] - [honu-> (sl (left right) #'(> left right))] - [honu-<= (sl (left right) #'(<= left right))] - [honu->= (sl (left right) #'(>= left right))]) - ([honu-+ (sl (left right) #'(+ left right))] - [honu-- (sl (left right) #'(- left right))]) - ([honu-* (sl (left right) #'(* left right))] - [honu-% (sl (left right) #'(modulo left right))] - [honu-/ (sl (left right) #'(/ left right))]))) - - (define-splicing-syntax-class ternary - #:literals (honu-? honu-:) - [pattern (~seq condition:expression-1 (~optional (~seq honu-? on-true:ternary - honu-: on-false:ternary))) - #:with result - (cond [(attribute on-true) - #'(if condition.result on-true.result on-false.result)] - [else #'condition.result])]) - - (define-syntax-class expression-top - #:literals (semicolon) - [pattern (e:ternary semicolon . rest) - #:with result #'e.result]) - - ;; (printf "~a\n" (syntax-class-parse function stx)) - (syntax-parse stx - [function:function (values #'function.result #'function.rest)] - [expr:expression-top (values #'expr.result #'expr.rest)] - #; - [(x:number . rest) (values #'x #'rest)] - )) - (cond - [(stx-null? stx) (values stx '())] - [(get-transformer stx) => (lambda (transformer) - (transformer stx context))] - [else (parse-one stx context)])) - (define (parse-block stx ctx) (let loop ([stx stx]) (parse-block-one ctx @@ -528,10 +296,10 @@ x(2) ) (define-syntax (define-honu-syntax stx) - (let-values ([(id rhs) (normalize-definition stx #'lambda #f)]) - (with-syntax ([id id] - [rhs rhs]) - #'(define-syntax id (make-honu-transformer rhs))))) + (let-values ([(id rhs) (normalize-definition stx #'lambda #f)]) + (with-syntax ([id id] + [rhs rhs]) + #'(define-syntax id (make-honu-transformer rhs))))) #| diff --git a/collects/honu/private/literals.ss b/collects/honu/private/literals.ss new file mode 100644 index 0000000000..79b738ec32 --- /dev/null +++ b/collects/honu/private/literals.ss @@ -0,0 +1,20 @@ +#lang scheme + +(provide (all-defined-out)) + +;; macro for defining literal tokens that can be used in macros +(define-syntax-rule (define-literal name ...) + (begin + (define-syntax name (lambda (stx) + (raise-syntax-error 'name + "this is a literal and cannot be used outside a macro"))) + ...)) + +(define-literal honu-return) +(define-literal semicolon) +(define-literal honu-+ honu-* honu-/ honu-- honu-|| honu-% + honu-= honu-+= honu--= honu-*= honu-/= honu-%= + honu-&= honu-^= honu-\|= honu-<<= honu->>= honu->>>= + honu->> honu-<< honu->>> honu-< honu-> honu-<= honu->= + honu-? honu-: honu-comma) + diff --git a/collects/honu/private/parse.ss b/collects/honu/private/parse.ss new file mode 100644 index 0000000000..f591b76332 --- /dev/null +++ b/collects/honu/private/parse.ss @@ -0,0 +1,236 @@ +#lang scheme + +(require "contexts.ss" + "util.ss" + (for-template "literals.ss") + syntax/parse + syntax/parse/experimental + scheme/splicing + syntax/stx + (for-syntax "util.ss") + (for-template scheme/base)) + +(provide (all-defined-out)) + +(define-syntax-class block + [pattern (#%braces statement ...) + #:with result (parse-block-one/2 #'(statement ...) the-block-context)]) + +(define-syntax-class function + [pattern (type:id name:id (#%parens args ...) body:block . rest) + #:with result #'(define (name args ...) + body.result)]) + +(define (syntax-object-position mstart end) + (if (stx-null? end) + (length (syntax->list mstart)) + (let loop ([start mstart] + [count 0]) + ;; (printf "Checking ~a vs ~a\n" start end) + (cond + [(stx-null? start) (raise-syntax-error 'honu-macro "the `rest' syntax returned by a honu macro did not return objects at the same syntactic nesting level as the head of the pattern. this is probably because it returned syntax from some inner nesting level such as (if (x + 1 2) more-stuff) where `rest' was (+ 1 2) instead of `more-stuff'" end mstart)] + [(eq? (stx-car start) (stx-car end)) count] + ;; [(equal? start end) count] + [else (loop (stx-cdr start) (add1 count))])))) + +(define-primitive-splicing-syntax-class (honu-expr context) + #:attrs (result) + #:description "honu-expr" + (lambda (stx fail) + (cond + [(stx-null? stx) (fail)] + [(get-transformer stx) => (lambda (transformer) + (let-values ([(used rest) + (transformer stx context)]) + (list rest (syntax-object-position stx rest) + used)))] + + [else (syntax-case stx () + [(f . rest) (list #'rest 1 #'f)])]))) + + #; + (define-splicing-syntax-class expr + [pattern (~seq f ...) #:with result]) + +(define-splicing-syntax-class (call context) + #:literals (honu-comma) + [pattern (~seq (~var e (honu-expr context)) (#%parens (~seq (~var arg (ternary context)) + (~optional honu-comma)) ...)) + #:with call #'(e.result arg.result ...)]) + +(define-splicing-syntax-class (expression-last context) + [pattern (~seq (~var call (call context))) #:with result #'call.call] + [pattern (~seq x:number) #:with result #'x] + [pattern (~seq (~var e (honu-expr context))) #:with result #'e.result] + ) + +(define-syntax-rule (define-infix-operator name next [operator reducer] ...) + (begin + (define-syntax-class operator-class + #:literals (operator ...) + (pattern operator #:attr func reducer) + ...) + (define-splicing-syntax-class (name context) + (pattern (~seq (~var left (next context)) + (~optional (~seq (~var op operator-class) (~var right (name context))))) + #:with result + (cond [(attribute right) + ((attribute op.func) #'left.result #'right.result)] + [else + #'left.result]))))) + +;; (infix-operators ([honu-* ...] +;; [honu-- ...]) +;; ([honu-+ ...] +;; [honu-- ...])) +;; Where operators defined higher in the table have higher precedence. +(define-syntax (infix-operators stx) + (define (create-stuff names operator-stuff) + (define make (syntax-lambda (expression next-expression operator-stuff) + #; + (printf "Make infix ~a ~a\n" (syntax->datum #'expression) (syntax->datum #'next-expression)) + (with-syntax ([(ops ...) #'operator-stuff]) + #'(define-infix-operator expression next-expression ops ...)))) + (for/list ([name1 (drop-last names)] + [name2 (cdr names)] + [operator operator-stuff]) + (make name1 name2 operator))) + (syntax-case stx () + [(_ first last operator-stuff ...) + (with-syntax ([(name ...) (generate-temporaries #'(operator-stuff ...))]) + (with-syntax ([(result ...) (create-stuff (cons #'first + (append + (drop-last (syntax->list #'(name ...))) + (list #'last))) + + (syntax->list #'(operator-stuff ...)))]) + #'(begin + result ...)))])) + +;; infix operators in the appropriate precedence level +;; things defined lower in the table have a higher precedence. +;; the first set of operators is `expression-1' +(splicing-let-syntax ([sl (make-rename-transformer #'syntax-lambda)]) + (infix-operators expression-1 expression-last + ([honu-= (sl (left right) #'(= left right))] + [honu-+= (sl (left right) #'(+ left right))] + [honu--= (sl (left right) #'(- left right))] + [honu-*= (sl (left right) #'(* left right))] + [honu-/= (sl (left right) #'(/ left right))] + [honu-%= (sl (left right) #'(modulo left right))] + [honu-&= (sl (left right) #'(+ left right))] + [honu-^= (sl (left right) #'(+ left right))] + [honu-\|= (sl (left right) #'(+ left right))] + [honu-<<= (sl (left right) #'(+ left right))] + [honu->>= (sl (left right) #'(+ left right))] + [honu->>>= (sl (left right) #'(+ left right))]) + ([honu-|| (sl (left right) #'(+ left right))]) + ([honu->> (sl (left right) #'(+ left right))] + [honu-<< (sl (left right) #'(+ left right))] + [honu->>> (sl (left right) #'(+ left right))] + [honu-< (sl (left right) #'(< left right))] + [honu-> (sl (left right) #'(> left right))] + [honu-<= (sl (left right) #'(<= left right))] + [honu->= (sl (left right) #'(>= left right))]) + ([honu-+ (sl (left right) #'(+ left right))] + [honu-- (sl (left right) #'(- left right))]) + ([honu-* (sl (left right) #'(* left right))] + [honu-% (sl (left right) #'(modulo left right))] + [honu-/ (sl (left right) #'(/ left right))]))) + + (define-splicing-syntax-class (ternary context) + #:literals (honu-? honu-:) + [pattern (~seq (~var condition (expression-1 context)) + (~optional (~seq honu-? (~var on-true (ternary context)) + honu-: (~var on-false (ternary context))))) + #:with result + (cond [(attribute on-true) + #'(if condition.result on-true.result on-false.result)] + [else #'condition.result])]) + + (define-syntax-class (expression-top context) + #:literals (semicolon) + [pattern ((~var e (ternary context)) semicolon . rest) + #:with result #'e.result]) + + +(define (parse-block-one/2 stx context) + (define (parse-one stx context) + + ;; (printf "~a\n" (syntax-class-parse function stx)) + (syntax-parse stx + [function:function (values #'function.result #'function.rest)] + [(~var expr (expression-top context)) (values #'expr.result #'expr.rest)] + #; + [(x:number . rest) (values #'x #'rest)] + )) + (cond + [(stx-null? stx) (values stx '())] + [(get-transformer stx) => (lambda (transformer) + (transformer stx context))] + [else (parse-one stx context)])) + +(define-values (prop:honu-transformer honu-transformer? honu-transformer-ref) + (make-struct-type-property 'honu-transformer)) + +(define operator? + (let ([sym-chars (string->list "+-_=?:<>.!%^&*/~|")]) + (lambda (stx) + (and (identifier? stx) + (let ([str (symbol->string (syntax-e stx))]) + (and (positive? (string-length str)) + (memq (string-ref str 0) sym-chars))))))) + + +(define-values (struct:honu-trans make-honu-trans honu-trans? honu-trans-ref honu-trans-set!) + (make-struct-type 'honu-trans #f 1 0 #f + (list (list prop:honu-transformer #t)) + (current-inspector) 0)) + +(define (make-honu-transformer proc) + (unless (and (procedure? proc) + (procedure-arity-includes? proc 2)) + (raise-type-error + 'define-honu-syntax + "procedure (arity 2)" + proc)) + (make-honu-trans proc)) + + +;; returns a transformer or #f +(define (get-transformer stx) + ;; if its an identifier and bound to a transformer return it + (define (bound-transformer stx) + (and (stx-pair? stx) + (identifier? (stx-car stx)) + (let ([v (syntax-local-value (stx-car stx) (lambda () #f))]) + (and (honu-transformer? v) v)))) + (define (special-transformer stx) + (and (stx-pair? stx) + (let ([first (stx-car stx)]) + (cond + [(and (stx-pair? first) + (identifier? (stx-car first)) + (delim-identifier=? #'#%parens (stx-car first))) + ;; If the stx-car is a list with just one operator symbol, + ;; try using the operator as a transformer + (let ([l (cdr (stx->list first))]) + (let loop ([l l]) + (cond + [(null? l) #f] + [(operator? (car l)) + (if (ormap operator? (cdr l)) + #f + (let ([v (syntax-local-value (car l) (lambda () #f))]) + (and (honu-transformer? v) + v)))] + [else (loop (cdr l))])))] + [(and (stx-pair? first) + (identifier? (stx-car first)) + (free-identifier=? #'#%angles (stx-car first))) + (let ([v (syntax-local-value (stx-car first) (lambda () #f))]) + (and (honu-transformer? v) v))] + [else #f])))) + ;; (printf "~a bound transformer? ~a\n" stx (bound-transformer stx)) + (or (bound-transformer stx) + (special-transformer stx))) diff --git a/collects/lang/private/beginner-funs.ss b/collects/lang/private/beginner-funs.ss index 35b4ced974..6b8313f0a0 100644 --- a/collects/lang/private/beginner-funs.ss +++ b/collects/lang/private/beginner-funs.ss @@ -468,7 +468,7 @@ ("Misc" (identity (any -> any) "to return the argument unchanged") - ((beginner-error error) (any ... -> void) "to signal an error, turning the given values into an error message ") + ((beginner-error error) (any ... -> void) "to signal an error, combining the given values into an error message.\n\nIf any of the values' printed representations is too long, it is truncated and ``...'' is put into the string. If the first value is a symbol, it is treated specially; it is suffixed with a colon and a space (the intention is that the symbol is the name of the function signalling the error).") ((beginner-struct? struct?) (any -> boolean) "to determine whether some value is a structure") ((beginner-equal? equal?) (any any -> boolean) diff --git a/collects/lang/private/teachprims.ss b/collects/lang/private/teachprims.ss index 83d9800aa9..e1c1be29e0 100644 --- a/collects/lang/private/teachprims.ss +++ b/collects/lang/private/teachprims.ss @@ -2,7 +2,7 @@ collects/tests/mzscheme/beginner.ss .../beginner-abbr.ss .../intermediate.ss - .../intermediate-lam.ss + .../intermediate-lambda.ss .../advanced.ss Each one has to run separately, since they mangle the top-level @@ -197,25 +197,13 @@ namespace. (if (and (cons? stuff0) (symbol? (first stuff0))) (values (first stuff0) (rest stuff0)) (values false stuff0))) - (define str - (let loop ([stuff stuff1][frmt ""][pieces '()]) - (cond - [(empty? stuff) (apply format frmt (reverse pieces))] - [else - (let ([f (first stuff)] - [r (rest stuff)]) - (if (string? f) - (loop r (string-append frmt f) pieces) - (loop r (string-append frmt "~e") (cons f pieces))))]))) - (if f (error f str) (error str))) - #; - (lambda (str) - (unless (string? str) - (raise - (make-exn:fail:contract - (format "error: expected a string, got ~e and ~e" str) - (current-continuation-marks)))) - (error str))) + (error (apply + string-append + (if f (format "~a: " f) "") + (for/list ([ele (in-list stuff1)]) + (if (string? ele) + ele + (format "~e" ele))))))) (define-teach beginner struct? (lambda (x) diff --git a/collects/macro-debugger/capability.ss b/collects/macro-debugger/capability.ss new file mode 100644 index 0000000000..506f1afbbc --- /dev/null +++ b/collects/macro-debugger/capability.ss @@ -0,0 +1,7 @@ +#lang scheme/base + +(provide macro-stepper-capability-key) + +(define macro-stepper-capability-key + (string->uninterned-symbol "Enable Macro Stepper")) + diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss index 0524d45045..7b864cc291 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -8,6 +8,7 @@ drscheme/tool mrlib/switchable-button string-constants + "capability.ss" "model/trace.ss" "model/deriv.ss" "model/deriv-util.ss" @@ -16,12 +17,7 @@ "view/stepper.ss" "view/prefs.ss") -(provide tool@ - language/macro-stepper<%>) - -(define language/macro-stepper<%> - (interface () - enable-macro-stepper?)) +(provide tool@) (define-local-member-name allow-macro-stepper?) (define-local-member-name run-macro-stepper) @@ -85,13 +81,10 @@ (export drscheme:tool-exports^) (define (phase1) - (drscheme:language:extend-language-interface - language/macro-stepper<%> - (mixin (drscheme:language:language<%>) (language/macro-stepper<%>) - (inherit get-language-position) - (define/public (enable-macro-stepper?) - (macro-stepper-works-for? (get-language-position))) - (super-new)))) + (drscheme:language:register-capability + macro-stepper-capability-key + boolean? + #f)) (define (phase2) (void)) (define drscheme-eventspace (current-eventspace)) @@ -170,7 +163,7 @@ (let ([lang (drscheme:language-configuration:language-settings-language (send (get-definitions-text) get-next-settings))]) - (send lang enable-macro-stepper?))) + (send lang capability-value macro-stepper-capability-key))) (define/private (enable/disable-stuff enable?) (if enable? @@ -304,19 +297,6 @@ (send director add-trace events)) )) - ;; Borrowed from mztake/debug-tool.ss - - (define (macro-stepper-works-for? lang) - (let ([main-group (car lang)] - [second (and (pair? (cdr lang)) (cadr lang))] - [third (and (pair? (cdr lang)) (pair? (cddr lang)) (caddr lang))]) - (or (equal? main-group "Module") - (and (equal? main-group (string-constant legacy-languages)) - (or (member second - (list (string-constant r5rs-language-name) - "Swindle" - (string-constant pretty-big-scheme)))))))) - ;; Macro debugger code (drscheme:get/extend:extend-unit-frame diff --git a/collects/mred/private/mrcanvas.ss b/collects/mred/private/mrcanvas.ss index e8e82e196e..b99d8496ec 100644 --- a/collects/mred/private/mrcanvas.ss +++ b/collects/mred/private/mrcanvas.ss @@ -260,6 +260,10 @@ [(on?) (set! force-focus? (and on? #t)) (send wx force-display-focus on?)]))] + [accept-tab-focus (entry-point + (case-lambda + [() (send wx get-tab-focus)] + [(on?) (send wx set-tab-focus (and on? #t))]))] [allow-tab-exit (entry-point (case-lambda [() (send wx is-tabable?)] diff --git a/collects/mred/private/wxcanvas.ss b/collects/mred/private/wxcanvas.ss index 806328a5a7..8465573275 100644 --- a/collects/mred/private/wxcanvas.ss +++ b/collects/mred/private/wxcanvas.ss @@ -14,7 +14,7 @@ wx-canvas% wx-editor-canvas%)) - (define (make-canvas-glue% %) ; implies make-window-glue% + (define (make-canvas-glue% default-tabable? %) ; implies make-window-glue% (class100 (make-window-glue% %) (mred proxy . args) (inherit get-mred get-top-level clear-margins) (public @@ -22,6 +22,22 @@ [do-on-event (lambda (e) (super on-event e))] [do-on-scroll (lambda (e) (super on-scroll e))] [do-on-paint (lambda () (super on-paint))]) + (private-field + [tabable? default-tabable?]) + (public + [get-tab-focus (lambda () tabable?)] + [set-tab-focus (lambda (v) (set! tabable? v))] + [on-tab-in (lambda () + (let ([mred (wx->mred this)]) + (when mred + (send mred on-tab-in))))]) + (override + [gets-focus? (lambda () tabable?)] + [handles-key-code + (lambda (code alpha? meta?) + (if default-tabable? + (super handles-key-code code alpha? meta?) + (or meta? (not tabable?))))]) (private [clear-and-on-paint (lambda (mred) @@ -68,20 +84,11 @@ (define wx-canvas% (make-canvas-glue% + #f (class100 (make-control% wx:canvas% 0 0 #t #t) (parent x y w h style gl-config) (inherit get-top-level) - (private-field - [tabable? #f]) (public - [clear-margins (lambda () (void))] - [on-tab-in (lambda () (send (wx->mred this) on-tab-in))] - [get-tab-focus (lambda () tabable?)] - [set-tab-focus (lambda (v) (set! tabable? v))]) - (override - [gets-focus? (lambda () tabable?)] - [handles-key-code - (lambda (code alpha? meta?) - (or meta? (not tabable?)))]) + [clear-margins (lambda () (void))]) (sequence (super-init style parent x y w h (cons 'deleted style) "canvas" gl-config) (unless (memq 'deleted style) @@ -163,10 +170,6 @@ (public [set-tabable (lambda (on?) (set! tabable? on?))] [is-tabable? (lambda () tabable?)] - [on-tab-in (lambda () - (let ([mred (wx->mred this)]) - (when mred - (send mred on-tab-in))))] [set-single-line (lambda () (set! single-line-canvas? #t))] [is-single-line? (lambda () single-line-canvas?)] [set-line-count (lambda (n) @@ -220,6 +223,7 @@ (define wx-editor-canvas% (class (make-canvas-glue% + #t (make-editor-canvas% (make-control% wx:editor-canvas% 0 0 #t #t))) (inherit editor-canvas-on-scroll) diff --git a/collects/mred/private/wxme/style.ss b/collects/mred/private/wxme/style.ss index 8bb830a326..092951786d 100644 --- a/collects/mred/private/wxme/style.ss +++ b/collects/mred/private/wxme/style.ss @@ -1,5 +1,6 @@ #lang scheme/base (require scheme/class + scheme/file (for-syntax scheme/base) "../syntax.ss" "cycle.ss" @@ -18,9 +19,10 @@ write-styles-to-file) (define default-size - (case (system-type) - [(windows) 10] - [else 12])) + (or (get-preference 'MrEd:default-font-size) + (case (system-type) + [(windows) 10] + [else 12]))) (define black-color (make-object color% 0 0 0)) diff --git a/collects/mrlib/hierlist/hierlist-unit.ss b/collects/mrlib/hierlist/hierlist-unit.ss index b06a7ed114..266efa79a5 100644 --- a/collects/mrlib/hierlist/hierlist-unit.ss +++ b/collects/mrlib/hierlist/hierlist-unit.ss @@ -720,10 +720,14 @@ [i (send i select #t) (send i scroll-to)] - [(and (allow-deselect) selected) - (send selected show-select #f) - (set! selected #f) - (set! selected-item #f)]))] + [(allow-deselect) + (when selected + (send selected show-select #f) + (set! selected #f) + (set! selected-item #f))] + [else + (error 'hierarchical-list%::select + "can only pass #f when allow-deselect has been called with #t")]))] [click-select (lambda (i) (send i click-select #t) (send i scroll-to))] diff --git a/collects/mrlib/text-string-style-desc.ss b/collects/mrlib/text-string-style-desc.ss index 9c1671adf0..906e943b3a 100644 --- a/collects/mrlib/text-string-style-desc.ss +++ b/collects/mrlib/text-string-style-desc.ss @@ -1,90 +1,89 @@ -(module text-string-style-desc mzscheme - (provide get-string/style-desc) - (require mred - mzlib/etc - mzlib/class) - - ;; get-string/style-desc : text -> (listof str/ann) - (define get-string/style-desc - (opt-lambda (text [start 0] [end (send text last-position)]) - (let* ([snips (get-snips text start end)] - [str/ann (map snip->str/ann snips)] - [joined-str/ann (join-like str/ann)]) - joined-str/ann))) - - ;; get-snips : text -> (listof snip) - ;; extracts the snips from a text - (define (get-snips text start end) - (send text split-snip start) - (send text split-snip end) - (let loop ([snip (send text find-snip start 'after-or-none)]) - (cond - [(not snip) null] - [(< (send text get-snip-position snip) end) - (cons snip (loop (send snip next)))] - [else null]))) - - ;; snip->str/ann : snip -> str/ann - ;; extracts the style type from the snip - (define (snip->str/ann snip) - (let* ([str (cond - [(is-a? snip string-snip%) - (send snip get-text 0 (send snip get-count))] - [(is-a? snip image-snip%) - 'image] - [else 'unknown])] - [style (send snip get-style)] - [style-name (send style get-name)] - [style-desc (if style-name - (translate-name style-name) - (describe-style style))]) - (list str style-desc))) - - ;; describe-style : style -> (listof symbol) - (define (describe-style style) - (list - 'alignment (send style get-alignment) - 'background (symbolic-color (send style get-background)) - 'face (send style get-face) - 'family (send style get-family) - 'foreground (symbolic-color (send style get-foreground)) - 'size (send style get-size) - 'underlined (send style get-underlined))) - - (define (symbolic-color color) - (list (send color red) - (send color green) - (send color blue))) +#lang scheme/base - ;; translate-name : (union #f string) -> symbol - ;; translates the style name to a symbol - (define (translate-name str) - (and str - (let ([m (regexp-match re:translate-name str)]) - (and m - (string->symbol (cadr m)))))) - - ;; re:translate-name : regexp - (define re:translate-name (regexp "^.*:([^:]*)$")) - - ;; join-like : (listof str/ann) -> (listof str/ann) - ;; joins same styles to form largest groups - (define (join-like str/anns) +(provide get-string/style-desc) +(require scheme/gui/base + scheme/class) + +;; get-string/style-desc : text -> (listof str/ann) +(define (get-string/style-desc text [start 0] [end (send text last-position)]) + (let* ([snips (get-snips text start end)] + [str/ann (map snip->str/ann snips)] + [joined-str/ann (join-like str/ann)]) + joined-str/ann)) + +;; get-snips : text -> (listof snip) +;; extracts the snips from a text +(define (get-snips text start end) + (send text split-snip start) + (send text split-snip end) + (let loop ([snip (send text find-snip start 'after-or-none)]) (cond - [(null? str/anns) null] - [else - (let loop ([first (car str/anns)] - [rest (cdr str/anns)]) - (cond - [(null? rest) (list first)] - [else - (let ([second (car rest)]) - (if (and (equal? (cadr first) (cadr second)) - (string? (car first)) - (string? (car second))) - (loop (list (string-append (car first) (car second)) - (cadr first)) - (cdr rest)) - (cons first - (loop second - (cdr rest)))))]))]))) + [(not snip) null] + [(< (send text get-snip-position snip) end) + (cons snip (loop (send snip next)))] + [else null]))) + +;; snip->str/ann : snip -> str/ann +;; extracts the style type from the snip +(define (snip->str/ann snip) + (let* ([str (cond + [(is-a? snip string-snip%) + (send snip get-text 0 (send snip get-count))] + [(is-a? snip image-snip%) + 'image] + [else 'unknown])] + [style (send snip get-style)] + [style-name (send style get-name)] + [style-desc (if style-name + (translate-name style-name) + (describe-style style))]) + (list str style-desc))) + +;; describe-style : style -> (listof symbol) +(define (describe-style style) + (list + 'alignment (send style get-alignment) + 'background (symbolic-color (send style get-background)) + 'face (send style get-face) + 'family (send style get-family) + 'foreground (symbolic-color (send style get-foreground)) + 'size (send style get-size) + 'underlined (send style get-underlined))) + +(define (symbolic-color color) + (list (send color red) + (send color green) + (send color blue))) + +;; translate-name : (union #f string) -> symbol +;; translates the style name to a symbol +(define (translate-name str) + (and str + (let ([m (regexp-match re:translate-name str)]) + (and m + (string->symbol (cadr m)))))) + +;; re:translate-name : regexp +(define re:translate-name (regexp "^.*:([^:]*)$")) + +;; join-like : (listof str/ann) -> (listof str/ann) +;; joins same styles to form largest groups +(define (join-like str/anns) + (cond + [(null? str/anns) null] + [else + (let loop ([first (car str/anns)] + [rest (cdr str/anns)]) + (cond + [(null? rest) (list first)] + [else + (let ([second (car rest)]) + (if (and (equal? (cadr first) (cadr second)) + (string? (car first)) + (string? (car second))) + (loop (list (string-append (car first) (car second)) + (cadr first)) + (cdr rest)) + (cons first + (loop second + (cdr rest)))))]))])) diff --git a/collects/redex/private/fresh.ss b/collects/redex/private/fresh.ss new file mode 100644 index 0000000000..a4c31fd005 --- /dev/null +++ b/collects/redex/private/fresh.ss @@ -0,0 +1,59 @@ +#lang scheme + +(define re:gen-d #rx".*[^0-9]([0-9]+)$") +(define (variable-not-in sexp var) + (let* ([var-str (symbol->string var)] + [var-prefix (let ([m (regexp-match #rx"^(.*[^0-9])[0-9]+$" var-str)]) + (if m + (cadr m) + var-str))] + [found-exact-var? #f] + [nums (let loop ([sexp sexp] + [nums null]) + (cond + [(pair? sexp) (loop (cdr sexp) (loop (car sexp) nums))] + [(symbol? sexp) + (when (eq? sexp var) + (set! found-exact-var? #t)) + (let* ([str (symbol->string sexp)] + [match (regexp-match re:gen-d str)]) + (if (and match + (is-prefix? var-prefix str)) + (cons (string->number (cadr match)) nums) + nums))] + [else nums]))]) + (cond + [(not found-exact-var?) var] + [(null? nums) (string->symbol (format "~a1" var))] + [else (string->symbol (format "~a~a" var-prefix (find-best-number nums)))]))) + +(define (find-best-number nums) + (let loop ([sorted (sort nums <)] + [i 1]) + (cond + [(empty? sorted) i] + [else + (let ([fst (car sorted)]) + (cond + [(< i fst) i] + [(> i fst) (loop (cdr sorted) i)] + [(= i fst) (loop (cdr sorted) (+ i 1))]))]))) + +(define (variables-not-in sexp vars) + (let loop ([vars vars] + [sexp sexp]) + (cond + [(null? vars) null] + [else + (let ([new-var (variable-not-in sexp (car vars))]) + (cons new-var + (loop (cdr vars) + (cons new-var sexp))))]))) + +(define (is-prefix? str1 str2) + (and (<= (string-length str1) (string-length str2)) + (equal? str1 (substring str2 0 (string-length str1))))) + +(provide/contract + [variable-not-in (any/c symbol? . -> . symbol?)] + [variables-not-in (any/c (listof symbol?) . -> . (listof symbol?))]) \ No newline at end of file diff --git a/collects/redex/private/pict.ss b/collects/redex/private/pict.ss index 83006b1449..2eeb5a549a 100644 --- a/collects/redex/private/pict.ss +++ b/collects/redex/private/pict.ss @@ -3,7 +3,8 @@ (lib "utils.ss" "texpict") scheme/gui/base scheme/class - (only-in scheme/list drop-right last) + scheme/match + (only-in scheme/list drop-right last partition) "reduction-semantics.ss" "struct.ss" "loc-wrapper.ss" @@ -793,20 +794,24 @@ [scs (map (lambda (eqn) (if (null? (list-ref eqn 1)) #f - (side-condition-pict null - (map (lambda (p) - (if (pair? p) - (cons (wrapper->pict (car p)) - (wrapper->pict (cdr p))) - (wrapper->pict p))) - (list-ref eqn 1)) - (if (memq style '(up-down/vertical-side-conditions - left-right/vertical-side-conditions)) - 0 - (if (memq style '(up-down/compact-side-conditions - left-right/compact-side-conditions)) - max-line-w/pre-sc - +inf.0))))) + (let-values ([(fresh where/sc) (partition metafunc-extra-fresh? (list-ref eqn 1))]) + (side-condition-pict (foldl (λ (clause picts) + (foldr (λ (l ps) (cons (wrapper->pict l) ps)) + picts (metafunc-extra-fresh-vars clause))) + '() fresh) + (map (match-lambda + [(struct metafunc-extra-where (lhs rhs)) + (cons (wrapper->pict lhs) (wrapper->pict rhs))] + [(struct metafunc-extra-side-cond (expr)) + (wrapper->pict expr)]) + where/sc) + (if (memq style '(up-down/vertical-side-conditions + left-right/vertical-side-conditions)) + 0 + (if (memq style '(up-down/compact-side-conditions + left-right/compact-side-conditions)) + max-line-w/pre-sc + +inf.0)))))) eqns)]) (case style [(left-right left-right/vertical-side-conditions left-right/compact-side-conditions left-right/beside-side-conditions) diff --git a/collects/redex/private/reduction-semantics.ss b/collects/redex/private/reduction-semantics.ss index d9204af898..c71664ba42 100644 --- a/collects/redex/private/reduction-semantics.ss +++ b/collects/redex/private/reduction-semantics.ss @@ -3,6 +3,7 @@ (require "matcher.ss" "struct.ss" "term.ss" + "fresh.ss" "loc-wrapper.ss" "error.ss" mzlib/trace @@ -1016,6 +1017,11 @@ (define-struct metafunc-case (cp rhs lhs-pat src-loc id)) +;; Intermediate structures recording clause "extras" for typesetting. +(define-struct metafunc-extra-side-cond (expr)) +(define-struct metafunc-extra-where (lhs rhs)) +(define-struct metafunc-extra-fresh (vars)) + (define-syntax (in-domain? stx) (syntax-case stx () [(_ (name exp ...)) @@ -1249,11 +1255,25 @@ (map (λ (hm) (map (λ (lst) - (syntax-case lst (side-condition where) + (syntax-case lst (side-condition where unquote) + [(where pat (unquote (f _ _))) + (and (or (identifier? #'pat) + (andmap identifier? (syntax->list #'pat))) + (or (free-identifier=? #'f #'variable-not-in) + (free-identifier=? #'f #'variables-not-in))) + (with-syntax ([(ids ...) + (map to-lw/proc + (if (identifier? #'pat) + (list #'pat) + (syntax->list #'pat)))]) + #`(make-metafunc-extra-fresh + (list ids ...)))] [(where pat exp) - #`(cons #,(to-lw/proc #'pat) #,(to-lw/proc #'exp))] + #`(make-metafunc-extra-where + #,(to-lw/proc #'pat) #,(to-lw/proc #'exp))] [(side-condition x) - (to-lw/uq/proc #'x)])) + #`(make-metafunc-extra-side-cond + #,(to-lw/uq/proc #'x))])) (reverse (syntax->list hm)))) (syntax->list #'(... seq-of-tl-side-cond/binds)))] @@ -1265,8 +1285,8 @@ [(x-lhs-for-lw ...) #'(... seq-of-lhs-for-lw)]) #'(list (list x-lhs-for-lw - (list (cons bind-id/lw bind-pat/lw) ... - (cons rhs-bind-id/lw rhs-bind-pat/lw/uq) ... + (list (make-metafunc-extra-where bind-id/lw bind-pat/lw) ... + (make-metafunc-extra-where rhs-bind-id/lw rhs-bind-pat/lw/uq) ... where/sc/lw ...) rhs/lw) ...)))]) @@ -1713,9 +1733,9 @@ [(_ name orig-lang (names rhs ...) ...) (begin (unless (identifier? (syntax name)) - (raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'name)) + (raise-syntax-error 'define-extended-language "expected an identifier" stx #'name)) (unless (identifier? (syntax orig-lang)) - (raise-syntax-error 'define-extended-langauge "expected an identifier" stx #'orig-lang)) + (raise-syntax-error 'define-extended-language "expected an identifier" stx #'orig-lang)) (check-rhss-not-empty stx (cdddr (syntax->list stx))) (let ([old-names (language-id-nts #'orig-lang 'define-extended-language)]) (with-syntax ([((new-nt-names orig) ...) (append (pull-out-names 'define-language stx #'(names ...)) @@ -1943,61 +1963,6 @@ (cons this-one (loop (cdr l))) (loop (cdr l))))]))) -(define re:gen-d #rx".*[^0-9]([0-9]+)$") -(define (variable-not-in sexp var) - (let* ([var-str (symbol->string var)] - [var-prefix (let ([m (regexp-match #rx"^(.*[^0-9])[0-9]+$" var-str)]) - (if m - (cadr m) - var-str))] - [found-exact-var? #f] - [nums (let loop ([sexp sexp] - [nums null]) - (cond - [(pair? sexp) (loop (cdr sexp) (loop (car sexp) nums))] - [(symbol? sexp) - (when (eq? sexp var) - (set! found-exact-var? #t)) - (let* ([str (symbol->string sexp)] - [match (regexp-match re:gen-d str)]) - (if (and match - (is-prefix? var-prefix str)) - (cons (string->number (cadr match)) nums) - nums))] - [else nums]))]) - (cond - [(not found-exact-var?) var] - [(null? nums) (string->symbol (format "~a1" var))] - [else (string->symbol (format "~a~a" var-prefix (find-best-number nums)))]))) - -(define (find-best-number nums) - (let loop ([sorted (sort nums <)] - [i 1]) - (cond - [(empty? sorted) i] - [else - (let ([fst (car sorted)]) - (cond - [(< i fst) i] - [(> i fst) (loop (cdr sorted) i)] - [(= i fst) (loop (cdr sorted) (+ i 1))]))]))) - -(define (variables-not-in sexp vars) - (let loop ([vars vars] - [sexp sexp]) - (cond - [(null? vars) null] - [else - (let ([new-var (variable-not-in sexp (car vars))]) - (cons new-var - (loop (cdr vars) - (cons new-var sexp))))]))) - -(define (is-prefix? str1 str2) - (and (<= (string-length str1) (string-length str2)) - (equal? str1 (substring str2 0 (string-length str1))))) - - (define (reduction-relation->rule-names x) (reverse (reduction-relation-rule-names x))) @@ -2169,6 +2134,10 @@ metafunc-proc? (struct-out metafunc-case) + (struct-out metafunc-extra-side-cond) + (struct-out metafunc-extra-where) + (struct-out metafunc-extra-fresh) + (struct-out binds)) (provide test-match diff --git a/collects/redex/private/rewrite-side-conditions.ss b/collects/redex/private/rewrite-side-conditions.ss index e0db2ae638..7620363269 100644 --- a/collects/redex/private/rewrite-side-conditions.ss +++ b/collects/redex/private/rewrite-side-conditions.ss @@ -62,7 +62,7 @@ [(variable-prefix a ...) (expected-exact 'variable-prefix 1 term)] [variable-prefix (expected-arguments 'variable-prefix term)] [hole term] - [(name x y) #`(name #,(loop #'x) #,(loop #'y))] + [(name x y) #`(name x #,(loop #'y))] [(name x ...) (expected-exact 'name 2 term)] [name (expected-arguments 'name term)] [(in-hole a b) #`(in-hole #,(loop #'a) #,(loop #'b))] diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index b9817cf770..e93860036c 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -45,17 +45,18 @@ (list->string (build-list length (λ (_) (pick-char attempt random)))))) (define (pick-any lang sexp [random random]) - (let ([c-lang (rg-lang-clang lang)] - [c-sexp (rg-lang-clang sexp)]) - (if (and (not (null? (compiled-lang-lang c-lang))) (zero? (random 5))) - (values lang (pick-from-list (map nt-name (compiled-lang-lang c-lang)) random)) - (values sexp (nt-name (car (compiled-lang-lang c-sexp))))))) + (if (and (> (dict-count (rg-lang-non-cross lang)) 0) (zero? (random 5))) + (let ([nts (rg-lang-non-cross lang)]) + (values lang (pick-from-list (dict-map nts (λ (nt _) nt)) random))) + (values sexp 'sexp))) (define (pick-string lang-lits attempt [random random]) (random-string lang-lits (random-natural 1/5 random) attempt random)) -(define (pick-nts name cross? lang attempt) - (nt-rhs (nt-by-name lang name cross?))) +;; next-non-terminal-decision selects a subset of a non-terminal's productions. +;; This implementation, the default, chooses them all, but many of the +;; generator's test cases restrict the productions. +(define pick-nts values) (define (pick-from-list l [random random]) (list-ref l (random (length l)))) @@ -132,19 +133,15 @@ (define (pick-sequence-length attempt) (random-natural (expected-value->p (attempt->size attempt)))) -(define (zip . lists) - (apply (curry map list) lists)) - -(define (min-prods nt base-table) - (let* ([sizes (hash-ref base-table (nt-name nt))] +(define (min-prods nt prods base-table) + (let* ([sizes (hash-ref base-table nt)] [min-size (apply min/f sizes)]) - (map cadr (filter (λ (x) (equal? min-size (car x))) (zip sizes (nt-rhs nt)))))) + (map cadr (filter (λ (x) (equal? min-size (car x))) (map list sizes prods))))) -(define-struct rg-lang (clang lits base-cases)) +(define-struct rg-lang (non-cross cross base-cases)) (define (prepare-lang lang) - (let ([lits (map symbol->string (compiled-lang-literals lang))] - [parsed (parse-language lang)]) - (make-rg-lang parsed lits (find-base-cases parsed)))) + (let ([parsed (parse-language lang)]) + (values parsed (map symbol->string (compiled-lang-literals lang)) (find-base-cases parsed)))) (define-struct (exn:fail:redex:generation-failure exn:fail:redex) ()) (define (raise-gen-fail who what attempts) @@ -152,51 +149,24 @@ who what attempts (if (= attempts 1) "" "s"))]) (raise (make-exn:fail:redex:generation-failure str (current-continuation-marks))))) -(define (generate lang decisions@ what) - (define-values/invoke-unit decisions@ +(define (compile lang what) + (define-values/invoke-unit (generation-decisions) (import) (export decisions^)) - (define ((generate-nt lang base-cases generate retries) - name cross? size attempt in-hole env) + (define (gen-nt lang name cross? retries size attempt in-hole) (let*-values - ([(term _) - (generate/pred - name - (λ (size attempt) - (let ([rhs (pick-from-list - (if (zero? size) - (min-prods (nt-by-name lang name cross?) - ((if cross? base-cases-cross base-cases-non-cross) - base-cases)) - ((next-non-terminal-decision) name cross? lang attempt)))]) - (generate (max 0 (sub1 size)) attempt empty-env in-hole (rhs-pattern rhs)))) - (λ (_ env) (mismatches-satisfied? env)) - size attempt retries)]) + ([(productions) + (hash-ref ((if cross? rg-lang-cross rg-lang-non-cross) lang) name)] + [(term _) + (let ([gen (pick-from-list + (if (zero? size) + (min-prods name productions + ((if cross? base-cases-cross base-cases-non-cross) + (rg-lang-base-cases lang))) + ((next-non-terminal-decision) productions)))]) + (gen retries (max 0 (sub1 size)) attempt empty-env in-hole))]) term)) - (define (generate-sequence ellipsis generate env length) - (define (split-environment env) - (foldl (λ (var seq-envs) - (let ([vals (hash-ref env var #f)]) - (if vals - (map (λ (seq-env val) (hash-set seq-env var val)) seq-envs vals) - seq-envs))) - (build-list length (λ (_) #hash())) (ellipsis-vars ellipsis))) - (define (merge-environments seq-envs) - (foldl (λ (var env) - (hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs))) - env (ellipsis-vars ellipsis))) - (let-values - ([(seq envs) - (let recur ([envs (split-environment env)]) - (if (null? envs) - (values null null) - (let*-values - ([(term env) (generate (car envs) the-hole (ellipsis-pattern ellipsis))] - [(terms envs) (recur (cdr envs))]) - (values (cons term terms) (cons env envs)))))]) - (values seq (merge-environments envs)))) - (define (generate/pred name gen pred init-sz init-att retries) (let ([pre-threshold-incr (ceiling @@ -206,8 +176,7 @@ (λ (remain) (zero? (modulo (sub1 remain) - (ceiling (* proportion-at-size - retries)))))]) + (ceiling (* proportion-at-size retries)))))]) (let retry ([remaining (add1 retries)] [size init-sz] [attempt init-att]) @@ -223,14 +192,37 @@ post-threshold-incr pre-threshold-incr))))))))) - (define (generate/prior name env generate) + (define (generate/prior name env gen) (let* ([none (gensym)] [prior (hash-ref env name none)]) (if (eq? prior none) - (let-values ([(term env) (generate)]) + (let-values ([(term env) (gen)]) (values term (hash-set env name term))) (values prior env)))) + (define (generate-sequence gen env vars length) + (define (split-environment env) + (foldl (λ (var seq-envs) + (let ([vals (hash-ref env var #f)]) + (if vals + (map (λ (seq-env val) (hash-set seq-env var val)) seq-envs vals) + seq-envs))) + (build-list length (λ (_) #hash())) vars)) + (define (merge-environments seq-envs) + (foldl (λ (var env) + (hash-set env var (map (λ (seq-env) (hash-ref seq-env var)) seq-envs))) + env vars)) + (let-values + ([(seq envs) + (let recur ([envs (split-environment env)]) + (if (null? envs) + (values null null) + (let*-values + ([(term env) (gen (car envs) the-hole)] + [(terms envs) (recur (cdr envs))]) + (values (cons term terms) (cons env envs)))))]) + (values seq (merge-environments envs)))) + (define (mismatches-satisfied? env) (let ([groups (make-hasheq)]) (define (get-group group) @@ -250,129 +242,150 @@ (define (bindings env) (make-bindings (for/fold ([bindings null]) ([(key val) env]) - (if (binder? key) - (cons (make-bind (binder-name key) val) bindings) - bindings)))) + (if (binder? key) + (cons (make-bind (binder-name key) val) bindings) + bindings)))) - (define (generate-pat lang sexp retries size attempt env in-hole pat) - (define recur (curry generate-pat lang sexp retries size attempt)) - (define recur/pat (recur env in-hole)) - (define ((recur/pat/size-attempt pat) size attempt) - (generate-pat lang sexp retries size attempt env in-hole pat)) - - (define clang (rg-lang-clang lang)) - (define gen-nt - (generate-nt - clang - (rg-lang-base-cases lang) - (curry generate-pat lang sexp retries) - retries)) - - (match pat - [`number (values ((next-number-decision) attempt) env)] - [`natural (values ((next-natural-decision) attempt) env)] - [`integer (values ((next-integer-decision) attempt) env)] - [`real (values ((next-real-decision) attempt) env)] - [`(variable-except ,vars ...) - (generate/pred 'variable - (recur/pat/size-attempt 'variable) - (λ (var _) (not (memq var vars))) - size attempt retries)] - [`variable - (values ((next-variable-decision) (rg-lang-lits lang) attempt) - env)] - [`variable-not-otherwise-mentioned - (generate/pred 'variable - (recur/pat/size-attempt 'variable) - (λ (var _) (not (memq var (compiled-lang-literals clang)))) - size attempt retries)] - [`(variable-prefix ,prefix) - (define (symbol-append prefix suffix) - (string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) - (let-values ([(term env) (recur/pat 'variable)]) - (values (symbol-append prefix term) env))] - [`string - (values ((next-string-decision) (rg-lang-lits lang) attempt) - env)] - [`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc) - (generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc) - (recur/pat/size-attempt pat) - (λ (_ env) (condition (bindings env))) - size attempt retries)] - [`(name ,(? symbol? id) ,p) - (let-values ([(term env) (recur/pat p)]) - (values term (hash-set env (make-binder id) term)))] - [`hole (values in-hole env)] - [`(in-hole ,context ,contractum) - (let-values ([(term env) (recur/pat contractum)]) - (recur env term context))] - [`(hide-hole ,pattern) (recur env the-hole pattern)] - [`any - (let*-values ([(new-lang nt) ((next-any-decision) lang sexp)] - [(term _) (generate-pat new-lang - sexp - retries - size - attempt - empty-env - the-hole - nt)]) - (values term env))] - [(? (is-nt? clang)) - (values (gen-nt pat #f size attempt in-hole env) env)] - [(struct binder ((or (? (is-nt? clang) nt) - (app (symbol-match named-nt-rx) (? (is-nt? clang) nt))))) - (generate/prior pat env (λ () (recur/pat nt)))] - [(struct binder ((or (? built-in? b) - (app (symbol-match named-nt-rx) (? built-in? b))))) - (generate/prior pat env (λ () (recur/pat b)))] - [(struct mismatch (name (app (symbol-match mismatch-nt-rx) - (? symbol? (? (is-nt? clang) nt))))) - (let-values ([(term _) (recur/pat nt)]) - (values term (hash-set env pat term)))] - [(struct mismatch (name (app (symbol-match mismatch-nt-rx) - (? symbol? (? built-in? b))))) - (let-values ([(term _) (recur/pat b)]) - (values term (hash-set env pat term)))] - [`(cross ,(? symbol? cross-nt)) - (values (gen-nt cross-nt #t size attempt in-hole env) env)] - [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) (values pat env)] - [(list-rest (and (struct ellipsis (name sub-pat class vars)) ellipsis) rest) - (let*-values ([(length) (let ([prior (hash-ref env class #f)]) - (if prior prior ((next-sequence-decision) attempt)))] - [(seq env) (generate-sequence ellipsis recur env length)] - [(rest env) (recur (hash-set (hash-set env class length) name length) - in-hole rest)]) - (values (append seq rest) env))] - [(list-rest pat rest) - (let*-values - ([(pat-term env) (recur/pat pat)] - [(rest-term env) (recur env in-hole rest)]) - (values (cons pat-term rest-term) env))] - [else - (error what "unknown pattern ~s\n" pat)])) - - (let ([rg-lang (prepare-lang lang)] - [rg-sexp (prepare-lang sexp)]) - (λ (pat) - (let ([parsed (reassign-classes (parse-pattern pat lang 'top-level))]) - (λ (size attempt retries) - (let-values ([(term env) - (generate/pred - pat - (λ (size attempt) - (generate-pat - rg-lang - rg-sexp - retries - size - attempt - empty-env - the-hole - parsed)) - (λ (_ env) (mismatches-satisfied? env)) - size attempt retries)]) - (values term (bindings env)))))))) + (let*-values ([(langp lits lang-bases) (prepare-lang lang)] + [(sexpp _ sexp-bases) (prepare-lang sexp)] + [(lit-syms) (compiled-lang-literals lang)]) + (letrec-values + ([(compile) + (λ (pat any?) + (let* ([nt? (is-nt? (if any? sexpp langp))] + [mismatches? #f] + [generator ; retries size attempt env in-hole -> (values term env) + (let recur ([pat pat]) + (match pat + [`number (λ (r s a e h) (values ((next-number-decision) a) e))] + [`natural (λ (r s a e h) (values ((next-natural-decision) a) e))] + [`integer (λ (r s a e h) (values ((next-integer-decision) a) e))] + [`real (λ (r s a e h) (values ((next-real-decision) a) e))] + [`(variable-except ,vars ...) + (let ([g (recur 'variable)]) + (λ (r s a e h) + (generate/pred pat + (λ (s a) (g r s a e h)) + (λ (var _) (not (memq var vars))) + s a r)))] + [`variable + (λ (r s a e h) + (values ((next-variable-decision) lits a) e))] + [`variable-not-otherwise-mentioned + (let ([g (recur 'variable)]) + (λ (r s a e h) + (generate/pred pat + (λ (s a) (g r s a e h)) + (λ (var _) (not (memq var lit-syms))) + s a r)))] + [`(variable-prefix ,prefix) + (define (symbol-append prefix suffix) + (string->symbol (string-append (symbol->string prefix) (symbol->string suffix)))) + (let ([g (recur 'variable)]) + (λ (r s a e h) + (let-values ([(term _) (g r s a e h)]) + (values (symbol-append prefix term) e))))] + [`string + (λ (r s a e h) + (values ((next-string-decision) lits a) e))] + [`(side-condition ,pat ,(? procedure? condition) ,guard-src-loc) + (let ([g (recur pat)]) + (λ (r s a e h) + (generate/pred `(side-condition ,(unparse-pattern pat) ,guard-src-loc) + (λ (s a) (g r s a e h)) + (λ (_ env) (condition (bindings env))) + s a r)))] + [`(name ,(? symbol? id) ,p) + (let ([g (recur p)]) + (λ (r s a e h) + (let-values ([(term env) (g r s a e h)]) + (values term (hash-set env (make-binder id) term)))))] + [`hole (λ (r s a e h) (values h e))] + [`(in-hole ,context ,contractum) + (let ([ctx (recur context)] + [ctm (recur contractum)]) + (λ (r s a e h) + (let-values ([(term env) (ctm r s a e h)]) + (ctx r s a env term))))] + [`(hide-hole ,pattern) + (let ([g (recur pattern)]) + (λ (r s a e h) + (g r s a e the-hole)))] + [`any + (λ (r s a e h) + (let*-values ([(lang nt) ((next-any-decision) langc sexpc)] + [(term) (gen-nt lang nt #f r s a the-hole)]) + (values term e)))] + [(or (? symbol? (? nt? p)) `(cross ,(? symbol? p))) + (let ([cross? (not (symbol? pat))]) + (λ (r s a e h) + (values (gen-nt (if any? sexpc langc) p cross? r s a h) e)))] + [(struct binder ((or (app (symbol-match named-nt-rx) (? symbol? p)) p))) + (let ([g (recur p)]) + (λ (r s a e h) + (generate/prior pat e (λ () (g r s a e h)))))] + [(struct mismatch (_ (app (symbol-match mismatch-nt-rx) p))) + (let ([g (recur p)]) + (set! mismatches? #t) + (λ (r s a e h) + (let-values ([(term _) (g r s a e h)]) + (values term (hash-set e pat term)))))] + [(or (? symbol?) (? number?) (? string?) (? boolean?) (? null?)) + (λ (r s a e h) (values pat e))] + [(list-rest (struct ellipsis (name sub-pat class vars)) rest) + (let ([elemg (recur sub-pat)] + [tailg (recur rest)]) + (when (mismatch? name) + (set! mismatches? #t)) + (λ (r s a e h) + (let*-values ([(len) + (let ([prior (hash-ref e class #f)]) + (if prior prior ((next-sequence-decision) a)))] + [(seq env) + (generate-sequence (λ (e h) (elemg r s a e h)) e vars len)] + [(tail env) + (let ([e (hash-set (hash-set env class len) name len)]) + (tailg r s a e h))]) + (values (append seq tail) env))))] + [(list-rest hdp tlp) + (let ([hdg (recur hdp)] + [tlg (recur tlp)]) + (λ (r s a e h) + (let*-values + ([(hd env) (hdg r s a e h)] + [(tl env) (tlg r s a env h)]) + (values (cons hd tl) env))))] + [else + (error what "unknown pattern ~s\n" pat)]))]) + (if mismatches? + (λ (r s a e h) + (let ([g (λ (s a) (generator r s a e h))] + [p? (λ (_ e) (mismatches-satisfied? e))]) + (generate/pred (unparse-pattern pat) g p? s a r))) + generator)))] + [(compile-non-terminals) + (λ (nts any?) + (make-immutable-hash + (map (λ (nt) (cons (nt-name nt) + (map (λ (p) (compile (rhs-pattern p) any?)) + (nt-rhs nt)))) + nts)))] + [(compile-language) + (λ (lang bases any?) + (make-rg-lang + (compile-non-terminals (compiled-lang-lang lang) any?) + (compile-non-terminals (compiled-lang-cclang lang) any?) + bases))] + [(langc sexpc compile-pattern) + (values + (compile-language langp lang-bases #f) + (compile-language sexpp sexp-bases #t) + (λ (pat) (compile pat #f)))]) + (λ (pat) + (let ([g (compile-pattern (reassign-classes (parse-pattern pat lang 'top-level)))]) + (λ (size attempt retries) + (let-values ([(term env) (g retries size attempt empty-env the-hole)]) + (values term (bindings env))))))))) (define-struct base-cases (cross non-cross)) @@ -643,12 +656,12 @@ x (raise-type-error 'redex-check "reduction-relation" x))) -(define-for-syntax (term-generator lang pat decisions@ what) +(define-for-syntax (term-generator lang pat what) (with-syntax ([pattern (rewrite-side-conditions/check-errs (language-id-nts lang what) what #t pat)]) - #`((generate #,lang #,decisions@ '#,what) `pattern))) + #`((compile #,lang '#,what) `pattern))) (define-syntax (generate-term stx) (syntax-case stx () @@ -663,7 +676,6 @@ [(name lang pat) (with-syntax ([make-gen (term-generator #'lang #'pat - #'(generation-decisions) (syntax-e #'name))]) (syntax/loc stx (let ([generate make-gen]) @@ -726,7 +738,6 @@ lang metafunc/red-rel property - random-decisions@ (max 1 (floor (/ att num-cases))) ret 'redex-check @@ -734,7 +745,7 @@ (test-match lang pat) (λ (generated) (redex-error 'redex-check "~s does not match ~s" generated 'pat)))) #`(check-prop - #,(term-generator #'lang #'pat #'random-decisions@ 'redex-check) + #,(term-generator #'lang #'pat 'redex-check) property att ret (and print? show)))))))))])) (define (format-attempts a) @@ -804,10 +815,9 @@ (syntax/loc stx (let ([lang (metafunc-proc-lang m)] [dom (metafunc-proc-dom-pat m)] - [decisions@ (generation-decisions)] [att (assert-nat 'check-metafunction-contract attempts)]) (check-prop - ((generate lang decisions@ 'check-metafunction-contract) + ((compile lang 'check-metafunction-contract) (if dom dom '(any (... ...)))) (λ (t _) (with-handlers ([exn:fail:redex? (λ (_) #f)]) @@ -816,10 +826,10 @@ retries show))))])) -(define (check-lhs-pats lang mf/rr prop decisions@ attempts retries what show +(define (check-lhs-pats lang mf/rr prop attempts retries what show [match #f] [match-fail #f]) - (let ([lang-gen (generate lang decisions@ what)]) + (let ([lang-gen (compile lang what)]) (let-values ([(pats srcs) (cond [(metafunc-proc? mf/rr) (values (map metafunc-case-lhs-pat (metafunc-proc-cases mf/rr)) @@ -869,7 +879,6 @@ (metafunc-proc-lang m) m (λ (term _) (property term)) - (generation-decisions) att ret 'check-metafunction @@ -887,10 +896,9 @@ (define-syntax (check-reduction-relation stx) (syntax-case stx () [(_ relation property . kw-args) - (with-syntax ([(attempts retries decisions@ print?) + (with-syntax ([(attempts retries print?) (parse-kw-args `((#:attempts . , #'default-check-attempts) (#:retries . ,#'default-retries) - (#:decisions . ,#'random-decisions@) (#:print? . #t)) (syntax kw-args) stx)] @@ -903,7 +911,6 @@ (reduction-relation-lang rel) rel (λ (term _) (property term)) - decisions@ attempts retries 'check-reduction-relation @@ -945,6 +952,7 @@ (struct-out mismatch) (struct-out class) (struct-out binder) + (struct-out rg-lang) (struct-out base-cases) (struct-out counterexample) (struct-out exn:fail:redex:test)) diff --git a/collects/redex/redex.scrbl b/collects/redex/redex.scrbl index 7fc37e9828..822c17f550 100644 --- a/collects/redex/redex.scrbl +++ b/collects/redex/redex.scrbl @@ -394,7 +394,7 @@ All of the exports in this section are provided both by all non-GUI portions of Redex) and also exported by @schememodname[redex] (which includes all of Redex). -Object langauge expressions in Redex are written using +Object language expressions in Redex are written using @scheme[term]. It is similar to Scheme's @scheme[quote] (in many cases it is identical) in that it constructs lists as the visible representation of terms. diff --git a/collects/redex/reduction-semantics.ss b/collects/redex/reduction-semantics.ss index ad0c601b0e..e58415cf84 100644 --- a/collects/redex/reduction-semantics.ss +++ b/collects/redex/reduction-semantics.ss @@ -54,6 +54,9 @@ (struct-out exn:fail:redex:test) (struct-out counterexample)) +(provide variable-not-in + variables-not-in) + (provide/contract [current-traced-metafunctions (parameter/c (or/c 'all (listof symbol?)))] [reduction-relation->rule-names (-> reduction-relation? (listof symbol?))] @@ -71,7 +74,5 @@ [lookup-binding (case-> (-> bindings? symbol? any) (-> bindings? symbol? (-> any) any))] - [variable-not-in (any/c symbol? . -> . symbol?)] - [variables-not-in (any/c (listof symbol?) . -> . (listof symbol?))] [relation-coverage (parameter/c (listof coverage?))] [covered-cases (-> coverage? (listof (cons/c string? natural-number/c)))]) diff --git a/collects/redex/tests/bitmap-test.ss b/collects/redex/tests/bitmap-test.ss index e5f73397d9..5b2bf981d7 100644 --- a/collects/redex/tests/bitmap-test.ss +++ b/collects/redex/tests/bitmap-test.ss @@ -163,5 +163,20 @@ (test (render-lw lang (to-lw (x_^abcdef x_q^abcdef))) "superscripts.png") +;; `variable-not-in' in `where' RHS rendered as `fresh' +(define-metafunction lang + [(f (name n 1)) + (x x_1 x_2 x_3) + (where x ,(variable-not-in 'y 'x)) + (where (x_1 x_2) ,(variables-not-in 'z '(x1 x2))) + (where x_3 (variables-not-in 'z '(x1 x2)))]) +(test (render-metafunction f) "var-not-in.png") +(let ([variable-not-in list]) + (define-metafunction lang + [(g 1) + x + (where x ,(variable-not-in 'y 'x))]) + (test (render-metafunction g) "var-not-in-rebound.png")) + (printf "bitmap-test.ss: ") (done) diff --git a/collects/redex/tests/bmps-macosx/var-not-in-rebound.png b/collects/redex/tests/bmps-macosx/var-not-in-rebound.png new file mode 100644 index 0000000000..79e5b401f5 Binary files /dev/null and b/collects/redex/tests/bmps-macosx/var-not-in-rebound.png differ diff --git a/collects/redex/tests/bmps-macosx/var-not-in.png b/collects/redex/tests/bmps-macosx/var-not-in.png new file mode 100644 index 0000000000..e6efc40fec Binary files /dev/null and b/collects/redex/tests/bmps-macosx/var-not-in.png differ diff --git a/collects/redex/tests/rg-test.ss b/collects/redex/tests/rg-test.ss index b233998dae..2abeac5b60 100644 --- a/collects/redex/tests/rg-test.ss +++ b/collects/redex/tests/rg-test.ss @@ -70,15 +70,6 @@ (test (hash-ref (base-cases-non-cross (find-base-cases L)) 'x) '(0 0))) -(let () - (define-language lang - (e number x y) - (x variable) - (y y)) - (test (min-prods (car (compiled-lang-lang lang)) - (base-cases-non-cross (find-base-cases lang))) - (list (car (nt-rhs (car (compiled-lang-lang lang))))))) - (define (make-random . nums) (let ([nums (box nums)]) (λ ([m +inf.0]) @@ -126,10 +117,7 @@ (make-exn-not-raised))))])) (define (patterns . selectors) - (map (λ (selector) - (λ (name cross? lang sizes) - (list (selector (nt-rhs (nt-by-name lang name cross?)))))) - selectors)) + (map (curry compose list) selectors)) (define (iterator name items) (let ([bi (box items)]) @@ -249,6 +237,7 @@ (f (n_1 ..._1 n_2 ..._2 n_2 ..._1)) (g (z_1 ..._!_1 z_2 ... (z_1 z_2) ...)) (n number) + (q literal) (z 4)) (test (generate-term/decisions @@ -263,7 +252,19 @@ (test (generate-term/decisions lang d 5 0 (decisions #:seq (list (λ (_) 2)))) '(4 4 4 4 (4 4) (4 4))) (test (raised-exn-msg exn:fail:redex:generation-failure? (generate-term lang e 5 #:retries 42)) - #rx"generate-term: unable to generate pattern e in 42") + #rx"generate-term: unable to generate pattern \\(n_1 ..._!_1 n_2 ..._!_1 \\(n_1 n_2\\) ..._3\\) in 42") + (test (raised-exn-msg + exn:fail:redex:generation-failure? + (parameterize ([generation-decisions + (decisions #:var (list (λ _ 'x) (λ _ 'x)))]) + (generate-term lang (variable-except x) 5 #:retries 1))) + #rx"generate-term: unable to generate pattern \\(variable-except x\\) in 1") + (test (raised-exn-msg + exn:fail:redex:generation-failure? + (parameterize ([generation-decisions + (decisions #:var (λ _ 'literal))]) + (generate-term lang variable-not-otherwise-mentioned 5 #:retries 1))) + #rx"generate-term: unable to generate pattern variable-not-otherwise-mentioned in 1") (test (generate-term/decisions lang f 5 0 (decisions #:seq (list (λ (_) 0)))) null) (test (generate-term/decisions lang ((0 ..._!_1) ... (1 ..._!_1) ...) 5 0 @@ -419,8 +420,8 @@ (define-language empty) ;; `any' pattern - (let ([four (prepare-lang four)] - [sexp (prepare-lang sexp)]) + (let ([four (make-rg-lang '((e . ()) (f . ())) '((e-e . ()) (f-f . ())) 'dont-care)] + [sexp (make-rg-lang 'dont-care 'dont-care 'dont-care)]) (test (call-with-values (λ () (pick-any four sexp (make-random 0 1))) list) (list four 'f)) (test (call-with-values (λ () (pick-any four sexp (make-random 1))) list) @@ -436,6 +437,7 @@ '("foo" "bar" "baz")) (test (generate-term/decisions empty any 5 0 (decisions #:nt (patterns first) + #:any (λ (langc sexpc) (values sexpc 'sexp)) #:var (list (λ _ 'x)))) 'x)) @@ -660,6 +662,7 @@ exn:fail:redex:generation-failure? (redex-check lang (side-condition any #f) #t #:retries 42 #:attempts 1)) #rx"^redex-check: unable .* in 42") + (let ([unable-loc #px"^redex-check: unable to generate LHS of clause at .*:\\d+:\\d+ in 42"]) (let-syntax ([test-gen-fail (syntax-rules () @@ -770,11 +773,12 @@ (test (begin (output (λ () - (check-reduction-relation - R (λ (term) (set! generated (cons term generated))) - #:decisions (decisions #:seq (list (λ _ 0) (λ _ 0) (λ _ 0)) - #:num (list (λ _ 1) (λ _ 1) (λ _ 0))) - #:attempts 1))) + (parameterize ([generation-decisions + (decisions #:seq (list (λ _ 0) (λ _ 0) (λ _ 0)) + #:num (list (λ _ 1) (λ _ 1) (λ _ 0)))]) + (check-reduction-relation + R (λ (term) (set! generated (cons term generated))) + #:attempts 1)))) generated) (reverse '((+ (+)) 0)))) @@ -804,10 +808,11 @@ (==> a b)])]) (test (output (λ () - (check-reduction-relation - T (curry equal? '(9 4)) - #:attempts 1 - #:decisions (decisions #:num (build-list 5 (λ (x) (λ _ x))))))) + (parameterize ([generation-decisions + (decisions #:num (build-list 5 (λ (x) (λ _ x))))]) + (check-reduction-relation + T (curry equal? '(9 4)) + #:attempts 1)))) #rx"no counterexamples")) (let ([U (reduction-relation L (--> (side-condition any #f) any))]) diff --git a/collects/redex/tests/tl-test.ss b/collects/redex/tests/tl-test.ss index c45255a96b..625a7b346e 100644 --- a/collects/redex/tests/tl-test.ss +++ b/collects/redex/tests/tl-test.ss @@ -52,6 +52,8 @@ (test (pair? ((redex-match grammar M) '(1 1))) #t) + + (test (pair? (redex-match grammar (name not-an-nt_subscript 1) 1)) #t) ;; next 3: test naming of subscript-less non-terminals (test (pair? (redex-match grammar (M M) (term (1 1)))) #t) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index a076d01b21..857b653267 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "29jan2010") +#lang scheme/base (provide stamp) (define stamp "3feb2010") diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index 5d89505c52..5c6656f0c5 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -426,20 +426,19 @@ d ri top (if (part-style? d 'no-toc) "tocview" "tocsub") sub-parts-on-other-page?) ,@(parameterize ([extra-breaking? #t]) - (append-map - (lambda (t) - (let loop ([t t]) - (if (table? t) - (render-table t d ri #f) - (loop (delayed-block-blocks t ri))))) - (filter (lambda (e) - (let loop ([e e]) - (or (and (table? e) - (memq 'aux (style-properties (table-style e))) - (pair? (table-blockss e))) - (and (delayed-block? e) - (loop (delayed-block-blocks e ri)))))) - (part-blocks d))))))) + (append-map (lambda (e) + (let loop ([e e]) + (cond + [(and (table? e) + (memq 'aux (style-properties (table-style e))) + (pair? (table-blockss e))) + (render-table e d ri #f)] + [(delayed-block? e) + (loop (delayed-block-blocks e ri))] + [(compound-paragraph? e) + (append-map loop (compound-paragraph-blocks e))] + [else null]))) + (part-blocks d)))))) (define/public (get-onthispage-label) null) diff --git a/collects/scribble/private/manual-class.ss b/collects/scribble/private/manual-class.ss index 8607349fe7..d4ced3a883 100644 --- a/collects/scribble/private/manual-class.ss +++ b/collects/scribble/private/manual-class.ss @@ -72,7 +72,7 @@ (let loop ([supers start][accum null]) (cond [(null? supers) (reverse accum)] - [(memq (car supers) accum) + [(assoc (caar supers) accum) (loop (cdr supers) accum)] [else (let ([super (car supers)]) diff --git a/collects/scribble/text/output.ss b/collects/scribble/text/output.ss index 4c20ca1496..90f6eaa282 100644 --- a/collects/scribble/text/output.ss +++ b/collects/scribble/text/output.ss @@ -4,7 +4,7 @@ (provide output) -;; Outputs some value, for the preprocessor langauge. +;; Outputs some value, for the preprocessor language. ;; ;; Uses global state because `output' is wrapped around each expression in a ;; scribble/text file so this is much more convenient than wrapping the whole diff --git a/collects/scribblings/drscheme/interface-essentials.scrbl b/collects/scribblings/drscheme/interface-essentials.scrbl index fbedebd94d..a7839b6d4f 100644 --- a/collects/scribblings/drscheme/interface-essentials.scrbl +++ b/collects/scribblings/drscheme/interface-essentials.scrbl @@ -787,7 +787,7 @@ Each type has advantages and disadvantages: In general, DrScheme's @drlang{Module} language gives you the most options. Most other languages only allow one type of executable. The -teaching langauges create stand-alone executables in +teaching languages create stand-alone executables in distributions. The legacy languages create launchers. @bold{Tip:} Disable debugging in the language dialog before creating diff --git a/collects/scribblings/drscheme/languages.scrbl b/collects/scribblings/drscheme/languages.scrbl index 66c70eb339..c6f31cb277 100644 --- a/collects/scribblings/drscheme/languages.scrbl +++ b/collects/scribblings/drscheme/languages.scrbl @@ -26,7 +26,7 @@ Scheme module can be written as @scheme[(module ...)]. In any case, aside from comments, the @tech{definitions window} must contain exactly one module. -In the details pane of the module langauge, some of the +In the details pane of the module language, some of the configuration options for the Module language that correspond to using various libraries and thus can be used without DrScheme. Here's how, for the ones that are straightforward (the ones diff --git a/collects/scribblings/gui/canvas-class.scrbl b/collects/scribblings/gui/canvas-class.scrbl index 1c05ac8df4..0550c2ea3b 100644 --- a/collects/scribblings/gui/canvas-class.scrbl +++ b/collects/scribblings/gui/canvas-class.scrbl @@ -90,26 +90,6 @@ The @scheme[gl-config] argument determines properties of an OpenGL } -@defmethod*[([(accept-tab-focus) - boolean?] - [(accept-tab-focus [on? any/c]) - void?])]{ - -@index['("keyboard focus" "navigation")]{Gets} or sets whether -tab-focus is enabled for the canvas (assuming that the canvas is -not created with the @scheme['no-focus] style). When tab-focus is -enabled, the canvas can receive the keyboard focus when the user -navigates among a frame or dialog's controls with the Tab and -arrow keys. By default, tab-focus is disabled. - -When tab-focus is enabled for a canvas, Tab, arrow, and Enter keyboard - events are consumed by a frame's default -@method[top-level-window<%> on-traverse-char] method. (In addition, a dialog's default method consumes Escape key - events.) Otherwise, -@method[top-level-window<%> on-traverse-char] allows the keyboard events to be propagated to the canvas. -} - - @defmethod[(get-scroll-page [which (one-of/c 'horizontal 'vertical)]) (integer-in 1 1000000000)]{ diff --git a/collects/scribblings/gui/canvas-intf.scrbl b/collects/scribblings/gui/canvas-intf.scrbl index c8d3ce4f96..d7544a9427 100644 --- a/collects/scribblings/gui/canvas-intf.scrbl +++ b/collects/scribblings/gui/canvas-intf.scrbl @@ -21,6 +21,33 @@ The @scheme[canvas<%>] interface is implemented by two classes: ] +@defmethod*[([(accept-tab-focus) + boolean?] + [(accept-tab-focus [on? any/c]) + void?])]{ + +@index['("keyboard focus" "navigation")]{Gets} or sets whether +tab-focus is enabled for the canvas (assuming that the canvas is +not created with the @scheme['no-focus] style for @scheme[canvas%]). When tab-focus is +enabled, the canvas can receive the keyboard focus when the user +navigates among a frame or dialog's controls with the Tab and +arrow keys. By default, tab-focus is disabled. + +When tab-focus is enabled for a @scheme[canvas%] object, Tab, arrow, + Enter, and Escape keyboard events are consumed by a frame's default + @method[top-level-window<%> on-traverse-char] method. (In addition, a + dialog's default method consumes Escape key events.) Otherwise, + @method[top-level-window<%> on-traverse-char] allows the keyboard + events to be propagated to the canvas. + +For an @scheme[editor-canvas%] object, handling of Tab, arrow, Enter, + and Escape keyboard events is determined by the + @method[editor-canvas% allow-tab-exit] method. + + +} + + @defmethod[(get-canvas-background) (or/c (is-a?/c color%) false/c)]{ Returns the color currently used to ``erase'' the canvas content before @@ -144,7 +171,7 @@ Called when the keyboard focus enters the canvas via keyboard @method[window<%> on-focus] is called. See also -@xmethod[canvas% accept-tab-focus] and +@method[canvas<%> accept-tab-focus] and @xmethod[top-level-window<%> on-traverse-char] . } diff --git a/collects/scribblings/gui/editor-canvas-class.scrbl b/collects/scribblings/gui/editor-canvas-class.scrbl index 4f3493aaae..9a25dc9c9d 100644 --- a/collects/scribblings/gui/editor-canvas-class.scrbl +++ b/collects/scribblings/gui/editor-canvas-class.scrbl @@ -121,15 +121,16 @@ Enables or disables last-line scrolling, or gets the current enable @index['("keyboard focus" "navigation")]{Gets} or sets whether tab-exit is enabled for the editor canvas. When tab-exit is enabled, the user can move the keyboard focus out of the editor using the Tab - and arrow keys, or invoke the default button using the Enter/Return - key. By default, tab-exit is disabled. + and arrow keys, invoke the default button using the Enter/Return key, + or invoke a dialog's close action with Escape. By default, tab-exit + is disabled. -When tab-exit is enabled for an editor canvas, Tab, arrow, and Enter - keyboard events are consumed by a frame's default - @method[top-level-window<%> on-traverse-char] method. (In addition, a - dialog's default method consumes Escape key events.) Otherwise, - @method[top-level-window<%> on-traverse-char] allows the keyboard - events to be propagated to the canvas. +When tab-exit is enabled for an editor canvas, Tab and Enter keyboard + events are consumed by a frame's default @method[top-level-window<%> + on-traverse-char] method; in addition, a dialog's default method + consumes Escape key events. Otherwise, @method[top-level-window<%> + on-traverse-char] allows the keyboard events to be propagated to the + canvas. } diff --git a/collects/scribblings/gui/top-level-window-intf.scrbl b/collects/scribblings/gui/top-level-window-intf.scrbl index ea915c7898..992ca0220d 100644 --- a/collects/scribblings/gui/top-level-window-intf.scrbl +++ b/collects/scribblings/gui/top-level-window-intf.scrbl @@ -223,7 +223,7 @@ If the window that currently owns the focus specifically handles the Meta/Alt events.} @item{@scheme[canvas%] --- when tab-focus is disabled (see -@method[canvas% accept-tab-focus]): all keyboard events, except alphanumeric key events when the Meta +@method[canvas<%> accept-tab-focus]): all keyboard events, except alphanumeric key events when the Meta (X) or Alt (Windows) key is pressed; when tab-focus is enabled: no key events} diff --git a/collects/scribblings/inside/overview.scrbl b/collects/scribblings/inside/overview.scrbl index ccf65c5d32..e02bf2f0f9 100644 --- a/collects/scribblings/inside/overview.scrbl +++ b/collects/scribblings/inside/overview.scrbl @@ -213,7 +213,7 @@ must be extended as follows: For a relatively simple extension @filepath{hw.c}, the extension is compiled under Unix for 3m with the following three commands: -@commandline{mzc --xform --cc hw.c} +@commandline{mzc --xform hw.c} @commandline{mzc --3m --cc hw.3m.c} @commandline{mzc --3m --ld hw.so hw.o} @@ -221,6 +221,50 @@ Some examples in @filepath{collects/mzscheme/examples} work with MzScheme3m in this way. A few examples are manually instrumented, in which case the @DFlag{xform} step should be skipped. +@subsection{Declaring a Module in an Extension} + +To create an extension that behaves as a module, return a symbol from +@cpp{scheme_module_name}, and have @cpp{scheme_initialize} and +@cpp{scheme_rename} declare a module using @cpp{scheme_primitive_module}. + +For example, the following extension implements a module named +@scheme[hello] that exports a binding @scheme[greeting]: + +@verbatim[#:indent 2]{ + #include "escheme.h" + + Scheme_Object *scheme_initialize(Scheme_Env *env) { + Scheme_Env *mod_env; + mod_env = scheme_primitive_module(scheme_intern_symbol("hi"), + env); + scheme_add_global("greeting", + scheme_make_utf8_string("hello"), + mod_env); + scheme_finish_primitive_module(mod_env); + return scheme_void; + } + + Scheme_Object *scheme_reload(Scheme_Env *env) { + return scheme_initialize(env); /* Nothing special for reload */ + } + + Scheme_Object *scheme_module_name() { + return scheme_intern_symbol("hi"); + } +} + +This extension could be compiled for 3m on Mac OS X for i386, for +example, using the following sequence of @exec{mzc} commands: + +@commandline{mzc --xform hi.c} +@commandline{mzc --3m --cc hi.3m.c} +@commandline{mkdir -p compiled/native/i386-macosx/3m} +@commandline{mzc --3m --ld compiled/native/i386-macosx/3m/hi_ss.dylib hi_3m.o} + +The resulting module can be loaded with + +@schemeblock[(require "hi.ss")] + @; ---------------------------------------------------------------------- @section[#:tag "embedding"]{Embedding MzScheme into a Program} diff --git a/collects/scribblings/reference/eval-model.scrbl b/collects/scribblings/reference/eval-model.scrbl index 0dbd964e09..e65caaf16b 100644 --- a/collects/scribblings/reference/eval-model.scrbl +++ b/collects/scribblings/reference/eval-model.scrbl @@ -366,6 +366,16 @@ via a @tech{weak reference}, then the object can be reclaimed, and the @tech{weak reference} is replaced by a different @tech{value} (typically @scheme[#f]). +As a special case, a @tech{fixnum} is always considered reachable by +the garbage collector. Many other values are always reachable due to +the way they are implemented and used: A @tech{character} in the +Latin-1 range is always reachable, because @scheme[equal?] Latin-1 +characters are always @scheme[eq?], and all of the Latin-1 characters +are referenced by an internal module. Similarly, @scheme[null], +@scheme[#t], @scheme[#f], @scheme[eof], and @|void-const| and are +always reachable. Values produced by @scheme[quote] remain reachable +when the @scheme[quote] expression itself is reachable. + @;------------------------------------------------------------------------ @section{Procedure Applications and Local Variables} diff --git a/collects/scribblings/reference/mpairs.scrbl b/collects/scribblings/reference/mpairs.scrbl index 8f2178157f..0edb8084e4 100644 --- a/collects/scribblings/reference/mpairs.scrbl +++ b/collects/scribblings/reference/mpairs.scrbl @@ -19,7 +19,7 @@ instead created with mutable pairs. @defproc[(mpair? [v any/c]) boolean?]{Returns @scheme[#t] if @scheme[v] is a mutable pair, @scheme[#f] otherwise.} -@defproc[(mcons [a any/c] [d any/c]) pair?]{Returns a mutable pair whose first +@defproc[(mcons [a any/c] [d any/c]) pair?]{Returns a newly allocated mutable pair whose first element is @scheme[a] and second element is @scheme[d].} @defproc[(mcar [p mpair?]) any/c]{Returns the first element of the diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index 564a9cf695..0c87b8e370 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -107,7 +107,7 @@ the empty list, @scheme[#f] otherwise. (null? (cdr (list 1))) ]} -@defproc[(cons [a any/c] [d any/c]) pair?]{Returns a pair whose first +@defproc[(cons [a any/c] [d any/c]) pair?]{Returns a newly allocated pair whose first element is @scheme[a] and second element is @scheme[d]. @mz-examples[ (cons 1 2) diff --git a/collects/scribblings/reference/read.scrbl b/collects/scribblings/reference/read.scrbl index 71e6c1a8ac..812e8ba018 100644 --- a/collects/scribblings/reference/read.scrbl +++ b/collects/scribblings/reference/read.scrbl @@ -114,14 +114,21 @@ soon as a @tech{reader language} (or its absence) is determined. A @deftech{reader language} is specified by @litchar{#lang} or @litchar{#!} (see @secref["parse-reader"]) at the beginning of the -input, though possibly after comment forms. Instead of dispatching to -a @schemeidfont{read} or @schemeidfont{read-syntax} form as -@scheme[read] and @scheme[read-syntax] do, @scheme[read-language] -dispatches to a @schemeidfont{get-info} function (if any) exported by -the same module. The result of the @schemeidfont{get-info} function is -the result of @scheme[read-language] if it is a function of two -arguments; if @schemeidfont{get-info} produces any other kind of -result, the @exnraise[exn:fail:contract]. +input, though possibly after comment forms. The default +@tech{readtable} is used by @scheme[read-language] (instead of the +value of @scheme[current-readtable]), and @litchar{#reader} forms +(which might produce comments) are not allowed before @litchar{#lang} +or @litchar{#!}. + +When it finds a @litchar{#lang} or @litchar{#!} specification, instead +of dispatching to a @schemeidfont{read} or @schemeidfont{read-syntax} +form as @scheme[read] and @scheme[read-syntax] do, +@scheme[read-language] dispatches to a @schemeidfont{get-info} +function (if any) exported by the same module. The result of the +@schemeidfont{get-info} function is the result of +@scheme[read-language] if it is a function of two arguments; if +@schemeidfont{get-info} produces any other kind of result, the +@exnraise[exn:fail:contract]. The function produced by @schemeidfont{get-info} reflects information about the expected syntax of the input stream. The first argument to the diff --git a/collects/scribblings/reference/readtables.scrbl b/collects/scribblings/reference/readtables.scrbl index acbf2dff83..2e90650e99 100644 --- a/collects/scribblings/reference/readtables.scrbl +++ b/collects/scribblings/reference/readtables.scrbl @@ -5,7 +5,7 @@ @title[#:style 'toc]{Reader Extension} Scheme's reader can be extended in three ways: through a reader-macro -procedure in a readtable (see @secref["readtables"]), through a +procedure in a @tech{readtable} (see @secref["readtables"]), through a @litchar{#reader} form (see @secref["parse-reader"]), or through a custom-port byte reader that returns a ``special'' result procedure (see @secref["customport"]). All three kinds of @deftech{reader diff --git a/collects/scribblings/reference/stx-ops.scrbl b/collects/scribblings/reference/stx-ops.scrbl index 944e4a5d30..4969cd889f 100644 --- a/collects/scribblings/reference/stx-ops.scrbl +++ b/collects/scribblings/reference/stx-ops.scrbl @@ -157,12 +157,12 @@ needed to strip lexical and source-location information recursively.} [cert (or/c syntax? #f) #f]) syntax?]{ -Converts the @tech{datum} @scheme[v] to a @tech{syntax object}. If -@scheme[v] is a pair, vector, box, immutable hash table, or immutable -@tech{prefab} structure, then the contents are recursively converted; -mutable vectors and boxes are essentially replaced by immutable -vectors and boxes. @tech{Syntax object}s already in @scheme[v] are -preserved as-is in the result. For any kind of value other than a +Converts the @tech{datum} @scheme[v] to a @tech{syntax object}. +The contents of pairs, vectors, and boxes, the fields of @tech{prefab} +structures, and the values of immutable hash tables are recursively converted. +The keys of @tech{prefab} structures and the keys of immutable hash tables are +not converted. Mutable vectors and boxes are replaced by immutable vectors and +boxes. For any kind of value other than a pair, vector, box, immutable @tech{hash table}, immutable @tech{prefab} structure, or @tech{syntax object}, conversion means wrapping the value with lexical information, source-location diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 2aafe83deb..f09b9f9741 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -95,7 +95,7 @@ id)] is the name of the declared module. @margin-note/ref{For a @scheme[module]-like form for use @emph{within} modules and other contexts, see @scheme[define-package].} -The @scheme[module-path] must be as for @scheme[require], and it +The @scheme[module-path] form must be as for @scheme[require], and it supplies the initial bindings for the body @scheme[form]s. That is, it is treated like a @scheme[(require module-path)] prefix before the @scheme[form]s, except that the bindings introduced by @@ -179,10 +179,13 @@ module, whose full name depends both on @scheme[id] and The module body is executed only when the module is explicitly @techlink{instantiate}d via @scheme[require] or @scheme[dynamic-require]. On invocation, expressions and definitions -are evaluated in order as they appear within the module; accessing a -@tech{module-level variable} before it is defined signals a run-time -error, just like accessing an undefined global variable. +are evaluated in order as they appear within the module. Each +evaluation of an expression or definition is wrapped with a +continuation prompt (see @scheme[call-with-continuation-prompt]) for +the default continuation and using the default prompt handler. +Accessing a @tech{module-level variable} before it is defined signals +a run-time error, just like accessing an undefined global variable. If a module (in its fully expanded form) does not contain a @scheme[set!] for an identifier that defined within the module, then the identifier is a @defterm{constant} after it is defined; its value @@ -218,8 +221,8 @@ See also @secref["module-eval-model"] and @secref["mod-parse"]. Legal only in a @tech{module begin context}, and handled by the @scheme[module] form. -The pre-defined @scheme[#%module-begin] form wraps every -top-level expression to print non-@|void-const| results using +The @scheme[#%module-begin] form of @schememodname[scheme/base] wraps +every top-level expression to print non-@|void-const| results using @scheme[current-print].} @defform[(#%plain-module-begin form ...)]{ diff --git a/collects/scribblings/reference/vectors.scrbl b/collects/scribblings/reference/vectors.scrbl index fd90298fb3..89ed54b763 100644 --- a/collects/scribblings/reference/vectors.scrbl +++ b/collects/scribblings/reference/vectors.scrbl @@ -36,7 +36,7 @@ initialized to contain @scheme[v].} @defproc[(vector [v any/c] ...) vector?]{ -Returns a mutable vector with as many slots as provided @scheme[v]s, +Returns a newly allocated mutable vector with as many slots as provided @scheme[v]s, where the slots are initialized to contain the given @scheme[v]s in order.} @@ -44,7 +44,7 @@ order.} @defproc[(vector-immutable [v any/c] ...) (and/c vector? immutable?)]{ -Returns an immutable vector with as many slots as provided +Returns a newly allocated immutable vector with as many slots as provided @scheme[v]s, where the slots are contain the given @scheme[v]s in order.} diff --git a/collects/scribblings/tools/language.scrbl b/collects/scribblings/tools/language.scrbl index 06a9c5a209..7588598fd1 100644 --- a/collects/scribblings/tools/language.scrbl +++ b/collects/scribblings/tools/language.scrbl @@ -711,7 +711,7 @@ expressions entered in the interactions window. It is also used in other contexts by tools to expand single expressions. See also -@method[drscheme:langauge:language<%> front-end/finished-complete-program]. +@method[drscheme:language:language<%> front-end/finished-complete-program]. } @defmethod[(get-comment-character) diff --git a/collects/string-constants/danish-string-constants.ss b/collects/string-constants/danish-string-constants.ss index 93d47591be..8b72e8670b 100644 --- a/collects/string-constants/danish-string-constants.ss +++ b/collects/string-constants/danish-string-constants.ss @@ -89,7 +89,7 @@ please adhere to these guidelines: |# (module danish-string-constants "string-constant-lang.ss" - ;;; when translating this constant, substitute name of actual langauge for `English' + ;;; when translating this constant, substitute name of actual language for `English' (is-this-your-native-language "Foretrækker du dansk?") (are-you-sure-you-want-to-switch-languages diff --git a/collects/string-constants/dutch-string-constants.ss b/collects/string-constants/dutch-string-constants.ss index 4bfdf1e82f..1ae3c69f26 100644 --- a/collects/string-constants/dutch-string-constants.ss +++ b/collects/string-constants/dutch-string-constants.ss @@ -2,7 +2,7 @@ ;;; -- Where are Undo, Redo, Select all, and friends from the right-click popup menu? - ;;; when translating this constant, substitute name of actual langauge for `English' + ;;; when translating this constant, substitute name of actual language for `English' (is-this-your-native-language "Is uw moedertaal Nederlands?") (are-you-sure-you-want-to-switch-languages diff --git a/collects/string-constants/english-string-constants.ss b/collects/string-constants/english-string-constants.ss index c99832e634..d67433e980 100644 --- a/collects/string-constants/english-string-constants.ss +++ b/collects/string-constants/english-string-constants.ss @@ -89,7 +89,7 @@ please adhere to these guidelines: |# (module english-string-constants "string-constant-lang.ss" - ;;; when translating this constant, substitute name of actual langauge for `English' + ;;; when translating this constant, substitute name of actual language for `English' (is-this-your-native-language "Is English Your Native Language?") (are-you-sure-you-want-to-switch-languages @@ -1055,6 +1055,7 @@ please adhere to these guidelines: (initial-language-category "Initial language") (no-language-chosen "No language chosen") + (module-language-name "Determine language from source") (module-language-one-line-summary "Reads the #lang line to specify the actual language") (module-language-auto-text "Automatic #lang line") ;; shows up in the details section of the module language diff --git a/collects/string-constants/french-string-constants.ss b/collects/string-constants/french-string-constants.ss index 3a2ae31d86..a8fb9f6693 100644 --- a/collects/string-constants/french-string-constants.ss +++ b/collects/string-constants/french-string-constants.ss @@ -89,7 +89,7 @@ (module french-string-constants "string-constant-lang.ss" - ;;; when translating this constant, substitue name of actual langauge for `English' + ;;; when translating this constant, substitue name of actual language for `English' (is-this-your-native-language "Le Français est-il votre langue maternelle ?") (are-you-sure-you-want-to-switch-languages diff --git a/collects/string-constants/japanese-string-constants.ss b/collects/string-constants/japanese-string-constants.ss index d108d74999..a2a2585833 100644 --- a/collects/string-constants/japanese-string-constants.ss +++ b/collects/string-constants/japanese-string-constants.ss @@ -89,7 +89,7 @@ please adhere to these guidelines: |# (module japanese-string-constants "string-constant-lang.ss" - ;;; when translating this constant, substitute name of actual langauge for `English' + ;;; when translating this constant, substitute name of actual language for `English' (is-this-your-native-language "Is Japanese Your Native Language?") (are-you-sure-you-want-to-switch-languages diff --git a/collects/string-constants/spanish-string-constants.ss b/collects/string-constants/spanish-string-constants.ss index f194d57ff7..7bd67b0326 100644 --- a/collects/string-constants/spanish-string-constants.ss +++ b/collects/string-constants/spanish-string-constants.ss @@ -1,6 +1,6 @@ (module spanish-string-constants "string-constant-lang.ss" - ;;; when translating this constant, substitue name of actual langauge for `English' + ;;; when translating this constant, substitue name of actual language for `English' (is-this-your-native-language "¿Es español tu idioma materno?") diff --git a/collects/string-constants/string-constant.ss b/collects/string-constants/string-constant.ss index 4f317394ca..f61b3ff0a5 100644 --- a/collects/string-constants/string-constant.ss +++ b/collects/string-constants/string-constant.ss @@ -87,8 +87,8 @@ ;; isn't well-formed according to `read' you get all output ;; If the environment variable is set to a symbol (according to read) ;; you get that language. If it is set to a list of symbols - ;; (again, according to read) you get those langauges. - ;; if it is set to anything else, you get all langauges. + ;; (again, according to read) you get those languages. + ;; if it is set to anything else, you get all languages. (define (env-var-set? lang) (cond [(symbol? specific) (eq? lang specific)] diff --git a/collects/swindle/tool.ss b/collects/swindle/tool.ss index dd9fa09615..ee8673c16a 100644 --- a/collects/swindle/tool.ss +++ b/collects/swindle/tool.ss @@ -9,6 +9,7 @@ mzlib/list mred net/sendurl + macro-debugger/capability string-constants) (provide tool@) @@ -34,6 +35,11 @@ v (namespace-syntax-introduce v))))) (super-instantiate ())))) + (define/augment (capability-value key) + (cond + [(eq? key macro-stepper-capability-key) #t] + [else (inner (drscheme:language:get-capability-default key) + capability-value key)])) (define/override (use-namespace-require/copy?) #t) (define/override (default-settings) (drscheme:language:make-simple-settings diff --git a/collects/syntax/private/stxparse/lib.ss b/collects/syntax/private/stxparse/lib.ss index 0513e79599..3506fb08c0 100644 --- a/collects/syntax/private/stxparse/lib.ss +++ b/collects/syntax/private/stxparse/lib.ss @@ -3,11 +3,9 @@ (require "sc.ss" "../util.ss" syntax/stx - syntax/kerncase scheme/struct-info unstable/srcloc (for-syntax scheme/base - syntax/kerncase "rep.ss" (only-in "rep-data.ss" make-literalset)) (for-template scheme/base @@ -117,9 +115,26 @@ (quote-syntax x)))) ;; Literal sets - -(define-syntax kernel-literals - (make-literalset - (list* (list '#%plain-module-begin (quote-syntax #%plain-module-begin)) - (for/list ([id (kernel-form-identifier-list)]) - (list (syntax-e id) id))))) + +(define-literal-set kernel-literals + (begin + begin0 + define-values + define-syntaxes + define-values-for-syntax + set! + let-values + letrec-values + #%plain-lambda + case-lambda + if + quote + letrec-syntaxes+values + with-continuation-mark + #%expression + #%plain-app + #%top + #%datum + #%variable-reference + module #%provide #%require + #%plain-module-begin)) diff --git a/collects/syntax/private/stxparse/minimatch.ss b/collects/syntax/private/stxparse/minimatch.ss index 65c3889edd..bd177143b0 100644 --- a/collects/syntax/private/stxparse/minimatch.ss +++ b/collects/syntax/private/stxparse/minimatch.ss @@ -77,6 +77,7 @@ (match-p xps (list p ...) success failure)) failure)))])) +#; (define-syntax struct (lambda (stx) (raise-syntax-error #f "illegal use of keyword" stx))) diff --git a/collects/syntax/private/stxparse/parse.ss b/collects/syntax/private/stxparse/parse.ss index fa1ac61e5b..ac002b221f 100644 --- a/collects/syntax/private/stxparse/parse.ss +++ b/collects/syntax/private/stxparse/parse.ss @@ -52,15 +52,18 @@ (syntax-case stx () [(parse:rhs #s(rhs _ _ transparent? _ variants (def ...)) relsattrs (arg ...) get-description splicing?) - #`(lambda (x arg ...) - (define (fail-rhs failure) - (expectation-of-thing (get-description arg ...) - transparent? - (if transparent? failure #f))) - def ... - (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) - (with-enclosing-fail* fail-rhs - (parse:variants x relsattrs variants splicing?))))])) + #`(with-error-collector + (make-parser + (lambda (x arg ...) + (define (fail-rhs failure) + (expectation-of-thing (get-description arg ...) + transparent? + (if transparent? failure #f))) + def ... + (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) + (with-enclosing-fail* fail-rhs + (parse:variants x relsattrs variants splicing?)))) + (collect-error)))])) ;; (parse:variants id (SAttr ...) (Variant ...) boolean) ;; : expr[SyntaxClassResult] @@ -366,6 +369,7 @@ #'#s(pat:compound attrs #:pair (head-part tail-part)))]))) ;; (parse:H id FCE HeadPattern id id expr) : expr +;; x must not alias rest (define-syntax (parse:H stx) (syntax-case stx () [(parse:H x fc head rest rest-fc k) @@ -468,11 +472,11 @@ [(attr-repc ...) attr-repcs]) (define-pattern-variable alt-map #'((id . alt-id) ...)) (define-pattern-variable loop-k - #'(dots-loop dx loop-fc* enclosing-fail rel-rep ... alt-id ...)) + #'(dots-loop dx* loop-fc* enclosing-fail rel-rep ... alt-id ...)) #`(let () (define (dots-loop dx loop-fc loop-fail rel-rep ... alt-id ...) (with-enclosing-fail loop-fail - (try (parse:EH dx loop-fc head head-repc loop-fc* alt-map head-rep + (try (parse:EH dx loop-fc head head-repc dx* loop-fc* alt-map head-rep loop-k) ... (cond [(< rel-rep (rep:min-number rel-repc)) @@ -491,7 +495,7 @@ ;; RepConstraint/#f expr) : expr (define-syntax (parse:EH stx) (syntax-case stx () - [(parse:EH x fc head repc fc* alts rep k0) + [(parse:EH x fc head repc x* fc* alts rep k0) (let () (define-pattern-variable k (let* ([main-attrs (wash-iattrs (pattern-attrs (wash #'head)))] @@ -508,11 +512,11 @@ #`(let ([alt-id (rep:combine repc (attribute id) alt-id)] ...) k0)))) (syntax-case #'repc () - [#f #`(parse:H x fc head x fc* k)] - [_ #`(parse:H x fc head x fc* + [#f #`(parse:H x fc head x* fc* k)] + [_ #`(parse:H x fc head x* fc* (if (< rep (rep:max-number repc)) (let ([rep (add1 rep)]) k) - (fail x + (fail x* #:expect (expectation-of-reps/too-many rep repc) #:fce fc*)))]))])) @@ -566,17 +570,19 @@ ;; (expectation Pattern) (define-syntax (expectation stx) (syntax-case stx () - [(_ #s(pat:datum attrs datum)) - #'(make-expect:atom 'datum)] - [(_ #s(pat:literal attrs literal)) - #'(make-expect:literal (quote-syntax literal))] + [(_ #s(pat:datum attrs d)) + #'(begin (collect-error '(datum d)) + (make-expect:atom 'd))] + [(_ #s(pat:literal attrs lit)) + #'(begin (collect-error '(literal lit)) + (make-expect:literal (quote-syntax lit)))] ;; 2 pat:compound patterns ;;[(_ #s(pat:compound attrs #:pair (head-pattern tail-pattern))) ;; #'(make-expect:pair)] [(_ #s(pat:compound attrs kind0 (part-pattern ...))) - #''ineffable] + #'(collect-error 'ineffable)] [(_ #s(pat:not _ pattern)) - #''ineffable] + #'(collect-error 'ineffable)] [(_ #s(ghost:fail _ condition message)) #'(expectation-of-message message)])) @@ -586,8 +592,10 @@ (make-expect:thing description transparent? chained)) (define-syntax-rule (expectation-of-message message) - (let ([msg message]) - (if msg (make-expect:message msg) 'ineffable))) + (let ([msg (collect-error message)]) + (if msg + (make-expect:message msg) + 'ineffable))) (define-syntax expectation-of-reps/too-few (syntax-rules () @@ -607,18 +615,45 @@ [(_ rep #s(rep:bounds min max name too-few-msg too-many-msg)) (expectation-of-message/too-many too-many-msg name)])) -(define-syntax-rule (expectation-of-message/too-few msg name) - (expectation-of-message - (or msg - (let ([n name]) - (if n - (format "missing required occurrence of ~a" n) - "repetition constraint violated"))))) +(define-syntax expectation-of-message/too-few + (syntax-rules () + [(emtf #f #f) + (expectation-of-message "repetition constraint violated")] + [(emtf #f name) + (expectation-of-message + (format "missing required occurrence of ~a" name))] + [(emtf msg _) + (expectation-of-message msg)])) -(define-syntax-rule (expectation-of-message/too-many msg name) - (expectation-of-message - (or msg - (let ([n name]) - (if n - (format "too many occurrences of ~a" n) - "repetition constraint violated"))))) +(define-syntax expectation-of-message/too-many + (syntax-rules () + [(emtm #f #f) + (expectation-of-message + (format "repetition constraint violated"))] + [(emtm #f name) + (expectation-of-message + (format "too many occurrences of ~a" name))] + [(emtm msg _) + (expectation-of-message msg)])) + +;; + +(define-syntax-parameter collect-error + (syntax-rules () + [(ce thing) thing] + [(ce) '()])) + +(define-syntax-rule (with-error-collector body) + (... + (let-syntax ([tmp (box null)]) + (syntax-parameterize ((collect-error + (lambda (stx) + (let ([b (syntax-local-value #'tmp)]) + (syntax-case stx () + [(ce thing) + (begin (set-box! b (cons #'thing (unbox b))) + #'thing)] + [(ce) + (with-syntax ([(thing ...) (reverse (unbox b))]) + #'(list #'thing ...))]))))) + body)))) diff --git a/collects/syntax/private/stxparse/rep-data.ss b/collects/syntax/private/stxparse/rep-data.ss index 9e9fd549bd..1d4330d088 100644 --- a/collects/syntax/private/stxparse/rep-data.ss +++ b/collects/syntax/private/stxparse/rep-data.ss @@ -4,6 +4,7 @@ syntax/stx syntax/id-table "../util.ss" + "minimatch.ss" "rep-attrs.ss" "rep-patterns.ss") (provide (all-from-out "rep-attrs.ss") @@ -81,14 +82,18 @@ A LiteralSet is DeclEnv = (make-declenv immutable-bound-id-mapping[id => DeclEntry] (listof ConventionRule)) + DeclEntry = - (list 'literal id id) - (list 'stxclass id id (listof stx)) - (list 'parser id id (listof IAttr)) - #f + (make-den:lit id id) + (make-den:class id id (listof syntax) bool) + (make-den:parser id id (listof SAttr) bool) |# (define-struct declenv (table conventions)) +(define-struct den:lit (internal external)) +(define-struct den:class (name class args)) +(define-struct den:parser (parser description attrs splicing?)) + (define (new-declenv literals #:conventions [conventions null]) (for/fold ([decls (make-declenv (make-immutable-bound-id-table) conventions)]) ([literal literals]) @@ -104,45 +109,63 @@ DeclEntry = ;; Order goes: literals, pattern, declares ;; So blame-declare? only applies to stxclass declares (let ([val (declenv-lookup env id #:use-conventions? #f)]) - (when val - (cond [(eq? 'literal (car val)) - (wrong-syntax id "identifier previously declared as literal")] - [(and blame-declare? stxclass-name) - (wrong-syntax (cadr val) - "identifier previously declared with syntax class ~a" - stxclass-name)] - [else - (wrong-syntax (if blame-declare? (cadr val) id) - "identifier previously declared")])))) + (match val + [(struct den:lit (_i _e)) + (wrong-syntax id "identifier previously declared as literal")] + [(struct den:class (name _c _a)) + (if (and blame-declare? stxclass-name) + (wrong-syntax name + "identifier previously declared with syntax class ~a" + stxclass-name) + (wrong-syntax (if blame-declare? name id) + "identifier previously declared"))] + [(struct den:parser (_p _d _a _sp)) + (wrong-syntax id "(internal error) late unbound check")] + ['#f (void)]))) (define (declenv-put-literal env internal-id lit-id) (declenv-check-unbound env internal-id) (make-declenv (bound-id-table-set (declenv-table env) internal-id - (list 'literal internal-id lit-id)) + (make den:lit internal-id lit-id)) (declenv-conventions env))) (define (declenv-put-stxclass env id stxclass-name args) (declenv-check-unbound env id) (make-declenv (bound-id-table-set (declenv-table env) id - (list 'stxclass id stxclass-name args)) + (make den:class id stxclass-name args)) (declenv-conventions env))) (define (declenv-put-parser env id parser get-description attrs splicing?) ;; no unbound check, since replacing 'stxclass entry (make-declenv (bound-id-table-set (declenv-table env) id - (list (if splicing? 'splicing-parser 'parser) - parser get-description attrs)) + (make den:parser parser get-description attrs splicing?)) (declenv-conventions env))) +;; declenv-update/fold : DeclEnv (Id/Regexp DeclEntry a -> DeclEntry a) a +;; -> (values DeclEnv a) +(define (declenv-update/fold env0 f acc0) + (define-values (acc1 rules1) + (for/fold ([acc acc0] [newrules null]) + ([rule (declenv-conventions env0)]) + (let-values ([(val acc) (f (car rule) (cadr rule) acc)]) + (values acc (cons (list (car rule) val) newrules))))) + (define-values (acc2 table2) + (for/fold ([acc acc1] [table (make-immutable-bound-id-table)]) + ([(k v) (in-dict (declenv-table env0))]) + (let-values ([(val acc) (f k v acc)]) + (values acc (bound-id-table-set table k val))))) + (values (make-declenv table2 (reverse rules1)) + acc2)) + ;; returns ids in domain of env but not in given list (define (declenv-domain-difference env ids) (define idbm (make-bound-id-table)) (for ([id ids]) (bound-id-table-set! idbm id #t)) (for/list ([(k v) (in-dict (declenv-table env))] - #:when (and (pair? v) (not (eq? (car v) 'literal))) + #:when (or (den:class? v) (den:parser? v)) #:when (not (bound-id-table-ref idbm k #f))) k)) @@ -158,11 +181,19 @@ DeclEntry = (define DeclEnv/c (flat-named-contract 'DeclEnv declenv?)) +(define DeclEntry/c + (flat-named-contract 'DeclEntry (or/c den:lit? den:class? den:parser?))) + (define SideClause/c (or/c clause:fail? clause:with? clause:attr?)) +(provide (struct-out den:lit) + (struct-out den:class) + (struct-out den:parser)) + (provide/contract [DeclEnv/c contract?] + [DeclEntry/c contract?] [SideClause/c contract?] [make-dummy-stxclass (-> identifier? stxclass?)] @@ -177,14 +208,20 @@ DeclEntry = [declenv-put-stxclass (-> DeclEnv/c identifier? identifier? (listof syntax?) DeclEnv/c)] + [declenv-put-literal + (-> DeclEnv/c identifier? identifier? + DeclEnv/c)] [declenv-put-parser (-> DeclEnv/c identifier? any/c any/c (listof sattr?) boolean? DeclEnv/c)] [declenv-domain-difference (-> DeclEnv/c (listof identifier?) (listof identifier?))] - [declenv-table - (-> DeclEnv/c any)] + [declenv-update/fold + (-> DeclEnv/c + (-> (or/c identifier? regexp?) DeclEntry/c any/c (values DeclEntry/c any/c)) + any/c + (values DeclEnv/c any/c))] [get-stxclass (-> identifier? any)] diff --git a/collects/syntax/private/stxparse/rep.ss b/collects/syntax/private/stxparse/rep.ss index b0a31a43c3..ec1ce9f8f5 100644 --- a/collects/syntax/private/stxparse/rep.ss +++ b/collects/syntax/private/stxparse/rep.ss @@ -18,7 +18,7 @@ (provide/contract [parse-rhs - (-> syntax? boolean? boolean? #:context (or/c false/c syntax?) + (-> syntax? (or/c false/c (listof sattr?)) boolean? #:context (or/c false/c syntax?) rhs?)] [parse-whole-pattern (-> syntax? DeclEnv/c #:context (or/c false/c syntax?) @@ -39,8 +39,8 @@ (values DeclEnv/c (listof syntax?)))] |# [create-aux-def - (-> list? ;; DeclEntry - (values identifier? identifier? (listof sattr?) (listof syntax?) boolean?))] + (-> DeclEntry/c + (values DeclEntry/c (listof syntax?)))] [check-literals-list (-> syntax? syntax? (listof (list/c identifier? identifier?)))] @@ -67,9 +67,10 @@ (free-identifier=? stx kw) (begin (disappeared! stx) #t)))) -(define wildcard? (id-predicate (quote-syntax _))) -(define epsilon? (id-predicate (quote-syntax ||))) -(define dots? (id-predicate (quote-syntax ...))) +(define wildcard? (id-predicate (quote-syntax _))) +(define epsilon? (id-predicate (quote-syntax ||))) +(define dots? (id-predicate (quote-syntax ...))) +(define plus-dots? (id-predicate (quote-syntax ...+))) (define keywords (list (quote-syntax _) @@ -85,13 +86,14 @@ (quote-syntax ~rep) (quote-syntax ~once) (quote-syntax ~optional) - (quote-syntax ~bounds) + (quote-syntax ~between) (quote-syntax ~rest) (quote-syntax ~describe) (quote-syntax ~!) (quote-syntax ~bind) (quote-syntax ~fail) - (quote-syntax ~parse))) + (quote-syntax ~parse) + (quote-syntax ...+))) (define (reserved? stx) (and (identifier? stx) @@ -116,20 +118,20 @@ ;; --- -;; parse-rhs : stx boolean boolean stx -> RHS -;; If strict? is true, then referenced stxclasses must be defined and +;; parse-rhs : stx boolean (or #f (listof SAttr)) stx -> RHS +;; If expected-attrs is true, then referenced stxclasses must be defined and ;; literals must be bound. Set to #f for pass1 (attr collection); ;; parser requires stxclasses to be bound. -(define (parse-rhs stx strict? splicing? #:context ctx) +(define (parse-rhs stx expected-attrs splicing? #:context ctx) (parameterize ((current-syntax-context ctx)) (define-values (rest description transp? attributes auto-nested? decls defs) - (parse-rhs/part1 stx strict?)) + (parse-rhs/part1 stx (and expected-attrs #t))) (define patterns (parameterize ((stxclass-lookup-config - (cond [strict? 'yes] + (cond [expected-attrs 'yes] [auto-nested? 'try] [else 'no]))) - (parse-variants rest decls splicing?))) + (parse-variants rest decls splicing? expected-attrs))) (when (null? patterns) (wrong-syntax #f "expected at least one variant")) (let ([sattrs @@ -151,12 +153,12 @@ (define-values (decls defs) (get-decls+defs chunks strict?)) (values rest description transparent? attributes auto-nested? decls defs)) -(define (parse-variants rest decls splicing?) +(define (parse-variants rest decls splicing? expected-attrs) (define (gather-patterns stx) (syntax-case stx (pattern) [((pattern . _) . rest) (begin (disappeared! (stx-car stx)) - (cons (parse-variant (stx-car stx) splicing? decls) + (cons (parse-variant (stx-car stx) splicing? decls expected-attrs) (gather-patterns #'rest)))] [(bad-variant . rest) (wrong-syntax #'bad-variant "expected syntax-class variant")] @@ -175,10 +177,11 @@ (define lits (options-select-value chunks '#:literals #:default null)) (define litsets (options-select-value chunks '#:literal-sets #:default null)) (define convs (options-select-value chunks '#:conventions #:default null)) + (define localconvs (options-select-value chunks '#:local-conventions #:default null)) (define literals (append-lits+litsets (check-literals-bound lits strict?) litsets)) - (define convention-rules (apply append convs)) + (define convention-rules (apply append (cons localconvs convs))) (new-declenv literals #:conventions convention-rules)) (define (check-literals-bound lits strict?) @@ -195,31 +198,34 @@ ;; decls-create-defs : DeclEnv -> (values DeclEnv (listof stx)) (define (decls-create-defs decls0) - (for/fold ([decls decls0] [defs null]) - ([(k v) (in-dict (declenv-table decls0))] - #:when (memq (car v) '(stxclass splicing-stxclass))) - (let-values ([(parser description attrs new-defs splicing?) (create-aux-def v)]) - (values (declenv-put-parser decls k parser description attrs splicing?) - (append new-defs defs))))) + (define (updater key value defs) + (let-values ([(value newdefs) (create-aux-def value)]) + (values value (append newdefs defs)))) + (declenv-update/fold decls0 updater null)) -;; create-aux-def : DeclEntry -> (values id id (listof SAttr) (listof stx) boolean) +;; create-aux-def : DeclEntry -> (values DeclEntry (listof stx)) (define (create-aux-def entry) - (let ([sc-name (caddr entry)] - [args (cadddr entry)]) - (let ([sc (get-stxclass/check-arg-count sc-name (length args))]) - (with-syntax ([sc-parser (stxclass-parser-name sc)] - [sc-description (stxclass-description sc)]) - (if (pair? args) - (with-syntax ([x (generate-temporary 'x)] - [parser (generate-temporary sc-name)] - [description (generate-temporary sc-name)] - [(arg ...) args]) - (values #'parser #'description (stxclass-attrs sc) - (list #'(define (parser x) (sc-parser x arg ...)) - #'(define (description) (description arg ...))) - (stxclass/h? sc))) - (values #'sc-parser #'sc-description (stxclass-attrs sc) - null (stxclass/h? sc))))))) + (match entry + [(struct den:lit (_i _e)) + (values entry null)] + [(struct den:class (name class args)) + (let ([sc (get-stxclass/check-arg-count class (length args))]) + (with-syntax ([sc-parser (stxclass-parser-name sc)] + [sc-description (stxclass-description sc)]) + (if (pair? args) + (with-syntax ([x (generate-temporary 'x)] + [parser (generate-temporary class)] + [description (generate-temporary class)] + [(arg ...) args]) + (values (make den:parser #'parser #'description + (stxclass-attrs sc) (stxclass/h? sc)) + (list #'(define (parser x) (sc-parser x arg ...)) + #'(define (description) (description arg ...))))) + (values (make den:parser #'sc-parser #'sc-description + (stxclass-attrs sc) (stxclass/h? sc)) + null))))] + [(struct den:parser (_p _d _a _sp)) + (values entry null)])) (define (append-lits+litsets lits litsets) (define seen (make-bound-id-table lits)) @@ -230,8 +236,8 @@ (bound-id-table-set! seen (car lit) #t))) (apply append lits litsets)) -;; parse-variant : stx boolean DeclEnv -> RHS -(define (parse-variant stx splicing? decls0) +;; parse-variant : stx boolean DeclEnv #f/(listof Sattr) -> RHS +(define (parse-variant stx splicing? decls0 expected-attrs) (syntax-case stx (pattern) [(pattern p . rest) (let-values ([(rest decls defs clauses) @@ -249,6 +255,10 @@ (cons (pattern-attrs pattern) (side-clauses-attrss clauses)))] [sattrs (iattrs->sattrs attrs)]) + (when expected-attrs + (parameterize ((current-syntax-context stx)) + ;; Called just for error-reporting + (reorder-iattrs expected-attrs attrs))) (make variant stx sattrs pattern clauses defs)))])) (define (side-clauses-attrss clauses) @@ -367,6 +377,10 @@ (dots? #'dots) (begin (disappeared! #'dots) (parse-pat:dots stx #'head #'tail decls))] + [(head plus-dots . tail) + (plus-dots? #'plus-dots) + (begin (disappeared! #'plus-dots) + (parse-pat:plus-dots stx #'head #'tail decls))] [(head . tail) (let ([headp (parse-*-pattern #'head decls #t #t)] [tailp (parse-single-pattern #'tail decls)]) @@ -394,47 +408,50 @@ (let ([lp (parse-single-pattern (datum->syntax #f contents #'s) decls)]) (create-pat:compound `(#:pstruct ,key) (list lp))))])) -;; parse-ellipsis-head-pattern : stx DeclEnv number -> EllipsisHeadPattern +;; parse-ellipsis-head-pattern : stx DeclEnv number -> (listof EllipsisHeadPattern) (define (parse-ellipsis-head-pattern stx decls) - (syntax-case stx (~bounds ~optional ~once) + (syntax-case stx (~or ~between ~optional ~once) + [(~or . _) + (begin + (unless (stx-list? stx) + (wrong-syntax stx "expected sequence of patterns")) + (apply append + (for/list ([sub (cdr (stx->list stx))]) + (parse-ellipsis-head-pattern sub decls))))] [(~optional . _) (disappeared! stx) - (parse-ehpat/optional stx decls)] + (list (parse-ehpat/optional stx decls))] [(~once . _) (disappeared! stx) - (parse-ehpat/once stx decls)] - [(~bounds . _) + (list (parse-ehpat/once stx decls))] + [(~between . _) (disappeared! stx) - (parse-ehpat/bounds stx decls)] + (list (parse-ehpat/bounds stx decls))] [_ (let ([head (parse-head-pattern stx decls)]) - (make ehpat (map increase-depth (pattern-attrs head)) - head - #f))])) + (list (make ehpat (map increase-depth (pattern-attrs head)) + head + #f)))])) ;; ---- (define (parse-pat:id id decls allow-head?) (define entry (declenv-lookup decls id)) (match entry - [(list 'literal internal-id literal-id) - (create-pat:literal literal-id)] - [(list 'stxclass _ _ _) + [(struct den:lit (internal literal)) + (create-pat:literal literal)] + [(struct den:class (_n _c _a)) (error 'parse-pat:id - "(internal error) decls had leftover 'stxclass entry: ~s" + "(internal error) decls had leftover stxclass entry: ~s" entry)] - [(list 'splicing-stxclass _ _ _) - (error 'parse-pat:id - "(internal error) decls had leftover 'splicing-stxclass entry: ~s" - entry)] - [(list 'parser parser description attrs) - (parse-pat:id/s id parser null attrs)] - [(list 'splicing-parser parser description attrs) - (parse-pat:id/h id parser null attrs)] + [(struct den:parser (parser desc attrs splicing?)) + (if splicing? + (parse-pat:id/h id parser null attrs) + (parse-pat:id/s id parser null attrs))] ['#f - (when #f ;; FIXME: enable? + (when #t ;; FIXME: right place??? (unless (safe-name? id) - (wrong-syntax id "expected identifier not starting with ~ character"))) + (wrong-syntax id "expected identifier not starting with ~~ character"))) (let-values ([(name sc) (split-id/get-stxclass id decls)]) (if sc (parse-pat:var* id allow-head? name sc null) @@ -631,21 +648,21 @@ result)) (define (parse-pat:dots stx head tail decls) - (define headps - (syntax-case head (~or) - [(~or . _) - (begin - (unless (stx-list? head) - (wrong-syntax head "expected sequence of patterns")) - (unless (stx-pair? (stx-cdr head)) - (wrong-syntax head "expected at least one pattern")) - (for/list ([sub (cdr (stx->list head))]) - (parse-ellipsis-head-pattern sub decls)))] - [_ - (list (parse-ellipsis-head-pattern head decls))])) + (define headps (parse-ellipsis-head-pattern head decls)) (define tailp (parse-single-pattern tail decls)) + (unless (pair? headps) + (wrong-syntax head "expected at least one pattern")) (create-pat:dots headps tailp)) +(define (parse-pat:plus-dots stx head tail decls) + (define headp (parse-head-pattern head decls)) + (define tailp (parse-single-pattern tail decls)) + (define head/rep + (make-ehpat (map increase-depth (pattern-attrs headp)) + headp + (make-rep:bounds 1 +inf.0 #f #f #f))) + (create-pat:dots (list head/rep) tailp)) + (define (parse-pat:bind stx decls) (syntax-case stx () [(_ clause ...) @@ -758,8 +775,8 @@ (make rep:once name too-few-msg too-many-msg))))])) (define (parse-ehpat/bounds stx decls) - (syntax-case stx (~bounds) - [(~bounds p min max . options) + (syntax-case stx (~between) + [(~between p min max . options) (let ([head (parse-head-pattern #'p decls)]) (define minN (syntax-e #'min)) (define maxN (syntax-e #'max)) @@ -959,26 +976,32 @@ [_ (raise-syntax-error "expected conventions entry" ctx stx)])) +;; returns (listof (list regexp DeclEntry)) (define (check-conventions-rules stx ctx) (unless (stx-list? stx) (raise-syntax-error #f "expected convention rule list" ctx stx)) (for/list ([x (stx->list stx)]) (check-conventions-rule x ctx))) +;; returns (list regexp DeclEntry) (define (check-conventions-rule stx ctx) (define (check-conventions-pattern x blame) (cond [(symbol? x) (regexp (string-append "^" (regexp-quote (symbol->string x)) "$"))] [(regexp? x) x] [else (raise-syntax-error #f "expected identifier convention pattern" ctx blame)])) - (define (check-sc-expr x) + (define (check-sc-expr x rx) (syntax-case x () - [sc (identifier? #'sc) (list #'sc null)] - [(sc arg ...) (identifier? #'sc) (list #'sc (syntax->list #'(arg ...)))] + [sc + (identifier? #'sc) + (make den:class rx #'sc null)] + [(sc arg ...) + (identifier? #'sc) + (make den:class rx #'sc (syntax->list #'(arg ...)))] [_ (raise-syntax-error #f "expected syntax class use" ctx x)])) (syntax-case stx () [(rx sc) (list (check-conventions-pattern (syntax-e #'rx) #'rx) - (check-sc-expr #'sc))])) + (check-sc-expr #'sc #'rx))])) ;; bind clauses (define (check-bind-clause-list stx ctx) @@ -993,11 +1016,15 @@ (make clause:attr (check-attr-arity #'attr-decl ctx) #'expr)] [_ (raise-syntax-error #f "expected bind clause" ctx clause)])) + +;; Directive tables + ;; common-parse-directive-table (define common-parse-directive-table (list (list '#:literals check-literals-list) (list '#:literal-sets check-literal-sets-list) - (list '#:conventions check-conventions-list))) + (list '#:conventions check-conventions-list) + (list '#:local-conventions check-conventions-rules))) ;; parse-directive-table (define parse-directive-table diff --git a/collects/syntax/private/stxparse/runtime-prose.ss b/collects/syntax/private/stxparse/runtime-prose.ss index 7cec766378..18bbd221f3 100644 --- a/collects/syntax/private/stxparse/runtime-prose.ss +++ b/collects/syntax/private/stxparse/runtime-prose.ss @@ -143,7 +143,8 @@ (for-alternative alt index stx)) ";" "or")))] [(eq? e 'ineffable) - #f])) + #f] + [else (error 'prose-for-expectation "unexpected: ~e" e)])) (define (for-alternative e index stx) (match e @@ -188,3 +189,50 @@ [(a . b) (cons #'a (improper-stx->list #'b))] [() null] [rest (list #'rest)])) + + +;; Ad-hoc interpretation of error message expressions +(provide interpret-error-expression) + +;; Recognize application of 'format' procedure +(define (interpret-error-expression e) + (define vars '(X Y Z)) + + ;; minieval : syntax -> (or syntax datum) + ;; Returns syntax on NON-evalable stuff, datum otherwise + (define (minieval x) + (syntax-case x (format quote datum literal) + [(format str arg ...) + (string? (syntax-e #'str)) + (let ([args (map minieval (syntax->list #'(arg ...)))]) + (define args* + (cond [(<= (length (filter syntax? args)) (length vars)) + (for/list ([arg args]) + (if (syntax? arg) + (begin0 (car vars) (set! vars (cdr vars))) + arg))] + [else + (let ([counter 1]) + (for/list ([arg args]) + (if (syntax? arg) + (begin0 (format "Q~a" counter) + (set! counter (add1 counter))) + arg)))])) + (apply format (syntax-e #'str) args*))] + [(quote (datum d)) + (format "expected the literal ~a" (syntax->datum #'d))] + [(quote (literal lit)) + (format "expected the literal identifier ~s" (syntax-e #'lit))] + [(quote thing) + (syntax->datum #'thing)] + [d + (let ([d (syntax->datum #'d)]) + (or (string? d) (number? d) (boolean? d))) + (syntax->datum #'d)] + [_ + x])) + (let ([ie (minieval e)]) + (if (syntax? ie) + (syntax->datum ie) + ie))) + diff --git a/collects/syntax/private/stxparse/runtime.ss b/collects/syntax/private/stxparse/runtime.ss index 5b34ed2353..db5283ee20 100644 --- a/collects/syntax/private/stxparse/runtime.ss +++ b/collects/syntax/private/stxparse/runtime.ss @@ -19,7 +19,7 @@ ~or ~not ~seq - ~bounds + ~between ~once ~optional ~rest @@ -28,6 +28,7 @@ ~bind ~fail ~parse + ...+ current-expression current-macro-name @@ -84,7 +85,7 @@ (define-keyword ~or) (define-keyword ~not) (define-keyword ~seq) -(define-keyword ~bounds) +(define-keyword ~between) (define-keyword ~once) (define-keyword ~optional) (define-keyword ~rest) @@ -93,6 +94,7 @@ (define-keyword ~bind) (define-keyword ~fail) (define-keyword ~parse) +(define-keyword ...+) ;; == Parameters & Syntax Parameters @@ -569,3 +571,11 @@ An Expectation is one of [(make expect:thing thing '#t chained) (make expect:thing thing #t (failure->sexpr chained))] [_ expectation])) + + +;; + +(provide (struct-out parser)) + +(define-struct parser (proc errors) + #:property prop:procedure (struct-field-index proc)) diff --git a/collects/syntax/private/stxparse/sc.ss b/collects/syntax/private/stxparse/sc.ss index e449d5e1c6..16dd9ec823 100644 --- a/collects/syntax/private/stxparse/sc.ss +++ b/collects/syntax/private/stxparse/sc.ss @@ -5,6 +5,7 @@ unstable/struct "rep-data.ss" "rep.ss") + scheme/list syntax/stx "parse.ss" "runtime.ss" @@ -17,6 +18,7 @@ define-conventions syntax-class-parse syntax-class-attributes + syntax-class-possible-errors debug-rhs debug-pattern @@ -33,7 +35,7 @@ ~or ~not ~seq - ~bounds + ~between ~once ~optional ~rest @@ -42,6 +44,7 @@ ~bind ~fail ~parse + ...+ attribute this-syntax) @@ -93,15 +96,14 @@ (with-syntax ([([entry (def ...)] ...) (for/list ([line (check-conventions-rules #'(rule ...) stx)]) (let ([rx (car line)] - [sc (car (cadr line))] - [args (cadr (cadr line))]) - (let-values ([(parser description attrs defs splicing?) - (create-aux-def (list 'stxclass rx sc args))]) + [den (cadr line)]) + (let-values ([(den defs) (create-aux-def den)]) (list #`(list (quote #,rx) - (list (quote #,(if splicing? 'splicing-parser 'parser)) - (quote-syntax #,parser) - (quote-syntax #,description) - (quote #,attrs))) + (make-den:parser + (quote-syntax #,(den:parser-parser den)) + (quote-syntax #,(den:parser-description den)) + (quote #,(den:parser-attrs den)) + (quote #,(den:parser-splicing? den)))) defs))))]) #'(begin def ... ... @@ -129,7 +131,8 @@ (with-disappeared-uses (let ([rhs (parameterize ((current-syntax-context #'ctx)) - (parse-rhs #'rhss #t (syntax-e #'splicing?) #:context #'ctx))]) + (parse-rhs #'rhss (syntax->datum #'attrs) (syntax-e #'splicing?) + #:context #'ctx))]) #`(let ([get-description (lambda args #,(or (rhs-description rhs) @@ -165,6 +168,15 @@ [(depth ...) (map attr-depth attrs)]) #'(quote ((a depth) ...)))))])) +(define-syntax (syntax-class-possible-errors stx) + (syntax-case stx () + [(_ s) + (parameterize ((current-syntax-context stx)) + (with-syntax ([p (stxclass-parser-name (get-stxclass #'s))]) + #'(remove-duplicates + (map interpret-error-expression + (parser-errors p)))))])) + (define-syntax (debug-rhs stx) (syntax-case stx () [(debug-rhs rhs) diff --git a/collects/syntax/scribblings/parse-patterns.scrbl b/collects/syntax/scribblings/parse-patterns.scrbl index 81cdceb011..c47fea6dd7 100644 --- a/collects/syntax/scribblings/parse-patterns.scrbl +++ b/collects/syntax/scribblings/parse-patterns.scrbl @@ -4,14 +4,22 @@ scribble/decode scribble/eval scheme/sandbox + (for-syntax scheme/base) (for-label scheme/base scheme/contract - syntax/parse + (rename-in syntax/parse [...+ DOTSPLUS]) syntax/kerncase)) -@(define ellipses @scheme[...]) +@(define-syntax-rule (define-dotsplus-names dotsplus def-dotsplus) + (begin (require (for-label (only-in syntax/parse ...+))) + (define dotsplus (scheme ...+)) + (define def-dotsplus (defhere ...+)))) +@(define-dotsplus-names dotsplus def-dotsplus) + @(define-syntax-rule (defhere id) (defidentifier #'id #:form? #t)) +@(define ellipses @scheme[...]) + @(define Spattern "single-term pattern") @(define Lpattern "list pattern") @(define Hpattern "head pattern") @@ -84,7 +92,7 @@ When a special form in this manual refers to @svar[syntax-pattern] means specifically @tech{@Spattern}. @schemegrammar*[#:literals (_ ~var ~literal ~or ~and ~not ~rest ~datum - ~describe ~seq ~optional ~rep ~once + ~describe ~seq ~optional ~rep ~once ~between ~! ~bind ~fail ~parse) [S-pattern pvar-id @@ -97,8 +105,8 @@ means specifically @tech{@Spattern}. (~datum datum) (H-pattern . S-pattern) (A-pattern . S-pattern) - ((@#,ref[~or eh] EH-pattern ...+) #,ellipses . S-pattern) (EH-pattern #,ellipses . S-pattern) + (H-pattern @#,dotsplus . S-pattern) (@#,ref[~and s] proper-S/A-pattern ...+) (@#,ref[~or s] S-pattern ...+) (~not S-pattern) @@ -112,8 +120,8 @@ means specifically @tech{@Spattern}. () (A-pattern . L-pattern) (H-pattern . L-pattern) - ((@#,ref[~or eh] EH-pattern ...+) #,ellipses . L-pattern) (EH-pattern #,ellipses . L-pattern) + (H-pattern @#,dotsplus . L-pattern) (~rest L-pattern)] [H-pattern pvar-id:splicing-syntax-class-id @@ -125,8 +133,10 @@ means specifically @tech{@Spattern}. (@#,ref[~describe h] expr H-pattern) proper-S-pattern] [EH-pattern + (@#,ref[~or eh] EH-pattern ...) (~once H-pattern once-option ...) (@#,ref[~optional eh] H-pattern optional-option ...) + (~between H min-number max-number between-option) H-pattern] [A-pattern ~! @@ -160,10 +170,10 @@ One of @ref[~and s], @ref[~and h], or @ref[~and a]: @defidform[~or]{ -One of @ref[~or s], @ref[~or h]), or @ref[~or eh]: +One of @ref[~or s], @ref[~or h], or @ref[~or eh]: @itemize[ @item{@ref[~or eh] if the pattern occurs directly before ellipses - (@ellipses)} + (@ellipses) or immediately within another @ref[~or eh] pattern} @item{@ref[~or h] if any of the disjuncts is a @tech{proper @Hpattern}} @item{@ref[~or s] otherwise} ] @@ -396,11 +406,11 @@ words, @Apatterns ``don't take up space.'' See @tech{@Apatterns} for more information. } -@specsubform[((@#,def[~or eh] EH-pattern ...+) #,ellipses . S-pattern)]{ +@specsubform[(EH-pattern #,ellipses . S-pattern)]{ Matches any term that can be decomposed into a list head matching some -number of repetitions of @scheme[EH-pattern] alternatives (subject to -its repetition constraints) followed by a list tail matching +number of repetitions of the @scheme[EH-pattern] alternatives (subject +to its repetition constraints) followed by a list tail matching @scheme[S-pattern]. In other words, the whole pattern matches either the second pattern @@ -411,10 +421,25 @@ the whole sequence pattern. See @tech{@EHpatterns} for more information. } -@specsubform[(EH-pattern #,ellipses . S-pattern)]{ +@specsubform[(H-pattern @#,def-dotsplus . S-pattern)]{ + +Like an ellipses (@ellipses) pattern, but requires at one occurrence +of the head pattern to be present. + +That is, the following patterns are equivalent: +@itemize[ +@item[@scheme[(H @#,dotsplus . S)]] +@item[@scheme[((~between H 1 +inf.0) ... . S)]] +] + +@myexamples[ +(syntax-parse #'(1 2 3) + [(n:nat ...+) 'ok]) +(syntax-parse #'() + [(n:nat ...+) 'ok] + [_ 'none]) +] -The @scheme[~or]-free variant of ellipses (@ellipses) pattern is -equivalent to the @scheme[~or] variant with just one alternative. } @specsubform[(@#,def[~and s] S/A-pattern ...)]{ @@ -704,7 +729,8 @@ An @deftech{@EHpattern} (abbreviated @svar[EH-pattern]) is pattern that describes some number of terms, like a @tech{@Hpattern}, but may also place contraints on the number of times it occurs in a repetition. They are useful for matching keyword arguments where the -keywords may come in any order. +keywords may come in any order. Multiple alternatives can be grouped +together via @ref[~or eh]. @myexamples[ (define parser1 @@ -725,6 +751,12 @@ arguments. The ``pieces'' can occur in any order. Here are the variants of @elem{@EHpattern}: +@specsubform[(@#,def[~or eh] EH-pattern ...)]{ + +Matches if any of the inner @scheme[EH-pattern] alternatives match. + +} + @specsubform/subs[(@#,defhere[~once] H-pattern once-option ...) ([once-option (code:line #:name name-expr) (code:line #:too-few too-few-message-expr) @@ -734,11 +766,11 @@ Matches if the inner @scheme[H-pattern] matches. This pattern must be selected exactly once in the match of the entire repetition sequence. If the pattern is not chosen in the repetition sequence, then an error -is raised with a message, either @scheme[too-few-message-expr] or +is raised with the message either @scheme[too-few-message-expr] or @schemevalfont{"missing required occurrence of @scheme[name-expr]"}. If the pattern is chosen more than once in the repetition sequence, -then an error is raised with a message, either +then an error is raised with the message either @scheme[too-many-message-expr] or @schemevalfont{"too many occurrences of @scheme[name-expr]"}. } @@ -752,7 +784,7 @@ Matches if the inner @scheme[H-pattern] matches. This pattern may be used at most once in the match of the entire repetition. If the pattern is chosen more than once in the repetition sequence, -then an error is raised with a message, either +then an error is raised with the message either @scheme[too-many-message-expr] or @schemevalfont{"too many occurrences of @scheme[name-expr]"}. @@ -762,6 +794,25 @@ sequence. The default attributes must be a subset of the subpattern's attributes. } +@specsubform/subs[(@#,defhere[~between] H-pattern min-number max-number between-option ...) + ([reps-option (code:line #:name name-expr) + (code:line #:too-few too-few-message-expr) + (code:line #:too-many too-many-message-expr)])]{ + +Matches if the inner @scheme[H-pattern] matches. This pattern must be +selected at least @scheme[min-number] and at most @scheme[max-number] +times in the entire repetition. + +If the pattern is chosen too few times, then an error is raised with a +message, either @scheme[too-few-message-expr] or @schemevalfont{"too +few occurrences of @scheme[name-expr]"}. + +If the pattern is chosen too many times, then an error is raised with +the message either @scheme[too-many-message-expr] or +@schemevalfont{"too few occurrences of @scheme[name-expr]"}. +} + + @;{--------} diff --git a/collects/syntax/scribblings/parse.scrbl b/collects/syntax/scribblings/parse.scrbl index 891cc685e7..dc1c828c03 100644 --- a/collects/syntax/scribblings/parse.scrbl +++ b/collects/syntax/scribblings/parse.scrbl @@ -6,7 +6,7 @@ scheme/sandbox (for-label scheme/base scheme/contract - syntax/parse + (except-in syntax/parse ...+) syntax/kerncase)) @(define ellipses @scheme[...]) @@ -283,7 +283,8 @@ Two parsing forms are provided: @scheme[syntax-parse] and ([parse-option (code:line #:context context-expr) (code:line #:literals (literal ...)) (code:line #:literal-sets (literal-set ...)) - (code:line #:conventions (convention-id ...))] + (code:line #:conventions (convention-id ...)) + (code:line #:local-conventions (convention-rule ...))] [literal literal-id (pattern-id literal-id)] [literal-set literal-set-id @@ -352,6 +353,14 @@ Imports @tech{convention}s that give default syntax classes to pattern variables that do not explicitly specify a syntax class. } +@specsubform[(code:line #:local-conventions (convention-rule ...))]{ + +Uses the @tech{conventions} specified. The advantage of +@scheme[#:local-conventions] over @scheme[#:conventions] is that local +conventions can be in the scope of syntax-class parameter +bindings. See the section on @tech{conventions} for examples. +} + Each clause consists of a @tech{syntax pattern}, an optional sequence of @tech{pattern directives}, and a non-empty sequence of body expressions. @@ -386,7 +395,8 @@ structures can share syntax class definitions. (code:line #:opaque) (code:line #:literals (literal-entry ...)) (code:line #:literal-sets (literal-set ...)) - (code:line #:conventions (convention-id ...))] + (code:line #:conventions (convention-id ...)) + (code:line #:local-conventions (convention-rule ...))] [attr-arity-decl attr-name-id (attr-name-id depth)] @@ -713,8 +723,9 @@ identifiers the literal matches. ] } -@defform/subs[(define-conventions name-id (id-pattern syntax-class) ...) - ([name-pattern exact-id +@defform/subs[(define-conventions name-id convention-rule ...) + ([convention-rule (name-pattern syntax-class)] + [name-pattern exact-id name-rx] [syntax-class syntax-class-id (syntax-class-id expr ...)])]{ @@ -741,6 +752,28 @@ class. (syntax->datum #'(x0 (x ...) n0 (n ...)))]) ] +Local conventions, introduced with the @scheme[#:local-conventions] +keyword argument of @scheme[syntax-parse] and syntax class +definitions, may refer to local bindings: + +@myexamples[ +(define-syntax-class (nat> bound) + (pattern n:nat + #:fail-unless (> (syntax-e #'n) bound) + (format "expected number > ~s" bound))) + +(define-syntax-class (natlist> bound) + #:local-conventions ([N (nat> bound)]) + (pattern (N ...))) + +(define (parse-natlist> bound x) + (syntax-parse x + #:local-conventions ([NS (natlist> bound)]) + [NS 'ok])) +(parse-natlist> 0 #'(1 2 3)) +(parse-natlist> 5 #'(8 6 4 2)) +] + } @;{----------} diff --git a/collects/tests/drscheme/README.ss b/collects/tests/drscheme/README.ss deleted file mode 100644 index 004199c8a5..0000000000 --- a/collects/tests/drscheme/README.ss +++ /dev/null @@ -1,57 +0,0 @@ -#lang scheme/base -(provide all-tests) -(define all-tests (map symbol->string '( -#| - -This directory contains code for testing DrScheme. To run the tests, -load run-test.ss. It will return a function that accepts the names of -tests. Those names must be listed here. If no arguments are passed to -the function, all tests will be run. - - stepper-test.ss - - runs the stepper on the sample solutions and - checks the results. - (this test suite is not being maintained) - -|# io.ss #| - - This tests the drscheme's io implementation. - -|# repl-test.ss #| - - This tests various interactions between parameters in the - implementation of drscheme. - -|# language-test.ss #| - - This tests that all of the individual settings in the language dialog - take effect in the repl. - -|# module-lang-test.ss #| - - This tests the code involved in implementing the new module language. - - graphics.ss - - This tests the various graphic elements that can appear - in programs. - - launcher.ss - - This tests the launcher feature of drscheme. - -|# sample-solutions-one-window.ss #| - - This tests the sample solutions in HtDP, - but reuses the same drscheme window. - There is a race condition in this test, - so it is commented out here, for now. - -|# teachpack.ss #| - - Tests the teachpacks - -|# syncheck-test.ss #| - -|#))) diff --git a/collects/tests/drscheme/drscheme-test-util.ss b/collects/tests/drscheme/drscheme-test-util.ss index a59708d991..d529b5a917 100644 --- a/collects/tests/drscheme/drscheme-test-util.ss +++ b/collects/tests/drscheme/drscheme-test-util.ss @@ -1,24 +1,18 @@ -;;; util.ss +#lang scheme/base -;;; utility functions for DrScheme GUI testing - -;;; Authors: Robby Findler, Paul Steckler - -(module drscheme-test-util mzscheme - (require (prefix fw: framework) - mrlib/hierlist - mred - mzlib/class - mzlib/list - mzlib/contract - mzlib/etc - tests/utils/gui - mzlib/contract) +(require (prefix-in fw: framework) + mrlib/hierlist + scheme/gui/base + scheme/class + scheme/contract + tests/utils/gui) (provide/contract - [use-get/put-dialog ((-> any) path? . -> . void?)]) + [use-get/put-dialog (-> (-> any) path? void?)] + [set-module-language! (->* () (boolean?) void?)]) - (provide save-drscheme-window-as + (provide fire-up-drscheme + save-drscheme-window-as do-execute test-util-error poll-until @@ -83,39 +77,36 @@ ;; waits until pred return a true value and returns that. ;; if that doesn't happen by `secs', calls fail and returns that. (define poll-until - (opt-lambda (pred [secs 10] [fail (lambda () - (error 'poll-until - "timeout after ~e secs, ~e never returned a true value" - secs pred))]) + (lambda (pred [secs 10] [fail (lambda () + (error 'poll-until + "timeout after ~e secs, ~e never returned a true value" + secs pred))]) (let ([step 1/20]) - (let loop ([counter secs]) - (if (<= counter 0) - (fail) - (let ([result (pred)]) - (or result - (begin - (sleep step) - (loop (- counter step)))))))))) + (let loop ([counter secs]) + (if (<= counter 0) + (fail) + (let ([result (pred)]) + (or result + (begin + (sleep step) + (loop (- counter step)))))))))) (define (drscheme-frame? frame) (method-in-interface? 'get-execute-button (object-interface frame))) - (define wait-for-drscheme-frame - (case-lambda - [() (wait-for-drscheme-frame #t)] - [(print-message?) - (let ([wait-for-drscheme-frame-pred - (lambda () - (let ([active (get-top-level-focus-window)]) - (if (and active - (drscheme-frame? active)) - active - #f)))]) - (or (wait-for-drscheme-frame-pred) - (begin - (when print-message? - (printf "Select DrScheme frame~n")) - (poll-until wait-for-drscheme-frame-pred))))])) + (define (wait-for-drscheme-frame [print-message? #f]) + (let ([wait-for-drscheme-frame-pred + (lambda () + (let ([active (get-top-level-focus-window)]) + (if (and active + (drscheme-frame? active)) + active + #f)))]) + (or (wait-for-drscheme-frame-pred) + (begin + (when print-message? + (printf "Select DrScheme frame~n")) + (poll-until wait-for-drscheme-frame-pred))))) ;; wait-for-new-frame : frame [(listof eventspace) = null] -> frame ;; returns the newly opened frame, waiting until old-frame @@ -321,7 +312,45 @@ ;; set language level in the frontmost DrScheme frame (resets settings to defaults) ;; If `close-dialog?' it #t, (define set-language-level! - (opt-lambda (in-language-spec [close-dialog? #t]) + (lambda (in-language-spec [close-dialog? #t]) + (unless (and (pair? in-language-spec) + (list? in-language-spec) + (andmap (lambda (x) (or string? regexp?)) in-language-spec)) + (error 'set-language-level! "expected a non-empty list of regexps and strings for language, got: ~e" in-language-spec)) + (let ([drs-frame (get-top-level-focus-window)]) + (fw:test:menu-select "Language" "Choose Language...") + (let* ([language-dialog (wait-for-new-frame drs-frame)] + [language-choice (find-labelled-window #f hierarchical-list%)] + [b1 (box 0)] + [b2 (box 0)] + [click-on-snip + (lambda (snip) + (let* ([editor (send (send snip get-admin) get-editor)] + [between-threshold (send editor get-between-threshold)]) + (send editor get-snip-location snip b1 b2) + (let-values ([(gx gy) (send editor editor-location-to-dc-location + (unbox b1) + (unbox b2))]) + (let ([x (inexact->exact (+ gx between-threshold 1))] + [y (inexact->exact (+ gy between-threshold 1))]) + (fw:test:mouse-click 'left x y)))))]) + (send language-choice focus) + (let loop ([list-item language-choice] + [language-spec in-language-spec]) + (let* ([name (car language-spec)] + [which (filter (lambda (child) + (let* ([text (send (send child get-editor) get-text)] + [matches + (or (and (regexp? name) + (regexp-match name text)) + (and (string? name) + (string=? name text)))]) + (and matches + child))) + (send list-item get-items))]) + (when (null? which) + (error '(define set-language-level! + (lambda (in-language-spec [close-dialog? #t]) (unless (and (pair? in-language-spec) (list? in-language-spec) (andmap (lambda (x) (or string? regexp?)) in-language-spec)) @@ -383,6 +412,38 @@ (fw:test:button-push "Revert to Language Defaults") + (when close-dialog? + (fw:test:button-push "OK") + (let ([new-frame (wait-for-new-frame language-dialog)]) + (unless (eq? new-frame drs-frame) + (error 'set-language-level! + "didn't get drscheme frame back, got: ~s (drs-frame ~s)\n" + new-frame + drs-frame)))))))) "couldn't find language: ~e, no match at ~e" + in-language-spec name)) + (unless (= 1 (length which)) + (error 'set-language-level! "couldn't find language: ~e, double match ~e" + in-language-spec name)) + (let ([next-item (car which)]) + (cond + [(null? (cdr language-spec)) + (when (is-a? next-item hierarchical-list-compound-item<%>) + (error 'set-language-level! "expected no more languages after ~e, but still are, input ~e" + name in-language-spec)) + (click-on-snip (send next-item get-clickable-snip))] + [else + (unless (is-a? next-item hierarchical-list-compound-item<%>) + (error 'set-language-level! "expected more languages after ~e, but got to end, input ~e" + name in-language-spec)) + (unless (send next-item is-open?) + (click-on-snip (send next-item get-arrow-snip))) + (loop next-item (cdr language-spec))])))) + + (with-handlers ([exn:fail? (lambda (x) (void))]) + (fw:test:button-push "Show Details")) + + (fw:test:button-push "Revert to Language Defaults") + (when close-dialog? (fw:test:button-push "OK") (let ([new-frame (wait-for-new-frame language-dialog)]) @@ -391,7 +452,26 @@ "didn't get drscheme frame back, got: ~s (drs-frame ~s)\n" new-frame drs-frame)))))))) - + (define (set-module-language! [close-dialog? #t]) + (let ([drs-frame (get-top-level-focus-window)]) + (fw:test:menu-select "Language" "Choose Language...") + (let* ([language-dialog (wait-for-new-frame drs-frame)]) + (fw:test:set-radio-box-item! "Use the language declared in the source") + + (with-handlers ([exn:fail? (lambda (x) (void))]) + (fw:test:button-push "Show Details")) + + (fw:test:button-push "Revert to Language Defaults") + + (when close-dialog? + (fw:test:button-push "OK") + (let ([new-frame (wait-for-new-frame language-dialog)]) + (unless (eq? new-frame drs-frame) + (error 'set-language-level! + "didn't get drscheme frame back, got: ~s (drs-frame ~s)\n" + new-frame + drs-frame))))))) + (provide/contract [check-language-level ((or/c string? regexp?) . -> . void?)]) ;; checks that the language in the drscheme window is set to the given one. ;; clears the definitions, clicks execute and checks the interactions window. @@ -536,4 +616,19 @@ (semaphore-wait s) (if raised-exn? (raise exn) - (apply values anss))))) + (apply values anss)))) + + ;; this is assumed to not open an windows or anything like that + ;; but just to print and return. + (define orig-display-handler (error-display-handler)) + + (define (fire-up-drscheme) + (dynamic-require 'drscheme #f) + + ;; reset the uncaught exception handler to be sure we kill everything (drscheme sets it) + (uncaught-exception-handler + (λ (x) + (if (exn? x) + (orig-display-handler (exn-message x) x) + (fprintf (current-error-port) "uncaught exception ~s\n" x)) + (exit 1)))) \ No newline at end of file diff --git a/collects/tests/drscheme/io.ss b/collects/tests/drscheme/io.ss index 083158c872..442550537d 100644 --- a/collects/tests/drscheme/io.ss +++ b/collects/tests/drscheme/io.ss @@ -1,3 +1,5 @@ +#lang scheme/base + #| add this test: @@ -10,186 +12,191 @@ add this test: |# -(module io mzscheme - (require "drscheme-test-util.ss" - tests/utils/gui - mzlib/class - mzlib/list - mzlib/pretty - mred - framework - mrlib/text-string-style-desc - (prefix fw: framework)) - - (provide run-test) - - (define (output-err-port-checking) - (define (check-output expression expected) - (begin - (clear-definitions drs-frame) - (type-in-definitions drs-frame expression) - (do-execute drs-frame) - (let ([got (get-annotated-output)]) - (unless (and (= (length expected) - (length got)) - (andmap (λ (exp got) - (and (string=? (car exp) (car got)) - (or (equal? (cadr exp) (cadr got)) - (and (procedure? (cadr exp)) - ((cadr exp) (cadr got)))))) - expected - got)) - (fprintf (current-error-port) - "expected ~s, got ~s for ~s\n\n" - expected - got - expression))))) - - (define (get-annotated-output) - (let ([chan (make-channel)]) - (queue-callback - (λ () - (let ([text (send drs-frame get-interactions-text)]) - (channel-put chan - (get-string/style-desc text - (send text paragraph-start-position 2)))))) - (channel-get chan))) - - (define (output-style x) (eq? x '|ports out|)) - (define (error-style x) (eq? x '|ports err|)) - (define (value-style x) (eq? x '|ports value|)) - - (define prompt '("\n> " default-color)) - - ;; this test has to be first to test an uninitialized state of the port - (check-output "(port-next-location (current-input-port))" - (list `("1\n0\n1" |ports value|) - prompt)) - - (check-output "(display 1)" (list (list "1" output-style) prompt)) - (check-output "(display 1 (current-output-port))" (list (list "1" output-style) prompt)) - - (check-output "(display 1 (current-error-port))" (list (list "1" error-style) prompt)) - (check-output "(display 1) (display 1 (current-error-port))" - (list (list "1" output-style) - (list "1" error-style) - prompt)) - (check-output "(display 1 (current-error-port)) (display 1)" - (list (list "1" error-style) - (list "1" output-style) - prompt)) - (check-output "(display 1) (display 1 (current-error-port)) (display 1)" - (list (list "1" output-style) - (list "1" error-style) - (list "1" output-style) - prompt)) - (check-output "(display 1 (current-error-port)) (display 1) (display 1 (current-error-port))" - (list (list "1" error-style) - (list "1" output-style) - (list "1" error-style) - prompt)) - (check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1) (semaphore-post s))) (semaphore-wait s))" - (list (list "1" output-style) - prompt)) - (check-output - "(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-output-port)) (semaphore-post s))) (semaphore-wait s))" - (list (list "1" output-style) - prompt)) - (check-output - "(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-error-port)) (semaphore-post s))) (semaphore-wait s))" - (list (list "1" error-style) - prompt))) - - (define (long-io/execute-test) - (let ([string-port (open-output-string)]) - (pretty-print - (let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1) (cons 'r p))))) - string-port) - (clear-definitions drs-frame) - (type-in-definitions - drs-frame - "(let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1) (cons 'r p)))))") - (do-execute drs-frame) - (let ([got-output (fetch-output drs-frame)]) - (clear-definitions drs-frame) - (do-execute drs-frame) - (unless (equal? "" (fetch-output drs-frame)) - (error 'io.ss "failed long io / execute test (extra io)")) - (unless (whitespace-string=? - (get-output-string string-port) - got-output) - (error 'io.ss "failed long io / execute test (output doesn't match)"))))) - - - (define (reading-test) - (define (do-input-test program input expected-transcript) - (do-execute drs-frame) - (type-in-interactions drs-frame program) - (let ([before-newline-pos (send interactions-text last-position)]) - (type-in-interactions drs-frame (string #\newline)) - (wait (λ () - ;; the focus moves to the input box, so wait for that. - (send interactions-text get-focus-snip)) - "input box didn't appear") - - (type-string input) - (wait-for-computation drs-frame) - (let ([got-value - (fetch-output drs-frame - (send interactions-text paragraph-start-position 3) ;; start after test expression - (send interactions-text paragraph-end-position - (- (send interactions-text last-paragraph) 1)))]) - (unless (equal? got-value expected-transcript) - (printf "FAILED: expected: ~s~n got: ~s~n program: ~s~n input: ~s~n" - expected-transcript got-value program input))))) - +(require "drscheme-test-util.ss" + tests/utils/gui + mzlib/class + mzlib/pretty + mred + mrlib/text-string-style-desc) + +(define (check-output expression expected) + (begin (clear-definitions drs-frame) - (do-input-test "(read-char)" "a\n" "a\n#\\a") - (do-input-test "(read-char)" "λ\n" "λ\n#\\λ") - (do-input-test "(read-line)" "abcdef\n" "abcdef\n\"abcdef\"") - (do-input-test "(list (read-char) (read-line))" "abcdef\n" "abcdef\n(#\\a \"bcdef\")") + (type-in-definitions drs-frame expression) + (do-execute drs-frame) + (let ([got (get-annotated-output)]) + (unless (and (= (length expected) + (length got)) + (andmap (λ (exp got) + (and (string=? (car exp) (car got)) + (or (equal? (cadr exp) (cadr got)) + (and (procedure? (cadr exp)) + ((cadr exp) (cadr got)))))) + expected + got)) + (fprintf (current-error-port) + "expected ~s\n got ~s\nfor ~s\n\n" + expected + got + expression))))) - (do-input-test "(read)" "a\n" "a\na") - (do-input-test "(list (read) (read))" "a a\n" "a a\n(a a)") - (do-input-test "(list (read-char) (read))" "aa\n" "aa\n(#\\a a)") - - (do-input-test "(begin (read-char) (sleep 1) (read-char))" "ab\ncd\n" "ab\ncd\n#\\b") - (do-input-test "(list (read) (sleep 1) (read) (read))" "a b\nc d\n" "a b\nc d\n(a # b c)") - - (do-input-test "(begin (display 1) (read))" "2\n" "12\n2\n") ;; why an extra newline?! - - (do-input-test "(read-line)" "\n" "\n\"\"") - (do-input-test "(read-char)" "\n" "\n#\\newline") +(define (get-annotated-output) + (let ([chan (make-channel)]) + (queue-callback + (λ () + (let ([text (send drs-frame get-interactions-text)]) + (channel-put chan + (get-string/style-desc text + (send text paragraph-start-position 2)))))) + (channel-get chan))) - (do-input-test "(list (read) (printf \"1~n\") (read) (printf \"3~n\"))" - "0 2\n" - "0 2\n1\n3\n(0 # 2 #)") - - (do-input-test "(write (read))" - "()\n" - "()\n()") - - (do-input-test "(begin (write (read)) (write (read)))" - "(1)\n(2)\n" - "(1)\n(1)(2)\n(2)") - - (do-input-test - (string-append "(let ([b (read-byte)][bs0 (bytes 0)][bs1 (bytes 1)][bs2 (bytes 2)])" - "(read-bytes-avail!* bs0)" - "(read-bytes-avail!* bs1)" - "(read-bytes-avail!* bs2)" - "(list b bs0 bs1 bs2))\n") - "ab\n" - "ab\n(97 #\"b\" #\"\\n\" #\"\\2\")")) + +(define (output-style x) (eq? x '|ports out|)) +(define (error-style x) (eq? x '|ports err|)) +(define (value-style x) (eq? x '|ports value|)) + +(define prompt '("\n> " default-color)) + +(define (output-err-port-checking) + ;; this test has to be first to test an uninitialized state of the port + (check-output "(port-next-location (current-input-port))" + (list `("1\n0\n1\n" |ports value|) + '("> " default-color))) - (define drs-frame #f) - (define interactions-text #f) + (check-output "(display 1)" (list (list "1" output-style) prompt)) + (check-output "(display 1 (current-output-port))" (list (list "1" output-style) prompt)) - (define (run-test) - (set! drs-frame (wait-for-drscheme-frame)) - (set! interactions-text (send drs-frame get-interactions-text)) - (set-language-level! (list #rx"Pretty Big")) - (output-err-port-checking) ;; must come first - ;(long-io/execute-test) - (reading-test) - )) + (check-output "(display 1 (current-error-port))" (list (list "1" error-style) prompt)) + (check-output "(display 1) (display 1 (current-error-port))" + (list (list "1" output-style) + (list "1" error-style) + prompt)) + (check-output "(display 1 (current-error-port)) (display 1)" + (list (list "1" error-style) + (list "1" output-style) + prompt)) + (check-output "(display 1) (display 1 (current-error-port)) (display 1)" + (list (list "1" output-style) + (list "1" error-style) + (list "1" output-style) + prompt)) + (check-output "(display 1 (current-error-port)) (display 1) (display 1 (current-error-port))" + (list (list "1" error-style) + (list "1" output-style) + (list "1" error-style) + prompt)) + (check-output "(let ([s (make-semaphore)]) (thread (lambda () (display 1) (semaphore-post s))) (semaphore-wait s))" + (list (list "1" output-style) + prompt)) + (check-output + "(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-output-port)) (semaphore-post s))) (semaphore-wait s))" + (list (list "1" output-style) + prompt)) + (check-output + "(let ([s (make-semaphore)]) (thread (lambda () (display 1 (current-error-port)) (semaphore-post s))) (semaphore-wait s))" + (list (list "1" error-style) + prompt))) + +(define (long-io/execute-test) + (let ([string-port (open-output-string)]) + (pretty-print + (let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1) (cons 'r p))))) + string-port) + (clear-definitions drs-frame) + (type-in-definitions + drs-frame + "(let f ([n 7] [p null]) (if (= n 0) p (list (f (- n 1) (cons 'l p)) (f (- n 1) (cons 'r p)))))") + (do-execute drs-frame) + (let ([got-output (fetch-output drs-frame)]) + (clear-definitions drs-frame) + (do-execute drs-frame) + (unless (equal? "" (fetch-output drs-frame)) + (error 'io.ss "failed long io / execute test (extra io)")) + (unless (whitespace-string=? + (get-output-string string-port) + got-output) + (error 'io.ss "failed long io / execute test (output doesn't match)"))))) + + +(define (reading-test) + (define (do-input-test program input expected-transcript) + (do-execute drs-frame) + (type-in-interactions drs-frame program) + (let ([before-newline-pos (send interactions-text last-position)]) + (type-in-interactions drs-frame (string #\newline)) + (wait (λ () + ;; the focus moves to the input box, so wait for that. + (send interactions-text get-focus-snip)) + "input box didn't appear") + + (type-string input) + (wait-for-computation drs-frame) + (let ([got-value + (fetch-output drs-frame + (send interactions-text paragraph-start-position 3) ;; start after test expression + (send interactions-text paragraph-end-position + (- (send interactions-text last-paragraph) 1)))]) + (unless (equal? got-value expected-transcript) + (fprintf (current-error-port) + "FAILED: expected: ~s~n got: ~s~n program: ~s~n input: ~s~n" + expected-transcript got-value program input))))) + + (clear-definitions drs-frame) + (do-input-test "(read-char)" "a\n" "a\n#\\a") + (do-input-test "(read-char)" "λ\n" "λ\n#\\λ") + (do-input-test "(read-line)" "abcdef\n" "abcdef\n\"abcdef\"") + (do-input-test "(list (read-char) (read-line))" "abcdef\n" "abcdef\n(#\\a \"bcdef\")") + + (do-input-test "(read)" "a\n" "a\na") + (do-input-test "(list (read) (read))" "a a\n" "a a\n(a a)") + (do-input-test "(list (read-char) (read))" "aa\n" "aa\n(#\\a a)") + + (do-input-test "(begin (read-char) (sleep 1) (read-char))" "ab\ncd\n" "ab\ncd\n#\\b") + (do-input-test "(list (read) (sleep 1) (read) (read))" "a b\nc d\n" "a b\nc d\n(a # b c)") + + (do-input-test "(begin (display 1) (read))" "2\n" "12\n2") + + (do-input-test "(read-line)" "\n" "\n\"\"") + (do-input-test "(read-char)" "\n" "\n#\\newline") + + (do-input-test "(list (read) (printf \"1~n\") (read) (printf \"3~n\"))" + "0 2\n" + "0 2\n1\n3\n(0 # 2 #)") + + (do-input-test "(write (read))" + "()\n" + "()\n()") + + (do-input-test "(begin (write (read)) (flush-output) (write (read)))" + "(1)\n(2)\n" + "(1)\n(1)(2)\n(2)") + + (do-input-test + (string-append "(let ([b (read-byte)][bs0 (bytes 0)][bs1 (bytes 1)][bs2 (bytes 2)])" + "(read-bytes-avail!* bs0)" + "(read-bytes-avail!* bs1)" + "(read-bytes-avail!* bs2)" + "(list b bs0 bs1 bs2))\n") + "ab\n" + "ab\n(97 #\"b\" #\"\\n\" #\"\\2\")")) + +(define drs-frame #f) +(define interactions-text #f) + +(let ([s (make-semaphore)]) + (fire-up-drscheme) + (thread + (λ () + (set! drs-frame (wait-for-drscheme-frame)) + (set! interactions-text (send drs-frame get-interactions-text)) + (set-language-level! (list #rx"Pretty Big")) + (clear-definitions drs-frame) + (do-execute drs-frame) + + (output-err-port-checking) ;; must come first + ;(long-io/execute-test) + (reading-test) + (semaphore-post s))) + (yield s) + (exit)) + diff --git a/collects/tests/drscheme/language-test.ss b/collects/tests/drscheme/language-test.ss index 6ac9d7e9b3..11bc5c7c69 100644 --- a/collects/tests/drscheme/language-test.ss +++ b/collects/tests/drscheme/language-test.ss @@ -20,8 +20,6 @@ the settings above should match r5rs framework (prefix-in fw: framework)) -(provide run-test) - (define language (make-parameter "<>")) ;; set-language : boolean -> void @@ -289,10 +287,8 @@ the settings above should match r5rs "call/cc: name is not defined, not a parameter, and not a primitive name" "reference to an identifier before its definition: call/cc") - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") (test-expression "(time 1)" "time: name is not defined, not a parameter, and not a primitive name" @@ -456,10 +452,8 @@ the settings above should match r5rs "call/cc: name is not defined, not a parameter, and not a primitive name" "reference to an identifier before its definition: call/cc") - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") (test-expression "(time 1)" "time: name is not defined, not a parameter, and not a primitive name" @@ -619,10 +613,8 @@ the settings above should match r5rs "call/cc: name is not defined, not a parameter, and not a primitive name" "reference to an identifier before its definition: call/cc") - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") (test-expression "(time 1)" #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") @@ -778,10 +770,8 @@ the settings above should match r5rs "call/cc: name is not defined, not a parameter, and not a primitive name" "reference to an identifier before its definition: call/cc") - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") (test-expression "(time 1)" #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") @@ -931,10 +921,8 @@ the settings above should match r5rs "call/cc: name is not defined, not a parameter, and not a primitive name" "reference to an identifier before its definition: call/cc") - (test-expression "(error 'a \"~a\" 1)" - "procedure error: expects 2 arguments, given 3: 'a \"~a\" 1") - (test-expression "(error \"a\" \"a\")" - "error: expected a symbol and a string, got \"a\" and \"a\"") + (test-expression "(error 'a \"~a\" 1)" "a: ~a1") + (test-expression "(error \"a\" \"a\")" "aa") (test-expression "(time 1)" #rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1") @@ -1055,8 +1043,9 @@ the settings above should match r5rs (do-execute drs) (let* ([got (fetch-output/should-be-tested drs)]) (unless (string=? result got) - (printf "FAILED: ~s ~s ~s test~n expected: ~s~n got: ~s~n" - (language) setting-name expression result got))))) + (fprintf (current-error-port) + "FAILED: ~s ~s ~s test~n expected: ~s~n got: ~s~n" + (language) setting-name expression result got))))) (define (test-hash-bang) (let* ([expression "#!/bin/sh\n1"] @@ -1068,8 +1057,9 @@ the settings above should match r5rs (do-execute drs) (let* ([got (fetch-output/should-be-tested drs)]) (unless (string=? "1" got) - (printf "FAILED: ~s ~a test~n expected: ~s~n got: ~s~n" - (language) expression result got))))) + (fprintf (current-error-port) + "FAILED: ~s ~a test~n expected: ~s~n got: ~s~n" + (language) expression result got))))) (define (fetch-output/should-be-tested . args) (regexp-replace (regexp @@ -1104,14 +1094,15 @@ the settings above should match r5rs (min (string-length line1-expect) (string-length line1-got)))) (regexp-match line1-expect line1-got))) - (printf "expected lines: ~n ~a~n ~a~ngot lines:~n ~a~n ~a~n" - line0-expect line1-expect - line0-got line1-got) + (fprintf (current-error-port) + "expected lines: ~n ~a~n ~a~ngot lines:~n ~a~n ~a~n" + line0-expect line1-expect + line0-got line1-got) (error 'language-test.ss "failed get top of repl test"))))) ;; teaching-language-fraction-output -;; tests that the teaching langauges properly handle repeating decimals +;; tests that the teaching languages properly handle repeating decimals (define (teaching-language-fraction-output) (test-setting (lambda () (fw:test:set-radio-box! "Fraction Style" "Mixed fractions")) @@ -1186,10 +1177,11 @@ the settings above should match r5rs (unless (if (procedure? answer) (answer got) (whitespace-string=? answer got)) - (printf "FAILED ~s ~a, sharing ~a pretty? ~a~n got ~s~n expected ~s~n" - (language) option show-sharing pretty? - (shorten got) - (if (procedure? answer) (answer) answer)))))]) + (fprintf (current-error-port) + "FAILED ~s ~a, sharing ~a pretty? ~a~n got ~s~n expected ~s~n" + (language) option show-sharing pretty? + (shorten got) + (if (procedure? answer) (answer) answer)))))]) (clear-definitions drs) (type-in-definitions drs expression) @@ -1254,7 +1246,8 @@ the settings above should match r5rs (send interactions-text paragraph-end-position (- (send interactions-text last-paragraph) 1)))]) (unless (equal? got "0") - (printf "FAILED: test-error-after-definition failed, expected 0, got ~s\n" got)))))) + (fprintf (current-error-port) + "FAILED: test-error-after-definition failed, expected 0, got ~s\n" got)))))) ;; test-expression : (union string 'xml 'image (listof (union string 'xml 'image))) @@ -1358,3 +1351,8 @@ the settings above should match r5rs (go advanced) (go pretty-big) (go r5rs)) + +(let () + (fire-up-drscheme) + (thread (λ () (run-test) (exit))) + (yield (make-semaphore))) \ No newline at end of file diff --git a/collects/tests/drscheme/module-lang-test-utils.ss b/collects/tests/drscheme/module-lang-test-utils.ss index bc16fc483b..af9295d51e 100644 --- a/collects/tests/drscheme/module-lang-test-utils.ss +++ b/collects/tests/drscheme/module-lang-test-utils.ss @@ -75,7 +75,8 @@ (send interactions-text paragraph-start-position 2) (send interactions-text paragraph-end-position 2))]) (unless (or (test-all? test) (string=? "> " after-execute-output)) - (printf "FAILED (line ~a): ~a\n ~a\n expected no output after execution, got: ~s\n" + (fprintf (current-error-port) + "FAILED (line ~a): ~a\n ~a\n expected no output after execution, got: ~s\n" (test-line test) (test-definitions test) (or (test-interactions test) 'no-interactions) @@ -107,12 +108,13 @@ [else 'module-lang-test "bad test value: ~e" r]) r text))]) (unless output-passed? - (printf "FAILED (line ~a): ~a\n ~a\n expected: ~s\n got: ~s\n" - (test-line test) - (test-definitions test) - (or (test-interactions test) 'no-interactions) - (test-result test) - text)) + (fprintf (current-error-port) + "FAILED (line ~a): ~a\n ~a\n expected: ~s\n got: ~s\n" + (test-line test) + (test-definitions test) + (or (test-interactions test) 'no-interactions) + (test-result test) + text)) (cond [(eq? (test-error-ranges test) 'dont-test) (void)] @@ -120,11 +122,12 @@ (let ([error-ranges-expected ((test-error-ranges test) definitions-text interactions-text)]) (unless (equal? error-ranges-expected (send interactions-text get-error-ranges)) - (printf "FAILED (line ~a; ranges): ~a\n expected: ~s\n got: ~s\n" - (test-line test) - (test-definitions test) - error-ranges-expected - (send interactions-text get-error-ranges))))]))))) + (fprintf (current-error-port) + "FAILED (line ~a; ranges): ~a\n expected: ~s\n got: ~s\n" + (test-line test) + (test-definitions test) + error-ranges-expected + (send interactions-text get-error-ranges))))]))))) (define drs 'not-yet-drs-frame) @@ -139,7 +142,7 @@ (run-use-compiled-file-paths-tests) - (set-language-level! '("Module") #f) + (set-module-language! #f) (test:set-radio-box-item! "Debugging") (let ([f (get-top-level-focus-window)]) (test:button-push "OK") @@ -153,7 +156,7 @@ (define (run-use-compiled-file-paths-tests) (define (setup-dialog/run proc) - (set-language-level! '("Module") #f) + (set-module-language! #f) (proc) (let ([f (get-top-level-focus-window)]) (test:button-push "OK") @@ -163,10 +166,10 @@ (define (run-one-test radio-box expected [no-check-expected #f]) (let ([got (setup-dialog/run (λ () (test:set-radio-box-item! radio-box)))]) - (unless (equal? got (format "~s" expected)) + (unless (spaces-equal? got (format "~s" expected)) (error 'r-u-c-f-p-t "got ~s expected ~s" got - expected))) + (format "~s" expected)))) (when no-check-expected (let ([got (setup-dialog/run @@ -176,8 +179,12 @@ (unless (equal? got (format "~s" no-check-expected)) (error 'r-u-c-f-p-t.2 "got ~s expected ~s" got - expected))))) - + (format "~s" no-check-expected)))))) + + (define (spaces-equal? a b) + (equal? (regexp-replace* #rx"[\n\t ]+" a " ") + (regexp-replace* #rx"[\n\t ]+" b " "))) + (define drs/compiled/et (build-path "compiled" "drscheme" "errortrace")) (define drs/compiled (build-path "compiled" "drscheme")) (define compiled/et (build-path "compiled" "errortrace")) diff --git a/collects/tests/drscheme/module-lang-test.ss b/collects/tests/drscheme/module-lang-test.ss index ad5dd5a63c..83bbecea9f 100644 --- a/collects/tests/drscheme/module-lang-test.ss +++ b/collects/tests/drscheme/module-lang-test.ss @@ -262,3 +262,10 @@ (current-namespace (make-base-empty-namespace))} "(+ 1 2)" "3") + + +(require "drscheme-test-util.ss") +(let () + (fire-up-drscheme) + (thread (λ () (run-test) (exit))) + (yield (make-semaphore 0))) \ No newline at end of file diff --git a/collects/tests/drscheme/randomly-click.ss b/collects/tests/drscheme/randomly-click.ss index 720a5f7774..4ff449ba43 100644 --- a/collects/tests/drscheme/randomly-click.ss +++ b/collects/tests/drscheme/randomly-click.ss @@ -3,6 +3,8 @@ (provide go) (define numButtonsToPush 200) +(define the-seed (+ 1 (modulo (current-seconds) (- (expt 2 31) 1)))) +(random-seed the-seed) ;;find-all-actions: area -> (listof (-> void)) (define (find-all-actions area) @@ -67,58 +69,64 @@ (send area get-label)])) (define (g open-dialog) - (thread - (λ () - (let ((base-window (get-top-level-focus-window))) - (open-dialog) - (wait-for-different-frame base-window) - (let loop ([n numButtonsToPush] - [actions '()]) - (cond - [(zero? n) - (printf "\n") - (exit 0)] - [else - - (printf "~a " n) - (when (= 1 (modulo n 10)) (printf "\n")) - (flush-output) + (let ((base-window (get-top-level-focus-window))) + (open-dialog) + (wait-for-different-frame base-window) + (let loop ([n numButtonsToPush] + [actions '()]) + (cond + [(zero? n) + (printf "\n") + (exit 0)] + [else - (let ((window (get-top-level-focus-window))) - (cond - ;; Back to base-window is not interesting, Reopen - [(eq? base-window window) - (open-dialog) - (wait-for-different-frame base-window) - (loop (- n 1) actions)] - - ;; get-top-level-focus-window returns #f may imply window not in current eventspace - ;; but it also might just mean we didn't look into subeventspaces(?) - ;; or that we need to wait for something to happen in the GUI(?) - [(eq? window #f) - (sleep .1) - (loop (- n 1) actions)] - - [else - ;; print out the button before the button is pushed - ;; Using the toy print-label function - ;; because some of the parents may not be sent with get-label e.g. vertical-pane% - ;(print (map print-label (trace-area button window))) - (let ([action (find-random-action window)]) - (cond - [action - (with-handlers ((exn:fail? (λ (x) - (fprintf (current-error-port) - "\nExecution fail: Bug? transcript of ~a clicking follows\n" - (send window get-label)) - (apply show-log (cons action actions)) - (raise x)))) - (action)) - (loop (- n 1) (cons action actions))] - [else - (fprintf (current-error-port) "\nExists/Meets window with no button: Bug? -> Reopen Dialog") - (open-dialog) - (loop n actions)]))]))])))))) + (printf "~a " n) + (when (= 1 (modulo n 10)) (printf "\n")) + (flush-output) + + (let ((window (get-top-level-focus-window))) + (cond + ;; Back to base-window is not interesting, Reopen + [(eq? base-window window) + (open-dialog) + (wait-for-different-frame base-window) + (loop (- n 1) actions)] + + ;; get-top-level-focus-window returns #f may imply window not in current eventspace + ;; but it also might just mean we didn't look into subeventspaces(?) + ;; or that we need to wait for something to happen in the GUI(?) + [(eq? window #f) + (sleep .1) + (loop (- n 1) actions)] + + [else + ;; print out the button before the button is pushed + ;; Using the toy print-label function + ;; because some of the parents may not be sent with get-label e.g. vertical-pane% + ;(print (map print-label (trace-area button window))) + (let ([action (find-random-action window)]) + (cond + [action + (with-handlers ((exn:fail? (λ (x) + (fprintf (current-error-port) + "\nExecution fail: transcript of ~a clicking follows with seed ~s\n" + (send window get-label) + the-seed) + (apply show-log (cons action actions)) + (raise x)))) + ;; pause to make sure all events are flushed from the queue + (let ([s (make-semaphore 0)]) + (queue-callback (λ () (semaphore-post s)) #f) + (semaphore-wait s)) + ;; do the new thing. + (action)) + (loop (- n 1) (cons action actions))] + [else + (fprintf (current-error-port) + "\nExists/Meets window with no button: Bug? seed ~s\n" + the-seed) + (apply show-log actions) + (error 'randomly-click.ss "giving up")]))]))])))) (define (show-log . actions) (for ((action (in-list actions))) @@ -129,12 +137,12 @@ ;; the splash screen is in a separate eventspace so wont' show up. (define (wait-for-first-frame) (let loop () - (let ([tlws (get-top-level-windows)]) + (let ([tlw (get-top-level-focus-window)]) (cond - [(null? tlws) - (sleep 1/10) + [(not tlw) + (sleep 1/20) (loop)] - [else (car tlws)])))) + [else tlw])))) (define (wait-for-different-frame win) diff --git a/collects/tests/drscheme/repl-test.ss b/collects/tests/drscheme/repl-test.ss index 6d89c636b5..72d4e68273 100644 --- a/collects/tests/drscheme/repl-test.ss +++ b/collects/tests/drscheme/repl-test.ss @@ -17,8 +17,6 @@ This produces an ACK message mred framework) -(provide run-test) - (define-struct loc (line col offset)) ;; loc = (make-loc number number number) ;; all numbers in loc structs start at zero. @@ -81,7 +79,7 @@ This produces an ACK message (define test-data (list -#| + ;; basic tests (mktest "1" ("1" @@ -840,21 +838,18 @@ This produces an ACK message void void) - |# - -(mktest "(new snip%)" - ("1" - "1" - "1" - "1" - "1" - "1") + (mktest "(new snip%)" + ("{unknown snip: #(struct:object:snip% ...)}\n" + "{unknown snip: #(struct:object:snip% ...)}\n" + "{unknown snip: #(struct:object:snip% ...)}\n" + "{unknown snip: #(struct:object:snip% ...)}\n" + "{unknown snip: #(struct:object:snip% ...)}\n" + "{unknown snip: #(struct:object:snip% ...)}\n") 'interactions #f void void) - - + ;; graphical lambda tests (mktest (list "((" '("Insert" "Insert λ") "(x) x) 1)") @@ -999,9 +994,8 @@ This produces an ACK message 'interactions #f void - void) - - )) + void))) + ;; these tests aren't used at the moment. #; (define xml-tests @@ -1190,12 +1184,14 @@ This produces an ACK message (cond [(eq? source-location 'definitions) (unless (send definitions-canvas has-focus?) - (printf "FAILED execute test for ~s\n expected definitions to have the focus\n" - program))] + (fprintf (current-error-port) + "FAILED execute test for ~s\n expected definitions to have the focus\n" + program))] [(eq? source-location 'interactions) (unless (send interactions-canvas has-focus?) - (printf "FAILED execute test for ~s\n expected interactions to have the focus\n" - program))] + (fprintf (current-error-port) + "FAILED execute test for ~s\n expected interactions to have the focus\n" + program))] [(send definitions-canvas has-focus?) (let ([start (car source-location)] [finish (cdr source-location)]) @@ -1207,13 +1203,14 @@ This produces an ACK message (= (+ (srcloc-position error-range) -1) (loc-offset start)) (= (+ (srcloc-position error-range) -1 (srcloc-span error-range)) (loc-offset finish))) - (printf "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n" - program - (and error-range - (list (+ (srcloc-position error-range) -1) - (+ (srcloc-position error-range) -1 (srcloc-span error-range)))) - (list (loc-offset start) - (loc-offset finish))))))])]) + (fprintf (current-error-port) + "FAILED execute test for ~s\n error-range is ~s\n expected ~s\n" + program + (and error-range + (list (+ (srcloc-position error-range) -1) + (+ (srcloc-position error-range) -1 (srcloc-span error-range)))) + (list (loc-offset start) + (loc-offset finish))))))])]) ; check text for execute test (next-test) @@ -1224,10 +1221,11 @@ This produces an ACK message (regexp-match execute-answer received-execute)] [else #f]) (failure) - (printf "FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n" - program - language-cust - execute-answer received-execute)) + (fprintf (current-error-port) + "FAILED execute test for ~s (~a)\n expected: ~s\n got: ~s\n" + program + language-cust + execute-answer received-execute)) (test:new-window interactions-canvas) @@ -1278,9 +1276,10 @@ This produces an ACK message (regexp-match load-answer received-load)] [else #f]) (failure) - (printf "FAILED load test ~a for ~s\n expected: ~s\n got: ~s\n" - short-filename - program load-answer received-load)))))]) + (fprintf (current-error-port) + "FAILED load test ~a for ~s\n expected: ~s\n got: ~s\n" + short-filename + program load-answer received-load)))))]) (load-test tmp-load-short-filename (make-load-answer in-vector language-cust #f)) (when (file-exists? tmp-load3-filename) (delete-file tmp-load3-filename)) @@ -1291,7 +1290,7 @@ This produces an ACK message ; check for edit-sequence (when (repl-in-edit-sequence?) - (printf "FAILED: repl in edit-sequence") + (fprintf (current-error-port) "FAILED: repl in edit-sequence") (escape))))) (define tests 0) @@ -1302,7 +1301,7 @@ This produces an ACK message (define (final-report) (if (= 0 failures) (printf "tests finished: all ~a tests passed\n" tests) - (printf "tests finished: ~a failed out of ~a total\n" failures tests))) + (fprintf (current-error-port) "tests finished: ~a failed out of ~a total\n" failures tests))) (define (run-test-in-language-level language-cust) (let ([level (list #rx"Pretty Big")]) @@ -1474,8 +1473,7 @@ This produces an ACK message (kill-tests) (callcc-test) (top-interaction-test) - (final-report) - ) + (final-report)) (define (insert-in-definitions/newlines drs str) (let loop ([strs (regexp-split #rx"\n" str)]) @@ -1508,3 +1506,9 @@ This produces an ACK message (if (regexp? b) (regexp (string-append (regexp-quote a) (object-name b))) (string-append a b))) + + +(let () + (fire-up-drscheme) + (thread (λ () (run-test) (exit))) + (yield (make-semaphore 0))) diff --git a/collects/tests/drscheme/run-tests.ss b/collects/tests/drscheme/run-tests.ss deleted file mode 100644 index 44e5d86977..0000000000 --- a/collects/tests/drscheme/run-tests.ss +++ /dev/null @@ -1,143 +0,0 @@ -;; load this file as a tool to run the test suites - -#lang scheme/base -(require scheme/class - scheme/gui/base - framework - "README.ss") - -(provide ask-test-suite run-test-suite) - -(define test-thread - (let ([kill-old void]) - (lambda (test thunk) - (kill-old) - (let ([thread-desc (thread - (lambda () - (printf "t>> ~a started~n" test) - (thunk) - (printf "t>> ~a finished~n" test)))]) - (set! kill-old - (lambda () - (when (thread-running? thread-desc) - (kill-thread thread-desc) - (printf "t>> killed ~a~n" test)))))))) - -(define (make-repl) - (test-thread - "REPL" - (lambda () - (let ([startup "~/.mzschemerc"]) - (when (file-exists? startup) - (load startup))) - (case (system-type) - [(windows macos) - (graphical-read-eval-print-loop (current-eventspace))] - [else - (read-eval-print-loop)])))) - -(define (run-test-suite filename [die-afterwards? #f]) - (test-thread - filename - (lambda () - ((dynamic-require `(lib ,filename "tests" "drscheme") 'run-test)) - (when die-afterwards? (exit))))) - -(define current-test-suite-frame #f) - -(define test-suite-frame% - (class frame% - (define/override (on-size w h) - (preferences:set 'drscheme:test-suite:frame-width w) - (preferences:set 'drscheme:test-suite:frame-height h)) - (define/augment (on-close) - (inner (void) on-close) - (set! current-test-suite-frame #f)) - (super-new))) - -(define (ask-test-suite parent) - (if current-test-suite-frame - (send current-test-suite-frame show #t) - (let* ([drscheme-test-dir (collection-path "tests" "drscheme")] - [frame (make-object test-suite-frame% - "Test Suites" - parent - (preferences:get 'drscheme:test-suite:frame-width) - (preferences:get 'drscheme:test-suite:frame-height))] - [panel (make-object vertical-panel% frame)] - [top-panel (make-object vertical-panel% panel)] - [bottom-panel (make-object horizontal-panel% panel)]) - (send top-panel stretchable-height #f) - (make-object button% - "REPL" - bottom-panel - (lambda (_1 _2) - (send frame show #f) - (make-repl))) - - (when drscheme-test-dir - (send top-panel stretchable-height #t) - (send bottom-panel stretchable-height #f) - (letrec ([lb (make-object list-box% - #f - all-tests - top-panel - (lambda (b e) - (when (eq? (send e get-event-type) 'list-box-dclick) - (run-test-suite-callback))))] - [run-test-suite-callback - (lambda () - (let ([selection (send lb get-selection)]) - (when selection - (send frame show #f) - (let ([test (list-ref all-tests selection)]) - (preferences:set - 'drscheme:test-suite:file-name - test) - (run-test-suite test)))))]) - - ;; set values from preferences - (let* ([test-suite (preferences:get 'drscheme:test-suite:file-name)] - [num (send lb find-string test-suite)]) - (when num - (send lb set-string-selection test-suite) - (send lb set-first-visible-item num) - (test:run-interval (preferences:get 'drscheme:test-suite:run-interval)))) - - (send - (make-object button% - "Run Test Suite" - bottom-panel - (lambda (_1 _2) - (run-test-suite-callback)) - '(border)) - focus)) - - (let* ([pre-times (list 0 10 50 100 500)] - [times (if (member (test:run-interval) pre-times) - pre-times - (append pre-times (list (test:run-interval))))] - [choice - (make-object choice% - "Run Interval" - (map number->string times) - top-panel - (lambda (choice event) - (let ([time (list-ref times (send choice get-selection))]) - (preferences:set 'drscheme:test-suite:run-interval time) - (test:run-interval time))))]) - (send choice set-selection - (let loop ([l times] - [n 0]) - (if (= (car l) (test:run-interval)) - n - (loop (cdr l) - (+ n 1))))))) - (make-object button% - "Cancel" - bottom-panel - (lambda (_1 _2) - (send frame show #f))) - (make-object grow-box-spacer-pane% bottom-panel) - (send frame show #t) - (set! current-test-suite-frame frame)))) diff --git a/collects/tests/drscheme/syncheck-test.ss b/collects/tests/drscheme/syncheck-test.ss index c9ff602323..18a0555c03 100644 --- a/collects/tests/drscheme/syncheck-test.ss +++ b/collects/tests/drscheme/syncheck-test.ss @@ -5,20 +5,20 @@ tests involving object% are commented out, since they trigger runtime errors in check syntax. |# +#lang scheme/base -(module syncheck-test mzscheme - (require "drscheme-test-util.ss" + string-constants/string-constant tests/utils/gui - mzlib/etc - mzlib/class - mzlib/list - mzlib/file + scheme/path + scheme/class + scheme/list + scheme/file mred framework mrlib/text-string-style-desc) - (provide run-test) + (provide main) ;; type str/ann = (list (union symbol string) symbol) ;; type test = (make-test string @@ -28,7 +28,7 @@ trigger runtime errors in check syntax. (define-struct (dir-test test) ()) (define build-test - (opt-lambda (input expected [arrow-table '()]) + (λ (input expected [arrow-table '()]) (make-test input expected arrow-table))) ;; tests : (listof test) @@ -191,7 +191,6 @@ trigger runtime errors in check syntax. ("))" default-color)) (list '((7 8) (19 20)))) - #; (build-test "object%" '(("object%" imported-syntax))) ; used to be lexically-bound-variable (build-test "unbound-id" @@ -600,7 +599,6 @@ trigger runtime errors in check syntax. (")" default-color)) (list '((5 6) (10 11) (12 13)))) - #; (build-test "(class object% this)" '(("(" default-color) ("class" imported-syntax) @@ -850,19 +848,29 @@ trigger runtime errors in check syntax. ("1))" default-color)) (list '((27 33) (19 26) (36 49) (53 59) (64 66)))))) - (define (run-test) - (check-language-level #rx"Pretty") - (let* ([drs (wait-for-drscheme-frame)] - [defs (send drs get-definitions-text)] - [filename (make-temporary-file "syncheck-test~a")]) - (let-values ([(dir _1 _2) (split-path filename)]) - (send defs save-file filename) - (preferences:set 'framework:coloring-active #f) - (for-each (run-one-test (normalize-path dir)) tests) - (preferences:set 'framework:coloring-active #t) - (send defs save-file) ;; clear out autosave - (send defs set-filename #f) - (delete-file filename)))) + (define (main) + (let ([s (make-semaphore 0)]) + (thread + (λ () + (let ([drs (wait-for-drscheme-frame)]) + (set-language-level! (list "Pretty Big")) + (do-execute drs) + (let* ([defs (send drs get-definitions-text)] + [filename (make-temporary-file "syncheck-test~a")]) + (let-values ([(dir _1 _2) (split-path filename)]) + (send defs save-file filename) + (preferences:set 'framework:coloring-active #f) + (for-each (run-one-test (normalize-path dir)) tests) + (preferences:set 'framework:coloring-active #t) + (send defs save-file) ;; clear out autosave + (send defs set-filename #f) + (delete-file filename) + ;; let the app die. + (semaphore-post s)))))) + (fire-up-drscheme) + (yield s) + (printf "Tests complete.\n") + (exit))) (define ((run-one-test save-dir) test) (let* ([drs (wait-for-drscheme-frame)] @@ -885,8 +893,9 @@ trigger runtime errors in check syntax. (error 'syncheck-test.ss "still in edit sequence for ~s" input)) (when (send drs syncheck:error-report-visible?) - (printf "FAILED ~s\n error report window is visible\n" - input)) + (fprintf (current-error-port) + "FAILED ~s\n error report window is visible\n" + input)) ;; need to check for syntax error here (let ([got (get-annotated-output drs)]) @@ -940,41 +949,42 @@ trigger runtime errors in check syntax. (define (compare-arrows test-exp expected raw-actual) (when expected (let () - (define already-checked (make-hash-table 'equal)) + (define already-checked (make-hash)) - (define actual-ht (make-hash-table 'equal)) + (define actual-ht (make-hash)) (define stupid-internal-define-syntax1 - (hash-table-for-each raw-actual + (hash-for-each raw-actual (lambda (k v) - (hash-table-put! actual-ht (cdr k) - (sort (map cdr v) - (lambda (x y) (< (car x) (car y)))))))) - (define expected-ht (make-hash-table 'equal)) + (hash-set! actual-ht (cdr k) + (sort (map cdr v) + (lambda (x y) (< (car x) (car y)))))))) + (define expected-ht (make-hash)) (define stupid-internal-define-syntax2 - (for-each (lambda (binding) (hash-table-put! expected-ht (car binding) (cdr binding))) + (for-each (lambda (binding) (hash-set! expected-ht (car binding) (cdr binding))) expected)) ;; binding-in-ht? : hash-table (list number number) (listof (list number number)) -> boolean (define (test-binding expected? ht) (lambda (pr) (let ([frm (car pr)] [to (cdr pr)]) - (hash-table-get + (hash-ref already-checked frm (lambda () - (hash-table-put! already-checked frm #t) - (let ([ht-ent (hash-table-get ht frm (lambda () 'nothing-there))]) + (hash-set! already-checked frm #t) + (let ([ht-ent (hash-ref ht frm (lambda () 'nothing-there))]) (unless (equal? ht-ent to) - (printf (if expected? - "FAILED arrow test ~s from ~s\n expected ~s\n actual ~s\n" - "FAILED arrow test ~s from ~s\n actual ~s\n expected ~s\n") + (fprintf (current-error-port) + (if expected? + "FAILED arrow test ~s from ~s\n expected ~s\n actual ~s\n" + "FAILED arrow test ~s from ~s\n actual ~s\n expected ~s\n") test-exp frm ht-ent to)))))))) - (for-each (test-binding #t expected-ht) (hash-table-map actual-ht cons)) - (for-each (test-binding #f actual-ht) (hash-table-map expected-ht cons))))) + (for-each (test-binding #t expected-ht) (hash-map actual-ht cons)) + (for-each (test-binding #f actual-ht) (hash-map expected-ht cons))))) (define (compare-output raw-expected got arrows arrows-got input) (let ([expected (collapse-and-rename raw-expected)]) @@ -982,8 +992,9 @@ trigger runtime errors in check syntax. [(equal? got expected) (compare-arrows input arrows arrows-got)] [else - (printf "FAILED: ~s\n expected: ~s\n got: ~s\n" - input expected got)]))) + (fprintf (current-error-port) + "FAILED: ~s\n expected: ~s\n got: ~s\n" + input expected got)]))) ;; get-annotate-output : drscheme-frame -> (listof str/ann) (define (get-annotated-output drs) @@ -991,5 +1002,6 @@ trigger runtime errors in check syntax. (queue-callback (λ () (channel-put chan (get-string/style-desc (send drs get-definitions-text))))) - (channel-get chan)))) - + (channel-get chan))) + + (main) \ No newline at end of file diff --git a/collects/tests/drscheme/teachpack.ss b/collects/tests/drscheme/teachpack.ss index ec44902473..3e03dc5ff4 100644 --- a/collects/tests/drscheme/teachpack.ss +++ b/collects/tests/drscheme/teachpack.ss @@ -1,240 +1,244 @@ +#lang scheme/base -(module teachpack mzscheme - (require "drscheme-test-util.ss" - mzlib/class - mzlib/file - mred - framework - (prefix fw: framework)) +(require "drscheme-test-util.ss" + scheme/class + scheme/path + scheme/gui/base + (prefix-in fw: framework)) + +(provide run-test) + +(define drs-frame 'not-yet-drs-frame) +(define interactions-text 'not-yet-interactions-text) + +(define good-teachpack-name "teachpack-tmp~a") + +(define (test-good-teachpack tp-exps dr-exp expected) + (clear-definitions drs-frame) + (type-in-definitions drs-frame dr-exp) + (fw:test:menu-select "Language" "Clear All Teachpacks") - (provide run-test) - - (define drs-frame 'not-yet-drs-frame) - (define interactions-text 'not-yet-interactions-text) - - (define good-teachpack-name "teachpack-tmp~a") - - (define (test-good-teachpack tp-exps dr-exp expected) - (clear-definitions drs-frame) - (type-in-definitions drs-frame dr-exp) - (fw:test:menu-select "Language" "Clear All Teachpacks") + (let ([tp-names + (let ([teachpack-path (normal-case-path + (normalize-path + (collection-path "tests" "drscheme")))]) + (let loop ([tp-exps tp-exps] + [n 0]) + (cond + [(null? tp-exps) null] + [else + (let ([tp-name (build-path teachpack-path + (string-append + (format good-teachpack-name n) + ".ss"))]) + (call-with-output-file tp-name + (lambda (port) (write (car tp-exps) port)) + 'truncate) + (use-get/put-dialog + (lambda () + (fw:test:menu-select "Language" "Add Teachpack...")) + tp-name) + (cons tp-name (loop (cdr tp-exps) (+ n 1))))])))]) - (let ([tp-names - (let ([teachpack-path (normal-case-path - (normalize-path - (collection-path "tests" "drscheme")))]) - (let loop ([tp-exps tp-exps] - [n 0]) - (cond - [(null? tp-exps) null] - [else - (let ([tp-name (build-path teachpack-path - (string-append - (format good-teachpack-name n) - ".ss"))]) - (call-with-output-file tp-name - (lambda (port) (write (car tp-exps) port)) - 'truncate) - (use-get/put-dialog - (lambda () - (fw:test:menu-select "Language" "Add Teachpack...")) - tp-name) - (cons tp-name (loop (cdr tp-exps) (+ n 1))))])))]) - - (do-execute drs-frame) - - (let ([got (fetch-output drs-frame)] - [full-expectation - (string-append - (apply string-append (map (lambda (x) (format "Teachpack: ~a.~n" x)) tp-names)) - expected - "\nThis psorgram should be tested.")]) - (unless (equal? got - full-expectation) - (printf - "FAILED: tp: ~s~n exp: ~s~n expected: ~s~n got: ~s~n" - tp-exps - dr-exp - full-expectation - got))))) - - ;; there are no more errors when the teachpack is loaded (for now...) - (define (test-bad/load-teachpack tp-exp expected-error) - (fw:test:menu-select "Language" "Clear All Teachpacks") - (let ([tp-name (normal-case-path - (normalize-path - (build-path - (collection-path "tests" "drscheme") - "teachpack-tmp.ss")))]) - (call-with-output-file tp-name - (lambda (port) (display tp-exp port)) - 'truncate) - (use-get/put-dialog - (lambda () - (fw:test:menu-select "Language" "Add Teachpack...")) - tp-name) - (let ([dialog - (with-handlers ([(lambda (x) #t) - (lambda (x) #f)]) - (wait-for-new-frame drs-frame))]) - (cond - [dialog - (let ([got (send dialog get-message)]) - (unless (string=? got expected-error) - (printf "FAILED: tp: ~s~n expected: ~s~n got: ~s~n" - tp-exp expected-error got)) - (fw:test:button-push "Ok") - (wait-for-new-frame dialog))] - [else - (printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n" - tp-exp expected-error)])))) - - (define (test-bad/execute-teachpack tp-exp expected) - (fw:test:menu-select "Language" "Clear All Teachpacks") - (let ([tp-name (normal-case-path - (normalize-path - (build-path - (collection-path "tests" "drscheme") - "teachpack-tmp.ss")))]) - (call-with-output-file tp-name - (lambda (port) (display tp-exp port)) - 'truncate) - (use-get/put-dialog - (lambda () - (fw:test:menu-select "Language" "Add Teachpack...")) - tp-name) - (do-execute drs-frame #f) - (let ([dialog - (with-handlers ([exn:fail? (lambda (x) #f)]) - (let ([wait-for-error-pred - (lambda () - (let ([active - (or - (get-top-level-focus-window) - (and (send interactions-text get-user-eventspace) - (parameterize ([current-eventspace - (send interactions-text get-user-eventspace)]) - (get-top-level-focus-window))))]) - (if (and active (not (eq? active drs-frame))) - active - #f)))]) - (poll-until wait-for-error-pred)))]) - (cond - [dialog - (let ([got (send dialog get-message)] - [expected-error - (string-append (format "Invalid Teachpack: ~a~n" tp-name) - expected)]) - (unless (string=? got expected-error) - (printf "FAILED: tp: ~s~n expected: ~s~n got: ~s~n" - tp-exp expected-error got)) - (fw:test:button-push "Ok") - (wait-for-new-frame dialog))] - [else - (printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n" - tp-exp error)])))) - - (define (generic-tests) - (test-good-teachpack - (list - `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme)) - "1" - "1") - - (test-good-teachpack - (list `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme - (provide not-a-primitive) - (define not-a-primitive 1))) - "not-a-primitive" - "1") - - (test-good-teachpack - (list `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme - (provide not-a-primitive1) - (define not-a-primitive1 1)) - `(module ,(string->symbol (format good-teachpack-name 1)) mzscheme - (provide not-a-primitive2) - (define not-a-primitive2 2))) - "(+ not-a-primitive1 not-a-primitive2)" - "3")) - - (define (good-tests) - (set-language-level! '("How to Design Programs" "Beginning Student")) (do-execute drs-frame) - (generic-tests)) - - (define (bad-tests) - (set-language-level! '("How to Design Programs" "Beginning Student")) - (test-bad/execute-teachpack - "undefined-id" - "reference to undefined identifier: undefined-id") - - (test-bad/execute-teachpack - `(module teachpack-tmp mzscheme (car)) - "car: expects argument of type ; given 1")) - - (define (get-string-from-file fn) - (call-with-input-file fn - (lambda (port) - (apply string-append - (let loop () - (let ([l (read-line port)]) - (if (eof-object? l) - null - (list* l " " (loop))))))) - 'text)) - - ;; doesn't test graphing.ss teachpack - (define (test-built-in-teachpacks) - (clear-definitions drs-frame) - (type-in-definitions drs-frame "1") - (let* ([test-teachpack - (lambda (dir) - (lambda (teachpack) - (when (or (equal? #"ss" (filename-extension teachpack)) - (equal? #"scm" (filename-extension teachpack))) - (unless (equal? "graphing.ss" (path->string teachpack)) - (printf " testing ~a~n" teachpack) - (fw:test:menu-select "Language" "Clear All Teachpacks") - (fw:test:menu-select "Language" "Add Teachpack...") - (wait-for-new-frame drs-frame) - (let* ([tp-dialog (get-top-level-focus-window)] - [choice (find-leftmost-choice tp-dialog)]) - (fw:test:set-list-box! choice (path->string teachpack)) - (fw:test:button-push "OK") - (wait-for-new-frame tp-dialog)) - (do-execute drs-frame) - - (let ([got (fetch-output drs-frame)] - [expected (format "Teachpack: ~a.\n1" - (path->string teachpack))]) - (unless (equal? got expected) - (printf "FAILED built in teachpack test: ~a~n" (path->string teachpack)) - (printf " got: ~s~n expected: ~s~n" got expected)))))))] - [test-teachpacks - (lambda (paths) - (for-each (lambda (dir) - (for-each (test-teachpack dir) - (directory-list dir))) - paths))] - [teachpack-dir (normalize-path (collection-path "teachpack"))]) - (set-language-level! '("How to Design Programs" "Advanced Student")) - (do-execute drs-frame) - (test-teachpacks (list (build-path teachpack-dir "2htdp") - (build-path teachpack-dir "htdp"))))) - - (define (find-leftmost-choice frame) - (let loop ([p frame]) + (let ([got (fetch-output drs-frame)] + [full-expectation + (string-append + (apply string-append (map (lambda (x) (format "Teachpack: ~a.~n" x)) tp-names)) + expected + "\nThis psorgram should be tested.")]) + (unless (equal? got + full-expectation) + (printf + "FAILED: tp: ~s~n exp: ~s~n expected: ~s~n got: ~s~n" + tp-exps + dr-exp + full-expectation + got))))) + +;; there are no more errors when the teachpack is loaded (for now...) +(define (test-bad/load-teachpack tp-exp expected-error) + (fw:test:menu-select "Language" "Clear All Teachpacks") + (let ([tp-name (normal-case-path + (normalize-path + (build-path + (collection-path "tests" "drscheme") + "teachpack-tmp.ss")))]) + (call-with-output-file tp-name + (lambda (port) (display tp-exp port)) + 'truncate) + (use-get/put-dialog + (lambda () + (fw:test:menu-select "Language" "Add Teachpack...")) + tp-name) + (let ([dialog + (with-handlers ([(lambda (x) #t) + (lambda (x) #f)]) + (wait-for-new-frame drs-frame))]) (cond - [(is-a? p list-box%) p] - [(is-a? p area-container<%>) - (ormap loop (send p get-children))] - [else #f]))) + [dialog + (let ([got (send dialog get-message)]) + (unless (string=? got expected-error) + (printf "FAILED: tp: ~s~n expected: ~s~n got: ~s~n" + tp-exp expected-error got)) + (fw:test:button-push "Ok") + (wait-for-new-frame dialog))] + [else + (printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n" + tp-exp expected-error)])))) + +(define (test-bad/execute-teachpack tp-exp expected) + (fw:test:menu-select "Language" "Clear All Teachpacks") + (let ([tp-name (normal-case-path + (normalize-path + (build-path + (collection-path "tests" "drscheme") + "teachpack-tmp.ss")))]) + (call-with-output-file tp-name + (lambda (port) (display tp-exp port)) + 'truncate) + (use-get/put-dialog + (lambda () + (fw:test:menu-select "Language" "Add Teachpack...")) + tp-name) + (do-execute drs-frame #f) + (let ([dialog + (with-handlers ([exn:fail? (lambda (x) #f)]) + (let ([wait-for-error-pred + (lambda () + (let ([active + (or + (get-top-level-focus-window) + (and (send interactions-text get-user-eventspace) + (parameterize ([current-eventspace + (send interactions-text get-user-eventspace)]) + (get-top-level-focus-window))))]) + (if (and active (not (eq? active drs-frame))) + active + #f)))]) + (poll-until wait-for-error-pred)))]) + (cond + [dialog + (let ([got (send dialog get-message)] + [expected-error + (string-append (format "Invalid Teachpack: ~a~n" tp-name) + expected)]) + (unless (string=? got expected-error) + (printf "FAILED: tp: ~s~n expected: ~s~n got: ~s~n" + tp-exp expected-error got)) + (fw:test:button-push "Ok") + (wait-for-new-frame dialog))] + [else + (printf "FAILED: no error message appeared~n tp: ~s~n expected: ~s~n" + tp-exp error)])))) + +(define (generic-tests) + (test-good-teachpack + (list + `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme)) + "1" + "1") - (define (run-test) - (set! drs-frame (wait-for-drscheme-frame)) - (set! interactions-text (send drs-frame get-interactions-text)) - ;(good-tests) - ;(bad-tests) - (test-built-in-teachpacks))) + (test-good-teachpack + (list `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme + (provide not-a-primitive) + (define not-a-primitive 1))) + "not-a-primitive" + "1") + + (test-good-teachpack + (list `(module ,(string->symbol (format good-teachpack-name 0)) mzscheme + (provide not-a-primitive1) + (define not-a-primitive1 1)) + `(module ,(string->symbol (format good-teachpack-name 1)) mzscheme + (provide not-a-primitive2) + (define not-a-primitive2 2))) + "(+ not-a-primitive1 not-a-primitive2)" + "3")) + +(define (good-tests) + (set-language-level! '("How to Design Programs" "Beginning Student")) + (do-execute drs-frame) + (generic-tests)) + +(define (bad-tests) + (set-language-level! '("How to Design Programs" "Beginning Student")) + + (test-bad/execute-teachpack + "undefined-id" + "reference to undefined identifier: undefined-id") + + (test-bad/execute-teachpack + `(module teachpack-tmp mzscheme (car)) + "car: expects argument of type ; given 1")) + +(define (get-string-from-file fn) + (call-with-input-file fn + (lambda (port) + (apply string-append + (let loop () + (let ([l (read-line port)]) + (if (eof-object? l) + null + (list* l " " (loop))))))) + 'text)) + +;; doesn't test graphing.ss teachpack +(define (test-built-in-teachpacks) + (clear-definitions drs-frame) + (type-in-definitions drs-frame "1") + (let* ([test-teachpack + (lambda (dir) + (lambda (teachpack) + (when (or (equal? #"ss" (filename-extension teachpack)) + (equal? #"scm" (filename-extension teachpack))) + (unless (equal? "graphing.ss" (path->string teachpack)) + (printf " testing ~a~n" teachpack) + (fw:test:menu-select "Language" "Clear All Teachpacks") + (fw:test:menu-select "Language" "Add Teachpack...") + (wait-for-new-frame drs-frame) + (let* ([tp-dialog (get-top-level-focus-window)] + [choice (find-leftmost-choice tp-dialog)]) + (fw:test:set-list-box! choice (path->string teachpack)) + (fw:test:button-push "OK") + (wait-for-new-frame tp-dialog)) + (do-execute drs-frame) + + (let ([got (fetch-output drs-frame)] + [expected (format "Teachpack: ~a.\n1" + (path->string teachpack))]) + (unless (equal? got expected) + (printf "FAILED built in teachpack test: ~a~n" (path->string teachpack)) + (printf " got: ~s~n expected: ~s~n" got expected)))))))] + [test-teachpacks + (lambda (paths) + (for-each (lambda (dir) + (for-each (test-teachpack dir) + (directory-list dir))) + paths))] + [teachpack-dir (normalize-path (collection-path "teachpack"))]) + (set-language-level! '("How to Design Programs" "Advanced Student")) + (do-execute drs-frame) + (test-teachpacks (list (build-path teachpack-dir "2htdp") + (build-path teachpack-dir "htdp"))))) + +(define (find-leftmost-choice frame) + (let loop ([p frame]) + (cond + [(is-a? p list-box%) p] + [(is-a? p area-container<%>) + (ormap loop (send p get-children))] + [else #f]))) + +(define (run-test) + (set! drs-frame (wait-for-drscheme-frame)) + (set! interactions-text (send drs-frame get-interactions-text)) + ;(good-tests) + ;(bad-tests) + (test-built-in-teachpacks)) + +(let () + (fire-up-drscheme) + (thread (λ () (run-test) (exit))) + (yield (make-semaphore))) diff --git a/collects/tests/drscheme/tool.ss b/collects/tests/drscheme/tool.ss deleted file mode 100644 index f589a076c8..0000000000 --- a/collects/tests/drscheme/tool.ss +++ /dev/null @@ -1,58 +0,0 @@ -;; load this file as a tool to run the test suites - -(module tool mzscheme - (require drscheme/tool - mzlib/list - mzlib/unit - mzlib/class - mred - framework - "README.ss") - - (provide tool@) - - (define tool@ - (unit - (import drscheme:tool^) - (export drscheme:tool-exports^) - (define (phase1) (void)) - (define (phase2) (void)) - - (preferences:set-default 'drscheme:test-suite:file-name "repl-tests.ss" string?) - (preferences:set-default 'drscheme:test-suite:run-interval 10 number?) - - (preferences:set-default 'drscheme:test-suite:frame-width #f (lambda (x) (or (not x) (number? x)))) - (preferences:set-default 'drscheme:test-suite:frame-height 300 (lambda (x) (or (not x) (number? x)))) - - (define (tool-mixin super%) - (class super% - (inherit get-button-panel) - (super-new) - (let* ([bitmap (make-object bitmap% - (if (<= (get-display-depth) 1) - (build-path (collection-path "icons") "bb-sm-bw.bmp") - (build-path (collection-path "icons") "bb-small.bmp")) - 'bmp)] - [button (make-object button% - (if (send bitmap ok?) bitmap "Console") - (get-button-panel) - (lambda (button evt) - (let ([ask-test-suite (dynamic-require 'tests/drscheme/run-tests - 'ask-test-suite)]) - (ask-test-suite this))))]) - (send (get-button-panel) change-children - (lambda (l) - (cons button (remq button l))))))) - - (define tests (getenv "PLTDRTESTS")) - - (cond - [(not tests) (void)] - [(member tests all-tests) - ((dynamic-require 'tests/drscheme/run-tests 'run-test-suite) - tests - #t)] - [else - (printf "PLTDRTESTS: installing unit frame mixin\n") - (drscheme:get/extend:extend-unit-frame tool-mixin)])))) - diff --git a/collects/tests/info.ss b/collects/tests/info.ss index 8c81976c79..2e13c2c61a 100644 --- a/collects/tests/info.ss +++ b/collects/tests/info.ss @@ -1,8 +1,8 @@ #lang setup/infotab (define name "Test Suites") -(define tools '(("tool.ss" "drscheme") ("time-keystrokes.ss" "drscheme"))) -(define tool-names '("DrScheme Test Suites" "Time Keystrokes")) +(define tools '(("time-keystrokes.ss" "drscheme"))) +(define tool-names '("Time Keystrokes")) (define compile-omit-paths '("2htdp" diff --git a/collects/tests/mzscheme/beg-adv.ss b/collects/tests/mzscheme/beg-adv.ss index 7789e80e39..edfe0e1a0e 100644 --- a/collects/tests/mzscheme/beg-adv.ss +++ b/collects/tests/mzscheme/beg-adv.ss @@ -387,6 +387,15 @@ (htdp-test false 'string-lower-case? (string-lower-case? "ab\t")) (htdp-test true 'string-lower-case? (string-lower-case? "abc")) +(htdp-err/rt-test (error "a" "a") #rx"^aa$") +(htdp-err/rt-test (error 'a "a") #rx"^a: a$") +(htdp-err/rt-test (error "This is" " an err" "or" " message with a number: " 5) + #rx"^This is an error message with a number: 5$") +(htdp-err/rt-test (error "several numbers " 1 2 3 4 5 6 7) + #rx"^several numbers 1234567$") +(htdp-err/rt-test (error "several numbers " 1 " 2 " 3 " 4") + #rx"^several numbers 1 2 3 4$") + (htdp-top (require scheme/match)) (htdp-test 17 'match (match 'x ['x 17])) (htdp-test 'x 'match (match 'x ['y 17][z z])) diff --git a/collects/tests/mzscheme/benchmarks/common/auto.ss b/collects/tests/mzscheme/benchmarks/common/auto.ss index 5c1c61b84e..a528bd52a0 100755 --- a/collects/tests/mzscheme/benchmarks/common/auto.ss +++ b/collects/tests/mzscheme/benchmarks/common/auto.ss @@ -456,7 +456,7 @@ exec mzscheme -qu "$0" ${1+"$@"} run-guile extract-guile-times void - '(dynamic dynamic2)) + '(ctak)) )) (define obsolte-impls '(mzscheme3m mzschemecgc mzscheme-j mzschemecgc-j mzschemecgc-tl mzc mz-old)) diff --git a/collects/tests/mzscheme/benchmarks/common/guile-prelude.sch b/collects/tests/mzscheme/benchmarks/common/guile-prelude.sch index f9e61fb5d1..4c1203e0fc 100644 --- a/collects/tests/mzscheme/benchmarks/common/guile-prelude.sch +++ b/collects/tests/mzscheme/benchmarks/common/guile-prelude.sch @@ -15,7 +15,7 @@ (display " system: ") (display (msecs (- (tms:stime end) (tms:stime start)))) (display " real: ") - (display (msecs (- (tms:stime end) (tms:stime start)))) + (display (msecs (- (tms:clock end) (tms:clock start)))) (display " gc: ") (display (msecs (- end-gc start-gc))) (newline))))) diff --git a/collects/tests/mzscheme/benchmarks/common/index-template.html b/collects/tests/mzscheme/benchmarks/common/index-template.html index 7f49f71c0c..eb81e28a3f 100644 --- a/collects/tests/mzscheme/benchmarks/common/index-template.html +++ b/collects/tests/mzscheme/benchmarks/common/index-template.html @@ -12,8 +12,8 @@ fastest run shown on the left. So, by default, 1 is the fastest, but select any implementation to normalize the table with respect - to that implementation's speed. A - appears when a - benchmark didn't run in an implementation for some reason (possibly + to that implementation’s speed. A - appears when a + benchmark didn’t run in an implementation for some reason (possibly not a good one).

@@ -21,12 +21,12 @@ The compilers-only page shows just the compilers among the tested implementations. For those results, the small gray numbers are (relative) compile times, where the compile time for the nothing benchmark is subtracted from -every other benchmark's compile time.

+every other benchmark’s compile time.

Run times are averaged over three runs for compilers or one run for interpreters. All reported times are CPU time (system plus user). The times are based on the output of the - implementation's time syntactic form or similar + implementation’s time syntactic form or similar functions.

Machine: @@ -40,24 +40,23 @@ every other benchmark's compile time.

  • Chicken (4.3.0): -no-trace -no-lambda-info -optimize-level 3 -block -lambda-lift
  • Gambit (4.6.0): (declare (block) (standard-bindings) (extended-bindings) (safe) (interrupts-enabled)), compiled and run with -:m10000
    • -
  • Guile (1.8.7): load
    • +
  • Guile (1.9.7): load
  • Ikarus (0.0.4-rc1+ rev 1870): in R6RS library
  • Larceny (0.97): in R6RS library
  • MIT (7.7.90+): (declare (usual-integrations)); run with --heap 12000
  • Petite Chez (7.4d): load
  • PLT (4.2.4): in module; for benchmarks that use set-car! and set-cdr!, - PLT's R5RS support is used
    • + PLT’s R5RS support is used
  • Scheme48 (1.8): load after ,bench on
    • These configurations are all “safe mode,” but they allow a compiler to assume that built-in Scheme functions are not redefined and that no top-level defintion is ever changed. Such assumptions -correspond to putting the benchmark in an R6RS library.

    - -

    In general, we attempt to use the various implementations in a compentent way, - but not in a sophisticated way. For example, we do not tweak - inlining parameters or specify fixnum arithmetic (where appropriate), - which could produce significant improvements from some compilers.

    +correspond to putting the benchmark in an R6RS library. We attempt to +use the various implementations in a compentent way, but not in a +sophisticated way. For example, we do not tweak inlining parameters or +specify fixnum arithmetic (where appropriate), which could produce +significant improvements from some compilers.

    For more benchmarks and a more sophisticated use of a few compilers, including fixnum- and flonum-specific arithmetic as well as unsafe modes, diff --git a/collects/tests/mzscheme/benchmarks/shootout/mandelbrot-unsafe.ss b/collects/tests/mzscheme/benchmarks/shootout/mandelbrot-unsafe.ss index 2fb31190e9..1701322ce3 100644 --- a/collects/tests/mzscheme/benchmarks/shootout/mandelbrot-unsafe.ss +++ b/collects/tests/mzscheme/benchmarks/shootout/mandelbrot-unsafe.ss @@ -4,10 +4,15 @@ ;; ;; Derived from the Chicken variant, which was ;; Contributed by Anthony Borla - +;; +;; This version uses unsafe operations + #lang scheme/base (require scheme/cmdline - scheme/unsafe/ops) + scheme/require (for-syntax scheme/base) + (filtered-in + (lambda (name) (regexp-replace #rx"unsafe-" name "")) + scheme/unsafe/ops)) (define +limit-sqr+ 4.0) @@ -16,15 +21,15 @@ ;; ------------------------------- (define (mandelbrot x y n ci) - (let ((cr (unsafe-fl- (unsafe-fl/ (unsafe-fl* 2.0 (unsafe-fx->fl x)) (unsafe-fx->fl n)) 1.5))) + (let ((cr (fl- (fl/ (fl* 2.0 (fx->fl x)) (fx->fl n)) 1.5))) (let loop ((i 0) (zr 0.0) (zi 0.0)) - (if (unsafe-fx> i +iterations+) + (if (fx> i +iterations+) 1 (cond - ((unsafe-fl> (unsafe-fl+ (unsafe-fl* zr zr) (unsafe-fl* zi zi)) +limit-sqr+) 0) - (else (loop (unsafe-fx+ 1 i) - (unsafe-fl+ (unsafe-fl- (unsafe-fl* zr zr) (unsafe-fl* zi zi)) cr) - (unsafe-fl+ (unsafe-fl* 2.0 (unsafe-fl* zr zi)) ci)))))))) + ((fl> (fl+ (fl* zr zr) (fl* zi zi)) +limit-sqr+) 0) + (else (loop (fx+ 1 i) + (fl+ (fl- (fl* zr zr) (fl* zi zi)) cr) + (fl+ (fl* 2.0 (fl* zr zi)) ci)))))))) ;; ------------------------------- @@ -35,23 +40,23 @@ (let loop-y ((y 0)) - (when (unsafe-fx< y n) + (when (fx< y n) - (let ([ci (unsafe-fl- (unsafe-fl/ (unsafe-fl* 2.0 (unsafe-fx->fl y)) (unsafe-fx->fl n)) 1.0)]) + (let ([ci (fl- (fl/ (fl* 2.0 (fx->fl y)) (fx->fl n)) 1.0)]) (let loop-x ((x 0) (bitnum 0) (byteacc 0)) - (if (unsafe-fx< x n) - (let ([bitnum (unsafe-fx+ 1 bitnum)] - [byteacc (unsafe-fx+ (unsafe-fxlshift byteacc 1) + (if (fx< x n) + (let ([bitnum (fx+ 1 bitnum)] + [byteacc (fx+ (fxlshift byteacc 1) (mandelbrot x y n ci))]) (cond - ((unsafe-fx= bitnum 8) + ((fx= bitnum 8) (write-byte byteacc out) - (loop-x (unsafe-fx+ 1 x) 0 0)) + (loop-x (fx+ 1 x) 0 0)) - [else (loop-x (unsafe-fx+ 1 x) bitnum byteacc)])) + [else (loop-x (fx+ 1 x) bitnum byteacc)])) (begin (when (positive? bitnum) diff --git a/collects/tests/mzscheme/htdp-test.ss b/collects/tests/mzscheme/htdp-test.ss index 2fb33f8062..afa4284440 100644 --- a/collects/tests/mzscheme/htdp-test.ss +++ b/collects/tests/mzscheme/htdp-test.ss @@ -94,7 +94,7 @@ #'(void)])) (define (htdp-string-to-pred exn?/rx) - (if (string? exn?/rx) + (if (or (regexp? exn?/rx) (string? exn?/rx)) (lambda (x) (regexp-match exn?/rx (exn-message x))) exn?/rx)) diff --git a/collects/tests/mzscheme/optimize.ss b/collects/tests/mzscheme/optimize.ss index 4647044eb2..66b681acea 100644 --- a/collects/tests/mzscheme/optimize.ss +++ b/collects/tests/mzscheme/optimize.ss @@ -534,7 +534,7 @@ (un0 '#&1 'box 1) (let ([test-setter - (lambda (make-X def-val set-val set-name set ref) + (lambda (make-X def-val set-val set-name set ref 3rd-all-ok?) (let ([v (make-X 3 def-val)]) (check-error-message set-name (eval `(lambda (x) (,set-name ,v -1 ,set-val)))) (check-error-message set-name (eval `(lambda (x) (,set-name ,v 3 ,set-val)))) @@ -547,12 +547,12 @@ (test def-val ref v (modulo (+ i 1) 3)) (test def-val ref v (modulo (+ i 2) 3)) (set v i def-val)) - #t)) + 3rd-all-ok?)) '(0 1 2))))]) - (test-setter make-vector #f 7 'vector-set! vector-set! vector-ref) - (test-setter make-bytes 0 7 'bytes-set! bytes-set! bytes-ref) - (test-setter make-string #\a #\7 'string-set! string-set! string-ref) - (test-setter make-flvector 1.0 7.0 'flvector-set! flvector-set! flvector-ref)) + (test-setter make-vector #f 7 'vector-set! vector-set! vector-ref #t) + (test-setter make-bytes 0 7 'bytes-set! bytes-set! bytes-ref #f) + (test-setter make-string #\a #\7 'string-set! string-set! string-ref #f) + (test-setter make-flvector 1.0 7.0 'flvector-set! flvector-set! flvector-ref #f)) )) diff --git a/collects/tests/mzscheme/thread.ss b/collects/tests/mzscheme/thread.ss index 832f33f3d3..35b0dcfe7e 100644 --- a/collects/tests/mzscheme/thread.ss +++ b/collects/tests/mzscheme/thread.ss @@ -1319,32 +1319,33 @@ (run #t)) ;; Make sure that transitive thread-resume keeps a weak link -;; when thread is blocked: -(let ([run - (lambda (suspend-first?) - (let ([done (make-semaphore)]) - (let ([boxes - (for/list ([i (in-range 100)]) - (let ([t - (thread (lambda () - (semaphore-wait (make-semaphore)) - (semaphore-post done)))]) - (when suspend-first? - (sync (system-idle-evt)) - (thread-suspend t)) - (thread-resume t (current-thread)) - (make-weak-box t)))]) - (sync (system-idle-evt)) - (collect-garbage) - (collect-garbage) - (test #t > (apply + (map (lambda (b) (if (weak-box-value b) - 0 - 1)) - boxes)) - 50) - (test #f sync/timeout 0.0 done))))]) - (run #f) - (run #t)) +;; when thread is blocked (but only test under 3m): +(when (regexp-match #rx"3m" (path->bytes (system-library-subpath))) + (let ([run + (lambda (suspend-first?) + (let ([done (make-semaphore)]) + (let ([boxes + (for/list ([i (in-range 100)]) + (let ([t + (thread (lambda () + (semaphore-wait (make-semaphore)) + (semaphore-post done)))]) + (when suspend-first? + (sync (system-idle-evt)) + (thread-suspend t)) + (thread-resume t (current-thread)) + (make-weak-box t)))]) + (sync (system-idle-evt)) + (collect-garbage) + (collect-garbage) + (test #t > (apply + (map (lambda (b) (if (weak-box-value b) + 0 + 1)) + boxes)) + 50) + (test #f sync/timeout 0.0 done))))]) + (run #f) + (run #t))) ; -------------------- diff --git a/collects/tests/stxparse/more-tests.ss b/collects/tests/stxparse/more-tests.ss index 86e903c862..1e794b1da0 100644 --- a/collects/tests/stxparse/more-tests.ss +++ b/collects/tests/stxparse/more-tests.ss @@ -189,19 +189,19 @@ (tcerr "parse-ehpat/bounds: min" (syntax-parser - [((~bounds x 1.0 9) ...) 'ok]) + [((~between x 1.0 9) ...) 'ok]) #rx"^syntax-parser: " #rx"expected exact nonnegative integer") (tcerr "parse-ehpat/bounds: max" (syntax-parser - [((~bounds x 1 "foo") ...) 'ok]) + [((~between x 1 "foo") ...) 'ok]) #rx"^syntax-parser: " #rx"expected exact nonnegative integer") (tcerr "parse-ehpat/bounds: min>max" (syntax-parser - [((~bounds x 3 2) ...) 'ok]) + [((~between x 3 2) ...) 'ok]) #rx"^syntax-parser: " #rx"minimum larger than maximum") diff --git a/collects/tests/stxparse/stxclass.ss b/collects/tests/stxparse/stxclass.ss index 7f93ec1260..da957d5c2a 100644 --- a/collects/tests/stxparse/stxclass.ss +++ b/collects/tests/stxparse/stxclass.ss @@ -210,3 +210,26 @@ (syntax-parse #'(4 -1) #:conventions (nat-convs) [(N ...) (void)])) (error 'test-conv1 "didn't work")) + +;; Local conventions + +(define-syntax-class (nats> bound) + #:local-conventions ([N (nat> bound)]) + (pattern (N ...))) + +(define (p1 bound x) + (syntax-parse x + #:local-conventions ([ns (nats> bound)]) + [ns 'yes] + [_ 'no])) + +(eq? (p1 0 #'(1 2 3)) 'yes) +(eq? (p1 2 #'(1 2 3)) 'no) + +;; Regression (2/2/2010) + +(define-splicing-syntax-class twoseq + (pattern (~seq a b))) + +(syntax-parse #'(1 2 3 4) + [(x:twoseq ...) 'ok]) diff --git a/collects/web-server/scribblings/tutorial/continue.scrbl b/collects/web-server/scribblings/tutorial/continue.scrbl index 263236034a..5c15cbe8b1 100644 --- a/collects/web-server/scribblings/tutorial/continue.scrbl +++ b/collects/web-server/scribblings/tutorial/continue.scrbl @@ -92,11 +92,13 @@ responses. One basic kind of response is to show an HTML page. @schemeblock[ (define html-response/c + (flat-rec-contract + html-response (or/c string? - (or/c (cons/c symbol? (listof html-response/c)) + (or/c (cons/c symbol? (listof html-response)) (cons/c symbol? (cons/c (listof (list/c symbol? string?)) - (listof html-response/c))))))] + (listof html-response)))))))] For example: diff --git a/doc/release-notes/mred/HISTORY.txt b/doc/release-notes/mred/HISTORY.txt index 0a1e5ca65f..b7cf89b6be 100644 --- a/doc/release-notes/mred/HISTORY.txt +++ b/doc/release-notes/mred/HISTORY.txt @@ -1,5 +1,7 @@ -Version 4.2.4.1 +Version 4.2.4.2 +Added accept-tab-focus method to canvas<%> and editor-canvas% +Version 4.2.4.1 Changed radio-box% to allow #f as a selection so that no buttons are selected diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 6c5c211139..6d453d777a 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,6 @@ +Version 4.2.4.2 +Changed module to wrap each body expression in a prompt + Version 4.2.4, January 2010 Added scheme/flonum and scheme/fixnum Extended scheme/unsafe/ops diff --git a/src/mzscheme/src/future.c b/src/mzscheme/src/future.c index 0b5930b6df..ff8b692f3f 100644 --- a/src/mzscheme/src/future.c +++ b/src/mzscheme/src/future.c @@ -161,7 +161,7 @@ static Scheme_Object *processor_count(int argc, Scheme_Object *argv[]); static void futures_init(void); static void init_future_thread(struct Scheme_Future_State *fs, int i); -#define THREAD_POOL_SIZE 12 +#define THREAD_POOL_SIZE 16 #define INITIAL_C_STACK_SIZE 500000 #define FUTURE_RUNSTACK_SIZE 1000 diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index dcc2bb189e..027569b60f 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -7857,9 +7857,16 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int if ((which == 3) && (can_unbox_inline(app->args[3], 5, JIT_FPR_NUM-3, 0) - || can_unbox_directly(app->args[3]))) - flonum_arg = 1; - else + || can_unbox_directly(app->args[3]))) { +# if !defined(INLINE_FP_OPS) || !defined(CAN_INLINE_ALLOC) + /* Error handling will have to box flonum, so don't unbox if + that cannot be done inline: */ + if (!unsafe) + flonum_arg = 0; + else +# endif + flonum_arg = 1; + } else flonum_arg = 0; if (flonum_arg) { diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index f8f526d521..6410018f49 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -4403,6 +4403,44 @@ static void eval_module_body(Scheme_Env *menv, Scheme_Env *env) #endif } +static Scheme_Object *body_one_expr(void *expr, int argc, Scheme_Object **argv) +{ + return _scheme_eval_linked_expr_multi((Scheme_Object *)expr); +} + +static int needs_prompt(Scheme_Object *e) +{ + Scheme_Type t; + + while (1) { + t = SCHEME_TYPE(e); + if (t > _scheme_values_types_) + return 0; + + switch (t) { + case scheme_unclosed_procedure_type: + case scheme_toplevel_type: + case scheme_local_type: + case scheme_local_unbox_type: + return 0; + case scheme_syntax_type: + switch (SCHEME_PINT_VAL(e)) { + case CASE_LAMBDA_EXPD: + return 0; + case DEFINE_VALUES_EXPD: + e = (Scheme_Object *)SCHEME_IPTR_VAL(e); + e = SCHEME_VEC_ELS(e)[0]; + break; + default: + return 1; + } + break; + default: + return 1; + } + } +} + void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env) { Scheme_Thread *p; @@ -4459,7 +4497,10 @@ void *scheme_module_run_finish(Scheme_Env *menv, Scheme_Env *env) cnt = SCHEME_VEC_SIZE(m->body); for (i = 0; i < cnt; i++) { body = SCHEME_VEC_ELS(m->body)[i]; - _scheme_eval_linked_expr_multi(body); + if (needs_prompt(body)) + (void)_scheme_call_with_prompt_multi(body_one_expr, body); + else + (void)_scheme_eval_linked_expr_multi(body); } if (scheme_module_demand_hook) { diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 8881496a34..65375a4149 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.2.4.1" +#define MZSCHEME_VERSION "4.2.4.2" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 2 #define MZSCHEME_VERSION_Z 4 -#define MZSCHEME_VERSION_W 1 +#define MZSCHEME_VERSION_W 2 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 6626ef2caf..76a5c9374f 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@