src/vm_system.c

   1 /* Copyright (C) 2000 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* This file is included in vm_engine.c */
  43
  44 \f
  45 /*
  46  * Basic operations
  47  */
  48
  49 /* This must be the first instruction! */
  50 VM_DEFINE_INSTRUCTION (nop, "nop", 0)
  51 {
  52   NEXT;
  53 }
  54
  55 VM_DEFINE_INSTRUCTION (halt, "halt", 0)
  56 {
  57   SCM ret = *sp;
  58   HALT_HOOK ();
  59   FREE_FRAME ();
  60   SYNC_ALL ();
  61   return ret;
  62 }
  63
  64 VM_DEFINE_INSTRUCTION (drop, "drop", 0)
  65 {
  66   DROP ();
  67   NEXT;
  68 }
  69
  70 VM_DEFINE_INSTRUCTION (dup, "dup", 0)
  71 {
  72   PUSH (*sp);
  73   NEXT;
  74 }
  75
  76 \f
  77 /*
  78  * Object creation
  79  */
  80
  81 VM_DEFINE_INSTRUCTION (void, "void", 0)
  82 {
  83   PUSH (SCM_UNSPECIFIED);
  84   NEXT;
  85 }
  86
  87 VM_DEFINE_INSTRUCTION (mark, "mark", 0)
  88 {
  89   PUSH (SCM_UNDEFINED);
  90   NEXT;
  91 }
  92
  93 VM_DEFINE_INSTRUCTION (make_true, "make-true", 0)
  94 {
  95   PUSH (SCM_BOOL_T);
  96   NEXT;
  97 }
  98
  99 VM_DEFINE_INSTRUCTION (make_false, "make-false", 0)
 100 {
 101   PUSH (SCM_BOOL_F);
 102   NEXT;
 103 }
 104
 105 VM_DEFINE_INSTRUCTION (make_eol, "make-eol", 0)
 106 {
 107   PUSH (SCM_EOL);
 108   NEXT;
 109 }
 110
 111 VM_DEFINE_INSTRUCTION (make_int8, "make-int8", 1)
 112 {
 113   PUSH (SCM_MAKINUM ((signed char) FETCH ()));
 114   NEXT;
 115 }
 116
 117 VM_DEFINE_INSTRUCTION (make_int8_0, "make-int8:0", 0)
 118 {
 119   PUSH (SCM_MAKINUM (0));
 120   NEXT;
 121 }
 122
 123 VM_DEFINE_INSTRUCTION (make_int8_1, "make-int8:1", 0)
 124 {
 125   PUSH (SCM_MAKINUM (1));
 126   NEXT;
 127 }
 128
 129 VM_DEFINE_INSTRUCTION (make_int16, "make-int16", 2)
 130 {
 131   PUSH (SCM_MAKINUM ((signed short) FETCH2 ()));
 132   NEXT;
 133 }
 134
 135 VM_DEFINE_INSTRUCTION (make_char8, "make-char8", 1)
 136 {
 137   PUSH (SCM_MAKE_CHAR (FETCH ()));
 138   NEXT;
 139 }
 140
 141 \f
 142 /*
 143  * Variable access
 144  */
 145
 146 #define OBJECT_REF(i)           objects[i]
 147 #define OBJECT_SET(i,o)         objects[i] = o
 148
 149 #define LOCAL_REF(i)            SCM_VM_FRAME_VARIABLE (fp, i)
 150 #define LOCAL_SET(i,o)          SCM_VM_FRAME_VARIABLE (fp, i) = o
 151
 152 #define VARIABLE_REF(v)         SCM_CDR (v)
 153 #define VARIABLE_SET(v,o)       SCM_SETCDR (v, o)
 154
 155 VM_DEFINE_INSTRUCTION (external, "external", 1)
 156 {
 157   int n = FETCH ();
 158   while (n-- > 0)
 159     CONS (external, SCM_UNDEFINED, external);
 160   NEXT;
 161 }
 162
 163 /* ref */
 164
 165 VM_DEFINE_INSTRUCTION (object_ref, "object-ref", 1)
 166 {
 167   PUSH (OBJECT_REF (FETCH ()));
 168   NEXT;
 169 }
 170
 171 VM_DEFINE_INSTRUCTION (object_ref_2, "object-ref*2", 2)
 172 {
 173   PUSH (OBJECT_REF (FETCH2 ()));
 174   NEXT;
 175 }
 176
 177 VM_DEFINE_INSTRUCTION (local_ref, "local-ref", 1)
 178 {
 179   PUSH (LOCAL_REF (FETCH ()));
 180   NEXT;
 181 }
 182
 183 VM_DEFINE_INSTRUCTION (local_ref_0, "local-ref:0", 0)
 184 {
 185   PUSH (LOCAL_REF (0));
 186   NEXT;
 187 }
 188
 189 VM_DEFINE_INSTRUCTION (local_ref_2, "local-ref*2", 2)
 190 {
 191   PUSH (LOCAL_REF (FETCH2 ()));
 192   NEXT;
 193 }
 194
 195 VM_DEFINE_INSTRUCTION (external_ref, "external-ref", 1)
 196 {
 197   unsigned int i;
 198   SCM e = external;
 199   for (i = FETCH (); i; i--)
 200     e = SCM_CDR (e);
 201   PUSH (SCM_CAR (e));
 202   NEXT;
 203 }
 204
 205 VM_DEFINE_INSTRUCTION (module_ref, "module-ref", 1)
 206 {
 207   int i = FETCH ();
 208   SCM o, x = OBJECT_REF (i);
 209   o = VARIABLE_REF (x);
 210   if (SCM_UNBNDP (o))
 211     {
 212       err_args = SCM_LIST1 (SCM_CAR (x));
 213       goto vm_error_unbound;
 214     }
 215   PUSH (o);
 216   NEXT;
 217 }
 218
 219 VM_DEFINE_INSTRUCTION (module_ref_2, "module-ref*2", 2)
 220 {
 221   int i = FETCH2 ();
 222   SCM o, x = OBJECT_REF (i);
 223   o = VARIABLE_REF (x);
 224   if (SCM_UNBNDP (o))
 225     {
 226       err_args = SCM_LIST1 (SCM_CAR (x));
 227       goto vm_error_unbound;
 228     }
 229   PUSH (o);
 230   NEXT;
 231 }
 232
 233 VM_DEFINE_INSTRUCTION (variable_ref, "variable-ref", 0)
 234 {
 235   SCM x = *sp;
 236   SCM o = VARIABLE_REF (x);
 237   if (SCM_UNBNDP (o))
 238     {
 239       err_args = SCM_LIST1 (SCM_CAR (x));
 240       goto vm_error_unbound;
 241     }
 242   *sp = o;
 243   NEXT;
 244 }
 245
 246 /* set */
 247
 248 VM_DEFINE_INSTRUCTION (local_set, "local-set", 1)
 249 {
 250   LOCAL_SET (FETCH (), *sp);
 251   DROP ();
 252   NEXT;
 253 }
 254
 255 VM_DEFINE_INSTRUCTION (local_set_2, "local-set*2", 2)
 256 {
 257   LOCAL_SET (FETCH2 (), *sp);
 258   DROP ();
 259   NEXT;
 260 }
 261
 262 VM_DEFINE_INSTRUCTION (external_set, "external-set", 1)
 263 {
 264   unsigned int i;
 265   SCM e = external;
 266   for (i = FETCH (); i; i--)
 267     e = SCM_CDR (e);
 268   SCM_SETCAR (e, *sp);
 269   DROP ();
 270   NEXT;
 271 }
 272
 273 VM_DEFINE_INSTRUCTION (module_set, "module-set", 1)
 274 {
 275   int i = FETCH ();
 276   SCM x = OBJECT_REF (i);
 277   VARIABLE_SET (x, *sp);
 278   DROP ();
 279   NEXT;
 280 }
 281
 282 VM_DEFINE_INSTRUCTION (module_set_2, "module-set*2", 2)
 283 {
 284   int i = FETCH2 ();
 285   SCM x = OBJECT_REF (i);
 286   VARIABLE_SET (x, *sp);
 287   DROP ();
 288   NEXT;
 289 }
 290
 291 VM_DEFINE_INSTRUCTION (variable_set, "variable-set", 0)
 292 {
 293   VARIABLE_SET (sp[0], sp[1]);
 294   sp += 2;
 295   NEXT;
 296 }
 297
 298 \f
 299 /*
 300  * branch and jump
 301  */
 302
 303 #define BR(p)                                   \
 304 {                                               \
 305   signed char offset = FETCH ();                \
 306   if (p)                                        \
 307     ip += offset;                               \
 308   DROP ();                                      \
 309   NEXT;                                         \
 310 }
 311
 312 VM_DEFINE_INSTRUCTION (br_if, "br-if", 1)
 313 {
 314   BR (!SCM_FALSEP (*sp));
 315 }
 316
 317 VM_DEFINE_INSTRUCTION (br_if_not, "br-if-not", 1)
 318 {
 319   BR (SCM_FALSEP (*sp));
 320 }
 321
 322 VM_DEFINE_INSTRUCTION (br_if_eq, "br-if-eq", 1)
 323 {
 324   BR (SCM_EQ_P (sp[0], sp--[1]));
 325 }
 326
 327 VM_DEFINE_INSTRUCTION (br_if_not_eq, "br-if-not-eq", 1)
 328 {
 329   BR (!SCM_EQ_P (sp[0], sp--[1]));
 330 }
 331
 332 VM_DEFINE_INSTRUCTION (br_if_null, "br-if-null", 1)
 333 {
 334   BR (SCM_NULLP (*sp));
 335 }
 336
 337 VM_DEFINE_INSTRUCTION (br_if_not_null, "br-if-not-null", 1)
 338 {
 339   BR (!SCM_NULLP (*sp));
 340 }
 341
 342 VM_DEFINE_INSTRUCTION (jump, "jump", 1)
 343 {
 344   ip += (signed char) FETCH ();
 345   NEXT;
 346 }
 347
 348 \f
 349 /*
 350  * Subprogram call
 351  */
 352
 353 VM_DEFINE_INSTRUCTION (make_closure, "make-closure", 0)
 354 {
 355   SYNC ();
 356   *sp = scm_c_make_vclosure (*sp, external);
 357   NEXT;
 358 }
 359
 360 VM_DEFINE_INSTRUCTION (call, "call", 1)
 361 {
 362   POP (program);
 363   nargs = FETCH ();
 364
 365  vm_call:
 366   /*
 367    * Subprogram call
 368    */
 369   if (SCM_PROGRAM_P (program))
 370     {
 371       CACHE_PROGRAM ();
 372       INIT_ARGS ();
 373       NEW_FRAME ();
 374       INIT_VARIABLES ();
 375       ENTER_HOOK ();
 376       APPLY_HOOK ();
 377       NEXT;
 378     }
 379   /*
 380    * Function call
 381    */
 382   if (!SCM_FALSEP (scm_procedure_p (program)))
 383     {
 384       POP_LIST (nargs);
 385       *sp = scm_apply (program, *sp, SCM_EOL);
 386       program = SCM_VM_FRAME_PROGRAM (fp);
 387       NEXT;
 388     }
 389   /*
 390    * Continuation call
 391    */
 392   if (SCM_VM_CONT_P (program))
 393     {
 394     vm_call_cc:
 395       /* Check the number of arguments */
 396       if (nargs != 1)
 397         scm_wrong_num_args (program);
 398
 399       /* Reinstate the continuation */
 400       EXIT_HOOK ();
 401       reinstate_vm_cont (vmp, program);
 402       CACHE ();
 403       /* We don't need to set the return value here
 404          because it is already on the top of the stack. */
 405       NEXT;
 406     }
 407
 408   goto vm_error_wrong_type_apply;
 409 }
 410
 411 VM_DEFINE_INSTRUCTION (tail_call, "tail-call", 1)
 412 {
 413   SCM x;
 414   POP (x);
 415   nargs = FETCH ();
 416
 417   SCM_TICK;     /* allow interrupt here */
 418
 419   /*
 420    * Tail recursive call
 421    */
 422   if (SCM_EQ_P (x, program))
 423     {
 424       INIT_ARGS ();
 425
 426       /* Move arguments */
 427       if (bp->nargs)
 428         {
 429           int i;
 430           SCM *base = fp + bp->nlocs;
 431           for (i = 0; i < bp->nargs; i++)
 432             base[i] = sp[i];
 433         }
 434
 435       ip = bp->base;
 436       sp = SCM_VM_FRAME_LOWER_ADDRESS (fp);
 437       APPLY_HOOK ();
 438       NEXT;
 439     }
 440   program = x;
 441   /*
 442    * Proper tail call
 443    */
 444   if (SCM_PROGRAM_P (program))
 445     {
 446       int i;
 447       int n = SCM_VM_FRAME_LOWER_ADDRESS (fp) - sp;
 448       SCM *base = sp;
 449
 450       /* Exit the current frame */
 451       EXIT_HOOK ();
 452       FREE_FRAME ();
 453
 454       /* Move arguments */
 455       sp -= n;
 456       for (i = 0; i < n; i++)
 457         sp[i] = base[i];
 458
 459       /* Call the program */
 460       goto vm_call;
 461     }
 462   /*
 463    * Function call
 464    */
 465   if (!SCM_FALSEP (scm_procedure_p (program)))
 466     {
 467       POP_LIST (nargs);
 468       *sp = scm_apply (program, *sp, SCM_EOL);
 469       program = SCM_VM_FRAME_PROGRAM (fp);
 470       goto vm_return;
 471     }
 472   /*
 473    * Continuation call
 474    */
 475   if (SCM_VM_CONT_P (program))
 476     goto vm_call_cc;
 477
 478   goto vm_error_wrong_type_apply;
 479 }
 480
 481 VM_DEFINE_INSTRUCTION (call_cc, "call/cc", 1)
 482 {
 483   SYNC ();
 484   PUSH (capture_vm_cont (vmp));
 485   POP (program);
 486   nargs = 1;
 487   goto vm_call;
 488 }
 489
 490 VM_DEFINE_INSTRUCTION (return, "return", 0)
 491 {
 492   SCM ret;
 493  vm_return:
 494   ret = *sp;
 495   EXIT_HOOK ();
 496   RETURN_HOOK ();
 497   FREE_FRAME ();
 498
 499   /* Cache the last program */
 500   program = SCM_VM_FRAME_PROGRAM (fp);
 501   CACHE_PROGRAM ();
 502   PUSH (ret);
 503   NEXT;
 504 }
 505
 506 \f
 507 /*
 508  * Exception handling
 509  */
 510
 511 VM_DEFINE_INSTRUCTION (raise, "raise", 1)
 512 {
 513 }
 514
 515 VM_DEFINE_INSTRUCTION (catch, "catch", 0)
 516 {
 517 }
 518
 519 VM_DEFINE_INSTRUCTION (stack_catch, "stach_catch", 0)
 520 {
 521 }
 522
 523 /*
 524   Local Variables:
 525   c-file-style: "gnu"
 526   End:
 527 */