1 /*=========================================================================== 2 * Filename : test-storage.c 3 * About : scheme object representation and accessor test 4 * 5 * Copyright (C) 2006 Jun Inoue <jun.lambda@gmail.com> 6 * Copyright (c) 2007-2008 SigScheme Project <uim-en AT googlegroups.com> 7 * 8 * All rights reserved. 9 * 10 * Redistribution and use in source and binary forms, with or without 11 * modification, are permitted provided that the following conditions 12 * are met: 13 * 14 * 1. Redistributions of source code must retain the above copyright 15 * notice, this list of conditions and the following disclaimer. 16 * 2. Redistributions in binary form must reproduce the above copyright 17 * notice, this list of conditions and the following disclaimer in the 18 * documentation and/or other materials provided with the distribution. 19 * 3. Neither the name of authors nor the names of its contributors 20 * may be used to endorse or promote products derived from this software 21 * without specific prior written permission. 22 * 23 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS 24 * IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, 25 * THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR 26 * PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR 27 * CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, 28 * EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, 29 * PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; 30 * OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, 31 * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR 32 * OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF 33 * ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 34 ===========================================================================*/ 35 36 #include <string.h> 37 #include <stdio.h> 38 #include <stdlib.h> 39 40 #include <sigscheme/config.h> 41 #if (!SCM_USE_CHAR || !SCM_USE_VECTOR) 42 #define TST_EXCLUDE_THIS 43 #endif 44 45 #ifndef EXPAND 46 #include "sscm-test.h" 47 #include "sigschemeinternal.h" 48 #endif 49 50 #ifndef TST_EXCLUDE_THIS 51 52 #include "utils.c" 53 54 #define STR(s) #s 55 #define TST TST_COND 56 57 typedef ScmObj OBJ; 58 typedef void *PTR; 59 typedef char *STR; 60 typedef scm_int_t INT; 61 62 #define TST1(o, typ, field, ftyp, fval, context) \ 63 do { \ 64 ftyp _fv = (fval); \ 65 TST_COND(SCM_##typ##P(o), STR(SCM_##typ##P()) " " context); \ 66 TST_ASSERT(!TST_FAILED); \ 67 TST_EQ_##ftyp(_fv, SCM_##typ##_##field(o), \ 68 STR(SCM_##typ##_##field()) " " context); \ 69 } while (0) 70 71 #define TST2(o, typ, f1, f1typ, f1val, f2, f2typ, f2val, context) \ 72 do { \ 73 f1typ _f1v = (f1val); \ 74 f2typ _f2v = (f2val); \ 75 TST1(o, typ, f1, f1typ, _f1v, context); \ 76 TST1(o, typ, f2, f2typ, _f2v, context); \ 77 } while (0) 78 79 #define TST_INIT2(o, typ, f1, f1typ, f1val, f2, f2typ, f2val) \ 80 do { \ 81 f1typ f1v = (f1val); \ 82 f2typ f2v = (f2val); \ 83 (o) = SCM_MAKE_##typ(f1v, f2v); \ 84 TST2(o, typ, f1, f1typ, f1v, \ 85 f2, f2typ, f2v, \ 86 "on fresh " #typ); \ 87 } while (0) 88 89 #define TST_INIT1(o, typ, field, ftyp, fval) \ 90 do { \ 91 ftyp fv = (fval); \ 92 (o) = SCM_MAKE_##typ(fv); \ 93 TST1(o, typ, field, ftyp, fv, "on fresh " #typ); \ 94 } while (0) 95 96 #define TST_SET1(o, typ, field, ftyp, fval) \ 97 do { \ 98 ftyp fnew = (fval); \ 99 SCM_##typ##_SET_##field((o), fnew); \ 100 TST1(o, typ, field, ftyp, fnew, "after setting " #field); \ 101 } while (0) 102 103 #define TST_SET2(o, typ, f1, f1typ, f1val, f2, f2typ, f2val) \ 104 do { \ 105 f2typ f2orig = SCM_##typ##_##f2(o); \ 106 f1typ f1new = (f1val); \ 107 f2typ f2new = (f2val); \ 108 SCM_##typ##_SET_##f1((o), f1new); \ 109 TST2(o, typ, f1, f1typ, f1new, \ 110 f2, f2typ, f2orig, \ 111 "after setting " #f1); \ 112 SCM_##typ##_SET_##f2((o), f2new); \ 113 TST2(o, typ, f1, f1typ, f1new, \ 114 f2, f2typ, f2new, \ 115 "after setting " #f2); \ 116 } while (0) 117 118 #define TST_EXPR(expr) TST_COND((expr), #expr) 119 120 121 TST_CASE("eq? and constants") 122 { 123 ScmObj obj; 124 TST_EQ(SCM_NULL, SCM_NULL, "(eq? '() '())"); 125 TST_ASSERT(!TST_FAILED); 126 TST_EXPR(NULLP(SCM_NULL)); 127 TST_EXPR(!VALIDP(SCM_INVALID)); 128 TST_EXPR(VALIDP(SCM_NULL)); 129 TST_EXPR(VALIDP(SCM_FALSE)); 130 TST_EXPR(FALSEP(SCM_FALSE)); 131 TST_EXPR(!FALSEP(SCM_TRUE)); 132 #if SCM_COMPAT_SIOD_BUGS 133 TST_EXPR(NULLP(SCM_FALSE)); 134 TST_EXPR(FALSEP(SCM_NULL)); 135 #else 136 TST_EXPR(!FALSEP(SCM_NULL)); 137 #endif 138 TST_EXPR(!FALSEP(SCM_EOF)); 139 TST_EXPR(EOFP(SCM_EOF)); 140 141 obj = LIST_1(SCM_FALSE); 142 TST_NEQ(obj, LIST_1(SCM_FALSE), "equal? but not eq?"); 143 TST_EQ(obj, obj, "eq?"); 144 } 145 146 TST_CASE("pair") 147 { 148 ScmObj obj; 149 150 #define CONS_TST(tst, kar, kdr) \ 151 tst(obj, CONS, \ 152 CAR, OBJ, kar, \ 153 CDR, OBJ, kdr) 154 155 /* These interfere with token generation. */ 156 #undef CONS 157 #undef CAR 158 #undef CDR 159 160 CONS_TST(TST_INIT2, SCM_EOF, SCM_NULL); 161 CONS_TST(TST_SET2, SCM_NULL, SCM_TRUE); 162 163 #define CONS SCM_CONS 164 #define CAR SCM_CAR 165 #define CDR SCM_CDR 166 } 167 168 169 TST_CASE("closure") 170 { 171 ScmObj obj; 172 ScmObj exp, env; 173 174 exp = LIST_1(SCM_SYM_QUOTE); 175 env = SCM_NULL_ENV; 176 177 #define CLOSURE_TST(tst, xp, nv) \ 178 tst(obj, CLOSURE, \ 179 EXP, OBJ, xp, \ 180 ENV, OBJ, nv) 181 182 CLOSURE_TST(TST_INIT2, exp, env); 183 CLOSURE_TST(TST_SET2, SCM_NULL, CONS(SCM_NULL, SCM_NULL)); 184 } 185 186 187 TST_CASE("int") 188 { 189 ScmObj obj; 190 /* for suppressing compiler warning on intentional overflowed/underflowed 191 * value */ 192 volatile scm_int_t scm_int_min = SCM_INT_MIN; 193 volatile scm_int_t scm_int_max = SCM_INT_MAX; 194 195 #define INT_TST(tst, val) \ 196 tst(obj, INT, \ 197 VALUE, INT, val) 198 199 INT_TST(TST_INIT1, 1); 200 INT_TST(TST_INIT1, SCM_INT_MIN); 201 INT_TST(TST_INIT1, SCM_INT_MAX); 202 obj = SCM_MAKE_INT(scm_int_min - 1); 203 TST_COND(INTP(obj), "INTP() on underflowed int"); 204 obj = SCM_MAKE_INT(scm_int_max + 1); 205 TST_COND(INTP(obj), "INTP() on overflowed int"); 206 } 207 208 TST_CASE("char") 209 { 210 ScmObj obj; 211 /* for suppressing compiler warning on intentional overflowed/underflowed 212 * value */ 213 volatile scm_ichar_t scm_char_min = SCM_CHAR_MIN; 214 volatile scm_ichar_t scm_char_max = SCM_CHAR_MAX; 215 216 #define CHAR_TST(tst, val) \ 217 tst(obj, CHAR, \ 218 VALUE, INT, val) 219 220 CHAR_TST(TST_INIT1, 0); 221 CHAR_TST(TST_INIT1, SCM_CHAR_MIN); 222 CHAR_TST(TST_INIT1, SCM_CHAR_MAX); 223 obj = SCM_MAKE_CHAR(scm_char_min - 1); 224 TST_COND(CHARP(obj), "CHARP() on underflowed char"); 225 obj = SCM_MAKE_CHAR(scm_char_max + 1); 226 TST_COND(CHARP(obj), "CHARP() on overflowed char"); 227 } 228 229 230 TST_CASE("symbol") 231 { 232 ScmObj obj; 233 char *p = scm_strdup("abcdefghijklmnopqrstuv"); 234 p = (char*)(((intptr_t)p + 7)& (-8)); 235 236 #define SYMBOL_TST(tst, nam, val) \ 237 tst(obj, SYMBOL, \ 238 NAME, PTR, nam, \ 239 VCELL, OBJ, val) 240 241 SYMBOL_TST(TST_INIT2, p, LIST_1(SCM_NULL)); 242 SYMBOL_TST(TST_SET2, NULL, SCM_NULL); 243 } 244 245 246 TST_CASE("string") 247 { 248 ScmObj obj; 249 char buf[] = "abcdefghijklmnopqrstuv", *p; 250 size_t len = sizeof (buf) / sizeof (*buf); 251 252 #define STRING_TST(tst, str, len) \ 253 tst(obj, STRING, \ 254 STR, PTR, str, \ 255 LEN, INT, len) 256 257 STRING_TST(TST_INIT2, aligned_dup(buf, sizeof(buf)), len); 258 259 #if SCM_HAS_IMMUTABLE_STRING 260 TST_COND(SCM_STRING_MUTABLEP(obj), "MAKE_STRING -> mutable?"); 261 obj = SCM_MAKE_IMMUTABLE_STRING_COPYING(buf, len); 262 TST_COND(!SCM_STRING_MUTABLEP(obj), 263 "MAKE_IMMUTABLE_STRING -> immutable?"); 264 SCM_STRING_SET_MUTABLE(obj); 265 TST_COND(SCM_STRING_MUTABLEP(obj), "STRING_SET_MUTABLE -> mutable?"); 266 SCM_STRING_SET_IMMUTABLE(obj); 267 TST_COND(!SCM_STRING_MUTABLEP(obj), "STRING_SET_IMMUTABLE -> immutable?"); 268 SCM_STRING_SET_MUTABLE(obj); 269 #endif /* have immutable string */ 270 271 p = SCM_STRING_STR(obj); 272 STRING_TST(TST_SET2, aligned_dup(buf, sizeof(buf)), len - 8); 273 free(p); 274 #if SCM_HAS_IMMUTABLE_STRING 275 TST_COND(SCM_STRING_MUTABLEP(obj), "string-mutable? after set"); 276 #endif 277 } 278 279 TST_CASE(vector, "vector") 280 { 281 ScmObj obj; 282 ScmObj buf[4]; 283 ScmObj *p; 284 size_t len; 285 len = sizeof (buf) / sizeof (*buf); 286 287 buf[0] = SCM_NULL; 288 buf[1] = SCM_TRUE; 289 buf[2] = SCM_MAKE_INT(0); 290 buf[3] = LIST_1(SCM_FALSE); 291 292 #define VECTOR_TST(tst, vec, len) \ 293 tst(obj, VECTOR, \ 294 VEC, PTR, vec, \ 295 LEN, INT, len) 296 297 VECTOR_TST(TST_INIT2, aligned_dup(buf, sizeof(buf)), len); 298 299 #if SCM_HAS_IMMUTABLE_VECTOR 300 TST_COND(SCM_VECTOR_MUTABLEP(obj), "MAKE_VECTOR -> mutable?"); 301 obj = SCM_MAKE_IMMUTABLE_VECTOR(NULL, len); 302 TST_COND(!SCM_VECTOR_MUTABLEP(obj), 303 "MAKE_IMMUTABLE_VECTOR -> immutable?"); 304 SCM_VECTOR_SET_MUTABLE(obj); 305 TST_COND(SCM_VECTOR_MUTABLEP(obj), "VECTOR_SET_MUTABLE -> mutable?"); 306 SCM_VECTOR_SET_IMMUTABLE(obj); 307 TST_COND(!SCM_VECTOR_MUTABLEP(obj), "VECTOR_SET_IMMUTABLE -> immutable?"); 308 SCM_VECTOR_SET_MUTABLE(obj); 309 #endif /* have immutable string */ 310 311 p = SCM_VECTOR_VEC(obj); 312 VECTOR_TST(TST_SET2, aligned_dup(buf, sizeof(buf)), len - 8); 313 free(p); 314 #if SCM_HAS_IMMUTABLE_VECTOR 315 TST_COND(SCM_VECTOR_MUTABLEP(obj), "vector-mutable? after set"); 316 #endif 317 } 318 319 TST_CASE("values") 320 { 321 #if !SCM_USE_VALUECONS 322 ScmObj obj; 323 324 #define VALS_TST(tst, vals) \ 325 tst(obj, VALUEPACKET, \ 326 VALUES, OBJ, vals) 327 328 VALS_TST(TST_INIT1, LIST_2(SCM_TRUE, SCM_FALSE)); 329 VALS_TST(TST_SET1, SCM_NULL); 330 #endif 331 } 332 333 TST_CASE("func") 334 { 335 ScmObj obj; 336 337 #define FUNC_TST(tst, typ, fun) \ 338 tst(obj, FUNC, \ 339 TYPECODE, INT, typ, \ 340 CFUNC, FPTR, fun) 341 342 typedef ScmFuncType FPTR; 343 FUNC_TST(TST_INIT2, SCM_SYNTAX_VARIADIC_1, (ScmFuncType)0xdeadbeef); 344 FUNC_TST(TST_SET2, SCM_PROCEDURE_FIXED_4, (ScmFuncType)0); 345 #if (SIZEOF_SCMOBJ == SIZEOF_INT64_T) 346 FUNC_TST(TST_INIT2, SCM_SYNTAX_VARIADIC_1, (ScmFuncType)0xdeadbeeffeed); 347 #endif 348 } 349 350 TST_CASE(port, "port") 351 { 352 /* TODO; currently passes but crashes at the end upon GC. Also 353 * reliant on the implementation details of SCM_MAKE_PORT(). */ 354 #if 0 355 ScmObj obj; 356 enum ScmPortFlag f; 357 #define PORT_TST(tst, impl, flag) \ 358 tst(obj, PORT, \ 359 IMPL, PTR, impl, \ 360 FLAG, INT, flag) 361 f = SCM_PORTFLAG_OUTPUT | SCM_PORTFLAG_LIVE_OUTPUT; /* FIXME */ 362 PORT_TST(TST_INIT2, NULL, f); 363 f = SCM_PORTFLAG_INPUT | SCM_PORTFLAG_LIVE_INPUT; /* FIXME */ 364 PORT_TST(TST_SET2, NULL, f); 365 #endif 366 } 367 368 TST_CASE("continuation") 369 { 370 ScmObj obj; 371 372 #define CONT_TST(tst, op, tag) \ 373 tst(obj, CONTINUATION, \ 374 OPAQUE, PTR, op, \ 375 TAG, INT, tag) 376 obj = SCM_MAKE_CONTINUATION(); 377 TST_COND(SCM_CONTINUATIONP(obj), "CONTINUATIONP() on fresh CONTINUATION"); 378 CONT_TST(TST_SET2, (void*)0x0deadbee, 0xf00f); 379 CONT_TST(TST_SET2, INVALID_CONTINUATION_OPAQUE, 0); 380 #if (SIZEOF_SCMOBJ == SIZEOF_INT64_T) 381 CONT_TST(TST_SET2, (void*)0x0deadbeefee, 0xf00f); 382 #endif 383 } 384 385 #if SCM_USE_SSCM_EXTENSIONS 386 TST_CASE("C ptr") 387 { 388 ScmObj obj; 389 390 #define CPTR_TST(tst, p) \ 391 tst(obj, C_POINTER, \ 392 VALUE, PTR, p) 393 394 CPTR_TST(TST_INIT1, (void*)0xdeadbeef); 395 CPTR_TST(TST_SET1, (void*)0xbaddeed); 396 #if (SIZEOF_SCMOBJ == SIZEOF_INT64_T) 397 CPTR_TST(TST_INIT1, (void*)0xdeadbeeffeedee); 398 CPTR_TST(TST_SET1, (void*)0xbaddeedbed); 399 #endif 400 } 401 402 TST_CASE("C func ptr") 403 { 404 ScmObj obj; 405 406 #define CFPTR_TST(tst, p) \ 407 tst(obj, C_FUNCPOINTER, \ 408 VALUE, FPTR, p) 409 410 typedef ScmCFunc FPTR; 411 CFPTR_TST(TST_INIT1, (ScmCFunc)0xdeadbeef); 412 CFPTR_TST(TST_SET1, (ScmCFunc)0xbaddeed); 413 #if (SIZEOF_SCMOBJ == SIZEOF_INT64_T) 414 /* both MSB and LSB are set */ 415 CFPTR_TST(TST_INIT1, (ScmCFunc)0xadeadbeeffedbeef); 416 CFPTR_TST(TST_SET1, (ScmCFunc)0xbaddeedbeddad); 417 #endif 418 } 419 #endif /* use sscm extension mechanism */ 420 421 #if SCM_USE_UNHYGIENIC_MACRO 422 #error "No test implemented." 423 #endif 424 425 TST_CASE("subpat") 426 { 427 #if SCM_USE_HYGIENIC_MACRO 428 ScmObj obj; 429 #define SUBPAT_TST(tst, pat, meta) \ 430 tst(obj, SUBPAT, \ 431 OBJ, OBJ, pat, \ 432 META, INT, meta) 433 434 SUBPAT_TST(TST_INIT2, LIST_1(SCM_NULL), -1); 435 SUBPAT_TST(TST_SET2, SCM_NULL, 5); 436 #endif /* SCM_USE_HYGIENIC_MACRO */ 437 } 438 439 TST_CASE("far symbol") 440 { 441 #if SCM_USE_HYGIENIC_MACRO 442 ScmObj obj; 443 #if SCM_USE_UNHYGIENIC_MACRO 444 #error "Packed env handling must be revised." 445 #endif 446 #define FARSYMBOL_TST(tst, sym, env) \ 447 tst(obj, FARSYMBOL, \ 448 SYM, OBJ, sym, \ 449 ENV, INT, env) /* ScmPackedEnv == scm_int_t */ 450 ScmPackedEnv null; 451 ScmObj env; 452 453 null = scm_pack_env(SCM_NULL_ENV); 454 env = scm_extend_environment(SCM_SYM_QUOTE, SCM_NULL, SCM_INTERACTION_ENV); 455 456 FARSYMBOL_TST(TST_INIT2, SCM_SYM_QUOTE, null); 457 FARSYMBOL_TST(TST_SET2, SCM_MAKE_FARSYMBOL(SCM_SYM_QUOTE, null), 458 scm_pack_env(env)); 459 #endif /* SCM_USE_HYGIENIC_MACRO */ 460 } 461 462 TST_CASE(hmacro, "hmacro") 463 { 464 #if SCM_USE_HYGIENIC_MACRO 465 ScmObj obj; 466 ScmObj env, rules; 467 468 #if SCM_USE_UNHYGIENIC_MACRO 469 #define TST_EQ_PENV TST_EQ_OBJ 470 #else 471 #define TST_EQ_PENV TST_EQ_INT 472 #endif 473 typedef ScmPackedEnv PENV; 474 475 #define HMACRO_TST(tst, rules, env, context) \ 476 tst(obj, HMACRO, \ 477 RULES, OBJ, rules, \ 478 ENV, PENV, env, \ 479 context) 480 481 obj = SCM_MAKE_HMACRO(SCM_NULL, SCM_INTERACTION_ENV); 482 HMACRO_TST(TST2, SCM_NULL, scm_pack_env(SCM_INTERACTION_ENV), 483 "on fresh HMACRO"); 484 485 rules = LIST_1(SCM_NULL); 486 SCM_HMACRO_SET_RULES(obj, rules); 487 HMACRO_TST(TST2, rules, scm_pack_env(SCM_INTERACTION_ENV), 488 "after SET_RULES()"); 489 490 env = scm_extend_environment(SCM_SYM_QUOTE, SCM_NULL, 491 SCM_NULL_ENV); 492 SCM_HMACRO_SET_ENV(obj, scm_pack_env(env)); 493 HMACRO_TST(TST2, rules, scm_pack_env(env), 494 "after SET_ENV"); 495 #endif /* SCM_USE_HYGIENIC_MACRO */ 496 } 497 498 #endif /* !TST_EXCLUDE_THIS */ 499