diff --git a/mps/code/gcbench.c b/mps/code/gcbench.c index 77886851d41..071c3de0331 100644 --- a/mps/code/gcbench.c +++ b/mps/code/gcbench.c @@ -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 0) { diff --git a/mps/code/mpmtypes.h b/mps/code/mpmtypes.h index b35534d0167..9aac8322b35 100644 --- a/mps/code/mpmtypes.h +++ b/mps/code/mpmtypes.h @@ -373,23 +373,8 @@ enum { /* .result-codes: Result Codes -- see */ -/* These definitions must match . */ -/* This is checked by . */ -/* Changing this list entails changing the list in */ -/* and the check in */ -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 */ diff --git a/mps/code/mps.h b/mps/code/mps.h index 6cbf1e180b4..94a287cb9aa 100644 --- a/mps/code/mps.h +++ b/mps/code/mps.h @@ -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 */ -/* and the check in */ -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 */ diff --git a/mps/code/mps.xcodeproj/project.pbxproj b/mps/code/mps.xcodeproj/project.pbxproj index 2157a0e2f7f..9524465561a 100644 --- a/mps/code/mps.xcodeproj/project.pbxproj +++ b/mps/code/mps.xcodeproj/project.pbxproj @@ -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 = ""; }; 2291A5EF175CB768001D4920 /* freelist.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = freelist.h; sourceTree = ""; }; 2291A5F0175CB7A4001D4920 /* testlib.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = testlib.h; sourceTree = ""; }; + 22B2BC2B18B6434000C33E63 /* scheme-advanced.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; name = "scheme-advanced.c"; path = "../example/scheme/scheme-advanced.c"; sourceTree = ""; }; + 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 = ""; }; 2D07B96C1636FC7200DB751B /* eventsql.c */ = {isa = PBXFileReference; lastKnownFileType = sourcecode.c.c; path = eventsql.c; sourceTree = ""; }; @@ -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 = ""; @@ -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 = ( diff --git a/mps/code/mpsi.c b/mps/code/mpsi.c index 8aa7876a939..eb7fdb89558 100644 --- a/mps/code/mpsi.c +++ b/mps/code/mpsi.c @@ -72,18 +72,7 @@ SRCID(mpsi, "$Id$"); static Bool mpsi_check(void) { - /* .check.rc: Check that external and internal result codes match. */ - /* See and . */ - /* 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 and */ diff --git a/mps/code/poolmv2.c b/mps/code/poolmv2.c index 0c4d7e50ca6..16f11060e05 100644 --- a/mps/code/poolmv2.c +++ b/mps/code/poolmv2.c @@ -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); } diff --git a/mps/code/protxc.c b/mps/code/protxc.c index fbd399b4878..8f62bb3a5df 100644 --- a/mps/code/protxc.c +++ b/mps/code/protxc.c @@ -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 . + * Copyright (C) 2013-2014 Ravenbrook Limited . * All rights reserved. This is an open source license. Contact * Ravenbrook for commercial licensing options. * diff --git a/mps/code/testlib.c b/mps/code/testlib.c index e9dd48e050b..2bed23b0f6f 100644 --- a/mps/code/testlib.c +++ b/mps/code/testlib.c @@ -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) diff --git a/mps/example/scheme/scheme-advanced.c b/mps/example/scheme/scheme-advanced.c index 1fceda68229..837556b333b 100644 --- a/mps/example/scheme/scheme-advanced.c +++ b/mps/example/scheme/scheme-advanced.c @@ -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 . @@ -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 . + * Copyright (C) 2001-2014 Ravenbrook Limited . * All rights reserved. This is an open source license. Contact * Ravenbrook for commercial licensing options. * diff --git a/mps/example/scheme/scheme.c b/mps/example/scheme/scheme.c index f790a9d1e03..4b825581bc1 100644 --- a/mps/example/scheme/scheme.c +++ b/mps/example/scheme/scheme.c @@ -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 . @@ -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 . + * Copyright (C) 2001-2014 Ravenbrook Limited . * All rights reserved. This is an open source license. Contact * Ravenbrook for commercial licensing options. *