From 940a47a439a4754dc767f1f7fd0d9767b5aeaa97 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 12 Mar 2009 17:22:45 +0000 Subject: [PATCH 001/140] fix include references svn: r14075 --- collects/tests/scribble/text/i03.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/tests/scribble/text/i03.ss b/collects/tests/scribble/text/i03.ss index 636fd376f1..ee9d7f9ea9 100644 --- a/collects/tests/scribble/text/i03.ss +++ b/collects/tests/scribble/text/i03.ss @@ -12,7 +12,7 @@ blah @angled{blah @shout{@z} blah} blah @twice{@twice{blah}} -@include{i3a} +@include{i03a} -@(let ([name "Eli"]) (let ([foo (include "i3b")]) (list foo "\n" foo))) +@(let ([name "Eli"]) (let ([foo (include "i03b")]) (list foo "\n" foo))) Repeating yourself much? From 422b9414bd2f94ca40a090ac2dc32cd9e38ace13 Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Thu, 12 Mar 2009 17:23:45 +0000 Subject: [PATCH 002/140] check for functions in the test specification svn: r14076 --- collects/test-engine/scheme-tests.ss | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/collects/test-engine/scheme-tests.ss b/collects/test-engine/scheme-tests.ss index 67e0090568..89e72076dd 100644 --- a/collects/test-engine/scheme-tests.ss +++ b/collects/test-engine/scheme-tests.ss @@ -17,10 +17,14 @@ (define INEXACT-NUMBERS-FMT "check-expect cannot compare inexact numbers. Try (check-within test ~a range).") +(define FUNCTION-FMT + "check-expect cannot compare functions.") (define CHECK-ERROR-STR-FMT "check-error requires a string for the second argument, representing the expected error message. Given ~s") (define CHECK-WITHIN-INEXACT-FMT "check-within requires an inexact number for the range. ~a is not inexact.") +(define CHECK-WITHIN-FUNCTION-FMT + "check-within cannot compare functions.") (define-for-syntax CHECK-EXPECT-STR "check-expect requires two expressions. Try (check-expect test expected).") @@ -113,7 +117,8 @@ ;; check-values-expected: (-> scheme-val) scheme-val src -> void (define (check-values-expected test actual src test-info) (error-check (lambda (v) (if (number? v) (exact? v) #t)) - actual INEXACT-NUMBERS-FMT) + actual INEXACT-NUMBERS-FMT #t) + (error-check (lambda (v) (not (procedure? v))) actual FUNCTION-FMT #f) (send (send test-info get-info) add-check) (run-and-check (lambda (v1 v2 _) (beginner-equal? v1 v2)) (lambda (src v1 v2 _) (make-unequal src v1 v2)) @@ -130,7 +135,8 @@ [_ (raise-syntax-error 'check-within CHECK-WITHIN-STR stx)])) (define (check-values-within test actual within src test-info) - (error-check number? within CHECK-WITHIN-INEXACT-FMT) + (error-check number? within CHECK-WITHIN-INEXACT-FMT #t) + (error-check (lambda (v) (not (procedure? v))) actual CHECK-WITHIN-FUNCTION-FMT #f) (send (send test-info get-info) add-check) (run-and-check beginner-equal~? make-outofrange test actual within src test-info @@ -147,7 +153,7 @@ [_ (raise-syntax-error 'check-error CHECK-ERROR-STR stx)])) (define (check-values-error test error src test-info) - (error-check string? error CHECK-ERROR-STR-FMT) + (error-check string? error CHECK-ERROR-STR-FMT #t) (send (send test-info get-info) add-check) (let ([result (with-handlers ([exn? (lambda (e) @@ -165,9 +171,9 @@ #t))) -(define (error-check pred? actual fmt) +(define (error-check pred? actual fmt fmt-act?) (unless (pred? actual) - (raise (make-exn:fail:contract (format fmt actual) + (raise (make-exn:fail:contract (if fmt-act? (format fmt actual) fmt) (current-continuation-marks))))) From 35374355648e0be9cdd93f9df4d74bb04b3d554f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 12 Mar 2009 18:25:08 +0000 Subject: [PATCH 003/140] dont show spaces at the end of a line when not needed svn: r14077 --- collects/scribble/text/output.ss | 84 +++++++++++++++------------- collects/tests/scribble/text/i12.ss | 10 ++++ collects/tests/scribble/text/o12.txt | 5 ++ 3 files changed, 61 insertions(+), 38 deletions(-) create mode 100644 collects/tests/scribble/text/i12.ss create mode 100644 collects/tests/scribble/text/o12.txt diff --git a/collects/scribble/text/output.ss b/collects/scribble/text/output.ss index f0e5e80dd0..04b32f6208 100644 --- a/collects/scribble/text/output.ss +++ b/collects/scribble/text/output.ss @@ -19,9 +19,11 @@ ;; system (when line counts are enabled) -- this is used to tell what part of a ;; prefix is already displayed. ;; -;; Each prefix is either an integer (for a number of spaces), a string, or #f -;; indicating that prefixes are disabled (different from 0 -- they will not be -;; accumulated). +;; Each prefix is either an integer (for a number of spaces) or a +;; string. The prefix mechanism can be disabled by using #f for the +;; global prefix, and in this case the line prefix can have (cons pfx +;; lpfx) so it can be restored -- used by `verbatim' and `unverbatim' +;; resp. (This is different from 0 -- no prefix will be accumulated). ;; (define (output x [p (current-output-port)]) ;; these are the global prefix and the one that is local to the current line @@ -63,6 +65,37 @@ (let ([col (- col len1)] [len2 (if (number? pfx2) pfx2 (string-length pfx2))]) (when (< col len2) (write-string (->str pfx2) p col )))]))))) + ;; the basic printing unit: strings + (define (output-string x) + (define pfx (mcar pfxs)) + (if (not pfx) ; vervatim mode? + (write-string x p) + (let ([len (string-length x)] + [nls (regexp-match-positions* #rx"\n" x)]) + (let loop ([start 0] [nls nls] [lpfx (mcdr pfxs)] [col (getcol)]) + (cond [(pair? nls) + (let ([nl (car nls)]) + (if (regexp-match? #rx"^ *$" x start (car nl)) + (newline p) ; only spaces before the end of the line + (begin (output-pfx col pfx lpfx) + (write-string x p start (cdr nl)))) + (loop (cdr nl) (cdr nls) 0 0))] + ;; last substring from here (always set lpfx state when done) + [(start . = . len) + (set-mcdr! pfxs lpfx)] + [(col . > . (2pfx-length pfx lpfx)) + (set-mcdr! pfxs lpfx) + ;; the prefix was already shown, no accumulation needed + (write-string x p start)] + [else + (let ([m (regexp-match-positions #rx"^ +" x start)]) + ;; accumulate spaces to lpfx, display if it's not all spaces + (let ([lpfx (if m (pfx+ lpfx (- (cdar m) (caar m))) lpfx)]) + (set-mcdr! pfxs lpfx) + (unless (and m (= len (cdar m))) + (output-pfx col pfx lpfx) + ;; the spaces were already added to lpfx + (write-string x p (if m (cdar m) start)))))]))))) ;; main loop (define (loop x) (cond @@ -114,41 +147,16 @@ [else (error 'output "unknown special value flag: ~e" (special-flag x))]))] [else - (let* ([x (cond [(string? x) x] - [(bytes? x) (bytes->string/utf-8 x)] - [(symbol? x) (symbol->string x)] - [(path? x) (path->string x)] - [(keyword? x) (keyword->string x)] - [(number? x) (number->string x)] - [(char? x) (string x)] - ;; generic fallback: throw an error - [else (error 'output "don't know how to render value: ~v" - x)])] - [len (string-length x)] - [nls (regexp-match-positions* #rx"\n" x)] - [pfx (mcar pfxs)]) - (let loop ([start 0] [nls nls] [lpfx (mcdr pfxs)] [col (getcol)]) - (cond [(pair? nls) - (let ([nl (car nls)]) - (output-pfx col pfx lpfx) - (write-string x p start (cdr nl)) - (loop (cdr nl) (cdr nls) 0 0))] - ;; last substring from here (always set lpfx state when done) - [(start . = . len) - (set-mcdr! pfxs lpfx)] - [(col . > . (2pfx-length pfx lpfx)) - (set-mcdr! pfxs lpfx) - ;; the prefix was already shown, no accumulation needed - (write-string x p start)] - [else - (let ([m (regexp-match-positions #rx"^ +" x start)]) - ;; accumulate spaces to lpfx, display if it's not all spaces - (let ([lpfx (if m (pfx+ lpfx (- (cdar m) (caar m))) lpfx)]) - (set-mcdr! pfxs lpfx) - (unless (and m (= len (cdar m))) - (output-pfx col pfx lpfx) - ;; the spaces were already added to lpfx - (write-string x p (if m (cdar m) start)))))])))])) + (output-string + (cond [(string? x) x] + [(bytes? x) (bytes->string/utf-8 x)] + [(symbol? x) (symbol->string x)] + [(path? x) (path->string x)] + [(keyword? x) (keyword->string x)] + [(number? x) (number->string x)] + [(char? x) (string x)] + ;; generic fallback: throw an error + [else (error 'output "don't know how to render value: ~v" x)]))])) ;; (port-count-lines! p) (loop x) diff --git a/collects/tests/scribble/text/i12.ss b/collects/tests/scribble/text/i12.ss new file mode 100644 index 0000000000..397ef801ff --- /dev/null +++ b/collects/tests/scribble/text/i12.ss @@ -0,0 +1,10 @@ +#!/bin/env mzscheme +#lang scribble/text + + @list{ + a + + b + } + + c diff --git a/collects/tests/scribble/text/o12.txt b/collects/tests/scribble/text/o12.txt new file mode 100644 index 0000000000..2a9aec7436 --- /dev/null +++ b/collects/tests/scribble/text/o12.txt @@ -0,0 +1,5 @@ + a + + b + + c From c20a9ab7a816b671066fe48dea156f70ed28285f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 12 Mar 2009 18:59:37 +0000 Subject: [PATCH 004/140] yet more formattings svn: r14078 --- src/foreign/foreign.c | 84 +++++++++++++++++++++---------------------- 1 file changed, 41 insertions(+), 43 deletions(-) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 016404bd68..5159b251d5 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -1733,17 +1733,17 @@ static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object *argv[]) if (basetype == 0) basetype = 1; /* int is the default type */ /* don't assume anything, so it can be used to verify compiler assumptions */ /* (only forbid stuff that the compiler doesn't allow) */ -#define RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *)) +# define RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *)) switch (basetype) { case 1: /* int */ switch (intsize) { case 0: RETSIZE(int); break; case 1: RETSIZE(long int); break; -#ifdef INT64_AS_LONG_LONG +# ifdef INT64_AS_LONG_LONG case 2: RETSIZE(_int64); break; /* MSVC doesn't allow long long */ -#else +# else /* INT64_AS_LONG_LONG undefined */ case 2: RETSIZE(long long int); break; -#endif +# endif /* INT64_AS_LONG_LONG */ case -1: RETSIZE(short int); break; } break; @@ -1768,7 +1768,7 @@ static Scheme_Object *foreign_compiler_sizeof(int argc, Scheme_Object *argv[]) scheme_signal_error(MYNAME": internal error (unexpected type %d)", basetype); } -#undef RETSIZE +# undef RETSIZE return scheme_make_integer(res); } #undef MYNAME @@ -2139,7 +2139,7 @@ static Scheme_Object *abs_sym; /* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ /* if n is given, an 'abs flag can precede it to make n be a byte offset rather - * than some multiple of sizeof(type). */ +/* than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ #define MYNAME "ptr-ref" static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) @@ -2192,7 +2192,7 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) /* (ptr-set! cpointer type [['abs] n] value) -> void */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ /* if n is given, an 'abs flag can precede it to make n be a byte offset rather - * than some multiple of sizeof(type). */ +/* than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ #define MYNAME "ptr-set!" static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[]) @@ -2253,11 +2253,11 @@ static Scheme_Object *foreign_ptr_equal_p(int argc, Scheme_Object *argv[]) /* (make-sized-byte-string cpointer len) */ #define MYNAME "make-sized-byte-string" static Scheme_Object *foreign_make_sized_byte_string(int argc, Scheme_Object *argv[]) -/* Warning: no copying is done so it is possible to share string contents. */ -/* Warning: if source ptr has a offset, resulting string object uses shifted - * pointer. - * (Should use real byte-strings with new version.) */ { + /* Warning: no copying is done so it is possible to share string contents. */ + /* Warning: if source ptr has a offset, resulting string object uses shifted + * pointer. + * (Should use real byte-strings with new version.) */ long len; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); @@ -2302,31 +2302,29 @@ void do_ptr_finalizer(void *p, void *finalizer) /* unreachable, and it will get a new cpointer object that points to it. */ /* (Only needed in cases where pointer aliases might be created.) */ /* - -(defsymbols pointer) -(cdefine register-finalizer 2 3) -{ - void *ptr, *old = NULL; - int ptrsym = (argc == 3 && argv[2] == pointer_sym); - if (ptrsym) { - if (!SCHEME_FFIANYPTRP(argv[0])) - scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); - ptr = SCHEME_FFIANYPTR_VAL(argv[0]); - if (ptr == NULL) - scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); - } else { - if (argc == 3) - scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv); - ptr = argv[0]; - } - if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1]))) - scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv); - scheme_register_finalizer - (ptr, (ptrsym ? do_ptr_finalizer : do_scm_finalizer), - argv[1], NULL, &old); - return (old == NULL) ? scheme_false : (Scheme_Object*)old; -} -*/ + * defsymbols[pointer] + * cdefine[register-finalizer 2 3]{ + * void *ptr, *old = NULL; + * int ptrsym = (argc == 3 && argv[2] == pointer_sym); + * if (ptrsym) { + * if (!SCHEME_FFIANYPTRP(argv[0])) + * scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); + * ptr = SCHEME_FFIANYPTR_VAL(argv[0]); + * if (ptr == NULL) + * scheme_wrong_type(MYNAME, "non-null-cpointer", 0, argc, argv); + * } else { + * if (argc == 3) + * scheme_wrong_type(MYNAME, "pointer-mode", 2, argc, argv); + * ptr = argv[0]; + * } + * if (!(SCHEME_FALSEP(argv[1]) || SCHEME_PROCP(argv[1]))) + * scheme_wrong_type(MYNAME, "procedure-or-false", 1, argc, argv); + * scheme_register_finalizer + * (ptr, (ptrsym ? do_ptr_finalizer : do_scm_finalizer), + * argv[1], NULL, &old); + * return (old == NULL) ? scheme_false : (Scheme_Object*)old; + * } + */ /*****************************************************************************/ /* Calling foreign function objects */ @@ -2415,7 +2413,7 @@ Scheme_Object *ffi_do_call(void *data, int argc, Scheme_Object *argv[]) /* Otherwise it was a struct pointer, and avalues[i] is already fine. */ /* Add offset, if any: */ if (offsets[i] != 0) { - ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i]; + ivals[i].x_pointer = (char *)ivals[i].x_pointer + offsets[i]; } } /* Finally, call the function */ @@ -2643,16 +2641,16 @@ static Scheme_Object *foreign_ffi_callback(int argc, Scheme_Object *argv[]) data->itypes = (argv[1]); data->otype = (argv[2]); data->call_in_scheduler = (((argc > 4) && SCHEME_TRUEP(argv[4]))); -#ifdef MZ_PRECISE_GC +# ifdef MZ_PRECISE_GC { /* put data in immobile, weak box */ void **tmp; tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0)); cl_cif_args->data = (struct immobile_box*)tmp; } -#else +# else /* MZ_PRECISE_GC undefined */ cl_cif_args->data = (void*)data; -#endif +# endif /* MZ_PRECISE_GC */ if (ffi_prep_closure(cl, cif, &ffi_do_callback, (void*)(cl_cif_args->data)) != FFI_OK) scheme_signal_error @@ -2697,12 +2695,12 @@ void scheme_init_foreign(Scheme_Env *env) ffi_obj_tag = scheme_make_type(""); ctype_tag = scheme_make_type(""); ffi_callback_tag = scheme_make_type(""); -#ifdef MZ_PRECISE_GC +# ifdef MZ_PRECISE_GC GC_register_traversers(ffi_lib_tag, ffi_lib_SIZE, ffi_lib_MARK, ffi_lib_FIXUP, 1, 0); GC_register_traversers(ffi_obj_tag, ffi_obj_SIZE, ffi_obj_MARK, ffi_obj_FIXUP, 1, 0); GC_register_traversers(ctype_tag, ctype_SIZE, ctype_MARK, ctype_FIXUP, 1, 0); GC_register_traversers(ffi_callback_tag, ffi_callback_SIZE, ffi_callback_MARK, ffi_callback_FIXUP, 1, 0); -#endif +# endif /* MZ_PRECISE_GC */ scheme_set_type_printer(ctype_tag, ctype_printer); MZ_REGISTER_STATIC(opened_libs); opened_libs = scheme_make_hash_table(SCHEME_hash_string); @@ -2757,7 +2755,7 @@ void scheme_init_foreign(Scheme_Env *env) scheme_add_global("make-ctype", scheme_make_prim_w_arity(foreign_make_ctype, "make-ctype", 3, 3), menv); scheme_add_global("make-cstruct-type", - scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 1), menv); + scheme_make_prim_w_arity(foreign_make_cstruct_type, "make-cstruct-type", 1, 2), menv); scheme_add_global("ffi-callback?", scheme_make_prim_w_arity(foreign_ffi_callback_p, "ffi-callback?", 1, 1), menv); scheme_add_global("cpointer?", From 0373964141091598627a8d4e070002590c868116 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 12 Mar 2009 19:02:16 +0000 Subject: [PATCH 005/140] Finally a version that uses the new preprocessor language. svn: r14079 --- src/foreign/foreign.ssc | 918 +++++++++++++++++++-------------------- src/foreign/ssc-utils.ss | 218 ++++++---- 2 files changed, 576 insertions(+), 560 deletions(-) diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index 4a19b20652..92e8b468ea 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -1,24 +1,17 @@ #!/bin/sh -#| -exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0" +#| -*- C -*- +exec mzscheme "$0" > `echo "$0" | sed 's/ssc$/c/'` "$0" |# ----begin -<<{:<<>>:}>> -/******************************************** - ** Do not edit this file! - ** This file is generated from {:current-file:}, - ** to make changes, edit that file and - ** run it to generate an updated version - ** of this file. - ** NOTE: This is no longer true, foreign.ssc needs to be updated to work with - ** the scribble/text preprocessor instead. - ********************************************/ -{:(load "ssc-utils.ss"):} +#lang scribble/text + +@(require "ssc-utils.ss") + +@header{foreign.ssc} #include "schpriv.h" -#ifndef WINDOWS_DYNAMIC_LOAD +@@@IFNDEF{WINDOWS_DYNAMIC_LOAD}{ # include @@ -59,7 +52,7 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0" # error "configuration error, please contact PLT (int64)" # endif -#else +}{ # include # ifndef __CYGWIN32__ @@ -74,7 +67,7 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0" typedef unsigned _int64 Tuint64; # endif -#endif +} #include "ffi.h" @@ -95,7 +88,7 @@ exec mzpp -s "---begin" -o `echo "$0" | sed 's/ssc$/c/'` "$0" only available in NT 4.0 and later. The alternative, Module32{First,Next}, is available *except* for NT 4.0! So we try EnumProcessModules first. */ -#ifdef WINDOWS_DYNAMIC_LOAD +@@IFDEF{WINDOWS_DYNAMIC_LOAD}{ #ifdef MZ_PRECISE_GC START_XFORM_SKIP; #endif @@ -153,25 +146,23 @@ BOOL mzEnumProcessModules(HANDLE hProcess, HMODULE* lphModule, } } - #ifdef MZ_PRECISE_GC END_XFORM_SKIP; #endif -#endif +} /*****************************************************************************/ /* Library objects */ -{:(cdefstruct ffi-lib - (handle "void*") - (name "Scheme_Object*") - (objects "Scheme_Hash_Table*")):} +@cdefstruct[ffi-lib + [handle "void*"] + [name "Scheme_Object*"] + [objects "Scheme_Hash_Table*"]] static Scheme_Hash_Table *opened_libs; /* (ffi-lib filename no-error?) -> ffi-lib */ -{:(cdefine ffi-lib 1 2):} -{ +@cdefine[ffi-lib 1 2]{ char *name; Scheme_Object *path, *hashname; void *handle; @@ -187,34 +178,32 @@ static Scheme_Hash_Table *opened_libs; lib = (ffi_lib_struct*)scheme_hash_get(opened_libs, hashname); if (!lib) { Scheme_Hash_Table *ht; -#ifdef WINDOWS_DYNAMIC_LOAD - if (name==NULL) { - /* openning the executable is marked by a NULL handle */ - handle = NULL; - null_ok = 1; - } else - handle = LoadLibrary(name); -#else - handle = dlopen(name, RTLD_NOW | RTLD_GLOBAL); -#endif + @@@IFDEF{WINDOWS_DYNAMIC_LOAD}{ + if (name==NULL) { + /* openning the executable is marked by a NULL handle */ + handle = NULL; + null_ok = 1; + } else + handle = LoadLibrary(name); + }{ + handle = dlopen(name, RTLD_NOW | RTLD_GLOBAL); + } if (handle == NULL && !null_ok) { if (argc > 1 && SCHEME_TRUEP(argv[1])) return scheme_false; else { -#ifdef WINDOWS_DYNAMIC_LOAD - long err; - err = GetLastError(); - scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, - MYNAME": couldn't open %V (%E)", argv[0], err); -#else - scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, - MYNAME": couldn't open %V (%s)", argv[0], dlerror()); -#endif + @@@IFDEF{WINDOWS_DYNAMIC_LOAD}{ + long err; + err = GetLastError(); + scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, + MYNAME": couldn't open %V (%E)", argv[0], err); + }{ + scheme_raise_exn(MZEXN_FAIL_FILESYSTEM, + MYNAME": couldn't open %V (%s)", argv[0], dlerror()); + } } } ht = scheme_make_hash_table(SCHEME_hash_string); - {:(cmake-object "lib" ffi-lib - "handle" "argv[0]" - "ht"):} + @cmake["lib" ffi-lib "handle" "argv[0]" "ht"] scheme_hash_set(opened_libs, hashname, (Scheme_Object*)lib); /* no dlclose finalizer - since the hash table always keeps a reference */ /* maybe add some explicit unload at some point */ @@ -223,8 +212,7 @@ static Scheme_Hash_Table *opened_libs; } /* (ffi-lib-name ffi-lib) -> string */ -{:(cdefine ffi-lib-name 1):} -{ +@cdefine[ffi-lib-name 1]{ if (!SCHEME_FFILIBP(argv[0])) scheme_wrong_type(MYNAME, "ffi-lib", 0, argc, argv); return ((ffi_lib_struct*)argv[0])->name; @@ -233,14 +221,13 @@ static Scheme_Hash_Table *opened_libs; /*****************************************************************************/ /* Pull pointers (mostly functions) out of ffi-lib objects */ -{:(cdefstruct ffi-obj - (obj "void*") - (name "char*") - (lib "ffi_lib_struct*")):} +@cdefstruct[ffi-obj + [obj "void*"] + [name "char*"] + [lib "ffi_lib_struct*"]] /* (ffi-obj objname ffi-lib-or-libname) -> ffi-obj */ -{:(cdefine ffi-obj 2):} -{ +@cdefine[ffi-obj 2]{ ffi_obj_struct *obj; void *dlobj; ffi_lib_struct *lib = NULL; @@ -256,35 +243,35 @@ static Scheme_Hash_Table *opened_libs; dlname = SCHEME_BYTE_STR_VAL(argv[0]); obj = (ffi_obj_struct*)scheme_hash_get(lib->objects, (Scheme_Object*)dlname); if (!obj) { -#ifdef WINDOWS_DYNAMIC_LOAD + @@@IFDEF{WINDOWS_DYNAMIC_LOAD}{ if (lib->handle) { dlobj = GetProcAddress(lib->handle, dlname); } else { /* this is for the executable-open case, which was marked by a NULL * handle, deal with it by searching all current modules */ -# define NUM_QUICK_MODS 16 + @DEFINE{NUM_QUICK_MODS 16} HMODULE *mods, me, quick_mods[NUM_QUICK_MODS]; DWORD cnt = NUM_QUICK_MODS * sizeof(HMODULE), actual_cnt, i; me = GetCurrentProcess(); mods = quick_mods; if (mzEnumProcessModules(me, mods, cnt, &actual_cnt)) { if (actual_cnt > cnt) { - cnt = actual_cnt; - mods = (HMODULE *)scheme_malloc_atomic(cnt); - if (!mzEnumProcessModules(me, mods, cnt, &actual_cnt)) - mods = NULL; - } else - cnt = actual_cnt; + cnt = actual_cnt; + mods = (HMODULE *)scheme_malloc_atomic(cnt); + if (!mzEnumProcessModules(me, mods, cnt, &actual_cnt)) + mods = NULL; + } else + cnt = actual_cnt; } else - mods = NULL; + mods = NULL; if (mods) { - cnt /= sizeof(HMODULE); - for (i = 0; i < cnt; i++) { - dlobj = GetProcAddress(mods[i], dlname); - if (dlobj) break; - } + cnt /= sizeof(HMODULE); + for (i = 0; i < cnt; i++) { + dlobj = GetProcAddress(mods[i], dlname); + if (dlobj) break; + } } else - dlobj = NULL; + dlobj = NULL; } if (!dlobj) { long err; @@ -293,7 +280,7 @@ static Scheme_Hash_Table *opened_libs; MYNAME": couldn't get \"%s\" from %V (%E)", dlname, lib->name, err); } -#else + }{ dlobj = dlsym(lib->handle, dlname); if (!dlobj) { const char *err; @@ -303,24 +290,22 @@ static Scheme_Hash_Table *opened_libs; MYNAME": couldn't get \"%s\" from %V (%s)", dlname, lib->name, err); } -#endif - {:(cmake-object "obj" ffi-obj "dlobj" "dlname" "lib"):} + } + @cmake["obj" ffi-obj "dlobj" "dlname" "lib"] scheme_hash_set(lib->objects, (Scheme_Object*)dlname, (Scheme_Object*)obj); } return (obj == NULL) ? scheme_false : (Scheme_Object*)obj; } /* (ffi-obj-lib ffi-obj) -> ffi-lib */ -{:(cdefine ffi-obj-lib 1):} -{ +@cdefine[ffi-obj-lib 1]{ if (!SCHEME_FFIOBJP(argv[0])) scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv); return (Scheme_Object*)(((ffi_obj_struct*)argv[0])->lib); } /* (ffi-obj-name ffi-obj) -> string */ -{:(cdefine ffi-obj-name 1):} -{ +@cdefine[ffi-obj-name 1]{ if (!SCHEME_FFIOBJP(argv[0])) scheme_wrong_type(MYNAME, "ffi-obj", 0, argc, argv); return scheme_make_byte_string(((ffi_obj_struct*)argv[0])->name); @@ -337,7 +322,7 @@ static Scheme_Hash_Table *opened_libs; #define scheme_make_integer_from_unsigned(i) \ ((Scheme_Object *)((((unsigned long)i) << 1) | 0x1)) -#ifndef SIXTY_FOUR_BIT_INTEGERS +@@@IFNDEF{SIXTY_FOUR_BIT_INTEGERS}{ /* longs and ints are really the same */ #define scheme_get_realint_val(x,y) \ @@ -349,7 +334,7 @@ static Scheme_Hash_Table *opened_libs; #define scheme_make_realinteger_value_from_unsigned \ scheme_make_integer_value_from_unsigned -#else /* SIXTY_FOUR_BIT_INTEGERS defined */ +}{ /* These will make sense in MzScheme when longs are longer than ints (needed * for libffi's int32 types). There is no need to deal with bignums because @@ -381,7 +366,7 @@ inline int scheme_get_unsigned_realint_val(Scheme_Object *o, unsigned int *v) #define scheme_make_realinteger_value_from_unsigned(ri) \ scheme_make_integer((unsigned long)(ri)) -#endif /* SIXTY_FOUR_BIT_INTEGERS */ +} /* This is related to the section of scheme.h that defines mzlonglong. */ #ifndef INT64_AS_LONG_LONG @@ -430,7 +415,7 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) /*****************************************************************************/ /* Types */ -{: +@(begin ;; Types are defined with the `defctype' function. This looks like: ;; (defctype 'type-name ;; 'prop1 val1 @@ -455,38 +440,39 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) ;; offset: if specified as "X", use "SCHEME_X_OFFSET" to extract an offset ;; value for s->c, otherwise leave 0 as the offset -(define types '()) +(define types null) + +(require (for-syntax scheme/base)) (define (get-prop type prop) (cadr (assq prop (cdr (assq type types))))) -(define *type-counter* 0) +(define type-counter + (let ([c 0]) + (lambda ([flag #f]) + (case flag + [(#f) (set! c (add1 c)) c] + [(last) (begin0 (add1 c) (set! c #f))] + [else (error "internal error")])))) -(define (describe-type type stype cname ftype ctype pred s->c c->s offset) - (set! *type-counter* (add1 *type-counter*)) - (~ "#define FOREIGN_"cname" ("*type-counter*")" \\ - "/* Type Name: "stype (and (not (equal? cname stype)) - (list " ("cname")")) \\ - " * LibFfi type: ffi_type_"ftype \\ - " * C type: "(or ctype "-none-") \\ - " * Predicate: "(cond [(not pred) "-none-"] - [(procedure? pred) (pred "" "aux")] - [else (list pred"()")]) \\ - " * Scheme->C: "(cond - [(not s->c) - (if pred "-none- (set by the predicate)" "-none-")] - [(procedure? s->c) (s->c "" "aux")] - [else (list s->c"()")]) \\ - " * S->C offset: "(cond - [(not offset) "0"] - [else offset]) \\ - " * C->Scheme: "(cond [(not c->s) "-none-"] - [(procedure? c->s) (c->s "")] - [else (list c->s"()")]) \\ - " */" \\ - ;; no need for these, at least for now: - ;; "static Scheme_Object *"cname"_sym;"\\ - )) +(define (describe-type stype cname ftype ctype pred s->c c->s offset) + @list{ + #define FOREIGN_@cname (@(type-counter)) + /* Type Name: @stype@(and (not (equal? cname stype)) @list{ (@cname)}) + * LibFfi type: ffi_type_@ftype + * C type: @(or ctype "-none-") + * Predicate: @(cond [(not pred) "-none-"] + [(procedure? pred) (pred "" "aux")] + [else @list{@|pred|()}]) + * Scheme->C: @(cond [(not s->c) + (if pred "-none- (set by the predicate)" "-none-")] + [(procedure? s->c) (s->c "" "aux")] + [else @list{@|s->c|()}]) + * S->C offset: @(or offset 0) + * C->Scheme: @(cond [(not c->s) "-none-"] + [(procedure? c->s) (c->s "")] + [else @list{@|c->s|()}]) + */}) (define (make-ctype type args) (define (prop p . default) @@ -507,22 +493,29 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) "int"))] [ftype (regexp-replace #rx"^(int|char|long)" ftype "s\\1")] [macro (prop 'macro)] - [pred (prop 'pred (and macro (list "SCHEME_"macro"P")))] - [s->c (prop 's->c (and macro (list "SCHEME_"macro"_VAL")))] + [pred (prop 'pred (and macro @list{SCHEME_@|macro|P}))] + [s->c (prop 's->c (and macro @list{SCHEME_@|macro|_VAL}))] [c->s (prop 'c->s)] [offset (prop 'offset #f)]) - (describe-type type stype cname ftype ctype pred s->c c->s offset) + (output (describe-type stype cname ftype ctype pred s->c c->s offset)) `(,type (stype ,stype) (cname ,cname) (ftype ,ftype) (ctype ,ctype) (macro ,macro) (pred ,pred) (s->c ,s->c) (c->s ,c->s) (offset ,offset)))) (define (defctype name . args) - (set! types (append! types (list (make-ctype name args))))) + (set! types (append types (list (make-ctype name args))))) -(define-syntax (for-each-type stx) +(define-syntax (map-types stx) (syntax-case stx () [(_ body ...) - (let ([id (lambda (sym) (datum->syntax-object (syntax _) sym))]) - (with-syntax ([stype (id 'stype)] + (let () + (define (id sym) (datum->syntax stx sym stx)) + (define-values (exprs semi?) + (syntax-case stx () + [(_ #:semicolons? s? body ...) (values #'(body ...) #'s?)] + [(_ body ...) (values #'(body ...) #'#t)])) + (with-syntax ([(body ...) exprs] + [semi? semi?] + [stype (id 'stype)] [cname (id 'cname)] [ctype (id 'ctype)] [ftype (id 'ftype)] @@ -532,22 +525,22 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) [c->s (id 'c->s)] [offset (id 'offset)] [ptr? (id 'ptr?)]) - #'(for-each - (lambda (t) - (define data (cdr t)) - (define (get sym) (cadr (assq sym data))) - (let* ([stype (get 'stype)] - [cname (get 'cname)] - [ftype (get 'ftype)] - [ctype (get 'ctype)] - [macro (get 'macro)] - [pred (get 'pred)] - [s->c (get 's->c)] - [c->s (get 'c->s)] - [offset (get 'offset)] - [ptr? (equal? "pointer" ftype)]) - body ...)) - types)))])) + #'(maplines #:semicolons? 'semi? + (lambda (t) + (define data (cdr t)) + (define (get sym) (cadr (assq sym data))) + (let* ([stype (get 'stype)] + [cname (get 'cname)] + [ftype (get 'ftype)] + [ctype (get 'ctype)] + [macro (get 'macro)] + [pred (get 'pred)] + [s->c (get 's->c)] + [c->s (get 'c->s)] + [offset (get 'offset)] + [ptr? (equal? "pointer" ftype)]) + body ...)) + types)))])) (define (defctype* name/+ftype ctype pred s->c c->s) (let ([name (if (pair? name/+ftype) (car name/+ftype) name/+ftype)] @@ -555,192 +548,197 @@ Scheme_Object *utf16_pointer_to_ucs4_string(unsigned short *utf) (apply defctype name `(ctype ,ctype ,@(if ftype `(ftype ,ftype) `()) - pred ,(if (string? pred) (list "SCHEME_"pred"P") pred) - s->c ,(if (string? s->c) (list "SCHEME_"s->c"_VAL") s->c) - c->s ,(if (string? c->s) (list "scheme_make_"c->s) c->s))))) + pred ,(if (string? pred) @list{SCHEME_@|pred|P} pred) + s->c ,(if (string? s->c) @list{SCHEME_@|s->c|_VAL} s->c) + c->s ,(if (string? c->s) @list{scheme_make_@|c->s|} c->s))))) -(~ "/***********************************************************************"\\ - " * The following are the only primitive types." \\ - " * The tricky part is figuring out what width-ed types correspond to"\\ - " * what internal types. Matthew says:" \\ - " * MzScheme expects to be compiled such that sizeof(int) == 4," \\ - " * sizeof(long) == sizeof(void*), sizeof(short) >= 2," \\ - " * sizeof(char) == 1, sizeof(float) == 4, and sizeof(double) == 8." \\ - " * So, on a 64-bit OS, MzScheme expects only `long' to change." \\ - " **********************************************************************/"\\ - ) +) -(~ "/* returns # when used as output type, not for input types. */") -(defctype 'void - 'ctype #f 'pred #f 's->c #f 'c->s (lambda (x) "scheme_void")) +/*********************************************************************** + * The following are the only primitive types. + * The tricky part is figuring out what width-ed types correspond to + * what internal types. Matthew says: + * MzScheme expects to be compiled such that sizeof(int) == 4, + * sizeof(long) == sizeof(void*), sizeof(short) >= 2, + * sizeof(char) == 1, sizeof(float) == 4, and sizeof(double) == 8. + * So, on a 64-bit OS, MzScheme expects only `long' to change. + **********************************************************************/ -;; libffi primitive types -;; scheme-name c-type SCHEME_?P SCHEME_?_VAL scheme_make_ -(defctype* 'int8 "Tsint8" "INT" "INT" "integer") -(defctype* 'uint8 "Tuint8" "INT" "UINT" "integer_from_unsigned") -(defctype* 'int16 "Tsint16" "INT" "INT" "integer") -(defctype* 'uint16 "Tuint16" "INT" "UINT" "integer_from_unsigned") +/* returns # when used as output type, not for input types. */ +@(defctype 'void + 'ctype #f 'pred #f 's->c #f 'c->s (lambda (x) "scheme_void")) -(~ "/* Treats integers properly: */") -(defctype* 'int32 "Tsint32" - (lambda (x aux) (list "scheme_get_realint_val("x",&"aux")")) #f +@; libffi primitive types +@; scheme-name c-type SCHEME_?P SCHEME_?_VAL scheme_make_ +@(defctype* 'int8 "Tsint8" "INT" "INT" "integer") + +@(defctype* 'uint8 "Tuint8" "INT" "UINT" "integer_from_unsigned") + +@(defctype* 'int16 "Tsint16" "INT" "INT" "integer") + +@(defctype* 'uint16 "Tuint16" "INT" "UINT" "integer_from_unsigned") + +/* Treats integers properly: */ +@(defctype* 'int32 "Tsint32" + (lambda (x aux) @list{scheme_get_realint_val(@x,&@aux)}) #f "realinteger_value") -(~ "/* Treats integers properly: */") -(defctype* 'uint32 "Tuint32" - (lambda (x aux) (list "scheme_get_unsigned_realint_val("x",&"aux")")) #f - "realinteger_value_from_unsigned") -;; mzlonglong is always assumed to be 64 bits, or the above will throw an error -(defctype* 'int64 "Tsint64" - (lambda (x aux) (list "scheme_get_long_long_val("x",&"aux")")) #f - "integer_value_from_long_long") -(defctype* 'uint64 "Tuint64" - (lambda (x aux) (list "scheme_get_unsigned_long_long_val("x",&"aux")")) #f - "integer_value_from_unsigned_long_long") +/* Treats integers properly: */ +@(defctype* 'uint32 "Tuint32" + (lambda (x aux) @list{scheme_get_unsigned_realint_val(@x,&@aux)}) #f + "realinteger_value_from_unsigned") -(~ "/* This is like int32, but always assumes fixnum: */") -(defctype* '(fixint "int32") "Tsint32" "INT" "INT" "integer") -(~ "/* This is like uint32, but always assumes fixnum: */") -(defctype* '(ufixint "uint32") "Tuint32" "INT" "UINT" "integer_from_unsigned") +@; mzlonglong is always assumed to be 64 bits, or the above will throw an error +@(defctype* 'int64 "Tsint64" + (lambda (x aux) @list{scheme_get_long_long_val(@x,&@aux)}) #f + "integer_value_from_long_long") -(~ "/* This is what mzscheme defines as long: */" \\ - "#ifndef SIXTY_FOUR_BIT_INTEGERS" \\ - "#define ffi_type_smzlong ffi_type_sint32" \\ - "#define ffi_type_umzlong ffi_type_uint32" \\ - "#else" \\ - "#define ffi_type_smzlong ffi_type_sint64" \\ - "#define ffi_type_umzlong ffi_type_uint64" \\ - "#endif" \\) +@(defctype* 'uint64 "Tuint64" + (lambda (x aux) @list{scheme_get_unsigned_long_long_val(@x,&@aux)}) #f + "integer_value_from_unsigned_long_long") -#| implemented in Scheme -(~ "/* This is what mzscheme defines as long: */") +/* This is like int32, but always assumes fixnum: */ +@(defctype* '(fixint "int32") "Tsint32" "INT" "INT" "integer") + +/* This is like uint32, but always assumes fixnum: */ +@(defctype* '(ufixint "uint32") "Tuint32" "INT" "UINT" "integer_from_unsigned") + +/* This is what mzscheme defines as long: */ +@@@IFNDEF{SIXTY_FOUR_BIT_INTEGERS}{ +#define ffi_type_smzlong ffi_type_sint32 +#define ffi_type_umzlong ffi_type_uint32 +}{ +#define ffi_type_smzlong ffi_type_sint64 +#define ffi_type_umzlong ffi_type_uint64 +} + +@;{ implemented in Scheme +/* This is what mzscheme defines as long: */ (defctype* '(long "smzlong") "long" - (lambda (x aux) (list "scheme_get_int_val("x",&"aux")")) #f + (lambda (x aux) list{scheme_get_int_val(@x,&@aux)}) #f "integer_value") -(~ "/* This is what mzscheme defines as ulong: */") +@line{/* This is what mzscheme defines as ulong: */} (defctype* '(ulong "umzlong") "unsigned long" - (lambda (x aux) (list "scheme_get_unsigned_int_val("x",&"aux")")) #f + (lambda (x aux) @list{scheme_get_unsigned_int_val(@x,&@aux)}) #f "integer_value_from_unsigned") -|# +;}@; +@; +/* This is what mzscheme defines as long, assuming fixnums: */ +@(defctype* '(fixnum "smzlong") + "long" "INT" "INT" "integer") -(~ "/* This is what mzscheme defines as long, assuming fixnums: */") -(defctype* '(fixnum "smzlong") - "long" "INT" "INT" "integer") -(~ "/* This is what mzscheme defines as ulong, assuming fixnums: */") -(defctype* '(ufixnum "umzlong") - "unsigned long" "INT" "UINT" "integer_from_unsigned") +/* This is what mzscheme defines as ulong, assuming fixnums: */ +@(defctype* '(ufixnum "umzlong") + "unsigned long" "INT" "UINT" "integer_from_unsigned") -(defctype* 'float "float" "FLT" "FLT" "float") -(defctype* 'double "double" "DBL" "DBL" "double") -;; Not useful? not implemented in any case. -;; (defctype* 'longdouble "long double" ...???...) +@(defctype* 'float "float" "FLT" "FLT" "float") -(~ "/* A double that will coerce numbers to doubles: */") -(defctype* '(double* "double") "double" - ;; use a list to avoid automatic "SCHEME_..._VAL" wrapping - "REAL" '("scheme_real_to_double") "double") +@(defctype* 'double "double" "DBL" "DBL" "double") +@; +@; Not useful? not implemented in any case. +@; (defctype* 'longdouble "long double" ...???...) -(~ "/* Booleans -- implemented as an int which is 1 or 0: */") -(defctype 'bool - 'ftype "int" - 'pred (lambda (x aux) "1") - 's->c "SCHEME_TRUEP" - 'c->s (lambda (x) (list "("x"?scheme_true:scheme_false)"))) +/* A double that will coerce numbers to doubles: */ +@(defctype* '(double* "double") "double" + ;; use a list to avoid automatic "SCHEME_..._VAL" wrapping + "REAL" '("scheme_real_to_double") "double") -(~ "/* Strings -- no copying is done (when possible)." \\ - " * #f is not NULL only for byte-strings, for other strings it is" \\ - " * meaningless to use NULL. */" \\ - ) +/* Booleans -- implemented as an int which is 1 or 0: */ +@(defctype 'bool + 'ftype "int" + 'pred (lambda (x aux) "1") + 's->c "SCHEME_TRUEP" + 'c->s (lambda (x) @list{(@|x|?scheme_true:scheme_false)})) -(defctype 'string/ucs-4 - 'ftype "pointer" - 'ctype "mzchar*" - 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" - 's->c "ucs4_string_or_null_to_ucs4_pointer" - 'c->s "scheme_make_char_string_without_copying") +/* Strings -- no copying is done (when possible). + * #f is not NULL only for byte-strings, for other strings it is + * meaningless to use NULL. */ -(defctype 'string/utf-16 - 'ftype "pointer" - 'ctype "unsigned short*" - 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" - 's->c "ucs4_string_or_null_to_utf16_pointer" - 'c->s "utf16_pointer_to_ucs4_string") +@(defctype 'string/ucs-4 + 'ftype "pointer" + 'ctype "mzchar*" + 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" + 's->c "ucs4_string_or_null_to_ucs4_pointer" + 'c->s "scheme_make_char_string_without_copying") -(~ "/* Byte strings -- not copying C strings, #f is NULL." \\ - " * (note: these are not like char* which is just a pointer) */" \\ - ) +@(defctype 'string/utf-16 + 'ftype "pointer" + 'ctype "unsigned short*" + 'pred "SCHEME_FALSEP_OR_CHAR_STRINGP" + 's->c "ucs4_string_or_null_to_utf16_pointer" + 'c->s "utf16_pointer_to_ucs4_string") -(defctype 'bytes - 'ftype "pointer" - 'ctype "char*" - 'pred (lambda (x aux) - (list "SCHEME_FALSEP("x")||SCHEME_BYTE_STRINGP("x")")) - 's->c (lambda (x aux) - (list "SCHEME_FALSEP("x")?NULL:SCHEME_BYTE_STR_VAL("x")")) - 'c->s (lambda (x) - (list "("x"==NULL)?scheme_false:" - "scheme_make_byte_string_without_copying("x")"))) +/* Byte strings -- not copying C strings, #f is NULL. + * (note: these are not like char* which is just a pointer) */ -(defctype 'path - 'ftype "pointer" - 'ctype "char*" - 'pred (lambda (x aux) - (list "SCHEME_FALSEP("x")||SCHEME_PATH_STRINGP("x")")) - 's->c (lambda (x aux) - (list "SCHEME_FALSEP("x")?NULL:SCHEME_PATH_VAL(TO_PATH("x"))")) - 'c->s (lambda (x) - (list "("x"==NULL)?scheme_false:" - "scheme_make_path_without_copying("x")"))) +@(defctype 'bytes + 'ftype "pointer" + 'ctype "char*" + 'pred (lambda (x aux) + @list{SCHEME_FALSEP(@x)||SCHEME_BYTE_STRINGP(@x)}) + 's->c (lambda (x aux) + @list{SCHEME_FALSEP(@x)?NULL:SCHEME_BYTE_STR_VAL(@x)}) + 'c->s (lambda (x) + @list{(@|x|==NULL)?scheme_false:@; + scheme_make_byte_string_without_copying(@x)})) -(defctype 'symbol - 'ftype "pointer" - 'ctype "char*" - 'pred "SCHEME_SYMBOLP" - 's->c "SCHEME_SYM_VAL" - 'c->s "scheme_intern_symbol") +@(defctype 'path + 'ftype "pointer" + 'ctype "char*" + 'pred (lambda (x aux) + @list{SCHEME_FALSEP(@x)||SCHEME_PATH_STRINGP(@x)}) + 's->c (lambda (x aux) + @list{SCHEME_FALSEP(@x)?NULL:SCHEME_PATH_VAL(TO_PATH(@x))}) + 'c->s (lambda (x) + @list{(@|x|==NULL)?scheme_false:@; + scheme_make_path_without_copying(@x)})) -(~ "/* This is for any C pointer: #f is NULL, cpointer values as well as" \\ - " * ffi-obj and string values pass their pointer. When used as a return" \\ - " * value, either a cpointer object or #f is returned. */") -(defctype 'pointer - 'ctype "void*" - 'macro "FFIANYPTR" - 'offset "FFIANYPTR" - 'c->s "scheme_make_foreign_cpointer") +@(defctype 'symbol + 'ftype "pointer" + 'ctype "char*" + 'pred "SCHEME_SYMBOLP" + 's->c "SCHEME_SYM_VAL" + 'c->s "scheme_intern_symbol") -;; This is probably not needed -;; (~ "/* Used for ffi-callback objects: */") -;; (defctype 'callback -;; 'ftype "pointer" -;; 'ctype "void*" -;; 'macro "FFICALLBACK" -;; 's->c (lambda (x aux) (list "((ffi_callback_struct*)("x"))->callback")) -;; 'c->s (lambda (x) x)) +/* This is for any C pointer: #f is NULL, cpointer values as well as + * ffi-obj and string values pass their pointer. When used as a return + * value, either a cpointer object or #f is returned. */ +@(defctype 'pointer + 'ctype "void*" + 'macro "FFIANYPTR" + 'offset "FFIANYPTR" + 'c->s "scheme_make_foreign_cpointer") -(~ "/* This is used for passing and Scheme_Object* value as is. Useful for" \\ - " * functions that know about Scheme_Object*s, like MzScheme's. */") -(defctype 'scheme - 'ftype "pointer" - 'ctype "Scheme_Object*" - 'pred (lambda (x aux) "1") - 's->c (lambda (x aux) x) - 'c->s (lambda (x) x)) +@; This is probably not needed +@; /* Used for ffi-callback objects: */ +@; @(defctype 'callback +@; 'ftype "pointer" +@; 'ctype "void*" +@; 'macro "FFICALLBACK" +@; 's->c (lambda (x aux) @list{((ffi_callback_struct*)(@x))->callback}) +@; 'c->s (lambda (x) x)) +@; +/* This is used for passing and Scheme_Object* value as is. Useful for + * functions that know about Scheme_Object*s, like MzScheme's. */ +@(defctype 'scheme + 'ftype "pointer" + 'ctype "Scheme_Object*" + 'pred (lambda (x aux) "1") + 's->c (lambda (x aux) x) + 'c->s (lambda (x) x)) -(~ "/* Special type, not actually used for anything except to mark values" \\ - " * that are treated like pointers but not referenced. Used for" \\ - " * creating function types. */") -(defctype 'fpointer 'ftype "pointer" 'ctype "void*") +/* Special type, not actually used for anything except to mark values + * that are treated like pointers but not referenced. Used for + * creating function types. */ +@(defctype 'fpointer 'ftype "pointer" 'ctype "void*") -:} typedef union _ForeignAny { - {:(for-each-type (when ctype (~ ctype" x_"cname";"))):} + @(map-types (when ctype @list{@ctype x_@cname})) } ForeignAny; -{: (set! *type-counter* (add1 *type-counter*)) - (~ "/* This is a tag that is used to identify user-made struct types. */" \\ - "#define FOREIGN_struct ("*type-counter*")") - (set! *type-counter* #f) ; make sure this is the last one defined -:} +/* This is a tag that is used to identify user-made struct types. */ +@; last makes sure this is the last one value that gets used +#define FOREIGN_struct (@(type-counter 'last)) /*****************************************************************************/ /* Type objects */ @@ -756,10 +754,10 @@ typedef union _ForeignAny { * integer is not really needed, since it is possible to identify the * type by the basetype field.) */ -{:(cdefstruct ctype - (basetype "Scheme_Object*") - (scheme_to_c "Scheme_Object*") - (c_to_scheme "Scheme_Object*")):} +@cdefstruct[ctype + [basetype "Scheme_Object*"] + [scheme_to_c "Scheme_Object*"] + [c_to_scheme "Scheme_Object*"]] #define CTYPE_BASETYPE(x) (((ctype_struct*)(x))->basetype) #define CTYPE_USERP(x) (CTYPE_BASETYPE(x) != NULL && SCHEME_CTYPEP(CTYPE_BASETYPE(x))) @@ -770,23 +768,20 @@ typedef union _ForeignAny { #define CTYPE_USER_C2S(x) (((ctype_struct*)(x))->c_to_scheme) /* Returns #f for primitive types. */ -{:(cdefine ctype-basetype 1):} -{ +@cdefine[ctype-basetype 1]{ if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); return CTYPE_BASETYPE(argv[0]); } -{:(cdefine ctype-scheme->c 1):} -{ +@cdefine[ctype-scheme->c 1]{ if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); return (CTYPE_PRIMP(argv[0])) ? scheme_false : ((ctype_struct*)(argv[0]))->scheme_to_c; } -{:(cdefine ctype-c->scheme 1):} -{ +@cdefine[ctype-c->scheme 1]{ if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "ctype", 0, argc, argv); return (CTYPE_PRIMP(argv[0])) ? scheme_false : @@ -807,9 +802,8 @@ static int ctype_sizeof(Scheme_Object *type) type = get_ctype_base(type); if (type == NULL) return -1; switch (CTYPE_PRIMLABEL(type)) { - {:(for-each-type - (~ "case FOREIGN_"cname": return " - (if ctype (list "sizeof("ctype");") "0;"))):} + @(map-types @list{case FOREIGN_@|cname|: @; + return @(if ctype @list{sizeof(@ctype)} "0")}) /* for structs */ default: return CTYPE_PRIMTYPE(type)->size; } @@ -819,8 +813,7 @@ static int ctype_sizeof(Scheme_Object *type) /* The scheme->c can throw type errors to check for valid arguments */ /* a #f means no conversion function, if both are #f -- then just return the */ /* basetype. */ -{:(cdefine make-ctype 3):} -{ +@cdefine[make-ctype 3]{ ctype_struct *type; if (!SCHEME_CTYPEP(argv[0])) scheme_wrong_type(MYNAME, "C-type", 0, argc, argv); @@ -831,10 +824,10 @@ static int ctype_sizeof(Scheme_Object *type) else if (SCHEME_FALSEP(argv[1]) && SCHEME_FALSEP(argv[2])) return argv[0]; else { - {:(cmake-object "type" ctype "argv[0]" "argv[1]" "argv[2]"):} + @cmake["type" ctype "argv[0]" "argv[1]" "argv[2]"] return (Scheme_Object*)type; } - return NULL; /* hush the compiler */ + @hush } /* see below */ @@ -847,7 +840,7 @@ void free_libffi_type(void *ignored, void *p) /*****************************************************************************/ /* ABI spec */ -{:(defsymbols default stdcall sysv):} +@defsymbols[default stdcall sysv] ffi_abi sym_to_abi(char *who, Scheme_Object *sym) { @@ -882,8 +875,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) /* This creates a new primitive type that is a struct. This type can be used * with cpointer objects, except that the contents is used rather than the * pointer value. Marshaling to lists or whatever should be done in Scheme. */ -{:(cdefine make-cstruct-type 1):} -{ +@cdefine[make-cstruct-type 1 2]{ Scheme_Object *p, *base; /* since ffi_type objects can be used in callbacks, they are allocated using * malloc so they don't move, and they are freed when the Scheme object is @@ -916,9 +908,9 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) dummy = &libffi_type; if (ffi_prep_cif(&cif, abi, 1, &ffi_type_void, dummy) != FFI_OK) scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); - {:(cmake-object "type" ctype "argv[0]" - "(Scheme_Object*)libffi_type" - "(Scheme_Object*)FOREIGN_struct"):} + @cmake["type" ctype "argv[0]" + "(Scheme_Object*)libffi_type" + "(Scheme_Object*)FOREIGN_struct"] scheme_register_finalizer(type, free_libffi_type, libffi_type, NULL, NULL); return (Scheme_Object*)type; } @@ -926,12 +918,12 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) /*****************************************************************************/ /* Callback type */ -{:(cdefstruct ffi-callback - (callback "void*") - (proc "Scheme_Object*") - (itypes "Scheme_Object*") - (otype "Scheme_Object*") - (call_in_scheduler "int")):} +@cdefstruct[ffi-callback + [callback "void*"] + [proc "Scheme_Object*"] + [itypes "Scheme_Object*"] + [otype "Scheme_Object*"] + [call_in_scheduler "int"]] /*****************************************************************************/ /* Pointer objects */ @@ -958,13 +950,11 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) #define scheme_make_foreign_cpointer(x) \ ((x==NULL)?scheme_false:scheme_make_cptr(x,NULL)) -{:(cdefine cpointer? 1):} -{ +@cdefine[cpointer? 1]{ return SCHEME_FFIANYPTRP(argv[0]) ? scheme_true : scheme_false; } -{:(cdefine cpointer-tag 1):} -{ +@cdefine[cpointer-tag 1]{ Scheme_Object *tag = NULL; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); @@ -972,8 +962,7 @@ ffi_abi sym_to_abi(char *who, Scheme_Object *sym) return (tag == NULL) ? scheme_false : tag; } -{:(cdefine set-cpointer-tag! 2):} -{ +@cdefine[set-cpointer-tag! 2]{ if (!SCHEME_CPTRP(argv[0])) scheme_wrong_type(MYNAME, "proper-cpointer", 0, argc, argv); SCHEME_CPTR_TYPE(argv[0]) = argv[1]; @@ -1012,17 +1001,17 @@ static Scheme_Object *C2SCHEME(Scheme_Object *type, void *src, } else if (CTYPE_PRIMLABEL(type) == FOREIGN_fpointer) { return scheme_make_foreign_cpointer(*(void **)W_OFFSET(src, delta)); } else switch (CTYPE_PRIMLABEL(type)) { - {:(for-each-type - (~ "case FOREIGN_"cname": return " - (if ctype - (let ([x (list "REF_CTYPE("ctype")")]) - (if (procedure? c->s) (c->s x) (list c->s"("x")"))) - "scheme_void")";")):} + @(map-types + @list{case FOREIGN_@|cname|: return @; + @(if ctype + (let ([x (list "REF_CTYPE("ctype")")]) + (if (procedure? c->s) (c->s x) (list c->s"("x")"))) + "scheme_void")}) case FOREIGN_struct: return scheme_make_foreign_cpointer(W_OFFSET(src, delta)); default: scheme_signal_error("corrupt foreign type: %V", type); } - return NULL; /* hush the compiler */ + @hush } #undef REF_CTYPE @@ -1061,57 +1050,59 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, else /* ((void**)W_OFFSET(dst,delta))[0] = val; */ scheme_wrong_type("Scheme->C", "cpointer", 0, 1, &val); } else switch (CTYPE_PRIMLABEL(type)) { - {:(for-each-type - (define (wrong-type obj type) - (list "scheme_wrong_type(\"Scheme->C\",\""type"\",0,1,&("obj"));")) - (~ "case FOREIGN_"cname":") - (if (and ctype (not (equal? stype "fpointer"))) - (let* ([x (list "((("ctype"*)W_OFFSET(dst,delta))[0])")] - [f (lambda (p) - (if (procedure? p) (p "val" x) (list p"(val)")))]) - (if s->c - (begin - (display "#ifdef SCHEME_BIG_ENDIAN\n") - (~ " if (sizeof("ctype")c)");") - (when offset - (~ " toff = SCHEME_"offset"_OFFSET(val);") - (~ " if (_offset) *_offset = toff;")) - (when ptr? - (~ " if (basetype_p == NULL ||" - (if offset - "(tmp == NULL && toff == 0)" - "tmp == NULL") - ") {") - (if offset - (~ " "x" = (_offset ? tmp : ("ctype")W_OFFSET(tmp, toff));") - (~ " "x" = tmp;")) - (~ " return NULL;" \\ - " } else {" \\ - " *basetype_p = FOREIGN_"cname";") - (if offset - (~ " return _offset ? tmp : ("ctype")W_OFFSET(tmp, toff);") - (~ " return tmp;")) - (~ " }")) - (when (not ptr?) - (~ " "x" = tmp; return NULL;")) - (~ " } else {" \\ - " "(wrong-type "val" stype) \\ - " return NULL; /* hush the compiler */" \\ - " }")) - (if ptr? - (error 'scheme->c "unhandled pointer type: ~s" ctype) - (~ " if (!("(pred "val" x)")) "(wrong-type "val" stype) \\ - " return NULL;")))) - (~ " if (!ret_loc) "(wrong-type "type" "non-void-C-type") - ~ " break;"))):} + @(map-types #:semicolons? #f + (define (wrong-type obj type) + @list{scheme_wrong_type("Scheme->C","@type",0,1,&(@obj))}) + @list{ + case FOREIGN_@|cname|: + @(let* ([x (and ctype @list{(((@|ctype|*)W_OFFSET(dst,delta))[0])})] + [f (lambda (p) + (if (procedure? p) @p["val" x] @list{@|p|(val)}))]) + (cond + [(not x) + @list{if (!ret_loc) @wrong-type["type" "non-void-C-type"]; + break; + }] + [(not s->c) + @list{if (!(@(if ptr? "ret_loc" (pred "val" x)))) @; + @wrong-type["val" stype]; + @(if ptr? "break" "return NULL");}] + [else + @list{ + @@IFDEF{SCHEME_BIG_ENDIAN}{ + if (sizeof(@ctype)c]); + @and[offset @list{ + toff = SCHEME_@|offset|_OFFSET(val); + if (_offset) *_offset = toff;@; + @"\n" }]@; + @(if ptr? + @list{if (basetype_p == NULL || @; + @(if offset + @list{(tmp == NULL && toff == 0)} + @list{tmp == NULL})) { + @x = @(if offset + @list{(_offset ? tmp : @; + (@ctype)W_OFFSET(tmp, toff))} + "tmp"); + return NULL; + } else { + *basetype_p = FOREIGN_@cname; + return @(if offset + @list{_offset ? tmp : @; + (@ctype)W_OFFSET(tmp, toff)} + "tmp"); + }} + @list{@x = tmp@";" return NULL@";"}) + } else { + @wrong-type["val" stype]; + @hush + }}]))}) case FOREIGN_struct: if (!SCHEME_FFIANYPTRP(val)) scheme_wrong_type("Scheme->C", "pointer", 0, 1, &val); @@ -1144,8 +1135,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, /* C type information */ /* (ctype-sizeof type) -> int, returns 0 for void, error if not a C type */ -{:(cdefine ctype-sizeof 1):} -{ +@cdefine[ctype-sizeof 1]{ int size; size = ctype_sizeof(argv[0]); if (size >= 0) return scheme_make_integer(size); @@ -1154,8 +1144,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } /* (ctype-alignof type) -> int, returns 0 for void, error if not a C type */ -{:(cdefine ctype-alignof 1):} -{ +@cdefine[ctype-alignof 1]{ Scheme_Object *type; type = get_ctype_base(argv[0]); if (type == NULL) scheme_wrong_type(MYNAME, "C-type", 0, argc, argv); @@ -1167,8 +1156,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, * The symbols are in 'int 'char 'void 'short 'long '*, order does not matter, * when a single symbol is used, a list is not needed. * (This is about actual C types, not C type objects.) */ -{:(cdefine compiler-sizeof 1):} -{ +@cdefine[compiler-sizeof 1]{ int res=0; int basetype = 0; /* 1=int, 2=char, 3=void, 4=float, 5=double */ int intsize = 0; /* "short" => decrement, "long" => increment */ @@ -1217,17 +1205,17 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, if (basetype == 0) basetype = 1; /* int is the default type */ /* don't assume anything, so it can be used to verify compiler assumptions */ /* (only forbid stuff that the compiler doesn't allow) */ -#define RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *)) + @@DEFINE{RETSIZE(t) res=((stars==0)?sizeof(t):sizeof(t *))} switch (basetype) { case 1: /* int */ switch (intsize) { case 0: RETSIZE(int); break; case 1: RETSIZE(long int); break; -#ifdef INT64_AS_LONG_LONG + @@@IFDEF{INT64_AS_LONG_LONG}{ case 2: RETSIZE(_int64); break; /* MSVC doesn't allow long long */ -#else + }{ case 2: RETSIZE(long long int); break; -#endif + } case -1: RETSIZE(short int); break; } break; @@ -1252,15 +1240,15 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, scheme_signal_error(MYNAME": internal error (unexpected type %d)", basetype); } -#undef RETSIZE + @UNDEF{RETSIZE} return scheme_make_integer(res); } /*****************************************************************************/ /* Pointer type user functions */ -{:(defsymbols nonatomic atomic stubborn uncollectable eternal - interior atomic-interior raw fail-ok):} +@defsymbols[nonatomic atomic stubborn uncollectable eternal + interior atomic-interior raw fail-ok] /* (malloc num type cpointer mode) -> pointer */ /* The arguments for this function are: @@ -1276,8 +1264,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, * different types, the only requirement is for a size, either a number of * bytes or a type. If no mode is specified, then scheme_malloc will be used * when the type is any pointer, otherwise scheme_malloc_atomic is used. */ -{:(cdefine malloc 1 5):} -{ +@cdefine[malloc 1 5]{ int i, size=0, num=0, failok=0; void *from = NULL, *res = NULL; long foff = 0; @@ -1339,8 +1326,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } /* (end-stubborn-change ptr) */ -{:(cdefine end-stubborn-change 1):} -{ +@cdefine[end-stubborn-change 1]{ void *ptr; long poff; if (!SCHEME_FFIANYPTRP(argv[0])) @@ -1356,8 +1342,7 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, /* (free ptr) */ /* This is useful for raw-malloced objects, including objects from C libraries * that the library is mallocing itself. */ -{:(cdefine free 1):} -{ +@cdefine[free 1]{ void *ptr; long poff; if (!SCHEME_FFIANYPTRP(argv[0])) @@ -1371,14 +1356,12 @@ static void* SCHEME2C(Scheme_Object *type, void *dst, long delta, } /* (malloc-immobile-cell v) */ -{:(cdefine malloc-immobile-cell 1):} -{ +@cdefine[malloc-immobile-cell 1]{ return scheme_make_foreign_cpointer(scheme_malloc_immobile_box(argv[0])); } /* (free-immobile-cell b) */ -{:(cdefine free-immobile-cell 1):} -{ +@cdefine[free-immobile-cell 1]{ void *ptr; long poff; if (!SCHEME_FFIANYPTRP(argv[0])) @@ -1433,21 +1416,19 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang, } /* (ptr-add cptr offset-k [type]) */ -{:(cdefine ptr-add 2 3):} { return do_ptr_add(MYNAME, 0, argc, argv); } +@cdefine[ptr-add 2 3]{return do_ptr_add(MYNAME, 0, argc, argv);} /* (ptr-add! cptr offset-k [type]) */ -{:(cdefine ptr-add! 2 3):} { return do_ptr_add(MYNAME, 1, argc, argv); } +@cdefine[ptr-add! 2 3]{return do_ptr_add(MYNAME, 1, argc, argv);} /* (offset-ptr? x) */ /* Returns #t if the argument is a cpointer with an offset */ -{:(cdefine offset-ptr? 1 1):} -{ +@cdefine[offset-ptr? 1 1]{ return (SCHEME_CPOINTER_W_OFFSET_P(argv[0])) ? scheme_true : scheme_false; } /* (ptr-offset ptr) */ /* Returns the offset of a cpointer (0 if it's not an offset pointer) */ -{:(cdefine ptr-offset 1 1):} -{ +@cdefine[ptr-offset 1 1]{ if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); return scheme_make_integer_value(SCHEME_FFIANYPTR_OFFSET(argv[0])); @@ -1456,8 +1437,7 @@ static Scheme_Object *do_ptr_add(const char *who, int is_bang, /* (set-ptr-offset! ptr offset [type]) */ /* Sets the offset of an offset-cpointer (possibly multiplied by the size of * the given ctype) */ -{:(cdefine set-ptr-offset! 2 3):} -{ +@cdefine[set-ptr-offset! 2 3]{ long noff; if (!SCHEME_CPOINTER_W_OFFSET_P(argv[0])) scheme_wrong_type(MYNAME, "offset-cpointer", 0, argc, argv); @@ -1565,19 +1545,18 @@ static Scheme_Object *do_memop(const char *who, int mode, return scheme_void; } -{:(cdefine memset 3 5):} { return do_memop(MYNAME, 0, argc, argv); } -{:(cdefine memmove 3 6):} { return do_memop(MYNAME, 1, argc, argv); } -{:(cdefine memcpy 3 6):} { return do_memop(MYNAME, 2, argc, argv); } +@cdefine[memset 3 5]{return do_memop(MYNAME, 0, argc, argv);} +@cdefine[memmove 3 6]{return do_memop(MYNAME, 1, argc, argv);} +@cdefine[memcpy 3 6]{return do_memop(MYNAME, 2, argc, argv);} -{:(defsymbols abs):} +@defsymbols[abs] /* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ /* if n is given, an 'abs flag can precede it to make n be a byte offset rather - * than some multiple of sizeof(type). */ +/* than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ -{:(cdefine ptr-ref 2 4):} -{ +@cdefine[ptr-ref 2 4]{ int size=0; void *ptr; Scheme_Object *base; long delta; @@ -1625,10 +1604,9 @@ static Scheme_Object *do_memop(const char *who, int mode, /* (ptr-set! cpointer type [['abs] n] value) -> void */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ /* if n is given, an 'abs flag can precede it to make n be a byte offset rather - * than some multiple of sizeof(type). */ +/* than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ -{:(cdefine ptr-set! 3 5):} -{ +@cdefine[ptr-set! 3 5]{ int size=0; void *ptr; long delta; Scheme_Object *val = argv[argc-1], *base; @@ -1667,8 +1645,7 @@ static Scheme_Object *do_memop(const char *who, int mode, } /* (ptr-equal? cpointer cpointer) -> boolean */ -{:(cdefine ptr-equal? 2 2):} -{ +@cdefine[ptr-equal? 2 2]{ if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); if (!SCHEME_FFIANYPTRP(argv[1])) @@ -1680,12 +1657,11 @@ static Scheme_Object *do_memop(const char *who, int mode, } /* (make-sized-byte-string cpointer len) */ -{:(cdefine make-sized-byte-string 2 2):} -/* Warning: no copying is done so it is possible to share string contents. */ -/* Warning: if source ptr has a offset, resulting string object uses shifted - * pointer. - * (Should use real byte-strings with new version.) */ -{ +@cdefine[make-sized-byte-string 2 2]{ + /* Warning: no copying is done so it is possible to share string contents. */ + /* Warning: if source ptr has a offset, resulting string object uses shifted + * pointer. + * (Should use real byte-strings with new version.) */ long len; if (!SCHEME_FFIANYPTRP(argv[0])) scheme_wrong_type(MYNAME, "cpointer", 0, argc, argv); @@ -1729,10 +1705,9 @@ void do_ptr_finalizer(void *p, void *finalizer) /* unreachable, and it will get a new cpointer object that points to it. */ /* (Only needed in cases where pointer aliases might be created.) */ /* - -{:"(defsymbols pointer)":} -{:"(cdefine register-finalizer 2 3)":} -{ +@prefix[" * "]{ +defsymbols[pointer] +cdefine[register-finalizer 2 3]{ void *ptr, *old = NULL; int ptrsym = (argc == 3 && argv[2] == pointer_sym); if (ptrsym) { @@ -1752,8 +1727,8 @@ void do_ptr_finalizer(void *p, void *finalizer) (ptr, (ptrsym ? do_ptr_finalizer : do_scm_finalizer), argv[1], NULL, &old); return (old == NULL) ? scheme_false : (Scheme_Object*)old; -} -*/ +}} + */ /*****************************************************************************/ /* Calling foreign function objects */ @@ -1877,8 +1852,7 @@ void free_fficall_data(void *ignored, void *p) /* (ffi-call ffi-obj in-types out-type [abi]) -> (in-types -> out-value) */ /* the real work is done by ffi_do_call above */ -{:(cdefine ffi-call 3 4):} -{ +@cdefine[ffi-call 3 4]{ static Scheme_Object *ffi_name_prefix = NULL; Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; @@ -1996,8 +1970,7 @@ void free_cl_cif_args(void *ignored, void *p) /* (ffi-callback scheme-proc in-types out-type [abi]) -> ffi-callback */ /* the treatment of in-types and out-types is similar to that in ffi-call */ /* the real work is done by ffi_do_callback above */ -{:(cdefine ffi-callback 3 5):} -{ +@cdefine[ffi-callback 3 5]{ ffi_callback_struct *data; Scheme_Object *itypes = argv[1]; Scheme_Object *otype = argv[2]; @@ -2060,19 +2033,19 @@ void free_cl_cif_args(void *ignored, void *p) } if (ffi_prep_cif(cif, abi, nargs, rtype, atypes) != FFI_OK) scheme_signal_error("internal error: ffi_prep_cif did not return FFI_OK"); - {:(cmake-object "data" ffi-callback - "cl_cif_args" "argv[0]" "argv[1]" "argv[2]" - "((argc > 4) && SCHEME_TRUEP(argv[4]))"):} -#ifdef MZ_PRECISE_GC + @cmake["data" ffi-callback + "cl_cif_args" "argv[0]" "argv[1]" "argv[2]" + "((argc > 4) && SCHEME_TRUEP(argv[4]))"] + @@@IFDEF{MZ_PRECISE_GC}{ { /* put data in immobile, weak box */ void **tmp; tmp = GC_malloc_immobile_box(GC_malloc_weak_box(data, NULL, 0)); cl_cif_args->data = (struct immobile_box*)tmp; } -#else + }{ cl_cif_args->data = (void*)data; -#endif + } if (ffi_prep_closure(cl, cif, &ffi_do_callback, (void*)(cl_cif_args->data)) != FFI_OK) scheme_signal_error @@ -2112,38 +2085,37 @@ void scheme_init_foreign(Scheme_Env *env) ctype_struct *t; Scheme_Object *s; menv = scheme_primitive_module(scheme_intern_symbol("#%foreign"), env); - {:(for-each (lambda (x) - (~ (cadr x)"_tag = scheme_make_type(\"<"(car x)">\");")) - (reverse cstructs)):} -#ifdef MZ_PRECISE_GC - {:(for-each (lambda (x) - (~ "GC_register_traversers("(cadr x)"_tag, "(cadr x)"_SIZE, " - (cadr x)"_MARK, " (cadr x)"_FIXUP, 1, 0);")) - (reverse cstructs)):} -#endif + @(maplines (lambda (x) + @list{@(cadr x)_tag = scheme_make_type("<@(car x)>")}) + (reverse (cstructs))) + @@IFDEF{MZ_PRECISE_GC}{ + @(maplines (lambda (x) + @list{GC_register_traversers(@(cadr x)_tag, @(cadr x)_SIZE, @; + @(cadr x)_MARK, @(cadr x)_FIXUP, 1, 0)}) + (reverse (cstructs))) + } scheme_set_type_printer(ctype_tag, ctype_printer); MZ_REGISTER_STATIC(opened_libs); opened_libs = scheme_make_hash_table(SCHEME_hash_string); - {:(for-each - (lambda (sym) - (~ "MZ_REGISTER_STATIC("(cadr sym)");" \\ - (cadr sym)" = scheme_intern_symbol(\""(car sym)"\");")) - (reverse symbols)):} - {:(for-each - (lambda (x) - (~ "scheme_add_global(\""(car x)"\"," \\ - " scheme_make_prim_w_arity(" - (cadr x)", \""(car x)"\", "(caddr x)", "(cadddr x)"), menv);")) - (reverse! cfunctions)) - (for-each-type - ;; no need for these, at least for now: - ;; (~ "MZ_REGISTER_STATIC("cname"_sym);" \\ - ;; cname"_sym = scheme_intern_symbol(\""stype"\");") - (~ "s = scheme_intern_symbol(\""stype"\");") - (cmake-object "t" ctype "s" - (list "(Scheme_Object*)(void*)(&ffi_type_"ftype")") - (list "(Scheme_Object*)FOREIGN_"cname)) - (~ "scheme_add_global(\"_"stype"\", (Scheme_Object*)t, menv);")):} + @(maplines (lambda (sym) + @list{MZ_REGISTER_STATIC(@(cadr sym)); + @(cadr sym) = scheme_intern_symbol("@(car sym)")}) + (reverse (symbols))) + @(maplines + (lambda (x) + (define-values (sname cfun min max) (apply values x)) + @list{scheme_add_global("@sname", + scheme_make_prim_w_arity(@cfun, "@sname", @min, @max), menv)}) + (reverse (cfunctions))) + @(map-types + ;; no need for these, at least for now: + ;; MZ_REGISTER_STATIC(@|cname|_sym); + ;; @|cname|_sym = scheme_intern_symbol("@stype"); + @list{s = scheme_intern_symbol("@stype"); + @cmake["t" ctype "s" + @list{(Scheme_Object*)(void*)(&ffi_type_@ftype)} + @list{(Scheme_Object*)FOREIGN_@cname}] + scheme_add_global("_@stype", (Scheme_Object*)t, menv)}) scheme_finish_primitive_module(menv); scheme_protect_primitive_provide(menv, NULL); } diff --git a/src/foreign/ssc-utils.ss b/src/foreign/ssc-utils.ss index 00427f0cea..632ea852ff 100644 --- a/src/foreign/ssc-utils.ss +++ b/src/foreign/ssc-utils.ss @@ -1,103 +1,147 @@ -;; Utilities for .ssc preprocessor files. +;; Preprocessor utilities for the .ssc file. -(define (~ . args) (apply show args) (newline*)) -(define \\ newline*) +#lang at-exp scheme/base -(define (seplist l sep) - (cdr (apply append (map (lambda (x) (list sep x)) l)))) -(define-syntax push! - (syntax-rules () [(push! x l) (set! l (cons x l))])) -(define-syntax pop! - (syntax-rules () [(pop! l) (begin0 (car l) (set! l (cdr l)))])) -(define (upcase x) - (list->string (map char-upcase (string->list (format "~a" x))))) +(require (for-syntax scheme/base) scheme/list scribble/text/output) +(provide maplines) +(define (maplines #:semicolons? [semi? #t] fun . ls) + (add-between + (apply filter-map (lambda xs + (let ([r (apply fun xs)]) + (cond [(list? r) (if semi? (append r '(";")) r)] + [(or (not r) (void? r)) #f] + [else (error 'maplines "bad result: ~e" r)]))) + ls) + "\n")) + +;; thunks are forced -- so this can be used as @@IFDEF{...}{...} too! +(provide IFDEF IFNDEF) +(define ((((IF*DEF token choose) . c) . t) . e) + (if (null? e) + @list{@verbatim{#}@token @c + @t + @verbatim{#}endif /* @c */} + @list{@verbatim{#}@token @c + @t + @verbatim{#}else /* @c @(choose '("undefined" . "defined")) */ + @e + @verbatim{#}endif /* @c */})) +(define IFDEF (IF*DEF "ifdef" car)) +(define IFNDEF (IF*DEF "ifndef" cdr)) + +(provide DEFINE UNDEF) +(define (DEFINE . t) @list{@verbatim{#}define @t}) +(define (UNDEF . t) @list{@verbatim{#}undef @t}) + +(provide scheme-id->c-name) (define (scheme-id->c-name str) - (let loop ([str (format "~a" str)] - [substs '((#rx"->" "_to_") (#rx"[-/]" "_") (#rx"\\*" "S") - (#rx"\\?$" "_p") (#rx"!$" "_bang"))]) - (if (null? substs) - str - (loop (regexp-replace* (caar substs) str (cadar substs)) (cdr substs))))) + (set! str (format "~a" str)) + (for ([subst '([#rx"->" "_to_"] [#rx"[-/]" "_"] [#rx"\\*" "S"] + [#rx"\\?$" "_p"] [#rx"!$" "_bang"])]) + (set! str (regexp-replace* (car subst) str (cadr subst)))) + str) + +;; Used to avoid bogus compilation errors +(provide hush) +(define hush @'{return NULL@";" /* hush the compiler */}) ;; User function definition -(define cfunctions '()) -(define (_cdefine name minargs . maxargs) - (define cname - (list "foreign_" (scheme-id->c-name name))) - (set! maxargs (if (null? maxargs) minargs (car maxargs))) - (push! (list name cname minargs maxargs) cfunctions) - (list "#undef MYNAME" \\ "#define MYNAME \""name"\""\\ - "static Scheme_Object *"cname"(int argc, Scheme_Object *argv[])"\\)) -(define-syntax cdefine - (syntax-rules () - [(_ name minargs maxargs) (_cdefine `name minargs maxargs)] - [(_ name args) (_cdefine `name args args)])) +(provide cfunctions) +(define cfunctions (make-parameter '())) +(define (_cdefine name minargs maxargs . body) + (define cname @list{foreign_@(scheme-id->c-name name)}) + (cfunctions (cons (list name cname minargs maxargs) (cfunctions))) + @list{@verbatim{#define MYNAME "@name"} + static Scheme_Object *@|cname|(int argc, Scheme_Object *argv[]) + { + @body + } + @verbatim{#undef MYNAME}}) +(provide cdefine) +(define-syntax (cdefine stx) + (syntax-case stx () + [(_ name minargs maxargs body ...) + (number? (syntax-e #'maxargs)) + #'(_cdefine `name minargs maxargs body ...)] + [(_ name args body ...) + #'(_cdefine `name args args body ...)])) ;; Struct definitions -(define cstructs '()) +(provide cstructs) +(define cstructs (make-parameter '())) (define (_cdefstruct name slots types) - (define cname - (regexp-replace* #rx"-" (symbol->string name) "_")) - (define mname - (list->string - (map char-upcase (string->list (regexp-replace* #rx"_" cname ""))))) - (define predname - (string->symbol (string-append (symbol->string name)"?"))) - (~ "/* "name" structure definition */") - (~ "static Scheme_Type "cname"_tag;" \\ - "typedef struct "cname"_struct {" \\ - " Scheme_Object so;") - (for-each (lambda (s t) (~ " "t" "s";")) slots types) - (~ "} "cname"_struct;" \\ - "#define SCHEME_"mname"P(x) (SCHEME_TYPE(x)=="cname"_tag)") - (~ (_cdefine predname 1) - "{ return SCHEME_"mname"P(argv[0]) ? scheme_true : scheme_false; }") - (~ "/* 3m stuff for "cname" */" \\ - "#ifdef MZ_PRECISE_GC" \\ - "START_XFORM_SKIP;" - "int "cname"_SIZE(void *p) {" \\ - " return gcBYTES_TO_WORDS(sizeof("cname"_struct));" \\ - "}") - (let ([mark/fix (lambda (mode) - (~ "int "cname"_"mode"(void *p) {" \\ - " "cname"_struct *s = ("cname"_struct *)p;") - (for-each (lambda (s t) - (when (regexp-match #rx"[*]" t) - (~ " gc"mode"(s->"s");"))) - slots types) - (~ " return gcBYTES_TO_WORDS(sizeof("cname"_struct));" \\ - "}"))]) - (mark/fix "MARK") - (mark/fix "FIXUP")) - (~ "END_XFORM_SKIP;" \\ - "#endif") - (push! (list* name cname slots) cstructs)) -(define-syntax cdefstruct - (syntax-rules () - [(_ name (slot type) ...) - (_cdefstruct `name (list `slot ...) (list type ...))])) + (define cname (regexp-replace* #rx"-" (symbol->string name) "_")) + (define mname (string-upcase (regexp-replace* #rx"_" cname ""))) + (define predname (string->symbol (format "~a?" name))) + (define (mark/fix mode) + @list{int @|cname|_@|mode|(void *p) { + @|cname|_struct *s = (@|cname|_struct *)p; + @(maplines (lambda (s t) + (when (regexp-match #rx"[*]" t) + @list{gc@|mode|(s->@s)})) + slots types) + return gcBYTES_TO_WORDS(sizeof(@|cname|_struct)); + }}) + (cstructs (cons (list* name cname slots) (cstructs))) + @list{/* @name structure definition */ + static Scheme_Type @|cname|_tag; + typedef struct @|cname|_struct { + Scheme_Object so; + @(maplines (lambda (s t) @list{@t @s}) slots types) + } @|cname|_struct; + #define SCHEME_@|mname|P(x) (SCHEME_TYPE(x)==@|cname|_tag) + @_cdefine[predname 1 1]{ + return SCHEME_@|mname|P(argv[0]) ? scheme_true : scheme_false@";" + } + /* 3m stuff for @cname */ + #ifdef MZ_PRECISE_GC + START_XFORM_SKIP; + int @|cname|_SIZE(void *p) { + return gcBYTES_TO_WORDS(sizeof(@|cname|_struct)); + } + @mark/fix{MARK} + @mark/fix{FIXUP} + END_XFORM_SKIP; + #endif}) +(provide cdefstruct) +(define-syntax-rule (cdefstruct name [slot type] ...) + (_cdefstruct `name (list `slot ...) (list type ...))) ;; Tagged object allocation -(define (_cmake-object var type . values) - (define cstruct (cdr (assq type cstructs))) - (~ var" = ("(car cstruct)"_struct*)scheme_malloc_tagged(sizeof(" - (car cstruct)"_struct));" \\ - var"->so.type = "(car cstruct)"_tag;") - (for-each (lambda (v f) (~ var"->"f" = ("v");")) values (cdr cstruct))) -(define-syntax cmake-object - (syntax-rules () [(_ var type val ...) (_cmake-object var `type val ...)])) +(define (_cmake var type . values) + (define cstruct (cdr (assq type (cstructs)))) + (define cname (car cstruct)) + @list{@var = (@|cname|_struct*)scheme_malloc_tagged(sizeof(@|cname|_struct)); + @|var|->so.type = @|cname|_tag; + @(maplines (lambda (v f) @list{@|var|->@f = (@v)}) + values (cdr cstruct))}) +(provide cmake) +(define-syntax-rule (cmake var type val ...) (_cmake var `type val ...)) ;; Pre-allocated symbols -(define symbols '()) +(provide symbols) +(define symbols (make-parameter '())) (define (add-symbols syms) - (map (lambda (s) - (when (assq s symbols) - (error 'add-symbols "symbol ~s already defined" s)) - (push! (list s (list (regexp-replace #rx"-" (symbol->string s) "_") - "_sym")) - symbols) - (list "static Scheme_Object *"(cadar symbols)";"\\)) - syms)) + (maplines (lambda (s) + (define new + @list{@(regexp-replace #rx"-" (symbol->string s) "_")_sym}) + (when (assq s (symbols)) + (error 'add-symbols "symbol ~s already defined" s)) + (symbols (cons (list s new) (symbols))) + @list{static Scheme_Object *@new}) + syms)) +(provide defsymbols) (define-syntax defsymbols (syntax-rules () [(_ sym ...) (add-symbols '(sym ...))])) + +;; warn against manual edits to the generated file +(provide header) +(define (header orig) + @list{/******************************************** + ** Do not edit this file! + ** This file is generated from @orig, + ** to make changes, edit that file and + ** run it to generate an updated version + ** of this file. + ********************************************/}) From edd69e5c506cb2ebe94f032b9967d8b9bd5a6ee5 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 12 Mar 2009 19:21:05 +0000 Subject: [PATCH 006/140] Welcome to a new PLT day. svn: r14080 --- 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 9cb55652f0..9549d197f3 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "11mar2009") +#lang scheme/base (provide stamp) (define stamp "12mar2009") From 5826654a4e6c460865f1987e34766180991e1c2b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 12 Mar 2009 20:53:18 +0000 Subject: [PATCH 007/140] fix bug in stxobj simplication svn: r14081 --- src/mzscheme/src/stxobj.c | 79 ++++++++++++++++++++------------------- 1 file changed, 40 insertions(+), 39 deletions(-) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index b8a6e75373..f73561d3e7 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -3163,8 +3163,8 @@ static Scheme_Object *check_floating_id(Scheme_Object *stx) #define EXPLAIN_RESOLVE 0 #if EXPLAIN_RESOLVE -static int explain_resolves = 1; -# define EXPLAIN(x) if (explain_resolves) { x; } +int scheme_explain_resolves = 0; +# define EXPLAIN(x) if (scheme_explain_resolves) { x; } #else # define EXPLAIN(x) /* empty */ #endif @@ -3754,7 +3754,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, EXPLAIN(fprintf(stderr, "%d tl_id_sym\n", depth)); if (!bdg) { EXPLAIN(fprintf(stderr, "%d get bdg\n", depth)); - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, skip_ribs, NULL, NULL, depth+1); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -4418,9 +4418,9 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase #if EXPLAIN_RESOLVE Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) { - explain_resolves++; + scheme_explain_resolves++; a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0); - --explain_resolves; + --scheme_explain_resolves; return a; } #endif @@ -4814,7 +4814,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab Scheme_Object *v, *v2, *v2l, *stx, *name, *svl, *end_mutable = NULL; Scheme_Lexical_Rib *did_rib = NULL; Scheme_Hash_Table *skip_ribs_ht = NULL, *prev_skip_ribs_ht; - int copy_on_write; + int copy_on_write, no_rib_mutation = 1; long size, vsize, psize, i, j, pos; /* Although it makes no sense to simplify the rename table itself, @@ -4886,7 +4886,12 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab if (SCHEME_RIBP(v)) { /* A rib certainly isn't simplified yet. */ Scheme_Lexical_Rib *rib = (Scheme_Lexical_Rib *)v; + no_rib_mutation = 0; add = 1; + if (!*rib->sealed) { + scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); + return NULL; + } if (SAME_OBJ(did_rib, rib) || !nonempty_rib(rib)) { skip_this = 1; @@ -4894,10 +4899,6 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab scheme_write_to_string(rib->timestamp, NULL))); } else { did_rib = rib; - if (!*rib->sealed) { - scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); - return NULL; - } prec_ribs = add_skip_set(rib->timestamp, prec_ribs); EXPLAIN_S(fprintf(stderr, " down rib %p=%s\n", rib, @@ -5226,36 +5227,36 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab ii++; } - if (pos != size) { - /* Shrink simplified vector */ - if (!pos) - v2 = empty_simplified; - else { - v = v2; - v2 = scheme_make_vector(2 + (2 * pos), NULL); - for (i = 0; i < pos; i++) { - SCHEME_VEC_ELS(v2)[2+i] = SCHEME_VEC_ELS(v)[2+i]; - SCHEME_VEC_ELS(v2)[2+pos+i] = SCHEME_VEC_ELS(v)[2+size+i]; - } - } - } - - SCHEME_VEC_ELS(v2)[0] = scheme_false; - SCHEME_VEC_ELS(v2)[1] = scheme_false; - - { - /* Sometimes we generate the same simplified lex table, so - look for an equivalent one in the cache. */ - v = scheme_hash_get(lex_cache, scheme_true); - if (!v) { - v = (Scheme_Object *)scheme_make_hash_table_equal(); - scheme_hash_set(lex_cache, scheme_true, v); + if (!pos) + v2 = empty_simplified; + else { + if (pos != size) { + /* Shrink simplified vector */ + v = v2; + v2 = scheme_make_vector(2 + (2 * pos), NULL); + for (i = 0; i < pos; i++) { + SCHEME_VEC_ELS(v2)[2+i] = SCHEME_VEC_ELS(v)[2+i]; + SCHEME_VEC_ELS(v2)[2+pos+i] = SCHEME_VEC_ELS(v)[2+size+i]; + } + } + + SCHEME_VEC_ELS(v2)[0] = scheme_false; + SCHEME_VEC_ELS(v2)[1] = scheme_false; + + if (no_rib_mutation) { + /* Sometimes we generate the same simplified lex table, so + look for an equivalent one in the cache. */ + v = scheme_hash_get(lex_cache, scheme_true); + if (!v) { + v = (Scheme_Object *)scheme_make_hash_table_equal(); + scheme_hash_set(lex_cache, scheme_true, v); + } + svl = scheme_hash_get((Scheme_Hash_Table *)v, v2); + if (svl) + v2 = svl; + else + scheme_hash_set((Scheme_Hash_Table *)v, v2, v2); } - svl = scheme_hash_get((Scheme_Hash_Table *)v, v2); - if (svl) - v2 = svl; - else - scheme_hash_set((Scheme_Hash_Table *)v, v2, v2); } v2l = CONS(v2, v2l); From 3d5377d8f8a0948c4c8ae112230a7017352343ae Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 13 Mar 2009 01:44:30 +0000 Subject: [PATCH 008/140] pretty-printer: changed 'module' printing svn: r14082 --- collects/mzlib/pretty.ss | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss index 7e38db918d..8c750b51d3 100644 --- a/collects/mzlib/pretty.ss +++ b/collects/mzlib/pretty.ss @@ -1050,6 +1050,11 @@ (pp-two-up expr extra pp-expr-list depth apair? acar acdr open close)) + (define (pp-module expr extra depth + apair? acar acdr open close) + (pp-two-up expr extra pp-expr depth + apair? acar acdr open close)) + (define (pp-make-object expr extra depth apair? acar acdr open close) (pp-one-up expr extra pp-expr-list depth @@ -1138,8 +1143,10 @@ ((do letrec-syntaxes+values) (and (no-sharing? expr 2 apair? acdr) pp-do)) - - ((send syntax-case instantiate module) + ((module) + (and (no-sharing? expr 2 apair? acdr) + pp-module)) + ((send syntax-case instantiate) (and (no-sharing? expr 2 apair? acdr) pp-syntax-case)) ((make-object) From 0a24b8945de524444cb7ed83fbd842e0fb0b01ec Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 13 Mar 2009 02:00:13 +0000 Subject: [PATCH 009/140] updated impl to match contracts svn: r14083 --- collects/htdp/world.ss | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/collects/htdp/world.ss b/collects/htdp/world.ss index 93f745c977..1a1228484d 100644 --- a/collects/htdp/world.ss +++ b/collects/htdp/world.ss @@ -183,8 +183,8 @@ Matthew ; (define (nw:rectangle width height mode color) - (check-pos 'rectangle width "first") - (check-pos 'rectangle height "second") + (check-size/0 'nw:rectangle width "first") + (check-size/0 'nw:rectangle height "second") (check-mode 'rectangle mode "third") (check-color 'rectangle color "fourth") (put-pinhole (rectangle width height mode color) 0 0)) @@ -199,8 +199,8 @@ Matthew (place-image0 image x y scene))) (define (empty-scene width height) - (check-pos 'empty-scene width "first") - (check-pos 'empty-scene height "second") + (check-size/0 'empty-scene width "first") + (check-size/0 'empty-scene height "second") (put-pinhole (overlay (rectangle width height 'solid 'white) (rectangle width height 'outline 'black)) @@ -253,8 +253,8 @@ Matthew (case-lambda [(w h delta world) (big-bang w h delta world #f)] [(w h delta world animated-gif) - (check-pos 'big-bang w "first") - (check-pos 'big-bang h "second") + (check-size/0 'big-bang w "first") + (check-size/0 'big-bang h "second") ;; ============================================ ;; WHAT IF THEY ARE NOT INTs? ;; ============================================ @@ -361,8 +361,8 @@ Matthew (define run-simulation0 (case-lambda [(width height rate f record?) - (check-pos 'run-simulation width "first") - (check-pos 'run-simulation height "second") + (check-size/0 'run-simulation width "first") + (check-size/0 'run-simulation height "second") (check-arg 'run-simulation (number? rate) 'number "third" rate) (check-proc 'run-simulation f 1 "fourth" "one argument") (check-arg 'run-simulation (boolean? record?) 'number "fifth [and optional]" record?) @@ -390,9 +390,9 @@ Matthew ; ;; Symbol Any String -> Void -(define (check-pos tag c rank) - (check-arg tag (and (number? c) (> (coerce c) 0)) - "positive integer" rank c)) +(define (check-size/0 tag c rank) + (check-arg tag (and (number? c) (>= (coerce c) 0)) + "natural number" rank c)) ;; Symbol Any String String *-> Void (define (check-image tag i rank . other-message) From 533c8dfd8b6d8c550aaf6d5b9631b382ece720e1 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Fri, 13 Mar 2009 02:04:41 +0000 Subject: [PATCH 010/140] problem with 0-sized images fixed svn: r14084 --- collects/2htdp/private/check-aux.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/2htdp/private/check-aux.ss b/collects/2htdp/private/check-aux.ss index ff81e7b968..094849c8e2 100644 --- a/collects/2htdp/private/check-aux.ss +++ b/collects/2htdp/private/check-aux.ss @@ -135,7 +135,7 @@ ;; Symbol Any String -> Void (define (check-pos t c r) (check-arg - t (and (number? c) (> (number->integer c) 0)) "positive integer" r c)) + t (and (number? c) (>= (number->integer c) 0)) "positive integer" r c)) ;; Symbol Any String String *-> Void (define (check-image tag i rank . other-message) From e11a24fda8c9c00a62be3fc92df83d36b6ac1b90 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 13 Mar 2009 05:54:17 +0000 Subject: [PATCH 011/140] macro stepper: better module hiding display prefab structs updated tests svn: r14085 --- collects/macro-debugger/model/reductions.ss | 3 +- .../syntax-browser/pretty-helper.ss | 15 ++ .../syntax-browser/pretty-printer.ss | 2 +- collects/tests/macro-debugger/gentests.ss | 6 +- collects/tests/macro-debugger/test-setup.ss | 38 ++-- collects/tests/macro-debugger/tests/hiding.ss | 211 ++++++++++-------- .../macro-debugger/tests/syntax-modules.ss | 50 ++--- 7 files changed, 183 insertions(+), 142 deletions(-) diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss index 527a094261..bb92f312be 100644 --- a/collects/macro-debugger/model/reductions.ss +++ b/collects/macro-debugger/model/reductions.ss @@ -3,7 +3,6 @@ (require scheme/match "stx-util.ss" "deriv-util.ss" - "context.ss" "deriv.ss" "reductions-engine.ss") @@ -61,7 +60,7 @@ [#:when (not (bound-identifier=? e1 e2)) [#:walk e2 'resolve-variable]])] [(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift)) - (R ;; [#:hide-check rs] ;; FIXME: test and enable!!! + (R [#:hide-check rs] [! ?1] [#:pattern (?module ?name ?language . ?body-parts)] [! ?2] diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss index 846eae3a0c..4688d2b1b0 100644 --- a/collects/macro-debugger/syntax-browser/pretty-helper.ss +++ b/collects/macro-debugger/syntax-browser/pretty-helper.ss @@ -89,6 +89,13 @@ lp-datum)] [(pair? obj) (pairloop obj)] + [(struct? obj) + ;; Only traverse prefab structs + (let ([pkey (prefab-struct-key obj)]) + (if pkey + (let-values ([(refold fields) (unfold-pstruct obj)]) + (refold (map loop fields))) + obj))] [(symbol? obj) (unintern obj)] [(null? obj) @@ -117,6 +124,14 @@ flat=>stx stx=>flat)))) +;; unfold-pstruct : prefab-struct -> (values (list -> prefab-struct) list) +(define (unfold-pstruct obj) + (define key (prefab-struct-key obj)) + (define fields (cdr (vector->list (struct->vector obj)))) + (values (lambda (new-fields) + (apply make-prefab-struct key new-fields)) + fields)) + ;; check+convert-special-expression : syntax -> #f/syntaxish (define (check+convert-special-expression stx) (define stx-list (stx->list stx)) diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss index 417e52b711..3fbb89a356 100644 --- a/collects/macro-debugger/syntax-browser/pretty-printer.ss +++ b/collects/macro-debugger/syntax-browser/pretty-printer.ss @@ -56,7 +56,7 @@ ;; Printing parameters (mzscheme manual 7.9.1.4) [print-unreadable #t] [print-graph #f] - [print-struct #f] + [print-struct #t] [print-box #t] [print-vector-length #t] [print-hash-table #f] diff --git a/collects/tests/macro-debugger/gentests.ss b/collects/tests/macro-debugger/gentests.ss index ca2254d488..ec0c9fd71e 100644 --- a/collects/tests/macro-debugger/gentests.ss +++ b/collects/tests/macro-debugger/gentests.ss @@ -57,7 +57,7 @@ [expect-ok? (cdr key+expect-ok?)]) (check-hide d hide-none-policy expect-ok?) (check-hide d hide-all-policy expect-ok?) - (check-hide d simple-policy expect-ok?))))] + (check-hide d T-policy expect-ok?))))] [else #f])) (define (check-hide d policy expect-ok?) @@ -86,14 +86,14 @@ (error 'checker-for-hidden-steps "no steps given for ~s" label)) (test-case label (let* ([d (trace/ns form (assq '#:kernel attrs))] - [rs (parameterize ((macro-policy simple-policy)) + [rs (parameterize ((macro-policy T-policy)) (reductions d))]) (check-steps (cdr (assq '#:steps attrs)) rs)))] [(assq '#:hidden-steps attrs) => (lambda (key+expected) (test-case label (let* ([d (trace/ns form (assq '#:kernel attrs))] - [rs (parameterize ((macro-policy simple-policy)) + [rs (parameterize ((macro-policy T-policy)) (reductions d))]) (check-steps (cdr (assq '#:hidden-steps attrs)) rs))))] [else #f])) diff --git a/collects/tests/macro-debugger/test-setup.ss b/collects/tests/macro-debugger/test-setup.ss index 7852037511..5fdb4646b0 100644 --- a/collects/tests/macro-debugger/test-setup.ss +++ b/collects/tests/macro-debugger/test-setup.ss @@ -8,12 +8,15 @@ trace/k hide-all-policy hide-none-policy - simple-policy + + T-policy + Tm-policy stx/hide-none stx/hide-all stx/hide-standard - stx/hide-simple) + stx/hide-T + stx/hide-Tm) (define (trace/t expr) (trace/ns expr #f)) @@ -133,22 +136,25 @@ (stx/hide-policy d hide-none-policy)) (define (stx/hide-all d) (stx/hide-policy d hide-all-policy)) -(define (stx/hide-simple d) - (stx/hide-policy d simple-policy)) (define (stx/hide-standard d) (stx/hide-policy d standard-policy)) -#| -(define (hide/standard d) (hide/policy d standard-policy)) -(define (hide/all d) (hide/policy d hide-all-policy)) -(define (hide/null d) (hide/policy d hide-none-policy)) -(define (hide/except d syms) - (hide/policy d (lambda (id) (memq (syntax-e id) syms)))) -(define (hide/simple d) (hide/policy d simple-policy)) -|# -;; Simple hiding policy -;; ALL MACROS & primitive tags are hidden -;; EXCEPT Tlist and Tlet (and #%module-begin) -(define (simple-policy id) +(define (stx/hide-T d) + (stx/hide-policy d T-policy)) +(define (stx/hide-Tm d) + (stx/hide-policy d Tm-policy)) + +;; T hiding policy +;; ALL macros & primitives are hidden +;; EXCEPT those starting with T (Tlist and Tlet) +(define (T-policy id) (or (memq (syntax-e id) '()) (regexp-match #rx"^T" (symbol->string (syntax-e id))))) + +;; Tm hiding policy +;; ALL MACROS & primitive tags are hidden +;; EXCEPT those starting with T (Tlist and Tlet) +;; EXCEPT module (=> #%module-begin gets tagged) +(define (Tm-policy id) + (or (memq (syntax-e id) '(module)) + (regexp-match #rx"^T" (symbol->string (syntax-e id))))) diff --git a/collects/tests/macro-debugger/tests/hiding.ss b/collects/tests/macro-debugger/tests/hiding.ss index 1131ec2ff3..8cf25d2a02 100644 --- a/collects/tests/macro-debugger/tests/hiding.ss +++ b/collects/tests/macro-debugger/tests/hiding.ss @@ -1,7 +1,6 @@ #lang scheme/base (require (planet "test.ss" ("schematics" "schemeunit.plt" 2 8)) - (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2 8)) macro-debugger/model/debug "../test-setup.ss") (provide specialized-hiding-tests) @@ -27,16 +26,19 @@ [(tthi form) (test-trivial-hiding form form)])) -(define-syntax test-simple-hiding - (syntax-rules () - [(tsh form hidden-e2) - (test-hiding/policy form hidden-e2 simple-policy)])) -(define-syntax test-simple-hiding/id - (syntax-rules () - [(tshi form) (test-simple-hiding form form)])) +(define-syntax-rule (test-T-hiding form hidden-e2) + (test-hiding/policy form hidden-e2 T-policy)) +(define-syntax-rule (test-T-hiding/id form) + (test-T-hiding form form)) + +(define-syntax-rule (test-Tm-hiding form hidden-e2) + (test-hiding/policy form hidden-e2 Tm-policy)) +(define-syntax-rule (test-Tm-hiding/id form) + (test-Tm-hiding form form)) (define specialized-hiding-tests (test-suite "Specialized macro hiding tests" + (test-suite "Result tests for trivial hiding" (test-suite "Atomic expressions" (test-trivial-hiding/id *) @@ -74,7 +76,7 @@ (lambda (x y) x y)) (test-trivial-hiding (lambda (x) (define-values (y) (id x)) y) (lambda (x) (letrec-values ([(y) x]) y)))) - #; + #| ;; Old hiding mechanism never did letrec transformation (unless forced) (test-suite "Block normalization" (test-trivial-hiding/id (lambda (x y) x y)) @@ -88,94 +90,119 @@ (test-trivial-hiding (lambda (x) (id (begin (define-values (y) x) x))) (lambda (x) (begin (define-values (y) x) x))) (test-trivial-hiding (lambda (x) (define-values (y) (id x)) y) - (lambda (x) (define-values (y) x) y)))) - (test-suite "Result tests for simple hiding" + (lambda (x) (define-values (y) x) y))) + |# + ) + + (test-suite "Result tests for T hiding" (test-suite "Atomic expressions" - (test-simple-hiding/id *) - (test-simple-hiding/id 1) - (test-simple-hiding/id unbound-var)) + (test-T-hiding/id *) + (test-T-hiding/id 1) + (test-T-hiding/id unbound-var)) (test-suite "Basic expressions" - (test-simple-hiding/id (if 1 2 3)) - (test-simple-hiding/id (with-continuation-mark 1 2 3)) - (test-simple-hiding/id (define-values (x) 1)) - (test-simple-hiding/id (define-syntaxes (x) 1))) + (test-T-hiding/id (if 1 2 3)) + (test-T-hiding/id (with-continuation-mark 1 2 3)) + (test-T-hiding/id (define-values (x) 1)) + (test-T-hiding/id (define-syntaxes (x) 1))) (test-suite "Opaque macros" - (test-simple-hiding/id (id '1)) - (test-simple-hiding/id (id 1)) - (test-simple-hiding/id (id (id '1))) + (test-T-hiding/id (id '1)) + (test-T-hiding/id (id 1)) + (test-T-hiding/id (id (id '1))) ;; app is hidden: - (test-simple-hiding/id (+ '1 '2))) + (test-T-hiding/id (+ '1 '2))) (test-suite "Transparent macros" - (test-simple-hiding (Tlist x) - (list x)) - (test-simple-hiding (Tid x) x) - (test-simple-hiding (Tlist (id x)) - (list (id x))) - (test-simple-hiding (Tid (id x)) - (id x)) - (test-simple-hiding (id (Tlist x)) - (id (list x))) - (test-simple-hiding (id (Tid x)) - (id x))) + (test-T-hiding (Tlist x) + (list x)) + (test-T-hiding (Tid x) x) + (test-T-hiding (Tlist (id x)) + (list (id x))) + (test-T-hiding (Tid (id x)) + (id x)) + (test-T-hiding (id (Tlist x)) + (id (list x))) + (test-T-hiding (id (Tid x)) + (id x))) (test-suite "Blocks" - (test-simple-hiding/id (lambda (x y) x y)) - (test-simple-hiding (lambda (x y z) (begin x y) z) - (lambda (x y z) x y z)) - (test-simple-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin! - (test-simple-hiding (lambda (x) (define-values (y) x) y) - (lambda (x) (letrec-values ([(y) x]) y))) - (test-simple-hiding (lambda (x) (begin (define-values (y) x)) y) - (lambda (x) (letrec-values ([(y) x]) y))) - (test-simple-hiding (lambda (x) (begin (define-values (y) x) y) x) - (lambda (x) (letrec-values ([(y) x]) y x))) - (test-simple-hiding (lambda (x) (id x)) - (lambda (x) (id x))) - (test-simple-hiding (lambda (x) (Tid x)) - (lambda (x) x)) - (test-simple-hiding/id (lambda (x) (id (define-values (y) x)) x)) - (test-simple-hiding (lambda (x) (id (define-values (y) x)) (Tid x)) - (lambda (x) (id (define-values (y) x)) x)) - (test-simple-hiding/id (lambda (x) (id (begin (define-values (y) x) x)))) - (test-simple-hiding (lambda (x) (begin (id (define-values (y) x)) y)) - (lambda (x) (id (define-values (y) x)) y)) - (test-simple-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) (Tid y)) - (lambda (x) (id (begin (define-values (y) x))) y)) - (test-simple-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) x (Tid y)) - (lambda (x) (id (begin (define-values (y) x))) x y)) - (test-simple-hiding (lambda (x) (define-values (y) (id x)) y) - (lambda (x) (letrec-values ([(y) (id x)]) y))) - (test-simple-hiding (lambda (x y) x (id y)) - (lambda (x y) x (id y))) - (test-simple-hiding (lambda (x y) x (Tid y)) - (lambda (x y) x y)) - (test-simple-hiding (lambda (x) (id (define-values (y) x)) x (Tid y)) - (lambda (x) (id (define-values (y) x)) x y)) - (test-simple-hiding/id (lambda (x) (id (define-values (y) (id x))) y)) - (test-simple-hiding (lambda (x) (id (define-values (y) (Tid x))) y) - (lambda (x) (id (define-values (y) x)) y))) + (test-T-hiding/id (lambda (x y) x y)) + (test-T-hiding (lambda (x y z) (begin x y) z) + (lambda (x y z) x y z)) + (test-T-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin! + (test-T-hiding (lambda (x) (define-values (y) x) y) + (lambda (x) (letrec-values ([(y) x]) y))) + (test-T-hiding (lambda (x) (begin (define-values (y) x)) y) + (lambda (x) (letrec-values ([(y) x]) y))) + (test-T-hiding (lambda (x) (begin (define-values (y) x) y) x) + (lambda (x) (letrec-values ([(y) x]) y x))) + (test-T-hiding (lambda (x) (id x)) + (lambda (x) (id x))) + (test-T-hiding (lambda (x) (Tid x)) + (lambda (x) x)) + (test-T-hiding/id (lambda (x) (id (define-values (y) x)) x)) + (test-T-hiding (lambda (x) (id (define-values (y) x)) (Tid x)) + (lambda (x) (id (define-values (y) x)) x)) + (test-T-hiding/id (lambda (x) (id (begin (define-values (y) x) x)))) + (test-T-hiding (lambda (x) (begin (id (define-values (y) x)) y)) + (lambda (x) (id (define-values (y) x)) y)) + (test-T-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) (Tid y)) + (lambda (x) (id (begin (define-values (y) x))) y)) + (test-T-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) x (Tid y)) + (lambda (x) (id (begin (define-values (y) x))) x y)) + (test-T-hiding (lambda (x) (define-values (y) (id x)) y) + (lambda (x) (letrec-values ([(y) (id x)]) y))) + (test-T-hiding (lambda (x y) x (id y)) + (lambda (x y) x (id y))) + (test-T-hiding (lambda (x y) x (Tid y)) + (lambda (x y) x y)) + (test-T-hiding (lambda (x) (id (define-values (y) x)) x (Tid y)) + (lambda (x) (id (define-values (y) x)) x y)) + (test-T-hiding/id (lambda (x) (id (define-values (y) (id x))) y)) + (test-T-hiding (lambda (x) (id (define-values (y) (Tid x))) y) + (lambda (x) (id (define-values (y) x)) y))) (test-suite "Binding expressions" - (test-simple-hiding/id (lambda (x) x)) - (test-simple-hiding/id (lambda (x) (id x)))) + (test-T-hiding/id (lambda (x) x)) + (test-T-hiding/id (lambda (x) (id x)))) (test-suite "Module declarations" - (test-simple-hiding (module m mzscheme - (require 'helper) - (define x 1)) - (module m mzscheme - (#%module-begin - (require 'helper) - (define x 1)))) - (test-simple-hiding (module m mzscheme - (require 'helper) - (define x (Tlist 1))) - (module m mzscheme - (#%module-begin - (require 'helper) - (define x (list 1))))) - (test-simple-hiding (module m mzscheme - (#%plain-module-begin - (require 'helper) - (define x (Tlist 1)))) - (module m mzscheme - (#%plain-module-begin - (require 'helper) - (define x (list 1))))))))) + (test-T-hiding (module m mzscheme + (require 'helper) + (define x 1)) + (module m mzscheme + (require 'helper) + (define x 1))) + (test-Tm-hiding (module m mzscheme + (require 'helper) + (define x 1)) + (module m mzscheme + (#%module-begin + (require 'helper) + (define x 1)))) + + (test-T-hiding (module m mzscheme + (require 'helper) + (define x (Tlist 1))) + (module m mzscheme + (require 'helper) + (define x (list 1)))) + (test-Tm-hiding (module m mzscheme + (require 'helper) + (define x (Tlist 1))) + (module m mzscheme + (#%module-begin + (require 'helper) + (define x (list 1))))) + + (test-T-hiding (module m mzscheme + (#%plain-module-begin + (require 'helper) + (define x (Tlist 1)))) + (module m mzscheme + (#%plain-module-begin + (require 'helper) + (define x (list 1))))) + (test-Tm-hiding (module m mzscheme + (#%plain-module-begin + (require 'helper) + (define x (Tlist 1)))) + (module m mzscheme + (#%plain-module-begin + (require 'helper) + (define x (list 1))))))))) diff --git a/collects/tests/macro-debugger/tests/syntax-modules.ss b/collects/tests/macro-debugger/tests/syntax-modules.ss index 41baa45fb1..b4db2d19a3 100644 --- a/collects/tests/macro-debugger/tests/syntax-modules.ss +++ b/collects/tests/macro-debugger/tests/syntax-modules.ss @@ -18,7 +18,7 @@ [#:steps (tag-module-begin (module m '#%kernel (#%module-begin (define-values (x) 'a))))] - #:same-hidden-steps) + #:no-hidden-steps) (test "module, MB, def, use" (module m '#%kernel (#%module-begin (define-values (x) 'a) x)) #:no-steps @@ -28,7 +28,7 @@ [#:steps (tag-module-begin (module m '#%kernel (#%module-begin (define-values (x) 'a) x)))] - #:same-hidden-steps) + #:no-hidden-steps) (test "module, MB, quote" (module m '#%kernel (#%module-begin 'a)) #:no-steps @@ -37,12 +37,12 @@ (module m '#%kernel 'a) [#:steps (tag-module-begin (module m '#%kernel (#%module-begin 'a)))] - #:same-hidden-steps) + #:no-hidden-steps) (test "module, 2 quotes" (module m '#%kernel 'a 'b) [#:steps (tag-module-begin (module m '#%kernel (#%module-begin 'a 'b)))] - #:same-hidden-steps) + #:no-hidden-steps) (test "module, MB, begin" (module m '#%kernel (#%module-begin (begin 'a 'b))) [#:steps @@ -53,7 +53,7 @@ [#:steps (tag-module-begin (module m '#%kernel (#%module-begin (begin 'a 'b)))) (splice-module (module m '#%kernel (#%module-begin 'a 'b)))] - #:same-hidden-steps) + #:no-hidden-steps) (test "module, MB, def in begin" (module m '#%kernel (#%module-begin (begin (define-values (x) 'a) x))) [#:steps @@ -67,7 +67,7 @@ (module m '#%kernel (#%module-begin (begin (define-values (x) 'a) x)))) (splice-module (module m '#%kernel (#%module-begin (define-values (x) 'a) x)))] - #:same-hidden-steps) + #:no-hidden-steps) (test "module, MB, defstx, use" (module m '#%kernel @@ -106,7 +106,11 @@ (#%module-begin (#%require 'helper) 'a)))] - #:same-hidden-steps) + [#:hidden-steps + (macro + (module m '#%kernel + (#%require 'helper) + 'a))]) (test "module k+helper, defs and opaque macros" (module m '#%kernel @@ -196,14 +200,12 @@ (tag-module-begin (module m mzscheme (#%module-begin (define-values (x) 'a) x))) (macro - (module m mzscheme - (#%plain-module-begin - (#%require (for-syntax scheme/mzscheme)) - (define-values (x) 'a) - x)))] - [#:hidden-steps - (tag-module-begin - (module m mzscheme (#%module-begin (define-values (x) 'a) x)))]) + (module m mzscheme + (#%plain-module-begin + (#%require (for-syntax scheme/mzscheme)) + (define-values (x) 'a) + x)))] + #:no-hidden-steps) (test "module mz, def" (module m mzscheme (define-values (x) 'a)) [#:steps @@ -214,9 +216,7 @@ (#%plain-module-begin (#%require (for-syntax scheme/mzscheme)) (define-values (x) 'a))))] - [#:hidden-steps - (tag-module-begin - (module m mzscheme (#%module-begin (define-values (x) 'a))))]) + #:no-hidden-steps) (test "module mz, quote" (module m mzscheme 'a) [#:steps @@ -227,10 +227,8 @@ (#%plain-module-begin (#%require (for-syntax scheme/mzscheme)) 'a)))] - [#:hidden-steps - (tag-module-begin - (module m mzscheme (#%module-begin 'a)))]) - + #:no-hidden-steps) + (test "module mz, begin with 2 quotes" (module m mzscheme (begin 'a 'b)) [#:steps @@ -246,9 +244,7 @@ (#%plain-module-begin (#%require (for-syntax scheme/mzscheme)) 'a 'b)))] - [#:hidden-steps - (tag-module-begin - (module m mzscheme (#%module-begin (begin 'a 'b))))]) + #:no-hidden-steps) (test "module mz, macro use, quote" (module m mzscheme (or 'a 'b) 'c) @@ -289,9 +285,7 @@ (let-values ([(or-part) 'a]) (if or-part or-part 'b)) 'c)))] - [#:hidden-steps - (tag-module-begin - (module m mzscheme (#%module-begin (or 'a 'b) 'c)))]) + #:no-hidden-steps) (test "module mz, macro use" (module m mzscheme (or 'a 'b)) From acb18e69899f4f781d50ebd7293e715b7a4970fb Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 13 Mar 2009 07:50:21 +0000 Subject: [PATCH 012/140] Welcome to a new PLT day. svn: r14086 --- 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 9549d197f3..c4515cdbee 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "12mar2009") +#lang scheme/base (provide stamp) (define stamp "13mar2009") From 04cdd975e97497ae10b27356e30be0f3d26729be Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 13 Mar 2009 14:55:37 +0000 Subject: [PATCH 013/140] Fixing xml snip bug svn: r14087 --- collects/stepper/private/xml-snip-helpers.ss | 2 +- collects/tests/xml/xml-snip-bug.ss | 3884 ++++++++++++++++++ collects/xml/private/structures.ss | 2 +- collects/xml/private/xexpr.ss | 3 +- collects/xml/xml.scrbl | 2 +- 5 files changed, 3889 insertions(+), 4 deletions(-) create mode 100644 collects/tests/xml/xml-snip-bug.ss diff --git a/collects/stepper/private/xml-snip-helpers.ss b/collects/stepper/private/xml-snip-helpers.ss index 8a46053c83..fb35654ce1 100644 --- a/collects/stepper/private/xml-snip-helpers.ss +++ b/collects/stepper/private/xml-snip-helpers.ss @@ -52,7 +52,7 @@ (lambda () (let* ([source-name (get-source-name editor)] [port (open-input-text-editor editor 0 'end (xml-snip-filter editor) source-name)] - [xml (read-xml port)] + [xml (parameterize ([permissive? #t]) (read-xml port))] [xexpr (parameterize ([permissive? #t]) (xml->xexpr (document-element xml)))] [clean-xexpr (if eliminate-whitespace-in-empty-tags? (eliminate-whitespace-in-empty-tags xexpr) diff --git a/collects/tests/xml/xml-snip-bug.ss b/collects/tests/xml/xml-snip-bug.ss new file mode 100644 index 0000000000..943285eebf --- /dev/null +++ b/collects/tests/xml/xml-snip-bug.ss @@ -0,0 +1,3884 @@ +#reader(lib"read.ss""wxme")WXME0108 ## +#| + This file is in PLT Scheme editor format. + Open this file in DrScheme version 370 or later to read it. + + Most likely, it was created by saving a program in DrScheme, + and it probably contains a program with non-text elements + (such as images or comment boxes). + + http://www.plt-scheme.org +|# + 45 7 #"wxtext\0" +3 1 6 #"wxtab\0" +1 1 8 #"wxmedia\0" +4 1 8 #"wximage\0" +2 0 34 #"(lib \"syntax-browser.ss\" \"mrlib\")\0" +1 0 16 #"drscheme:number\0" +3 0 44 #"(lib \"number-snip.ss\" \"drscheme\" \"private\")\0" +1 0 36 #"(lib \"comment-snip.ss\" \"framework\")\0" +1 0 43 #"(lib \"collapsed-snipclass.ss\" \"framework\")\0" +0 0 19 #"drscheme:sexp-snip\0" +0 0 36 #"(lib \"cache-image-snip.ss\" \"mrlib\")\0" +1 0 33 #"(lib \"bullet-snip.ss\" \"browser\")\0" +0 0 29 #"drscheme:bindings-snipclass%\0" +1 0 25 #"(lib \"matrix.ss\" \"htdp\")\0" +1 0 22 #"drscheme:lambda-snip%\0" +1 0 8 #"gb:core\0" +5 0 10 #"gb:canvas\0" +5 0 17 #"gb:editor-canvas\0" +5 0 10 #"gb:slider\0" +5 0 9 #"gb:gauge\0" +5 0 11 #"gb:listbox\0" +5 0 12 #"gb:radiobox\0" +5 0 10 #"gb:choice\0" +5 0 8 #"gb:text\0" +5 0 11 #"gb:message\0" +5 0 10 #"gb:button\0" +5 0 12 #"gb:checkbox\0" +5 0 18 #"gb:vertical-panel\0" +5 0 9 #"gb:panel\0" +5 0 20 #"gb:horizontal-panel\0" +5 0 33 #"(lib \"readable.ss\" \"guibuilder\")\0" +1 0 56 +( + #"(lib \"hrule-snip.ss\" \"macro-debugger\" \"syntax-browse" + #"r\")\0" +) 1 0 18 #"java-comment-box%\0" +1 0 23 #"java-interactions-box%\0" +1 0 45 #"(lib \"image-snipr.ss\" \"slideshow\" \"private\")\0" +1 0 26 #"drscheme:pict-value-snip%\0" +0 0 38 #"(lib \"pict-snipclass.ss\" \"slideshow\")\0" +2 0 55 +( + #"(lib \"vertical-separator-snip.ss\" \"stepper\" \"private" + #"\")\0" +) 1 0 18 #"drscheme:xml-snip\0" +1 0 31 #"(lib \"xml-snipclass.ss\" \"xml\")\0" +1 0 21 #"drscheme:scheme-snip\0" +2 0 34 #"(lib \"scheme-snipclass.ss\" \"xml\")\0" +1 0 10 #"text-box%\0" +1 0 32 #"(lib \"text-snipclass.ss\" \"xml\")\0" +1 0 15 #"test-case-box%\0" +2 0 1 6 #"wxloc\0" +00000000000 1 1269 0 1 #"\0" +0 75 1 #"\0" +0 10 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 9 +#"Standard\0" +0 75 15 #"Lucida Console\0" +0 10 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 24 +#"framework:default-color\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 -1 -1 2 15 +#"text:ports out\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 15 +#"text:ports err\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 17 +#"text:ports value\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 27 +#"Matching Parenthesis Style\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 37 +#"framework:syntax-color:scheme:symbol\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 38 +#"framework:syntax-color:scheme:keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +38 #"framework:syntax-color:scheme:comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 37 +#"framework:syntax-color:scheme:string\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 39 +#"framework:syntax-color:scheme:constant\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 42 +#"framework:syntax-color:scheme:parenthesis\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 36 +#"framework:syntax-color:scheme:error\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 36 +#"framework:syntax-color:scheme:other\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 +38 #"drscheme:check-syntax:lexically-bound\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 31 +#"drscheme:check-syntax:imported\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 41 +#"profj:syntax-colors:scheme:block-comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +35 #"profj:syntax-colors:scheme:keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 0 139 0 0 0 -1 -1 2 37 +#"profj:syntax-colors:scheme:prim-type\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 0 139 0 0 0 -1 -1 2 38 +#"profj:syntax-colors:scheme:identifier\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 34 +#"profj:syntax-colors:scheme:string\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 35 +#"profj:syntax-colors:scheme:literal\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 35 +#"profj:syntax-colors:scheme:comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +33 #"profj:syntax-colors:scheme:error\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 35 +#"profj:syntax-colors:scheme:default\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 37 +#"profj:syntax-colors:scheme:uncovered\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 35 +#"profj:syntax-colors:scheme:covered\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 0 139 0 0 0 -1 -1 4 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 4 4 +#"XML\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 8 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 8 24 +#"drscheme:text:ports err\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 4 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 4 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 0 1 +#"\0" +0 75 1 #"\0" +0 12 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 1 +#"\0" +0 75 7 #"Monaco\0" +0 12 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 255 255 0 -1 -1 0 1 +#"\0" +0 75 15 #"Lucida Console\0" +0 10 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 200 0 0 0 0 0 -1 -1 22 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 14 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 20 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 15 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 17 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 22 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 14 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 15 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 17 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 20 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 26 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 19 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 19 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 22 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 14 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 19 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 17 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 15 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 20 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 26 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 65 105 225 0 0 0 -1 -1 26 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 24 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 24 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 0 0 0 -1 -1 24 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 90 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 0 1 +#"\0" +0 75 23 #"Lucida Sans Typewriter\0" +0 12 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 +14 #"Html Standard\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 148 0 211 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 4 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 0 1 +#"\0" +0 75 12 #"Courier New\0" +0 12 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 +40 #"framework:syntax-coloring:scheme:symbol\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 41 +#"framework:syntax-coloring:scheme:keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 41 +#"framework:syntax-coloring:scheme:comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +40 #"framework:syntax-coloring:scheme:string\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 42 +#"framework:syntax-coloring:scheme:constant\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 41 128 38 0 0 0 -1 -1 2 45 +#"framework:syntax-coloring:scheme:parenthesis\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 39 +#"framework:syntax-coloring:scheme:error\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 39 +#"framework:syntax-coloring:scheme:other\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 49 +#"drscheme:check-syntax:lexically-bound-identifier\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 +42 #"drscheme:check-syntax:imported-identifier\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 37 +#"profj:syntax-coloring:scheme:keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 39 +#"profj:syntax-coloring:scheme:prim-type\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 0 139 0 0 0 -1 -1 2 40 +#"profj:syntax-coloring:scheme:identifier\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 36 +#"profj:syntax-coloring:scheme:string\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 37 +#"profj:syntax-coloring:scheme:literal\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 37 +#"profj:syntax-coloring:scheme:comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +35 #"profj:syntax-coloring:scheme:error\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 37 +#"profj:syntax-coloring:scheme:default\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 39 +#"profj:syntax-coloring:scheme:uncovered\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 37 +#"profj:syntax-coloring:scheme:covered\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 0 139 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 255 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 128 106 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 119 255 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 47 208 28 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 65 209 60 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 203 91 55 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +0 15 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 -2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 -2 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 50 205 50 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 90 +1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 0 -1 90 1 +#"\0" +0 70 1 #"\0" +0.6000000000000001 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 +0 0 0 -1 90 1 #"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 64 108 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 0 -1 2 +36 #"honu:syntax-coloring:scheme:keyword\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 40 +#"honu:syntax-coloring:scheme:parenthesis\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 35 +#"honu:syntax-coloring:scheme:string\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 36 +#"honu:syntax-coloring:scheme:literal\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 36 +#"honu:syntax-coloring:scheme:comment\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 +34 #"honu:syntax-coloring:scheme:error\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 39 +#"honu:syntax-coloring:scheme:identifier\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 36 +#"honu:syntax-coloring:scheme:default\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 90 1 +#"\0" +0 70 1 #"\0" +0.75 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 -2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 -2 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 50 205 50 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 +1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 0 -1 2 1 +#"\0" +0 70 1 #"\0" +0.6000000000000001 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 +0 0 0 -1 2 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 0 1 +#"\0" +0 75 8 #"Courier\0" +0 14 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 4 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 2 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +0.75 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 94 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 200 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 2 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 101 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 97 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 96 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 100 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 101 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 96 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 100 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 101 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 96 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 98 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 97 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 +100 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1.2000000476837158 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 +0 -1 -1 2 1 #"\0" +0 70 1 #"\0" +1.2000000476837158 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 +0 0 -1 -1 2 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 64 108 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +0.800000011920929 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 +0 0 0 -1 2 1 #"\0" +0 70 1 #"\0" +0.6000000238418579 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 +0 0 0 -1 2 1 #"\0" +0 70 1 #"\0" +0.800000011920929 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 +0 1 -1 2 1 #"\0" +0 70 1 #"\0" +0.800000011920929 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 +0 1 -1 2 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 68 64 108 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 60 248 52 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.800000011920929 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 64 108 +0 0 0 0 -1 2 1 #"\0" +0 70 1 #"\0" +0.800000011920929 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 +0 0 -1 2 1 #"\0" +0 75 1 #"\0" +0.800000011920929 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 +0 0 0 0 -1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 81 112 204 0 0 0 -1 -1 2 +47 #"drscheme:check-syntax:lexically-bound-variable\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 81 112 204 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 122 81 204 0 0 0 -1 -1 2 +40 #"drscheme:check-syntax:imported-variable\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 122 81 204 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 51 204 0 0 0 -1 -1 2 45 +#"drscheme:check-syntax:lexically-bound-syntax\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 51 204 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 0 204 0 0 0 -1 -1 2 38 +#"drscheme:check-syntax:imported-syntax\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 68 0 204 0 0 0 -1 -1 0 1 +#"\0" +0 75 8 #"Courier\0" +0 14 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 37 +#"syntax-coloring:Scheme Color:keyword\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 36 +#"syntax-coloring:Scheme Color:string\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 37 +#"syntax-coloring:Scheme Color:literal\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 105 105 105 0 0 0 -1 -1 2 +37 #"syntax-coloring:Scheme Color:comment\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 105 105 105 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 35 +#"syntax-coloring:Scheme Color:error\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 40 +#"syntax-coloring:Scheme Color:identifier\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 35 +#"syntax-coloring:Scheme Color:other\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 40 25 15 0 0 0 -1 -1 2 30 +#"drscheme:check-syntax:keyword\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 40 25 15 0 0 0 -1 -1 2 39 +#"drscheme:check-syntax:unbound-variable\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 37 +#"drscheme:check-syntax:bound-variable\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 32 +#"drscheme:check-syntax:primitive\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 51 135 39 0 0 0 -1 -1 2 31 +#"drscheme:check-syntax:constant\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 51 135 39 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 165 0 0 0 0 -1 -1 2 32 +#"drscheme:check-syntax:tail-call\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 165 0 0 0 0 -1 -1 2 27 +#"drscheme:check-syntax:base\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 29 +#"syntax-coloring:Java:keyword\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 2 28 +#"syntax-coloring:Java:string\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 2 29 +#"syntax-coloring:Java:literal\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 -1 -1 2 29 +#"syntax-coloring:Java:comment\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 105 105 105 0 0 0 -1 -1 2 +27 #"syntax-coloring:Java:error\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 139 0 0 0 -1 -1 2 32 +#"syntax-coloring:Java:identifier\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 0 0 139 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 169 169 169 0 0 0 -1 -1 2 +29 #"syntax-coloring:Java:default\0" +0 -1 1 #"\0" +1 0 -1 92 -1 93 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 169 169 169 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 40 25 15 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 165 0 0 0 0 -1 -1 0 1 +#"\0" +0 75 1 #"\0" +0 12 90 -1 90 -1 3 -1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 1 +#"\0" +0 75 8 #"Courier\0" +0 12 90 -1 90 -1 1 -1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 0 1 +#"\0" +0 75 12 #"Courier New\0" +0 12 90 90 90 90 3 3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 40 25 15 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 51 135 39 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" +0 75 8 #"Courier\0" +0 13 90 -1 90 -1 1 -1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 0 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 1 1 0 13 +#"h-link-style\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 1 1 2 1 #"\0" +0 -1 1 #"\0" +1 2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 2 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +1 321 326 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 326 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 329 +1 #"\0" +1 321 2 1 #"\0" +0 -1 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 331 1 +#"\0" +1 321 332 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 332 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 335 1 +#"\0" +1 321 2 1 #"\0" +0 -1 1 #"\0" +0.75 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 326 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 0 1 +#"\0" +0 75 1 #"\0" +0 12 90 90 90 90 3 3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 1 2 1 +#"\0" +0 71 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 1 1 2 1 +#"\0" +0 71 1 #"\0" +1 0 90 90 90 90 3 3 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 1 1 2 1 +#"\0" +0 71 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 1 1 2 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 0 100 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 0 0 128 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 165 42 42 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 150 0 150 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 94 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 1 1 0 1 #"\0" +0 75 7 #"Monaco\0" +0 12 90 90 90 90 3 3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 1 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" +0 70 1 #"\0" +0 12 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +2 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 354 1 #"\0" +1 321 0 1 #"\0" +0 70 1 #"\0" +1 -2 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 356 1 #"\0" +1 321 355 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 50 205 50 0 0 0 1 1 0 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 93 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 93 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 1 1 360 1 +#"\0" +1 321 353 1 #"\0" +1 321 362 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 362 1 #"\0" +0 75 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 93 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 326 1 #"\0" +0 70 1 #"\0" +1 0 90 90 93 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 1 1 2 1 +#"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 1 2 1 +#"\0" +0 75 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 1 1 2 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 75 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1.5 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 373 1 +#"\0" +1 321 326 1 #"\0" +0 70 1 #"\0" +0.800000011920929 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 +0 1 326 1 #"\0" +0 70 1 #"\0" +0.6000000238418579 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 +0 1 2 1 #"\0" +0 70 1 #"\0" +1.2000000476837158 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 +1 1 377 1 #"\0" +1 321 2 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 1 1 2 1 +#"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 68 64 108 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 -2 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 1 1 0 1 +#"\0" +0 75 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 1 1 0 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 1 0 1 +#"\0" +0 70 1 #"\0" +1.2000000476837158 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 +1 1 385 1 #"\0" +1 321 0 1 #"\0" +1 321 0 1 #"\0" +0 70 1 #"\0" +1.5 0 92 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 388 1 +#"\0" +1 321 0 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 387 1 #"\0" +0 70 1 #"\0" +0.800000011920929 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 +0 1 387 1 #"\0" +0 70 1 #"\0" +0.6000000238418579 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 +0 1 387 1 #"\0" +0 70 1 #"\0" +1 0 90 90 93 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 0 1 #"\0" +0 70 1 #"\0" +1 0 90 90 93 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 1 1 394 1 +#"\0" +1 321 326 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 1 1 390 1 +#"\0" +1 321 397 1 #"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 1 1 387 1 +#"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 1 1 0 1 +#"\0" +0 75 7 #"Monaco\0" +0 10 90 90 90 90 3 3 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 1 1 0 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 200 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 60 248 52 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 -1 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 0 90 90 94 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 255 255 0 1 1 45 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 1 45 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 0 1 #"\0" +0 75 8 #"Courier\0" +0 14 90 -1 90 -1 1 -1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 255 165 0 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 -3 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 3 0 153 0 0 0 1 1 2 1 #"\0" +0 70 1 #"\0" +1 -3 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 102 102 102 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 1 1 0 1 +#"\0" +0 75 12 #"Courier New\0" +0 12 90 -1 90 -1 3 -1 0 1 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 90 90 90 90 3 3 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 160 32 240 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 90 90 90 3 3 1 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 0 90 90 90 90 3 3 0 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 1 1 2 1 +#"\0" +0 70 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 -1 -1 0 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 1 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 80 80 248 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 60 248 52 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 255 255 0 -1 -1 101 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 96 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 99 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 101 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 97 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 96 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 100 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 0 1 +#"\0" +0 75 8 #"Courier\0" +0 13 90 -1 90 -1 1 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.800000011920929 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 +0 0 0 1 -1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 69 0 255 69 0 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 99 71 255 99 71 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 139 0 0 139 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 248 20 64 248 20 64 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 178 34 34 178 34 34 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 220 20 60 220 20 60 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 20 147 255 20 147 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 176 48 96 176 48 96 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 205 92 92 205 92 92 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 199 21 133 199 21 133 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 208 32 144 208 32 144 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 128 128 240 128 128 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 105 180 255 105 180 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 219 112 147 219 112 147 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 182 193 255 182 193 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 188 143 143 188 143 143 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 192 203 255 192 203 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 218 112 214 218 112 214 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 240 245 255 240 245 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 250 250 255 250 250 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 210 105 30 210 105 30 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 139 69 19 139 69 19 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 132 60 36 132 60 36 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 140 0 255 140 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 127 80 255 127 80 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 160 82 45 160 82 45 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 255 165 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 128 114 250 128 114 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 205 133 63 205 133 63 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 184 134 11 184 134 11 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 218 165 32 218 165 32 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 244 164 96 244 164 96 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 160 122 255 160 122 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 233 150 122 233 150 122 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 215 0 255 215 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 0 255 255 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 128 128 0 128 128 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 222 184 135 222 184 135 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 210 180 140 210 180 140 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 222 173 255 222 173 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 218 185 255 218 185 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 230 140 240 230 140 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 189 183 107 189 183 107 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 228 181 255 228 181 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 222 179 245 222 179 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 228 196 255 228 196 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 238 232 170 238 232 170 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 235 205 255 235 205 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 234 234 173 234 234 173 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 239 213 255 239 213 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 228 225 255 228 225 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 250 205 255 250 205 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 235 215 250 235 215 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 248 220 255 248 220 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 250 210 250 250 210 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 253 245 230 253 245 230 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 240 230 250 240 230 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 224 255 255 224 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 245 238 255 245 238 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 245 220 245 245 220 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 250 240 255 250 240 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 240 255 255 240 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 60 248 52 60 248 52 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 124 252 0 124 252 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 127 255 0 127 255 0 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 173 255 47 173 255 47 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 154 205 50 154 205 50 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 107 142 35 107 142 35 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 85 107 47 85 107 47 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 143 188 139 143 188 139 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 255 0 0 255 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 100 0 0 100 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 50 205 50 50 205 50 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 34 139 34 34 139 34 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 255 127 0 255 127 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 250 154 0 250 154 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 46 139 87 46 139 87 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 60 179 113 60 179 113 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 112 216 144 112 216 144 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 144 238 144 144 238 144 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 152 251 152 152 251 152 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 102 205 170 102 205 170 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 64 224 208 64 224 208 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 32 178 170 32 178 170 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 72 209 204 72 209 204 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 255 240 240 255 240 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 255 250 245 255 250 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 65 105 225 65 105 225 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 30 144 255 30 144 255 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 191 255 0 191 255 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 100 149 237 100 149 237 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 70 130 180 70 130 180 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 135 206 250 135 206 250 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 206 209 0 206 209 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 255 255 0 255 255 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 139 139 0 139 139 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 128 128 0 128 128 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 135 206 235 135 206 235 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 95 158 160 95 158 160 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 47 79 79 47 79 79 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 119 136 153 119 136 153 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 112 128 144 112 128 144 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 176 196 222 176 196 222 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 173 216 230 173 216 230 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 176 224 230 176 224 230 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 175 238 238 175 238 238 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 224 255 255 224 255 255 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 248 255 240 248 255 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 255 255 240 255 255 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 205 0 0 205 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 139 0 0 139 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 25 25 112 25 25 112 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 36 36 140 36 36 140 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 80 80 248 80 80 248 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 75 0 130 75 0 130 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 138 43 226 138 43 226 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 123 104 238 123 104 238 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 106 90 205 106 90 205 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 160 32 240 160 32 240 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 72 61 139 72 61 139 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 148 0 211 148 0 211 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 153 50 204 153 50 204 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 147 112 219 147 112 219 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 186 85 211 186 85 211 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 0 255 255 0 255 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 139 0 139 139 0 139 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 238 130 238 238 130 238 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 221 160 221 221 160 221 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 230 230 250 230 230 250 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 216 191 216 216 191 216 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 248 248 255 248 248 255 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 255 255 255 255 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 245 245 245 245 245 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 220 220 220 220 220 220 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 211 211 211 211 211 211 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 192 192 192 192 192 192 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 190 190 190 190 190 190 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 169 169 169 169 169 169 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 105 105 105 105 105 105 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 2 1 #"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 248 20 64 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 -2 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 4 1 +#"\0" +0 70 1 #"\0" +0 12 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 150 0 150 255 255 255 1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 255 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Times New Roman\0" +1 1 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Courier New\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Courier New\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Courier New\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 248 248 250 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 248 248 250 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 3 -1 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 102 153 248 248 250 -1 +-1 2 1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 1 0 0 0 0 0 0 0 0 255 248 248 250 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 3 -1 -1 -1 -1 -1 -1 1 0 0 0 0 1 0 0 0 0 0 0 0 0 255 248 248 250 -1 -1 +2 1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 4 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 97 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 0 -1 2 1 +#"\0" +0 70 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 99 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 102 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 99 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 70 7 #"Geneva\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Geneva\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Geneva\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Monaco\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Monaco\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Monaco\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Times\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Times\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Times\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Helvetica\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Helvetica\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Helvetica\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Courier\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Courier\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Courier\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Symbol\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Symbol\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Symbol\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #".Keyboard\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #".Keyboard\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #".Keyboard\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #".LastResort\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #".LastResort\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #".LastResort\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Lucida Grande\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Lucida Grande\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Lucida Grande\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Zapf Dingbats\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Zapf Dingbats\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Zapf Dingbats\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #".TimesLTMM_1_Wt_1_Wd\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #".TimesLTMM_1_Wt_1_Wd\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #".TimesLTMM_1_Wt_1_Wd\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #".HelveLTMM_170_Wt_1200_Wd\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #".HelveLTMM_170_Wt_1200_Wd\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #".HelveLTMM_170_Wt_1200_Wd\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Osaka\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Osaka\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Osaka\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Osaka\342\210\222\347\255\211\345\271\205\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Osaka\342\210\222\347\255\211\345\271\205\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Osaka\342\210\222\347\255\211\345\271\205\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 22 #"Apple LiGothic Medium\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 22 #"Apple LiGothic Medium\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 22 #"Apple LiGothic Medium\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"AppleGothic\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"AppleGothic\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"AppleGothic\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Monaco CY\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Monaco CY\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Monaco CY\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Lucida Grande CY\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Lucida Grande CY\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Lucida Grande CY\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Times CY\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Times CY\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Times CY\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 4 #"Hei\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 4 #"Hei\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 4 #"Hei\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geneva CE\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geneva CE\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geneva CE\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Monaco CE\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Monaco CE\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Monaco CE\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Times CE\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Times CE\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Times CE\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Helvetica CE\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Helvetica CE\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Helvetica CE\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Courier CE\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Courier CE\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Courier CE\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Pro W6\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Pro W6\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Pro W6\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Pro W3\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Pro W3\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Pro W3\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\344\270\270\343" + #"\202\264 Pro W4\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\344\270\270\343" + #"\202\264 Pro W4\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\344\270\270\343" + #"\202\264 Pro W4\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\346\230\216\346" + #"\234\235 Pro W6\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\346\230\216\346" + #"\234\235 Pro W6\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\346\230\216\346" + #"\234\235 Pro W6\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\346\230\216\346" + #"\234\235 Pro W3\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\346\230\216\346" + #"\234\235 Pro W3\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\346\230\216\346" + #"\234\235 Pro W3\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #".Aqua \343\201\213\343\201\252\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #".Aqua \343\201\213\343\201\252\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #".Aqua \343\201\213\343\201\252\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\347\273\206\351\273\221\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\347\273\206\351\273\221\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\347\273\206\351\273\221\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Std W8\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Std W8\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #"\343\203\222\343\203\251\343\202\256\343\203\216\350\247\222\343" + #"\202\264 Std W8\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Geeza Pro Bold\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Geeza Pro Bold\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Geeza Pro Bold\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Lucida Grande CE\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Lucida Grande CE\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Lucida Grande CE\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"\345\204\267\351\273\221 Pro\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"\345\204\267\351\273\221 Pro\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"\345\204\267\351\273\221 Pro\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geeza Pro\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geeza Pro\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geeza Pro\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #".Aqua \343\201\213\343\201\252 \343\203\234\343\203\274\343\203\253" + #"\343\203\211\0" +) 0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #".Aqua \343\201\213\343\201\252 \343\203\234\343\203\274\343\203\253" + #"\343\203\211\0" +) 0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 +( + #".Aqua \343\201\213\343\201\252 \343\203\234\343\203\274\343\203\253" + #"\343\203\211\0" +) 0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\351\273\221\344\275\223\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\351\273\221\344\275\223\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\351\273\221\344\275\223\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Zapfino\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Zapfino\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Zapfino\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Trebuchet MS\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Trebuchet MS\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Trebuchet MS\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Arial Narrow\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Arial Narrow\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Arial Narrow\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Courier New\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Courier New\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Courier New\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Times New Roman\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Times New Roman\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Times New Roman\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Hoefler Text\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Hoefler Text\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Hoefler Text\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 23 #"Hoefler Text Ornaments\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 23 #"Hoefler Text Ornaments\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 23 #"Hoefler Text Ornaments\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Marker Felt\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Marker Felt\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Marker Felt\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Impact\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Impact\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Impact\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 5 #"Skia\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 5 #"Skia\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 5 #"Skia\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Copperplate\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Copperplate\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Copperplate\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Apple Chancery\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Apple Chancery\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Apple Chancery\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 18 #"Copperplate Light\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 18 #"Copperplate Light\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 18 #"Copperplate Light\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Baskerville\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Baskerville\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Baskerville\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Baskerville Semibold\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Baskerville Semibold\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Baskerville Semibold\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Big Caslon\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Big Caslon\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Big Caslon\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 22 #"Arial Rounded MT Bold\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 22 #"Arial Rounded MT Bold\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 22 #"Arial Rounded MT Bold\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Brush Script MT\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Brush Script MT\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Brush Script MT\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 20 #"American Typewriter\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 20 #"American Typewriter\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 20 #"American Typewriter\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 30 #"American Typewriter Condensed\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 30 #"American Typewriter Condensed\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 30 #"American Typewriter Condensed\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #"American Typewriter Light\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #"American Typewriter Light\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #"American Typewriter Light\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 36 #"American Typewriter Condensed Light\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 36 #"American Typewriter Condensed Light\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 36 #"American Typewriter Condensed Light\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Futura\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Futura\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Futura\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Futura Condensed\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Futura Condensed\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 17 #"Futura Condensed\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 18 #"Optima ExtraBlack\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 18 #"Optima ExtraBlack\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 18 #"Optima ExtraBlack\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Herculanum\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Herculanum\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Herculanum\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Gill Sans\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Gill Sans\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Gill Sans\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Gill Sans Light\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Gill Sans Light\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Gill Sans Light\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Comic Sans MS\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Comic Sans MS\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Comic Sans MS\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Helvetica Neue\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Helvetica Neue\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"Helvetica Neue\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 30 #"Helvetica Neue Bold Condensed\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 30 #"Helvetica Neue Bold Condensed\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 30 #"Helvetica Neue Bold Condensed\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #"Helvetica Neue UltraLight\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #"Helvetica Neue UltraLight\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 26 #"Helvetica Neue UltraLight\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Helvetica Neue Light\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Helvetica Neue Light\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Helvetica Neue Light\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 31 #"Helvetica Neue Black Condensed\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 31 #"Helvetica Neue Black Condensed\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 31 #"Helvetica Neue Black Condensed\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Papyrus\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Papyrus\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Papyrus\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Optima\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Optima\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Optima\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Andale Mono\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Andale Mono\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Andale Mono\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Verdana\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Verdana\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Verdana\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Didot\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Didot\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Didot\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Arial Black\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Arial Black\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Arial Black\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Georgia\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Georgia\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Georgia\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Webdings\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Webdings\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Webdings\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Cochin\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Cochin\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 7 #"Cochin\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"BiauKai\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"BiauKai\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"BiauKai\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 19 #"Apple LiSung Light\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 19 #"Apple LiSung Light\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 19 #"Apple LiSung Light\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"AppleMyungjo\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"AppleMyungjo\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"AppleMyungjo\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"#\352\266\201\354\204\234\354\262\264\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"#\352\266\201\354\204\234\354\262\264\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"#\352\266\201\354\204\234\354\262\264\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"#\355\227\244\353\223\234\353\235\274\354\235\270A\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"#\355\227\244\353\223\234\353\235\274\354\235\270A\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"#\355\227\244\353\223\234\353\235\274\354\235\270A\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"#\355\225\204\352\270\260\354\262\264\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"#\355\225\204\352\270\260\354\262\264\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"#\355\225\204\352\270\260\354\262\264\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"#PC\353\252\205\354\241\260\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"#PC\353\252\205\354\241\260\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"#PC\353\252\205\354\241\260\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geneva CY\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geneva CY\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Geneva CY\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Charcoal CY\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Charcoal CY\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 12 #"Charcoal CY\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Helvetica CY\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Helvetica CY\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"Helvetica CY\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 4 #"Kai\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 4 #"Kai\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 4 #"Kai\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\345\256\213\344\275\223\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\345\256\213\344\275\223\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\345\256\213\344\275\223\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Chalkboard\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Chalkboard\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"Chalkboard\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Euphemia UCAS Italic\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Euphemia UCAS Italic\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Euphemia UCAS Italic\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"\345\204\267\345\256\213 Pro\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"\345\204\267\345\256\213 Pro\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 11 #"\345\204\267\345\256\213 Pro\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Ayuthaya\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Ayuthaya\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Ayuthaya\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Thonburi\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Thonburi\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 9 #"Thonburi\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\346\245\267\344\275\223\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\346\245\267\344\275\223\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\346\245\267\344\275\223\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 19 #"Euphemia UCAS Bold\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 19 #"Euphemia UCAS Bold\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 19 #"Euphemia UCAS Bold\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"InaiMathi\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"InaiMathi\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"InaiMathi\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Euphemia UCAS\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Euphemia UCAS\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 14 #"Euphemia UCAS\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Chalkboard Bold\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Chalkboard Bold\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 16 #"Chalkboard Bold\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Silom\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Silom\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Silom\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\344\273\277\345\256\213\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\344\273\277\345\256\213\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 13 #"\345\215\216\346\226\207\344\273\277\345\256\213\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"GB18030 Bitmap\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"GB18030 Bitmap\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 15 #"GB18030 Bitmap\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Krungthep\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Krungthep\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 10 #"Krungthep\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Sathu\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Sathu\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 6 #"Sathu\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Plantagenet Cherokee\0" +0 72 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Plantagenet Cherokee\0" +0 72 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 21 #"Plantagenet Cherokee\0" +0 72 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 2 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 2 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 2 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 0 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 0 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 0 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 2 -1 0 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 #"\0" +0 75 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 0 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 0 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 0 -1 0 1 +#"\0" +0 70 1 #"\0" +0.6400000000000001 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 +0 1 -1 0 1 #"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 0 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 0 1 +#"\0" +0 70 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 +#"\0" +0 70 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 2 -1 0 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 0 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 2 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 2 1 #"\0" +0 75 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 102 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 98 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 0 0 0 0 -1 -1 98 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 102 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 0 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 94 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 0 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 98 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 90 1 #"\0" +0 75 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 96 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 0 1 #"\0" +0 75 12 #"Courier New\0" +0 10 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 102 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 99 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 153 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 0 1 +#"\0" +0 75 12 #"Courier New\0" +0 7 90 -1 90 -1 3 -1 0 1 0 1 0 0 0 0 0 0 0 0 0 0 0 255 255 255 1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 160 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 160 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 92 -1 90 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 90 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 90 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 160 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1.5 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 34 139 34 0 0 0 -1 -1 99 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 100 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 178 34 34 255 255 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 90 1 +#"\0" +0 70 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 68 64 108 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 -1 90 +1 #"\0" +0 75 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 2 -1 4 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 255 0 0 0 0 -1 -1 0 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 255 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 2 -1 90 1 +#"\0" +0 70 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 -1 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 4 1 +#"\0" +0 71 1 #"\0" +1 0 -1 -1 94 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +2 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1.2 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 90 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 100 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 90 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 64 128 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 255 0 0 0 0 -1 -1 0 1 +#"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 255 0 0 0 0 2 -1 2 1 +#"\0" +0 70 6 #"Arial\0" +0.75 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 1 #"\0" +1 2 -1 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 -1 2 1 +#"\0" +0 75 1 #"\0" +0.8 0 -1 -1 93 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 36 36 140 0 0 0 1 -1 19 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 75 1 #"\0" +1 0 92 -1 93 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 69 0 255 69 0 -1 -1 90 +1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 99 71 255 99 71 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 139 0 0 139 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 0 0 255 0 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 178 34 34 178 34 34 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 220 20 60 220 20 60 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 20 147 255 20 147 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 176 48 96 176 48 96 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 205 92 92 205 92 92 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 199 21 133 199 21 133 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 208 32 144 208 32 144 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 128 128 240 128 128 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 105 180 255 105 180 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 219 112 147 219 112 147 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 182 193 255 182 193 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 188 143 143 188 143 143 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 192 203 255 192 203 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 218 112 214 218 112 214 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 240 245 255 240 245 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 250 250 255 250 250 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 210 105 30 210 105 30 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 139 69 19 139 69 19 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 132 60 36 132 60 36 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 140 0 255 140 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 127 80 255 127 80 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 160 82 45 160 82 45 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 165 0 255 165 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 128 114 250 128 114 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 205 133 63 205 133 63 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 184 134 11 184 134 11 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 218 165 32 218 165 32 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 244 164 96 244 164 96 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 160 122 255 160 122 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 233 150 122 233 150 122 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 215 0 255 215 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 0 255 255 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 128 128 0 128 128 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 222 184 135 222 184 135 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 210 180 140 210 180 140 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 222 173 255 222 173 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 218 185 255 218 185 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 230 140 240 230 140 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 189 183 107 189 183 107 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 228 181 255 228 181 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 222 179 245 222 179 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 228 196 255 228 196 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 238 232 170 238 232 170 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 235 205 255 235 205 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 234 234 173 234 234 173 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 239 213 255 239 213 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 228 225 255 228 225 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 250 205 255 250 205 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 235 215 250 235 215 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 248 220 255 248 220 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 250 210 250 250 210 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 253 245 230 253 245 230 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 250 240 230 250 240 230 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 224 255 255 224 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 245 238 255 245 238 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 245 220 245 245 220 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 250 240 255 250 240 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 240 255 255 240 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 255 0 0 255 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 124 252 0 124 252 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 127 255 0 127 255 0 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 173 255 47 173 255 47 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 154 205 50 154 205 50 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 107 142 35 107 142 35 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 85 107 47 85 107 47 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 143 188 139 143 188 139 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 100 0 0 100 0 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 50 205 50 50 205 50 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 34 139 34 34 139 34 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 255 127 0 255 127 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 250 154 0 250 154 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 46 139 87 46 139 87 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 60 179 113 60 179 113 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 112 216 144 112 216 144 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 144 238 144 144 238 144 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 152 251 152 152 251 152 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 102 205 170 102 205 170 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 64 224 208 64 224 208 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 32 178 170 32 178 170 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 72 209 204 72 209 204 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 255 240 240 255 240 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 255 250 245 255 250 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 65 105 225 65 105 225 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 30 144 255 30 144 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 191 255 0 191 255 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 100 149 237 100 149 237 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 70 130 180 70 130 180 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 135 206 250 135 206 250 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 206 209 0 206 209 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 255 255 0 255 255 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 139 139 0 139 139 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 128 128 0 128 128 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 135 206 235 135 206 235 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 95 158 160 95 158 160 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 47 79 79 47 79 79 -1 -1 90 +1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 119 136 153 119 136 153 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 112 128 144 112 128 144 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 176 196 222 176 196 222 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 173 216 230 173 216 230 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 176 224 230 176 224 230 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 175 238 238 175 238 238 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 224 255 255 224 255 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 248 255 240 248 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 240 255 255 240 255 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 205 0 0 205 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 139 0 0 139 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 25 25 112 25 25 112 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 36 36 140 36 36 140 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 255 0 0 255 -1 -1 90 1 +#"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 75 0 130 75 0 130 -1 -1 90 +1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 138 43 226 138 43 226 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 123 104 238 123 104 238 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 106 90 205 106 90 205 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 160 32 240 160 32 240 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 72 61 139 72 61 139 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 148 0 211 148 0 211 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 153 50 204 153 50 204 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 147 112 219 147 112 219 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 186 85 211 186 85 211 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 0 255 255 0 255 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 139 0 139 139 0 139 -1 -1 +90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 238 130 238 238 130 238 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 221 160 221 221 160 221 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 230 230 250 230 230 250 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 216 191 216 216 191 216 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 248 248 255 248 248 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 255 255 255 255 255 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 245 245 245 245 245 245 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 220 220 220 220 220 220 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 211 211 211 211 211 211 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 192 192 192 192 192 192 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 190 190 190 190 190 190 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 169 169 169 169 169 169 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 105 105 105 105 105 105 -1 +-1 90 1 #"\0" +0 70 1 #"\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 255 228 225 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 224 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 255 255 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 255 224 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 0 245 245 245 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 107 142 35 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 107 142 35 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 107 142 35 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 139 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 139 0 0 255 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 139 0 0 224 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 139 0 0 255 228 225 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 70 130 180 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 70 130 180 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 70 130 180 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 70 130 180 255 228 225 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 47 79 79 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 47 79 79 255 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 47 79 79 224 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 47 79 79 255 228 225 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 139 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 139 255 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 0 0 139 224 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 47 79 79 245 245 245 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 160 32 240 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 160 32 240 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 160 32 240 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 255 165 0 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 255 165 0 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 250 128 114 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 250 128 114 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 250 128 114 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 250 128 114 245 245 245 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 250 128 114 255 228 225 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 184 134 11 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 184 134 11 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 184 134 11 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 184 134 11 245 245 245 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 184 134 11 255 228 225 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 128 128 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 128 128 0 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 128 128 0 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 169 169 169 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 169 169 169 255 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 169 169 169 224 255 255 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 169 169 169 255 228 225 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 1 0 0 0 1 0 0 0 0 0 0 169 169 169 245 245 245 -1 +-1 2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 192 46 214 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 90 -1 94 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 255 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 94 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 57 89 216 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 90 -1 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 102 102 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 102 102 255 0 0 0 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 249 148 40 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 51 174 51 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 60 194 57 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 151 69 43 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 50 163 255 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 166 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 94 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 0 0 175 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 38 38 128 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 194 116 31 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 132 60 36 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 81 112 203 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 94 -1 -1 0 1 0 0 0 0 0 0 0 1 1 1 68 0 203 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 1 1 1 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 255 228 225 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 0 0 255 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 255 255 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 255 0 0 224 255 255 -1 -1 +2 1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 0 224 255 255 -1 -1 2 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 92 -1 -1 -1 -1 0 0 0 0 0 1 0 0 0 0 0 0 0 0 255 224 255 255 -1 -1 +2 1 #"\0" +0 70 8 #"Courier\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Courier\0" +1 0 92 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 2 1 +#"\0" +0 70 8 #"Courier\0" +1 0 92 -1 -1 -1 -1 -1 1 0 0 0 0 0 0 0 0 1 1 1 0 0 255 0 0 0 -1 -1 2 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 192 192 192 0 0 0 -1 -1 2 +1 #"\0" +0 70 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 192 192 192 0 0 0 -1 -1 22 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 14 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 22 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 14 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 20 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 1 1 1 178 34 34 0 0 0 -1 -1 22 1 +#"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 15 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 14 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 20 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 0 0 0 0 0 0 0 0 0 255 255 255 -1 -1 4 +1 #"\0" +0 -1 1 #"\0" +1 0 -1 -1 -1 -1 -1 -1 0 0 0 0 0 0 1 1 1 1 1 1 0 0 0 0 0 0 -1 -1 +00000000002 0 00000000000 39 00000000000 19 0 26 3 16 +#"#lang scheme/gui" +0 0 4 29 1 #"\n" +0 0 4 29 1 #"\n" +0 0 22 3 1 #"(" +0 0 15 3 6 #"define" +0 0 4 3 1 #" " +0 0 22 3 1 #"(" +0 0 14 3 11 #"single-line" +0 0 4 3 1 #" " +0 0 14 3 4 #"name" +0 0 4 3 1 #" " +0 0 14 3 4 #"link" +0 0 22 3 1 #")" +0 0 4 29 1 #"\n" +0 0 4 3 2 #" " +0 39 00000000060 4 0 00000000000 1 00000000001 41 00000000000 5 0 45 3 8 +#"" +0 41 00000000014 45 1 00000000000 1 00000000000 1 0 14 3 4 #"name" +0 00000000000 0 0 45 3 4 #"" +0 00000000000 0 0 22 3 1 #")" +0 0 4 29 1 #"\n" +0 0 4 29 1 #"\n" +0 00000000000 diff --git a/collects/xml/private/structures.ss b/collects/xml/private/structures.ss index b211c2b8f4..52d4708124 100644 --- a/collects/xml/private/structures.ss +++ b/collects/xml/private/structures.ss @@ -111,7 +111,7 @@ (struct (attribute source) ([start location/c] [stop location/c] [name symbol?] - [value string?])) + [value (or/c string? permissive/c)])) [permissive? (parameter/c boolean?)] [permissive/c contract?] [content/c contract?] diff --git a/collects/xml/private/xexpr.ss b/collects/xml/private/xexpr.ss index 38fdf7616d..f7d536251f 100644 --- a/collects/xml/private/xexpr.ss +++ b/collects/xml/private/xexpr.ss @@ -129,7 +129,8 @@ ;; True if the list is a list of String,Symbol pairs. (define (attribute-symbol-string? attr true false) (if (symbol? (car attr)) - (if (string? (cadr attr)) + (if (or (string? (cadr attr)) + (permissive?)) (true) (false (make-exn:invalid-xexpr (format "Expected a string, given ~a" (cadr attr)) diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl index 36d98fae47..a41328af4e 100644 --- a/collects/xml/xml.scrbl +++ b/collects/xml/xml.scrbl @@ -96,7 +96,7 @@ Represents a document.} [content (listof content/c)])]{ Represents an element.} -@defstruct[(attribute source) ([name symbol?] [value string?])]{ +@defstruct[(attribute source) ([name symbol?] [value (or/c string? permissive/c)])]{ Represents an attribute within an element.} From 6ee7b0379cda92726ac8d1b51a4d7ec704774b1c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 13 Mar 2009 16:08:06 +0000 Subject: [PATCH 014/140] add center valignment for table cells svn: r14089 --- collects/scribble/html-render.ss | 1 + collects/scribble/latex-render.ss | 19 +++++++++++-------- collects/scribblings/scribble/struct.scrbl | 3 ++- 3 files changed, 14 insertions(+), 9 deletions(-) diff --git a/collects/scribble/html-render.ss b/collects/scribble/html-render.ss index d2d904f59f..8888b06062 100644 --- a/collects/scribble/html-render.ss +++ b/collects/scribble/html-render.ss @@ -1076,6 +1076,7 @@ [(#f) null] [(top) '((valign "top"))] [(baseline) '((valign "baseline"))] + [(center) '((valign "center"))] [(bottom) '((valign "bottom"))]) ,@(if (string? st) `([class ,st]) diff --git a/collects/scribble/latex-render.ss b/collects/scribble/latex-render.ss index 4399ddd8e4..4633c9d590 100644 --- a/collects/scribble/latex-render.ss +++ b/collects/scribble/latex-render.ss @@ -302,12 +302,12 @@ (let ([flows (car flowss)] [row-style (car row-styles)]) (let loop ([flows flows] - [col-v-styles (and (list? row-style) - (or (let ([p (assoc 'valignment row-style)]) - (and p (cdr p))) - (let ([p (and (list? (table-style t)) - (assoc 'valignment (table-style t)))]) - (and p (cdr p)))))]) + [col-v-styles (or (and (list? row-style) + (let ([p (assoc 'valignment row-style)]) + (and p (cdr p)))) + (let ([p (and (list? (table-style t)) + (assoc 'valignment (table-style t)))]) + (and p (cdr p))))]) (unless (null? flows) (when index? (printf "\\item ")) (unless (eq? 'cont (car flows)) @@ -347,17 +347,20 @@ (printf "\\begin{tabular}~a{@{}l@{}}\n" (cond [(eq? vstyle 'top) "[t]"] + [(eq? vstyle 'center) "[c]"] [else ""]))) (let loop ([ps (flow-paragraphs p)]) (cond [(null? ps) (void)] [else - (let ([minipage? (not (or (paragraph? (car ps)) - (table? (car ps))))]) + (let ([minipage? (or (not (or (paragraph? (car ps)) + (table? (car ps)))) + (eq? vstyle 'center))]) (when minipage? (printf "\\begin{minipage}~a{~a\\linewidth}\n" (cond [(eq? vstyle 'top) "[t]"] + [(eq? vstyle 'center) "[c]"] [else ""]) (/ 1.0 twidth))) (render-block (car ps) part ri #f) diff --git a/collects/scribblings/scribble/struct.scrbl b/collects/scribblings/scribble/struct.scrbl index 5809ba0bae..60bb8e19d2 100644 --- a/collects/scribblings/scribble/struct.scrbl +++ b/collects/scribblings/scribble/struct.scrbl @@ -426,7 +426,8 @@ The @scheme[style] can be any of the following: @item{@scheme['valignment] to a list of symbols and @scheme[#f]s (one for each column); each symbol can be - @scheme['top], @scheme['baseline], or @scheme['bottom].} + @scheme['top], @scheme['baseline], @scheme['center], + or @scheme['bottom].} @item{@scheme['row-styles] to a list of association lists, one for each row in the table. Each of these nested From 0458416ec308d4667cac9b9d335cfae3828bc1c5 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Fri, 13 Mar 2009 20:58:40 +0000 Subject: [PATCH 015/140] stxclass: removed basic syntax classes svn: r14090 --- collects/stxclass/main.ss | 4 +- collects/stxclass/private/codegen.ss | 62 +++++++++++++-------------- collects/stxclass/private/rep-data.ss | 46 ++++++++++++++++---- collects/stxclass/private/rep.ss | 38 ++-------------- collects/stxclass/private/runtime.ss | 2 - collects/stxclass/private/sc.ss | 36 ---------------- 6 files changed, 70 insertions(+), 118 deletions(-) diff --git a/collects/stxclass/main.ss b/collects/stxclass/main.ss index f55c6ba21a..ba5bbc094c 100644 --- a/collects/stxclass/main.ss +++ b/collects/stxclass/main.ss @@ -4,10 +4,8 @@ "private/lib.ss") (provide define-syntax-class - define-basic-syntax-class - define-basic-syntax-class* pattern - basic-syntax-class + ~and ~or ...* diff --git a/collects/stxclass/private/codegen.ss b/collects/stxclass/private/codegen.ss index 81727b614f..0798fafc58 100644 --- a/collects/stxclass/private/codegen.ss +++ b/collects/stxclass/private/codegen.ss @@ -23,25 +23,22 @@ ;; Takes a list of the relevant attrs; order is significant! ;; Returns either fail or a list having length same as 'relsattrs' (define (parse:rhs rhs relsattrs args) - (cond [(rhs:union? rhs) - (with-syntax ([(arg ...) args]) - #`(lambda (x arg ...) - (define (fail-rhs x expected frontier frontier-stx) - #,(if (rhs-transparent? rhs) - #`(make-failed x expected frontier frontier-stx) - #'#f)) - (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) - #,(let ([pks (rhs->pks rhs relsattrs #'x)]) - (unless (pair? pks) - (wrong-syntax (rhs-orig-stx rhs) - "syntax class has no variants")) - (parse:pks (list #'x) - (list (empty-frontier #'x)) - #'fail-rhs - (list #f) - pks)))))] - [(rhs:basic? rhs) - (rhs:basic-parser rhs)])) + (with-syntax ([(arg ...) args]) + #`(lambda (x arg ...) + (define (fail-rhs x expected frontier frontier-stx) + #,(if (rhs-transparent? rhs) + #`(make-failed x expected frontier frontier-stx) + #'#f)) + (syntax-parameterize ((this-syntax (make-rename-transformer #'x))) + #,(let ([pks (rhs->pks rhs relsattrs #'x)]) + (unless (pair? pks) + (wrong-syntax (rhs-ostx rhs) + "syntax class has no variants")) + (parse:pks (list #'x) + (list (empty-frontier #'x)) + #'fail-rhs + (list #f) + pks)))))) ;; parse:clauses : stx identifier identifier -> stx (define (parse:clauses stx var phi) @@ -82,15 +79,15 @@ ;; rhs->pks : RHS (listof SAttr) identifier -> (listof PK) (define (rhs->pks rhs relsattrs main-var) (match rhs - [(struct rhs:union (orig-stx attrs transparent? description patterns)) + [(struct rhs:union (_ attrs transparent? description patterns)) (for*/list ([rhs patterns] [pk (rhs-pattern->pks rhs relsattrs main-var)]) pk)])) ;; rhs-pattern->pks : RHS (listof SAttr) identifier -> (listof PK) (define (rhs-pattern->pks rhs relsattrs main-var) (match rhs - [(struct rhs:pattern (orig-stx attrs pattern decls remap sides)) - (parameterize ((current-syntax-context orig-stx)) + [(struct rhs:pattern (ostx attrs pattern decls remap sides)) + (parameterize ((current-syntax-context ostx)) (define iattrs (append-attrs (cons (pattern-attrs pattern) @@ -311,7 +308,7 @@ Conventions: ;; parse:gseq:and : pat:and (listof Pattern) stx ;; -> stx (define (parse:group:and vars fcs phi ds and-pattern rest-patterns k) - (match-define (struct pat:and (orig-stx attrs depth description patterns)) + (match-define (struct pat:and (_ _ _ description patterns)) and-pattern) ;; FIXME: handle description (let ([var0-copies (for/list ([p patterns]) (car vars))] @@ -326,7 +323,7 @@ Conventions: ;; parse:compound:gseq : pat:gseq (listof Pattern) stx ;; -> stx (define (parse:group:gseq vars fcs phi ds gseq-pattern rest-patterns k) - (match-define (struct pat:gseq (orig-stx attrs depth heads tail)) gseq-pattern) + (match-define (struct pat:gseq (ostx attrs depth heads tail)) gseq-pattern) (define xvar (generate-temporary 'x)) (define head-lengths (for/list ([head heads]) (length (head-ps head)))) (define head-attrss (for/list ([head heads]) (flatten-attrs* (head-attrs head)))) @@ -348,7 +345,7 @@ Conventions: (map attr-name head-attrs))) (define completed-heads (for/list ([head heads]) - (complete-heads-pattern head xvar (add1 depth) orig-stx))) + (complete-heads-pattern head xvar (add1 depth) ostx))) (define hid-argss (map generate-temporaries head-idss)) (define hid-args (apply append hid-argss)) (define mins (map head-min heads)) @@ -436,12 +433,12 @@ Conventions: [rep 0] ...) (parse-loop var0 hid ... ... rep ... #,phi)))))) -;; complete-heads-patterns : Head identifier number stx -> Pattern -(define (complete-heads-pattern head rest-var depth seq-orig-stx) +;; complete-heads-patterns : Head identifier number -> Pattern +(define (complete-heads-pattern head rest-var depth seq-ostx) (define (loop ps pat) (if (pair? ps) (make pat:compound - (cons (pattern-orig-stx (car ps)) (pattern-orig-stx pat)) + (cons (pattern-ostx (car ps)) (pattern-ostx pat)) (append (pattern-attrs (car ps)) (pattern-attrs pat)) depth pairK @@ -449,7 +446,7 @@ Conventions: pat)) (define base (make pat:id - seq-orig-stx + seq-ostx (list (make-attr rest-var depth null)) depth rest-var #f null)) (loop (head-ps head) base)) @@ -493,8 +490,8 @@ Conventions: (let ([result (not (pattern-intersects? p1 p2))]) (when #f ;; result (printf "commutes!\n ~s\n & ~s\n" - (syntax->datum (pattern-orig-stx p1)) - (syntax->datum (pattern-orig-stx p2)))) + (syntax->datum (pattern-ostx p1)) + (syntax->datum (pattern-ostx p2)))) result)) (define (pattern-intersects? p1 p2) @@ -636,8 +633,7 @@ Conventions: (define (shift-pks:compound pks) (define (shift-pk pk0) (match pk0 - [(struct pk ((cons (struct pat:compound (orig-stx attrs depth kind patterns)) - rest-ps) + [(struct pk ((cons (struct pat:compound (_ _ _ _ patterns)) rest-ps) k)) (make-pk (append patterns rest-ps) k)])) (map shift-pk pks)) diff --git a/collects/stxclass/private/rep-data.ss b/collects/stxclass/private/rep-data.ss index 6de85b445f..7e06a6e34a 100644 --- a/collects/stxclass/private/rep-data.ss +++ b/collects/stxclass/private/rep-data.ss @@ -8,7 +8,6 @@ (struct-out attr) (struct-out rhs) (struct-out rhs:union) - (struct-out rhs:basic) (struct-out rhs:pattern) (struct-out pattern) (struct-out pat:id) @@ -34,22 +33,50 @@ #:transparent) ;; RHSBase is stx (listof SAttr) boolean stx/#f -(define-struct rhs (orig-stx attrs transparent? description) +(define-struct rhs (ostx attrs transparent? description) #:transparent) ;; A RHS is one of ;; (make-rhs:union (listof RHS)) -;; (make-rhs:basic stx) (define-struct (rhs:union rhs) (patterns) #:transparent) -(define-struct (rhs:basic rhs) (parser) - #:transparent) ;; An RHSPattern is ;; (make-rhs:pattern stx (listof SAttr) Pattern Env Env (listof SideClause)) -(define-struct rhs:pattern (stx attrs pattern decls remap whens) +(define-struct rhs:pattern (stx attrs pattern decls remap sides) #:transparent) +#| + +NOT YET ... + +;; A Pattern is +;; (make-pattern (listof IAttr) PCtx (listof id) string/#f Descriminator) +(define-struct pattern (attrs ctx names description descrim) #:transparent) + +;; A PatternContext (PCtx) is +;; (make-pctx stx nat (listof IAttr) (listof IAttr)) +(define-struct pctx (ostx depth env outer-env) #:transparent) + +;; A Descriminator is one of +;; (make-d:any) +;; (make-d:stxclass SC (listof stx)) +;; (make-d:datum datum) +;; (make-d:literal id) +;; (make-d:gseq (listof Head) Pattern) +;; (make-d:and (listof Pattern)) +;; (make-d:orseq (listof Head)) +;; (make-d:compound Kind (listof Pattern)) +(define-struct d:any () #:transparent) +(define-struct d:stxclass (stxclass args) #:transparent) +(define-struct d:datum (datum) #:transparent) +(define-struct d:literal (literal) #:transparent) +(define-struct d:gseq (heads tail) #:transparent) +(define-struct d:and (subpatterns) #:transparent) +(define-struct d:orseq (heads) #:transparent) +(define-struct d:compound (kind patterns) #:transparent) +|# + ;; A Pattern is one of ;; (make-pat:id identifier SC/#f (listof stx)) ;; (make-pat:datum datum) @@ -59,7 +86,7 @@ ;; (make-pat:and string/#f (listof Pattern)) ;; (make-pat:compound Kind (listof Pattern)) ;; when = stx (listof IAttr) number -(define-struct pattern (orig-stx attrs depth) #:transparent) +(define-struct pattern (ostx attrs depth) #:transparent) (define-struct (pat:id pattern) (name stxclass args) #:transparent) (define-struct (pat:datum pattern) (datum) #:transparent) (define-struct (pat:literal pattern) (literal) #:transparent) @@ -72,8 +99,9 @@ (define-struct kind (predicate selectors frontier-procs) #:transparent) ;; A Head is -;; (make-head stx (listof IAttr) nat (listof Pattern) nat/f nat/f boolean id/#f stx/#f) -(define-struct head (orig-stx attrs depth ps min max as-list?) #:transparent) +;; (make-head stx (listof IAttr) nat (listof Pattern) +;; nat/f nat/f boolean id/#f stx/#f) +(define-struct head (ostx attrs depth ps min max as-list?) #:transparent) ;; A SideClause is one of ;; (make-clause:with pattern stx) diff --git a/collects/stxclass/private/rep.ss b/collects/stxclass/private/rep.ss index dd96ade8d5..d604bae802 100644 --- a/collects/stxclass/private/rep.ss +++ b/collects/stxclass/private/rep.ss @@ -102,30 +102,6 @@ (define transparent? (and trans0 #t)) (define attributes (and attrs0 (caddr attrs0))) - (define (parse-rhs*-basic rhss) - (syntax-case rhss (basic-syntax-class) - [((basic-syntax-class . rest)) - (let-values ([(basic-chunks rest) - (chunk-kw-seq/no-dups #'rest basic-rhs-directive-table - #:context (stx-car rhss))]) - (syntax-case rest () - [(parser-expr) - (make rhs:basic ctx - (or attributes null) - transparent? - description - (if (assq '#:transforming basic-chunks) - #'parser-expr - #`(let ([parser parser-expr]) - (lambda (x . args) - (let ([result (apply parser x args)]) - (if (ok? result) - (cons x result) - result))))))] - [_ - (wrong-syntax (stx-car rhss) - "expected parser expression")]))])) - (define (parse-rhs*-patterns rest) (define (gather-patterns stx) (syntax-case stx (pattern) @@ -145,11 +121,7 @@ description patterns))) - (syntax-case rest (pattern basic-syntax-class) - [((basic-syntax-class . _)) - (parse-rhs*-basic rest)] - [_ - (parse-rhs*-patterns rest)])) + (parse-rhs*-patterns rest)) ;; parse-rhs-pattern : stx boolean boolean (listof id+id) -> RHS (define (parse-rhs-pattern stx allow-unbound? literals) @@ -278,8 +250,8 @@ (define (pattern->head p) (match p - [(struct pattern (orig-stx iattrs depth)) - (make head orig-stx iattrs depth (list p) #f #f #t)])) + [(struct pattern (ostx iattrs depth)) + (make head ostx iattrs depth (list p) #f #f #t)])) (define (parse-heads stx decls enclosing-depth) (syntax-case stx () @@ -468,10 +440,6 @@ (list '#:transparent) (list '#:attributes check-attr-arity-list))) -;; basic-rhs-directive-table -(define basic-rhs-directive-table - (list (list '#:transforming))) - ;; pattern-directive-table (define pattern-directive-table (list (list '#:declare check-id values) diff --git a/collects/stxclass/private/runtime.ss b/collects/stxclass/private/runtime.ss index 22a3bdaaad..ba9ecebdee 100644 --- a/collects/stxclass/private/runtime.ss +++ b/collects/stxclass/private/runtime.ss @@ -8,7 +8,6 @@ (for-syntax "rep-data.ss") (for-syntax "../util/error.ss")) (provide pattern - basic-syntax-class ~and ~or ...* @@ -44,7 +43,6 @@ (raise-syntax-error #f "keyword used out of context" stx)))) (define-keyword pattern) -(define-keyword basic-syntax-class) (define-keyword ~and) (define-keyword ~or) (define-keyword ...*) diff --git a/collects/stxclass/private/sc.ss b/collects/stxclass/private/sc.ss index 1f9e10b039..453d8e63fb 100644 --- a/collects/stxclass/private/sc.ss +++ b/collects/stxclass/private/sc.ss @@ -12,8 +12,6 @@ "runtime.ss") (provide define-syntax-class - define-basic-syntax-class - define-basic-syntax-class* parse-sc attrs-of @@ -22,7 +20,6 @@ with-patterns pattern - basic-syntax-class ~and ~or ...* @@ -92,39 +89,6 @@ (syntax/loc stx (define-syntax-class (name) . rhss))])) -(define-syntax define-basic-syntax-class - (syntax-rules () - [(define-basic-syntax-class (name arg ...) - ([attr-name attr-depth] ...) - parser-expr) - (define-basic-syntax-class* (name arg ...) - ([attr-name attr-depth] ...) - (let ([name parser-expr]) - (let ([name - (lambda (x arg ...) - (let ([r (name x arg ...)]) - (if (ok? r) - (cons x r) - r)))]) - name)))] - [(define-basic-syntax-class name - ([attr-name attr-depth] ...) - parser-expr) - (define-basic-syntax-class (name) - ([attr-name attr-depth] ...) - parser-expr)])) - -(define-syntax define-basic-syntax-class* - (syntax-rules () - [(define-basic-syntax-class* (name arg ...) - ([attr-name attr-depth] ...) - parser-expr) - (define-syntax-class (name arg ...) - #:attributes ([attr-name attr-depth] ...) - (basic-syntax-class - #:transforming - (let ([name parser-expr]) name)))])) - (define-syntax (rhs->parser+description stx) (syntax-case stx () [(rhs->parser+description name rhss (arg ...) ctx) From 2e0c4e6585387d5b355c227e68b9d84af6857e5e Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Fri, 13 Mar 2009 23:31:58 +0000 Subject: [PATCH 016/140] svn: r14091 --- collects/parser-tools/parser-tools.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/parser-tools/parser-tools.scrbl b/collects/parser-tools/parser-tools.scrbl index d10806ab5d..e0cbd21223 100644 --- a/collects/parser-tools/parser-tools.scrbl +++ b/collects/parser-tools/parser-tools.scrbl @@ -157,8 +157,8 @@ are a few examples, using @scheme[:] prefixed SRE syntax: action: @itemize{ - @item{@scheme[start-pos] --- a position struct for the first character matched.} - @item{@scheme[end-pos] --- a position struct for the character after the last character in the match.} + @item{@scheme[start-pos] --- a @scheme[position] struct for the first character matched.} + @item{@scheme[end-pos] --- a @scheme[position] struct for the character after the last character in the match.} @item{@scheme[lexeme] --- the matched string.} @item{@scheme[input-port] --- the input-port being processed (this is useful for matching input with multiple From d9b543ae6f7bfca52702706438857c988025c660 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 14 Mar 2009 07:50:22 +0000 Subject: [PATCH 017/140] Welcome to a new PLT day. svn: r14092 --- 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 c4515cdbee..00bdfb0b78 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "13mar2009") +#lang scheme/base (provide stamp) (define stamp "14mar2009") From dc8c06381abe077b773944a1c531c35a8914b621 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 14 Mar 2009 09:38:05 +0000 Subject: [PATCH 018/140] fix algorithmic problems in syntax-object resolution with nested intdef contexts svn: r14093 --- src/mzscheme/src/stxobj.c | 129 ++++++++++++++++++++++++++++++++++---- 1 file changed, 117 insertions(+), 12 deletions(-) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index f73561d3e7..62ed20871f 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -77,10 +77,10 @@ static Scheme_Object *origin_symbol; static Scheme_Object *lexical_symbol; static Scheme_Object *protected_symbol; -static Scheme_Object *nominal_ipair_cache; +static THREAD_LOCAL Scheme_Object *nominal_ipair_cache; -static Scheme_Object *mark_id = scheme_make_integer(0); -static Scheme_Object *current_rib_timestamp = scheme_make_integer(0); +static THREAD_LOCAL Scheme_Object *mark_id = scheme_make_integer(0); +static THREAD_LOCAL Scheme_Object *current_rib_timestamp = scheme_make_integer(0); static Scheme_Stx_Srcloc *empty_srcloc; @@ -88,11 +88,12 @@ static Scheme_Object *empty_simplified; static Scheme_Hash_Table *empty_hash_table; -static Scheme_Object *last_phase_shift; +static THREAD_LOCAL Scheme_Object *last_phase_shift; -/* caches */ -static THREAD_LOCAL Scheme_Hash_Table *id_marks_ht; -static THREAD_LOCAL Scheme_Hash_Table *than_id_marks_ht; +static THREAD_LOCAL Scheme_Object *unsealed_dependencies; + +static THREAD_LOCAL Scheme_Hash_Table *id_marks_ht; /* a cache */ +static THREAD_LOCAL Scheme_Hash_Table *than_id_marks_ht; /* a cache */ static Scheme_Object *no_nested_inactive_certs; @@ -225,6 +226,9 @@ static Module_Renames *krn; ->pos) void => not yet computed or #f sym => mark check done, var-resolved is answer to replace #f + for nozero skipped ribs + (rlistof (rcons skipped sym)) => generalization of sym + (mcons var-resolved next) => depends on unsealed rib - A wrap-elem (vector ... ...) is also a lexical rename var resolved where the variables have already been resolved and filtered (no mark @@ -560,6 +564,8 @@ void scheme_init_stx(Scheme_Env *env) REGISTER_SO(no_nested_inactive_certs); no_nested_inactive_certs = scheme_make_raw_pair(NULL, NULL); SCHEME_SET_IMMUTABLE(no_nested_inactive_certs); + + REGISTER_SO(unsealed_dependencies); } /*========================================================================*/ @@ -1059,6 +1065,7 @@ Scheme_Object *scheme_make_rename_rib() void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename) { Scheme_Lexical_Rib *rib, *naya; + Scheme_Object *next; naya = MALLOC_ONE_TAGGED(Scheme_Lexical_Rib); naya->so.type = scheme_lexical_rib_type; @@ -1070,6 +1077,13 @@ void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename) naya->timestamp = rib->timestamp; naya->sealed = rib->sealed; + + while (unsealed_dependencies) { + next = SCHEME_CDR(unsealed_dependencies); + SCHEME_CAR(unsealed_dependencies) = NULL; + SCHEME_CDR(unsealed_dependencies) = NULL; + unsealed_dependencies = next; + } } void scheme_drop_first_rib_rename(Scheme_Object *ro) @@ -3614,7 +3628,89 @@ static int in_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) static Scheme_Object *add_skip_set(Scheme_Object *timestamp, Scheme_Object *skip_ribs) { - return scheme_make_raw_pair(timestamp, skip_ribs); + if (in_skip_set(timestamp, skip_ribs)) + return skip_ribs; + else + return scheme_make_raw_pair(timestamp, skip_ribs); +} + +XFORM_NONGCING static int same_skipped_ribs(Scheme_Object *a, Scheme_Object *b) +{ + while (a) { + if (!b) return 0; + if (!SAME_OBJ(SCHEME_CAR(a), SCHEME_CAR(b))) + return 0; + a = SCHEME_CDR(a); + b = SCHEME_CDR(b); + } + return !b; +} + +XFORM_NONGCING static Scheme_Object *filter_cached_env(Scheme_Object *other_env, Scheme_Object *skip_ribs) +{ + Scheme_Object *p; + + if (SCHEME_MPAIRP(other_env)) { + other_env = SCHEME_CAR(other_env); + if (!other_env) + return scheme_void; + } + + if (SCHEME_RPAIRP(other_env)) { + while (other_env) { + p = SCHEME_CAR(other_env); + if (same_skipped_ribs(SCHEME_CAR(p), skip_ribs)) + return SCHEME_CDR(p); + other_env = SCHEME_CDR(other_env); + } + return scheme_void; + } else if (!skip_ribs) + return other_env; + else + return scheme_void; +} + +static Scheme_Object *extend_cached_env(Scheme_Object *orig, Scheme_Object *other_env, Scheme_Object *skip_ribs, + int depends_on_unsealed_rib) +{ + Scheme_Object *in_mpair = NULL; + + if (SCHEME_MPAIRP(orig)) { + in_mpair = orig; + orig = SCHEME_CAR(orig); + if (!depends_on_unsealed_rib && !orig) { + /* no longer depends on unsealed rib: */ + in_mpair = NULL; + orig = scheme_void; + } else { + /* (some) still depends on unsealed rib: */ + if (!orig) { + /* re-register in list of dependencies */ + SCHEME_CDR(in_mpair) = unsealed_dependencies; + unsealed_dependencies = in_mpair; + orig = scheme_void; + } + } + } else if (depends_on_unsealed_rib) { + /* register dependency: */ + in_mpair = scheme_make_mutable_pair(NULL, unsealed_dependencies); + unsealed_dependencies = in_mpair; + } + + if (SCHEME_VOIDP(orig) && !skip_ribs) { + orig = other_env; + } else { + if (!SCHEME_RPAIRP(orig)) + orig = scheme_make_raw_pair(scheme_make_raw_pair(NULL, orig), NULL); + + orig = scheme_make_raw_pair(scheme_make_raw_pair(skip_ribs, other_env), orig); + } + + if (in_mpair) { + SCHEME_CAR(in_mpair) = orig; + return in_mpair; + } else + return orig; } #define QUICK_STACK_SIZE 8 @@ -4000,13 +4096,18 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } else { envname = SCHEME_VEC_ELS(rename)[0]; other_env = SCHEME_VEC_ELS(rename)[2+c+ri]; - + other_env = filter_cached_env(other_env, recur_skip_ribs); + if (SCHEME_VOIDP(other_env)) { int rib_dep = 0; SCHEME_USE_FUEL(1); other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1); - if (!is_rib && !rib_dep) - SCHEME_VEC_ELS(rename)[2+c+ri] = other_env; + { + Scheme_Object *e; + e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs, + (is_rib && !(*is_rib->sealed)) || rib_dep); + SCHEME_VEC_ELS(rename)[2+c+ri] = e; + } if (rib_dep) depends_on_unsealed_rib = 1; SCHEME_USE_FUEL(1); @@ -4065,6 +4166,8 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } } if (rib) { + if (!*rib->sealed) + depends_on_unsealed_rib = 1; if (nonempty_rib(rib)) { if (SAME_OBJ(did_rib, rib)) { EXPLAIN(fprintf(stderr, "%d Did rib\n", depth)); @@ -4925,6 +5028,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab /* No. Should we skip? */ Scheme_Object *other_env; other_env = SCHEME_VEC_ELS(rib->rename)[2+vsize+i]; + other_env = filter_cached_env(other_env, prec_ribs); if (SCHEME_VOIDP(other_env)) { int rib_dep; other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0); @@ -5093,6 +5197,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab } other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; + other_env = filter_cached_env(other_env, prec_ribs); if (SCHEME_VOIDP(other_env)) { int rib_dep; other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0); @@ -5100,7 +5205,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); return NULL; } - if (!rib) + if (!prec_ribs) SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; } From 8f0fd5a555ddc5319c749f5780846a58fca5565c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 14 Mar 2009 10:21:10 +0000 Subject: [PATCH 019/140] fix submenus in popup menus svn: r14094 --- src/wxmac/src/mac/wx_menu.cc | 1 + 1 file changed, 1 insertion(+) diff --git a/src/wxmac/src/mac/wx_menu.cc b/src/wxmac/src/mac/wx_menu.cc index ede59182dc..ca72f799c2 100644 --- a/src/wxmac/src/mac/wx_menu.cc +++ b/src/wxmac/src/mac/wx_menu.cc @@ -329,6 +329,7 @@ MenuHandle wxMenu::CreateCopy(char *title, Bool doabouthack, MenuHandle toHandle title = wxBuildMacMenuString(tempString, menuItem->itemName, NULL, NULL, NULL); subMenu = menuItem->subMenu; subMenu->wxMacInsertSubmenu(); + ::InsertMenu(subMenu->cMacMenu, -1); hId = subMenu->cMacMenuId; } else { title = wxBuildMacMenuString(tempString, menuItem->itemName, &spc, &modifiers, &is_virt); From 43d2625aceb95e3ae211c00b44506e956f0c0194 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Sat, 14 Mar 2009 12:34:12 +0000 Subject: [PATCH 020/140] added docs to make-bundle svn: r14096 --- collects/teachpack/2htdp/scribblings/universe.scrbl | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/teachpack/2htdp/scribblings/universe.scrbl b/collects/teachpack/2htdp/scribblings/universe.scrbl index 25b41981d7..e8da05e248 100644 --- a/collects/teachpack/2htdp/scribblings/universe.scrbl +++ b/collects/teachpack/2htdp/scribblings/universe.scrbl @@ -940,7 +940,7 @@ for universe programs. For example: } @item{Each event handler produces a @emph{bundle}, which is a structure - that contains the list of @emph{iworld}s to keep track of; the + that contains the list of @emph{iworld}s that the universe must track; the @tech{server}'s remaining state; and a list of mails to other worlds: @@ -948,8 +948,11 @@ for universe programs. For example: determines whether @scheme[x] is a @emph{bundle}.} @defproc[(make-bundle [low (listof iworld?)] [state any/c] [mails (listof mail?)]) bundle?]{ - creates a @emph{bundle} from a list of iworlds, a piece of data that represents a server - state, and a list of mails.} + creates a @emph{bundle} from a list of iworlds, a piece of data that + represents a server state, and a list of mails.} + +If an event handler returns a bundle with an empty list of worlds, the +universe server is restarted in the initial state. A @emph{mail} represents a message from an event handler to a world. The teachpack provides only a predicate and a constructor for these structures: @@ -960,7 +963,6 @@ teachpack provides only a predicate and a constructor for these structures: @defproc[(make-mail [to iworld?] [content sexp?]) mail?]{ creates a @emph{mail} from a @emph{iworld} and an @tech{S-expression}.} } - ] @; ----------------------------------------------------------------------------- @@ -1039,7 +1041,6 @@ The mandatory clauses of a @scheme[universe] server description are @scheme[w] is guaranteed to be on the list @scheme[low]. } }] - All proper event handlers produce a @emph{bundle}. The list of worlds in this @emph{bundle} becomes the server's list of worlds, meaning that only the server listens only to messages from "approved" worlds. The state in From 7d71c34ba9a5ff6f659bdac1a6a9e38ab4b09da0 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Sat, 14 Mar 2009 13:42:57 +0000 Subject: [PATCH 021/140] Consolidate the DMdA docs into a single chapter. svn: r14098 --- .../deinprogramm/scribblings/DMdA-lib.scrbl | 2 +- .../scribblings/deinprogramm-langs.scrbl | 25 -------------- .../scribblings/deinprogramm.scrbl | 31 ++++++++++++++++++ .../deinprogramm/scribblings/image.scrbl | 0 collects/deinprogramm/scribblings/info.ss | 3 +- .../deinprogramm/scribblings/line3d.scrbl | 0 .../deinprogramm/scribblings/p1.jpg | Bin .../deinprogramm/scribblings/p2.jpg | Bin .../deinprogramm/scribblings/p3.jpg | Bin .../deinprogramm/scribblings/p4.jpg | Bin .../deinprogramm/scribblings/shared.ss | 0 .../deinprogramm/scribblings/sound.scrbl | 0 .../deinprogramm/scribblings/turtle.scrbl | 0 .../deinprogramm/scribblings/world.scrbl | 0 .../scribblings/deinprogramm.scrbl | 18 ---------- .../deinprogramm/scribblings/info.ss | 3 -- 16 files changed, 33 insertions(+), 49 deletions(-) delete mode 100644 collects/deinprogramm/scribblings/deinprogramm-langs.scrbl create mode 100644 collects/deinprogramm/scribblings/deinprogramm.scrbl rename collects/{teachpack => }/deinprogramm/scribblings/image.scrbl (100%) rename collects/{teachpack => }/deinprogramm/scribblings/line3d.scrbl (100%) rename collects/{teachpack => }/deinprogramm/scribblings/p1.jpg (100%) rename collects/{teachpack => }/deinprogramm/scribblings/p2.jpg (100%) rename collects/{teachpack => }/deinprogramm/scribblings/p3.jpg (100%) rename collects/{teachpack => }/deinprogramm/scribblings/p4.jpg (100%) rename collects/{teachpack => }/deinprogramm/scribblings/shared.ss (100%) rename collects/{teachpack => }/deinprogramm/scribblings/sound.scrbl (100%) rename collects/{teachpack => }/deinprogramm/scribblings/turtle.scrbl (100%) rename collects/{teachpack => }/deinprogramm/scribblings/world.scrbl (100%) delete mode 100644 collects/teachpack/deinprogramm/scribblings/deinprogramm.scrbl delete mode 100644 collects/teachpack/deinprogramm/scribblings/info.ss diff --git a/collects/deinprogramm/scribblings/DMdA-lib.scrbl b/collects/deinprogramm/scribblings/DMdA-lib.scrbl index e372fa50ce..28b3b13712 100644 --- a/collects/deinprogramm/scribblings/DMdA-lib.scrbl +++ b/collects/deinprogramm/scribblings/DMdA-lib.scrbl @@ -10,7 +10,7 @@ lang/prim)) @(define DMdA @italic{Die Macht der Abstraktion}) -@(define (DMdA-ref s) @secref[#:doc '(lib "deinprogramm/scribblings/deinprogramm-langs.scrbl") s]) +@(define (DMdA-ref s) @secref[#:doc '(lib "deinprogramm/scribblings/deinprogramm.scrbl") s]) Note: This is documentation for the language levels that go with the German textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die diff --git a/collects/deinprogramm/scribblings/deinprogramm-langs.scrbl b/collects/deinprogramm/scribblings/deinprogramm-langs.scrbl deleted file mode 100644 index 383f5150b7..0000000000 --- a/collects/deinprogramm/scribblings/deinprogramm-langs.scrbl +++ /dev/null @@ -1,25 +0,0 @@ -#lang scribble/doc -@(require scribblings/htdp-langs/common) - -@title{Sprachebenen für @italic{Die Macht der Abstraktion}} - -Note: This is documentation for the language levels that go with the -German textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die -Macht der Abstraktion}}. - -Die Sprachebenen in diesem Handbuch sind für Verwendung mit dem Buch -the @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der -Abstraktion}} gedacht. - -@table-of-contents[] - -@;------------------------------------------------------------------------ - -@include-section["DMdA-beginner.scrbl"] -@include-section["DMdA-vanilla.scrbl"] -@include-section["DMdA-assignments.scrbl"] -@include-section["DMdA-advanced.scrbl"] - -@;------------------------------------------------------------------------ - -@index-section[] diff --git a/collects/deinprogramm/scribblings/deinprogramm.scrbl b/collects/deinprogramm/scribblings/deinprogramm.scrbl new file mode 100644 index 0000000000..daddab6653 --- /dev/null +++ b/collects/deinprogramm/scribblings/deinprogramm.scrbl @@ -0,0 +1,31 @@ +#lang scribble/doc + +@(require scribble/manual + (for-label scheme)) + +@title[#:style '(toc) #:tag "deinprogramm"]{Sprachebenen und Material zu @italic{Die Macht der Abstraktion}} + +Note: This is documentation for the teachpacks that go with the German +textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht +der Abstraktion}}. + +Die Sprachebenen und Teachpacks in diesem Handbuch sind für Verwendung +mit dem Buch the @italic{@link["http://www.deinprogramm.de/dmda/"]{Die +Macht der Abstraktion}} gedacht. + +@table-of-contents[] + +@include-section["DMdA-beginner.scrbl"] +@include-section["DMdA-vanilla.scrbl"] +@include-section["DMdA-assignments.scrbl"] +@include-section["DMdA-advanced.scrbl"] + +@include-section["ka.scrbl"] + +@include-section["image.scrbl"] +@include-section["world.scrbl"] +@include-section["turtle.scrbl"] +@include-section["sound.scrbl"] +@include-section["line3d.scrbl"] + +@index-section[] diff --git a/collects/teachpack/deinprogramm/scribblings/image.scrbl b/collects/deinprogramm/scribblings/image.scrbl similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/image.scrbl rename to collects/deinprogramm/scribblings/image.scrbl diff --git a/collects/deinprogramm/scribblings/info.ss b/collects/deinprogramm/scribblings/info.ss index 2ac704094a..cb89cb8058 100644 --- a/collects/deinprogramm/scribblings/info.ss +++ b/collects/deinprogramm/scribblings/info.ss @@ -1,6 +1,5 @@ #lang setup/infotab -(define scribblings '(("deinprogramm-langs.scrbl" (multi-page) (language -14)) - ("ka.scrbl" (multi-page) (other -10)) +(define scribblings '(("deinprogramm.scrbl" (multi-page) (language -14)) ("DMdA-lib.scrbl"))) diff --git a/collects/teachpack/deinprogramm/scribblings/line3d.scrbl b/collects/deinprogramm/scribblings/line3d.scrbl similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/line3d.scrbl rename to collects/deinprogramm/scribblings/line3d.scrbl diff --git a/collects/teachpack/deinprogramm/scribblings/p1.jpg b/collects/deinprogramm/scribblings/p1.jpg similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/p1.jpg rename to collects/deinprogramm/scribblings/p1.jpg diff --git a/collects/teachpack/deinprogramm/scribblings/p2.jpg b/collects/deinprogramm/scribblings/p2.jpg similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/p2.jpg rename to collects/deinprogramm/scribblings/p2.jpg diff --git a/collects/teachpack/deinprogramm/scribblings/p3.jpg b/collects/deinprogramm/scribblings/p3.jpg similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/p3.jpg rename to collects/deinprogramm/scribblings/p3.jpg diff --git a/collects/teachpack/deinprogramm/scribblings/p4.jpg b/collects/deinprogramm/scribblings/p4.jpg similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/p4.jpg rename to collects/deinprogramm/scribblings/p4.jpg diff --git a/collects/teachpack/deinprogramm/scribblings/shared.ss b/collects/deinprogramm/scribblings/shared.ss similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/shared.ss rename to collects/deinprogramm/scribblings/shared.ss diff --git a/collects/teachpack/deinprogramm/scribblings/sound.scrbl b/collects/deinprogramm/scribblings/sound.scrbl similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/sound.scrbl rename to collects/deinprogramm/scribblings/sound.scrbl diff --git a/collects/teachpack/deinprogramm/scribblings/turtle.scrbl b/collects/deinprogramm/scribblings/turtle.scrbl similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/turtle.scrbl rename to collects/deinprogramm/scribblings/turtle.scrbl diff --git a/collects/teachpack/deinprogramm/scribblings/world.scrbl b/collects/deinprogramm/scribblings/world.scrbl similarity index 100% rename from collects/teachpack/deinprogramm/scribblings/world.scrbl rename to collects/deinprogramm/scribblings/world.scrbl diff --git a/collects/teachpack/deinprogramm/scribblings/deinprogramm.scrbl b/collects/teachpack/deinprogramm/scribblings/deinprogramm.scrbl deleted file mode 100644 index ff415fcf71..0000000000 --- a/collects/teachpack/deinprogramm/scribblings/deinprogramm.scrbl +++ /dev/null @@ -1,18 +0,0 @@ -#lang scribble/doc - -@(require scribble/manual - (for-label scheme)) - -@title[#:style '(toc) #:tag "deinprogramm"]{DeinProgramm-Teachpacks} - -Note: This is documentation for the teachpacks that go with the German -textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht -der Abstraktion}}. - -@table-of-contents[] - -@include-section["image.scrbl"] -@include-section["world.scrbl"] -@include-section["turtle.scrbl"] -@include-section["sound.scrbl"] -@include-section["line3d.scrbl"] diff --git a/collects/teachpack/deinprogramm/scribblings/info.ss b/collects/teachpack/deinprogramm/scribblings/info.ss deleted file mode 100644 index 3bae7dc50b..0000000000 --- a/collects/teachpack/deinprogramm/scribblings/info.ss +++ /dev/null @@ -1,3 +0,0 @@ -#lang setup/infotab - -(define scribblings '(("deinprogramm.scrbl" (multi-page) (library -10)))) From fe141d30ba27d7732f8557e682a1e89f56d440a3 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sat, 14 Mar 2009 15:39:47 +0000 Subject: [PATCH 022/140] fixed plural in error message svn: r14099 --- collects/parser-tools/private-yacc/table.ss | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/collects/parser-tools/private-yacc/table.ss b/collects/parser-tools/private-yacc/table.ss index 9493b65ba3..9f9e9e228c 100644 --- a/collects/parser-tools/private-yacc/table.ss +++ b/collects/parser-tools/private-yacc/table.ss @@ -129,9 +129,13 @@ (newline port))) (when (> SR-conflicts 0) - (fprintf port "~a shift/reduce conflicts~n" SR-conflicts)) + (fprintf port "~a shift/reduce conflict~a~n" + SR-conflicts + (if (= SR-conflicts 1) "" "s"))) (when (> RR-conflicts 0) - (fprintf port "~a reduce/reduce conflicts~n" RR-conflicts)))) + (fprintf port "~a reduce/reduce conflict~a~n" + RR-conflicts + (if (= RR-conflicts 1) "" "s"))))) ;; resolve-conflict : (listof action?) -> action? bool bool (define (resolve-conflict actions) @@ -176,12 +180,14 @@ (unless suppress (when (> SR-conflicts 0) (fprintf (current-error-port) - "~a shift/reduce conflicts~n" - SR-conflicts)) + "~a shift/reduce conflict~a~n" + SR-conflicts + (if (= SR-conflicts 1) "" "s"))) (when (> RR-conflicts 0) (fprintf (current-error-port) - "~a reduce/reduce conflicts~n" - RR-conflicts))) + "~a reduce/reduce conflict~a~n" + RR-conflicts + (if (= RR-conflicts 1) "" "s")))) table)) From 838b3dff2a4a339a46709f252f8c8b1a300679c1 Mon Sep 17 00:00:00 2001 From: Jon Rafkind Date: Sat, 14 Mar 2009 23:59:09 +0000 Subject: [PATCH 023/140] link to file-position from the 'update flag svn: r14102 --- collects/scribblings/reference/file-ports.scrbl | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/reference/file-ports.scrbl b/collects/scribblings/reference/file-ports.scrbl index f5261aba5e..037c6f285e 100644 --- a/collects/scribblings/reference/file-ports.scrbl +++ b/collects/scribblings/reference/file-ports.scrbl @@ -111,7 +111,8 @@ files that already exist: @item{@indexed-scheme['update] --- open an existing file without truncating it; if the file does not exist, the - @exnraise[exn:fail:filesystem].} + @exnraise[exn:fail:filesystem]. Use @scheme[file-position] + to change the current read/write position.} @item{@indexed-scheme['can-update] --- open an existing file without truncating it, or create the file if it does not exist.} From eb62b52d3af646a32eb842087c91743bdb815f94 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 15 Mar 2009 01:06:57 +0000 Subject: [PATCH 024/140] reformat using #lang svn: r14103 --- collects/scribblings/scribble/utils.ss | 204 +++++++++++-------------- 1 file changed, 93 insertions(+), 111 deletions(-) diff --git a/collects/scribblings/scribble/utils.ss b/collects/scribblings/scribble/utils.ss index a1f581a00c..18e0908835 100644 --- a/collects/scribblings/scribble/utils.ss +++ b/collects/scribblings/scribble/utils.ss @@ -1,120 +1,102 @@ +#lang scheme/base -(module utils scheme/base - (require scribble/struct - scribble/manual - (prefix-in scheme: scribble/scheme) - (prefix-in scribble: scribble/reader)) +(require scribble/struct + scribble/manual + (prefix-in scheme: scribble/scheme) + (prefix-in scribble: scribble/reader)) - (define-syntax bounce-for-label - (syntax-rules (all-except) - [(_ (all-except mod (id ...) (id2 ...))) - (begin - (require (for-label (except-in mod id ...))) - (provide (for-label (except-out (all-from-out mod) id2 ...))))] - [(_ mod) (begin - (require (for-label mod)) - (provide (for-label (all-from-out mod))))] - [(_ mod ...) (begin (bounce-for-label mod) ...)])) +(define-syntax bounce-for-label + (syntax-rules (all-except) + [(_ (all-except mod (id ...) (id2 ...))) + (begin (require (for-label (except-in mod id ...))) + (provide (for-label (except-out (all-from-out mod) id2 ...))))] + [(_ mod) (begin (require (for-label mod)) + (provide (for-label (all-from-out mod))))] + [(_ mod ...) (begin (bounce-for-label mod) ...)])) - (bounce-for-label (all-except scheme (link) ()) - scribble/struct - scribble/base-render - scribble/decode - scribble/manual - scribble/scheme - scribble/eval - scribble/bnf) +(bounce-for-label (all-except scheme (link) ()) + scribble/struct + scribble/base-render + scribble/decode + scribble/manual + scribble/scheme + scribble/eval + scribble/bnf) - (provide scribble-examples litchar/lines) +(provide scribble-examples litchar/lines) - (define (litchar/lines . strs) - (let ([strs (regexp-split #rx"\n" (apply string-append strs))]) - (if (= 1 (length strs)) - (litchar (car strs)) - (make-table - #f - (map (lambda (s) - (list (make-flow (list (make-paragraph - (if (string=? s "") - '(nbsp) ; needed for IE - (list (litchar s)))))))) - strs))))) +(define (litchar/lines . strs) + (let ([strs (regexp-split #rx"\n" (apply string-append strs))]) + (if (= 1 (length strs)) + (litchar (car strs)) + (make-table + #f + (map (lambda (s) + (let ([line (if (string=? s "") + '(nbsp) ; needed for IE + (list (litchar s)))]) + (list (make-flow (list (make-paragraph line)))))) + strs))))) - (define (as-flow e) - (make-flow (list (if (block? e) - e - (make-paragraph (list e)))))) +(define (as-flow e) + (make-flow (list (if (block? e) e (make-paragraph (list e)))))) - (define spacer (hspace 2)) +(define spacer (hspace 2)) - (define ((norm-spacing base) p) - (cond - [(and (syntax->list p) - (not (null? (syntax-e p)))) - (let loop ([e (syntax->list p)] - [line (syntax-line (car (syntax-e p)))] - [pos base] - [second #f] - [accum null]) - (cond - [(null? e) - (datum->syntax - p - (reverse accum) - (list (syntax-source p) - (syntax-line p) - base - (add1 base) - (- pos base)) - p)] - [else - (let* ([v ((norm-spacing (if (= line (syntax-line (car e))) - pos - (or second pos))) - (car e))] - [next-pos (+ (syntax-column v) (syntax-span v) 1)]) - (loop (cdr e) - (syntax-line v) - next-pos - (or second next-pos) - (cons v accum)))]))] - [else - (datum->syntax - p - (syntax-e p) - (list (syntax-source p) - (syntax-line p) - base - (add1 base) - 1) - p)])) +(define ((norm-spacing base) p) + (cond [(and (syntax->list p) (not (null? (syntax-e p)))) + (let loop ([e (syntax->list p)] + [line (syntax-line (car (syntax-e p)))] + [pos base] + [second #f] + [accum null]) + (if (null? e) + (datum->syntax + p (reverse accum) + (list (syntax-source p) (syntax-line p) base (add1 base) + (- pos base)) + p) + (let* ([v ((norm-spacing (if (= line (syntax-line (car e))) + pos + (or second pos))) + (car e))] + [next-pos (+ (syntax-column v) (syntax-span v) 1)]) + (loop (cdr e) + (syntax-line v) + next-pos + (or second next-pos) + (cons v accum)))))] + [else (datum->syntax + p (syntax-e p) + (list (syntax-source p) (syntax-line p) base (add1 base) 1) + p)])) - (define (scribble-examples . lines) - (define reads-as (make-paragraph (list spacer "reads as" spacer))) - (let* ([lines (apply string-append lines)] - [p (open-input-string lines)]) - (port-count-lines! p) - (let loop ([r '()] [newlines? #f]) - (regexp-match? #px#"^[[:space:]]*" p) - (let* ([p1 (file-position p)] - [stx (scribble:read-syntax #f p)] - [p2 (file-position p)]) - (if (not (eof-object? stx)) - (let ([str (substring lines p1 p2)]) - (loop (cons (list str stx) r) - (or newlines? (regexp-match? #rx#"\n" str)))) - (let* ([r (reverse r)] - [r (if newlines? - (cdr (apply append (map (lambda (x) (list #f x)) r))) - r)]) - (make-table - #f - (map (lambda (x) - (let ([@expr (if x (litchar/lines (car x)) "")] - [sexpr (if x - (scheme:to-paragraph - ((norm-spacing 0) (cadr x))) - "")] - [reads-as (if x reads-as "")]) - (map as-flow (list spacer @expr reads-as sexpr)))) - r))))))))) +(define (scribble-examples . lines) + (define reads-as (make-paragraph (list spacer "reads as" spacer))) + (let* ([lines (apply string-append lines)] + [p (open-input-string lines)]) + (port-count-lines! p) + (let loop ([r '()] [newlines? #f]) + (regexp-match? #px#"^[[:space:]]*" p) + (let* ([p1 (file-position p)] + [stx (scribble:read-syntax #f p)] + [p2 (file-position p)]) + (if (not (eof-object? stx)) + (let ([str (substring lines p1 p2)]) + (loop (cons (list str stx) r) + (or newlines? (regexp-match? #rx#"\n" str)))) + (let* ([r (reverse r)] + [r (if newlines? + (cdr (apply append (map (lambda (x) (list #f x)) r))) + r)]) + (make-table + #f + (map (lambda (x) + (let ([@expr (if x (litchar/lines (car x)) "")] + [sexpr (if x + (scheme:to-paragraph + ((norm-spacing 0) (cadr x))) + "")] + [reads-as (if x reads-as "")]) + (map as-flow (list spacer @expr reads-as sexpr)))) + r)))))))) From cd233f856e8aba843956cc6180457dd4e96f840e Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 15 Mar 2009 07:41:04 +0000 Subject: [PATCH 025/140] functionality for packaging tests and documentation for the preprocessor language svn: r14104 --- collects/scribblings/scribble/utils.ss | 110 +++++++++++++++++++++++-- 1 file changed, 102 insertions(+), 8 deletions(-) diff --git a/collects/scribblings/scribble/utils.ss b/collects/scribblings/scribble/utils.ss index 18e0908835..0c5b843717 100644 --- a/collects/scribblings/scribble/utils.ss +++ b/collects/scribblings/scribble/utils.ss @@ -25,22 +25,19 @@ (provide scribble-examples litchar/lines) +(define (as-flow e) + (make-flow (list (if (block? e) e (make-paragraph (list e)))))) + (define (litchar/lines . strs) (let ([strs (regexp-split #rx"\n" (apply string-append strs))]) (if (= 1 (length strs)) (litchar (car strs)) (make-table #f - (map (lambda (s) - (let ([line (if (string=? s "") - '(nbsp) ; needed for IE - (list (litchar s)))]) - (list (make-flow (list (make-paragraph line)))))) + (map (lambda (s) ; the nbsp is needed for IE + (list (as-flow (if (string=? s "") 'nbsp (litchar s))))) strs))))) -(define (as-flow e) - (make-flow (list (if (block? e) e (make-paragraph (list e)))))) - (define spacer (hspace 2)) (define ((norm-spacing base) p) @@ -100,3 +97,100 @@ [reads-as (if x reads-as "")]) (map as-flow (list spacer @expr reads-as sexpr)))) r)))))))) + +;; stuff for the preprocessor examples + +(require scheme/list (for-syntax scheme/base scheme/list)) + +(define max-textsample-width 32) + +(define (textsample-verbatim-boxes 1st 2nd more) + (define (split str) (regexp-split #rx"\n" str)) + (define strs1 (split 1st)) + (define strs2 (split 2nd)) + (define strsm (map (compose split cdr) more)) + (define (str->elts str) + (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)]) + (if spaces + (list* (substring str 0 (caar spaces)) + (hspace (- (cdar spaces) (caar spaces))) + (str->elts (substring str (cdar spaces)))) + (list (make-element 'tt (list str)))))) + (define (make-line str) (list (as-flow (make-element 'tt (str->elts str))))) + (define (make-box strs) (make-table 'boxed (map make-line strs))) + (define box1 (make-box strs1)) + (define box2 (make-box strs2)) + (define boxm (map make-box strsm)) + (define filenames (map car more)) + (define indent (let ([d (- max-textsample-width + (for*/fold ([m 0]) + ([s (in-list (cons strs1 strsm))] + [s (in-list s)]) + (max m (string-length s))))]) + (if (negative? d) + (error 'textsample-verbatim-boxes "left box too wide") + (hspace d)))) + (values + (make-table '([alignment right left] [valignment top top]) + (cons (list (as-flow indent) (as-flow box1)) + (map (lambda (file strs) + (let* ([file (make-element 'tt (list file ":" 'nbsp))] + [file (list (make-element 'italic (list file)))]) + (list (as-flow (make-element '(bg-color 232 232 255) file)) + (as-flow (make-box strs))))) + filenames strsm))) + box2)) + +(define (textsample 1st 2nd . more) + (define-values (box1 box2) (textsample-verbatim-boxes 1st 2nd more)) + (make-table '([alignment left left left] [valignment center center center]) + (list (map as-flow (list box1 (make-paragraph '(nbsp rarr nbsp)) box2))))) + +(define-for-syntax tests-ids #f) + +(provide initialize-tests) +(define-syntax (initialize-tests stx) + (set! tests-ids (map (lambda (x) (datum->syntax stx x stx)) + '(tests add-to-tests))) + (with-syntax ([(tests add-to-tests) tests-ids]) + #'(begin (provide tests) + (define-values (tests add-to-tests) + (let ([l '()]) + (values (lambda () (reverse l)) + (lambda (x) (set! l (cons x l))))))))) + +(provide example) +(define-syntax (example stx) + (define sep-rx #px"^---[*]{3}---(?: +(.*))?$") + (define file-rx #rx"^[a-z0-9_.+-]+$") + (syntax-case stx () + [(_ x ...) + (let loop ([xs #'(x ...)] [text '(#f)] [texts '()]) + (syntax-case xs () + [("\n" sep "\n" . xs) + (and (string? (syntax-e #'sep)) + (regexp-match? sep-rx (syntax-e #'sep))) + (let ([m (cond [(regexp-match sep-rx (syntax-e #'sep)) => cadr] + [else #f])]) + (if (and m (not (regexp-match? file-rx m))) + (raise-syntax-error #f "bad filename specified" stx #'sep) + (loop #'xs + (list (and m (datum->syntax #'sep m #'sep #'sep))) + (cons (reverse text) texts))))] + [(x . xs) (loop #'xs (cons #'x text) texts)] + [() (let ([texts (reverse (cons (reverse text) texts))] + [line (syntax-line stx)]) + (define-values (files i/o) (partition car texts)) + (unless ((length i/o) . = . 2) + (raise-syntax-error + 'example "need at least an input and an output block" stx)) + (with-syntax ([line line] + [((i/o ...) ...) (map cdr i/o)] + [((file text ...) ...) files] + [add-to-tests (cadr tests-ids)]) + (syntax/loc stx + (let ([t (list (string-append i/o ...) ... + (cons file (string-append text ...)) ...)]) + (add-to-tests (cons line t)) + (apply textsample t)))))] + [_ (raise-syntax-error #f "no separator found in example text")]))])) From 1aea8aa69f4124c691f3dd86dd33cf711644f828 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 15 Mar 2009 07:50:22 +0000 Subject: [PATCH 026/140] Welcome to a new PLT day. svn: r14105 --- 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 00bdfb0b78..8684e72835 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "14mar2009") +#lang scheme/base (provide stamp) (define stamp "15mar2009") From 56305945899a7e89bd1a380ab12490f57729d5e8 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Sun, 15 Mar 2009 10:49:41 +0000 Subject: [PATCH 027/140] Fold DMdA-lib.scrbl into the other DMdA docs. svn: r14106 --- collects/deinprogramm/scribblings/deinprogramm.scrbl | 8 +++++--- collects/deinprogramm/scribblings/info.ss | 3 +-- 2 files changed, 6 insertions(+), 5 deletions(-) diff --git a/collects/deinprogramm/scribblings/deinprogramm.scrbl b/collects/deinprogramm/scribblings/deinprogramm.scrbl index daddab6653..38ba574949 100644 --- a/collects/deinprogramm/scribblings/deinprogramm.scrbl +++ b/collects/deinprogramm/scribblings/deinprogramm.scrbl @@ -9,9 +9,9 @@ Note: This is documentation for the teachpacks that go with the German textbook @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der Abstraktion}}. -Die Sprachebenen und Teachpacks in diesem Handbuch sind für Verwendung -mit dem Buch the @italic{@link["http://www.deinprogramm.de/dmda/"]{Die -Macht der Abstraktion}} gedacht. +Das Material in diesem Handbuch ist für die Verwendung mit dem Buch +the @italic{@link["http://www.deinprogramm.de/dmda/"]{Die Macht der +Abstraktion}} gedacht. @table-of-contents[] @@ -28,4 +28,6 @@ Macht der Abstraktion}} gedacht. @include-section["sound.scrbl"] @include-section["line3d.scrbl"] +@include-section["DMdA-lib.scrbl"] + @index-section[] diff --git a/collects/deinprogramm/scribblings/info.ss b/collects/deinprogramm/scribblings/info.ss index cb89cb8058..24a48b2bb0 100644 --- a/collects/deinprogramm/scribblings/info.ss +++ b/collects/deinprogramm/scribblings/info.ss @@ -1,5 +1,4 @@ #lang setup/infotab -(define scribblings '(("deinprogramm.scrbl" (multi-page) (language -14)) - ("DMdA-lib.scrbl"))) +(define scribblings '(("deinprogramm.scrbl" (multi-page) (language -14)))) From 073013d8eff555d555bba470733eb0bd21855681 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 15 Mar 2009 13:30:26 +0000 Subject: [PATCH 028/140] change render og var-ids under a quote svn: r14108 --- collects/scribble/scheme.ss | 7 +++++-- collects/scribblings/scribble/scheme.scrbl | 6 ++++-- 2 files changed, 9 insertions(+), 4 deletions(-) diff --git a/collects/scribble/scheme.ss b/collects/scribble/scheme.ss index 281603a8bc..3518e4c548 100644 --- a/collects/scribble/scheme.ss +++ b/collects/scribble/scheme.ss @@ -123,7 +123,8 @@ (make-element style content))) (define (typeset-atom c out color? quote-depth) - (if (var-id? (syntax-e c)) + (if (and (var-id? (syntax-e c)) + (zero? quote-depth)) (out (format "~s" (let ([v (var-id-sym (syntax-e c))]) (if (syntax? v) (syntax-e v) @@ -135,7 +136,9 @@ (let ([sc (syntax-e c)]) (let ([s (format "~s" (if (literal-syntax? sc) (literal-syntax-stx sc) - sc))]) + (if (var-id? sc) + (var-id-sym sc) + sc)))]) (if (and (symbol? sc) ((string-length s) . > . 1) (char=? (string-ref s 0) #\_) diff --git a/collects/scribblings/scribble/scheme.scrbl b/collects/scribblings/scribble/scheme.scrbl index 5c7376738b..9f991404cc 100644 --- a/collects/scribblings/scribble/scheme.scrbl +++ b/collects/scribblings/scribble/scheme.scrbl @@ -90,7 +90,8 @@ typically used to typeset results.} When @scheme[to-paragraph] and variants encounter a @scheme[var-id] structure, it is typeset as @scheme[sym] in the variable font, like -@scheme[schemevarfont].} +@scheme[schemevarfont]---unless the @scheme[var-id] appears under +quote or quasiquote, in which case @scheme[sym] is typeset as a symbol.} @defstruct[shaped-parens ([val any/c] @@ -149,4 +150,5 @@ Provided @scheme[for-syntax]; returns @scheme[#t] if @scheme[v] is an Provided @scheme[for-syntax]; like @scheme[element-id-transformer] for a transformer that produces @scheme[sym] typeset as a variable (like -@scheme[schemevarfont]).} +@scheme[schemevarfont])---unless it appears under quote or quasiquote, +in which case @scheme[sym] is typeset as a symbol.} From 87ab3142a8e9e5bfc8d203586f0801d7b933b654 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 15 Mar 2009 22:04:03 +0000 Subject: [PATCH 029/140] cheap hack to make it possible to provide a custom failure message svn: r14111 --- collects/tests/eli-tester.ss | 52 +++++++++++++++++++++++------------- 1 file changed, 34 insertions(+), 18 deletions(-) diff --git a/collects/tests/eli-tester.ss b/collects/tests/eli-tester.ss index 48ccc17619..f6e2f899a5 100644 --- a/collects/tests/eli-tester.ss +++ b/collects/tests/eli-tester.ss @@ -19,7 +19,8 @@ [(list 'values x) (format "~e" x)] [(list 'values xs ...) (format "~e" (cons 'values xs))])) -(define test-context (make-parameter #f)) +(define test-context (make-parameter #f)) +(define failure-message (make-parameter #f)) (define-syntax (test-thunk stx) (define (blame e fmt . args) @@ -32,7 +33,10 @@ [(syntax-position e) => (lambda (p) (format "#~a" p))] [else "?"]))))) (with-syntax ([e e] [fmt fmt] [(arg ...) args] [loc loc]) - #'(error 'loc "test failure in ~e\n ~a" 'e (format fmt arg ...)))) + #'(let ([msg (failure-message)]) + (if msg + (error 'loc "test failure\n ~a" (msg)) + (error 'loc "test failure in ~e\n ~a" 'e (format fmt arg ...)))))) (define (t1 x) #`(let ([x (safe #,x)]) (unless (and (eq? 'values (car x)) (= 2 (length x)) (cadr x)) @@ -55,23 +59,35 @@ #,(apply t args)))) (define (tb x) x) (let loop ([xs (map (lambda (x) - (if (memq (syntax-e x) '(do => <= =error> <= =error> list stx)))] [r '()]) - (let ([t (match xs - [(list* 'do x r) (cons (tb x) r)] - [(list* x '=> y r) (cons (try t2 x y) r)] - [(list* y '<= x r) (cons (try t2 x y) r)] - [(list* x '=error> y r) (cons (try te x y) r)] - [(list* y ' y r) (cons (try t2 x y) r)] + [(list* y '<= x r) (cons (try t2 x y) r)] + [(list* x '=error> y r) (cons (try te x y) r)] + [(list* y ' Date: Sun, 15 Mar 2009 22:05:52 +0000 Subject: [PATCH 030/140] Start a proper preprocessor documentation, with tests included. (proper "literate testing".) svn: r14112 --- .../scribblings/scribble/preprocessor.scrbl | 119 ++++++++++++++---- collects/scribblings/scribble/utils.ss | 15 +-- collects/tests/scribble/main.ss | 17 ++- 3 files changed, 118 insertions(+), 33 deletions(-) diff --git a/collects/scribblings/scribble/preprocessor.scrbl b/collects/scribblings/scribble/preprocessor.scrbl index c393f0b13d..e502ddc86c 100644 --- a/collects/scribblings/scribble/preprocessor.scrbl +++ b/collects/scribblings/scribble/preprocessor.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc -@(require scribble/manual - "utils.ss" +@(require scribble/manual scribble/struct "utils.ss" (for-label scheme/base)) +@initialize-tests @title[#:tag "preprocessor"]{Text Preprocessor} @@ -12,35 +12,106 @@ changes that make it suitable as a preprocessor language: @itemize{ @item{It uses @scheme[read-syntax-inside] to read the body of the - module, similar to @secref["docreader"].} + module, similar to @secref["docreader"]. This means that by + default, all text is read in as Scheme strings; and + @seclink["reader"]|{@-forms}| can be used to use Scheme + functions and expression escapes.} - @item{It has a custom printer (@scheme[current-print]) that displays - all values. The printer is also installed as the - @scheme[port-display-handler] so it can be used through - @scheme[display] as well as @litchar{~a} in format strings. - The printer displays most values (as is usual for - @scheme[display]), except for - @itemize{@item{@scheme[void] and @scheme[#f] are not - displayed,} - @item{pairs are displayed recursively (just their - contents, no parentheses),} - @item{promises are forced, thunks are invoked.}}}} + @item{Values of expressions are printed with a custom + @scheme[output] function. This function displays most values + in a similar way to @scheme[display], except that it is more + convenient for a preprocessor output.}} } -This means that to write a text file that has scheme code, you simply -write it as a module in the @scheme[scribble/text] language, and run -it through @exec{mzscheme}. Here is a sample file: +@;-------------------------------------------------------------------- +@section{Writing Preprocessor Files} -@verbatim[#:indent 2]|{ - #lang scribble/text - @(define (angled . body) (list "<" body ">"))@; - @(define (shout . body) @angled[(map string-upcase body)])@; - blah @angled{blah @shout{blah} blah} blah -}| +The combination of the two features makes text in files in the +@scheme[scribble/text] language be read as strings, which get printed +out when the module is @scheme[require]d, for example, when a file is +given as an argument to @exec{mzscheme}. (In these example the left +part shows the source input, and the right part the printed result.) -(Note how @litchar["@;"] is used to avoid empty lines in the output.) +@example|-{#lang scribble/text + Programming languages should + be designed not by piling + feature on top of feature, but + blah blah blah. + ---***--- + Programming languages should + be designed not by piling + feature on top of feature, but + blah blah blah.}-| +Using @seclink["reader"]|{@-forms}| we can define and use Scheme +functions. + +@example|-{#lang scribble/text + @(require scheme/list) + @(define Foo "Preprocessing") + @(define (3x . x) + (add-between (list x x x) " ")) + @Foo languages should + be designed not by piling + feature on top of feature, but + @3x{blah}. + ---***--- + Preprocessing languages should + be designed not by piling + feature on top of feature, but + blah blah blah.}-| + +As demonstrated in this case, the @scheme[output] function simply +scans nested list structures recursively, which makes them convenient +for function results. In addition, @scheme[output] prints most values +similarly to @scheme[display] \- a notable exception are void and +false values which cause no output to appear. This can be used for +convenient conditional output. + +@example|-{#lang scribble/text + @(define (errors n) + (list n + " error" + (and (not (= n 1)) "s"))) + You have @errors[3] in your code, + I fixed @errors[1]. + ---***--- + You have 3 errors in your code, + I fixed 1 error.}-| + +Using the scribble @seclink["reader"]|{@-forms}| syntax, you can write +functions more conveniently too. + +@example|-{#lang scribble/text + @(define (errors n) + @list{@n error@; + @and[(not (= n 1))]{s}}) + You have @errors[3] in your code, + I fixed @errors[1]. + ---***--- + You have 3 errors in your code, + I fixed 1 error.}-| + +Following the details of the scribble reader, you may notice that in +these examples there are newline strings after each definition, yet +they do not show in the output. To make it easier to write +definitions, newlines after definitions and indentation spaces before +them are ignored. + +@example|-{#lang scribble/text + + @(define (plural n) + (unless (= n 1) "s")) + + @(define (errors n) + @list{@n error@plural[n]}) + + You have @errors[3] in your code, + I fixed @errors[1]. + ---***--- + You have 3 errors in your code, + I fixed 1 error.}-| @;-------------------------------------------------------------------- @section{Using External Files} diff --git a/collects/scribblings/scribble/utils.ss b/collects/scribblings/scribble/utils.ss index 0c5b843717..d70962b29b 100644 --- a/collects/scribblings/scribble/utils.ss +++ b/collects/scribblings/scribble/utils.ss @@ -102,9 +102,9 @@ (require scheme/list (for-syntax scheme/base scheme/list)) -(define max-textsample-width 32) +(define max-textsample-width 35) -(define (textsample-verbatim-boxes 1st 2nd more) +(define (textsample-verbatim-boxes line 1st 2nd more) (define (split str) (regexp-split #rx"\n" str)) (define strs1 (split 1st)) (define strs2 (split 2nd)) @@ -128,7 +128,8 @@ [s (in-list s)]) (max m (string-length s))))]) (if (negative? d) - (error 'textsample-verbatim-boxes "left box too wide") + (error 'textsample-verbatim-boxes + "left box too wide for sample at line ~s" line) (hspace d)))) (values (make-table '([alignment right left] [valignment top top]) @@ -141,8 +142,8 @@ filenames strsm))) box2)) -(define (textsample 1st 2nd . more) - (define-values (box1 box2) (textsample-verbatim-boxes 1st 2nd more)) +(define (textsample line 1st 2nd . more) + (define-values (box1 box2) (textsample-verbatim-boxes line 1st 2nd more)) (make-table '([alignment left left left] [valignment center center center]) (list (map as-flow (list box1 (make-paragraph '(nbsp rarr nbsp)) box2))))) @@ -189,8 +190,8 @@ [((file text ...) ...) files] [add-to-tests (cadr tests-ids)]) (syntax/loc stx - (let ([t (list (string-append i/o ...) ... + (let ([t (list line (string-append i/o ...) ... (cons file (string-append text ...)) ...)]) - (add-to-tests (cons line t)) + (add-to-tests t) (apply textsample t)))))] [_ (raise-syntax-error #f "no separator found in example text")]))])) diff --git a/collects/tests/scribble/main.ss b/collects/tests/scribble/main.ss index b95d0d3dc7..b14650880b 100644 --- a/collects/tests/scribble/main.ss +++ b/collects/tests/scribble/main.ss @@ -1,8 +1,10 @@ #lang scheme/base -(require tests/eli-tester scribble/text/syntax-utils scheme/runtime-path) +(require tests/eli-tester scribble/text/syntax-utils scheme/runtime-path + scheme/sandbox (lib "scribblings/scribble/preprocessor.scrbl")) (define-runtime-path text-dir "text") +(define-runtime-path this-dir ".") (test @@ -78,7 +80,7 @@ (f 3 #:> "]" #:< "[")) => '(1 ("<" 1 ">") ("[" 2 ">") ("[" 3 "]")) - ;; preprocessor functionality + ;; preprocessor tests (parameterize ([current-directory text-dir]) (for ([ifile (map path->string (directory-list))] #:when (and (file-exists? ifile) @@ -90,5 +92,16 @@ (parameterize ([current-output-port o]) (dynamic-require (path->complete-path ifile) #f)) (test (get-output-bytes o) => expected))) + ;; preprocessor tests that are part of the documentation + (parameterize ([current-directory this-dir] + [sandbox-output 'string] + [sandbox-error-output current-output-port]) + (define (text-test line in out . more) + (define e (make-module-evaluator in)) + (test + #:failure-message (format "preprocessor test failure at line ~s" line) + (equal? (get-output e) out))) + (call-with-trusted-sandbox-configuration + (lambda () (for ([t (in-list (tests))]) (apply text-test t))))) ) From ed566b2f7db55febc321da81c5773d755ad4c221 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 15 Mar 2009 22:58:21 +0000 Subject: [PATCH 031/140] moved to scheme/base language and has it overwrite the output file, if it exists svn: r14113 --- collects/parser-tools/private-yacc/table.ss | 39 ++++++++++----------- 1 file changed, 19 insertions(+), 20 deletions(-) diff --git a/collects/parser-tools/private-yacc/table.ss b/collects/parser-tools/private-yacc/table.ss index 9f9e9e228c..bd5107b9b1 100644 --- a/collects/parser-tools/private-yacc/table.ss +++ b/collects/parser-tools/private-yacc/table.ss @@ -1,4 +1,4 @@ -(module table mzscheme +#lang scheme/base ;; Routine to build the LALR table @@ -31,14 +31,14 @@ (list->vector (map (lambda (state-entry) - (let ((ht (make-hash-table 'equal))) + (let ((ht (make-hash))) (for-each (lambda (gs/actions) - (let ((group (hash-table-get ht (car gs/actions) (lambda () null)))) + (let ((group (hash-ref ht (car gs/actions) (lambda () null)))) (unless (member (cdr gs/actions) group) - (hash-table-put! ht (car gs/actions) (cons (cdr gs/actions) group))))) + (hash-set! ht (car gs/actions) (cons (cdr gs/actions) group))))) state-entry) - (hash-table-map ht cons))) + (hash-map ht cons))) (vector->list table)))) ;; table-map : (vectorof (listof (cons/c gram-sym? X))) (gram-sym? X -> Y) -> @@ -119,10 +119,10 @@ (print-entry sym (car act) port)) (else (fprintf port "begin conflict:~n") - (if (> (count reduce? act) 1) - (set! RR-conflicts (add1 RR-conflicts))) - (if (> (count shift? act) 0) - (set! SR-conflicts (add1 SR-conflicts))) + (when (> (count reduce? act) 1) + (set! RR-conflicts (add1 RR-conflicts))) + (when (> (count shift? act) 0) + (set! SR-conflicts (add1 SR-conflicts))) (map (lambda (x) (print-entry sym x port)) act) (fprintf port "end conflict~n"))))) (vector-ref grouped-table (kernel-index state))) @@ -236,7 +236,7 @@ (end-terms (send g get-end-terms)) (table (make-parse-table (send a get-num-states))) (get-lookahead (compute-LA a g)) - (reduce-cache (make-hash-table 'equal))) + (reduce-cache (make-hash))) (for-each (lambda (trans-key/state) @@ -262,17 +262,17 @@ (bit-vector-for-each (lambda (term-index) (unless (start-item? item) - (let ((r (hash-table-get reduce-cache item-prod + (let ((r (hash-ref reduce-cache item-prod (lambda () (let ((r (make-reduce item-prod))) - (hash-table-put! reduce-cache item-prod r) + (hash-set! reduce-cache item-prod r) r))))) (table-add! table (kernel-index state) (vector-ref term-vector term-index) r)))) (get-lookahead state item-prod)))) - (append (hash-table-get (send a get-epsilon-trans) state (lambda () null)) + (append (hash-ref (send a get-epsilon-trans) state (lambda () null)) (filter (lambda (item) (not (move-dot-right item))) (kernel-items state)))))) @@ -283,13 +283,12 @@ (lambda (e) (fprintf (current-error-port) - "Cannot write debug output to file \"~a\".~n" - file)))] + "Cannot write debug output to file \"~a\": ~a\n" + file + (exn-message e))))] (call-with-output-file file (lambda (port) - (display-parser a grouped-table (send g get-prods) port))))) + (display-parser a grouped-table (send g get-prods) port)) + #:exists 'truncate))) (resolve-conflicts grouped-table suppress)))) - - ) - - + \ No newline at end of file From cf791ead47f2b107410406d9c01ea31f7b340e10 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Sun, 15 Mar 2009 23:01:54 +0000 Subject: [PATCH 032/140] moved to scheme/base language and has it overwrite the output file, if it exists svn: r14114 --- collects/parser-tools/yacc.ss | 47 ++++++++++++++++++----------------- 1 file changed, 24 insertions(+), 23 deletions(-) diff --git a/collects/parser-tools/yacc.ss b/collects/parser-tools/yacc.ss index 0c16284c05..296e027aa6 100644 --- a/collects/parser-tools/yacc.ss +++ b/collects/parser-tools/yacc.ss @@ -1,9 +1,10 @@ -(module yacc mzscheme - - (require-for-syntax "private-yacc/parser-builder.ss" - "private-yacc/grammar.ss" - "private-yacc/yacc-helper.ss" - "private-yacc/parser-actions.ss") +#lang scheme/base + +(require (for-syntax scheme/base + "private-yacc/parser-builder.ss" + "private-yacc/grammar.ss" + "private-yacc/yacc-helper.ss" + "private-yacc/parser-actions.ss")) (require "private-lex/token.ss" "private-yacc/parser-actions.ss" mzlib/etc @@ -19,12 +20,12 @@ (list->vector (map (lambda (state-entry) - (let ((ht (make-hash-table))) + (let ((ht (make-hasheq))) (for-each (lambda (gs/action) - (hash-table-put! ht - (gram-sym-symbol (car gs/action)) - (action->runtime-action (cdr gs/action)))) + (hash-set! ht + (gram-sym-symbol (car gs/action)) + (action->runtime-action (cdr gs/action)))) state-entry) ht)) (vector->list table)))) @@ -177,13 +178,14 @@ yacc-output)))] (call-with-output-file yacc-output (lambda (port) - (display-yacc (syntax-object->datum grammar) + (display-yacc (syntax->datum grammar) tokens - (map syntax-object->datum start) + (map syntax->datum start) (if precs - (syntax-object->datum precs) + (syntax->datum precs) #f) - port))))) + port)) + #:exists 'truncate))) (with-syntax ((check-syntax-fix check-syntax-fix) (err error) (ends end) @@ -245,7 +247,7 @@ (define (extract-no-src-pos ip) (extract-helper ip #f #f)) - (define-struct stack-frame (state value start-pos end-pos) (make-inspector)) + (define-struct stack-frame (state value start-pos end-pos) #:inspector (make-inspector)) (define (make-empty-stack i) (list (make-stack-frame i #f #f #f))) @@ -304,17 +306,17 @@ (remove-states))))))))) (define (find-action stack tok val start-pos end-pos) - (unless (hash-table-get all-term-syms - tok - (lambda () #f)) + (unless (hash-ref all-term-syms + tok + #f) (if src-pos (err #f tok val start-pos end-pos) (err #f tok val)) (raise-read-error (format "parser: got token of unknown type ~a" tok) #f #f #f #f #f)) - (hash-table-get (vector-ref table (stack-frame-state (car stack))) - tok - (lambda () #f))) + (hash-ref (vector-ref table (stack-frame-state (car stack))) + tok + #f)) (define (make-parser start-number) (lambda (get-token) @@ -341,7 +343,7 @@ src-pos))) (let ((goto (runtime-goto-state - (hash-table-get + (hash-ref (vector-ref table (stack-frame-state (car new-stack))) (runtime-reduce-lhs action))))) (parsing-loop @@ -378,4 +380,3 @@ (cond ((null? l) null) (else (cons (make-parser i) (loop (cdr l) (add1 i)))))))))) - ) From a75a83add2fec494fb31245aab99a99dc1de687d Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 16 Mar 2009 01:28:19 +0000 Subject: [PATCH 033/140] update version numbers for the v4.1.5 release svn: r14116 --- src/mzscheme/src/schvers.h | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index baece58a99..d12e51749b 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.4.3" +#define MZSCHEME_VERSION "4.1.5.1" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 -#define MZSCHEME_VERSION_Z 4 -#define MZSCHEME_VERSION_W 3 +#define MZSCHEME_VERSION_Z 5 +#define MZSCHEME_VERSION_W 1 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) From ff9ebbde05dbf1750985d918f789b493bfe4cf44 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 16 Mar 2009 04:40:30 +0000 Subject: [PATCH 034/140] fix PR 9398: debugger and macro stepper buttons get out of sync wrt tabs move enable/disable-evaluation extensions from tab mixin to unit-frame mixin svn: r14118 --- collects/gui-debugger/debug-tool.ss | 16 ++++++++-------- collects/macro-debugger/tool.ss | 23 +++++++---------------- 2 files changed, 15 insertions(+), 24 deletions(-) diff --git a/collects/gui-debugger/debug-tool.ss b/collects/gui-debugger/debug-tool.ss index 3efc59a2b9..de7e2978b1 100644 --- a/collects/gui-debugger/debug-tool.ss +++ b/collects/gui-debugger/debug-tool.ss @@ -1006,14 +1006,6 @@ (define/public (hide-debug) (send (get-frame) hide-debug)) - (define/override (enable-evaluation) - (send (send (get-frame) get-debug-button) enable #t) - (super enable-evaluation)) - - (define/override (disable-evaluation) - (send (send (get-frame) get-debug-button) enable #f) - (super disable-evaluation)) - (super-new))) (define debug-bitmap @@ -1285,6 +1277,14 @@ (inherit register-toolbar-button) (register-toolbar-button debug-button) + (define/augment (enable-evaluation) + (send debug-button enable #t) + (inner (void) enable-evaluation)) + + (define/augment (disable-evaluation) + (send debug-button enable #f) + (inner (void) disable-evaluation)) + (define pause-button (instantiate button% () [label (make-pause-label this)] diff --git a/collects/macro-debugger/tool.ss b/collects/macro-debugger/tool.ss index af578c1620..1d1430aae2 100644 --- a/collects/macro-debugger/tool.ss +++ b/collects/macro-debugger/tool.ss @@ -79,7 +79,6 @@ (define drscheme-eventspace (current-eventspace)) (define-local-member-name check-language) - (define-local-member-name get-debug-button) (define macro-debugger-bitmap (make-object bitmap% @@ -113,6 +112,13 @@ (inherit register-toolbar-button) (register-toolbar-button macro-debug-button) + (define/augment (enable-evaluation) + (send macro-debug-button enable #t) + (inner (void) enable-evaluation)) + (define/augment (disable-evaluation) + (send macro-debug-button enable #f) + (inner (void) disable-evaluation)) + (define/override (execute-callback) (execute #f)) @@ -120,8 +126,6 @@ (send (get-interactions-text) enable-macro-debugging debugging?) (super execute-callback)) - (define/public (get-debug-button) macro-debug-button) - ;; Hide button for inappropriate languages (define/augment (on-tab-change old new) @@ -157,17 +161,6 @@ (inner (void) after-set-next-settings s)) (super-new))) - (define (macro-debugger-tab-mixin %) - (class % - (inherit get-frame) - (define/override (enable-evaluation) - (super enable-evaluation) - (send (send (get-frame) get-debug-button) enable #t)) - (define/override (disable-evaluation) - (super disable-evaluation) - (send (send (get-frame) get-debug-button) enable #f)) - (super-new))) - (define (macro-debugger-interactions-text-mixin %) (class % (super-new) @@ -268,7 +261,5 @@ macro-debugger-interactions-text-mixin) (drscheme:get/extend:extend-definitions-text macro-debugger-definitions-text-mixin) - (drscheme:get/extend:extend-tab - macro-debugger-tab-mixin) )) From cf87504e001c3550c5e3d6cc743af5bdf3d49f88 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Mon, 16 Mar 2009 06:25:31 +0000 Subject: [PATCH 035/140] Fixed startup errors caused by tool dependencies (see PR 10125) removed htdp-lang dependency on debugger removed deinprogramm dependency on stepper, debugger, and htdp-langs both still depend on test-engine tool, but only for execution Probably apply to release branch, but needs review. svn: r14119 --- collects/deinprogramm/deinprogramm-langs.ss | 61 +++++++++++++++------ collects/lang/htdp-langs.ss | 4 +- 2 files changed, 48 insertions(+), 17 deletions(-) diff --git a/collects/deinprogramm/deinprogramm-langs.ss b/collects/deinprogramm/deinprogramm-langs.ss index 4148e3a426..4bb68a456a 100644 --- a/collects/deinprogramm/deinprogramm-langs.ss +++ b/collects/deinprogramm/deinprogramm-langs.ss @@ -177,6 +177,7 @@ (run-in-user-thread (lambda () (read-accept-quasiquote (get-accept-quasiquote?)) + (ensure-drscheme-secrets-declared drs-namespace) (namespace-attach-module drs-namespace ''drscheme-secrets) (namespace-attach-module drs-namespace deinprogramm-struct-module-name) (error-display-handler teaching-languages-error-display-handler) @@ -244,6 +245,27 @@ (super-new))) + ;; this inspector should be powerful enough to see + ;; any structure defined in the user's namespace + (define drscheme-inspector (current-inspector)) + + ;; FIXME: brittle, mimics drscheme-secrets + ;; as declared in lang/htdp-langs.ss. + ;; Is it even needed for DeinProgramm langs? + ;; Only used by htdp/hangman teachpack. + (define (ensure-drscheme-secrets-declared drs-namespace) + (parameterize ((current-namespace drs-namespace)) + (define (declare) + (eval `(,#'module drscheme-secrets mzscheme + (provide drscheme-inspector) + (define drscheme-inspector ,drscheme-inspector))) + (namespace-require ''drscheme-secrets)) + (with-handlers ([exn:fail? (lambda (e) (declare))]) + ;; May have been declared by lang/htdp-langs tool, if loaded + (dynamic-require ''drscheme-secrets 'drscheme-inspector)) + (void))) + + ;; { ;; all this copied from collects/drscheme/private/language.ss @@ -1051,24 +1073,31 @@ answer) (define (stepper-settings-language %) - (class* % (stepper-language<%>) - (init-field stepper:supported) - (define/override (stepper:supported?) stepper:supported) - (define/override (stepper:render-to-sexp val settings language-level) - (parameterize ([pc:current-print-convert-hook (make-print-convert-hook settings)]) - (set-print-settings - language-level - settings - (lambda () - (stepper-convert-value val settings))))) - - (super-new))) + (if (implementation? % stepper-language<%>) + (class* % (stepper-language<%>) + (init-field stepper:supported) + (define/override (stepper:supported?) stepper:supported) + (define/override (stepper:render-to-sexp val settings language-level) + (parameterize ([pc:current-print-convert-hook (make-print-convert-hook settings)]) + (set-print-settings + language-level + settings + (lambda () + (stepper-convert-value val settings))))) + (super-new)) + (class % + (init stepper:supported) + (super-new)))) (define (debugger-settings-language %) - (class* % (debugger-language<%>) - (init-field [debugger:supported #f]) - (define/override (debugger:supported?) debugger:supported) - (super-new))) + (if (implementation? % debugger-language<%>) + (class* % (debugger-language<%>) + (init-field [debugger:supported #f]) + (define/override (debugger:supported?) debugger:supported) + (super-new)) + (class % + (init [debugger:supported #f]) + (super-new)))) ;; make-print-convert-hook: ;; simple-settings -> (TST (TST -> TST) (TST -> TST) -> TST) diff --git a/collects/lang/htdp-langs.ss b/collects/lang/htdp-langs.ss index 37fbadc1af..65ffafd3f9 100644 --- a/collects/lang/htdp-langs.ss +++ b/collects/lang/htdp-langs.ss @@ -864,7 +864,9 @@ (init-field [debugger:supported #f]) (define/override (debugger:supported?) debugger:supported) (super-new)) - %)) + (class % + (init [debugger:supported #f]) + (super-new)))) ;; filter/hide-ids : syntax[list] -> listof syntax (define (filter/hide-ids ids) From 87fcebba646145beb7918e6f33d9c9249387bf62 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 16 Mar 2009 07:50:44 +0000 Subject: [PATCH 036/140] Welcome to a new PLT day. svn: r14120 --- collects/repos-time-stamp/stamp.ss | 2 +- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 8684e72835..a5cd42cabf 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "15mar2009") +#lang scheme/base (provide stamp) (define stamp "16mar2009") diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 06a169c986..07638206ba 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Mon, 16 Mar 2009 11:44:09 +0000 Subject: [PATCH 037/140] added docs for the latex keybindings svn: r14121 --- .../scribblings/drscheme/keybindings.scrbl | 26 ++++++++++++++++++- 1 file changed, 25 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/drscheme/keybindings.scrbl b/collects/scribblings/drscheme/keybindings.scrbl index 21bdee0c6a..42b6238335 100644 --- a/collects/scribblings/drscheme/keybindings.scrbl +++ b/collects/scribblings/drscheme/keybindings.scrbl @@ -1,10 +1,15 @@ #lang scribble/doc @(require "common.ss" + scribble/struct scribble/bnf + scheme/list + mrlib/tex-table (for-label scheme/gui/base)) @(define (keybinding key . desc) - (apply item @index[(list (format "~a keybinding" key)) key] " : " desc)) + (let* ([keys (if (string? key) (list key) key)] + [key-str (apply string-append (add-between keys " "))]) + (apply item @index[(map (lambda (x) (format "~a keybinding" x)) keys) key-str] " : " desc))) @(define-syntax-rule (def-mod-beg id) (begin @@ -166,6 +171,25 @@ as the @tech{definitions window} plus a few more: expression history down to the prompt} ] +@section{LaTeX and TeX inspired keybindings} + +@itemize[ +@keybinding['("C-\\" "M-\\")]{traces backwards from the insertion +point, looking for a backslash followed by a @index["LaTeX"]{LaTeX} macro name; if one is +found, it replaces the backslash and the macro's name with the keybinding. +These are the currently supported macro names and the keys they map into: +@(make-table + '() + (map (lambda (line) + (let ([macro (list-ref line 0)] + [char (list-ref line 1)]) + (list (make-flow (list (make-paragraph (list (index (format "\\~a keyboard shortcut" macro)) + (tt (format "\\~a" macro)))))) + (make-flow (list (make-paragraph (list char))))))) + tex-shortcut-table)) +} +] + @section[#:tag "defining-shortcuts"]{Defining Custom Shortcuts} The @onscreen{Add User-defined Keybindings...} menu item in the From 2556c61f9d818ad09d2264d56adb49b3ee4c3177 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 16 Mar 2009 12:06:17 +0000 Subject: [PATCH 038/140] PR 10078 -- NOT for inclusion in the release svn: r14122 --- collects/scheme/private/contract-guts.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/scheme/private/contract-guts.ss b/collects/scheme/private/contract-guts.ss index b998a7521e..2e84a67a27 100644 --- a/collects/scheme/private/contract-guts.ss +++ b/collects/scheme/private/contract-guts.ss @@ -356,7 +356,9 @@ (define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate)) (define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate)) (define (flat-named-contract name predicate) - (coerce-flat-contract 'flat-named-contract predicate) + (unless (and (procedure? predicate) + (procedure-arity-includes? predicate 1)) + (error 'flat-named-contract "expected a procedure of arity 1 as second argument, got ~e" predicate)) (make-predicate-contract name predicate)) ;; build-compound-type-name : (union contract symbol) ... -> (-> sexp) From 812d4307b08869bc95ef271447c50522d408e9ca Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 16 Mar 2009 12:27:21 +0000 Subject: [PATCH 039/140] probable fix to 10094 svn: r14123 --- collects/drscheme/private/language-configuration.ss | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss index 711317ad3e..73d888a376 100644 --- a/collects/drscheme/private/language-configuration.ss +++ b/collects/drscheme/private/language-configuration.ss @@ -521,9 +521,9 @@ (send language default-settings)))] [else (values #f #f)])]) (cond - [(not vis-lang) (void)] - [(equal? (send vis-lang get-language-position) - (send language get-language-position)) + [(and vis-lang + (equal? (send vis-lang get-language-position) + (send language get-language-position))) (get/set-settings vis-settings) (send details-panel active-child language-details-panel)] [else From 14e4172c552ef96b3ec9dc60757c3e98f3d458cb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Mar 2009 12:52:28 +0000 Subject: [PATCH 040/140] fix 'defform*' #:id without #:literals (PR 10103); should merge to 4.1.5 svn: r14124 --- collects/scribble/private/manual-form.ss | 3 +++ 1 file changed, 3 insertions(+) diff --git a/collects/scribble/private/manual-form.ss b/collects/scribble/private/manual-form.ss index 1302b65d5a..7f032455b0 100644 --- a/collects/scribble/private/manual-form.ss +++ b/collects/scribble/private/manual-form.ss @@ -106,6 +106,9 @@ [(_ #:literals lits [spec ...] desc ...) (syntax/loc stx (defform*/subs #:literals lits [spec ...] () desc ...))] + [(_ #:id id [spec ...] desc ...) + (syntax/loc stx + (defform*/subs #:id id [spec ...] () desc ...))] [(_ [spec ...] desc ...) (syntax/loc stx (defform*/subs [spec ...] () desc ...))])) From 499464527e8a6149db4e7a0b7f23627abf8992ea Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Mar 2009 13:08:23 +0000 Subject: [PATCH 041/140] reference repairs (PRs 9978, 9704, 9820) svn: r14125 --- .../scribblings/reference/cont-marks.scrbl | 2 +- .../scribblings/reference/sequences.scrbl | 38 ++++++++++--------- collects/scribblings/reference/syntax.scrbl | 4 +- 3 files changed, 23 insertions(+), 21 deletions(-) diff --git a/collects/scribblings/reference/cont-marks.scrbl b/collects/scribblings/reference/cont-marks.scrbl index 54b2cdb18d..e847bd67b1 100644 --- a/collects/scribblings/reference/cont-marks.scrbl +++ b/collects/scribblings/reference/cont-marks.scrbl @@ -89,7 +89,7 @@ separated by a prompt tagged with @scheme[prompt-tag]..} @defproc[(continuation-mark-set->list* [mark-set continuation-mark-set?] - [key-v any/c] + [key-list (listof any/c)] [none-v any/c #f] [prompt-tag prompt-tag? (default-continuation-prompt-tag)]) (listof vector?)]{ diff --git a/collects/scribblings/reference/sequences.scrbl b/collects/scribblings/reference/sequences.scrbl index c19a10da47..cee6ed893a 100644 --- a/collects/scribblings/reference/sequences.scrbl +++ b/collects/scribblings/reference/sequences.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc @(require "mz.ss" - (for-syntax scheme/base)) + (for-syntax scheme/base) + scribble/scheme) @(define-syntax speed (syntax-rules () @@ -246,23 +247,24 @@ the structure and returns a sequence. If @scheme[v] is an instance of a structure type with this property, then @scheme[(sequence? v)] produces @scheme[#t]. -@examples[ -(define-struct train (car next) - #:property prop:sequence (lambda (t) - (make-do-sequence - (lambda () - (values train-car - train-next - t - (lambda (t) t) - (lambda (v) #t) - (lambda (t v) #t)))))) -(for/list ([c (make-train 'engine - (make-train 'boxcar - (make-train 'caboose - #f)))]) - c) -]} +@let-syntax[([car (make-element-id-transformer (lambda (id) #'@schemeidfont{car}))]) + @examples[ + (define-struct train (car next) + #:property prop:sequence (lambda (t) + (make-do-sequence + (lambda () + (values train-car + train-next + t + (lambda (t) t) + (lambda (v) #t) + (lambda (t v) #t)))))) + (for/list ([c (make-train 'engine + (make-train 'boxcar + (make-train 'caboose + #f)))]) + c) + ]]} @section{Sequence Generators} diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 4548fdc229..048e56b9ea 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -1489,8 +1489,8 @@ created first and filled with @|undefined-const|, and all (or (zero? n) (is-odd? (sub1 n))))] [is-odd? (lambda (n) - (or (= n 1) - (is-even? (sub1 n))))]) + (and (not (zero? n)) + (is-even? (sub1 n))))]) (is-odd? 11)) ]} From 1547638f3b9346040246a88bd5acaa02bbbb9160 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 16 Mar 2009 13:13:34 +0000 Subject: [PATCH 042/140] allow pict-pat on pin-arrow-line, etc. (PR 9934): should merge to 4.1.5 svn: r14126 --- collects/texpict/utils.ss | 18 ++++++++++++------ 1 file changed, 12 insertions(+), 6 deletions(-) diff --git a/collects/texpict/utils.ss b/collects/texpict/utils.ss index 71ef173391..d353a200a6 100644 --- a/collects/texpict/utils.ss +++ b/collects/texpict/utils.ss @@ -56,19 +56,25 @@ clip hyperlinkize) + + (define (pict-path? p) + (or (pict? p) + (and (pair? p) + (list? p) + (andmap pict? p)))) (provide/contract [pin-line (->* (pict? - pict? (-> pict? pict? (values number? number?)) - pict? (-> pict? pict? (values number? number?))) + pict-path? (-> pict? pict-path? (values number? number?)) + pict-path? (-> pict? pict-path? (values number? number?))) ((or/c false/c number?) (or/c false/c string?) boolean?) pict?)] [pin-arrow-line (->* (number? pict? - pict? (-> pict? pict? (values number? number?)) - pict? (-> pict? pict? (values number? number?))) + pict-path? (-> pict? pict-path? (values number? number?)) + pict-path? (-> pict? pict-path? (values number? number?))) ((or/c false/c number?) (or/c false/c string?) boolean? @@ -76,8 +82,8 @@ #:hide-arrowhead? any/c) pict?)] [pin-arrows-line (->* (number? pict? - pict? (-> pict? pict? (values number? number?)) - pict? (-> pict? pict? (values number? number?))) + pict-path? (-> pict? pict-path? (values number? number?)) + pict-path? (-> pict? pict-path? (values number? number?))) ((or/c false/c number?) (or/c false/c string?) boolean? From ef85043b9a9d21a47452c49bd2648a48d9088c7e Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Mon, 16 Mar 2009 14:50:13 +0000 Subject: [PATCH 043/140] bug report 10129 svn: r14127 --- collects/2htdp/universe.ss | 20 ++++++++++++++++---- 1 file changed, 16 insertions(+), 4 deletions(-) diff --git a/collects/2htdp/universe.ss b/collects/2htdp/universe.ss index d4d4d80981..601f08f949 100644 --- a/collects/2htdp/universe.ss +++ b/collects/2htdp/universe.ss @@ -146,15 +146,18 @@ (syntax-case #'E () [(V) (set! rec? #'V)] [_ (err 'record? stx)])) - (cons (syntax-e #'kw) (syntax E)))] + (cons #'kw #;(syntax-e #'kw) (syntax E)))] [_ (raise-syntax-error 'big-bang "not a legal big-bang clause" stx)])) (syntax->list (syntax (s ...))))] ;; assert: all bind = (kw . E) and kw is constrained via Bind [args (map (lambda (x) (define kw (car x)) - (define co (assq kw Spec)) - (list kw ((cadr co) (cdr x)))) + (define co ;; patch from Jay to allow rename on import + (findf (lambda (n) (free-identifier=? kw (car n))) + (map (lambda (k s) (cons k (cdr s))) + kwds Spec))) + (list (syntax-e (car co)) ((cadr co) (cdr x)))) spec)]) #`(send (new (if #,rec? aworld% world%) [world0 w] #,@args) last))])) @@ -276,7 +279,7 @@ [(kw . E) (and (identifier? #'kw) (for/or ([n kwds]) (free-identifier=? #'kw n))) - (cons (syntax-e #'kw) (syntax E))] + (cons #'kw (syntax E))] [(kw E) (and (identifier? #'kw) (for/or ([n kwds]) (free-identifier=? #'kw n))) @@ -285,6 +288,15 @@ 'universe "not a legal universe clause" stx)])) (syntax->list (syntax (bind ...))))] ;; assert: all bind = (kw . E) and kw is constrained via Bind + [args (map (lambda (x) + (define kw (car x)) + (define co ;; patch from Jay to allow rename on import + (findf (lambda (n) (free-identifier=? kw (car n))) + (map (lambda (k s) (cons k (cdr s))) + kwds Spec))) + (list (syntax-e (car co)) ((cadr co) (cdr x)))) + spec)] + #; [args (map (lambda (x) (define kw (car x)) (define co (assq kw Spec)) From 65c8b6265291fe1c31a8e14b9f27c063240297f8 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 16 Mar 2009 18:28:56 +0000 Subject: [PATCH 044/140] pr6711 svn: r14129 --- collects/tests/xml/rss.xml | 57 ++++++++++++++++++++++++++++++++++++++ collects/xml/xml.scrbl | 1 + 2 files changed, 58 insertions(+) create mode 100644 collects/tests/xml/rss.xml diff --git a/collects/tests/xml/rss.xml b/collects/tests/xml/rss.xml new file mode 100644 index 0000000000..91ea38e1d0 --- /dev/null +++ b/collects/tests/xml/rss.xml @@ -0,0 +1,57 @@ + + + + + + XML.com + http://xml.com/pub + + XML.com features a rich mix of information and services + for the XML community. + + + + + + + + + + + + + + XML.com + http://www.xml.com + http://xml.com/universal/images/xml_tiny.gif + + + + Processing Inclusions with XSLT + http://xml.com/pub/2000/08/09/xslt/xslt.html + + Processing document inclusions with general XML tools can be + problematic. This article proposes a way of preserving inclusion + information through SAX-based processing. + + + + + Putting RDF to Work + http://xml.com/pub/2000/08/09/rdfdb/index.html + + Tool and API support for the Resource Description Framework + is slowly coming of age. Edd Dumbill takes a look at RDFDB, + one of the most exciting new RDF toolkits. + + + + + Search XML.com + Search XML.com's XML collection + s + http://search.xml.com + + \ No newline at end of file diff --git a/collects/xml/xml.scrbl b/collects/xml/xml.scrbl index a41328af4e..7ca86aa9c3 100644 --- a/collects/xml/xml.scrbl +++ b/collects/xml/xml.scrbl @@ -28,6 +28,7 @@ called an @deftech{X-expression}. The @schememodname[xml] library does not provide Document Type Declaration (DTD) processing, including preservation of DTDs in read documents, or validation. It also does not expand user-defined entities or read user-defined entities in attributes. +It does interpret namespaces either. @; ---------------------------------------------------------------------- From fb15ae339f843b86c74f8095a1edce7b7be8218f Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 16 Mar 2009 18:34:28 +0000 Subject: [PATCH 045/140] pr7382 svn: r14130 --- collects/web-server/scribblings/configuration.scrbl | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/collects/web-server/scribblings/configuration.scrbl b/collects/web-server/scribblings/configuration.scrbl index 43d576d1d3..b51bc9840b 100644 --- a/collects/web-server/scribblings/configuration.scrbl +++ b/collects/web-server/scribblings/configuration.scrbl @@ -234,6 +234,10 @@ turn the paths given in the @scheme[configuration-table] into responders for the Generates a @scheme[response/full] with the given @scheme[http-code] and @scheme[short-version] as the corresponding fields; with the content of the @scheme[text-file] as the body; and, with the @scheme[header]s as, you guessed it, headers. + +This does not cause redirects to a well-known URL, such as @filepath{conf/not-found.html}, but rather use the contents +of @filepath{not-found.html} (for example) as its contents. Therefore, any relative URLs in @scheme[text-file] are relative +to whatever URL @scheme[file-response] is used to respond @emph{to}. Thus, you should probably use absolute URLs in these files. } @defproc[(servlet-loading-responder (url url?) (exn exn?)) From f9c4e4eb542b3980d0d27e6c53e10f62399c3ae4 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 16 Mar 2009 18:45:16 +0000 Subject: [PATCH 046/140] pr7974 + include in release svn: r14132 --- collects/net/cgi-unit.ss | 25 ++++++++++++--- collects/net/scribblings/cgi.scrbl | 6 +++- collects/tests/net/cgi.ss | 50 ++++++++++++++++++++++++++++++ 3 files changed, 75 insertions(+), 6 deletions(-) create mode 100644 collects/tests/net/cgi.ss diff --git a/collects/net/cgi-unit.ss b/collects/net/cgi-unit.ss index ce92d4a38f..a42c3da5b3 100644 --- a/collects/net/cgi-unit.ss +++ b/collects/net/cgi-unit.ss @@ -96,32 +96,47 @@ ;; -- operates on the default input port; the second value indicates whether ;; reading stopped because an EOF was hit (as opposed to the delimiter being ;; seen); the delimiter is not part of the result -(define (read-until-char ip delimiter) +(define (read-until-char ip delimiter?) (let loop ([chars '()]) (let ([c (read-char ip)]) (cond [(eof-object? c) (values (reverse chars) #t)] - [(char=? c delimiter) (values (reverse chars) #f)] + [(delimiter? c) (values (reverse chars) #f)] [else (loop (cons c chars))])))) +;; delimiter->predicate : +;; symbol -> (char -> bool) +;; returns a predicates to pass to read-until-char +(define (delimiter->predicate delimiter) + (case delimiter + [(eq) (lambda (c) (char=? c #\=))] + [(amp) (lambda (c) (char=? c #\&))] + [(semi) (lambda (c) (char=? c #\;))] + [(amp-or-semi) (lambda (c) (or (char=? c #\&) (char=? c #\;)))])) + ;; read-name+value : iport -> (symbol + bool) x (string + bool) x bool ;; -- If the first value is false, so is the second, and the third is true, ;; indicating EOF was reached without any input seen. Otherwise, the first ;; and second values contain strings and the third is either true or false ;; depending on whether the EOF has been reached. The strings are processed ;; to remove the CGI spec "escape"s. This code is _slightly_ lax: it allows -;; an input to end in `&'. It's not clear this is legal by the CGI spec, +;; an input to end in (current-alist-separator-mode). +;; It's not clear this is legal by the CGI spec, ;; which suggests that the last value binding must end in an EOF. It doesn't ;; look like this matters. It would also introduce needless modality and ;; reduce flexibility. (define (read-name+value ip) - (let-values ([(name eof?) (read-until-char ip #\=)]) + (let-values ([(name eof?) (read-until-char ip (delimiter->predicate 'eq))]) (cond [(and eof? (null? name)) (values #f #f #t)] [eof? (generate-error-output (list "Server generated malformed input for POST method:" (string-append "No binding for `" (list->string name) "' field.")))] - [else (let-values ([(value eof?) (read-until-char ip #\&)]) + [else (let-values ([(value eof?) + (read-until-char + ip + (delimiter->predicate + (current-alist-separator-mode)))]) (values (string->symbol (query-chars->string name)) (query-chars->string value) eof?))]))) diff --git a/collects/net/scribblings/cgi.scrbl b/collects/net/scribblings/cgi.scrbl index abfb1795e2..e81f5ce91f 100644 --- a/collects/net/scribblings/cgi.scrbl +++ b/collects/net/scribblings/cgi.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc @(require "common.ss" (for-label net/cgi + net/uri-codec net/cgi-unit net/cgi-sig)) @@ -41,7 +42,10 @@ Returns the bindings that corresponding to the options specified by the user. The @scheme[get-bindings/post] and @scheme[get-bindings/get] variants work only when POST and GET forms are used, respectively, while @scheme[get-bindings] determines the -kind of form that was used and invokes the appropriate function.} +kind of form that was used and invokes the appropriate function. + +These functions respect @scheme[current-alist-separator-mode]. +} @defproc[(extract-bindings [key? (or/c symbol? string?)] diff --git a/collects/tests/net/cgi.ss b/collects/tests/net/cgi.ss new file mode 100644 index 0000000000..3cc717689b --- /dev/null +++ b/collects/tests/net/cgi.ss @@ -0,0 +1,50 @@ +#lang scheme +(require net/cgi + net/uri-codec) + +(define-syntax test-result + (syntax-rules () + [(test-result expression expected) + (let ([result expression]) + (if (equal? result expected) + (display (format "Ok: `~a' evaluated to `~a'.\n" + 'expression expected)) + (display (format + "Error: `~a' evaluated to `~a', expected `~a'.\n" + 'expression result expected))))])) + +(putenv "REQUEST_METHOD" "GET") + +(test-result (begin + (current-alist-separator-mode 'amp-or-semi) + (putenv "QUERY_STRING" "key1=value1&key2=value2;key3=value3") + (get-bindings)) + '((key1 . "value1") + (key2 . "value2") + (key3 . "value3"))) + +(test-result (begin + (current-alist-separator-mode 'amp) + (putenv "QUERY_STRING" "key1=value1&key2=value2") + (get-bindings)) + '((key1 . "value1") + (key2 . "value2"))) + +(test-result (begin + (current-alist-separator-mode 'amp) + (putenv "QUERY_STRING" "key1=value1;key2=value2") + (get-bindings)) + '((key1 . "value1;key2=value2"))) + +(test-result (begin + (current-alist-separator-mode 'semi) + (putenv "QUERY_STRING" "key1=value1;key2=value2") + (get-bindings)) + '((key1 . "value1") + (key2 . "value2"))) + +(test-result (begin + (current-alist-separator-mode 'semi) + (putenv "QUERY_STRING" "key1=value1&key2=value2") + (get-bindings)) + '((key1 . "value1&key2=value2"))) \ No newline at end of file From b3cec49237b28a66c610e3fdb26409fd0134f734 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Mon, 16 Mar 2009 19:26:36 +0000 Subject: [PATCH 047/140] pr9106, include in release svn: r14133 --- collects/tests/web-server/private/request-test.ss | 14 ++++++++++++++ collects/web-server/http/request.ss | 13 ++++++++----- 2 files changed, 22 insertions(+), 5 deletions(-) diff --git a/collects/tests/web-server/private/request-test.ss b/collects/tests/web-server/private/request-test.ss index 2998634914..13f325a3f4 100644 --- a/collects/tests/web-server/private/request-test.ss +++ b/collects/tests/web-server/private/request-test.ss @@ -2,6 +2,7 @@ (require (planet schematics/schemeunit:3) web-server/private/connection-manager web-server/private/timer + web-server/http/request web-server/http) (provide request-tests) @@ -21,6 +22,7 @@ ip op (make-custodian) #f) headers))) + (define (get-bindings post-data) (define-values (conn headers) (make-mock-connection&headers post-data)) (call-with-values (lambda () (read-bindings&post-data/raw conn #"POST" #f headers)) @@ -54,6 +56,18 @@ ; XXX This needs to be really extensive, see what Apache has (test-suite "Parsing" + (test-suite + "URL Query" + (test-not-exn "Unfinished URL query" + (lambda () + (define ip (open-input-string "GET http://127.0.0.1:8080/servlets/examples/hello.ss?a=1&b: HTTP/1.1")) + (read-request + (make-connection 0 (make-timer ip +inf.0 (lambda () (void))) + ip + (open-output-bytes) (make-custodian) #f) + 8081 + (lambda _ (values "s1" "s2")))))) + (test-suite "POST Bindings" (test-equal? "simple test 1" diff --git a/collects/web-server/http/request.ss b/collects/web-server/http/request.ss index 6a89746f4e..ffe274b741 100644 --- a/collects/web-server/http/request.ss +++ b/collects/web-server/http/request.ss @@ -152,11 +152,14 @@ (define (read-bindings&post-data/raw conn meth uri headers) (cond [(bytes-ci=? #"GET" meth) - (values (map (match-lambda - [(list-rest k v) - (make-binding:form (string->bytes/utf-8 (symbol->string k)) - (string->bytes/utf-8 v))]) - (url-query uri)) + (values (filter (lambda (x) x) + (map (match-lambda + [(list-rest k v) + (if (and (symbol? k) (string? v)) + (make-binding:form (string->bytes/utf-8 (symbol->string k)) + (string->bytes/utf-8 v)) + #f)]) + (url-query uri))) #f)] [(bytes-ci=? #"POST" meth) (local From ee084ad7ff39d0932a60f662b70e7a198c8b9c0c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Mar 2009 00:45:29 +0000 Subject: [PATCH 048/140] adjust special scheme/class keywords to effectively declare themselves as expression forms (PR 10135): merge to 4.1.5 svn: r14137 --- collects/scheme/private/class-internal.ss | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/collects/scheme/private/class-internal.ss b/collects/scheme/private/class-internal.ss index a6ae8f06ee..a9040846b5 100644 --- a/collects/scheme/private/class-internal.ss +++ b/collects/scheme/private/class-internal.ss @@ -148,10 +148,12 @@ (define-for-syntax not-in-a-class (lambda (stx) - (raise-syntax-error - #f - "use of a class keyword is not in a class" - stx))) + (if (eq? (syntax-local-context) 'expression) + (raise-syntax-error + #f + "use of a class keyword is not in a class" + stx) + (quasisyntax/loc stx (#%expression #,stx))))) (define-syntax define/provide-context-keyword (syntax-rules () From 6b5b193815bd469a2119e1227503fe446f89e8d2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 17 Mar 2009 02:14:11 +0000 Subject: [PATCH 049/140] Fix docs for HashTable. Add string->list, list->string, sort. svn: r14138 --- collects/typed-scheme/private/base-env.ss | 4 ++++ collects/typed-scheme/ts-reference.scrbl | 2 ++ 2 files changed, 6 insertions(+) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index dea4afdee6..08cacb6c24 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -538,6 +538,10 @@ [maybe-print-message (-String . -> . -Void)] +[list->string ((-lst -Char) . -> . -String)] +[string->list (-String . -> . (-lst -Char))] +[sort (-poly (a) ((-lst a) (a a . -> . B) . -> . (-lst a)))] + ;; scheme/list [last-pair (-poly (a) ((-mu x (Un a (-val '()) (-pair a x))) . -> . diff --git a/collects/typed-scheme/ts-reference.scrbl b/collects/typed-scheme/ts-reference.scrbl index 102a13e905..b1d44a0c82 100644 --- a/collects/typed-scheme/ts-reference.scrbl +++ b/collects/typed-scheme/ts-reference.scrbl @@ -52,6 +52,8 @@ The following base types are parameteric in their type arguments. the first is the type the parameter accepts, and the second is the type returned.} @defform[(Pair s t)]{is the pair containing @scheme[s] as the @scheme[car] and @scheme[t] as the @scheme[cdr]} +@defform[(HashTable k v)]{is the type of a @rtech{hash table} with key type + @scheme[k] and value type @scheme[v].} @subsubsub*section{Type Constructors} From 2008456d645da58daa6f70321248dde29e8717c2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 17 Mar 2009 07:04:16 +0000 Subject: [PATCH 050/140] Converted the cgi tests to use my test macro, and included them in the nightly testing. svn: r14139 --- collects/tests/net/cgi.ss | 51 +++++++++------------------ collects/tests/net/main.ss | 3 ++ collects/tests/run-automated-tests.ss | 1 + 3 files changed, 21 insertions(+), 34 deletions(-) create mode 100644 collects/tests/net/main.ss diff --git a/collects/tests/net/cgi.ss b/collects/tests/net/cgi.ss index 3cc717689b..a96f609d6b 100644 --- a/collects/tests/net/cgi.ss +++ b/collects/tests/net/cgi.ss @@ -1,6 +1,7 @@ #lang scheme (require net/cgi - net/uri-codec) + net/uri-codec + tests/eli-tester) (define-syntax test-result (syntax-rules () @@ -13,38 +14,20 @@ "Error: `~a' evaluated to `~a', expected `~a'.\n" 'expression result expected))))])) -(putenv "REQUEST_METHOD" "GET") +(void (putenv "REQUEST_METHOD" "GET")) -(test-result (begin - (current-alist-separator-mode 'amp-or-semi) - (putenv "QUERY_STRING" "key1=value1&key2=value2;key3=value3") - (get-bindings)) - '((key1 . "value1") - (key2 . "value2") - (key3 . "value3"))) +(define (test-bindings mode query-string) + (parameterize ([current-alist-separator-mode mode]) + (putenv "QUERY_STRING" query-string) + (get-bindings))) -(test-result (begin - (current-alist-separator-mode 'amp) - (putenv "QUERY_STRING" "key1=value1&key2=value2") - (get-bindings)) - '((key1 . "value1") - (key2 . "value2"))) - -(test-result (begin - (current-alist-separator-mode 'amp) - (putenv "QUERY_STRING" "key1=value1;key2=value2") - (get-bindings)) - '((key1 . "value1;key2=value2"))) - -(test-result (begin - (current-alist-separator-mode 'semi) - (putenv "QUERY_STRING" "key1=value1;key2=value2") - (get-bindings)) - '((key1 . "value1") - (key2 . "value2"))) - -(test-result (begin - (current-alist-separator-mode 'semi) - (putenv "QUERY_STRING" "key1=value1&key2=value2") - (get-bindings)) - '((key1 . "value1&key2=value2"))) \ No newline at end of file +(test (test-bindings 'amp-or-semi "key1=value1&key2=value2;key3=value3") + => '([key1 . "value1"] [key2 . "value2"] [key3 . "value3"]) + (test-bindings 'amp "key1=value1&key2=value2") + => '([key1 . "value1"] [key2 . "value2"]) + (test-bindings 'amp "key1=value1;key2=value2") + => '([key1 . "value1;key2=value2"]) + (test-bindings 'semi "key1=value1;key2=value2") + => '([key1 . "value1"] [key2 . "value2"]) + (test-bindings 'semi "key1=value1&key2=value2") + => '([key1 . "value1&key2=value2"])) diff --git a/collects/tests/net/main.ss b/collects/tests/net/main.ss new file mode 100644 index 0000000000..62381b4835 --- /dev/null +++ b/collects/tests/net/main.ss @@ -0,0 +1,3 @@ +#lang scheme/base + +(require "cgi.ss") diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index b0978b659b..7c4407c1dd 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -38,6 +38,7 @@ ;; [require "stepper/automatic-tests.ss" (lib "scheme/base")] [require "lazy/main.ss"] [require "scribble/main.ss"] + [require "net/main.ss"] )) From 19eb34367fd977700a76a4eb9ba1f12902d3ecfe Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 17 Mar 2009 07:06:08 +0000 Subject: [PATCH 051/140] typo svn: r14140 --- collects/scribblings/guide/module-basics.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/guide/module-basics.scrbl b/collects/scribblings/guide/module-basics.scrbl index ac6f8fa0a2..bfe8ff2180 100644 --- a/collects/scribblings/guide/module-basics.scrbl +++ b/collects/scribblings/guide/module-basics.scrbl @@ -67,7 +67,7 @@ scheme In addition to the main @tech{collection} directory, which contains all collections that are part of the installation, collections can also be installed in a user-specific location. Finally, additional -collection directories can be specified n configuration files or +collection directories can be specified in configuration files or through the @envvar{PLTCOLLECTS} search path. Try running the following program to find out where your collections are: From 167bae8bddb7411e17d5a69c38c8a1646eda9b89 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 17 Mar 2009 10:04:20 +0000 Subject: [PATCH 052/140] add option for testing errors and non-exception raised values with a predicate svn: r14141 --- collects/tests/eli-tester.ss | 70 +++++++++++++++++++++++++++--------- 1 file changed, 54 insertions(+), 16 deletions(-) diff --git a/collects/tests/eli-tester.ss b/collects/tests/eli-tester.ss index f6e2f899a5..0fb6027370 100644 --- a/collects/tests/eli-tester.ss +++ b/collects/tests/eli-tester.ss @@ -7,17 +7,25 @@ (syntax-case stx () [(_ expr) ;; catch syntax errors while expanding, turn them into runtime errors - (with-handlers ([exn? (lambda (e) #`(list 'error #,(exn-message e)))]) + (with-handlers ([exn? (lambda (e) #`(list 'error #,(exn-message e) #,e))]) (define-values (_ opaque) (syntax-local-expand-expression - #'(with-handlers ([exn? (lambda (e) (list 'error (exn-message e)))]) + #'(with-handlers + ([(lambda (_) #t) + (lambda (e) (list 'error (and (exn? e) (exn-message e)) e))]) (cons 'values (call-with-values (lambda () expr) list))))) opaque)])) (define show - (match-lambda [(list 'error msg) (format "error: ~a" msg)] - [(list 'values x) (format "~e" x)] - [(list 'values xs ...) (format "~e" (cons 'values xs))])) + (match-lambda + [(list 'values x) (format "~e" x)] + [(list 'values xs ...) (format "~e" (cons 'values xs))] + [(list 'error err val) + (cond [(procedure? err) (format "error satisfying ~s" err)] + [(regexp? err) (format "error matching ~s" err)] + [err (format "error: ~a" err)] + [else (format "a raised non-exception ~s" val)])] + [x (format "INTERNAL ERROR, unexpected value: ~s" x)])) (define test-context (make-parameter #f)) (define failure-message (make-parameter #f)) @@ -41,17 +49,36 @@ #`(let ([x (safe #,x)]) (unless (and (eq? 'values (car x)) (= 2 (length x)) (cadr x)) #,(blame x "expected non-#f single value; got: ~a" #'(show x))))) - (define (t2 x y) - #`(let ([x (safe #,x)] [y (safe #,y)]) - (cond [(and (eq? 'values (car x)) (eq? 'error (car y))) - #,(blame x "expected an error; got ~a" #'(show x))] - [(and (eq? 'error (car x)) (eq? 'error (car y))) - (unless (regexp-match? (regexp-quote (cadr y)) (cadr x)) - #,(blame x "bad error message, expected ~s; got ~s" - #'(cadr y) #'(cadr x)))] - [(not (equal? x y)) - #,(blame x "expected ~a; got: ~a" #'(show y) #'(show x))]))) - (define (te x y) (t2 x #`(error #,y))) + (define (t2 x y [eval2? #t]) + #`(let* ([x (safe #,x)] [xtag (car x)] + [y #,(if eval2? #`(safe #,y) y)] [ytag (car y)]) + (cond + [(eq? ytag 'values) + (unless (equal? x y) + #,(blame x "expected ~a; got: ~a" #'(show y) #'(show x)))] + [(eq? xtag 'values) + #,(blame x "expected an error; got ~a" #'(show x))] + ;; both are errors (or other raised values) + [(not (cadr x)) ; expecting a non-exception raise + (unless (or (equal? x y) + (and (procedure? (cadr y)) ((cadr y) (caddr x)))) + #,(blame x "expected ~a; got ~a" #'(show y) #'(show x)))] + [else + (let ([xerr (cadr x)] [xval (caddr x)] [yerr (cadr y)]) + (cond [(string? yerr) + (unless (regexp-match? (regexp-quote yerr) xerr) + #,(blame x "bad error message, expected ~s; got ~s" + #'yerr #'xerr))] + [(regexp? yerr) + (unless (regexp-match? yerr xerr) + #,(blame x "bad error message, expected ~a ~s; got ~s" + "a match for" #'yerr #'xerr))] + [(and (procedure? yerr) (procedure-arity-includes? yerr 1)) + (unless (yerr xval) + #,(blame x "bad error message, expected ~a ~s; got ~s" + "an exception satisfying" #'yerr #'xerr))] + [else (error 'test "bad error specification: ~e" yerr)]))]))) + (define (te x y) (t2 x #`(list 'error #,y #f) #f)) (define (try t . args) #`(let ([c (test-context)]) (with-handlers ([exn? (lambda (e) (set-mcdr! c (cons e (mcdr c))))]) @@ -133,11 +160,22 @@ ;; syntax errors (if 1) =error> "if: bad syntax" + ;; error (and non-exception raises) predicates + (+ 1 "2") =error> exn:fail:contract? + (+ 1 "2") =error> (lambda (x) (not (exn:fail:filesystem? x))) + (+ 1 "2") =error> #rx"expects.*" + (error "1") =error> exn? + (raise 1) =error> number? + (raise "1") =error> string? + ;; test `test' errors (test* (/ 0)) =error> "expected non-#f single value" (test* 1 => 2) =error> "expected 2" (test* 1 =error> "") =error> "expected an error" (test* (/ 0) =error> "zzz") =error> "bad error message" + (test* (raise 1) =error> "foo") =error> "raised non-exception" + (test* #:failure-message "FOO" (/ 0) => 1) =error> "FOO" + (test* #:failure-message "FOO" (/ 0)) =error> "FOO" ) ;; SchemeUnit stuff From e616818d347b3ab5d9ec3ed8d92890f060ea9997 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 17 Mar 2009 10:53:13 +0000 Subject: [PATCH 053/140] fixed use of string-length and error symbol svn: r14142 --- collects/net/head-unit.ss | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/collects/net/head-unit.ss b/collects/net/head-unit.ss index 7b42b5a363..d5b82b9e5d 100644 --- a/collects/net/head-unit.ss +++ b/collects/net/head-unit.ss @@ -33,15 +33,15 @@ [(and (= (+ offset 2) len) (bytes=? CRLF/bytes (subbytes s offset len))) (void)] ; validated - [(= offset len) (error 'validate-header/bytes "missing ending CRLF")] + [(= offset len) (error 'validate-header "missing ending CRLF")] [(or (regexp-match re:field-start/bytes s offset) (regexp-match re:continue/bytes s offset)) (let ([m (regexp-match-positions #rx#"\r\n" s offset)]) (if m (loop (cdar m)) - (error 'validate-header/bytes "missing ending CRLF")))] - [else (error 'validate-header/bytes "ill-formed header at ~s" - (subbytes s offset (string-length s)))]))) + (error 'validate-header "missing ending CRLF")))] + [else (error 'validate-header "ill-formed header at ~s" + (subbytes s offset (bytes-length s)))]))) ;; otherwise it should be a string: (begin (let ([m (regexp-match #rx"[^\000-\377]" s)]) From b647ea2ae955d0180a7ed367514033b545396c09 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 17 Mar 2009 11:41:06 +0000 Subject: [PATCH 054/140] new copy of net tests, split into modules, and using my test macro svn: r14143 --- collects/tests/net/cgi.ss | 40 ++-- collects/tests/net/cookie.ss | 84 ++++++++ collects/tests/net/encoders.ss | 109 ++++++++++ collects/tests/net/head.ss | 93 +++++++++ collects/tests/net/main.ss | 18 +- collects/tests/net/uri-codec.ss | 131 ++++++++++++ collects/tests/net/url.ss | 357 ++++++++++++++++++++++++++++++++ 7 files changed, 805 insertions(+), 27 deletions(-) create mode 100644 collects/tests/net/cookie.ss create mode 100644 collects/tests/net/encoders.ss create mode 100644 collects/tests/net/head.ss create mode 100644 collects/tests/net/uri-codec.ss create mode 100644 collects/tests/net/url.ss diff --git a/collects/tests/net/cgi.ss b/collects/tests/net/cgi.ss index a96f609d6b..3e5694a2d4 100644 --- a/collects/tests/net/cgi.ss +++ b/collects/tests/net/cgi.ss @@ -1,33 +1,21 @@ #lang scheme -(require net/cgi - net/uri-codec - tests/eli-tester) - -(define-syntax test-result - (syntax-rules () - [(test-result expression expected) - (let ([result expression]) - (if (equal? result expected) - (display (format "Ok: `~a' evaluated to `~a'.\n" - 'expression expected)) - (display (format - "Error: `~a' evaluated to `~a', expected `~a'.\n" - 'expression result expected))))])) - -(void (putenv "REQUEST_METHOD" "GET")) +(require net/cgi net/uri-codec tests/eli-tester) (define (test-bindings mode query-string) (parameterize ([current-alist-separator-mode mode]) (putenv "QUERY_STRING" query-string) (get-bindings))) -(test (test-bindings 'amp-or-semi "key1=value1&key2=value2;key3=value3") - => '([key1 . "value1"] [key2 . "value2"] [key3 . "value3"]) - (test-bindings 'amp "key1=value1&key2=value2") - => '([key1 . "value1"] [key2 . "value2"]) - (test-bindings 'amp "key1=value1;key2=value2") - => '([key1 . "value1;key2=value2"]) - (test-bindings 'semi "key1=value1;key2=value2") - => '([key1 . "value1"] [key2 . "value2"]) - (test-bindings 'semi "key1=value1&key2=value2") - => '([key1 . "value1&key2=value2"])) +(provide tests) +(define (tests) + (putenv "REQUEST_METHOD" "GET") + (test (test-bindings 'amp-or-semi "key1=value1&key2=value2;key3=value3") + => '([key1 . "value1"] [key2 . "value2"] [key3 . "value3"]) + (test-bindings 'amp "key1=value1&key2=value2") + => '([key1 . "value1"] [key2 . "value2"]) + (test-bindings 'amp "key1=value1;key2=value2") + => '([key1 . "value1;key2=value2"]) + (test-bindings 'semi "key1=value1;key2=value2") + => '([key1 . "value1"] [key2 . "value2"]) + (test-bindings 'semi "key1=value1&key2=value2") + => '([key1 . "value1&key2=value2"]))) diff --git a/collects/tests/net/cookie.ss b/collects/tests/net/cookie.ss new file mode 100644 index 0000000000..601eb3d71f --- /dev/null +++ b/collects/tests/net/cookie.ss @@ -0,0 +1,84 @@ +#lang scheme +(require net/cookie tests/eli-tester) + +;; cookie tests --- JBM, 2006-12-01 + +(provide tests) +(define (tests) + ;; cookie-test : (cookie -> cookie) string -> test + (define (cookie-test fn expected) + (test (print-cookie (fn (set-cookie "a" "b"))) => expected)) + ;; RC = "reverse curry" + (define (RC f arg2) (λ (arg1) (f arg1 arg2))) + ;; o = compose + (define-syntax o + (syntax-rules () + [(o f) f] + [(o f g h ...) (λ (x) (o/* x f g h ...))])) + (define-syntax o/* + (syntax-rules () + [(o/* x) x] + [(o/* x f g ...) (f (o/* x g ...))])) + + (define (tests) + + ;; test the most basic functionality + (cookie-test (λ (x) x) "a=b; Version=1") + + ;; test each modifier individually + (cookie-test (RC cookie:add-comment "set+a+to+b") + "a=b; Comment=set+a+to+b; Version=1") + (cookie-test (RC cookie:add-comment "a comment with spaces") + "a=b; Comment=\"a comment with spaces\"; Version=1") + (cookie-test (RC cookie:add-comment "the \"risks\" involved in waking") + "a=b; Comment=\"the \\\"risks\\\" involved in waking\"; Version=1") + (cookie-test (RC cookie:add-comment "\"already formatted\"") + "a=b; Comment=\"already formatted\"; Version=1") + (cookie-test (RC cookie:add-comment "\"problematic \" internal quote\"") + "a=b; Comment=\"\\\"problematic \\\" internal quote\\\"\"; Version=1") + (cookie-test (RC cookie:add-comment "contains;semicolon") + "a=b; Comment=\"contains;semicolon\"; Version=1") + (cookie-test (RC cookie:add-domain ".example.net") + "a=b; Domain=.example.net; Version=1") + (cookie-test (RC cookie:add-max-age 100) + "a=b; Max-Age=100; Version=1") + (cookie-test (RC cookie:add-path "/whatever/wherever/") + "a=b; Path=\"/whatever/wherever/\"; Version=1") + (cookie-test (RC cookie:add-path "a+path") + "a=b; Path=a+path; Version=1") + (cookie-test (RC cookie:add-path "\"/already/quoted/\"") + "a=b; Path=\"/already/quoted/\"; Version=1") + (cookie-test (RC cookie:secure #t) + "a=b; Secure; Version=1") + (cookie-test (RC cookie:secure #f) + "a=b; Version=1") + (cookie-test (RC cookie:version 12) + "a=b; Version=12") + + ;; test combinations + (cookie-test (o (RC cookie:add-comment "set+a+to+b") + (RC cookie:add-domain ".example.net")) + "a=b; Comment=set+a+to+b; Domain=.example.net; Version=1") + (cookie-test (o (RC cookie:add-max-age 300) + (RC cookie:secure #t)) + "a=b; Max-Age=300; Secure; Version=1") + (cookie-test (o (RC cookie:add-path "/whatever/wherever/") + (RC cookie:version 10) + (RC cookie:add-max-age 20)) + "a=b; Max-Age=20; Path=\"/whatever/wherever/\"; Version=10") + + ;; test error cases + (let () + (define-syntax cookie-error-test + (syntax-rules () + [(cookie-error-test e) + (test (e (set-cookie "a" "b")) =error> cookie-error?)])) + (cookie-error-test (RC cookie:add-comment "illegal character #\000")) + (cookie-error-test (RC cookie:add-max-age -10)) + (cookie-error-test (RC cookie:add-domain "doesntstartwithadot.example.com")) + (cookie-error-test (RC cookie:add-domain "bad domain.com")) + (cookie-error-test (RC cookie:add-domain ".bad-domain;com"))) + + ) + + (test do (tests))) diff --git a/collects/tests/net/encoders.ss b/collects/tests/net/encoders.ss new file mode 100644 index 0000000000..3d06130db2 --- /dev/null +++ b/collects/tests/net/encoders.ss @@ -0,0 +1,109 @@ +#lang scheme +(require net/base64 net/qp tests/eli-tester) + +(define tricky-strings + (let ([dir (collection-path "tests" "mzscheme")]) + (list (make-bytes 200 32) + (make-bytes 200 9) + (make-bytes 200 (char->integer #\x)) + (make-bytes 201 (char->integer #\x)) + (make-bytes 202 (char->integer #\x)) + (make-bytes 203 (char->integer #\x)) + (make-bytes 204 (char->integer #\x)) + (list->bytes (for/list ([i (in-range 256)]) i)) + ;; Something that doesn't end with a LF: + (bytes-append (with-input-from-file (build-path dir "net.ss") + (lambda () (read-bytes 500))) + #"xxx") + ;; CRLF: + (regexp-replace #rx#"\r?\n" + (with-input-from-file (build-path dir "net.ss") + (lambda () (read-bytes 500))) + #"\r\n")))) + +(define (check-same encode decode port line-rx max-w) + (let ([p (open-output-bytes)]) + (copy-port port p) + (let ([bytes (get-output-bytes p)] + [r (open-output-bytes)]) + (encode (open-input-bytes bytes) r) + (let ([p (open-input-bytes (get-output-bytes r))]) + (let loop () + (let ([l (read-bytes-line p 'any)]) + (unless (eof-object? l) + (test ; #:failure-message (format "line too long; ~s" encode) + (<= (bytes-length l) max-w)) + (let ([m (regexp-match-positions line-rx l)]) + (test ; #:failure-message (format "bad line; ~s" encode) + (and m (= (bytes-length l) (cdar m))))) + (loop)))) + (let ([q (open-output-bytes)]) + (decode (open-input-bytes (get-output-bytes r)) q) + (unless (equal? (get-output-bytes q) bytes) + (with-output-to-file "/tmp/x0" (lambda () (display (get-output-bytes r))) 'truncate) + (with-output-to-file "/tmp/x1" (lambda () (display (get-output-bytes q))) 'truncate) + (with-output-to-file "/tmp/x2" (lambda () (display bytes)) 'truncate) + (error 'decode "failed"))))))) + +(define ((check-same-file encode decode line-rx max-w) file) + (call-with-input-file file + (lambda (p) (check-same encode decode p line-rx max-w)))) + +(define (check-same-all encode decode line-rx max-w) + (for-each (lambda (tricky-string) + (check-same encode decode + (open-input-bytes tricky-string) + line-rx max-w)) + tricky-strings) + (let* ([dir (collection-path "tests" "mzscheme")] + [files (filter-map + (lambda (f) + ;; check 1/4 of the files, randomly + (let ([p (build-path dir f)]) + (and (zero? (random 4)) + (not (regexp-match #rx"^flat.*\\.ss$" + (path-element->string f))) + (file-exists? p) + p))) + (directory-list dir))]) + (for-each (check-same-file encode decode line-rx max-w) files))) + +(provide tests) +(define (tests) + (test + do (check-same-all (lambda (i o) (qp-encode-stream i o)) + qp-decode-stream + #rx#"^(|[\t \41-\176]*[\41-\176]+)$" + 76) + do (check-same-all base64-encode-stream + base64-decode-stream + #rx#"^[0-9a-zA-Z+=/]*$" + 72))) + +#| +Use this to compare base64 encode/decode against the unix utilities +(require net/base64 scheme/system) +(define (base64-encode* bstr) + (let ([o (open-output-bytes)]) + (parameterize ([current-output-port o] + [current-input-port (open-input-bytes bstr)]) + (system "base64-encode")) + (let* ([o (get-output-bytes o)] + [o (regexp-replace #rx#"(.)(?:\r?\n)?$" o #"\\1\r\n")] + [o (regexp-replace* #rx#"\r?\n" o #"\r\n")]) + o))) +(define (base64-decode* bstr) + (let ([o (open-output-bytes)]) + (parameterize ([current-output-port o] + [current-input-port (open-input-bytes bstr)]) + (system "base64-decode")) + (get-output-bytes o))) +(define (check-base64-encode bstr) + (equal? (base64-encode bstr) (base64-encode* bstr))) +(define (check-base64-decode bstr) + (equal? (base64-decode bstr) (base64-decode* bstr))) +(define (check-base64-both bstr) + (let ([en (base64-encode bstr)]) + (and (equal? en (base64-encode* bstr)) + (equal? (base64-decode en) (base64-decode* en))))) +|# diff --git a/collects/tests/net/head.ss b/collects/tests/net/head.ss new file mode 100644 index 0000000000..63df83896d --- /dev/null +++ b/collects/tests/net/head.ss @@ -0,0 +1,93 @@ +#lang scheme +(require net/head tests/eli-tester) + +;; a few tests of head.ss -- JBC, 2006-07-31 + +(provide tests) +(define (tests) + (define test-header + (string-append "From: abc\r\nTo: field is\r\n continued\r\n" + "Another: zoo\r\n continued\r\n\r\n")) + (define test-header/bytes + (bytes-append #"From: abc\r\nTo: field is\r\n continued\r\n" + #"Another: zoo\r\n continued\r\n\r\n")) + (test + + (validate-header "From: me@here.net\r\n\r\n") + (validate-header #"From: me@here.net\r\n\r\n") + (validate-header "From: a\r\nTo: b\r\nResent-to: qrv@erocg\r\n\r\n") + (validate-header #"From: a\r\nTo: b\r\nResent-to: qrv@erocg\r\n\r\n") + + (validate-header "From: a\r\nTo: b\r\nMissingTrailingrn: qrv@erocg\r\n") + =error> "missing ending CRLF" + (validate-header #"From: a\r\nTo: b\r\nMissingTrailingrn: qrv@erocg\r\n") + =error> "missing ending CRLF" + (validate-header "From: a\r\nnocolon inthisline\r\n\r\n") + =error> "ill-formed header" + (validate-header #"From: a\r\nnocolon inthisline\r\n\r\n") + =error> "ill-formed header" + (validate-header "From: a\r\nMissingReturn: och\n\r\n") + =error> "missing ending CRLF" + (validate-header #"From: a\r\nMissingReturn: och\n\r\n") + =error> "missing ending CRLF" + (validate-header "From: a\r\nSpacein Fieldname: och\r\n\r\n") + =error> "ill-formed header" + (validate-header #"From: a\r\nSpacein Fieldname: och\r\n\r\n") + =error> "ill-formed header" + + (extract-field "From" test-header) + => "abc" + (extract-field #"From" test-header/bytes) + => #"abc" + (extract-field "To" test-header) + => "field is\r\n continued" + (extract-field #"To" test-header/bytes) + => #"field is\r\n continued" + (extract-field "Another" test-header) + => "zoo\r\n continued" + (extract-field #"Another" test-header/bytes) + => #"zoo\r\n continued" + + (replace-field "From" "def" test-header) + => "From: def\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" + (replace-field #"From" #"def" test-header/bytes) + => #"From: def\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" + (replace-field "From" #f test-header) + => "To: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" + (replace-field #"From" #f test-header/bytes) + => #"To: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" + + (replace-field "To" "qrs" test-header) + => "From: abc\r\nTo: qrs\r\nAnother: zoo\r\n continued\r\n\r\n" + (replace-field #"To" #"qrs" test-header/bytes) + => #"From: abc\r\nTo: qrs\r\nAnother: zoo\r\n continued\r\n\r\n" + (replace-field "To" #f test-header) + => "From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" + (replace-field #"To" #f test-header/bytes) + => #"From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" + + (replace-field "Another" "abc\r\n def" test-header) + => "From: abc\r\nTo: field is\r\n continued\r\nAnother: abc\r\n def\r\n\r\n" + (replace-field #"Another" #"abc\r\n def" test-header/bytes) + => #"From: abc\r\nTo: field is\r\n continued\r\nAnother: abc\r\n def\r\n\r\n" + (replace-field "Another" #f test-header) + => "From: abc\r\nTo: field is\r\n continued\r\n\r\n" + (replace-field #"Another" #f test-header/bytes) + => #"From: abc\r\nTo: field is\r\n continued\r\n\r\n" + + (remove-field "To" test-header) + => "From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" + (remove-field #"To" test-header/bytes) + => #"From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" + + (extract-all-fields test-header) + => `(("From" . "abc") ("To" . "field is\r\n continued") ("Another" . "zoo\r\n continued")) + (extract-all-fields test-header/bytes) + => `((#"From" . #"abc") (#"To" . #"field is\r\n continued") (#"Another" . #"zoo\r\n continued")) + + (append-headers test-header "Athird: data\r\n\r\n") + => "From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\nAthird: data\r\n\r\n" + (append-headers test-header/bytes #"Athird: data\r\n\r\n") + => #"From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\nAthird: data\r\n\r\n" + + )) diff --git a/collects/tests/net/main.ss b/collects/tests/net/main.ss index 62381b4835..a9db1e8a23 100644 --- a/collects/tests/net/main.ss +++ b/collects/tests/net/main.ss @@ -1,3 +1,19 @@ #lang scheme/base -(require "cgi.ss") +(require tests/eli-tester + (prefix-in ucodec: "uri-codec.ss") + (prefix-in url: "url.ss") + (prefix-in cgi: "cgi.ss") + (prefix-in head: "head.ss") + (prefix-in cookie: "cookie.ss") + (prefix-in encoders: "encoders.ss")) + +(define (tests) + (test do (begin (url:tests) + (ucodec:tests) + (cgi:tests) + (head:tests) + (cookie:tests) + (encoders:tests)))) + +(tests) diff --git a/collects/tests/net/uri-codec.ss b/collects/tests/net/uri-codec.ss new file mode 100644 index 0000000000..d53caa3ba5 --- /dev/null +++ b/collects/tests/net/uri-codec.ss @@ -0,0 +1,131 @@ +#lang scheme +(require net/uri-codec tests/eli-tester) + +(provide tests) +(define (tests) + (define sepmode current-alist-separator-mode) + (test (uri-decode "%Pq") => "%Pq" + (uri-decode "%P") => "%P" + + (alist->form-urlencoded '([a . "hel+lo \u7238"])) + => "a=hel%2Blo+%E7%88%B8" + (form-urlencoded->alist + (alist->form-urlencoded '([a . "hel+lo \u7238"]))) + => '([a . "hel+lo \u7238"]) + (alist->form-urlencoded '([a . "hel+lo"] [b . "good-bye"])) + => "a=hel%2Blo&b=good-bye" + + do (let ([alist '([a . "hel+lo"] [b . "good-bye"])] + [ampstr "a=hel%2Blo&b=good-bye"] + [semistr "a=hel%2Blo;b=good-bye"]) + (define (alist<->str mode str) + (parameterize ([sepmode (or mode (sepmode))]) + (test (alist->form-urlencoded alist) => str + (form-urlencoded->alist str) => alist))) + (alist<->str #f ampstr) ; test the default + (alist<->str 'amp ampstr) + (alist<->str 'amp-or-semi ampstr) + (alist<->str 'semi semistr) + (alist<->str 'semi-or-amp semistr)) + + (form-urlencoded->alist "x=foo&y=bar;z=baz") + => '([x . "foo"] [y . "bar"] [z . "baz"]) + (parameterize ([sepmode 'semi]) + (form-urlencoded->alist + (parameterize ([sepmode 'amp]) + (alist->form-urlencoded '([a . "hel+lo"] [b . "good-bye"]))))) + => '([a . "hel+lo&b=good-bye"]) + (parameterize ([sepmode 'amp]) + (form-urlencoded->alist + (parameterize ([sepmode 'semi]) + (alist->form-urlencoded '([a . "hel+lo"] [b . "good-bye"]))))) + => '([a . "hel+lo;b=good-bye"]) + + (alist->form-urlencoded '([aNt . "Hi"])) + => "aNt=Hi" + (form-urlencoded->alist (alist->form-urlencoded '([aNt . "Hi"]))) + => '([aNt . "Hi"]) + (alist->form-urlencoded (form-urlencoded->alist "aNt=Hi")) + => "aNt=Hi" + + (current-alist-separator-mode) => 'amp-or-semi + (current-alist-separator-mode 'bad) =error> "expected argument of type" + + ;; Test all ASCII chars + do + (let ([p (for/list ([n (in-range 128)]) + (let ([s (string (char-downcase (integer->char n)))]) + (cons (string->symbol s) s)))]) + (test (form-urlencoded->alist (alist->form-urlencoded p)) => p) + (let ([l (apply string-append (map cdr p))]) + (test (uri-decode (uri-encode l)) => l))) + + do (noels-tests) + + (uri-userinfo-encode "hello") => "hello" + (uri-userinfo-encode "hello there") => "hello%20there" + (uri-userinfo-encode "hello:there") => "hello:there" + (uri-userinfo-decode "hello") => "hello" + (uri-userinfo-decode "hello%20there") => "hello there" + (uri-userinfo-decode "hello:there") => "hello:there" + + )) + +;; tests adapted from Noel Welsh's original test suite +(define (noels-tests) + (define (pad2 str) + (if (= (string-length str) 1) (string-append "0" str) str)) + (define (%hex n) + (string-append "%" (pad2 (string-downcase (number->string n 16))))) + (define (%HEX n) + (string-append "%" (pad2 (string-upcase (number->string n 16))))) + (test + + (uri-encode "hello") => "hello" + (uri-encode "hello there") => "hello%20there" + + do + (for ([code (in-range 128)]) + (if (or (member code '(33 39 40 41 42 45 46 95 126)) + (<= 48 code 57) ; 0-9 + (<= 65 code 90) ; A-Z + (<= 97 code 122)) ; a-z + (test (uri-encode (string (integer->char code))) + => (string (integer->char code))) + (test (uri-encode (string (integer->char code))) + => (%HEX code)))) + + (alist->form-urlencoded '()) => "" + (alist->form-urlencoded '([key . "hello there"])) + => "key=hello+there" + (alist->form-urlencoded '([key1 . "hi"] [key2 . "hello"])) + => "key1=hi&key2=hello" + (alist->form-urlencoded '([key1 . "hello there"])) + => "key1=hello+there" + (uri-decode "hello") + => "hello" + (uri-decode "hello%20there") + => "hello there" + + ;; these were going from 0 to 255 in Noel's original test suite. + ;; Those fail here, however. + do (for ([code (in-range 128)]) + (test (uri-decode (%HEX code)) => (string (integer->char code)) + (uri-decode (%hex code)) => (string (integer->char code)) + (uri-decode (string (integer->char code))) + => (string (integer->char code)))) + + ;; form-urlencoded->alist + (form-urlencoded->alist "") => '() + (form-urlencoded->alist "key=value") + => '([key . "value"]) + (form-urlencoded->alist "key=hello+there") + => '([key . "hello there"]) + (form-urlencoded->alist "key=a%20value") + => '([key . "a value"]) + (form-urlencoded->alist "key") + => '([key . #f]) + (form-urlencoded->alist "key1=value+1&key2=value+2") + => '([key1 . "value 1"] [key2 . "value 2"]) + + )) diff --git a/collects/tests/net/url.ss b/collects/tests/net/url.ss new file mode 100644 index 0000000000..e6b52ef462 --- /dev/null +++ b/collects/tests/net/url.ss @@ -0,0 +1,357 @@ +#lang scheme +(require net/url tests/eli-tester + (only-in net/uri-codec current-alist-separator-mode)) + +(define (url->vec url) + (vector + (url-scheme url) + (url-user url) + (url-host url) + (url-port url) + (url-path-absolute? url) + (map (lambda (x) + (list->vector (cons (path/param-path x) (path/param-param x)))) + (url-path url)) + (url-query url) + (url-fragment url))) + +(define (vec->url vec) + (make-url + (vector-ref vec 0) + (vector-ref vec 1) + (vector-ref vec 2) + (vector-ref vec 3) + (vector-ref vec 4) + (map (lambda (x) + (let ([lst (vector->list x)]) + (make-path/param (car lst) (cdr lst)))) + (vector-ref vec 5)) + (vector-ref vec 6) + (vector-ref vec 7))) + +(define (string->url/vec str) (url->vec (string->url str))) +(define (url/vec->string vec) (url->string (vec->url vec))) + +(define (test-s->u vec str) + (test (string->url/vec str) => vec + (url/vec->string vec) => str)) + +(define (test-c-u/r expected base relative) + (define (combine-url/relative-vec x y) + (url->vec (combine-url/relative (vec->url x) y))) + (define (->vec x) (url->vec (if (string? x) (string->url x) x))) + (test (combine-url/relative-vec (->vec base) relative) + => (->vec expected))) + +(define (run-tests) + (test + ;; Test the current-proxy-servers parameter can be set + (parameterize ([current-proxy-servers '(("http" "proxy.com" 3128))]) + (current-proxy-servers)) + => '(("http" "proxy.com" 3128))) + + (test-s->u #(#f #f #f #f #t (#("")) () #f) + "/") + (test-s->u #(#f #f #f #f #f () () #f) + "") + + (test-s->u #("http" #f #f #f #t (#("")) () #f) + "http:/") + + (test-s->u #("http" #f "" #f #t (#("")) () #f) + "http:///") + + (test-s->u #("http" #f "www.drscheme.org" #f #f () () #f) + "http://www.drscheme.org") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("")) () #f) + "http://www.drscheme.org/") + + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) () #f) + "http://www.drscheme.org/a/b/c") + (test-s->u #("http" "robby" "www.drscheme.org" #f #t (#("a") #("b") #("c")) () #f) + "http://robby@www.drscheme.org/a/b/c") + (test-s->u #("http" #f "www.drscheme.org" 8080 #t (#("a") #("b") #("c")) () #f) + "http://www.drscheme.org:8080/a/b/c") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) () "joe") + "http://www.drscheme.org/a/b/c#joe") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "")) #f) + "http://www.drscheme.org/a/b/c?tim=") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "")) "joe") + "http://www.drscheme.org/a/b/c?tim=#joe") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "tim")) "joe") + "http://www.drscheme.org/a/b/c?tim=tim#joe") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom")) "joe") + "http://www.drscheme.org/a/b/c?tam=tom#joe") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") + "http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe") + (parameterize ([current-alist-separator-mode 'semi]) + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") + "http://www.drscheme.org/a/b/c?tam=tom;pam=pom#joe")) + (parameterize ([current-alist-separator-mode 'amp]) + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") + "http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe")) + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c" "b")) () #f) + "http://www.drscheme.org/a/b/c;b") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a" "x") #("b") #("c" "b")) () #f) + "http://www.drscheme.org/a;x/b/c;b") + + ;; test unquoting for % + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((ti#m . "")) "jo e") + "http://www.drscheme.org/a/b/c?ti%23m=#jo%20e") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a " " a") #(" b ") #(" c ")) () #f) + "http://www.drscheme.org/a%20;%20a/%20b%20/%20c%20") + (test-s->u #("http" "robb y" "www.drscheme.org" #f #t (#("")) () #f) + "http://robb%20y@www.drscheme.org/") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("%a") #("b/") #("c")) () #f) + "http://www.drscheme.org/%25a/b%2F/c") + (test-s->u #("http" "robby:password" "www.drscheme.org" #f #t (#("")) () #f) + "http://robby:password@www.drscheme.org/") + (test "robby:password" (lambda (x) (url-user (string->url x))) "http://robby%3apassword@www.drscheme.org/") + + ;; test the characters that need to be encoded in paths vs those that do not need to + ;; be encoded in paths + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a:@!$&'()*+,=z") #("/?#[];") #("")) () #f) + "http://www.drscheme.org/a:@!$&'()*+,=z/%2F%3F%23%5B%5D%3B/") + + (test-s->u #("http" #f "www.drscheme.org" #f #t (#(".") #("..") #(same) #(up) #("...") #("abc.def")) () #f) + "http://www.drscheme.org/%2e/%2e%2e/./../.../abc.def") + (test-s->u #("http" #f "www.drscheme.org" #f #t (#("." "") #(".." "") #(same "") #(up "") #("..." "") #("abc.def" "")) () #f) + "http://www.drscheme.org/%2e;/%2e%2e;/.;/..;/...;/abc.def;") + + ;; test other scheme identifiers + (test-s->u #("blah" #f "www.foo.com" #f #t (#("")) () #f) + "blah://www.foo.com/") + (test-s->u #("blah99" #f "www.foo.com" #f #t (#("")) () #f) + "blah99://www.foo.com/") + (test-s->u #("blah+" #f "www.foo.com" #f #t (#("")) () #f) + "blah+://www.foo.com/") + (test-s->u #("a+b-c456.d" #f "www.foo.com" #f #t (#("")) () #f) + "a+b-c456.d://www.foo.com/") + + ;; a colon and other junk (`sub-delims') can appear in usernames + (test #("http" "x:!$&'()*+,;=y" "www.drscheme.org" #f #t (#("a")) () #f) + string->url/vec + "http://x:!$&'()*+,;=y@www.drscheme.org/a") + ;; a colon and atsign can appear in absolute paths + (test-s->u #(#f #f #f #f #t (#("x:@y") #("z")) () #f) + "/x:@y/z") + ;; and in relative paths as long as it's not in the first element + (test-s->u #(#f #f #f #f #f (#("x") #("y:@z")) () #f) + "x/y:@z") + + ;; test bad schemes + (test + (string->url "://www.foo.com/") =error> url-exception? + (string->url "9://www.foo.com/") =error> url-exception? + (string->url "9a://www.foo.com/") =error> url-exception? + (string->url "a*b://www.foo.com/") =error> url-exception? + (string->url "a b://www.foo.com/") =error> url-exception?) + + ;; test file: urls + (test-s->u #("file" #f "" #f #t (#("abc") #("def.html")) () #f) + "file:///abc/def.html") + (test (url->string (string->url "file:///abc/def.html")) + => "file:///abc/def.html") + (parameterize ([file-url-path-convention-type 'unix]) + (test (url->string (string->url "file://a/b")) + => "file://a/b") + (test-s->u #("file" #f "localhost" #f #t (#("abc") #("def.html")) () #f) + "file://localhost/abc/def.html")) + + ;; test files: urls with colons, and the different parsing on Windows + (test-s->u #("file" #f "localhost" 123 #t (#("abc") #("def.html")) () #f) + "file://localhost:123/abc/def.html") + (parameterize ([file-url-path-convention-type 'unix]) + ;; different parse for file://foo:/... + (test (string->url/vec "file://foo:/abc/def.html") + => #("file" #f "foo" #f #t (#("abc") #("def.html")) () #f))) + (parameterize ([file-url-path-convention-type 'windows]) + (test (string->url/vec "file://foo:/abc/def.html") + => #("file" #f "" #f #t (#("foo:") #("abc") #("def.html")) () #f) + (string->url/vec "file://c:/abc/def.html") + => #("file" #f "" #f #t (#("c:") #("abc") #("def.html")) () #f) + (string->url/vec "file:\\\\d\\c\\abc\\def.html") + => #("file" #f "" #f #t (#("") #("d") #("c") #("abc") #("def.html")) () #f))) + + (parameterize ([file-url-path-convention-type 'unix]) + ;; but no effect on http://foo:/... + (test (string->url/vec "http://foo:/abc/def.html") + => #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f))) + (parameterize ([file-url-path-convention-type 'windows]) + (test (string->url/vec "http://foo:/abc/def.html") + => #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f))) + + (test (url->string (path->url (bytes->path #"c:\\a\\b" 'windows))) + => "file:///c:/a/b" + (url->string (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows))) + => "file:///c:/a/b") + + (test + (path->bytes (url->path (path->url (bytes->path #"/a/b/c" 'unix)) 'unix)) + => #"/a/b/c" + (path->bytes (url->path (path->url (bytes->path #"a/b/c" 'unix)) 'unix)) + => #"a/b/c" + (path->bytes (url->path (path->url (bytes->path #"c:/a/b" 'windows)) 'windows)) + => #"c:\\a\\b" + (path->bytes (url->path (path->url (bytes->path #"a/b" 'windows)) 'windows)) + => #"a\\b" + (path->bytes (url->path (path->url (bytes->path #"//d/c/a" 'windows)) 'windows)) + => #"\\\\d\\c\\a" + (path->bytes (url->path (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows)) 'windows)) + => #"c:\\a\\b" + (path->bytes (url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\c\\a\\b" 'windows)) 'windows)) + => #"\\\\d\\c\\a\\b" + (path->bytes (url->path (path->url (bytes->path #"\\\\?\\c:\\a/x\\b" 'windows)) 'windows)) + => #"\\\\?\\c:\\a/x\\b" + (path->bytes (url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\\\c\\a/x\\b" 'windows)) 'windows)) + => #"\\\\?\\UNC\\d\\c\\a/x\\b") + + ;; see PR8809 (value-less keys in the query part) + (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f)) #f) + "http://foo.bar/baz?ugh") + (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . "")) #f) + "http://foo.bar/baz?ugh=") + (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f) + "http://foo.bar/baz?ugh&x=y&1=2") + (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . "") (x . "y") (|1| . "2")) #f) + "http://foo.bar/baz?ugh=&x=y&1=2") + + (parameterize ([current-alist-separator-mode 'amp]) + (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f) + "http://foo.bar/baz?ugh&x=y&1=2")) + (parameterize ([current-alist-separator-mode 'semi]) + (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f) + "http://foo.bar/baz?ugh;x=y;1=2")) + + ;; test case sensitivity + (test (string->url/vec + "HTTP://ROBBY@WWW.DRSCHEME.ORG:80/INDEX.HTML;XXX?T=P#YYY") + => #("http" "ROBBY" "www.drscheme.org" 80 #t (#("INDEX.HTML" "XXX")) ((T . "P")) "YYY")) + + (test-s->u #("mailto" #f #f #f #f (#("robby@plt-scheme.org")) () #f) + "mailto:robby@plt-scheme.org") + + (test (string->url/vec "http://www.drscheme.org?bar=馨慧") + #("http" #f "www.drscheme.org" #f #f () ((bar . "馨慧")) #f)) + + (test (string->url/vec "http://www.drscheme.org?bár=é") + => #("http" #f "www.drscheme.org" #f #f () ((bár . "é")) #f)) + + (test-c-u/r "http://www.drscheme.org" + (make-url #f #f #f #f #f '() '() #f) + "http://www.drscheme.org") + + (test-c-u/r "http://www.drscheme.org" + "http://www.drscheme.org" + "") + + (test-c-u/r "http://www.mzscheme.org" + "http://www.drscheme.org/" + "http://www.mzscheme.org") + + (test-c-u/r "http://www.drscheme.org/index.html" + "http://www.drscheme.org/" + "index.html") + (test-c-u/r "http://www.drscheme.org/index.html" + "http://www.drscheme.org/" + "/index.html") + (test-c-u/r "http://www.drscheme.org/index.html" + "http://www.drscheme.org/a/b/c/" + "/index.html") + (test-c-u/r "http://www.drscheme.org/a/b/index.html" + "http://www.drscheme.org/a/b/c" + "index.html") + (test-c-u/r "http://www.drscheme.org/a/b/c/index.html" + "http://www.drscheme.org/a/b/c/" + "index.html") + (test-c-u/r "http://www.drscheme.org/a/b/d/index.html" + "http://www.drscheme.org/a/b/c" + "d/index.html") + (test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html" + "http://www.drscheme.org/a/b/c/" + "d/index.html") + (test-c-u/r "http://www.drscheme.org/a/b/index.html" + "http://www.drscheme.org/a/b/c/" + "../index.html") + (test-c-u/r "http://www.drscheme.org/a/b/c/index.html" + "http://www.drscheme.org/a/b/c/" + "./index.html") + (test-c-u/r "http://www.drscheme.org/a/b/c/%2e%2e/index.html" + "http://www.drscheme.org/a/b/c/" + "%2e%2e/index.html") + (test-c-u/r "http://www.drscheme.org/a/index.html" + "http://www.drscheme.org/a/b/../c/" + "../index.html") + + (test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html" + "http://www.drscheme.org/a/b/c/d/index.html#ghijkl" + "index.html") + (test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html#abcdef" + "http://www.drscheme.org/a/b/c/d/index.html#ghijkl" + "#abcdef") + + (test-c-u/r "file:///a/b/c/d/index.html" + "file:///a/b/c/" + "d/index.html") + (test-c-u/r "file:///a/b/d/index.html" + "file:///a/b/c" + "d/index.html") + + ;; tests from rfc 3986 + (for-each + (λ (line) (test-c-u/r (caddr line) "http://a/b/c/d;p?q" (car line))) + '(("g:h" = "g:h") + ("g" = "http://a/b/c/g") + ("./g" = "http://a/b/c/g") + ("g/" = "http://a/b/c/g/") + ("/g" = "http://a/g") + ("//g" = "http://g") + ("?y" = "http://a/b/c/d;p?y") + ("g?y" = "http://a/b/c/g?y") + ("#s" = "http://a/b/c/d;p?q#s") + ("g#s" = "http://a/b/c/g#s") + ("g?y#s" = "http://a/b/c/g?y#s") + (";x" = "http://a/b/c/;x") + ("g;x" = "http://a/b/c/g;x") + ("g;x?y#s" = "http://a/b/c/g;x?y#s") + ("" = "http://a/b/c/d;p?q") + ("." = "http://a/b/c/") + ("./" = "http://a/b/c/") + (".." = "http://a/b/") + ("../" = "http://a/b/") + ("../g" = "http://a/b/g") + ("../.." = "http://a/") + ("../../" = "http://a/") + ("../../g" = "http://a/g") + + ;; abnormal examples follow + + ("../../../g" = "http://a/g") + ("../../../../g" = "http://a/g") + + ("/./g" = "http://a/g") + ("/../g" = "http://a/g") + ("g." = "http://a/b/c/g.") + (".g" = "http://a/b/c/.g") + ("g.." = "http://a/b/c/g..") + ("..g" = "http://a/b/c/..g") + + ("./../g" = "http://a/b/g") + ("./g/." = "http://a/b/c/g/") + ("g/./h" = "http://a/b/c/g/h") + ("g/../h" = "http://a/b/c/h") + ("g;x=1/./y" = "http://a/b/c/g;x=1/y") + ("g;x=1/../y" = "http://a/b/c/y") + + ("g?y/./x" = "http://a/b/c/g?y/./x") + ("g?y/../x" = "http://a/b/c/g?y/../x") + ("g#s/./x" = "http://a/b/c/g#s/./x") + ("g#s/../x" = "http://a/b/c/g#s/../x") + ("http:g" = "http:g") ; for strict parsers + + )) + + ) + +(provide tests) +(define (tests) (test do (run-tests))) From 5d6b74d3b69cab982c1b13fb42febdb88fc72ae4 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 17 Mar 2009 11:42:31 +0000 Subject: [PATCH 055/140] remove old net tests svn: r14144 --- collects/tests/mzscheme/all.ss | 1 - collects/tests/mzscheme/net.ss | 762 --------------------------------- 2 files changed, 763 deletions(-) diff --git a/collects/tests/mzscheme/all.ss b/collects/tests/mzscheme/all.ss index b2a713926b..b85c0a48de 100644 --- a/collects/tests/mzscheme/all.ss +++ b/collects/tests/mzscheme/all.ss @@ -5,6 +5,5 @@ (load-relative "mzlib-tests.ss") (load-relative "syntax-tests.ss") (load-in-sandbox "version.ss") -(load-in-sandbox "net.ss") (load-in-sandbox "foreign-test.ss") (load-in-sandbox "uni-norm.ss") diff --git a/collects/tests/mzscheme/net.ss b/collects/tests/mzscheme/net.ss index 7b72211105..5d804c56e0 100644 --- a/collects/tests/mzscheme/net.ss +++ b/collects/tests/mzscheme/net.ss @@ -3,657 +3,6 @@ (Section 'net) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; url.ss tests -;; - -(require net/url - net/uri-codec - mzlib/string - ) - -(test "%Pq" uri-decode "%Pq") -(test "%P" uri-decode "%P") -(test "a=hel%2Blo+%E7%88%B8" alist->form-urlencoded '((a . "hel+lo \u7238"))) -(test '((a . "hel+lo \u7238")) form-urlencoded->alist (alist->form-urlencoded '((a . "hel+lo \u7238")))) -(test "a=hel%2Blo&b=good-bye" alist->form-urlencoded '((a . "hel+lo") (b . "good-bye"))) -(let* ([alist '((a . "hel+lo") (b . "good-bye"))] - [ampstr "a=hel%2Blo&b=good-bye"] - [semistr "a=hel%2Blo;b=good-bye"]) - (define (test:alist<->str mode str) - (parameterize ([current-alist-separator-mode - (or mode (current-alist-separator-mode))]) - (test str alist->form-urlencoded alist) - (test alist form-urlencoded->alist str))) - (test:alist<->str #f ampstr) ; the default - (test:alist<->str 'amp ampstr) - (test:alist<->str 'amp-or-semi ampstr) - (test:alist<->str 'semi semistr) - (test:alist<->str 'semi-or-amp semistr)) -(test '((x . "foo") (y . "bar") (z . "baz")) - form-urlencoded->alist "x=foo&y=bar;z=baz") -(parameterize ([current-alist-separator-mode 'semi]) - (test '((a . "hel+lo&b=good-bye")) form-urlencoded->alist - (parameterize ([current-alist-separator-mode 'amp]) - (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))))) -(parameterize ([current-alist-separator-mode 'amp]) - (test '((a . "hel+lo;b=good-bye")) form-urlencoded->alist - (parameterize ([current-alist-separator-mode 'semi]) - (alist->form-urlencoded '((a . "hel+lo") (b . "good-bye")))))) -(test "aNt=Hi" alist->form-urlencoded '((aNt . "Hi"))) -(test '((aNt . "Hi")) form-urlencoded->alist (alist->form-urlencoded '((aNt . "Hi")))) -(test "aNt=Hi" alist->form-urlencoded (form-urlencoded->alist "aNt=Hi")) - -(test 'amp-or-semi current-alist-separator-mode) -(err/rt-test (current-alist-separator-mode 'bad)) - -;; Test the current-proxy-servers parameter can be set -(parameterize ([current-proxy-servers '(("http" "proxy.com" 3128))]) - (test '(("http" "proxy.com" 3128)) current-proxy-servers)) - -(let ([with-censor (load-relative "censor.ss")]) - (with-censor - (lambda () - ;; Test all ASCII chars - (let ([p (let loop ([n 0]) - (if (= n 128) - null - (let ([s (string (char-downcase (integer->char n)))]) - (cons (cons (string->symbol s) s) - (loop (add1 n))))))]) - (test p form-urlencoded->alist (alist->form-urlencoded p)) - (let ([l (apply string-append (map cdr p))]) - (test l uri-decode (uri-encode l))))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; tests adapted from Noel Welsh's original test suite -;; - -(let () - (define-syntax (for stx) - (syntax-case stx (code) - [(_ (i from to) e) - (and (identifier? (syntax code)) - (number? (syntax-e (syntax from))) - (number? (syntax-e (syntax to)))) - (syntax (let loop ([i from]) - e - (unless (= i to) - (loop (+ i 1)))))])) - - (test "hello" uri-encode "hello") - (test "hello%20there" uri-encode "hello there") - - (let ((pad (lambda (str) - (if (= (string-length str) 1) - (string-append "0" str) - str)))) - (for (code 0 127) - (if (or (= code 45) (= code 33) (= code 95) - (= code 46) (= code 126) (= code 42) - (= code 39) (= code 40) (= code 41) - (and (<= 48 code) (<= code 57)) ; 0-9 - (and (<= 65 code) (<= code 90)) ; A-Z - (and (<= 97 code) (<= code 122))) ; a-z - (test (string (integer->char code)) uri-encode (string (integer->char code))) - (test (string-append "%" (pad (string-upcase (number->string code 16)))) - uri-encode - (string (integer->char code)))))) - - (test "" alist->form-urlencoded '()) - (test "key=hello+there" alist->form-urlencoded '((key . "hello there"))) - (test "key1=hi&key2=hello" alist->form-urlencoded '((key1 . "hi") (key2 . "hello"))) - (test "key1=hello+there" alist->form-urlencoded '((key1 . "hello there"))) - - (test "hello" uri-decode "hello") - (test "hello there" uri-decode "hello%20there") - - (let* ((pad (lambda (str) - (if (= (string-length str) 1) - (string-append "0" str) - str))) - (uppercase (lambda (str) - (string-uppercase! str) - str)) - (lowercase (lambda (str) - (string-lowercase! str) - str)) - (hexcode (lambda (code) - (string-append "%" - (pad (number->string code 16)))))) - - ;; each of the next three of these were going from 0 to 255 in Noel's - ;; original test suite. Those fail here, however. - - (for (code 0 127) - (test (string (integer->char code)) uri-decode (uppercase (hexcode code)))) - (for (code 0 127) - (test (string (integer->char code)) uri-decode (lowercase (hexcode code))))) - - (for (code 0 127) - (test (string (integer->char code)) uri-decode (string (integer->char code)))) - - ;; form-urlencoded->alist - (test '() form-urlencoded->alist "") - (test '((key . "value")) form-urlencoded->alist "key=value") - (test '((key . "hello there")) form-urlencoded->alist "key=hello+there") - (test '((key . "a value")) form-urlencoded->alist "key=a%20value") - (test '((key . #f)) form-urlencoded->alist "key") - (test '((key1 . "value 1") (key2 . "value 2")) form-urlencoded->alist "key1=value+1&key2=value+2")) - -;; -;; end Noel's original tests -;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(test "hello" uri-userinfo-encode "hello") -(test "hello%20there" uri-userinfo-encode "hello there") -(test "hello:there" uri-userinfo-encode "hello:there") -(test "hello" uri-userinfo-decode "hello") -(test "hello there" uri-userinfo-decode "hello%20there") -(test "hello:there" uri-userinfo-decode "hello:there") - - -(let () - (define (test-s->u vec str) - (test vec string->url/vec str) - (test str url/vec->string vec)) - - (define (string->url/vec str) (url->vec (string->url str))) - (define (url/vec->string vec) (url->string (vec->url vec))) - - (define (test-c-u/r expected base relative) - (define (combine-url/relative-vec x y) - (url->vec (combine-url/relative (vec->url x) y))) - (define (->vec x) (url->vec (if (string? x) (string->url x) x))) - (test (->vec expected) combine-url/relative-vec (->vec base) relative)) - - (define (vec->url vec) - (make-url (vector-ref vec 0) - (vector-ref vec 1) - (vector-ref vec 2) - (vector-ref vec 3) - (vector-ref vec 4) - (map (lambda (x) - (let ([lst (vector->list x)]) - (make-path/param (car lst) (cdr lst)))) - (vector-ref vec 5)) - (vector-ref vec 6) - (vector-ref vec 7))) - - (define (url->vec url) - (vector (url-scheme url) - (url-user url) - (url-host url) - (url-port url) - (url-path-absolute? url) - (map (lambda (x) (list->vector (cons (path/param-path x) (path/param-param x)))) - (url-path url)) - (url-query url) - (url-fragment url))) - - (test-s->u #(#f #f #f #f #t (#("")) () #f) - "/") - (test-s->u #(#f #f #f #f #f () () #f) - "") - (test-s->u #("http" #f #f #f #t (#("")) () #f) - "http:/") - - (test-s->u #("http" #f "" #f #t (#("")) () #f) - "http:///") - - (test-s->u #("http" #f "www.drscheme.org" #f #f () () #f) - "http://www.drscheme.org") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("")) () #f) - "http://www.drscheme.org/") - - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) () #f) - "http://www.drscheme.org/a/b/c") - (test-s->u #("http" "robby" "www.drscheme.org" #f #t (#("a") #("b") #("c")) () #f) - "http://robby@www.drscheme.org/a/b/c") - (test-s->u #("http" #f "www.drscheme.org" 8080 #t (#("a") #("b") #("c")) () #f) - "http://www.drscheme.org:8080/a/b/c") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) () "joe") - "http://www.drscheme.org/a/b/c#joe") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "")) #f) - "http://www.drscheme.org/a/b/c?tim=") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "")) "joe") - "http://www.drscheme.org/a/b/c?tim=#joe") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tim . "tim")) "joe") - "http://www.drscheme.org/a/b/c?tim=tim#joe") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom")) "joe") - "http://www.drscheme.org/a/b/c?tam=tom#joe") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") - "http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe") - (parameterize ([current-alist-separator-mode 'semi]) - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") - "http://www.drscheme.org/a/b/c?tam=tom;pam=pom#joe")) - (parameterize ([current-alist-separator-mode 'amp]) - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((tam . "tom") (pam . "pom")) "joe") - "http://www.drscheme.org/a/b/c?tam=tom&pam=pom#joe")) - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c" "b")) () #f) - "http://www.drscheme.org/a/b/c;b") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a" "x") #("b") #("c" "b")) () #f) - "http://www.drscheme.org/a;x/b/c;b") - - ;; test unquoting for % - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a") #("b") #("c")) ((ti#m . "")) "jo e") - "http://www.drscheme.org/a/b/c?ti%23m=#jo%20e") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a " " a") #(" b ") #(" c ")) () #f) - "http://www.drscheme.org/a%20;%20a/%20b%20/%20c%20") - (test-s->u #("http" "robb y" "www.drscheme.org" #f #t (#("")) () #f) - "http://robb%20y@www.drscheme.org/") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("%a") #("b/") #("c")) () #f) - "http://www.drscheme.org/%25a/b%2F/c") - (test-s->u #("http" "robby:password" "www.drscheme.org" #f #t (#("")) () #f) - "http://robby:password@www.drscheme.org/") - (test "robby:password" (lambda (x) (url-user (string->url x))) "http://robby%3apassword@www.drscheme.org/") - - ;; test the characters that need to be encoded in paths vs those that do not need to - ;; be encoded in paths - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("a:@!$&'()*+,=z") #("/?#[];") #("")) () #f) - "http://www.drscheme.org/a:@!$&'()*+,=z/%2F%3F%23%5B%5D%3B/") - - (test-s->u #("http" #f "www.drscheme.org" #f #t (#(".") #("..") #(same) #(up) #("...") #("abc.def")) () #f) - "http://www.drscheme.org/%2e/%2e%2e/./../.../abc.def") - (test-s->u #("http" #f "www.drscheme.org" #f #t (#("." "") #(".." "") #(same "") #(up "") #("..." "") #("abc.def" "")) () #f) - "http://www.drscheme.org/%2e;/%2e%2e;/.;/..;/...;/abc.def;") - - ;; test other scheme identifiers - (test-s->u #("blah" #f "www.foo.com" #f #t (#("")) () #f) - "blah://www.foo.com/") - (test-s->u #("blah99" #f "www.foo.com" #f #t (#("")) () #f) - "blah99://www.foo.com/") - (test-s->u #("blah+" #f "www.foo.com" #f #t (#("")) () #f) - "blah+://www.foo.com/") - (test-s->u #("a+b-c456.d" #f "www.foo.com" #f #t (#("")) () #f) - "a+b-c456.d://www.foo.com/") - - ;; a colon and other junk (`sub-delims') can appear in usernames - (test #("http" "x:!$&'()*+,;=y" "www.drscheme.org" #f #t (#("a")) () #f) - string->url/vec - "http://x:!$&'()*+,;=y@www.drscheme.org/a") - ;; a colon and atsign can appear in absolute paths - (test-s->u #(#f #f #f #f #t (#("x:@y") #("z")) () #f) - "/x:@y/z") - ;; and in relative paths as long as it's not in the first element - (test-s->u #(#f #f #f #f #f (#("x") #("y:@z")) () #f) - "x/y:@z") - - ;; test bad schemes - (err/rt-test (string->url "://www.foo.com/") url-exception?) - (err/rt-test (string->url "9://www.foo.com/") url-exception?) - (err/rt-test (string->url "9a://www.foo.com/") url-exception?) - (err/rt-test (string->url "a*b://www.foo.com/") url-exception?) - (err/rt-test (string->url "a b://www.foo.com/") url-exception?) - - ;; test file: urls - (test-s->u #("file" #f "" #f #t (#("abc") #("def.html")) () #f) - "file:///abc/def.html") - (test "file:///abc/def.html" url->string (string->url "file:///abc/def.html")) - (parameterize ([file-url-path-convention-type 'unix]) - (test "file://a/b" url->string (string->url "file://a/b"))) - - (parameterize ([file-url-path-convention-type 'unix]) - (test-s->u #("file" #f "localhost" #f #t (#("abc") #("def.html")) () #f) - "file://localhost/abc/def.html")) - - ;; test files: urls with colons, and the different parsing on Windows - (test-s->u #("file" #f "localhost" 123 #t (#("abc") #("def.html")) () #f) - "file://localhost:123/abc/def.html") - (parameterize ([file-url-path-convention-type 'unix]) - ;; different parse for file://foo:/... - (test #("file" #f "foo" #f #t (#("abc") #("def.html")) () #f) - string->url/vec - "file://foo:/abc/def.html")) - (parameterize ([file-url-path-convention-type 'windows]) - (test #("file" #f "" #f #t (#("foo:") #("abc") #("def.html")) () #f) - string->url/vec - "file://foo:/abc/def.html") - (test #("file" #f "" #f #t (#("c:") #("abc") #("def.html")) () #f) - string->url/vec - "file://c:/abc/def.html") - (test #("file" #f "" #f #t (#("") #("d") #("c") #("abc") #("def.html")) () #f) - string->url/vec - "file:\\\\d\\c\\abc\\def.html")) - - (parameterize ([file-url-path-convention-type 'unix]) - ;; but no effect on http://foo:/... - (test #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f) - string->url/vec - "http://foo:/abc/def.html")) - (parameterize ([file-url-path-convention-type 'windows]) - (test #("http" #f "foo" #f #t (#("abc") #("def.html")) () #f) - string->url/vec - "http://foo:/abc/def.html")) - - (test "file:///c:/a/b" - url->string (path->url (bytes->path #"c:\\a\\b" 'windows))) - (test "file:///c:/a/b" - url->string (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows))) - - (test #"/a/b/c" path->bytes - (url->path (path->url (bytes->path #"/a/b/c" 'unix)) 'unix)) - (test #"a/b/c" path->bytes - (url->path (path->url (bytes->path #"a/b/c" 'unix)) 'unix)) - (test #"c:\\a\\b" path->bytes - (url->path (path->url (bytes->path #"c:/a/b" 'windows)) 'windows)) - (test #"a\\b" path->bytes - (url->path (path->url (bytes->path #"a/b" 'windows)) 'windows)) - (test #"\\\\d\\c\\a" path->bytes - (url->path (path->url (bytes->path #"//d/c/a" 'windows)) 'windows)) - (test #"c:\\a\\b" path->bytes - (url->path (path->url (bytes->path #"\\\\?\\c:\\a\\b" 'windows)) 'windows)) - (test #"\\\\d\\c\\a\\b" path->bytes - (url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\c\\a\\b" 'windows)) 'windows)) - (test #"\\\\?\\c:\\a/x\\b" path->bytes - (url->path (path->url (bytes->path #"\\\\?\\c:\\a/x\\b" 'windows)) 'windows)) - (test #"\\\\?\\UNC\\d\\c\\a/x\\b" path->bytes - (url->path (path->url (bytes->path #"\\\\?\\UNC\\d\\\\c\\a/x\\b" 'windows)) 'windows)) - - ;; see PR8809 (value-less keys in the query part) - (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f)) #f) - "http://foo.bar/baz?ugh") - (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . "")) #f) - "http://foo.bar/baz?ugh=") - (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f) - "http://foo.bar/baz?ugh&x=y&1=2") - (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . "") (x . "y") (|1| . "2")) #f) - "http://foo.bar/baz?ugh=&x=y&1=2") - (parameterize ([current-alist-separator-mode 'amp]) - (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f) - "http://foo.bar/baz?ugh&x=y&1=2")) - (parameterize ([current-alist-separator-mode 'semi]) - (test-s->u #("http" #f "foo.bar" #f #t (#("baz")) ((ugh . #f) (x . "y") (|1| . "2")) #f) - "http://foo.bar/baz?ugh;x=y;1=2")) - - ;; test case sensitivity - (test #("http" "ROBBY" "www.drscheme.org" 80 #t (#("INDEX.HTML" "XXX")) ((T . "P")) "YYY") - string->url/vec - "HTTP://ROBBY@WWW.DRSCHEME.ORG:80/INDEX.HTML;XXX?T=P#YYY") - - (test-s->u #("mailto" #f #f #f #f (#("robby@plt-scheme.org")) () #f) - "mailto:robby@plt-scheme.org") - - (test #("http" #f "www.drscheme.org" #f #f () ((bar . "馨慧")) #f) - string->url/vec - "http://www.drscheme.org?bar=馨慧") - - (test #("http" #f "www.drscheme.org" #f #f () ((bár . "é")) #f) - string->url/vec - "http://www.drscheme.org?bár=é") - - (test-c-u/r "http://www.drscheme.org" - (make-url #f #f #f #f #f '() '() #f) - "http://www.drscheme.org") - - (test-c-u/r "http://www.drscheme.org" - "http://www.drscheme.org" - "") - - (test-c-u/r "http://www.mzscheme.org" - "http://www.drscheme.org/" - "http://www.mzscheme.org") - - (test-c-u/r "http://www.drscheme.org/index.html" - "http://www.drscheme.org/" - "index.html") - (test-c-u/r "http://www.drscheme.org/index.html" - "http://www.drscheme.org/" - "/index.html") - (test-c-u/r "http://www.drscheme.org/index.html" - "http://www.drscheme.org/a/b/c/" - "/index.html") - (test-c-u/r "http://www.drscheme.org/a/b/index.html" - "http://www.drscheme.org/a/b/c" - "index.html") - (test-c-u/r "http://www.drscheme.org/a/b/c/index.html" - "http://www.drscheme.org/a/b/c/" - "index.html") - (test-c-u/r "http://www.drscheme.org/a/b/d/index.html" - "http://www.drscheme.org/a/b/c" - "d/index.html") - (test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html" - "http://www.drscheme.org/a/b/c/" - "d/index.html") - (test-c-u/r "http://www.drscheme.org/a/b/index.html" - "http://www.drscheme.org/a/b/c/" - "../index.html") - (test-c-u/r "http://www.drscheme.org/a/b/c/index.html" - "http://www.drscheme.org/a/b/c/" - "./index.html") - (test-c-u/r "http://www.drscheme.org/a/b/c/%2e%2e/index.html" - "http://www.drscheme.org/a/b/c/" - "%2e%2e/index.html") - (test-c-u/r "http://www.drscheme.org/a/index.html" - "http://www.drscheme.org/a/b/../c/" - "../index.html") - - (test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html" - "http://www.drscheme.org/a/b/c/d/index.html#ghijkl" - "index.html") - (test-c-u/r "http://www.drscheme.org/a/b/c/d/index.html#abcdef" - "http://www.drscheme.org/a/b/c/d/index.html#ghijkl" - "#abcdef") - - (test-c-u/r "file:///a/b/c/d/index.html" - "file:///a/b/c/" - "d/index.html") - (test-c-u/r "file:///a/b/d/index.html" - "file:///a/b/c" - "d/index.html") - - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - ;; - ;; tests from rfc 3986 - ;; - - (for-each - (λ (line) (test-c-u/r (caddr line) "http://a/b/c/d;p?q" (car line))) - '(("g:h" = "g:h") - ("g" = "http://a/b/c/g") - ("./g" = "http://a/b/c/g") - ("g/" = "http://a/b/c/g/") - ("/g" = "http://a/g") - ("//g" = "http://g") - ("?y" = "http://a/b/c/d;p?y") - ("g?y" = "http://a/b/c/g?y") - ("#s" = "http://a/b/c/d;p?q#s") - ("g#s" = "http://a/b/c/g#s") - ("g?y#s" = "http://a/b/c/g?y#s") - (";x" = "http://a/b/c/;x") - ("g;x" = "http://a/b/c/g;x") - ("g;x?y#s" = "http://a/b/c/g;x?y#s") - ("" = "http://a/b/c/d;p?q") - ("." = "http://a/b/c/") - ("./" = "http://a/b/c/") - (".." = "http://a/b/") - ("../" = "http://a/b/") - ("../g" = "http://a/b/g") - ("../.." = "http://a/") - ("../../" = "http://a/") - ("../../g" = "http://a/g") - - ;; abnormal examples follow - - ("../../../g" = "http://a/g") - ("../../../../g" = "http://a/g") - - ("/./g" = "http://a/g") - ("/../g" = "http://a/g") - ("g." = "http://a/b/c/g.") - (".g" = "http://a/b/c/.g") - ("g.." = "http://a/b/c/g..") - ("..g" = "http://a/b/c/..g") - - ("./../g" = "http://a/b/g") - ("./g/." = "http://a/b/c/g/") - ("g/./h" = "http://a/b/c/g/h") - ("g/../h" = "http://a/b/c/h") - ("g;x=1/./y" = "http://a/b/c/g;x=1/y") - ("g;x=1/../y" = "http://a/b/c/y") - - ("g?y/./x" = "http://a/b/c/g?y/./x") - ("g?y/../x" = "http://a/b/c/g?y/../x") - ("g#s/./x" = "http://a/b/c/g#s/./x") - ("g#s/../x" = "http://a/b/c/g#s/../x") - ("http:g" = "http:g") ; for strict parsers - - )) - - ) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; a few tests of head.ss -- JBC, 2006-07-31 -;; - -(require net/head) - -(test (void) validate-header "From: me@here.net\r\n\r\n") -(test (void) validate-header #"From: me@here.net\r\n\r\n") -(test (void) validate-header "From: a\r\nTo: b\r\nResent-to: qrv@erocg\r\n\r\n") -(test (void) validate-header #"From: a\r\nTo: b\r\nResent-to: qrv@erocg\r\n\r\n") -(err/rt-test (validate-header "From: a\r\nTo: b\r\nMissingTrailingrn: qrv@erocg\r\n") exn:fail?) -(err/rt-test (validate-header #"From: a\r\nTo: b\r\nMissingTrailingrn: qrv@erocg\r\n") exn:fail?) -(err/rt-test (validate-header "From: a\r\nnocolon inthisline\r\n\r\n") exn:fail?) -(err/rt-test (validate-header #"From: a\r\nnocolon inthisline\r\n\r\n") exn:fail?) -(err/rt-test (validate-header "From: a\r\nMissingReturn: och\n\r\n" exn:fail?)) -(err/rt-test (validate-header #"From: a\r\nMissingReturn: och\n\r\n" exn:fail?)) -(err/rt-test (validate-header "From: a\r\nSpacein Fieldname: och\r\n\r\n" exn:fail?)) -(err/rt-test (validate-header #"From: a\r\nSpacein Fieldname: och\r\n\r\n" exn:fail?)) - -(define test-header "From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n") -(define test-header/bytes #"From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n") - -(test "abc" extract-field "From" test-header) -(test #"abc" extract-field #"From" test-header/bytes) -(test "field is\r\n continued" extract-field "To" test-header) -(test #"field is\r\n continued" extract-field #"To" test-header/bytes) -(test "zoo\r\n continued" extract-field "Another" test-header) -(test #"zoo\r\n continued" extract-field #"Another" test-header/bytes) - -(test "From: def\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field "From" "def" test-header) -(test #"From: def\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field #"From" #"def" test-header/bytes) -(test "To: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field "From" #f test-header) -(test #"To: field is\r\n continued\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field #"From" #f test-header/bytes) - -(test "From: abc\r\nTo: qrs\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field "To" "qrs" test-header) -(test #"From: abc\r\nTo: qrs\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field #"To" #"qrs" test-header/bytes) -(test "From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field "To" #f test-header) -(test #"From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" - replace-field #"To" #f test-header/bytes) - -(test "From: abc\r\nTo: field is\r\n continued\r\nAnother: abc\r\n def\r\n\r\n" - replace-field "Another" "abc\r\n def" test-header) -(test #"From: abc\r\nTo: field is\r\n continued\r\nAnother: abc\r\n def\r\n\r\n" - replace-field #"Another" #"abc\r\n def" test-header/bytes) -(test "From: abc\r\nTo: field is\r\n continued\r\n\r\n" - replace-field "Another" #f test-header) -(test #"From: abc\r\nTo: field is\r\n continued\r\n\r\n" - replace-field #"Another" #f test-header/bytes) - -(test "From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" - remove-field "To" test-header) -(test #"From: abc\r\nAnother: zoo\r\n continued\r\n\r\n" - remove-field #"To" test-header/bytes) - -(test `(("From" . "abc") - ("To" . "field is\r\n continued") - ("Another" . "zoo\r\n continued")) - extract-all-fields test-header) -(test `((#"From" . #"abc") - (#"To" . #"field is\r\n continued") - (#"Another" . #"zoo\r\n continued")) - extract-all-fields test-header/bytes) - -(test "From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\nAthird: data\r\n\r\n" - append-headers test-header "Athird: data\r\n\r\n") -(test #"From: abc\r\nTo: field is\r\n continued\r\nAnother: zoo\r\n continued\r\nAthird: data\r\n\r\n" - append-headers test-header/bytes #"Athird: data\r\n\r\n") - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; cookie tests --- JBM, 2006-12-01 - -(require net/cookie) - -;; cookie-test : (cookie -> cookie) string -> test -(define (cookie-test fn expected) - (test expected - (λ (c) (print-cookie (fn c))) - (set-cookie "a" "b"))) - -;; RC = "reverse curry" -(define (RC f arg2) (λ (arg1) (f arg1 arg2))) -;; o = compose -(define-syntax o - (syntax-rules () - [(o f) f] - [(o f g h ...) - (λ (x) (o/* x f g h ...))])) -(define-syntax o/* - (syntax-rules () - [(o/* x) x] - [(o/* x f g ...) - (f (o/* x g ...))])) - -;; test the most basic functionality -(cookie-test (λ (x) x) "a=b; Version=1") - -;; test each modifier individually -(cookie-test (RC cookie:add-comment "set+a+to+b") "a=b; Comment=set+a+to+b; Version=1") -(cookie-test (RC cookie:add-comment "a comment with spaces") "a=b; Comment=\"a comment with spaces\"; Version=1") -(cookie-test (RC cookie:add-comment "the \"risks\" involved in waking") - "a=b; Comment=\"the \\\"risks\\\" involved in waking\"; Version=1") -(cookie-test (RC cookie:add-comment "\"already formatted\"") - "a=b; Comment=\"already formatted\"; Version=1") -(cookie-test (RC cookie:add-comment "\"problematic \" internal quote\"") - "a=b; Comment=\"\\\"problematic \\\" internal quote\\\"\"; Version=1") -(cookie-test (RC cookie:add-comment "contains;semicolon") - "a=b; Comment=\"contains;semicolon\"; Version=1") -(cookie-test (RC cookie:add-domain ".example.net") "a=b; Domain=.example.net; Version=1") -(cookie-test (RC cookie:add-max-age 100) "a=b; Max-Age=100; Version=1") -(cookie-test (RC cookie:add-path "/whatever/wherever/") "a=b; Path=\"/whatever/wherever/\"; Version=1") -(cookie-test (RC cookie:add-path "a+path") "a=b; Path=a+path; Version=1") -(cookie-test (RC cookie:add-path "\"/already/quoted/\"") "a=b; Path=\"/already/quoted/\"; Version=1") -(cookie-test (RC cookie:secure #t) "a=b; Secure; Version=1") -(cookie-test (RC cookie:secure #f) "a=b; Version=1") -(cookie-test (RC cookie:version 12) "a=b; Version=12") - -;; test combinations -(cookie-test (o (RC cookie:add-comment "set+a+to+b") - (RC cookie:add-domain ".example.net")) - "a=b; Comment=set+a+to+b; Domain=.example.net; Version=1") -(cookie-test (o (RC cookie:add-max-age 300) - (RC cookie:secure #t)) - "a=b; Max-Age=300; Secure; Version=1") -(cookie-test (o (RC cookie:add-path "/whatever/wherever/") - (RC cookie:version 10) - (RC cookie:add-max-age 20)) - "a=b; Max-Age=20; Path=\"/whatever/wherever/\"; Version=10") - -;; test error cases -(define-syntax cookie-error-test - (syntax-rules () - [(cookie-error-test e) - (thunk-error-test (λ () (e (set-cookie "a" "b"))) #'e cookie-error?)])) - -(cookie-error-test (RC cookie:add-comment "illegal character #\000")) -(cookie-error-test (RC cookie:add-max-age -10)) -(cookie-error-test (RC cookie:add-domain "doesntstartwithadot.example.com")) -(cookie-error-test (RC cookie:add-domain "bad domain.com")) -(cookie-error-test (RC cookie:add-domain ".bad-domain;com")) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; other net tests @@ -663,115 +12,4 @@ net/qp mzlib/port) -(define tricky-strings - (let ([dir (collection-path "tests" "mzscheme")]) - (list (make-bytes 200 32) - (make-bytes 200 9) - (make-bytes 200 (char->integer #\x)) - (make-bytes 201 (char->integer #\x)) - (make-bytes 202 (char->integer #\x)) - (make-bytes 203 (char->integer #\x)) - (make-bytes 204 (char->integer #\x)) - (list->bytes - (let loop ([i 0]) - (if (= i 256) - null - (cons i (loop (add1 i)))))) - ;; Something that doesn't end with a LF: - (bytes-append (with-input-from-file (build-path dir "net.ss") - (lambda () (read-bytes 500))) - #"xxx") - ;; CRLF: - (regexp-replace #rx#"\r?\n" - (with-input-from-file (build-path dir "net.ss") - (lambda () (read-bytes 500))) - #"\r\n")))) - -(define (check-same encode decode port line-rx max-w) - (let ([p (open-output-bytes)]) - (copy-port port p) - (let ([bytes (get-output-bytes p)] - [r (open-output-bytes)]) - (encode (open-input-bytes bytes) r) - (let ([p (open-input-bytes (get-output-bytes r))]) - (let loop () - (let ([l (read-bytes-line p 'any)]) - (unless (eof-object? l) - (unless (<= (bytes-length l) max-w) - (test encode "line too long" l)) - (let ([m (regexp-match-positions line-rx l)]) - (unless (and m (= (bytes-length l) (cdar m))) - (test encode 'bad-line l))) - (loop)))) - (let ([q (open-output-bytes)]) - (decode (open-input-bytes (get-output-bytes r)) q) - (unless (equal? (get-output-bytes q) bytes) - (with-output-to-file "/tmp/x0" (lambda () (display (get-output-bytes r))) 'truncate) - (with-output-to-file "/tmp/x1" (lambda () (display (get-output-bytes q))) 'truncate) - (with-output-to-file "/tmp/x2" (lambda () (display bytes)) 'truncate) - (error 'decode "failed"))))))) - -(define ((check-same-file encode decode line-rx max-w) file) - ;; This "test" is really just a progress report: - (test #t list? (list file encode)) - (call-with-input-file file - (lambda (p) (check-same encode decode p line-rx max-w)))) - -(define (check-same-all encode decode line-rx max-w) - (for-each (lambda (tricky-string) - (check-same encode decode - (open-input-bytes tricky-string) - line-rx max-w)) - tricky-strings) - (let* ([dir (collection-path "tests" "mzscheme")] - [files (filter-map (lambda (f) - ;; check 1/3 of the files, randomly - (let ([p (build-path dir f)]) - (and (zero? (random 3)) - (not (regexp-match - #rx"^flat.*\\.ss$" - (path-element->string f))) - (file-exists? p) - p))) - (directory-list dir))]) - (for-each (check-same-file encode decode line-rx max-w) files))) - -(check-same-all (lambda (i o) (qp-encode-stream i o)) - qp-decode-stream - #rx#"^(|[\t \41-\176]*[\41-\176]+)$" - 76) - -(check-same-all base64-encode-stream - base64-decode-stream - #rx#"^[0-9a-zA-Z+=/]*$" - 72) - -#| -Use this to compare base64 encode/decode against the unix utilities -(require net/base64 scheme/system) -(define (base64-encode* bstr) - (let ([o (open-output-bytes)]) - (parameterize ([current-output-port o] - [current-input-port (open-input-bytes bstr)]) - (system "base64-encode")) - (let* ([o (get-output-bytes o)] - [o (regexp-replace #rx#"(.)(?:\r?\n)?$" o #"\\1\r\n")] - [o (regexp-replace* #rx#"\r?\n" o #"\r\n")]) - o))) -(define (base64-decode* bstr) - (let ([o (open-output-bytes)]) - (parameterize ([current-output-port o] - [current-input-port (open-input-bytes bstr)]) - (system "base64-decode")) - (get-output-bytes o))) -(define (check-base64-encode bstr) - (equal? (base64-encode bstr) (base64-encode* bstr))) -(define (check-base64-decode bstr) - (equal? (base64-decode bstr) (base64-decode* bstr))) -(define (check-base64-both bstr) - (let ([en (base64-encode bstr)]) - (and (equal? en (base64-encode* bstr)) - (equal? (base64-decode en) (base64-decode* en))))) -|# - (report-errs) From fee4c1944dca20f41b0dc3217dfaf3295ee89215 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 17 Mar 2009 12:43:20 +0000 Subject: [PATCH 056/140] add new section about libraries in ts svn: r14145 --- collects/typed-scheme/ts-reference.scrbl | 51 +++++++++++++++++++++++- 1 file changed, 49 insertions(+), 2 deletions(-) diff --git a/collects/typed-scheme/ts-reference.scrbl b/collects/typed-scheme/ts-reference.scrbl index b1d44a0c82..c2982e2546 100644 --- a/collects/typed-scheme/ts-reference.scrbl +++ b/collects/typed-scheme/ts-reference.scrbl @@ -1,7 +1,10 @@ #lang scribble/doc -@begin[(require scribble/manual) - (require (for-label typed-scheme))] +@begin[(require scribble/manual scribble/eval + scheme/sandbox) + (require (for-label typed-scheme + scheme/list srfi/14 + version/check))] @begin[ (define (item* header . args) (apply item @bold[header]{: } args)) @@ -247,3 +250,47 @@ known to Typed Scheme, either via @scheme[define-struct:] or Like @scheme[do], but each @scheme[id] having the associated type @scheme[t], and the final body @scheme[expr] having the type @scheme[u]. } + +@section{Libraries Provided With Typed Scheme} + +The @schememodname[typed-scheme] language corresponds to the +@schememodname[scheme/base] language---that is, any identifier provided +by @schememodname[scheme/base], such as @scheme[mod] is available by default in +@schememodname[typed-scheme]. + +@schememod[typed-scheme +(modulo 12 2) +] + +Any value provided by @schememodname[scheme] is available by simply +@scheme[require]ing it; use of @scheme[require/typed] is not +neccessary. + +@schememod[typed-scheme +(require scheme/list) +(display (first (list 1 2 3))) +] + +Some libraries have counterparts in the @schemeidfont{typed} +collection, which provide the same exports as the untyped versions. +Such libraries include @schememodname[srfi/14], +@schememodname[net/url], and many others. + +@schememod[typed-scheme +(require typed/srfi/14) +(char-set= (string->char-set "hello") + (string->char-set "olleh")) +] + +To participate in making more libraries available, please visit +@link["http://www.ccs.neu.edu/home/samth/adapt/"]{here}. + + +Other libraries can be used with Typed Scheme via +@scheme[require/typed]. + +@schememod[typed-scheme +(require/typed version/check + [check-version (-> (U Symbol (Listof Any)))]) +(check-version) +] From c69045008d2f8dbcd278291d96460828614768f0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 17 Mar 2009 14:57:01 +0000 Subject: [PATCH 057/140] Added a `file' "test suite", with only tests for inflate/deflate. svn: r14147 --- collects/tests/file/gzip.ss | 37 +++++++++++++++++++++++++++ collects/tests/file/main.ss | 9 +++++++ collects/tests/net/cgi.ss | 3 ++- collects/tests/run-automated-tests.ss | 1 + 4 files changed, 49 insertions(+), 1 deletion(-) create mode 100644 collects/tests/file/gzip.ss create mode 100644 collects/tests/file/main.ss diff --git a/collects/tests/file/gzip.ss b/collects/tests/file/gzip.ss new file mode 100644 index 0000000000..6e7afabf0f --- /dev/null +++ b/collects/tests/file/gzip.ss @@ -0,0 +1,37 @@ +#lang scheme/base +(require file/gzip file/gunzip scheme/file tests/eli-tester) + +(define ((io->str-op io) buf [check-ratio #f]) + (let* ([b? (bytes? buf)] + [i (if b? (open-input-bytes buf) (open-input-string buf))] + [o (if b? (open-output-bytes) (open-output-string))]) + (io i o) + (let ([res (if b? (get-output-bytes o) (get-output-string o))]) + (when check-ratio + (if b? + (check-ratio (bytes-length buf) (bytes-length res)) + (check-ratio (string-length buf) (string-length res)))) + res))) + +(define deflate* (io->str-op deflate)) +(define inflate* (io->str-op inflate)) + +(define (id* buf [ratio #f]) + (test (inflate* (deflate* buf (and ratio (lambda (i o) + (test (< (/ o i) ratio)))))) + => buf)) + +(define (test-big-file) + (define big-file + (build-path (collection-path "drscheme/private") "unit.ss")) + ;; should be around 6 times smaller + (id* (file->bytes big-file) 4)) + +(define (run-tests) + (define (rand-bytes) + (list->bytes (for/list ([j (in-range (random 1000))]) (random 256)))) + (test-big-file) + (for ([i (in-range 100)]) (id* (rand-bytes)))) + +(provide tests) +(define (tests) (test do (run-tests))) diff --git a/collects/tests/file/main.ss b/collects/tests/file/main.ss new file mode 100644 index 0000000000..37d31538d6 --- /dev/null +++ b/collects/tests/file/main.ss @@ -0,0 +1,9 @@ +#lang scheme/base + +(require tests/eli-tester + (prefix-in gzip: "gzip.ss")) + +(define (tests) + (test do (begin (gzip:tests)))) + +(tests) diff --git a/collects/tests/net/cgi.ss b/collects/tests/net/cgi.ss index 3e5694a2d4..9f6eb2e2ff 100644 --- a/collects/tests/net/cgi.ss +++ b/collects/tests/net/cgi.ss @@ -1,5 +1,6 @@ #lang scheme -(require net/cgi net/uri-codec tests/eli-tester) +(require net/cgi (only-in net/uri-codec current-alist-separator-mode) + tests/eli-tester) (define (test-bindings mode query-string) (parameterize ([current-alist-separator-mode mode]) diff --git a/collects/tests/run-automated-tests.ss b/collects/tests/run-automated-tests.ss index 7c4407c1dd..03105e78b9 100755 --- a/collects/tests/run-automated-tests.ss +++ b/collects/tests/run-automated-tests.ss @@ -39,6 +39,7 @@ [require "lazy/main.ss"] [require "scribble/main.ss"] [require "net/main.ss"] + [require "file/main.ss"] )) From 9d0175ac2d76decc9ca5b9f3d1ae9e52ec8f93f7 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 17 Mar 2009 15:01:17 +0000 Subject: [PATCH 058/140] Removed old (unused) gzip tests svn: r14148 --- collects/tests/file/gzip.ss | 102 ++++++++++++++++++++++++++++++++ collects/tests/mzscheme/gzip.ss | 93 ----------------------------- 2 files changed, 102 insertions(+), 93 deletions(-) delete mode 100644 collects/tests/mzscheme/gzip.ss diff --git a/collects/tests/file/gzip.ss b/collects/tests/file/gzip.ss index 6e7afabf0f..8904eeceb6 100644 --- a/collects/tests/file/gzip.ss +++ b/collects/tests/file/gzip.ss @@ -35,3 +35,105 @@ (provide tests) (define (tests) (test do (run-tests))) + + +#| + +;; ELI: These are the old tests; I think that the only thing that +;; should be added from this to the above is trying the file-related +;; functionality (check that the filename is kept etc). + +(require mzlib/deflate + mzlib/inflate) + +(for-each (lambda (f) + (when (file-exists? f) + (printf "trying ~a~n" f) + (let ([str + (call-with-input-file f + (lambda (p) + (let-values ([(in out) (make-pipe 4096)] + [(out2) (open-output-bytes)]) + (thread + (lambda () + (gzip-through-ports p out "x" 0) + (close-output-port out))) + (thread-wait + (thread + (lambda () + (gunzip-through-ports in out2) + (close-output-port out2)))) + (get-output-bytes out2))))]) + (let ([orig-str (call-with-input-file f + (lambda (p) + (read-bytes (file-size f) p)))]) + (unless (bytes=? str orig-str) + (printf "not the same for ~a" f)))))) + (directory-list)) + + +#| + +;; Uses (unix) `gzip' program from your path. +;; Run this in a directory with lots of files to use as tests + +(require mzlib/deflate + mzlib/process) + +(define (check-file/fastest p in) + (let ([s1 (make-string 5000)] + [s2 (make-string 5000)]) + (let loop ([leftover 0][startpos 0][pos 0]) + (let* ([n1 (if (zero? leftover) + (read-string-avail! s1 p) + leftover)] + [n2 (read-string-avail! s2 in 0 (if (eof-object? n1) + 1 + n1))]) + (unless (if (or (eof-object? n1) + (eof-object? n2)) + (and (eof-object? n1) + (eof-object? n2)) + (if (= n2 n1 5000) + (string=? s1 s2) + (string=? (substring s1 startpos (+ startpos n2)) + (substring s2 0 n2)))) + (error 'check "failed at ~a (~a@~a ~a)" pos n1 startpos n2)) + (unless (eof-object? n1) + (loop (- n1 n2) + (if (= n1 n2) + 0 + (+ startpos n2)) + (+ pos n2))))))) + +(define gzip (find-executable-path "gzip" #f)) +(unless gzip + (error "cannot find gzip")) + +(for-each + (lambda (f) + (when (file-exists? f) + (printf "trying ~a~n" f) + (let-values ([(zo zi zn ze zf) + (apply values (process* gzip "-c" f))] + [(mi mo) (make-pipe 4096)]) + (close-output-port zi) + (close-input-port ze) + (thread + (lambda () + (let ([p (open-input-file f)] + [gz (lambda (p mo) + (gzip-through-ports p mo + (let-values ([(base name dir?) (split-path f)]) + name) + (file-or-directory-modify-seconds f)))]) + (gz p mo) + (close-output-port mo)))) + ;; Compare output + (check-file/fastest mi zo) + (close-input-port zo)))) + (directory-list)) + +|# + +|# diff --git a/collects/tests/mzscheme/gzip.ss b/collects/tests/mzscheme/gzip.ss deleted file mode 100644 index e40ea2a22e..0000000000 --- a/collects/tests/mzscheme/gzip.ss +++ /dev/null @@ -1,93 +0,0 @@ - -(require mzlib/deflate - mzlib/inflate) - -(for-each (lambda (f) - (when (file-exists? f) - (printf "trying ~a~n" f) - (let ([str - (call-with-input-file f - (lambda (p) - (let-values ([(in out) (make-pipe 4096)] - [(out2) (open-output-bytes)]) - (thread - (lambda () - (gzip-through-ports p out "x" 0) - (close-output-port out))) - (thread-wait - (thread - (lambda () - (gunzip-through-ports in out2) - (close-output-port out2)))) - (get-output-bytes out2))))]) - (let ([orig-str (call-with-input-file f - (lambda (p) - (read-bytes (file-size f) p)))]) - (unless (bytes=? str orig-str) - (printf "not the same for ~a" f)))))) - (directory-list)) - - -#| - -;; Uses (unix) `gzip' program from your path. -;; Run this in a directory with lots of files to use as tests - -(require mzlib/deflate - mzlib/process) - -(define (check-file/fastest p in) - (let ([s1 (make-string 5000)] - [s2 (make-string 5000)]) - (let loop ([leftover 0][startpos 0][pos 0]) - (let* ([n1 (if (zero? leftover) - (read-string-avail! s1 p) - leftover)] - [n2 (read-string-avail! s2 in 0 (if (eof-object? n1) - 1 - n1))]) - (unless (if (or (eof-object? n1) - (eof-object? n2)) - (and (eof-object? n1) - (eof-object? n2)) - (if (= n2 n1 5000) - (string=? s1 s2) - (string=? (substring s1 startpos (+ startpos n2)) - (substring s2 0 n2)))) - (error 'check "failed at ~a (~a@~a ~a)" pos n1 startpos n2)) - (unless (eof-object? n1) - (loop (- n1 n2) - (if (= n1 n2) - 0 - (+ startpos n2)) - (+ pos n2))))))) - -(define gzip (find-executable-path "gzip" #f)) -(unless gzip - (error "cannot find gzip")) - -(for-each - (lambda (f) - (when (file-exists? f) - (printf "trying ~a~n" f) - (let-values ([(zo zi zn ze zf) - (apply values (process* gzip "-c" f))] - [(mi mo) (make-pipe 4096)]) - (close-output-port zi) - (close-input-port ze) - (thread - (lambda () - (let ([p (open-input-file f)] - [gz (lambda (p mo) - (gzip-through-ports p mo - (let-values ([(base name dir?) (split-path f)]) - name) - (file-or-directory-modify-seconds f)))]) - (gz p mo) - (close-output-port mo)))) - ;; Compare output - (check-file/fastest mi zo) - (close-input-port zo)))) - (directory-list)) - -|# From 0a0053c9fd29ae13a92e09cc007224cab616529a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 17 Mar 2009 15:29:53 +0000 Subject: [PATCH 059/140] Welcome to a new PLT day. svn: r14150 --- 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 a5cd42cabf..c82a55de51 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "16mar2009") +#lang scheme/base (provide stamp) (define stamp "17mar2009") From 2068a5dcc3b71ab958e127787e6f4705fce79a84 Mon Sep 17 00:00:00 2001 From: Carl Eastlund Date: Tue, 17 Mar 2009 15:36:36 +0000 Subject: [PATCH 060/140] Corrected a typo in the contracts reference ('exmaple' -> 'example'). svn: r14151 --- collects/scribblings/reference/contracts.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index f8df8bd61d..b35a8f56cb 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -367,7 +367,7 @@ The @scheme[case->] contract is a specialized contract, designed to match @scheme[case-lambda] and @scheme[unconstrained-domain->] allows range checking without requiring that the domain have any particular shape -(see below for an exmaple use). +(see below for an example use). @defform*/subs[#:literals (any values) [(-> dom ... range)] From 289b20005782c936aefc75497fc0c2fa1cb4c828 Mon Sep 17 00:00:00 2001 From: Casey Klein Date: Tue, 17 Mar 2009 18:21:11 +0000 Subject: [PATCH 061/140] Fixed bug in parse-language. svn: r14155 --- collects/redex/private/rg-test.ss | 8 ++++++++ collects/redex/private/rg.ss | 2 +- 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/collects/redex/private/rg-test.ss b/collects/redex/private/rg-test.ss index fafdb8079d..2a0e6974fd 100644 --- a/collects/redex/private/rg-test.ss +++ b/collects/redex/private/rg-test.ss @@ -530,6 +530,14 @@ (decisions #:nt (patterns fourth first first second first first first) #:var (list (λ _ 'x) (λ _ 'y)))) (term (λ (x) (hole y))))) +(let () + (define-language L + (a ((a ...) ...))) + (test (generate-term/decisions + L (cross a) 3 0 + (decisions #:nt (patterns second first) + #:seq (list (λ _ 0) (λ _ 0) (λ _ 0) (λ _ 0)))) + (term ((hole))))) ;; generation failures increase size and attempt (let () diff --git a/collects/redex/private/rg.ss b/collects/redex/private/rg.ss index 50732ad1bd..65b9b00463 100644 --- a/collects/redex/private/rg.ss +++ b/collects/redex/private/rg.ss @@ -620,7 +620,7 @@ To do a better job of not generating programs with free variables, (struct-copy compiled-lang lang [lang (map (parse-nt 'grammar) (compiled-lang-lang lang))] - [cclang (map (parse-nt 'top-level) (compiled-lang-cclang lang))])) + [cclang (map (parse-nt 'cross) (compiled-lang-cclang lang))])) ;; unparse-pattern: parsed-pattern -> pattern (define unparse-pattern From 19196868769ce178df2746952151baf6de6ab9bb Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Mar 2009 19:57:04 +0000 Subject: [PATCH 062/140] HISTORY updates through 4.1.5: merge to 4.1.5 svn: r14157 --- doc/release-notes/mred/HISTORY.txt | 8 +++++++- doc/release-notes/mzscheme/HISTORY.txt | 6 ++---- 2 files changed, 9 insertions(+), 5 deletions(-) diff --git a/doc/release-notes/mred/HISTORY.txt b/doc/release-notes/mred/HISTORY.txt index 5776acfd64..1fa020db74 100644 --- a/doc/release-notes/mred/HISTORY.txt +++ b/doc/release-notes/mred/HISTORY.txt @@ -1,4 +1,10 @@ -Version 4.1.4, January 2008 +Version 4.1.5, March 2009 + +Minor bug fixes + +---------------------------------------------------------------------- + +Version 4.1.4, January 2009 Changed image-snip% to implement equal<%> diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index f45f79c843..eacec19c81 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,12 +1,10 @@ -Version 4.1.4.3 +Version 4.1.5, March 2009 Allow infix notation for prefab structure literals Change quasiquote so that unquote works in value positions of #hash Change read-syntax to represent #hash value forms as syntax - -Version 4.1.4.2 Added bitwise-bit-field -Version 4.1.4, January 2008 +Version 4.1.4, January 2009 Changed memory accounting to bias charges to parent instead of children Changed function contracts to preserve tail recursion in many cases Added scheme/package, scheme/splicing, ffi/objc From e8dba7c7b18497ec8ad4c73ba19c3f6a61d01846 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Mar 2009 20:49:04 +0000 Subject: [PATCH 063/140] fix comment closer: merge to 4.1.5 svn: r14159 --- src/foreign/foreign.c | 4 ++-- src/foreign/foreign.ssc | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 5159b251d5..86ab89913e 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -2138,7 +2138,7 @@ static Scheme_Object *abs_sym; /* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ -/* if n is given, an 'abs flag can precede it to make n be a byte offset rather +/* if n is given, an 'abs flag can precede it to make n be a byte offset rather */ /* than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ #define MYNAME "ptr-ref" @@ -2191,7 +2191,7 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) /* (ptr-set! cpointer type [['abs] n] value) -> void */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ -/* if n is given, an 'abs flag can precede it to make n be a byte offset rather +/* if n is given, an 'abs flag can precede it to make n be a byte offset rather */ /* than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ #define MYNAME "ptr-set!" diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index 92e8b468ea..ed8e5857b2 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -1553,7 +1553,7 @@ static Scheme_Object *do_memop(const char *who, int mode, /* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ -/* if n is given, an 'abs flag can precede it to make n be a byte offset rather +/* if n is given, an 'abs flag can precede it to make n be a byte offset rather */ /* than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ @cdefine[ptr-ref 2 4]{ From 09914dda3f9a62858486fbe422f5c3421b35aac2 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Mar 2009 21:05:53 +0000 Subject: [PATCH 064/140] =?UTF-8?q?make-rename-transformer=20=3D>=20free-i?= =?UTF-8?q?dentifier=3D=3F=20(v5.1.5.2)?= svn: r14160 --- src/mzscheme/include/scheme.h | 3 +- src/mzscheme/src/cstartup.inc | 388 +++++------ src/mzscheme/src/env.c | 28 +- src/mzscheme/src/error.c | 6 +- src/mzscheme/src/eval.c | 7 +- src/mzscheme/src/module.c | 43 +- src/mzscheme/src/mzmark.c | 4 + src/mzscheme/src/mzmarksrc.c | 2 + src/mzscheme/src/print.c | 18 +- src/mzscheme/src/read.c | 7 + src/mzscheme/src/schpriv.h | 24 +- src/mzscheme/src/schvers.h | 4 +- src/mzscheme/src/stxobj.c | 1130 +++++++++++++++++++++++++-------- src/mzscheme/src/syntax.c | 12 +- 14 files changed, 1193 insertions(+), 483 deletions(-) diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index db193f31da..d924b5952f 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -790,7 +790,7 @@ typedef struct { typedef struct Scheme_Hash_Table { - Scheme_Inclhash_Object iso; + Scheme_Inclhash_Object iso; /* 0x1 flag => marshal as #t (hack for stxobj bytecode) */ int size; /* power of 2 */ int count; Scheme_Object **keys; @@ -1024,6 +1024,7 @@ typedef struct Scheme_Thread { struct Scheme_Marshal_Tables *current_mt; Scheme_Object *constant_folding; /* compiler hack */ + Scheme_Object *reading_delayed; /* reader hack */ Scheme_Object *(*overflow_k)(void); Scheme_Object *overflow_reply; diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index 57e3464d2a..1f54490d79 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -1,5 +1,5 @@ { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,52,46,50,50,0,0,0,1,0,0,3,0,12,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,50,50,0,0,0,1,0,0,3,0,12,0, 17,0,20,0,27,0,40,0,47,0,51,0,58,0,63,0,68,0,72,0,78, 0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0, 177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,87,1,126,1,165, @@ -14,13 +14,13 @@ 115,61,120,73,108,101,116,114,101,99,45,118,97,108,117,101,115,66,108,97,109, 98,100,97,1,20,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110, 45,107,101,121,61,118,73,100,101,102,105,110,101,45,118,97,108,117,101,115,98, -10,35,11,8,134,228,94,159,2,15,35,35,159,2,14,35,35,16,20,2,3, +10,35,11,8,148,228,94,159,2,15,35,35,159,2,14,35,35,16,20,2,3, 2,1,2,5,2,1,2,6,2,1,2,7,2,1,2,8,2,1,2,9,2, 1,2,10,2,1,2,4,2,1,2,11,2,1,2,12,2,1,97,36,11,8, -134,228,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2,2,2,1,2, -2,97,10,11,11,8,134,228,16,0,97,10,37,11,8,134,228,16,0,13,16, +148,228,93,159,2,14,35,36,16,2,2,2,161,2,1,36,2,2,2,1,2, +2,97,10,11,11,8,148,228,16,0,97,10,37,11,8,148,228,16,0,13,16, 4,35,29,11,11,2,1,11,18,16,2,99,64,104,101,114,101,8,31,8,30, -8,29,8,28,8,27,93,8,224,13,57,0,0,95,9,8,224,13,57,0,0, +8,29,8,28,8,27,93,8,224,27,57,0,0,95,9,8,224,27,57,0,0, 2,1,27,248,22,135,4,23,196,1,249,22,128,4,80,158,38,35,251,22,75, 2,16,248,22,90,23,200,2,12,249,22,65,2,17,248,22,92,23,202,1,27, 248,22,135,4,23,196,1,249,22,128,4,80,158,38,35,251,22,75,2,16,248, @@ -29,16 +29,16 @@ 248,22,73,248,22,67,23,195,2,248,22,66,193,249,22,128,4,80,158,38,35, 251,22,75,2,16,248,22,66,23,200,2,249,22,65,2,12,248,22,67,23,202, 1,11,18,16,2,101,10,8,31,8,30,8,29,8,28,8,27,16,4,11,11, -2,18,3,1,7,101,110,118,57,55,57,53,16,4,11,11,2,19,3,1,7, -101,110,118,57,55,57,54,93,8,224,14,57,0,0,95,9,8,224,14,57,0, +2,18,3,1,7,101,110,118,57,56,48,52,16,4,11,11,2,19,3,1,7, +101,110,118,57,56,48,53,93,8,224,28,57,0,0,95,9,8,224,28,57,0, 0,2,1,27,248,22,67,248,22,135,4,23,197,1,28,248,22,73,23,194,2, 20,15,159,36,35,36,28,248,22,73,248,22,67,23,195,2,248,22,66,193,249, 22,128,4,80,158,38,35,250,22,75,2,20,248,22,75,249,22,75,248,22,75, 2,21,248,22,66,23,202,2,251,22,75,2,16,2,21,2,21,249,22,65,2, 4,248,22,67,23,205,1,18,16,2,101,11,8,31,8,30,8,29,8,28,8, -27,16,4,11,11,2,18,3,1,7,101,110,118,57,55,57,56,16,4,11,11, -2,19,3,1,7,101,110,118,57,55,57,57,93,8,224,15,57,0,0,95,9, -8,224,15,57,0,0,2,1,248,22,135,4,193,27,248,22,135,4,194,249,22, +27,16,4,11,11,2,18,3,1,7,101,110,118,57,56,48,55,16,4,11,11, +2,19,3,1,7,101,110,118,57,56,48,56,93,8,224,29,57,0,0,95,9, +8,224,29,57,0,0,2,1,248,22,135,4,193,27,248,22,135,4,194,249,22, 65,248,22,75,248,22,66,196,248,22,67,195,27,248,22,67,248,22,135,4,23, 197,1,249,22,128,4,80,158,38,35,28,248,22,53,248,22,129,4,248,22,66, 23,198,2,27,249,22,2,32,0,89,162,8,44,36,42,9,222,33,39,248,22, @@ -68,9 +68,9 @@ 249,22,164,8,248,22,129,4,248,22,66,23,201,2,64,101,108,115,101,10,248, 22,66,23,198,2,250,22,76,2,20,9,248,22,67,23,201,1,249,22,65,2, 3,248,22,67,23,203,1,100,8,31,8,30,8,29,8,28,8,27,16,4,11, -11,2,18,3,1,7,101,110,118,57,56,50,49,16,4,11,11,2,19,3,1, -7,101,110,118,57,56,50,50,93,8,224,16,57,0,0,18,16,2,158,94,10, -64,118,111,105,100,8,47,95,9,8,224,16,57,0,0,2,1,27,248,22,67, +11,2,18,3,1,7,101,110,118,57,56,51,48,16,4,11,11,2,19,3,1, +7,101,110,118,57,56,51,49,93,8,224,30,57,0,0,18,16,2,158,94,10, +64,118,111,105,100,8,47,95,9,8,224,30,57,0,0,2,1,27,248,22,67, 248,22,135,4,196,249,22,128,4,80,158,38,35,28,248,22,53,248,22,129,4, 248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,199,248,22,90,198,27, 248,22,129,4,248,22,66,197,250,22,75,2,26,248,22,75,248,22,66,197,250, @@ -100,7 +100,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 2045); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,52,46,50,59,0,0,0,1,0,0,13,0,18,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,50,59,0,0,0,1,0,0,13,0,18,0, 35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226, 0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1, 199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100, @@ -342,12 +342,12 @@ EVAL_ONE_SIZED_STR((char *)expr, 5009); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,52,46,50,8,0,0,0,1,0,0,6,0,19,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,50,8,0,0,0,1,0,0,6,0,19,0, 34,0,48,0,62,0,76,0,111,0,0,0,1,1,0,0,65,113,117,111,116, 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37, 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122, 11,29,94,2,1,68,35,37,101,120,112,111,98,115,11,29,94,2,1,68,35, -37,107,101,114,110,101,108,11,98,10,35,11,8,140,230,97,159,2,2,35,35, +37,107,101,114,110,101,108,11,98,10,35,11,8,154,230,97,159,2,2,35,35, 159,2,3,35,35,159,2,4,35,35,159,2,5,35,35,159,2,6,35,35,16, 0,159,35,20,103,159,35,16,1,11,16,0,83,158,41,20,100,143,69,35,37, 98,117,105,108,116,105,110,29,11,11,11,10,10,18,96,11,42,42,42,35,80, @@ -360,12 +360,12 @@ EVAL_ONE_SIZED_STR((char *)expr, 294); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,52,46,50,52,0,0,0,1,0,0,11,0,38,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,50,52,0,0,0,1,0,0,11,0,38,0, 44,0,57,0,71,0,93,0,119,0,131,0,149,0,169,0,181,0,197,0,220, 0,0,1,5,1,10,1,15,1,24,1,29,1,60,1,64,1,72,1,81,1, -89,1,196,1,241,1,5,2,34,2,65,2,121,2,131,2,178,2,188,2,195, -2,82,4,95,4,114,4,233,4,245,4,141,5,155,5,21,6,27,6,41,6, -68,6,153,6,155,6,221,6,166,12,225,12,3,13,0,0,138,15,0,0,70, +89,1,192,1,237,1,1,2,30,2,61,2,117,2,127,2,174,2,184,2,191, +2,78,4,91,4,110,4,229,4,241,4,137,5,151,5,17,6,23,6,37,6, +64,6,149,6,151,6,217,6,162,12,221,12,255,12,0,0,134,15,0,0,70, 100,108,108,45,115,117,102,102,105,120,1,25,100,101,102,97,117,108,116,45,108, 111,97,100,47,117,115,101,45,99,111,109,112,105,108,101,100,65,113,117,111,116, 101,29,94,2,3,67,35,37,117,116,105,108,115,11,29,94,2,3,68,35,37, @@ -383,178 +383,178 @@ 45,109,111,100,117,108,101,45,110,97,109,101,45,114,101,115,111,108,118,101,114, 63,108,105,98,67,105,103,110,111,114,101,100,249,22,14,195,80,159,37,45,37, 249,80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,164,8,23,197,2, -80,159,38,46,37,87,94,23,195,1,80,159,36,47,37,27,248,22,173,4,23, -197,2,28,248,22,139,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22, -160,13,23,197,1,87,95,83,160,37,11,80,159,40,46,37,198,83,160,37,11, -80,159,40,47,37,192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247, -22,191,4,28,192,192,247,22,179,13,20,14,159,80,158,35,39,250,80,158,38, -40,249,22,27,11,80,158,40,39,22,191,4,28,248,22,139,13,23,198,2,23, -197,1,87,94,23,197,1,247,22,179,13,247,194,250,22,157,13,23,197,1,23, -199,1,249,80,158,42,38,23,198,1,2,17,252,22,157,13,23,199,1,23,201, -1,2,18,247,22,179,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87, -94,23,194,1,27,250,22,174,13,196,11,32,0,89,162,8,44,35,40,9,222, -11,28,192,249,22,65,195,194,11,27,252,22,157,13,23,200,1,23,202,1,2, -18,247,22,179,7,249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22, -174,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,65,195, -194,11,249,247,22,184,13,248,22,66,195,195,27,250,22,157,13,23,198,1,23, -200,1,249,80,158,43,38,23,199,1,2,17,27,250,22,174,13,196,11,32,0, -89,162,8,44,35,40,9,222,11,28,192,249,22,65,195,194,11,249,247,22,189, -4,248,22,66,195,195,249,247,22,189,4,194,195,87,94,28,248,80,158,36,37, -23,195,2,12,250,22,132,9,77,108,111,97,100,47,117,115,101,45,99,111,109, -112,105,108,101,100,6,25,25,112,97,116,104,32,111,114,32,118,97,108,105,100, -45,112,97,116,104,32,115,116,114,105,110,103,23,197,2,91,159,41,11,90,161, -36,35,11,28,248,22,163,13,23,201,2,23,200,1,27,247,22,191,4,28,23, -193,2,249,22,164,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,160, -13,23,194,2,87,94,23,196,1,90,161,36,39,11,28,249,22,164,8,23,196, -2,68,114,101,108,97,116,105,118,101,87,94,23,194,1,2,16,23,194,1,90, -161,36,40,11,247,22,181,13,27,89,162,43,36,49,62,122,111,225,7,5,3, -33,27,27,89,162,43,36,51,9,225,8,6,4,33,28,27,249,22,5,89,162, -8,44,36,46,9,223,5,33,29,23,203,2,27,28,23,195,1,27,249,22,5, -89,162,8,44,36,52,9,225,13,11,9,33,30,23,205,2,27,28,23,196,2, -11,193,28,192,192,28,193,28,23,196,2,28,249,22,168,3,248,22,67,196,248, -22,67,23,199,2,193,11,11,11,11,28,23,193,2,249,80,159,47,54,36,202, -89,162,43,35,45,9,224,14,2,33,31,87,94,23,193,1,27,28,23,197,1, -27,249,22,5,83,158,39,20,97,94,89,162,8,44,36,50,9,225,14,12,10, -33,32,23,203,1,23,206,1,27,28,196,11,193,28,192,192,28,193,28,196,28, -249,22,168,3,248,22,67,196,248,22,67,199,193,11,11,11,11,28,192,249,80, -159,48,54,36,203,89,162,43,35,45,9,224,15,2,33,33,249,80,159,48,54, -36,203,89,162,43,35,44,9,224,15,7,33,34,32,36,89,162,8,44,36,54, -2,19,222,33,38,0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42, -41,36,34,27,249,22,189,13,2,37,23,196,2,28,23,193,2,87,94,23,194, -1,249,22,65,248,22,90,23,196,2,27,248,22,99,23,197,1,27,249,22,189, -13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,65,248,22,90, -23,196,2,27,248,22,99,23,197,1,27,249,22,189,13,2,37,23,196,2,28, -23,193,2,87,94,23,194,1,249,22,65,248,22,90,23,196,2,248,2,36,248, -22,99,23,197,1,248,22,75,194,248,22,75,194,248,22,75,194,32,39,89,162, -43,36,54,2,19,222,33,40,28,248,22,73,248,22,67,23,195,2,249,22,7, -9,248,22,66,195,91,159,37,11,90,161,37,35,11,27,248,22,67,23,197,2, -28,248,22,73,248,22,67,23,195,2,249,22,7,9,248,22,66,195,91,159,37, -11,90,161,37,35,11,27,248,22,67,23,197,2,28,248,22,73,248,22,67,23, -195,2,249,22,7,9,248,22,66,195,91,159,37,11,90,161,37,35,11,248,2, -39,248,22,67,23,197,2,249,22,7,249,22,65,248,22,66,23,200,1,23,197, -1,195,249,22,7,249,22,65,248,22,66,23,200,1,23,197,1,195,249,22,7, -249,22,65,248,22,66,23,200,1,23,197,1,195,27,248,2,36,23,195,1,28, -194,192,248,2,39,193,87,95,28,248,22,171,4,195,12,250,22,132,9,2,20, -6,20,20,114,101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97, -116,104,197,28,24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250, -22,139,2,80,159,41,42,37,248,22,145,14,247,22,186,11,11,28,23,193,2, -192,87,94,23,193,1,27,247,22,123,87,94,250,22,137,2,80,159,42,42,37, -248,22,145,14,247,22,186,11,195,192,250,22,137,2,195,198,66,97,116,116,97, -99,104,251,211,197,198,199,10,28,192,250,22,131,9,11,196,195,248,22,129,9, -194,28,249,22,165,6,194,6,1,1,46,2,16,28,249,22,165,6,194,6,2, -2,46,46,62,117,112,192,28,249,22,166,8,248,22,67,23,200,2,23,197,1, -28,249,22,164,8,248,22,66,23,200,2,23,196,1,251,22,129,9,2,20,6, -26,26,99,121,99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116, -32,126,101,58,32,126,101,23,200,1,249,22,2,22,67,248,22,80,249,22,65, -23,206,1,23,202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,65, -248,22,145,14,247,22,186,11,23,197,1,20,14,159,80,158,39,39,250,80,158, -42,40,249,22,27,11,80,158,44,39,22,153,4,23,196,1,249,247,22,190,4, -23,198,1,248,22,54,248,22,143,13,23,198,1,87,94,28,28,248,22,139,13, -23,197,2,10,248,22,177,4,23,197,2,12,28,23,198,2,250,22,131,9,11, -6,15,15,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,201,2, -250,22,132,9,2,20,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32, -111,114,32,112,97,116,104,23,199,2,28,28,248,22,63,23,197,2,249,22,164, -8,248,22,66,23,199,2,2,3,11,248,22,172,4,248,22,90,197,28,28,248, -22,63,23,197,2,249,22,164,8,248,22,66,23,199,2,66,112,108,97,110,101, -116,11,87,94,28,207,12,20,14,159,80,158,37,39,250,80,158,40,40,249,22, -27,11,80,158,42,39,22,186,11,23,197,1,90,161,36,35,10,249,22,154,4, -21,94,2,21,6,18,18,112,108,97,110,101,116,47,114,101,115,111,108,118,101, -114,46,115,115,1,27,112,108,97,110,101,116,45,109,111,100,117,108,101,45,110, -97,109,101,45,114,101,115,111,108,118,101,114,12,251,211,199,200,201,202,87,94, -23,193,1,27,89,162,8,44,36,45,79,115,104,111,119,45,99,111,108,108,101, -99,116,105,111,110,45,101,114,114,223,6,33,44,27,28,248,22,53,23,199,2, -27,250,22,139,2,80,159,43,43,37,249,22,65,23,204,2,247,22,180,13,11, -28,23,193,2,192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80, -159,44,48,36,248,22,56,23,204,2,11,27,251,80,158,47,50,2,20,23,202, -1,28,248,22,73,23,199,2,23,199,2,248,22,66,23,199,2,28,248,22,73, -23,199,2,9,248,22,67,23,199,2,249,22,157,13,23,195,1,28,248,22,73, -23,197,1,87,94,23,197,1,6,7,7,109,97,105,110,46,115,115,249,22,182, -6,23,199,1,6,3,3,46,115,115,28,248,22,159,6,23,199,2,87,94,23, -194,1,27,248,80,159,41,55,36,23,201,2,27,250,22,139,2,80,159,44,43, -37,249,22,65,23,205,2,23,199,2,11,28,23,193,2,192,87,94,23,193,1, -91,159,37,11,90,161,37,35,11,249,80,159,45,48,36,23,204,2,11,250,22, -1,22,157,13,23,199,1,249,22,79,249,22,2,32,0,89,162,8,44,36,43, -9,222,33,45,23,200,1,248,22,75,23,200,1,28,248,22,139,13,23,199,2, -87,94,23,194,1,28,248,22,162,13,23,199,2,23,198,2,248,22,75,6,26, -26,32,40,97,32,112,97,116,104,32,109,117,115,116,32,98,101,32,97,98,115, -111,108,117,116,101,41,28,249,22,164,8,248,22,66,23,201,2,2,21,27,250, -22,139,2,80,159,43,43,37,249,22,65,23,204,2,247,22,180,13,11,28,23, -193,2,192,87,94,23,193,1,91,159,38,11,90,161,37,35,11,249,80,159,45, -48,36,248,22,90,23,205,2,11,90,161,36,37,11,28,248,22,73,248,22,92, -23,204,2,28,248,22,73,23,194,2,249,22,191,13,0,8,35,114,120,34,91, -46,93,34,23,196,2,11,10,27,27,28,23,197,2,249,22,79,28,248,22,73, -248,22,92,23,208,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,79, -249,22,2,80,159,51,56,36,248,22,92,23,211,2,23,197,2,28,248,22,73, -23,196,2,248,22,75,23,197,2,23,195,2,251,80,158,49,50,2,20,23,204, -1,248,22,66,23,198,2,248,22,67,23,198,1,249,22,157,13,23,195,1,28, -23,198,1,87,94,23,196,1,23,197,1,28,248,22,73,23,197,1,87,94,23, -197,1,6,7,7,109,97,105,110,46,115,115,28,249,22,191,13,0,8,35,114, -120,34,91,46,93,34,23,199,2,23,197,1,249,22,182,6,23,199,1,6,3, -3,46,115,115,28,249,22,164,8,248,22,66,23,201,2,64,102,105,108,101,249, -22,164,13,248,22,168,13,248,22,90,23,202,2,248,80,159,42,55,36,23,202, -2,12,87,94,28,28,248,22,139,13,23,194,2,10,248,22,181,7,23,194,2, -87,94,23,200,1,12,28,23,200,2,250,22,131,9,67,114,101,113,117,105,114, -101,249,22,143,7,6,17,17,98,97,100,32,109,111,100,117,108,101,32,112,97, -116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0,0,23,203,1,87, -94,23,200,1,250,22,132,9,2,20,249,22,143,7,6,13,13,109,111,100,117, -108,101,32,112,97,116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0, -0,23,201,2,27,28,248,22,181,7,23,195,2,249,22,186,7,23,196,2,35, -249,22,166,13,248,22,167,13,23,197,2,11,27,28,248,22,181,7,23,196,2, -249,22,186,7,23,197,2,36,248,80,158,42,51,23,195,2,91,159,38,11,90, -161,38,35,11,28,248,22,181,7,23,199,2,250,22,7,2,22,249,22,186,7, -23,203,2,37,2,22,248,22,160,13,23,198,2,87,95,23,195,1,23,193,1, -27,28,248,22,181,7,23,200,2,249,22,186,7,23,201,2,38,249,80,158,47, -52,23,197,2,5,0,27,28,248,22,181,7,23,201,2,249,22,186,7,23,202, -2,39,248,22,172,4,23,200,2,27,27,250,22,139,2,80,159,51,42,37,248, -22,145,14,247,22,186,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22, -123,87,94,250,22,137,2,80,159,52,42,37,248,22,145,14,247,22,186,11,195, -192,87,95,28,23,209,1,27,250,22,139,2,23,197,2,197,11,28,23,193,1, -12,87,95,27,27,28,248,22,17,80,159,51,45,37,80,159,50,45,37,247,22, -19,250,22,25,248,22,23,23,197,2,80,159,53,44,37,23,196,1,27,248,22, -145,14,247,22,186,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54, -9,226,12,11,2,3,33,46,23,195,1,23,196,1,248,28,248,22,17,80,159, -50,45,37,32,0,89,162,43,36,41,9,222,33,47,80,159,49,57,36,89,162, -43,35,50,9,227,14,9,8,4,3,33,48,250,22,137,2,23,197,1,197,10, -12,28,28,248,22,181,7,23,202,1,11,27,248,22,159,6,23,208,2,28,192, -192,28,248,22,63,23,208,2,249,22,164,8,248,22,66,23,210,2,2,21,11, -250,22,137,2,80,159,50,43,37,28,248,22,159,6,23,210,2,249,22,65,23, -211,1,248,80,159,53,55,36,23,213,1,87,94,23,210,1,249,22,65,23,211, -1,247,22,180,13,252,22,183,7,23,208,1,23,207,1,23,205,1,23,203,1, -201,12,193,91,159,37,10,90,161,36,35,10,11,90,161,36,36,10,83,158,38, -20,96,96,2,20,89,162,8,44,36,50,9,224,2,0,33,42,89,162,43,38, -48,9,223,1,33,43,89,162,43,39,8,30,9,225,2,3,0,33,49,208,87, -95,248,22,152,4,248,80,159,37,49,37,247,22,186,11,248,22,190,4,80,159, -36,36,37,248,22,177,12,80,159,36,41,36,159,35,20,103,159,35,16,1,11, -16,0,83,158,41,20,100,143,66,35,37,98,111,111,116,29,11,11,11,11,10, -10,36,80,158,35,35,20,103,159,39,16,19,2,1,2,2,30,2,4,72,112, -97,116,104,45,115,116,114,105,110,103,63,10,30,2,4,75,112,97,116,104,45, -97,100,100,45,115,117,102,102,105,120,7,30,2,5,1,20,112,97,114,97,109, -101,116,101,114,105,122,97,116,105,111,110,45,107,101,121,4,30,2,5,1,23, -101,120,116,101,110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105, -111,110,3,2,6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14, -30,2,4,69,45,102,105,110,100,45,99,111,108,0,30,2,4,76,110,111,114, -109,97,108,45,99,97,115,101,45,112,97,116,104,6,30,2,4,79,112,97,116, -104,45,114,101,112,108,97,99,101,45,115,117,102,102,105,120,9,2,15,16,0, -11,11,16,0,35,16,0,35,16,11,2,9,2,10,2,7,2,8,2,11,2, -12,2,2,2,6,2,1,2,14,2,13,46,11,11,38,35,11,11,16,1,2, -15,16,1,11,16,1,2,15,36,36,36,11,11,16,0,16,0,16,0,35,35, -11,11,11,16,0,16,0,16,0,35,35,16,0,16,16,83,158,35,16,2,89, -162,43,36,44,9,223,0,33,23,80,159,35,57,36,83,158,35,16,2,89,162, -43,36,44,9,223,0,33,24,80,159,35,56,36,83,158,35,16,2,89,162,43, -36,48,67,103,101,116,45,100,105,114,223,0,33,25,80,159,35,55,36,83,158, -35,16,2,89,162,43,37,48,68,119,105,116,104,45,100,105,114,223,0,33,26, -80,159,35,54,36,83,158,35,16,2,248,22,178,7,69,115,111,45,115,117,102, -102,105,120,80,159,35,35,36,83,158,35,16,2,89,162,43,37,59,2,2,223, -0,33,35,80,159,35,36,36,83,158,35,16,2,32,0,89,162,8,44,36,41, -2,6,222,192,80,159,35,41,36,83,158,35,16,2,247,22,126,80,159,35,42, -36,83,158,35,16,2,247,22,125,80,159,35,43,36,83,158,35,16,2,247,22, -61,80,159,35,44,36,83,158,35,16,2,248,22,18,74,109,111,100,117,108,101, -45,108,111,97,100,105,110,103,80,159,35,45,36,83,158,35,16,2,11,80,158, -35,46,83,158,35,16,2,11,80,158,35,47,83,158,35,16,2,32,0,89,162, -43,37,44,2,13,222,33,41,80,159,35,48,36,83,158,35,16,2,89,162,8, -44,36,44,2,14,223,0,33,50,80,159,35,49,36,83,158,35,16,2,89,162, -43,35,43,2,15,223,0,33,51,80,159,35,53,36,95,29,94,2,3,68,35, -37,107,101,114,110,101,108,11,29,94,2,3,69,35,37,109,105,110,45,115,116, -120,11,2,4,9,9,9,35,0}; - EVAL_ONE_SIZED_STR((char *)expr, 4103); +80,158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,173,4,23,197,2, +28,248,22,139,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,160,13, +23,197,1,87,95,83,160,37,11,80,158,40,46,198,83,160,37,11,80,158,40, +47,192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,191,4,28, +192,192,247,22,179,13,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27, +11,80,158,40,39,22,191,4,28,248,22,139,13,23,198,2,23,197,1,87,94, +23,197,1,247,22,179,13,247,194,250,22,157,13,23,197,1,23,199,1,249,80, +158,42,38,23,198,1,2,17,252,22,157,13,23,199,1,23,201,1,2,18,247, +22,179,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87,94,23,194,1, +27,250,22,174,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249, +22,65,195,194,11,27,252,22,157,13,23,200,1,23,202,1,2,18,247,22,179, +7,249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,174,13,196,11, +32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,65,195,194,11,249,247, +22,184,13,248,22,66,195,195,27,250,22,157,13,23,198,1,23,200,1,249,80, +158,43,38,23,199,1,2,17,27,250,22,174,13,196,11,32,0,89,162,8,44, +35,40,9,222,11,28,192,249,22,65,195,194,11,249,247,22,189,4,248,22,66, +195,195,249,247,22,189,4,194,195,87,94,28,248,80,158,36,37,23,195,2,12, +250,22,132,9,77,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101, +100,6,25,25,112,97,116,104,32,111,114,32,118,97,108,105,100,45,112,97,116, +104,32,115,116,114,105,110,103,23,197,2,91,159,41,11,90,161,36,35,11,28, +248,22,163,13,23,201,2,23,200,1,27,247,22,191,4,28,23,193,2,249,22, +164,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,160,13,23,194,2, +87,94,23,196,1,90,161,36,39,11,28,249,22,164,8,23,196,2,68,114,101, +108,97,116,105,118,101,87,94,23,194,1,2,16,23,194,1,90,161,36,40,11, +247,22,181,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,27,27,89, +162,43,36,51,9,225,8,6,4,33,28,27,249,22,5,89,162,8,44,36,46, +9,223,5,33,29,23,203,2,27,28,23,195,1,27,249,22,5,89,162,8,44, +36,52,9,225,13,11,9,33,30,23,205,2,27,28,23,196,2,11,193,28,192, +192,28,193,28,23,196,2,28,249,22,168,3,248,22,67,196,248,22,67,23,199, +2,193,11,11,11,11,28,23,193,2,249,80,159,47,54,36,202,89,162,43,35, +45,9,224,14,2,33,31,87,94,23,193,1,27,28,23,197,1,27,249,22,5, +83,158,39,20,97,94,89,162,8,44,36,50,9,225,14,12,10,33,32,23,203, +1,23,206,1,27,28,196,11,193,28,192,192,28,193,28,196,28,249,22,168,3, +248,22,67,196,248,22,67,199,193,11,11,11,11,28,192,249,80,159,48,54,36, +203,89,162,43,35,45,9,224,15,2,33,33,249,80,159,48,54,36,203,89,162, +43,35,44,9,224,15,7,33,34,32,36,89,162,8,44,36,54,2,19,222,33, +38,0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42,41,36,34,27, +249,22,189,13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,65, +248,22,90,23,196,2,27,248,22,99,23,197,1,27,249,22,189,13,2,37,23, +196,2,28,23,193,2,87,94,23,194,1,249,22,65,248,22,90,23,196,2,27, +248,22,99,23,197,1,27,249,22,189,13,2,37,23,196,2,28,23,193,2,87, +94,23,194,1,249,22,65,248,22,90,23,196,2,248,2,36,248,22,99,23,197, +1,248,22,75,194,248,22,75,194,248,22,75,194,32,39,89,162,43,36,54,2, +19,222,33,40,28,248,22,73,248,22,67,23,195,2,249,22,7,9,248,22,66, +195,91,159,37,11,90,161,37,35,11,27,248,22,67,23,197,2,28,248,22,73, +248,22,67,23,195,2,249,22,7,9,248,22,66,195,91,159,37,11,90,161,37, +35,11,27,248,22,67,23,197,2,28,248,22,73,248,22,67,23,195,2,249,22, +7,9,248,22,66,195,91,159,37,11,90,161,37,35,11,248,2,39,248,22,67, +23,197,2,249,22,7,249,22,65,248,22,66,23,200,1,23,197,1,195,249,22, +7,249,22,65,248,22,66,23,200,1,23,197,1,195,249,22,7,249,22,65,248, +22,66,23,200,1,23,197,1,195,27,248,2,36,23,195,1,28,194,192,248,2, +39,193,87,95,28,248,22,171,4,195,12,250,22,132,9,2,20,6,20,20,114, +101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,197,28, +24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250,22,139,2,80, +159,41,42,37,248,22,145,14,247,22,186,11,11,28,23,193,2,192,87,94,23, +193,1,27,247,22,123,87,94,250,22,137,2,80,159,42,42,37,248,22,145,14, +247,22,186,11,195,192,250,22,137,2,195,198,66,97,116,116,97,99,104,251,211, +197,198,199,10,28,192,250,22,131,9,11,196,195,248,22,129,9,194,28,249,22, +165,6,194,6,1,1,46,2,16,28,249,22,165,6,194,6,2,2,46,46,62, +117,112,192,28,249,22,166,8,248,22,67,23,200,2,23,197,1,28,249,22,164, +8,248,22,66,23,200,2,23,196,1,251,22,129,9,2,20,6,26,26,99,121, +99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116,32,126,101,58, +32,126,101,23,200,1,249,22,2,22,67,248,22,80,249,22,65,23,206,1,23, +202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,65,248,22,145,14, +247,22,186,11,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40,249,22, +27,11,80,158,44,39,22,153,4,23,196,1,249,247,22,190,4,23,198,1,248, +22,54,248,22,143,13,23,198,1,87,94,28,28,248,22,139,13,23,197,2,10, +248,22,177,4,23,197,2,12,28,23,198,2,250,22,131,9,11,6,15,15,98, +97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,201,2,250,22,132,9, +2,20,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32,111,114,32,112, +97,116,104,23,199,2,28,28,248,22,63,23,197,2,249,22,164,8,248,22,66, +23,199,2,2,3,11,248,22,172,4,248,22,90,197,28,28,248,22,63,23,197, +2,249,22,164,8,248,22,66,23,199,2,66,112,108,97,110,101,116,11,87,94, +28,207,12,20,14,159,80,158,37,39,250,80,158,40,40,249,22,27,11,80,158, +42,39,22,186,11,23,197,1,90,161,36,35,10,249,22,154,4,21,94,2,21, +6,18,18,112,108,97,110,101,116,47,114,101,115,111,108,118,101,114,46,115,115, +1,27,112,108,97,110,101,116,45,109,111,100,117,108,101,45,110,97,109,101,45, +114,101,115,111,108,118,101,114,12,251,211,199,200,201,202,87,94,23,193,1,27, +89,162,8,44,36,45,79,115,104,111,119,45,99,111,108,108,101,99,116,105,111, +110,45,101,114,114,223,6,33,44,27,28,248,22,53,23,199,2,27,250,22,139, +2,80,159,43,43,37,249,22,65,23,204,2,247,22,180,13,11,28,23,193,2, +192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159,44,48,36, +248,22,56,23,204,2,11,27,251,80,158,47,50,2,20,23,202,1,28,248,22, +73,23,199,2,23,199,2,248,22,66,23,199,2,28,248,22,73,23,199,2,9, +248,22,67,23,199,2,249,22,157,13,23,195,1,28,248,22,73,23,197,1,87, +94,23,197,1,6,7,7,109,97,105,110,46,115,115,249,22,182,6,23,199,1, +6,3,3,46,115,115,28,248,22,159,6,23,199,2,87,94,23,194,1,27,248, +80,159,41,55,36,23,201,2,27,250,22,139,2,80,159,44,43,37,249,22,65, +23,205,2,23,199,2,11,28,23,193,2,192,87,94,23,193,1,91,159,37,11, +90,161,37,35,11,249,80,159,45,48,36,23,204,2,11,250,22,1,22,157,13, +23,199,1,249,22,79,249,22,2,32,0,89,162,8,44,36,43,9,222,33,45, +23,200,1,248,22,75,23,200,1,28,248,22,139,13,23,199,2,87,94,23,194, +1,28,248,22,162,13,23,199,2,23,198,2,248,22,75,6,26,26,32,40,97, +32,112,97,116,104,32,109,117,115,116,32,98,101,32,97,98,115,111,108,117,116, +101,41,28,249,22,164,8,248,22,66,23,201,2,2,21,27,250,22,139,2,80, +159,43,43,37,249,22,65,23,204,2,247,22,180,13,11,28,23,193,2,192,87, +94,23,193,1,91,159,38,11,90,161,37,35,11,249,80,159,45,48,36,248,22, +90,23,205,2,11,90,161,36,37,11,28,248,22,73,248,22,92,23,204,2,28, +248,22,73,23,194,2,249,22,191,13,0,8,35,114,120,34,91,46,93,34,23, +196,2,11,10,27,27,28,23,197,2,249,22,79,28,248,22,73,248,22,92,23, +208,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,79,249,22,2,80, +159,51,56,36,248,22,92,23,211,2,23,197,2,28,248,22,73,23,196,2,248, +22,75,23,197,2,23,195,2,251,80,158,49,50,2,20,23,204,1,248,22,66, +23,198,2,248,22,67,23,198,1,249,22,157,13,23,195,1,28,23,198,1,87, +94,23,196,1,23,197,1,28,248,22,73,23,197,1,87,94,23,197,1,6,7, +7,109,97,105,110,46,115,115,28,249,22,191,13,0,8,35,114,120,34,91,46, +93,34,23,199,2,23,197,1,249,22,182,6,23,199,1,6,3,3,46,115,115, +28,249,22,164,8,248,22,66,23,201,2,64,102,105,108,101,249,22,164,13,248, +22,168,13,248,22,90,23,202,2,248,80,159,42,55,36,23,202,2,12,87,94, +28,28,248,22,139,13,23,194,2,10,248,22,181,7,23,194,2,87,94,23,200, +1,12,28,23,200,2,250,22,131,9,67,114,101,113,117,105,114,101,249,22,143, +7,6,17,17,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,126,97, +28,23,198,2,248,22,66,23,199,2,6,0,0,23,203,1,87,94,23,200,1, +250,22,132,9,2,20,249,22,143,7,6,13,13,109,111,100,117,108,101,32,112, +97,116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0,0,23,201,2, +27,28,248,22,181,7,23,195,2,249,22,186,7,23,196,2,35,249,22,166,13, +248,22,167,13,23,197,2,11,27,28,248,22,181,7,23,196,2,249,22,186,7, +23,197,2,36,248,80,158,42,51,23,195,2,91,159,38,11,90,161,38,35,11, +28,248,22,181,7,23,199,2,250,22,7,2,22,249,22,186,7,23,203,2,37, +2,22,248,22,160,13,23,198,2,87,95,23,195,1,23,193,1,27,28,248,22, +181,7,23,200,2,249,22,186,7,23,201,2,38,249,80,158,47,52,23,197,2, +5,0,27,28,248,22,181,7,23,201,2,249,22,186,7,23,202,2,39,248,22, +172,4,23,200,2,27,27,250,22,139,2,80,159,51,42,37,248,22,145,14,247, +22,186,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,123,87,94,250, +22,137,2,80,159,52,42,37,248,22,145,14,247,22,186,11,195,192,87,95,28, +23,209,1,27,250,22,139,2,23,197,2,197,11,28,23,193,1,12,87,95,27, +27,28,248,22,17,80,159,51,45,37,80,159,50,45,37,247,22,19,250,22,25, +248,22,23,23,197,2,80,159,53,44,37,23,196,1,27,248,22,145,14,247,22, +186,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54,9,226,12,11, +2,3,33,46,23,195,1,23,196,1,248,28,248,22,17,80,159,50,45,37,32, +0,89,162,43,36,41,9,222,33,47,80,159,49,57,36,89,162,43,35,50,9, +227,14,9,8,4,3,33,48,250,22,137,2,23,197,1,197,10,12,28,28,248, +22,181,7,23,202,1,11,27,248,22,159,6,23,208,2,28,192,192,28,248,22, +63,23,208,2,249,22,164,8,248,22,66,23,210,2,2,21,11,250,22,137,2, +80,159,50,43,37,28,248,22,159,6,23,210,2,249,22,65,23,211,1,248,80, +159,53,55,36,23,213,1,87,94,23,210,1,249,22,65,23,211,1,247,22,180, +13,252,22,183,7,23,208,1,23,207,1,23,205,1,23,203,1,201,12,193,91, +159,37,10,90,161,36,35,10,11,90,161,36,36,10,83,158,38,20,96,96,2, +20,89,162,8,44,36,50,9,224,2,0,33,42,89,162,43,38,48,9,223,1, +33,43,89,162,43,39,8,30,9,225,2,3,0,33,49,208,87,95,248,22,152, +4,248,80,159,37,49,37,247,22,186,11,248,22,190,4,80,159,36,36,37,248, +22,177,12,80,159,36,41,36,159,35,20,103,159,35,16,1,11,16,0,83,158, +41,20,100,143,66,35,37,98,111,111,116,29,11,11,11,11,10,10,36,80,158, +35,35,20,103,159,39,16,19,2,1,2,2,30,2,4,72,112,97,116,104,45, +115,116,114,105,110,103,63,10,30,2,4,75,112,97,116,104,45,97,100,100,45, +115,117,102,102,105,120,7,30,2,5,1,20,112,97,114,97,109,101,116,101,114, +105,122,97,116,105,111,110,45,107,101,121,4,30,2,5,1,23,101,120,116,101, +110,100,45,112,97,114,97,109,101,116,101,114,105,122,97,116,105,111,110,3,2, +6,2,7,2,8,2,9,2,10,2,11,2,12,2,13,2,14,30,2,4,69, +45,102,105,110,100,45,99,111,108,0,30,2,4,76,110,111,114,109,97,108,45, +99,97,115,101,45,112,97,116,104,6,30,2,4,79,112,97,116,104,45,114,101, +112,108,97,99,101,45,115,117,102,102,105,120,9,2,15,16,0,11,11,16,0, +35,16,0,35,16,11,2,9,2,10,2,7,2,8,2,11,2,12,2,2,2, +6,2,1,2,14,2,13,46,11,11,38,35,11,11,16,1,2,15,16,1,11, +16,1,2,15,36,36,36,11,11,16,0,16,0,16,0,35,35,11,11,11,16, +0,16,0,16,0,35,35,16,0,16,16,83,158,35,16,2,89,162,43,36,44, +9,223,0,33,23,80,159,35,57,36,83,158,35,16,2,89,162,43,36,44,9, +223,0,33,24,80,159,35,56,36,83,158,35,16,2,89,162,43,36,48,67,103, +101,116,45,100,105,114,223,0,33,25,80,159,35,55,36,83,158,35,16,2,89, +162,43,37,48,68,119,105,116,104,45,100,105,114,223,0,33,26,80,159,35,54, +36,83,158,35,16,2,248,22,178,7,69,115,111,45,115,117,102,102,105,120,80, +159,35,35,36,83,158,35,16,2,89,162,43,37,59,2,2,223,0,33,35,80, +159,35,36,36,83,158,35,16,2,32,0,89,162,8,44,36,41,2,6,222,192, +80,159,35,41,36,83,158,35,16,2,247,22,126,80,159,35,42,36,83,158,35, +16,2,247,22,125,80,159,35,43,36,83,158,35,16,2,247,22,61,80,159,35, +44,36,83,158,35,16,2,248,22,18,74,109,111,100,117,108,101,45,108,111,97, +100,105,110,103,80,159,35,45,36,83,158,35,16,2,11,80,158,35,46,83,158, +35,16,2,11,80,158,35,47,83,158,35,16,2,32,0,89,162,43,37,44,2, +13,222,33,41,80,159,35,48,36,83,158,35,16,2,89,162,8,44,36,44,2, +14,223,0,33,50,80,159,35,49,36,83,158,35,16,2,89,162,43,35,43,2, +15,223,0,33,51,80,159,35,53,36,95,29,94,2,3,68,35,37,107,101,114, +110,101,108,11,29,94,2,3,69,35,37,109,105,110,45,115,116,120,11,2,4, +9,9,9,35,0}; + EVAL_ONE_SIZED_STR((char *)expr, 4099); } diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index b3e1720277..645e0aabe7 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -1171,6 +1171,22 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo) } else { if (env->shadowed_syntax) scheme_hash_set(env->shadowed_syntax, n, NULL); + + if (rn) { + /* If the syntax binding is a rename transformer, need to install + a mapping. */ + Scheme_Object *v; + v = scheme_lookup_in_table(env->syntax, (const char *)n); + if (v) { + v = SCHEME_PTR_VAL(v); + if (SAME_TYPE(SCHEME_TYPE(v), scheme_id_macro_type)) { + scheme_install_free_id_rename(n, + SCHEME_PTR1_VAL(v), + rn, + scheme_make_integer(env->phase)); + } + } + } } } @@ -1959,7 +1975,8 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec existing rename. */ if (!SCHEME_HASHTP((Scheme_Object *)env) && env->module && (mode < 2)) { Scheme_Object *mod, *nm = id; - mod = scheme_stx_module_name(&nm, scheme_make_integer(env->phase), NULL, NULL, NULL, NULL, NULL); + mod = scheme_stx_module_name(0, &nm, scheme_make_integer(env->phase), NULL, NULL, NULL, + NULL, NULL, NULL, NULL); if (mod /* must refer to env->module, otherwise there would have been an error before getting here */ && NOT_SAME_OBJ(nm, sym)) @@ -2634,7 +2651,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, } src_find_id = find_id; - modidx = scheme_stx_module_name(&find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, NULL, NULL); + modidx = scheme_stx_module_name(0, &find_id, scheme_make_integer(phase), NULL, NULL, &mod_defn_phase, + NULL, NULL, NULL, NULL); /* Used out of context? */ if (SAME_OBJ(modidx, scheme_undefined)) { @@ -2646,9 +2664,10 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags, } if (modidx) { - if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) + if (!(flags & SCHEME_OUT_OF_CONTEXT_OK)) { scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id, "identifier used out of context"); + } if (flags & SCHEME_OUT_OF_CONTEXT_LOCAL) return scheme_make_local(scheme_local_type, 0, 0); return NULL; @@ -2910,7 +2929,8 @@ int scheme_check_context(Scheme_Env *env, Scheme_Object *name, Scheme_Object *ok if (mod && SCHEME_TRUEP(mod) && NOT_SAME_OBJ(ok_modidx, mod)) { return 1; } else { - mod = scheme_stx_module_name(&id, scheme_make_integer(env->phase), NULL, NULL, NULL, NULL, NULL); + mod = scheme_stx_module_name(0, &id, scheme_make_integer(env->phase), NULL, NULL, NULL, + NULL, NULL, NULL, NULL); if (SAME_OBJ(mod, scheme_undefined)) return 1; } diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index 0b0ed9010a..f59f5ff98c 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -661,6 +661,9 @@ call_error(char *buffer, int len, Scheme_Object *exn) scheme_optimize_context_to_string(scheme_current_thread->constant_folding), buffer); scheme_longjmp(scheme_error_buf, 1); + } else if (scheme_current_thread->reading_delayed) { + scheme_current_thread->reading_delayed = exn; + scheme_longjmp(scheme_error_buf, 1); } else { mz_jmp_buf savebuf; Scheme_Object *p[2], *display_handler, *escape_handler, *v; @@ -1592,7 +1595,8 @@ static void do_wrong_syntax(const char *where, if (scheme_current_thread->current_local_env) phase = scheme_current_thread->current_local_env->genv->phase; else phase = 0; - scheme_stx_module_name(&first, scheme_make_integer(phase), &mod, &nomwho, NULL, NULL, NULL); + scheme_stx_module_name(0, &first, scheme_make_integer(phase), &mod, &nomwho, + NULL, NULL, NULL, NULL, NULL); } } } else { diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index feada2d58b..78d4d555b2 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -6070,7 +6070,8 @@ static Scheme_Object *check_top(const char *when, Scheme_Object *form, Scheme_Co if (NOT_SAME_OBJ(tl_id, SCHEME_STX_SYM(symbol))) { /* Since the module has a rename for this id, it's certainly defined. */ } else { - modidx = scheme_stx_module_name(&symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, NULL, NULL); + modidx = scheme_stx_module_name(0, &symbol, scheme_make_integer(env->genv->phase), NULL, NULL, NULL, + NULL, NULL, NULL, NULL); if (modidx) { /* If it's an access path, resolve it: */ if (env->genv->module @@ -6535,7 +6536,7 @@ scheme_compile_expand_block(Scheme_Object *forms, Scheme_Comp_Env *env, names, expr, new_env->genv->exp_env, new_env->insp, rec, drec, new_env, new_env, - &pos); + &pos, rib); } /* Remember extended environment */ @@ -9800,7 +9801,7 @@ local_eval(int argc, Scheme_Object **argv) scheme_bind_syntaxes("local syntax definition", names, expr, stx_env->genv->exp_env, stx_env->insp, &rec, 0, stx_env, stx_env, - &pos); + &pos, rib); } /* Extend shared rib with renamings */ diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 2398ea2ba4..a8cba4d810 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -116,7 +116,8 @@ static void eval_exptime(Scheme_Object *names, int count, Scheme_Env *genv, Scheme_Comp_Env *env, Resolve_Prefix *rp, int let_depth, int shift, Scheme_Bucket_Table *syntax, int for_stx, - Scheme_Object *certs); + Scheme_Object *certs, + Scheme_Object *free_id_rename_rn); static Scheme_Module_Exports *make_module_exports(); @@ -3947,7 +3948,7 @@ void scheme_run_module_exptime(Scheme_Env *menv, int set_ns) eval_exptime(names, scheme_list_length(names), e, exp_env, rhs_env, rp, let_depth, 1, (for_stx ? for_stx_globals : syntax), for_stx, - NULL); + NULL, scheme_false); } if (set_ns) { @@ -4401,13 +4402,15 @@ static void *eval_exptime_k(void) Resolve_Prefix *rp; int let_depth, shift; Scheme_Bucket_Table *syntax; + Scheme_Object *free_id_rename_rn; names = (Scheme_Object *)p->ku.k.p1; expr = (Scheme_Object *)p->ku.k.p2; genv = (Scheme_Env *)SCHEME_CAR((Scheme_Object *)p->ku.k.p3); comp_env = (Scheme_Comp_Env *)SCHEME_CDR((Scheme_Object *)p->ku.k.p3); - rp = (Resolve_Prefix *)SCHEME_CAR((Scheme_Object *)p->ku.k.p4); - syntax = (Scheme_Bucket_Table *)SCHEME_CDR((Scheme_Object *)p->ku.k.p4); + free_id_rename_rn = SCHEME_CAR((Scheme_Object *)p->ku.k.p4); + rp = (Resolve_Prefix *)SCHEME_CAR(SCHEME_CDR((Scheme_Object *)p->ku.k.p4)); + syntax = (Scheme_Bucket_Table *)SCHEME_CDR(SCHEME_CDR((Scheme_Object *)p->ku.k.p4)); count = p->ku.k.i1; let_depth = p->ku.k.i2; shift = p->ku.k.i3; @@ -4420,7 +4423,8 @@ static void *eval_exptime_k(void) p->ku.k.p4 = NULL; p->ku.k.p5 = NULL; - eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, for_stx, certs); + eval_exptime(names, count, expr, genv, comp_env, rp, let_depth, shift, syntax, for_stx, + certs, free_id_rename_rn); return NULL; } @@ -4441,7 +4445,8 @@ static void eval_exptime(Scheme_Object *names, int count, Scheme_Env *genv, Scheme_Comp_Env *comp_env, Resolve_Prefix *rp, int let_depth, int shift, Scheme_Bucket_Table *syntax, - int for_stx, Scheme_Object *certs) + int for_stx, Scheme_Object *certs, + Scheme_Object *free_id_rename_rn) { Scheme_Object *macro, *vals, *name, **save_runstack; int i, g, depth; @@ -4454,6 +4459,7 @@ static void eval_exptime(Scheme_Object *names, int count, vals = scheme_make_pair((Scheme_Object *)genv, (Scheme_Object *)comp_env); p->ku.k.p3 = vals; vals = scheme_make_pair((Scheme_Object *)rp, (Scheme_Object *)syntax); + vals = scheme_make_pair(free_id_rename_rn, vals); p->ku.k.p4 = vals; p->ku.k.i1 = count; p->ku.k.i2 = let_depth; @@ -4511,6 +4517,11 @@ static void eval_exptime(Scheme_Object *names, int count, macro = scheme_alloc_small_object(); macro->type = scheme_macro_type; SCHEME_PTR_VAL(macro) = values[i]; + + if (SCHEME_TRUEP(free_id_rename_rn) + && SAME_TYPE(SCHEME_TYPE(values[i]), scheme_id_macro_type)) + scheme_install_free_id_rename(name, SCHEME_PTR1_VAL(values[i]), free_id_rename_rn, + scheme_make_integer(0)); } else macro = values[i]; @@ -4526,6 +4537,11 @@ static void eval_exptime(Scheme_Object *names, int count, macro = scheme_alloc_small_object(); macro->type = scheme_macro_type; SCHEME_PTR_VAL(macro) = vals; + + if (SCHEME_TRUEP(free_id_rename_rn) + && SAME_TYPE(SCHEME_TYPE(vals), scheme_id_macro_type)) + scheme_install_free_id_rename(name, SCHEME_PTR1_VAL(vals), free_id_rename_rn, + scheme_make_integer(0)); } else macro = vals; @@ -6170,6 +6186,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, Optimize_Info *oi; int count = 0; int for_stx; + int use_post_ex = 0; for_stx = scheme_stx_module_eq(define_for_syntaxes_stx, fst, 0); @@ -6233,6 +6250,7 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, scheme_extend_module_rename(for_stx ? post_ex_et_rn : post_ex_rn, self_modidx, name, name, self_modidx, name, for_stx ? 1 : 0, NULL, NULL, 0); *all_simple_renames = 0; + use_post_ex = 1; } else scheme_extend_module_rename(for_stx ? et_rn : rn, self_modidx, name, name, self_modidx, name, for_stx ? 1 : 0, NULL, NULL, 0); @@ -6304,8 +6322,9 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, eval_exptime(names, count, m, eenv->genv, rhs_env, rp, ri->max_let_depth, 0, (for_stx ? env->genv->exp_env->toplevel : env->genv->syntax), for_stx, - rec[drec].certs); - + rec[drec].certs, + for_stx ? scheme_false : (use_post_ex ? post_ex_rn : rn)); + if (rec[drec].comp) e = NULL; else { @@ -6369,11 +6388,11 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, } /* first = a list of (cons semi-expanded-expression kind) */ - /* Bound names will be re-bound at this point: */ + /* Bound names will not be re-bound at this point: */ if (rec[drec].comp || (rec[drec].depth != -2)) { scheme_seal_module_rename_set(rn_set, STX_SEAL_BOUND); - scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_BOUND); } + scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_BOUND); /* Pass 2 */ SCHEME_EXPAND_OBSERVE_NEXT_GROUP(observer); @@ -6534,8 +6553,8 @@ static Scheme_Object *do_module_begin(Scheme_Object *form, Scheme_Comp_Env *env, if (rec[drec].comp || (rec[drec].depth != -2)) { scheme_seal_module_rename_set(rn_set, STX_SEAL_ALL); - scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_ALL); } + scheme_seal_module_rename_set(post_ex_rn_set, STX_SEAL_ALL); /* Compute provides for re-provides and all-defs-out: */ reprovide_kernel = compute_reprovides(all_provided, @@ -8441,7 +8460,7 @@ void add_single_require(Scheme_Module_Exports *me, /* from module */ exets ? exets[j] : 0, src_phase_index, pt->phase_index, - for_unmarshal || (!has_context && can_save_marshal)); + (for_unmarshal || (!has_context && can_save_marshal)) ? 1 : 0); } } } diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index 64c2337deb..53565447b8 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -1649,6 +1649,7 @@ static int thread_val_MARK(void *p) { gcMARK(pr->current_mt); gcMARK(pr->constant_folding); + gcMARK(pr->reading_delayed); gcMARK(pr->overflow_reply); @@ -1759,6 +1760,7 @@ static int thread_val_FIXUP(void *p) { gcFIXUP(pr->current_mt); gcFIXUP(pr->constant_folding); + gcFIXUP(pr->reading_delayed); gcFIXUP(pr->overflow_reply); @@ -5036,6 +5038,7 @@ static int mark_rename_table_MARK(void *p) { gcMARK(rn->plus_kernel_nominal_source); gcMARK(rn->set_identity); gcMARK(rn->marked_names); + gcMARK(rn->free_id_renames); return gcBYTES_TO_WORDS(sizeof(Module_Renames)); } @@ -5050,6 +5053,7 @@ static int mark_rename_table_FIXUP(void *p) { gcFIXUP(rn->plus_kernel_nominal_source); gcFIXUP(rn->set_identity); gcFIXUP(rn->marked_names); + gcFIXUP(rn->free_id_renames); return gcBYTES_TO_WORDS(sizeof(Module_Renames)); } diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index a49b33ab01..66afce57cf 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -662,6 +662,7 @@ thread_val { gcMARK(pr->current_mt); gcMARK(pr->constant_folding); + gcMARK(pr->reading_delayed); gcMARK(pr->overflow_reply); @@ -2068,6 +2069,7 @@ mark_rename_table { gcMARK(rn->plus_kernel_nominal_source); gcMARK(rn->set_identity); gcMARK(rn->marked_names); + gcMARK(rn->free_id_renames); size: gcBYTES_TO_WORDS(sizeof(Module_Renames)); } diff --git a/src/mzscheme/src/print.c b/src/mzscheme/src/print.c index 8bf974c8bd..5a67a701d4 100644 --- a/src/mzscheme/src/print.c +++ b/src/mzscheme/src/print.c @@ -120,6 +120,8 @@ static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, Prin #define PRINTABLE_STRUCT(obj, pp) (scheme_inspector_sees_part(obj, pp->inspector, -1)) #define SCHEME_PREFABP(obj) (((Scheme_Structure *)(obj))->stype->prefab_key) +#define SCHEME_HASHTPx(obj) ((SCHEME_HASHTP(obj) && !(MZ_OPT_HASH_KEY(&(((Scheme_Hash_Table *)obj)->iso)) & 0x1))) + #define HAS_SUBSTRUCT(obj, qk) \ (SCHEME_PAIRP(obj) \ || SCHEME_MUTABLE_PAIRP(obj) \ @@ -129,7 +131,7 @@ static Scheme_Object *writable_struct_subs(Scheme_Object *s, int for_write, Prin && SCHEME_STRUCTP(obj) \ && PRINTABLE_STRUCT(obj, pp), 0)) \ || (qk(SCHEME_STRUCTP(obj) && scheme_is_writable_struct(obj), 0)) \ - || (qk(pp->print_hash_table, 1) && (SCHEME_HASHTP(obj) || SCHEME_HASHTRP(obj)))) + || (qk(pp->print_hash_table, 1) && (SCHEME_HASHTPx(obj) || SCHEME_HASHTRP(obj)))) #define ssQUICK(x, isbox) x #define ssQUICKp(x, isbox) (pp ? x : isbox) #define ssALL(x, isbox) 1 @@ -486,7 +488,7 @@ static int check_cycles(Scheme_Object *obj, int for_write, Scheme_Hash_Table *ht } } } - } else if (SCHEME_HASHTP(obj)) { + } else if (SCHEME_HASHTPx(obj)) { /* got here => printable */ Scheme_Hash_Table *t; Scheme_Object **keys, **vals, *val; @@ -591,7 +593,7 @@ static int check_cycles_fast(Scheme_Object *obj, PrintParams *pp, int *fast_chec } else cycle = 0; } else if (pp->print_hash_table - && SCHEME_HASHTP(obj)) { + && SCHEME_HASHTPx(obj)) { if (!((Scheme_Hash_Table *)obj)->count) cycle = 0; else @@ -702,7 +704,7 @@ static void setup_graph_table(Scheme_Object *obj, int for_write, Scheme_Hash_Tab setup_graph_table(((Scheme_Structure *)obj)->slots[i], for_write, ht, counter, pp); } } - } else if (pp && SCHEME_HASHTP(obj)) { /* got here => printable */ + } else if (pp && SCHEME_HASHTPx(obj)) { /* got here => printable */ Scheme_Hash_Table *t; Scheme_Object **keys, **vals, *val; int i; @@ -1831,7 +1833,7 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, } } else if ((compact || pp->print_hash_table) - && (SCHEME_HASHTP(obj) || SCHEME_HASHTRP(obj))) + && (SCHEME_HASHTPx(obj) || SCHEME_HASHTRP(obj))) { Scheme_Hash_Table *t; Scheme_Hash_Tree *tr; @@ -1918,6 +1920,12 @@ print(Scheme_Object *obj, int notdisplay, int compact, Scheme_Hash_Table *ht, closed = 1; } + else if (compact && SCHEME_HASHTP(obj)) + { + /* since previous case didn't catch this table, it has a 0x1 flag + and should be marshalled as #t */ + print_compact(pp, CPT_TRUE); + } else if (SAME_OBJ(obj, scheme_true)) { if (compact) diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index 1c65afc98a..5823bb7042 100644 --- a/src/mzscheme/src/read.c +++ b/src/mzscheme/src/read.c @@ -5322,6 +5322,7 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in unsigned char *st; Scheme_Object * volatile port; Scheme_Object * volatile v; + Scheme_Object * volatile v_exn; Scheme_Hash_Table ** volatile ht; mz_jmp_buf newbuf, * volatile savebuf; @@ -5417,12 +5418,16 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in /* Perform the read, catching escapes so we can clean up: */ savebuf = scheme_current_thread->error_buf; scheme_current_thread->error_buf = &newbuf; + scheme_current_thread->reading_delayed = scheme_true; if (scheme_setjmp(newbuf)) { v = NULL; + v_exn = scheme_current_thread->reading_delayed; } else { v = read_compact(rp, 0); + v_exn = NULL; } scheme_current_thread->error_buf = savebuf; + scheme_current_thread->reading_delayed = NULL; /* Clean up: */ @@ -5452,6 +5457,8 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in return v; } else { + if (v_exn) + scheme_raise(v_exn); scheme_longjmp(*scheme_current_thread->error_buf, 1); return NULL; } diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index ef64736e32..3c7920e318 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -743,6 +743,11 @@ Scheme_Object *scheme_stx_remove_extra_marks(Scheme_Object *o, Scheme_Object *re Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv); +void scheme_install_free_id_rename(Scheme_Object *id, + Scheme_Object *orig_id, + Scheme_Object *rename_rib, + Scheme_Object *phase); + #define mzMOD_RENAME_TOPLEVEL 0 #define mzMOD_RENAME_NORMAL 1 #define mzMOD_RENAME_MARKED 2 @@ -763,11 +768,11 @@ void scheme_seal_module_rename_set(Scheme_Object *rns, int level); #define STX_SEAL_ALL 2 Scheme_Object *scheme_make_module_rename(Scheme_Object *phase, int kind, Scheme_Hash_Table *mns); -void scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *modname, - Scheme_Object *locname, Scheme_Object *exname, - Scheme_Object *nominal_src, Scheme_Object *nominal_ex, - int mod_phase, Scheme_Object *src_phase_index, - Scheme_Object *nom_export_phase, int drop_for_marshal); +Scheme_Object* scheme_extend_module_rename(Scheme_Object *rn, Scheme_Object *modname, + Scheme_Object *locname, Scheme_Object *exname, + Scheme_Object *nominal_src, Scheme_Object *nominal_ex, + int mod_phase, Scheme_Object *src_phase_index, + Scheme_Object *nom_export_phase, int drop_for_marshal); void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, struct Scheme_Module_Phase_Exports *pt, Scheme_Object *unmarshal_phase_index, @@ -797,12 +802,15 @@ Scheme_Object *scheme_flatten_syntax_list(Scheme_Object *lst, int *islist); int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase); int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase, Scheme_Object *asym); Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase); -Scheme_Object *scheme_stx_module_name(Scheme_Object **name, Scheme_Object *phase, +Scheme_Object *scheme_stx_module_name(int recur, + Scheme_Object **name, Scheme_Object *phase, Scheme_Object **nominal_modidx, Scheme_Object **nominal_name, Scheme_Object **mod_phase, Scheme_Object **src_phase_index, - Scheme_Object **nominal_src_phase); + Scheme_Object **nominal_src_phase, + Scheme_Object **lex_env, + int *_sealed); Scheme_Object *scheme_stx_moduleless_env(Scheme_Object *a); int scheme_stx_parallel_is_used(Scheme_Object *sym, Scheme_Object *stx); @@ -2111,7 +2119,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Compile_Expand_Info *rec, int drec, Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, - int *_pos); + int *_pos, Scheme_Object *rename_rib); int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env); typedef struct SFS_Info { diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index d12e51749b..6aabc11135 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.5.1" +#define MZSCHEME_VERSION "4.1.5.2" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 5 -#define MZSCHEME_VERSION_W 1 +#define MZSCHEME_VERSION_W 2 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 62ed20871f..7f70231c20 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -150,6 +150,11 @@ typedef struct Module_Renames { set to a gensym created for the binding */ Scheme_Object *unmarshal_info; /* stores some renamings as infomation needed to consult imported modules and restore renames from their exports */ + Scheme_Hash_Table *free_id_renames; /* like `ht', but only for free-id=? checking, + and targets can also include: + id => resolve id (but cache if possible; never appears after simplifying) + (box (cons sym #f)) => top-level binding + (box (cons sym sym)) => lexical binding */ } Module_Renames; typedef struct Module_Renames_Set { @@ -209,6 +214,8 @@ static Module_Renames *krn; #define SCHEME_RENAMESP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_type)) #define SCHEME_RENAMES_SETP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_rename_table_set_type)) +#define SCHEME_MODIDXP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_module_index_type)) + /* Wraps: A wrap is a list of wrap-elems and wrap-chunks. A wrap-chunk is a @@ -221,16 +228,23 @@ static Module_Renames *krn; - A wrap-elem <-num> is a certificate-only mark (doesn't conttribute to id equivalence) - - A wrap-elem (vector ... ...) is a lexical rename - env (sym var var-resolved + - A wrap-elem (vector ... ...) is a lexical rename + env (sym var : ->pos) void => not yet computed - or #f sym => mark check done, - var-resolved is answer to replace #f + or #f sym => var-resolved is answer to replace #f for nozero skipped ribs (rlistof (rcons skipped sym)) => generalization of sym - (mcons var-resolved next) => depends on unsealed rib - - A wrap-elem (vector ... ...) is also a lexical rename - var resolved + (mcons var-resolved next) => depends on unsealed rib, + will be cleared when rib set + or: + (cons (cons )) => + free-id=? renaming to on match + - A wrap-elem (vector ... ...) is also a lexical rename + var resolved: sym or (cons ), + where is module/lexical binding info: + (cons #f) => top-level binding + (cons ) => lexical binding + (vector ...) => module-binding where the variables have already been resolved and filtered (no mark or lexical-env comparison needed with the remaining wraps) @@ -813,7 +827,7 @@ static int maybe_add_chain_cache(Scheme_Stx *stx) if (SCHEME_VECTORP(p)) { skipable++; } else if (SCHEME_NUMBERP(p) || SCHEME_SYMBOLP(p)) { - /* ok to skip, but don't count toward needing a cache */ + /* ok to skip, but don<'t count toward needing a cache */ } else if (SCHEME_HASHTP(p)) { /* Hack: we store the depth of the table in the chain in the `size' fields, at least until the table is initialized: */ @@ -1007,6 +1021,8 @@ Scheme_Object *scheme_add_remove_mark(Scheme_Object *o, Scheme_Object *m) /******************** lexical renames ********************/ +#define RENAME_HT_THRESHOLD 15 + Scheme_Object *scheme_make_rename(Scheme_Object *newname, int c) { Scheme_Object *v; @@ -1014,7 +1030,7 @@ Scheme_Object *scheme_make_rename(Scheme_Object *newname, int c) v = scheme_make_vector((2 * c) + 2, NULL); SCHEME_VEC_ELS(v)[0] = newname; - if (c > 15) { + if (c > RENAME_HT_THRESHOLD) { Scheme_Hash_Table *ht; ht = scheme_make_hash_table(SCHEME_hash_ptr); SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht; @@ -1028,6 +1044,21 @@ Scheme_Object *scheme_make_rename(Scheme_Object *newname, int c) return v; } +static void maybe_install_rename_hash_table(Scheme_Object *v) +{ + if (SCHEME_VEC_SIZE(v) > ((2 * RENAME_HT_THRESHOLD) + 2)) { + Scheme_Hash_Table *ht; + int i; + + ht = scheme_make_hash_table(SCHEME_hash_ptr); + MZ_OPT_HASH_KEY(&(ht->iso)) |= 0x1; + for (i = (SCHEME_VEC_SIZE(v) - 2) >> 1; i--; ) { + scheme_hash_set(ht, SCHEME_VEC_ELS(v)[i + 2], scheme_make_integer(i)); + } + SCHEME_VEC_ELS(v)[1] = (Scheme_Object *)ht; + } +} + void scheme_set_rename(Scheme_Object *rnm, int pos, Scheme_Object *oldname) { /* Every added name must be symbolicly distinct! */ @@ -1332,21 +1363,24 @@ static Scheme_Object *phase_to_index(Scheme_Object *phase) return phase; } -void scheme_extend_module_rename(Scheme_Object *mrn, - Scheme_Object *modname, /* actual source module */ - Scheme_Object *localname, /* name in local context */ - Scheme_Object *exname, /* name in definition context */ - Scheme_Object *nominal_mod, /* nominal source module */ - Scheme_Object *nominal_ex, /* nominal import before local renaming */ - int mod_phase, /* phase of source defn */ - Scheme_Object *src_phase_index, /* nominal import phase */ - Scheme_Object *nom_phase, /* nominal export phase */ - int unmarshal_drop) /* 1 => can be reconstructed from unmarshal info */ +Scheme_Object *scheme_extend_module_rename(Scheme_Object *mrn, + Scheme_Object *modname, /* actual source module */ + Scheme_Object *localname, /* name in local context */ + Scheme_Object *exname, /* name in definition context */ + Scheme_Object *nominal_mod, /* nominal source module */ + Scheme_Object *nominal_ex, /* nominal import before local renaming */ + int mod_phase, /* phase of source defn */ + Scheme_Object *src_phase_index, /* nominal import phase */ + Scheme_Object *nom_phase, /* nominal export phase */ + int mode) /* 1 => can be reconstructed from unmarshal info + 2 => free-id=? renaming + 3 => return info */ { Scheme_Object *elem; Scheme_Object *phase_index; - check_not_sealed((Module_Renames *)mrn); + if (mode != 3) + check_not_sealed((Module_Renames *)mrn); phase_index = phase_to_index(((Module_Renames *)mrn)->phase); if (!src_phase_index) @@ -1393,15 +1427,21 @@ void scheme_extend_module_rename(Scheme_Object *mrn, elem = CONS(modname, elem); } - if (unmarshal_drop) { + if (mode == 1) { if (!((Module_Renames *)mrn)->nomarshal_ht) { Scheme_Hash_Table *ht; ht = scheme_make_hash_table(SCHEME_hash_ptr); ((Module_Renames *)mrn)->nomarshal_ht = ht; } scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, elem); + } else if (mode == 2) { + scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, localname, elem); + } else if (mode == 3) { + return elem; } else scheme_hash_set(((Module_Renames *)mrn)->ht, localname, elem); + + return NULL; } void scheme_extend_module_rename_with_shared(Scheme_Object *rn, Scheme_Object *modidx, @@ -1613,6 +1653,8 @@ void scheme_remove_module_rename(Scheme_Object *mrn, scheme_hash_set(((Module_Renames *)mrn)->ht, localname, NULL); if (((Module_Renames *)mrn)->nomarshal_ht) scheme_hash_set(((Module_Renames *)mrn)->nomarshal_ht, localname, NULL); + if (((Module_Renames *)mrn)->free_id_renames) + scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, localname, NULL); } void scheme_list_module_rename(Scheme_Object *set, Scheme_Hash_Table *ht) @@ -1885,6 +1927,146 @@ Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib) return scheme_add_rename(o, rib); } +static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, + Scheme_Object *id, + Scheme_Object *orig_id, + int *_sealed) +{ + Scheme_Object *result; + Scheme_Object *modname; + Scheme_Object *nominal_modidx; + Scheme_Object *nominal_name; + Scheme_Object *mod_phase; + Scheme_Object *src_phase_index; + Scheme_Object *nominal_src_phase; + Scheme_Object *lex_env; + + modname = scheme_stx_module_name(1, + &orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx, + &nominal_name, + &mod_phase, + &src_phase_index, + &nominal_src_phase, + &lex_env, + _sealed); + + if (!modname) + result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), scheme_false)); + else if (SAME_OBJ(modname, scheme_undefined)) + result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), lex_env)); + else + result = scheme_extend_module_rename(mrn, + modname, + id, /* name in local context */ + orig_id, /* name in definition context */ + nominal_modidx, /* nominal source module */ + nominal_name, /* nominal import before local renaming */ + SCHEME_INT_VAL(mod_phase), /* phase of source defn */ + src_phase_index, /* nominal import phase */ + nominal_src_phase, /* nominal export phase */ + 3); + + if (*_sealed) { + /* cache the result */ + scheme_hash_set(((Module_Renames *)mrn)->free_id_renames, id, result); + } + + return result; +} + +void scheme_install_free_id_rename(Scheme_Object *id, + Scheme_Object *orig_id, + Scheme_Object *rename_rib, + Scheme_Object *phase) +{ + Scheme_Object *v = NULL, *env, *r_id; + Scheme_Lexical_Rib *rib = NULL; + + if (rename_rib && (SCHEME_RENAMESP(rename_rib) || SCHEME_RENAMES_SETP(rename_rib))) { + /* Install a Module_Rename-level free-id=? rename, instead of at + the level of a lexical-rename. In this case, id is a symbol instead + of an identifier. */ + Module_Renames *rn; + + if (SCHEME_RENAMES_SETP(rename_rib)) + rename_rib = scheme_get_module_rename_from_set(rename_rib, phase, 1); + rn = (Module_Renames *)rename_rib; + + if (!rn->free_id_renames) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + rn->free_id_renames = ht; + } + + scheme_hash_set(rn->free_id_renames, id, orig_id); + + return; + } + + env = scheme_stx_moduleless_env(id); + + if (rename_rib) { + rib = (Scheme_Lexical_Rib *)rename_rib; + } else { + WRAP_POS wl; + + WRAP_POS_INIT(wl, ((Scheme_Stx *)id)->wraps); + while (!WRAP_POS_END_P(wl)) { + v = WRAP_POS_FIRST(wl); + if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) { + break; + } if (SCHEME_RIBP(v)) { + rib = (Scheme_Lexical_Rib *)v; + while (rib) { + if (rib->rename) { + v = rib->rename; + if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) + break; + v = NULL; + } + rib = rib->next; + } + } else + v = NULL; + WRAP_POS_INC(wl); + } + } + + while (v || rib) { + if (!v) { + while (rib) { + if (rib->rename) { + v = rib->rename; + if (SCHEME_VECTORP(v) && SAME_OBJ(SCHEME_VEC_ELS(v)[0], env)) + break; + v = NULL; + } + rib = rib->next; + } + } + + if (v) { + int i, sz; + + sz = SCHEME_RENAME_LEN(v); + for (i = 0; i < sz; i++) { + r_id = SCHEME_VEC_ELS(v)[i+2]; + if (SAME_OBJ(SCHEME_STX_SYM(r_id), SCHEME_STX_VAL(id))) { + /* Install rename: */ + env = SCHEME_VEC_ELS(v)[i+sz+2]; + if (SCHEME_PAIRP(env)) env = SCHEME_CAR(env); + env = CONS(env, CONS(orig_id, phase)); + SCHEME_VEC_ELS(v)[i+sz+2] = env; + return; + } + } + } + + v = NULL; + if (rib) rib = rib->next; + } +} + Scheme_Object *scheme_stx_phase_shift_as_rename(long shift, Scheme_Object *old_midx, Scheme_Object *new_midx, Scheme_Hash_Table *export_registry) { @@ -3650,6 +3832,11 @@ XFORM_NONGCING static Scheme_Object *filter_cached_env(Scheme_Object *other_env, { Scheme_Object *p; + if (SCHEME_PAIRP(other_env)) { + /* paired with free-id=? rename */ + other_env = SCHEME_CAR(other_env); + } + if (SCHEME_MPAIRP(other_env)) { other_env = SCHEME_CAR(other_env); if (!other_env) @@ -3674,6 +3861,12 @@ static Scheme_Object *extend_cached_env(Scheme_Object *orig, Scheme_Object *othe int depends_on_unsealed_rib) { Scheme_Object *in_mpair = NULL; + Scheme_Object *free_id_rename = NULL; + + if (SCHEME_PAIRP(orig)) { + free_id_rename = SCHEME_CDR(orig); + orig = SCHEME_CAR(orig); + } if (SCHEME_MPAIRP(orig)) { in_mpair = orig; @@ -3708,12 +3901,18 @@ static Scheme_Object *extend_cached_env(Scheme_Object *orig, Scheme_Object *othe if (in_mpair) { SCHEME_CAR(in_mpair) = orig; - return in_mpair; - } else - return orig; + orig = in_mpair; + } + + if (free_id_rename) { + orig = CONS(orig, free_id_rename); + } + + return orig; } -#define QUICK_STACK_SIZE 8 +/* This needs to be a multiple of 3: */ +#define QUICK_STACK_SIZE 12 /* Although resolve_env may call itself recursively, the recursion depth is bounded (by the fact that modules can't be nested, @@ -3723,15 +3922,17 @@ 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, int *_binding_marks_skipped, - int *_depends_on_unsealed_rib, int depth) + int *_depends_on_unsealed_rib, int depth, int get_free_id_info) /* 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 the nominal source module's export, get_names[3] is set to the phase of the source definition, and get_names[4] is set to the nominal import phase index, and get_names[5] is set to the nominal export phase. - If lexically bound, result is env id, and a get_names[0] is set to scheme_undefined. - If neither, result is #f and get_names[0] is either unchanged or NULL. */ + If lexically bound, result is env id, and a get_names[0] is set to scheme_undefined; + get_names[1] is set if a free-id=? rename provides a different name for the bindig. + If neither, result is #f and get_names[0] is either unchanged or NULL; get_names[1] + is set if a free-id=? rename provides a different name. */ { WRAP_POS wraps; Scheme_Object *o_rename_stack = scheme_null, *recur_skip_ribs = skip_ribs; @@ -3745,7 +3946,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, Scheme_Object *bdg = NULL, *floating = NULL; Scheme_Hash_Table *export_registry = NULL; int mresult_skipped = -1; - int depends_on_unsealed_rib = 0; + int depends_on_unsealed_rib = 0, mresult_depends_unsealed = 0; EXPLAIN(fprintf(stderr, "%d Resolving %s [skips: %s]:\n", depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)), scheme_write_to_string(skip_ribs ? skip_ribs : scheme_false, NULL))); @@ -3759,18 +3960,21 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, while (1) { if (WRAP_POS_END_P(wraps)) { /* See rename case for info on rename_stack: */ - Scheme_Object *result, *key; + Scheme_Object *result, *result_free_rename, *key; int did_lexical = 0; EXPLAIN(fprintf(stderr, "%d Rename...\n", depth)); result = scheme_false; + result_free_rename = scheme_false; while (!SCHEME_NULLP(o_rename_stack)) { key = SCHEME_CAAR(o_rename_stack); if (SAME_OBJ(key, result)) { EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); did_lexical = 1; result = SCHEME_CDR(SCHEME_CAR(o_rename_stack)); + result_free_rename = SCHEME_CDR(result); + result = SCHEME_CAR(result); } else { EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); if (SAME_OBJ(key, scheme_true)) { @@ -3785,6 +3989,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, if (SAME_OBJ(key, result)) { EXPLAIN(fprintf(stderr, "%d Match %s\n", depth, scheme_write_to_string(key, 0))); result = rename_stack[stack_pos - 2]; + result_free_rename = rename_stack[stack_pos - 3]; did_lexical = 1; } else { EXPLAIN(fprintf(stderr, "%d No match %s\n", depth, scheme_write_to_string(key, 0))); @@ -3793,14 +3998,65 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, did_lexical = 0; } } - stack_pos -= 2; + stack_pos -= 3; } if (!did_lexical) { result = mresult; if (_binding_marks_skipped) *_binding_marks_skipped = mresult_skipped; - } else if (get_names) - get_names[0] = scheme_undefined; + if (mresult_depends_unsealed) + depends_on_unsealed_rib = 1; + } else { + if (get_free_id_info && !SCHEME_VOIDP(result_free_rename)) { + Scheme_Object *orig; + int rib_dep = 0; + orig = result_free_rename; + result_free_rename = SCHEME_VEC_ELS(orig)[0]; + if (SCHEME_PAIRP(result_free_rename) && SCHEME_STXP(SCHEME_CAR(result_free_rename))) { + phase = SCHEME_CDR(result_free_rename); + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(orig)[1])) + phase = scheme_bin_plus(phase, SCHEME_VEC_ELS(orig)[1]); + if (get_names) + get_names[1] = NULL; + result = resolve_env(NULL, SCHEME_CAR(result_free_rename), phase, + w_mod, get_names, + NULL, _binding_marks_skipped, + &rib_dep, depth + 1, 1); + if (get_names && !get_names[1]) + if (SCHEME_FALSEP(result) || SAME_OBJ(scheme_undefined, get_names[0])) + get_names[1] = SCHEME_STX_VAL(SCHEME_CAR(result_free_rename)); + } else if (SCHEME_PAIRP(result_free_rename) && SCHEME_SYMBOLP(SCHEME_CDR(result_free_rename))) { + if (get_names) + get_names[1] = SCHEME_CAR(result_free_rename); + result = SCHEME_CDR(result_free_rename); + if (get_names) + get_names[0] = scheme_undefined; + } else if (SCHEME_VECTORP(result_free_rename)) { + result = SCHEME_VEC_ELS(result_free_rename)[0]; + if (get_names) { + get_names[0] = SCHEME_VEC_ELS(result_free_rename)[1]; + get_names[1] = SCHEME_VEC_ELS(result_free_rename)[2]; + get_names[2] = SCHEME_VEC_ELS(result_free_rename)[3]; + get_names[3] = SCHEME_VEC_ELS(result_free_rename)[4]; + get_names[4] = SCHEME_VEC_ELS(result_free_rename)[5]; + get_names[5] = SCHEME_VEC_ELS(result_free_rename)[6]; + } + } else { + if (get_names) + get_names[1] = SCHEME_CAR(result_free_rename); + result = scheme_false; + } + if (rib_dep) + depends_on_unsealed_rib = 1; + if (SAME_TYPE(SCHEME_TYPE(result), scheme_module_index_type)) + result = scheme_modidx_shift(result, SCHEME_VEC_ELS(orig)[2], SCHEME_VEC_ELS(orig)[3]); + } else { + if (get_names) { + get_names[0] = scheme_undefined; + get_names[1] = NULL; + } + } + } if (_depends_on_unsealed_rib) *_depends_on_unsealed_rib = depends_on_unsealed_rib; @@ -3844,13 +4100,13 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, EXPLAIN(fprintf(stderr, "%d {unmarshal}\n", depth)); unmarshal_rename(mrn, modidx_shift_from, modidx_shift_to, export_registry); } - - if (mrn->marked_names) { + + if (mrn->marked_names) { /* Resolve based on rest of wraps: */ EXPLAIN(fprintf(stderr, "%d tl_id_sym\n", depth)); if (!bdg) { EXPLAIN(fprintf(stderr, "%d get bdg\n", depth)); - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, recur_skip_ribs, NULL, NULL, depth+1, 0); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -3880,7 +4136,21 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, EXPLAIN(fprintf(stderr, "%d search %s\n", depth, scheme_write_to_string(glob_id, 0))); - rename = scheme_hash_get(mrn->ht, glob_id); + if (get_free_id_info && mrn->free_id_renames) { + rename = scheme_hash_get(mrn->free_id_renames, glob_id); + if (rename && SCHEME_STXP(rename)) { + int sealed; + rename = extract_module_free_id_binding((Scheme_Object *)mrn, + glob_id, + rename, + &sealed); + if (!sealed) + mresult_depends_unsealed = 1; + } + } else + rename = NULL; + if (!rename) + rename = scheme_hash_get(mrn->ht, glob_id); if (!rename && mrn->nomarshal_ht) rename = scheme_hash_get(mrn->nomarshal_ht, glob_id); if (!rename && mrn->plus_kernel) { @@ -3898,6 +4168,9 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, EXPLAIN(fprintf(stderr, "%d search result: %p\n", depth, rename)); if (rename) { + if (mrn->sealed < STX_SEAL_BOUND) + mresult_depends_unsealed = 1; + if (mrn->kind == mzMOD_RENAME_MARKED) { /* One job of a mzMOD_RENAME_MARKED renamer is to replace any binding that might have come from the identifier in its source @@ -3907,90 +4180,105 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } /* match; set mresult, which is used in the case of no lexical capture: */ - if (SCHEME_PAIRP(rename)) - mresult = SCHEME_CAR(rename); - else - mresult = rename; - - if (modidx_shift_from) - mresult = scheme_modidx_shift(mresult, - modidx_shift_from, - modidx_shift_to); - mresult_skipped = skipped; + + if (SCHEME_BOXP(rename)) { + /* This should only happen for mappings from free_id_renames */ + mresult = SCHEME_BOX_VAL(rename); + if (get_names) { + if (SCHEME_FALSEP(SCHEME_CDR(mresult))) + get_names[0] = NULL; + else + get_names[0] = scheme_undefined; + get_names[1] = SCHEME_CAR(mresult); + } + mresult = SCHEME_CDR(mresult); + } else { + if (SCHEME_PAIRP(rename)) + mresult = SCHEME_CAR(rename); + else + mresult = rename; + + if (modidx_shift_from) + mresult = scheme_modidx_shift(mresult, + modidx_shift_from, + modidx_shift_to); - if (get_names) { - int no_shift = 0; + if (get_names) { + int no_shift = 0; - if (!get_names_done) { - if (SCHEME_PAIRP(rename)) { - if (nom_mod_p(rename)) { - /* (cons modidx nominal_modidx) case */ - get_names[0] = glob_id; - get_names[1] = SCHEME_CDR(rename); - get_names[2] = get_names[0]; - } else { - rename = SCHEME_CDR(rename); - if (SCHEME_PAIRP(rename)) { - /* (list* modidx [mod-phase] exportname nominal_modidx nominal_exportname) case */ - if (SCHEME_INTP(SCHEME_CAR(rename)) - || SCHEME_FALSEP(SCHEME_CAR(rename))) { - get_names[3] = SCHEME_CAR(rename); - rename = SCHEME_CDR(rename); - } - get_names[0] = SCHEME_CAR(rename); - get_names[1] = SCHEME_CADR(rename); - if (SCHEME_PAIRP(get_names[1])) { - get_names[4] = SCHEME_CDR(get_names[1]); - get_names[1] = SCHEME_CAR(get_names[1]); - if (SCHEME_PAIRP(get_names[4])) { - get_names[5] = SCHEME_CDR(get_names[4]); - get_names[4] = SCHEME_CAR(get_names[4]); - } else { - get_names[5] = get_names[3]; - } - } - get_names[2] = SCHEME_CDDR(rename); + if (!get_names_done) { + if (SCHEME_PAIRP(rename)) { + if (nom_mod_p(rename)) { + /* (cons modidx nominal_modidx) case */ + get_names[0] = glob_id; + get_names[1] = SCHEME_CDR(rename); + get_names[2] = get_names[0]; } else { - /* (cons modidx exportname) case */ - get_names[0] = rename; - get_names[2] = NULL; /* finish below */ + rename = SCHEME_CDR(rename); + if (SCHEME_PAIRP(rename)) { + /* (list* modidx [mod-phase] exportname nominal_modidx nominal_exportname) case */ + if (SCHEME_INTP(SCHEME_CAR(rename)) + || SCHEME_FALSEP(SCHEME_CAR(rename))) { + get_names[3] = SCHEME_CAR(rename); + rename = SCHEME_CDR(rename); + } + get_names[0] = SCHEME_CAR(rename); + get_names[1] = SCHEME_CADR(rename); + if (SCHEME_PAIRP(get_names[1])) { + get_names[4] = SCHEME_CDR(get_names[1]); + get_names[1] = SCHEME_CAR(get_names[1]); + if (SCHEME_PAIRP(get_names[4])) { + get_names[5] = SCHEME_CDR(get_names[4]); + get_names[4] = SCHEME_CAR(get_names[4]); + } else { + get_names[5] = get_names[3]; + } + } + get_names[2] = SCHEME_CDDR(rename); + } else { + /* (cons modidx exportname) case */ + get_names[0] = rename; + get_names[2] = NULL; /* finish below */ + } + } + } else { + get_names[0] = glob_id; + get_names[2] = NULL; /* finish below */ + } + + if (!get_names[2]) { + get_names[2] = get_names[0]; + if (nominal) + get_names[1] = nominal; + else { + no_shift = 1; + get_names[1] = mresult; } } - } else { - get_names[0] = glob_id; - get_names[2] = NULL; /* finish below */ - } - - if (!get_names[2]) { - get_names[2] = get_names[0]; - if (nominal) - get_names[1] = nominal; - else { - no_shift = 1; - get_names[1] = mresult; + if (!get_names[4]) { + GC_CAN_IGNORE Scheme_Object *pi; + pi = phase_to_index(mrn->phase); + get_names[4] = pi; + } + if (!get_names[5]) { + get_names[5] = get_names[3]; } } - if (!get_names[4]) { - GC_CAN_IGNORE Scheme_Object *pi; - pi = phase_to_index(mrn->phase); - get_names[4] = pi; - } - if (!get_names[5]) { - get_names[5] = get_names[3]; - } - } - if (modidx_shift_from && !no_shift) { - Scheme_Object *nom; - nom = get_names[1]; - nom = scheme_modidx_shift(nom, - modidx_shift_from, - modidx_shift_to); - get_names[1] = nom; + if (modidx_shift_from && !no_shift) { + Scheme_Object *nom; + nom = get_names[1]; + nom = scheme_modidx_shift(nom, + modidx_shift_from, + modidx_shift_to); + get_names[1] = nom; + } } } - } else { + } else { + if (mrn->sealed < STX_SEAL_ALL) + mresult_depends_unsealed = 1; mresult = scheme_false; mresult_skipped = -1; if (get_names) @@ -4082,26 +4370,36 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, int same; { - Scheme_Object *other_env, *envname; + Scheme_Object *other_env, *envname, *free_id_rename; if (SCHEME_SYMBOLP(renamed)) { /* Simplified table */ other_env = scheme_false; envname = SCHEME_VEC_ELS(rename)[2+c+ri]; + if (SCHEME_PAIRP(envname)) { + free_id_rename = SCHEME_CDR(envname); + envname = SCHEME_CAR(envname); + } else + free_id_rename = scheme_void; same = 1; no_lexical = 1; /* simplified table always has final result */ - EXPLAIN(fprintf(stderr, "%d Targes %s <- %s\n", depth, + EXPLAIN(fprintf(stderr, "%d Targes %s <- %s %p\n", depth, scheme_write_to_string(envname, 0), - scheme_write_to_string(other_env, 0))); + scheme_write_to_string(other_env, 0), + free_id_rename)); } else { envname = SCHEME_VEC_ELS(rename)[0]; other_env = SCHEME_VEC_ELS(rename)[2+c+ri]; + if (SCHEME_PAIRP(other_env)) + free_id_rename = SCHEME_CDR(other_env); + else + free_id_rename = scheme_void; other_env = filter_cached_env(other_env, recur_skip_ribs); if (SCHEME_VOIDP(other_env)) { int rib_dep = 0; SCHEME_USE_FUEL(1); - other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1); + other_env = resolve_env(NULL, renamed, 0, 0, NULL, recur_skip_ribs, NULL, &rib_dep, depth+1, 0); { Scheme_Object *e; e = extend_cached_env(SCHEME_VEC_ELS(rename)[2+c+ri], other_env, recur_skip_ribs, @@ -4134,11 +4432,22 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, top element of the stack and combine the two mappings, but the intermediate name may be needed (for other_env values that don't come from this stack). */ + if (get_free_id_info && !SCHEME_VOIDP(free_id_rename)) { + /* Need to remember phase ad shifts for free-id=? rename: */ + Scheme_Object *vec; + vec = scheme_make_vector(4, NULL); + SCHEME_VEC_ELS(vec)[0] = free_id_rename; + SCHEME_VEC_ELS(vec)[1] = phase; + SCHEME_VEC_ELS(vec)[2] = modidx_shift_from; + SCHEME_VEC_ELS(vec)[3] = modidx_shift_to; + free_id_rename = vec; + } if (stack_pos < QUICK_STACK_SIZE) { + rename_stack[stack_pos++] = free_id_rename; rename_stack[stack_pos++] = envname; rename_stack[stack_pos++] = other_env; } else { - o_rename_stack = CONS(CONS(other_env, envname), + o_rename_stack = CONS(CONS(other_env, CONS(envname, free_id_rename)), o_rename_stack); } if (is_rib) { @@ -4209,18 +4518,22 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, } } -static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase) +static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_phase, int use_free_id_renames) /* Gets a module source name under the assumption that the identifier is not lexically renamed. This is used as a quick pre-test for - free-identifier=?. */ + free-identifier=?. We do have to look at lexical renames to check for + equivalences installed on detection of make-rename-transformer, but at least + we can normally cache the result. */ { WRAP_POS wraps; Scheme_Object *result, *result_from; int is_in_module = 0, skip_other_mods = 0, sealed = STX_SEAL_ALL, floating_checked = 0; + int no_lexical = !use_free_id_renames; Scheme_Object *phase = orig_phase; Scheme_Object *bdg = NULL, *floating = NULL; - if (SAME_OBJ(phase, scheme_make_integer(0)) + if (!use_free_id_renames + && SAME_OBJ(phase, scheme_make_integer(0)) && ((Scheme_Stx *)a)->u.modinfo_cache) return ((Scheme_Stx *)a)->u.modinfo_cache; @@ -4238,7 +4551,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ if (!result) result = SCHEME_STX_VAL(a); - if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0))) + if (can_cache && SAME_OBJ(orig_phase, scheme_make_integer(0)) && !use_free_id_renames) ((Scheme_Stx *)a)->u.modinfo_cache = result; return result; @@ -4279,13 +4592,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, NULL, NULL, 0); + resolve_env(NULL, a, orig_phase, 1, NULL, NULL, NULL, NULL, 0, 0); } if (mrn->marked_names) { /* Resolve based on rest of wraps: */ if (!bdg) - bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0); + bdg = resolve_env(&wraps, a, orig_phase, 0, NULL, NULL, NULL, NULL, 0, 0); if (SCHEME_FALSEP(bdg)) { if (!floating_checked) { floating = check_floating_id(a); @@ -4295,10 +4608,30 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ } /* 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, NULL); + + if (SCHEME_TRUEP(bdg) + && !SAME_OBJ(glob_id, SCHEME_STX_VAL(a))) { + /* See "Even if this module doesn't match, the lex-renamed id" in resolve_env() */ + no_lexical = 1; + } } else glob_id = SCHEME_STX_VAL(a); - rename = scheme_hash_get(mrn->ht, glob_id); + if (use_free_id_renames && mrn->free_id_renames) { + rename = scheme_hash_get(mrn->free_id_renames, glob_id); + if (rename && SCHEME_STXP(rename)) { + int sealed; + rename = extract_module_free_id_binding((Scheme_Object *)mrn, + glob_id, + rename, + &sealed); + if (!sealed) + sealed = 0; + } + } else + rename = NULL; + if (!rename) + rename = scheme_hash_get(mrn->ht, glob_id); if (!rename && mrn->nomarshal_ht) rename = scheme_hash_get(mrn->nomarshal_ht, glob_id); if (!rename && mrn->plus_kernel) @@ -4310,7 +4643,11 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ /* match; set result: */ if (mrn->kind == mzMOD_RENAME_MARKED) skip_other_mods = 1; - if (SCHEME_PAIRP(rename)) { + if (SCHEME_BOXP(rename)) { + /* only happens with free_id_renames */ + rename = SCHEME_BOX_VAL(rename); + result = SCHEME_CAR(rename); + } else if (SCHEME_PAIRP(rename)) { if (nom_mod_p(rename)) { result = glob_id; } else { @@ -4332,10 +4669,98 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ n = SCHEME_VEC_ELS(vec)[0]; if (SCHEME_TRUEP(phase)) phase = scheme_bin_minus(phase, n); + } else if (!no_lexical + && (SCHEME_VECTORP(WRAP_POS_FIRST(wraps)) + || SCHEME_RIBP(WRAP_POS_FIRST(wraps)))) { + /* Lexical rename */ + Scheme_Object *rename, *renamed, *renames; + Scheme_Lexical_Rib *rib; + int ri, istart, iend; + + rename = WRAP_POS_FIRST(wraps); + if (SCHEME_RIBP(rename)) { + rib = ((Scheme_Lexical_Rib *)rename)->next; + rename = NULL; + } else { + rib = NULL; + if (SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[0])) { + /* No free-id=? renames here. */ + rename = NULL; + } + } + + do { + if (rib) { + if (!*rib->sealed) sealed = 0; + rename = rib->rename; + rib = rib->next; + } + + if (rename) { + int c = SCHEME_RENAME_LEN(rename); + + /* Get index from hash table, if there is one: */ + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(rename)[1])) { + void *pos; + pos = scheme_hash_get((Scheme_Hash_Table *)(SCHEME_VEC_ELS(rename)[1]), SCHEME_STX_VAL(a)); + if (pos) { + istart = SCHEME_INT_VAL(pos); + if (istart < 0) { + /* -1 indicates multiple slots matching this name. */ + istart = 0; + iend = c; + } else + iend = istart + 1; + } else { + istart = 0; + iend = 0; + } + } else { + istart = 0; + iend = c; + } + + for (ri = istart; ri < iend; ri++) { + renamed = SCHEME_VEC_ELS(rename)[2+ri]; + if (SAME_OBJ(SCHEME_STX_VAL(a), SCHEME_STX_SYM(renamed))) { + /* Check for free-id mapping: */ + renames = SCHEME_VEC_ELS(rename)[2 + ri + c]; + if (SCHEME_PAIRP(renames)) { + /* Has a relevant-looking free-id mapping. + Give up on the "fast" traversal. */ + Scheme_Object *modname, *names[6]; + int rib_dep; + + names[0] = NULL; + names[1] = NULL; + names[3] = scheme_make_integer(0); + names[4] = NULL; + names[5] = NULL; + + modname = resolve_env(NULL, a, orig_phase, 1, names, NULL, NULL, &rib_dep, 0, 1); + if (rib_dep) + sealed = 0; + + if (!SCHEME_FALSEP(modname) + && !SAME_OBJ(names[0], scheme_undefined)) { + result = names[0]; + } else { + result = names[1]; /* can be NULL or alternate name */ + } + + WRAP_POS_INIT_END(wraps); + rib = NULL; + break; + } + } + } + } + } while (rib); } /* Keep looking: */ - WRAP_POS_INC(wraps); + if (!WRAP_POS_END_P(wraps)) + WRAP_POS_INC(wraps); } } @@ -4346,16 +4771,16 @@ int scheme_stx_module_eq2(Scheme_Object *a, Scheme_Object *b, Scheme_Object *pha if (!a || !b) return (a == b); + if (SCHEME_STXP(b)) + bsym = get_module_src_name(b, phase, !asym); + else + bsym = b; if (!asym) { if (SCHEME_STXP(a)) - asym = get_module_src_name(a, phase); + asym = get_module_src_name(a, phase, 1); else asym = a; } - if (SCHEME_STXP(b)) - bsym = get_module_src_name(b, phase); - else - bsym = b; /* Same name? */ if (!SAME_OBJ(asym, bsym)) @@ -4364,8 +4789,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, NULL, NULL, 0); - b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0); + a = resolve_env(NULL, a, phase, 1, NULL, NULL, NULL, NULL, 0, 1); + b = resolve_env(NULL, b, phase, 1, NULL, NULL, NULL, NULL, 0, 1); if (SAME_TYPE(SCHEME_TYPE(a), scheme_module_index_type)) a = scheme_module_resolve(a, 0); @@ -4384,34 +4809,47 @@ int scheme_stx_module_eq(Scheme_Object *a, Scheme_Object *b, long phase) Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *phase) { if (SCHEME_STXP(a)) - return get_module_src_name(a, phase); + return get_module_src_name(a, phase, 0); else return a; } -Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase, +Scheme_Object *scheme_stx_module_name(int recur, + Scheme_Object **a, Scheme_Object *phase, Scheme_Object **nominal_modidx, Scheme_Object **nominal_name, Scheme_Object **mod_phase, Scheme_Object **src_phase_index, - Scheme_Object **nominal_src_phase) + Scheme_Object **nominal_src_phase, + Scheme_Object **lex_env, + int *_sealed) /* If module bound, result is module idx, and a is set to source name. - If lexically bound, result is scheme_undefined and a is unchanged. - If neither, result is NULL and a is unchanged. */ + If lexically bound, result is scheme_undefined, a is unchanged, + and nominal_name is NULL or a free_id=? renamed id. + If neither, result is NULL, a is unchanged, and + and nominal_name is NULL or a free_id=? renamed id. */ { if (SCHEME_STXP(*a)) { Scheme_Object *modname, *names[6]; + int rib_dep; names[0] = NULL; + names[1] = NULL; names[3] = scheme_make_integer(0); names[4] = NULL; names[5] = NULL; - modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, NULL, 0); + modname = resolve_env(NULL, *a, phase, 1, names, NULL, NULL, _sealed ? &rib_dep : NULL, 0, recur); + + if (_sealed) *_sealed = !rib_dep; if (names[0]) { if (SAME_OBJ(names[0], scheme_undefined)) { - return scheme_undefined; + if (lex_env) + *lex_env = modname; + if (nominal_name) + *nominal_name = names[1]; + return scheme_undefined; } else { *a = names[0]; if (nominal_modidx) @@ -4426,10 +4864,15 @@ Scheme_Object *scheme_stx_module_name(Scheme_Object **a, Scheme_Object *phase, *nominal_src_phase = names[5]; return modname; } - } else + } else { + if (nominal_name) *nominal_name = names[1]; return NULL; - } else + } + } else { + if (nominal_name) *nominal_name = NULL; + if (_sealed) *_sealed = 1; return NULL; + } } int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs) @@ -4442,8 +4885,8 @@ int scheme_stx_ribs_matter(Scheme_Object *a, Scheme_Object *skip_ribs) skip_ribs = SCHEME_CDR(skip_ribs); } - m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0); - m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0); + m1 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, NULL, NULL, NULL, 0, 0); + m2 = resolve_env(NULL, a, scheme_make_integer(0), 1, NULL, skips, NULL, NULL, 0, 0); return !SAME_OBJ(m1, m2); } @@ -4454,7 +4897,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, NULL, NULL, 0); + r = resolve_env(NULL, a, scheme_make_integer(0), 0, NULL, NULL, NULL, NULL, 0, 0); if (SCHEME_FALSEP(r)) r = check_floating_id(a); @@ -4486,13 +4929,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, NULL, NULL, 0); + ae = resolve_env(NULL, a, phase, 0, NULL, NULL, NULL, NULL, 0, 0); /* 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, NULL, NULL, 0); + be = resolve_env(NULL, b, phase, 0, NULL, NULL, NULL, NULL, 0, 0); /* No need to module_resolve be, because we ignored module renamings. */ } @@ -4522,7 +4965,7 @@ int scheme_stx_bound_eq(Scheme_Object *a, Scheme_Object *b, Scheme_Object *phase Scheme_Object *scheme_explain_resolve_env(Scheme_Object *a) { scheme_explain_resolves++; - a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0); + a = resolve_env(NULL, a, 0, 0, NULL, NULL, NULL, NULL, 0, 1); --scheme_explain_resolves; return a; } @@ -4909,6 +5352,44 @@ static void print_skips(Scheme_Object *skips) #define EXPLAIN_S(x) /* empty */ #endif +static Scheme_Object *extract_free_id_info(Scheme_Object *id) +{ + Scheme_Object *bind; + Scheme_Object *nominal_modidx; + Scheme_Object *nominal_name; + Scheme_Object *mod_phase; + Scheme_Object *src_phase_index; + Scheme_Object *nominal_src_phase; + Scheme_Object *lex_env = NULL; + Scheme_Object *vec, *phase; + + phase = SCHEME_CDR(id); + id = SCHEME_CAR(id); + + bind = scheme_stx_module_name(1, + &id, phase, &nominal_modidx, &nominal_name, + &mod_phase, &src_phase_index, &nominal_src_phase, + &lex_env, NULL); + if (!nominal_name) + nominal_name = SCHEME_STX_VAL(id); + + if (!bind) + return CONS(nominal_name, scheme_false); + else if (SAME_OBJ(bind, scheme_undefined)) + return CONS(nominal_name, lex_env); + else { + vec = scheme_make_vector(7, NULL); + SCHEME_VEC_ELS(vec)[0] = bind; + SCHEME_VEC_ELS(vec)[1] = id; + SCHEME_VEC_ELS(vec)[2] = nominal_modidx; + SCHEME_VEC_ELS(vec)[3] = nominal_name; + SCHEME_VEC_ELS(vec)[4] = mod_phase; + SCHEME_VEC_ELS(vec)[5] = src_phase_index; + SCHEME_VEC_ELS(vec)[6] = nominal_src_phase; + return vec; + } +} + static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_cache) { WRAP_POS w, prev, w2; @@ -5031,7 +5512,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab other_env = filter_cached_env(other_env, prec_ribs); if (SCHEME_VOIDP(other_env)) { int rib_dep; - other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0); + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, 0); if (rib_dep) { scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); return NULL; @@ -5187,7 +5668,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab answer applies. */ Scheme_Object *ok = NULL, *ok_replace = NULL; int ok_replace_index = 0; - Scheme_Object *other_env; + Scheme_Object *other_env, *free_id_rename, *prev_env, *orig_prev_env; if (rib) { EXPLAIN_S(fprintf(stderr, " resolve %s %s (%d)\n", @@ -5197,16 +5678,26 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab } other_env = SCHEME_VEC_ELS(v)[2+vvsize+ii]; + if (SCHEME_PAIRP(other_env)) + free_id_rename = extract_free_id_info(SCHEME_CDR(other_env)); + else + free_id_rename = NULL; other_env = filter_cached_env(other_env, prec_ribs); if (SCHEME_VOIDP(other_env)) { int rib_dep; - other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0); + other_env = resolve_env(NULL, stx, 0, 0, NULL, prec_ribs, NULL, &rib_dep, 0, 0); if (rib_dep) { scheme_signal_error("compile: unsealed local-definition context found in fully expanded form"); return NULL; } - if (!prec_ribs) - SCHEME_VEC_ELS(v)[2+vvsize+ii] = other_env; + if (!prec_ribs) { + if (free_id_rename) + ok = CONS(other_env, free_id_rename); + else + ok = other_env; + SCHEME_VEC_ELS(v)[2+vvsize+ii] = ok; + ok = NULL; + } } if (!WRAP_POS_END_P(prev) @@ -5221,7 +5712,7 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab } if (other_env) { - /* A simplified table need to have the final answer, so + /* A simplified table needs to have the final answer, so fold conversions from the rest of the wraps. In the case of ribs, the "rest" can include earlier rib renamings. Otherwise, check simplications accumulated in v2l (possibly from a @@ -5233,10 +5724,15 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab for (j = 0; j < done_rib_pos; j++) { if (SAME_OBJ(SCHEME_VEC_ELS(v2)[2+j], name)) { rib_found = 1; - if (SAME_OBJ(SCHEME_VEC_ELS(v2)[2+size+j], other_env)) { + prev_env = SCHEME_VEC_ELS(v2)[2+size+j]; + orig_prev_env = prev_env; + if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env); + if (SAME_OBJ(prev_env, other_env)) { ok = SCHEME_VEC_ELS(v)[0]; ok_replace = v2; ok_replace_index = 2 + size + j; + if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) + free_id_rename = SCHEME_CDR(orig_prev_env); } else { EXPLAIN_S(fprintf(stderr, " not matching prev rib\n")); ok = NULL; @@ -5259,8 +5755,13 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab psize = SCHEME_RENAME_LEN(vp); for (j = 0; j < psize; j++) { if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+j], name)) { - if (SAME_OBJ(SCHEME_VEC_ELS(vp)[2+psize+j], other_env)) { + prev_env = SCHEME_VEC_ELS(vp)[2+psize+j]; + orig_prev_env = prev_env; + if (SCHEME_PAIRP(prev_env)) prev_env = SCHEME_CAR(prev_env); + if (SAME_OBJ(prev_env, other_env)) { ok = SCHEME_VEC_ELS(v)[0]; + if (!free_id_rename && SCHEME_PAIRP(orig_prev_env)) + free_id_rename = SCHEME_CDR(orig_prev_env); } else { EXPLAIN_S(fprintf(stderr, " not matching deeper %s\n", @@ -5309,6 +5810,8 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab } if (ok) { + if (free_id_rename) + ok = CONS(ok, free_id_rename); if (ok_replace) { EXPLAIN_S(fprintf(stderr, " replace mapping %s\n", scheme_write_to_string(ok, NULL))); @@ -5346,7 +5849,13 @@ static Scheme_Object *simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Tab } SCHEME_VEC_ELS(v2)[0] = scheme_false; + for (i = 0; i < pos; i++) { + if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(v2)[2+pos+i])) + SCHEME_VEC_ELS(v2)[0] = scheme_true; + } + SCHEME_VEC_ELS(v2)[1] = scheme_false; + maybe_install_rename_hash_table(v2); if (no_rib_mutation) { /* Sometimes we generate the same simplified lex table, so @@ -5524,6 +6033,7 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, /* Not useful if there's no marked names. */ redundant = ((mrn->sealed >= STX_SEAL_ALL) && (!mrn->marked_names || !mrn->marked_names->count) + && (!mrn->free_id_renames || !mrn->free_id_renames->count) && SCHEME_NULLP(mrn->shared_pes)); if (!redundant) { /* Otherwise, watch out for multiple instances of the same rename: */ @@ -5579,6 +6089,32 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, if (just_simplify) { stack = CONS((Scheme_Object *)mrn, stack); } else { + if (mrn->free_id_renames) { + /* resolve all renamings */ + int i; + Scheme_Object *b; + for (i = mrn->free_id_renames->size; i--; ) { + if (mrn->free_id_renames->vals[i]) { + if (SCHEME_STXP(mrn->free_id_renames->vals[i])) { + int sealed; + b = extract_module_free_id_binding((Scheme_Object *)mrn, + mrn->free_id_renames->keys[i], + mrn->free_id_renames->vals[i], + &sealed); + if (!sealed) { + extract_module_free_id_binding((Scheme_Object *)mrn, + mrn->free_id_renames->keys[i], + mrn->free_id_renames->vals[i], + &sealed); + scheme_signal_error("write: unsealed local-definition or module context" + " found in syntax object"); + } + scheme_hash_set(mrn->free_id_renames, mrn->free_id_renames->keys[i], b); + } + } + } + } + if (mrn->kind == mzMOD_RENAME_TOPLEVEL) { if (same_phase(mrn->phase, scheme_make_integer(0))) stack = CONS(scheme_true, stack); @@ -5589,21 +6125,34 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, local_key = scheme_marshal_lookup(mt, (Scheme_Object *)mrn); if (!local_key) { - /* Convert hash table to vector: */ + /* Convert hash table to vector, etc.: */ int i, j, count = 0; - Scheme_Object *l; + Scheme_Hash_Table *ht; + Scheme_Object *l, *fil; - count = mrn->ht->count; - - l = scheme_make_vector(count * 2, NULL); - - for (i = mrn->ht->size, j = 0; i--; ) { - if (mrn->ht->vals[i]) { - SCHEME_VEC_ELS(l)[j++] = mrn->ht->keys[i]; - SCHEME_VEC_ELS(l)[j++] = mrn->ht->vals[i]; + ht = mrn->ht; + count = ht->count; + l = scheme_make_vector(count * 2, NULL); + for (i = ht->size, j = 0; i--; ) { + if (ht->vals[i]) { + SCHEME_VEC_ELS(l)[j++] = ht->keys[i]; + SCHEME_VEC_ELS(l)[j++] = ht->vals[i]; } } + ht = mrn->free_id_renames; + if (ht && ht->count) { + count = ht->count; + fil = scheme_make_vector(count * 2, NULL); + for (i = ht->size, j = 0; i--; ) { + if (ht->vals[i]) { + SCHEME_VEC_ELS(fil)[j++] = ht->keys[i]; + SCHEME_VEC_ELS(fil)[j++] = ht->vals[i]; + } + } + } else + fil = NULL; + if (mrn->marked_names && mrn->marked_names->count) { Scheme_Object *d = scheme_null, *p; @@ -5617,10 +6166,17 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in, } } - l = CONS(l, d); - } else - l = CONS(l, scheme_null); - + if (fil) + fil = CONS(fil, d); + else + fil = d; + } else if (fil) + fil = CONS(fil, scheme_null); + else + fil = scheme_null; + + l = CONS(l, fil); + if (SCHEME_PAIRP(mrn->unmarshal_info)) l = CONS(mrn->unmarshal_info, l); @@ -6150,6 +6706,100 @@ static int ok_phase_index(Scheme_Object *o) { return ok_phase(o); } +static Scheme_Object *datum_to_module_renames(Scheme_Object *a, Scheme_Hash_Table *ht, int lex_ok) +{ + int count, i; + Scheme_Object *key, *p; + + if (!SCHEME_VECTORP(a)) return_NULL; + count = SCHEME_VEC_SIZE(a); + if (count & 0x1) return_NULL; + + for (i = 0; i < count; i+= 2) { + key = SCHEME_VEC_ELS(a)[i]; + p = SCHEME_VEC_ELS(a)[i+1]; + + if (!SCHEME_SYMBOLP(key)) return_NULL; + + if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { + /* Ok */ + } else if (SCHEME_PAIRP(p)) { + Scheme_Object *midx; + + midx = SCHEME_CAR(p); + if (!SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type)) + return_NULL; + + if (SCHEME_SYMBOLP(SCHEME_CDR(p))) { + /* Ok */ + } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(p)), scheme_module_index_type)) { + /* Ok */ + } else { + Scheme_Object *ap, *bp; + + ap = SCHEME_CDR(p); + if (!SCHEME_PAIRP(ap)) + return_NULL; + + /* mod-phase, maybe */ + if (SCHEME_INTP(SCHEME_CAR(ap))) { + bp = SCHEME_CDR(ap); + } else + bp = ap; + + /* exportname */ + if (!SCHEME_PAIRP(bp)) + return_NULL; + ap = SCHEME_CAR(bp); + if (!SCHEME_SYMBOLP(ap)) + return_NULL; + + /* nominal_modidx_plus_phase */ + bp = SCHEME_CDR(bp); + if (!SCHEME_PAIRP(bp)) + return_NULL; + ap = SCHEME_CAR(bp); + if (SAME_TYPE(SCHEME_TYPE(ap), scheme_module_index_type)) { + /* Ok */ + } else if (SCHEME_PAIRP(ap)) { + if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(ap)), scheme_module_index_type)) + return_NULL; + ap = SCHEME_CDR(ap); + /* import_phase_plus_nominal_phase */ + if (SCHEME_PAIRP(ap)) { + if (!ok_phase_index(SCHEME_CAR(ap))) return_NULL; + if (!ok_phase_index(SCHEME_CDR(ap))) return_NULL; + } else if (!ok_phase_index(ap)) + return_NULL; + } else + return_NULL; + + /* nominal_exportname */ + ap = SCHEME_CDR(bp); + if (!SCHEME_SYMBOLP(ap)) + return_NULL; + } + } else if (lex_ok) { + Scheme_Object *ap; + if (!SCHEME_BOXP(p)) + return_NULL; + ap = SCHEME_BOX_VAL(p); + if (!SCHEME_PAIRP(ap)) + return_NULL; + if (!SCHEME_SYMBOLP(SCHEME_CAR(ap))) + return_NULL; + ap = SCHEME_CDR(ap); + if (!SCHEME_SYMBOLP(ap) && !SCHEME_FALSEP(ap)) + return_NULL; + } else + return_NULL; + + scheme_hash_set(ht, key, p); + } + + return scheme_true; +} + static Scheme_Object *datum_to_wraps(Scheme_Object *w, Scheme_Unmarshal_Tables *ut) { @@ -6213,15 +6863,53 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, if (!a) return_NULL; } else if (SCHEME_VECTORP(a)) { /* A (simplified) rename table. */ - int i = SCHEME_VEC_SIZE(a); + int sz = SCHEME_VEC_SIZE(a), cnt, i, any_free_id_renames = 0; + Scheme_Object *v; /* Make sure that it's a well-formed rename table. */ - if ((i < 2) || !SCHEME_FALSEP(SCHEME_VEC_ELS(a)[1])) + if (sz < 2) return_NULL; - while (i > 2) { - i--; - if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[i])) + cnt = (sz - 2) >> 1; + for (i = 0; i < cnt; i++) { + if (!SCHEME_SYMBOLP(SCHEME_VEC_ELS(a)[i + 2])) return_NULL; + v = SCHEME_VEC_ELS(a)[i + cnt + 2]; + if (SCHEME_SYMBOLP(v)) { + /* simple target-environment symbol */ + } else if (SCHEME_PAIRP(v)) { + /* target-environment symbol paired with free-id=? rename info */ + any_free_id_renames = 1; + if (!SCHEME_SYMBOLP(SCHEME_CAR(v))) + return_NULL; + v = SCHEME_CDR(v); + if (SCHEME_PAIRP(v)) { + if (!SCHEME_SYMBOLP(SCHEME_CAR(v))) + return_NULL; + v = SCHEME_CDR(v); + if (!SCHEME_SYMBOLP(v) && !SCHEME_FALSEP(v)) + return_NULL; + } else if (SCHEME_VECTORP(v)) { + if (SCHEME_VEC_SIZE(v) != 7) + return_NULL; + if (!SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[0]) + || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[1]) + || !SCHEME_MODIDXP(SCHEME_VEC_ELS(v)[2]) + || !SCHEME_SYMBOLP(SCHEME_VEC_ELS(v)[3]) + || !ok_phase(SCHEME_VEC_ELS(v)[4]) + || !ok_phase(SCHEME_VEC_ELS(v)[5]) + || !ok_phase(SCHEME_VEC_ELS(v)[6])) + return_NULL; + } else + return_NULL; + } else + return_NULL; + } + + SCHEME_VEC_ELS(a)[0] = (any_free_id_renames ? scheme_true : scheme_false); + + if (!SCHEME_FALSEP(SCHEME_VEC_ELS(a)[1])) { + SCHEME_VEC_ELS(a)[1] = scheme_false; + maybe_install_rename_hash_table(a); } /* It's ok: */ @@ -6237,7 +6925,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, Scheme_Object *mns; Module_Renames *mrn; Scheme_Object *p, *key; - int plus_kernel, i, count, kind; + int plus_kernel, kind; Scheme_Object *phase, *set_identity; if (!SCHEME_PAIRP(a)) return_NULL; @@ -6377,78 +7065,17 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w, mns = SCHEME_CDR(mns); } - if (!SCHEME_VECTORP(a)) return_NULL; - count = SCHEME_VEC_SIZE(a); - if (count & 0x1) return_NULL; + if (!datum_to_module_renames(a, mrn->ht, 0)) + return_NULL; - for (i = 0; i < count; i+= 2) { - key = SCHEME_VEC_ELS(a)[i]; - p = SCHEME_VEC_ELS(a)[i+1]; - - if (!SCHEME_SYMBOLP(key)) return_NULL; - - if (SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)) { - /* Ok */ - } else if (SCHEME_PAIRP(p)) { - Scheme_Object *midx; - - midx = SCHEME_CAR(p); - if (!SAME_TYPE(SCHEME_TYPE(midx), scheme_module_index_type)) - return_NULL; - - if (SCHEME_SYMBOLP(SCHEME_CDR(p))) { - /* Ok */ - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_CDR(p)), scheme_module_index_type)) { - /* Ok */ - } else { - Scheme_Object *ap, *bp; - - ap = SCHEME_CDR(p); - if (!SCHEME_PAIRP(ap)) - return_NULL; - - /* mod-phase, maybe */ - if (SCHEME_INTP(SCHEME_CAR(ap))) { - bp = SCHEME_CDR(ap); - } else - bp = ap; - - /* exportname */ - if (!SCHEME_PAIRP(bp)) - return_NULL; - ap = SCHEME_CAR(bp); - if (!SCHEME_SYMBOLP(ap)) - return_NULL; - - /* nominal_modidx_plus_phase */ - bp = SCHEME_CDR(bp); - if (!SCHEME_PAIRP(bp)) - return_NULL; - ap = SCHEME_CAR(bp); - if (SAME_TYPE(SCHEME_TYPE(ap), scheme_module_index_type)) { - /* Ok */ - } else if (SCHEME_PAIRP(ap)) { - if (!SAME_TYPE(SCHEME_TYPE(SCHEME_CAR(ap)), scheme_module_index_type)) - return_NULL; - ap = SCHEME_CDR(ap); - /* import_phase_plus_nominal_phase */ - if (SCHEME_PAIRP(ap)) { - if (!ok_phase_index(SCHEME_CAR(ap))) return_NULL; - if (!ok_phase_index(SCHEME_CDR(ap))) return_NULL; - } else if (!ok_phase_index(ap)) - return_NULL; - } else - return_NULL; - - /* nominal_exportname */ - ap = SCHEME_CDR(bp); - if (!SCHEME_SYMBOLP(ap)) - return_NULL; - } - } else - return_NULL; - - scheme_hash_set(mrn->ht, key, p); + /* Extract free-id=? renames, if any */ + if (SCHEME_PAIRP(mns) && SCHEME_VECTORP(SCHEME_CAR(mns))) { + Scheme_Hash_Table *ht; + ht = scheme_make_hash_table(SCHEME_hash_ptr); + mrn->free_id_renames = ht; + if (!datum_to_module_renames(SCHEME_CAR(mns), mrn->free_id_renames, 1)) + return_NULL; + mns = SCHEME_CDR(mns); } /* Extract the mark-rename table, if any: */ @@ -7151,7 +7778,7 @@ void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) if (SAME_OBJ(scheme_intern_symbol("y"), SCHEME_STX_VAL(stx))) { fprintf(stderr, "simplifying... %s\n", - scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0), + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, 0), NULL)); explain_simp = 1; } @@ -7169,7 +7796,7 @@ void scheme_simplify_stx(Scheme_Object *stx, Scheme_Object *cache) if (explain_simp) { explain_simp = 0; fprintf(stderr, "simplified: %s\n", - scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0), + scheme_write_to_string(resolve_env(NULL, stx, 0, 0, NULL, NULL, NULL, NULL, 0, 0), NULL)); } #endif @@ -7661,7 +8288,7 @@ Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv) int skipped = -1; Scheme_Object *mod; - mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0); + mod = resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0, 1); if ((skipped == -1) && SCHEME_FALSEP(mod)) { /* For top-level bindings, need to check the current environment's table, @@ -7787,12 +8414,15 @@ static Scheme_Object *do_module_binding(char *name, int argc, Scheme_Object **ar phase = scheme_bin_plus(dphase, phase); } - m = scheme_stx_module_name(&a, + m = scheme_stx_module_name(1, + &a, phase, &nom_mod, &nom_a, &mod_phase, &src_phase_index, - &nominal_src_phase); + &nominal_src_phase, + NULL, + NULL); if (!m) return scheme_false; diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index b68e2f1b80..77444877c6 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -5737,7 +5737,7 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Compile_Expand_Info *rec, int drec, Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, - int *_pos) + int *_pos, Scheme_Object *rename_rib) { Scheme_Object **results, *l; Scheme_Comp_Env *eenv; @@ -5841,10 +5841,16 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object macro->type = scheme_macro_type; if (vc == 1) SCHEME_PTR_VAL(macro) = a; - else + else SCHEME_PTR_VAL(macro) = results[j]; scheme_set_local_syntax(i++, name, macro, stx_env); + + if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(macro)), scheme_id_macro_type)) { + /* Install a free-id=? rename */ + scheme_install_free_id_rename(name, SCHEME_PTR1_VAL(SCHEME_PTR_VAL(macro)), rename_rib, + scheme_make_integer(rhs_env->genv->phase)); + } } *_pos = i; @@ -6033,7 +6039,7 @@ do_letrec_syntaxes(const char *where, stx_env->insp, rec, drec, stx_env, rhs_env, - &i); + &i, NULL); } } From 9335e3cf285f6f25a100005fb69be0019646db29 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Mar 2009 21:06:42 +0000 Subject: [PATCH 065/140] doc updates for v4.1.5.2 svn: r14161 --- collects/scribble/text/syntax-utils.ss | 6 +++-- collects/scribblings/reference/stx-comp.scrbl | 23 ++++++++++++------- .../scribblings/reference/stx-trans.scrbl | 10 ++++---- .../scribblings/reference/syntax-model.scrbl | 9 ++++++-- collects/tests/mzscheme/macro.ss | 1 + doc/release-notes/mzscheme/HISTORY.txt | 4 ++++ 6 files changed, 37 insertions(+), 16 deletions(-) diff --git a/collects/scribble/text/syntax-utils.ss b/collects/scribble/text/syntax-utils.ss index 2c181e4efa..5ec450eb5c 100644 --- a/collects/scribble/text/syntax-utils.ss +++ b/collects/scribble/text/syntax-utils.ss @@ -159,8 +159,10 @@ (cond [(pair? rest) #`(list* #,@nondefns (begin/collect* #t #,@rest))] [(and (not always-list?) (= 1 (length nondefns))) (car nondefns)] [else #`(list #,@nondefns)])) - (local-expand (if (null? defns) body #`(let () #,@defns #,body)) - context stoplist (car context))) + (begin0 + (local-expand (if (null? defns) body #`(let () #,@defns #,body)) + context stoplist (car context)) + (internal-definition-context-seal (car context)))) (define-syntax-rule (begin/collect x ...) (begin/collect* #f x ...)) ;; begin for templates (allowing definition blocks) diff --git a/collects/scribblings/reference/stx-comp.scrbl b/collects/scribblings/reference/stx-comp.scrbl index bdcacc0ba9..8bcda845b5 100644 --- a/collects/scribblings/reference/stx-comp.scrbl +++ b/collects/scribblings/reference/stx-comp.scrbl @@ -22,15 +22,16 @@ suitable expression context at the @tech{phase level} indicated by Returns @scheme[#t] if @scheme[a-id] and @scheme[b-id] access the same @tech{local binding}, @tech{module binding}, or @tech{top-level -binding} at the @tech{phase level} indicated by -@scheme[phase-level]. A @scheme[#f] value for @scheme[phase-level] -corresponds to the @tech{label phase level}. +binding}---perhaps via @tech{rename transformers}---at the @tech{phase +level} indicated by @scheme[phase-level]. A @scheme[#f] value for +@scheme[phase-level] corresponds to the @tech{label phase level}. ``Same module binding'' means that the identifiers refer to the same -original definition site, not necessarily the @scheme[require] or -@scheme[provide] site. Due to renaming in @scheme[require] and -@scheme[provide], the identifiers may return distinct results with -@scheme[syntax-e].} +original definition site, and not necessarily to the same +@scheme[require] or @scheme[provide] site. Due to renaming in +@scheme[require] and @scheme[provide], or due to a transformer binding +to a @tech{rename transformer}, the identifiers may return distinct +results with @scheme[syntax-e].} @defproc[(free-transformer-identifier=? [a-id syntax?][b-id syntax?]) boolean?]{ @@ -132,7 +133,13 @@ Returns one of three kinds of values, depending on the binding of @tech{top-level binding} (or, equivalently, if it is @tech{unbound}).} - }} + } + +If @scheme[id-stx] is bound to a @tech{rename-transformer}, the result +from @scheme[identifier] binding is for the identifier in the +transformer, so that @scheme[identifier-binding] is consistent with +@scheme[free-identifier=?].} + @defproc[(identifier-transformer-binding [id-stx syntax?]) (or/c 'lexical diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index fac8180a96..49e188aa33 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -66,10 +66,12 @@ Returns the procedure that was passed to Creates a @tech{rename transformer} that, when used as a @tech{transformer binding}, acts as a transformer that insert the identifier @scheme[id-stx] in place of whatever identifier binds the -transformer, including in non-application positions, and in -@scheme[set!] expressions. Such a transformer could be written -manually, but the one created by @scheme[make-rename-transformer] -cooperates specially with @scheme[syntax-local-value] and +transformer, including in non-application positions, in @scheme[set!] +expressions. Such a transformer could be written manually, but the one +created by @scheme[make-rename-transformer] also causes the parser to +install a @scheme[free-identifier=?] and @scheme[identifier-binding] +equivalence, and it cooperates specially with +@scheme[syntax-local-value] and @scheme[syntax-local-make-delta-introducer].} diff --git a/collects/scribblings/reference/syntax-model.scrbl b/collects/scribblings/reference/syntax-model.scrbl index dfa0d2bf55..aa201a3ae1 100644 --- a/collects/scribblings/reference/syntax-model.scrbl +++ b/collects/scribblings/reference/syntax-model.scrbl @@ -542,8 +542,13 @@ also handled specially by the expander and by @scheme[set!] as a transformer binding's value. When @scheme[_id] is bound to a @deftech{rename transformer} produced by @scheme[make-rename-transformer], it is replaced with the identifier -passed to @scheme[make-rename-transformer]. Furthermore, the binding -is also specially handled by @scheme[syntax-local-value] and +passed to @scheme[make-rename-transformer]. In addition, the lexical +information that contains the binding of @scheme[_id] is also enriched +so that @scheme[_id] is @scheme[free-identifier=?] to the identifier +passed to @scheme[make-rename-transformer], and +@scheme[identifier-binding] returns the same results for both +identifiers. Finally, the binding is treated specially by +@scheme[syntax-local-value], and @scheme[syntax-local-make-delta-introducer] as used by @tech{syntax transformer}s. diff --git a/collects/tests/mzscheme/macro.ss b/collects/tests/mzscheme/macro.ss index 5c9b022a05..9087be2801 100644 --- a/collects/tests/mzscheme/macro.ss +++ b/collects/tests/mzscheme/macro.ss @@ -415,6 +415,7 @@ [(define-values (id) rhs) (begin (syntax-local-bind-syntaxes (list #'id) #f def-ctx) + (internal-definition-context-seal def-ctx) #'(begin (define-values (id) rhs) (define-syntax handle (quote-syntax id))))] diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index eacec19c81..52c6065aa0 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,7 @@ +Version 4.1.5.2 +Changed expander to detect a reaname transformer and install a + free-identifier=? syntax-object equivalence + Version 4.1.5, March 2009 Allow infix notation for prefab structure literals Change quasiquote so that unquote works in value positions of #hash From 0ed8d251bff94224448a2d860d329a7427513a61 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 17 Mar 2009 21:18:50 +0000 Subject: [PATCH 066/140] Allow `apply' of non-uniform polymorphic functions to fixed-length list arguments. Please backport. svn: r14162 --- .../typed-scheme/succeed/apply-dots-list.ss | 25 +++++++++++++++++++ .../typed-scheme/typecheck/tc-app-unit.ss | 13 ++++++++++ 2 files changed, 38 insertions(+) create mode 100644 collects/tests/typed-scheme/succeed/apply-dots-list.ss diff --git a/collects/tests/typed-scheme/succeed/apply-dots-list.ss b/collects/tests/typed-scheme/succeed/apply-dots-list.ss new file mode 100644 index 0000000000..d068a14e5a --- /dev/null +++ b/collects/tests/typed-scheme/succeed/apply-dots-list.ss @@ -0,0 +1,25 @@ + +;; Change the lang to scheme for untyped version +#lang typed-scheme + +(define tests (list (list (λ() 1) 1 "test 1") + (list (λ() 2) 2 "test 2"))) + +; Comment out the type signature when running untyped +(: check-all (All (A ...) ((List (-> A) A String) ... A -> Void))) +(define (check-all . tests) + (let aux ([tests tests] + [num-passed 0]) + (if (null? tests) + (printf "~a tests passed.~n" num-passed) + (let ((test (car tests))) + (let ((actual ((car test))) + (expected (cadr test)) + (msg (caddr test))) + (if (equal? actual expected) + (aux (cdr tests) (+ num-passed 1)) + (printf "Test failed: ~a. Expected ~a, got ~a.~n" + msg expected actual))))))) + +(apply check-all tests) ; Works in untyped, but not in typed +(check-all (car tests) (cadr tests)) ; Works in typed or untyped \ No newline at end of file diff --git a/collects/typed-scheme/typecheck/tc-app-unit.ss b/collects/typed-scheme/typecheck/tc-app-unit.ss index dbe864f112..61b4f54be6 100644 --- a/collects/typed-scheme/typecheck/tc-app-unit.ss +++ b/collects/typed-scheme/typecheck/tc-app-unit.ss @@ -342,6 +342,19 @@ drest-bound (subst-all (alist-delete drest-bound substitution eq?) (car rngs*)))))] + ;; ... function, (List A B C etc) arg + [(and (car drests*) + (not tail-bound) + (eq? (cdr (car drests*)) dotted-var) + (= (length (car doms*)) + (length arg-tys)) + (untuple tail-ty) + (infer/dots fixed-vars dotted-var (append arg-tys (untuple tail-ty)) (car doms*) + (car (car drests*)) (car rngs*) (fv (car rngs*)))) + => (lambda (substitution) + (define drest-bound (cdr (car drests*))) + (do-apply-log substitution 'dots 'dots) + (ret (subst-all substitution (car rngs*))))] ;; if nothing matches, around the loop again [else (loop (cdr doms*) (cdr rngs*) (cdr rests*) (cdr drests*))])))] [(tc-result: (PolyDots: vars (Function: '()))) From d39ff7e079ff6633d80a05c2af05e779b22272dc Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 17 Mar 2009 22:41:13 +0000 Subject: [PATCH 067/140] fix other comment terminator in .ssc, reflow comment svn: r14163 --- src/foreign/foreign.c | 8 ++++---- src/foreign/foreign.ssc | 8 ++++---- 2 files changed, 8 insertions(+), 8 deletions(-) diff --git a/src/foreign/foreign.c b/src/foreign/foreign.c index 86ab89913e..69b2775995 100644 --- a/src/foreign/foreign.c +++ b/src/foreign/foreign.c @@ -2138,8 +2138,8 @@ static Scheme_Object *abs_sym; /* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ -/* if n is given, an 'abs flag can precede it to make n be a byte offset rather */ -/* than some multiple of sizeof(type). */ +/* if n is given, an 'abs flag can precede it to make n be a byte offset */ +/* rather than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ #define MYNAME "ptr-ref" static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) @@ -2191,8 +2191,8 @@ static Scheme_Object *foreign_ptr_ref(int argc, Scheme_Object *argv[]) /* (ptr-set! cpointer type [['abs] n] value) -> void */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ -/* if n is given, an 'abs flag can precede it to make n be a byte offset rather */ -/* than some multiple of sizeof(type). */ +/* if n is given, an 'abs flag can precede it to make n be a byte offset */ +/* rather than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ #define MYNAME "ptr-set!" static Scheme_Object *foreign_ptr_set_bang(int argc, Scheme_Object *argv[]) diff --git a/src/foreign/foreign.ssc b/src/foreign/foreign.ssc index ed8e5857b2..20bd47d594 100755 --- a/src/foreign/foreign.ssc +++ b/src/foreign/foreign.ssc @@ -1553,8 +1553,8 @@ static Scheme_Object *do_memop(const char *who, int mode, /* (ptr-ref cpointer type [['abs] n]) -> the object at the given location */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ -/* if n is given, an 'abs flag can precede it to make n be a byte offset rather */ -/* than some multiple of sizeof(type). */ +/* if n is given, an 'abs flag can precede it to make n be a byte offset */ +/* rather than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ @cdefine[ptr-ref 2 4]{ int size=0; void *ptr; Scheme_Object *base; @@ -1603,8 +1603,8 @@ static Scheme_Object *do_memop(const char *who, int mode, /* (ptr-set! cpointer type [['abs] n] value) -> void */ /* n defaults to 0 which is the only value that should be used with ffi_objs */ -/* if n is given, an 'abs flag can precede it to make n be a byte offset rather -/* than some multiple of sizeof(type). */ +/* if n is given, an 'abs flag can precede it to make n be a byte offset */ +/* rather than some multiple of sizeof(type). */ /* WARNING: there are *NO* checks at all, this is raw C level code. */ @cdefine[ptr-set! 3 5]{ int size=0; void *ptr; From 4cd11d7f6479ea77881ca6ee0e542b4c6429132b Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 17 Mar 2009 23:01:56 +0000 Subject: [PATCH 068/140] one more fix to the language dialog svn: r14164 --- collects/drscheme/private/language-configuration.ss | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/collects/drscheme/private/language-configuration.ss b/collects/drscheme/private/language-configuration.ss index 73d888a376..299b9dec14 100644 --- a/collects/drscheme/private/language-configuration.ss +++ b/collects/drscheme/private/language-configuration.ss @@ -761,8 +761,6 @@ (send revert-to-defaults-outer-panel stretchable-height #f) (send outermost-panel set-alignment 'center 'center) - (update-show/hide-details) - (for-each add-language-to-dialog languages) (send languages-hier-list sort (λ (x y) @@ -820,6 +818,7 @@ (get/set-selected-language-settings settings-to-show)) (when details-shown? (do-construct-details)) + (update-show/hide-details) (send languages-hier-list focus) (values (λ () selected-language) From e8cbe7ff811a6dce9586de8321e917680c7ee658 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 17 Mar 2009 23:09:38 +0000 Subject: [PATCH 069/140] splicing-let, etc. svn: r14165 --- collects/scheme/splicing.ss | 50 +++++++++++++------ collects/scribblings/reference/splicing.scrbl | 13 ++++- collects/tests/mzscheme/syntax.ss | 46 +++++++++++++++++ 3 files changed, 93 insertions(+), 16 deletions(-) diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss index 725283c4f8..d0ad785a61 100644 --- a/collects/scheme/splicing.ss +++ b/collects/scheme/splicing.ss @@ -8,9 +8,13 @@ splicing-let-syntaxes splicing-letrec-syntax splicing-letrec-syntaxes + splicing-let + splicing-let-values + splicing-letrec + splicing-letrec-values splicing-syntax-parameterize) -(define-for-syntax (do-let-syntax stx rec? multi? let-stx-id) +(define-for-syntax (do-let-syntax stx rec? multi? let-id def-id need-top-decl?) (syntax-case stx () [(_ ([ids expr] ...) body ...) (let ([all-ids (map (lambda (ids-stx) @@ -42,11 +46,11 @@ stx dup-id))) (if (eq? 'expression (syntax-local-context)) - (with-syntax ([let-stx let-stx-id]) + (with-syntax ([LET let-id]) (syntax/loc stx - (let-stx ([ids expr] ...) - (#%expression body) - ...))) + (LET ([ids expr] ...) + (#%expression body) + ...))) (let ([def-ctx (syntax-local-make-definition-context)] [ctx (list (gensym 'intdef))]) (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) @@ -69,23 +73,41 @@ (map add-context exprs) exprs))] [(body ...) - (map add-context (syntax->list #'(body ...)))]) - #'(begin - (define-syntaxes (id ...) expr) - ... - body ...))))))])) + (map add-context (syntax->list #'(body ...)))] + [DEF def-id]) + (with-syntax ([(top-decl ...) + (if (and need-top-decl? (equal? 'top-level (syntax-local-context))) + #'((define-syntaxes (id ... ...) (values))) + null)]) + #'(begin + top-decl ... + (DEF (id ...) expr) + ... + body ...)))))))])) (define-syntax (splicing-let-syntax stx) - (do-let-syntax stx #f #f #'let-syntax)) + (do-let-syntax stx #f #f #'let-syntax #'define-syntaxes #f)) (define-syntax (splicing-let-syntaxes stx) - (do-let-syntax stx #f #t #'let-syntaxes)) + (do-let-syntax stx #f #t #'let-syntaxes #'define-syntaxes #f)) (define-syntax (splicing-letrec-syntax stx) - (do-let-syntax stx #t #f #'letrec-syntax)) + (do-let-syntax stx #t #f #'letrec-syntax #'define-syntaxes #f)) (define-syntax (splicing-letrec-syntaxes stx) - (do-let-syntax stx #t #t #'letrec-syntaxes)) + (do-let-syntax stx #t #t #'letrec-syntaxes #'define-syntaxes #f)) + +(define-syntax (splicing-let stx) + (do-let-syntax stx #f #f #'let #'define-values #f)) + +(define-syntax (splicing-let-values stx) + (do-let-syntax stx #f #t #'let-values #'define-values #f)) + +(define-syntax (splicing-letrec stx) + (do-let-syntax stx #t #f #'letrec #'define-values #t)) + +(define-syntax (splicing-letrec-values stx) + (do-let-syntax stx #t #t #'letrec-values #'define-values #t)) ;; ---------------------------------------- diff --git a/collects/scribblings/reference/splicing.scrbl b/collects/scribblings/reference/splicing.scrbl index 634458661c..5e3368e043 100644 --- a/collects/scribblings/reference/splicing.scrbl +++ b/collects/scribblings/reference/splicing.scrbl @@ -13,16 +13,25 @@ @note-lib-only[scheme/splicing] @deftogether[( +@defidform[splicing-let] +@defidform[splicing-letrec] +@defidform[splicing-let-values] +@defidform[splicing-letrec-values] @defidform[splicing-let-syntax] @defidform[splicing-letrec-syntax] @defidform[splicing-let-syntaxes] @defidform[splicing-letrec-syntaxes] )]{ -Like @scheme[let-syntax], @scheme[letrec-syntax], +Like @scheme[let], @scheme[letrec], @scheme[let-values], +@scheme[letrec-values], @scheme[let-syntax], @scheme[letrec-syntax], @scheme[let-syntaxes], and @scheme[letrec-syntaxes], except that in a definition context, the body forms are spliced into the enclosing -definition context (in the same as as for @scheme[begin]). +definition context (in the same as as for @scheme[begin]). Also, for +@scheme[splicing-letrec] and @scheme[splicing-letrec-values], a +reference to a bound identifiers before is initialized is treated in +the same way as definition in the enclosing context, which may be +different than for @scheme[letrec] and @scheme[letrec-values]. @examples[ #:eval splice-eval diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss index cb38db8f37..432281dbc3 100644 --- a/collects/tests/mzscheme/syntax.ss +++ b/collects/tests/mzscheme/syntax.ss @@ -1203,6 +1203,52 @@ (define x 10)) (abcdefg))) + +;; ---------------------------------------- + +(test 79 'splicing-let (let () + (splicing-let ([x 79]) + (define (y) x)) + (y))) +(test 77 'splicing-let (let () + (define q 77) + (splicing-let ([q 8] + [x q]) + (define (z) x)) + (z))) +(test 81 'splicing-letrec (let () + (define q 77) + (splicing-letrec ([q 81] + [x q]) + (define (z) x)) + (z))) +(test 82 'splicing-letrec (let () + (define q 77) + (splicing-letrec ([x (lambda () (q))] + [q (lambda () 82)]) + (define (z) x)) + ((z)))) +(test 81 'splicing-letrec (eval + '(begin + (define q 77) + (splicing-letrec ([q 81] + [x q]) + (define (z) x)) + (z)))) +(test 82 'splicing-letrec (eval + '(begin + (define q 77) + (splicing-letrec ([x (lambda () (q))] + [q (lambda () 82)]) + (define (z) x)) + ((z))))) +(err/rt-test (eval + '(begin + (splicing-letrec ([x q] + [q 81]) + x))) + exn:fail:contract:variable?) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) From 977b08c5c4de9120354f0b42af0498044b8aa61c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 18 Mar 2009 01:20:42 +0000 Subject: [PATCH 070/140] Fix bug in calling put_short with a bad value svn: r14166 --- collects/mzlib/deflate.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/mzlib/deflate.ss b/collects/mzlib/deflate.ss index 125db9e05e..c0f89d1222 100644 --- a/collects/mzlib/deflate.ss +++ b/collects/mzlib/deflate.ss @@ -2062,7 +2062,7 @@ (when header (put_short len) - (put_short (bitwise-not len)) + (put_short (bitwise-and (bitwise-not len) #xFFFF)) (set! bits_sent (+ bits_sent (* 2 16)))) (set! bits_sent (+ bits_sent (<< len 3))) @@ -2112,7 +2112,7 @@ ;; /* Output a 32 bit value to the bit stream, lsb first */ (define (put_long n) (put_short (bitwise-and #xFFFF n)) - (put_short (>> n 16))) + (put_short (bitwise-and #xFFFF (>> n 16)))) (define outcnt 0) (define bytes_out 0) From bdc82f21006bfa056ac94c439431b7820132b79c Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Wed, 18 Mar 2009 07:50:05 +0000 Subject: [PATCH 071/140] Welcome to a new PLT day. svn: r14169 --- collects/repos-time-stamp/stamp.ss | 2 +- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index c82a55de51..995aabcb64 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "17mar2009") +#lang scheme/base (provide stamp) (define stamp "18mar2009") diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 07638206ba..3afc29ca9f 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Wed, 18 Mar 2009 11:53:42 +0000 Subject: [PATCH 072/140] fix htdp lang require test: merge to 4.1.5 svn: r14170 --- collects/tests/mzscheme/beg-adv.ss | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/tests/mzscheme/beg-adv.ss b/collects/tests/mzscheme/beg-adv.ss index 79d118494f..6430ee5e7b 100644 --- a/collects/tests/mzscheme/beg-adv.ss +++ b/collects/tests/mzscheme/beg-adv.ss @@ -221,6 +221,9 @@ (htdp-top (require (lib "unit.ss" "mzlib"))) (htdp-test #f unit? 12) (htdp-top-pop 1) +(htdp-top (require mzlib/unit)) +(htdp-test #f unit? 12) +(htdp-top-pop 1) ;; Error messages (htdp-top (define my-x 5)) @@ -236,7 +239,7 @@ (htdp-syntax-test #'define #rx"does not follow") (htdp-syntax-test #'(require) #rx"found nothing") -(htdp-syntax-test #'(require a) #rx"expected a module name as a") +(htdp-syntax-test #'(require a!) #rx"bad syntax for a module path") (htdp-syntax-test #'(require "a" "b") #rx"a single module name") (htdp-syntax-test #'(require "") #rx"empty") (htdp-syntax-test #'(require "/a") #rx"start with a slash") From cca41988afc42e7765a9790c0e8bf4446b9920ec Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Wed, 18 Mar 2009 14:21:42 +0000 Subject: [PATCH 073/140] added $n-start-pos and $n-end-pos svn: r14171 --- collects/parser-tools/parser-tools.scrbl | 18 +++--- .../private-yacc/input-file-parser.ss | 63 ++++++++++++------- 2 files changed, 51 insertions(+), 30 deletions(-) diff --git a/collects/parser-tools/parser-tools.scrbl b/collects/parser-tools/parser-tools.scrbl index e0cbd21223..a49958ddf7 100644 --- a/collects/parser-tools/parser-tools.scrbl +++ b/collects/parser-tools/parser-tools.scrbl @@ -526,23 +526,27 @@ the right choice when using @scheme[lexer] in other situations. Each action is scheme code that has the same scope as its parser's definition, except that the variables @scheme[$1], ..., - @schemeidfont{$}@math{n} are bound, where @math{n} is the number + @schemeidfont{$}@math{i} are bound, where @math{i} is the number of @scheme[grammar-id]s in the corresponding production. Each - @schemeidfont{$}@math{i} is bound to the result of the action - for the @math{i}@superscript{th} grammar symbol on the right of + @schemeidfont{$}@math{k} is bound to the result of the action + for the @math{k}@superscript{th} grammar symbol on the right of the production, if that grammar symbol is a non-terminal, or the value stored in the token if the grammar symbol is a terminal. If the @scheme[src-pos] option is present in the parser, then variables @scheme[$1-start-pos], ..., - @schemeidfont{$}@math{n}@schemeidfont{-start-pos} and + @schemeidfont{$}@math{i}@schemeidfont{-start-pos} and @scheme[$1-end-pos], ..., - @schemeidfont{$}@math{n}@schemeidfont{-end-pos} and are also + @schemeidfont{$}@math{i}@schemeidfont{-end-pos} and are also available, and they refer to the position structures corresponding to the start and end of the corresponding @scheme[grammar-symbol]. Grammar symbols defined as empty-tokens - have no @schemeidfont{$}@math{i} associated, but do have + have no @schemeidfont{$}@math{k} associated, but do have + @schemeidfont{$}@math{k}@schemeidfont{-start-pos} and + @schemeidfont{$}@math{k}@schemeidfont{-end-pos}. + Also @schemeidfont{$n-start-pos} and @schemeidfont{$n-end-pos} + are bound to the largest start and end positions, (i.e., @schemeidfont{$}@math{i}@schemeidfont{-start-pos} and - @schemeidfont{$}@math{i}@schemeidfont{-end-pos}. + @schemeidfont{$}@math{i}@schemeidfont{-end-pos}). All of the productions for a given non-terminal must be grouped with it. That is, no @scheme[non-terminal-id] may appear twice diff --git a/collects/parser-tools/private-yacc/input-file-parser.ss b/collects/parser-tools/private-yacc/input-file-parser.ss index c8508f6cdc..5c6771c94e 100644 --- a/collects/parser-tools/private-yacc/input-file-parser.ss +++ b/collects/parser-tools/private-yacc/input-file-parser.ss @@ -18,9 +18,10 @@ (define stx-for-original-property (read-syntax #f (open-input-string "original"))) - ;; get-args: ??? + ;; get-args: ??? -> (values (listof syntax) (or/c #f (cons integer? stx))) (define (get-args i rhs src-pos term-defs) - (let ((empty-table (make-hash-table))) + (let ((empty-table (make-hash-table)) + (biggest-pos #f)) (hash-table-put! empty-table 'error #t) (for-each (lambda (td) (let ((v (syntax-local-value td))) @@ -29,24 +30,31 @@ (hash-table-put! empty-table (syntax-object->datum s) #t)) (syntax->list (e-terminals-def-t v)))))) term-defs) - (let get-args ((i i) - (rhs rhs)) - (cond - ((null? rhs) null) - (else - (let ((b (car rhs)) - (name (if (hash-table-get empty-table (syntax-object->datum (car rhs)) (lambda () #f)) - (gensym) - (string->symbol (format "$~a" i))))) - (cond - (src-pos - `(,(datum->syntax-object b name b stx-for-original-property) - ,(datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property) - ,(datum->syntax-object b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property) - ,@(get-args (add1 i) (cdr rhs)))) - (else - `(,(datum->syntax-object b name b stx-for-original-property) - ,@(get-args (add1 i) (cdr rhs))))))))))) + (let ([args + (let get-args ((i i) + (rhs rhs)) + (cond + ((null? rhs) null) + (else + (let ((b (car rhs)) + (name (if (hash-table-get empty-table (syntax-object->datum (car rhs)) (lambda () #f)) + (gensym) + (string->symbol (format "$~a" i))))) + (cond + (src-pos + (let ([start-pos-id + (datum->syntax-object b (string->symbol (format "$~a-start-pos" i)) b stx-for-original-property)] + [end-pos-id + (datum->syntax-object b (string->symbol (format "$~a-end-pos" i)) b stx-for-original-property)]) + (set! biggest-pos (cons start-pos-id end-pos-id)) + `(,(datum->syntax-object b name b stx-for-original-property) + ,start-pos-id + ,end-pos-id + ,@(get-args (add1 i) (cdr rhs))))) + (else + `(,(datum->syntax-object b name b stx-for-original-property) + ,@(get-args (add1 i) (cdr rhs)))))))))]) + (values args biggest-pos)))) ;; Given the list of terminal symbols and the precedence/associativity definitions, ;; builds terminal structures (See grammar.ss) @@ -250,9 +258,18 @@ ;; parse-action: syntax-object * syntax-object -> syntax-object (parse-action (lambda (rhs act) - (quasisyntax/loc act - (lambda #,(get-args 1 (syntax->list rhs) src-pos term-defs) - #,act)))) + (let-values ([(args biggest) (get-args 1 (syntax->list rhs) src-pos term-defs)]) + (let ([act + (if biggest + (with-syntax ([$n-start-pos (datum->syntax-object (car biggest) '$n-start-pos)] + [$n-end-pos (datum->syntax-object (cdr biggest) '$n-end-pos)]) + #`(let ([$n-start-pos #,(car biggest)] + [$n-end-pos #,(cdr biggest)]) + #,act)) + act)]) + (quasisyntax/loc act + (lambda #,args + #,act)))))) ;; parse-prod+action: non-term * syntax-object -> production (parse-prod+action From 05cf2432877327626865e1f1fc931937a50b4e0c Mon Sep 17 00:00:00 2001 From: Kathy Gray Date: Wed, 18 Mar 2009 15:55:18 +0000 Subject: [PATCH 074/140] Adding check-expect documentation, not tied to the teaching languages docs. svn: r14172 --- collects/test-engine/info.ss | 2 + collects/test-engine/test-engine.scrbl | 63 ++++++++++++++++++++++++++ 2 files changed, 65 insertions(+) create mode 100644 collects/test-engine/test-engine.scrbl diff --git a/collects/test-engine/info.ss b/collects/test-engine/info.ss index b3d8151bf4..038c6489e6 100644 --- a/collects/test-engine/info.ss +++ b/collects/test-engine/info.ss @@ -2,3 +2,5 @@ (define tools (list (list "test-tool.scm"))) (define tool-names '("Test Engine")) + +(define scribblings '(("test-engine.scrbl" () (tool-library)))) \ No newline at end of file diff --git a/collects/test-engine/test-engine.scrbl b/collects/test-engine/test-engine.scrbl new file mode 100644 index 0000000000..ebac43cdfd --- /dev/null +++ b/collects/test-engine/test-engine.scrbl @@ -0,0 +1,63 @@ +#lang scribble/doc +@(require scribble/manual + (for-label scheme/base + #;test-engine/scheme-tests)) + +@title{Test Support} + +@author["Kathryn Gray"] + +@table-of-contents[] + +@; ---------------------------------------------------------------------- + +@section{Using check forms} + +@defmodule[test-engine/scheme-tests] +@defmodule[test-engine/scheme-gui] + +These modules provide test forms for use in Scheme programs, as well as parameters to configure the behavior of test reports. + +The gui module requires MrEd and produces an independent window when displaying test results. Both modules provide an identical +set of check forms. + +Each check form may only occur at the top-level or within the definitions of a local declaration; +results are collected and reported by the test function. + + @defproc[(check-expect (test any/c) (expected any/c)) void?] + + + Accepts two value-producing expressions and structurally compares the resulting values. + + It is an error to produce a function value or an inexact number. + + +@defproc[(check-within (test any/c) (expected any/c) (delta number?)) void?] + +Like @scheme[check-expect], but with an extra expression that produces a number delta. Every number in the first expression + must be within delta of the cooresponding number in the second expression. + + It is an error to produce a function value. + + +@defproc[(check-error (test any/c) (msg string?)) void?] +Checks that evaluating the first expression signals an error, where the error message matches the string. + + +@defproc[(test) void?] + Runs all of the tests specified by check forms in the current module and reports the results. + When using the gui module, the results are provided in a separate window, otherwise the results + are printed to the current output port. + +@defproc[(test-format) (-> any/c string?)] + A parameter that stores the formatting function for the values tested by the check forms. + +@defproc[(test-silence) bool?] + A parameter that stores a boolean, defaults to #f, that can be used to suppress the printed + summary from test. + +@defproc[(test-execute) bool?] A parameter that stores a boolean, defaults to #t, that can be used to suppress evaluation of test expressions. + + +@section{Integrating languages with Test Engine} +To be written. \ No newline at end of file From d1ad79e96dccdad2b4a87ec738fb072dab58dd0b Mon Sep 17 00:00:00 2001 From: John Clements Date: Wed, 18 Mar 2009 21:55:01 +0000 Subject: [PATCH 075/140] updated for 4.1.5 svn: r14173 --- doc/release-notes/stepper/HISTORY.txt | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/doc/release-notes/stepper/HISTORY.txt b/doc/release-notes/stepper/HISTORY.txt index d7ccd3378f..a97dcc2374 100644 --- a/doc/release-notes/stepper/HISTORY.txt +++ b/doc/release-notes/stepper/HISTORY.txt @@ -1,6 +1,10 @@ Stepper ------- +Changes for v4.1.5: + +Minor bug fixes. + Changes for v4.1.4: None. From 4983ad30e3752c280e03c75df2b0cd0aed28dcd9 Mon Sep 17 00:00:00 2001 From: Matthias Felleisen Date: Wed, 18 Mar 2009 22:54:08 +0000 Subject: [PATCH 076/140] fixed number in teachpack svn: r14174 --- doc/release-notes/teachpack/HISTORY.txt | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/doc/release-notes/teachpack/HISTORY.txt b/doc/release-notes/teachpack/HISTORY.txt index f27c57b7b6..8c5523402d 100644 --- a/doc/release-notes/teachpack/HISTORY.txt +++ b/doc/release-notes/teachpack/HISTORY.txt @@ -1,5 +1,5 @@ ------------------------------------------------------------------------ -Version 4.1.****** [Sat Feb 14 20:12:23 EST 2009] +Version 4.1.5 [Sat Feb 14 20:12:23 EST 2009] * the universe teachpack exports iworld, not world now From 05c7e54222e849e5360aa820f8214dba870105c0 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 19 Mar 2009 02:32:45 +0000 Subject: [PATCH 077/140] fix lots of things svn: r14178 --- collects/test-engine/test-engine.scrbl | 113 +++++++++++++++---------- 1 file changed, 68 insertions(+), 45 deletions(-) diff --git a/collects/test-engine/test-engine.scrbl b/collects/test-engine/test-engine.scrbl index ebac43cdfd..80d332a5cb 100644 --- a/collects/test-engine/test-engine.scrbl +++ b/collects/test-engine/test-engine.scrbl @@ -1,7 +1,8 @@ #lang scribble/doc @(require scribble/manual - (for-label scheme/base - #;test-engine/scheme-tests)) + (for-label scheme/base + test-engine/scheme-tests + (prefix-in gui: test-engine/scheme-gui))) @title{Test Support} @@ -11,53 +12,75 @@ @; ---------------------------------------------------------------------- -@section{Using check forms} +@section{Using Check Forms} @defmodule[test-engine/scheme-tests] + +This module provides test forms for use in Scheme programs, as well +as parameters to configure the behavior of test reports. + +Each check form may only occur at the top-level or within the +definitions of a local declaration; results are collected and reported +by the test function. + +@defproc[(check-expect (test any/c) (expected any/c)) void?]{ + +Accepts two value-producing expressions and structurally compares the +resulting values. + +It is an error to produce a function value or an inexact number.} + + +@defproc[(check-within (test any/c) (expected any/c) (delta number?)) void?]{ + +Like @scheme[check-expect], but with an extra expression that produces +a number delta. Every number in the first expression must be within +delta of the cooresponding number in the second expression. + +It is an error to produce a function value.} + + +@defproc[(check-error (test any/c) (msg string?)) void?]{ + +Checks that evaluating the first expression signals an error, where +the error message matches the string.} + +@defproc[(test) void?]{ + +Runs all of the tests specified by check forms in the current module +and reports the results. When using the gui module, the results are +provided in a separate window, otherwise the results are printed to +the current output port.} + +@defparam[test-format format (any/c . -> . string?)]{ + +A parameter that stores the formatting function for the values tested +by the check forms.} + + +@defboolparam[test-silence silence?]{ + +A parameter that stores a boolean, defaults to #f, that can be used to +suppress the printed summary from test.} + + +@defboolparam[test-execute execute?]{ + +A parameter that stores a boolean, defaults to #t, that can be used to +suppress evaluation of test expressions. +} + +@section{GUI Interface} + @defmodule[test-engine/scheme-gui] -These modules provide test forms for use in Scheme programs, as well as parameters to configure the behavior of test reports. - -The gui module requires MrEd and produces an independent window when displaying test results. Both modules provide an identical -set of check forms. - -Each check form may only occur at the top-level or within the definitions of a local declaration; -results are collected and reported by the test function. - - @defproc[(check-expect (test any/c) (expected any/c)) void?] - - - Accepts two value-producing expressions and structurally compares the resulting values. - - It is an error to produce a function value or an inexact number. - - -@defproc[(check-within (test any/c) (expected any/c) (delta number?)) void?] - -Like @scheme[check-expect], but with an extra expression that produces a number delta. Every number in the first expression - must be within delta of the cooresponding number in the second expression. - - It is an error to produce a function value. - - -@defproc[(check-error (test any/c) (msg string?)) void?] -Checks that evaluating the first expression signals an error, where the error message matches the string. - - -@defproc[(test) void?] - Runs all of the tests specified by check forms in the current module and reports the results. - When using the gui module, the results are provided in a separate window, otherwise the results - are printed to the current output port. - -@defproc[(test-format) (-> any/c string?)] - A parameter that stores the formatting function for the values tested by the check forms. - -@defproc[(test-silence) bool?] - A parameter that stores a boolean, defaults to #f, that can be used to suppress the printed - summary from test. - -@defproc[(test-execute) bool?] A parameter that stores a boolean, defaults to #t, that can be used to suppress evaluation of test expressions. +@; FIXME: need to actually list the bindings here, so they're found in +@; the index +This module requires MrEd and produces an independent window when +displaying test results. It provides the same bindings as +@scheme[test-engine/scheme-tests]. @section{Integrating languages with Test Engine} -To be written. \ No newline at end of file + +@italic{(To be written.)} From e52b23b88134c2ee491e640f8c237af8d4714356 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Thu, 19 Mar 2009 07:50:28 +0000 Subject: [PATCH 078/140] Welcome to a new PLT day. svn: r14179 --- 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 995aabcb64..4d76bf533a 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "18mar2009") +#lang scheme/base (provide stamp) (define stamp "19mar2009") From 154b73755a855ecc3fd282a9e461cc834ed79072 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Mar 2009 12:31:33 +0000 Subject: [PATCH 079/140] sandbox break propagation svn: r14182 --- collects/scheme/sandbox.ss | 103 ++++++++++++++++++++++++------------- 1 file changed, 67 insertions(+), 36 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index df7b0766c8..3e834a0a0d 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -627,6 +627,7 @@ (define user-thread #t) ; set later to the thread (define user-done-evt #t) ; set in the same place (define terminated? #f) ; set to an exception value when the sandbox dies + (define breaks-originally-enabled? (break-enabled)) (define (limit-thunk thunk) (let* ([sec (and limits (car limits))] [mb (and limits (cadr limits))] @@ -665,42 +666,70 @@ (define (user-break) (when user-thread (break-thread user-thread))) (define (user-process) - (with-handlers ([void (lambda (exn) (channel-put result-ch exn))]) - ;; first set up the environment - (init-hook) - ((sandbox-init-hook)) - ;; now read and evaluate the input program - (evaluate-program - (if (procedure? program-maker) (program-maker) program-maker) - limit-thunk - (and coverage? (lambda (es+get) (set! uncovered es+get)))) - (channel-put result-ch 'ok)) - (set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler - ;; finally wait for interaction expressions - (let ([n 0]) - (let loop () - (let ([expr (channel-get input-ch)]) - (when (eof-object? expr) - (terminated! 'eof) (channel-put result-ch expr) (user-kill)) - (with-handlers ([void (lambda (exn) - (channel-put result-ch (cons 'exn exn)))]) - (define run - (if (evaluator-message? expr) - (case (evaluator-message-msg expr) - [(thunk) (limit-thunk (car (evaluator-message-args expr)))] - [(thunk*) (car (evaluator-message-args expr))] - [else (error 'sandbox "internal error (bad message)")]) - (limit-thunk - (lambda () - (set! n (add1 n)) - (eval* (map (lambda (expr) (cons '#%top-interaction expr)) - (input->code (list expr) 'eval n))))))) - (channel-put result-ch (cons 'vals (call-with-values run list)))) - (loop))))) + (let ([break-paramz (current-break-parameterization)]) + (parameterize-break + #f ;; disable breaks during administrative work + (with-handlers ([void (lambda (exn) (channel-put result-ch exn))]) + (call-with-break-parameterization + break-paramz + (lambda () + ;; enable breaks, maybe + (when breaks-originally-enabled? (break-enabled #t)) + ;; first set up the environment + (init-hook) + ((sandbox-init-hook)) + ;; now read and evaluate the input program + (evaluate-program + (if (procedure? program-maker) (program-maker) program-maker) + limit-thunk + (and coverage? (lambda (es+get) (set! uncovered es+get))))))) + (channel-put result-ch 'ok) + (set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler + ;; finally wait for interaction expressions + (let ([n 0]) + (let loop () + (let ([expr (channel-get input-ch)]) + (when (eof-object? expr) + (terminated! 'eof) (channel-put result-ch expr) (user-kill)) + (with-handlers ([void (lambda (exn) + (channel-put result-ch (cons 'exn exn)))]) + (define run + (if (evaluator-message? expr) + (case (evaluator-message-msg expr) + [(thunk) (limit-thunk (car (evaluator-message-args expr)))] + [(thunk*) (car (evaluator-message-args expr))] + [else (error 'sandbox "internal error (bad message)")]) + (limit-thunk + (lambda () + (set! n (add1 n)) + (eval* (map (lambda (expr) (cons '#%top-interaction expr)) + (input->code (list expr) 'eval n))))))) + (channel-put result-ch (cons 'vals + (call-with-break-parameterization + break-paramz + (lambda () + (call-with-values run list)))))) + (loop))))))) (define (get-user-result) - (with-handlers ([(if (sandbox-propagate-breaks) exn:break? (lambda (_) #f)) - (lambda (e) (user-break) (get-user-result))]) - (sync user-done-evt result-ch))) + (let ([get-result (lambda () (sync user-done-evt result-ch))]) + (if (and (sandbox-propagate-breaks) + ;; The following test is weird. We reliably catch breaks if breaks + ;; are enabled, except that a break just before or after isn't + ;; reliably propagated. A `get-result/enable-breaks' function + ;; would make more sense. + (break-enabled)) + ;; The following loop ensures that breaks are disabled while trying + ;; to handle a break, which ensures that we don't fail to + ;; propagate a break. + (parameterize-break + #f + (let loop () + (with-handlers* ([exn:break? (lambda (e) (user-break) (loop))]) + (parameterize-break + #t + (get-result))))) + ;; The same case doesn't have to deal with breaks: + (get-result)))) (define (user-eval expr) ;; the thread will usually be running, but it might be killed outside of ;; the sandboxed environment, for example, if you do something like @@ -856,7 +885,9 @@ ;; evaluates the program in `run-in-bg') -- so this parameterization ;; must be nested in the above (which is what paramaterize* does), or ;; it will not use the new namespace. - [current-eventspace (make-eventspace)]) + [current-eventspace (parameterize-break + #f + (make-eventspace))]) (let ([t (bg-run->thread (run-in-bg user-process))]) (set! user-done-evt (handle-evt t (lambda (_) (terminate+kill! #t #t)))) (set! user-thread t)) From f14b7158cd7c024efd6b5ac739ca71a797cea48a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Mar 2009 12:33:22 +0000 Subject: [PATCH 080/140] better error message for R5RS transformer expressions that are not 'syntax-rules' svn: r14183 --- collects/r5rs/main.ss | 8 ++++++-- collects/r5rs/private/r5rs-trans.ss | 11 +++++++++++ collects/r5rs/r5rs.scrbl | 3 ++- 3 files changed, 19 insertions(+), 3 deletions(-) create mode 100644 collects/r5rs/private/r5rs-trans.ss diff --git a/collects/r5rs/main.ss b/collects/r5rs/main.ss index a39d84d29d..6e48ff2b52 100644 --- a/collects/r5rs/main.ss +++ b/collects/r5rs/main.ss @@ -1,10 +1,14 @@ (module main scheme/base (require scheme/mpair - (for-syntax scheme/base syntax/kerncase) + (for-syntax scheme/base syntax/kerncase + "private/r5rs-trans.ss") (only-in mzscheme transcript-on transcript-off)) - (provide (for-syntax syntax-rules ...) + (provide (for-syntax syntax-rules ... + (rename-out [syntax-rules-only #%top] + [syntax-rules-only #%app] + [syntax-rules-only #%datum])) (rename-out [mcons cons] [mcar car] diff --git a/collects/r5rs/private/r5rs-trans.ss b/collects/r5rs/private/r5rs-trans.ss new file mode 100644 index 0000000000..62fa57ccef --- /dev/null +++ b/collects/r5rs/private/r5rs-trans.ss @@ -0,0 +1,11 @@ +#lang scheme/base +(require (for-syntax scheme/base)) +(provide syntax-rules-only) + +(define-syntax (syntax-rules-only stx) + (syntax-case stx () + [(_ . form) + (raise-syntax-error + 'macro-transformer + "only a `syntax-rules' form is allowed" + #'form)])) diff --git a/collects/r5rs/r5rs.scrbl b/collects/r5rs/r5rs.scrbl index 6da1ff522a..ffcb6a8629 100644 --- a/collects/r5rs/r5rs.scrbl +++ b/collects/r5rs/r5rs.scrbl @@ -1,6 +1,7 @@ #lang scribble/doc @(require scribble/manual - (for-label r5rs + (for-label (only-meta-in 0 r5rs) + (only-in r5rs syntax-rules ...) (only-in mzscheme #%plain-module-begin) (only-in scheme/mpair mmap) (only-in scheme/contract one-of/c) From edcec6820e894718480555cd46f1cb0360b75ff1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Mar 2009 12:34:03 +0000 Subject: [PATCH 081/140] fix SirMail encoding and headers for non-ASCII outgoing messages svn: r14184 --- collects/sirmail/sendr.ss | 70 ++++++++++++++++++++++++--------------- 1 file changed, 44 insertions(+), 26 deletions(-) diff --git a/collects/sirmail/sendr.ss b/collects/sirmail/sendr.ss index 3f648394e6..fa7e7f8c8d 100644 --- a/collects/sirmail/sendr.ss +++ b/collects/sirmail/sendr.ss @@ -6,6 +6,7 @@ (require scheme/tcp scheme/unit scheme/class + scheme/string mred/mred-sig framework) @@ -133,12 +134,34 @@ ;; `body-lines' is a list of strings and byte strings ;; `enclosures' is a list of `enclosure' structs (define (enclose header body-lines enclosures) + (define qp-body-lines? + (ormap (lambda (l) + (or ((string-length l) . > . 1000) + (regexp-match? #rx"[^\0-\177]" l))) + body-lines)) + (define (encode-body-lines) + (if qp-body-lines? + (map + bytes->string/utf-8 + (regexp-split #rx"\r\n" + (qp-encode (string->bytes/utf-8 + (string-join body-lines "\r\n"))))) + body-lines)) + (define (add-body-encoding-headers header) + (insert-field + "Content-Type" + "text/plain; charset=UTF-8" + (insert-field + "Content-Transfer-Encoding" + (if qp-body-lines? "quoted-printable" "7bit") + header))) (if (null? enclosures) (values (insert-field - "Content-Type" - "text/plain; charset=UTF-8" - header) - body-lines) + "MIME-Version" + "1.0" + (add-body-encoding-headers + header)) + (encode-body-lines)) (let* ([enclosure-datas (map (lambda (e) ((enclosure-data-thunk e))) enclosures)] [boundary @@ -175,28 +198,23 @@ "This is a multi-part message in MIME format." (format "--~a" boundary)) (header->lines - (insert-field - "Content-Type" - "text/plain; charset=UTF-8" - (insert-field - "Content-Transfer-Encoding" - "7bit" - empty-header))) - body-lines - (apply - append - (map - (lambda (enc data) - (cons - (format "--~a" boundary) - (append - (header->lines - (enclosure-subheader enc)) - data))) - enclosures enclosure-datas)) - (list - (format "--~a--" boundary)))))))) - + (add-body-encoding-headers + empty-header)) + (encode-body-lines) + (apply + append + (map + (lambda (enc data) + (cons + (format "--~a" boundary) + (append + (header->lines + (enclosure-subheader enc)) + data))) + enclosures enclosure-datas)) + (list + (format "--~a--" boundary)))))))) + (define (get-enclosure-type-and-encoding filename mailer-frame auto?) (let ([types '("application/postscript" "text/plain" From 88222f7df4c94279e4390ed4772ada31b5c776de Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Mar 2009 12:35:34 +0000 Subject: [PATCH 082/140] fix problems with break exceptions and thread termination during constant-folding, make GMP temporary memory accountable by GC, and limit folding of 'expt' expressions svn: r14185 --- src/mzscheme/gc2/mem_account.c | 2 +- src/mzscheme/include/scheme.h | 1 + src/mzscheme/src/bignum.c | 14 +++++++ src/mzscheme/src/error.c | 10 +++++ src/mzscheme/src/eval.c | 15 ++++++- src/mzscheme/src/gmp/gmp.c | 34 +++++++++------- src/mzscheme/src/mzmarksrc.c | 1 + src/mzscheme/src/read.c | 2 +- src/mzscheme/src/thread.c | 72 ++++++++++++++++++++++++++++++---- 9 files changed, 124 insertions(+), 27 deletions(-) diff --git a/src/mzscheme/gc2/mem_account.c b/src/mzscheme/gc2/mem_account.c index 67eb15fe33..c9e9ba92e2 100644 --- a/src/mzscheme/gc2/mem_account.c +++ b/src/mzscheme/gc2/mem_account.c @@ -590,7 +590,7 @@ inline static void BTC_run_account_hooks(NewGC *gc) if( ((work->type == MZACCT_REQUIRE) && ((gc->used_pages > (gc->max_pages_for_use / 2)) || ((((gc->max_pages_for_use / 2) - gc->used_pages) * APAGE_SIZE) - < (work->amount + custodian_super_require(gc, work->c1))))) + < (work->amount + custodian_super_require(gc, work->c1))))) || ((work->type == MZACCT_LIMIT) && (GC_get_memory_use(work->c1) > work->amount))) { diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index d924b5952f..41b06f0eee 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -1079,6 +1079,7 @@ typedef struct Scheme_Thread { /* save thread-specific GMP state: */ long gmp_tls[6]; + void *gmp_tls_data; struct Scheme_Thread_Custodian_Hop *mr_hop; Scheme_Custodian_Reference *mref; diff --git a/src/mzscheme/src/bignum.c b/src/mzscheme/src/bignum.c index 12fb65e68f..46d4493beb 100644 --- a/src/mzscheme/src/bignum.c +++ b/src/mzscheme/src/bignum.c @@ -887,6 +887,20 @@ Scheme_Object *do_big_power(const Scheme_Object *a, const Scheme_Object *b) Scheme_Object *scheme_generic_integer_power(const Scheme_Object *a, const Scheme_Object *b) { unsigned long exponent; + + if (scheme_current_thread->constant_folding) { + /* if we're trying to fold a constant, limit the work that we're willing to do at compile time */ + if (SCHEME_BIGNUMP(b) + || (SCHEME_INT_VAL(b) > 10000)) + scheme_signal_error("too big"); + else if (SCHEME_BIGNUMP(a)) { + int len = SCHEME_BIGLEN(a); + if ((len > 10000) + || (len * SCHEME_INT_VAL(b)) > 10000) + scheme_signal_error("too big"); + } + } + if (scheme_get_unsigned_int_val((Scheme_Object *)b, &exponent)) return do_power(a, exponent); else diff --git a/src/mzscheme/src/error.c b/src/mzscheme/src/error.c index f59f5ff98c..e74d9ad92b 100644 --- a/src/mzscheme/src/error.c +++ b/src/mzscheme/src/error.c @@ -660,6 +660,11 @@ call_error(char *buffer, int len, Scheme_Object *exn) "optimizer constant-fold attempt failed%s: %s", scheme_optimize_context_to_string(scheme_current_thread->constant_folding), buffer); + if (SCHEME_STRUCTP(exn) + && scheme_is_struct_instance(exn_table[MZEXN_BREAK].type, exn)) { + /* remember to re-raise exception */ + scheme_current_thread->reading_delayed = exn; + } scheme_longjmp(scheme_error_buf, 1); } else if (scheme_current_thread->reading_delayed) { scheme_current_thread->reading_delayed = exn; @@ -3257,6 +3262,11 @@ do_raise(Scheme_Object *arg, int need_debug, int eb) scheme_optimize_context_to_string(p->constant_folding), msg); } + if (SCHEME_STRUCTP(arg) + && scheme_is_struct_instance(exn_table[MZEXN_BREAK].type, arg)) { + /* remember to re-raise exception */ + scheme_current_thread->reading_delayed = arg; + } scheme_longjmp (scheme_error_buf, 1); } diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 78d4d555b2..5727de38cd 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -1012,19 +1012,30 @@ static Scheme_Object *try_apply(Scheme_Object *f, Scheme_Object *args, Scheme_Ob folding attempts */ { Scheme_Object * volatile result; + Scheme_Object * volatile exn = NULL; mz_jmp_buf *savebuf, newbuf; + scheme_current_thread->reading_delayed = NULL; scheme_current_thread->constant_folding = (context ? context : scheme_true); savebuf = scheme_current_thread->error_buf; scheme_current_thread->error_buf = &newbuf; - if (scheme_setjmp(newbuf)) + if (scheme_setjmp(newbuf)) { result = NULL; - else + exn = scheme_current_thread->reading_delayed; + } else result = _scheme_apply_to_list(f, args); scheme_current_thread->error_buf = savebuf; scheme_current_thread->constant_folding = NULL; + scheme_current_thread->reading_delayed = NULL; + + if (scheme_current_thread->cjs.is_kill) { + scheme_longjmp(*scheme_current_thread->error_buf, 1); + } + + if (exn) + scheme_raise(exn); return result; } diff --git a/src/mzscheme/src/gmp/gmp.c b/src/mzscheme/src/gmp/gmp.c index f754b14157..13a61a2fd1 100644 --- a/src/mzscheme/src/gmp/gmp.c +++ b/src/mzscheme/src/gmp/gmp.c @@ -21,13 +21,11 @@ MA 02111-1307, USA. */ #define _FORCE_INLINES #define _EXTERN_INLINE /* empty */ -/* We use malloc for now; this will have to change. */ -/* The allocation function should not create collectable - memory, though it can safely GC when allocating. */ -extern void *malloc(unsigned long); -extern void free(void *); -#define MALLOC malloc -#define FREE(p, s) free(p) +extern void *scheme_malloc_gmp(unsigned long, void **mem_pool); +extern void scheme_free_gmp(void *, void **mem_pool); +static void *mem_pool = 0; +#define MALLOC(amt) scheme_malloc_gmp(amt, &mem_pool) +#define FREE(p, s) scheme_free_gmp(p, &mem_pool) #include "../../sconfig.h" #include "mzconfig.h" @@ -5796,18 +5794,21 @@ void scheme_gmp_tls_init(long *s) ((tmp_marker *)(s + 3))->alloc_point = &xxx; } -void scheme_gmp_tls_load(long *s) +void *scheme_gmp_tls_load(long *s) { s[0] = (long)current_total_allocation; s[1] = (long)max_total_allocation; s[2] = (long)current; + return mem_pool; } -void scheme_gmp_tls_unload(long *s) +void scheme_gmp_tls_unload(long *s, void *data) { current_total_allocation = (unsigned long)s[0]; max_total_allocation = (unsigned long)s[1]; current = (tmp_stack *)s[2]; + s[0] = 0; + mem_pool = data; } void scheme_gmp_tls_snapshot(long *s, long *save) @@ -5817,14 +5818,16 @@ void scheme_gmp_tls_snapshot(long *s, long *save) __gmp_tmp_mark((tmp_marker *)(s + 3)); } -void scheme_gmp_tls_restore_snapshot(long *s, long *save, int do_free) +void scheme_gmp_tls_restore_snapshot(long *s, void *data, long *save, int do_free) { long other[6]; + void *other_data; if (do_free == 2) { - scheme_gmp_tls_load(other); - scheme_gmp_tls_unload(s); - } + other_data = scheme_gmp_tls_load(other); + scheme_gmp_tls_unload(s, data); + } else + other_data = NULL; if (do_free) __gmp_tmp_free((tmp_marker *)(s + 3)); @@ -5832,11 +5835,12 @@ void scheme_gmp_tls_restore_snapshot(long *s, long *save, int do_free) if (save) { s[3] = save[0]; s[4] = save[1]; + } if (do_free == 2) { - scheme_gmp_tls_load(s); - scheme_gmp_tls_unload(other); + data = scheme_gmp_tls_load(s); + scheme_gmp_tls_unload(other, other_data); } } diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index 66afce57cf..f8f0dd3a37 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -690,6 +690,7 @@ thread_val { gcMARK(pr->private_kill_next); gcMARK(pr->user_tls); + gcMARK(pr->gmp_tls_data); gcMARK(pr->mr_hop); gcMARK(pr->mref); diff --git a/src/mzscheme/src/read.c b/src/mzscheme/src/read.c index 5823bb7042..6ea1585bbf 100644 --- a/src/mzscheme/src/read.c +++ b/src/mzscheme/src/read.c @@ -5457,7 +5457,7 @@ Scheme_Object *scheme_load_delayed_code(int _which, Scheme_Load_Delay *_delay_in return v; } else { - if (v_exn) + if (v_exn && !scheme_current_thread->cjs.is_kill) scheme_raise(v_exn); scheme_longjmp(*scheme_current_thread->error_buf, 1); return NULL; diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 4f91a56160..232d6be8cd 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -114,10 +114,10 @@ static int swapping = 0; #endif extern void scheme_gmp_tls_init(long *s); -extern void scheme_gmp_tls_load(long *s); -extern void scheme_gmp_tls_unload(long *s); +extern void *scheme_gmp_tls_load(long *s); +extern void scheme_gmp_tls_unload(long *s, void *p); extern void scheme_gmp_tls_snapshot(long *s, long *save); -extern void scheme_gmp_tls_restore_snapshot(long *s, long *save, int do_free); +extern void scheme_gmp_tls_restore_snapshot(long *s, void *data, long *save, int do_free); static void check_ready_break(); @@ -2511,7 +2511,9 @@ static void do_swap_thread() #if WATCH_FOR_NESTED_SWAPS swapping = 0; #endif - scheme_gmp_tls_unload(scheme_current_thread->gmp_tls); + scheme_gmp_tls_unload(scheme_current_thread->gmp_tls, scheme_current_thread->gmp_tls_data); + scheme_current_thread->gmp_tls_data = NULL; + { Scheme_Object *l, *o; Scheme_Closure_Func f; @@ -2558,7 +2560,11 @@ static void do_swap_thread() cb = can_break_param(scheme_current_thread); scheme_current_thread->can_break_at_swap = cb; } - scheme_gmp_tls_load(scheme_current_thread->gmp_tls); + { + GC_CAN_IGNORE void *data; + data = scheme_gmp_tls_load(scheme_current_thread->gmp_tls); + scheme_current_thread->gmp_tls_data = data; + } #ifdef RUNSTACK_IS_GLOBAL scheme_current_thread->runstack = MZ_RUNSTACK; scheme_current_thread->runstack_start = MZ_RUNSTACK_START; @@ -2782,7 +2788,8 @@ static void remove_thread(Scheme_Thread *r) thread_is_dead(r); /* In case we kill a thread while in a bignum operation: */ - scheme_gmp_tls_restore_snapshot(r->gmp_tls, NULL, ((r == scheme_current_thread) ? 1 : 2)); + scheme_gmp_tls_restore_snapshot(r->gmp_tls, r->gmp_tls_data, + NULL, ((r == scheme_current_thread) ? 1 : 2)); if (r == scheme_current_thread) { /* We're going to be swapped out immediately. */ @@ -2825,7 +2832,8 @@ static void start_child(Scheme_Thread * volatile child, MZ_CONT_MARK_STACK = scheme_current_thread->cont_mark_stack; MZ_CONT_MARK_POS = scheme_current_thread->cont_mark_pos; #endif - scheme_gmp_tls_unload(scheme_current_thread->gmp_tls); + scheme_gmp_tls_unload(scheme_current_thread->gmp_tls, scheme_current_thread->gmp_tls_data); + scheme_current_thread->gmp_tls_data = NULL; { Scheme_Object *l, *o; Scheme_Closure_Func f; @@ -3745,7 +3753,7 @@ static Scheme_Object *raise_user_break(int argc, Scheme_Object ** volatile argv) int cont; cont = SAME_OBJ((Scheme_Object *)scheme_jumping_to_continuation, argv[0]); - scheme_gmp_tls_restore_snapshot(scheme_current_thread->gmp_tls, save, !cont); + scheme_gmp_tls_restore_snapshot(scheme_current_thread->gmp_tls, NULL, save, !cont); scheme_longjmp(*savebuf, 1); } @@ -7325,6 +7333,12 @@ static void get_ready_for_GC() scheme_block_child_signals(1); #endif + { + GC_CAN_IGNORE void *data; + data = scheme_gmp_tls_load(scheme_current_thread->gmp_tls); + scheme_current_thread->gmp_tls_data = data; + } + did_gc_count++; } @@ -7332,6 +7346,9 @@ extern int GC_words_allocd; static void done_with_GC() { + scheme_gmp_tls_unload(scheme_current_thread->gmp_tls, scheme_current_thread->gmp_tls_data); + scheme_current_thread->gmp_tls_data = NULL; + #ifdef RUNSTACK_IS_GLOBAL # ifdef MZ_PRECISE_GC if (scheme_current_thread->running) { @@ -7505,6 +7522,45 @@ static Scheme_Object *current_stats(int argc, Scheme_Object *argv[]) return scheme_void; } +/*========================================================================*/ +/* gmp allocation */ +/*========================================================================*/ + +/* Allocate atomic, immobile memory for GMP. Although we have set up + GMP to reliably free anything that it allocates, we allocate via + the GC to get accounting with 3m. The set of allocated blocks are + stored in a "mem_pool" variable, which is a linked list; GMP + allocates with a stack discipline, so maintaining the list is easy. + Meanwhile, scheme_gmp_tls_unload, etc., attach to the pool to the + owning thread as needed for GC. */ + +void *scheme_malloc_gmp(unsigned long amt, void **mem_pool) +{ + void *p, *mp; + +#ifdef MZ_PRECISE_GC + if (amt < GC_malloc_stays_put_threshold()) + amt = GC_malloc_stays_put_threshold(); +#endif + + p = scheme_malloc_atomic(amt); + + mp = scheme_make_raw_pair(p, *mem_pool); + *mem_pool = mp; + + return p; +} + +void scheme_free_gmp(void *p, void **mem_pool) +{ + if (p != SCHEME_CAR(*mem_pool)) + scheme_log(NULL, + SCHEME_LOG_FATAL, + 0, + "bad GMP memory free"); + *mem_pool = SCHEME_CDR(*mem_pool); +} + /*========================================================================*/ /* precise GC */ /*========================================================================*/ From 8e175869d9e1871e8d1c4c548f0f93bb167d0b29 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Mar 2009 13:06:14 +0000 Subject: [PATCH 083/140] refine expt constant-fold-fail message svn: r14186 --- src/mzscheme/src/bignum.c | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/src/mzscheme/src/bignum.c b/src/mzscheme/src/bignum.c index 46d4493beb..eec7d91266 100644 --- a/src/mzscheme/src/bignum.c +++ b/src/mzscheme/src/bignum.c @@ -890,14 +890,15 @@ Scheme_Object *scheme_generic_integer_power(const Scheme_Object *a, const Scheme if (scheme_current_thread->constant_folding) { /* if we're trying to fold a constant, limit the work that we're willing to do at compile time */ + GC_CAN_IGNORE const char *too_big = "arguments too big to fold `expt'"; if (SCHEME_BIGNUMP(b) || (SCHEME_INT_VAL(b) > 10000)) - scheme_signal_error("too big"); + scheme_signal_error(too_big); else if (SCHEME_BIGNUMP(a)) { int len = SCHEME_BIGLEN(a); if ((len > 10000) || (len * SCHEME_INT_VAL(b)) > 10000) - scheme_signal_error("too big"); + scheme_signal_error(too_big); } } From afc5ad8d830ea484ee2eb5e4ad309e215ac95e67 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Thu, 19 Mar 2009 13:22:46 +0000 Subject: [PATCH 084/140] fixed broken syntax error checks svn: r14187 --- collects/parser-tools/lex.ss | 3 +- collects/parser-tools/private-lex/actions.ss | 33 +++++++++----------- 2 files changed, 17 insertions(+), 19 deletions(-) diff --git a/collects/parser-tools/lex.ss b/collects/parser-tools/lex.ss index 4aceb59429..7613ecc9c1 100644 --- a/collects/parser-tools/lex.ss +++ b/collects/parser-tools/lex.ss @@ -81,7 +81,8 @@ (((special) act) (not (ormap (lambda (x) - (module-or-top-identifier=? (syntax special) x)) + (and (identifier? #'special) + (module-or-top-identifier=? (syntax special) x))) ids))) (_ #t))) spec/re-act-lst)) diff --git a/collects/parser-tools/private-lex/actions.ss b/collects/parser-tools/private-lex/actions.ss index 10330a899d..6ec0c7f491 100644 --- a/collects/parser-tools/private-lex/actions.ss +++ b/collects/parser-tools/private-lex/actions.ss @@ -1,19 +1,16 @@ -(module actions mzscheme - (provide (all-defined)) - (require syntax/stx) - - ;; get-special-action: (syntax-object list) syntax-object syntax-object -> syntax-object - ;; Returns the first action from a rule of the form ((which-special) action) - (define (get-special-action rules which-special none) - (cond - ((null? rules) none) - (else - (syntax-case (car rules) () - (((special) act) - (module-or-top-identifier=? (syntax special) which-special) - (syntax act)) - (_ (get-special-action (cdr rules) which-special none)))))) - +#lang scheme/base - - ) +(provide (all-defined-out)) +(require syntax/stx) + +;; get-special-action: (syntax-object list) syntax-object syntax-object -> syntax-object +;; Returns the first action from a rule of the form ((which-special) action) +(define (get-special-action rules which-special none) + (cond + ((null? rules) none) + (else + (syntax-case (car rules) () + (((special) act) + (and (identifier? #'special) (module-or-top-identifier=? (syntax special) which-special)) + (syntax act)) + (_ (get-special-action (cdr rules) which-special none)))))) From d154493077cdc9242eb98dba3041dd184cf9600a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 19 Mar 2009 13:45:45 +0000 Subject: [PATCH 085/140] scheme/splicing: added splicing variants of local and letrec-syntaxes+values svn: r14188 --- collects/scheme/local.ss | 65 +---------------- collects/scheme/private/local.ss | 81 +++++++++++++++++++++ collects/scheme/splicing.ss | 115 ++++++++++++++++++++++-------- collects/tests/mzscheme/syntax.ss | 72 ++++++++++++++++++- 4 files changed, 240 insertions(+), 93 deletions(-) create mode 100644 collects/scheme/private/local.ss diff --git a/collects/scheme/local.ss b/collects/scheme/local.ss index cb037855e0..88bd7fff69 100644 --- a/collects/scheme/local.ss +++ b/collects/scheme/local.ss @@ -1,66 +1,7 @@ #lang scheme/base - -(require (for-syntax scheme/base - syntax/context - syntax/kerncase)) - +(require (for-syntax scheme/base) + "private/local.ss") (provide local) (define-syntax (local stx) - (syntax-case stx () - [(_ (defn ...) body1 body ...) - (let ([defs (let ([expand-context (generate-expand-context)]) - (let loop ([defns (syntax->list (syntax (defn ...)))]) - (apply - append - (map - (lambda (defn) - (let ([d (local-expand - defn - expand-context - (kernel-form-identifier-list))] - [check-ids (lambda (ids) - (for-each - (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "not an identifier for definition" - stx - id))) - ids))]) - (syntax-case d (define-values define-syntaxes begin) - [(begin defn ...) - (loop (syntax->list (syntax (defn ...))))] - [(define-values (id ...) body) - (begin - (check-ids (syntax->list (syntax (id ...)))) - (list d))] - [(define-values . rest) - (raise-syntax-error - #f "ill-formed definition" stx d)] - [(define-syntaxes (id ...) body) - (begin - (check-ids (syntax->list (syntax (id ...)))) - (list d))] - [(define-syntaxes . rest) - (raise-syntax-error - #f "ill-formed definition" stx d)] - [_else - (raise-syntax-error - #f "not a definition" stx defn)]))) - defns))))]) - (let ([ids (apply append - (map - (lambda (d) - (syntax-case d () - [(_ ids . __) (syntax->list (syntax ids))])) - defs))]) - (let ([dup (check-duplicate-identifier ids)]) - (when dup - (raise-syntax-error #f "duplicate identifier" stx dup))) - (with-syntax ([(def ...) defs]) - (syntax/loc stx - (let () def ... (let () body1 body ...))))))] - [(_ x body1 body ...) - (raise-syntax-error #f "not a definition sequence" stx (syntax x))])) + (do-local stx #'letrec-syntaxes+values)) diff --git a/collects/scheme/private/local.ss b/collects/scheme/private/local.ss new file mode 100644 index 0000000000..7c0c27fbef --- /dev/null +++ b/collects/scheme/private/local.ss @@ -0,0 +1,81 @@ +#lang scheme/base +(require (for-syntax scheme/base) + (for-syntax syntax/context) + (for-syntax syntax/kerncase)) +(provide (for-syntax do-local)) + +(define-for-syntax (do-local stx letrec-syntaxes+values-id) + (syntax-case stx () + [(_ (defn ...) body1 body ...) + (let ([defs (let ([expand-context (generate-expand-context)]) + (let loop ([defns (syntax->list (syntax (defn ...)))]) + (apply + append + (map + (lambda (defn) + (let ([d (local-expand + defn + expand-context + (kernel-form-identifier-list))] + [check-ids (lambda (ids) + (for-each + (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "not an identifier for definition" + stx + id))) + ids))]) + (syntax-case d (define-values define-syntaxes begin) + [(begin defn ...) + (loop (syntax->list (syntax (defn ...))))] + [(define-values (id ...) body) + (begin + (check-ids (syntax->list (syntax (id ...)))) + (list d))] + [(define-values . rest) + (raise-syntax-error + #f "ill-formed definition" stx d)] + [(define-syntaxes (id ...) body) + (begin + (check-ids (syntax->list (syntax (id ...)))) + (list d))] + [(define-syntaxes . rest) + (raise-syntax-error + #f "ill-formed definition" stx d)] + [_else + (raise-syntax-error + #f "not a definition" stx defn)]))) + defns))))]) + (let ([ids (apply append + (map + (lambda (d) + (syntax-case d () + [(_ ids . __) (syntax->list (syntax ids))])) + defs))] + [vbindings (apply append + (map (lambda (d) + (syntax-case d (define-values) + [(define-values ids rhs) + (list #'(ids rhs))] + [_ null])) + defs))] + [sbindings (apply append + (map (lambda (d) + (syntax-case d (define-syntaxes) + [(define-syntaxes ids rhs) + (list #'(ids rhs))] + [_ null])) + defs))]) + (let ([dup (check-duplicate-identifier ids)]) + (when dup + (raise-syntax-error #f "duplicate identifier" stx dup))) + (with-syntax ([sbindings sbindings] + [vbindings vbindings] + [LSV letrec-syntaxes+values-id]) + (syntax/loc stx + (LSV sbindings vbindings + body1 body ...)))))] + [(_ x body1 body ...) + (raise-syntax-error #f "not a definition sequence" stx (syntax x))])) diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss index d0ad785a61..da675688ac 100644 --- a/collects/scheme/splicing.ss +++ b/collects/scheme/splicing.ss @@ -2,7 +2,8 @@ (require (for-syntax scheme/base syntax/kerncase) "stxparam.ss" - "private/stxparam.ss") + "private/stxparam.ss" + "private/local.ss") (provide splicing-let-syntax splicing-let-syntaxes @@ -12,45 +13,43 @@ splicing-let-values splicing-letrec splicing-letrec-values + splicing-letrec-syntaxes+values + splicing-local splicing-syntax-parameterize) +(define-for-syntax ((check-id stx) id-stx) + (unless (identifier? id-stx) + (raise-syntax-error #f "expected an identifier" stx id-stx)) + (list id-stx)) + +(define-for-syntax ((check-ids stx) ids-stx) + (let ([ids (syntax->list ids-stx)]) + (unless ids + (raise-syntax-error + #f + "expected a parenthesized sequence of identifiers" + stx + ids-stx)) + (for-each (check-id stx) ids) + ids)) + +(define-for-syntax (check-dup-binding stx idss) + (let ([dup-id (check-duplicate-identifier (apply append idss))]) + (when dup-id + (raise-syntax-error #f "duplicate binding" stx dup-id)))) + (define-for-syntax (do-let-syntax stx rec? multi? let-id def-id need-top-decl?) (syntax-case stx () [(_ ([ids expr] ...) body ...) - (let ([all-ids (map (lambda (ids-stx) - (let ([ids (if multi? - (syntax->list ids-stx) - (list ids-stx))]) - (unless ids - (raise-syntax-error - #f - "expected a parenthesized sequence of identifiers" - stx - ids-stx)) - (for-each (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "expected an identifier" - stx - id))) - ids) - ids)) + (let ([all-ids (map ((if multi? check-ids check-id) stx) (syntax->list #'(ids ...)))]) - (let ([dup-id (check-duplicate-identifier - (apply append all-ids))]) - (when dup-id - (raise-syntax-error - #f - "duplicate binding" - stx - dup-id))) + (check-dup-binding stx all-ids) (if (eq? 'expression (syntax-local-context)) (with-syntax ([LET let-id]) (syntax/loc stx (LET ([ids expr] ...) - (#%expression body) - ...))) + (#%expression body) + ...))) (let ([def-ctx (syntax-local-make-definition-context)] [ctx (list (gensym 'intdef))]) (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) @@ -111,6 +110,62 @@ ;; ---------------------------------------- +(define-syntax (splicing-letrec-syntaxes+values stx) + (syntax-case stx () + [(_ ([sids sexpr] ...) ([vids vexpr] ...) body ...) + (let* ([all-sids (map (check-ids stx) + (syntax->list #'(sids ...)))] + [all-vids (map (check-ids stx) + (syntax->list #'(vids ...)))] + [all-ids (append all-sids all-vids)]) + (check-dup-binding stx all-ids) + (if (eq? 'expression (syntax-local-context)) + (syntax/loc stx + (letrec-syntaxes+values ([sids sexpr] ...) ([vids vexpr] ...) + (#%expression body) ...)) + (let ([def-ctx (syntax-local-make-definition-context)] + [ctx (list (gensym 'intdef))]) + (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) + (internal-definition-context-seal def-ctx) + (let* ([add-context + (lambda (expr) + (let ([q (local-expand #`(quote #,expr) + ctx + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ expr) #'expr])))] + [add-context-to-idss + (lambda (idss) + (map add-context idss))]) + (with-syntax ([((sid ...) ...) + (map add-context-to-idss all-sids)] + [((vid ...) ...) + (map add-context-to-idss all-vids)] + [(sexpr ...) + (map add-context (syntax->list #'(sexpr ...)))] + [(vexpr ...) + (map add-context (syntax->list #'(vexpr ...)))] + [(body ...) + (map add-context (syntax->list #'(body ...)))]) + (with-syntax ([top-decl + (if (equal? 'top-level (syntax-local-context)) + #'(define-syntaxes (vid ... ...) (values)) + #'(begin))]) + (syntax/loc stx + (begin + top-decl + (define-syntaxes (sid ...) sexpr) ... + (define-values (vid ...) vexpr) ... + body ...))))))))])) + + + +(define-syntax (splicing-local stx) + (do-local stx #'splicing-letrec-syntaxes+values)) + +;; ---------------------------------------- + (define-syntax (splicing-syntax-parameterize stx) (if (eq? 'expression (syntax-local-context)) ;; Splicing is no help in an expression context: diff --git a/collects/tests/mzscheme/syntax.ss b/collects/tests/mzscheme/syntax.ss index 432281dbc3..c9f7b6a1ad 100644 --- a/collects/tests/mzscheme/syntax.ss +++ b/collects/tests/mzscheme/syntax.ss @@ -1249,7 +1249,77 @@ x))) exn:fail:contract:variable?) +(test 82 'splicing-letrec-syntaxes+values + (let () + (define q 77) + (splicing-letrec-syntaxes+values + ([(mx) (lambda (stx) (quote-syntax (x)))] + [(m) (lambda (stx) (quote-syntax (mx)))]) + ([(x) (lambda () (q))] + [(q) (lambda () 82)]) + (define (a) (m))) + (a))) + +(test 82 'splicing-letrec-syntaxes+values + (eval + '(begin + (define q 77) + (splicing-letrec-syntaxes+values + ([(mx) (lambda (stx) (quote-syntax (x)))] + [(m) (lambda (stx) (quote-syntax (mx)))]) + ([(x) (lambda () (q))] + [(q) (lambda () 82)]) + (define (a) (m))) + (a)))) + +(test 82 'splicing-local + (let () + (define (x) q) + (define q 77) + (define-syntax (m stx) (quote-syntax (x))) + (splicing-local + [(define-syntax (m stx) (quote-syntax (mx))) + (define (x) (q)) + (define-syntax (mx stx) (quote-syntax (x))) + (define (q) 82)] + (define (a) (m))) + (a))) + +(test 82 'splicing-local + (eval + '(begin + (define (x) q) + (define q 77) + (define-syntax (m stx) (quote-syntax (x))) + (splicing-local + [(define-syntax (m stx) (quote-syntax (mx))) + (define (x) (q)) + (define-syntax (mx stx) (quote-syntax (x))) + (define (q) 82)] + (define (a) (m))) + (a)))) + +;; local names are not visible outside +(test 77 'splicing-local + (let () + (define q 77) + (define-syntax (m stx) (quote-syntax (x))) + (splicing-local + [(define-syntax (m stx) (quote-syntax (q))) + (define (q) 82)] + (define (a) (m))) + (m))) +(test 77 'splicing-local + (eval + '(begin + (define q 77) + (define-syntax (m stx) (quote-syntax (x))) + (splicing-local + [(define-syntax (m stx) (quote-syntax (q))) + (define (q) 82)] + (define (a) (m))) + (m)))) + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (report-errs) - From 04e2fb9118b3168f82bfc734c493cf71e23d8d88 Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Thu, 19 Mar 2009 19:02:28 +0000 Subject: [PATCH 086/140] scheme/splicing: updated reference for new splicing forms svn: r14189 --- collects/scribblings/reference/splicing.scrbl | 32 ++++++++++++++----- 1 file changed, 24 insertions(+), 8 deletions(-) diff --git a/collects/scribblings/reference/splicing.scrbl b/collects/scribblings/reference/splicing.scrbl index 5e3368e043..ccae290e4f 100644 --- a/collects/scribblings/reference/splicing.scrbl +++ b/collects/scribblings/reference/splicing.scrbl @@ -1,7 +1,8 @@ #lang scribble/doc @(require "mz.ss" (for-label scheme/splicing - scheme/stxparam)) + scheme/stxparam + scheme/local)) @(define splice-eval (make-base-eval)) @interaction-eval[#:eval splice-eval (require scheme/splicing @@ -21,17 +22,16 @@ @defidform[splicing-letrec-syntax] @defidform[splicing-let-syntaxes] @defidform[splicing-letrec-syntaxes] +@defidform[splicing-letrec-syntaxes+values] +@defidform[splicing-local] )]{ Like @scheme[let], @scheme[letrec], @scheme[let-values], @scheme[letrec-values], @scheme[let-syntax], @scheme[letrec-syntax], -@scheme[let-syntaxes], and @scheme[letrec-syntaxes], except that in a +@scheme[let-syntaxes], @scheme[letrec-syntaxes], +@scheme[letrec-syntaxes+values], and @scheme[local], except that in a definition context, the body forms are spliced into the enclosing -definition context (in the same as as for @scheme[begin]). Also, for -@scheme[splicing-letrec] and @scheme[splicing-letrec-values], a -reference to a bound identifiers before is initialized is treated in -the same way as definition in the enclosing context, which may be -different than for @scheme[letrec] and @scheme[letrec-values]. +definition context (in the same way as for @scheme[begin]). @examples[ #:eval splice-eval @@ -39,7 +39,23 @@ different than for @scheme[letrec] and @scheme[letrec-values]. (define o one)) o one -]} +] + +When a splicing binding form occurs in a @tech{top-level context} or +@tech{module context}, its local bindings are treated similarly to +definitions. In particular, if a reference to one of the splicing +form's bound variables is evaluated before the variable is +initialized, an unbound variable error is raised, instead of the +variable evaluating to the undefined value. Also, syntax bindings are +evaluated every time the module is @tech{visit}ed, instead of only +once during compilation as in @scheme[let-syntax], etc. + +@examples[ +#:eval splice-eval +(splicing-letrec ([x bad] + [bad 1]) + x)] +} @defidform[splicing-syntax-parameterize]{ From 2109cec2f4d89f820647ae75e81b0d7b6a70f4a1 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Mar 2009 20:22:18 +0000 Subject: [PATCH 087/140] =?UTF-8?q?free-id=3D=3F=20propagation=20through?= =?UTF-8?q?=20module=20exports;=20add=20'not-free-identifier=3D=3F=20synta?= =?UTF-8?q?x=20property=20to=20disable=20free-id=3D=3F=20propagation;=20ad?= =?UTF-8?q?d=20prop:rename-transformer=20and=20prop:set-transformer;=20fix?= =?UTF-8?q?=20scheme/local=20so=20that=20local=20syntax=20bindings=20are?= =?UTF-8?q?=20visible=20to=20later=20definitions=20(v4.1.5.3)?= svn: r14191 --- collects/ffi/objc.scrbl | 4 +- collects/mzlib/foreign.ss | 1622 +---------------- collects/scheme/foreign.ss | 1622 ++++++++++++++++- collects/scheme/private/local.ss | 109 +- collects/scribblings/foreign/libs.scrbl | 1 - .../reference/module-reflect.scrbl | 4 +- .../scribblings/reference/stx-trans.scrbl | 129 +- .../scribblings/reference/syntax-model.scrbl | 28 +- collects/scribblings/reference/syntax.scrbl | 29 +- collects/tests/mzscheme/macro.ss | 105 ++ src/mzscheme/src/cstartup.inc | 324 ++-- src/mzscheme/src/env.c | 67 +- src/mzscheme/src/eval.c | 19 +- src/mzscheme/src/fun.c | 8 +- src/mzscheme/src/module.c | 123 +- src/mzscheme/src/schminc.h | 2 +- src/mzscheme/src/schpriv.h | 6 + src/mzscheme/src/schvers.h | 4 +- src/mzscheme/src/struct.c | 172 +- src/mzscheme/src/stxobj.c | 10 +- src/mzscheme/src/syntax.c | 22 +- 21 files changed, 2439 insertions(+), 1971 deletions(-) diff --git a/collects/ffi/objc.scrbl b/collects/ffi/objc.scrbl index a43ccb9713..b2b984d44c 100644 --- a/collects/ffi/objc.scrbl +++ b/collects/ffi/objc.scrbl @@ -14,9 +14,7 @@ @title{@bold{Objective-C} FFI} -@declare-exporting[ffi/private/objc-doc-unsafe #:use-sources (ffi/objc)] - -@defmodule*/no-declare[(ffi/objc)]{The @schememodname[ffi/objc] library builds on +@defmodule[ffi/objc]{The @schememodname[ffi/objc] library builds on @schememodname[scheme/foreign] to support interaction with @link["http://developer.apple.com/documentation/Cocoa/Conceptual/ObjectiveC/"]{Objective-C}.} diff --git a/collects/mzlib/foreign.ss b/collects/mzlib/foreign.ss index 5ca2e2446e..00d2ccebd7 100644 --- a/collects/mzlib/foreign.ss +++ b/collects/mzlib/foreign.ss @@ -1,1620 +1,4 @@ -#lang scheme/base -;; Foreign Scheme interface -(require '#%foreign setup/dirs - (for-syntax scheme/base scheme/list syntax/stx)) - -;; This module is full of unsafe bindings that are not provided to requiring -;; modules. Instead, an `unsafe!' binding is provided that makes these unsafe -;; bindings available. The following two syntaxes do that: `provide*' is like -;; `provide', but using `(unsafe id)' registers an unsafe binding. Then, -;; `define-unsafer' should be used with a binding that will expose the unsafe -;; bindings. This might move elsewhere at some point if it turns out to be -;; useful in other contexts. -(provide provide* define-unsafer) -(define-syntaxes (provide* define-unsafer) - (let ((unsafe-bindings '())) - (values - (lambda (stx) - (syntax-case stx () - [(_ p ...) - (let loop ([provides '()] - [unsafes '()] - [ps (syntax->list #'(p ...))]) - (if (null? ps) - (begin (set! unsafe-bindings - (append unsafe-bindings (reverse unsafes))) - (with-syntax ([(p ...) provides]) #'(provide p ...))) - (syntax-case (car ps) (unsafe) - [(unsafe u) - (syntax-case #'u (rename-out) - [(rename-out [from to]) - (loop provides (cons (cons #'from #'to) unsafes) (cdr ps))] - [id (identifier? #'id) - (loop provides (cons (cons #'id #'id) unsafes) (cdr ps))] - [_ - (raise-syntax-error 'provide* "bad unsafe usage" - (car ps) stx)])] - [_ (loop (cons (car ps) provides) unsafes (cdr ps))])))])) - (lambda (stx) - (syntax-case stx () - [(_ unsafe) - (with-syntax ([(from ...) (map car unsafe-bindings)] - [(to ...) (map cdr unsafe-bindings)] - [(id ...) (generate-temporaries unsafe-bindings)]) - (set! unsafe-bindings '()) - #'(begin - (provide (protect-out unsafe)) - (define-syntax (unsafe stx) - (syntax-case stx () - [(_) (with-syntax ([(id ...) (list (datum->syntax - stx 'to stx) - ...)]) - #'(begin (define-syntax id - (make-rename-transformer #'from)) - ...))]))))]))))) - -(provide* ctype-sizeof ctype-alignof compiler-sizeof - (unsafe malloc) (unsafe free) (unsafe end-stubborn-change) - cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) - ptr-offset ptr-add! offset-ptr? set-ptr-offset! - ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout - _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64 - _fixint _ufixint _fixnum _ufixnum - _float _double _double* - _bool _pointer _scheme _fpointer function-ptr - (unsafe memcpy) (unsafe memmove) (unsafe memset) - (unsafe malloc-immobile-cell) (unsafe free-immobile-cell)) - -(define-syntax define* - (syntax-rules () - [(_ (name . args) body ...) - (begin (provide name) (define (name . args) body ...))] - [(_ name expr) - (begin (provide name) (define name expr))])) - -;; ---------------------------------------------------------------------------- -;; C integer types - -(define* _sint8 _int8) -(define* _sint16 _int16) -(define* _sint32 _int32) -(define* _sint64 _int64) - -;; _byte etc is a convenient name for _uint8 & _sint8 -;; (_byte is unsigned) -(define* _byte _uint8) -(define* _ubyte _uint8) -(define* _sbyte _int8) - -;; _word etc is a convenient name for _uint16 & _sint16 -;; (_word is unsigned) -(define* _word _uint16) -(define* _uword _uint16) -(define* _sword _int16) - -;; _short etc is a convenient name for whatever is the compiler's `short' -;; (_short is signed) -(provide _short _ushort _sshort) -(define-values (_short _ushort _sshort) - (case (compiler-sizeof 'short) - [(2) (values _int16 _uint16 _int16)] - [(4) (values _int32 _uint32 _int32)] - [else (error 'foreign "internal error: bad compiler size for `short'")])) - -;; _int etc is a convenient name for whatever is the compiler's `int' -;; (_int is signed) -(provide _int _uint _sint) -(define-values (_int _uint _sint) - (case (compiler-sizeof 'int) - [(2) (values _int16 _uint16 _int16)] - [(4) (values _int32 _uint32 _int32)] - [(8) (values _int64 _uint64 _int64)] - [else (error 'foreign "internal error: bad compiler size for `int'")])) - -;; _long etc is a convenient name for whatever is the compiler's `long' -;; (_long is signed) -(provide _long _ulong _slong) -(define-values (_long _ulong _slong) - (case (compiler-sizeof 'long) - [(4) (values _int32 _uint32 _int32)] - [(8) (values _int64 _uint64 _int64)] - [else (error 'foreign "internal error: bad compiler size for `long'")])) - -;; _llong etc is a convenient name for whatever is the compiler's `long long' -;; (_llong is signed) -(provide _llong _ullong _sllong) -(define-values (_llong _ullong _sllong) - (case (compiler-sizeof '(long long)) - [(4) (values _int32 _uint32 _int32)] - [(8) (values _int64 _uint64 _int64)] - [else (error 'foreign "internal error: bad compiler size for `llong'")])) - -;; ---------------------------------------------------------------------------- -;; Getting and setting library objects - -(define lib-suffix (bytes->string/latin-1 (subbytes (system-type 'so-suffix) 1))) -(define lib-suffix-re (regexp (string-append "\\." lib-suffix "$"))) -(define suffix-before-version? (not (equal? lib-suffix "dylib"))) - -(provide* (unsafe (rename-out [get-ffi-lib ffi-lib])) - ffi-lib? ffi-lib-name) -(define get-ffi-lib - (case-lambda - [(name) (get-ffi-lib name "")] - [(name version/s) - (cond - [(not name) (ffi-lib name)] ; #f => NULL => open this executable - [(not (or (string? name) (path? name))) - (raise-type-error 'ffi-lib "library-name" name)] - [else - ;; A possible way that this might be misleading: say that there is a - ;; "foo.so" file in the current directory, which refers to some - ;; undefined symbol, trying to use this function with "foo.so" will try - ;; a dlopen with "foo.so" which isn't found, then it tries a dlopen with - ;; "//foo.so" which fails because of the undefined symbol, and - ;; since all fails, it will use (ffi-lib "foo.so") to raise the original - ;; file-not-found error. This is because the dlopen doesn't provide a - ;; way to distinguish different errors (only dlerror, but that's - ;; unreliable). - (let* ([versions (if (list? version/s) version/s (list version/s))] - [versions (map (lambda (v) - (if (or (not v) (zero? (string-length v))) - "" (string-append "." v))) - versions)] - [fullpath (lambda (p) (path->complete-path (cleanse-path p)))] - [absolute? (absolute-path? name)] - [name0 (path->string (cleanse-path name))] ; orig name - [names (map (if (regexp-match lib-suffix-re name0) ; name+suffix - (lambda (v) (string-append name0 v)) - (lambda (v) - (if suffix-before-version? - (string-append name0 "." lib-suffix v) - (string-append name0 v "." lib-suffix)))) - versions)] - [ffi-lib* (lambda (name) (ffi-lib name #t))]) - (or ;; try to look in our library paths first - (and (not absolute?) - (ormap (lambda (dir) - ;; try good names first, then original - (or (ormap (lambda (name) - (ffi-lib* (build-path dir name))) - names) - (ffi-lib* (build-path dir name0)))) - (get-lib-search-dirs))) - ;; try a system search - (ormap ffi-lib* names) ; try good names first - (ffi-lib* name0) ; try original - (ormap (lambda (name) ; try relative paths - (and (file-exists? name) (ffi-lib* (fullpath name)))) - names) - (and (file-exists? name0) ; relative with original - (ffi-lib* (fullpath name0))) - ;; give up: call ffi-lib so it will raise an error - (ffi-lib (car names))))])])) - -(define (get-ffi-lib-internal x) - (if (ffi-lib? x) x (get-ffi-lib x))) - -;; These internal functions provide the functionality to be used by -;; get-ffi-obj, set-ffi-obj! and define-c below -(define (ffi-get ffi-obj type) - (ptr-ref ffi-obj type)) -(define (ffi-set! ffi-obj type new) - (let-values ([(new type) (get-lowlevel-object new type)]) - (hash-set! ffi-objects-ref-table ffi-obj new) - (ptr-set! ffi-obj type new))) - -;; This is better handled with `make-c-parameter' -(provide* (unsafe ffi-obj-ref)) -(define ffi-obj-ref - (case-lambda - [(name lib) (ffi-obj-ref name lib #f)] - [(name lib failure) - (let ([name (get-ffi-obj-name 'ffi-obj-ref name)] - [lib (get-ffi-lib-internal lib)]) - (with-handlers ([exn:fail:filesystem? - (lambda (e) (if failure (failure) (raise e)))]) - (ffi-obj name lib)))])) - -;; get-ffi-obj is implemented as a syntax only to be able to propagate the -;; foreign name into the type syntax, which allows generated wrappers to have a -;; proper name. -(provide* (unsafe get-ffi-obj)) -(define get-ffi-obj* - (case-lambda - [(name lib type) (get-ffi-obj* name lib type #f)] - [(name lib type failure) - (let ([name (get-ffi-obj-name 'get-ffi-obj name)] - [lib (get-ffi-lib-internal lib)]) - (let-values ([(obj error?) - (with-handlers - ([exn:fail:filesystem? - (lambda (e) - (if failure (values (failure) #t) (raise e)))]) - (values (ffi-obj name lib) #f))]) - (if error? obj (ffi-get obj type))))])) -(define-syntax (get-ffi-obj stx) - (syntax-case stx () - [(_ name lib type) - #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name))] - [(_ name lib type failure) - #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name) - failure)] - [x (identifier? #'x) #'get-ffi-obj*])) - -;; It is important to use the set-ffi-obj! wrapper because it takes care of -;; keeping a handle on the object -- otherwise, setting a callback hook will -;; crash when the Scheme function is gone. -(provide* (unsafe set-ffi-obj!)) -(define (set-ffi-obj! name lib type new) - (ffi-set! (ffi-obj (get-ffi-obj-name 'set-ffi-obj! name) - (get-ffi-lib-internal lib)) - type new)) - -;; Combining the above two in a `define-c' special form which makes a Scheme -;; `binding', first a `parameter'-like constructor: -(provide* (unsafe make-c-parameter)) -(define (make-c-parameter name lib type) - (let ([obj (ffi-obj (get-ffi-obj-name 'make-c-parameter name) - (get-ffi-lib-internal lib))]) - (case-lambda [() (ffi-get obj type)] - [(new) (ffi-set! obj type new)]))) -;; Then the fake binding syntax, uses the defined identifier to name the -;; object: -(provide* (unsafe define-c)) -(define-syntax (define-c stx) - (syntax-case stx () - [(_ var-name lib-name type-expr) - (with-syntax ([(p) (generate-temporaries (list #'var-name))]) - (namespace-syntax-introduce - #'(begin (define p (make-c-parameter 'var-name lib-name type-expr)) - (define-syntax var-name - (syntax-id-rules (set!) - [(set! var val) (p val)] - [(var . xs) ((p) . xs)] - [var (p)])))))])) - -;; Used to convert strings and symbols to a byte-string that names an object -(define (get-ffi-obj-name who objname) - (cond [(bytes? objname) objname] - [(symbol? objname) (get-ffi-obj-name who (symbol->string objname))] - [(string? objname) (string->bytes/utf-8 objname)] - [else (raise-type-error who "object-name" objname)])) - -;; This table keeps references to values that are set in foreign libraries, to -;; avoid them being GCed. See set-ffi-obj! above. -(define ffi-objects-ref-table (make-hasheq)) - -;; ---------------------------------------------------------------------------- -;; Compile-time support for fun-expanders - -(begin-for-syntax - - ;; The `_fun' macro tears its input apart and reassemble it using pieces from - ;; custom function types (macros). This whole deal needs some work to make - ;; it play nicely with code certificates, so Matthew wrote the following - ;; code. The idea is to create a define-fun-syntax which makes the new - ;; syntax transformer be an object that carries extra information, later used - ;; by `expand-fun-syntax/fun'. - - (define fun-cert-key (gensym)) - - ;; bug in begin-for-syntax (PR7104), see below - (define foo!!! (make-parameter #f)) - (define (expand-fun-syntax/normal fun-stx stx) - ((foo!!!) fun-stx stx)) - - (define-values (make-fun-syntax fun-syntax? - fun-syntax-proc fun-syntax-certifier fun-syntax-name) - (let-values ([(desc make pred? get set!) - (make-struct-type - 'fun-syntax #f 3 0 #f '() (current-inspector) - expand-fun-syntax/normal)]) - (values make pred? - (make-struct-field-accessor get 0 'proc) - (make-struct-field-accessor get 1 'certifier) - (make-struct-field-accessor get 2 'name)))) - - ;; This is used to expand a fun-syntax in a _fun type context. - (define (expand-fun-syntax/fun stx) - (let loop ([stx stx]) - (define (do-expand id id?) ; id? == are we expanding an identifier? - (define v (syntax-local-value id (lambda () #f))) - (define set!-trans? (set!-transformer? v)) - (define proc (if set!-trans? (set!-transformer-procedure v) v)) - (if (and (fun-syntax? proc) (or (not id?) set!-trans?)) - ;; Do essentially the same thing that `local-expand' does. - ;; First, create an "introducer" to mark introduced identifiers: - (let* ([introduce (make-syntax-introducer)] - [expanded - ;; Re-introduce mark related to expansion of `_fun': - (syntax-local-introduce - ;; Re-add mark specific to this expansion, cancelling - ;; some marks applied before expanding (leaving only - ;; introuced syntax marked) - (introduce - ;; Actually expand: - ((fun-syntax-proc proc) - ;; Add mark specific to this expansion: - (introduce - ;; Remove mark related to expansion of `_fun': - (syntax-local-introduce stx)))))]) - ;; Certify based on definition of expander, then loop - ;; to continue expanding: - (loop ((fun-syntax-certifier proc) - expanded fun-cert-key introduce))) - stx)) - (syntax-case stx () - [(id . rest) (identifier? #'id) (do-expand #'id #f)] - [id (identifier? #'id) (do-expand #'id #t)] - [_else stx]))) - - ;; Use module-or-top-identifier=? because we use keywords like `=' and want - ;; to make it possible to play with it at the toplevel. - (define id=? module-or-top-identifier=?) - - (define (split-by key args) - (let loop ([args args] [r (list '())]) - (cond [(null? args) (reverse (map reverse r))] - [(eq? key (car args)) (loop (cdr args) (cons '() r))] - [else (loop (cdr args) - (cons (cons (car args) (car r)) (cdr r)))]))) - - (define (add-renamer body from to) - (with-syntax ([body body] [from from] [to to]) - #'(let-syntax ([to (syntax-id-rules () - [(_?_ . _rest_) (from . _rest_)] [_?_ from])]) - body))) - - (define (custom-type->keys type err) - (define stops (map (lambda (s) (datum->syntax type s #f)) - '(#%app #%top #%datum))) - ;; Expand `type' using expand-fun-syntax/fun - (define orig (expand-fun-syntax/fun type)) - (define (with-arg x) - (syntax-case* x (=>) id=? - [(id => body) (identifier? #'id) - ;; Extract #'body from its context, use a key it needs certification: - (list (syntax-recertify #'id orig #f fun-cert-key) - (syntax-recertify #'body orig #f fun-cert-key))] - [_else x])) - (define (cert-id id) - (syntax-recertify id orig #f fun-cert-key)) - (let ([keys '()]) - (define (setkey! key val . id?) - (cond - [(assq key keys) - (err "bad expansion of custom type (two `~a:'s)" key type)] - [(and (pair? id?) (car id?) (not (identifier? val))) - (err "bad expansion of custom type (`~a:' expects an identifier)" - key type)] - [else (set! keys (cons (cons key val) keys))])) - (let loop ([t orig]) - (define (next rest . args) (apply setkey! args) (loop rest)) - (syntax-case* t (type: expr: bind: 1st-arg: prev-arg: pre: post:) id=? - [(type: t x ...) (next #'(x ...) 'type #'t)] - [(expr: e x ...) (next #'(x ...) 'expr #'e)] - [(bind: id x ...) (next #'(x ...) 'bind (cert-id #'id) #t)] - [(1st-arg: id x ...) (next #'(x ...) '1st (cert-id #'id) #t)] - [(prev-arg: id x ...) (next #'(x ...) 'prev (cert-id #'id) #t)] - ;; in the following two cases pass along orig for recertifying - [(pre: p x ...) (next #'(x ...) 'pre (with-arg #'p))] - [(post: p x ...) (next #'(x ...) 'post (with-arg #'p))] - [() (and (pair? keys) keys)] - [_else #f])))) - - ;; This is used for a normal expansion of fun-syntax, when not in a _fun type - ;; context. - ;; bug in begin-for-syntax (PR7104), see above - ;; should be (define (expand-fun-syntax/normal fun-stx stx) ...) - (foo!!! (lambda (fun-stx stx) - (define (err msg . sub) - (apply raise-syntax-error (fun-syntax-name fun-stx) msg stx sub)) - (let ([keys (custom-type->keys stx err)]) - (define (getkey key) (cond [(assq key keys) => cdr] [else #f])) - (define (notkey key) - (when (getkey key) - (err (format "this type must be used in a _fun expression (uses ~s)" - key)))) - (if keys - (let ([type (getkey 'type)] [pre (getkey 'pre)] [post (getkey 'post)]) - (unless type - (err "this type must be used in a _fun expression (#f type)")) - (for-each notkey '(expr bind 1st prev)) - (if (or pre post) - ;; a type with pre/post blocks - (let ([make-> (lambda (x what) - (cond [(not x) #'#f] - [(and (list? x) (= 2 (length x)) - (identifier? (car x))) - #`(lambda (#,(car x)) #,(cadr x))] - [else #`(lambda (_) - (error '#,(fun-syntax-name fun-stx) - "cannot be used to ~a" - #,what))]))]) - (with-syntax ([type type] - [scheme->c (make-> pre "send values to C")] - [c->scheme (make-> post "get values from C")]) - #'(make-ctype type scheme->c c->scheme))) - ;; simple type - type)) - ;; no keys => normal expansion - ((fun-syntax-proc fun-stx) stx)))))) - -;; Use define-fun-syntax instead of define-syntax for forms that -;; are to be expanded by `_fun': -(provide define-fun-syntax) -(define-syntax define-fun-syntax - (syntax-rules () - [(_ id trans) - (define-syntax id - (let* ([xformer trans] - [set!-trans? (set!-transformer? xformer)]) - (unless (or (and (procedure? xformer) - (procedure-arity-includes? xformer 1)) - set!-trans?) - (raise-type-error 'define-fun-syntax - "procedure (arity 1) or set!-transformer" - xformer)) - (let ([f (make-fun-syntax (if set!-trans? - (set!-transformer-procedure xformer) - xformer) - ;; Capture definition-time certificates: - (syntax-local-certifier) - 'id)]) - (if set!-trans? (make-set!-transformer f) f))))])) - -;; ---------------------------------------------------------------------------- -;; Function type - -;; Creates a simple function type that can be used for callouts and callbacks, -;; optionally applying a wrapper function to modify the result primitive -;; (callouts) or the input procedure (callbacks). -(define* (_cprocedure itypes otype - #:abi [abi #f] - #:wrapper [wrapper #f] - #:keep [keep #f] - #:atomic? [atomic? #f]) - (_cprocedure* itypes otype abi wrapper keep atomic?)) - -;; for internal use -(define held-callbacks (make-weak-hasheq)) -(define (_cprocedure* itypes otype abi wrapper keep atomic?) - (define-syntax-rule (make-it wrap) - (make-ctype _fpointer - (lambda (x) - (and x - (let ([cb (ffi-callback (wrap x) itypes otype abi atomic?)]) - (cond [(eq? keep #t) (hash-set! held-callbacks x cb)] - [(box? keep) - (let ([x (unbox keep)]) - (set-box! keep - (if (or (null? x) (pair? x)) (cons cb x) cb)))] - [(procedure? keep) (keep cb)]) - cb))) - (lambda (x) (and x (wrap (ffi-call x itypes otype abi)))))) - (if wrapper (make-it wrapper) (make-it begin))) - -;; Syntax for the special _fun type: -;; (_fun [{(name ... [. name]) | name} [-> expr] ::] -;; {type | (name : type [= expr]) | ([name :] type = expr)} ... -;; -> {type | (name : type)} -;; [-> expr]) -;; Usage: -;; `{(name ...) | ...} ::' specify explicit wrapper function formal arguments -;; `-> expr' can be used instead of the last expr -;; `type' input type (implies input, but see type macros next) -;; `(name : type = expr)' specify name and type, `= expr' means computed input -;; `-> type' output type (possibly with name) -;; `-> expr' specify different output, can use previous names -;; Also, see below for custom function types. - -(provide ->) ; to signal better errors when trying to use this with contracts -(define-syntax -> - (syntax-id-rules () - [_ (raise-syntax-error '-> "should be used only in a _fun context")])) - -(provide _fun) -(define-syntax (_fun stx) - (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub)) - (define xs #f) - (define abi #f) - (define keep #f) - (define atomic? #f) - (define inputs #f) - (define output #f) - (define bind '()) - (define pre '()) - (define post '()) - (define input-names #f) - (define output-type #f) - (define output-expr #f) - (define 1st-arg #f) - (define prev-arg #f) - (define (bind! x) (set! bind (append bind (list x)))) - (define (pre! x) (set! pre (append pre (list x)))) - (define (post! x) (set! post (append post (list x)))) - (define ((t-n-e clause) type name expr) - (let ([keys (custom-type->keys type err)]) - (define (getkey key) (cond [(assq key keys) => cdr] [else #f])) - (define (arg x . no-expr?) - (define use-expr? - (and (list? x) (= 2 (length x)) (identifier? (car x)))) - ;; when the current expr is not used with a (x => ...) form, - ;; either check that no expression is given or just make it - ;; disappear from the inputs. - (unless use-expr? - (if (and (pair? no-expr?) (car no-expr?) expr) - (err "got an expression for a custom type that do not use it" - clause) - (set! expr (void)))) - (set! x (if use-expr? (add-renamer (cadr x) name (car x)) x)) - (cond [(getkey '1st) => - (lambda (v) - (if 1st-arg - (set! x (add-renamer x 1st-arg v)) - (err "got a custom type that wants 1st arg too early" - clause)))]) - (cond [(getkey 'prev) => - (lambda (v) - (if prev-arg - (set! x (add-renamer x prev-arg v)) - (err "got a custom type that wants prev arg too early" - clause)))]) - x) - (when keys - (set! type (getkey 'type)) - (cond [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))]) - (cond [(getkey 'bind) => (lambda (x) (bind! #`[#,x #,name]))]) - (cond [(getkey 'pre) => (lambda (x) (pre! #`[#,name #,(arg x #t)]))]) - (cond [(getkey 'post) => (lambda (x) (post! #`[#,name #,(arg x)]))])) - ;; turn a #f syntax to #f - (set! type (and type (syntax-case type () [#f #f] [_ type]))) - (when type ; remember these for later usages - (unless 1st-arg (set! 1st-arg name)) - (set! prev-arg name)) - (list type name expr))) - (define (do-fun) - ;; parse keywords - (let loop () - (let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))]) - (define-syntax-rule (kwds [key var] ...) - (case k - [(key) (if var - (err (format "got a second ~s keyword") 'key (car xs)) - (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))] - ... - [else (err "unknown keyword" (car xs))])) - (when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?])))) - (unless abi (set! abi #'#f)) - (unless keep (set! keep #'#t)) - (unless atomic? (set! atomic? #'#f)) - ;; parse known punctuation - (set! xs (map (lambda (x) - (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) - xs)) - ;; parse "::" - (let ([s (split-by ':: xs)]) - (case (length s) - [(0) (err "something bad happened (::)")] - [(1) (void)] - [(2) (if (and (= 1 (length (car s))) (not (eq? '-> (caar s)))) - (begin (set! xs (cadr s)) (set! input-names (caar s))) - (err "bad wrapper formals"))] - [else (err "saw two or more instances of `::'")])) - ;; parse "->" - (let ([s (split-by '-> xs)]) - (case (length s) - [(0) (err "something bad happened (->)")] - [(1) (err "missing output type")] - [(2 3) (set! inputs (car s)) - (case (length (cadr s)) - [(1) (set! output-type (caadr s))] - [(0) (err "missing output type after `->'")] - [else (err "extraneous output type" (cadadr s))]) - (unless (null? (cddr s)) - (case (length (caddr s)) - [(1) (set! output-expr (caaddr s))] - [(0) (err "missing output expression after `->'")] - [else (err "extraneous output expression" - (cadr (caddr s)))]))] - [else (err "saw three or more instances of `->'")])) - (set! inputs - (map (lambda (sub temp) - (let ([t-n-e (t-n-e sub)]) - (syntax-case* sub (: =) id=? - [(name : type) (t-n-e #'type #'name #f)] - [(type = expr) (t-n-e #'type temp #'expr)] - [(name : type = expr) (t-n-e #'type #'name #'expr)] - [type (t-n-e #'type temp #f)]))) - inputs - (generate-temporaries (map (lambda (x) 'tmp) inputs)))) - ;; when processing the output type, only the post code matters - (set! pre! (lambda (x) #f)) - (set! output - (let ([temp (car (generate-temporaries #'(ret)))] - [t-n-e (t-n-e output-type)]) - (syntax-case* output-type (: =) id=? - [(name : type) (t-n-e #'type #'name output-expr)] - [(type = expr) (if output-expr - (err "extraneous output expression" #'expr) - (t-n-e #'type temp #'expr))] - [(name : type = expr) - (if output-expr - (err "extraneous output expression" #'expr) - (t-n-e #'type #'name #'expr))] - [type (t-n-e #'type temp output-expr)]))) - (if (or (caddr output) input-names (ormap caddr inputs) - (ormap (lambda (x) (not (car x))) inputs) - (pair? bind) (pair? pre) (pair? post)) - (let* ([input-names (or input-names - (filter-map (lambda (i) - (and (not (caddr i)) (cadr i))) - inputs))] - [output-expr (let ([o (caddr output)]) - (or (and (not (void? o)) o) - (cadr output)))] - [args (filter-map (lambda (i) - (and (caddr i) - (not (void? (caddr i))) - #`[#,(cadr i) #,(caddr i)])) - inputs)] - [ffi-args (filter-map (lambda (x) (and (car x) (cadr x))) inputs)] - ;; the actual wrapper body - [body (quasisyntax/loc stx - (lambda #,input-names - (let* (#,@args - #,@bind - #,@pre - [#,(cadr output) (ffi #,@ffi-args)] - #,@post) - #,output-expr)))] - ;; if there is a string 'ffi-name property, use it as a name - [body (let ([n (cond [(syntax-property stx 'ffi-name) - => syntax->datum] - [else #f])]) - (if (string? n) - (syntax-property - body 'inferred-name - (string->symbol (string-append "ffi-wrapper:" n))) - body))]) - #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi (lambda (ffi) #,body) #,keep #,atomic?)) - #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) - #,abi #f #,keep #,atomic?))) - (syntax-case stx () - [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) - -(define (function-ptr p fun-ctype) - (if (or (cpointer? p) (procedure? p)) - (if (eq? (ctype->layout fun-ctype) 'fpointer) - (if (procedure? p) - ((ctype-scheme->c fun-ctype) p) - ((ctype-c->scheme fun-ctype) p)) - (raise-type-error 'function-ptr "function ctype" fun-ctype)) - (raise-type-error 'function-ptr "cpointer" p))) - -;; ---------------------------------------------------------------------------- -;; String types - -;; The internal _string type uses the native ucs-4 encoding, also providing a -;; utf-16 type -(provide _string/ucs-4 _string/utf-16) - -;; 8-bit string encodings, #f is NULL -(define ((false-or-op op) x) (and x (op x))) -(define* _string/utf-8 - (make-ctype _bytes - (false-or-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) -(define* _string/locale - (make-ctype _bytes - (false-or-op string->bytes/locale) (false-or-op bytes->string/locale))) -(define* _string/latin-1 - (make-ctype _bytes - (false-or-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) - -;; 8-bit string encodings, #f is NULL, can also use bytes and paths -(define ((any-string-op op) x) - (cond [(not x) x] - [(bytes? x) x] - [(path? x) (path->bytes x)] - [else (op x)])) -(define* _string*/utf-8 - (make-ctype _bytes - (any-string-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) -(define* _string*/locale - (make-ctype _bytes - (any-string-op string->bytes/locale) (false-or-op bytes->string/locale))) -(define* _string*/latin-1 - (make-ctype _bytes - (any-string-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) - -;; A generic _string type that usually does the right thing via a parameter -(define* default-_string-type - (make-parameter _string*/utf-8 - (lambda (x) - (if (ctype? x) - x (error 'default-_string-type "expecting a C type, got ~e" x))))) -;; The type looks like an identifier, but it's actually using the parameter -(provide _string) -(define-syntax _string - (syntax-id-rules () - [(_ . xs) ((default-_string-type) . xs)] - [_ (default-_string-type)])) - -;; _symbol is defined in C, since it uses simple C strings -(provide _symbol) - -(provide _path) -;; `file' type: path-expands a path string, provide _path too. -(define* _file (make-ctype _path cleanse-path #f)) - -;; `string/eof' type: converts an output #f (NULL) to an eof-object. -(define string-type->string/eof-type - (let ([table (make-hasheq)]) - (lambda (string-type) - (hash-ref table string-type - (lambda () - (let ([new-type (make-ctype string-type - (lambda (x) (and (not (eof-object? x)) x)) - (lambda (x) (or x eof)))]) - (hash-set! table string-type new-type) - new-type)))))) -(provide _string/eof _bytes/eof) -(define _bytes/eof - (make-ctype _bytes - (lambda (x) (and (not (eof-object? x)) x)) - (lambda (x) (or x eof)))) -(define-syntax _string/eof ; make it a syntax so it depends on the _string type - (syntax-id-rules () - [(_ . xs) ((string-type->string/eof-type _string) . xs)] - [_ (string-type->string/eof-type _string)])) - -;; ---------------------------------------------------------------------------- -;; Utility types - -;; Call this with a name (symbol) and a list of symbols, where a symbol can be -;; followed by a '= and an integer to have a similar effect of C's enum. -(define (_enum* name symbols . base?) - (define basetype (if (pair? base?) (car base?) _ufixint)) - (define sym->int '()) - (define int->sym '()) - (define s->c - (if name (string->symbol (format "enum:~a->int" name)) 'enum->int)) - (let loop ([i 0] [symbols symbols]) - (unless (null? symbols) - (let-values ([(i rest) - (if (and (pair? (cdr symbols)) - (eq? '= (cadr symbols)) - (pair? (cddr symbols))) - (values (caddr symbols) - (cdddr symbols)) - (values i - (cdr symbols)))]) - (set! sym->int (cons (cons (car symbols) i) sym->int)) - (set! int->sym (cons (cons i (car symbols)) int->sym)) - (loop (add1 i) rest)))) - (make-ctype basetype - (lambda (x) - (let ([a (assq x sym->int)]) - (if a - (cdr a) - (raise-type-error s->c (format "~a" (or name "enum")) x)))) - (lambda (x) (cond [(assq x int->sym) => cdr] [else #f])))) - -;; Macro wrapper -- no need for a name -(provide _enum) -(define-syntax (_enum stx) - (syntax-case stx () - [(_ syms) - (with-syntax ([name (syntax-local-name)]) - #'(_enum* 'name syms))] - [(_ syms basetype) - (with-syntax ([name (syntax-local-name)]) - #'(_enum* 'name syms basetype))] - [id (identifier? #'id) - #'(lambda (syms . base?) (apply _enum* #f syms base?))])) - -;; Call this with a name (symbol) and a list of (symbol int) or symbols like -;; the above with '= -- but the numbers have to be specified in some way. The -;; generated type will convert a list of these symbols into the logical-or of -;; their values and back. -(define (_bitmask* name orig-symbols->integers . base?) - (define basetype (if (pair? base?) (car base?) _uint)) - (define s->c - (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int)) - (define symbols->integers - (let loop ([s->i orig-symbols->integers]) - (cond - [(null? s->i) - null] - [(and (pair? (cdr s->i)) (eq? '= (cadr s->i)) (pair? (cddr s->i))) - (cons (list (car s->i) (caddr s->i)) - (loop (cdddr s->i)))] - [(and (pair? (car s->i)) (pair? (cdar s->i)) (null? (cddar s->i)) - (symbol? (caar s->i)) (integer? (cadar s->i))) - (cons (car s->i) (loop (cdr s->i)))] - [else - (error '_bitmask "bad spec in ~e" orig-symbols->integers)]))) - (make-ctype basetype - (lambda (symbols) - (if (null? symbols) ; probably common - 0 - (let loop ([xs (if (pair? symbols) symbols (list symbols))] [n 0]) - (cond [(null? xs) n] - [(assq (car xs) symbols->integers) => - (lambda (x) (loop (cdr xs) (bitwise-ior (cadr x) n)))] - [else (raise-type-error s->c (format "~a" (or name "bitmask")) - symbols)])))) - (lambda (n) - (if (zero? n) ; probably common - '() - (let loop ([s->i symbols->integers] [l '()]) - (if (null? s->i) - (reverse l) - (loop (cdr s->i) - (let ([i (cadar s->i)]) - (if (and (not (= i 0)) (= i (bitwise-and i n))) - (cons (caar s->i) l) - l))))))))) - -;; Macro wrapper -- no need for a name -(provide _bitmask) -(define-syntax (_bitmask stx) - (syntax-case stx () - [(_ syms) - (with-syntax ([name (syntax-local-name)]) - #'(_bitmask* 'name syms))] - [(_ syms basetype) - (with-syntax ([name (syntax-local-name)]) - #'(_bitmask* 'name syms basetype))] - [id (identifier? #'id) - #'(lambda (syms . base?) (apply _bitmask* #f syms base?))])) - -;; ---------------------------------------------------------------------------- -;; Custom function type macros - -;; These macros get expanded by the _fun type. They can expand to a form that -;; looks like (keyword: value ...), where the keyword is one of: -;; * `type:' for the type that will be used, -;; * `expr:' an expression that will always be used for these arguments, as -;; if `= expr' is always given, when an expression is actually -;; given in an argument specification, it supersedes this. -;; * `bind:' for an additional binding that holds the initial value, -;; * `1st-arg:' is used to name an identifier that will be bound to the value -;; of the 1st foreign argument in pre/post chunks (good for -;; common cases where the first argument has a special meaning, -;; eg, for method calls), -;; * `prev-arg:' similar to 1st-arg: but for the previous argument, -;; * `pre:' for a binding that will be inserted before the ffi call, -;; * `post:' for a binding after the ffi call. -;; The pre: and post: bindings can be of the form (id => expr) to use the -;; existing value. Note that if the pre: expression is not (id => expr), then -;; it means that there is no input for this argument. Also note that if a -;; custom type is used as an output type of a function, then only the post: -;; code is used -- for example, this is useful for foreign functions that -;; allocate a memory block and return it to the user. The resulting wrapper -;; looks like: -;; (let* (...bindings for arguments... -;; ...bindings for bind: identifiers... -;; ...bindings for pre-code... -;; (ret-name ffi-call) -;; ...bindings for post-code...) -;; return-expression) -;; -;; Finally, the code in a custom-function macro needs special treatment when it -;; comes to dealing with code certificates, so instead of using -;; `define-syntax', you should use `define-fun-syntax' (used in the same way). - -;; _? -;; This is not a normal ffi type -- it is a marker for expressions that should -;; not be sent to the ffi function. Use this to bind local values in a -;; computation that is part of an ffi wrapper interface. -(provide _?) -(define-fun-syntax _? - (syntax-id-rules () [(_ . xs) ((type: #f) . xs)] [_ (type: #f)])) - -;; (_ptr ) -;; This is for pointers, where mode indicates input or output pointers (or -;; both). If the mode is `o' (output), then the wrapper will not get an -;; argument for it, instead it generates the matching argument. -(provide _ptr) -(define-fun-syntax _ptr - (syntax-rules (i o io) - [(_ i t) (type: _pointer - pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p)))] - [(_ o t) (type: _pointer - pre: (malloc t) - post: (x => (ptr-ref x t)))] - [(_ io t) (type: _pointer - pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p)) - post: (x => (ptr-ref x t)))])) - -;; (_box ) -;; This is similar to a (_ptr io ) argument, where the input is expected -;; to be a box, which is unboxed on entry and modified on exit. -(provide _box) -(define-fun-syntax _box - (syntax-rules () - [(_ t) (type: _pointer - bind: tmp ; need to save the box so we can get back to it - pre: (x => (let ([p (malloc t)]) (ptr-set! p t (unbox x)) p)) - post: (x => (begin (set-box! tmp (ptr-ref x t)) tmp)))])) - -;; (_list []) -;; Similar to _ptr, except that it is used for converting lists to/from C -;; vectors. The length is needed for output values where it is used in the -;; post code, and in the pre code of an output mode to allocate the block. In -;; any case it can refer to a previous binding for the length of the list which -;; the C function will most likely require. -(provide _list) -(define-fun-syntax _list - (syntax-rules (i o io) - [(_ i t ) (type: _pointer - pre: (x => (list->cblock x t)))] - [(_ o t n) (type: _pointer - pre: (malloc n t) - post: (x => (cblock->list x t n)))] - [(_ io t n) (type: _pointer - pre: (x => (list->cblock x t)) - post: (x => (cblock->list x t n)))])) - -;; (_vector []) -;; Same as _list, except that it uses Scheme vectors. -(provide _vector) -(define-fun-syntax _vector - (syntax-rules (i o io) - [(_ i t ) (type: _pointer - pre: (x => (vector->cblock x t)))] - [(_ o t n) (type: _pointer - pre: (malloc n t) - post: (x => (cblock->vector x t n)))] - [(_ io t n) (type: _pointer - pre: (x => (vector->cblock x t)) - post: (x => (cblock->vector x t n)))])) - -;; _bytes or (_bytes o n) is for a memory block represented as a Scheme byte -;; string. _bytes is just like a byte-string, and (_bytes o n) is for -;; pre-malloc of the string. There is no need for other modes: i or io would -;; be just like _bytes since the string carries its size information (so there -;; is no real need for the `o', but it's there for consistency with the above -;; macros). -(provide (rename-out [_bytes* _bytes])) -(define-fun-syntax _bytes* - (syntax-id-rules (o) - [(_ o n) (type: _bytes - pre: (make-sized-byte-string (malloc n) n) - ;; post is needed when this is used as a function output type - post: (x => (make-sized-byte-string x n)))] - [(_ . xs) (_bytes . xs)] - [_ _bytes])) - -;; ---------------------------------------------------------------------------- -;; Safe raw vectors - -(define-struct cvector (ptr type length)) - -(provide* cvector? cvector-length cvector-type cvector-ptr - ;; make-cvector* is a dangerous operation - (unsafe (rename-out [make-cvector make-cvector*]))) - -(define _cvector* ; used only as input types - (make-ctype _pointer cvector-ptr - (lambda (x) - (error '_cvector - "cannot automatically convert a C pointer to a cvector")))) - -;; (_cvector [ ]) | _cevector -;; Same as _list etc above, except that it uses C vectors. -(provide _cvector) -(define-fun-syntax _cvector - (syntax-id-rules (i o io) - [(_ i ) _cvector*] - [(_ o t n) (type: _pointer ; needs to be a pointer, not a cvector* - pre: (malloc n t) - post: (x => (make-cvector x t n)))] - [(_ io ) (type: _cvector* - bind: tmp - pre: (x => (cvector-ptr x)) - post: (x => tmp))] - [(_ . xs) (_cvector* . xs)] - [_ _cvector*])) - -(provide (rename-out [allocate-cvector make-cvector])) -(define (allocate-cvector type len) - (make-cvector (if (zero? len) #f ; 0 => NULL - (malloc len type)) - type len)) - -(provide (rename-out [cvector-args cvector])) -(define (cvector-args type . args) - (list->cvector args type)) - -(define* (cvector-ref v i) - (if (and (exact-nonnegative-integer? i) (< i (cvector-length v))) - (ptr-ref (cvector-ptr v) (cvector-type v) i) - (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e" - i (sub1 (cvector-length v))))) - -(define* (cvector-set! v i x) - (if (and (exact-nonnegative-integer? i) (< i (cvector-length v))) - (ptr-set! (cvector-ptr v) (cvector-type v) i x) - (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e" - i (sub1 (cvector-length v))))) - -(define* (cvector->list v) - (cblock->list (cvector-ptr v) (cvector-type v) (cvector-length v))) - -(define* (list->cvector l type) - (make-cvector (list->cblock l type) type (length l))) - -;; ---------------------------------------------------------------------------- -;; SRFI-4 implementation - -(define-syntax (srfi-4-define/provide stx) - (syntax-case stx () - [(_ TAG type) - (identifier? #'TAG) - (let ([name (format "~avector" (syntax->datum #'TAG))]) - (define (id prefix suffix) - (let* ([name (if prefix (string-append prefix name) name)] - [name (if suffix (string-append name suffix) name)]) - (datum->syntax #'TAG (string->symbol name) #'TAG))) - (with-syntax ([TAG? (id "" "?")] - [TAG (id "" "")] - [s:TAG (id "s:" "")] - [make-TAG (id "make-" "")] - [TAG-ptr (id "" "-ptr")] - [TAG-length (id "" "-length")] - [allocate-TAG (id "allocate-" "")] - [TAG* (id "" "*")] - [list->TAG (id "list->" "")] - [TAG->list (id "" "->list")] - [TAG-ref (id "" "-ref")] - [TAG-set! (id "" "-set!")] - [_TAG (id "_" "")] - [_TAG* (id "_" "*")] - [TAGname name]) - #'(begin - (define-struct TAG (ptr length)) - (provide TAG? TAG-length (rename-out [TAG s:TAG])) - (provide (rename-out [allocate-TAG make-TAG])) - (define (allocate-TAG n . init) - (let* ([p (if (eq? n 0) #f (malloc n type))] - [v (make-TAG p n)]) - (when (and p (pair? init)) - (let ([init (car init)]) - (let loop ([i (sub1 n)]) - (unless (< i 0) - (ptr-set! p type i init) - (loop (sub1 i)))))) - v)) - (provide (rename-out [TAG* TAG])) - (define (TAG* . vals) - (list->TAG vals)) - (define* (TAG-ref v i) - (if (TAG? v) - (if (and (exact-nonnegative-integer? i) (< i (TAG-length v))) - (ptr-ref (TAG-ptr v) type i) - (error 'TAG-ref "bad index ~e for ~a bounds of 0..~e" - i 'TAG (sub1 (TAG-length v)))) - (raise-type-error 'TAG-ref TAGname v))) - (define* (TAG-set! v i x) - (if (TAG? v) - (if (and (exact-nonnegative-integer? i) (< i (TAG-length v))) - (ptr-set! (TAG-ptr v) type i x) - (error 'TAG-set! "bad index ~e for ~a bounds of 0..~e" - i 'TAG (sub1 (TAG-length v)))) - (raise-type-error 'TAG-set! TAGname v))) - (define* (TAG->list v) - (if (TAG? v) - (cblock->list (TAG-ptr v) type (TAG-length v)) - (raise-type-error 'TAG->list TAGname v))) - (define* (list->TAG l) - (make-TAG (list->cblock l type) (length l))) - ;; same as the _cvector implementation - (provide _TAG) - (define _TAG* - (make-ctype _pointer TAG-ptr - (lambda (x) - (error - '_TAG - "cannot automatically convert a C pointer to a ~a" - TAGname)))) - (define-fun-syntax _TAG - (syntax-id-rules (i o io) - [(_ i ) _TAG*] - [(_ o n) (type: _pointer - pre: (malloc n type) - post: (x => (make-TAG x n)))] - [(_ io ) (type: _cvector* - bind: tmp - pre: (x => (TAG-ptr x)) - post: (x => tmp))] - [(_ . xs) (_TAG* . xs)] - [_ _TAG*])))))] - [(_ TAG type) - (identifier? #'TAG)])) - -;; check that the types that were used above have the proper sizes -(unless (= 4 (ctype-sizeof _float)) - (error 'foreign "internal error: float has a bad size (~s)" - (ctype-sizeof _float))) -(unless (= 8 (ctype-sizeof _double*)) - (error 'foreign "internal error: double has a bad size (~s)" - (ctype-sizeof _double*))) - -(srfi-4-define/provide s8 _int8) -(srfi-4-define/provide s16 _int16) -(srfi-4-define/provide u16 _uint16) -(srfi-4-define/provide s32 _int32) -(srfi-4-define/provide u32 _uint32) -(srfi-4-define/provide s64 _int64) -(srfi-4-define/provide u64 _uint64) -(srfi-4-define/provide f32 _float) -(srfi-4-define/provide f64 _double*) - -;; simply rename bytes* to implement the u8vector type -(provide (rename-out [bytes? u8vector? ] - [bytes-length u8vector-length] - [make-bytes make-u8vector ] - [bytes u8vector ] - [bytes-ref u8vector-ref ] - [bytes-set! u8vector-set! ] - [bytes->list u8vector->list ] - [list->bytes list->u8vector ] - [_bytes _u8vector ])) -;; additional `u8vector' bindings for srfi-66 -(provide (rename-out [bytes-copy u8vector-copy] [bytes=? u8vector=?])) -(define* (u8vector-compare v1 v2) - (cond [(bytes? v1 v2) 1] - [else 0])) -(define* (u8vector-copy! src src-start dest dest-start n) - (bytes-copy! dest dest-start src src-start (+ src-start n))) - -;; ---------------------------------------------------------------------------- -;; Tagged pointers - -;; Make these operations available for unsafe interfaces (they can be used to -;; grab a hidden tag value and break code). -(provide* (unsafe cpointer-tag) (unsafe set-cpointer-tag!) - (unsafe cpointer-has-tag?) (unsafe cpointer-push-tag!)) - -;; Defined as syntax for efficiency, but can be used as procedures too. -(define-syntax (cpointer-has-tag? stx) - (syntax-case stx () - [(_ cptr tag) - #'(let ([ptag (cpointer-tag cptr)]) - (if (pair? ptag) (memq tag ptag) (eq? tag ptag)))] - [id (identifier? #'id) - #'(lambda (cptr tag) (cpointer-has-tag? cptr tag))])) -(define-syntax (cpointer-push-tag! stx) - (syntax-case stx () - [(_ cptr tag) - #'(let ([ptag (cpointer-tag cptr)]) - (set-cpointer-tag! cptr - (cond [(not ptag) tag] - [(pair? ptag) (cons tag ptag)] - [else (list tag ptag)])))] - [id (identifier? #'id) - #'(lambda (cptr tag) (cpointer-push-tag! cptr tag))])) - -(define (cpointer-maker nullable?) - (case-lambda - [(tag) ((cpointer-maker nullable?) tag #f #f #f)] - [(tag ptr-type) ((cpointer-maker nullable?) tag ptr-type #f #f)] - [(tag ptr-type scheme->c c->scheme) - (let* ([tag->C (string->symbol (format "~a->C" tag))] - [error-str (format "~a`~a' pointer" - (if nullable? "" "non-null ") tag)] - [error* (lambda (p) (raise-type-error tag->C error-str p))]) - (define-syntax-rule (tag-or-error ptr t) - (let ([p ptr]) - (if (cpointer? p) - (if (cpointer-has-tag? p t) p (error* p)) - (error* p)))) - (define-syntax-rule (tag-or-error/null ptr t) - (let ([p ptr]) - (if (cpointer? p) - (and p (if (cpointer-has-tag? p t) p (error* p))) - (error* p)))) - (make-ctype (or ptr-type _pointer) - ;; bad hack: `if's outside the lambda for efficiency - (if nullable? - (if scheme->c - (lambda (p) (tag-or-error/null (scheme->c p) tag)) - (lambda (p) (tag-or-error/null p tag))) - (if scheme->c - (lambda (p) (tag-or-error (scheme->c p) tag)) - (lambda (p) (tag-or-error p tag)))) - (if nullable? - (if c->scheme - (lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p)) - (lambda (p) (when p (cpointer-push-tag! p tag)) p)) - (if c->scheme - (lambda (p) - (if p (cpointer-push-tag! p tag) (error* p)) - (c->scheme p)) - (lambda (p) - (if p (cpointer-push-tag! p tag) (error* p)) - p)))))])) - -;; This is a kind of a pointer that gets a specific tag when converted to -;; Scheme, and accepts only such tagged pointers when going to C. An optional -;; `ptr-type' can be given to be used as the base pointer type, instead of -;; _pointer, `scheme->c' and `c->scheme' can be used for adding conversion -;; hooks. -(define* _cpointer (cpointer-maker #f)) - -;; Similar to the above, but can tolerate null pointers (#f). -(define* _cpointer/null (cpointer-maker #t)) - -;; A macro version of the above two functions, using the defined name for a tag -;; string, and defining a predicate too. The name should look like `_foo', the -;; predicate will be `foo?', and the tag will be "foo". In addition, `foo-tag' -;; is bound to the tag. The optional `ptr-type', `scheme->c', and `c->scheme' -;; arguments are the same as those of `_cpointer'. `_foo' will be bound to the -;; _cpointer type, and `_foo/null' to the _cpointer/null type. -(provide define-cpointer-type) -(define-syntax (define-cpointer-type stx) - (syntax-case stx () - [(_ _TYPE) #'(define-cpointer-type _TYPE #f #f #f)] - [(_ _TYPE ptr-type) #'(define-cpointer-type _TYPE ptr-type #f #f)] - [(_ _TYPE ptr-type scheme->c c->scheme) - (and (identifier? #'_TYPE) - (regexp-match #rx"^_.+" (symbol->string (syntax-e #'_TYPE)))) - (let ([name (cadr (regexp-match #rx"^_(.+)$" - (symbol->string (syntax-e #'_TYPE))))]) - (define (id . strings) - (datum->syntax - #'_TYPE (string->symbol (apply string-append strings)) #'_TYPE)) - (with-syntax ([name-string name] - [TYPE? (id name "?")] - [TYPE-tag (id name "-tag")] - [_TYPE/null (id "_" name "/null")]) - #'(define-values (_TYPE _TYPE/null TYPE? TYPE-tag) - (let ([TYPE-tag name-string]) - (values (_cpointer TYPE-tag ptr-type scheme->c c->scheme) - (_cpointer/null TYPE-tag ptr-type scheme->c c->scheme) - (lambda (x) - (and (cpointer? x) (cpointer-has-tag? x TYPE-tag))) - TYPE-tag)))))])) - -;; ---------------------------------------------------------------------------- -;; Struct wrappers - -(define (compute-offsets types) - (let loop ([ts types] [cur 0] [r '()]) - (if (null? ts) - (reverse r) - (let* ([algn (ctype-alignof (car ts))] - [pos (+ cur (modulo (- (modulo cur algn)) algn))]) - (loop (cdr ts) - (+ pos (ctype-sizeof (car ts))) - (cons pos r)))))) - -;; Simple structs: call this with a list of types, and get a type that marshals -;; C structs to/from Scheme lists. -(define* (_list-struct . types) - (let ([stype (make-cstruct-type types)] - [offsets (compute-offsets types)] - [len (length types)]) - (make-ctype stype - (lambda (vals) - (unless (and (list vals) (= len (length vals))) - (raise-type-error 'list-struct (format "list of ~a items" len) vals)) - (let ([block (malloc stype)]) - (for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val)) - types offsets vals) - block)) - (lambda (block) - (map (lambda (type ofs) (ptr-ref block type 'abs ofs)) - types offsets))))) - -;; (define-cstruct _foo ([slot type] ...)) -;; or -;; (define-cstruct (_foo _super) ([slot type] ...)) -;; defines a type called _foo for a C struct, with user-procedues: make-foo, -;; foo? foo-slot... and set-foo-slot!.... The `_' prefix is required. Objects -;; of this new type are actually cpointers, with a type tag that is "foo" and -;; (possibly more if the first type is itself a cstruct type or if a super type -;; is given,) provided as foo-tag, and tags of pointers are checked before -;; attempting to use them (see define-cpointer-type above). Note that since -;; structs are implemented as pointers, they can be used for a _pointer input -;; to a foreign function: their address will be used, to make this possible, -;; the corresponding cpointer type is defined as _foo-pointer. If a super -;; cstruct type is given, the constructor function expects values for every -;; field of the super type as well as other fields that are specified, and a -;; slot named `super' can be used to extract this initial struct -- although -;; pointers to the new struct type can be used as pointers to the super struct -;; type. -(provide define-cstruct) -(define-syntax (define-cstruct stx) - (define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx) - (define name - (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx))))) - (define slot-names (map (lambda (x) (symbol->string (syntax-e x))) - (syntax->list slot-names-stx))) - (define 1st-type - (let ([xs (syntax->list slot-types-stx)]) (and (pair? xs) (car xs)))) - (define (id . strings) - (datum->syntax - _TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx)) - (define (ids name-func) - (map (lambda (s) - (datum->syntax - _TYPE-stx - (string->symbol (apply string-append (name-func s))) - _TYPE-stx)) - slot-names)) - (define (safe-id=? x y) - (and (identifier? x) (identifier? y) (free-identifier=? x y))) - (with-syntax - ([has-super? has-super?] - [name-string name] - [struct-string (format "struct:~a" name)] - [(slot ...) slot-names-stx] - [(slot-type ...) slot-types-stx] - [_TYPE _TYPE-stx] - [_TYPE-pointer (id "_"name"-pointer")] - [_TYPE-pointer/null (id "_"name"-pointer/null")] - [_TYPE/null (id "_"name"/null")] - [_TYPE* (id "_"name"*")] - [TYPE? (id name"?")] - [make-TYPE (id "make-"name)] - [list->TYPE (id "list->"name)] - [list*->TYPE (id "list*->"name)] - [TYPE->list (id name"->list")] - [TYPE->list* (id name"->list*")] - [TYPE-tag (id name"-tag")] - [(stype ...) (ids (lambda (s) `(,name"-",s"-type")))] - [(TYPE-SLOT ...) (ids (lambda (s) `(,name"-",s)))] - [(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))] - [(offset ...) (generate-temporaries - (ids (lambda (s) `(,s"-offset"))))]) - (with-syntax ([get-super-info - ;; the 1st-type might be a pointer to this type - (if (or (safe-id=? 1st-type #'_TYPE-pointer/null) - (safe-id=? 1st-type #'_TYPE-pointer)) - #'(values #f '() #f #f #f #f) - #`(cstruct-info #,1st-type - (lambda () (values #f '() #f #f #f #f))))]) - #'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag - make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... - list->TYPE list*->TYPE TYPE->list TYPE->list*) - (let-values ([(super-pointer super-tags super-types super-offsets - super->list* list*->super) - get-super-info]) - (define-cpointer-type _TYPE super-pointer) - ;; these makes it possible to use recursive pointer definitions - (define _TYPE-pointer _TYPE) - (define _TYPE-pointer/null _TYPE/null) - (let*-values ([(stype ...) (values slot-type ...)] - [(types) (list stype ...)] - [(offsets) (compute-offsets types)] - [(offset ...) (apply values offsets)]) - (define all-tags (cons TYPE-tag super-tags)) - (define _TYPE* - ;; c->scheme adjusts all tags - (let* ([cst (make-cstruct-type types)] - [t (_cpointer TYPE-tag cst)] - [c->s (ctype-c->scheme t)]) - (make-ctype cst (ctype-scheme->c t) - ;; hack: modify & reuse the procedure made by _cpointer - (lambda (p) - (if p (set-cpointer-tag! p all-tags) (c->s p)) - p)))) - (define-values (all-types all-offsets) - (if (and has-super? super-types super-offsets) - (values (append super-types (cdr types)) - (append super-offsets (cdr offsets))) - (values types offsets))) - (define (TYPE-SLOT x) - (unless (TYPE? x) - (raise-type-error 'TYPE-SLOT struct-string x)) - (ptr-ref x stype 'abs offset)) - ... - (define (set-TYPE-SLOT! x slot) - (unless (TYPE? x) - (raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot)) - (ptr-set! x stype 'abs offset slot)) - ... - (define make-TYPE - (if (and has-super? super-types super-offsets) - ;; init using all slots - (lambda vals - (if (= (length vals) (length all-types)) - (let ([block (malloc _TYPE*)]) - (set-cpointer-tag! block all-tags) - (for-each (lambda (type ofs value) - (ptr-set! block type 'abs ofs value)) - all-types all-offsets vals) - block) - (error '_TYPE "expecting ~s values, got ~s: ~e" - (length all-types) (length vals) vals))) - ;; normal initializer - (lambda (slot ...) - (let ([block (malloc _TYPE*)]) - (set-cpointer-tag! block all-tags) - (ptr-set! block stype 'abs offset slot) - ... - block)))) - (define (list->TYPE vals) (apply make-TYPE vals)) - (define (list*->TYPE vals) - (cond - [(TYPE? vals) vals] - [(= (length vals) (length all-types)) - (let ([block (malloc _TYPE*)]) - (set-cpointer-tag! block all-tags) - (for-each - (lambda (type ofs value) - (let-values - ([(ptr tags types offsets T->list* list*->T) - (cstruct-info - type - (lambda () (values #f '() #f #f #f #f)))]) - (ptr-set! block type 'abs ofs - (if list*->T (list*->T value) value)))) - all-types all-offsets vals) - block)] - [else (error '_TYPE "expecting ~s values, got ~s: ~e" - (length all-types) (length vals) vals)])) - (define (TYPE->list x) - (unless (TYPE? x) - (raise-type-error 'TYPE-list struct-string x)) - (map (lambda (type ofs) (ptr-ref x type 'abs ofs)) - all-types all-offsets)) - (define (TYPE->list* x) - (unless (TYPE? x) - (raise-type-error 'TYPE-list struct-string x)) - (map (lambda (type ofs) - (let-values - ([(v) (ptr-ref x type 'abs ofs)] - [(ptr tags types offsets T->list* list*->T) - (cstruct-info - type - (lambda () (values #f '() #f #f #f #f)))]) - (if T->list* (T->list* v) v))) - all-types all-offsets)) - (cstruct-info - _TYPE* 'set! - _TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE) - (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag - make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... - list->TYPE list*->TYPE TYPE->list TYPE->list*))))))) - (define (identifiers? stx) - (andmap identifier? (syntax->list stx))) - (define (_-identifier? id stx) - (and (identifier? id) - (or (regexp-match #rx"^_." (symbol->string (syntax-e id))) - (raise-syntax-error #f "cstruct name must begin with a `_'" - stx id)))) - (syntax-case stx () - [(_ _TYPE ([slot slot-type] ...)) - (and (_-identifier? #'_TYPE stx) - (identifiers? #'(slot ...))) - (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))] - [(_ (_TYPE _SUPER) ([slot slot-type] ...)) - (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...))) - (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)]) - (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))])) - -;; helper for the above: keep runtime information on structs -(define cstruct-info - (let ([table (make-weak-hasheq)]) - (lambda (cstruct msg/fail-thunk . args) - (cond [(eq? 'set! msg/fail-thunk) - (hash-set! table cstruct (make-ephemeron cstruct args))] - [(and cstruct ; might get a #f if there were no slots - (hash-ref table cstruct (lambda () #f))) - => (lambda (xs) - (let ([v (ephemeron-value xs)]) - (if v (apply values v) (msg/fail-thunk))))] - [else (msg/fail-thunk)])))) - -;; ---------------------------------------------------------------------------- -;; - -(define prim-synonyms - #hasheq((double* . double) - (fixint . long) - (ufixint . ulong) - (fixnum . long) - (ufixnum . ulong) - (path . bytes) - (symbol . bytes) - (scheme . pointer))) - -(define (ctype->layout c) - (let ([b (ctype-basetype c)]) - (cond - [(ctype? b) (ctype->layout b)] - [(list? b) (map ctype->layout b)] - [else (hash-ref prim-synonyms b b)]))) - -;; ---------------------------------------------------------------------------- -;; Misc utilities - -;; Used by set-ffi-obj! to get the actual value so it can be kept around -(define (get-lowlevel-object x type) - (let ([basetype (ctype-basetype type)]) - (if (ctype? basetype) - (let ([s->c (ctype-scheme->c type)]) - (get-lowlevel-object (if s->c (s->c x) x) basetype)) - (values x type)))) - -;; Converting Scheme lists to/from C vectors (going back requires a length) -(define* (list->cblock l type) - (if (null? l) - #f ; null => NULL - (let ([cblock (malloc (length l) type)]) - (let loop ([l l] [i 0]) - (unless (null? l) - (ptr-set! cblock type i (car l)) - (loop (cdr l) (add1 i)))) - cblock))) -(provide* (unsafe cblock->list)) -(define (cblock->list cblock type len) - (cond [(zero? len) '()] - [(cpointer? cblock) - (let loop ([i (sub1 len)] [r '()]) - (if (< i 0) - r - (loop (sub1 i) (cons (ptr-ref cblock type i) r))))] - [else (error 'cblock->list - "expecting a non-void pointer, got ~s" cblock)])) - -;; Converting Scheme vectors to/from C vectors -(define* (vector->cblock v type) - (let ([len (vector-length v)]) - (if (zero? len) - #f ; #() => NULL - (let ([cblock (malloc len type)]) - (let loop ([i 0]) - (when (< i len) - (ptr-set! cblock type i (vector-ref v i)) - (loop (add1 i)))) - cblock)))) -(provide* (unsafe cblock->vector)) -(define (cblock->vector cblock type len) - (cond [(zero? len) '#()] - [(cpointer? cblock) - (let ([v (make-vector len)]) - (let loop ([i (sub1 len)]) - (unless (< i 0) - (vector-set! v i (ptr-ref cblock type i)) - (loop (sub1 i)))) - v)] - [else (error 'cblock->vector - "expecting a non-void pointer, got ~s" cblock)])) - -;; Useful for automatic definitions -;; If a provided regexp begins with a "^" or ends with a "$", then -;; `regexp-replace' is used, otherwise use `regexp-replace*'. -(define* (regexp-replaces x rs) - (let loop ([str (if (bytes? x) (bytes->string/utf-8 x) (format "~a" x))] - [rs rs]) - (if (null? rs) - str - (loop ((if (regexp-match #rx"^\\^|\\$$" - (if (regexp? (caar rs)) - (object-name (caar rs)) (caar rs))) - regexp-replace regexp-replace*) - (caar rs) str (cadar rs)) (cdr rs))))) - -;; A facility for running finalizers using executors. #%foreign has a C-based -;; version that uses finalizers, but that leads to calling Scheme from the GC -;; which is not a good idea. -(define killer-executor (make-will-executor)) -(define killer-thread #f) - -(define* (register-finalizer obj finalizer) - (unless killer-thread - (set! killer-thread - (thread (lambda () - (let loop () (will-execute killer-executor) (loop)))))) - (will-register killer-executor obj finalizer)) - -(define-unsafer unsafe!) +(module foreign scheme/base + (require scheme/foreign) + (provide (all-from-out scheme/foreign))) diff --git a/collects/scheme/foreign.ss b/collects/scheme/foreign.ss index 1a2b729546..5ca2e2446e 100644 --- a/collects/scheme/foreign.ss +++ b/collects/scheme/foreign.ss @@ -1,4 +1,1620 @@ +#lang scheme/base -(module foreign scheme/base - (require mzlib/foreign) - (provide (all-from-out mzlib/foreign))) +;; Foreign Scheme interface +(require '#%foreign setup/dirs + (for-syntax scheme/base scheme/list syntax/stx)) + +;; This module is full of unsafe bindings that are not provided to requiring +;; modules. Instead, an `unsafe!' binding is provided that makes these unsafe +;; bindings available. The following two syntaxes do that: `provide*' is like +;; `provide', but using `(unsafe id)' registers an unsafe binding. Then, +;; `define-unsafer' should be used with a binding that will expose the unsafe +;; bindings. This might move elsewhere at some point if it turns out to be +;; useful in other contexts. +(provide provide* define-unsafer) +(define-syntaxes (provide* define-unsafer) + (let ((unsafe-bindings '())) + (values + (lambda (stx) + (syntax-case stx () + [(_ p ...) + (let loop ([provides '()] + [unsafes '()] + [ps (syntax->list #'(p ...))]) + (if (null? ps) + (begin (set! unsafe-bindings + (append unsafe-bindings (reverse unsafes))) + (with-syntax ([(p ...) provides]) #'(provide p ...))) + (syntax-case (car ps) (unsafe) + [(unsafe u) + (syntax-case #'u (rename-out) + [(rename-out [from to]) + (loop provides (cons (cons #'from #'to) unsafes) (cdr ps))] + [id (identifier? #'id) + (loop provides (cons (cons #'id #'id) unsafes) (cdr ps))] + [_ + (raise-syntax-error 'provide* "bad unsafe usage" + (car ps) stx)])] + [_ (loop (cons (car ps) provides) unsafes (cdr ps))])))])) + (lambda (stx) + (syntax-case stx () + [(_ unsafe) + (with-syntax ([(from ...) (map car unsafe-bindings)] + [(to ...) (map cdr unsafe-bindings)] + [(id ...) (generate-temporaries unsafe-bindings)]) + (set! unsafe-bindings '()) + #'(begin + (provide (protect-out unsafe)) + (define-syntax (unsafe stx) + (syntax-case stx () + [(_) (with-syntax ([(id ...) (list (datum->syntax + stx 'to stx) + ...)]) + #'(begin (define-syntax id + (make-rename-transformer #'from)) + ...))]))))]))))) + +(provide* ctype-sizeof ctype-alignof compiler-sizeof + (unsafe malloc) (unsafe free) (unsafe end-stubborn-change) + cpointer? ptr-equal? ptr-add (unsafe ptr-ref) (unsafe ptr-set!) + ptr-offset ptr-add! offset-ptr? set-ptr-offset! + ctype? make-ctype make-cstruct-type (unsafe make-sized-byte-string) ctype->layout + _void _int8 _uint8 _int16 _uint16 _int32 _uint32 _int64 _uint64 + _fixint _ufixint _fixnum _ufixnum + _float _double _double* + _bool _pointer _scheme _fpointer function-ptr + (unsafe memcpy) (unsafe memmove) (unsafe memset) + (unsafe malloc-immobile-cell) (unsafe free-immobile-cell)) + +(define-syntax define* + (syntax-rules () + [(_ (name . args) body ...) + (begin (provide name) (define (name . args) body ...))] + [(_ name expr) + (begin (provide name) (define name expr))])) + +;; ---------------------------------------------------------------------------- +;; C integer types + +(define* _sint8 _int8) +(define* _sint16 _int16) +(define* _sint32 _int32) +(define* _sint64 _int64) + +;; _byte etc is a convenient name for _uint8 & _sint8 +;; (_byte is unsigned) +(define* _byte _uint8) +(define* _ubyte _uint8) +(define* _sbyte _int8) + +;; _word etc is a convenient name for _uint16 & _sint16 +;; (_word is unsigned) +(define* _word _uint16) +(define* _uword _uint16) +(define* _sword _int16) + +;; _short etc is a convenient name for whatever is the compiler's `short' +;; (_short is signed) +(provide _short _ushort _sshort) +(define-values (_short _ushort _sshort) + (case (compiler-sizeof 'short) + [(2) (values _int16 _uint16 _int16)] + [(4) (values _int32 _uint32 _int32)] + [else (error 'foreign "internal error: bad compiler size for `short'")])) + +;; _int etc is a convenient name for whatever is the compiler's `int' +;; (_int is signed) +(provide _int _uint _sint) +(define-values (_int _uint _sint) + (case (compiler-sizeof 'int) + [(2) (values _int16 _uint16 _int16)] + [(4) (values _int32 _uint32 _int32)] + [(8) (values _int64 _uint64 _int64)] + [else (error 'foreign "internal error: bad compiler size for `int'")])) + +;; _long etc is a convenient name for whatever is the compiler's `long' +;; (_long is signed) +(provide _long _ulong _slong) +(define-values (_long _ulong _slong) + (case (compiler-sizeof 'long) + [(4) (values _int32 _uint32 _int32)] + [(8) (values _int64 _uint64 _int64)] + [else (error 'foreign "internal error: bad compiler size for `long'")])) + +;; _llong etc is a convenient name for whatever is the compiler's `long long' +;; (_llong is signed) +(provide _llong _ullong _sllong) +(define-values (_llong _ullong _sllong) + (case (compiler-sizeof '(long long)) + [(4) (values _int32 _uint32 _int32)] + [(8) (values _int64 _uint64 _int64)] + [else (error 'foreign "internal error: bad compiler size for `llong'")])) + +;; ---------------------------------------------------------------------------- +;; Getting and setting library objects + +(define lib-suffix (bytes->string/latin-1 (subbytes (system-type 'so-suffix) 1))) +(define lib-suffix-re (regexp (string-append "\\." lib-suffix "$"))) +(define suffix-before-version? (not (equal? lib-suffix "dylib"))) + +(provide* (unsafe (rename-out [get-ffi-lib ffi-lib])) + ffi-lib? ffi-lib-name) +(define get-ffi-lib + (case-lambda + [(name) (get-ffi-lib name "")] + [(name version/s) + (cond + [(not name) (ffi-lib name)] ; #f => NULL => open this executable + [(not (or (string? name) (path? name))) + (raise-type-error 'ffi-lib "library-name" name)] + [else + ;; A possible way that this might be misleading: say that there is a + ;; "foo.so" file in the current directory, which refers to some + ;; undefined symbol, trying to use this function with "foo.so" will try + ;; a dlopen with "foo.so" which isn't found, then it tries a dlopen with + ;; "//foo.so" which fails because of the undefined symbol, and + ;; since all fails, it will use (ffi-lib "foo.so") to raise the original + ;; file-not-found error. This is because the dlopen doesn't provide a + ;; way to distinguish different errors (only dlerror, but that's + ;; unreliable). + (let* ([versions (if (list? version/s) version/s (list version/s))] + [versions (map (lambda (v) + (if (or (not v) (zero? (string-length v))) + "" (string-append "." v))) + versions)] + [fullpath (lambda (p) (path->complete-path (cleanse-path p)))] + [absolute? (absolute-path? name)] + [name0 (path->string (cleanse-path name))] ; orig name + [names (map (if (regexp-match lib-suffix-re name0) ; name+suffix + (lambda (v) (string-append name0 v)) + (lambda (v) + (if suffix-before-version? + (string-append name0 "." lib-suffix v) + (string-append name0 v "." lib-suffix)))) + versions)] + [ffi-lib* (lambda (name) (ffi-lib name #t))]) + (or ;; try to look in our library paths first + (and (not absolute?) + (ormap (lambda (dir) + ;; try good names first, then original + (or (ormap (lambda (name) + (ffi-lib* (build-path dir name))) + names) + (ffi-lib* (build-path dir name0)))) + (get-lib-search-dirs))) + ;; try a system search + (ormap ffi-lib* names) ; try good names first + (ffi-lib* name0) ; try original + (ormap (lambda (name) ; try relative paths + (and (file-exists? name) (ffi-lib* (fullpath name)))) + names) + (and (file-exists? name0) ; relative with original + (ffi-lib* (fullpath name0))) + ;; give up: call ffi-lib so it will raise an error + (ffi-lib (car names))))])])) + +(define (get-ffi-lib-internal x) + (if (ffi-lib? x) x (get-ffi-lib x))) + +;; These internal functions provide the functionality to be used by +;; get-ffi-obj, set-ffi-obj! and define-c below +(define (ffi-get ffi-obj type) + (ptr-ref ffi-obj type)) +(define (ffi-set! ffi-obj type new) + (let-values ([(new type) (get-lowlevel-object new type)]) + (hash-set! ffi-objects-ref-table ffi-obj new) + (ptr-set! ffi-obj type new))) + +;; This is better handled with `make-c-parameter' +(provide* (unsafe ffi-obj-ref)) +(define ffi-obj-ref + (case-lambda + [(name lib) (ffi-obj-ref name lib #f)] + [(name lib failure) + (let ([name (get-ffi-obj-name 'ffi-obj-ref name)] + [lib (get-ffi-lib-internal lib)]) + (with-handlers ([exn:fail:filesystem? + (lambda (e) (if failure (failure) (raise e)))]) + (ffi-obj name lib)))])) + +;; get-ffi-obj is implemented as a syntax only to be able to propagate the +;; foreign name into the type syntax, which allows generated wrappers to have a +;; proper name. +(provide* (unsafe get-ffi-obj)) +(define get-ffi-obj* + (case-lambda + [(name lib type) (get-ffi-obj* name lib type #f)] + [(name lib type failure) + (let ([name (get-ffi-obj-name 'get-ffi-obj name)] + [lib (get-ffi-lib-internal lib)]) + (let-values ([(obj error?) + (with-handlers + ([exn:fail:filesystem? + (lambda (e) + (if failure (values (failure) #t) (raise e)))]) + (values (ffi-obj name lib) #f))]) + (if error? obj (ffi-get obj type))))])) +(define-syntax (get-ffi-obj stx) + (syntax-case stx () + [(_ name lib type) + #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name))] + [(_ name lib type failure) + #`(get-ffi-obj* name lib #,(syntax-property #`type 'ffi-name #'name) + failure)] + [x (identifier? #'x) #'get-ffi-obj*])) + +;; It is important to use the set-ffi-obj! wrapper because it takes care of +;; keeping a handle on the object -- otherwise, setting a callback hook will +;; crash when the Scheme function is gone. +(provide* (unsafe set-ffi-obj!)) +(define (set-ffi-obj! name lib type new) + (ffi-set! (ffi-obj (get-ffi-obj-name 'set-ffi-obj! name) + (get-ffi-lib-internal lib)) + type new)) + +;; Combining the above two in a `define-c' special form which makes a Scheme +;; `binding', first a `parameter'-like constructor: +(provide* (unsafe make-c-parameter)) +(define (make-c-parameter name lib type) + (let ([obj (ffi-obj (get-ffi-obj-name 'make-c-parameter name) + (get-ffi-lib-internal lib))]) + (case-lambda [() (ffi-get obj type)] + [(new) (ffi-set! obj type new)]))) +;; Then the fake binding syntax, uses the defined identifier to name the +;; object: +(provide* (unsafe define-c)) +(define-syntax (define-c stx) + (syntax-case stx () + [(_ var-name lib-name type-expr) + (with-syntax ([(p) (generate-temporaries (list #'var-name))]) + (namespace-syntax-introduce + #'(begin (define p (make-c-parameter 'var-name lib-name type-expr)) + (define-syntax var-name + (syntax-id-rules (set!) + [(set! var val) (p val)] + [(var . xs) ((p) . xs)] + [var (p)])))))])) + +;; Used to convert strings and symbols to a byte-string that names an object +(define (get-ffi-obj-name who objname) + (cond [(bytes? objname) objname] + [(symbol? objname) (get-ffi-obj-name who (symbol->string objname))] + [(string? objname) (string->bytes/utf-8 objname)] + [else (raise-type-error who "object-name" objname)])) + +;; This table keeps references to values that are set in foreign libraries, to +;; avoid them being GCed. See set-ffi-obj! above. +(define ffi-objects-ref-table (make-hasheq)) + +;; ---------------------------------------------------------------------------- +;; Compile-time support for fun-expanders + +(begin-for-syntax + + ;; The `_fun' macro tears its input apart and reassemble it using pieces from + ;; custom function types (macros). This whole deal needs some work to make + ;; it play nicely with code certificates, so Matthew wrote the following + ;; code. The idea is to create a define-fun-syntax which makes the new + ;; syntax transformer be an object that carries extra information, later used + ;; by `expand-fun-syntax/fun'. + + (define fun-cert-key (gensym)) + + ;; bug in begin-for-syntax (PR7104), see below + (define foo!!! (make-parameter #f)) + (define (expand-fun-syntax/normal fun-stx stx) + ((foo!!!) fun-stx stx)) + + (define-values (make-fun-syntax fun-syntax? + fun-syntax-proc fun-syntax-certifier fun-syntax-name) + (let-values ([(desc make pred? get set!) + (make-struct-type + 'fun-syntax #f 3 0 #f '() (current-inspector) + expand-fun-syntax/normal)]) + (values make pred? + (make-struct-field-accessor get 0 'proc) + (make-struct-field-accessor get 1 'certifier) + (make-struct-field-accessor get 2 'name)))) + + ;; This is used to expand a fun-syntax in a _fun type context. + (define (expand-fun-syntax/fun stx) + (let loop ([stx stx]) + (define (do-expand id id?) ; id? == are we expanding an identifier? + (define v (syntax-local-value id (lambda () #f))) + (define set!-trans? (set!-transformer? v)) + (define proc (if set!-trans? (set!-transformer-procedure v) v)) + (if (and (fun-syntax? proc) (or (not id?) set!-trans?)) + ;; Do essentially the same thing that `local-expand' does. + ;; First, create an "introducer" to mark introduced identifiers: + (let* ([introduce (make-syntax-introducer)] + [expanded + ;; Re-introduce mark related to expansion of `_fun': + (syntax-local-introduce + ;; Re-add mark specific to this expansion, cancelling + ;; some marks applied before expanding (leaving only + ;; introuced syntax marked) + (introduce + ;; Actually expand: + ((fun-syntax-proc proc) + ;; Add mark specific to this expansion: + (introduce + ;; Remove mark related to expansion of `_fun': + (syntax-local-introduce stx)))))]) + ;; Certify based on definition of expander, then loop + ;; to continue expanding: + (loop ((fun-syntax-certifier proc) + expanded fun-cert-key introduce))) + stx)) + (syntax-case stx () + [(id . rest) (identifier? #'id) (do-expand #'id #f)] + [id (identifier? #'id) (do-expand #'id #t)] + [_else stx]))) + + ;; Use module-or-top-identifier=? because we use keywords like `=' and want + ;; to make it possible to play with it at the toplevel. + (define id=? module-or-top-identifier=?) + + (define (split-by key args) + (let loop ([args args] [r (list '())]) + (cond [(null? args) (reverse (map reverse r))] + [(eq? key (car args)) (loop (cdr args) (cons '() r))] + [else (loop (cdr args) + (cons (cons (car args) (car r)) (cdr r)))]))) + + (define (add-renamer body from to) + (with-syntax ([body body] [from from] [to to]) + #'(let-syntax ([to (syntax-id-rules () + [(_?_ . _rest_) (from . _rest_)] [_?_ from])]) + body))) + + (define (custom-type->keys type err) + (define stops (map (lambda (s) (datum->syntax type s #f)) + '(#%app #%top #%datum))) + ;; Expand `type' using expand-fun-syntax/fun + (define orig (expand-fun-syntax/fun type)) + (define (with-arg x) + (syntax-case* x (=>) id=? + [(id => body) (identifier? #'id) + ;; Extract #'body from its context, use a key it needs certification: + (list (syntax-recertify #'id orig #f fun-cert-key) + (syntax-recertify #'body orig #f fun-cert-key))] + [_else x])) + (define (cert-id id) + (syntax-recertify id orig #f fun-cert-key)) + (let ([keys '()]) + (define (setkey! key val . id?) + (cond + [(assq key keys) + (err "bad expansion of custom type (two `~a:'s)" key type)] + [(and (pair? id?) (car id?) (not (identifier? val))) + (err "bad expansion of custom type (`~a:' expects an identifier)" + key type)] + [else (set! keys (cons (cons key val) keys))])) + (let loop ([t orig]) + (define (next rest . args) (apply setkey! args) (loop rest)) + (syntax-case* t (type: expr: bind: 1st-arg: prev-arg: pre: post:) id=? + [(type: t x ...) (next #'(x ...) 'type #'t)] + [(expr: e x ...) (next #'(x ...) 'expr #'e)] + [(bind: id x ...) (next #'(x ...) 'bind (cert-id #'id) #t)] + [(1st-arg: id x ...) (next #'(x ...) '1st (cert-id #'id) #t)] + [(prev-arg: id x ...) (next #'(x ...) 'prev (cert-id #'id) #t)] + ;; in the following two cases pass along orig for recertifying + [(pre: p x ...) (next #'(x ...) 'pre (with-arg #'p))] + [(post: p x ...) (next #'(x ...) 'post (with-arg #'p))] + [() (and (pair? keys) keys)] + [_else #f])))) + + ;; This is used for a normal expansion of fun-syntax, when not in a _fun type + ;; context. + ;; bug in begin-for-syntax (PR7104), see above + ;; should be (define (expand-fun-syntax/normal fun-stx stx) ...) + (foo!!! (lambda (fun-stx stx) + (define (err msg . sub) + (apply raise-syntax-error (fun-syntax-name fun-stx) msg stx sub)) + (let ([keys (custom-type->keys stx err)]) + (define (getkey key) (cond [(assq key keys) => cdr] [else #f])) + (define (notkey key) + (when (getkey key) + (err (format "this type must be used in a _fun expression (uses ~s)" + key)))) + (if keys + (let ([type (getkey 'type)] [pre (getkey 'pre)] [post (getkey 'post)]) + (unless type + (err "this type must be used in a _fun expression (#f type)")) + (for-each notkey '(expr bind 1st prev)) + (if (or pre post) + ;; a type with pre/post blocks + (let ([make-> (lambda (x what) + (cond [(not x) #'#f] + [(and (list? x) (= 2 (length x)) + (identifier? (car x))) + #`(lambda (#,(car x)) #,(cadr x))] + [else #`(lambda (_) + (error '#,(fun-syntax-name fun-stx) + "cannot be used to ~a" + #,what))]))]) + (with-syntax ([type type] + [scheme->c (make-> pre "send values to C")] + [c->scheme (make-> post "get values from C")]) + #'(make-ctype type scheme->c c->scheme))) + ;; simple type + type)) + ;; no keys => normal expansion + ((fun-syntax-proc fun-stx) stx)))))) + +;; Use define-fun-syntax instead of define-syntax for forms that +;; are to be expanded by `_fun': +(provide define-fun-syntax) +(define-syntax define-fun-syntax + (syntax-rules () + [(_ id trans) + (define-syntax id + (let* ([xformer trans] + [set!-trans? (set!-transformer? xformer)]) + (unless (or (and (procedure? xformer) + (procedure-arity-includes? xformer 1)) + set!-trans?) + (raise-type-error 'define-fun-syntax + "procedure (arity 1) or set!-transformer" + xformer)) + (let ([f (make-fun-syntax (if set!-trans? + (set!-transformer-procedure xformer) + xformer) + ;; Capture definition-time certificates: + (syntax-local-certifier) + 'id)]) + (if set!-trans? (make-set!-transformer f) f))))])) + +;; ---------------------------------------------------------------------------- +;; Function type + +;; Creates a simple function type that can be used for callouts and callbacks, +;; optionally applying a wrapper function to modify the result primitive +;; (callouts) or the input procedure (callbacks). +(define* (_cprocedure itypes otype + #:abi [abi #f] + #:wrapper [wrapper #f] + #:keep [keep #f] + #:atomic? [atomic? #f]) + (_cprocedure* itypes otype abi wrapper keep atomic?)) + +;; for internal use +(define held-callbacks (make-weak-hasheq)) +(define (_cprocedure* itypes otype abi wrapper keep atomic?) + (define-syntax-rule (make-it wrap) + (make-ctype _fpointer + (lambda (x) + (and x + (let ([cb (ffi-callback (wrap x) itypes otype abi atomic?)]) + (cond [(eq? keep #t) (hash-set! held-callbacks x cb)] + [(box? keep) + (let ([x (unbox keep)]) + (set-box! keep + (if (or (null? x) (pair? x)) (cons cb x) cb)))] + [(procedure? keep) (keep cb)]) + cb))) + (lambda (x) (and x (wrap (ffi-call x itypes otype abi)))))) + (if wrapper (make-it wrapper) (make-it begin))) + +;; Syntax for the special _fun type: +;; (_fun [{(name ... [. name]) | name} [-> expr] ::] +;; {type | (name : type [= expr]) | ([name :] type = expr)} ... +;; -> {type | (name : type)} +;; [-> expr]) +;; Usage: +;; `{(name ...) | ...} ::' specify explicit wrapper function formal arguments +;; `-> expr' can be used instead of the last expr +;; `type' input type (implies input, but see type macros next) +;; `(name : type = expr)' specify name and type, `= expr' means computed input +;; `-> type' output type (possibly with name) +;; `-> expr' specify different output, can use previous names +;; Also, see below for custom function types. + +(provide ->) ; to signal better errors when trying to use this with contracts +(define-syntax -> + (syntax-id-rules () + [_ (raise-syntax-error '-> "should be used only in a _fun context")])) + +(provide _fun) +(define-syntax (_fun stx) + (define (err msg . sub) (apply raise-syntax-error '_fun msg stx sub)) + (define xs #f) + (define abi #f) + (define keep #f) + (define atomic? #f) + (define inputs #f) + (define output #f) + (define bind '()) + (define pre '()) + (define post '()) + (define input-names #f) + (define output-type #f) + (define output-expr #f) + (define 1st-arg #f) + (define prev-arg #f) + (define (bind! x) (set! bind (append bind (list x)))) + (define (pre! x) (set! pre (append pre (list x)))) + (define (post! x) (set! post (append post (list x)))) + (define ((t-n-e clause) type name expr) + (let ([keys (custom-type->keys type err)]) + (define (getkey key) (cond [(assq key keys) => cdr] [else #f])) + (define (arg x . no-expr?) + (define use-expr? + (and (list? x) (= 2 (length x)) (identifier? (car x)))) + ;; when the current expr is not used with a (x => ...) form, + ;; either check that no expression is given or just make it + ;; disappear from the inputs. + (unless use-expr? + (if (and (pair? no-expr?) (car no-expr?) expr) + (err "got an expression for a custom type that do not use it" + clause) + (set! expr (void)))) + (set! x (if use-expr? (add-renamer (cadr x) name (car x)) x)) + (cond [(getkey '1st) => + (lambda (v) + (if 1st-arg + (set! x (add-renamer x 1st-arg v)) + (err "got a custom type that wants 1st arg too early" + clause)))]) + (cond [(getkey 'prev) => + (lambda (v) + (if prev-arg + (set! x (add-renamer x prev-arg v)) + (err "got a custom type that wants prev arg too early" + clause)))]) + x) + (when keys + (set! type (getkey 'type)) + (cond [(and (not expr) (getkey 'expr)) => (lambda (x) (set! expr x))]) + (cond [(getkey 'bind) => (lambda (x) (bind! #`[#,x #,name]))]) + (cond [(getkey 'pre) => (lambda (x) (pre! #`[#,name #,(arg x #t)]))]) + (cond [(getkey 'post) => (lambda (x) (post! #`[#,name #,(arg x)]))])) + ;; turn a #f syntax to #f + (set! type (and type (syntax-case type () [#f #f] [_ type]))) + (when type ; remember these for later usages + (unless 1st-arg (set! 1st-arg name)) + (set! prev-arg name)) + (list type name expr))) + (define (do-fun) + ;; parse keywords + (let loop () + (let ([k (and (pair? xs) (pair? (cdr xs)) (syntax-e (car xs)))]) + (define-syntax-rule (kwds [key var] ...) + (case k + [(key) (if var + (err (format "got a second ~s keyword") 'key (car xs)) + (begin (set! var (cadr xs)) (set! xs (cddr xs)) (loop)))] + ... + [else (err "unknown keyword" (car xs))])) + (when (keyword? k) (kwds [#:abi abi] [#:keep keep] [#:atomic? atomic?])))) + (unless abi (set! abi #'#f)) + (unless keep (set! keep #'#t)) + (unless atomic? (set! atomic? #'#f)) + ;; parse known punctuation + (set! xs (map (lambda (x) + (syntax-case* x (-> ::) id=? [:: '::] [-> '->] [_ x])) + xs)) + ;; parse "::" + (let ([s (split-by ':: xs)]) + (case (length s) + [(0) (err "something bad happened (::)")] + [(1) (void)] + [(2) (if (and (= 1 (length (car s))) (not (eq? '-> (caar s)))) + (begin (set! xs (cadr s)) (set! input-names (caar s))) + (err "bad wrapper formals"))] + [else (err "saw two or more instances of `::'")])) + ;; parse "->" + (let ([s (split-by '-> xs)]) + (case (length s) + [(0) (err "something bad happened (->)")] + [(1) (err "missing output type")] + [(2 3) (set! inputs (car s)) + (case (length (cadr s)) + [(1) (set! output-type (caadr s))] + [(0) (err "missing output type after `->'")] + [else (err "extraneous output type" (cadadr s))]) + (unless (null? (cddr s)) + (case (length (caddr s)) + [(1) (set! output-expr (caaddr s))] + [(0) (err "missing output expression after `->'")] + [else (err "extraneous output expression" + (cadr (caddr s)))]))] + [else (err "saw three or more instances of `->'")])) + (set! inputs + (map (lambda (sub temp) + (let ([t-n-e (t-n-e sub)]) + (syntax-case* sub (: =) id=? + [(name : type) (t-n-e #'type #'name #f)] + [(type = expr) (t-n-e #'type temp #'expr)] + [(name : type = expr) (t-n-e #'type #'name #'expr)] + [type (t-n-e #'type temp #f)]))) + inputs + (generate-temporaries (map (lambda (x) 'tmp) inputs)))) + ;; when processing the output type, only the post code matters + (set! pre! (lambda (x) #f)) + (set! output + (let ([temp (car (generate-temporaries #'(ret)))] + [t-n-e (t-n-e output-type)]) + (syntax-case* output-type (: =) id=? + [(name : type) (t-n-e #'type #'name output-expr)] + [(type = expr) (if output-expr + (err "extraneous output expression" #'expr) + (t-n-e #'type temp #'expr))] + [(name : type = expr) + (if output-expr + (err "extraneous output expression" #'expr) + (t-n-e #'type #'name #'expr))] + [type (t-n-e #'type temp output-expr)]))) + (if (or (caddr output) input-names (ormap caddr inputs) + (ormap (lambda (x) (not (car x))) inputs) + (pair? bind) (pair? pre) (pair? post)) + (let* ([input-names (or input-names + (filter-map (lambda (i) + (and (not (caddr i)) (cadr i))) + inputs))] + [output-expr (let ([o (caddr output)]) + (or (and (not (void? o)) o) + (cadr output)))] + [args (filter-map (lambda (i) + (and (caddr i) + (not (void? (caddr i))) + #`[#,(cadr i) #,(caddr i)])) + inputs)] + [ffi-args (filter-map (lambda (x) (and (car x) (cadr x))) inputs)] + ;; the actual wrapper body + [body (quasisyntax/loc stx + (lambda #,input-names + (let* (#,@args + #,@bind + #,@pre + [#,(cadr output) (ffi #,@ffi-args)] + #,@post) + #,output-expr)))] + ;; if there is a string 'ffi-name property, use it as a name + [body (let ([n (cond [(syntax-property stx 'ffi-name) + => syntax->datum] + [else #f])]) + (if (string? n) + (syntax-property + body 'inferred-name + (string->symbol (string-append "ffi-wrapper:" n))) + body))]) + #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) + #,abi (lambda (ffi) #,body) #,keep #,atomic?)) + #`(_cprocedure* (list #,@(filter-map car inputs)) #,(car output) + #,abi #f #,keep #,atomic?))) + (syntax-case stx () + [(_ x ...) (begin (set! xs (syntax->list #'(x ...))) (do-fun))])) + +(define (function-ptr p fun-ctype) + (if (or (cpointer? p) (procedure? p)) + (if (eq? (ctype->layout fun-ctype) 'fpointer) + (if (procedure? p) + ((ctype-scheme->c fun-ctype) p) + ((ctype-c->scheme fun-ctype) p)) + (raise-type-error 'function-ptr "function ctype" fun-ctype)) + (raise-type-error 'function-ptr "cpointer" p))) + +;; ---------------------------------------------------------------------------- +;; String types + +;; The internal _string type uses the native ucs-4 encoding, also providing a +;; utf-16 type +(provide _string/ucs-4 _string/utf-16) + +;; 8-bit string encodings, #f is NULL +(define ((false-or-op op) x) (and x (op x))) +(define* _string/utf-8 + (make-ctype _bytes + (false-or-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) +(define* _string/locale + (make-ctype _bytes + (false-or-op string->bytes/locale) (false-or-op bytes->string/locale))) +(define* _string/latin-1 + (make-ctype _bytes + (false-or-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) + +;; 8-bit string encodings, #f is NULL, can also use bytes and paths +(define ((any-string-op op) x) + (cond [(not x) x] + [(bytes? x) x] + [(path? x) (path->bytes x)] + [else (op x)])) +(define* _string*/utf-8 + (make-ctype _bytes + (any-string-op string->bytes/utf-8) (false-or-op bytes->string/utf-8))) +(define* _string*/locale + (make-ctype _bytes + (any-string-op string->bytes/locale) (false-or-op bytes->string/locale))) +(define* _string*/latin-1 + (make-ctype _bytes + (any-string-op string->bytes/latin-1) (false-or-op bytes->string/latin-1))) + +;; A generic _string type that usually does the right thing via a parameter +(define* default-_string-type + (make-parameter _string*/utf-8 + (lambda (x) + (if (ctype? x) + x (error 'default-_string-type "expecting a C type, got ~e" x))))) +;; The type looks like an identifier, but it's actually using the parameter +(provide _string) +(define-syntax _string + (syntax-id-rules () + [(_ . xs) ((default-_string-type) . xs)] + [_ (default-_string-type)])) + +;; _symbol is defined in C, since it uses simple C strings +(provide _symbol) + +(provide _path) +;; `file' type: path-expands a path string, provide _path too. +(define* _file (make-ctype _path cleanse-path #f)) + +;; `string/eof' type: converts an output #f (NULL) to an eof-object. +(define string-type->string/eof-type + (let ([table (make-hasheq)]) + (lambda (string-type) + (hash-ref table string-type + (lambda () + (let ([new-type (make-ctype string-type + (lambda (x) (and (not (eof-object? x)) x)) + (lambda (x) (or x eof)))]) + (hash-set! table string-type new-type) + new-type)))))) +(provide _string/eof _bytes/eof) +(define _bytes/eof + (make-ctype _bytes + (lambda (x) (and (not (eof-object? x)) x)) + (lambda (x) (or x eof)))) +(define-syntax _string/eof ; make it a syntax so it depends on the _string type + (syntax-id-rules () + [(_ . xs) ((string-type->string/eof-type _string) . xs)] + [_ (string-type->string/eof-type _string)])) + +;; ---------------------------------------------------------------------------- +;; Utility types + +;; Call this with a name (symbol) and a list of symbols, where a symbol can be +;; followed by a '= and an integer to have a similar effect of C's enum. +(define (_enum* name symbols . base?) + (define basetype (if (pair? base?) (car base?) _ufixint)) + (define sym->int '()) + (define int->sym '()) + (define s->c + (if name (string->symbol (format "enum:~a->int" name)) 'enum->int)) + (let loop ([i 0] [symbols symbols]) + (unless (null? symbols) + (let-values ([(i rest) + (if (and (pair? (cdr symbols)) + (eq? '= (cadr symbols)) + (pair? (cddr symbols))) + (values (caddr symbols) + (cdddr symbols)) + (values i + (cdr symbols)))]) + (set! sym->int (cons (cons (car symbols) i) sym->int)) + (set! int->sym (cons (cons i (car symbols)) int->sym)) + (loop (add1 i) rest)))) + (make-ctype basetype + (lambda (x) + (let ([a (assq x sym->int)]) + (if a + (cdr a) + (raise-type-error s->c (format "~a" (or name "enum")) x)))) + (lambda (x) (cond [(assq x int->sym) => cdr] [else #f])))) + +;; Macro wrapper -- no need for a name +(provide _enum) +(define-syntax (_enum stx) + (syntax-case stx () + [(_ syms) + (with-syntax ([name (syntax-local-name)]) + #'(_enum* 'name syms))] + [(_ syms basetype) + (with-syntax ([name (syntax-local-name)]) + #'(_enum* 'name syms basetype))] + [id (identifier? #'id) + #'(lambda (syms . base?) (apply _enum* #f syms base?))])) + +;; Call this with a name (symbol) and a list of (symbol int) or symbols like +;; the above with '= -- but the numbers have to be specified in some way. The +;; generated type will convert a list of these symbols into the logical-or of +;; their values and back. +(define (_bitmask* name orig-symbols->integers . base?) + (define basetype (if (pair? base?) (car base?) _uint)) + (define s->c + (if name (string->symbol (format "bitmask:~a->int" name)) 'bitmask->int)) + (define symbols->integers + (let loop ([s->i orig-symbols->integers]) + (cond + [(null? s->i) + null] + [(and (pair? (cdr s->i)) (eq? '= (cadr s->i)) (pair? (cddr s->i))) + (cons (list (car s->i) (caddr s->i)) + (loop (cdddr s->i)))] + [(and (pair? (car s->i)) (pair? (cdar s->i)) (null? (cddar s->i)) + (symbol? (caar s->i)) (integer? (cadar s->i))) + (cons (car s->i) (loop (cdr s->i)))] + [else + (error '_bitmask "bad spec in ~e" orig-symbols->integers)]))) + (make-ctype basetype + (lambda (symbols) + (if (null? symbols) ; probably common + 0 + (let loop ([xs (if (pair? symbols) symbols (list symbols))] [n 0]) + (cond [(null? xs) n] + [(assq (car xs) symbols->integers) => + (lambda (x) (loop (cdr xs) (bitwise-ior (cadr x) n)))] + [else (raise-type-error s->c (format "~a" (or name "bitmask")) + symbols)])))) + (lambda (n) + (if (zero? n) ; probably common + '() + (let loop ([s->i symbols->integers] [l '()]) + (if (null? s->i) + (reverse l) + (loop (cdr s->i) + (let ([i (cadar s->i)]) + (if (and (not (= i 0)) (= i (bitwise-and i n))) + (cons (caar s->i) l) + l))))))))) + +;; Macro wrapper -- no need for a name +(provide _bitmask) +(define-syntax (_bitmask stx) + (syntax-case stx () + [(_ syms) + (with-syntax ([name (syntax-local-name)]) + #'(_bitmask* 'name syms))] + [(_ syms basetype) + (with-syntax ([name (syntax-local-name)]) + #'(_bitmask* 'name syms basetype))] + [id (identifier? #'id) + #'(lambda (syms . base?) (apply _bitmask* #f syms base?))])) + +;; ---------------------------------------------------------------------------- +;; Custom function type macros + +;; These macros get expanded by the _fun type. They can expand to a form that +;; looks like (keyword: value ...), where the keyword is one of: +;; * `type:' for the type that will be used, +;; * `expr:' an expression that will always be used for these arguments, as +;; if `= expr' is always given, when an expression is actually +;; given in an argument specification, it supersedes this. +;; * `bind:' for an additional binding that holds the initial value, +;; * `1st-arg:' is used to name an identifier that will be bound to the value +;; of the 1st foreign argument in pre/post chunks (good for +;; common cases where the first argument has a special meaning, +;; eg, for method calls), +;; * `prev-arg:' similar to 1st-arg: but for the previous argument, +;; * `pre:' for a binding that will be inserted before the ffi call, +;; * `post:' for a binding after the ffi call. +;; The pre: and post: bindings can be of the form (id => expr) to use the +;; existing value. Note that if the pre: expression is not (id => expr), then +;; it means that there is no input for this argument. Also note that if a +;; custom type is used as an output type of a function, then only the post: +;; code is used -- for example, this is useful for foreign functions that +;; allocate a memory block and return it to the user. The resulting wrapper +;; looks like: +;; (let* (...bindings for arguments... +;; ...bindings for bind: identifiers... +;; ...bindings for pre-code... +;; (ret-name ffi-call) +;; ...bindings for post-code...) +;; return-expression) +;; +;; Finally, the code in a custom-function macro needs special treatment when it +;; comes to dealing with code certificates, so instead of using +;; `define-syntax', you should use `define-fun-syntax' (used in the same way). + +;; _? +;; This is not a normal ffi type -- it is a marker for expressions that should +;; not be sent to the ffi function. Use this to bind local values in a +;; computation that is part of an ffi wrapper interface. +(provide _?) +(define-fun-syntax _? + (syntax-id-rules () [(_ . xs) ((type: #f) . xs)] [_ (type: #f)])) + +;; (_ptr ) +;; This is for pointers, where mode indicates input or output pointers (or +;; both). If the mode is `o' (output), then the wrapper will not get an +;; argument for it, instead it generates the matching argument. +(provide _ptr) +(define-fun-syntax _ptr + (syntax-rules (i o io) + [(_ i t) (type: _pointer + pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p)))] + [(_ o t) (type: _pointer + pre: (malloc t) + post: (x => (ptr-ref x t)))] + [(_ io t) (type: _pointer + pre: (x => (let ([p (malloc t)]) (ptr-set! p t x) p)) + post: (x => (ptr-ref x t)))])) + +;; (_box ) +;; This is similar to a (_ptr io ) argument, where the input is expected +;; to be a box, which is unboxed on entry and modified on exit. +(provide _box) +(define-fun-syntax _box + (syntax-rules () + [(_ t) (type: _pointer + bind: tmp ; need to save the box so we can get back to it + pre: (x => (let ([p (malloc t)]) (ptr-set! p t (unbox x)) p)) + post: (x => (begin (set-box! tmp (ptr-ref x t)) tmp)))])) + +;; (_list []) +;; Similar to _ptr, except that it is used for converting lists to/from C +;; vectors. The length is needed for output values where it is used in the +;; post code, and in the pre code of an output mode to allocate the block. In +;; any case it can refer to a previous binding for the length of the list which +;; the C function will most likely require. +(provide _list) +(define-fun-syntax _list + (syntax-rules (i o io) + [(_ i t ) (type: _pointer + pre: (x => (list->cblock x t)))] + [(_ o t n) (type: _pointer + pre: (malloc n t) + post: (x => (cblock->list x t n)))] + [(_ io t n) (type: _pointer + pre: (x => (list->cblock x t)) + post: (x => (cblock->list x t n)))])) + +;; (_vector []) +;; Same as _list, except that it uses Scheme vectors. +(provide _vector) +(define-fun-syntax _vector + (syntax-rules (i o io) + [(_ i t ) (type: _pointer + pre: (x => (vector->cblock x t)))] + [(_ o t n) (type: _pointer + pre: (malloc n t) + post: (x => (cblock->vector x t n)))] + [(_ io t n) (type: _pointer + pre: (x => (vector->cblock x t)) + post: (x => (cblock->vector x t n)))])) + +;; _bytes or (_bytes o n) is for a memory block represented as a Scheme byte +;; string. _bytes is just like a byte-string, and (_bytes o n) is for +;; pre-malloc of the string. There is no need for other modes: i or io would +;; be just like _bytes since the string carries its size information (so there +;; is no real need for the `o', but it's there for consistency with the above +;; macros). +(provide (rename-out [_bytes* _bytes])) +(define-fun-syntax _bytes* + (syntax-id-rules (o) + [(_ o n) (type: _bytes + pre: (make-sized-byte-string (malloc n) n) + ;; post is needed when this is used as a function output type + post: (x => (make-sized-byte-string x n)))] + [(_ . xs) (_bytes . xs)] + [_ _bytes])) + +;; ---------------------------------------------------------------------------- +;; Safe raw vectors + +(define-struct cvector (ptr type length)) + +(provide* cvector? cvector-length cvector-type cvector-ptr + ;; make-cvector* is a dangerous operation + (unsafe (rename-out [make-cvector make-cvector*]))) + +(define _cvector* ; used only as input types + (make-ctype _pointer cvector-ptr + (lambda (x) + (error '_cvector + "cannot automatically convert a C pointer to a cvector")))) + +;; (_cvector [ ]) | _cevector +;; Same as _list etc above, except that it uses C vectors. +(provide _cvector) +(define-fun-syntax _cvector + (syntax-id-rules (i o io) + [(_ i ) _cvector*] + [(_ o t n) (type: _pointer ; needs to be a pointer, not a cvector* + pre: (malloc n t) + post: (x => (make-cvector x t n)))] + [(_ io ) (type: _cvector* + bind: tmp + pre: (x => (cvector-ptr x)) + post: (x => tmp))] + [(_ . xs) (_cvector* . xs)] + [_ _cvector*])) + +(provide (rename-out [allocate-cvector make-cvector])) +(define (allocate-cvector type len) + (make-cvector (if (zero? len) #f ; 0 => NULL + (malloc len type)) + type len)) + +(provide (rename-out [cvector-args cvector])) +(define (cvector-args type . args) + (list->cvector args type)) + +(define* (cvector-ref v i) + (if (and (exact-nonnegative-integer? i) (< i (cvector-length v))) + (ptr-ref (cvector-ptr v) (cvector-type v) i) + (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e" + i (sub1 (cvector-length v))))) + +(define* (cvector-set! v i x) + (if (and (exact-nonnegative-integer? i) (< i (cvector-length v))) + (ptr-set! (cvector-ptr v) (cvector-type v) i x) + (error 'cvector-ref "bad index ~e for cvector bounds of 0..~e" + i (sub1 (cvector-length v))))) + +(define* (cvector->list v) + (cblock->list (cvector-ptr v) (cvector-type v) (cvector-length v))) + +(define* (list->cvector l type) + (make-cvector (list->cblock l type) type (length l))) + +;; ---------------------------------------------------------------------------- +;; SRFI-4 implementation + +(define-syntax (srfi-4-define/provide stx) + (syntax-case stx () + [(_ TAG type) + (identifier? #'TAG) + (let ([name (format "~avector" (syntax->datum #'TAG))]) + (define (id prefix suffix) + (let* ([name (if prefix (string-append prefix name) name)] + [name (if suffix (string-append name suffix) name)]) + (datum->syntax #'TAG (string->symbol name) #'TAG))) + (with-syntax ([TAG? (id "" "?")] + [TAG (id "" "")] + [s:TAG (id "s:" "")] + [make-TAG (id "make-" "")] + [TAG-ptr (id "" "-ptr")] + [TAG-length (id "" "-length")] + [allocate-TAG (id "allocate-" "")] + [TAG* (id "" "*")] + [list->TAG (id "list->" "")] + [TAG->list (id "" "->list")] + [TAG-ref (id "" "-ref")] + [TAG-set! (id "" "-set!")] + [_TAG (id "_" "")] + [_TAG* (id "_" "*")] + [TAGname name]) + #'(begin + (define-struct TAG (ptr length)) + (provide TAG? TAG-length (rename-out [TAG s:TAG])) + (provide (rename-out [allocate-TAG make-TAG])) + (define (allocate-TAG n . init) + (let* ([p (if (eq? n 0) #f (malloc n type))] + [v (make-TAG p n)]) + (when (and p (pair? init)) + (let ([init (car init)]) + (let loop ([i (sub1 n)]) + (unless (< i 0) + (ptr-set! p type i init) + (loop (sub1 i)))))) + v)) + (provide (rename-out [TAG* TAG])) + (define (TAG* . vals) + (list->TAG vals)) + (define* (TAG-ref v i) + (if (TAG? v) + (if (and (exact-nonnegative-integer? i) (< i (TAG-length v))) + (ptr-ref (TAG-ptr v) type i) + (error 'TAG-ref "bad index ~e for ~a bounds of 0..~e" + i 'TAG (sub1 (TAG-length v)))) + (raise-type-error 'TAG-ref TAGname v))) + (define* (TAG-set! v i x) + (if (TAG? v) + (if (and (exact-nonnegative-integer? i) (< i (TAG-length v))) + (ptr-set! (TAG-ptr v) type i x) + (error 'TAG-set! "bad index ~e for ~a bounds of 0..~e" + i 'TAG (sub1 (TAG-length v)))) + (raise-type-error 'TAG-set! TAGname v))) + (define* (TAG->list v) + (if (TAG? v) + (cblock->list (TAG-ptr v) type (TAG-length v)) + (raise-type-error 'TAG->list TAGname v))) + (define* (list->TAG l) + (make-TAG (list->cblock l type) (length l))) + ;; same as the _cvector implementation + (provide _TAG) + (define _TAG* + (make-ctype _pointer TAG-ptr + (lambda (x) + (error + '_TAG + "cannot automatically convert a C pointer to a ~a" + TAGname)))) + (define-fun-syntax _TAG + (syntax-id-rules (i o io) + [(_ i ) _TAG*] + [(_ o n) (type: _pointer + pre: (malloc n type) + post: (x => (make-TAG x n)))] + [(_ io ) (type: _cvector* + bind: tmp + pre: (x => (TAG-ptr x)) + post: (x => tmp))] + [(_ . xs) (_TAG* . xs)] + [_ _TAG*])))))] + [(_ TAG type) + (identifier? #'TAG)])) + +;; check that the types that were used above have the proper sizes +(unless (= 4 (ctype-sizeof _float)) + (error 'foreign "internal error: float has a bad size (~s)" + (ctype-sizeof _float))) +(unless (= 8 (ctype-sizeof _double*)) + (error 'foreign "internal error: double has a bad size (~s)" + (ctype-sizeof _double*))) + +(srfi-4-define/provide s8 _int8) +(srfi-4-define/provide s16 _int16) +(srfi-4-define/provide u16 _uint16) +(srfi-4-define/provide s32 _int32) +(srfi-4-define/provide u32 _uint32) +(srfi-4-define/provide s64 _int64) +(srfi-4-define/provide u64 _uint64) +(srfi-4-define/provide f32 _float) +(srfi-4-define/provide f64 _double*) + +;; simply rename bytes* to implement the u8vector type +(provide (rename-out [bytes? u8vector? ] + [bytes-length u8vector-length] + [make-bytes make-u8vector ] + [bytes u8vector ] + [bytes-ref u8vector-ref ] + [bytes-set! u8vector-set! ] + [bytes->list u8vector->list ] + [list->bytes list->u8vector ] + [_bytes _u8vector ])) +;; additional `u8vector' bindings for srfi-66 +(provide (rename-out [bytes-copy u8vector-copy] [bytes=? u8vector=?])) +(define* (u8vector-compare v1 v2) + (cond [(bytes? v1 v2) 1] + [else 0])) +(define* (u8vector-copy! src src-start dest dest-start n) + (bytes-copy! dest dest-start src src-start (+ src-start n))) + +;; ---------------------------------------------------------------------------- +;; Tagged pointers + +;; Make these operations available for unsafe interfaces (they can be used to +;; grab a hidden tag value and break code). +(provide* (unsafe cpointer-tag) (unsafe set-cpointer-tag!) + (unsafe cpointer-has-tag?) (unsafe cpointer-push-tag!)) + +;; Defined as syntax for efficiency, but can be used as procedures too. +(define-syntax (cpointer-has-tag? stx) + (syntax-case stx () + [(_ cptr tag) + #'(let ([ptag (cpointer-tag cptr)]) + (if (pair? ptag) (memq tag ptag) (eq? tag ptag)))] + [id (identifier? #'id) + #'(lambda (cptr tag) (cpointer-has-tag? cptr tag))])) +(define-syntax (cpointer-push-tag! stx) + (syntax-case stx () + [(_ cptr tag) + #'(let ([ptag (cpointer-tag cptr)]) + (set-cpointer-tag! cptr + (cond [(not ptag) tag] + [(pair? ptag) (cons tag ptag)] + [else (list tag ptag)])))] + [id (identifier? #'id) + #'(lambda (cptr tag) (cpointer-push-tag! cptr tag))])) + +(define (cpointer-maker nullable?) + (case-lambda + [(tag) ((cpointer-maker nullable?) tag #f #f #f)] + [(tag ptr-type) ((cpointer-maker nullable?) tag ptr-type #f #f)] + [(tag ptr-type scheme->c c->scheme) + (let* ([tag->C (string->symbol (format "~a->C" tag))] + [error-str (format "~a`~a' pointer" + (if nullable? "" "non-null ") tag)] + [error* (lambda (p) (raise-type-error tag->C error-str p))]) + (define-syntax-rule (tag-or-error ptr t) + (let ([p ptr]) + (if (cpointer? p) + (if (cpointer-has-tag? p t) p (error* p)) + (error* p)))) + (define-syntax-rule (tag-or-error/null ptr t) + (let ([p ptr]) + (if (cpointer? p) + (and p (if (cpointer-has-tag? p t) p (error* p))) + (error* p)))) + (make-ctype (or ptr-type _pointer) + ;; bad hack: `if's outside the lambda for efficiency + (if nullable? + (if scheme->c + (lambda (p) (tag-or-error/null (scheme->c p) tag)) + (lambda (p) (tag-or-error/null p tag))) + (if scheme->c + (lambda (p) (tag-or-error (scheme->c p) tag)) + (lambda (p) (tag-or-error p tag)))) + (if nullable? + (if c->scheme + (lambda (p) (when p (cpointer-push-tag! p tag)) (c->scheme p)) + (lambda (p) (when p (cpointer-push-tag! p tag)) p)) + (if c->scheme + (lambda (p) + (if p (cpointer-push-tag! p tag) (error* p)) + (c->scheme p)) + (lambda (p) + (if p (cpointer-push-tag! p tag) (error* p)) + p)))))])) + +;; This is a kind of a pointer that gets a specific tag when converted to +;; Scheme, and accepts only such tagged pointers when going to C. An optional +;; `ptr-type' can be given to be used as the base pointer type, instead of +;; _pointer, `scheme->c' and `c->scheme' can be used for adding conversion +;; hooks. +(define* _cpointer (cpointer-maker #f)) + +;; Similar to the above, but can tolerate null pointers (#f). +(define* _cpointer/null (cpointer-maker #t)) + +;; A macro version of the above two functions, using the defined name for a tag +;; string, and defining a predicate too. The name should look like `_foo', the +;; predicate will be `foo?', and the tag will be "foo". In addition, `foo-tag' +;; is bound to the tag. The optional `ptr-type', `scheme->c', and `c->scheme' +;; arguments are the same as those of `_cpointer'. `_foo' will be bound to the +;; _cpointer type, and `_foo/null' to the _cpointer/null type. +(provide define-cpointer-type) +(define-syntax (define-cpointer-type stx) + (syntax-case stx () + [(_ _TYPE) #'(define-cpointer-type _TYPE #f #f #f)] + [(_ _TYPE ptr-type) #'(define-cpointer-type _TYPE ptr-type #f #f)] + [(_ _TYPE ptr-type scheme->c c->scheme) + (and (identifier? #'_TYPE) + (regexp-match #rx"^_.+" (symbol->string (syntax-e #'_TYPE)))) + (let ([name (cadr (regexp-match #rx"^_(.+)$" + (symbol->string (syntax-e #'_TYPE))))]) + (define (id . strings) + (datum->syntax + #'_TYPE (string->symbol (apply string-append strings)) #'_TYPE)) + (with-syntax ([name-string name] + [TYPE? (id name "?")] + [TYPE-tag (id name "-tag")] + [_TYPE/null (id "_" name "/null")]) + #'(define-values (_TYPE _TYPE/null TYPE? TYPE-tag) + (let ([TYPE-tag name-string]) + (values (_cpointer TYPE-tag ptr-type scheme->c c->scheme) + (_cpointer/null TYPE-tag ptr-type scheme->c c->scheme) + (lambda (x) + (and (cpointer? x) (cpointer-has-tag? x TYPE-tag))) + TYPE-tag)))))])) + +;; ---------------------------------------------------------------------------- +;; Struct wrappers + +(define (compute-offsets types) + (let loop ([ts types] [cur 0] [r '()]) + (if (null? ts) + (reverse r) + (let* ([algn (ctype-alignof (car ts))] + [pos (+ cur (modulo (- (modulo cur algn)) algn))]) + (loop (cdr ts) + (+ pos (ctype-sizeof (car ts))) + (cons pos r)))))) + +;; Simple structs: call this with a list of types, and get a type that marshals +;; C structs to/from Scheme lists. +(define* (_list-struct . types) + (let ([stype (make-cstruct-type types)] + [offsets (compute-offsets types)] + [len (length types)]) + (make-ctype stype + (lambda (vals) + (unless (and (list vals) (= len (length vals))) + (raise-type-error 'list-struct (format "list of ~a items" len) vals)) + (let ([block (malloc stype)]) + (for-each (lambda (type ofs val) (ptr-set! block type 'abs ofs val)) + types offsets vals) + block)) + (lambda (block) + (map (lambda (type ofs) (ptr-ref block type 'abs ofs)) + types offsets))))) + +;; (define-cstruct _foo ([slot type] ...)) +;; or +;; (define-cstruct (_foo _super) ([slot type] ...)) +;; defines a type called _foo for a C struct, with user-procedues: make-foo, +;; foo? foo-slot... and set-foo-slot!.... The `_' prefix is required. Objects +;; of this new type are actually cpointers, with a type tag that is "foo" and +;; (possibly more if the first type is itself a cstruct type or if a super type +;; is given,) provided as foo-tag, and tags of pointers are checked before +;; attempting to use them (see define-cpointer-type above). Note that since +;; structs are implemented as pointers, they can be used for a _pointer input +;; to a foreign function: their address will be used, to make this possible, +;; the corresponding cpointer type is defined as _foo-pointer. If a super +;; cstruct type is given, the constructor function expects values for every +;; field of the super type as well as other fields that are specified, and a +;; slot named `super' can be used to extract this initial struct -- although +;; pointers to the new struct type can be used as pointers to the super struct +;; type. +(provide define-cstruct) +(define-syntax (define-cstruct stx) + (define (make-syntax _TYPE-stx has-super? slot-names-stx slot-types-stx) + (define name + (cadr (regexp-match #rx"^_(.+)$" (symbol->string (syntax-e _TYPE-stx))))) + (define slot-names (map (lambda (x) (symbol->string (syntax-e x))) + (syntax->list slot-names-stx))) + (define 1st-type + (let ([xs (syntax->list slot-types-stx)]) (and (pair? xs) (car xs)))) + (define (id . strings) + (datum->syntax + _TYPE-stx (string->symbol (apply string-append strings)) _TYPE-stx)) + (define (ids name-func) + (map (lambda (s) + (datum->syntax + _TYPE-stx + (string->symbol (apply string-append (name-func s))) + _TYPE-stx)) + slot-names)) + (define (safe-id=? x y) + (and (identifier? x) (identifier? y) (free-identifier=? x y))) + (with-syntax + ([has-super? has-super?] + [name-string name] + [struct-string (format "struct:~a" name)] + [(slot ...) slot-names-stx] + [(slot-type ...) slot-types-stx] + [_TYPE _TYPE-stx] + [_TYPE-pointer (id "_"name"-pointer")] + [_TYPE-pointer/null (id "_"name"-pointer/null")] + [_TYPE/null (id "_"name"/null")] + [_TYPE* (id "_"name"*")] + [TYPE? (id name"?")] + [make-TYPE (id "make-"name)] + [list->TYPE (id "list->"name)] + [list*->TYPE (id "list*->"name)] + [TYPE->list (id name"->list")] + [TYPE->list* (id name"->list*")] + [TYPE-tag (id name"-tag")] + [(stype ...) (ids (lambda (s) `(,name"-",s"-type")))] + [(TYPE-SLOT ...) (ids (lambda (s) `(,name"-",s)))] + [(set-TYPE-SLOT! ...) (ids (lambda (s) `("set-",name"-",s"!")))] + [(offset ...) (generate-temporaries + (ids (lambda (s) `(,s"-offset"))))]) + (with-syntax ([get-super-info + ;; the 1st-type might be a pointer to this type + (if (or (safe-id=? 1st-type #'_TYPE-pointer/null) + (safe-id=? 1st-type #'_TYPE-pointer)) + #'(values #f '() #f #f #f #f) + #`(cstruct-info #,1st-type + (lambda () (values #f '() #f #f #f #f))))]) + #'(define-values (_TYPE _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag + make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... + list->TYPE list*->TYPE TYPE->list TYPE->list*) + (let-values ([(super-pointer super-tags super-types super-offsets + super->list* list*->super) + get-super-info]) + (define-cpointer-type _TYPE super-pointer) + ;; these makes it possible to use recursive pointer definitions + (define _TYPE-pointer _TYPE) + (define _TYPE-pointer/null _TYPE/null) + (let*-values ([(stype ...) (values slot-type ...)] + [(types) (list stype ...)] + [(offsets) (compute-offsets types)] + [(offset ...) (apply values offsets)]) + (define all-tags (cons TYPE-tag super-tags)) + (define _TYPE* + ;; c->scheme adjusts all tags + (let* ([cst (make-cstruct-type types)] + [t (_cpointer TYPE-tag cst)] + [c->s (ctype-c->scheme t)]) + (make-ctype cst (ctype-scheme->c t) + ;; hack: modify & reuse the procedure made by _cpointer + (lambda (p) + (if p (set-cpointer-tag! p all-tags) (c->s p)) + p)))) + (define-values (all-types all-offsets) + (if (and has-super? super-types super-offsets) + (values (append super-types (cdr types)) + (append super-offsets (cdr offsets))) + (values types offsets))) + (define (TYPE-SLOT x) + (unless (TYPE? x) + (raise-type-error 'TYPE-SLOT struct-string x)) + (ptr-ref x stype 'abs offset)) + ... + (define (set-TYPE-SLOT! x slot) + (unless (TYPE? x) + (raise-type-error 'set-TYPE-SLOT! struct-string 0 x slot)) + (ptr-set! x stype 'abs offset slot)) + ... + (define make-TYPE + (if (and has-super? super-types super-offsets) + ;; init using all slots + (lambda vals + (if (= (length vals) (length all-types)) + (let ([block (malloc _TYPE*)]) + (set-cpointer-tag! block all-tags) + (for-each (lambda (type ofs value) + (ptr-set! block type 'abs ofs value)) + all-types all-offsets vals) + block) + (error '_TYPE "expecting ~s values, got ~s: ~e" + (length all-types) (length vals) vals))) + ;; normal initializer + (lambda (slot ...) + (let ([block (malloc _TYPE*)]) + (set-cpointer-tag! block all-tags) + (ptr-set! block stype 'abs offset slot) + ... + block)))) + (define (list->TYPE vals) (apply make-TYPE vals)) + (define (list*->TYPE vals) + (cond + [(TYPE? vals) vals] + [(= (length vals) (length all-types)) + (let ([block (malloc _TYPE*)]) + (set-cpointer-tag! block all-tags) + (for-each + (lambda (type ofs value) + (let-values + ([(ptr tags types offsets T->list* list*->T) + (cstruct-info + type + (lambda () (values #f '() #f #f #f #f)))]) + (ptr-set! block type 'abs ofs + (if list*->T (list*->T value) value)))) + all-types all-offsets vals) + block)] + [else (error '_TYPE "expecting ~s values, got ~s: ~e" + (length all-types) (length vals) vals)])) + (define (TYPE->list x) + (unless (TYPE? x) + (raise-type-error 'TYPE-list struct-string x)) + (map (lambda (type ofs) (ptr-ref x type 'abs ofs)) + all-types all-offsets)) + (define (TYPE->list* x) + (unless (TYPE? x) + (raise-type-error 'TYPE-list struct-string x)) + (map (lambda (type ofs) + (let-values + ([(v) (ptr-ref x type 'abs ofs)] + [(ptr tags types offsets T->list* list*->T) + (cstruct-info + type + (lambda () (values #f '() #f #f #f #f)))]) + (if T->list* (T->list* v) v))) + all-types all-offsets)) + (cstruct-info + _TYPE* 'set! + _TYPE all-tags all-types all-offsets TYPE->list* list*->TYPE) + (values _TYPE* _TYPE-pointer _TYPE-pointer/null TYPE? TYPE-tag + make-TYPE TYPE-SLOT ... set-TYPE-SLOT! ... + list->TYPE list*->TYPE TYPE->list TYPE->list*))))))) + (define (identifiers? stx) + (andmap identifier? (syntax->list stx))) + (define (_-identifier? id stx) + (and (identifier? id) + (or (regexp-match #rx"^_." (symbol->string (syntax-e id))) + (raise-syntax-error #f "cstruct name must begin with a `_'" + stx id)))) + (syntax-case stx () + [(_ _TYPE ([slot slot-type] ...)) + (and (_-identifier? #'_TYPE stx) + (identifiers? #'(slot ...))) + (make-syntax #'_TYPE #f #'(slot ...) #'(slot-type ...))] + [(_ (_TYPE _SUPER) ([slot slot-type] ...)) + (and (_-identifier? #'_TYPE stx) (identifiers? #'(slot ...))) + (with-syntax ([super (datum->syntax #'_TYPE 'super #'_TYPE)]) + (make-syntax #'_TYPE #t #'(super slot ...) #'(_SUPER slot-type ...)))])) + +;; helper for the above: keep runtime information on structs +(define cstruct-info + (let ([table (make-weak-hasheq)]) + (lambda (cstruct msg/fail-thunk . args) + (cond [(eq? 'set! msg/fail-thunk) + (hash-set! table cstruct (make-ephemeron cstruct args))] + [(and cstruct ; might get a #f if there were no slots + (hash-ref table cstruct (lambda () #f))) + => (lambda (xs) + (let ([v (ephemeron-value xs)]) + (if v (apply values v) (msg/fail-thunk))))] + [else (msg/fail-thunk)])))) + +;; ---------------------------------------------------------------------------- +;; + +(define prim-synonyms + #hasheq((double* . double) + (fixint . long) + (ufixint . ulong) + (fixnum . long) + (ufixnum . ulong) + (path . bytes) + (symbol . bytes) + (scheme . pointer))) + +(define (ctype->layout c) + (let ([b (ctype-basetype c)]) + (cond + [(ctype? b) (ctype->layout b)] + [(list? b) (map ctype->layout b)] + [else (hash-ref prim-synonyms b b)]))) + +;; ---------------------------------------------------------------------------- +;; Misc utilities + +;; Used by set-ffi-obj! to get the actual value so it can be kept around +(define (get-lowlevel-object x type) + (let ([basetype (ctype-basetype type)]) + (if (ctype? basetype) + (let ([s->c (ctype-scheme->c type)]) + (get-lowlevel-object (if s->c (s->c x) x) basetype)) + (values x type)))) + +;; Converting Scheme lists to/from C vectors (going back requires a length) +(define* (list->cblock l type) + (if (null? l) + #f ; null => NULL + (let ([cblock (malloc (length l) type)]) + (let loop ([l l] [i 0]) + (unless (null? l) + (ptr-set! cblock type i (car l)) + (loop (cdr l) (add1 i)))) + cblock))) +(provide* (unsafe cblock->list)) +(define (cblock->list cblock type len) + (cond [(zero? len) '()] + [(cpointer? cblock) + (let loop ([i (sub1 len)] [r '()]) + (if (< i 0) + r + (loop (sub1 i) (cons (ptr-ref cblock type i) r))))] + [else (error 'cblock->list + "expecting a non-void pointer, got ~s" cblock)])) + +;; Converting Scheme vectors to/from C vectors +(define* (vector->cblock v type) + (let ([len (vector-length v)]) + (if (zero? len) + #f ; #() => NULL + (let ([cblock (malloc len type)]) + (let loop ([i 0]) + (when (< i len) + (ptr-set! cblock type i (vector-ref v i)) + (loop (add1 i)))) + cblock)))) +(provide* (unsafe cblock->vector)) +(define (cblock->vector cblock type len) + (cond [(zero? len) '#()] + [(cpointer? cblock) + (let ([v (make-vector len)]) + (let loop ([i (sub1 len)]) + (unless (< i 0) + (vector-set! v i (ptr-ref cblock type i)) + (loop (sub1 i)))) + v)] + [else (error 'cblock->vector + "expecting a non-void pointer, got ~s" cblock)])) + +;; Useful for automatic definitions +;; If a provided regexp begins with a "^" or ends with a "$", then +;; `regexp-replace' is used, otherwise use `regexp-replace*'. +(define* (regexp-replaces x rs) + (let loop ([str (if (bytes? x) (bytes->string/utf-8 x) (format "~a" x))] + [rs rs]) + (if (null? rs) + str + (loop ((if (regexp-match #rx"^\\^|\\$$" + (if (regexp? (caar rs)) + (object-name (caar rs)) (caar rs))) + regexp-replace regexp-replace*) + (caar rs) str (cadar rs)) (cdr rs))))) + +;; A facility for running finalizers using executors. #%foreign has a C-based +;; version that uses finalizers, but that leads to calling Scheme from the GC +;; which is not a good idea. +(define killer-executor (make-will-executor)) +(define killer-thread #f) + +(define* (register-finalizer obj finalizer) + (unless killer-thread + (set! killer-thread + (thread (lambda () + (let loop () (will-execute killer-executor) (loop)))))) + (will-register killer-executor obj finalizer)) + +(define-unsafer unsafe!) diff --git a/collects/scheme/private/local.ss b/collects/scheme/private/local.ss index 7c0c27fbef..62a4720405 100644 --- a/collects/scheme/private/local.ss +++ b/collects/scheme/private/local.ss @@ -7,47 +7,60 @@ (define-for-syntax (do-local stx letrec-syntaxes+values-id) (syntax-case stx () [(_ (defn ...) body1 body ...) - (let ([defs (let ([expand-context (generate-expand-context)]) - (let loop ([defns (syntax->list (syntax (defn ...)))]) - (apply - append - (map - (lambda (defn) - (let ([d (local-expand - defn - expand-context - (kernel-form-identifier-list))] - [check-ids (lambda (ids) - (for-each - (lambda (id) - (unless (identifier? id) - (raise-syntax-error - #f - "not an identifier for definition" - stx - id))) - ids))]) - (syntax-case d (define-values define-syntaxes begin) - [(begin defn ...) - (loop (syntax->list (syntax (defn ...))))] - [(define-values (id ...) body) - (begin - (check-ids (syntax->list (syntax (id ...)))) - (list d))] - [(define-values . rest) - (raise-syntax-error - #f "ill-formed definition" stx d)] - [(define-syntaxes (id ...) body) - (begin - (check-ids (syntax->list (syntax (id ...)))) - (list d))] - [(define-syntaxes . rest) - (raise-syntax-error - #f "ill-formed definition" stx d)] - [_else - (raise-syntax-error - #f "not a definition" stx defn)]))) - defns))))]) + (let* ([def-ctx (syntax-local-make-definition-context)] + [defs (let ([expand-context (cons (gensym 'intdef) + (let ([orig-ctx (syntax-local-context)]) + (if (pair? orig-ctx) + orig-ctx + null)))]) + (let loop ([defns (syntax->list (syntax (defn ...)))]) + (apply + append + (map + (lambda (defn) + (let ([d (local-expand + defn + expand-context + (kernel-form-identifier-list) + def-ctx)] + [check-ids (lambda (defn ids) + (for-each + (lambda (id) + (unless (identifier? id) + (raise-syntax-error + #f + "not an identifier for definition" + defn + id))) + ids))]) + (syntax-case d (define-values define-syntaxes begin) + [(begin defn ...) + (loop (syntax->list (syntax (defn ...))))] + [(define-values (id ...) body) + (let ([ids (syntax->list (syntax (id ...)))]) + (check-ids d ids) + (syntax-local-bind-syntaxes ids #f def-ctx) + (list d))] + [(define-values . rest) + (raise-syntax-error + #f "ill-formed definition" stx d)] + [(define-syntaxes (id ...) rhs) + (let ([ids (syntax->list (syntax (id ...)))]) + (check-ids d ids) + (with-syntax ([rhs (local-transformer-expand + #'rhs + 'expression + null)]) + (syntax-local-bind-syntaxes ids #'rhs def-ctx) + (list (quasisyntax/loc d (define-syntaxes #,ids rhs)))))] + [(define-syntaxes . rest) + (raise-syntax-error + #f "ill-formed definition" stx d)] + [_else + (raise-syntax-error + #f "not a definition" stx defn)]))) + defns))))]) + (internal-definition-context-seal def-ctx) (let ([ids (apply append (map (lambda (d) @@ -73,9 +86,19 @@ (raise-syntax-error #f "duplicate identifier" stx dup))) (with-syntax ([sbindings sbindings] [vbindings vbindings] - [LSV letrec-syntaxes+values-id]) + [LSV letrec-syntaxes+values-id] + [(body ...) + (map (lambda (stx) + ;; add def-ctx: + (let ([q (local-expand #`(quote #,stx) + 'expression + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ stx) #'stx]))) + (syntax->list #'(body1 body ...)))]) (syntax/loc stx (LSV sbindings vbindings - body1 body ...)))))] + body ...)))))] [(_ x body1 body ...) (raise-syntax-error #f "not a definition sequence" stx (syntax x))])) diff --git a/collects/scribblings/foreign/libs.scrbl b/collects/scribblings/foreign/libs.scrbl index cd3c352a56..b3084f9dc3 100644 --- a/collects/scribblings/foreign/libs.scrbl +++ b/collects/scribblings/foreign/libs.scrbl @@ -21,7 +21,6 @@ Returns @scheme[#t] if @scheme[v] is the result of @scheme[ffi-lib], @declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc[(ffi-lib [path (or/c path-string? #f)] [version (or/c string? (listof string?) #f) #f]) any]{ diff --git a/collects/scribblings/reference/module-reflect.scrbl b/collects/scribblings/reference/module-reflect.scrbl index 801383101e..91d47f3ae9 100644 --- a/collects/scribblings/reference/module-reflect.scrbl +++ b/collects/scribblings/reference/module-reflect.scrbl @@ -256,7 +256,9 @@ the module's explicit imports.} Returns two association lists mapping @tech{phase level} values (where @scheme[#f] corresponds to the @tech{label phase level}) to exports at the corresponding phase. The first association list is for exported -variables, and the second is for exported syntax. +variables, and the second is for exported syntax. Beware however, that +value bindings re-exported though a @tech{rename transformer} are in +the syntax list instead of the value list. Each associated list, which is represented by @scheme[list?] in the result contracts above, more precisely matches the contract diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 49e188aa33..8da2fbfb77 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -16,15 +16,22 @@ expander, otherwise the @exnraise[exn:fail:contract].}) @title[#:tag "stxtrans"]{Syntax Transformers} +@defproc[(set!-transformer? [v any/c]) boolean?]{ + +Returns @scheme[#t] if @scheme[v] is a value created by +@scheme[make-set!-transformer] or an instance of a structure type with +the @scheme[prop:set!-transformer] property, @scheme[#f] otherwise.} + + @defproc[(make-set!-transformer [proc (syntax? . -> . syntax?)]) set!-transformer?]{ -Creates a @tech{syntax transformer} that cooperates with +Creates an @tech{assignment transformer} that cooperates with @scheme[set!]. If the result of @scheme[make-set!-transformer] is -bound to @scheme[identifier] as a @tech{transformer binding}, then -@scheme[proc] is applied as a transformer when @scheme[identifier] is +bound to @scheme[_id] as a @tech{transformer binding}, then +@scheme[proc] is applied as a transformer when @scheme[_id] is used in an expression position, or when it is used as the target of a -@scheme[set!] assignment as @scheme[(set! identifier _expr)]. When the +@scheme[set!] assignment as @scheme[(set! _id _expr)]. When the identifier appears as a @scheme[set!] target, the entire @scheme[set!] expression is provided to the transformer. @@ -45,17 +52,48 @@ expression is provided to the transformer. ]} -@defproc[(set!-transformer? [v any/c]) boolean?]{ - -Returns @scheme[#t] if @scheme[v] is a value created by -@scheme[make-set!-transformer], @scheme[#f] otherwise.} - - @defproc[(set!-transformer-procedure [transformer set!-transformer?]) (syntax? . -> . syntax?)]{ Returns the procedure that was passed to -@scheme[make-set!-transformer] to create @scheme[transformer].} +@scheme[make-set!-transformer] to create @scheme[transformer] or that +is identified by the @scheme[prop:set!-transformer] property of +@scheme[transformer].} + + +@defthing[prop:set!-transformer struct-type-property?]{ + +A @tech{structure type property} to indentify structure types that act +as @tech{assignment transformers} like the ones created by +@scheme[make-set!-transformer]. + +The property value must be an exact integer or procedure of one +argument. In the former case, the integer designates a field within +the structure that should contain a procedure; the integer must be +between @scheme[0] (inclusive) and the number of non-automatic fields +in the structure type (exclusive, not counting supertype fields), and +the designated field must also be specified as immutable. + +If the property value is an procedure, then the procedure serves as a +@tech{syntax transformer} and for @scheme[set!] transformations. If +the property value is an integer, the target identifier is extracted +from the structure instance; if the field value is not a procedure of +one argument, then a procedure that always calls +@scheme[raise-syntax-error] is used, instead. + +If a value has both the @scheme[prop:set!-transformer] and +@scheme[prop:rename-transformer] properties, then the latter takes +precedence. If a structure type has the @scheme[prop:set!-transformer] +and @scheme[prop:procedure] properties, then the former takes +precedence for the purposes of macro expansion.} + + +@defproc[(rename-transformer? [v any/c]) boolean?]{ + +Returns @scheme[#t] if @scheme[v] is a value created by +@scheme[make-rename-transformer] or an instance of a structure type +with the @scheme[prop:rename-transformer] property, @scheme[#f] +otherwise.} @defproc[(make-rename-transformer [id-stx syntax?] @@ -64,28 +102,49 @@ Returns the procedure that was passed to rename-transformer?]{ Creates a @tech{rename transformer} that, when used as a -@tech{transformer binding}, acts as a transformer that insert the +@tech{transformer binding}, acts as a transformer that inserts the identifier @scheme[id-stx] in place of whatever identifier binds the transformer, including in non-application positions, in @scheme[set!] -expressions. Such a transformer could be written manually, but the one -created by @scheme[make-rename-transformer] also causes the parser to -install a @scheme[free-identifier=?] and @scheme[identifier-binding] -equivalence, and it cooperates specially with +expressions. + +Such a transformer could be written manually, but the one created by +@scheme[make-rename-transformer] also causes the parser to install a +@scheme[free-identifier=?] and @scheme[identifier-binding] +equivalence, as long as @scheme[id-stx] does not have a true value for the +@indexed-scheme['not-free-identifier=?] @tech{syntax property}. +In addition, the rename transformer cooperates specially with @scheme[syntax-local-value] and @scheme[syntax-local-make-delta-introducer].} -@defproc[(rename-transformer? [v any/c]) boolean?]{ - -Returns @scheme[#t] if @scheme[v] is a value created by -@scheme[make-rename-transformer], @scheme[#f] otherwise.} - - @defproc[(rename-transformer-target [transformer rename-transformer?]) - syntax?]{ + identifier?]{ Returns the identifier passed to @scheme[make-rename-transformer] to -create @scheme[transformer].} +create @scheme[transformer] or as indicated by a +@scheme[prop:rename-transformer] property on @scheme[transformer].} + + +@defthing[prop:rename-transformer struct-type-property?]{ + +A @tech{structure type property} to indentify structure types that act +as @tech{rename transformers} like the ones created by +@scheme[make-rename-transformer]. + +The property value must be an exact integer or an identifier +@tech{syntax object}. In the former case, the integer designates a +field within the structure that should contain an identifier; the +integer must be between @scheme[0] (inclusive) and the number of +non-automatic fields in the structure type (exclusive, not counting +supertype fields), and the designated field must also be specified as +immutable. + +If the property value is an identifier, the identifier serves as the +target for renaming, just like the first argument to +@scheme[make-rename-transformer]. If the property value is an integer, +the target identifier is extracted from the structure instance; if the +field value is not an identifier, then an identifier @schemeidfont{?} +with an empty context is used, instead.} @defproc[(local-expand [stx syntax?] @@ -309,6 +368,28 @@ being expanded for the body of a module, then resolving @transform-time[]} +@defproc[(syntax-local-value/immediate [id-stx syntax?] + [failure-thunk (or/c (-> any) #f) + #f] + [intdef-ctx (or/c internal-definition-context? + #f) + #f]) + any]{ + +Like @scheme[syntax-local-value], but the result is normally two +values. If @scheme[id-stx] is bound to a @tech{rename transformer}, +the results are the rename transformer and the identifier in the +transformer augmented with certificates from @scheme[id-stx]. If +@scheme[id-stx] is not bound to a @tech{rename transformer}, then the +results are the value that @scheme[syntax-local-value] would produce +and @scheme[#f]. + +If @scheme[id-stx] has no transformer biding, then +@scheme[failure-thunk] is called (and it can return any number of +values), or an exception is raised if @scheme[failure-thunk] is +@scheme[#f].} + + @defproc[(syntax-local-lift-expression [stx syntax?]) identifier?]{ diff --git a/collects/scribblings/reference/syntax-model.scrbl b/collects/scribblings/reference/syntax-model.scrbl index aa201a3ae1..1f080ca659 100644 --- a/collects/scribblings/reference/syntax-model.scrbl +++ b/collects/scribblings/reference/syntax-model.scrbl @@ -531,23 +531,27 @@ is the one left with a mark, and the reference @scheme[x] has no mark, so the binding @scheme[x] is not @scheme[bound-identifier=?] to the body @scheme[x]. -The @scheme[set!] form and the @scheme[make-set!-transformer] -procedure work together to support @deftech{assignment transformers} -that transformer @scheme[set!] expression. @tech{Assignment -transformers} are applied by @scheme[set!] in the same way as a normal +The @scheme[set!] form works with the @scheme[make-set!-transformer] +and @scheme[prop:set!-transformer] property to support +@deftech{assignment transformers} that transform @scheme[set!] +expressions. An @tech{assignment transformer} contains a procedure +that is applied by @scheme[set!] in the same way as a normal transformer by the expander. -The @scheme[make-rename-transformer] procedure creates a value that is -also handled specially by the expander and by @scheme[set!] as a +The @scheme[make-rename-transformer] procedure or +@scheme[prop:rename-transformer] property creates a value that is also +handled specially by the expander and by @scheme[set!] as a transformer binding's value. When @scheme[_id] is bound to a @deftech{rename transformer} produced by -@scheme[make-rename-transformer], it is replaced with the identifier -passed to @scheme[make-rename-transformer]. In addition, the lexical -information that contains the binding of @scheme[_id] is also enriched -so that @scheme[_id] is @scheme[free-identifier=?] to the identifier -passed to @scheme[make-rename-transformer], and +@scheme[make-rename-transformer], it is replaced with the target +identifier passed to @scheme[make-rename-transformer]. In addition, as +long as the target identifier does not have a true value for the +@scheme['not-free-identifier=?] @tech{syntax property}, the lexical information that +contains the binding of @scheme[_id] is also enriched so that +@scheme[_id] is @scheme[free-identifier=?] to the target identifier, @scheme[identifier-binding] returns the same results for both -identifiers. Finally, the binding is treated specially by +identifiers, and @scheme[provide] exports @scheme[_id] as the target +identifier. Finally, the binding is treated specially by @scheme[syntax-local-value], and @scheme[syntax-local-make-delta-introducer] as used by @tech{syntax transformer}s. diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 048e56b9ea..e0647da100 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -702,7 +702,13 @@ follows. (define foo 2)) (require 'test) foo - ]} + ] + + If @scheme[id] has a transformer binding to a @tech{rename + transformer}, then the exported binding is the target identifier of + the @tech{rename transformer}, instead of @scheme[id], unless the + target identifier has a true value for the + @scheme['not-free-identifier=?] @tech{syntax property}.} @defsubform[(all-defined-out)]{ Exports all identifiers that are defined at @tech{phase level} 0 or @tech{phase level} 1 within the @@ -2109,14 +2115,19 @@ Equivalent to @scheme[(when (not test-expr) expr ...)]. @defform[(set! id expr)]{ -If @scheme[id] has a @tech{transformer binding} to an -@tech{assignment transformer}, as produced by -@scheme[make-set!-transformer], then this form is expanded by calling -the assignment transformer with the full expressions. If @scheme[id] -has a @tech{transformer binding} to a @tech{rename transformer} as -produced by @scheme[make-rename-transformer], then this form is -expanded by replacing @scheme[id] with the one provided to -@scheme[make-rename-transformer]. +If @scheme[id] has a @tech{transformer binding} to an @tech{assignment +transformer}, as produced by @scheme[make-set!-transformer] or as an +instance of a structure type with the @scheme[prop:set!-transformer] +property, then this form is expanded by calling the assignment +transformer with the full expressions. If @scheme[id] has a +@tech{transformer binding} to a @tech{rename transformer} as produced +by @scheme[make-rename-transformer] or as an instance of a structure +type with the @scheme[prop:rename-transformer] property, then this +form is expanded by replacing @scheme[id] with the target identifier +(e.g., the one provided to @scheme[make-rename-transformer]). If a +transformer binding has both @scheme[prop:set!-transformer] ad +@scheme[prop:rename-transformer] properties, the latter takes +precedence. Otherwise, evaluates @scheme[expr] and installs the result into the location for @scheme[id], which must be bound as a local variable or diff --git a/collects/tests/mzscheme/macro.ss b/collects/tests/mzscheme/macro.ss index 9087be2801..e308ab9b05 100644 --- a/collects/tests/mzscheme/macro.ss +++ b/collects/tests/mzscheme/macro.ss @@ -144,6 +144,32 @@ (set! f 7) x))) +(test 77 'set!-transformer-prop + (let ([x 3]) + (let-syntax ([f (let () + (define-struct s!t (proc) + #:property prop:set!-transformer 0) + (make-s!t + (lambda (stx) + (syntax-case stx () + [(_ __ val) + #'(set! x val)]))))]) + (set! f 77) + x))) + +(test 777 'set!-transformer-prop2 + (let ([x 3]) + (let-syntax ([f (let () + (define-struct s!t () + #:property prop:set!-transformer + (lambda (stx) + (syntax-case stx () + [(_ __ val) + #'(set! x val)]))) + (make-s!t))]) + (set! f 777) + x))) + (test 7 'rename-transformer (let ([x 3]) (let-syntax ([f (make-rename-transformer #'x)]) @@ -431,6 +457,85 @@ (define q 8) (nab h)) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(module rename-transformer-tests scheme/base + (require (for-syntax scheme/base)) + + (define x 12) + (define-syntax bar (let ([x 10]) + (make-rename-transformer #'x))) + (define-syntax foo (make-rename-transformer #'x)) + (list foo + (identifier-binding #'foo) + (free-identifier=? #'x #'foo)) + (identifier-binding #'bar) + + (begin-for-syntax + (define-struct rt (id) + #:property prop:rename-transformer 0 + #:omit-define-syntaxes)) + + (let-syntax ([q (make-rt #'x)]) + (list q + (identifier-binding #'q) + (free-identifier=? #'q #'x))) + + (let ([w 11]) + (letrec-syntax ([q (let () + (define-struct rt () + #:property prop:rename-transformer #'w) + (make-rt))]) + (list q + (identifier-binding #'q) + (free-identifier=? #'q #'w)))) + + (letrec-syntax ([n (make-rename-transformer #'glob)]) + (list (identifier-binding #'n) + (free-identifier=? #'n #'glob))) + + (letrec-syntax ([i (make-rename-transformer #'glob)]) + (letrec-syntax ([n (make-rename-transformer (syntax-property #'i 'not-free-identifier=? #f))]) + (list (identifier-binding #'n) + (free-identifier=? #'n #'glob))))) + +(let ([accum null]) + (parameterize ([current-print (lambda (v) + (set! accum (cons (let loop ([v v]) + (cond + [(module-path-index? v) 'mpi] + [(pair? v) (cons (loop (car v)) + (loop (cdr v)))] + [else v])) + accum)))]) + (dynamic-require ''rename-transformer-tests #f)) + (test '((#f #t) + (#f #t) + (11 lexical #t) + (12 (mpi x mpi x 0 0 0) #t) + lexical + (12 (mpi x mpi x 0 0 0) #t)) + values accum)) + +(module rename-transformer-tests:m scheme/base + (require (for-syntax scheme/base)) + (define-syntax x 1) + (define-syntax x* (make-rename-transformer #'x)) + (define-syntax x** (make-rename-transformer (syntax-property #'x 'not-free-identifier=? #t))) + (define-syntax (get stx) + (syntax-case stx () + [(_ i) + #`#,(free-identifier=? #'i #'x)])) + (provide get x* x**)) + +(module rename-transformer-tests:n scheme + (require 'rename-transformer-tests:m) + (provide go) + (define (go) + (list (get x*) (get x**)))) + +(test '(#t #f) (dynamic-require ''rename-transformer-tests:n 'go)) + ;; ---------------------------------------- (report-errs) diff --git a/src/mzscheme/src/cstartup.inc b/src/mzscheme/src/cstartup.inc index 1f54490d79..2e1ecdac6b 100644 --- a/src/mzscheme/src/cstartup.inc +++ b/src/mzscheme/src/cstartup.inc @@ -1,5 +1,5 @@ { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,50,50,0,0,0,1,0,0,3,0,12,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,50,0,0,0,1,0,0,3,0,12,0, 17,0,20,0,27,0,40,0,47,0,51,0,58,0,63,0,68,0,72,0,78, 0,92,0,106,0,109,0,115,0,119,0,121,0,132,0,134,0,148,0,155,0, 177,0,179,0,193,0,253,0,23,1,32,1,41,1,51,1,87,1,126,1,165, @@ -100,7 +100,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 2045); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,50,59,0,0,0,1,0,0,13,0,18,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,59,0,0,0,1,0,0,13,0,18,0, 35,0,50,0,68,0,84,0,94,0,112,0,132,0,148,0,166,0,197,0,226, 0,248,0,6,1,12,1,26,1,31,1,41,1,49,1,77,1,109,1,154,1, 199,1,223,1,6,2,8,2,65,2,155,3,196,3,31,5,135,5,239,5,100, @@ -132,173 +132,173 @@ 116,101,32,115,116,114,105,110,103,6,36,36,99,97,110,110,111,116,32,97,100, 100,32,97,32,115,117,102,102,105,120,32,116,111,32,97,32,114,111,111,116,32, 112,97,116,104,58,32,5,0,27,20,14,159,80,158,36,50,250,80,158,39,51, -249,22,27,11,80,158,41,50,22,182,12,10,248,22,157,5,23,196,2,28,248, +249,22,27,11,80,158,41,50,22,184,12,10,248,22,157,5,23,196,2,28,248, 22,154,6,23,194,2,12,87,94,248,22,168,8,23,194,1,248,80,159,37,53, 36,195,28,248,22,73,23,195,2,9,27,248,22,66,23,196,2,27,28,248,22, -163,13,23,195,2,23,194,1,28,248,22,162,13,23,195,2,249,22,164,13,23, -196,1,250,80,158,42,48,248,22,178,13,2,19,11,10,250,80,158,40,48,248, -22,178,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,166,13,249, -22,164,13,23,198,1,247,22,179,13,27,248,22,67,23,200,1,28,248,22,73, -23,194,2,9,27,248,22,66,23,195,2,27,28,248,22,163,13,23,195,2,23, -194,1,28,248,22,162,13,23,195,2,249,22,164,13,23,196,1,250,80,158,47, -48,248,22,178,13,2,19,11,10,250,80,158,45,48,248,22,178,13,2,19,23, -197,1,10,28,23,193,2,249,22,65,248,22,166,13,249,22,164,13,23,198,1, -247,22,179,13,248,80,159,45,52,36,248,22,67,23,199,1,87,94,23,193,1, +165,13,23,195,2,23,194,1,28,248,22,164,13,23,195,2,249,22,166,13,23, +196,1,250,80,158,42,48,248,22,180,13,2,19,11,10,250,80,158,40,48,248, +22,180,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,168,13,249, +22,166,13,23,198,1,247,22,181,13,27,248,22,67,23,200,1,28,248,22,73, +23,194,2,9,27,248,22,66,23,195,2,27,28,248,22,165,13,23,195,2,23, +194,1,28,248,22,164,13,23,195,2,249,22,166,13,23,196,1,250,80,158,47, +48,248,22,180,13,2,19,11,10,250,80,158,45,48,248,22,180,13,2,19,23, +197,1,10,28,23,193,2,249,22,65,248,22,168,13,249,22,166,13,23,198,1, +247,22,181,13,248,80,159,45,52,36,248,22,67,23,199,1,87,94,23,193,1, 248,80,159,43,52,36,248,22,67,23,197,1,87,94,23,193,1,27,248,22,67, 23,198,1,28,248,22,73,23,194,2,9,27,248,22,66,23,195,2,27,28,248, -22,163,13,23,195,2,23,194,1,28,248,22,162,13,23,195,2,249,22,164,13, -23,196,1,250,80,158,45,48,248,22,178,13,2,19,11,10,250,80,158,43,48, -248,22,178,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,166,13, -249,22,164,13,23,198,1,247,22,179,13,248,80,159,43,52,36,248,22,67,23, -199,1,248,80,159,41,52,36,248,22,67,196,27,248,22,139,13,23,195,2,28, -23,193,2,192,87,94,23,193,1,28,248,22,159,6,23,195,2,27,248,22,161, -13,195,28,192,192,248,22,162,13,195,11,87,94,28,28,248,22,140,13,23,195, -2,10,27,248,22,139,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28, -248,22,159,6,23,196,2,27,248,22,161,13,23,197,2,28,23,193,2,192,87, -94,23,193,1,248,22,162,13,23,197,2,11,12,250,22,132,9,76,110,111,114, +22,165,13,23,195,2,23,194,1,28,248,22,164,13,23,195,2,249,22,166,13, +23,196,1,250,80,158,45,48,248,22,180,13,2,19,11,10,250,80,158,43,48, +248,22,180,13,2,19,23,197,1,10,28,23,193,2,249,22,65,248,22,168,13, +249,22,166,13,23,198,1,247,22,181,13,248,80,159,43,52,36,248,22,67,23, +199,1,248,80,159,41,52,36,248,22,67,196,27,248,22,141,13,23,195,2,28, +23,193,2,192,87,94,23,193,1,28,248,22,159,6,23,195,2,27,248,22,163, +13,195,28,192,192,248,22,164,13,195,11,87,94,28,28,248,22,142,13,23,195, +2,10,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193,1,28, +248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2,192,87, +94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,76,110,111,114, 109,97,108,45,112,97,116,104,45,99,97,115,101,6,42,42,112,97,116,104,32, 40,102,111,114,32,97,110,121,32,115,121,115,116,101,109,41,32,111,114,32,118, 97,108,105,100,45,112,97,116,104,32,115,116,114,105,110,103,23,197,2,28,28, -248,22,140,13,23,195,2,249,22,164,8,248,22,141,13,23,197,2,2,20,249, +248,22,142,13,23,195,2,249,22,164,8,248,22,143,13,23,197,2,2,20,249, 22,164,8,247,22,178,7,2,20,27,28,248,22,159,6,23,196,2,23,195,2, -248,22,168,7,248,22,144,13,23,197,2,28,249,22,191,13,0,21,35,114,120, +248,22,168,7,248,22,146,13,23,197,2,28,249,22,129,14,0,21,35,114,120, 34,94,91,92,92,93,91,92,92,93,91,63,93,91,92,92,93,34,23,195,2, -28,248,22,159,6,195,248,22,147,13,195,194,27,248,22,134,7,23,195,1,249, -22,148,13,248,22,171,7,250,22,133,14,0,6,35,114,120,34,47,34,28,249, -22,191,13,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47, -92,92,93,42,36,34,23,201,2,23,199,1,250,22,133,14,0,19,35,114,120, +28,248,22,159,6,195,248,22,149,13,195,194,27,248,22,134,7,23,195,1,249, +22,150,13,248,22,171,7,250,22,135,14,0,6,35,114,120,34,47,34,28,249, +22,129,14,0,22,35,114,120,34,91,47,92,92,93,91,46,32,93,43,91,47, +92,92,93,42,36,34,23,201,2,23,199,1,250,22,135,14,0,19,35,114,120, 34,91,32,46,93,43,40,91,47,92,92,93,42,41,36,34,23,202,1,6,2, -2,92,49,80,159,43,36,37,2,20,28,248,22,159,6,194,248,22,147,13,194, -193,87,94,28,27,248,22,139,13,23,196,2,28,23,193,2,192,87,94,23,193, -1,28,248,22,159,6,23,196,2,27,248,22,161,13,23,197,2,28,23,193,2, -192,87,94,23,193,1,248,22,162,13,23,197,2,11,12,250,22,132,9,23,196, -2,2,21,23,197,2,28,248,22,161,13,23,195,2,12,248,22,158,11,249,22, -167,10,248,22,188,6,250,22,143,7,2,22,23,200,1,23,201,1,247,22,23, -87,94,28,27,248,22,139,13,23,196,2,28,23,193,2,192,87,94,23,193,1, -28,248,22,159,6,23,196,2,27,248,22,161,13,23,197,2,28,23,193,2,192, -87,94,23,193,1,248,22,162,13,23,197,2,11,12,250,22,132,9,23,196,2, -2,21,23,197,2,28,248,22,161,13,23,195,2,12,248,22,158,11,249,22,167, +2,92,49,80,159,43,36,37,2,20,28,248,22,159,6,194,248,22,149,13,194, +193,87,94,28,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193, +1,28,248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2, +192,87,94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,23,196, +2,2,21,23,197,2,28,248,22,163,13,23,195,2,12,248,22,160,11,249,22, +169,10,248,22,188,6,250,22,143,7,2,22,23,200,1,23,201,1,247,22,23, +87,94,28,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193,1, +28,248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2,192, +87,94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,23,196,2, +2,21,23,197,2,28,248,22,163,13,23,195,2,12,248,22,160,11,249,22,169, 10,248,22,188,6,250,22,143,7,2,22,23,200,1,23,201,1,247,22,23,87, -94,87,94,28,27,248,22,139,13,23,196,2,28,23,193,2,192,87,94,23,193, -1,28,248,22,159,6,23,196,2,27,248,22,161,13,23,197,2,28,23,193,2, -192,87,94,23,193,1,248,22,162,13,23,197,2,11,12,250,22,132,9,195,2, -21,23,197,2,28,248,22,161,13,23,195,2,12,248,22,158,11,249,22,167,10, +94,87,94,28,27,248,22,141,13,23,196,2,28,23,193,2,192,87,94,23,193, +1,28,248,22,159,6,23,196,2,27,248,22,163,13,23,197,2,28,23,193,2, +192,87,94,23,193,1,248,22,164,13,23,197,2,11,12,250,22,132,9,195,2, +21,23,197,2,28,248,22,163,13,23,195,2,12,248,22,160,11,249,22,169,10, 248,22,188,6,250,22,143,7,2,22,199,23,201,1,247,22,23,249,22,3,89, -162,8,44,36,49,9,223,2,33,33,196,248,22,158,11,249,22,133,11,23,196, +162,8,44,36,49,9,223,2,33,33,196,248,22,160,11,249,22,135,11,23,196, 1,247,22,23,87,94,250,80,159,38,39,36,2,6,196,197,251,80,159,39,41, 36,2,6,32,0,89,162,8,44,36,44,9,222,33,35,197,198,32,37,89,162, 43,41,58,65,99,108,111,111,112,222,33,38,28,248,22,73,23,199,2,87,94, 23,198,1,248,23,196,1,251,22,143,7,2,23,23,199,1,28,248,22,73,23, -203,2,87,94,23,202,1,23,201,1,250,22,1,22,157,13,23,204,1,23,205, -1,23,198,1,27,249,22,157,13,248,22,66,23,202,2,23,199,2,28,248,22, -152,13,23,194,2,27,250,22,1,22,157,13,23,197,1,23,202,2,28,248,22, -152,13,23,194,2,192,87,94,23,193,1,27,248,22,67,23,202,1,28,248,22, +203,2,87,94,23,202,1,23,201,1,250,22,1,22,159,13,23,204,1,23,205, +1,23,198,1,27,249,22,159,13,248,22,66,23,202,2,23,199,2,28,248,22, +154,13,23,194,2,27,250,22,1,22,159,13,23,197,1,23,202,2,28,248,22, +154,13,23,194,2,192,87,94,23,193,1,27,248,22,67,23,202,1,28,248,22, 73,23,194,2,87,94,23,193,1,248,23,199,1,251,22,143,7,2,23,23,202, -1,28,248,22,73,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,157, -13,23,207,1,23,208,1,23,201,1,27,249,22,157,13,248,22,66,23,197,2, -23,202,2,28,248,22,152,13,23,194,2,27,250,22,1,22,157,13,23,197,1, -204,28,248,22,152,13,193,192,253,2,37,203,204,205,206,23,15,248,22,67,201, +1,28,248,22,73,23,206,2,87,94,23,205,1,23,204,1,250,22,1,22,159, +13,23,207,1,23,208,1,23,201,1,27,249,22,159,13,248,22,66,23,197,2, +23,202,2,28,248,22,154,13,23,194,2,27,250,22,1,22,159,13,23,197,1, +204,28,248,22,154,13,193,192,253,2,37,203,204,205,206,23,15,248,22,67,201, 253,2,37,202,203,204,205,206,248,22,67,200,87,94,23,193,1,27,248,22,67, 23,201,1,28,248,22,73,23,194,2,87,94,23,193,1,248,23,198,1,251,22, 143,7,2,23,23,201,1,28,248,22,73,23,205,2,87,94,23,204,1,23,203, -1,250,22,1,22,157,13,23,206,1,23,207,1,23,200,1,27,249,22,157,13, -248,22,66,23,197,2,23,201,2,28,248,22,152,13,23,194,2,27,250,22,1, -22,157,13,23,197,1,203,28,248,22,152,13,193,192,253,2,37,202,203,204,205, -206,248,22,67,201,253,2,37,201,202,203,204,205,248,22,67,200,27,247,22,180, -13,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,140,13,23,194,2, -10,27,248,22,139,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248, -22,159,6,23,195,2,27,248,22,161,13,23,196,2,28,23,193,2,192,87,94, -23,193,1,248,22,162,13,23,196,2,11,12,252,22,132,9,23,200,2,2,24, +1,250,22,1,22,159,13,23,206,1,23,207,1,23,200,1,27,249,22,159,13, +248,22,66,23,197,2,23,201,2,28,248,22,154,13,23,194,2,27,250,22,1, +22,159,13,23,197,1,203,28,248,22,154,13,193,192,253,2,37,202,203,204,205, +206,248,22,67,201,253,2,37,201,202,203,204,205,248,22,67,200,27,247,22,182, +13,253,2,37,198,199,200,201,202,198,87,95,28,28,248,22,142,13,23,194,2, +10,27,248,22,141,13,23,195,2,28,23,193,2,192,87,94,23,193,1,28,248, +22,159,6,23,195,2,27,248,22,163,13,23,196,2,28,23,193,2,192,87,94, +23,193,1,248,22,164,13,23,196,2,11,12,252,22,132,9,23,200,2,2,24, 35,23,198,2,23,199,2,28,28,248,22,159,6,23,195,2,10,248,22,147,7, 23,195,2,87,94,23,194,1,12,252,22,132,9,23,200,2,2,25,36,23,198, -2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,160,13,23,197,2,87, +2,23,199,1,91,159,38,11,90,161,38,35,11,248,22,162,13,23,197,2,87, 94,23,195,1,87,94,28,192,12,250,22,133,9,23,201,1,2,26,23,199,1, -249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,140, -13,23,196,2,10,27,248,22,139,13,23,197,2,28,23,193,2,192,87,94,23, -193,1,28,248,22,159,6,23,197,2,27,248,22,161,13,23,198,2,28,23,193, -2,192,87,94,23,193,1,248,22,162,13,23,198,2,11,12,252,22,132,9,2, +249,22,7,194,195,91,159,37,11,90,161,37,35,11,87,95,28,28,248,22,142, +13,23,196,2,10,27,248,22,141,13,23,197,2,28,23,193,2,192,87,94,23, +193,1,28,248,22,159,6,23,197,2,27,248,22,163,13,23,198,2,28,23,193, +2,192,87,94,23,193,1,248,22,164,13,23,198,2,11,12,252,22,132,9,2, 9,2,24,35,23,200,2,23,201,2,28,28,248,22,159,6,23,197,2,10,248, 22,147,7,23,197,2,12,252,22,132,9,2,9,2,25,36,23,200,2,23,201, -2,91,159,38,11,90,161,38,35,11,248,22,160,13,23,199,2,87,94,23,195, +2,91,159,38,11,90,161,38,35,11,248,22,162,13,23,199,2,87,94,23,195, 1,87,94,28,192,12,250,22,133,9,2,9,2,26,23,201,2,249,22,7,194, -195,27,249,22,149,13,250,22,132,14,0,18,35,114,120,35,34,40,91,46,93, -91,94,46,93,42,124,41,36,34,248,22,145,13,23,201,1,28,248,22,159,6, -23,203,2,249,22,171,7,23,204,1,8,63,23,202,1,28,248,22,140,13,23, -199,2,248,22,141,13,23,199,1,87,94,23,198,1,247,22,142,13,28,248,22, -139,13,194,249,22,157,13,195,194,192,91,159,37,11,90,161,37,35,11,87,95, -28,28,248,22,140,13,23,196,2,10,27,248,22,139,13,23,197,2,28,23,193, -2,192,87,94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,161,13,23, -198,2,28,23,193,2,192,87,94,23,193,1,248,22,162,13,23,198,2,11,12, +195,27,249,22,151,13,250,22,134,14,0,18,35,114,120,35,34,40,91,46,93, +91,94,46,93,42,124,41,36,34,248,22,147,13,23,201,1,28,248,22,159,6, +23,203,2,249,22,171,7,23,204,1,8,63,23,202,1,28,248,22,142,13,23, +199,2,248,22,143,13,23,199,1,87,94,23,198,1,247,22,144,13,28,248,22, +141,13,194,249,22,159,13,195,194,192,91,159,37,11,90,161,37,35,11,87,95, +28,28,248,22,142,13,23,196,2,10,27,248,22,141,13,23,197,2,28,23,193, +2,192,87,94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,163,13,23, +198,2,28,23,193,2,192,87,94,23,193,1,248,22,164,13,23,198,2,11,12, 252,22,132,9,2,10,2,24,35,23,200,2,23,201,2,28,28,248,22,159,6, 23,197,2,10,248,22,147,7,23,197,2,12,252,22,132,9,2,10,2,25,36, -23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,160,13,23,199, +23,200,2,23,201,2,91,159,38,11,90,161,38,35,11,248,22,162,13,23,199, 2,87,94,23,195,1,87,94,28,192,12,250,22,133,9,2,10,2,26,23,201, -2,249,22,7,194,195,27,249,22,149,13,249,22,157,7,250,22,133,14,0,9, -35,114,120,35,34,91,46,93,34,248,22,145,13,23,203,1,6,1,1,95,28, +2,249,22,7,194,195,27,249,22,151,13,249,22,157,7,250,22,135,14,0,9, +35,114,120,35,34,91,46,93,34,248,22,147,13,23,203,1,6,1,1,95,28, 248,22,159,6,23,202,2,249,22,171,7,23,203,1,8,63,23,201,1,28,248, -22,140,13,23,199,2,248,22,141,13,23,199,1,87,94,23,198,1,247,22,142, -13,28,248,22,139,13,194,249,22,157,13,195,194,192,249,247,22,190,4,194,11, -249,80,158,37,46,9,9,249,80,158,37,46,195,9,27,247,22,182,13,249,80, +22,142,13,23,199,2,248,22,143,13,23,199,1,87,94,23,198,1,247,22,144, +13,28,248,22,141,13,194,249,22,159,13,195,194,192,249,247,22,190,4,194,11, +249,80,158,37,46,9,9,249,80,158,37,46,195,9,27,247,22,184,13,249,80, 158,38,47,28,23,195,2,27,248,22,176,7,6,11,11,80,76,84,67,79,76, 76,69,67,84,83,28,192,192,6,0,0,6,0,0,27,28,23,196,1,250,22, -157,13,248,22,178,13,69,97,100,100,111,110,45,100,105,114,247,22,174,7,6, +159,13,248,22,180,13,69,97,100,100,111,110,45,100,105,114,247,22,174,7,6, 8,8,99,111,108,108,101,99,116,115,11,27,248,80,159,41,52,36,250,22,79, -23,203,1,248,22,75,248,22,178,13,72,99,111,108,108,101,99,116,115,45,100, +23,203,1,248,22,75,248,22,180,13,72,99,111,108,108,101,99,116,115,45,100, 105,114,23,204,1,28,23,194,2,249,22,65,23,196,1,23,195,1,192,32,47, -89,162,8,44,38,54,2,18,222,33,48,27,249,22,189,13,23,197,2,23,198, +89,162,8,44,38,54,2,18,222,33,48,27,249,22,191,13,23,197,2,23,198, 2,28,23,193,2,87,94,23,196,1,27,248,22,90,23,195,2,27,27,248,22, -99,23,197,1,27,249,22,189,13,23,201,2,23,196,2,28,23,193,2,87,94, +99,23,197,1,27,249,22,191,13,23,201,2,23,196,2,28,23,193,2,87,94, 23,194,1,27,248,22,90,23,195,2,27,250,2,47,23,203,2,23,204,1,248, 22,99,23,199,1,28,249,22,153,7,23,196,2,2,27,249,22,79,23,202,2, -194,249,22,65,248,22,148,13,23,197,1,23,195,1,87,95,23,199,1,23,193, +194,249,22,65,248,22,150,13,23,197,1,23,195,1,87,95,23,199,1,23,193, 1,28,249,22,153,7,23,196,2,2,27,249,22,79,23,200,2,9,249,22,65, -248,22,148,13,23,197,1,9,28,249,22,153,7,23,196,2,2,27,249,22,79, -197,194,87,94,23,196,1,249,22,65,248,22,148,13,23,197,1,194,87,94,23, +248,22,150,13,23,197,1,9,28,249,22,153,7,23,196,2,2,27,249,22,79, +197,194,87,94,23,196,1,249,22,65,248,22,150,13,23,197,1,194,87,94,23, 193,1,28,249,22,153,7,23,198,2,2,27,249,22,79,195,9,87,94,23,194, -1,249,22,65,248,22,148,13,23,199,1,9,87,95,28,28,248,22,147,7,194, +1,249,22,65,248,22,150,13,23,199,1,9,87,95,28,28,248,22,147,7,194, 10,248,22,159,6,194,12,250,22,132,9,2,13,6,21,21,98,121,116,101,32, 115,116,114,105,110,103,32,111,114,32,115,116,114,105,110,103,196,28,28,248,22, -74,195,249,22,4,22,139,13,196,11,12,250,22,132,9,2,13,6,13,13,108, +74,195,249,22,4,22,141,13,196,11,12,250,22,132,9,2,13,6,13,13,108, 105,115,116,32,111,102,32,112,97,116,104,115,197,250,2,47,197,195,28,248,22, 159,6,197,248,22,170,7,197,196,32,50,89,162,8,44,39,57,2,18,222,33, 53,32,51,89,162,8,44,38,54,70,102,111,117,110,100,45,101,120,101,99,222, -33,52,28,23,193,2,91,159,38,11,90,161,38,35,11,248,22,160,13,23,199, -2,87,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,165,13,23,201, -2,28,249,22,166,8,23,195,2,23,202,2,11,28,248,22,161,13,23,194,2, -250,2,51,23,201,2,23,202,2,249,22,157,13,23,200,2,23,198,1,250,2, +33,52,28,23,193,2,91,159,38,11,90,161,38,35,11,248,22,162,13,23,199, +2,87,95,23,195,1,23,194,1,27,28,23,198,2,27,248,22,167,13,23,201, +2,28,249,22,166,8,23,195,2,23,202,2,11,28,248,22,163,13,23,194,2, +250,2,51,23,201,2,23,202,2,249,22,159,13,23,200,2,23,198,1,250,2, 51,23,201,2,23,202,2,23,196,1,11,28,23,193,2,192,87,94,23,193,1, -27,28,248,22,139,13,23,196,2,27,249,22,157,13,23,198,2,23,201,2,28, -28,248,22,152,13,193,10,248,22,151,13,193,192,11,11,28,23,193,2,192,87, -94,23,193,1,28,23,199,2,11,27,248,22,165,13,23,202,2,28,249,22,166, -8,23,195,2,23,203,1,11,28,248,22,161,13,23,194,2,250,2,51,23,202, -1,23,203,1,249,22,157,13,23,201,1,23,198,1,250,2,51,201,202,195,194, -28,248,22,73,23,197,2,11,27,248,22,164,13,248,22,66,23,199,2,27,249, -22,157,13,23,196,1,23,197,2,28,248,22,151,13,23,194,2,250,2,51,198, +27,28,248,22,141,13,23,196,2,27,249,22,159,13,23,198,2,23,201,2,28, +28,248,22,154,13,193,10,248,22,153,13,193,192,11,11,28,23,193,2,192,87, +94,23,193,1,28,23,199,2,11,27,248,22,167,13,23,202,2,28,249,22,166, +8,23,195,2,23,203,1,11,28,248,22,163,13,23,194,2,250,2,51,23,202, +1,23,203,1,249,22,159,13,23,201,1,23,198,1,250,2,51,201,202,195,194, +28,248,22,73,23,197,2,11,27,248,22,166,13,248,22,66,23,199,2,27,249, +22,159,13,23,196,1,23,197,2,28,248,22,153,13,23,194,2,250,2,51,198, 199,195,87,94,23,193,1,27,248,22,67,23,200,1,28,248,22,73,23,194,2, -11,27,248,22,164,13,248,22,66,23,196,2,27,249,22,157,13,23,196,1,23, -200,2,28,248,22,151,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1, -27,248,22,67,23,197,1,28,248,22,73,23,194,2,11,27,248,22,164,13,248, -22,66,195,27,249,22,157,13,23,196,1,202,28,248,22,151,13,193,250,2,51, -204,205,195,251,2,50,204,205,206,248,22,67,199,87,95,28,27,248,22,139,13, +11,27,248,22,166,13,248,22,66,23,196,2,27,249,22,159,13,23,196,1,23, +200,2,28,248,22,153,13,23,194,2,250,2,51,201,202,195,87,94,23,193,1, +27,248,22,67,23,197,1,28,248,22,73,23,194,2,11,27,248,22,166,13,248, +22,66,195,27,249,22,159,13,23,196,1,202,28,248,22,153,13,193,250,2,51, +204,205,195,251,2,50,204,205,206,248,22,67,199,87,95,28,27,248,22,141,13, 23,196,2,28,23,193,2,192,87,94,23,193,1,28,248,22,159,6,23,196,2, -27,248,22,161,13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,162, +27,248,22,163,13,23,197,2,28,23,193,2,192,87,94,23,193,1,248,22,164, 13,23,197,2,11,12,250,22,132,9,2,14,6,25,25,112,97,116,104,32,111, 114,32,115,116,114,105,110,103,32,40,115,97,110,115,32,110,117,108,41,23,197, -2,28,28,23,195,2,28,27,248,22,139,13,23,197,2,28,23,193,2,192,87, -94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,161,13,23,198,2,28, -23,193,2,192,87,94,23,193,1,248,22,162,13,23,198,2,11,248,22,161,13, +2,28,28,23,195,2,28,27,248,22,141,13,23,197,2,28,23,193,2,192,87, +94,23,193,1,28,248,22,159,6,23,197,2,27,248,22,163,13,23,198,2,28, +23,193,2,192,87,94,23,193,1,248,22,164,13,23,198,2,11,248,22,163,13, 23,196,2,11,10,12,250,22,132,9,2,14,6,29,29,35,102,32,111,114,32, 114,101,108,97,116,105,118,101,32,112,97,116,104,32,111,114,32,115,116,114,105, -110,103,23,198,2,28,28,248,22,161,13,23,195,2,91,159,38,11,90,161,38, -35,11,248,22,160,13,23,198,2,249,22,164,8,194,68,114,101,108,97,116,105, +110,103,23,198,2,28,28,248,22,163,13,23,195,2,91,159,38,11,90,161,38, +35,11,248,22,162,13,23,198,2,249,22,164,8,194,68,114,101,108,97,116,105, 118,101,11,27,248,22,176,7,6,4,4,80,65,84,72,251,2,50,23,199,1, 23,200,1,23,201,1,28,23,197,2,27,249,80,159,43,47,37,23,200,1,9, -28,249,22,164,8,247,22,178,7,2,20,249,22,65,248,22,148,13,5,1,46, -23,195,1,192,9,27,248,22,164,13,23,196,1,28,248,22,151,13,193,250,2, +28,249,22,164,8,247,22,178,7,2,20,249,22,65,248,22,150,13,5,1,46, +23,195,1,192,9,27,248,22,166,13,23,196,1,28,248,22,153,13,193,250,2, 51,198,199,195,11,250,80,158,38,48,196,197,11,250,80,158,38,48,196,11,11, 87,94,249,22,150,6,247,22,186,4,195,248,22,176,5,249,22,172,3,35,249, 22,156,3,197,198,27,28,23,197,2,87,95,23,196,1,23,195,1,23,197,1, -87,94,23,197,1,27,248,22,178,13,2,19,27,249,80,159,40,48,37,23,196, +87,94,23,197,1,27,248,22,180,13,2,19,27,249,80,159,40,48,37,23,196, 1,11,27,27,248,22,175,3,23,200,1,28,192,192,35,27,27,248,22,175,3, 23,202,1,28,192,192,35,249,22,153,5,23,197,1,83,158,39,20,97,95,89, 162,8,44,35,47,9,224,3,2,33,57,23,195,1,23,196,1,27,248,22,138, @@ -330,7 +330,7 @@ 36,43,2,11,222,33,43,80,159,35,45,36,83,158,35,16,2,83,158,38,20, 96,96,2,12,89,162,43,35,43,9,223,0,33,44,89,162,43,36,44,9,223, 0,33,45,89,162,43,37,54,9,223,0,33,46,80,159,35,46,36,83,158,35, -16,2,27,248,22,185,13,248,22,170,7,27,28,249,22,164,8,247,22,178,7, +16,2,27,248,22,187,13,248,22,170,7,27,28,249,22,164,8,247,22,178,7, 2,20,6,1,1,59,6,1,1,58,250,22,143,7,6,14,14,40,91,94,126, 97,93,42,41,126,97,40,46,42,41,23,196,2,23,196,1,89,162,8,44,37, 47,2,13,223,0,33,49,80,159,35,47,36,83,158,35,16,2,83,158,38,20, @@ -342,7 +342,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 5009); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,50,8,0,0,0,1,0,0,6,0,19,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,8,0,0,0,1,0,0,6,0,19,0, 34,0,48,0,62,0,76,0,111,0,0,0,1,1,0,0,65,113,117,111,116, 101,29,94,2,1,67,35,37,117,116,105,108,115,11,29,94,2,1,69,35,37, 110,101,116,119,111,114,107,11,29,94,2,1,68,35,37,112,97,114,97,109,122, @@ -360,7 +360,7 @@ EVAL_ONE_SIZED_STR((char *)expr, 294); } { - static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,50,52,0,0,0,1,0,0,11,0,38,0, + static MZCOMPILED_STRING_FAR unsigned char expr[] = {35,126,7,52,46,49,46,53,46,51,52,0,0,0,1,0,0,11,0,38,0, 44,0,57,0,71,0,93,0,119,0,131,0,149,0,169,0,181,0,197,0,220, 0,0,1,5,1,10,1,15,1,24,1,29,1,60,1,64,1,72,1,81,1, 89,1,192,1,237,1,1,2,30,2,61,2,117,2,127,2,174,2,184,2,191, @@ -384,30 +384,30 @@ 63,108,105,98,67,105,103,110,111,114,101,100,249,22,14,195,80,159,37,45,37, 249,80,159,37,48,36,195,10,27,28,23,195,2,28,249,22,164,8,23,197,2, 80,158,38,46,87,94,23,195,1,80,158,36,47,27,248,22,173,4,23,197,2, -28,248,22,139,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,160,13, +28,248,22,141,13,23,194,2,91,159,38,11,90,161,38,35,11,248,22,162,13, 23,197,1,87,95,83,160,37,11,80,158,40,46,198,83,160,37,11,80,158,40, 47,192,192,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,191,4,28, -192,192,247,22,179,13,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27, -11,80,158,40,39,22,191,4,28,248,22,139,13,23,198,2,23,197,1,87,94, -23,197,1,247,22,179,13,247,194,250,22,157,13,23,197,1,23,199,1,249,80, -158,42,38,23,198,1,2,17,252,22,157,13,23,199,1,23,201,1,2,18,247, +192,192,247,22,181,13,20,14,159,80,158,35,39,250,80,158,38,40,249,22,27, +11,80,158,40,39,22,191,4,28,248,22,141,13,23,198,2,23,197,1,87,94, +23,197,1,247,22,181,13,247,194,250,22,159,13,23,197,1,23,199,1,249,80, +158,42,38,23,198,1,2,17,252,22,159,13,23,199,1,23,201,1,2,18,247, 22,179,7,249,80,158,44,38,23,200,1,80,159,44,35,37,87,94,23,194,1, -27,250,22,174,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249, -22,65,195,194,11,27,252,22,157,13,23,200,1,23,202,1,2,18,247,22,179, -7,249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,174,13,196,11, +27,250,22,176,13,196,11,32,0,89,162,8,44,35,40,9,222,11,28,192,249, +22,65,195,194,11,27,252,22,159,13,23,200,1,23,202,1,2,18,247,22,179, +7,249,80,158,45,38,23,201,1,80,159,45,35,37,27,250,22,176,13,196,11, 32,0,89,162,8,44,35,40,9,222,11,28,192,249,22,65,195,194,11,249,247, -22,184,13,248,22,66,195,195,27,250,22,157,13,23,198,1,23,200,1,249,80, -158,43,38,23,199,1,2,17,27,250,22,174,13,196,11,32,0,89,162,8,44, +22,186,13,248,22,66,195,195,27,250,22,159,13,23,198,1,23,200,1,249,80, +158,43,38,23,199,1,2,17,27,250,22,176,13,196,11,32,0,89,162,8,44, 35,40,9,222,11,28,192,249,22,65,195,194,11,249,247,22,189,4,248,22,66, 195,195,249,247,22,189,4,194,195,87,94,28,248,80,158,36,37,23,195,2,12, 250,22,132,9,77,108,111,97,100,47,117,115,101,45,99,111,109,112,105,108,101, 100,6,25,25,112,97,116,104,32,111,114,32,118,97,108,105,100,45,112,97,116, 104,32,115,116,114,105,110,103,23,197,2,91,159,41,11,90,161,36,35,11,28, -248,22,163,13,23,201,2,23,200,1,27,247,22,191,4,28,23,193,2,249,22, -164,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,160,13,23,194,2, +248,22,165,13,23,201,2,23,200,1,27,247,22,191,4,28,23,193,2,249,22, +166,13,23,203,1,23,195,1,200,90,161,38,36,11,248,22,162,13,23,194,2, 87,94,23,196,1,90,161,36,39,11,28,249,22,164,8,23,196,2,68,114,101, 108,97,116,105,118,101,87,94,23,194,1,2,16,23,194,1,90,161,36,40,11, -247,22,181,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,27,27,89, +247,22,183,13,27,89,162,43,36,49,62,122,111,225,7,5,3,33,27,27,89, 162,43,36,51,9,225,8,6,4,33,28,27,249,22,5,89,162,8,44,36,46, 9,223,5,33,29,23,203,2,27,28,23,195,1,27,249,22,5,89,162,8,44, 36,52,9,225,13,11,9,33,30,23,205,2,27,28,23,196,2,11,193,28,192, @@ -420,10 +420,10 @@ 203,89,162,43,35,45,9,224,15,2,33,33,249,80,159,48,54,36,203,89,162, 43,35,44,9,224,15,7,33,34,32,36,89,162,8,44,36,54,2,19,222,33, 38,0,17,35,114,120,34,94,40,46,42,63,41,47,40,46,42,41,36,34,27, -249,22,189,13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,65, -248,22,90,23,196,2,27,248,22,99,23,197,1,27,249,22,189,13,2,37,23, +249,22,191,13,2,37,23,196,2,28,23,193,2,87,94,23,194,1,249,22,65, +248,22,90,23,196,2,27,248,22,99,23,197,1,27,249,22,191,13,2,37,23, 196,2,28,23,193,2,87,94,23,194,1,249,22,65,248,22,90,23,196,2,27, -248,22,99,23,197,1,27,249,22,189,13,2,37,23,196,2,28,23,193,2,87, +248,22,99,23,197,1,27,249,22,191,13,2,37,23,196,2,28,23,193,2,87, 94,23,194,1,249,22,65,248,22,90,23,196,2,248,2,36,248,22,99,23,197, 1,248,22,75,194,248,22,75,194,248,22,75,194,32,39,89,162,43,36,54,2, 19,222,33,40,28,248,22,73,248,22,67,23,195,2,249,22,7,9,248,22,66, @@ -437,19 +437,19 @@ 39,193,87,95,28,248,22,171,4,195,12,250,22,132,9,2,20,6,20,20,114, 101,115,111,108,118,101,100,45,109,111,100,117,108,101,45,112,97,116,104,197,28, 24,193,2,248,24,194,1,195,87,94,23,193,1,12,27,27,250,22,139,2,80, -159,41,42,37,248,22,145,14,247,22,186,11,11,28,23,193,2,192,87,94,23, -193,1,27,247,22,123,87,94,250,22,137,2,80,159,42,42,37,248,22,145,14, -247,22,186,11,195,192,250,22,137,2,195,198,66,97,116,116,97,99,104,251,211, +159,41,42,37,248,22,147,14,247,22,188,11,11,28,23,193,2,192,87,94,23, +193,1,27,247,22,123,87,94,250,22,137,2,80,159,42,42,37,248,22,147,14, +247,22,188,11,195,192,250,22,137,2,195,198,66,97,116,116,97,99,104,251,211, 197,198,199,10,28,192,250,22,131,9,11,196,195,248,22,129,9,194,28,249,22, 165,6,194,6,1,1,46,2,16,28,249,22,165,6,194,6,2,2,46,46,62, 117,112,192,28,249,22,166,8,248,22,67,23,200,2,23,197,1,28,249,22,164, 8,248,22,66,23,200,2,23,196,1,251,22,129,9,2,20,6,26,26,99,121, 99,108,101,32,105,110,32,108,111,97,100,105,110,103,32,97,116,32,126,101,58, 32,126,101,23,200,1,249,22,2,22,67,248,22,80,249,22,65,23,206,1,23, -202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,65,248,22,145,14, -247,22,186,11,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40,249,22, +202,1,12,12,247,192,20,14,159,80,159,39,44,37,249,22,65,248,22,147,14, +247,22,188,11,23,197,1,20,14,159,80,158,39,39,250,80,158,42,40,249,22, 27,11,80,158,44,39,22,153,4,23,196,1,249,247,22,190,4,23,198,1,248, -22,54,248,22,143,13,23,198,1,87,94,28,28,248,22,139,13,23,197,2,10, +22,54,248,22,145,13,23,198,1,87,94,28,28,248,22,141,13,23,197,2,10, 248,22,177,4,23,197,2,12,28,23,198,2,250,22,131,9,11,6,15,15,98, 97,100,32,109,111,100,117,108,101,32,112,97,116,104,23,201,2,250,22,132,9, 2,20,6,19,19,109,111,100,117,108,101,45,112,97,116,104,32,111,114,32,112, @@ -457,74 +457,74 @@ 23,199,2,2,3,11,248,22,172,4,248,22,90,197,28,28,248,22,63,23,197, 2,249,22,164,8,248,22,66,23,199,2,66,112,108,97,110,101,116,11,87,94, 28,207,12,20,14,159,80,158,37,39,250,80,158,40,40,249,22,27,11,80,158, -42,39,22,186,11,23,197,1,90,161,36,35,10,249,22,154,4,21,94,2,21, +42,39,22,188,11,23,197,1,90,161,36,35,10,249,22,154,4,21,94,2,21, 6,18,18,112,108,97,110,101,116,47,114,101,115,111,108,118,101,114,46,115,115, 1,27,112,108,97,110,101,116,45,109,111,100,117,108,101,45,110,97,109,101,45, 114,101,115,111,108,118,101,114,12,251,211,199,200,201,202,87,94,23,193,1,27, 89,162,8,44,36,45,79,115,104,111,119,45,99,111,108,108,101,99,116,105,111, 110,45,101,114,114,223,6,33,44,27,28,248,22,53,23,199,2,27,250,22,139, -2,80,159,43,43,37,249,22,65,23,204,2,247,22,180,13,11,28,23,193,2, +2,80,159,43,43,37,249,22,65,23,204,2,247,22,182,13,11,28,23,193,2, 192,87,94,23,193,1,91,159,37,11,90,161,37,35,11,249,80,159,44,48,36, 248,22,56,23,204,2,11,27,251,80,158,47,50,2,20,23,202,1,28,248,22, 73,23,199,2,23,199,2,248,22,66,23,199,2,28,248,22,73,23,199,2,9, -248,22,67,23,199,2,249,22,157,13,23,195,1,28,248,22,73,23,197,1,87, +248,22,67,23,199,2,249,22,159,13,23,195,1,28,248,22,73,23,197,1,87, 94,23,197,1,6,7,7,109,97,105,110,46,115,115,249,22,182,6,23,199,1, 6,3,3,46,115,115,28,248,22,159,6,23,199,2,87,94,23,194,1,27,248, 80,159,41,55,36,23,201,2,27,250,22,139,2,80,159,44,43,37,249,22,65, 23,205,2,23,199,2,11,28,23,193,2,192,87,94,23,193,1,91,159,37,11, -90,161,37,35,11,249,80,159,45,48,36,23,204,2,11,250,22,1,22,157,13, +90,161,37,35,11,249,80,159,45,48,36,23,204,2,11,250,22,1,22,159,13, 23,199,1,249,22,79,249,22,2,32,0,89,162,8,44,36,43,9,222,33,45, -23,200,1,248,22,75,23,200,1,28,248,22,139,13,23,199,2,87,94,23,194, -1,28,248,22,162,13,23,199,2,23,198,2,248,22,75,6,26,26,32,40,97, +23,200,1,248,22,75,23,200,1,28,248,22,141,13,23,199,2,87,94,23,194, +1,28,248,22,164,13,23,199,2,23,198,2,248,22,75,6,26,26,32,40,97, 32,112,97,116,104,32,109,117,115,116,32,98,101,32,97,98,115,111,108,117,116, 101,41,28,249,22,164,8,248,22,66,23,201,2,2,21,27,250,22,139,2,80, -159,43,43,37,249,22,65,23,204,2,247,22,180,13,11,28,23,193,2,192,87, +159,43,43,37,249,22,65,23,204,2,247,22,182,13,11,28,23,193,2,192,87, 94,23,193,1,91,159,38,11,90,161,37,35,11,249,80,159,45,48,36,248,22, 90,23,205,2,11,90,161,36,37,11,28,248,22,73,248,22,92,23,204,2,28, -248,22,73,23,194,2,249,22,191,13,0,8,35,114,120,34,91,46,93,34,23, +248,22,73,23,194,2,249,22,129,14,0,8,35,114,120,34,91,46,93,34,23, 196,2,11,10,27,27,28,23,197,2,249,22,79,28,248,22,73,248,22,92,23, 208,2,21,93,6,5,5,109,122,108,105,98,249,22,1,22,79,249,22,2,80, 159,51,56,36,248,22,92,23,211,2,23,197,2,28,248,22,73,23,196,2,248, 22,75,23,197,2,23,195,2,251,80,158,49,50,2,20,23,204,1,248,22,66, -23,198,2,248,22,67,23,198,1,249,22,157,13,23,195,1,28,23,198,1,87, +23,198,2,248,22,67,23,198,1,249,22,159,13,23,195,1,28,23,198,1,87, 94,23,196,1,23,197,1,28,248,22,73,23,197,1,87,94,23,197,1,6,7, -7,109,97,105,110,46,115,115,28,249,22,191,13,0,8,35,114,120,34,91,46, +7,109,97,105,110,46,115,115,28,249,22,129,14,0,8,35,114,120,34,91,46, 93,34,23,199,2,23,197,1,249,22,182,6,23,199,1,6,3,3,46,115,115, -28,249,22,164,8,248,22,66,23,201,2,64,102,105,108,101,249,22,164,13,248, -22,168,13,248,22,90,23,202,2,248,80,159,42,55,36,23,202,2,12,87,94, -28,28,248,22,139,13,23,194,2,10,248,22,181,7,23,194,2,87,94,23,200, +28,249,22,164,8,248,22,66,23,201,2,64,102,105,108,101,249,22,166,13,248, +22,170,13,248,22,90,23,202,2,248,80,159,42,55,36,23,202,2,12,87,94, +28,28,248,22,141,13,23,194,2,10,248,22,181,7,23,194,2,87,94,23,200, 1,12,28,23,200,2,250,22,131,9,67,114,101,113,117,105,114,101,249,22,143, 7,6,17,17,98,97,100,32,109,111,100,117,108,101,32,112,97,116,104,126,97, 28,23,198,2,248,22,66,23,199,2,6,0,0,23,203,1,87,94,23,200,1, 250,22,132,9,2,20,249,22,143,7,6,13,13,109,111,100,117,108,101,32,112, 97,116,104,126,97,28,23,198,2,248,22,66,23,199,2,6,0,0,23,201,2, -27,28,248,22,181,7,23,195,2,249,22,186,7,23,196,2,35,249,22,166,13, -248,22,167,13,23,197,2,11,27,28,248,22,181,7,23,196,2,249,22,186,7, +27,28,248,22,181,7,23,195,2,249,22,186,7,23,196,2,35,249,22,168,13, +248,22,169,13,23,197,2,11,27,28,248,22,181,7,23,196,2,249,22,186,7, 23,197,2,36,248,80,158,42,51,23,195,2,91,159,38,11,90,161,38,35,11, 28,248,22,181,7,23,199,2,250,22,7,2,22,249,22,186,7,23,203,2,37, -2,22,248,22,160,13,23,198,2,87,95,23,195,1,23,193,1,27,28,248,22, +2,22,248,22,162,13,23,198,2,87,95,23,195,1,23,193,1,27,28,248,22, 181,7,23,200,2,249,22,186,7,23,201,2,38,249,80,158,47,52,23,197,2, 5,0,27,28,248,22,181,7,23,201,2,249,22,186,7,23,202,2,39,248,22, -172,4,23,200,2,27,27,250,22,139,2,80,159,51,42,37,248,22,145,14,247, -22,186,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,123,87,94,250, -22,137,2,80,159,52,42,37,248,22,145,14,247,22,186,11,195,192,87,95,28, +172,4,23,200,2,27,27,250,22,139,2,80,159,51,42,37,248,22,147,14,247, +22,188,11,11,28,23,193,2,192,87,94,23,193,1,27,247,22,123,87,94,250, +22,137,2,80,159,52,42,37,248,22,147,14,247,22,188,11,195,192,87,95,28, 23,209,1,27,250,22,139,2,23,197,2,197,11,28,23,193,1,12,87,95,27, 27,28,248,22,17,80,159,51,45,37,80,159,50,45,37,247,22,19,250,22,25, -248,22,23,23,197,2,80,159,53,44,37,23,196,1,27,248,22,145,14,247,22, -186,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54,9,226,12,11, +248,22,23,23,197,2,80,159,53,44,37,23,196,1,27,248,22,147,14,247,22, +188,11,249,22,3,83,158,39,20,97,94,89,162,8,44,36,54,9,226,12,11, 2,3,33,46,23,195,1,23,196,1,248,28,248,22,17,80,159,50,45,37,32, 0,89,162,43,36,41,9,222,33,47,80,159,49,57,36,89,162,43,35,50,9, 227,14,9,8,4,3,33,48,250,22,137,2,23,197,1,197,10,12,28,28,248, 22,181,7,23,202,1,11,27,248,22,159,6,23,208,2,28,192,192,28,248,22, 63,23,208,2,249,22,164,8,248,22,66,23,210,2,2,21,11,250,22,137,2, 80,159,50,43,37,28,248,22,159,6,23,210,2,249,22,65,23,211,1,248,80, -159,53,55,36,23,213,1,87,94,23,210,1,249,22,65,23,211,1,247,22,180, +159,53,55,36,23,213,1,87,94,23,210,1,249,22,65,23,211,1,247,22,182, 13,252,22,183,7,23,208,1,23,207,1,23,205,1,23,203,1,201,12,193,91, 159,37,10,90,161,36,35,10,11,90,161,36,36,10,83,158,38,20,96,96,2, 20,89,162,8,44,36,50,9,224,2,0,33,42,89,162,43,38,48,9,223,1, 33,43,89,162,43,39,8,30,9,225,2,3,0,33,49,208,87,95,248,22,152, -4,248,80,159,37,49,37,247,22,186,11,248,22,190,4,80,159,36,36,37,248, -22,177,12,80,159,36,41,36,159,35,20,103,159,35,16,1,11,16,0,83,158, +4,248,80,159,37,49,37,247,22,188,11,248,22,190,4,80,159,36,36,37,248, +22,179,12,80,159,36,41,36,159,35,20,103,159,35,16,1,11,16,0,83,158, 41,20,100,143,66,35,37,98,111,111,116,29,11,11,11,11,10,10,36,80,158, 35,35,20,103,159,39,16,19,2,1,2,2,30,2,4,72,112,97,116,104,45, 115,116,114,105,110,103,63,10,30,2,4,75,112,97,116,104,45,97,100,100,45, diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 645e0aabe7..42999c5960 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -92,6 +92,7 @@ static Scheme_Object *variable_top_level_namespace(int, Scheme_Object *[]); static Scheme_Object *variable_phase(int, Scheme_Object *[]); static Scheme_Object *now_transforming(int argc, Scheme_Object *argv[]); static Scheme_Object *local_exp_time_value(int argc, Scheme_Object *argv[]); +static Scheme_Object *local_exp_time_value_one(int argc, Scheme_Object *argv[]); static Scheme_Object *local_exp_time_name(int argc, Scheme_Object *argv[]); static Scheme_Object *local_context(int argc, Scheme_Object *argv[]); static Scheme_Object *local_phase_level(int argc, Scheme_Object *argv[]); @@ -522,6 +523,7 @@ static void make_kernel_env(void) GLOBAL_PRIM_W_ARITY("syntax-transforming?", now_transforming, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-value", local_exp_time_value, 1, 3, env); + GLOBAL_PRIM_W_ARITY("syntax-local-value/immediate", local_exp_time_value_one, 1, 3, env); GLOBAL_PRIM_W_ARITY("syntax-local-name", local_exp_time_name, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-context", local_context, 0, 0, env); GLOBAL_PRIM_W_ARITY("syntax-local-phase-level", local_phase_level, 0, 0, env); @@ -1179,9 +1181,9 @@ void scheme_shadow(Scheme_Env *env, Scheme_Object *n, int stxtoo) v = scheme_lookup_in_table(env->syntax, (const char *)n); if (v) { v = SCHEME_PTR_VAL(v); - if (SAME_TYPE(SCHEME_TYPE(v), scheme_id_macro_type)) { + if (scheme_is_binding_rename_transformer(v)) { scheme_install_free_id_rename(n, - SCHEME_PTR1_VAL(v), + scheme_rename_transformer_id(v), rn, scheme_make_integer(env->phase)); } @@ -4169,9 +4171,9 @@ now_transforming(int argc, Scheme_Object *argv[]) } static Scheme_Object * -local_exp_time_value(int argc, Scheme_Object *argv[]) +do_local_exp_time_value(const char *name, int argc, Scheme_Object *argv[], int recur) { - Scheme_Object *v, *sym; + Scheme_Object *v, *sym, *a[2]; Scheme_Env *menv; Scheme_Comp_Env *env; int renamed = 0; @@ -4179,24 +4181,26 @@ local_exp_time_value(int argc, Scheme_Object *argv[]) env = scheme_current_thread->current_local_env; if (!env) scheme_raise_exn(MZEXN_FAIL_CONTRACT, - "syntax-local-value: not currently transforming"); + "%s: not currently transforming", + name); sym = argv[0]; if (!(SCHEME_STXP(sym) && SCHEME_SYMBOLP(SCHEME_STX_VAL(sym)))) - scheme_wrong_type("syntax-local-value", "syntax identifier", 0, argc, argv); + scheme_wrong_type(name, "syntax identifier", 0, argc, argv); if (argc > 1) { - scheme_check_proc_arity2("syntax-local-value", 0, 1, argc, argv, 1); + scheme_check_proc_arity2(name, 0, 1, argc, argv, 1); if ((argc > 2) && SCHEME_TRUEP(argv[2])) { Scheme_Comp_Env *stx_env; if (!SAME_TYPE(scheme_intdef_context_type, SCHEME_TYPE(argv[2]))) - scheme_wrong_type("syntax-local-value", "internal-definition context or #f", 2, argc, argv); + scheme_wrong_type(name, "internal-definition context or #f", 2, argc, argv); stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[2]); if (!scheme_is_sub_env(stx_env, env)) { - scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-value: transforming context does " - "not match given internal-definition context"); + scheme_raise_exn(MZEXN_FAIL_CONTRACT, "%s: transforming context does " + "not match given internal-definition context", + name); } env = stx_env; } @@ -4227,7 +4231,7 @@ local_exp_time_value(int argc, Scheme_Object *argv[]) if ((argc > 1) && SCHEME_TRUEP(argv[1])) return _scheme_tail_apply(argv[1], 0, NULL); else - scheme_arg_mismatch("syntax-local-value", + scheme_arg_mismatch(name, (renamed ? "not defined as syntax (after renaming): " : "not defined as syntax: "), @@ -4235,17 +4239,38 @@ local_exp_time_value(int argc, Scheme_Object *argv[]) } v = SCHEME_PTR_VAL(v); - if (SAME_TYPE(SCHEME_TYPE(v), scheme_id_macro_type)) { - sym = SCHEME_PTR1_VAL(v); + if (scheme_is_rename_transformer(v)) { + sym = scheme_rename_transformer_id(v); sym = scheme_stx_cert(sym, scheme_false, menv, sym, NULL, 1); renamed = 1; menv = NULL; SCHEME_USE_FUEL(1); + if (!recur) { + a[0] = v; + a[1] = sym; + return scheme_values(2, a); + } + } else if (!recur) { + a[0] = v; + a[1] = scheme_false; + return scheme_values(2, a); } else return v; } } +static Scheme_Object * +local_exp_time_value(int argc, Scheme_Object *argv[]) +{ + return do_local_exp_time_value("syntax-local-value", argc, argv, 1); +} + +static Scheme_Object * +local_exp_time_value_one(int argc, Scheme_Object *argv[]) +{ + return do_local_exp_time_value("syntax-local-value/immediate", argc, argv, 0); +} + static Scheme_Object * local_exp_time_name(int argc, Scheme_Object *argv[]) { @@ -4675,10 +4700,10 @@ local_make_delta_introduce(int argc, Scheme_Object *argv[]) introducers = scheme_make_pair(introducer, introducers); v = SCHEME_PTR_VAL(v); - if (SAME_TYPE(SCHEME_TYPE(v), scheme_id_macro_type)) { + if (scheme_is_rename_transformer(v)) { certs = scheme_stx_extract_certs(sym, certs); - sym = SCHEME_PTR1_VAL(v); + sym = scheme_rename_transformer_id(v); sym = scheme_stx_activate_certs(sym); v = SCHEME_PTR2_VAL(v); @@ -5039,7 +5064,7 @@ make_set_transformer(int argc, Scheme_Object *argv[]) static Scheme_Object * set_transformer_p(int argc, Scheme_Object *argv[]) { - return ((SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_set_macro_type)) + return (scheme_is_set_transformer(argv[0]) ? scheme_true : scheme_false); } @@ -5047,10 +5072,10 @@ set_transformer_p(int argc, Scheme_Object *argv[]) static Scheme_Object * set_transformer_proc(int argc, Scheme_Object *argv[]) { - if (!(SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_set_macro_type))) + if (!scheme_is_set_transformer(argv[0])) scheme_wrong_type("set!-transformer-procedure", "set!-transformer", 1, argc, argv); - return SCHEME_PTR_VAL(argv[0]); + return scheme_set_transformer_proc(argv[0]); } static Scheme_Object * @@ -5075,16 +5100,16 @@ make_rename_transformer(int argc, Scheme_Object *argv[]) static Scheme_Object * rename_transformer_target(int argc, Scheme_Object *argv[]) { - if (!SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_id_macro_type)) + if (!scheme_is_rename_transformer(argv[0])) scheme_wrong_type("rename-transformer-target", "rename transformer", 0, argc, argv); - return SCHEME_PTR_VAL(argv[0]); + return scheme_rename_transformer_id(argv[0]); } static Scheme_Object * rename_transformer_p(int argc, Scheme_Object *argv[]) { - return ((SAME_TYPE(SCHEME_TYPE(argv[0]), scheme_id_macro_type)) + return (scheme_is_rename_transformer(argv[0]) ? scheme_true : scheme_false); } diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 5727de38cd..dcb3562b7a 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -5204,9 +5204,10 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first, SCHEME_EXPAND_OBSERVE_EXIT_CHECK(rec[drec].observer, first); return first; } else if (SAME_TYPE(SCHEME_TYPE(val), scheme_macro_type)) { - if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(val)), scheme_id_macro_type)) { + if (scheme_is_rename_transformer(SCHEME_PTR_VAL(val))) { /* It's a rename. Look up the target name and try again. */ - name = scheme_stx_cert(SCHEME_PTR_VAL(SCHEME_PTR_VAL(val)), scheme_false, menv, name, NULL, 1); + name = scheme_stx_cert(scheme_rename_transformer_id(SCHEME_PTR_VAL(val)), + scheme_false, menv, name, NULL, 1); menv = NULL; SCHEME_USE_FUEL(1); } else { @@ -5247,7 +5248,7 @@ compile_expand_macro_app(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *m xformer = (Scheme_Object *)SCHEME_PTR_VAL(macro); - if (SAME_TYPE(SCHEME_TYPE(xformer), scheme_set_macro_type)) { + if (scheme_is_set_transformer(xformer)) { /* scheme_apply_macro unwraps it */ } else { if (!scheme_check_proc_arity(NULL, 1, 0, -1, &xformer)) { @@ -5402,10 +5403,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer,find_name); if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) { + && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { /* It's a rename. Look up the target name and try again. */ Scheme_Object *new_name; - new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); if (!rec[drec].comp) { new_name = scheme_stx_track(new_name, find_name, find_name); } @@ -5508,10 +5509,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name); if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) { + && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { /* It's a rename. Look up the target name and try again. */ Scheme_Object *new_name; - new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); if (!rec[drec].comp) { new_name = scheme_stx_track(new_name, find_name, find_name); } @@ -5595,10 +5596,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env, SCHEME_EXPAND_OBSERVE_RESOLVE(rec[drec].observer, find_name); if (var && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type) - && SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) { + && scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { /* It's a rename. Look up the target name and try again. */ Scheme_Object *new_name; - new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); if (!rec[drec].comp) { new_name = scheme_stx_track(new_name, find_name, find_name); } diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index df919cb3a5..a768c6c5a4 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -2603,10 +2603,10 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, Scheme_Object *certs; certs = rec[drec].certs; - if (SAME_TYPE(SCHEME_TYPE(rator), scheme_id_macro_type)) { + if (scheme_is_rename_transformer(rator)) { Scheme_Object *mark; - rator = SCHEME_PTR1_VAL(rator); + rator = scheme_rename_transformer_id(rator); /* rator is now an identifier */ /* and it's introduced by this expression: */ @@ -2639,8 +2639,8 @@ scheme_apply_macro(Scheme_Object *name, Scheme_Env *menv, certs = scheme_stx_extract_certs(code, certs); - if (SAME_TYPE(SCHEME_TYPE(rator), scheme_set_macro_type)) - rator = SCHEME_PTR_VAL(rator); + if (scheme_is_set_transformer(rator)) + rator = scheme_set_transformer_proc(rator); mark = scheme_new_mark(); code = scheme_add_remove_mark(code, mark); diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index a8cba4d810..58d5157fdf 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -4519,8 +4519,8 @@ static void eval_exptime(Scheme_Object *names, int count, SCHEME_PTR_VAL(macro) = values[i]; if (SCHEME_TRUEP(free_id_rename_rn) - && SAME_TYPE(SCHEME_TYPE(values[i]), scheme_id_macro_type)) - scheme_install_free_id_rename(name, SCHEME_PTR1_VAL(values[i]), free_id_rename_rn, + && scheme_is_binding_rename_transformer(values[i])) + scheme_install_free_id_rename(name, scheme_rename_transformer_id(values[i]), free_id_rename_rn, scheme_make_integer(0)); } else macro = values[i]; @@ -4539,8 +4539,8 @@ static void eval_exptime(Scheme_Object *names, int count, SCHEME_PTR_VAL(macro) = vals; if (SCHEME_TRUEP(free_id_rename_rn) - && SAME_TYPE(SCHEME_TYPE(vals), scheme_id_macro_type)) - scheme_install_free_id_rename(name, SCHEME_PTR1_VAL(vals), free_id_rename_rn, + && scheme_is_binding_rename_transformer(vals)) + scheme_install_free_id_rename(name, scheme_rename_transformer_id(vals), free_id_rename_rn, scheme_make_integer(0)); } else macro = vals; @@ -7334,6 +7334,69 @@ static Scheme_Object *adjust_for_rename(Scheme_Object *out_name, Scheme_Object * return first; } +static Scheme_Object *extract_free_id_name(Scheme_Object *name, + Scheme_Object *phase, + Scheme_Env *genv, + int always, + int *_implicit, + Scheme_Object **_implicit_src, + Scheme_Object **_implicit_src_name, + Scheme_Object **_implicit_mod_phase, + Scheme_Object **_implicit_nominal_name, + Scheme_Object **_implicit_nominal_mod) +{ + *_implicit = 0; + + while (1) { /* loop for free-id=? renaming */ + if (SCHEME_STXP(name)) { + if (genv + && (always + || SAME_OBJ(phase, scheme_make_integer(0)) + || SAME_OBJ(phase, scheme_make_integer(1)))) + name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL); + else + name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ + } + + /* Check for free-id=? renaming: */ + if (SAME_OBJ(phase, scheme_make_integer(0))) { + Scheme_Object *v2; + v2 = scheme_lookup_in_table(genv->syntax, (const char *)name); + if (v2 && scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(v2))) { + Scheme_Object *name2; + Scheme_Object *mod, *id; + + name2 = scheme_rename_transformer_id(SCHEME_PTR_VAL(v2)); + id = name2; + mod = scheme_stx_module_name(0, &id, phase, + _implicit_nominal_mod, _implicit_nominal_name, + _implicit_mod_phase, + NULL, NULL, NULL, NULL); + if (SAME_TYPE(SCHEME_TYPE(mod), scheme_module_index_type)) { + if (SCHEME_FALSEP(((Scheme_Modidx *)mod)->path)) { + /* keep looking locally */ + name = name2; + SCHEME_USE_FUEL(1); + } else { + /* free-id=? equivalence to a name that is not necessarily imported explicitly */ + if (_implicit_src) { + *_implicit_src = mod; + *_implicit_src_name = id; + } + *_implicit = 1; + break; + } + } else + break; + } else + break; + } else + break; + } + + return name; +} + char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table *tables, Scheme_Module_Exports *me, Scheme_Env *genv, @@ -7341,13 +7404,15 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table Scheme_Object *form, char **_phase1_protects) { - int i, count, z; + int i, count, z, implicit; Scheme_Object **exs, **exsns, **exss, **exsnoms, *phase; Scheme_Hash_Table *provided, *required; char *exps, *exets, *phase0_exps = NULL, *phase1_exps = NULL; int excount, exvcount; Scheme_Module_Phase_Exports *pt; - + Scheme_Object *implicit_src, *implicit_src_name, *implicit_mod_phase; + Scheme_Object *implicit_nominal_name, *implicit_nominal_mod; + for (z = 0; z < all_provided->size; z++) { provided = (Scheme_Hash_Table *)all_provided->vals[z]; @@ -7400,16 +7465,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table v = provided->vals[i]; /* external name */ name = SCHEME_CAR(v); /* internal name (maybe already a symbol) */ protected = SCHEME_TRUEP(SCHEME_CDR(v)); - prnt_name = name; - if (SCHEME_STXP(name)) { - if (genv) - name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL); - else - name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ - } - if (genv + name = extract_free_id_name(name, phase, genv, 1, &implicit, + NULL, NULL, NULL, NULL, NULL); + + if (!implicit + && genv && (SAME_OBJ(phase, scheme_make_integer(0)) || SAME_OBJ(phase, scheme_make_integer(1))) && scheme_lookup_in_table(SAME_OBJ(phase, scheme_make_integer(0)) @@ -7425,10 +7487,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table if (SAME_OBJ(phase, scheme_make_integer(1))) exets[count] = 1; count++; - } else if (genv + } else if (!implicit + && genv && SAME_OBJ(phase, scheme_make_integer(0)) && scheme_lookup_in_table(genv->syntax, (const char *)name)) { - /* Skip for now. */ + /* Skip syntax for now. */ + } else if (implicit) { + /* Rename-transformer redirect; skip for now. */ } else if ((v = scheme_hash_get(required, name))) { /* Required */ if (protected) { @@ -7473,17 +7538,13 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table name = SCHEME_CAR(v); /* internal name (maybe already a symbol) */ protected = SCHEME_TRUEP(SCHEME_CDR(v)); - if (SCHEME_STXP(name)) { - if (genv - && (SAME_OBJ(phase, scheme_make_integer(0)) - || SAME_OBJ(phase, scheme_make_integer(1)))) - name = scheme_tl_id_sym(genv, name, NULL, -1, phase, NULL); - else { - name = SCHEME_STX_VAL(name); /* shouldn't get here; no `define-for-label' */ - } - } + name = extract_free_id_name(name, phase, genv, 0, &implicit, + &implicit_src, &implicit_src_name, + &implicit_mod_phase, + &implicit_nominal_name, &implicit_nominal_mod); - if (genv + if (!implicit + && genv && SAME_OBJ(phase, scheme_make_integer(0)) && scheme_lookup_in_table(genv->syntax, (const char *)name)) { /* Defined locally */ @@ -7493,6 +7554,16 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table exsnoms[count] = scheme_null; /* since "self" */ exps[count] = protected; count++; + } else if (implicit) { + /* We record all free-id=?-based exprts as synatx, even though they may be values. */ + Scheme_Object *noms; + exs[count] = provided->keys[i]; + exsns[count] = implicit_src_name; + exss[count] = implicit_src; + noms = adjust_for_rename(exs[count], implicit_nominal_name, cons(implicit_nominal_mod, scheme_null)); + exsnoms[count] = noms; + exps[count] = protected; + count++; } else if ((v = scheme_hash_get(required, name))) { /* Required */ if (SCHEME_FALSEP(SCHEME_VEC_ELS(v)[3])) { diff --git a/src/mzscheme/src/schminc.h b/src/mzscheme/src/schminc.h index 448a7dfaad..519ede6b74 100644 --- a/src/mzscheme/src/schminc.h +++ b/src/mzscheme/src/schminc.h @@ -13,7 +13,7 @@ #define USE_COMPILED_STARTUP 1 -#define EXPECTED_PRIM_COUNT 947 +#define EXPECTED_PRIM_COUNT 950 #ifdef MZSCHEME_SOMETHING_OMITTED # undef USE_COMPILED_STARTUP diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 3c7920e318..7c9b7cc040 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -2515,6 +2515,12 @@ void scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables *ut, Scheme_Object *wraps_key, Scheme_Object *v); +int scheme_is_rename_transformer(Scheme_Object *o); +int scheme_is_binding_rename_transformer(Scheme_Object *o); +Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o); +int scheme_is_set_transformer(Scheme_Object *o); +Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o); + /*========================================================================*/ /* namespaces and modules */ /*========================================================================*/ diff --git a/src/mzscheme/src/schvers.h b/src/mzscheme/src/schvers.h index 6aabc11135..3b6a3749fc 100644 --- a/src/mzscheme/src/schvers.h +++ b/src/mzscheme/src/schvers.h @@ -13,12 +13,12 @@ consistently.) */ -#define MZSCHEME_VERSION "4.1.5.2" +#define MZSCHEME_VERSION "4.1.5.3" #define MZSCHEME_VERSION_X 4 #define MZSCHEME_VERSION_Y 1 #define MZSCHEME_VERSION_Z 5 -#define MZSCHEME_VERSION_W 2 +#define MZSCHEME_VERSION_W 3 #define MZSCHEME_VERSION_MAJOR ((MZSCHEME_VERSION_X * 100) + MZSCHEME_VERSION_Y) #define MZSCHEME_VERSION_MINOR ((MZSCHEME_VERSION_Z * 1000) + MZSCHEME_VERSION_W) diff --git a/src/mzscheme/src/struct.c b/src/mzscheme/src/struct.c index 8c0c3d0753..d3f23a65ab 100644 --- a/src/mzscheme/src/struct.c +++ b/src/mzscheme/src/struct.c @@ -70,6 +70,8 @@ static Scheme_Object *check_equal_property_value_ok(int argc, Scheme_Object *arg static Scheme_Object *check_write_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *check_output_port_property_value_ok(int argc, Scheme_Object *argv[]); +static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[]); +static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[]); static Scheme_Object *make_struct_type(int argc, Scheme_Object *argv[]); @@ -134,6 +136,10 @@ static Scheme_Object *exn_source_get(int argc, Scheme_Object **argv); static Scheme_Object *procedure_extract_target(int argc, Scheme_Object **argv); +static Scheme_Object *rename_transformer_property; +static Scheme_Object *set_transformer_property; +static Scheme_Object *not_free_id_symbol; + #ifdef MZ_PRECISE_GC static void register_traversers(void); #endif @@ -178,6 +184,7 @@ scheme_init_struct (Scheme_Env *env) Scheme_Object **loc_values, *loc_et; int loc_count; int i; + Scheme_Object *guard; static const char *arity_fields[1] = { "value" }; #ifdef TIME_SYNTAX @@ -253,7 +260,7 @@ scheme_init_struct (Scheme_Env *env) REGISTER_SO(write_property); { - Scheme_Object *guard, *a[2], *pred, *access; + Scheme_Object *a[2], *pred, *access; guard = scheme_make_prim_w_arity(check_write_property_value_ok, "guard-for-prop:custom-write", 2, 2); @@ -271,7 +278,6 @@ scheme_init_struct (Scheme_Env *env) REGISTER_SO(evt_property); { - Scheme_Object *guard; guard = scheme_make_prim_w_arity(check_evt_property_value_ok, "guard-for-prop:evt", 2, 2); @@ -292,7 +298,6 @@ scheme_init_struct (Scheme_Env *env) } { - Scheme_Object *guard; guard = scheme_make_prim_w_arity(check_equal_property_value_ok, "guard-for-prop:equal+hash", 2, 2); @@ -303,7 +308,6 @@ scheme_init_struct (Scheme_Env *env) } { - Scheme_Object *guard; REGISTER_SO(scheme_input_port_property); REGISTER_SO(scheme_output_port_property); @@ -323,6 +327,33 @@ scheme_init_struct (Scheme_Env *env) scheme_add_global_constant("prop:output-port", scheme_output_port_property, env); } + { + REGISTER_SO(rename_transformer_property); + + guard = scheme_make_prim_w_arity(check_rename_transformer_property_value_ok, + "guard-for-prop:rename-transformer", + 2, 2); + rename_transformer_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("rename-transformer"), + guard); + + scheme_add_global_constant("prop:rename-transformer", rename_transformer_property, env); + } + + { + REGISTER_SO(set_transformer_property); + + guard = scheme_make_prim_w_arity(check_set_transformer_property_value_ok, + "guard-for-prop:set!-transformer", + 2, 2); + set_transformer_property = scheme_make_struct_type_property_w_guard(scheme_intern_symbol("set!-transformer"), + guard); + + scheme_add_global_constant("prop:set!-transformer", set_transformer_property, env); + } + + REGISTER_SO(not_free_id_symbol); + not_free_id_symbol = scheme_intern_symbol("not-free-identifier=?"); + REGISTER_SO(scheme_recur_symbol); REGISTER_SO(scheme_display_symbol); REGISTER_SO(scheme_write_special_symbol); @@ -552,7 +583,6 @@ scheme_init_struct (Scheme_Env *env) REGISTER_SO(scheme_source_property); { - Scheme_Object *guard; guard = scheme_make_prim_w_arity(check_exn_source_property_value_ok, "guard-for-prop:exn:srclocs", 2, 2); @@ -1073,25 +1103,22 @@ static int is_evt_struct(Scheme_Object *o) /* port structs */ /*========================================================================*/ -static Scheme_Object *check_port_property_value_ok(const char *name, int input, int argc, Scheme_Object *argv[]) -/* This is the guard for prop:input-port and prop:output-port */ +typedef int (*Check_Val_Proc)(Scheme_Object *); + +static Scheme_Object *check_indirect_property_value_ok(const char *name, Check_Val_Proc ck, const char *complain, + int argc, Scheme_Object *argv[]) { Scheme_Object *v, *l, *acc; int pos, num_islots; v = argv[0]; - - if ((input && SCHEME_INPUT_PORTP(v)) - || (!input && SCHEME_OUTPUT_PORTP(v))) + + if (ck(v)) return v; if (!((SCHEME_INTP(v) && (SCHEME_INT_VAL(v) >= 0)) || (SCHEME_BIGNUMP(v) && SCHEME_BIGPOS(v)))) - scheme_arg_mismatch(name, - (input - ? "property value is not an input port or exact non-negative integer: " - : "property value is not an output port or exact non-negative integer: "), - v); + scheme_arg_mismatch(name, complain, v); l = argv[1]; l = SCHEME_CDR(l); @@ -1131,6 +1158,20 @@ static Scheme_Object *check_port_property_value_ok(const char *name, int input, return v; } +static int is_input_port(Scheme_Object *v) { return SCHEME_INPUT_PORTP(v); } +static int is_output_port(Scheme_Object *v) { return SCHEME_OUTPUT_PORTP(v); } + +static Scheme_Object *check_port_property_value_ok(const char *name, int input, int argc, Scheme_Object *argv[]) +/* This is the guard for prop:input-port and prop:output-port */ +{ + return check_indirect_property_value_ok(name, + input ? is_input_port : is_output_port, + (input + ? "property value is not an input port or exact non-negative integer: " + : "property value is not an output port or exact non-negative integer: "), + argc, argv); +} + static Scheme_Object *check_input_port_property_value_ok(int argc, Scheme_Object *argv[]) { return check_port_property_value_ok("guard-for-prop:input-port", 1, argc, argv); @@ -1207,6 +1248,107 @@ Scheme_Object *scheme_is_writable_struct(Scheme_Object *s) return scheme_struct_type_property_ref(write_property, s); } +/*========================================================================*/ +/* rename and set! transformer properties */ +/*========================================================================*/ + +int scheme_is_rename_transformer(Scheme_Object *o) +{ + if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type)) + return 1; + if (SCHEME_STRUCTP(o) + && scheme_struct_type_property_ref(rename_transformer_property, o)) + return 1; + return 0; +} + +int scheme_is_binding_rename_transformer(Scheme_Object *o) +{ + if (scheme_is_rename_transformer(o)) { + o = scheme_rename_transformer_id(o); + o = scheme_stx_property(o, not_free_id_symbol, NULL); + if (o && SCHEME_TRUEP(o)) + return 0; + return 1; + } + return 0; +} + +static int is_stx_id(Scheme_Object *o) { return (SCHEME_STXP(o) && SCHEME_SYMBOLP(SCHEME_STX_VAL(o))); } + +Scheme_Object *scheme_rename_transformer_id(Scheme_Object *o) +{ + if (SAME_TYPE(SCHEME_TYPE(o), scheme_id_macro_type)) + return SCHEME_PTR1_VAL(o); + if (SCHEME_STRUCTP(o)) { + Scheme_Object *v; + v = scheme_struct_type_property_ref(rename_transformer_property, o); + if (SCHEME_BOXP(v)) v = SCHEME_BOX_VAL(v); + if (SCHEME_INTP(v)) { + v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)]; + if (!is_stx_id(v)) { + v = scheme_datum_to_syntax(scheme_intern_symbol("?"), scheme_false, scheme_false, 0, 0); + } + } + return v; + } + return NULL; +} + +static Scheme_Object *check_rename_transformer_property_value_ok(int argc, Scheme_Object *argv[]) +{ + return check_indirect_property_value_ok("guard-for-prop:rename-transformer", + is_stx_id, + "property value is not an identifier or exact non-negative integer, optionaly boxed: ", + argc, argv); +} + +int scheme_is_set_transformer(Scheme_Object *o) +{ + if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type)) + return 1; + if (SCHEME_STRUCTP(o) + && scheme_struct_type_property_ref(set_transformer_property, o)) + return 1; + return 0; +} + +static int is_proc_1(Scheme_Object *o) { return (SCHEME_PROCP(o) && scheme_check_proc_arity(NULL, 1, -1, 0, &o)); } + +Scheme_Object *signal_bad_syntax(int argc, Scheme_Object **argv) +{ + scheme_wrong_syntax(NULL, NULL, argv[0], "bad syntax"); + return NULL; +} + +Scheme_Object *scheme_set_transformer_proc(Scheme_Object *o) +{ + if (SAME_TYPE(SCHEME_TYPE(o), scheme_set_macro_type)) + return SCHEME_PTR_VAL(o); + if (SCHEME_STRUCTP(o)) { + Scheme_Object *v; + v = scheme_struct_type_property_ref(set_transformer_property, o); + if (SCHEME_INTP(v)) { + v = ((Scheme_Structure *)o)->slots[SCHEME_INT_VAL(v)]; + if (!is_proc_1(v)) { + v = scheme_make_prim_w_arity(signal_bad_syntax, + "bad-syntax-set!-transformer", + 1, 1); + } + } + return v; + } + return NULL; +} + +static Scheme_Object *check_set_transformer_property_value_ok(int argc, Scheme_Object *argv[]) +{ + return check_indirect_property_value_ok("guard-for-prop:set!-transformer", + is_proc_1, + "property value is not an procedure (arity 1) or exact non-negative integer: ", + argc, argv); +} + /*========================================================================*/ /* struct ops */ /*========================================================================*/ diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 7f70231c20..bc3b812e74 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -4816,11 +4816,11 @@ Scheme_Object *scheme_stx_get_module_eq_sym(Scheme_Object *a, Scheme_Object *pha Scheme_Object *scheme_stx_module_name(int recur, Scheme_Object **a, Scheme_Object *phase, - Scheme_Object **nominal_modidx, - Scheme_Object **nominal_name, - Scheme_Object **mod_phase, - Scheme_Object **src_phase_index, - Scheme_Object **nominal_src_phase, + Scheme_Object **nominal_modidx, /* how it was imported */ + Scheme_Object **nominal_name, /* imported as name */ + Scheme_Object **mod_phase, /* original defn phase level */ + Scheme_Object **src_phase_index, /* phase level of import from nominal modidx */ + Scheme_Object **nominal_src_phase, /* phase level of export from nominal modidx */ Scheme_Object **lex_env, int *_sealed) /* If module bound, result is module idx, and a is set to source name. diff --git a/src/mzscheme/src/syntax.c b/src/mzscheme/src/syntax.c index 77444877c6..407abd05d4 100644 --- a/src/mzscheme/src/syntax.c +++ b/src/mzscheme/src/syntax.c @@ -1698,12 +1698,12 @@ set_syntax (Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Compile_Info *rec, if (SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { /* Redirect to a macro? */ - if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_set_macro_type)) { + if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { form = scheme_apply_macro(name, menv, SCHEME_PTR_VAL(var), form, env, scheme_false, rec, drec, 1); return scheme_compile_expr(form, env, rec, drec); - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) { - find_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var)); + } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { + find_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); find_name = scheme_stx_cert(find_name, scheme_false, menv, find_name, NULL, 1); SCHEME_USE_FUEL(1); menv = NULL; @@ -1787,7 +1787,7 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, if ((erec[drec].depth != 0) && SAME_TYPE(SCHEME_TYPE(var), scheme_macro_type)) { /* Redirect to a macro? */ - if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_set_macro_type)) { + if (scheme_is_set_transformer(SCHEME_PTR_VAL(var))) { SCHEME_EXPAND_OBSERVE_ENTER_MACRO(erec[drec].observer, form); @@ -1801,9 +1801,9 @@ set_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *erec, erec[drec].value_name = name; return scheme_expand_expr(form, env, erec, drec); - } else if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(var)), scheme_id_macro_type)) { + } else if (scheme_is_rename_transformer(SCHEME_PTR_VAL(var))) { Scheme_Object *new_name; - new_name = SCHEME_PTR_VAL(SCHEME_PTR_VAL(var)); + new_name = scheme_rename_transformer_id(SCHEME_PTR_VAL(var)); new_name = scheme_stx_track(new_name, find_name, find_name); new_name = scheme_stx_cert(new_name, scheme_false, menv, find_name, NULL, 1); find_name = new_name; @@ -5732,14 +5732,13 @@ static void *eval_letmacro_rhs_k(void) return (void *)eval_letmacro_rhs(a, rhs_env, max_let_depth, rp, phase, certs); } - void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object *a, Scheme_Env *exp_env, Scheme_Object *insp, Scheme_Compile_Expand_Info *rec, int drec, Scheme_Comp_Env *stx_env, Scheme_Comp_Env *rhs_env, int *_pos, Scheme_Object *rename_rib) { - Scheme_Object **results, *l; + Scheme_Object **results, *l, *a_expr; Scheme_Comp_Env *eenv; Scheme_Object *certs; Resolve_Prefix *rp; @@ -5795,7 +5794,8 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object SCHEME_EXPAND_OBSERVE_NEXT(rec[drec].observer); - a = eval_letmacro_rhs(a, rhs_env, ri->max_let_depth, rp, eenv->genv->phase, certs); + a_expr = a; + a = eval_letmacro_rhs(a_expr, rhs_env, ri->max_let_depth, rp, eenv->genv->phase, certs); if (SAME_OBJ(a, SCHEME_MULTIPLE_VALUES)) { vc = scheme_current_thread->ku.multiple.count; @@ -5846,9 +5846,9 @@ void scheme_bind_syntaxes(const char *where, Scheme_Object *names, Scheme_Object scheme_set_local_syntax(i++, name, macro, stx_env); - if (SAME_TYPE(SCHEME_TYPE(SCHEME_PTR_VAL(macro)), scheme_id_macro_type)) { + if (scheme_is_binding_rename_transformer(SCHEME_PTR_VAL(macro))) { /* Install a free-id=? rename */ - scheme_install_free_id_rename(name, SCHEME_PTR1_VAL(SCHEME_PTR_VAL(macro)), rename_rib, + scheme_install_free_id_rename(name, scheme_rename_transformer_id(SCHEME_PTR_VAL(macro)), rename_rib, scheme_make_integer(rhs_env->genv->phase)); } } From 55dd268c64f02fedd80c16dcf9da229a3ed728c4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 19 Mar 2009 20:24:03 +0000 Subject: [PATCH 088/140] release notes for 4.1.5.3 svn: r14192 --- doc/release-notes/mzscheme/HISTORY.txt | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index 52c6065aa0..ea3c16984c 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -1,3 +1,12 @@ +Version 4.1.5.3 +Change provide to convert an exported rename transformer to its + free-identifier=? target +Add 'not-free-identifier=? syntax property to disable free-identifier=? + propagation through a rename transformer +Add prop:rename-transformer and prop:set!-transformer +Fix scheme/local so that local syntax bindings are visible to later + local definitions + Version 4.1.5.2 Changed expander to detect a reaname transformer and install a free-identifier=? syntax-object equivalence From cbc5759254a876e229267d2619e9e9f7f1b0427f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Mar 2009 00:34:07 +0000 Subject: [PATCH 089/140] fix SRFI 38 (PR 10141) svn: r14193 --- collects/srfi/38/38.ss | 16 +++++++++++----- 1 file changed, 11 insertions(+), 5 deletions(-) diff --git a/collects/srfi/38/38.ss b/collects/srfi/38/38.ss index b124d4c5bf..ce4306df4c 100644 --- a/collects/srfi/38/38.ss +++ b/collects/srfi/38/38.ss @@ -1,8 +1,14 @@ #lang scheme/base -(provide s:read s:write) +(define (write-with-shared-structure val [port (current-output-port)] [optarg #f]) + (parameterize ([print-graph #t]) (write val port))) + +(define (read-with-shared-structure [port (current-input-port)] [optarg #f]) + (parameterize ([read-accept-graph #t]) + (read port))) + +(provide write-with-shared-structure + (rename-out [write-with-shared-structure write/ss]) + read-with-shared-structure + (rename-out [read-with-shared-structure read/ss])) -(define (s:write . args) - (parameterize ([print-graph #t]) (apply write args))) -(define (s:read . args) - (parameterize ([read-accept-graph #t]) (apply read args))) From 0686dd721e3e4ca4a2b30ff64d6cd37b1849f12a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Fri, 20 Mar 2009 07:50:38 +0000 Subject: [PATCH 090/140] Welcome to a new PLT day. svn: r14194 --- collects/repos-time-stamp/stamp.ss | 2 +- src/worksp/mred/mred.manifest | 2 +- src/worksp/mred/mred.rc | 8 ++++---- src/worksp/mzcom/mzcom.rc | 8 ++++---- src/worksp/mzcom/mzobj.rgs | 6 +++--- src/worksp/mzscheme/mzscheme.rc | 8 ++++---- src/worksp/starters/start.rc | 8 ++++---- 7 files changed, 21 insertions(+), 21 deletions(-) diff --git a/collects/repos-time-stamp/stamp.ss b/collects/repos-time-stamp/stamp.ss index 4d76bf533a..fb26e2e962 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "19mar2009") +#lang scheme/base (provide stamp) (define stamp "20mar2009") diff --git a/src/worksp/mred/mred.manifest b/src/worksp/mred/mred.manifest index 3afc29ca9f..d3142c851d 100644 --- a/src/worksp/mred/mred.manifest +++ b/src/worksp/mred/mred.manifest @@ -1,7 +1,7 @@ Date: Fri, 20 Mar 2009 16:59:28 +0000 Subject: [PATCH 091/140] add 'not-provide-all-defined and 'nonimal-id suport for rename transformers; fix scheme/foreign and foreign docs to use it svn: r14195 --- collects/ffi/private/objc-doc-unsafe.ss | 8 +++++- collects/scheme/foreign.ss | 8 +++++- collects/scheme/private/reqprov.ss | 11 +++++++- collects/scribblings/foreign/derived.scrbl | 4 --- collects/scribblings/foreign/foreign.scrbl | 2 +- collects/scribblings/foreign/libs.scrbl | 2 -- collects/scribblings/foreign/misc.scrbl | 2 -- collects/scribblings/foreign/pointers.scrbl | 4 --- .../scribblings/foreign/unsafe-foreign.ss | 26 ++++++++++++++++--- .../scribblings/reference/stx-trans.scrbl | 12 ++++++--- collects/scribblings/reference/syntax.scrbl | 14 +++++----- src/mzscheme/src/module.c | 12 +++++++-- src/mzscheme/src/stxobj.c | 17 ++++++++++-- 13 files changed, 90 insertions(+), 32 deletions(-) diff --git a/collects/ffi/private/objc-doc-unsafe.ss b/collects/ffi/private/objc-doc-unsafe.ss index 20ecc1eb89..6aad33ea1e 100644 --- a/collects/ffi/private/objc-doc-unsafe.ss +++ b/collects/ffi/private/objc-doc-unsafe.ss @@ -6,5 +6,11 @@ (objc-unsafe!) -(provide (protect-out (all-defined-out)) +(provide (protect-out objc_msgSend/typed + objc_msgSendSuper/typed + import-class + get-ivar set-ivar! + selector + tell tellv + define-objc-class) (all-from-out ffi/objc)) diff --git a/collects/scheme/foreign.ss b/collects/scheme/foreign.ss index 5ca2e2446e..122b11c8ba 100644 --- a/collects/scheme/foreign.ss +++ b/collects/scheme/foreign.ss @@ -51,7 +51,13 @@ stx 'to stx) ...)]) #'(begin (define-syntax id - (make-rename-transformer #'from)) + (make-rename-transformer (syntax-property + (syntax-property + #'from + 'not-provide-all-defined + #t) + 'nominal-id + 'to))) ...))]))))]))))) (provide* ctype-sizeof ctype-alignof compiler-sizeof diff --git a/collects/scheme/private/reqprov.ss b/collects/scheme/private/reqprov.ss index c1fa40a40c..a0c1aa4236 100644 --- a/collects/scheme/private/reqprov.ss +++ b/collects/scheme/private/reqprov.ss @@ -653,7 +653,16 @@ (memq 0 modes)) (map (lambda (id) (make-export id (syntax-e id) 0 #f stx)) - (filter (same-ctx? free-identifier=?) + (filter (lambda (id) + (and ((same-ctx? free-identifier=?) id) + (let-values ([(v id) (syntax-local-value/immediate + id + (lambda () (values #f #f)))]) + (not + (and (rename-transformer? v) + (syntax-property + (rename-transformer-target v) + 'not-provide-all-defined)))))) ids)) null)))])))) diff --git a/collects/scribblings/foreign/derived.scrbl b/collects/scribblings/foreign/derived.scrbl index 2b64510041..8ff776dd5a 100644 --- a/collects/scribblings/foreign/derived.scrbl +++ b/collects/scribblings/foreign/derived.scrbl @@ -64,8 +64,6 @@ obtain a tag. The tag is the string form of @schemevarfont{id}.} @subsection{Unsafe Tagged C Pointer Functions} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc*[([(cpointer-has-tag? [cptr any/c] [tag any/c]) boolean?] [(cpointer-push-tag! [cptr any/c] [tag any/c]) void])]{ @@ -157,8 +155,6 @@ Converts the list @scheme[lst] to a C vector of the given @subsection{Unsafe C Vector Construction} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc[(make-cvector* [cptr any/c] [type ctype?] [length exact-nonnegative-integer?]) cvector?]{ diff --git a/collects/scribblings/foreign/foreign.scrbl b/collects/scribblings/foreign/foreign.scrbl index 880e267b93..bdc92ff4d8 100644 --- a/collects/scribblings/foreign/foreign.scrbl +++ b/collects/scribblings/foreign/foreign.scrbl @@ -5,7 +5,7 @@ @author["Eli Barzilay"] -@defmodule[scheme/foreign] +@defmodule[scheme/foreign #:use-sources ('#%foreign)] The @schememodname[scheme/foreign] library enables the direct use of C-based APIs within Scheme programs---without writing any new C diff --git a/collects/scribblings/foreign/libs.scrbl b/collects/scribblings/foreign/libs.scrbl index b3084f9dc3..d514f24f29 100644 --- a/collects/scribblings/foreign/libs.scrbl +++ b/collects/scribblings/foreign/libs.scrbl @@ -19,8 +19,6 @@ Returns @scheme[#t] if @scheme[v] is the result of @scheme[ffi-lib], @section{Unsafe Library Functions} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc[(ffi-lib [path (or/c path-string? #f)] [version (or/c string? (listof string?) #f) #f]) any]{ diff --git a/collects/scribblings/foreign/misc.scrbl b/collects/scribblings/foreign/misc.scrbl index cf5dd3d4f2..850e89b714 100644 --- a/collects/scribblings/foreign/misc.scrbl +++ b/collects/scribblings/foreign/misc.scrbl @@ -54,8 +54,6 @@ Like @scheme[list->cblock], but for Scheme vectors.} @section{Unsafe Miscellaneous Operations} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc[(cblock->list [cblock any/c][type ctype?][length exact-nonnegative-integer?]) list?]{ diff --git a/collects/scribblings/foreign/pointers.scrbl b/collects/scribblings/foreign/pointers.scrbl index 9f4a4a47e1..5810e194a6 100644 --- a/collects/scribblings/foreign/pointers.scrbl +++ b/collects/scribblings/foreign/pointers.scrbl @@ -50,8 +50,6 @@ offset is always in bytes.} @section{Unsafe Pointer Operations} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc[(set-ptr-offset! [cptr cpointer?][offset exact-integer?][ctype ctype? _byte]) void?]{ @@ -209,8 +207,6 @@ can contain other information).} @section{Unsafe Memory Management} -@declare-exporting[scribblings/foreign/unsafe-foreign] - For general information on C-level memory management with PLT Scheme, see @|InsideMzScheme|. diff --git a/collects/scribblings/foreign/unsafe-foreign.ss b/collects/scribblings/foreign/unsafe-foreign.ss index 766bbdc086..e3eccbb4a8 100644 --- a/collects/scribblings/foreign/unsafe-foreign.ss +++ b/collects/scribblings/foreign/unsafe-foreign.ss @@ -1,11 +1,31 @@ #lang scheme/base - -(require scheme/foreign) +(require scheme/foreign + (for-syntax scheme/base + scheme/provide-transform)) (error 'unsafe! "only `for-label' use in the documentation") (unsafe!) -(provide (protect-out (all-defined-out)) +;; This is like `all-defined-out', but it ignores the 'not-provide-all-defined +;; property, so that the bindings introduced by `unsafe!' are exported. +(define-syntax all-unsafe-defined-out + (make-provide-transformer + (lambda (stx modes) + (syntax-case stx () + [(_) + (let-values ([(ids stx-ids) (syntax-local-module-defined-identifiers)] + [(same-ctx?) (lambda (free-identifier=?) + (lambda (id) + (free-identifier=? id + (datum->syntax + stx + (syntax-e id)))))]) + (map (lambda (id) + (make-export id (syntax-e id) 0 #f stx)) + (filter (same-ctx? free-identifier=?) + ids)))])))) + +(provide (protect-out (all-unsafe-defined-out)) (all-from-out scheme/foreign)) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 8da2fbfb77..b1aa58f3a2 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -110,9 +110,15 @@ expressions. Such a transformer could be written manually, but the one created by @scheme[make-rename-transformer] also causes the parser to install a @scheme[free-identifier=?] and @scheme[identifier-binding] -equivalence, as long as @scheme[id-stx] does not have a true value for the -@indexed-scheme['not-free-identifier=?] @tech{syntax property}. -In addition, the rename transformer cooperates specially with +equivalence, as long as @scheme[id-stx] does not have a true value for +the @indexed-scheme['not-free-identifier=?] @tech{syntax property}. +Also, if @scheme[id-stx] has a true value for the +@indexed-scheme['not-provide-all-defined] @tech{syntax property} and +it is bound as a module-level transformer, the bound identifier is not +exported by @scheme[all-defined-out]; the @scheme[provide] form +otherwise uses a symbol-valued @indexed-scheme['nominal-id] property +of @scheme[id-stx] to specify the ``nominal source identifier'' of the +binding. Finally, the rename transformer cooperates specially with @scheme[syntax-local-value] and @scheme[syntax-local-make-delta-introducer].} diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index e0647da100..d248ba0dd2 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -713,12 +713,14 @@ follows. @defsubform[(all-defined-out)]{ Exports all identifiers that are defined at @tech{phase level} 0 or @tech{phase level} 1 within the exporting module, and that have the same lexical context as the - @scheme[(all-defined-out)] form. The external name for each - identifier is the symbolic form of the identifier. Only identifiers - accessible from the lexical context of the @scheme[(all-defined-out)] - form are included; that is, macro-introduced imports are not - re-exported, unless the @scheme[(all-defined-out)] form was - introduced at the same time. + @scheme[(all-defined-out)] form, excluding bindings to @tech{rename + transformers} where the target identifier has the + @scheme['not-provide-all-defined] @tech{syntax property}. The + external name for each identifier is the symbolic form of the + identifier. Only identifiers accessible from the lexical context of + the @scheme[(all-defined-out)] form are included; that is, + macro-introduced imports are not re-exported, unless the + @scheme[(all-defined-out)] form was introduced at the same time. @defexamples[#:eval (syntax-eval) (module test scheme diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 58d5157fdf..9b8a595c3c 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -157,6 +157,7 @@ static Scheme_Object *lib_symbol; static Scheme_Object *planet_symbol; static Scheme_Object *file_symbol; static Scheme_Object *module_name_symbol; +static Scheme_Object *nominal_id_symbol; /* global read-only syntax */ Scheme_Object *scheme_module_stx; @@ -566,6 +567,9 @@ void scheme_finish_kernel(Scheme_Env *env) REGISTER_SO(module_name_symbol); module_name_symbol = scheme_intern_symbol("enclosing-module-name"); + + REGISTER_SO(nominal_id_symbol); + nominal_id_symbol = scheme_intern_symbol("nominal-id"); } int scheme_is_kernel_modname(Scheme_Object *modname) @@ -7381,7 +7385,10 @@ static Scheme_Object *extract_free_id_name(Scheme_Object *name, /* free-id=? equivalence to a name that is not necessarily imported explicitly */ if (_implicit_src) { *_implicit_src = mod; - *_implicit_src_name = id; + *_implicit_src_name = id; + name2 = scheme_stx_property(name2, nominal_id_symbol, NULL); + if (SCHEME_SYMBOLP(name2)) + *_implicit_nominal_name = name2; } *_implicit = 1; break; @@ -7468,7 +7475,8 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table prnt_name = name; name = extract_free_id_name(name, phase, genv, 1, &implicit, - NULL, NULL, NULL, NULL, NULL); + NULL, NULL, NULL, + NULL, NULL); if (!implicit && genv diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index bc3b812e74..d1e811ce11 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -76,6 +76,7 @@ static Scheme_Object *share_symbol; /* uninterned! */ static Scheme_Object *origin_symbol; static Scheme_Object *lexical_symbol; static Scheme_Object *protected_symbol; +static Scheme_Object *nominal_id_symbol; static THREAD_LOCAL Scheme_Object *nominal_ipair_cache; @@ -544,11 +545,13 @@ void scheme_init_stx(Scheme_Env *env) REGISTER_SO(origin_symbol); REGISTER_SO(lexical_symbol); REGISTER_SO(protected_symbol); + REGISTER_SO(nominal_id_symbol); source_symbol = scheme_make_symbol("source"); /* not interned! */ share_symbol = scheme_make_symbol("share"); /* not interned! */ origin_symbol = scheme_intern_symbol("origin"); lexical_symbol = scheme_intern_symbol("lexical"); protected_symbol = scheme_intern_symbol("protected"); + nominal_id_symbol = scheme_intern_symbol("nominal-id"); REGISTER_SO(mark_id); @@ -1935,12 +1938,14 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, Scheme_Object *result; Scheme_Object *modname; Scheme_Object *nominal_modidx; - Scheme_Object *nominal_name; + Scheme_Object *nominal_name, *nom2; Scheme_Object *mod_phase; Scheme_Object *src_phase_index; Scheme_Object *nominal_src_phase; Scheme_Object *lex_env; + nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL); + modname = scheme_stx_module_name(1, &orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx, &nominal_name, @@ -1949,6 +1954,9 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, &nominal_src_phase, &lex_env, _sealed); + + if (SCHEME_SYMBOLP(nom2)) + nominal_name = nom2; if (!modname) result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), scheme_false)); @@ -5356,7 +5364,7 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) { Scheme_Object *bind; Scheme_Object *nominal_modidx; - Scheme_Object *nominal_name; + Scheme_Object *nominal_name, *nom2; Scheme_Object *mod_phase; Scheme_Object *src_phase_index; Scheme_Object *nominal_src_phase; @@ -5366,10 +5374,15 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) phase = SCHEME_CDR(id); id = SCHEME_CAR(id); + nom2 = scheme_stx_property(id, nominal_id_symbol, NULL); + bind = scheme_stx_module_name(1, &id, phase, &nominal_modidx, &nominal_name, &mod_phase, &src_phase_index, &nominal_src_phase, &lex_env, NULL); + + if (SCHEME_SYMBOLP(nom2)) + nominal_name = nom2; if (!nominal_name) nominal_name = SCHEME_STX_VAL(id); From 91c53fa1237f752007d7d486e6ad442694162dac Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Mar 2009 17:20:04 +0000 Subject: [PATCH 092/140] add replace-context to syntax/strip-context svn: r14196 --- .../syntax/scribblings/strip-context.scrbl | 6 ++++++ collects/syntax/strip-context.ss | 20 +++++++++++-------- 2 files changed, 18 insertions(+), 8 deletions(-) diff --git a/collects/syntax/scribblings/strip-context.scrbl b/collects/syntax/scribblings/strip-context.scrbl index 0953ef514c..e36bff5850 100644 --- a/collects/syntax/scribblings/strip-context.scrbl +++ b/collects/syntax/scribblings/strip-context.scrbl @@ -10,3 +10,9 @@ Removes all lexical context from @scheme[stx], preserving source-location information and properties.} + +@defproc[(replace-context [ctx-stx syntax?] [stx syntax?]) syntax?]{ + +Uses the lexical context of @scheme[ctx-stx] to replace the lexical +context of all parts of @scheme[stx], preserving source-location +information and properties of @scheme[stx].} diff --git a/collects/syntax/strip-context.ss b/collects/syntax/strip-context.ss index 779b7f5342..20d71747ef 100644 --- a/collects/syntax/strip-context.ss +++ b/collects/syntax/strip-context.ss @@ -1,23 +1,27 @@ #lang scheme/base -(provide strip-context) +(provide strip-context + replace-context) (define (strip-context e) + (replace-context #f e)) + +(define (replace-context ctx e) (cond [(syntax? e) - (datum->syntax #f - (strip-context (syntax-e e)) + (datum->syntax ctx + (replace-context ctx (syntax-e e)) e e)] - [(pair? e) (cons (strip-context (car e)) - (strip-context (cdr e)))] + [(pair? e) (cons (replace-context ctx (car e)) + (replace-context ctx (cdr e)))] [(vector? e) (list->vector - (map strip-context + (map (lambda (e) (replace-context ctx e)) (vector->list e)))] - [(box? e) (box (strip-context (unbox e)))] + [(box? e) (box (replace-context ctx (unbox e)))] [(prefab-struct-key e) => (lambda (k) (apply make-prefab-struct k - (strip-context (cdr (vector->list (struct->vector e))))))] + (replace-context ctx (cdr (vector->list (struct->vector e))))))] [else e])) From 20dd11d322a261c3cc2b3e68f9244424b861322c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Mar 2009 19:45:55 +0000 Subject: [PATCH 093/140] fix problem with make-syntax-delta-introducer svn: r14198 --- src/mzscheme/src/stxobj.c | 31 ++++++++++++++++++++----------- 1 file changed, 20 insertions(+), 11 deletions(-) diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index d1e811ce11..2792830328 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -3629,7 +3629,8 @@ static void add_all_marks(Scheme_Object *wraps, Scheme_Hash_Table *marks) } } -static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache, int depth) +static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme_Object **marks_cache, int depth, + int *_skipped) { int l1, l2; Scheme_Object *m1, *m2; @@ -3638,6 +3639,7 @@ static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme p = SCHEME_CDR(p); /* skip phase_export */ if (SCHEME_PAIRP(p)) { /* has marks */ + int skip = 0; EXPLAIN(fprintf(stderr, "%d has marks\n", depth)); @@ -3658,25 +3660,30 @@ static int check_matching_marks(Scheme_Object *p, Scheme_Object *orig_id, Scheme while (l2 > l1) { m2 = SCHEME_CDR(m2); l2--; + skip++; } - if (scheme_equal(m1, m2)) + if (scheme_equal(m1, m2)) { + if (_skipped ) *_skipped = skip; return l1; /* matches */ - else + } else return -1; /* no match */ - } else + } else { + if (_skipped) *_skipped = -1; return 0; /* match empty mark set */ + } } static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, Scheme_Object *glob_id, Scheme_Object *orig_id, Scheme_Object **get_names, int get_orig_name, - int depth) + int depth, + int *_skipped) { Scheme_Object *pr, *idx, *pos, *src, *best_match = NULL; Scheme_Module_Phase_Exports *pt; Scheme_Hash_Table *ht; - int i, phase, best_match_len = -1; + int i, phase, best_match_len = -1, skip; Scheme_Object *marks_cache = NULL; for (pr = shared_pes; !SCHEME_NULLP(pr); pr = SCHEME_CDR(pr)) { @@ -3699,10 +3706,11 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, /* Found it, maybe. Check marks. */ int mark_len; EXPLAIN(fprintf(stderr, "%d found %p\n", depth, pos)); - mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth); + mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth, &skip); if (mark_len > best_match_len) { /* Marks match and improve on previously found match. Build suitable rename: */ best_match_len = mark_len; + if (_skipped) *_skipped = skip; idx = SCHEME_CAR(SCHEME_CAR(pr)); @@ -3752,11 +3760,12 @@ static Scheme_Object *search_shared_pes(Scheme_Object *shared_pes, kpr = scheme_hash_get(krn->ht, glob_id); if (kpr) { /* Found it, maybe. Check marks. */ - int mark_len; - mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth); + int mark_len, skip; + mark_len = check_matching_marks(SCHEME_CAR(pr), orig_id, &marks_cache, depth, &skip); if (mark_len > best_match_len) { /* Marks match and improve on previously found match. Build suitable rename: */ best_match_len = mark_len; + if (_skipped) *_skipped = skip; if (get_orig_name) best_match = glob_id; @@ -4168,7 +4177,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps, get_names_done = 0; if (!rename) { EXPLAIN(fprintf(stderr, "%d in pes\n", depth)); - rename = search_shared_pes(mrn->shared_pes, glob_id, a, get_names, 0, depth); + rename = search_shared_pes(mrn->shared_pes, glob_id, a, get_names, 0, depth, &skipped); if (rename) get_names_done = 1; } @@ -4646,7 +4655,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_ rename = scheme_hash_get(krn->ht, glob_id); if (!rename) - result = search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1, 0); + result = search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1, 0, NULL); else { /* match; set result: */ if (mrn->kind == mzMOD_RENAME_MARKED) From 1db2b65978b9f2330d2de01f1caaef26f3f2cd3a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 21 Mar 2009 15:06:48 +0000 Subject: [PATCH 094/140] Finished the docs+tests, added some minor utilities. svn: r14199 --- collects/scribble/text/output.ss | 45 +- .../scribblings/scribble/preprocessor.scrbl | 1086 ++++++++++++++++- collects/scribblings/scribble/utils.ss | 114 +- collects/tests/scribble/main.ss | 236 ++-- collects/tests/scribble/text/i01.ss | 3 - collects/tests/scribble/text/i02.ss | 25 - collects/tests/scribble/text/i03.ss | 18 - collects/tests/scribble/text/i03a | 1 - collects/tests/scribble/text/i03b | 12 - collects/tests/scribble/text/i04.ss | 24 - collects/tests/scribble/text/i05.ss | 30 - collects/tests/scribble/text/i06.ss | 25 - collects/tests/scribble/text/i07.ss | 18 - collects/tests/scribble/text/i08.ss | 17 - collects/tests/scribble/text/i09.ss | 25 - collects/tests/scribble/text/i10.ss | 33 - collects/tests/scribble/text/i11.ss | 13 - collects/tests/scribble/text/i12.ss | 10 - collects/tests/scribble/text/o01.txt | 1 - collects/tests/scribble/text/o02.txt | 8 - collects/tests/scribble/text/o03.txt | 14 - collects/tests/scribble/text/o04.txt | 19 - collects/tests/scribble/text/o05.txt | 25 - collects/tests/scribble/text/o06.txt | 18 - collects/tests/scribble/text/o07.txt | 13 - collects/tests/scribble/text/o08.txt | 10 - collects/tests/scribble/text/o09.txt | 11 - collects/tests/scribble/text/o10.txt | 26 - collects/tests/scribble/text/o11.txt | 7 - collects/tests/scribble/text/o12.txt | 5 - 30 files changed, 1293 insertions(+), 599 deletions(-) delete mode 100644 collects/tests/scribble/text/i01.ss delete mode 100644 collects/tests/scribble/text/i02.ss delete mode 100644 collects/tests/scribble/text/i03.ss delete mode 100644 collects/tests/scribble/text/i03a delete mode 100644 collects/tests/scribble/text/i03b delete mode 100644 collects/tests/scribble/text/i04.ss delete mode 100644 collects/tests/scribble/text/i05.ss delete mode 100644 collects/tests/scribble/text/i06.ss delete mode 100644 collects/tests/scribble/text/i07.ss delete mode 100644 collects/tests/scribble/text/i08.ss delete mode 100644 collects/tests/scribble/text/i09.ss delete mode 100644 collects/tests/scribble/text/i10.ss delete mode 100644 collects/tests/scribble/text/i11.ss delete mode 100644 collects/tests/scribble/text/i12.ss delete mode 100644 collects/tests/scribble/text/o01.txt delete mode 100644 collects/tests/scribble/text/o02.txt delete mode 100644 collects/tests/scribble/text/o03.txt delete mode 100644 collects/tests/scribble/text/o04.txt delete mode 100644 collects/tests/scribble/text/o05.txt delete mode 100644 collects/tests/scribble/text/o06.txt delete mode 100644 collects/tests/scribble/text/o07.txt delete mode 100644 collects/tests/scribble/text/o08.txt delete mode 100644 collects/tests/scribble/text/o09.txt delete mode 100644 collects/tests/scribble/text/o10.txt delete mode 100644 collects/tests/scribble/text/o11.txt delete mode 100644 collects/tests/scribble/text/o12.txt diff --git a/collects/scribble/text/output.ss b/collects/scribble/text/output.ss index 04b32f6208..238b25b4f6 100644 --- a/collects/scribble/text/output.ss +++ b/collects/scribble/text/output.ss @@ -2,7 +2,7 @@ (require scheme/promise) -(provide output splice verbatim unverbatim flush prefix) +(provide output) ;; Outputs some value, for the preprocessor langauge. ;; @@ -68,7 +68,7 @@ ;; the basic printing unit: strings (define (output-string x) (define pfx (mcar pfxs)) - (if (not pfx) ; vervatim mode? + (if (not pfx) ; verbatim mode? (write-string x p) (let ([len (string-length x)] [nls (regexp-match-positions* #rx"\n" x)]) @@ -105,16 +105,13 @@ ;; one, then output the contents recursively (no need to change the ;; state, since we pass the values in the loop, and we'd need to restore ;; it afterwards anyway) - [(pair? x) (let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)] - [npfx (pfx+col (pfx+ pfx lpfx))]) - (set-mcar! pfxs npfx) (set-mcdr! pfxs 0) - (if (list? x) + [(pair? x) (if (list? x) + (let* ([pfx (mcar pfxs)] [lpfx (mcdr pfxs)] + [npfx (pfx+col (pfx+ pfx lpfx))]) + (set-mcar! pfxs npfx) (set-mcdr! pfxs 0) (for ([x (in-list x)]) (loop x)) - (let ploop ([x x]) - (if (pair? x) - (begin (loop (car x)) (ploop (cdr x))) - (loop x)))) - (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx))] + (set-mcar! pfxs pfx) (set-mcdr! pfxs lpfx)) + (begin (loop (car x)) (loop (cdr x))))] ;; delayed values [(and (procedure? x) (procedure-arity-includes? x 0)) (loop (x))] [(promise? x) (loop (force x))] @@ -172,6 +169,10 @@ (set! last (cons p s)) s))))) +;; special constructs + +(provide splice verbatim unverbatim flush prefix) + (define-struct special (flag contents)) (define (splice . contents) (make-special 'splice contents)) @@ -187,3 +188,25 @@ (let ([spaces (make-string n #\space)]) (if (< n 80) (vector-set! v n spaces) (hash-set! t n spaces)) spaces))))) + +;; Convenient utilities + +(provide add-newlines) +(define (add-newlines list #:sep [sep "\n"]) + (define r + (let loop ([list list]) + (if (null? list) + null + (let ([1st (car list)]) + (if (or (not 1st) (void? 1st)) + (loop (cdr list)) + (list* sep 1st (loop (cdr list)))))))) + (if (null? r) r (cdr r))) + +(provide split-lines) +(define (split-lines list) + (let loop ([list list] [cur '()] [r '()]) + (cond + [(null? list) (reverse (cons (reverse cur) r))] + [(equal? "\n" (car list)) (loop (cdr list) '() (cons (reverse cur) r))] + [else (loop (cdr list) (cons (car list) cur) r)]))) diff --git a/collects/scribblings/scribble/preprocessor.scrbl b/collects/scribblings/scribble/preprocessor.scrbl index e502ddc86c..5d34ef68c6 100644 --- a/collects/scribblings/scribble/preprocessor.scrbl +++ b/collects/scribblings/scribble/preprocessor.scrbl @@ -1,6 +1,9 @@ #lang scribble/doc @(require scribble/manual scribble/struct "utils.ss" - (for-label scheme/base)) + (for-label scheme/base + ;; FIXME: need to get this in + ;; scribble/text + )) @initialize-tests @title[#:tag "preprocessor"]{Text Preprocessor} @@ -24,6 +27,12 @@ changes that make it suitable as a preprocessor language: } +@; TODO: +@; * make all example sections be subsections, +@; * add a reference section, +@; * a section on "scribble/text.ss" +@; * maybe a section on additional utilities: begin/text + @;-------------------------------------------------------------------- @section{Writing Preprocessor Files} @@ -44,13 +53,14 @@ part shows the source input, and the right part the printed result.) feature on top of feature, but blah blah blah.}-| -Using @seclink["reader"]|{@-forms}| we can define and use Scheme +Using @seclink["reader"]|{@-forms}|, we can define and use Scheme functions. @example|-{#lang scribble/text @(require scheme/list) @(define Foo "Preprocessing") @(define (3x . x) + ;; scheme syntax here (add-between (list x x x) " ")) @Foo languages should be designed not by piling @@ -65,7 +75,7 @@ functions. As demonstrated in this case, the @scheme[output] function simply scans nested list structures recursively, which makes them convenient for function results. In addition, @scheme[output] prints most values -similarly to @scheme[display] \- a notable exception are void and +similarly to @scheme[display] --- notable exceptions are void and false values which cause no output to appear. This can be used for convenient conditional output. @@ -85,8 +95,8 @@ functions more conveniently too. @example|-{#lang scribble/text @(define (errors n) - @list{@n error@; - @and[(not (= n 1))]{s}}) + ;; note the use of `unless' + @list{@n error@unless[(= n 1)]{s}}) You have @errors[3] in your code, I fixed @errors[1]. ---***--- @@ -108,38 +118,1058 @@ them are ignored. @list{@n error@plural[n]}) You have @errors[3] in your code, - I fixed @errors[1]. + @(define fixed 1) + I fixed @errors[fixed]. ---***--- You have 3 errors in your code, I fixed 1 error.}-| +These end-of-line newline strings are not ignored when they follow +other kinds of expressions, which may lead to redundant empty lines in +the output. + +@example|-{#lang scribble/text + @(define (count n str) + (for/list ([i (in-range 1 (add1 n))]) + @list{@i @str,@"\n"})) + Start... + @count[3]{Mississippi} + ... and I'm done. + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + + ... and I'm done.}-| + +There are several ways to avoid having such empty lines in your +output. The simplest way is to arrange for the function call's form +to end right before the next line begins, but this is often not too +convenient. An alternative is to use a @litchar|{@;}| comment, which +makes the scribble reader ignore everything that follows it up to and +including the newline. (These methods can be applied to the line that +precedes the function call too, but the results are likely to have +what looks like erroneous indentation. More about this below.) + +@example|-{#lang scribble/text + @(define (count n str) + (for/list ([i (in-range 1 (+ n 1))]) + @list{@i @str,@"\n"})) + Start... + @count[3]{Mississippi + }... done once. + + Start again... + @count[3]{Massachusetts}@; + ... and I'm done again. + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + ... done once. + + Start again... + 1 Massachusetts, + 2 Massachusetts, + 3 Massachusetts, + ... and I'm done again.}-| + +A better approach is to generate newlines only when needed. + +@example|-{#lang scribble/text + @(require scheme/list) + @(define (count n str) + (add-between + (for/list ([i (in-range 1 (+ n 1))]) + @list{@i @str,}) + "\n")) + Start... + @count[3]{Mississippi} + ... and I'm done. + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + ... and I'm done.}-| + +In fact, this is common enough that the @scheme[scribble/text] +language provides a convenient facility: @scheme[add-newlines] is a +function that is similar to @scheme[add-between] using a newline +string as the default separator, except that false and void values are +filtered out before doing so. + +@example|-{#lang scribble/text + @(define (count n str) + (add-newlines + (for/list ([i (in-range 1 (+ n 1))]) + @list{@i @str,}))) + Start... + @count[3]{Mississippi} + ... and I'm done. + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + ... and I'm done.}-| + +@example|-{#lang scribble/text + @(define (count n str) + (add-newlines + (for/list ([i (in-range 1 (+ n 1))]) + @(and (even? i) @list{@i @str,})))) + Start... + @count[6]{Mississippi} + ... and I'm done. + ---***--- + Start... + 2 Mississippi, + 4 Mississippi, + 6 Mississippi, + ... and I'm done.}-| + +The separator can be set to any value. + +@example|-{#lang scribble/text + @(define (count n str) + (add-newlines #:sep ",\n" + (for/list ([i (in-range 1 (+ n 1))]) + @list{@i @str}))) + Start... + @count[3]{Mississippi}. + ... and I'm done. + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi. + ... and I'm done.}-| + + +@;-------------------------------------------------------------------- +@section{Defining Functions and More} + +(Note: most of the tips in this section are applicable to any code +that uses the Scribble @"@"-form syntax.) + +Because the Scribble reader is uniform, you can use it in place of any +expression where it is more convenient. (By convention, we use a +plain S-expression syntax when we want a Scheme expression escape, and +an @"@"-form for expressions that render as text, which, in the +@scheme[scribble/text] language, is any value-producing expression.) +For example, you can use an @"@"-form for a function that you define. + +@example|-{#lang scribble/text + @(define @bold[text] @list{*@|text|*}) + An @bold{important} note. + ---***--- + An *important* note. + }-| + +This is not commonly done, since most functions that operate with text +will need to accept a variable number of arguments. In fact, this +leads to a common problem: what if we want to write a function that +consumes a number of ``text arguments'' rathen than a single +``rest-like'' body? The common solution for this is to provide the +separate text arguments in the S-expression part of an @"@"-form. + +@example|-{#lang scribble/text + @(define (choose 1st 2nd) + @list{Either @1st, or @2nd@"."}) + @(define who "us") + @choose[@list{you're with @who} + @list{against @who}] + ---***--- + Either you're with us, or against us. + }-| + +You can even use @"@"-forms with a Scheme quote or quasiquote as the +``head'' part to make it shorter, or use a macro to get grouping of +sub-parts without dealing with quotes. + +@example|-{#lang scribble/text + @(define (choose 1st 2nd) + @list{Either @1st, or @2nd@"."}) + @(define who "us") + @choose[@list{you're with @who} + @list{against @who}] + @(define-syntax-rule (compare (x ...) ...) + (add-newlines + (list (list "* " x ...) ...))) + Shopping list: + @compare[@{apples} + @{oranges} + @{@(* 2 3) bananas}] + ---***--- + Either you're with us, or against us. + Shopping list: + * apples + * oranges + * 6 bananas + }-| + +Yet another solution is to look at the text values and split the input +arguments based on a specific token. Using @scheme[match] can make it +convenient --- you can even specify the patterns with @"@"-forms. + +@example|-{#lang scribble/text + @(require scheme/match) + @(define (features . text) + (match text + [@list{@1st@... + --- + @2nd@...} + @list{>> Pros << + @1st; + >> Cons << + @|2nd|.}])) + @features{fast, + reliable + --- + expensive, + ugly} + ---***--- + >> Pros << + fast, + reliable; + >> Cons << + expensive, + ugly. + }-| + +In particular, it is often convenient to split the input by lines, +identified by delimiting @scheme["\n"] strings. Since this can be +useful, a @scheme[split-lines] function is provided. + +@example|-{#lang scribble/text + @(require scheme/list) + @(define (features . text) + (add-between (split-lines text) + ", ")) + @features{red + fast + reliable}. + ---***--- + red, fast, reliable. + }-| + +Finally, the Scribble reader accepts @emph{any} expression as the head +part of an @"@"-form --- even an @"@" form. This makes it possible to +get a number of text bodies by defining a curried function, where each +step accepts any number of arguments. This, however, means that the +number of body expressions must be fixed. + +@example|-{#lang scribble/text + @(define ((choose . 1st) . 2nd) + @list{Either you're @1st, or @2nd@"."}) + @(define who "me") + @@choose{with @who}{against @who} + ---***--- + Either you're with me, or against me. + }-| + + +@;-------------------------------------------------------------------- +@section{Using Printouts} + +Because the preprocessor language simply displays each toplevel value +as the file is run, it is possible to print text directly as part of +the output. + +@example|-{#lang scribble/text + First + @display{Second} + Third + ---***--- + First + Second + Third}-| + +Taking this further, it is possible to write functions that output +some text @emph{instead} of returning values that represent the text. + +@example|-{#lang scribble/text + @(define (count n) + (for ([i (in-range 1 (+ n 1))]) + (printf "~a Mississippi,\n" i))) + Start... + @count[3]@; avoid an empty line + ... and I'm done. + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + ... and I'm done.}-| + +This can be used to produce a lot of output text, even infinite. + +@example|-{#lang scribble/text + @(define (count n) + (printf "~a Mississippi,\n" n) + (count (add1 n))) + Start... + @count[1] + this line is never printed! + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + 4 Mississippi, + 5 Mississippi, + ...}-| + +However, you should be careful not to mix returning values with +printouts, as the results are rarely desirable. + +@example|-{#lang scribble/text + @list{1 @display{two} 3} + ---***--- + two1 3}-| + +Note that you don't need side-effects if you want infinite output. +The @scheme[output] function iterates thunks and (composable) +promises, so you can create a loop that is delayed in either form. +@; Note: there is some sfs-related problem in mzscheme that makes it not +@; run in bounded space, so don't show it for nowx. + +@example|-{#lang scribble/text + @(define (count n) + (cons @list{@n Mississippi,@"\n"} + (lambda () + (count (add1 n))))) + Start... + @count[1] + this line is never printed! + ---***--- + Start... + 1 Mississippi, + 2 Mississippi, + 3 Mississippi, + 4 Mississippi, + 5 Mississippi, + ...}-| + + +@;-------------------------------------------------------------------- +@section{Indentation in Preprocessed output} + +An issue that can be very important in many preprocessor applications +is the indentation of the output. This can be crucial in some cases, +if you're generating code for an indentation-sensitive language (e.g., +Haskell, Python, or C preprocessor directives). To get a better +understanding of how the pieces interact, you may want to review how +the @seclink["reader"]|{Scribble reader}| section, but also remember +that you can use quoted forms to see how some form is read. + +@example|-{#lang scribble/text + @(format "~s" '@list{ + a + b + c}) + ---***--- + (list "a" "\n" " " "b" "\n" "c")}-| + +The Scribble reader ignores indentation spaces in its body. This is +an intentional feature, since you usually do not want an expression to +depend on its position in the source. But the question is how +@emph{can} we render some output text with proper indentation. The +@scheme[output] function achieves that by assigning a special meaning +to lists: when a newline is part of a list's contents, it causes the +following text to appear with indentation that corresponds to the +column position at the beginning of the list. In most cases, this +makes the output appear ``as intended'' when lists are used for nested +pieces of text --- either from a literal @scheme[list] expression, or +an expression that evaluates to a list, or when a list is passed on as +a value; either as a toplevel expression, or as a nested value; either +appearing after spaces, or after other output. + +@example|-{#lang scribble/text + foo @list{1 + 2 + 3} + ---***--- + foo 1 + 2 + 3}-| + +@example|-{#lang scribble/text + @(define (block . text) + @list{begin + @text + end}) + @block{first + second + @block{ + third + fourth} + last} + ---***--- + begin + first + second + begin + third + fourth + end + last + end}-| + +@example|-{#lang scribble/text + @(define (enumerate . items) + (add-newlines #:sep ";\n" + (for/list ([i (in-naturals 1)] + [item (in-list items)]) + @list{@|i|. @item}))) + Todo: @enumerate[@list{Install PLT Scheme} + @list{Hack, hack, hack} + @list{Profit}]. + ---***--- + Todo: 1. Install PLT Scheme; + 2. Hack, hack, hack; + 3. Profit.}-| + +@example[#:hidden]|-{ + #lang scribble/text + @; demonstrates how indentation is preserved inside lists + begin + a + b + @list{c + d + @list{e + f + g} + h + i + @list{j + k + l} + m + n + o} + p + q + end + ---***--- + begin + a + b + c + d + e + f + g + h + i + j + k + l + m + n + o + p + q + end + }-| + +@example[#:hidden]|-{ + #lang scribble/text + + @list{ + a + + b + } + + c + ---***--- + a + + b + + c + }-| + +@example[#:hidden]|-{ + #lang scribble/text + @; indentation works even when coming from a function + @(define (((if . c) . t) . e) + @list{ + if (@c) + @t + else + @e + fi}) + function foo() { + @list{if (1 < 2) + something1 + else + @@@if{2<3}{something2}{something3} + repeat 3 { + @@@if{2<3}{something2}{something3} + @@@if{2<3}{ + @list{something2.1 + something2.2} + }{ + something3 + } + } + fi} + return + } + ---***--- + function foo() { + if (1 < 2) + something1 + else + if (2<3) + something2 + else + something3 + fi + repeat 3 { + if (2<3) + something2 + else + something3 + fi + if (2<3) + something2.1 + something2.2 + else + something3 + fi + } + fi + return + } + }-| + +@example[#:hidden]|-{ + #lang scribble/text + @; indentation works with a list, even a single string with a newline + @; in a list, but not in a string by itself + function foo() { + prefix + @list{if (1 < 2) + something1 + else + @list{something2 + something3} + @'("something4\nsomething5") + @"something6\nsomething7" + fi} + return + } + @; can be used with a `display', but makes sense only at the top level + @; or in thunks (not demonstrated here) + @(display 123) foo @list{bar1 + bar2 + bar2} + ---***--- + function foo() { + prefix + if (1 < 2) + something1 + else + something2 + something3 + something4 + something5 + something6 + something7 + fi + return + } + 123 foo bar1 + bar2 + bar2 + }-| + +There are, however, cases when you need more refined control over the +output. The @scheme[scribble/text] provides a few functions for such +cases. The @scheme[splice] function is used to group together a +number of values but avoid introducing a new indentation context. + +@example|-{#lang scribble/text + @(define (block . text) + @splice{{ + blah(@text); + }}) + start + @splice{foo(); + loop:} + @list{if (something) @block{one, + two}} + end + ---***--- + start + foo(); + loop: + if (something) { + blah(one, + two); + } + end + }-| + +The @scheme[verbatim] function disables all indentation printouts in +its contents, including the indentation before the verbatim value +itself. It is useful, for example, to print out CPP directives. + +@example|-{#lang scribble/text + @(define (((IFFOO . var) . expr1) . expr2) + (define (array e1 e2) + @list{[@e1, + @e2]}) + @list{var @var; + @verbatim{#ifdef FOO} + @var = @array[expr1 expr2]; + @verbatim{#else} + @var = @array[expr2 expr1]; + @verbatim{#endif}}) + + function blah(something, something_else) { + @verbatim{#include "stuff.inc"} + @@@IFFOO{i}{something}{something_else} + } + ---***--- + function blah(something, something_else) { + #include "stuff.inc" + var i; + #ifdef FOO + i = [something, + something_else]; + #else + i = [something_else, + something]; + #endif + } + }-| + +If there are values after a @scheme[verbatim] value on the same line +will, they will get indented to the goal column (unless the output is +already beyond it). + +@example|-{#lang scribble/text + @(define (thunk name . body) + @list{function @name() { + @body + }}) + @(define (ifdef cond then else) + @list{@verbatim{#}ifdef @cond + @then + @verbatim{#}else + @else + @verbatim{#}endif}) + + @thunk['do_stuff]{ + init(); + @ifdef["HAS_BLAH" + @list{var x = blah();} + @thunk['blah]{ + @ifdef["BLEHOS" + @list{@verbatim{#}include + bleh();} + @list{error("no bleh");}] + }] + more_stuff(); + } + ---***--- + function do_stuff() { + init(); + # ifdef HAS_BLAH + var x = blah(); + # else + function blah() { + # ifdef BLEHOS + # include + bleh(); + # else + error("no bleh"); + # endif + } + # endif + more_stuff(); + } + }-| + +There are cases where each line should be prefixed with some string +other than a plain indentation. The @scheme[prefix] function causes +its contents to be printed using some given string prefix for every +line. The prefix gets accumulated to an existing indentation, and +indentation in the contents gets added to the prefix. + +@example|-{#lang scribble/text + @(define (comment . body) + @prefix["// "]{@body}) + @comment{add : int int -> string} + char *foo(int x, int y) { + @comment{ + skeleton: + allocate a string + print the expression into it + @comment{...more work...} + } + char *buf = malloc(@comment{FIXME! + This is bad} + 100); + } + ---***--- + // add : int int -> string + char *foo(int x, int y) { + // skeleton: + // allocate a string + // print the expression into it + // // ...more work... + char *buf = malloc(// FIXME! + // This is bad + 100); + } + }-| + +Trying to combine @scheme[prefix] and @scheme[verbatim] is more useful +using an additional value: @scheme[flush] is bound to a value that +causes @scheme[output] to print the current indentation and prefix. +It makes it possible to get the ``ignored as a prefix'' property of +@scheme[verbatim] but only for a nested prefix. + +@example|-{#lang scribble/text + @(define (comment . text) + (list flush + @prefix[" *"]{ + @verbatim{/*} @text */})) + function foo(x) { + @comment{blah + more blah + yet more blah} + if (x < 0) { + @comment{even more + blah here + @comment{even + nested}} + do_stuff(); + } + } + ---***--- + function foo(x) { + /* blah + * more blah + * yet more blah */ + if (x < 0) { + /* even more + * blah here + * /* even + * * nested */ */ + do_stuff(); + } + } + }-| + +@example[#:hidden]|-{ + #lang scribble/text + + @(begin + ;; This is a somewhat contrived example, showing how to use lists + ;; and verbatim to control the added prefix + (define (item . text) + ;; notes: the `flush' makes the prefix to that point print so the + ;; verbatim "* " is printed after it, which overwrites the "| " + ;; prefix + (list flush (prefix "| " (verbatim "* ") text))) + ;; note that a simple item with spaces is much easier: + (define (simple . text) @list{* @text})) + + start + @item{blah blah blah + blah blah blah + @item{more stuff + more stuff + more stuff} + blah blah blah + blah blah blah} + @simple{more blah + blah blah} + end + ---***--- + start + * blah blah blah + | blah blah blah + | * more stuff + | | more stuff + | | more stuff + | blah blah blah + | blah blah blah + * more blah + blah blah + end + }-| + + @;-------------------------------------------------------------------- @section{Using External Files} Using additional files that contain code for your preprocessing is -trivial: the preprocessor source is a plain Scheme file, so you can -@scheme[require] additional files as usual. +trivial: the preprocessor source is still source code in a module, so +you can @scheme[require] additional files with utility functions. -However, things can become tricky if you want to include an external -file that should also be preprocessed. Using @scheme[require] with a -text file (that uses the @scheme[scribble/text] language) almost -works, but when a module is required, it is invoked before the current -module, which means that the required file will be preprocessed before -the current file regardless of where the @scheme[require] expression -happens to be. Alternatively, you can use @scheme[dynamic-require] -with @scheme[#f] for the last argument (which makes it similar to a -plain @scheme[load])---but remember that the path will be relative to -the current directory, not to the source file. +@example|-{#lang scribble/text + @(require "itemize.ss") + Todo: + @itemize[@list{Hack some} + @list{Sleep some} + @list{Hack some + more}] + ---***--- itemize.ss + #lang scheme + (provide itemize) + (define (itemize . items) + (add-between (map (lambda (item) + (list "* " item)) + items) + "\n")) + ---***--- + Todo: + * Hack some + * Sleep some + * Hack some + more + }-| -Finally, there is a convenient syntax for including text files to be -processed: +Note that the @seclink["at-exp-lang"]{@scheme[at-exp] language} can +often be useful here, since such files need to deal with texts. Using +it, it is easy to include a lot of textual content. -@defform[(include filename)]{ +@example|-{#lang scribble/text + @(require "stuff.ss") + Todo: + @itemize[@list{Hack some} + @list{Sleep some} + @list{Hack some + more}] + @summary + ---***--- stuff.ss + #lang at-exp scheme/base + (require scheme/list) + (provide (all-defined-out)) + (define (itemize . items) + (add-between (map (lambda (item) + @list{* @item}) + items) + "\n")) + (define summary + @list{If that's not enough, + I don't know what is.}) + ---***--- + Todo: + * Hack some + * Sleep some + * Hack some + more + If that's not enough, + I don't know what is. + }-| -Preprocess the @scheme[filename] using the same syntax as -@scheme[scribble/text]. This is similar to using @scheme[load] in a -namespace that can access names bound in the current file so included -code can refer to bindings from the including module. Note, however, -that the including module cannot refer to names that are bound the -included file because it is still a plain scheme module---for such -uses you should still use @scheme[require] as usual.} +Of course, the extreme side of this will be to put all of your content +in a plain Scheme module, using @"@"-forms for convenience. However, +there is no need to use the preprocessor language in this case; +instead, you can @scheme[(require scribble/text)], which will get all +of the bindings that are available in the @scheme[scribble/text] +language. Using @scheme[output], switching from a preprocessed files +to a Scheme file is very easy ---- choosing one or the other depends +on whether it is more convenient to write a text file with occasional +Scheme expressions or the other way. + +@example|-{#lang at-exp scheme/base + @(require scribble/text scheme/list) + (define (itemize . items) + (add-between (map (lambda (item) + @list{* @item}) + items) + "\n")) + (define summary + @list{If that's not enough, + I don't know what is.}) + @(output + @list{ + Todo: + @itemize[@list{Hack some} + @list{Sleep some} + @list{Hack some + more}] + @summary + }) + ---***--- + Todo: + * Hack some + * Sleep some + * Hack some + more + If that's not enough, + I don't know what is. + }-| + +However, you might run into a case where it is desirable to include a +mostly-text file from a preprocessor file. It might be because you +prefer to split the source text to several files, or because you need +to preprocess a file without even a @litchar{#lang} header (for +example, an HTML template file that is the result of an external +editor). For these cases, the @scheme[scribble/text] language +provides an @scheme[include] form that includes a file in the +preprocessor syntax (where the default parsing mode is text). + + +@example|-{#lang scribble/text + @(require scheme/list) + @(define (itemize . items) + (list + "
    " + (add-between + (map (lambda (item) + @list{
  • @|item|
    • }) + items) + "\n") + "
")) + @(define title "Todo") + @(define summary + @list{If that's not enough, + I don't know what is.}) + + @include["template.html"] + ---***--- template.html + + @|title| + +

@|title|

+ @itemize[@list{Hack some} + @list{Sleep some} + @list{Hack some + more}] +

@|summary|

+ + + ---***--- + + Todo + +

Todo

+
  • Hack some
    • +
  • Sleep some
    • +
  • Hack some + more
+

If that's not enough, + I don't know what is.

+ + + }-| + +(Using @scheme[require] with a text file in the @scheme[scribble/text] +language will not work as intended: using the preprocessor language +means that the text is displayed when the module is invoked, so the +required file's contents will be printed before any of the requiring +module's text does. If you find yourself in such a situation, it is +better to switch to a Scheme-with-@"@"-expressions file as shown +above.) + +@;FIXME: add this to the reference section +@;@defform[(include filename)]{ +@; +@;Preprocess the @scheme[filename] using the same syntax as +@;@scheme[scribble/text]. This is similar to using @scheme[load] in a +@;namespace that can access names bound in the current file so included +@;code can refer to bindings from the including module. Note, however, +@;that the including module cannot refer to names that are bound the +@;included file because it is still a plain scheme module---for such +@;uses you should still use @scheme[require] as usual.} + + +@; Two random tests +@example[#:hidden]|-{ + #lang scribble/text + + @define[name]{PLT Scheme} + + Suggested price list for "@name" + + @; test mutual recursion, throwing away inter-definition spaces + @; <-- this is needed to get only one line of space above + @(define (items-num) + (length items)) + + @(define average + (delay (/ (apply + (map car items)) (length items)))) + + @(define items + (list @list[99]{Home} + @list[149]{Professional} + @list[349]{Enterprize})) + + @(for/list ([i items] [n (in-naturals)]) + @list{@|n|. @name @cadr[i] edition: $@car[i].99 + @||})@; <-- also needed + + Total: @items-num items + Average price: $@|average|.99 + ---***--- + Suggested price list for "PLT Scheme" + + 0. PLT Scheme Home edition: $99.99 + 1. PLT Scheme Professional edition: $149.99 + 2. PLT Scheme Enterprize edition: $349.99 + + Total: 3 items + Average price: $199.99 + }-| +@example[#:hidden]|-{ + #lang scribble/text + + --*-- + @(define (angled . body) (list "<" body ">")) + @(define (shout . body) @angled[(map string-upcase body)]) + @define[z]{blah} + + blah @angled{blah @shout{@z} blah} blah + + @(define-syntax-rule @twice[x] + (list x ", " x)) + + @twice{@twice{blah}} + + @include{inp1} + + @(let ([name "Eli"]) (let ([foo (include "inp2")]) (list foo "\n" foo))) + Repeating yourself much? + ---***--- inp1 + Warning: blah overdose might be fatal + ---***--- inp2 + @(define (foo . xs) (bar xs)) + @(begin (define (isname) @list{is @foo{@name}}) + (define-syntax-rule (DEF x y) (define x y))) + @(DEF (bar x) (list z " " x)) + @(define-syntax-rule (BEG x ...) (begin x ...)) + @(BEG (define z "zee")) + + My name @isname + @DEF[x]{Foo!} + + ... and to that I say "@x", I think. + + ---***--- + --*-- + blah blah> blah + + blah, blah, blah, blah + + Warning: blah overdose might be fatal + + My name is zee Eli + ... and to that I say "Foo!", I think. + My name is zee Eli + ... and to that I say "Foo!", I think. + Repeating yourself much? + }-| diff --git a/collects/scribblings/scribble/utils.ss b/collects/scribblings/scribble/utils.ss index d70962b29b..b51fe4d09e 100644 --- a/collects/scribblings/scribble/utils.ss +++ b/collects/scribblings/scribble/utils.ss @@ -102,25 +102,27 @@ (require scheme/list (for-syntax scheme/base scheme/list)) -(define max-textsample-width 35) +(define max-textsample-width 45) -(define (textsample-verbatim-boxes line 1st 2nd more) +(define (textsample-verbatim-boxes line in-text out-text more) (define (split str) (regexp-split #rx"\n" str)) - (define strs1 (split 1st)) - (define strs2 (split 2nd)) + (define strs1 (split in-text)) + (define strs2 (split out-text)) (define strsm (map (compose split cdr) more)) (define (str->elts str) - (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)]) - (if spaces - (list* (substring str 0 (caar spaces)) - (hspace (- (cdar spaces) (caar spaces))) - (str->elts (substring str (cdar spaces)))) - (list (make-element 'tt (list str)))))) + (if (equal? str "") + (list (make-element 'newline (list ""))) + (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)]) + (if spaces + (list* (substring str 0 (caar spaces)) + (hspace (- (cdar spaces) (caar spaces))) + (str->elts (substring str (cdar spaces)))) + (list (make-element 'tt (list str))))))) (define (make-line str) (list (as-flow (make-element 'tt (str->elts str))))) - (define (make-box strs) (make-table 'boxed (map make-line strs))) - (define box1 (make-box strs1)) - (define box2 (make-box strs2)) - (define boxm (map make-box strsm)) + (define (small-attr attr) + (make-with-attributes attr '([style . "font-size: 82%;"]))) + (define (make-box strs) + (make-table (small-attr 'boxed) (map make-line strs))) (define filenames (map car more)) (define indent (let ([d (- max-textsample-width (for*/fold ([m 0]) @@ -130,20 +132,27 @@ (if (negative? d) (error 'textsample-verbatim-boxes "left box too wide for sample at line ~s" line) - (hspace d)))) + (make-element 'tt (list (hspace d)))))) + ;; Note: the font-size property is reset for every table, so we need it + ;; everywhere there's text, and they don't accumulate for nested tables (values - (make-table '([alignment right left] [valignment top top]) - (cons (list (as-flow indent) (as-flow box1)) + (make-table (make-with-attributes + '([alignment right left] [valignment top top]) + '()) + (cons (list (as-flow (make-table (small-attr #f) + (list (list (as-flow indent))))) + (as-flow (make-box strs1))) (map (lambda (file strs) (let* ([file (make-element 'tt (list file ":" 'nbsp))] [file (list (make-element 'italic (list file)))]) (list (as-flow (make-element '(bg-color 232 232 255) file)) (as-flow (make-box strs))))) filenames strsm))) - box2)) + (make-box strs2))) -(define (textsample line 1st 2nd . more) - (define-values (box1 box2) (textsample-verbatim-boxes line 1st 2nd more)) +(define (textsample line in-text out-text more) + (define-values (box1 box2) + (textsample-verbatim-boxes line in-text out-text more)) (make-table '([alignment left left left] [valignment center center center]) (list (map as-flow (list box1 (make-paragraph '(nbsp rarr nbsp)) box2))))) @@ -164,34 +173,37 @@ (define-syntax (example stx) (define sep-rx #px"^---[*]{3}---(?: +(.*))?$") (define file-rx #rx"^[a-z0-9_.+-]+$") - (syntax-case stx () - [(_ x ...) - (let loop ([xs #'(x ...)] [text '(#f)] [texts '()]) - (syntax-case xs () - [("\n" sep "\n" . xs) - (and (string? (syntax-e #'sep)) - (regexp-match? sep-rx (syntax-e #'sep))) - (let ([m (cond [(regexp-match sep-rx (syntax-e #'sep)) => cadr] - [else #f])]) - (if (and m (not (regexp-match? file-rx m))) - (raise-syntax-error #f "bad filename specified" stx #'sep) - (loop #'xs - (list (and m (datum->syntax #'sep m #'sep #'sep))) - (cons (reverse text) texts))))] - [(x . xs) (loop #'xs (cons #'x text) texts)] - [() (let ([texts (reverse (cons (reverse text) texts))] - [line (syntax-line stx)]) - (define-values (files i/o) (partition car texts)) - (unless ((length i/o) . = . 2) - (raise-syntax-error - 'example "need at least an input and an output block" stx)) - (with-syntax ([line line] - [((i/o ...) ...) (map cdr i/o)] - [((file text ...) ...) files] - [add-to-tests (cadr tests-ids)]) - (syntax/loc stx - (let ([t (list line (string-append i/o ...) ... - (cons file (string-append text ...)) ...)]) - (add-to-tests t) - (apply textsample t)))))] - [_ (raise-syntax-error #f "no separator found in example text")]))])) + (define-values (body hidden?) + (syntax-case stx () + [(_ #:hidden x ...) (values #'(x ...) #t)] + [(_ x ...) (values #'(x ...) #f)])) + (let loop ([xs body] [text '(#f)] [texts '()]) + (syntax-case xs () + [("\n" sep "\n" . xs) + (and (string? (syntax-e #'sep)) (regexp-match? sep-rx (syntax-e #'sep))) + (let ([m (cond [(regexp-match sep-rx (syntax-e #'sep)) => cadr] + [else #f])]) + (if (and m (not (regexp-match? file-rx m))) + (raise-syntax-error #f "bad filename specified" stx #'sep) + (loop #'xs + (list (and m (datum->syntax #'sep m #'sep #'sep))) + (cons (reverse text) texts))))] + [(x . xs) (loop #'xs (cons #'x text) texts)] + [() (let ([texts (reverse (cons (reverse text) texts))] + [line (syntax-line stx)]) + (define-values (files i/o) (partition car texts)) + (unless ((length i/o) . = . 2) + (raise-syntax-error + 'example "need at least an input and an output block" stx)) + (with-syntax ([line line] + [((in ...) (out ...)) (map cdr i/o)] + [((file text ...) ...) files] + [add-to-tests (cadr tests-ids)]) + (quasisyntax/loc stx + (let* ([in-text (string-append in ...)] + [out-text (string-append out ...)] + [more (list (cons file (string-append text ...)) ...)]) + (add-to-tests (list line in-text out-text more)) + #,(if hidden? #'"" + #'(textsample line in-text out-text more))))))] + [_ (raise-syntax-error #f "no separator found in example text")]))) diff --git a/collects/tests/scribble/main.ss b/collects/tests/scribble/main.ss index b14650880b..15ba5bbd7e 100644 --- a/collects/tests/scribble/main.ss +++ b/collects/tests/scribble/main.ss @@ -1,107 +1,147 @@ #lang scheme/base -(require tests/eli-tester scribble/text/syntax-utils scheme/runtime-path - scheme/sandbox (lib "scribblings/scribble/preprocessor.scrbl")) +(require tests/eli-tester scribble/text/syntax-utils + scheme/runtime-path scheme/port scheme/sandbox + (prefix-in doc: (lib "scribblings/scribble/preprocessor.scrbl"))) (define-runtime-path text-dir "text") (define-runtime-path this-dir ".") -(test +(define (tests) + (begin/collect-tests) + (preprocessor-tests)) - ;; begin/collect scope etc - (begin/collect 1) => 1 - (begin/collect 1 2 3) => '(1 2 3) - (begin/collect) => '() - (begin/collect (define x 1) x) => 1 - (begin/collect (define x 1)) => '() - (begin/collect (define x 1) x x x) => '(1 1 1) - (begin/collect (define x 1) (define y 2) x y x y) => '(1 2 1 2) - (begin/collect (define x 1) x (define y 2) y) => '(1 2) - (begin/collect (define x 1) x (define y 2)) => '(1) - (begin/collect (define x 1) x x (define y 2) y y) => '(1 1 2 2) - (begin/collect (define x 1) x (define x 2) x) => '(1 2) - (begin/collect (define x 1) x x (define x 2) x x) => '(1 1 2 2) - (begin/collect (define (x) y) (define y 1) (x) (x) (x)) => '(1 1 1) - (begin/collect (define x 1) x (define y 2) x) => '(1 1) - (begin/collect (define x 1) x x (define y 2) x x) => '(1 1 1 1) - (begin/collect (define x 1) x x (define y x) y y) => '(1 1 1 1) - (begin/collect (define (x) y) (define y 1) (x) (x) - (define (x) y) (define y 2) (x) (x)) - => '(1 1 2 2) - (begin/collect (define-syntax-rule (DEF x y) (define x y)) (DEF x 1) x x) - => '(1 1) - (begin/collect (define-syntax-rule (DEF x y) (define x y)) 1 (DEF x 2) x) - => '(1 2) - (begin/collect (define-syntax-rule (DEF x y) (define x y)) - (DEF x 1) x x - (DEF x 2) x x) - => '(1 1 2 2) - (begin/collect (define (x) y) - (define-syntax-rule (DEF x y) (define x y)) - (DEF y 1) (x) (x) - (DEF y 2) (x) (x)) - => '(1 1 1 1) - (let ([y 1]) (begin/collect y y (define x y) x y x)) => '(1 1 1 1 1) - (let ([y 1]) (begin/collect y y (define y 2) y y)) => '(1 1 2 2) - (let ([y 1]) (begin/collect (define (x) y) (x) (x))) => '(1 1) - (let ([y 1]) (begin/collect (define (x) y) (define y 2) (x) (x))) => '(2 2) - (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y)) - => '(1 1 2 2) - (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y (x))) - => '(1 1 2 2 1) - (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) (x) y y)) - => '(1 1 1 2 2) - (begin/collect (begin (define (x) y) - (define-syntax-rule (DEF x y) (define x y)) - (define y 2)) - (x) (x)) - => '(2 2) - (begin/collect (define (x) y) - (begin (define-syntax-rule (DEF x y) (define x y)) - (define y 2)) - (x) (x)) - => '(2 2) - (begin/collect (define (x) y) - (define-syntax-rule (DEF x y) (define x y)) - (begin (define y 2)) - (x) (x)) - => '(2 2) - (begin/collect (begin (begin (begin (define (x) y)) - (begin (define-syntax-rule (DEF x y) - (define x y)))) - (begin (begin (define y 2)) - (begin (x))) - (begin (x)))) - => '(2 2) - (begin/collect 1 - (define (f x #:< [< "<"] #:> [> ">"]) (list < x >)) - (f 1) - (f #:< "[" 2) - (f 3 #:> "]" #:< "[")) - => '(1 ("<" 1 ">") ("[" 2 ">") ("[" 3 "]")) +(define (begin/collect-tests) + (test - ;; preprocessor tests - (parameterize ([current-directory text-dir]) - (for ([ifile (map path->string (directory-list))] - #:when (and (file-exists? ifile) - (regexp-match? #rx"^i[0-9]+\\.ss$" ifile))) - (define ofile (regexp-replace #rx"^i([0-9]+)\\..*$" ifile "o\\1.txt")) - (define expected (call-with-input-file ofile - (lambda (i) (read-bytes (file-size ofile) i)))) - (define o (open-output-bytes)) - (parameterize ([current-output-port o]) - (dynamic-require (path->complete-path ifile) #f)) - (test (get-output-bytes o) => expected))) - ;; preprocessor tests that are part of the documentation - (parameterize ([current-directory this-dir] - [sandbox-output 'string] - [sandbox-error-output current-output-port]) - (define (text-test line in out . more) - (define e (make-module-evaluator in)) - (test - #:failure-message (format "preprocessor test failure at line ~s" line) - (equal? (get-output e) out))) - (call-with-trusted-sandbox-configuration - (lambda () (for ([t (in-list (tests))]) (apply text-test t))))) + ;; begin/collect scope etc + (begin/collect 1) => 1 + (begin/collect 1 2 3) => '(1 2 3) + (begin/collect) => '() + (begin/collect (define x 1) x) => 1 + (begin/collect (define x 1)) => '() + (begin/collect (define x 1) x x x) => '(1 1 1) + (begin/collect (define x 1) (define y 2) x y x y) => '(1 2 1 2) + (begin/collect (define x 1) x (define y 2) y) => '(1 2) + (begin/collect (define x 1) x (define y 2)) => '(1) + (begin/collect (define x 1) x x (define y 2) y y) => '(1 1 2 2) + (begin/collect (define x 1) x (define x 2) x) => '(1 2) + (begin/collect (define x 1) x x (define x 2) x x) => '(1 1 2 2) + (begin/collect (define (x) y) (define y 1) (x) (x) (x)) => '(1 1 1) + (begin/collect (define x 1) x (define y 2) x) => '(1 1) + (begin/collect (define x 1) x x (define y 2) x x) => '(1 1 1 1) + (begin/collect (define x 1) x x (define y x) y y) => '(1 1 1 1) + (begin/collect (define (x) y) (define y 1) (x) (x) + (define (x) y) (define y 2) (x) (x)) + => '(1 1 2 2) + (begin/collect (define-syntax-rule (DEF x y) (define x y)) (DEF x 1) x x) + => '(1 1) + (begin/collect (define-syntax-rule (DEF x y) (define x y)) 1 (DEF x 2) x) + => '(1 2) + (begin/collect (define-syntax-rule (DEF x y) (define x y)) + (DEF x 1) x x + (DEF x 2) x x) + => '(1 1 2 2) + (begin/collect (define (x) y) + (define-syntax-rule (DEF x y) (define x y)) + (DEF y 1) (x) (x) + (DEF y 2) (x) (x)) + => '(1 1 1 1) + (let ([y 1]) (begin/collect y y (define x y) x y x)) => '(1 1 1 1 1) + (let ([y 1]) (begin/collect y y (define y 2) y y)) => '(1 1 2 2) + (let ([y 1]) (begin/collect (define (x) y) (x) (x))) => '(1 1) + (let ([y 1]) (begin/collect (define (x) y) (define y 2) (x) (x))) => '(2 2) + (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y)) + => '(1 1 2 2) + (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) y y (x))) + => '(1 1 2 2 1) + (let ([y 1]) (begin/collect (define (x) y) (x) (x) (define y 2) (x) y y)) + => '(1 1 1 2 2) + (begin/collect (begin (define (x) y) + (define-syntax-rule (DEF x y) (define x y)) + (define y 2)) + (x) (x)) + => '(2 2) + (begin/collect (define (x) y) + (begin (define-syntax-rule (DEF x y) (define x y)) + (define y 2)) + (x) (x)) + => '(2 2) + (begin/collect (define (x) y) + (define-syntax-rule (DEF x y) (define x y)) + (begin (define y 2)) + (x) (x)) + => '(2 2) + (begin/collect (begin (begin (begin (define (x) y)) + (begin (define-syntax-rule (DEF x y) + (define x y)))) + (begin (begin (define y 2)) + (begin (x))) + (begin (x)))) + => '(2 2) + (begin/collect 1 + (define (f x #:< [< "<"] #:> [> ">"]) (list < x >)) + (f 1) + (f #:< "[" 2) + (f 3 #:> "]" #:< "[")) + => '(1 ("<" 1 ">") ("[" 2 ">") ("[" 3 "]")) - ) + )) + +(define (preprocessor-tests) + ;; (sample-file-tests) + (in-documentation-tests)) + +(define (sample-file-tests) + (parameterize ([current-directory text-dir]) + (for ([ifile (map path->string (directory-list))] + #:when (and (file-exists? ifile) + (regexp-match? #rx"^i[0-9]+\\.ss$" ifile))) + (define ofile (regexp-replace #rx"^i([0-9]+)\\..*$" ifile "o\\1.txt")) + (define expected (call-with-input-file ofile + (lambda (i) (read-bytes (file-size ofile) i)))) + (define o (open-output-bytes)) + (parameterize ([current-output-port o]) + (dynamic-require (path->complete-path ifile) #f)) + (test (get-output-bytes o) => expected)))) + +(define (in-documentation-tests) + (define (text-test line in-text out-text more) + (define-values (i o) (make-pipe 512)) + (define-values (expected len-to-read) + (let ([m (regexp-match-positions #rx"\n\\.\\.\\.$" out-text)]) + (if m + (values (substring out-text 0 (caar m)) (caar m)) + (values out-text #f)))) + ;; test with name indicating the source + (define-syntax-rule (t . stuff) + (test ;#:failure-message + ;(format "preprocessor test failure at line ~s" line) + . stuff)) + (parameterize ([current-directory this-dir] + [sandbox-output o] + [sandbox-error-output current-output-port]) + (define exn #f) + (define thd #f) + (define (run) + ;; only need to evaluate the module, so we have its output; but do that + ;; in a thread, since we might want to look at just a prefix of an + ;; infinite output + (with-handlers ([void (lambda (e) (set! exn e))]) + (make-module-evaluator in-text) + (close-output-port o))) + (for ([m more]) + (call-with-output-file (car m) #:exists 'truncate + (lambda (o) (display (cdr m) o)))) + (set! thd (thread run)) + (t (with-limits 1 #f + (if len-to-read (read-string len-to-read i) (port->string i))) + => expected) + (t (begin (kill-thread thd) (cond [exn => raise] [else #t]))))) + (call-with-trusted-sandbox-configuration + (lambda () + (for ([t (in-list (doc:tests))]) + (begin (apply text-test t)))))) + +;; run all +(test do (tests)) diff --git a/collects/tests/scribble/text/i01.ss b/collects/tests/scribble/text/i01.ss deleted file mode 100644 index 3769a0749e..0000000000 --- a/collects/tests/scribble/text/i01.ss +++ /dev/null @@ -1,3 +0,0 @@ -#lang scribble/text - -foo diff --git a/collects/tests/scribble/text/i02.ss b/collects/tests/scribble/text/i02.ss deleted file mode 100644 index ad930c26c5..0000000000 --- a/collects/tests/scribble/text/i02.ss +++ /dev/null @@ -1,25 +0,0 @@ -#lang scribble/text - -@define[name]{PLT Scheme} - -Suggested price list for "@name" - -@; test mutual recursion, throwing away inter-definition spaces -@; <-- this is needed to get only one line of space above -@(define (items-num) - (length items)) - -@(define average - (delay (/ (apply + (map car items)) (length items)))) - -@(define items - (list @list[99]{Home} - @list[149]{Professional} - @list[349]{Enterprize})) - -@(for/list ([i items] [n (in-naturals)]) - @list{@|n|. @name @cadr[i] edition: $@car[i].99 - @||})@; <-- also needed - -Total: @items-num items -Average price: $@|average|.99 diff --git a/collects/tests/scribble/text/i03.ss b/collects/tests/scribble/text/i03.ss deleted file mode 100644 index ee9d7f9ea9..0000000000 --- a/collects/tests/scribble/text/i03.ss +++ /dev/null @@ -1,18 +0,0 @@ -#lang scribble/text - ----***--- -@(define (angled . body) (list "<" body ">")) - @(define (shout . body) @angled[(map string-upcase body)]) - @define[z]{blah} - -blah @angled{blah @shout{@z} blah} blah - -@(define-syntax-rule @twice[x] - (list x ", " x)) - -@twice{@twice{blah}} - -@include{i03a} - -@(let ([name "Eli"]) (let ([foo (include "i03b")]) (list foo "\n" foo))) -Repeating yourself much? diff --git a/collects/tests/scribble/text/i03a b/collects/tests/scribble/text/i03a deleted file mode 100644 index e1009c1cda..0000000000 --- a/collects/tests/scribble/text/i03a +++ /dev/null @@ -1 +0,0 @@ -Warning: blah overdose might be fatal diff --git a/collects/tests/scribble/text/i03b b/collects/tests/scribble/text/i03b deleted file mode 100644 index 9037c24a65..0000000000 --- a/collects/tests/scribble/text/i03b +++ /dev/null @@ -1,12 +0,0 @@ -@(define (foo . xs) (bar xs)) -@(begin (define (isname) @list{is @foo{@name}}) - (define-syntax-rule (DEF x y) (define x y))) -@(DEF (bar x) (list z " " x)) -@(define-syntax-rule (BEG x ...) (begin x ...)) -@(BEG (define z "zee")) - -My name @isname -@DEF[x]{Foo!} - - ... and to that I say "@x", I think. - diff --git a/collects/tests/scribble/text/i04.ss b/collects/tests/scribble/text/i04.ss deleted file mode 100644 index 6482834867..0000000000 --- a/collects/tests/scribble/text/i04.ss +++ /dev/null @@ -1,24 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@; demonstrates how indentation is preserved inside lists - -begin - a - b - @list{c - d - @list{e - f - g} - h - i - @list{j - k - l} - m - n - o} - p - q -end diff --git a/collects/tests/scribble/text/i05.ss b/collects/tests/scribble/text/i05.ss deleted file mode 100644 index f82514de3d..0000000000 --- a/collects/tests/scribble/text/i05.ss +++ /dev/null @@ -1,30 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@(define (((if . c) . t) . e) - @list{ - if (@c) - @t - else - @e - fi}) - -@; indentation works even when coming from a function - -function foo() { - @list{if (1 < 2) - something1 - else - @@@if{2<3}{something2}{something3} - repeat 3 { - @@@if{2<3}{something2}{something3} - @@@if{2<3}{ - @list{something2.1 - something2.2} - }{ - something3 - } - } - fi} - return -} diff --git a/collects/tests/scribble/text/i06.ss b/collects/tests/scribble/text/i06.ss deleted file mode 100644 index e79db613e9..0000000000 --- a/collects/tests/scribble/text/i06.ss +++ /dev/null @@ -1,25 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@; indentation works with a list, even a single string with a newline -@; in a list, but not in a string by itself - -function foo() { - prefix - @list{if (1 < 2) - something1 - else - @list{something2 - something3} - @'("something4\nsomething5") - @"something6\nsomething7" - fi} - return -} - -@; can be used with a `display', but makes sense only at the top level -@; or in thunks (not demonstrated here) -@; -@(display 123) foo @list{bar1 - bar2 - bar2} diff --git a/collects/tests/scribble/text/i07.ss b/collects/tests/scribble/text/i07.ss deleted file mode 100644 index 193c1ce637..0000000000 --- a/collects/tests/scribble/text/i07.ss +++ /dev/null @@ -1,18 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@; demonstrates using a prefix - -function foo() { - var lst = [@list{item1, - item2}] - @prefix["//"]{ comment1 - comment2 - comment3 - @list{comment4 - comment5 - comment6} - @prefix["*"]{ more - stuff}} - return -} diff --git a/collects/tests/scribble/text/i08.ss b/collects/tests/scribble/text/i08.ss deleted file mode 100644 index 97227b7515..0000000000 --- a/collects/tests/scribble/text/i08.ss +++ /dev/null @@ -1,17 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@; using verbatim -@(define (((foo . var) . expr1) . expr2) - @list{int var; - @verbatim{#ifdef FOO} - var = [@expr1, - @expr2]; - @verbatim{#else} - var = [@expr2, - @expr1]; - @verbatim{#endif}}) - -int blah() { - @@@foo{i}{something}{something_else} -} diff --git a/collects/tests/scribble/text/i09.ss b/collects/tests/scribble/text/i09.ss deleted file mode 100644 index 59973b2abf..0000000000 --- a/collects/tests/scribble/text/i09.ss +++ /dev/null @@ -1,25 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@(begin - ;; This is a somewhat contrived example, showing how to use lists - ;; and verbatim to control the added prefix - (define (item . text) - ;; notes: the `flush' makes the prefix to that point print so the - ;; verbatim "* " is printed after it, which overwrites the "| " - ;; prefix - (cons flush (prefix "| " (cons (verbatim "* ") text)))) - ;; note that a simple item with spaces is much easier: - (define (simple . text) @list{* @text})) - -start - @item{blah blah blah - blah blah blah - @item{more stuff - more stuff - more stuff} - blah blah blah - blah blah blah} - @simple{more blah - blah blah} -end diff --git a/collects/tests/scribble/text/i10.ss b/collects/tests/scribble/text/i10.ss deleted file mode 100644 index 42592fd76e..0000000000 --- a/collects/tests/scribble/text/i10.ss +++ /dev/null @@ -1,33 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@(define (((if . c) . t) . e) - @list{if (@c) - @t - else - @e - fi}) - -function foo() { - @prefix["//"]{ comment1 - comment2 @list{comment3 - comment4}} - var x = [@list{item1, - item2}] - bar1 - @list{if (1 < 2) - @list{something1 - something2 - something3} - else - @@@if{2 < 3}{something_else}{something_completely_different} - @@@if{3 < 4}{ - another_something_else1 - another_something_else2 - }{ - another_something_completely_different - } - fi - } - return; -} diff --git a/collects/tests/scribble/text/i11.ss b/collects/tests/scribble/text/i11.ss deleted file mode 100644 index 558c6a224e..0000000000 --- a/collects/tests/scribble/text/i11.ss +++ /dev/null @@ -1,13 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - -@(define (block x) - @splice{{ - blah(@x); - }}) - -start - @splice{foo(); - loop:} - @list{if (something) @block{stuff}} -end diff --git a/collects/tests/scribble/text/i12.ss b/collects/tests/scribble/text/i12.ss deleted file mode 100644 index 397ef801ff..0000000000 --- a/collects/tests/scribble/text/i12.ss +++ /dev/null @@ -1,10 +0,0 @@ -#!/bin/env mzscheme -#lang scribble/text - - @list{ - a - - b - } - - c diff --git a/collects/tests/scribble/text/o01.txt b/collects/tests/scribble/text/o01.txt deleted file mode 100644 index 257cc5642c..0000000000 --- a/collects/tests/scribble/text/o01.txt +++ /dev/null @@ -1 +0,0 @@ -foo diff --git a/collects/tests/scribble/text/o02.txt b/collects/tests/scribble/text/o02.txt deleted file mode 100644 index 405a0abf33..0000000000 --- a/collects/tests/scribble/text/o02.txt +++ /dev/null @@ -1,8 +0,0 @@ -Suggested price list for "PLT Scheme" - -0. PLT Scheme Home edition: $99.99 -1. PLT Scheme Professional edition: $149.99 -2. PLT Scheme Enterprize edition: $349.99 - -Total: 3 items -Average price: $199.99 diff --git a/collects/tests/scribble/text/o03.txt b/collects/tests/scribble/text/o03.txt deleted file mode 100644 index a23359348e..0000000000 --- a/collects/tests/scribble/text/o03.txt +++ /dev/null @@ -1,14 +0,0 @@ ----***--- -blah blah> blah - -blah, blah, blah, blah - -Warning: blah overdose might be fatal - -My name is zee Eli - ... and to that I say "Foo!", I think. - -My name is zee Eli - ... and to that I say "Foo!", I think. - -Repeating yourself much? diff --git a/collects/tests/scribble/text/o04.txt b/collects/tests/scribble/text/o04.txt deleted file mode 100644 index a132abf8d8..0000000000 --- a/collects/tests/scribble/text/o04.txt +++ /dev/null @@ -1,19 +0,0 @@ -begin - a - b - c - d - e - f - g - h - i - j - k - l - m - n - o - p - q -end diff --git a/collects/tests/scribble/text/o05.txt b/collects/tests/scribble/text/o05.txt deleted file mode 100644 index 219a2e7e9d..0000000000 --- a/collects/tests/scribble/text/o05.txt +++ /dev/null @@ -1,25 +0,0 @@ -function foo() { - if (1 < 2) - something1 - else - if (2<3) - something2 - else - something3 - fi - repeat 3 { - if (2<3) - something2 - else - something3 - fi - if (2<3) - something2.1 - something2.2 - else - something3 - fi - } - fi - return -} diff --git a/collects/tests/scribble/text/o06.txt b/collects/tests/scribble/text/o06.txt deleted file mode 100644 index 48c61d96f4..0000000000 --- a/collects/tests/scribble/text/o06.txt +++ /dev/null @@ -1,18 +0,0 @@ -function foo() { - prefix - if (1 < 2) - something1 - else - something2 - something3 - something4 - something5 - something6 - something7 - fi - return -} - -123 foo bar1 - bar2 - bar2 diff --git a/collects/tests/scribble/text/o07.txt b/collects/tests/scribble/text/o07.txt deleted file mode 100644 index e891777ab8..0000000000 --- a/collects/tests/scribble/text/o07.txt +++ /dev/null @@ -1,13 +0,0 @@ -function foo() { - var lst = [item1, - item2] - // comment1 - // comment2 - // comment3 - // comment4 - // comment5 - // comment6 - // * more - // * stuff - return -} diff --git a/collects/tests/scribble/text/o08.txt b/collects/tests/scribble/text/o08.txt deleted file mode 100644 index 4474770d83..0000000000 --- a/collects/tests/scribble/text/o08.txt +++ /dev/null @@ -1,10 +0,0 @@ -int blah() { - int var; -#ifdef FOO - var = [something, - something_else]; -#else - var = [something_else, - something]; -#endif -} diff --git a/collects/tests/scribble/text/o09.txt b/collects/tests/scribble/text/o09.txt deleted file mode 100644 index 583c738b1c..0000000000 --- a/collects/tests/scribble/text/o09.txt +++ /dev/null @@ -1,11 +0,0 @@ -start - * blah blah blah - | blah blah blah - | * more stuff - | | more stuff - | | more stuff - | blah blah blah - | blah blah blah - * more blah - blah blah -end diff --git a/collects/tests/scribble/text/o10.txt b/collects/tests/scribble/text/o10.txt deleted file mode 100644 index 50d405d59a..0000000000 --- a/collects/tests/scribble/text/o10.txt +++ /dev/null @@ -1,26 +0,0 @@ -function foo() { - // comment1 - // comment2 comment3 - // comment4 - var x = [item1, - item2] - bar1 - if (1 < 2) - something1 - something2 - something3 - else - if (2 < 3) - something_else - else - something_completely_different - fi - if (3 < 4) - another_something_else1 - another_something_else2 - else - another_something_completely_different - fi - fi - return; -} diff --git a/collects/tests/scribble/text/o11.txt b/collects/tests/scribble/text/o11.txt deleted file mode 100644 index 46bef0f064..0000000000 --- a/collects/tests/scribble/text/o11.txt +++ /dev/null @@ -1,7 +0,0 @@ -start - foo(); -loop: - if (something) { - blah(stuff); - } -end diff --git a/collects/tests/scribble/text/o12.txt b/collects/tests/scribble/text/o12.txt deleted file mode 100644 index 2a9aec7436..0000000000 --- a/collects/tests/scribble/text/o12.txt +++ /dev/null @@ -1,5 +0,0 @@ - a - - b - - c From a1455d8fe6d9c83f86f24aad74f80397d93e901e Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 21 Mar 2009 15:24:05 +0000 Subject: [PATCH 095/140] fix safe-for-safe problems with tail-call trampoline svn: r14203 --- src/mzscheme/src/eval.c | 17 +++++++++++++ src/mzscheme/src/jit.c | 48 +++++++++++++++++++++++++++++++++++- src/mzscheme/src/schnapp.inc | 12 ++++++++- 3 files changed, 75 insertions(+), 2 deletions(-) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index dcb3562b7a..dc9441b193 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -7543,6 +7543,7 @@ void scheme_escape_to_continuation(Scheme_Object *obj, int num_rands, Scheme_Obj Scheme_Object * scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, int get_value) + /* If rands == MZ_RUNSTACK on entry, rands elements can be modified. */ { Scheme_Type type; Scheme_Object *v; @@ -7930,6 +7931,14 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, v = data->code(obj, num_rands, rands); + if (v == SCHEME_TAIL_CALL_WAITING) { + /* [TC-SFS]; see schnapp.inc */ + if (rands == old_runstack) { + int i; + for (i = 0; i < num_rands; i++) { rands[i] = NULL; } + } + } + DEBUG_CHECK_TYPE(v); #endif } else if (type == scheme_cont_type) { @@ -8009,6 +8018,14 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, v = prim->prim_val(prim->data, num_rands, rands); + if (v == SCHEME_TAIL_CALL_WAITING) { + /* [TC-SFS]; see schnapp.inc */ + if (rands == old_runstack) { + int i; + for (i = 0; i < num_rands; i++) { rands[i] = NULL; } + } + } + DEBUG_CHECK_TYPE(v); } else { UPDATE_THREAD_RSPTR_FOR_ERROR(); diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 05fcfb6ea3..224749bcd4 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -631,6 +631,15 @@ static Scheme_Object *tail_call_with_values_from_multiple_result(Scheme_Object * return scheme_tail_apply(f, num_rands, p->ku.multiple.array); } +static Scheme_Object *clear_runstack(long amt, Scheme_Object *sv) +{ + int i; + for (i = 0; i < amt; i++) { + MZ_RUNSTACK[i] = NULL; + } + return sv; +} + /*========================================================================*/ /* code-gen utils */ /*========================================================================*/ @@ -1981,7 +1990,7 @@ static int generate_retry_call(mz_jit_state *jitter, int num_rands, int multi_ok jit_subr_l(JIT_RUNSTACK, JIT_RUNSTACK, JIT_R2); CHECK_RUNSTACK_OVERFLOW(); - /* Copy argument to runstack, then jump to reftop. */ + /* Copy arguments to runstack, then jump to reftop. */ jit_ldxi_l(JIT_R2, JIT_R1, &((Scheme_Thread *)0x0)->ku.apply.tail_num_rands); jit_ldxi_l(JIT_V1, JIT_R1, &((Scheme_Thread *)0x0)->ku.apply.tail_rands); jit_lshi_l(JIT_R2, JIT_R2, JIT_LOG_WORD_SIZE); @@ -2010,6 +2019,31 @@ static int generate_retry_call(mz_jit_state *jitter, int num_rands, int multi_ok return 1; } +static int generate_clear_previous_args(mz_jit_state *jitter, int num_rands) +{ + if (num_rands >= 0) { + int i; + for (i = 0; i < num_rands; i++) { + jit_stxi_p(WORDS_TO_BYTES(i), JIT_RUNSTACK, JIT_RUNSTACK); + CHECK_LIMIT(); + } + } else { + /* covered by generate_clear_slow_previous_args */ + } + return 1; +} + +static int generate_clear_slow_previous_args(mz_jit_state *jitter) +{ + CHECK_LIMIT(); + mz_prepare(2); + jit_pusharg_p(JIT_R0); + jit_pusharg_l(JIT_V1); + mz_finish(clear_runstack); + jit_retval(JIT_R0); + return 1; +} + static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direct_native, int need_set_rs, int multi_ok, int nontail_self, int pop_and_jump) { @@ -2152,6 +2186,8 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc __START_SHORT_JUMPS__(1); } ref6 = jit_bnei_p(jit_forward(), JIT_R0, SCHEME_TAIL_CALL_WAITING); + generate_clear_previous_args(jitter, num_rands); + CHECK_LIMIT(); if (pop_and_jump) { /* Expects argc in V1 if num_rands < 0: */ generate_retry_call(jitter, num_rands, multi_ok, reftop); @@ -2160,6 +2196,10 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc if (need_set_rs) { JIT_UPDATE_THREAD_RSPTR(); } + if (num_rands < 0) { + generate_clear_slow_previous_args(jitter); + CHECK_LIMIT(); + } mz_prepare(1); jit_pusharg_p(JIT_R0); if (multi_ok) { @@ -2203,11 +2243,17 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc __START_SHORT_JUMPS__(1); } ref10 = jit_bnei_p(jit_forward(), JIT_R0, SCHEME_TAIL_CALL_WAITING); + generate_clear_previous_args(jitter, num_rands); + CHECK_LIMIT(); if (pop_and_jump) { /* Expects argc in V1 if num_rands < 0: */ generate_retry_call(jitter, num_rands, multi_ok, reftop); } CHECK_LIMIT(); + if (num_rands < 0) { + generate_clear_slow_previous_args(jitter); + CHECK_LIMIT(); + } mz_prepare(1); jit_pusharg_p(JIT_R0); if (multi_ok) { diff --git a/src/mzscheme/src/schnapp.inc b/src/mzscheme/src/schnapp.inc index 50baa5bd18..275cc877f4 100644 --- a/src/mzscheme/src/schnapp.inc +++ b/src/mzscheme/src/schnapp.inc @@ -3,6 +3,13 @@ scheme_do_eval()'s increment, because this might be the continuation of a tail call. */ +/* The arguments in argv are in the runstack. If computation can go + back into native code, those arguments should not live past the + native-code call. The native code clears/reuses arguments itself if + they are on the stack, but there's a problem if a tail buffer leads + to new pushes onto the run stack. We handle this with code marked + [TC-SFS]. */ + /* This code is written in such a way that xform can see that no GC cooperation is needed. */ @@ -26,8 +33,11 @@ static MZ_INLINE Scheme_Object *PRIM_APPLY_NAME_FAST(Scheme_Object *rator, v = f(argc, argv, (Scheme_Object *)prim); #if PRIM_CHECK_VALUE - if (v == SCHEME_TAIL_CALL_WAITING) + if (v == SCHEME_TAIL_CALL_WAITING) { + int i; + for (i = 0; i < argc; i++) { argv[i] = NULL; } /* [TC-SFS]; see above */ v = scheme_force_value_same_mark(v); + } #endif #if PRIM_CHECK_MULTI From 27a67c9c1a68f6cced96bbc01a991914566d4849 Mon Sep 17 00:00:00 2001 From: John Clements Date: Sat, 21 Mar 2009 21:28:16 +0000 Subject: [PATCH 096/140] ... svn: r14204 --- .../tests/stepper/language-level-model.ss | 59 + collects/tests/stepper/test-engine.ss | 241 ++ collects/tests/stepper/through-tests.ss | 2366 ++++++++--------- 3 files changed, 1344 insertions(+), 1322 deletions(-) create mode 100644 collects/tests/stepper/language-level-model.ss create mode 100644 collects/tests/stepper/test-engine.ss diff --git a/collects/tests/stepper/language-level-model.ss b/collects/tests/stepper/language-level-model.ss new file mode 100644 index 0000000000..f7983f888e --- /dev/null +++ b/collects/tests/stepper/language-level-model.ss @@ -0,0 +1,59 @@ +#lang scheme/base + +(require stepper/private/model-settings) + +(provide (all-defined-out)) + +;; DEFINING A LANGUAGE FOR THE PURPOSES OF TESTING + +;; ll-model : a representation of the behavior of a language level w.r.t. the stepper +(define-struct ll-model (namespace-spec teachpack-specs render-settings show-lambdas-as-lambdas? enable-testing?)) + +;; the built-in ll-models: +(define mz + (make-ll-model 'mzscheme `() fake-mz-render-settings #t #f)) + +(define beginner + (make-ll-model `(lib "htdp-beginner.ss" "lang") `() fake-beginner-render-settings #f #t)) + +(define beginner-wla + (make-ll-model `(lib "htdp-beginner-abbr.ss" "lang") `() fake-beginner-wla-render-settings #f #t)) + +(define intermediate + (make-ll-model `(lib "htdp-intermediate.ss" "lang") `() fake-intermediate-render-settings #f #t)) + +(define intermediate-lambda + (make-ll-model `(lib "htdp-intermediate-lambda.ss" "lang") `() fake-intermediate/lambda-render-settings #t #t)) + +(define advanced + (make-ll-model `(lib "htdp-advanced.ss" "lang") `() fake-advanced-render-settings #t #t)) + +(define lazy + (make-ll-model `(lib "lazy.ss" "lazy") `() fake-mz-render-settings #f #f)) + + +;; SUPPORT FOR TESTING A BUNCH OF LANGUAGES AT ONCE: + +;; built-in multi-language bundles: +(define upto-int/lam + (list beginner + beginner-wla + intermediate + intermediate-lambda)) + +(define upto-int + (list beginner + beginner-wla + intermediate)) + +(define bwla-to-int/lam + (list beginner-wla + intermediate + intermediate-lambda)) + +(define both-intermediates + (list intermediate + intermediate-lambda)) + + + diff --git a/collects/tests/stepper/test-engine.ss b/collects/tests/stepper/test-engine.ss new file mode 100644 index 0000000000..e15f99e676 --- /dev/null +++ b/collects/tests/stepper/test-engine.ss @@ -0,0 +1,241 @@ +#lang scheme + +(require stepper/private/shared + stepper/private/model + tests/utils/sexp-diff + lang/run-teaching-program + (only-in srfi/13 string-contains) + scheme/contract + #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss") + "language-level-model.ss") + + +;; A SIMPLE EXAMPLE OF USING THIS FRAMEWORK: + +;; note that this example uses the abbreviation from test-abbrev; don't uncomment it! + +#; +(let* ([defs1 `((define (a x) (+ x 5)) (define b a))] + [defs2 (append defs1 `((define c a)))]) + (apply ;; you can abstract over this application with a define-syntax + run-one-test + (tt 'top-ref4 ;; - the name of the test + m:intermediate ;; - the language level (or levels) to run in + ,@defs1 (define c b) (c 3) ;; - the expressions to test (everything up to the first ::) + :: ,@defs1 (define c {b}) ;; - the steps; the '::' divides steps, repeated '->'s indicate + -> ,@defs1 (define c {a}) ;; that the 'before' of the second step is the 'after' of + :: ,@defs2 ({c} 3) ;; the first one. the curly braces indicate the hilighted sexp. + -> ,@defs2 ({a} 3) + :: ,@defs2 {(a 3)} + -> ,@defs2 {(+ 3 5)} + -> ,@defs2 {8}))) + + + + +;; PARAMETERS THAT CONTROL TESTING + +(provide test-directory + display-only-errors + show-all-steps + disable-stepper-error-handling) + +(define test-directory (find-system-path 'temp-dir)) + +;; use this parameter to suppress output except in error cases: +(define display-only-errors (make-parameter #f)) + +;; use this parameter to show successful steps as well as unsuccessful ones: +(define show-all-steps (make-parameter #f)) + +;; use this parameter to prevent the stepper from capturing errors +;; (so that you can take advantage of DrScheme's error reporting) +(define disable-stepper-error-handling (make-parameter #f)) + +;; DATA DEFINITIONS: + +;; a step is one of +;; - `(before-after ,before ,after) where before and after are sexp-with-hilite's +;; - `(error ,err-msg) where err-msg is a string +;; - `(before-error ,before ,err-msg) where before is an sexp-with-hilite and err-msg is a string +;; - `(finished-stepping) +;; or +;; - `(ignore) +(define (step? sexp) + (match sexp + [(list 'before-after before after) #t] + [(list 'error (? string? msg)) #t] + [(list 'before-error before (? string? msg)) #t] + [(list 'finished-stepping) #t] + [(list 'ignore) #t] + [else #f])) + +;; a model-or-models is one of +;; - an ll-model, or +;; - (listof ll-model?) +(define model-or-models/c (or/c ll-model? (listof ll-model?))) + +;; THE METHOD THAT RUNS A TEST: + +(provide/contract [run-one-test (symbol? model-or-models/c string? (listof step?) . -> . boolean?)]) +;; run-one-test : symbol? model-or-models? string? steps? -> boolean? + +;; the ll-model determines the behavior of the stepper w.r.t. "language-level"-y things: +;; how should values be rendered, should steps be displayed (i.e, will the input & output +;; steps look just the same), etc. If + +;; the string contains a program to be evaluated. The string is an ironclad if blunt way +;; of ensuring that the program has no syntax information associated with it. + +;; the steps lists the desired steps. The easiest way to understand these is probably just to +;; read the code for the comparison given in "compare-steps", below. + +;; run the named test, return #t if a failure occurred during the test +(define (run-one-test name models exp-str expected-steps) + (unless (display-only-errors) + (printf "running test: ~v\n" name)) + (parameterize ([error-has-occurred-box (box #f)]) + (test-sequence/many models exp-str expected-steps) + (if (unbox (error-has-occurred-box)) + (begin (fprintf (current-error-port) "...Error has occurred during test: ~v\n" name) + #f) + #t))) + + +;; test-sequence/many : model-or-models/c string? steps? -> (void) +;; run a given test through a bunch of language models (or just one). + +(define (test-sequence/many models exp-str expected-steps) + (cond [(list? models)(for-each (lambda (model) (test-sequence model exp-str expected-steps)) + models)] + [else (test-sequence models exp-str expected-steps)])) + +;; test-sequence : ll-model? string? steps? -> (void) +;; given a language model and an expression and a sequence of steps, +;; check to see whether the stepper produces the desired steps +(define (test-sequence the-ll-model exp-str expected-steps) + (match the-ll-model + [(struct ll-model (namespace-spec teachpack-specs render-settings show-lambdas-as-lambdas? enable-testing?)) + (let ([filename (build-path test-directory "stepper-test")]) + (call-with-output-file filename + (lambda (port) (fprintf port "~a" exp-str)) + #:exists + 'truncate) + (unless (display-only-errors) + (printf "testing string: ~v\n" exp-str)) + (let* ([port (open-input-file filename)] + [module-id (gensym "stepper-module-name-")] + [expanded (expand-teaching-program port read-syntax namespace-spec teachpack-specs #f module-id enable-testing?)]) + (test-sequence/core render-settings show-lambdas-as-lambdas? expanded expected-steps)))])) + +;; test-sequence/core : render-settings? boolean? syntax? steps? +;; this is a front end for calling the stepper's "go"; the main +;; responsibility here is to fake the behavior of DrScheme and collect the +;; resulting steps. +(define (test-sequence/core render-settings show-lambdas-as-lambdas? expanded expected-steps) + (let* ([current-error-display-handler (error-display-handler)] + [all-steps + (append expected-steps '((finished-stepping)))] + [receive-result + (lambda (result) + (if (null? all-steps) + (warn 'test-sequence + "ran out of expected steps. Given result: ~v" result) + (begin + (if (compare-steps result (car all-steps)) + (when (and (show-all-steps) (not (display-only-errors))) + (printf "test-sequence: steps match for expected result: ~v\n" + (car all-steps))) + (warn 'test-sequence + "steps do not match\n given: ~v\nexpected: ~v" + (show-result result) (car all-steps))) + (set! all-steps (cdr all-steps)))))] + [iter-caller + (lambda (init iter) + (init) + (call-iter-on-each expanded iter))]) + (let/ec escape + (parameterize ([error-escape-handler (lambda () (escape (void)))]) + (go iter-caller receive-result render-settings + show-lambdas-as-lambdas? + ;; language level: + 'testing + ;; run-in-drscheme thunk: + (lambda (thunk) (thunk)) + (disable-stepper-error-handling)))) + (error-display-handler current-error-display-handler))) + +;; call-iter-on-each : (-> syntax?) (syntax? (-> 'a) -> 'a) -> void/c +;; call the given iter on each syntax-object in turn (iter bounces control) +;; back to us by calling the followup-thunk. +(define (call-iter-on-each stx-thunk iter) + (let* ([next (stx-thunk)] + [followup-thunk (if (eof-object? next) void (lambda () (call-iter-on-each stx-thunk iter)))]) + (iter (expand next) followup-thunk))) + +(define error-has-occurred-box (make-parameter #f)) + +(define (warn who fmt . args) + (set-box! (error-has-occurred-box) #t) + (fprintf (current-error-port) "~a: ~a\n" who (apply format fmt args))) + + +;; (-> step-result? sexp? boolean?) +(define (compare-steps actual expected) + (match expected + [`(before-after ,before ,after) + (and (before-after-result? actual) + (andmap (lambda (fn expected name) + (unless (list? (fn actual)) + (warn 'compare-steps "not a list: ~v" + (syntax-object->hilite-datum (fn actual)))) + (noisy-equal? (map syntax-object->hilite-datum + (fn actual)) + expected + name)) + (list before-after-result-pre-exps + before-after-result-post-exps) + (list before after) + (list 'before 'after)))] + [`(error ,err-msg) + (and (error-result? actual) + (string-contains (error-result-err-msg actual) err-msg))] + [`(before-error ,before ,err-msg) + (and (before-error-result? actual) + (and (noisy-equal? (map syntax-object->hilite-datum + (before-error-result-pre-exps actual)) + before + 'before) + (equal? err-msg (before-error-result-err-msg actual))))] + [`(finished-stepping) (finished-stepping? actual)] + [`(ignore) (warn 'compare-steps "ignoring one step") #t] + [else (begin (warn 'compare-steps + "unexpected expected step type: ~v" expected) + #f)])) + + + +;; used to display results in an error message +(define (show-result r) + (if (before-after-result? r) + (list 'before-after-result + (map (lambda (fn) + (unless (list? (fn r)) + (warn 'show-result "not a list: ~v" + (syntax-object->hilite-datum (fn r)))) + (map syntax-object->hilite-datum + (fn r))) + (list before-after-result-pre-exps + before-after-result-post-exps))) + r)) + +;; noisy-equal? : (any any . -> . boolean) +;; like equal?, but prints a noisy error message +(define (noisy-equal? actual expected name) + (if (equal? actual expected) + #t + (begin (warn 'not-equal? + "~e:\nactual: ~e =/= \nexpected: ~e\n here's the diff: ~e" name actual expected (sexp-diff actual expected)) + #f))) + + diff --git a/collects/tests/stepper/through-tests.ss b/collects/tests/stepper/through-tests.ss index 0799b97919..7fb258926b 100755 --- a/collects/tests/stepper/through-tests.ss +++ b/collects/tests/stepper/through-tests.ss @@ -1,988 +1,716 @@ -#lang scheme/base +#lang scheme - (require (for-syntax scheme/base) - (for-syntax scheme/mpair) - scheme/match - stepper/private/shared - stepper/private/model - stepper/private/model-settings - tests/utils/sexp-diff - lang/run-teaching-program - (only-in srfi/13 string-contains) - ;; for xml testing: - ;; mzlib/class - ;; (all-except xml/xml-snipclass snip-class) - ;; (all-except xml/scheme-snipclass snip-class) - ;; mred - #;(file "/Users/clements/clements/scheme-scraps/eli-debug.ss") - ) - - (provide (all-defined-out)) +(require stepper/private/model-settings + (prefix-in m: "language-level-model.ss") + "test-engine.ss" + "test-abbrev.ss" + + ;; for xml testing: + ;; mzlib/class + ;; (all-except xml/xml-snipclass snip-class) + ;; (all-except xml/scheme-snipclass snip-class) + ;; mred - (define test-directory (find-system-path 'temp-dir)) - - (define display-only-errors (make-parameter #f)) - - (define error-has-occurred-box (make-parameter #f)) - - (define show-all-steps (make-parameter #f)) + ) - (define disable-stepper-error-handling (make-parameter #f)) - - (define (stream-ify stx-thunk iter) - (lambda () - (let* ([next (stx-thunk)] - [followup-thunk (if (eof-object? next) void (stream-ify stx-thunk iter))]) - (iter (expand next) followup-thunk)))) +(define list-of-tests null) - (define (warn who fmt . args) - (set-box! (error-has-occurred-box) #t) - (fprintf (current-error-port) "~a: ~a\n" who (apply format fmt args))) +(define (add-test test) + (match test + [(list name models string expected-steps) + (when (assq name list-of-tests) + (error 'add-test "name ~v is already in the list of tests" name)) + (set! list-of-tests (append list-of-tests (list (list name (list models string expected-steps)))))])) - (define (test-sequence-core namespace-spec teachpack-specs render-settings - show-lambdas-as-lambdas? enable-testing? in-port expected-steps) - (let* ([current-error-display-handler (error-display-handler)] - [all-steps - (append expected-steps '((finished-stepping)))] - [receive-result - (lambda (result) - (if (null? all-steps) - (warn 'test-sequence - "ran out of expected steps. Given result: ~v" result) - (begin - (if (compare-steps result (car all-steps)) - (when (and (show-all-steps) (not (display-only-errors))) - (printf "test-sequence: steps match for expected result: ~v\n" - (car all-steps))) - (warn 'test-sequence - "steps do not match\n given: ~v\nexpected: ~v" - (show-result result) (car all-steps))) - (set! all-steps (cdr all-steps)))))] - [program-expander - (let ([module-id (gensym "stepper-module-name-")]) - (lambda (init iter) - (init) - ((stream-ify (expand-teaching-program in-port read-syntax namespace-spec teachpack-specs #f module-id enable-testing?) iter))))]) - (let/ec escape - (parameterize ([error-escape-handler (lambda () (escape (void)))]) - (go program-expander receive-result render-settings - show-lambdas-as-lambdas? - ;; language level: - 'testing - ;; run-in-drscheme thunk: - (lambda (thunk) (thunk)) - (disable-stepper-error-handling)))) - (error-display-handler current-error-display-handler))) +(define (t1 name models string expected-steps) + (add-test (list name models string expected-steps))) - (define (test-sequence namespace-spec teachpack-specs render-settings - show-lambdas-as-lambdas? enable-testing? exp-str expected-steps) - (let ([filename (build-path test-directory "stepper-test")]) - (call-with-output-file filename - (lambda (port) (fprintf port "~a" exp-str)) - #:exists - 'truncate) - (unless (display-only-errors) - (printf "testing string: ~v\n" exp-str)) - (letrec ([port (open-input-file filename)]) - (test-sequence-core namespace-spec teachpack-specs render-settings - show-lambdas-as-lambdas? enable-testing? port expected-steps)))) +;; one more layer around +(define-syntax (t stx) + (syntax-case stx () + [(_ . rest) + (quasisyntax/loc stx + (add-test (tt . rest)))])) - (define (lang-level-test-sequence namespace-spec rs show-lambdas-as-lambdas? enable-testing?) - (lambda args - (apply test-sequence namespace-spec `() rs show-lambdas-as-lambdas? enable-testing? args))) +;; run a test : (list symbol test-thunk) -> boolean +;; run the named test, return #t if a failure occurred during the test +(define (run-one-test/helper test-pair) + (apply run-one-test (car test-pair) (cadr test-pair))) - (define (make-multi-level-test-sequence level-fns) - (lambda args - (for-each (lambda (fn) (apply fn args)) level-fns))) +(define (run-all-tests) + (andmap/no-shortcut + run-one-test/helper + list-of-tests)) - (define test-mz-sequence - (lang-level-test-sequence 'mzscheme fake-mz-render-settings #t #f)) - (define test-beginner-sequence - (lang-level-test-sequence `(lib "htdp-beginner.ss" "lang") - fake-beginner-render-settings #f #t)) - (define test-beginner-wla-sequence - (lang-level-test-sequence `(lib "htdp-beginner-abbr.ss" "lang") - fake-beginner-wla-render-settings #f #t)) - (define test-intermediate-sequence - (lang-level-test-sequence `(lib "htdp-intermediate.ss" "lang") - fake-intermediate-render-settings #f #t)) - (define test-intermediate/lambda-sequence - (lang-level-test-sequence `(lib "htdp-intermediate-lambda.ss" "lang") - fake-intermediate/lambda-render-settings #t #t)) - (define test-advanced-sequence - (lang-level-test-sequence `(lib "htdp-advanced.ss" "lang") - fake-advanced-render-settings #t #t)) +(define (run-all-tests-except nix-list) + (andmap/no-shortcut + run-one-test/helper + (filter (lambda (pr) (not (member (car pr) nix-list))) + list-of-tests))) - (define test-upto-int/lam - (make-multi-level-test-sequence - (list test-beginner-sequence - test-beginner-wla-sequence - test-intermediate-sequence - test-intermediate/lambda-sequence))) +(define (run-test name) + (let ([maybe-test (assq name list-of-tests)]) + (if maybe-test + (run-one-test/helper maybe-test) + (error 'run-test "test not found: ~e" name)))) - (define test-upto-int - (make-multi-level-test-sequence - (list test-beginner-sequence - test-beginner-wla-sequence - test-intermediate-sequence))) +(define (run-tests names) + (ormap/no-shortcut run-test names)) - (define test-bwla-to-int/lam - (make-multi-level-test-sequence - (list test-beginner-wla-sequence - test-intermediate-sequence - test-intermediate/lambda-sequence))) - (define test-both-ints - (make-multi-level-test-sequence - (list test-intermediate-sequence - test-intermediate/lambda-sequence))) +;; like an ormap, but without short-cutting +(define (ormap/no-shortcut f args) + (foldl (lambda (a b) (or a b)) #f (map f args))) - (define test-lazy-sequence - (lang-level-test-sequence `(lib "lazy.ss" "lazy") - fake-mz-render-settings #f #f)) +(define (andmap/no-shortcut f args) + (foldl (lambda (a b) (and a b)) #t (map f args))) - ;; mutate these to values you want to examine in the repl: - (define bell-jar-specimen-1 #f) - (define bell-jar-specimen-2 #f) +(t 'mz1 m:mz + (for-each (lambda (x) x) '(1 2 3)) + :: {(for-each (lambda (x) x) `(1 2 3))} -> (... {1} ...) + :: ... -> (... {2} ...) + :: ... -> (... {3} ...) + :: ... -> {(void)}) - ;; so->d/finished : call (syntax-object->hilite-datum stx #t). For finished - ;; steps, we want to ignore the highlight but not the xml boxes (and other - ;; future stuff?) - (define (so->d/finished stx) - (syntax-object->hilite-datum stx #t)) +;; new test case language: +;; an expected is (listof step) +;; a step is one of +;; (before-after exps exps) +;; (before-error exps str) +;; (error str) +;; (finished) +;; an exps is a list of s-expressions with certain non-hygienic extensions: +;; - (hilite X) denotes the s-expression X, only highlighted +;; - any denotes any s-expression (matches everything) +;; ... in principle, these could collide with programs that use the +;; identifiers 'hilite' and 'any', but since I'm writing the test cases, +;; I can alpha-rename manually to avoid collisions. - ;; (-> step-result? sexp? boolean?) - (define (compare-steps actual expected) - (match expected - [`(before-after ,before ,after) - (and (before-after-result? actual) - (andmap (lambda (fn expected name) - (unless (list? (fn actual)) - (warn 'compare-steps "not a list: ~v" - (syntax-object->hilite-datum (fn actual)))) - (noisy-equal? (map syntax-object->hilite-datum - (fn actual)) - expected - name)) - (list before-after-result-pre-exps - before-after-result-post-exps) - (list before after) - (list 'before 'after)))] - [`(error ,err-msg) - (and (error-result? actual) - (string-contains (error-result-err-msg actual) err-msg))] - [`(before-error ,before ,err-msg) - (and (before-error-result? actual) - (and (noisy-equal? (map syntax-object->hilite-datum - (before-error-result-pre-exps actual)) - before - 'before) - (equal? err-msg (before-error-result-err-msg actual))))] - [`(finished-stepping) (finished-stepping? actual)] - [`(ignore) (warn 'compare-steps "ignoring one step") #t] - [else (begin (warn 'compare-steps - "unexpected expected step type: ~v" expected) - #f)])) - - ;; used to display results in an error message - (define (show-result r) - (if (before-after-result? r) - (list 'before-after-result - (map (lambda (fn) - (unless (list? (fn r)) - (warn 'show-result "not a list: ~v" - (syntax-object->hilite-datum (fn r)))) - (map syntax-object->hilite-datum - (fn r))) - (list before-after-result-pre-exps - before-after-result-post-exps))) - r)) +;; on top of this, the `t' macro makes things easier to write, informally: +;; (t 'name ; symbolic name for the test +;; tester ; tester function that gets used +;; expr1 ... :: expr2 ... -> expr3 ...) +;; means that `expr1 ...' is the original, the first step is +;; (before-after (expr2 ...) (expr3 ...)) +;; Cute stuff: +;; * use `::' to mark a new step that doesn't continue the previous one +;; e1 :: e2 -> e3 -> e4 +;; is the same as +;; e1 :: e2 -> e3 :: e3 -> e4 +;; * use `-> error: "..."' for a `before-error' step +;; * use `:: error: "..."' for an `error' step +;; * a `finished-stepping' is added if no error was specified +;; * a `{...}' is replaced with `(hilite ...)' - ;; noisy-equal? : (any any . -> . boolean) - ;; like equal?, but prints a noisy error message - (define (noisy-equal? actual expected name) - (if (equal? actual expected) - #t - (begin (warn 'not-equal? - "~e:\nactual: ~e =/= \nexpected: ~e\n here's the diff: ~e" name actual expected (sexp-diff actual expected)) - #f))) +(t 'mz-app m:mz + (+ 3 4) + :: {(+ 3 4)} -> {7}) - ;; (-> (listof sexp) (listof sexp) boolean?) - (define (compare-finished finished-exps expected-exps) - (and (>= (length finished-exps) (length expected-exps)) - (andmap (lambda (x y) - (if (equal? x y) - #t - (begin - (warn 'not-equal? - "~e =/= ~e\n here's the diff: ~e" - x y (sexp-diff x y)) - #f))) - (list-tail finished-exps - (- (length finished-exps) (length expected-exps))) - expected-exps))) +(t 'mz-app2 m:mz + ((lambda (x) (+ x 3)) 4) + :: {((lambda (x) (+ x 3)) 4)} -> {(+ 4 3)} -> {7}) - ;; (-> (listof sexp) string?) - (define (exprs->string exprs) - (apply string-append - (cdr (apply append (map (lambda (x) (list " " (format "~s" x))) - exprs))))) +(t 'mz-if m:mz + (if 3 4 5) + :: {(if 3 4 5)} -> {4}) - (define list-of-tests null) +(t 'simple-if m:upto-int/lam + (if true false true) + :: {(if true false true)} -> {false}) - (define (add-test name thunk) - (when (assq name list-of-tests) - (error 'add-test "name ~v is already in the list of tests" name)) - (set! list-of-tests (append list-of-tests (list (list name thunk))))) +(t 'if-bool m:upto-int/lam + (if (if true false true) false true) + :: (if {(if true false true)} false true) -> (if {false} false true) + :: {(if false false true)} -> {true}) - (define-syntax (t1 stx) - (syntax-case stx () - [(_ name test) - (syntax/loc stx (add-test `name (lambda () test)))])) - - ;; Eli can't help adding his own convenient but complex syntax here (JBC, 2006-11-14): +(t 'direct-app m:mz + ((lambda (x) x) 3) + :: {((lambda (x) x) 3)} -> {3}) - (define-syntax (t stx) - (define (maybe-mlist->list r) - (if (mpair? r) - (mlist->list r) - r)) - (define (split l) - (let loop ([l l] [r '()]) - (cond [(null? l) (reverse (map maybe-mlist->list r))] - [(symbol? (car l)) (loop (cdr l) (cons (car l) r))] - [(or (null? r) (not (mpair? (car r)))) - (loop (cdr l) (cons (mlist (car l)) r))] - [else (mappend! (car r) (mlist (car l))) - (loop (cdr l) r)]))) - (define (process-hilites s) - (syntax-case s () - [(x) (eq? #\{ (syntax-property s 'paren-shape)) - (with-syntax ([x (process-hilites #'x)]) #'(hilite x))] - [(x . y) (let* ([x0 #'x] - [y0 #'y] - [x1 (process-hilites #'x)] - [y1 (process-hilites #'y)]) - (if (and (eq? x0 x1) (eq? y0 y1)) - s - (with-syntax ([x x1] [y y1]) #'(x . y))))] - [_else s])) - (define (process stx) - (split (map (lambda (s) - (if (and (identifier? s) - (memq (syntax-e s) '(:: -> error:))) - (syntax-e s) - (process-hilites s))) - (syntax->list stx)))) - (define (parse l) - (syntax-case l (::) - [(fst :: rest ...) - (cons #'fst - (let loop ([rest #'(rest ...)]) - (syntax-case rest (:: -> error:) - [(error: (err)) (list #'(error err))] - [() (list #'(finished-stepping))] - [(x -> y) (list #'(before-after x y) #'(finished-stepping))] - [(x -> error: (err)) (list #'(before-error x err))] - [(x -> y :: . rest) - (cons #'(before-after x y) (loop #'rest))] - [(x -> y -> . rest) - (cons #'(before-after x y) (loop #'(y -> . rest)))])))])) - (syntax-case stx (::) - [(_ name tester . rest) - (with-syntax ([(exprs arg ...) (parse (process #'rest))]) - (quasisyntax/loc stx - (add-test `name - (lambda () - (tester - ;printf "exprs = ~s\n args = ~s\n" - (exprs->string `exprs) `(arg ...))))))])) - - ;; run a test : (list symbol test-thunk) -> boolean - ;; run the named test, return #t if a failure occurred during the test - (define (run-one-test test-pair) - (unless (display-only-errors) - (printf "running test: ~v\n" (car test-pair))) - (parameterize ([error-has-occurred-box (box #f)]) - ((cadr test-pair)) - (if (unbox (error-has-occurred-box)) - (begin (fprintf (current-error-port) "...Error has occurred during test: ~v\n" (car test-pair)) - #t) - #f))) - - (define (run-all-tests) - (ormap/no-shortcut - run-one-test - list-of-tests)) - - (define (run-all-tests-except nix-list) - (ormap/no-shortcut - run-one-test - (filter (lambda (pr) (not (member (car pr) nix-list))) - list-of-tests))) - - (define (run-test name) - (let ([maybe-test (assq name list-of-tests)]) - (if maybe-test - (run-one-test maybe-test) - (error 'run-test "test not found: ~e" name)))) - - (define (run-tests names) - (ormap/no-shortcut run-test names)) - - - ;; like an ormap, but without short-cutting - (define (ormap/no-shortcut f args) - (foldl (lambda (a b) (or a b)) #f (map f args))) - - (t mz1 test-mz-sequence - (for-each (lambda (x) x) '(1 2 3)) - :: {(for-each (lambda (x) x) `(1 2 3))} -> (... {1} ...) - :: ... -> (... {2} ...) - :: ... -> (... {3} ...) - :: ... -> {(void)}) - - ;; new test case language: - ;; an expected is (listof step) - ;; a step is one of - ;; (before-after exps exps) - ;; (before-error exps str) - ;; (error str) - ;; (finished) - ;; an exps is a list of s-expressions with certain non-hygienic extensions: - ;; - (hilite X) denotes the s-expression X, only highlighted - ;; - any denotes any s-expression (matches everything) - ;; ... in principle, these could collide with programs that use the - ;; identifiers 'hilite' and 'any', but since I'm writing the test cases, - ;; I can alpha-rename manually to avoid collisions. - - ;; on top of this, the `t' macro makes things easier to write, informally: - ;; (t name ; symbolic name for the test - ;; tester ; tester function that gets used - ;; expr1 ... :: expr2 ... -> expr3 ...) - ;; means that `expr1 ...' is the original, the first step is - ;; (before-after (expr2 ...) (expr3 ...)) - ;; Cute stuff: - ;; * use `::' to mark a new step that doesn't continue the previous one - ;; e1 :: e2 -> e3 -> e4 - ;; is the same as - ;; e1 :: e2 -> e3 :: e3 -> e4 - ;; * use `-> error: "..."' for a `before-error' step - ;; * use `:: error: "..."' for an `error' step - ;; * a `finished-stepping' is added if no error was specified - ;; * a `{...}' is replaced with `(hilite ...)' - - (t mz-app test-mz-sequence - (+ 3 4) - :: {(+ 3 4)} -> {7}) - - (t mz-app2 test-mz-sequence - ((lambda (x) (+ x 3)) 4) - :: {((lambda (x) (+ x 3)) 4)} -> {(+ 4 3)} -> {7}) - - (t mz-if test-mz-sequence - (if 3 4 5) - :: {(if 3 4 5)} -> {4}) - - (t simple-if test-upto-int/lam - (if true false true) - :: {(if true false true)} -> {false}) - - (t if-bool test-upto-int/lam - (if (if true false true) false true) - :: (if {(if true false true)} false true) -> (if {false} false true) - :: {(if false false true)} -> {true}) - - (t direct-app test-mz-sequence - ((lambda (x) x) 3) - :: {((lambda (x) x) 3)} -> {3}) - -; (test-mz-sequence "((lambda (x) x) (begin (+ 3 4) (+ 4 5)))" +; (m:mz "((lambda (x) x) (begin (+ 3 4) (+ 4 5)))" ; `((before-after ((begin (hilite (+ 3 4)) (+ 4 5))) ; ((begin (hilite 7) (+ 4 5)))) ; (before-after ((hilite (begin 7 (+ 4 5)))) ((hilite (+ 4 5)))) ; (before-after ((hilite (+ 4 5))) ((hilite 9))) ; (finished-stepping))) - (t curried test-mz-sequence - ((lambda (a) (lambda (b) (+ a b))) 14) - :: {((lambda (a) (lambda (b) (+ a b))) 14)} - -> {(lambda (b) (+ 14 b))}) +(t 'curried m:mz + ((lambda (a) (lambda (b) (+ a b))) 14) + :: {((lambda (a) (lambda (b) (+ a b))) 14)} + -> {(lambda (b) (+ 14 b))}) - (t case-lambda test-mz-sequence - ((case-lambda ((a) 3) ((b c) (+ b c))) 5 6) - :: {((case-lambda ((a) 3) ((b c) (+ b c))) 5 6)} - -> {(+ 5 6)} - -> {11}) +(t 'case-lambda m:mz + ((case-lambda ((a) 3) ((b c) (+ b c))) 5 6) + :: {((case-lambda ((a) 3) ((b c) (+ b c))) 5 6)} + -> {(+ 5 6)} + -> {11}) - ;; not really a part of base mzscheme anymore - #;(t 2armed-if test-mz-sequence +;; not really a part of base mzscheme anymore +#;(t '2armed-if m:mz (if 3 4) :: {(if 3 4)} -> {4}) - ;(test-mz-sequence "((call-with-current-continuation call-with-current-continuation) (call-with-current-continuation call-with-current-continuation))" - ; `((before-after (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((call-with-current-continuation call-with-current-continuation)) - ; (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((lambda args ...))) - ; (before-after (((lambda args ...) (hilite ,h-p))) ((call-with-current-continuation call-with-current-continuation)) - ; (((lambda args ...) (hilite ,h-p))) ((lambda args ...))))) +;(m:mz "((call-with-current-continuation call-with-current-continuation) (call-with-current-continuation call-with-current-continuation))" +; `((before-after (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((call-with-current-continuation call-with-current-continuation)) +; (((hilite ,h-p) (call-with-current-continuation call-with-current-continuation))) ((lambda args ...))) +; (before-after (((lambda args ...) (hilite ,h-p))) ((call-with-current-continuation call-with-current-continuation)) +; (((lambda args ...) (hilite ,h-p))) ((lambda args ...))))) - ;(test-mz-sequence '(begin (define g 3) g) - ; `((before-after ((hilite ,h-p)) (g) - ; ((hilite ,h-p)) 3))) +;(m:mz '(begin (define g 3) g) +; `((before-after ((hilite ,h-p)) (g) +; ((hilite ,h-p)) 3))) - ;(syntax-object->datum (cadr (annotate-expr test2 'mzscheme 0 (lambda (x) x)))) +;(syntax-object->datum (cadr (annotate-expr test2 'mzscheme 0 (lambda (x) x)))) - (t top-def test-upto-int/lam - (define a (+ 3 4)) - :: (define a {(+ 3 4)}) - -> (define a {7})) +(t 'top-def m:upto-int/lam + (define a (+ 3 4)) + :: (define a {(+ 3 4)}) + -> (define a {7})) - (t top-def-ref test-upto-int/lam - (define a 6) a - :: (define a 6) {a} -> (define a 6) {6}) +(t 'top-def-ref m:upto-int/lam + (define a 6) a + :: (define a 6) {a} -> (define a 6) {6}) - (t app test-upto-int/lam - (+ 4 129) - :: {(+ 4 129)} -> {133}) +(t 'app m:upto-int/lam + (+ 4 129) + :: {(+ 4 129)} -> {133}) - (t if test-upto-int/lam (if true 3 4) - :: {(if true 3 4)} -> {3}) +(t 'if m:upto-int/lam (if true 3 4) + :: {(if true 3 4)} -> {3}) - (let ([def `(define (a3 x) (if true x x))]) - (t top-app test-upto-int - ,def (a3 false) - :: ,def {(a3 false)} - -> ,def {(if true false false)} - -> ,def {false}) - ;; - (t top-app/lam test-intermediate/lambda-sequence - ,def (a3 false) - :: ,def ({a3} false) - -> ,def ({(lambda (x) (if true x x))} false) - :: ,def {((lambda (x) (if true x x)) false)} - -> ,def {(if true false false)} - -> ,def {false})) - - (let ([defs `((define (a12 x) (+ x 9)) (define b12 a12))]) - (t top-interref test-intermediate-sequence - ,@defs (b12 12) - :: ,@defs ({b12} 12) - -> ,@defs ({a12} 12) - :: ,@defs {(a12 12)} - -> ,@defs {(+ 12 9)} - -> ,@defs {21})) - - ;;;;;;;;;;;; +(let ([def `(define (a3 x) (if true x x))]) + (t 'top-app m:upto-int + ,def (a3 false) + :: ,def {(a3 false)} + -> ,def {(if true false false)} + -> ,def {false}) ;; - ;; OR / AND + (t 'top-app/lam m:intermediate-lambda + ,def (a3 false) + :: ,def ({a3} false) + -> ,def ({(lambda (x) (if true x x))} false) + :: ,def {((lambda (x) (if true x x)) false)} + -> ,def {(if true false false)} + -> ,def {false})) + +(let ([defs `((define (a12 x) (+ x 9)) (define b12 a12))]) + (t 'top-interref m:intermediate + ,@defs (b12 12) + :: ,@defs ({b12} 12) + -> ,@defs ({a12} 12) + :: ,@defs {(a12 12)} + -> ,@defs {(+ 12 9)} + -> ,@defs {21})) + +;;;;;;;;;;;; +;; +;; OR / AND +;; +;;;;;;;;;;;;;. + +(t 'or1 m:upto-int/lam + (or false true false) + :: {(or false true false)} -> {true}) + +(t 'and1 m:upto-int/lam + (and true false true) + :: {(and true false true)} -> {false}) + +(t 'and2 m:upto-int/lam + (and true (if true true false)) + :: (and true {(if true true false)}) -> (and true {true}) + :: {(and true true)} -> {true}) + +(let ([def `(define (b2 x) (and true x))]) + (t 'and3 m:upto-int + ,def (b2 false) + :: ,def {(b2 false)} + -> ,def {(and true false)} + -> ,def {false}) ;; - ;;;;;;;;;;;;;. + (t 'and3/lam m:intermediate-lambda + (define (b2 x) (and true x)) (b2 false) + :: ,def ({b2} false) + -> ,def ({(lambda (x) (and true x))} false) + :: ,def {((lambda (x) (and true x)) false)} + -> ,def {(and true false)} + -> ,def {false})) - (t or1 test-upto-int/lam - (or false true false) - :: {(or false true false)} -> {true}) - - (t and1 test-upto-int/lam - (and true false true) - :: {(and true false true)} -> {false}) - - (t and2 test-upto-int/lam - (and true (if true true false)) - :: (and true {(if true true false)}) -> (and true {true}) - :: {(and true true)} -> {true}) - - (let ([def `(define (b2 x) (and true x))]) - (t and3 test-upto-int - ,def (b2 false) - :: ,def {(b2 false)} - -> ,def {(and true false)} - -> ,def {false}) - ;; - (t and3/lam test-intermediate/lambda-sequence - (define (b2 x) (and true x)) (b2 false) - :: ,def ({b2} false) - -> ,def ({(lambda (x) (and true x))} false) - :: ,def {((lambda (x) (and true x)) false)} - -> ,def {(and true false)} - -> ,def {false})) - - (let ([defs `((define a1 true) - (define (b1 x) (and a1 true x)))]) - (t and4 test-upto-int - ,@defs (b1 false) - :: ,@defs {(b1 false)} - -> ,@defs {(and a1 true false)} - :: ,@defs (and {a1} true false) - -> ,@defs (and {true} true false) - :: ,@defs {(and true true false)} - -> ,@defs {false}) - ;; - (t and4/lam test-intermediate/lambda-sequence - ,@defs (b1 false) - :: ,@defs ({b1} false) - -> ,@defs ({(lambda (x) (and a1 true x))} false) - :: ,@defs {((lambda (x) (and a1 true x)) false)} - -> ,@defs {(and a1 true false)} - :: ,@defs (and {a1} true false) - -> ,@defs (and {true} true false) - :: ,@defs {(and true true false)} - -> ,@defs {false})) - - (t bad-and test-upto-int/lam - (and true 1) - :: {(and true 1)} - -> error: "and: question result is not true or false: 1") - - ;;;;;;;;;;;;; +(let ([defs `((define a1 true) + (define (b1 x) (and a1 true x)))]) + (t 'and4 m:upto-int + ,@defs (b1 false) + :: ,@defs {(b1 false)} + -> ,@defs {(and a1 true false)} + :: ,@defs (and {a1} true false) + -> ,@defs (and {true} true false) + :: ,@defs {(and true true false)} + -> ,@defs {false}) ;; - ;; COND - ;; - ;;;;;;;;;;;;; + (t 'and4/lam m:intermediate-lambda + ,@defs (b1 false) + :: ,@defs ({b1} false) + -> ,@defs ({(lambda (x) (and a1 true x))} false) + :: ,@defs {((lambda (x) (and a1 true x)) false)} + -> ,@defs {(and a1 true false)} + :: ,@defs (and {a1} true false) + -> ,@defs (and {true} true false) + :: ,@defs {(and true true false)} + -> ,@defs {false})) - (t cond1 test-upto-int/lam - (cond [false 4] [false 5] [true 3]) - :: {(cond (false 4) (false 5) (true 3))} - -> {(cond (false 5) (true 3))} - -> {(cond (true 3))} - -> {3}) +(t 'bad-and m:upto-int/lam + (and true 1) + :: {(and true 1)} + -> error: "and: question result is not true or false: 1") - (t cond-else test-upto-int/lam - (cond [false 4] [else 9]) - :: {(cond [false 4] [else 9])} - -> {(cond [else 9])} - -> {9}) +;;;;;;;;;;;;; +;; +;; COND +;; +;;;;;;;;;;;;; - (t cond-andelse test-upto-int/lam - (cond [true 3] [else (and true true)]) - :: {(cond (true 3) (else (and true true)))} -> {3}) +(t 'cond1 m:upto-int/lam + (cond [false 4] [false 5] [true 3]) + :: {(cond (false 4) (false 5) (true 3))} + -> {(cond (false 5) (true 3))} + -> {(cond (true 3))} + -> {3}) - (t bad-cond test-upto-int/lam - (cond) - :: error: "cond: expected a question--answer clause after `cond', but nothing's there") +(t 'cond-else m:upto-int/lam + (cond [false 4] [else 9]) + :: {(cond [false 4] [else 9])} + -> {(cond [else 9])} + -> {9}) - (t just-else test-upto-int/lam - (cond [else 3]) - :: {(cond (else 3))} -> {3}) +(t 'cond-andelse m:upto-int/lam + (cond [true 3] [else (and true true)]) + :: {(cond (true 3) (else (and true true)))} -> {3}) - (t nested-cond test-upto-int/lam - (cond [else (cond [else 3])]) - :: {(cond (else (cond (else 3))))} - -> {(cond (else 3))} - -> {3}) +(t 'bad-cond m:upto-int/lam + (cond) + :: error: "cond: expected a question--answer clause after `cond', but nothing's there") - ;; reconstruct can't handle 'begin' - #; - (test-mz-sequence "(cond [#f 3 4] [#t (+ 3 4) (+ 4 9)])" - `((before-after ((hilite (cond (#f 3 4) (#t (+ 3 4) (+ 4 9))))) - ((hilite (cond (#t (+ 3 4) (+ 4 9)))))) - (before-after ((hilite (cond (#t (+ 3 4) (+ 4 9))))) - ((hilite (begin (+ 3 4) (+ 4 9))))) - (before-after ((begin (hilite (+ 3 4)) (+ 4 9))) - ((begin (hilite 7) (+ 4 9)))) - (before-after ((hilite (begin 7 (+ 4 9)))) - ((hilite (+ 4 9)))) - (before-after ((hilite (+ 4 9))) - ((hilite 13))) +(t 'just-else m:upto-int/lam + (cond [else 3]) + :: {(cond (else 3))} -> {3}) + +(t 'nested-cond m:upto-int/lam + (cond [else (cond [else 3])]) + :: {(cond (else (cond (else 3))))} + -> {(cond (else 3))} + -> {3}) + +;; reconstruct can't handle 'begin' +#; +(m:mz "(cond [#f 3 4] [#t (+ 3 4) (+ 4 9)])" + `((before-after ((hilite (cond (#f 3 4) (#t (+ 3 4) (+ 4 9))))) + ((hilite (cond (#t (+ 3 4) (+ 4 9)))))) + (before-after ((hilite (cond (#t (+ 3 4) (+ 4 9))))) + ((hilite (begin (+ 3 4) (+ 4 9))))) + (before-after ((begin (hilite (+ 3 4)) (+ 4 9))) + ((begin (hilite 7) (+ 4 9)))) + (before-after ((hilite (begin 7 (+ 4 9)))) + ((hilite (+ 4 9)))) + (before-after ((hilite (+ 4 9))) + ((hilite 13))) + (finished-stepping))) + +(t 'nested-cond2 m:upto-int/lam + (cond [false 3] [else (cond [true 4])]) + :: {(cond (false 3) (else (cond (true 4))))} + -> {(cond (else (cond (true 4))))} + -> {(cond (true 4))} + -> {4}) + +(t 'top-ref m:intermediate + (define a4 +) a4 + :: (define a4 +) {a4} + -> (define a4 +) {+}) + +(t 'top-ref2 m:intermediate + (define (f123 x) (+ x 13)) f123 + ::) + +(t 'top-ref3 m:intermediate-lambda + (define (f123 x) (+ x 13)) f123 + :: (define (f123 x) (+ x 13)) {f123} + -> (define (f123 x) (+ x 13)) {(lambda (x) (+ x 13))}) + +(let* ([defs1 `((define (a x) (+ x 5)) (define b a))] + [defs2 (append defs1 `((define c a)))]) + (t 'top-ref4 m:intermediate + ,@defs1 (define c b) (c 3) + :: ,@defs1 (define c {b}) + -> ,@defs1 (define c {a}) + :: ,@defs2 ({c} 3) + -> ,@defs2 ({a} 3) + :: ,@defs2 {(a 3)} + -> ,@defs2 {(+ 3 5)} + -> ,@defs2 {8})) + +(t 'define-struct m:upto-int/lam + (define-struct mamba (rhythm tempo)) (mamba-rhythm (make-mamba 24 2)) + :: (define-struct mamba (rhythm tempo)) {(mamba-rhythm (make-mamba 24 2))} + -> (define-struct mamba (rhythm tempo)) {24}) + +(let ([def `(define a5 (lambda (a5) (+ a5 13)))]) + (t 'lam-def m:upto-int + ,def (a5 23) + :: ,def {(a5 23)} + -> ,def {(+ 23 13)} + -> ,def {36})) + +(let ([def `(define a5 (lambda (a5) (+ a5 13)))]) + (t 'lam-def/lam m:intermediate-lambda + ,def (a5 23) + :: ,def ({a5} 23) + -> ,def ({(lambda (a5) (+ a5 13))} 23) + :: ,def {((lambda (a5) (+ a5 13)) 23)} + -> ,def {(+ 23 13)} + -> ,def {36})) + +(let ([def `(define a_0 (lambda (x) (+ x 5)))]) + (t 'lam-let m:intermediate + (let ([a (lambda (x) (+ x 5))]) (a 6)) + :: {(let ([a (lambda (x) (+ x 5))]) (a 6))} + -> {(define a_0 (lambda (x) (+ x 5)))} {(a_0 6)} + :: ,def {(a_0 6)} + -> ,def {(+ 6 5)} + -> ,def {11})) + +(let ([defs `((define c1 false) + (define (d2 x) (or c1 false x)))]) + (t 'whocares m:upto-int + ,@defs (d2 false) + :: ,@defs {(d2 false)} + -> ,@defs {(or c1 false false)} + :: ,@defs (or {c1} false false) + -> ,@defs (or {false} false false) + :: ,@defs {(or false false false)} + -> ,@defs {false})) + +(let ([defs `((define c1 false) + (define (d2 x) (or c1 false x)))]) + (t 'whocares/lam m:intermediate-lambda + ,@defs (d2 false) + :: ,@defs ({d2} false) + -> ,@defs ({(lambda (x) (or c1 false x))} false) + :: ,@defs {((lambda (x) (or c1 false x)) false)} + -> ,@defs {(or c1 false false)} + :: ,@defs (or {c1} false false) + -> ,@defs (or {false} false false) + :: ,@defs {(or false false false)} + -> ,@defs {false})) + +(let ([defs `((define (f x) (+ (g x) 10)) (define (g x) (- x 22)))]) + (t 'forward-ref m:upto-int + ,@defs (f 13) + :: ,@defs {(f 13)} + -> ,@defs {(+ (g 13) 10)} + :: ,@defs (+ {(g 13)} 10) + -> ,@defs (+ {(- 13 22)} 10) + -> ,@defs (+ {-9} 10) + :: ,@defs {(+ -9 10)} + -> ,@defs {1})) + +(let ([defs `((define (f x) (+ (g x) 10)) (define (g x) (- x 22)))]) + (t 'forward-ref/lam m:intermediate-lambda + ,@defs (f 13) + :: ,@defs ({f} 13) + -> ,@defs ({(lambda (x) (+ (g x) 10))} 13) + :: ,@defs {((lambda (x) (+ (g x) 10)) 13)} + -> ,@defs {(+ (g 13) 10)} + :: ,@defs (+ ({g} 13) 10) + -> ,@defs (+ ({(lambda (x) (- x 22))} 13) 10) + :: ,@defs (+ {((lambda (x) (- x 22)) 13)} 10) + -> ,@defs (+ {(- 13 22)} 10) + -> ,@defs (+ {-9} 10) + :: ,@defs {(+ -9 10)} + -> ,@defs {1})) + + +;; loops; I should add a mechanism to stop testing after n steps... +#;(let ([defs '((define (f x) (cond (else (f x)))) + (define (g x) x))]) + (t 'pnkfelix m:intermediate-lambda + ,@defs (f (g empty)) + :: ,@defs ({f} (g empty)) + -> ,@defs ({(lambda (x) (cond (else (f x))))} (g empty)) + :: ,@defs ((lambda (x) (cond (else (f x)))) ({g} empty)) + -> ,@defs ((lambda (x) (cond (else (f x)))) ({(lambda (x) x)} empty)))) + +(t 'bad-cons m:upto-int/lam + (cons 1 2) + :: {(cons 1 2)} + -> error: "cons: second argument must be of type , given 1 and 2") + +(t1 'prims + m:beginner "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)" + (let ([defs `((cons 3 (cons 1 empty)))]) + `((before-after (,@defs (hilite (list 1 2 3))) + (,@defs (hilite (cons 1 (cons 2 (cons 3 empty))))))))) + +(t1 'prims/non-beginner + m:bwla-to-int/lam "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)" + `((before-after ((cons 3 (hilite (cons 1 empty)))) ((cons 3 (hilite (list 1))))) + (before-after ((hilite (cons 3 (list 1)))) ((hilite (list 3 1)))))) + + +(t1 'map + m:mz "(map (lambda (x) x) (list 3 4 5))" + `((before-after ((map (lambda (x) x) (hilite (list 3 4 5)))) + ((map (lambda (x) x) (hilite `( 3 4 5))))) + (before-after ((hilite (map (lambda (x) x) `(3 4 5)))) + ((... (hilite 3) ...))) + (before-after (...) + ((... (hilite 4) ...))) + (before-after (...) + ((... (hilite 5) ...))) + (before-after (...) ((hilite `(3 4 5)))))) + +(t1 'quoted-list + m:beginner-wla "'(3 4 5)" + `()) + +(t1 'quoted-list-display + m:bwla-to-int/lam "(define (f x) '((a))) (+ 3 4)" + `((before-after ((define (f x) (list (list 'a))) (hilite (+ 3 4))) + ((define (f x) (list (list 'a))) (hilite 7))) (finished-stepping))) - (t nested-cond2 test-upto-int/lam - (cond [false 3] [else (cond [true 4])]) - :: {(cond (false 3) (else (cond (true 4))))} - -> {(cond (else (cond (true 4))))} - -> {(cond (true 4))} - -> {4}) - (t top-ref test-intermediate-sequence - (define a4 +) a4 - :: (define a4 +) {a4} - -> (define a4 +) {+}) +;;;;;;;;;;;;; +;; +;; QUASIQUOTE +;; +;;;;;;;;;;;;;. - (t top-ref2 test-intermediate-sequence - (define (f123 x) (+ x 13)) f123 - ::) +; note: we currently punt on trying to unwind quasiquote. - (t top-ref3 test-intermediate/lambda-sequence - (define (f123 x) (+ x 13)) f123 - :: (define (f123 x) (+ x 13)) {f123} - -> (define (f123 x) (+ x 13)) {(lambda (x) (+ x 13))}) +(t1 'qq1 + m:beginner-wla "`(3 4 ,(+ 4 5))" + `((before-after ((cons 3 (cons 4 (cons (hilite (+ 4 5)) empty)))) + ((cons 3 (cons 4 (cons (hilite 9) empty))))) + (before-after ((cons 3 (cons 4 (hilite (cons 9 empty))))) + ((cons 3 (cons 4 (hilite (list 9)))))) + (before-after ((cons 3 (hilite (cons 4 (list 9))))) + ((cons 3 (hilite (list 4 9))))) + (before-after ((hilite (cons 3 (list 4 9)))) ((hilite (list 3 4 9)))) + (finished-stepping))) - (let* ([defs1 `((define (a x) (+ x 5)) (define b a))] - [defs2 (append defs1 `((define c a)))]) - (t top-ref4 test-intermediate-sequence - ,@defs1 (define c b) (c 3) - :: ,@defs1 (define c {b}) - -> ,@defs1 (define c {a}) - :: ,@defs2 ({c} 3) - -> ,@defs2 ({a} 3) - :: ,@defs2 {(a 3)} - -> ,@defs2 {(+ 3 5)} - -> ,@defs2 {8})) +(t1 'qq-splice + m:beginner-wla "`(3 ,@(list (+ 3 4) 5) 6)" + `((before-after ((cons 3 (append (list (hilite (+ 3 4)) 5) (cons 6 empty)))) ((cons 3 (append (list (hilite 7) 5) (cons 6 empty))))) + (before-after ((cons 3 (append (list 7 5) (hilite (cons 6 empty))))) ((cons 3 (append (list 7 5) (list 6))))) + (before-after ((cons 3 (hilite (append (list 7 5) (list 6))))) ((cons 3 (hilite (list 7 5 6))))) + (before-after ((hilite (cons 3 (list 7 5 6)))) ((hilite (list 3 7 5 6)))) + (finished-stepping))) - (t define-struct test-upto-int/lam - (define-struct mamba (rhythm tempo)) (mamba-rhythm (make-mamba 24 2)) - :: (define-struct mamba (rhythm tempo)) {(mamba-rhythm (make-mamba 24 2))} - -> (define-struct mamba (rhythm tempo)) {24}) +;;;;;;;;;;;;; +;; +;; LET +;; +;;;;;;;;;;;;; - (let ([def `(define a5 (lambda (a5) (+ a5 13)))]) - (t lam-def test-upto-int - ,def (a5 23) - :: ,def {(a5 23)} - -> ,def {(+ 23 13)} - -> ,def {36})) +(t1 'let1 m:both-intermediates "(let ([a 3]) 4)" + `((before-after ((hilite (let ([a 3]) 4))) ((hilite (define a_0 3)) (hilite 4))) + (finished-stepping))) - (let ([def `(define a5 (lambda (a5) (+ a5 13)))]) - (t lam-def/lam test-intermediate/lambda-sequence - ,def (a5 23) - :: ,def ({a5} 23) - -> ,def ({(lambda (a5) (+ a5 13))} 23) - :: ,def {((lambda (a5) (+ a5 13)) 23)} - -> ,def {(+ 23 13)} - -> ,def {36})) +(t1 'let2 + m:both-intermediates "(let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b))" + `((before-after ((hilite (let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b)))) + ((hilite (define a_0 (+ 4 5))) (hilite (define b_0 (+ 9 20))) (hilite (+ a_0 b_0)))) + (before-after ((define a_0 (hilite (+ 4 5))) (define b_0 (+ 9 20)) (+ a_0 b_0)) + ((define a_0 (hilite 9)) (define b_0 (+ 9 20)) (+ a_0 b_0))) + (before-after ((define a_0 9) (define b_0 (hilite (+ 9 20))) (+ a_0 b_0)) + ((define a_0 9) (define b_0 (hilite 29)) (+ a_0 b_0))) + (before-after ((define a_0 9) (define b_0 29) (+ (hilite a_0) b_0)) + ((define a_0 9) (define b_0 29) (+ (hilite 9) b_0))) + (before-after ((define a_0 9) (define b_0 29) (+ 9 (hilite b_0))) + ((define a_0 9) (define b_0 29) (+ 9 (hilite 29)))) + (before-after ((define a_0 9) (define b_0 29) (hilite (+ 9 29))) + ((define a_0 9) (define b_0 29) (hilite 38))) + (finished-stepping))) - (let ([def `(define a_0 (lambda (x) (+ x 5)))]) - (t lam-let test-intermediate-sequence - (let ([a (lambda (x) (+ x 5))]) (a 6)) - :: {(let ([a (lambda (x) (+ x 5))]) (a 6))} - -> {(define a_0 (lambda (x) (+ x 5)))} {(a_0 6)} - :: ,def {(a_0 6)} - -> ,def {(+ 6 5)} - -> ,def {11})) - - (let ([defs `((define c1 false) - (define (d2 x) (or c1 false x)))]) - (t whocares test-upto-int - ,@defs (d2 false) - :: ,@defs {(d2 false)} - -> ,@defs {(or c1 false false)} - :: ,@defs (or {c1} false false) - -> ,@defs (or {false} false false) - :: ,@defs {(or false false false)} - -> ,@defs {false})) - - (let ([defs `((define c1 false) - (define (d2 x) (or c1 false x)))]) - (t whocares/lam test-intermediate/lambda-sequence - ,@defs (d2 false) - :: ,@defs ({d2} false) - -> ,@defs ({(lambda (x) (or c1 false x))} false) - :: ,@defs {((lambda (x) (or c1 false x)) false)} - -> ,@defs {(or c1 false false)} - :: ,@defs (or {c1} false false) - -> ,@defs (or {false} false false) - :: ,@defs {(or false false false)} - -> ,@defs {false})) - - (let ([defs `((define (f x) (+ (g x) 10)) (define (g x) (- x 22)))]) - (t forward-ref test-upto-int - ,@defs (f 13) - :: ,@defs {(f 13)} - -> ,@defs {(+ (g 13) 10)} - :: ,@defs (+ {(g 13)} 10) - -> ,@defs (+ {(- 13 22)} 10) - -> ,@defs (+ {-9} 10) - :: ,@defs {(+ -9 10)} - -> ,@defs {1})) - - (let ([defs `((define (f x) (+ (g x) 10)) (define (g x) (- x 22)))]) - (t forward-ref/lam test-intermediate/lambda-sequence - ,@defs (f 13) - :: ,@defs ({f} 13) - -> ,@defs ({(lambda (x) (+ (g x) 10))} 13) - :: ,@defs {((lambda (x) (+ (g x) 10)) 13)} - -> ,@defs {(+ (g 13) 10)} - :: ,@defs (+ ({g} 13) 10) - -> ,@defs (+ ({(lambda (x) (- x 22))} 13) 10) - :: ,@defs (+ {((lambda (x) (- x 22)) 13)} 10) - -> ,@defs (+ {(- 13 22)} 10) - -> ,@defs (+ {-9} 10) - :: ,@defs {(+ -9 10)} - -> ,@defs {1})) - - - ;; loops; I should add a mechanism to stop testing after n steps... - #;(let ([defs '((define (f x) (cond (else (f x)))) - (define (g x) x))]) - (t pnkfelix test-intermediate/lambda-sequence - ,@defs (f (g empty)) - :: ,@defs ({f} (g empty)) - -> ,@defs ({(lambda (x) (cond (else (f x))))} (g empty)) - :: ,@defs ((lambda (x) (cond (else (f x)))) ({g} empty)) - -> ,@defs ((lambda (x) (cond (else (f x)))) ({(lambda (x) x)} empty)))) - - (t bad-cons test-upto-int/lam - (cons 1 2) - :: {(cons 1 2)} - -> error: "cons: second argument must be of type , given 1 and 2") - - (t1 prims - (test-beginner-sequence "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)" - (let ([defs `((cons 3 (cons 1 empty)))]) - `((before-after (,@defs (hilite (list 1 2 3))) - (,@defs (hilite (cons 1 (cons 2 (cons 3 empty)))))) - (finished-stepping))))) - - (t1 prims/non-beginner - (test-bwla-to-int/lam "(cons 3 (cons 1 empty)) (list 1 2 3) (define-struct aa (b)) (make-aa 3)" - `((before-after ((cons 3 (hilite (cons 1 empty)))) ((cons 3 (hilite (list 1))))) - (before-after ((hilite (cons 3 (list 1)))) ((hilite (list 3 1)))) - (finished-stepping)))) +(t1 'let-scoping1 + m:intermediate "(let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4)))" + (let ([d1 `(define a_0 3)] + [d2 `(define a_1 (lambda (x) (+ a_0 x)))]) + `((before-after ((hilite (let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4))))) + ((hilite (define a_0 3)) (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4))))) + (before-after (,d1 (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))) + (,d1 (hilite (define a_1 (lambda (x) (+ a_0 x)))) (hilite (a_1 4)))) + (before-after (,d1 ,d2 (hilite (a_1 4))) + (,d1 ,d2 (hilite (+ a_0 4)))) + (before-after (,d1 ,d2 (+ (hilite a_0) 4)) + (,d1 ,d2 (+ (hilite 3) 4))) + (before-after (,d1 ,d2 (hilite (+ 3 4))) + (,d1 ,d2 (hilite 7))) + (finished-stepping)))) - (t1 map - (test-mz-sequence "(map (lambda (x) x) (list 3 4 5))" - `((before-after ((map (lambda (x) x) (hilite (list 3 4 5)))) - ((map (lambda (x) x) (hilite `( 3 4 5))))) - (before-after ((hilite (map (lambda (x) x) `(3 4 5)))) - ((... (hilite 3) ...))) - (before-after (...) - ((... (hilite 4) ...))) - (before-after (...) - ((... (hilite 5) ...))) - (before-after (...) ((hilite `(3 4 5)))) - (finished-stepping)))) +(t1 'let-scoping2 + m:intermediate-lambda "(let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4)))" + (let* ([d1 `(define a_0 3)] + [defs `(,d1 (define a_1 (lambda (x) (+ a_0 x))))]) + `((before-after ((hilite (let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4))))) + ((hilite (define a_0 3)) (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4))))) + (before-after (,d1 (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))) + (,d1 (hilite (define a_1 (lambda (x) (+ a_0 x)))) (hilite (a_1 4)))) + (before-after (,@defs ((hilite a_1) 4)) + (,@defs ((hilite (lambda (x) (+ a_0 x))) 4))) + (before-after (,@defs (hilite ((lambda (x) (+ a_0 x)) 4))) (,@defs (hilite (+ a_0 4)))) + (before-after (,@defs (+ (hilite a_0) 4)) (,@defs (+ (hilite 3) 4))) + (before-after (,@defs (hilite (+ 3 4))) (,@defs (hilite 7))) + (finished-stepping)))) - (t1 quoted-list - (test-beginner-wla-sequence "'(3 4 5)" - `((finished-stepping)))) +(t1 'let-scoping3 + m:intermediate "(define a12 3) (define c12 19) (let ([a12 13] [b12 a12]) (+ b12 a12 c12))" + (let* ([defs1 `((define a12 3) (define c12 19))] + [defs2 `(,@defs1 (define a12_0 13))] + [defs3 `(,@defs2 (define b12_0 3))]) + `((before-after (,@defs1 (hilite (let ([a12 13] [b12 a12]) (+ b12 a12 c12)))) + (,@defs1 (hilite (define a12_0 13)) (hilite (define b12_0 a12)) (hilite (+ b12_0 a12_0 c12)))) + (before-after (,@defs2 (define b12_0 (hilite a12)) (+ b12_0 a12_0 c12)) + (,@defs2 (define b12_0 (hilite 3)) (+ b12_0 a12_0 c12))) + (before-after (,@defs3 (+ (hilite b12_0) a12_0 c12)) + (,@defs3 (+ (hilite 3) a12_0 c12))) + (before-after (,@defs3 (+ 3 (hilite a12_0) c12)) + (,@defs3 (+ 3 (hilite 13) c12))) + (before-after (,@defs3 (+ 3 13 (hilite c12))) + (,@defs3 (+ 3 13 (hilite 19)))) + (before-after (,@defs3 (hilite (+ 3 13 19))) + (,@defs3 (hilite 35))) + (finished-stepping)))) - (t1 quoted-list-display - (test-bwla-to-int/lam "(define (f x) '((a))) (+ 3 4)" - `((before-after ((define (f x) (list (list 'a))) (hilite (+ 3 4))) - ((define (f x) (list (list 'a))) (hilite 7))) - (finished-stepping)))) +(t1 'let-lifting1 + m:intermediate "(let ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" + `((before-after ((hilite (let ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) + ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (define b_0 (+ 3 4))) (hilite 9))) + (before-after ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite (+ 3 4))) 9) + ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite 7)) 9)) + (finished-stepping))) +(t1 'let-deriv + m:intermediate "(define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" + (let ([defs `((define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) + `((before-after (,@defs (define gprime (hilite (f cos)))) + (,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) + (before-after (,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) + (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) + (finished-stepping)))) - ;;;;;;;;;;;;; - ;; - ;; QUASIQUOTE - ;; - ;;;;;;;;;;;;;. +(t1 'let-assigned + m:intermediate "(define a (let ([f (lambda (x) (+ x 13))]) f))" + `((before-after ((define a (hilite (let ([f (lambda (x) (+ x 13))]) f)))) + ((hilite (define f_0 (lambda (x) (+ x 13)))) (define a (hilite f_0)))) + (finished-stepping))) - ; note: we currently punt on trying to unwind quasiquote. +(t1 'let-assigned/lam + m:intermediate-lambda "(define a (let ([f (lambda (x) (+ x 13))]) f))" + `((before-after ((define a (hilite (let ([f (lambda (x) (+ x 13))]) f)))) + ((hilite (define f_0 (lambda (x) (+ x 13)))) (define a (hilite f_0)))) + (before-after ((define f_0 (lambda (x) (+ x 13))) (define a (hilite f_0))) + ((define f_0 (lambda (x) (+ x 13))) (define a (hilite (lambda (x) (+ x 13)))))) + (finished-stepping))) - (t1 qq1 - (test-beginner-wla-sequence "`(3 4 ,(+ 4 5))" - `((before-after ((cons 3 (cons 4 (cons (hilite (+ 4 5)) empty)))) - ((cons 3 (cons 4 (cons (hilite 9) empty))))) - (before-after ((cons 3 (cons 4 (hilite (cons 9 empty))))) - ((cons 3 (cons 4 (hilite (list 9)))))) - (before-after ((cons 3 (hilite (cons 4 (list 9))))) - ((cons 3 (hilite (list 4 9))))) - (before-after ((hilite (cons 3 (list 4 9)))) ((hilite (list 3 4 9)))) - (finished-stepping)))) +;;;;;;;;;;;;; +;; +;; LET* +;; +;;;;;;;;;;;;; - (t1 qq-splice - (test-beginner-wla-sequence "`(3 ,@(list (+ 3 4) 5) 6)" - `((before-after ((cons 3 (append (list (hilite (+ 3 4)) 5) (cons 6 empty)))) ((cons 3 (append (list (hilite 7) 5) (cons 6 empty))))) - (before-after ((cons 3 (append (list 7 5) (hilite (cons 6 empty))))) ((cons 3 (append (list 7 5) (list 6))))) - (before-after ((cons 3 (hilite (append (list 7 5) (list 6))))) ((cons 3 (hilite (list 7 5 6))))) - (before-after ((hilite (cons 3 (list 7 5 6)))) ((hilite (list 3 7 5 6)))) - (finished-stepping)))) +(t1 'let*-scoping1 + m:both-intermediates "(define a 3) (define c 19) (let* ([a 13] [b a]) (+ b a c))" + (let* ([defs1 `((define a 3) (define c 19))] + [defs2 (append defs1 `((define a_0 13)))] + [defs3 (append defs2 `((define b_1 13)))]) + `((before-after (,@defs1 (hilite (let* ([a 13] [b a]) (+ b a c)))) + (,@defs1 (hilite (define a_0 13)) (hilite (let* ([b a_0]) (+ b a_0 c))))) + (before-after (,@defs2 (hilite (let* ([b a_0]) (+ b a_0 c)))) + (,@defs2 (hilite (define b_1 a_0)) (hilite (+ b_1 a_0 c)))) + (before-after (,@defs2 (define b_1 (hilite a_0)) (+ b_1 a_0 c)) + (,@defs2 (define b_1 (hilite 13)) (+ b_1 a_0 c))) + (before-after (,@defs3 (+ (hilite b_1) a_0 c)) + (,@defs3 (+ (hilite 13) a_0 c))) + (before-after (,@defs3 (+ 13 (hilite a_0) c)) + (,@defs3 (+ 13 (hilite 13) c))) + (before-after (,@defs3 (+ 13 13 (hilite c))) + (,@defs3 (+ 13 13 (hilite 19)))) + (before-after (,@defs3 (hilite (+ 13 13 19))) + (,@defs3 (hilite 45))) + (finished-stepping)))) - ;;;;;;;;;;;;; - ;; - ;; LET - ;; - ;;;;;;;;;;;;; +(t1 'let*-lifting1 + m:intermediate "(let* ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" + (let ([defs `((define a_0 (lambda (x) (+ x 14))))]) + `((before-after ((hilite (let* ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) + ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (let* ([b (+ 3 4)]) 9)))) + (before-after (,@defs (hilite (let* ([b (+ 3 4)]) 9))) + (,@defs (hilite (define b_1 (+ 3 4))) (hilite 9))) + (before-after (,@defs (define b_1 (hilite (+ 3 4))) 9) + (,@defs (define b_1 (hilite 7)) 9)) + (finished-stepping)))) - (t1 let1 (test-both-ints "(let ([a 3]) 4)" - `((before-after ((hilite (let ([a 3]) 4))) ((hilite (define a_0 3)) (hilite 4))) - (finished-stepping)))) +(t1 'let*-deriv + m:intermediate "(define (f g) (let* ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" + (let ([defs `((define (f g) (let* ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) + `((before-after (,@defs (define gprime (hilite (f cos)))) + (,@defs (define gprime (hilite (let* ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) + (before-after (,@defs (define gprime (hilite (let* ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) + (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) + (finished-stepping)))) - (t1 let2 - (test-both-ints "(let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b))" - `((before-after ((hilite (let ([a (+ 4 5)] [b (+ 9 20)]) (+ a b)))) - ((hilite (define a_0 (+ 4 5))) (hilite (define b_0 (+ 9 20))) (hilite (+ a_0 b_0)))) - (before-after ((define a_0 (hilite (+ 4 5))) (define b_0 (+ 9 20)) (+ a_0 b_0)) - ((define a_0 (hilite 9)) (define b_0 (+ 9 20)) (+ a_0 b_0))) - (before-after ((define a_0 9) (define b_0 (hilite (+ 9 20))) (+ a_0 b_0)) - ((define a_0 9) (define b_0 (hilite 29)) (+ a_0 b_0))) - (before-after ((define a_0 9) (define b_0 29) (+ (hilite a_0) b_0)) - ((define a_0 9) (define b_0 29) (+ (hilite 9) b_0))) - (before-after ((define a_0 9) (define b_0 29) (+ 9 (hilite b_0))) - ((define a_0 9) (define b_0 29) (+ 9 (hilite 29)))) - (before-after ((define a_0 9) (define b_0 29) (hilite (+ 9 29))) - ((define a_0 9) (define b_0 29) (hilite 38))) - (finished-stepping)))) +(t1 'let/let* + m:both-intermediates "(let* ([a 9]) (let ([b 6]) a))" + `((before-after ((hilite (let* ([a 9]) (let ([b 6]) a)))) ((hilite (define a_0 9)) (hilite (let ([b 6]) a_0)))) + (before-after ((define a_0 9) (hilite (let ([b 6]) a_0))) + ((define a_0 9) (hilite (define b_1 6)) (hilite a_0))) + (before-after ((define a_0 9) (define b_1 6) (hilite a_0)) + ((define a_0 9) (define b_1 6) (hilite 9))) + (finished-stepping))) - (t1 let-scoping1 - (test-intermediate-sequence "(let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4)))" - (let ([d1 `(define a_0 3)] - [d2 `(define a_1 (lambda (x) (+ a_0 x)))]) - `((before-after ((hilite (let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4))))) - ((hilite (define a_0 3)) (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4))))) - (before-after (,d1 (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))) - (,d1 (hilite (define a_1 (lambda (x) (+ a_0 x)))) (hilite (a_1 4)))) - (before-after (,d1 ,d2 (hilite (a_1 4))) - (,d1 ,d2 (hilite (+ a_0 4)))) - (before-after (,d1 ,d2 (+ (hilite a_0) 4)) - (,d1 ,d2 (+ (hilite 3) 4))) - (before-after (,d1 ,d2 (hilite (+ 3 4))) - (,d1 ,d2 (hilite 7))) - (finished-stepping))))) +;;;;;;;;;;;;; +;; +;; LETREC +;; +;;;;;;;;;;;;; - (t1 let-scoping2 - (test-intermediate/lambda-sequence "(let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4)))" - (let* ([d1 `(define a_0 3)] - [defs `(,d1 (define a_1 (lambda (x) (+ a_0 x))))]) - `((before-after ((hilite (let ([a 3]) (let ([a (lambda (x) (+ a x))]) (a 4))))) - ((hilite (define a_0 3)) (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4))))) - (before-after (,d1 (hilite (let ([a (lambda (x) (+ a_0 x))]) (a 4)))) - (,d1 (hilite (define a_1 (lambda (x) (+ a_0 x)))) (hilite (a_1 4)))) - (before-after (,@defs ((hilite a_1) 4)) - (,@defs ((hilite (lambda (x) (+ a_0 x))) 4))) - (before-after (,@defs (hilite ((lambda (x) (+ a_0 x)) 4))) (,@defs (hilite (+ a_0 4)))) - (before-after (,@defs (+ (hilite a_0) 4)) (,@defs (+ (hilite 3) 4))) - (before-after (,@defs (hilite (+ 3 4))) (,@defs (hilite 7))) - (finished-stepping))))) +(t1 'letrec1 + m:intermediate "(define a 3) (define c 19) (letrec ([a 13] [b a]) (+ b a c))" + (let* ([defs1 `((define a 3) (define c 19))] + [defs2 (append defs1 `((define a_0 13)))] + [defs3 (append defs2 `((define b_0 13)))]) + `((before-after (,@defs1 (hilite (letrec ([a 13] [b a]) (+ b a c)))) + (,@defs1 (hilite (define a_0 13)) (hilite (define b_0 a_0)) (hilite (+ b_0 a_0 c)))) + (before-after (,@defs2 (define b_0 (hilite a_0)) (+ b_0 a_0 c)) + (,@defs2 (define b_0 (hilite 13)) (+ b_0 a_0 c))) + (before-after (,@defs3 (+ (hilite b_0) a_0 c)) + (,@defs3 (+ (hilite 13) a_0 c))) + (before-after (,@defs3 (+ 13 (hilite a_0) c)) + (,@defs3 (+ 13 (hilite 13) c))) + (before-after (,@defs3 (+ 13 13 (hilite c))) + (,@defs3 (+ 13 13 (hilite 19)))) + (before-after (,@defs3 (hilite (+ 13 13 19))) + (,@defs3 (hilite 45))) + (finished-stepping)))) - (t1 let-scoping3 - (test-intermediate-sequence "(define a12 3) (define c12 19) (let ([a12 13] [b12 a12]) (+ b12 a12 c12))" - (let* ([defs1 `((define a12 3) (define c12 19))] - [defs2 `(,@defs1 (define a12_0 13))] - [defs3 `(,@defs2 (define b12_0 3))]) - `((before-after (,@defs1 (hilite (let ([a12 13] [b12 a12]) (+ b12 a12 c12)))) - (,@defs1 (hilite (define a12_0 13)) (hilite (define b12_0 a12)) (hilite (+ b12_0 a12_0 c12)))) - (before-after (,@defs2 (define b12_0 (hilite a12)) (+ b12_0 a12_0 c12)) - (,@defs2 (define b12_0 (hilite 3)) (+ b12_0 a12_0 c12))) - (before-after (,@defs3 (+ (hilite b12_0) a12_0 c12)) - (,@defs3 (+ (hilite 3) a12_0 c12))) - (before-after (,@defs3 (+ 3 (hilite a12_0) c12)) - (,@defs3 (+ 3 (hilite 13) c12))) - (before-after (,@defs3 (+ 3 13 (hilite c12))) - (,@defs3 (+ 3 13 (hilite 19)))) - (before-after (,@defs3 (hilite (+ 3 13 19))) - (,@defs3 (hilite 35))) - (finished-stepping))))) + (t1 'letrec2 + m:intermediate "(letrec ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" + `((before-after ((hilite (letrec ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) + ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (define b_0 (+ 3 4))) (hilite 9))) + (before-after ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite (+ 3 4))) 9) + ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite 7)) 9)) + (finished-stepping))) - (t1 let-lifting1 - (test-intermediate-sequence "(let ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" - `((before-after ((hilite (let ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) - ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (define b_0 (+ 3 4))) (hilite 9))) - (before-after ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite (+ 3 4))) 9) - ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite 7)) 9)) - (finished-stepping)))) - - (t1 let-deriv - (test-intermediate-sequence "(define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" - (let ([defs `((define (f g) (let ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) - `((before-after (,@defs (define gprime (hilite (f cos)))) - (,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) - (before-after (,@defs (define gprime (hilite (let ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) - (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) - (finished-stepping))))) - - (t1 let-assigned - (test-intermediate-sequence "(define a (let ([f (lambda (x) (+ x 13))]) f))" - `((before-after ((define a (hilite (let ([f (lambda (x) (+ x 13))]) f)))) - ((hilite (define f_0 (lambda (x) (+ x 13)))) (define a (hilite f_0)))) - (finished-stepping)))) - - (t1 let-assigned/lam - (test-intermediate/lambda-sequence "(define a (let ([f (lambda (x) (+ x 13))]) f))" - `((before-after ((define a (hilite (let ([f (lambda (x) (+ x 13))]) f)))) - ((hilite (define f_0 (lambda (x) (+ x 13)))) (define a (hilite f_0)))) - (before-after ((define f_0 (lambda (x) (+ x 13))) (define a (hilite f_0))) - ((define f_0 (lambda (x) (+ x 13))) (define a (hilite (lambda (x) (+ x 13)))))) - (finished-stepping)))) - - ;;;;;;;;;;;;; - ;; - ;; LET* - ;; - ;;;;;;;;;;;;; - - (t1 let*-scoping1 - (test-both-ints "(define a 3) (define c 19) (let* ([a 13] [b a]) (+ b a c))" - (let* ([defs1 `((define a 3) (define c 19))] - [defs2 (append defs1 `((define a_0 13)))] - [defs3 (append defs2 `((define b_1 13)))]) - `((before-after (,@defs1 (hilite (let* ([a 13] [b a]) (+ b a c)))) - (,@defs1 (hilite (define a_0 13)) (hilite (let* ([b a_0]) (+ b a_0 c))))) - (before-after (,@defs2 (hilite (let* ([b a_0]) (+ b a_0 c)))) - (,@defs2 (hilite (define b_1 a_0)) (hilite (+ b_1 a_0 c)))) - (before-after (,@defs2 (define b_1 (hilite a_0)) (+ b_1 a_0 c)) - (,@defs2 (define b_1 (hilite 13)) (+ b_1 a_0 c))) - (before-after (,@defs3 (+ (hilite b_1) a_0 c)) - (,@defs3 (+ (hilite 13) a_0 c))) - (before-after (,@defs3 (+ 13 (hilite a_0) c)) - (,@defs3 (+ 13 (hilite 13) c))) - (before-after (,@defs3 (+ 13 13 (hilite c))) - (,@defs3 (+ 13 13 (hilite 19)))) - (before-after (,@defs3 (hilite (+ 13 13 19))) - (,@defs3 (hilite 45))) - (finished-stepping))))) - - (t1 let*-lifting1 - (test-intermediate-sequence "(let* ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" - (let ([defs `((define a_0 (lambda (x) (+ x 14))))]) - `((before-after ((hilite (let* ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) - ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (let* ([b (+ 3 4)]) 9)))) - (before-after (,@defs (hilite (let* ([b (+ 3 4)]) 9))) - (,@defs (hilite (define b_1 (+ 3 4))) (hilite 9))) - (before-after (,@defs (define b_1 (hilite (+ 3 4))) 9) - (,@defs (define b_1 (hilite 7)) 9)) - (finished-stepping))))) - - (t1 let*-deriv - (test-intermediate-sequence "(define (f g) (let* ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" - (let ([defs `((define (f g) (let* ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) - `((before-after (,@defs (define gprime (hilite (f cos)))) - (,@defs (define gprime (hilite (let* ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) - (before-after (,@defs (define gprime (hilite (let* ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) - (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) - (finished-stepping))))) - - (t1 let/let* - (test-both-ints "(let* ([a 9]) (let ([b 6]) a))" - `((before-after ((hilite (let* ([a 9]) (let ([b 6]) a)))) ((hilite (define a_0 9)) (hilite (let ([b 6]) a_0)))) - (before-after ((define a_0 9) (hilite (let ([b 6]) a_0))) - ((define a_0 9) (hilite (define b_1 6)) (hilite a_0))) - (before-after ((define a_0 9) (define b_1 6) (hilite a_0)) - ((define a_0 9) (define b_1 6) (hilite 9))) - (finished-stepping)))) - - ;;;;;;;;;;;;; - ;; - ;; LETREC - ;; - ;;;;;;;;;;;;; - - (t1 letrec1 - (test-intermediate-sequence "(define a 3) (define c 19) (letrec ([a 13] [b a]) (+ b a c))" - (let* ([defs1 `((define a 3) (define c 19))] - [defs2 (append defs1 `((define a_0 13)))] - [defs3 (append defs2 `((define b_0 13)))]) - `((before-after (,@defs1 (hilite (letrec ([a 13] [b a]) (+ b a c)))) - (,@defs1 (hilite (define a_0 13)) (hilite (define b_0 a_0)) (hilite (+ b_0 a_0 c)))) - (before-after (,@defs2 (define b_0 (hilite a_0)) (+ b_0 a_0 c)) - (,@defs2 (define b_0 (hilite 13)) (+ b_0 a_0 c))) - (before-after (,@defs3 (+ (hilite b_0) a_0 c)) - (,@defs3 (+ (hilite 13) a_0 c))) - (before-after (,@defs3 (+ 13 (hilite a_0) c)) - (,@defs3 (+ 13 (hilite 13) c))) - (before-after (,@defs3 (+ 13 13 (hilite c))) - (,@defs3 (+ 13 13 (hilite 19)))) - (before-after (,@defs3 (hilite (+ 13 13 19))) - (,@defs3 (hilite 45))) - (finished-stepping))))) - - (t1 letrec2 - (test-intermediate-sequence "(letrec ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9)" - `((before-after ((hilite (letrec ([a (lambda (x) (+ x 14))] [b (+ 3 4)]) 9))) - ((hilite (define a_0 (lambda (x) (+ x 14)))) (hilite (define b_0 (+ 3 4))) (hilite 9))) - (before-after ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite (+ 3 4))) 9) - ((define a_0 (lambda (x) (+ x 14))) (define b_0 (hilite 7)) 9)) - (finished-stepping)))) - - (t1 letrec3 - (test-intermediate-sequence "(define (f g) (letrec ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" - (let ([defs `((define (f g) (letrec ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) - `((before-after (,@defs (define gprime (hilite (f cos)))) - (,@defs (define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) - (before-after (,@defs (define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) - (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) - (finished-stepping))))) + (t1 'letrec3 + m:intermediate "(define (f g) (letrec ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)) (define gprime (f cos))" + (let ([defs `((define (f g) (letrec ([gp (lambda (x) (/ (- (g (+ x 0.1)) (g x)) 0.001))]) gp)))]) + `((before-after (,@defs (define gprime (hilite (f cos)))) + (,@defs (define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp))))) + (before-after (,@defs (define gprime (hilite (letrec ([gp (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001))]) gp)))) + (,@defs (hilite (define gp_0 (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.001)))) (define gprime (hilite gp_0)))) + (finished-stepping)))) ;;;;;;;;;;;;; ;; ;; RECUR @@ -993,45 +721,45 @@ ;; just the applied loop identifier. This is hard to fix because we have an application which is initially hidden, but then later ;; not hidden. Fixing this involves parameterizing the unwind by what kind of break it was. Yuck! So we just fudge the test case. - (t1 recur - (test-advanced-sequence "(define (countdown n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))) (countdown 2)" - (let* ([defs1 `((define (countdown n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))))] - [defs2 (append defs1 `((define (loop_0 n) (if (= n 0) 13 (loop_0 (- n 1))))))]) - `((before-after (,@defs1 ((hilite countdown) 2)) - (,@defs1 ((hilite (lambda (n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1)))))) 2))) - (before-after (,@defs1 (hilite ((lambda (n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))) 2))) - (,@defs1 (hilite (recur loop ([n 2]) (if (= n 0) 13 (loop (- n 1))))))) - (before-after (,@defs1 (hilite (recur loop ([n 2]) (if (= n 0) 13 (loop (- n 1)))))) - (,@defs1 (hilite (define (loop_0 n) (if (= n 0) 13 (loop_0 (- n 1))))) ((hilite loop_0) 2))) - (before-after (,@defs2 ((hilite loop_0) 2)) - (,@defs2 ((hilite (lambda (n) (if (= n 0) 13 (loop_0 (- n 1))))) 2))) - (before-after (,@defs2 (hilite ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) 2))) - (,@defs2 (hilite (if (= 2 0) 13 (loop_0 (- 2 1)))))) - (before-after (,@defs2 (if (hilite (= 2 0)) 13 (loop_0 (- 2 1)))) - (,@defs2 (if (hilite false) 13 (loop_0 (- 2 1))))) - (before-after (,@defs2 (hilite (if false 13 (loop_0 (- 2 1))))) - (,@defs2 (hilite (loop_0 (- 2 1))))) - (before-after (,@defs2 ((hilite loop_0) (- 2 1))) - (,@defs2 ((hilite (lambda (n) (if (= n 0) 13 (loop_0 (- n 1))))) (- 2 1)))) - (before-after (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite (- 2 1)))) - (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite 1)))) - (before-after (,@defs2 (hilite ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) 1))) - (,@defs2 (hilite (if (= 1 0) 13 (loop_0 (- 1 1)))))) - (before-after (,@defs2 (if (hilite (= 1 0)) 13 (loop_0 (- 1 1)))) - (,@defs2 (if (hilite false) 13 (loop_0 (- 1 1))))) - (before-after (,@defs2 (hilite (if false 13 (loop_0 (- 1 1))))) - (,@defs2 (hilite (loop_0 (- 1 1))))) - (before-after (,@defs2 ((hilite loop_0) (- 1 1))) - (,@defs2 ((hilite (lambda (n) (if (= n 0) 13 (loop_0 (- n 1))))) (- 1 1)))) - (before-after (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite (- 1 1)))) - (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite 0)))) - (before-after (,@defs2 (hilite ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) 0))) - (,@defs2 (hilite (if (= 0 0) 13 (loop_0 (- 0 1)))))) - (before-after (,@defs2 (if (hilite (= 0 0)) 13 (loop_0 (- 0 1)))) - (,@defs2 (if (hilite true) 13 (loop_0 (- 0 1))))) - (before-after (,@defs2 (hilite (if true 13 (loop_0 (- 0 1))))) - (,@defs2 (hilite 13))) - (finished-stepping))))) + (t1 'recur + m:advanced "(define (countdown n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))) (countdown 2)" + (let* ([defs1 `((define (countdown n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))))] + [defs2 (append defs1 `((define (loop_0 n) (if (= n 0) 13 (loop_0 (- n 1))))))]) + `((before-after (,@defs1 ((hilite countdown) 2)) + (,@defs1 ((hilite (lambda (n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1)))))) 2))) + (before-after (,@defs1 (hilite ((lambda (n) (recur loop ([n n]) (if (= n 0) 13 (loop (- n 1))))) 2))) + (,@defs1 (hilite (recur loop ([n 2]) (if (= n 0) 13 (loop (- n 1))))))) + (before-after (,@defs1 (hilite (recur loop ([n 2]) (if (= n 0) 13 (loop (- n 1)))))) + (,@defs1 (hilite (define (loop_0 n) (if (= n 0) 13 (loop_0 (- n 1))))) ((hilite loop_0) 2))) + (before-after (,@defs2 ((hilite loop_0) 2)) + (,@defs2 ((hilite (lambda (n) (if (= n 0) 13 (loop_0 (- n 1))))) 2))) + (before-after (,@defs2 (hilite ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) 2))) + (,@defs2 (hilite (if (= 2 0) 13 (loop_0 (- 2 1)))))) + (before-after (,@defs2 (if (hilite (= 2 0)) 13 (loop_0 (- 2 1)))) + (,@defs2 (if (hilite false) 13 (loop_0 (- 2 1))))) + (before-after (,@defs2 (hilite (if false 13 (loop_0 (- 2 1))))) + (,@defs2 (hilite (loop_0 (- 2 1))))) + (before-after (,@defs2 ((hilite loop_0) (- 2 1))) + (,@defs2 ((hilite (lambda (n) (if (= n 0) 13 (loop_0 (- n 1))))) (- 2 1)))) + (before-after (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite (- 2 1)))) + (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite 1)))) + (before-after (,@defs2 (hilite ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) 1))) + (,@defs2 (hilite (if (= 1 0) 13 (loop_0 (- 1 1)))))) + (before-after (,@defs2 (if (hilite (= 1 0)) 13 (loop_0 (- 1 1)))) + (,@defs2 (if (hilite false) 13 (loop_0 (- 1 1))))) + (before-after (,@defs2 (hilite (if false 13 (loop_0 (- 1 1))))) + (,@defs2 (hilite (loop_0 (- 1 1))))) + (before-after (,@defs2 ((hilite loop_0) (- 1 1))) + (,@defs2 ((hilite (lambda (n) (if (= n 0) 13 (loop_0 (- n 1))))) (- 1 1)))) + (before-after (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite (- 1 1)))) + (,@defs2 ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) (hilite 0)))) + (before-after (,@defs2 (hilite ((lambda (n) (if (= n 0) 13 (loop_0 (- n 1)))) 0))) + (,@defs2 (hilite (if (= 0 0) 13 (loop_0 (- 0 1)))))) + (before-after (,@defs2 (if (hilite (= 0 0)) 13 (loop_0 (- 0 1)))) + (,@defs2 (if (hilite true) 13 (loop_0 (- 0 1))))) + (before-after (,@defs2 (hilite (if true 13 (loop_0 (- 0 1))))) + (,@defs2 (hilite 13))) + (finished-stepping)))) ;;;;;;;;;;;;; ;; @@ -1040,166 +768,166 @@ ;;;;;;;;;;;;; - (t1 empty-local - (test-both-ints "(local () (+ 3 4))" - `((before-after ((hilite (local () (+ 3 4)))) ((hilite (+ 3 4)))) - (before-after ((hilite (+ 3 4))) ((hilite 7))) - (finished-stepping)))) + (t1 'empty-local + m:both-intermediates "(local () (+ 3 4))" + `((before-after ((hilite (local () (+ 3 4)))) ((hilite (+ 3 4)))) + (before-after ((hilite (+ 3 4))) ((hilite 7))) + (finished-stepping))) - (t1 local1 - (test-both-ints "(local ((define a 3) (define b 8)) 4)" - `((before-after ((hilite (local ((define a 3) (define b 8)) 4))) - ((hilite (define a_0 3)) (hilite (define b_0 8)) (hilite 4))) - (finished-stepping)))) + (t1 'local1 + m:both-intermediates "(local ((define a 3) (define b 8)) 4)" + `((before-after ((hilite (local ((define a 3) (define b 8)) 4))) + ((hilite (define a_0 3)) (hilite (define b_0 8)) (hilite 4))) + (finished-stepping))) - (t1 local2 - (test-intermediate-sequence "(local ((define (a x) (+ x 9))) (a 6))" - (let ([defs `((define (a_0 x) (+ x 9)))]) - `((before-after ((hilite (local ((define (a x) (+ x 9))) (a 6)))) - ((hilite (define (a_0 x) (+ x 9))) (hilite (a_0 6)))) - (before-after (,@defs (hilite (a_0 6))) - (,@defs (hilite (+ 6 9)))) - (before-after (,@defs (hilite (+ 6 9))) - (,@defs (hilite 15))) - (finished-stepping))))) + (t1 'local2 + m:intermediate "(local ((define (a x) (+ x 9))) (a 6))" + (let ([defs `((define (a_0 x) (+ x 9)))]) + `((before-after ((hilite (local ((define (a x) (+ x 9))) (a 6)))) + ((hilite (define (a_0 x) (+ x 9))) (hilite (a_0 6)))) + (before-after (,@defs (hilite (a_0 6))) + (,@defs (hilite (+ 6 9)))) + (before-after (,@defs (hilite (+ 6 9))) + (,@defs (hilite 15))) + (finished-stepping)))) - (t1 local3 - (test-intermediate/lambda-sequence "(local ((define (a x) (+ x 9))) (a 6))" - (let ([defs `((define (a_0 x) (+ x 9)))]) - `((before-after ((hilite (local ((define (a x) (+ x 9))) (a 6)))) - ((hilite (define (a_0 x) (+ x 9))) (hilite (a_0 6)))) - (before-after (,@defs ((hilite a_0) 6)) - (,@defs ((hilite (lambda (x) (+ x 9))) 6))) - (before-after (,@defs (hilite ((lambda (x) (+ x 9)) 6))) - (,@defs (hilite (+ 6 9)))) - (before-after (,@defs (hilite (+ 6 9))) - (,@defs (hilite 15))) - (finished-stepping))))) + (t1 'local3 + m:intermediate-lambda "(local ((define (a x) (+ x 9))) (a 6))" + (let ([defs `((define (a_0 x) (+ x 9)))]) + `((before-after ((hilite (local ((define (a x) (+ x 9))) (a 6)))) + ((hilite (define (a_0 x) (+ x 9))) (hilite (a_0 6)))) + (before-after (,@defs ((hilite a_0) 6)) + (,@defs ((hilite (lambda (x) (+ x 9))) 6))) + (before-after (,@defs (hilite ((lambda (x) (+ x 9)) 6))) + (,@defs (hilite (+ 6 9)))) + (before-after (,@defs (hilite (+ 6 9))) + (,@defs (hilite 15))) + (finished-stepping)))) - (t1 local4 - (test-intermediate-sequence "(local ((define (a x) (+ x 13))) a)" - `((before-after ((hilite (local ((define (a x) (+ x 13))) a))) ((hilite (define (a_0 x) (+ x 13))) (hilite a_0))) - (finished-stepping)))) + (t1 'local4 + m:intermediate "(local ((define (a x) (+ x 13))) a)" + `((before-after ((hilite (local ((define (a x) (+ x 13))) a))) ((hilite (define (a_0 x) (+ x 13))) (hilite a_0))) + (finished-stepping))) - (t1 local5 - (test-intermediate/lambda-sequence "(local ((define (a x) (+ x 13))) a)" - `((before-after ((hilite (local ((define (a x) (+ x 13))) a))) - ((hilite (define (a_0 x) (+ x 13))) (hilite a_0))) - (before-after ((define (a_0 x) (+ x 13)) (hilite a_0)) - ((define (a_0 x) (+ x 13)) (hilite (lambda (x) (+ x 13))))) - (finished-stepping)))) + (t1 'local5 + m:intermediate-lambda "(local ((define (a x) (+ x 13))) a)" + `((before-after ((hilite (local ((define (a x) (+ x 13))) a))) + ((hilite (define (a_0 x) (+ x 13))) (hilite a_0))) + (before-after ((define (a_0 x) (+ x 13)) (hilite a_0)) + ((define (a_0 x) (+ x 13)) (hilite (lambda (x) (+ x 13))))) + (finished-stepping))) - (t1 local-interref1 - (test-intermediate-sequence "(local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))" - (let* ([defs1 `((define (a_0 x) (+ x 9)) (define b_0 a_0))] - [defs2 (append defs1 `((define p_0 7)))]) - `((before-after ((hilite (local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1)))) - ((hilite (define (a_0 x) (+ x 9))) (hilite (define b_0 a_0)) (hilite (define p_0 (+ 3 4))) (hilite (b_0 1)))) - (before-after (,@defs1 (define p_0 (hilite (+ 3 4))) (b_0 1)) - (,@defs1 (define p_0 (hilite 7)) (b_0 1))) - (before-after (,@defs2 ((hilite b_0) 1)) - (,@defs2 ((hilite a_0) 1))) - (before-after (,@defs2 (hilite (a_0 1))) - (,@defs2 (hilite (+ 1 9)))) - (before-after (,@defs2 (hilite (+ 1 9))) - (,@defs2 (hilite 10))) - (finished-stepping))))) + (t1 'local-interref1 + m:intermediate "(local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))" + (let* ([defs1 `((define (a_0 x) (+ x 9)) (define b_0 a_0))] + [defs2 (append defs1 `((define p_0 7)))]) + `((before-after ((hilite (local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1)))) + ((hilite (define (a_0 x) (+ x 9))) (hilite (define b_0 a_0)) (hilite (define p_0 (+ 3 4))) (hilite (b_0 1)))) + (before-after (,@defs1 (define p_0 (hilite (+ 3 4))) (b_0 1)) + (,@defs1 (define p_0 (hilite 7)) (b_0 1))) + (before-after (,@defs2 ((hilite b_0) 1)) + (,@defs2 ((hilite a_0) 1))) + (before-after (,@defs2 (hilite (a_0 1))) + (,@defs2 (hilite (+ 1 9)))) + (before-after (,@defs2 (hilite (+ 1 9))) + (,@defs2 (hilite 10))) + (finished-stepping)))) - (t1 local-interref2 - (test-intermediate/lambda-sequence "(local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))" - (let* ([defs1 `((define (a_0 x) (+ x 9)))] - [defs2 (append defs1 `((define b_0 (lambda (x) (+ x 9)))))] - [defs3 (append defs2 `((define p_0 7)))]) - `((before-after ((hilite (local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1)))) - ((hilite (define (a_0 x) (+ x 9))) (hilite (define b_0 a_0)) (hilite (define p_0 (+ 3 4))) (hilite (b_0 1)))) - (before-after (,@defs1 (define b_0 (hilite a_0)) (define p_0 (+ 3 4)) (b_0 1)) - (,@defs1 (define b_0 (hilite (lambda (x) (+ x 9)))) (define p_0 (+ 3 4)) (b_0 1))) - (before-after (,@defs2 (define p_0 (hilite (+ 3 4))) (b_0 1)) - (,@defs2 (define p_0 (hilite 7)) (b_0 1))) - (before-after (,@defs3 ((hilite b_0) 1)) - (,@defs3 ((hilite (lambda (x) (+ x 9))) 1))) - (before-after (,@defs3 (hilite ((lambda (x) (+ x 9)) 1))) - (,@defs3 (hilite (+ 1 9)))) - (before-after (,@defs3 (hilite (+ 1 9))) - (,@defs3 (hilite 10))) - (finished-stepping))))) + (t1 'local-interref2 + m:intermediate-lambda "(local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1))" + (let* ([defs1 `((define (a_0 x) (+ x 9)))] + [defs2 (append defs1 `((define b_0 (lambda (x) (+ x 9)))))] + [defs3 (append defs2 `((define p_0 7)))]) + `((before-after ((hilite (local ((define (a x) (+ x 9)) (define b a) (define p (+ 3 4))) (b 1)))) + ((hilite (define (a_0 x) (+ x 9))) (hilite (define b_0 a_0)) (hilite (define p_0 (+ 3 4))) (hilite (b_0 1)))) + (before-after (,@defs1 (define b_0 (hilite a_0)) (define p_0 (+ 3 4)) (b_0 1)) + (,@defs1 (define b_0 (hilite (lambda (x) (+ x 9)))) (define p_0 (+ 3 4)) (b_0 1))) + (before-after (,@defs2 (define p_0 (hilite (+ 3 4))) (b_0 1)) + (,@defs2 (define p_0 (hilite 7)) (b_0 1))) + (before-after (,@defs3 ((hilite b_0) 1)) + (,@defs3 ((hilite (lambda (x) (+ x 9))) 1))) + (before-after (,@defs3 (hilite ((lambda (x) (+ x 9)) 1))) + (,@defs3 (hilite (+ 1 9)))) + (before-after (,@defs3 (hilite (+ 1 9))) + (,@defs3 (hilite 10))) + (finished-stepping)))) - (t1 local-gprime - (test-intermediate-sequence "(define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) (define gprime (f12 cos))" - (let ([defs `((define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)))]) - `((before-after (,@defs (define gprime (hilite (f12 cos)))) - (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp))))) - (before-after (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp)))) - (,@defs (hilite (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) (define gprime (hilite gp_0)))) - (finished-stepping))))) + (t1 'local-gprime + m:intermediate "(define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) (define gprime (f12 cos))" + (let ([defs `((define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)))]) + `((before-after (,@defs (define gprime (hilite (f12 cos)))) + (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp))))) + (before-after (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp)))) + (,@defs (hilite (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) (define gprime (hilite gp_0)))) + (finished-stepping)))) - (t1 local-gprime/lambda - (test-intermediate/lambda-sequence "(define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) (define gprime (f12 cos))" - (let ([defs `((define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)))]) - `((before-after (,@defs (define gprime ((hilite f12) cos))) - (,@defs (define gprime ((hilite (lambda (g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp))) cos)))) - (before-after (,@defs (define gprime (hilite ((lambda (g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) cos)))) - (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp))))) - (before-after (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp)))) - (,@defs (hilite (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) (define gprime (hilite gp_0)))) - (before-after (,@defs (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)) (define gprime (hilite gp_0))) - (,@defs - (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)) - (define gprime (hilite (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)))))) - (finished-stepping))))) + (t1 'local-gprime/lambda + m:intermediate-lambda "(define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) (define gprime (f12 cos))" + (let ([defs `((define (f12 g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)))]) + `((before-after (,@defs (define gprime ((hilite f12) cos))) + (,@defs (define gprime ((hilite (lambda (g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp))) cos)))) + (before-after (,@defs (define gprime (hilite ((lambda (g) (local ([define (gp x) (/ (- (g (+ x 0.1)) (g x)) 0.1)]) gp)) cos)))) + (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp))))) + (before-after (,@defs (define gprime (hilite (local ([define (gp x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)]) gp)))) + (,@defs (hilite (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1))) (define gprime (hilite gp_0)))) + (before-after (,@defs (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)) (define gprime (hilite gp_0))) + (,@defs + (define (gp_0 x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)) + (define gprime (hilite (lambda (x) (/ (- (cos (+ x 0.1)) (cos x)) 0.1)))))) + (finished-stepping)))) ; test generativity... that is, multiple evaluations of a local should get different lifted names: - (t1 local-generative - (test-intermediate-sequence "(define (a13 b13 c13) (b13 c13)) (define (f9 x) (local ((define (maker dc) x)) maker)) (define m1 (f9 3)) (a13 (f9 4) 1)" - (let* ([defs1 `((define (a13 b13 c13) (b13 c13)) - (define (f9 x) (local ((define (maker dc) x)) maker)))] - [defs2 (append defs1 `((define (maker_0 dc) 3) (define m1 maker_0)))] - [defs3 (append defs2 `((define (maker_1 dc) 4)))]) - `((before-after (,@defs1 (define m1 (hilite (f9 3)))) - (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker))))) - (before-after (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker)))) - (,@defs1 (hilite (define (maker_0 dc) 3)) (define m1 (hilite maker_0)))) - (before-after (,@defs2 (a13 (hilite (f9 4)) 1)) - (,@defs2 (a13 (hilite (local ((define (maker dc) 4)) maker)) 1))) - (before-after (,@defs2 (a13 (hilite (local ((define (maker dc) 4)) maker)) 1)) - (,@defs2 (hilite (define (maker_1 dc) 4)) (a13 (hilite maker_1) 1))) - (before-after (,@defs3 (hilite (a13 maker_1 1))) - (,@defs3 (hilite (maker_1 1)))) - (before-after (,@defs3 (hilite (maker_1 1))) - (,@defs3 (hilite 4))) - (finished-stepping))))) + (t1 'local-generative + m:intermediate "(define (a13 b13 c13) (b13 c13)) (define (f9 x) (local ((define (maker dc) x)) maker)) (define m1 (f9 3)) (a13 (f9 4) 1)" + (let* ([defs1 `((define (a13 b13 c13) (b13 c13)) + (define (f9 x) (local ((define (maker dc) x)) maker)))] + [defs2 (append defs1 `((define (maker_0 dc) 3) (define m1 maker_0)))] + [defs3 (append defs2 `((define (maker_1 dc) 4)))]) + `((before-after (,@defs1 (define m1 (hilite (f9 3)))) + (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker))))) + (before-after (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker)))) + (,@defs1 (hilite (define (maker_0 dc) 3)) (define m1 (hilite maker_0)))) + (before-after (,@defs2 (a13 (hilite (f9 4)) 1)) + (,@defs2 (a13 (hilite (local ((define (maker dc) 4)) maker)) 1))) + (before-after (,@defs2 (a13 (hilite (local ((define (maker dc) 4)) maker)) 1)) + (,@defs2 (hilite (define (maker_1 dc) 4)) (a13 (hilite maker_1) 1))) + (before-after (,@defs3 (hilite (a13 maker_1 1))) + (,@defs3 (hilite (maker_1 1)))) + (before-after (,@defs3 (hilite (maker_1 1))) + (,@defs3 (hilite 4))) + (finished-stepping)))) - (t1 local-generative/lambda - (test-intermediate/lambda-sequence "(define (a13 b13 c13) (b13 c13)) (define (f9 x) (local ((define (maker dc) x)) maker)) (define m1 (f9 3)) (a13 (f9 4) 1)" - (let* ([defs1 `((define (a13 b13 c13) (b13 c13)) - (define (f9 x) (local ((define (maker dc) x)) maker)))] - [defs2 (append defs1 `((define (maker_0 dc) 3)))] - [defs3 (append defs2 `((define m1 (lambda (dc) 3))))] - [defs4 (append defs3 `((define (maker_1 dc) 4)))]) - `((before-after (,@defs1 (define m1 ((hilite f9) 3))) - (,@defs1 (define m1 ((hilite (lambda (x) (local ((define (maker dc) x)) maker))) 3)))) - (before-after (,@defs1 (define m1 (hilite ((lambda (x) (local ((define (maker dc) x)) maker)) 3)))) - (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker))))) - (before-after (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker)))) - (,@defs1 (hilite (define (maker_0 dc) 3)) (define m1 (hilite maker_0)))) - (before-after (,@defs2 (define m1 (hilite maker_0))) - (,@defs2 (define m1 (hilite (lambda (dc) 3))))) - (before-after (,@defs3 ((hilite a13) (f9 4) 1)) - (,@defs3 ((hilite (lambda (b13 c13) (b13 c13))) (f9 4) 1))) - (before-after (,@defs3 ((lambda (b13 c13) (b13 c13)) ((hilite f9) 4) 1)) - (,@defs3 ((lambda (b13 c13) (b13 c13)) ((hilite (lambda (x) (local ((define (maker dc) x)) maker))) 4) 1))) - (before-after (,@defs3 ((lambda (b13 c13) (b13 c13)) (hilite ((lambda (x) (local ((define (maker dc) x)) maker)) 4)) 1)) - (,@defs3 ((lambda (b13 c13) (b13 c13)) (hilite (local ((define (maker dc) 4)) maker)) 1))) - (before-after (,@defs3 ((lambda (b13 c13) (b13 c13)) (hilite (local ((define (maker dc) 4)) maker)) 1)) - (,@defs3 (hilite (define (maker_1 dc) 4)) ((lambda (b13 c13) (b13 c13)) (hilite maker_1) 1))) - (before-after (,@defs4 ((lambda (b13 c13) (b13 c13)) (hilite maker_1) 1)) - (,@defs4 ((lambda (b13 c13) (b13 c13)) (hilite (lambda (dc) 4)) 1))) - (before-after (,@defs4 (hilite ((lambda (b13 c13) (b13 c13)) (lambda (dc) 4) 1))) - (,@defs4 (hilite ((lambda (dc) 4) 1)))) - (before-after (,@defs4 (hilite ((lambda (dc) 4) 1))) - (,@defs4 (hilite 4))) - (finished-stepping))))) + (t1 'local-generative/lambda + m:intermediate-lambda "(define (a13 b13 c13) (b13 c13)) (define (f9 x) (local ((define (maker dc) x)) maker)) (define m1 (f9 3)) (a13 (f9 4) 1)" + (let* ([defs1 `((define (a13 b13 c13) (b13 c13)) + (define (f9 x) (local ((define (maker dc) x)) maker)))] + [defs2 (append defs1 `((define (maker_0 dc) 3)))] + [defs3 (append defs2 `((define m1 (lambda (dc) 3))))] + [defs4 (append defs3 `((define (maker_1 dc) 4)))]) + `((before-after (,@defs1 (define m1 ((hilite f9) 3))) + (,@defs1 (define m1 ((hilite (lambda (x) (local ((define (maker dc) x)) maker))) 3)))) + (before-after (,@defs1 (define m1 (hilite ((lambda (x) (local ((define (maker dc) x)) maker)) 3)))) + (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker))))) + (before-after (,@defs1 (define m1 (hilite (local ((define (maker dc) 3)) maker)))) + (,@defs1 (hilite (define (maker_0 dc) 3)) (define m1 (hilite maker_0)))) + (before-after (,@defs2 (define m1 (hilite maker_0))) + (,@defs2 (define m1 (hilite (lambda (dc) 3))))) + (before-after (,@defs3 ((hilite a13) (f9 4) 1)) + (,@defs3 ((hilite (lambda (b13 c13) (b13 c13))) (f9 4) 1))) + (before-after (,@defs3 ((lambda (b13 c13) (b13 c13)) ((hilite f9) 4) 1)) + (,@defs3 ((lambda (b13 c13) (b13 c13)) ((hilite (lambda (x) (local ((define (maker dc) x)) maker))) 4) 1))) + (before-after (,@defs3 ((lambda (b13 c13) (b13 c13)) (hilite ((lambda (x) (local ((define (maker dc) x)) maker)) 4)) 1)) + (,@defs3 ((lambda (b13 c13) (b13 c13)) (hilite (local ((define (maker dc) 4)) maker)) 1))) + (before-after (,@defs3 ((lambda (b13 c13) (b13 c13)) (hilite (local ((define (maker dc) 4)) maker)) 1)) + (,@defs3 (hilite (define (maker_1 dc) 4)) ((lambda (b13 c13) (b13 c13)) (hilite maker_1) 1))) + (before-after (,@defs4 ((lambda (b13 c13) (b13 c13)) (hilite maker_1) 1)) + (,@defs4 ((lambda (b13 c13) (b13 c13)) (hilite (lambda (dc) 4)) 1))) + (before-after (,@defs4 (hilite ((lambda (b13 c13) (b13 c13)) (lambda (dc) 4) 1))) + (,@defs4 (hilite ((lambda (dc) 4) 1)))) + (before-after (,@defs4 (hilite ((lambda (dc) 4) 1))) + (,@defs4 (hilite 4))) + (finished-stepping)))) ;;;;;;;;;;;;; ;; @@ -1207,32 +935,32 @@ ;; ;;;;;;;;;;;;; - (t1 int/lam1 - (test-intermediate/lambda-sequence "(define f ((lambda (x) x) (lambda (x) x))) (f f)" - (let ([defs `((define f (lambda (x) x)))]) - `((before-after ((define f (hilite ((lambda (x) x) (lambda (x) x))))) - ((define f (hilite (lambda (x) x))))) - (before-after (,@defs ((hilite f) f)) - (,@defs ((hilite (lambda (x) x)) f))) - (before-after (,@defs ((lambda (x) x) (hilite f))) - (,@defs ((lambda (x) x) (hilite (lambda (x) x))))) - (before-after (,@defs (hilite ((lambda (x) x) (lambda (x) x)))) - (,@defs (hilite (lambda (x) x)))) - (finished-stepping))))) + (t1 'int/lam1 + m:intermediate-lambda "(define f ((lambda (x) x) (lambda (x) x))) (f f)" + (let ([defs `((define f (lambda (x) x)))]) + `((before-after ((define f (hilite ((lambda (x) x) (lambda (x) x))))) + ((define f (hilite (lambda (x) x))))) + (before-after (,@defs ((hilite f) f)) + (,@defs ((hilite (lambda (x) x)) f))) + (before-after (,@defs ((lambda (x) x) (hilite f))) + (,@defs ((lambda (x) x) (hilite (lambda (x) x))))) + (before-after (,@defs (hilite ((lambda (x) x) (lambda (x) x)))) + (,@defs (hilite (lambda (x) x)))) + (finished-stepping)))) - (t1 int/lam2 - (test-intermediate/lambda-sequence "(define f (if false (lambda (x) x) (lambda (x) x))) (f f)" - (let ([defs `((define f (lambda (x) x)))]) - `((before-after ((define f (hilite (if false (lambda (x) x) (lambda (x) x))))) - ((define f (hilite (lambda (x) x))))) - (before-after (,@defs ((hilite f) f)) - (,@defs ((hilite (lambda (x) x)) f))) - (before-after (,@defs ((lambda (x) x) (hilite f))) - (,@defs ((lambda (x) x) (hilite (lambda (x) x))))) - (before-after (,@defs (hilite ((lambda (x) x) (lambda (x) x)))) - (,@defs (hilite (lambda (x) x)))) - (finished-stepping))))) + (t1 'int/lam2 + m:intermediate-lambda "(define f (if false (lambda (x) x) (lambda (x) x))) (f f)" + (let ([defs `((define f (lambda (x) x)))]) + `((before-after ((define f (hilite (if false (lambda (x) x) (lambda (x) x))))) + ((define f (hilite (lambda (x) x))))) + (before-after (,@defs ((hilite f) f)) + (,@defs ((hilite (lambda (x) x)) f))) + (before-after (,@defs ((lambda (x) x) (hilite f))) + (,@defs ((lambda (x) x) (hilite (lambda (x) x))))) + (before-after (,@defs (hilite ((lambda (x) x) (lambda (x) x)))) + (,@defs (hilite (lambda (x) x)))) + (finished-stepping)))) ; ; ;;;;;;;;;;;;; @@ -1242,11 +970,11 @@ ; ;;;;;;;;;;;;; ; - (t1 time - (test-intermediate-sequence "(time (+ 3 4))" - `((before-after ((hilite (+ 3 4))) - ((hilite 7))) - (finished-stepping)))) + (t1 'time + m:intermediate "(time (+ 3 4))" + `((before-after ((hilite (+ 3 4))) + ((hilite 7))) + (finished-stepping))) ;;;;;;;;;;;;;;;; @@ -1258,8 +986,8 @@ ;; NOT UPDATED FOR NEW TEST CASE FORMAT #; - (t1 ddj-screenshot - (test-mz-sequence (define-syntax (xml stx) + (t1 'ddj-screenshot + (m:mz (define-syntax (xml stx) (letrec ([process-xexpr (lambda (xexpr) (syntax-case xexpr (lmx lmx-splice) @@ -1318,30 +1046,30 @@ #; (define (test-xml-beginner-sequence spec expected) - (test-xml-sequence `(lib "htdp-beginner.ss" "lang") - fake-beginner-render-settings - #t - spec - expected)) + test-xml-sequence `(lib "htdp-beginner.ss" "lang") + fake-beginner-render-settings + #t + spec + expected) #; - (t1 xml-box1 - (test-xml-beginner-sequence `((xml-box "3")) - `((finished-stepping)))) + (t1 'xml-box1 + test-xml-beginner-sequence `((xml-box "3")) + `((finished-stepping))) #; - (t1 xml-box2 - (text-xml-beginnner-sequence `("(cdr (cdr " (xml-box "a b") "))") - `((before-after ((cdr (cdr (xml-box "a b")))))))) + (t1 'xml-box2 + text-xml-beginnner-sequence `("(cdr (cdr " (xml-box "a b") "))") + `((before-after ((cdr (cdr (xml-box "a b"))))))) - ;(t1 filled-rect-image - ; (test-upto-int-lam "(image-width (filled-rect 10 10 'blue))" + ;(t1 'filled-rect-image + ; (m:upto-int-lam "(image-width (filled-rect 10 10 'blue))" ; `((before-after ((image-width (hilite (filled-rect 10 10 'blue)))) ((image-width (hilite ))))))) ; add image test: (image-width (filled-rect 10 10 'blue)) - (t check-expect test-upto-int/lam + (t 'check-expect m:upto-int/lam (check-expect (+ 3 4) (+ 8 9)) (check-expect (+ 1 1) 2) (check-expect (+ 2 2) 4) (+ 4 5) :: {(+ 4 5)} -> {9} :: 9 (check-expect (+ 3 4) {(+ 8 9)}) -> 9 (check-expect (+ 3 4) {17}) @@ -1349,57 +1077,57 @@ :: 9 false (check-expect {(+ 1 1)} 2) -> 9 false (check-expect {2} 2) :: 9 false true (check-expect {(+ 2 2)} 4) -> 9 false true (check-expect {4} 4)) - (t1 check-within - (test-upto-int/lam - "(check-within (+ 3 4) (+ 8 10) (+ 10 90)) (check-expect (+ 1 1) 2)(+ 4 5)" - `((before-after ((hilite (+ 4 5))) - ((hilite 9))) - (before-after (9 (check-within (+ 3 4) (hilite (+ 8 10)) (+ 10 90))) - (9 (check-within (+ 3 4) (hilite 18) (+ 10 90)))) - (before-after (9 (check-within (+ 3 4) 18 (hilite (+ 10 90)))) - (9 (check-within (+ 3 4) 18 (hilite 100)))) - (before-after (9 (check-within (hilite (+ 3 4)) 18 100)) - (9 (check-within (hilite 7) 18 100))) - (before-after (9 true (check-expect (hilite (+ 1 1)) 2)) - (9 true (check-expect (hilite 2) 2)))))) + (t1 'check-within + m:upto-int/lam + "(check-within (+ 3 4) (+ 8 10) (+ 10 90)) (check-expect (+ 1 1) 2)(+ 4 5)" + `((before-after ((hilite (+ 4 5))) + ((hilite 9))) + (before-after (9 (check-within (+ 3 4) (hilite (+ 8 10)) (+ 10 90))) + (9 (check-within (+ 3 4) (hilite 18) (+ 10 90)))) + (before-after (9 (check-within (+ 3 4) 18 (hilite (+ 10 90)))) + (9 (check-within (+ 3 4) 18 (hilite 100)))) + (before-after (9 (check-within (hilite (+ 3 4)) 18 100)) + (9 (check-within (hilite 7) 18 100))) + (before-after (9 true (check-expect (hilite (+ 1 1)) 2)) + (9 true (check-expect (hilite 2) 2))))) - (t1 check-within-bad - (test-upto-int/lam - "(check-within (+ 3 4) (+ 8 10) 0.01) (+ 4 5) (check-expect (+ 1 1) 2)" - `((before-after ((hilite (+ 4 5))) - ((hilite 9))) - (before-after (9 (check-within (+ 3 4) (hilite (+ 8 10)) 0.01)) - (9 (check-within (+ 3 4) (hilite 18) 0.01))) - (before-after (9 (check-within (hilite (+ 3 4)) 18 0.01)) - (9 (check-within (hilite 7) 18 0.01))) - (before-after (9 false (check-expect (hilite (+ 1 1)) 2)) - (9 false (check-expect (hilite 2) 2)))))) + (t1 'check-within-bad + m:upto-int/lam + "(check-within (+ 3 4) (+ 8 10) 0.01) (+ 4 5) (check-expect (+ 1 1) 2)" + `((before-after ((hilite (+ 4 5))) + ((hilite 9))) + (before-after (9 (check-within (+ 3 4) (hilite (+ 8 10)) 0.01)) + (9 (check-within (+ 3 4) (hilite 18) 0.01))) + (before-after (9 (check-within (hilite (+ 3 4)) 18 0.01)) + (9 (check-within (hilite 7) 18 0.01))) + (before-after (9 false (check-expect (hilite (+ 1 1)) 2)) + (9 false (check-expect (hilite 2) 2))))) (let ([errmsg "rest: expected argument of type ; given ()"]) - (t1 check-error - (test-upto-int/lam - "(check-error (+ (+ 3 4) (rest empty)) (string-append \"rest: \" \"expected argument of type ; given ()\")) (check-expect (+ 3 1) 4) (+ 4 5)" - `((before-after ((hilite (+ 4 5))) - ((hilite 9))) - (before-after (9 (check-error (+ (+ 3 4) (rest empty)) (hilite (string-append "rest: " "expected argument of type ; given ()")))) - (9 (check-error (+ (+ 3 4) (rest empty)) (hilite ,errmsg)))) - (before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) ,errmsg)) - (9 (check-error (+ (hilite 7) (rest empty)) ,errmsg))) - (before-after (9 true (check-expect (hilite (+ 3 1)) 4)) - (9 true (check-expect (hilite 4) 4))))))) + (t1 'check-error + m:upto-int/lam + "(check-error (+ (+ 3 4) (rest empty)) (string-append \"rest: \" \"expected argument of type ; given ()\")) (check-expect (+ 3 1) 4) (+ 4 5)" + `((before-after ((hilite (+ 4 5))) + ((hilite 9))) + (before-after (9 (check-error (+ (+ 3 4) (rest empty)) (hilite (string-append "rest: " "expected argument of type ; given ()")))) + (9 (check-error (+ (+ 3 4) (rest empty)) (hilite ,errmsg)))) + (before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) ,errmsg)) + (9 (check-error (+ (hilite 7) (rest empty)) ,errmsg))) + (before-after (9 true (check-expect (hilite (+ 3 1)) 4)) + (9 true (check-expect (hilite 4) 4)))))) - (t1 check-error-bad - (test-upto-int/lam - "(check-error (+ (+ 3 4) (rest empty)) (string-append \"b\" \"ogus\")) (check-expect (+ 3 1) 4) (+ 4 5)" - `((before-after ((hilite (+ 4 5))) - ((hilite 9))) - (before-after (9 (check-error (+ (+ 3 4) (rest empty)) (hilite (string-append "b" "ogus")))) - (9 (check-error (+ (+ 3 4) (rest empty)) (hilite "bogus")))) - (before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) "bogus")) - (9 (check-error (+ (hilite 7) (rest empty)) "bogus"))) - (before-after (9 false (check-expect (hilite (+ 3 1)) 4)) - (9 false (check-expect (hilite 4) 4)))))) + (t1 'check-error-bad + m:upto-int/lam + "(check-error (+ (+ 3 4) (rest empty)) (string-append \"b\" \"ogus\")) (check-expect (+ 3 1) 4) (+ 4 5)" + `((before-after ((hilite (+ 4 5))) + ((hilite 9))) + (before-after (9 (check-error (+ (+ 3 4) (rest empty)) (hilite (string-append "b" "ogus")))) + (9 (check-error (+ (+ 3 4) (rest empty)) (hilite "bogus")))) + (before-after (9 (check-error (+ (hilite (+ 3 4)) (rest empty)) "bogus")) + (9 (check-error (+ (hilite 7) (rest empty)) "bogus"))) + (before-after (9 false (check-expect (hilite (+ 3 1)) 4)) + (9 false (check-expect (hilite 4) 4))))) ; ;;;;;;;;;;;;; ; ;; @@ -1412,15 +1140,8 @@ ;; (require mred) - (define test-teachpack-sequence (lambda (teachpack-specs expr-string expected-results) - ;(let ([new-custodian (make-custodian)]) - ; (parameterize ([current-custodian new-custodian]) - ; (parameterize ([current-eventspace (make-eventspace)]) - (test-sequence `(lib "htdp-beginner.ss" "lang") teachpack-specs fake-beginner-render-settings #f #f expr-string expected-results) - ;)) - ; (custodian-shutdown-all new-custodian)) - )) - + (define (make-teachpack-ll-model teachpack-specs) + (m:make-ll-model `(lib "htdp-beginner.ss" "lang") teachpack-specs fake-beginner-render-settings #f #f)) ; uses set-render-settings! ;(reconstruct:set-render-settings! fake-beginner-render-settings) @@ -1431,69 +1152,70 @@ ; tp-namespace) #; - (t1 teachpack-drawing - (test-teachpack-sequence - `((lib "draw.ss" "htdp")) - "(define (draw-limb i) (cond + (t1 'teachpack-drawing + (make-teachpack-ll-model + `((lib "draw.ss" "htdp"))) + "(define (draw-limb i) (cond [(= i 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] [(= i 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])) (and (start 100 100) (draw-limb 0))" - `((before-after-finished ((define (draw-limb i) (cond [(= i 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= i 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) - ((and (hilite (start 100 100)) (draw-limb 0))) - ((and (hilite true) (draw-limb 0)))) - (before-after ((and true (hilite (draw-limb 0)))) - ((and true (hilite (cond [(= 0 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))) - (before-after ((and true (cond [(hilite (= 0 1)) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) - ((and true (cond [(hilite false) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) - (before-after ((and true (hilite (cond [false (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] - [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) - ((and true (hilite (cond [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))) - (before-after ((and true (cond [(hilite (= 0 0)) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) - ((and true (cond [(hilite true) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) - (before-after ((and true (hilite (cond [true (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) - ((and true (hilite (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red))))) - (before-after ((and true (draw-solid-line (make-posn (hilite (+ 1 10)) 10) (make-posn 10 100) 'red))) - ((and true (draw-solid-line (make-posn (hilite 11) 10) (make-posn 10 100) 'red)))) - (before-after ((and true (hilite (draw-solid-line (make-posn 11 10) (make-posn 10 100) 'red)))) - ((and true (hilite true)))) - (before-after ((hilite (and true true))) - ((hilite true))) - (finished-stepping)))) + `((before-after-finished ((define (draw-limb i) (cond [(= i 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] + [(= i 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) + ((and (hilite (start 100 100)) (draw-limb 0))) + ((and (hilite true) (draw-limb 0)))) + (before-after ((and true (hilite (draw-limb 0)))) + ((and true (hilite (cond [(= 0 1) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] + [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))) + (before-after ((and true (cond [(hilite (= 0 1)) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] + [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) + ((and true (cond [(hilite false) (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] + [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) + (before-after ((and true (hilite (cond [false (draw-solid-line (make-posn 20 20) (make-posn 20 100) 'blue)] + [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) + ((and true (hilite (cond [(= 0 0) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))))) + (before-after ((and true (cond [(hilite (= 0 0)) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)]))) + ((and true (cond [(hilite true) (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) + (before-after ((and true (hilite (cond [true (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red)])))) + ((and true (hilite (draw-solid-line (make-posn (+ 1 10) 10) (make-posn 10 100) 'red))))) + (before-after ((and true (draw-solid-line (make-posn (hilite (+ 1 10)) 10) (make-posn 10 100) 'red))) + ((and true (draw-solid-line (make-posn (hilite 11) 10) (make-posn 10 100) 'red)))) + (before-after ((and true (hilite (draw-solid-line (make-posn 11 10) (make-posn 10 100) 'red)))) + ((and true (hilite true)))) + (before-after ((hilite (and true true))) + ((hilite true))) + (finished-stepping))) - #;(t1 teachpack-universe - (test-teachpack-sequence - `((lib "universe.ss" "2htdp")) - "(define (z world) + #;(t1 'teachpack-universe + (test-teachpack-sequence + `((lib "universe.ss" "2htdp"))) + "(define (z world) (empty-scene 100 100)) (big-bang 3 (on-tick add1) (on-draw z))" - `((finished-stepping)))) + `((finished-stepping))) + #; - (t1 teachpack-name-rendering - (test-teachpack-sequence - `((file "/Users/clements/plt/teachpack/htdp/draw.ss")) + (t1 'teachpack-name-rendering + (test-teachpack-sequence + `((file "/Users/clements/plt/teachpack/htdp/draw.ss"))) "(start 300 300) (if true (get-key-event) 3)" `((before-after ((hilite (start 300 300))) - ((hilite true))) + ((hilite true))) (before-after-finished (true) ((hilite (if true (get-key-event) 3))) ((hilite (get-key-event)))) (before-after ((hilite (get-key-event))) ((hilite false))) - (finished-stepping)))) + (finished-stepping))) #; - (t1 teachpack-hop-names - (test-teachpack-sequence - `((file "/Users/clements/plt/teachpack/htdp/draw.ss")) + (t1 'teachpack-hop-names + (make-teachpack-ll-model + `((file "/Users/clements/plt/teachpack/htdp/draw.ss"))) "(start 300 300) (define (a x y) (+ 3 4)) (if true (on-key-event a) 3)" `((before-after ((hilite (start 300 300))) ((hilite true))) @@ -1502,32 +1224,32 @@ ((hilite (on-key-event a)))) (before-after ((hilite (on-key-event a))) ((hilite true))) - (finished-stepping)))) + (finished-stepping))) #; - (t1 teachpack-web-interaction - (test-teachpack-sequence - `(htdp/servlet2) - "(define (adder go) (inform (number->string (+ (single-query (make-number \"enter 10\")) (single-query (make-number \"enter 20\")))))) (adder true)" - `((before-after-finished ((define (adder go) (inform (number->string (+ (single-query (make-number "enter 10")) (single-query (make-number "enter 20"))))))) - ((hilite (adder true))) - ((hilite (inform (number->string (+ (single-query (make-number "enter 10")) (single-query (make-number "enter 20")))))))) - (before-after ((inform (number->string (+ (single-query (hilite (make-number "enter 10"))) (single-query (make-number "enter 20")))))) ; this step looks wrong wrong wrong. - ((inform (number->string (+ (single-query (hilite (make-numeric "enter 10"))) (single-query (make-number "enter 20"))))))) - (before-after ((inform (number->string (+ (hilite (single-query (make-numeric "enter 10"))) (single-query (make-number "enter 20")))))) - ((inform (number->string (+ (hilite 10) (single-query (make-number "enter 20"))))))) - (before-after ((inform (number->string (+ 10 (single-query (hilite (make-number "enter 20"))))))) - ((inform (number->string (+ 10 (single-query (hilite (make-numeric "enter 20")))))))) - (before-after ((inform (number->string (+ 10 (hilite (single-query (make-numeric "enter 20"))))))) - ((inform (nut - mber->string (+ 10 (hilite 20)))))) - (before-after ((inform (number->string (hilite (+ 10 20))))) - ((inform (number->string (hilite 30))))) - (before-after ((inform (hilite (number->string 30)))) - ((inform (hilite "30")))) - (before-after ((hilite (inform "30"))) - ((hilite true))) - (finished-stepping)))) + (t1 'teachpack-web-interaction + (make-teachpack-ll-model + `(htdp/servlet2)) + "(define (adder go) (inform (number->string (+ (single-query (make-number \"enter 10\")) (single-query (make-number \"enter 20\")))))) (adder true)" + `((before-after-finished ((define (adder go) (inform (number->string (+ (single-query (make-number "enter 10")) (single-query (make-number "enter 20"))))))) + ((hilite (adder true))) + ((hilite (inform (number->string (+ (single-query (make-number "enter 10")) (single-query (make-number "enter 20")))))))) + (before-after ((inform (number->string (+ (single-query (hilite (make-number "enter 10"))) (single-query (make-number "enter 20")))))) ; this step looks wrong wrong wrong. + ((inform (number->string (+ (single-query (hilite (make-numeric "enter 10"))) (single-query (make-number "enter 20"))))))) + (before-after ((inform (number->string (+ (hilite (single-query (make-numeric "enter 10"))) (single-query (make-number "enter 20")))))) + ((inform (number->string (+ (hilite 10) (single-query (make-number "enter 20"))))))) + (before-after ((inform (number->string (+ 10 (single-query (hilite (make-number "enter 20"))))))) + ((inform (number->string (+ 10 (single-query (hilite (make-numeric "enter 20")))))))) + (before-after ((inform (number->string (+ 10 (hilite (single-query (make-numeric "enter 20"))))))) + ((inform (nut + mber->string (+ 10 (hilite 20)))))) + (before-after ((inform (number->string (hilite (+ 10 20))))) + ((inform (number->string (hilite 30))))) + (before-after ((inform (hilite (number->string 30)))) + ((inform (hilite "30")))) + (before-after ((hilite (inform "30"))) + ((hilite true))) + (finished-stepping))) ;;;;;;;;;;;;; @@ -1536,28 +1258,28 @@ ;; ;;;;;;;;;;;;; - (t1 top-ref-to-lifted - (test-advanced-sequence "(define a (local ((define i1 0) (define (i2 x) i1)) i2)) (+ 3 4)" - (let ([defs `((define i1_0 0) (define (i2_0 x) i1_0))]) - `((before-after ((define a (hilite (local ((define i1 0) (define (i2 x) i1)) i2)))) - ((hilite (define i1_0 0)) (hilite (define (i2_0 x) i1_0)) (define a (hilite i2_0)))) - (before-after (,@defs (define a (hilite i2_0))) - (,@defs (define a (hilite (lambda (x) i1_0))))) - (before-after (,@defs (define a (lambda (x) i1_0)) (hilite (+ 3 4))) - (,@defs (define a (lambda (x) i1_0)) (hilite 7))))))) + (t1 'top-ref-to-lifted + m:advanced "(define a (local ((define i1 0) (define (i2 x) i1)) i2)) (+ 3 4)" + (let ([defs `((define i1_0 0) (define (i2_0 x) i1_0))]) + `((before-after ((define a (hilite (local ((define i1 0) (define (i2 x) i1)) i2)))) + ((hilite (define i1_0 0)) (hilite (define (i2_0 x) i1_0)) (define a (hilite i2_0)))) + (before-after (,@defs (define a (hilite i2_0))) + (,@defs (define a (hilite (lambda (x) i1_0))))) + (before-after (,@defs (define a (lambda (x) i1_0)) (hilite (+ 3 4))) + (,@defs (define a (lambda (x) i1_0)) (hilite 7)))))) - (t1 set! - (test-advanced-sequence "(define a 3) (set! a (+ 4 5)) a" - `((before-after ((define a 3) (set! a (hilite (+ 4 5)))) - ((define a 3) (set! a (hilite 9)))) - (before-after ((hilite (define a 3)) (hilite (set! a 9))) - ((hilite (define a 9)) (hilite (void)))) - (before-after ((define a 9) (void) (hilite a)) - ((define a 9) (void) (hilite 9))) - (finished-stepping)))) + (t1 'set! + m:advanced "(define a 3) (set! a (+ 4 5)) a" + `((before-after ((define a 3) (set! a (hilite (+ 4 5)))) + ((define a 3) (set! a (hilite 9)))) + (before-after ((hilite (define a 3)) (hilite (set! a 9))) + ((hilite (define a 9)) (hilite (void)))) + (before-after ((define a 9) (void) (hilite a)) + ((define a 9) (void) (hilite 9))) + (finished-stepping))) - (t1 local-set! - (test-advanced-sequence + (t1 'local-set! + m:advanced "(define a (local ((define in 14) (define (getter dc) in) (define (modder n) (set! in n))) modder)) (a 15)" (let ([d1 `(define in_0 14)] [d2 `(define (getter_0 dc) in_0)] @@ -1573,7 +1295,7 @@ (,d1 ,d2 ,d3 ,d4 (hilite (set! in_0 15)))) (before-after ((hilite ,d1) ,d2 ,d3 , d4 (hilite (set! in_0 15))) ((hilite (define in_0 15)) ,d2 ,d3 ,d4 (void))) - (finished-stepping))))) + (finished-stepping)))) ;;;;;;;;;;; ;; @@ -1581,25 +1303,25 @@ ;; ;;;;;;;;;;; - (t1 simple-begin - (test-advanced-sequence "(+ 3 (begin 4 5))" - `((before-after ((+ 3 (hilite (begin 4 5)))) - ((+ 3 (hilite 5)))) - (before-after ((hilite (+ 3 5))) - ((hilite 8))) - (finished-stepping)))) + (t1 'simple-begin + m:advanced "(+ 3 (begin 4 5))" + `((before-after ((+ 3 (hilite (begin 4 5)))) + ((+ 3 (hilite 5)))) + (before-after ((hilite (+ 3 5))) + ((hilite 8))) + (finished-stepping))) - (t1 begin-onlyvalues - (test-advanced-sequence "(+ 3 (begin 4 5 6))" - `((before-after ((+ 3 (hilite (begin 4 5 6)))) - ((+ 3 (hilite (begin 5 6))))) - (before-after ((+ 3 (hilite (begin 5 6)))) - ((+ 3 (hilite 6)))) - (before-after ((hilite (+ 3 6))) - ((hilite 9)))))) + (t1 'begin-onlyvalues + m:advanced "(+ 3 (begin 4 5 6))" + `((before-after ((+ 3 (hilite (begin 4 5 6)))) + ((+ 3 (hilite (begin 5 6))))) + (before-after ((+ 3 (hilite (begin 5 6)))) + ((+ 3 (hilite 6)))) + (before-after ((hilite (+ 3 6))) + ((hilite 9))))) - (t1 begin - (test-advanced-sequence "(begin (+ 3 4) (+ 4 5) (+ 9 8))" + (t1 'begin + m:advanced "(begin (+ 3 4) (+ 4 5) (+ 9 8))" `((before-after ((begin (hilite (+ 3 4)) (+ 4 5) (+ 9 8))) ((begin (hilite 7) (+ 4 5) (+ 9 8)))) (before-after ((hilite (begin 7 (+ 4 5) (+ 9 8)))) @@ -1610,18 +1332,18 @@ ((hilite (+ 9 8)))) (before-after ((hilite (+ 9 8))) ((hilite 17))) - (finished-stepping)))) + (finished-stepping))) - (t begin-let-bug test-advanced-sequence + (t 'begin-let-bug m:advanced (let ([x 3]) (begin 3 4)) :: {(let ([x 3]) (begin 3 4))} -> {(define x_0 3)} {(begin 3 4)} :: (define x_0 3) {(begin 3 4)} -> (define x_0 3) 4) - (t1 empty-begin - (test-advanced-sequence "(begin)" - `((error "begin: expected a sequence of expressions after `begin', but nothing's there")))) + (t1 'empty-begin + m:advanced "(begin)" + `((error "begin: expected a sequence of expressions after `begin', but nothing's there"))) ;;;;;;;;;;;; ;; @@ -1629,32 +1351,32 @@ ;; ;;;;;;;;;;;; - (t1 empty-begin0 - (test-advanced-sequence "(begin0)" - `((error "begin0: expected a sequence of expressions after `begin0', but nothing's there")))) + (t1 'empty-begin0 + m:advanced "(begin0)" + `((error "begin0: expected a sequence of expressions after `begin0', but nothing's there"))) - (t1 trivial-begin0 - (test-advanced-sequence "(begin0 3)" + (t1 'trivial-begin0 + m:advanced "(begin0 3)" `((before-after ((hilite (begin0 3))) - ((hilite 3))) - (finished-stepping)))) + ((hilite 3))) + (finished-stepping))) - ;; urg... the first element of a begin0 is in tail position if there's only one. - (t1 one-item-begin0 - (test-advanced-sequence "(begin0 (+ 3 4))" - `((before-after ((hilite (begin0 (+ 3 4)))) - ((hilite (+ 3 4)))) - (before-after ((hilite (+ 3 4))) - ((hilite 7))) - (finished-stepping)))) + ;; urg.. the first element of a begin0 is in tail position if there's only one. + (t1 'one-item-begin0 + m:advanced "(begin0 (+ 3 4))" + `((before-after ((hilite (begin0 (+ 3 4)))) + ((hilite (+ 3 4)))) + (before-after ((hilite (+ 3 4))) + ((hilite 7))) + (finished-stepping))) - (t begin0-onlyvalues test-advanced-sequence + (t 'begin0-onlyvalues m:advanced (begin0 3 4 5) :: {(begin0 3 4 5)} -> {(begin0 3 5)} -> {3}) - (t begin0 test-advanced-sequence + (t 'begin0 m:advanced (begin0 (+ 3 4) (+ 4 5) (+ 6 7)) :: (begin0 {(+ 3 4)} (+ 4 5) (+ 6 7)) -> (begin0 {7} (+ 4 5) (+ 6 7)) @@ -1670,21 +1392,21 @@ ;; LAZY.SS: - (t lazy1 test-lazy-sequence + (t 'lazy1 m:lazy (! (+ 3 4)) :: 3 -> 3 :: 3 -> 3 :: 3 -> 3 :: {(! (+ 3 4))} -> {7}) - (t lazy2 test-lazy-sequence + (t 'lazy2 m:lazy (+ (+ 3 4) 5) :: (+ {(+ 3 4)} 5) -> (+ {7} 5) :: {(+ 7 5)} -> {12}) - (t lazy3 test-lazy-sequence + (t 'lazy3 m:lazy ((lambda (x y) (* x x)) (+ 1 2) (+ 3 4)) :: {((lambda (x y) (* x x)) (+ 1 2) (+ 3 4))} -> {(* (+ 1 2) (+ 1 2))} @@ -1694,7 +1416,7 @@ -> {9}) #; - (t1 teachpack-callbacks + (t1 'teachpack-callbacks (test-teachpack-sequence "(define (f2c x) x) (convert-gui f2c)" `() ; placeholder )) From 2af626972de3041951ef9efdbdbb216b6031cc72 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 22 Mar 2009 01:26:15 +0000 Subject: [PATCH 097/140] There is a problem with empty lines: having a line (= a row) in the code tables with empty contents makes the row not appear. Usually, we'd put an   there so it does show, but that would be bad for the preprocessor examples where I really want to have the table contents reflect the exact file contents. So another solution is to use a 'newline element, but then latex barfs because it's not happy with a \\ inside a tt macro. The hacked "solution" is to have the newline element not be inside a tt element -- latex doesn't barf now, but it does have one extra newline as a result since it doesn't hide the newline to begin with. A better solution is to find a way to make table cells in html not be hidden when they have no contents, maybe through some css magic. svn: r14206 --- collects/scribblings/scribble/utils.ss | 18 ++++++++++-------- 1 file changed, 10 insertions(+), 8 deletions(-) diff --git a/collects/scribblings/scribble/utils.ss b/collects/scribblings/scribble/utils.ss index b51fe4d09e..abf1581aeb 100644 --- a/collects/scribblings/scribble/utils.ss +++ b/collects/scribblings/scribble/utils.ss @@ -110,15 +110,17 @@ (define strs2 (split out-text)) (define strsm (map (compose split cdr) more)) (define (str->elts str) + (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)]) + (if spaces + (list* (substring str 0 (caar spaces)) + (hspace (- (cdar spaces) (caar spaces))) + (str->elts (substring str (cdar spaces)))) + (list (make-element 'tt (list str)))))) + (define (make-line str) (if (equal? str "") - (list (make-element 'newline (list ""))) - (let ([spaces (regexp-match-positions #rx"(?:^| ) +" str)]) - (if spaces - (list* (substring str 0 (caar spaces)) - (hspace (- (cdar spaces) (caar spaces))) - (str->elts (substring str (cdar spaces)))) - (list (make-element 'tt (list str))))))) - (define (make-line str) (list (as-flow (make-element 'tt (str->elts str))))) + ;;FIXME: this works in html, but in latex it creates a redundant newline + (list (as-flow (make-element 'newline '()))) + (list (as-flow (make-element 'tt (str->elts str)))))) (define (small-attr attr) (make-with-attributes attr '([style . "font-size: 82%;"]))) (define (make-box strs) From 1048d204ca6cc87395fc6ead393e7ffe5808799f Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 22 Mar 2009 01:30:13 +0000 Subject: [PATCH 098/140] more time, for slower machines svn: r14207 --- collects/tests/scribble/main.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/tests/scribble/main.ss b/collects/tests/scribble/main.ss index 15ba5bbd7e..4fd6febb3e 100644 --- a/collects/tests/scribble/main.ss +++ b/collects/tests/scribble/main.ss @@ -134,7 +134,7 @@ (call-with-output-file (car m) #:exists 'truncate (lambda (o) (display (cdr m) o)))) (set! thd (thread run)) - (t (with-limits 1 #f + (t (with-limits 2 #f (if len-to-read (read-string len-to-read i) (port->string i))) => expected) (t (begin (kill-thread thd) (cond [exn => raise] [else #t]))))) From 2e66794799812b421278b76065de6ae03a6f2157 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 22 Mar 2009 02:50:25 +0000 Subject: [PATCH 099/140] removed unused binding svn: r14209 --- collects/redex/private/matcher.ss | 2 -- 1 file changed, 2 deletions(-) diff --git a/collects/redex/private/matcher.ss b/collects/redex/private/matcher.ss index 8ac741baf8..0b4edac046 100644 --- a/collects/redex/private/matcher.ss +++ b/collects/redex/private/matcher.ss @@ -18,8 +18,6 @@ before the pattern compiler is invoked. (define-struct compiled-pattern (cp)) -(define count 0) - (define caching-enabled? (make-parameter #t)) ;; lang = (listof nt) From 18fd48af9789c8017063f680e6bc4e45ec223e00 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 22 Mar 2009 02:53:27 +0000 Subject: [PATCH 100/140] Added `count'. svn: r14210 --- collects/scheme/list.ss | 24 ++++++++++++++++- collects/scribblings/reference/pairs.scrbl | 7 +++++ collects/tests/mzscheme/list.ss | 31 ++++++++++++++-------- 3 files changed, 50 insertions(+), 12 deletions(-) diff --git a/collects/scheme/list.ss b/collects/scheme/list.ss index ec13a28140..cedd06621c 100644 --- a/collects/scheme/list.ss +++ b/collects/scheme/list.ss @@ -20,11 +20,12 @@ add-between remove-duplicates filter-map + count partition argmin argmax - + ;; convenience append-map filter-not) @@ -237,6 +238,27 @@ (let ([x (f (car l))]) (if x (cons x (loop (cdr l))) (loop (cdr l)))))))) +;; very similar to `filter-map', one more such function will justify some macro +(define (count f l . ls) + (unless (and (procedure? f) (procedure-arity-includes? f (add1 (length ls)))) + (raise-type-error + 'count (format "procedure (arity ~a)" (add1 (length ls))) f)) + (unless (and (list? l) (andmap list? ls)) + (raise-type-error + 'count "proper list" + (ormap (lambda (x) (and (not (list? x)) x)) (cons l ls)))) + (if (pair? ls) + (let ([len (length l)]) + (if (andmap (lambda (l) (= len (length l))) ls) + (let loop ([l l] [ls ls] [c 0]) + (if (null? l) + c + (loop (cdr l) (map cdr ls) + (if (apply f (car l) (map car ls)) (add1 c) c)))) + (error 'count "all lists must have same size"))) + (let loop ([l l] [c 0]) + (if (null? l) c (loop (cdr l) (if (f (car l)) (add1 c) c)))))) + ;; Originally from srfi-1 -- shares common tail with the input when possible ;; (define (partition f l) ;; (unless (and (procedure? f) (procedure-arity-includes? f 1)) diff --git a/collects/scribblings/reference/pairs.scrbl b/collects/scribblings/reference/pairs.scrbl index bda29a70ea..81e09663ae 100644 --- a/collects/scribblings/reference/pairs.scrbl +++ b/collects/scribblings/reference/pairs.scrbl @@ -633,6 +633,13 @@ Returns @scheme[(filter (lambda (x) x) (map proc lst ...))], but without building the intermediate list.} +@defproc[(count [proc procedure?] [lst list?] ...+) + list?]{ + +Returns @scheme[(length (filter proc lst ...))], but +without building the intermediate list.} + + @defproc[(partition [pred procedure?] [lst list?]) (values list? list?)]{ diff --git a/collects/tests/mzscheme/list.ss b/collects/tests/mzscheme/list.ss index ad9152bc63..ca1d8877db 100644 --- a/collects/tests/mzscheme/list.ss +++ b/collects/tests/mzscheme/list.ss @@ -263,6 +263,15 @@ (test '(1 2 3) fm values '(#f 1 #f 2 #f 3 #f)) (test '(4 8 12) fm (lambda (x) (and (even? x) (* x 2))) '(1 2 3 4 5 6))) +;; ---------- count ---------- + +(let () + (test 0 count even? '()) + (test 4 count even? '(0 2 4 6)) + (test 0 count even? '(1 3 5 7)) + (test 2 count even? '(1 2 3 4)) + (test 2 count < '(1 2 3 4) '(4 3 2 1))) + ;; ---------- append-map ---------- (let () (define am append-map) @@ -273,53 +282,53 @@ ;; ---------- argmin & argmax ---------- (let () - + (define ((check-regs . regexps) exn) (and (exn:fail? exn) (andmap (λ (reg) (regexp-match reg (exn-message exn))) regexps))) - + (test 'argmin object-name argmin) (test 1 argmin (lambda (x) 0) (list 1)) (test 1 argmin (lambda (x) x) (list 1 2 3)) (test 1 argmin (lambda (x) 1) (list 1 2 3)) - + (test 3 'argmin-makes-right-number-of-calls (let ([c 0]) (argmin (lambda (x) (set! c (+ c 1)) 0) (list 1 2 3)) c)) - + (test '(1 banana) argmin car '((3 pears) (1 banana) (2 apples))) - + (err/rt-test (argmin 1 (list 1)) (check-regs #rx"argmin" #rx"procedure")) (err/rt-test (argmin (lambda (x) x) 3) (check-regs #rx"argmin" #rx"list")) (err/rt-test (argmin (lambda (x) x) (list 1 #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers")) (err/rt-test (argmin (lambda (x) x) (list #f)) (check-regs #rx"argmin" #rx"procedure that returns real numbers")) - + (err/rt-test (argmin (lambda (x) x) (list +i)) (check-regs #rx"argmin" #rx"procedure that returns real numbers")) (err/rt-test (argmin (lambda (x) x) (list)) (check-regs #rx"argmin" #rx"non-empty list")) - + (test 'argmax object-name argmax) (test 1 argmax (lambda (x) 0) (list 1)) (test 3 argmax (lambda (x) x) (list 1 2 3)) (test 1 argmax (lambda (x) 1) (list 1 2 3)) - + (test 3 'argmax-makes-right-number-of-calls (let ([c 0]) (argmax (lambda (x) (set! c (+ c 1)) 0) (list 1 2 3)) c)) - + (test '(3 pears) argmax car '((3 pears) (1 banana) (2 apples))) - + (err/rt-test (argmax 1 (list 1)) (check-regs #rx"argmax" #rx"procedure")) (err/rt-test (argmax (lambda (x) x) 3) (check-regs #rx"argmax" #rx"list")) (err/rt-test (argmax (lambda (x) x) (list 1 #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers")) (err/rt-test (argmax (lambda (x) x) (list #f)) (check-regs #rx"argmax" #rx"procedure that returns real numbers")) - + (err/rt-test (argmax (lambda (x) x) (list +i)) (check-regs #rx"argmax" #rx"procedure that returns real numbers")) (err/rt-test (argmax (lambda (x) x) (list)) (check-regs #rx"argmax" #rx"non-empty list"))) From b12698d31ae4b8810ee2d778eb970689fffd38e4 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 22 Mar 2009 02:59:59 +0000 Subject: [PATCH 101/140] reprovide the scheme/list binding for count, and for append* (as concatenate) svn: r14211 --- collects/srfi/1/misc.ss | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/collects/srfi/1/misc.ss b/collects/srfi/1/misc.ss index 6e59b41ac3..066cacaa1e 100644 --- a/collects/srfi/1/misc.ss +++ b/collects/srfi/1/misc.ss @@ -39,16 +39,18 @@ "selector.ss" "util.ss" (only-in "fold.ss" reduce-right) - (rename-in "fold.ss" [map s:map] [for-each s:for-each])) + (rename-in "fold.ss" [map s:map] [for-each s:for-each]) + (only-in scheme/list count append*)) (provide length+ - concatenate (rename-out [concatenate concatenate!]) + (rename-out [append* concatenate] [append* concatenate!]) (rename-out [append append!]) (rename-out [reverse reverse!]) append-reverse (rename-out [append-reverse append-reverse!]) zip unzip1 unzip2 unzip3 unzip4 unzip5 count) +#; ; reprovided from scheme/list ;; count ;;;;;;;; (define (count pred list1 . lists) @@ -169,6 +171,7 @@ (set-cdr! rev-head tail) (lp next-rev rev-head))))) +#; ; reprovide scheme/list's `append*' function (define (concatenate lists) (reduce-right append '() lists)) #; ; lists are immutable (define (concatenate! lists) (reduce-right my-append! '() lists)) From 4ba449b30de7b96981c01def2ca6bfbd97f42a19 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sun, 22 Mar 2009 07:50:17 +0000 Subject: [PATCH 102/140] Welcome to a new PLT day. svn: r14213 --- 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 fb26e2e962..2f152650d5 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "20mar2009") +#lang scheme/base (provide stamp) (define stamp "22mar2009") From 6d8014783b16c2d31624f8bd5f6d25d9fb10b5e2 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Sun, 22 Mar 2009 12:41:26 +0000 Subject: [PATCH 103/140] =?UTF-8?q?Use=20'no-free-identifier=3D=3F=20prope?= =?UTF-8?q?rty=20with=20rename=20transformers.=20Allow=20use=20of=20...=20?= =?UTF-8?q?without=20bound=20when=20only=20one=20...=20var=20in=20scope.?= svn: r14214 --- .../tests/typed-scheme/succeed/no-bound-fl.ss | 11 ++++++ .../unit-tests/parse-type-tests.ss | 6 +++ .../typed-scheme/env/type-environments.ss | 14 +++++++ collects/typed-scheme/private/parse-type.ss | 37 +++++++++++++++++++ .../typecheck/provide-handling.ss | 12 ++++-- 5 files changed, 76 insertions(+), 4 deletions(-) create mode 100644 collects/tests/typed-scheme/succeed/no-bound-fl.ss diff --git a/collects/tests/typed-scheme/succeed/no-bound-fl.ss b/collects/tests/typed-scheme/succeed/no-bound-fl.ss new file mode 100644 index 0000000000..1f9bd5265a --- /dev/null +++ b/collects/tests/typed-scheme/succeed/no-bound-fl.ss @@ -0,0 +1,11 @@ +#lang typed-scheme + +(: fold-left (All (a b ...) ((a b ... -> a) a (Listof b) ... -> a))) +(define (fold-left f a . bss) + (if (ormap null? bss) + a + (apply fold-left + f + (apply f a (map car bss)) + (map cdr bss)))) + diff --git a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss index cfe775ea65..c14f64d80a 100644 --- a/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss +++ b/collects/tests/typed-scheme/unit-tests/parse-type-tests.ss @@ -80,6 +80,10 @@ [(All (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] [(∀ (a) (Listof a)) (-poly (a) (make-Listof a))] [(∀ (a ...) (a ... a -> Integer)) (-polydots (a) ( (list) (a a) . ->... . -Integer))] + [(All (a ...) (a ... -> Number)) + (-polydots (a) ((list) [a a] . ->... . N))] + [(All (a ...) (values a ...)) + (-polydots (a) (make-ValuesDots (list) a 'a))] [(case-lambda (Number -> Boolean) (Number Number -> Number)) (cl-> [(N) B] [(N N) N])] [1 (-val 1)] @@ -91,6 +95,8 @@ [a (-v a) (extend-env (list 'a) (list (-v a)) initial-tvar-env)] + [(All (a ...) (a ... -> Number)) + (-polydots (a) ((list) [a a] . ->... . N))] )) diff --git a/collects/typed-scheme/env/type-environments.ss b/collects/typed-scheme/env/type-environments.ss index 0f159ec0bd..42eb02c9db 100644 --- a/collects/typed-scheme/env/type-environments.ss +++ b/collects/typed-scheme/env/type-environments.ss @@ -8,6 +8,9 @@ extend/values dotted-env initial-tvar-env + env-filter + env-vals + env-keys+vals with-dotted-env/extend) (require (prefix-in r: "../utils/utils.ss")) @@ -17,6 +20,17 @@ ;; eq? has the type of equal?, and l is an alist (with conses!) (define-struct env (eq? l)) +(define (env-vals e) + (map cdr (env-l e))) + +(define (env-keys+vals e) + (env-l e)) + +(define (env-filter f e) + (match e + [(struct env (eq? l)) + (make-env eq? (filter f l))])) + ;; the initial type variable environment - empty ;; this is used in the parsing of types (define initial-tvar-env (make-env eq? '())) diff --git a/collects/typed-scheme/private/parse-type.ss b/collects/typed-scheme/private/parse-type.ss index 135384af86..8cc2d1cef4 100644 --- a/collects/typed-scheme/private/parse-type.ss +++ b/collects/typed-scheme/private/parse-type.ss @@ -350,6 +350,26 @@ (current-tvars))]) (parse-type #'rest)) (syntax-e #'bound)))))))] + [(dom ... rest ::: -> rng) + (and (eq? (syntax-e #'->) '->) + (eq? (syntax-e #':::) '...)) + (begin + (add-type-name-reference #'->) + (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))]) + (when (null? bounds) + (tc-error/stx stx "No type variable bound with ... in scope for ... type")) + (unless (null? (cdr bounds)) + (tc-error/stx stx "Cannot infer bound for ... type")) + (match-let ([(cons var (struct Dotted (t))) (car bounds)]) + (make-Function + (list + (make-arr-dots (map parse-type (syntax->list #'(dom ...))) + (parse-type #'rng) + (parameterize ([current-tvars (extend-env (list var) + (list (make-DottedBoth t)) + (current-tvars))]) + (parse-type #'rest)) + var))))))] ;; has to be below the previous one [(dom ... -> rng) (eq? (syntax-e #'->) '->) @@ -369,6 +389,23 @@ (current-tvars))]) (parse-type #'dty)) (syntax-e #'bound))))] + [(values tys ... dty dd) + (and (eq? (syntax-e #'values) 'values) + (eq? (syntax-e #'dd) '...)) + (begin + (add-type-name-reference #'values) + (let ([bounds (filter (compose Dotted? cdr) (env-keys+vals (current-tvars)))]) + (when (null? bounds) + (tc-error/stx stx "No type variable bound with ... in scope for ... type")) + (unless (null? (cdr bounds)) + (tc-error/stx stx "Cannot infer bound for ... type")) + (match-let ([(cons var (struct Dotted (t))) (car bounds)]) + (make-ValuesDots (map parse-type (syntax->list #'(tys ...))) + (parameterize ([current-tvars (extend-env (list var) + (list (make-DottedBoth t)) + (current-tvars))]) + (parse-type #'dty)) + var))))] [(values tys ...) (eq? (syntax-e #'values) 'values) (-values (map parse-type (syntax->list #'(tys ...))))] diff --git a/collects/typed-scheme/typecheck/provide-handling.ss b/collects/typed-scheme/typecheck/provide-handling.ss index 791d6384d7..66b3576a13 100644 --- a/collects/typed-scheme/typecheck/provide-handling.ss +++ b/collects/typed-scheme/typecheck/provide-handling.ss @@ -54,15 +54,18 @@ (define/contract cnt-id #,cnt id) (define-syntax export-id (if (unbox typed-context?) - (make-rename-transformer #'id) - (make-rename-transformer #'cnt-id))) + (make-rename-transformer (syntax-property #'id + 'not-free-identifier=? #t)) + (make-rename-transformer (syntax-property #'cnt-id + 'not-free-identifier=? #t)))) (#%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 (syntax-property #'id + 'not-free-identifier=? #t)) (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) @@ -76,7 +79,8 @@ (if (unbox typed-context?) (begin (add-alias #'export-id #'id) - (make-rename-transformer #'id)) + (make-rename-transformer (syntax-property #'id + 'not-free-identifier=? #t))) (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]))))))] From 26f50142b2e9899a613137942203a042cad28108 Mon Sep 17 00:00:00 2001 From: Mike Sperber Date: Sun, 22 Mar 2009 14:30:39 +0000 Subject: [PATCH 104/140] Add test suites for DeinProgramm stuff. svn: r14215 --- collects/tests/deinprogramm/contract.ss | 264 +++++ collects/tests/deinprogramm/image.ss | 1037 +++++++++++++++++ .../tests/deinprogramm/run-contract-tests.ss | 6 + collects/tests/deinprogramm/run-image-test.ss | 6 + 4 files changed, 1313 insertions(+) create mode 100644 collects/tests/deinprogramm/contract.ss create mode 100644 collects/tests/deinprogramm/image.ss create mode 100644 collects/tests/deinprogramm/run-contract-tests.ss create mode 100644 collects/tests/deinprogramm/run-image-test.ss diff --git a/collects/tests/deinprogramm/contract.ss b/collects/tests/deinprogramm/contract.ss new file mode 100644 index 0000000000..f450d55a38 --- /dev/null +++ b/collects/tests/deinprogramm/contract.ss @@ -0,0 +1,264 @@ +#lang scheme/base + +(provide all-contract-tests) + +(require (planet schematics/schemeunit:3) + deinprogramm/contract/contract + deinprogramm/contract/contract-syntax) + +(require scheme/promise) + +(define integer (make-predicate-contract 'integer integer? 'integer-marker)) +(define boolean (make-predicate-contract 'boolean boolean? 'boolean-marker)) +(define %a (make-type-variable-contract 'a 'a-marker)) +(define %b (make-type-variable-contract 'b 'b-marker)) + +(define-syntax say-no + (syntax-rules () + ((say-no ?body ...) + (let/ec exit + (call-with-contract-violation-proc + (lambda (obj contract message blame) + (exit 'no)) + (lambda () + ?body ...)))))) + +(define-syntax failed-contract + (syntax-rules () + ((say-no ?body ...) + (let/ec exit + (call-with-contract-violation-proc + (lambda (obj contract message blame) + (exit contract)) + (lambda () + ?body ...)))))) + +(define contract-tests + (test-suite + "Tests for contract combinators" + + (test-case + "flat" + (check-equal? (say-no (apply-contract integer 5)) 5) + (check-equal? (say-no (apply-contract integer "foo")) 'no)) + + (test-case + "list" + (define integer-list (make-list-contract 'integer-list integer #f)) + (check-equal? (say-no (apply-contract integer-list '(1 2 3))) + '(1 2 3)) + (check-equal? (say-no (apply-contract integer-list '#f)) + 'no) + (check-eq? (failed-contract (apply-contract integer-list '(1 #f 3))) + integer)) + + (test-case + "list-cached" + (define integer-list (make-list-contract 'integer-list integer #f)) + (define boolean-list (make-list-contract 'integer-list boolean #f)) + (define l '(1 2 3)) + (define foo "foo") + (define no '(1 #f 3)) + (define no2 '(1 #f 3)) + (define integer-list->bool (make-procedure-contract 'integer-list->bool (list integer-list) boolean 'int->bool-marker)) + + (check-equal? (say-no (apply-contract integer-list l)) + '(1 2 3)) + (check-equal? (say-no (apply-contract integer-list l)) + '(1 2 3)) + (check-equal? (say-no (apply-contract boolean-list l)) + 'no) + (check-equal? (say-no (apply-contract integer-list foo)) + 'no) + (check-equal? (say-no (apply-contract integer-list foo)) + 'no) + (check-eq? (failed-contract (apply-contract integer-list no)) + integer) + (check-eq? (failed-contract (apply-contract integer-list no)) + integer) + + (let ((proc (say-no (apply-contract integer-list->bool (lambda (l) (even? (car l))))))) + (check-equal? (say-no (proc no)) 'no) + (check-equal? (say-no (proc no)) 'no) + (check-equal? (say-no (proc no2)) 'no) + (check-equal? (say-no (proc no2)) 'no)) + ) + + (test-case + "mixed" + (define int-or-bool (make-mixed-contract 'int-or-bool + (list integer + boolean) + 'int-or-bool-marker)) + (check-equal? (say-no (apply-contract int-or-bool #f)) + #f) + (check-equal? (say-no (apply-contract int-or-bool 17)) + 17) + (check-equal? (say-no (apply-contract int-or-bool "foo")) + 'no)) + + (test-case + "combined" + (define octet (make-combined-contract + 'octet + (list + integer + (make-predicate-contract '<256 + (delay (lambda (x) + (< x 256))) + '<256-marker) + (make-predicate-contract 'non-negative + (delay (lambda (x) + (>= x 0))) + 'non-negative-marker)) + 'octet-marker)) + (check-equal? (say-no (apply-contract octet #f)) + 'no) + (check-equal? (say-no (apply-contract octet 17)) + 17) + (check-equal? (say-no (apply-contract octet 0)) + 0) + (check-equal? (say-no (apply-contract octet -1)) + 'no) + (check-equal? (say-no (apply-contract octet 255)) + 255) + (check-equal? (say-no (apply-contract octet 256)) + 'no) + (check-equal? (say-no (apply-contract octet "foo")) + 'no)) + + (test-case + "case" + (define foo-or-bar (make-case-contract 'foo-or-bar '("foo" "bar") 'foo-or-bar-marker)) + (check-equal? (say-no (apply-contract foo-or-bar #f)) + 'no) + (check-equal? (say-no (apply-contract foo-or-bar "foo")) + "foo") + (check-equal? (say-no (apply-contract foo-or-bar "bar")) + "bar")) + + (test-case + "procedure" + (define int->bool (make-procedure-contract 'int->bool (list integer) boolean 'int->bool-marker)) + (check-equal? (say-no (apply-contract int->bool #f)) + 'no) + (check-equal? (say-no (apply-contract int->bool (lambda () "foo"))) + 'no) + (check-equal? (say-no (apply-contract int->bool (lambda (x y) "foo"))) + 'no) + (let ((proc (say-no (apply-contract int->bool (lambda (x) (odd? x)))))) + (check-pred procedure? proc) + (check-equal? (proc 15) #t) + (check-equal? (proc 16) #f) + (check-equal? (say-no (proc 12 15)) 'no) + (check-equal? (say-no (proc "foo")) 'no)) + (let ((proc (say-no (apply-contract int->bool (lambda (x) (+ x 1)))))) + (check-equal? (say-no (proc 12)) 'no))) + + (test-case + "type variable - simple" + (check-equal? (say-no (apply-contract %a #f)) #f) + (check-equal? (say-no (apply-contract %a 15)) 15)) + + (test-case + "type variable - list" + (define a-list (make-list-contract 'a-list %a #f)) + (check-equal? (say-no (apply-contract a-list '(1 2 3))) + '(1 2 3)) + (check-equal? (say-no (apply-contract a-list '#f)) + 'no) + (check-equal? (say-no (apply-contract a-list '(#f "foo" 5))) + '(#f "foo" 5))) + + (test-case + "apply-contract/blame" + (define int->bool (make-procedure-contract 'int->bool (list integer) boolean 'int->bool-marker)) + (let ((proc (say-no (apply-contract/blame int->bool (lambda (x) (odd? x)))))) + (check-pred procedure? proc) + (check-equal? (proc 15) #t) + (check-equal? (proc 16) #f) + (check-equal? (say-no (proc 12 15)) 'no) + (check-equal? (say-no (proc "foo")) 'no)) + (let ((proc (say-no (apply-contract/blame int->bool (lambda (x) x))))) + (call-with-contract-violation-proc + (lambda (obj contract message blame) + (check-true (syntax? blame))) + (lambda () + (proc 5))))) + )) + +(define contract-syntax-tests + (test-suite + "Tests for contract syntax" + + (test-case + "predicate" + (define-contract integer (predicate integer?)) + (check-equal? (say-no (apply-contract integer 5)) 5) + (check-equal? (say-no (apply-contract integer "foo")) 'no)) + + (test-case + "list" + (check-equal? (say-no (apply-contract (contract x (list %a)) 5)) 'no) + (check-equal? (say-no (apply-contract (contract x (list %a)) '(1 2 3))) '(1 2 3)) + (check-equal? (say-no (apply-contract (contract x (list (predicate integer?))) '(1 2 3))) '(1 2 3)) + (check-equal? (say-no (apply-contract (contract x (list (predicate integer?))) '(1 #f 3))) 'no)) + + (test-case + "mixed" + (define int-or-bool (contract (mixed integer boolean))) + (check-equal? (say-no (apply-contract int-or-bool #f)) + #f) + (check-equal? (say-no (apply-contract int-or-bool 17)) + 17) + (check-equal? (say-no (apply-contract int-or-bool "foo")) + 'no)) + + (test-case + "combined" + (define octet (contract (combined integer + (predicate (lambda (x) + (< x 256))) + (predicate (lambda (x) + (>= x 0)))))) + (check-equal? (say-no (apply-contract octet #f)) + 'no) + (check-equal? (say-no (apply-contract octet 17)) + 17) + (check-equal? (say-no (apply-contract octet 0)) + 0) + (check-equal? (say-no (apply-contract octet -1)) + 'no) + (check-equal? (say-no (apply-contract octet 255)) + 255) + (check-equal? (say-no (apply-contract octet 256)) + 'no) + (check-equal? (say-no (apply-contract octet "foo")) + 'no)) + + (test-case + "procedure" + (define int->bool (contract int->bool ((predicate integer?) -> (predicate boolean?)))) + (check-equal? (say-no (apply-contract int->bool #f)) + 'no) + (check-equal? (say-no (apply-contract int->bool (lambda () "foo"))) + 'no) + (check-equal? (say-no (apply-contract int->bool (lambda (x y) "foo"))) + 'no) + (let ((proc (say-no (apply-contract int->bool (lambda (x) (odd? x)))))) + (check-pred procedure? proc) + (check-equal? (proc 15) #t) + (check-equal? (proc 16) #f) + (check-equal? (say-no (proc 12 15)) 'no) + (check-equal? (say-no (proc "foo")) 'no)) + (let ((proc (say-no (apply-contract int->bool (lambda (x) (+ x 1)))))) + (check-equal? (say-no (proc 12)) 'no))) + +)) + + +(define all-contract-tests + (test-suite + "all-contract-tests" + contract-tests + contract-syntax-tests)) diff --git a/collects/tests/deinprogramm/image.ss b/collects/tests/deinprogramm/image.ss new file mode 100644 index 0000000000..41d41ab64e --- /dev/null +++ b/collects/tests/deinprogramm/image.ss @@ -0,0 +1,1037 @@ +#lang scheme/base + +(provide all-image-tests) + +(require (planet schematics/schemeunit:3) + deinprogramm/image + (only-in lang/private/imageeq image=?) + mred + mzlib/class + mrlib/cache-image-snip + lang/posn + htdp/error) + + +(define-values (image-snip1 image-snip2) + (let () + (define size 2) + + (define (do-draw c-bm m-bm) + (let ([bdc (make-object bitmap-dc% c-bm)]) + (send bdc clear) + (send bdc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send bdc set-brush (send the-brush-list find-or-create-brush "red" 'solid)) + (send bdc draw-rectangle 0 0 size size) + (send bdc set-bitmap m-bm) + (send bdc clear) + (send bdc set-pen (send the-pen-list find-or-create-pen "black" 1 'transparent)) + (send bdc set-brush (send the-brush-list find-or-create-brush "black" 'solid)) + (send bdc draw-rectangle 0 0 (/ size 2) size) + (send bdc set-bitmap #f))) + + (define image-snip1 + (let* ([c-bm (make-object bitmap% size size)] + [m-bm (make-object bitmap% size size #t)]) + (do-draw c-bm m-bm) + (make-object image-snip% c-bm m-bm))) + + (define image-snip2 + (let* ([c-bm (make-object bitmap% size size)] + [m-bm (make-object bitmap% size size)]) + (do-draw c-bm m-bm) + (send c-bm set-loaded-mask m-bm) + (make-object image-snip% c-bm))) + + (values image-snip1 image-snip2))) + +(define image-snip3 (make-object image-snip%)) + +;; check-on-bitmap : symbol snip -> void +;; checks on various aspects of the bitmap snips to make +;; sure that they draw properly +(define (check-on-bitmap snp) + (let-values ([(width height) (send snp get-size)]) + (let ([bdc (make-object bitmap-dc%)] + [max-difference + (lambda (s1 s2) + (cond + [(and (zero? (bytes-length s1)) + (zero? (bytes-length s2))) + 0] + [else + (apply max + (map (lambda (x y) (abs (- x y))) + (bytes->list s1) + (bytes->list s1)))]))]) + + ;; test that no drawing is outside the snip's drawing claimed drawing area + (let* ([extra-space 100] + [bm-width (+ width extra-space)] + [bm-height (+ height extra-space)] + [bm-clip (make-object bitmap% bm-width bm-height)] + [bm-noclip (make-object bitmap% bm-width bm-height)] + [s-clip (make-bytes (* bm-width bm-height 4))] + [s-noclip (make-bytes (* bm-width bm-height 4))] + [s-trunc (make-bytes (* bm-width bm-height 4))]) + (send bdc set-bitmap bm-clip) + (send bdc clear) + (send bdc set-clipping-rect (/ extra-space 2) (/ extra-space 2) width height) + (send snp draw bdc (/ extra-space 2) (/ extra-space 2) 0 0 (+ width extra-space) (+ height extra-space) 0 0 #f) + (send bdc set-clipping-region #f) + (send bdc get-argb-pixels 0 0 (+ width extra-space) (+ height extra-space) s-clip) + + (send bdc set-bitmap bm-noclip) + (send bdc clear) + (send snp draw bdc (/ extra-space 2) (/ extra-space 2) 0 0 (+ width extra-space) (+ height extra-space) 0 0 #f) + (send bdc get-argb-pixels 0 0 (+ width extra-space) (+ height extra-space) s-noclip) + (send bdc set-bitmap #f) + + (check-equal? s-clip s-noclip) + + (send bdc set-bitmap bm-noclip) + (send bdc set-pen "black" 1 'transparent) + (send bdc set-brush "white" 'solid) + (send bdc draw-rectangle 0 0 (/ extra-space 2) bm-height) + (send bdc draw-rectangle (- bm-width (/ extra-space 2)) 0 (/ extra-space 2) bm-height) + (send bdc draw-rectangle 0 0 bm-width (/ extra-space 2)) + (send bdc draw-rectangle 0 (- bm-height (/ extra-space 2)) bm-width (/ extra-space 2)) + (send bdc get-argb-pixels 0 0 (+ width extra-space) (+ height extra-space) s-trunc) + + (check-equal? s-noclip s-trunc)) + + (let ([bm-normal (make-object bitmap% (max 1 width) (max 1 height))] + [bm-bitmap (make-object bitmap% (max 1 width) (max 1 height))] + [s-normal (make-bytes (* width height 4))] + [s-bitmap (make-bytes (* width height 4))]) + + (send bdc set-bitmap bm-normal) + (send bdc clear) + (send snp draw bdc 0 0 0 0 width height 0 0 #f) + (send bdc get-argb-pixels 0 0 width height s-normal) + (send bdc set-bitmap bm-bitmap) + (send bdc clear) + + ;; force the snip to switch over to bitmap mode + (send snp get-argb) + + (send snp draw bdc 0 0 0 0 width height 0 0 #f) + (send bdc get-argb-pixels 0 0 width height s-bitmap) + (send bdc set-bitmap #f) + (check-true (<= (max-difference s-normal s-bitmap) 2)))))) + +(define red (make-color 255 0 0)) +(define blue (make-color 0 0 255)) +(define black (make-color 0 0 0)) +(define white (make-color 255 255 255)) + +(define awhite (make-alpha-color 0 255 255 255)) +(define ablack (make-alpha-color 0 0 0 0)) +(define ared (make-alpha-color 0 255 0 0)) +(define aclr (make-alpha-color 255 0 0 0)) + +(define-simple-check (check-image=? i1 i2) + (image=? i1 i2)) + +(define-simple-check (check-not-image=? i1 i2) + (not (image=? i1 i2))) + +(define-simple-check (check-terminates val1) + #t) + +(define (add-line i x1 y1 x2 y2 color) + (overlay i + (line (image-width i) + (image-height i) + x1 y1 x2 y2 color) + "left" "top")) + +(define (not-image-inside? i1 i2) + (not (image-inside? i1 i2))) + +;; tests that the expression +;; a) raises a teachpack exception record, +;; b) has the right argument position, and +;; c) has the right name. +(define (tp-exn-pred name position) + (lambda (exn) + (and (tp-exn? exn) + (let* ([msg (exn-message exn)] + [beg (format "~a:" name)] + [len (string-length beg)]) + (and (regexp-match position msg) + ((string-length msg) . > . len) + (string=? (substring msg 0 len) beg)))))) + +(define-syntax err/rt-name-test + (syntax-rules () + [(_ (name . args) position) + (check-exn (tp-exn-pred 'name position) + (lambda () + (name . args)))])) + +(define all-image-tests + (test-suite + "Tests for images" + + (test-case + "image?" + (check-pred image? (rectangle 10 10 'solid 'blue)) + (check-pred image? (rectangle 10 10 "solid" 'blue)) + (check-pred image? (rectangle 10 10 'outline 'blue)) + (check-pred image? (rectangle 10 10 "outline" 'blue)) + (check-false (image? 5))) + + (test-case + "color-list" + (check-equal? (list red) + (image->color-list (rectangle 1 1 'solid 'red))) + (check-equal? (list blue blue blue blue) + (image->color-list (rectangle 2 2 'solid 'blue)))) + + (test-case + "colors-set-up-properly" + (check-equal? (list (list red) (list blue) (list black) (list white)) + (list (image->color-list (rectangle 1 1 'solid 'red)) + (image->color-list (rectangle 1 1 'solid 'blue)) + (image->color-list (rectangle 1 1 'solid 'black)) + (image->color-list (rectangle 1 1 'solid 'white))))) + + (test-case + "color-list2" + (check-equal? (list blue blue blue + blue blue blue + blue blue blue) + (image->color-list (rectangle 3 3 'solid 'blue))) + (check-equal? (list blue blue blue + blue blue blue + blue blue blue) + (image->color-list (rectangle 3 3 "solid" 'blue))) + (check-equal? (list blue blue blue + blue white blue + blue blue blue) + (image->color-list (rectangle 3 3 'outline 'blue)))) + + (test-case + "color-list3" + (check-equal? (list blue blue blue + blue white blue + blue blue blue) + (image->color-list (rectangle 3 3 "outline" 'blue)))) + + (test-case + "color-list4" + (check-image=? (color-list->image (list blue blue blue blue) 2 2) + (rectangle 2 2 'solid 'blue))) + (test-case + "color-list5" + (check-not-image=? (color-list->image (list blue blue blue blue) 2 2) + (rectangle 1 4 'solid 'blue))) + + (test-case + "color-list6" + (check-image=? (color-list->image (list blue blue blue blue) 1 4) + (rectangle 1 4 'solid 'blue))) + (test-case + "color-list7" + (check-image=? (color-list->image (list 'blue 'blue 'blue 'blue) 2 2) + (rectangle 2 2 'solid 'blue))) + + (test-case + "color-list8" + (check-equal? 10 + (image-width (color-list->image '() 10 0)))) + + (test-case + "color-list9" + (check-equal? 0 + (image-height (color-list->image '() 10 0)))) + + (test-case + "color-list10" + (check-equal? 0 + (image-width (color-list->image '() 0 10)))) + + (test-case + "color-list11" + (check-equal? 10 + (image-height (color-list->image '() 0 10)))) + + (test-case + "alpha-color-list1" + (check-equal? (make-alpha-color 0 255 0 0) + (car (image->alpha-color-list (rectangle 1 1 'solid 'red))))) + + (test-case + "alpha-color-list2" + (check-equal? (make-alpha-color 0 255 0 0) + (car (image->alpha-color-list (rectangle 1 1 "solid" 'red))))) + + (test-case + "alpha-color-list3" + (for-each + (lambda (x) + (check-equal? x (make-alpha-color 0 255 0 0))) + (image->alpha-color-list (rectangle 1 1 "solid" 'red)))) + + (test-case + "alpha-color-list4" + (for-each + (lambda (x) + (check-equal? x (make-alpha-color 0 255 0 0))) + (image->alpha-color-list (rectangle 1 1 'solid 'red)))) + + (test-case + "alpha-color-list5" + (check-equal? (make-alpha-color 0 0 255 0) + (car (image->alpha-color-list (rectangle 1 1 'solid 'green))))) + + (test-case + "alpha-color-list6" + (check-equal? (make-alpha-color 0 0 0 255) + (car (image->alpha-color-list (rectangle 1 1 'solid 'blue))))) + + (test-case + "alpha-color-list7" + (check-equal? (image-width + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr) + 3 + 2)) + 3)) + (test-case + "alpha-color-list8" + (check-equal? (image-height + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr) + 3 + 2)) + 2)) + + (test-case + "alpha-color-list9" + (check-equal? (image->color-list + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr) + 3 2)) + (list red white red + white white white))) + (test-case + "alpha-color-list10" + (check-equal? (image->color-list + (overlay + (rectangle 3 3 'solid 'blue) + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr + ared aclr ared) + 3 3) + "left" "top")) + (list red blue red + blue blue blue + red blue red))) + + (test-case + "alpha-color-list11" + (check-equal? 10 (image-width (alpha-color-list->image '() 10 0)))) + + (test-case + "alpha-color-list12" + (check-equal? 0 (image-height (alpha-color-list->image '() 10 0)))) + + (test-case + "alpha-color-list13" + (check-equal? 0 (image-width (alpha-color-list->image '() 0 10)))) + + (test-case + "alpha-color-list14" + (check-equal? 10 (image-height (alpha-color-list->image '() 0 10)))) + + (test-case + "image=?1" + (check-image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1) + (alpha-color-list->image (list (make-alpha-color 200 100 150 175)) 1 1))) + + (test-case + "image=?2" + (check-image=? (alpha-color-list->image (list (make-alpha-color 255 100 100 100)) 1 1) + (alpha-color-list->image (list (make-alpha-color 255 200 200 200)) 1 1))) + + (test-case + "image=?3" + (check-not-image=? (alpha-color-list->image (list (make-alpha-color 200 100 100 100)) 1 1) + (alpha-color-list->image (list (make-alpha-color 200 200 200 200)) 1 1))) + + (test-case + "image=?4" + (check-not-image=? (alpha-color-list->image (list (make-alpha-color 200 100 150 175) + (make-alpha-color 200 100 150 175)) + 1 + 2) + (alpha-color-list->image (list (make-alpha-color 200 100 150 175) + (make-alpha-color 200 100 150 175)) + 2 + 1))) + + (test-case + "image=?5" + (write (image=? (rectangle 4 4 'outline 'black) + (overlay + (rectangle 4 4 'outline 'black) + (circle 1 'solid 'red) + 1 1))) + + (check-not-image=? (rectangle 4 4 'outline 'black) + (overlay + (rectangle 4 4 'outline 'black) + (circle 1 'solid 'red) + 0 0))) + + (test-case + "overlay" + (check-image=? (color-list->image (list blue red blue red) 2 2) + (overlay (rectangle 2 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + "left" "top"))) + + (test-case + "overlay/multiple" + (check-image=? (overlay (rectangle 6 6 'solid 'red) + (overlay (rectangle 4 4 'solid 'white) + (rectangle 2 2 'solid 'blue) + "center" "center") + "center" "center") + (overlay (overlay (rectangle 6 6 'solid 'red) + (rectangle 4 4 'solid 'white) + "center" "center") + (rectangle 2 2 'solid 'blue) + "center" "center"))) + + (test-case + "overlay/empty-spaces-are-unmasked" + (check-image=? (color-list->image (list red red red blue) 2 2) + (overlay + (rectangle 2 2 'solid 'blue) + (overlay (rectangle 1 2 'solid 'red) + (rectangle 2 1 'solid 'red) + "left" "top") + "left" "top"))) + + (test-case + "overlay/xy1" + (check-image=? (color-list->image (list red blue red blue) 2 2) + (overlay (rectangle 2 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0))) + + (test-case + "overlay/xy2" + (check-image=? (color-list->image (list red red red blue) 2 2) + (overlay (rectangle 2 2 'solid 'red) + (rectangle 1 1 'solid 'blue) + 1 1))) + + (test-case + "overlay/xy3" + (check-image=? (color-list->image (list red red blue blue) 2 2) + (overlay (rectangle 2 1 'solid 'red) + (rectangle 2 1 'solid 'blue) + 0 1))) + + (test-case + "overlay/xy/white" + (check-image=? (alpha-color-list->image (list ablack ablack ablack + ablack awhite ablack + ablack ablack ablack) + 3 3) + (overlay (rectangle 3 3 'solid 'black) + (rectangle 1 1 'solid 'white) + 1 1))) + + (test-case + "color-list->image/white-in-mask" + (check-image=? (color-list->image (list black red black + red red red + black red black) + 3 3) + (overlay (rectangle 3 3 'solid 'red) + (color-list->image (list black white black + white white white + black white black) + 3 3) + "left" "top"))) + + + (test-case + "overlay" + (check-image=? (color-list->image (list red blue red red blue red) 3 2) + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0))) + + (test-case + "image=?-zero1" + (check-image=? (rectangle 0 10 'solid 'red) + (rectangle 0 10 'solid 'red))) + (test-case + "image=?-zero2" + (check-image=? (rectangle 0 10 'solid 'red) + (rectangle 0 10 'solid 'blue))) + (test-case + "image=?-zero3" + (check-not-image=? (rectangle 0 5 'solid 'red) + (rectangle 0 4'solid 'blue))) + + (test-case + "image-inside?1" + (check image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 1 2 'solid 'blue))) + + (test-case + "image-inside?2" + (check not-image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 1 2 'solid 'black))) + + (test-case + "image-inside?3" + (check image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 1 2 'solid 'red))) + + (test-case + "image-inside?4" + (check not-image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (rectangle 2 1 'solid 'red))) + + (test-case + "image-inside?5" + (check image-inside? + (alpha-color-list->image (list (make-alpha-color 0 255 0 0)) 1 1) + (alpha-color-list->image (list (make-alpha-color 255 0 0 0)) 1 1))) + + (test-case + "image-inside?6" + (check not-image-inside? + (overlay (rectangle 3 2 'solid 'red) + (rectangle 1 2 'solid 'blue) + 1 0) + (color-list->image (list blue white white) + 3 1))) + + (test-case + "image-inside?7" + (check image-inside? + (overlay (rectangle 16 16 'solid 'red) + (ellipse 6 6 'outline 'blue) + 2 5) + (ellipse 6 6 'outline 'blue))) + + (test-case + "image-inside?8" + (check image-inside? + (overlay (rectangle (image-width (text "x" 12 'red)) + (image-height (text "x" 12 'red)) + 'solid + 'white) + (text "x" 12 'red) + "center" "center") + (text "x" 12 'red))) + + (test-case + "image-inside?9" + (check image-inside? + (text "y x y" 12 'red) + (text "x" 12 'red))) + + (test-case + "find-image1" + (check-equal? (make-posn 2 5) + (find-image (overlay (rectangle 16 16 'solid 'red) + (ellipse 6 6 'outline 'blue) + 2 5) + (ellipse 6 6 'outline 'blue)))) + + (test-case + "find-image2" + (check-equal? (make-posn 0 0) + (find-image (rectangle 16 16 'solid 'blue) + (ellipse 6 6 'outline 'blue)))) + + (test-case + "find-image3" + (check-equal? (make-posn 1 1) + (find-image (overlay (rectangle 10 10 'solid 'blue) + (ellipse 5 5 'solid 'red) + 1 1) + (ellipse 5 5 'solid 'red)))) + + (test-case + "image-width" + (check-equal? 5 (image-width (rectangle 5 7 'solid 'red)))) + + (test-case + "image-height" + (check-equal? 7 (image-height (rectangle 5 7 'solid 'red)))) + + (test-case + "color-red" + (check-equal? 1 (color-red (make-color 1 2 3)))) + + (test-case + "color-green" + (check-equal? 2 (color-green (make-color 1 2 3)))) + + (test-case + "color-blue" + (check-equal? 3 (color-blue (make-color 1 2 3)))) + + (test-case + "color?1" + (check-true (color? (make-color 1 2 3)))) + + (test-case + "color?2" + (check-false (color? 10))) + + (test-case + "image-color?1" + (check-pred image-color? (make-color 1 2 3))) + + (test-case + "image-color?2" + (check-pred image-color? "blue")) + + (test-case + "image-color?3" + (check-pred image-color? 'blue)) + + (test-case + "image-color?4" + (check-false (image-color? 10))) + + (test-case + "image-color?5" + (check-false (image-color? "not-a-color"))) + + (test-case + "image-color?6" + (check-false (image-color? 'not-a-color))) + + (test-case + "line" + (check image=? + (line 5 1 0 0 4 0 'red) + (color-list->image (list red red red red red) 5 1)) + (check image=? + (line 1 5 0 0 0 4 'red) + (color-list->image (list red red red red red) 1 5)) + + (check image=? + (line 1 5 0 4 0 0 'red) + (color-list->image (list red red red red red) 1 5)) + + (check image=? + (line 5 1 4 0 0 0 'red) + (color-list->image (list red red red red red) 5 1))) + + +; note: next two tests may be platform-specific... I'm not sure. + ;; I developed them under macos x. -robby + (test-case + "triangle1" + (check image=? + (triangle 3 'outline 'red) + (color-list->image + (list white red white + white red white + red white red + red red red) + 3 + 4))) + + (test-case + "triangle2" + (check image=? + (triangle 3 'solid 'red) + (color-list->image + (list white red white + white red white + red red red + red red red) + 3 + 4))) + + (test-case + "clipping-twice-clips-both-times" + (check image=? + (overlay + (rectangle 11 11 'solid 'green) + (clip (rectangle 11 11 'solid 'red) + 5 5 1 1) + "center" "center") + (overlay + (rectangle 11 11 'solid 'green) + (clip (clip (rectangle 11 11 'solid 'red) + 3 3 2 2) + 2 2 1 1) + "center" "center"))) + + (test-case + "solid-rect" + (check-on-bitmap (rectangle 2 2 'solid 'red))) + + (test-case + "outline-rect" + (check-on-bitmap (rectangle 2 2 'outline 'red))) + (test-case + "solid-ellipse" + (check-on-bitmap (ellipse 2 4 'solid 'red))) + (test-case + "outline-ellipse" + (check-on-bitmap (ellipse 2 4 'outline 'red))) + (test-case + "solid-circle" + (check-on-bitmap (circle 4 'solid 'red))) + (test-case + "outline-circle" + (check-on-bitmap (circle 4 'outline 'red))) + + (test-case + "0solid-rect1" + (check-on-bitmap (rectangle 0 2 'solid 'red))) + (test-case + "0solid-rect2" + (check-on-bitmap (rectangle 2 0 'solid 'red))) + (test-case + "0outline-rect1" + (check-on-bitmap (rectangle 2 0 'outline 'red))) + (test-case + "0outline-rect2" + (check-on-bitmap (rectangle 0 0 'outline 'red))) + (test-case + "0solid-ellipse1" + (check-on-bitmap (ellipse 0 3 'solid 'red))) + (test-case + "0solid-ellipse2" + (check-on-bitmap (ellipse 3 0 'solid 'red))) + (test-case + "0outline-ellipse1" + (check-on-bitmap (ellipse 0 4 'outline 'red))) + (test-case + "0outline-ellipse2" + (check-on-bitmap (ellipse 2 0 'outline 'red))) + (test-case + "0solid-circle" + (check-on-bitmap (circle 0 'solid 'red))) + (test-case + "0outline-circle" + (check-on-bitmap (circle 0 'outline 'red))) + + (test-case + "solid-triangle" + (check-on-bitmap (triangle 10 'solid 'red))) + (test-case + "outline-triangle" + (check-on-bitmap (triangle 10 'outline 'red))) + (test-case + "line" + (check-on-bitmap (line 10 7 0 0 9 6 'red))) + + + + ;; (check-on-bitmap 'text (text "XX" 12 'red)) ;; this test fails for reasons I can't control ... -robby + (test-case + "overlay1" + (check-on-bitmap (overlay (rectangle 1 4 'solid 'blue) + (rectangle 4 1 'solid 'green) + "left" "top"))) + (test-case + "overlay2" + (check-on-bitmap (overlay (rectangle 4 4 'solid 'blue) + (rectangle 4 4 'solid 'green) + 2 2))) + (test-case + "overlay3" + (check-on-bitmap (overlay image-snip1 + (rectangle (image-width image-snip1) + (image-height image-snip1) + 'outline + 'red) + "center" "center"))) + (test-case + "alpha-color-list" + (check-on-bitmap + (overlay + (rectangle 3 3 'solid 'blue) + (alpha-color-list->image + (list ared aclr ared + aclr aclr aclr + ared aclr ared) + 3 + 3) + "center" "center"))) + (test-case + "add-line" + (check-on-bitmap + (overlay + (rectangle 100 100 'solid 'black) + (line 100 100 -10 -10 110 110 'red) + 0 0))) + + (test-case + "add-line1" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + -20 -20 + 0 0 + 'red))) + (test-case + "add-line2" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + -20 20 + 0 0 + 'red))) + (test-case + "add-line3" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 20 -20 + 0 0 + 'red))) + + (test-case + "add-line4" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 20 20 + 0 0 + 'red))) + + (test-case + "add-line5" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 0 0 + -20 -20 + 'red))) + + (test-case + "add-line6" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 0 0 + -20 20 + 'red))) + + (test-case + "add-line7" + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 0 0 + 20 -20 + 'red)) + + (test-case + "add-line8" + (check-on-bitmap + (add-line (overlay (rectangle 11 11 'solid 'black) (rectangle 3 3 'solid 'green) "center" "center") + 0 0 + 20 20 + 'red))) + + (test-case + "shrink" + (check-on-bitmap + (clip (rectangle 11 11 'solid 'red) + 5 5 1 1))) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test images with zero width or zero height + ;; for various things + ;; + + (test-case + "zero-width/height" + (check-equal? 10 (image-width (rectangle 10 0 'solid 'red))) + (check-equal? 0 (image-height (rectangle 10 0 'solid 'red))) + (check-equal? 0 (image-width (rectangle 0 10 'solid 'red))) + (check-equal? 10 (image-height (rectangle 0 10 'solid 'red))) + + (check-equal? 0 (image-width (text "" 12 'black))) + (check > (image-height (text "" 12 'black)) 0) + + (check-equal? '() (image->color-list (rectangle 0 10 'solid 'red))) + (check-equal? '() (image->color-list (rectangle 10 0 'solid 'red))) + (check-equal? '() (image->color-list (rectangle 0 0 'solid 'red))) + + (check-equal? '() (image->alpha-color-list (rectangle 0 10 'solid 'red))) + (check-equal? '() (image->alpha-color-list (rectangle 10 0 'solid 'red))) + (check-equal? '() (image->alpha-color-list (rectangle 0 0 'solid 'red)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test that the image construction functions + ;; accept non-integer values (and floor them) + ;; + + (test-case + "accept-non-integer" + (check-equal? (image->color-list (rectangle 2 2 'solid 'blue)) + (image->color-list (rectangle #e2.5 2.5 'solid 'blue))) + (check-equal? (image->color-list (ellipse 2 2 'solid 'blue)) + (image->color-list (ellipse #e2.5 2.5 'solid 'blue))) + (check-equal? (image->color-list (circle 2 'solid 'blue)) + (image->color-list (circle #e2.5 'solid 'blue))) + (check-equal? (image->color-list (triangle 12 'solid 'blue)) + (image->color-list (triangle 12.5 'solid 'blue))) + (check-equal? (image->color-list (line 10 12 0 0 9 11 'blue)) + (image->color-list (line 10 12 0 0 9.5 #e11.5 'blue))) + (check-equal? (image->color-list (clip (rectangle 10 10 'solid 'blue) 3 3 4 4)) + (image->color-list + (clip (rectangle 10 10 'solid 'blue) + 3.1 + 3.2 + #e4.3 + 4.4))) + (check-equal? (image->color-list (add-line (rectangle 10 10 'solid 'blue) + 0 0 2 2 'red)) + (image->color-list (add-line (rectangle 10 10 'solid 'blue) + 0.1 #e.2 2.1 2.2 'red)))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; The tests beginning with "bs-" ensure + ;; that the operations all can accept bitmap + ;; snips as arguments + ;; + + (test-case + "accept-bitmap" + (check-pred image? image-snip1) + (check-pred image? image-snip2) + (check image=? image-snip1 (send image-snip1 copy)) + (check-not-image=? + ;; They have different masks: + image-snip1 image-snip2) + (check-equal? 2 (image-width image-snip1)) + (check-equal? 2 (image-width image-snip2)) + (check-equal? 2 (image-height image-snip1)) + (check-equal? 2 (image-height image-snip2)) + (check image=? image-snip1 (overlay image-snip1 image-snip2 "center" "center")) + (check image=? image-snip1 (overlay image-snip1 image-snip2 "left" "top")) + (check image=? + (add-line image-snip1 0 0 10 10 'green) + (add-line image-snip2 0 0 10 10 'green)) + (check image-inside? image-snip1 image-snip2) + (check image-inside? image-snip2 image-snip1) + (check-equal? (make-posn 0 0) + (find-image image-snip1 image-snip2)) + (check-equal? (make-posn 0 0) + (find-image image-snip2 image-snip1)) + (check-equal? (image->color-list image-snip1) + (image->color-list image-snip2)) + (check-equal? (image->alpha-color-list image-snip1) + (image->alpha-color-list image-snip2))) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test image-snip that doesnt' have a bitmap + ;; + + (test-case + "image-snip-no-bitmap" + (check-equal? 20 + (image-width image-snip3)) + (overlay image-snip3 image-snip3 10 10)) + + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; + ;; test color arguments + ;; + (test-case + "color-arguments" + (check-terminates (rectangle 10 10 'solid 'blue)) + (check-terminates (rectangle 10 10 'solid "blue")) + (check-terminates (rectangle 10 10 'solid (make-color 0 0 255))) + (check-terminates (ellipse 10 10 'solid 'blue)) + (check-terminates (ellipse 10 10 'solid "blue")) + (check-terminates (ellipse 10 10 'solid (make-color 0 0 255))) + (check-terminates (circle 10 'solid 'blue)) + (check-terminates (circle 10 'solid "blue")) + (check-terminates (circle 10 'solid (make-color 0 0 255))) + (check-terminates (triangle 10 'solid 'blue)) + (check-terminates (triangle 10 'solid "blue")) + (check-terminates (triangle 10 'solid (make-color 0 0 255))) + (check-terminates (line 10 10 0 0 9 9 'blue)) + (check-terminates (line 10 10 0 0 9 9 "blue")) + (check-terminates (line 10 10 0 0 9 9 (make-color 0 0 255))) + (check-terminates (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 'blue)) + (check-terminates (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 "blue")) + (check-terminates (add-line (rectangle 1 1 'solid 'blue) 0 0 1 1 (make-color 0 0 255))) + (check-terminates (text "abc" 12 'blue)) + (check-terminates (text "abc" 12 "blue")) + (check-terminates (text "abc" 12 (make-color 0 0 255)))) + + (test-case + "error-message" + (err/rt-name-test (image-width 1) "first") + (err/rt-name-test (image-height 1) "first") + (err/rt-name-test (overlay 1 2 "center" "center") "first") + (err/rt-name-test (overlay image-snip1 2 "center" "center") "second") + (err/rt-name-test (overlay 1 2 "center" "center") "first") + (err/rt-name-test (overlay image-snip1 image-snip2 "foo" "center") "third") + (err/rt-name-test (overlay image-snip1 image-snip2 "center" "foo") "fourth") + (err/rt-name-test (rectangle #f #f #f #f) "first") + (err/rt-name-test (rectangle 10 #f #f #f) "second") + (err/rt-name-test (rectangle 10 10 #f #f) "third") + (err/rt-name-test (rectangle 10 10 'solid #f) "fourth") + (err/rt-name-test (circle #f #f #f) "first") + (err/rt-name-test (circle 10 #f #f) "second") + (err/rt-name-test (circle 10 'solid #f) "third") + (err/rt-name-test (ellipse #f #f #f #f) "first") + (err/rt-name-test (ellipse 10 #f #f #f) "second") + (err/rt-name-test (ellipse 10 10 #f #f) "third") + (err/rt-name-test (ellipse 10 10 'solid #f) "fourth") + (err/rt-name-test (triangle #f #f #f) "first") + (err/rt-name-test (triangle 10 #f #f) "second") + (err/rt-name-test (triangle 10 'solid #f) "third") + (err/rt-name-test (line #f #f 0 0 0 0 #f) "first") + (err/rt-name-test (line 10 #f 0 0 0 0 #f) "second") + (err/rt-name-test (line 10 10 #f 0 0 0 #f) "third") + (err/rt-name-test (line 10 10 0 #f 0 0 #f) "fourth") + (err/rt-name-test (line 10 10 0 0 #f 0 #f) "fifth") + (err/rt-name-test (line 10 10 0 0 0 #f #f) "sixth") + (err/rt-name-test (line 10 10 0 0 0 0 #f) "seventh") + (err/rt-name-test (text #f #f #f) "first") + (err/rt-name-test (text "abc" #f #f) "second") + (err/rt-name-test (text "abc" 10 #f) "third") + (err/rt-name-test (image-inside? #f #f) "first") + (err/rt-name-test (image-inside? image-snip1 #f) "second") + (err/rt-name-test (find-image #f #f) "first") + (err/rt-name-test (find-image image-snip1 #f) "second") + (err/rt-name-test (image->color-list 1) "first") + (err/rt-name-test (color-list->image #f #f #f) "first") + (err/rt-name-test (color-list->image (list (make-color 0 0 0)) #f #f) "second") + (err/rt-name-test (color-list->image (list (make-color 0 0 0)) 1 #f) "third") + (err/rt-name-test (image->alpha-color-list #f) "first") + (err/rt-name-test (alpha-color-list->image #f #f #f) "first") + (err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) #f #f) "second") + (err/rt-name-test (alpha-color-list->image (list (make-alpha-color 0 0 0 0)) 1 #f) "third")) +)) diff --git a/collects/tests/deinprogramm/run-contract-tests.ss b/collects/tests/deinprogramm/run-contract-tests.ss new file mode 100644 index 0000000000..c375180247 --- /dev/null +++ b/collects/tests/deinprogramm/run-contract-tests.ss @@ -0,0 +1,6 @@ +#lang scheme/base + +(require (planet schematics/schemeunit:3/text-ui)) +(require tests/deinprogramm/contract) + +(run-tests all-contract-tests) \ No newline at end of file diff --git a/collects/tests/deinprogramm/run-image-test.ss b/collects/tests/deinprogramm/run-image-test.ss new file mode 100644 index 0000000000..06215561da --- /dev/null +++ b/collects/tests/deinprogramm/run-image-test.ss @@ -0,0 +1,6 @@ +#lang scheme/base + +(require (planet schematics/schemeunit:3/text-ui)) +(require tests/deinprogramm/image) + +(run-tests all-image-tests) \ No newline at end of file From 8243dfaefb1de9376dfdef093f7db6c9b3698adc Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Mar 2009 16:21:26 +0000 Subject: [PATCH 105/140] fix potential SFS problem in runstack-overflow handling svn: r14216 --- src/mzscheme/src/eval.c | 16 ++++++++++++++++ 1 file changed, 16 insertions(+) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index dc9441b193..434288e9d2 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -7095,6 +7095,18 @@ static void make_tail_buffer_safe() p->tail_buffer = tb; } +static Scheme_Object **evacuate_runstack(int num_rands, Scheme_Object **rands, Scheme_Object **runstack) +{ + if (rands == runstack) { + /* See [TC-SFS] in "schnapp.inc" */ + Scheme_Thread *p = scheme_current_thread; + (void)scheme_tail_apply(scheme_void, num_rands, rands); + rands = p->ku.apply.tail_rands; + p->ku.apply.tail_rands = NULL; + return rands; + } +} + static Scheme_Dynamic_Wind *intersect_dw(Scheme_Dynamic_Wind *a, Scheme_Dynamic_Wind *b, Scheme_Object *prompt_tag, int b_has_tag, int *_common_depth) { @@ -7615,6 +7627,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, if ((RUNSTACK - RUNSTACK_START) < SCHEME_TAIL_COPY_THRESHOLD) { /* It's possible that a sequence of primitive _scheme_tail_apply() calls will exhaust the Scheme stack. Watch out for that. */ + rands = evacuate_runstack(num_rands, rands, RUNSTACK); + p->ku.k.p1 = (void *)obj; p->ku.k.i1 = num_rands; p->ku.k.p2 = (void *)rands; @@ -7687,6 +7701,8 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands, data = SCHEME_COMPILED_CLOS_CODE(obj); if ((RUNSTACK - RUNSTACK_START) < data->max_let_depth) { + rands = evacuate_runstack(num_rands, rands, RUNSTACK); + if (rands == p->tail_buffer) { UPDATE_THREAD_RSPTR_FOR_GC(); make_tail_buffer_safe(); From bf499a4e05e2f6662d91b27727038c89dfd74ab8 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Mar 2009 16:22:05 +0000 Subject: [PATCH 106/140] avoid a jump in fast-path arity checking svn: r14217 --- src/mzscheme/src/jit.c | 58 ++++++++++++++++++++++++++---------------- 1 file changed, 36 insertions(+), 22 deletions(-) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index 224749bcd4..bc6ae41b13 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -7527,7 +7527,7 @@ static int generate_alloc_retry(mz_jit_state *jitter, int i) typedef struct { Scheme_Closure_Data *data; - void *code, *tail_code, *code_end, **patch_depth; + void *arity_code, *code, *tail_code, *code_end, **patch_depth; int max_extra, max_depth; Scheme_Native_Closure *nc; } Generate_Closure_Data; @@ -7536,8 +7536,8 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) { Generate_Closure_Data *gdata = (Generate_Closure_Data *)_data; Scheme_Closure_Data *data = gdata->data; - void *code, *tail_code, *code_end; - int i, r, cnt, has_rest; + void *code, *tail_code, *code_end, *arity_code; + int i, r, cnt, has_rest, is_method, num_params; code = jit_get_ip().ptr; @@ -7553,7 +7553,35 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST), data->num_params); CHECK_LIMIT(); + + /* A tail call with arity checking can start here. + (This is a little reundant checking when `code' is the + etry point, but that's the slow path anyway.) */ + has_rest = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? 1 : 0); + is_method = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_IS_METHOD) ? 1 : 0); + num_params = data->num_params; + if (num_params && has_rest) + --num_params; + + if (num_params < MAX_SHARED_ARITY_CHECK) { + void *shared_arity_code; + + shared_arity_code = shared_arity_check[num_params][has_rest][is_method]; + if (!shared_arity_code) { + shared_arity_code = generate_lambda_simple_arity_check(num_params, has_rest, is_method, 1); + shared_arity_check[num_params][has_rest][is_method] = shared_arity_code; + } + + arity_code = jit_get_ip().ptr; + + if (!has_rest) + (void)jit_bnei_i(shared_arity_code, JIT_R1, num_params); + else + (void)jit_blti_i(shared_arity_code, JIT_R1, num_params); + } else + arity_code = generate_lambda_simple_arity_check(num_params, has_rest, is_method, 0); + /* A tail call starts here. Caller must ensure that the stack is big enough, right number of arguments, closure is in R0. If the closure has a rest arg, also ensure @@ -7563,8 +7591,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) /* 0 params and has_rest => (lambda args E) where args is not in E, so accept any number of arguments and ignore them. */ - if ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) - && data->num_params) { + if (has_rest && data->num_params) { /* If runstack == argv and argc == cnt, then we didn't copy args down, and we need to make room for scheme_null. */ jit_insn *ref, *ref2, *ref3; @@ -7622,7 +7649,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) /* Keeping the native-closure pointer on the runstack ensures that the code won't be GCed while we're running it. */ - mz_pushr_p(JIT_R0); + mz_pushr_p(JIT_R0); #endif /* Extract closure to runstack: */ @@ -7710,6 +7737,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) code_end = jit_get_ip().ptr; if (jitter->retain_start) { + gdata->arity_code = arity_code; gdata->code = code; gdata->tail_code = tail_code; gdata->max_extra = jitter->max_extra_pushed; @@ -7727,7 +7755,7 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc) Scheme_Closure_Data *data; Generate_Closure_Data gdata; void *code, *tail_code, *arity_code; - int has_rest, is_method, num_params, max_depth; + int max_depth; data = ndata->u2.orig_code; @@ -7748,6 +7776,7 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc) if (SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_SINGLE_RESULT) SCHEME_NATIVE_CLOSURE_DATA_FLAGS(ndata) |= NATIVE_IS_SINGLE_RESULT; + arity_code = gdata.arity_code; code = gdata.code; tail_code = gdata.tail_code; @@ -7759,21 +7788,6 @@ static void on_demand_generate_lambda(Scheme_Native_Closure *nc) #endif } - has_rest = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_HAS_REST) ? 1 : 0); - is_method = ((SCHEME_CLOSURE_DATA_FLAGS(data) & CLOS_IS_METHOD) ? 1 : 0); - num_params = data->num_params; - if (num_params && has_rest) - --num_params; - - if (num_params < MAX_SHARED_ARITY_CHECK) { - arity_code = shared_arity_check[num_params][has_rest][is_method]; - if (!arity_code) { - arity_code = generate_lambda_simple_arity_check(num_params, has_rest, is_method, 1); - shared_arity_check[num_params][has_rest][is_method] = arity_code; - } - } else - arity_code = generate_lambda_simple_arity_check(num_params, has_rest, is_method, 0); - /* Add a couple of extra slots to computed let-depth, in case we haven't quite computed right for inlined uses, etc. */ max_depth = WORDS_TO_BYTES(data->max_let_depth + gdata.max_extra + 2); From 769ad3e98aa7f990e6cc4b1ef132287b49e3fe9c Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Mar 2009 16:24:50 +0000 Subject: [PATCH 107/140] fix bug in sync/enable-break where a channel recv could be accepted during the raise of a break exn; also, post NACKs before raising exn svn: r14218 --- src/mzscheme/src/sema.c | 3 +++ src/mzscheme/src/thread.c | 10 ++++++++-- 2 files changed, 11 insertions(+), 2 deletions(-) diff --git a/src/mzscheme/src/sema.c b/src/mzscheme/src/sema.c index 4980063a15..0e927e49a8 100644 --- a/src/mzscheme/src/sema.c +++ b/src/mzscheme/src/sema.c @@ -387,6 +387,7 @@ static int out_of_line(Scheme_Object *a) } static void get_into_line(Scheme_Sema *sema, Scheme_Channel_Syncer *w) + /* Can be called multiple times. */ { Scheme_Channel_Syncer *last, *first; @@ -430,6 +431,8 @@ static void get_outof_line(Scheme_Sema *sema, Scheme_Channel_Syncer *w) { Scheme_Channel_Syncer *last, *first; + if (!w->in_line) + return; w->in_line = 0; if (SAME_TYPE(SCHEME_TYPE(sema), scheme_never_evt_type)) { diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 232d6be8cd..0561f29992 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -363,6 +363,7 @@ static Scheme_Object *will_executor_go(int argc, Scheme_Object *args[]); static Scheme_Object *will_executor_sema(Scheme_Object *w, int *repost); static Scheme_Object *check_break_now(int argc, Scheme_Object *args[]); +static int syncing_ready(Scheme_Object *s, Scheme_Schedule_Info *sinfo); static void make_initial_config(Scheme_Thread *p); @@ -3772,6 +3773,11 @@ static void raise_break(Scheme_Thread *p) p->external_break = 0; + if (p->blocker && (p->block_check == syncing_ready)) { + /* Get out of lines for channels, etc., before calling a break exn handler. */ + scheme_post_syncing_nacks((Syncing *)p->blocker); + } + block_descriptor = p->block_descriptor; blocker = p->blocker; block_check = p->block_check; @@ -5677,7 +5683,7 @@ Scheme_Object *scheme_make_evt_set(int argc, Scheme_Object **argv) } void scheme_post_syncing_nacks(Syncing *syncing) - /* Also removes channel-syncers */ + /* Also removes channel-syncers. Can be called multiple times. */ { int i, c; Scheme_Object *l; @@ -5792,7 +5798,7 @@ static Scheme_Object *do_sync(const char *name, int argc, Scheme_Object *argv[], timeout = 0.0; /* means "no timeout" to block_until */ if (with_break) { - /* Suspended breaks when something is selected: */ + /* Suspended breaks when something is selected. */ syncing->disable_break = scheme_current_thread; } From a61e7b67f97a5e12c99c9f042c32286389adec99 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Mar 2009 16:26:01 +0000 Subject: [PATCH 108/140] fix more break-progaration problems in scheme/sandbox (where recent changes were not quite right) svn: r14219 --- collects/scheme/sandbox.ss | 39 ++++++++++++++++++-------------------- 1 file changed, 18 insertions(+), 21 deletions(-) diff --git a/collects/scheme/sandbox.ss b/collects/scheme/sandbox.ss index 3e834a0a0d..935a7273d6 100644 --- a/collects/scheme/sandbox.ss +++ b/collects/scheme/sandbox.ss @@ -682,8 +682,8 @@ (evaluate-program (if (procedure? program-maker) (program-maker) program-maker) limit-thunk - (and coverage? (lambda (es+get) (set! uncovered es+get))))))) - (channel-put result-ch 'ok) + (and coverage? (lambda (es+get) (set! uncovered es+get)))))) + (channel-put result-ch 'ok)) (set! eval-handler (cadr (sandbox-eval-handlers))) ; interactions handler ;; finally wait for interaction expressions (let ([n 0]) @@ -711,25 +711,22 @@ (call-with-values run list)))))) (loop))))))) (define (get-user-result) - (let ([get-result (lambda () (sync user-done-evt result-ch))]) - (if (and (sandbox-propagate-breaks) - ;; The following test is weird. We reliably catch breaks if breaks - ;; are enabled, except that a break just before or after isn't - ;; reliably propagated. A `get-result/enable-breaks' function - ;; would make more sense. - (break-enabled)) - ;; The following loop ensures that breaks are disabled while trying - ;; to handle a break, which ensures that we don't fail to - ;; propagate a break. - (parameterize-break - #f - (let loop () - (with-handlers* ([exn:break? (lambda (e) (user-break) (loop))]) - (parameterize-break - #t - (get-result))))) - ;; The same case doesn't have to deal with breaks: - (get-result)))) + (if (and (sandbox-propagate-breaks) + ;; The following test is weird. We reliably catch breaks if breaks + ;; are enabled, except that a break just before or after isn't + ;; reliably propagated. A `get-result/enable-breaks' function + ;; would make more sense. + (break-enabled)) + ;; The following loop ensures that breaks are disabled while trying + ;; to handle a break, which ensures that we don't fail to + ;; propagate a break. + (parameterize-break + #f + (let loop () + (with-handlers* ([exn:break? (lambda (e) (user-break) (loop))]) + (sync/enable-break user-done-evt result-ch)))) + ;; The simple case doesn't have to deal with breaks: + (sync user-done-evt result-ch))) (define (user-eval expr) ;; the thread will usually be running, but it might be killed outside of ;; the sandboxed environment, for example, if you do something like From 5514afa4bc9f31da13813cd7024be982352d4f13 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Mar 2009 16:42:03 +0000 Subject: [PATCH 109/140] notes on the hazards of sandbox break propagation svn: r14220 --- collects/scribblings/reference/sandbox.scrbl | 12 +++++++++--- 1 file changed, 9 insertions(+), 3 deletions(-) diff --git a/collects/scribblings/reference/sandbox.scrbl b/collects/scribblings/reference/sandbox.scrbl index 386a62df8d..d469fb5f94 100644 --- a/collects/scribblings/reference/sandbox.scrbl +++ b/collects/scribblings/reference/sandbox.scrbl @@ -411,12 +411,18 @@ collected by sandbox evaluators. Use @defboolparam[sandbox-propagate-breaks propagate?]{ -When this boolean parameter is true, breaking while an evaluator is -running evaluator propagates the break signal to the sandboxed +When both this boolean parameter and @scheme[(break-enabled)] are true, +breaking while an evaluator is +running propagates the break signal to the sandboxed context. This makes the sandboxed evaluator break, typically, but beware that sandboxed evaluation can capture and avoid the breaks (so if safe execution of code is your goal, make sure you use it with a -time limit). The default is @scheme[#t].} +time limit). Also, beware that a break may be received after the +evaluator's result, in which case the evaluation result is lost. Finally, +beware that a break may be propagated after an evaluator has produced +a result, so that the break is visible on the next interaction with +the evaluator (or the break is lost if the evaluator is not used +further). The default is @scheme[#t].} @defparam[sandbox-namespace-specs spec (cons/c (-> namespace?) From 547101ac5bb81b9af1ccb39377fb6895101a2f2f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sun, 22 Mar 2009 16:42:35 +0000 Subject: [PATCH 110/140] disable sandbox break propagation in scribble/eval svn: r14221 --- collects/scribble/eval.ss | 38 ++++++++++++++++++++------------------ 1 file changed, 20 insertions(+), 18 deletions(-) diff --git a/collects/scribble/eval.ss b/collects/scribble/eval.ss index 269dc707b0..93eb5a2c46 100644 --- a/collects/scribble/eval.ss +++ b/collects/scribble/eval.ss @@ -238,7 +238,8 @@ (call-with-trusted-sandbox-configuration (lambda () (parameterize ([sandbox-output 'string] - [sandbox-error-output 'string]) + [sandbox-error-output 'string] + [sandbox-propagate-breaks #f]) (make-evaluator '(begin (require scheme/base))))))) (define (close-eval e) @@ -246,23 +247,24 @@ "") (define (do-plain-eval ev s catching-exns?) - (call-with-values (lambda () - ((scribble-eval-handler) - ev - catching-exns? - (let ([s (strip-comments s)]) - (cond - [(syntax? s) - (syntax-case s (module) - [(module . _rest) - (syntax->datum s)] - [_else s])] - [(bytes? s) - `(begin ,s)] - [(string? s) - `(begin ,s)] - [else s])))) - list)) + (parameterize ([sandbox-propagate-breaks #f]) + (call-with-values (lambda () + ((scribble-eval-handler) + ev + catching-exns? + (let ([s (strip-comments s)]) + (cond + [(syntax? s) + (syntax-case s (module) + [(module . _rest) + (syntax->datum s)] + [_else s])] + [(bytes? s) + `(begin ,s)] + [(string? s) + `(begin ,s)] + [else s])))) + list))) (define-syntax-rule (quote-expr e) 'e) From 75373d4094cef19a68b80d8f6a24fd3a6479f679 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2009 01:25:45 +0000 Subject: [PATCH 111/140] refine replace-context docs svn: r14223 --- collects/syntax/scribblings/strip-context.scrbl | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/syntax/scribblings/strip-context.scrbl b/collects/syntax/scribblings/strip-context.scrbl index e36bff5850..41e38b7314 100644 --- a/collects/syntax/scribblings/strip-context.scrbl +++ b/collects/syntax/scribblings/strip-context.scrbl @@ -2,7 +2,7 @@ @(require "common.ss" (for-label syntax/strip-context)) -@title[#:tag "strip-context"]{Stripping Lexical Context} +@title[#:tag "strip-context"]{Replacing Lexical Context} @defmodule[syntax/strip-context] @@ -11,7 +11,7 @@ Removes all lexical context from @scheme[stx], preserving source-location information and properties.} -@defproc[(replace-context [ctx-stx syntax?] [stx syntax?]) syntax?]{ +@defproc[(replace-context [ctx-stx (or/c syntax? #f)] [stx syntax?]) syntax?]{ Uses the lexical context of @scheme[ctx-stx] to replace the lexical context of all parts of @scheme[stx], preserving source-location From 5d3d5a890a91d3adeb2f6c18ef9dda732740ac14 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2009 01:26:51 +0000 Subject: [PATCH 112/140] record per-thread milliseconds svn: r14224 --- collects/scribblings/reference/time.scrbl | 10 +++++++--- doc/release-notes/mzscheme/HISTORY.txt | 1 + src/mzscheme/include/mzscheme.exp | 1 + src/mzscheme/include/mzscheme3m.exp | 1 + src/mzscheme/include/mzwin.def | 1 + src/mzscheme/include/mzwin3m.def | 1 + src/mzscheme/include/scheme.h | 3 +++ src/mzscheme/src/fun.c | 24 +++++++++++++++++++++-- src/mzscheme/src/schemef.h | 1 + src/mzscheme/src/schemex.h | 1 + src/mzscheme/src/schemex.inc | 1 + src/mzscheme/src/schemexm.h | 1 + src/mzscheme/src/thread.c | 18 +++++++++++++++++ 13 files changed, 59 insertions(+), 5 deletions(-) diff --git a/collects/scribblings/reference/time.scrbl b/collects/scribblings/reference/time.scrbl index ca72c8637b..2c28abea77 100644 --- a/collects/scribblings/reference/time.scrbl +++ b/collects/scribblings/reference/time.scrbl @@ -72,12 +72,16 @@ Like @scheme[current-milliseconds], but the result never decreases (until the machine is turned off).} -@defproc[(current-process-milliseconds) exact-integer?]{ +@defproc[(current-process-milliseconds [thread (or/c thread? #f)]) + exact-integer?]{ -Returns the amount of processor time in @tech{fixnum} milliseconds +Returns an amount of processor time in @tech{fixnum} milliseconds that has been consumed by the Scheme process on the underlying operating system. (Under @|AllUnix|, this includes both user and -system time.) The precision of the result is platform-specific, and +system time.) If @scheme[thread] is @scheme[#f], the reported time +is for all Scheme threads, otherwise the result is specific to the +time while @scheme[thread] ran. +The precision of the result is platform-specific, and since the result is a @tech{fixnum}, the value increases only over a limited (though reasonably long) time.} diff --git a/doc/release-notes/mzscheme/HISTORY.txt b/doc/release-notes/mzscheme/HISTORY.txt index ea3c16984c..6713c0f407 100644 --- a/doc/release-notes/mzscheme/HISTORY.txt +++ b/doc/release-notes/mzscheme/HISTORY.txt @@ -6,6 +6,7 @@ Add 'not-free-identifier=? syntax property to disable free-identifier=? Add prop:rename-transformer and prop:set!-transformer Fix scheme/local so that local syntax bindings are visible to later local definitions +Changed current-process-milliseconds to accept a thread argument Version 4.1.5.2 Changed expander to detect a reaname transformer and install a diff --git a/src/mzscheme/include/mzscheme.exp b/src/mzscheme/include/mzscheme.exp index ac24cae8e5..7c3ff49e19 100644 --- a/src/mzscheme/include/mzscheme.exp +++ b/src/mzscheme/include/mzscheme.exp @@ -562,6 +562,7 @@ scheme_get_seconds scheme_get_milliseconds scheme_get_inexact_milliseconds scheme_get_process_milliseconds +scheme_get_thread_milliseconds scheme_banner scheme_version scheme_check_proc_arity diff --git a/src/mzscheme/include/mzscheme3m.exp b/src/mzscheme/include/mzscheme3m.exp index ac6876fdc3..8a0104b167 100644 --- a/src/mzscheme/include/mzscheme3m.exp +++ b/src/mzscheme/include/mzscheme3m.exp @@ -574,6 +574,7 @@ scheme_get_seconds scheme_get_milliseconds scheme_get_inexact_milliseconds scheme_get_process_milliseconds +scheme_get_thread_milliseconds scheme_banner scheme_version scheme_check_proc_arity diff --git a/src/mzscheme/include/mzwin.def b/src/mzscheme/include/mzwin.def index e52df5313c..63c7fbd1a0 100644 --- a/src/mzscheme/include/mzwin.def +++ b/src/mzscheme/include/mzwin.def @@ -550,6 +550,7 @@ EXPORTS scheme_get_milliseconds scheme_get_inexact_milliseconds scheme_get_process_milliseconds + scheme_get_thread_milliseconds scheme_banner scheme_version scheme_check_proc_arity diff --git a/src/mzscheme/include/mzwin3m.def b/src/mzscheme/include/mzwin3m.def index 9e2f1bd4ef..c85242740b 100644 --- a/src/mzscheme/include/mzwin3m.def +++ b/src/mzscheme/include/mzwin3m.def @@ -566,6 +566,7 @@ EXPORTS scheme_get_milliseconds scheme_get_inexact_milliseconds scheme_get_process_milliseconds + scheme_get_thread_milliseconds scheme_banner scheme_version scheme_check_proc_arity diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index 41b06f0eee..57fdb5866a 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -1081,6 +1081,9 @@ typedef struct Scheme_Thread { long gmp_tls[6]; void *gmp_tls_data; + long accum_process_msec; + long current_start_process_msec; + struct Scheme_Thread_Custodian_Hop *mr_hop; Scheme_Custodian_Reference *mref; Scheme_Object *extra_mrefs; /* More owning custodians */ diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index a768c6c5a4..74810fb41d 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -447,7 +447,7 @@ scheme_init_fun (Scheme_Env *env) scheme_add_global_constant("current-process-milliseconds", scheme_make_prim_w_arity(current_process_milliseconds, "current-process-milliseconds", - 0, 0), + 0, 1), env); scheme_add_global_constant("current-gc-milliseconds", scheme_make_prim_w_arity(current_gc_milliseconds, @@ -7986,6 +7986,19 @@ long scheme_get_process_milliseconds(void) #endif } +long scheme_get_thread_milliseconds(Scheme_Object *thrd) +{ + Scheme_Thread *t = thrd ? (Scheme_Thread *)thrd : scheme_current_thread; + + if (t == scheme_current_thread) { + long cpm; + cpm = scheme_get_process_milliseconds(); + return t->accum_process_msec + (cpm - t->current_start_process_msec); + } else { + return t->accum_process_msec; + } +} + #ifdef MZ_XFORM END_XFORM_SKIP; #endif @@ -8272,7 +8285,14 @@ static Scheme_Object *current_inexact_milliseconds(int argc, Scheme_Object **arg static Scheme_Object *current_process_milliseconds(int argc, Scheme_Object **argv) { - return scheme_make_integer(scheme_get_process_milliseconds()); + if (!argc || SCHEME_FALSEP(argv[0])) + return scheme_make_integer(scheme_get_process_milliseconds()); + else { + if (SCHEME_THREADP(argv[0])) + return scheme_make_integer(scheme_get_thread_milliseconds(argv[0])); + scheme_wrong_type("current-process-milliseconds", "thread", 0, argc, argv); + return NULL; + } } static Scheme_Object *current_gc_milliseconds(int argc, Scheme_Object **argv) diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index 0a52678a7e..6856587fc4 100644 --- a/src/mzscheme/src/schemef.h +++ b/src/mzscheme/src/schemef.h @@ -1071,6 +1071,7 @@ MZ_EXTERN long scheme_get_seconds(void); MZ_EXTERN long scheme_get_milliseconds(void); MZ_EXTERN double scheme_get_inexact_milliseconds(void); MZ_EXTERN long scheme_get_process_milliseconds(void); +MZ_EXTERN long scheme_get_thread_milliseconds(Scheme_Object *thrd); MZ_EXTERN char *scheme_banner(void); MZ_EXTERN char *scheme_version(void); diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index 6a3224ac99..dfaec8a86b 100644 --- a/src/mzscheme/src/schemex.h +++ b/src/mzscheme/src/schemex.h @@ -886,6 +886,7 @@ long (*scheme_get_seconds)(void); long (*scheme_get_milliseconds)(void); double (*scheme_get_inexact_milliseconds)(void); long (*scheme_get_process_milliseconds)(void); +long (*scheme_get_thread_milliseconds)(Scheme_Object *thrd); char *(*scheme_banner)(void); char *(*scheme_version)(void); int (*scheme_check_proc_arity)(const char *where, int a, diff --git a/src/mzscheme/src/schemex.inc b/src/mzscheme/src/schemex.inc index 0753e7a6eb..a1eb923619 100644 --- a/src/mzscheme/src/schemex.inc +++ b/src/mzscheme/src/schemex.inc @@ -620,6 +620,7 @@ scheme_extension_table->scheme_get_milliseconds = scheme_get_milliseconds; scheme_extension_table->scheme_get_inexact_milliseconds = scheme_get_inexact_milliseconds; scheme_extension_table->scheme_get_process_milliseconds = scheme_get_process_milliseconds; + scheme_extension_table->scheme_get_thread_milliseconds = scheme_get_thread_milliseconds; scheme_extension_table->scheme_banner = scheme_banner; scheme_extension_table->scheme_version = scheme_version; scheme_extension_table->scheme_check_proc_arity = scheme_check_proc_arity; diff --git a/src/mzscheme/src/schemexm.h b/src/mzscheme/src/schemexm.h index fec4281b78..bb7e3dd2eb 100644 --- a/src/mzscheme/src/schemexm.h +++ b/src/mzscheme/src/schemexm.h @@ -620,6 +620,7 @@ #define scheme_get_milliseconds (scheme_extension_table->scheme_get_milliseconds) #define scheme_get_inexact_milliseconds (scheme_extension_table->scheme_get_inexact_milliseconds) #define scheme_get_process_milliseconds (scheme_extension_table->scheme_get_process_milliseconds) +#define scheme_get_thread_milliseconds (scheme_extension_table->scheme_get_thread_milliseconds) #define scheme_banner (scheme_extension_table->scheme_banner) #define scheme_version (scheme_extension_table->scheme_version) #define scheme_check_proc_arity (scheme_extension_table->scheme_check_proc_arity) diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index 0561f29992..dde50e7cf7 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -2532,6 +2532,12 @@ static void do_swap_thread() scheme_takeover_stacks(scheme_current_thread); } + { + long cpm; + cpm = scheme_get_process_milliseconds(); + scheme_current_thread->current_start_process_msec = cpm; + } + if (scheme_current_thread->return_marks_to) { stash_current_marks(); goto start; @@ -2539,6 +2545,12 @@ static void do_swap_thread() } else { Scheme_Thread *new_thread = swap_target; + { + long cpm; + cpm = scheme_get_process_milliseconds(); + scheme_current_thread->accum_process_msec += (cpm - scheme_current_thread->current_start_process_msec); + } + swap_target = NULL; swap_no_setjmp = 0; @@ -2846,6 +2858,12 @@ static void start_child(Scheme_Thread * volatile child, } } + { + long cpm; + cpm = scheme_get_process_milliseconds(); + scheme_current_thread->current_start_process_msec = cpm; + } + RESETJMP(child); #if WATCH_FOR_NESTED_SWAPS From 4eb298c6f748b3e96c7e0ce9a5ab7e40712d2807 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 23 Mar 2009 03:56:51 +0000 Subject: [PATCH 113/140] svn: r14225 --- collects/drscheme/tool-lib.ss | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/collects/drscheme/tool-lib.ss b/collects/drscheme/tool-lib.ss index 708e4123f1..d18f85b627 100644 --- a/collects/drscheme/tool-lib.ss +++ b/collects/drscheme/tool-lib.ss @@ -673,8 +673,8 @@ all of the names in the tools library, for use defining keybindings (proc-doc/names drscheme:get/extend:extend-tab (case-> - ((make-mixin-contract drscheme:unit:tab%) . -> . void?) - ((make-mixin-contract drscheme:unit:tab%) boolean? . -> . void?)) + ((make-mixin-contract drscheme:unit:tab<%>) . -> . void?) + ((make-mixin-contract drscheme:unit:tab<%>) boolean? . -> . void?)) ((mixin) (mixin before?)) @{This class implements the tabs in drscheme. One is created for each tab From 4f057fce77095bc82de3a123267ef5f7138d3294 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 23 Mar 2009 03:58:13 +0000 Subject: [PATCH 114/140] svn: r14226 --- collects/drscheme/info.ss | 4 +- collects/drscheme/sprof.ss | 304 +++++++++++++++++++++++++++++++++++++ 2 files changed, 306 insertions(+), 2 deletions(-) create mode 100644 collects/drscheme/sprof.ss diff --git a/collects/drscheme/info.ss b/collects/drscheme/info.ss index 9786880b1f..f99ab06b9d 100644 --- a/collects/drscheme/info.ss +++ b/collects/drscheme/info.ss @@ -1,6 +1,6 @@ #lang setup/infotab -(define tools '("syncheck.ss")) -(define tool-names '("Check Syntax")) +(define tools '("syncheck.ss" "sprof.ss")) +(define tool-names '("Check Syntax" "Sampling Profiler")) (define mred-launcher-names '("DrScheme")) (define mred-launcher-libraries '("drscheme.ss")) diff --git a/collects/drscheme/sprof.ss b/collects/drscheme/sprof.ss new file mode 100644 index 0000000000..ccab44e1dd --- /dev/null +++ b/collects/drscheme/sprof.ss @@ -0,0 +1,304 @@ +#lang scheme/base +(require scheme/gui/base + framework + scheme/class) + +;; how long between samples +(define pause-time 0.1) + +;; gui updates occur every 'update-frequency' samples +(define update-frequency 4) + +(define (make-prod-thread get-threads update-gui) + (thread (lambda () + (define traces-table (make-hash)) + (let loop ([i 0]) + (sleep pause-time) + (let ([new-traces + (map (λ (t) (continuation-mark-set->context (continuation-marks t))) + (get-threads))]) + (for-each + (λ (trace) + (for-each + (λ (line) + (hash-set! traces-table line (cons trace (hash-ref traces-table line '())))) + trace)) + new-traces) + (cond + [(zero? i) + (update-gui traces-table) + (loop update-frequency)] + [else + (loop (- i 1))])))))) + +(define (format-fn-name i) + (let ([id (car i)] + [src (cdr i)]) + (cond + [id (format "~a" id)] + [src + (format "~a:~a~a" + (cond + [(path? (srcloc-source src)) + (let-values ([(base name dir?) (split-path (srcloc-source src))]) + name)] + [else (srcloc-source src)]) + (if (srcloc-line src) + (format "~a:~a" + (srcloc-line src) + (srcloc-column src)) + (srcloc-position src)) + (if id + (format ": ~a" id) + ""))] + [else "???"]))) + +(define (insert-long-fn-name t i) + (send t begin-edit-sequence) + (send t erase) + (let ([id (car i)] + [src (cdr i)]) + (when src + (send t insert + (format "~a:~a" + (srcloc-source src) + (if (srcloc-line src) + (format "~a:~a" + (srcloc-line src) + (srcloc-column src)) + (format ":~a" (srcloc-position src)))))) + (when (and id src) + (send t insert "\n")) + (when id + (send t insert (format (format "~a" id)))) + (unless (or id src) + (send t insert "???"))) + (send t end-edit-sequence)) + +(define (format-percentage n) + (let ([trunc (floor (* n 100))]) + (format "~a%" (pad3 trunc)))) + +(define (pad3 n) + (cond + [(< n 10) (format "00~a" n)] + [(< n 100) (format "0~a" n)] + [else (format "~a" n)])) + +(define cumulative-t% + (class text:basic% + (init-field open-button vp ec1 lp info-editor) + (inherit begin-edit-sequence + end-edit-sequence + erase + find-position + get-admin + dc-location-to-editor-location + position-paragraph + insert + last-position + highlight-range + last-paragraph + lock) + + (define gui-display-data '()) + (define clicked-srcloc-pr #f) + (define line-to-source (make-hasheq)) + + (define clear-old-pr void) + + (define/override (on-event event) + (cond + [(send event button-up? 'left) + (let ([admin (get-admin)]) + (when admin + (let ([dc (send admin get-dc)]) + (let-values ([(x y) (dc-location-to-editor-location (send event get-x) + (send event get-y))]) + (let* ([loc (find-position x y)] + [para (position-paragraph loc)]) + (set! clicked-srcloc-pr (and (<= 0 para (last-paragraph)) + (car (list-ref gui-display-data para)))) + (update-gui-display))))))] + [else (void)])) + + (define/public (set-gui-display-data/refresh traces-table) + (set! gui-display-data + (sort (hash-map traces-table (λ (k v) (cons k v))) + > + #:key (λ (x) (length (cdr x))))) + (update-gui-display)) + + (define/public (clear-clicked) + (set! clicked-srcloc-pr #f) + (update-gui-display)) + + (define/private (update-gui-display) + (lock #f) + (begin-edit-sequence) + (erase) + (set! line-to-source (make-hasheq)) + (clear-old-pr) + (set! clear-old-pr void) + (let* ([denom-ht (make-hasheq)] + [filtered-gui-display-data + (map + (λ (pr) + (let ([id (car pr)] + [stacks (filter-stacks (cdr pr))]) + (for-each (λ (stack) (hash-set! denom-ht stack #t)) stacks) + (cons id stacks))) + gui-display-data)] + [denom-count (hash-count denom-ht)]) + (let loop ([prs filtered-gui-display-data] + [first? #t] + [i 0]) + (cond + [(null? prs) (void)] + [else + (let* ([pr (car prs)] + [fn (car pr)] + [count (length (cdr pr))]) + (cond + [(zero? count) + (loop (cdr prs) first? i)] + [else + (unless first? (insert "\n")) + (let ([before (last-position)]) + (hash-set! line-to-source i pr) + (insert (format-percentage (/ count denom-count))) + (insert (format " ~a" (format-fn-name fn))) + (let ([after (last-position)]) + (when (equal? (car pr) clicked-srcloc-pr) + (set! clear-old-pr (highlight-range before after "NavajoWhite"))))) + (loop (cdr prs) #f (+ i 1))]))])) + (lock #t) + (end-edit-sequence) + (update-info-editor clicked-srcloc-pr) + (send open-button enable (and clicked-srcloc-pr (path? (srcloc-source (cdr clicked-srcloc-pr))))))) + + (define/private (filter-stacks stacks) + (cond + [(not clicked-srcloc-pr) stacks] + [else + (filter (λ (stack) (ormap (λ (stack-ent) (equal? clicked-srcloc-pr stack-ent)) + stack)) + stacks)])) + + (define/public (open-current-pr) + (when clicked-srcloc-pr + (let ([src (cdr clicked-srcloc-pr)]) + (when (path? (srcloc-source src)) + (printf "open ~s\n" (srcloc-source src)) + (when (number? (srcloc-position src)) + (printf "go to ~s\n" (srcloc-position src))))))) + + (define/private (update-info-editor pr) + (send vp change-children (λ (l) (if pr (list ec1 lp) (list ec1)))) + (when pr + (insert-long-fn-name info-editor pr))) + + (super-new))) + +(define (construct-gui f) + (define info-editor (new text%)) + (define vp (new vertical-panel% [parent f])) + (define ec1 (new editor-canvas% + [parent vp] + [min-height 800] + [min-width 400])) + (define lp (new vertical-panel% [parent vp])) + (define ec2 (new editor-canvas% + [parent lp] + [min-height 100] + [stretchable-height #f] + [editor info-editor])) + (define bp (new horizontal-panel% [stretchable-height #f] [parent lp] [alignment '(center center)])) + (define open-button (new button% + [parent bp] + [label "Open"] + [callback + (λ (x y) + (send cumulative-t open-current-pr))])) + (define unlock (new button% + [label "Show All"] + [parent bp] + [callback + (λ (x y) + (send cumulative-t clear-clicked))])) + (define cumulative-t (new cumulative-t% + [open-button open-button] + [vp vp] + [ec1 ec1] + [lp lp] + [info-editor info-editor])) + (send ec1 set-editor cumulative-t) + (send vp change-children (λ (l) (list ec1))) + (send cumulative-t hide-caret #t) + (send cumulative-t lock #t) + (send info-editor auto-wrap #t) + (values vp cumulative-t)) + +;; running an example outside of drscheme +#; +(begin + (define evt (make-eventspace)) + (define f (parameterize ([current-eventspace evt]) + (new frame% [label ""]))) + (define cumulative-t (construct-gui f)) + (send f show #t) + + (void (make-prod-thread (let ([t (current-thread)]) + (λ () (list t))) + (λ (traces-table) + (parameterize ([current-eventspace evt]) + (queue-callback + (λ () + (send cumulative-t set-gui-display-data/refresh traces-table))))))) + + (time (dynamic-require '(lib "scribblings/reference/reference.scrbl") + #f))) + + +(begin + (require drscheme/tool + scheme/unit) + (provide tool@) + (define tool@ + (unit + (import drscheme:tool^) + (export drscheme:tool-exports^) + (define (phase1) (void)) + (define (phase2) (void)) + + #; + (define-local-member-name + ) + + (define unit-frame-mixin + (mixin (drscheme:unit:frame<%>) () + (define main-panel #f) + (define sprof-main-panel #f) + (define everything-else #f) + (define cumulative-t #f) + (define/override (make-root-area-container cls parent) + (set! main-panel (super make-root-area-container horizontal-panel% parent)) + (set! everything-else (make-object cls main-panel)) + (set!-values (sprof-main-panel cumulative-t) (construct-gui main-panel)) + (send main-panel change-children (λ (l) (list everything-else))) + everything-else) + (super-new))) + + (define tab-mixin + (mixin (drscheme:unit:tab<%>) () + (define prof-visible? #f) + + (super-new))) + + (define repl-mixin + (mixin (drscheme:rep:text<%>) () + (super-new))) + + (drscheme:get/extend:extend-tab tab-mixin) + (drscheme:get/extend:extend-interactions-text repl-mixin) + (drscheme:get/extend:extend-unit-frame unit-frame-mixin)))) From dec8ea4775c37b17359c964fc282ff106dfc2abd Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 23 Mar 2009 07:50:24 +0000 Subject: [PATCH 115/140] Welcome to a new PLT day. svn: r14227 --- 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 2f152650d5..66af1acfca 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "22mar2009") +#lang scheme/base (provide stamp) (define stamp "23mar2009") From bb2268b9be8243a7e928df4e83ef6bc19a68a213 Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Mar 2009 12:02:46 +0000 Subject: [PATCH 116/140] improve types for foldl, foldr svn: r14228 --- collects/typed-scheme/private/base-env.ss | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 08cacb6c24..7f3ee7e562 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -101,10 +101,14 @@ [fold-right (-polydots (c a b) ((list ((list c a) (b b) . ->... . c) c (-lst a)) ((-lst b) b) . ->... . c))] [foldl - (-poly (a b c) + (-poly (a b c d) (cl-> [((a b . -> . b) b (-lst a)) b] - [((a b c . -> . c) c (-lst a) (-lst b)) c]))] -[foldr (-poly (a b c) ((a b . -> . b) b (-lst a) . -> . b))] + [((a b c . -> . c) c (-lst a) (-lst b)) c] + [((a b c d . -> . d) d (-lst a) (-lst b) (-lst d)) d]))] +[foldr (-poly (a b c d) + (cl-> [((a b . -> . b) b (-lst a)) b] + [((a b c . -> . c) c (-lst a) (-lst b)) c] + [((a b c d . -> . d) d (-lst a) (-lst b) (-lst d)) d]))] [filter (-poly (a b) (cl->* ((a . -> . B : From 3e039705fa2385195a5c378f1d6916e1ab090cb7 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2009 12:34:40 +0000 Subject: [PATCH 117/140] fix missig return (PR 10149) svn: r14229 --- src/mzscheme/src/eval.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 434288e9d2..0e379b0ddd 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -7104,7 +7104,8 @@ static Scheme_Object **evacuate_runstack(int num_rands, Scheme_Object **rands, S rands = p->ku.apply.tail_rands; p->ku.apply.tail_rands = NULL; return rands; - } + } else + return rands; } static Scheme_Dynamic_Wind *intersect_dw(Scheme_Dynamic_Wind *a, Scheme_Dynamic_Wind *b, From 7e6dc9b40e96929689daaeb0c8ac54da9985afe4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2009 13:17:46 +0000 Subject: [PATCH 118/140] optimize (if (if #t #f) ) to (if #t #f); this pattern happens with 'and' and constant folding svn: r14230 --- src/mzscheme/src/eval.c | 10 ++++++++++ 1 file changed, 10 insertions(+) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 0e379b0ddd..cc22486294 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -2902,6 +2902,16 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info) } else t = scheme_optimize_expr(t, info); + /* For test position, convert (if #t #f) to */ + while (1) { + if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type) + && SAME_OBJ(((Scheme_Branch_Rec *)t)->tbranch, scheme_true) + && SAME_OBJ(((Scheme_Branch_Rec *)t)->fbranch, scheme_false)) + t = ((Scheme_Branch_Rec *)t)->test; + else + break; + } + if (SCHEME_TYPE(t) > _scheme_compiled_values_types_) { if (SCHEME_FALSEP(t)) return scheme_optimize_expr(fb, info); From 1c9f11717c942c09174d3e21ed4cb4db9736102a Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2009 13:23:25 +0000 Subject: [PATCH 119/140] remove unnecessary loop svn: r14231 --- src/mzscheme/src/eval.c | 12 ++++-------- 1 file changed, 4 insertions(+), 8 deletions(-) diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index cc22486294..9efc9e879a 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -2903,14 +2903,10 @@ static Scheme_Object *optimize_branch(Scheme_Object *o, Optimize_Info *info) t = scheme_optimize_expr(t, info); /* For test position, convert (if #t #f) to */ - while (1) { - if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type) - && SAME_OBJ(((Scheme_Branch_Rec *)t)->tbranch, scheme_true) - && SAME_OBJ(((Scheme_Branch_Rec *)t)->fbranch, scheme_false)) - t = ((Scheme_Branch_Rec *)t)->test; - else - break; - } + if (SAME_TYPE(SCHEME_TYPE(t), scheme_branch_type) + && SAME_OBJ(((Scheme_Branch_Rec *)t)->tbranch, scheme_true) + && SAME_OBJ(((Scheme_Branch_Rec *)t)->fbranch, scheme_false)) + t = ((Scheme_Branch_Rec *)t)->test; if (SCHEME_TYPE(t) > _scheme_compiled_values_types_) { if (SCHEME_FALSEP(t)) From 40b47311061fda5fedef3c8017cd6b7c75432f6b Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Mar 2009 14:13:10 +0000 Subject: [PATCH 120/140] Expand (require A ...) into (begin (require A) ...) - docs (including discussion of require scoping) - tests svn: r14232 --- collects/scheme/private/reqprov.ss | 10 +++++----- collects/scribblings/reference/syntax.scrbl | 9 ++++++++- collects/tests/mzscheme/module.ss | 17 +++++++++++++++++ 3 files changed, 30 insertions(+), 6 deletions(-) diff --git a/collects/scheme/private/reqprov.ss b/collects/scheme/private/reqprov.ss index a0c1aa4236..bd2c9518d9 100644 --- a/collects/scheme/private/reqprov.ss +++ b/collects/scheme/private/reqprov.ss @@ -317,12 +317,12 @@ (syntax->list #'(elem ...))))] [_ (transform-simple in 0 #| run phase |#)]))]) (syntax-case stx () - [(_ in ...) - (with-syntax ([(new-in ...) - (apply append - (map transform-one (syntax->list #'(in ...))))]) + [(_ in) + (with-syntax ([(new-in ...) (transform-one #'in)]) (syntax/loc stx - (#%require new-in ...)))]))) + (#%require new-in ...)))] + [(_ in ...) + (syntax/loc stx (begin (require in) ...))]))) ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; require transformers diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index d248ba0dd2..6d9bc39c3e 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -272,7 +272,8 @@ In a @tech{top-level context}, @scheme[require] instantiates modules (see @secref["module-eval-model"]). In a @tech{module context}, @scheme[require] @tech{visits} modules (see @secref["mod-parse"]). In both contexts, @scheme[require] introduces bindings into a -@tech{namespace} or a module (see @secref["intro-binding"]). A +@tech{namespace} or a module (see @secref["intro-binding"]). + A @scheme[require] form in a @tech{expression context} or @tech{internal-definition context} is a syntax error. @@ -283,6 +284,12 @@ be different from the symbolic name of the originally exported identifier. Each identifier also binds at a particular @tech{phase level}. +A @scheme[require] scopes over all subsequent forms in @tech{top-level +contexts}, and all subsequent module top-level forms in a @tech{module +context} as well as all expression forms in a module. In both cases, +each @scheme[require-spec] scopes over all subsequent +@scheme[require-spec]s in them same @scheme[require] form. + The syntax of @scheme[require-spec] can be extended via @scheme[define-require-syntax], but the pre-defined forms are as follows. diff --git a/collects/tests/mzscheme/module.ss b/collects/tests/mzscheme/module.ss index e3550e034e..24eba26299 100644 --- a/collects/tests/mzscheme/module.ss +++ b/collects/tests/mzscheme/module.ss @@ -236,6 +236,23 @@ (require 'p3_cr) (test 18 values w_cr) +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Test `require' scoping + + +(module fake-prefix-in scheme + (require scheme/require-syntax) + (define-require-syntax (pseudo-+ stx) + (syntax-case stx () + [(_ id) + #'(only-in scheme [+ id])])) + (provide pseudo-+)) + +(require 'fake-prefix-in + (pseudo-+ ++)) +(test 12 values (++ 7 5)) + + ;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Test proper bindings for `#%module-begin' From 746446d4ac5f05a8876859a6a1de26541d654e5c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Mar 2009 15:34:34 +0000 Subject: [PATCH 121/140] Typed wrapper for file/tar contributed by YC. svn: r14233 --- collects/typed/file/tar.ss | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) create mode 100644 collects/typed/file/tar.ss diff --git a/collects/typed/file/tar.ss b/collects/typed/file/tar.ss new file mode 100644 index 0000000000..625a45a899 --- /dev/null +++ b/collects/typed/file/tar.ss @@ -0,0 +1,22 @@ +#lang typed-scheme +;; typed-scheme wrapper on file/tar +;; yc 2009/2/25 + +;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; basic type aliases. +(define-type-alias Path-String (U Path String)) + +(require/typed file/tar + ;; tar appears to return exact-nonenegative-integer? instead of void? + [tar (Path-String Path-String * -> Integer)] + ;; tar->output appears to take (listof path) instead of (listof path-string?) + ;; it also appears to return exact-nonenegative-integer? + [tar->output (case-lambda ((Listof Path) -> Integer) + ((Listof Path) Output-Port -> Integer))] + ;; tar->gzip + ;; missing from file/tar but available in mzlib/tar + ;; actually returns void? + [tar-gzip (Path-String Path-String * -> Void)] + ) + +(provide tar tar->output tar-gzip) \ No newline at end of file From ba56d99adb281488a2d64f7f5c9c68bc15983f5c Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Mar 2009 15:54:26 +0000 Subject: [PATCH 122/140] Fix return documentation for `tar' and `tar->output' Add documentation for `tar-gzip' svn: r14235 --- collects/file/scribblings/tar.scrbl | 14 ++++++++++---- 1 file changed, 10 insertions(+), 4 deletions(-) diff --git a/collects/file/scribblings/tar.scrbl b/collects/file/scribblings/tar.scrbl index 8f019ddc51..07c85d863f 100644 --- a/collects/file/scribblings/tar.scrbl +++ b/collects/file/scribblings/tar.scrbl @@ -1,6 +1,6 @@ #lang scribble/doc @(require "common.ss" - (for-label file/tar)) + (for-label file/tar file/gzip)) @title[#:tag "tar"]{@exec{tar} File Creation} @@ -13,7 +13,7 @@ information is not preserved; the owner that is stored in the archive is always ``root.''} @defproc[(tar [tar-file path-string?][path path-string?] ...) - void?]{ + exact-nonnegative-integer?]{ Creates @scheme[tar-file], which holds the complete content of all @scheme[path]s. The given @scheme[path]s are all expected to be @@ -23,12 +23,18 @@ to the current directory). If a nested path is provided as a resulting tar file, up to the current directory (using @scheme[pathlist-closure]).} -@defproc[(tar->output [paths (listof path-string?)] +@defproc[(tar->output [paths (listof path?)] [out output-port? (current-output-port)]) - void?]{ + exact-nonnegative-integer?]{ Packages each of the given @scheme[paths] in a @exec{tar} format archive that is written directly to the @scheme[out]. The specified @scheme[paths] are included as-is; if a directory is specified, its content is not automatically added, and nested directories are added without parent directories.} + +@defproc[(tar-gzip [tar-file path-string?] [paths path-string?] ...) + void?]{ + +Like @scheme[tar], but compresses the resulting file with @scheme[gzip]. +} From 29aa214cfec0eaea8b11ee5af0cc61edde2962db Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Mon, 23 Mar 2009 16:09:54 +0000 Subject: [PATCH 123/140] svn: r14236 --- collects/drscheme/info.ss | 4 +- collects/drscheme/sprof.ss | 118 +++++++++++++++++++++++++++++++++---- 2 files changed, 108 insertions(+), 14 deletions(-) diff --git a/collects/drscheme/info.ss b/collects/drscheme/info.ss index f99ab06b9d..4ece34f38a 100644 --- a/collects/drscheme/info.ss +++ b/collects/drscheme/info.ss @@ -1,6 +1,6 @@ #lang setup/infotab -(define tools '("syncheck.ss" "sprof.ss")) -(define tool-names '("Check Syntax" "Sampling Profiler")) +(define tools '("syncheck.ss" #;"sprof.ss")) +(define tool-names '("Check Syntax" #;"Sampling Profiler")) (define mred-launcher-names '("DrScheme")) (define mred-launcher-libraries '("drscheme.ss")) diff --git a/collects/drscheme/sprof.ss b/collects/drscheme/sprof.ss index ccab44e1dd..099dc03230 100644 --- a/collects/drscheme/sprof.ss +++ b/collects/drscheme/sprof.ss @@ -203,11 +203,8 @@ (define (construct-gui f) (define info-editor (new text%)) (define vp (new vertical-panel% [parent f])) - (define ec1 (new editor-canvas% - [parent vp] - [min-height 800] - [min-width 400])) - (define lp (new vertical-panel% [parent vp])) + (define ec1 (new editor-canvas% [parent vp])) + (define lp (new vertical-panel% [parent vp] [stretchable-height #f])) (define ec2 (new editor-canvas% [parent lp] [min-height 100] @@ -244,8 +241,11 @@ (begin (define evt (make-eventspace)) (define f (parameterize ([current-eventspace evt]) - (new frame% [label ""]))) - (define cumulative-t (construct-gui f)) + (new frame% + [label ""] + [width 400] + [height 800]))) + (define-values (panel cumulative-t) (construct-gui f)) (send f show #t) (void (make-prod-thread (let ([t (current-thread)]) @@ -259,10 +259,15 @@ (time (dynamic-require '(lib "scribblings/reference/reference.scrbl") #f))) - +;; tool code, for integration with drscheme (begin (require drscheme/tool - scheme/unit) + scheme/unit + string-constants/string-constant) + + (define sc-show-sprof "Show SProfile") + (define sc-hide-sprof "Hide SProfile") + (provide tool@) (define tool@ (unit @@ -271,32 +276,121 @@ (define (phase1) (void)) (define (phase2) (void)) - #; (define-local-member-name - ) + show/hide-sprof-panel + update-sprof-panel + toggle-sprof-visiblity + stop-profiling-thread + start-profiling-thread + get-threads-to-profile) (define unit-frame-mixin (mixin (drscheme:unit:frame<%>) () + (inherit get-current-tab) + (define main-panel #f) (define sprof-main-panel #f) (define everything-else #f) (define cumulative-t #f) + (define show/hide-menu-item #f) + + (define/public (show/hide-sprof-panel show?) + (let ([main-children (send main-panel get-children)]) + (send show/hide-menu-item + set-label + (if show? sc-hide-sprof sc-show-sprof)) + (unless (or (and show? (= 2 (length main-children))) + (and (not show?) (= 1 (length main-children)))) + (send main-panel change-children + (λ (l) + (if show? + (list everything-else sprof-main-panel) + (list everything-else))))))) + (define/override (make-root-area-container cls parent) - (set! main-panel (super make-root-area-container horizontal-panel% parent)) + (set! main-panel (super make-root-area-container panel:horizontal-dragable% parent)) (set! everything-else (make-object cls main-panel)) (set!-values (sprof-main-panel cumulative-t) (construct-gui main-panel)) (send main-panel change-children (λ (l) (list everything-else))) everything-else) + + (define/augment (on-tab-change from-tab to-tab) + (inner (void) on-tab-change from-tab to-tab) + (send to-tab update-sprof-panel)) + + (define/override (add-show-menu-items show-menu) + (super add-show-menu-items show-menu) + (set! show/hide-menu-item + (new menu-item% + [parent show-menu] + [label sc-show-sprof] + [callback + (λ (x y) + (send (get-current-tab) toggle-sprof-visiblity))]))) + + ;; FIX: the cumulative-t text object shouldn't be handed out like this + ;; instead its contents need to be tab specific, so switching tabs + ;; (ala the update-sprof-panel method) should change the contents of + ;; the cumulative-t, presumably via the set-gui-display-data/refresh method. + (define/public (get-cumulative-t) cumulative-t) + (super-new))) (define tab-mixin (mixin (drscheme:unit:tab<%>) () + (inherit get-frame get-ints) (define prof-visible? #f) + (define/public (toggle-sprof-visiblity) + (set! prof-visible? (not prof-visible?)) + (cond + [prof-visible? + (start-profiling-thread)] + [else + (stop-profiling-thread)]) + (update-sprof-panel)) + (define/public (update-sprof-panel) + (send (get-frame) show/hide-sprof-panel prof-visible?)) + + (define profiling-thread #f) + + (define/public (stop-profiling-thread) + (when profiling-thread + (kill-thread profiling-thread)) + (set! profiling-thread #f)) + + (define current-traces-table #f) + + (define/public (start-profiling-thread) + (stop-profiling-thread) + (set! profiling-thread (make-prod-thread + (λ () (send (get-ints) get-threads-to-profile)) + (λ (traces-table) + (queue-callback + (λ () + (send (send (get-frame) get-cumulative-t) set-gui-display-data/refresh traces-table))))))) (super-new))) + (define system-custodian (current-custodian)) + (define repl-mixin (mixin (drscheme:rep:text<%>) () + (inherit get-user-custodian) + (define/public (get-threads-to-profile) + (let ([thds '()]) + (let loop ([cust (get-user-custodian)]) + (for-each + (λ (obj) + (cond + [(custodian? obj) (loop obj)] + [(thread? obj) (set! thds (cons obj thds))])) + (custodian-managed-list cust system-custodian))) + thds)) + + ;; FIX + ;; something needs to happen here so that the profiling gets shutdown when the repl dies. + ;; the right call back isn't obvious, tho. :( + (super-new))) (drscheme:get/extend:extend-tab tab-mixin) From 59988f5ca5243ba40010f49ea6ce840ce2782e60 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2009 16:30:29 +0000 Subject: [PATCH 124/140] refine examples for require & provide svn: r14237 --- collects/scribblings/reference/syntax.scrbl | 310 ++++++++------------ 1 file changed, 125 insertions(+), 185 deletions(-) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 6d9bc39c3e..ad02549294 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -13,11 +13,13 @@ scheme/package scheme/splicing)) +@(define require-eval (make-base-eval)) @(define syntax-eval (lambda () (let ([the-eval (make-base-eval)]) (the-eval '(require (for-syntax scheme/base))) the-eval))) +@(define meta-in-eval (syntax-eval)) @(define cvt (schemefont "CVT")) @(define unquote-id (scheme unquote)) @@ -202,11 +204,13 @@ be preserved in marshaled bytecode. See also See also @secref["module-eval-model"] and @secref["mod-parse"]. @defexamples[#:eval (syntax-eval) -(module example-module scheme - (provide foo bar) - (define foo 2) - (define (bar x) - (+ x 1))) +(module duck scheme/base + (provide num-eggs quack) + (define num-eggs 2) + (define (quack n) + (unless (zero? n) + (printf "quack\n") + (quack (sub1 n))))) ] @defform[(#%module-begin form ...)]{ @@ -284,12 +288,6 @@ be different from the symbolic name of the originally exported identifier. Each identifier also binds at a particular @tech{phase level}. -A @scheme[require] scopes over all subsequent forms in @tech{top-level -contexts}, and all subsequent module top-level forms in a @tech{module -context} as well as all expression forms in a module. In both cases, -each @scheme[require-spec] scopes over all subsequent -@scheme[require-spec]s in them same @scheme[require] form. - The syntax of @scheme[require-spec] can be extended via @scheme[define-require-syntax], but the pre-defined forms are as follows. @@ -371,56 +369,34 @@ pre-defined forms are as follows. binding that is not for @scheme[phase-level], where @scheme[#f] for @scheme[phase-level] corresponds to the @tech{label phase level}. - This example only imports bindings at @tech{phase level} 1, the - transform phase. + The following example imports bindings only at @tech{phase level} 1, + the transform phase: - @defexamples[#:eval (syntax-eval) - (module test scheme + @interaction[#:eval meta-in-eval + (module nest scheme + (provide (for-syntax meta-eggs) + (for-meta 1 meta-chicks) + num-eggs) + (define-for-syntax meta-eggs 2) + (define-for-syntax meta-chicks 3) + (define num-eggs 2)) - (provide (for-syntax meta-1a) - (for-meta 1 meta-1b) - meta-0) + (require (only-meta-in 1 'nest)) - (define-for-syntax meta-1a 'a) - (define-for-syntax meta-1b 'b) - (define meta-0 2)) + (define-syntax (desc stx) + (printf "~s ~s\n" meta-eggs meta-chicks) + #'(void)) - (require (only-meta-in 1 'test)) - - (define-syntax bar - (lambda (stx) - (printf "~a\n" meta-1a) - (printf "~a\n" meta-1b) - #'1)) - - (bar) - meta-0 + (desc) + num-eggs ] - This example only imports bindings at @tech{phase level} 0, the + The following example imports only bindings at @tech{phase level} 0, the normal phase. - @defexamples[#:eval (syntax-eval) - (module test scheme - - (provide (for-syntax meta-1a) - (for-meta 1 meta-1b) - meta-0) - - (define-for-syntax meta-1a 'a) - (define-for-syntax meta-1b 'b) - (define meta-0 2)) - - (require (only-meta-in 0 'test)) - - (define-syntax bar - (lambda (stx) - (printf "~a\n" meta-1a) - (printf "~a\n" meta-1b) - #'1)) - - meta-0 - (bar) + @interaction[#:eval meta-in-eval + (require (only-meta-in 0 'nest)) + num-eggs ]} @specsubform[#:literals (for-meta) @@ -431,23 +407,15 @@ pre-defined forms are as follows. combination that involves @scheme[#f] produces @scheme[#f]. @defexamples[#:eval (syntax-eval) - (module test scheme - (provide foo) - (define foo 2)) - (require (for-meta 0 'test)) - foo - ]} - - @defexamples[#:eval (syntax-eval) - (module test scheme - (provide foo) - (define foo 2)) - (require (for-meta 1 'test)) - (define-syntax bar - (lambda (stx) - (printf "~a\n" foo) - #'1)) - (bar) + (module nest scheme + (provide num-eggs) + (define num-eggs 2)) + (require (for-meta 0 'nest)) + num-eggs + (require (for-meta 1 'nest)) + (define-syntax (roost stx) + (datum->syntax stx num-eggs)) + (roost) ]} @specsubform[#:literals (for-syntax) @@ -463,7 +431,10 @@ pre-defined forms are as follows. @scheme[(for-meta #f require-spec ...)].} @specsubform[derived-require-spec]{See @scheme[define-require-syntax] - for information on expanding the set of @scheme[require-spec] forms.} + for information on expanding the set of @scheme[require-spec] + forms. When multiple @scheme[require-spec]s are specified in a + @scheme[require], the bindings of each @scheme[require-spec] are + vsible for expanding later @scheme[require-spec]s.} @guideintro["module-paths"]{module paths} @@ -530,8 +501,8 @@ corresponds to the default @tech{module name resolver}. @tech{collection}, and @filepath{main.ss} is the library file name. Example: require swindle - @defexamples[#:eval (syntax-eval) - (require (lib "swindle"))]} + @defexamples[#:eval require-eval + (eval:alts (require (lib "swindle")) (void))]} @item{If a single @scheme[rel-string] is provided, and if it consists of multiple @litchar{/}-separated elements, then each @@ -540,8 +511,8 @@ corresponds to the default @tech{module name resolver}. no file suffix, @filepath{.ss} is added. Example: require a file within the swindle collection - @defexamples[#:eval (syntax-eval) - (require (lib "swindle/turbo"))]} + @defexamples[#:eval require-eval + (eval:alts (require (lib "swindle/turbo")) (void))]} @item{If a single @scheme[rel-string] is provided, and if it consists of a single element @italic{with} a file suffix (i.e, @@ -550,8 +521,8 @@ corresponds to the default @tech{module name resolver}. compatibility with older version of PLT Scheme.) Example: require the tar module from mzlib - @defexamples[#:eval (syntax-eval) - (require (lib "tar.ss"))]} + @defexamples[#:eval require-eval + (eval:alts (require (lib "tar.ss")) (void))]} @item{Otherwise, when multiple @scheme[rel-string]s are provided, the first @scheme[rel-string] is effectively moved after the @@ -562,8 +533,8 @@ corresponds to the default @tech{module name resolver}. with older version of PLT Scheme.) Example: require the tar module from mzlib - @defexamples[#:eval (syntax-eval) - (require (lib "tar.ss" "mzlib"))]} + @defexamples[#:eval require-eval + (eval:alts (require (lib "tar.ss" "mzlib")) (void))]} }} @specsubform[id]{A shorthand for a @scheme[lib] form with a single @@ -571,14 +542,14 @@ corresponds to the default @tech{module name resolver}. form of @scheme[id]. In addition to the constraints of a @scheme[lib] @scheme[_rel-string], @scheme[id] must not contain @litchar{.}. - @defexamples[#:eval (syntax-eval) - (require scheme/tcp)]} + @examples[#:eval require-eval + (eval:alts (require scheme/tcp) (void))]} @defsubform[(file string)]{Similar to the plain @scheme[rel-string] case, but @scheme[string] is a path---possibly absolute---using the current platform's path conventions and @scheme[expand-user-path]. - @scheme[(require (file "~/tmp/x.ss"))]} + @examples[(eval:alts (require (file "~/tmp/x.ss")) (void))]} @defsubform*[((planet id) (planet string) @@ -638,27 +609,22 @@ corresponds to the default @tech{module name resolver}. identifiers in a minor-version constraint are recognized symbolically. - Example: Load main.ss file package foo owned by bar. - - @scheme[(require (planet bar/foo))] - - Example: Load major version 2 of main.ss file package foo owned by bar. - - @scheme[(require (planet bar/foo:2))] - - Example: Load major version 2 and minor version 5 of main.ss file package foo owned by bar. - - @scheme[(require (planet bar/foo:2:5))] - - Example: Load major version 2 and minor version 5 of buz.ss file package foo owned by bar. - - @scheme[(require (planet bar/foo:2:5/buz))]} + @examples[ + (code:comment #, @t{@filepath{main.ss} in package @filepath{farm} by @filepath{mcdonald}:}) + (eval:alts (require (planet mcdonald/farm)) (void)) + (code:comment #, @t{@filepath{main.ss} in version >= 2.0 of package @filepath{farm} by @filepath{mcdonald}:}) + (eval:alts (require (planet mcdonald/farm:2)) (void)) + (code:comment #, @t{@filepath{main.ss} in version >= 2.5 of package @filepath{farm} by @filepath{mcdonald}:}) + (eval:alts (require (planet mcdonald/farm:2:5)) (void)) + (code:comment #, @t{@filepath{duck.ss} in version >= 2.5 of package @filepath{farm} by @filepath{mcdonald}:}) + (eval:alts (require (planet mcdonald/farm:2:5/duck)) (void)) + ]} No identifier can be bound multiple times in a given @tech{phase level} by an import, unless all of the bindings refer to the same original definition in the same module. In a @tech{module context}, an identifier can be either imported or defined for a given -@tech{phase level}, but not both.} +@tech{phase level}, but not both.}} @guideintro["module-provide"]{@scheme[provide]} @@ -704,11 +670,11 @@ follows. ambiguous). @defexamples[#:eval (syntax-eval) - (module test scheme - (provide foo) - (define foo 2)) - (require 'test) - foo + (module nest scheme + (provide num-eggs) + (define num-eggs 2)) + (require 'nest) + num-eggs ] If @scheme[id] has a transformer binding to a @tech{rename @@ -730,11 +696,11 @@ follows. @scheme[(all-defined-out)] form was introduced at the same time. @defexamples[#:eval (syntax-eval) - (module test scheme + (module nest scheme (provide (all-defined-out)) - (define foo 2)) - (require 'test) - foo + (define num-eggs 2)) + (require 'nest) + num-eggs ]} @defsubform[(all-from-out module-path ...)]{ Exports all identifiers @@ -749,14 +715,14 @@ follows. @scheme[module-path] was introduced at the same time. @defexamples[#:eval (syntax-eval) - (module a scheme - (provide foo) - (define foo 2)) - (module b scheme - (require 'a) - (provide (all-from-out 'a))) - (require 'b) - foo + (module nest scheme + (provide num-eggs) + (define num-eggs 2)) + (module hen-house scheme + (require 'nest) + (provide (all-from-out 'nest))) + (require 'hen-house) + num-eggs ]} @defsubform[(rename-out [orig-id export-id] ...)]{ Exports each @@ -765,12 +731,12 @@ follows. @scheme[export-id] instead @scheme[orig-d]. @defexamples[#:eval (syntax-eval) - (module a scheme - (provide (rename-out (foo myfoo))) - (define foo 2)) - (require 'a) - foo - myfoo + (module nest scheme + (provide (rename-out [count num-eggs])) + (define count 2)) + (require 'nest) + num-eggs + count ]} @defsubform[(except-out provide-spec provide-spec ...)]{ Like the @@ -781,14 +747,14 @@ follows. @scheme[provide-spec]s is ignored; only the bindings are used. @defexamples[#:eval (syntax-eval) - (module a scheme + (module nest scheme (provide (except-out (all-defined-out) - bar)) - (define foo 2) - (define bar 3)) - (require 'a) - foo - bar + num-chicks)) + (define num-eggs 2) + (define num-chicks 3)) + (require 'nest) + num-eggs + num-chicks ]} @defsubform[(prefix-out prefix-id provide-spec)]{ @@ -796,11 +762,11 @@ follows. @scheme[provide-spec] prefixed with @scheme[prefix-id]. @defexamples[#:eval (syntax-eval) - (module a scheme - (provide (prefix-out f: foo)) - (define foo 2)) - (require 'a) - f:foo + (module nest scheme + (provide (prefix-out chicken: num-eggs)) + (define num-eggs 2)) + (require 'nest) + chicken:num-eggs ]} @defsubform[(struct-out id)]{Exports the bindings associated with a @@ -818,28 +784,24 @@ follows. included by @scheme[struct-out] for export. @defexamples[#:eval (syntax-eval) - (module a scheme - (provide (struct-out foo)) - (define-struct foo (a b c))) - (require 'a) - make-foo - foo-a - foo-b - foo-c - foo? + (module nest scheme + (provide (struct-out egg)) + (define-struct egg (color wt))) + (require 'nest) + (egg-color (make-egg 'blue 10)) ]} @defsubform[(combine-out provide-spec ...)]{ The union of the @scheme[provide-spec]s. @defexamples[#:eval (syntax-eval) - (module a scheme - (provide (combine-out foo bar)) - (define foo 2) - (define bar 1)) - (require 'a) - foo - bar + (module nest scheme + (provide (combine-out num-eggs num-chicks)) + (define num-eggs 2) + (define num-chicks 1)) + (require 'nest) + num-eggs + num-chicks ]} @defsubform[(protect-out provide-spec ...)]{ Like the union of the @@ -847,31 +809,19 @@ follows. @secref["modprotect"]. The @scheme[provide-spec] must specify only bindings that are defined within the exporting module. - @defexamples[#:eval (syntax-eval) - (module a scheme - (provide (protect-out foo)) - (define foo 1)) + @examples[#:eval (syntax-eval) + (module nest scheme + (provide num-eggs (protect-out num-chicks)) + (define num-eggs 2) + (define num-chicks 3)) (define weak-inspector (make-inspector (current-code-inspector))) (define (weak-eval x) (parameterize ([current-code-inspector weak-inspector]) (eval x))) - (require 'a) - foo - (weak-eval 'foo) - ] - - Note that @scheme[require] works within eval as well. - @defexamples[#:eval (syntax-eval) - (module a scheme - (provide (protect-out foo)) - (define foo 1)) - (define weak-inspector (make-inspector (current-code-inspector))) - (define (weak-eval x) - (parameterize ([current-code-inspector weak-inspector]) - (eval x))) - (weak-eval '(require 'a)) - foo - (weak-eval 'foo) + (require 'nest) + (list num-eggs num-chicks) + (weak-eval 'num-eggs) + (weak-eval 'num-chicks) ]} @specsubform[#:literals (for-meta) @@ -1020,21 +970,7 @@ context of the @scheme[phaseless-spec] form.} @note-lib-only[scheme/require] The following forms support more complex selection and manipulation of -sets of imported identifiers. Note that a @scheme[require] form is -expanded before it is used, which means that requiring the library -itself should be a separate form. For example, use - -@schemeblock[ - (require scheme/require) - (require (matching-identifiers-in #rx"foo" "foo.ss")) -] - -instead of - -@schemeblock[ - (require scheme/require - (matching-identifiers-in #rx"foo" "foo.ss")) -] +sets of imported identifiers. @defform[(matching-identifiers-in regexp require-spec)]{ Like @scheme[require-spec], but including only imports whose names match @@ -2364,3 +2300,7 @@ than a precise prose description: [(nest ([form forms ...] . more) body0 body ...) (form forms ... (nest more body0 body ...))])) ]} + + +@close-eval[require-eval] +@close-eval[meta-in-eval] From f3a50081767182ab0ae911df3b7e6e3b149d0a29 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2009 16:32:02 +0000 Subject: [PATCH 125/140] typo svn: r14238 --- collects/scribblings/reference/syntax.scrbl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index ad02549294..2ad8fe3c0a 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -434,7 +434,7 @@ pre-defined forms are as follows. for information on expanding the set of @scheme[require-spec] forms. When multiple @scheme[require-spec]s are specified in a @scheme[require], the bindings of each @scheme[require-spec] are - vsible for expanding later @scheme[require-spec]s.} + visible for expanding later @scheme[require-spec]s.} @guideintro["module-paths"]{module paths} From 31e1057128d17f807bc31ba810413b6722330d75 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2009 16:38:21 +0000 Subject: [PATCH 126/140] aother refinement to note on require sub-form expansion svn: r14239 --- collects/scribblings/reference/syntax.scrbl | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index 2ad8fe3c0a..3f25fb23c0 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -277,8 +277,7 @@ In a @tech{top-level context}, @scheme[require] instantiates modules @scheme[require] @tech{visits} modules (see @secref["mod-parse"]). In both contexts, @scheme[require] introduces bindings into a @tech{namespace} or a module (see @secref["intro-binding"]). - A -@scheme[require] form in a @tech{expression context} or +A @scheme[require] form in a @tech{expression context} or @tech{internal-definition context} is a syntax error. A @scheme[require-spec] designates a particular set of identifiers to @@ -289,8 +288,11 @@ identifier. Each identifier also binds at a particular @tech{phase level}. The syntax of @scheme[require-spec] can be extended via -@scheme[define-require-syntax], but the -pre-defined forms are as follows. +@scheme[define-require-syntax], and when multiple +@scheme[require-spec]s are specified in a @scheme[require], the +bindings of each @scheme[require-spec] are visible for expanding later +@scheme[require-spec]s. The pre-defined forms (as exported by +@scheme[scheme/base]) are as follows: @specsubform[module-path]{ Imports all exported bindings from the named module, using the export identifiers as the local identifiers. @@ -432,9 +434,7 @@ pre-defined forms are as follows. @specsubform[derived-require-spec]{See @scheme[define-require-syntax] for information on expanding the set of @scheme[require-spec] - forms. When multiple @scheme[require-spec]s are specified in a - @scheme[require], the bindings of each @scheme[require-spec] are - visible for expanding later @scheme[require-spec]s.} + forms.} @guideintro["module-paths"]{module paths} @@ -998,7 +998,7 @@ sets of imported identifiers. #rx"-" (string-titlecase name) ""))) scheme/base))] will get the @scheme[scheme/base] bindings that match the regexp, - and renamed to use ``camel case''.} + and renamed to use ``camel case.''} @; -------------------- From 6108dc873cb9c07a86f64fb20ef6b5f89f3c79ab Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Mar 2009 17:25:57 +0000 Subject: [PATCH 127/140] Types for `scheme/path', from Harsha. svn: r14240 --- collects/typed-scheme/private/base-env.ss | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 7f3ee7e562..4579ee344f 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -576,3 +576,18 @@ [real->decimal-string (N [-Nat] . ->opt . -String)] [current-continuation-marks (-> -Cont-Mark-Set)] + +;; path.ss + +[explode-path (-Pathlike . -> . (-lst (Un -Path (-val 'up) (-val 'same))))] +[find-relative-path (-Pathlike -Pathlike . -> . -Path)] +[simple-form-path (-Pathlike . -> . -Path)] +[normalize-path (cl->* (-Pathlike . -> . -Path) + (-Pathlike -Pathlike . -> . -Path))] +[filename-extension (-Pathlike . -> . (-opt -Bytes))] +[file-name-from-path (-Pathlike . -> . (-opt -Path))] +[path-only (-Pathlike . -> . -Path)] +[some-system-path->string (-Path . -> . -String)] +[string->some-system-path + (-String (Un (-val 'unix) (-val 'windows)) . -> . -Path)] + From 60e096913d18554592f4dd6e024d3f58cc94b88e Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Mon, 23 Mar 2009 18:29:07 +0000 Subject: [PATCH 128/140] First step to polymorphic functions in typed/untyped interface - poly/c contract from Carl/Stevie - generate the contracts - test - use in typed/srfi/14 svn: r14241 --- .../tests/typed-scheme/fail/bad-map-poly.ss | 15 ++++ .../typed-scheme/private/type-contract.ss | 33 +++++---- collects/typed-scheme/utils/poly-c.ss | 70 +++++++++++++++++++ collects/typed-scheme/utils/utils.ss | 1 + collects/typed/srfi/14.ss | 33 ++++----- 5 files changed, 124 insertions(+), 28 deletions(-) create mode 100644 collects/tests/typed-scheme/fail/bad-map-poly.ss create mode 100644 collects/typed-scheme/utils/poly-c.ss diff --git a/collects/tests/typed-scheme/fail/bad-map-poly.ss b/collects/tests/typed-scheme/fail/bad-map-poly.ss new file mode 100644 index 0000000000..280bd9bc54 --- /dev/null +++ b/collects/tests/typed-scheme/fail/bad-map-poly.ss @@ -0,0 +1,15 @@ +#; +(exn-pred exn:fail:contract? ".*interface for bad-map.*") +#lang scheme/load + +(module bad-map scheme + (provide bad-map) + (define (bad-map f l) + (list (f 'quux)))) + +(module use-bad-map typed-scheme + (require/typed 'bad-map + [bad-map (All (A B) ((A -> B) (Listof A) -> (Listof B)))]) + (bad-map add1 (list 12 13 14))) + +(require 'use-bad-map) diff --git a/collects/typed-scheme/private/type-contract.ss b/collects/typed-scheme/private/type-contract.ss index da0990418e..b74c331316 100644 --- a/collects/typed-scheme/private/type-contract.ss +++ b/collects/typed-scheme/private/type-contract.ss @@ -20,7 +20,7 @@ mzlib/trace scheme/list (only-in scheme/contract -> ->* case-> cons/c flat-rec-contract provide/contract any/c) - (for-template scheme/base scheme/contract (only-in scheme/class object% is-a?/c subclass?/c))) + (for-template scheme/base scheme/contract (utils poly-c) (only-in scheme/class object% is-a?/c subclass?/c))) (define (define/fixup-contract? stx) (or (syntax-property stx 'typechecker:contract-def) @@ -54,7 +54,9 @@ (define (type->contract ty fail) (define vars (make-parameter '())) (let/cc exit - (let t->c ([ty ty]) + (let loop ([ty ty] [pos? #t]) + (define (t->c t) (loop t pos?)) + (define (t->c/neg t) (loop t (not pos?))) (match ty [(or (App: _ _ _) (Name: _)) (t->c (resolve-once ty))] [(Univ:) #'any/c] @@ -74,13 +76,13 @@ (define-values (dom* rngs* rst) (match a [(arr: dom (Values: rngs) #f #f '() _ _) - (values (map t->c dom) (map t->c rngs) #f)] + (values (map t->c/neg dom) (map t->c rngs) #f)] [(arr: dom rng #f #f '() _ _) - (values (map t->c dom) (list (t->c rng)) #f)] + (values (map t->c/neg dom) (list (t->c rng)) #f)] [(arr: dom (Values: rngs) rst #f '() _ _) - (values (map t->c dom) (map t->c rngs) (t->c rst))] + (values (map t->c/neg dom) (map t->c rngs) (t->c/neg rst))] [(arr: dom rng rst #f '() _ _) - (values (map t->c dom) (list (t->c rng)) (t->c rst))])) + (values (map t->c/neg dom) (list (t->c rng)) (t->c/neg rst))])) (with-syntax ([(dom* ...) dom*] [rng* (match rngs* @@ -102,12 +104,22 @@ #`(cons/c #,(t->c t1) #,(t->c t2))] [(Opaque: p? cert) #`(flat-contract #,(cert p?))] - [(F: v) (cond [(assoc v (vars)) => cadr] + [(F: v) (cond [(assoc v (vars)) => (if pos? second third)] [else (int-err "unknown var: ~a" v)])] + [(Poly: vs (and b (Function: _))) + (match-let ([(Poly-names: vs-nm _) ty]) + (with-syntax ([(vs+ ...) (generate-temporaries (for/list ([v vs-nm]) (symbol-append v '+)))] + [(vs- ...) (generate-temporaries (for/list ([v vs-nm]) (symbol-append v '-)))]) + (parameterize ([vars (append (map list + vs + (syntax->list #'(vs+ ...)) + (syntax->list #'(vs- ...))) + (vars))]) + #`(poly/c ([vs- vs+] ...) #,(t->c b)))))] [(Mu: n b) (match-let ([(Mu-name: n-nm _) ty]) (with-syntax ([(n*) (generate-temporaries (list n-nm))]) - (parameterize ([vars (cons (list n #'n*) (vars))]) + (parameterize ([vars (cons (list n #'n* #'n*) (vars))]) #`(flat-rec-contract n* #,(t->c b)))))] [(Value: #f) #'false/c] [(Instance: _) #'(is-a?/c object%)] @@ -115,10 +127,7 @@ [(Value: '()) #'null?] [(Struct: _ _ _ _ #f pred? cert) (cert pred?)] [(Syntax: (Base: 'Symbol _)) #'identifier?] - [(Syntax: t) - (if (equal? ty Any-Syntax) - #`syntax? - #`(syntax/c #,(t->c t)))] + [(Syntax: t) #`(syntax/c #,(t->c t))] [(Value: v) #`(flat-named-contract #,(format "~a" v) (lambda (x) (equal? x '#,v)))] [(Param: in out) #`(parameter/c #,(t->c out))] [(Hashtable: k v) #`hash?] diff --git a/collects/typed-scheme/utils/poly-c.ss b/collects/typed-scheme/utils/poly-c.ss new file mode 100644 index 0000000000..695a85dc50 --- /dev/null +++ b/collects/typed-scheme/utils/poly-c.ss @@ -0,0 +1,70 @@ +#lang scheme/base + +(require scheme/contract (for-syntax scheme/base)) + +(provide memory/c apply/c poly/c) + +(with-contract + poly-internals + ([memory/c + (->* + [] + [ #:name any/c + #:to any/c + #:from any/c + #:weak boolean? + #:equal (or/c 'eq 'eqv 'equal) + #:table (-> (and/c hash? (not/c immutable?))) ] + (values flat-contract? flat-contract?))] + [apply/c (->* [any/c] [#:name any/c] contract?)]) + + (define (memory/c + #:name [name "memory/c"] + #:to [to (format "~a:to" name)] + #:from [from (format "~a:from" name)] + #:weak [weak? #t] + #:equal [equal 'eq] + #:table [make-table + (case equal + [(eq) (if weak? make-weak-hasheq make-hasheq)] + [(eqv) (if weak? make-weak-hasheqv make-hasheqv)] + [(equal) (if weak? make-weak-hash make-hash)])]) + (let* ([table (make-table)]) + (values + (flat-named-contract from + (lambda (v) (hash-set! table v #t) #t)) + (flat-named-contract to + (lambda (v) (hash-ref table v #f)))))) + + (define (apply/c c + #:name [name (build-compound-type-name 'apply/c c)]) + (make-proj-contract + name + (lambda (pos neg src name2) + (lambda (p) + (let* ([ctc (coerce-contract 'apply/c c)] + [thunk (lambda () ((((proj-get ctc) ctc) pos neg src name2) p))]) + (make-keyword-procedure + (lambda (keys vals . args) (keyword-apply (thunk) keys vals args)) + (case-lambda + [() ((thunk))] + [(a) ((thunk) a)] + [(a b) ((thunk) a b)] + [(a b c) ((thunk) a b c)] + [(a b c d) ((thunk) a b c d)] + [(a b c d e) ((thunk) a b c d e)] + [(a b c d e f) ((thunk) a b c d e f)] + [(a b c d e f g) ((thunk) a b c d e f g)] + [(a b c d e f g h) ((thunk) a b c d e f g h)] + [args (apply (thunk) args)]))))) + procedure?))) + +(define-syntax (poly/c stx) + (syntax-case stx () + [(_ opts ... ([c- c+] ...) c) + (quasisyntax/loc stx + (apply/c + #:name (quote #,stx) + (recursive-contract + (let-values ([(c- c+) (memory/c #:from 'c- #:to 'c+ opts ...)] ...) + c))))])) diff --git a/collects/typed-scheme/utils/utils.ss b/collects/typed-scheme/utils/utils.ss index 485bc20b7f..d90e27ee33 100644 --- a/collects/typed-scheme/utils/utils.ss +++ b/collects/typed-scheme/utils/utils.ss @@ -19,6 +19,7 @@ extend debug in-syntax + symbol-append ;; require macros rep utils typecheck infer env private) diff --git a/collects/typed/srfi/14.ss b/collects/typed/srfi/14.ss index 4867007896..4c656e913a 100644 --- a/collects/typed/srfi/14.ss +++ b/collects/typed/srfi/14.ss @@ -91,23 +91,28 @@ [char-set:ascii Char-Set] [char-set:empty Char-Set] [char-set:full Char-Set] + [char-set-fold (All (A) ((Char A -> A) A Char-Set -> A))] + [char-set-unfold + (All (A) + (case-lambda + ((A -> Any) (A -> Char) (A -> A) A -> Char-Set) + ((A -> Any) (A -> Char) (A -> A) A Char-Set -> Char-Set)))] + [char-set-unfold! + (All (A) ((A -> Any) (A -> Char) (A -> A) A Char-Set -> Char-Set))] + [char-set-for-each (All (A) ((Char -> A) Char-Set -> (U A Void)))] + [char-set-any (All (A) ((Char -> A) Char-Set -> (U A #f)))] + [char-set-every (All (A) ((Char -> A) Char-Set -> (U A Boolean)))] ) ; end of require/typed ;; Definitions provided here for polymorphism - -(: char-set-fold (All (A) ((Char A -> A) A Char-Set -> A))) +#; (define (char-set-fold comb base cs) (let loop ((c (char-set-cursor cs)) (b base)) (cond [(end-of-char-set? c) b] [else (loop (char-set-cursor-next cs c) (comb (char-set-ref cs c) b))]))) - -(: char-set-unfold - (All (A) - (case-lambda - ((A -> Any) (A -> Char) (A -> A) A -> Char-Set) - ((A -> Any) (A -> Char) (A -> A) A Char-Set -> Char-Set)))) +#; (define char-set-unfold (pcase-lambda: (A) [([p : (A -> Any)] [f : (A -> Char)] [g : (A -> A)] [seed : A]) @@ -115,29 +120,25 @@ [([p : (A -> Any)] [f : (A -> Char)] [g : (A -> A)] [seed : A] [base-cs : Char-Set]) (char-set-unfold! p f g seed (char-set-copy base-cs))])) - -(: char-set-unfold! - (All (A) ((A -> Any) (A -> Char) (A -> A) A Char-Set -> Char-Set))) +#; (define (char-set-unfold! p f g seed base-cs) (let lp ((seed seed) (cs base-cs)) (if (p seed) cs ; P says we are done. (lp (g seed) ; Loop on (G SEED). (char-set-adjoin! cs (f seed)))))) -(: char-set-for-each (All (A) ((Char -> A) Char-Set -> (U A Void)))) +#; (define (char-set-for-each f cs) (char-set-fold (lambda: ([c : Char] [b : (U A Void)]) (f c)) (void) cs)) - -(: char-set-any (All (A) ((Char -> A) Char-Set -> (U A #f)))) +#; (define (char-set-any pred cs) (let loop ((c (char-set-cursor cs))) (and (not (end-of-char-set? c)) (or (pred (char-set-ref cs c)) (loop (char-set-cursor-next cs c)))))) - -(: char-set-every (All (A) ((Char -> A) Char-Set -> (U A Boolean)))) +#; (define (char-set-every pred cs) (let loop ((c (char-set-cursor cs)) (b (ann #t (U #t A)))) (cond [(end-of-char-set? c) b] From c656a658e9852b8f6e974db31304fba016dc9444 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2009 18:49:03 +0000 Subject: [PATCH 129/140] doc xform Scheme API a provided by Will Farr (PR 10151) svn: r14242 --- collects/scribblings/mzc/cc.scrbl | 30 +++++++++++++++++++++++++++++- 1 file changed, 29 insertions(+), 1 deletion(-) diff --git a/collects/scribblings/mzc/cc.scrbl b/collects/scribblings/mzc/cc.scrbl index cc5e7d2b03..6e9c005a89 100644 --- a/collects/scribblings/mzc/cc.scrbl +++ b/collects/scribblings/mzc/cc.scrbl @@ -1,6 +1,8 @@ #lang scribble/doc @(require scribble/manual - (for-label scheme/base) + (for-label scheme/base + compiler/xform + dynext/compile) "common.ss") @(define (xflag str) (as-index (DFlag str))) @@ -55,3 +57,29 @@ loaded into the 3m variant of PLT Scheme. The @as-index{@DFlag{cgc}} flag specifies that the extension is to be used with the CGC. The default depends on @|mzc|: @DFlag{3m} if @|mzc| itself is running in 3m, @DFlag{cgc} if @|mzc| itself is running in CGC. + + +@section[#:tag "xform-api"]{Scheme API for 3m Transformation} + +@defmodule[compiler/xform] + +@defproc[(xform [quiet? any/c] + [input-file path-string?] + [output-file path-string?] + [include-dirs (listof path-string?)] + [#:keep-lines? keep-lines? boolean? #f]) + any/c]{ + +Transforms C code that is written without explicit GC-cooperation +hooks to cooperate with PLT Scheme's 3m garbage collector; see +@secref[#:doc '(lib "scribblings/inside/inside.scrbl") "overview"] in +@other-manual['(lib "scribblings/inside/inside.scrbl")]. + +The arguments are as for @scheme[compile-extension]; in addition +@scheme[keep-lines?] can be @scheme[#t] to generate GCC-style +annotations to connect the generated C code with the original source +locations. + +The file generated by @scheme[xform] can be compiled via +@scheme[compile-extension].} + From 4dc66510699fbb3a81ad5d1425214d95e215a227 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2009 18:54:12 +0000 Subject: [PATCH 130/140] within mzscheme, use gcc noinline attribute on some stack-mangling functions svn: r14243 --- src/configure | 61 +++++++++++++++++++++++++++++++++++++ src/mzscheme/configure.ac | 16 +++++++++- src/mzscheme/mzconfig.h.in | 2 ++ src/mzscheme/src/fun.c | 11 +++++-- src/mzscheme/src/schpriv.h | 7 +++++ src/mzscheme/src/setjmpup.c | 8 +++-- src/mzscheme/src/thread.c | 5 +-- 7 files changed, 101 insertions(+), 9 deletions(-) diff --git a/src/configure b/src/configure index 5dd4a89108..715a606311 100755 --- a/src/configure +++ b/src/configure @@ -6038,6 +6038,67 @@ fi if test "$inline" = "no" ; then MZOPTIONS="$MZOPTIONS -DNO_INLINE_KEYWORD" +fi +{ echo "$as_me:$LINENO: result: $inline" >&5 +echo "${ECHO_T}$inline" >&6; } + + msg="for noinline attribute" +{ echo "$as_me:$LINENO: checking $msg" >&5 +echo $ECHO_N "checking $msg... $ECHO_C" >&6; } +if test "$cross_compiling" = yes; then + noinline=no +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +static int foo() __attribute__ ((noinline)); + static int foo() { return 0; } + int main() { + return foo(); + } +_ACEOF +rm -f conftest$ac_exeext +if { (ac_try="$ac_link" +case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_link") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && { ac_try='./conftest$ac_exeext' + { (case "(($ac_try" in + *\"* | *\`* | *\\*) ac_try_echo=\$ac_try;; + *) ac_try_echo=$ac_try;; +esac +eval "echo \"\$as_me:$LINENO: $ac_try_echo\"") >&5 + (eval "$ac_try") 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + noinline=yes +else + echo "$as_me: program exited with status $ac_status" >&5 +echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +( exit $ac_status ) +noinline=no +fi +rm -f core *.core core.conftest.* gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext +fi + + +if test "$noinline" = "yes" ; then + +cat >>confdefs.h <<\_ACEOF +#define MZ_USE_NOINLINE 1 +_ACEOF + fi { echo "$as_me:$LINENO: result: $inline" >&5 echo "${ECHO_T}$inline" >&6; } diff --git a/src/mzscheme/configure.ac b/src/mzscheme/configure.ac index e90eed7f25..55c680a812 100644 --- a/src/mzscheme/configure.ac +++ b/src/mzscheme/configure.ac @@ -722,12 +722,26 @@ AC_TRY_RUN( static inline int foo() { return 0; } int main() { return foo(); - }, inline=yes, inline=no, inline=no) + }, + inline=yes, inline=no, inline=no) if test "$inline" = "no" ; then MZOPTIONS="$MZOPTIONS -DNO_INLINE_KEYWORD" fi AC_MSG_RESULT($inline) +[ msg="for noinline attribute" ] +AC_MSG_CHECKING($msg) +AC_TRY_RUN( + static int foo() __attribute__ ((noinline)); + static int foo() { return 0; } + int main() { + return foo(); + }, noinline=yes, noinline=no, noinline=no) +if test "$noinline" = "yes" ; then + AC_DEFINE(MZ_USE_NOINLINE,1,[Have noinline attribute]) +fi +AC_MSG_RESULT($inline) + [ msg="for GNU preprocessor" ] AC_MSG_CHECKING($msg) AC_TRY_RUN( diff --git a/src/mzscheme/mzconfig.h.in b/src/mzscheme/mzconfig.h.in index 2d7056aacd..425fd7b2f3 100644 --- a/src/mzscheme/mzconfig.h.in +++ b/src/mzscheme/mzconfig.h.in @@ -32,5 +32,7 @@ /* Whether getaddrinfo works. */ #undef HAVE_GETADDRINFO +/* Whether __attribute__ ((noinline)) works */ +#undef MZ_USE_NOINLINE #endif diff --git a/src/mzscheme/src/fun.c b/src/mzscheme/src/fun.c index 74810fb41d..d1f95d53bc 100644 --- a/src/mzscheme/src/fun.c +++ b/src/mzscheme/src/fun.c @@ -1827,7 +1827,8 @@ typedef Scheme_Object *(*Overflow_K_Proc)(void); THREAD_LOCAL Scheme_Overflow_Jmp *scheme_overflow_jmp; THREAD_LOCAL void *scheme_overflow_stack_start; -/* private, but declared public to avoid inlining: */ +MZ_DO_NOT_INLINE(void scheme_really_create_overflow(void *stack_base)); + void scheme_really_create_overflow(void *stack_base) { Scheme_Overflow_Jmp *jmp; @@ -5747,7 +5748,9 @@ void scheme_drop_prompt_meta_continuations(Scheme_Object *prompt_tag) scheme_current_thread->meta_continuation = mc; } -/* private, but declared public to avoid inlining: */ +MZ_DO_NOT_INLINE(Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *_prompt_tag, + Scheme_Object *proc, int argc, Scheme_Object **argv)); + Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *_prompt_tag, Scheme_Object *proc, int argc, Scheme_Object **argv) { @@ -5887,7 +5890,9 @@ Scheme_Object *scheme_finish_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Obje } } -/* private, but declared public to avoid inlining: */ +MZ_DO_NOT_INLINE(Scheme_Object *scheme_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *prompt_tag, + Scheme_Object *proc, int argc, Scheme_Object **argv)); + Scheme_Object *scheme_apply_for_prompt(Scheme_Prompt *prompt, Scheme_Object *prompt_tag, Scheme_Object *proc, int argc, Scheme_Object **argv) { diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 7c9b7cc040..a37bd4b790 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -104,6 +104,13 @@ int scheme_num_types(void); # define SET_REQUIRED_TAG(e) /* empty */ #endif +#if MZ_USE_NOINLINE +# define MZ_DO_NOT_INLINE(decl) decl __attribute__ ((noinline)); +#else +# define MZ_DO_NOT_INLINE() +#endif + + void scheme_reset_finalizations(void); extern unsigned long scheme_get_current_os_thread_stack_base(void); diff --git a/src/mzscheme/src/setjmpup.c b/src/mzscheme/src/setjmpup.c index 8aad99bf14..57e3dca67b 100644 --- a/src/mzscheme/src/setjmpup.c +++ b/src/mzscheme/src/setjmpup.c @@ -325,7 +325,9 @@ void MZ_NO_INLINE scheme_copy_stack(Scheme_Jumpup_Buf *b, void *base, void *star size); } -static void uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev) +MZ_DO_NOT_INLINE(void scheme_uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev)); + +void scheme_uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev) { GC_CAN_IGNORE Scheme_Jumpup_Buf *c; long top_delta = 0, bottom_delta = 0, size; @@ -337,7 +339,7 @@ static void uncopy_stack(int ok, Scheme_Jumpup_Buf *b, long *prev) z = (unsigned long)&junk[0]; - uncopy_stack(STK_COMP(z, DEEPPOS(b)), b, junk); + scheme_uncopy_stack(STK_COMP(z, DEEPPOS(b)), b, junk); } /* Vague attempt to prevent the compiler from optimizing away `prev': */ @@ -619,7 +621,7 @@ void scheme_longjmpup(Scheme_Jumpup_Buf *b) scheme_flush_stack_cache(); #endif - uncopy_stack(STK_COMP((unsigned long)&z, DEEPPOS(b)), b, junk); + scheme_uncopy_stack(STK_COMP((unsigned long)&z, DEEPPOS(b)), b, junk); } void scheme_init_jmpup_buf(Scheme_Jumpup_Buf *b) diff --git a/src/mzscheme/src/thread.c b/src/mzscheme/src/thread.c index dde50e7cf7..4fff4b5ee6 100644 --- a/src/mzscheme/src/thread.c +++ b/src/mzscheme/src/thread.c @@ -3222,7 +3222,8 @@ static Scheme_Object *def_nested_exn_handler(int argc, Scheme_Object *argv[]) return scheme_void; /* misuse of exception handler (wrong kind of thread or under prompt) */ } -/* private, but declared as public to avoid inlining: */ +MZ_DO_NOT_INLINE(Scheme_Object *scheme_call_as_nested_thread(int argc, Scheme_Object *argv[], void *max_bottom)); + Scheme_Object *scheme_call_as_nested_thread(int argc, Scheme_Object *argv[], void *max_bottom) { Scheme_Thread *p = scheme_current_thread; @@ -3791,7 +3792,7 @@ static void raise_break(Scheme_Thread *p) p->external_break = 0; - if (p->blocker && (p->block_check == syncing_ready)) { + if (p->blocker && (p->block_check == (Scheme_Ready_Fun)syncing_ready)) { /* Get out of lines for channels, etc., before calling a break exn handler. */ scheme_post_syncing_nacks((Syncing *)p->blocker); } From 60bdcaed2580a754e67275d8011f72f65216b8d4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 23 Mar 2009 19:41:03 +0000 Subject: [PATCH 131/140] skip compiling deinprogramm tests svn: r14244 --- collects/tests/info.ss | 1 + 1 file changed, 1 insertion(+) diff --git a/collects/tests/info.ss b/collects/tests/info.ss index 05abf1ffb9..5fd8b6aad9 100644 --- a/collects/tests/info.ss +++ b/collects/tests/info.ss @@ -6,6 +6,7 @@ (define compile-omit-paths '("aligned-pasteboard" + "deinprogramm" "honu" "match" "macro-debugger" From 896018f96ba3276c199b9221d00f3d5605c8c10b Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Mon, 23 Mar 2009 23:04:30 +0000 Subject: [PATCH 132/140] remove support files when a test is done svn: r14245 --- collects/tests/scribble/main.ss | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/collects/tests/scribble/main.ss b/collects/tests/scribble/main.ss index 4fd6febb3e..8ef6019dc3 100644 --- a/collects/tests/scribble/main.ss +++ b/collects/tests/scribble/main.ss @@ -137,7 +137,9 @@ (t (with-limits 2 #f (if len-to-read (read-string len-to-read i) (port->string i))) => expected) - (t (begin (kill-thread thd) (cond [exn => raise] [else #t]))))) + (t (begin (kill-thread thd) (cond [exn => raise] [else #t]))) + (for ([m more]) + (when (file-exists? (car m)) (delete-file (car m)))))) (call-with-trusted-sandbox-configuration (lambda () (for ([t (in-list (doc:tests))]) From 1ac8f8b11391956f37870a262b4bf1aadf882096 Mon Sep 17 00:00:00 2001 From: Philippe Meunier Date: Tue, 24 Mar 2009 01:55:03 +0000 Subject: [PATCH 133/140] quaterly update svn: r14246 --- .../french-string-constants.ss | 49 ++++++++++++++----- 1 file changed, 38 insertions(+), 11 deletions(-) diff --git a/collects/string-constants/french-string-constants.ss b/collects/string-constants/french-string-constants.ss index 82fa1a4a66..1a699599b5 100644 --- a/collects/string-constants/french-string-constants.ss +++ b/collects/string-constants/french-string-constants.ss @@ -191,7 +191,8 @@ (cs-status-expanding-expression "Vérificateur de syntaxe : expansion d'une expression") (cs-status-loading-docs-index "Vérificateur de syntaxe : chargement de l'index de la documentation") (cs-mouse-over-import "l'identificateur ~s est importé de ~s") - (cs-view-docs "Regarder la documentation pour ~a") + (cs-view-docs "Documentation pour ~a") + (cs-view-docs-from "~a dans ~a") ;; a completed version of the line above (cs-view-docs) is put into the first ~a and a list of modules (separated by commas) is put into the second ~a. Use check syntax and right-click on a documented variable (eg, 'require') to see this in use (cs-lexical-variable "variables lexicales") (cs-imported-variable "variables importées") @@ -200,7 +201,7 @@ (collect-button-label "Ramassage") ; de miettes (read-only "Lecture seulement") (auto-extend-selection "Autosélection") ; "Sélection auto-étendable" ? - (overwrite "Correction") ; vs Insertion ? surimpression ? + (overwrite "Écrasement") ; vs Insertion ? surimpression ? (running "en cours") (not-running "en attente") ; "en attente" ; pause ? @@ -242,6 +243,11 @@ (erase-log-directory-contents "Effacer le contenu du répertoire d'enregistrement : ~a ?") (error-erasing-log-directory "Erreur durant l'effacement du contenu du répertoire d'enregistrement.\n\n~a\n") + ;; menu items connected to the logger -- also in a button in the planet status line in the drs frame + (show-log "Montrer le journa&l") ; "journaux" ne contient pas de "l"... + (hide-log "Cacher le journa&l") + (logging-all "Tous") ;; in the logging window in drscheme, shows all logs simultaneously + ;; modes (mode-submenu-label "Modes") (scheme-mode "Mode scheme") @@ -676,6 +682,9 @@ (complete-word "Compléter le mot") ; the complete word menu item in the edit menu (no-completions "... pas de complétion connue") ; shows up in the completions menu when there are no completions (in italics) + (overwrite-mode "Mode d'écrasement") + (enable-overwrite-mode-keybindings "Raccourci clavier pour le mode d'écrasement") + (preferences-info "Configurer vos préférences.") (preferences-menu-item "Préférences...") @@ -707,18 +716,21 @@ (wrap-text-item "Replier le texte") + ;; windows menu (windows-menu-label "Fe&nêtres") (minimize "Minimiser") ;; minimize and zoom are only used under mac os x (zoom "Agrandir") ; Zoomer? (bring-frame-to-front "Amener une fenêtre au premier plan") ;;; title of dialog (bring-frame-to-front... "Amener une fenêtre au premier plan...") ;;; corresponding title of menu item (most-recent-window "Fenêtre la plus récente") + (next-tab "Onglet suivant") + (prev-tab "Onglet précédent") (view-menu-label "&Montrer") - (show-overview "Montrer le contour") - (hide-overview "Cacher le contour") - (show-module-browser "Montrer le navigateur de modules") - (hide-module-browser "Cacher le navigateur de modules") + (show-overview "Montrer le contour du &programme") + (hide-overview "Cacher le contour du &programme") + (show-module-browser "Montrer le navigateur de &modules") + (hide-module-browser "Cacher le navigateur de &modules") (help-menu-label "&Aide") (about-info "Auteurs et détails concernant ce logiciel.") @@ -783,7 +795,7 @@ ;;; file modified warning (file-has-been-modified "Ce fichier a été modifié depuis sa dernière sauvegarde. Voulez-vous écraser les modifications ?") - (overwrite-file-button-label "Ecraser") + (overwrite-file-button-label "Écraser") (definitions-modified "Le texte de la fenêtre de définition a été modifié directement sur le disque dur. Sauvegardez ou retournez à la version sur le disque.") @@ -842,7 +854,7 @@ (close-tab "Fermer l'onglet") (close-tab-amp "Fermer l'onglet") ;; like close-tab, but with an ampersand on the same letter as the one in close-menu-item - ;;; edit-menu + ;;; edit menu (split-menu-item-label "Di&viser") (collapse-menu-item-label "&Rassembler") @@ -859,10 +871,10 @@ (force-quit-menu-item-help-string "Utilise custodian-shutdown-all pour terminer toute l'évaluation courante") (limit-memory-menu-item-label "Limiter la mémoire...") (limit-memory-msg-1 "La limite prendra effet à la prochaine exécution du programme.") - (limit-memory-msg-2 "Elle doit être d'au moins 1 megaoctet.") + (limit-memory-msg-2 "Elle doit être d'au moins un megaoctet.") (limit-memory-unlimited "Illimitée") - (limit-memory-limited "Limitée") - (limit-memory-megabytes "Megaoctets") + (limit-memory-limited "Limitée à") + (limit-memory-megabytes "megaoctets") (clear-error-highlight-menu-item-label "Effacer le surlignage d'erreur") (clear-error-highlight-item-help-string "Efface le surlignage rose après une erreur") (reindent-menu-item-label "&Réindenter") @@ -996,6 +1008,7 @@ (decimal-notation-for-rationals "Utiliser la notation décimale pour les nombres rationnels") (enforce-primitives-group-box-label "Définitions initiales") (enforce-primitives-check-box-label "Interdire la redéfinition des définition initiales") + (automatically-compile? "Compiler automatiquement les fichiers source ?") ; used in the bottom left of the drscheme frame as the label ; used the popup menu from the just above; greyed out and only @@ -1033,6 +1046,7 @@ (no-language-chosen "Aucun langage sélectionné") (module-language-one-line-summary "Exécuter crée une fenêtre d'interaction dans le contexte du module, incluant le langage du module lui-même") + (module-language-auto-text "Ligne #lang automatique") ;; shows up in the details section of the module language ;;; from the `not a language language' used initially in drscheme. (must-choose-language "DrScheme ne peut pas traiter un programme avant que vous aillez sélectionné un langage.") @@ -1423,5 +1437,18 @@ (bug-track-forget "Oublier") (bug-track-forget-all "Oublier tous") + ;; planet status messages in the bottom of the drscheme window; the ~a is filled with the name of the package + (planet-downloading "PLaneT: téléchargement de ~a...") + (planet-installing "PLaneT: installation de ~a...") + (planet-finished "PLaneT: ~a à jour.") + (planet-no-status "PLaneT") ;; this can happen when there is status shown in a different and then the user switches to a tab where planet hasn't been used + + ;; string normalization. To see this, paste some text with a ligature into DrScheme + ;; the first three strings are in the dialog that appears. The last one is in the preferences dialog + (normalize "Normaliser") + (leave-alone "Ne pas changer") + (normalize-string-info "La chaîne de caractères à coller contient des ligatures ou des caractères non-normalisés. Normaliser la chaîne ?") + (normalize-string-preference "Normaliser les chaînes de caractères durant le collage") + (ask-about-normalizing-strings "Demander à propos de la normalisation des chaînes de caractères") ); "aâàbcçdeéêèëfghiîïjklmnoôpqrstuûùüvwxyz" From 043ffccc913a22f457e6330a2dcfd4366c837dde Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Mar 2009 16:35:01 +0000 Subject: [PATCH 134/140] avoid png & zlib makefiles when libpng is enabled svn: r14248 --- src/configure | 6 +++++- src/mzscheme/configure.ac | 6 +++++- 2 files changed, 10 insertions(+), 2 deletions(-) diff --git a/src/configure b/src/configure index 715a606311..ae2482e643 100755 --- a/src/configure +++ b/src/configure @@ -12014,8 +12014,12 @@ if test "${enable_mred}" = "yes" ; then makefiles="$makefiles mred/Makefile mred/wxs/Makefile mred/wxme/Makefile - mred/gc2/Makefile + mred/gc2/Makefile" + + if test "${enable_libpng}" != "yes" ; then + makefiles="$makefiles wxcommon/libpng/Makefile wxcommon/zlib/Makefile" + fi if test "${enable_quartz}" = "yes" ; then makefiles="$makefiles diff --git a/src/mzscheme/configure.ac b/src/mzscheme/configure.ac index 55c680a812..87af1f2b53 100644 --- a/src/mzscheme/configure.ac +++ b/src/mzscheme/configure.ac @@ -1453,8 +1453,12 @@ if test "${enable_mred}" = "yes" ; then makefiles="$makefiles mred/Makefile mred/wxs/Makefile mred/wxme/Makefile - mred/gc2/Makefile + mred/gc2/Makefile" + + if test "${enable_libpng}" != "yes" ; then + makefiles="$makefiles wxcommon/libpng/Makefile wxcommon/zlib/Makefile" + fi if test "${enable_quartz}" = "yes" ; then makefiles="$makefiles From 7362da34a91afdf7c7ff5d886dd1abc33eebc248 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Mar 2009 16:36:16 +0000 Subject: [PATCH 135/140] JIT peephole-ish optimization to avoid unnecessary ajustments to the runstack register svn: r14249 --- src/mzscheme/src/jit.c | 349 +++++++++++++++++++++++++++++------------ 1 file changed, 248 insertions(+), 101 deletions(-) diff --git a/src/mzscheme/src/jit.c b/src/mzscheme/src/jit.c index bc6ae41b13..235c69cbb7 100644 --- a/src/mzscheme/src/jit.c +++ b/src/mzscheme/src/jit.c @@ -175,6 +175,7 @@ typedef struct { void *status_at_ptr; int reg_status; void *patch_depth; + int rs_virtual_offset; } mz_jit_state; #define mz_RECORD_STATUS(s) (jitter->status_at_ptr = _jit.x.pc, jitter->reg_status = (s)) @@ -690,6 +691,40 @@ static void *top4; # define VALIDATE_RESULT(reg) /* empty */ #endif +/* The mz_rs_... family of operations operate on a virtual + JIT_RUNSTACK register to perform a kind of peephole optimization. + The virtual register can be de-sync'd from the actual register, so + that multiple adjustments to the register can be collapsed; this + mostly improves code size, rather than speed. Functions that cause + the register to be de-sync'd are marked as such. Functions that can + accomodate a de-sync'd register on entry are marked as such. All + other fuctions can assume a sync'd regsiter and ensure a sync'd + register. Note that branches and calls normally require a sync'd + register. */ + +#if 1 +# define mz_rs_dec(n) (jitter->rs_virtual_offset -= (n)) +# define mz_rs_inc(n) (jitter->rs_virtual_offset += (n)) +# define mz_rs_ldxi(reg, n) jit_ldxi_p(reg, JIT_RUNSTACK, WORDS_TO_BYTES(((n) + jitter->rs_virtual_offset))) +# define mz_rs_ldr(reg) mz_rs_ldxi(reg, 0) +# define mz_rs_stxi(n, reg) jit_stxi_p(WORDS_TO_BYTES(((n) + jitter->rs_virtual_offset)), JIT_RUNSTACK, reg) +# define mz_rs_str(reg) mz_rs_stxi(0, reg) +# define mz_rs_sync() (jitter->rs_virtual_offset \ + ? (jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(jitter->rs_virtual_offset)), \ + jitter->rs_virtual_offset = 0) \ + : 0) +# define mz_rs_sync_0() (jitter->rs_virtual_offset = 0) +#else +# define mz_rs_dec(n) jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(n)) +# define mz_rs_inc(n) jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(n)) +# define mz_rs_ldr(reg) jit_ldr_p(reg, JIT_RUNSTACK) +# define mz_rs_ldxi(reg, n) jit_ldxi_p(reg, JIT_RUNSTACK, WORDS_TO_BYTES(n)) +# define mz_rs_str(reg) jit_str_p(JIT_RUNSTACK, reg) +# define mz_rs_stxi(n, reg) jit_stxi_p(WORDS_TO_BYTES(n), JIT_RUNSTACK, reg) +# define mz_rs_sync() /* empty */ +# define mz_rs_sync_0() /* empty */ +#endif + static void new_mapping(mz_jit_state *jitter) { jitter->num_mappings++; @@ -704,6 +739,7 @@ static void new_mapping(mz_jit_state *jitter) } static void mz_pushr_p_it(mz_jit_state *jitter, int reg) +/* de-sync's rs */ { int v; @@ -719,14 +755,15 @@ static void mz_pushr_p_it(mz_jit_state *jitter, int reg) v++; jitter->mappings[jitter->num_mappings] = ((v << 1) | 0x1); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW_NOCL(); - jit_str_p(JIT_RUNSTACK, reg); + mz_rs_str(reg); jitter->need_set_rs = 1; } static void mz_popr_p_it(mz_jit_state *jitter, int reg) +/* de-sync's rs */ { int v; @@ -740,8 +777,8 @@ static void mz_popr_p_it(mz_jit_state *jitter, int reg) else jitter->mappings[jitter->num_mappings] = ((v << 1) | 0x1); - jit_ldr_p(reg, JIT_RUNSTACK); - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_ldr(reg); + mz_rs_inc(1); jitter->need_set_rs = 1; } @@ -919,18 +956,21 @@ static int mz_is_closure(mz_jit_state *jitter, int i, int arity, int *_flags) } static int stack_safety(mz_jit_state *jitter, int cnt, int offset) +/* de-sync'd rs ok */ { /* To preserve space safety, we must initialize any stack room that we make, so that whatever happens to be there isn't - traversed in case of a GC. */ + traversed in case of a GC. the value of JIT_RUNSTACK is + handy to use as a "clear" value. */ int i; for (i = 0; i < cnt; i++) { - jit_stxi_p(WORDS_TO_BYTES(i+offset), JIT_RUNSTACK, JIT_RUNSTACK); + mz_rs_stxi(i+offset, JIT_RUNSTACK); CHECK_LIMIT(); } return 1; } +/* de-sync's rs: */ #define mz_pushr_p(x) mz_pushr_p_it(jitter, x) #define mz_popr_p(x) mz_popr_p_it(jitter, x) @@ -2380,6 +2420,7 @@ static int generate_self_tail_call(Scheme_Object *rator, mz_jit_state *jitter, i jit_stxi_p(WORDS_TO_BYTES(num_rands - 1), JIT_RUNSTACK, JIT_R0); generate(rator, jitter, 0, 0, JIT_V1); CHECK_LIMIT(); + mz_rs_sync(); (void)jit_jmpi(slow_code); @@ -2560,6 +2601,7 @@ static int can_direct_native(Scheme_Object *p, int num_rands, long *extract_case static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_rands, mz_jit_state *jitter, int is_tail, int multi_ok, int no_call) +/* de-sync'd ok */ { int i, offset, need_safety = 0; int direct_prim = 0, need_non_tail = 0, direct_native = 0, direct_self = 0, nontail_self = 0; @@ -2696,7 +2738,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ if (num_rands) { if (!direct_prim || (num_rands > 1)) { - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(num_rands)); + mz_rs_dec(num_rands); need_safety = num_rands; CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, num_rands); @@ -2726,7 +2768,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ need_safety = 0; } - generate_non_tail(rator, jitter, 0, !need_non_tail); + generate_non_tail(rator, jitter, 0, !need_non_tail); /* sync'd after args below */ CHECK_LIMIT(); if (num_rands) { @@ -2742,7 +2784,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ jit_movr_p(JIT_V1, JIT_R0); proc_already_in_place = 1; } else { - jit_stxi_p(WORDS_TO_BYTES(num_rands - 1 + offset), JIT_RUNSTACK, JIT_R0); + mz_rs_stxi(num_rands - 1 + offset, JIT_R0); if (need_safety) need_safety--; } @@ -2750,6 +2792,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ jit_movr_p(JIT_V1, JIT_R0); } } + /* not sync'd...*/ for (i = 0; i < num_rands; i++) { PAUSE_JIT_DATA(); @@ -2761,18 +2804,19 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ CHECK_LIMIT(); need_safety = 0; } - generate_non_tail(arg, jitter, 0, !need_non_tail); + generate_non_tail(arg, jitter, 0, !need_non_tail); /* sync'd below */ RESUME_JIT_DATA(); CHECK_LIMIT(); if ((i == num_rands - 1) && !direct_prim && !reorder_ok && !direct_self && !proc_already_in_place) { /* Move rator back to register: */ - jit_ldxi_p(JIT_V1, JIT_RUNSTACK, WORDS_TO_BYTES(i + offset)); + mz_rs_ldxi(JIT_V1, i + offset); } if ((!direct_prim || (num_rands > 1)) && (!direct_self || !is_tail || no_call || (i + 1 < num_rands))) { - jit_stxi_p(WORDS_TO_BYTES(i + offset), JIT_RUNSTACK, JIT_R0); + mz_rs_stxi(i + offset, JIT_R0); } } + /* not sync'd... */ if (need_non_tail) { /* Uses JIT_R2: */ @@ -2786,6 +2830,7 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ if (num_rands == 1) { mz_runstack_unskipped(jitter, 1); } else { + mz_rs_sync(); JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); } LOG_IT(("direct: %s\n", ((Scheme_Primitive_Proc *)rator)->name)); @@ -2793,11 +2838,14 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_ } if (reorder_ok) { - if (!no_call) - generate(rator, jitter, 0, 0, JIT_V1); + if (!no_call) { + generate(rator, jitter, 0, 0, JIT_V1); /* sync'd below */ + } CHECK_LIMIT(); } + mz_rs_sync(); + END_JIT_DATA(20); if (direct_prim || direct_native || direct_self || nontail_self) @@ -3191,6 +3239,7 @@ static int generate_double_arith(mz_jit_state *jitter, int arith, int cmp, int r static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Object *rand, Scheme_Object *rand2, int orig_args, int arith, int cmp, int v, jit_insn **for_branch, int branch_short) +/* needs de-sync */ /* Either arith is non-zero or it's a cmp; the value of each determines the operation: arith = 1 -> + or add1 (if !rand2) arith = -1 -> - or sub1 @@ -3279,28 +3328,31 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj if (rand2 && !simple_rand && !simple_rand2) { mz_runstack_skipped(jitter, 1); - generate_non_tail(rand, jitter, 0, 1); + generate_non_tail(rand, jitter, 0, 1); /* sync'd later */ CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, 1); - jit_str_p(JIT_RUNSTACK, JIT_R0); + mz_rs_str(JIT_R0); } + /* not sync'd... */ if (simple_rand2) { if (SAME_TYPE(SCHEME_TYPE(rand), scheme_local_type)) - generate(rand, jitter, 0, 0, JIT_R1); + generate(rand, jitter, 0, 0, JIT_R1); /* sync'd below */ else { - generate_non_tail(rand, jitter, 0, 1); + generate_non_tail(rand, jitter, 0, 1); /* sync'd below */ + CHECK_LIMIT(); jit_movr_p(JIT_R1, JIT_R0); } CHECK_LIMIT(); - generate(rand2, jitter, 0, 0, JIT_R0); + generate(rand2, jitter, 0, 0, JIT_R0); /* sync'd below */ } else { - generate_non_tail(rand2 ? rand2 : rand, jitter, 0, 1); + generate_non_tail(rand2 ? rand2 : rand, jitter, 0, 1); /* sync'd below */ } CHECK_LIMIT(); + /* sync'd in three branches below */ if (arith == -2) { if (rand2 || (v != 1) || reversed) @@ -3318,13 +3370,15 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } else { if (simple_rand) { pos = mz_remap(SCHEME_LOCAL_POS(rand)); - jit_ldxi_p(JIT_R1, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + mz_rs_ldxi(JIT_R1, pos); } /* check both fixnum bits at once by ANDing into R2: */ jit_andr_ul(JIT_R2, JIT_R0, JIT_R1); va = JIT_R2; } + mz_rs_sync(); + __START_TINY_JUMPS__(1); ref2 = jit_bmsi_ul(jit_forward(), va, 0x1); __END_TINY_JUMPS__(1); @@ -3352,10 +3406,12 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj CHECK_LIMIT(); } else if (rand2) { /* Move rand result back into R1 */ - jit_ldr_p(JIT_R1, JIT_RUNSTACK); - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_ldr(JIT_R1); + mz_rs_inc(1); mz_runstack_popped(jitter, 1); + mz_rs_sync(); + /* check both fixnum bits at once by ANDing into R2: */ jit_andr_ul(JIT_R2, JIT_R0, JIT_R1); __START_TINY_JUMPS__(1); @@ -3386,6 +3442,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj } CHECK_LIMIT(); } else { + mz_rs_sync(); /* Only one argument: */ __START_TINY_JUMPS__(1); ref2 = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); @@ -3731,6 +3788,7 @@ static int generate_arith(mz_jit_state *jitter, Scheme_Object *rator, Scheme_Obj static int generate_inlined_constant_test(mz_jit_state *jitter, Scheme_App2_Rec *app, Scheme_Object *cnst, Scheme_Object *cnst2, jit_insn **for_branch, int branch_short) +/* de-sync'd ok */ { GC_CAN_IGNORE jit_insn *ref, *ref2; @@ -3743,6 +3801,8 @@ static int generate_inlined_constant_test(mz_jit_state *jitter, Scheme_App2_Rec mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + __START_SHORT_JUMPS__(branch_short); if (cnst2) { @@ -3786,6 +3846,8 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + __START_SHORT_JUMPS__(branch_short); ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); @@ -3831,35 +3893,38 @@ static int generate_inlined_type_test(mz_jit_state *jitter, Scheme_App2_Rec *app static int generate_inlined_struct_op(int kind, mz_jit_state *jitter, Scheme_Object *rator, Scheme_Object *rand, jit_insn **for_branch, int branch_short) +/* de-sync'd ok; for branch, sync'd before */ { mz_runstack_skipped(jitter, 1); LOG_IT(("inlined struct op\n")); - generate(rator, jitter, 0, 0, JIT_R0); + generate(rator, jitter, 0, 0, JIT_R0); /* sync'd below */ CHECK_LIMIT(); if (SAME_TYPE(scheme_local_type, SCHEME_TYPE(rand))) { jit_movr_p(JIT_R1, JIT_R0); - generate(rand, jitter, 0, 0, JIT_R0); + generate(rand, jitter, 0, 0, JIT_R0); /* sync'd below */ mz_runstack_unskipped(jitter, 1); } else { mz_runstack_unskipped(jitter, 1); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, 1); - jit_str_p(JIT_RUNSTACK, JIT_R0); + mz_rs_str(JIT_R0); CHECK_LIMIT(); - generate_non_tail(rand, jitter, 0, 1); + generate_non_tail(rand, jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); - jit_ldr_p(JIT_R1, JIT_RUNSTACK); - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_ldr(JIT_R1); + mz_rs_inc(1); mz_runstack_popped(jitter, 1); } + mz_rs_sync(); + /* R1 is [potential] predicate/getter, R0 is value */ if (for_branch) { @@ -3880,6 +3945,7 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, int is_tail, int multi_ok, jit_insn **for_branch, int branch_short) +/* de-sync's, unless branch */ { Scheme_Object *rator = app->rator; @@ -3984,6 +4050,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + /* Jump ahead if it's a fixnum: */ __START_TINY_JUMPS__(1); ref = jit_bmsi_ul(jit_forward(), JIT_R0, 0x1); @@ -4055,6 +4123,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + __START_TINY_JUMPS__(1); if (steps > 1) { @@ -4118,6 +4188,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + __START_TINY_JUMPS__(1); ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); @@ -4154,6 +4226,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + __START_TINY_JUMPS__(1); ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); __END_TINY_JUMPS__(1); @@ -4184,6 +4258,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + __START_TINY_JUMPS__(1); ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); __END_TINY_JUMPS__(1); @@ -4210,6 +4286,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_unskipped(jitter, 1); + mz_rs_sync(); + (void)jit_calli(syntax_e_code); return 1; @@ -4242,6 +4320,7 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in mz_runstack_skipped(jitter, 1); generate_non_tail(app->rand, jitter, 0, 1); CHECK_LIMIT(); + mz_rs_sync(); mz_runstack_unskipped(jitter, 1); (void)jit_movi_p(JIT_R1, &scheme_null); return generate_cons_alloc(jitter, 0, 0); @@ -4250,7 +4329,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in generate_non_tail(app->rand, jitter, 0, 1); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); - + mz_rs_sync(); + #ifdef CAN_INLINE_ALLOC /* Inlined alloc */ (void)jit_movi_p(JIT_R1, NULL); /* needed because R1 is marked during a GC */ @@ -4283,7 +4363,8 @@ static int generate_inlined_unary(mz_jit_state *jitter, Scheme_App2_Rec *app, in } static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_state *jitter, int order_matters) -/* Results go into R0 and R1. If !order_matters, and if only the +/* de-sync's rs. + Results go into R0 and R1. If !order_matters, and if only the second is simple, then the arguments will be in reverse order. */ { int simple1, simple2, direction = 1; @@ -4295,11 +4376,11 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ if (simple2) { mz_runstack_skipped(jitter, 2); - generate_non_tail(rand1, jitter, 0, 1); + generate_non_tail(rand1, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); jit_movr_p(JIT_R1, JIT_R0); - generate(rand2, jitter, 0, 0, JIT_R0); + generate(rand2, jitter, 0, 0, JIT_R0); /* no sync... */ CHECK_LIMIT(); if (order_matters) { @@ -4313,39 +4394,39 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ mz_runstack_unskipped(jitter, 2); } else { mz_runstack_skipped(jitter, 2); - generate_non_tail(rand1, jitter, 0, 1); + generate_non_tail(rand1, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); mz_runstack_unskipped(jitter, 2); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, 1); - jit_str_p(JIT_RUNSTACK, JIT_R0); + mz_rs_str(JIT_R0); mz_runstack_skipped(jitter, 1); - generate_non_tail(rand2, jitter, 0, 1); + generate_non_tail(rand2, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); jit_movr_p(JIT_R1, JIT_R0); - jit_ldr_p(JIT_R0, JIT_RUNSTACK); + mz_rs_ldr(JIT_R0); mz_runstack_unskipped(jitter, 1); - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_inc(1); mz_runstack_popped(jitter, 1); } } else { mz_runstack_skipped(jitter, 2); if (simple2) { - generate(rand2, jitter, 0, 0, JIT_R1); + generate(rand2, jitter, 0, 0, JIT_R1); /* no sync... */ CHECK_LIMIT(); } else { - generate_non_tail(rand2, jitter, 0, 1); + generate_non_tail(rand2, jitter, 0, 1); /* no sync... */ CHECK_LIMIT(); jit_movr_p(JIT_R1, JIT_R0); } - generate(rand1, jitter, 0, 0, JIT_R0); + generate(rand1, jitter, 0, 0, JIT_R0); /* no sync... */ CHECK_LIMIT(); mz_runstack_unskipped(jitter, 2); @@ -4356,6 +4437,7 @@ static int generate_two_args(Scheme_Object *rand1, Scheme_Object *rand2, mz_jit_ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, jit_insn **for_branch, int branch_short) +/* de-sync'd ok */ { Scheme_Object *r1, *r2, *rator = app->rator; GC_CAN_IGNORE jit_insn *reffail = NULL, *ref; @@ -4368,6 +4450,8 @@ static int generate_binary_char(mz_jit_state *jitter, Scheme_App3_Rec *app, direction = generate_two_args(r1, r2, jitter, 1); CHECK_LIMIT(); + mz_rs_sync(); + __START_SHORT_JUMPS__(branch_short); if (!SCHEME_CHARP(r1)) { @@ -4483,6 +4567,7 @@ static int generate_vector_op(mz_jit_state *jitter, int set) static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, int is_tail, int multi_ok, jit_insn **for_branch, int branch_short) +/* de-sync's; for branch, sync'd before */ { Scheme_Object *rator = app->rator; @@ -4516,6 +4601,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_non_tail(a2, jitter, 0, 1); CHECK_LIMIT(); + mz_rs_sync(); mz_runstack_unskipped(jitter, 2); @@ -4551,7 +4637,10 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i } else { /* Two complex expressions: */ generate_two_args(a2, a1, jitter, 0); - + CHECK_LIMIT(); + + mz_rs_sync(); + __START_SHORT_JUMPS__(branch_short); ref = jit_bner_p(jit_forward(), JIT_R0, JIT_R1); @@ -4643,6 +4732,8 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_two_args(app->rand1, app->rand2, jitter, 1); CHECK_LIMIT(); + mz_rs_sync(); + if (!which) { /* vector-ref is relatively simple and worth inlining */ generate_vector_op(jitter, 0); @@ -4659,6 +4750,8 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_non_tail(app->rand1, jitter, 0, 1); CHECK_LIMIT(); + + mz_rs_sync(); offset = SCHEME_INT_VAL(app->rand2); (void)jit_movi_p(JIT_R1, offset); @@ -4690,6 +4783,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_two_args(app->rand1, app->rand2, jitter, 1); CHECK_LIMIT(); + mz_rs_sync(); __START_TINY_JUMPS__(1); ref = jit_bmci_ul(jit_forward(), JIT_R0, 0x1); @@ -4720,6 +4814,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_two_args(app->rand1, app->rand2, jitter, 1); CHECK_LIMIT(); + mz_rs_sync(); return generate_cons_alloc(jitter, 0, 0); } else if (IS_NAMED_PRIM(rator, "mcons")) { @@ -4727,6 +4822,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_two_args(app->rand1, app->rand2, jitter, 1); CHECK_LIMIT(); + mz_rs_sync(); #ifdef CAN_INLINE_ALLOC /* Inlined alloc */ @@ -4753,12 +4849,13 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i generate_two_args(app->rand1, app->rand2, jitter, 1); CHECK_LIMIT(); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, 1); - jit_str_p(JIT_RUNSTACK, JIT_R0); + mz_rs_str(JIT_R0); (void)jit_movi_p(JIT_R0, &scheme_null); CHECK_LIMIT(); + mz_rs_sync(); generate_cons_alloc(jitter, 1, 0); CHECK_LIMIT(); @@ -4787,6 +4884,7 @@ static int generate_inlined_binary(mz_jit_state *jitter, Scheme_App3_Rec *app, i static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int is_tail, int multi_ok, jit_insn **for_branch, int branch_short) +/* de-sync's; for branch, sync'd before */ { Scheme_Object *rator = app->args[0]; @@ -4833,33 +4931,34 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int mz_runstack_skipped(jitter, 3 - pushed); if (pushed) { - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(pushed)); + mz_rs_dec(pushed); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, pushed); stack_safety(jitter, pushed, 0); CHECK_LIMIT(); } - generate_non_tail(app->args[1], jitter, 0, 1); + generate_non_tail(app->args[1], jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); if (!constval || !simple) { - jit_str_p(JIT_RUNSTACK, JIT_R0); + mz_rs_str(JIT_R0); } else { jit_movr_p(JIT_V1, JIT_R0); } if (!simple) { - generate_non_tail(app->args[2], jitter, 0, 1); + generate_non_tail(app->args[2], jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); if (!constval) { - jit_stxi_p(WORDS_TO_BYTES(1), JIT_RUNSTACK, JIT_R0); + mz_rs_stxi(1, JIT_R0); } else { jit_movr_p(JIT_R1, JIT_R0); } } - generate_non_tail(app->args[3], jitter, 0, 1); + generate_non_tail(app->args[3], jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); + mz_rs_sync(); if (!constval || !simple) { jit_movr_p(JIT_R2, JIT_R0); @@ -4901,7 +5000,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int } } - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(pushed)); + mz_rs_inc(pushed); /* no sync */ mz_runstack_popped(jitter, pushed); mz_runstack_unskipped(jitter, 3 - pushed); @@ -4920,6 +5019,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int if (c) generate_app(app, NULL, c, jitter, 0, 0, 1); CHECK_LIMIT(); + mz_rs_sync(); #ifdef CAN_INLINE_ALLOC jit_movi_l(JIT_R2, c); @@ -4940,7 +5040,7 @@ static int generate_inlined_nary(mz_jit_state *jitter, Scheme_App_Rec *app, int #endif if (c) { - jit_addi_l(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c)); + mz_rs_inc(c); /* no sync */ mz_runstack_popped(jitter, c); } @@ -4995,6 +5095,7 @@ static int generate_cons_alloc(mz_jit_state *jitter, int rev, int inline_retry) static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, Scheme_App_Rec *app, Scheme_App2_Rec *app2, Scheme_App3_Rec *app3) +/* de-sync'd ok */ { int imm, i, c; @@ -5002,20 +5103,22 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, if (app2) { mz_runstack_skipped(jitter, 1); - generate_non_tail(app2->rand, jitter, 0, 1); + generate_non_tail(app2->rand, jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); c = 1; } else if (app3) { - generate_two_args(app3->rand1, app3->rand2, jitter, 1); + generate_two_args(app3->rand1, app3->rand2, jitter, 1); /* sync'd below */ c = 2; } else { c = app->num_args; if (c) - generate_app(app, NULL, c, jitter, 0, 0, 1); + generate_app(app, NULL, c, jitter, 0, 0, 1); /* sync'd below */ } CHECK_LIMIT(); + mz_rs_sync(); + #ifdef CAN_INLINE_ALLOC /* Inlined alloc */ if (app2) @@ -5073,6 +5176,7 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, } if (c) { + /* could use mz_rs */ jit_addi_l(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c)); mz_runstack_popped(jitter, c); } @@ -5082,6 +5186,7 @@ static int generate_vector_alloc(mz_jit_state *jitter, Scheme_Object *rator, } int generate_inlined_test(mz_jit_state *jitter, Scheme_Object *obj, int branch_short, jit_insn **refs) +/* de-sync'd ok; syncs before jump */ { switch (SCHEME_TYPE(obj)) { case scheme_application2_type: @@ -5248,6 +5353,7 @@ static void ensure_case_closure_native(Scheme_Case_Lambda *c) } static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int target) +/* de-sync's */ { Scheme_Case_Lambda *c = (Scheme_Case_Lambda *)obj; Scheme_Native_Closure_Data *ndata; @@ -5258,6 +5364,8 @@ static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int t ensure_case_closure_native(c); ndata = c->native_code; + mz_rs_sync(); + JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); mz_prepare(1); retptr = mz_retain(ndata); @@ -5279,6 +5387,7 @@ static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int t o = (Scheme_Object *)((Scheme_Closure *)o)->code; data = (Scheme_Closure_Data *)o; mz_pushr_p(JIT_R1); + mz_rs_sync(); generate_closure(data, jitter, 1); CHECK_LIMIT(); generate_closure_fill(data, jitter); @@ -5299,7 +5408,8 @@ static int generate_case_closure(Scheme_Object *obj, mz_jit_state *jitter, int t static int generate_non_tail_mark_pos_prefix(mz_jit_state *jitter) { - /* This part of a non-tail setup can be done once for a sequence + /* dsync'd ok. + This part of a non-tail setup can be done once for a sequence of non-tail calls. In that case, pass 0 for the `mark_pos_ends' argument to generate_non_tail(), so that it can skip this prefix and suffix. In case this prefix needs to adjust the runstack, @@ -5311,6 +5421,7 @@ static int generate_non_tail_mark_pos_prefix(mz_jit_state *jitter) } static void generate_non_tail_mark_pos_suffix(mz_jit_state *jitter) +/* dsync'd ok */ { jit_ldi_l(JIT_R2, &scheme_current_cont_mark_pos); jit_subi_l(JIT_R2, JIT_R2, 2); @@ -5318,6 +5429,7 @@ static void generate_non_tail_mark_pos_suffix(mz_jit_state *jitter) } static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int mark_pos_ends) +/* de-sync's rs */ { if (is_simple(obj, INIT_SIMPLE_DEPTH, 0, jitter, 0)) { /* Simple; doesn't change the stack or set marks: */ @@ -5348,7 +5460,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi /* mark stack is an integer... turn it into a pointer */ jit_lshi_l(JIT_R2, JIT_R2, 0x1); jit_ori_l(JIT_R2, JIT_R2, 0x1); - mz_pushr_p(JIT_R2); + mz_pushr_p(JIT_R2); /* no sync */ } CHECK_LIMIT(); } @@ -5358,7 +5470,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi PAUSE_JIT_DATA(); FOR_LOG(jitter->log_depth++); - generate(obj, jitter, 0, multi_ok, JIT_R0); + generate(obj, jitter, 0, multi_ok, JIT_R0); /* no sync */ FOR_LOG(--jitter->log_depth); RESUME_JIT_DATA(); @@ -5366,14 +5478,14 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi amt = mz_runstack_restored(jitter); if (amt) { - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(amt)); + mz_rs_inc(amt); } if (need_ends) { if (using_local1) { mz_get_local_p(JIT_R2, JIT_LOCAL1); jitter->local1_busy = 0; } else { - mz_popr_p(JIT_R2); + mz_popr_p(JIT_R2); /* no sync */ jit_rshi_l(JIT_R2, JIT_R2, 0x1); /* pointer back to integer */ } jit_sti_p(&scheme_current_cont_mark_stack, JIT_R2); @@ -5393,6 +5505,7 @@ static int generate_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi /*========================================================================*/ static int generate_ignored_non_tail(Scheme_Object *obj, mz_jit_state *jitter, int multi_ok, int need_ends) +/* de-sync's */ { Scheme_Type t = SCHEME_TYPE(obj); @@ -5404,7 +5517,7 @@ static int generate_ignored_non_tail(Scheme_Object *obj, mz_jit_state *jitter, i START_JIT_DATA(); pos = mz_remap(SCHEME_LOCAL_POS(obj)); LOG_IT(("clear %d\n", pos)); - jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_RUNSTACK); + mz_rs_stxi(pos, JIT_RUNSTACK); END_JIT_DATA(2); } return 1; @@ -5429,7 +5542,7 @@ static Scheme_Object *generate_k(void) } static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int multi_ok, int target) -/* result goes to JIT_R0 */ +/* de-sync's; result goes to target */ { Scheme_Type type; @@ -5468,9 +5581,10 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m /* Other parts of the JIT rely on this code not modifying R1 */ START_JIT_DATA(); LOG_IT(("top-level\n")); + mz_rs_sync(); /* Load global array: */ pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(obj)); - jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + mz_rs_ldxi(JIT_R2, pos); /* Load bucket: */ pos = SCHEME_TOPLEVEL_POS(obj); jit_ldxi_p(JIT_R2, JIT_R2, WORDS_TO_BYTES(pos)); @@ -5493,13 +5607,13 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m pos = mz_remap(SCHEME_LOCAL_POS(obj)); LOG_IT(("local %d [%d]\n", pos, SCHEME_LOCAL_FLAGS(obj))); if (pos || (mz_CURRENT_STATUS() != mz_RS_R0_HAS_RUNSTACK0)) { - jit_ldxi_p(target, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + mz_rs_ldxi(target, pos); VALIDATE_RESULT(target); } else if (target != JIT_R0) { jit_movr_p(target, JIT_R0); } if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) { - jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_RUNSTACK); + mz_rs_stxi(pos, JIT_RUNSTACK); } END_JIT_DATA(2); return 1; @@ -5511,11 +5625,11 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("unbox local\n")); pos = mz_remap(SCHEME_LOCAL_POS(obj)); - jit_ldxi_p(JIT_R0, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + mz_rs_ldxi(JIT_R0, pos); jit_ldr_p(target, JIT_R0); if (SCHEME_LOCAL_FLAGS(obj) & SCHEME_LOCAL_CLEAR_ON_READ) { LOG_IT(("clear-on-read\n")); - jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_RUNSTACK); + mz_rs_stxi(pos, JIT_RUNSTACK); } VALIDATE_RESULT(target); @@ -5525,6 +5639,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m case scheme_syntax_type: { int pos; + mz_rs_sync(); pos = SCHEME_PINT_VAL(obj); switch (pos) { case CASE_LAMBDA_EXPD: @@ -5551,17 +5666,19 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m evaluation, allow multiple values. */ generate_non_tail(seq->array[0], jitter, 1, 1); CHECK_LIMIT(); + mz_rs_sync(); /* Save value(s) */ jit_movr_p(JIT_V1, JIT_R0); mz_pushr_p(JIT_V1); mz_pushr_p(JIT_V1); mz_pushr_p(JIT_V1); + mz_rs_sync(); __START_SHORT_JUMPS__(1); ref = jit_bnei_p(jit_forward(), JIT_R0, SCHEME_MULTIPLE_VALUES); CHECK_LIMIT(); /* Save away multiple values */ - mz_popr_p(JIT_V1); + mz_popr_p(JIT_V1); /* sync'd below... */ mz_popr_p(JIT_V1); mz_popr_p(JIT_V1); jit_ldi_p(JIT_R0, &scheme_current_thread); @@ -5569,14 +5686,15 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m jit_ldxi_l(JIT_V1, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.count); jit_lshi_l(JIT_V1, JIT_V1, 0x1); jit_ori_l(JIT_V1, JIT_V1, 0x1); - mz_pushr_p(JIT_V1); + mz_pushr_p(JIT_V1); /* sync'd below */ jit_ldxi_p(JIT_V1, JIT_R0, &((Scheme_Thread *)0x0)->ku.multiple.array); - mz_pushr_p(JIT_V1); + mz_pushr_p(JIT_V1); /* sync'd below */ CHECK_LIMIT(); (void)jit_movi_p(JIT_R1, 0x0); mz_pushr_p(JIT_R1); /* pushing 0 indicates that multi-array follows */ /* If multi-value array is values buffer, zero out values buffer */ jit_ldxi_p(JIT_R2, JIT_R0, &((Scheme_Thread *)0x0)->values_buffer); + mz_rs_sync(); ref2 = jit_bner_p(jit_forward(), JIT_V1, JIT_R2); jit_stxi_p(&((Scheme_Thread *)0x0)->values_buffer, JIT_R0, JIT_R1); CHECK_LIMIT(); @@ -5586,7 +5704,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_patch_branch(ref2); __END_SHORT_JUMPS__(1); for (i = 1; i < seq->count; i++) { - generate_ignored_non_tail(seq->array[i], jitter, 1, 1); + generate_ignored_non_tail(seq->array[i], jitter, 1, 1); /* sync's below */ CHECK_LIMIT(); } @@ -5594,6 +5712,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_popr_p(JIT_R0); mz_popr_p(JIT_R1); mz_popr_p(JIT_R2); + mz_rs_sync(); CHECK_LIMIT(); __START_TINY_JUMPS__(1); ref = jit_bnei_p(jit_forward(), JIT_R0, 0x0); @@ -5629,7 +5748,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m generate_non_tail(p, jitter, 0, 1); CHECK_LIMIT(); - + mz_rs_sync(); + /* Load global+stx array: */ pos = mz_remap(SCHEME_TOPLEVEL_DEPTH(v)); jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); @@ -5666,7 +5786,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m generate_non_tail(v, jitter, 0, 1); CHECK_LIMIT(); - + mz_rs_sync(); + /* If v is not known to produce a procedure, then check result: */ if (!is_a_procedure(v, jitter)) { (void)jit_bmsi_l(bad_app_vals_target, JIT_R0, 0x1); @@ -5683,6 +5804,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_popr_p(JIT_V1); /* Function is in V1, argument(s) in R0 */ + mz_rs_sync(); + __START_SHORT_JUMPS__(1); ref = jit_beqi_p(jit_forward(), JIT_R0, SCHEME_MULTIPLE_VALUES); /* Single-value case: --------------- */ @@ -5985,6 +6108,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m if (!generate_inlined_test(jitter, branch->test, then_short_ok, refs)) { CHECK_LIMIT(); generate_non_tail(branch->test, jitter, 0, 1); + mz_rs_sync(); CHECK_LIMIT(); __START_SHORT_JUMPS__(then_short_ok); refs[0] = jit_beqi_p(jit_forward(), JIT_R0, scheme_false); @@ -6003,9 +6127,11 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m CHECK_LIMIT(); amt = mz_runstack_restored(jitter); if (g1 != 2) { - if (amt && !is_tail) { - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(amt)); - } + if (!is_tail) { + if (amt) + mz_rs_inc(amt); + mz_rs_sync(); + } __START_SHORT_JUMPS__(else_short_ok); ref2 = jit_jmpi(jit_forward()); __END_SHORT_JUMPS__(else_short_ok); @@ -6015,7 +6141,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m nsrs1 = 0; } jitter->need_set_rs = nsrs; - + mz_rs_sync_0(); + /* False branch */ mz_runstack_saved(jitter); __START_SHORT_JUMPS__(then_short_ok); @@ -6047,9 +6174,11 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m CHECK_LIMIT(); amt = mz_runstack_restored(jitter); if (g2 != 2) { - if (amt && !is_tail) { - jit_addi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(amt)); - } + if (!is_tail) { + if (amt) + mz_rs_inc(amt); + mz_rs_sync(); + } } else { jitter->need_set_rs = 0; } @@ -6079,6 +6208,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("lambda\n")); + mz_rs_sync(); + /* Allocate closure */ generate_closure(data, jitter, 1); CHECK_LIMIT(); @@ -6102,15 +6233,15 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m if (lv->count == 1) { /* Expect one result: */ - generate_non_tail(lv->value, jitter, 0, 1); + generate_non_tail(lv->value, jitter, 0, 1); /* no sync */ CHECK_LIMIT(); if (ab) { pos = mz_remap(lv->position); - jit_ldxi_p(JIT_R2, JIT_RUNSTACK, WORDS_TO_BYTES(pos)); + mz_rs_ldxi(JIT_R2, pos); jit_str_p(JIT_R2, JIT_R0); } else { pos = mz_remap(lv->position); - jit_stxi_p(WORDS_TO_BYTES(pos), JIT_RUNSTACK, JIT_R0); + mz_rs_stxi(pos, JIT_R0); } CHECK_LIMIT(); } else { @@ -6119,6 +6250,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m generate_non_tail(lv->value, jitter, 1, 1); CHECK_LIMIT(); + + mz_rs_sync(); __START_SHORT_JUMPS__(1); @@ -6185,13 +6318,14 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("letv...\n")); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(c)); + mz_rs_dec(c); CHECK_RUNSTACK_OVERFLOW(); stack_safety(jitter, c, 0); mz_runstack_pushed(jitter, c); if (SCHEME_LET_AUTOBOX(lv)) { int i; + mz_rs_sync(); JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); for (i = 0; i < c; i++) { CHECK_LIMIT(); @@ -6219,6 +6353,8 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("letrec...\n")); + mz_rs_sync(); + /* Create unfinished closures */ for (i = 0; i < l->count; i++) { ((Scheme_Closure_Data *)l->procs[i])->context = (Scheme_Object *)l; @@ -6274,17 +6410,17 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m mz_runstack_skipped(jitter, 1); PAUSE_JIT_DATA(); - generate_non_tail(lv->value, jitter, 0, 1); + generate_non_tail(lv->value, jitter, 0, 1); /* no sync */ RESUME_JIT_DATA(); CHECK_LIMIT(); mz_runstack_unskipped(jitter, 1); - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(1)); + mz_rs_dec(1); CHECK_RUNSTACK_OVERFLOW(); mz_runstack_pushed(jitter, 1); - jit_str_p(JIT_RUNSTACK, JIT_R0); + mz_rs_str(JIT_R0); END_JIT_DATA(17); @@ -6302,20 +6438,21 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m LOG_IT(("wcm...\n")); /* Key: */ - generate_non_tail(wcm->key, jitter, 0, 1); + generate_non_tail(wcm->key, jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); if (SCHEME_TYPE(wcm->val) > _scheme_values_types_) { /* No need to push mark onto value stack: */ jit_movr_p(JIT_V1, JIT_R0); - generate_non_tail(wcm->val, jitter, 0, 1); + generate_non_tail(wcm->val, jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); } else { mz_pushr_p(JIT_R0); - generate_non_tail(wcm->val, jitter, 0, 1); + generate_non_tail(wcm->val, jitter, 0, 1); /* sync'd below */ CHECK_LIMIT(); - mz_popr_p(JIT_V1); + mz_popr_p(JIT_V1); /* sync'd below */ } + mz_rs_sync(); JIT_UPDATE_THREAD_RSPTR_IF_NEEDED(); mz_prepare(2); @@ -6341,7 +6478,9 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m i = qs->position; c = mz_remap(qs->depth); p = qs->midpoint; - + + mz_rs_sync(); + jit_movi_i(JIT_R0, WORDS_TO_BYTES(c)); jit_movi_i(JIT_R1, WORDS_TO_BYTES(i + p + 1)); jit_movi_i(JIT_R2, WORDS_TO_BYTES(p)); @@ -7620,7 +7759,10 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) #ifndef JIT_PRECISE_GC if (data->closure_size) #endif - mz_pushr_p(JIT_R0); + { + mz_pushr_p(JIT_R0); + mz_rs_sync(); + } JIT_UPDATE_THREAD_RSPTR(); CHECK_LIMIT(); mz_prepare(3); @@ -7634,7 +7776,10 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) #ifndef JIT_PRECISE_GC if (data->closure_size) #endif - mz_popr_p(JIT_R0); + { + mz_popr_p(JIT_R0); + mz_rs_sync(); + } jit_stxi_p(WORDS_TO_BYTES(cnt), JIT_RUNSTACK, JIT_V1); mz_patch_ucbranch(ref2); /* jump here if we copied and produced null */ CHECK_LIMIT(); @@ -7649,24 +7794,26 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) /* Keeping the native-closure pointer on the runstack ensures that the code won't be GCed while we're running it. */ - mz_pushr_p(JIT_R0); + mz_pushr_p(JIT_R0); /* no sync */ #endif /* Extract closure to runstack: */ cnt = data->closure_size; if (cnt) { - jit_subi_p(JIT_RUNSTACK, JIT_RUNSTACK, WORDS_TO_BYTES(cnt)); + mz_rs_dec(cnt); CHECK_RUNSTACK_OVERFLOW(); for (i = cnt; i--; ) { int pos; pos = WORDS_TO_BYTES(i) + (long)&((Scheme_Native_Closure *)0x0)->vals; jit_ldxi_p(JIT_R1, JIT_R0, pos); - jit_stxi_p(WORDS_TO_BYTES(i), JIT_RUNSTACK, JIT_R1); + mz_rs_stxi(i, JIT_R1); CHECK_LIMIT(); } } + mz_rs_sync(); + /* If we have a letrec context, record arities */ if (data->context && SAME_TYPE(SCHEME_TYPE(data->context), scheme_letrec_type)) { Scheme_Letrec *lr = (Scheme_Letrec *)data->context; @@ -7722,7 +7869,7 @@ static int do_generate_closure(mz_jit_state *jitter, void *_data) /* Generate code for the body: */ jitter->need_set_rs = 1; - r = generate(data->code, jitter, 1, 1, JIT_R0); + r = generate(data->code, jitter, 1, 1, JIT_R0); /* no need for sync */ /* Result is in JIT_R0 */ CHECK_LIMIT(); From e0a95e9e22ca9bfe802a41e0c7ec1f9fbbeb2a2f Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 24 Mar 2009 17:48:11 +0000 Subject: [PATCH 136/140] Add `tanh' with documentation. svn: r14250 --- collects/scheme/math.ss | 4 +++- collects/scribblings/reference/numbers.scrbl | 4 ++++ 2 files changed, 7 insertions(+), 1 deletion(-) diff --git a/collects/scheme/math.ss b/collects/scheme/math.ss index 99346dc1cc..a98ccd613e 100644 --- a/collects/scheme/math.ss +++ b/collects/scheme/math.ss @@ -7,7 +7,7 @@ (provide pi sqr sgn conjugate - sinh cosh) + sinh cosh tanh) (define (sqr z) (* z z)) @@ -29,3 +29,5 @@ (define (cosh x) (/ (+ (exp x) (exp (- x))) 2.0)) + +(define (tanh x) (/ (sinh x) (cosh x))) diff --git a/collects/scribblings/reference/numbers.scrbl b/collects/scribblings/reference/numbers.scrbl index 01a0de3cea..900e15ee55 100644 --- a/collects/scribblings/reference/numbers.scrbl +++ b/collects/scribblings/reference/numbers.scrbl @@ -890,6 +890,10 @@ Returns the hyperbolic sine of @scheme[z].} Returns the hyperbolic cosine of @scheme[z].} +@defproc[(tanh [z number?]) number?]{ + +Returns the hyperbolic tangent of @scheme[z].} + @; ---------------------------------------------------------------------- @close-eval[math-eval] From 43443652b8d4c0b73ec950c3ead818c262ddf0bb Mon Sep 17 00:00:00 2001 From: Sam Tobin-Hochstadt Date: Tue, 24 Mar 2009 17:49:15 +0000 Subject: [PATCH 137/140] Add fake type name -Real Add `scheme/math' types from Jos Koot. svn: r14251 --- collects/typed-scheme/private/base-env.ss | 12 +++++++++++- collects/typed-scheme/private/type-abbrev.ss | 2 ++ 2 files changed, 13 insertions(+), 1 deletion(-) diff --git a/collects/typed-scheme/private/base-env.ss b/collects/typed-scheme/private/base-env.ss index 4579ee344f..f314d2727e 100644 --- a/collects/typed-scheme/private/base-env.ss +++ b/collects/typed-scheme/private/base-env.ss @@ -577,7 +577,7 @@ [current-continuation-marks (-> -Cont-Mark-Set)] -;; path.ss +;; scheme/path [explode-path (-Pathlike . -> . (-lst (Un -Path (-val 'up) (-val 'same))))] [find-relative-path (-Pathlike -Pathlike . -> . -Path)] @@ -591,3 +591,13 @@ [string->some-system-path (-String (Un (-val 'unix) (-val 'windows)) . -> . -Path)] +;; scheme/math + +[sgn (-Real . -> . -Real)] +[pi N] +[sqr (N . -> . N)] +[sgn (N . -> . N)] +[conjugate (N . -> . N)] +[sinh (N . -> . N)] +[cosh (N . -> . N)] +[tanh (N . -> . N)] \ No newline at end of file diff --git a/collects/typed-scheme/private/type-abbrev.ss b/collects/typed-scheme/private/type-abbrev.ss index 35de27f4cc..ea41573036 100644 --- a/collects/typed-scheme/private/type-abbrev.ss +++ b/collects/typed-scheme/private/type-abbrev.ss @@ -204,6 +204,8 @@ (define -Pattern (*Un -String -Bytes -Regexp -Byte-Regexp -PRegexp -Byte-PRegexp)) (define -Byte N) +(define -Real N) + (define (-Tuple l) (foldr -pair (-val '()) l)) From 3b490389470c977be372a943ccc03bfb1b8ae25f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Mar 2009 18:38:18 +0000 Subject: [PATCH 138/140] better eof handling in zo-parse svn: r14252 --- collects/compiler/zo-parse.ss | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/collects/compiler/zo-parse.ss b/collects/compiler/zo-parse.ss index 49e6ccd3ae..b4d4375997 100644 --- a/collects/compiler/zo-parse.ss +++ b/collects/compiler/zo-parse.ss @@ -927,7 +927,7 @@ (define rst (read-bytes size* port)) - (unless (eof-object? (read port)) + (unless (eof-object? (read-byte port)) (error 'not-end)) (unless (= size* (bytes-length rst)) From 6e80847b1884a1dc5f63263c78bea0e2694dc220 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 24 Mar 2009 18:38:42 +0000 Subject: [PATCH 139/140] auto add main include dir in compiler/xform (PR 10155) svn: r14253 --- collects/compiler/xform.ss | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/collects/compiler/xform.ss b/collects/compiler/xform.ss index 8907315faa..451ab30159 100644 --- a/collects/compiler/xform.ss +++ b/collects/compiler/xform.ss @@ -1,6 +1,7 @@ #lang scheme/base (require dynext/compile + setup/dirs (prefix-in xform: "private/xform.ss")) (provide xform) @@ -11,7 +12,9 @@ (current-extension-preprocess-flags))] [headers (apply append (map (current-make-compile-include-strings) - header-dirs))]) + (append + header-dirs + (list (find-include-dir)))))]) (xform:xform quiet? (cons exe (append flags headers)) From 5cc75c59886397cc4325ada48c09c05e7395a19a Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Tue, 24 Mar 2009 21:17:13 +0000 Subject: [PATCH 140/140] Welcome to a new PLT day. svn: r14254 --- 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 66af1acfca..837a8d5dec 100644 --- a/collects/repos-time-stamp/stamp.ss +++ b/collects/repos-time-stamp/stamp.ss @@ -1 +1 @@ -#lang scheme/base (provide stamp) (define stamp "23mar2009") +#lang scheme/base (provide stamp) (define stamp "24mar2009")