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

370.2

Browse Source 
svn: r6369
This commit is contained in:
Matthew Flatt 2007-05-29 03:26:32 +00:00
parent 72eefe8b26
commit e9385a910e
66 changed files with 4047 additions and 3450 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/compiler/private/driver.ss
View File

@ -438,8 +438,6 @@
"file appears to have graphical syntax (try gmzc): ~a"
path))
p)))])
;; Skip leading "#!:
(strip-shell-command-start p)
p))
;;-------------------------------------------------------------------------------

8
collects/drscheme/private/eval.ss
View File

@ -195,7 +195,6 @@
;; build-input-port : string[file-exists?] -> (values input any)
;; constructs an input port for the load handler. Also
;; returns a value representing the source of code read from the file.
;; if the file's first lines begins with #!, skips the first chars of the file.
(define (build-input-port filename)
(let* ([p (open-input-file filename)]
[chars (list (read-char p)
@ -209,15 +208,8 @@
(send text load-file filename)
(let ([port (open-input-text-editor text)])
(port-count-lines! port)
(when (and ((send text last-position) . >= . 2)
(char=? #\# (send text get-character 0))
(char=? #\! (send text get-character 1)))
(read-line port))
(values port text)))]
[else
(let ([port (open-input-file filename)])
(port-count-lines! port)
(when (and (equal? #\# (car chars))
(equal? #\! (cadr chars)))
(read-line port))
(values port filename))])))))

6
collects/drscheme/private/unit.ss
View File

@ -2004,11 +2004,7 @@ module browser threading seems wrong.
(send interactions-canvas focus)
(send interactions-text reset-console)
(send interactions-text clear-undos)
(let ([start (if (and ((send definitions-text last-position) . >= . 2)
(char=? (send definitions-text get-character 0) #\#)
(char=? (send definitions-text get-character 1) #\!))
(send definitions-text paragraph-start-position 1)
0)])
(let ([start 0])
(send definitions-text split-snip start)
(let ([text-port (open-input-text-editor definitions-text start)])
(port-count-lines! text-port)

3
collects/guibuilder/toolbar.ss
View File

@ -35,6 +35,7 @@
(define toolbar%
(class mred:canvas%
(inherit min-height stretchable-height get-dc)
(init [style '()])
(private-field
[margin 2]
[icon-size 16]
@ -129,7 +130,7 @@
#f))))])
(hash-table-put! icons name icon)
(set! tools (append tools (list (make-tool icon cb #f))))))])
(super-new)
(super-new [style (cons 'no-focus style)])
(min-height (+ icon-size (* margin 2)))
(stretchable-height #f)))

3
collects/mred/private/mrcanvas.ss
View File

@ -92,7 +92,8 @@
(sequence
(let ([cwho '(constructor canvas)])
(check-container-parent cwho parent)
(check-style cwho #f '(border hscroll vscroll gl deleted control-border combo no-autoclear transparent resize-corner)
(check-style cwho #f '(border hscroll vscroll gl deleted control-border combo no-autoclear
transparent resize-corner no-focus)
style)
(check-callback cwho paint-callback)
(check-label-string/false cwho label)))

16
collects/mred/private/snipfile.ss
View File

@ -249,7 +249,6 @@
;; build-input-port : string -> (values input any)
;; constructs an input port for the load handler. Also
;; returns a value representing the source of code read from the file.
;; if the file's first lines begins with #!, skips the first chars of the file.
(define (build-input-port filename)
(let ([p (open-input-file filename)])
(port-count-lines! p)
@ -261,21 +260,6 @@
(open-input-text-editor t))]
[else p])])
(port-count-lines! p) ; in case it's new
(let loop ()
;; Wrap regexp check with `with-handlers' in case the file
;; starts with non-text input
(when (with-handlers ([exn:fail? (lambda (x) #f)])
(regexp-match-peek #rx"^#!" p))
;; Throw away chars/specials up to eol,
;; and continue if line ends in backslash
(let lloop ([prev #f])
(let ([c (read-char-or-special p)])
(if (or (eof-object? c)
(eq? c #\return)
(eq? c #\newline))
(when (eq? prev #\\)
(loop))
(lloop c))))))
(values p filename))))
(define (open-input-graphical-file filename)

2
collects/mrlib/name-message.ss
View File

@ -156,7 +156,7 @@
(when (and (> w 5) (> h 5))
(draw-button-label dc label 0 0 w h mouse-over? mouse-grabbed? font))]))))
(super-new [style '(transparent)])
(super-new [style '(transparent no-focus)])
(update-min-sizes)
(stretchable-width #f)
(stretchable-height #f)))

1
collects/mzlib/compile.ss
View File

@ -25,7 +25,6 @@
void
(lambda ()
(port-count-lines! in)
(strip-shell-command-start in)
(with-handlers ([void
(lambda (exn)
(with-handlers ([void void])

5
collects/mzlib/foreign.ss
View File

@ -56,14 +56,15 @@
...))]))))])))))
(provide* ctype-sizeof ctype-alignof compiler-sizeof
malloc free end-stubborn-change
(unsafe malloc) (unsafe free) end-stubborn-change
cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!)
ctype? make-ctype make-cstruct-type make-sized-byte-string
_void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64
_fixint _ufixint _fixnum _ufixnum
_float _double _double*
_bool _pointer _scheme _fpointer
(unsafe memcpy) (unsafe memmove) (unsafe memset))
(unsafe memcpy) (unsafe memmove) (unsafe memset)
(unsafe malloc-immobile-cell) (unsafe free-immobile-cell))
(define-syntax define*
(syntax-rules ()

11
collects/mztake/load-sandbox.ss
View File

@ -76,17 +76,6 @@
(open-input-text-editor t))]
[else p])])
(port-count-lines! p)
(let loop ()
(when (with-handlers ([exn:fail? (lambda (x) #f)])
(regexp-match-peek "^#!" p))
(let lloop ([prev #f])
(let ([c (read-char-or-special p)])
(if (or (eof-object? c)
(eq? c #\return)
(eq? c #\newline))
(when (eq? prev #\\)
(loop))
(lloop c))))))
(values p filename))))

18
collects/scribble/eval.ss
View File

@ -17,6 +17,7 @@
defs+int
examples
defexamples
as-examples
current-int-namespace
eval-example-string
@ -150,6 +151,10 @@
(vector-set! v2 i (copy-value (vector-ref v i) ht))
(loop i))))
v2)]
[(box? v) (let ([v2 (box #f)])
(hash-table-put! ht v v2)
(set-box! v2 (copy-value (unbox v) ht))
v2)]
[else v]))
(define (strip-comments s)
@ -209,12 +214,15 @@
(make-paragraph null))))
(define-syntax (schemedefinput* stx)
(syntax-case stx (eval-example-string define)
(syntax-case stx (eval-example-string define define-struct)
[(_ (eval-example-string s))
#'(schemeinput* (eval-example-string s))]
[(_ (define . rest))
(syntax-case stx ()
[(_ e) #'(defspace (schemeblock e))])]
[(_ (define-struct . rest))
(syntax-case stx ()
[(_ e) #'(defspace (schemeblock e))])]
[(_ (code:line (define . rest) . rest2))
(syntax-case stx ()
[(_ e) #'(defspace (schemeblock e))])]
@ -266,5 +274,11 @@
(define-syntax defexamples
(syntax-rules ()
[(_ e ...)
(titled-interaction example-title schemedefinput* e ...)])))
(titled-interaction example-title schemedefinput* e ...)]))
(define (as-examples t)
(make-table #f
(list
(list example-title)
(list (make-flow (list t)))))))

8
collects/scribble/manual.ss
View File

@ -54,10 +54,12 @@
(let ([s (apply string-append
(map (lambda (s) (if (string=? s "\n") " " s))
strs))])
(let ([spaces (regexp-match-positions #rx"^ *" s)])
(let ([spaces (regexp-match-positions #rx"^ *" s)]
[end-spaces (regexp-match-positions #rx" *$" s)])
(make-element "schemeinput"
(list (hspace (cdar spaces))
(make-element 'tt (list (substring s (cdar spaces)))))))))
(make-element 'tt (list (substring s (cdar spaces) (caar end-spaces))))
(hspace (- (cdar end-spaces) (caar end-spaces))))))))
(define (verbatim s)
(let ([strs (regexp-split #rx"\n" s)])
@ -134,7 +136,7 @@
var svar void-const)
(define (void-const)
"void")
(schemefont "#<void>"))
(define dots0
(make-element #f (list "...")))

12
collects/scribble/scheme.ss
View File

@ -248,6 +248,12 @@
p-color)
(set! src-col (+ src-col 1))
(hash-table-put! col-map src-col dest-col))]
[(box? (syntax-e c))
(advance c init-line!)
(out "#&" value-color)
(set! src-col (+ src-col 2))
(hash-table-put! col-map src-col dest-col)
((loop init-line! +inf.0) (unbox (syntax-e c)))]
[(hash-table? (syntax-e c))
(advance c init-line!)
(let ([equal-table? (hash-table? (syntax-e c) 'equal)])
@ -444,5 +450,11 @@
(cons a b)
(list #f 1 col (+ 1 col)
(+ 2 sep (syntax-span a) (syntax-span b)))))]
[(box? v)
(let ([a (syntax-ize (unbox v) (+ col 2))])
(datum->syntax-object #f
(box a)
(list #f 1 col (+ 1 col)
(+ 2 (syntax-span a)))))]
[else
(datum->syntax-object #f v (list #f 1 col (+ 1 col) 1))])))

21
collects/scribblings/guide/boxes.scrbl Normal file
View File

@ -0,0 +1,21 @@
#reader(lib "docreader.ss" "scribble")
@require[(lib "manual.ss" "scribble")]
@require[(lib "eval.ss" "scribble")]
@require["guide-utils.ss"]
@title[#:tag "boxes"]{Boxes}
A @defterm{box} is like a single-element vector. It prints as
@schemefont{#&} followed by the printed form of the boxed value. A
@schemefont{#&} form can also be used as an expression, but since the
resulting box is constant, it has practically no use.
@examples[
(define b (box "apple"))
b
(unbox b)
(set-box! b '(banana boat))
b
]
@refdetails["mz:boxes"]{boxes and box procedures}

7
collects/scribblings/guide/data.scrbl
View File

@ -8,9 +8,7 @@
The @seclink["to-scheme"]{little Scheme section} introduced some of
Scheme's built-in datatype: numbers, booleans, strings, lists, and
procedures. This section provides a more complete coverage of the
built-in datatypes, and also introduces the @scheme[define-struct]
form for creating your own datatypes. We defer a discussion of the
class-based object system to @secref["classes"].
built-in datatypes for simple forms of data.
@local-table-of-contents[]
@ -23,3 +21,6 @@ class-based object system to @secref["classes"].
@include-section["pairs.scrbl"]
@include-section["vectors.scrbl"]
@include-section["hash-tables.scrbl"]
@include-section["keywords.scrbl"]
@include-section["boxes.scrbl"]
@include-section["void-and-undef.scrbl"]

145
collects/scribblings/guide/define-struct.scrbl Normal file
View File

@ -0,0 +1,145 @@
#reader(lib "docreader.ss" "scribble")
@require[(lib "manual.ss" "scribble")]
@require[(lib "eval.ss" "scribble")]
@require[(lib "bnf.ss" "scribble")]
@require["guide-utils.ss"]
@title{Programmer-Defined Datatypes}
This section introduces the @scheme[define-struct] form for creating
your own datatypes. The class-based object system offers an alternate
mechanism for creating new datatypes; the resulting objects are
nevertheless implemented as structures, and we defer discussion of
objects to @secref["classes"].
@; ------------------------------------------------------------
@section{Simple Structure Types}
To a first approximation, the syntax of @scheme[define-struct] is
@schemeblock[
(define-struct _struct-id (_field-id ...))
]
Such a definition binds @scheme[_struct-id], but only to static
information about the structure type that cannot be used directly:
@def+int[
(define-struct posn (x y))
posn
]
We explain one use of the @scheme[_struct-id] binding in the next
section.
In addition to defining @scheme[_struct-id], however,
@scheme[define-struct] also defines a number of procedures whose names
are built from @scheme[_struct-id] and the @scheme[_field-id]s:
@itemize{
@item{@schemeidfont{make-}@scheme[_struct-id] : a
@defterm{constructor} procedure that takes as many arguments as
the number of @scheme[_field-id]s, and returns an instance of
the structure type.
@examples[(make-posn 1 2)]}
@item{@scheme[_struct-id]@schemeidfont{?} : a @defterm{predicate}
procedure that takes a single argument and returns @scheme[#t]
if it is an instance of the structure type, @scheme[#f]
otherwise.
@examples[(posn? 3) (posn? (make-posn 1 2))]}
@item{@scheme[_struct-id]@schemeidfont{-}@scheme[_field-id] : for
each @scheme[_field-id], an @defterm{accessor} that extracts
the value of the corresponding field from an instance of the
structure type.
@examples[(posn-x (make-posn 1 2)) (posn-y (make-posn 1 2))]}
@item{@schemeidfont{set-}@scheme[_struct-id]@schemeidfont{-}@scheme[_field-id]@schemeidfont{!} : for
each @scheme[_field-id], a @defterm{mutator} that sets
the value of the corresponding field in an instance of the
structure type.
@examples[(define p (make-posn 1 2))
(posn-x p)
(set-posn-x! p 10)
(posn-x p)]}
}
A @scheme[define-struct] form places no constraints on the kinds of
values that can appears for fields in an instance of the structure
type. For example, @scheme[(make-posn "apple" #f)] produces an
instance of @scheme[posn], even though @scheme["apple"] and
@scheme[#f] are not valid co-ordinates for the obvious uses of
@scheme[posn] instances. Enforcing constraints on field values, such
as requiring them to be numbers, is the job of a contract, as
discussed later in @secref["contracts"].
@; ------------------------------------------------------------
@section{Structure Subtypes}
An extended form of @scheme[defin-struct] can be used to define a
@defterm{structure subtype}, which is a structure type that extends an
existing structure type:
@schemeblock[
(define-struct (_struct-id _super-id) (_field-id ...))
]
The @scheme[_super-id] must be a structure type name bound by
@scheme[define-struct] (i.e., the name bound by @scheme[define-struct]
that cannot be used directly as an expression).
@as-examples[@schemeblock+eval[
(define-struct posn (x y))
(define-struct (3d-posn posn) (z))
]]
A structure subtype inherits the fields of its supertype, and the
subtype constructor accepts the values for the subtype fields after
values for the supertype fields. An instance of a structure subtype
can be used with the predicate, accessor, and mutator fields of the
supertype.
@examples[
(define p (make-3d-posn 1 2 3))
p
(posn? p)
(posn-x p)
(3d-posn-z p)
]
@; ------------------------------------------------------------
@section{Opaque versus Transparent Stucture Types}
With a structure type definition like
@schemeblock[
(define-struct posn (x y))
]
an instance of the structure type prints in a way that does not show
any information about the fields values. That is, structure types by
default are @defterm{opaque}. If the accessors and mutators of a
structure type are kept private to a module, then no other module can
rely on the representation of the type's instances.
To make a structure type @defterm{transparent}, use the
@scheme[#:inspector] keyword with the value @scheme[#f] after the
field-name sequence:
@def+int[
(define-struct posn (x y)
#f)
(make-posn 1 2)
]
An instance of a transparent structure type prints like a vector, and
it shows the content of the structure's fields. A transparent
structure type allows allows reflective operations like
@scheme[struct?] and @scheme[struct-info] to be used on its
instances (see @secref["reflection"]).

4
collects/scribblings/guide/guide-utils.ss
View File

@ -33,7 +33,3 @@
(define (refsecref s)
(make-element #f (list (secref s) " in " MzScheme))))

2
collects/scribblings/guide/guide.scrbl
View File

@ -24,7 +24,7 @@ precise details to @|MzScheme| and other reference manuals.
@include-section["data.scrbl"]
@section{Programmer-Defined Datatypes}
@include-section["define-struct.scrbl"]
@; ----------------------------------------------------------------------
@section[#:tag "scheme-forms"]{Programs and Expressions}

18
collects/scribblings/guide/hash-tables.scrbl
View File

@ -9,7 +9,7 @@ A @defterm{hash table} implements a maping from keys to values, where
both keys can values can be arbitrary Scheme values, and access and
update to the tabel are normally constant-time operations. Keys are
compared using @scheme[equal?] or @scheme[eq?], depending on whether
the hash table is created with @scheme['equal] or @scheme['eq].
the hash table is created with the @scheme['equal] flag.
@examples[
(define ht (make-hash-table 'equal))
@ -35,7 +35,7 @@ key--value pair. Literal hash tables are immutable.
@refdetails["mz:parse-hashtable"]{the syntax of hash table literals}
A hash table can optionally retain its keys @defterm{weakly}, so the
A hash table can optionally retain its keys @defterm{weakly}, so each
mapping is retained only so long as the key is retained elsewhere.
@examples[
@ -45,12 +45,12 @@ mapping is retained only so long as the key is retained elsewhere.
(eval:alts (hash-table-count ht) 0)
]
Beware that a weak hash table retains its values strongly, as long as
the corresponding key is accessible. This creates a catch-22
dependency in the case that a value refers back to its key, so that
the mapping is retained permanently. To break the cycle, map the key
to an @seclink["ephemerons"]{ephemeron} that pair the value with its
key (in addition to the implicit pairing of the hash table).
Beware that even a weak hash table retains its values strongly, as
long as the corresponding key is accessible. This creates a catch-22
dependency when a value refers back to its key, so that the mapping is
retained permanently. To break the cycle, map the key to an
@seclink["ephemerons"]{ephemeron} that pair the value with its key (in
addition to the implicit pairing of the hash table).
@examples[
(define ht (make-hash-table 'weak))
@ -67,3 +67,5 @@ key (in addition to the implicit pairing of the hash table).
(collect-garbage)
(eval:alts (hash-table-count ht) 0)
]
@refdetails["mz:hashtables"]{hash tables and hash-table procedures}

7
collects/scribblings/guide/keywords.scrbl Normal file
View File

@ -0,0 +1,7 @@
#reader(lib "docreader.ss" "scribble")
@require[(lib "manual.ss" "scribble")]
@require[(lib "eval.ss" "scribble")]
@require["guide-utils.ss"]
@title[#:tag "keywords"]{Keywords}

43
collects/scribblings/guide/void-and-undef.scrbl Normal file
View File

@ -0,0 +1,43 @@
#reader(lib "docreader.ss" "scribble")
@require[(lib "manual.ss" "scribble")]
@require[(lib "eval.ss" "scribble")]
@require["guide-utils.ss"]
@title[#:tag "void+undefined"]{Void and Undefined}
Some procedures or expression forms have no need for a result
value. For example, the @scheme[display] procedure is called only for
the side-effect of writing output. In such cases the reslt value is
normally a special constant that prints as @void-const[]. When the
result of an expression is simply @void-const[], the REPL does not
print anything.
The @scheme[void] procedure takes any number of arguments and returns
@void-const[]. (That is, the identifier @schemeidfont{void} is bound
to a procedure that returns @void-const[], instead of being bound
directly to @void-const[].)
@examples[
(void)
(void 1 2 3)
(list (void))
]
A constant that prints as @schemefont{#<undefined>} is used as the
result of a reference to a local binding when the binding is not yet
initialized. Such early references are not possible for bindings that
corerspond to procedure arguments, @scheme[let] bindings, or
@scheme[let*] bindings; early reference requires a recursive binding
context, such as @scheme[letrec] or local @scheme[define]s in a
procedure body. Also, early references to top-level and module
top-level bindings raise an exception, instead of producing
@schemefont{#<undefined>}. For these reasons,
@schemefont{#<undefined>} rarely appears.
@def+int[
(define (strange)
(define x x)
x)
(strange)
]

9
collects/scribblings/reference/read.scrbl
View File

@ -127,6 +127,8 @@ on the next character or characters in the input stream as follows:
@dispatch[@litchar["#|"]]{starts a block comment; see @secref["mz:parse-comment"]}
@dispatch[@litchar["#;"]]{starts an S-expression comment; see @secref["mz:parse-comment"]}
@dispatch[@litchar{#,}]{starts a syntax quote; see @secref["mz:parse-quote"]}
@dispatch[@litchar["#! "]]{starts a line comment; see @secref["mz:parse-comment"]}
@dispatch[@litchar["#!/"]]{starts a line comment; see @secref["mz:parse-comment"]}
@dispatch[@litchar{#`}]{starts a syntax quasiquote; see @secref["mz:parse-quote"]}
@dispatch[@litchar{#,}]{starts an syntax unquote or splicing unquote; see @secref["mz:parse-quote"]}
@dispatch[@litchar["#~"]]{starts compiled code; see @secref["compilation"]}
@ -500,12 +502,19 @@ encounters @litchar{#;}, it recursively reads one datum, and then
discards the datum (continuing on to the next datum for the read
result).
A @litchar{#! } (which is @litchar{#!} followed by a space) or
@litchar{#!/} starts a line comment that can be continued to the next
line by ending a line with @litchar["\\"]. This form of comment
normally appears at the beginning of a Unix script file.
@reader-examples
[
"; comment"
"#| a |# 1"
"#| #| a |# 1 |# 2"
"#;1 2"
"#!/bin/sh"
"#! /bin/sh"
]
@subsection[#:tag "mz:parse-vector"]{Reading Vectors}

8
collects/syntax-color/scheme-lexer.ss
View File

@ -105,8 +105,8 @@
[radix10 (:or "#d" "#D")]
[radix16 (:or "#x" "#X")]
[script (:: "#!" (:* (:~ #\newline) (:: #\\ #\newline)))]
[script (:: "#!" (:or #\space #\/) (:* (:~ #\newline) (:: #\\ #\newline)))]
[identifier-delims (:or (char-set "\",'`()[]{};") scheme-whitespace)]
[identifier-chars (:~ identifier-delims "\\" "|")]
[identifier-escapes (:or (:: "\\" any-char)
@ -273,6 +273,8 @@
["#;"
(ret lexeme 'sexp-comment #f start-pos end-pos)]
["#|" (read-nested-comment 1 start-pos input-port)]
[script
(ret lexeme 'comment #f start-pos end-pos)]
[(:: (:or "" "#hash" "#hasheq" (:: "#" (:* digit10))) "(")
(ret lexeme 'parenthesis '|(| start-pos end-pos)]
[(:: (:or "" "#hash" "#hasheq" (:: "#" (:* digit10))) "[")
@ -283,7 +285,7 @@
(ret lexeme 'parenthesis (string->symbol lexeme) start-pos end-pos)]
[(:or "'" "`" "#'" "#`" "#&")
(ret lexeme 'constant #f start-pos end-pos)]
[(:or script sharing reader-command "." "," ",@" "#," "#,@")
[(:or sharing reader-command "." "," ",@" "#," "#,@")
(ret lexeme 'other #f start-pos end-pos)]
[identifier
(ret lexeme 'symbol #f start-pos end-pos)]

2
collects/syntax/modcode.ss
View File

@ -40,7 +40,7 @@
(define (read-one path src?)
(let ([p ((moddep-current-open-input-file) path)])
(when src? (port-count-lines! p) (strip-shell-command-start p))
(when src? (port-count-lines! p))
(dynamic-wind
void
(lambda ()

10
collects/tests/mzscheme/optimize.ss
View File

@ -424,6 +424,16 @@
(quote-syntax no!))
''ok)
(test-comp '(values 10)
10)
(test-comp '(let ([x (values 10)])
(values x))
10)
(test-comp '(let ([x (random)])
(values x))
'(let ([x (random)])
x))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check bytecode verification of lifted functions

26
collects/tests/mzscheme/read.ss
View File

@ -956,6 +956,32 @@
(err/rt-test (read/recursive (open-input-string ";") #\. #f) exn:fail:read?)
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Some hash-table reading trickyness with readtables
(test #hash((apple . (red round))
(banana . (yellow long)))
values
(parameterize ([current-readtable
(make-readtable #f
#\! 'terminating-macro (lambda (ch port . args)
(read/recursive port)))])
(read (open-input-string
"!#hash((apple . (red round)) (banana . (yellow long)))"))))
(test #hash((apple . (red round))
(banana . (yellow long)))
values
(parameterize ([current-readtable
(make-readtable #f
#\! 'terminating-macro (lambda (ch port . args)
(read/recursive port))
#\* 'terminating-macro (lambda args
(make-special-comment #f)))])
(read (open-input-string
"!#hash((apple . (red round)) * (banana . (yellow long)))"))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(report-errs)

6
doc/release-notes/mred/HISTORY
View File

@ -1,3 +1,9 @@
Version 370.2
Added 'no-focus style for canvas%
----------------------------------------------------------------------
Version 370, May 2007
WXME file format changed to include a #reader() prefix

7
doc/release-notes/mzscheme/HISTORY
View File

@ -1,3 +1,10 @@
Version 370.2
Added make-sibling-inspector
Added graph? argument to read[-syntax]/recursive
Changed `#! ' and `#!/' to general comment forms
Inside MzScheme: GC_{malloc,free}_immobile_box
foreign.ss: added {malloc,free}-immobile-box
Version 370, May 2007
Memory management:
Default build uses 3m instead of CGC

29
src/foreign/foreign.c
View File

@ -1828,6 +1828,31 @@ static Scheme_Object *foreign_free(int argc, Scheme_Object *argv[])
return scheme_void;
}
/* (malloc-immobile-cell v) */
#undef MYNAME
#define MYNAME "malloc-immobile-cell"
static Scheme_Object *foreign_malloc_immobile_cell(int argc, Scheme_Object *argv[])
{
return scheme_make_foreign_cpointer(scheme_malloc_immobile_box(argv[0]));
}
/* (free-immobile-cell b) */
#undef MYNAME
#define MYNAME "free-immobile-cell"
static Scheme_Object *foreign_free_immobile_cell(int argc, Scheme_Object *argv[])
{
void *ptr;
long poff;
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_free_immobile_box((void **)W_OFFSET(ptr, poff));
return scheme_void;
}
#define C_LONG_TYPE_STR "exact integer that fits a C long"
/* (ptr-add cptr offset-k [type])
@ -2631,6 +2656,10 @@ void scheme_init_foreign(Scheme_Env *env)
scheme_make_prim_w_arity(foreign_end_stubborn_change, "end-stubborn-change", 1, 1), menv);
scheme_add_global("free",
scheme_make_prim_w_arity(foreign_free, "free", 1, 1), menv);
scheme_add_global("malloc-immobile-cell",
scheme_make_prim_w_arity(foreign_malloc_immobile_cell, "malloc-immobile-cell", 1, 1), menv);
scheme_add_global("free-immobile-cell",
scheme_make_prim_w_arity(foreign_free_immobile_cell, "free-immobile-cell", 1, 1), menv);
scheme_add_global("ptr-add",
scheme_make_prim_w_arity(foreign_ptr_add, "ptr-add", 2, 3), menv);
scheme_add_global("ptr-add!",

21
src/foreign/foreign.ssc
View File

@ -1307,6 +1307,27 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta,
return scheme_void;
}
/* (malloc-immobile-cell v) */
{:(cdefine malloc-immobile-cell 1):}
{
return scheme_make_foreign_cpointer(scheme_malloc_immobile_box(argv[0]));
}
/* (free-immobile-cell b) */
{:(cdefine free-immobile-cell 1):}
{
void *ptr;
long poff;
if (!SCHEME_FFIANYPTRP(argv[0]))
scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv);
ptr = SCHEME_FFIANYPTR_VAL(argv[0]);
poff = SCHEME_FFIANYPTR_OFFSET(argv[0]);
if ((ptr == NULL) && (poff == 0))
scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv);
scheme_free_immobile_box((void **)W_OFFSET(ptr, poff));
return scheme_void;
}
#define C_LONG_TYPE_STR "exact integer that fits a C long"
/* (ptr-add cptr offset-k [type])

6
src/mred/wxs/wxs_cnvs.cxx
View File

@ -85,6 +85,7 @@ static Scheme_Object *canvasStyle_wxNO_AUTOCLEAR_sym = NULL;
static Scheme_Object *canvasStyle_wxINVISIBLE_sym = NULL;
static Scheme_Object *canvasStyle_wxTRANSPARENT_WIN_sym = NULL;
static Scheme_Object *canvasStyle_wxRESIZE_CORNER_sym = NULL;
static Scheme_Object *canvasStyle_wxNEVER_FOCUS_sym = NULL;
static void init_symset_canvasStyle(void) {
REMEMBER_VAR_STACK();
@ -108,12 +109,14 @@ static void init_symset_canvasStyle(void) {
canvasStyle_wxTRANSPARENT_WIN_sym = WITH_REMEMBERED_STACK(scheme_intern_symbol("transparent"));
wxREGGLOB(canvasStyle_wxRESIZE_CORNER_sym);
canvasStyle_wxRESIZE_CORNER_sym = WITH_REMEMBERED_STACK(scheme_intern_symbol("resize-corner"));
wxREGGLOB(canvasStyle_wxNEVER_FOCUS_sym);
canvasStyle_wxNEVER_FOCUS_sym = WITH_REMEMBERED_STACK(scheme_intern_symbol("no-focus"));
}
static int unbundle_symset_canvasStyle(Scheme_Object *v, const char *where) {
SETUP_VAR_STACK(1);
VAR_STACK_PUSH(0, v);
if (!canvasStyle_wxRESIZE_CORNER_sym) WITH_VAR_STACK(init_symset_canvasStyle());
if (!canvasStyle_wxNEVER_FOCUS_sym) WITH_VAR_STACK(init_symset_canvasStyle());
Scheme_Object *i INIT_NULLED_OUT, *l = v;
long result = 0;
while (SCHEME_PAIRP(l)) {
@ -129,6 +132,7 @@ static int unbundle_symset_canvasStyle(Scheme_Object *v, const char *where) {
else if (i == canvasStyle_wxINVISIBLE_sym) { result = result | wxINVISIBLE; }
else if (i == canvasStyle_wxTRANSPARENT_WIN_sym) { result = result | wxTRANSPARENT_WIN; }
else if (i == canvasStyle_wxRESIZE_CORNER_sym) { result = result | wxRESIZE_CORNER; }
else if (i == canvasStyle_wxNEVER_FOCUS_sym) { result = result | wxNEVER_FOCUS; }
else { break; }
l = SCHEME_CDR(l);
}

1
src/mred/wxs/wxs_cnvs.xc
View File

@ -60,6 +60,7 @@ static void wxSetResizeCorner(wxCanvas *c, Bool v)
@SYM "deleted" : wxINVISIBLE
@SYM "transparent" : wxTRANSPARENT_WIN
@SYM "resize-corner" : wxRESIZE_CORNER
@SYM "no-focus" : wxNEVER_FOCUS
@ENDSYMBOLS
@INCLUDE wxs_ornt.xci

8
src/mred/wxs/wxs_dc.cxx
View File

@ -1154,7 +1154,7 @@ static Scheme_Object *os_wxDCGlyphAvailable(int n, Scheme_Object *p[])
} else
x1 = NULL;
DO_OK_CHECK(METHODNAME("dc<%>","glyph-exists?"))
r = WITH_VAR_STACK(((wxDC *)((Scheme_Class_Object *)p[0])->primdata)->GlyphAvailable(x0, x1));
@ -1705,7 +1705,7 @@ static Scheme_Object *os_wxDCGetCharWidth(int n, Scheme_Object *p[])
DO_OK_CHECK(METHODNAME("dc<%>","get-char-width"))
r = WITH_VAR_STACK(((wxDC *)((Scheme_Class_Object *)p[0])->primdata)->GetCharWidth());
@ -1726,7 +1726,7 @@ static Scheme_Object *os_wxDCGetCharHeight(int n, Scheme_Object *p[])
DO_OK_CHECK(METHODNAME("dc<%>","get-char-height"))
r = WITH_VAR_STACK(((wxDC *)((Scheme_Class_Object *)p[0])->primdata)->GetCharHeight());
@ -1766,7 +1766,7 @@ static Scheme_Object *os_wxDCMyTextExtent(int n, Scheme_Object *p[])
} else
x3 = 0;
if (x3 > SCHEME_CHAR_STRLEN_VAL(p[POFFSET+0])) WITH_VAR_STACK(scheme_arg_mismatch(METHODNAME("dc<%>","get-text-extent"), "string index too large: ", p[POFFSET+3]));
if (x3 > SCHEME_CHAR_STRLEN_VAL(p[POFFSET+0])) WITH_VAR_STACK(scheme_arg_mismatch(METHODNAME("dc<%>","get-text-extent"), "string index too large: ", p[POFFSET+3]));DO_OK_CHECK(METHODNAME("dc<%>","get-text-extent"))
r = WITH_VAR_STACK(MyTextExtent(((wxDC *)((Scheme_Class_Object *)p[0])->primdata), x0, x1, x2, x3));

8
src/mred/wxs/wxs_dc.xc
View File

@ -659,9 +659,9 @@ START_XFORM_SKIP;
@INCLUDE wxs_draw.xci
// Also in wxWindow:
@ m "get-text-extent" : void[]/CastToSO//spAnything MyTextExtent(mzstring,wxFont^=NULL,bool=FALSE,nnint=0); : : /CheckStringIndex["get-text-extent".0.3]
@ Q "get-char-height" : double GetCharHeight();
@ Q "get-char-width" : double GetCharWidth();
@ m "get-text-extent" : void[]/CastToSO//spAnything MyTextExtent(mzstring,wxFont^=NULL,bool=FALSE,nnint=0); : : /CheckStringIndex["get-text-extent".0.3]|CheckOk[METHODNAME("dc<%>","get-text-extent")]
@ Q "get-char-height" : double GetCharHeight(); : : /CheckOk[METHODNAME("dc<%>","get-char-height")]
@ Q "get-char-width" : double GetCharWidth(); : : /CheckOk[METHODNAME("dc<%>","get-char-width")]
@MACRO rZERO = return 0;
@MACRO rFALSE = return FALSE;
@ -718,7 +718,7 @@ START_XFORM_SKIP;
@ Q "end-doc" : void EndDoc(); : : /CheckOk[METHODNAME("dc<%>","end-doc-line")]
@ Q "end-page" : void EndPage(); : : /CheckOk[METHODNAME("dc<%>","end-page")]
@ "glyph-exists?" : bool GlyphAvailable(mzchar,wxFont^=NULL)
@ "glyph-exists?" : bool GlyphAvailable(mzchar,wxFont^=NULL) : : /CheckOk[METHODNAME("dc<%>","glyph-exists?")]
@END

2
src/mzscheme/include/mzscheme.exp
View File

@ -181,6 +181,8 @@ scheme_remove_all_finalization
scheme_dont_gc_ptr
scheme_gc_ptr_ok
scheme_collect_garbage
scheme_malloc_immobile_box
scheme_free_immobile_box
scheme_make_bucket_table
scheme_add_to_table
scheme_change_in_table

2
src/mzscheme/include/mzscheme3m.exp
View File

@ -191,6 +191,8 @@ GC_register_traversers
GC_resolve
GC_mark
GC_fixup
scheme_malloc_immobile_box
scheme_free_immobile_box
scheme_make_bucket_table
scheme_add_to_table
scheme_change_in_table

2
src/mzscheme/include/mzwin.def
View File

@ -169,6 +169,8 @@ EXPORTS
scheme_dont_gc_ptr
scheme_gc_ptr_ok
scheme_collect_garbage
scheme_malloc_immobile_box
scheme_free_immobile_box
scheme_make_bucket_table
scheme_add_to_table
scheme_change_in_table

2
src/mzscheme/include/mzwin3m.def
View File

@ -183,6 +183,8 @@ EXPORTS
GC_resolve
GC_mark
GC_fixup
scheme_malloc_immobile_box
scheme_free_immobile_box
scheme_make_bucket_table
scheme_add_to_table
scheme_change_in_table

2
src/mzscheme/src/builtin.c
View File

@ -47,7 +47,7 @@ Scheme_Object *scheme_eval_compiled_sized_string_with_magic(const char *str, int
if (!env)
env = scheme_get_env(NULL);
expr = scheme_internal_read(port, NULL, 1, 1, 0, 0, -1, NULL,
expr = scheme_internal_read(port, NULL, 1, 1, 0, 0, 0, -1, NULL,
magic_sym, magic_val,
NULL);

6725
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

14
src/mzscheme/src/eval.c
View File

@ -775,7 +775,8 @@ void *scheme_enlarge_runstack(long size, void *(*k)())
int scheme_omittable_expr(Scheme_Object *o, int vals)
/* Checks whether the bytecode `o' returns `vals' values with no
side-effects. -1 for vals means that any return count is ok. */
side-effects and without pushing and using continuation marks.
-1 for vals means that any return count is ok. */
{
Scheme_Type vtype;
@ -2291,8 +2292,13 @@ static Scheme_Object *optimize_application2(Scheme_Object *o, Optimize_Info *inf
if (le)
return le;
}
info->size += 1;
if (SAME_OBJ(scheme_values_func, app->rator)
&& scheme_omittable_expr(app->rand, 1)) {
info->preserves_marks = 1;
info->single_result = 1;
return app->rand;
}
info->preserves_marks = !!(rator_flags & CLOS_PRESERVES_MARKS);
info->single_result = !!(rator_flags & CLOS_SINGLE_RESULT);
@ -7376,7 +7382,7 @@ Scheme_Object *scheme_load_compiled_stx_string(const char *str, long len)
port = scheme_make_sized_byte_string_input_port(str, -len);
expr = scheme_internal_read(port, NULL, 1, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
expr = scheme_internal_read(port, NULL, 1, 0, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
expr = _scheme_eval_compiled(expr, scheme_get_env(NULL));

53
src/mzscheme/src/portfun.c
View File

@ -364,7 +364,7 @@ scheme_init_port_fun(Scheme_Env *env)
scheme_add_global_constant("read/recursive",
scheme_make_noncm_prim(read_recur_f,
"read/recursive",
0, 3),
0, 4),
env);
scheme_add_global_constant("read-syntax",
scheme_make_noncm_prim(read_syntax_f,
@ -374,7 +374,7 @@ scheme_init_port_fun(Scheme_Env *env)
scheme_add_global_constant("read-syntax/recursive",
scheme_make_noncm_prim(read_syntax_recur_f,
"read-syntax/recursive",
0, 4),
0, 5),
env);
scheme_add_global_constant("read-honu",
scheme_make_noncm_prim(read_honu_f,
@ -3039,10 +3039,11 @@ static Scheme_Object *sch_default_read_handler(void *ignore, int argc, Scheme_Ob
else
src = NULL;
return scheme_internal_read(argv[0], src, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
return scheme_internal_read(argv[0], src, -1, 0, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
}
static int extract_recur_args(const char *who, int argc, Scheme_Object **argv, int delta, Scheme_Object **_readtable)
static int extract_recur_args(const char *who, int argc, Scheme_Object **argv, int delta,
Scheme_Object **_readtable, int *_recur_graph)
{
int pre_char = -1;
@ -3059,6 +3060,9 @@ static int extract_recur_args(const char *who, int argc, Scheme_Object **argv, i
scheme_wrong_type(who, "readtable or #f", delta + 2, argc, argv);
}
*_readtable = readtable;
if (argc > delta + 3) {
*_recur_graph = SCHEME_TRUEP(argv[delta + 3]);
}
}
}
@ -3068,7 +3072,7 @@ static int extract_recur_args(const char *who, int argc, Scheme_Object **argv, i
static Scheme_Object *do_read_f(const char *who, int argc, Scheme_Object *argv[], int honu_mode, int recur)
{
Scheme_Object *port, *readtable = NULL;
int pre_char = -1;
int pre_char = -1, recur_graph = recur;
Scheme_Input_Port *ip;
if (argc && !SCHEME_INPUT_PORTP(argv[0]))
@ -3080,7 +3084,7 @@ static Scheme_Object *do_read_f(const char *who, int argc, Scheme_Object *argv[]
port = CURRENT_INPUT_PORT(scheme_current_config());
if (recur && !honu_mode) {
pre_char = extract_recur_args(who, argc, argv, 0, &readtable);
pre_char = extract_recur_args(who, argc, argv, 0, &readtable, &recur_graph);
}
ip = scheme_input_port_record(port);
@ -3093,7 +3097,9 @@ static Scheme_Object *do_read_f(const char *who, int argc, Scheme_Object *argv[]
if (port == scheme_orig_stdin_port)
scheme_flush_orig_outputs();
return scheme_internal_read(port, NULL, -1, 0, honu_mode, recur, pre_char, readtable,
return scheme_internal_read(port, NULL, -1, 0, honu_mode,
recur_graph, recur,
pre_char, readtable,
NULL, NULL, NULL);
}
}
@ -3121,7 +3127,7 @@ static Scheme_Object *read_honu_recur_f(int argc, Scheme_Object *argv[])
static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object *argv[], int honu_mode, int recur)
{
Scheme_Object *port, *readtable = NULL;
int pre_char = -1;
int pre_char = -1, recur_graph = recur;
Scheme_Input_Port *ip;
if ((argc > 1) && !SCHEME_INPUT_PORTP(argv[1]))
@ -3133,7 +3139,7 @@ static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object
port = CURRENT_INPUT_PORT(scheme_current_config());
if (recur && !honu_mode) {
pre_char = extract_recur_args(who, argc, argv, 1, &readtable);
pre_char = extract_recur_args(who, argc, argv, 1, &readtable, &recur_graph);
}
ip = scheme_input_port_record(port);
@ -3160,7 +3166,9 @@ static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object
if (port == scheme_orig_stdin_port)
scheme_flush_orig_outputs();
return scheme_internal_read(port, src, -1, 0, honu_mode, recur, pre_char, readtable,
return scheme_internal_read(port, src, -1, 0, honu_mode,
recur, recur_graph,
pre_char, readtable,
NULL, NULL, NULL);
}
}
@ -4350,7 +4358,7 @@ static Scheme_Object *do_load_handler(void *data)
Scheme_Env *genv;
int save_count = 0, got_one = 0;
while ((obj = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, -1, NULL,
while ((obj = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, 0, -1, NULL,
NULL, NULL, lhd->delay_load_info))
&& !SCHEME_EOFP(obj)) {
save_array = NULL;
@ -4428,7 +4436,7 @@ static Scheme_Object *do_load_handler(void *data)
}
/* Check no more expressions: */
d = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
d = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
if (!SCHEME_EOFP(d)) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(port);
@ -4504,7 +4512,7 @@ static Scheme_Object *do_load_handler(void *data)
static Scheme_Object *default_load(int argc, Scheme_Object *argv[])
{
Scheme_Object *port, *name, *expected_module, *v;
int ch, use_delay_load;
int use_delay_load;
Scheme_Thread *p = scheme_current_thread;
Scheme_Config *config;
LoadHandlerData *lhd;
@ -4539,25 +4547,6 @@ static Scheme_Object *default_load(int argc, Scheme_Object *argv[])
scheme_count_lines(port);
}
/* Skip over #! at beginning of file */
if ((ch = scheme_peek_byte(port)) == '#') {
if ((ch = scheme_peek_byte_skip(port, scheme_make_integer(1), NULL)) == '!') {
int oldch;
scheme_get_byte(port);
scheme_get_byte(port);
eol_loop:
oldch = 0;
while (1) {
ch = scheme_getc(port);
if (ch == EOF || ch == '\n' || ch == '\r')
break;
oldch = ch;
}
if (oldch == '\\')
goto eol_loop;
}
}
config = scheme_current_config();
v = scheme_get_param(config, MZCONFIG_LOAD_DELAY_ENABLED);

61
src/mzscheme/src/read.c
View File

@ -978,8 +978,11 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
return honu_semicolon;
} else {
while (((ch = scheme_getc_special_ok(port)) != '\n') && (ch != '\r')) {
if (ch == EOF)
if (ch == EOF) {
if (comment_mode & RETURN_FOR_COMMENT)
return NULL;
return scheme_eof;
}
if (ch == SCHEME_SPECIAL)
scheme_get_ready_read_special(port, stxsrc, ht);
}
@ -1524,6 +1527,43 @@ read_inner_inner(Scheme_Object *port, Scheme_Object *stxsrc, Scheme_Hash_Table *
}
}
break;
case '!':
ch = scheme_getc_special_ok(port);
if ((ch == ' ') || (ch == '/')) {
/* line comment, with '\' as a continuation */
int was_backslash = 0, was_backslash_cr = 0, prev_backslash_cr;
while(1) {
prev_backslash_cr = was_backslash_cr;
was_backslash_cr = 0;
ch = scheme_getc_special_ok(port);
if (ch == EOF) {
break;
} else if (ch == SCHEME_SPECIAL) {
scheme_get_ready_read_special(port, stxsrc, ht);
} else if (ch == '\r') {
if (was_backslash) {
was_backslash_cr = 1;
} else
break;
} else if (ch == '\n') {
if (!was_backslash && !was_backslash_cr)
break;
}
was_backslash = (ch == '\\');
}
if (comment_mode & RETURN_FOR_COMMENT)
return NULL;
goto start_over;
} else {
if (NOT_EOF_OR_SPECIAL(ch))
scheme_read_err(port, stxsrc, line, col, pos, 3,
ch, indentation, "read: bad syntax `#!%c'", ch);
else
scheme_read_err(port, stxsrc, line, col, pos, 2,
ch, indentation, "read: bad syntax `#!'", ch);
return NULL;
}
break;
default:
if (!params->honu_mode) {
int vector_length = -1;
@ -1901,7 +1941,7 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
Scheme_Object *
_scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int honu_mode,
int recur, int extra_char, Scheme_Object *init_readtable,
int recur, int expose_comment, int extra_char, Scheme_Object *init_readtable,
Scheme_Object *magic_sym, Scheme_Object *magic_val,
Scheme_Object *delay_load_info)
{
@ -1972,7 +2012,7 @@ _scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int h
do {
v = read_inner_inner(port, stxsrc, ht, scheme_null, &params,
(RETURN_FOR_HASH_COMMENT
| (recur ? (RETURN_FOR_COMMENT | RETURN_FOR_SPECIAL_COMMENT) : 0)),
| (expose_comment ? (RETURN_FOR_COMMENT | RETURN_FOR_SPECIAL_COMMENT) : 0)),
extra_char,
(init_readtable
? (SCHEME_FALSEP(init_readtable)
@ -1996,7 +2036,7 @@ _scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int h
*ht = NULL;
}
if (!v && recur) {
if (!v && expose_comment) {
/* Return to indicate comment: */
v = scheme_alloc_small_object();
v->type = scheme_special_comment_type;
@ -2054,13 +2094,14 @@ static void *scheme_internal_read_k(void)
}
return (void *)_scheme_internal_read(port, stxsrc, p->ku.k.i1, p->ku.k.i2,
p->ku.k.i3, p->ku.k.i4, init_readtable,
p->ku.k.i3 & 0x2, p->ku.k.i3 & 0x1,
p->ku.k.i4, init_readtable,
magic_sym, magic_val, delay_load_info);
}
Scheme_Object *
scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail, int honu_mode,
int recur, int pre_char, Scheme_Object *init_readtable,
int recur, int expose_comment, int pre_char, Scheme_Object *init_readtable,
Scheme_Object *magic_sym, Scheme_Object *magic_val,
Scheme_Object *delay_load_info)
{
@ -2074,7 +2115,7 @@ scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int ca
scheme_alloc_list_stack(p);
if (cantfail) {
return _scheme_internal_read(port, stxsrc, crc, honu_mode, recur, -1, NULL,
return _scheme_internal_read(port, stxsrc, crc, honu_mode, recur, expose_comment, -1, NULL,
magic_sym, magic_val, delay_load_info);
} else {
if (magic_sym)
@ -2084,7 +2125,7 @@ scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int ca
p->ku.k.p2 = (void *)stxsrc;
p->ku.k.i1 = crc;
p->ku.k.i2 = honu_mode;
p->ku.k.i3 = recur;
p->ku.k.i3 = ((recur ? 0x2 : 0) | (expose_comment ? 0x1 : 0));
p->ku.k.i4 = pre_char;
p->ku.k.p3 = (void *)init_readtable;
p->ku.k.p4 = (void *)magic_sym;
@ -2096,12 +2137,12 @@ scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int ca
Scheme_Object *scheme_read(Scheme_Object *port)
{
return scheme_internal_read(port, NULL, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
return scheme_internal_read(port, NULL, -1, 0, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
}
Scheme_Object *scheme_read_syntax(Scheme_Object *port, Scheme_Object *stxsrc)
{
return scheme_internal_read(port, stxsrc, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
return scheme_internal_read(port, stxsrc, -1, 0, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
}
Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj, int mkstx)

35
src/mzscheme/src/salloc.c
View File

@ -255,6 +255,41 @@ Scheme_Object *scheme_make_offset_cptr(void *cptr, long offset, Scheme_Object *t
return o;
}
#ifndef MZ_PRECISE_GC
static Scheme_Hash_Table *immobiles;
#endif
void **scheme_malloc_immobile_box(void *p)
{
#ifdef MZ_PRECISE_GC
return GC_malloc_immobile_box(p);
#else
void **b;
if (!immobiles) {
REGISTER_SO(immobiles);
immobiles = scheme_make_hash_table(SCHEME_hash_ptr);
}
b = scheme_malloc(sizeof(void *));
*b = p;
scheme_hash_set(immobiles, (Scheme_Object *)(void *)b, scheme_true);
return b;
#endif
}
void scheme_free_immobile_box(void **b)
{
#ifdef MZ_PRECISE_GC
GC_free_immobile_box(b);
#else
if (immobiles) {
scheme_hash_set(immobiles, (Scheme_Object *)(void *)b, NULL);
}
#endif
}
static void (*save_oom)(void);
static void raise_out_of_memory(void)

3
src/mzscheme/src/schemef.h
View File

@ -385,6 +385,9 @@ MZ_EXTERN void GC_mark(const void *p);
MZ_EXTERN void GC_fixup(void *p);
#endif
MZ_EXTERN void **scheme_malloc_immobile_box(void *p);
MZ_EXTERN void scheme_free_immobile_box(void **b);
/*========================================================================*/
/* hash tables */
/*========================================================================*/

2
src/mzscheme/src/schemex.h
View File

@ -312,6 +312,8 @@ void *(*GC_resolve)(void *p);
void (*GC_mark)(const void *p);
void (*GC_fixup)(void *p);
#endif
void **(*scheme_malloc_immobile_box)(void *p);
void (*scheme_free_immobile_box)(void **b);
/*========================================================================*/
/* hash tables */
/*========================================================================*/

2
src/mzscheme/src/schemex.inc
View File

@ -212,6 +212,8 @@
scheme_extension_table->GC_mark = GC_mark;
scheme_extension_table->GC_fixup = GC_fixup;
#endif
scheme_extension_table->scheme_malloc_immobile_box = scheme_malloc_immobile_box;
scheme_extension_table->scheme_free_immobile_box = scheme_free_immobile_box;
scheme_extension_table->scheme_make_bucket_table = scheme_make_bucket_table;
scheme_extension_table->scheme_add_to_table = scheme_add_to_table;
scheme_extension_table->scheme_change_in_table = scheme_change_in_table;

2
src/mzscheme/src/schemexm.h
View File

@ -212,6 +212,8 @@
#define GC_mark (scheme_extension_table->GC_mark)
#define GC_fixup (scheme_extension_table->GC_fixup)
#endif
#define scheme_malloc_immobile_box (scheme_extension_table->scheme_malloc_immobile_box)
#define scheme_free_immobile_box (scheme_extension_table->scheme_free_immobile_box)
#define scheme_make_bucket_table (scheme_extension_table->scheme_make_bucket_table)
#define scheme_add_to_table (scheme_extension_table->scheme_add_to_table)
#define scheme_change_in_table (scheme_extension_table->scheme_change_in_table)

2
src/mzscheme/src/schminc.h
View File

@ -13,7 +13,7 @@
#define USE_COMPILED_STARTUP 1
#define EXPECTED_PRIM_COUNT 897
#define EXPECTED_PRIM_COUNT 898
#ifdef MZSCHEME_SOMETHING_OMITTED
# undef USE_COMPILED_STARTUP

2
src/mzscheme/src/schpriv.h
View File

@ -1567,7 +1567,7 @@ Scheme_Object *_scheme_apply_to_list (Scheme_Object *rator, Scheme_Object *rands
Scheme_Object *_scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *rands);
Scheme_Object *scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail,
int honu_mode, int recur, int pre_char, Scheme_Object *readtable,
int honu_mode, int recur, int expose_comment, int pre_char, Scheme_Object *readtable,
Scheme_Object *magic_sym, Scheme_Object *magic_val,
Scheme_Object *delay_load_info);
void scheme_internal_display(Scheme_Object *obj, Scheme_Object *port);

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 370
#define MZSCHEME_VERSION_MINOR 1
#define MZSCHEME_VERSION_MINOR 2
#define MZSCHEME_VERSION "370.1" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "370.2" _MZ_SPECIAL_TAG

22
src/mzscheme/src/struct.c
View File

@ -55,6 +55,7 @@ typedef struct {
} Nack_Guard_Evt;
static Scheme_Object *make_inspector(int argc, Scheme_Object *argv[]);
static Scheme_Object *make_sibling_inspector(int argc, Scheme_Object *argv[]);
static Scheme_Object *inspector_p(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_inspector(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_code_inspector(int argc, Scheme_Object *argv[]);
@ -455,6 +456,11 @@ scheme_init_struct (Scheme_Env *env)
"make-inspector",
0, 1),
env);
scheme_add_global_constant("make-sibling-inspector",
scheme_make_prim_w_arity(make_sibling_inspector,
"make-sibling-inspector",
0, 1),
env);
scheme_add_global_constant("inspector?",
scheme_make_prim_w_arity(inspector_p,
"inspector?",
@ -559,6 +565,22 @@ static Scheme_Object *make_inspector(int argc, Scheme_Object **argv)
return scheme_make_inspector(superior);
}
static Scheme_Object *make_sibling_inspector(int argc, Scheme_Object **argv)
{
Scheme_Object *superior;
if (argc) {
superior = argv[0];
if (!SAME_TYPE(SCHEME_TYPE(superior), scheme_inspector_type))
scheme_wrong_type("make-sibling-inspector", "inspector", 0, argc, argv);
} else
superior = scheme_get_param(scheme_current_config(), MZCONFIG_INSPECTOR);
superior = (Scheme_Object *)((Scheme_Inspector *)superior)->superior;
return scheme_make_inspector(superior);
}
static Scheme_Object *inspector_p(int argc, Scheme_Object **argv)
{
return (SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_inspector_type)

1
src/wxmac/include/base/common.h
View File

@ -103,6 +103,7 @@ typedef short int WXTYPE;
#define wxRESIZE_CORNER 0x00200000
#define wxCOMBO_SIDE 0x00400000
#define wxAS_CONTROL 0x00800000
#define wxNEVER_FOCUS 0x01000000
# define wxFLAT 0x00000100

7
src/wxmac/src/mac/wx_canvs.cc
View File

@ -154,7 +154,6 @@ void wxCanvas::InitDefaults(wxGLConfig *gl_cfg)
}
if (!(cStyle & wxFLAT)) {
cStyle |= wxHIDE_MENUBAR;
CreatePaintControl(-1, !(cStyle & wxTRANSPARENT_WIN));
}
@ -734,7 +733,7 @@ void wxCanvas::ClientToLogical(int* x, int* y) // mac platform only; testing
Bool wxCanvas::WantsFocus(void)
{
if (cStyle & wxAS_CONTROL)
if (cStyle & (wxAS_CONTROL | wxNEVER_FOCUS))
return FALSE;
else
return !cHidden;
@ -742,7 +741,9 @@ Bool wxCanvas::WantsFocus(void)
Bool wxCanvas::AcceptsExplicitFocus(void)
{
if (cStyle & wxAS_CONTROL)
if (cStyle & wxNEVER_FOCUS)
return FALSE;
else if (cStyle & wxAS_CONTROL)
return wxAllControlsWantFocus();
else
return wxbCanvas::AcceptsExplicitFocus();

1
src/wxwindow/include/base/common.h
View File

@ -124,6 +124,7 @@ typedef short int WXTYPE;
#define wxHORIZONTAL_LABEL 0x00400000
#define wxTRANSPARENT_WIN 0x00800000
#define wxCOMBO_SIDE 0x04000000
#define wxNEVER_FOCUS 0x01000000
enum {
// Text font families

2
src/wxwindow/include/msw/wx_canvs.h
View File

@ -70,6 +70,8 @@ class wxCanvas: public wxbCanvas
virtual void GetSize(int *width, int *height);
virtual Bool AcceptsExplicitFocus();
private:
wxColour *bgcol;
};

2
src/wxwindow/include/msw/wx_win.h
View File

@ -117,6 +117,8 @@ class wxWindow: public wxbWindow
virtual wxWindow *FindFocusWindow();
virtual Bool AcceptsExplicitFocus();
void InitEnable();
};

12
src/wxwindow/src/msw/wx_canvs.cxx
View File

@ -178,12 +178,22 @@ Bool wxCanvas::Show(Bool show)
wxWindow *wxCanvas::FindFocusWindow()
{
if (!wxSubType(__type, wxTYPE_PANEL))
if (GetWindowStyleFlag() & wxNEVER_FOCUS)
return NULL;
else if (!wxSubType(__type, wxTYPE_PANEL))
return IsShown() ? this : NULL;
else
return wxWindow::FindFocusWindow();
}
Bool wxCanvas::AcceptsExplicitFocus()
{
if (GetWindowStyleFlag() & wxNEVER_FOCUS)
return FALSE;
else
return TRUE;
}
/*
* horizontal/vertical: number of pixels per unit (e.g. pixels per text line)
* x/y_length: : no. units per scrollbar

8
src/wxwindow/src/msw/wx_win.cxx
View File

@ -250,6 +250,9 @@ void wxWindow::SetFocus(void)
if (!IsShownTree())
return;
if (!AcceptsExplicitFocus())
return;
p = GetTopLevel();
if (p && wxSubType(p->__type, wxTYPE_FRAME)
@ -288,6 +291,11 @@ void wxWindow::SetFocus(void)
}
}
Bool wxWindow::AcceptsExplicitFocus()
{
return TRUE;
}
/* Enable state flags:
winEnabled = whether the specific window has been enabled or disabled;
implies graying

7
src/wxxt/src/Windows/Canvas.cc
View File

@ -489,3 +489,10 @@ void wxCanvas::OnChar(wxKeyEvent *event)
}
}
Bool wxCanvas::WantsFocus(void)
{
if (GetWindowStyleFlag() & wxNEVER_FOCUS)
return FALSE;
else
return TRUE;
}

2
src/wxxt/src/Windows/Canvas.h
View File

@ -75,6 +75,8 @@ public:
virtual void Layout(void);
virtual Bool WantsFocus(void);
private:
int h_size, h_units, h_units_per_page,
v_size, v_units, v_units_per_page;

5
src/wxxt/src/Windows/Panel.cc
View File

@ -271,3 +271,8 @@ void wxPanel::OnDefaultAction(wxItem *WXUNUSED(item))
}
}
Bool wxPanel::WantsFocus(void)
{
return FALSE;
}

1
src/wxxt/src/Windows/Panel.h
View File

@ -71,6 +71,7 @@ public:
wxPanelDC* GetPanelDC(void) { return dc; }
virtual void ChangeToGray(Bool gray);
virtual void ReleaseAllFocus();
virtual Bool WantsFocus(void);
protected:
friend class wxButton; // allow access to default_item

27
src/wxxt/src/Windows/Window.cc
View File

@ -943,6 +943,9 @@ void wxWindow::SetFocus(void)
if (IsGray() || !IsShown())
return;
if (!WantsFocus())
return;
if (misc_flags & FOCUS_FLAG)
/* focus is already here */
return;
@ -953,20 +956,6 @@ void wxWindow::SetFocus(void)
if (wxSubType(win->__type, wxTYPE_FRAME))
break;
}
#if 0
/* MATTHEW: Is the frame currently active? */
if (win && (win->misc_flags & FOCUS_FLAG)) {
/* MATTHEW: Avoids trying to set focus when it's already there: */
if (XtIsSubclass(X->frame, xfwfCommonWidgetClass)) {
Time time = CurrentTime;
XtCallAcceptFocus(X->frame, &time);
return;
}
}
#endif
// if found: set focus
if (win)
@ -2196,8 +2185,9 @@ void wxWindow::WindowEventHandler(Widget w,
f = (wxFrame *)(win->GetParent());
f->OnMenuClick();
}
} else if (!wxSubType(win->__type, wxTYPE_PANEL)) {
win->SetFocus();
} else {
if (win->WantsFocus())
win->SetFocus();
}
}
@ -2366,6 +2356,11 @@ void wxWindow::WindowEventHandler(Widget w,
#endif
}
Bool wxWindow::WantsFocus(void)
{
return TRUE;
}
//-----------------------------------------------------------------------------
// create and destroy associated device context
//-----------------------------------------------------------------------------

1
src/wxxt/src/Windows/Window.h
View File

@ -145,6 +145,7 @@ public:
virtual void Refresh(void);
virtual void ReleaseMouse(void);
virtual void SetFocus(void);
virtual Bool WantsFocus(void);
virtual void SetUserEditMode(Bool edit) { user_edit_mode = edit; }
virtual Bool Show(Bool show);
// event handling

1
src/wxxt/src/wxDefines.h
View File

@ -427,6 +427,7 @@ enum {
#define wxGL_CONTEXT 0x02000000
#define wxNO_AUTOCLEAR 0x04000000
#define wxCOMBO_SIDE 0x08000000
#define wxNEVER_FOCUS 0x01000000
#define wxALIGN_CENTRE 0
#define wxALIGN_LEFT 1