« back to all changes in this revision
Viewing changes to .pc/16-Web--ratfor.web.patch/Web/ratfor.web
- browse files at revision 4
- compare with another revision
- download diff
- download tarball
- view history from revision 4
- Committer: Package Import Robot
- Author(s): Jari Aalto
- Date: 2011-11-18 21:05:43 UTC
- Revision ID: package-import@ubuntu.com-20111118210543-i4gn84g98pi86war
Tags: 1.62-11.1
* Non-maintainer upload.
- Move to packaging format "3.0 (quilt)".
* debian/compat
- Update to 8.
* debian/control
- (Build-Depends): update to debhelper 8.
- (Description): Adjust first line (lintian).
- (Homepage): Add.
- (Recommends): Change to tetex-base to texlive (Closes: #601268).
- (Standards-Version): Update to 3.9.2.
- (Suggests): Remove tetex-base.
Package fweb-doc
- (Description): Extend first line (Lintian).
- (Depends): Add ${misc:Depends}, add dpkg (>= 1.15.4) | install-info
- (Section): Add doc.
* debian/copyright
- Remove obsolete FSF address. Correct GPL path.
* debian/idxmerge.1
- Fix hyphen-used-as-minus-sign (Lintian).
* debian/patches
- New. Convert embedded changes to upstream code into individual patches.
* debian/rules
- Replace obsolete dh_clean with dh_prep
- (build-arch, build-indep): New (W: Lintian).
- (clean): Adjust make call Web/Makefile (Lintian).
Delete generated files: Web/fweave.mds Web/fweave.ndx
- (docdir): Install docs to $package-doc.
- (infodir): New variable.
- (install): Don't create directory doc-base (lintian).
Don't create empty info dir (Lintian).
- (tmpdir): Install to $package, not tmp dir thus no longer needing
dh_movefiles.
* debian/source/format
- New file.
* fweb-doc.doc-base
- (Section): Update from Apps/Programming to Programming.
- Move to packaging format "3.0 (quilt)".
* debian/compat
- Update to 8.
* debian/control
- (Build-Depends): update to debhelper 8.
- (Description): Adjust first line (lintian).
- (Homepage): Add.
- (Recommends): Change to tetex-base to texlive (Closes: #601268).
- (Standards-Version): Update to 3.9.2.
- (Suggests): Remove tetex-base.
Package fweb-doc
- (Description): Extend first line (Lintian).
- (Depends): Add ${misc:Depends}, add dpkg (>= 1.15.4) | install-info
- (Section): Add doc.
* debian/copyright
- Remove obsolete FSF address. Correct GPL path.
* debian/idxmerge.1
- Fix hyphen-used-as-minus-sign (Lintian).
* debian/patches
- New. Convert embedded changes to upstream code into individual patches.
* debian/rules
- Replace obsolete dh_clean with dh_prep
- (build-arch, build-indep): New (W: Lintian).
- (clean): Adjust make call Web/Makefile (Lintian).
Delete generated files: Web/fweave.mds Web/fweave.ndx
- (docdir): Install docs to $package-doc.
- (infodir): New variable.
- (install): Don't create directory doc-base (lintian).
Don't create empty info dir (Lintian).
- (tmpdir): Install to $package, not tmp dir thus no longer needing
dh_movefiles.
* debian/source/format
- New file.
* fweb-doc.doc-base
- (Section): Update from Apps/Programming to Programming.
- files added:
- .pc
- .pc/01-Web--Makefile.patch
- .pc/01-Web--Makefile.patch/Web
- .pc/02-Web--configure.patch
- .pc/02-Web--configure.patch/Web
- .pc/10-Manual--fweb.texi.patch
- .pc/10-Manual--fweb.texi.patch/Manual
- .pc/12-Web--common.web.patch
- .pc/12-Web--common.web.patch/Web
- .pc/14-Web--fweave.web.patch
- .pc/14-Web--fweave.web.patch/Web
- .pc/16-Web--ratfor.web.patch
- .pc/16-Web--ratfor.web.patch/Web
- .pc/18-Web--style.web.patch
- .pc/18-Web--style.web.patch/Web
- .pc/20-Web--common.c.patch
- .pc/20-Web--common.c.patch/Web
- .pc/22-Web--fweave.c.patch
- .pc/22-Web--fweave.c.patch/Web
- .pc/24-Web--ratfor.c.patch
- .pc/24-Web--ratfor.c.patch/Web
- .pc/26-Web--style.c.patch
- .pc/26-Web--style.c.patch/Web
- debian/patches
- debian/source
- files removed:
- Web/fweave.mds
- files modified:
- debian/changelog
added
removed
.pc/16-Web--ratfor.web.patch/Web/ratfor.web
1
@z --- ratfor.web ---
2
3
FWEB version 1.62 (September 25, 1998)
4
5
Based on version 0.5 of S. Levy's CWEB [copyright (C) 1987 Princeton University]
6
7
@x-----------------------------------------------------------------------------
8
9
10
\Title{RATFOR.WEB} % Ratfor statement translation for FTANGLE.
11
12
@c
13
@* RATFOR. Here we endow \FTANGLE\ with a \RATFOR-like syntax that will
14
be expanded directly into \Fortran\ code. This processing will work
15
during the output phase involving |get_output()| and |out_char()|.
16
17
This code is recent; the initial goal was to achieve functionality. Some
18
improvements are obvious. In particular, the \RATFOR\ tokens and associated
19
functions should be better integrated into the list of all tokens, instead
20
of being held in a separate list. This improvement will be made in future
21
versions.
22
23
@m _RATFOR_
24
@d _RATFOR_h
25
@d _ratfor_ /* Used in \.{r\_type.web}. */
26
27
@A
28
@<Possibly split into parts@>@;
29
30
@<Include files@>@;
31
@<Typedef declarations@>@;
32
@<Prototypes@>@;
33
@<Global variables@>@;
34
35
/* For pc's, the file is split into two compilable parts using the
36
compiler-line macro |part|, which must equal either~1 or~2. */
37
#if(part != 2)
38
@<Part 1@>@;
39
#endif /* Part 1 */
40
41
#if(part != 1)
42
@<Part 2@>@;
43
#endif /* Part 2 */
44
45
@I typedefs.hweb /* Declarations common to both \FTANGLE\ and \FWEAVE. */
46
47
@I t_codes.hweb /* Definitions of some constants. */
48
@I texts.hweb
49
@I stacks.hweb
50
@I val.hweb
51
@I macs.hweb
52
@I trunc.hweb
53
54
@
55
@<Include...@>=
56
#include "map.h"
57
58
@ The function prototypes must appear before the global variables.
59
@<Proto...@>=
60
61
#include "t_type.h" /* Function prototypes for everything. */
62
63
@ We need to declare variables defined in \FTANGLE.
64
65
@d UNNAMED_MODULE 0
66
@d N_IDBUF 100
67
68
@<Glob...@>=
69
70
EXTERN boolean mac_protected,in_string;
71
EXTERN text_pointer macro_text;
72
EXTERN long cur_val;
73
EXTERN OUTPUT_STATE out_state;
74
EXTERN int indent_level,out_pos,rst_pos,indnt_size;
75
EXTERN eight_bits sent;
76
77
IN_COMMON STMT_LBL max_stmt;
78
IN_COMMON sixteen_bits outp_line[];
79
80
@ We need to know whether this whole package has been linked on.
81
82
@<Part 1@>=@[
83
84
SRTN
85
is_Rat_present(VOID)
86
{
87
Rat_is_loaded = YES;
88
}
89
90
@
91
@<Part 1@>=@[
92
93
boolean
94
Rat_OK FCN((msg))
95
outer_char *msg C1("")@;
96
{
97
return YES;
98
}
99
100
@ Here are the various special tokens:
101
102
@<Global variables@>=
103
104
/* Expandable input tokens. */
105
IN_RATFOR sixteen_bits
106
id_block, id_blockdata, id_break,
107
id_case,
108
#if(0)
109
id_continue,
110
#endif
111
id_default, id_do,
112
id_else, id_elseif, id_end,
113
id_endif,
114
id_for,
115
#if(0)
116
id_goto,
117
#endif
118
id_if,
119
id_next, id_procedure, id_repeat,
120
id_return, id_switch, id_then, id_until,
121
id_while;
122
123
IN_RATFOR sixteen_bits id_function,id_program,id_subroutine;
124
125
IN_RATFOR sixteen_bits
126
id_contains, id_elsewhere, id_endinterface, id_endtype, id_endmodule,
127
id_endselect, id_endwhere, id_interface, id_module, id_type, id_where;
128
129
/* Non-expandable input tokens. */
130
IN_RATFOR sixteen_bits id_data;
131
132
/* Output tokens. */
133
IN_RATFOR sixteen_bits
134
id__CASE,id__CONTINUE,id__DEFAULT,
135
id__DO,id__ELSE,id__ELSEIF,id__END,
136
id__ENDIF,id__EXIT,id__GOTO,id__IF,
137
id__RETURN,id__THEN,
138
id__WHILE;
139
140
/* More output tokens for \Fortran--90. */
141
IN_RATFOR sixteen_bits
142
id__CONTAINS,id__CYCLE,id__ENDWHERE,id__INTERFACE,id__MODULE,
143
id__SELECT,id__TYPE,id__WHERE;
144
145
@% static sixteen_bits id__ELSEWHERE; // This must be worked on.
146
147
/* The following tokens are printed as the result of \Ratfor\ translation.
148
(The lengths are filled in by |ini_out_tokens|.) */
149
IN_RATFOR SPEC out_tokens[]
150
#if(part == 0 || part == 1)
151
= {
152
{"CASE",0,NULL,&id__CASE},
153
{"CONTINUE",0,NULL,&id__CONTINUE},
154
{"DEFAULT",0,NULL,&id__DEFAULT},
155
{"DO",0,NULL,&id__DO},
156
{"ELSE",0,NULL,&id__ELSE},
157
{"ELSEIF",0,NULL,&id__ELSEIF},
158
{"END",0,NULL,&id__END},
159
{"ENDIF",0,NULL,&id__ENDIF},
160
{"EXIT",0,NULL,&id__EXIT},
161
{"GOTO",0,NULL,&id__GOTO},
162
{"IF",0,NULL,&id__IF},
163
{"RETURN",0,NULL,&id__RETURN},
164
{"THEN",0,NULL,&id__THEN},
165
{"WHILE",0,NULL,&id__WHILE},
166
{"",0,NULL,NULL}
167
}
168
#endif
169
;
170
171
IN_RATFOR SPEC out90_tokens[]
172
#if(part == 0 || part == 1)
173
= {
174
{"CONTAINS",0,NULL,&id__CONTAINS},
175
{"CYCLE",0,NULL,&id__CYCLE},
176
{"ENDWHERE",0,NULL,&id__ENDWHERE},
177
{"INTERFACE",0,NULL,&id__INTERFACE},
178
{"MODULE",0,NULL,&id__MODULE},
179
{"SELECT",0,NULL,&id__SELECT},
180
{"TYPE",0,NULL,&id__TYPE},
181
{"WHERE",0,NULL,&id__WHERE},
182
{"",0,NULL,NULL}
183
}
184
#endif
185
;
186
187
/* The following is used during \FORTRAN-88\ |case| expansion to see
188
whether the last |case| ended with |break|. */
189
eight_bits break_tokens[3];
190
191
/* These are the special \Ratfor\ tokens that are expanded. */
192
IN_RATFOR SPEC spec_tokens[]
193
#if(part == 0 || part == 1)
194
= {
195
{"block",0,x_block,&id_block},
196
{"blockdata",0,x_blockdata,&id_blockdata},
197
{"break",0,x_break,&id_break},
198
{"case",0,(X_FCN (*@e)(VOID))x_case,&id_case},
199
{"default",0,(X_FCN (*@e)(VOID))x_default,&id_default},
200
{"do",0,x_do,&id_do},
201
{"else",0,x_else,&id_else},
202
{"elseif",0,x_els_if,&id_elseif},
203
{"end",0,x_end,&id_end},
204
{"endif",0,x_en_if,&id_endif},
205
{"for",0,x_for,&id_for},
206
{"function",0,x_function,&id_function},
207
{"if",0,x_if,&id_if},
208
{"next",0,x_next,&id_next},
209
{"procedure",0,x_procedure,&id_procedure},
210
{"program",0,x_program,&id_program},
211
{"repeat",0,x_repeat,&id_repeat},
212
{"return",0,x_return,&id_return},
213
{"switch",0,x_switch,&id_switch},
214
{"subroutine",0,x_subroutine,&id_subroutine},
215
{"then",0,x_then,&id_then},
216
{"until",0,x_until,&id_until},
217
{"while",0,x_while,&id_while},
218
{"",0,NULL,NULL}
219
}
220
#endif
221
;
222
223
/* \Fortran--90. */
224
IN_RATFOR SPEC spec90_tokens[]
225
#if(part == 0 || part == 1)
226
= {
227
{"contains",0,x_contains,&id_contains},
228
{"endinterface",0,x_en_interface,&id_endinterface},
229
{"endmodule",0,x_en_module,&id_endmodule},
230
{"endselect",0,x_en_select,&id_endselect},
231
{"endtype",0,x_en_type,&id_endtype},
232
{"endwhere",0,x_en_where,&id_endwhere},
233
{"interface",0,x_interface,&id_interface},
234
{"module",0,x_module,&id_module},
235
{"type",0,x_type,&id_type},
236
{"where",0,x_where,&id_where},
237
{"",0,NULL,NULL}
238
}
239
#endif
240
;
241
242
@ Interface to \.{reserved}; initialize the special \Ratfor\ tables.
243
244
@<Part 1@>=@[
245
246
SRTN
247
ini_RAT_tokens FCN((language0))
248
LANGUAGE language0 C1("")@;
249
{
250
switch(language0)
251
{
252
case RATFOR_90:
253
ini_special_tokens(language0,spec90_tokens);
254
ini_out_tokens(out90_tokens);
255
256
/* The previous case falls through to here! */
257
case RATFOR:
258
ini_special_tokens(language0,spec_tokens);// Initialize special tokens.
259
ini_out_tokens(out_tokens); // Printed during Ratfor expansion.
260
break;
261
262
default:
263
CONFUSION("ini_RAT_tokens","Language should be RATFOR-like here");
264
}
265
266
ini_univ_tokens(language0);
267
@<Store miscellaneous tokens@>@;
268
}
269
270
@
271
@<Store miscellaneous tokens@>=
272
{
273
ASCII HUGE *pd;
274
275
/* Store the phrase ``|break;|''. */
276
break_tokens[0] = LEFT(id_break,ID0);
277
break_tokens[1] = RIGHT(id_break);
278
break_tokens[2] = @';';
279
280
pd = x_to_ASCII(OC("data"));
281
id_data = ID_NUM(pd,pd+4);
282
}
283
284
@ Here is another interface to \FTANGLE. In \Fortran--90, certain loops
285
can be preceded by symbolic labels. \Ratfor--90 checks for that, and if
286
they're present will label the ends of the loops with those labels.
287
@<Glob...@>=
288
289
IN_RATFOR sixteen_bits sym_label RSET(0);
290
291
@ This function is called from \FTANGLE. It considers whether the token in
292
|cur_val| is a label; it returns one of three values:
293
$$\vbox{\halign{#\hfil&\ ---\ \vtop{\hsize0.75\hsize\noindent\hang\strut
294
#\strut}\hfil\cr
295
|NO|&The identifier isn't followed by a colon, so it's not a label.\cr
296
|-1|&It's a label, but doesn't label a special \Ratfor\ token.\cr
297
|YES|&It's a label on a special \Ratfor\ token such as |@r9 where|.\cr
298
}}$$
299
300
@<Part 1@>=@[
301
302
int
303
chk_lbl(VOID)
304
{
305
sixteen_bits a;
306
307
if(next_byte() == @':')
308
{
309
sym_label = (sixteen_bits)cur_val; // Remember symbolic label.
310
311
if(TOKEN1(a=next_byte())) BACK_UP@;
312
else
313
{ // Labelled identifier.
314
a = IDENTIFIER(a,next_byte()); // Labelled token.
315
316
if(name_dir[a].expandable)
317
{ // It's a labelled \Ratfor\ token.
318
cur_val = a;
319
return YES;
320
}
321
else
322
{ // Nothing special about this label; spit it out.
323
BACK_UP@;
324
cur_val = sym_label;
325
sym_label = ignore;
326
327
checking_label = YES;
328
out_char(identifier);
329
checking_label = NO;
330
331
return -1;
332
}
333
}
334
}
335
336
// The identifier isn't followed by a colon, so it isn't a label.
337
sym_label = ignore;
338
BACK_UP@;
339
return NO;
340
}
341
342
@* ERROR MESSAGES.
343
The Ratfor routines issue special error messages. They employ ANSI's
344
variable argument conventions. This may be a sticky point for users of
345
pre-ANSI compilers.
346
347
@d fatal_RAT_ERROR(s1,s2,s3) {RAT_ERROR(ERROR,s1,0); FATAL(R, s2, s3);}
348
349
@<Part 1@>=@[
350
351
SRTN
352
RAT_error FCN(VA_ALIST((err_type,msg,n VA_ARGS)))
353
VA_DCL(
354
ERR_TYPE err_type C0("Is it warning or error?")@;
355
CONST outer_char msg[] C0("Error message.")@;
356
int n C2("Number of arguments to follow.")@;)@;
357
{
358
VA_LIST(arg_ptr)@;
359
outer_char HUGE *temp, HUGE *temp1;
360
int last_level;
361
#if(NUM_VA_ARGS == 1)
362
ERR_TYPE err_type;
363
CONST outer_char *msg;
364
int n;
365
#endif
366
367
temp = GET_MEM("RAT_error:temp",N_MSGBUF,outer_char);
368
temp1 = GET_MEM("RAT_error:temp1",N_MSGBUF,outer_char);
369
370
VA_START(arg_ptr,n);
371
372
#if(NUM_VA_ARGS == 1)
373
err_type = va_arg(arg_ptr,ERR_TYPE);
374
msg = va_arg(arg_ptr,char *);
375
va_arg(arg_ptr,int);
376
#endif
377
378
vsprintf((char *)temp1,(CONST char *)msg,arg_ptr);
379
va_end(arg_ptr);
380
381
SPRINTF(N_MSGBUF,temp,`"RATFOR %s (Output l. %u in %s): %s.",
382
err_type == ERROR ? "ERROR" : "WARNING",
383
OUTPUT_LINE,params.OUTPUT_FILE_NAME,temp1`);
384
385
last_level = MAX(rlevel-1,0);
386
387
SPRINTF(N_MSGBUF,temp1,
388
`"%s Expanding \"%s\" (loop level %d) beginning at output line %u. \
389
In \"%s %s\" beginning at line %u.",
390
(char *)temp,
391
(char *)cmd_name(begun[last_level].cmd),
392
begun[last_level].level, begun[last_level].line,
393
(char *)cmd_name(begun[0].cmd),
394
(char *)name_of(begun[0].name),
395
begun[0].line`);
396
397
printf("\n%s\n", (char *)temp1); // Error msg to the terminal.
398
OUT_MSG(to_ASCII(temp1),NULL); // Error msg to the file.
399
400
mark_error;
401
402
FREE_MEM(temp,"RAT_error:temp",N_MSGBUF,char);
403
FREE_MEM(temp1,"RAT_error:temp1",N_MSGBUF,char);
404
}
405
406
@ Various checks are made for premature end-of-file. The next routine
407
prints an appropriate error message, then aborts.
408
409
@m OUTPUT_ENDED(msg,n,...)
410
output_ended(OC(msg),n,#.)
411
412
@<Part 1@>=@[
413
414
SRTN
415
output_ended FCN(VA_ALIST((msg,n VA_ARGS)))
416
VA_DCL(
417
CONST outer_char msg[] C0("Error message.")@;
418
int n C2("Number of arguments to follow.")@;)@;
419
{
420
VA_LIST(arg_ptr)@;
421
char HUGE *temp;
422
423
temp = GET_MEM("output_ended:temp",N_MSGBUF,char);
424
425
VA_START(arg_ptr,n);
426
vsprintf_(temp,(CONST char *)msg,arg_ptr)@;
427
va_end(arg_ptr);
428
429
RAT_ERROR(ERROR,"Output ended %s",1,temp);
430
FATAL(R, "ABORTING!", "");
431
}
432
433
@ For the error messages, we need to translate between the |CMD| type and
434
the actual name.
435
436
@m TC(name) case name##_CMD: return OC(#name)
437
438
@<Part 1@>=@[
439
440
outer_char HUGE *
441
cmd_name FCN((cmd))
442
CMD cmd C1("Type of command.")@;
443
{
444
switch(cmd)
445
{
446
case _DO_CMD:
447
return OC("$DO");
448
449
TC(blockdata);
450
TC(break);
451
TC(case);
452
TC(contains);
453
TC(default);
454
TC(do);
455
TC(for);
456
TC(function);
457
TC(if);
458
TC(interface);
459
TC(module);
460
TC(next);
461
TC(program);
462
TC(repeat);
463
TC(return);
464
TC(subroutine);
465
TC(switch);
466
TC(type);
467
TC(until);
468
TC(where);
469
TC(while);
470
default: return OC("UNKNOWN CMD");
471
}
472
}
473
474
@ Print an error message if |case| or |default| don't occur inside a |switch|.
475
476
@<Part 1@>=@[
477
478
SRTN
479
not_switch FCN((s))
480
CONST outer_char s[] C1("Error message.")@;
481
{
482
RAT_ERROR(ERROR,"Misplaced keyword: \
483
\"%s\" must be used only inside \"switch\"",1,s);
484
}
485
486
@ Miscellaneous error-checking macros.
487
@<Part 1@>=@[
488
SRTN didnt_expand FCN((c0,c,op))
489
eight_bits c0 C0("")@;
490
eight_bits c C0("")@;
491
CONST char *op C1("")@;
492
{
493
RAT_ERROR(ERROR,"Was expecting '%c', not '%c', after \"%s\"; \
494
expansion aborted",3,XCHR(c0),XCHR(c),op);
495
}
496
497
@ Print an error message if the appropriate character didn't follow a
498
keyword. If the correct character did follow, then it is eaten.
499
500
@<Part 1@>=@[
501
boolean
502
char_after FCN((c))
503
outer_char c C1("Character expected next.")@;
504
{
505
if((ASCII)(next_byte()) != XORD(c))
506
{
507
RAT_ERROR(WARNING,"Inserted '%c' after \"%s\"",
508
1,c,cmd_name(begun[rlevel-1].cmd));
509
BACK_UP@;
510
return NO;
511
}
512
513
return YES;
514
}
515
516
@* SCANNING AHEAD.
517
When we scan ahead to process the various \Ratfor\ commands, we must
518
expand macros; we can't wait until they're sent to the output file. The
519
function |next_byte| is akin to |get_output|; it returns the next
520
(eight-bit) byte after macro expansion, but doesn't send it to the output.
521
Because sometimes two bytes must be read as a unit, but we return only one
522
at a time, we must sometimes save one byte until the next call to
523
|next_byte|.
524
525
@<Glob...@>=
526
527
IN_RATFOR boolean saved_token RSET(NO); // Is there another byte waiting?
528
IN_RATFOR eight_bits last_a; // The byte that was saved.
529
IN_RATFOR int last_bytes;
530
/* Length (either~1 or~2) of the token just read. Used to
531
back up properly. */
532
533
@ The |next_byte| function automatically advances the |cur_byte| pointer
534
beyond the thing it returns. Sometimes, we must back up because of that.
535
536
@<Part 1@>=@[
537
538
eight_bits
539
next_byte(VOID)
540
{
541
eight_bits a0; // The next byte.
542
sixteen_bits a; // Next two-byte token.
543
static boolean ended_module = NO;
544
long cur_val0; // Incoming value of |cur_val|.
545
546
/* Check if there's a byte already waiting. */
547
if(saved_token)
548
{
549
saved_token = NO;
550
return last_a;
551
}
552
553
cur_val0 = cur_val; // Trouble if we don't restore the state of |cur_val|.
554
555
WHILE()
556
{
557
if(DONE_LEVEL)
558
{
559
if(!ended_module)
560
{
561
cur_val = -(long)cur_mod;
562
if(cur_val != ignore) OUT_CHAR(module_number);
563
ended_module = YES;
564
}
565
566
if(!pop_level())
567
{
568
a0 = ignore;
569
break;
570
}
571
572
ended_module = NO;
573
}
574
575
if(TOKEN1(a0= *cur_byte++))
576
{
577
if(a0==ignore && !in_string)
578
continue; // Forget about null bytes.
579
580
if(rlevel > 0 && a0==begin_language)
581
{ /* Skip the |begin_language|--|NUWEB_OFF| pair. */
582
cur_byte++;
583
continue;
584
}
585
586
last_bytes = 1;
587
break;
588
}
589
590
@<Expand two-byte token@>@;
591
}
592
593
return_next_byte:
594
cur_val = cur_val0;
595
return a0;
596
}
597
598
@ For |next_byte|:
599
@<Expand two-byte token@>=
600
{
601
a = IDENTIFIER(a0,last_a= *cur_byte++);
602
last_bytes = 2;
603
604
/* Expand the two-byte token. */
605
switch(a/MODULE_NAME)
606
{
607
case 0: /* An identifier. */
608
609
if(is_deferred(a)) continue; // Execute deferred macro def'n.
610
611
/* If it's a macro, expand it. */
612
if(!mac_protected &&
613
(macro_text=(text_pointer)mac_lookup(a)) != NULL)
614
{
615
eight_bits HUGE *p;
616
long cur_val0 = cur_val;
617
618
cur_val = a; // In case it's a built-in function.
619
p = xmacro(macro_text, &cur_byte, &cur_end, YES,
620
macrobuf);
621
cur_val = cur_val0;
622
push_level(NULL, p, mp);
623
break;
624
}
625
else if(!balanced && language==RATFOR &&
626
(a==id_function || a==id_program || a==id_subroutine))
627
{
628
RAT_ERROR(ERROR,"Inserted missing '%c' at beginning of function",
629
1,XCHR(cur_delim));
630
cur_byte -= 2;
631
saved_token = NO;
632
a0 = cur_delim;
633
goto return_next_byte;
634
}
635
else
636
{
637
saved_token = YES;
638
goto return_next_byte;
639
}
640
641
case 1: /* Module name. */
642
x_mod_a(a);
643
break;
644
645
default:
646
cur_val = a - MODULE_NUM;
647
if(cur_val > UNNAMED_MODULE) cur_mod = (sixteen_bits)cur_val;
648
OUT_CHAR(module_number);
649
}
650
}
651
652
@ In various contexts, we must skip over newlines. In doing so, verbatim
653
comments are either copied to the output or saved in a buffer for later
654
writing.
655
656
@d COPY_COMMENTS NO
657
@d SAVE_COMMENTS YES
658
659
@<Glob...@>=
660
661
IN_RATFOR eight_bits HUGE *cmnt_buf RSET(NULL),
662
HUGE *cmnt_buf_end RSET(NULL),
663
HUGE *cmnt_pos RSET(NULL);
664
665
@
666
@<Part 1@>=@[
667
668
SRTN
669
skip_newlines FCN((save_comments))
670
boolean save_comments C1("")@;
671
{
672
eight_bits a;
673
674
if(save_comments)
675
{ // Allocate a buffer to hold the comments.
676
cmnt_pos = cmnt_buf = GET_MEM("cmnt_buf",SAVE8,eight_bits);
677
cmnt_buf_end = cmnt_buf + SAVE8;
678
}
679
680
while((a=copy_comment(save_comments)) == @'\n') ;
681
682
if(a == ignore) OUTPUT_ENDED("while skipping newlines",0);
683
684
BACK_UP@;
685
}
686
687
@ While skipping newlines, we should also copy any verbatim comments
688
directly to the output, or save them in a buffer. Verbatim comments are
689
bracketed by |stringg|.
690
691
@<Part 1@>=@[
692
eight_bits
693
copy_comment FCN((save_comments))
694
boolean save_comments C1("")@;
695
{
696
eight_bits a;
697
698
WHILE()
699
if((a=next_byte()) != stringg) return a;
700
/* Beginning of string. */
701
else if(save_comments)
702
{ /* Save in preallocated buffer, for later use with
703
|flush_comments|. */
704
*cmnt_pos++ = a;
705
in_string = YES;
706
while((a=next_byte()) != stringg)
707
{
708
if(cmnt_pos == cmnt_buf_end)
709
resize(&cmnt_buf,SAVE8,&cmnt_pos,&cmnt_buf_end);
710
711
*cmnt_pos++ = a;
712
}
713
*cmnt_pos++ = a;
714
in_string = NO;
715
}
716
else
717
{ // Copy directly to output.
718
OUT_CHAR(stringg);
719
while((a=get_output()) != stringg) ;
720
}
721
722
DUMMY_RETURN(ignore);
723
}
724
725
@ When comments have been saved in |cmnt_buf|, the following code writes
726
them out.
727
728
@<Part 1@>=@[
729
730
SRTN
731
flush_comments(VOID)
732
{
733
eight_bits *p;
734
735
if(!cmnt_buf) return; // Nothing left in buffer.
736
737
for(p=cmnt_buf; p < cmnt_pos; p++) out_char(*p); // Print out saved stuff.
738
if(cmnt_pos > cmnt_buf) NL; // If there was a comment, issue a newline.
739
740
FREE_MEM(cmnt_buf,"cmnt_buf",SAVE8,eight_bits);
741
cmnt_buf = cmnt_buf_end = cmnt_pos = NULL;
742
}
743
744
@ In the course of the expansions, one must print out special tokens,
745
but not expand them again.
746
747
@<Part 1@>=@[
748
749
SRTN
750
id0 FCN((cur_val))
751
sixteen_bits cur_val C1("Token to print out.")@;
752
{
753
if(cur_val == ignore) return;
754
755
if (out_state==NUM_OR_ID) C_putc(' '); // Space properly between identifiers.
756
757
out_ptrunc(cur_val); /* Output a possibly truncated identifier; see
758
\.{ftangle.web}. */
759
out_state = NUM_OR_ID;
760
}
761
762
@ We will maintain a stack of labels, referring to the top of, the bottom
763
of, and the next statement after the block being expanded. It also holds
764
the labels of the next |case| and |default| statements, and the identifier
765
token that is being used for comparisons in the current |switch|.
766
767
@d current_cmd lbl[wlevel].cmd
768
@d do_or_while (current_cmd==do_CMD || current_cmd==while_CMD)
769
770
@d s_top lbl[wlevel].Top
771
@d s_next lbl[wlevel].Next
772
@d was_next lbl[wlevel].was_Next
773
@d s_break lbl[wlevel].Break
774
@d was_break lbl[wlevel].was_Break
775
@d s_case lbl[wlevel].Case
776
@d s_default lbl[wlevel].Default
777
@d icase lbl[wlevel].Icase
778
779
@f CMD int
780
781
@<Glob...@>=
782
typedef struct
783
{
784
CMD cmd; // The command that initiated this block.
785
STMT_LBL Top,Next,Break; // Statement labels for loops.
786
STMT_LBL Case,Default; // Labels for next |case| or |default|.
787
sixteen_bits Icase; // Identifier token for current comparand.
788
unsigned was_Break:1, // Did a |break| occur?
789
was_Next:1; // Did a |@r next| occur?
790
} LBL;
791
792
IN_RATFOR LBL HUGE *lbl, HUGE *lbl_end; // Dynamic array.
793
IN_RATFOR BUF_SIZE max_lbls; // Dynamic allocation length.
794
795
IN_RATFOR int wlevel RSET(0);
796
/* Current level of expansion that can be broken out of
797
with a |break| or |next|. This is incremented for
798
such things as |do|, but not for such things as
799
|if|. */
800
801
@ Allocate an array of loop info.
802
@<Allocate dynamic memory@>=
803
804
ALLOC(LBL,lbl,ABBREV(max_lbls),max_lbls,0);
805
lbl_end = lbl + max_lbls;
806
807
@ At the beginning of the loop expansion routines such as |@n9 where| or~|do|
808
(but not~|if|), we must put appropriate statement labels onto the stack.
809
810
@<Part 1@>=@[
811
812
int
813
save_lbls FCN((cmd,top0,next0,break0,n_used))
814
CMD cmd C0("The current command.")@;
815
STMT_LBL top0 C0("Label number for top of block.")@;
816
STMT_LBL next0 C0("Go here on |next|.")@;
817
STMT_LBL break0 C0("Go here on |break|.")@;
818
int n_used C1("Number of labels used in this expansion.")@;
819
{
820
/* Advance the level counter; check for overflow. */
821
if(++wlevel >= (int)max_lbls) OVERFLW("stmt labels","");
822
823
current_cmd = cmd; /* Save type of block. */
824
s_top = top0; /* Top of block. */
825
s_next = next0; /* Jump here on |@r next|. */
826
s_break = break0; /* Jump here on |@r break|. */
827
was_break = was_next = NO; // Did one occur during loop?
828
829
max_stmt += n_used; /* Advance the statement counter to ensure unique
830
labels. */
831
832
s_case = s_default = 0;
833
icase = ignore;
834
835
return wlevel;
836
}
837
838
@ In various contexts, we must send the character expansion of a statement
839
number or other integer. If it's a statement label, we should suppress it
840
if it's~0.
841
842
@d DONT_PRINT_IF_0 YES
843
@d PRINT_IF_0 NO
844
845
@<Part 1@>=@[
846
847
SRTN
848
out_label FCN((suppress_0,stmt_num))
849
boolean suppress_0 C0("Suppress if zero?")@;
850
STMT_LBL stmt_num C1("Statement number to print.")@;
851
{
852
outer_char temp[N_IDBUF];
853
outer_char *p;
854
855
if(stmt_num == (STMT_LBL)0 && suppress_0) return;
856
857
/* In \Fortran, the statement number must be $\le 99999$. */
858
if(stmt_num > (STMT_LBL)99999)
859
{
860
stmt_num = (STMT_LBL)99999;
861
RAT_ERROR(WARNING,
862
"Automatic statement number out of bounds; %ld assumed",
863
1,stmt_num);
864
}
865
866
SPRINTF(N_IDBUF,temp,`"%ld",stmt_num`);
867
868
OUT_CHAR(constant);
869
for(p=temp; *p; p++)
870
OUT_CHAR(XORD(*p));
871
OUT_CHAR(constant);
872
}
873
874
@ In expanding |if|s and |while|s, we must copy stuff through a balanced
875
closing delimiter, ignoring such delimiters within strings. The routine is
876
also used for scanning compound statements. In this case, it is expected
877
that the opening brace has already been read.
878
879
When we're in the middle of a scan, the variable |balanced| will be~|NO|;
880
this can be used in the various output routines such as |get_output| to
881
help limit the scope of the scan, if one recognizes a situation that
882
couldn't possibly arise within the scan.
883
884
@<Glob...@>=
885
886
IN_RATFOR boolean balanced RSET(YES);
887
IN_RATFOR ASCII cur_delim RSET('\0');
888
889
@ The |copyd| function is basically simple: it copies from left-hand
890
delimiter~|l| to and including right-hand delimiter~|r|. If the |to|
891
argument is |NULL|, stuff is copied to the output. Otherwise, it is copied
892
to memory. The memory copy is necessary only when processing a |switch|.
893
All the text of the |switch| must be read and stored so the cases can be
894
analyzed for the appropriate kind of expansion---computed |goto| or |if|
895
statements. While processing a |switch|, only the keywords |case| and
896
|default| are expanded immediately. (Expansion means closing off the
897
previous case and initializing the new one, so the tokens are stored in the
898
appropriate place.) However, if a |switch| is nested, then the
899
|case| and |default| of the inner |switch| should not be processed when
900
it's stored. The argument |xpn_cases| prevents such premature expansion.
901
902
@d TO_OUTPUT NO /* First argument of |copyd|. */
903
@d TO_MEMORY YES
904
905
@d SAVE_IN_MEM(a) {if(cur_case->txt.next >= cur_case->txt.end)
906
resize(&cur_case->txt.start,BIG_SAVE8,
907
&cur_case->txt.next,
908
&cur_case->txt.end);
909
*(cur_case->txt.next++) = (eight_bits)(a);}
910
911
@d SAVE_16 {SAVE_IN_MEM(a0)@; SAVE_IN_MEM(a1)@;} /* Store a 16-bit token. */
912
913
@d XPN_CASES YES
914
@d DONT_XPN_CASES NO
915
916
@d BLEVELS 100
917
918
@<Part 1@>=@[
919
920
SRTN
921
copyd FCN((to_memory,xpn_cases,l,r,semi_allowed))
922
boolean to_memory C0("To memory?")@;
923
boolean xpn_cases C0("Expand |case| statements?")@;
924
ASCII l C0("Left-hand delimiter.")@;
925
ASCII r C0("Right-hand delimiter.")@;
926
boolean semi_allowed C1("Is a semicolon allowed in the text to be \
927
copied?")@;
928
{
929
int bal,bal0[BLEVELS];
930
LINE_NUMBER starting_line;
931
eight_bits (*output_rtn)(VOID);
932
sixteen_bits a,last_token;
933
sixteen_bits l0 = ignore,r0 = ignore;
934
boolean found_semi;
935
boolean balanced0 = balanced; // Save since possible recursion.
936
ASCII cur_delim0 = cur_delim;
937
938
@<Set up |l0| and |r0|@>@;
939
940
if(l == @'{' && xpn_cases) /* We should be positioned after the brace. */
941
{
942
if(DONE_LEVEL && !pop_level()) OUTPUT_ENDED("after '{'",0);
943
944
bal0[bal = 1] = 0; /* Don't copy the opening brace. */
945
}
946
else
947
{
948
if((ASCII)(next_byte()) != l)
949
{
950
RAT_ERROR(ERROR,"Missing opening delimiter '%c'; \
951
text not copied",
952
1,XCHR(l));
953
return;
954
}
955
956
/* Include the opening delimiter in the copy. */
957
BACK_UP@;
958
bal0[bal = 0] = 0;
959
}
960
961
starting_line = OUTPUT_LINE;
962
963
/* Normally we copy the stuff directly to the output. However, if we're
964
processing a |switch|, we store it. */
965
output_rtn = to_memory ? next_byte : get_output;
966
967
/* We use |last_token| to help check for a semicolon just before the closing
968
delimiter. */
969
last_token = ignore;
970
found_semi = NO;
971
972
/* For use with check in |get_output|. */
973
balanced = NO;
974
cur_delim = r;
975
976
WHILE()
977
{
978
a = (sixteen_bits)(*output_rtn)(); /* Copy a token to the output,
979
and remember it. */
980
981
if(to_memory && a==(sixteen_bits)stringg)
982
in_string = BOOLEAN(!in_string);
983
984
if(!in_string) @<Check for balanced delimiter@>@;
985
986
if(to_memory) @<Store stuff in memory@>@;
987
}
988
989
balanced = balanced0;
990
cur_delim = cur_delim0;
991
}
992
993
@ The routine |copyd| is used to scan only between matched parentheses or
994
matched braces. We check to avoid imbalances such as \.{(\dots \{\dots )}.
995
The scan set is |{l,r}|; the alternate set is |{l0,r0}|.
996
997
@<Set up |l0|...@>=
998
999
switch(l)
1000
{
1001
case @'{':
1002
l0 = @'('; @~ r0 = @')';
1003
break;
1004
1005
case @'(':
1006
l0 = @'{'; @~ r0 = @'}';
1007
break;
1008
1009
default:
1010
CONFUSION("copyd", "Invalid left delimiter 0x%x", l);
1011
}
1012
1013
@ We maintain a brace balance for the scan set, and also for the alternate
1014
set, so we can catch various kinds of interlacing problems.
1015
1016
@<Check for balanced delim...@>=
1017
{
1018
if(a == ignore) OUTPUT_ENDED("while scanning for '%c'. Scan began \
1019
with delimiter '%c' at line %u",3,XCHR(r),XCHR(l),starting_line);
1020
1021
if(a == (sixteen_bits)l) bal0[++bal] = 0;
1022
else if(a == (sixteen_bits)r) @<Check right-hand delimiter~|r|@>@;
1023
else if(a == l0) bal0[bal]++;
1024
else if(a == r0) @<Check alternate right-hand delimiter~|r0|@>@;
1025
else if(a != stringg)
1026
{
1027
if(a==@';')
1028
if(semi_allowed) found_semi = YES;
1029
else RAT_ERROR(ERROR,"Spurious semicolon",0);
1030
1031
if(chk_stmts)
1032
if(!to_memory && a==id_keyword) last_token = ignore;
1033
else last_token = a; /* Remember last character so we can check
1034
for semicolon. */
1035
}
1036
}
1037
1038
@
1039
@<Check right-hand delim...@>=
1040
{
1041
if(bal <= 0)
1042
{
1043
if(!to_memory) out_pos--; // Kill off what was already output.
1044
unmatched(l,r);
1045
continue;
1046
}
1047
else
1048
{
1049
if(bal0[bal] != 0)
1050
{
1051
inserted(bal0[bal],l0,r0,l,bal);
1052
1053
while(bal0[bal]--)
1054
if(to_memory) SAVE_IN_MEM(r0)@;
1055
else OUT_CHAR(r0);
1056
}
1057
1058
if(--bal == 0)
1059
{
1060
if(semi_allowed && last_token && last_token != @';')
1061
{
1062
RAT_ERROR(WARNING,"Supplied missing ';' before \
1063
delimiter '%c'", 1,r);
1064
1065
if(to_memory) SAVE_IN_MEM(@';')@;
1066
else OUT_CHAR(@';');
1067
}
1068
1069
if(to_memory) SAVE_IN_MEM(r)@;
1070
1071
/* We've successfully found the end of the scan. */
1072
balanced = YES;
1073
cur_delim = '\0';
1074
break;
1075
}
1076
}
1077
}
1078
1079
@
1080
@<Check alternate right...@>=
1081
{
1082
if(bal0[bal] <= 0)
1083
{
1084
if(!to_memory) out_pos--;
1085
unmatched((ASCII)l0,(ASCII)r0);
1086
continue;
1087
}
1088
else bal0[bal]--;
1089
}
1090
1091
@ The nuance here is to remember that certain single-byte tokens such as
1092
|dot_const| are really escapes that are followed by data. That data need
1093
not conform to the standard interpretation of a token, so must be copied
1094
explicitly.
1095
@<Store stuff in memory@>=
1096
{
1097
if(TOKEN1(a))
1098
{
1099
SAVE_IN_MEM(a)@; /* Store it if necessary. */
1100
1101
switch(a)
1102
{
1103
case dot_const:
1104
case begin_language:
1105
SAVE_IN_MEM(*cur_byte++);
1106
break;
1107
1108
case new_output_file:
1109
RAT_ERROR(ERROR,"@@o command not allowed inside switch",0);
1110
}
1111
}
1112
else
1113
{
1114
if(xpn_cases)
1115
@<Possibly expand 16-bit token@>@;
1116
else
1117
{/* For inner |switches|, just copy tokens. */
1118
SAVE_IN_MEM(a)@;
1119
SAVE_IN_MEM(next_byte())@;
1120
}
1121
}
1122
}
1123
1124
@ While processing a |switch|, we copy everything to memory except for
1125
|case| and |default|, which are expanded immediately. Also, an inner
1126
|switch| should just be copied in its entirety.
1127
1128
@<Possibly expand 16...@>=
1129
@B
1130
eight_bits a0,a1;
1131
1132
@b
1133
a = IDENTIFIER(a0=(eight_bits)a,a1=next_byte());
1134
1135
if(a==id_switch)
1136
{
1137
SAVE_16; /* |switch|. */
1138
copyd(TO_MEMORY,DONT_XPN_CASES,@'(',@')',NO); /* $(\dots)$ */
1139
skip_newlines(COPY_COMMENTS);
1140
copyd(TO_MEMORY,DONT_XPN_CASES,@'{',@'}',YES); /* |{body;}| */
1141
}
1142
else if(a==id_case) x_case();
1143
else if(a==id_default) x_default();
1144
else SAVE_16;
1145
}
1146
1147
@ Interface to \FTANGLE.
1148
1149
@<Part 1@>=@[
1150
1151
SRTN
1152
cp_fcn_body(VOID)
1153
{
1154
brace_level++;
1155
copyd(TO_OUTPUT,XPN_CASES,@'{',@'}',YES);
1156
1157
if(--brace_level == 0)
1158
{
1159
END; /* Automatically insert an |@r end| statement. */
1160
cur_fcn = NO_FCN; /* No longer inside a function. */
1161
rlevel--;
1162
}
1163
}
1164
1165
@ Copy to output, stopping just \It{before} a delimiter~|r_before|
1166
(generally~\.{'\{}') or just \It{after} a delimiter~|r_after|
1167
(generally~\.{';'}). As a special case, if |r_before == 0177|, we just
1168
look for |r_after|.
1169
1170
@d copy_to(r_after) copy_2to(NOT_BEFORE,r_after)
1171
1172
@<Unused@>=
1173
1174
unsigned copy_2to FCN((r_before,r_after))
1175
ASCII r_before C0("")@;
1176
char r_after C1("Terminating delimiter.")@;
1177
{
1178
eight_bits a;
1179
LINE_NUMBER starting_line;
1180
unsigned k = 0;
1181
1182
starting_line = OUTPUT_LINE; // Remember where scan started in case of error.
1183
1184
WHILE()
1185
if(TOKEN1(a= next_byte()))
1186
{
1187
k++;
1188
if(!in_string)
1189
{
1190
if(a == ignore) OUTPUT_ENDED("while copying \
1191
from line %u to delimiter (before = '%c', after = '%c')",3,
1192
starting_line,
1193
r_before==NOT_BEFORE ? '\0' : XCHR(r_before),
1194
r_after==NOT_AFTER ? '\0' : XCHR(r_after));
1195
1196
if(a == (sixteen_bits)r_after && a != NOT_AFTER) return k;
1197
if(a == (sixteen_bits)r_before && a != NOT_BEFORE)
1198
{
1199
BACK_UP@;
1200
return k-1;
1201
}
1202
}
1203
1204
OUT_CHAR(a);
1205
}
1206
else
1207
{
1208
cur_val = IDENTIFIER(a,next_byte());
1209
k += 2;
1210
OUT_CHAR(identifier);
1211
}
1212
}
1213
1214
@ A very important function is the one that copies and possibly expands a
1215
(possibly compound) statement. One annoyance is that in the auto-semi mode
1216
an extra semicolon may be put after constructions such as |for()|; this
1217
must be eaten.
1218
1219
@d BRACE_ONLY 1 /* In some situations such as after |switch|, only a brace
1220
is expected. */
1221
1222
@<Part 1@>=@[
1223
1224
SRTN
1225
stmt FCN((to_memory,brace_only))
1226
boolean to_memory C0("")@;
1227
boolean brace_only C1("Is only a left brace allowed next?")@;
1228
{
1229
sixteen_bits a;
1230
1231
EAT_AUTO_SEMI;
1232
skip_newlines(COPY_COMMENTS);
1233
1234
if((a=next_byte()) != @'{')
1235
{
1236
if(a == ignore) OUTPUT_ENDED("at beginning of statement",0);
1237
1238
/* Issue error message if was expecting brace. */
1239
if(brace_only)
1240
{
1241
RAT_ERROR(WARNING,"Inserted '{'",0);
1242
BACK_UP@;
1243
copyd(to_memory,XPN_CASES,@'{',@'}',YES);
1244
return;
1245
}
1246
1247
if(TOKEN1(a))
1248
{ /* Definitely not a compound statement. */
1249
BACK_UP@;
1250
x_stmt();
1251
}
1252
else
1253
{ /* Check if it's a Ratfor token that needs to be
1254
expanded. */
1255
SPEC HUGE *s;
1256
1257
a = IDENTIFIER(a,next_byte());
1258
1259
for(s=spec_tokens; s->len != 0; s++)
1260
if(a == *s->pid && s->expand != NULL)
1261
{
1262
(*s->expand)();
1263
return; // Successfully expanded special token.
1264
}
1265
BACK_UP@;
1266
x_stmt();
1267
}
1268
}
1269
else copyd(to_memory,XPN_CASES,@'{',@'}',YES); /* Scan compound
1270
statement. */
1271
}
1272
1273
1274
@ Expand a simple statement, by copying to and eating a semicolon. If
1275
verbatim comments are present, we copy those as well.
1276
1277
@<Part 1@>=@[
1278
1279
SRTN
1280
x_stmt(VOID)
1281
{
1282
eight_bits a;
1283
1284
WHILE()
1285
{
1286
if( (a=get_output()) == ignore) OUTPUT_ENDED("during scan of simple \
1287
statement ",0);
1288
1289
if(a == @';' && !in_string) break;
1290
}
1291
1292
/* Does a verbatim comment follow? If so, it's bracketed by |stringg|. */
1293
if( (a=next_byte()) != stringg) {BACK_UP@; @~ return;}
1294
1295
if(*cur_byte != @'\n') {BACK_UP@; @~ return;}
1296
1297
/* Copy verbatim comment. */
1298
OUT_CHAR(a);
1299
while((a=get_output()) != stringg) ;
1300
}
1301
1302
1303
@* SAVING and OUTPUTTING RATFOR TEXT. We need a routine to save the
1304
token-by-token output in a buffer~|p| of maximum length~|nmax|. We scan
1305
until we encounter the right delimiter, which may be either/or |r_before|
1306
or |r_after|. If it's |r_before|, the scan stops before |r_before|. If
1307
it's |r_after| (which may be either~\.{')'}, \.{';'}, or~\.{':'}), the scan
1308
stops after |r_after|, and |r_after| is eaten. Note that if |r_after ==
1309
')'|, then we're in the midst of a parenthesized expression, and we must be
1310
careful not to stop prematurely if there are extra balanced parentheses.
1311
1312
In some cases, we just need to copy stuff directly to the output.
1313
Nevertheless, it's convenient to save it first, then output it, because the
1314
save operation handles the single-token escapes conveniently.
1315
1316
@<Glob...@>=
1317
1318
IN_RATFOR eight_bits HUGE *save_buffer RSET(NULL), HUGE *psave_buffer;
1319
1320
@
1321
1322
@d unmatched(l,r) RAT_ERROR(WARNING,"Ignored '%c' not matched with %s",
1323
2,XCHR(r),qdelim(l))
1324
1325
@d inserted(n,l0,r0,l,level) RAT_ERROR(WARNING,
1326
"Inserted %d '%c' to balance '%c' at %s level %d",
1327
5,n,XCHR(r0),XCHR(l0),qdelim(l),level)
1328
1329
/* Copy, then immediately output. */
1330
@d COPY_TO(r) psave_buffer = SAVE_AFTER(&save_buffer,BIG_SAVE8,r);
1331
copy_out(save_buffer,psave_buffer,!macro)@;
1332
1333
@d COPY_2TO(r_before,r_after)
1334
psave_buffer = save_out(&save_buffer,BIG_SAVE8,r_before,r_after);
1335
copy_out(save_buffer,psave_buffer,!macro)@;
1336
1337
@<Part 1@>=@[
1338
1339
eight_bits HUGE *
1340
save_out FCN((pp,nmax,r_before,r_after))
1341
eight_bits HUGE **pp C0("Address of pointer to buffer where result is \
1342
saved.")@;
1343
int nmax C0("Length of above buffer.")@;
1344
eight_bits r_before C0("Stop before here.")@;
1345
eight_bits r_after C1("Stop after here.")@;
1346
{
1347
eight_bits a,l;
1348
eight_bits HUGE *p, HUGE *p_end;
1349
LINE_NUMBER starting_line;
1350
int bal,bal0[BLEVELS];
1351
1352
/* If a save buffer hasn't already been allocated, do that. */
1353
if(!(*pp))
1354
*pp = GET_MEM("*pp",nmax,eight_bits); /* Send back the buffer
1355
address, so we can free later. */
1356
p = *pp;
1357
p_end = p + nmax - 1; /* End of buffer. When we get this far, we must
1358
reallocate. The $-1$~is because we might
1359
increment~|p| by~2. */
1360
1361
switch(r_after)
1362
{
1363
case @')':
1364
l = (eight_bits)@'(';
1365
bal = 1;
1366
break;
1367
1368
case @'}':
1369
l = (eight_bits)@'{';
1370
bal = 1;
1371
break;
1372
1373
default:
1374
l = '\0';
1375
bal = 0;
1376
break;
1377
}
1378
1379
bal0[bal] = 0;
1380
1381
starting_line = OUTPUT_LINE; /* Remember where the scan started, in case
1382
there is an error. */
1383
1384
if(in_string)
1385
CONFUSION("save_out","Shouldn't be inside string here");
1386
1387
WHILE()
1388
{
1389
if(p >= p_end) resize(pp,nmax,&p,&p_end); /* Reallocate the save
1390
buffer. */
1391
1392
if(TOKEN1(a= next_byte()))
1393
{
1394
if(!in_string)
1395
@<Check for balanced parentheses or braces@>@;
1396
1397
@<Save single-byte token@>@;
1398
}
1399
else
1400
{
1401
*p++ = a;
1402
*p++ = next_byte();
1403
}
1404
}
1405
1406
DUMMY_RETURN(NULL);
1407
}
1408
1409
1410
@
1411
@<Check for balanced paren...@>=
1412
{
1413
if(a == ignore) OUTPUT_ENDED("while scanning from line %u \
1414
for delimiter (r_before = '%c', r_after = '%c')",
1415
3,starting_line,XCHR(r_before),XCHR(r_after));
1416
1417
if(a==l) bal0[++bal] = 0;
1418
else if(a == r_after && r_after != NOT_AFTER) @<Check right-hand balance@>@;
1419
else if(a == r_before && r_before != NOT_BEFORE)
1420
{
1421
BACK_UP;
1422
*p = '\0';
1423
return p;
1424
}
1425
else if(a == @'{') bal0[bal]++;
1426
else if(a == @'}') @<Check alternate balance@>@;
1427
}
1428
1429
@
1430
@<Check right-hand balance@>=
1431
{
1432
if(l && bal <= 0)
1433
{
1434
p--;
1435
unmatched(l,r_after);
1436
continue;
1437
}
1438
else
1439
{
1440
if(bal0[bal] != 0)
1441
{
1442
inserted(bal0[bal],@'{',@'}',l,bal);
1443
1444
while(bal0[bal]--)
1445
{
1446
*p++ = @'}';
1447
if(p >= p_end) resize(pp,nmax,&p,&p_end);
1448
}
1449
}
1450
1451
if(l) bal--;
1452
if(bal == 0)
1453
{ /* Found right-hand delimiter. */
1454
*p = '\0'; /* Mark end of tokens. */
1455
return p;
1456
}
1457
}
1458
}
1459
1460
@
1461
@<Check alternate balance@>=
1462
{
1463
if(bal0[bal] <= 0)
1464
{
1465
p--;
1466
unmatched(@'{',@'}');
1467
continue;
1468
}
1469
else bal0[bal]--;
1470
}
1471
1472
@
1473
@<Save single-byte token@>=
1474
{
1475
*p++ = a;
1476
1477
switch(a)
1478
{
1479
case stringg:
1480
in_string = BOOLEAN(!in_string);
1481
break;
1482
1483
case dot_const:
1484
case begin_language:
1485
*p++ = *cur_byte++;
1486
break;
1487
}
1488
}
1489
1490
@
1491
@<Part 1@>=@[
1492
1493
outer_char *
1494
qdelim FCN((delim))
1495
ASCII delim C1("")@;
1496
{
1497
static outer_char q0[4];
1498
1499
sprintf((char *)q0,delim ? "'%c'" : "?",XCHR(delim));
1500
return q0;
1501
}
1502
1503
@ If necessary, we reallocate the save buffer to a larger size.
1504
1505
@<Part 1@>=@[
1506
1507
SRTN
1508
resize FCN((pp,nmax,pq,pp_end))
1509
eight_bits HUGE **pp C0("Addr of ptr to beginning of buffer")@;
1510
int nmax C0("Resizing increment")@;
1511
eight_bits HUGE **pq C0("Address of current pointer")@;
1512
eight_bits HUGE **pp_end C1("Addr of ptr to end of buffer")@;
1513
{
1514
int old_len = PTR_DIFF(int, *pq, *pp); // Old length. Should this be |size_t|?
1515
int new_len = old_len + nmax; // New length.
1516
1517
*pp = (eight_bits HUGE *)REALLOC(*pp,
1518
new_len*sizeof(eight_bits),
1519
old_len*sizeof(eight_bits));
1520
*pq = *pp + old_len; /* New next position to which to accrete. */
1521
*pp_end = *pp + new_len - 1; // New end.
1522
}
1523
1524
@* KEYWORD TRANSLATION.
1525
A variety of macro definitions facilitate constructing the expanded output.
1526
1527
/* The |INDENT| and |OUTDENT| macros are used to beautify the \.{FOR}
1528
output. */
1529
@d INDENT indent_level++; blank_out(1)@;
1530
@d OUTDENT indent_level--; out_pos -= indnt_size@;
1531
1532
@d LABEL(lbl) out_label(DONT_PRINT_IF_0,(STMT_LBL)(lbl)) /* Statement label. */
1533
@d NUMBER(lbl) out_label(PRINT_IF_0,(STMT_LBL)(lbl)) /* Ordinary integer,
1534
including~0. */
1535
1536
@d PARENS copyd(TO_OUTPUT,XPN_CASES,@'(',@')',NO) /* Copies text between
1537
(and including) parens. */
1538
1539
@m ID(type) id0(id__##type) /* Send identifier directly to output. */
1540
@m XPN_BODY(var1,flag,var2) xpn_body(id__##var1,flag,id__##var2) /* For
1541
|if| or |where| stmts. */
1542
@m XPN_ELSE(id1,id2,var1,flag,var2)
1543
xpn_else(id1,id2,id__##var1,flag,id__##var2) /* For
1544
|if| or |where| stmts. */
1545
1546
/* Macro up various single characters to be sent to the output. */
1547
@d NL out_char(@'\n')
1548
@d LP out_char(@'(')
1549
@d RP out_char(@')')
1550
@d COMMA out_char(@',')
1551
@d NOT out_char(@'!')
1552
@d EQUALS out_char(@'=')
1553
@d MINUS out_char(@'-')
1554
@d EQ_EQ out_char(eq_eq)
1555
@d OR out_char(or_or)
1556
@d LT out_char(@'<')
1557
@d GT out_char(@'>')
1558
1559
@d IF(stmt_num) LABEL(stmt_num); @~ ID(IF)@;
1560
@d THEN ID(THEN); @~ NL@;
1561
@d ELSE ID(ELSE)
1562
@d ENDIF ID(ENDIF); @~ if(symbolic_label) id0(symbolic_label); @~ NL@;
1563
@d ENDWHERE ID(ENDWHERE); @~ NL@;
1564
@d GOTO(stmt) ID(GOTO); @~ LABEL(stmt); @~ NL@;
1565
@d CONTINUE(stmt) LABEL(stmt); @~ ID(CONTINUE); @~ NL@;
1566
@d RETURN ID(RETURN); @~ NL@;
1567
@d END ID(END); @~ NL@;
1568
1569
@d END_DO ID(END); @~ ID(DO); @~ NL@;
1570
@d END_SELECT ID(END); @~ ID(SELECT); @~ NL@;
1571
1572
@ Ratfor has the ability to generate comments about each keyword it's
1573
expanding. (These can be suppress by command-line option~`\.{-k}'.)
1574
1575
We'll need a couple of buffers.
1576
@<Glob...@>=
1577
1578
IN_RATFOR outer_char HUGE *cmd_fmt;
1579
IN_RATFOR ASCII HUGE *cmd_msg, HUGE *cmd_end;
1580
IN_RATFOR BUF_SIZE cmd_fsize,cmd_size;
1581
1582
@ We also need an interface to \FTANGLE.
1583
1584
@<Part 2@>=@[
1585
1586
SRTN
1587
alloc_Rat(VOID)
1588
{
1589
@<Allocate dynamic memory@>@;
1590
}
1591
1592
@
1593
@<Allocate dyn...@>=
1594
1595
ALLOC(outer_char,cmd_fmt,ABBREV(cmd_fsize),cmd_fsize,0);
1596
ALLOC(ASCII,cmd_msg,ABBREV(cmd_size),cmd_size,0);
1597
cmd_end = cmd_msg + cmd_size;
1598
1599
@
1600
@m OUT_CMD(emit,abbrev,beginning,fmt0,n,...)
1601
out_cmd(emit,abbrev,OC(beginning),OC(fmt0),n,#.)
1602
1603
@<Part 2@>=@[
1604
1605
SRTN
1606
out_cmd FCN(VA_ALIST((emit_continue,abbrev,beginning,fmt0,n VA_ARGS)))
1607
VA_DCL(
1608
boolean emit_continue C0("Put a |continue| in case of label.")@;
1609
outer_char abbrev C0("Abbreviation of command.")@;
1610
CONST outer_char beginning[] C0("Beginning part of message.")@;
1611
CONST outer_char *fmt0 C0("Format of the message.")@;
1612
int n C2("Number of arguments to message.")@;)@;
1613
{
1614
VA_LIST(arg_ptr)@;
1615
#if(NUM_VA_ARGS == 1)
1616
boolean emit_continue;
1617
char abbrev;
1618
CONST outer_char *beginning;
1619
CONST outer_char *fmt0;
1620
int n;
1621
#endif
1622
1623
VA_START(arg_ptr,n);
1624
1625
#if(NUM_VA_ARGS == 1)
1626
emit_continue = va_arg(arg_ptr,boolean);
1627
abbrev = va_arg(arg_ptr,char);
1628
beginning = va_arg(arg_ptr,char *);
1629
fmt0 = va_arg(arg_ptr,char *);
1630
va_arg(arg_ptr,int);
1631
#endif
1632
1633
@<Check if command is suppressed@>@;
1634
1635
if(emit_continue)
1636
{
1637
CONTINUE(ignore); /* In case there's a statement label. */
1638
}
1639
1640
/* Make prettier format. */
1641
SPRINTF(cmd_fsize,cmd_fmt,
1642
`"--- %s \"%s%s\" ---",beginning,cmd_name(begun[rlevel-1].cmd),fmt0`);
1643
1644
@<Fill in the variable parts of the msg@>;
1645
1646
if(Fortran88 && symbolic_label)
1647
{
1648
id0(symbolic_label); @~ OUT_CHAR(@':');
1649
}
1650
}
1651
1652
@ Filling in the token strings is a bit annoying. We can't simply treat
1653
them as character strings, because some of the tokens may be zero. Thus, we
1654
actually parse the format looking for |"%s"| and replace that by the
1655
appropriate token string.
1656
1657
@<Fill in the var...@>=
1658
@B
1659
outer_char HUGE *p;
1660
ASCII HUGE *q;
1661
eight_bits HUGE *s, HUGE *s1;
1662
1663
@b
1664
p = cmd_fmt;
1665
q = cmd_msg;
1666
1667
while(*p)
1668
{
1669
if(q >= cmd_end)
1670
OVERFLW("cmd_msg",ABBREV(cmd_size));
1671
1672
if(*p == '%' && *(p+1) == 's')
1673
{
1674
p += 2;
1675
1676
/* For compilers that don't implement variable arguments, the following
1677
calls return a string beginning with \.{"KLUDGE"}. (See
1678
\.{proto.hweb}.) This doesn't work right on the MAC, since it seems to
1679
put copies of identical strings into different locations. Thus, the
1680
\Ratfor\ comments look strange. To kill off those comments, use the \.{-k}
1681
option. */
1682
s = va_arg(arg_ptr,eight_bits *);
1683
s1 = va_arg(arg_ptr,eight_bits *);
1684
1685
while(s < s1)
1686
*q++ = *s++;
1687
}
1688
else
1689
*q++ = XORD(*p++);
1690
}
1691
1692
va_end(arg_ptr);
1693
1694
/* Translate it to the output. */
1695
OUT_MSG(cmd_msg,q);
1696
}
1697
1698
@ The command-line option~`\.{-k}' gives a list of abbreviations for which
1699
a comment should not be output. '\.*' means nothing should be output.
1700
Option `\.{-K}' means output comments only for those abbreviations; '\.*'
1701
means output all comments.
1702
@<Check if command is ...@>=
1703
@B
1704
static outer_char brkset[3] = "*?"; /* Prototype list of possible characters to
1705
be searched for in the command-line list. */
1706
char *strpbrk();
1707
boolean found_abbrev;
1708
1709
@b
1710
brkset[1] = abbrev;
1711
found_abbrev = BOOLEAN(STRPBRK(abbrev_cmds,brkset) != NULL);
1712
1713
if(suppress_cmds) {if(found_abbrev) return;}
1714
else {if(!found_abbrev) return;}
1715
}
1716
1717
@ We just use |max_lbls| here, rather than defining a new dynamic type.
1718
@<Allocate dyn...@>=
1719
1720
begun = GET_MEM("begun",max_lbls,BEGUN);
1721
1722
@
1723
@<Part 2@>=@[
1724
1725
SRTN
1726
expanding FCN((cmd))
1727
CMD cmd C1("Type of identifier being expanded.")@;
1728
{
1729
if(rlevel >= (int)max_lbls) OVERFLW("Nesting","");
1730
1731
begun[rlevel].cmd = cmd;
1732
begun[rlevel].name = rlevel ? cur_fcn : NO_FCN;
1733
begun[rlevel].symbolic = sym_label; // For |do| or |switch|.
1734
begun[rlevel].function = BOOLEAN(CHOICE(rlevel, is_function, NO));
1735
begun[rlevel].line = OUTPUT_LINE;
1736
begun[rlevel].level = wlevel;
1737
rlevel++;
1738
}
1739
1740
@ Expand a |while| statement.
1741
@<Rdoc@>=
1742
@r
1743
/* Source construction: */
1744
while(expr) {stmt;}
1745
1746
@n
1747
/* Translation: */
1748
TOP: continue
1749
if(expr) then
1750
stmt
1751
endif
1752
goto TOP
1753
BREAK: continue
1754
1755
@
1756
@<Part 2@>=@[
1757
1758
X_FCN
1759
x_while(VOID)
1760
{
1761
eight_bits HUGE *a = NULL, HUGE *pa;
1762
1763
expanding(while_CMD);
1764
save_lbls(while_CMD,max_stmt,max_stmt,max_stmt+1,2);
1765
1766
/* Is parenthesized condition present? */
1767
IS_NEXT_PAREN(while);
1768
pa = SAVE_AFTER(&a,SAVE8,@')'); /* Save the condition. */
1769
1770
OUT_CMD(YES,'w',"","(%s)",2,a,pa); /* Comment to output. */
1771
1772
if(Fortran88)
1773
{
1774
ID(DO); @~ ID(WHILE); @~ LP; @~ copy_out(a,pa,!macro); @~ RP; @~
1775
NL; /* |@n DO WHILE|$(\dots)$ */
1776
}
1777
else
1778
{
1779
IF(s_top); @~ LP; @~ copy_out(a,pa,!macro); @~ RP; @~ THEN;
1780
}
1781
INDENT;
1782
stmt(TO_OUTPUT,0); /* Body. */
1783
if(!Fortran88) {GOTO(s_top);}
1784
OUTDENT;
1785
1786
if(Fortran88) {END_DO;}
1787
else
1788
{
1789
ENDIF;
1790
if(was_break) {CONTINUE(s_break);}
1791
}
1792
1793
wlevel--;
1794
rlevel--;
1795
FREE_MEM(a,"while:a",SAVE8,eight_bits);
1796
}
1797
1798
@ Expand a |break| statement. Outputs a jump statement to the |break|
1799
label saved earlier.
1800
1801
@<Part 2@>=@[
1802
1803
X_FCN
1804
x_break(VOID)
1805
{
1806
sixteen_bits a;
1807
1808
/* Check that we're in a loop or |switch|. */
1809
if(wlevel==0 && switch_level==0)
1810
{
1811
NOT_LOOP("break"," or \"switch\"");
1812
COPY_TO(@';');
1813
return;
1814
}
1815
1816
expanding(break_CMD);
1817
1818
was_break = YES; /* Remember that at least one
1819
|break| statement happened during this loop. */
1820
1821
OUT_CMD(YES,'b',"","",0); /* Comment to output. */
1822
1823
if(Fortran88 && do_or_while)
1824
{
1825
ID(EXIT);
1826
1827
if(TOKEN1(a=next_byte())) BACK_UP@;
1828
else id0(IDENTIFIER(a,next_byte()));
1829
1830
NL; /* The |do_or_while| is used since |EXIT| can only
1831
be used inside of |do|'s or |while|'s. */
1832
}
1833
else {GOTO(s_break);}
1834
1835
char_after(';'); /* |break| must be immediately followed by semicolon. */
1836
rlevel--;
1837
}
1838
1839
@ Issue an error message about misplaced command.
1840
1841
@d NOT_LOOP(id,msg) not_loop(OC(id),OC(msg))
1842
1843
@<Part 2@>=@[
1844
1845
SRTN
1846
not_loop FCN((id,msg))
1847
CONST outer_char id[] C0("Errant identifier name.")@;
1848
CONST outer_char msg[] C1("Error message.")@;
1849
{
1850
RAT_ERROR(WARNING,"Misplaced keyword: \
1851
\"%s\" must appear inside loop%s; command ignored",
1852
2,id,msg);
1853
}
1854
1855
@ Expand a |@r next| statement. Outputs a jump statement to the |@r next| label
1856
saved earlier.
1857
1858
@<Part 2@>=@[
1859
1860
X_FCN
1861
x_next(VOID)
1862
{
1863
sixteen_bits a;
1864
1865
/* Check that |next| occurs inside loop. */
1866
if(wlevel == 0)
1867
{
1868
NOT_LOOP("next","");
1869
COPY_TO(@';');
1870
return;
1871
}
1872
1873
expanding(next_CMD);
1874
1875
was_next = YES; /* At least one |next| occurred during this loop. */
1876
OUT_CMD(YES,'n',"","",0);
1877
1878
if(Fortran88 && do_or_while)
1879
{
1880
ID(CYCLE);
1881
1882
if(TOKEN1(a=next_byte())) BACK_UP@;
1883
else id0(IDENTIFIER(a,next_byte()));
1884
1885
NL;
1886
}
1887
else {GOTO(s_next);}
1888
1889
char_after(';');
1890
rlevel--;
1891
}
1892
1893
@ Expand a |repeat| statement. Note that in the \Ratfor\ syntax the |@r
1894
until| is optional.
1895
@<Rdoc@>=
1896
@r
1897
/* Source construction: */
1898
repeat {stmt;} until(expr);
1899
1900
@n
1901
/* Translation: */
1902
TOP: continue
1903
stmt
1904
NEXT: if(!(expr)) goto TOP
1905
BREAK: continue
1906
1907
@
1908
@<Part 2@>=@[
1909
1910
X_FCN
1911
x_repeat(VOID)
1912
{
1913
sixteen_bits a;
1914
eight_bits HUGE *u = NULL, HUGE *pu;
1915
1916
expanding(repeat_CMD);
1917
save_lbls(repeat_CMD,max_stmt,max_stmt+1,max_stmt+2,3);
1918
1919
OUT_CMD(YES,'p',"","",0); /* Comment to output. */
1920
1921
CONTINUE(s_top);
1922
INDENT;
1923
stmt(TO_OUTPUT,0);
1924
OUTDENT;
1925
if(was_next) LABEL(s_next);
1926
1927
skip_newlines(SAVE_COMMENTS);
1928
1929
/* Check for optional |@r until|. */
1930
if(TOKEN1(a=next_byte())) BACK_UP@;
1931
else
1932
{
1933
a = IDENTIFIER(a,next_byte());
1934
1935
if(a == id_until)
1936
{
1937
flush_comments();
1938
rlevel--;
1939
expanding(until_CMD);
1940
1941
IS_NEXT_PAREN(until);
1942
pu = SAVE_AFTER(&u,SAVE8,@')'); /* The |until| condition. */
1943
OUT_CMD(NO,'p',"","(%s)",2,u,pu);
1944
1945
IF(ignore); @~ LP; @~ NOT;
1946
@~ LP; @~ copy_out(u,pu,!macro); @~ RP;
1947
@~ RP;
1948
FREE_MEM(u,"repeat:u",SAVE8,eight_bits);
1949
}
1950
else BACK_UP@;
1951
}
1952
1953
GOTO(s_top);
1954
flush_comments();
1955
1956
if(was_break) {CONTINUE(s_break);}
1957
1958
wlevel--;
1959
rlevel--;
1960
}
1961
1962
@ Expand a |do| statement.
1963
@<Rdoc@>=
1964
@r
1965
/* Source construction: */
1966
do expr;
1967
{
1968
stmt;
1969
}
1970
1971
@n
1972
/* Translation: */
1973
do NEXT@,@,expr
1974
stmt
1975
NEXT: continue
1976
BREAK: continue
1977
1978
@
1979
@<Part 2@>=@[
1980
X_FCN
1981
x_do(VOID)
1982
{
1983
eight_bits b;
1984
sixteen_bits a;
1985
1986
/* Is the next a statement number? */
1987
b = next_byte(); @~ BACK_UP@;
1988
1989
/* Don't expand the ordinary Fortran numbered |do|. */
1990
if(b == constant)
1991
{
1992
id0(id_do); /* Numbered |do|. */
1993
return;
1994
}
1995
1996
/* Expand the Ratfor |do|. */
1997
expanding(do_CMD);
1998
save_lbls(do_CMD,0L,max_stmt,max_stmt+1,2);
1999
2000
OUT_CMD(YES,'d',"","",0); /* Comment to output. */
2001
2002
/* The following |if| accounts for the possibility of a semicolon or left
2003
brace immediately following the |do|. */
2004
if(!TOKEN1(a = next_byte()))
2005
a = IDENTIFIER(a,next_byte());
2006
2007
BACK_UP@;
2008
2009
if(!(a==id_while))
2010
{
2011
ID(DO); @~ if(!Fortran88) LABEL(s_next); @~ COPY_2TO(@'{',@';'); @~ NL;
2012
INDENT;
2013
stmt(TO_OUTPUT,0);
2014
OUTDENT;
2015
if(Fortran88)
2016
{
2017
ID(END); @~ ID(DO);
2018
if(symbolic_label) id0(symbolic_label);
2019
NL;
2020
}
2021
else
2022
{
2023
CONTINUE(s_next);
2024
if(was_break) {CONTINUE(s_break);}
2025
}
2026
}
2027
2028
wlevel--;
2029
rlevel--;
2030
}
2031
2032
@ Expand a |for| statement.
2033
@<Rdoc@>=
2034
@r
2035
/* Source construction: */
2036
for(a;b;c)
2037
{stmt;}
2038
2039
@n
2040
/* Translation: */
2041
a
2042
TOP: if(b) then
2043
stmt
2044
NEXT: continue
2045
c
2046
goto TOP
2047
endif
2048
BREAK: continue
2049
2050
@ Here, we must parse and save the three elements
2051
of the |for|, then spit them out later.
2052
2053
@d SAVE8 200 /* Default length of buffer for parenthesized stuff like
2054
|if(...)@;|. */
2055
@d BIG_SAVE8 10000 /* Default length for |case| text. */
2056
2057
@<Part 2@>=@[
2058
2059
X_FCN
2060
x_for(VOID)
2061
{
2062
eight_bits HUGE *a=NULL, HUGE *b=NULL, HUGE *c=NULL,
2063
HUGE *pa, HUGE *pb, HUGE *pc;
2064
2065
expanding(for_CMD);
2066
save_lbls(for_CMD,max_stmt,max_stmt+1,max_stmt+2,3);
2067
2068
/* Check for parenthesized list. */
2069
IS_NEXT_PAREN(for);
2070
pa = SAVE_AFTER(&a,SAVE8,@';'); /* Initialization. */
2071
pb = SAVE_AFTER(&b,SAVE8,@';'); /* Test. */
2072
pc = SAVE_AFTER(&c,SAVE8,@')'); /* Reinitialization. */
2073
2074
OUT_CMD(YES,'f',"","(%s;%s;%s)",6,a,pa,b,pb,c,pc); /* Comment to output. */
2075
2076
/* Initialization. */
2077
if(pa > a) {copy_out(a,pa,!macro); @~ NL;}
2078
2079
/* Conditional. */
2080
if(pb > b)
2081
{IF(s_top); @~ LP; @~ copy_out(b,pb,!macro); @~ RP; @~ THEN;}
2082
else {CONTINUE(s_top);}
2083
2084
/* Body. */
2085
INDENT;
2086
stmt(TO_OUTPUT,0);
2087
2088
/* Reinitialization. */
2089
if(was_next) {CONTINUE(s_next);}
2090
if(pc > c)
2091
{
2092
OUT_CMD(NO,'f',"Reinitialization of",
2093
"(%s;%s;%s)",6,a,pa,b,pb,c,pc);
2094
copy_out(c,pc,!macro); @~ NL;
2095
}
2096
GOTO(s_top);
2097
OUTDENT;
2098
if(pb > b) {ENDIF;}
2099
if(was_break) {CONTINUE(s_break);}
2100
wlevel--;
2101
rlevel--;
2102
FREE_MEM(a,"for:a",SAVE8,eight_bits);
2103
FREE_MEM(b,"for:b",SAVE8,eight_bits);
2104
FREE_MEM(c,"for:c",SAVE8,eight_bits);
2105
}
2106
2107
@ Expand an |if| statement.
2108
@<Rdoc@>=
2109
@r
2110
/* Source construction: */
2111
if(expr)
2112
{stmt;}
2113
else if(expr)
2114
{stmt;}
2115
else
2116
{stmt;}
2117
2118
@n
2119
/* Translation: */
2120
if(expr) then
2121
stmt
2122
else if(expr) then
2123
stmt
2124
else
2125
stmt
2126
endif
2127
2128
@
2129
@<Part 2@>=@[
2130
2131
X_FCN
2132
x_if(VOID)
2133
{
2134
expanding(if_CMD);
2135
OUT_CMD(YES,'i',"","",0);
2136
2137
XPN_BODY(IF,YES,THEN);
2138
2139
/* Hunt for |else| or |elseif|. */
2140
WHILE()
2141
if(!XPN_ELSE(id_if,id_elseif,IF,YES,THEN)) break;
2142
2143
ENDIF;
2144
flush_comments();
2145
rlevel--;
2146
}
2147
2148
2149
@
2150
@<Part 2@>=@[
2151
2152
SRTN
2153
xpn_body FCN((token1,scan_parens,token2))
2154
sixteen_bits token1 C0("")@;
2155
boolean scan_parens C0("")@;
2156
sixteen_bits token2 C1("")@;
2157
{
2158
LABEL(ignore); @~ id0(token1);
2159
2160
if(scan_parens) PARENS;
2161
if(token2) id0(token2);
2162
NL;
2163
2164
INDENT;
2165
stmt(TO_OUTPUT,0);
2166
OUTDENT;
2167
}
2168
2169
@
2170
@<Part 2@>=@[
2171
2172
boolean
2173
xpn_else FCN((id_x,id_else_x,token1,scan_parens,token2))
2174
sixteen_bits id_x C0("")@;
2175
sixteen_bits id_else_x C0("")@;
2176
sixteen_bits token1 C0("")@;
2177
boolean scan_parens C0("")@;
2178
sixteen_bits token2 C1("")@;
2179
{
2180
sixteen_bits a;
2181
2182
skip_newlines(SAVE_COMMENTS);
2183
2184
if(TOKEN1(a= next_byte()))
2185
{ /* Not a keyword. */
2186
BACK_UP@;
2187
return NO;
2188
}
2189
else
2190
{
2191
a = IDENTIFIER(a,next_byte());
2192
2193
if(a == id_else_x)
2194
{ /* |@r elseif| */
2195
flush_comments();
2196
ELSE;
2197
xpn_body(token1,scan_parens,token2);
2198
return YES;
2199
}
2200
2201
if(a != id_else)
2202
{ /* Neither |else if| nor |else|. */
2203
BACK_UP@;
2204
return NO;
2205
}
2206
else
2207
{ /* |@r else| */
2208
flush_comments();
2209
ELSE;
2210
2211
if(TOKEN1(a= next_byte())) BACK_UP@;
2212
else
2213
{ /* Possible |@r if| or |@r where|. */
2214
a = IDENTIFIER(a,next_byte());
2215
2216
if(a == id_x) /* |else if| or |else where@;| */
2217
{
2218
xpn_body(token1,scan_parens,token2);
2219
return YES;
2220
}
2221
else BACK_UP@;
2222
}
2223
2224
if(out_pos > rst_pos) NL; /* Terminate the |else|. */
2225
2226
INDENT;
2227
stmt(TO_OUTPUT,0); /* Expand body of |else|. */
2228
OUTDENT;
2229
return NO;
2230
}
2231
}
2232
}
2233
2234
@ The previous scan should have found all the |else|'s. If an |else| is
2235
encountered anywhere else, it's an error and is just skipped.
2236
@<Part 2@>=@[
2237
2238
X_FCN
2239
x_else(VOID)
2240
{
2241
UNEXPECTED("else");
2242
}
2243
2244
X_FCN
2245
x_els_if(VOID)
2246
{
2247
UNEXPECTED("elseif");
2248
}
2249
2250
@ Also, no |end| statements should appear explicitly anywhere; the
2251
terminating |end| statement is inserted automatically. Therefore, if we
2252
encounter any of these, it's an error.
2253
2254
@<Part 2@>=@[
2255
2256
X_FCN
2257
x_end(VOID)
2258
{
2259
UNEXPECTED("end");
2260
}
2261
2262
X_FCN
2263
x_en_if(VOID)
2264
{
2265
UNEXPECTED("endif");
2266
}
2267
2268
X_FCN
2269
x_en_interface(VOID)
2270
{
2271
UNEXPECTED("endinterface");
2272
}
2273
2274
X_FCN
2275
x_en_module(VOID)
2276
{
2277
UNEXPECTED("endmodule");
2278
}
2279
2280
X_FCN
2281
x_en_select(VOID)
2282
{
2283
UNEXPECTED("endselect");
2284
}
2285
2286
X_FCN
2287
x_en_type(VOID)
2288
{
2289
UNEXPECTED("endtype");
2290
}
2291
2292
X_FCN
2293
x_en_where(VOID)
2294
{
2295
UNEXPECTED("endwhere");
2296
}
2297
2298
X_FCN
2299
x_procedure(VOID)
2300
{
2301
UNEXPECTED("procedure");
2302
}
2303
2304
X_FCN
2305
x_then(VOID)
2306
{
2307
UNEXPECTED("then");
2308
}
2309
2310
X_FCN
2311
x_until(VOID)
2312
{
2313
UNEXPECTED("until");
2314
}
2315
2316
@ Expand a |@n9 where| statement.
2317
@<Rdoc@>=
2318
@r9
2319
/* Source construction: */
2320
where(expr)
2321
{stmt;}
2322
else
2323
{stmt;}
2324
2325
@n[-n9]
2326
/* Translation: */
2327
where(expr)
2328
stmt
2329
else where
2330
stmt
2331
end where
2332
2333
@
2334
@d id__ignore ignore
2335
2336
@<Part 2@>=@[
2337
2338
X_FCN
2339
x_where(VOID)
2340
{
2341
expanding(where_CMD);
2342
OUT_CMD(YES,'h',"","",0);
2343
2344
XPN_BODY(WHERE,YES,ignore);
2345
XPN_ELSE(id_where,id_elsewhere,WHERE,NO,ignore);
2346
2347
ENDWHERE;
2348
rlevel--;
2349
}
2350
2351
@ An error message about an unexpected keyword.
2352
2353
@d UNEXPECTED(id) unexpected(OC(id))
2354
2355
@<Part 2@>=@[
2356
2357
SRTN
2358
unexpected FCN((id))
2359
CONST outer_char id[] C1("Error message.")@;
2360
{
2361
RAT_ERROR(WARNING,"Unexpected keyword \"%s\" ignored",1,id);
2362
}
2363
2364
@*1 Expand a |switch| statement. This is the most complicated \Ratfor\
2365
statement. Several different kinds of expansions may be made, for
2366
efficiency reasons. If the list of cases is fairly dense, with few gaps,
2367
then a computed |goto| is used; otherwise, the |switch| is expanded into a
2368
series of |if| statements. In order to know which expansion to make, the
2369
entire |switch| must be read into memory first.
2370
@<Rdoc@>=
2371
@r
2372
/* Source construction: */
2373
switch(expr)
2374
{
2375
case 1:
2376
stmts;
2377
break;
2378
2379
case 2:
2380
stmts;
2381
break;
2382
2383
default:
2384
stmts;
2385
break;
2386
}
2387
2388
@n
2389
/* Translation: */
2390
i123 = expr
2391
if(!(i123 == 1)) goto S2
2392
stmts
2393
goto 123
2394
2395
S2: continue
2396
if(!(i123==2)) goto S3
2397
stmts
2398
goto 123
2399
DFLT: continue
2400
stmts
2401
goto 123
2402
S3: continue
2403
goto DFLT
2404
123: continue
2405
2406
@ We need a flag to say that we're inside at least one |switch|, so we can
2407
check whether the |case| or |default| statements are in valid places. We
2408
also need various structures to hold the various parts of the |switch| as
2409
it is parsed.
2410
2411
@<Typedef...@>=
2412
2413
IN_RATFOR int switch_level RSET(0);
2414
2415
/* The starting and ending positions of a token string. */
2416
typedef struct
2417
{
2418
eight_bits HUGE *start, HUGE *next, HUGE *end;
2419
} TEXT;
2420
2421
/* The info for one |case| or |default|. */
2422
typedef struct
2423
{
2424
STMT_LBL label; // Statement label assigned to this |case|.
2425
TEXT case_txt; // The token string for the |case| value.
2426
CASE_TYPE value; // The numerical value of the above string.
2427
TEXT txt; // The body of the |case| or |default|.
2428
boolean is_default; // Distinguishes between |default| and |case|.
2429
} CASE;
2430
2431
IN_RATFOR CASE HUGE *cur_case; // A pointer to the current case being processed.
2432
2433
/* A whole |switch|. */
2434
typedef struct
2435
{
2436
CASE HUGE *cases; // The array of cases.
2437
unsigned short ncases; // How many cases?
2438
boolean has_default; // At most one |default| is allowed.
2439
} SWITCH;
2440
2441
IN_RATFOR SWITCH HUGE *switches; // Switches may be nested, so we need an array.
2442
2443
@ Memory is only allocated for |switches| and |cases| when and if it is
2444
actually needed. However, once allocated, it is never deallocated.
2445
2446
For convenience, |switches[0]| and |cases[0]| are not used.
2447
2448
@d NSWITCHES 20 /* Nesting level for |switch| statements. */
2449
@d NCASES 257 /* Number of |case| labels in a |switch|. */
2450
@d cur_switch switches[switch_level]
2451
2452
@<Part 2@>=@[
2453
2454
X_FCN
2455
x_switch(VOID)
2456
{
2457
eight_bits HUGE *a=NULL, HUGE *pa;
2458
outer_char temp[N_IDBUF];
2459
unsigned short k;
2460
boolean computed_goto = NO;
2461
CASE_TYPE cmin=0,cmax; /* Minimum and maximum |case| values. */
2462
CASE_TYPE mcases=0; // Spread in the case value.
2463
unsigned short num_cases; // Number of cases.
2464
2465
expanding(switch_CMD);
2466
2467
if(switches==NULL) switches = GET_MEM("switches",NSWITCHES,SWITCH);
2468
2469
++switch_level;
2470
if(cur_switch.cases == NULL)
2471
cur_switch.cases = GET_MEM("cur_switch.cases",NCASES,CASE);
2472
cur_switch.ncases = 0;
2473
cur_switch.has_default = NO;
2474
2475
/* Allocate the zeroth case. This won't be used, except if there's text
2476
before the first |case|. */
2477
cur_case = &cur_switch.cases[0];
2478
cur_case->txt.next = cur_case->txt.start =
2479
GET_MEM("cur_case->txt.start",BIG_SAVE8,eight_bits);
2480
cur_case->txt.end = cur_case->txt.start + BIG_SAVE8;
2481
2482
save_lbls(switch_CMD,0L,s_next,max_stmt,1);
2483
2484
/* Look for the parenthesized expression. */
2485
IS_NEXT_PAREN(switch);
2486
pa = SAVE_AFTER(&a,SAVE8,@')'); /* Save the expression. */
2487
2488
OUT_CMD(YES,'s',"","(%s)",2,a,pa); /* Comment to output. */
2489
2490
if(Fortran88)
2491
{
2492
ID(SELECT); @~ ID(CASE); @~ LP; @~ copy_out(a,pa,!macro); @~ RP; @~ NL;
2493
}
2494
INDENT;
2495
stmt(TO_MEMORY,BRACE_ONLY); /* Read the |switch| into memory. */
2496
2497
if(Fortran88)
2498
{
2499
computed_goto = NO;
2500
}
2501
else @<Analyze the cases@>;
2502
2503
if(computed_goto) @<Use computed |goto|@>@;
2504
else @<Use multiple |if|s@>@;
2505
OUTDENT;
2506
2507
if(Fortran88)
2508
{
2509
if(was_break) LABEL(s_break);
2510
ID(END); @~ ID(SELECT);
2511
if(symbolic_label) id0(symbolic_label);
2512
NL;
2513
}
2514
else if(was_break) {CONTINUE(s_break);}
2515
2516
wlevel--;
2517
rlevel--;
2518
switch_level--;
2519
2520
FREE_MEM(a,"switch:a",SAVE8,eight_bits);
2521
}
2522
2523
@ First, evaluate all the cases. If they don't all evaluate to integers,
2524
use |if| statements. Otherwise, if the ratio of the case value spread to
2525
the total number of cases is less than |g_ratio|, then use a computed
2526
|goto|. Also do that if the number of cases if greater than
2527
|marginal_cases| (if the spread is less than |max_spread|). Otherwise, use
2528
|if| statements.
2529
2530
@<Glob...@>=
2531
2532
IN_COMMON double g_ratio;
2533
IN_COMMON CASE_TYPE max_spread;
2534
IN_COMMON unsigned short marginal_cases;
2535
2536
IN_EVAL VAL HUGE *val_ptr, HUGE *val_heap;
2537
2538
@
2539
@<Analyze the cases@>=
2540
@B
2541
unsigned short k;
2542
VAL val;
2543
2544
@b
2545
/* We need to find the minimum and maximum |case| value. */
2546
cmin = LONG_MAX; // See |limits.h|.
2547
cmax = LONG_MIN + 1; // The |+1| takes care of an \.{scc} bug.
2548
2549
for(k=1; k<=cur_switch.ncases; k++)
2550
{
2551
cur_case = &cur_switch.cases[k];
2552
2553
if(cur_case->is_default) continue;
2554
2555
/* Call up the expression evaluator to reduce the |case| text to an
2556
integer. */
2557
{
2558
extern boolean eval_msgs;
2559
2560
eval_msgs = NO;
2561
EVALUATE(val,cur_case->case_txt.start,cur_case->case_txt.next);
2562
eval_msgs = YES;
2563
}
2564
2565
switch(val.type)
2566
{
2567
case Int:
2568
cur_case->value = (CASE_TYPE)(val.value.i);
2569
break;
2570
2571
case Double:
2572
RAT_ERROR(WARNING,
2573
"Case value %#g of type double truncated to int",1,val.value.d);
2574
cur_case->value = (CASE_TYPE)(val.value.d);
2575
break;
2576
2577
default:
2578
/* The case didn't evaluate to an integer. */
2579
computed_goto = NO;
2580
goto not_integer;
2581
}
2582
2583
/* Running determination of the minimum and maximum |case| value. */
2584
if(cur_case->value < cmin) cmin = cur_case->value;
2585
if(cur_case->value > cmax) cmax = cur_case->value;
2586
}
2587
2588
if(cur_switch.ncases==1 && s_default!=0)
2589
{
2590
mcases = 0;
2591
computed_goto = YES;
2592
goto not_integer;
2593
}
2594
else mcases = (cmax - cmin + 1); // Spread in the cases.
2595
2596
if((num_cases = cur_switch.ncases-(unsigned short)(s_default!=0)) == 0)
2597
{
2598
computed_goto = NO;
2599
goto not_integer;
2600
}
2601
computed_goto = BOOLEAN((num_cases > marginal_cases &&
2602
mcases < max_spread) ? YES :
2603
((double)mcases)/num_cases <= g_ratio);
2604
2605
not_integer: ;
2606
}
2607
2608
@ We use the computed |goto| when the list of cases is fairly dense, with
2609
few gaps. Out of bounds cases branch to the |default| if present, or around
2610
the whole |switch| otherwise.
2611
2612
@<Use computed |goto|@>=
2613
@B
2614
CASE_TYPE m; // Indexes case values.
2615
unsigned short k; // Indexes the cases.
2616
2617
@b
2618
/* Generate computed |goto| to handle the cases; fill in any gaps. */
2619
OUTDENT;
2620
if(mcases > 0) {ID(GOTO); @~ LP;}
2621
2622
for(m=0; m<mcases; m++,m<mcases ? COMMA : RP)
2623
LABEL(label_case(cmin,m));
2624
2625
if(mcases > 0)
2626
{
2627
COMMA; @~ LP; @~ copy_out(a,pa,!macro); @~ RP;
2628
@~ MINUS; @~ LP; @~ NUMBER(cmin-1); @~ RP; @~ NL;
2629
}
2630
2631
/* Handle the out-of-bound statements. (If the previous |goto| was out of
2632
range, control passes to here.) */
2633
GOTO(s_default ? s_default : (was_break=YES,s_break));
2634
INDENT;
2635
2636
/* Output the various cases. */
2637
for(k=1; k<=cur_switch.ncases; k++)
2638
{
2639
cur_case = &cur_switch.cases[k];
2640
2641
show_cmd(cur_case);
2642
OUTDENT;
2643
CONTINUE(cur_case->label);
2644
INDENT;
2645
copy_out(cur_case->txt.start,cur_case->txt.next,!macro);
2646
rlevel--;
2647
}
2648
}
2649
2650
@ This code is used when the computed |@r goto| is not appropriate. In this
2651
case, the |switch| is expanded into a series of multiple |if|s.
2652
2653
@<Use multiple...@>=
2654
{
2655
boolean case_ended_with_break = NO;
2656
boolean made_temp = YES; /* Did we construct a temporary integer for the
2657
|switch|? */
2658
2659
/* |made_temp == NO| means the expression is a single identifier. */
2660
if(!Fortran88 && (made_temp = BOOLEAN(!((pa-a)==2 && !TOKEN1(*a)))))
2661
{
2662
/* Make a temporary integer identifier to effect the comparisons. */
2663
SPRINTF(N_IDBUF,temp,`"I%d",s_break`);
2664
to_ASCII(temp);
2665
icase = ID_NUM((ASCII HUGE *)temp,(ASCII HUGE *)(temp+STRLEN(temp)));
2666
2667
id0(icase); @~ EQUALS; @~ copy_out(a,pa,!macro); @~ NL;
2668
}
2669
2670
for(k=1; k<=cur_switch.ncases; k++)
2671
@<Expand a |case| or |default|@>@;
2672
2673
if(!Fortran88)
2674
{
2675
CONTINUE(s_case); /* Finish off the last |case|. */
2676
if(s_default)
2677
{
2678
GOTO(s_default); /* Jump to the |default|, if present. */
2679
}
2680
}
2681
}
2682
2683
@ Display a |case| or |default| command as an output comment.
2684
2685
@<Part 2@>=@[
2686
2687
SRTN
2688
show_cmd FCN((cur_case))
2689
CONST CASE HUGE *cur_case C1("")@;
2690
{
2691
if(cur_case->is_default)
2692
{
2693
expanding(default_CMD);
2694
OUT_CMD(NO,'t',"",":",0);
2695
}
2696
else
2697
{
2698
expanding(case_CMD);
2699
OUT_CMD(NO,'c',""," %s:",2,
2700
cur_case->case_txt.start,cur_case->case_txt.next);
2701
}
2702
}
2703
2704
@ Return the appropriate label: If it's a |case|, generate a new label; if
2705
it's a |default|, return |s_default|; otherwise, return |s_default| if a
2706
|default| was present, or |s_break| otherwise.
2707
2708
@<Part 2@>=@[
2709
2710
STMT_LBL
2711
label_case FCN((cmin,m))
2712
CASE_TYPE cmin C0("")@;
2713
CASE_TYPE m C1("")@;
2714
{
2715
CASE_TYPE num = cmin + m;
2716
unsigned short k;
2717
2718
/* Check for ordinary cases. */
2719
for(k=1; k<=cur_switch.ncases; k++)
2720
{
2721
cur_case = &cur_switch.cases[k];
2722
2723
if(!cur_case->is_default && cur_case->value == num)
2724
return cur_case->label = s_case = max_stmt++;
2725
}
2726
2727
/* Look for |default|. */
2728
for(k=1; k<=cur_switch.ncases; k++)
2729
if(cur_case->is_default) return s_default;
2730
2731
return s_break; // A gap.
2732
}
2733
2734
@
2735
@<Expand a |case|...@>=
2736
{
2737
cur_case = &cur_switch.cases[k];
2738
2739
if(Fortran88)
2740
if(k==1) s_case = max_stmt++;
2741
else
2742
{
2743
@<Did last |case| end with ``|break;|''?@>@;
2744
if(!case_ended_with_break) {GOTO(s_case);}
2745
}
2746
2747
show_cmd(cur_case);
2748
OUTDENT;
2749
if(Fortran88)
2750
{
2751
ID(CASE);
2752
2753
if(cur_case->is_default) ID(DEFAULT);
2754
else
2755
{
2756
if(*cur_case->case_txt.start != @'(') LP;
2757
copy_out(cur_case->case_txt.start,cur_case->case_txt.next,
2758
!macro);
2759
if(*(cur_case->case_txt.next - 1) != @')') RP;
2760
}
2761
NL;
2762
INDENT;
2763
if(k > 1 && !case_ended_with_break)
2764
{
2765
CONTINUE(s_case);
2766
s_case = max_stmt++;
2767
}
2768
}
2769
else
2770
{
2771
if(cur_case->is_default) {CONTINUE(s_default);}
2772
else
2773
{
2774
IF(s_case); @~ LP; @~ NOT; @~ LP;
2775
/* The |made_temp?@e@:@e| form of the next command crashed the Apollo
2776
compiler. */
2777
if(made_temp) id0(icase); else copy_out(a,pa,!macro);
2778
EQ_EQ;
2779
copy_out(cur_case->case_txt.start,
2780
cur_case->case_txt.next,!macro);
2781
RP; @~ RP;
2782
GOTO(s_case=max_stmt++);
2783
}
2784
INDENT;
2785
}
2786
2787
/* Recall the text stored previously. */
2788
copy_out(cur_case->txt.start,cur_case->txt.next,!macro);
2789
2790
rlevel--;
2791
}
2792
2793
@ To pretty up the \FORTRAN-88 output, we check to see if the previous case
2794
ended with a |break| statement. If so, we don't output a |@r goto| to the
2795
next case.
2796
@<Did last...@>=
2797
@B
2798
CASE HUGE *last_case = &cur_switch.cases[k-1];
2799
2800
@b
2801
if(PTR_DIFF(long,last_case->txt.next,last_case->txt.start) >= 3)
2802
case_ended_with_break =
2803
BOOLEAN(MEMCMP(last_case->txt.next-3,break_tokens,3) == 0);
2804
else case_ended_with_break = NO;
2805
}
2806
2807
@ Expand a |case| statement.
2808
@<Part 2@>=@[
2809
X_FCN x_case(VOID)
2810
{
2811
if(switch_level ==0)
2812
{
2813
not_switch(OC("case"));
2814
return;
2815
}
2816
2817
expanding(case_CMD);
2818
2819
@<Initialize a |case| or |default|@>;
2820
cur_case->case_txt.next = SAVE_AFTER(&cur_case->case_txt.start,SAVE8,@':');
2821
cur_case->is_default = NO;
2822
2823
@<Check for duplicate |case|s@>@;
2824
2825
rlevel--;
2826
}
2827
2828
@ This fragment is used in expanding |case| and |default| statements; it
2829
sets things up so the text is stored in the proper place.
2830
@<Initialize a |case|...@>=
2831
2832
*cur_case->txt.next = '\0'; /* Terminate previous text. */
2833
2834
/* Get address of next available |CASE| structure. */
2835
cur_case = &cur_switch.cases[++cur_switch.ncases];
2836
2837
/* If that hasn't been allocated yet, do so. */
2838
if(cur_case->case_txt.start==NULL)
2839
{
2840
cur_case->case_txt.start =
2841
GET_MEM("cur_case->case_txt.start",SAVE8,eight_bits);
2842
cur_case->case_txt.end = cur_case->case_txt.start + SAVE8;
2843
2844
cur_case->txt.start =
2845
GET_MEM("cur_case->txt.start",BIG_SAVE8,eight_bits);
2846
cur_case->txt.end = cur_case->txt.start + BIG_SAVE8;
2847
}
2848
2849
/* Initialize the pointer to beginning of buffer. */
2850
cur_case->txt.next = cur_case->txt.start;
2851
2852
@
2853
@<Check for duplicate...@>=
2854
{
2855
unsigned short k;
2856
CONST CASE HUGE *old_case;
2857
2858
for(k=1; k<cur_switch.ncases; k++)
2859
{
2860
old_case = &cur_switch.cases[k];
2861
2862
if(web_strcmp((CONST ASCII HUGE *)cur_case->case_txt.start,
2863
(CONST ASCII HUGE *)cur_case->case_txt.next,
2864
(CONST ASCII HUGE *)old_case->case_txt.start,
2865
(CONST ASCII HUGE *)old_case->case_txt.next) == EQUAL)
2866
{
2867
RAT_ERROR(ERROR,"Duplicate case value in switch",0);
2868
break;
2869
}
2870
}
2871
}
2872
2873
@ Expand a |default| statement. This just initializes stuff so the text is
2874
stored in the proper place.
2875
2876
@<Part 2@>=@[
2877
2878
X_FCN
2879
x_default(VOID)
2880
{
2881
if(switch_level == 0)
2882
{
2883
not_switch(OC("default"));
2884
return;
2885
}
2886
2887
expanding(default_CMD);
2888
2889
if(cur_switch.has_default)
2890
RAT_ERROR(ERROR,"Only one default allowed per switch",0);
2891
else cur_switch.has_default = YES;
2892
2893
@<Initialize a |case| or |default|@>;
2894
cur_case->case_txt.next = cur_case->case_txt.start;
2895
cur_case->is_default = YES;
2896
2897
cur_case->label = s_default = max_stmt++;
2898
2899
char_after(':'); /* |default| must be followed immediately by colon. */
2900
rlevel--;
2901
}
2902
2903
@*1 Program units.
2904
@r9
2905
@v .IN. "\\in" <
2906
@n9
2907
@v .IN. "\\in" <
2908
@<Rdoc@>=
2909
@r9
2910
/* Source construction: */
2911
program main
2912
{stmt;}
2913
2914
/* Translation: */
2915
@n9
2916
program main
2917
stmt
2918
end program main
2919
2920
/* Source: */
2921
@r9
2922
subroutine s(x,y,z)
2923
real x,y,z;
2924
{stmt;}
2925
2926
/* Translation: */
2927
@n9
2928
subroutine s(x,y,z)
2929
real x,y,z
2930
2931
stmt
2932
end subroutine s
2933
2934
/* Source: */
2935
@r9
2936
function f(i)
2937
integer i;
2938
{
2939
return 10;
2940
}
2941
2942
/* Translation: */
2943
@n9
2944
function f(i)
2945
integer i
2946
2947
f = 10
2948
return
2949
end function f
2950
2951
/* Source: */
2952
@r9
2953
block data work
2954
{
2955
common/wrkcom/ a,b,c;
2956
data a/1.0/, b/2.0/, c/0.0/;
2957
}
2958
2959
/* Translation: */
2960
@n9
2961
block data work
2962
common/wrkcom/ a,b,c
2963
data a/1.0/, b/2.0/, c/0.0/
2964
end block data work
2965
2966
/* Source: */
2967
@r9
2968
module integer_sets
2969
{
2970
integer i;
2971
2972
type set
2973
{
2974
private:
2975
integer card;
2976
};
2977
2978
interface operator (.IN.)
2979
{
2980
module procedure element;
2981
}
2982
}
2983
2984
/* Translation: */
2985
@n9
2986
module integer_sets
2987
integer i
2988
2989
type set
2990
private
2991
integer card
2992
end type set
2993
2994
interface operator (.IN.)
2995
module procedure element
2996
end interface
2997
2998
end module integer_sets
2999
3000
@ Expand a |@r program|, |@r9 module|, |@r subroutine|, or |@r function|
3001
statement. We define a \WEB\ macro to generate separate functions.
3002
3003
@#if 0
3004
if(brace_level != 0)
3005
{
3006
RAT_ERROR(ERROR,
3007
"Missing '}' (level %d) at beginning of %s; \
3008
END statement inserted",2,brace_level,#type);
3009
END;
3010
brace_level = 0;
3011
}
3012
@#endif
3013
3014
@m X_ROUTINE(type,is_fcn,check_id)@/
3015
X_FCN x_##type(VOID)
3016
{
3017
sixteen_bits a;
3018
eight_bits b;
3019
3020
expanding(type##_CMD);
3021
3022
// Insert |brace_level| check here.
3023
3024
WHILE()
3025
{
3026
a = next_byte();
3027
3028
if(!(a == @' ' || a == tab_mark))
3029
break;
3030
}
3031
3032
if(TOKEN1(a))
3033
{
3034
$P if(check_id)
3035
RAT_ERROR(ERROR,"Expected identifier after \"%s\"",1,#type);
3036
$P endif
3037
BACK_UP@;
3038
cur_fcn = NO_FCN;
3039
is_function = NO;
3040
}
3041
else
3042
{
3043
cur_fcn = IDENTIFIER(a,next_byte());
3044
is_function = is_fcn;
3045
}
3046
3047
id0(id_##type); @~ id0(cur_fcn); /* |@r subroutine sub| */
3048
3049
if(cur_fcn == id_procedure)
3050
{ // |@r9 module procedure test;|
3051
COPY_TO(@';'); @~ NL;
3052
}
3053
else
3054
{
3055
b = next_byte(); @~ BACK_UP@;
3056
if(b == @'(') PARENS; /* Routine with arguments. */
3057
NL; // Start the body on the next line.
3058
EAT_AUTO_SEMI;
3059
skip_newlines(COPY_COMMENTS);
3060
INDENT;
3061
copy_out(insert.type.start,insert.type.end,!macro);
3062
out_char(@';');
3063
COPY_2TO(@'{',NOT_AFTER);
3064
if(psave_buffer > save_buffer) NL; /* Argument declarations,
3065
with blank line between argument declarations and body. */
3066
brace_level++;
3067
stmt(TO_OUTPUT,BRACE_ONLY);
3068
brace_level--;
3069
OUTDENT;
3070
3071
ID(END);
3072
if(Fortran88) {id0(id_##type); @~ id0(cur_fcn);}
3073
NL;
3074
}
3075
3076
cur_fcn = NO_FCN; // No longer inside a function.
3077
3078
rlevel--;
3079
}
3080
3081
@<Part 2@>=@[
3082
3083
X_ROUTINE(program,NO,YES)@;
3084
X_ROUTINE(module,NO,YES)@;
3085
X_ROUTINE(subroutine,NO,YES)@;
3086
X_ROUTINE(function,YES,YES)@;
3087
X_ROUTINE(blockdata,NO,NO)@;
3088
X_ROUTINE(interface,NO,NO)@;
3089
3090
@ The |@r block data| statement has optional spaces.
3091
@<Part 2@>=@[
3092
3093
X_FCN
3094
x_block(VOID)
3095
{
3096
sixteen_bits a;
3097
3098
if(TOKEN1(a=next_byte()))
3099
{
3100
BACK_UP@;
3101
id0(id_block);
3102
}
3103
else
3104
{
3105
a = IDENTIFIER(a,next_byte());
3106
3107
if(a == id_data) x_blockdata();
3108
else
3109
{
3110
BACK_UP@;
3111
id0(a);
3112
}
3113
}
3114
}
3115
3116
@*1 Expand a |@r9 contains| statement.
3117
@<Rdoc@>=
3118
@r9
3119
/* Source construction: */
3120
subroutine outer
3121
{
3122
call inner(a);
3123
3124
contains:
3125
subroutine inner(b)
3126
{}
3127
}
3128
3129
/* Translation: The |@r9 contains| is appropriately outdented. */
3130
3131
@ We do nothing here except outdent the |@r9 contains|.
3132
3133
@<Part 2@>=@[
3134
3135
X_FCN
3136
x_contains(VOID)
3137
{
3138
OUTDENT;
3139
ID(CONTAINS);
3140
char_after(':');
3141
NL;
3142
INDENT;
3143
}
3144
3145
@*1 Expand a |@r9 type| statement.
3146
3147
@<Rdoc@>=
3148
@r9
3149
/* Source construction: */
3150
type person
3151
{
3152
integer i;
3153
real x;
3154
};
3155
3156
@n9
3157
/* Translation: */
3158
type person
3159
integer i
3160
real x
3161
end type person
3162
3163
@ We define a macro to generate separate functions.
3164
3165
@m X_STRUCT(type)@/
3166
3167
X_FCN x_##type(VOID)
3168
{
3169
sixteen_bits a;
3170
eight_bits b;
3171
3172
b = next_byte(); @~ BACK_UP@;
3173
if(b == @',') {} /* Access spec. */
3174
else if(b==@'(')
3175
{
3176
id0(id_##type);
3177
return;
3178
}
3179
3180
expanding(type##_CMD);
3181
3182
if(TOKEN1(a= next_byte()))
3183
{
3184
RAT_ERROR(ERROR,"Expected identifier after \"%s\"",1,#type);
3185
BACK_UP@;
3186
cur_struct = NO_FCN;
3187
}
3188
else
3189
{
3190
cur_struct = IDENTIFIER(a,next_byte());
3191
}
3192
3193
id0(id_##type); @~ id0(cur_struct); /* |@r9 type person| */
3194
NL; // Start the body on the next line.
3195
INDENT;
3196
brace_level++;
3197
stmt(TO_OUTPUT,BRACE_ONLY);
3198
brace_level--;
3199
OUTDENT;
3200
3201
ID(END); @~ id0(id_##type); @~ id0(cur_struct);
3202
char_after(';'); @~ OUT_CHAR(';');
3203
3204
wlevel--;
3205
rlevel--;
3206
}
3207
3208
@<Part 2@>=@[
3209
X_STRUCT(type)@;
3210
@#if 0
3211
X_STRUCT(module)@;
3212
@#endif
3213
3214
@ Expand a |return| statement. Turns construction `|@r return expr@;|' into `|@n
3215
f = expr; return;|'
3216
.
3217
@<Part 2@>=@[
3218
3219
X_FCN
3220
x_return(VOID)
3221
{
3222
eight_bits HUGE *return_expr=NULL, HUGE *pr;
3223
3224
expanding(return_CMD);
3225
3226
/* Save the return expression, if it's there. */
3227
if((pr=SAVE_AFTER(&return_expr,SAVE8,@';')) > return_expr)
3228
{
3229
if(!is_function)
3230
RAT_ERROR(ERROR,
3231
"Can't return value from program or subroutine",0);
3232
else
3233
{
3234
OUT_CMD(YES,'r',""," %s",2,return_expr,pr);
3235
id0(cur_fcn); @~ EQUALS; @~
3236
copy_out(return_expr,pr,!macro); @~ NL;
3237
}
3238
}
3239
3240
RETURN;
3241
rlevel--;
3242
FREE_MEM(return_expr,"return_expr",SAVE8,eight_bits);
3243
}
3244
3245
@ This function implements the |$DO| and |$UNROLL| built-ins. |$DO| is
3246
defined in \FTANGLE.
3247
3248
@<Part 2@>=@[
3249
3250
X_FCN
3251
x_unroll(VOID)
3252
{
3253
eight_bits HUGE *I = NULL, HUGE *pI;
3254
eight_bits HUGE *Imin = NULL, HUGE *pImin;
3255
eight_bits HUGE *Imax = NULL, HUGE *pImax;
3256
eight_bits HUGE *Di = NULL, HUGE *pDi;
3257
eight_bits HUGE *txt = NULL, HUGE *ptxt;
3258
int i,imin,imax,di;
3259
name_pointer n;
3260
text_pointer t;
3261
eight_bits temp[20];
3262
extern int last_bytes;
3263
extern boolean saved_token;
3264
eight_bits c;
3265
3266
expanding(_DO_CMD);
3267
3268
IS_NEXT_PAREN("$DO");
3269
3270
pI = SAVE_AFTER(&I,SAVE8,@',');
3271
3272
if(TOKEN1(*I))
3273
{
3274
RAT_ERROR(ERROR, "Expected identifier for first argument of $DO; \
3275
expansion aborted",0);
3276
return;
3277
}
3278
3279
pImin = SAVE_AFTER(&Imin,SAVE8,@',');
3280
imin = neval(Imin,pImin);
3281
3282
pImax = SAVE_AFTER(&Imax,SAVE8,@',');
3283
imax = neval(Imax,pImax);
3284
3285
pDi = SAVE_AFTER(&Di,SAVE8,@')');
3286
di = neval(Di,pDi);
3287
3288
EAT_AUTO_SEMI;
3289
skip_newlines(NO);
3290
3291
c = next_byte();
3292
3293
if(!(c==@'{' || c==@'('))
3294
{
3295
RAT_ERROR(ERROR, "Was expecting '{' or '(', not '%c', after $DO(); \
3296
expansion aborted", 1, XCHR(c));
3297
return;
3298
}
3299
3300
/* Absorb the body of the |$DO|. Tell |next_byte| to not expand macros, so
3301
the loop counter can be used as an argument to a macro such as |$IFCASE|. */
3302
mac_protected = YES;
3303
ptxt = SAVE_AFTER(&txt, BIG_SAVE8, c==@'{' ? @'}' : @')');
3304
mac_protected = NO;
3305
3306
n = name_dir + IDENTIFIER(*I, *(I+1));
3307
n->info.Macro_type = IMMEDIATE_MACRO;
3308
t = GET_MEM("equiv", 2, text);
3309
n->equiv_or_xref = (EQUIV)t;
3310
t->tok_start = temp;
3311
t->moffset = 2;
3312
3313
if(!((di >= 0 && imax < imin) || (di < 0 && imax > imin)))
3314
for(i=imin;di >= 0 ? i<=imax : i>=imax; i+=di)
3315
{
3316
STRNCPY(temp,I,2);
3317
sprintf((char *)(temp+2), "%c%d%c", XCHR(constant), i, XCHR(constant));
3318
to_ASCII(temp+2);
3319
#if 0
3320
(t+1)->tok_start = temp + STRLEN(temp);
3321
#endif
3322
t->nbytes = STRLEN(temp);
3323
copy_out(txt, ptxt, !macro);
3324
3325
if(i == imax)
3326
break;
3327
}
3328
3329
rlevel--;
3330
3331
FREE_MEM(t, "t", 2, text);
3332
n->equiv_or_xref = NULL;
3333
n->info.Macro_type = NOT_DEFINED;
3334
3335
FREE_MEM(I, "unroll:I", SAVE8, eight_bits);
3336
FREE_MEM(Imin, "unroll:Imin", SAVE8, eight_bits);
3337
FREE_MEM(Imax, "unroll:Imax", SAVE8, eight_bits);
3338
FREE_MEM(txt, "unroll:txt", SAVE8, eight_bits);
3339
}
3340
3341
@ Initialize automatic insertion material.
3342
@m INI_INSERT(type) insert.type.start = insert.type.end =
3343
GET_MEM(#type,2,eight_bits)
3344
3345
@<Part 2@>=@[
3346
3347
SRTN
3348
ini_Ratfor(VOID)
3349
{
3350
INI_INSERT(program);
3351
INI_INSERT(module);
3352
INI_INSERT(subroutine);
3353
INI_INSERT(function);
3354
INI_INSERT(blockdata);
3355
INI_INSERT(interface);
3356
}
3357
3358
@* INDEX.
Loggerhead is a web-based interface for Breezy
Version: 2.0.1