| 1 | /* Copyright (C) 2001,2008,2009,2010,2011,2012,2013 Free Software Foundation, Inc. |
| 2 | * |
| 3 | * This library is free software; you can redistribute it and/or |
| 4 | * modify it under the terms of the GNU Lesser General Public License |
| 5 | * as published by the Free Software Foundation; either version 3 of |
| 6 | * the License, or (at your option) any later version. |
| 7 | * |
| 8 | * This library is distributed in the hope that it will be useful, but |
| 9 | * WITHOUT ANY WARRANTY; without even the implied warranty of |
| 10 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
| 11 | * Lesser General Public License for more details. |
| 12 | * |
| 13 | * You should have received a copy of the GNU Lesser General Public |
| 14 | * License along with this library; if not, write to the Free Software |
| 15 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
| 16 | * 02110-1301 USA |
| 17 | */ |
| 18 | |
| 19 | |
| 20 | /* This file is included in vm_engine.c */ |
| 21 | |
| 22 | \f |
| 23 | /* |
| 24 | * Basic operations |
| 25 | */ |
| 26 | |
| 27 | VM_DEFINE_INSTRUCTION (0, nop, "nop", 0, 0, 0) |
| 28 | { |
| 29 | NEXT; |
| 30 | } |
| 31 | |
| 32 | VM_DEFINE_INSTRUCTION (1, halt, "halt", 0, 0, 0) |
| 33 | { |
| 34 | SCM ret; |
| 35 | |
| 36 | nvalues = SCM_I_INUM (*sp--); |
| 37 | NULLSTACK (1); |
| 38 | |
| 39 | if (nvalues == 1) |
| 40 | POP (ret); |
| 41 | else |
| 42 | { |
| 43 | SYNC_REGISTER (); |
| 44 | sp -= nvalues; |
| 45 | CHECK_UNDERFLOW (); |
| 46 | ret = scm_c_values (sp + 1, nvalues); |
| 47 | NULLSTACK (nvalues); |
| 48 | } |
| 49 | |
| 50 | { |
| 51 | #ifdef VM_ENABLE_STACK_NULLING |
| 52 | SCM *old_sp = sp; |
| 53 | #endif |
| 54 | |
| 55 | /* Restore registers */ |
| 56 | sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; |
| 57 | /* Setting the ip here doesn't actually affect control flow, as the calling |
| 58 | code will restore its own registers, but it does help when walking the |
| 59 | stack */ |
| 60 | ip = SCM_FRAME_RETURN_ADDRESS (fp); |
| 61 | fp = SCM_FRAME_DYNAMIC_LINK (fp); |
| 62 | NULLSTACK (old_sp - sp); |
| 63 | } |
| 64 | |
| 65 | SYNC_ALL (); |
| 66 | return ret; |
| 67 | } |
| 68 | |
| 69 | VM_DEFINE_INSTRUCTION (2, drop, "drop", 0, 1, 0) |
| 70 | { |
| 71 | DROP (); |
| 72 | NEXT; |
| 73 | } |
| 74 | |
| 75 | VM_DEFINE_INSTRUCTION (3, dup, "dup", 0, 0, 1) |
| 76 | { |
| 77 | SCM x = *sp; |
| 78 | PUSH (x); |
| 79 | NEXT; |
| 80 | } |
| 81 | |
| 82 | \f |
| 83 | /* |
| 84 | * Object creation |
| 85 | */ |
| 86 | |
| 87 | VM_DEFINE_INSTRUCTION (4, void, "void", 0, 0, 1) |
| 88 | { |
| 89 | PUSH (SCM_UNSPECIFIED); |
| 90 | NEXT; |
| 91 | } |
| 92 | |
| 93 | VM_DEFINE_INSTRUCTION (5, make_true, "make-true", 0, 0, 1) |
| 94 | { |
| 95 | PUSH (SCM_BOOL_T); |
| 96 | NEXT; |
| 97 | } |
| 98 | |
| 99 | VM_DEFINE_INSTRUCTION (6, make_false, "make-false", 0, 0, 1) |
| 100 | { |
| 101 | PUSH (SCM_BOOL_F); |
| 102 | NEXT; |
| 103 | } |
| 104 | |
| 105 | VM_DEFINE_INSTRUCTION (7, make_nil, "make-nil", 0, 0, 1) |
| 106 | { |
| 107 | PUSH (SCM_ELISP_NIL); |
| 108 | NEXT; |
| 109 | } |
| 110 | |
| 111 | VM_DEFINE_INSTRUCTION (8, make_eol, "make-eol", 0, 0, 1) |
| 112 | { |
| 113 | PUSH (SCM_EOL); |
| 114 | NEXT; |
| 115 | } |
| 116 | |
| 117 | VM_DEFINE_INSTRUCTION (9, make_int8, "make-int8", 1, 0, 1) |
| 118 | { |
| 119 | PUSH (SCM_I_MAKINUM ((signed char) FETCH ())); |
| 120 | NEXT; |
| 121 | } |
| 122 | |
| 123 | VM_DEFINE_INSTRUCTION (10, make_int8_0, "make-int8:0", 0, 0, 1) |
| 124 | { |
| 125 | PUSH (SCM_INUM0); |
| 126 | NEXT; |
| 127 | } |
| 128 | |
| 129 | VM_DEFINE_INSTRUCTION (11, make_int8_1, "make-int8:1", 0, 0, 1) |
| 130 | { |
| 131 | PUSH (SCM_I_MAKINUM (1)); |
| 132 | NEXT; |
| 133 | } |
| 134 | |
| 135 | VM_DEFINE_INSTRUCTION (12, make_int16, "make-int16", 2, 0, 1) |
| 136 | { |
| 137 | int h = FETCH (); |
| 138 | int l = FETCH (); |
| 139 | PUSH (SCM_I_MAKINUM ((signed short) (h << 8) + l)); |
| 140 | NEXT; |
| 141 | } |
| 142 | |
| 143 | VM_DEFINE_INSTRUCTION (13, make_int64, "make-int64", 8, 0, 1) |
| 144 | { |
| 145 | scm_t_uint64 v = 0; |
| 146 | v += FETCH (); |
| 147 | v <<= 8; v += FETCH (); |
| 148 | v <<= 8; v += FETCH (); |
| 149 | v <<= 8; v += FETCH (); |
| 150 | v <<= 8; v += FETCH (); |
| 151 | v <<= 8; v += FETCH (); |
| 152 | v <<= 8; v += FETCH (); |
| 153 | v <<= 8; v += FETCH (); |
| 154 | PUSH (scm_from_int64 ((scm_t_int64) v)); |
| 155 | NEXT; |
| 156 | } |
| 157 | |
| 158 | VM_DEFINE_INSTRUCTION (14, make_uint64, "make-uint64", 8, 0, 1) |
| 159 | { |
| 160 | scm_t_uint64 v = 0; |
| 161 | v += FETCH (); |
| 162 | v <<= 8; v += FETCH (); |
| 163 | v <<= 8; v += FETCH (); |
| 164 | v <<= 8; v += FETCH (); |
| 165 | v <<= 8; v += FETCH (); |
| 166 | v <<= 8; v += FETCH (); |
| 167 | v <<= 8; v += FETCH (); |
| 168 | v <<= 8; v += FETCH (); |
| 169 | PUSH (scm_from_uint64 (v)); |
| 170 | NEXT; |
| 171 | } |
| 172 | |
| 173 | VM_DEFINE_INSTRUCTION (15, make_char8, "make-char8", 1, 0, 1) |
| 174 | { |
| 175 | scm_t_uint8 v = 0; |
| 176 | v = FETCH (); |
| 177 | |
| 178 | PUSH (SCM_MAKE_CHAR (v)); |
| 179 | /* Don't simplify this to PUSH (SCM_MAKE_CHAR (FETCH ())). The |
| 180 | contents of SCM_MAKE_CHAR may be evaluated more than once, |
| 181 | resulting in a double fetch. */ |
| 182 | NEXT; |
| 183 | } |
| 184 | |
| 185 | VM_DEFINE_INSTRUCTION (16, make_char32, "make-char32", 4, 0, 1) |
| 186 | { |
| 187 | scm_t_wchar v = 0; |
| 188 | v += FETCH (); |
| 189 | v <<= 8; v += FETCH (); |
| 190 | v <<= 8; v += FETCH (); |
| 191 | v <<= 8; v += FETCH (); |
| 192 | PUSH (SCM_MAKE_CHAR (v)); |
| 193 | NEXT; |
| 194 | } |
| 195 | |
| 196 | |
| 197 | |
| 198 | VM_DEFINE_INSTRUCTION (17, list, "list", 2, -1, 1) |
| 199 | { |
| 200 | unsigned h = FETCH (); |
| 201 | unsigned l = FETCH (); |
| 202 | unsigned len = ((h << 8) + l); |
| 203 | POP_LIST (len); |
| 204 | NEXT; |
| 205 | } |
| 206 | |
| 207 | VM_DEFINE_INSTRUCTION (18, vector, "vector", 2, -1, 1) |
| 208 | { |
| 209 | unsigned h = FETCH (); |
| 210 | unsigned l = FETCH (); |
| 211 | unsigned len = ((h << 8) + l); |
| 212 | SCM vect; |
| 213 | |
| 214 | SYNC_REGISTER (); |
| 215 | sp++; sp -= len; |
| 216 | CHECK_UNDERFLOW (); |
| 217 | vect = scm_make_vector (scm_from_uint (len), SCM_BOOL_F); |
| 218 | memcpy (SCM_I_VECTOR_WELTS(vect), sp, sizeof(SCM) * len); |
| 219 | NULLSTACK (len); |
| 220 | *sp = vect; |
| 221 | |
| 222 | NEXT; |
| 223 | } |
| 224 | |
| 225 | \f |
| 226 | /* |
| 227 | * Variable access |
| 228 | */ |
| 229 | |
| 230 | #define OBJECT_REF(i) objects[i] |
| 231 | #define OBJECT_SET(i,o) objects[i] = o |
| 232 | |
| 233 | #define LOCAL_REF(i) SCM_FRAME_VARIABLE (fp, i) |
| 234 | #define LOCAL_SET(i,o) SCM_FRAME_VARIABLE (fp, i) = o |
| 235 | |
| 236 | /* For the variable operations, we _must_ obviously avoid function calls to |
| 237 | `scm_variable_ref ()', `scm_variable_bound_p ()' and friends which do |
| 238 | nothing more than the corresponding macros. */ |
| 239 | #define VARIABLE_REF(v) SCM_VARIABLE_REF (v) |
| 240 | #define VARIABLE_SET(v,o) SCM_VARIABLE_SET (v, o) |
| 241 | #define VARIABLE_BOUNDP(v) (!scm_is_eq (VARIABLE_REF (v), SCM_UNDEFINED)) |
| 242 | |
| 243 | #define FREE_VARIABLE_REF(i) SCM_PROGRAM_FREE_VARIABLE_REF (program, i) |
| 244 | |
| 245 | /* ref */ |
| 246 | |
| 247 | VM_DEFINE_INSTRUCTION (19, object_ref, "object-ref", 1, 0, 1) |
| 248 | { |
| 249 | register unsigned objnum = FETCH (); |
| 250 | CHECK_OBJECT (objnum); |
| 251 | PUSH (OBJECT_REF (objnum)); |
| 252 | NEXT; |
| 253 | } |
| 254 | |
| 255 | /* FIXME: necessary? elt 255 of the vector could be a vector... */ |
| 256 | VM_DEFINE_INSTRUCTION (20, long_object_ref, "long-object-ref", 2, 0, 1) |
| 257 | { |
| 258 | unsigned int objnum = FETCH (); |
| 259 | objnum <<= 8; |
| 260 | objnum += FETCH (); |
| 261 | CHECK_OBJECT (objnum); |
| 262 | PUSH (OBJECT_REF (objnum)); |
| 263 | NEXT; |
| 264 | } |
| 265 | |
| 266 | VM_DEFINE_INSTRUCTION (21, local_ref, "local-ref", 1, 0, 1) |
| 267 | { |
| 268 | PUSH (LOCAL_REF (FETCH ())); |
| 269 | ASSERT_BOUND (*sp); |
| 270 | NEXT; |
| 271 | } |
| 272 | |
| 273 | VM_DEFINE_INSTRUCTION (22, long_local_ref, "long-local-ref", 2, 0, 1) |
| 274 | { |
| 275 | unsigned int i = FETCH (); |
| 276 | i <<= 8; |
| 277 | i += FETCH (); |
| 278 | PUSH (LOCAL_REF (i)); |
| 279 | ASSERT_BOUND (*sp); |
| 280 | NEXT; |
| 281 | } |
| 282 | |
| 283 | VM_DEFINE_INSTRUCTION (23, local_bound, "local-bound?", 1, 0, 1) |
| 284 | { |
| 285 | PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (FETCH ()), SCM_UNDEFINED))); |
| 286 | NEXT; |
| 287 | } |
| 288 | |
| 289 | VM_DEFINE_INSTRUCTION (24, long_local_bound, "long-local-bound?", 2, 0, 1) |
| 290 | { |
| 291 | unsigned int i = FETCH (); |
| 292 | i <<= 8; |
| 293 | i += FETCH (); |
| 294 | PUSH (scm_from_bool (!scm_is_eq (LOCAL_REF (i), SCM_UNDEFINED))); |
| 295 | NEXT; |
| 296 | } |
| 297 | |
| 298 | VM_DEFINE_INSTRUCTION (25, variable_ref, "variable-ref", 0, 1, 1) |
| 299 | { |
| 300 | SCM x = *sp; |
| 301 | |
| 302 | /* We don't use ASSERT_VARIABLE or ASSERT_BOUND_VARIABLE here because, |
| 303 | unlike in top-variable-ref, it really isn't an internal assertion |
| 304 | that can be optimized out -- the variable could be coming directly |
| 305 | from the user. */ |
| 306 | VM_ASSERT (SCM_VARIABLEP (x), |
| 307 | vm_error_not_a_variable ("variable-ref", x)); |
| 308 | |
| 309 | if (SCM_UNLIKELY (!VARIABLE_BOUNDP (x))) |
| 310 | { |
| 311 | SCM var_name; |
| 312 | |
| 313 | SYNC_ALL (); |
| 314 | /* Attempt to provide the variable name in the error message. */ |
| 315 | var_name = scm_module_reverse_lookup (scm_current_module (), x); |
| 316 | vm_error_unbound (program, scm_is_true (var_name) ? var_name : x); |
| 317 | } |
| 318 | else |
| 319 | { |
| 320 | SCM o = VARIABLE_REF (x); |
| 321 | *sp = o; |
| 322 | } |
| 323 | |
| 324 | NEXT; |
| 325 | } |
| 326 | |
| 327 | VM_DEFINE_INSTRUCTION (26, variable_bound, "variable-bound?", 0, 1, 1) |
| 328 | { |
| 329 | SCM x = *sp; |
| 330 | |
| 331 | VM_ASSERT (SCM_VARIABLEP (x), |
| 332 | vm_error_not_a_variable ("variable-bound?", x)); |
| 333 | |
| 334 | *sp = scm_from_bool (VARIABLE_BOUNDP (x)); |
| 335 | NEXT; |
| 336 | } |
| 337 | |
| 338 | VM_DEFINE_INSTRUCTION (27, toplevel_ref, "toplevel-ref", 1, 0, 1) |
| 339 | { |
| 340 | unsigned objnum = FETCH (); |
| 341 | SCM what, resolved; |
| 342 | CHECK_OBJECT (objnum); |
| 343 | what = OBJECT_REF (objnum); |
| 344 | |
| 345 | if (!SCM_VARIABLEP (what)) |
| 346 | { |
| 347 | SYNC_REGISTER (); |
| 348 | resolved = resolve_variable (what, scm_program_module (program)); |
| 349 | VM_ASSERT (VARIABLE_BOUNDP (resolved), vm_error_unbound (program, what)); |
| 350 | what = resolved; |
| 351 | OBJECT_SET (objnum, what); |
| 352 | } |
| 353 | |
| 354 | PUSH (VARIABLE_REF (what)); |
| 355 | NEXT; |
| 356 | } |
| 357 | |
| 358 | VM_DEFINE_INSTRUCTION (28, long_toplevel_ref, "long-toplevel-ref", 2, 0, 1) |
| 359 | { |
| 360 | SCM what, resolved; |
| 361 | unsigned int objnum = FETCH (); |
| 362 | objnum <<= 8; |
| 363 | objnum += FETCH (); |
| 364 | CHECK_OBJECT (objnum); |
| 365 | what = OBJECT_REF (objnum); |
| 366 | |
| 367 | if (!SCM_VARIABLEP (what)) |
| 368 | { |
| 369 | SYNC_REGISTER (); |
| 370 | resolved = resolve_variable (what, scm_program_module (program)); |
| 371 | VM_ASSERT (VARIABLE_BOUNDP (resolved), |
| 372 | vm_error_unbound (program, what)); |
| 373 | what = resolved; |
| 374 | OBJECT_SET (objnum, what); |
| 375 | } |
| 376 | |
| 377 | PUSH (VARIABLE_REF (what)); |
| 378 | NEXT; |
| 379 | } |
| 380 | |
| 381 | /* set */ |
| 382 | |
| 383 | VM_DEFINE_INSTRUCTION (29, local_set, "local-set", 1, 1, 0) |
| 384 | { |
| 385 | SCM x; |
| 386 | POP (x); |
| 387 | LOCAL_SET (FETCH (), x); |
| 388 | NEXT; |
| 389 | } |
| 390 | |
| 391 | VM_DEFINE_INSTRUCTION (30, long_local_set, "long-local-set", 2, 1, 0) |
| 392 | { |
| 393 | SCM x; |
| 394 | unsigned int i = FETCH (); |
| 395 | i <<= 8; |
| 396 | i += FETCH (); |
| 397 | POP (x); |
| 398 | LOCAL_SET (i, x); |
| 399 | NEXT; |
| 400 | } |
| 401 | |
| 402 | VM_DEFINE_INSTRUCTION (31, variable_set, "variable-set", 0, 2, 0) |
| 403 | { |
| 404 | VM_ASSERT (SCM_VARIABLEP (sp[0]), |
| 405 | vm_error_not_a_variable ("variable-set!", sp[0])); |
| 406 | VARIABLE_SET (sp[0], sp[-1]); |
| 407 | DROPN (2); |
| 408 | NEXT; |
| 409 | } |
| 410 | |
| 411 | VM_DEFINE_INSTRUCTION (32, toplevel_set, "toplevel-set", 1, 1, 0) |
| 412 | { |
| 413 | unsigned objnum = FETCH (); |
| 414 | SCM what; |
| 415 | CHECK_OBJECT (objnum); |
| 416 | what = OBJECT_REF (objnum); |
| 417 | |
| 418 | if (!SCM_VARIABLEP (what)) |
| 419 | { |
| 420 | SYNC_BEFORE_GC (); |
| 421 | what = resolve_variable (what, scm_program_module (program)); |
| 422 | OBJECT_SET (objnum, what); |
| 423 | } |
| 424 | |
| 425 | VARIABLE_SET (what, *sp); |
| 426 | DROP (); |
| 427 | NEXT; |
| 428 | } |
| 429 | |
| 430 | VM_DEFINE_INSTRUCTION (33, long_toplevel_set, "long-toplevel-set", 2, 1, 0) |
| 431 | { |
| 432 | SCM what; |
| 433 | unsigned int objnum = FETCH (); |
| 434 | objnum <<= 8; |
| 435 | objnum += FETCH (); |
| 436 | CHECK_OBJECT (objnum); |
| 437 | what = OBJECT_REF (objnum); |
| 438 | |
| 439 | if (!SCM_VARIABLEP (what)) |
| 440 | { |
| 441 | SYNC_BEFORE_GC (); |
| 442 | what = resolve_variable (what, scm_program_module (program)); |
| 443 | OBJECT_SET (objnum, what); |
| 444 | } |
| 445 | |
| 446 | VARIABLE_SET (what, *sp); |
| 447 | DROP (); |
| 448 | NEXT; |
| 449 | } |
| 450 | |
| 451 | \f |
| 452 | /* |
| 453 | * branch and jump |
| 454 | */ |
| 455 | |
| 456 | /* offset must be at least 24 bits wide, and signed */ |
| 457 | #define FETCH_OFFSET(offset) \ |
| 458 | { \ |
| 459 | offset = FETCH () << 16; \ |
| 460 | offset += FETCH () << 8; \ |
| 461 | offset += FETCH (); \ |
| 462 | offset -= (offset & (1<<23)) << 1; \ |
| 463 | } |
| 464 | |
| 465 | #define BR(p) \ |
| 466 | { \ |
| 467 | scm_t_int32 offset; \ |
| 468 | FETCH_OFFSET (offset); \ |
| 469 | if (p) \ |
| 470 | ip += offset; \ |
| 471 | if (offset < 0) \ |
| 472 | VM_HANDLE_INTERRUPTS; \ |
| 473 | NEXT; \ |
| 474 | } |
| 475 | |
| 476 | VM_DEFINE_INSTRUCTION (34, br, "br", 3, 0, 0) |
| 477 | { |
| 478 | scm_t_int32 offset; |
| 479 | FETCH_OFFSET (offset); |
| 480 | ip += offset; |
| 481 | if (offset < 0) |
| 482 | VM_HANDLE_INTERRUPTS; |
| 483 | NEXT; |
| 484 | } |
| 485 | |
| 486 | VM_DEFINE_INSTRUCTION (35, br_if, "br-if", 3, 0, 0) |
| 487 | { |
| 488 | SCM x; |
| 489 | POP (x); |
| 490 | BR (scm_is_true (x)); |
| 491 | } |
| 492 | |
| 493 | VM_DEFINE_INSTRUCTION (36, br_if_not, "br-if-not", 3, 0, 0) |
| 494 | { |
| 495 | SCM x; |
| 496 | POP (x); |
| 497 | BR (scm_is_false (x)); |
| 498 | } |
| 499 | |
| 500 | VM_DEFINE_INSTRUCTION (37, br_if_eq, "br-if-eq", 3, 0, 0) |
| 501 | { |
| 502 | SCM x, y; |
| 503 | POP2 (y, x); |
| 504 | BR (scm_is_eq (x, y)); |
| 505 | } |
| 506 | |
| 507 | VM_DEFINE_INSTRUCTION (38, br_if_not_eq, "br-if-not-eq", 3, 0, 0) |
| 508 | { |
| 509 | SCM x, y; |
| 510 | POP2 (y, x); |
| 511 | BR (!scm_is_eq (x, y)); |
| 512 | } |
| 513 | |
| 514 | VM_DEFINE_INSTRUCTION (39, br_if_null, "br-if-null", 3, 0, 0) |
| 515 | { |
| 516 | SCM x; |
| 517 | POP (x); |
| 518 | BR (scm_is_null (x)); |
| 519 | } |
| 520 | |
| 521 | VM_DEFINE_INSTRUCTION (40, br_if_not_null, "br-if-not-null", 3, 0, 0) |
| 522 | { |
| 523 | SCM x; |
| 524 | POP (x); |
| 525 | BR (!scm_is_null (x)); |
| 526 | } |
| 527 | |
| 528 | \f |
| 529 | /* |
| 530 | * Subprogram call |
| 531 | */ |
| 532 | |
| 533 | VM_DEFINE_INSTRUCTION (41, br_if_nargs_ne, "br-if-nargs-ne", 5, 0, 0) |
| 534 | { |
| 535 | scm_t_ptrdiff n; |
| 536 | scm_t_int32 offset; |
| 537 | n = FETCH () << 8; |
| 538 | n += FETCH (); |
| 539 | FETCH_OFFSET (offset); |
| 540 | if (sp - (fp - 1) != n) |
| 541 | ip += offset; |
| 542 | NEXT; |
| 543 | } |
| 544 | |
| 545 | VM_DEFINE_INSTRUCTION (42, br_if_nargs_lt, "br-if-nargs-lt", 5, 0, 0) |
| 546 | { |
| 547 | scm_t_ptrdiff n; |
| 548 | scm_t_int32 offset; |
| 549 | n = FETCH () << 8; |
| 550 | n += FETCH (); |
| 551 | FETCH_OFFSET (offset); |
| 552 | if (sp - (fp - 1) < n) |
| 553 | ip += offset; |
| 554 | NEXT; |
| 555 | } |
| 556 | |
| 557 | VM_DEFINE_INSTRUCTION (43, br_if_nargs_gt, "br-if-nargs-gt", 5, 0, 0) |
| 558 | { |
| 559 | scm_t_ptrdiff n; |
| 560 | scm_t_int32 offset; |
| 561 | |
| 562 | n = FETCH () << 8; |
| 563 | n += FETCH (); |
| 564 | FETCH_OFFSET (offset); |
| 565 | if (sp - (fp - 1) > n) |
| 566 | ip += offset; |
| 567 | NEXT; |
| 568 | } |
| 569 | |
| 570 | VM_DEFINE_INSTRUCTION (44, assert_nargs_ee, "assert-nargs-ee", 2, 0, 0) |
| 571 | { |
| 572 | scm_t_ptrdiff n; |
| 573 | n = FETCH () << 8; |
| 574 | n += FETCH (); |
| 575 | VM_ASSERT (sp - (fp - 1) == n, |
| 576 | vm_error_wrong_num_args (program)); |
| 577 | NEXT; |
| 578 | } |
| 579 | |
| 580 | VM_DEFINE_INSTRUCTION (45, assert_nargs_ge, "assert-nargs-ge", 2, 0, 0) |
| 581 | { |
| 582 | scm_t_ptrdiff n; |
| 583 | n = FETCH () << 8; |
| 584 | n += FETCH (); |
| 585 | VM_ASSERT (sp - (fp - 1) >= n, |
| 586 | vm_error_wrong_num_args (program)); |
| 587 | NEXT; |
| 588 | } |
| 589 | |
| 590 | VM_DEFINE_INSTRUCTION (46, bind_optionals, "bind-optionals", 2, -1, -1) |
| 591 | { |
| 592 | scm_t_ptrdiff n; |
| 593 | n = FETCH () << 8; |
| 594 | n += FETCH (); |
| 595 | while (sp - (fp - 1) < n) |
| 596 | PUSH (SCM_UNDEFINED); |
| 597 | NEXT; |
| 598 | } |
| 599 | |
| 600 | VM_DEFINE_INSTRUCTION (47, bind_optionals_shuffle, "bind-optionals/shuffle", 6, -1, -1) |
| 601 | { |
| 602 | SCM *walk; |
| 603 | scm_t_ptrdiff nreq, nreq_and_opt, ntotal; |
| 604 | nreq = FETCH () << 8; |
| 605 | nreq += FETCH (); |
| 606 | nreq_and_opt = FETCH () << 8; |
| 607 | nreq_and_opt += FETCH (); |
| 608 | ntotal = FETCH () << 8; |
| 609 | ntotal += FETCH (); |
| 610 | |
| 611 | /* look in optionals for first keyword or last positional */ |
| 612 | /* starting after the last required positional arg */ |
| 613 | walk = fp + nreq; |
| 614 | while (/* while we have args */ |
| 615 | walk <= sp |
| 616 | /* and we still have positionals to fill */ |
| 617 | && walk - fp < nreq_and_opt |
| 618 | /* and we haven't reached a keyword yet */ |
| 619 | && !scm_is_keyword (*walk)) |
| 620 | /* bind this optional arg (by leaving it in place) */ |
| 621 | walk++; |
| 622 | /* now shuffle up, from walk to ntotal */ |
| 623 | { |
| 624 | scm_t_ptrdiff nshuf = sp - walk + 1, i; |
| 625 | sp = (fp - 1) + ntotal + nshuf; |
| 626 | CHECK_OVERFLOW (); |
| 627 | for (i = 0; i < nshuf; i++) |
| 628 | sp[-i] = walk[nshuf-i-1]; |
| 629 | } |
| 630 | /* and fill optionals & keyword args with SCM_UNDEFINED */ |
| 631 | while (walk <= (fp - 1) + ntotal) |
| 632 | *walk++ = SCM_UNDEFINED; |
| 633 | |
| 634 | NEXT; |
| 635 | } |
| 636 | |
| 637 | /* See also bind-optionals/shuffle-or-br below. */ |
| 638 | |
| 639 | /* Flags that determine whether other keywords are allowed, and whether a |
| 640 | rest argument is expected. These values must match those used by the |
| 641 | glil->assembly compiler. */ |
| 642 | #define F_ALLOW_OTHER_KEYS 1 |
| 643 | #define F_REST 2 |
| 644 | |
| 645 | VM_DEFINE_INSTRUCTION (48, bind_kwargs, "bind-kwargs", 5, 0, 0) |
| 646 | { |
| 647 | scm_t_uint16 idx; |
| 648 | scm_t_ptrdiff nkw; |
| 649 | int kw_and_rest_flags; |
| 650 | SCM kw; |
| 651 | idx = FETCH () << 8; |
| 652 | idx += FETCH (); |
| 653 | /* XXX: We don't actually use NKW. */ |
| 654 | nkw = FETCH () << 8; |
| 655 | nkw += FETCH (); |
| 656 | kw_and_rest_flags = FETCH (); |
| 657 | |
| 658 | VM_ASSERT ((kw_and_rest_flags & F_REST) |
| 659 | || ((sp - (fp - 1) - nkw) % 2) == 0, |
| 660 | vm_error_kwargs_length_not_even (program)) |
| 661 | |
| 662 | CHECK_OBJECT (idx); |
| 663 | kw = OBJECT_REF (idx); |
| 664 | |
| 665 | /* Switch NKW to be a negative index below SP. */ |
| 666 | for (nkw = -(sp - (fp - 1) - nkw) + 1; nkw < 0; nkw++) |
| 667 | { |
| 668 | SCM walk; |
| 669 | |
| 670 | if (scm_is_keyword (sp[nkw])) |
| 671 | { |
| 672 | for (walk = kw; scm_is_pair (walk); walk = SCM_CDR (walk)) |
| 673 | { |
| 674 | if (scm_is_eq (SCM_CAAR (walk), sp[nkw])) |
| 675 | { |
| 676 | SCM si = SCM_CDAR (walk); |
| 677 | LOCAL_SET (SCM_I_INUMP (si) ? SCM_I_INUM (si) : scm_to_long (si), |
| 678 | sp[nkw + 1]); |
| 679 | break; |
| 680 | } |
| 681 | } |
| 682 | VM_ASSERT (scm_is_pair (walk) |
| 683 | || (kw_and_rest_flags & F_ALLOW_OTHER_KEYS), |
| 684 | vm_error_kwargs_unrecognized_keyword (program)); |
| 685 | nkw++; |
| 686 | } |
| 687 | else |
| 688 | VM_ASSERT (kw_and_rest_flags & F_REST, |
| 689 | vm_error_kwargs_invalid_keyword (program)); |
| 690 | } |
| 691 | |
| 692 | NEXT; |
| 693 | } |
| 694 | |
| 695 | #undef F_ALLOW_OTHER_KEYS |
| 696 | #undef F_REST |
| 697 | |
| 698 | |
| 699 | VM_DEFINE_INSTRUCTION (49, push_rest, "push-rest", 2, -1, -1) |
| 700 | { |
| 701 | scm_t_ptrdiff n; |
| 702 | SCM rest = SCM_EOL; |
| 703 | n = FETCH () << 8; |
| 704 | n += FETCH (); |
| 705 | while (sp - (fp - 1) > n) |
| 706 | /* No need to check for underflow. */ |
| 707 | CONS (rest, *sp--, rest); |
| 708 | PUSH (rest); |
| 709 | NEXT; |
| 710 | } |
| 711 | |
| 712 | VM_DEFINE_INSTRUCTION (50, bind_rest, "bind-rest", 4, -1, -1) |
| 713 | { |
| 714 | scm_t_ptrdiff n; |
| 715 | scm_t_uint32 i; |
| 716 | SCM rest = SCM_EOL; |
| 717 | n = FETCH () << 8; |
| 718 | n += FETCH (); |
| 719 | i = FETCH () << 8; |
| 720 | i += FETCH (); |
| 721 | while (sp - (fp - 1) > n) |
| 722 | /* No need to check for underflow. */ |
| 723 | CONS (rest, *sp--, rest); |
| 724 | LOCAL_SET (i, rest); |
| 725 | NEXT; |
| 726 | } |
| 727 | |
| 728 | VM_DEFINE_INSTRUCTION (51, reserve_locals, "reserve-locals", 2, -1, -1) |
| 729 | { |
| 730 | SCM *old_sp; |
| 731 | scm_t_int32 n; |
| 732 | n = FETCH () << 8; |
| 733 | n += FETCH (); |
| 734 | old_sp = sp; |
| 735 | sp = (fp - 1) + n; |
| 736 | |
| 737 | if (old_sp < sp) |
| 738 | { |
| 739 | CHECK_OVERFLOW (); |
| 740 | while (old_sp < sp) |
| 741 | *++old_sp = SCM_UNDEFINED; |
| 742 | } |
| 743 | else |
| 744 | NULLSTACK (old_sp - sp); |
| 745 | |
| 746 | NEXT; |
| 747 | } |
| 748 | |
| 749 | VM_DEFINE_INSTRUCTION (52, new_frame, "new-frame", 0, 0, 3) |
| 750 | { |
| 751 | /* NB: if you change this, see frames.c:vm-frame-num-locals */ |
| 752 | /* and frames.h, vm-engine.c, etc of course */ |
| 753 | |
| 754 | /* We don't initialize the dynamic link here because we don't actually |
| 755 | know that this frame will point to the current fp: it could be |
| 756 | placed elsewhere on the stack if captured in a partial |
| 757 | continuation, and invoked from some other context. */ |
| 758 | PUSH (SCM_PACK (0)); /* dynamic link */ |
| 759 | PUSH (SCM_PACK (0)); /* mvra */ |
| 760 | PUSH (SCM_PACK (0)); /* ra */ |
| 761 | NEXT; |
| 762 | } |
| 763 | |
| 764 | VM_DEFINE_INSTRUCTION (53, call, "call", 1, -1, 1) |
| 765 | { |
| 766 | nargs = FETCH (); |
| 767 | |
| 768 | vm_call: |
| 769 | VM_HANDLE_INTERRUPTS; |
| 770 | |
| 771 | { |
| 772 | SCM *old_fp = fp; |
| 773 | |
| 774 | fp = sp - nargs + 1; |
| 775 | |
| 776 | ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0); |
| 777 | ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); |
| 778 | ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); |
| 779 | SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); |
| 780 | SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); |
| 781 | SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, 0); |
| 782 | } |
| 783 | |
| 784 | PUSH_CONTINUATION_HOOK (); |
| 785 | |
| 786 | program = fp[-1]; |
| 787 | |
| 788 | if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) |
| 789 | goto apply; |
| 790 | |
| 791 | CACHE_PROGRAM (); |
| 792 | ip = SCM_C_OBJCODE_BASE (bp); |
| 793 | |
| 794 | APPLY_HOOK (); |
| 795 | NEXT; |
| 796 | } |
| 797 | |
| 798 | VM_DEFINE_INSTRUCTION (54, tail_call, "tail-call", 1, -1, 1) |
| 799 | { |
| 800 | nargs = FETCH (); |
| 801 | |
| 802 | vm_tail_call: |
| 803 | VM_HANDLE_INTERRUPTS; |
| 804 | |
| 805 | { |
| 806 | int i; |
| 807 | #ifdef VM_ENABLE_STACK_NULLING |
| 808 | SCM *old_sp = sp; |
| 809 | CHECK_STACK_LEAK (); |
| 810 | #endif |
| 811 | |
| 812 | /* shuffle down the program and the arguments */ |
| 813 | for (i = -1, sp = sp - nargs + 1; i < nargs; i++) |
| 814 | SCM_FRAME_STACK_ADDRESS (fp)[i] = sp[i]; |
| 815 | |
| 816 | sp = fp + i - 1; |
| 817 | |
| 818 | NULLSTACK (old_sp - sp); |
| 819 | } |
| 820 | |
| 821 | program = fp[-1]; |
| 822 | |
| 823 | if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) |
| 824 | goto apply; |
| 825 | |
| 826 | CACHE_PROGRAM (); |
| 827 | ip = SCM_C_OBJCODE_BASE (bp); |
| 828 | |
| 829 | APPLY_HOOK (); |
| 830 | NEXT; |
| 831 | } |
| 832 | |
| 833 | VM_DEFINE_INSTRUCTION (55, subr_call, "subr-call", 1, -1, -1) |
| 834 | { |
| 835 | SCM pointer, ret; |
| 836 | SCM (*subr)(); |
| 837 | |
| 838 | nargs = FETCH (); |
| 839 | POP (pointer); |
| 840 | |
| 841 | subr = SCM_POINTER_VALUE (pointer); |
| 842 | |
| 843 | VM_HANDLE_INTERRUPTS; |
| 844 | SYNC_REGISTER (); |
| 845 | |
| 846 | switch (nargs) |
| 847 | { |
| 848 | case 0: |
| 849 | ret = subr (); |
| 850 | break; |
| 851 | case 1: |
| 852 | ret = subr (sp[0]); |
| 853 | break; |
| 854 | case 2: |
| 855 | ret = subr (sp[-1], sp[0]); |
| 856 | break; |
| 857 | case 3: |
| 858 | ret = subr (sp[-2], sp[-1], sp[0]); |
| 859 | break; |
| 860 | case 4: |
| 861 | ret = subr (sp[-3], sp[-2], sp[-1], sp[0]); |
| 862 | break; |
| 863 | case 5: |
| 864 | ret = subr (sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); |
| 865 | break; |
| 866 | case 6: |
| 867 | ret = subr (sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); |
| 868 | break; |
| 869 | case 7: |
| 870 | ret = subr (sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); |
| 871 | break; |
| 872 | case 8: |
| 873 | ret = subr (sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); |
| 874 | break; |
| 875 | case 9: |
| 876 | ret = subr (sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); |
| 877 | break; |
| 878 | case 10: |
| 879 | ret = subr (sp[-9], sp[-8], sp[-7], sp[-6], sp[-5], sp[-4], sp[-3], sp[-2], sp[-1], sp[0]); |
| 880 | break; |
| 881 | default: |
| 882 | abort (); |
| 883 | } |
| 884 | |
| 885 | NULLSTACK_FOR_NONLOCAL_EXIT (); |
| 886 | |
| 887 | if (SCM_UNLIKELY (SCM_VALUESP (ret))) |
| 888 | { |
| 889 | /* multiple values returned to continuation */ |
| 890 | ret = scm_struct_ref (ret, SCM_INUM0); |
| 891 | nvalues = scm_ilength (ret); |
| 892 | PUSH_LIST (ret, scm_is_null); |
| 893 | goto vm_return_values; |
| 894 | } |
| 895 | else |
| 896 | { |
| 897 | PUSH (ret); |
| 898 | goto vm_return; |
| 899 | } |
| 900 | } |
| 901 | |
| 902 | VM_DEFINE_INSTRUCTION (56, smob_call, "smob-call", 1, -1, -1) |
| 903 | { |
| 904 | SCM smob, ret; |
| 905 | SCM (*subr)(); |
| 906 | nargs = FETCH (); |
| 907 | POP (smob); |
| 908 | |
| 909 | subr = SCM_SMOB_DESCRIPTOR (smob).apply; |
| 910 | |
| 911 | VM_HANDLE_INTERRUPTS; |
| 912 | SYNC_REGISTER (); |
| 913 | |
| 914 | switch (nargs) |
| 915 | { |
| 916 | case 0: |
| 917 | ret = subr (smob); |
| 918 | break; |
| 919 | case 1: |
| 920 | ret = subr (smob, sp[0]); |
| 921 | break; |
| 922 | case 2: |
| 923 | ret = subr (smob, sp[-1], sp[0]); |
| 924 | break; |
| 925 | case 3: |
| 926 | ret = subr (smob, sp[-2], sp[-1], sp[0]); |
| 927 | break; |
| 928 | default: |
| 929 | abort (); |
| 930 | } |
| 931 | |
| 932 | NULLSTACK_FOR_NONLOCAL_EXIT (); |
| 933 | |
| 934 | if (SCM_UNLIKELY (SCM_VALUESP (ret))) |
| 935 | { |
| 936 | /* multiple values returned to continuation */ |
| 937 | ret = scm_struct_ref (ret, SCM_INUM0); |
| 938 | nvalues = scm_ilength (ret); |
| 939 | PUSH_LIST (ret, scm_is_null); |
| 940 | goto vm_return_values; |
| 941 | } |
| 942 | else |
| 943 | { |
| 944 | PUSH (ret); |
| 945 | goto vm_return; |
| 946 | } |
| 947 | } |
| 948 | |
| 949 | VM_DEFINE_INSTRUCTION (57, foreign_call, "foreign-call", 1, -1, -1) |
| 950 | { |
| 951 | SCM foreign, ret; |
| 952 | nargs = FETCH (); |
| 953 | POP (foreign); |
| 954 | |
| 955 | VM_HANDLE_INTERRUPTS; |
| 956 | SYNC_REGISTER (); |
| 957 | |
| 958 | ret = scm_i_foreign_call (foreign, sp - nargs + 1); |
| 959 | |
| 960 | NULLSTACK_FOR_NONLOCAL_EXIT (); |
| 961 | |
| 962 | if (SCM_UNLIKELY (SCM_VALUESP (ret))) |
| 963 | { |
| 964 | /* multiple values returned to continuation */ |
| 965 | ret = scm_struct_ref (ret, SCM_INUM0); |
| 966 | nvalues = scm_ilength (ret); |
| 967 | PUSH_LIST (ret, scm_is_null); |
| 968 | goto vm_return_values; |
| 969 | } |
| 970 | else |
| 971 | { |
| 972 | PUSH (ret); |
| 973 | goto vm_return; |
| 974 | } |
| 975 | } |
| 976 | |
| 977 | VM_DEFINE_INSTRUCTION (58, continuation_call, "continuation-call", 0, -1, 0) |
| 978 | { |
| 979 | SCM contregs; |
| 980 | POP (contregs); |
| 981 | |
| 982 | SYNC_ALL (); |
| 983 | scm_i_check_continuation (contregs); |
| 984 | vm_return_to_continuation (scm_i_contregs_vm (contregs), |
| 985 | scm_i_contregs_vm_cont (contregs), |
| 986 | sp - (fp - 1), fp); |
| 987 | scm_i_reinstate_continuation (contregs); |
| 988 | |
| 989 | /* no NEXT */ |
| 990 | abort (); |
| 991 | } |
| 992 | |
| 993 | VM_DEFINE_INSTRUCTION (59, partial_cont_call, "partial-cont-call", 0, -1, 0) |
| 994 | { |
| 995 | SCM vmcont, intwinds, prevwinds; |
| 996 | POP2 (intwinds, vmcont); |
| 997 | SYNC_REGISTER (); |
| 998 | VM_ASSERT (SCM_VM_CONT_REWINDABLE_P (vmcont), |
| 999 | vm_error_continuation_not_rewindable (vmcont)); |
| 1000 | prevwinds = scm_i_dynwinds (); |
| 1001 | vm_reinstate_partial_continuation (vm, vmcont, intwinds, sp + 1 - fp, fp, |
| 1002 | vm_cookie); |
| 1003 | |
| 1004 | /* Rewind prompt jmpbuffers, if any. */ |
| 1005 | { |
| 1006 | SCM winds = scm_i_dynwinds (); |
| 1007 | for (; !scm_is_eq (winds, prevwinds); winds = scm_cdr (winds)) |
| 1008 | if (SCM_PROMPT_P (scm_car (winds)) && SCM_PROMPT_SETJMP (scm_car (winds))) |
| 1009 | break; |
| 1010 | } |
| 1011 | |
| 1012 | CACHE_REGISTER (); |
| 1013 | program = SCM_FRAME_PROGRAM (fp); |
| 1014 | CACHE_PROGRAM (); |
| 1015 | NEXT; |
| 1016 | } |
| 1017 | |
| 1018 | VM_DEFINE_INSTRUCTION (60, tail_call_nargs, "tail-call/nargs", 0, 0, 1) |
| 1019 | { |
| 1020 | SCM x; |
| 1021 | POP (x); |
| 1022 | nargs = scm_to_int (x); |
| 1023 | /* FIXME: should truncate values? */ |
| 1024 | goto vm_tail_call; |
| 1025 | } |
| 1026 | |
| 1027 | VM_DEFINE_INSTRUCTION (61, call_nargs, "call/nargs", 0, 0, 1) |
| 1028 | { |
| 1029 | SCM x; |
| 1030 | POP (x); |
| 1031 | nargs = scm_to_int (x); |
| 1032 | /* FIXME: should truncate values? */ |
| 1033 | goto vm_call; |
| 1034 | } |
| 1035 | |
| 1036 | VM_DEFINE_INSTRUCTION (62, mv_call, "mv-call", 4, -1, 1) |
| 1037 | { |
| 1038 | scm_t_int32 offset; |
| 1039 | scm_t_uint8 *mvra; |
| 1040 | SCM *old_fp = fp; |
| 1041 | |
| 1042 | nargs = FETCH (); |
| 1043 | FETCH_OFFSET (offset); |
| 1044 | mvra = ip + offset; |
| 1045 | |
| 1046 | VM_HANDLE_INTERRUPTS; |
| 1047 | |
| 1048 | fp = sp - nargs + 1; |
| 1049 | |
| 1050 | ASSERT (SCM_FRAME_DYNAMIC_LINK (fp) == 0); |
| 1051 | ASSERT (SCM_FRAME_RETURN_ADDRESS (fp) == 0); |
| 1052 | ASSERT (SCM_FRAME_MV_RETURN_ADDRESS (fp) == 0); |
| 1053 | SCM_FRAME_SET_DYNAMIC_LINK (fp, old_fp); |
| 1054 | SCM_FRAME_SET_RETURN_ADDRESS (fp, ip); |
| 1055 | SCM_FRAME_SET_MV_RETURN_ADDRESS (fp, mvra); |
| 1056 | |
| 1057 | PUSH_CONTINUATION_HOOK (); |
| 1058 | |
| 1059 | program = fp[-1]; |
| 1060 | |
| 1061 | if (SCM_UNLIKELY (!SCM_PROGRAM_P (program))) |
| 1062 | goto apply; |
| 1063 | |
| 1064 | CACHE_PROGRAM (); |
| 1065 | ip = SCM_C_OBJCODE_BASE (bp); |
| 1066 | |
| 1067 | APPLY_HOOK (); |
| 1068 | NEXT; |
| 1069 | } |
| 1070 | |
| 1071 | VM_DEFINE_INSTRUCTION (63, apply, "apply", 1, -1, 1) |
| 1072 | { |
| 1073 | int len; |
| 1074 | SCM ls; |
| 1075 | POP (ls); |
| 1076 | |
| 1077 | nargs = FETCH (); |
| 1078 | ASSERT (nargs >= 2); |
| 1079 | |
| 1080 | len = scm_ilength (ls); |
| 1081 | VM_ASSERT (len >= 0, |
| 1082 | vm_error_apply_to_non_list (ls)); |
| 1083 | PUSH_LIST (ls, SCM_NULL_OR_NIL_P); |
| 1084 | |
| 1085 | nargs += len - 2; |
| 1086 | goto vm_call; |
| 1087 | } |
| 1088 | |
| 1089 | VM_DEFINE_INSTRUCTION (64, tail_apply, "tail-apply", 1, -1, 1) |
| 1090 | { |
| 1091 | int len; |
| 1092 | SCM ls; |
| 1093 | POP (ls); |
| 1094 | |
| 1095 | nargs = FETCH (); |
| 1096 | ASSERT (nargs >= 2); |
| 1097 | |
| 1098 | len = scm_ilength (ls); |
| 1099 | VM_ASSERT (len >= 0, |
| 1100 | vm_error_apply_to_non_list (ls)); |
| 1101 | PUSH_LIST (ls, SCM_NULL_OR_NIL_P); |
| 1102 | |
| 1103 | nargs += len - 2; |
| 1104 | goto vm_tail_call; |
| 1105 | } |
| 1106 | |
| 1107 | VM_DEFINE_INSTRUCTION (65, call_cc, "call/cc", 0, 1, 1) |
| 1108 | { |
| 1109 | int first; |
| 1110 | SCM proc, vm_cont, cont; |
| 1111 | POP (proc); |
| 1112 | SYNC_ALL (); |
| 1113 | vm_cont = scm_i_vm_capture_stack (vp->stack_base, fp, sp, ip, NULL, 0); |
| 1114 | cont = scm_i_make_continuation (&first, vm, vm_cont); |
| 1115 | if (first) |
| 1116 | { |
| 1117 | PUSH (SCM_PACK (0)); /* dynamic link */ |
| 1118 | PUSH (SCM_PACK (0)); /* mvra */ |
| 1119 | PUSH (SCM_PACK (0)); /* ra */ |
| 1120 | PUSH (proc); |
| 1121 | PUSH (cont); |
| 1122 | nargs = 1; |
| 1123 | goto vm_call; |
| 1124 | } |
| 1125 | else |
| 1126 | { |
| 1127 | /* Otherwise, the vm continuation was reinstated, and |
| 1128 | vm_return_to_continuation pushed on one value. We know only one |
| 1129 | value was returned because we are in value context -- the |
| 1130 | previous block jumped to vm_call, not vm_mv_call, after all. |
| 1131 | |
| 1132 | So, pull our regs back down from the vp, and march on to the |
| 1133 | next instruction. */ |
| 1134 | CACHE_REGISTER (); |
| 1135 | program = SCM_FRAME_PROGRAM (fp); |
| 1136 | CACHE_PROGRAM (); |
| 1137 | RESTORE_CONTINUATION_HOOK (); |
| 1138 | NEXT; |
| 1139 | } |
| 1140 | } |
| 1141 | |
| 1142 | VM_DEFINE_INSTRUCTION (66, tail_call_cc, "tail-call/cc", 0, 1, 1) |
| 1143 | { |
| 1144 | int first; |
| 1145 | SCM proc, vm_cont, cont; |
| 1146 | POP (proc); |
| 1147 | SYNC_ALL (); |
| 1148 | /* In contrast to call/cc, tail-call/cc captures the continuation without the |
| 1149 | stack frame. */ |
| 1150 | vm_cont = scm_i_vm_capture_stack (vp->stack_base, |
| 1151 | SCM_FRAME_DYNAMIC_LINK (fp), |
| 1152 | SCM_FRAME_LOWER_ADDRESS (fp) - 1, |
| 1153 | SCM_FRAME_RETURN_ADDRESS (fp), |
| 1154 | SCM_FRAME_MV_RETURN_ADDRESS (fp), |
| 1155 | 0); |
| 1156 | cont = scm_i_make_continuation (&first, vm, vm_cont); |
| 1157 | if (first) |
| 1158 | { |
| 1159 | PUSH (proc); |
| 1160 | PUSH (cont); |
| 1161 | nargs = 1; |
| 1162 | goto vm_tail_call; |
| 1163 | } |
| 1164 | else |
| 1165 | { |
| 1166 | /* Otherwise, cache regs and NEXT, as above. Invoking the continuation |
| 1167 | does a return from the frame, either to the RA or |
| 1168 | MVRA. */ |
| 1169 | CACHE_REGISTER (); |
| 1170 | program = SCM_FRAME_PROGRAM (fp); |
| 1171 | CACHE_PROGRAM (); |
| 1172 | /* Unfortunately we don't know whether we are at the RA, and thus |
| 1173 | have one value without an nvalues marker, or we are at the |
| 1174 | MVRA and thus have multiple values and the nvalues |
| 1175 | marker. Instead of adding heuristics here, we will let hook |
| 1176 | client code do that. */ |
| 1177 | RESTORE_CONTINUATION_HOOK (); |
| 1178 | NEXT; |
| 1179 | } |
| 1180 | } |
| 1181 | |
| 1182 | VM_DEFINE_INSTRUCTION (67, return, "return", 0, 1, 1) |
| 1183 | { |
| 1184 | vm_return: |
| 1185 | POP_CONTINUATION_HOOK (1); |
| 1186 | |
| 1187 | VM_HANDLE_INTERRUPTS; |
| 1188 | |
| 1189 | { |
| 1190 | SCM ret; |
| 1191 | |
| 1192 | POP (ret); |
| 1193 | |
| 1194 | #ifdef VM_ENABLE_STACK_NULLING |
| 1195 | SCM *old_sp = sp; |
| 1196 | #endif |
| 1197 | |
| 1198 | /* Restore registers */ |
| 1199 | sp = SCM_FRAME_LOWER_ADDRESS (fp); |
| 1200 | ip = SCM_FRAME_RETURN_ADDRESS (fp); |
| 1201 | fp = SCM_FRAME_DYNAMIC_LINK (fp); |
| 1202 | |
| 1203 | #ifdef VM_ENABLE_STACK_NULLING |
| 1204 | NULLSTACK (old_sp - sp); |
| 1205 | #endif |
| 1206 | |
| 1207 | /* Set return value (sp is already pushed) */ |
| 1208 | *sp = ret; |
| 1209 | } |
| 1210 | |
| 1211 | /* Restore the last program */ |
| 1212 | program = SCM_FRAME_PROGRAM (fp); |
| 1213 | CACHE_PROGRAM (); |
| 1214 | CHECK_IP (); |
| 1215 | NEXT; |
| 1216 | } |
| 1217 | |
| 1218 | VM_DEFINE_INSTRUCTION (68, return_values, "return/values", 1, -1, -1) |
| 1219 | { |
| 1220 | /* nvalues declared at top level, because for some reason gcc seems to think |
| 1221 | that perhaps it might be used without declaration. Fooey to that, I say. */ |
| 1222 | nvalues = FETCH (); |
| 1223 | vm_return_values: |
| 1224 | POP_CONTINUATION_HOOK (nvalues); |
| 1225 | |
| 1226 | VM_HANDLE_INTERRUPTS; |
| 1227 | |
| 1228 | if (nvalues != 1 && SCM_FRAME_MV_RETURN_ADDRESS (fp)) |
| 1229 | { |
| 1230 | /* A multiply-valued continuation */ |
| 1231 | SCM *vals = sp - nvalues; |
| 1232 | int i; |
| 1233 | /* Restore registers */ |
| 1234 | sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; |
| 1235 | ip = SCM_FRAME_MV_RETURN_ADDRESS (fp); |
| 1236 | fp = SCM_FRAME_DYNAMIC_LINK (fp); |
| 1237 | |
| 1238 | /* Push return values, and the number of values */ |
| 1239 | for (i = 0; i < nvalues; i++) |
| 1240 | *++sp = vals[i+1]; |
| 1241 | *++sp = SCM_I_MAKINUM (nvalues); |
| 1242 | |
| 1243 | /* Finally null the end of the stack */ |
| 1244 | NULLSTACK (vals + nvalues - sp); |
| 1245 | } |
| 1246 | else if (nvalues >= 1) |
| 1247 | { |
| 1248 | /* Multiple values for a single-valued continuation -- here's where I |
| 1249 | break with guile tradition and try and do something sensible. (Also, |
| 1250 | this block handles the single-valued return to an mv |
| 1251 | continuation.) */ |
| 1252 | SCM *vals = sp - nvalues; |
| 1253 | /* Restore registers */ |
| 1254 | sp = SCM_FRAME_LOWER_ADDRESS (fp) - 1; |
| 1255 | ip = SCM_FRAME_RETURN_ADDRESS (fp); |
| 1256 | fp = SCM_FRAME_DYNAMIC_LINK (fp); |
| 1257 | |
| 1258 | /* Push first value */ |
| 1259 | *++sp = vals[1]; |
| 1260 | |
| 1261 | /* Finally null the end of the stack */ |
| 1262 | NULLSTACK (vals + nvalues - sp); |
| 1263 | } |
| 1264 | else |
| 1265 | { |
| 1266 | SYNC_ALL (); |
| 1267 | vm_error_no_values (); |
| 1268 | } |
| 1269 | |
| 1270 | /* Restore the last program */ |
| 1271 | program = SCM_FRAME_PROGRAM (fp); |
| 1272 | CACHE_PROGRAM (); |
| 1273 | CHECK_IP (); |
| 1274 | NEXT; |
| 1275 | } |
| 1276 | |
| 1277 | VM_DEFINE_INSTRUCTION (69, return_values_star, "return/values*", 1, -1, -1) |
| 1278 | { |
| 1279 | SCM l; |
| 1280 | |
| 1281 | nvalues = FETCH (); |
| 1282 | ASSERT (nvalues >= 1); |
| 1283 | |
| 1284 | nvalues--; |
| 1285 | POP (l); |
| 1286 | while (scm_is_pair (l)) |
| 1287 | { |
| 1288 | PUSH (SCM_CAR (l)); |
| 1289 | l = SCM_CDR (l); |
| 1290 | nvalues++; |
| 1291 | } |
| 1292 | VM_ASSERT (SCM_NULL_OR_NIL_P (l), vm_error_improper_list (l)); |
| 1293 | |
| 1294 | goto vm_return_values; |
| 1295 | } |
| 1296 | |
| 1297 | VM_DEFINE_INSTRUCTION (70, return_nvalues, "return/nvalues", 0, 1, -1) |
| 1298 | { |
| 1299 | SCM n; |
| 1300 | POP (n); |
| 1301 | nvalues = scm_to_int (n); |
| 1302 | ASSERT (nvalues >= 0); |
| 1303 | goto vm_return_values; |
| 1304 | } |
| 1305 | |
| 1306 | VM_DEFINE_INSTRUCTION (71, truncate_values, "truncate-values", 2, -1, -1) |
| 1307 | { |
| 1308 | SCM x; |
| 1309 | int nbinds, rest; |
| 1310 | POP (x); |
| 1311 | nvalues = scm_to_int (x); |
| 1312 | nbinds = FETCH (); |
| 1313 | rest = FETCH (); |
| 1314 | |
| 1315 | if (rest) |
| 1316 | nbinds--; |
| 1317 | |
| 1318 | VM_ASSERT (nvalues >= nbinds, vm_error_not_enough_values ()); |
| 1319 | |
| 1320 | if (rest) |
| 1321 | POP_LIST (nvalues - nbinds); |
| 1322 | else |
| 1323 | DROPN (nvalues - nbinds); |
| 1324 | |
| 1325 | NEXT; |
| 1326 | } |
| 1327 | |
| 1328 | VM_DEFINE_INSTRUCTION (72, box, "box", 1, 1, 0) |
| 1329 | { |
| 1330 | SCM val; |
| 1331 | POP (val); |
| 1332 | SYNC_BEFORE_GC (); |
| 1333 | LOCAL_SET (FETCH (), scm_cell (scm_tc7_variable, SCM_UNPACK (val))); |
| 1334 | NEXT; |
| 1335 | } |
| 1336 | |
| 1337 | /* for letrec: |
| 1338 | (let ((a *undef*) (b *undef*) ...) |
| 1339 | (set! a (lambda () (b ...))) |
| 1340 | ...) |
| 1341 | */ |
| 1342 | VM_DEFINE_INSTRUCTION (73, empty_box, "empty-box", 1, 0, 0) |
| 1343 | { |
| 1344 | SYNC_BEFORE_GC (); |
| 1345 | LOCAL_SET (FETCH (), |
| 1346 | scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED))); |
| 1347 | NEXT; |
| 1348 | } |
| 1349 | |
| 1350 | VM_DEFINE_INSTRUCTION (74, local_boxed_ref, "local-boxed-ref", 1, 0, 1) |
| 1351 | { |
| 1352 | SCM v = LOCAL_REF (FETCH ()); |
| 1353 | ASSERT_BOUND_VARIABLE (v); |
| 1354 | PUSH (VARIABLE_REF (v)); |
| 1355 | NEXT; |
| 1356 | } |
| 1357 | |
| 1358 | VM_DEFINE_INSTRUCTION (75, local_boxed_set, "local-boxed-set", 1, 1, 0) |
| 1359 | { |
| 1360 | SCM v, val; |
| 1361 | v = LOCAL_REF (FETCH ()); |
| 1362 | POP (val); |
| 1363 | ASSERT_VARIABLE (v); |
| 1364 | VARIABLE_SET (v, val); |
| 1365 | NEXT; |
| 1366 | } |
| 1367 | |
| 1368 | VM_DEFINE_INSTRUCTION (76, free_ref, "free-ref", 1, 0, 1) |
| 1369 | { |
| 1370 | scm_t_uint8 idx = FETCH (); |
| 1371 | |
| 1372 | CHECK_FREE_VARIABLE (idx); |
| 1373 | PUSH (FREE_VARIABLE_REF (idx)); |
| 1374 | NEXT; |
| 1375 | } |
| 1376 | |
| 1377 | /* no free-set -- if a var is assigned, it should be in a box */ |
| 1378 | |
| 1379 | VM_DEFINE_INSTRUCTION (77, free_boxed_ref, "free-boxed-ref", 1, 0, 1) |
| 1380 | { |
| 1381 | SCM v; |
| 1382 | scm_t_uint8 idx = FETCH (); |
| 1383 | CHECK_FREE_VARIABLE (idx); |
| 1384 | v = FREE_VARIABLE_REF (idx); |
| 1385 | ASSERT_BOUND_VARIABLE (v); |
| 1386 | PUSH (VARIABLE_REF (v)); |
| 1387 | NEXT; |
| 1388 | } |
| 1389 | |
| 1390 | VM_DEFINE_INSTRUCTION (78, free_boxed_set, "free-boxed-set", 1, 1, 0) |
| 1391 | { |
| 1392 | SCM v, val; |
| 1393 | scm_t_uint8 idx = FETCH (); |
| 1394 | POP (val); |
| 1395 | CHECK_FREE_VARIABLE (idx); |
| 1396 | v = FREE_VARIABLE_REF (idx); |
| 1397 | ASSERT_BOUND_VARIABLE (v); |
| 1398 | VARIABLE_SET (v, val); |
| 1399 | NEXT; |
| 1400 | } |
| 1401 | |
| 1402 | VM_DEFINE_INSTRUCTION (79, make_closure, "make-closure", 2, -1, 1) |
| 1403 | { |
| 1404 | size_t n, len; |
| 1405 | SCM closure; |
| 1406 | |
| 1407 | len = FETCH (); |
| 1408 | len <<= 8; |
| 1409 | len += FETCH (); |
| 1410 | SYNC_BEFORE_GC (); |
| 1411 | closure = scm_words (scm_tc7_program | (len<<16), len + 3); |
| 1412 | SCM_SET_CELL_OBJECT_1 (closure, SCM_PROGRAM_OBJCODE (sp[-len])); |
| 1413 | SCM_SET_CELL_OBJECT_2 (closure, SCM_PROGRAM_OBJTABLE (sp[-len])); |
| 1414 | sp[-len] = closure; |
| 1415 | for (n = 0; n < len; n++) |
| 1416 | SCM_PROGRAM_FREE_VARIABLE_SET (closure, n, sp[-len + 1 + n]); |
| 1417 | DROPN (len); |
| 1418 | NEXT; |
| 1419 | } |
| 1420 | |
| 1421 | VM_DEFINE_INSTRUCTION (80, make_variable, "make-variable", 0, 0, 1) |
| 1422 | { |
| 1423 | SYNC_BEFORE_GC (); |
| 1424 | /* fixme underflow */ |
| 1425 | PUSH (scm_cell (scm_tc7_variable, SCM_UNPACK (SCM_UNDEFINED))); |
| 1426 | NEXT; |
| 1427 | } |
| 1428 | |
| 1429 | VM_DEFINE_INSTRUCTION (81, fix_closure, "fix-closure", 2, -1, 0) |
| 1430 | { |
| 1431 | SCM x; |
| 1432 | unsigned int i = FETCH (); |
| 1433 | size_t n, len; |
| 1434 | i <<= 8; |
| 1435 | i += FETCH (); |
| 1436 | /* FIXME CHECK_LOCAL (i) */ |
| 1437 | x = LOCAL_REF (i); |
| 1438 | /* FIXME ASSERT_PROGRAM (x); */ |
| 1439 | len = SCM_PROGRAM_NUM_FREE_VARIABLES (x); |
| 1440 | for (n = 0; n < len; n++) |
| 1441 | SCM_PROGRAM_FREE_VARIABLE_SET (x, n, sp[-len + 1 + n]); |
| 1442 | DROPN (len); |
| 1443 | NEXT; |
| 1444 | } |
| 1445 | |
| 1446 | VM_DEFINE_INSTRUCTION (82, define, "define", 0, 0, 2) |
| 1447 | { |
| 1448 | SCM sym, val; |
| 1449 | POP2 (sym, val); |
| 1450 | SYNC_REGISTER (); |
| 1451 | scm_define (sym, val); |
| 1452 | NEXT; |
| 1453 | } |
| 1454 | |
| 1455 | VM_DEFINE_INSTRUCTION (83, make_keyword, "make-keyword", 0, 1, 1) |
| 1456 | { |
| 1457 | CHECK_UNDERFLOW (); |
| 1458 | SYNC_REGISTER (); |
| 1459 | *sp = scm_symbol_to_keyword (*sp); |
| 1460 | NEXT; |
| 1461 | } |
| 1462 | |
| 1463 | VM_DEFINE_INSTRUCTION (84, make_symbol, "make-symbol", 0, 1, 1) |
| 1464 | { |
| 1465 | CHECK_UNDERFLOW (); |
| 1466 | SYNC_REGISTER (); |
| 1467 | *sp = scm_string_to_symbol (*sp); |
| 1468 | NEXT; |
| 1469 | } |
| 1470 | |
| 1471 | VM_DEFINE_INSTRUCTION (85, prompt, "prompt", 4, 2, 0) |
| 1472 | { |
| 1473 | scm_t_int32 offset; |
| 1474 | scm_t_uint8 escape_only_p; |
| 1475 | SCM k, prompt; |
| 1476 | |
| 1477 | escape_only_p = FETCH (); |
| 1478 | FETCH_OFFSET (offset); |
| 1479 | POP (k); |
| 1480 | |
| 1481 | SYNC_REGISTER (); |
| 1482 | /* Push the prompt onto the dynamic stack. */ |
| 1483 | prompt = scm_c_make_prompt (k, fp, sp, ip + offset, escape_only_p, vm_cookie, |
| 1484 | scm_i_dynwinds ()); |
| 1485 | scm_i_set_dynwinds (scm_cons (prompt, SCM_PROMPT_DYNWINDS (prompt))); |
| 1486 | if (SCM_PROMPT_SETJMP (prompt)) |
| 1487 | { |
| 1488 | /* The prompt exited nonlocally. Cache the regs back from the vp, and go |
| 1489 | to the handler. |
| 1490 | |
| 1491 | Note, at this point, we must assume that any variable local to |
| 1492 | vm_engine that can be assigned *has* been assigned. So we need to pull |
| 1493 | all our state back from the ip/fp/sp. |
| 1494 | */ |
| 1495 | CACHE_REGISTER (); |
| 1496 | program = SCM_FRAME_PROGRAM (fp); |
| 1497 | CACHE_PROGRAM (); |
| 1498 | /* The stack contains the values returned to this prompt, along |
| 1499 | with a number-of-values marker -- like an MV return. */ |
| 1500 | ABORT_CONTINUATION_HOOK (); |
| 1501 | NEXT; |
| 1502 | } |
| 1503 | |
| 1504 | /* Otherwise setjmp returned for the first time, so we go to execute the |
| 1505 | prompt's body. */ |
| 1506 | NEXT; |
| 1507 | } |
| 1508 | |
| 1509 | VM_DEFINE_INSTRUCTION (86, wind, "wind", 0, 2, 0) |
| 1510 | { |
| 1511 | SCM wind, unwind; |
| 1512 | POP2 (unwind, wind); |
| 1513 | SYNC_REGISTER (); |
| 1514 | /* Push wind and unwind procedures onto the dynamic stack. Note that neither |
| 1515 | are actually called; the compiler should emit calls to wind and unwind for |
| 1516 | the normal dynamic-wind control flow. */ |
| 1517 | VM_ASSERT (scm_to_bool (scm_thunk_p (wind)), |
| 1518 | vm_error_not_a_thunk ("dynamic-wind", wind)); |
| 1519 | VM_ASSERT (scm_to_bool (scm_thunk_p (unwind)), |
| 1520 | vm_error_not_a_thunk ("dynamic-wind", unwind)); |
| 1521 | scm_i_set_dynwinds (scm_cons (scm_cons (wind, unwind), scm_i_dynwinds ())); |
| 1522 | NEXT; |
| 1523 | } |
| 1524 | |
| 1525 | VM_DEFINE_INSTRUCTION (87, abort, "abort", 1, -1, -1) |
| 1526 | { |
| 1527 | unsigned n = FETCH (); |
| 1528 | SYNC_REGISTER (); |
| 1529 | PRE_CHECK_UNDERFLOW (n + 2); |
| 1530 | vm_abort (vm, n, vm_cookie); |
| 1531 | /* vm_abort should not return */ |
| 1532 | abort (); |
| 1533 | } |
| 1534 | |
| 1535 | VM_DEFINE_INSTRUCTION (88, unwind, "unwind", 0, 0, 0) |
| 1536 | { |
| 1537 | /* A normal exit from the dynamic extent of an expression. Pop the top entry |
| 1538 | off of the dynamic stack. */ |
| 1539 | scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ())); |
| 1540 | NEXT; |
| 1541 | } |
| 1542 | |
| 1543 | VM_DEFINE_INSTRUCTION (89, wind_fluids, "wind-fluids", 1, -1, 0) |
| 1544 | { |
| 1545 | unsigned n = FETCH (); |
| 1546 | SCM wf; |
| 1547 | |
| 1548 | SYNC_REGISTER (); |
| 1549 | sp -= 2 * n; |
| 1550 | CHECK_UNDERFLOW (); |
| 1551 | wf = scm_i_make_with_fluids (n, sp + 1, sp + 1 + n); |
| 1552 | NULLSTACK (2 * n); |
| 1553 | |
| 1554 | scm_i_swap_with_fluids (wf, current_thread->dynamic_state); |
| 1555 | scm_i_set_dynwinds (scm_cons (wf, scm_i_dynwinds ())); |
| 1556 | NEXT; |
| 1557 | } |
| 1558 | |
| 1559 | VM_DEFINE_INSTRUCTION (90, unwind_fluids, "unwind-fluids", 0, 0, 0) |
| 1560 | { |
| 1561 | SCM wf; |
| 1562 | wf = scm_car (scm_i_dynwinds ()); |
| 1563 | scm_i_set_dynwinds (scm_cdr (scm_i_dynwinds ())); |
| 1564 | scm_i_swap_with_fluids (wf, current_thread->dynamic_state); |
| 1565 | NEXT; |
| 1566 | } |
| 1567 | |
| 1568 | VM_DEFINE_INSTRUCTION (91, fluid_ref, "fluid-ref", 0, 1, 1) |
| 1569 | { |
| 1570 | size_t num; |
| 1571 | SCM fluids; |
| 1572 | |
| 1573 | CHECK_UNDERFLOW (); |
| 1574 | fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state); |
| 1575 | if (SCM_UNLIKELY (!SCM_FLUID_P (*sp)) |
| 1576 | || ((num = SCM_I_FLUID_NUM (*sp)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) |
| 1577 | { |
| 1578 | /* Punt dynstate expansion and error handling to the C proc. */ |
| 1579 | SYNC_REGISTER (); |
| 1580 | *sp = scm_fluid_ref (*sp); |
| 1581 | } |
| 1582 | else |
| 1583 | { |
| 1584 | SCM val = SCM_SIMPLE_VECTOR_REF (fluids, num); |
| 1585 | if (scm_is_eq (val, SCM_UNDEFINED)) |
| 1586 | val = SCM_I_FLUID_DEFAULT (*sp); |
| 1587 | VM_ASSERT (!scm_is_eq (val, SCM_UNDEFINED), |
| 1588 | vm_error_unbound_fluid (program, *sp)); |
| 1589 | *sp = val; |
| 1590 | } |
| 1591 | |
| 1592 | NEXT; |
| 1593 | } |
| 1594 | |
| 1595 | VM_DEFINE_INSTRUCTION (92, fluid_set, "fluid-set", 0, 2, 0) |
| 1596 | { |
| 1597 | size_t num; |
| 1598 | SCM val, fluid, fluids; |
| 1599 | |
| 1600 | POP2 (val, fluid); |
| 1601 | fluids = SCM_I_DYNAMIC_STATE_FLUIDS (current_thread->dynamic_state); |
| 1602 | if (SCM_UNLIKELY (!SCM_FLUID_P (fluid)) |
| 1603 | || ((num = SCM_I_FLUID_NUM (fluid)) >= SCM_SIMPLE_VECTOR_LENGTH (fluids))) |
| 1604 | { |
| 1605 | /* Punt dynstate expansion and error handling to the C proc. */ |
| 1606 | SYNC_REGISTER (); |
| 1607 | scm_fluid_set_x (fluid, val); |
| 1608 | } |
| 1609 | else |
| 1610 | SCM_SIMPLE_VECTOR_SET (fluids, num, val); |
| 1611 | |
| 1612 | NEXT; |
| 1613 | } |
| 1614 | |
| 1615 | VM_DEFINE_INSTRUCTION (93, assert_nargs_ee_locals, "assert-nargs-ee/locals", 1, 0, 0) |
| 1616 | { |
| 1617 | scm_t_ptrdiff n; |
| 1618 | SCM *old_sp; |
| 1619 | |
| 1620 | /* nargs = n & 0x7, nlocs = nargs + (n >> 3) */ |
| 1621 | n = FETCH (); |
| 1622 | |
| 1623 | VM_ASSERT (sp - (fp - 1) == (n & 0x7), |
| 1624 | vm_error_wrong_num_args (program)); |
| 1625 | |
| 1626 | old_sp = sp; |
| 1627 | sp += (n >> 3); |
| 1628 | CHECK_OVERFLOW (); |
| 1629 | while (old_sp < sp) |
| 1630 | *++old_sp = SCM_UNDEFINED; |
| 1631 | |
| 1632 | NEXT; |
| 1633 | } |
| 1634 | |
| 1635 | /* Like bind-optionals/shuffle, but if there are too many positional |
| 1636 | arguments, jumps to the next case-lambda clause. */ |
| 1637 | VM_DEFINE_INSTRUCTION (94, bind_optionals_shuffle_or_br, "bind-optionals/shuffle-or-br", 9, -1, -1) |
| 1638 | { |
| 1639 | SCM *walk; |
| 1640 | scm_t_ptrdiff nreq, nreq_and_opt, ntotal; |
| 1641 | scm_t_int32 offset; |
| 1642 | nreq = FETCH () << 8; |
| 1643 | nreq += FETCH (); |
| 1644 | nreq_and_opt = FETCH () << 8; |
| 1645 | nreq_and_opt += FETCH (); |
| 1646 | ntotal = FETCH () << 8; |
| 1647 | ntotal += FETCH (); |
| 1648 | FETCH_OFFSET (offset); |
| 1649 | |
| 1650 | /* look in optionals for first keyword or last positional */ |
| 1651 | /* starting after the last required positional arg */ |
| 1652 | walk = fp + nreq; |
| 1653 | while (/* while we have args */ |
| 1654 | walk <= sp |
| 1655 | /* and we still have positionals to fill */ |
| 1656 | && walk - fp < nreq_and_opt |
| 1657 | /* and we haven't reached a keyword yet */ |
| 1658 | && !scm_is_keyword (*walk)) |
| 1659 | /* bind this optional arg (by leaving it in place) */ |
| 1660 | walk++; |
| 1661 | if (/* If we have filled all the positionals */ |
| 1662 | walk - fp == nreq_and_opt |
| 1663 | /* and there are still more arguments */ |
| 1664 | && walk <= sp |
| 1665 | /* and the next argument is not a keyword, */ |
| 1666 | && !scm_is_keyword (*walk)) |
| 1667 | { |
| 1668 | /* Jump to the next case-lambda* clause. */ |
| 1669 | ip += offset; |
| 1670 | } |
| 1671 | else |
| 1672 | { |
| 1673 | /* Otherwise, finish as in bind-optionals/shuffle: shuffle up, |
| 1674 | from walk to ntotal */ |
| 1675 | scm_t_ptrdiff nshuf = sp - walk + 1, i; |
| 1676 | sp = (fp - 1) + ntotal + nshuf; |
| 1677 | CHECK_OVERFLOW (); |
| 1678 | for (i = 0; i < nshuf; i++) |
| 1679 | sp[-i] = walk[nshuf-i-1]; |
| 1680 | |
| 1681 | /* and fill optionals & keyword args with SCM_UNDEFINED */ |
| 1682 | while (walk <= (fp - 1) + ntotal) |
| 1683 | *walk++ = SCM_UNDEFINED; |
| 1684 | } |
| 1685 | |
| 1686 | NEXT; |
| 1687 | } |
| 1688 | |
| 1689 | |
| 1690 | /* |
| 1691 | (defun renumber-ops () |
| 1692 | "start from top of buffer and renumber 'VM_DEFINE_FOO (\n' sequences" |
| 1693 | (interactive "") |
| 1694 | (save-excursion |
| 1695 | (let ((counter -1)) (goto-char (point-min)) |
| 1696 | (while (re-search-forward "^VM_DEFINE_[^ ]+ (\\([^,]+\\)," (point-max) t) |
| 1697 | (replace-match |
| 1698 | (number-to-string (setq counter (1+ counter))) |
| 1699 | t t nil 1))))) |
| 1700 | (renumber-ops) |
| 1701 | */ |
| 1702 | /* |
| 1703 | Local Variables: |
| 1704 | c-file-style: "gnu" |
| 1705 | End: |
| 1706 | */ |