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 ===============================================================
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
26 COMMON /BLANK/ IOP(4),
28 X TLDIM, TLBAS, IDL, OBJL,
29 X TRDIM, TRBAS, IDR, OBJR,
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 ,
41 EQUIVALENCE(STALER(1),IPMEM(1) )
42 EQUIVALENCE(STACK(1),IPMEM(1))
45 c second parameter - buffer array
48 c check if one-dimensional array
49 if (stack(vlprev-3) .ne. 1) goto 30
50 c check if primitive type
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
60 do 100 i=1, stckap(elem)
61 stack(valtop-i+1)=stack(vlprev-i+1)
65 if (stack(valtop-3) .gt. 0) goto 20
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
74 call quadr4(145, svats(valtop), action, 1)
76 c check if variable or array element
78 if (n .ne. 3 .and. n .ne. 4) goto 10
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
87 call quadr3(59, ats1, ats)
90 call sstore(valtop, ats)