Added upstream from http://ftp.icm.edu.pl/pub/loglan/
[loglan.git] / sources / pass1 / logdeb.log
1 program pr;
2 (*********************************************************************)
3 (*                                                                   *)
4 (*                    L O G D E B                                    *)
5 (*                                                                   *)
6
7 (*$D-*)
8 (*$L-*)
9
10 UNIT logdeb : CLASS;
11
12 (*====================================================================*)
13 (*                                                                    *)
14 (*                 L O G D E B                                        *)
15 (*                                                                    *)
16 (*          D E B U G G E R     F O R    L O G L A N                  *)
17 (*                                                                    *)
18 (*               WERSJA 2 ( 1985 )                                    *)
19 (*                                                                    *)
20 (*              TERESA PRZYTYCKA                                      *)
21 (*                                                                    *)
22 (*====================================================================*)
23
24 (*====================================================================*)
25 (*                                                                    *)
26 (*     Adapted to the Loglan interpreter.                               *)
27 (*   Uses special standard procedures DB01OX, SCCD01OX, SCND01OX,     *)
28 (*    DB01OF for communication with the interpreter.                  *)
29 (*   Uses auxilliary files  name.deb (name - file name of the source  *)
30 (*     loglan program) and temp.deb.                                  *)
31 (*   The copy of output is printed to the file debug.ech              *)
32 (*                                                                    *)
33 (*                       June 1986, D.Szczepanska                     *)
34 (*====================================================================*)
35
36 (*============================================*)
37 (* WYDRUKI KOTROLNE :   STRUMIEN LO           *)
38 (*                     +i  - PRZED INSTRUKCJA *)
39 (*                    ++i  - PO INSTRUKCJI    *)
40 (*   i - szczegolowosc wydrukow kontrolnych   *)
41 (*============================================*)
42
43
44 VAR LINENR:INTEGER,   (* NR LINII MIEJSCA WYSTAPIENA PZETWANIA      *)
45     LINENR1:INTEGER,  (* NR LINII Z OSTATNIM PRZERWANIEM            *)
46     linenr2:integer,  (* nr linii do ktorej ciagnie sie "do"        *)
47     DISPNR :INTEGER,  (* DISPNR OBIEKTU,KTOREGO WYKONYWANIE ZOSTALO *)
48     UNITCASE : INTEGER,(*     TYP JEDNOSTKI SYNTAKTYCZNEJ PUNKTU    *)
49                        (*           OBSERWACJI                      *)
50                       (* PRZERWANE A POZNIEJ ZMIENNA ROBOCZA DO     *)
51                       (* PRZECHOWYWANIA WYNIKU Z PROCEDURY FIND     *)
52     BREAKT            (* TABLICA Z NUMERAMI LINII PUNKTUW LAMIACYCH *)
53               :ARRAYOF INTEGER,
54
55    BREAKTL:ARRAYOF BR, (* TABLICA INFORMACJI O PUNKTACH LAMIACYCH   *)
56                        (* ODPOWIADAJACA TABLICY BREAKT              *)
57   MOV :MOVEL,          (* POCZATEK LISTY ZMIAN PONKTOW OBSERWACJI   *)
58   CADR,                (*     ADRES OBIEKTU, KTOREG OBLICZENIA      *)
59                        (*       ZOSTALY PRZERWANE                   *)
60   OBSADR,              (*    ADRES OBIEKTU BEDACEGO PUNKTEM         *)
61                        (*           OBSERWACJI                      *)
62                        (*  PRZERWANE                                *)
63   CCOR : ARRAYOF INTEGER, (*             AKTYWNA  COROUTINA         *)
64   ctxt : arrayof integer, (* bufor na biezaca lnie wejsciowa        *)
65    protf   :FILE  ,    (* PLIK O DOSTEPIE sekwencyjnym,binarny      *)
66                        (* zawierajacy breakt i prototypy debuggera  *)
67    CO      :FILE  ,    (* PLIK NA KTORY WYSYLA WYNKI DEBUGGER       *)
68    LO      :FILE  ,    (* KOPIA WYNIKOW PRZY WLACZONYM ECHU         *)
69    PROTNR  :INTEGER ,  (*  NR PROTOTYPU OBIEKTU BEDACEGO            *)
70                        (* PUNKTEM OBSERWACJI                        *)
71    SINGLESTEP:boolean, (* CZY PRZERWANIE JEST GENEROWANE PO KAZDEJ  *)
72                        (* INSTRUKCJI LOGLANOWEJ                     *)
73    GGO :integer,       (* GO = TRUE POWODUJE WYKONYWANIE PROGRAMU   *)
74                        (* BEZ PRZERWAN, JEDYNIE Z SYGNALIZACJA      *)
75                        (* PUNKTOW LAMIACYCH W POSTACI SLADU         *)
76    ECHO  : BOOLEAN,    (* CZY JEST PISANA KOPIA WYNKOW NA LO        *)
77    CBR  :BR         ,  (* PUNKT LAMIACY OBSLUGIWANY W BIEZACYM      *)
78                        (*          PRZERWANIU                       *)
79    CIND  : INTEGER,    (* INDEKS W TABLICY BIEZACEGO PRZERWANIA     *)
80                        (* STRUKTURU DANYCH DO KOMUNIKACJI Z BAZA    *)
81                        (* DANYCH PROTOTYPOW                         *)
82    IDICT ,             (* slownik prototypow debuggera              *)
83    prot                (* tablica zawierajaca prototypy debuggera   *)
84            : arrayof integer,
85
86    GOTXT : ARRAYOF INTEGER,     (* TEKST INSTRUKCJI GO *)
87
88    first:boolean,     (* true for the first interrupt *)
89    lastbr:integer,    (* last used in breakt *)
90    DECL : DEC ;       (* LISTA BANKOW INSTRUKCJI *)
91
92
93 CONST  MAXBR=500,  (* MAKSYMALNA LICZBA PUNKTOW LAMIACYCH *)
94        MAXIDICT = 499; (* ROZMIAR TABLICY IDICT *)
95 VAR   I:INTEGER ; (* GLOBaLNA POMOCNICZA *)
96 var glovirt:arrayof integer, gloreal:real; (*globalne pomocnicze *)
97 var   maxprot:integer; (* rozmiar tablicy PROT *)
98
99 (*=====================================================================*)
100 (*     S T R U K T U R Y       D A N Y C H                             *)
101 (*=====================================================================*)
102
103 UNIT INSTR : CLASS ;  (* ELEMENT LISY INSTRUKCJI *)
104 VAR MARK:INTEGER,
105     TXT :ARRAYOF INTEGER,
106     NEXT :INSTR;
107 END;
108
109 UNIT KILLI :PROCEDURE(INOUT I:INSTR);
110 VAR J :INSTR;
111 BEGIN
112   J:=I;
113   WHILE J=/= NONE DO J:=J.NEXT;KILL(I.TXT);KILL(I);I:=J OD;
114 END;
115
116 (*---------------------------------------------------------------------*)
117
118 UNIT  BR : CLASS ;    (* OPIS PUNKTU PRZERYWAJACEGO *)
119 VAR MARK : INTEGER,
120     CONDTXT : ARRAYOF INTEGER,
121     INS     : INSTR ;
122 END;
123
124 UNIT KILLB :PROCEDURE(INOUT B:BR);
125 BEGIN
126    KILL(B.CONDTXT);CALL KILLI(B.INS) ; KILL(B)
127 END;
128
129 (*-------------------------------------------------------------------*)
130
131 UNIT DEC :CLASS;      (* ELEMENT LIST BANKOW INSTRUKCJI *)
132 VAR ID :INTEGER,
133     INS : INSTR,
134     NEXT : DEC;
135 END;
136
137 (*----------------------------------------------------------------*)
138
139 UNIT MOVEL : CLASS(MARK,PROT :INTEGER,ADR,COR : ARRAYOF INTEGER);
140
141 (* ELEMENT LISTY ZMIAN PUNKTOW OBSERWACJI                      *)
142 (* ZNACZENIE ATRYBUTOW : MARK - ETYKIETA INSTRUKCJI MOVE       *)
143 (*                       PROT - NR PROTOTUPU PUNKTU OBSERWACJI *)
144 (*                       ADR  - ADRES PUNKTU OPSERWACJI        *)
145 (*                       COR  - OBSERWOWANA COROUTINA          *)
146 VAR  NEXT :MOVEL;
147 END;
148 (*------------------------------------------------------------------*)
149
150 (*===================================================================*)
151 (*  CONTROL - PREFIX DLA COROUTIN UZYTKOWNIKA, KTORE MOGA BYC        *)
152 (*  OBSERWOWANE PO EWENTUALNYN BLEDZIE WYKONANIA                     *)
153 (*===================================================================*)
154
155 (*===================================================================*)
156 (*                                                                   *)
157 (*                       S T R I N G S                               *)
158 (*                                                                   *)
159 (*===================================================================*)
160
161 const
162    t1 = " RUNERROR",
163    T2 = " CONERROR",
164    T3 = " LOGERROR",
165    T4 = " TYPERROR",
166    T5 = " SYSERROR",
167    T6 = " NUMERROR",
168    T7 = " MEMERROR",
169    T8 = " UNHANDLED",
170    T9 = " BREAK POINT : ",
171    T10 = " INSTANCE OF ",
172    T11 = " BLOCK",
173    T12 = " HANDLER",
174    T13 = " DECLARED IN LINE",
175    T14 = "     ---   END OF LIST ---",
176    T15 = " NOT IMPLEMENTED",
177    T16 = " ARRAY OF",
178    T17 = " OF ",
179    T18 = " FORMAL TYPE",
180    T19 = " NONE VALUE OF FORMAL TYPE",
181    T20 = " INTEGER",
182    T21 = " BOOL",
183    T22 = " CHAR",
184    T23 = " REAL",
185    T24 = " STRING",
186    T25 = " TRUE",
187    T26 = " FALSE",
188    T27 = " !!! ERROR NR",
189    T28 = " LINENR :",
190    t29 = " OBSERVATION POINT:";
191
192
193 (*============================================================*)
194 (*  CONTROL - prefix for user's coroutines                    *)
195 (*============================================================*)
196
197 UNIT CONTROL:CLASS;
198
199 HANDLERS
200 WHEN ACCERROR : writeln(co,t1); call runerror;
201 WHEN CONERROR : writeln(co,t2); call runerror;
202 WHEN LOGERROR : writeln(co,t3); call runerror;
203 WHEN TYPERROR : writeln(co,t4); call runerror;
204 WHEN SYSERROR : writeln(co,t5); call runerror;
205 WHEN NUMERROR : writeln(co,t6); call runerror;
206 WHEN MEMERROR : writeln(co,t7); call runerror;
207 OTHERS : WRITELN(CO,t8);CALL RUNERROR;
208 END HANDLERS;
209 BEGIN END;
210
211 (*=====================================================================*)
212
213 (*******************************************************************)
214 (*                                                                 *)
215 (*             B R E A K L                                         *)
216 (*                                                                 *)
217 (*-----------------------------------------------------------------*)
218 (*  PROCEDURA WYWOLYWANA PRZEZ PROCEDURE RUNING SYSTEMU :TRACE     *)
219 (*  SPRAWDZA CZY W DANEJ LINI WYKONYWANEGO PROGRAMU JEST           *)
220 (*  ZADEKLAROWANY BREAK POINT.JESLI TAK WYWOLUJE PROCEDURE INTERPR *)
221 (*******************************************************************)
222
223 UNIT BREAKL:PROCEDURE;
224
225 VAR BREAKP: BOOLEAN,
226     K:INTEGER;
227
228 BEGIN
229    (* linenr := line of the break point, dispnr := number of interrupted
230        object, cadr := address of interrupted object *)
231    call db01ox(28,glovirt, linenr, cadr, gloreal, dispnr);
232 if ggo=4 then call endrun fi;
233 if ggo=/=3 then
234   cind := 0; cbr := none;
235 (*+ WRITELN(LO," LINENR",LINENR," LINENR1",LINENR1); ++*)
236   if linenr1=0 then first:=true; fi;
237   IF SINGLESTEP OR LINENR1=0 THEN BREAKP:=TRUE
238   ELSE
239   IF LINENR =/= LINENR1 THEN
240      K:=0;
241      FOR I:=1 TO lastbr DO
242        IF BREAKT(I)=LINENR THEN K:=LINENR ; CIND:=I;EXIT FI;
243      OD;
244      IF K =/= 0 THEN CBR:=BREAKTL(CIND);
245                 BREAKP:=TRUE
246      FI
247   FI;
248   FI;
249   LINENR1:=LINENR;
250   IF BREAKP THEN (* jest przerwanie w lnii linenr *)
251     if ggo=1 andif linenr > linenr2 then ggo := 0 fi;
252     if ggo = 0 then
253      (* ccor - address of  an active coroutine head *)
254      call db01ox (0,ccor,i,glovirt,gloreal,i);
255      CALL INTERPR;
256     else
257       writeln(co,t9,linenr);
258       if echo then writeln(lo,t9,linenr) fi;
259     FI;
260   FI;
261 fi;
262 END;(* BREAKL *)
263
264
265 (************************************************************)
266 (*                                                          *)
267 (*             I N I C B R                                  *)
268 (*                                                          *)
269 (*----------------------------------------------------------*)
270 (*  PROCEDURA INICJALIZUJACA DZIALANIE DEBUGGERA.           *)
271 (*  WYKONUJE KOLEJNO NASTEPUJACE KROKI :                    *)
272 (*   1.ZNAJDUJE ADRES PROTOTYPU INSTRUKCJI BREAKL           *)
273 (*     I EXPORTUJE GO DLA PROCEDURY RAN. SYS. TRACE         *)
274 (*   2.KOPIUJE ZE STRUMIENIA SC TABLICE HASHU,              *)
275 (*     OTWIERA STRUMIEN SC DLA PROCEDUR LOGLANOWYCH,        *)
276 (*     OTWIERA STRUMIEN CI ,INICJALIZUJE ZMIENNE SCANERA    *)
277 (*   3.INICJALIZUJE TABLICE BREAKT I DISPT,                 *)
278 (*     OTWIERA STRUMIENI SC ORAZ CO                         *)
279 (************************************************************)
280
281 UNIT INICBR:PROCEDURE;
282   var i, brnr : integer;
283 BEGIN
284    (* files  openning *)
285     open(protf,integer, unpack("debug.tmp"));
286     call reset(protf);
287    (* copy of the debugger output *)
288     open(lo,text,unpack( "debug.ech"));
289     call rewrite(lo);
290     open (co,text,unpack("SYS$OUTPUT")); (* output of the debugger *)
291     call rewrite(co);
292  (*  breakt *)
293     array breakt dim (1:maxbr);
294     get (protf, brnr);
295     array breaktl dim (1:maxbr);
296     for i:=1 to brnr do
297        get (protf, breakt(i));
298     od;
299     for i := brnr+1 to maxbr do
300        breakt(i) := 0;
301     od;
302  (* initialization of lastbr *)
303     lastbr := 1;
304     while lastbr <= maxbr do
305        if breakt(lastbr) = 0 then exit fi;
306        lastbr := lastbr+1;
307     od;
308     lastbr := lastbr-1;    
309   (* idict *)
310     array idict dim (0:maxidict);
311     for i:=0 to maxidict do
312         get(protf,idict(i));
313     od;
314   (* maxprot *)
315      get(protf,maxprot);
316   (* prot *)
317     array prot dim (1:maxprot);
318     for i:=1 to maxprot do
319         get(protf,prot(i));
320     od;
321  (* protf must be removed from directory *)
322  (* killing of protf and transferring the variable lo to the interpreter *)
323     call db01of(protf,lo);
324 end  inicbr ;
325
326 (*********** PROCEDURY  TESTUJACE ***************************)
327
328 UNIT TEST1:PROCEDURE (INPUT T:ARRAYOF INTEGER );
329
330 (* PROCEDURA DRUKUJE ZAWARTOSC TABLICY T  *)
331
332 VAR I,J:INTEGER;
333 BEGIN
334 J:=0;
335 WRITELN(LO);
336 FOR I:=LOWER(T) TO UPPER(T) DO
337         IF J=10 THEN WRITELN(LO); J:=0 FI;
338         WRITE (LO,T(I));
339         J:=J+1;
340 OD;
341 WRITELN(LO);
342 END (* TEST1 *) ;
343
344 UNIT OUTREF:PROCEDURE(ADRES:ARRAYOF INTEGER);
345 VAR I,J:INTEGER;
346 BEGIN
347   (* (i,j) := virtual address refval *)
348   call db01ox(30,adres,i,glovirt,gloreal,j);
349 (*+  writeln(lo,"refval",i,j); ++*)
350 END;
351
352 (************************************************************)
353 (*                                                          *)
354 (*            I N T E R P R                                 *)
355 (*                                                          *)
356 (*----------------------------------------------------------*)
357 (* PROCEDURA CZYTA I INTERPROTUJE INSTRUKCJE WYSYLANE PRZEZ *)
358 (* UZYTKOWNIKA DO DEBUGGERA .                               *)
359 (* WYJSCIE DLA INSTRUKCJI - STRUMIEN CI                     *)
360 (* WYNIKI                 - STRUMIEN CO                     *)
361 (* EWENTUALNA KOPIA       - STRUMIEN LO                     *)
362 (************************************************************)
363
364 UNIT INTERPR :PROCEDURE ;
365
366 SIGNAL DEBERROR(NR :INTEGER);
367
368 VAR  S,K,ADRES : INTEGER ,  (* ZMIENNE NA WYNIKI PROCEDURY SCAN  *)
369      STP : BOOLEAN,         (* CZY NAPOTKANO INSTRUKCJE GO *)
370                             (* BUFORY DLA WARTASCI ZMIENNYCH *)
371                             (* 1 -DLA WYNIKOW CZESCIWYCH PRZY ASSIGN *)
372      INTVAL,INTVAL1 : INTEGER,
373      RELVAL,RELVAL1 : REAL  ,
374      CHAVAL,CHAVAL1 : CHAR   ,
375      REFVAL,REFVAL1 : ARRAYOF INTEGER,
376      R,R1           : INTEGER,          (* BUFORY NA LICZBE ARRAYOF *)
377      REFFVAL : ARRAYOF INTEGER,
378      PROTDEB,PROTDEB1,OFFSET1,OFFSET,MODE,MODE1:INTEGER,
379
380      HELP:INSTR,
381      MA:INTEGER;    (* MARKER INTERPRETOWANEJ INSTRUKCJI *)
382
383 (*------   TYPY PREDEFINIOWANE -----------------*)
384
385 CONST  INTT = -2,
386        BOOLT =-8,
387        RELT  =-5,
388        CHT   =-11,
389        STRT  =-35,
390        NONT = -12,
391        FORT  =-10,
392        filt = -14,
393        cortt = -24,
394        proctt = -33;
395
396 (*     TYPY JEDNOSTEK SYNTAKTYCZNYCH           *)
397
398 CONST  VART =  5 ,   (* ZMIENNA   *)
399        CORT = 11 ,   (* COROUTINA *)
400        RECT = 12 ,   (* REKORD    *)
401        BLCT=  1 ,   (* BLOCK     *)
402        HANT = 14 ;   (* HANDLER   *)
403
404 (*   KODY ZNAKOW  *)
405 CONST   ELN=13,
406         bl = 32,
407         SR =59;
408
409
410 (*   S T A L E       S C A N E R A                         *)
411
412 (* IDENTYFIKATORY : S=1,ADRES =    *)
413 CONST  ADELETE = 2393,
414        ASTORE  = 7803,
415        AGO     = 79  ,
416        AREMOVE = 7809,
417        ASSIGN  = 1337,
418        AMOVE   = 2279,
419        ADECLARE= 7817,
420        AMARK   = 7821,
421        AWITH   = 7831,
422        AREPORT = 7827;
423 const
424 (* SLOWA KLUCZOWE S = *)
425        sident = 1,
426        SOUTPUT = 95,
427        SOR     = 68,
428        SAND    = 67,
429        SNOT    = 66,
430        STO     = 104,
431        SWHEN   = 109,
432        SWRITE  = 19,
433        SBREAK  = 33,
434        SRETURN = 4 ,
435        SSTEP   =102,
436        SDO    = 14,
437        SCALL   = 9 ,
438        SEND    = 80,
439        SEOF    = 70,
440        SNONE   = 1002,
441        SBOL    = 1001, (* ADRES = 1 DLA FALSE 2 TRUE *)
442        SCOLON  = 47,
443        SEMICOL = 45,
444        SLPAR   = 52,
445        SART    = 51,
446                      adlt = 5,
447                      adle = 6,
448                      adeq = 3,
449                      adne = 4,
450                      adgt = 7,
451                      adge = 8,
452        SRPAR   = 53,
453        SCOM    = 42,
454        SDOT    = 38,
455        SAST    = 50,  (* *-ADRES= ,- -ADRES=4*)
456                      adast = 5,
457                      admin = 4,
458                      adadd = 3,
459        SCONST  =1000,
460                      kint = 3,
461                      kch  = 6;
462
463 (*==================================================================*)
464 (*                KOMUNIKACJA Z UZYTKOWNIKIEM                       *)
465 (*                ----------------------------                      *)
466 (* ODBYWA SIE LINIAMI ZA POSREDNICTWEM BUFORA SCANNERA              *)
467 (*==================================================================*)
468
469 UNIT INTEX : PROCEDURE (OUTPUT TX:ARRAYOF INTEGER);
470 (* PROCEDURA CZYTA LINE Z BUFORA SCANNERA DO TABLICY TX *)
471 VAR CH,MAX:INTEGER;
472 BEGIN
473 (*+ WRITELN(LO); ++*)
474 (*+ WRITELN(LO," INTEX"); ++*);
475   (* max := max from scanner *)
476   call sccd01ox(0,max,i,tx);
477 ARRAY TX DIM(1:MAX+1);
478   (* TX := bufor from scanner *)
479   call sccd01ox(1,max,max,tx);
480 (*+ for i:=1 to max do  ++*)
481 (*+ IF(I MOD 10) =1 THEN WRITELN(LO);WRITE(LO," "); FI;++*)
482 (*+ WRITE(LO,TX(I));++*)
483 (*+ od; ++*)
484   ch := 0; i := 1;
485   do
486     if i >= max then exit fi;
487     if tx(i) = eln then exit fi;
488     ch := tx(i); i := I+1
489   od;
490   if ch=/=sr then
491     tx(i) := sr; i := i+1;
492   fi;
493   tx(i) := eln;
494   I:=I+1;
495   WHILE I<MAX DO tx(i) := bl;I:=I+1 OD;
496 END(* INTEX*);
497
498 UNIT OUTEX : PROCEDURE (TX:ARRAYOF INTEGER);
499 (* PROCEDURA WPISUJE ZAWARTOSC TABLICY TX DO BUFORA SCANERA *)
500   var pom:integer;
501 BEGIN
502 (*+ WRITELN(LO) ++*);
503 (*+ WRITELN(LO," OUTEX"); ++*);
504   (* bufor from scanner:=tx, max form scanner:=upper(tx),lp from scanner:=1 *)
505   i := 1; pom := upper(tx);
506   call sccd01ox(2,pom,i,tx);
507 (*+FOR I:=1 TO UPPER(TX) DO ++*)
508 (*+ IF (I MOD 10)=1 THEN WRITELN(LO);WRITE(LO," ") FI; ++*)
509 (*+ WRITE(LO,TX(I)) ++*);
510 (*+ OD;++*)
511 END(* OUTEX *);
512
513 (*---------------------------------------------------------*)
514 (*             S C A N                                     *)
515 (* WYWOLUJE PROCEDURE ASSEMBLERA SCAN . WYNIK NA ZMIENNYCH *)
516 (* GLOBALNYCH S,K,ADRES                                    *)
517 (* W PRZYPADKU BLEDU S OTRZYMYJE WARTOSC -1 A K -NUMER     *)
518 (*       BLEDU SYGNALIZOWANY PRZEZ SCANER                  *)
519 (*---------------------------------------------------------*)
520
521 UNIT SCAN :PROCEDURE;
522    begin
523      call scnd01ox(s,k,adres);
524 (*+ WRITELN(LO," S= ",S," K= ",K," ADRES=",ADRES);++*)
525 IF S < 0 THEN RAISE DEBERROR(0) FI;
526 END  (**** SCAN ******);
527
528 UNIT NEWLIN :PROCEDURE;
529 (* PRZEJSCIE DO NOWEJ LINII *)
530 BEGIN
531   (* scanner variables: sy1:=45; k1:=6; okey:=false;lp:=max+1 *)
532   call sccd01ox(4,i,i,refval);
533 END;
534
535 (*-----------------------------------------------------------*)
536 (*           WRID ,WRCH ,WRLIN                               *)
537 (*-----------------------------------------------------------*)
538 UNIT WRID:PROCEDURE (I:INTEGER; num : integer);
539
540 (* WYPISANIE IDENTYFIKATORA               *)
541 (* I- ADRES IDENTYFIKATORA W TABLICY HASH *)
542 (* num - na tylu miejsach ma byc wypisany identyfikator *)
543
544 VAR J,L,K:INTEGER;
545 BEGIN
546 j := 0;
547 DO
548   (* k, l := hash(i), hash(i+1) *)
549   call sccd01ox(3,i,k,refval );
550   i := i+1;
551   call sccd01ox(3,i,l,refval);
552   CALL WRCH(K);
553   IF L<0 THEN I:=-L;J:=J+2;REPEAT FI;
554   EXIT
555 OD;
556 FOR I:=J+2 TO num DO WRITE(CO," ");
557                IF ECHO THEN WRITE(LO," ") FI;
558                OD;
559 END wrid;
560
561 UNIT WRCH:PROCEDURE(I:INTEGER);
562 (* I- SLOWO ZAWIERAJACE DWA ZNAKI DO WYPISANIA *)
563 VAR K:INTEGER,
564     BOO:BOOL;
565 BEGIN
566 K:=I DIV 64;
567 DO
568   CASE K
569     WHEN 0:IF  BOO THEN WRITE(CO,"0");
570                       IF ECHO THEN WRITE(LO,"0") FI FI;
571     WHEN 60:IF NOT BOO THEN WRITE(CO,"0");
572                        IF ECHO THEN WRITE(LO,"0") FI FI;
573     WHEN 46:WRITE(CO," "); IF ECHO THEN WRITE(LO," ") FI;
574     WHEN 1,2,3,4,5,6,7,8,9:WRITE(CO,CHR(48+K));
575                          IF ECHO THEN WRITE(LO,CHR(48+K)) FI;
576     OTHERWISE WRITE(CO,CHR(55+K));IF ECHO THEN WRITE(LO,CHR(55+K)) FI;
577   ESAC;
578   IF BOO THEN EXIT FI;
579   K:=I MOD 64;
580   BOO:=TRUE
581 OD;
582 END wrch;
583
584 UNIT WRLIN:PROCEDURE (TXT:ARRAYOF INTEGER);
585 VAR J:INTEGER;
586 BEGIN WRITE(CO," ");
587 IF ECHO THEN WRITE(LO," ") FI;
588 I:=1;
589 WHILE TXT(I)=/=eln DO
590     WRITE(CO,CHR(TXT(I)));
591     IF ECHO THEN WRITE(LO,CHR(TXT(I))) FI;
592     I:=I+1;
593 OD;
594 WRITELN(CO) ;IF ECHO THEN WRITELN(LO) FI;
595 END wrlin;
596
597 (*-----------------------------------------------------------*)
598 (*               T A K E                                     *)
599 (*                                                           *)
600 (* GRUPA PROCEDUR UMAZLIWIAJACA ODCZYRANIE WARTOSCI OKRESLO- *)
601 (* TYPU PRZY OKRESLONYM SPOSOBIE ADRESOWANIA.                *)
602 (* WYNIKI NA ZMINNYCH INTVAL,RELVAL,CHVAL,REFVAL ODPOWIEDNIO *)
603 (* DO TYPU ( BOOL NA INTVAL 0 LUB -1 )                       *)
604 (*-----------------------------------------------------------*)
605
606
607 UNIT TAKEREF :PROCEDURE(OFFSET,TYP : INTEGER );
608
609 (* ODCZYTUJE WARTSC O  DANYM OFFSECIE W OBIEKCIE WSKAZYWANYM PREZ REF *)
610 (* relval/chaval/intval/refval - value from memory  *)
611 (* refval,offset - address in the memory *)
612 BEGIN
613 IF REFVAL=NONE THEN RAISE DEBERROR(15) FI;
614 CASE TYP
615
616 WHEN RELT:
617     (* relval := value of the address (refval,offset) *)
618     call db01ox(1,refval,offset,glovirt,relval,intval);
619 (*+ WRITELN(LO," TAKEREF RELVAL ",RELVAL)++*);
620
621 WHEN BOOLT,INTT :
622      (* intval := value of the address (refval,offset) *)
623      call db01ox(2,refval,offset,glovirt,relval,intval );
624
625 WHEN CHT:
626      (* chaval := value of the address (refval,offset ) *)
627      call db01ox(3,refval,offset,glovirt, relval, i);
628      chaval := chr(i);
629 (*+ WRITELN(LO," TAKEREF CHAVAL ",CHAVAL)++*);
630
631  WHEN STRT : WRITELN(CO,t15);
632
633 OTHERWISE
634     (* refval := value of the address (refval,offset) *)
635     call db01ox(4,refval,offset,glovirt,relval, intval);
636 (*+ WRITELN(LO," TAKEREF REFVAL ")++*)
637 ESAC
638 END takeref;
639
640 (*-------------------------------------------------------------*)
641 UNIT TAKEARR :PROCEDURE(IND,TYP : INTEGER );
642 (* TO CO TAKEREF ALE DLA TABLIC *)
643 (* refval/intval/relval/chaval := value of an array element   *)
644 (*  ind - real offset in an array object, refval - address of the array *)
645 VAR AP,I :INTEGER;
646 BEGIN
647 IF REFVAL=NONE THEN RAISE DEBERROR(15) FI;
648 CASE TYP
649   WHEN RELT : IND:=IND*2;I:=2;
650   WHEN INTT,BOOLT,CHT,STRT :I:=1;
651   OTHERWISE IND:=IND*2;I:=2;
652 ESAC;
653 (* ind - offset, i - appetite of an array element *)
654 (* ap := appetite of the array object, intval := lower*element appetite -3 *)
655     call db01ox(5,refval,intval,glovirt,relval, ap);
656 INTVAL:=INTVAL+3; (* LOWER*APPETITE *)
657 IF IND < INTVAL OR IND >AP-3+I-INTVAL THEN RAISE DEBERROR(33) FI;
658
659 CASE TYP
660 WHEN RELT:
661    (* relval := array element *)
662    call db01ox(6,refval,ind,glovirt,relval,intval);
663 (*+ WRITELN(LO," TAKEARR IND RELVAL",IND,RELVAL)++*);
664
665 WHEN INTT,BOOLT :
666     (* intval := array element *)
667     call db01ox(7,refval,ind,glovirt,relval,intval);
668 (*+ WRITELN(LO,"TAKEARR IND, INTVAL ",IND,INTVAL )++*);
669
670 WHEN CHT:
671     (* chaval := array element *)
672     call db01ox(8,refval,ind,glovirt,relval,i);
673     chaval := chr(i);
674 (*+ WRITELN(LO," TAKEARR IND ,CHAVAL",IND,CHAVAL )++*);
675
676  WHEN STRT :WRITELN(CO,t15);
677
678 OTHERWISE
679    (* refval := array element *)
680    call db01ox(9,refval,ind,glovirt,relval,intval);
681 (*+ WRITELN(LO," TAKEARR REFVAL ")++*);
682 ESAC;
683 END (* TAKEARR *);
684
685
686 (*-----------------------------------------------------------*)
687 (*       E N D   P R O C E D U R    T A K E  ...             *)
688 (*-----------------------------------------------------------*)
689
690 (*================   I N F ==================================*)
691
692 UNIT INF:PROCEDURE;
693 BEGIN
694    WRITE(CO,t10);IF ECHO THEN WRITE(LO,t10) FI;
695    i := idict(protnr);
696    unitcase := prot(i);
697    IF UNITCASE=BLCT (* BLOCK *) THEN WRITE(CO,t11);
698                IF ECHO THEN WRITE(LO,t11) FI;
699    ELSE
700      IF UNITCASE=HANT THEN WRITE(CO, t12);
701          IF ECHO THEN WRITE(LO,t12) FI
702      ELSE
703      CALL WRID(prot(I-1), 10);
704      FI
705    FI;
706    WRITE(CO,t13);IF ECHO THEN WRITE(LO,t13) FI;
707    I:=I+2;
708    WRITELN(CO,prot(I));IF ECHO THEN WRITELN(LO,prot(I)) FI;
709 END inf;
710
711 (*===========================================================*)
712
713 (* ----------------------------------------------------------*)
714 (*                                                           *)
715 (*                     F I N D L I N                         *)
716 (*  reads line number, label or dot                          *)
717 (*  returns index (in breakt) of the line identified by the  *)
718 (*             given symbol                                  *)
719 (*-----------------------------------------------------------*)
720
721    unit findlin:function:integer;
722     var i:integer;
723    begin
724      if s=sdot then result:=cind
725      else
726        if s=sident then
727        for i:=1 to lastbr do
728          if breakt(i)=/=0 andif breaktl(i)=/=none andif
729             breaktl(i).mark = adres then result := i;
730                                          exit;
731          fi;
732        od
733        else
734          if s=/=sconst or k=/=kint then raise deberror(1) fi;
735          (* searching for the index in breakt *)
736          for i:=1 to lastbr do
737             if breakt(i) = adres then exit fi;
738          od;
739          if  i<=lastbr andif breakt(i) = adres then result := i fi;
740        fi
741     fi;
742     if result=0 then raise deberror(18) fi;
743     (*+  writeln(lo,"  findlin :", result); ++*)
744   end findlin;
745
746 (*-----------------------------------------------------------*)
747 (*                                                           *)
748 (*             D    E     L            (DELETE )             *)
749 (*                                                           *)
750 (*  PROCEDURA USUWA PUNKT PRZERYWAJACY OKRESLAONY PRZEZ      *)
751 (*  ETYKIETE LUB NUMER LINII                                 *)
752 (*-----------------------------------------------------------*)
753
754 UNIT DEL : PROCEDURE;
755 VAR I:INTEGER;
756 BEGIN
757   CALL SCAN;
758   i := findlin;
759   if i=cind then raise deberror(39) fi;
760   if breaktl(i) =/= none then call killb(breaktl(i)) fi;
761   breakt(i) := breakt(lastbr);
762   if cind = lastbr then cind := i fi;
763   breaktl(i) := breaktl(lastbr);
764   lastbr := lastbr-1;
765 END (* DEL *)
766
767 (*-------------------------------------------------------------*)
768 (*                                                             *)
769 (*              B   R   E        (BREAK)                       *)
770 (*                                                             *)
771 (* DEKLARACJA PUNKTU PRZERYWAJECEGO. PUNKT TEM MOZE BYC        *)
772 (* OZNACZONY ETYKIETA. MOZE BYC TO WARUNKOWY PUNKT PRZERYWAJACY*)
773 (*-------------------------------------------------------------*)
774
775 UNIT BRE : PROCEDURE;
776 VAR I:INTEGER;
777 BEGIN
778   CALL SCAN;  (* CZYTAMY NR LINII  *)
779   IF S =/= SCONST or K<>kint THEN RAISE DEBERROR(1) FI;
780   FOR  I:=1 TO lastbr DO IF BREAKT(I)=ADRES THEN RAISE DEBERROR(17) FI OD;
781   IF lastbr = maxbr THEN RAISE DEBERROR(16) fi;
782    (* NO SPACE IN BREAK POINTS TABLE *) 
783   lastbr := lastbr+1;
784   BREAKT(lastbr):=ADRES;
785   BREAKTL(lastbr):=NEW BR;
786   if adres = linenr then cind := lastbr fi;
787   CALL SCAN;   (* CZY JEST TO WARUNKOWY PUNKT ? *)
788   IF S=SWHEN THEN CALL INTEX(BREAKTL(lastbr).CONDTXT);  (* TAK-ZAPAMIETUJEMY *)
789                                                   (* TEKST Z WARUNKIEM *)
790            (* PRZESKAKUJEMY TEKST WARUNKU *)
791            WHILE S=/=SEMICOL AND NOT(S=sident AND ADRES=AWITH) DO CALL SCAN OD
792   FI;
793   IF S=sident AND ADRES = AWITH THEN CALL SCAN;  (* BEDZIE ETYKIETA *)
794        IF S=/=sident THEN RAISE DEBERROR(1) (*IDENTIFIER EXPECTED *) FI;
795        BREAKTL(lastbr).MARK:=ADRES;
796        call scan;
797   FI;
798 END (* BRE *);
799
800 (*--------------------------------------------------------------------*)
801 (*                                                                    *)
802 (*                           M A R K                                  *)
803 (*                                                                    *)
804 (*--------------------------------------------------------------------*)
805
806    unit mark:procedure;
807     (* marks the given break point *)
808    begin
809      call scan;
810      i := findlin;
811      call scan;
812      if s=/= sident then raise deberror(1) fi;
813      if breaktl(i)=none then breaktl(i):=new br fi;
814      breaktl(i).mark:=adres;
815    end mark;
816
817 (*--------------------------------------------------------------------*)
818 (*                                                                    *)
819 (*                           G O O                                    *)
820 (*                                                                    *)
821 (*   return to user program execution                                 *)
822 (*    -  without parameters - standard execution                      *)
823 (*    -  * - execution with trace, without breaks                     *)
824 (*    -  line number - execution with traceand without breaks         *)
825 (*                     up to the given line, then standard execution  *)
826 (*    -  + - execution without trace and without breaks               *)
827 (*    -  -  - abort                                                   *)
828 (*--------------------------------------------------------------------*)
829
830   unit goo:procedure;
831     var pom:movel;
832     begin
833        stp := true; (* stop ! *)
834        call scan;
835        if s=sconst and k=3 then
836          ggo:=1; linenr2:=adres
837        else
838           if s=sast then
839           case adres
840             when adast:  ggo:=2 (* * *);
841             when adadd:  ggo:=3 (* + *);
842             when admin:  ggo:=4 (* - *);
843             otherwise  raise deberror(34)
844           esac
845           else
846             if s=/= semicol then raise deberror(10) fi
847           fi
848         fi;
849        (* deallocation *)
850         pom := mov.next;
851         while pom=/=none do
852            kill(mov); mov:=pom; pom:=pom.next
853         od;
854         kill (mov)
855     end goo;
856
857 (*--------------------------------------------------------------------*)
858 (*                                                                    *)
859 (*                      R E P O R T                                   *)
860 (*                                                                    *)
861 (*--------------------------------------------------------------------*)
862 UNIT REPORT : PROCEDURE;
863 VAR POM:INSTR,
864      P2:DEC,
865     M,I,K1:INTEGER;
866 BEGIN
867 CALL SCAN;
868 IF S=SBREAK THEN (* REPORT BREAK *)
869    CALL SCAN;
870    IF S=SAST THEN (* REPORT BREAK *  *)
871        writeln(co);
872        WRITELN(CO,"         LIST OF BREAK POINTS");
873        WRITELN(CO,"   LINE NR /        MARKER          / INSTR. LIST ");
874        FOR I:=1 TO lastbr DO
875           IF BREAKT(I)=/=0 THEN
876              WRITELN(CO," ");WRITE(CO,BREAKT(I):8); write(co, "    ");
877              IF BREAKTL(I)=/=NONE THEN
878                 IF BREAKTL(I).MARK=/=0 THEN
879                          WRITE(CO,"        ");
880                          CALL WRID(BREAKTL(I).MARK, 17)
881                 ELSE WRITE(CO,"                         ") FI;
882                 IF BREAKTL(I).INS=/=NONE THEN WRITE(CO,"    YES")
883                 ELSE WRITE(CO,"    NO") FI
884              ELSE WRITE(CO,"                             NO") FI
885          FI
886        OD;
887        WRITELN(CO," ");
888        WRITELN(CO, " ");
889    ELSE (* REPORT BREAK - IDENTYFIKATOR , NR LINII  lub kropka *)
890        i := findlin;
891        if i=0 then raise deberror(18) fi; (* break point doesn't exist *)
892        if breaktl(i)=/=none then m:=breaktl(i).mark fi;
893        writeln(co);
894        write(co," BREAK POINT - LINE :", breakt(i));
895        if m=/=0 then write(co,"    MARKER :"); call wrid(m, 10) fi;
896        writeln(co);
897        if breaktl(i) =/= none then
898          pom := breaktl(i).ins;
899          while pom=/=none do
900             call wrlin(pom.txt);
901             pom := pom.next;
902          od;
903        fi;
904        writeln(co)
905     fi;
906     call scan
907  ELSE (* OCZEKUJEMY REPORT DECLARE *)
908 IF ADRES=ADECLARE THEN
909     CALL SCAN;P2 := DECL;
910   IF S =/= sident THEN
911       IF S = SAST THEN (* LISTA WSZYSTKICH BANKOW INSTRUKCJI *)
912         WRITELN(CO,"       LIST OF DELCARED BANKS :");
913         WHILE P2 =/= NONE DO
914           WRITE(CO," ");CALL  WRID(P2.ID, 10);WRITELN(CO);
915           P2 := P2.NEXT;
916         OD;
917         WRITELN(CO)
918     ELSE RAISE DEBERROR(1)
919     FI
920   ELSE (* LISTA INSTRUKCJI BANKU O PODANUM IDENTYFIKATORZE *)
921     WHILE P2=/=NONE DO
922       IF P2.ID = ADRES THEN EXIT FI;P2:=P2.NEXT;
923     OD;
924     IF P2=NONE THEN RAISE DEBERROR(13)
925     ELSE
926      POM := P2.INS;
927      WHILE POM =/= NONE DO
928         CALL WRLIN(POM.TXT);
929         POM := POM.NEXT
930      OD;
931      WRITELN(CO);
932     FI
933   FI;
934   call scan
935 else
936   if s=semicol then (* report; *)
937      writeln(co,t9,linenr);write(co,t29);
938      if echo then writeln(lo,t9,linenr); write(lo,t29) fi;
939      call inf;
940    ELSE RAISE DEBERROR(14) FI
941 FI
942 fi;
943 END report;
944
945 (*----------------------------------------------------------*)
946 (*                                                          *)
947 (*                   S T O R E                              *)
948 (*                                                          *)
949 (* ZWIAZANIE  listy INSTRUKCJI Z podanym PUNKTEM            *)
950 (*           przerywajacym                                  *)
951 (*----------------------------------------------------------*)
952
953 UNIT STORE :PROCEDURE;
954 VAR POM,POM1:INSTR,
955         lin : integer;
956 BEGIN
957 CALL SCAN;
958 lin := findlin;
959 call scan;
960 if s =/= semicol then raise deberror(10) fi;
961 if breaktl(lin)=none then breaktl(lin) := new br fi;
962 pom,pom1 := breaktl(lin).ins;
963 while pom=/=none do pom1:=pom; pom:=pom.next od;
964 do
965    call newlin;
966    call scan;
967    if s = send then exit fi;
968    pom := new instr;
969    call intex(pom.txt);
970    if s=sident then pom.mark:=adres fi;
971    if pom1=none then breaktl(lin).ins:=pom
972      else pom1.next:=pom fi;
973    pom1 := pom
974  od
975 end store;
976
977 (*----------------------------------------------------------*)
978 (*                                                          *)
979 (*                    R E M O V E                           *)
980 (*                                                          *)
981 (* USUNIECIE INSTRUKCJI ZWIAZANEJ Z AKTUALNYM PUNKTEM       *)
982 (* PRZERYWAJECYM. (PODAJE SIE ETYKIETE USUWANEJ INSTRUKCJI) *)
983 (*----------------------------------------------------------*)
984
985 UNIT REMOVE :PROCEDURE;
986 VAR POM,POM1:INSTR;
987 var ok:boolean;
988 BEGIN
989   CALL SCAN;
990   i := findlin;
991   call scan;
992   if i=0 then raise deberror(18) fi;
993  (* ODCZYTALISMY ETYKIETE ,SZUKAMY INSTRUKCJI DO USUNECIA *)
994   IF BREAKTL(i)=NONE THEN POM:=NONE
995     ELSE POM:=BREAKTL(i).INS
996   FI;
997   pom1 := pom;
998   WHILE POM =/= NONE DO
999      (*+ writeln(lo," marker :", pom.mark); ++*)
1000      IF POM.MARK = ADRES THEN (* ZNALEZLISMY, KOPIUJEMY *)
1001         ok := true;
1002         if pom.next=/= none then
1003            if pom = pom1 then
1004             (* element jest na poczatku listy *)
1005             breaktl(i).ins:=pom.next
1006           else
1007             pom1.next:=pom.next
1008           fi;
1009           pom.next := none;
1010         fi;
1011         CALL KILLI (POM)
1012      ELSE POM1:=POM;POM:=POM.NEXT
1013      FI
1014   OD;
1015   if not ok then raise deberror(38) fi;
1016 END;
1017
1018 (*---------------------------------------------------*)
1019 (*                                                   *)
1020 (*          D E C L A R E                            *)
1021 (*                                                   *)
1022 (* DEKLARACJA BANKU INSTRUKCJI                       *)
1023 (*---------------------------------------------------*)
1024
1025 UNIT DECLARE :PROCEDURE;
1026 VAR POM : DEC,
1027     P1,P2 : INSTR;
1028 BEGIN
1029    CALL SCAN;
1030    IF S =/= sident THEN RAISE DEBERROR(1) FI;
1031    (* PRZECZYTALISMY IDENTYFIKATOR PRZYSZLEGO BANKU *)
1032    POM := NEW DEC;
1033    POM.ID := ADRES;
1034    POM.NEXT:=DECL;
1035    (* DOLACZYLISMY INFORMACJE O  NOWYM BANKU DO LISTY BANKOW *)
1036    DECL := POM; CALL NEWLIN;CALL SCAN;
1037    WHILE S =/= SEND DO
1038      (* KOPIUJEMY INSTRUKCJE *)
1039      P1 := NEW INSTR;
1040      CALL INTEX(P1.TXT);
1041      CALL NEWLIN;
1042      IF P2 = NONE THEN POM.INS := P1
1043      ELSE P2.NEXT := P1  FI;
1044      p2 := p1;
1045      CALL SCAN
1046    OD
1047 END declare;
1048
1049 (*----------------------------------------------*)
1050 (*                                              *)
1051 (*           C A L                              *)
1052 (*                                              *)
1053 (* WYKONANIE INSTRUKCJI Z BANKU INSTRUKCJI      *)
1054 (*----------------------------------------------*)
1055
1056 UNIT CAL : PROCEDURE;
1057 VAR POM : DEC,
1058      MC : INTEGER,
1059     P2 :INSTR;
1060 BEGIN
1061    MC := MA;
1062    CALL INTEX(ctxt);
1063    (* PRZECHOWANIE BUFORA SCANERA *)
1064    CALL SCAN ;IF S =/= sident THEN RAISE DEBERROR(1) FI;
1065    POM := DECL;
1066    WHILE POM =/= NONE DO
1067      IF POM.ID = ADRES THEN EXIT FI;
1068      POM := POM.NEXT;
1069    OD;
1070    IF POM = NONE THEN RAISE DEBERROR(13)
1071    ELSE
1072      P2 := POM.INS;
1073      WHILE P2 =/= NONE DO
1074         CALL OUTEX(P2.TXT);
1075         CALL WRLIN(P2.TXT);
1076         CALL SCAN;
1077         CALL INTLIN;
1078         P2 := P2.NEXT
1079      OD;
1080    FI;
1081    MA :=MC;
1082    CALL NEWLIN;
1083 END cal;
1084
1085 (*---------------------------------------------------------*)
1086 (*                                                         *)
1087 (*              A S S I G N                                *)
1088 (*                                                         *)
1089 (* INTERPRERACJA INSTRUKCJI PODSTAWIENIA                   *)
1090 (*---------------------------------------------------------*)
1091
1092 UNIT ASSIG :PROCEDURE;
1093 BEGIN
1094   CALL SCAN;
1095   CALL FIND(FALSE);
1096   (* ODCZYTANE WARTOSCI prawej STRONY PODSTAWIENIA *)
1097   MODE1:=MODE; PROTDEB1:=PROTDEB; INTVAL1:= INTVAL;
1098   (* ZAPAMIETANIE WAROTSCI WYNIKOW PROCEDURY FIND *)
1099   REFVAL1:=REFVAL; RELVAL1:= RELVAL; CHAVAL1:= CHAVAL;
1100  (*+ WRITELN(LO," ",MODE,PROTDEB,INTVAL,RELVAL); ++*)
1101   IF  S=/= STO THEN RAISE DEBERROR(11) FI;
1102   CALL SCAN;
1103   CALL FIND(TRUE);
1104   (* ODCZYTANIE PRAWEJ STRONY WYRAZENIA *)
1105   (*+ WRITELN(LO," ",MODE,PROTDEB,INTVAL,RELVAL,OFFSET); ++*)
1106   IF PROTDEB1=INTT AND PROTDEB=RELT THEN RELVAL1:=INTVAL1 FI;
1107   IF PROTDEB1=RELT AND PROTDEB=INTT THEN INTVAL1:=RELVAL1 FI;
1108   IF PROTDEB1*PROTDEB<0 THEN RAISE DEBERROR(19) FI;
1109   IF PROTDEB=NONT THEN RAISE DEBERROR(15) FI;
1110   IF PROTDEB1=NONT THEN PROTDEB1:=1 FI;
1111   (*+WRITELN(LO," ",MODE,RELVAL1,INTVAL1);++*)
1112   IF MODE1>3 THEN IF MODE<3 THEN RAISE DEBERROR(19) FI FI;
1113   CALL OUTREF(REFFVAL);
1114   CALL OUTREF(REFVAL);
1115   CALL OUTREF(REFVAL1);
1116
1117 CASE MODE
1118 (* PODSTAWIENIE WARTOSCI PRZEBIEGA ROZNIE W ZALEZNOSCI  *)
1119 (* OD SPOSOBU ADRESACJI I TYPU ZMIENNEJ                 *)
1120  WHEN 1,2,5,6 : (* assign an object attribute *)
1121       IF REFFVAL=NONE THEN RAISE DEBERROR(15) FI;
1122       IF MODE1>3 OR PROTDEB>0 THEN
1123        (* refval1 --> address (refval,offset) *)
1124          call db01ox(10,refval,offset,refval1,relval,intval);
1125       ELSE
1126
1127       case protdeb
1128        WHEN INTT,BOOLT:
1129           (* intval1 --> address(refval,offset) *)
1130           call db01ox(11,refval,offset,glovirt,relval,intval1);
1131        WHEN CHT :
1132           (* chaval1 --> address (refval,offset) *)
1133           i := ord(chaval1);
1134           call db01ox(12,refval,offset,glovirt,relval,i);
1135       WHEN RELT :
1136           (* relval1 --> address (refval,offset) *)
1137           call db01ox(13,refval,offset,glovirt,relval1,intval);
1138       esac
1139    FI;
1140
1141   WHEN 3,4: (* assign an array element *)
1142      IF REFFVAL = NONE THEN RAISE DEBERROR(15) FI;
1143      IF MODE1>3 OR PROTDEB>0 THEN
1144        OFFSET:=OFFSET*2;
1145         (* refval1 ---> array element of an address (refval,offset) *)
1146         call db01ox(14,refval,offset,refval1,relval,intval);
1147
1148     ELSE CASE PROTDEB
1149        WHEN INTT,BOOLT :
1150          (* intval1 --> array element *)
1151          call db01ox(15,refval,offset,glovirt,relval,intval1);
1152        WHEN CHT :
1153           (* chaval1 --> array element *)
1154           i := ord(chaval1);
1155           call db01ox(16,refval,offset,glovirt,relval,i);
1156      WHEN RELT :
1157           (* relval1 --> array element *)
1158           OFFSET:=OFFSET*3;
1159            call db01ox(17,refval,offset,glovirt,relval1,intval);
1160      ESAC
1161    FI
1162 ESAC
1163 END assig;
1164
1165 (*========================================================*)
1166 (*                                                        *)
1167 (*               O U T P          ( OUTPUT )              *)
1168 (*                                                        *)
1169 (* WYPISANIE WARTOSCI WYRAZENIA LUB JEGO TYPU             *)
1170 (*========================================================*)
1171
1172 UNIT OUTP : PROCEDURE;
1173   var i,j:integer;
1174 BEGIN
1175 CALL SCAN;
1176 CALL FIND(FALSE);
1177 IF S=SAST AND ADRES=adast then
1178 (* WYPISANIE TYPU WYRAZENIA             *)
1179    IF R=/=0 THEN
1180        WRITE(CO,t16,R,t17);
1181        IF ECHO THEN WRITE(LO,t16,R,t17) FI;
1182        IF PROTDEB=FORT THEN WRITELN(CO,t18);
1183                IF ECHO THEN WRITELN(LO,t18) FI;RETURN
1184        FI;
1185    FI;
1186 IF PROTDEB=FORT or protdeb =cortt or protdeb = proctt THEN
1187  IF REFVAL=NONE THEN WRITELN(CO,t19);
1188                    IF ECHO THEN WRITELN(LO,t19) FI; RETURN FI;
1189 (* protdeb := dispnr of the object refval *)
1190  call db01ox(18,refval,i,glovirt,gloreal,protdeb);
1191 FI;
1192    IF PROTDEB<0 THEN
1193    CASE -PROTDEB
1194      WHEN 2:WRITE(CO,t20); IF ECHO THEN WRITE(LO,t20) FI;
1195      WHEN 8:WRITE(CO,t21);IF ECHO THEN WRITE(LO,t21) FI;
1196      WHEN 11:WRITE(CO,t22);IF ECHO THEN WRITE(LO,t22) FI;
1197      WHEN 5:WRITE(CO,t23);IF ECHO THEN WRITE(LO,t23) FI;
1198      WHEN 35:WRITE(CO,t24);IF ECHO THEN WRITE(LO,t24) FI;
1199      OTHERWISE ;
1200      ESAC;
1201    ELSE
1202      i := idict(protdeb);
1203      WRITE(CO," "); IF ECHO THEN WRITE(LO," ") FI;
1204      CALL WRID(prot(I-1), 10)
1205   FI;
1206   WRITELN(CO); IF ECHO THEN WRITELN(LO) FI;
1207   call scan;
1208 ELSE
1209 (* WYPISANIE WARTOSCI WYRAZENIA                  *)
1210 IF S=/=SEMICOL THEN RAISE DEBERROR(10) FI;
1211 IF MODE >= 4 THEN RAISE DEBERROR(20) FI;
1212 IF PROTDEB=INTT THEN WRITELN(CO," ",INTVAL);
1213                  IF ECHO THEN WRITELN(LO," ",INTVAL) FI;
1214 ELSE
1215 IF PROTDEB=RELT THEN WRITELN (CO," ",RELVAL);
1216                 IF ECHO THEN WRITELN(LO," ",RELVAL) FI
1217 ELSE
1218 IF PROTDEB=CHT THEN WRITELN(CO," ",CHAVAL);
1219                IF ECHO THEN WRITE(LO," ",CHAVAL) FI
1220 ELSE
1221 IF PROTDEB=BOOLT THEN IF INTVAL = -1 THEN WRITELN(CO,t25);
1222                          IF ECHO THEN WRITELN(LO,t25) FI;
1223                   ELSE WRITELN(CO,t26);
1224                        IF ECHO THEN WRITELN(LO,t26) FI
1225                   FI
1226 ELSE
1227   call db01ox(30,refval,i,glovirt,gloreal,j);
1228   writeln(co, " virtual address  ",i,j);
1229   if echo then writeln(lo," virtual address ",i,j) fi;
1230 FI FI FI FI
1231 FI
1232 END;
1233
1234 (*-----------------------------------------------*)
1235 (*                                               *)
1236 (*          M O V E                              *)
1237 (*                                               *)
1238 (* ZMIANA PUNKTU OBSERWACJI                      *)
1239 (*-----------------------------------------------*)
1240
1241 UNIT MOVE :PROCEDURE;
1242 VAR M:MOVEL, C:ARRAYOF INTEGER;
1243
1244 BEGIN
1245 CALL SCAN;C:=MOV.COR;
1246 i := idict(protnr);
1247 (*+ CALL OUTREF(MOV.ADR); CALL OUTREF(C); ++*)
1248 IF S=SAST AND ADRES=adast  THEN
1249    (* IDZIEMY PO PREFIKSIE *)
1250    IF PROTNR<0 THEN RAISE DEBERROR(31) FI;
1251    CALL SCAN;IF S=/=SART OR ADRES=/=adgt THEN RAISE DEBERROR (28) FI;
1252    I:=I+4;   (* ADRES numeru PROTOTYPU PREFIKSU *)
1253    PROTDEB:=prot(I);
1254    (* protdeb - adres prototypu prefiksu *)
1255    (* ODCZYTANIE PROTOTYPU DEBUGGERA PREFIKSU *)
1256    IF PROTDEB=0 (* NIE MA PREFIKSU *) THEN RAISE DEBERROR(31) FI;
1257    M:=NEW MOVEL(MA,PROTDEB,MOV.ADR,MOV.COR);
1258    M.NEXT:=MOV ; MOV:=M; PROTNR:=PROTDEB; CALL INF;
1259    call scan; (* przeczytanie ';' *)
1260   RETURN
1261 FI;
1262 if s=/= 1 then (* poruSZAMY SIE PO SL LUB DL LUB CL *)
1263       IF UNITCASE=RECT THEN RAISE DEBERROR(35) FI;
1264       IF S=SART AND ADRES=adeq THEN (* = *)  (* SL  *)
1265       IF PROTNR=0 THEN RAISE DEBERROR(30) FI; (* main block *)
1266       CALL SCAN;
1267       IF S=/=SART OR ADRES=/=7 THEN RAISE DEBERROR(28) FI;
1268       I:=I+1; PROTDEB:=prot(I);(* SL *)
1269       (* ODCZYTANIE  ADRESU OBIEKTU WSKAZYWANEGO PRZEZ SL *)
1270       (* refval := address of the SL of mov.adr *)
1271       call db01ox(19,mov.adr,offset,refval,relval,intval);
1272        C:=FINDCR(REFVAL);
1273        call scan; (* wczytanie ';' *)
1274    ELSE
1275    IF S=SAST AND ADRES= admin THEN (* - *)   (*  DL *)
1276       IF PROTNR=0 THEN RAISE DEBERROR(30) FI; (* main block *)
1277       IF UNITCASE=CORT (* COROUTINE *) THEN RAISE DEBERROR(32) FI;
1278       CALL SCAN;
1279       IF S=/=SART OR ADRES=/=adgt THEN RAISE DEBERROR(28) FI;
1280       (* ODCZYTENIE OBIEKTU WSKAZYWNEGO PRZEZ DL *)
1281       (* refval := address of the DL of the object mov.adr *)
1282       call db01ox(20,mov.adr,offset,refval,relval,intval);
1283       IF MOV.ADR=REFVAL THEN RAISE DEBERROR(36) FI;
1284       call scan; (* wczytanie srednika *)
1285        (* MOVE DL W IBIEKCIE STERMINOWANYM *)
1286      ELSE   (*   CL  *)
1287         IF S=/=SART OR ADRES =/= adgt THEN RAISE DEBERROR(28) FI;
1288         CALL SCAN;
1289         IF S =/= SART OR ADRES =/= adgt THEN RAISE DEBERROR(28) FI;
1290         (* ODCZYTUJEMY CL *)
1291         IF MOV.COR=NONE THEN RAISE DEBERROR(37) FI;
1292         (*  JESTESMY W OBIEKCIE NALEZACYM DO LANCUCHA COROUTINY *)
1293         (* refval := address of the CL of the object mov.cor *)
1294         call db01ox(21,mov.cor,offset,refval,relval,intval);
1295          C:=REFVAL;
1296         IF REFVAL=NONE THEN RAISE DEBERROR(15) FI;
1297         IF CCOR=REFVAL THEN (* WRACAMY DO AKTYWNEJ COROUTINY *)
1298            REFVAL:=CADR;
1299         ELSE  (* ODCZYTUJEMY ADRES OBJEKTU WSKAZYWANEGO PRZEZ DL GLOWY *)
1300            (* refval := address of DL of the object C *)
1301            call db01ox(22,c,offset,refval,relval,intval);
1302        FI;
1303        call scan; (* wczytanie srednika *)
1304   FI;
1305   (*+ CALL OUTREF(REFVAL); ++*)
1306    IF REFVAL=NONE THEN RAISE DEBERROR(15) FI;
1307    (* ODCZYTUJEMY DISPNR NOWEGO PUNKTU OBSERWACJI *)
1308    (* protdeb := dispnr of the object refval *)
1309    call db01ox(23,refval,offset,glovirt,relval,protdeb);
1310    (*+ WRITELN(LO," PR=",PROTDEB)++*);
1311 FI
1312 ELSE
1313 (* MOVE DO OBIEKTU OKRESLONEGO PRZEZ WYRAZENIE *)
1314 (*+ WRITELN(LO," MOVE DO OBIEKTU"); ++*)
1315 CALL FIND(TRUE);
1316 if refval=none then raise deberror(15) fi;
1317 IF PROTDEB<0 THEN RAISE DEBERROR(21) FI;
1318 i := idict(protdeb); UNITCASE:=prot(I);
1319 IF UNITCASE=/=RECT THEN C:=FINDCR(REFVAL) ELSE C:=NONE FI;
1320 FI;
1321 PROTNR:=PROTDEB;
1322 (* UAKTUALNIENIE LISTY BREAKL *)
1323 M:=NEW MOVEL(MA,PROTDEB,REFVAL,C); M.NEXT:=MOV; MOV:=M;
1324 (*+ WRITELN(LO," NOWY PUNKT OBSERWACJI"); ++*)
1325 (*+ CALL OUTREF(REFVAL); ++*)
1326 OBSADR:=REFVAL; (* adres obiektu bedacego punktem obserwacji *)
1327 CALL INF;
1328 END move;
1329
1330
1331 (*--------------------------------------------------*)
1332 (*                                                  *)
1333 (*             R E T     (RETURN)                   *)
1334 (*                                                  *)
1335 (* POWROT DO POPRZEDNIEGO PUNKTU OBSERWACJI         *)
1336 (*--------------------------------------------------*)
1337
1338 UNIT RET :PROCEDURE;
1339 VAR P1,POM :MOVEL;
1340 BEGIN
1341 CALL SCAN;
1342 (*+ CALL OUTREF(MOV.ADR); ++*)
1343 POM:= MOV;
1344 IF S=SAST and adres = adast THEN (* KASUJ WSZYSTKIE ZMIANY *)
1345           WHILE POM.NEXT=/=NONE DO MOV:=MOV.NEXT; KILL(POM); POM:=MOV OD;
1346           call scan
1347 ELSE IF S=SEMICOL THEN (* COFAMY SIE JEDEN KROK *)
1348           IF MOV.NEXT=NONE THEN RAISE DEBERROR(22) FI;
1349           MOV:=MOV.NEXT; KILL (POM)
1350      ELSE (* COFAMY SIE DO PUNKTU OBSERWACJI, KTORY OBOWIAZYWAL *)
1351           (* PRZED INSTRUKCJA MOVE O ETYKIECI = ADRES           *)
1352      IF S=/=sident THEN RAISE DEBERROR(1) FI;
1353         WHILE POM=/=NONE DO
1354            IF POM.MARK=ADRES THEN EXIT FI;
1355            POM:=POM.NEXT;
1356         OD;
1357         IF POM=NONE THEN RAISE DEBERROR(22) FI;
1358         P1:=MOV;
1359         WHILE MOV=/=POM DO MOV:=MOV.NEXT; KILL(P1); P1:=MOV OD;
1360         MOV:=MOV.NEXT; KILL (P1);
1361         call scan;
1362      FI
1363 FI;
1364 (* AKTUALIZUJEMY PUNKT OBSERWACJI  *)
1365 OBSADR:=MOV.ADR;
1366 PROTNR:=MOV.PROT;
1367 i := idict(protnr); unitcase := prot(i);
1368 CALL INF;
1369 END;
1370
1371 (*--------------------------------------------------------------------*)
1372 (*                                                                    *)
1373 (*                           F I N D                                  *)
1374 (*                                                                    *)
1375 (*--------------------------------------------------------------------*)
1376 (* PROCEDURA ODCZYTUJE WARTOSC ZMIENNEJ A DLA LEXPR ROWNIEZ JEJ ADRES *)
1377 (* WYNIKI ZWRACA NA ZMIENNYCH GLOBALNYCH protdeb,DISPNR,OFFSET,R      *)
1378 (* (LICZBA ARRAY OF ) I MODE - SPOSOB ADRESOWANIA                     *)
1379 (* WARTOSCI LICZBOWE NA INTVAL ,REFVAL ,CHAVAL,RELVAL W ZALEZNOSCI    *)
1380 (* OD TYPU WARTOSCI                                                   *)
1381 (*--------------------------------------------------------------------*)
1382
1383 UNIT FIND : PROCEDURE (LEXPR :BOOLEAN);
1384
1385 (*  mode = 0  - nie zmienna (stala)                    *)
1386 (*         1 - zmienna czytana jako offset w obiekcie  *)
1387 (*         2 -     j.w.                                *)
1388 (*         3 - zmienna czytana jako element tablicy    *)
1389 (*         4 - tablica czytana jako element tablicy    *)
1390 (*         5 - tablica czytana jako element w obiekcie *)
1391 (*         6 - tablica czytana jako offset w obiekcie  *)
1392
1393
1394 UNIT SZUKATR:PROCEDURE(ADRES:INTEGER;INOUT ADRPROT:INTEGER;
1395                         OUTPUT OFFSET,R:INTEGER;OUTPUT TAK:BOOLEAN);
1396
1397 (*  SZUKA W PROTOTYPIE O ADRESIE ADRPROT ZMIENNEJ O ADRESIE                 *)
1398 (*  W TABLICY HASH ROWNYM ADRes                                             *)
1399 (* WYNIK: OFFSET-OFFSET ZMIENNEJ,R-LICZBA ARRAYOF TYPU ZMIENNEJ,TAK-WSKAZUJE*)
1400 (*     CZY ZNALEZIONO ZMIENNA,ADRPROT- JEST TYPEM ZMIENNEJ*)
1401
1402 VAR L,ADR,PROTDEB:INTEGER;
1403
1404 BEGIN
1405 (*+WRITELN(LO," SZUATR ADRES=",ADRES,"ADRPROT = ",ADRPROT)++*);
1406 OFFSET:=(ADRES-1)/2;(*+WRITELN(LO," L1",OFFSET)++*);
1407 OFFSET:=OFFSET MOD 8;
1408 (*+  WRITELN(LO," L2",OFFSET)++*);
1409 OFFSET:=OFFSET+5;
1410 L:=ADRPROT+OFFSET;
1411 (*+ WRITELN(LO," L3",L)++*);
1412 ADR:=prot(L);
1413 (*+  WRITELN(LO," ADR",ADR)++*);
1414  (* ADR-POCZATEK LISTY HASHU*)
1415 DO
1416    r := prot(adr);
1417   (* r - kolejny element listy *)
1418    IF R = -100 THEN EXIT FI;
1419    IF ADRES = R THEN  (*TO JEST NASZA ZMIENNA*)
1420          ADR:=ADR+2;
1421          adrprot := -prot(adr);
1422          if adrprot <= 15 then (* to nie jest zmienna *)
1423              raise deberror(29) fi;
1424          (* zmienna lub stala *)
1425          EXIT
1426    ELSE ADR:=ADR+3
1427    FI
1428 OD;
1429 IF R =/= -100 THEN (* ZNALEZLISMY PROTOTYP ZMIENNEJ*)
1430      TAK:=TRUE;
1431     IF prot(ADRPROT)=VART THEN (*JEST TO ZMIENNA LUB PARAMETR*)
1432                ADR:=ADRPROT+1;
1433                R:= prot(ADR); (* R:= LICZBA ARRAY OF *)
1434                ADR:=ADR +1;
1435                ADRPROT:=prot(ADR);
1436                ADR:=ADR+1;
1437                OFFSET:=prot(ADR);
1438     ELSE  (*CASE=/=5*)   RAISE DEBERROR(29) FI;
1439 ELSE (* NIE ZNALEZLISMY ZMIENNEJ*)
1440 TAK:=FALSE
1441 FI;
1442 END SZUKATR;
1443
1444 UNIT SEP :FUNCTION:BOOLEAN;
1445 (* SPREWDZA CZY PRZECZYTANY PRZEZ SCANER SYMBOL JEST SEPERATOREM *)
1446 (*  DLA WYRAZENIA                                                *)
1447 BEGIN RESULT:= S=SEMICOL OR S=STO OR S=SRPAR OR S=SLPAR OR S=SCOM
1448            OR S=SART    OR S=SAST AND ADRES=adast OR S=SOR  OR S=SAND  OR S=SNOT
1449            OR S=SWHEN OR (S=1 AND ADRES=AWITH)
1450     OR PROTDEB<0 AND PROTDEB =/=FORT and protdeb <> cortt and protdeb <> proctt
1451 END sep;
1452
1453 VAR ADRPROT,A,LINDEKSOW : INTEGER,
1454     BOL,SL,POKROPCE:BOOLEAN,
1455     CURADR : ARRAYOF INTEGER,
1456     MIN : INTEGER;
1457
1458 BEGIN (* of find *)
1459 MIN:=1;
1460 (* ZAKLADAMY ,ZE JEST PRZECZYTANY SYMBOL *)
1461 (*PROTNR-NR PROTOTYPU DEBUGGERA AKTUALNEGO OBIEKTU*)
1462 IF S=/=sident THEN  MODE:=0;
1463    IF  LEXPR THEN RAISE DEBERROR(1) FI;
1464    IF S=SNONE THEN PROTDEB:=NONT;CALL SCAN;REFVAL:=NONE ;RETURN FI;
1465    IF S=SBOL THEN PROTDEB:=BOOLT;
1466                  IF ADRES=1 THEN INTVAL:=0 ELSE INTVAL:=-1 FI;
1467                  CALL SCAN; RETURN FI;
1468    IF S=SAST AND ADRES=admin THEN(* MINUS*) MIN:=-1;CALL SCAN FI;
1469    IF S=/=SCONST THEN RAISE DEBERROR(1) FI;
1470    CASE K
1471     WHEN kint : PROTDEB:=INTT;INTVAL:=ADRES*MIN;
1472     WHEN 4,5 :RAISE DEBERROR(23);
1473     WHEN kch : PROTDEB:=CHT;
1474                chaval := chr(adres);
1475    ESAC;
1476    CALL SCAN;
1477    RETURN;
1478 FI;
1479 A,PROTDEB:=PROTNR;
1480 CURADR:=OBSADR;
1481 DO
1482 (*+WRITELN(LO," OUTP IN DO ")++*);
1483 adrprot := idict(protdeb);
1484 IF SL THEN A:=PROTDEB FI; (*A JEST PROTOTYPEM ZMIENIAJACYM SIE TYLKO DLA
1485                             MODULOW PO SL*)
1486 SL:=FALSE;
1487 I:=ADRPROT+3; DISPNR:=prot(I);
1488 (*+WRITELN(LO," DISPNR = ",DISPNR," ADRPROT = ",ADRPROT)++*);
1489 (* ODCZYTANIE NR DISPLAYA Z PROTOTYPU AKT OBIEKTU*)
1490 CALL SZUKATR(ADRES, ADRPROT, OFFSET,  R, BOL);
1491    (*PO WYWOLANIU ADRPROT JEST NR TYPU PIERWOTNEGO LUB NR PROTOTYPU *)
1492    (*O ILE ZNALEZIONO ZMIENNA *)
1493    (* W P.P. ADRPROT SIE NIE ZMIENIA*)
1494 IF BOL THEN (*ZNALEZLISMY ZMIENNA*)
1495    POKROPCE:=FALSE;
1496    DO  (*PETLA DO WYPISANIA ZMIENNEJ a wlasciwie do rozpoznania wyr. do konca*)
1497    LINDEKSOW:=0;
1498    PROTDEB:=ADRPROT;
1499    IF R=0 AND NOT POKROPCE THEN (*JEST TO ZMIENNA NIEABLICOWA BEZ KROPKI*)
1500               (*+WRITELN(LO," ***LICZYMY WARTOSC PIERWSZEGO IDENT")++*);
1501               REFFVAL,REFVAL:=CURADR;
1502               CALL TAKEREF(OFFSET,ADRPROT);
1503               PROTDEB:=ADRPROT;
1504               MODE:=1;CALL SCAN;
1505    FI;
1506   IF R=0 AND POKROPCE THEN (*REFVAL JEST ADRESEM OBIEKTU PRZED KROPKA*)
1507             (*+WRITELN(LO," ***LICZYMY WARTOSC IDENT PO KROPCE")++*);
1508             REFFVAL:=REFVAL;
1509             CALL TAKEREF(OFFSET,ADRPROT);PROTDEB:=ADRPROT;
1510             MODE:=2;
1511             CALL SCAN;
1512    FI;
1513   IF R=/=0 AND NOT POKROPCE AND LINDEKSOW=0 THEN (* PIERWSZY INDEKS *)
1514           (*+WRITELN(LO," ***LICZYMY WARTOSC ZMIENNEJ INDEKSOWANEJ")++*);
1515           REFFVAL,REFVAL:=CURADR;
1516           CALL TAKEREF(OFFSET,1);
1517           MODE:=5;
1518           CALL SCAN;
1519           IF S=/=SLPAR THEN EXIT EXIT
1520             ELSE
1521             CALL SCAN;   (*CZYTA INDEKS,TO MUSI BYC STALA*)
1522             MIN:=1;
1523             IF S=SAST AND ADRES=admin THEN MIN:=-1;CALL SCAN FI;
1524             (*+  WRITELN(LO," ***CZYTA INDEKS")++*);
1525             IF S=SCONST AND K=3 THEN LINDEKSOW:=1;
1526                 (*+WRITELN(LO," ***LICZY WARTOSC TABLICY")++*);
1527                 REFFVAL:=REFVAL;
1528                 IF R=1 THEN CALL TAKEARR(ADRES*MIN,ADRPROT)
1529                        ELSE CALL TAKEARR(ADRES*MIN,1) FI;
1530                 OFFSET:=ADRES;MODE:=4;
1531                 (*+ WRITELN(LO," ***WARTOSC ZMIENNEJ INDEKSOWANEJ") ++*);
1532             ELSE RAISE DEBERROR(1)   (*INDEKS NIE JEST STALA*)
1533             FI;
1534             CALL SCAN;    (* OGRANICZNIKI LUB ")"*)
1535             IF S=/=SRPAR THEN (*S=/=")"*)
1536                          IF S =/=SCOM THEN RAISE DEBERROR(5) FI;
1537             ELSE (*S=")" *)
1538                (*+WRITELN(LO," ***PRZECZYTALISMY PRAWY NAWIAS")++*);
1539                IF R=1 THEN MODE:=3 FI;
1540                CALL SCAN;
1541                IF SEP THEN R:=R-LINDEKSOW FI;
1542             FI
1543      FI;   (*S=/=52 0R ADRES=/=3 *)
1544 FI;
1545
1546 IF R>1 OR R=1 AND POKROPCE THEN
1547 DO    (*PETLA OBSLUGUJE ZMIENNE TABLICOWE PO KROPCE LUB O WIECEJ NIZ
1548         JEDNYM INDEKSIE*)
1549          (*S- WARTOSC INDEKSU*)
1550      CALL SCAN;
1551      MIN:=1;
1552      IF S=SAST AND ADRES=admin (*MINUS*) THEN MIN:=-1; CALL SCAN FI;
1553      IF S=SCONST AND K=kint THEN LINDEKSOW := LINDEKSOW+1;
1554         IF LINDEKSOW=R THEN
1555            REFFVAL:=REFVAL;CALL TAKEARR(ADRES,ADRPROT);
1556            MODE:=4;OFFSET:=ADRES;
1557         ELSE
1558            REFFVAL:=REFVAL;
1559            CALL TAKEARR(ADRES, 1);       (*ADRES=WARTOSC(S)*)
1560            MODE:=3;
1561            (* TYP DANY JAKO 1 OZNACZA TYP REFERENC.*)
1562        FI;
1563      ELSE RAISE DEBERROR(1) (*INDEKS NIE JEST STALA*)
1564      FI;
1565      CALL SCAN;       (*OGRANICZNIKI*)
1566      IF S=SRPAR THEN IF R=LINDEKSOW THEN MODE:=3 FI;
1567      CALL SCAN ; IF SEP THEN R:=R-LINDEKSOW;EXIT FI;
1568      ELSE
1569                  IF LINDEKSOW < R THEN
1570                    IF S =/= SCOM THEN RAISE DEBERROR(5) FI
1571                  ELSE RAISE DEBERROR(6);  (*ZA DLUGIE WYRAZENIE INDEKSOWE *)
1572                  FI
1573      FI;
1574 if lindeksow=r then exit fi;
1575 OD;
1576 FI;
1577   if protdeb > 0 or protdeb = fort or protdeb = proctt or protdeb = cortt then
1578     (* TRZEBA ZNALESC PROTOTYP TYPU AKTUALNEGO *)
1579     IF REFVAL=NONE THEN RAISE DEBERROR(15) FI;
1580     (* protdeb := protnumber of the actual type *)
1581     call db01ox(24,refval,offset,glovirt,relval,protdeb);
1582    (*+ WRITELN(LO," PROTDEB =",PROTDEB);++*)
1583   fi;
1584 IF SEP THEN EXIT EXIT FI;
1585 IF S=SDOT THEN
1586 IF R=/=0 AND LINDEKSOW=/=R OR PROTDEB <0 THEN RAISE DEBERROR(24) FI;
1587          (*+ WRITELN(LO," ***CZYTAMY KROPKE") ++*);
1588          POKROPCE:=TRUE;
1589          CALL SCAN; (*CZYTA ZMIENNA PO KROPCE*)
1590          (*+ WRITELN (LO," ***CZYTAMY IDENT PO KROPCE")++*);
1591          adrprot := idict(protdeb);
1592          CALL SZUKATR(ADRES,ADRPROT,OFFSET,R,BOL);
1593          (*ZNAJDUJE ZMIENNA ZAPISANA W ADRES I BEDACA
1594            ATRYBUTEM PROTOTYPU ADRPROT*)
1595          IF NOT BOL THEN RAISE DEBERROR(7)  FI;
1596          IF R=/=0 THEN (* ATRYBUTEM JEST TABLICA *)
1597            CALL SCAN;
1598            IF S=/=SLPAR THEN
1599               IF S=/=SEMICOL and S=/=STO THEN RAISE DEBERROR(10) FI;
1600               MODE:=6;EXIT EXIT;
1601            FI;
1602         REFFVAL:=REFVAL;
1603         CALL TAKEREF(OFFSET,1);
1604         MODE:=4;
1605         FI;
1606 FI
1607 OD
1608 ELSE (*NIE ZNALEZLISMY ZMIENNEJ, TRZEBA ISC DO PREFIKSU*)
1609    adrprot := idict(protdeb);
1610    I:=ADRPROT+4; (* ADRPROT+4 =ADRES PROTOTYPU PREFIKSU *)
1611    PROTDEB:=prot(I);
1612    (*+WRITELN(LO," **** PROTDEB",PROTDEB)++*);
1613    IF PROTDEB<=0 (*NIE MA PREFIKSU WIEC IDZIEMY PO SL*) THEN
1614    IF A=0 THEN (* MODUL GLOWNY *) RAISE DEBERROR(9) FI;
1615    SL:=TRUE;
1616    (*+WRITELN(LO," A =",A)++*);
1617    adrprot := idict(a);
1618    I:=ADRPROT+1; (* BUFFP(I) = NUMER PROTUTYPU SL *)
1619       IF UNITCASE=RECT THEN RAISE DEBERROR(9) FI;
1620       (* SZUKAMY DALEJ TYLKO WTEDY, GDY NIE JEST TO REKORD *)
1621       PROTDEB:=prot(I);
1622       (* curadr := address of SL of the object curadr *)
1623       glovirt := curadr;
1624      call db01ox(25,glovirt,offset,curadr,relval,intval);
1625    (*+WRITELN(LO," +++ PROTDEB",PROTDEB)++*);
1626 FI
1627 FI
1628 OD;
1629 END FIND;
1630
1631 (* ------------------------------------------------------------------- *)
1632
1633 UNIT FINDCR:FUNCTION( INPUT C1:ARRAYOF INTEGER):ARRAYOF INTEGER;
1634 (* SZUKA GLOWY COROUTINY DLA INSTANCJI O ADRESIE C1 *)
1635 VAR J:INTEGER;
1636 BEGIN
1637   (*+WRITELN(LO," FINDCR");++*)
1638 DO
1639   IF C1=NONE THEN EXIT  FI;;
1640   (*+ CALL OUTREF(C1); ++*)
1641   RESULT:=C1;
1642   (*  i := dispnr of the object c1 *)
1643   call db01ox(26,c1,offset,refval,relval,i);
1644   (*+ WRITELN(LO," I=",I); ++*)
1645   IF I=0 THEN EXIT FI;
1646   J:=I;
1647   DO (* SZUKAMY W CIAGU PREFIKSOWYM COROUTINY *)
1648      j := idict(j);
1649       (*+ WRITELN(LO," J=",J); ++*)
1650       IF prot(J)=11 THEN EXIT EXIT FI;
1651       J:=J+4; J:=prot(J);
1652       (*+ WRITELN(LO," J=",J); ++*)
1653       IF J<=0 THEN EXIT FI;
1654   OD;
1655   (* PORUSZAMY SIE PO DL *)
1656   (* c1 := DL of the object c1 *)
1657   glovirt := c1;
1658   call db01ox(27,glovirt,offset,c1,relval,intval);
1659   IF RESULT=C1 THEN RESULT:=NONE ; EXIT FI;
1660   (* ZAPETLENIE DL WSKAZUJE NA OBIEKT STERMINOWANY *)
1661 OD;
1662 END;
1663
1664 (*-------------------------------------------------------*)
1665 (*                                                       *)
1666 (*             C O N D                                   *)
1667 (*                                                       *)
1668 (* SPRAWDZENIE WARUNKU BOOLOWSKIEGO PRZY WARUNKOWYM      *)
1669 (* PUNKCIE PRZERYWAJACYM                                 *)
1670 (*-------------------------------------------------------*)
1671 UNIT COND :FUNCTION:BOOLEAN;
1672 VAR BL:BOOLEAN;
1673 BEGIN
1674 CALL SCAN;WHILE S=/=SWHEN DO CALL SCAN OD;
1675 (* ROZPOCZYNAMY INTERPRETACJE WARUNKU  *)
1676 RESULT:=TRUE;
1677 DO (* PETLA PO "AND" *)
1678    CALL SCAN;
1679    IF S = SNOT THEN CALL SCAN;RESULT:=NOT COND1 AND RESULT
1680    ELSE IF S=/=SLPAR THEN RESULT:=COND1 AND RESULT
1681         ELSE
1682            (* PETLA PO "OR" *)
1683           DO BL:=FALSE;CALL SCAN;
1684              IF S= SNOT THEN CALL SCAN;BL:=BL OR NOT COND1
1685                         ELSE BL:=BL OR COND1 FI;
1686              IF S=SRPAR THEN CALL SCAN; EXIT FI;
1687              IF S =/= SOR THEN RAISE DEBERROR(25) FI;
1688           OD;
1689         RESULT:=RESULT AND BL;
1690         FI
1691      FI;
1692      IF ADRES=AWITH OR S=SEMICOL THEN EXIT FI;
1693      IF S =/= SAND THEN RAISE DEBERROR(26) FI;
1694      IF NOT RESULT THEN EXIT FI;
1695 OD
1696 END cond;
1697
1698 UNIT COND1 : FUNCTION:BOOLEAN;
1699 (* WARUNEK - WYRAZENIE *)
1700 VAR OPER :INTEGER;
1701 BEGIN
1702 CALL FIND(FALSE);
1703 (* ZAKLADAMY ,ZE JEST PRZECZYTANY SYMBOL *)
1704 (*+WRITELN(LO," ",PROTDEB,INTVAL,RELVAL,CHAVAL,MODE) ++*);
1705 IF S=/=SART THEN
1706     IF PROTDEB=BOOLT THEN RESULT:=INTVAL=/=0
1707     ELSE RAISE DEBERROR(8) FI
1708 ELSE OPER:=ADRES;PROTDEB1:=PROTDEB;MODE1:=MODE;REFVAL1:=REFVAL;
1709      INTVAL1:=INTVAL;CHAVAL1:=CHAVAL;RELVAL1:=RELVAL;
1710      CALL SCAN;
1711      CALL FIND(FALSE);
1712      (*+WRITELN(LO," ",PROTDEB,INTVAL,RELVAL,CHAVAL,MODE) ++*);
1713      IF (PROTDEB=INTT OR PROTDEB=RELT) AND MODE<4 AND
1714         (PROTDEB1=INTT OR PROTDEB1=RELT) AND MODE1<4 THEN
1715         IF PROTDEB=INTT THEN RELVAL:=INTVAL FI;
1716         IF PROTDEB1=INTT THEN RELVAL1:=INTVAL1 FI;
1717         CASE OPER
1718           WHEN adeq :RESULT:=RELVAL1=RELVAL;
1719           WHEN adne :RESULT:=RELVAL1=/=RELVAL;
1720           WHEN adgt :RESULT:=RELVAL1>RELVAL ;
1721           WHEN adge :RESULT:=RELVAL1>=RELVAL ;
1722           WHEN adlt :RESULT:=RELVAL1<RELVAL;
1723           WHEN adle :RESULT:=RELVAL1<=RELVAL;
1724        ESAC
1725      ELSE
1726        IF (PROTDEB=NONT OR PROTDEB>0 OR MODE>4) AND
1727           (PROTDEB1=NONT OR PROTDEB1>0 OR MODE1>4)
1728            OR   PROTDEB1=PROTDEB AND MODE1<4 AND MODE<4 THEN
1729          IF PROTDEB=BOOLT THEN
1730            CASE OPER
1731               WHEN adeq: RESULT:=INTVAL1=INTVAL;
1732               WHEN adne: RESULT:=INTVAL1=/=INTVAL;
1733               OTHERWISE RAISE DEBERROR(8)
1734             ESAC
1735           ELSE
1736             IF PROTDEB=CHT THEN
1737               CASE OPER
1738                 WHEN adeq:RESULT:=CHAVAL1=CHAVAL;
1739                 WHEN adne:RESULT:=CHAVAL1=/=CHAVAL;
1740                 OTHERWISE RAISE DEBERROR(8)
1741               ESAC
1742                 ELSE
1743                   CASE OPER
1744                     WHEN adeq:RESULT:=REFVAL1=REFVAL;
1745                     WHEN adne:RESULT:=REFVAL1=/=REFVAL;
1746                     OTHERWISE RAISE DEBERROR(8)
1747                   ESAC
1748                  FI
1749               FI
1750       ELSE RAISE DEBERROR(8) FI
1751    FI
1752 FI
1753 END COND1;
1754
1755
1756 (*===========================================*)
1757 UNIT INTLIN :PROCEDURE;
1758
1759 (* INTERPRETACJA LINII        *)
1760
1761 VAR POM: MOVEL;
1762
1763 BEGIN
1764 MA := 0;
1765 DO
1766 IF S= SEMICOL THEN CALL SCAN FI;
1767 IF S=sident THEN (* IDENTYFIKATOR *)
1768   IF ADRES=AGO THEN call goo; exit else
1769   IF ADRES=AREPORT THEN CALL REPORT  ;EXIT ELSE
1770   IF ADRES=AREMOVE THEN CALL REMOVE  ;call scan;EXIT ELSE
1771   IF ADRES=ASTORE THEN CALL STORE  ;call scan;EXIT ELSE
1772   IF ADRES=AMOVE THEN CALL MOVE;EXIT ELSE
1773   IF ADRES=ASSIGN THEN CALL ASSIG;EXIT ELSE
1774   IF ADRES=ADELETE THEN CALL DEL  ;call scan;EXIT ELSE
1775   IF ADRES=ADECLARE THEN CALL DECLARE;call scan;EXIT ELSE
1776   IF ADRES=AMARK THEN call mark;call scan; exit else
1777 MA :=ADRES; CALL SCAN;
1778 IF S=/= SCOLON THEN RAISE DEBERROR(4)
1779 FI;CALL SCAN;
1780 FI FI FI FI FI FI FI FI FI
1781 ELSE (* SLOWO KLUCZOWE *)
1782    CASE S
1783    WHEN SOUTPUT  : CALL OUTP ; EXIT ;
1784    WHEN SWRITE   : ECHO:=NOT ECHO ;call scan;EXIT;
1785    WHEN SBREAK  : CALL BRE ;EXIT;
1786    WHEN SRETURN: CALL RET; EXIT ;
1787    WHEN SCALL   : CALL CAL ;EXIT;
1788    WHEN SSTEP : call scan;
1789                 SINGLESTEP:=NOT SINGLESTEP;EXIT ;
1790    OTHERWISE RAISE DEBERROR(3); EXIT
1791   ESAC
1792 FI;
1793 OD;
1794 END;
1795
1796 HANDLERS
1797 WHEN DEBERROR :
1798             if nr<>0 then
1799             WRITE(CO," !!! ERROR NR ",NR, "  -  ");
1800                  case nr
1801          when 1: writeln(co,"IDENTIFIER EXPECTED");
1802          when 2: writeln(co,"INTEGER CONSTANT EXPECTED");
1803          when 3: writeln(co,"INCORRECT INSTRUCTION NAME");
1804          when 4: writeln(co,"':' EXPECTED");
1805          when 5: writeln(co,"',' EXPECTED");
1806          when 6: writeln(co,"TOO MANY INDICES");
1807          when 7: writeln(co,"IDENTIFIER AFTER '.' MUST BE AN ATTRIBUTE");
1808          when 8: writeln(co,"INCORRECT CONDITION");
1809          when 9: writeln(co,"UNDECLARED IDENTIFIER");
1810          when 10: writeln(co,"';' EXPECTED");
1811          when 11: writeln(co,"'TO' EXPECTED");
1812          when 12: writeln(co,"UNRECOGNIZED INSTRUCTION");
1813          when 13: writeln(co,"UNRECOGNIZED BANK");
1814          when 14: writeln(co,"ERROR IN REPORT PARAMETER");
1815          when 15: writeln(co,"REFERENCE TO NONE");
1816          when 16: writeln(co,"TOO MANY BREAK POINTS");
1817          when 17: writeln(co,"BREAK POINT DECLARED TWICE");
1818          when 18: writeln(co,"UNRECOGNIZED BREAK POINT");
1819          when 19: writeln(co,"INCOMPATIBLE TYPES IN ASSIGN STATEMENT");
1820          when 20: writeln(co,"TRY TO OUTPUT A REFERENCE TYPE VARIABLE");
1821          when 21: writeln(co,"MOVE ARGUMENT IS NOT OF A REFERENCE TYPE");
1822          when 22: writeln(co,"UNRECOGNIZED MOVE INSTRUCTION");
1823          when 23: writeln(co,"REAL AND STRING CONSTANTS ARE FORBIDDEN");
1824          when 24: writeln(co,"'.' AFTER AN ARRAY");
1825          when 25: writeln(co,"'OR' EXPECTED");
1826          when 26: writeln(co,"'AND' EXPECTED");
1827          WHEN 27: WRITELN(co,"';' OR '*' OR IDENTIFIER EXPECTED");
1828          when 28: writeln(co,"'->' OR '=>' OR '>>' OR '*>' EXPECTED");
1829          when 29: writeln(co,"VARIABLE EXPECTED");
1830          when 30: writeln(co,"TRY TO GO OUTSIDE THE MAIN BLOCK");
1831          when 31: writeln(co,"EMPTY PREFIX");
1832          when 32: writeln(co,"MOVE -> IN COROUTINE HEAD");
1833          when 33: writeln(co,"INDEX OUT OF RANGE");
1834          when 34: writeln(co,"WRONG PARAMETER OF GO");
1835          when 35: writeln(co,"MOVE IN RECORD OBJECT");
1836          when 36: writeln(co,"MOVE '->' IN TERMINATED OBJECT");
1837          when 37: writeln(co,"THIS IS NOT A COROUTINE");
1838          when 38: writeln(co,"WRONG MARK");
1839          when 39: writeln(co,"TRY TO DELETE CURRENT BREAK POINT");
1840       esac;
1841       fi;
1842
1843  CALL NEWLIN;
1844       WIND;
1845 END HANDLERS;
1846
1847
1848 (*=============================================*)
1849 BEGIN  (***** INTERPR ******)
1850 PROTNR:=dispnr;
1851 (*+CALL OUTREF(CADR);++*)
1852 OBSADR:=CADR;
1853 IF CBR=NONE THEN HELP:=NONE
1854 ELSE
1855     if cbr.condtxt =/= none then call outex(cbr.condtxt);
1856        if not cond then return fi;
1857     fi;
1858     help := cbr.ins;
1859     IF CBR.MARK =/=0 THEN WRITE(CO," ");
1860                      IF ECHO THEN WRITE(LO," ") FI;
1861                      CALL WRID(CBR.MARK, 10)
1862     FI;
1863 FI;
1864 if first then  (* first interrupt *)
1865    writeln(co,' ');
1866    writeln(co,"                        LOGLAN DEBUGGER ");
1867    writeln(co,' ');
1868 if echo then  writeln(lo,' ');
1869                writeln(lo,"                         LOGLAN DEBUGGER ");
1870                  writeln(lo,' '); fi;
1871    first := false;
1872    writeln(co,"INITIAL BREAK AT LINE ",linenr)
1873 else
1874    writeln(co,t9,linenr);
1875    if echo then writeln(lo,t9,linenr) fi;
1876 fi;
1877
1878 mov := new movel(0,protnr,cadr,findcr(cadr));
1879 (*+WRITELN(LO," DISPNR      :",DISPNR)++*);
1880 CALL INF;
1881 CALL NEWLIN;
1882 (*   SCANER CZYTA TEREAZ TEREAZ OD NOWEJ LINII       *)
1883 WHILE NOT STP DO
1884 IF HELP =/= NONE THEN (* WYKONANIE INSTRUKCJI ZWIAZANYCH *)
1885    CALL OUTEX(HELP.TXT);
1886    CALL WRLIN(HELP.TXT);
1887    CALL SCAN;
1888    CALL INTLIN;
1889    (* NASTEPNA INSTRUKCJA Z LISTY *)
1890    HELP:=HELP.NEXT
1891 ELSE
1892  call sccd01ox(5,i,i,ctxt); (* prompt *)
1893   CALL SCAN;WHILE S=SEMICOL DO
1894                   call sccd01ox(5,i,i,ctxt);
1895                   call scan
1896                             od;
1897   CALL INTEX(ctxt);
1898   IF ECHO THEN CALL WRLIN(ctxt) FI; CALL INTLIN;
1899 FI;
1900 OD;
1901
1902 END    (***** INTERPR ******);
1903
1904 UNIT RUNERROR :PROCEDURE;
1905 BEGIN
1906 (* ODTWARZMY SRODOWISKO MODULU W KTORYM WYSTAPIL BLAD *)
1907 (* OBIEKT TEN JEST WSKAZYWANY PRZEZ DL HANDLERA       *)
1908   (* dispnr := number of interrupted object,
1909      obsadr := address of interrupted object *)
1910    call db01ox(29,glovirt,linenr,obsadr,gloreal,dispnr);
1911    cadr := obsadr;
1912  (* ccor - address of an active coroutine head *)
1913   call db01ox(0,ccor,dispnr,glovirt,gloreal,dispnr);
1914 (* linenr = line of the last break = (sometimes) line of the error occurrence *)
1915   write(co,t28,linenr);
1916   if echo then write(lo,t28,linenr) fi;
1917   cind := 0;
1918   call interpr;
1919   call endrun
1920 END  runerror;
1921
1922 HANDLERS
1923 WHEN ACCERROR : writeln(co,t1); call runerror;
1924 WHEN CONERROR : writeln(co,t2); call runerror;
1925 WHEN LOGERROR : writeln(co,t3); call runerror;
1926 WHEN TYPERROR : writeln(co,t4); call runerror;
1927 WHEN SYSERROR : writeln(co,t5); call runerror;
1928 WHEN NUMERROR : writeln(co,t6); call runerror;
1929 WHEN MEMERROR : writeln(co,t7); call runerror;
1930 OTHERS : WRITELN(CO,t8);CALL RUNERROR;
1931 END HANDLERS;
1932
1933 BEGIN (**** MAIN DEBUGGER *****)
1934   CALL INICBR;
1935 (*+WRITELN(LO," RETURN AFTER INICBR ")++*);
1936   inner;
1937   call db01oe;  (* end of block prefixed by LOGDEB *)
1938 END logdeb;
1939 (*******************************************************************)
1940 begin
1941   pref logdeb 
1942 (*$d+*)
1943 (*$l+*) 
1944   block
1945     var ix : integer;
1946     begin
1947       ix := 100;
1948     break;
1949     writeln("  ok ");
1950   end;  
1951 end
1952