![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to fsplit.c CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv8dc / cmd|
Return to fsplit.c CVS log | Up to [Research Unix] / researchv8dc / cmd |
1.1 root 1: /*
2: Program to split file(s) containing Fortran, Ratfor, or Efl
3: procedures into separate files, one per procedure.
4: Procedure X is put in file X.f, X.r, or X.e depending on
5: the language option (-f, -r, -e); Fortran (-f) is default.
6: The -s option causes Fortran procedures to be stripped to 72
7: or fewer characters, with trailing blanks removed.
8: The -y option forces filenames to lower case.
9: */
10:
11: #include <stdio.h>
12: #include <ctype.h>
13: #define BIG 1000
14:
15: #define NO 0
16: #define YES 1
17:
18: #define FORTRAN 0
19: #define RATFOR 1
20: #define EFL 2
21:
22: int blkdatano = 0;
23: int language = FORTRAN;
24: char suffix = 'f';
25: int strip = NO;
26: int yflag;
27:
28: #define SKIP while( isspace(*s) ) ++s;
29:
30:
31: main(argc, argv)
32: int argc;
33: char **argv;
34: {
35: FILE *fd;
36: int i;
37: register char *s;
38:
39: while(argc>1 && argv[1][0]=='-')
40: {
41: for(s = argv[1]+1 ; *s ; ++s)
42: switch(*s)
43: {
44: case 'y':
45: yflag++;
46: break;
47:
48: case 's':
49: strip = YES;
50: break;
51:
52: case 'f':
53: language = FORTRAN;
54: suffix = 'f';
55: break;
56:
57: case 'r':
58: language = RATFOR;
59: suffix = 'r';
60: break;
61:
62: case 'e':
63: language = EFL;
64: suffix = 'e';
65: break;
66:
67: default:
68: fprintf(stderr, "bad option %c\n", *s);
69: exit(1);
70: }
71:
72: --argc;
73: ++argv;
74: }
75:
76: if(strip && language!=FORTRAN)
77: fprintf(stderr, "implausible to strip non-Fortran programs\n");
78:
79:
80: if(argc <= 1)
81: splitup(stdin);
82:
83: else for(i = 1 ; i < argc ; ++i)
84: {
85: if( (fd = fopen(argv[i], "r")) == NULL)
86: {
87: fprintf(stderr, "cannot open %s\n", argv[i]);
88: exit(1);
89: }
90: splitup(fd);
91: fclose(fd);
92: }
93:
94: exit(0);
95: }
96:
97:
98:
99: splitup(fin)
100: FILE *fin;
101: {
102: FILE *fout;
103: char in[BIG], fname[20];
104: int i, c;
105:
106: while( fgets(in,BIG,fin) )
107: {
108: if( *in=='c' || *in=='C' || *in=='\0' || *in=='\n' ) continue;
109: if(strip)
110: shorten(in);
111: getname(in, fname);
112: if(yflag)
113: lowercase(fname);
114: if( (fout = fopen(fname, "w")) == NULL)
115: {
116: fprintf(stderr, "can't open %s", fname);
117: exit(1);
118: }
119: fputs(in,fout);
120: while( !endcard(in) && fgets(in, BIG, fin) )
121: {
122: if(strip)
123: shorten(in);
124: fputs(in, fout);
125: }
126: fclose(fout);
127: }
128: }
129:
130:
131:
132: lowercase(s)
133: register char *s;
134: {
135: do
136: if(isupper(*s))
137: *s=tolower(*s);
138: while(*s++);
139: }
140:
141:
142: getname(s,f)
143: char *s,*f;
144: {
145: int i,j,c;
146: loop:
147: if( compar(&s,"subroutine") ) goto bot;
148: else if( compar(&s,"function") ) goto bot;
149: else if( compar(&s,"procedure") ) goto bot;
150: else if( compar(&s,"program") ) goto bot;
151: else if( compar(&s,"real") ) goto loop;
152: else if( compar(&s,"integer") ) goto loop;
153: else if( compar(&s,"logical") ) goto loop;
154: else if( compar(&s,"double") ) goto loop;
155: else if( compar(&s,"precision") ) goto loop;
156: else if( compar(&s,"complex") ) goto loop;
157: else if( compar(&s,"character") ) goto loop;
158: else if( compar(&s,"*") ) /* complex *16 etc */
159: {
160: for( ++s ; isdigit(*s) || isspace(*s) ; ++s)
161: ;
162: goto loop;
163: }
164: else if( compar(&s,"blockdata") )
165: {
166: SKIP
167: if(*s == '\0') /* no block data name */
168: {
169: sprintf(f, "BLOCKDATA%d.%c", ++blkdatano, suffix);
170: return;
171: }
172: goto bot;
173: }
174: else
175: s = "";
176:
177: bot:
178: SKIP
179: for(i=0 ; isalpha(*s) || isdigit(*s) ; i++)
180: f[i] = *s++;
181: if(i > 0)
182: {
183: f[i++] = '.';
184: f[i++] = suffix;
185: f[i++] = '\0';
186: }
187: else
188: sprintf(f, "MAIN.%c", suffix);
189: }
190:
191: /* compare two strings for equality. assume that
192: t is all lower case. ignore blanks and decase s
193: during comparison. s0 points to next character after
194: successful comparison.
195: */
196: compar(s0, t)
197: char **s0,*t;
198: {
199: register char *s;
200: register int s1;
201: s = *s0;
202: while( *t )
203: {
204: SKIP
205: s1 = *s++;
206: if(isupper(s1))
207: s1 = tolower(s1);
208: if(s1 != *t++)
209: return(NO);
210: }
211: *s0 = s;
212: return(YES);
213: }
214:
215:
216: endcard(s)
217: char *s;
218: {
219: register int i;
220:
221: if( *s==0 )
222: return(YES);
223: SKIP
224: if( s[0]!='e' && s[0]!='E' )
225: return(NO);
226: if( s[1]!='n' && s[1]!='N' )
227: return(NO);
228: if( s[2]!='d' && s[2]!='D' )
229: return(NO);
230: for(i = 3; i<66; ++i)
231: if(s[i] == '\n')
232: return(YES);
233: else if(s[i] != ' ')
234: return(NO);
235: return(YES);
236: }
237:
238:
239:
240: shorten(s0)
241: register char *s0;
242: {
243: register char *s, *s72;
244: s72 = s0 + 72;
245:
246: for(s=s0 ; s<s72; ++s)
247: if(*s=='\n' || *s=='\0')
248: break;
249:
250: while(s>s0 && s[-1]==' ')
251: --s;
252: s[0] = '\n';
253: s[1] = '\0';
254: }
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.