mirrors/emacs
1
Fork 0
mirror of git://git.sv.gnu.org/emacs.git synced 2026-03-07 06:22:32 -08:00
Code Issues Projects Releases Wiki Activity

Catch-up merge from master, mainly to pick up gcbench fixes.

Browse source 
Copied from Perforce
 Change: 184504
 ServerID: perforce.ravenbrook.com
This commit is contained in:
Richard Brooksby 2014-02-25 01:29:12 +00:00
commit f9051f09f6
10 changed files with 338 additions and 156 deletions
Download patch file Download diff file Expand all files Collapse all files

45
mps/code/gcbench.c
View file

@ -33,9 +33,6 @@ static mps_arena_t arena;
static mps_pool_t pool;
static mps_fmt_t format;
static mps_chain_t chain;
static mps_gen_param_s genDefault[] = {
{ 5 * 1024 * 1024, 0.85 },
{ 50 * 1024 * 1024, 0.45 } };
/* objNULL needs to be odd so that it's ignored in exactRoots. */
#define objNULL ((obj_t)MPS_WORD_CONST(0xDECEA5ED))
@ -52,6 +49,7 @@ static double pupdate = 0.1; /* probability of update */
static unsigned ngen = 0; /* number of generations specified */
static mps_gen_param_s gen[genLIMIT]; /* generation parameters */
static size_t arenasize = 256ul * 1024 * 1024; /* arena size */
static unsigned pinleaf = FALSE; /* are leaf objects pinned at start */
typedef struct gcthread_s *gcthread_t;
@ -82,13 +80,13 @@ static void aset(obj_t v, size_t i, obj_t val) {
}
/* mktree - make a tree of nodes with depth d. */
static obj_t mktree(mps_ap_t ap, unsigned d) {
static obj_t mktree(mps_ap_t ap, unsigned d, obj_t leaf) {
obj_t tree;
size_t i;
if (d <= 0) return objNULL;
if (d <= 0) return leaf;
tree = mkvector(ap, width);
for (i = 0; i < width; ++i) {
aset(tree, i, mktree(ap, d - 1));
aset(tree, i, mktree(ap, d - 1, leaf));
}
return tree;
}
@ -154,8 +152,9 @@ static obj_t update_tree(mps_ap_t ap, obj_t oldtree, unsigned d) {
static void *gc_tree(gcthread_t thread) {
unsigned i, j;
mps_ap_t ap = thread->ap;
obj_t leaf = pinleaf ? mktree(ap, 1, objNULL) : objNULL;
for (i = 0; i < niter; ++i) {
obj_t tree = mktree(ap, depth);
obj_t tree = mktree(ap, depth, leaf);
for (j = 0 ; j < npass; ++j) {
if (preuse < 1.0)
tree = new_tree(ap, tree, depth);
@ -248,10 +247,12 @@ static void arena_setup(gcthread_fn_t fn,
/* Make wrappers now to avoid race condition. */
/* dylan_make_wrappers() uses malloc. */
RESMUST(dylan_make_wrappers());
RESMUST(mps_chain_create(&chain, arena, ngen, gen));
if (ngen > 0)
RESMUST(mps_chain_create(&chain, arena, ngen, gen));
MPS_ARGS_BEGIN(args) {
MPS_ARGS_ADD(args, MPS_KEY_FORMAT, format);
MPS_ARGS_ADD(args, MPS_KEY_CHAIN, chain);
if (ngen > 0)
MPS_ARGS_ADD(args, MPS_KEY_CHAIN, chain);
MPS_ARGS_DONE(args);
RESMUST(mps_pool_create_k(&pool, arena, pool_class, args));
} MPS_ARGS_END(args);
@ -276,6 +277,8 @@ static struct option longopts[] = {
{"depth", required_argument, NULL, 'd'},
{"preuse", required_argument, NULL, 'r'},
{"pupdate", required_argument, NULL, 'u'},
{"pin-leaf", no_argument, NULL, 'l'},
{"seed", required_argument, NULL, 'x'},
{NULL, 0, NULL, 0}
};
@ -295,10 +298,17 @@ static struct {
int main(int argc, char *argv[]) {
int ch;
unsigned i;
int k;
seed = rnd_seed();
for(k=0; k<argc; k++) {
printf("%s", argv[k]);
if (k + 1 < argc)
putchar(' ');
}
putchar('\n');
while ((ch = getopt_long(argc, argv, "ht:i:p:g:m:w:d:r:u:x:", longopts, NULL)) != -1)
while ((ch = getopt_long(argc, argv, "ht:i:p:g:m:w:d:r:u:lx:", longopts, NULL)) != -1)
switch (ch) {
case 't':
nthreads = (unsigned)strtoul(optarg, NULL, 10);
@ -360,6 +370,12 @@ int main(int argc, char *argv[]) {
case 'u':
pupdate = strtod(optarg, NULL);
break;
case 'l':
pinleaf = TRUE;
break;
case 'x':
seed = strtoul(optarg, NULL, 10);
break;
default:
fprintf(stderr,
"Usage: %s [option...] [test...]\n"
@ -390,6 +406,10 @@ int main(int argc, char *argv[]) {
" Probability of reusing a node (default %g)\n"
" -u p, --pupdate=p\n"
" Probability of updating a node (default %g)\n"
" -l --pin-leaf\n"
" Make a pinned object to use for leaves.\n"
" -x n, --seed=n\n"
" Random number seed (default from entropy)\n"
"Tests:\n"
" amc pool class AMC\n"
" ams pool class AMS\n",
@ -401,11 +421,6 @@ int main(int argc, char *argv[]) {
argc -= optind;
argv += optind;
if (ngen == 0) {
memcpy(gen, genDefault, sizeof(genDefault));
ngen = sizeof(genDefault) / sizeof(genDefault[0]);
}
printf("seed: %lu\n", seed);
while (argc > 0) {

17
mps/code/mpmtypes.h
View file

@ -373,23 +373,8 @@ enum {
/* .result-codes: Result Codes -- see <design/type/#res> */
/* These definitions must match <code/mps.h#result-codes>. */
/* This is checked by <code/mpsi.c#check.rc>. */
/* Changing this list entails changing the list in */
/* <code/mps.h#result-codes> and the check in <code/mpsi.c#check.rc> */
enum {
ResOK = 0, /* MPS_RES_OK */
ResFAIL, /* MPS_RES_FAIL */
ResRESOURCE, /* MPS_RES_RESOURCE */
ResMEMORY, /* MPS_RES_MEMORY */
ResLIMIT, /* MPS_RES_LIMIT */
/* note "LIMIT" does _not_ have usual end-of-enum meaning -rhsk */
ResUNIMPL, /* MPS_RES_UNIMPL */
ResIO, /* MPS_RES_IO */
ResCOMMIT_LIMIT, /* MPS_RES_COMMIT_LIMIT */
ResPARAM /* MPS_RES_PARAM */
};
_mps_ENUM_DEF(_mps_RES_ENUM, Res)
/* TraceStates -- see <design/trace/> */

30
mps/code/mps.h
View file

@ -77,21 +77,25 @@ typedef mps_word_t mps_clock_t; /* processor time */
typedef mps_word_t mps_label_t; /* telemetry label */
/* Result Codes */
/* .result-codes: Keep in sync with <code/mpmtypes.h#result-codes> */
/* and the check in <code/mpsi.c#check.rc> */
enum {
MPS_RES_OK = 0, /* success (always zero) */
MPS_RES_FAIL, /* unspecified failure */
MPS_RES_RESOURCE, /* unable to obtain resources */
MPS_RES_MEMORY, /* unable to obtain memory */
MPS_RES_LIMIT, /* limitation reached */
MPS_RES_UNIMPL, /* unimplemented facility */
MPS_RES_IO, /* system I/O error */
MPS_RES_COMMIT_LIMIT, /* arena commit limit exceeded */
MPS_RES_PARAM /* illegal user parameter value */
};
#define _mps_RES_ENUM(R, X) \
R(X, OK, "success (always zero)") \
R(X, FAIL, "unspecified failure") \
R(X, RESOURCE, "unable to obtain resources") \
R(X, MEMORY, "unable to obtain memory") \
R(X, LIMIT, "limitation reached") \
R(X, UNIMPL, "unimplemented facility") \
R(X, IO, "system I/O error") \
R(X, COMMIT_LIMIT, "arena commit limit exceeded") \
R(X, PARAM, "illegal user parameter value")
#define _mps_ENUM_DEF_ROW(prefix, ident, doc) prefix##ident,
#define _mps_ENUM_DEF(REL, prefix) \
enum { \
REL(_mps_ENUM_DEF_ROW, prefix) \
_mps_##prefix##LIMIT \
};
_mps_ENUM_DEF(_mps_RES_ENUM, MPS_RES_)
/* Format and Root Method Types */
/* see design.mps.root-interface */

143
mps/code/mps.xcodeproj/project.pbxproj
View file

@ -39,12 +39,14 @@
2291A5C0175CAB5F001D4920 /* PBXTargetDependency */,
3114A677156E961C001E0AA3 /* PBXTargetDependency */,
3114A612156E943B001E0AA3 /* PBXTargetDependency */,
22B2BC3D18B643B300C33E63 /* PBXTargetDependency */,
2291A5E6175CB207001D4920 /* PBXTargetDependency */,
2291A5E8175CB20E001D4920 /* PBXTargetDependency */,
3114A65B156E95B4001E0AA3 /* PBXTargetDependency */,
3114A5CC156E932C001E0AA3 /* PBXTargetDependency */,
3114A5EA156E93C4001E0AA3 /* PBXTargetDependency */,
224CC79D175E187C002FF81B /* PBXTargetDependency */,
22B2BC3F18B643B700C33E63 /* PBXTargetDependency */,
31D60034156D3D5A00337B26 /* PBXTargetDependency */,
3114A5A0156E915A001E0AA3 /* PBXTargetDependency */,
3114A6A7156E9739001E0AA3 /* PBXTargetDependency */,
@ -54,6 +56,8 @@
31D6004F156D3EF700337B26 /* PBXTargetDependency */,
3114A5B6156E92DC001E0AA3 /* PBXTargetDependency */,
3104B002156D37CB000A585A /* PBXTargetDependency */,
22B2BC3918B643AD00C33E63 /* PBXTargetDependency */,
22B2BC3B18B643B000C33E63 /* PBXTargetDependency */,
3104B04A156D3AE4000A585A /* PBXTargetDependency */,
31D6009D156D404B00337B26 /* PBXTargetDependency */,
3114A62E156E94AA001E0AA3 /* PBXTargetDependency */,
@ -94,6 +98,8 @@
2291A5DD175CB05F001D4920 /* libmps.a in Frameworks */ = {isa = PBXBuildFile; fileRef = 31EEABFB156AAF9D00714D05 /* libmps.a */; };
2291A5E4175CB076001D4920 /* exposet0.c in Sources */ = {isa = PBXBuildFile; fileRef = 2291A5AA175CAA9B001D4920 /* exposet0.c */; };
2291A5ED175CB5E2001D4920 /* fbmtest.c in Sources */ = {isa = PBXBuildFile; fileRef = 2291A5E9175CB4EC001D4920 /* fbmtest.c */; };
22B2BC2E18B6434F00C33E63 /* mps.c in Sources */ = {isa = PBXBuildFile; fileRef = 31A47BA3156C1E130039B1C2 /* mps.c */; };
22B2BC3718B6437C00C33E63 /* scheme-advanced.c in Sources */ = {isa = PBXBuildFile; fileRef = 22B2BC2B18B6434000C33E63 /* scheme-advanced.c */; };
22FA176916E8D6FC0098B23F /* fmtdy.c in Sources */ = {isa = PBXBuildFile; fileRef = 3124CAC6156BE48D00753214 /* fmtdy.c */; };
22FA176A16E8D6FC0098B23F /* fmtdytst.c in Sources */ = {isa = PBXBuildFile; fileRef = 3124CAC7156BE48D00753214 /* fmtdytst.c */; };
22FA176B16E8D6FC0098B23F /* fmthe.c in Sources */ = {isa = PBXBuildFile; fileRef = 3124CAE4156BE6D500753214 /* fmthe.c */; };
@ -318,6 +324,34 @@
remoteGlobalIDString = 2291A5C1175CAFCA001D4920;
remoteInfo = expt825;
};
22B2BC3818B643AD00C33E63 /* PBXContainerItemProxy */ = {
isa = PBXContainerItemProxy;
containerPortal = 31EEABDA156AAE9E00714D05 /* Project object */;
proxyType = 1;
remoteGlobalIDString = 31FCAE0917692403008C034C;
remoteInfo = scheme;
};
22B2BC3A18B643B000C33E63 /* PBXContainerItemProxy */ = {
isa = PBXContainerItemProxy;
containerPortal = 31EEABDA156AAE9E00714D05 /* Project object */;
proxyType = 1;
remoteGlobalIDString = 22B2BC2C18B6434F00C33E63;
remoteInfo = "scheme-advanced";
};
22B2BC3C18B643B300C33E63 /* PBXContainerItemProxy */ = {
isa = PBXContainerItemProxy;
containerPortal = 31EEABDA156AAE9E00714D05 /* Project object */;
proxyType = 1;
remoteGlobalIDString = 318DA8C31892B0F30089718C;
remoteInfo = djbench;
};
22B2BC3E18B643B700C33E63 /* PBXContainerItemProxy */ = {
isa = PBXContainerItemProxy;
containerPortal = 31EEABDA156AAE9E00714D05 /* Project object */;
proxyType = 1;
remoteGlobalIDString = 6313D46718A400B200EB03EF;
remoteInfo = gcbench;
};
22CDE92D16E9EB9300366D0A /* PBXContainerItemProxy */ = {
isa = PBXContainerItemProxy;
containerPortal = 31EEABDA156AAE9E00714D05 /* Project object */;
@ -812,6 +846,15 @@
);
runOnlyForDeploymentPostprocessing = 1;
};
22B2BC3118B6434F00C33E63 /* CopyFiles */ = {
isa = PBXCopyFilesBuildPhase;
buildActionMask = 2147483647;
dstPath = /usr/share/man/man1/;
dstSubfolderSpec = 0;
files = (
);
runOnlyForDeploymentPostprocessing = 1;
};
22FA177016E8D6FC0098B23F /* CopyFiles */ = {
isa = PBXCopyFilesBuildPhase;
buildActionMask = 2147483647;
@ -1155,6 +1198,8 @@
2291A5EE175CB768001D4920 /* freelist.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = freelist.c; sourceTree = "<group>"; };
2291A5EF175CB768001D4920 /* freelist.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = freelist.h; sourceTree = "<group>"; };
2291A5F0175CB7A4001D4920 /* testlib.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = testlib.h; sourceTree = "<group>"; };
22B2BC2B18B6434000C33E63 /* scheme-advanced.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; name = "scheme-advanced.c"; path = "../example/scheme/scheme-advanced.c"; sourceTree = "<group>"; };
22B2BC3618B6434F00C33E63 /* scheme-advanced */ = {isa = PBXFileReference; explicitFileType = "compiled.mach-o.executable"; includeInIndex = 0; path = "scheme-advanced"; sourceTree = BUILT_PRODUCTS_DIR; };
22FA177516E8D6FC0098B23F /* amcssth */ = {isa = PBXFileReference; explicitFileType = "compiled.mach-o.executable"; includeInIndex = 0; path = amcssth; sourceTree = BUILT_PRODUCTS_DIR; };
22FA177616E8D7A80098B23F /* amcssth.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = amcssth.c; sourceTree = "<group>"; };
2D07B96C1636FC7200DB751B /* eventsql.c */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.c; path = eventsql.c; sourceTree = "<group>"; };
@ -1454,6 +1499,13 @@
);
runOnlyForDeploymentPostprocessing = 0;
};
22B2BC3018B6434F00C33E63 /* Frameworks */ = {
isa = PBXFrameworksBuildPhase;
buildActionMask = 2147483647;
files = (
);
runOnlyForDeploymentPostprocessing = 0;
};
22FA176E16E8D6FC0098B23F /* Frameworks */ = {
isa = PBXFrameworksBuildPhase;
buildActionMask = 2147483647;
@ -1986,6 +2038,7 @@
31FCAE0A17692403008C034C /* scheme */,
318DA8CD1892B0F30089718C /* djbench */,
6313D47218A400B200EB03EF /* gcbench */,
22B2BC3618B6434F00C33E63 /* scheme-advanced */,
);
name = Products;
sourceTree = "<group>";
@ -2142,6 +2195,7 @@
31FCAE171769247F008C034C /* Scheme */ = {
isa = PBXGroup;
children = (
22B2BC2B18B6434000C33E63 /* scheme-advanced.c */,
31FCAE18176924D4008C034C /* scheme.c */,
);
name = Scheme;
@ -2232,6 +2286,23 @@
productReference = 2291A5E3175CB05F001D4920 /* exposet0 */;
productType = "com.apple.product-type.tool";
};
22B2BC2C18B6434F00C33E63 /* scheme-advanced */ = {
isa = PBXNativeTarget;
buildConfigurationList = 22B2BC3218B6434F00C33E63 /* Build configuration list for PBXNativeTarget "scheme-advanced" */;
buildPhases = (
22B2BC2D18B6434F00C33E63 /* Sources */,
22B2BC3018B6434F00C33E63 /* Frameworks */,
22B2BC3118B6434F00C33E63 /* CopyFiles */,
);
buildRules = (
);
dependencies = (
);
name = "scheme-advanced";
productName = scheme;
productReference = 22B2BC3618B6434F00C33E63 /* scheme-advanced */;
productType = "com.apple.product-type.tool";
};
22FA176416E8D6FC0098B23F /* amcssth */ = {
isa = PBXNativeTarget;
buildConfigurationList = 22FA177116E8D6FC0098B23F /* Build configuration list for PBXNativeTarget "amcssth" */;
@ -2913,6 +2984,7 @@
projectRoot = "";
targets = (
3104AFF1156D37A0000A585A /* all */,
22CDE8EF16E9E97D00366D0A /* testrun */,
31EEABFA156AAF9D00714D05 /* mps */,
3114A632156E94DB001E0AA3 /* abqtest */,
3124CAEA156BE7F300753214 /* amcss */,
@ -2927,12 +2999,14 @@
2291A5AC175CAB2F001D4920 /* awlutth */,
3114A661156E95D9001E0AA3 /* btcv */,
3114A604156E9430001E0AA3 /* bttest */,
3114A64B156E9596001E0AA3 /* fbmtest */,
318DA8C31892B0F30089718C /* djbench */,
2291A5D3175CB05F001D4920 /* exposet0 */,
2291A5C1175CAFCA001D4920 /* expt825 */,
3114A64B156E9596001E0AA3 /* fbmtest */,
3114A5BC156E9315001E0AA3 /* finalcv */,
3114A5D5156E93A0001E0AA3 /* finaltest */,
224CC78C175E1821002FF81B /* fotest */,
6313D46718A400B200EB03EF /* gcbench */,
31D60026156D3D3E00337B26 /* lockcov */,
3114A58F156E913C001E0AA3 /* locv */,
3114A694156E971B001E0AA3 /* messtest */,
@ -2951,10 +3025,8 @@
3114A6C5156E9815001E0AA3 /* mpseventcnv */,
2D07B9701636FC9900DB751B /* mpseventsql */,
2D604B9B16514B1A003AAF46 /* mpseventtxt */,
22CDE8EF16E9E97D00366D0A /* testrun */,
31FCAE0917692403008C034C /* scheme */,
318DA8C31892B0F30089718C /* djbench */,
6313D46718A400B200EB03EF /* gcbench */,
22B2BC2C18B6434F00C33E63 /* scheme-advanced */,
);
};
/* End PBXProject section */
@ -3023,6 +3095,15 @@
);
runOnlyForDeploymentPostprocessing = 0;
};
22B2BC2D18B6434F00C33E63 /* Sources */ = {
isa = PBXSourcesBuildPhase;
buildActionMask = 2147483647;
files = (
22B2BC2E18B6434F00C33E63 /* mps.c in Sources */,
22B2BC3718B6437C00C33E63 /* scheme-advanced.c in Sources */,
);
runOnlyForDeploymentPostprocessing = 0;
};
22FA176716E8D6FC0098B23F /* Sources */ = {
isa = PBXSourcesBuildPhase;
buildActionMask = 2147483647;
@ -3457,6 +3538,26 @@
target = 2291A5C1175CAFCA001D4920 /* expt825 */;
targetProxy = 2291A5E7175CB20E001D4920 /* PBXContainerItemProxy */;
};
22B2BC3918B643AD00C33E63 /* PBXTargetDependency */ = {
isa = PBXTargetDependency;
target = 31FCAE0917692403008C034C /* scheme */;
targetProxy = 22B2BC3818B643AD00C33E63 /* PBXContainerItemProxy */;
};
22B2BC3B18B643B000C33E63 /* PBXTargetDependency */ = {
isa = PBXTargetDependency;
target = 22B2BC2C18B6434F00C33E63 /* scheme-advanced */;
targetProxy = 22B2BC3A18B643B000C33E63 /* PBXContainerItemProxy */;
};
22B2BC3D18B643B300C33E63 /* PBXTargetDependency */ = {
isa = PBXTargetDependency;
target = 318DA8C31892B0F30089718C /* djbench */;
targetProxy = 22B2BC3C18B643B300C33E63 /* PBXContainerItemProxy */;
};
22B2BC3F18B643B700C33E63 /* PBXTargetDependency */ = {
isa = PBXTargetDependency;
target = 6313D46718A400B200EB03EF /* gcbench */;
targetProxy = 22B2BC3E18B643B700C33E63 /* PBXContainerItemProxy */;
};
22CDE92E16E9EB9300366D0A /* PBXTargetDependency */ = {
isa = PBXTargetDependency;
target = 3104AFF1156D37A0000A585A /* all */;
@ -3857,6 +3958,30 @@
};
name = Release;
};
22B2BC3318B6434F00C33E63 /* Debug */ = {
isa = XCBuildConfiguration;
buildSettings = {
GCC_TREAT_WARNINGS_AS_ERRORS = NO;
PRODUCT_NAME = "scheme-advanced";
};
name = Debug;
};
22B2BC3418B6434F00C33E63 /* Release */ = {
isa = XCBuildConfiguration;
buildSettings = {
GCC_TREAT_WARNINGS_AS_ERRORS = NO;
PRODUCT_NAME = "scheme-advanced";
};
name = Release;
};
22B2BC3518B6434F00C33E63 /* RASH */ = {
isa = XCBuildConfiguration;
buildSettings = {
GCC_TREAT_WARNINGS_AS_ERRORS = NO;
PRODUCT_NAME = "scheme-advanced";
};
name = RASH;
};
22CDE8F116E9E97E00366D0A /* Debug */ = {
isa = XCBuildConfiguration;
buildSettings = {
@ -5142,6 +5267,16 @@
defaultConfigurationIsVisible = 0;
defaultConfigurationName = Release;
};
22B2BC3218B6434F00C33E63 /* Build configuration list for PBXNativeTarget "scheme-advanced" */ = {
isa = XCConfigurationList;
buildConfigurations = (
22B2BC3318B6434F00C33E63 /* Debug */,
22B2BC3418B6434F00C33E63 /* Release */,
22B2BC3518B6434F00C33E63 /* RASH */,
);
defaultConfigurationIsVisible = 0;
defaultConfigurationName = Release;
};
22CDE8F016E9E97E00366D0A /* Build configuration list for PBXAggregateTarget "testrun" */ = {
isa = XCConfigurationList;
buildConfigurations = (

11
mps/code/mpsi.c
View file

@ -72,18 +72,7 @@ SRCID(mpsi, "$Id$");
static Bool mpsi_check(void)
{
/* .check.rc: Check that external and internal result codes match. */
/* See <code/mps.h#result-codes> and <code/mpmtypes.h#result-codes>. */
/* Also see .check.enum.cast. */
CHECKL(COMPATTYPE(mps_res_t, Res));
CHECKL((int)MPS_RES_OK == (int)ResOK);
CHECKL((int)MPS_RES_FAIL == (int)ResFAIL);
CHECKL((int)MPS_RES_RESOURCE == (int)ResRESOURCE);
CHECKL((int)MPS_RES_MEMORY == (int)ResMEMORY);
CHECKL((int)MPS_RES_LIMIT == (int)ResLIMIT);
CHECKL((int)MPS_RES_UNIMPL == (int)ResUNIMPL);
CHECKL((int)MPS_RES_IO == (int)ResIO);
CHECKL((int)MPS_RES_COMMIT_LIMIT == (int)ResCOMMIT_LIMIT);
/* Check that external and internal message types match. */
/* See <code/mps.h#message.types> and */

16
mps/code/poolmv2.c
View file

@ -1208,13 +1208,27 @@ static Res MVTSegAlloc(Seg *segReturn, MVT mvt, Size size,
*/
static void MVTSegFree(MVT mvt, Seg seg)
{
Size size = SegSize(seg);
Buffer buffer;
Size size;
size = SegSize(seg);
AVER(mvt->available >= size);
mvt->available -= size;
mvt->size -= size;
mvt->availLimit = mvt->size * mvt->fragLimit / 100;
AVER(mvt->size == mvt->allocated + mvt->available + mvt->unavailable);
/* If the client program allocates the exactly the entire buffer then
frees the allocated memory then we'll try to free the segment with
the buffer still attached. It's safe, but we must detach the buffer
first. See job003520 and job003672. */
buffer = SegBuffer(seg);
if (buffer != NULL) {
AVER(BufferAP(buffer)->init == SegLimit(seg));
BufferDetach(buffer, MVT2Pool(mvt));
}
SegFree(seg);
METER_ACC(mvt->segFrees, size);
}

6
mps/code/protxc.c
View file

@ -1,7 +1,7 @@
/* protxc.c: PROTECTION EXCEPTION HANDLER FOR OS X MACH
*
* $Id$
* Copyright (c) 2013 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2013-2014 Ravenbrook Limited. See end of file for license.
*
* This is the protection exception handling code for OS X using the
* Mach interface (not pthreads).
@ -283,9 +283,9 @@ static void protCatchOne(void)
*/
static void *protCatchThread(void *p) {
UNUSED(p);
for (;;)
protCatchOne();
return p;
}
@ -403,7 +403,7 @@ void ProtSetup(void)
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2013 Ravenbrook Limited <http://www.ravenbrook.com/>.
* Copyright (C) 2013-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* All rights reserved. This is an open source license. Contact
* Ravenbrook for commercial licensing options.
*

34
mps/code/testlib.c
View file

@ -326,6 +326,17 @@ void rnd_state_set_v2(unsigned long seed0_v2)
}
/* res_strings -- human readable MPS result codes */
static struct {
const char *ident;
const char *doc;
} res_strings[] = {
#define RES_STRINGS_ROW(X, ident, doc) {#ident, #doc},
_mps_RES_ENUM(RES_STRINGS_ROW, X)
};
/* verror -- die with message */
void verror(const char *format, va_list args)
@ -359,26 +370,27 @@ void error(const char *format, ...)
}
/* die -- Test a return code, and exit on error */
void die(mps_res_t res, const char *s)
{
if (res != MPS_RES_OK) {
error("\n%s: %d\n", s, res);
}
}
/* die_expect -- Test a return code, and exit on unexpected result */
void die_expect(mps_res_t res, mps_res_t expected, const char *s)
{
if (res != expected) {
error("\n%s: %d\n", s, res);
if (0 <= res && (unsigned)res < sizeof(res_strings) / sizeof(res_strings[0]))
error("\n%s: %s: %s\n", s, res_strings[res].ident, res_strings[res].doc);
else
error("\n%s: %d: unknown result code\n", s, res);
}
}
/* die -- Test a return code, and exit on error */
void die(mps_res_t res, const char *s)
{
die_expect(res, MPS_RES_OK, s);
}
/* cdie -- Test a C boolean, and exit on error */
void cdie(int res, const char *s)

101
mps/example/scheme/scheme-advanced.c
View file

@ -1,6 +1,6 @@
/* scheme.c -- SCHEME INTERPRETER EXAMPLE FOR THE MEMORY POOL SYSTEM
*
* Copyright (c) 2001-2013 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
*
* This is a toy interpreter for a subset of the Scheme programming
* language <http://en.wikipedia.org/wiki/Scheme_%28programming_language%29>.
@ -54,6 +54,7 @@
#define unless(c) if(!(c))
#define LENGTH(array) (sizeof(array) / sizeof(array[0]))
#define UNUSED(var) ((void)var)
/* CONFIGURATION PARAMETERS */
@ -130,12 +131,12 @@ typedef struct integer_s {
typedef struct special_s {
type_t type; /* TYPE_SPECIAL */
char *name; /* printed representation, NUL terminated */
const char *name; /* printed representation, NUL terminated */
} special_s;
typedef struct operator_s {
type_t type; /* TYPE_OPERATOR */
char *name; /* printed name, NUL terminated */
const char *name; /* printed name, NUL terminated */
entry_t entry; /* entry point -- see eval() */
obj_t arguments, body; /* function arguments and code */
obj_t env, op_env; /* closure environments */
@ -397,7 +398,7 @@ static mps_ap_t weak_buckets_ap; /* allocation point for weak buckets */
* message.
*/
static void error(char *format, ...)
static void error(const char *format, ...)
{
va_list args;
@ -509,7 +510,7 @@ static obj_t make_symbol(obj_t name)
return obj;
}
static obj_t make_string(size_t length, char string[])
static obj_t make_string(size_t length, const char *string)
{
obj_t obj;
mps_addr_t addr;
@ -527,7 +528,7 @@ static obj_t make_string(size_t length, char string[])
return obj;
}
static obj_t make_special(char *string)
static obj_t make_special(const char *string)
{
obj_t obj;
mps_addr_t addr;
@ -543,7 +544,7 @@ static obj_t make_special(char *string)
return obj;
}
static obj_t make_operator(char *name,
static obj_t make_operator(const char *name,
entry_t entry, obj_t arguments,
obj_t body, obj_t env, obj_t op_env)
{
@ -715,18 +716,17 @@ static int isealpha(int c)
*/
static unsigned long hash(const char *s, size_t length) {
char c;
unsigned long h=0;
unsigned long c, h=0;
size_t i = 0;
switch(length % 4) {
do {
c=s[i++]; h+=(c<<17)^(c<<11)^(c<<5)^(c>>1);
c=(unsigned long)s[i++]; h+=(c<<17)^(c<<11)^(c<<5)^(c>>1);
case 3:
c=s[i++]; h^=(c<<14)+(c<<7)+(c<<4)+c;
c=(unsigned long)s[i++]; h^=(c<<14)+(c<<7)+(c<<4)+c;
case 2:
c=s[i++]; h^=(~c<<11)|((c<<3)^(c>>1));
c=(unsigned long)s[i++]; h^=(~c<<11)|((c<<3)^(c>>1));
case 1:
c=s[i++]; h-=(c<<16)|(c<<9)|(c<<2)|(c&3);
c=(unsigned long)s[i++]; h-=(c<<16)|(c<<9)|(c<<2)|(c&3);
case 0:
;
} while(i < length);
@ -757,9 +757,9 @@ static unsigned long eqv_hash(obj_t obj, mps_ld_t ld)
{
switch(TYPE(obj)) {
case TYPE_INTEGER:
return obj->integer.integer;
return (unsigned long)obj->integer.integer;
case TYPE_CHARACTER:
return obj->character.c;
return (unsigned long)obj->character.c;
default:
return eq_hash(obj, ld);
}
@ -783,6 +783,7 @@ static int eqvp(obj_t obj1, obj_t obj2)
static unsigned long string_hash(obj_t obj, mps_ld_t ld)
{
UNUSED(ld);
unless(TYPE(obj) == TYPE_STRING)
error("string-hash: argument must be a string");
return hash(obj->string.string, obj->string.length);
@ -972,7 +973,7 @@ static obj_t intern_string(obj_t name)
}
static obj_t intern(char *string)
static obj_t intern(const char *string)
{
return intern_string(make_string(strlen(string), string));
}
@ -1006,8 +1007,11 @@ static void port_close(obj_t port)
}
static void print(obj_t obj, unsigned depth, FILE *stream)
static void print(obj_t obj, long depth, FILE *stream)
{
if (depth < 0) {
depth = -1;
}
switch(TYPE(obj)) {
case TYPE_INTEGER: {
fprintf(stream, "%ld", obj->integer.integer);
@ -1179,11 +1183,11 @@ static obj_t read_integer(FILE *stream, int c)
static obj_t read_symbol(FILE *stream, int c)
{
int length = 0;
size_t length = 0;
char string[SYMMAX+1];
do {
string[length++] = tolower(c);
string[length++] = (char)tolower(c);
c = getc(stream);
} while(length < SYMMAX && (isalnum(c) || isealpha(c)));
@ -1200,7 +1204,7 @@ static obj_t read_symbol(FILE *stream, int c)
static obj_t read_string(FILE *stream, int c)
{
int length = 0;
size_t length = 0;
char string[STRMAX+1];
for(;;) {
@ -1223,7 +1227,7 @@ static obj_t read_string(FILE *stream, int c)
error("read: unknown escape '%c'", c);
}
}
string[length++] = c;
string[length++] = (char)c;
}
string[length] = '\0';
@ -1237,12 +1241,14 @@ static obj_t read(FILE *stream);
static obj_t read_quote(FILE *stream, int c)
{
UNUSED(c);
return make_pair(obj_quote, make_pair(read(stream), obj_empty));
}
static obj_t read_quasiquote(FILE *stream, int c)
{
UNUSED(c);
return make_pair(obj_quasiquote, make_pair(read(stream), obj_empty));
}
@ -1326,7 +1332,7 @@ static obj_t read_special(FILE *stream, int c)
c = getc(stream);
if(c == EOF)
error("read: end of file reading character literal");
return make_character(c);
return make_character((char)c);
}
case '(': { /* vector (R4RS 6.8) */
obj_t list = read_list(stream, c);
@ -1523,7 +1529,7 @@ static obj_t load(obj_t env, obj_t op_env, obj_t filename) {
* using the message given.
*/
static obj_t eval_list(obj_t env, obj_t op_env, obj_t list, char *message)
static obj_t eval_list(obj_t env, obj_t op_env, obj_t list, const char *message)
{
obj_t result, end, pair;
result = obj_empty;
@ -1548,7 +1554,7 @@ static obj_t eval_list(obj_t env, obj_t op_env, obj_t list, char *message)
* See eval_args and eval_args_rest for usage.
*/
static obj_t eval_args1(char *name, obj_t env, obj_t op_env,
static obj_t eval_args1(const char *name, obj_t env, obj_t op_env,
obj_t operands, unsigned n, va_list args)
{
unsigned i;
@ -1573,7 +1579,7 @@ static obj_t eval_args1(char *name, obj_t env, obj_t op_env,
* eval_args("foo", env, op_env, operands, 2, &arg1, &arg2);
*/
static void eval_args(char *name, obj_t env, obj_t op_env,
static void eval_args(const char *name, obj_t env, obj_t op_env,
obj_t operands, unsigned n, ...)
{
va_list args;
@ -1597,7 +1603,7 @@ static void eval_args(char *name, obj_t env, obj_t op_env,
* eval_args_rest("foo", env, op_env, operands, &rest, 2, &arg1, &arg2);
*/
static void eval_args_rest(char *name, obj_t env, obj_t op_env,
static void eval_args_rest(const char *name, obj_t env, obj_t op_env,
obj_t operands, obj_t *restp, unsigned n, ...)
{
va_list args;
@ -1702,6 +1708,8 @@ static obj_t entry_interpret(obj_t env, obj_t op_env, obj_t operator, obj_t oper
static obj_t entry_quote(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
UNUSED(env);
UNUSED(op_env);
unless(TYPE(operands) == TYPE_PAIR &&
CDR(operands) == obj_empty)
error("%s: illegal syntax", operator->operator.name);
@ -2721,7 +2729,7 @@ static obj_t entry_reverse(obj_t env, obj_t op_env, obj_t operator, obj_t operan
static obj_t entry_list_tail(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, k;
int i;
long i;
eval_args(operator->operator.name, env, op_env, operands, 2, &arg, &k);
unless(TYPE(k) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
@ -2744,7 +2752,7 @@ static obj_t entry_list_tail(obj_t env, obj_t op_env, obj_t operator, obj_t oper
static obj_t entry_list_ref(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, k, result;
int i;
long i;
eval_args(operator->operator.name, env, op_env, operands, 2, &arg, &k);
unless(TYPE(k) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
@ -3012,12 +3020,14 @@ static obj_t entry_make_vector(obj_t env, obj_t op_env, obj_t operator, obj_t op
eval_args_rest(operator->operator.name, env, op_env, operands, &rest, 1, &length);
unless(TYPE(length) == TYPE_INTEGER)
error("%s: first argument must be an integer", operator->operator.name);
unless(0 <= length->integer.integer)
error("%s: first argument is out of range", operator->operator.name);
unless(rest == obj_empty) {
unless(CDR(rest) == obj_empty)
error("%s: too many arguments", operator->operator.name);
fill = CAR(rest);
}
return make_vector(length->integer.integer, fill);
return make_vector((size_t)length->integer.integer, fill);
}
@ -3046,7 +3056,7 @@ static obj_t entry_vector_length(obj_t env, obj_t op_env, obj_t operator, obj_t
eval_args(operator->operator.name, env, op_env, operands, 1, &vector);
unless(TYPE(vector) == TYPE_VECTOR)
error("%s: argument must be a vector", operator->operator.name);
return make_integer(vector->vector.length);
return make_integer((long)vector->vector.length);
}
@ -3231,7 +3241,7 @@ static obj_t entry_make_string(obj_t env, obj_t op_env, obj_t operator, obj_t op
error("%s: too many arguments", operator->operator.name);
c = CAR(args)->character.c;
}
obj = make_string(k->integer.integer, NULL);
obj = make_string((size_t)k->integer.integer, NULL);
for (i = 0; i < k->integer.integer; ++i) {
obj->string.string[i] = c;
}
@ -3280,7 +3290,7 @@ static obj_t entry_string_length(obj_t env, obj_t op_env, obj_t operator, obj_t
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
return make_integer(arg->string.length);
return make_integer((long)arg->string.length);
}
@ -3343,7 +3353,7 @@ static obj_t entry_substring(obj_t env, obj_t op_env, obj_t operator, obj_t oper
&& start->integer.integer <= end->integer.integer
&& (size_t)end->integer.integer <= arg->string.length)
error("%s: arguments out of range", operator->operator.name);
length = end->integer.integer - start->integer.integer;
length = (size_t)end->integer.integer - (size_t)start->integer.integer;
obj = make_string(length, NULL);
strncpy(obj->string.string, &arg->string.string[start->integer.integer], length);
return obj;
@ -3462,7 +3472,7 @@ static obj_t entry_string_hash(obj_t env, obj_t op_env, obj_t operator, obj_t op
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
return make_integer(string_hash(arg, NULL));
return make_integer((long)string_hash(arg, NULL));
}
@ -3470,7 +3480,7 @@ static obj_t entry_eq_hash(obj_t env, obj_t op_env, obj_t operator, obj_t operan
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_integer(eq_hash(arg, NULL));
return make_integer((long)eq_hash(arg, NULL));
}
@ -3478,7 +3488,7 @@ static obj_t entry_eqv_hash(obj_t env, obj_t op_env, obj_t operator, obj_t opera
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_integer(eqv_hash(arg, NULL));
return make_integer((long)eqv_hash(arg, NULL));
}
@ -3495,7 +3505,7 @@ static obj_t make_hashtable(obj_t operator, obj_t rest, hash_t hashf, cmp_t cmpf
error("%s: first argument must be an integer", operator->operator.name);
unless(arg->integer.integer > 0)
error("%s: first argument must be positive", operator->operator.name);
length = arg->integer.integer;
length = (size_t)arg->integer.integer;
}
return make_table(length, hashf, cmpf, weak_key, weak_value);
}
@ -3638,7 +3648,7 @@ static obj_t entry_hashtable_size(obj_t env, obj_t op_env, obj_t operator, obj_t
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_TABLE)
error("%s: first argument must be a hash table", operator->operator.name);
return make_integer(table_size(arg));
return make_integer((long)table_size(arg));
}
@ -3754,7 +3764,7 @@ static obj_t entry_gc(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
/* special table */
static struct {char *name; obj_t *varp;} sptab[] = {
static struct {const char *name; obj_t *varp;} sptab[] = {
{"()", &obj_empty},
{"#[eof]", &obj_eof},
{"#[error]", &obj_error},
@ -3769,7 +3779,7 @@ static struct {char *name; obj_t *varp;} sptab[] = {
/* initial symbol table */
static struct {char *name; obj_t *varp;} isymtab[] = {
static struct {const char *name; obj_t *varp;} isymtab[] = {
{"quote", &obj_quote},
{"lambda", &obj_lambda},
{"begin", &obj_begin},
@ -3782,7 +3792,7 @@ static struct {char *name; obj_t *varp;} isymtab[] = {
/* operator table */
static struct {char *name; entry_t entry;} optab[] = {
static struct {const char *name; entry_t entry;} optab[] = {
{"quote", entry_quote},
{"define", entry_define},
{"set!", entry_set},
@ -3803,7 +3813,7 @@ static struct {char *name; entry_t entry;} optab[] = {
/* function table */
static struct {char *name; entry_t entry;} funtab[] = {
static struct {const char *name; entry_t entry;} funtab[] = {
{"not", entry_not},
{"boolean?", entry_booleanp},
{"eqv?", entry_eqvp},
@ -4107,7 +4117,7 @@ static void obj_fwd(mps_addr_t old, mps_addr_t new)
{
obj_t obj = old;
mps_addr_t limit = obj_skip(old);
size_t size = (char *)limit - (char *)old;
size_t size = (size_t)((char *)limit - (char *)old);
assert(size >= ALIGN_WORD(sizeof(fwd2_s)));
if (size == ALIGN_WORD(sizeof(fwd2_s))) {
TYPE(obj) = TYPE_FWD2;
@ -4218,6 +4228,8 @@ static mps_addr_t buckets_find_dependent(mps_addr_t addr)
static mps_res_t globals_scan(mps_ss_t ss, void *p, size_t s)
{
UNUSED(p);
UNUSED(s);
MPS_SCAN_BEGIN(ss) {
size_t i;
for (i = 0; i < LENGTH(sptab); ++i)
@ -4509,6 +4521,7 @@ int main(int argc, char *argv[])
MPS_ARGS_ADD(args, MPS_KEY_FMT_ALIGN, ALIGNMENT);
MPS_ARGS_ADD(args, MPS_KEY_FMT_SCAN, buckets_scan);
MPS_ARGS_ADD(args, MPS_KEY_FMT_SKIP, buckets_skip);
MPS_ARGS_DONE(args);
res = mps_fmt_create_k(&buckets_fmt, arena, args);
} MPS_ARGS_END(args);
if (res != MPS_RES_OK) error("Couldn't create buckets format");
@ -4592,7 +4605,7 @@ int main(int argc, char *argv[])
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2013 Ravenbrook Limited <http://www.ravenbrook.com/>.
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* All rights reserved. This is an open source license. Contact
* Ravenbrook for commercial licensing options.
*

91
mps/example/scheme/scheme.c
View file

@ -1,6 +1,6 @@
/* scheme.c -- SCHEME INTERPRETER EXAMPLE FOR THE MEMORY POOL SYSTEM
*
* Copyright (c) 2001-2013 Ravenbrook Limited. See end of file for license.
* Copyright (c) 2001-2014 Ravenbrook Limited. See end of file for license.
*
* This is a toy interpreter for a subset of the Scheme programming
* language <http://en.wikipedia.org/wiki/Scheme_%28programming_language%29>.
@ -55,6 +55,7 @@
#define unless(c) if(!(c))
#define LENGTH(array) (sizeof(array) / sizeof(array[0]))
#define UNUSED(var) ((void)var)
/* CONFIGURATION PARAMETERS */
@ -501,7 +502,7 @@ static obj_t make_symbol(size_t length, const char string[])
return obj;
}
static obj_t make_string(size_t length, char string[])
static obj_t make_string(size_t length, const char *string)
{
obj_t obj;
mps_addr_t addr;
@ -702,18 +703,17 @@ static int isealpha(int c)
*/
static unsigned long hash(const char *s, size_t length) {
char c;
unsigned long h=0;
unsigned long c, h=0;
size_t i = 0;
switch(length % 4) {
do {
c=s[i++]; h+=(c<<17)^(c<<11)^(c<<5)^(c>>1);
c=(unsigned long)s[i++]; h+=(c<<17)^(c<<11)^(c<<5)^(c>>1);
case 3:
c=s[i++]; h^=(c<<14)+(c<<7)+(c<<4)+c;
c=(unsigned long)s[i++]; h^=(c<<14)+(c<<7)+(c<<4)+c;
case 2:
c=s[i++]; h^=(~c<<11)|((c<<3)^(c>>1));
c=(unsigned long)s[i++]; h^=(~c<<11)|((c<<3)^(c>>1));
case 1:
c=s[i++]; h-=(c<<16)|(c<<9)|(c<<2)|(c&3);
c=(unsigned long)s[i++]; h-=(c<<16)|(c<<9)|(c<<2)|(c&3);
case 0:
;
} while(i < length);
@ -754,7 +754,7 @@ static obj_t *find(const char *string) {
static void rehash(void) {
obj_t *old_symtab = symtab;
unsigned old_symtab_size = symtab_size;
size_t old_symtab_size = symtab_size;
mps_root_t old_symtab_root = symtab_root;
unsigned i;
mps_addr_t ref;
@ -831,9 +831,9 @@ static unsigned long eqv_hash(obj_t obj, mps_ld_t ld)
{
switch(TYPE(obj)) {
case TYPE_INTEGER:
return obj->integer.integer;
return (unsigned long)obj->integer.integer;
case TYPE_CHARACTER:
return obj->character.c;
return (unsigned long)obj->character.c;
default:
return eq_hash(obj, ld);
}
@ -857,6 +857,7 @@ static int eqvp(obj_t obj1, obj_t obj2)
static unsigned long string_hash(obj_t obj, mps_ld_t ld)
{
UNUSED(ld);
unless(TYPE(obj) == TYPE_STRING)
error("string-hash: argument must be a string");
return hash(obj->string.string, obj->string.length);
@ -1028,8 +1029,11 @@ static void port_close(obj_t port)
}
static void print(obj_t obj, unsigned depth, FILE *stream)
static void print(obj_t obj, long depth, FILE *stream)
{
if (depth < 0) {
depth = -1;
}
switch(TYPE(obj)) {
case TYPE_INTEGER: {
fprintf(stream, "%ld", obj->integer.integer);
@ -1205,11 +1209,11 @@ static obj_t read_integer(FILE *stream, int c)
static obj_t read_symbol(FILE *stream, int c)
{
int length = 0;
size_t length = 0;
char string[SYMMAX+1];
do {
string[length++] = tolower(c);
string[length++] = (char)tolower(c);
c = getc(stream);
} while(length < SYMMAX && (isalnum(c) || isealpha(c)));
@ -1226,7 +1230,7 @@ static obj_t read_symbol(FILE *stream, int c)
static obj_t read_string(FILE *stream, int c)
{
int length = 0;
size_t length = 0;
char string[STRMAX+1];
for(;;) {
@ -1249,7 +1253,7 @@ static obj_t read_string(FILE *stream, int c)
error("read: unknown escape '%c'", c);
}
}
string[length++] = c;
string[length++] = (char)c;
}
string[length] = '\0';
@ -1263,12 +1267,14 @@ static obj_t read(FILE *stream);
static obj_t read_quote(FILE *stream, int c)
{
UNUSED(c);
return make_pair(obj_quote, make_pair(read(stream), obj_empty));
}
static obj_t read_quasiquote(FILE *stream, int c)
{
UNUSED(c);
return make_pair(obj_quasiquote, make_pair(read(stream), obj_empty));
}
@ -1352,7 +1358,7 @@ static obj_t read_special(FILE *stream, int c)
c = getc(stream);
if(c == EOF)
error("read: end of file reading character literal");
return make_character(c);
return make_character((char)c);
}
case '(': { /* vector (R4RS 6.8) */
obj_t list = read_list(stream, c);
@ -1728,6 +1734,8 @@ static obj_t entry_interpret(obj_t env, obj_t op_env, obj_t operator, obj_t oper
static obj_t entry_quote(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
UNUSED(env);
UNUSED(op_env);
unless(TYPE(operands) == TYPE_PAIR &&
CDR(operands) == obj_empty)
error("%s: illegal syntax", operator->operator.name);
@ -2747,7 +2755,7 @@ static obj_t entry_reverse(obj_t env, obj_t op_env, obj_t operator, obj_t operan
static obj_t entry_list_tail(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, k;
int i;
long i;
eval_args(operator->operator.name, env, op_env, operands, 2, &arg, &k);
unless(TYPE(k) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
@ -2770,7 +2778,7 @@ static obj_t entry_list_tail(obj_t env, obj_t op_env, obj_t operator, obj_t oper
static obj_t entry_list_ref(obj_t env, obj_t op_env, obj_t operator, obj_t operands)
{
obj_t arg, k, result;
int i;
long i;
eval_args(operator->operator.name, env, op_env, operands, 2, &arg, &k);
unless(TYPE(k) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
@ -3008,7 +3016,7 @@ static obj_t entry_integer_to_char(obj_t env, obj_t op_env, obj_t operator, obj_
error("%s: first argument must be an integer", operator->operator.name);
unless(0 <= arg->integer.integer)
error("%s: first argument is out of range", operator->operator.name);
return make_character(arg->integer.integer);
return make_character((char)arg->integer.integer);
}
@ -3037,12 +3045,14 @@ static obj_t entry_make_vector(obj_t env, obj_t op_env, obj_t operator, obj_t op
eval_args_rest(operator->operator.name, env, op_env, operands, &rest, 1, &length);
unless(TYPE(length) == TYPE_INTEGER)
error("%s: first argument must be an integer", operator->operator.name);
unless(0 <= length->integer.integer)
error("%s: first argument is out of range", operator->operator.name);
unless(rest == obj_empty) {
unless(CDR(rest) == obj_empty)
error("%s: too many arguments", operator->operator.name);
fill = CAR(rest);
}
return make_vector(length->integer.integer, fill);
return make_vector((size_t)length->integer.integer, fill);
}
@ -3071,7 +3081,7 @@ static obj_t entry_vector_length(obj_t env, obj_t op_env, obj_t operator, obj_t
eval_args(operator->operator.name, env, op_env, operands, 1, &vector);
unless(TYPE(vector) == TYPE_VECTOR)
error("%s: argument must be a vector", operator->operator.name);
return make_integer(vector->vector.length);
return make_integer((long)vector->vector.length);
}
@ -3088,8 +3098,9 @@ static obj_t entry_vector_ref(obj_t env, obj_t op_env, obj_t operator, obj_t ope
error("%s: first argument must be a vector", operator->operator.name);
unless(TYPE(index) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
unless(0 <= index->integer.integer && index->integer.integer < vector->vector.length)
error("%s: index %ld out of bounds of vector length %ld",
unless(0 <= index->integer.integer
&& (size_t)index->integer.integer < vector->vector.length)
error("%s: index %ld out of bounds of vector length %lu",
operator->operator.name, index->integer.integer, vector->vector.length);
return vector->vector.vector[index->integer.integer];
}
@ -3109,8 +3120,9 @@ static obj_t entry_vector_set(obj_t env, obj_t op_env, obj_t operator, obj_t ope
error("%s: first argument must be a vector", operator->operator.name);
unless(TYPE(index) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
unless(0 <= index->integer.integer && index->integer.integer < vector->vector.length)
error("%s: index %ld out of bounds of vector length %ld",
unless(0 <= index->integer.integer
&& (size_t)index->integer.integer < vector->vector.length)
error("%s: index %ld out of bounds of vector length %lu",
operator->operator.name, index->integer.integer, vector->vector.length);
vector->vector.vector[index->integer.integer] = obj;
return obj_undefined;
@ -3257,7 +3269,7 @@ static obj_t entry_make_string(obj_t env, obj_t op_env, obj_t operator, obj_t op
error("%s: too many arguments", operator->operator.name);
c = CAR(args)->character.c;
}
obj = make_string(k->integer.integer, NULL);
obj = make_string((size_t)k->integer.integer, NULL);
for (i = 0; i < k->integer.integer; ++i) {
obj->string.string[i] = c;
}
@ -3306,7 +3318,7 @@ static obj_t entry_string_length(obj_t env, obj_t op_env, obj_t operator, obj_t
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
return make_integer(arg->string.length);
return make_integer((long)arg->string.length);
}
@ -3323,7 +3335,8 @@ static obj_t entry_string_ref(obj_t env, obj_t op_env, obj_t operator, obj_t ope
error("%s: first argument must be a string", operator->operator.name);
unless(TYPE(k) == TYPE_INTEGER)
error("%s: second argument must be an integer", operator->operator.name);
unless(0 <= k->integer.integer && k->integer.integer < arg->string.length)
unless(0 <= k->integer.integer
&& (size_t)k->integer.integer < arg->string.length)
error("%s: second argument is out of range", operator->operator.name);
return make_character(arg->string.string[k->integer.integer]);
}
@ -3367,9 +3380,9 @@ static obj_t entry_substring(obj_t env, obj_t op_env, obj_t operator, obj_t oper
error("%s: third argument must be an integer", operator->operator.name);
unless(0 <= start->integer.integer
&& start->integer.integer <= end->integer.integer
&& end->integer.integer <= arg->string.length)
&& (size_t)end->integer.integer <= arg->string.length)
error("%s: arguments out of range", operator->operator.name);
length = end->integer.integer - start->integer.integer;
length = (size_t)end->integer.integer - (size_t)start->integer.integer;
obj = make_string(length, NULL);
strncpy(obj->string.string, &arg->string.string[start->integer.integer], length);
return obj;
@ -3488,7 +3501,7 @@ static obj_t entry_string_hash(obj_t env, obj_t op_env, obj_t operator, obj_t op
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_STRING)
error("%s: argument must be a string", operator->operator.name);
return make_integer(string_hash(arg, NULL));
return make_integer((long)string_hash(arg, NULL));
}
@ -3496,7 +3509,7 @@ static obj_t entry_eq_hash(obj_t env, obj_t op_env, obj_t operator, obj_t operan
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_integer(eq_hash(arg, NULL));
return make_integer((long)eq_hash(arg, NULL));
}
@ -3504,7 +3517,7 @@ static obj_t entry_eqv_hash(obj_t env, obj_t op_env, obj_t operator, obj_t opera
{
obj_t arg;
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
return make_integer(eqv_hash(arg, NULL));
return make_integer((long)eqv_hash(arg, NULL));
}
@ -3521,7 +3534,7 @@ static obj_t make_hashtable(obj_t operator, obj_t rest, hash_t hashf, cmp_t cmpf
error("%s: first argument must be an integer", operator->operator.name);
unless(arg->integer.integer > 0)
error("%s: first argument must be positive", operator->operator.name);
length = arg->integer.integer;
length = (size_t)arg->integer.integer;
}
return make_table(length, hashf, cmpf);
}
@ -3616,7 +3629,7 @@ static obj_t entry_hashtable_size(obj_t env, obj_t op_env, obj_t operator, obj_t
eval_args(operator->operator.name, env, op_env, operands, 1, &arg);
unless(TYPE(arg) == TYPE_TABLE)
error("%s: first argument must be a hash table", operator->operator.name);
return make_integer(table_size(arg));
return make_integer((long)table_size(arg));
}
@ -4097,7 +4110,7 @@ static void obj_fwd(mps_addr_t old, mps_addr_t new)
{
obj_t obj = old;
mps_addr_t limit = obj_skip(old);
size_t size = (char *)limit - (char *)old;
size_t size = (size_t)((char *)limit - (char *)old);
assert(size >= ALIGN_WORD(sizeof(fwd2_s)));
if (size == ALIGN_WORD(sizeof(fwd2_s))) {
TYPE(obj) = TYPE_FWD2;
@ -4143,6 +4156,8 @@ static void obj_pad(mps_addr_t addr, size_t size)
static mps_res_t globals_scan(mps_ss_t ss, void *p, size_t s)
{
UNUSED(p);
UNUSED(s);
MPS_SCAN_BEGIN(ss) {
size_t i;
for (i = 0; i < LENGTH(sptab); ++i)
@ -4470,7 +4485,7 @@ int main(int argc, char *argv[])
/* C. COPYRIGHT AND LICENSE
*
* Copyright (C) 2001-2013 Ravenbrook Limited <http://www.ravenbrook.com/>.
* Copyright (C) 2001-2014 Ravenbrook Limited <http://www.ravenbrook.com/>.
* All rights reserved. This is an open source license. Contact
* Ravenbrook for commercial licensing options.
*