From 1d1aea5b2b1692900ed5e132deeb4e3a3e3eed7a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 18 Oct 2008 07:50:10 +0000 Subject: [PATCH 01/37] Welcome to a new PLT day. svn: r12055 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 9dc8c1106a..8d7ed6f689 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "17oct2008") +#lang scheme/base (provide stamp) (define stamp "18oct2008") From 69685db89223c8f25f8de110a0a0bb76cb79523c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Oct 2008 14:22:51 +0000 Subject: [PATCH 02/37] try to fix problems force-closing stuck ports under Windows svn: r12056 --- src/mzscheme/src/port.c | 118 +++++++++++++++++++++++++++++----------- 1 file changed, 87 insertions(+), 31 deletions(-) diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index f49a88ed02..c39142dec6 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -122,11 +122,14 @@ typedef struct Win_FD_Input_Thread { /* This is malloced for use in a Win32 thread */ HANDLE fd; volatile int avail, err, checking; + int *refcount; HANDLE eof; unsigned char *buffer; HANDLE checking_sema, ready_sema, you_clean_up_sema; } Win_FD_Input_Thread; +static HANDLE refcount_sema; + typedef struct Win_FD_Output_Thread { /* This is malloced for use in a Win32 thread */ HANDLE fd; @@ -144,6 +147,7 @@ typedef struct Win_FD_Output_Thread { volatile int done, err_no; volatile unsigned int buflen, bufstart, bufend; /* used for blocking, only */ unsigned char *buffer; /* used for blocking, only */ + int *refcount; HANDLE lock_sema, work_sema, ready_sema, you_clean_up_sema; /* lock_sema protects the fields, work_sema starts the flush or flush-checking thread to work, ready_sema indicates that a flush @@ -4532,6 +4536,26 @@ scheme_make_file_input_port(FILE *fp) # ifdef WINDOWS_FILE_HANDLES static long WindowsFDReader(Win_FD_Input_Thread *th); static void WindowsFDICleanup(Win_FD_Input_Thread *th); +typedef BOOL (WINAPI* CSI_proc)(HANDLE); + +static CSI_proc get_csi(void) +{ + static int tried_csi = 0; + static CSI_proc csi; + + START_XFORM_SKIP; + if (!tried_csi) { + HMODULE hm; + hm = LoadLibrary("kernel32.dll"); + if (hm) + csi = (CSI_proc)GetProcAddress(hm, "CancelSynchronousIo"); + else + csi = NULL; + tried_csi = 1; + } + END_XFORM_SKIP; + return csi; +} # endif /* forward decl: */ @@ -4914,11 +4938,10 @@ fd_close_input(Scheme_Input_Port *port) fip = (Scheme_FD *)port->port_data; - if (fip->refcount) - *fip->refcount -= 1; - #ifdef WINDOWS_FILE_HANDLES if (fip->th) { + CSI_proc csi; + /* -1 for checking means "shut down" */ fip->th->checking = -1; ReleaseSemaphore(fip->th->checking_sema, 1, NULL); @@ -4928,18 +4951,29 @@ fd_close_input(Scheme_Input_Port *port) fip->th->eof = NULL; } + csi = get_csi(); + if (csi) { + csi(fip->th->thread); + /* See note on csi at fd_close_output */ + } + /* Try to get out of cleaning up the records (since they can't be cleaned until the thread is also done: */ if (WaitForSingleObject(fip->th->you_clean_up_sema, 0) != WAIT_OBJECT_0) { /* The other thread exited and left us with clean-up: */ WindowsFDICleanup(fip->th); } /* otherwise, thread is responsible for clean-up */ - } - if (!fip->refcount || !*fip->refcount) { - CloseHandle((HANDLE)fip->fd); - --scheme_file_open_count; + } else { + if (fip->refcount) + *fip->refcount -= 1; + if (!fip->refcount || !*fip->refcount) { + CloseHandle((HANDLE)fip->fd); + --scheme_file_open_count; + } } #else + if (fip->refcount) + *fip->refcount -= 1; if (!fip->refcount || !*fip->refcount) { int cr; do { @@ -5088,6 +5122,11 @@ make_fd_input_port(int fd, Scheme_Object *name, int regfile, int win_textmode, i th->ready_sema = sm; sm = CreateSemaphore(NULL, 1, 1, NULL); th->you_clean_up_sema = sm; + if (refcount) { + th->refcount = refcount; + if (!refcount_sema) + refcount_sema = CreateSemaphore(NULL, 1, 1, NULL); + } h = CreateThread(NULL, 4096, (LPTHREAD_START_ROUTINE)WindowsFDReader, th, 0, &id); @@ -5161,9 +5200,21 @@ static long WindowsFDReader(Win_FD_Input_Thread *th) static void WindowsFDICleanup(Win_FD_Input_Thread *th) { + int rc; + CloseHandle(th->checking_sema); CloseHandle(th->ready_sema); CloseHandle(th->you_clean_up_sema); + + if (th->refcount) { + WaitForSingleObject(refcount_sema, INFINITE); + *th->refcount -= 1; + rc = *th->refcount; + ReleaseSemaphore(refcount_sema, 1, NULL); + } else + rc = 0; + if (!rc) CloseHandle(th->fd); + free(th->buffer); free(th); } @@ -5906,6 +5957,11 @@ static long flush_fd(Scheme_Output_Port *op, oth->ready_sema = sm; sm = CreateSemaphore(NULL, 1, 1, NULL); oth->you_clean_up_sema = sm; + if (refcount) { + oth->refcount = refcount; + if (!refcount_sema) + refcount_sema = CreateSemaphore(NULL, 1, 1, NULL); + } h = CreateThread(NULL, 4096, (LPTHREAD_START_ROUTINE)WindowsFDWriter, oth, 0, &id); @@ -6134,10 +6190,6 @@ fd_write_string(Scheme_Output_Port *port, return len; } -#ifdef WINDOWS_FILE_HANDLES -typedef BOOL (WINAPI* CSI_proc)(HANDLE); -#endif - static void fd_close_output(Scheme_Output_Port *port) { @@ -6163,25 +6215,11 @@ fd_close_output(Scheme_Output_Port *port) if (port->closed) return; - if (fop->refcount) - *fop->refcount -= 1; - #ifdef WINDOWS_FILE_HANDLES if (fop->oth) { - static int tried_csi = 0; - static CSI_proc csi; + CSI_proc csi; - START_XFORM_SKIP; - if (!tried_csi) { - HMODULE hm; - hm = LoadLibrary("kernel32.dll"); - if (hm) - csi = (BOOL (WINAPI*)(HANDLE))GetProcAddress(hm, "CancelSynchronousIo"); - else - csi = NULL; - tried_csi = 1; - } - END_XFORM_SKIP; + csi = get_csi(); if (csi) { csi(fop->oth->thread); @@ -6200,12 +6238,18 @@ fd_close_output(Scheme_Output_Port *port) WindowsFDOCleanup(fop->oth); } /* otherwise, thread is responsible for clean-up */ fop->oth = NULL; - } - if (!fop->refcount || !*fop->refcount) { - CloseHandle((HANDLE)fop->fd); - --scheme_file_open_count; + } else { + if (fop->refcount) + *fop->refcount -= 1; + if (!fop->refcount || !*fop->refcount) { + CloseHandle((HANDLE)fop->fd); + --scheme_file_open_count; + } } #else + if (fop->refcount) + *fop->refcount -= 1; + if (!fop->refcount || !*fop->refcount) { int cr; do { @@ -6382,9 +6426,21 @@ static long WindowsFDWriter(Win_FD_Output_Thread *oth) static void WindowsFDOCleanup(Win_FD_Output_Thread *oth) { + int rc; + CloseHandle(oth->lock_sema); CloseHandle(oth->work_sema); CloseHandle(oth->you_clean_up_sema); + + if (oth->refcount) { + WaitForSingleObject(refcount_sema, INFINITE); + *oth->refcount -= 1; + rc = *oth->refcount; + ReleaseSemaphore(refcount_sema, 1, NULL); + } else + rc = 0; + if (!rc) CloseHandle(oth->fd); + if (oth->buffer) free(oth->buffer); free(oth); From b013cf9d7ad8d9a531af06304ed6627669568a58 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Oct 2008 14:33:51 +0000 Subject: [PATCH 03/37] fix Windows repairs for ports svn: r12057 --- src/mzscheme/src/port.c | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index c39142dec6..5de7d3774b 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -126,6 +126,7 @@ typedef struct Win_FD_Input_Thread { HANDLE eof; unsigned char *buffer; HANDLE checking_sema, ready_sema, you_clean_up_sema; + HANDLE thread; } Win_FD_Input_Thread; static HANDLE refcount_sema; @@ -5130,6 +5131,8 @@ make_fd_input_port(int fd, Scheme_Object *name, int regfile, int win_textmode, i h = CreateThread(NULL, 4096, (LPTHREAD_START_ROUTINE)WindowsFDReader, th, 0, &id); + th->thread = h; + scheme_remember_thread(h, 1); } #endif @@ -5957,8 +5960,8 @@ static long flush_fd(Scheme_Output_Port *op, oth->ready_sema = sm; sm = CreateSemaphore(NULL, 1, 1, NULL); oth->you_clean_up_sema = sm; - if (refcount) { - oth->refcount = refcount; + if (fop->refcount) { + oth->refcount = fop->refcount; if (!refcount_sema) refcount_sema = CreateSemaphore(NULL, 1, 1, NULL); } From 431b60d7b408989cfbfecdfc08e8b91358f984c7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Oct 2008 14:54:34 +0000 Subject: [PATCH 04/37] rewind broken Windows port chages, for now svn: r12058 --- src/mzscheme/src/port.c | 121 ++++++++++------------------------------ 1 file changed, 31 insertions(+), 90 deletions(-) diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index 5de7d3774b..f49a88ed02 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -122,15 +122,11 @@ typedef struct Win_FD_Input_Thread { /* This is malloced for use in a Win32 thread */ HANDLE fd; volatile int avail, err, checking; - int *refcount; HANDLE eof; unsigned char *buffer; HANDLE checking_sema, ready_sema, you_clean_up_sema; - HANDLE thread; } Win_FD_Input_Thread; -static HANDLE refcount_sema; - typedef struct Win_FD_Output_Thread { /* This is malloced for use in a Win32 thread */ HANDLE fd; @@ -148,7 +144,6 @@ typedef struct Win_FD_Output_Thread { volatile int done, err_no; volatile unsigned int buflen, bufstart, bufend; /* used for blocking, only */ unsigned char *buffer; /* used for blocking, only */ - int *refcount; HANDLE lock_sema, work_sema, ready_sema, you_clean_up_sema; /* lock_sema protects the fields, work_sema starts the flush or flush-checking thread to work, ready_sema indicates that a flush @@ -4537,26 +4532,6 @@ scheme_make_file_input_port(FILE *fp) # ifdef WINDOWS_FILE_HANDLES static long WindowsFDReader(Win_FD_Input_Thread *th); static void WindowsFDICleanup(Win_FD_Input_Thread *th); -typedef BOOL (WINAPI* CSI_proc)(HANDLE); - -static CSI_proc get_csi(void) -{ - static int tried_csi = 0; - static CSI_proc csi; - - START_XFORM_SKIP; - if (!tried_csi) { - HMODULE hm; - hm = LoadLibrary("kernel32.dll"); - if (hm) - csi = (CSI_proc)GetProcAddress(hm, "CancelSynchronousIo"); - else - csi = NULL; - tried_csi = 1; - } - END_XFORM_SKIP; - return csi; -} # endif /* forward decl: */ @@ -4939,10 +4914,11 @@ fd_close_input(Scheme_Input_Port *port) fip = (Scheme_FD *)port->port_data; + if (fip->refcount) + *fip->refcount -= 1; + #ifdef WINDOWS_FILE_HANDLES if (fip->th) { - CSI_proc csi; - /* -1 for checking means "shut down" */ fip->th->checking = -1; ReleaseSemaphore(fip->th->checking_sema, 1, NULL); @@ -4952,29 +4928,18 @@ fd_close_input(Scheme_Input_Port *port) fip->th->eof = NULL; } - csi = get_csi(); - if (csi) { - csi(fip->th->thread); - /* See note on csi at fd_close_output */ - } - /* Try to get out of cleaning up the records (since they can't be cleaned until the thread is also done: */ if (WaitForSingleObject(fip->th->you_clean_up_sema, 0) != WAIT_OBJECT_0) { /* The other thread exited and left us with clean-up: */ WindowsFDICleanup(fip->th); } /* otherwise, thread is responsible for clean-up */ - } else { - if (fip->refcount) - *fip->refcount -= 1; - if (!fip->refcount || !*fip->refcount) { - CloseHandle((HANDLE)fip->fd); - --scheme_file_open_count; - } + } + if (!fip->refcount || !*fip->refcount) { + CloseHandle((HANDLE)fip->fd); + --scheme_file_open_count; } #else - if (fip->refcount) - *fip->refcount -= 1; if (!fip->refcount || !*fip->refcount) { int cr; do { @@ -5123,16 +5088,9 @@ make_fd_input_port(int fd, Scheme_Object *name, int regfile, int win_textmode, i th->ready_sema = sm; sm = CreateSemaphore(NULL, 1, 1, NULL); th->you_clean_up_sema = sm; - if (refcount) { - th->refcount = refcount; - if (!refcount_sema) - refcount_sema = CreateSemaphore(NULL, 1, 1, NULL); - } h = CreateThread(NULL, 4096, (LPTHREAD_START_ROUTINE)WindowsFDReader, th, 0, &id); - th->thread = h; - scheme_remember_thread(h, 1); } #endif @@ -5203,21 +5161,9 @@ static long WindowsFDReader(Win_FD_Input_Thread *th) static void WindowsFDICleanup(Win_FD_Input_Thread *th) { - int rc; - CloseHandle(th->checking_sema); CloseHandle(th->ready_sema); CloseHandle(th->you_clean_up_sema); - - if (th->refcount) { - WaitForSingleObject(refcount_sema, INFINITE); - *th->refcount -= 1; - rc = *th->refcount; - ReleaseSemaphore(refcount_sema, 1, NULL); - } else - rc = 0; - if (!rc) CloseHandle(th->fd); - free(th->buffer); free(th); } @@ -5960,11 +5906,6 @@ static long flush_fd(Scheme_Output_Port *op, oth->ready_sema = sm; sm = CreateSemaphore(NULL, 1, 1, NULL); oth->you_clean_up_sema = sm; - if (fop->refcount) { - oth->refcount = fop->refcount; - if (!refcount_sema) - refcount_sema = CreateSemaphore(NULL, 1, 1, NULL); - } h = CreateThread(NULL, 4096, (LPTHREAD_START_ROUTINE)WindowsFDWriter, oth, 0, &id); @@ -6193,6 +6134,10 @@ fd_write_string(Scheme_Output_Port *port, return len; } +#ifdef WINDOWS_FILE_HANDLES +typedef BOOL (WINAPI* CSI_proc)(HANDLE); +#endif + static void fd_close_output(Scheme_Output_Port *port) { @@ -6218,11 +6163,25 @@ fd_close_output(Scheme_Output_Port *port) if (port->closed) return; + if (fop->refcount) + *fop->refcount -= 1; + #ifdef WINDOWS_FILE_HANDLES if (fop->oth) { - CSI_proc csi; + static int tried_csi = 0; + static CSI_proc csi; - csi = get_csi(); + START_XFORM_SKIP; + if (!tried_csi) { + HMODULE hm; + hm = LoadLibrary("kernel32.dll"); + if (hm) + csi = (BOOL (WINAPI*)(HANDLE))GetProcAddress(hm, "CancelSynchronousIo"); + else + csi = NULL; + tried_csi = 1; + } + END_XFORM_SKIP; if (csi) { csi(fop->oth->thread); @@ -6241,18 +6200,12 @@ fd_close_output(Scheme_Output_Port *port) WindowsFDOCleanup(fop->oth); } /* otherwise, thread is responsible for clean-up */ fop->oth = NULL; - } else { - if (fop->refcount) - *fop->refcount -= 1; - if (!fop->refcount || !*fop->refcount) { - CloseHandle((HANDLE)fop->fd); - --scheme_file_open_count; - } + } + if (!fop->refcount || !*fop->refcount) { + CloseHandle((HANDLE)fop->fd); + --scheme_file_open_count; } #else - if (fop->refcount) - *fop->refcount -= 1; - if (!fop->refcount || !*fop->refcount) { int cr; do { @@ -6429,21 +6382,9 @@ static long WindowsFDWriter(Win_FD_Output_Thread *oth) static void WindowsFDOCleanup(Win_FD_Output_Thread *oth) { - int rc; - CloseHandle(oth->lock_sema); CloseHandle(oth->work_sema); CloseHandle(oth->you_clean_up_sema); - - if (oth->refcount) { - WaitForSingleObject(refcount_sema, INFINITE); - *oth->refcount -= 1; - rc = *oth->refcount; - ReleaseSemaphore(refcount_sema, 1, NULL); - } else - rc = 0; - if (!rc) CloseHandle(oth->fd); - if (oth->buffer) free(oth->buffer); free(oth); From 2288db4fc9981fe170068697d2546136da8527ea Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 18 Oct 2008 15:00:53 +0000 Subject: [PATCH 05/37] modernized notation svn: r12059 --- collects/redex/examples/omega.ss | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/collects/redex/examples/omega.ss b/collects/redex/examples/omega.ss index 30789b4705..7d947b55bc 100644 --- a/collects/redex/examples/omega.ss +++ b/collects/redex/examples/omega.ss @@ -20,15 +20,15 @@ (define reductions (reduction-relation lang - (--> (in-hole c_1 (call/cc v_arg)) - ,(term-let ([v (variable-not-in (term c_1) 'x)]) - (term (in-hole c_1 (v_arg (lambda (v) (abort (in-hole c_1 v))))))) - call/cc) - (--> (in-hole c (abort e_1)) - e_1 + (--> (in-hole c (call/cc v)) + (in-hole c (v (lambda (x) (abort (in-hole c x))))) + call/cc + (fresh x)) + (--> (in-hole c (abort e)) + e abort) - (--> (in-hole c_1 ((lambda (variable_x) e_body) v_arg)) - (in-hole c_1 (subst (variable_x v_arg e_body))) + (--> (in-hole c ((lambda (x) e) v)) + (in-hole c (subst (x v e))) βv))) (traces reductions '((lambda (x) (x x)) (lambda (x) (x x)))) From 02fbdf09b186fff01aaf83cda28b6c63c6f7b53e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Oct 2008 16:40:08 +0000 Subject: [PATCH 06/37] avoid having MzScheme get stuck on pipes when CancelSynchronizedIo is not available svn: r12060 --- src/mzscheme/src/port.c | 197 +++++++++++++++++++++++++++++----------- 1 file changed, 146 insertions(+), 51 deletions(-) diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index f49a88ed02..635a10fce1 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -122,11 +122,15 @@ typedef struct Win_FD_Input_Thread { /* This is malloced for use in a Win32 thread */ HANDLE fd; volatile int avail, err, checking; + int *refcount; HANDLE eof; unsigned char *buffer; HANDLE checking_sema, ready_sema, you_clean_up_sema; + HANDLE thread; } Win_FD_Input_Thread; +static HANDLE refcount_sema; + typedef struct Win_FD_Output_Thread { /* This is malloced for use in a Win32 thread */ HANDLE fd; @@ -144,6 +148,7 @@ typedef struct Win_FD_Output_Thread { volatile int done, err_no; volatile unsigned int buflen, bufstart, bufend; /* used for blocking, only */ unsigned char *buffer; /* used for blocking, only */ + int *refcount; HANDLE lock_sema, work_sema, ready_sema, you_clean_up_sema; /* lock_sema protects the fields, work_sema starts the flush or flush-checking thread to work, ready_sema indicates that a flush @@ -187,6 +192,59 @@ typedef struct Scheme_Subprocess { # define MZ_FDS #endif +/******************** refcounts ********************/ + +#ifdef WINDOWS_FILE_HANDLES + +static int *malloc_refcount() +{ + if (!refcount_sema) + refcount_sema = CreateSemaphore(NULL, 1, 1, NULL); + + return (int *)malloc(sizeof(int)); +} + +#ifdef MZ_XFORM +START_XFORM_SKIP; +#endif + +static int dec_refcount(int *refcount) +{ + int rc; + + if (!refcount) + return 0; + + WaitForSingleObject(refcount_sema, INFINITE); + *refcount -= 1; + rc = *refcount; + ReleaseSemaphore(refcount_sema, 1, NULL); + + if (!rc) free(refcount); + + return rc; +} + +#ifdef MZ_XFORM +END_XFORM_SKIP; +#endif + +#else + +static int *malloc_refcount() +{ + return (int *)scheme_malloc_atomic(sizeof(int)); +} + +static int dec_refcount(int *refcount) +{ + if (!refcount) + return 0; + *refcont -= 1; + return *refcount; +} + +#endif /******************** file-descriptor I/O ********************/ @@ -4532,6 +4590,26 @@ scheme_make_file_input_port(FILE *fp) # ifdef WINDOWS_FILE_HANDLES static long WindowsFDReader(Win_FD_Input_Thread *th); static void WindowsFDICleanup(Win_FD_Input_Thread *th); +typedef BOOL (WINAPI* CSI_proc)(HANDLE); + +static CSI_proc get_csi(void) +{ + static int tried_csi = 0; + static CSI_proc csi; + + START_XFORM_SKIP; + if (!tried_csi) { + HMODULE hm; + hm = LoadLibrary("kernel32.dll"); + if (hm) + csi = (CSI_proc)GetProcAddress(hm, "CancelSynchronousIo"); + else + csi = NULL; + tried_csi = 1; + } + END_XFORM_SKIP; + return csi; +} # endif /* forward decl: */ @@ -4914,11 +4992,10 @@ fd_close_input(Scheme_Input_Port *port) fip = (Scheme_FD *)port->port_data; - if (fip->refcount) - *fip->refcount -= 1; - #ifdef WINDOWS_FILE_HANDLES if (fip->th) { + CSI_proc csi; + /* -1 for checking means "shut down" */ fip->th->checking = -1; ReleaseSemaphore(fip->th->checking_sema, 1, NULL); @@ -4928,25 +5005,40 @@ fd_close_input(Scheme_Input_Port *port) fip->th->eof = NULL; } + csi = get_csi(); + if (csi) { + /* Helps thread wake up. Otherwise, it's possible for the + thread to stay stuck trying to read, in which case the + file handle (probably a pipe) doesn't get closed. */ + csi(fip->th->thread); + } + /* Try to get out of cleaning up the records (since they can't be cleaned until the thread is also done: */ if (WaitForSingleObject(fip->th->you_clean_up_sema, 0) != WAIT_OBJECT_0) { /* The other thread exited and left us with clean-up: */ WindowsFDICleanup(fip->th); } /* otherwise, thread is responsible for clean-up */ - } - if (!fip->refcount || !*fip->refcount) { - CloseHandle((HANDLE)fip->fd); - --scheme_file_open_count; + } else { + int rc; + rc = dec_refcount(fip->refcount); + if (!rc) { + CloseHandle((HANDLE)fip->fd); + --scheme_file_open_count; + } } #else - if (!fip->refcount || !*fip->refcount) { - int cr; - do { - cr = close(fip->fd); - } while ((cr == -1) && (errno == EINTR)); - --scheme_file_open_count; - } + { + int rc; + rc = dec_refcount(fip->refcount); + if (!rc) { + int cr; + do { + cr = close(fip->fd); + } while ((cr == -1) && (errno == EINTR)); + --scheme_file_open_count; + } + } #endif } @@ -5088,9 +5180,12 @@ make_fd_input_port(int fd, Scheme_Object *name, int regfile, int win_textmode, i th->ready_sema = sm; sm = CreateSemaphore(NULL, 1, 1, NULL); th->you_clean_up_sema = sm; + th->refcount = refcount; h = CreateThread(NULL, 4096, (LPTHREAD_START_ROUTINE)WindowsFDReader, th, 0, &id); + th->thread = h; + scheme_remember_thread(h, 1); } #endif @@ -5161,9 +5256,15 @@ static long WindowsFDReader(Win_FD_Input_Thread *th) static void WindowsFDICleanup(Win_FD_Input_Thread *th) { + int rc; + CloseHandle(th->checking_sema); CloseHandle(th->ready_sema); CloseHandle(th->you_clean_up_sema); + + rc = dec_refcount(th->refcount); + if (!rc) CloseHandle(th->fd); + free(th->buffer); free(th); } @@ -5906,7 +6007,8 @@ static long flush_fd(Scheme_Output_Port *op, oth->ready_sema = sm; sm = CreateSemaphore(NULL, 1, 1, NULL); oth->you_clean_up_sema = sm; - + oth->refcount = fop->refcount; + h = CreateThread(NULL, 4096, (LPTHREAD_START_ROUTINE)WindowsFDWriter, oth, 0, &id); scheme_remember_thread(h, 1); @@ -6134,10 +6236,6 @@ fd_write_string(Scheme_Output_Port *port, return len; } -#ifdef WINDOWS_FILE_HANDLES -typedef BOOL (WINAPI* CSI_proc)(HANDLE); -#endif - static void fd_close_output(Scheme_Output_Port *port) { @@ -6163,32 +6261,15 @@ fd_close_output(Scheme_Output_Port *port) if (port->closed) return; - if (fop->refcount) - *fop->refcount -= 1; - #ifdef WINDOWS_FILE_HANDLES if (fop->oth) { - static int tried_csi = 0; - static CSI_proc csi; + CSI_proc csi; - START_XFORM_SKIP; - if (!tried_csi) { - HMODULE hm; - hm = LoadLibrary("kernel32.dll"); - if (hm) - csi = (BOOL (WINAPI*)(HANDLE))GetProcAddress(hm, "CancelSynchronousIo"); - else - csi = NULL; - tried_csi = 1; - } - END_XFORM_SKIP; + csi = get_csi(); if (csi) { + /* See also call to csi in fd_close_input */ csi(fop->oth->thread); - /* We're hoping that if CancelSyncrhonousIo isn't available, that - CloseHandle() will work, or that WriteFile() didn't block after - all (which seems to be the case with pre-Vista FILE_TYPE_CHAR - handles). */ } CloseHandle(fop->oth->thread); fop->oth->done = 1; @@ -6200,19 +6281,27 @@ fd_close_output(Scheme_Output_Port *port) WindowsFDOCleanup(fop->oth); } /* otherwise, thread is responsible for clean-up */ fop->oth = NULL; - } - if (!fop->refcount || !*fop->refcount) { - CloseHandle((HANDLE)fop->fd); - --scheme_file_open_count; + } else { + int rc; + rc = dec_refcount(fop->refcount); + if (!rc) { + CloseHandle((HANDLE)fop->fd); + --scheme_file_open_count; + } } #else - if (!fop->refcount || !*fop->refcount) { - int cr; - do { - cr = close(fop->fd); - } while ((cr == -1) && (errno == EINTR)); - --scheme_file_open_count; - } + { + int rc; + rc = dec_refcount(fop->refcount); + + if (!rc) { + int cr; + do { + cr = close(fop->fd); + } while ((cr == -1) && (errno == EINTR)); + --scheme_file_open_count; + } + } #endif } @@ -6290,7 +6379,7 @@ make_fd_output_port(int fd, Scheme_Object *name, int regfile, int win_textmode, if (and_read) { int *rc; Scheme_Object *a[2]; - rc = (int *)scheme_malloc_atomic(sizeof(int)); + rc = malloc_refcount(); *rc = 2; fop->refcount = rc; a[1] = the_port; @@ -6382,9 +6471,15 @@ static long WindowsFDWriter(Win_FD_Output_Thread *oth) static void WindowsFDOCleanup(Win_FD_Output_Thread *oth) { + int rc; + CloseHandle(oth->lock_sema); CloseHandle(oth->work_sema); CloseHandle(oth->you_clean_up_sema); + + rc = dec_refcount(oth->refcount); + if (!rc) CloseHandle(oth->fd); + if (oth->buffer) free(oth->buffer); free(oth); From c73be48400adb7d9fdf5893d230ecbdadda1ebeb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Oct 2008 16:41:18 +0000 Subject: [PATCH 07/37] fix refcount typo svn: r12061 --- src/mzscheme/src/port.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/src/mzscheme/src/port.c b/src/mzscheme/src/port.c index 635a10fce1..6eaba89dff 100644 --- a/src/mzscheme/src/port.c +++ b/src/mzscheme/src/port.c @@ -240,7 +240,7 @@ static int dec_refcount(int *refcount) { if (!refcount) return 0; - *refcont -= 1; + *refcount -= 1; return *refcount; } From 881d884b6727284336ccb6129206a02814007bb7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 18 Oct 2008 23:47:32 +0000 Subject: [PATCH 08/37] avoid calling FindScrollStep with a negative offset svn: r12062 --- src/mred/wxme/wx_mline.cxx | 2 ++ 1 file changed, 2 insertions(+) diff --git a/src/mred/wxme/wx_mline.cxx b/src/mred/wxme/wx_mline.cxx index 2fbd1ea0ad..3101c56b80 100644 --- a/src/mred/wxme/wx_mline.cxx +++ b/src/mred/wxme/wx_mline.cxx @@ -747,6 +747,8 @@ long wxMediaLine::FindExtraScroll(double y) { if (y >= h) return numscrolls; + if (y <= 0) + return 0; if (!scrollSnip) return 0; From 860bbfe0a0909e6f0ba69f32a62860fecea84ac0 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 19 Oct 2008 03:03:45 +0000 Subject: [PATCH 09/37] svn: r12063 --- .../scribblings/guide/contracts-gotchas.scrbl | 120 +++++++++++++----- 1 file changed, 89 insertions(+), 31 deletions(-) diff --git a/collects/scribblings/guide/contracts-gotchas.scrbl b/collects/scribblings/guide/contracts-gotchas.scrbl index 99d4203628..3eb8e58464 100644 --- a/collects/scribblings/guide/contracts-gotchas.scrbl +++ b/collects/scribblings/guide/contracts-gotchas.scrbl @@ -1,12 +1,99 @@ #lang scribble/doc -@(require scribble/manual +@(require scribble/manual scribble/eval + scheme/sandbox "guide-utils.ss" "contracts-utils.ss" (for-label scheme/contract)) @title[#:tag "contracts-gotchas"]{Gotchas} +@ctc-section{Contracts and @scheme[eq?]} + +As a general rule, adding a contract to a program should +either leave the behavior of the program unchanged, or +should signal a contract violation. And this is almost true +for PLT Scheme contracts, with one exception: @scheme[eq?]. + +The @scheme[eq?] procedure is designed to be fast and does +not provide much in the way of guarantees, except that if it +returns true, it means that the two values behave +identically in all respects. Internally, this is implemented +as pointer equality at a low-level so it exposes information +about how PLT Scheme is implemented (and how contracts are +implemented). + +Contracts interact poorly with @scheme[eq?] because function +contract checking is implemented internally as wrapper +functions. For example, consider this module: +@schememod[ +scheme + +(define (make-adder x) + (if (= 1 x) + add1 + (lambda (y) (+ x 1)))) +(provide/contract [make-adder (-> number? (-> number? number?))]) +] + +It exports the @scheme[make-adder] function that is the usual curried +addition function, except that it returns Scheme's @scheme[add1] when +its input is @scheme[1]. + +You might expect that +@schemeblock[ +(eq? (make-adder 1) + (make-adder 1)) +] + +would return @scheme[#t], but it does not. If the contract were +changed to @scheme[any/c] (or even @scheme[(-> number? any/c)]), then +the @scheme[eq?] call would return @scheme[#t]. + +Moral: do not use @scheme[eq?] on values that have contracts. + +@ctc-section{Defining recursive contracts} + +When defining a self-referential contract, it is natural to use +@scheme[define]. For example, one might try to write a contract on +streams like this: + +@interaction[ +#:eval + (parameterize ([sandbox-security-guard (current-security-guard)] + [sandbox-output 'string] + [sandbox-error-output 'string] + [sandbox-eval-limits #f] + [sandbox-make-inspector current-inspector]) + (make-evaluator '(begin (require scheme)))) +(define stream/c + (promise/c + (or/c + null? + (cons/c number? stream/c)))) +] + +Unfortunately, this does not work because the value of +@scheme[stream/c] is needed before it is defined. Put another way, all +of the combinators evaluate their arguments eagerly, even thought the +values that they accept do not. + +Instead, use +@schemeblock[ +(define stream/c + (promise/c + (or/c + null? + (cons/c 1 + (recursive-contract stream/c))))) +] + +The use of @scheme[recursive-contract] delays the evaluation of the +identifier @scheme[stream/c] until after the contract is first +checked, long enough to ensure that @scheme[stream/c] is defined. + +See also @ctc-link["lazy-contracts"]. + @ctc-section{Using @scheme[set!] to Assign to Variables Provided via @scheme[provide/contract]} The contract library assumes that variables exported via @@ -50,34 +137,5 @@ scheme [get-x (-> integer?)]) ] -This is a bug we hope to address in a future release. -@;{ -@question{Contracts and @scheme[eq?]} +Moral: This is a bug we hope to address in a future release. -As a general rule, adding a contract to a program should -either leave the behavior of the program unchanged, or -should signal a contract violation. And this is almost true -for PLT Scheme contracts, with one exception: @scheme[eq?]. - -The @scheme[eq?] procedure is designed to be fast and does -not provide much in the way of guarantees, except that if it -returns true, it means that the two values behave -identically in all respects. Internally, this is implemented -as pointer equality at a low-level so it exposes information -about how PLT Scheme is implemented (and how contracts are -implemented). - -Contracts interact poorly with @scheme[eq?] because function -contract checking is implemented internally as wrapper -functions. For example, consider this module: -@schememod[ -scheme - -(define (make-adder )) -(provide make-adder) - -(provide/contract [make-adder (-> number? (-> number? number?))]) -] - - -} From a81f0b07dbf895b4b72ce84f42920ae16a8dd811 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 19 Oct 2008 07:50:11 +0000 Subject: [PATCH 10/37] Welcome to a new PLT day. svn: r12064 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 8d7ed6f689..508e39adc4 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "18oct2008") +#lang scheme/base (provide stamp) (define stamp "19oct2008") From 46af55311d6f1a2e1c14a49bcf914e6c48e50e8d Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 19 Oct 2008 11:20:13 +0000 Subject: [PATCH 11/37] regexp contract refinemenets (follow-up on PR 9840) svn: r12065 --- collects/scribblings/reference/regexps.scrbl | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/collects/scribblings/reference/regexps.scrbl b/collects/scribblings/reference/regexps.scrbl index 92885b8d0d..eea79141e9 100644 --- a/collects/scribblings/reference/regexps.scrbl +++ b/collects/scribblings/reference/regexps.scrbl @@ -206,8 +206,8 @@ case-sensitively. [start-pos exact-nonnegative-integer? 0] [end-pos (or/c exact-nonnegative-integer? #f) #f] [output-port (or/c output-port? #f) #f]) - (or/c (listof (or/c (or/c string? bytes?) - #f)) + (or/c (listof (or/c string? #f)) + (listof (or/c bytes? #f)) #f)]{ Attempts to match @scheme[pattern] (a string, byte string, regexp @@ -304,7 +304,7 @@ bytes. To avoid such interleaving, use @scheme[regexp-match-peek] [input (or/c string? bytes? input-port?)] [start-pos exact-nonnegative-integer? 0] [end-pos (or/c exact-nonnegative-integer? #f) #f]) - (listof (or/c string? bytes?))]{ + (or/c (listof string?) (listof bytes?))]{ Like @scheme[regexp-match], but the result is a list of strings or byte strings corresponding to a sequence of matches of @@ -336,8 +336,8 @@ port). [start-pos exact-nonnegative-integer? 0] [end-pos (or/c exact-nonnegative-integer? #f) #f] [output-port (or/c output-port? #f) #f]) - (or/c (listof (or/c (or/c string? bytes?) - #f)) + (or/c (listof (or/c string? #f)) + (listof (or/c bytes? #f)) #f)]{ Like @scheme[regexp-match] on input ports, except that if the match From a559c81d631411ae6c6ff962e9913b747573e653 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 19 Oct 2008 12:40:31 +0000 Subject: [PATCH 12/37] svn: r12066 --- collects/scribblings/guide/contracts-gotchas.scrbl | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/collects/scribblings/guide/contracts-gotchas.scrbl b/collects/scribblings/guide/contracts-gotchas.scrbl index 3eb8e58464..5064870eb0 100644 --- a/collects/scribblings/guide/contracts-gotchas.scrbl +++ b/collects/scribblings/guide/contracts-gotchas.scrbl @@ -58,14 +58,10 @@ When defining a self-referential contract, it is natural to use @scheme[define]. For example, one might try to write a contract on streams like this: +@(define e (make-base-eval)) +@(interaction-eval #:eval e (require scheme/contract)) @interaction[ -#:eval - (parameterize ([sandbox-security-guard (current-security-guard)] - [sandbox-output 'string] - [sandbox-error-output 'string] - [sandbox-eval-limits #f] - [sandbox-make-inspector current-inspector]) - (make-evaluator '(begin (require scheme)))) + #:eval e (define stream/c (promise/c (or/c From d5e3fdf639cf0ab102a376ba96daade0b5bc6426 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 20 Oct 2008 02:24:04 +0000 Subject: [PATCH 13/37] svn: r12067 --- collects/lang/private/beginner-funs.ss | 20 ++++++++++---------- 1 file changed, 10 insertions(+), 10 deletions(-) diff --git a/collects/lang/private/beginner-funs.ss b/collects/lang/private/beginner-funs.ss index 9c44f36b8d..e00dd65ea9 100644 --- a/collects/lang/private/beginner-funs.ss +++ b/collects/lang/private/beginner-funs.ss @@ -304,32 +304,32 @@ ("Characters" (char? (any -> boolean) "to determine whether a value is a character") - (char=? (char char ... -> boolean) + (char=? (char char char ... -> boolean) "to determine whether two characters are equal") - (char boolean) + (char boolean) "to determine whether a character precedes another") - (char>? (char char ... -> boolean) + (char>? (char char char ... -> boolean) "to determine whether a character succeeds another") - (char<=? (char char ... -> boolean) + (char<=? (char char char ... -> boolean) "to determine whether a character precedes another" " (or is equal to it)") - (char>=? (char char ... -> boolean) + (char>=? (char char char ... -> boolean) "to determine whether a character succeeds another" " (or is equal to it)") - (char-ci=? (char char ... -> boolean) + (char-ci=? (char char char ... -> boolean) "to determine whether two characters are equal" " in a case-insensitive manner") - (char-ci boolean) + (char-ci boolean) "to determine whether a character precedes another" " in a case-insensitive manner") - (char-ci>? (char char ... -> boolean) + (char-ci>? (char char char ... -> boolean) "to determine whether a character succeeds another" " in a case-insensitive manner") - (char-ci<=? (char char ... -> boolean) + (char-ci<=? (char char char ... -> boolean) "to determine whether a character precedes another" " (or is equal to it) in a case-insensitive manner") - (char-ci>=? (char char ... -> boolean) + (char-ci>=? (char char char ... -> boolean) "to determine whether a character succeeds another" " (or is equal to it) in a case-insensitive manner") From 72198bf8561aa280ed12850e99e16ba92c6677f8 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 20 Oct 2008 02:52:23 +0000 Subject: [PATCH 14/37] a little improvement (see PR9847) but still not working svn: r12068 --- collects/typed-scheme/private/base-env.ss | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index df537b8951..633e34f28c 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -4,6 +4,7 @@ scheme/list (only-in rnrs/lists-6 fold-left) '#%paramz + (rename-in '#%kernel [apply kernel:apply]) scheme/promise (only-in scheme/match/runtime match:error)) @@ -239,8 +240,10 @@ [odd? (-> N B)] [even? (-> N B)] -[apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] -[time-apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] +[apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] +[kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] +[time-apply (-poly (a b) (((list) a . ->* . b) (-lst a) + . -> . (-values (list b N N N))))] [call/cc (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))] [call/ec (-poly (a b) (((a . -> . (Un)) . -> . b) . -> . (*Un a b)))] From d90bf83f8c3b3f5c1bfcd29168368a867e0062da Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 20 Oct 2008 03:28:01 +0000 Subject: [PATCH 15/37] fix output contract (see PR9845) svn: r12069 --- collects/scribblings/reference/sandbox.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 73942e8708..87f3780709 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -539,8 +539,8 @@ byte string into the pipe. It can also be used with @scheme[eof], which closes the pipe.} -@defproc*[([(get-output [evaluator (any/c . -> . any)]) (or/c input-port? bytes? string?)] - [(get-error-output [evaluator (any/c . -> . any)]) (or/c input-port? bytes? string?)])]{ +@defproc*[([(get-output [evaluator (any/c . -> . any)]) (or/c #f input-port? bytes? string?)] + [(get-error-output [evaluator (any/c . -> . any)]) (or/c #f input-port? bytes? string?)])]{ Returns the output or error-output of the @scheme[evaluator], in a way that depends on the setting of @scheme[(sandbox-output)] or From 79b048727023846a812151bf87aa6f040e350d52 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 20 Oct 2008 07:50:09 +0000 Subject: [PATCH 16/37] Welcome to a new PLT day. svn: r12070 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 508e39adc4..1581ba61d3 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "19oct2008") +#lang scheme/base (provide stamp) (define stamp "20oct2008") From 9d0f9f7a0572542c427d57793010bde12d5d8fd7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 20 Oct 2008 13:13:42 +0000 Subject: [PATCH 17/37] fix problem with transferring marks when some marks contirbuted to the generation of a module-level binding svn: r12071 --- src/mzscheme/src/env.c | 13 ++++-- src/mzscheme/src/eval.c | 8 ++-- src/mzscheme/src/module.c | 28 ++++++------- src/mzscheme/src/schpriv.h | 3 +- src/mzscheme/src/stxobj.c | 81 ++++++++++++++++++++++++++------------ src/mzscheme/src/syntax.c | 4 +- 6 files changed, 88 insertions(+), 49 deletions(-) diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index e49d9bb5f4..0bb16801d1 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -1743,7 +1743,8 @@ Scheme_Object *scheme_hash_module_variable(Scheme_Env *env, Scheme_Object *modid return val; } -Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def, Scheme_Object *phase) +Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def, + Scheme_Object *phase, int *_skipped) /* The `env' argument can actually be a hash table. */ { Scheme_Object *marks = NULL, *sym, *map, *l, *a, *amarks, *m, *best_match, *cm, *abdg; @@ -1752,6 +1753,9 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec sym = SCHEME_STX_SYM(id); + if (_skipped) + *_skipped = 0; + if (SCHEME_HASHTP((Scheme_Object *)env)) marked_names = (Scheme_Hash_Table *)env; else { @@ -1951,6 +1955,9 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec scheme_hash_set(rev_ht, best_match, scheme_true); } } + } else { + if (_skipped) + *_skipped = best_match_skipped; } return best_match; @@ -2515,7 +2522,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, if (SAME_OBJ(modidx, scheme_undefined)) { if (!env->genv->module && SCHEME_STXP(find_id)) { /* Looks like lexically bound, but double-check that it's not bound via a tl_id: */ - find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL); + find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL); if (!SAME_OBJ(find_global_id, SCHEME_STX_VAL(find_id))) modidx = NULL; /* yes, it is bound */ } @@ -2582,7 +2589,7 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, *_menv = genv; if (!modname && SCHEME_STXP(find_id)) - find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL); + find_global_id = scheme_tl_id_sym(env->genv, find_id, NULL, 0, NULL, NULL); else find_global_id = find_id; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 1f6e7c342f..70e2c235a7 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -5435,7 +5435,7 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, /* If form is a marked name, then force #%top binding. This is so temporaries can be used as defined ids. */ Scheme_Object *nm; - nm = scheme_tl_id_sym(env->genv, form, NULL, 0, NULL); + nm = scheme_tl_id_sym(env->genv, form, NULL, 0, NULL, NULL); if (!SAME_OBJ(nm, SCHEME_STX_VAL(form))) { stx = scheme_datum_to_syntax(top_symbol, scheme_false, scheme_sys_wraps(env), 0, 0); @@ -5870,7 +5870,7 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co Scheme_Object *modidx, *symbol = c, *tl_id; int bad; - tl_id = scheme_tl_id_sym(env->genv, symbol, NULL, 0, NULL); + tl_id = scheme_tl_id_sym(env->genv, symbol, NULL, 0, NULL, NULL); if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) { /* Since the module has a rename for this id, it's certainly defined. */ } else { @@ -5917,7 +5917,7 @@ top_syntax(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, c = check_top(scheme_compile_stx_string, form, env, rec, drec); - c = scheme_tl_id_sym(env->genv, c, NULL, 0, NULL); + c = scheme_tl_id_sym(env->genv, c, NULL, 0, NULL, NULL); if (env->genv->module && !rec[drec].resolve_module_ids) { /* Self-reference in a module; need to remember the modidx. Don't @@ -8954,7 +8954,7 @@ scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Ob Scheme_Object *l; /* Registers marked id: */ - scheme_tl_id_sym(env->genv, *_id, scheme_false, 2, NULL); + scheme_tl_id_sym(env->genv, *_id, scheme_false, 2, NULL, NULL); l = icons(scheme_datum_to_syntax(define_values_symbol, scheme_false, sys_wraps, 0, 0), icons(scheme_make_pair(*_id, scheme_null), diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index a22bbff3f0..72ba911c39 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -3210,7 +3210,7 @@ Scheme_Object *scheme_check_accessible_in_module(Scheme_Env *env, Scheme_Object supplied (not both). For unprotected access, both prot_insp and stx+certs should be supplied. */ { - symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL); + symbol = scheme_tl_id_sym(env, symbol, NULL, 0, NULL, NULL); if (scheme_is_kernel_env(env) || ((env->module->primitive && !env->module->provide_protects)) @@ -3389,7 +3389,7 @@ Scheme_Object *scheme_module_syntax(Scheme_Object *modname, Scheme_Env *env, Sch if (!menv->et_ran) scheme_run_module_exptime(menv, 1); - name = scheme_tl_id_sym(menv, name, NULL, 0, NULL); + name = scheme_tl_id_sym(menv, name, NULL, 0, NULL, NULL); val = scheme_lookup_in_table(menv->syntax, (char *)name); @@ -5505,7 +5505,7 @@ static int check_already_required(Scheme_Hash_Table *required, Scheme_Object *na static Scheme_Object *stx_sym(Scheme_Object *name, Scheme_Object *_genv) { - return scheme_tl_id_sym((Scheme_Env *)_genv, name, NULL, 2, NULL); + return scheme_tl_id_sym((Scheme_Env *)_genv, name, NULL, 2, NULL, NULL); } static Scheme_Object *add_a_rename(Scheme_Object *fm, Scheme_Object *post_ex_rn) @@ -5546,7 +5546,7 @@ static Scheme_Object *add_lifted_defn(Scheme_Object *data, Scheme_Object **_id, self_modidx = SCHEME_VEC_ELS(data)[1]; rn = SCHEME_VEC_ELS(data)[2]; - name = scheme_tl_id_sym(env->genv, *_id, scheme_false, 2, NULL); + name = scheme_tl_id_sym(env->genv, *_id, scheme_false, 2, NULL, NULL); /* Create the bucket, indicating that the name will be defined: */ scheme_add_global_symbol(name, scheme_undefined, env->genv); @@ -5848,7 +5848,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, /* Remember the original: */ all_defs = scheme_make_pair(name, all_defs); - name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL); + name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL); /* Check that it's not yet defined: */ if (scheme_lookup_in_table(env->genv->toplevel, (const char *)name)) { @@ -5925,7 +5925,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, else all_et_defs = scheme_make_pair(name, all_et_defs); - name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL); + name = scheme_tl_id_sym(oenv->genv, name, NULL, 2, NULL, NULL); if (scheme_lookup_in_table(oenv->genv->syntax, (const char *)name)) { scheme_wrong_syntax("module", orig_name, e, @@ -6278,7 +6278,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, /* may be a single shadowed exclusion, now bound to exclude_hint... */ n = SCHEME_CAR(n); if (SCHEME_STXP(n)) - n = scheme_tl_id_sym(env->genv, n, NULL, 0, NULL); + n = scheme_tl_id_sym(env->genv, n, NULL, 0, NULL, NULL); n = scheme_hash_get(required, n); if (n && !SAME_OBJ(SCHEME_VEC_ELS(n)[1], kernel_modidx)) { /* there is a single shadowed exclusion. */ @@ -6814,7 +6814,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, /* Make sure each excluded name was defined: */ for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { a = SCHEME_STX_CAR(exns); - name = scheme_tl_id_sym(genv, a, NULL, 0, NULL); + name = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL); if (!scheme_lookup_in_table(genv->toplevel, (const char *)name) && !scheme_lookup_in_table(genv->syntax, (const char *)name)) { scheme_wrong_syntax("module", a, ree_kw, "excluded identifier was not defined"); @@ -6824,12 +6824,12 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, for (adl = all_defs; SCHEME_PAIRP(adl); adl = SCHEME_CDR(adl)) { name = SCHEME_CAR(adl); exname = SCHEME_STX_SYM(name); - name = scheme_tl_id_sym(genv, name, NULL, 0, NULL); + name = scheme_tl_id_sym(genv, name, NULL, 0, NULL, NULL); /* Was this one excluded? */ for (exns = exl; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) { a = SCHEME_STX_CAR(exns); - a = scheme_tl_id_sym(genv, a, NULL, 0, NULL); + a = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL); if (SAME_OBJ(a, name)) break; } @@ -6845,7 +6845,7 @@ int compute_reprovides(Scheme_Hash_Table *all_provided, as if it had ree_kw's context, then comparing that result to the actual tl_id. */ a = scheme_datum_to_syntax(exname, scheme_false, ree_kw, 0, 0); - a = scheme_tl_id_sym(genv, a, NULL, 0, NULL); + a = scheme_tl_id_sym(genv, a, NULL, 0, NULL, NULL); if (SAME_OBJ(a, name)) { /* Add prefix, if any */ @@ -7033,7 +7033,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table prnt_name = name; if (SCHEME_STXP(name)) { if (genv) - name = scheme_tl_id_sym(genv, name, NULL, 0, phase); + name = scheme_tl_id_sym(genv, name, NULL, 0, phase, NULL); else name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ } @@ -7106,7 +7106,7 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table if (genv && (SAME_OBJ(phase, scheme_make_integer(0)) || SAME_OBJ(phase, scheme_make_integer(1)))) - name = scheme_tl_id_sym(genv, name, NULL, 0, phase); + name = scheme_tl_id_sym(genv, name, NULL, 0, phase, NULL); else { name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ } @@ -8040,7 +8040,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ /* The `require' expression has a set of marks in its context, which means that we need to generate a name. */ iname = scheme_datum_to_syntax(iname, scheme_false, mark_src, 0, 0); - iname = scheme_tl_id_sym(orig_env, iname, scheme_false, 2, to_phase); + iname = scheme_tl_id_sym(orig_env, iname, scheme_false, 2, to_phase, NULL); if (all_simple) *all_simple = 0; } diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 8a6b5b270e..0ab5091ff3 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -2634,7 +2634,8 @@ void scheme_add_global_constant_symbol(Scheme_Object *name, Scheme_Object *v, Sc -Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def, Scheme_Object *phase); +Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Object *bdg, int is_def, + Scheme_Object *phase, int *_skipped); int scheme_tl_id_is_sym_used(Scheme_Hash_Table *marked_names, Scheme_Object *sym); Scheme_Object *scheme_sys_wraps(Scheme_Comp_Env *env); diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 31ec03d690..95fc7830c3 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -3300,7 +3300,7 @@ static int explain_resolves = 0; static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *a, Scheme_Object *orig_phase, int w_mod, Scheme_Object **get_names, - Scheme_Object *skip_ribs) + Scheme_Object *skip_ribs, int *_binding_marks_skipped) /* Module binding ignored if w_mod is 0. If module bound, result is module idx, and get_names[0] is set to source name, get_names[1] is set to the nominal source module, get_names[2] is set to @@ -3321,6 +3321,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *phase = orig_phase; Scheme_Object *bdg = NULL, *floating = NULL; Scheme_Hash_Table *export_registry = NULL; + int mresult_skipped = 0; EXPLAIN(printf("Resolving %s [skips: %s]:\n", SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); @@ -3370,10 +3371,12 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } stack_pos -= 2; } - if (!did_lexical) + if (!did_lexical) { result = mresult; - else if (get_names) - get_names[0] = scheme_undefined; + if (_binding_marks_skipped) + *_binding_marks_skipped = mresult_skipped; + } else if (get_names) + get_names[0] = scheme_undefined; EXPLAIN(printf("Result: %s\n", scheme_write_to_string(result, 0))); @@ -3383,6 +3386,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, && w_mod) { /* Module rename: */ Module_Renames *mrn; + int skipped; EXPLAIN(printf("Rename/set\n")); @@ -3415,7 +3419,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (mrn->marked_names) { /* Resolve based on rest of wraps: */ if (!bdg) { - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, skip_ribs); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, skip_ribs, NULL); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -3425,7 +3429,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } } /* Remap id based on marks and rest-of-wraps resolution: */ - glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL); + glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, &skipped); if (SCHEME_TRUEP(bdg) && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) { /* Even if this module doesn't match, the lex-renamed id @@ -3437,8 +3441,10 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, stack_pos = 0; o_rename_stack = scheme_null; } - } else + } else { + skipped = 0; glob_id = SCHEME_STX_VAL(a); + } EXPLAIN(printf(" search %s\n", scheme_write_to_string(glob_id, 0))); @@ -3478,6 +3484,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, modidx_shift_from, modidx_shift_to); + mresult_skipped = skipped; + if (get_names) { int no_shift = 0; @@ -3551,6 +3559,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } } else { mresult = scheme_false; + mresult_skipped = 0; if (get_names) get_names[0] = NULL; } @@ -3647,7 +3656,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (SCHEME_VOIDP(other_env)) { SCHEME_USE_FUEL(1); - other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs); + other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL); if (!is_rib) SCHEME_VEC_ELS(rename)[2+c+ri] = other_env; SCHEME_USE_FUEL(1); @@ -3806,13 +3815,13 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ if (mrn->needs_unmarshal) { /* Use resolve_env to trigger unmarshal, so that we don't have to implement top/from shifts here: */ - resolve_env(NULL, a, orig_phase, 1, NULL, NULL); + resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL); } if (mrn->marked_names) { /* Resolve based on rest of wraps: */ if (!bdg) - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -3821,7 +3830,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ bdg = floating; } /* Remap id based on marks and rest-of-wraps resolution: */ - glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL); + glob_id = scheme_tl_id_sym((Scheme_Env *)mrn->marked_names, a, bdg, 0, NULL, NULL); } else glob_id = SCHEME_STX_VAL(a); @@ -3892,8 +3901,8 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha if ((a == asym) || (b == bsym)) return 1; - a = resolve_env(NULL, a, phase, 1, NULL, NULL); - b = resolve_env(NULL, b, phase, 1, NULL, NULL); + a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL); + b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL); if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) a = scheme_module_resolve(a, 0); @@ -3935,7 +3944,7 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase, names[4] = NULL; names[5] = NULL; - modname = resolve_env(NULL, *a, phase, 1, names, NULL); + modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL); if (names[0]) { if (SAME_OBJ(names[0], scheme_undefined)) { @@ -3966,7 +3975,7 @@ Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a) if (SCHEME_STXP(a)) { Scheme_Object *r; - r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL); + r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL); if (SCHEME_FALSEP(r)) r = check_floating_id(a); @@ -3998,13 +4007,13 @@ int scheme_stx_env_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *u if (!SAME_OBJ(asym, bsym)) return 0; - ae = resolve_env(NULL, a, phase, 0, NULL, NULL); + ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL); /* No need to module_resolve ae, because we ignored module renamings. */ if (uid) be = uid; else { - be = resolve_env(NULL, b, phase, 0, NULL, NULL); + be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL); /* No need to module_resolve be, because we ignored module renamings. */ } @@ -4034,7 +4043,7 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) { explain_resolves++; - a = resolve_env(NULL, a, 0, 0, NULL, NULL); + a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL); --explain_resolves; return a; } @@ -4567,7 +4576,7 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; if (SCHEME_VOIDP(other_env)) { - other_env = resolve_env(NULL, stx, 0, 0, NULL, skip_ribs); + other_env = resolve_env(NULL, stx, 0, 0, NULL, skip_ribs, NULL); SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; } @@ -6788,7 +6797,7 @@ static Scheme_Object *delta_introducer(int argc, struct Scheme_Object *argv[], S static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv) { - Scheme_Object *m1, *m2, *delta, *a[1]; + Scheme_Object *orig_m1, *m1, *m2, *delta, *a[1]; int l1, l2; if (!SCHEME_STXP(argv[0])) @@ -6797,6 +6806,7 @@ static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv) scheme_wrong_type("make-syntax-delta-introducer", "syntax", 1, argc, argv); m1 = scheme_stx_extract_marks(argv[0]); + orig_m1 = m1; m2 = scheme_stx_extract_marks(argv[1]); l1 = scheme_list_length(m1); @@ -6810,11 +6820,32 @@ static Scheme_Object *syntax_transfer_intro(int argc, Scheme_Object **argv) } if (!scheme_equal(m1, m2)) { - /* tails don't match, so keep all marks */ - while (l1) { - delta = CONS(SCHEME_CAR(m1), delta); - m1 = SCHEME_CDR(m1); - l1--; + /* tails don't match, so keep all marks --- except those that determine a module binding */ + int skipped = 0; + Scheme_Object *phase; + Scheme_Thread *p = scheme_current_thread; + + phase = scheme_make_integer(p->current_local_env + ? p->current_local_env->genv->phase + : 0); + resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped); + + if (skipped) { + /* Just keep the first `skipped' marks. */ + delta = scheme_null; + m1 = orig_m1; + while (skipped) { + delta = CONS(SCHEME_CAR(m1), delta); + m1 = SCHEME_CDR(m1); + skipped--; + } + } else { + /* Keep them all */ + while (l1) { + delta = CONS(SCHEME_CAR(m1), delta); + m1 = SCHEME_CDR(m1); + l1--; + } } } diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index e095659f65..b3534c2053 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -1102,7 +1102,7 @@ defn_targets_syntax (Scheme_Object *var, Scheme_Comp_Env *env, Scheme_Compile_In Scheme_Object *name, *pr, *bucket; name = SCHEME_STX_CAR(var); - name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL); + name = scheme_tl_id_sym(env->genv, name, NULL, 2, NULL, NULL); if (rec[drec].resolve_module_ids || !env->genv->module) { bucket = (Scheme_Object *)scheme_global_bucket(name, env->genv); @@ -5373,7 +5373,7 @@ static Scheme_Object *stx_val(Scheme_Object *name, Scheme_Object *_env) { Scheme_Env *env = (Scheme_Env *)_env; - return scheme_tl_id_sym(env, name, NULL, 2, NULL); + return scheme_tl_id_sym(env, name, NULL, 2, NULL, NULL); } static Scheme_Object * From 2b4a60ced6c62b02d13d4c0fbb7ffc3ad702a9c0 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 20 Oct 2008 14:04:10 +0000 Subject: [PATCH 18/37] Document singleton symbol types. svn: r12072 --- collects/typed-scheme/typed-scheme.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/typed-scheme.scrbl b/collects/typed-scheme/typed-scheme.scrbl index 4c7a66e389..e9ad7336e3 100644 --- a/collects/typed-scheme/typed-scheme.scrbl +++ b/collects/typed-scheme/typed-scheme.scrbl @@ -460,8 +460,8 @@ The following base types are parameteric in their type arguments. @defform[(values t ...)]{is the type of a sequence of multiple values, with types @scheme[t ...]. This can only appear as the return type of a function.} -@defform/none[v]{where @scheme[v] is a number, boolean or string, is the singleton type containing -only that value} +@defform/none[v]{where @scheme[v] is a number, boolean or string, is the singleton type containing only that value} +@defform/none['sym]{where @scheme[sym] is a symbol, is the singleton type containing only that symbol} @defform/none[i]{where @scheme[i] is an identifier can be a reference to a type name or a type variable} @defform[(Rec n t)]{is a recursive type where @scheme[n] is bound to the From aad41cc46e026059e17dc0737fd140f03835b8f9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 20 Oct 2008 16:55:55 +0000 Subject: [PATCH 19/37] require/typed is really a definition for the purpose of provide. svn: r12073 --- collects/typed-scheme/typecheck/tc-app-unit.ss | 16 ++++++++++++---- collects/typed-scheme/typecheck/tc-toplevel.ss | 4 +++- 2 files changed, 15 insertions(+), 5 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index 6114a73981..6a012fd36a 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -108,7 +108,8 @@ [else (tc-error/delayed #:stx (car stxs) - "Wrong function argument type, expected ~a, got ~a for argument ~a" + "Wrong function argument type to ~a, expected ~a, got ~a for argument ~a" + (syntax->datum (current-orig-stx)) (car doms) (car args) arg-count) (loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))])))) @@ -395,6 +396,7 @@ (define (tc/funapp f-stx args-stx ftype0 argtys expected) + ;(printf "~a~n" (syntax->datum f-stx)) (match-let* ([(list (tc-result: argtypes arg-thn-effs arg-els-effs) ...) argtys]) (let outer-loop ([ftype ftype0] [argtypes argtypes] @@ -694,7 +696,9 @@ "Cannot apply expression of type ~a, since it is not a function type" t)])] ;; even more special case for match [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) - (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*)) + (begin + (printf "got here~n") + (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*))) (let-loop-check form #'lp #'actuals #'args #'body expected)] ;; or/andmap of ... argument [(#%plain-app or/andmap f arg) @@ -717,6 +721,7 @@ (tc/funapp #'f #'(args ...) (tc-expr #'f) (map tc-expr (syntax->list #'(args ...))) expected)])) (define (let-loop-check form lp actuals args body expected) + (printf "in let-loop-check~n") (kernel-syntax-case* #`(#,args #,body #,actuals) #f (null?) [((val acc ...) ((if (#%plain-app null? val*) thn els)) @@ -730,10 +735,13 @@ (or (find-annotation #'(if (#%plain-app null? val*) thn els) a) (generalize (tc-expr/t ac))))] [ts (cons ts1 ann-ts)]) + (printf "in body~n") ;; check that the actual arguments are ok here - (map tc-expr/check (syntax->list #'(actuals ...)) ann-ts) + (for-each tc-expr/check (syntax->list #'(actuals ...)) ann-ts) + (printf "checked args~n") ;; then check that the function typechecks with the inferred types - (tc/rec-lambda/check form args body lp ts expected) + (values #;debug (tc/rec-lambda/check form args body lp ts expected)) + (printf "done~n") (ret expected))] ;; special case when argument needs inference [_ diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index 5f2d36f25b..2c3aa72e28 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -40,7 +40,9 @@ ;; require/typed [(define-values () (begin (quote-syntax (require/typed-internal nm ty)) (#%plain-app values))) - (register-type #'nm (parse-type #'ty))] + (let ([t (parse-type #'ty)]) + (register-type #'nm t) + (list (make-def-binding #'nm t)))] ;; define-typed-struct [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values))) From 714e356fb48a1bb78c850a1d2e676645c3ab0e8e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 20 Oct 2008 19:01:52 +0000 Subject: [PATCH 20/37] revert previous change svn: r12074 --- collects/typed-scheme/typecheck/tc-app-unit.ss | 16 ++++------------ 1 file changed, 4 insertions(+), 12 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index 6a012fd36a..6114a73981 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -108,8 +108,7 @@ [else (tc-error/delayed #:stx (car stxs) - "Wrong function argument type to ~a, expected ~a, got ~a for argument ~a" - (syntax->datum (current-orig-stx)) + "Wrong function argument type, expected ~a, got ~a for argument ~a" (car doms) (car args) arg-count) (loop (cdr args) (cdr doms) (cdr stxs) (add1 arg-count))])))) @@ -396,7 +395,6 @@ (define (tc/funapp f-stx args-stx ftype0 argtys expected) - ;(printf "~a~n" (syntax->datum f-stx)) (match-let* ([(list (tc-result: argtypes arg-thn-effs arg-els-effs) ...) argtys]) (let outer-loop ([ftype ftype0] [argtypes argtypes] @@ -696,9 +694,7 @@ "Cannot apply expression of type ~a, since it is not a function type" t)])] ;; even more special case for match [(#%plain-app (letrec-values ([(lp) (#%plain-lambda args . body)]) lp*) . actuals) - (begin - (printf "got here~n") - (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*))) + (and expected (not (andmap type-annotation (syntax->list #'args))) (free-identifier=? #'lp #'lp*)) (let-loop-check form #'lp #'actuals #'args #'body expected)] ;; or/andmap of ... argument [(#%plain-app or/andmap f arg) @@ -721,7 +717,6 @@ (tc/funapp #'f #'(args ...) (tc-expr #'f) (map tc-expr (syntax->list #'(args ...))) expected)])) (define (let-loop-check form lp actuals args body expected) - (printf "in let-loop-check~n") (kernel-syntax-case* #`(#,args #,body #,actuals) #f (null?) [((val acc ...) ((if (#%plain-app null? val*) thn els)) @@ -735,13 +730,10 @@ (or (find-annotation #'(if (#%plain-app null? val*) thn els) a) (generalize (tc-expr/t ac))))] [ts (cons ts1 ann-ts)]) - (printf "in body~n") ;; check that the actual arguments are ok here - (for-each tc-expr/check (syntax->list #'(actuals ...)) ann-ts) - (printf "checked args~n") + (map tc-expr/check (syntax->list #'(actuals ...)) ann-ts) ;; then check that the function typechecks with the inferred types - (values #;debug (tc/rec-lambda/check form args body lp ts expected)) - (printf "done~n") + (tc/rec-lambda/check form args body lp ts expected) (ret expected))] ;; special case when argument needs inference [_ From b173fb073efdcf3f5a9acc9188de84de32ee3cf4 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 20 Oct 2008 20:04:15 +0000 Subject: [PATCH 21/37] revert this change to fix drscheme. svn: r12075 --- collects/typed-scheme/typecheck/tc-toplevel.ss | 4 +--- 1 file changed, 1 insertion(+), 3 deletions(-) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index 2c3aa72e28..5f2d36f25b 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -40,9 +40,7 @@ ;; require/typed [(define-values () (begin (quote-syntax (require/typed-internal nm ty)) (#%plain-app values))) - (let ([t (parse-type #'ty)]) - (register-type #'nm t) - (list (make-def-binding #'nm t)))] + (register-type #'nm (parse-type #'ty))] ;; define-typed-struct [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values))) From 122f8d41dc965c1bcf4bddf7c176c58ccbaa9020 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 20 Oct 2008 20:08:05 +0000 Subject: [PATCH 22/37] PR 9852 svn: r12076 --- collects/scheme/private/contract.ss | 1 + collects/tests/mzscheme/contract-test.ss | 1 + 2 files changed, 2 insertions(+) diff --git a/collects/scheme/private/contract.ss b/collects/scheme/private/contract.ss index c1ba0f5c48..1061e62ba6 100644 --- a/collects/scheme/private/contract.ss +++ b/collects/scheme/private/contract.ss @@ -1463,6 +1463,7 @@ improve method arity mismatch contract violation error messages? (λ (x) (and (number? x) (integer? x) + (exact? x) (x . >= . 0))))) (define (integer-in start end) diff --git a/collects/tests/mzscheme/contract-test.ss b/collects/tests/mzscheme/contract-test.ss index 22f9a040be..52ef6ffe3f 100644 --- a/collects/tests/mzscheme/contract-test.ss +++ b/collects/tests/mzscheme/contract-test.ss @@ -4534,6 +4534,7 @@ so that propagation occurs. (test-flat-contract '(real-in 1 10) 3/2 20) (test-flat-contract '(string-len/c 3) "ab" "abc") (test-flat-contract 'natural-number/c 5 -1) + (test-flat-contract 'natural-number/c #e3 #i3.0) (test-flat-contract 'false/c #f #t) (test-flat-contract #t #t "x") From e2d4bc0d2bd46db59dbb5cbf0eda94f47c491719 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 21 Oct 2008 00:10:47 +0000 Subject: [PATCH 23/37] finish decompiler on syntax objects svn: r12077 --- collects/compiler/decompile.ss | 7 +- collects/compiler/zo-parse.ss | 121 +++++++++++++++++++++++++++++++-- collects/mzlib/pretty.ss | 27 ++++---- src/mzscheme/src/eval.c | 3 + src/mzscheme/src/stxobj.c | 2 +- 5 files changed, 140 insertions(+), 20 deletions(-) diff --git a/collects/compiler/decompile.ss b/collects/compiler/decompile.ss index aa851a4052..5f1248b43e 100644 --- a/collects/compiler/decompile.ss +++ b/collects/compiler/decompile.ss @@ -75,7 +75,9 @@ (if (null? stx-ids) null '(#%stx-array)) lift-ids) (map (lambda (stx id) - `(define ,id (#%decode-syntax ,(stx-encoded stx)))) + `(define ,id ,(if stx + `(#%decode-syntax ,(stx-encoded stx)) + #f))) stxs stx-ids)))] [else (error 'decompile-prefix "huh?: ~e" a-prefix)])) @@ -304,7 +306,8 @@ + - * / min max bitwise-and bitwise-ior arithmetic-shift vector-ref string-ref bytes-ref set-mcar! set-mcdr! cons mcons))] - [(4) (memq (car a) '(vector-set! string-set! bytes-set!))])) + [(4) (memq (car a) '(vector-set! string-set! bytes-set!))] + [else #f])) (cons '#%in a) a)) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index f73b98d2ce..29b7b76f5b 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -306,7 +306,7 @@ ;; not sure if it's really unsigned (integer-bytes->integer (read-bytes 4 p) #f #f)) -(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns)) +(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns mpis)) (define (cp-getc cp) (begin-with-definitions @@ -430,6 +430,11 @@ ;; Synatx unmarshaling (define-form-struct wrapped (datum wraps certs)) +(define-form-struct lexical-rename (alist)) +(define-form-struct phase-shift (amt src dest)) +(define-form-struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) +(define-form-struct all-from-module (path phase src-phase exceptions prefix)) +(define-form-struct module-binding (path mod-phase import-phase id nominal-path nominal-phase nominal-id)) (define (decode-stx cp v) (if (integer? v) @@ -515,15 +520,107 @@ ;; a mark (string->symbol (format "mark~a" (car a)))] [(vector? a) - `(#%decode-lexical-rename ,a)] + (make-lexical-rename + (let ([top (+ (/ (- (vector-length a) 2) 2) 2)]) + (let loop ([i 2]) + (if (= i top) + null + (cons (cons (vector-ref a i) + (vector-ref a (+ (- top 2) i))) + (loop (+ i 1)))))))] [(pair? a) - `(#%decode-module-rename ,a)] + (let-values ([(plus-kern? a) (if (eq? (car a) #t) + (values #t (cdr a)) + (values #f a))]) + (match a + [`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames) + (let-values ([(unmarshals renames mark-renames) + (if (vector? maybe-unmarshals) + (values null maybe-unmarshals renames) + (values maybe-unmarshals + (car renames) + (cdr renames)))]) + (make-module-rename phase + (if kind 'marked 'normal) + set-id + (map (lambda (u) + (let ([just-phase? (number? (cddr u))]) + (let-values ([(exns prefix) + (if just-phase? + (values null #f) + (let loop ([u (if just-phase? null (cdddr u))] + [a null]) + (if (pair? u) + (loop (cdr u) (cons (car u) a)) + (values (reverse a) u))))]) + (make-all-from-module + (parse-module-path-index cp (car u)) + (cadr u) + (if just-phase? + (cddr u) + (caddr u)) + exns + prefix)))) + unmarshals) + (let loop ([i 0]) + (if (= i (vector-length renames)) + null + (cons + (let ([key (vector-ref renames i)] + [make-mapping + (lambda (path mod-phase import-phase id nominal-path nominal-phase nominal-id) + (make-module-binding + (parse-module-path-index cp path) + mod-phase + import-phase + id + (parse-module-path-index cp nominal-path) + nominal-phase + (if (eq? id nominal-id) #t nominal-id)))]) + (cons key + (let ([m (vector-ref renames (add1 i))] + [parse-nominal-modidx-plus-phase + (lambda (modidx mod-phase exportname nominal-modidx-plus-phase nom-exportname) + (match nominal-modidx-plus-phase + [`(,nominal-modidx ,import-phase-plus-nominal-phase) + (match import-phase-plus-nominal-phase + [`(,import-phase ,nom-phase) + (make-mapping modidx mod-phase import-phase exportname + nominal-modidx nom-phase nom-exportname)] + [import-phase + (make-mapping modidx mod-phase import-phase exportname + modidx mod-phase nom-exportname)])] + [nominal-modidx + (make-mapping modidx mod-phase '* exportname + nominal-modidx mod-phase nom-exportname)]))]) + (match m + [`(,modidx ,mod-phase ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname) + (parse-nominal-modidx-plus-phase modidx mod-phase exportname + nominal-modidx-plus-phase nominal-exportname)] + [`(,modidx ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname) + (parse-nominal-modidx-plus-phase modidx '* exportname + nominal-modidx-plus-phase nominal-exportname)] + [`(,modidx ,nominal-modidx) + (make-mapping modidx '* '* key nominal-modidx '* key)] + [`(,modidx ,exportname) + (make-mapping modidx '* '* exportname modidx '* exportname)] + [modidx + (make-mapping modidx '* '* key modidx '* key)])))) + (loop (+ i 2))))) + mark-renames + (and plus-kern? 'plus-kern)))] + [else (error "bad module rename: ~e" a)]))] [(boolean? a) `(#%top-level-rename ,a)] [(symbol? a) '(#%mark-barrier)] [(box? a) - `(#%phase-shift ,(unbox a))] + (match (unbox a) + [`#(,amt ,src ,dest #f) + (make-phase-shift amt + (parse-module-path-index cp src) + (parse-module-path-index cp dest))] + [else (error 'parse "bad phase shift: ~e" a)])] [else (error 'decode-wraps "bad wrap element: ~e" a)]))) w))) @@ -544,6 +641,20 @@ (vector-set! (cport-symtab cp) pos v) (vector-set! (cport-decoded cp) pos #t)) +(define (parse-module-path-index cp s) + (cond + [(not s) #f] + [(module-path-index? s) + (hash-ref (cport-mpis cp) s + (lambda () + (let-values ([(name base) (module-path-index-split s)]) + (let ([v `(module-path-index-join + (quote ,name) + ,(parse-module-path-index cp base))]) + (hash-set! (cport-mpis cp) s v) + v))))] + [else `(quote ,s)])) + ;; ---------------------------------------- ;; Main parsing loop @@ -784,7 +895,7 @@ (define symtab (make-vector symtabsize (make-not-ready))) - (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash))) + (define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (for/list ([i (in-range 1 symtabsize)]) (when (not-ready? (vector-ref symtab i)) (set-cport-pos! cp (vector-ref so* (sub1 i))) diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss index c860882047..ca90839973 100644 --- a/collects/mzlib/pretty.ss +++ b/collects/mzlib/pretty.ss @@ -1088,11 +1088,13 @@ (define max-call-head-width 5) - (define (no-sharing? expr count acdr) - (if (and found (hash-table-get found (acdr expr) #f)) + (define (no-sharing? expr count apair? acdr) + (if (and found + (apair? expr) + (hash-table-get found (acdr expr) #f)) #f (or (zero? count) - (no-sharing? (acdr expr) (sub1 count) acdr)))) + (no-sharing? (acdr expr) (sub1 count) apair? acdr)))) (define (style head expr apair? acar acdr) (case (look-in-style-table head) @@ -1100,22 +1102,22 @@ syntax-rules shared unless when) - (and (no-sharing? expr 1 acdr) + (and (no-sharing? expr 1 apair? acdr) pp-lambda)) ((if set! set!-values) - (and (no-sharing? expr 1 acdr) + (and (no-sharing? expr 1 apair? acdr) pp-if)) ((cond case-lambda) - (and (no-sharing? expr 0 acdr) + (and (no-sharing? expr 0 apair? acdr) pp-cond)) ((case class) - (and (no-sharing? expr 1 acdr) + (and (no-sharing? expr 1 apair? acdr) pp-case)) ((and or import export require require-for-syntax require-for-template provide link public private override rename inherit field init) - (and (no-sharing? expr 0 acdr) + (and (no-sharing? expr 0 apair? acdr) pp-and)) ((let letrec let* let-values letrec-values let*-values @@ -1126,20 +1128,21 @@ (symbol? (acar (acdr expr)))) 2 1) + apair? acdr) pp-let)) ((begin begin0) - (and (no-sharing? expr 0 acdr) + (and (no-sharing? expr 0 apair? acdr) pp-begin)) ((do letrec-syntaxes+values) - (and (no-sharing? expr 2 acdr) + (and (no-sharing? expr 2 apair? acdr) pp-do)) ((send syntax-case instantiate module) - (and (no-sharing? expr 2 acdr) + (and (no-sharing? expr 2 apair? acdr) pp-syntax-case)) ((make-object) - (and (no-sharing? expr 1 acdr) + (and (no-sharing? expr 1 apair? acdr) pp-make-object)) (else #f))) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 70e2c235a7..5886b1ba8b 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -3518,6 +3518,9 @@ static void sfs_note_app(SFS_Info *info, Scheme_Object *rator) { if (!info->pass) { if (!info->tail_pos) { + if (SAME_OBJ(scheme_values_func, rator)) + /* no need to clear for app of `values' */ + return; if (SCHEME_PRIMP(rator)) { int opt; opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK; diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 95fc7830c3..b619c3de83 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -5518,7 +5518,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, scheme_unmarshal_wrap_set(ut, local_key, a); } else if (SCHEME_PAIRP(a)) { /* A rename table: - - ([#t] [unmarshal] #( ...) + - ([#t] [unmarshal] #( ...) . (( ( . ) ...) ...)) ; <- marked_names where a is actually two values, one of: - From f26fcdd82c1efa40fce0ea76cb562f6377c86d76 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Tue, 21 Oct 2008 07:06:48 +0000 Subject: [PATCH 24/37] Add `stepper-skipto/discard' property. Like stepper-skipto, but discards the context. This is for the contracts implementation in the DMdA teaching languages. svn: r12078 --- collects/stepper/internal-docs.txt | 10 ++++++++ collects/stepper/private/annotate.ss | 34 ++++++++++++++++------------ collects/stepper/private/shared.ss | 3 ++- 3 files changed, 31 insertions(+), 16 deletions(-) diff --git a/collects/stepper/internal-docs.txt b/collects/stepper/internal-docs.txt index f47d9be621..fefbd85372 100644 --- a/collects/stepper/internal-docs.txt +++ b/collects/stepper/internal-docs.txt @@ -202,6 +202,16 @@ Where it's used: the stepper-skipto label is used by the 2nd-pass macro-labeler and the annotator. Both are in annotate.ss. In addition to skipping inward, a stepper hint +stepper-skipto/discard : + + This is like stepper-skipto, except that it makes the stepper + replace the expression the property is attached to by the + subexpression indicated by its value. + + (This is used in the contracts implementation for "Die Macht der + Abstraktion", where procedures are wrapped in a contract-checking + context that has no impact on the reduction semantics.) + stepper-else : [ #t ] : Initially applied to the 'true' that the cond macro replaces a beginner's 'else' with, it is later transferred diff --git a/collects/stepper/private/annotate.ss b/collects/stepper/private/annotate.ss index 5a2a69a785..8107300a0e 100644 --- a/collects/stepper/private/annotate.ss +++ b/collects/stepper/private/annotate.ss @@ -387,21 +387,25 @@ . -> . (vector/p syntax? binding-set?)) (lambda (exp tail-bound pre-break? procedure-name-info) - (cond [(stepper-syntax-property exp 'stepper-skipto) - (let* ([free-vars-captured #f] ; this will be set!'ed - ;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (stepper-syntax-property expr 'stepper-skipto))] - ; WARNING! I depend on the order of evaluation in application arguments here: - [annotated (skipto/auto - exp - 'rebuild - (lambda (subterm) - (let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)]) - (set! free-vars-captured free-vars) - stx)))]) - (2vals (wcm-wrap - skipto-mark - annotated) - free-vars-captured))] + (cond [(cond + ((stepper-syntax-property exp 'stepper-skipto) 'rebuild) + ((stepper-syntax-property exp 'stepper-skipto/discard) 'discard) + (else #f)) + => (lambda (traversal) + (let* ([free-vars-captured #f] ; this will be set!'ed + ;;[dont-care (printf "expr: ~a\nskipto: ~a\n" expr (stepper-syntax-property expr 'stepper-skipto))] + ;; WARNING! I depend on the order of evaluation in application arguments here: + [annotated (skipto/auto + exp + traversal + (lambda (subterm) + (let*-2vals ([(stx free-vars) (annotate/inner subterm tail-bound pre-break? procedure-name-info)]) + (set! free-vars-captured free-vars) + stx)))]) + (2vals (wcm-wrap + skipto-mark + annotated) + free-vars-captured)))] [(stepper-syntax-property exp 'stepper-skip-completely) (2vals (wcm-wrap 13 exp) null)] diff --git a/collects/stepper/private/shared.ss b/collects/stepper/private/shared.ss index 59b55eeb08..208f50393e 100644 --- a/collects/stepper/private/shared.ss +++ b/collects/stepper/private/shared.ss @@ -481,7 +481,8 @@ ;; traversal argument is 'discard, the result of the transformation is the ;; result of this function (define (skipto/auto stx traversal transformer) - (cond [(stepper-syntax-property stx 'stepper-skipto) + (cond [(or (stepper-syntax-property stx 'stepper-skipto) + (stepper-syntax-property stx 'stepper-skipto/discard)) => (cut update <> stx (cut skipto/auto <> traversal transformer) traversal)] [else (transformer stx)])) From facb6648bb224ce7055a99dc919bc9748b01cc4a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 21 Oct 2008 07:50:09 +0000 Subject: [PATCH 25/37] Welcome to a new PLT day. svn: r12079 --- collects/repos-time-stamp/stamp.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 1581ba61d3..1b822b13f6 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "20oct2008") +#lang scheme/base (provide stamp) (define stamp "21oct2008") From d8a5a4e1c64a8620451d2c76cc0b8b320fc568b1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 21 Oct 2008 11:26:35 +0000 Subject: [PATCH 26/37] fix macro-introduced define-values-for-syntax in HtDP languages svn: r12080 --- collects/lang/private/contracts/contracts-module-begin.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/lang/private/contracts/contracts-module-begin.ss b/collects/lang/private/contracts/contracts-module-begin.ss index ac2c2764a5..637a1834a2 100644 --- a/collects/lang/private/contracts/contracts-module-begin.ss +++ b/collects/lang/private/contracts/contracts-module-begin.ss @@ -144,7 +144,7 @@ [_ (raise-syntax-error 'contract "internal error.5")]))) (define local-expand-stop-list - (list 'contract 'define-values 'define-syntaxes '#%require + (list 'contract 'define-values 'define-syntaxes 'define-values-for-syntax '#%require '#%provide 'define-data '#%app '#%datum 'define-struct 'begin 'begin0)) ;; parse-contract-expressions From 428d4070459df22496e8d840d2d0ba9c64b677b9 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 21 Oct 2008 14:47:01 +0000 Subject: [PATCH 27/37] typed-scheme tests fail enough to create a lot of noise svn: r12081 --- collects/tests/run-automated-tests.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index f5b8a1e95e..bacba4089a 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -32,7 +32,7 @@ ;; ignored, and should only be used by the mzscheme tests.) (define tests '([no-handler load "mzscheme/quiet.ss" (lib "scheme/init")] - [require "typed-scheme/run.ss"] + ;; [require "typed-scheme/run.ss"] [require "match/plt-match-tests.ss"] ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")] [require "lazy/main.ss"] From c6c4a049ee8b658459b5bf6b1564aced1afdd7b8 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 21 Oct 2008 17:58:57 +0000 Subject: [PATCH 28/37] Add new test for better error reporting. svn: r12082 --- collects/tests/typed-scheme/fail/unbound-type.ss | 9 +++++++++ 1 file changed, 9 insertions(+) create mode 100644 collects/tests/typed-scheme/fail/unbound-type.ss diff --git a/collects/tests/typed-scheme/fail/unbound-type.ss b/collects/tests/typed-scheme/fail/unbound-type.ss new file mode 100644 index 0000000000..3ae769ab65 --- /dev/null +++ b/collects/tests/typed-scheme/fail/unbound-type.ss @@ -0,0 +1,9 @@ +#; +(exn-pred 1) +#lang typed-scheme + + +(: f (Foo -> String)) +(define (f x) (string-append x)) + +(f 1) \ No newline at end of file From 3a9928474523b042f83a7a707346daa01ef63899 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 21 Oct 2008 18:01:03 +0000 Subject: [PATCH 29/37] New error handling for type parsing errors. New error type that is both top/bot. Fix provide handling if identifier is provided twice. Note that require/typed is really a definition. Fix require of #%kernel. svn: r12083 --- collects/typed-scheme/private/base-env.ss | 2 +- collects/typed-scheme/private/parse-type.ss | 7 +- collects/typed-scheme/private/prims.ss | 5 +- collects/typed-scheme/private/subtype.ss | 3 + .../private/type-effect-convenience.ss | 1 + collects/typed-scheme/rep/type-rep.ss | 3 + .../typecheck/provide-handling.ss | 135 ++++++++++-------- .../typed-scheme/typecheck/tc-app-unit.ss | 2 + .../typed-scheme/typecheck/tc-toplevel.ss | 4 +- 9 files changed, 91 insertions(+), 71 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 633e34f28c..39daf9aee9 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -4,7 +4,7 @@ scheme/list (only-in rnrs/lists-6 fold-left) '#%paramz - (rename-in '#%kernel [apply kernel:apply]) + (only-in '#%kernel [apply kernel:apply]) scheme/promise (only-in scheme/match/runtime match:error)) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index c04f26dc1e..58560d2d50 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -213,10 +213,10 @@ (make-Name #'id)] [(eq? '-> (syntax-e #'id)) (tc-error/delayed "Incorrect use of -> type constructor") - Univ] + Err] [else (tc-error/delayed "Unbound type name ~a" (syntax-e #'id)) - Univ])] + Err])] [(All . rest) (eq? (syntax-e #'All) 'All) (tc-error "All: bad syntax")] [(Opaque . rest) (eq? (syntax-e #'Opaque) 'Opqaue) (tc-error "Opaque: bad syntax")] @@ -239,8 +239,9 @@ (tc-error "Wrong number of arguments to type ~a, expected ~a but got ~a" rator (length ns) (length args))) (instantiate-poly rator args)] [(Mu: _ _) (loop (unfold rator) args)] + [(Error:) Err] [_ (tc-error/delayed "Type ~a cannot be applied, arguments were: ~a" rator args) - Univ])) + Err])) #; (let ([ty (parse-type #'id)]) #;(printf "ty is ~a" ty) diff --git a/collects/typed-scheme/private/prims.ss b/collects/typed-scheme/private/prims.ss index d6eb0a8365..a7bbcbedbe 100644 --- a/collects/typed-scheme/private/prims.ss +++ b/collects/typed-scheme/private/prims.ss @@ -52,14 +52,13 @@ This file defines two sorts of primitives. All of them are provided into any mod -(define-syntax (require/typed stx) - +(define-syntax (require/typed stx) (syntax-case* stx (rename) (lambda (x y) (eq? (syntax-e x) (syntax-e y))) [(_ lib [nm ty] ...) #'(begin (require/typed nm ty lib) ...)] [(_ nm ty lib) (identifier? #'nm) - (with-syntax ([(cnt*) (syntax->datum #'(nm))]) + (with-syntax ([(cnt*) (generate-temporaries #'(nm))]) (quasisyntax/loc stx (begin #,(syntax-property (syntax-property #'(define cnt* #f) 'typechecker:contract-def #'ty) diff --git a/collects/typed-scheme/private/subtype.ss b/collects/typed-scheme/private/subtype.ss index 1db8c33be8..4438704580 100644 --- a/collects/typed-scheme/private/subtype.ss +++ b/collects/typed-scheme/private/subtype.ss @@ -168,6 +168,9 @@ [(list t t) A0] ;; univ is top [(list _ (Univ:)) A0] + ;; error is top and bot + [(list _ (Error:)) A0] + [(list (Error:) _) A0] ;; (Un) is bot [(list _ (Union: (list))) (fail! s t)] [(list (Union: (list)) _) A0] diff --git a/collects/typed-scheme/private/type-effect-convenience.ss b/collects/typed-scheme/private/type-effect-convenience.ss index 28db30a89a..22510c5768 100644 --- a/collects/typed-scheme/private/type-effect-convenience.ss +++ b/collects/typed-scheme/private/type-effect-convenience.ss @@ -139,6 +139,7 @@ (define -Promise make-promise-ty) (define Univ (make-Univ)) +(define Err (make-Error)) (define-syntax -v (syntax-rules () diff --git a/collects/typed-scheme/rep/type-rep.ss b/collects/typed-scheme/rep/type-rep.ss index 5536a84417..4b6effb7a4 100644 --- a/collects/typed-scheme/rep/type-rep.ss +++ b/collects/typed-scheme/rep/type-rep.ss @@ -15,6 +15,9 @@ ;; t must be a Type (dt Scope (t)) +;; this is ONLY used when a type error ocurrs +(dt Error () [#:frees #f] [#:fold-rhs #:base]) + ;; i is an nat (dt B (i) [#:frees empty-hash-table (make-immutable-hasheq (list (cons i Covariant)))] diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss index 4ca36a3460..d3fb28c9d2 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/typecheck/provide-handling.ss @@ -2,7 +2,7 @@ (require (except-in "../utils/utils.ss" extend)) (require (only-in srfi/1/list s:member) - syntax/kerncase + syntax/kerncase syntax/boundmap mzlib/trace (private type-contract) (rep type-rep) @@ -23,68 +23,77 @@ (define (remove-provides forms) (filter (lambda (e) (not (provide? e))) (syntax->list forms))) -(define ((generate-prov stx-defs val-defs) form) - (define (mem? i vd) - (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car] - [else #f])) - (define (lookup-id i vd) - (def-binding-ty (mem? i vd))) - (define (mk internal-id external-id) - (cond - [(mem? internal-id val-defs) - => - (lambda (b) - (with-syntax ([id internal-id] - [out-id external-id]) - (cond [(type->contract (def-binding-ty b) (lambda () #f)) - => - (lambda (cnt) - (with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))]) - #`(begin - (define/contract cnt-id #,cnt id) +(define (generate-prov stx-defs val-defs) + (define mapping (make-free-identifier-mapping)) + (lambda (form) + (define (mem? i vd) + (cond [(s:member i vd (lambda (i j) (free-identifier=? i (binding-name j)))) => car] + [else #f])) + (define (lookup-id i vd) + (def-binding-ty (mem? i vd))) + (define (mk internal-id external-id) + (cond + ;; if it's already done, do nothing + [(free-identifier-mapping-get mapping internal-id + ;; if it wasn't there, put it in, and skip this case + (lambda () + (free-identifier-mapping-put! mapping internal-id #t) + #f)) + #'(begin)] + [(mem? internal-id val-defs) + => + (lambda (b) + (with-syntax ([id internal-id] + [out-id external-id]) + (cond [(type->contract (def-binding-ty b) (lambda () #f)) + => + (lambda (cnt) + (with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))]) + #`(begin + (define/contract cnt-id #,cnt id) + (define-syntax export-id + (if (unbox typed-context?) + (make-rename-transformer #'id) + (make-rename-transformer #'cnt-id))) + (#%provide (rename export-id out-id)))))] + [else + (with-syntax ([(export-id) (generate-temporaries #'(id))]) + #`(begin (define-syntax export-id (if (unbox typed-context?) (make-rename-transformer #'id) - (make-rename-transformer #'cnt-id))) - (#%provide (rename export-id out-id)))))] - [else - (with-syntax ([(export-id) (generate-temporaries #'(id))]) - #`(begin - (define-syntax export-id - (if (unbox typed-context?) - (make-rename-transformer #'id) - (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))) - (provide (rename-out [export-id out-id]))))])))] - [(mem? internal-id stx-defs) - => - (lambda (b) - (with-syntax ([id internal-id] - [out-id external-id]) - (with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))]) - #`(begin - (define-syntax export-id - (if (unbox typed-context?) - (make-rename-transformer #'id) - (lambda (stx) - (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id))))) - (provide (rename-out [export-id out-id]))))))] - [(eq? (syntax-e internal-id) (syntax-e external-id)) - #`(provide #,internal-id)] - [else #`(provide (rename-out [#,internal-id #,external-id]))])) - (kernel-syntax-case form #f - [(#%provide form ...) - (map - (lambda (f) - (parameterize ([current-orig-stx f]) - (syntax-case* f (struct rename all-defined protect all-defined-except all-from all-from-except) - (lambda (a b) (eq? (syntax-e a) (syntax-e b))) - [id - (identifier? #'id) - (mk #'id #'id)] - [(rename in out) - (mk #'in #'out)] - [(protect . _) - (tc-error "provide: protect not supported by Typed Scheme")] - [_ (int-err "unknown provide form")]))) - (syntax->list #'(form ...)))] - [_ (int-err "non-provide form! ~a" (syntax->datum form))])) + (lambda (stx) (tc-error/stx stx "The type of ~a cannot be converted to a contract" (syntax-e #'id))))) + (provide (rename-out [export-id out-id]))))])))] + [(mem? internal-id stx-defs) + => + (lambda (b) + (with-syntax ([id internal-id] + [out-id external-id]) + (with-syntax ([(export-id cnt-id) (generate-temporaries #'(id id))]) + #`(begin + (define-syntax export-id + (if (unbox typed-context?) + (make-rename-transformer #'id) + (lambda (stx) + (tc-error/stx stx "Macro ~a from typed module used in untyped code" (syntax-e #'out-id))))) + (provide (rename-out [export-id out-id]))))))] + [(eq? (syntax-e internal-id) (syntax-e external-id)) + #`(provide #,internal-id)] + [else #`(provide (rename-out [#,internal-id #,external-id]))])) + (kernel-syntax-case form #f + [(#%provide form ...) + (map + (lambda (f) + (parameterize ([current-orig-stx f]) + (syntax-case* f (struct rename all-defined protect all-defined-except all-from all-from-except) + (lambda (a b) (eq? (syntax-e a) (syntax-e b))) + [id + (identifier? #'id) + (mk #'id #'id)] + [(rename in out) + (mk #'in #'out)] + [(protect . _) + (tc-error "provide: protect not supported by Typed Scheme")] + [_ (int-err "unknown provide form")]))) + (syntax->list #'(form ...)))] + [_ (int-err "non-provide form! ~a" (syntax->datum form))]))) diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index 6114a73981..d0ada2721c 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -484,6 +484,8 @@ (match-let ([(list (tc-result: ts) ...) (map (lambda (f) (outer-loop (ret f e1 e2) argtypes arg-thn-effs arg-els-effs args)) fs)]) (ret (apply Un ts)))] + ;; error type is a perfectly good fcn type + [(tc-result: (Error:)) (ret (make-Error))] [(tc-result: f-ty _ _) (tc-error/expr #:return (ret (Un)) "Cannot apply expression of type ~a, since it is not a function type" f-ty)])))) diff --git a/collects/typed-scheme/typecheck/tc-toplevel.ss b/collects/typed-scheme/typecheck/tc-toplevel.ss index 5f2d36f25b..2c3aa72e28 100644 --- a/collects/typed-scheme/typecheck/tc-toplevel.ss +++ b/collects/typed-scheme/typecheck/tc-toplevel.ss @@ -40,7 +40,9 @@ ;; require/typed [(define-values () (begin (quote-syntax (require/typed-internal nm ty)) (#%plain-app values))) - (register-type #'nm (parse-type #'ty))] + (let ([t (parse-type #'ty)]) + (register-type #'nm t) + (list (make-def-binding #'nm t)))] ;; define-typed-struct [(define-values () (begin (quote-syntax (define-typed-struct-internal nm ([fld : ty] ...))) (#%plain-app values))) From 695c8979ec3d037241ba0b63b6204ce0e0be58a0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 21 Oct 2008 18:43:23 +0000 Subject: [PATCH 30/37] caml -> camel aka gamal svn: r12084 --- collects/scribblings/reference/syntax.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 64b6e2cb6d..c98d287524 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -753,7 +753,7 @@ instead of #rx"-" (string-titlecase name) ""))) scheme/base))] will get the @scheme[scheme/base] bindings that match the regexp, - and renamed to use ``caml case''.} + and renamed to use ``camel case''.} @; -------------------- @@ -783,7 +783,7 @@ instead of #rx"-" (string-titlecase name) ""))) (all-defined-out)))] will provide all defined bindings that match the regexp, and renamed - to use ``caml case''.} + to use ``camel case''.} @;------------------------------------------------------------------------ @section[#:tag "quote"]{Literals: @scheme[quote] and @scheme[#%datum]} From b349b4baa2da4b0d92ea33e3b3dcb21a18eeadee Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 21 Oct 2008 19:52:40 +0000 Subject: [PATCH 31/37] look -- a let! svn: r12085 --- collects/typed-scheme/private/base-env.ss | 32 +++++++++++++---------- 1 file changed, 18 insertions(+), 14 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 39daf9aee9..e31e1f3ca4 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -267,20 +267,24 @@ ;; regexp stuff [regexp-match - (cl-> - [((*Un -String -Regexp) -String) (-opt (-lst (-opt -String)))] - [(-Pattern -String) (-opt (-lst (-opt (*Un -Bytes -String))))] - [(-Pattern -String N) (-opt (-lst (-opt (*Un -Bytes -String))))] - [(-Pattern -String N (-opt N)) (-opt (-lst (-opt (*Un -Bytes -String))))] - [(-Pattern -String N (-opt N) (-opt -Output-Port)) (-lst (-opt (*Un -Bytes -String)))] - [(-Pattern -String (-opt N) (-opt -Output-Port)) (-lst (-opt (*Un -Bytes -String)))] - [(-Pattern -String (-opt -Output-Port)) (-lst (-opt (*Un -Bytes -String)))] - [(-Pattern (*Un -Input-Port -Bytes)) (-opt (-lst (-opt -Bytes)))] - [(-Pattern (*Un -Input-Port -Bytes) N) (-opt (-lst (-opt -Bytes)))] - [(-Pattern (*Un -Input-Port -Bytes) N (-opt N)) (-opt (-lst (-opt -Bytes)))] - [(-Pattern (*Un -Input-Port -Bytes) (-opt N)) (-opt (-lst (-opt -Bytes)))] - [(-Pattern (*Un -Input-Port -Bytes) N (-opt N) (-opt -Output-Port)) (-lst (-opt -Bytes))])] - + (let ([?outp (-opt -Output-Port)] + [?N (-opt N)] + [optlist (lambda (t) (-opt (-lst (-opt t))))] + [-StrRx (*Un -String -Regexp -PRegexp)] + [-BtsRx (*Un -Bytes -Byte-Regexp -Byte-PRegexp)] + [-InpBts (*Un -Input-Port -Bytes)]) + (cl-> [(-StrRx -String ) (optlist -String)] + [(-StrRx -String N ) (optlist -String)] + [(-StrRx -String N ?N ) (optlist -String)] + [(-StrRx -String N ?N ?outp) (optlist -String)] + [(-BtsRx -String ) (optlist -Bytes)] + [(-BtsRx -String N ) (optlist -Bytes)] + [(-BtsRx -String N ?N ) (optlist -Bytes)] + [(-BtsRx -String N ?N ?outp) (optlist -Bytes)] + [(-Pattern -InpBts ) (optlist -Bytes)] + [(-Pattern -InpBts N ) (optlist -Bytes)] + [(-Pattern -InpBts N ?N ) (optlist -Bytes)] + [(-Pattern -InpBts N ?N ?outp) (optlist -Bytes)]))] [number->string (N . -> . -String)] From 0ec881dc60a15b185c0c07ed2c36eaf992a368e9 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 21 Oct 2008 20:55:07 +0000 Subject: [PATCH 32/37] Fix type of odd and even. svn: r12086 --- collects/typed-scheme/private/base-env.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index e31e1f3ca4..f1452e1303 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -237,8 +237,8 @@ [list-tail (-poly (a) ((-lst a) -Integer . -> . (-lst a)))] [positive? (-> N B)] [negative? (-> N B)] -[odd? (-> N B)] -[even? (-> N B)] +[odd? (-> -Integer B)] +[even? (-> -Integer B)] [apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] [kernel:apply (-poly (a b) (((list) a . ->* . b) (-lst a) . -> . b))] From 505cc651814d62fc009b186d57d6159e8a576591 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 21 Oct 2008 21:24:49 +0000 Subject: [PATCH 33/37] added note about experimenting with contracts svn: r12088 --- .../scribblings/guide/contracts-intro.scrbl | 37 +++++++++++++++++++ 1 file changed, 37 insertions(+) diff --git a/collects/scribblings/guide/contracts-intro.scrbl b/collects/scribblings/guide/contracts-intro.scrbl index 4fc42f0ce5..8648fbc729 100644 --- a/collects/scribblings/guide/contracts-intro.scrbl +++ b/collects/scribblings/guide/contracts-intro.scrbl @@ -193,3 +193,40 @@ services, it also demands the client to deliver something. This kind of thing happens when a module exports a function, an object, a class or other values that enable values to flow in both directions. + +@ctc-section{Experimenting with examples} + +All of the contracts and module in this chapter (excluding those just +following) are written using the standard @tt{#lang} syntax for +describing modules. Thus, if you extract examples from this chapter in +order to experiment with the behavior of the contract system, you +would have to make multiple files. + +To rectify this, PLT Scheme provides a special language, called +@tt{scheme/load}. The contents of such a module is other modules (and +@scheme[require] statements), using the parenthesized syntax for a +module. For example, to try the example earlier in this section, you +would write: +@schememod[ +scheme/load + +(module m scheme + (define amount 150) + (provide/contract [amount (and/c number? positive?)])) + +(module n scheme + (require 'm) + (+ amount 10)) + +(require 'n)] + +Each of the modules and their contracts are wrapped in parenthesis +with the @scheme[module] keyword at the front. The first argument to +@scheme[module] should be the name of the module, so it can be used in +a subsequent @scheme[require] statement (note that in the +@scheme[require], the name of the module must be prefixed with a +quote). The second argument to @scheme[module] is the language (what +would have come lang @tt{#lang} in the usual notation), and the +remaining arguments are the body of the module. After all of the +modules, there must a @scheme[require] to kick things off. + From 567ef6d95c00d68a57f6b152556a7da6f86fbac4 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 21 Oct 2008 23:02:37 +0000 Subject: [PATCH 34/37] added half-assed prompt-avoiding control-a keybinding svn: r12089 --- collects/drscheme/private/language.ss | 25 ++++++++++++++++++++++--- collects/drscheme/private/rep.ss | 25 +++++++++++++++++++++++++ 2 files changed, 47 insertions(+), 3 deletions(-) diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 9e5228a149..47cdae2694 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -1086,12 +1086,31 @@ (λ () (with-handlers ([(λ (x) #t) (λ (x) - (display (exn-message x)) - (newline))]) + (parameterize ([current-error-port original-output-port]) + ((error-display-handler) + (if (exn? x) + (exn-message x) + (format "~s" x)) + x)) + (printf "~a\n" (if (exn? x) + (exn-message x) + (format "~s" x))))]) (when module-spec (if use-copy? (namespace-require/copy module-spec) - (namespace-require/constant module-spec))) + (let ([t (current-thread)]) + (thread + (λ () + (let loop ([i 5]) + (unless (zero? i) + (printf "sleeping ... ~a\n" i) + (sleep 1) + (loop (- i 1)))) + (printf "breaking...\n") + (break-thread t) + (printf "broke\n"))) + (break-enabled #t) + (namespace-require/constant module-spec)))) (when transformer-module-spec (namespace-require `(for-syntax ,transformer-module-spec))))))) diff --git a/collects/drscheme/private/rep.ss b/collects/drscheme/private/rep.ss index cabd4c33a1..c49bb2fda4 100644 --- a/collects/drscheme/private/rep.ss +++ b/collects/drscheme/private/rep.ss @@ -323,6 +323,26 @@ TODO (define setup-scheme-interaction-mode-keymap (λ (keymap) + (define (beginning-of-line text select?) + (let* ([para (send text position-line (send text get-start-position))] + [para-start (send text line-start-position para)] + [prompt (send text get-prompt)] + [para-start-text (send text get-text para-start (+ para-start (string-length prompt)))] + [new-start + (cond + [(equal? prompt para-start-text) + (+ para-start (string-length prompt))] + [else + para-start])]) + (if select? + (send text set-position new-start (send text get-end-position)) + (send text set-position new-start new-start)))) + + (send keymap add-function "beginning-of-line/prompt" + (λ (text event) (beginning-of-line text #f))) + (send keymap add-function "select-to-beginning-of-line/prompt" + (λ (text event) (beginning-of-line text #t))) + (send keymap add-function "put-previous-sexp" (λ (text event) (send text copy-prev-previous-expr))) @@ -330,6 +350,11 @@ TODO (λ (text event) (send text copy-next-previous-expr))) + (send keymap map-function "c:a" "beginning-of-line/prompt") + (send keymap map-function "s:c:a" "select-to-beginning-of-line/prompt") + (send keymap map-function "home" "beginning-of-line/prompt") + (send keymap map-function "s:home" "select-to-beginning-of-line/prompt") + (keymap:send-map-function-meta keymap "p" "put-previous-sexp") (keymap:send-map-function-meta keymap "n" "put-next-sexp") (send keymap map-function "c:up" "put-previous-sexp") From e102ee95740432d25362b01677b14e0d5fef58dc Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 21 Oct 2008 23:04:48 +0000 Subject: [PATCH 35/37] undid last commit ... oops svn: r12090 --- collects/drscheme/private/language.ss | 25 +++---------------------- 1 file changed, 3 insertions(+), 22 deletions(-) diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 47cdae2694..9e5228a149 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -1086,31 +1086,12 @@ (λ () (with-handlers ([(λ (x) #t) (λ (x) - (parameterize ([current-error-port original-output-port]) - ((error-display-handler) - (if (exn? x) - (exn-message x) - (format "~s" x)) - x)) - (printf "~a\n" (if (exn? x) - (exn-message x) - (format "~s" x))))]) + (display (exn-message x)) + (newline))]) (when module-spec (if use-copy? (namespace-require/copy module-spec) - (let ([t (current-thread)]) - (thread - (λ () - (let loop ([i 5]) - (unless (zero? i) - (printf "sleeping ... ~a\n" i) - (sleep 1) - (loop (- i 1)))) - (printf "breaking...\n") - (break-thread t) - (printf "broke\n"))) - (break-enabled #t) - (namespace-require/constant module-spec)))) + (namespace-require/constant module-spec))) (when transformer-module-spec (namespace-require `(for-syntax ,transformer-module-spec))))))) From 7005c324d480b76e9bc66304bcc5c823a04eb3c8 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 22 Oct 2008 12:23:44 +0000 Subject: [PATCH 36/37] typos svn: r12091 --- collects/scribblings/guide/contracts-intro.scrbl | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/guide/contracts-intro.scrbl b/collects/scribblings/guide/contracts-intro.scrbl index 8648fbc729..bcef700631 100644 --- a/collects/scribblings/guide/contracts-intro.scrbl +++ b/collects/scribblings/guide/contracts-intro.scrbl @@ -203,7 +203,7 @@ order to experiment with the behavior of the contract system, you would have to make multiple files. To rectify this, PLT Scheme provides a special language, called -@tt{scheme/load}. The contents of such a module is other modules (and +@schememodname[scheme/load]. The contents of such a module is other modules (and @scheme[require] statements), using the parenthesized syntax for a module. For example, to try the example earlier in this section, you would write: @@ -220,13 +220,13 @@ scheme/load (require 'n)] -Each of the modules and their contracts are wrapped in parenthesis +Each of the modules and their contracts are wrapped in parentheses with the @scheme[module] keyword at the front. The first argument to @scheme[module] should be the name of the module, so it can be used in a subsequent @scheme[require] statement (note that in the @scheme[require], the name of the module must be prefixed with a quote). The second argument to @scheme[module] is the language (what -would have come lang @tt{#lang} in the usual notation), and the +would have come after @tt{#lang} in the usual notation), and the remaining arguments are the body of the module. After all of the modules, there must a @scheme[require] to kick things off. From 5f5faacf29c5e43718069bd9b803d15364832fd6 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 22 Oct 2008 12:55:48 +0000 Subject: [PATCH 37/37] fixed a bug Mike Sperber reported svn: r12092 --- collects/drscheme/private/language.ss | 4 +++- collects/lang/htdp-langs.ss | 34 ++++++++++++--------------- 2 files changed, 18 insertions(+), 20 deletions(-) diff --git a/collects/drscheme/private/language.ss b/collects/drscheme/private/language.ss index 9e5228a149..1e282e30e5 100644 --- a/collects/drscheme/private/language.ss +++ b/collects/drscheme/private/language.ss @@ -1086,7 +1086,9 @@ (λ () (with-handlers ([(λ (x) #t) (λ (x) - (display (exn-message x)) + (display (if (exn? x) + (exn-message x) + (format "~s" x))) (newline))]) (when module-spec (if use-copy? diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 82004b4038..0dc74efd39 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -167,8 +167,7 @@ (namespace-require scheme-test-module-name) (scheme-test-data (list (drscheme:rep:current-rep) drs-eventspace test-display%)) (test-execute (get-preference 'tests:enable? (lambda () #t))) - (test-format (make-formatter (lambda (v o) (render-value/format v settings o 40)))) - ))) + (test-format (make-formatter (lambda (v o) (render-value/format v settings o 40))))))) (super on-execute settings run-in-user-thread)) (define/private (teaching-languages-error-value->string settings v len) @@ -1034,22 +1033,19 @@ (thread-cell-set! current-test-coverage-info ht) (let ([rep (drscheme:rep:current-rep)]) (when rep - (let ([s (make-semaphore 0)]) - (parameterize ([current-eventspace drs-eventspace]) - (queue-callback - (λ () - (let ([on-sd (make-object style-delta%)] - [off-sd (make-object style-delta%)]) - (cond - [(preferences:get 'framework:white-on-black?) - (send on-sd set-delta-foreground "white") - (send off-sd set-delta-foreground "indianred")] - [else - (send on-sd set-delta-foreground "black") - (send off-sd set-delta-foreground "firebrick")]) - (send rep set-test-coverage-info ht on-sd off-sd #f)) - (semaphore-post s)))) - (semaphore-wait s)))))) + (parameterize ([current-eventspace drs-eventspace]) + (queue-callback + (λ () + (let ([on-sd (make-object style-delta%)] + [off-sd (make-object style-delta%)]) + (cond + [(preferences:get 'framework:white-on-black?) + (send on-sd set-delta-foreground "white") + (send off-sd set-delta-foreground "indianred")] + [else + (send on-sd set-delta-foreground "black") + (send off-sd set-delta-foreground "firebrick")]) + (send rep set-test-coverage-info ht on-sd off-sd #f))))))))) (let ([ht (thread-cell-ref current-test-coverage-info)]) (when ht (hash-set! ht key (mcons #f expr))))) @@ -1124,7 +1120,7 @@ (lambda (exp) (let* ([is-compiled? (compiled-expression? (if (syntax? exp) (syntax-e exp) exp))] [annotated - (if is-compiled? + (if is-compiled? exp (let* ([et-annotated (et:annotate-top (expand exp) (namespace-base-phase))]