sources/pass1/debug.f

   1 C    Loglan82 Compiler&Interpreter
   2 C     Copyright (C) 1981-1993 Institute of Informatics, University of Warsaw
   3 C     Copyright (C)  1993, 1994 LITA, Pau
   4 C
   5 C     This program is free software; you can redistribute it and/or modify
   6 C     it under the terms of the GNU General Public License as published by
   7 C     the Free Software Foundation; either version 2 of the License, or
   8 C     (at your option) any later version.
   9 C
  10 C     This program is distributed in the hope that it will be useful,
  11 C     but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 C     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  13 C     GNU General Public License for more details. File: LICENSE.GNU
  14 C  ===============================================================
  15
  16       subroutine ts1
  17       implicit integer(a-z)
  18 c  wolana po it1
  19 c  wpisuje do tablicy prs nazwe i numer linii prototypu
  20 c  prs(2*i-1) = nazwa, prs(2*i) = numer linii prototypu i
  21 c  prototypy liczone od isfin do lpmem
  22       common /debpr/ prs(600)
  23       common /BLANK/ com(278),
  24      x          lmem,lpmem,irecn,isfin,
  25      x          com1(20),
  26      x          mem(5000)
  27
  28       do 100 i=isfin,lpmem
  29       k = mem(i)
  30       p = mem(k)
  31 c  k - adres slowa zerowego prototypu o numerze i
  32       j = i-isfin+1
  33 c  nazwa
  34       prs(2*j-1) = -100
  35 c blok i handler nie maja nazwy
  36       if(p.ne.1.and.p.ne.8) prs(2*j-1) = mem(k+10)
  37 c  numer linii
  38       prs(2*j) = mem(k+9)
  39 100   continue
  40       call dsw
  41       return
  42       end
  43
  44       subroutine TS2
  45       implicit integer(a-z)
  46 c   przebieg wolany po DSW
  47 c   wypelnia prototypy debuggera prawie do konca
  48 c   DISPNR(3) i dla zmiennych OFFSET (3) = adres prototypu kompilacjnego
  49 c
  50 c  -----------------------------------------------------
  51 c                    BUDOWA PROTOTYPOW
  52 c
  53 c   -1     nazwa modulu ( hash ze scannera)
  54 c    0            case
  55 c    1     SL - numer prot. debuggera w IDICT
  56 c    2     numer linii z poczatkien definicji
  57 c    3           dispnr
  58 c    4     prefiks - numer prot. debuggera w IDICT
  59 c    5       mala tablica hash nazw atrybutow
  60 c    .         (jak w DSW)
  61 c   12
  62 c   13     elementy listy hash i prototypy zmiennych
  63 c   .         i stalych
  64 c   .
  65 c  ----------------------------------------------------
  66 c
  67 c                    ZMIENNA
  68 c
  69 c    0            case
  70 c    1     liczba array of
  71 c    2     typ - numer prototypu debuggera w IDICT
  72 c    3     offset
  73 c    4     SL - numer prototypu debuggera w IDICT
  74 c
  75 c   UWAGA: typ: typ formalny = -10, typ prymitywny = -typ kompilacyjny
  76 c               typ uniwersalny = 0, typ process/coroutine = -typ komp.
  77 c
  78 c  ---------------------------------------------------
  79 c
  80 c                   STALA
  81 c
  82 c    0             case
  83 c    1     typ - numer prototypu ( dla typu prymitywnego = -typ komp.)
  84 c    2     adres stalej w tablicy stalych
  85 c
  86 c   UWAGA: procedura, funkcja i typ formalny nie maja prototypow, ale
  87 c          wystepuja w tablicy hash (malej)
  88 c
  89 c  --------------------------------------------------
  90 c
  91 c   CASE:    1 - block, 2 - klasa, 3 - procedura, 4 - funkcja
  92 c            5 - zmienna
  93 c            7 - funkcja form., 8 - proc. form,
  94 c            9 - stala
  95 c            10 - process, 11 - coroutina, 12 - rekord
  96 c            14 - handler, 15 - sygnal
  97 c
  98 c  --------------------------------------------------
  99 c
 100 c                 ELEMENT LISTY HASH
 101 c
 102 c   0   nazwa ze scannera
 103 c   1                NT/H/C  - 3 bity
 104 c   2   numer prototypu debuggera: dla unitow - w IDICT, dla zmiennych
 105 c                                   i stalych = -adres bezp. protrotypu
 106 c                    proc/fun/typ formalny = -7,-8,-10
 107 c
 108 c ----------------------------------------------------
 109
 110 c-------------------------------------------------------
 111 c    budowa pliku 21:
 112 c         hash(8000), idict(500), ind,prot(ind)
 113 c-------------------------------------------------------
 114
 115       common /BLANK/ com(8000)
 116       call deb2
 117       call AL1
 118       return
 119       end
 120
 121       subroutine deb2
 122 c  glowna procedura tworzaca prototypy debuggera
 123       implicit integer (a-z)
 124       logical btest
 125       common /BLANK/ com(278),
 126      x          lmem,lpmem,irecn,isfin,
 127      x          com2(7),
 128      x          nrcor, nrproc,
 129      x          com3(5),
 130      x          nblus,
 131      x          com1(5),
 132      x          mem(8000)
 133
 134       common /pr/ prot(5000),ind
 135 c   prot - tablica na prototypy debuggera
 136 c   ind - ostatnie zajete miejsce w tablicy
 137
 138       common/debpr/prs(600)
 139 c prs zawiera nazwy i numery linii kolejnych prototypow
 140 c  prs(2*i-1) = nazwa, prs(2*i) = nr. linii prot. i-tego
 141 c  prototypy liczone sa od isfin do lpmem
 142
 143       dimension  idict(500),chang(500)
 144 cps   dimension  idict(300),chang(300)
 145 c  idict(i) - adres w prot prototypu o numerze disp. i-1
 146 c  chang(i) - numer z parsera prototypu o numerze w idict=i
 147
 148       data  idict/500*0/
 149 cps   data  idict/300*0/
 150
 151 c  curr - pierwsze wolne miejsce w tablicy prot
 152 c  zw - miejsce slowa zerowego biezacego prototypu
 153
 154        ind = 0
 155        curr = 1
 156 c przepelnienie ?
 157        if(lpmem-isfin+1 .gt. 500) call mdrop(199)
 158 cps    if(lpmem-isfin+1 .gt. 300) call mdrop(199)
 159
 160 c-------  budowa tablicy chang
 161       p = nblus
 162       i = 1
 163 10    continue
 164       k = mem(p)
 165 c  pomijamy formalne i sygnaly
 166       if(btest(k,4).or.btest(k,5)) go to 11
 167       if(btest(k,7)) go to 11
 168       chang(i) = findnr(p)
 169       i = i+1
 170  11   p = mem(p+2)
 171       if(p.ne.0) go to 10
 172 c-----------
 173
 174       k = nblus
 175       i = 1
 176 c-----------  glowna petla
 177 5000   continue
 178 c  k - adres slowa zerowego prototypu kompilacyjnego
 179        call zerow(k,case1)
 180 c  sygnal nie ma prototypu
 181        if(case1.eq.15) go to 5001
 182 c  formalne tez nie maja prototypow
 183        if(case1.eq.7.or.case1.eq.8.or.case1.eq.-10) go to 5001
 184        zw = curr+1
 185        idict(i) = zw
 186        call getm(4)
 187 c  wypelnienie pierwszych 4-ech slow opisu
 188 c  nazwa
 189        j = chang(i)
 190        prot(curr) = prs(2*j-1)
 191 c  case
 192        prot(zw) = case1
 193 c  SL
 194        p = mem(k-1)
 195        prot(zw+1) = findsc(p)-1
 196 c  numer linii
 197        prot(zw+2) = prs(2*j)
 198        call getm(10)
 199        curr = curr+14
 200        if(case1.eq.14) go to 12
 201 c  handler nie ma prefiksu
 202        id = mem(k+21)
 203         j = findsc(id)
 204        if(j.eq.0) go to 12
 205        prot(zw+4) = j-1
 206   12   prot(zw+3) = k
 207 c  k - ident. opisu wstawiany w miejsce przyszlego dispnr
 208 c  wypelniamy tablice hash'u
 209 c  curr - teraz bedzie oznaczlo pierwsze wolne miejsce do tworzenia
 210 c         elementow listy
 211
 212         curr1 = curr
 213         do 101 j=5,12
 214         prot(zw+j) = curr
 215         t = k+j+5
 216         l = mem(t)
 217   102   if(l.eq.0) go to 151
 218 c  miejsce na element listy
 219         curr = curr+3
 220         call getm(3)
 221         l = mem(l+3)
 222         go to 102
 223   151   call getm(1)
 224         curr = curr+1
 225  101    continue
 226
 227 c   teraz beda wypelniane elementy listy i tworzone nowe prototypy
 228 c   curr - pierwsze wolne miejsce do tworzenia prototypow
 229 c   curr1 - wskaznik do chodzenia po elementach listy
 230
 231         do 100 j=5,12
 232         t = k+j+5
 233         l = mem(t)
 234  30     if(l.eq.0) go to 150
 235 c  l - poiter do nastepnego elementu listy
 236 c  element listy hash'u
 237 c  nazwa ze scannera
 238         prot(curr1) = mem(l)
 239 c  NT/H/C
 240         prot(curr1+1) = mem(l+1)
 241         id = mem(l+2)
 242 c  id opisu w ipmem
 243         call zerow(id,case)
 244         if(case.eq.7.or.case.eq.8.or.case.eq.-10.or.case.eq.15) goto 250
 245         if(case.eq.5) go to 200
 246         if(case.eq.9) go to 400
 247
 248 c  unit - nie bedzie nowego opisu
 249         prot(curr1+2) = findsc(id)-1
 250         go to 90
 251
 252 c  zmienna
 253  200    t = mem(l+1)
 254         if(btest(t,2)) go to 300
 255 c  nowy opis zmiennej
 256         prot(curr1+2) = -curr
 257 c  adres bezposredni prototypu debuggera
 258         call getm(5)
 259 c  wpisanie  numeru opisu do mem(l+1)
 260         mem(l+1) = curr*8
 261 c  case
 262         prot(curr) = case
 263         prot(curr+1) = mem(id-4)
 264 c    process/ coroutine systemowe ?
 265         p = mem(id-3)
 266         t = -p
 267         if(p.eq.nrproc.or.p.eq.nrcor) go to 240
 268         call zerow(p,t)
 269         if(t.ne.2.and.t.lt.10) go to 240
 270 c  typ klasowy - nie prymitywny i nie formalny
 271         t = findsc(mem(id-3))-1
 272  240    prot(curr+2) = t
 273 c  id prototypu w ipmem zamiast offsetu
 274         prot(curr+3) = id
 275 c  sl
 276         prot(curr+4) = findsc(mem(id-1))-1
 277         curr = curr+5
 278         go to 90
 279 c  zmienna not taken
 280 300     t = ishft(t,-8)
 281         prot(curr1+2) = -t
 282         go to 90
 283
 284 c  stala - nowy opis
 285  400   call getm(3)
 286        prot(curr1+2) = -curr
 287 c  -adres bezposredni prototypu debuggera
 288        prot(curr) = case
 289 c  typ prymitywny
 290        call zerow(mem(id-3),t)
 291        prot(curr+1) = t
 292 c  ident. stalej w tablicy stalych
 293        prot(curr+2) = mem(id-1)
 294        curr = curr+3
 295        go to 90
 296
 297 c  proc/fun/typ formalne - nie ma prototypu
 298  250   if(case.ne.-10) case = -case
 299        prot(curr1+2) = case
 300
 301 c  nastepny element listy
 302  90    curr1 = curr1+3
 303        l = mem(l+3)
 304        go to 30
 305 c  straznik
 306  150   curr1 = curr1+1
 307  100   continue
 308
 309        i = i+1
 310 5001   continue
 311        k = mem(k+2)
 312        if(k.ne.0) go to 5000
 313 c-------------------- koniec wypelniania prototypow
 314
 315 c  skasowanie zapamietanej uprzednio w MEM informacji dla zmiennych
 316
 317       id = X'0007'
 318       do 111 i = isfin, lpmem
 319       k = mem(i)
 320       do 112 j = 1,8
 321       t = k+j+9
 322       l = mem(t)
 323  110  if(l.eq.0) go to 112
 324 c  wyzerowanie bitow 3-15
 325       mem(l+1) = iand(mem(l+1),id)
 326       l = mem(l+3)
 327       go to 110
 328  112  continue
 329  111  continue
 330
 331 c  wypisanie idict
 332       call out(idict,500)
 333 cps   call out(idict,300)
 334 c  wypisanie ind - ostatnie zajete miejsce w prot
 335       call out(ind,1)
 336 c  wypisanie prot do miejsca ind
 337       call out(prot,ind)
 338       return
 339       end
 340
 341       subroutine getm(n)
 342       implicit integer(a-z)
 343       common /pr/ prot(5000), ind
 344 c  sprawdza, czy jest jeszcze miejsce w PROT
 345 c  ind - ostatnie zajete
 346       ind = ind+n
 347       if(ind.le.5000) return
 348 c  przepelnienie - za duzo prototypow
 349       call mdrop(41)
 350       return
 351       end
 352
 353       subroutine out(tab,n)
 354       implicit integer(a-z)
 355       dimension tab(n)
 356       call ffwrite_ints(21, tab, n)
 357       return
 358       end
 359
 360       subroutine zerow(kk,id)
 361       implicit integer(a-z)
 362       logical btest
 363       common /BLANK/ com(302), mem(6890)
 364 c  odkodowuje slowo zerowe o adresie kk, wynik na id (case)
 365 c  dla typow prymitywnych wynik = -kk
 366 c  dlA typu uniwersalnego wynik = 0
 367
 368       k = mem(kk)
 369 c  uniwersalny ?
 370       if(k.eq.4) go to 300
 371 c  prymitywny ?
 372       if(btest(k,3)) go to 5
 373       if(btest(k,1).and..not.btest(k,2)) go to 10
 374       if(btest(k,2).and..not.btest(k,1).and..not.btest(k,0)) go to 100
 375       if(btest(k,2).and.btest(k,0).and..not.btest(k,1)) go to 30
 376       if(btest(k,1).and.btest(k,2).and.btest(k,0)) go to 40
 377       if(btest(k,2).and.btest(k,1).and..not.btest(k,0)) go to 90
 378       if(.not.btest(k,2).and..not.btest(k,1).and.btest(k,0)) go to 100
 379
 380 c  typ prymitywny
 381 5     id = -kk
 382       return
 383 c   klasa lub rekord
 384  10   id = 12
 385       if(btest(k,0)) id = 2
 386       return
 387 c  process
 388  30   id = 10
 389       return
 390 c  coroutine
 391  40   id = 11
 392       return
 393 c  typ formalny
 394  90   id = -10
 395       return
 396 c  stala
 397  150  id = 9
 398       return
 399 c  zmienna
 400  140  id = 5
 401       return
 402 c  block
 403  160  id = 1
 404       return
 405 c  funkcja formalna
 406  110  id = 7
 407       return
 408 c  proc. formalna
 409  120   id = 8
 410       return
 411 c   funkcja
 412  170  id = 4
 413       return
 414 c   procedura
 415  180  id = 3
 416       return
 417 c  handler
 418  190  id = 14
 419       return
 420 c  sygnal
 421  155  id = 15
 422       return
 423 c  nie typ
 424 100   continue
 425       if(btest(k,7).and..not.btest(K,6).and..not.btest(k,5).and.
 426      x btest(k,4))go to 140
 427       if(btest(k,7)) go to 200
 428       if(btest(k,6)) go to 140
 429       if(btest(k,5).and..not.btest(k,4)) go to 110
 430       if(btest(k,5).and.btest(k,4)) go to 120
 431       if(.not.btest(k,5)) go to 220
 432 c  stala/signal
 433  200  continue
 434       if(.not.btest(k,6).and..not.btest(k,5).and..not.btest(k,4))
 435      x go to 150
 436       if(.not.btest(k,6).and.btest(k,5).and.btest(k,4)) go to 155
 437 c procedura/funkcja/blok
 438  220  continue
 439       if(.not.btest(k,10).and..not.btest(k,9)) go to 160
 440       if(.not.btest(k,10).and.btest(k,9)) go to 170
 441       if(btest(k,10).and..not.btest(k,9).and..not.btest(k,8))
 442      x go to 180
 443       if(btest(k,10).and.btest(k,9).and.btest(k,8)) go to 190
 444 c  typ uniwersalny
 445 300   id=0
 446       return
 447       end
 448
 449       integer function findnr(id)
 450       implicit integer(a-z)
 451       common /BLANK/ com(278),
 452      x          lmem,lpmem,irecn,isfin,
 453      x          com1(20),
 454      x          mem(7890)
 455       if(id.eq.0) go to 1010
 456       do 1000 i = isfin,lpmem
 457       k = mem(i)
 458 c  adres slowa zerowego
 459       if(k.ne.id) go to 1000
 460       findnr = i-isfin+1
 461       return
 462 1000  continue
 463 1010  findnr = 0
 464       return
 465       end
 466
 467       integer function findsc(id)
 468       implicit integer(a-z)
 469       common /BLANK/ com(278),
 470      x          com2(18),
 471      x          nblus,
 472      x          com1(5),
 473      x          mem(7890)
 474       logical btest
 475       p = nblus
 476       i = 1
 477  100  continue
 478       if(p.eq.0) go to 120
 479       k = mem(p)
 480 c  formalne i sygnaly sa pomijane w numeracji
 481 c  formalne
 482       if(btest(k,4).or.btest(k,5)) go to 111
 483 c  sygnal
 484       if(btest(k,7)) go to 111
 485       if(id.eq.p) go to 110
 486       i = i+1
 487 111   p = mem(p+2)
 488       go to 100
 489 120   findsc = 0
 490       return
 491 110   findsc = i
 492       return
 493       end
 494