devel/misc/unknown/src/TRACE.ELA

Raw file
Back to index

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
PACKET tracer DEFINES breakpoint handler ,          (* M. Staubermann  *) 
                      handlers module nr ,          (* 20.04.86        *)
                      list breakpoints ,
                      set breakpoint , 
                      reset breakpoint ,
                      source file , 
                      trace ,
                      reset breakpoints : 
 
LET local base field           = 25 , 
    packet data segment        = 0 , 
    local data segment         = 1 ,
 
    begin of module nr link table = 512 , 
 
    previous local base offset = 0 , 
    return address offset      = 1 , 
    return segment offset      = 2 , 
    c8k offset                 = 3 , 
 
    opcode mask                = 31744 , 
    bt opcode                  = 0 , 
    btlong opcode              = 1024 , 
    bf opcode                  = 28672 , 
    bflong opcode              = 29696 , 
    br opcode                  = 28672 , 
    brlong opcode              = 29696 , 
 
    ln opcode                  = 0 , 
    ln long opcode             = 1024 , 
    call opcode                = 30720 , 
    pcall opcode               = 32543 ;
 
LET nr of breakpoints = 2 , 
    BREAKPOINT = STRUCT (BOOL set, 
                         INT  segment, 
                              address, 
                              saved word) ; 
 
ROW nr of breakpoints BREAKPOINT VAR breakpoints ;
BREAKPOINT CONST init breakpoint :: BREAKPOINT:(FALSE, 3, -5, 0) ;
 
FOR i FROM 1 UPTO nr of breakpoints REP 
 breakpoints (i) := init breakpoint 
PER ; 
 
BOOL VAR auto trace := FALSE , 
         zweizeilig ;
INT VAR next instruction address ,
        next instruction segment ,
        next instruction ,
        return segment,
        return address, 
        breakpoint address , 
        breakpoint segment , 
        breakpoint nr ,
        lbas , 
        this local base ,
        branch address , 
        c8k , 
        packet base ,
        op word,
        saved word ,
        i, x, y , 
        actual line number := -1 , 
        handler module := 395 ; (* PROC stop *) 
 
TEXT VAR key := "" , 
         previous key := "" , 
         statement line := "" , 
         source line := "" , 
         source file name := "" ;
 
FILE VAR source ; 
 
PROC trace (BOOL CONST b) : 
 auto trace := b 
ENDPROC trace ; 
 
PROC source file (TEXT CONST file name) : 
 IF exists (file name) 
    THEN source := sequentialfile (modify, file name) 
 FI ; 
 IF actual line number >= 0 CAND actual line number <= lines (source) 
    THEN toline (source, actual line number) ; 
         readrecord (source, source line) 
    ELSE source line := ""
 FI
ENDPROC source file ; 
 
TEXT PROC source file : 
 source file name 
ENDPROC source file ; 
 
PROC breakpoint handler : 
 determine return address ;
 determine breakpoint nr ; 
 reset breakpoints ; 
 getcursor (x, y) ; 
 REP 
   ueberschrift schreiben ;
   IF auto trace 
      THEN IF incharety = "" 
              THEN key := "s" 
              ELSE auto trace := FALSE 
           FI 
   FI ; 
   IF NOT auto trace 
      THEN REP 
            inchar (key) 
           UNTIL pos (""13"acdefgst", key) > 0 PER ; 
           IF key = "a" 
              THEN auto trace := TRUE ; 
                   key := "s" 
           ELIF key = "f" 
              THEN out (""13""5"Sourcefile:") ; 
                   getline (source file name) ; 
                   out (""3"") ;
                   source file (source file name) 
           ELIF key = ""13"" 
              THEN key := "s" 
           FI 
   FI ; 
   previous key := key 
 UNTIL pos ("gst", key) > 0 PER ; 
 cursor (1, 7) ; 
 out (""5"") ;
 IF key <> "t" 
    THEN execute saved instruction 
 FI ;
 IF key = "t" 
    THEN resetbreakpoints ; 
         term 
 ELIF key = "s" 
    THEN singlestep 
 FI ; 
 cursor (x, y) . 
 
ueberschrift schreiben : 
 feld loeschen ; 
 put (""1"Breakpoint") ; put (breakpoint nr) ; 
 put ("lbas:") ; put (hex16 (lbas)) ; 
 put ("pbas:") ; put (hex8 (packet base)) ; 
 put ("c8k:") ;  put (hex8 (c8k)) ; 
 IF valid source 
    THEN out ("""") ; out (source file name) ; put ("""") 
 FI ; 
 line ;
 IF valid source AND source line <> "" 
    THEN put (text (actual line number, 5)) ; put ("|") ; 
         outsubtext (source line, 1, 71) ; 
         line ; 
         IF LENGTH source line < 72 
            THEN put (text (actual line number +1, 5)) ; put ("|") ; 
                 toline (source, actual line number +1) ; 
                 out (subtext (source, 1, 71)) ; 
                 toline (source, actual line number) ; 
                 line 
            ELSE put ("______|") ; 
                 outsubtext (source line, 72, 143) ; 
                 line 
         FI
    ELSE line (2)
 FI ; 
 out (text (return segment AND 3)) ; 
 put (hex16 (return address)) ; 
 put ("|") ;
 seg (breakpoint segment) ; 
 addr (breakpoint address) ; 
 zweizeilig := TRUE ;
 disassemble one statement ; 
 IF auto trace 
    THEN pause (5) 
 FI ; 
 next instruction segment := breakpoint segment ; 
 next instruction address := addr ADD 1 ; 
 next instruction := getword (next instruction segment,
                              next instruction address) ; 
 line ; 
 put ("a)uto, s)tep, g)o, t)erm, d)stop, e)stop, c)lrerr, f)ile:") . 
 
feld loeschen : 
 out (""1"") ; 
 7 TIMESOUT ""5""10"" ; 
 79 TIMESOUT "-" . 
 
valid source : 
 exists (source file name) . 
 
disassemble one statement : 
 statement line := hex16 (get word (breakpoint segment, addr)) ; 
 statement line CAT " " ; 
 code word line (statement line) ; 
(* local base (lbas + offset) ; *) 
 statement line := opcode ; 
 local base (-1) ;
 put (code word line) ; 
(* i := max (0, 26 - length (code word line)) ; 
 i TIMESOUT " " ; *) 
i:=0; i := 71 - LENGTH codeword line - i ; 
 outsubtext (statement line, 1, i) ; 
 line ; 
 IF zweizeilig 
    THEN put ("      |") ; 
         outsubtext (statement line, i + 1, i + 72) ; 
         line 
 FI ;
 codeword line ("") . 
 
singlestep : 
 IF is return opcode
    THEN set breakpoint behind previous call
 ELIF bool result 
    THEN set first breakpoint behind branch instruction ; 
         set second breakpoint at branch address ;
         bool result (FALSE) ;
 ELIF is bool return opcode 
    THEN set first breakpoint behind branch instruction at return address ; 
         set second breakpoint at branch address of branch instruction at 
         return address ; 
 ELIF is branch instruction 
    THEN set breakpoint at branch address 
 ELIF is call opcode AND NOT auto trace CAND segment 3 module CAND
      yes (""3"Subroutine Trace") 
    THEN out (""3""13""5"") ; 
         calculate subroutine segment and address ; 
         set breakpoint behind next instruction
 ELSE set breakpoint behind next instruction
 FI . 
 
is call opcode : 
 (saved word AND opcode mask) = call opcode OR 
(* saved word = pcall opcode OR //einbauen, wenn local zugriffe ok sind// *) 
 saved word = -136 . (* LONGA CALL *) 
 
is line number : 
 (saved word AND opcode mask) = ln opcode OR 
 (saved word AND opcode mask) = lnlong opcode . 
 
is branch instruction : 
 (saved word AND opcode mask) = br opcode OR 
 (saved word AND opcode mask) = brlong opcode . 
 
is return opcode : 
 saved word = 32512 . 
 
is bool return opcode : 
 saved word = 32513 OR saved word = 32514 . 
 
read source line : 
 actual line number := ((saved word AND 768) * 2) OR (saved word AND 255);
 IF saved word < 0 
    THEN actual line number INCR 256 
 FI ; 
 IF (saved word AND opcode mask) = lnlong opcode 
    THEN actual line number INCR 2048 
 FI ; 
 actual line number DECR 1 ; 
 IF valid source 
    THEN IF lineno (source) = actual line number CAND source line <> "" 
            THEN (* nichts*) 
         ELIF actual line number >= 0 AND actual line number <= lines(source) 
            THEN toline (source, actual line number) ; 
                 readrecord (source, source line) 
         ELSE source line := "" 
         FI 
    ELSE source line := "" 
 FI . 
 
set first breakpoint behind branch instruction : 
 op word := next instruction AND opcode mask ; 
 IF op word = bf opcode OR op word = bflong opcode OR 
    op word = bt opcode OR op word = btlong opcode 
    THEN seg (next instruction segment) ; 
         addr (next instruction address) ; 
         out (""3"") ; 
         out (text (next instruction segment)) ; 
         put (hex16 (next instruction address)) ; 
         put ("|") ; 
         zweizeilig := FALSE ;
         bool result (TRUE) ;
         disassemble one statement ; (* Branch instruction *)
         IF NOT auto trace
            THEN pause (30) 
            ELSE pause (5)
         FI ;
         next free breakpoint ;
         set breakpoint (i, next instruction segment,
                            next instruction address ADD 1) ;
    ELSE putline (""3""7"Interner Fehler: Nach BOOL-Result folgt kein Branch"); 
         LEAVE singlestep 
 FI . 
 
set second breakpoint at branch address : 
 calculate branch address ; 
 next free breakpoint ;
 set breakpoint (i, next instruction segment, branch address) . 
 
set breakpoint at branch address : 
 next instruction := saved word ; 
 next instruction address := breakpoint address ; 
 calculate branch address ; 
 set breakpoint (breakpoint nr, next instruction segment, branch address) . 
 
set first breakpoint behind branch instruction at return address : 
 next instruction address := getword (local data segment, 
                             lbas + return address offset) ; 
 next instruction segment := getword (local data segment, 
                             lbas + return segment offset) AND 3 ; 
 next instruction := getword (next instruction segment,
                              next instruction address) ;
 IF next instruction segment = 3 
    THEN set first breakpoint behind branch instruction 
    ELSE putline ("Trace beendet.") 
 FI . 
 
set second breakpoint at branch address of branch instruction at return address : 
 set second breakpoint at branch address . 
 
determine return address : 
 pause (0) ;    (* Local Base fixieren *)
 this local base := getword (local data segment, pcb (local base field)) ; 
 pause (0) ;
 lbas            := getword (local data segment, this local base + 
                             previous local base offset) ; 
 c8k             := getword (local data segment, this local base + 
                             c8k offset) AND 255 ; 
 return segment  := getword (local data segment, this local base + 
                             return segment offset) ; 
 return address  := getword (local data segment, this local base + 
                             return address offset) ; 
 packet base     := HIGH return segment ; 
 arith 16 ; 
 return address DECR 1 ; 
 arith 15 . 
 
segment 3 module : 
 IF saved word = -136 (* LONGA CALL *) 
    THEN op word := getword (breakpoint segment, breakpoint address ADD 1) 
 ELSE op word := saved word AND 1023 ; 
      IF saved word < 0 
         THEN op word INCR 1024 
      FI ; 
 FI ; 
 op word >= 1280 . 
 
calculate subroutine segment and address : 
 next instruction segment := 3 ; (* Laeuft nur in Segment 3 ! *) 
 next instruction address := getword (packet data segment,
                             begin of module nr link table + op word) ADD 1. 
 
determine breakpoint nr : 
 FOR i FROM 1 UPTO nr of breakpoints REP 
  IF breakpoints (i).set CAND 
     breakpoints (i).segment = (return segment AND 3) CAND 
     breakpoints (i).address = return address 
     THEN breakpoint nr := i ; 
          breakpoint address := breakpoints (i).address ; 
          breakpoint segment := breakpoints (i).segment ; 
          saved word         := breakpoints (i).saved word ;
          LEAVE determine breakpoint nr 
  FI 
 PER ;
 put ("Returnaddresse:") ; 
 out (text (return segment AND 3)) ; 
 putline (hex16 (return address)) ; 
 list breakpoints ;
 reset breakpoints ; 
 enablestop ;
 errorstop ("Falsche Returnaddresse") . 
 
calculate branch address : 
 IF lowbyte replacement possible 
    THEN branch address := (next instruction address AND -256) OR 
                           (next instruction AND 255) ; 
         LEAVE calculate branch address 
 FI ; 
 branch address := next instruction AND 768 ; 
 IF branch long 
    THEN branch address INCR 2048 
 FI ; 
 branch address INCR branch address ; 
 IF next instruction < 0 
    THEN branch address INCR 256 
 FI ; 
 arith 16 ;
 branch address INCR (next instruction address AND -256) ; 
 IF HIGH branch address >= c8k 
    THEN branch address DECR 4096 
 FI ;
 arith 15 ; 
 branch address := (branch address AND -256) OR (next instruction AND 255) . 
 
lowbyte replacement possible : 
 (next instruction AND -32000) = 0 . 
 
branch long : 
 bit (next instruction, 10) . 
 
execute saved instruction : 
 perhaps change error flags ; 
 putword (local data segment, this local base + return address offset,
          return address) ; 
 putword (local data segment, this local base + return segment offset, 
          return segment) . 
 
perhaps change error flags : 
 IF bit (return segment, 7) AND previous key = "c"
    THEN reset bit (return segment, 7)
 FI ; 
 IF bit (return segment, 6) AND previous key = "e" 
    THEN reset bit (return segment, 6) 
 ELIF NOT bit (return segment, 6) AND previous key = "d" 
    THEN set bit (return segment, 6) 
 FI . 
 
set breakpoint behind next instruction : 
 IF is linenumber 
    THEN read source line 
 FI ; 
 set breakpoint (breakpoint nr, next instruction segment, 
                 next instruction address) . 
 
set breakpoint behind previous call : 
 return segment := getword (local data segment, 
                   lbas + return segment offset) AND 3 ;
 return address := getword (local data segment, 
                   lbas + return address offset) ; 
 IF return segment = 3 
    THEN set breakpoint (breakpoint nr, return segment, return address) 
    ELSE putline ("Trace beendet.") 
 FI . 
 
next free breakpoint : 
 FOR i FROM 1 UPTO nr of breakpoints REP 
  IF NOT breakpoints (i).set
     THEN LEAVE next free breakpoint 
  FI 
 PER ; 
 putline (""3""7"Alle " + text(nr of breakpoints) + " Breakpoints sind belegt") ; 
 LEAVE singlestep . 
 
ENDPROC breakpoint handler ; 
 
INT OP HIGH (INT CONST word) : 
 TEXT VAR t := "  " ; 
 replace (t, 1, word) ; 
 code (t SUB 2) 
ENDOP HIGH ; 
 
PROC reset breakpoints : 
 FOR i FROM 1 UPTO nr of breakpoints REP 
  IF breakpoints (i).set 
     THEN reset breakpoint (i) 
     ELSE breakpoints (i) := init breakpoint 
  FI 
 PER 
ENDPROC reset breakpoints ; 
 
PROC reset breakpoint (INT CONST nr) : 
 IF nr < 1 OR nr > nr of breakpoints 
    THEN errorstop ("Unzulaessige Breakpoint Nummer") 
 ELIF NOT breakpoints (nr).set 
    THEN display ("Warnung: Breakpoint " + text (nr) + " war nicht gesetzt")
 ELSE putword (breakpoints (nr).segment, breakpoints (nr).address, 
               breakpoints (nr).saved word) ; 
      breakpoints (nr) := init breakpoint 
 FI 
ENDPROC reset breakpoint ; 
 
PROC set breakpoint (INT CONST nr, segment, address) : 
 INT VAR new word ;
 IF nr < 1 OR nr > nr of breakpoints 
    THEN errorstop ("Unzulaessige Breakpoint Nummer") 
 ELIF breakpoints (nr).set 
    THEN errorstop ("Breakpoint " + text (nr) + " ist bereits gesetzt") 
 ELIF segment < 2 OR segment > 3 
    THEN errorstop ("Segment " + text (segment) + " ist kein Codesegment") 
 ELSE breakpoints (nr).segment := segment ; 
      breakpoints (nr).address := address ; 
      breakpoints (nr).saved word := get word (segment, address) ; 
      new word := call opcode + (handler module AND 1023) ; 
      IF handler module >= 1024 
         THEN setbit (new word, 15) 
      FI ; 
      putword (segment, address, new word) ; 
      IF getword (segment, address) <> new word 
         THEN errorstop ("Addresse Schreibgeschuetzt")
         ELSE breakpoints (nr).set := TRUE
      FI 
 FI 
ENDPROC set breakpoint ; 
 
PROC handlers module nr (INT CONST module nr) : 
 handler module := module nr 
ENDPROC handlers module nr ; 
 
INT PROC handlers module nr : 
 handler module
ENDPROC handlers module nr ; 
 
PROC set breakpoint : 
 handlers module nr (module number ("breakpointhandler", 1)) ; 
 auto trace := FALSE ;
 source file name := "" ; 
 actual line number := -1 ;
 page ; 
 TEXT VAR object ; 
 INT VAR object nr ; 
 put ("Object Name:") ; 
 getline (object) ; 
 changeall (object, " ", "") ;
 putline ("Objekt von Anfang an abzaehlen") ; 
 pause (5) ; 
 help (object) ; 
 put ("Objekt Nr:") ; 
 get (object nr) ; 
 INT VAR code address := code start (object, object nr) ADD 1 ; 
 naechsten freien breakpoint setzen ; 
 put ("Breakpoint") ; 
 put (i) ; 
 putline ("wurde gesetzt.") . 
 
naechsten freien breakpoint setzen : 
 FOR i FROM 1 UPTO nr of breakpoints REP 
  IF NOT breakpoints (i).set 
     THEN set breakpoint (i, code segment, code address) ; 
          LEAVE naechsten freien breakpoint setzen 
  FI 
 PER ; 
 errorstop ("Alle " + text (nr of breakpoints) + " Breakpoints sind belegt"). 
 
ENDPROC set breakpoint ; 
 
PROC list breakpoints : 
 line ; 
 putline (" No Set  Address Word") ; 
 FOR i FROM 1 UPTO nr of breakpoints REP
  put (text (i, 3)) ; 
  IF breakpoints (i).set 
     THEN put (" Y  ")
     ELSE put (" N  ") 
  FI ; 
  out (text (breakpoints (i).segment)) ;
  put (hex16 (breakpoints (i).address)) ; 
  put(" ") ; 
  put (hex16 (breakpoints (i).saved word)) ; 
  line 
 PER 
ENDPROC list breakpoints ; 
 
ENDPACKET tracer