« back to all changes in this revision
Viewing changes to rat4.c
- browse files at revision 1
- compare with another revision
- download diff
- download tarball
- view history from revision 1
- Committer: Bazaar Package Importer
- Author(s): Alan Bain
- Date: 1999-10-26 14:00:00 UTC
- Revision ID: james.westby@ubuntu.com-19991026140000-jhakh07r6sfdh1gr
Tags: upstream-1.0
Import upstream version 1.0
added
removed
rat4.c
1
/*
2
* ratfor - A ratfor pre-processor in C.
3
* Derived from a pre-processor distributed by the
4
* University of Arizona. Closely corresponds to the
5
* pre-processor described in the "SOFTWARE TOOLS" book.
6
*
7
* By: oz
8
*
9
* Not deived from AT&T code.
10
*
11
* This code is in the public domain. In other words, all rights
12
* are granted to all recipients, "public" at large.
13
*
14
* Modification history:
15
*
16
* June 1985
17
* - Ken Yap's mods for F77 output. Currently
18
* available thru #define F77.
19
* - Two minor bug-fixes for sane output.
20
* June 1985
21
* - Improve front-end with getopt().
22
* User may specify -l n for starting label.
23
* - Retrofit switch statement handling. This code
24
* is borrowed from the SWTOOLS Ratfor.
25
*
26
* 05-28-91 W. Bauske IBM
27
* - ported to RS/6000
28
* - fixed line continuations
29
* - added -C option to leave comments in the source code
30
* - added % in column 1 to force copy to output
31
* - support both && and & for .and.
32
* - support both || and | for .or.
33
*
34
*/
35
36
#include <stdio.h>
37
38
#if defined __stdc__ || defined __STDC__
39
#include <stdlib.h>
40
#endif
41
42
#include <string.h>
43
44
#include "ratdef.h"
45
#include "ratcom.h"
46
47
/* keywords: */
48
49
char sdo[3] = {
50
LETD,LETO,EOS};
51
char vdo[2] = {
52
LEXDO,EOS};
53
54
char sif[3] = {
55
LETI,LETF,EOS};
56
char vif[2] = {
57
LEXIF,EOS};
58
59
char selse[5] = {
60
LETE,LETL,LETS,LETE,EOS};
61
char velse[2] = {
62
LEXELSE,EOS};
63
64
#ifdef F77
65
char sthen[5] = {
66
LETT,LETH,LETE,LETN,EOS};
67
68
char sendif[6] = {
69
LETE,LETN,LETD,LETI,LETF,EOS};
70
71
#endif /* F77 */
72
char swhile[6] = {
73
LETW, LETH, LETI, LETL, LETE, EOS};
74
char vwhile[2] = {
75
LEXWHILE, EOS};
76
77
char ssbreak[6] = {
78
LETB, LETR, LETE, LETA, LETK, EOS};
79
char vbreak[2] = {
80
LEXBREAK, EOS};
81
82
char snext[5] = {
83
LETN,LETE, LETX, LETT, EOS};
84
char vnext[2] = {
85
LEXNEXT, EOS};
86
87
char sfor[4] = {
88
LETF,LETO, LETR, EOS};
89
char vfor[2] = {
90
LEXFOR, EOS};
91
92
char srept[7] = {
93
LETR, LETE, LETP, LETE, LETA, LETT, EOS};
94
char vrept[2] = {
95
LEXREPEAT, EOS};
96
97
char suntil[6] = {
98
LETU, LETN, LETT, LETI, LETL, EOS};
99
char vuntil[2] = {
100
LEXUNTIL, EOS};
101
102
char sswitch[7] = {
103
LETS, LETW, LETI, LETT, LETC, LETH, EOS};
104
char vswitch[2] = {
105
LEXSWITCH, EOS};
106
107
char scase[5] = {
108
LETC, LETA, LETS, LETE, EOS};
109
char vcase[2] = {
110
LEXCASE, EOS};
111
112
char sdefault[8] = {
113
LETD, LETE, LETF, LETA, LETU, LETL, LETT, EOS};
114
char vdefault[2] = {
115
LEXDEFAULT, EOS};
116
117
char sret[7] = {
118
LETR, LETE, LETT, LETU, LETR, LETN, EOS};
119
char vret[2] = {
120
LEXRETURN, EOS};
121
122
char sstr[7] = {
123
LETS, LETT, LETR, LETI, LETN, LETG, EOS};
124
char vstr[2] = {
125
LEXSTRING, EOS};
126
127
char deftyp[2] = {
128
DEFTYPE, EOS};
129
130
/* constant strings */
131
132
char *errmsg = "error at line ";
133
char *in = " in ";
134
char *ifnot = "if(.not.";
135
char *incl = "include";
136
char *fncn = "function";
137
char *def = "define";
138
char *bdef = "DEFINE";
139
char *contin = "continue";
140
char *rgoto = "goto ";
141
char *dat = "data ";
142
char *eoss = "EOS/";
143
144
extern S_CHAR ngetch();
145
char *progname;
146
int startlab = 23000; /* default start label */
147
int leaveC = NO; /* Flag for handling comments */
148
149
/*
150
* M A I N L I N E & I N I T
151
*/
152
153
main(argc,argv)
154
int argc;
155
char *argv[];
156
{
157
int c, errflg = 0;
158
extern int optind77;
159
extern char *optarg;
160
161
progname = argv[0];
162
163
while ((c=our_getopt(argc, argv, "Chn:o:6:")) != EOF)
164
switch (c) {
165
case 'C':
166
leaveC = YES; /* keep comments in src */
167
break;
168
case 'h':
169
/* not written yet */
170
break;
171
case 'l': /* user sets label */
172
startlab = atoi(optarg);
173
break;
174
case 'o':
175
if ((freopen(optarg, "w", stdout)) == NULL)
176
error("can't write %s\n", optarg);
177
break;
178
case '6':
179
/* not written yet */
180
break;
181
default:
182
++errflg;
183
}
184
185
if (errflg) {
186
fprintf(stderr,
187
"usage: %s [-C][-hx][-l n][-o file][-6x] [file...]\n",progname);
188
exit(1);
189
}
190
191
/*
192
* present version can only process one file, sadly.
193
*/
194
if (optind77 >= argc)
195
infile[0] = stdin;
196
else if ((infile[0] = fopen(argv[optind77], "r")) == NULL)
197
error("cannot read %s\n", argv[optind77]);
198
199
initvars();
200
201
parse(); /* call parser.. */
202
203
exit(0);
204
}
205
206
/*
207
* initialise
208
*/
209
initvars()
210
{
211
int i;
212
213
outp = 0; /* output character pointer */
214
level = 0; /* file control */
215
linect[0] = 1; /* line count of first file */
216
fnamp = 0;
217
fnames[0] = EOS;
218
bp = -1; /* pushback buffer pointer */
219
fordep = 0; /* for stack */
220
swtop = 0; /* switch stack index */
221
swlast = 1; /* switch stack index */
222
for( i = 0; i <= 126; i++)
223
tabptr[i] = 0;
224
install(def, deftyp); /* default definitions */
225
install(bdef, deftyp);
226
fcname[0] = EOS; /* current function name */
227
label = startlab; /* next generated label */
228
printf("C Output from Public domain Ratfor, version 1.0\n");
229
}
230
231
/*
232
* P A R S E R
233
*/
234
235
parse()
236
{
237
S_CHAR lexstr[MAXTOK];
238
int lab, labval[MAXSTACK], lextyp[MAXSTACK], sp, i, token;
239
240
sp = 0;
241
lextyp[0] = EOF;
242
for (token = lex(lexstr); token != EOF; token = lex(lexstr)) {
243
if (token == LEXIF)
244
ifcode(&lab);
245
else if (token == LEXDO)
246
docode(&lab);
247
else if (token == LEXWHILE)
248
whilec(&lab);
249
else if (token == LEXFOR)
250
forcod(&lab);
251
else if (token == LEXREPEAT)
252
repcod(&lab);
253
else if (token == LEXSWITCH)
254
swcode(&lab);
255
else if (token == LEXCASE || token == LEXDEFAULT) {
256
for (i = sp; i >= 0; i--)
257
if (lextyp[i] == LEXSWITCH)
258
break;
259
if (i < 0)
260
synerr("illegal case of default.");
261
else
262
cascod(labval[i], token);
263
}
264
else if (token == LEXDIGITS)
265
labelc(lexstr);
266
else if (token == LEXELSE) {
267
if (lextyp[sp] == LEXIF)
268
elseif(labval[sp]);
269
else
270
synerr("illegal else.");
271
}
272
if (token == LEXIF || token == LEXELSE || token == LEXWHILE
273
|| token == LEXFOR || token == LEXREPEAT
274
|| token == LEXDO || token == LEXDIGITS
275
|| token == LEXSWITCH || token == LBRACE) {
276
sp++; /* beginning of statement */
277
if (sp > MAXSTACK)
278
baderr("stack overflow in parser.");
279
lextyp[sp] = token; /* stack type and value */
280
labval[sp] = lab;
281
}
282
else if (token != LEXCASE && token != LEXDEFAULT) {
283
/*
284
* end of statement - prepare to unstack
285
*/
286
if (token == RBRACE) {
287
if (lextyp[sp] == LBRACE)
288
sp--;
289
else if (lextyp[sp] == LEXSWITCH) {
290
swend(labval[sp]);
291
sp--;
292
}
293
else
294
synerr("illegal right brace.");
295
}
296
else if (token == LEXOTHER)
297
otherc(lexstr);
298
else if (token == LEXBREAK || token == LEXNEXT)
299
brknxt(sp, lextyp, labval, token);
300
else if (token == LEXRETURN)
301
retcod();
302
else if (token == LEXSTRING)
303
strdcl();
304
token = lex(lexstr); /* peek at next token */
305
pbstr(lexstr);
306
unstak(&sp, lextyp, labval, token);
307
}
308
}
309
if (sp != 0)
310
synerr("unexpected EOF.");
311
}
312
313
/*
314
* L E X I C A L A N A L Y S E R
315
*/
316
317
/*
318
* alldig - return YES if str is all digits
319
*
320
*/
321
int
322
alldig(str)
323
S_CHAR str[];
324
{
325
int i,j;
326
327
j = NO;
328
if (str[0] == EOS)
329
return(j);
330
for (i = 0; str[i] != EOS; i++)
331
if (type(str[i]) != DIGIT)
332
return(j);
333
j = YES;
334
return(j);
335
}
336
337
338
/*
339
* balpar - copy balanced paren string
340
*
341
*/
342
balpar()
343
{
344
S_CHAR token[MAXTOK];
345
int t,nlpar;
346
347
if (gnbtok(token, MAXTOK) != LPAREN) {
348
synerr("missing left paren.");
349
return;
350
}
351
outstr(token);
352
nlpar = 1;
353
do {
354
t = gettok(token, MAXTOK);
355
if (t==SEMICOL || t==LBRACE || t==RBRACE || t==EOF) {
356
pbstr(token);
357
break;
358
}
359
if (t == NEWLINE) /* delete newlines */
360
token[0] = EOS;
361
else if (t == LPAREN)
362
nlpar++;
363
else if (t == RPAREN)
364
nlpar--;
365
/* else nothing special */
366
outstr(token);
367
}
368
while (nlpar > 0);
369
if (nlpar != 0)
370
synerr("missing parenthesis in condition.");
371
}
372
373
/*
374
* deftok - get token; process macro calls and invocations
375
*
376
*/
377
int
378
deftok(token, toksiz, fd)
379
S_CHAR token[];
380
int toksiz;
381
FILE *fd;
382
{
383
S_CHAR defn[MAXDEF];
384
int t;
385
386
for (t=gtok(token, toksiz, fd); t!=EOF; t=gtok(token, toksiz, fd)) {
387
if (t != ALPHA) /* non-alpha */
388
break;
389
if (look(token, defn) == NO) /* undefined */
390
break;
391
if (defn[0] == DEFTYPE) { /* get definition */
392
getdef(token, toksiz, defn, MAXDEF, fd);
393
install(token, defn);
394
}
395
else
396
pbstr(defn); /* push replacement onto input */
397
}
398
if (t == ALPHA) /* convert to single case */
399
fold(token);
400
return(t);
401
}
402
403
404
/*
405
* eatup - process rest of statement; interpret continuations
406
*
407
*/
408
eatup()
409
{
410
411
S_CHAR ptoken[MAXTOK], token[MAXTOK];
412
int nlpar, t;
413
414
nlpar = 0;
415
do {
416
t = gettok(token, MAXTOK);
417
if (t == SEMICOL || t == NEWLINE)
418
break;
419
if (t == RBRACE || t == LBRACE) {
420
pbstr(token);
421
break;
422
}
423
if (t == EOF) {
424
synerr("unexpected EOF.");
425
pbstr(token);
426
break;
427
}
428
if (t == COMMA || t == PLUS
429
|| t == MINUS || t == STAR || t == LPAREN
430
|| t == AND || t == BAR || t == BANG
431
|| t == EQUALS || t == UNDERLINE ) {
432
while (gettok(ptoken, MAXTOK) == NEWLINE)
433
;
434
pbstr(ptoken);
435
if (t == UNDERLINE)
436
token[0] = EOS;
437
}
438
if (t == LPAREN)
439
nlpar++;
440
else if (t == RPAREN)
441
nlpar--;
442
outstr(token);
443
444
} while (nlpar >= 0);
445
446
if (nlpar != 0)
447
synerr("unbalanced parentheses.");
448
}
449
450
/*
451
* getdef (for no arguments) - get name and definition
452
*
453
*/
454
getdef(token, toksiz, defn, defsiz, fd)
455
S_CHAR token[];
456
int toksiz;
457
S_CHAR defn[];
458
int defsiz;
459
FILE *fd;
460
{
461
int i, nlpar, t;
462
S_CHAR c, ptoken[MAXTOK];
463
464
skpblk(fd);
465
/*
466
* define(name,defn) or
467
* define name defn
468
*
469
*/
470
if ((t = gtok(ptoken, MAXTOK, fd)) != LPAREN) {;
471
t = BLANK; /* define name defn */
472
pbstr(ptoken);
473
}
474
skpblk(fd);
475
if (gtok(token, toksiz, fd) != ALPHA)
476
baderr("non-alphanumeric name.");
477
skpblk(fd);
478
c = (S_CHAR) gtok(ptoken, MAXTOK, fd);
479
if (t == BLANK) { /* define name defn */
480
pbstr(ptoken);
481
i = 0;
482
do {
483
c = ngetch(&c, fd);
484
if (i > defsiz)
485
baderr("definition too long.");
486
defn[i++] = c;
487
}
488
while (c != SHARP && c != NEWLINE && c != (S_CHAR)EOF && c != PERCENT);
489
if (c == SHARP || c == PERCENT)
490
putbak(c);
491
}
492
else if (t == LPAREN) { /* define (name, defn) */
493
if (c != COMMA)
494
baderr("missing comma in define.");
495
/* else got (name, */
496
nlpar = 0;
497
for (i = 0; nlpar >= 0; i++)
498
if (i > defsiz)
499
baderr("definition too long.");
500
else if (ngetch(&defn[i], fd) == (S_CHAR)EOF)
501
baderr("missing right paren.");
502
else if (defn[i] == LPAREN)
503
nlpar++;
504
else if (defn[i] == RPAREN)
505
nlpar--;
506
/* else normal character in defn[i] */
507
}
508
else
509
baderr("getdef is confused.");
510
defn[i-1] = EOS;
511
}
512
513
/*
514
* gettok - get token. handles file inclusion and line numbers
515
*
516
*/
517
int
518
gettok(token, toksiz)
519
S_CHAR token[];
520
int toksiz;
521
{
522
int t, i;
523
int tok;
524
S_CHAR name[MAXNAME];
525
526
for ( ; level >= 0; level--) {
527
for (tok = deftok(token, toksiz, infile[level]); tok != EOF;
528
tok = deftok(token, toksiz, infile[level])) {
529
if (equal(token, fncn) == YES) {
530
skpblk(infile[level]);
531
t = deftok(fcname, MAXNAME, infile[level]);
532
pbstr(fcname);
533
if (t != ALPHA)
534
synerr("missing function name.");
535
putbak(BLANK);
536
return(tok);
537
}
538
else if (equal(token, incl) == NO)
539
return(tok);
540
for (i = 0 ;; i = strlen((char *) (&name[0]))) {
541
t = deftok(&name[i], MAXNAME, infile[level]);
542
if (t == NEWLINE || t == SEMICOL) {
543
pbstr(&name[i]);
544
break;
545
}
546
}
547
name[i] = EOS;
548
/*WSB 6-25-91
549
if (name[1] == SQUOTE) {
550
outtab();
551
outstr(token);
552
outstr(name);
553
outdon();
554
eatup();
555
return(tok);
556
}
557
*/
558
if (level >= NFILES)
559
synerr("includes nested too deeply.");
560
else {
561
/**/
562
name[i-1]=EOS;
563
infile[level+1] = fopen((char*)&name[2], "r");
564
/*WSB 6-25-91
565
infile[level+1] = fopen(name, "r");
566
*/
567
linect[level+1] = 1;
568
if (infile[level+1] == NULL)
569
synerr("can't open include.");
570
else {
571
level++;
572
if (fnamp + i <= MAXFNAMES) {
573
scopy(name, 0, fnames, fnamp);
574
fnamp = fnamp + i; /* push file name stack */
575
}
576
}
577
}
578
}
579
if (level > 0) { /* close include and pop file name stack */
580
fclose(infile[level]);
581
for (fnamp--; fnamp > 0; fnamp--)
582
if (fnames[fnamp-1] == EOS)
583
break;
584
}
585
}
586
token[0] = EOF; /* in case called more than once */
587
token[1] = EOS;
588
tok = EOF;
589
return(tok);
590
}
591
592
/*
593
* gnbtok - get nonblank token
594
*
595
*/
596
int
597
gnbtok(token, toksiz)
598
S_CHAR token[];
599
int toksiz;
600
{
601
int tok;
602
603
skpblk(infile[level]);
604
tok = gettok(token, toksiz);
605
return(tok);
606
}
607
608
/*
609
* gtok - get token for Ratfor
610
*
611
*/
612
int
613
gtok(lexstr, toksiz, fd)
614
S_CHAR lexstr[];
615
int toksiz;
616
FILE *fd;
617
{ int i, b, n, tok;
618
S_CHAR c;
619
c = ngetch(&lexstr[0], fd);
620
if (c == BLANK || c == TAB) {
621
lexstr[0] = BLANK;
622
while (c == BLANK || c == TAB) /* compress many blanks to one */
623
c = ngetch(&c, fd);
624
if (c == PERCENT)
625
{
626
outasis(fd); /* copy direct to output if % */
627
c = NEWLINE;
628
}
629
if (c == SHARP) {
630
if(leaveC == YES)
631
{
632
outcmnt(fd); /* copy comments to output */
633
c = NEWLINE;
634
}
635
else
636
while (ngetch(&c, fd) != NEWLINE) /* strip comments */
637
;
638
}
639
/*
640
if (c == UNDERLINE)
641
if(ngetch(&c, fd) == NEWLINE)
642
while(ngetch(&c, fd) == NEWLINE)
643
;
644
else
645
{
646
putbak(c);
647
c = UNDERLINE;
648
}
649
*/
650
if (c != NEWLINE)
651
putbak(c);
652
else
653
lexstr[0] = NEWLINE;
654
lexstr[1] = EOS;
655
return((int)lexstr[0]);
656
}
657
i = 0;
658
tok = type(c);
659
if (tok == LETTER) { /* alpha */
660
for (i = 0; i < toksiz - 3; i++) {
661
tok = type(ngetch(&lexstr[i+1], fd));
662
/* Test for DOLLAR added by BM, 7-15-80 */
663
if (tok != LETTER && tok != DIGIT
664
&& tok != UNDERLINE && tok!=DOLLAR
665
&& tok != PERIOD)
666
break;
667
}
668
putbak(lexstr[i+1]);
669
tok = ALPHA;
670
}
671
else if (tok == DIGIT) { /* digits */
672
b = c - DIG0; /* in case alternate base number */
673
for (i = 0; i < toksiz - 3; i++) {
674
if (type(ngetch(&lexstr[i+1], fd)) != DIGIT)
675
break;
676
b = 10*b + lexstr[i+1] - DIG0;
677
}
678
if (lexstr[i+1] == RADIX && b >= 2 && b <= 36) {
679
/* n%ddd... */
680
for (n = 0;; n = b*n + c - DIG0) {
681
c = ngetch(&lexstr[0], fd);
682
if (c >= LETA && c <= LETZ)
683
c = c - LETA + DIG9 + 1;
684
else if (c >= BIGA && c <= BIGZ)
685
c = c - BIGA + DIG9 + 1;
686
if (c < DIG0 || c >= DIG0 + b)
687
break;
688
}
689
putbak(lexstr[0]);
690
i = itoc(n, lexstr, toksiz);
691
}
692
else
693
putbak(lexstr[i+1]);
694
tok = DIGIT;
695
}
696
#ifdef SQUAREB
697
else if (c == LBRACK) { /* allow [ for { */
698
lexstr[0] = LBRACE;
699
tok = LBRACE;
700
}
701
else if (c == RBRACK) { /* allow ] for } */
702
lexstr[0] = RBRACE;
703
tok = RBRACE;
704
}
705
#endif
706
else if (c == SQUOTE || c == DQUOTE) {
707
for (i = 1; ngetch(&lexstr[i], fd) != lexstr[0]; i++) {
708
if (lexstr[i] == UNDERLINE)
709
if (ngetch(&c, fd) == NEWLINE) {
710
while (c == NEWLINE || c == BLANK || c == TAB)
711
c = ngetch(&c, fd);
712
lexstr[i] = c;
713
}
714
else
715
putbak(c);
716
if (lexstr[i] == NEWLINE || i >= toksiz-1) {
717
synerr("missing quote.");
718
lexstr[i] = lexstr[0];
719
putbak(NEWLINE);
720
break;
721
}
722
}
723
}
724
else if (c == PERCENT) {
725
outasis(fd); /* direct copy of protected */
726
tok = NEWLINE;
727
}
728
else if (c == SHARP) {
729
if(leaveC == YES)
730
outcmnt(fd); /* copy comments to output */
731
else
732
while (ngetch(&lexstr[0], fd) != NEWLINE) /* strip comments */
733
;
734
tok = NEWLINE;
735
}
736
else if (c == GREATER || c == LESS || c == NOT
737
|| c == BANG || c == CARET || c == EQUALS
738
|| c == AND || c == OR)
739
i = relate(lexstr, fd);
740
if (i >= toksiz-1)
741
synerr("token too long.");
742
lexstr[i+1] = EOS;
743
if (lexstr[0] == NEWLINE)
744
linect[level] = linect[level] + 1;
745
746
#if defined(CRAY) || defined(GNU)
747
/* cray cannot compare char and ints, since EOF is an int we check with feof */
748
if (feof(fd)) tok = EOF;
749
#endif
750
751
return(tok);
752
}
753
754
/*
755
* lex - return lexical type of token
756
*
757
*/
758
int
759
lex(lexstr)
760
S_CHAR lexstr[];
761
{
762
763
int tok;
764
765
for (tok = gnbtok(lexstr, MAXTOK);
766
tok == NEWLINE; tok = gnbtok(lexstr, MAXTOK))
767
;
768
if (tok == EOF || tok == SEMICOL || tok == LBRACE || tok == RBRACE)
769
return(tok);
770
if (tok == DIGIT)
771
tok = LEXDIGITS;
772
else if (equal(lexstr, sif) == YES)
773
tok = vif[0];
774
else if (equal(lexstr, selse) == YES)
775
tok = velse[0];
776
else if (equal(lexstr, swhile) == YES)
777
tok = vwhile[0];
778
else if (equal(lexstr, sdo) == YES)
779
tok = vdo[0];
780
else if (equal(lexstr, ssbreak) == YES)
781
tok = vbreak[0];
782
else if (equal(lexstr, snext) == YES)
783
tok = vnext[0];
784
else if (equal(lexstr, sfor) == YES)
785
tok = vfor[0];
786
else if (equal(lexstr, srept) == YES)
787
tok = vrept[0];
788
else if (equal(lexstr, suntil) == YES)
789
tok = vuntil[0];
790
else if (equal(lexstr, sswitch) == YES)
791
tok = vswitch[0];
792
else if (equal(lexstr, scase) == YES)
793
tok = vcase[0];
794
else if (equal(lexstr, sdefault) == YES)
795
tok = vdefault[0];
796
else if (equal(lexstr, sret) == YES)
797
tok = vret[0];
798
else if (equal(lexstr, sstr) == YES)
799
tok = vstr[0];
800
else
801
tok = LEXOTHER;
802
return(tok);
803
}
804
805
/*
806
* ngetch - get a (possibly pushed back) character
807
*
808
*/
809
S_CHAR
810
ngetch(c, fd)
811
S_CHAR *c;
812
FILE *fd;
813
{
814
815
if (bp >= 0) {
816
*c = buf[bp];
817
bp--;
818
}
819
else
820
*c = (S_CHAR) getc(fd);
821
822
/*
823
* check for a continuation '_\n'
824
* also removes UNDERLINES from
825
* variable names
826
*/
827
while ( *c == UNDERLINE)
828
{
829
if (bp >= 0) {
830
*c = buf[bp];
831
bp--;
832
}
833
else
834
*c = (S_CHAR) getc(fd);
835
836
if (*c != NEWLINE)
837
{
838
putbak(*c);
839
*c=UNDERLINE;
840
break;
841
}
842
else
843
{
844
while(*c == NEWLINE)
845
{
846
if (bp >= 0) {
847
*c = buf[bp];
848
bp--;
849
}
850
else
851
*c = (S_CHAR) getc(fd);
852
}
853
}
854
}
855
856
return(*c);
857
}
858
/*
859
* pbstr - push string back onto input
860
*
861
*/
862
pbstr(in)
863
S_CHAR in[];
864
{
865
int i;
866
867
for (i = strlen((char *) (&in[0])) - 1; i >= 0; i--)
868
putbak(in[i]);
869
}
870
871
/*
872
* putbak - push char back onto input
873
*
874
*/
875
putbak(c)
876
S_CHAR c;
877
{
878
879
bp++;
880
if (bp > BUFSIZE)
881
baderr("too many characters pushed back.");
882
buf[bp] = c;
883
}
884
885
886
/*
887
* relate - convert relational shorthands into long form
888
*
889
*/
890
int
891
relate(token, fd)
892
S_CHAR token[];
893
FILE *fd;
894
{
895
896
if (ngetch(&token[1], fd) != EQUALS) {
897
putbak(token[1]);
898
token[2] = LETT;
899
}
900
else
901
token[2] = LETE;
902
token[3] = PERIOD;
903
token[4] = EOS;
904
token[5] = EOS; /* for .not. and .and. */
905
if (token[0] == GREATER)
906
token[1] = LETG;
907
else if (token[0] == LESS)
908
token[1] = LETL;
909
else if (token[0] == NOT || token[0] == BANG || token[0] == CARET) {
910
if (token[1] != EQUALS) {
911
token[2] = LETO;
912
token[3] = LETT;
913
token[4] = PERIOD;
914
}
915
token[1] = LETN;
916
}
917
else if (token[0] == EQUALS) {
918
if (token[1] != EQUALS) {
919
token[2] = EOS;
920
return(0);
921
}
922
token[1] = LETE;
923
token[2] = LETQ;
924
}
925
else if (token[0] == AND) { /* look for && or & */
926
if (ngetch(&token[1], fd) != AND)
927
putbak(token[1]);
928
token[1] = LETA;
929
token[2] = LETN;
930
token[3] = LETD;
931
token[4] = PERIOD;
932
}
933
else if (token[0] == OR) {
934
if (ngetch(&token[1], fd) != OR) /* look for || or | */
935
putbak(token[1]);
936
token[1] = LETO;
937
token[2] = LETR;
938
}
939
else /* can't happen */
940
token[1] = EOS;
941
token[0] = PERIOD;
942
return(strlen((char *) (&token[0]))-1);
943
}
944
945
/*
946
* skpblk - skip blanks and tabs in file fd
947
*
948
*/
949
skpblk(fd)
950
FILE *fd;
951
{
952
S_CHAR c;
953
954
for (c = ngetch(&c, fd); c == BLANK || c == TAB; c = ngetch(&c, fd))
955
;
956
putbak(c);
957
}
958
959
960
/*
961
* type - return LETTER, DIGIT or char; works with ascii alphabet
962
*
963
*/
964
int
965
type(c)
966
S_CHAR c;
967
{
968
int t;
969
970
if (c >= DIG0 && c <= DIG9)
971
t = DIGIT;
972
else if (c >= LETA && c <= LETZ)
973
t = LETTER;
974
else if (c >= BIGA && c <= BIGZ)
975
t = LETTER;
976
else
977
t = c;
978
return(t);
979
}
980
981
/*
982
* C O D E G E N E R A T I O N
983
*/
984
985
/*
986
* brknxt - generate code for break n and next n; n = 1 is default
987
*/
988
brknxt(sp, lextyp, labval, token)
989
int sp;
990
int lextyp[];
991
int labval[];
992
int token;
993
{
994
int i, n;
995
S_CHAR t, ptoken[MAXTOK];
996
997
n = 0;
998
t = gnbtok(ptoken, MAXTOK);
999
if (alldig(ptoken) == YES) { /* have break n or next n */
1000
i = 0;
1001
n = ctoi(ptoken, &i) - 1;
1002
}
1003
else if (t != SEMICOL) /* default case */
1004
pbstr(ptoken);
1005
for (i = sp; i >= 0; i--)
1006
if (lextyp[i] == LEXWHILE || lextyp[i] == LEXDO
1007
|| lextyp[i] == LEXFOR || lextyp[i] == LEXREPEAT) {
1008
if (n > 0) {
1009
n--;
1010
continue; /* seek proper level */
1011
}
1012
else if (token == LEXBREAK)
1013
outgo(labval[i]+1);
1014
else
1015
outgo(labval[i]);
1016
/* original value
1017
xfer = YES;
1018
*/
1019
xfer = NO;
1020
return;
1021
}
1022
if (token == LEXBREAK)
1023
synerr("illegal break.");
1024
else
1025
synerr("illegal next.");
1026
return;
1027
}
1028
1029
/*
1030
* docode - generate code for beginning of do
1031
*
1032
*/
1033
docode(lab)
1034
int *lab;
1035
{
1036
xfer = NO;
1037
outtab();
1038
outstr(sdo);
1039
*lab = labgen(2);
1040
outnum(*lab);
1041
eatup();
1042
outdon();
1043
}
1044
1045
/*
1046
* dostat - generate code for end of do statement
1047
*
1048
*/
1049
dostat(lab)
1050
int lab;
1051
{
1052
outcon(lab);
1053
outcon(lab+1);
1054
}
1055
1056
/*
1057
* elseif - generate code for end of if before else
1058
*
1059
*/
1060
elseif(lab)
1061
int lab;
1062
{
1063
1064
#ifdef F77
1065
outtab();
1066
outstr(selse);
1067
outdon();
1068
#else
1069
outgo(lab+1);
1070
outcon(lab);
1071
#endif /* F77 */
1072
}
1073
1074
/*
1075
* forcod - beginning of for statement
1076
*
1077
*/
1078
forcod(lab)
1079
int *lab;
1080
{
1081
S_CHAR t, token[MAXTOK];
1082
int i, j, nlpar,tlab;
1083
1084
tlab = *lab;
1085
tlab = labgen(3);
1086
outcon(0);
1087
if (gnbtok(token, MAXTOK) != LPAREN) {
1088
synerr("missing left paren.");
1089
return;
1090
}
1091
if (gnbtok(token, MAXTOK) != SEMICOL) { /* real init clause */
1092
pbstr(token);
1093
outtab();
1094
eatup();
1095
outdon();
1096
}
1097
if (gnbtok(token, MAXTOK) == SEMICOL) /* empty condition */
1098
outcon(tlab);
1099
else { /* non-empty condition */
1100
pbstr(token);
1101
outnum(tlab);
1102
outtab();
1103
outstr(ifnot);
1104
outch(LPAREN);
1105
nlpar = 0;
1106
while (nlpar >= 0) {
1107
t = gettok(token, MAXTOK);
1108
if (t == SEMICOL)
1109
break;
1110
if (t == LPAREN)
1111
nlpar++;
1112
else if (t == RPAREN)
1113
nlpar--;
1114
if (t == (S_CHAR)EOF) {
1115
pbstr(token);
1116
return;
1117
}
1118
if (t != NEWLINE && t != UNDERLINE)
1119
outstr(token);
1120
}
1121
outch(RPAREN);
1122
outch(RPAREN);
1123
outgo((tlab)+2);
1124
if (nlpar < 0)
1125
synerr("invalid for clause.");
1126
}
1127
fordep++; /* stack reinit clause */
1128
j = 0;
1129
for (i = 1; i < fordep; i++) /* find end *** should i = 1 ??? *** */
1130
j = j + strlen((char *) (&forstk[j])) + 1;
1131
forstk[j] = EOS; /* null, in case no reinit */
1132
nlpar = 0;
1133
t = gnbtok(token, MAXTOK);
1134
pbstr(token);
1135
while (nlpar >= 0) {
1136
t = gettok(token, MAXTOK);
1137
if (t == LPAREN)
1138
nlpar++;
1139
else if (t == RPAREN)
1140
nlpar--;
1141
if (t == (S_CHAR)EOF) {
1142
pbstr(token);
1143
break;
1144
}
1145
if (nlpar >= 0 && t != NEWLINE && t != UNDERLINE) {
1146
if ((j + ((int) strlen((char *) (&token[0])))) >=
1147
((int) MAXFORSTK))
1148
baderr("for clause too long.");
1149
scopy(token, 0, forstk, j);
1150
j = j + strlen((char *) (&token[0]));
1151
}
1152
}
1153
tlab++; /* label for next's */
1154
*lab = tlab;
1155
}
1156
1157
/*
1158
* fors - process end of for statement
1159
*
1160
*/
1161
fors(lab)
1162
int lab;
1163
{
1164
int i, j;
1165
1166
xfer = NO;
1167
outnum(lab);
1168
j = 0;
1169
for (i = 1; i < fordep; i++)
1170
j = j + strlen((char *) (&forstk[j])) + 1;
1171
if (((int) strlen((char *) (&forstk[j]))) > ((int) 0)) {
1172
outtab();
1173
outstr(&forstk[j]);
1174
outdon();
1175
}
1176
outgo(lab-1);
1177
outcon(lab+1);
1178
fordep--;
1179
}
1180
1181
/*
1182
* ifcode - generate initial code for if
1183
*
1184
*/
1185
ifcode(lab)
1186
int *lab;
1187
{
1188
1189
xfer = NO;
1190
*lab = labgen(2);
1191
#ifdef F77
1192
ifthen();
1193
#else
1194
ifgo(*lab);
1195
#endif /* F77 */
1196
}
1197
1198
#ifdef F77
1199
/*
1200
* ifend - generate code for end of if
1201
*
1202
*/
1203
ifend()
1204
{
1205
outtab();
1206
outstr(sendif);
1207
outdon();
1208
}
1209
#endif /* F77 */
1210
1211
/*
1212
* ifgo - generate "if(.not.(...))goto lab"
1213
*
1214
*/
1215
ifgo(lab)
1216
int lab;
1217
{
1218
1219
outtab(); /* get to column 7 */
1220
outstr(ifnot); /* " if(.not. " */
1221
balpar(); /* collect and output condition */
1222
outch(RPAREN); /* " ) " */
1223
outgo(lab); /* " goto lab " */
1224
}
1225
1226
#ifdef F77
1227
/*
1228
* ifthen - generate "if((...))then"
1229
*
1230
*/
1231
ifthen()
1232
{
1233
outtab();
1234
outstr(sif);
1235
balpar();
1236
outstr(sthen);
1237
outdon();
1238
}
1239
#endif /* F77 */
1240
1241
/*
1242
* labelc - output statement number
1243
*
1244
*/
1245
labelc(lexstr)
1246
S_CHAR lexstr[];
1247
{
1248
1249
xfer = NO; /* can't suppress goto's now */
1250
if (strlen((char *) (&lexstr[0])) == 5) /* warn about 23xxx labels */
1251
if (atoi((char*)lexstr) >= startlab)
1252
synerr("warning: possible label conflict.");
1253
outstr(lexstr);
1254
outtab();
1255
}
1256
1257
/*
1258
* labgen - generate n consecutive labels, return first one
1259
*
1260
*/
1261
int
1262
labgen(n)
1263
int n;
1264
{
1265
int i;
1266
1267
i = label;
1268
label = label + n;
1269
return(i);
1270
}
1271
1272
/*
1273
* otherc - output ordinary Fortran statement
1274
*
1275
*/
1276
otherc(lexstr)
1277
S_CHAR lexstr[];
1278
{
1279
xfer = NO;
1280
outtab();
1281
outstr(lexstr);
1282
eatup();
1283
outdon();
1284
}
1285
1286
/*
1287
* outch - put one char into output buffer
1288
*
1289
*/
1290
outch(c)
1291
S_CHAR c;
1292
{
1293
int i;
1294
1295
if (outp >= 72) { /* continuation card */
1296
outdon();
1297
for (i = 0; i < 6; i++)
1298
outbuf[i] = BLANK;
1299
outbuf[5]='*';
1300
outp = 6;
1301
}
1302
outbuf[outp] = c;
1303
outp++;
1304
}
1305
1306
/*
1307
* outcon - output "n continue"
1308
*
1309
*/
1310
outcon(n)
1311
int n;
1312
{
1313
xfer = NO;
1314
if (n <= 0 && outp == 0)
1315
return; /* don't need unlabeled continues */
1316
if (n > 0)
1317
outnum(n);
1318
outtab();
1319
outstr(contin);
1320
outdon();
1321
}
1322
1323
/*
1324
* outdon - finish off an output line
1325
*
1326
*/
1327
outdon()
1328
{
1329
1330
outbuf[outp] = NEWLINE;
1331
outbuf[outp+1] = EOS;
1332
printf("%s", outbuf);
1333
outp = 0;
1334
}
1335
1336
/*
1337
* outcmnt - copy comment to output
1338
*
1339
*/
1340
outcmnt(fd)
1341
FILE * fd;
1342
{
1343
S_CHAR c;
1344
S_CHAR comout[81];
1345
int i, comoutp=0;
1346
1347
comoutp=1;
1348
comout[0]='C';
1349
while((c=ngetch(&c,fd)) != NEWLINE) {
1350
if (comoutp > 79) {
1351
comout[80]=NEWLINE;
1352
comout[81]=EOS;
1353
printf("%s",comout);
1354
comoutp=0;
1355
comout[comoutp]='C';
1356
comoutp++;
1357
}
1358
comout[comoutp]=c;
1359
comoutp++;
1360
}
1361
comout[comoutp]=NEWLINE;
1362
comout[comoutp+1]=EOS;
1363
printf("%s",comout);
1364
}
1365
1366
/*
1367
* outasis - copy directly out
1368
*
1369
*/
1370
outasis(fd)
1371
FILE * fd;
1372
{
1373
S_CHAR c;
1374
while((c=ngetch(&c,fd)) != NEWLINE)
1375
outch(c);
1376
outdon();
1377
}
1378
1379
/*
1380
* outgo - output "goto n"
1381
*
1382
*/
1383
outgo(n)
1384
int n;
1385
{
1386
if (xfer == YES)
1387
return;
1388
outtab();
1389
outstr(rgoto);
1390
outnum(n);
1391
outdon();
1392
}
1393
1394
/*
1395
* outnum - output decimal number
1396
*
1397
*/
1398
outnum(n)
1399
int n;
1400
{
1401
1402
S_CHAR chars[MAXCHARS];
1403
int i, m;
1404
1405
m = abs(n);
1406
i = -1;
1407
do {
1408
i++;
1409
chars[i] = (m % 10) + DIG0;
1410
m = m / 10;
1411
}
1412
while (m > 0 && i < MAXCHARS);
1413
if (n < 0)
1414
outch(MINUS);
1415
for ( ; i >= 0; i--)
1416
outch(chars[i]);
1417
}
1418
1419
1420
1421
/*
1422
* outstr - output string
1423
*
1424
*/
1425
outstr(str)
1426
S_CHAR str[];
1427
{
1428
int i;
1429
1430
for (i=0; str[i] != EOS; i++)
1431
outch(str[i]);
1432
}
1433
1434
/*
1435
* outtab - get past column 6
1436
*
1437
*/
1438
outtab()
1439
{
1440
while (outp < 6)
1441
outch(BLANK);
1442
}
1443
1444
1445
/*
1446
* repcod - generate code for beginning of repeat
1447
*
1448
*/
1449
repcod(lab)
1450
int *lab;
1451
{
1452
1453
int tlab;
1454
1455
tlab = *lab;
1456
outcon(0); /* in case there was a label */
1457
tlab = labgen(3);
1458
outcon(tlab);
1459
*lab = ++tlab; /* label to go on next's */
1460
}
1461
1462
/*
1463
* retcod - generate code for return
1464
*
1465
*/
1466
retcod()
1467
{
1468
S_CHAR token[MAXTOK], t;
1469
1470
t = gnbtok(token, MAXTOK);
1471
if (t != NEWLINE && t != SEMICOL && t != RBRACE) {
1472
pbstr(token);
1473
outtab();
1474
outstr(fcname);
1475
outch(EQUALS);
1476
eatup();
1477
outdon();
1478
}
1479
else if (t == RBRACE)
1480
pbstr(token);
1481
outtab();
1482
outstr(sret);
1483
outdon();
1484
xfer = YES;
1485
}
1486
1487
1488
/* strdcl - generate code for string declaration */
1489
strdcl()
1490
{
1491
S_CHAR t, name[MAXNAME], init[MAXTOK];
1492
int i, len;
1493
1494
t = gnbtok(name, MAXNAME);
1495
if (t != ALPHA)
1496
synerr("missing string name.");
1497
if (gnbtok(init, MAXTOK) != LPAREN) { /* make size same as initial value */
1498
len = strlen((char *) (&init[0])) + 1;
1499
if (init[1] == SQUOTE || init[1] == DQUOTE)
1500
len = len - 2;
1501
}
1502
else { /* form is string name(size) init */
1503
t = gnbtok(init, MAXTOK);
1504
i = 0;
1505
len = ctoi(init, &i);
1506
if (init[i] != EOS)
1507
synerr("invalid string size.");
1508
if (gnbtok(init, MAXTOK) != RPAREN)
1509
synerr("missing right paren.");
1510
else
1511
t = gnbtok(init, MAXTOK);
1512
}
1513
outtab();
1514
/*
1515
* outstr(int);
1516
*/
1517
outstr(name);
1518
outch(LPAREN);
1519
outnum(len);
1520
outch(RPAREN);
1521
outdon();
1522
outtab();
1523
outstr(dat);
1524
len = strlen((char *)(&init[0])) + 1;
1525
if (init[0] == SQUOTE || init[0] == DQUOTE) {
1526
init[len-1] = EOS;
1527
scopy(init, 1, init, 0);
1528
len = len - 2;
1529
}
1530
for (i = 1; i <= len; i++) { /* put out variable names */
1531
outstr(name);
1532
outch(LPAREN);
1533
outnum(i);
1534
outch(RPAREN);
1535
if (i < len)
1536
outch(COMMA);
1537
else
1538
outch(SLASH);
1539
;
1540
}
1541
for (i = 0; init[i] != EOS; i++) { /* put out init */
1542
outnum(init[i]);
1543
outch(COMMA);
1544
}
1545
pbstr(eoss); /* push back EOS for subsequent substitution */
1546
}
1547
1548
1549
/*
1550
* unstak - unstack at end of statement
1551
*
1552
*/
1553
unstak(sp, lextyp, labval, token)
1554
int *sp;
1555
int lextyp[];
1556
int labval[];
1557
S_CHAR token;
1558
{
1559
int tp;
1560
1561
tp = *sp;
1562
for ( ; tp > 0; tp--) {
1563
if (lextyp[tp] == LBRACE)
1564
break;
1565
if (lextyp[tp] == LEXSWITCH)
1566
break;
1567
if (lextyp[tp] == LEXIF && token == LEXELSE)
1568
break;
1569
if (lextyp[tp] == LEXIF)
1570
#ifdef F77
1571
ifend();
1572
#else
1573
outcon(labval[tp]);
1574
#endif /* F77 */
1575
else if (lextyp[tp] == LEXELSE) {
1576
if (*sp > 1)
1577
tp--;
1578
#ifdef F77
1579
ifend();
1580
#else
1581
outcon(labval[tp]+1);
1582
#endif /* F77 */
1583
}
1584
else if (lextyp[tp] == LEXDO)
1585
dostat(labval[tp]);
1586
else if (lextyp[tp] == LEXWHILE)
1587
whiles(labval[tp]);
1588
else if (lextyp[tp] == LEXFOR)
1589
fors(labval[tp]);
1590
else if (lextyp[tp] == LEXREPEAT)
1591
untils(labval[tp], token);
1592
}
1593
*sp = tp;
1594
}
1595
1596
/*
1597
* untils - generate code for until or end of repeat
1598
*
1599
*/
1600
untils(lab, token)
1601
int lab;
1602
int token;
1603
{
1604
S_CHAR ptoken[MAXTOK];
1605
1606
xfer = NO;
1607
outnum(lab);
1608
if (token == LEXUNTIL) {
1609
lex(ptoken);
1610
ifgo(lab-1);
1611
}
1612
else
1613
outgo(lab-1);
1614
outcon(lab+1);
1615
}
1616
1617
/*
1618
* whilec - generate code for beginning of while
1619
*
1620
*/
1621
whilec(lab)
1622
int *lab;
1623
{
1624
int tlab;
1625
1626
tlab = *lab;
1627
outcon(0); /* unlabeled continue, in case there was a label */
1628
tlab = labgen(2);
1629
outnum(tlab);
1630
#ifdef F77
1631
ifthen();
1632
#else
1633
ifgo(tlab+1);
1634
#endif /* F77 */
1635
*lab = tlab;
1636
}
1637
1638
/*
1639
* whiles - generate code for end of while
1640
*
1641
*/
1642
whiles(lab)
1643
int lab;
1644
{
1645
1646
outgo(lab);
1647
#ifdef F77
1648
ifend();
1649
#endif /* F77 */
1650
outcon(lab+1);
1651
}
1652
1653
/*
1654
* E R R O R M E S S A G E S
1655
*/
1656
1657
/*
1658
* baderr - print error message, then die
1659
*/
1660
baderr(msg)
1661
S_CHAR msg[];
1662
{
1663
synerr(msg);
1664
exit(1);
1665
}
1666
1667
/*
1668
* error - print error message with one parameter, then die
1669
*/
1670
error(msg, s)
1671
char *msg;
1672
S_CHAR *s;
1673
{
1674
fprintf(stderr, msg,s);
1675
exit(1);
1676
}
1677
1678
/*
1679
* synerr - report Ratfor syntax error
1680
*/
1681
synerr(msg)
1682
S_CHAR *msg;
1683
{
1684
S_CHAR lc[MAXCHARS];
1685
int i;
1686
1687
fprintf(stderr,errmsg);
1688
if (level >= 0)
1689
i = level;
1690
else
1691
i = 0; /* for EOF errors */
1692
itoc(linect[i], lc, MAXCHARS);
1693
fprintf(stderr,(char*)lc);
1694
for (i = fnamp - 1; i > 1; i = i - 1)
1695
if (fnames[i-1] == EOS) { /* print file name */
1696
fprintf(stderr,in);
1697
fprintf(stderr,(char*)&fnames[i]);
1698
break;
1699
}
1700
fprintf(stderr,": \n %s\n",msg);
1701
}
1702
1703
1704
/*
1705
* U T I L I T Y R O U T I N E S
1706
*/
1707
1708
/*
1709
* ctoi - convert string at in[i] to int, increment i
1710
*/
1711
int
1712
ctoi(in, i)
1713
S_CHAR in[];
1714
int *i;
1715
{
1716
int k, j;
1717
1718
j = *i;
1719
while (in[j] == BLANK || in[j] == TAB)
1720
j++;
1721
for (k = 0; in[j] != EOS; j++) {
1722
if (in[j] < DIG0 || in[j] > DIG9)
1723
break;
1724
k = 10 * k + in[j] - DIG0;
1725
}
1726
*i = j;
1727
return(k);
1728
}
1729
1730
/*
1731
* fold - convert alphabetic token to single case
1732
*
1733
*/
1734
fold(token)
1735
S_CHAR token[];
1736
{
1737
1738
int i;
1739
1740
/* WARNING - this routine depends heavily on the */
1741
/* fact that letters have been mapped into internal */
1742
/* right-adjusted ascii. god help you if you */
1743
/* have subverted this mechanism. */
1744
1745
for (i = 0; token[i] != EOS; i++)
1746
if (token[i] >= BIGA && token[i] <= BIGZ)
1747
token[i] = token[i] - BIGA + LETA;
1748
}
1749
1750
/*
1751
* equal - compare str1 to str2; return YES if equal, NO if not
1752
*
1753
*/
1754
int
1755
equal(str1, str2)
1756
S_CHAR str1[];
1757
S_CHAR str2[];
1758
{
1759
int i;
1760
1761
for (i = 0; str1[i] == str2[i]; i++)
1762
if (str1[i] == EOS)
1763
return(YES);
1764
return(NO);
1765
}
1766
1767
/*
1768
* scopy - copy string at from[i] to to[j]
1769
*
1770
*/
1771
scopy(from, i, to, j)
1772
S_CHAR from[];
1773
int i;
1774
S_CHAR to[];
1775
int j;
1776
{
1777
int k1, k2;
1778
1779
k2 = j;
1780
for (k1 = i; from[k1] != EOS; k1++) {
1781
to[k2] = from[k1];
1782
k2++;
1783
}
1784
to[k2] = EOS;
1785
}
1786
1787
#include "lookup.h"
1788
/*
1789
* look - look-up a definition
1790
*
1791
*/
1792
int
1793
look(name,defn)
1794
S_CHAR name[];
1795
S_CHAR defn[];
1796
{
1797
extern struct hashlist *lookup();
1798
struct hashlist *p;
1799
1800
if ((p = lookup(name)) == NULL)
1801
return(NO);
1802
(void) strcpy((char *) (&defn[0]),(char *) (&((p->def)[0])));
1803
return(YES);
1804
}
1805
1806
/*
1807
* itoc - special version of itoa
1808
*/
1809
int
1810
itoc(n,str,size)
1811
int n;
1812
S_CHAR str[];
1813
int size;
1814
{
1815
int i,j,k,sign;
1816
S_CHAR c;
1817
1818
if ((sign = n) < 0)
1819
n = -n;
1820
i = 0;
1821
do {
1822
str[i++] = n % 10 + '0';
1823
}
1824
while ((n /= 10) > 0 && i < size-2);
1825
if (sign < 0 && i < size-1)
1826
str[i++] = '-';
1827
str[i] = EOS;
1828
/*
1829
* reverse the string and plug it back in
1830
*/
1831
for (j = 0, k = strlen((char *) (&str[0])) - 1; j < k; j++, k--) {
1832
c = str[j];
1833
str[j] = str[k];
1834
str[k] = c;
1835
}
1836
return(i-1);
1837
}
1838
1839
/*
1840
* cascod - generate code for case or default label
1841
*
1842
*/
1843
cascod (lab, token)
1844
int lab;
1845
int token;
1846
{
1847
int t, l, lb, ub, i, j, junk;
1848
S_CHAR scrtok[MAXTOK];
1849
1850
if (swtop <= 0) {
1851
synerr ("illegal case or default.");
1852
return;
1853
}
1854
outgo(lab + 1); /* # terminate previous case */
1855
xfer = YES;
1856
l = labgen(1);
1857
if (token == LEXCASE) { /* # case n[,n]... : ... */
1858
while (caslab (&lb, &t) != EOF) {
1859
ub = lb;
1860
if (t == MINUS)
1861
junk = caslab (&ub, &t);
1862
if (lb > ub) {
1863
synerr ("illegal range in case label.");
1864
ub = lb;
1865
}
1866
if (swlast + 3 > MAXSWITCH)
1867
baderr ("switch table overflow.");
1868
for (i = swtop + 3; i < swlast; i = i + 3)
1869
if (lb <= swstak[i])
1870
break;
1871
else if (lb <= swstak[i+1])
1872
synerr ("duplicate case label.");
1873
if (i < swlast && ub >= swstak[i])
1874
synerr ("duplicate case label.");
1875
for (j = swlast; j > i; j--) /* # insert new entry */
1876
swstak[j+2] = swstak[j-1];
1877
swstak[i] = lb;
1878
swstak[i + 1] = ub;
1879
swstak[i + 2] = l;
1880
swstak[swtop + 1] = swstak[swtop + 1] + 1;
1881
swlast = swlast + 3;
1882
if (t == COLON)
1883
break;
1884
else if (t != COMMA)
1885
synerr ("illegal case syntax.");
1886
}
1887
}
1888
else { /* # default : ... */
1889
t = gnbtok (scrtok, MAXTOK);
1890
if (swstak[swtop + 2] != 0)
1891
baderr ("multiple defaults in switch statement.");
1892
else
1893
swstak[swtop + 2] = l;
1894
}
1895
1896
if (t == EOF)
1897
synerr ("unexpected EOF.");
1898
else if (t != COLON)
1899
baderr ("missing colon in case or default label.");
1900
1901
xfer = NO;
1902
outcon (l);
1903
}
1904
1905
/*
1906
* caslab - get one case label
1907
*
1908
*/
1909
int
1910
caslab (n, t)
1911
int *n;
1912
int *t;
1913
{
1914
S_CHAR tok[MAXTOK];
1915
int i, s;
1916
1917
*t = gnbtok (tok, MAXTOK);
1918
while (*t == NEWLINE)
1919
*t = gnbtok (tok, MAXTOK);
1920
if (*t == EOF)
1921
return (*t);
1922
if (*t == MINUS)
1923
s = -1;
1924
else
1925
s = 1;
1926
if (*t == MINUS || *t == PLUS)
1927
*t = gnbtok (tok, MAXTOK);
1928
if (*t != DIGIT) {
1929
synerr ("invalid case label.");
1930
*n = 0;
1931
}
1932
else {
1933
i = 0;
1934
*n = s * ctoi (tok, &i);
1935
}
1936
*t = gnbtok (tok, MAXTOK);
1937
while (*t == NEWLINE)
1938
*t = gnbtok (tok, MAXTOK);
1939
}
1940
1941
/*
1942
* swcode - generate code for switch stmt.
1943
*
1944
*/
1945
swcode (lab)
1946
int *lab;
1947
{
1948
S_CHAR scrtok[MAXTOK];
1949
1950
*lab = labgen (2);
1951
if (swlast + 3 > MAXSWITCH)
1952
baderr ("switch table overflow.");
1953
swstak[swlast] = swtop;
1954
swstak[swlast + 1] = 0;
1955
swstak[swlast + 2] = 0;
1956
swtop = swlast;
1957
swlast = swlast + 3;
1958
xfer = NO;
1959
outtab(); /* # Innn=(e) */
1960
swvar(*lab);
1961
outch(EQUALS);
1962
balpar();
1963
outdon();
1964
outgo(*lab); /* # goto L */
1965
xfer = YES;
1966
while (gnbtok (scrtok, MAXTOK) == NEWLINE)
1967
;
1968
if (scrtok[0] != LBRACE) {
1969
synerr ("missing left brace in switch statement.");
1970
pbstr (scrtok);
1971
}
1972
}
1973
1974
/*
1975
* swend - finish off switch statement; generate dispatch code
1976
*
1977
*/
1978
swend(lab)
1979
int lab;
1980
{
1981
int lb, ub, n, i, j;
1982
1983
static char *sif = "if (";
1984
static char *slt = ".lt.1.or.";
1985
static char *sgt = ".gt.";
1986
static char *sgoto = "goto (";
1987
static char *seq = ".eq.";
1988
static char *sge = ".ge.";
1989
static char *sle = ".le.";
1990
static char *sand = ".and.";
1991
1992
lb = swstak[swtop + 3];
1993
ub = swstak[swlast - 2];
1994
n = swstak[swtop + 1];
1995
outgo(lab + 1); /* # terminate last case */
1996
if (swstak[swtop + 2] == 0)
1997
swstak[swtop + 2] = lab + 1; /* # default default label */
1998
xfer = NO;
1999
outcon (lab); /* L continue */
2000
/* output branch table */
2001
/*
2002
if (n >= CUTOFF && ub - lb < DENSITY * n) {
2003
if (lb != 0) { * L Innn=Innn-lb *
2004
outtab();
2005
swvar (lab);
2006
outch (EQUALS);
2007
swvar (lab);
2008
if (lb < 0)
2009
outch (PLUS);
2010
outnum (-lb + 1);
2011
outdon();
2012
}
2013
outtab(); * if (Innn.lt.1.or.Innn.gt.ub-lb+1)goto default *
2014
outstr (sif);
2015
swvar (lab);
2016
outstr (slt);
2017
swvar (lab);
2018
outstr (sgt);
2019
outnum (ub - lb + 1);
2020
outch (RPAREN);
2021
outgo (swstak[swtop + 2]);
2022
outtab();
2023
outstr (sgoto); * goto ... *
2024
j = lb;
2025
for (i = swtop + 3; i < swlast; i = i + 3) {
2026
* # fill in vacancies *
2027
for ( ; j < swstak[i]; j++) {
2028
outnum(swstak[swtop + 2]);
2029
outch(COMMA);
2030
}
2031
for (j = swstak[i + 1] - swstak[i]; j >= 0; j--)
2032
outnum(swstak[i + 2]); * # fill in range *
2033
j = swstak[i + 1] + 1;
2034
if (i < swlast - 3)
2035
outch(COMMA);
2036
}
2037
outch(RPAREN);
2038
outch(COMMA);
2039
swvar(lab);
2040
outdon();
2041
}
2042
else if (n > 0) { * # output linear search form *
2043
*/
2044
if (n > 0) { /* # output linear search form */
2045
for (i = swtop + 3; i < swlast; i = i + 3) {
2046
outtab(); /* # if (Innn */
2047
outstr (sif);
2048
swvar (lab);
2049
if (swstak[i] == swstak[i+1]) {
2050
outstr (seq); /* # .eq....*/
2051
outnum (swstak[i]);
2052
}
2053
else {
2054
outstr (sge); /* # .ge.lb.and.Innn.le.ub */
2055
outnum (swstak[i]);
2056
outstr (sand);
2057
swvar (lab);
2058
outstr (sle);
2059
outnum (swstak[i + 1]);
2060
}
2061
outch (RPAREN); /* # ) goto ... */
2062
outgo (swstak[i + 2]);
2063
}
2064
if (lab + 1 != swstak[swtop + 2])
2065
outgo (swstak[swtop + 2]);
2066
}
2067
outcon (lab + 1); /* # L+1 continue */
2068
swlast = swtop; /* # pop switch stack */
2069
swtop = swstak[swtop];
2070
}
2071
2072
/*
2073
* swvar - output switch variable Innn, where nnn = lab
2074
*/
2075
swvar (lab)
2076
int lab;
2077
{
2078
2079
outch ('I');
2080
outnum (lab);
2081
}
Loggerhead is a web-based interface for Breezy
Version: 2.0.1