more drscheme repairs and tests
svn: r9721
This commit is contained in:
Matthew Flatt
parent
5295dcb197
commit
fad08fcd84
|
|
@ -6,6 +6,7 @@
|
|||
mzlib/contract
|
||||
mzlib/kw
|
||||
mzlib/string
|
||||
mzlib/struct
|
||||
"drsig.ss"
|
||||
string-constants
|
||||
mred
|
||||
|
|
@ -1308,6 +1309,66 @@
|
|||
[else `(expand ',res)]))))
|
||||
(super-instantiate ())))
|
||||
|
||||
(define-struct (simple-settings+assume drscheme:language:simple-settings) (no-redef?))
|
||||
(define simple-settings+assume->vector (make-->vector simple-settings+assume))
|
||||
|
||||
(define (assume-mixin %)
|
||||
(class %
|
||||
(define/override (default-settings)
|
||||
(extend-simple-settings (super default-settings) #t))
|
||||
|
||||
(define/override (marshall-settings settings)
|
||||
(simple-settings+assume->vector settings))
|
||||
|
||||
(define/override (unmarshall-settings printable)
|
||||
(and (vector? printable)
|
||||
(= (vector-length printable) 7)
|
||||
(let ([base
|
||||
(super unmarshall-settings
|
||||
(list->vector
|
||||
(reverse
|
||||
(cdr (reverse (vector->list printable))))))])
|
||||
(and base
|
||||
(extend-simple-settings
|
||||
base
|
||||
(and (vector-ref printable 6) #t))))))
|
||||
|
||||
(define/override (config-panel parent)
|
||||
(let ([p (new vertical-panel% [parent parent])])
|
||||
(let ([base-config (super config-panel p)]
|
||||
[assume-cb (new check-box%
|
||||
[parent
|
||||
(new group-box-panel%
|
||||
[parent p]
|
||||
[label "Initial Bindings"]
|
||||
[stretchable-height #f]
|
||||
[stretchable-width #f])]
|
||||
[label "Assume initial bindings never change"])])
|
||||
(case-lambda
|
||||
[() (extend-simple-settings (base-config)
|
||||
(send assume-cb get-value))]
|
||||
[(c)
|
||||
(base-config c)
|
||||
(send assume-cb set-value (simple-settings+assume-no-redef? c))]))))
|
||||
|
||||
(define/override (default-settings? x)
|
||||
(equal? (simple-settings+assume->vector x)
|
||||
(simple-settings+assume->vector (default-settings))))
|
||||
|
||||
(define/private (extend-simple-settings s no-redef?)
|
||||
(make-simple-settings+assume (drscheme:language:simple-settings-case-sensitive s)
|
||||
(drscheme:language:simple-settings-printing-style s)
|
||||
(drscheme:language:simple-settings-fraction-style s)
|
||||
(drscheme:language:simple-settings-show-sharing s)
|
||||
(drscheme:language:simple-settings-insert-newlines s)
|
||||
(drscheme:language:simple-settings-annotations s)
|
||||
no-redef?))
|
||||
|
||||
(define/override (use-namespace-require/copy-from-setting? s)
|
||||
(not (simple-settings+assume-no-redef? s)))
|
||||
|
||||
(super-new)))
|
||||
|
||||
(define (r5rs-mixin %)
|
||||
(class %
|
||||
(define/override (on-execute setting run-in-user-thread)
|
||||
|
|
@ -1317,12 +1378,13 @@
|
|||
(read-square-bracket-as-paren #f)
|
||||
(read-curly-brace-as-paren #f)
|
||||
(read-accept-infix-dot #f)
|
||||
(print-pair-curly-braces #t)
|
||||
(print-mpair-curly-braces #f)
|
||||
(print-vector-length #f))))
|
||||
(define/override (get-transformer-module) #f)
|
||||
|
||||
(define/override (default-settings)
|
||||
(drscheme:language:make-simple-settings #f 'write 'mixed-fraction-e #f #t 'debug))
|
||||
(make-simple-settings+assume #f 'write 'mixed-fraction-e #f #t 'debug #t))
|
||||
|
||||
(define/override (order-manuals x)
|
||||
(values
|
||||
(list #"r5rs" #"drscheme" #"tour" #"help")
|
||||
|
|
@ -1344,8 +1406,8 @@
|
|||
(λ (%)
|
||||
(class* % (drscheme:language:language<%>)
|
||||
(define/override (get-one-line-summary) one-line-summary)
|
||||
(define/override (use-namespace-require/copy?) #t)
|
||||
(inherit get-module get-transformer-module get-init-code)
|
||||
(inherit get-module get-transformer-module get-init-code
|
||||
use-namespace-require/copy-from-setting?)
|
||||
(define/augment (capability-value key)
|
||||
(cond
|
||||
[(eq? key 'drscheme:autocomplete-words)
|
||||
|
|
@ -1369,7 +1431,7 @@
|
|||
(get-transformer-module)
|
||||
(get-init-code setting)
|
||||
mred-launcher?
|
||||
(use-namespace-require/copy?)))))
|
||||
(use-namespace-require/copy-from-setting? setting)))))
|
||||
(super-new))))]
|
||||
[make-simple
|
||||
(λ (module id position numbers mred-launcher? one-line-summary extra-mixin)
|
||||
|
|
@ -1393,7 +1455,7 @@
|
|||
(list -1000 3)
|
||||
#t
|
||||
(string-constant pretty-big-scheme-one-line-summary)
|
||||
(λ (x) x)))
|
||||
assume-mixin))
|
||||
(add-language
|
||||
(make-simple '(lib "r5rs/lang.ss")
|
||||
"plt:r5rs"
|
||||
|
|
@ -1402,7 +1464,7 @@
|
|||
(list -1000 -1000)
|
||||
#f
|
||||
(string-constant r5rs-one-line-summary)
|
||||
r5rs-mixin))
|
||||
(lambda (%) (r5rs-mixin (assume-mixin %)))))
|
||||
|
||||
(add-language
|
||||
(make-simple 'mzscheme
|
||||
|
|
|
|||
|
|
@ -79,6 +79,7 @@
|
|||
get-module
|
||||
get-transformer-module
|
||||
use-namespace-require/copy?
|
||||
use-namespace-require/copy-from-setting?
|
||||
config-panel
|
||||
|
||||
get-reader
|
||||
|
|
@ -167,6 +168,8 @@
|
|||
(mixin (simple-module-based-language<%>) (module-based-language<%>)
|
||||
(define/public (get-transformer-module) 'mzscheme)
|
||||
(define/public (use-namespace-require/copy?) #f)
|
||||
(define/public (use-namespace-require/copy-from-setting? setting)
|
||||
(use-namespace-require/copy?))
|
||||
(define/public (use-mred-launcher) #t)
|
||||
|
||||
(inherit get-module)
|
||||
|
|
@ -520,7 +523,7 @@
|
|||
;; given a module-based-language, implements a language
|
||||
(define module-based-language->language-mixin
|
||||
(mixin (module-based-language<%>) (language<%>)
|
||||
(inherit get-module get-transformer-module use-namespace-require/copy?
|
||||
(inherit get-module get-transformer-module use-namespace-require/copy-from-setting?
|
||||
get-init-code use-mred-launcher get-reader)
|
||||
|
||||
(define/pubment (capability-value s)
|
||||
|
|
@ -539,7 +542,7 @@
|
|||
(define/public (get-style-delta) #f)
|
||||
(define/override (on-execute setting run-in-user-thread)
|
||||
(super on-execute setting run-in-user-thread)
|
||||
(initialize-module-based-language (use-namespace-require/copy?)
|
||||
(initialize-module-based-language (use-namespace-require/copy-from-setting? setting)
|
||||
(get-module)
|
||||
(get-transformer-module)
|
||||
run-in-user-thread))
|
||||
|
|
@ -554,7 +557,7 @@
|
|||
(get-transformer-module)
|
||||
(get-init-code setting)
|
||||
(use-mred-launcher)
|
||||
(use-namespace-require/copy?)))
|
||||
(use-namespace-require/copy-from-setting? setting)))
|
||||
(define/public (extra-repl-information _1 _2) (void))
|
||||
(define/public (get-reader-module) #f)
|
||||
(define/public (get-metadata a b c) #f)
|
||||
|
|
@ -1125,12 +1128,9 @@
|
|||
(λ (x)
|
||||
(display (exn-message x))
|
||||
(newline))])
|
||||
(namespace-require module-spec)
|
||||
;; we always do a require to get the provide-for-syntax bindings
|
||||
;; if copy semantics is wanted, we do a copy next to clobber (some of)
|
||||
;; the bindings
|
||||
(when use-copy?
|
||||
(namespace-require/copy module-spec))
|
||||
(if use-copy?
|
||||
(namespace-require/copy module-spec)
|
||||
(namespace-require module-spec))
|
||||
(when transformer-module-spec
|
||||
(namespace-require `(for-syntax ,transformer-module-spec)))))))
|
||||
|
||||
|
|
|
|||
|
|
@ -1052,6 +1052,9 @@ TODO
|
|||
(equal? code #\return)
|
||||
(equal? code #\newline)))
|
||||
(super on-local-char key)]
|
||||
[(not prompt-position)
|
||||
;; evaluating? just drop the keypress
|
||||
(void)]
|
||||
[(and (< end prompt-position)
|
||||
(= start end)
|
||||
(get-backward-sexp end))
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
|
||||
(require (only "string.ss" expr->string)
|
||||
(only "list.ss" sort)
|
||||
scheme/mpair
|
||||
"etc.ss"
|
||||
"pconvert-prop.ss"
|
||||
"class.ss")
|
||||
|
|
@ -145,6 +146,10 @@
|
|||
(unless (build-sub expr)
|
||||
(build (car expr))
|
||||
(build (cdr expr)))]
|
||||
[(mpair? expr)
|
||||
(unless (build-sub expr)
|
||||
(build (mcar expr))
|
||||
(build (mcdr expr)))]
|
||||
[(vector? expr)
|
||||
(unless (build-sub expr)
|
||||
(for-each build (vector->list expr)))]
|
||||
|
|
@ -171,7 +176,8 @@
|
|||
(define print-convert-expr
|
||||
(lambda (csi expr unroll-once?)
|
||||
(letrec
|
||||
([share-hash (convert-share-info-share-hash csi)]
|
||||
([mpair-mode? (is-mpair-mode?)]
|
||||
[share-hash (convert-share-info-share-hash csi)]
|
||||
[find-hash
|
||||
(lambda (expr)
|
||||
(hash-table-get share-hash expr (lambda () #f)))]
|
||||
|
|
@ -209,18 +215,23 @@
|
|||
[use-quasi-quote? (not (constructor-style-printing))]
|
||||
[use-read-syntax (quasi-read-style-printing)]
|
||||
[doesnt-contain-shared-conses
|
||||
(lambda (input-expr)
|
||||
(letrec ([doesnt-contain-shared-conses
|
||||
(lambda (expr)
|
||||
(cond
|
||||
[(and (pair? expr)
|
||||
(shared? expr))
|
||||
#f]
|
||||
[(pair? expr)
|
||||
(doesnt-contain-shared-conses (cdr expr))]
|
||||
[else #t]))])
|
||||
(let ([answer (doesnt-contain-shared-conses input-expr)])
|
||||
answer)))]
|
||||
(lambda (expr)
|
||||
(cond
|
||||
[(and (pair? expr)
|
||||
(shared? expr))
|
||||
#f]
|
||||
[(pair? expr)
|
||||
(doesnt-contain-shared-conses (cdr expr))]
|
||||
[else #t]))]
|
||||
[doesnt-contain-shared-mconses
|
||||
(lambda (expr)
|
||||
(cond
|
||||
[(and (mpair? expr)
|
||||
(shared? expr))
|
||||
#f]
|
||||
[(mpair? expr)
|
||||
(doesnt-contain-shared-mconses (mcdr expr))]
|
||||
[else #t]))]
|
||||
[get-whole/frac
|
||||
(lambda (exact-num)
|
||||
(let ([split
|
||||
|
|
@ -252,10 +263,8 @@
|
|||
(zero? frac))))))))
|
||||
(and (symbol? expr)
|
||||
(not (eq? expr 'quasiquote))
|
||||
(not (eq? expr 'quote))
|
||||
(not (eq? expr 'unquote))
|
||||
(not (eq? expr 'quote-syntax))
|
||||
(not (eq? expr 'syntax)))
|
||||
(not (eq? expr 'unquote-splicing)))
|
||||
(char? expr)
|
||||
(string? expr)
|
||||
(not expr)
|
||||
|
|
@ -270,21 +279,12 @@
|
|||
(lambda ()
|
||||
(cond
|
||||
[(null? expr) '()]
|
||||
[(and (pair? expr)
|
||||
(pair? (cdr expr))
|
||||
(null? (cddr expr))
|
||||
(or (eq? (car expr) 'quote)
|
||||
(eq? expr 'quasiquote)
|
||||
(eq? expr 'quote)
|
||||
(eq? expr 'unquote)
|
||||
(eq? expr 'quote-syntax)
|
||||
(eq? expr 'syntax)))
|
||||
`(,(car expr) ,(recur (cadr expr)))]
|
||||
[(and (list? expr)
|
||||
(doesnt-contain-shared-conses expr))
|
||||
(map recur expr)]
|
||||
[(pair? expr)
|
||||
(cons (recur (car expr)) (recur (cdr expr)))]
|
||||
[(and mpair-mode?
|
||||
(mpair? expr))
|
||||
;; generate pairs, which will be converted back to mpairs later
|
||||
(cons (recur (mcar expr)) (recur (mcdr expr)))]
|
||||
[(self-quoting? expr) expr]
|
||||
[else `(,'unquote ,((print #f first-time) expr))]))]
|
||||
|
||||
|
|
@ -335,6 +335,21 @@
|
|||
(guard/quasiquote
|
||||
(lambda ()
|
||||
`(cons ,(recur (car expr)) ,(recur (cdr expr)))))]
|
||||
[(and mpair-mode?
|
||||
(abbreviate-cons-as-list)
|
||||
(mlist? expr)
|
||||
(or (and first-time
|
||||
(doesnt-contain-shared-mconses (mcdr expr)))
|
||||
(doesnt-contain-shared-mconses expr)))
|
||||
(guard/quasiquote
|
||||
(lambda ()
|
||||
`(list ,@(map recur (mlist->list expr)))))]
|
||||
[(mpair? expr)
|
||||
(if mpair-mode?
|
||||
(guard/quasiquote
|
||||
(lambda ()
|
||||
`(cons ,(recur (mcar expr)) ,(recur (mcdr expr)))))
|
||||
`(mcons ,(recur (mcar expr)) ,(recur (mcdr expr))))]
|
||||
[(weak-box? expr) `(make-weak-box ,(recur (weak-box-value expr)))]
|
||||
[(box? expr) `(box ,(recur (unbox expr)))]
|
||||
[(hash-table? expr) `(,(cond
|
||||
|
|
@ -448,6 +463,9 @@
|
|||
(quasi-style))
|
||||
(constructor-style)))))))])
|
||||
((print #f unroll-once?) expr))))
|
||||
|
||||
(define (is-mpair-mode?)
|
||||
(not (print-mpair-curly-braces)))
|
||||
|
||||
;; type (improper-list a) = (union (cons (improper-list a) (improper-list a)) null a)
|
||||
;; improper-map : (a -> b) -> (improper-list a) -> (improper-list b)
|
||||
|
|
|
|||
|
|
@ -86,6 +86,13 @@ used; e.g., the pair containing @scheme[1] and @scheme[2] is
|
|||
represented as @scheme[`(1 . 2)]. The initial value of the parameter
|
||||
is @scheme[#f].
|
||||
|
||||
The constructor used for mutable pairs is @schemeidfont{mcons}, unless
|
||||
@scheme[print-mpair-curly-braces] is set to @scheme[#f], in which case
|
||||
@schemeidfont{cons} and @schemeidfont{list} are used. Similarly, when
|
||||
using @scheme[quasiquote] style and @scheme[print-mpair-curly-braces]
|
||||
is set to @scheme[#f], mutable pair constructions are represented
|
||||
using @schemeidfont{quote}, @schemeidfont{quasiquote}, etc.
|
||||
|
||||
See also @scheme[quasi-read-style-printing] and
|
||||
@scheme[prop:print-convert-constructor-name].}
|
||||
|
||||
|
|
|
|||
|
|
@ -96,9 +96,22 @@
|
|||
(define (mlist? l)
|
||||
(cond
|
||||
[(null? l) #t]
|
||||
[(mpair? l) (mlist? (mcdr l))]
|
||||
[(mpair? l)
|
||||
(let loop ([turtle l][hare (mcdr l)])
|
||||
(cond
|
||||
[(null? hare) #t]
|
||||
[(eq? hare turtle) #f]
|
||||
[(mpair? hare)
|
||||
(let ([hare (mcdr hare)])
|
||||
(cond
|
||||
[(null? hare) #t]
|
||||
[(eq? hare turtle) #f]
|
||||
[(mpair? hare)
|
||||
(loop (mcdr turtle) (mcdr hare))]
|
||||
[else #f]))]
|
||||
[else #f]))]
|
||||
[else #f]))
|
||||
|
||||
|
||||
(define (mlength l)
|
||||
(let loop ([l l][len 0])
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -364,11 +364,11 @@ then when then reader encounters @litchar["{"] and @litchar["}"], the
|
|||
@exnraise{exn:fail:read}.
|
||||
|
||||
If the @scheme[read-accept-dot] @tech{parameter} is set to
|
||||
@scheme[#f], then a delimited @scheme{.} is not treated specially; it
|
||||
is instead parsed as a symbol. If the @scheme[read-accept-infix-dot]
|
||||
@tech{parameter} is set to @scheme[#f], then multiple delimited
|
||||
@litchar{.}s trigger a @scheme[exn:fail:read], instead of the infix
|
||||
conversion.
|
||||
@scheme[#f], then a delimited @litchar{.} triggers an
|
||||
@scheme[exn:fail:read] exception. If the
|
||||
@scheme[read-accept-infix-dot] @tech{parameter} is set to @scheme[#f],
|
||||
then multiple delimited @litchar{.}s trigger an @scheme[exn:fail:read]
|
||||
exception, instead of the infix conversion.
|
||||
|
||||
@section[#:tag "parse-string"]{Reading Strings}
|
||||
|
||||
|
|
|
|||
|
|
@ -185,7 +185,7 @@ add this test:
|
|||
|
||||
(define drs-frame (wait-for-drscheme-frame))
|
||||
(define interactions-text (send drs-frame get-interactions-text))
|
||||
(set-language-level! (list "PLT" (regexp "Textual")))
|
||||
(set-language-level! (list "Pretty Big (includes MrEd and Advanced Student)"))
|
||||
|
||||
(define (run-test)
|
||||
(output-err-port-checking) ;; must come first
|
||||
|
|
|
|||
|
|
@ -41,6 +41,7 @@ the settings above should match r5rs
|
|||
;; ; ;; ;;;; ;;; ;;; ;
|
||||
|
||||
|
||||
#:
|
||||
(define (mred)
|
||||
(parameterize ([language (list "PLT" (regexp "Graphical"))])
|
||||
(check-top-of-repl)
|
||||
|
|
@ -61,7 +62,7 @@ the settings above should match r5rs
|
|||
|
||||
(test-expression 'xml "(a () (b ()))")
|
||||
|
||||
(test-expression "(define-struct spider (legs))(make-spider 4)" "#<struct:spider>")
|
||||
(test-expression "(define-struct spider (legs))(make-spider 4)" "#<spider>")
|
||||
|
||||
(test-expression "(sqrt -1)" "0+1i")
|
||||
|
||||
|
|
@ -75,7 +76,7 @@ the settings above should match r5rs
|
|||
(test-expression "(define (f car) 1)" "")
|
||||
(test-expression "(define (f empty) 1)" "")
|
||||
|
||||
(test-expression "call/cc" "#<primitive:call-with-current-continuation>")
|
||||
(test-expression "call/cc" "#<procedure:call-with-current-continuation>")
|
||||
|
||||
(test-expression "(error 'a \"~a\" 1)" "{bug09.png} a: 1")
|
||||
(test-expression "(error \"a\" \"a\")" "{bug09.png} a \"a\"")
|
||||
|
|
@ -139,11 +140,9 @@ the settings above should match r5rs
|
|||
;; ; ;; ;;;;; ;;; ;;; ;;; ;;; ;;; ;; ; ;; ;;;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
(define (mzscheme)
|
||||
(parameterize ([language (list "PLT" (regexp "Textual"))])
|
||||
(define (pretty-big)
|
||||
(parameterize ([language (list "Pretty Big (includes MrEd and Advanced Student)")])
|
||||
|
||||
(check-top-of-repl)
|
||||
|
||||
|
|
@ -160,12 +159,12 @@ the settings above should match r5rs
|
|||
"#f")
|
||||
(test-expression "(define x 1)(define x 2)" "")
|
||||
|
||||
(test-expression "(define-struct spider (legs))(make-spider 4)" "#<struct:spider>")
|
||||
(test-expression "(define-struct spider (legs))(make-spider 4)" "#<spider>")
|
||||
|
||||
(test-expression "(sqrt -1)" "0+1i")
|
||||
|
||||
(test-expression "class" "{bug09.png} reference to undefined identifier: class")
|
||||
(test-expression "shared" "{bug09.png} reference to undefined identifier: shared")
|
||||
(test-expression "class" (regexp "class: bad syntax in: class"))
|
||||
(test-expression "shared" (regexp "shared: bad syntax in: shared"))
|
||||
|
||||
(test-expression "(define (. x y) (* x y))" #rx"read: illegal use of \"\\.\"")
|
||||
(test-expression "'(1 . 2)" "(1 . 2)")
|
||||
|
|
@ -174,7 +173,7 @@ the settings above should match r5rs
|
|||
(test-expression "(define (f car) 1)" "")
|
||||
(test-expression "(define (f empty) 1)" "")
|
||||
|
||||
(test-expression "call/cc" "#<primitive:call-with-current-continuation>")
|
||||
(test-expression "call/cc" "#<procedure:call-with-current-continuation>")
|
||||
|
||||
(test-expression "(error 'a \"~a\" 1)" "{bug09.png} a: 1")
|
||||
(test-expression "(error \"a\" \"a\")" "{bug09.png} a \"a\"")
|
||||
|
|
@ -182,7 +181,7 @@ the settings above should match r5rs
|
|||
(test-expression "(time 1)"
|
||||
#rx"cpu time: [0-9]+ real time: [0-9]+ gc time: [0-9]+\n1")
|
||||
|
||||
(test-expression "true" "{bug09.png} reference to undefined identifier: true")
|
||||
(test-expression "true" "#t")
|
||||
(test-expression "mred^" "{bug09.png} reference to undefined identifier: mred^")
|
||||
(test-expression "(eq? 'a 'A)" "#f")
|
||||
(test-expression "(set! x 1)" "{bug09.png} set!: cannot set undefined identifier: x")
|
||||
|
|
@ -193,9 +192,7 @@ the settings above should match r5rs
|
|||
(test-expression "'(1)" "(1)")
|
||||
(test-expression "(define shrd (box 1)) (list shrd shrd)"
|
||||
"(#&1 #&1)")
|
||||
(test-expression
|
||||
"(local ((define x x)) 1)"
|
||||
#rx"define: not allowed in an expression context")
|
||||
(test-expression "(local ((define x x)) 1)" "1")
|
||||
(test-expression "(letrec ([x x]) 1)" "1")
|
||||
(test-expression "(if 1 1 1)" "1")
|
||||
(test-expression "(+ 1)" "1")
|
||||
|
|
@ -221,7 +218,7 @@ the settings above should match r5rs
|
|||
(test-expression "(list 1)" "(1)")
|
||||
(test-expression "(car (list))" "{bug09.png} car: expects argument of type <pair>; given ()")
|
||||
|
||||
(test-expression "argv" "#0()")
|
||||
(test-expression "(current-command-line-arguments)" "#()")
|
||||
(test-expression "(define-syntax app syntax-case)" "syntax-case: bad syntax in: syntax-case")))
|
||||
|
||||
|
||||
|
|
@ -324,7 +321,7 @@ the settings above should match r5rs
|
|||
|
||||
(test-expression "(list 1)" "(1)")
|
||||
(test-expression "(car (list))"
|
||||
"{bug09.png} car: expects argument of type <pair>; given ()")
|
||||
"{bug09.png} mcar: expects argument of type <mutable-pair>; given ()")
|
||||
|
||||
(test-expression "argv" "{bug09.png} reference to undefined identifier: argv")
|
||||
(test-expression "(define-syntax app syntax-case)"
|
||||
|
|
@ -357,7 +354,7 @@ the settings above should match r5rs
|
|||
|
||||
(prepare-for-test-expression)
|
||||
|
||||
(test-expression "'|.|" "'|.|")
|
||||
(test-expression "'|.|" "'.")
|
||||
(test-expression '("(equal? (list " image ") (list " image "))")
|
||||
"true")
|
||||
|
||||
|
|
@ -378,9 +375,8 @@ the settings above should match r5rs
|
|||
"shared: name is not defined, not a parameter, and not a primitive name"
|
||||
"reference to an identifier before its definition: shared")
|
||||
|
||||
(test-expression "(define (. x y) (* x y))"
|
||||
"read: illegal use of \".\"")
|
||||
(test-expression "'(1 . 2)" "read: illegal use of \".\"")
|
||||
(test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
|
||||
(test-expression "'(1 . 2)" "read: illegal use of \".\"")
|
||||
|
||||
(test-expression "call/cc"
|
||||
"call/cc: name is not defined, not a parameter, and not a primitive name"
|
||||
|
|
@ -450,7 +446,9 @@ the settings above should match r5rs
|
|||
(test-expression "argv"
|
||||
"argv: name is not defined, not a parameter, and not a primitive name"
|
||||
"reference to an identifier before its definition: argv")
|
||||
(test-expression "(define-syntax app syntax-case)" "")))
|
||||
(test-expression "(define-syntax app syntax-case)"
|
||||
"define-syntax: name is not defined, not a parameter, and not a primitive name"
|
||||
"reference to an identifier before its definition: define-syntax")))
|
||||
|
||||
|
||||
|
||||
|
|
@ -483,7 +481,7 @@ the settings above should match r5rs
|
|||
|
||||
(prepare-for-test-expression)
|
||||
|
||||
(test-expression "'|.|" "'|.|")
|
||||
(test-expression "'|.|" "'.")
|
||||
(test-expression '("(equal? (list " image ") (list " image "))")
|
||||
"true")
|
||||
|
||||
|
|
@ -504,8 +502,8 @@ the settings above should match r5rs
|
|||
"shared: name is not defined, not a parameter, and not a primitive name"
|
||||
"reference to an identifier before its definition: shared")
|
||||
|
||||
(test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
|
||||
(test-expression "'(1 . 2)" "read: illegal use of \".\"")
|
||||
(test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
|
||||
(test-expression "'(1 . 2)" "read: illegal use of \".\"")
|
||||
|
||||
(test-expression "call/cc"
|
||||
"call/cc: name is not defined, not a parameter, and not a primitive name"
|
||||
|
|
@ -576,7 +574,8 @@ the settings above should match r5rs
|
|||
"reference to an identifier before its definition: argv")
|
||||
|
||||
(test-expression "(define-syntax app syntax-case)"
|
||||
"define-syntax: name is not defined, not a parameter, and not a primitive name")))
|
||||
"define-syntax: name is not defined, not a parameter, and not a primitive name"
|
||||
"reference to an identifier before its definition: define-syntax")))
|
||||
|
||||
|
||||
|
||||
|
|
@ -607,7 +606,7 @@ the settings above should match r5rs
|
|||
|
||||
(prepare-for-test-expression)
|
||||
|
||||
(test-expression "'|.|" "'|.|")
|
||||
(test-expression "'|.|" "'.")
|
||||
(test-expression '("(equal? (list " image ") (list " image "))")
|
||||
"true")
|
||||
|
||||
|
|
@ -628,8 +627,8 @@ the settings above should match r5rs
|
|||
"shared: name is not defined, not a parameter, and not a primitive name"
|
||||
"reference to an identifier before its definition: shared")
|
||||
|
||||
(test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
|
||||
(test-expression "'(1 . 2)" "read: illegal use of \".\"")
|
||||
(test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
|
||||
(test-expression "'(1 . 2)" "read: illegal use of \".\"")
|
||||
|
||||
(test-expression "call/cc"
|
||||
"call/cc: name is not defined, not a parameter, and not a primitive name"
|
||||
|
|
@ -690,8 +689,10 @@ the settings above should match r5rs
|
|||
(test-expression "argv"
|
||||
"argv: name is not defined, not a parameter, and not a primitive name"
|
||||
"reference to an identifier before its definition: argv")
|
||||
|
||||
(test-expression "(define-syntax app syntax-case)"
|
||||
"define-syntax: name is not defined, not a parameter, and not a primitive name")))
|
||||
"define-syntax: name is not defined, not a parameter, and not a primitive name"
|
||||
"reference to an identifier before its definition: define-syntax")))
|
||||
|
||||
|
||||
|
||||
|
|
@ -723,7 +724,7 @@ the settings above should match r5rs
|
|||
|
||||
(prepare-for-test-expression)
|
||||
|
||||
(test-expression "'|.|" "'|.|")
|
||||
(test-expression "'|.|" "'.")
|
||||
(test-expression '("(equal? (list " image ") (list " image "))")
|
||||
"true")
|
||||
(test-expression "(define x 1)(define x 2)"
|
||||
|
|
@ -805,8 +806,10 @@ the settings above should match r5rs
|
|||
(test-expression "argv"
|
||||
"argv: name is not defined, not a parameter, and not a primitive name"
|
||||
"reference to an identifier before its definition: argv")
|
||||
|
||||
(test-expression "(define-syntax app syntax-case)"
|
||||
"define-syntax: name is not defined, not a parameter, and not a primitive name")))
|
||||
"define-syntax: name is not defined, not a parameter, and not a primitive name"
|
||||
"reference to an identifier before its definition: define-syntax")))
|
||||
|
||||
|
||||
|
||||
|
|
@ -837,7 +840,7 @@ the settings above should match r5rs
|
|||
|
||||
(prepare-for-test-expression)
|
||||
|
||||
(test-expression "'|.|" "'|.|")
|
||||
(test-expression "'|.|" "'.")
|
||||
(test-expression '("(equal? (list " image ") (list " image "))")
|
||||
"true")
|
||||
(test-expression "(define x 1)(define x 2)"
|
||||
|
|
@ -856,8 +859,8 @@ the settings above should match r5rs
|
|||
|
||||
(test-expression "shared" "shared: found a use of `shared' that does not follow an open parenthesis")
|
||||
|
||||
(test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
|
||||
(test-expression "'(1 . 2)" "read: illegal use of \".\"")
|
||||
(test-expression "(define (. x y) (* x y))" "read: illegal use of \".\"")
|
||||
(test-expression "'(1 . 2)" "read: illegal use of \".\"")
|
||||
|
||||
(test-expression "call/cc"
|
||||
"call/cc: name is not defined, not a parameter, and not a primitive name"
|
||||
|
|
@ -918,8 +921,10 @@ the settings above should match r5rs
|
|||
(test-expression "argv"
|
||||
"argv: name is not defined, not a parameter, and not a primitive name"
|
||||
"reference to an identifier before its definition: argv")
|
||||
|
||||
(test-expression "(define-syntax app syntax-case)"
|
||||
"define-syntax: name is not defined, not a parameter, and not a primitive name")))
|
||||
"define-syntax: name is not defined, not a parameter, and not a primitive name"
|
||||
"reference to an identifier before its definition: define-syntax")))
|
||||
|
||||
|
||||
|
||||
|
|
@ -982,6 +987,8 @@ the settings above should match r5rs
|
|||
(define (check-top-of-repl)
|
||||
(let ([drs (wait-for-drscheme-frame)])
|
||||
(set-language #t)
|
||||
(with-handlers ([exn:fail? void])
|
||||
(fw:test:menu-select "Testing" "Disable tests"))
|
||||
(do-execute drs)
|
||||
(let* ([interactions (send drs get-interactions-text)]
|
||||
[short-lang (car (last-pair (language)))]
|
||||
|
|
@ -991,13 +998,16 @@ the settings above should match r5rs
|
|||
[line0-expect (format "Welcome to DrScheme, version ~a [3m]." (version:version))]
|
||||
[line1-expect
|
||||
(if (string? short-lang)
|
||||
(format "Language: ~a." short-lang)
|
||||
(format "Language: ~a" short-lang)
|
||||
short-lang)]
|
||||
[line0-got (get-line 0)]
|
||||
[line1-got (get-line 1)])
|
||||
(unless (and (string=? line0-expect line0-got)
|
||||
(if (string? short-lang)
|
||||
(string=? line1-expect line1-got)
|
||||
(string=? line1-expect (substring line1-got
|
||||
0
|
||||
(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
|
||||
|
|
@ -1166,12 +1176,12 @@ the settings above should match r5rs
|
|||
(cond
|
||||
[(eq? item 'image)
|
||||
(use-get/put-dialog
|
||||
(lambda () (fw:test:menu-select "Special" "Insert Image..."))
|
||||
(simplify-path (build-path (collection-path "icons") "recycle.gif")))]
|
||||
(lambda () (fw:test:menu-select "Insert" "Insert Image..."))
|
||||
(simplify-path (build-path (collection-path "icons") "recycle.png")))]
|
||||
[(string? item)
|
||||
(type-in-definitions drs item)]
|
||||
[(eq? item 'xml)
|
||||
(fw:test:menu-select "Special" "Insert XML Box")
|
||||
(fw:test:menu-select "Insert" "Insert XML Box")
|
||||
(for-each fw:test:keystroke (string->list "<a><b>"))]
|
||||
[else (error 'handle-insertion "unknown thing to insert ~s" item)]))]
|
||||
[check-expectation
|
||||
|
|
@ -1246,11 +1256,11 @@ the settings above should match r5rs
|
|||
(printf ">> finished ~a\n" (syntax-object->datum #'arg))))]))
|
||||
|
||||
(define (run-test)
|
||||
(go mred)
|
||||
(go mzscheme)
|
||||
;; (go mred)
|
||||
(go r5rs)
|
||||
(go pretty-big)
|
||||
(go beginner)
|
||||
(go beginner/abbrev)
|
||||
(go intermediate)
|
||||
(go intermediate/lambda)
|
||||
(go advanced)
|
||||
(go r5rs)))
|
||||
(go advanced)))
|
||||
|
|
|
|||
|
|
@ -218,9 +218,7 @@
|
|||
(list read-accept-dot
|
||||
(list #t #f)
|
||||
'(let ([p (open-input-string "(1 . 2)")])
|
||||
(if (list? (read p))
|
||||
(error "ack")
|
||||
'ok))
|
||||
(read p))
|
||||
exn:fail?
|
||||
#f)
|
||||
(list read-accept-quasiquote
|
||||
|
|
|
|||
|
|
@ -1003,9 +1003,12 @@
|
|||
|
||||
(parameterize ([current-readtable (make-readtable (current-readtable) #\. #\a #f)])
|
||||
(test '|.| read (open-input-string ".")))
|
||||
(parameterize ([current-readtable (make-readtable (current-readtable) #\. #\a #f)]
|
||||
[read-accept-dot #f])
|
||||
(test '|.| read (open-input-string ".")))
|
||||
(parameterize ([read-accept-dot #f]
|
||||
[current-readtable (make-readtable (current-readtable) #\w #\. #f)])
|
||||
(test '|w| read (open-input-string "w")))
|
||||
(err/rt-test (read (open-input-string "w")) exn:fail:read?))
|
||||
(parameterize ([current-readtable (make-readtable (current-readtable) #\w #\. #f)])
|
||||
(err/rt-test (read (open-input-string "w")) exn:fail:read?))
|
||||
|
||||
|
|
|
|||
|
|
@ -2,6 +2,14 @@
|
|||
Version 4.0
|
||||
------------------------------
|
||||
|
||||
. renamed "(module ...)" language to "Module"
|
||||
|
||||
. dropped "MzScheme" and "MrEd" as seperate languages;
|
||||
try `#lang scheme/load' with the "Module" language
|
||||
|
||||
. changed the "Pretty Big" and "R5RS" to assume by default
|
||||
that pre-defined names will not be redefined
|
||||
|
||||
. renamed the get-special-menu method to get-insert-menu
|
||||
|
||||
. drscheme:debug:show-backtrace-window
|
||||
|
|
|
|||
|
|
@ -7748,7 +7748,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
|
|||
int is_kern, has_context, save_marshal_info = 0;
|
||||
Scheme_Object *nominal_modidx, *one_exn, *prnt_iname, *name, *rn, *ename = orig_ename;
|
||||
Scheme_Hash_Table *orig_onlys;
|
||||
int k, skip_rename;
|
||||
int k, skip_rename, do_copy_vars;
|
||||
|
||||
if (mark_src) {
|
||||
/* Check whether there's context for this import (which
|
||||
|
|
@ -7824,11 +7824,17 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
|
|||
to_phase,
|
||||
1);
|
||||
|
||||
if (copy_vars)
|
||||
do_copy_vars = !orig_env->module && !orig_env->phase && SAME_OBJ(src_phase_index, scheme_make_integer(0)) && (k == -3);
|
||||
else
|
||||
do_copy_vars = 0;
|
||||
|
||||
if (can_save_marshal
|
||||
&& !exns
|
||||
&& !prefix
|
||||
&& !orig_ename
|
||||
&& (pt->num_provides || pt->reprovide_kernel)) {
|
||||
&& (pt->num_provides || pt->reprovide_kernel)
|
||||
&& !do_copy_vars) {
|
||||
/* Simple "import everything" whose mappings can be shared via the exporting module: */
|
||||
if (!pt->src_modidx)
|
||||
pt->src_modidx = me->src_modidx;
|
||||
|
|
@ -7919,9 +7925,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */
|
|||
data, cki, form, err_src, mark_src, to_phase, src_phase_index, pt->phase_index);
|
||||
|
||||
if (!is_kern) {
|
||||
if (copy_vars && (j < var_count) && !orig_env->module
|
||||
&& SAME_OBJ(src_phase_index, scheme_make_integer(0))
|
||||
&& !orig_env->phase && !k) {
|
||||
if (do_copy_vars && (j < var_count)) {
|
||||
Scheme_Env *menv;
|
||||
Scheme_Object *val;
|
||||
modidx = scheme_module_resolve(modidx, 1);
|
||||
|
|
@ -8440,7 +8444,7 @@ void parse_requires(Scheme_Object *form,
|
|||
rn_set, post_ex_rn_set, NULL,
|
||||
exns, onlys, prefix, iname, ename,
|
||||
mark_src,
|
||||
unpack_kern, copy_vars && start, 0, can_save_marshal,
|
||||
unpack_kern, copy_vars, 0, can_save_marshal,
|
||||
all_simple,
|
||||
ck, data,
|
||||
form, err_src, i);
|
||||
|
|
|
|||
|
|
@ -3625,8 +3625,7 @@ read_number_or_symbol(int init_ch, int skip_rt, Scheme_Object *port,
|
|||
|
||||
if (!quoted_ever && (i == 1)
|
||||
&& (readtable_effective_char(params->table, buf[0]) == '.')
|
||||
&& !honu_mode
|
||||
&& params->can_read_dot) {
|
||||
&& !honu_mode) {
|
||||
long xl, xc, xp;
|
||||
scheme_tell_all(port, &xl, &xc, &xp);
|
||||
scheme_read_err(port, stxsrc, xl, xc, xp,
|
||||
|
|
|
|||
|
|
@ -73,8 +73,8 @@ wxFrame::wxFrame // Constructor (for frame window)
|
|||
) :
|
||||
wxbFrame (windowName, wxScreen::gScreenWindow,
|
||||
x, y,
|
||||
(width < 30) ? 30 : width,
|
||||
(height < 40) ? 40 : height, style)
|
||||
(cStyle & wxNO_CAPTION) ? width : ((width < 30) ? 30 : width),
|
||||
(cStyle & wxNO_CAPTION) ? height : ((height < 40) ? 40 : height), style)
|
||||
{
|
||||
int X, Y, theMacX, theMacY, theMacWidth, theMacHeight;
|
||||
Rect theBoundsRect;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user