source: to-imperative/trunk/compiler/rfp_debug.rf @ 1625

Last change on this file since 1625 was 1625, checked in by sveta, 16 years ago
  • File for debugger added.
  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 11.3 KB
Line 
1//  creating of label for debug
2
3$use "rfpc";         //  rfpc.rfi 
4$use "rfp_lex";      // rfp_lex.rfi
5$use "rfp_parse";    // rfp_parse.rfi
6$use "rfp_compile";  // rfp_compile.rfi
7$use "rfp_format";   // rfp_format.rfi
8$use "rfp_src";
9
10
11$use Box ;
12$use Convert ;
13$use Table ;
14$use StdIO ;
15$use Arithm ;
16$use Access;
17
18$func Debug-Call e.pos = e.debug;
19//  $func Debug s.id e.names = e.Debug ;
20$func Push-Vars  = ;
21$func Pop-Vars = ;
22$func Add-Vars t.var = ;
23$func Get-Vars-Str  e.list = e.result;
24$func Get-Vars e.list = e.vars;
25$func Names-List t.pragma ex = ey;
26$func AS-To-Ref e.as = e.rf;
27$func Save-Id s.id (e.pos) = ;
28$func Add-Pragma t.pragma e.list = e.vars;
29$func Debug-Sent e.sentence = e.Debug;
30$func Debug-Result e.result = e.Debug;
31$func Debug-Hard e.hard = e.Debug;
32$func Debug-Module e.module = e.Debug;
33$func Store-Pragma e.pragma = ;
34$func Debug-Pattern e.pattern = e.Debug;
35$func Debug-Call-Pattern t.pragma = e.Debug;
36$func Debug-Add e.sent = e.Debug;
37$func Format-Hard t.pragma e.expr = e.format;
38$func? Debug-Lib /*empty*/ = e.lib;
39$func? Try-Open e.path = e.dir;
40$func Get-Ready-To-Work e.lib = e.ImportLib;
41$func Correct-Tab-Sources s.tab e.key = ;
42$func Def-Key s.key = s.new;
43
44$box Debug-id;
45$box Vars;
46$box Pragma;    //  (e.filename) s.line s.col
47$box HardExpr;  // result format for ::
48$box Numb;     // for unical "_debug"
49
50$table Id-Position;
51
52//RFP-Debug ex = <PrintLN "Debug : "ex '\n'>, ex :
53//{
54//  t.Syntax e.rest = t.Syntax : {
55//    (MODULE t.Module e.ModuleBody) = <Push-Vars>
56//      (MODULE t.Module <Debug-Module e.ModuleBody>)<Pop-Vars>;                             
57//    (INTERFACE e.body)  = t.Syntax;
58//  } :: e.debug, e.debug <RFP-Debug e.rest>;
59//  /*empty*/;
60// };
61
62RFP-Debug  e.module = {
63  <Table-Copy &RFP-Sources> :: s.tab,
64  <Debug-Lib> <Correct-Tab-Sources s.tab <Domain s.tab>> 
65  <Push-Vars> <Store &Debug-id 0>
66  <Debug-Module e.module> <Pop-Vars>;
67  e.module ;
68};
69
70Correct-Tab-Sources s.tab e.sources = e.sources : {
71  /*empty*/;
72  (s.key) e.rest = <Def-Key s.key> :: s.idx, 
73    <Bind &RFP-Sources (s.idx) (<Lookup s.tab s.key>) > <Correct-Tab-Sources s.tab e.rest>;
74}; 
75
76Def-Key s.key = {
77  <In-Table?  &RFP-Sources s.key> = <Def-Key <"+" s.key 1> >;
78  s.key;                 
79};
80
81Debug-Module
82{
83  /*empty*/;
84  t.item e.rest = t.item : (s.type e.body), 
85  {
86    s.type : PRAGMA = t.item;   
87    s.type : IMPORT,   
88    {
89      e.body : s.objtype t.pragma t.objname,
90      {
91         t.objname : CHANNEL = t.item;
92// ToDo    <Add-Vars t.objname>
93         t.item;
94      };
95      t.item;     
96    };
97    s.type: \{ LOCAL; EXPORT; }, e.body : {
98      CONST e.const = t.item;
99      s.tag t.pragma t.fname t.input t.output e.sent = <Push-Vars>
100         (s.type s.tag t.pragma t.fname t.input t.output <Debug-Sent e.sent>)
101         <Pop-Vars>;
102      s.objtype t.pragma t.objname =
103      {
104         t.objname : CHANNEL = t.item;
105// ToDo    <Add-Vars t.objname>
106          t.item;
107      };
108    };
109  } :: e.debug, e.debug <Debug-Module e.rest>;
110};
111
112Debug-Sent 
113{
114  /*empty*/ ;
115  (RESULT (PRAGMA) e.expr) e.rest = (RESULT (PRAGMA) e.expr)
116    <Debug-Sent e.rest>;
117//  (RESULT (EVAR (PRAGMA) e.var) e.expr) e.rest =
118//    (RESULT (EVAR (PRAGMA) e.var) e.expr) <Debug-Sent e.rest>;
119  (RESULT t.pragma e.expr) e.rest = 
120//   { e.rest : /*empty*/ = <Debug-Call><Store-Pragma t.pragma>
121//     (RESULT t.pragma <Debug-Result e.expr>) <Debug-Call-Pattern t.pragma > ;
122    <Debug-Call> 
123    <Store-Pragma t.pragma>   
124      (RESULT t.pragma <Debug-Result e.expr>) <Debug-Add e.rest>;
125//  };
126  t.stat e.rest = t.stat :
127  {
128    (PRAGMA e.pragma) = t.stat;
129//    (FORMAT (EVAR (PRAGMA) e.var)) = t.stat;
130    (FORMAT t.pragma e.hard)  = (FORMAT t.pragma <Debug-Hard e.hard>);   
131    (NOT t.branch)  = (NOT <Debug-Sent t.branch>) ;
132    (ITER e.sent)  = (ITER <Debug-Sent e.sent>) ;
133    (TRY t.try e.Nofail t.catch) =
134      (TRY <Debug-Sent t.try> e.Nofail <Debug-Sent t.catch>);
135    (CUT) = t.stat;
136    (CUTALL t.pragma) = t.stat;
137    (STAKE) = t.stat;
138    (FAIL t.pragma) = <Debug-Call t.pragma> t.stat;
139    (ERROR t.pragma) = <Store-Pragma t.pragma> t.stat;
140    (NOFAIL) = t.stat;
141    (BLOCK t.pragma e.branch) = <Push-Vars> <Store-Pragma t.pragma>
142      (BLOCK t.pragma <Debug-Sent e.branch>) <Pop-Vars>;
143    (BLOCK? t.pragma e.branch) = <Push-Vars>  <Store-Pragma t.pragma>
144      (BLOCK? t.pragma <Debug-Sent e.branch>) <Pop-Vars>;
145    (BRANCH t.pragma e.sent) = <Push-Vars> <Store-Pragma t.pragma>
146//      (BRANCH t.pragma <Debug-Sent e.sent> <Debug-Call>) <Pop-Vars>;
147        (BRANCH t.pragma <Debug-Sent e.sent>) <Pop-Vars>;
148    (BRANCH? t.pragma e.sent) = <Push-Vars> <Store-Pragma t.pragma>
149//    (BRANCH? t.pragma <Debug-Sent e.sent> <Debug-Call>) <Pop-Vars> ;
150       (BRANCH? t.pragma <Debug-Sent e.sent>) <Pop-Vars>;
151    (LEFT t.pragma e.expr) = (LEFT t.pragma <Debug-Pattern e.expr>);
152    (RIGHT t.pragma e.expr) = (RIGHT t.pragma <Debug-Pattern e.expr>);
153  } :: e.debug, e.debug <Debug-Sent e.rest>;
154};
155
156Debug-Add e.sent = e.sent : {
157/*empty*/ = ;
158(FORMAT t.pragma e.expr) e.rest = <Store &Numb 1>
159  <Store &HardExpr <Format-Hard t.pragma e.expr>>
160  <Debug-Call-Pattern t.pragma> <Debug-Sent e.sent>;
161(BLOCK t.pragma e.expr) e.rest = <Debug-Call-Pattern t.pragma>
162  <Debug-Sent e.sent>;
163(BLOCK? t.pragma e.expr) e.rest = <Debug-Call-Pattern t.pragma>
164  <Debug-Sent e.sent>;
165(LEFT t.pragma e.expr) e.rest = <Debug-Call-Pattern t.pragma>
166  <Debug-Sent e.sent>;
167(RIGHT t.pragma e.expr) e.rest = <Debug-Call-Pattern t.pragma>
168  <Debug-Sent e.sent>;
169e.sent = <Debug-Sent e.sent>;
170};
171
172Format-Hard t.pragma e.expr = e.expr : {
173/*empty*/ = ;
174t1 e.rest = t1: {
175  s.sym = (SVAR t.pragma ("_debug_" <To-Word <? &Numb>>));
176  (PAREN e.hard) = (PAREN <Format-Hard t.pragma e.hard>);
177  (e.type t.var-pragma t.name) =
178    (e.type t.pragma ("_debug_" <To-Chars <? &Numb>>));
179  } :: e.format,
180  <? &Numb> : s.num, <Store &Numb <"+" s.num 1>>,
181  e.format <Format-Hard t.pragma e.rest>;
182};
183
184Debug-Pattern
185{
186  (PAREN e.pat) = (PAREN <Debug-Pattern e.pat>);
187  (e.type t.pragma t.name) =
188    (e.type t.pragma t.name) <Add-Vars (e.type t.name)>;
189  e.expr = e.expr;
190};
191
192Store-Pragma {
193 (PRAGMA (FILE e.file) (LINE s.line s.col)) = <Store &Pragma (e.file) s.line s.col>;
194};
195
196Debug-Result
197{
198  /*empty*/;
199  t.res e.rest = t.res :
200  {
201    s1 = s1;
202    (PAREN e.expr) = (PAREN <Debug-Result e.expr>);
203    (REF t.name) = t.res;
204    (CALL t.pragma t.name e.expr) = (CALL t.pragma t.name <Debug-Result e.expr>);
205    (BLOCK t.pragma e.branch) = <Push-Vars> <Store-Pragma t.pragma>
206      (BLOCK t.pragma <Debug-Sent e.branch>)<Pop-Vars>;
207    (BLOCK? t.pragma e.branch) = <Push-Vars> <Store-Pragma t.pragma>
208      (BLOCK? t.pragma <Debug-Sent e.branch>) <Pop-Vars>;
209    (e.type t.pragma t.name) =
210      <Add-Vars (e.type t.name)> t.res;     
211  } :: e.debug, e.debug <Debug-Result e.rest>;
212};
213
214Debug-Hard
215{
216  /*empty*/ =  ;
217  t.hard e.rest = t.hard :
218  {
219    s1 = s1;
220    (PAREN e.expr) = (PAREN <Debug-Hard e.expr>);
221    (e.type t.pragma t.name) = 
222      <Add-Vars (e.type t.name)> t.hard;
223  } :: e.debug, e.debug <Debug-Hard e.rest>;
224};
225
226Debug-Call  {
227/*empty*/ =
228     <? &Pragma> : (e.file) s.line s.col,
229       <"+" s.col 1> :: s.col, 
230       (e.file) s.line s.col :: e.pos,
231       <Store &Pragma e.pos>,
232       (PRAGMA (FILE e.file) (LINE s.line s.col)) :: t.pragma,
233       <? &Debug-id> : s.id,
234       <Store &Debug-id <"+" s.id 1>>,
235       <Bind &Id-Position (s.id) (e.pos)>,
236       (BLOCK t.pragma
237         (BRANCH t.pragma
238            (RESULT t.pragma
239             (CALL t.pragma ("Debug" "Debug-Check") s.id)
240             (CALL t.pragma ("Debug" "Debug")<Get-Vars-Str t.pragma <? &Vars>>)
241            )
242          )
243          (BRANCH t.pragma (RESULT t.pragma))
244       ); 
245//     <Debug s.id e.pos>;
246t.pragma = t.pragma : (PRAGMA (FILE e.file)(LINE s.line s.col)),
247    (e.file) s.line s.col :: e.pos,
248    <? &Debug-id> : s.id,
249    <Store &Debug-id <"+" s.id 1>>,
250    <Bind &Id-Position (s.id) (e.pos)>,
251    (BLOCK t.pragma
252      (BRANCH t.pragma
253         (RESULT t.pragma
254           (CALL t.pragma ("Debug" "Debug-Check") s.id)
255           (CALL t.pragma ("Debug" "Debug")  <Get-Vars-Str t.pragma <? &Vars>> )
256         )
257       )
258       (BRANCH t.pragma (RESULT t.pragma))
259    );
260//  <Debug s.id e.pos >;
261};
262
263Debug-Call-Pattern t.pragma =
264  t.pragma : (PRAGMA (FILE e.file)(LINE s.line s.col)),
265  (e.file) s.line s.col :: e.pos,
266  <? &Debug-id> : s.id,
267  <Store &Debug-id <"+" s.id 1>>,
268  <Bind &Id-Position (s.id)(e.pos)>,
269  <? &HardExpr> :: e.format,
270  <Store &HardExpr /*empty*/ >,
271  { 
272    e.format : /*empty*/ = (EVAR t.pragma ("_debug_"));
273    e.format;
274  } :: e.format,
275  (FORMAT t.pragma e.format)
276  (BLOCK t.pragma
277    (BRANCH t.pragma
278      (RESULT t.pragma
279        (CALL t.pragma ("Debug" "Debug-Check") s.id)
280        (CALL t.pragma ("Debug" "Debug") <Get-Vars-Str t.pragma <? &Vars>>)
281      )
282    )
283    (BRANCH t.pragma (RESULT t.pragma)
284    )
285  )
286  (RESULT t.pragma e.format);
287
288// Call of Debug-Function with variant- parameters
289// Debug s.id e.pos = e.pos : (e.file) s.line s.col, 
290//   <Save-Id s.id (e.idx s.line s.col)>
291//     <PrintLN 's.id = 's.id ' e.pos= ' e.file
292//     s.line s.col 'e.names ='<Names-List (e.pos) <Get-Vars <? &Vars>>> > ;
293
294// new level of vars-stack is added
295Push-Vars = <Store &Vars <? &Vars> () >;
296
297// level of vars-stack is deleted
298Pop-Vars  = <? &Vars> : e.var (e.last),
299            <Store &Vars e.var>;
300
301Add-Vars t.var =  // t.var = (e.type t.name)
302  <? &Vars> :: e.list, e.list : {
303     e1 ( e2 t.var e3) e4 = ;
304     e1 (e.last) = <Store &Vars e1 (e.last t.var) >;
305  };
306
307Get-Vars
308{
309  /*empty*/ = /*empty*/;
310   (e.head) e.tail = e.head <Get-Vars e.tail>;
311};
312
313Get-Vars-Str   
314{
315  t.pragma  = ;
316  t.pragma (e.head) e.tail  =  {
317    e.head : /*empty*/  = <Get-Vars-Str  t.pragma e.tail>;
318    <Names-List t.pragma e.head> <Get-Vars-Str t.pragma e.tail>;
319  };
320};
321
322Add-Pragma t.pragma e.list = e.list :
323{
324  (s.type t.name) e.tail = (s.type t.pragma t.name) <Add-Pragma t.pragma e.tail>;
325   /*empty*/ = ;;
326};
327
328Names-List
329
330   t.pragma  = /*empty*/;
331   t.pragma t.var e.tail = (PAREN <To-Word <AS-To-Ref t.var>>) (PAREN <Add-Pragma t.pragma  t.var>)
332                  <Names-List t.pragma e.tail>;
333};     
334
335AS-To-Ref
336{
337  SVAR = 's';
338  TVAR = 't';
339  EVAR = 'e';
340  VVAR = 'v';
341  (s.tag (e.name)) = <AS-To-Ref s.tag> '.' <To-Chars e.name> ;
342};
343
344Save-Id s.idx (e.pos) = ;  // e.pos : e.filename s.line s.col
345
346Try-Open {
347/*empty*/ = <PrintLN "File of debug-library " &Name-Debug-File "  not found ">
348   $fail;
349(e.dir) e.rest = {
350  <Channel> :: s.ch,
351  <Open-File s.ch e.dir &Dir-Separator &Name-Debug-File "r">,
352  <Close-Channel s.ch>,
353  e.dir;
354  <Try-Open e.rest>;
355  };
356};
357 
358Debug-Lib  =  <? &RFP-Include-Path> :: e.path, {
359  <Try-Open e.path> :: e.dir,
360  <RFP-Lexer e.dir &Dir-Separator &Name-Debug-File> :: e.source,
361  <Store &RFP-Token-Stack e.source>,
362  <RFP-Parser> : (INTERFACE t.name e.lib),      // Debug.rfi
363  <Get-Ready-To-Work e.lib>; 
364  $fail;
365};
366
367Get-Ready-To-Work 
368{
369  /*empty*/ ;
370  t.Item e.rest =
371    t.Item : (s.Linkage s.ItemType t.Pragma t.ItemName e.ItemBody),
372    s.ItemType : {
373      FUNC = <Left 0 2 e.ItemBody> : (e.in) (e.out),
374        &Fun (<Format-Exp e.in>) (<Format-Exp e.out>);
375      FUNC? = <Left 0 2 e.ItemBody> : (e.in) (e.out),
376        &Fun? (<Format-Exp e.in>) (<Format-Exp e.out>);
377    } :: s.tab e.ItemDef,
378    <Bind s.tab (t.ItemName) (IMPORT s.ItemType t.Pragma e.ItemDef)>,
379    (IMPORT s.ItemType t.Pragma t.ItemName e.ItemBody)
380    <Get-Ready-To-Work e.rest>;
381};
382
383
Note: See TracBrowser for help on using the repository browser.