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 / step.c < prev    next >
C/C++ Source or Header  |  1999-01-02  |  5KB  |  156 lines
  1. /* -*-C-*-
  2.  
  3. $Id: step.c,v 9.34 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1987-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. /* Support for the stepper */
  23.  
  24. #include "scheme.h"
  25. #include "prims.h"
  26.  
  27.                  /**********************************/
  28.                  /* Support of stepping primitives */
  29.                  /**********************************/
  30.  
  31. /* UGLY ... this knows (a) that it is called with the primitive frame
  32.    already popped off the stack; and (b) the order in which Save_Cont
  33.    stores things on the stack.
  34. */
  35.  
  36. static void
  37. DEFUN (Install_Traps, (Hunk3), SCHEME_OBJECT Hunk3)
  38. {
  39.   SCHEME_OBJECT Eval_Hook, Apply_Hook, Return_Hook;
  40.  
  41.   Stop_Trapping();
  42.   Eval_Hook = MEMORY_REF (Hunk3, HUNK_CXR0);
  43.   Apply_Hook = MEMORY_REF (Hunk3, HUNK_CXR1);
  44.   Return_Hook = MEMORY_REF (Hunk3, HUNK_CXR2);
  45.   Set_Fixed_Obj_Slot(Stepper_State, Hunk3);
  46.   Trapping = ((Eval_Hook != SHARP_F) |
  47.           (Apply_Hook != SHARP_F) |
  48.           (Return_Hook != SHARP_F));
  49.   return;
  50. }
  51.  
  52. /* (PRIMITIVE-EVAL-STEP EXPRESSION ENV HUNK3)
  53.    Evaluates EXPRESSION in ENV and intalls the eval-trap,
  54.    apply-trap, and return-trap from HUNK3.  If any
  55.    trap is #F, it is a null trap that does a normal EVAL,
  56.    APPLY or return.
  57. */
  58.  
  59. DEFINE_PRIMITIVE ("PRIMITIVE-EVAL-STEP", Prim_eval_step, 3, 3, 0)
  60. {
  61.   PRIMITIVE_HEADER (3);
  62.   CHECK_ARG (3, HUNK3_P);
  63.   {
  64.     SCHEME_OBJECT expression = (ARG_REF (1));
  65.     SCHEME_OBJECT environment = (ARG_REF (2));
  66.     SCHEME_OBJECT hooks = (ARG_REF (3));
  67.     PRIMITIVE_CANONICALIZE_CONTEXT ();
  68.     POP_PRIMITIVE_FRAME (3);
  69.     Install_Traps (hooks);
  70.     Store_Expression (expression);
  71.     Store_Env (environment);
  72.   }
  73.   PRIMITIVE_ABORT (PRIM_NO_TRAP_EVAL);
  74.   /*NOTREACHED*/
  75.   PRIMITIVE_RETURN (UNSPECIFIC);
  76. }
  77.  
  78. /* (PRIMITIVE-APPLY-STEP OPERATOR OPERANDS HUNK3)
  79.    Applies OPERATOR to OPERANDS and intalls the eval-trap,
  80.    apply-trap, and return-trap from HUNK3.  If any
  81.    trap is #F, it is a null trap that does a normal EVAL,
  82.    APPLY or return.
  83.  
  84.    Mostly a copy of Prim_Apply, since this, too, must count the space
  85.    required before actually building a frame */
  86.  
  87. DEFINE_PRIMITIVE ("PRIMITIVE-APPLY-STEP", Prim_apply_step, 3, 3, 0)
  88. {
  89.   PRIMITIVE_HEADER (3);
  90.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  91.   CHECK_ARG (3, HUNK3_P);
  92.   {
  93.     SCHEME_OBJECT hooks = (ARG_REF (3));
  94.     fast long number_of_args = 0;
  95.     {
  96.       SCHEME_OBJECT procedure = (ARG_REF (1));
  97.       SCHEME_OBJECT argument_list = (ARG_REF (2));
  98.       {
  99.     fast SCHEME_OBJECT scan_list;
  100.     TOUCH_IN_PRIMITIVE (argument_list, scan_list);
  101.     while (PAIR_P (scan_list))
  102.       {
  103.         number_of_args += 1;
  104.         TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
  105.       }
  106.     if (scan_list != EMPTY_LIST)
  107.       error_wrong_type_arg (2);
  108.       }
  109.       POP_PRIMITIVE_FRAME (3);
  110.       Install_Traps (hooks);
  111.       {
  112.     fast SCHEME_OBJECT * scan_stack = (STACK_LOC (- number_of_args));
  113.     fast SCHEME_OBJECT scan_list;
  114.     fast long i;
  115.     Will_Push (number_of_args + STACK_ENV_EXTRA_SLOTS + 1);
  116.     Stack_Pointer = scan_stack;
  117.     TOUCH_IN_PRIMITIVE (argument_list, scan_list);
  118.     for (i = number_of_args; (i > 0); i -= 1)
  119.       {
  120.         (*scan_stack++) = (PAIR_CAR (scan_list));
  121.         TOUCH_IN_PRIMITIVE ((PAIR_CDR (scan_list)), scan_list);
  122.       }
  123.     STACK_PUSH (procedure);
  124.     STACK_PUSH (STACK_FRAME_HEADER + number_of_args);
  125.     Pushed ();
  126.       }
  127.     }
  128.   }
  129.   PRIMITIVE_ABORT (PRIM_NO_TRAP_APPLY);
  130.   /*NOTREACHED*/
  131.   PRIMITIVE_RETURN (UNSPECIFIC);
  132. }
  133.  
  134. /* (PRIMITIVE-RETURN-STEP VALUE HUNK3)
  135.    Returns VALUE and intalls the eval-trap, apply-trap, and
  136.    return-trap from HUNK3.  If any trap is #F, it is a null trap
  137.    that does a normal EVAL, APPLY or return.
  138. */
  139.  
  140. DEFINE_PRIMITIVE ("PRIMITIVE-RETURN-STEP", Prim_return_step, 2, 2, 0)
  141. {
  142.   PRIMITIVE_HEADER (2);
  143.   PRIMITIVE_CANONICALIZE_CONTEXT ();
  144.   CHECK_ARG (2, HUNK3_P);
  145.   {
  146.     SCHEME_OBJECT value = (ARG_REF (1));
  147.     SCHEME_OBJECT hooks = (ARG_REF (2));
  148.  
  149.     POP_PRIMITIVE_FRAME (2); 
  150.     Install_Traps (hooks);
  151.     Val = (value);
  152.     PRIMITIVE_ABORT (PRIM_NO_TRAP_POP_RETURN);
  153.     PRIMITIVE_RETURN (UNSPECIFIC);
  154.   }
  155. }
  156.