! "W N D=    @ #D  D ҃RR \ B ы e@W 0 , & 7    " 7 -  X e5PߋRTV`RߋR RT `Re `R7 t*p ȋ@E A Ze   ?    7? eE./c01.c^ \?i./c02.c+^ iO[./c03.c?^ ve./c04.cv&^ ~pF./c05.c-^ p./c0h.cG] ./c10.c/^ ./c11.c ^ l./c12.c^ ./c14.cS ] Ŕ./c15.c,] ./pr1.c}$] aO./pr2.c@] ./c00.c)^ M./prh.co]  ./regtab.t"] - :./#clenf.cf]  ./#gtargs.cO] !./#rel.c-] $./access.c] %~./calloc.c] (N./cclose.cq] *./cexit.c] +C$./cflush.c] ,9z./cfree.c] -a&./cgate.c] ../cgetc.c:] /./clenf.cf] 1./copen.c] 2-./cputc.c] 5 ./cread.c] 8;./cstop.ASM] 90./cwrite.c] :Jw./defnam.c_] ;}./ermsg.cf] < ./ftoa.c] =./gcell.c] A#./genreg.c] B./getargih.c] C}#./getargs.cO] F ./getchar.c3] I-./getmain.c] J./gets.c] K./hodum.c-] L./inout.ASM] M./iodef.c{] N_./macgho.ASM ] ON./macros.ASM, ] Vz@./nargs.c] ])./printf.c] ^n./putchar.c8] c./rrio.ASMfW] dJ./scanf.c0] W./ungetc.c] ./memoj] *o./cctab.t] ../newcv.c ] .` ./CONTENTSa # /* C compiler (file - c01.c) Copyright 1972 Bell Telephone Laboratories, Inc. */ #include "c0h.c" int mainftn; int mainfile; char pointrel[] { LESSEQP, LESSP, GREATQP, GREATP }; build(op) { register int t1; int t2, t; struct tnode *disarray(); register struct tnode *p1, *p2; int dope, leftc, cvn, pcvn; if (op==LBRACK) { build(PLUS); op = STAR; } if( op==INCAFT||op==DECAFT||op==INCBEF||op==DECBEF) *cp++ = block( 1, CON, INT, 0, 1 ); dope = opdope[op]; if ((dope&BINARY)!=0) { p2 = chkfun(disarray(*--cp)); t2 = p2->type; } p1 = *--cp; if (op == SIZEOF) { t1=length(p1); p1->op=CON; p1->type=INT; p1->dimp=0; p1->value=t1; *cp++ = p1; return; } if (op!=AMPER) { p1 = disarray(p1); if (op!=CALL) p1 = chkfun(p1); } t1 = p1->type; pcvn = 0; switch (op) { /* end of expression */ case 0: *cp++ = p1; return; /* no-conversion operators */ case COMMA: case LOGAND: case LOGOR: *cp++ = block(2, op, 0, 0, p1, p2); return; case QUEST: if (p2->op!=COLON) error("Illegal conditional"); t = t2; goto nocv; case CALL: if ((t1&030) != FUNC) error("Call of non-function"); *cp++ = block(2,CALL,decref(t1),p1->dimp,p1,p2); return; case STAR: if (p1->op==AMPER) { *cp++ = p1->tr1; return; } if ((t1&030) == FUNC) error("Illegal indirection"); *cp++ = block(1,STAR,decref(t1),p1->dimp,p1); return; case AMPER: if (p1->op==STAR) { p1->tr1->dimp = p1->dimp; p1->tr1->type = incref(t1); *cp++ = p1->tr1; return; } if (p1->op==NAME) { *cp++ = block(1,op,incref(t1),p1->dimp,p1); return; } error("Illegal lvalue"); break; case INCBEF: case DECBEF: case INCAFT: case DECAFT: chklval(p1); if( op==INCBEF) op=ASPLUS; if( op==DECBEF ) op=ASMINUS; break; case ARROW: *cp++ = p1; chkw(p1); p1->type = PTR+STRUCT; build(STAR); p1 = *--cp; case DOT: if (p2->op!=NAME || p2->class!=MOS) error("Illegal structure ref"); *cp++ = p1; t = t2; if ((t&030) == ARRAY) { t = decref(t); p2->ssp++; } setype(p1, t, p2->dimp); build(AMPER); *cp++ = block(1,CON,7,0,p2->nloc); build(PLUS); if ((t2&030) != ARRAY) build(STAR); return; } if ((dope&LVALUE)!=0) chklval(p1); if ((dope&LWORD)!=0) chkw(p1); if ((dope&RWORD)!=0) chkw(p2); if ((dope&BINARY)==0) { if (!fold(op, p1, 0)) *cp++ = block(1,op,t1,p1->dimp,p1); return; } if (t2==7) { t = t1; p2->type = 0; /* no int cv for struct */ t2 = 0; goto nocv; } cvn = cvtab[11*lintyp(t1)+lintyp(t2)]; leftc = cvn&0100; cvn = cvn&077; t = leftc? t2:t1; if (op==ASSIGN ) { t = t1; if (cvn!=3) /* i=p and p=i */ goto nocv; } if (cvn ) { if (op==COLON && t1>=PTR && t1==t2) goto nocv; if (cvn==077) { if ((dope&RELAT)==0 || t1float */ leftc = 0; cvn = 4; t = t1; goto rcvt; } else goto illcv; } p1 = convert(p1, t, cvn, plength(p2)); } else { rcvt: p2 = convert(p2, t, cvn, plength(p1)); } nocv:; } if ((dope&RELAT)!=0) { if (op>NEQUAL && (t1>=PTR || t2>=PTR)) op = pointrel[op - LESSEQ]; /* ptr relation */ t = 0; /* relational is integer */ } if (fold(op, p1, p2)) return; *cp++ = block(2,op,t,(p1->dimp==0? p2:p1)->dimp,p1,p2); if (pcvn) { p1 = *--cp; *cp++ = convert(p1, 0, pcvn, plength(p1->tr1)); } } convert(p, t, cvn, len) struct tnode *p; { register int n; switch(cvn) { /* int -> ptr */ case 1: n = TIMES; goto md; /* ptr -> int */ case 2: n = DIVIDE; md: return(block(2, n, t, 0, p, block(1, CON, 0, 0, len))); /* int -> double */ case 3: n = ITOF; goto di; /* double -> int */ case 4: n = FTOI; di: return(block(1, n, t, 0, p)); } error("C error-- convert"); return(p); } setype(ap, at, adimptr) struct tnode *ap; { register struct tnode *p; register t, dimptr; p = ap; t = at; dimptr = adimptr; p->type = t; if (dimptr != -1) p->dimp = dimptr; switch(p->op) { case AMPER: setype(p->tr1, decref(t), dimptr); return; case STAR: setype(p->tr1, incref(t), dimptr); return; case PLUS: case MINUS: setype(p->tr1, t, dimptr); } } chkfun(ap) /* Is current node a ftn? if so, convert it to a pointer. */ struct tnode *ap; { register struct tnode *p; register int t; p = ap; if (((t = p->type)&030)==FUNC) return(block(1,AMPER,incref(t),p->dimp,p)); return(p); } struct tnode *disarray(ap) /* Turns arrays into pointers. */ struct tnode *ap; { register int t; register struct tnode *p; p = ap; /* check array & not MOS */ if (((t = p->type)&030)!=ARRAY || p->op==NAME&&p->class==MOS) return(p); p->ssp++; *cp++ = p; setype(p, decref(t), -1); build(AMPER); return(*--cp); } chkw(p) struct tnode *p; { register int t; if ((t=p->type)>CHAR && top!=NAME && p->op!=STAR) error("Lvalue required"); } fold(op, ap1, ap2) struct tnode *ap1, *ap2; { register struct tnode *p1; register int v1, v2; p1 = ap1; if (p1->op!=CON || (ap2!=0 && ap2->op!=CON)) return(0); v1 = p1->value; v2 = ap2->value; switch (op) { case PLUS: v1 =+ v2; break; case MINUS: v1 =- v2; break; case TIMES: v1 = v1 * v2; break; case DIVIDE: v1 = v1 / v2; break; case MOD: v1 = v1 % v2; break; case AND: v1 =& v2; break; case OR: v1 =| v2; break; case EXOR: v1 =^ v2; break; case NEG: v1 = - v1; break; case COMPL: v1 = ~ v1; break; case LSHIFT: v1 = v1 << v2; break; case RSHIFT: v1 = v1 >> v2; break; default: return(0); } p1->value = v1; *cp++ = p1; return(1); } conexp() { register struct tnode *t; initflg++; if (t = tree()) if (t->op != CON) error("Constant required"); initflg--; return(t->value); } transvec() { /* Print out the transfer vector. */ register struct hshtab *cs; hgprloc(hgtvec); for (cs = hshtab; cs < hshtab+hshsiz; cs++) { if (((cs->hflags&GLOBAL) == GLOBAL) && (cs -> hclass != KEYWC)) { if ((cs->hflags & DEFINED) == DEFINED) { { if (scomp(cs->name, "main") != '=') printf(" entry %.8s \n", cs->name); } if (function == YES) printf("@%.7s INT%s %.8s\n",cs->name, (cs->htype&030)==FUNC?"FUNC":"ADDR", cs->name ); } else { if (function == YES) printf("@%.7s EXT%s %.8s\n",cs->name, (cs->htype&030)==FUNC?"FUNC":"ADDR", cs->name ); else printf(" extrn %.8s\n", cs->name); } } } hgprloc(hgcode); } mainchk(cs) /* If a ftn is 'main' then print special BAL. */ char *cs; { int i; for (i=0; i<=4; i =+ 1) { if ("main"[i] == *(cs++) ) ; else{mainftn = NO; return;} } hgprloc(hglit); printf(" ltorg\n"); hgprloc(hgmain); printf("$main$ equ *\n"); printf(" subsave\n"); printf(" runmain\n"); printf(" subretrn cc=00\n ltorg\n"); printf(" stackdo\n"); hgprloc(hgcode); mainftn = mainfile = YES; } scomp(s1, s2) char *s1, *s2; { int c,d; while ( (c= *s1++) == (d= *s2++)) if (c==0) return('='); return(c>d ? '>' : '<'); } 'main' then print special BAL. */ char *cs; { int i; for (i=0; i<=4; i =+ 1) { if ("main"[i] == *(cs++) ) ; else{mainftn = NO; return;} } hgprloc(hglit); printf(" ltorg\n"); hgprloc(hgmain); printf("$main$ equ *\n"); printf(" subsave\n"); printf(" runmain\n"); printf(" subretrn cc=00\n ltorg\n"); printf(" stackdo\n"); hgprl# /* C compiler ( file - c02.c ) Copyright 1972 Bell Telephone Laboratories, Inc. */ #include "c0h.c" /* */ extdef() { register o, width; int type, elsize, nel; char *cs; register struct hshtab *ds; if(((o=symbol())==EOF) || o==SEMI) return; type = 0; xdflg++; xtern = NO; ftern = NO; xxx: if (o==KEYW) { if (cval==EXTERN) { xtern = YES; o = symbol(); goto xxx; } if (cval==FORTRAN) { ftern = YES; o = symbol(); goto xxx; } if ((type=cval)>STRUCT) goto syntax; /* not type */ elsize = 0; if (type==STRUCT) { elsize = strdec(&type, 0); if ((peeksym=symbol())!=KEYW) { blkhed(); } } } else { if (o!=NAME) goto syntax; peeksym = o; } do { defsym = 0; strflg = 1; endp = YES; decl1(xtern==YES?GXTERN:(ftern==YES?FORTRAN:EXTERN), type&07, 0, elsize, NO); /* (this also sets ndp) */ if ((ds=defsym)==0) return; cs = ds->name; funcsym = ds; ds -> hflags =| GLOBAL; /* flag global */ xdflg = 0; type = ds->type; if ((type&030)==FUNC && ((peeksym=symbol())==LBRACE || peeksym==KEYW)) { mainchk(cs); /* add extra BAL code for main functions. */ ds -> hflags =| DEFINED; /* set defined flag. */ ds->hflags =| PERM; /* nondeletable */ cfunc(cs, ndp); /* This is the only call of cfunc. */ return; } if ((xtern == NO)&&(ftern == NO)) ds->hflags =| DEFINED; ds->hflags =| PERM; /* non-deletable */ nel = 1; while ((ds->type&030)==ARRAY) { nel = dimtab[ds->ssp]; ds->type = decref(ds->type); } width = length(ds); if (ds->type==STRUCT) { nel = nel * width/4; width = 4; } ds->type = type; cinit(cs, type, nel, width); hgprloc(hgcode); } while ((o=symbol())==COMMA); if (o==SEMI) return; syntax: if (o == RBRACE) { error("Too many }'s"); return; } error("External definition syntax"); errflush(o); statement(0); } cfunc(cs, np) /* Compile a function. */ char *cs; int np; { register savdimp; regvar = 1; strflg = 0; function = YES; savdimp = dimp; declist(ARG); retlab = isn++; statement(1, cs); printf("$%d EPILOG %d,%d\n", retlab, np, autolen); /* autolen contains the total length of the automatics and temps */ printf(" DC C'END %.8s' \n", cs); dimp = savdimp; } cinit(cs, type, nel, awidth) char *cs; { register o, ninit, width; hgprloc(hgdata); width = awidth; if ((peeksym=symbol())==COMMA || peeksym==SEMI) { if (xtern == NO && ftern == NO) { printf("%.8s dc %dx'00' \n", cs, (nel*width+3)&~03); } /* Allocate storage only in multiples of four bytes. */ return; } ninit = 0; if (xtern == YES) error("Can not initialize externals."); if(width==8 || width==4) printf(" cnop 0,%d\n",width); printf("%.8s equ * \n", cs); if ((o=symbol())==LBRACE) { do ninit = cinit1( width, ninit); while ((o=symbol())==COMMA); if (o!=RBRACE) peeksym = o; } else { peeksym = o; ninit = cinit1( width, 0); } if (ninit1 && (type&030)!=ARRAY && (type&07)!=STRUCT) error("Too many initializers"); printf(" cnop 0,4 \n"); } cinit1( width, ninit) { register struct tnode *s; register int sign; sign = 1; if ((peeksym=symbol())==STRING ) { peeksym = -1; if( width == 4 ){ hgprloc( hgistring ); getstr(); hgprloc( hgdata ); printf( " dc a($%d)\n", cval ); return(1); } getstr(); return(nchstr); } if (peeksym==RBRACE) return(ninit); initflg++; s = tree(); hgprloc(hgdata); initflg = 0; switch(width) { case 1: rcexpr0(block(1,INIB,0,0,s), regtab); break; case 4: if (s->op != FCON) { rcexpr0(block(1,INIT,0,0,s), regtab); break; } case 8: if (s->op==FCON) { if(peeksym==MINUS) { peeksym = -1; sign = -sign;} prtflo(sign,width); break; } default: bxdec(); } return(++ninit); } bxdec() { error("Inconsistent external initialization"); } statement(d, cs) char *cs; { register o, o1, o2; int o3; struct tnode *np; stmt: switch(o=symbol()) { case EOF: error("Unexpected EOF"); case SEMI: return; case LBRACE: if(d) { if (proflg) error("The profiler is not supported on IBM C."); hgprloc(hgcode); printf("%.8s PROLOG %d \n", cs, ndp); blkhed(); } while (!eof) { if ((o=symbol())==RBRACE) return; peeksym = o; statement(0); } error("Missing '}'"); return; case KEYW: switch(cval) { case GOTO: if (o1 = simplegoto()) branch(o1); else dogoto(); goto semi; case ASM: if(doasm()<0) goto syntax; goto semi; case RETURN: doret(); goto semi; case IF: np = pexpr(); o2 = 0; if ((o1=symbol())==KEYW) switch (cval) { case GOTO: if (o2=simplegoto()) goto simpif; cbrnch0(np, o2=isn++, 0); dogoto(); label(o2); goto hardif; case RETURN: if (nextchar()==';') { o2 = retlab; goto simpif; } cbrnch0(np, o1=isn++, 0); doret(); label(o1); o2++; goto hardif; case BREAK: o2 = brklab; goto simpif; case CONTIN: o2 = contlab; simpif: chconbrk(o2); cbrnch0(np, o2, 1); hardif: if ((o=symbol())!=SEMI) goto syntax; if ((o1=symbol())==KEYW && cval==ELSE) goto stmt; peeksym = o1; return; } peeksym = o1; cbrnch0(np, o1=isn++, 0); statement(0); if ((o=symbol())==KEYW && cval==ELSE) { o2 = isn++; branch(o2); label(o1); statement(0); label(o2); return; } peeksym = o; label(o1); return; case WHILE: o1 = contlab; o2 = brklab; label(contlab = isn++); cbrnch0(pexpr(), brklab=isn++, 0); statement(0); branch(contlab); label(brklab); contlab = o1; brklab = o2; return; case BREAK: chconbrk(brklab); branch(brklab); goto semi; case CONTIN: chconbrk(contlab); branch(contlab); goto semi; case DO: o1 = contlab; o2 = brklab; contlab = isn++; brklab = isn++; label(o3 = isn++); statement(0); label(contlab); contlab = o1; if ((o=symbol())==KEYW && cval==WHILE) { cbrnch0(tree(), o3, 1); label(brklab); brklab = o2; goto semi; } goto syntax; case CASE: o1 = conexp(); if ((o=symbol())!=COLON) goto syntax; if (swp==0) { error("Case not in switch"); goto stmt; } if(swp>=swtab+swsiz) { error("Switch table overflow"); } else { swp->swlab = isn; (swp++)->swval = o1; label(isn++); } goto stmt; case SWITCH: o1 = brklab; brklab = isn++; np = pexpr(); chkw(np); rcexpr0(block(1,RFORCE,0,0,np), regtab); pswtch0(); brklab = o1; return; case DEFAULT: if (swp==0) error("Default not in switch"); if ((o=symbol())!=COLON) goto syntax; label(deflab = isn++); goto stmt; case FOR: o1 = contlab; o2 = brklab; contlab = isn++; brklab = isn++; if (o=forstmt()) goto syntax; label(brklab); contlab = o1; brklab = o2; return; } error("Unknown keyword = %o",cval); goto syntax; case NAME: if (nextchar()==':') { peekc = 0; o1 = csym; if (o1->hclass>0) { error("Redefinition"); goto stmt; } o1->hclass = STATIC; o1->htype = ARRAY; if (o1->hoffset==0) o1->hoffset = isn++; label(o1->hoffset); if ((peeksym=symbol())==RBRACE) return; goto stmt; } } peeksym = o; rcexpr0(tree(), efftab); semi: if ((o=symbol())==SEMI) return; syntax: error("Statement syntax"); errflush(o); return; } blkhed() { register pl; register struct hshtab *cs; autolen = hgreglen + ndp*4; /* Save 16 registers and declared parameters. */ declist(0); pl = 0; while(paraml) { parame->hoffset = 0; cs = paraml; paraml = paraml->hoffset; if (cs->htype==FLOAT) cs->htype = DOUBLE; cs->hoffset = pl; cs->hclass = AUTO; if ((cs->htype&030) == ARRAY) { cs->htype =- 020; /* set ptr */ cs->ssp++; /* pop dims */ } if (cs->htype == CHAR) cs->htype = INT; pl =+ rlength(cs); } for (cs=hshtab; csname[0] == '\0') continue; /* check tagged structure */ if (cs->hclass>KEYWC && (cs->htype&07)==RSTRUCT) { cs->lenp = dimtab[cs->lenp]->lenp; cs->htype = cs->htype&~07 | STRUCT; } if (cs->hclass == STRTAG && dimtab[cs->lenp]==0) error("Undefined structure: %.8s", cs->name); if (cs->hclass == ARG) error("Not an argument: %.8s", cs->name); } osleft = ossiz; space = treebase; return(autolen); } blkend() { register struct hshtab *cs; for (cs=hshtab; csname[0]) { if ((cs->hflags & DELETED) == 0) { if (cs->hclass==0) error("%.8s undefined", cs->name); if((cs->hflags&PERM)==0) { cs->hflags =| DELETED; /* delete nonglobal items from the symbol table. */ hshused--; } } } } } errflush(ao) { register o; o = ao; while(o>RBRACE) /* ; { } */ o = symbol(); peeksym = o; } declist(skwd) { int o, elsize, ndec; register offset, tkw, skw; offset = 0; loop: ndec = 0; tkw = -1; skw = skwd; elsize = 0; while ((o=symbol())==KEYW) switch(cval) { case AUTO: case STATIC: case EXTERN: case GXTERN: case FORTRAN: case REG: if (skw) error("Conflict in storage class"); skw = cval; ndec++; if (tkw<0) continue; goto list; case STRUCT: o = cval; elsize = strdec(&o, skw==MOS); cval = o; case INT: case CHAR: case FLOAT: case DOUBLE: ndec++; if (tkw>=0) error("Type clash"); tkw = cval; if (skw==0) continue; goto list; default: goto brk1; } brk1: peeksym = o; if (ndec==0) return(offset); list: if (tkw<0) tkw = INT; if (skw==0) skw = AUTO; offset = declare(skw, tkw, offset, elsize); goto loop; } strdec(tkwp, mosf) int *tkwp; { register elsize, o; register struct hshtab *ssym; struct hshtab *ds; mosflg = 1; ssym = 0; if ((o=symbol())==NAME) { ssym = csym; if (ssym->hclass==0) { ssym->hclass = STRTAG; ssym->lenp = dimp; dimtab[dimp++] = 0; } if (ssym->hclass != STRTAG) redec(); mosflg = mosf; o = symbol(); } mosflg = 0; if (o != LBRACE) { if (ssym==0) { syntax: decsyn(o); return(0); } if (ssym->hclass!=STRTAG) error("Bad structure name"); if ((elsize = dimtab[ssym->lenp])==0) { *tkwp = RSTRUCT; elsize = ssym; } peeksym = o; } else { ds = defsym; mosflg = 0; elsize = declist(MOS); elsize = (elsize+03) & ~03; /* round to multiple of 4. */ defsym = ds; if ((o = symbol()) != RBRACE) goto syntax; if (ssym) { if (dimtab[ssym->lenp]) error("%.8s redeclared", ssym->name); dimtab[ssym->lenp] = elsize; } } return(elsize); } prtflo(sign,init) /*print floating point value */ { /* sign is +1 for +, -1 for - */ /* init is 0 for execution constants, non-zero for initialization: */ /* 4 for single precision, 8 for double precision */ if (!init) hgprloc(hgdata); printf("$%d dc ",cval=isn++); if (init == hgfloatsz) /* double precision */ printf("d'"); else /* single precision */ printf("d'"); if(sign<0) printf("-"); printf(fcval,'e'); printf("'\n"); if (!init) hgprloc(hgcode); } } } return(elsize); } prtflo(sign,init) /*print floating point value */ { /* sign is +1 for # /* C compiler (file c03.c) Copyright 1972 Bell Telephone Laboratories, Inc. */ #include "c0h.c" #define forsps 150 forstmt() { int l, savxpr[forsps]; int *st, *ss; register int *sp1, *sp2, o; if ((o=symbol()) != LPARN) return(o); if ((o=symbol()) != SEMI) { /* init part */ peeksym = o; rcexpr0(tree(), efftab); if ((o=symbol()) != SEMI) return(o); } label(contlab); if ((o=symbol()) != SEMI) { /* test part */ peeksym = o; rcexpr0(block(1,CBRANCH,tree(),brklab,0), cctab); if ((o=symbol()) != SEMI) return(o); } if ((peeksym=symbol()) == RPARN) { /* incr part */ peeksym = -1; statement(0); branch(contlab); return(0); } l = contlab; contlab = isn++; st = tree(); if ((o=symbol()) != RPARN) return(o); ss = space; if (space-treebase > forsps) { error("Expression too large"); space = &treebase[forsps]; } sp2 = savxpr; for (sp1=treebase; sp1>2) & ~07 | t&07); } incref(t) /* given type int, returns type pointer to int. */ { return((t<<2)&~034 | (t&07) | PTR); } /* Given a tree labeled true or false, it */ cbrnch0(tree, lbl, cond) /* generates conditional transfers to a tree label */ struct tnode *tree; /* depending on logic value.*/ { rcexpr0(block(1,CBRANCH,tree,lbl,cond),cctab); } rcexpr0(tree, table) /* Call functions that will evaluate an expression. */ struct table *table; struct tnode *tree; { if (tree == 0) return; tree = optim(tree); nstack = 0; rcexpr(tree, table, lowreg); } branch(lab) { /* Put out a branch instruction. */ printf(" B $%d \n", lab); } label(l) { /* Puts out a label. */ printf("$%d equ * \n", l); } plength(ap) /* Arguement is a node containing a pointer. */ struct tname *ap; /* Plength is length of thing pointed to. */ { register t, l; register struct tname *p; p = ap; if (((t=p->ntype)&~07) == 0) /* not a reference */ return(1); p->ntype = decref(t); l = length(p); p->ntype = t; return(l); } length(acs) /* length in bytes of a thing. */ struct tnode *acs; { register t, n; register struct tnode *cs; cs = acs; t = cs->type; n = 1; while ((t&030) == ARRAY) { t = decref(t); n = dimtab[cs->ssp]; } if ((t&~07)==FUNC) return(0); if (t>=PTR) return(4*n); switch(t&07) { case INT: return(4*n); case CHAR: return(n); case FLOAT: return(4*n); case DOUBLE: return(8*n); case STRUCT: return(n * dimtab[cs->lenp]); case RSTRUCT: error("Bad structure"); return(0); } error("Compiler error (length)"); return(0); } rlength(cs) /* same, but does rounding - allignment required. */ struct tnode *cs; { return((length(cs) + 03) & ~03); /* round up to multiple of four. */ } simplegoto() { register struct hshtab *csp; if ((peeksym=symbol())==NAME && nextchar()==';') { csp = csym; if (csp->hclass==0 && csp->htype==0) { csp->htype = ARRAY; if (csp->hoffset==0) csp->hoffset = isn++; } if ((csp->hclass==0||csp->hclass==STATIC) && csp->htype==ARRAY) { peeksym = -1; return(csp->hoffset); } } return(0); } nextchar() /* Peek ahead, but skip over spaces. */ { while (getctab(peekc)==SPACE) peekc = getchar(); return(peekc); } chconbrk(l) /* check continue and break */ { if (l==0) error("Break/continue error"); } dogoto() /* does the jump in general goto case. */ { register struct tnode *np; *cp++ = tree(); build(STAR); chkw(np = *--cp); rcexpr0(block(1,JUMP,0,0,np), regtab); } doret() /* Perform a RETURN statement. */ { if (nextchar() != ';') rcexpr0(block(1, RFORCE, 0, 0, tree()), regtab); branch(retlab); } doasm() /* Process Assembly Language Window (ASM) */ /* asm("....."); is format, where text inside"-s is laid down exactly as is. */ { char a; if(symbol() != LPARN) goto asmerr ; if(getchar() != '"') goto asmerr ; while ((a=getchar()) != '"') {putchar(a); } printf("\n"); if(getchar() != ')') goto asmerr; return(0); asmerr: error("asm delimiter error"); return(-1); } hgprloc(hglocval) int hglocval; { if (hglocval == hgcurloc) return; switch (hglocval) { case hgmain: { printf(" mainloc\n"); break; } case hgcode: { printf(" codeloc\n"); break; } case hgdata: { printf(" dataloc\n"); break; } case hgstring: { printf(" strgloc\n"); break; } case hgtvec: { printf(" tvecloc\n"); break; } case hglit: { printf(" litloc\n"); break; } case hgistring: { printf( " istrloc\n" ); break; } default: error("Illegal loctr value"); } hgcurloc = hglocval; return; } loc) return; switch (hglocval) { case hgmain: { printf(" mainloc\n"); break; } case hgcode: { printf(" codeloc\n"); break; } case hgdata: { printf(" dataloc\n"); br# #include "c0h.c" /* * info on operators: * 01-- is binary operator * 02-- left (or only) operand must be lvalue * 04-- is relational operator * 010-- is assignment-type operator * 020-- non-float req. on left * 040-- non-float req. on right * 0100-- is commutative * 0200-- is right, not left-associative * 0400-- is leaf of tree * *0XX000-- XX is priority of operator */ int opdope[] { 000000, /* EOF */ 000000, /* ; */ 000000, /* { */ 000000, /* } */ 036000, /* [ */ 002000, /* ] */ 036000, /* ( */ 002000, /* ) */ 014201, /* : */ 007201, /* , */ 000000, /* 10 */ 000000, /* 11 */ 000000, /* 12 */ 000000, /* 13 */ 000000, /* 14 */ 000000, /* 15 */ 000000, /* 16 */ 000000, /* 17 */ 000000, /* 18 */ 000000, /* 19 */ 000400, /* name */ 000400, /* short constant */ 000400, /* string */ 000400, /* float */ 000400, /* double */ 000000, /* 25 */ 000000, /* 26 */ 000000, /* 27 */ 000000, /* 28 */ 034200, /* sizeof */ 034203, /* ++pre */ 034203, /* --pre */ 034203, /* ++post */ 034203, /* --post */ 034220, /* !un */ 034202, /* &un */ 034220, /* *un */ 034200, /* -un */ 034220, /* ~un */ 036001, /* . (structure reference) */ 030101, /* + */ 030001, /* - */ 032101, /* * */ 032001, /* / */ 032001, /* % */ 026061, /* >> */ 026061, /* << */ 020161, /* & */ 017161, /* | */ 017161, /* ^ */ 036001, /* -> */ 000000, /* int -> double */ 000000, /* double -> int */ 016001, /* && */ 015001, /* || */ 000000, /* 55 */ 000000, /* 56 */ 000000, /* 57 */ 000000, /* 58 */ 000000, /* 59 */ 022005, /* == */ 022005, /* != */ 024005, /* <= */ 024005, /* < */ 024005, /* >= */ 024005, /* > */ 024005, /*

p */ 024005, /* >=p */ 012213, /* =+ */ 012213, /* =- */ 012213, /* =* */ 012213, /* =/ */ 012213, /* =% */ 012253, /* =>> */ 012253, /* =<< */ 012253, /* =& */ 012253, /* =| */ 012253, /* =^ */ 012213, /* = */ 000000, /* 81 */ 000000, /* 82 */ 000000, /* 83 */ 000000, /* 84 */ 000000, /* 85 */ 000000, /* 86 */ 000000, /* 87 */ 000000, /* 88 */ 000000, /* 89 */ 014201, /* ? */ 000000, /* 91 */ 000000, /* 92 */ 000000, /* 93 */ 000000, /* 94 */ 000000, /* 95 */ 000000, /* 96 */ 000000, /* 97 */ 000000, /* 98 */ 000000, /* 99 */ 036001, /* call */ 036001, /* mcall */ 000000, /* goto */ 000000, /* jump cond */ 000000, /* branch cond */ 000000, /* 105 */ 000000, /* 106 */ 000000, /* 107 */ 000000, /* 108 */ 000000, /* 109 */ 000000 /* force r0 */ }; /* * conversion table: * 0100-- convert left operand * 0*0XX-- XX is conversion number, to wit: * 000: none * 001: int -> ptr * 002: ptr -> int * 003: int -> double * 004: double -> int * 077: generally illegal */ char cvtab[] { 0000, /* i : i */ 0000, /* i : c */ 0103, /* i : f */ 0103, /* i : d */ 0077, /* i : s */ 0101, /* i : *i */ 0000, /* i : *c */ 0101, /* i : *f */ 0101, /* i : *d */ 0101, /* i : *s */ 0101, /* i : ** */ 0000, /* c : i */ 0000, /* c : c */ 0103, /* c : f */ 0103, /* c : d */ 0077, /* c : s */ 0101, /* c : *i */ 0000, /* c : *c */ 0101, /* c : *f */ 0101, /* c : *d */ 0101, /* c : *s */ 0101, /* c : ** */ 0003, /* f : i */ 0003, /* f : c */ 0000, /* f : f */ 0000, /* f : d */ 0077, /* f : s */ 0077, /* f : *i */ 0077, /* f : *c */ 0077, /* f : *f */ 0077, /* f : *d */ 0077, /* f : *s */ 0077, /* f : ** */ 0003, /* d : i */ 0003, /* d : c */ 0000, /* d : f */ 0000, /* d : d */ 0077, /* d : s */ 0077, /* d : *i */ 0077, /* d : *c */ 0077, /* d : *f */ 0077, /* d : *d */ 0077, /* d : *s */ 0077, /* d : ** */ 0077, /* s : i */ 0077, /* s : c */ 0077, /* s : f */ 0077, /* s : d */ 0077, /* s : s */ 0077, /* s : *i */ 0077, /* s : *c */ 0077, /* s : *f */ 0077, /* s : *d */ 0077, /* s : *s */ 0077, /* s : ** */ 0001, /* *i : i */ 0001, /* *i : c */ 0077, /* *i : f */ 0077, /* *i : d */ 0077, /* *i : s */ 0002, /* *i : *i */ 0077, /* *i : *c */ 0077, /* *i : *f */ 0077, /* *i : *d */ 0077, /* *i : *s */ 0002, /* *i : ** */ 0000, /* *c : i */ 0000, /* *c : c */ 0077, /* *c : f */ 0077, /* *c : d */ 0077, /* *c : s */ 0077, /* *c : *i */ 0000, /* *c : *c */ 0077, /* *c : *f */ 0077, /* *c : *d */ 0077, /* *c : *s */ 0077, /* *c : ** */ 0001, /* *f : i */ 0001, /* *f : c */ 0077, /* *f : f */ 0077, /* *f : d */ 0077, /* *f : s */ 0077, /* *f : *i */ 0077, /* *f : *c */ 0002, /* *f : *f */ 0077, /* *f : *d */ 0077, /* *f : *s */ 0077, /* *f : ** */ 0001, /* *d : i */ 0001, /* *d : c */ 0077, /* *d : f */ 0077, /* *d : d */ 0077, /* *d : s */ 0077, /* *d : *i */ 0077, /* *d : *c */ 0077, /* *d : *f */ 0002, /* *d : *d */ 0077, /* *d : *s */ 0077, /* *d : ** */ 0001, /* *s : i */ 0001, /* *s : c */ 0077, /* *s : f */ 0077, /* *s : d */ 0077, /* *s : s */ 0077, /* *s : *i */ 0077, /* *s : *c */ 0077, /* *s : *f */ 0077, /* *s : *d */ 0002, /* *s : *s */ 0077, /* *s : ** */ 0001, /* ** : i */ 0001, /* ** : c */ 0077, /* ** : f */ 0077, /* ** : d */ 0077, /* ** : s */ 0002, /* ** : *i */ 0077, /* ** : *c */ 0077, /* ** : *f */ 0077, /* ** : *d */ 0077, /* ** : *s */ 0002 /* ** : ** */ }; /* * character type table */ char ctab[] { EOF, INSERT, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, SPACE, NEWLN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, UNKN, SPACE, EXCLA, DQUOTE, UNKN, UNKN, MOD, AND, SQUOTE, LPARN, RPARN, TIMES, PLUS, COMMA, MINUS, PERIOD, DIVIDE, DIGIT, DIGIT, DIGIT, DIGIT, DIGIT, DIGIT, DIGIT, DIGIT, DIGIT, DIGIT, COLON, SEMI, LESS, ASSIGN, GREAT, QUEST, UNKN, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LBRACK, UNKN, RBRACK, EXOR, LETTER, UNKN, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LETTER, LBRACE, OR, RBRACE, COMPL, UNKN }; char atoe[] { 0000,0001,0002,0003,0067,0055,0056,0057, 0026,0005,0045,0013,0014,0015,0016,0017, 0020,0021,0022,0023,0074,0075,0062,0046, 0030,0031,0077,0047,0034,0035,0036,0037, 0100,0132,0177,0173,0133,0154,0120,0175, 0115,0135,0134,0116,0153,0140,0113,0141, 0360,0361,0362,0363,0364,0365,0366,0367, 0370,0371,0172,0136,0114,0176,0156,0157, 0174,0301,0302,0303,0304,0305,0306,0307, 0310,0311,0321,0322,0323,0324,0325,0326, 0327,0330,0331,0342,0343,0344,0345,0346, 0347,0350,0351,0214,0340,0254,0275,0155, 0171,0201,0202,0203,0204,0205,0206,0207, 0210,0211,0221,0222,0223,0224,0225,0226, 0227,0230,0231,0242,0243,0244,0245,0246, 0247,0250,0251,0300,0117,0320,0241,0007, 0004,0006,0010,0011,0012,0024,0025,0027, 0032,0033,0040,0041,0042,0043,0044,0050, 0051,0052,0053,0054,0060,0061,0063,0064, 0065,0066,0070,0071,0072,0073,0076,0101, 0102,0103,0104,0105,0106,0107,0110,0111, 0112,0121,0122,0123,0124,0125,0126,0127, 0130,0131,0137,0142,0143,0144,0145,0146, 0147,0150,0151,0152,0160,0161,0162,0163, 0164,0165,0166,0167,0170,0200,0212,0213, 0215,0216,0217,0220,0232,0233,0234,0235, 0236,0237,0240,0252,0253,0255,0256,0257, 0260,0261,0262,0263,0264,0265,0266,0267, 0270,0271,0272,0273,0274,0276,0277,0312, 0313,0314,0315,0316,0317,0332,0333,0334, 0335,0336,0337,0341,0352,0353,0354,0355, 0356,0357,0372,0373,0374,0375,0376,0377, }; char symbuf[ncps]; int hshused; struct hshtab hshtab[hshsiz]; int *space; int *cp; int cmst[cmsiz]; struct swtab *swp; int contlab; int brklab; int retlab; int deflab; int autolen; int peekc; int eof; int hgcurloc; struct hshtab *defsym; struct hshtab *funcsym; int xdflg; int proflg; struct hshtab *csym; int cval; int nchstr; char *fcval; int fflg; int ftern; int hgcurlo; int nerror; struct hshtab *paraml; struct hshtab *parame; int strflg; int osleft; int mosflg; int initflg; int inhdr; int dimtab[dimsiz]; int dimp; /* Next free slot in dimension table. */ int regvar; /* Number of declared register variables. */ /* Variables added for ibmc. */ int ndp; /* nbr of declared parameters in a ftn. */ int endp; /* enable incrementing of ndp. */ int xtern; /* flag to indicate keyword extern was seen. */ int function; /* flag to indicate if a ftn has yet been seen. */ int hgoffs; struct table efftab[]; int nstack; int nfloat; char etoa[] { 0000,0001,0002,0003,0200,0011,0201,0177, 0202,0203,0204,0013,0014,0015,0016,0017, 0020,0021,0022,0023,0205,0206,0010,0207, 0030,0031,0210,0211,0034,0035,0036,0037, 0212,0213,0214,0215,0216,0012,0027,0033, 0217,0220,0221,0222,0223,0005,0006,0007, 0224,0225,0026,0226,0227,0230,0231,0004, 0232,0233,0234,0235,0024,0025,0236,0032, 0040,0237,0240,0241,0242,0243,0244,0245, 0246,0247,0250,0056,0074,0050,0053,0174, 0046,0251,0252,0253,0254,0255,0256,0257, 0260,0261,0041,0044,0052,0051,0073,0262, 0055,0057,0263,0264,0265,0266,0267,0270, 0271,0272,0273,0054,0045,0137,0076,0077, 0274,0275,0276,0277,0300,0301,0302,0303, 0304,0140,0072,0043,0100,0047,0075,0042, 0305,0141,0142,0143,0144,0145,0146,0147, 0150,0151,0306,0307,0133,0310,0311,0312, 0313,0152,0153,0154,0155,0156,0157,0160, 0161,0162,0314,0315,0316,0317,0320,0321, 0322,0176,0163,0164,0165,0166,0167,0170, 0171,0172,0323,0324,0135,0325,0326,0327, 0330,0331,0332,0333,0334,0335,0336,0337, 0340,0341,0342,0343,0344,0136,0345,0346, 0173,0101,0102,0103,0104,0105,0106,0107, 0110,0111,0347,0350,0351,0352,0353,0354, 0175,0112,0113,0114,0115,0116,0117,0120, 0121,0122,0355,0356,0357,0360,0361,0362, 0134,0363,0123,0124,0125,0126,0127,0130, 0131,0132,0364,0365,0366,0367,0370,0371, 0060,0061,0062,0063,0064,0065,0066,0067, 0070,0071,0372,0373,0374,0375,0376,0377, }; 321, 0322,0176,0163,0164,0165,0166,0167,0170, 0171,0172,0323,0324,0135,0325,0326,0327, 0330,0331,0332,0333,0334,0335,0336,0337, 0340,0341,0342,0343,0344,0136,0345,0346, 0173,0101,0102,0103,0104,0105,0106,0107, 0110,0111,0347,0350,0351,0352,0353,0354, 0175,0112,0113,0114,0115,0116,0117,0120, 0121,0122,0355,0356,0357,0360,0361,0362, 0134,0363,0123,0124,0125,0126,0127,0130, 0131,0132,# /* C compiler ( file - c05.c ) Copyright 1972 Bell Telephone Laboratories, Inc. */ #include "c0h.c" struct swtab swtab[swsiz]; extern char etoa[]; extern char atoe[]; int machine; struct hshtab *lookup() { /* returns a pointer to a hshtab structure member */ int ihash; register struct hshtab *rp; register char *sp, *np; char *delp; int delpen, lpctr; ihash = 0; delpen = YES; lpctr = 0; for (sp=symbuf; spname)) { /* look while items in the table are nonzero. */ if ((delpen == YES) && ((rp->hflags & DELETED) == DELETED) && ((rp->hflags & GLOBAL) == 0)) { delp = rp; delpen = NO; } for (sp=symbuf; sphflags & DELETED) == DELETED) goto insertname; return(rp); no: if (++lpctr >= hshsiz) goto insert; if (++rp >= &hshtab[hshsiz]) rp = hshtab; } insert: if (delpen == NO) rp = delp; insertname: if(++hshused >= hshsiz) { error("Symbol table overflow"); cexit(1); } rp->hclass = 0; rp->htype = 0; rp->hoffset = 0; rp->hdimp = 0; rp->hflags = 0; sp = symbuf; if (xdflg) rp->hflags =| PERM; /* non-deletable */ for (np=rp->name; sp=0) { c = peeksym; peeksym = -1; if (c==NAME) mosflg = 0; return(c); } if (peekc) { c = peekc; peekc = 0; } else if (eof) return(EOF); else c = getchar(); loop: switch(getctab(c)) { /* Ctab is a character set dependant table, initialized in c04.c. */ case INSERT: /* ignore next newline on # inserted files. */ inhdr = 1; c = getchar(); goto loop; case NEWLN: if (!inhdr) line++; inhdr = 0; case SPACE: c = getchar(); goto loop; case EOF: eof++; return(0); case PLUS: return(subseq(c,PLUS,INCBEF)); case MINUS: return(subseq(c,subseq('>',MINUS,ARROW),DECBEF)); case ASSIGN: if (subseq(' ',0,1)) return(ASSIGN); c = symbol(); if (c>=PLUS && c<=EXOR) return(c+30); if (c==ASSIGN) return(EQUAL); peeksym = c; return(ASSIGN); case LESS: if (subseq(c,0,1)) return(LSHIFT); return(subseq('=',LESS,LESSEQ)); case GREAT: if (subseq(c,0,1)) return(RSHIFT); return(subseq('=',GREAT,GREATEQ)); case EXCLA: return(subseq('=',EXCLA,NEQUAL)); case DIVIDE: if (subseq('*',1,0)) return(DIVIDE); com: /* Process a comment. */ c = getchar(); com1: switch(c) { case '\0': eof++; error("Nonterminated comment"); return(0); case '\n': if (!inhdr) line++; inhdr = 0; goto com; case 001: /* SOH, insert marker */ inhdr++; default: goto com; case '*': c = getchar(); if (c!='/') goto com1; } /* End processing a comment. */ c = getchar(); goto loop; case PERIOD: c = getchar(); if(c>='0' && c<='9' ) { dig[0] = '.'; i=1; goto fc; } /* not floating point; structure reference */ peekc = c; return (DOT); case DIGIT: cval = 0; i = 0; base = (c=='0') ? 8 : 10; while (c>='0' && c<='9') { cval = (cval*base-'0')+c; dig[i++] = c; c = getchar(); } if( c=='.' || c=='d' || c=='D' || c=='e' || c=='E' ) goto fc; peekc = c; return (CON); fc: /* convert floating point constant */ state = 0; /* haven't seen d */ for( ;; c=getchar() ) { switch(c) { case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '0': case '.': dig[i++] = c; if (state) state=2; continue; case 'd': case 'D': case 'e': case 'E': dig[i++] = '%'; dig[i++] = 'c'; if(state!=0) error("illegal floating point constant"); state = 1; continue; case '+': case '-': if(state==1) { dig[i++] = c; continue; } } /*otherwise, and + and - not preceded by d */ break; } /* we now have collected the digits; output the number */ if(state==0) { dig[i++] = '%'; dig[i++] = 'c'; dig[i++] = '0'; } peekc = c; dig[i++] = '\0'; fcval = dig; return(FCON); case DQUOTE: return(STRING); /* return, but dont get contents */ case SQUOTE: return(getcc()); /* Only call of getcc. */ case LETTER: sp = symbuf; /* Put a word into symbol buffer - then call lookup. */ if (mosflg) { *sp++ = '.'; mosflg = 0; } while(getctab(c)==LETTER || getctab(c)==DIGIT) { if (c == '_') c = '#'; if (sphclass==KEYWC) { if (csym->htype==SIZEOF) return(SIZEOF); cval = csym->htype; return(KEYW); } return(NAME); case AND: return(subseq('&', AND, LOGAND)); case OR: return(subseq('|', OR, LOGOR)); case UNKN: error("Unknown character"); c = getchar(); goto loop; } return(getctab(c)); } /* End of Symbol function. */ subseq(c,a,b) { if (!peekc) peekc = getchar(); if (peekc != c) return(a); peekc = 0; return(b); } getstr() { /* get string - processes something in double quotes. */ register int c; register int slpctr; nchstr = 1; printf("$%d",cval = isn++); printf(" dc x'"); slpctr = 0; while((c=mapch('"')) >= 0) { if (slpctr >= 25) { slpctr = 0; printf("'\n dc x'"); } printf("%02x", c); nchstr++; slpctr++; } if (nchstr<= 1) printf("00"); printf("' \n dc x'00' \n"); } getcc() /* get a character constant (eg 'a'). */ { register int c, cc; cval = 0; cc = 0; while((c=mapch('\'')) >= 0) {cc++; if(cc<=2) cval = (cval<<8) + c; } if(cc>2) /* don't allow char const > 2 char */ error("Long character constant"); return(CON); } mapch(ac) /* map character - implements the escapes (eg \n). */ { register int a, c; c = ac; loop: if((a=getchar())==c) return(-1); switch(a) { case '\n': case '\0': error("Nonterminated string"); peekc = a; return(-1); case '\\': /* Return numerical value of ebcdic character. */ switch (a=getchar()) { case 't': return(05); /* return('\t') */ case 'n': return(37); /* \n line feed */ case 'b': return(22); /* \b, backspace */ case '0': return(0); /* \0, null */ case 'r': return(13); /* \r, carriage return */ case '\n': if (!inhdr) line++; inhdr = 0; goto loop; } } if (machine == UNIX) { c= (atoe[a] & 0377); return(c); } else /* machine is IBM */ return(a); } getctab(c) char c; { if (machine == IBM) return(ctab[etoa[c]]); else /* machine is UNIX */ return(ctab[c]); } */ case 'n': return(37); /* \n line feed */ case 'b': return(22); /* \b, backspace */ case '0': return(0); /* \0, null */ case 'r': return(13); /* \r, carriage return */ cas# /* (file - c0h.c) C compiler-- header file Copyright 1973 Bell Telephone Laboratories, Inc. */ /* parameters */ #define ncps 8 #define hshsiz 400 #define cmsiz 40 #define swsiz 200 #define ncpw 4 /* number of characters per word */ #define ossiz 500 #define dimsiz 100 # define hgintsz 4 /* number of bytes in an integer */ # define hgfloatsz 8 /* number of bytes in a float */ # define hgreglen 64 /* bytes required to store 16 registers */ # define totregs 5 # define lowreg 2 /* the following constants indicate the type of loctr */ # define hgmain 1 # define hgcode 2 # define hgdata 3 # define hgstring 4 # define hgtvec 5 # define hglit 6 # define hgistring 7 struct tnode { /* nodes for expression tree */ int op; int type; int dimp; /* dimention pointer */ struct tnode *tr1, *tr2; }; struct { int fop; int ftype; char ssp; /* subscript list */ char lenp; /* structure length */ }; struct { /* tnode from pass 1. */ int op; int type; int degree; struct tnode *tr1, *tr2; }; struct tname { /* node for a leaf in the expression tree */ int nop; int ntype; int ndimp; int class; int offset; int nloc; }; struct { /* tname from pass 1. */ int nop; int ntype; int elsize; int class; int offset; int nloc; }; struct tconst { /* node for a constant in the expression tree */ int cop; int ctype; int cdimp; int value; }; struct { /* tconst from pass 1. */ int cop; int ctype; int cdeg; int value; }; struct hshtab { /* hash table */ int hclass; int htype; int hdimp; int hoffset; int hflags; char name[ncps]; }; struct swtab { /* switch table */ int swlab; int swval; }; struct bnode { int bop; struct tnode *btree; int lbl; int cond; }; struct optab { int tabdeg1; int tabtyp1; int tabdeg2; int tabtyp2; char *tabstring; }; struct table { int tabop; struct optab *tabp; }; extern struct tconst czero, cone; extern char cvtab[]; /* conversion table in c04.c ; used in type conversions */ extern int opdope[]; /* information on operators */ extern char ctab[]; /* table that maps characters into character types */ extern char symbuf[ncps]; extern int hshused; extern struct hshtab hshtab[hshsiz]; extern int *space; extern int *cp; extern int cmst[cmsiz]; extern int isn; extern int isn1; extern struct swtab swtab[swsiz]; extern struct swtab *swp; extern int contlab; extern int brklab; extern int retlab; extern int deflab; extern int autolen; extern int peeksym; extern int peekc; extern int eof; extern int line; extern int *treebase; extern struct hshtab *defsym; extern struct hshtab *funcsym; extern int xdflg; extern int proflg; extern struct hshtab *csym; extern int cval; extern char *fcval; extern int nchstr; extern int nerror; extern struct hshtab *paraml; extern struct hshtab *parame; extern int strflg; extern int osleft; extern int mosflg; extern int initflg; extern int inhdr; extern int dimtab[dimsiz]; extern int dimp; /* Next free slot in dimension table. */ extern int regvar; /* Number of declared register variables. */ /* Variables added for ibmc. */ extern int ndp; /* nbr of declared parameters in a ftn. */ extern int endp; /* enable incrementing of ndp. */ extern int xtern; /* flag to indicate keyword extern was seen. */ extern int ftern; /* flag to indicate keyword fortran was seen. */ extern int fflg; /* composite fortran flag */ extern int function; /* flag to indicate if a ftn has yet been seen. */ extern int mainftn; /* flag to indicate whether ftn is main */ extern int mainfile; /* flag indicating whether main function is in file */ extern int machine; /* flag to tell which machine this program is executing on. */ extern int hgoffs; /* contents of HGARGP plus hgoffs points to first free space on arg. stack */ extern int hgcurloc; /* current loctr */ extern char maprel[]; extern char notrel[]; extern int nreg; extern struct table cctab[]; extern struct table efftab[]; extern struct table regtab[]; extern int nstack; extern int nfloat; /* operators */ #define EOF 0 #define SEMI 1 #define LBRACE 2 #define RBRACE 3 #define LBRACK 4 #define RBRACK 5 #define LPARN 6 #define RPARN 7 #define COLON 8 #define COMMA 9 #define KEYW 19 #define NAME 20 #define CON 21 #define STRING 22 #define FCON 23 #define SFCON 24 #define INCBEF 30 #define DECBEF 31 #define INCAFT 32 #define DECAFT 33 #define EXCLA 34 #define AMPER 35 #define STAR 36 #define NEG 37 #define COMPL 38 #define DOT 39 #define PLUS 40 #define MINUS 41 #define TIMES 42 #define DIVIDE 43 #define MOD 44 #define RSHIFT 45 #define LSHIFT 46 #define AND 47 #define OR 48 #define EXOR 49 #define ARROW 50 #define ITOF 51 #define FTOI 52 #define LOGAND 53 #define LOGOR 54 #define EQUAL 60 #define NEQUAL 61 #define LESSEQ 62 #define LESS 63 #define GREATEQ 64 #define GREAT 65 #define LESSP 66 #define LESSEQP 67 #define GREATP 68 #define GREATQP 69 #define ASPLUS 70 #define ASMINUS 71 #define ASTIMES 72 #define ASDIV 73 #define ASMOD 74 #define ASRSH 75 #define ASLSH 76 #define ASSAND 77 #define ASOR 78 #define ASXOR 79 #define ASSIGN 80 #define QUEST 90 #define CALL 100 #define MCALL 101 #define JUMP 102 #define CBRANCH 103 #define INIT 104 #define SETREG 105 #define LOAD 106 #define INIB 107 #define RFORCE 110 #define BRANCH 111 #define LABEL 112 /* types */ #define INT 0 #define CHAR 1 #define FLOAT 2 #define DOUBLE 3 #define STRUCT 4 #define RSTRUCT 5 #define PTR 010 #define FUNC 020 #define ARRAY 030 /* storage classes */ #define KEYWC 1 #define MOS 4 #define GXTERN 9 #define AUTO 5 #define EXTERN 6 #define STATIC 7 #define REG 8 #define STRTAG 3 #define ARG 10 #define ARG1 11 #define FORTRAN 23 #define BLISS 22 /* keywords */ #define GOTO 10 #define RETURN 11 #define IF 12 #define WHILE 13 #define ELSE 14 #define SWITCH 15 #define CASE 16 #define BREAK 17 #define CONTIN 18 #define DO 19 #define DEFAULT 20 #define FOR 21 #define ASM 24 #define SIZEOF 29 /* characters */ #define INSERT 119 #define PERIOD 120 #define SQUOTE 121 #define DQUOTE 122 #define LETTER 123 #define DIGIT 124 #define NEWLN 125 #define SPACE 126 #define UNKN 127 /* Flag bits */ #define BINARY 01 #define LVALUE 02 #define RELAT 04 #define ASSGOP 010 #define LWORD 020 #define RWORD 040 #define COMMUTE 0100 #define RASSOC 0200 #define LEAF 0400 /* hflags */ #define GLOBAL 01 #define DEFINED 02 #define DELETED 04 #define PERM 010 #define YES 1 #define NO 0 #define IBM 0 #define UNIX 1 racters */ #define INSERT 119 #define PERIOD 120 #define SQUOTE 121 #define DQUOTE 122 #define LETTER 123 #define DIGIT 124 #define NEWLN 125 #define SPACE 126 #define UNKN 127 /* Fl# /* some general table writing rules X specifies that the result may come back in other than the requested register (incl reg. 0 ); R1 should not be used after X is (R) should not be used after X is In particular, FX* and FS* should be used very cautiously, since they tend to imply #1(R), or similar * always skips the constant in a *(e+c) situation #1 or #2 should always be used in this case! */ /* C compiler (file - c10.c) Copyright 1972 Bell Telephone Laboratories, Inc. */ #include "c0h.c" int hdebug 0; char maprel[] { EQUAL, NEQUAL, GREATEQ, GREAT, LESSEQ, LESS, GREATP, GREATQP, LESSP, LESSEQP }; char notrel[] { NEQUAL, EQUAL, GREAT, GREATEQ, LESS, LESSEQ, GREATQP, GREATP, LESSEQP, LESSP }; int nreg 7; int flreg 0; int *treebase; extern char etoa[]; char *match(atree, table, nrleft) struct tnode *atree; struct table *table; { int op, d1, d2, t1, t2, dope,i; struct tnode *p2; register struct tnode *p1, *tree; register struct optab *opt; if ((tree=atree)==0) return(0); op = tree->op; dope = opdope[op]; if (isfloat(tree)) if (op == MOD || op == ASMOD) return(0); if ((dope&LEAF) == 0) p1 = tree->tr1; else p1 = tree; t1 = p1->type; d1 = dcalc(p1, nrleft); if (hdebug>100) printf("d1=%d\n",d1); if ((dope&BINARY)!=0) { p2 = tree->tr2; t2 = p2->type; d2 = dcalc(p2, nrleft); if( hdebug>100) printf( "d2=%d\n", d2 ); } for (; table->op!=op; table++) if (table->op==0) return(0); if (hdebug>100) printf("table->tabop=%d\n",table->op); for (opt = table->tabp; opt->tabdeg1!=0; opt++) { if (hdebug>100) printf("opt->tabdeg1=%d\n",opt->tabdeg1); if (opt->tabdeg1 >= 0100) { if (p1->op != STAR) { if (hdebug > 100) printf("p1->op=%d\n"); continue; } /* else p1->op == STAR */ if ((i=dcalc(p1->tr1,nrleft)) > (opt->tabdeg1&077)) { if (hdebug > 100) printf("dcalc(p1->tr1)=%d, opt->tabdeg1&077=%d\n", i,(opt->tabdeg1&077)); continue; } } if (d1 > opt->tabdeg1) continue; if (i=notcompat(p1, opt->tabtyp1)) { if (hdebug>100) printf("notcompat=%d\n",i); continue; } if ((opdope[op]&BINARY)!=0 && p2!=0) { if (d2 > (opt->tabdeg2&077) || (opt->tabdeg2 >= 0100) && (p2->op != STAR) ) {if (hdebug > 100) printf("opt->tabdeg2=%d,p2->op=%d\n",opt->tabdeg2, p2->op); continue; } if (i=notcompat(p2,opt->tabtyp2)) { if( hdebug>100 ) printf("notcompat2=%d\n", i); continue; } } while (opt->tabstring == 0) opt++; return(opt); } return(0); } rcexpr(atree, atable, reg) struct tnode *atree; struct table *atable; { register r; register struct tnode *tree; register struct table *table; /* I assert that rcexpr should never be asked to compile anything into registers 0 or 1 */ if( reg < lowreg || reg>7 ){ error( "rcexper register error" ); return(lowreg); } table = atable; if((tree=atree)==0) return(99); switch (tree->op) { case CBRANCH: cbranch(tree->btree, tree->lbl, tree->cond, lowreg); return(99); case INIT: if (tree->tr1->op == AMPER) tree->tr1 = tree->tr1->tr1; if (tree->tr1->op!=NAME && tree->tr1->op!=CON) error("Illegal initialization"); else{ cexpr(tree, regtab, nreg); } return(99); case INIB: cexpr(tree, regtab, nreg); return(99); case EXCLA: if ((opdope[tree->tr1->op] & RELAT) != 0) { tree = tree->tr1; tree->op = notrel[tree->op - EQUAL]; } break; case RFORCE: if((r=rcexpr(tree->tr1, table, reg)) != 0) printf(" lr 0,%d\n", r); return(0); case TIMES: case ASTIMES: pow2(tree); } if ((r=cexpr(tree, table, reg))>=0) { return(r); } if (table!=regtab) if((r=cexpr(tree, regtab, reg))>=0) { if (table==cctab) { printf(" ltr %d,%d\n", r, r); } return(99); } error("No match for op %d", tree->op); return(lowreg); } # define SHARP 1 # define STAROP 2 cexpr(atree, table, areg) /* Compile an expression. */ struct tnode *atree; struct table *table; { int c, r; int tstat; /* status check for * and # operators */ register struct tnode *p, *p1, *tree; struct tnode *p2; char *string; int reg, reg1, rreg; char *opt; int tempoff; char cr; /* I assert that reg is always between 2 and 9 */ /* the return value of this function is always -1, which means can7t be done 0, which means result in register 0 value is result register, >= reg >= 2 1 is never a legal return value The registers r satisfying 2<=r= 2 X is used if the result could come back into register 0 Register 1 can be freely used at all times by the code sequences */ if( areg < lowreg || areg > 7 ){ if (hdebug > 50) printf(2,"lowreg=%d, areg=%d\n", lowreg, areg); error( "cexpr register error" ); return( lowreg ); } tstat = 0; tree = atree; reg = areg; p1 = tree->tr2; if ((c = tree->op)==CALL) { /* beware: comarg doesn't know about reg... */ if (tree->tr1->op == STAR) tree->tr1 = tree->tr1->tr1; else error("Compiler ftn call error"); if(tree->tr1->class == FORTRAN) ftern=YES; else ftern = NO; fflg = (fflg<<1) + ftern; r = 0; if(p1->op) { while (p1->op==COMMA) { r =+ comarg(p1->tr1); p1 = p1->tr2; } r =+ comarg(p1); } tree->op = MCALL; /* MCALL is a CALL with arguements already taken care of. */ tree->degree = r; /* save arg length */ fflg = fflg>>1; } if ((opdope[c]&RELAT||c==LOGAND||c==LOGOR||c==EXCLA) && table!=cctab) { cbranch(tree, c=isn++, 1, reg); rcexpr(&czero, table, reg); branch(isn); label(c); rcexpr(&cone, table, reg); label(isn++); return(reg); } if(c==QUEST) { if (table==cctab) return(-1); cbranch(tree->tr1, c=isn1++, 0, reg); rreg = rcexpr(p1->tr1, table, reg); branch(r=isn1++); label(c); reg = rcexpr(p1->tr2, table, reg); if (rreg!=reg) printf(" lr %d,%d\n", rreg, reg); reg = rreg; label(r); goto retrn; } reg = oddreg(tree, reg); reg1 = reg+1; if (chkleaf(tree, table, reg) >= 0) goto retrn; if ((opt=match(tree, table, nreg-reg))==0) return(-1); string = opt->tabstring; p1 = tree->tr1; p2 = 0; if (opdope[tree->op] & BINARY) p2 = tree->tr2; loop: switch(c = *string++) { case '\0': if (tree->op==MCALL) { if(tree->tr1->class==FORTRAN) ftern = YES; else ftern = NO; if (ftern==YES) { printf(" mvi %d(HGARGP),x'80'\n",hgoffs-hgintsz); printf(" la 1,%d(HGARGP)\n",hgoffs-tree->degree); printf(" la HGARGP,%d(HGARGP)\n",hgoffs); printf(" FCALL\n"); printf(" s HGARGP,=f'%d'\n",hgoffs); } else { printf(" la 1,%d\n",tree->degree); if (hgoffs - tree->degree) printf(" la HGARGP,%d(HGARGP)\n",hgoffs-tree->degree); printf(" BCALL\n"); if (hgoffs - tree->degree) printf(" s HGARGP,=f'%d'\n",hgoffs-tree->degree); } hgoffs =- tree->degree; reg = 0; } retrn: if( tstat != 0 && tstat != (SHARP+STAROP) )error( "compiler error; star without sharp" ); if (!isfloat(tree)) if (tree->op==DIVIDE || tree->op==ASDIV) reg++; if (tree->type == FLOAT || tree->type == DOUBLE) return(0); return(reg); /* A1 and A2 */ case 'A': if (*string++ == '1') p=p1; else p=p2; pname(p); goto loop; /* B1 B2 or BF */ case 'B': switch (*string++) { case 'F': p=tree; if (isfloat(p)) putchar('d'); goto loop; case '1': case '2': if (((opdope[tree->op]&LEAF) != 0 ) || (tree->op == STAR)) p=tree; else if (*(string-1) == '1') p=p1; else p=p2; } if (p->type == CHAR) putchar('c'); if (cr=isfloat(p)) putchar(cr); goto loop; /* C1 or C2 */ case 'C': if (*string++ == '1') p=p1->tr1; else p=p2->tr1; printf("%d",p); goto loop; /* F or FR */ case 'F': if (*string != 'R') { p=p1; goto subtre; } else { string++; goto breg; } case 'S': p=p2; goto subtre; case 'H': p=tree; subtre: c=((*string++)-'0')*8+((*string++)-'0'); if (c&01) { /* star operator */ if (p->op != STAR) error("compiler error; bad star entry"); p=p->tr1; tstat =| STAROP; if (collcon(p)) p = p->tr1; } if( c&02 ){ /* FS or SS or FS* or SS* */ /* compile, then simulate a store to temp */ /* this should appear before any other forms of F or S /* except other FS or SS forms */ /* This is legal only in the forms FS, SS, FS*, and SS* */ rreg = rcexpr( p, regtab, areg ); tempoff = autolen; autolen =+ 4; if( isfloat(p) ){ autolen =+ 4; /* floating point store here */ printf( "\tstd\t%d,%d(HGAUTOP)\ttemp\n", flreg, tempoff ); } else { printf( "\tst\t%d,%d(HGAUTOP)\ttemp\n", rreg, tempoff ); } goto loop; } if (c&010){ /* F2 or S2 */ r = reg1 + 1; goto csubtre; } if (c&4) /* F1 or S1 */ r = reg1; else if( c & 020 ) r = areg; /* we don't really care ! */ else r = reg; csubtre: rreg = rcexpr(p, regtab, r); if (c & 010) { if (rreg != r) { printf(" lr %d,%d\n", r, rreg); if (hdebug > 100) printf("010 matches\n"); } goto loop; } if (c&4) reg1 = rreg; else if (rreg != reg) if (c&020) { /* we assert (through the X mechanism) that we are prepared to live with the result in a place where we did not expect it */ /* warning! don't use with mult, div, etc. */ reg = rreg; /* reg1 should never be used if this is done */ reg1 = 99; } else { if (tree->type != FLOAT && tree->type != DOUBLE) printf(" lr %d,%d\n", reg, rreg); if (hdebug > 100) printf("020 not recognized\n"); } goto loop; /* Z */ case 'Z': if(isfloat(p)) breg: { r=flreg; if (*string == '2') { r =+ 2; string++; } goto preg; } /* R */ case 'R': switch (*string++) { case '-': r=reg-1; goto preg; case '+': r=reg+1; goto preg; case '1': r=reg1; goto preg; case '2': r=reg+2; string++; goto preg; default: r=reg; string--; preg: if (r>nreg) error("Register overflow: simplify expression"); printf("%d",r); goto loop; } /* end case R */ /* #1 or #2 */ case '#': if ((*string++) == '1') p=p1->tr1; else p=p2->tr1; goto nmbr; case '~': p=p1; nmbr: tstat =| SHARP; if (collcon(p)) printf("%d", p->tr2->value); else printf("0"); goto loop; /* Q */ case 'Q': p = p1->tr1; printf("%x", p); goto loop; /* O */ case 'O': wexpr(tree->op<50?tree->op:tree->op-30,tree); goto loop; /* T */ case 'T': printf("%d(HGAUTOP) temp", tempoff); goto loop; } putchar(c); goto loop; } wexpr(operator,tree) /* part of cexpr moved to here because cexpr got to big */ struct tnode *tree; int operator; { switch(operator) { case INCAFT: case PLUS: printf("a"); break; case DECAFT: case MINUS: printf("s"); break; case AND: printf("n"); break; case OR: printf("o"); break; case EXOR: printf("x"); break; default: error("No match - binary op %d", tree->op); } } chkleaf(atree, table, reg) struct tnode *atree; { struct tnode lbuf; register struct tnode *tree; tree = atree; if (dcalc(tree, nreg-reg) > 12) return(-1); lbuf.op = LOAD; lbuf.type = tree->type; lbuf.degree = tree->degree; lbuf.tr1 = tree; return(cexpr(&lbuf, table, reg)); } comarg(atree) /* Compile an argument for a function call. */ { register struct tnode *tree; int r,t,l; tree = atree; t = isfloat(tree); if (tree->type==STRUCT) error("Illegal structure"); r = rcexpr(tree, regtab, lowreg); ftern = fflg & 1; if(ftern) { if (t) { printf(" std %d",flreg); l=hgfloatsz; } else { printf(" st %d",r); l=hgintsz; } printf(",%d(HGAUTOP) conv args to ptrs for fortran\n",autolen); printf(" la %d,%d(HGAUTOP)\n",r,autolen); autolen =+ l; } if((t) && (!ftern)) { printf(" std %d,%d(HGARGP)\n", flreg, hgoffs); hgoffs =+ hgfloatsz; l=hgfloatsz; } else { printf(" st %d,%d(HGARGP)\n",r, hgoffs); hgoffs =+ hgintsz; l=hgintsz; } return(l); } p# /* * C compiler */ #include "c0h.c" char *condop[] { "be", "bne", "bnh", "bl", "bnl", "bh", "bl", "bnh", "bh", "bnl", 0 }; max(a, b) /* returns max of a b. */ { if (a>b) return(a); return(b); } degree(at) struct tnode *at; { register struct tnode *t; if ((t=at)==0 || t->op==0) return(0); if (t->op == CON) return(-3); if (t->op == AMPER) return(-2); if ((opdope[t->op] & LEAF) != 0) return(0); return(t->degree); } pname(ap) /* Called by cexpr to print addresses. */ struct tnode *ap; { register i; register struct tnode *p; p = ap; if (p->op == STAR) p = p->tr1; loop: switch(p->op) { case SFCON: case FCON: printf("$%d",p->value); return; case CON: printf("=f'%d'", p->value); return; case NAME: if (i = p->offset) printf("%d+", i); switch(p->class) { case AUTO: printf("%d(HGAUTOP)", p->nloc); return; case EXTERN: printf("%.8s", &(p->nloc)); return; case FORTRAN: case GXTERN: printf("@%.7s", &(p->nloc)); return; case STRUCT: error("Illegal structure reference"); printf("$0"); return; case REG: if (i) error("Bad reg. reference"); printf("%d", p->nloc); return; } /* presumably, it's static */ printf("$%d", p->nloc); return; } error("pname called illegally"); } dcalc(ap, nrleft) /* Difficulty calculation - returns stuff like e, n, a, or whatever. */ struct tnode *ap; { register struct tnode *p; if ((p=ap)==0) return(0); switch (p->op) { case NAME: return(12); /* 12 => addressible. */ case SFCON: case FCON: return(12); case CON: return(p->value==0? 4:(p->value==1?5:((p->value >=0)&&(p->value <4096))?6:8)); /* 4=>zero, 5=>one, 6=> 0<=x<4096, 8=>constant. */ } return(p->degree<=nrleft? 20: 24); /* 20 => easy, 24 => anything. */ } notcompat(ap, ast) /* check compatibility of types - eg int, char, or whatever. */ /* if tree is type float and tables say double, pretend tree is type double ... */ /* this is a mess and should be re-written */ struct tnode *ap; /* ftn returns 0 if compatible and 1 if not. */ { register at, st; register struct tnode *p; p = ap; at = p->type; /* actual type - of the object. */ st = ast; /* string type - type demanded by the code table. */ if ((at&07)==STRUCT) /* dmr said this shouldn't happen. */ at =& 077770; /* map to int */ if (st==0) /* word, byte */ return(at>1 & at<=07); /* compatible if at = 0 or 1, or if at > 7. */ if (st==1) /* word */ return(at>0 & at<=07); /* compatible if at is 0 or if at >7. */ st =- 2; if ((at&077740) != 0) at = 020; /* 020 is pointer to int. */ if ((at&077770) != 0) at = at&07 | 020; if (st==DOUBLE && at==FLOAT) at = DOUBLE; return(st != at); } collcon(ap) /* collect constant. */ struct tnode *ap; { register op; register struct tnode *p; p = ap; if(p->op==PLUS) { op = p->tr2->op; if ((op == CON) && (p->tr2->value >= 0) && (p->tr2->value < 4096)) return(1); } return(0); } isfloat(at) /* Is type float or double? */ struct tnode *at; { register struct tnode *t; t = at; if ((opdope[t->op]&RELAT)!=0) t = t->tr1; if (t->type == FLOAT) return('e'); if (t->type == DOUBLE) return('d'); return(0); } oddreg(t, areg) struct tnode *t; { register reg; reg = areg; if (!isfloat(t)) switch(t->op) { case DIVIDE: /* for / and % need even reg. */ case MOD: case ASDIV: case ASMOD: reg++; return(reg & 0776); case TIMES: /* for * need odd reg and empty even below it. */ case ASTIMES: reg++; return(reg|1); } return(reg); } pswitch(afp, alp) /* Generate code for a switch statement. */ struct swtab *afp, *alp; { int tlab, ncase, i, j, tabs, worst, best, range; int l1, l2, l3; register struct swtab *swpo, *fp, *lp; int poctab[swsiz]; fp = afp; lp = alp; if (fp==lp) { printf(" b $%d\n", deflab); return; } tlab = isn1++; if (sort(fp, lp)) return; ncase = lp-fp; lp--; range = lp->swval - fp->swval; /* direct switch */ /* Direct switch is not currently implemented. */ /* if (( 0>1 ) && (range>0 && range <= 3*ncase)) { /* if (fp->swval) /* printf("sub $0%o,r0\n", fp->swval); /* printf("cmp r0,$0%o\n", range); /* printf("jhi L%d\n", deflab); /* printf("asl r0\n"); /* printf("jmp *.+4(r0)\n"); /* for (i=fp->swval; i<=lp->swval; i++) { /* if (i==fp->swval) { /* printf("L%d\n", fp->swlab); /* fp++; /* } else /* printf("L%d\n", deflab); /* } /* goto esw; /* } */ /* simple switch */ /* this is the only one currently implemented */ if( 1 || (ncase<8)) { printf(" la 1,4 put 4 into r1 \n"); printf(" la %d,0 zero r2 \n",lowreg); printf("$%d c %d,$%d-4(1) is addr 0 ? \n", l3=isn1++, lowreg, l1=isn1++); printf(" be $%d+4 \n",l2=isn1++); printf(" c 0,$%d(1) is case satisfied ? \n",l1); printf(" be $%d \n", l2); printf(" la 1,8(1) bump r1 by 8 \n"); printf(" b $%d \n", l3); printf("$%d s 1,=f'4' \n", l2); printf(" l %d,$%d(1) \n", lowreg, l1); printf(" br %d \n",lowreg); printf(" dataloc\n"); /*switchfudge*/ printf(" cnop 0,4 \n$%d equ * \n", l1); for (; fp<=lp; fp++) printf(" dc a($%d) \n dc f'%d' \n", fp->swlab, fp->swval); printf(" dc f'0' \n dc a($%d) \n", deflab); printf(" codeloc\n"); /*switchfudge*/ goto esw; } /* hash switch */ /* Hash switch is not currently supported. */ /* best = 077777; /* for (i=ncase/4; i<=ncase/2; i++) { /* for (j=0; jswval, i)]++; /* worst = 0; /* for (j=0; jworst) /* worst = poctab[j]; /* if (i*worst < best) { /* tabs = i; /* best = i*worst; /* } /* } /* printf("jsr pc,hswitch; 0%o; .+4; L%d\n", tabs, deflab); /* for (i=0; iswval, tabs) == i) { /* printf("2f\n.data\n2:\n"); /* for (; swpo<=lp; swpo++) /* if (lrem(0,swpo->swval,tabs)==i) /* printf("L%d;0%o\n", /* swpo->swlab, /* swpo->swval); /* printf("0\n.text\n"); /* goto break1; /* } /* } /* printf("0\n"); /*break1:; /* } */ esw: printf("* End of switch code.\n"); } sort(afp, alp) struct swtab *afp, *alp; { register struct swtab *bp, *fp, *lp; int intch, t; fp = afp; lp = alp; while (fp < --lp) { intch = 0; for (bp=fp; bpswval == bp[1].swval) { error("Duplicate case (%d)", bp->swval); return(1); } if (bp->swval > bp[1].swval) { intch++; t = bp->swval; bp->swval = bp[1].swval; bp[1].swval = t; t = bp->swlab; bp->swlab = bp[1].swlab; bp[1].swlab = t; } } if (intch==0) break; } return(0); } ispow2(atree) { register int d; register struct tnode *tree; tree = atree; if (!isfloat(tree) && tree->tr2->op==CON) { d = tree->tr2->value; if (d>0 && (d&(d-1))==0) return(d); } return(0); } pow2(atree) struct tnode *atree; { register int d, i; register struct tnode *tree; tree = atree; if (d = ispow2(tree)) { for (i=0; (d = d >> 1)!=0; i++); tree->tr2->value = i; d = tree->op; tree->op = ( d==TIMES? LSHIFT: ASLSH ); } } struct tconst czero { CON, INT, 0, 0}; struct tconst cone { CON, INT, 0, 1}; cbranch(atree, albl, cond, areg) struct tnode *atree; { int l1; register lbl, reg; register struct tnode *tree; struct tnode lbuf; lbl = albl; reg = areg; if ((tree=atree)==0) return; switch(tree->op) { case LOGAND: if (cond) { cbranch(tree->tr1, l1=isn1++, 0, reg); cbranch(tree->tr2, lbl, 1, reg); label(l1); } else { cbranch(tree->tr1, lbl, 0, reg); cbranch(tree->tr2, lbl, 0, reg); } return; case LOGOR: if (cond) { cbranch(tree->tr1, lbl, 1, reg); cbranch(tree->tr2, lbl, 1, reg); } else { cbranch(tree->tr1, l1=isn1++, 1, reg); cbranch(tree->tr2, lbl, 0, reg); label(l1); } return; case EXCLA: cbranch(tree->tr1, lbl, !cond, reg); return; } if ((opdope[tree->op]&RELAT)==0) { lbuf.op = NEQUAL; lbuf.type = tree->type; lbuf.degree = tree->degree; lbuf.tr1 = tree; lbuf.tr2 = &czero; tree = &lbuf; } rcexpr(tree, cctab, reg); branch1(lbl, tree->op, !cond); } branch1(lbl, aop, c) /* generate jump instruction for branching. */ { register op; if(op=aop) cbr(op,c); else printf("b"); printf(" $%d\n", lbl); } cbr(op, flag) { if (flag) op = notrel[op - EQUAL]; printf(" %s", condop[op - EQUAL]); } , !cond, reg); return; } if ((opdope[tree->op]&RELAT)==0) { lbuf.op = NEQUAL; lbuf.type = tree->type; lbuf.degree = tree->degree; lbuf.tr1 = tree; lbuf.tr2 = &czero; tree = &lbuf; } rcexpr(tree, cctab, reg); branch1(lbl, tree->op, !cond); } branch1(lbl, # /* C compiler (file - c12.c) Copyright 1972 Bell Telephone Laboratories, Inc. */ #include "c0h.c" extern int hdebug; optim(atree) struct tnode *atree; { register op, dope; int d1, d2; struct tnode *t; register struct tnode *tree; if ((tree=atree)==0) return(0); op = tree->op; if (op==0) return(tree); dope = opdope[op]; if ((dope&LEAF) != 0) return(tree); if ((dope&BINARY) == 0) return(unoptim(tree)); /* is known to be binary */ if ((dope&COMMUTE)!=0) { acomm: d1 = tree->type; tree = acommute(tree); tree->type = d1; return(tree); } tree->tr1 = optim(tree->tr1); tree->tr2 = optim(tree->tr2); if ((dope&RELAT) != 0) if (degree(tree->tr1) < degree(tree->tr2)) { t = tree->tr1; tree->tr1 = tree->tr2; tree->tr2 = t; tree->op = maprel[op-EQUAL]; } d1 = max(degree(tree->tr1), 1); d2 = max(degree(tree->tr2), 0); if( hdebug > 100 ) printf( "optim(%o), op = %d, d1, d2 = %d, %d\n", tree, op, d1, d2 ); switch (op) { case CALL: tree->degree = 10; break; case QUEST: case COLON: tree->degree = max(d1, d2); break; case MINUS: if (tree->tr2->op==CON) { /* const */ tree->op = PLUS; tree->tr2->value = -tree->tr2->value; goto acomm; } goto def; /* TIMES is handled in acommute */ case ASTIMES: if (ispow2(tree) == 0) { case DIVIDE: case ASDIV: case MOD: case ASMOD: d1 =+ 2; d2 =+ 2; } case LSHIFT: case RSHIFT: if (tree->tr1->op==CON && tree->tr2->op==CON) { const(op, &tree->tr1->value, tree->tr2->value); return(tree->tr1); } def: default: tree->degree = d1==d2? ++d1: max(d1, d2); break; } if( hdebug > 100 ) printf( " degree = %d\n", tree->degree ); return(tree); } unoptim(atree) /* Unary optimization. */ struct tnode *atree; { register struct tnode *subtre, *tree; if ((tree=atree)==0) return(0); if (tree->op==CBRANCH) { tree->btree = optim(tree->btree); return(tree); } subtre = tree->tr1 = optim(tree->tr1); /* try to reduce * & */ if (tree->op==STAR && (subtre->op==AMPER)) return(subtre->tr1); if ((tree->op==AMPER) && (subtre->op==STAR)){ return(subtre->tr1); } if (subtre->op == CON) switch(tree->op) { case NEG: subtre->value = -subtre->value; return(subtre); case COMPL: subtre->value = ~subtre->value; return(subtre); } tree->degree = max(1, degree(subtre)); return(tree); } struct acl { int nextl; int nextn; struct tnode *nlist[20]; struct tnode *llist[21]; }; acommute(atree) { struct acl acl; int d, i, op, flt; register struct tnode *t1, **t2, *tree; struct tnode *t; acl.nextl = 0; acl.nextn = 0; tree = atree; op = tree->op; flt = isfloat(tree); insert(op, tree, &acl); acl.nextl--; if (!flt) { /* put constants together */ t2 = &acl.llist[acl.nextl]; for (i=acl.nextl;i>0&&t2[0]->op==CON&&t2[-1]->op==CON;i--) { acl.nextl--; t2--; const(op, &t2[0]->value, t2[1]->value); } } if (op==PLUS && !flt) { /* toss out "+0" */ if (acl.nextl>0 && (*t2)->op==CON && (*t2)->value==0) { acl.nextl--; t2--; } if (acl.nextl <= 0) return(*t2); /* subsume constant in "&x+c" */ if (t2[0]->op==CON && (t2[0]->value >= 0) && (t2[-1]->op==AMPER)) { t2--; t2[0]->tr1->offset =+ t2[1]->value; acl.nextl--; } } else if (op==TIMES) { t1 = acl.llist[acl.nextl]; if (t1->op==CON && t1->value==0) return(t1); } if (op==PLUS && !flt) distrib(&acl); tree = *(t2 = &acl.llist[0]); d = max(degree(tree), 1); if (op==TIMES && !flt) d++; for (i=0; itr2 = t = *++t2; t1->degree = d = degree(t)>=d? d+1:d; t1->tr1 = tree; tree = t1; } if (tree->op==TIMES && ispow2(tree)) tree->degree = max(degree(tree->tr1), 1); return(tree); } distrib(list) struct acl *list; { /* * Find a list member of the form c1c2*x such * that c1c2 divides no other such constant, is divided by * at least one other (say in the form c1*y), and which has * fewest divisors. Reduce this pair to c1*(y+c2*x) * and iterate until no reductions occur. */ register struct tnode **p1, **p2; struct tnode *t; int ndmaj, ndmin; struct tnode **dividend, **divisor; struct tnode **maxnod, **mindiv; loop: maxnod = &list->llist[list->nextl]; ndmaj = 1000; dividend = 0; for (p1 = list->llist; p1 <= maxnod; p1++) { if ((*p1)->op!=TIMES || (*p1)->tr2->op!=CON) continue; ndmin = 0; for (p2 = list->llist; p2 <= maxnod; p2++) { if (p1==p2 || (*p2)->op!=TIMES || (*p2)->tr2->op!=CON) continue; if ((*p1)->tr2->value == (*p2)->tr2->value) { (*p2)->tr2 = (*p1)->tr1; (*p2)->op = PLUS; (*p1)->tr1 = (*p2); *p1 = optim(*p1); squash(p2, maxnod); list->nextl--; goto loop; } if (((*p2)->tr2->value % (*p1)->tr2->value) == 0) goto contmaj; if (((*p1)->tr2->value % (*p2)->tr2->value) == 0) { ndmin++; mindiv = p2; } } if (ndmin > 0 && ndmin < ndmaj) { ndmaj = ndmin; dividend = p1; divisor = mindiv; } contmaj:; } if (dividend==0) return; t = list->nlist[--list->nextn]; p1 = dividend; p2 = divisor; t->op = PLUS; t->type = (*p1)->type; t->tr1 = (*p1); t->tr2 = (*p2)->tr1; (*p1)->tr2->value = (*p1)->tr2->value / (*p2)->tr2->value; (*p2)->tr1 = t; t = optim(*p2); if (p1 < p2) { *p1 = t; squash(p2, maxnod); list->nextl--; goto loop; } *p2 = t; squash(p1, maxnod); list->nextl--; goto loop; } squash(p, maxp) struct tnode **p, **maxp; { register struct tnode **np; for (np = p; np < maxp; np++) *np = *(np+1); } const(op, vp, av) int *vp; { register int v; v = av; switch (op) { case PLUS: *vp =+ v; return; case TIMES: *vp = *vp * v; return; case AND: *vp =& v; return; case OR: *vp =| v; return; case EXOR: *vp =^ v; return; case DIVIDE: case MOD: if (v==0) error("Divide check"); else if (op==DIVIDE) *vp = *vp / v; else *vp = *vp % v; return; case RSHIFT: *vp = *vp >> v; return; case LSHIFT: *vp = *vp << v; return; } error("C error: const"); } insert(op, atree, alist) struct acl *alist; { register d; register struct acl *list; register struct tnode *tree; int d1, i; struct tnode *t; tree = atree; list = alist; if (tree->op == op) { ins: list->nlist[list->nextn++] = tree; insert(op, tree->tr1, list); insert(op, tree->tr2, list); return; } tree = optim(tree); if (tree->op == op) goto ins; if (!isfloat(tree)) { /* c1*(x+c2) -> c1*x+c1*c2 */ if ((tree->op==TIMES||tree->op==LSHIFT) && tree->tr2->op==CON && tree->tr1->op==PLUS && tree->tr1->tr2->op==CON) { d = tree->tr2->value; if (tree->op==TIMES) tree->tr2->value = tree->tr2->value * tree->tr1->tr2->value; else tree->tr2->value = tree->tr1->tr2->value << d; tree->tr1->tr2->value = d; tree->tr1->op = tree->op; tree->op = PLUS; if (op==PLUS) goto ins; } } d = degree(tree); for (i=0; inextl; i++) { if ((d1=degree(list->llist[i]))llist[i]; list->llist[i] = tree; tree = t; d = d1; } } list->llist[list->nextl++] = tree; } ->op==CON) { d = tree->tr2->value; if (tree->op==TIMES) tree->tr2->va# struct optab { int tabdeg1; int tabtyp1; int tabdeg2; int tabtyp2; char *tabstring; }; struct table { int tabop; struct optab *tabp; }; struct optab regtabop[] { # define cr104 ®tabop[0] 8,0, 63,0, "\tdc\tf'C1'\n", 16,0, 63,0, 0, 16,5, 63,0, "\tdc\ta(A1)\n", # define cr107 ®tabop[3] 8,0, 63,0, "\tdc\tx'Q'\n", # define cr102 ®tabop[4] 16,0, 63,0, "\tb\tA1\n", 127,0, 63,0, "F01\tb\t#1(R)\n", # define cr100 ®tabop[6] 16,0, 63,0, 0, 16,0, 63,5, "\tlfunc\t15,A1\n", 63,0, 63,0, 0, 63,0, 63,5, "F20\tlr\t15,R\n", # define cr106 ®tabop[10] 4,0, 63,0, "\tsr\tR,R\n", 16,3, 63,0, "\tsr\tR,R\n\tic\tR,A1\n", 16,0, 63,0, "\tl\tR,A1\n", 16,4, 63,0, "\tsdr\tFR,FR\n\tle\tFR,A1\n", 16,5, 63,0, "\tld\tFR,A1\n", # define cr32 ®tabop[15] 16,0, 63,0, 0, 16,3, 63,0, "\tlB1\tR,A1\n\tlr\t0,R\n\tO\t0,A2\n\tstB1\t0,A1\n", 84,0, 63,0, 0, 84,3, 63,0, "F01\tlB1\t0,#1(R)\n\tlr\t1,0\n\tO\t1,A2\n\tstB1\t1,#1(R)\n\tlr\tR,0\n", 127,0, 63,0, "F01\tlr\t1,R\n\tlB1\tR,#1(1)\n\tlr\t0,R\n\tO\t0,A2\n\tstB1\t0,#1(1)\n", # define cr35 ®tabop[20] 16,0, 63,0, 0, 16,4, 63,0, "\tla\tR,A1\n", # define cr36 ®tabop[22] 16,18, 63,0, 0, 16,19, 63,0, "\tl\t1,A1\n\tlB1\tR,0(1)\n", 63,19, 63,0, "H01\tsr\t1,1\n\tic\t1,~(R)\n\tlr\tR,1\n", 63,20, 63,0, "H01\tsdr\tFR,FR\n\tle\tFR,~(R)\n", 63,0, 63,0, 0, 63,21, 63,0, "H01\tlBF\tZ,~(R)\n", # define cr37 ®tabop[28] 63,0, 63,0, 0, 63,5, 63,0, "F20\tlcBFr\tZ,Z\n", # define cr38 ®tabop[30] 63,0, 63,0, "F20\tx\tR,=x'ffffffff'\n", # define cr80 ®tabop[31] 16,0, 63,0, 0, 16,5, 63,5, "S20\tstB1\tZ,A1\n", 80,0, 63,0, "S20\tl\t1,A1\n\tstB1\tR,0(1)\n", 16,0, 63,5, "S20\tmovfi\tFR,R\n\tstB1\tR,A1\n", 84,0, 63,5, "S00F05\tmovfi\tFR,R\n\tstB1\tR,#1(R1)\n", 127,0, 63,5, "F03S00\tmovfi\tFR,R\n\tstB1\tR1,#1(R)\n\tlr\tR,R1\n", 127,0, 20,0, "F01S04\tstB1\tR1,#1(R)\n\tlr\tR,R1\n", 127,0, 63,0, 0, 127,5, 63,5, "F03S20\tl\t1,T\n\tstB1\tZ,#1(1)\n", # define cr45 ®tabop[40] 63,0, 4,0, "F20", 63,0, 8,0, "F20\tsrl\tR,C2\n", 63,0, 20,0, "F00S04\tsrl\tR,0(R1)\n", 63,0, 63,0, "S02F20\tl\t1,T\n\tsrl\tR,0(1)\n", # define cr46 ®tabop[44] 63,0, 4,0, "F20", 63,0, 8,0, "F20\tsll\tR,C2\n", 63,0, 20,0, "F00S04\tsll\tR,0(R1)\n", 63,0, 63,0, "S02F20\tl\t1,T\n\tsll\tR,0(1)\n", # define cr40 ®tabop[48] 63,0, 4,0, "F00", 63,0, 16,1, 0, 63,5, 16,5, "F20\tOB2\tZ,A2\n", 63,0, 84,1, "F00S05\tOB2\tZ,#2(R1)\n", 63,0, 20,0, "F00S04\tOr\tR,R1\n", 63,0, 63,0, 0, 63,5, 63,5, "S02F20\tOBF\tZ,T\n", # define cr47 ®tabop[55] 63,0, 4,0, "\tsr\tR,R\n", 63,0, 16,1, "F00\tn\tR,A2\n", 63,0, 84,1, "F00S05\tn\tR,#2(R1)\n", 63,0, 20,0, "F00S04\tnr\tR,R1\n", 63,0, 63,0, "S02F00\tn\tR,T\n", # define cr42 ®tabop[60] 63,0, 16,1, "F00\tm\tR-,A2\n", 63,0, 84,1, "F00S05\tm\tR-,#2(R1)\n", 63,0, 20,0, "F00S04\tmr\tR-,R1\n", 63,0, 63,0, "S02F00\tm\tR-,T\n", 63,5, 16,5, "F00\tmB2\tFR,A2\n", 63,5, 63,5, "S02F00\tmd\tFR,T\n", # define cr43 ®tabop[66] 63,0, 16,1, "F00\tsrda\tR,32\n\td\tR,A2\n", 63,0, 84,1, "F00S05\tl\t0,#2(R1)\n\tsrda\tR,32\n\tdr\tR,0\n", 63,0, 20,0, "F00S04\tl\t0,R1\n\tsrda\tR,32\n\tdr\tR,0\n", 63,0, 63,0, "S02F00\tsrda\tR,32\n\td\tR,T\n", 63,5, 16,5, "F00\tdB2\tFR,A2\n", 63,5, 63,5, "S02F00\tdBF\tFR,T\n", # define cr72 ®tabop[72] 16,3, 63,0, "S00\tsr\t0,0\n\tic\t0,A1\n\tmr\tR-,0\n\tstc\tR,A1\n", 16,0, 63,0, "S00\tm\tR-,A1\n\tst\tR,A1\n", 84,3, 63,0, "S00F05\tsr\t0,0\n\tic\t0,#1(R1)\n\tmr\tR-,0\n\tstc\tR,#1(R1)\n", 84,0, 63,0, "S00F05\tm\tR-,#1(R1)\n\tst\tR,#1(R1)\n", 127,3, 63,0, "F03S00\tl\t1,T\n\tsr\t0,0\n\tic\t0,#1(1)\n\tmr\tR-,0\n\tstc\tR,#1(1)\n", 127,0, 63,0, "F03S00\tl\t1,T\n\tm\tR-,#1(1)\n\tst\tR,#1(1)\n", 16,5, 16,5, "F00\tmB2\tFR,A2\n\tstB1\tFR,A1\n", 16,5, 63,5, "S02F00\tmd\tFR,T\n\tstB1\tFR,A1\n", 127,5, 16,5, "F01\tlB1\tFR,#1(R)\n\tmB2\tFR,A2\n\tstB1\tFR,#1(R)\n", 127,5, 63,5, "S02F01\tlB1\tFR,#1(R)\n\tmd\tFR,T\n\tstB1\tFR,#1(R)\n", # define cr73 ®tabop[82] 16,3, 63,0, 0, 16,0, 63,0, "S00\tlB1\t0,A1\n\tsrda\t0,32\n\tdr\t0,R\n \tstB1\t1,A1\n\tlr\tR+,1\n", 84,3, 63,0, 0, 84,0, 63,0, "S00F05\tlB1\t0,#1(R1)\n\tsrda\t0,32\n\tdr\t0,R\n\tstB1\t1,#1(R1)\n\tlr\tR+,1\n", 127,0, 63,0, "S02F01\tlB1\t0,#1(R)\n\tsrda\t0,32\n\td\t0,T\n\tstB1\t1,#1(R)\n\tlr\tR+,1\n", 16,5, 16,5, "F00\tdB2\tFR,A2\n\tstB1\tFR,A1\n", 16,5, 63,5, "S02F00\tdd\tFR,T\n\tstB1\tFR,A1\n", 127,5, 16,5, "F01\tlB1\tFR,#1(R)\n\tmB2\tFR,A2\n\tstB1\tFR,#1(R)\n", 127,5, 63,5, "S02F01\tlB1\tFR,#1(R)\n\tdd\tFR,T\n\tstB1\tFR,#1(R)\n", # define cr74 ®tabop[91] 16,3, 63,0, 0, 16,0, 63,0, "S00\tlB1\t0,A1\n\tsrda\t0,32\n\tdr\t0,R\n\tstB1\t0,A1\n\tlr\tR,0\n", 84,3, 63,0, 0, 84,0, 63,0, "S00F05\tlB1\t0,#1(R1)\n\tsrda\t0,32\n\tdr\t0,R\n\tstB1\t0,#1(R1)\n\tlr\tR,0\n", 127,0, 63,0, "S02F01\tlB1\t0,#1(R)\n\tsrda\t0,32\n\td\t0,T\n\tstB1\t0,#1(R)\n\tlr\tR,0\n", # define cr75 ®tabop[96] 16,0, 8,0, "\tlB1\tR,A1\n\tsrl\tR,C2\n\tstB1\tR,A1\n", 16,0, 63,0, "S00\tlB1\t1,A1\n\tsrl\t1,0(R)\n\tstB1\t1,A1\n\tlr\tR,1\n", 127,0, 8,0, "F01\tlB1\t1,#1(R)\n\tsrl\t1,C2\n\tstB1\t1,#1(R)\n\tlr\tR,1\n", 84,0, 63,0, "S00F05\tlB1\t1,#1(R1)\n\tsrl\t1,0(R)\n\tstB1\t1,#1(R1)\n\tlr\tR,1\n", 127,0, 63,0, "S02F01\tlB1\t0,#1(R)\n\tl\t1,T\n\tsrl\t0,0(1)\n\tstB1\t0,#1(R)\n\tlr\tR,0\n", # define cr76 ®tabop[101] 16,0, 8,0, "\tlB1\tR,A1\n\tsll\tR,C2\n\tstB1\tR,A1\n", 16,0, 63,0, "S00\tlB1\t1,A1\n\tsll\t1,0(R)\n\tstB1\t1,A1\n\tlr\tR,1\n", 127,0, 8,0, "F01\tlB1\t1,#1(R)\n\tsll\t1,C2\n\tstB1\t1,#1(R)\n\tlr\tR,1\n", 84,0, 63,0, "S00F05\tlB1\t1,#1(R1)\n\tsll\t1,0(R)\n\tstB1\t1,#1(R1)\n\tlr\tR,1\n", 127,0, 63,0, "S02F01\tlB1\t0,#1(R)\n\tl\t1,T\n\tsll\t0,0(1)\n\tstB1\t0,#1(R)\n\tlr\tR,0\n", # define cr70 ®tabop[106] 16,3, 63,0, "S20\tsr\t1,1\n\tic\t1,A1\n\tOr\tR,1\n\tstc\tR,A1\n", 16,0, 63,0, 0, 16,5, 63,5, "S20\tOB1\tZ,A1\n\tstB1\tZ,A1\n", 84,3, 16,1, 0, 84,0, 16,1, "F01\tlB1\t0,#1(R)\n\tO\t0,A2\n\tstB1\t0,#1(R)\n\tlr\tR,0\n", 84,3, 63,0, "S00F05\tsr\t0,0\n\tic\t0,#1(R1)\n\tOr\tR,0\n\tstc\tR,#1(R1)\n", 84,0, 63,0, "S00F05\tO\tR,#1(R1)\n\tst\tR,#1(R1)\n", 127,0, 16,1, "F21\tlr\t1,R\n\tlB1\tR,#1(1)\n\tO\tR,A2\n\tstB1\tR,#1(1)\n", 127,3, 63,0, "F03S00\tl\t1,T\n\tsr\t0,0\n\tic\t0,#1(1)\n\tOr\tR,0\n\tstc\tR,#1(1)\n", 127,0, 63,0, "F03S20\tl\t1,T\n\tO\tR,#1(1)\n\tst\tR,#1(1)\n", 127,5, 16,5, "F01\tl\tFR,#1(R)\n\taB2\tFR,A2\n\tstB1\tFR,#1(R)\n", 127,5, 63,5, "S02F01\tl\tFR,#1(R)\n\tad\tFR,T\n\tstB1\tFR,#1(R)\n", # define cr71 ®tabop[118] 16,3, 63,0, "S20\tsr\t1,1\n\tic\t1,A1\n\tOr\tR,1\n\tlcr\tR,R\n\tstc\tR,A1\n", 16,0, 16,1, "\tl\tR,A1\n\tO\tR,A2\n\tst\tR,A1\n", 16,0, 63,0, 0, 16,5, 63,5, "S20\tOB1\tZ,A1\n\tlcBFr\tZ,Z\n\tstB1\tZ,A1\n", 84,3, 16,1, "F01\tsr\t0,0\n\tic\t0,#1(R)\n\tO\t0,A2\n\tstc\t0,#1(R)\n\tlr\tR,0\n", 84,3, 63,0, "S00F05\tsr\t0,0\n\tic\t0,#1(R1)\n\tOr\t0,R\n\tstc\t0,#1(R1)\n\tlr\tR,0\n", 84,0, 16,1, "F01\tl\t0,#1(R)\n\tO\t0,A2\n\tst\t0,#1(R)\n\tlr\tR,0\n", 84,0, 63,0, "S00F05\tO\tR,#1(R1)\n\tlcr\tR,R\n\tst\tR,#1(R1)\n", 127,3, 16,1, "F21\tlr\t1,R\n\tsr\tR,R\n\tic\tR,#1(1)\n\tO\tR,A2\n\tstc\tR,#1(1)\n", 127,3, 63,0, "F03S00\tl\t1,T\n\tsr\t0,0\n\tic\t0,#1(1)\n\tOr\t0,R\n\tstc\t0,#1(1)\n\tlr\tR,0\n", 127,0, 16,1, "F21\tlr\t1,R\n\tl\tR,#1(1)\n\tO\tR,A2\n\tst\tR,#1(1)\n", 127,0, 63,0, "F03S20\tl\t1,T\n\tOr\tR,#1(1)\n\tlcr\tR,R\n\tst\tR,#1(1)\n", 127,5, 16,5, "F01\tlB1\tFR,#1(R)\n\tsB2\tFR,A2\n\tstB1\tFR,#1(R)\n", 127,5, 63,5, "S02F01\tlB1\tFR,#1(R)\n\tsd\tFR,T\n\tstB1\tFR,#1(R)\n", # define cr51 ®tabop[132] 16,0, 63,0, "\tl\tR,A1\n\tmovif\tFR,R\n", 127,0, 63,0, "F01\tl\tR,#1(R)\n\tmovif\tFR,R\n", 63,0, 63,0, "F20\tmovif\tFR,R\n", # define cr52 ®tabop[135] 63,5, 63,0, "F20\tmovfi\tFR,R\n", }; struct table regtab[] { 106, cr106, 32, cr32, 33, cr32, 35, cr35, 36, cr36, 37, cr37, 38, cr38, 101, cr100, 80, cr80, 40, cr40, 41, cr40, 42, cr42, 43, cr43, 44, cr43, 45, cr45, 46, cr46, 47, cr47, 48, cr40, 49, cr40, 70, cr70, 71, cr71, 72, cr72, 73, cr73, 74, cr74, 75, cr75, 76, cr76, 77, cr70, 78, cr70, 79, cr70, 102, cr102, 51, cr51, 52, cr52, 104, cr104, 107, cr107, 0, 0, }; ®tabop[135] 63,5, 63,0, "F20\tmovfi\tFR,R\n", }; struct table regtab[] { 106, cr106, 32, cr32, 33, cr32, 35, cr35, 36, cr36, 37, cr37, 38, cr38, 101, cr100, 80, cr80, 40, cr40, 41, cr40, 42, cr42, 43, cr43, 44, cr43, 45, cr45, 46, cr46, 47, cr47, 48, cr40, 49, cr40, 70, cr70, 71, cr71, 72, cr72, 73, cr73, 74, cr74, 75, cr75, 76, cr76, 77, cr70, 78, cr70, 79, c# struct optab { int tabdeg1; int tabtyp1; int tabdeg2; int tabtyp2; char *tabstring; }; struct table { int tabop; struct optab *tabp; }; struct optab cctabop[] { # define cc60 &cctabop[0] 63,0, 4,0, 0, 63,4, 4,0, 0, 63,5, 4,0, 0, 63,4, 4,4, 0, 63,5, 4,5, "F20\tltBFr\tZ,Z\n", 63,0, 16,1, 0, 63,4, 16,5, 0, 63,5, 16,5, "F20\tcBF\tZ,A2\n", 63,0, 84,1, 0, 63,4, 84,4, 0, 63,4, 84,5, "F00S05\tcBF\tZ,#2(R1)\n", 63,0, 20,0, "F00S04\tcr\tR,R1\n", 63,0, 63,0, 0, 63,4, 63,4, 0, 63,4, 20,4, 0, 63,5, 20,5, 0, 63,5, 63,5, "S02F20\tcBF\tZ,T\n", # define rest &cctabop[17] 63,0, 63,0, 0, 63,4, 63,4, "H00", }; struct table cctab[] { 60, cc60, 61, cc60, 62, cc60, 63, cc60, 64, cc60, 65, cc60, 66, cc60, 67, cc60, 68, cc60, 69, cc60, 0, 0, }; 63,0, 16,1, 0, 63,4, 16,5, 0, 63,5, 16,5, "F20\tcBF\tZ,A2\n", 63,0, 84,1, 0, 63,4, 84,4, 0, 63,4, 84,5, "F00S05\tcBF\tZ,#2(R1)\n", 63,0, 20,0, "F00S04\tcr\tR,R1\n", 63,0, 63,0, 0, 63,4, 63,4, 0,# include "prh.c" /* ibm preprocessor */ extern int cin, cout; int ppeekc; int inlno; int lno1; int lno2; int instring; int exfail; int infil; int f1; int f2; int depth; char *lp; char *ppline; int lineno; struct symtab *symtab; extern struct symtab stab[]; struct symtab *defloc; struct symtab *incloc; struct symtab *eifloc; struct symtab *ifdloc; struct symtab *ifnloc; struct symtab *locsys; int trulvl; int flslvl; char *stringbuf; char ln [512]; extern char sbf[]; main(argc, argv) char **argv; { if( argc==0 ){ /* we are in bfor situation */ cout = copen( "**2", 'w' ); expand( "*S*" ); } else if( argc >= 3 ){ cout = copen( argv[2], 'w' ); expand( argv[1] ); } else { perror( "Arg count" ); } if( exfail ) cexit(1); } expand(file) char *file; { register int c; register char *rlp; if ((infil = f1 = copen(file, 'r')) < 0) { perror("Can't find %s", file); return; } symtab = stab; for (c=0; c='0' && ppeekc<='9' ) ++lno1; ungetc(ppeekc,infil); inlno = lno1; while(getline()) { if ( infil==f2 ) cputc(001, cout); /*SOH: insert */ if (ln[0] != '#' && flslvl ==0) for (rlp = ppline; c = *rlp++;) cputc(c, cout); cputc('\n', cout); } cclose(f1); } getline() { register int c, sc, state; struct symtab *np; char *namep, *filname; if (infil==f1) lineno++; depth=0; lp = ppline; *lp = '\0'; state = 0; c = getch(); if( inlno ){ /* delete line number */ while( c>='0' && c<='9' ) c = getch(); if( c == '#' ) c = getch(); } if (c == '#') state = 1; while (c!='\n' && c!='\0') { if (alpha(c) || c == '_') { namep = lp; sch(c); while (alpha(c=getch()) ||'0'<=c && c<='9' ||c=='_') sch(c); sch('\0'); lp--; if (state>3) { if (flslvl==0 &&(state+!plookup(namep,0)->name[0])==5) trulvl++; else flslvl++; out: while (c!='\n' && c!= '\0') c = getch(); return(c); } if (state!=2 || flslvl==0) { ungetc(c,infil); /* hide possible '(' after name */ np = plookup(namep, state); c = getch(); } if (state==1) { if (np==defloc) state = 2; else if (np==incloc) state = 3; else if (np==ifnloc) state = 4; else if (np==ifdloc) state = 5; else if (np==eifloc) { if (flslvl) --flslvl; else if (trulvl) --trulvl; else perror("If-less endif"); goto out; } else { perror("Undefined control"); while (c!='\n' && c!='\0') c = getch(); return(c); } } else if (state==2) { if (flslvl) goto out; np->value = stringbuf; savch(c); while ((c=getch())!='\n' && c!='\0') savch(c); savch('\0'); trimsav(); return(1); } continue; } else if ((sc=c)=='\'' || sc=='"') { sch(sc); filname = lp; instring++; while ((c=getch())!=sc && c!='\n' && c!='\0') { sch(c); if (c=='\\') sch(getch()); } instring = 0; if (flslvl) goto out; if (state==3) { *lp = '\0'; while ((c=getch())!='\n' && c!='\0'); if (infil==f2) perror("Nested 'include'"); if ((f2 = copen(filname, 'r'))<0) perror("Missing file %s", filname); else { infil = f2; lno2 = 0; if( (ppeekc = getch() ) >= '0' && ppeekc<='9' ) ++lno2; ungetc(ppeekc,infil); inlno = lno2; } return(c); } } sch(c); c = getch(); } sch('\0'); if (state>1) perror("Control syntax"); return(c); } insym (sp, namep) struct symtab **sp; char *namep; { register struct symtab *np; *sp = np = plookup(namep, 1); np->value = np->name; } perror(s, x) { printf( 2, "*F* %d: ", lineno); printf( 2, s, x); printf( 2, "\n"); exfail++; } sch(c) { register char *rlp; rlp = lp; if (rlp==ppline+510) perror("Line overflow"); *rlp++ = c; if (rlp>ppline+511) rlp = ppline+511; lp = rlp; } savch(c) { *stringbuf++ = c; if (stringbuf-sbf sbf) *--stringbuf = '\0'; stringbuf++; } getch() { register int c; loop: if ((c=getc1())=='/' && !instring) { if ((c=getc1())!='*') { ungetc(c,infil); return('/'); } for(;;) { c = getc1(); cloop: switch (c) { case '\0': return('\0'); case '*': if ((c=getc1())=='/') goto loop; goto cloop; case '\n': if (infil==f1) { cputc('\n', cout); lineno++; } depth=0; continue; } } } return(c); } getc1() { register c; if ((c = cgetc(infil)) <= 0 && infil==f2) { cclose(f2); infil = f1; inlno = lno1; cputc('\n', cout); c = getc1(); } if (c<0) return(0); return(c); } plookup(namep, enterf) char *namep; { register char *np, *snp; register struct symtab *sp; int i, c, around; np = namep; around = i = 0; while (c = *np++) i =+ c; i = i % symsiz; sp = &symtab[i]; while (sp->name[0]) { snp = sp; np = namep; while (*snp++ == *np) if (*np++ == '\0' || np==namep+8) { if (!enterf) subst(namep, sp); return(sp); } if (++sp >= &symtab[symsiz]) if (around++) { perror("too many defines"); cexit(1); } else sp = symtab; } if (enterf) { snp = namep; for (np = &sp->name[0]; np < &sp->name[8];) if (*np++ = *snp) snp++; } return(sp); } char revbuff[200], *bp; backsch(c) { if (bp-revbuff > 200) perror("Excessive define looping", bp--); *bp++ = c; } subst(np, sp) char *np; struct symtab *sp; { register char *vp; lp = np; bp = revbuff; if (depth++>100) { perror("define recursion loop\n"); return; } if ((vp = sp->value) == 0) return; /* arrange that define unix unix still has no effect, avoiding rescanning */ if (streq(sp->name,sp->value)) { while (*vp) sch(*vp++); return; } backsch(' '); if (*vp == '(') expdef(vp); else while (*vp) backsch(*vp++); backsch(' '); while (bp>revbuff) ungetc(*--bp, infil); } expdef(proto) char *proto; { char buffer[100], *parg[20], *pval[20], name[20], *cspace, *wp; char protcop[100], *pr; int narg, k, i, c; pr = protcop; while (*pr++ = *proto++); proto= protcop; for (narg=0; (parg[narg] = token(&proto)) != 0; narg++) ; /* now scan input */ cspace = buffer; if ((c=getch()) == ' ') while ((c=getch()) == ' '); ungetc(c,infil); for(k=0; pval[k] = coptok(&cspace); k++); if (k!=narg) perror("define argument mismatch"); while (c= *proto++) { if (!letter(c)) sch(c); else { wp = name; *wp++ = c; while (letnum(*proto)) *wp++ = *proto++; *wp = 0; for (k=0; k 0) { if (stc == '\0') { perror ("non terminated macro call"); val=0; break; } if (stc == '"' || stc == '\'') { stop = stc; if (stop == '\'') *(*cpp)++ = '\''; while ( (stc = getch()) != stop) { if (stc == '\n' || stc == '0') { perror ("non-terminated string"); break; } if (stc == '\\') if ((stc= getch()) != stop && stc != '\\') *(*cpp)++ = '\\'; *(*cpp)++ = stc; } if (stop = '\'') *(*cpp)++ = '\''; } else if (stc == '\\') { stc = getch(); if (stc != '"' && stc != '\\') *(*cpp)++ = '\\'; *(*cpp)++ = stc; } else { *(*cpp)++ = stc; if (stc== '(') paren++; if (stc == ')') paren--; } } *(*cpp)++ = 0; ungetc(stc,infil); return(val); } letter(c) { if (alpha(c) || (c == '_')) return (1); else return(0); } letnum(c) { if (letter(c) || (c >= '0' && c <= '9')) return(1); else return(0); } streq(s,t) char *s, *t; { int c; while ( (c= *s++) == *t++) if (c==0) return(1); return(0); } alpha(c) { switch(c) { case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u': case 'v': case 'w': case 'x': case 'y': case 'z': case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': case 'Y': case 'Z': return(1); } return(0); } : case 'f': case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u': case 'v': case 'w': case 'x': case 'y': case 'z': case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N': case 'O': case 'P': case # include "prh.c" struct symtab stab[symsiz]; char sbf[SBSIZE]; ': case 'X': case 'Y': case 'Z': return(1); } return(0); } : case 'f': case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': case 's': case 't': case 'u': case 'v': case 'w': case 'x': case 'y': case 'z': case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': case 'M': case 'N': case 'O': case 'P': case # /* C compiler ( file - c00.c ) Copyright 1972 Bell Telephone Laboratories, Inc. */ #include "c0h.c" int isn1 10000; int isn 1; int peeksym -1; int line 1; int assemblycode; struct kwtab { /* key word table */ char *kwname; int kwval; } kwtab[] { "int", INT, "char", CHAR, "float", FLOAT, /*float is being tested. */ "double", DOUBLE, /* double is being tested.*/ "struct", STRUCT, "auto", AUTO, "extern", EXTERN, "static", STATIC, "register", AUTO, "goto", GOTO, "return", RETURN, "if", IF, "while", WHILE, "else", ELSE, "switch", SWITCH, "case", CASE, "break", BREAK, "continue", CONTIN, "do", DO, "default", DEFAULT, "for", FOR, "bliss", BLISS, "fortran", FORTRAN, "asm", ASM, "sizeof", SIZEOF, 0, 0, }; main(argc, argv) /* main for the entire C compiiler */ char *argv[]; { extern cin, cout; int treespace[ossiz]; register char *sp, *np; char *namep; register struct kwtab *ip; int i,c; if ('r' + 1 == 's') {machine = UNIX;} else machine = IBM; nerror = 0; i=1; if(*argv[i]== '-') { switch(c=argv[i][1]) { default: {error("illegal option - %s",c); i++; break;} } } if((argc-i)<2) { error("Arg count"); cexit(1); } if((cin=copen(argv[i],'r'))<0) { error("Can't find %s", argv[i]); cexit(1); } if ((assemblycode = cout = copen(argv[i+1], 'w', 'e')) < 0) { error("Can't create temp"); cexit(1); } if ((argc - i)>2) proflg++; xdflg++; for (ip=kwtab; (np = ip->kwname); ip++) { /* Initialize the symbol table by */ for (sp = symbuf; sphclass = KEYWC; np->htype = ip->kwval; } xdflg = 0; treebase = treespace+10; /* Treebase is a constant pointing to the base of the syntax tree. */ namep=argv[i]; while (alphanum(*namep)) namep++; *namep= '\0'; printf("%.7s startup\n", argv[i]); while(!eof) { /* This is the main loop of the compiler. It reads all */ extdef(); /* of the input program and calls functions which */ blkend(); /* compile that input. */ } transvec(); /* Produce a transfer vector. */ hgprloc(hglit); printf(" ltorg\n"); printf(" end %s\n", mainfile ? "$main$": " "); cexit(nerror!=0); } error(s, p1, p2, p3, p4, p5, p6) { extern cout; cout = 1; /* Switch output to ft06f001. */ printf("%d: ", line); printf(s, p1, p2, p3, p4, p5, p6); putchar('\n'); nerror++; cout = assemblycode; /* Switch back. */ } tree() /* The expression compiler - returns root node of tree.*/ { #define SEOF 200 #define SSIZE 20 int *op, opst[SSIZE], *pp, prst[SSIZE]; register int andflg, o; register struct hshtab *cs; struct hshtab *p1, *p2; int p, ps, os, *np; osleft = ossiz; space = treebase; op = opst; pp = prst; cp = cmst; *op = SEOF; *pp = 06; andflg = 0; advanc: switch (o=symbol()) { case NAME: cs = csym; if (cs->hclass==0 && cs->htype==0) if(nextchar()=='(') { /* set function */ cs->hclass = GXTERN; cs->htype = FUNC; cs->hflags =| GLOBAL; } else if (initflg) cs->hclass = EXTERN; else { /* set label */ cs->htype = ARRAY; if (cs->hoffset==0) cs->hoffset = isn++; } p1 = block(2,NAME,cs->htype,cs->hdimp, cs->hclass,0); if (cs->hclass==EXTERN || cs->hclass==GXTERN || cs->hclass==FORTRAN) { np = cs->name; for (o=0; o<4; o++) { pblock(*np); if (((*np++)&~0177) == 0) break; } } else pblock(cs->hoffset); if (p1->op == NAME && (p1->class == GXTERN || p1->class == FORTRAN)) { p2 = block(1,STAR,p1->type,p1->dimp,p1); p1->type = incref(p1->type); /* change N to pointer to N. */ p1 = p2; } *cp++ = p1; goto tand; case SFCON: /* short floating constant - an optimization for the PDP 11. */ case FCON: if (!initflg) prtflo(1,0); case CON: *cp++ = block(1,o,(o==CON?INT:DOUBLE),0,cval); goto tand; /* fake a static char array */ case STRING: if( initflg ) error( "initializer too complicated" ); hgprloc( hgstring ); getstr(); hgprloc( hgcode ); *cp++ = block(3, NAME, ARRAY+CHAR,0,STATIC,0,cval); tand: if(cp>=cmst+cmsiz) { error("Expression overflow"); cexit(1); } if (andflg) goto syntax; andflg = 1; goto advanc; case INCBEF: /* increment before */ case DECBEF: /* decrement before */ if (andflg) o =+ 2; goto oponst; case COMPL: /* complement */ case EXCLA: /* exclaimation point */ case SIZEOF: if (andflg) goto syntax; goto oponst; case MINUS: if (!andflg) o = NEG; andflg = 0; goto oponst; case AND: case TIMES: if (andflg) andflg = 0; else if(o==AND) o = AMPER; else o = STAR; goto oponst; case LPARN: if (andflg) { o = symbol(); if (o==RPARN) o = MCALL; else { peeksym = o; o = CALL; andflg = 0; } } goto oponst; case RBRACK: case RPARN: if (!andflg) goto syntax; goto oponst; case DOT: case ARROW: mosflg++; break; } /* binaries */ if (!andflg) goto syntax; andflg = 0; oponst: p = (opdope[o]>>9) & 077; if ((o==COMMA || o==COLON) && initflg) p = 05; opon1: ps = *pp; if (p>ps || p==ps && (opdope[o]&RASSOC)!=0) { switch (o) { case INCAFT: case DECAFT: p = 37; break; case LPARN: case LBRACK: case CALL: p = 04; } if(op>=opst+SSIZE) { error("expression overflow"); cexit(1); } *++op = o; *++pp = p; goto advanc; } --pp; switch (os = *op--) { case SEOF: /* see bottom of stack */ peeksym = o; build(0); /* flush conversions */ return(*--cp); case CALL: /* ftn call operator eg f(x) */ if (o!=RPARN) goto syntax; build(os); goto advanc; case MCALL: /* empty arguement call eg f() */ *cp++ = block(0,0,0,0); /* 0 arg call */ os = CALL; goto fbuild; case LPARN: if (o!=RPARN) goto syntax; goto advanc; case LBRACK: /* [ - for subscripts */ if (o!=RBRACK) goto syntax; build(LBRACK); goto advanc; } fbuild: build(os); goto opon1; syntax: error("Expression syntax"); errflush(o); return(0); } /* End of the tree function. */ declare(askw, tkw, offset, elsize) /* Parses a list of declarators. */ { register int o; register int skw; int corr; corr = NO; skw = askw; mosflg = skw==MOS; if (endp == YES) ndp = 0; if ((peeksym = symbol() ) == RPARN) corr = YES; do { if (endp == YES) { ndp =+ 1; } /* Count nbr of declared parameters. */ offset =+ decl1(skw, tkw, offset, elsize, YES); if (xdflg && skw!=MOS) return(offset); } while ((o=symbol()) == COMMA); if (endp == YES && corr == YES) ndp = 0; endp = NO; if (o==SEMI || o==RPARN && skw==ARG1) return(offset); decsyn(o); return(offset); } decl1(askw, tkw, offset, elsize, declr) { int t1, chkoff; register int type, skw; register struct hshtab *dsym; int predef; int savetype; skw = askw; chkoff = 0; mosflg = skw==MOS; if ((peeksym=symbol())==SEMI || peeksym==RPARN) return(0); if ((t1=getype()) < 0) goto syntax; type = 0; do type = type<<2 | (t1 & 030); while (((t1=(t1>>2)) & 030)!=0); type =| tkw; dsym = defsym; if (dsym->hclass != 0) predef = YES; else predef = NO; if (!(dsym->hclass==0 || (skw==ARG && dsym->hclass==ARG1) || ((skw==EXTERN || skw==GXTERN || skw==FORTRAN) && (dsym->hclass==EXTERN || dsym->hclass==GXTERN || dsym->hclass==FORTRAN) && dsym->htype==type))) if (skw==MOS && dsym->hclass==MOS && dsym->htype==type) chkoff = 1; else { redec(); goto syntax; } dsym->htype = type; if (skw) { savetype = dsym->hclass; dsym->hclass = skw; } if ((declr==YES) && (skw==EXTERN)) { if (predef == NO) { dsym->hclass = GXTERN; dsym->hflags =| GLOBAL; } else if (dsym->hflags & PERM) dsym->hclass = savetype; } if (skw==ARG1) { if (paraml==0) paraml = dsym; else parame->hoffset = dsym; parame = dsym; } if (elsize) { dsym->lenp = dimp; dimtab[dimp++] = elsize; } elsize = 0; if (skw==MOS) { elsize = length(dsym); if (elsize != 1) { elsize =+ ((offset + 3) & ~3) - offset; offset = ((offset + 3) & ~3); /* round up to multiple of 4 */ } if (chkoff && dsym->hoffset != offset) redec(); dsym->hoffset = offset; } if ((dsym->htype&030)==FUNC) { if (dsym->hclass!=EXTERN && dsym->hclass!=AUTO && dsym->hclass!=GXTERN && dsym->hclass!=FORTRAN) error("Bad function"); dsym->hclass = dsym->hclass==FORTRAN?FORTRAN:GXTERN; dsym->hflags =| GLOBAL; } if (dsym->hclass==AUTO) { dsym->hoffset = autolen; autolen =+ rlength(dsym); } else if (dsym->hclass==STATIC) { dsym->hoffset = isn; hgprloc(hgdata); printf("$%d equ * \n", isn++); printf(" dc %dx'00' \n", rlength(dsym) ); hgprloc(hgcode); } else if (dsym->hclass==REG) { if ((type&07)>CHAR && (type&030)==0 || (type&030)>PTR || regvar>5) error("Bad register %o", type); dsym->hoffset = ++regvar; } syntax: return(elsize); } getype() { register int o, type; register struct hshtab *ds; switch(o=symbol()) { case TIMES: return(getype()<<2 | PTR); case LPARN: type = getype(); if ((o=symbol()) != RPARN) goto syntax; ds = defsym; goto getf; case NAME: defsym = ds = csym; type = 0; ds->ssp = dimp; getf: switch(o=symbol()) { case LPARN: if (xdflg) { xdflg = 0; ds = defsym; declare(ARG1, 0, 0, 0); defsym = ds; xdflg++; } else if ((o=symbol()) != RPARN) goto syntax; type = type<<2 | FUNC; goto getf; case LBRACK: if ((o=symbol()) != RBRACK) { peeksym = o; cval = conexp(); for (o=ds->ssp; oname); } alphanum(c) { switch(c) { case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': case 'g': case 'h': case 'i': case 'j': case 'k': case 'l': case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': case 'm': case 'n': case 'o': case 'p': case 'q': case 'r': case 'M': case 'N': case 'O': case 'P': case 'Q': case 'R': case 's': case 't': case 'u': case 'v': case 'w': case 'x': case 'y': case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': case 'Y': case 'z': case '0': case '1': case '2': case '3': case '4': case 'Z': case '5': case '6': case '7': case '8': case '9': return(1); default: return(0); } } 'k': case 'l': case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': case '# define SBSIZE 20000 # define symsiz 1000 struct symtab { char name[8]; char *value; }; 'R': case 's': case 't': case 'u': case 'v': case 'w': case 'x': case 'y': case 'S': case 'T': case 'U': case 'V': case 'W': case 'X': case 'Y': case 'z': case '0': case '1': case '2': case '3': case '4': case 'Z': case '5': case '6': case '7': case '8': case '9': return(1); default: return(0); } } 'k': case 'l': case 'G': case 'H': case 'I': case 'J': case 'K': case 'L': case '$regtab / init expression :cr104: %c,n dc f'C1' %a,n %ad,n dc a(A1) / inib constant :cr107: %c,n dc x'Q' / goto :cr102: %a,n b A1 %n*,n F* b #1(R) / function call :cr100: %a,n %a,nd lfunc 15,A1 %n,n %n,nd FX lr 15,R / addressible :cr106: %z,n sr R,R %ab,n sr R,R ic R,A1 %a,n l R,A1 %af,n sdr FR,FR le FR,A1 %ad,n ld FR,A1 / ++,-- postfix :cr32: %a,n %ab,n lB1 R,A1 lr 0,R O 0,A2 stB1 0,A1 %e*,n %eb*,n F* lB1 0,#1(R) lr 1,0 O 1,A2 stB1 1,#1(R) lr R,0 %n*,n F* lr 1,R lB1 R,#1(1) lr 0,R O 0,A2 stB1 0,#1(1) / &unary :cr35: %a,n %af,n la R,A1 / *unary indirection :cr36: %aip,n %abp,n l 1,A1 lB1 R,0(1) %nbp,n H* sr 1,1 ic 1,~(R) lr R,1 %nfp,n H* sdr FR,FR le FR,~(R) %n,n %ndp,n H* lBF Z,~(R) / - unary minus :cr37: %n,n %nd,n FX lcBFr Z,Z / ~ ones complement :cr38: %n,n FX x R,=x'ffffffff' / = assignment :cr80: %a,n %ad,nd SX stB1 Z,A1 %a*,n SX l 1,A1 stB1 R,0(1) %a,nd SX movfi FR,R stB1 R,A1 %e*,nd S F1* movfi FR,R stB1 R,#1(R1) %n*,nd F*S S movfi FR,R stB1 R1,#1(R) lr R,R1 %n*,e F* S1 stB1 R1,#1(R) lr R,R1 %n*,n %nd*,nd FS* SX l 1,T stB1 Z,#1(1) / right shift :cr45: %n,z FX %n,c FX srl R,C2 %n,e F S1 srl R,0(R1) %n,n SS FX l 1,T srl R,0(1) / << :cr46: %n,z FX %n,c FX sll R,C2 %n,e F S1 sll R,0(R1) %n,n SS FX l 1,T sll R,0(1) / +, -, |, ^ binary RR or RX instructions except & :cr40: %n,z F %n,aw %nd,ad FX OB2 Z,A2 %n,ew* F S1* OB2 Z,#2(R1) %n,e F S1 Or R,R1 %n,n %nd,nd SS FX OBF Z,T / & -- binary and :cr47: %n,z sr R,R %n,aw F n R,A2 %n,ew* F S1* n R,#2(R1) %n,e F S1 nr R,R1 %n,n SS F n R,T / * -- R must be odd & this will clobber the even register R- multiply :cr42: %n,aw F m R-,A2 %n,ew* F S1* m R-,#2(R1) %n,e F S1 mr R-,R1 %n,n SS F m R-,T %nd,ad F mB2 FR,A2 %nd,nd SS F md FR,T / R must be even. divide and mod :cr43: %n,aw F srda R,32 d R,A2 %n,ew* F S1* l 0,#2(R1) srda R,32 dr R,0 %n,e F S1 l 0,R1 srda R,32 dr R,0 %n,n SS F srda R,32 d R,T %nd,ad F dB2 FR,A2 %nd,nd SS F dBF FR,T / =* :cr72: %ab,n S sr 0,0 ic 0,A1 mr R-,0 stc R,A1 %a,n S m R-,A1 st R,A1 %eb*,n S F1* sr 0,0 ic 0,#1(R1) mr R-,0 stc R,#1(R1) %e*,n S F1* m R-,#1(R1) st R,#1(R1) %nb*,n FS* S l 1,T sr 0,0 ic 0,#1(1) mr R-,0 stc R,#1(1) %n*,n FS* S l 1,T m R-,#1(1) st R,#1(1) %ad,ad F mB2 FR,A2 stB1 FR,A1 %ad,nd SS F md FR,T stB1 FR,A1 %nd*,ad F* lB1 FR,#1(R) mB2 FR,A2 stB1 FR,#1(R) %nd*,nd SS F* lB1 FR,#1(R) md FR,T stB1 FR,#1(R) / =/; R must be odd on integers :cr73: %ab,n %a,n S lB1 0,A1 srda 0,32 dr 0,R stB1 1,A1 lr R+,1 %eb*,n %e*,n S F1* lB1 0,#1(R1) srda 0,32 dr 0,R stB1 1,#1(R1) lr R+,1 %n*,n SS F* lB1 0,#1(R) srda 0,32 d 0,T stB1 1,#1(R) lr R+,1 %ad,ad F dB2 FR,A2 stB1 FR,A1 %ad,nd SS F dd FR,T stB1 FR,A1 %nd*,ad F* lB1 FR,#1(R) mB2 FR,A2 stB1 FR,#1(R) %nd*,nd SS F* lB1 FR,#1(R) dd FR,T stB1 FR,#1(R) / =mod; R must be odd on integers :cr74: %ab,n %a,n S lB1 0,A1 srda 0,32 dr 0,R stB1 0,A1 lr R,0 %eb*,n %e*,n S F1* lB1 0,#1(R1) srda 0,32 dr 0,R stB1 0,#1(R1) lr R,0 %n*,n SS F* lB1 0,#1(R) srda 0,32 d 0,T stB1 0,#1(R) lr R,0 / =>> :cr75: %a,c lB1 R,A1 srl R,C2 stB1 R,A1 %a,n S lB1 1,A1 srl 1,0(R) stB1 1,A1 lr R,1 %n*,c F* lB1 1,#1(R) srl 1,C2 stB1 1,#1(R) lr R,1 %e*,n S F1* lB1 1,#1(R1) srl 1,0(R) stB1 1,#1(R1) lr R,1 %n*,n SS F* lB1 0,#1(R) l 1,T srl 0,0(1) stB1 0,#1(R) lr R,0 / =<< :cr76: %a,c lB1 R,A1 sll R,C2 stB1 R,A1 %a,n S lB1 1,A1 sll 1,0(R) stB1 1,A1 lr R,1 %n*,c F* lB1 1,#1(R) sll 1,C2 stB1 1,#1(R) lr R,1 %e*,n S F1* lB1 1,#1(R1) sll 1,0(R) stB1 1,#1(R1) lr R,1 %n*,n SS F* lB1 0,#1(R) l 1,T sll 0,0(1) stB1 0,#1(R) lr R,0 / =+ =& =| =^ :cr70: %ab,n SX sr 1,1 ic 1,A1 Or R,1 stc R,A1 %a,n %ad,nd SX OB1 Z,A1 stB1 Z,A1 %eb*,aw %e*,aw F* lB1 0,#1(R) O 0,A2 stB1 0,#1(R) lr R,0 %eb*,n S F1* sr 0,0 ic 0,#1(R1) Or R,0 stc R,#1(R1) %e*,n S F1* O R,#1(R1) st R,#1(R1) %n*,aw FX* lr 1,R lB1 R,#1(1) O R,A2 stB1 R,#1(1) %nb*,n FS* S l 1,T sr 0,0 ic 0,#1(1) Or R,0 stc R,#1(1) %n*,n FS* SX l 1,T O R,#1(1) st R,#1(1) %nd*,ad F* l FR,#1(R) aB2 FR,A2 stB1 FR,#1(R) %nd*,nd SS F* l FR,#1(R) ad FR,T stB1 FR,#1(R) / =- :cr71: %ab,n SX sr 1,1 ic 1,A1 Or R,1 lcr R,R stc R,A1 %a,aw l R,A1 O R,A2 st R,A1 %a,n %ad,nd SX OB1 Z,A1 lcBFr Z,Z stB1 Z,A1 %eb*,aw F* sr 0,0 ic 0,#1(R) O 0,A2 stc 0,#1(R) lr R,0 %eb*,n S F1* sr 0,0 ic 0,#1(R1) Or 0,R stc 0,#1(R1) lr R,0 %e*,aw F* l 0,#1(R) O 0,A2 st 0,#1(R) lr R,0 %e*,n S F1* O R,#1(R1) lcr R,R st R,#1(R1) %nb*,aw FX* lr 1,R sr R,R ic R,#1(1) O R,A2 stc R,#1(1) %nb*,n FS* S l 1,T sr 0,0 ic 0,#1(1) Or 0,R stc 0,#1(1) lr R,0 %n*,aw FX* lr 1,R l R,#1(1) O R,A2 st R,#1(1) %n*,n FS* SX l 1,T Or R,#1(1) lcr R,R st R,#1(1) %nd*,ad F* lB1 FR,#1(R) sB2 FR,A2 stB1 FR,#1(R) %nd*,nd SS F* lB1 FR,#1(R) sd FR,T stB1 FR,#1(R) / int -> float :cr51: %a,n l R,A1 movif FR,R %n*,n F* l R,#1(R) movif FR,R %n,n FX movif FR,R / float, double -> int :cr52: %nd,n FX movfi FR,R }; struct table regtab[] { / c code tables-- compile to register 106, cr106, / LOAD / 30, cr30, / INCBEF / 31, cr30, / DECBEF 32, cr32, / INCAFT 33, cr32, / DECAFT 35, cr35, / AMPER 36, cr36, / star - indirection 37, cr37, / negation 38, cr38, / complement 101, cr100, / function call 80, cr80, / assign 40, cr40, / binary addition 41, cr40, / binary subtraction 42, cr42, / * times 43, cr43, / / divide 44, cr43, / mod 45, cr45, / right shift 46, cr46, / << left shift 47, cr47, / binary and 48, cr40, / binary or 49, cr40, / binary xor 70, cr70, / =+, 71, cr71, / =-, 72, cr72, / =* 73, cr73, / =/ 74, cr74, / =% 75, cr75, / =>> 76, cr76, / =<< 77, cr70, / =&, 78, cr70, / =|, 79, cr70, / =^, 102, cr102, / goto 51, cr51, 52, cr52, 104, cr104, / init expression 107, cr107, / inib constant 0, 0, }; nary addition 41, cr40, / binary subtraction 42, cr42, / * times 43, cr43, / / divide 44, cr43, / mod 45, cr45, / right shift 46, cr46, / << left shift 47, cr47, / binary and 48, cr40, / binary or 49, cr40, / bi_clenf (s) /* counts length of string */ char *s; { int n; for (n=0; *s++ != '\0'; n++); return (n);} / =>> 76, cr76, / =<< 77, cr70, / =&, 78, cr70, / =|, 79, cr70, / =^, 102, cr102, / goto 51, cr51, 52, cr52, 104, cr104, / init expression 107, cr107, / inib constant 0, 0, }; nary addition 41, cr40, / binary subtraction 42, cr42, / * times 43, cr43, / / divide 44, cr43, / mod 45, cr45, / right shift 46, cr46, / << left shift 47, cr47, / binary and 48, cr40, / binary or 49, cr40, / bi# define LPARM 100 char *_argv_[20]; _gtargs() { static char pbuff[LPARM+2]; int nchar, argc, i; char *parm, **parmlist, *newp; extern char *_definp, *_defout; parmlist = genreg (3,0); /* find register 1 which was copied to 3 */ if (parmlist==0) return(0); parm = *parmlist; /* find actual address of parameter string */ /* this won't cross compile ... parm =& 077777777; /* get 24-bit address */ i = parm; i = i<<8; i = i>>8; parm = i; /* next lines for OS ... */ nchar = parm[0]*256+parm[1]; parm =+ 2; /* actual start of characters */ /* next line for TSS ... nchar = parm[-1]; /* ... */ if (nchar==0) return (0); newp = pbuff; if (nchar > LPARM) nchar= LPARM; for (i=0; i') _defout = parm+1; else /* normal argument */ _argv_[argc++] = parm; while (*parm != ' ') parm++; } } . */ if (nchar==0) return (0); newp = pbuff; if (nchar > LPARM) nchar= LPARM; for (i=0; i') _defout = parm+1; else /* no_rel() { return; } _access(x) { return(x); } ile (*parm != ' ') parm++; } } . */ if (nchar==0) return (0); newp = pbuff; if (nchar > LPARM) nchar= LPARM; for (i=0; i') _defout = parm+1; else /* no_access(name,fn,dir) char *name; { static char ddn[20]; char line[40], *jfcb; int rd; if(_scomp(name, "TERMINAL")== '=') return(name); _pad(line,name,35); if (_isddn(line)) { _pad(ddn,name,8); ddn[9]=0; return(ddn); } if (jfcb= _isdsn(line)) { _pad(ddn,jfcb,8); ddn[9]= 0; return(ddn); } if (dir == 'r' || dir == 'R') return(0); _pad(line, "C##0,vi,dsname=",15); _pad(line+15, name,24); line[3] = '0'+fn; line[39] = 39; /* 39 is hex 27 which is the character to end parameter string */ _pad(ddn,"C##0",8); ddn[3] = '0'+fn; ddn[9] = 0; rd = _ddef(line); return( rd? ddn : 0); } _pad(b, s, n) char *b, *s; { int i, c; for(i=0; i' : '<'); } r(c) ? c + 'A' - 'a' : c; while (inext) != -1; cp=np) { if (np->size>=size) { if (size+slop >= np->size) { cp->next = np->next; return(&np->next); } cp = cp->next = np+size; cp->size = np->size - size; cp->next = np->next; np->size = size; return(&np->next); } } asize = size<1020? 1024: size+4; cp = getmain(asize, asize<<2); if (cp->size <= 0) return(-1); v = cp->next; v[0] = cp->size-4; v[1] = cp->next+4; cfree(v+1); } } ; size =& ~03; for (;;) { for (cp=_freech; (np= cp->next) != -1; cp=np) { if (np->size>=size) { if (size+slop >= np->size) { cp->next = np->next; return(&np->next); } cp = cp->next = np+size; cp->size = np->size - size; cp->next = np->next;# include "iodef.c" cclose (fn) { char *ddn; if (fn < 0 || fn > NFILES || _fbuffp[fn] == 0) return; cflush (fn); inout (ddn=_fbuffp[fn]->dd, "C "); if (_prefix(ddn, "C##")) _rel(ddn); if (_prefix(ddn, "$$$")) _rel(ddn); cfree (_fbuffp[fn],612+20+4+4+4,1); _fbuffp[fn] = 0; } _prefix(s,t) char *s, *t; { while (*s++ == *t++) if (*t==0) return(1); return(0); } { cp->next = np->next; return(&np->next); } cp = cp->next = np+size; cp->size = np->size - size; cp->next = np->next;# include "iodef.c" cexit (returncode) { int i; extern int _gate; if (_gate == 0) cgate(); for (i=0; inext = np->next; return(&np->next); } cp = cp->next = np+size; cp->size = np->size - size; cp->next = np->next;# include "iodef.c" cflush (fn) { struct iobuf *fp; if (fn < 0 || fn > NFILES || _fbuffp[fn] == 0) return;; fp = _fbuffp[fn]; if (fp->nchars == 0) return; if (fp->out > 0) inout (fp->dd, "W ", fp->cp=fp->buf, fp->nchars); fp->nchars = 0; } 12+20+4+4+4,1); _fbuffp[fn] = 0; } _prefix(s,t) char *s, *t; { while (*s++ == *t++) if (*t==0) return(1); return(0); } { cp->next = np->next; return(&np->next); } cp = cp->next = np+size; cp->size = np->size - size; cp->next = np->next;struct fb { int size; char *next; }; extern int _freech[]; cfree(aptr) char *aptr; { char *ptr, *cp, *np; ptr = aptr-4; cp = _freech; while (((np = cp->next) < ptr) && (np > 0)) cp = np; if (ptr+ptr->size == np) { ptr->size =+ np->size; ptr->next = np->next; np = ptr; } else ptr->next = np; if (cp+cp->size == ptr) { cp->size =+ ptr->size; cp->next = ptr->next; } else cp->next = ptr; } xt); } cp = cp->next = np+size; cp->size = np->size - size; cp->next = np->next;# include "iodef.c" extern int _gate; cgate() { extern char *_definp, *_defout, *_deferr; extern int cexit(); if (_gate) return; _gate = &cexit; if (_fbuffp[0] == 0) copen ( _definp, 'r'); if (_fbuffp[1] == 0) copen( _defout,'w'); if (_fbuffp[2] == 0) copen( _deferr, 'w'); } ptr; } else ptr->next = np; if (cp+cp->size == ptr) { cp->size =+ ptr->size; cp->next = ptr->next; } else cp->next = ptr; } xt); } cp = cp->next = np+size; cp->size = np->size - size; cp->next = np->next;# include "iodef.c" cgetc (fl) { struct iobuf *fp; int fn; extern int _gate, cin; if (_gate ==0) cgate(); /* open files first time */ fn = nargs(1) > 0 ? fl : cin; if (fn < 0 || fn >NFILES || (fp = _fbuffp[fn]) == 0) ermsg("CGETC: no file %d\n",fn); if (fp->out > 0) ermsg ("CGETC: reading file %d open for write\n",fn); if (fp->nchars == 0) { fp->nchars = inout(fp->dd, "R ", fp->cp=fp->buf+100,512); if (fp->nchars > 0) fp->cp[fp->nchars++] = '\n'; } if (fp->nchars-- > 0) return ( *(fp->cp)++ ); else { fp->nchars = -1; return ('\0'); } } int cin 0; ; extern int _gate, cin; if (_gate ==0) cgate(); /* open files first time */ fn = nargs(1) > 0 ? fl : cin; if (fn < 0 || fn >NFILES || (fp = _fbuffp[fn]) == 0) ermsg("CGETC: no file %d\n",fn); if (fp->out > 0) ermsg ("CGETC: reading file %d open for write\n",fn); if (fp->nchars == 0) { fp->nchars = inout(fp->dd, "R ", fp->cp=fp->buf+100,512); if (fp->nchars > 0) fp->cp[fp->nchars++] = '\n'; } if (fp->nchars-- > 0) return ( *(fp->cp)++ ); e_clenf (s) /* counts length of string */ char *s; { int n; for (n=0; *s++ != '\0'; n++); return (n);} e(); /* open files first time */ fn = nargs(1) > 0 ? fl : cin; if (fn < 0 || fn >NFILES || (fp = _fbuffp[fn]) == 0) ermsg("CGETC: no file %d\n",fn); if (fp->out > 0) ermsg ("CGETC: reading file %d open for write\n",fn); if (fp->nchars == 0) { fp->nchars = inout(fp->dd, "R ", fp->cp=fp->buf+100,512); if (fp->nchars > 0) fp->cp[fp->nchars++] = '\n'; } if (fp->nchars-- > 0) return ( *(fp->cp)++ ); e# define NFILES 10 struct iobuf {char dd[20], *cp; int out, nchars; char buf[612];}; struct iobuf *_fbuffp[NFILES]; copen (name, direction, options) char *name, *options; int direction; { int fn, n, i; char *optstr, optdef[4]; struct iobuf *fp; extern int _gate; if (_gate==0) cgate(); for (fn = 0; _fbuffp[fn] != 0 && fn < NFILES; fn++); if (fn >= NFILES) return (-1); /* special choices now are e - edit lower case and tabs from output b - begin each line with blank n - don't begin each line with blank */ optstr = nargs(3) == 3 ? options : ""; if (optstr >= 0 && optstr < 512) {optstr = optdef; optdef[0] = i = options; optdef[1] = 0;} _fbuffp[fn] = fp = calloc(612+20+4+4+4,1); name = _access(name,fn,direction); if (name==0) return(-1); /* name must be blank padded in dd field */ for(i=0; i<20; i++) { fp->dd[i] = *name ? *name++ : ' '; } fp->nchars = 0; fp->out = (direction == 'w' || direction == 'W') ? 1 : 0; fp->cp = fp->buf + (fp->out ? 0 : 100); if (fp->out > 0) while (*optstr) switch (*optstr++) { case 'e': case 'E': fp->out =| 2; break; case 'b': case 'B': fp->out =| 04; break; case 'n': case 'N': fp->out =& (~04); break; } return (fn); } _access(name,fn,direction); if (name==0) return(-1); /* name must be blank padded in dd field */ for(i=0; i<20; i++) { fp->dd[i] = *name ? *name++ : ' '; } fp->nchars = 0; fp->out = (direction == 'w' || direction == 'W') ? 1 : 0; fp->cp = fp->buf + (fp->out ? 0 : 100); if (fp->out > 0) while (*optstr) sw# include "iodef.c" cputc (ch, fl) { struct iobuf *fp; int fn; extern int _gate, cout; if (_gate== 0) cgate(); fn = nargs(2) > 1 ? fl : cout; if (fn < 0 || fn > NFILES || (fp=_fbuffp[fn]) == 0 ) ermsg ("CPUTC: file %d not opened\n",fn); if (fp->out == 0) ermsg ("CPUTC: file %d opened to read\n",fn); if ((fp->out&02) != 0) /* edit mode on output */ if (ch >= 'a' && ch <= 'z') /* translate to upper case */ ch =+ 'A'-'a'; if (ch != '\n') { if (fp->nchars == 0 && (fp->out&04) != 0) /* fp->out bit 04 is on if carriage control wanted */ {fp->nchars++; *(fp->cp)++ = ' ';} /* should we process tabs ? */ if (ch == '\t' && (fp->out&02) != 0) for (ch = ' '; (fp->nchars==0 || fp->nchars % 8); fp->nchars++) *(fp->cp)++ = ' '; *(fp->cp)++ = ch; if (++(fp->nchars) < 511) return (ch); } /* newline or record too long */ if (fp->nchars == 0) /* zero length record, add a blank */ {*fp->cp = ' '; fp->nchars = 1;} inout (fp->dd, "W ", fp->cp=fp->buf, fp->nchars); fp->nchars = 0; return ('\n'); } int cout 1; carriage control wanted */ {fp->nchars++; *(fp->cp)++ = ' ';} /* should we process tabs ? */ if (ch == '\t' && (fp->out&02) != 0) for (ch = ' '; (fp->nchars==0 || fp->nchars % 8); fp->nchars++) *(fp->cp)++ = ' '; *(fp->cp)++ = ch; if (++(fp->nchars) < 511) return (ch); } /* newline or record too long */ if (fp->nchars == 0) /* zero length record, add a blank */ {*fp->cp = ' '; fp->nchars = 1;} inout (fp->dd, "W ", fp->cp=fp->buf, fp->nchars); fp->nchars = 0; return ('\n'); } int co# include "iodef.c" cread (ptr, ptrp1, numb, fn) { int need, k, size, start; char buff[804], *pb, *sp; if (fn < 0 || fn >NFILES || _fbuffp[fn] == 0) ermsg ("CREAD: file %d not opened\n", fn); sp = start = ptr; size = ptrp1 - ptr; need = size*numb; if (need <800) pb = buff; else pb = calloc(need+4, 1); pb=+4; k = inout(_fbuffp[fn]->dd, "R ", pb, need); for(k=0; k= 800) cfree(pb-4,need+4,1); return (numb); } buf, fp->nchars); fp->nchars = 0; return ('\n'); } int co#cstop csect lr 11,15 get addressability using #cstop,11 l 15,0(13) store arg l 13,=v(stack$) l 13,4(13) get pointer to return regs lm 14,12,12(13) br 14 end ile %d not opened\n", fn); sp = start = ptr; size = ptrp1 - ptr; need = size*numb; if (need <800) pb = buff; else pb = calloc(need+4, 1); pb=+4; k = inout(_fbuffp[fn]->dd, "R ", pb, need); for(k=0; k= 800) cfree(pb-4,need+4,1); return (numb); } buf, fp->nchars); fp->nchars = 0; return ('\n'); } int co# include "iodef.c" cwrite (ptr, ptrp1, numb, fn) { int need, k, size, start; char buff[804], *pb, *sp; if (fn < 0 || fn >NFILES || _fbuffp[fn] == 0) ermsg ("CWRITE: file %d not opened\n", fn); sp =start = ptr; size = ptrp1 - ptr; need = size*numb; if (need <800) pb = buff; else pb = calloc(need+4, 1); pb =+ 4; for(k=0; kdd, "W ", pb, need); if (need>= 800) cfree(pb-4, need+4,1); return (numb); } fp->nchars); fp->nchars = 0; return ('\n'); } int co/* default names */ char *_definp "SYSIN"; char *_defout "SYSPRINT"; char *_deferr "SYSPRINT"; *pb, *sp; if (fn < 0 || fn >NFILES || _fbuffp[fn] == 0) ermsg ("CWRITE: file %d not opened\n", fn); sp =start = ptr; size = ptrp1 - ptr; need = size*numb; if (need <800) pb = buff; else pb = calloc(need+4, 1); pb =+ 4; for(k=0; kdd, "W ", pb, need); if (need>= 800) cfree(pb-4, need+4,1); return (numb); } fp->nchars); fp->nchars = 0; return ('\n'); } int coermsg(format, data) char *format; { extern int cout; printf (format, data); cclose(cout); cexit(8); } p; if (fn < 0 || fn >NFILES || _fbuffp[fn] == 0) ermsg ("CWRITE: file %d not opened\n", fn); sp =start = ptr; size = ptrp1 - ptr; need = size*numb; if (need <800) pb = buff; else pb = calloc(need+4, 1); pb =+ 4; for(k=0; kdd, "W ", pb, need); if (need>= 800) cfree(pb-4, need+4,1); return (numb); } fp->nchars); fp->nchars = 0; return ('\n'); } int coftoa (x, str, prec, format) float x; char *str; { /* converts a floating point number to an ascii string */ /* x is stored into str, which should be at least 30 chars long */ int ie, i, k, ndig, fstyle; double y; ndig = ( prec<0) ? 7 : (prec > 22 ? 23 : prec+1); if (format == 'f' || format == 'F') fstyle = 1; else fstyle = 0; /* print in e format unless last arg is 'f' */ ie = 0; /* if x negative, write minus and reverse */ if ( x < 0) { *str++ = '-'; x = -x; } /* put x in range 1 <= x < 10 */ if (x > 0.0) while (x < 1.0) { x = x* 10.0; ie--; } while (x >= 10.0) { x = x/10.0; ie++; } /* in f format, number of digits is related to size */ if (fstyle) ndig =+ ie; /* round. x is between 1 and 10 and ndig will be printed to right of decimal point so rounding is ... */ y = 10.0; for (i = 0; i < ndig; i++) y = y/10.; x =+ y/2.; if (x >= 10.0) /* repair rounding disasters */ { x = 1.0; ie++; if (fstyle) ndig++; } /* now loop. put out a digit (obtain by multiplying by 10, truncating, subtracting) until enough digits out */ /* if fstyle, and leading zeros, they go out special */ if (fstyle && ie < 0) { *str++ = '0'; i = (ndig > 0) ? -1 : (ndig-1); i =- ie; if (i > 0) { *str++ = '.'; while (i--) *str++ = '0'; } } for (i=0; i < ndig; i++) { if (i == (fstyle ? ie+1 : 1)) /* where is decimal point */ *str++ = '.'; k = x; *str++ = k + '0'; x =- (y=k); x = x* 10.0; } /* now, in estyle, put out exponent if not zero */ if (!fstyle && ie != 0) { *str++ = 'E'; if (ie < 0) { ie = -ie; *str++ = '-'; } for (k=100; k > ie; k =k/10); for (; k > 0; k =k/10) { *str++ = ie/k + '0'; ie = ie%k; } } *str = '\0'; return; } while (i--) *str++ = '0'; } } for (i=0; i < ndig; i++) { if (i == (fstyle ? ie+1 : 1)) /* where is decimal point */ *str++ = '.'; k = x; *str++ = k + '0'; x =- (y=k); x = x* 10.0; } /* now, in estyle, put out exponent if not zero */ if (!fstyle && ie != 0) { int _gate 0; int _gates 0; ) { ie = -ie; *str++ = '-'; } for (k=100; k > ie; k =k/10); for (; k > 0; k =k/10) { *str++ = ie/k + '0'; ie = ie%k; } } *str = '\0'; return; } while (i--) *str++ = '0'; } } for (i=0; i < ndig; i++) { if (i == (fstyle ? ie+1 : 1)) /* where is decimal point */ *str++ = '.'; k = x; *str++ = k + '0'; x =- (y=k); x = x* 10.0; } /* now, in estyle, put out exponent if not zero */ if (!fstyle && ie != 0) { genreg (regno, ndecl) { /* this returns the value of register regno to a subroutine that had ndecl paramters */ int **mysave; /* find my own save area */ mysave = &ndecl; mysave++; /* now find his save area */ return ( *( mysave[12]+ndecl+regno) ); } } } for (i=0; i < ndig; i++) { if (i == (fstyle ? ie+1 : 1)) /* where is decimal point */ *str++ = '.'; k = x; *str++ = k + '0'; x =- (y=k); x = x* 10.0; } /* now, in estyle, put out exponent if not zero */ if (!fstyle && ie != 0) { # define LPARM 100 char *_argv_[20]; _gtargs() { static char pbuff[LPARM+2]; int nchar, argc, i; char *parm, **parmlist, *newp; extern char *_definp, *_defout; /* TSS only ... */ extern char *_deferr, *_defter; extern int _tabflg, _gate; char b[10]; /* ... */ printf(-1, b, "%cTABS", 4); _tabflg = _deflt(b+1); _definp = _defout = _deferr = _defter; _gate = 0; parmlist = genreg (3,0); /* find register 1 which was copied to 3 */ if (parmlist==0) return(0); parm = *parmlist; /* find actual address of parameter string */ /* this won't cross compile ... parm =& 077777777; /* get 24-bit address */ i = parm; i = i<<8; i = i>>8; parm = i; /* next lines for OS ... nchar = parm[0]*256+parm[1]; parm =+ 2; /* actual start of characters */ /* next lines for TSS ... */ nchar = parm[-1]; /* ... */ if (nchar==0) return (0); newp = pbuff; if (nchar > LPARM) nchar= LPARM; for (i=0; i') _defout = parm+1; else /* normal argument */ _argv_[argc++] = parm; while (*parm != ' ') parm++; } } . */ if (nchar==0) return (0); newp = pbuff; if (nchar > LPARM) nchar= LPARM; for (i=0; i>8; parm = i; /* next lines for OS ... */ nchar = parm[0]*256+parm[1]; parm =+ 2; /* actual start of characters */ /* next line for TSS ... nchar = parm[-1]; /* ... */ if (nchar==0) return (0); newp = pbuff; if (nchar > LPARM) nchar= LPARM; for (i=0; i') _defout = parm+1; else /* normal argument */ _argv_[argc++] = parm; while (*parm != ' ') parm++; } } . */ if (nchar==0) return (0); newp = pbuff; if (nchar > LPARM) nchar= LPARM; for (i=0; i') _defout = parm+1; else /* nogetchar() { extern int cin; return(cgetc(cin)); } parm != ' ') parm++; } } . */ if (nchar==0) return (0); newp = pbuff; if (nchar > LPARM) nchar= LPARM; for (i=0; i') _defout = parm+1; else /* no/* For use with OS only */ struct fb {int size; char *next;} * getmain(min,max) { static int ptr[2]; static int rtr[2]; ptr[1] = (nargs(2)==1) ? min : max; ptr[0] = min; asm(" getmain vc,la=$2,a=$3 "); asm(" n 15,=x'000000ff' "); asm(" l 0,$3 "); asm(" l 1,$3+4 "); asm(" ltr 15,15 "); asm(" bz ok "); asm(" l 0,=f'-1' "); asm("ok st 0,$3+4 "); asm(" st 1,$3 "); return(rtr); } f (*parm == '>') _defout = parm+1; else /* nochar *gets(s,n) char *s; { int c, fn; char *p; extern int cin; p = s; fn = nargs(2) > 1 ? n : cin; while ((c=cgetc(fn)) != '\0' && c != '\n') *s++ = c; *s = '\0'; while (*--s == ' ') *s = '\0'; return (c ? p : 0); } n 15,=x'000000ff' "); asm(" l 0,$3 "); asm(" l 1,$3+4 "); asm(" ltr 15,15 "); asm(" bz ok "); asm(" l 0,=f'-1' "); asm("ok st 0,$3+4 "); asm(" st 1,$3 "); return(rtr); } f (*parm == '>') _defout = parm+1; else /* no_rel() { return; } _access(x) { return(x); } ; extern int cin; p = s; fn = nargs(2) > 1 ? n : cin; while ((c=cgetc(fn)) != '\0' && c != '\n') *s++ = c; *s = '\0'; while (*--s == ' ') *s = '\0'; return (c ? p : 0); } n 15,=x'000000ff' "); asm(" l 0,$3 "); asm(" l 1,$3+4 "); asm(" ltr 15,15 "); asm(" bz ok "); asm(" l 0,=f'-1' "); asm("ok st 0,$3+4 "); asm(" st 1,$3 "); return(rtr); } f (*parm == '>') _defout = parm+1; else /* no* Intended for use with RR INOUT package. inout csect using inout,15 stm 1,15,16(13) lr 11,15 drop 15 using inout,11 lr 12,13 lr 1,13 l 9,4(1) mvc 4(4,1),0(9) la 13,sa l 15,=v(cinout) balr 14,15 lm 1,15,16(12) br 14 sa dc 18a(0) end asm(" l 0,$3 "); asm(" l 1,$3+4 "); asm(" ltr 15,15 "); asm(" bz ok "); asm(" l 0,=f'-1' "); asm("ok st 0,$3+4 "); asm(" st 1,$3 "); return(rtr); } f (*parm == '>') _defout = parm+1; else /* no# define NFILES 10 struct iobuf {char dd[20], *cp; int out, nchars; char buf[612];}; extern struct iobuf *_fbuffp[NFILES]; lr 12,13 lr 1,13 l 9,4(1) mvc 4(4,1),0(9) la 13,sa l 15,=v(cinout) balr 14,15 lm 1,15,16(12) br 14 sa dc 18a(0) end asm(" l 0,$3 "); asm(" l 1,$3+4 "); asm(" ltr 15,15 "); asm(" bz ok "); asm(" l 0,=f'-1' "); asm("ok st 0,$3+4 "); asm(" st 1,$3 "); return(rtr); } f (*parm == '>') _defout = parm+1; else /* no* macros for C language routines * * macro bcall balr 14,15 mend * macro fcall balr 14,15 mend * macro mainloc $main csect mend * macro codeloc gblc &sec &sec.c csect mend * macro dataloc gblc &sec &sec.p csect mend * macro strgloc gblc &sec &sec.p csect mend * macro istrloc gblc &sec &sec.s csect mend macro litloc gblc &sec &sec.p csect mend * macro tvecloc gblc &sec &sec.p csect mend * macro &loc intaddr &name gblc &sec cnop 0,4 &loc equ * dc a(&name) mend * macro &loc intfunc &name gblc &sec cnop 0,4 &loc equ * dc a(&name) mend * macro &loc extaddr &name cnop 0,4 &loc equ * dc v(&name) mend * macro &loc extfunc &name cnop 0,4 &loc equ * dc v(&name) mend macro &name startup gblc &sec &sec setc '&name' &sec.c csect &sec.p csect &sec.c csect * Register usage * hgautop equ 12 hgargp equ 13 $base1 equ 10 $base2 equ 11 $base3 equ 9 $base4 equ 8 mend * * macro subsave gblc &sec mainloc stm 14,12,12(13) lr $base1,15 using $main$,$base1 l $base2,72(13) using &sec.p,$base2 la $base3,stack$ st 13,4($base3) la 13,20($base3) mend * * * macro subretrn &cc=0 l 15,b$cexit ltr 15,15 be return$ la 1,0 lfunc 15,b$cexit bcall return$ l 13,stack$+4 lm 14,12,12(13) la 15,0 br 14 b$cexit dc f'0' mend * macro stackdo dc c'stack' stack$ dc 1000f'0' entry stack$ dc c'end stack' mend * * * * macro &name prolog &ndp gblc &sec gbla &fnum lcla &a &a seta 4*(&ndp) &fnum seta &fnum+1 codeloc cnop 0,4 dc cl12'&name' dc f'&a' &name equ * stm 0,15,&a.(13) save registers lr $base1,15 using &name,$base1 first $ addresses this code l $base2,b&sysndx using &sec.p,$base2 lr 12,13 la 13,ss$&fnum.(13) l $base3,c&sysndx l $base4,d&sysndx b go&sysndx cnop 0,4 b&sysndx dc a(&sec.p) c&sysndx dc a(&sec.p+4096) d&sysndx dc a(&name+4096) go&sysndx equ * using &sec.p+4096,$base3 using &name+4096,$base4 mend * * macro &name epilog &ndp,&stk number of declared parameters gbla &fnum lcla &a &a seta &ndp*4 &name lm 1,15,&a.+4(12) br 14 ss$&fnum equ &stk mend * * * macro runmain la 13,20(13) lr 3,1 lfunc 15,@gtarg@ la 1,0 bcall st 0,0(13) l 2,=v(#argv#) st 2,4(13) lfunc 15,@main@ la 1,8 bcall b go&sysndx @main@ intfunc main @gtarg@ extfunc #gtargs go&sysndx equ * mend * macro movif &fr,&r gbla &fflg aif (&fflg ne 0).ok2 &fflg seta 1 dataloc cnop 0,8 $fltcs dc xl8'4e00000000000000' $fltmp dc d'0.0' codeloc .ok2 anop ld &fr,$fltcs std &fr,$fltmp ltr &r,&r bm flt&sysndx st &r,$fltmp+4 ad &fr,$fltmp b flt&sysndx.a flt&sysndx equ * lpr &r,&r st &r,$fltmp sd &fr,$fltmp flt&sysndx.a equ * mend macro movfi &fr,&r gbla &fflg aif (&fflg ne 0).ok &fflg seta 1 dataloc cnop 0,8 $fltcs dc xl8'4e00000000000000' $fltmp dc d'0.0' codeloc .ok anop aw &fr,$fltcs std &fr,$fltmp l &r,$fltmp bc 10,flb&sysndx lnr &r,&r flb&sysndx equ * mend * macro entname &name dataloc entry &name mend * macro &name defext &name equ * &name.p equ * mend * macro lfunc ®,&add l ®,&add mend * macro lc ®,&add sr ®,® ic ®,&add mend * * * * end of macros * fltmp flt&sysndx.a equ * mend macro movfi &fr,&r gbla &fflg aif (&fflg ne 0).ok &fflg seta 1 dataloc cnop 0,8 $fltcs dc xl8'4e00000000000000' $fltmp dc d'0.0' codeloc .ok anop aw &fr,$fltcs std &fr,$fltmp l &r,$fltmp bc 10,flb&sysndx lnr &r,&r flb&sysndx equ * mend * macro entname lfunc opsyn l * macro bcall balr 14,15 mend * macro fcall balr 14,15 mend * macro mainloc $main loctr mend * macro codeloc $code loctr mend * macro dataloc $data loctr cnop 0,4 mend * macro strgloc $string loctr mend * macro istrloc $string loctr mend * macro litloc $data loctr mend * macro tvecloc $data loctr mend * macro &loc intaddr &name cnop 0,4 &loc equ * dc a(&name) mend * macro &loc intfunc &name &loc intaddr &name mend * macro &loc extaddr &name cnop 0,4 &loc equ * dc v(&name) mend * macro &loc extfunc &name &loc extaddr &name mend macro startup csect $main loctr $code loctr $string loctr $data loctr $code loctr mend * * macros for C language routines * hgautop equ 12 hgargp equ 13 $base1 equ 10 $base2 equ 11 $base3 equ 9 $base4 equ 8 * macro &name subsave &sa=stack$ a&sysndx equ * stm 14,12,12(13) lr 12,15 using a&sysndx,12 la 9,&sa st 13,4(9) st 9,8(13) la 2,return$ st 2,0(9) la 13,&sa mend * * * macro subretrn &cc=0 la 1,0 l 15,b$cexit ltr 15,15 be return$ balr 14,15 return$ l 13,stack$+4 lm 14,12,12(13) la 15,&cc br 14 wxtrn cexit b$cexit dc v(cexit) mend * macro stackdo dc c'stack' stack$ dc 1000f'0' entry stack$ dc c'end stack' mend * * * * macro &name prolog &ndp gbla &fnum lcla &a &a seta 4*(&ndp) &fnum seta &fnum+1 dc cl12'&name' dc f'&a' &name equ * stm 0,15,&a.(13) save registers lr $base1,15 using &name,$base1 first $ addresses this code lr 12,13 la 13,ss$&fnum.(13) cnop 0,4 force full word allignment l $base2,b&sysndx l $base3,c&sysndx l $base4,d&sysndx b go&sysndx b&sysndx dc a($string) c&sysndx dc a($string+4096) d&sysndx dc a(&name+4096) go&sysndx equ * using $string,$base2 using $string+4096,$base3 using &name+4096,$base4 mend * * macro &name epilog &ndp,&stk number of declared parameters lcla &a gbla &fnum &a seta &ndp*4 &name lm 1,15,&a.+4(12) br 14 ss$&fnum equ &stk mend * * * macro runmain la 13,20(13) lr 3,1 l 15,=v(#gtargs) la 1,0 extrn #gtargs balr 14,15 st 0,0(13) l 2,=v(#argv#) st 2,4(13) l 15,=a(main) la 1,8 balr 14,15 mend * macro lc &r,&a sr &r,&r ic &r,&a mend * macro movif &fr,&r gbla &fflg aif (&fflg ne 0).ok2 &fflg seta 1 dataloc cnop 0,8 $fltcs dc xl8'4e00000000000000' $fltmp dc d'0.0' codeloc .ok2 anop ld &fr,$fltcs std &fr,$fltmp ltr &r,&r bm flt&sysndx st &r,$fltmp+4 ad &fr,$fltmp b flt&sysndx.a flt&sysndx equ * lpr &r,&r st &r,$fltmp sd &fr,$fltmp flt&sysndx.a equ * mend macro movfi &fr,&r gbla &fflg aif (&fflg ne 0).ok &fflg seta 1 dataloc cnop 0,8 $fltcs dc xl8'4e00000000000000' $fltmp dc d'0.0' codeloc .ok anop aw &fr,$fltcs std &fr,$fltmp l &r,$fltmp bc 10,flb&sysndx lnr &r,&r flb&sysndx equ * mend * * end of macros * l8'4e00000000000000' $fltmp dc d'0.0' codeloc .ok2 anop ld &fr,$fltcs std &fr,$fltmp ltr &r,&r bm flt&sysndx st &r,$fltmp+4 ad &fr,$fltmp b flt&sysndx.a flt&sysndx equ * lpr &r,&r st &r,$fltmp sd &fr,$fltmp flt&sysndx.a equ * mend macro movfi &fr,&r gbla &fflg aif (&fflg ne 0).ok &fflg seta 1 dataloc cnop 0,8 $fltcs dc xl8'4e00000000000000' $fltmp dc d'0.0' codeloc .ok anop aw &fr,$fltcs std &fr,$fltmp l &r,$fltmp bc 10,flb&sysndx lnr &r,&r# define ARCOUNT 1 nargs(x) { int *r12; r12 = genreg(12, 1); /* ARCOUNT is the number fo the register containing the length of the arguments, now 1 */ return(r12[x+ARCOUNT]>>2); } fltmp b flt&sysndx.a flt&sysndx equ * lpr &r,&r st &r,$fltmp sd &fr,$fltmp flt&sysndx.a equ * mend macro movfi &fr,&r gbla &fflg aif (&fflg ne 0).ok &fflg seta 1 dataloc cnop 0,8 $fltcs dc xl8'4e00000000000000' $fltmp dc d'0.0' codeloc .ok anop aw &fr,$fltcs std &fr,$fltmp l &r,$fltmp bc 10,flb&sysndx lnr &r,&rchar *_ptrbf, *_ptrst, *__fmt; printf(a1,a2,a3,a4, z1, z2, z3, z4, z5, z6, z7, z8, z9){ auto char c, *s, adj, *ptr,*p, buf[30]; extern cputc(),_putstr(), cout; auto int *adx, x, n, m, width, prec,i, padchar, fd; double *dblptr; char (*f)(); _ptrbf = buf; fd=cout; adx = &a1; f = cputc; if (a1 == -1) { f = _putstr; _ptrst = a2; adx =+ 2; } else if (a1 >= 0 && a1 <= 9) fd = *adx++; __fmt = *adx++; while( c = *__fmt++ ){ if(c != '%') (*f)(c,fd); else { x = *adx++; if( *__fmt == '-' ){ adj = 'l'; __fmt++; } else adj = 'r'; padchar = (*__fmt=='0') ? '0' : ' '; width = __conv(); if( *__fmt == '.'){++__fmt; prec = __conv();} else prec = -1; s = 0; switch ( c = *__fmt++ ) { case 'u': case 'U': case 'd': case 'D': __prnt10(x); break; case 'o': case 'O': _prnt8(x); break; case 'x': case 'X': _prntx(x); break; case 'S': case 's': s=x; break; case 'C': case 'c': *_ptrbf++ = x&0377; break; case 'E': case 'e': case 'F': case 'f': dblptr = adx-1; adx =+ 1; ftoa (*dblptr, s=buf, prec, c); prec = -1; break; default: (*f)(c,fd); adx--; } if (s == 0) {*_ptrbf = '\0'; s = buf;} n = _clenf (s); n = (prec= 0) ? prec : n; m = width-n; if (adj == 'r') { if (padchar=='0' && s[0] == '-') { n--; (*f)(*s++,fd); } while (m-- > 0) (*f)(padchar,fd); } while (n--) (*f)(*s++,fd); while (m-- > 0) (*f)(padchar,fd); _ptrbf = buf; } } if(a1 == -1) (*f)('\0',fd); } __conv() { auto c,n; n = 0; while( ((c = *__fmt++) >= '0') && (c<='9')) n = n*10+c-'0'; __fmt--; return(n); } _putstr(chr,str){ *_ptrst++ = chr; return; } __prnt10(n) { int pstk[10], *ps; if (n>=0) n= -n; else *_ptrbf++ = '-'; ps = pstk; if (n==0) *ps++ = '0'; else while (n) { *ps++ = '0' - (n%10); n = n/10; } while (ps>pstk) *_ptrbf++ = *--ps; } _prnt8 (n) { /* print in octtal */ int p, k, sw; if (n==0) {*_ptrbf++ = '0'; return;} sw = 0; for (p=15; p >= 0; p =- 3) if ((k = (n>>p)&07) || sw) { *_ptrbf++ = '0' + k; sw = 1; } } _prntx (n) { int d,a; if (a = n>>4) _prntx ( a & 0177777); d = n&017; *_ptrbf++ = d > 9 ? 'A'+d-10 : '0' + d; } t pstk[10], *ps; if (n>=0) n= -n; else *_ptrbf++ = '-'; ps = pstk; if (n==0) *ps++ = '0'; else while (n) { *ps++ = '0' - (n%10); n = n/10; } while (ps>pstk) *_ptrbf++ = *--ps; } _prnt8 (n) { /* print in octtal */ int p, k, sw; if (n==0) {*_ptrbf+putchar(c) { extern int cout; return (cputc(c,cout)); } f ((k = (n>>p)&07) || sw) { *_ptrbf++ = '0' + k; sw = 1; } } _prntx (n) { int d,a; if (a = n>>4) _prntx ( a & 0177777); d = n&017; *_ptrbf++ = d > 9 ? 'A'+d-10 : '0' + d; } t pstk[10], *ps; if (n>=0) n= -n; else *_ptrbf++ = '-'; ps = pstk; if (n==0) *ps++ = '0'; else while (n) { *ps++ = '0' - (n%10); n = n/10; } while (ps>pstk) *_ptrbf++ = *--ps; } _prnt8 (n) { /* print in octtal */ int p, k, sw; if (n==0) {*_ptrbf+*PROGRAM: CINOUT, AN OS/370 ASSEMBLY EXTERNAL FUNCTION *LANGUAGE: OS/360 ASSEMBLER LANGUAGE *AUTHOR: A L SABSEVITZ, BTL DEPT 9152, RRC 4C-830, X6343 * WRITTEN ORIGINALLY FOR SNOFLAKE AND SNOBOL4 USAGE BY T B MUENZER * REVISED MAY 21, 1971, T B MUENZER, TO TIGHTEN UP CODE * REVISED FEBRUARY 7, 1972, T. B. MUENZER, TO CORRECT PROGRAM BUG: * WHEN ASKED TO WRITE NULL STRING, CINOUT WOULD FAIL TO BLANK FIRST * BYTE OF OUTPUT BUFFER AND WOULD BLANK FIRST BYTE AFTER OUTPUT BUFFER. * REVISED FEBRUARY 8, 1972, T. B. MUENZER, TO INSERT FREEPOOL * INSTRUCTION TO FREE BUFFERS AFTER CLOSING DCB. * REVISED OCTOBER 15, 1974, A. L. SABSEVITZ TO TIGHTEN UP CODE * AND BE CALLABLE DIRECTLY FROM ASSEMBLY LANG PROGRAMS. * REVISED NOV 1974, A. L. SABSEVITZ TO USE MVCL INSTR AND TO INTERACT * WITH IBMC. SPACE * * REVISED SEPT 1973 BY D. W. SMITH * * ADD FACILITY TO HANDLE VARIABLE LENGTH RECORDS * REVISED FEB 1974, A. L. SABSEVITZ TO FIX BUG IN ABOVE FACILITY * SPACE *PURPOSE: TO MAKE OS/360 QSAM ACCESS METHOD ACCESSIBLE BY IBMC * FOR READING AND WRITING FIXED AND VARIABLE LENGTH RECORD SEQUENTIAL * DATA SETS INCLUDING (MULTIPLE) MEMBERS OF PARTITIONED DATA SETS SPACE *RESTRICTIONS: * STRINGS TO BE WRITTEN ARE TRUNCATED OR PADDED WITH BLANKS * ON THE RIGHT TO LOGICAL RECORD LENGTH SPACE * THE MODEL DCB IS CODED MACRF=(GL,PL) WHICH IMPLIES THAT * PAPER TAPE CANNOT BE READ SPACE * CONCATENATIONS OF PARTITIONED DATA SETS CANNOT BE PROCESSED SPACE * THE FIRST AND SECOND ARGUMENT STRINGS MUST BE CODED IN IBM EBCDIC SPACE * THE SUBSTRINGS DDNAME AND MEMBER IN THE FIRST ARGUMENT MUST NOT * CONTAIN PARENTHESES (BELIEVED TO BE AN OS/360 RESTRICTION) EJECT SPACE *USAGE: CINOUT(FILE,FUNCTION,STRING) WHERE * FILE = 18 BYTE STRING IN THE FORM: DDNAME ; DDNAME '(' MEMBER ')' AND * FUNCTION = 'R' ; 'W' ; 'C' AND * STRING = ADDRESS OF STRING TO BE WRITTEN OR READ SPACE * FILE = DDNAME IF THERE IS A DD STATEMENT OF THE FORM * //DDNAME DD DSNAME=DATA-SET-NAME,.... * WHERE DATA-SET-NAME IS THE NAME OF A (FIXED-LENGTH RECORD, * BLOCKED OR UNBLOCKED) SEQUENTIAL DATA SET * OR IF THERE IS A DD STATEMENT OF THE FORM * //DDNAME DD DSNAME=DATA-SET-NAME(MEMBER),.... * WHERE DATA-SET-NAME IS THE NAME OF A (FIXED-LENGTH RECORD, * BLOCKED OR UNBLOCKED) PARTITIONED DATA SET SPACE * FILE = DDNAME '(' MEMBER ')' IF THERE IS A DD STATEMENT OF THE FORM * //DDNAME DD DSNAME=DATA-SET-NAME,... * WHERE DATA-SET-NAME IS THE NAME OF A (FIXED-LENGTH RECORD, * BLOCKED OR UNBLOCKED) PARTITIONED DATA SET SPACE * CINOUT MAINTAINS A LIST OF DCB'S FOR PROCESSING SUCH DATA SETS SPACE * CINOUT(FILE,'R',STRING) RETURNS: * 1. NUMBER OF BYTES READ OR * 2. 0 IF EOF OR * 3. NEGATIVE NUMBER IF ERRORS SPACE * CINOUT(FILE,'W',STRING) RETURNS: * 1. NEGATIVE NUMBER IF ERRORS SPACE * IF THE FIRST OR SECOND ARGUMENT IS MISSPELLED, * IF NO DD STATEMENT WAS SUPPLIED, OR IF OPEN FAILS SPACE * CINOUT AS CURRENTLY PROGRAMMED TOLERATES CERTAIN ILLEGAL ARGUMENTS * THIS INFORMATION IS FOR DEBUGGING PURPOSES ONLY AND IS NOT PART * OF THE DEFINITION OF WHAT THE PROGRAM IS SUPPOSED TO DO * PROGRAMMERS TAKE ADVANTAGE OF THIS INFORMATION AT THEIR PERIL * CINOUT TOLERATES A DDNAME, MEMBER, OR FUNCTION PADDED WITH BLANKS * TO NOT MORE THAN 8 CHARACTERS * CINOUT ALSO TOLERATES CERTAIN ILLEGAL FIRST ARGUMENTS WHEN * THE FUNCTION = 'C' * IN PARTICULAR, THE FOLLOWING ALL HAVE THE SAME EFFECT: * CINOUT('DDNAME(GARBAGE)','C') * CINOUT('DDNAME(MEMBER)','C') * CINOUT('DDNAME','C') SPACE * CINOUT MAY BE COMPARED WITH FORTRAN INPUT/OUTPUT * CINOUT(DDNAME,'R',STRING) IS APPARENTLY ABOUT 3 TIMES AS FAST AS * A SNOBOL4 INPUT ASSOCIATION EJECT * THIS PROGRAM IS A REVISION OF A PROGRAM OF THE SAME NAME WRITTEN BY * I BENYACAR, BTL DEPT 3344, HO 2E-412, X5656, JULY 23, 1968 SPACE * THIS PROGRAM IS INTENDED TO PRESERVE ALL FUNCTIONAL PROPERTIES OF * THAT PROGRAM, EXCEPT IN THE FOLLOWING RESPECTS: * 1. THE MAXIMUM LIMIT OF 25 SIMULTANEOUSLY OPEN DATA SETS HAS BEEN * ELIMINATED * 2. BLOCKSIZE, RECORD FORMAT, AND LOGICAL RECORD LENGTH OF * DATA SETS TO BE WRITTEN MUST BE DEFINED IN THE DD STATEMENT * OR DATA SET LABEL, RATHER THAN IN THE DCB * 3. ON END OF FILE, OR ON CHANGE OF MEMBER FOR A GIVEN DDNAME, * THE DATA SET IS CLOSED AUTOMATICALLY EJECT * THIS PROGRAM EXTENDS THE FUNCTIONAL PROPERTIES OF THAT PROGRAM IN * THE FOLLOWING RESPECT: SPACE * WHAT MEMBER OF A PARTITIONED DATA SET IS TO BE READ OR WRITTEN MAY BE * SPECIFIED IN A IBMC FUNCTION REFERENCE, RATHER THAN ONLY IN A * DD STATEMENT * DIFFERENT MEMBERS MAY BE SPECIFIED FOR THE SAME DDNAME AT DIFFERENT * TIMES, SO THAT MULTIPLE MEMBERS OF A PARTITIONED DATA SET CAN BE * PROCESSED THROUGH A SINGLE DD STATEMENT * ONLY ONE MEMBER ASSOCIATED WITH A DDNAME CAN BE PROCESSED AT A * TIME, HOWEVER * WHEN A DIFFERENT MEMBER IS SPECIFIED, CINOUT CLOSES ITS DCB FOR THE * GIVEN DDNAME, ALTERS THE JOB FILE CONTROL BLOCK, AND REOPENS * THE DCB FOR THE NEWLY-SPECIFIED MEMBER * IF IT IS NECESSARY TO PROCESS SEVERAL MEMBERS OF A PARTITIONED * DATA SET CONCURRENTLY, SEVERAL DD STATEMENTS REFERRING TO THE * SAME PARTITIONED DATA SET MAY BE USED * NATURALLY, ONLY ONE MEMBER OF A PARTITIONED DATA SET CAN BE * W R I T T E N AT A TIME * NOTE THAT THIS METHOD OF PROCESSING MEMBERS OF PARTITIONED DATA SETS * WILL, ON OUTPUT, UPDATE THE DIRECTORY ENTRY FOR A MEMBER, BUT * WILL NOT UPDATE ANY DIRECTORY ENTRIES FOR ALIASES * NOTE THAT, UNDER THIS METHOD OF WRITING MEMBERS OF PARTITIONED DATA * SETS, OS/360 REQUIRES A DD STATEMENT DISPOSITION OF OLD IF EXISTING * MEMBERS ARE TO BE REPLACED (COMPARE OS/360 LINKAGE EDITOR SYSLMOD * DD STATEMENT) SPACE * REFERENCES: BTL IBM SYSTEM/360 PROGRAMMING MANUALS * STRAUSS H J, EXTERNAL FUNCTION FOR SNOBOL4, MM-68-3344-3 * IBM OS/360 SYSTEM PROGRAMMER'S GUIDE, C28-6550 * IBM OS/360 SYSTEM CONTROL BLOCKS, C28-6628 SPACE * THE METHOD OF PROCESSING MEMBERS OF PARTITIONED DATA SETS IS TO * OPEN AND CLOSE THE DATA SET FOR EACH MEMBER (YES) * ALTERING THE JOB FILE CONTROL BLOCK BY SUPPLYING JFCBELNM AND BY * SETTING BIT 7 OF JFCBIND1 * THIS METHOD IS CHOSEN FOR THE CONVENIENCE OF USING QSAM RATHER * THAN BPAM SPACE * NOTE THAT (IT HAS BEEN DISCOVERED BY EXPERIMENT THAT) OS/360 * PROVIDES A CAPABILITY FOR READING THE DIRECTORY OF A PARTITIONED * DATA SET AS A SEQUENTIAL DATA SET * IT IS NECESSARY ONLY TO SUPPLY A DD STATEMENT OF THE FORM * //DDNAME DD DSNAME=DATA-SET-NAME, * // DCB=(RECFM=FS,LRECL=256,BLKSIZE=256),.... * THE IBM OS/360 UTILITIES MANUAL (IEBPTPCH) ALLUDES TO BUT DOES NOT * EXPLAIN THIS CAPABILITY * NOTE THAT WELL-DEFINED BUT STRANGE RESULTS ARE TO BE EXPECTED * IF THE DIRECTORY OF A PARTITIONED DATA SET IS BEING READ AS A * SEQUENTIAL DATA SET WHILE THE DIRECTORY IS BEING UPDATED BY * THE ADDITION OF NEW MEMBERS EJECT * EXTENDED MNEMONIC CODES NOT SUPPLIED BY IBM * MACRO *&SYMBOL BHR *&SYMBOL BCR 2,&SYSLIST(1) * MEND * MACRO *&SYMBOL BLR *&SYMBOL BCR 4,&SYSLIST(1) * MEND * MACRO *&SYMBOL BER *&SYMBOL BCR 8,&SYSLIST(1) * MEND * MACRO *&SYMBOL BNHR *&SYMBOL BCR 13,&SYSLIST(1) * MEND * MACRO *&SYMBOL BNLR *&SYMBOL BCR 11,&SYSLIST(1) * MEND * MACRO *&SYMBOL BNER *&SYMBOL BCR 7,&SYSLIST(1) * MEND * MACRO *&SYMBOL BOR *&SYMBOL BCR 1,&SYSLIST(1) * MEND * MACRO *&SYMBOL BPR *&SYMBOL BCR 2,&SYSLIST(1) * MEND * MACRO *&SYMBOL BMR *&SYMBOL BCR 4,&SYSLIST(1) * MEND * MACRO *&SYMBOL BZR *&SYMBOL BCR 8,&SYSLIST(1) * MEND * MACRO *&SYMBOL BNOR *&SYMBOL BCR 14,&SYSLIST(1) * MEND * MACRO *&SYMBOL BNPR *&SYMBOL BCR 13,&SYSLIST(1) * MEND * MACRO *&SYMBOL BNMR *&SYMBOL BCR 11,&SYSLIST(1) * MEND * MACRO *&SYMBOL BNZR *&SYMBOL BCR 7,&SYSLIST(1) * MEND EJECT * LOAD IMMEDIATE MACRO &SYMBOL LI ®,&ABSEXP &SYMBOL LA ®,&ABSEXP.(0,0) MEND * INCREMENT REGISTER MACRO &SYMBOL INCR ® &SYMBOL LA ®,1(0,®) MEND * DECREMENT REGISTER MACRO &SYMBOL DECR ® &SYMBOL BCTR ®,0 MEND * CALL TO A NON-EXTERNAL SYMBOL MACRO &SYMBOL CALL &SYMBOL BAL 14,&SYSLIST(1) MEND EJECT MACRO IEFJFCBN * PARTIAL DSECT FOR JOB FILE CONTROL BLOCK * SEE IBM OS/360 SYSTEM PROGRAMMER'S GUIDE, IEFJFCBN MACRO INSTRUCTION INFMJFCB EQU * DS CL44 JFCBELNM DS CL8 DS CL34 JFCBIND1 DS BL1 DS CL89 MEND EJECT MACRO SAVED * DSECT FOR SAVE AREA SAVED DSECT WD1 DS F HSA DS F LSA DS F RET DS F EPA DS F R0 DS F R1 DS F R2 DS F R3 DS F R4 DS F R5 DS F R6 DS F R7 DS F R8 DS F R9 DS F R10 DS F R11 DS F R12 DS F MEND EJECT MACRO &SYMBOL NULL * STORE THE NULL STRING * RETURN BYTE SIZE OF ZERO TO CALLER &SYMBOL SR 0,0 MEND EJECT MACRO &SYMBOL RESULT * PRODUCE THE RESULT OF THE EXTERNAL FUNCTION GBLC &LANG &SYMBOL L 13,HSA L 14,RET LR 0,MAX AIF ('&SYSLIST(1)' NE 'FAIL').DONE L 0,=F'-2' .DONE RETURN (2,12) MEND EJECT GBLC &LANG GBLC &CLOSE GBLA &SZSADW SNOFLAKE SET SYMBOL &SZSADW SETA 13 SNOFLAKE-DEPENDENT VALUE &LANG SETC 'SNOBOL4' &CLOSE SETC 'DISP' *&CLOSE SETC 'LEAVE' SPACE CINOUT START * PRINT NOGEN * GENERAL PURPOSE REGISTER ALLOCATION MAX EQU 2 ADDRESS EQU 4 LENGTH EQU 5 TO EQU 6 HEAD EQU 3 ELEMENT EQU 11 DCB EQU 8 PROCESS EQU 9 BASE EQU 10 WORK EQU 7 ARGLIST EQU 12 * FLAG SETTINGS FOR DCBRECFM 9/73 DWS FIXED EQU B'10000000' 9/73 DWS VARBLE EQU B'01000000' 9/73 DWS BLCKD EQU B'00010000' 9/73 DWS EJECT DCBD DSORG=(QS) SPACE JFCBD DSECT IEFJFCBN SPACE SAVED EJECT BLOCK DSECT * MASK FOR ELEMENTS OF LIST OF DCB'S QSAM DCB DSORG=PS,MACRF=(GL,PL) DCBNEXT DS A DCBPREV DS A DCBNAME DS CL8 DCBMEMB DS CL8 DCBFNCN DS CL8 LENBLOCK EQU *-BLOCK SPACE * DSECT FOR ARGUMENT LIST ARGVEC DSECT FILE DS F FUNCTION DS F STRING DS F LEN DS F EJECT CINOUT CSECT * SAVE REGISTERS, ESTABLISH ADDRESSABILITY, CHAIN SAVE AREAS SAVE (14,12) LR BASE,15 CONTAINING ADDRESS OF THIS PROGRAM USING CINOUT,BASE TO ADDRESS THIS PROGRAM LA WORK,SAVEAREA OF THIS PROGRAM USING SAVED,WORK TO ADDRESS SAVE AREA OF THIS PROGRAM ST 13,HSA IN SAVE AREA OF THIS PROGRAM DROP WORK USING SAVED,13 TO ADDRESS SAVE AREAS ST WORK,LSA IN SAVE AREA OF CALLING PROGRAM LR 13,WORK CONTAINING ADDRESS OF SAVE AREA THIS PROGRAM * OBTAIN ARGUMENT LIST ADDRESS LR ARGLIST,1 CONTAINING ADDRESS OF ARGUMENT LIST USING ARGVEC,ARGLIST TO ADDRESS THE ARGUMENT LIST * FETCH AND CHECK FIRST ARGUMENT FETCH1 L ADDRESS,FILE LA LENGTH,18 CALL SEARCH FOR FIRST ( ) BNZ PDSFILE IF ARGUMENT CONTAINS ( ) SPACE * FIRST ARGUMENT HAS FORM DDNAME SEQFILE MVC DDNAME,0(ADDRESS) MVC MEMBER,=C' ' TO BLANK MEMBER B FETCH2 EJECT * FIRST ARGUMENT HAS FORM DDNAME '(' MEMBER ')' (PROBABLY) PDSFILE CLI 0(1),C'(' BNE FAIL IF NOT LEFT PAREN LR WORK,LENGTH PRESERVING LENGTH OF FIRST ARGUMENT SR 1,ADDRESS DEVELOPING LENGTH UP TO LEFT PAREN LR LENGTH,1 BCTR 1,0 * STORE DDNAME MVC DDNAME,=C' ' LA TO,DDNAME EX 1,MOVECHAR SPACE * TAKE REMAINDER OF FIRST ARGUMENT LA ADDRESS,1(LENGTH,ADDRESS) SKIPPING LEFT PAREN SR WORK,LENGTH DEVELOPING LENGTH OF REMAINDER DECR WORK SKIPPING LEFT PAREN LR LENGTH,WORK CALL SEARCH FOR SECOND ( ) CLI 0(1),C')' BNE FAIL IF NOT RIGHT PAREN SR 1,ADDRESS LR LENGTH,1 DECR LENGTH SKIPPING RIGHT PAREN MVC MEMBER,=C' ' LA TO,MEMBER EX LENGTH,MOVECHAR B FETCH2 EJECT * SUBROUTINE SEARCH * SEARCH A STRING FOR LEFT OR RIGHT PARENTHESIS * IMPLICIT ARGUMENTS (ADDRESS), (LENGTH) * RETURNS (1), (2), CONDITION CODE SEARCH LTR 1,LENGTH BNP FAIL ON NON-POSITIVE STRING LENGTH DECR 1 TO MACHINE LENGTH FORM EX 1,TRANS RETURN TRANS TRT 0(0,ADDRESS),TRTABLE * TABLE ALL ZERO EXCEPT FOR ( ) TRTABLE DC 77X'00',C'(',15X'00',C')',162X'00' EJECT FETCH2 MVC FUNCNAME(1),FUNCTION SPACE *DECISION TABLE. DECODE AND PROCESS *CONDITION RULES * 1111111111222 * 1234567890123456789012 * DDNAME = DCBNAME -TTTTTTTTTTTTTTTTTTFFF * MEMBER = DCBMEMB -TTTTTTTTTFFFFFFFFFUUU * FUNCTION = R W C O (CURRENT REQUEST) ORRRWWWCCCRRRWWWCCCRWC * DCBFUNC = R W C (PREV. REQUEST) -RWCRWCRWCRWCRWCRWCUUU *ACTION * CLOSE --X-X--XX-XX-XX-XX---- * SPLICE -------XXX------XXX--- * NEWDCB -------------------XX- * OPEN --XXX-X---XXXXXX---XX- * GET -XXX------XXX------X-- * PUT ----XXX------XXX----X- * NULL ----XXXXXX---XXXXXX--X * FAIL X--------------------- *END OF DECISION TABLE EJECT * DECODE FUNCTION IFREAD CLI FUNCNAME,C'r' BE READ CLI FUNCNAME,C'R' BNE IFWRITE READ LA PROCESS,GET B OKFUNC IFWRITE CLI FUNCNAME,C'w' BE WRITE CLI FUNCNAME,C'W' BNE IFCLOSE WRITE LA PROCESS,PUT B OKFUNC IFCLOSE CLI FUNCNAME,C'c' BE CLOSEP CLI FUNCNAME,C'C' BNE FAIL ON INVALID FUNCTION RULE 1 CLOSEP LA PROCESS,NULL OKFUNC EQU * SPACE * SEARCH LIST OF DCB'S FOR MATCHING DDNAME LA HEAD,LISTHEAD HEADING TWO-WAY LIST OF DCB'S LR ELEMENT,HEAD USING BLOCK,ELEMENT MATCHDCB L ELEMENT,DCBNEXT TAKING SUCCESSOR ELEMENT CR ELEMENT,HEAD BE NODCB IF LIST IS EXHAUSTED CLC DDNAME,DCBNAME BNE MATCHDCB IF NOT SAME DDNAME SPACE * (ELEMENT) IS MATCHING DCB * MAKE DCB FIELDS ADDRESSABLE LA DCB,QSAM USING IHADCB,DCB TO ADDRESS DCB FIELDS * IF MEMBER = DCBMEMB & FUNCNAME = DCBFUNC CLC MEMBER(16),DCBMEMB BER PROCESS RULES 2, 6, 10 SPACE * IT IS NECESSARY TO CLOSE THE DCB * RULE 2 BECOMES 4; 5, 7; 11 AND 12, 13; 14 AND 15, 16 CALL CLOSE SPACE * IS THE FUNCTION CLOSE LA WORK,NULL CR WORK,PROCESS BNE OPEN AIF ('&CLOSE' EQ 'LEAVE').NULL CALL SPLICE .NULL B NULL RULES 8, 9, 17, 18, 19 EJECT * COMPARE FUNCTION TO 'CLOSE' AND TERMINATE IF EQUAL NODCB LA WORK,NULL CR WORK,PROCESS BER PROCESS * OBTAIN STORAGE FOR DCB NEWDCB GETMAIN R,LV=LENBLOCK LR ELEMENT,1 SPACE * SET UP DCB USING BLOCK,ELEMENT MVC BLOCK(LENBLOCK),LISTHEAD SPACE * ADD DCB TO LIST LA HEAD,LISTHEAD DROP ELEMENT USING BLOCK,HEAD L WORK,DCBPREV ST ELEMENT,DCBPREV DROP HEAD USING BLOCK,WORK ST ELEMENT,DCBNEXT DROP WORK USING BLOCK,ELEMENT ST HEAD,DCBNEXT ST WORK,DCBPREV * MAKE DCB FIELDS ADDRESSABLE LA DCB,QSAM USING IHADCB,DCB TO ADDRESS DCB FIELDS * SET DDNAME IN DCB MVC DCBDDNAM,DDNAME EJECT * CHECK WHETHER DD STATEMENT WAS SUPPLIED OPEN LA WORK,JFCB USING INFMJFCB,WORK TO ADDRESS JOB FILE CONTROL BLOCK FIELDS * JFCBELNM IS SUPPLIED BY THE SYSTEM AS BLANKS OR A NAME RDJFCB (QSAM),MF=(E,OPENLIST) SEE SYSTEM PROGRAMMERS GUIDE LTR 15,15 BNZ NOTOPEN WHEN NO DD STATEMENT WAS SUPPLIED SPACE * CHECK WHETHER MEMBER OF PARTITIONED DATA SET IFPDS CLC MEMBER,=C' ' BE OPENUP IF FUNCTION REFERENCE SPECIFIED NO MEMBER * SUPPLY JFCBELNM AND SET JFCBIND1 MVC JFCBELNM,MEMBER OI JFCBIND1,B'00000001' DROP WORK SPACE * OPEN DCB FOR INPUT OR OUTPUT OPENUP LA WORK,GET CR WORK,PROCESS BE OPENIN LA WORK,PUT CR WORK,PROCESS BE OPENOUT * FUNCTION NOT 'READ', NOT 'WRITE' B NOTOPEN ON PROGRAM ERROR * FOR OPEN TYPE=J SEE SYSTEM PROGRAMMERS GUIDE OPENIN OPEN (QSAM,(INPUT,&CLOSE)),MF=(E,OPENLIST),TYPE=J B IFOPEN OPENOUT OPEN (QSAM,(OUTPUT,&CLOSE)),MF=(E,OPENLIST),TYPE=J SPACE * CHECK WHETHER OPEN IS SUCCESSFUL IFOPEN TM DCBOFLGS,B'00010000' BZ NOTOPEN IF OPEN WAS UNSUCCESSFUL * STORE MEMBER AND FUNCNAME IN LIST ELEMENT OPENED MVC DCBMEMB(16),MEMBER * BRANCH TO GET, PUT, OR NULL. BR PROCESS RULES 4, 7, 13, 16 SPACE * DATA SET COULD NOT BE OPENED * NO DD STATEMENT, OPEN UNSUCCESSFUL, OR PROGRAM ERROR NOTOPEN MVI DCBFNCN,C'C' AIF ('&CLOSE' EQ 'LEAVE').FAIL CALL SPLICE .FAIL B FAIL IF DATA SET COULD NOT BE OPENED EJECT * SUBROUTINE CLOSE * CLOSE DCB QSAM * IMPLICIT ARGUMENT (ELEMENT) * USES (WORK) * IS THE DCB ALREADY CLOSED CLOSE CLI DCBFNCN,C'C' BE CLOSED LR WORK,14 PRESERVING RETURN POINT CLOSE (QSAM,&CLOSE),MF=(E,OPENLIST) MVI DCBFNCN,C'C' LR 14,WORK RESTORING RETURN POINT CLOSED RETURN EJECT * SUBROUTINE SPLICE * SPLICE THE DCB (ELEMENT) OUT OF THE LIST OF DCB'S * IMPLICIT ARGUMENT (ELEMENT) AIF ('&CLOSE' EQ 'LEAVE').SPLICE USING BLOCK,ELEMENT SPLICE L HEAD,DCBNEXT L WORK,DCBPREV DROP ELEMENT USING BLOCK,HEAD ST WORK,DCBPREV DROP HEAD USING BLOCK,WORK ST HEAD,DCBNEXT DROP WORK USING BLOCK,ELEMENT FREEMAIN R,A=(ELEMENT),LV=LENBLOCK RETURN .SPLICE ANOP EJECT GET GET QSAM LH LENGTH,DCBLRECL LR MAX,LENGTH LR WORK,MAX O LENGTH,=X'40000000' MVC PARM,DCBRECFM ALS 3/7/74 NC PARM,X'C0' ALS 3/7/74 CLI PARM,X'40' ALS 3/7/74 BNE GET#ST NOT V, ALS 3/7/74 LA 1,4(,1) BUMP PTR PASSED RDW IN RECORD 9/73 DWS SH LENGTH,=H'4' DECR LENGTH OF RECORD 9/73 DWS SH WORK,=H'4' SH MAX,=H'4' GET#ST EQU * 9/73 DWS L TO,STRING LR ADDRESS,1 CALL MOVE B RETURN EJECT * SUBROUTINE MOVE * MOVE A CHARACTER STRING OF ANY LENGTH * IMPLICIT ARGUMENTS (ADDRESS), (LENGTH), (TO), (WORK) * USES (ADDRESS), (LENGTH), (TO) * RETURNS (ADDRESS), (LENGTH), (TO) MOVE LTR LENGTH,LENGTH BNP DONEMOVE IF MOVING NULL STRING MVCL TO,ADDRESS DONEMOVE RETURN MOVECHAR MVC 0(0,TO),0(ADDRESS) EJECT * PRINT GEN 9/73 DWS PUT MVC PARM,DCBRECFM TEST IS VARIABLE, ALS 3/74 L LENGTH,LEN LTR LENGTH,LENGTH BNP FAIL O LENGTH,=X'40000000' L ADDRESS,STRING NC PARM,X'C0' ALS 3/74 CLI PARM,X'40' ALS 3/74 BE PUT#V ALS 3/74 PUT QSAM 9/73 DWS LR TO,1 FETCH3 LH WORK,DCBLRECL CALL MOVE B NULL TO SKIP VRBLE LENGTH STUFF 9/73 DWS PUT#V LA WORK,4(,LENGTH) ADD 4 FOR RDW BYTES 9/73 DWS STH WORK,DCBLRECL UPDATE LRECL BEFORE PUT 9/73 DWS PUT QSAM 9/73 DWS LR TO,1 HAVE PTR TO NEXT BUFFER 9/73 DWS STH WORK,0(,TO) SET LENGTH IN 1ST HALF OF RDW 9/73 DWS MVC 2(2,TO),=H'0' SET ZEROS IN 2ND HALF OF RDW 9/73 DWS LA TO,4(,TO) BUMP PTR TO START OF BUFFER 9/73 DWS CALL MOVE TO MOVE STRING INTO BUFFER 9/73 DWS * PRINT NOGEN 9/73 DWS EJECT NULL NULL RETURN RESULT SUCCEED SPACE EOF CALL CLOSE AIF ('&CLOSE' EQ 'LEAVE').EOF CALL SPLICE .EOF ANOP L 13,HSA L 14,RET SR 0,0 RETURN (2,12) FAIL RESULT FAIL EJECT * STRING DESCRIPTOR BLOCK FOR STRINGS RETURNED DS 0D SPACE * DCB EXIT LIST AND JOB FILE CONTROL BLOCK DS 0F EXITLIST DC X'87',AL3(JFCB) JFCB DS CL176 SPACE OPENLIST OPEN (LISTHEAD),MF=L SPACE * MODEL BLOCK IN LIST OF DCB'S AND HEADER OF THAT TWO-WAY LIST LISTHEAD DS 0F MODEL DCB DSORG=PS,MACRF=(GL,PL),EXLST=EXITLIST,EODAD=EOF DC A(LISTHEAD),A(LISTHEAD) DDNAME DC CL8' ' MEMBER DC CL8' ' FUNCNAME DC C' ' DC CL7' ' SPACE SAVEAREA DS 18F PARM DS F END CINOUT IST AND JOB FILE CONTROL BLOCK DS 0F EXITLIST DC X'87',AL3(JFCB) JFCB DS CL176 SPACE OPENLIST OPEN (LISTHEAD),MF=L scanf (p1, p2, p3, p4, z0,z1,z2,z3,z4,z5,z6,z7,z8,z9) int p1, p2, p3, p4; { /* first arg can be a control string, a file id, or -1 */ int ptrs[10], nptrs, j, ip, flp, k; extern int cin; extern (*_Igetc)(), (*_Iungc)(), cgetc(), ungetc(), _Igstr(), _Iungs(); extern char *_Iinpt; ip = 0; if (p1 == -1) {k = 1; _Iinpt = p2;} else if (p1 >= 0 && p1 < 10) k = 0; else k = -1; if (k <= 0) {_Igetc = cgetc; _Iungc = ungetc;} else {_Igetc = _Igstr; _Iungc = _Iungs;} nptrs = nargs(14) -2 - k; for (j= 0; j < nptrs; j++) ptrs[ip++] = (&p3)[j+k]; return (_Iscan ((k==0 ? p1 : cin), (&p2)[k], ptrs)); } _Iscan (fileid, format, listp) char *format; int *listp; { char ch, _Inxch(); int nmatch; extern int _Isfil; _Isfil = fileid; nmatch = 0; while (1) switch (ch= *format++) { case '\0': return (nmatch); case '%': switch (_Isfrm(&format, *listp++)) { case 0: listp--; break; case -1: return (nmatch > 0 ? nmatch : -1); default: nmatch++; } case ' ': case '\n': case '\t': break; default: if (ch != _Inxch()) return(nmatch); } } int _Isfil 0; _Ichar (cptr) char *cptr; { char ch, _Inxch(); if ((ch = _Inxch()) < 0) return (-1); if (cptr == 0) return (0); *cptr = ch; return (1); } /*%%%%% _Iflot (fptr, length) float *fptr; int length; { char temp[75]; int _Inodg(); float x; double atof(); if (_Isstr(temp, length, _Inodg) < 0) return (-1); x = atof(temp); if (fptr == 0) return (0); *fptr = x; return (1); } %%%%%*/ _Inodg (ch) char ch; { if (_Idigt(ch)) return (0); switch (ch) { case 'E': case 'e': case '.': case '+': case '-': return (0); } return (1); } _Isfrm (spec, pointer) char **spec; int pointer; { int length, lflag, _Iestr(), _Ispnd(); char ch; length = lflag = 0; while (1) switch (ch = *((*spec)++)) { case '*': pointer=0; break; case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': length = length*10 + ch - '0' ; lflag++; break; case 'o': case 'O': /* octal */ return(_Iint(pointer, lflag ? length : 100, 8)); case 'x': case 'X': /* hex */ return(_Iint(pointer, lflag ? length : 100, 16)); case 'd': case 'D': /* decimal */ return (_Iint(pointer, lflag ? length : 100, 10)); case 'c': case 'C': /* character */ return (_Ichar(pointer)); case 's': case 'S': /* string */ return (_Isstr(pointer, lflag ? length : 100, _Iestr)); case 'f': case 'F': case 'e': case 'E': /* float */ /*%%%% return (_Iflot(pointer, lflag ? length : 100)); */ ermsg("SCAN: no floating point\n",0); /*%%%%*/ case 'l': case 'L': /* double (long */ /*%%%%% ermsg("SCAN: no floating point\n",0); return (_Ilong (pointer, lflag ? length : 100)); %%%%*/ case '[': /* special strings */ _Imtab(spec); return (_Isstr (pointer, lflag ? length : 100, _Ispnd)); case '%': if (_Inxch() != '%') return (-1); return(0); case '\0': _Ierr("scanf: bad format termination\n"); default: _Ierr ("scanf: format character %c", ch); } } _Iint (iptr, length, numbase) int *iptr, length; { int n, minus, numdig; extern int _Isfil, (*_Iungc)(), (*_Igetc)(); int c, dval; n = minus = numdig = 0; switch ((c=_Inxch())) { case '-': minus = 1; case '+': break; default: (*_Iungc)(c,_Isfil); } while ((dval=_Idigt(c=((*_Igetc)(_Isfil)), numbase ) ) >= 0 && numdig++ < length) n = n*numbase + dval; (*_Iungc)(c,_Isfil); if (numdig == 0) return (-1); if (iptr == 0) return (0); *iptr = minus ? -n : n; return (1); } _Idigt (x, base) { switch (x) { case '0': case '1': case '2': case '3': case '4': case '5': case '6': case '7': return(x-'0'); case '8': case '9': if (base > 8) return(x - '0'); case 'a': case 'b': case 'c': case 'd': case 'e': case 'f': if (base >10) return(x - 'a' + 10); case 'A': case 'B': case 'C': case 'D': case 'E': case 'F': if (base > 10) return(x-'A' + 10); } return(-1); } /*%%%% _Ilong (dptr, length) double *dptr; int length; { char temp[75]; int _Inodg(); double x; double atof(); if (_Isstr(temp, length, _Inodg) < 0) return (-1); x = atof(temp); if (dptr == 0) return (0); *dptr = x; return (1); } %%%%%*/ _Isstr (sptr, length, stopf) char *sptr; int length, (*stopf)(); { int ch, initlen, _Inxch(); extern int _Isfil, (*_Igetc)(), (*_Iungc)(); initlen = length; if ((ch=_Inxch()) < 0) return (-1); (*_Iungc)(ch,_Isfil); while (!((*stopf)(ch=(*_Igetc)(_Isfil))) && length-- > 0) if (sptr != 0) *(sptr++) = ch; if (ch >= 0) (*_Iungc)(ch,_Isfil); if (length == initlen) return (-1); if (sptr == 0) return (0); *sptr = '\0'; return (1); } _Iestr (c) char c; { if (_Ispce(c)) return (1); if (c == '\0') return (1); return (0); } _Ierr (message, a, b, c, d, e) char message[]; { printf("ERROR "); printf(message, a, b, c, d, e); cputc('\n'); cexit(); } char _Iendm[128] {0}; _Imtab (formatp) char **formatp; { /* make up special table of string ending characters */ int i, normal; char ch; /* normally all characters end string except those listed */ normal = 1; if (**formatp == '^') {normal = 0; (*formatp)++;} for (i= 0; i < 128; i++) _Iendm[i] = normal; while ((ch = *((*formatp)++)) != ']') _Iendm[ch] = !_Iendm[ch]; } _Inxch () /* returns next character which is not _Ispce */ { extern int _Isfil, (*_Igetc)(); int ch; while ((ch = (*_Igetc)(_Isfil)) > 0 && _Ispce(ch)); if (ch > 0) return (ch); return (-1); } _Ispce (c) char c; { switch (c) { case ' ': case '\n': case '\t': return(1); } return(0); } _Ispnd (ch) char ch; { return (_Iendm[ch] > 0); } char *_Iinpt; int (*_Igetc)(), (*_Iungc)(); _Igstr () { extern char *_Iinpt; return (*_Iinpt++); } _Iungs(ch) { extern char *_Iinpt; *--_Iinpt = ch; } ; } _Inxch () /* returns next character which is not _Ispce */ { extern int _Isfil, (*_Igetc)(); int ch; while ((ch = (*_Igetc)(_Isfil)) > 0 && _Ispce(ch)); if (ch > 0) return (ch); return (-1); } _Ispce (c) char c; { switch (c) { case ' ': case '\n': case '\t': return(1); } return(0); } _Ispnd (ch) char ch; { return (_Iendm[ch] > 0); } char *_Iinpt; int (*_Igetc)(), (*_Iungc)(); _Igstr () { extern char *_Iinpt; return (*_Iinpt++); } _Iun# include "iodef.c" ungetc (c, fnin) { struct iobuf *fp; extern int cin, _gate; int fn; if (_gate == 0) cgate(); fn = nargs(2) > 1 ? fnin : cin; /* push back onto input */ if (fn < 0 || fn >NFILES || (fp = _fbuffp[fn]) == 0) ermsg("UNGETC: no file %d\n",fn); if (fp->out > 0) ermsg("UNGETC: attempt to push back output file %d\n",fn); if (fp->cp <= fp->buf) ermsg("UNGETC: buffer full file %d",fn); if (fp->nchars < 0) return (c); *--fp->cp = c; fp->nchars++; return (c); } Iinpt; return (*_Iinpt++); } _Iun.de mn .sp .ne 3 .I \\$1 .R .LP .. .TL Notes on the IBM C compiler. .AU Mike Lesk .AI .MH .PP This note assists in the setup and handling of the IBM C compiler. It describes the makeup of the compiler and library, the runtime environment, and the handling of assembler and operating system dependencies. .PP Six sections follow. .IP 1. Contents of the system. .IP 2. Code environment. .IP 3. Outline of the library. .IP 4. Operating System dependencies .IP 5. Assembler dependencies. .IP 6. Macro descriptions. .LP Since the compiler is still under development, beware of out of date copies of this memo. The next language feature scheduled for this compiler is the 'register' storage class for variables. .PP It is not expected that anyone unfamiliar with C or the IBM 370 systems will understand this memorandum. Nor is it likely to be profitable for anyone not involved in system maintenance to read it. .NH Contents. .PP There are several distinct programs associated with the C system; they are separated for ease of maintenance and portability. The C system is compatible with either OS or TSS or TSO operating system environments on an IBM 370; output code is assembler code, but can assemble with Assembler H, Assembler G, or the TSS assembler. At Bell Laboratories, the TSS operating system runs at Indian Hill; the OS operating system runs at Indian Hill, Holmdel, and some other locations. The character sets in use at Bell Laboratories may not agree with those in use elsewhere. .PP The .I compiler .R proper is the largest single set of programs. It translates the source language, except for the lines beginning with the # character, into assembly code. It exists in only one version; the assembly code contains macro instructions wherever operating system dependencies intrude. .PP The .I preprocessor .R is a C to C translator; it removes all lines beginning with # and produces a valid C program with the same meaning. Note that whereas the compiler is a simple one input stream one output stream program which makes minimal demands on the I/O library, the preprocessor (because of the .I include .R operation) has multiple inputs and expects to be able to open files by name. .PP The .I run-time library .R can be broken into two major parts. Routines such as .I cgetc, cputc .R and .I printf .R do not actually do any I/O, merely buffering up characters into lines. The actual system interactions are preformed by .I inout .R and .I #access .R and a few other routines. In general, system dependencies have been isolated in as few areas as possible. The actual transmission of records is outside of the C library; a large assembler program from Raritan River is used to perform OS I/O transfers, and the BLISS library is used on TSS. .PP The assembler code produced by the compiler is specialized to a particular operating system and assembler by the .I macro definitions. .R There are three sets of macro definitions: one for OS Assembler H, another for OS Assembler G, and one for TSS Assembler. There is no distinction between TSO and OS code. .PP Finally, note that the compiler contains two sections which are generated from .I code tables .R using the program .I cvtab. .R This is essential to modifying the compiler, although not necessary for reproducing the present version since the generated programs (c14.c and c15.c) are also supplied. .PP To get off the ground, it is necessary to have either a UNIX system or the load modules for the compiler, since it is self maintaining. The standard magnetic tape IBM C distribution thus contains load modules for the compiler and preprocessor and a partitioned data set containing the library. .NH Code organization. .PP The machine's eye view of the object code organization is best understood in terms of the register usage. The registers are divided into several classes: .IP Registers 0, 1, 13, 14 and 15 are used in calling sequences. The BLISS calling sequence is default. In particular, it is the only way C programs are prepared to be called. The OS FORTRAN linkage can be used to call programs not written in C. .IP Registers 8, 9, 10, 11 and 12 are used for addressing. In particular, the stack is simulated by addresses off of register 12. Arguments, automatics and the save area are stored on the stack. In any one program, the layout of the stack is in the order: arguments (four bytes per fixed argument, eight byte per float argument), save area (64 bytes), automatics, temporaries, and finally items being passed to further subroutines. .IP Registers 0, 1, 2, 3, ... are used for expression evaluation (register 0 can not be used for certain pointer operations, however). It is unusual to find an expression requiring even register 4. The class of "register" variables is not yet recognized as distinct from ordinary automatics in the IBM C compiler. .LP Although the register numbers are parameterized in the object code, they are actually fixed by the specification of BLISS compatibility. For those not familiar with the BLISS call, here is the subroutine interface: .IP The .I calling .R program computes the arguments and stores them in addresses 0(13), 4(13), ... where register 13 points to the end of the stack space used by this program. Floating arguments are passed as double and therefore require eight bytes; all other kinds of arguments, including pointers, take four bytes each. The total number of bytes of arguments is placed in register 1. The address of the .I called .R program is placed in register 15 and (a) on OS a BALR 14,15 is done, (b) on TSS the address of the PSECT of the called program is placed in register 0 and a BASR 14,15 is done. .PP On entry the .I called .R program stores the registers on the stack, sets register 12 to address its stack space (merely copying register 13 to register 12), and initializes register 13 to point to the end of the stack space it uses, therefore the beginning of the arguments for any routine it calls. On exit the registers are restored and the value of the function (if any) is returned in register 0 (in floating register 0 if the result is float or double) .PP The allocation of base registers is as follows: (code) registers 10 and 8; (data) registers 11 and 9. These base registers are established by the prolog macro. A few easy-to -determine facts from a C core image are that (register 10)-16 contains the name of the currently executing routine and (register 15)-16 contains the name of the most recently called routine. .PP The C language considers underscore (_) to be an alphabetic character. Except on UNIX, this is not a legal character for the loader. On the 370, therefore, underscore is translated to # in external ames. When a program is named in this memo as (e.g.) .I #isddn .R it must be called from C as .DS _isddn() .DE and the name with the # character must never be used in a C program. .PP Since the compiler does not bother to 8-align double precision numbers the code it generates will not execute on a 360, as opposed to a 370, processor. .NH Library .PP The library organization is motivated by the desire to separate the functions performed as much as possible in the interests of portability, maintainability, and permitting users to use some functions without others. There are some routines, such as printf and scanf, which are more or less the same on all systems. They use putchar and getchar and do not care how the stream I/O is actually performed. Next most portable are the cgetc and cputc routines. These routines must know what buffering strategy to employ, so they differ between UNIX and the record-oriented systems. On all the record-oriented operating systems, however, they are similar and use a common strategy. This is to translate "newline" to "record gap" on output and vice versa on input. A buffer is provided for up to 512 character lines. Each newline causes a record to be transmitted. .PP Underneath these routines, however, is a routine named (on the 370 library) .I inout. .R It performs the record I/O function by calling some other facility, considered outside the scope of the C library. On the OS system, this is the RR INOT program; on the TSS system, this is the BLISS library. .PP A similar strategy is employed with the storage allocator. The routines .I calloc .R and .I cfree .R are identical on OS and TSS; the differences are represented by the two different routines for performing .I getmain .R supervisor calls. .PP A few other low level routines are needed in the library for I/O. At present the file accessing mechanism is complete only at IH TSS. The extra low level routines are: .IP .I #isddn .R to perform a FINDJFCB supervisor call and determine whether its argument is a ddname; .IP .I #isdsn .R to perform a FINDS supervisor call and determine whether its argument is a dsname; and .IP .I #ddef .R to perform the DDEF supervisor call required to create new data sets; and .IP .I #rel .R to perform the REL supervisor call to release previously attached data sets. .PP The most complex problem faced by the I/O library is the need to provide wrapup (buffer flushing, data set closing) on exit when the standard I/O has been used, without loading the I/O library and causing wrapup when there has been no use of standard I/O. Also, the standard default file opening of files 0, 1 and 2 should be provided for anyone using the standard library; but not forced on people using their own code. This is handled (a) on OS by using weak external references and (b) on TSS by using a program .I cgate .R and two external cells, .I #gate .R and .I #gates. .R .IP (OS) On entry to any program in the I/O library, the routine .I cgate .R is called to interrogate the one_time gate cell .I #gate .R and on the first call to any I/O routine, the standard files are opened. In addition, the gate routine contains a normal external reference to .I cexit. .R The standard main program invocation contains a weak external reference to .I cexit .R and a conditional invocation of .I cexit .R if the weak reference has been supplied. Thus, (a) if the user calls anything in the I/O library, when he executes it the gate cell is set, the standard files are opened, and since .I cexit .R is referenced it is called for wrapup; while (b) if the user doesn't call anything in the I/O library, none of it except the gate cell is loaded, and on exit there is no wrapup call since .I cexit .R was not loaded. .IP In addition, to permit an exit from the middle of a program module without performing a stack trace to find the save area from the operating system, the stack base address (STACK$) is made an entry point so that it is accessible to the exit routine, which can determine the original save area and simulate a normal return to the supervisor. .IP (TSS) On entry to any program in the I/O library, the routine .I cgate .R is called to interrogate the one-time gate cell .I #gate .R and on the first call to any I/O routine, the standard files are opened. In addition, the gate cell is stuffed with the address of the .I cexit .R routine to perform wrapup. On exit, the .I #gate .R cell is interrogated; if non zero it is taken as a function pointer and branched to. Thus, (a) if the user calls anything in the I/O library, when he executes it the gate cell is set and on exit wrapup takes place; while (b) if the user doesn't call anything in the I/O library, none of it except the gate cell is loaded, and on exit the gate cell is still zero and no wrapup is performed. .IP In addition, to permit an exit from the middle of a program module without performing a stack trace to find the save area from the operating system, the cell .I #gates .R is stuffed on entry with the base of the stack; from this the exit routine can determine the original save area and simulate a normal return to the supervisor. .LP Aside from the above discussion, there is no use of weak external references in OS, and no use of the stack base cell in TSS. .PP The remaining tricky routine is .I getargs .R which is called before the main program to fetch the 'parm string' or command line to set up the arguments for the main program. This program exists in two different formats, one for OS and one for TSS. On OS the equivalent of the UNIX command line is in the PARM='...' string of the EXEC card for the C job step; on TSS an appropriate invocation of a C program is a line of the form .DS module 'command line' .DE and again, the quoted string is the equivalent of the UNIX command line. Within this string both > and < are recognized as on UNIX for default I/O diversion; as explained above, if the user does not call any C library I/O routines they are ignored. The only immediate effect on recognizing these command line diversions is to change the default name pointers that will be used to open files 0, 1 and 2 if and when .I cgate .R is finally called. .NH Operating System dependencies .PP Regrettably, there are many differences between OS and TSS operating conventions, and not all of these have been papered over by the C implementation. There is always a choice between making everything UNIX compatible, at the expense of making usage quite unusual on the IBM system; and being compatible with the local system, annoying those bringing programs over from UNIX. In general an effort has been made to keep the semantics of the language constant, while allowing the methods of compiling and loading to agree with local practice. .PP C was designed on a computer which supports the ASCII character set. Source programs must, therefore, be typed on a terminal which contains all the ASCII characters, including particularly the square and curly brackets, and the backslash. Although all of these characters are defined in the EBCDIC character set, on TSS in particular there is some disagreement about what they are. Since the keywords are only recognized in lower case, TSS users must enter programs in KA mode; three characters differ in KA and KB mode, and to avoid a horrendous problem of associating every program with the mode in which its input must be entered, the input character fetch routine .I cgetc .R translates the three strange characters (single quote, backslash, and vertical bar) to standard representations. This means that C can not copy an arbitrary file without changing it. Note also that the Holmdel and Indian Hill character sets are different; and that the common C expression .DS c >= 'a' && c<= 'z' .DE does .I not .R test whether c is a lower case character in the EBCDIC character set. Table 1 shows the character set differences between Holmdel and Indian Hill IBM systems. .c2 * .sp ____________________________________________________________ .sp .ce Table 1 .sp .ce Character Set Variation .TS l l l l l l Character KA mode KB mode Holmdel Standard \e backslash E0 5F E0 E0 ' single quote AE 7D 7D 7D* [ open bracket 8C 8C AD AD ] close bracket AC AC BD BD { open brace C0 C0 8B C0 } close brace D0 D0 9B D0 .c2 ' ~ tilde A1 A1 5F A1 ^ circumflex BD BD 9A 9A | vertical bar 6A 4F 4F 4F .TE .sp * The standard expects the Ascii ' (047) to correspond to hex 90, but it is clear that programming languages on the 370 will continue to use 7D as the single quote/apostrophe character. .sp Notes: KA and KB modes refer to the two keyboard input modes on IH TSS. "Standard" is the proposed new Bell Laboratories IBM character set, to be adopted in March 1976. The table entries are the hexadecimal representation of the characters. .br ____________________________________________________________ .br .PP In entering the program, care should also be taken either to stick to short lines or avoid formats in which record lengths are limited to 80 characters. In particular, when moving programs from UNIX, be aware that many UNIX C programs contain lines of 120 characters or so in length. .PP If the character set in the compiler is not what you want, it can be changed by altering the initialization constants in the arrays .I atoe .R (ascii to ebcdic) and .I etoa .R (ebcdic to ascii) in the file .I c04.c .R of the compiler. Note, if you start changing these files, that each must be a 256-character array, that the mapping between character sets MUST be one to one, and that the two tables must be exact inverses. This is so important that you should check any changes you make with a program before installing a new version. When these tables are changed, the entire compiler should be recompiled; the new compiler will then use the new character set. It does not matter what you do with the characters numbered above 127 in the ASCII set so long as the tables are one to one and invert correctly. .PP The command procedures to invoke the compiler on the now-written program are still in a state of flux. .IP (TSO) There is a command procedure (not yet public) which assumes the source data set name conforms to NAME.data, takes an argument of NAME, and delivers a data set named NAME.obj. There need be no relation between NAME and any entry point of the program being compiled. However, the normal mode of storing library programs is as incompletely linked modules stored in a partitioned data set; for the loader and link editor to search these correctly it is necessary for the module name to agree with an entry point name. If there are several entry points, the remaining entries should be alias names of the member. In the library, this occurs with the routines COPEN (alias #FBUFFP) and #DEFINP (aliases #DEFOUT and #DEFERR). .IP "(OS, not TSO)" Since the "include" operation can not be performed under OS/370 the compiler is not much use here. .IP (TSS) Normally C programs are stored in data sets of the style source.NAME. The 'cc' command (not yet public) when invoked as .DS cc name .DE compiles such a program and places the result in the top job library of your job library stack. The 'name' argument is used as the module name. Because of restrictions imposed by the IH loader, this module name must .I not .R be the same as the entry name of the program. In fact, .I all .R module names and entry point names on a library must be distinct. .IP Since main programs are also placed on libraries at IH, rather than being kept as object modules as on OS, the TSS macros have been modified to suppress the external definition of MAIN as an entry and avoid any common entries for main programs. This is in contrast to the OS situation, where every main program contains an entry point STACK$ pointing to the stack base. .LP Having managed to compile the C program, it must now be loaded. The C library is not yet publicly available at Holmdel. At Indian Hill it is stored on 'HANIA.C.LIB' which may be shared by anyone. The BLISS parts library (SPOT.ZPNPARTS(0) on Red TSS and BANG.ZPNPARTS(0) on Green TSS) must also be on your joblib stack. .PP Much of this command language may be avoided on IH TSS by using the .I ccrun .R procedure. The command .DS ccrun name,'arguments' .DE will run program .I name .R with a command line of .I name .R concatenated with .I arguments. .R .PP When running, note one enormous difference in the I/O systems. On TSS, data sets may be accessed dynamically whereas on OS they may not be. Hence the "file name" argument to COPEN on OS must be a .I ddname. .R On TSS the name may be either a DDNAME or a DSNAME. The I/O library first checks for a valid DDNAME; if the given name is not a DDNAME a DSNAME is tried; if neither is found, and the file is opened for writing, a new data set is created with the indicated name. .NH Assembler dependencies. .PP The major difference between the assemblers is caused by the existence of the PSECT/CSECT pair system on TSS, and the presence of the LOCTR (location counter) pseudo-operation on OS Assembler H. On TSS all compiler output must be sorted into read-only and read-write areas, and assigned appropriately. For convenience, the code is also sorted on OS, but the distinction is not important. With Assembler H there is only one CSECT per program file, with a blank name; the various location counters needed are handled with the LOCTR pseudo-op. Assembler G requires multiple CSECTS; the name is taken from the file name (as in the case of the module name on TSS) and the file names for assemblies with Assembler G must therefore be unique. The UNIX compiler also separates code and data, but in a different way. .PP Compiler output is sorted into seven categories, each imagined as a different 'location counter' although not implemented that way. A set of seven macro instructions define imaginary location counters, as shown below. Only the code and data areas need be addressed; the initialized string and main areas are only addressed by explicit address constant reference. .IP code Executable instructions are assembled under the macro .I codeloc. .R These are read-only and placed in a PUBLIC CSECT on TSS. .IP data Static data in a program file are placed under the macro .I dataloc .R and placed in a PSECT on TSS. .IP strings Strings occurring in ordinary context (e.g. assignment to character pointers) are placed under the macro .I strgloc .R and mixed into the data segment. .IP Strings occurring in initialization context can not be mixed with data (consider the problem of handling both the pointers and the characters in the initialization for .sp char *array[] {"Washington", "Adams", "Jefferson", ...}; .sp and so the .I istrloc .R provides another location counter for initialized strings. This requires a third control section in TSS assembler or assembler G. .IP literals The literals are placed in the .I litloc .R macro area. This is basically read-only, but may contain address constants; hence literals are placed with code on OS and with data on TSS. .IP externals The transfer vector for externals is similarly read-only but contains address constants; it also goes with code on OS and data on TSS. The name of the macro is .I tvecloc. .R .IP main The main program must have a separate control section because the stack, which it contains, is too large to have anything after it which is addressable. Hence a macro .I mainloc .R provides a final control section. At most, then, in assembler G or TSS assembler, there may be four control sections. .LP C does not adjust the number of base registers used for addressing to the program size. There are two base registers assigned to code and two to data. The transfer vector, which must be addressable, is placed at the end of the data. Hence (1) no function compiling into more than 8192 bytes of code can be expected to run and (2) no file containing more than 8192 bytes of static data and any code can be expected to run. Note that (1) a file may contain many programs so long as no individual function compiles into more than 8192 bytes and (2) a file containing no functions, only declarations may allocate any amount of storage. .PP Alternatively, programs written to obtain their working storage arrays with the .I calloc .R dynamic allocator will not have addressing problems. It is in fact planned to replace all large arrays with pointers to dynamically obtained arrays in the compiler; this will eliminate the addressing problem for data. The code addressing problem is not as serious, since the source and object code are roughly the same size. A function 8000 bytes long is very unusual. .PP The most serious difference between the OS and TSS environments is in the initialization of storage for programs executed several times in sequence. On OS, all initialized storage is re-initialized when the program is re-executed. But on TSS, the data areas from the previous program load are retained when the same program is started again. This is at variance with UNIX and GCOS practice as well. Users not planning to use this TSS 'feature' would do well to type .I unload name .R before entering .I ccrun name .R for security. By contrast, storage obtained dynamically on UNIX, GCOS and OS is initially random; on TSS it is zero. .NH Macro definitions. .PP The macros used by the compiler, and their meanings, are listed here. .mn bcall Executes a subroutine call using the BLISS linkage. The arguments are assumed set up. Since all pointers are one word, while 2 words of information are required to call a function on TSS, a TSS function pointer actually points to a two word vector containing the CSECT and PSECT addresses of the actual function. On OS a function pointer is simply the entry point address. .mn fcall Executes a subroutine call using the FORTRAN linkage. The arguments are assumed set up. .mn mainloc Uses the location counter for the main program. .mn codeloc Uses the location counter for code. .mn dataloc Uses the location counter for data. .mn strgloc Uses the location counter for strings that may be mixed with data. .mn istrloc Uses the location counter for strings being initialized externally that may not be mixed with data. Consider declarations of the form .ip char *listp[] {"first", "second", "third"}; .tp .mn litloc Uses the location counter for literals. Mixed with either code or data. .mn tvecloc Uses the location counter for the transfer vector. Mixed with either code or data. .mn intaddr Define an address pointer to an internal data cell. .mn extaddr Define an address pointer to an external data cell. .mn intfunc Define a function pointer for a function defined in this file. On OS this macro defines a single word pointing to the function entry; on TSS three words are defined; the first points to the remaining two words, which are the function CSECT and PSECT addresses. .mn extfunc Define a function pointer for a function defined outside of this file. .mn startup Define the appropriate location counters for this program file. In the case of Assembler H, these are internal names; for Assembler G and TSS Assembler, these are external names and are generated from the macro argument, which is usually the name of the file being compiled. These names must be unique within a single collection of programs (presumably this is implied by their tie to the file names). .mn subsave Accept a call from the supervisor program. .mn subretrn Return for a call received by subsave. .mm stackdo Define the automatic variable stack. .mn prolog Entry code for a C routine: defines base registers, stack pointers. Suitable only for calls from the BLISS calling sequence. Immediately before the code for the program are 16 bytes of information: the name of the function (EBCDIC, 12 bytes) and the length of the list in bytes (binary, one word). .mn epilog Exit code for a C routine: returns to caller. Only suitable to return from a BLISS style call. .mn runmain Get the command line arguments, call the main program. .mn stackdo Define the stack. The argument is the stack length in words, 1000 by default. There is no provision in the C run-time package for growing the stack. .mn lc Load a character into a register. .mn movif Convert integer to floating; register to register conversion, floating register given first. .mn movfi Convert floating to integer; register to register conversion, floating register given first. .NH Acknowledgments .PP The IBM C compiler was originally written by T. G. Peterson, based on the UNIX compiler by D. M. Ritchie. It has been revised by H. Gajewska and S. Johnson. The IH command procedures and support are by Joe Hall. ckage for growing the stack. .mn lc Load a character into a register. .mn movif Convert integer to floating; register to register conversion, floating register given first. .mn movfi Convert floating to integer; register to register conversion, floating register given fi$cctab / c code tables-- set condition codes / relationals :cc60: %n,z %nf,z %nd,z %nf,zf %nd,zd FX ltBFr Z,Z %n,aw %nf,ad %nd,ad FX cBF Z,A2 %n,ew* %nf,ef* %nf,ed* F S1* cBF Z,#2(R1) %n,e F S1 cr R,R1 %n,n %nf,nf %nf,ef %nd,ed %nd,nd SS FX cBF Z,T / set codes right :rest: %n,n %nf,nf H }; struct table cctab[] { /temporarily prohibit use of most of this table / 106, rest, / 28, rest, / 21, rest, / 22, rest, / 30, rest, / 31, rest, / 34, rest, / 35, rest, / 36, rest, / 37, rest, / 40, rest, / 41, rest, / 42, rest, / 43, rest, / 45, rest, / 46, rest, / 47, cc47, / 48, rest, 60, cc60, / == 61, cc60, / |= 62, cc60, / <= 63, cc60, / < 64, cc60, / >= 65, cc60, / > 66, cc60, /

p 69, cc60, / >=p / 70, rest, / 71, rest, / 72, rest, / 73, rest, / 75, rest, / 76, rest, / 77, rest, / 78, rest, / 79, rest, / 80, rest, 0, 0, }; ble / 106, rest, / 28, rest, / 21, rest, / 22, rest, / 30, rest, / 31, rest, / 34, rest, / 35, rest, / 36, rest, / 37, restint smode; int peekc; int peekchar; int pcmode; char name[10],*namep; main(argc, argv) int argc; char **argv; { auto c,d,snlflg,nlflg,t,m,ssmode,i,itemnbr; extern cin,cout; int j; j=cout; itemnbr=smode=nlflg=snlflg=ssmode=0; if (argc>1) if ((cin=copen(argv[1],'r'))<0) { putchar('?\n'); cexit(1); } if (argc > 2) if ((cout=copen(argv[2],'w'))<0) { printf(j,"?\n"); cexit(1); } printf("#\n"); printf("struct optab {\n"); printf(" int tabdeg1;\n"); printf(" int tabtyp1;\n"); printf(" int tabdeg2;\n"); printf(" int tabtyp2;\n"); printf(" char *tabstring;\n"); printf("};\n"); printf("struct table {\n"); printf(" int tabop;\n"); printf(" struct optab *tabp;\n"); printf("};\n\n"); namep = &name[0]; if (getchar() != '$') { printf("No table name\n"); cexit(1); } for (i=0; i<8 && (c=getchar()) != '\n'; i++) name[i]=c; printf("struct optab %sop[] {\n", namep); loop: c=getc(); if ((c != '\n') && (c != '\t')) nlflg=0; if (ssmode && c != '%') ssmode=0; switch (c) { case '\0': cexit(0); case ':': printf("\n# define "); while ((c=getc()) != ':') putchar(c); printf(" &%sop[%d]\n", namep,itemnbr); goto loop; case 'F': case 'S': case 'H': putchar(c); if (c == 'F') if ((c=getc()) == 'R') { putchar(c); goto loop; } else peekc=c; subtre: snlflg=1; t=0; l1: switch (c=getc()) { case '*': t =| 1; goto l1; case 'S': t =| 2; goto l1; case '1': t =| 4; goto l1; case '2': t =| 010; goto l1; case 'X': t =| 020; goto l1; } peekc=c; putchar(t/8+'0'); putchar((t&07)+'0'); goto loop; /* end of cases for F,S,H */ case 'B': putchar(c); if ((c=getc()) == 'F') putchar(c); else peekc=c; goto loop; case '\t': if (nlflg) nlflg=0; else printf("\\t"); goto loop; case '\n': if (!smode) { putchar('\n'); goto loop; } if (nlflg) { /* have just seen \n\n */ nlflg=0; printf("\",\n"); smode=0; pcmode=0; goto loop; } if (!snlflg) printf("\\n"); snlflg=0; nlflg=1; goto loop; case '%': pcmode=1; loop2: itemnbr++; loop1: switch(c=getc()) { case ',': putchar(' '); goto loop1; case 'z': m=4; t=flag(); goto pf; case 'c': t=0; m=8; goto pf; case 'r': m=12; t=flag(); goto pf; case 'a': m=16; t=flag(); goto pf; case 'e': m=20; t=flag(); goto pf; case 'n': m=63; t=flag(); pf: if ((c=getc()) == '*') m =| 0100; else peekc=c; printf(" %d,%d,",m,t); goto loop1; case '\n': if ((c=getc()) == '%') { printf(" 0,\n"); goto loop2; } else { peekc=c; printf(" \""); ssmode=1; nlflg=1; smode=1; snlflg=0; goto loop; } } putchar(c); goto loop1; /* end case '%' */ case '[': if ((c=getc()) == ']') { printf("[]"); while(putchar(getc())); peekc='\0'; } else { peekc=c; putchar('['); } goto loop; } /* end of big switch */ putchar(c); goto loop; } /* end of main function */ getc() { auto t; if (peekc) { t=peekc; peekc=0; } else { if (peekchar) { t=peekchar; peekchar=0; } else t=getchar(); } if (!pcmode) { if (t == '/') /* process a comment */ while ((t=getchar()) != '\n'); if (t == '\n') while ((peekchar=getchar()) == '/') while (getchar() != '\n'); } return(t); } flag() { register c,f; f=0; l1: switch (c=getc()) { case 'w': f=1; goto l1; case 'i': f=2; goto l1; case 'b': f=3; goto l1; case 'f': f=4; goto l1; case 'd': f=5; goto l1; case 's': f=6; goto l1; case 'p': f =+ 16; goto l1; } peekc=c; return(f); } ) { t=peekchar; peekchar=0; } else t=getchar(); } if (!pcmode) { if (t == '/') /*Contents of this directory are: 1. The compiler proper. Files c??.c. The appropriate command to compile this is cc c??.c -lp mv a.out ibmc and to run is ibmc source assembler 2. The preprocessor. This is not needed on UNIX, since the UNIX preprocessor can be used. Files pr?.c To compiler on UNIX (if desired) cc pr?.c -lp mv a.out preproc and to run preproc source newsource 3. The code tables and conversion program. The program "newcv.c" converts files regtab.t cctab.t into c14.c c15.c which are part of the compiler 4. The macro files. "macros.ASM" should be used to assembler with assembler H, and "macgho.ASM" with assembler G. 5. The library. All other files ending in ".c" or ".ASM". 6. The internals manual, file "memo". Runoff with tbl memo | nroff -ms *** character set translation *** Before you compile this to make a cross-compiler, examine the file c04.c which contains two tables called etoa[] and atoe[]. These tables (ebcdic to ascii and ascii to ebcdic) define the character set used by the IBM compiler. They MUST be one-to-one and inverses. You should arrange that they reflect the character set in use at your IBM computer center, especially insofar as the characters {} [] \ ^ ~ are concerned; otherwise you will be unable to print programs and read the listings. If you change the two tables and recompile the ENTIRE compiler you will get a cross compiler that believes in the new character set. Never, after changing the character tables, recompile only part of the compiler. It is particularly important that c14, c15, and c10 all have a consistent idea of the character set. lect the character set in use at your IBM computer center, especially insofar as the characters {} [] \ ^ ~ are concerned; otherwise you will be unable to print programs and read the listings. If you change the two tables and recompile the ENTIRE compiler you will get a cross compiler that believes in the new character set. Never, after changing the character ta@@@@k@@K@@@@@@@@@@@@@@@@77 1530 28 prime* 1559 6 42 1566 10 degree* 1577 11 52 1589 8 57 1598 4 50 1603 16 51 1620 16 133 1637 10 135 1648 10 173 1659 23 175 1683 23 aip126* 1707 5 aip127* 1713 5 174 1719 4 aip169* 1724 6 55 1731 4 53 1736 6 aip9* 1743 8 aip11* 1752 8 aip7* 1761 6 aip172* 1768 7 aip14* 1776 14 75 1791 6 aip12* 1798 8 aip5* 1807 8 74 1816 5 76 1822 5 aip56* 1828 9 aip55* 1838 9 aip21* 1848 22 aip23* 1871 16 circumflex* 1888 8 aigu* 1897 7 grave* 1905 7 breve* 1913 14 47 1928 9 140 1938 9 opquote* 1948 9 clquote* 1958 9 aip68* 1968 12 aip66* 1981 12 aip67* 1994 12 aip65* 2007 12 aip410* 2020 14 176 2035 12 aip98* 2048 12 136 2061 12 aip99* 2074 12 diff* 2087 36 aip413* 2124 12 aip106* 2137 9 aip101* 2147 26 aip102* 2174 39 aip20* 2214 27 45 2242 25 46 2268 40 100 2309 29 44 2339 32 43 2372 10 section*  2383 38 dagger* 2422 26 2dagger* 2449 40 aip429* 2490 10 ff* 2501 34 fi* 2536 24 fl* 2561 22 40 2584 1 cir22 1 34 cir04 36 14 cir11 51 22 cir07 74 18 cir17 93 34 cir41 128 50 cir05 179 18 cir02 198 10 cir04blk 209 28       star16 1 12 pine 14 77 oak 92 37 willow 130 29 palm 160 49 verupblk 210 13 verdnblk 224 13 verltblk 238 13 verrtblk 252 13 sqr04blk 266 20 bell 287 31 sqr12 319 6 cross10 326 5 ast10 332 7 grass 340 11 mark14 352 5 tri14 358 5 dia12 364 6 wreck 371 9 derrick 381 13 star06blk 395 17 flag07         blk 413 9     301 1 8 302 10 15 307 26 6 304 33 8 305 42 10 332 53 8 310 62 8 321 71 19 311 91 4 313 96 8 314 105 6 315 112 10 316 123 8 312 132 10 317 143 15 320 159 8 322 168 10 323 179 9 324 189 6 325 196 15 306 212 13 330      226 6 326 233 12 327 246 14 240 261 1 DIRECTORY DK0: [ 30,3 ] 10-OCT-73 PORN .DMP 17 01-JAN-72 <233> C2GD .CDF 32C 01-JAN-72 <233> C2UR .CDF 32C 23-SEP-73 <233> DCHRE .FTN 7 01-JAN-72 <000> DEMO1 .DMP 17 02-SEP-73 <233> DCHRE .LDA 33 01-JAN-72 <233> NYT .DMP 17 01-JAN-72 <233> C2IR .CDF 32C 23-SEP-73 <233> D2UR .NDX 4 01-SEP-73 <233> D2SR .NDX 4 01-SEP-73 <233> C2GE .CDF 32C 03-SEP-73 <233> DCHR .LDA 30 01-SEP-73 <233> C2GE  ! .NDX 3 03-SEP-73 <233> D2SR .CDF 32C 01-SEP-73 <233> P2UC .CDF 32C 01-SEP-73 <233> K0UR .NDX 3 02-SEP-73 <233> S2UR .NDX 5 02-SEP-73 <233> S2UG .NDX 3 02-SEP-73 <233> S2SR .CDF 32C 02-SEP-73 <233> S2SR .NDX 3 02-SEP-73 <233> C2IR .NDX 4 01-SEP-73 <233> C2UR .NDX 4 01-SEP-73 <233> P2UC .NDX 4 01-SEP-73 <233> P2US .NDX 4 01-SEP-73 <233> P1US .NDX 2 01-SEP-73 <233> S2UP .NDX 2 01-"$?SEP-73 <233> C2GI .NDX 3 02-SEP-73 <233> C2GN .CDF 32C 02-SEP-73 <233> C2GN .NDX 2 02-SEP-73 <233> S2UN .NDX 4 02-SEP-73 <233> P2NUM .NDX 2 02-SEP-73 <233> C2GD .NDX 3 03-SEP-73 <233> P1UG .NDX 3 04-SEP-73 <233> P2UR .CDF 32C 04-SEP-73 <233> P2UR .NDX 7 04-SEP-73 <233> P2IR .CDF 32C 04-SEP-73 <233> P2IR .NDX 3 04-SEP-73 <233> P2UG .CDF 32C 04-SEP-73 <233> P2UG .NDX 3 04-SEP-73 <233> &(*,.02468:<> P1IR .NDX 3 04-SEP-73 <233> P1UR .NDX 7 04-SEP-73 <233> CIRCLE.CDF 32C 04-SEP-73 <233> CIRCLE.NDX 1 04-SEP-73 <233> SHAPES.CDF 32C 04-SEP-73 <233> SHAPES.NDX 2 04-SEP-73 <233> K0UG .NDX 2 04-SEP-73 <233> TOTL BLKS: 627 TOTL FILES: 46