sources/pass1/resume.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 CBC B.Ciesielski  added concurrent statements
  17 CBC 1987.04.15  1. RESUME same as ATTACH, opcode 220
  18 CBC 1987.04.24  2. added missing STORAGE:2 metacommand
  19 CBC 1987.11.18  3. added procedure SCONC
  20 C
  21       SUBROUTINE SRESUM
  22 C------------------------------------------------------
  23 C
  24 C     NA CZUBKU JEST ARGUMENT RESUME. BADA TYP,GENERUJE KOD,
  25 C     ZDEJMUJE ZE STOSU.
  26 C
  27 C     ##### OUTPUT CODE : 220 .
  28 C
  29 C     ##### DETECTED ERROR(S) : 477
  30 C
  31 C............. /STOS/ .....
  32       IMPLICIT INTEGER (A-Z)
  33       COMMON /STOS/ BOTTOM,VALTOP,VLPREV,STCKAG,STCKA0,STCKAP(14),
  34      X              APETYT(4),LSTLSE,LSTFOR,KIND,PHADR,LASTPR,FSTOUT,
  35      X              CONSNR(8),LSTSAF,LSTEMP,TEMPNR,LSTWRD,QRECNR,WB,
  36      X              RESULT,FRSTTS,UNIT,INNER,LSTWILL,TEST,ARG,ATLINE,
  37      X              FILE,FLARGS,FLMODF,FLREADY,ICOUNT,OCOUNT
  38              LOGICAL LSTWILL,FLREADY,TEST
  39 C
  40       COMMON/OPTION/OPTMEM,OPTOPT,OPTIND,OPTTYP,OPTTRC,OPTCSC,OPTCSF
  41       LOGICAL OPTOPT,OPTTYP,OPTTRC
  42 C
  43       LOGICAL   INSYS,  OWN
  44       COMMON /BLANK/ IOP(4),
  45      X        P,
  46      X        TLDIM, TLBAS,  IDL, OBJL,
  47      X        TRDIM, TRBAS,  IDR, OBJR,
  48      X        TRESLT,
  49      X        CONVL, CONVR,
  50      X        NRPAR,
  51      X        IX (261),
  52      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
  53      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
  54      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
  55      X        LOCAL,  OWN,    OBJECT,
  56      X        IPMEM(5000)
  57       REAL   STALER(100)
  58       INTEGER STACK(5000)
  59       EQUIVALENCE(STALER(1),IPMEM(1) )
  60       EQUIVALENCE(STACK(1),IPMEM(1))
  61 C
  62 C
  63       INTEGER ELEM
  64 C.........
  65       CALL SVALUE
  66       IF(STACK(VALTOP).EQ.0)RETURN
  67       IF(STACK(VALTOP-3).GT.0)GO TO 500
  68       ELEM=STACK(VALTOP-4)
  69       ELEM=IAND(IPMEM(ELEM),15)
  70       IF(ELEM.GT.7 .AND. ELEM.LT.13 .OR. ELEM.EQ.2)GO TO 500
  71       ELEM=STACK(VALTOP-2)
  72 C     RESUME( NONE ) ?
  73       IF(STACK(VALTOP).EQ.1)ELEM=LMEM-3
  74 C                           = ATS NONE
  75       CALL QUADR2(220,ELEM)
  76       RETURN
  77 C     NIEPOPRAWNY TYP ARGUMENTU RESUME
  78   500 CALL SERROR(477)
  79       RETURN
  80       END
  81
  82       subroutine sconc(action)
  83       IMPLICIT INTEGER (A-Z)
  84       COMMON /STOS/ BOTTOM,VALTOP,VLPREV,STCKAG,STCKA0,STCKAP(14),
  85      X              APETYT(4),LSTLSE,LSTFOR,KIND,PHADR,LASTPR,FSTOUT,
  86      X              CONSNR(8),LSTSAF,LSTEMP,TEMPNR,LSTWRD,QRECNR,WB,
  87      X              RESULT,FRSTTS,UNIT,INNER,LSTWILL,TEST,ARG,ATLINE,
  88      X              FILE,FLARGS,FLMODF,FLREADY,ICOUNT,OCOUNT
  89              LOGICAL LSTWILL,FLREADY,TEST
  90 C
  91       LOGICAL   INSYS,  OWN
  92       COMMON /BLANK/ IOP(4),
  93      X        P,
  94      X        TLDIM, TLBAS,  IDL, OBJL,
  95      X        TRDIM, TRBAS,  IDR, OBJR,
  96      X        TRESLT,
  97      X        CONVL, CONVR,
  98      X        NRPAR,
  99      X        IX (261),
 100      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
 101      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
 102      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
 103      X        LOCAL,  OWN,    OBJECT,
 104      X        IPMEM(5000)
 105       REAL   STALER(100)
 106       INTEGER STACK(5000)
 107       EQUIVALENCE(STALER(1),IPMEM(1) )
 108       EQUIVALENCE(STACK(1),IPMEM(1))
 109 c
 110 c generate proper opcode
 111       call quadr1(action)
 112 c process next identifier
 113 100   call snext
 114       if (wb .ne. 28) goto 200
 115       call snext
 116 c check if procedure or function
 117       ind = mident(wb)
 118       elem = swhat(ind)
 119       if (elem .ne. 11 .and. elem .ne. 12) goto 110
 120 c output prototype address
 121       call quadr1(ind)
 122       goto 100
 123 110   call serror(478)
 124       goto 100
 125 c end of identifier list
 126 200   call quadr1(0)
 127 c generate ACCEPT2 if necessary
 128       if (action .eq. 225) call quadr1(226)
 129       return
 130       end
 131