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
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.
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 ===============================================================
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,
31 c k - adres slowa zerowego prototypu o numerze i
35 c blok i handler nie maja nazwy
36 if(p.ne.1.and.p.ne.8) prs(2*j-1) = mem(k+10)
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
50 c -----------------------------------------------------
53 c -1 nazwa modulu ( hash ze scannera)
55 c 1 SL - numer prot. debuggera w IDICT
56 c 2 numer linii z poczatkien definicji
58 c 4 prefiks - numer prot. debuggera w IDICT
59 c 5 mala tablica hash nazw atrybutow
62 c 13 elementy listy hash i prototypy zmiennych
65 c ----------------------------------------------------
71 c 2 typ - numer prototypu debuggera w IDICT
73 c 4 SL - numer prototypu debuggera w IDICT
75 c UWAGA: typ: typ formalny = -10, typ prymitywny = -typ kompilacyjny
76 c typ uniwersalny = 0, typ process/coroutine = -typ komp.
78 c ---------------------------------------------------
83 c 1 typ - numer prototypu ( dla typu prymitywnego = -typ komp.)
84 c 2 adres stalej w tablicy stalych
86 c UWAGA: procedura, funkcja i typ formalny nie maja prototypow, ale
87 c wystepuja w tablicy hash (malej)
89 c --------------------------------------------------
91 c CASE: 1 - block, 2 - klasa, 3 - procedura, 4 - funkcja
93 c 7 - funkcja form., 8 - proc. form,
95 c 10 - process, 11 - coroutina, 12 - rekord
96 c 14 - handler, 15 - sygnal
98 c --------------------------------------------------
102 c 0 nazwa ze scannera
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
108 c ----------------------------------------------------
110 c-------------------------------------------------------
112 c hash(8000), idict(500), ind,prot(ind)
113 c-------------------------------------------------------
115 common /BLANK/ com(8000)
122 c glowna procedura tworzaca prototypy debuggera
123 implicit integer (a-z)
125 common /BLANK/ com(278),
126 x lmem,lpmem,irecn,isfin,
134 common /pr/ prot(5000),ind
135 c prot - tablica na prototypy debuggera
136 c ind - ostatnie zajete miejsce w tablicy
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
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
149 cps data idict/300*0/
151 c curr - pierwsze wolne miejsce w tablicy prot
152 c zw - miejsce slowa zerowego biezacego prototypu
157 if(lpmem-isfin+1 .gt. 500) call mdrop(199)
158 cps if(lpmem-isfin+1 .gt. 300) call mdrop(199)
160 c------- budowa tablicy chang
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
176 c----------- glowna petla
178 c k - adres slowa zerowego prototypu kompilacyjnego
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
187 c wypelnienie pierwszych 4-ech slow opisu
190 prot(curr) = prs(2*j-1)
195 prot(zw+1) = findsc(p)-1
197 prot(zw+2) = prs(2*j)
200 if(case1.eq.14) go to 12
201 c handler nie ma prefiksu
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
217 102 if(l.eq.0) go to 151
218 c miejsce na element listy
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
234 30 if(l.eq.0) go to 150
235 c l - poiter do nastepnego elementu listy
236 c element listy hash'u
240 prot(curr1+1) = mem(l+1)
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
248 c unit - nie bedzie nowego opisu
249 prot(curr1+2) = findsc(id)-1
254 if(btest(t,2)) go to 300
256 prot(curr1+2) = -curr
257 c adres bezposredni prototypu debuggera
259 c wpisanie numeru opisu do mem(l+1)
263 prot(curr+1) = mem(id-4)
264 c process/ coroutine systemowe ?
267 if(p.eq.nrproc.or.p.eq.nrcor) go to 240
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
273 c id prototypu w ipmem zamiast offsetu
276 prot(curr+4) = findsc(mem(id-1))-1
286 prot(curr1+2) = -curr
287 c -adres bezposredni prototypu debuggera
290 call zerow(mem(id-3),t)
292 c ident. stalej w tablicy stalych
293 prot(curr+2) = mem(id-1)
297 c proc/fun/typ formalne - nie ma prototypu
298 250 if(case.ne.-10) case = -case
301 c nastepny element listy
312 if(k.ne.0) go to 5000
313 c-------------------- koniec wypelniania prototypow
315 c skasowanie zapamietanej uprzednio w MEM informacji dla zmiennych
318 do 111 i = isfin, lpmem
323 110 if(l.eq.0) go to 112
324 c wyzerowanie bitow 3-15
325 mem(l+1) = iand(mem(l+1),id)
333 cps call out(idict,300)
334 c wypisanie ind - ostatnie zajete miejsce w prot
336 c wypisanie prot do miejsca ind
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
347 if(ind.le.5000) return
348 c przepelnienie - za duzo prototypow
353 subroutine out(tab,n)
354 implicit integer(a-z)
356 call ffwrite_ints(21, tab, n)
360 subroutine zerow(kk,id)
361 implicit integer(a-z)
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
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
385 if(btest(k,0)) id = 2
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
434 if(.not.btest(k,6).and..not.btest(k,5).and..not.btest(k,4))
436 if(.not.btest(k,6).and.btest(k,5).and.btest(k,4)) go to 155
437 c procedura/funkcja/blok
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))
443 if(btest(k,10).and.btest(k,9).and.btest(k,8)) go to 190
449 integer function findnr(id)
450 implicit integer(a-z)
451 common /BLANK/ com(278),
452 x lmem,lpmem,irecn,isfin,
455 if(id.eq.0) go to 1010
456 do 1000 i = isfin,lpmem
458 c adres slowa zerowego
459 if(k.ne.id) go to 1000
467 integer function findsc(id)
468 implicit integer(a-z)
469 common /BLANK/ com(278),
480 c formalne i sygnaly sa pomijane w numeracji
482 if(btest(k,4).or.btest(k,5)) go to 111
484 if(btest(k,7)) go to 111
485 if(id.eq.p) go to 110