home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / microcode / prmcon.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  4KB  |  158 lines
  1. /* -*-C-*-
  2.  
  3. $Id: prmcon.c,v 1.3 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1990-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. */
  21.  
  22. #define SCM_PRMCON_C
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26. #include "prmcon.h"
  27.  
  28. void
  29. DEFUN (suspend_primitive,
  30.        (continuation, reentry_record_length, reentry_record),
  31.        int continuation AND
  32.        int reentry_record_length AND
  33.        SCHEME_OBJECT *reentry_record)
  34. {
  35.   int i;
  36.   long nargs;
  37.   SCHEME_OBJECT primitive;
  38.  
  39.   if (continuation > CONT_MAX_INDEX)
  40.   {
  41.     signal_error_from_primitive (ERR_UNKNOWN_PRIMITIVE_CONTINUATION);
  42.     /* NOTREACHED */
  43.   }
  44.  
  45.   primitive = (Regs[REGBLOCK_PRIMITIVE]);
  46.   if (!PRIMITIVE_P (primitive))
  47.   {
  48.     outf_fatal ("\nsuspend_primitive invoked when not in primitive!\n");
  49.     Microcode_Termination (TERM_BAD_BACK_OUT);
  50.   }
  51.  
  52.   nargs = (PRIMITIVE_N_ARGUMENTS (primitive));
  53.  
  54.   Will_Push (CONTINUATION_SIZE + 3 + reentry_record_length);
  55.    STACK_PUSH (primitive);
  56.    STACK_PUSH (STACK_FRAME_HEADER + nargs);
  57.  
  58.    for (i = (reentry_record_length - 1);
  59.     i >= 0;
  60.     i -= 1)
  61.    {
  62.      STACK_PUSH (reentry_record[i]);
  63.    }
  64.    STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (reentry_record_length));
  65.    Store_Expression (LONG_TO_UNSIGNED_FIXNUM ((long) continuation));
  66.    Store_Return (RC_PRIMITIVE_CONTINUE);
  67.    Save_Cont ();
  68.   Pushed ();
  69.  
  70.   return;
  71. }
  72.  
  73. SCHEME_OBJECT
  74. DEFUN_VOID (continue_primitive)
  75. {
  76.   long nargs;
  77.   int continuation, record_length;
  78.   SCHEME_OBJECT primitive, *buffer, result;
  79.  
  80.   continuation = ((int) (UNSIGNED_FIXNUM_TO_LONG (Fetch_Expression ())));
  81.   if (continuation > CONT_MAX_INDEX)
  82.   {
  83.     Store_Expression (LONG_TO_UNSIGNED_FIXNUM ((long) continuation));
  84.     Store_Return (RC_PRIMITIVE_CONTINUE);
  85.     Save_Cont ();
  86.     immediate_error (ERR_UNKNOWN_PRIMITIVE_CONTINUATION);
  87.     /* NOTREACHED */
  88.   }
  89.   record_length = ((int) (UNSIGNED_FIXNUM_TO_LONG (STACK_POP ())));
  90.   if (GC_Check (record_length))
  91.   {
  92.     Request_GC (record_length);
  93.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM ((long) record_length));
  94.     Store_Expression (LONG_TO_UNSIGNED_FIXNUM ((long) continuation));
  95.     Store_Return (RC_PRIMITIVE_CONTINUE);
  96.     Save_Cont ();
  97.     immediate_interrupt ();
  98.     /* NOTREACHED */
  99.   }
  100.  
  101.   buffer = Free;
  102.   while ((--record_length) >= 0)
  103.   {
  104.     *Free++ = (STACK_POP ());
  105.   }
  106.  
  107.   nargs = ((OBJECT_DATUM (STACK_POP ())) -
  108.        (STACK_ENV_FIRST_ARG - 1));
  109.   primitive = (STACK_POP ());
  110.  
  111.   /* Most of the testing here is paranioa in case we disk-save in the
  112.      middle of the suspension and then disk-restore into an incompatible
  113.      microcode.
  114.      It's not complete, but will catch some errors.
  115.    */
  116.  
  117.   if (!IMPLEMENTED_PRIMITIVE_P (primitive))
  118.   {
  119.     STACK_PUSH (primitive);
  120.     STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nargs));
  121.     immediate_error (ERR_UNIMPLEMENTED_PRIMITIVE);
  122.     /* NOTREACHED */
  123.   }
  124.  
  125.   if (nargs != (PRIMITIVE_ARITY (primitive)))
  126.   {
  127.     if ((PRIMITIVE_ARITY (primitive)) != LEXPR_PRIMITIVE_ARITY)
  128.     {
  129.       STACK_PUSH (primitive);
  130.       STACK_PUSH (LONG_TO_UNSIGNED_FIXNUM (nargs));
  131.       immediate_error (ERR_WRONG_NUMBER_OF_ARGUMENTS);
  132.     }
  133.     Regs[REGBLOCK_LEXPR_ACTUALS] = ((SCHEME_OBJECT) nargs);
  134.   }
  135.   Store_Expression (primitive);
  136.   Regs[REGBLOCK_PRIMITIVE] = primitive;
  137.   result = (*(continuation_procedures[continuation]))(buffer);
  138.   Regs[REGBLOCK_PRIMITIVE] = SHARP_F;
  139.   POP_PRIMITIVE_FRAME (nargs);
  140.   return (result);
  141. }
  142.  
  143. void
  144. DEFUN_VOID (immediate_interrupt)
  145. {
  146.   Setup_Interrupt (PENDING_INTERRUPTS ());
  147.   abort_to_interpreter (PRIM_APPLY);
  148.   /* NOTREACHED */
  149. }
  150.  
  151. void
  152. DEFUN (immediate_error, (error_code), long error_code)
  153. {
  154.   Do_Micro_Error (error_code, false);
  155.   abort_to_interpreter (PRIM_APPLY);
  156.   /* NOTREACHED */
  157. }
  158.