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

299.202

Browse Source 
svn: r773
This commit is contained in:
Matthew Flatt 2005-09-05 15:40:43 +00:00
parent 1e36a07fc3
commit 33a1602606
28 changed files with 3648 additions and 2635 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
src/mred/wxs/wxscheme.cxx
View File

@ -1044,7 +1044,7 @@ static int CALLBACK get_font(ENUMLOGFONTW FAR* lpelf,
data->names = naya;
}
s = scheme_utf16_to_ucs4(lpelf->elfLogFont.lfFaceName, 0,
s = scheme_utf16_to_ucs4((unsigned short *)lpelf->elfLogFont.lfFaceName, 0,
wx_wstrlen(lpelf->elfLogFont.lfFaceName),
0, 0, &ulen, 1);
s[ulen] = 0;

6
src/mzscheme/cmdline.inc
View File

@ -434,12 +434,12 @@ static int run_from_cmd_line(int argc, char *_argv[],
#ifdef DOS_FILE_SYSTEM
{
/* For consistency, strip trailing spaces, and make sure the .exe
/* For consistency, strip trailing spaces and dots, and make sure the .exe
extension is present. */
int l = strlen(prog);
if ((l > 0) && (prog[l-1] == ' ')) {
if ((l > 0) && ((prog[l-1] == ' ') || (prog[l-1] == '.'))) {
char *s;
while ((l > 0) && (prog[l-1] == ' ')) {
while ((l > 0) && ((prog[l-1] == ' ') || (prog[l-1] == '.'))) {
l--;
}
s = (char *)scheme_malloc_atomic(l + 1);

34
src/mzscheme/gc2/xform-mod.ss
View File

@ -692,6 +692,8 @@
;; In case a conversion is unnecessary where we have this annotation:
(printf "#define START_XFORM_SKIP /**/~n")
(printf "#define END_XFORM_SKIP /**/~n")
(printf "#define START_XFORM_SUSPEND /**/~n")
(printf "#define END_XFORM_SUSPEND /**/~n")
;; For avoiding warnings:
(printf "#define XFORM_OK_PLUS +~n")
(printf "#define XFORM_OK_MINUS -~n")
@ -759,6 +761,8 @@
(define semi (string->symbol ";"))
(define START_XFORM_SKIP (string->symbol "START_XFORM_SKIP"))
(define END_XFORM_SKIP (string->symbol "END_XFORM_SKIP"))
(define START_XFORM_SUSPEND (string->symbol "START_XFORM_SUSPEND"))
(define END_XFORM_SUSPEND (string->symbol "END_XFORM_SUSPEND"))
(define Scheme_Object (string->symbol "Scheme_Object"))
(define sElF (string->symbol "sElF"))
(define NULLED_OUT (string->symbol "NULLED_OUT"))
@ -1249,6 +1253,7 @@
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(define skipping? #f)
(define suspend-xform 0)
(define re:h (regexp "[.]h$"))
@ -1272,6 +1277,14 @@
[skipping?
e]
;; START_XFORM_SUSPEND and END_XFORM_SUSPEND:
[(end-suspend? e)
(set! suspend-xform (sub1 suspend-xform))
null]
[(start-suspend? e)
(set! suspend-xform (add1 suspend-xform))
null]
;; END_XFORM_ARITH and START_XFORM_ARITH enable and
;; re-enable warnings about arithmetic operations
;; on pointers
@ -1367,7 +1380,8 @@
[(function? e)
(let ([name (register-proto-information e)])
(when show-info? (printf "/* FUNCTION ~a */~n" name))
(if (or (not pgc?)
(if (or (positive? suspend-xform)
(not pgc?)
(and where
(regexp-match re:h where)
(let loop ([e e][prev #f])
@ -1379,7 +1393,8 @@
;; inline constructor: need to convert
#f]
[else (loop (cdr e) (car e))]))))
;; Not pgc, or still in headers and probably a simple inlined function
;; Not pgc, xform suspended,
;; or still in headers and probably a simple inlined function
(let ([palm-static? (and palm? (eq? 'static (tok-n (car e))))])
(when palm?
(fprintf map-port "(~aimpl ~s)~n"
@ -1410,9 +1425,16 @@
(top-vars (append pointers non-pointers (top-vars))))))
e))]
[(empty-decl? e)
e]
[else (print-struct #t)
(error 'xform "unknown form: ~s" e)]))
(define (empty-decl? e)
(and (= 1 (length e))
(eq? '|;| (tok-n (car e)))))
(define (start-skip? e)
(and (pair? e)
(eq? START_XFORM_SKIP (tok-n (car e)))))
@ -1421,6 +1443,14 @@
(and (pair? e)
(eq? END_XFORM_SKIP (tok-n (car e)))))
(define (start-suspend? e)
(and (pair? e)
(eq? START_XFORM_SUSPEND (tok-n (car e)))))
(define (end-suspend? e)
(and (pair? e)
(eq? END_XFORM_SUSPEND (tok-n (car e)))))
(define (start-arith? e)
(and (pair? e)
(eq? START_XFORM_ARITH (tok-n (car e)))))

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

@ -206,6 +206,7 @@ scheme_byte_string_to_char_string
scheme_char_string_to_byte_string_locale
scheme_byte_string_to_char_string_locale
scheme_char_string_to_path
scheme_path_to_char_string
scheme_make_char_string
scheme_make_sized_char_string
scheme_make_sized_offset_char_string
@ -388,6 +389,8 @@ scheme_add_fd_eventmask
scheme_security_check_file
scheme_security_check_network
scheme_get_host_address
scheme_get_port_file_descriptor
scheme_get_port_socket
scheme_set_type_printer
scheme_print_bytes
scheme_print_utf8

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

@ -213,6 +213,7 @@ scheme_byte_string_to_char_string
scheme_char_string_to_byte_string_locale
scheme_byte_string_to_char_string_locale
scheme_char_string_to_path
scheme_path_to_char_string
scheme_make_char_string
scheme_make_sized_char_string
scheme_make_sized_offset_char_string
@ -395,6 +396,8 @@ scheme_add_fd_eventmask
scheme_security_check_file
scheme_security_check_network
scheme_get_host_address
scheme_get_port_file_descriptor
scheme_get_port_socket
scheme_set_type_printer
scheme_print_bytes
scheme_print_utf8

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

@ -198,6 +198,7 @@ EXPORTS
scheme_char_string_to_byte_string_locale
scheme_byte_string_to_char_string_locale
scheme_char_string_to_path
scheme_path_to_char_string
scheme_make_char_string
scheme_make_sized_char_string
scheme_make_sized_offset_char_string
@ -380,6 +381,8 @@ EXPORTS
scheme_security_check_file
scheme_security_check_network
scheme_get_host_address
scheme_get_port_file_descriptor
scheme_get_port_socket
scheme_set_type_printer
scheme_print_bytes
scheme_print_utf8

10
src/mzscheme/include/scheme.h
View File

@ -110,6 +110,10 @@ typedef long FILE;
# define MZ_SIGSET(s, f) sigset(s, f)
#endif
#ifdef MZ_XFORM
START_XFORM_SUSPEND;
#endif
#include <stdio.h>
#include <setjmp.h>
#include <stdarg.h>
@ -117,6 +121,10 @@ typedef long FILE;
#include <string.h>
#include <stddef.h>
#ifdef MZ_XFORM
END_XFORM_SUSPEND;
#endif
#ifdef PALMOS_STUFF
typedef jmpbuf jmp_buf[1];
#endif
@ -518,7 +526,7 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
#define scheme_make_integer(i) LONG_TO_OBJ ((OBJ_TO_LONG(i) << 1) | 0x1)
#define scheme_make_character(ch) ((((mzchar)ch) < 256) ? scheme_char_constants[(unsigned char)(ch)] : scheme_make_char(ch))
#define scheme_make_ascii_character(ch) scheme_char_constants[(unsigned char)(ch)];
#define scheme_make_ascii_character(ch) scheme_char_constants[(unsigned char)(ch)]
#define scheme_uchar_find(table, x) (table[(x >> 8) & 0x1FFF][x & 0xFF])

8
src/mzscheme/main.c
View File

@ -49,6 +49,10 @@
# define DONT_LOAD_INIT_FILE
#endif
#ifdef MZ_XFORM
START_XFORM_SUSPEND;
#endif
#ifdef FILES_HAVE_FDS
# include <sys/types.h>
# include <sys/time.h>
@ -80,6 +84,10 @@
# endif
#endif
#ifdef MZ_XFORM
END_XFORM_SUSPEND;
#endif
#ifdef WIN32_THREADS
/* Only set up for Boehm GC that thinks it's a DLL: */
# include <windows.h>

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

File diff suppressed because it is too large Load Diff

1518
src/mzscheme/src/file.c
View File

File diff suppressed because it is too large Load Diff

36
src/mzscheme/src/network.c
View File

@ -3069,6 +3069,42 @@ static void tcp_accept_evt_needs_wakeup(Scheme_Object *ae, void *fds)
tcp_accept_needs_wakeup(SCHEME_PTR_VAL(ae), fds);
}
int scheme_get_port_socket(Scheme_Object *p, long *_s)
{
#ifdef USE_TCP
tcp_t s = 0;
int s_ok = 0;
if (SCHEME_OUTPORTP(p)) {
Scheme_Output_Port *op;
op = (Scheme_Output_Port *)p;
if (op->sub_type == scheme_tcp_output_port_type) {
if (!op->closed) {
s = ((Scheme_Tcp *)op->port_data)->tcp;
s_ok = 1;
}
}
} else if (SCHEME_INPORTP(p)) {
/* Abandon is not really useful on input ports from the Schemer's
perspective, but it's here for completeness. */
Scheme_Input_Port *ip;
ip = (Scheme_Input_Port *)p;
if (ip->sub_type == scheme_tcp_input_port_type) {
if (!ip->closed) {
s = ((Scheme_Tcp *)ip->port_data)->tcp;
s_ok = 1;
}
}
}
if (s_ok) {
*_s = (long)s;
return 1;
} else
return 0;
#endif
}
/*========================================================================*/
/* UDP */
/*========================================================================*/

95
src/mzscheme/src/port.c
View File

@ -211,7 +211,7 @@ typedef struct Scheme_Subprocess {
/* The Scheme_FD type is used for both input and output */
typedef struct Scheme_FD {
MZTAG_IF_REQUIRED
int fd; /* fd is really a HANDLE in Windows */
long fd; /* fd is really a HANDLE in Windows */
long bufcount, buffpos;
char flushing, regfile, flush;
char textmode; /* Windows: textmode => CRLF conversion; SOME_FDS_... => select definitely works */
@ -3163,6 +3163,50 @@ scheme_file_stream_port_p (int argc, Scheme_Object *argv[])
return scheme_false;
}
int scheme_get_port_file_descriptor(Scheme_Object *p, long *_fd)
{
long fd = 0;
int fd_ok = 0;
if (SCHEME_INPORTP(p)) {
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
if (!ip->closed) {
if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
fd = MSC_IZE(fileno)((FILE *)((Scheme_Input_File *)ip->port_data)->f);
fd_ok = 1;
}
#ifdef MZ_FDS
else if (SAME_OBJ(ip->sub_type, fd_input_port_type)) {
fd = ((Scheme_FD *)ip->port_data)->fd;
fd_ok = 1;
}
#endif
}
} else if (SCHEME_OUTPORTP(p)) {
Scheme_Output_Port *op = (Scheme_Output_Port *)p;
if (!op->closed) {
if (SAME_OBJ(op->sub_type, file_output_port_type)) {
fd = MSC_IZE (fileno)((FILE *)((Scheme_Output_File *)op->port_data)->f);
fd_ok = 1;
}
#ifdef MZ_FDS
else if (SAME_OBJ(op->sub_type, fd_output_port_type)) {
fd = ((Scheme_FD *)op->port_data)->fd;
fd_ok = 1;
}
#endif
}
}
if (!fd_ok)
return 0;
*_fd = fd;
return 1;
}
Scheme_Object *scheme_file_identity(int argc, Scheme_Object *argv[])
{
long fd = 0;
@ -3171,40 +3215,23 @@ Scheme_Object *scheme_file_identity(int argc, Scheme_Object *argv[])
p = argv[0];
if (SCHEME_INPORTP(p)) {
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
CHECK_PORT_CLOSED("port-file-identity", "input", p, ip->closed);
if (SAME_OBJ(ip->sub_type, file_input_port_type)) {
fd = MSC_IZE(fileno)((FILE *)((Scheme_Input_File *)ip->port_data)->f);
fd_ok = 1;
}
#ifdef MZ_FDS
else if (SAME_OBJ(ip->sub_type, fd_input_port_type)) {
fd = ((Scheme_FD *)ip->port_data)->fd;
fd_ok = 1;
}
#endif
} else if (SCHEME_OUTPORTP(p)) {
Scheme_Output_Port *op = (Scheme_Output_Port *)p;
CHECK_PORT_CLOSED("port-file-identity", "output", p, op->closed);
if (SAME_OBJ(op->sub_type, file_output_port_type)) {
fd = MSC_IZE (fileno)((FILE *)((Scheme_Output_File *)op->port_data)->f);
fd_ok = 1;
}
#ifdef MZ_FDS
else if (SAME_OBJ(op->sub_type, fd_output_port_type)) {
fd = ((Scheme_FD *)op->port_data)->fd;
fd_ok = 1;
}
#endif
}
fd_ok = scheme_get_port_file_descriptor(p, &fd);
if (!fd_ok) {
/* Maybe failed because it was closed... */
if (SCHEME_INPORTP(p)) {
Scheme_Input_Port *ip = (Scheme_Input_Port *)p;
CHECK_PORT_CLOSED("port-file-identity", "input", p, ip->closed);
} else if (SCHEME_OUTPORTP(p)) {
Scheme_Output_Port *op = (Scheme_Output_Port *)p;
CHECK_PORT_CLOSED("port-file-identity", "output", p, op->closed);
}
/* Otherwise, it's just the wrong type: */
scheme_wrong_type("port-file-identity", "file-stream-port", 0, argc, argv);
return NULL;
}
return scheme_get_fd_identity(p, fd);
@ -6833,7 +6860,7 @@ static Scheme_Object *subprocess(int c, Scheme_Object *args[])
char *np;
int nplen;
nplen = strlen(argv[0]);
np = scheme_normal_path_seps(argv[0], &nplen);
np = scheme_normal_path_seps(argv[0], &nplen, 0);
argv[0] = np;
}
@ -7279,7 +7306,7 @@ static Scheme_Object *sch_shell_execute(int c, Scheme_Object *argv[])
Scheme_Object *sv, *sf, *sp;
nplen = strlen(dir);
dir = scheme_normal_path_seps(dir, &nplen);
dir = scheme_normal_path_seps(dir, &nplen, 0);
if (SCHEME_FALSEP(argv[0]))
sv = scheme_false;

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

@ -1560,7 +1560,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht,
print_utf8_string(pp, "#<path:", 0, 7);
{
Scheme_Object *str;
str = scheme_byte_string_to_char_string_locale(obj);
str = scheme_path_to_char_string(obj);
print(str, 0, 0, ht, symtab, rnht, pp);
}
if (notdisplay) {

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

@ -280,6 +280,8 @@ static Scheme_Object *quasisyntax_symbol;
static Scheme_Object *honu_comma, *honu_semicolon;
static Scheme_Object *honu_parens, *honu_braces, *honu_brackets;
static Scheme_Object *paren_shape_symbol;
static Scheme_Object *terminating_macro_symbol, *non_terminating_macro_symbol, *dispatch_macro_symbol;
static char *builtin_fast;
@ -314,6 +316,7 @@ void scheme_init_read(Scheme_Env *env)
REGISTER_SO(unsyntax_splicing_symbol);
REGISTER_SO(quasisyntax_symbol);
REGISTER_SO(an_uninterned_symbol);
REGISTER_SO(paren_shape_symbol);
quote_symbol = scheme_intern_symbol("quote");
quasiquote_symbol = scheme_intern_symbol("quasiquote");
@ -326,6 +329,8 @@ void scheme_init_read(Scheme_Env *env)
an_uninterned_symbol = scheme_make_symbol("unresolved");
paren_shape_symbol = scheme_intern_symbol("paren-shape");
REGISTER_SO(honu_comma);
REGISTER_SO(honu_semicolon);
REGISTER_SO(honu_parens);
@ -1928,6 +1933,11 @@ Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj, int mkstx)
/* list reader */
/*========================================================================*/
static Scheme_Object *attach_shape_property(Scheme_Object *list,
Scheme_Object *stxsrc,
ReadParams *params,
int closer);
static Scheme_Object *honu_add_module_wrapper(Scheme_Object *list,
Scheme_Object *stxsrc,
Scheme_Object *port);
@ -2033,6 +2043,7 @@ read_list(Scheme_Object *port,
if (params->honu_mode && (closer == EOF)) {
list = honu_add_module_wrapper(list, stxsrc, port);
}
list = attach_shape_property(list, stxsrc, params, closer);
return list;
}
@ -2123,9 +2134,11 @@ read_list(Scheme_Object *port,
}
pop_indentation(indentation);
return (stxsrc
list = (stxsrc
? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG)
: list);
list = attach_shape_property(list, stxsrc, params, closer);
return list;
} else if (!params->honu_mode
&& params->can_read_dot
&& (ch == '.')
@ -2209,9 +2222,11 @@ read_list(Scheme_Object *port,
pop_indentation(indentation);
return (stxsrc
list = (stxsrc
? scheme_make_stx_w_offset(list, line, col, pos, SPAN(port, pos), stxsrc, STX_SRCTAG)
: list);
list = attach_shape_property(list, stxsrc, params, closer);
return list;
}
} else {
if ((ch == SCHEME_SPECIAL) || (params->table && (ch != EOF))) {
@ -2283,6 +2298,21 @@ honu_add_module_wrapper(Scheme_Object *list, Scheme_Object *stxsrc, Scheme_Objec
return v;
}
static Scheme_Object *attach_shape_property(Scheme_Object *list,
Scheme_Object *stxsrc,
ReadParams *params,
int closer)
{
if ((closer != ')') && stxsrc && !params->honu_mode) {
Scheme_Object *opener;
opener = ((closer == '}')
? scheme_make_ascii_character('{')
: scheme_make_ascii_character('['));
return scheme_stx_property(list, paren_shape_symbol, opener);
}
return list;
}
/*========================================================================*/
/* string reader */
/*========================================================================*/

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

@ -437,6 +437,7 @@ MZ_EXTERN Scheme_Object *scheme_byte_string_to_char_string(Scheme_Object *s);
MZ_EXTERN Scheme_Object *scheme_char_string_to_byte_string_locale(Scheme_Object *s);
MZ_EXTERN Scheme_Object *scheme_byte_string_to_char_string_locale(Scheme_Object *s);
MZ_EXTERN Scheme_Object *scheme_char_string_to_path(Scheme_Object *p);
MZ_EXTERN Scheme_Object *scheme_path_to_char_string(Scheme_Object *p);
MZ_EXTERN Scheme_Object *scheme_make_char_string(const mzchar *chars);
MZ_EXTERN Scheme_Object *scheme_make_sized_char_string(mzchar *chars, long len, int copy);
@ -774,6 +775,9 @@ MZ_EXTERN void scheme_security_check_network(const char *who, const char *host,
MZ_EXTERN int scheme_get_host_address(const char *address, int id, void *result);
MZ_EXTERN int scheme_get_port_file_descriptor(Scheme_Object *p, long *_fd);
MZ_EXTERN int scheme_get_port_socket(Scheme_Object *p, long *_s);
MZ_EXTERN void scheme_set_type_printer(Scheme_Type stype, Scheme_Type_Printer printer);
MZ_EXTERN void scheme_print_bytes(Scheme_Print_Params *pp, const char *str, int offset, int len);
MZ_EXTERN void scheme_print_utf8(Scheme_Print_Params *pp, const char *str, int offset, int len);

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

@ -356,6 +356,7 @@ Scheme_Object *(*scheme_byte_string_to_char_string)(Scheme_Object *s);
Scheme_Object *(*scheme_char_string_to_byte_string_locale)(Scheme_Object *s);
Scheme_Object *(*scheme_byte_string_to_char_string_locale)(Scheme_Object *s);
Scheme_Object *(*scheme_char_string_to_path)(Scheme_Object *p);
Scheme_Object *(*scheme_path_to_char_string)(Scheme_Object *p);
Scheme_Object *(*scheme_make_char_string)(const mzchar *chars);
Scheme_Object *(*scheme_make_sized_char_string)(mzchar *chars, long len, int copy);
Scheme_Object *(*scheme_make_sized_offset_char_string)(mzchar *chars, long d, long len, int copy);
@ -644,6 +645,8 @@ void (*scheme_add_fd_eventmask)(void *fds, int mask);
void (*scheme_security_check_file)(const char *who, const char *filename, int guards);
void (*scheme_security_check_network)(const char *who, const char *host, int port, int client);
int (*scheme_get_host_address)(const char *address, int id, void *result);
int (*scheme_get_port_file_descriptor)(Scheme_Object *p, long *_fd);
int (*scheme_get_port_socket)(Scheme_Object *p, long *_s);
void (*scheme_set_type_printer)(Scheme_Type stype, Scheme_Type_Printer printer);
void (*scheme_print_bytes)(Scheme_Print_Params *pp, const char *str, int offset, int len);
void (*scheme_print_utf8)(Scheme_Print_Params *pp, const char *str, int offset, int len);

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

@ -234,6 +234,7 @@
scheme_extension_table->scheme_char_string_to_byte_string_locale = scheme_char_string_to_byte_string_locale;
scheme_extension_table->scheme_byte_string_to_char_string_locale = scheme_byte_string_to_char_string_locale;
scheme_extension_table->scheme_char_string_to_path = scheme_char_string_to_path;
scheme_extension_table->scheme_path_to_char_string = scheme_path_to_char_string;
scheme_extension_table->scheme_make_char_string = scheme_make_char_string;
scheme_extension_table->scheme_make_sized_char_string = scheme_make_sized_char_string;
scheme_extension_table->scheme_make_sized_offset_char_string = scheme_make_sized_offset_char_string;
@ -437,6 +438,8 @@
scheme_extension_table->scheme_security_check_file = scheme_security_check_file;
scheme_extension_table->scheme_security_check_network = scheme_security_check_network;
scheme_extension_table->scheme_get_host_address = scheme_get_host_address;
scheme_extension_table->scheme_get_port_file_descriptor = scheme_get_port_file_descriptor;
scheme_extension_table->scheme_get_port_socket = scheme_get_port_socket;
scheme_extension_table->scheme_set_type_printer = scheme_set_type_printer;
scheme_extension_table->scheme_print_bytes = scheme_print_bytes;
scheme_extension_table->scheme_print_utf8 = scheme_print_utf8;

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

@ -234,6 +234,7 @@
#define scheme_char_string_to_byte_string_locale (scheme_extension_table->scheme_char_string_to_byte_string_locale)
#define scheme_byte_string_to_char_string_locale (scheme_extension_table->scheme_byte_string_to_char_string_locale)
#define scheme_char_string_to_path (scheme_extension_table->scheme_char_string_to_path)
#define scheme_path_to_char_string (scheme_extension_table->scheme_path_to_char_string)
#define scheme_make_char_string (scheme_extension_table->scheme_make_char_string)
#define scheme_make_sized_char_string (scheme_extension_table->scheme_make_sized_char_string)
#define scheme_make_sized_offset_char_string (scheme_extension_table->scheme_make_sized_offset_char_string)
@ -437,6 +438,8 @@
#define scheme_security_check_file (scheme_extension_table->scheme_security_check_file)
#define scheme_security_check_network (scheme_extension_table->scheme_security_check_network)
#define scheme_get_host_address (scheme_extension_table->scheme_get_host_address)
#define scheme_get_port_file_descriptor (scheme_extension_table->scheme_get_port_file_descriptor)
#define scheme_get_port_socket (scheme_extension_table->scheme_get_port_socket)
#define scheme_set_type_printer (scheme_extension_table->scheme_set_type_printer)
#define scheme_print_bytes (scheme_extension_table->scheme_print_bytes)
#define scheme_print_utf8 (scheme_extension_table->scheme_print_utf8)

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

@ -2061,7 +2061,7 @@ int scheme_is_complete_path(const char *s, long len);
Scheme_Object *scheme_get_file_directory(const char *filename);
char *scheme_normal_path_seps(char *s, int *_len);
char *scheme_normal_path_seps(char *s, int *_len, int delta);
int scheme_is_regular_file(char *filename);

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 299
#define MZSCHEME_VERSION_MINOR 201
#define MZSCHEME_VERSION_MINOR 202
#define MZSCHEME_VERSION "299.201" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "299.202" _MZ_SPECIAL_TAG

15
src/mzscheme/src/startup.inc
View File

@ -2494,11 +2494,18 @@
" (raise-type-error 'normal-path-case \"path or valid-path string\" s))"
"(cond"
"((eq?(system-type) 'windows)"
"(let((s(string-locale-downcase(if(string? s)"
" s"
"(path->string s)))))"
"(let((str(if(string? s) s(path->string s))))"
" (if (regexp-match-positions #rx\"^[\\u5C][\\u5C][?][\\u5C]\" str)"
"(if(string? s)"
"(string->path s)"
" s)"
"(let((s(string-locale-downcase str)))"
"(string->path "
" (regexp-replace* #rx\"/\" (regexp-replace* #rx\" +$\" s \"\") bsbs))))"
" (regexp-replace* #rx\"/\" "
" (if (regexp-match-positions #rx\"[/\\u5C][. ]+[/\\u5C]*$\" s)"
" s"
" (regexp-replace* #rx\"\\u5B .\\u5D+([/\\u5C]*)$\" s \"\\u005C1\"))"
" bsbs))))))"
"((eq?(system-type) 'macos)"
"(string->path(string-locale-downcase(if(string? s)"
" s"

20
src/mzscheme/src/startup.ss
View File

@ -2902,18 +2902,26 @@
(raise-type-error 'normal-path-case "path or valid-path string" s))
(cond
[(eq? (system-type) 'windows)
(let ([s (string-locale-downcase (if (string? s)
s
(path->string s)))])
(string->path
(regexp-replace* #rx"/" (regexp-replace* #rx" +$" s "") bsbs)))]
(let ([str (if (string? s) s (path->string s))])
(if (regexp-match-positions #rx"^[\u5C][\u5C][?][\u5C]" str)
(if (string? s)
(string->path s)
s)
(let ([s (string-locale-downcase str)])
(string->path
(regexp-replace* #rx"/"
(if (regexp-match-positions #rx"[/\u5C][. ]+[/\u5C]*$" s)
;; Just "." or ".." in last path element - don't remove
s
(regexp-replace* #rx"\u5B .\u5D+([/\u5C]*)$" s "\u005C1"))
bsbs)))))]
[(eq? (system-type) 'macos)
(string->path (string-locale-downcase (if (string? s)
s
(path->string s))))]
[(string? s) (string->path s)]
[else s]))
(define rationalize
(letrec ([check (lambda (x)
(unless (real? x) (raise-type-error 'rationalize "real" x)))]

1
src/mzscheme/src/string.c
View File

@ -3208,6 +3208,7 @@ mzchar *scheme_string_recase(mzchar *s, int d, int len, int mode, int inplace, i
j++;
}
}
t[len+extra+td] = 0;
return t;
}

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

@ -15,6 +15,10 @@
#define wx_msw
#ifdef MZ_XFORM
START_XFORM_SUSPEND;
#endif
#include <stddef.h>
#include <string.h>
#include "wx_setup.h"
@ -26,6 +30,10 @@
# define Bool_DEFINED
#endif
#ifdef MZ_XFORM
END_XFORM_SUSPEND;
#endif
#ifndef TRUE
# define TRUE 1
# define FALSE 0

4
src/wxwindow/src/msw/wx_cmdlg.cxx
View File

@ -128,7 +128,7 @@ static char* ExtractMultipleFileNames(OPENFILENAMEW* of, wchar_t* wFileBuffer)
directoryByteLength = len_in_bytes(wFileBuffer, 0, directoryLength);
result = new WXGC_ATOMIC wchar_t[totalLength];
result = (wchar_t *)GC_malloc_atomic(sizeof(wchar_t) * totalLength);
/* Skip the directory part */
currentFileLength = wx_wstrlen(wFileBuffer);
@ -287,7 +287,7 @@ char *wxFileSelector(char *message,
free(b);
if (ok) {
result = new WXGC_ATOMIC wchar_t[MAX_PATH + 1];
result = (wchar_t *)GC_malloc_atomic(sizeof(wchar_t) * (MAX_PATH + 1));
memcpy(result, _result, sizeof(wchar_t) * (MAX_PATH + 1));
} else
result = NULL;

4
src/wxwindow/src/msw/wx_dc.cxx
View File

@ -1594,7 +1594,7 @@ wchar_t *convert_to_drawable_format(const char *text, int d, int ucs4, long *_ul
ulen = theStrlen + extra;
alloc_ulen = ulen;
if (alloc_ulen > QUICK_UBUF_SIZE)
unicode = new WXGC_ATOMIC wchar_t[alloc_ulen];
unicode = (wchar_t *)GC_malloc_atomic(sizeof(wchar_t) * alloc_ulen);
else
unicode = u_buf;
@ -1618,7 +1618,7 @@ wchar_t *convert_to_drawable_format(const char *text, int d, int ucs4, long *_ul
NULL, 1 /*UTF-16*/, '?');
alloc_ulen = ulen;
if (alloc_ulen > QUICK_UBUF_SIZE)
unicode = new WXGC_ATOMIC wchar_t[alloc_ulen];
unicode = (wchar_t *)GC_malloc_atomic(sizeof(wchar_t) * alloc_ulen);
else
unicode = u_buf;
ulen = scheme_utf8_decode((unsigned char *)text, d, theStrlen,

2
src/wxwindow/src/msw/wx_utils.cxx
View File

@ -454,7 +454,7 @@ wchar_t *wx_convert_to_wchar(char *s, int do_copy)
if (!do_copy && (len < (WC_BUFFER_SIZE-1)))
ws = wc_buffer;
else
ws = new WXGC_ATOMIC wchar_t[len + 1];
ws = (wchar_t *)GC_malloc_atomic(sizeof(wchar_t) * (len + 1));
scheme_utf8_decode((unsigned char *)s, 0, l,
(unsigned int *)ws, 0, -1,
NULL, 1/*UTF-16*/, 1);

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

@ -1032,9 +1032,8 @@ static LONG WindowProc(HWND hWnd, UINT message, WPARAM wParam, LPARAM lParam, in
&& ((wParam == HTVSCROLL) || (wParam == HTHSCROLL))
&& wnd->wx_window
&& wxSubType(wnd->wx_window->__type, wxTYPE_CANVAS)) {
/* To support interactive scrolling in canvases, we let
windows run its handler for the click in a new
thread. Messages get redirected to this thread. */
/* To support interactive scrolling in canvases, we
use a trampoline. See wxHiEventTrampoline in mred.cxx. */
wxDWP_Closure *c;
c = new wxDWP_Closure;
c->wnd = wnd;