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

msvs9-friendly patches; preliminary splicing let-syntax library; export and doc GC_resolve and GC_fixup_self

Browse Source 
svn: r11758
This commit is contained in:
Matthew Flatt 2008-09-15 19:08:50 +00:00
parent 9c1f3eda0c
commit 186bf67630
17 changed files with 155 additions and 22 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -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))))

2
collects/mzlib/pretty.ss
View File

@ -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)))))

93
collects/scheme/splicing.ss Normal file
View File

@ -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))

29
collects/scribblings/inside/memory.scrbl
View File

@ -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.}

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

@ -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

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

@ -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

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

@ -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);

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

@ -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);

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

@ -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;

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

@ -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)

2
src/worksp/gc2/make.ss
View File

@ -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))

2
src/worksp/libmysterx/xform.ss
View File

@ -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"

2
src/worksp/mzcom/xform.ss
View File

@ -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)

13
src/wxwindow/contrib/fafa/fafabuf.h Normal file
View File

@ -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

14
src/wxwindow/contrib/fafa/fafapriv.h
View File

@ -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"
/*
|-----------------------------------------------------------------------|

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

@ -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"

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

@ -3344,7 +3344,9 @@ wxGL *wxMemoryDC::GetGL()
#include <gl/gl.h>
#include <gl/glu.h>
#include <gl/glaux.h>
#if _MSC_VER < 1500
# include <gl/glaux.h>
#endif
#include "wx_wglext.h"
#include "../../../wxcommon/wxGLConfig.cxx"