![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to mwm.changes CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / f2c|
Return to mwm.changes CVS log | Up to [Research Unix] / researchv10no / cmd / f2c |
1.1 root 1: #From arpa!NSFnet-Relay.AC.UK!NAGIST%vax.oxford.ac.uk Fri Jun 30 13:02 BST 1989
2: #Received: from vax.oxford.ac.uk by NSFnet-Relay.AC.UK via Janet with NIFTP
3: # id aa05326; 30 Jun 89 12:59 BST
4: #Date: Fri, 30 Jun 89 13:02 BST
5: #From: NAG Software Engineering Group <NAGIST%[email protected]>
6: #To: DMG <@NSFnet-Relay.AC.UK:[email protected]>
7: #Subject:
8: #
9: #!/bin/sh
10: # to extract, remove the header and type "sh filename"
11: if `test ! -s ./data.c.ed`
12: then
13: echo "writting ./data.c.ed"
14: cat > ./data.c.ed << '\Rogue\Monster\'
15: 378a
16:
17: void
18: make_param(p, e)
19: register struct Paramblock *p;
20: expptr e;
21: {
22: p->vclass = CLPARAM;
23: impldcl(p);
24: p->paramval = mkconv(p->vtype, e);
25: }
26: .
27: 3c
28: /* ROUTINES CALLED DURING DATA AND PARAMETER STATEMENT PROCESSING */
29: .
30: \Rogue\Monster\
31: else
32: echo "will not over write ./data.c.ed"
33: fi
34: if `test ! -s ./defines.h.ed`
35: then
36: echo "writting ./defines.h.ed"
37: cat > ./defines.h.ed << '\Rogue\Monster\'
38: 204c
39: #define OPASSIGNI 56 /* assignment for inquire stmt */
40: #define OPIDENTITY 57 /* for turning TADDR into TEXPR */
41: .
42: 16,27d
43: \Rogue\Monster\
44: else
45: echo "will not over write ./defines.h.ed"
46: fi
47: if `test ! -s ./defs.h.ed`
48: then
49: echo "writting ./defs.h.ed"
50: cat > ./defs.h.ed << '\Rogue\Monster\'
51: 635,637d
52: 294a
53: chainp init_values; /* list of sorted block data init values */
54: .
55: 202,207d
56: \Rogue\Monster\
57: else
58: echo "will not over write ./defs.h.ed"
59: fi
60: if `test ! -s ./equiv.c.ed`
61: then
62: echo "writting ./equiv.c.ed"
63: cat > ./equiv.c.ed << '\Rogue\Monster\'
64: 308,312d
65: 275,278d
66: 261d
67: 256,259d
68: 223,226c
69: freqchain(equivdecl);
70: .
71: 216,221d
72: 214a
73: if (x == 0) {
74: x = 1;
75: k = TYCHAR;
76: } /* if */
77: .
78: 210,213d
79: 204,207c
80:
81: /* Only want TYLOGICAL if ALL the init values are logical. Otherwise, all
82: non-zero values get mapped onto TRUE_ */
83:
84: if ((x < t && (np -> vtype != TYLOGICAL || x == 0))
85: || k == TYLOGICAL) {
86: x = t;
87: k = np->vtype;
88: }
89: .
90: 198c
91: x = 0;
92: .
93: 192,196d
94: 136,139d
95: 2,8d
96: \Rogue\Monster\
97: else
98: echo "will not over write ./equiv.c.ed"
99: fi
100: if `test ! -s ./exec.c.ed`
101: then
102: echo "writting ./exec.c.ed"
103: cat > ./exec.c.ed << '\Rogue\Monster\'
104: 633,637c
105: vname -> vis_assigned = 1;
106: }
107:
108: /* don't duplicate labels... */
109:
110: stno = labelval->stateno;
111: for(cp = vname->varxptr.assigned_values; cp; cp = cp->nextp)
112: if ((ftnint)cp->datap == stno)
113: break;
114: if (!cp)
115: vname->varxptr.assigned_values =
116: mkchain(stno, vname->varxptr.assigned_values);
117: }
118:
119: /* Code for FORMAT label... */
120:
121: fs = labelval->fmtstring;
122: if (!labelval->labdefined || fs && fs != nullstr) {
123: if (!fs)
124: labelval->fmtstring = nullstr;
125: labelval->labused = 1;
126: vname = asg_name(vname->varname);
127: q = ALLOC(Addrblock);
128: q->tag = TADDR;
129: q->vtype = TYCHAR;
130: q->vstg = STGAUTO;
131: q->ntempelt = 1;
132: q->memoffset = ICON(0);
133: q->uname_tag = UNAM_IDENT;
134: sprintf(q->user.ident, "fmt_%ld", labelval->stateno);
135: putout(mkexpr(OPASSIGN, vname, q));
136: }
137:
138: .
139: 631c
140: if (!labelval->labdefined || !labelval->fmtstring) {
141:
142: putout(mkexpr(OPASSIGN, p, mkintcon(labelval->stateno)));
143:
144: if (vname -> vis_assigned == 0) {
145: .
146: 627d
147: 625c
148: /* code for executable label... */
149: .
150: 623c
151: /* If the label hasn't been defined, then we do things twice:
152: * once for an executable stmt label, once for a format
153: */
154: .
155: 621c
156: return;
157: }
158: .
159: 619c
160: if( ! ONEOF(p->vtype, MSKINT|MSKADDR) ) {
161: .
162: 616a
163: register Addrp q;
164: static char nullstr[] = "";
165: char *fs;
166: register chainp cp;
167: register ftnint stno;
168: .
169: 612c
170: register Namep vname;
171: .
172: 610a
173: Namep
174: asg_name(s1)
175: register char *s1;
176: {
177: char buf[VL], *s, *se;
178: register Namep vn;
179: extern chainp assigned_fmts;
180:
181: /* Use Upper-case first letter for corresponding format variable */
182: buf[0] = *s1 + 'A' - 'a';
183: s = buf + 1;
184: se = buf + VL;
185: while(s < se && (*s = *++s1) != ' ')
186: s++;
187: vn = mkname(s-buf, buf);
188: if (!vn->vis_assigned) {
189: vn->vis_assigned = 1;
190: vn->vstg = STGAUTO;
191: vn->vprocclass = CLVAR;
192: vn->vtype = TYCHAR;
193: vn->vleng = ICON(-1); /* kludge used in list_decls */
194: assigned_fmts = mkchain((tagptr) vn, assigned_fmts);
195: }
196: return vn;
197: }
198:
199: .
200: 393c
201: /* putx added 6-29-89 (mwm), not sure if fixtype is required, but I doubt it
202: since mkconv is called just before */
203: doinit = putx (mkconv (dotype, DOINIT));
204: .
205: \Rogue\Monster\
206: else
207: echo "will not over write ./exec.c.ed"
208: fi
209: if `test ! -s ./expr.c.ed`
210: then
211: echo "writting ./expr.c.ed"
212: cat > ./expr.c.ed << '\Rogue\Monster\'
213: 2590,2591c
214: if (doing_setbound)
215: lp = p->exprblock.leftp = make_int_expr(lp);
216: else {
217: p->exprblock.vtype = ltype;
218: return(p);
219: }
220: .
221: 2551a
222: extern expptr make_int_expr();
223: .
224: 2545a
225: int doing_setbound;
226: .
227: 1991a
228: case OPASSIGNI:
229: .
230: 1980a
231: case OPIDENTITY:
232: .
233: 1865a
234: case OPIDENTITY:
235: .
236: 1843a
237: case OPASSIGNI:
238: .
239: 1405c
240: return (Addrp) cpexpr ((expptr) retslot);
241: .
242: 1282,1284d
243: 1279d
244: 1128c
245: if (!replaced)
246: s->memoffset = mkexpr(OPPLUS, s->memoffset, suboffset(p) );
247: .
248: 1118a
249: replaced = 0;
250: .
251: 1082c
252: return((Addrp) errnode() );
253: .
254: 1068a
255: replaced = 1;
256: .
257: 1052d
258: 1050a
259: static int replaced;
260: .
261: 1003c
262: if((rp->rpltag = rp->rplvp->tag) == TERROR)
263: .
264: 871a
265: #endif
266: .
267: 869a
268: #if 0
269: /* erroneous error msg */
270: .
271: 822d
272: 806d
273: 561,563d
274: 559d
275: 549a
276: if (rtype == TYREAL)
277: break;
278: .
279: 363a
280: if (p->addrblock.vtype > TYERROR) /* i/o block */
281: break;
282: .
283: 209c
284: #if PDP11_option
285: .
286: 99a
287: p -> vtype = (p -> const.ci >> typesize[TYSHORT]) ? TYLONG : TYSHORT;
288: .
289: \Rogue\Monster\
290: else
291: echo "will not over write ./expr.c.ed"
292: fi
293: if `test ! -s ./f2c.h.ed`
294: then
295: echo "writting ./f2c.h.ed"
296: cat > ./f2c.h.ed << '\Rogue\Monster\'
297: 102a
298: /* fix up name clashes */
299:
300: #define acos__ acos_
301: #define asin__ asin_
302: #define asm__ asm_
303: #define auto__ auto_
304: #define break__ break_
305: #define case__ case_
306: #define char__ char_
307: #define const__ const_
308: #define cos__ cos_
309: #define cosh__ cosh_
310: #define do__ do_
311: #define double__ double_
312: #define else__ else_
313: #define entry__ entry_
314: #define enum__ enum_
315: #define exp__ exp_
316: #define extern__ extern_
317: #define float__ float_
318: #define for__ for_
319: #define int__ int_
320: #define log__ log_
321: #define long__ long_
322: #define short__ short_
323: #define signed__ signed_
324: #define sin__ sin_
325: #define sinh__ sinh_
326: #define sizeof__ sizeof_
327: #define sqrt__ sqrt_
328: #define static__ static_
329: #define struct__ struct_
330: #define switch__ switch_
331: #define tan__ tan_
332: #define tanh__ tanh_
333: #define union__ union_
334: #define void__ void_
335: #define while__ while_
336: #define pow_ii_ pow_ii
337: #define pow_ri_ pow_ri
338: #define pow_di_ pow_di
339: #define pow_ci_ pow_ci
340: #define pow_zi_ pow_zi
341: #define pow_hh_ pow_hh
342: #define pow_dd_ pow_dd
343: #define pow_zz_ pow_zz
344: .
345: \Rogue\Monster\
346: else
347: echo "will not over write ./f2c.h.ed"
348: fi
349: if `test ! -s ./format.c.ed`
350: then
351: echo "writting ./format.c.ed"
352: cat > ./format.c.ed << '\Rogue\Monster\'
353: 1319c
354: sprintf(buf+k, "[%d]", this_size -> constblock.const.ci);
355: k += strlen (buf + k);
356: .
357: 1310c
358: sprintf (buf, "\t/* was ");
359: k = strlen (buf);
360: .
361: 1304c
362: int i, k;
363: .
364: 1302a
365: int size;
366: .
367: 1300c
368: char *write_array_decls(outfile, dimp, size)
369: .
370: 1260a
371: else if (write_header == 2)
372: nice_printf(outfile, "\n");
373:
374: /* Finally, ioblocks (which may reference equivs) */
375: if (iob_list)
376: write_ioblocks(outfile);
377: if (assigned_fmts)
378: write_assigned_fmts(outfile);
379:
380: .
381: 1249a
382: if (Define) {
383: indent_printf(0, outfile, ")\n");
384: write_header = 2;
385: }
386: .
387: 1200c
388: if (!Define)
389: nice_printf (outfile, " = ");
390: .
391: 1178c
392: Alias1:
393: if (Alias) {
394: .
395: 1175d
396: 1173c
397: comment = write_array_decls(outfile, var->vdim, 1);
398: }
399: .
400: 1160,1171c
401: !ISICON (var -> vleng)
402: || oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON)))
403: nice_printf (outfile, "*%s", storage);
404: else {
405: nice_printf (outfile, "%s", storage);
406: if (var -> vclass == CLPROC)
407: nice_printf (outfile, "()");
408: else if (var -> vtype == TYCHAR && ISICON ((var -> vleng)))
409: write_char_len(outfile, var->vdim,
410: var -> vleng -> constblock.const.ci, 0);
411: else if (var -> vdim &&
412: .
413: 1115c
414: Alias = oneof_stg(var, stg, M(STGEQUIV)|M(STGCOMMON));
415: if (Define = Alias && define_equivs) {
416: if (!write_header)
417: nice_printf(outfile, ";\n");
418: define_start(outfile, storage, CNULL, "(");
419: goto Alias1;
420: }
421: else if (type == last_type && class == last_class &&
422: .
423: 1104a
424: write_header = 2;
425: }
426: .
427: 1103c
428: M(STGBSS)|M(STGEXT)|M(STGAUTO)|M(STGCOMMON)|M(STGEQUIV))) {
429: .
430: 1101c
431: if (write_header == 1 && (new_vars || nequiv || used_builtins)
432: .
433: 999,1001c
434: ISICON ((var -> vleng))
435: && (i = var->vleng->constblock.const.ci) > 0)
436: nice_printf (outfile, "[%d]", i);
437: .
438: 957a
439: /* Next come formats */
440: write_formats(outfile);
441:
442: .
443: 951c
444: int Alias, Define, did_one, i, last_type, type;
445: extern int define_equivs;
446: .
447: 939a
448: static void
449: write_formats(outfile)
450: FILE *outfile;
451: {
452: register struct Labelblock *lp;
453: int first = 1;
454: extern int in_string;
455: char *fs;
456:
457: for(lp = labeltab ; lp < highlabtab ; ++lp)
458: if (lp->labused) {
459: if (first) {
460: first = 0;
461: nice_printf(outfile, "/* Format strings */\n");
462: }
463: nice_printf(outfile, "static char fmt_%ld[] = \"",
464: lp->stateno);
465: in_string = 1;
466: if (!(fs = lp->fmtstring))
467: fs = "";
468: nice_printf(outfile, "%s\"", fs);
469: in_string = 0;
470: nice_printf(outfile, ";\n");
471: }
472: if (!first)
473: nice_printf(outfile, "\n");
474: }
475:
476: static void
477: write_ioblocks(outfile)
478: FILE *outfile;
479: {
480: register iob_data *L;
481: register char *f, **s, *sep;
482:
483: nice_printf(outfile, "/* Fortran I/O blocks */\n");
484: L = iob_list = (iob_data *)revchain((chainp)iob_list);
485: do {
486: nice_printf(outfile, "static %s %s = { ",
487: L->type, L->name);
488: indent += tab_size;
489: sep = 0;
490: for(s = L->fields; f = *s; s++) {
491: if (sep)
492: nice_printf(outfile, sep);
493: sep = ", ";
494: if (*f == '"') { /* kludge */
495: nice_printf(outfile, "\"");
496: in_string = 1;
497: nice_printf(outfile, "%s\"", f+1);
498: in_string = 0;
499: }
500: else
501: nice_printf(outfile, "%s", f);
502: }
503: nice_printf(outfile, " };\n");
504: indent -= tab_size;
505: }
506: while(L = L->next);
507: nice_printf(outfile, "\n\n");
508: }
509:
510: static void
511: write_assigned_fmts(outfile)
512: FILE *outfile;
513: {
514: register chainp cp;
515: Namep np;
516: int did_one = 0;
517:
518: cp = assigned_fmts = revchain(assigned_fmts);
519: nice_printf(outfile, "/* Assigned format variables */\nchar ");
520: do {
521: np = (Namep)cp->datap;
522: if (did_one)
523: nice_printf(outfile, ", ");
524: did_one = 1;
525: nice_printf(outfile, "*%s", varstr(VL, np->varname));
526: }
527: while(cp = cp->nextp);
528: nice_printf(outfile, ";\n\n");
529: }
530:
531: .
532: 747c
533: next_tab (outfile);
534: .
535: 742a
536:
537: .
538: 98a
539: other_undefs(c_file);
540: .
541: 40c
542: extern FILE *fopen ();
543: .
544: 31a
545: extern chainp assigned_fmts;
546: .
547: 20a
548: static int p1get_const (), p1getn ();
549: .
550: 12c
551: int c_output_line_length = DEF_C_LINE_LENGTH;
552: .
553: 10a
554: #include "iob.h"
555: .
556: \Rogue\Monster\
557: else
558: echo "will not over write ./format.c.ed"
559: fi
560: if `test ! -s ./format_d.c.ed`
561: then
562: echo "writting ./format_d.c.ed"
563: cat > ./format_d.c.ed << '\Rogue\Monster\'
564: 821a
565:
566: save_block_data (comname, values)
567: char *comname;
568: chainp values;
569: {
570: struct Extsym *ext = mkext (varunder (XL, comname));
571:
572: if (ext && ext -> extp)
573: if (ext -> init_values)
574: errstr ("Two block data for %s common block", comname);
575: else
576: ext -> init_values = values;
577: else
578: errstr ("Bad common block '%s' with BLOCK DATA", comname);
579: } /* save_block_data */
580: .
581: 802,820c
582: type = eqv -> eqvtype;
583: nice_printf (outfile, "static %s %s", c_type_decl (type, NULL),
584: equiv_name (memno, NULL));
585: nice_printf (outfile, "[%d] = ", (eqv -> eqvtop - eqv -> eqvbottom) /
586: typesize[type]);
587: reshape_values (type, values, '\0');
588: write_array_init (outfile, type, values);
589: nice_printf (outfile, ";\n");
590: .
591: 799,800d
592: 792a
593: int type;
594: .
595: 622a
596: int index = (int) (((chainp) values -> datap) -> datap);
597:
598: while (index - main_index++ > 0)
599: *str_ptr++ = ' ';
600:
601: .
602: 620c
603: /* Find the max length of init string, by finding the highest offset
604: value stored in the list of initial values */
605:
606: for(k = 1, prev = CHNULL, v = values; v; prev = v, v = v->nextp)
607: ;
608: if (prev != CHNULL)
609: k = ((int) (((chainp) prev -> datap) -> datap)) + 1;
610: .
611: 617,618c
612: chainp v, prev;
613: int b = 0, k = 0, main_index = 0;
614: .
615: 611a
616: int str_start; /* offset at which character storage starts. If type
617: is not TYCHAR, this value is ignored */
618: .
619: 608c
620: union Constant *make_one_const (type, storage, values, str_start)
621: .
622: 583c
623: const = make_one_const (type, storage, values, 0);
624: .
625: 574c
626: const = make_one_const (type, storage, values, 0);
627: .
628: 511a
629: if (stddbg)fprintf (stddbg, "format_data: index %d, main %d\n", index, main_index);
630: .
631: 455c
632: (tagptr) mkchain ((tagptr) offset, mkchain ((tagptr) dest, val)), CHNULL));
633: .
634: 434c
635: res.c[i] = pad_char;
636: if (i == 0)
637: offset = 0;
638: .
639: 418c
640: c = pad_char;
641: .
642: 414c
643: make_one_const (TYLONG, &c, cp, 0);
644: .
645: 409a
646:
647: /* Now this is a little weird. Until June 20, 1989, we didn't need to store
648: any offset information. But it seems the equiv init process requires it.
649: So, instead of zeroing it out, we'll keep it in, BUT the offset is in
650: terms of characters, whereas the reshaped data is of the proper type. */
651:
652: offset = ((int) this -> datap);
653: .
654: 400a
655: int offset = 0;
656: .
657: 349a
658: char pad_char; /* value used for padding. ' ' for most, but
659: '\0' for equivalenced data */
660: .
661: 347c
662: static reshape_values (dest, data, pad_char)
663: .
664: 339c
665: const = make_one_const (type, temp, values, 0);
666: .
667: 330c
668: reshape_values (type, values, ' ');
669: .
670: 216,219d
671: 213,214c
672: ? 0 : write_array_decls (outfile, namep -> vdim, 1);
673: .
674: 173c
675:
676: /* I don't know why eqvstart needs to be subtracted, but Dave Gay thinks
677: it's necessary 28-June-89 (mwm)
678: */
679: write_equiv_init (outfile, memno - eqvstart, values);
680: .
681: 139c
682: static int ch_ar_dim = -1; /* length of each element of char string array,
683: used to break up long init strings for ansi
684: compilers */
685: .
686: 78a
687: /* Save the COMMON block data initializations for later */
688: save_block_data (ovarname, values);
689:
690: .
691: 77a
692: else
693: .
694: \Rogue\Monster\
695: else
696: echo "will not over write ./format_d.c.ed"
697: fi
698: if `test ! -s ./gram.dcl.ed`
699: then
700: echo "writting ./gram.dcl.ed"
701: cat > ./gram.dcl.ed << '\Rogue\Monster\'
702: 197,199c
703: make_param($1, $3);
704: .
705: 173d
706: \Rogue\Monster\
707: else
708: echo "will not over write ./gram.dcl.ed"
709: fi
710: if `test ! -s ./gram.exec.ed`
711: then
712: echo "writting ./gram.exec.ed"
713: cat > ./gram.exec.ed << '\Rogue\Monster\'
714: \Rogue\Monster\
715: else
716: echo "will not over write ./gram.exec.ed"
717: fi
718: if `test ! -s ./gram.expr.ed`
719: then
720: echo "writting ./gram.expr.ed"
721: cat > ./gram.expr.ed << '\Rogue\Monster\'
722: 98a
723: | bit_const
724: .
725: \Rogue\Monster\
726: else
727: echo "will not over write ./gram.expr.ed"
728: fi
729: if `test ! -s ./gram.head.ed`
730: then
731: echo "writting ./gram.head.ed"
732: cat > ./gram.head.ed << '\Rogue\Monster\'
733: 136,149d
734: 5,16d
735: \Rogue\Monster\
736: else
737: echo "will not over write ./gram.head.ed"
738: fi
739: if `test ! -s ./init.c.ed`
740: then
741: echo "writting ./init.c.ed"
742: cat > ./init.c.ed << '\Rogue\Monster\'
743: 318d
744: 302a
745: frchain(&assigned_fmts);
746: .
747: 270d
748: 266,268d
749: 242d
750: 240d
751: 237a
752: iob_list = 0;
753: for(i = 0; i < 9; i++)
754: io_structs[i] = 0;
755: .
756: 168,172d
757: 161d
758: 23a
759: chainp assigned_fmts = CHNULL; /* assigned formats */
760: .
761: 3a
762: #include "iob.h"
763: .
764: \Rogue\Monster\
765: else
766: echo "will not over write ./init.c.ed"
767: fi
768: if `test ! -s ./intr.c.ed`
769: then
770: echo "writting ./intr.c.ed"
771: cat > ./intr.c.ed << '\Rogue\Monster\'
772: 672c
773: return((Addrp) errnode() );
774: .
775: 26c
776: char intrfname[VL+1]; /* "+1" added 19 June 89 (mwm) */
777: .
778: \Rogue\Monster\
779: else
780: echo "will not over write ./intr.c.ed"
781: fi
782: if `test ! -s ./io.c.ed`
783: then
784: echo "writting ./io.c.ed"
785: cat > ./io.c.ed << '\Rogue\Monster\'
786: 963a
787: ioset_assign = OPASSIGN;
788: }
789: .
790: 962c
791: ONEOF(p->addrblock.vtype, M(TYLONG)|M(TYLOGICAL)) ) {
792: ioset_assign = OPASSIGNI;
793: .
794: 940,946c
795: if (!p)
796: return;
797: if (p->tag != TADDR)
798: badtag(who, p->tag);
799: if (p->vtype != TYCHAR
800: && p->vtype != TYLONG
801: && p->vtype != TYSHORT)
802: badtype(who, p->vtype);
803: offset /= SZLONG;
804: switch(p->uname_tag) {
805: case UNAM_NAME:
806: mo = p->memoffset;
807: if (mo->tag != TCONST)
808: badtag("ioseta/memoffset", mo->tag);
809: if (mo->constblock.const.ci)
810: sprintf(s = mem(VL+20,0), "%s+%ld",
811: varstr(VL, p->user.name->varname),
812: mo->constblock.const.ci);
813: else
814: s = cpstring(varstr(VL, p->user.name->varname));
815: break;
816: case UNAM_CONST:
817: s = tostring(p->user.const.ccp1.ccp0,
818: p->vleng->constblock.const.ci);
819: break;
820: default:
821: badthing("uname_tag", who, p->uname_tag);
822: }
823: /* kludge for Hollerith */
824: if (p->vtype != TYCHAR) {
825: s1 = mem(strlen(s)+10,0);
826: sprintf(s1, "(char *)%s%s", p->isarray ? "" : "&", s);
827: s = s1;
828: }
829: iob_list->fields[offset] = s;
830: .
831: 936c
832: char *s, *s1;
833: static char who[] = "ioseta";
834: expptr mo;
835: .
836: 910,912c
837: }
838: else {
839: register Addrp q;
840:
841: q = ALLOC(Addrblock);
842: q->tag = TADDR;
843: q->vtype = type;
844: q->vstg = STGAUTO;
845: q->ntempelt = 1;
846: q->isarray = 0;
847: q->memoffset = ICON(0);
848: q->uname_tag = UNAM_IDENT;
849: sprintf(q->user.ident, "%s.%s",
850: statstruct ? iob_list->name : ioblkp->user.ident,
851: io_fields[offset + 1]);
852: if (type == TYADDR && p->tag == TCONST
853: && p->constblock.vtype == TYADDR) {
854: /* kludge */
855: register Addrp p1;
856: p1 = ALLOC(Addrblock);
857: p1->tag = TADDR;
858: p1->vtype = type;
859: p1->vstg = STGAUTO; /* wrong, but who cares? */
860: p1->ntempelt = 1;
861: p1->isarray = 0;
862: p1->memoffset = ICON(0);
863: p1->uname_tag = UNAM_IDENT;
864: sprintf(p1->user.ident, "fmt_%ld",
865: p->constblock.const.ci);
866: frexpr(p);
867: p = (expptr)p1;
868: }
869: putexpr(mkexpr(ioset_assign, q, p));
870: }
871: .
872: 900,908c
873: offset /= SZLONG;
874: if(statstruct && ISCONST(p)) {
875: register char *s;
876: switch(type) {
877: case TYADDR: /* stmt label */
878: s = IO_FMT_NAME;
879: break;
880: case TYIOINT:
881: s = "";
882: break;
883: default:
884: badtype("ioset", type);
885: }
886: iob_list->fields[offset] =
887: string_num(s, p->constblock.const.ci);
888: .
889: 895d
890: 893a
891: static int ioset_assign = OPASSIGN;
892: .
893: 794a
894: ioblkp = 0; /* unnecessary */
895: .
896: 793d
897: 746,758d
898: 744c
899: new_iob_data(ios,
900: temp_name(IO_YAIN_NAME, lastvarno,
901: ioblkp->user.ident));
902: } else if(!(ioblkp = io_structs[iostmt1]))
903: io_structs[iostmt1] = ioblkp =
904: autovar(1, ios->type, PNULL, IO_BLOCK_NAME);
905: .
906: 738c
907: ioblkp->vtype = ios->type;
908: .
909: 732,735c
910: iob_data *iod;
911: char *s, *se;
912: .
913: 729a
914: if (intfile) {
915: ios = io_stuff + iostmt;
916: iostmt1 = IOREAD;
917: }
918: else {
919: ios = io_stuff;
920: iostmt1 = 0;
921: }
922: io_fields = ios->fields;
923: .
924: 690c
925: fmtp = (Addrp)mkaddcon(lp->stateno);
926: /* lp->stateno for names fmt_nnn */
927: lp->labused = 1;
928: .
929: 688c
930: struct Labelblock *lp;
931: lp = mklabel(p->constblock.const.ci);
932: if( (k = fmtstmt(lp)) > 0 )
933: .
934: 674,675c
935: varfmt = YES;
936: fmtp = asg_addr(p);
937: .
938: 588a
939: struct io_setup *ios;
940: .
941: 587c
942: int iostmt1, k;
943: .
944: 583c
945: register Addrp unitp, fmtp, recp;
946: .
947: 577a
948:
949: LOCAL Addrp asg_addr(p)
950: union Expression *p;
951: {
952: extern Namep asg_name();
953: register Addrp q;
954:
955: if (p->tag != TPRIM)
956: badtag("asg_addr", p->tag);
957: q = ALLOC(Addrblock);
958: q->tag = TADDR;
959: q->vtype = TYCHAR;
960: q->vstg = STGAUTO;
961: q->ntempelt = 1;
962: q->isarray = 0;
963: q->memoffset = ICON(0);
964: q->uname_tag = UNAM_NAME;
965: q->user.name = asg_name(p->primblock.namep->varname);
966: return q;
967: }
968: .
969: 571,576c
970: putexpr(q);
971: if(ioendlab) {
972: exif(mkexpr(OPLT, cpexpr(zork), ICON(0)));
973: exgoto(execlab(ioendlab));
974: exendif();
975: }
976: if(ioerrlab) {
977: exif(mkexpr(iostmt==IOREAD||iostmt==IOWRITE ? OPGT : OPNE,
978: cpexpr(zork), ICON(0)));
979: exgoto(execlab(ioerrlab));
980: exendif();
981: }
982: if (zorkf)
983: templist = mkchain(zorkf, templist);
984: .
985: 569c
986: q = fixexpr( mkexpr(OPASSIGN, cpexpr(zork), q));
987: .
988: 566c
989: expptr zork, zorkf;
990:
991: if (!(zork = IOSTP) && (ioendlab || ioerrlab))
992: zork = zorkf = (expptr)mktemp(tyint, PNULL, IO_RESRC_NAME);
993: else
994: zorkf = 0;
995: if(zork)
996: .
997: 546,556d
998: 533,537c
999: expptr mc = mkconv(TYLONG, ICON(type));
1000: q = c ? call4(TYINT, "do_lio", mc, nelt, addr, c)
1001: : call3(TYINT, "do_lio", mc, nelt, addr);
1002: }
1003: else {
1004: char *s = ioformatted==FORMATTED ? "do_fio" : "do_uio";
1005: q = c ? call3(TYINT, s, nelt, addr, c)
1006: : call2(TYINT, s, nelt, addr);
1007: }
1008: .
1009: 528a
1010: #endif
1011: c = ALLOC(Addrblock);
1012: c->tag = TADDR;
1013: c->vtype = type;
1014: c->vstg = STGAUTO;
1015: c->ntempelt = 1;
1016: c->isarray = 1;
1017: c->memoffset = ICON(0);
1018: c->uname_tag = UNAM_IDENT;
1019: sprintf(c->user.ident, "sizeof(%s)", c_type_decl ((type
1020: == TYCHAR ? TYADDR : type), NULL));
1021: .
1022: 519c
1023: #if 0
1024: .
1025: 515a
1026: char *c_type_decl ();
1027: .
1028: 514d
1029: 502a
1030: extern Constp mkconst();
1031: register Addrp c = 0;
1032: .
1033: 494,496d
1034: 457c
1035: }
1036: else if(qe->headblock.vtype != TYERROR)
1037: .
1038: 283c
1039:
1040: .
1041: 279,280c
1042: io_structs[iostmt] = ioblkp =
1043: autovar(1, ios->type, PNULL, IO_BLOCK_NAME);
1044: .
1045: 277a
1046: ios = io_stuff + iostmt;
1047: io_fields = ios->fields;
1048: ioblkp = io_structs[iostmt];
1049: .
1050: 244,272c
1051: else if(iostmt == IOREAD && ioerrlab && ioendlab && ioerrlab!=ioendlab)
1052: IOSTP = (expptr) mktemp(TYINT, PNULL, IO_START_NAME);
1053: .
1054: 232c
1055: execlab(ioerrlab = p->constblock.const.ci);
1056: .
1057: 226c
1058: execlab(ioendlab = p->constblock.const.ci);
1059: .
1060: 222c
1061: ioerrlab = ioendlab = 0;
1062: .
1063: 216a
1064: struct io_setup *ios;
1065: .
1066: 193,194c
1067: s0 = s = lexline(&n);
1068: se = t = s + n;
1069:
1070: /* fix MYQUOTES (\002's) and \\'s */
1071:
1072: while(s < se)
1073: switch(*s++) {
1074: case 2:
1075: t += 3; break;
1076: case '"':
1077: case '\\':
1078: t++; break;
1079: }
1080: s = s0;
1081: lp->fmtstring = t = mem(t - s + 1, 0);
1082: while(s < se)
1083: switch(k = *s++) {
1084: case 2:
1085: t[0] = '\\';
1086: t[1] = '0';
1087: t[2] = '0';
1088: t[3] = '2';
1089: t += 4;
1090: break;
1091: case '"':
1092: case '\\':
1093: *t++ = '\\';
1094: /* no break */
1095: default:
1096: *t++ = k;
1097: }
1098: *t = 0;
1099: .
1100: 189,191c
1101: char *s0, *lexline();
1102: register char *s, *se, *t;
1103: register k;
1104: .
1105: 184d
1106: 160a
1107:
1108: LOCAL char _0[] = "0";
1109: LOCAL char *cilist_names[] = {
1110: "cilist",
1111: "cierr",
1112: "ciunit",
1113: "ciend",
1114: "cifmt",
1115: "cirec"
1116: };
1117: LOCAL char *icilist_names[] = {
1118: "icilist",
1119: "icierr",
1120: "iciunit",
1121: "iciend",
1122: "icifmt",
1123: "icirlen",
1124: "icirnum"
1125: };
1126: LOCAL char *olist_names[] = {
1127: "olist",
1128: "oerr",
1129: "ounit",
1130: "ofnm",
1131: "ofnmlen",
1132: "osta",
1133: "oacc",
1134: "ofm",
1135: "orl",
1136: "oblnk"
1137: };
1138: LOCAL char *cllist_names[] = {
1139: "cllist",
1140: "cerr",
1141: "cunit",
1142: "csta"
1143: };
1144: LOCAL char *alist_names[] = {
1145: "alist",
1146: "aerr",
1147: "aunit"
1148: };
1149: LOCAL char *inlist_names[] = {
1150: "inlist",
1151: "inerr",
1152: "inunit",
1153: "infile",
1154: "infilen",
1155: "inex",
1156: "inopen",
1157: "innum",
1158: "innamed",
1159: "inname",
1160: "innamlen",
1161: "inacc",
1162: "inacclen",
1163: "inseq",
1164: "inseqlen",
1165: "indir",
1166: "indirlen",
1167: "infmt",
1168: "infmtlen",
1169: "inform",
1170: "informlen",
1171: "inunf",
1172: "inunflen",
1173: "inrecl",
1174: "innrec",
1175: "inblank",
1176: "inblanklen"
1177: };
1178:
1179: LOCAL char **io_fields;
1180:
1181: #define zork(n,t) n, sizeof(n)/sizeof(char *) - 1, t
1182:
1183: LOCAL io_setup io_stuff[] = {
1184: zork(cilist_names, TYCILIST), /* external read/write */
1185: zork(inlist_names, TYINLIST), /* inquire */
1186: zork(olist_names, TYOLIST), /* open */
1187: zork(cllist_names, TYCLLIST), /* close */
1188: zork(alist_names, TYALIST), /* rewind */
1189: zork(alist_names, TYALIST), /* backspace */
1190: zork(alist_names, TYALIST), /* endfile */
1191: zork(icilist_names,TYICILIST), /* internal read */
1192: zork(icilist_names,TYICILIST) /* internal write */
1193: };
1194:
1195: #undef zork
1196:
1197: .
1198: 24c
1199: Addrp ioblkp;
1200: .
1201: 20,21d
1202: 12c
1203: iob_data *iob_list;
1204: Addrp io_structs[9];
1205: .
1206: 10a
1207: #include "iob.h"
1208: .
1209: \Rogue\Monster\
1210: else
1211: echo "will not over write ./io.c.ed"
1212: fi
1213: if `test ! -s ./lex.c.ed`
1214: then
1215: echo "writting ./lex.c.ed"
1216: cat > ./lex.c.ed << '\Rogue\Monster\'
1217: 985a
1218:
1219: /* Check for NAG's special hex constant */
1220:
1221: if (isdigit (*nextch) && (*(nextch + 1) == '#' ||
1222: (isdigit (*(nextch + 1)) && *(nextch + 2) == '#'))) {
1223:
1224: radix = atoi (nextch);
1225: if (*++nextch != '#')
1226: nextch++;
1227: if (radix != 2 && radix != 8 && radix != 16) {
1228: erri ("invalid base for constant, defaulting to hex", radix);
1229: radix = 16;
1230: } /* if */
1231: nextch++;
1232: for (p = token; hextoi (*nextch) < radix;)
1233: *p++ = *nextch++;
1234: toklen = p - token;
1235: token[toklen] = '\0';
1236: return (radix == 16) ? SHEXCON : ((radix == 8) ? SOCTCON :
1237: SBITCON);
1238: } /* if */
1239:
1240: .
1241: 930a
1242:
1243: /* BUG BUG BUG Why the heck is this a single OR? (mwm 6-20-89) */
1244:
1245: .
1246: 923a
1247:
1248: .
1249: 840a
1250: /* gettok -- moves the right amount of text from nextch into the token
1251: buffer. token initially contains garbage (leftovers from the prev token) */
1252:
1253: .
1254: \Rogue\Monster\
1255: else
1256: echo "will not over write ./lex.c.ed"
1257: fi
1258: if `test ! -s ./machdefs.h.ed`
1259: then
1260: echo "writting ./machdefs.h.ed"
1261: cat > ./machdefs.h.ed << '\Rogue\Monster\'
1262: 1,15c
1263: /*#define SDB 1*/
1264: .
1265: \Rogue\Monster\
1266: else
1267: echo "will not over write ./machdefs.h.ed"
1268: fi
1269: if `test ! -s ./main.c.ed`
1270: then
1271: echo "writting ./main.c.ed"
1272: cat > ./main.c.ed << '\Rogue\Monster\'
1273: 378d
1274: 369,376d
1275: 305,318d
1276: 262,265d
1277: 255,258d
1278: 226d
1279: 220,221c
1280: /* fatal("vax cannot recover from floating exception");*/
1281: .
1282: 99c
1283: f2c_entry ("Fr", P_ONE_ARG, P_STRING, &fl_fmt_string, 0),
1284: f2c_entry ("ev", P_NO_ARGS, P_INT, &define_equivs, NO)
1285: .
1286: 67a
1287: int define_equivs = YES;
1288: .
1289: 30d
1290: 8,28d
1291: 1,2c
1292: char xxxvers[] = "\n@(#) FORTRAN to C Translator, VERSION 0.4, June 29, 1989\n";
1293: #define VER 0x9629 /* for pi; 8YMDD */
1294: .
1295: \Rogue\Monster\
1296: else
1297: echo "will not over write ./main.c.ed"
1298: fi
1299: if `test ! -s ./mem.c.ed`
1300: then
1301: echo "writting ./mem.c.ed"
1302: cat > ./mem.c.ed << '\Rogue\Monster\'
1303: 59a
1304: }
1305:
1306: void
1307: new_iob_data(ios, name)
1308: register io_setup *ios;
1309: char *name;
1310: {
1311: register iob_data *iod;
1312: register char **s, **se;
1313:
1314: iod = (iob_data *)
1315: mem(sizeof(iob_data) + ios->nelt*sizeof(char *), 1);
1316: iod->next = iob_list;
1317: iob_list = iod;
1318: iod->type = ios->fields[0];
1319: iod->name = cpstring(name);
1320: s = iod->fields;
1321: se = s + ios->nelt;
1322: while(s < se)
1323: *s++ = "0";
1324: *s = 0;
1325: }
1326:
1327: char *
1328: string_num(pfx, n)
1329: char *pfx;
1330: long n;
1331: {
1332: char buf[32];
1333: sprintf(buf, "%s%ld", pfx, n);
1334: /* can't trust return type of sprintf -- BSD gets it wrong */
1335: return strcpy(mem(strlen(buf)+1,0), buf);
1336: }
1337:
1338: char *
1339: cpstring(s)
1340: register char *s;
1341: {
1342: return strcpy(mem(strlen(s)+1,0), s);
1343: }
1344:
1345: static defines *define_list;
1346:
1347: void
1348: define_start(outfile, s1, s2, post)
1349: FILE *outfile;
1350: char *s1, *s2, *post;
1351: {
1352: defines *d;
1353: int n, n1;
1354:
1355: n = n1 = strlen(s1);
1356: if (s2)
1357: n += strlen(s2);
1358: d = (defines *)mem(sizeof(defines)+n, 1);
1359: d->next = define_list;
1360: define_list = d;
1361: strcpy(d->defname, s1);
1362: if (s2)
1363: strcpy(d->defname + n1, s2);
1364: nice_printf(outfile, "#define %s %s", d->defname, post);
1365: }
1366:
1367: void
1368: other_undefs(outfile)
1369: FILE *outfile;
1370: {
1371: defines *d;
1372: if (d = define_list) {
1373: define_list = 0;
1374: nice_printf(outfile, "\n");
1375: do
1376: nice_printf(outfile, "#undef %s\n", d->defname);
1377: while(d = d->next);
1378: nice_printf(outfile, "\n");
1379: }
1380: .
1381: 57,58c
1382: register int k = n + 2, L;
1383: for(L = 0; L < n; L++)
1384: if (s[L] == '"')
1385: k++;
1386: rv = s1 = mem(k);
1387: *s1++ = '"';
1388: for(L = 0; L < n; L++) {
1389: if (s[L] == '"')
1390: *s1++ = '\\';
1391: *s1++ = s[L];
1392: }
1393: *s1 = 0;
1394: .
1395: 55a
1396: register char *s1;
1397: .
1398: 53,54c
1399: register char *s;
1400: register int n;
1401: .
1402: 48c
1403: return rv;
1404: .
1405: 44,45c
1406: rv = b->buf;
1407: mem_last = rv + sizeof(b->buf);
1408: s = rv + n;
1409: .
1410: 28c
1411: if (round)
1412: mem_next = (char *)(
1413: ((long)mem_next + sizeof(char *)-1)
1414: & ~(sizeof(char *)-1));
1415: rv = mem_next;
1416: s = rv + n;
1417: .
1418: 26c
1419: register char *rv, *s;
1420: .
1421: 22c
1422: mem(n, round)
1423: .
1424: 1a
1425: #include "iob.h"
1426: #include <string.h>
1427: .
1428: \Rogue\Monster\
1429: else
1430: echo "will not over write ./mem.c.ed"
1431: fi
1432: if `test ! -s ./misc.c.ed`
1433: then
1434: echo "writting ./misc.c.ed"
1435: cat > ./misc.c.ed << '\Rogue\Monster\'
1436: 1137a
1437: } /* struct_eq */
1438:
1439: /* biggest_type -- returns the largest type that can be used to output
1440: offset padding bytes. */
1441:
1442: int biggest_type (offset)
1443: int offset;
1444: {
1445: if (offset % typesize[TYDCOMPLEX] == 0)
1446: return TYDCOMPLEX;
1447: if (offset % typesize[TYDREAL] == 0)
1448: return TYDREAL;
1449: if (offset % typesize[TYLONG] == 0)
1450: return TYLONG;
1451: if (offset % typesize[TYSHORT] == 0)
1452: return TYSHORT;
1453: return TYCHAR;
1454: } /* biggest_type */
1455: .
1456: 888a
1457: case OPASSIGNI:
1458: .
1459: 745d
1460: 730c
1461:
1462: .
1463: 559a
1464: nextext->init_values = CHNULL;
1465: .
1466: 510c
1467: /* lp->labused = YES; */
1468: .
1469: 485a
1470: lp->fmtstring = 0;
1471: .
1472: 275,276d
1473: 273d
1474: 247c
1475: static char name[IDENT_LEN+1];
1476: .
1477: \Rogue\Monster\
1478: else
1479: echo "will not over write ./misc.c.ed"
1480: fi
1481: if `test ! -s ./names.c.ed`
1482: then
1483: echo "writting ./names.c.ed"
1484: cat > ./names.c.ed << '\Rogue\Monster\'
1485: 605,610c
1486: "acos", "alist", "asin", "asm", "atan", "atan2", "auto", "break",
1487: "case", "char", "cilist", "cllist", "const", "continue", "cos", "cosh",
1488: "default", "do", "double", "else", "entry", "enum", "exp",
1489: "extern", "flag", "float", "for", "ftnint", "ftnlen", "goto",
1490: "icilist", "if", "inlist", "int", "log", "long",
1491: "noalias", "olist", "register", "return",
1492: .
1493: 602a
1494: /* Also includes keywords used for I/O in f2c.h */
1495: .
1496: 545c
1497: static char buf[USER_LABEL_MAX + 1];
1498: .
1499: 427,429c
1500: define_start (outfile, varstr (XL, ext -> extname),
1501: comm_union_name (count, NULL), CNULL);
1502: .
1503: 264,267c
1504: sprintf (pointer, "_%d", count);
1505: .
1506: 78a
1507: case TYCILIST: strcpy (buff, "cilist"); break;
1508: case TYICILIST: strcpy (buff, "icilist"); break;
1509: case TYOLIST: strcpy (buff, "olist"); break;
1510: case TYCLLIST: strcpy (buff, "cllist"); break;
1511: case TYALIST: strcpy (buff, "alist"); break;
1512: case TYINLIST: strcpy (buff, "inlist"); break;
1513: .
1514: \Rogue\Monster\
1515: else
1516: echo "will not over write ./names.c.ed"
1517: fi
1518: if `test ! -s ./names.h.ed`
1519: then
1520: echo "writting ./names.h.ed"
1521: cat > ./names.h.ed << '\Rogue\Monster\'
1522: 18a
1523: #define IO_YAIN_NAME "io_" /* Yet another I/O Name */
1524: #define IO_FMT_NAME "fmt_" /* IO Format prefix */
1525: #define IO_RESRC_NAME "io_rc"
1526: .
1527: \Rogue\Monster\
1528: else
1529: echo "will not over write ./names.h.ed"
1530: fi
1531: if `test ! -s ./nice_printf.c.ed`
1532: then
1533: echo "writting ./nice_pf.c.ed"
1534: cat > ./nice_pf.c.ed << '\Rogue\Monster\'
1535: 229c
1536: cursor_pos = in_string ? 0 : ind +
1537: .
1538: 211a
1539: (void) safe_strncpy (next_slot, pointer + 1, sizeof(output_buf)-1);
1540: .
1541: 210d
1542: 198,199c
1543: pointer = adjust_pointer_in_string(pointer);
1544: else if (strchr("&*+-/<=>|", *pointer)
1545: .
1546: 167c
1547: else if (word_start && isntident(*(unsigned char *)pointer))
1548: .
1549: 164,165c
1550: if (!word_start && isident(*(unsigned char *)pointer))
1551: .
1552: 160,162c
1553: at the same time. Must check for tokens first, since '-' is considered
1554: part of an identifier; checking isident first would mean breaking up "->" */
1555: .
1556: 129d
1557: 124c
1558: if (in_string)
1559: for (pointer = next_slot; *pointer && *pointer != '\n' &&
1560: cursor_pos <= max_line_len; pointer++)
1561: cursor_pos++;
1562: else
1563: for (pointer = next_slot; *pointer && *pointer != '\n' &&
1564: .
1565: 117,119d
1566: 113a
1567: ind = indent <= MAX_INDENT
1568: ? indent
1569: : MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
1570:
1571: .
1572: 100a
1573: extern char tr_tab[]; /* in output.c */
1574: register char *Tr = tr_tab;
1575: int ind;
1576: .
1577: 97d
1578: 89c
1579: /* #define isident(x) (isalnum (x) || (x) == '_' || (x) == '.' || (x) == '-') */
1580: #define isident(x) (Tr[x] & 1)
1581: #define isntident(x) (!Tr[x])
1582: .
1583: 81a
1584: static char *
1585: adjust_pointer_in_string(pointer)
1586: register char *pointer;
1587: {
1588: register char *s, *s1, *se, *s0;
1589:
1590: if (pointer - next_slot < 20) /* arbitrary choice */
1591: return next_slot - 1;
1592: /* arrange not to break \002 */
1593: for(s = s1 = next_slot; s < pointer; s++) {
1594: s0 = s1;
1595: s1 = s;
1596: if (*s == '\\') {
1597: se = s++ + 4;
1598: if (se > pointer)
1599: break;
1600: if (*s < '0' || *s > '7')
1601: continue;
1602: while(++s < se)
1603: if (*s < '0' || *s > '7')
1604: break;
1605: --s;
1606: }
1607: }
1608: return s0 - 1;
1609: }
1610:
1611: .
1612: 22c
1613: int tab = ind + (use_extra ? TOO_LONG_INDENT : 0);
1614: .
1615: 20a
1616: ind = indent <= MAX_INDENT
1617: ? indent
1618: : MIN_INDENT + indent % (MAX_INDENT - MIN_INDENT);
1619:
1620: .
1621: 19c
1622: int ind;
1623: .
1624: 8a
1625: #define MAX_INDENT 44
1626: #define MIN_INDENT 22
1627: .
1628: 7d
1629: 2d
1630: \Rogue\Monster\
1631: else
1632: echo "will not over write ./nice_pf.c.ed"
1633: fi
1634: if `test ! -s ./nice_pf.h.ed`
1635: then
1636: echo "writting ./nice_pf.h.ed"
1637: cat > ./nice_pf.h.ed << '\Rogue\Monster\'
1638: 5c
1639: #define MAX_OUTPUT_SIZE 6000 /* Number of chars on one output line PLUS
1640: .
1641: \Rogue\Monster\
1642: else
1643: echo "will not over write ./nice_pf.h.ed"
1644: fi
1645: if `test ! -s ./output.c.ed`
1646: then
1647: echo "writting ./output.c.ed"
1648: cat > ./output.c.ed << '\Rogue\Monster\'
1649: 1168a
1650: extern int tab_size;
1651: register char *s;
1652:
1653: s = "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789_+-.";
1654: while(*s)
1655: tr_tab[*s++] = 3;
1656: tr_tab['>'] = 1;
1657: .
1658: 1157a
1659: char tr_tab[256]; /* machine dependent */
1660: .
1661: 1114,1141d
1662: 1104,1108d
1663: 1096d
1664: 1050,1054c
1665: #endif
1666: ONEOF(q->addrblock.vstg,
1667: M(STGARG)|M(STGCOMMON)|M(STGEQUIV)|M(STGCONST))
1668: || (memoffset && (!ISICON(memoffset)
1669: || memoffset->constblock.const.ci)))
1670: || ONEOF(q->addrblock.vstg,
1671: M(STGINIT)|M(STGAUTO)|M(STGBSS))
1672: && !q->addrblock.isarray)
1673: .
1674: 1047c
1675: q -> addrblock.vstg, M(STGARG)|M(STGEQUIV)) ||
1676: .
1677: 1045c
1678: !oneof_stg(q -> addrblock.uname_tag == UNAM_NAME ?
1679: .
1680: 1043c
1681: !ONEOF (q -> addrblock.vstg, M(STGEXT)|M(STGLENG))
1682: && (
1683: #if 0
1684: .
1685: 983a
1686: if (q->tag == TADDR) {
1687: if (q->addrblock.vtype > TYERROR) {
1688: /* I/O block */
1689: nice_printf(outfile, "&%s", q->addrblock.user.ident);
1690: continue;
1691: }
1692: if (!byvalue && q->addrblock.isarray
1693: && q->addrblock.vtype != TYCHAR
1694: && q->addrblock.memoffset->tag == TCONST
1695: && q->addrblock.memoffset->constblock.const.ci == 0) {
1696:
1697: /* &x[0] == x */
1698: /* This also prevents &sizeof(doublereal)[0] */
1699: switch(q->addrblock.uname_tag) {
1700: case UNAM_NAME:
1701: output_name(outfile, q->addrblock.user.name);
1702: continue;
1703: case UNAM_IDENT:
1704: nice_printf(outfile, "%s",
1705: q->addrblock.user.ident);
1706: continue;
1707: case UNAM_EXTERN:
1708: output_extern(outfile,
1709: &extsymtab[q->addrblock.memno]);
1710: continue;
1711: }
1712: }
1713: }
1714:
1715: .
1716: 976,977c
1717: for (cp = arglist; cp; cp = cp -> nextp, done_once = TRUE) {
1718: .
1719: 961c
1720: nice_printf(outfile, " (");
1721: .
1722: 940,947d
1723: 909a
1724: register expptr q;
1725: .
1726: 907,908d
1727: 894d
1728: 877,879d
1729: 813a
1730: /* Fudge character/arithmetic pairs: promote char to int. */
1731: /* This mainuplation is meant to make ichar() work right. */
1732:
1733: if (e->vtype >= TYSHORT && e->vtype <= TYLOGICAL) {
1734: register union Expression *Offset;
1735:
1736: if (e->leftp && e->leftp->tag == TADDR
1737: && e->leftp->addrblock.vtype == TYCHAR) {
1738: e->leftp->addrblock.vtype = tyint;
1739: Offset = e->leftp->addrblock.memoffset;
1740: e->leftp->addrblock.memoffset =
1741: Offset
1742: ? mkexpr(OPSTAR, Offset, ICON(typesize[tyint]))
1743: : ICON(0);
1744: e->leftp->addrblock.isarray = 1;
1745: }
1746: if (e->rightp && e->rightp->tag == TADDR
1747: && e->rightp->addrblock.vtype == TYCHAR) {
1748: e->rightp->addrblock.vtype = tyint;
1749: Offset = e->rightp->addrblock.memoffset;
1750: e->rightp->addrblock.memoffset =
1751: Offset
1752: ? mkexpr(OPSTAR, Offset, ICON(typesize[tyint]))
1753: : ICON(0);
1754: e->rightp->addrblock.isarray = 1;
1755: }
1756: }
1757:
1758: .
1759: 754a
1760: case OPIDENTITY:
1761: .
1762: 110d
1763: 94a
1764: /* OPASSIGNI 56 */ { BINARY_OP, 2, "%l = &%r" },
1765: /* OPIDENTITY 57 */ { UNARY_OP, 15, "%l" },
1766: .
1767: 27,28c
1768: /* OPEQV 9 */ { BINARY_OP, 9, "%l == %r" },
1769: /* OPNEQV 10 */ { BINARY_OP, 9, "%l != %r" },
1770: .
1771: \Rogue\Monster\
1772: else
1773: echo "will not over write ./output.c.ed"
1774: fi
1775: if `test ! -s ./p1output.c.ed`
1776: then
1777: echo "writting ./p1output.c.ed"
1778: cat > ./p1output.c.ed << '\Rogue\Monster\'
1779: 359a
1780: case OPIDENTITY:
1781: .
1782: 209c
1783: stg, M(STGARG)|M(STGEQUIV)) && addrp->vtype != TYCHAR) {
1784: .
1785: 206c
1786: Lengths are passed by value, so don't check STGLENG
1787: 28-Jun-89 (dmg) Added the check for != TYCHAR
1788: */
1789: .
1790: \Rogue\Monster\
1791: else
1792: echo "will not over write ./p1output.c.ed"
1793: fi
1794: if `test ! -s ./pccdefs.h.ed`
1795: then
1796: echo "writting ./pccdefs.h.ed"
1797: cat > ./pccdefs.h.ed << '\Rogue\Monster\'
1798: 56,64c
1799: #define P2SHORT 3
1800: #define P2INT 4
1801: #define P2LONG 4
1802: .
1803: 1c
1804: /* The following numbers are strange, and implementation-dependent */
1805: .
1806: \Rogue\Monster\
1807: else
1808: echo "will not over write ./pccdefs.h.ed"
1809: fi
1810: if `test ! -s ./proc.c.ed`
1811: then
1812: echo "writting ./proc.c.ed"
1813: cat > ./proc.c.ed << '\Rogue\Monster\'
1814: 1522a
1815: doing_setbound = 0;
1816: .
1817: 1521c
1818: p->basexpr = make_int_expr (fixtype (q));
1819: .
1820: 1491c
1821: p->dims[i].dimexpr = make_int_expr (fixtype (q));
1822: .
1823: 1458a
1824: doing_setbound = 1;
1825: .
1826: 1445a
1827: extern expptr make_int_expr ();
1828: extern int doing_setbound;
1829: .
1830: 1046,1099d
1831: 1003,1007d
1832: 990,993c
1833:
1834: .
1835: 959,964d
1836: 770,773d
1837: 733,761d
1838: 727,731d
1839: 688,691c
1840: (qclass==CLVAR && qstg==STGUNKNOWN) ) {
1841: if (! q -> vis_assigned)
1842: warn1("local variable %s never used",
1843: varstr(VL,q->varname) );
1844: } else if(qclass==CLVAR && qstg==STGBSS) {
1845: .
1846: 658,686d
1847: 597,600d
1848: 565,569d
1849: 536,542d
1850: 519,524d
1851: 451,454d
1852: 439,442d
1853: 404,411d
1854: 402d
1855: 397,399d
1856: 394d
1857: 390,392d
1858: 260,281d
1859: 172,186d
1860: 111,123d
1861: 97d
1862: 87,95d
1863: 41,44d
1864: 18a
1865: char *memname();
1866: .
1867: 4,12d
1868: \Rogue\Monster\
1869: else
1870: echo "will not over write ./proc.c.ed"
1871: fi
1872: if `test ! -s ./put.c.ed`
1873: then
1874: echo "writting ./put.c.ed"
1875: cat > ./put.c.ed << '\Rogue\Monster\'
1876: 85,86c
1877: /* templist = hookup(templist, holdtemps); */
1878: /* holdtemps = NULL; */
1879:
1880: .
1881: 61d
1882: 57,59d
1883: 50c
1884: P2BAD, P2BAD, P2BAD, P2BAD,
1885: 1,1,1,1,1 /* OPNEG1, OPQUESTd, OPCOLONd, OPASSIGNI, OPIDENTITY */
1886: .
1887: 9,15d
1888: 7a
1889: #include "pccdefs.h"
1890: .
1891: \Rogue\Monster\
1892: else
1893: echo "will not over write ./put.c.ed"
1894: fi
1895: if `test ! -s ./putpcc.c.ed`
1896: then
1897: echo "writting ./putpcc.c.ed"
1898: cat > ./putpcc.c.ed << '\Rogue\Monster\'
1899: 1459c
1900: return (expptr) p;
1901: .
1902: 1447c
1903: cp -> datap = (tagptr) addrfix(putx( mkconv(TYLENG,cp->datap)));
1904: .
1905: 1327c
1906: if( ISCHAR(q) &&
1907: (q->headblock.vclass != CLPROC || q->headblock.vstg == STGARG))
1908: .
1909: 1260a
1910: LOCAL expptr
1911: addrfix(e) /* fudge character string length if it's a TADDR */
1912: expptr e;
1913: {
1914: return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
1915: }
1916:
1917: .
1918: 1076c
1919: return (expptr) p;
1920: .
1921: 1070c
1922: return ENULL;
1923: .
1924: 895c
1925: return (Addrp) p;
1926: .
1927: 465a
1928: case OPASSIGNI:
1929: .
1930: 355a
1931: case OPASSIGNI:
1932: case OPIDENTITY:
1933: .
1934: \Rogue\Monster\
1935: else
1936: echo "will not over write ./putpcc.c.ed"
1937: fi
1938: if `test ! -s ./star2s.c.ed`
1939: then
1940: echo "writting ./star2s.c.ed"
1941: cat > ./star2s.c.ed << '\Rogue\Monster\'
1942: 634a
1943:
1944: char *parstate2s (par, pointer)
1945: int par;
1946: char *pointer;
1947: {
1948: static char buff[STATIC_STORE_SIZE];
1949:
1950: if (pointer == NULL)
1951: pointer = buff;
1952:
1953: switch (par) {
1954: case OUTSIDE: strcpy (pointer, "OUTSIDE"); break;
1955: case INSIDE: strcpy (pointer, "INSIDE"); break;
1956: case INDCL: strcpy (pointer, "INDCL"); break;
1957: case INDATA: strcpy (pointer, "INDATA"); break;
1958: case INEXEC: strcpy (pointer, "INEXEC"); break;
1959: default: strcpy (pointer, "Bad parstate '%d'", par);
1960: } /* switch */
1961:
1962: return pointer;
1963: } /* parstate2s */
1964: .
1965: \Rogue\Monster\
1966: else
1967: echo "will not over write ./star2s.c.ed"
1968: fi
1969: if `test ! -s ./star2s.h.ed`
1970: then
1971: echo "writting ./star2s.h.ed"
1972: cat > ./star2s.h.ed << '\Rogue\Monster\'
1973: 3a
1974: char *parstate2s ();
1975: .
1976: \Rogue\Monster\
1977: else
1978: echo "will not over write ./star2s.h.ed"
1979: fi
1980: if `test ! -s ./statics.c.ed`
1981: then
1982: echo "writting ./statics.c.ed"
1983: cat > ./statics.c.ed << '\Rogue\Monster\'
1984: 169a
1985: } /* free_static_inits */
1986: .
1987: 63c
1988: type = biggest_type (val);
1989: val /= typesize[type];
1990: nice_printf (fp, "%s ", c_type_decl (type, 0));
1991: .
1992: 39a
1993: int type;
1994: .
1995: \Rogue\Monster\
1996: else
1997: echo "will not over write ./statics.c.ed"
1998: fi
1999: if `test ! -s ./vax.c.ed`
2000: then
2001: echo "writting ./vax.c.ed"
2002: cat > ./vax.c.ed << '\Rogue\Monster\'
2003: 617,840d
2004: 608d
2005: 603d
2006: 497d
2007: 495c
2008: expptr expr = (expptr) cpexpr (dp -> dims[i].dimexpr);
2009: .
2010: 170d
2011: 144,153d
2012: 140d
2013: 80,87d
2014: 32,33c
2015: #if 1
2016: .
2017: 2,10d
2018: \Rogue\Monster\
2019: else
2020: echo "will not over write ./vax.c.ed"
2021: fi
2022: if `test ! -s ./vaxdefs.h.ed`
2023: then
2024: echo "writting ./vaxdefs.h.ed"
2025: cat > ./vaxdefs.h.ed << '\Rogue\Monster\'
2026: 1,15c
2027: /*#define SDB 1*/
2028: .
2029: \Rogue\Monster\
2030: else
2031: echo "will not over write ./vaxdefs.h.ed"
2032: fi
2033: if `test ! -s ./FINAL_NOTES`
2034: then
2035: echo "writting ./FINAL_NOTES"
2036: cat > ./FINAL_NOTES << '\Rogue\Monster\'
2037: NOTES AS I PREPARE TO LEAVE NAG ON JUNE 30
2038: ----------------------------------------------------------------------
2039:
2040: /user/mark/bin/f2c - translator before I merged the IO stuff
2041: -- source in /user/mark/f2c/hold
2042: /user/mark/bin/f2cio - Dave Gay's version, as of June 28
2043: -- source in /user/mark/update_f2c/new
2044: /user/mark/f2c/f2c - translator with I/O and bugs
2045: -- source in /user/mark/f2c
2046:
2047: (null)com_ bug -- grep for "null" in all source files, I think
2048: the only one is in star2s.c, stg2s(). Set a breakpoint there, run the
2049: translator and look at the stack trace.
2050:
2051: common array init bug -- look at the differences between an
2052: earlier version and the current version. First run the earlier
2053: version to see if it gets it right (it should).
2054:
2055: other bugs -- look at the file /user/mark/mail/dave. These
2056: are the email messages I've exchanged with David Gay
2057: (cbs%uk.ac.nsfnet-relay::com.att.research::dmg). I've incorporated
2058: most of his bug fixes except for the last ones (which 1. increase the
2059: default sizee of the statement function table and 2. fix a problem
2060: with a "too many initializers" error message). There's nothing too
2061: personal in there, I hope!
2062:
2063: Look in my .login for the c and h aliases. Most useful at
2064: searching the right files, avoiding gram.c (yacc output) and gram.o,
2065: but looking at the 5 grammar source files.
2066:
2067: I want to send Dave Gay my whole directory tree, if possible.
2068: PLEASE delete the .o's, files ending in ~, and the executables (look
2069: in /user/mark/bin for some more of these) before tar(1)ing these. If
2070: that's not possible, just /user/mark/f2c subtree. If THAT's not
2071: possible, just the /user/mark/f2c directory by itself.
2072:
2073: I also want to email him the diff -e between /user/mark/f2c
2074: source files and /user/mark/update_f2c/original_f2c source files. You
2075: can find a list of all relevant source files in the file
2076: /user/mark/f2c/myfiles.
2077: \Rogue\Monster\
2078: else
2079: echo "will not over write ./FINAL_NOTES"
2080: fi
2081: echo "Finished archive 1 of 1"
2082: exit
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.