Commit | Line | Data |
---|---|---|
b21e4053 | 1 | /* |
161423a6 RE |
2 | * Copyright (c) 1980 Regents of the University of California. |
3 | * All rights reserved. The Berkeley software License Agreement | |
4 | * specifies the terms and conditions for redistribution. | |
b21e4053 | 5 | * |
f10a0ae9 | 6 | * @(#)dofio.c 5.2 %G% |
161423a6 RE |
7 | */ |
8 | ||
9 | /* | |
b21e4053 DW |
10 | * fortran format executer |
11 | */ | |
12 | ||
13 | #include "fio.h" | |
43666f58 | 14 | #include "format.h" |
b21e4053 DW |
15 | |
16 | #define DO(x) if(n=x) err(n>0?errflag:endflag,n,dfio) | |
a7aa6d87 DL |
17 | #define DO_F(x) if(n=x) err_f(n>0?errflag:endflag,n,dfio) |
18 | #define err_f(f,n,s) {if(f) return(dof_err(n)); else fatal(n,s);} | |
b21e4053 | 19 | #define STKSZ 10 |
5e52dbf7 DL |
20 | LOCAL int cnt[STKSZ],ret[STKSZ],cp,rp; |
21 | LOCAL char *dfio = "dofio"; | |
65c2c568 | 22 | int used_data; |
b21e4053 DW |
23 | |
24 | en_fio() | |
25 | { ftnint one=1; | |
c8c7f341 | 26 | return(do_fio(&one,NULL,0L)); |
b21e4053 DW |
27 | } |
28 | ||
2679f7ac DL |
29 | /* OP_TYPE_TAB is defined in format.h, |
30 | it is NED for X,SLASH,APOS,H,TL,TR,T | |
31 | ED for I,IM,F,E,EE,D,DE,G,GE,L,A,AW | |
32 | and returns op for other values | |
33 | */ | |
f10a0ae9 | 34 | LOCAL int optypes[] = OP_TYPE_TAB; |
5e52dbf7 | 35 | LOCAL int rep_count, in_mid; |
29b60297 | 36 | |
b21e4053 DW |
37 | do_fio(number,ptr,len) ftnint *number; ftnlen len; char *ptr; |
38 | { struct syl *p; | |
2679f7ac | 39 | int n,i,more,optype; |
b21e4053 | 40 | more = *number; |
2679f7ac DL |
41 | for(;;) { |
42 | if( (optype = ((p= &syl_ptr[pc])->op)) > LAST_TERM ) | |
a7aa6d87 | 43 | err_f(errflag,F_ERFMT,"impossible code"); |
2679f7ac DL |
44 | #ifdef DEBUG |
45 | fprintf(stderr," pc=%d, cnt[%d]=%d, ret[%d]=%d, op=%d\n", | |
46 | pc,cp,cnt[cp],rp,ret[rp],optype); /*for debug*/ | |
47 | #endif | |
48 | switch(optypes[optype]) | |
49 | { | |
50 | case NED: | |
a7aa6d87 | 51 | DO_F((*doned)(p,ptr)) |
b21e4053 DW |
52 | pc++; |
53 | break; | |
2679f7ac | 54 | case ED: |
29b60297 DL |
55 | if(in_mid == NO) rep_count = p->rpcnt; |
56 | in_mid = YES; | |
57 | while (rep_count > 0 ) { | |
58 | if(ptr==NULL) | |
59 | { DO((*doend)('\n')) | |
b21e4053 | 60 | return(OK); |
29b60297 DL |
61 | } |
62 | if(!more) return(OK); | |
65c2c568 | 63 | used_data = YES; |
a7aa6d87 | 64 | DO_F((*doed)(p,ptr,len)) |
29b60297 DL |
65 | ptr += len; |
66 | more--; | |
67 | rep_count--; | |
b21e4053 | 68 | } |
29b60297 DL |
69 | pc++; |
70 | in_mid = NO; | |
b21e4053 | 71 | break; |
2679f7ac | 72 | case STACK: /* repeat count */ |
a7aa6d87 | 73 | if(++cp==STKSZ) err_f(errflag,F_ERFMT,"too many nested ()") |
b21e4053 DW |
74 | cnt[cp]=p->p1; |
75 | pc++; | |
76 | break; | |
2679f7ac | 77 | case RET: /* open paren */ |
a7aa6d87 | 78 | if(++rp==STKSZ) err_f(errflag,F_ERFMT,"too many nested ()") |
b21e4053 DW |
79 | ret[rp]=p->p1; |
80 | pc++; | |
81 | break; | |
2679f7ac | 82 | case GOTO: /* close paren */ |
b21e4053 DW |
83 | if(--cnt[cp]<=0) |
84 | { cp--; | |
85 | rp--; | |
86 | pc++; | |
87 | } | |
88 | else pc = ret[rp--] + 1; | |
89 | break; | |
2679f7ac | 90 | case REVERT: /* end of format */ |
b21e4053 DW |
91 | if(ptr==NULL) |
92 | { DO((*doend)('\n')) | |
93 | return(OK); | |
94 | } | |
95 | if(!more) return(OK); | |
a7aa6d87 | 96 | if( used_data == NO ) err_f(errflag,F_ERFMT,"\nNo more editing terms in format"); |
65c2c568 | 97 | used_data = NO; |
b21e4053 DW |
98 | rp=cp=0; |
99 | pc = p->p1; | |
100 | DO((*dorevert)()) | |
101 | break; | |
2679f7ac | 102 | case COLON: |
b21e4053 | 103 | #ifndef KOSHER |
2679f7ac | 104 | case DOLAR: /*** NOT STANDARD FORTRAN ***/ |
b21e4053 DW |
105 | #endif |
106 | if (ptr == NULL) | |
107 | { DO((*doend)((char)p->p1)) | |
108 | return(OK); | |
109 | } | |
110 | if (!more) return(OK); | |
111 | pc++; | |
112 | break; | |
113 | #ifndef KOSHER | |
2679f7ac | 114 | case SU: /*** NOT STANDARD FORTRAN ***/ |
b21e4053 | 115 | #endif |
2679f7ac DL |
116 | case SS: |
117 | case SP: | |
118 | case S: cplus = p->p1; | |
b21e4053 DW |
119 | signit = p->p2; |
120 | pc++; | |
121 | break; | |
2679f7ac | 122 | case P: |
b21e4053 DW |
123 | scale = p->p1; |
124 | pc++; | |
125 | break; | |
126 | #ifndef KOSHER | |
2679f7ac | 127 | case R: /*** NOT STANDARD FORTRAN ***/ |
b21e4053 DW |
128 | radix = p->p1; |
129 | pc++; | |
130 | break; | |
2679f7ac | 131 | case B: /*** NOT STANDARD FORTRAN ***/ |
e20e9e79 DW |
132 | if (external) cblank = curunit->ublnk; |
133 | else cblank = 0; /* blank = 'NULL' */ | |
134 | pc++; | |
135 | break; | |
b21e4053 | 136 | #endif |
2679f7ac | 137 | case BNZ: |
b21e4053 DW |
138 | cblank = p->p1; |
139 | pc++; | |
140 | break; | |
2679f7ac | 141 | default: |
a7aa6d87 | 142 | err_f(errflag,F_ERFMT,"impossible code") |
2679f7ac | 143 | } |
b21e4053 DW |
144 | } |
145 | } | |
146 | ||
147 | fmt_bg() | |
148 | { | |
29b60297 | 149 | in_mid = NO; |
b21e4053 DW |
150 | cp=rp=pc=cursor=0; |
151 | cnt[0]=ret[0]=0; | |
65c2c568 | 152 | used_data = NO; |
b21e4053 | 153 | } |
a7aa6d87 | 154 | |
5e52dbf7 | 155 | LOCAL |
a7aa6d87 DL |
156 | dof_err(n) |
157 | { | |
158 | if( reading==YES && external==YES && sequential==YES) donewrec(); | |
159 | return(errno=n); | |
160 | } |