sources/pass1/spgrec.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 spgrec(action)
  17       IMPLICIT INTEGER (A-Z)
  18       COMMON /STOS/ BOTTOM,VALTOP,VLPREV,STCKAG,STCKA0,STCKAP(14),
  19      X              APETYT(4),LSTLSE,LSTFOR,KIND,PHADR,LASTPR,FSTOUT,
  20      X              CONSNR(8),LSTSAF,LSTEMP,TEMPNR,LSTWRD,QRECNR,WB,
  21      X              RESULT,FRSTTS,UNIT,INNER,LSTWILL,TEST,ARG,ATLINE,
  22      X              FILE,FLARGS,FLMODF,FLREADY,ICOUNT,OCOUNT
  23              LOGICAL LSTWILL,FLREADY,TEST
  24 C
  25       LOGICAL   INSYS,  OWN
  26       COMMON /BLANK/ IOP(4),
  27      X        P,
  28      X        TLDIM, TLBAS,  IDL, OBJL,
  29      X        TRDIM, TRBAS,  IDR, OBJR,
  30      X        TRESLT,
  31      X        CONVL, CONVR,
  32      X        NRPAR,
  33      X        IX (261),
  34      X        LMEM  , LPMEM , IRECN , ISFIN , LPMSYS, LPML  , LPMF  ,
  35      X        NRINT , NRRE  , NRBOOL, NRCHR , NRCOR , NRPROC, NRTEXT,
  36      X        NRUNIV, NATTR , NRNONE, NBLSYS, NBLUS , NEMPTY, INSYS ,
  37      X        LOCAL,  OWN,    OBJECT,
  38      X        IPMEM(5000)
  39       REAL   STALER(100)
  40       INTEGER STACK(5000)
  41       EQUIVALENCE(STALER(1),IPMEM(1) )
  42       EQUIVALENCE(STACK(1),IPMEM(1))
  43       logical conv
  44 c
  45 c second parameter - buffer array
  46       flargs = 2
  47       call svalu2
  48 c check if one-dimensional array
  49       if (stack(vlprev-3) .ne. 1) goto 30
  50 c check if primitive type
  51       n = stack(vlprev-4)
  52       if (n .ne. nrint .and. n .ne. nrre .and. n .ne. nrbool .and.
  53      *    n .ne. nrchr) goto 40
  54       call quadr4(145, svats(vlprev), action, 0)
  55 c third parameter - byte count
  56 c duplicate stack top
  57 200   conv = .FALSE.
  58       elem = stack(valtop)
  59       call spush(elem)
  60       do 100 i=1, stckap(elem)
  61       stack(valtop-i+1)=stack(vlprev-i+1)
  62 100   continue
  63       call svalue
  64 c check if not array
  65       if (stack(valtop-3) .gt. 0) goto 20
  66 c check if integer
  67       if (stack(valtop-4) .eq. nrint) goto 300
  68 c not integer, check if real
  69       if (stack(valtop-4) .ne. nrre) goto 20
  70 c real, convert to integer
  71       conv = .TRUE.
  72       call svint(valtop)
  73 300   continue
  74       call quadr4(145, svats(valtop), action, 1)
  75       call spop
  76 c check if variable or array element
  77       n = stack(valtop)
  78       if (n .ne. 3 .and. n .ne. 4) goto 10
  79       ats = tstemp(1)
  80 c generate LCALLPROCSTAND
  81       call quadr2(132, action)
  82 c read output parameter
  83       call quadr4(23, ats, action, 1)
  84       if ( .not. conv) go to 400
  85 c convert to real
  86       ats1 = tstemp(2)
  87       call quadr3(59, ats1, ats)
  88       ats = ats1
  89 400   continue
  90       call sstore(valtop, ats)
  91       call spop
  92       return
  93 c error recovery
  94 10    call serror(420)
  95       call spop
  96       return
  97 20    call serror(478)
  98       call spop
  99       call spop
 100       return
 101 30    call serror(416)
 102       goto 200
 103 40    call serror(478)
 104       goto 200
 105       end
 106