← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/mit-scheme/intrepid-updates

« back to all changes in this revision

Viewing changes to src/microcode/step.c

  • Committer: Bazaar Package Importer
  • Author(s): Chris Hanson
  • Date: 2002-03-14 17:04:07 UTC
  • Revision ID: james.westby@ubuntu.com-20020314170407-m5lg1d6bdsl9lv0s
Tags: upstream-7.7.0
Import upstream version 7.7.0

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/microcode/step.c
 
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
}