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