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 ===============================================================
18 IMPLICIT INTEGER (A-Z)
20 COMMON /BLANK/ COM(278),
21 X LMEM , LPMEM , IRECN , ISFIN , LPMSYS, LPML , LPMF ,
22 X NRINT , NRRE , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
23 X NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
24 X LOCAL , OWN , OBJECT,
27 C COM - OBSZAR KOMUNIKACYJNY STRUMIENI
28 C LMEM - (=32000) ROZMIAR CALEJ PAMIECI GLOWNEJ
29 C LPMEM - PODZIAL PAMIECI NA CZESCI IPMEM I ISMEM
30 C IRECN - INDEKS SZCZYTU STOSU STALYCH REAL
31 C ISFIN - INDEKS SZCZYTU SLOWNIKA PROTOTYPOW
33 C LPMSYS - INDEKS PIERWSZEGO SLOWA W IPMEM OBSZARU NIEPRZEZ-
34 C NACZONEGO NA PROTOTYPY SYSTEMOWE
35 C LPML - INDEKS PIERWSZEGO SLOWA OBSZARU WOLNEGO W IPMEM
36 C LPMF - INDEKS OSTATNIEGO SLOWA WOLNEGO OBSZARU W IPMEM
38 C IDENTYFIKATORY PROTOTYPOW SYSTEMOWYCH
39 C NRINT - IDENTYFIKATOR PROTOTYPU INTEGER
45 C NRTEXT - STRING (TEXT)
46 C NRUNIV - IDENTYFIKATOR PROTOTYPU UNIWERSALNEGO
47 C NATTR - IDENTYFIKATOR PSEUDO-ATRYBUTU (Z NUMEREM -1)
48 C NRNONE - IDENTYFIKATOR PROTOTYPU TYPU NONE (UNIWERSALNY
50 C NBLSYS - IDENTYFIKATOR BLOKU SYSTEMOWEGO
51 C NBLUS - BLOKU GLOWNEGO UZYTKOWNIKA
53 C INSYS - FLAGA SPOSOBU REZERWACJI (PRZEZ MGETM) PAMIECI
54 C W IPMEM - .TRUE. JESLI REZERWACJA W CZESCI SYSTE-
56 C LOCAL - FLAGA DOSTEPU DO OBIEKTOW - 2 JESLI OBIEKT
57 C BYL LOKALNY, 1 - GDY Z SL, 0 - GDY Z BLOKU GLOWNEGO
58 C OWN - FLAGA DOSTEPU DO OBIEKTOW - .TRUE. JESLI OBIEKT NIE
59 C POCHODZI Z PREFIKSOW (TYLKO Z WLASCIWEGO OBIEKTU)
60 C OBJECT - PROTOTYP OBIEKTU, Z KTOREGO POCHODZIL OSTATNIO
61 C SZUKANY IDENTYFIKATOR (OBIEKT POCHODZACY Z CIAGU SL)
64 cdeb ----------- added ----------------------
65 c new common blockfor the debugger
66 common /debug/ deb,breakt(500),brnr,maxbr
68 c deb = true - compilation with the debugger
69 c breakt - array of static break points
70 c brnr - index in breakt
71 c maxbr - maximal number of static break points
72 cdeb ----------------------------------------
74 COMMON /MJLMSG/IERC,MSG
79 cdsw DATA IDENT /4HWAN /
99 IMPLICIT INTEGER (A-Z)
101 common /jf/jfname(72),jf
103 common /combuf/ ind, length, bigbuf(16000)
108 COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),BUF(7),ON,BUFOUT(256),
110 COMMON /LISTING/ OUTSTR(265)
111 COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,POSTR(265),STATUS
114 O S, ADRES, K, SCOMA, SDOT, SEMICOL,
115 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
116 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
117 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
118 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
119 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
120 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
121 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
122 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
123 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
124 O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
125 A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
126 B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
127 C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
128 D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
129 E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
130 F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
131 G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
134 H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
135 I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
136 J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
137 K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
138 L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
139 M WRITE, WRITELN, WBOUND, UNICAL,
141 O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
142 P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
143 Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
144 R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
145 S HASH(8000), M, NAME(10), NLAST, NL,
147 U TRANS1(13,13), TRANS2(13,13), B0, B(70),
148 V SKOK0, SKOK(70), KK, MM, STAN, STAN1,
149 W AUX, K1, SY, SY1, NU, EXP,
150 X SIGN, INTPART, FRAC, OKEY, FRACT, NB,
151 Y TL, BYTE, TEXT(20),
152 Z TOP, IN, NEKST, STACK(500)
163 cdeb ----------- added ----------------------
164 c new common blockfor the debugger
165 common /debug/ deb,breakt(500),brnr,maxbr
167 c deb = true - compilation with the debugger
168 c breakt - array of static break points
169 c brnr - index in breakt
170 c maxbr - maximal number of static break points
172 cdeb ----------------------------------------
176 EQUIVALENCE (W(1),WAND)
178 cdsw kod spacji ascii
179 data data1hex /x'2020'/
183 c nadanie wartosci zmiennej deb - czy zapalona opcja S
185 if(btest(c0m(2),13)) deb = .true.
192 c unit 16 - roboczy listing (sequential )
194 C --- WRITE LISTING OPTION FLAG
195 call ffwrhex(16, c0m(2))
199 cdsw *********** new file **************
200 c unit 18 - roboczy,sekwencyjny do kodu posredniego
203 c ------ unit 14 (buf) - kod posredni (direct)
211 C DATA BUFOR,LN,LP,MAX /85*4Z2020,0,81,81/
217 if (jfname(jf).eq.'.') go to 9998
218 if (jfname(jf).eq.' ') goto 9996
220 9996 if(jf+4.gt.70) goto 9991
226 jfname(jf+4) = int2char(0)
227 9991 jfname(70) = int2char(0)
228 c unit 17 - input (sequential)
229 call ffopen(17,jfname(1))
236 jfname(jf+4)=int2char(0)
237 call ffcreat(15, jfname(1))
247 900 if(ord(bufor(i)).ne.ord(ichar(' '))) goto 1000
249 IF (I.GT.MAX) GOTO 800
251 1000 IF (BUFOR(I ).NE.ICHAR('P').AND.BUFOR(I).NE.ICHAR('p'))
253 IF (BUFOR(I+1).NE.ICHAR('R').AND.BUFOR(I+1).NE.ICHAR('r'))
255 IF (BUFOR(I+2).NE.ICHAR('O').AND.BUFOR(I+2).NE.ICHAR('o'))
257 IF (BUFOR(I+3).NE.ICHAR('G').AND.BUFOR(I+3).NE.ICHAR('g'))
259 IF (BUFOR(I+4).NE.ICHAR('R').AND.BUFOR(I+4).NE.ICHAR('r'))
261 IF (BUFOR(I+5).NE.ICHAR('A').AND.BUFOR(I+5).NE.ICHAR('a'))
263 IF (BUFOR(I+6).NE.ICHAR('M').AND.BUFOR(I+6).NE.ICHAR('m'))
265 IF (BUFOR(I+7).EQ.1) GOTO 1100
266 if(ord(bufor(i+7)) .ne. ord(ichar(' '))) goto 2500
268 IF (I.LT.MAX) GOTO 1200
271 1200 if(ord(bufor(i)).ne.ord(ichar(' '))) goto 1300
273 IF (I.GT.MAX) GOTO 1150
277 1350 IF ((ORD(BUFOR(I)).LT.10).OR.(ORD(BUFOR(I)).GT.35)) GOTO 1500
279 IF (BUFOR(I).GE.ICHAR('0').AND.BUFOR(I).LE.ICHAR('9')) GOTO 1400
283 C INITIALIZE STRINGS OUTPUT TO LFILE WITH EMPTY STRING
288 C write length of empty string
289 call ffwrite_ints(15, 0, 1)
290 C write empty string itself
291 call ffwrite_ints(15, 0, 1)
295 if (btest(c0m(2), 12)) call ffwrite_ints(15, 0, 1)
299 C INITIATE THE TABLE OF REAL CONSTANTS
300 C THE TWO INITIAL CONSTANTS, WHICH ALWAYS RESIDE IN THE TABLE ARE
307 IF (IEND.LT.BEGIN) GOTO 3500
310 3500 IF (S.EQ.70) CALL ERROR(191)
312 3600 IF (S.EQ.SBLOCK) GOTO 4000
314 IF (S.EQ.SBEGIN) GOTO 4000
315 IF (S.EQ.SUNIT) GOTO 4000
316 IF (S.EQ.SVAR) GOTO 4000
317 IF (S.EQ.SCONS) GOTO 4000
318 IF (S.EQ.SEND) GOTO 4000
319 IF (S.EQ.SPRCD) GOTO 4000
320 IF (S.EQ.SFUNCT) GOTO 4000
321 IF (S.EQ.SCLASS) GOTO 4000
322 IF (S.EQ.SIDENT) GOTO 3550
323 IF (S.EQ.STAKEN) GOTO 4000
324 IF (S.EQ.SCLOSE) GOTO 4000
325 IF (S.LT.25) GOTO 4000
326 IF (S.NE.70) GOTO 3550
328 4000 IF (I.EQ.1) CALL ERROR(137)
335 implicit integer(a-z)
337 cdeb ----------- added ----------------------
338 c new common blockfor the debugger
339 common /debug/ deb,breakt(500),brnr,maxbr
341 c deb = true - compilation with the debugger
342 c breakt - array of static break points
343 c brnr - index in breakt
344 c maxbr - maximal number of static break points
345 cdeb ----------------------------------------
349 common /jf/ jfname(72), jf
355 c file na hash, breakt, keys
359 jfname(jf+4) = int2char(0)
360 call ffcreat(21, jfname(1))
365 implicit integer(a-z)
367 cdeb ----------- added ----------------------
368 c new common blockfor the debugger
369 common /debug/ deb,breakt(500),brnr,maxbr
371 c deb = true - compilation with the debugger
372 c breakt - array of static break points
373 c brnr - index in breakt
374 c maxbr - maximal number of static break points
375 cdeb ----------------------------------------
377 c wstawia do breakt linie o numerze l
382 if(l.eq.breakt(i)) return
385 if(brnr.ge.maxbr) return
386 c nadmiarowe punkty lamiace sa ignorowane
393 implicit integer(a-z)
394 common /BLANK/ com(302),
395 x hash(8000), dow(13), keys(200),
398 cdeb ----------- added ----------------------
399 c new common blockfor the debugger
400 common /debug/ deb,breakt(500),brnr,maxbr
402 c deb = true - compilation with the debugger
403 c breakt - array of static break points
404 c brnr - index in breakt
405 c maxbr - maximal number of static break points
406 cdeb ----------------------------------------
408 c wypisuje na plik 21 tablice hash
409 call ffwrite_ints(21, hash, 8000)
410 cps call ffwrite_ints(21, keys, 200)
411 cps call ffwrite_ints(21, brnr, 1)
412 cps call ffwrite_ints(21, breakt, brnr)
420 IMPLICIT INTEGER (A-Z)
424 equivalence (endmsg(1), endms1)
425 COMMON /LISTING/ OUTSTR(265)
426 COMMON /STREAM/ ERRFLG,LINE,IBUF2(265),IBUF3(7),ON,JUNK(259)
427 COMMON /BUFF/ INSTR(265),BUFOR(85),LP,LN,MAX,JNK(266)
428 COMMON /BLANK/ C0M(4)
431 data endms1 /'end of parsing -------------------------'/
435 IF (BTEST(C0M(2),15)) GOTO 1
436 call ffwrite_char(16, '0')
439 1 call ffwrite_char(16, '1')
442 call ffwrite(16, endmsg(1), 40)
443 c end of line - write CR/LF
444 call ffwrite_char(16, int2char(13))
445 call ffwrite_char(16, int2char(10))
446 3 IF (BUFOR(1).EQ.2) RETURN
455 C ORGANIZATION OF THE STACK:
456 C STACK(TOP) - STACK TOP FOR THE INVOKING MODULE
457 C STACK(TOP+1) - NUMBER OF THE INVOKING MODULEY
458 C STACK(TOP+2) - NUMBER OF THE RETURN POINT TO THE INVOKING MODULE
459 C THE LOCAL VARIABLES, IF ANY ARE USED IN THE MODULE, ARE ALLOCATED ON THE
460 C STACK STARTING FROM TOP+3 UP.
461 C AN INVOKING MODULE HAS TO APPROPRIATELY INCREMENT THE TOP OF THE STACK
462 C RESPECTING ITS LOCAL VARIABLES, THEN STORE ITS NUMBER AND RETURN POINT
463 C ON THE STACK AND TRANSFER THE CONTROL TO THE SUPERVISING PROGRAM (RETURN).
464 C AFTER RETURN FROM THE CALLED PROGRAM THE STACK TOP IS APPROPRIATELY
465 C RESET BY THE SUPERVISING PROGRAM.
466 C THE PATTERN OF TRANSFERRING CONTROL:
467 C NEXT= N - CONTROL TO BE PASSED TO THE MODULE NUMBER N;
468 C NEXT= 0 - RETURN TO THE CALLER.
469 C UPON ENTRY TO A SUBPROGRAM
470 C PARAMETER - KEEPS THE NUMBER OF PLACE FROM WHICH THE COMPUTATIONS HAVE TO
472 IMPLICIT INTEGER (A-Z)
475 O S, ADRES, K, SCOMA, SDOT, SEMICOL,
476 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
477 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
478 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
479 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
480 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
481 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
482 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
483 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
484 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
485 O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
486 A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
487 B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
488 C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
489 D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
490 E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
491 F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
492 G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
495 H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
496 I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
497 J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
498 K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
499 L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
500 M WRITE, WRITELN, WBOUND, UNICAL,
502 O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
503 P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
504 Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
505 R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
510 Z TOP, IN, NEXT, STACK(500),
516 C NOTE: THE FIRST CALL OF E11, I.E. FOR THE MAIN BLOCK, IS NON-STANDARD.
517 C IN IS ASSIGNED VALUE 5 INSTEAD OF STANDARD (1). THIS FACILITATES
518 C THE TEXT ANALYSIS OF A PROGRAM WHICH DOESN-T START WITH 'BLOCK'.
521 IF (S.EQ.70) GOTO 10025
522 IF (S.NE.SBLOCK) CALL ERROR(122)
523 CALL OUTPUT(WBLOCK,ISFIN)
526 C E11 IS CALLED WITH THE PARAMETER (TOP+4)=0, WHICH MEANS THAT NO PREFIX
527 C IS SPECIFIED. E11 ANALYSES THE ENTIRE SYNTACTICAL UNIT.
554 IF (NEXT.EQ.0) GOTO 1002
556 GOTO (10,20,30,40,50,60,70,80,90,100,110,120,130),NEXT
557 1002 IN = STACK(TOP+2)
560 IF (TOP.GT.0) GOTO 1001
566 C E1 - RECOGNIZES BOOLEAN EXPRESSION
568 C STACK(TOP+3) - NUMBER OF RECOGNIZED AND-S
569 C STACK(TOP+4) - NUMBER OF RECOGNIZED OR-S
570 C STACK(TOP+5) - RELATION CODE
571 C STACK(TOP+6) - 1 IFF 'NOT' HAS BEEN ENCOUNTERED, 0 IN THE OPPOSITE CASE
572 IMPLICIT INTEGER (A-Z)
575 O S, ADRES, K, SCOMA, SDOT, SEMICOL,
576 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
577 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
578 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
579 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
580 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
581 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
582 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
583 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
584 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
585 O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
586 A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
587 B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
588 C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
589 D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
590 E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
591 F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
592 G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
595 H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
596 I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
597 J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
598 K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
599 L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
600 M WRITE, WRITELN, WBOUND, UNICAL,
602 O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
603 P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
604 Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
605 R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
610 Z TOP, IN, NEXT, STACK(500),
612 cdsw INTEGER WEOF0,WEOF1,WEOLN0,WEOLN1
613 cdsw DATA WEOF0,WEOF1,WEOLN0,WEOLN1/79,80,85,86/
615 GOTO (10,20,30,40),IN
617 411 STACK(TOP+4)=STACK(TOP+4)+1
618 IF (STACK(TOP+4).GT.1) CALL SCAN
620 420 STACK(TOP+3)=STACK(TOP+3)+1
621 IF (STACK(TOP+3).GT.1) CALL SCAN
623 IF (S.NE.SNOT) GOTO 400
626 400 IF (S.NE.STRUE) GOTO 401
627 C A BOOLEAN CONSTANT HAS BEEN ENCOUNTERED. ITS WRITING OUT IS SPLIT
628 C INTO TWO STAGES BECAUSE THE VALUE TRUE (-1) CANNOT STAND FOR THE
629 C SECOND PARAMETER OF THE WRITING PROCEDURE (OUTPUT).
630 CALL OUTPUT(WCNSTB,-1)
631 CALL OUTPUT(1-ADRES,-1)
634 401 IF (S.NE.SEOFSI) GOTO 402
635 IF (ADRES.NE.1) ADRES=7
637 STACK(TOP+5)=SEOFSI+18+ADRES
639 IF (S.NE.SLEFT) GOTO 444
640 STACK(TOP+5)=STACK(TOP+5)+1
645 C CALL OBJECTEXPRESSION /E3/
646 40 IF (S.EQ.SRIGHT) GOTO 430
650 444 CALL OUTPUT(STACK(TOP+5),-1)
655 C CALL E2 - ARITHMETIC EXPRESSION
657 20 IF (S.NE.SRELAT) GOTO 300
658 IF (ADRES.GT.2) GOTO 22
659 C RECOGNIZED RELATION IS OR IN
662 IF (S.EQ.SCOROUT) GOTO 205
663 IF (S.EQ.SIDENT) GOTO 21
667 205 CALL OUTPUT(WIDENT,K)
668 C FOR "PROCESS", "COROUTINE" THE HASH ADDRESS IS PASSED BY K
670 21 CALL OUTPUT(WIDENT,ADRES)
672 CALL OUTPUT(WRELAT,STACK(TOP+5))
674 22 STACK(TOP+5)=ADRES
678 C NEXT CALL FOR E2 - ARITHMETIC EXPRESSION
680 30 CALL OUTPUT(WRELAT,STACK(TOP+5))
681 300 IF (STACK(TOP+6).EQ.1) CALL OUTPUT(WNOT,-1)
682 IF (STACK(TOP+3).GT.1) CALL OUTPUT(WAND,-1)
683 IF (S.EQ.SAND) GOTO 420
684 IF (STACK(TOP+4).GT.1) CALL OUTPUT(WOR,-1)
685 IF (S.EQ.SOR) GOTO 411
691 C E2 - RECOGNIZES ARITHMETIC EXPRESSION
693 C STACK(TOP+3) - MULTIPLICATIVE (HIGHER PRIORITY) OPERATOR
694 C STACK(TOP+4) - ADDITIVE (LOWER PRIORITY) OPERATOR
695 C STACK(TOP+5) - CONTAINS 1 IF SIGN CHANGE IS REQUIRED, 0 IF NOT,
696 C STACK(TOP+6) - CONTAINS 1 IF "ABS" HAS OCCURRED,
697 C STACK(TOP+7) - KEEPS LOWER/UPPER OPERATOR KIND,
698 C STACK(TOP+8) - INCLUDES 1 IF THE VARIABLE AFTER LOWER/UPPER IS IN
700 C NOTE: THE LAST TWO FIELDS ARE ONLY USED IF THE PERTINET
701 C OPERATOR HAS BEEN ENCOUNTERED. THUS THIS PROCEDURE MAY
702 C BE INVOKED WITH DIFFERENT SIZES OF THE AREA FOR LOCAL
703 C VARIABLES, DEPENDING ON THE CONTENTS.
705 IMPLICIT INTEGER (A-Z)
708 O S, ADRES, K, SCOMA, SDOT, SEMICOL,
709 1 SCOLON, SLEFT, SRIGHT, SBECOME, STAR, SRELAT,
710 2 SEOF, SIDENT, SCONST, SAND, SARRAY, SARROF,
711 3 SATTACH, SBEGIN, SBLOCK, SBOOL, SCALL, SCASE,
712 4 SCLASS, SCLOSE, SCONS, SCOPY, SCOROUT, SDETACH,
713 5 SDIM, SDO, SDOWN, SELSE, SEND, SESAC,
714 6 SEXIT, SEXTERN, SFI, SFOR, SFUNCT, SIF,
715 7 SINNER, SINPUT, SINT, SKILL, SLOCK, SNEW,
716 8 SNONE, SNOT, SOD, SOR, SORIF, SOTHER,
717 9 SOUTPUT, SPREF, SPRCD, SQUA, SREAD, SRESUME,
718 O SRETURN, STEP, STOP, STAKEN, STHEN, STHIS,
719 A STO, STYPE, SUNIT, SVAR, SVIRTUAL, SWAIT,
720 B SWHEN, SWHILE, SWRIT, SWRITLN, STRUE, SALL,
721 C WAND, WARRAY, WASSIGN, WASSCON, WATTACH, WBLOCK,
722 D WCALL, WCASE, WCASEL, WCOMA, WCNSTB, WCNSTC,
723 E WCNSTI, WCNSTN, WCNSTR, WCNST, WCOPY, WDETACH,
724 F WDOT, WDOWNTO, WEOF, WESAC, WFIN, WFIRST,
725 G WFOREND, WFORVAR, WFROM, WIDENT, WIFFALS, WIFTRUE
728 H WINNER, WINSTREND,WJUMP, WKILL, WLABEL, WLEFT,
729 I WLOCK, WLOW, WLSE, WNEW, WNEWARRAY,WNOT,
730 J WOPERAT, WOPT, WOR, WOTHER, WPREF, WPRIM,
731 K WQUA, WREAD, WRELAT, WRESUME, WRETURN, WRIGHT,
732 L WSTART, WSTEP, WSTOP, WTHIS, WTO, WAIT,
733 M WRITE, WRITELN, WBOUND, UNICAL,
735 O LMEM, LPMEM, IRECN, ISFIN, LPMSYS, LPML,
736 P LPMF, NRINT, NRRE, NRBOOL, NRCHAR, NRCOR,
737 Q NRPROC, NRTEXT, NRUNIV, NATTR, NRNONE, NBLSYS,
738 R NBLUS, NEMPTY, INSYS, LOCAL, OWN, OBJECT,
743 Z TOP, IN, NEXT, STACK(500),
745 EQUIVALENCE (WEOF,WSIGN)
746 DATA SLOWUP,WLOWER /79,64/
748 C**********************************************************************
749 C****** SLOWUP, WLOWER, WUPPER SHOUD BE PUT INTO BLANK
750 C****** COMMON AT THE NEAREST OPPORTUNITY.
751 C****** *********** 13.01.1982 *************
752 C**********************************************************************
753 GOTO (10,20,30,40,50),IN
755 C INITIALIZE LOCAL VARIABLES
761 C CHECK FOR MINUS (-)
763 IF (S.NE.STAR) GOTO 100
764 IF (ADRES.GT.4) GOTO 80
765 GOTO (100,100,70,75),ADRES
772 C PLUS (+) ENCOUNTERED
777 C THE EXPRESSION STARTS WITH * , / , DIV , MOD
783 C START OF ANALYSING A SUM COMPONENT
785 110 IF (STACK(TOP+4).NE.0) CALL SCAN
787 C START OF ANALYSING A MULTIPLICATIVE COMPONENT
789 120 IF (STACK(TOP+3).NE.0) CALL SCAN
793 IF (S.NE.STAR) GOTO 122
794 IF (ADRES.NE.1) GOTO 122
801 C CHECK FOR A CONSTANT, IF AFFIRMATIVE THEN RECOGNIZE ITS TYPE
803 122 IF (S.NE.SCONST) GOTO 130
804 GOTO (210,210,125,127,123,128),K
808 123 CALL OUTPUT(WCNSTR,ADRES)
814 125 CALL OUTPUT(WCNSTI,ADRES)
820 127 CALL OUTPUT(WCNST,ADRES)
825 128 CALL OUTPUT(WCNSTC,ADRES)
828 C CHECK AGAINST AN OCCURRENCE OF A STRING/CHAR CONSTANT WITHIN AN EXPRESSION
830 IF (STACK(TOP+3)+STACK(TOP+4)+STACK(TOP+5)+STACK(TOP+6).NE.0)
834 C CHECK IF THE MULTIPLICATIVE COMPONENT IS AN EXPRESSION
836 130 IF (S.NE.SLEFT) GOTO 160
842 C CALL E1 - BOOLEAN EXPRESSION
843 C AFTER RETURN CHECK IF THE EXPRESSION IS TERMINATED BY THEW RIGHT
846 20 IF (S.EQ.SRIGHT) GOTO 140
851 160 IF (S.EQ.SLOWUP) GOTO 170
852 IF (S.EQ.SIGN) GOTO 165
856 C CALL E3 - OBJECTEXPRESSION TO ANALYSE THE VARIABLE
857 C RETURN TO LABEL 30 BELOW - JUMP OPTIMIZATION
861 C "SIGN" ENCOUNTERED, ARITHMETIC EXPRESSION SHOULD FOLOW.
868 C CALL E1 TO ANALYSE THE EXPRESSION
870 50 CALL OUTPUT(WSIGN,-1)
873 C LOWER/UPPER HAS BEEN ENCOUNTERED. WE HAVE TO REMEMBER WHICH ONE AND CALL
874 C OBJECTEXPRESSION TO ANALYSE THE VARIABLE. THE LOCAL VARIABLE FIELD IS
875 C INCREASED TO 5 VARIABLES.
877 170 STACK(TOP+7)=ADRES
880 IF (S.NE.SLEFT) GOTO 172
881 C THERE WAS A LEFT PARANTHESIS
887 C CALL E3 - OBJECT EXPRESSION, AFTER RETURN THE OPERATOR TYPE
888 C (LOWER/UPPER) IS TO BE WRITTEN
889 40 CALL OUTPUT(WLOWER+STACK(TOP+7)-1,-1)
890 IF (STACK(TOP+8).EQ.0) GOTO 30
891 IF (S.EQ.SRIGHT) GOTO 44
892 C NO MATCHING RIGHT PARANTHESIS
897 180 IF (STACK(TOP+6).NE.1) GOTO 185
899 C ABS BEFORE THE MULTIPLICATIVE COMPONENT
901 CALL OUTPUT(WOPERAT,1)
903 185 IF (STACK(TOP+5).NE.1) GOTO 190
905 C MINUS BEFORE THE MULTIPLICATIVE COMPONENT
907 CALL OUTPUT(WOPERAT,2)
909 190 IF (STACK(TOP+3).NE.0) CALL OUTPUT(WOPERAT,STACK(TOP+3))
912 C AND OF THE ANALYSIS OF THE COMPONENT, CHECK WHETHER MORE COMPONENTS ARE
913 C EXPECTED, E.G. IF THERE OCCURRS * , / , DIV , MOD
915 IF (S.NE.STAR) GOTO 200
916 IF (ADRES.LT.5) GOTO 200
920 C END OF MULTIPLICATIVE SEQUENCE
922 200 IF (STACK(TOP+4).NE.0) CALL OUTPUT(WOPERAT,STACK(TOP+4))
925 C END OF AN ADDITIVE COMPONENT, CHECK FOR MORE (+,-)
927 IF (S.NE.STAR) GOTO 210
928 IF (ADRES.LT.3) GOTO 210
932 C END OF ADDITIVE SEQUENCE