00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028 #include "defs.h"
00029 #include "p1defs.h"
00030 #include "format.h"
00031 #include "output.h"
00032 #include "names.h"
00033 #include "iob.h"
00034
00035 int c_output_line_length = DEF_C_LINE_LENGTH;
00036
00037 int last_was_label;
00038
00039 static char this_proc_name[52];
00040
00041
00042
00043 static tagptr do_format Argdcl((FILEP, FILEP));
00044 static void do_p1_1while Argdcl((FILEP));
00045 static void do_p1_2while Argdcl((FILEP, FILEP));
00046 static tagptr do_p1_addr Argdcl((FILEP, FILEP));
00047 static void do_p1_asgoto Argdcl((FILEP, FILEP));
00048 static tagptr do_p1_charp Argdcl((FILEP));
00049 static void do_p1_comment Argdcl((FILEP, FILEP));
00050 static void do_p1_comp_goto Argdcl((FILEP, FILEP));
00051 static tagptr do_p1_const Argdcl((FILEP));
00052 static void do_p1_elif Argdcl((FILEP, FILEP));
00053 static void do_p1_else Argdcl((FILEP));
00054 static void do_p1_elseifstart Argdcl((FILEP));
00055 static void do_p1_end_for Argdcl((FILEP));
00056 static void do_p1_endelse Argdcl((FILEP));
00057 static void do_p1_endif Argdcl((FILEP));
00058 static tagptr do_p1_expr Argdcl((FILEP, FILEP));
00059 static tagptr do_p1_extern Argdcl((FILEP));
00060 static void do_p1_for Argdcl((FILEP, FILEP));
00061 static void do_p1_fortran Argdcl((FILEP, FILEP));
00062 static void do_p1_goto Argdcl((FILEP, FILEP));
00063 static tagptr do_p1_head Argdcl((FILEP, FILEP));
00064 static tagptr do_p1_ident Argdcl((FILEP));
00065 static void do_p1_if Argdcl((FILEP, FILEP));
00066 static void do_p1_label Argdcl((FILEP, FILEP));
00067 static tagptr do_p1_list Argdcl((FILEP, FILEP));
00068 static tagptr do_p1_literal Argdcl((FILEP));
00069 static tagptr do_p1_name_pointer Argdcl((FILEP));
00070 static void do_p1_set_line Argdcl((FILEP));
00071 static void do_p1_subr_ret Argdcl((FILEP, FILEP));
00072 static int get_p1_token Argdcl((FILEP));
00073 static int p1get_const Argdcl((FILEP, int, Constp*));
00074 static int p1getd Argdcl((FILEP, long int*));
00075 static int p1getf Argdcl((FILEP, char**));
00076 static int p1getn Argdcl((FILEP, int, char**));
00077 static int p1gets Argdcl((FILEP, char*, int));
00078 static void proto Argdcl((FILEP, Argtypes*, char*));
00079
00080 extern chainp assigned_fmts;
00081 char filename[P1_FILENAME_MAX];
00082 extern int gflag, sharp_line;
00083 int gflag1;
00084 extern char *parens;
00085
00086 void
00087 start_formatting(Void)
00088 {
00089 FILE *infile;
00090 static int wrote_one = 0;
00091 extern int usedefsforcommon;
00092 extern char *p1_file, *p1_bakfile;
00093
00094 this_proc_name[0] = '\0';
00095 last_was_label = 0;
00096 ei_next = ei_first;
00097 wh_next = wh_first;
00098
00099 (void) fclose (pass1_file);
00100 if ((infile = fopen (p1_file, binread)) == NULL)
00101 Fatal("start_formatting: couldn't open the intermediate file\n");
00102
00103 if (wrote_one)
00104 nice_printf (c_file, "\n");
00105
00106 while (!feof (infile)) {
00107 expptr this_expr;
00108
00109 this_expr = do_format (infile, c_file);
00110 if (this_expr) {
00111 out_and_free_statement (c_file, this_expr);
00112 }
00113 }
00114
00115 (void) fclose (infile);
00116
00117 if (last_was_label)
00118 nice_printf (c_file, ";\n");
00119
00120 prev_tab (c_file);
00121 gflag1 = sharp_line = 0;
00122 if (this_proc_name[0])
00123 nice_printf (c_file, "} /* %s */\n", this_proc_name);
00124
00125
00126
00127
00128 if (usedefsforcommon) {
00129 Extsym *ext;
00130 int did_one = 0;
00131
00132 for (ext = extsymtab; ext < nextext; ext++)
00133 if (ext -> extstg == STGCOMMON && ext -> used_here) {
00134 ext -> used_here = 0;
00135 if (!did_one)
00136 nice_printf (c_file, "\n");
00137 wr_abbrevs(c_file, 0, ext->extp);
00138 did_one = 1;
00139 ext -> extp = CHNULL;
00140 }
00141
00142 if (did_one)
00143 nice_printf (c_file, "\n");
00144 }
00145
00146 other_undefs(c_file);
00147
00148 wrote_one = 1;
00149
00150
00151
00152 if (debugflag && (pass1_file = fopen (p1_bakfile, binwrite)))
00153 if (infile = fopen (p1_file, binread)) {
00154 ffilecopy (infile, pass1_file);
00155 fclose (infile);
00156 fclose (pass1_file);
00157 }
00158
00159
00160
00161 scrub(p1_file);
00162
00163 if ((pass1_file = fopen (p1_file, binwrite)) == NULL)
00164 err ("start_formatting: couldn't reopen the pass1 file");
00165
00166 }
00167
00168
00169 static void
00170 #ifdef KR_headers
00171 put_semi(outfile)
00172 FILE *outfile;
00173 #else
00174 put_semi(FILE *outfile)
00175 #endif
00176 {
00177 nice_printf (outfile, ";\n");
00178 last_was_label = 0;
00179 }
00180
00181 #define SEM_CHECK(x) if (last_was_label) put_semi(x)
00182
00183
00184
00185
00186
00187 static expptr
00188 #ifdef KR_headers
00189 do_format(infile, outfile)
00190 FILE *infile;
00191 FILE *outfile;
00192 #else
00193 do_format(FILE *infile, FILE *outfile)
00194 #endif
00195 {
00196 int token_type, was_c_token;
00197 expptr retval = ENULL;
00198
00199 token_type = get_p1_token (infile);
00200 was_c_token = 1;
00201 switch (token_type) {
00202 case P1_COMMENT:
00203 do_p1_comment (infile, outfile);
00204 was_c_token = 0;
00205 break;
00206 case P1_SET_LINE:
00207 do_p1_set_line (infile);
00208 was_c_token = 0;
00209 break;
00210 case P1_FILENAME:
00211 p1gets(infile, filename, P1_FILENAME_MAX);
00212 was_c_token = 0;
00213 break;
00214 case P1_NAME_POINTER:
00215 retval = do_p1_name_pointer (infile);
00216 break;
00217 case P1_CONST:
00218 retval = do_p1_const (infile);
00219 break;
00220 case P1_EXPR:
00221 retval = do_p1_expr (infile, outfile);
00222 break;
00223 case P1_IDENT:
00224 retval = do_p1_ident(infile);
00225 break;
00226 case P1_CHARP:
00227 retval = do_p1_charp(infile);
00228 break;
00229 case P1_EXTERN:
00230 retval = do_p1_extern (infile);
00231 break;
00232 case P1_HEAD:
00233 gflag1 = sharp_line = 0;
00234 retval = do_p1_head (infile, outfile);
00235 gflag1 = sharp_line = gflag;
00236 break;
00237 case P1_LIST:
00238 retval = do_p1_list (infile, outfile);
00239 break;
00240 case P1_LITERAL:
00241 retval = do_p1_literal (infile);
00242 break;
00243 case P1_LABEL:
00244 do_p1_label (infile, outfile);
00245
00246 was_c_token = 0;
00247 break;
00248 case P1_ASGOTO:
00249 do_p1_asgoto (infile, outfile);
00250 break;
00251 case P1_GOTO:
00252 do_p1_goto (infile, outfile);
00253 break;
00254 case P1_IF:
00255 do_p1_if (infile, outfile);
00256 break;
00257 case P1_ELSE:
00258 SEM_CHECK(outfile);
00259 do_p1_else (outfile);
00260 break;
00261 case P1_ELIF:
00262 SEM_CHECK(outfile);
00263 do_p1_elif (infile, outfile);
00264 break;
00265 case P1_ENDIF:
00266 SEM_CHECK(outfile);
00267 do_p1_endif (outfile);
00268 break;
00269 case P1_ENDELSE:
00270 SEM_CHECK(outfile);
00271 do_p1_endelse (outfile);
00272 break;
00273 case P1_ADDR:
00274 retval = do_p1_addr (infile, outfile);
00275 break;
00276 case P1_SUBR_RET:
00277 do_p1_subr_ret (infile, outfile);
00278 break;
00279 case P1_COMP_GOTO:
00280 do_p1_comp_goto (infile, outfile);
00281 break;
00282 case P1_FOR:
00283 do_p1_for (infile, outfile);
00284 break;
00285 case P1_ENDFOR:
00286 SEM_CHECK(outfile);
00287 do_p1_end_for (outfile);
00288 break;
00289 case P1_WHILE1START:
00290 do_p1_1while(outfile);
00291 break;
00292 case P1_WHILE2START:
00293 do_p1_2while(infile, outfile);
00294 break;
00295 case P1_PROCODE:
00296 procode(outfile);
00297 break;
00298 case P1_ELSEIFSTART:
00299 SEM_CHECK(outfile);
00300 do_p1_elseifstart(outfile);
00301 break;
00302 case P1_FORTRAN:
00303 do_p1_fortran(infile, outfile);
00304
00305 case P1_EOF:
00306 was_c_token = 0;
00307 break;
00308 case P1_UNKNOWN:
00309 Fatal("do_format: Unknown token type in intermediate file");
00310 break;
00311 default:
00312 Fatal("do_format: Bad token type in intermediate file");
00313 break;
00314 }
00315
00316 if (was_c_token)
00317 last_was_label = 0;
00318 return retval;
00319 }
00320
00321
00322 static void
00323 #ifdef KR_headers
00324 do_p1_comment(infile, outfile)
00325 FILE *infile;
00326 FILE *outfile;
00327 #else
00328 do_p1_comment(FILE *infile, FILE *outfile)
00329 #endif
00330 {
00331 extern int c_output_line_length, in_comment;
00332
00333 char storage[COMMENT_BUFFER_SIZE + 1];
00334 int length;
00335
00336 if (!p1gets(infile, storage, COMMENT_BUFFER_SIZE + 1))
00337 return;
00338
00339 length = strlen (storage);
00340
00341 gflag1 = sharp_line = 0;
00342 in_comment = 1;
00343 if (length > c_output_line_length - 6)
00344 margin_printf(outfile, "/*%s*/\n", storage);
00345 else
00346 margin_printf(outfile, length ? "/* %s */\n" : "\n", storage);
00347 in_comment = 0;
00348 gflag1 = sharp_line = gflag;
00349 }
00350
00351 static void
00352 #ifdef KR_headers
00353 do_p1_set_line(infile)
00354 FILE *infile;
00355 #else
00356 do_p1_set_line(FILE *infile)
00357 #endif
00358 {
00359 int status;
00360 long new_line_number = -1;
00361
00362 status = p1getd (infile, &new_line_number);
00363
00364 if (status == EOF)
00365 err ("do_p1_set_line: Missing line number at end of file\n");
00366 else if (status == 0 || new_line_number == -1)
00367 errl("do_p1_set_line: Illegal line number in intermediate file: %ld\n",
00368 new_line_number);
00369 else {
00370 lineno = new_line_number;
00371 }
00372 }
00373
00374
00375 static expptr
00376 #ifdef KR_headers
00377 do_p1_name_pointer(infile)
00378 FILE *infile;
00379 #else
00380 do_p1_name_pointer(FILE *infile)
00381 #endif
00382 {
00383 Namep namep = (Namep) NULL;
00384 int status;
00385
00386 status = p1getd (infile, (long *) &namep);
00387
00388 if (status == EOF)
00389 err ("do_p1_name_pointer: Missing pointer at end of file\n");
00390 else if (status == 0 || namep == (Namep) NULL)
00391 erri ("do_p1_name_pointer: Illegal name pointer in p1 file: '%x'\n",
00392 (int) namep);
00393
00394 return (expptr) namep;
00395 }
00396
00397
00398
00399 static expptr
00400 #ifdef KR_headers
00401 do_p1_const(infile)
00402 FILE *infile;
00403 #else
00404 do_p1_const(FILE *infile)
00405 #endif
00406 {
00407 struct Constblock *c = (struct Constblock *) NULL;
00408 long type = -1;
00409 int status;
00410
00411 status = p1getd (infile, &type);
00412
00413 if (status == EOF)
00414 err ("do_p1_const: Missing constant type at end of file\n");
00415 else if (status == 0)
00416 errl("do_p1_const: Illegal constant type in p1 file: %ld\n", type);
00417 else {
00418 status = p1get_const (infile, (int)type, &c);
00419
00420 if (status == EOF) {
00421 err ("do_p1_const: Missing constant value at end of file\n");
00422 c = (struct Constblock *) NULL;
00423 } else if (status == 0) {
00424 err ("do_p1_const: Illegal constant value in p1 file\n");
00425 c = (struct Constblock *) NULL;
00426 }
00427 }
00428 return (expptr) c;
00429 }
00430
00431 void
00432 #ifdef KR_headers
00433 addrlit(addrp)
00434 Addrp addrp;
00435 #else
00436 addrlit(Addrp addrp)
00437 #endif
00438 {
00439 long memno = addrp->memno;
00440 struct Literal *litp, *lastlit;
00441
00442 lastlit = litpool + nliterals;
00443 for (litp = litpool; litp < lastlit; litp++)
00444 if (litp->litnum == memno) {
00445 addrp->vtype = litp->littype;
00446 *((union Constant *) &(addrp->user)) =
00447 *((union Constant *) &(litp->litval));
00448 addrp->vstg = STGMEMNO;
00449 return;
00450 }
00451 err("addrlit failure!");
00452 }
00453
00454 static expptr
00455 #ifdef KR_headers
00456 do_p1_literal(infile)
00457 FILE *infile;
00458 #else
00459 do_p1_literal(FILE *infile)
00460 #endif
00461 {
00462 int status;
00463 long memno;
00464 Addrp addrp;
00465
00466 status = p1getd (infile, &memno);
00467
00468 if (status == EOF)
00469 err ("do_p1_literal: Missing memno at end of file");
00470 else if (status == 0)
00471 err ("do_p1_literal: Missing memno in p1 file");
00472 else {
00473 addrp = ALLOC (Addrblock);
00474 addrp -> tag = TADDR;
00475 addrp -> vtype = TYUNKNOWN;
00476 addrp -> Field = NULL;
00477 addrp -> memno = memno;
00478 addrlit(addrp);
00479 addrp -> uname_tag = UNAM_CONST;
00480 }
00481
00482 return (expptr) addrp;
00483 }
00484
00485
00486 static void
00487 #ifdef KR_headers
00488 do_p1_label(infile, outfile)
00489 FILE *infile;
00490 FILE *outfile;
00491 #else
00492 do_p1_label(FILE *infile, FILE *outfile)
00493 #endif
00494 {
00495 int status;
00496 ftnint stateno;
00497 struct Labelblock *L;
00498 char *fmt;
00499
00500 status = p1getd (infile, &stateno);
00501
00502 if (status == EOF)
00503 err ("do_p1_label: Missing label at end of file");
00504 else if (status == 0)
00505 err ("do_p1_label: Missing label in p1 file ");
00506 else if (stateno < 0) {
00507 margin_printf(outfile, "\n%s:\n", user_label(stateno));
00508 last_was_label = 1;
00509 }
00510 else {
00511 L = labeltab + stateno;
00512 if (L->labused) {
00513 fmt = "%s:\n";
00514 last_was_label = 1;
00515 }
00516 else
00517 fmt = "/* %s: */\n";
00518 margin_printf(outfile, fmt, user_label(L->stateno));
00519 }
00520 }
00521
00522
00523
00524 static void
00525 #ifdef KR_headers
00526 do_p1_asgoto(infile, outfile)
00527 FILE *infile;
00528 FILE *outfile;
00529 #else
00530 do_p1_asgoto(FILE *infile, FILE *outfile)
00531 #endif
00532 {
00533 expptr expr;
00534
00535 expr = do_format (infile, outfile);
00536 out_asgoto (outfile, expr);
00537
00538 }
00539
00540
00541 static void
00542 #ifdef KR_headers
00543 do_p1_goto(infile, outfile)
00544 FILE *infile;
00545 FILE *outfile;
00546 #else
00547 do_p1_goto(FILE *infile, FILE *outfile)
00548 #endif
00549 {
00550 int status;
00551 long stateno;
00552
00553 status = p1getd (infile, &stateno);
00554
00555 if (status == EOF)
00556 err ("do_p1_goto: Missing goto label at end of file");
00557 else if (status == 0)
00558 err ("do_p1_goto: Missing goto label in p1 file");
00559 else {
00560 nice_printf (outfile, "goto %s;\n", user_label (stateno));
00561 }
00562 }
00563
00564
00565 static void
00566 #ifdef KR_headers
00567 do_p1_if(infile, outfile)
00568 FILE *infile;
00569 FILE *outfile;
00570 #else
00571 do_p1_if(FILE *infile, FILE *outfile)
00572 #endif
00573 {
00574 expptr cond;
00575
00576 do {
00577 cond = do_format (infile, outfile);
00578 } while (cond == ENULL);
00579
00580 out_if (outfile, cond);
00581 }
00582
00583
00584 static void
00585 #ifdef KR_headers
00586 do_p1_else(outfile)
00587 FILE *outfile;
00588 #else
00589 do_p1_else(FILE *outfile)
00590 #endif
00591 {
00592 out_else (outfile);
00593 }
00594
00595
00596 static void
00597 #ifdef KR_headers
00598 do_p1_elif(infile, outfile)
00599 FILE *infile;
00600 FILE *outfile;
00601 #else
00602 do_p1_elif(FILE *infile, FILE *outfile)
00603 #endif
00604 {
00605 expptr cond;
00606
00607 do {
00608 cond = do_format (infile, outfile);
00609 } while (cond == ENULL);
00610
00611 elif_out (outfile, cond);
00612 }
00613
00614 static void
00615 #ifdef KR_headers
00616 do_p1_endif(outfile)
00617 FILE *outfile;
00618 #else
00619 do_p1_endif(FILE *outfile)
00620 #endif
00621 {
00622 endif_out (outfile);
00623 }
00624
00625
00626 static void
00627 #ifdef KR_headers
00628 do_p1_endelse(outfile)
00629 FILE *outfile;
00630 #else
00631 do_p1_endelse(FILE *outfile)
00632 #endif
00633 {
00634 end_else_out (outfile);
00635 }
00636
00637
00638 static expptr
00639 #ifdef KR_headers
00640 do_p1_addr(infile, outfile)
00641 FILE *infile;
00642 FILE *outfile;
00643 #else
00644 do_p1_addr(FILE *infile, FILE *outfile)
00645 #endif
00646 {
00647 Addrp addrp = (Addrp) NULL;
00648 int status;
00649
00650 status = p1getn (infile, (int)sizeof(struct Addrblock), (char **) &addrp);
00651
00652 if (status == EOF)
00653 err ("do_p1_addr: Missing Addrp at end of file");
00654 else if (status == 0)
00655 err ("do_p1_addr: Missing Addrp in p1 file");
00656 else if (addrp == (Addrp) NULL)
00657 err ("do_p1_addr: Null addrp in p1 file");
00658 else if (addrp -> tag != TADDR)
00659 erri ("do_p1_addr: bad tag in p1 file '%d'", addrp -> tag);
00660 else {
00661 addrp -> vleng = do_format (infile, outfile);
00662 addrp -> memoffset = do_format (infile, outfile);
00663 }
00664
00665 return (expptr) addrp;
00666 }
00667
00668
00669
00670 static void
00671 #ifdef KR_headers
00672 do_p1_subr_ret(infile, outfile)
00673 FILE *infile;
00674 FILE *outfile;
00675 #else
00676 do_p1_subr_ret(FILE *infile, FILE *outfile)
00677 #endif
00678 {
00679 expptr retval;
00680
00681 nice_printf (outfile, "return ");
00682 retval = do_format (infile, outfile);
00683 if (!multitype)
00684 if (retval)
00685 expr_out (outfile, retval);
00686
00687 nice_printf (outfile, ";\n");
00688 }
00689
00690
00691
00692 static void
00693 #ifdef KR_headers
00694 do_p1_comp_goto(infile, outfile)
00695 FILE *infile;
00696 FILE *outfile;
00697 #else
00698 do_p1_comp_goto(FILE *infile, FILE *outfile)
00699 #endif
00700 {
00701 expptr index;
00702 expptr labels;
00703
00704 index = do_format (infile, outfile);
00705
00706 if (index == ENULL) {
00707 err ("do_p1_comp_goto: no expression for computed goto");
00708 return;
00709 }
00710
00711 labels = do_format (infile, outfile);
00712
00713 if (labels && labels -> tag != TLIST)
00714 erri ("do_p1_comp_goto: expected list, got tag '%d'", labels -> tag);
00715 else
00716 compgoto_out (outfile, index, labels);
00717 }
00718
00719
00720 static void
00721 #ifdef KR_headers
00722 do_p1_for(infile, outfile)
00723 FILE *infile;
00724 FILE *outfile;
00725 #else
00726 do_p1_for(FILE *infile, FILE *outfile)
00727 #endif
00728 {
00729 expptr init, test, inc;
00730
00731 init = do_format (infile, outfile);
00732 test = do_format (infile, outfile);
00733 inc = do_format (infile, outfile);
00734
00735 out_for (outfile, init, test, inc);
00736 }
00737
00738 static void
00739 #ifdef KR_headers
00740 do_p1_end_for(outfile)
00741 FILE *outfile;
00742 #else
00743 do_p1_end_for(FILE *outfile)
00744 #endif
00745 {
00746 out_end_for (outfile);
00747 }
00748
00749
00750 static void
00751 #ifdef KR_headers
00752 do_p1_fortran(infile, outfile)
00753 FILE *infile;
00754 FILE *outfile;
00755 #else
00756 do_p1_fortran(FILE *infile, FILE *outfile)
00757 #endif
00758 {
00759 char buf[P1_STMTBUFSIZE];
00760 if (!p1gets(infile, buf, P1_STMTBUFSIZE))
00761 return;
00762
00763 fprintf(outfile, "/*< %s >*/\n", buf+1);
00764 }
00765
00766
00767 static expptr
00768 #ifdef KR_headers
00769 do_p1_expr(infile, outfile)
00770 FILE *infile;
00771 FILE *outfile;
00772 #else
00773 do_p1_expr(FILE *infile, FILE *outfile)
00774 #endif
00775 {
00776 int status;
00777 long opcode, type;
00778 struct Exprblock *result = (struct Exprblock *) NULL;
00779
00780 status = p1getd (infile, &opcode);
00781
00782 if (status == EOF)
00783 err ("do_p1_expr: Missing expr opcode at end of file");
00784 else if (status == 0)
00785 err ("do_p1_expr: Missing expr opcode in p1 file");
00786 else {
00787
00788 status = p1getd (infile, &type);
00789
00790 if (status == EOF)
00791 err ("do_p1_expr: Missing expr type at end of file");
00792 else if (status == 0)
00793 err ("do_p1_expr: Missing expr type in p1 file");
00794 else if (opcode == 0)
00795 return ENULL;
00796 else {
00797 result = ALLOC (Exprblock);
00798
00799 result -> tag = TEXPR;
00800 result -> vtype = type;
00801 result -> opcode = opcode;
00802 result -> vleng = do_format (infile, outfile);
00803
00804 if (is_unary_op (opcode))
00805 result -> leftp = do_format (infile, outfile);
00806 else if (is_binary_op (opcode)) {
00807 result -> leftp = do_format (infile, outfile);
00808 result -> rightp = do_format (infile, outfile);
00809 } else
00810 errl("do_p1_expr: Illegal opcode %ld", opcode);
00811 }
00812 }
00813
00814 return (expptr) result;
00815 }
00816
00817
00818 static expptr
00819 #ifdef KR_headers
00820 do_p1_ident(infile)
00821 FILE *infile;
00822 #else
00823 do_p1_ident(FILE *infile)
00824 #endif
00825 {
00826 Addrp addrp;
00827 int status;
00828 long vtype, vstg;
00829
00830 addrp = ALLOC (Addrblock);
00831 addrp -> tag = TADDR;
00832
00833 status = p1getd (infile, &vtype);
00834 if (status == EOF)
00835 err ("do_p1_ident: Missing identifier type at end of file\n");
00836 else if (status == 0 || vtype < 0 || vtype >= NTYPES)
00837 errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype);
00838 else
00839 addrp -> vtype = vtype;
00840
00841 status = p1getd (infile, &vstg);
00842 if (status == EOF)
00843 err ("do_p1_ident: Missing identifier storage at end of file\n");
00844 else if (status == 0 || vstg < 0 || vstg > STGNULL)
00845 errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype);
00846 else
00847 addrp -> vstg = vstg;
00848
00849 status = p1gets(infile, addrp->user.ident, IDENT_LEN);
00850
00851 if (status == EOF)
00852 err ("do_p1_ident: Missing ident string at end of file");
00853 else if (status == 0)
00854 err ("do_p1_ident: Missing ident string in intermediate file");
00855 addrp->uname_tag = UNAM_IDENT;
00856 return (expptr) addrp;
00857 }
00858
00859 static expptr
00860 #ifdef KR_headers
00861 do_p1_charp(infile)
00862 FILE *infile;
00863 #else
00864 do_p1_charp(FILE *infile)
00865 #endif
00866 {
00867 Addrp addrp;
00868 int status;
00869 long vtype, vstg;
00870 char buf[64];
00871
00872 addrp = ALLOC (Addrblock);
00873 addrp -> tag = TADDR;
00874
00875 status = p1getd (infile, &vtype);
00876 if (status == EOF)
00877 err ("do_p1_ident: Missing identifier type at end of file\n");
00878 else if (status == 0 || vtype < 0 || vtype >= NTYPES)
00879 errl("do_p1_ident: Bad type in intermediate file: %ld\n", vtype);
00880 else
00881 addrp -> vtype = vtype;
00882
00883 status = p1getd (infile, &vstg);
00884 if (status == EOF)
00885 err ("do_p1_ident: Missing identifier storage at end of file\n");
00886 else if (status == 0 || vstg < 0 || vstg > STGNULL)
00887 errl("do_p1_ident: Bad storage in intermediate file: %ld\n", vtype);
00888 else
00889 addrp -> vstg = vstg;
00890
00891 status = p1gets(infile, buf, (int)sizeof(buf));
00892
00893 if (status == EOF)
00894 err ("do_p1_ident: Missing charp ident string at end of file");
00895 else if (status == 0)
00896 err ("do_p1_ident: Missing charp ident string in intermediate file");
00897 addrp->uname_tag = UNAM_CHARP;
00898 addrp->user.Charp = strcpy(mem(strlen(buf)+1,0), buf);
00899 return (expptr) addrp;
00900 }
00901
00902
00903 static expptr
00904 #ifdef KR_headers
00905 do_p1_extern(infile)
00906 FILE *infile;
00907 #else
00908 do_p1_extern(FILE *infile)
00909 #endif
00910 {
00911 Addrp addrp;
00912
00913 addrp = ALLOC (Addrblock);
00914 if (addrp) {
00915 int status;
00916
00917 addrp->tag = TADDR;
00918 addrp->vstg = STGEXT;
00919 addrp->uname_tag = UNAM_EXTERN;
00920 status = p1getd (infile, &(addrp -> memno));
00921 if (status == EOF)
00922 err ("do_p1_extern: Missing memno at end of file");
00923 else if (status == 0)
00924 err ("do_p1_extern: Missing memno in intermediate file");
00925 if (addrp->vtype = extsymtab[addrp->memno].extype)
00926 addrp->vclass = CLPROC;
00927 }
00928
00929 return (expptr) addrp;
00930 }
00931
00932
00933
00934 static expptr
00935 #ifdef KR_headers
00936 do_p1_head(infile, outfile)
00937 FILE *infile;
00938 FILE *outfile;
00939 #else
00940 do_p1_head(FILE *infile, FILE *outfile)
00941 #endif
00942 {
00943 int status;
00944 int add_n_;
00945 long classKRH;
00946 char storage[256];
00947
00948 status = p1getd (infile, &classKRH);
00949 if (status == EOF)
00950 err ("do_p1_head: missing header class at end of file");
00951 else if (status == 0)
00952 err ("do_p1_head: missing header class in p1 file");
00953 else {
00954 status = p1gets (infile, storage, (int)sizeof(storage));
00955 if (status == EOF || status == 0)
00956 storage[0] = '\0';
00957 }
00958
00959 if (classKRH == CLPROC || classKRH == CLMAIN) {
00960 chainp lengths;
00961
00962 add_n_ = nentry > 1;
00963 lengths = length_comp(entries, add_n_);
00964
00965 if (!add_n_ && protofile && classKRH != CLMAIN)
00966 protowrite(protofile, proctype, storage, entries, lengths);
00967
00968 if (classKRH == CLMAIN)
00969 nice_printf (outfile, "/* Main program */ ");
00970 else
00971 nice_printf(outfile, "%s ", multitype ? "VOID"
00972 : c_type_decl(proctype, 1));
00973
00974 nice_printf(outfile, add_n_ ? "%s0_" : "%s", storage);
00975 if (!Ansi) {
00976 listargs(outfile, entries, add_n_, lengths);
00977 nice_printf (outfile, "\n");
00978 }
00979 list_arg_types (outfile, entries, lengths, add_n_, "\n");
00980 nice_printf (outfile, "{\n");
00981 frchain(&lengths);
00982 next_tab (outfile);
00983 strcpy(this_proc_name, storage);
00984 list_decls (outfile);
00985
00986 } else if (classKRH == CLBLOCK)
00987 next_tab (outfile);
00988 else
00989 errl("do_p1_head: got class %ld", classKRH);
00990
00991 return NULL;
00992 }
00993
00994
00995 static expptr
00996 #ifdef KR_headers
00997 do_p1_list(infile, outfile)
00998 FILE *infile;
00999 FILE *outfile;
01000 #else
01001 do_p1_list(FILE *infile, FILE *outfile)
01002 #endif
01003 {
01004 long tag, type, count;
01005 int status;
01006 expptr result;
01007
01008 status = p1getd (infile, &tag);
01009 if (status == EOF)
01010 err ("do_p1_list: missing list tag at end of file");
01011 else if (status == 0)
01012 err ("do_p1_list: missing list tag in p1 file");
01013 else {
01014 status = p1getd (infile, &type);
01015 if (status == EOF)
01016 err ("do_p1_list: missing list type at end of file");
01017 else if (status == 0)
01018 err ("do_p1_list: missing list type in p1 file");
01019 else {
01020 status = p1getd (infile, &count);
01021 if (status == EOF)
01022 err ("do_p1_list: missing count at end of file");
01023 else if (status == 0)
01024 err ("do_p1_list: missing count in p1 file");
01025 }
01026 }
01027
01028 result = (expptr) ALLOC (Listblock);
01029 if (result) {
01030 chainp pointer;
01031
01032 result -> tag = tag;
01033 result -> listblock.vtype = type;
01034
01035
01036
01037 if (count--) {
01038 pointer = result->listblock.listp =
01039 mkchain((char *)do_format(infile, outfile), CHNULL);
01040 while (count--) {
01041 pointer -> nextp =
01042 mkchain((char *)do_format(infile, outfile), CHNULL);
01043 pointer = pointer -> nextp;
01044 }
01045 }
01046 }
01047
01048 return result;
01049 }
01050
01051
01052 chainp
01053 #ifdef KR_headers
01054 length_comp(e, add_n)
01055 struct Entrypoint *e;
01056 int add_n;
01057 #else
01058 length_comp(struct Entrypoint *e, int add_n)
01059 #endif
01060
01061 {
01062 chainp lengths;
01063 chainp args, args1;
01064 Namep arg, np;
01065 int nchargs;
01066 Argtypes *at;
01067 Atype *a;
01068 extern int init_ac[TYSUBR+1];
01069
01070 if (!e)
01071 return 0;
01072 args = args1 = add_n ? allargs : e->arglist;
01073 nchargs = 0;
01074 for (lengths = NULL; args; args = args -> nextp)
01075 if (arg = (Namep)args->datap) {
01076 if (arg->vclass == CLUNKNOWN)
01077 arg->vclass = CLVAR;
01078 if (arg->vtype == TYCHAR && arg->vclass != CLPROC) {
01079 lengths = mkchain((char *)arg, lengths);
01080 nchargs++;
01081 }
01082 }
01083 if (!add_n && (np = e->enamep)) {
01084
01085
01086
01087 save_argtypes(e->arglist, &e->entryname->arginfo,
01088 &np->arginfo, 0, np->fvarname, STGEXT, nchargs,
01089 np->vtype, 1);
01090 at = e->entryname->arginfo;
01091 a = at->atypes + init_ac[np->vtype];
01092 for(; args1; a++, args1 = args1->nextp) {
01093 frchain(&a->cp);
01094 if (arg = (Namep)args1->datap)
01095 switch(arg->vclass) {
01096 case CLPROC:
01097 if (arg->vimpltype
01098 && a->type >= 300)
01099 a->type = TYUNKNOWN + 200;
01100 break;
01101 case CLUNKNOWN:
01102 a->type %= 100;
01103 }
01104 }
01105 }
01106 return revchain(lengths);
01107 }
01108
01109 void
01110 #ifdef KR_headers
01111 listargs(outfile, entryp, add_n_, lengths)
01112 FILE *outfile;
01113 struct Entrypoint *entryp;
01114 int add_n_;
01115 chainp lengths;
01116 #else
01117 listargs(FILE *outfile, struct Entrypoint *entryp, int add_n_, chainp lengths)
01118 #endif
01119 {
01120 chainp args;
01121 char *s;
01122 Namep arg;
01123 int did_one = 0;
01124
01125 nice_printf (outfile, "(");
01126
01127 if (add_n_) {
01128 nice_printf(outfile, "n__");
01129 did_one = 1;
01130 args = allargs;
01131 }
01132 else {
01133 if (!entryp)
01134 return;
01135 args = entryp->arglist;
01136 }
01137
01138 if (multitype)
01139 {
01140 nice_printf(outfile, ", ret_val");
01141 did_one = 1;
01142 args = allargs;
01143 }
01144 else if (ONEOF(proctype, MSKCOMPLEX|MSKCHAR))
01145 {
01146 s = xretslot[proctype]->user.ident;
01147 nice_printf(outfile, did_one ? ", %s" : "%s",
01148 *s == '(' ? "r_v" : s);
01149 did_one = 1;
01150 if (proctype == TYCHAR)
01151 nice_printf (outfile, ", ret_val_len");
01152 }
01153 for (; args; args = args -> nextp)
01154 if (arg = (Namep)args->datap) {
01155 nice_printf (outfile, "%s", did_one ? ", " : "");
01156 out_name (outfile, arg);
01157 did_one = 1;
01158 }
01159
01160 for (args = lengths; args; args = args -> nextp)
01161 nice_printf(outfile, ", %s",
01162 new_arg_length((Namep)args->datap));
01163 nice_printf (outfile, ")");
01164 }
01165
01166
01167 void
01168 #ifdef KR_headers
01169 list_arg_types(outfile, entryp, lengths, add_n_, finalnl)
01170 FILE *outfile;
01171 struct Entrypoint *entryp;
01172 chainp lengths;
01173 int add_n_;
01174 char *finalnl;
01175 #else
01176 list_arg_types(FILE *outfile, struct Entrypoint *entryp, chainp lengths, int add_n_, char *finalnl)
01177 #endif
01178 {
01179 chainp args;
01180 int last_type = -1, last_class = -1;
01181 int did_one = 0, done_one, is_ext;
01182 char *s, *sep = "", *sep1;
01183
01184 if (outfile == (FILE *) NULL) {
01185 err ("list_arg_types: null output file");
01186 return;
01187 } else if (entryp == (struct Entrypoint *) NULL) {
01188 err ("list_arg_types: null procedure entry pointer");
01189 return;
01190 }
01191
01192 if (Ansi) {
01193 done_one = 0;
01194 sep1 = ", ";
01195 nice_printf(outfile, "(" );
01196 }
01197 else {
01198 done_one = 1;
01199 sep1 = ";\n";
01200 }
01201 args = entryp->arglist;
01202 if (add_n_) {
01203 nice_printf(outfile, "int n__");
01204 did_one = done_one;
01205 sep = sep1;
01206 args = allargs;
01207 }
01208 if (multitype) {
01209 nice_printf(outfile, "%sMultitype *ret_val", sep);
01210 did_one = done_one;
01211 sep = sep1;
01212 }
01213 else if (ONEOF (proctype, MSKCOMPLEX|MSKCHAR)) {
01214 s = xretslot[proctype]->user.ident;
01215 nice_printf(outfile, "%s%s *%s", sep, c_type_decl(proctype, 0),
01216 *s == '(' ? "r_v" : s);
01217 did_one = done_one;
01218 sep = sep1;
01219 if (proctype == TYCHAR)
01220 nice_printf (outfile, "%sftnlen ret_val_len", sep);
01221 }
01222 for (; args; args = args -> nextp) {
01223 Namep arg = (Namep) args->datap;
01224
01225
01226
01227
01228
01229 if (arg) {
01230 int type = arg -> vtype, classKRH = arg -> vclass;
01231
01232 if (classKRH == CLPROC)
01233 if (arg->vimpltype)
01234 type = Castargs ? TYUNKNOWN : TYSUBR;
01235 else if (type == TYREAL && forcedouble && !Castargs)
01236 type = TYDREAL;
01237
01238 if (type == last_type && classKRH == last_class && did_one)
01239 nice_printf (outfile, ", ");
01240 else
01241 if ((is_ext = classKRH == CLPROC) && Castargs)
01242 nice_printf(outfile, "%s%s ", sep,
01243 usedcasts[type] = casttypes[type]);
01244 else
01245 nice_printf(outfile, "%s%s ", sep,
01246 c_type_decl(type, is_ext));
01247 if (classKRH == CLPROC)
01248 if (Castargs)
01249 out_name(outfile, arg);
01250 else {
01251 nice_printf(outfile, "(*");
01252 out_name(outfile, arg);
01253 nice_printf(outfile, ") %s", parens);
01254 }
01255 else {
01256 nice_printf (outfile, "*");
01257 out_name (outfile, arg);
01258 }
01259
01260 last_type = type;
01261 last_class = classKRH;
01262 did_one = done_one;
01263 sep = sep1;
01264 }
01265 }
01266
01267 for (args = lengths; args; args = args -> nextp)
01268 nice_printf(outfile, "%sftnlen %s", sep,
01269 new_arg_length((Namep)args->datap));
01270 if (did_one)
01271 nice_printf (outfile, ";\n");
01272 else if (Ansi)
01273 nice_printf(outfile,
01274 sep != sep1 && Ansi == 1 ? "void)%s" : ")%s",
01275 finalnl);
01276 }
01277
01278 static void
01279 #ifdef KR_headers
01280 write_formats(outfile)
01281 FILE *outfile;
01282 #else
01283 write_formats(FILE *outfile)
01284 #endif
01285 {
01286 register struct Labelblock *lp;
01287 int first = 1;
01288 char *fs;
01289
01290 for(lp = labeltab ; lp < highlabtab ; ++lp)
01291 if (lp->fmtlabused) {
01292 if (first) {
01293 first = 0;
01294 nice_printf(outfile, "/* Format strings */\n");
01295 }
01296 nice_printf(outfile, "static char fmt_%ld[] = \"",
01297 lp->stateno);
01298 if (!(fs = lp->fmtstring))
01299 fs = "";
01300 nice_printf(outfile, "%s\";\n", fs);
01301 }
01302 if (!first)
01303 nice_printf(outfile, "\n");
01304 }
01305
01306 static void
01307 #ifdef KR_headers
01308 write_ioblocks(outfile)
01309 FILE *outfile;
01310 #else
01311 write_ioblocks(FILE *outfile)
01312 #endif
01313 {
01314 register iob_data *L;
01315 register char *f, **s, *sep;
01316
01317 nice_printf(outfile, "/* Fortran I/O blocks */\n");
01318 L = iob_list = (iob_data *)revchain((chainp)iob_list);
01319 do {
01320 nice_printf(outfile, "static %s %s = { ",
01321 L->type, L->name);
01322 sep = 0;
01323 for(s = L->fields; f = *s; s++) {
01324 if (sep)
01325 nice_printf(outfile, sep);
01326 sep = ", ";
01327 if (*f == '"') {
01328 nice_printf(outfile, "\"");
01329 nice_printf(outfile, "%s\"", f+1);
01330 }
01331 else
01332 nice_printf(outfile, "%s", f);
01333 }
01334 nice_printf(outfile, " };\n");
01335 }
01336 while(L = L->next);
01337 nice_printf(outfile, "\n\n");
01338 }
01339
01340 static void
01341 #ifdef KR_headers
01342 write_assigned_fmts(outfile)
01343 FILE *outfile;
01344 #else
01345 write_assigned_fmts(FILE *outfile)
01346 #endif
01347 {
01348 register chainp cp;
01349 Namep np;
01350 char *comma, *type;
01351 int did_one = 0;
01352
01353 cp = assigned_fmts = revchain(assigned_fmts);
01354 nice_printf(outfile, "/* Assigned format variables */\n");
01355 do {
01356 np = (Namep)cp->datap;
01357 if (did_one == np->vstg) {
01358 comma = ", ";
01359 type = "";
01360 }
01361 else {
01362 comma = did_one ? ";\n" : "";
01363 type = np->vstg == STGAUTO ? "char " : "static char ";
01364 did_one = np->vstg;
01365 }
01366 nice_printf(outfile, "%s%s*%s_fmt", comma, type, np->fvarname);
01367 }
01368 while(cp = cp->nextp);
01369 nice_printf(outfile, ";\n\n");
01370 }
01371
01372 static char *
01373 #ifdef KR_headers
01374 to_upper(s)
01375 register char *s;
01376 #else
01377 to_upper(register char *s)
01378 #endif
01379 {
01380 static char buf[64];
01381 register char *t = buf;
01382 register int c;
01383 while(*t++ = (c = *s++) >= 'a' && c <= 'z' ? c + 'A' - 'a' : c);
01384 return buf;
01385 }
01386
01387
01388
01389
01390
01391
01392
01393
01394
01395
01396
01397
01398
01399
01400
01401
01402
01403
01404
01405
01406
01407
01408
01409
01410
01411
01412
01413
01414
01415
01416
01417
01418 static void
01419 #ifdef KR_headers
01420 write_namelists(nmch, outfile)
01421 chainp nmch;
01422 FILE *outfile;
01423 #else
01424 write_namelists(chainp nmch, FILE *outfile)
01425 #endif
01426 {
01427 Namep var;
01428 struct Hashentry *entry;
01429 struct Dimblock *dimp;
01430 int i, nd, type;
01431 char *comma, *name;
01432 register chainp q;
01433 register Namep v;
01434 extern int typeconv[];
01435
01436 nice_printf(outfile, "/* Namelist stuff */\n\n");
01437 for (entry = hashtab; entry < lasthash; ++entry) {
01438 if (!(v = entry->varp) || !v->vnamelist)
01439 continue;
01440 type = v->vtype;
01441 name = v->cvarname;
01442 if (dimp = v->vdim) {
01443 nd = dimp->ndim;
01444 nice_printf(outfile,
01445 "static ftnlen %s_dims[] = { %d, %ld, %ld",
01446 name, nd,
01447 dimp->nelt->constblock.Const.ci,
01448 dimp->baseoffset->constblock.Const.ci);
01449 for(i = 0, --nd; i < nd; i++)
01450 nice_printf(outfile, ", %ld",
01451 dimp->dims[i].dimsize->constblock.Const.ci);
01452 nice_printf(outfile, " };\n");
01453 }
01454 nice_printf(outfile, "static Vardesc %s_dv = { \"%s\", %s",
01455 name, to_upper(v->fvarname),
01456 type == TYCHAR ? ""
01457 : (dimp || oneof_stg(v,v->vstg,
01458 M(STGEQUIV)|M(STGCOMMON)))
01459 ? "(char *)" : "(char *)&");
01460 out_name(outfile, v);
01461 nice_printf(outfile, dimp ? ", %s_dims" : ", (ftnlen *)0", name);
01462 nice_printf(outfile, ", %ld };\n",
01463 type != TYCHAR ? (long)typeconv[type]
01464 : -v->vleng->constblock.Const.ci);
01465 }
01466
01467 do {
01468 var = (Namep)nmch->datap;
01469 name = var->cvarname;
01470 nice_printf(outfile, "\nstatic Vardesc *%s_vl[] = ", name);
01471 comma = "{";
01472 i = 0;
01473 for(q = var->varxptr.namelist ; q ; q = q->nextp) {
01474 v = (Namep)q->datap;
01475 if (!v->vnamelist)
01476 continue;
01477 i++;
01478 nice_printf(outfile, "%s &%s_dv", comma, v->cvarname);
01479 comma = ",";
01480 }
01481 nice_printf(outfile, " };\n");
01482 nice_printf(outfile,
01483 "static Namelist %s = { \"%s\", %s_vl, %d };\n",
01484 name, to_upper(var->fvarname), name, i);
01485 }
01486 while(nmch = nmch->nextp);
01487 nice_printf(outfile, "\n");
01488 }
01489
01490
01491
01492
01493
01494
01495 static int
01496 #ifdef KR_headers
01497 fixexttype(var)
01498 Namep var;
01499 #else
01500 fixexttype(Namep var)
01501 #endif
01502 {
01503 Extsym *e;
01504 int type, type1;
01505
01506 type = var->vtype;
01507 e = &extsymtab[var->vardesc.varno];
01508 if ((type1 = e->extype) && type == TYUNKNOWN)
01509 return var->vtype = type1;
01510 if (var->visused) {
01511 if (e->exused && type != type1)
01512 changedtype(var);
01513 e->exused = 1;
01514 e->extype = type;
01515 }
01516 return type;
01517 }
01518
01519 static void
01520 #ifdef KR_headers
01521 ref_defs(outfile, refdefs)
01522 FILE *outfile;
01523 chainp refdefs;
01524 #else
01525 ref_defs(FILE *outfile, chainp refdefs)
01526 #endif
01527 {
01528 chainp cp;
01529 int eb, i, j, n;
01530 struct Dimblock *dimp;
01531 expptr b, vl;
01532 Namep var;
01533 char *amp, *comma;
01534
01535 margin_printf(outfile, "\n");
01536 for(cp = refdefs = revchain(refdefs); cp; cp = cp->nextp) {
01537 var = (Namep)cp->datap;
01538 cp->datap = 0;
01539 amp = "_subscr";
01540 if (!(eb = var->vsubscrused)) {
01541 var->vrefused = 0;
01542 if (!ISCOMPLEX(var->vtype))
01543 amp = "_ref";
01544 }
01545 def_start(outfile, var->cvarname, amp, CNULL);
01546 dimp = var->vdim;
01547 vl = 0;
01548 comma = "(";
01549 amp = "";
01550 if (var->vtype == TYCHAR) {
01551 amp = "&";
01552 vl = var->vleng;
01553 if (ISCONST(vl) && vl->constblock.Const.ci == 1)
01554 vl = 0;
01555 nice_printf(outfile, "%sa_0", comma);
01556 comma = ",";
01557 }
01558 n = dimp->ndim;
01559 for(i = 1; i <= n; i++, comma = ",")
01560 nice_printf(outfile, "%sa_%d", comma, i);
01561 nice_printf(outfile, ") %s", amp);
01562 if (var->vsubscrused)
01563 var->vsubscrused = 0;
01564 else if (!ISCOMPLEX(var->vtype)) {
01565 out_name(outfile, var);
01566 nice_printf(outfile, "[%s", vl ? "(" : "");
01567 }
01568 for(j = 2; j < n; j++)
01569 nice_printf(outfile, "(");
01570 while(--i > 1) {
01571 nice_printf(outfile, "(a_%d)%s*", i, i == n ? "" : ")");
01572 expr_out(outfile, cpexpr(dimp->dims[i-2].dimsize));
01573 nice_printf(outfile, " + ");
01574 }
01575 nice_printf(outfile, "a_1");
01576 if (var->vtype == TYCHAR) {
01577 if (vl) {
01578 nice_printf(outfile, ")*");
01579 expr_out(outfile, cpexpr(vl));
01580 }
01581 nice_printf(outfile, " + a_0");
01582 }
01583 if ((var->vstg != STGARG )
01584 && (b = dimp->baseoffset)) {
01585 b = cpexpr(b);
01586 if (var->vtype == TYCHAR)
01587 b = mkexpr(OPSTAR, cpexpr(var->vleng), b);
01588 nice_printf(outfile, " - ");
01589 expr_out(outfile, b);
01590 }
01591 if (ISCOMPLEX(var->vtype)) {
01592 margin_printf(outfile, "\n");
01593 def_start(outfile, var->cvarname, "_ref", CNULL);
01594 comma = "(";
01595 for(i = 1; i <= n; i++, comma = ",")
01596 nice_printf(outfile, "%sa_%d", comma, i);
01597 nice_printf(outfile, ") %s[%s_subscr",
01598 var->cvarname, var->cvarname);
01599 comma = "(";
01600 for(i = 1; i <= n; i++, comma = ",")
01601 nice_printf(outfile, "%sa_%d", comma, i);
01602 nice_printf(outfile, ")");
01603 }
01604 margin_printf(outfile, "]\n" + eb);
01605 }
01606 nice_printf(outfile, "\n");
01607 frchain(&refdefs);
01608 }
01609
01610 void
01611 #ifdef KR_headers
01612 list_decls(outfile)
01613 FILE *outfile;
01614 #else
01615 list_decls(FILE *outfile)
01616 #endif
01617 {
01618 extern chainp used_builtins;
01619 extern struct Hashentry *hashtab;
01620 struct Hashentry *entry;
01621 int write_header = 1;
01622 int last_class = -1, last_stg = -1;
01623 Namep var;
01624 int Alias, Define, did_one, last_type, type;
01625 extern int def_equivs, useauto;
01626 extern chainp new_vars;
01627 chainp namelists = 0, refdefs = 0;
01628 char *ctype;
01629 int useauto1 = useauto && !saveall;
01630 long x;
01631 extern int hsize;
01632
01633
01634
01635 if (initfile)
01636 list_init_data(&initfile, initfname, outfile);
01637
01638
01639 write_formats(outfile);
01640
01641
01642
01643 if (new_vars || nequiv) {
01644 chainp args, next_var, this_var;
01645 chainp nv[TYVOID], nv1[TYVOID];
01646 int i, j;
01647 Addrp Var;
01648 Namep arg;
01649
01650
01651
01652 for(args = allargs; args; args = args->nextp) {
01653 arg = (Namep)args->datap;
01654 if (this_var = arg->vlastdim) {
01655 frexpr((tagptr)this_var->datap);
01656 this_var->datap = 0;
01657 }
01658 }
01659
01660
01661
01662 for(i = TYADDR; i < TYVOID; i++)
01663 nv[i] = 0;
01664 for(this_var = new_vars; this_var; this_var = next_var) {
01665 next_var = this_var->nextp;
01666 if (Var = (Addrp)this_var->datap) {
01667 if (!(this_var->nextp = nv[j = Var->vtype]))
01668 nv1[j] = this_var;
01669 nv[j] = this_var;
01670 }
01671 else {
01672 this_var->nextp = 0;
01673 frchain(&this_var);
01674 }
01675 }
01676 new_vars = 0;
01677 for(i = TYVOID; --i >= TYADDR;)
01678 if (this_var = nv[i]) {
01679 nv1[i]->nextp = new_vars;
01680 new_vars = this_var;
01681 }
01682
01683
01684
01685 did_one = 0;
01686 last_type = -1;
01687
01688 for (this_var = new_vars; this_var; this_var = this_var -> nextp) {
01689 Var = (Addrp) this_var->datap;
01690
01691 if (Var == (Addrp) NULL)
01692 err ("list_decls: null variable");
01693 else if (Var -> tag != TADDR)
01694 erri ("list_decls: bad tag on new variable '%d'",
01695 Var -> tag);
01696
01697 type = nv_type (Var);
01698 if (Var->vstg == STGINIT
01699 || Var->uname_tag == UNAM_IDENT
01700 && *Var->user.ident == ' '
01701 && multitype)
01702 continue;
01703 if (!did_one)
01704 nice_printf (outfile, "/* System generated locals */\n");
01705
01706 if (last_type == type && did_one)
01707 nice_printf (outfile, ", ");
01708 else {
01709 if (did_one)
01710 nice_printf (outfile, ";\n");
01711 nice_printf (outfile, "%s ",
01712 c_type_decl (type, Var -> vclass == CLPROC));
01713 }
01714
01715
01716
01717
01718 if (Var -> vtype == TYCHAR && (!ISICON ((Var -> vleng))
01719 || Var -> vclass == CLPROC))
01720 nice_printf (outfile, "*");
01721
01722 write_nv_ident(outfile, (Addrp)this_var->datap);
01723 if (Var -> vtype == TYCHAR && Var->vclass != CLPROC &&
01724 ISICON((Var -> vleng))
01725 && (i = Var->vleng->constblock.Const.ci) > 0)
01726 nice_printf (outfile, "[%d]", i);
01727
01728 did_one = 1;
01729 last_type = nv_type (Var);
01730 }
01731
01732
01733
01734 do_uninit_equivs (outfile, &did_one);
01735
01736 if (did_one)
01737 nice_printf (outfile, ";\n\n");
01738 }
01739
01740
01741
01742 if (used_builtins) {
01743 chainp cp;
01744 Extsym *es;
01745
01746 last_type = -1;
01747 did_one = 0;
01748
01749 nice_printf (outfile, "/* Builtin functions */");
01750
01751 for (cp = used_builtins; cp; cp = cp -> nextp) {
01752 Addrp e = (Addrp)cp->datap;
01753
01754 switch(type = e->vtype) {
01755 case TYDREAL:
01756 case TYREAL:
01757
01758
01759 type = TYDREAL;
01760 ctype = "double";
01761 break;
01762 case TYCOMPLEX:
01763 case TYDCOMPLEX:
01764 type = TYVOID;
01765
01766 default:
01767 ctype = c_type_decl(type, 0);
01768 }
01769
01770 if (did_one && last_type == type)
01771 nice_printf(outfile, ", ");
01772 else
01773 nice_printf(outfile, "%s\n%s ", did_one ? ";" : "", ctype);
01774
01775 extern_out(outfile, es = &extsymtab[e -> memno]);
01776 proto(outfile, es->arginfo, es->fextname);
01777 last_type = type;
01778 did_one = 1;
01779 }
01780
01781 nice_printf (outfile, ";\n\n");
01782 }
01783
01784 last_type = -1;
01785 for (entry = hashtab; entry < lasthash; ++entry) {
01786 var = entry -> varp;
01787
01788 if (var) {
01789 int procclass = var -> vprocclass;
01790 char *comment = NULL;
01791 int stg = var -> vstg;
01792 int classKRH = var -> vclass;
01793 type = var -> vtype;
01794
01795 if (var->vrefused)
01796 refdefs = mkchain((char *)var, refdefs);
01797 if (var->vsubscrused)
01798 if (ISCOMPLEX(var->vtype))
01799 var->vsubscrused = 0;
01800 else
01801 refdefs = mkchain((char *)var, refdefs);
01802 if (ONEOF(stg, M(STGARG)|M(STGLENG)|M(STGINIT)))
01803 continue;
01804
01805 if (useauto1 && stg == STGBSS && !var->vsave)
01806 stg = STGAUTO;
01807
01808 switch (classKRH) {
01809 case CLVAR:
01810 break;
01811 case CLPROC:
01812 switch(procclass) {
01813 case PTHISPROC:
01814 extsymtab[var->vardesc.varno].extype = type;
01815 continue;
01816 case PSTFUNCT:
01817 case PINTRINSIC:
01818 continue;
01819 case PUNKNOWN:
01820 err ("list_decls: unknown procedure class");
01821 continue;
01822 case PEXTERNAL:
01823 if (stg == STGUNKNOWN) {
01824 warn1(
01825 "%.64s declared EXTERNAL but never used.",
01826 var->fvarname);
01827
01828
01829
01830 continue;
01831 }
01832 else
01833 type = fixexttype(var);
01834 }
01835 break;
01836 case CLUNKNOWN:
01837
01838 continue;
01839 case CLPARAM:
01840 continue;
01841 case CLNAMELIST:
01842 if (var->visused)
01843 namelists = mkchain((char *)var, namelists);
01844 continue;
01845 default:
01846 erri("list_decls: can't handle class '%d' yet",
01847 classKRH);
01848 Fatal(var->fvarname);
01849 continue;
01850 }
01851
01852
01853 if (stg == STGCOMMON && !var->vcommequiv)
01854 continue;
01855
01856
01857
01858
01859 if (write_header == 1 && (new_vars || nequiv || used_builtins)
01860 && oneof_stg ( var, stg,
01861 M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
01862 nice_printf (outfile, "/* Local variables */\n");
01863 write_header = 2;
01864 }
01865
01866
01867 Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
01868 if (Define = (Alias && def_equivs)) {
01869 if (!write_header)
01870 nice_printf(outfile, ";\n");
01871 def_start(outfile, var->cvarname, CNULL, "(");
01872 goto Alias1;
01873 }
01874 else if (type == last_type && classKRH == last_class &&
01875 stg == last_stg && !write_header)
01876 nice_printf (outfile, ", ");
01877 else {
01878 if (!write_header && ONEOF(stg, M(STGBSS)|
01879 M(STGEXT)|M(STGAUTO)|M(STGEQUIV)|M(STGCOMMON)))
01880 nice_printf (outfile, ";\n");
01881
01882 switch (stg) {
01883 case STGARG:
01884 case STGLENG:
01885
01886
01887 continue;
01888 case STGBSS:
01889 case STGEQUIV:
01890 case STGCOMMON:
01891 nice_printf (outfile, "static ");
01892 break;
01893 case STGEXT:
01894 nice_printf (outfile, "extern ");
01895 break;
01896 case STGAUTO:
01897 break;
01898 case STGINIT:
01899 case STGUNKNOWN:
01900
01901
01902
01903 continue;
01904 default:
01905 erri("list_decls: can't handle storage class %d",
01906 stg);
01907 continue;
01908 }
01909
01910 if (type == TYCHAR && halign && classKRH != CLPROC
01911 && ISICON(var->vleng)) {
01912 nice_printf(outfile, "struct { %s fill; char val",
01913 halign);
01914 x = wr_char_len(outfile, var->vdim,
01915 var->vleng->constblock.Const.ci, 1);
01916 if (x %= hsize)
01917 nice_printf(outfile, "; char fill2[%ld]",
01918 hsize - x);
01919 nice_printf(outfile, "; } %s_st;\n", var->cvarname);
01920 def_start(outfile, var->cvarname, CNULL, var->cvarname);
01921 margin_printf(outfile, "_st.val\n");
01922 last_type = -1;
01923 write_header = 2;
01924 continue;
01925 }
01926 nice_printf(outfile, "%s ",
01927 c_type_decl(type, classKRH == CLPROC));
01928 }
01929
01930
01931
01932
01933 if (type == TYCHAR && classKRH != CLPROC
01934 && (!var->vleng || !ISICON (var -> vleng))
01935 || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
01936 nice_printf (outfile, "*%s", var->cvarname);
01937 else {
01938 nice_printf (outfile, "%s", var->cvarname);
01939 if (classKRH == CLPROC) {
01940 Argtypes *at;
01941 if (!(at = var->arginfo)
01942 && var->vprocclass == PEXTERNAL)
01943 at = extsymtab[var->vardesc.varno].arginfo;
01944 proto(outfile, at, var->fvarname);
01945 }
01946 else if (type == TYCHAR && ISICON ((var -> vleng)))
01947 wr_char_len(outfile, var->vdim,
01948 (int)var->vleng->constblock.Const.ci, 0);
01949 else if (var -> vdim &&
01950 !oneof_stg (var, stg, M(STGEQUIV)|M(STGCOMMON)))
01951 comment = wr_ardecls(outfile, var->vdim, 1L);
01952 }
01953
01954 if (comment)
01955 nice_printf (outfile, "%s", comment);
01956 Alias1:
01957 if (Alias) {
01958 char *amp, *lp, *name, *rp;
01959 ftnint voff = var -> voffset;
01960 int et0, expr_type, k;
01961 Extsym *E;
01962 struct Equivblock *eb;
01963 char buf[16];
01964
01965
01966
01967
01968 if (stg == STGEQUIV) {
01969 name = equiv_name(k = var->vardesc.varno, CNULL);
01970 eb = eqvclass + k;
01971 if (eb->eqvinit) {
01972 amp = "&";
01973 et0 = TYERROR;
01974 }
01975 else {
01976 amp = "";
01977 et0 = eb->eqvtype;
01978 }
01979 expr_type = et0;
01980 }
01981 else {
01982 E = &extsymtab[var->vardesc.varno];
01983 sprintf(name = buf, "%s%d", E->cextname, E->curno);
01984 expr_type = type;
01985 et0 = -1;
01986 amp = "&";
01987 }
01988
01989 if (!Define)
01990 nice_printf (outfile, " = ");
01991 if (voff) {
01992 k = typesize[type];
01993 switch((int)(voff % k)) {
01994 case 0:
01995 voff /= k;
01996 expr_type = type;
01997 break;
01998 case SZSHORT:
01999 case SZSHORT+SZLONG:
02000 expr_type = TYSHORT;
02001 voff /= SZSHORT;
02002 break;
02003 case SZLONG:
02004 expr_type = TYLONG;
02005 voff /= SZLONG;
02006 break;
02007 default:
02008 expr_type = TYCHAR;
02009 }
02010 }
02011
02012 if (expr_type == type) {
02013 lp = rp = "";
02014 if (et0 == -1 && !voff)
02015 goto cast;
02016 }
02017 else {
02018 lp = "(";
02019 rp = ")";
02020 cast:
02021 nice_printf(outfile, "(%s *)", c_type_decl(type, 0));
02022 }
02023
02024
02025
02026 if (voff) {
02027 if (expr_type == et0)
02028 nice_printf (outfile, "%s%s + %ld%s",
02029 lp, name, voff, rp);
02030 else
02031 nice_printf(outfile, "%s(%s *)%s%s + %ld%s", lp,
02032 c_type_decl (expr_type, 0), amp,
02033 name, voff, rp);
02034 } else
02035 nice_printf(outfile, "%s%s", amp, name);
02036
02037 last_type = last_class = last_stg = -1;
02038 write_header = 0;
02039 if (Define) {
02040 margin_printf(outfile, ")\n");
02041 write_header = 2;
02042 }
02043 continue;
02044 }
02045 write_header = 0;
02046 last_type = type;
02047 last_class = classKRH;
02048 last_stg = stg;
02049 }
02050 }
02051
02052 if (!write_header)
02053 nice_printf (outfile, ";\n\n");
02054 else if (write_header == 2)
02055 nice_printf(outfile, "\n");
02056
02057
02058
02059 if (namelists) {
02060 write_namelists(namelists = revchain(namelists), outfile);
02061 frchain(&namelists);
02062 }
02063
02064
02065 if (iob_list)
02066 write_ioblocks(outfile);
02067 if (assigned_fmts)
02068 write_assigned_fmts(outfile);
02069
02070 if (refdefs)
02071 ref_defs(outfile, refdefs);
02072
02073 }
02074
02075 void
02076 #ifdef KR_headers
02077 do_uninit_equivs(outfile, did_one)
02078 FILE *outfile;
02079 int *did_one;
02080 #else
02081 do_uninit_equivs(FILE *outfile, int *did_one)
02082 #endif
02083 {
02084 extern int nequiv;
02085 struct Equivblock *eqv, *lasteqv = eqvclass + nequiv;
02086 int k, last_type = -1, t;
02087
02088 for (eqv = eqvclass; eqv < lasteqv; eqv++)
02089 if (!eqv -> eqvinit && eqv -> eqvtop != eqv -> eqvbottom) {
02090 if (!*did_one)
02091 nice_printf (outfile, "/* System generated locals */\n");
02092 t = eqv->eqvtype;
02093 if (last_type == t)
02094 nice_printf (outfile, ", ");
02095 else {
02096 if (*did_one)
02097 nice_printf (outfile, ";\n");
02098 nice_printf (outfile, "static %s ", c_type_decl(t, 0));
02099 k = typesize[t];
02100 }
02101 nice_printf(outfile, "%s", equiv_name((int)(eqv - eqvclass), CNULL));
02102 nice_printf(outfile, "[%ld]",
02103 (eqv->eqvtop - eqv->eqvbottom + k - 1) / k);
02104 last_type = t;
02105 *did_one = 1;
02106 }
02107 }
02108
02109
02110
02111
02112
02113
02114
02115
02116
02117 char *
02118 #ifdef KR_headers
02119 wr_ardecls(outfile, dimp, size)
02120 FILE *outfile;
02121 struct Dimblock *dimp;
02122 long size;
02123 #else
02124 wr_ardecls(FILE *outfile, struct Dimblock *dimp, long size)
02125 #endif
02126 {
02127 int i, k;
02128 ftnint j;
02129 static char buf[1000];
02130
02131 if (dimp == (struct Dimblock *) NULL)
02132 return NULL;
02133
02134 sprintf(buf, "\t/* was ");
02135 k = strlen(buf);
02136
02137 for (i = 0; i < dimp -> ndim; i++) {
02138 expptr this_size = dimp -> dims[i].dimsize;
02139
02140 if (ISCONST(this_size)) {
02141 if (ISINT(this_size->constblock.vtype))
02142 j = this_size -> constblock.Const.ci;
02143 else if (ISREAL(this_size->constblock.vtype))
02144 j = (ftnint)this_size -> constblock.Const.cd[0];
02145 else
02146 goto non_const;
02147 size *= j;
02148 sprintf(buf+k, "[%ld]", j);
02149 k += strlen(buf+k);
02150
02151 }
02152 else {
02153 non_const:
02154 err ("wr_ardecls: nonconstant array size");
02155 }
02156 }
02157
02158 nice_printf (outfile, "[%ld]", size);
02159 strcat(buf+k, " */");
02160
02161 return (i > 1) ? buf : NULL;
02162 }
02163
02164
02165
02166
02167
02168
02169
02170
02171
02172
02173 static int
02174 #ifdef KR_headers
02175 get_p1_token(infile)
02176 FILE *infile;
02177 #else
02178 get_p1_token(FILE *infile)
02179 #endif
02180 {
02181 int token = P1_UNKNOWN;
02182
02183
02184
02185 if (fscanf (infile, "%d", &token) == EOF)
02186 return P1_EOF;
02187
02188
02189
02190 if (getc (infile) != '\n')
02191 getc (infile);
02192
02193 return token;
02194 }
02195
02196
02197
02198
02199
02200 static int
02201 #ifdef KR_headers
02202 p1gets(fp, str, size)
02203 FILE *fp;
02204 char *str;
02205 int size;
02206 #else
02207 p1gets(FILE *fp, char *str, int size)
02208 #endif
02209 {
02210 char c;
02211
02212 if (str == NULL)
02213 return 0;
02214
02215 if ((c = getc (fp)) != ' ')
02216 ungetc (c, fp);
02217
02218 if (fgets (str, size, fp)) {
02219 int length;
02220
02221 str[size - 1] = '\0';
02222 length = strlen (str);
02223
02224
02225
02226 if (str[length - 1] == '\n')
02227 str[length - 1] = '\0';
02228 return 1;
02229
02230 } else if (feof (fp))
02231 return EOF;
02232 else
02233 return 0;
02234 }
02235
02236
02237 static int
02238 #ifdef KR_headers
02239 p1get_const(infile, type, resultp)
02240 FILE *infile;
02241 int type;
02242 struct Constblock **resultp;
02243 #else
02244 p1get_const(FILE *infile, int type, struct Constblock **resultp)
02245 #endif
02246 {
02247 int status;
02248 struct Constblock *result;
02249
02250 if (type != TYCHAR) {
02251 *resultp = result = ALLOC(Constblock);
02252 result -> tag = TCONST;
02253 result -> vtype = type;
02254 }
02255
02256 switch (type) {
02257 case TYINT1:
02258 case TYSHORT:
02259 case TYLONG:
02260 case TYLOGICAL:
02261 #ifdef TYQUAD
02262 case TYQUAD:
02263 #endif
02264 case TYLOGICAL1:
02265 case TYLOGICAL2:
02266 status = p1getd (infile, &(result -> Const.ci));
02267 break;
02268 case TYREAL:
02269 case TYDREAL:
02270 status = p1getf(infile, &result->Const.cds[0]);
02271 result->vstg = 1;
02272 break;
02273 case TYCOMPLEX:
02274 case TYDCOMPLEX:
02275 status = p1getf(infile, &result->Const.cds[0]);
02276 if (status && status != EOF)
02277 status = p1getf(infile, &result->Const.cds[1]);
02278 result->vstg = 1;
02279 break;
02280 case TYCHAR:
02281 status = fscanf(infile, "%lx", resultp);
02282 break;
02283 default:
02284 erri ("p1get_const: bad constant type '%d'", type);
02285 status = 0;
02286 break;
02287 }
02288
02289 return status;
02290 }
02291
02292 static int
02293 #ifdef KR_headers
02294 p1getd(infile, result)
02295 FILE *infile;
02296 long *result;
02297 #else
02298 p1getd(FILE *infile, long *result)
02299 #endif
02300 {
02301 return fscanf (infile, "%ld", result);
02302 }
02303
02304 static int
02305 #ifdef KR_headers
02306 p1getf(infile, result)
02307 FILE *infile;
02308 char **result;
02309 #else
02310 p1getf(FILE *infile, char **result)
02311 #endif
02312 {
02313
02314 char buf[1324];
02315 register int k;
02316
02317 k = fscanf (infile, "%s", buf);
02318 if (k < 1)
02319 k = EOF;
02320 else
02321 strcpy(*result = mem(strlen(buf)+1,0), buf);
02322 return k;
02323 }
02324
02325 static int
02326 #ifdef KR_headers
02327 p1getn(infile, count, result)
02328 FILE *infile;
02329 int count;
02330 char **result;
02331 #else
02332 p1getn(FILE *infile, int count, char **result)
02333 #endif
02334 {
02335
02336 char *bufptr;
02337
02338 bufptr = (char *) ckalloc (count);
02339
02340 if (result)
02341 *result = bufptr;
02342
02343 for (; !feof (infile) && count > 0; count--)
02344 *bufptr++ = getc (infile);
02345
02346 return feof (infile) ? EOF : 1;
02347 }
02348
02349 static void
02350 #ifdef KR_headers
02351 proto(outfile, at, fname)
02352 FILE *outfile;
02353 Argtypes *at;
02354 char *fname;
02355 #else
02356 proto(FILE *outfile, Argtypes *at, char *fname)
02357 #endif
02358 {
02359 int i, j, k, n;
02360 char *comma;
02361 Atype *atypes;
02362 Namep np;
02363 chainp cp;
02364
02365 if (at) {
02366
02367
02368
02369
02370
02371
02372 atypes = at->atypes;
02373 n = at->defined ? at->dnargs : at->nargs;
02374 for(i = 0; i++ < n; atypes++) {
02375 if (!(cp = atypes->cp))
02376 continue;
02377 j = atypes->type;
02378 do {
02379 np = (Namep)cp->datap;
02380 k = np->vtype;
02381 if (np->vclass == CLPROC) {
02382 if (!np->vimpltype && k)
02383 k += 200;
02384 else {
02385 if (j >= 300)
02386 j = TYUNKNOWN + 200;
02387 continue;
02388 }
02389 }
02390 if (j == k)
02391 continue;
02392 if (j >= 300
02393 || j == 200 && k >= 200)
02394 j = k;
02395 else {
02396 if (at->nargs >= 0)
02397 bad_atypes(at,fname,i,j,k,""," and");
02398 goto break2;
02399 }
02400 }
02401 while(cp = cp->nextp);
02402 atypes->type = j;
02403 frchain(&atypes->cp);
02404 }
02405 }
02406 break2:
02407 if (parens) {
02408 nice_printf(outfile, parens);
02409 return;
02410 }
02411
02412 if (!at || (n = at-> defined ? at->dnargs : at->nargs) < 0) {
02413 nice_printf(outfile, Ansi == 1 ? "()" : "(...)");
02414 return;
02415 }
02416
02417 if (n == 0) {
02418 nice_printf(outfile, Ansi == 1 ? "(void)" : "()");
02419 return;
02420 }
02421
02422 atypes = at->atypes;
02423 nice_printf(outfile, "(");
02424 comma = "";
02425 for(; --n >= 0; atypes++) {
02426 k = atypes->type;
02427 if (k == TYADDR)
02428 nice_printf(outfile, "%schar **", comma);
02429 else if (k >= 200) {
02430 k -= 200;
02431 nice_printf(outfile, "%s%s", comma,
02432 usedcasts[k] = casttypes[k]);
02433 }
02434 else if (k >= 100)
02435 nice_printf(outfile,
02436 k == TYCHAR + 100 ? "%s%s *" : "%s%s",
02437 comma, c_type_decl(k-100, 0));
02438 else
02439 nice_printf(outfile, "%s%s *", comma,
02440 c_type_decl(k, 0));
02441 comma = ", ";
02442 }
02443 nice_printf(outfile, ")");
02444 }
02445
02446 void
02447 #ifdef KR_headers
02448 protowrite(protofile, type, name, e, lengths)
02449 FILE *protofile;
02450 int type;
02451 char *name;
02452 struct Entrypoint *e;
02453 chainp lengths;
02454 #else
02455 protowrite(FILE *protofile, int type, char *name, struct Entrypoint *e, chainp lengths)
02456 #endif
02457 {
02458 extern char used_rets[];
02459 int asave;
02460
02461 if (!(asave = Ansi))
02462 Castargs = Ansi = 1;
02463 nice_printf(protofile, "extern %s %s", protorettypes[type], name);
02464 list_arg_types(protofile, e, lengths, 0, ";\n");
02465 used_rets[type] = 1;
02466 if (!(Ansi = asave))
02467 Castargs = 0;
02468 }
02469
02470 static void
02471 #ifdef KR_headers
02472 do_p1_1while(outfile)
02473 FILE *outfile;
02474 #else
02475 do_p1_1while(FILE *outfile)
02476 #endif
02477 {
02478 if (*wh_next) {
02479 nice_printf(outfile,
02480 "for(;;) { /* while(complicated condition) */\n" );
02481 next_tab(outfile);
02482 }
02483 else
02484 nice_printf(outfile, "while(" );
02485 }
02486
02487 static void
02488 #ifdef KR_headers
02489 do_p1_2while(infile, outfile)
02490 FILE *infile;
02491 FILE *outfile;
02492 #else
02493 do_p1_2while(FILE *infile, FILE *outfile)
02494 #endif
02495 {
02496 expptr test;
02497
02498 test = do_format(infile, outfile);
02499 if (*wh_next)
02500 nice_printf(outfile, "if (!(");
02501 expr_out(outfile, test);
02502 if (*wh_next++)
02503 nice_printf(outfile, "))\n\tbreak;\n");
02504 else {
02505 nice_printf(outfile, ") {\n");
02506 next_tab(outfile);
02507 }
02508 }
02509
02510 static void
02511 #ifdef KR_headers
02512 do_p1_elseifstart(outfile)
02513 FILE *outfile;
02514 #else
02515 do_p1_elseifstart(FILE *outfile)
02516 #endif
02517 {
02518 if (ei_next < ei_last && *ei_next++) {
02519 prev_tab(outfile);
02520 nice_printf(outfile,
02521 "} else /* if(complicated condition) */ {\n" );
02522 next_tab(outfile);
02523 }
02524 }
