← Back to branch summary

~ubuntu-branches/debian/jessie/eso-midas/jessie

« back to all changes in this revision

Viewing changes to system/ext/linetype.c

  • Committer: Package Import Robot
  • Author(s): Ole Streicher
  • Date: 2014-04-22 14:44:58 UTC
  • Revision ID: package-import@ubuntu.com-20140422144458-okiwi1assxkkiz39
Tags: upstream-13.09pl1.2+dfsg
Import upstream version 13.09pl1.2+dfsg

Show diffs side-by-side

added added

removed removed

Lines of Context:
system/ext/linetype.c
 
1
/*===========================================================================
 
2
  Copyright (C) 1992-2009 European Southern Observatory (ESO)
 
3
 
 
4
  This program is free software; you can redistribute it and/or 
 
5
  modify it under the terms of the GNU General Public License as 
 
6
  published by the Free Software Foundation; either version 2 of 
 
7
  the License, or (at your option) any later version.
 
8
 
 
9
  This program is distributed in the hope that it will be useful,
 
10
  but WITHOUT ANY WARRANTY; without even the implied warranty of
 
11
  MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
 
12
  GNU General Public License for more details.
 
13
 
 
14
  You should have received a copy of the GNU General Public 
 
15
  License along with this program; if not, write to the Free 
 
16
  Software Foundation, Inc., 675 Massachusetts Ave, Cambridge, 
 
17
  MA 02139, USA.
 
18
 
 
19
  Correspondence concerning ESO-MIDAS should be addressed as follows:
 
20
        Internet e-mail: midas@eso.org
 
21
        Postal address: European Southern Observatory
 
22
                        Data Management Division 
 
23
                        Karl-Schwarzschild-Strasse 2
 
24
                        D 85748 Garching bei Muenchen 
 
25
                        GERMANY
 
26
===========================================================================*/
 
27
 
 
28
/*+++++++++  Remove ESO extensions to FORTRAN 77    ++++++++++++++++++++
 
29
.LANGUAGE    C
 
30
.IDENT       linetype.c
 
31
.AUTHOR      Preben J. Grosbol [ESO/IPG]
 
32
.KEYWORDS    fortran, statement type
 
33
.ENVIRONMENT UNIX
 
34
.VERSION     1.0  1987-Nov-12: Creation,     PJG
 
35
.VERSION     1.1  1988-Feb-01: insert typed functions + correct IF,  PJG
 
36
.VERSION     1.2  1988-Mar-23: Redefine 'c' as int,  PJG
 
37
.VERSION     1.3  1988-Mar-24: Initiate 'action and check END,  PJG
 
38
.VERSION     1.4  1988-Sep-08: Standard error lists,  PJG
 
39
.VERSION     1.5  1990-Mar-02: Add SAVE statement to list,  PJG
 
40
.VERSION     1.6  1991-May-15: Correct for CHAR*n FUNCTION, PJG
 
41
.VERSION     1.7  1992-Aug-07: Print warning for SECTION error, PJG
 
42
 
 
43
 090903         last modif
 
44
------------------------------------------------------------------------*/
 
45
 
 
46
#include   <stdio.h>                        /* standard I/O functions   */
 
47
#include   <ctype.h>                        /* character types          */
 
48
#include   <string.h>                       /* string functions         */
 
49
#include   <f77ext.h>                       /* definition of constants  */
 
50
#include   <f77stat.h>                      /* FORTRAN statement types  */
 
51
 
 
52
void chk_exp(), chk_io(), new_id();
 
53
 
 
54
 
 
55
extern    int                 section;      /* program section          */
 
56
extern    int                  x_flag;      /* extension option flag    */
 
57
extern    int                   equal;      /* level zero equal sign    */
 
58
extern    int                   comma;      /* level zero comma         */
 
59
extern    int                     lno;      /* current line number      */
 
60
extern    int                  no_lid;      /* no. of line identifiers  */
 
61
extern    char                 stmt[];      /* present statement        */
 
62
extern    char   lbuf[MXLBUF][MXLINE];      /* buffer for input lines   */
 
63
extern    LID                   lid[];      /* list of line identifiers */
 
64
 
 
65
static    FSTAT   sc_name[] = {             /* f77 section names        */
 
66
                  { PROG_SEC,         "PROGRAM"},
 
67
                  { IMPL_SEC,         "IMPLICIT"},
 
68
                  { DECL_SEC,         "DECLARATION"},
 
69
                  { DATA_SEC,         "DATA"},
 
70
                  { EXEC_SEC,         "EXECUTABLE"},
 
71
                  { END_SEC,          "END"},
 
72
                  { 0,                (char *) 0}};
 
73
 
 
74
static    FSTAT   fs_none[] = {             /* f77 stat. without , or = */
 
75
                  { IF,               "IF"},
 
76
                  { ELSEIF,           "ELSEIF"},
 
77
                  { ELSE,             "ELSE"},
 
78
                  { CALL,             "CALL"},
 
79
                  { CONTINUE,         "CONTINUE"},
 
80
                  { GOTO,             "GOTO"},
 
81
                  { CLOSE,            "CLOSE"},
 
82
                  { ENDIF,            "ENDIF"},
 
83
                  { ENDDO,            "ENDDO"},
 
84
                  { END,              "END"},
 
85
                  { WRITE,            "WRITE"},
 
86
                  { RFUNCTION,        "REALFUNCTION"},
 
87
                  { IFUNCTION,        "INTEGERFUNCTION"},
 
88
                  { DFUNCTION,        "DOUBLEPRECISIONFUNCTION"},
 
89
                  { CFUNCTION,        "CHARACTERFUNCTION"},
 
90
                  { LFUNCTION,        "LOGICALFUNCTION"},
 
91
                  { REAL,             "REAL"},
 
92
                  { INTEGER,          "INTEGER"},
 
93
                  { DOUBLEPRECISION,  "DOUBLEPRECISION"},
 
94
                  { CHARACTER,        "CHARACTER"},
 
95
                  { LOGICAL,          "LOGICAL"},
 
96
                  { RETURN,           "RETURN"},
 
97
                  { ASSIGN,           "ASSIGN"},
 
98
                  { OPEN,             "OPEN"},
 
99
                  { PARAMETER,        "PARAMETER"},
 
100
                  { INCLUDE,          "INCLUDE"},
 
101
                  { STOP,             "STOP"},
 
102
                  { SUBROUTINE,       "SUBROUTINE"},
 
103
                  { FORMAT,           "FORMAT"},
 
104
                  { FUNCTION,         "FUNCTION"},
 
105
                  { READ,             "READ"},
 
106
                  { COMMON,           "COMMON"},
 
107
                  { COMPLEX,          "COMPLEX"},
 
108
                  { DATA,             "DATA"},
 
109
                  { DIMENSION,        "DIMENSION"},
 
110
                  { EQUIVALENCE,      "EQUIVALENCE"},
 
111
                  { IMPLICITNONE,     "IMPLICITNONE"},
 
112
                  { IMPLICIT,         "IMPLICIT"},
 
113
                  { PROGRAM,          "PROGRAM"},
 
114
                  { EXTERNAL,         "EXTERNAL"},
 
115
                  { INTRINSIC,        "INTRINSIC"},
 
116
                  { REWIND,           "REWIND"},
 
117
                  { SAVE,             "SAVE"},
 
118
                  { BACKSPACE,        "BACKSPACE"},
 
119
                  { BLOCKDATA,        "BLOCKDATA"},
 
120
                  { ENDFILE,          "ENDFILE"},
 
121
                  { ENTRY,            "ENTRY"},
 
122
                  { INQUIRE,          "INQUIRE"},
 
123
                  { PAUSE,            "PAUSE"},
 
124
                  { 0,                (char *) 0}};
 
125
 
 
126
static    FSTAT   fs_c[] = {                /* f77 stat. with , only    */
 
127
                  { IF,               "IF"},
 
128
                  { WRITE,            "WRITE"},
 
129
                  { REAL,             "REAL"},
 
130
                  { INTEGER,          "INTEGER"},
 
131
                  { DOUBLEPRECISION,  "DOUBLEPRECISION"},
 
132
                  { CHARACTER,        "CHARACTER"},
 
133
                  { LOGICAL,          "LOGICAL"},
 
134
                  { COMMON,           "COMMON"},
 
135
                  { COMPLEX,          "COMPLEX"},
 
136
                  { DATA,             "DATA"},
 
137
                  { DIMENSION,        "DIMENSION"},
 
138
                  { EQUIVALENCE,      "EQUIVALENCE"},
 
139
                  { EXTERNAL,         "EXTERNAL"},
 
140
                  { IMPLICIT,         "IMPLICIT"},
 
141
                  { INTRINSIC,        "INTRINSIC"},
 
142
                  { READ,             "READ"},
 
143
                  { SUBROUTINE,       "SUBROUTINE"},
 
144
                  { FUNCTION,         "FUNCTION"},
 
145
                  { RFUNCTION,        "REALFUNCTION"},
 
146
                  { IFUNCTION,        "INTEGERFUNCTION"},
 
147
                  { DFUNCTION,        "DOUBLEPRECISIONFUNCTION"},
 
148
                  { CFUNCTION,        "CHARACTERFUNCTION"},
 
149
                  { LFUNCTION,        "LOGICALFUNCTION"},
 
150
                  { SAVE,             "SAVE"},
 
151
                  { 0,                (char *) 0}};
 
152
 
 
153
static    FSTAT   fs_e[] = {                /* f77 stat. with = only    */
 
154
                  { IF,               "IF"},
 
155
                  { 0,                (char *) 0}};
 
156
 
 
157
static    FSTAT   fs_ce[] = {               /* f77 stat. with , and =   */
 
158
                  { DO,               "DO"},
 
159
                  { 0,                (char *) 0}};
 
160
 
 
161
static    FSTAT   fs_if[] = {               /* f77 stat. in IF stat.    */
 
162
                  { READ,             "READ"},
 
163
                  { IF,               "IF"},
 
164
                  { CALL,             "CALL"},
 
165
                  { CONTINUE,         "CONTINUE"},
 
166
                  { GOTO,             "GOTO"},
 
167
                  { CLOSE,            "CLOSE"},
 
168
                  { RETURN,           "RETURN"},
 
169
                  { ASSIGN,           "ASSIGN"},
 
170
                  { OPEN,             "OPEN"},
 
171
                  { STOP,             "STOP"},
 
172
                  { READ,             "READ"},
 
173
                  { WRITE,            "WRITE"},
 
174
                  { REWIND,           "REWIND"},
 
175
                  { BACKSPACE,        "BACKSPACE"},
 
176
                  { ENDFILE,          "ENDFILE"},
 
177
                  { INQUIRE,          "INQUIRE"},
 
178
                  { PAUSE,            "PAUSE"},
 
179
                  { 0,                (char *) 0}};
 
180
 
 
181
int line_type(ptype)                         /* find statement type      */
 
182
int      *ptype;
 
183
{
 
184
  int    no, action, n, err, f77_sect();
 
185
  char   *pc, type, group, *find_f77();
 
186
  ID     *pid, *add_id();
 
187
  LID    *plid;
 
188
 
 
189
  action = NO_ACTION;                        /* initiate action to none  */
 
190
 
 
191
  if (!comma && !equal) pc = find_f77(fs_none,stmt,&no,ptype);
 
192
  if (comma && !equal) pc = find_f77(fs_c,stmt,&no,ptype);
 
193
  if (!comma && equal) pc = find_f77(fs_e,stmt,&no,ptype);
 
194
  if (comma && equal) pc = find_f77(fs_ce,stmt,&no,ptype);
 
195
 
 
196
  section = f77_sect(ptype,section,&err);    /* update and check section */
 
197
 
 
198
  if (err) {
 
199
     for (n=0; section!=sc_name[n].type && sc_name[n].id; n++);
 
200
     fprintf(stderr,"esooext-warning: line %d: ",lno);
 
201
     fprintf(stderr,"Statement >%-16.16s< in wrong section (%s)\n",
 
202
             stmt,sc_name[n].id);
 
203
  }
 
204
 
 
205
  plid = lid; n = 0;
 
206
  if (*ptype != EXEC_STAT) {                /* modify identifier        */
 
207
    plid->sid = pc; plid->size -= no;
 
208
    if (*ptype == CFUNCTION && *pc == '*') {
 
209
      plid++;
 
210
      plid->sid += 8; plid->size -= 8;
 
211
    }
 
212
  }
 
213
 
 
214
  if (*ptype == IF || *ptype == ELSEIF) {    /* check conditioned stat. */
 
215
    plid++; n++;
 
216
    while (plid->level && n<no_lid) { plid++; n++; }
 
217
    if (n<no_lid) {                          /* if more ident. on line  */
 
218
       if (!strncmp(plid->sid,"THEN",4)) plid->size = 0;
 
219
        else {
 
220
          pc = find_f77(fs_if,plid->sid,&no,ptype);
 
221
          if (*ptype != EXEC_STAT) {
 
222
             plid->sid = pc; plid->size -=no;
 
223
          }
 
224
       }
 
225
    }
 
226
    chk_exp(lid);
 
227
  }
 
228
 
 
229
  plid = lid;
 
230
  switch (*ptype) {                        /* special things            */
 
231
    case EXEC_STAT    : chk_exp(lid); break;
 
232
    case FORMAT       : if (!equal) { no_lid = 0; return NO_ACTION; } 
 
233
                        break;
 
234
    case ENDDO        : no_lid = 0; return DO_ACTION;
 
235
    case DO           : if (isdigit((int)*pc)) { /* f77 DO statement    */
 
236
                          no = 1;
 
237
                          while (isdigit((int)*(++pc))) no++;
 
238
                          if (isalpha((int)*pc)) {
 
239
                            plid->sid = pc; plid->size -= no; }
 
240
                          else plid->size = 0;
 
241
                          action = NO_ACTION;
 
242
                        }
 
243
                        else action = DO_ACTION;
 
244
                        break;
 
245
    case GOTO         : if (isdigit((int)*plid->sid)) {
 
246
                          plid->size = 0; action = NO_ACTION;
 
247
                        }
 
248
                        break;
 
249
    case IMPLICIT     : no_lid = 0; return NO_ACTION;
 
250
    case IMPLICITNONE : no_lid = 0; return RM_ACTION;
 
251
    case INCLUDE      : no_lid = 0; return IN_ACTION;
 
252
    case STOP         : no_lid = 0; return NO_ACTION;
 
253
    case END          : no_lid = 0; return NO_ACTION;
 
254
    case PAUSE        : no_lid = 0; return NO_ACTION;
 
255
    case ASSIGN       : no = 0; pc = plid->sid;
 
256
                        while (isdigit((int)*(plid->sid++))) no++;
 
257
                        plid->sid += 2; plid->size -= no + 2;
 
258
                        break;
 
259
    case READ         :
 
260
    case WRITE        :
 
261
    case PRINT        :
 
262
    case OPEN         :
 
263
    case CLOSE        :
 
264
    case ENDFILE      :
 
265
    case REWIND       :
 
266
    case BACKSPACE    :
 
267
    case INQUIRE      : chk_io(lid); break;
 
268
  }
 
269
 
 
270
  type = '?'; group = 'V';
 
271
  if (*ptype == CALL) { type = 'X'; group = 'S'; }
 
272
  if (*ptype & PROG_STAT)                   /* check program block      */
 
273
    switch (*ptype) {
 
274
           case SUBROUTINE : group = 'S'; break;
 
275
           case FUNCTION   : group = 'F'; break;
 
276
           case IFUNCTION  : type = 'I'; group = 'F'; break;
 
277
           case RFUNCTION  : type = 'R'; group = 'F'; break;
 
278
           case DFUNCTION  : type = 'D'; group = 'F'; break;
 
279
           case LFUNCTION  : type = 'L'; group = 'F'; break;
 
280
           case CFUNCTION  : type = 'C'; group = 'F'; break;
 
281
           case PROGRAM    : group = 'P'; break;
 
282
           case BLOCKDATA  : group = 'D'; break;
 
283
    }
 
284
 
 
285
  if (*ptype & DECL_STAT)                   /* check type decleration   */
 
286
    switch (*ptype) {
 
287
      case REAL            : type = 'R'; break;
 
288
      case INTEGER         : type = 'I'; break;
 
289
      case DOUBLEPRECISION : type = 'D'; break;
 
290
      case CHARACTER       : type = 'S'; break;
 
291
      case LOGICAL         : type = 'L'; break;
 
292
      case EXTERNAL        : group = 'F'; break;
 
293
      case INTRINSIC       : group = 'F'; break;
 
294
      case PARAMETER       : type = 'P'; group = 'P'; break;
 
295
      case COMMON          : group = 'C'; break;
 
296
    }
 
297
 
 
298
  plid = lid;
 
299
  for (n=0; n<no_lid; n++, plid++) {        /* go through identifiers   */
 
300
    if (!plid->size) continue;
 
301
    pid = add_id(plid->sid,plid->size,type,group,&err);
 
302
    if (err) {
 
303
       fprintf(stderr,"Error: line %5d: ",lno);
 
304
       fprintf(stderr,"Identifier >%-20.20s<, error %d\n",plid->sid,err);
 
305
       plid->size = 0;
 
306
    }
 
307
    plid->id = pid;
 
308
    if (x_flag & LN_FLAG)
 
309
      new_id(pid->lname,plid->size,pid->sname);
 
310
     else *(pid->sname) = '\0';
 
311
  }
 
312
 
 
313
  return action;
 
314
}