Added upstream from http://ftp.icm.edu.pl/pub/loglan/
[loglan.git] / 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