diff --git a/collects/compiler/private/xform.ss b/collects/compiler/private/xform.ss index 35e9cafcfe..c024cb9d13 100644 --- a/collects/compiler/private/xform.ss +++ b/collects/compiler/private/xform.ss @@ -2676,7 +2676,7 @@ (eq? semi (tok-n (cadr e)))) (tok-n (car e)) (loop (cdr e))))]) - (unless (eq? '|::| (tok-n (cadar body))) + (unless (or (eq? '|::| type) (eq? '|::| (tok-n (cadar body)))) ;; $patch vs2008 - goetter (log-error "[DECL] ~a in ~a: Variable declaration (~a ~a) not at the beginning of a block." (tok-line (caar body)) (tok-file (caar body)) type var)))) diff --git a/collects/mzlib/pretty.ss b/collects/mzlib/pretty.ss index 91e7aea70d..6849cb1cd3 100644 --- a/collects/mzlib/pretty.ss +++ b/collects/mzlib/pretty.ss @@ -1173,7 +1173,7 @@ (and (pretty-print-abbreviate-read-macros) (let ((head (car l)) (tail (cdr l))) (case head - ((quote quasiquote unquote unquote-splicing syntax) + ((quote quasiquote unquote unquote-splicing syntax unsyntax unsyntax-splicing) (length1? tail)) (else #f))))) diff --git a/collects/scheme/splicing.ss b/collects/scheme/splicing.ss new file mode 100644 index 0000000000..906587efd1 --- /dev/null +++ b/collects/scheme/splicing.ss @@ -0,0 +1,93 @@ +#lang scheme/base +(require (for-syntax scheme/base)) + +(provide splicing-let-syntax + splicing-let-syntaxes + splicing-letrec-syntax + splicing-letrec-syntaxes) + +(define-for-syntax (do-let-syntax stx rec? multi?) + (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)) + (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))) + (if (eq? 'expression (syntax-local-context)) + (with-syntax ([let-stx (if rec? + (if multi? + #'letrec-syntaxes + #'letrec-syntax) + (if multi? + #'let-syntaxes + #'let-syntax))]) + (syntax/loc stx + (let-stx ([ids expr] ...) + (#%expression body) + ...))) + (let ([sli (if (list? (syntax-local-context)) + syntax-local-introduce + values)]) + (let ([all-ids (map (lambda (ids) (map sli ids)) all-ids)] + [def-ctx (syntax-local-make-definition-context)] + [ctx (list (gensym 'intdef))]) + (syntax-local-bind-syntaxes (apply append all-ids) #f def-ctx) + (let* ([add-context + (lambda (expr) + (let ([q (local-expand #`(quote #,expr) + ctx + (list #'quote) + def-ctx)]) + (syntax-case q () + [(_ expr) #'expr])))]) + (with-syntax ([((id ...) ...) + (map (lambda (ids) + (map sli (map add-context ids))) + all-ids)] + [(expr ...) + (let ([exprs (syntax->list #'(expr ...))]) + (if rec? + (map add-context exprs) + exprs))] + [(body ...) + (map add-context (syntax->list #'(body ...)))]) + #'(begin + (define-syntaxes (id ...) expr) + ... + body ...)))))))])) + +(define-syntax (splicing-let-syntax stx) + (do-let-syntax stx #f #f)) + +(define-syntax (splicing-let-syntaxes stx) + (do-let-syntax stx #f #t)) + +(define-syntax (splicing-letrec-syntax stx) + (do-let-syntax stx #t #f)) + +(define-syntax (splicing-letrec-syntaxes stx) + (do-let-syntax stx #t #t)) \ No newline at end of file diff --git a/collects/scribblings/inside/memory.scrbl b/collects/scribblings/inside/memory.scrbl index 30387dc506..b9309f4264 100644 --- a/collects/scribblings/inside/memory.scrbl +++ b/collects/scribblings/inside/memory.scrbl @@ -939,6 +939,7 @@ See @cpp{scheme_dont_gc_ptr}.} Forces an immediate garbage-collection.} + @function[(void GC_register_traversers [short tag] [Size_Proc s] @@ -961,6 +962,30 @@ Each of the three procedures takes a pointer and returns an integer: If the result of the size procedure is a constant, then pass a non-zero value for @var{is_const_size}. If the mark and fixup procedures are no-ops, then pass a non-zero value - for @var{is_atomic}. + for @var{is_atomic}.} -} + +@function[(void* GC_resolve [void* p])]{ + +3m only. Can be called by a size, mark, or fixup procedure that is registered +with @cpp{GC_register_traversers}. It returns the current address of +an object @var{p} that might have been moved already, where @var{p} +corresponds to an object that is referenced directly by the object +being sized, marked, or fixed. This translation is necessary, for +example, if the size or structure of an object depends on the content +of an object it references. For example, the size of a class instance +usually depends on a field count that is stored in the class. A fixup +procedure should call this function on a reference @emph{before} +fixing it.} + + +@function[(void* GC_fixup_self [void* p])]{ + +3m only. Can be called by a fixup procedure that is registered with +@cpp{GC_register_traversers}. It returns the final address of @var{p}, +which must be the pointer passed to the fixup procedure. For some +implementations of the memory manager, the result is the same as +@var{p}, either because objects are not moved or because the object is +moved before it is fixed. With other implementations, an object might +be moved after the fixup process, and the result is the location that +the object will have after garbage collection finished.} diff --git a/src/mzscheme/include/mzscheme3m.exp b/src/mzscheme/include/mzscheme3m.exp index 84941c25c2..2d4e5561c6 100644 --- a/src/mzscheme/include/mzscheme3m.exp +++ b/src/mzscheme/include/mzscheme3m.exp @@ -201,6 +201,8 @@ GC_register_traversers GC_resolve GC_mark GC_fixup +GC_fixup_self +GC_resolve scheme_malloc_immobile_box scheme_free_immobile_box scheme_make_bucket_table diff --git a/src/mzscheme/include/mzwin3m.def b/src/mzscheme/include/mzwin3m.def index 19fe2ba515..3a7e88f9b7 100644 --- a/src/mzscheme/include/mzwin3m.def +++ b/src/mzscheme/include/mzwin3m.def @@ -193,6 +193,8 @@ EXPORTS GC_resolve GC_mark GC_fixup + GC_fixup_self + GC_resolve scheme_malloc_immobile_box scheme_free_immobile_box scheme_make_bucket_table diff --git a/src/mzscheme/src/schemef.h b/src/mzscheme/src/schemef.h index 6aee13eafd..f098acb8fb 100644 --- a/src/mzscheme/src/schemef.h +++ b/src/mzscheme/src/schemef.h @@ -396,6 +396,8 @@ MZ_EXTERN void GC_register_traversers(short tag, Size_Proc size, Mark_Proc mark, MZ_EXTERN void *GC_resolve(void *p); MZ_EXTERN void GC_mark(const void *p); MZ_EXTERN void GC_fixup(void *p); +MZ_EXTERN void *GC_fixup_self(void *p); +MZ_EXTERN void *GC_resolve(void *p); #endif MZ_EXTERN void **scheme_malloc_immobile_box(void *p); diff --git a/src/mzscheme/src/schemex.h b/src/mzscheme/src/schemex.h index 55239e85ef..f26c49d88e 100644 --- a/src/mzscheme/src/schemex.h +++ b/src/mzscheme/src/schemex.h @@ -322,6 +322,8 @@ void (*GC_register_traversers)(short tag, Size_Proc size, Mark_Proc mark, Fixup_ void *(*GC_resolve)(void *p); void (*GC_mark)(const void *p); void (*GC_fixup)(void *p); +void *(*GC_fixup_self)(void *p); +void *(*GC_resolve)(void *p); #endif void **(*scheme_malloc_immobile_box)(void *p); void (*scheme_free_immobile_box)(void **b); diff --git a/src/mzscheme/src/schemex.inc b/src/mzscheme/src/schemex.inc index d9cc68f466..656d9177c4 100644 --- a/src/mzscheme/src/schemex.inc +++ b/src/mzscheme/src/schemex.inc @@ -221,6 +221,8 @@ scheme_extension_table->GC_resolve = GC_resolve; scheme_extension_table->GC_mark = GC_mark; scheme_extension_table->GC_fixup = GC_fixup; + scheme_extension_table->GC_fixup_self = GC_fixup_self; + scheme_extension_table->GC_resolve = GC_resolve; #endif scheme_extension_table->scheme_malloc_immobile_box = scheme_malloc_immobile_box; scheme_extension_table->scheme_free_immobile_box = scheme_free_immobile_box; diff --git a/src/mzscheme/src/schemexm.h b/src/mzscheme/src/schemexm.h index 4ac0a90b91..7745185b5f 100644 --- a/src/mzscheme/src/schemexm.h +++ b/src/mzscheme/src/schemexm.h @@ -221,6 +221,8 @@ #define GC_resolve (scheme_extension_table->GC_resolve) #define GC_mark (scheme_extension_table->GC_mark) #define GC_fixup (scheme_extension_table->GC_fixup) +#define GC_fixup_self (scheme_extension_table->GC_fixup_self) +#define GC_resolve (scheme_extension_table->GC_resolve) #endif #define scheme_malloc_immobile_box (scheme_extension_table->scheme_malloc_immobile_box) #define scheme_free_immobile_box (scheme_extension_table->scheme_free_immobile_box) diff --git a/src/worksp/gc2/make.ss b/src/worksp/gc2/make.ss index a6a60f8e09..f7635ae83d 100644 --- a/src/worksp/gc2/make.ss +++ b/src/worksp/gc2/make.ss @@ -63,7 +63,7 @@ "type" "vector")) -(define common-cpp-defs " /D _CRT_SECURE_NO_DEPRECATE ") +(define common-cpp-defs " /D _CRT_SECURE_NO_DEPRECATE /D _USE_DECLSPECS_FOR_SAL=0 /D _USE_ATTRIBUTES_FOR_SAL=0 ") (define (check-timestamp t2 dep) (when (t2 . > . (current-seconds)) diff --git a/src/worksp/libmysterx/xform.ss b/src/worksp/libmysterx/xform.ss index c059c70f83..db6ff612ef 100644 --- a/src/worksp/libmysterx/xform.ss +++ b/src/worksp/libmysterx/xform.ss @@ -5,7 +5,7 @@ (require mzlib/restart) -(define cpp-flags "/D _CRT_SECURE_NO_DEPRECATE /D WIN32") +(define cpp-flags "/D _CRT_SECURE_NO_DEPRECATE /D WIN32 /D _USE_DECLSPECS_FOR_SAL=0 /D _USE_ATTRIBUTES_FOR_SAL=0") (define includes (string-append "/I ../../mzscheme/include /I . /I .. /I ../../mysterx" diff --git a/src/worksp/mzcom/xform.ss b/src/worksp/mzcom/xform.ss index d595984435..7e3d863994 100644 --- a/src/worksp/mzcom/xform.ss +++ b/src/worksp/mzcom/xform.ss @@ -4,7 +4,7 @@ (require mzlib/restart) -(define cpp-flags "/D _CRT_SECURE_NO_DEPRECATE /D WIN32") +(define cpp-flags "/D _CRT_SECURE_NO_DEPRECATE /D WIN32 /D _USE_DECLSPECS_FOR_SAL=0 /D _USE_ATTRIBUTES_FOR_SAL=0") (define includes "/I ../../mzscheme/include /I . /I .. /I ../../mzcom") (define (xform src dest) diff --git a/src/wxwindow/contrib/fafa/fafabuf.h b/src/wxwindow/contrib/fafa/fafabuf.h new file mode 100644 index 0000000000..a99c8a2998 --- /dev/null +++ b/src/wxwindow/contrib/fafa/fafabuf.h @@ -0,0 +1,13 @@ +#ifdef __cplusplus +extern "C" char FafaWind[] ; +extern "C" char FafaButt[] ; +extern "C" char FafaStat[] ; +extern "C" char FafaChck[] ; +extern "C" char MichButt[] ; +#else +extern char FafaWind[] ; +extern char FafaButt[] ; +extern char FafaStat[] ; +extern char FafaChck[] ; +extern char MichButt[] ; +#endif diff --git a/src/wxwindow/contrib/fafa/fafapriv.h b/src/wxwindow/contrib/fafa/fafapriv.h index 4b8c2d4069..bb7590aca6 100644 --- a/src/wxwindow/contrib/fafa/fafapriv.h +++ b/src/wxwindow/contrib/fafa/fafapriv.h @@ -120,19 +120,7 @@ enum { /* Extra BYTES, Offsets : */ extern HANDLE Inst ; /* instance librairie */ extern HBITMAP DisableBitmap ; /* bitmap controles disables */ -#ifdef __cplusplus -extern "C" char FafaWind[] ; -extern "C" char FafaButt[] ; -extern "C" char FafaStat[] ; -extern "C" char FafaChck[] ; -extern "C" char MichButt[] ; -#else -extern char FafaWind[] ; -extern char FafaButt[] ; -extern char FafaStat[] ; -extern char FafaChck[] ; -extern char MichButt[] ; -#endif +#include "fafabuf.h" /* |-----------------------------------------------------------------------| diff --git a/src/wxwindow/include/msw/wx_itemp.h b/src/wxwindow/include/msw/wx_itemp.h index 20a199fe3e..9cf1adf02a 100644 --- a/src/wxwindow/include/msw/wx_itemp.h +++ b/src/wxwindow/include/msw/wx_itemp.h @@ -18,7 +18,7 @@ #include "wx_utils.h" #include "fafa.h" -#include "fafapriv.h" //added by Chubraev +#include "fafabuf.h" #define STATIC_CLASS "STATIC" #define LSTATIC_CLASS L"STATIC" diff --git a/src/wxwindow/src/msw/wx_dc.cxx b/src/wxwindow/src/msw/wx_dc.cxx index 4bf98ae9d3..24af20cce8 100644 --- a/src/wxwindow/src/msw/wx_dc.cxx +++ b/src/wxwindow/src/msw/wx_dc.cxx @@ -3344,7 +3344,9 @@ wxGL *wxMemoryDC::GetGL() #include #include -#include +#if _MSC_VER < 1500 +# include +#endif #include "wx_wglext.h" #include "../../../wxcommon/wxGLConfig.cxx"