Doxygen Source Code Documentation
putpcc.c File Reference
#include "defs.h"#include "pccdefs.h"#include "output.h"#include "names.h"#include "p1defs.h"Go to the source code of this file.
Defines | |
| #define | P2BUFFMAX 128 |
| #define | PAIR(x, y) mkexpr (OPCOMMA, (x), (y)) |
Functions | |
| Addrp intdouble | Argdcl ((Addrp)) |
| Addrp putcx1 | Argdcl ((tagptr)) |
| tagptr putcall | Argdcl ((tagptr, Addrp *)) |
| tagptr putcat | Argdcl ((tagptr, tagptr)) |
| void putct1 | Argdcl ((tagptr, Addrp, Addrp, ptr)) |
| void | puthead (char *s, int classKRH) |
| void | putif (register expptr p, int else_if_p) |
| void | putout (expptr p) |
| void | putcmgo (expptr index, int nlab, struct Labelblock **labs) |
| expptr | krput (register expptr p) |
| expptr | putx (register expptr p) |
| LOCAL expptr | putop (expptr p) |
| LOCAL expptr | putpower (expptr p) |
| LOCAL Addrp | intdouble (Addrp p) |
| LOCAL Addrp | putcxeq (register expptr p) |
| expptr | putcxop (expptr p) |
| LOCAL Addrp | putcx1 (register expptr p) |
| LOCAL expptr | putcxcmp (register expptr p) |
| LOCAL Addrp | putch1 (register expptr p) |
| Addrp | putchop (expptr p) |
| LOCAL expptr | putcheq (register expptr p) |
| LOCAL expptr | putchcmp (register expptr p) |
| LOCAL expptr | putcat (expptr lhs0, register expptr rhs) |
| LOCAL void | putct1 (register expptr q, register Addrp length_var, register Addrp string_var, int *ip) |
| LOCAL expptr | putaddr (expptr p0) |
| LOCAL expptr | addrfix (expptr e) |
| LOCAL int | typekludge (int ccall, register expptr q, Atype *at, int j) |
| char * | Argtype (int k, char *buf) |
| void | atype_squawk (Argtypes *at, char *msg) |
| void | bad_atypes (Argtypes *at, char *fname, int i, int j, int k, char *here, char *prev) |
| int | type_fixup (Argtypes *at, Atype *a, int k) |
| void | save_argtypes (chainp arglist, Argtypes **at0, Argtypes **at1, int ccall, char *fname, int stg, int nchargs, int type, int zap) |
| char * | get_argtypes (Exprp p, Argtypes ***pat0, Argtypes ***pat1) |
| void | saveargtypes (register Exprp p) |
| LOCAL expptr | putcall (expptr p0, Addrp *temp) |
| LOCAL expptr | putmnmx (register expptr p) |
| void | putwhile (expptr p) |
Variables | |
| int | init_ac [TYSUBR+1] |
| int | ops2 [] |
| int | proc_argchanges |
| int | proc_protochanges |
| int | krparens |
| char | inconsist [] = "inconsistent calling sequences for " |
Define Documentation
|
|
|
|
|
|
Function Documentation
|
|
Definition at line 1209 of file putpcc.c. References ENULL, mkexpr(), OPIDENTITY, TADDR, and Expression::tag. Referenced by putcall().
01212 {
01213 return e->tag == TADDR ? mkexpr(OPIDENTITY, e, ENULL) : e;
01214 }
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
||||||||||||
|
Definition at line 1326 of file putpcc.c. Referenced by argverify(), bad_atypes(), Pbadret(), and save_argtypes().
01328 {
01329 if (k < 100) {
01330 sprintf(buf, "%s variable", ftn_types[k]);
01331 return buf;
01332 }
01333 if (k < 200) {
01334 k -= 100;
01335 return ftn_types[k];
01336 }
01337 if (k < 300) {
01338 k -= 200;
01339 if (k == TYSUBR)
01340 return ftn_types[TYSUBR];
01341 sprintf(buf, "%s function", ftn_types[k]);
01342 return buf;
01343 }
01344 if (k < 400)
01345 return "external argument";
01346 k -= 400;
01347 sprintf(buf, "%s argument", ftn_types[k]);
01348 return buf;
01349 }
|
|
||||||||||||
|
Definition at line 1357 of file putpcc.c. References a, Atype::cp, frchain(), proc_protochanges, and warn(). Referenced by bad_atypes(), and save_argtypes().
|
|
||||||||||||||||||||||||||||||||
|
Definition at line 1382 of file putpcc.c. References Argtype(), atype_squawk(), i, and inconsist. Referenced by save_argtypes().
01384 {
01385 char buf[208], buf1[32], buf2[32];
01386
01387 sprintf(buf, "%s%.90s,\n\targ %d: %s%s%s %s.",
01388 inconsist, fname, i, here, Argtype(k, buf1),
01389 prev, Argtype(j, buf2));
01390 atype_squawk(at, buf);
01391 }
|
|
||||||||||||||||
|
Definition at line 1603 of file putpcc.c. References Nameblock::arginfo, Extsym::arginfo, Fatal(), Extsym::fextname, Nameblock::fvarname, Addrblock::memno, p, STGARG, STGEXT, UNAM_EXTERN, UNAM_NAME, Addrblock::uname_tag, Addrblock::user, Nameblock::vardesc, and Addrblock::vstg. Referenced by putcall(), and saveargtypes().
01605 {
01606 Addrp a;
01607 Argtypes **at0, **at1;
01608 Namep np;
01609 expptr rp;
01610 Extsym *e;
01611 char *fname;
01612
01613 a = (Addrp)p->leftp;
01614 switch(a->vstg) {
01615 case STGEXT:
01616 switch(a->uname_tag) {
01617 case UNAM_EXTERN: /* e.g., sqrt() */
01618 e = extsymtab + a->memno;
01619 at0 = at1 = &e->arginfo;
01620 fname = e->fextname;
01621 break;
01622 case UNAM_NAME:
01623 np = a->user.name;
01624 at0 = &extsymtab[np->vardesc.varno].arginfo;
01625 at1 = &np->arginfo;
01626 fname = np->fvarname;
01627 break;
01628 default:
01629 goto bug;
01630 }
01631 break;
01632 case STGARG:
01633 if (a->uname_tag != UNAM_NAME)
01634 goto bug;
01635 np = a->user.name;
01636 at0 = at1 = &np->arginfo;
01637 fname = np->fvarname;
01638 break;
01639 default:
01640 bug:
01641 Fatal("Confusion in saveargtypes");
01642 }
01643 *pat0 = at0;
01644 *pat1 = at1;
01645 return fname;
01646 }
|
|
|
Definition at line 594 of file putpcc.c. References cpexpr(), ENULL, mktmp(), p, putassign(), and putout(). Referenced by putcx1().
|
|
|
Definition at line 165 of file putpcc.c. References cpexpr(), ENULL, Expression::exprblock, krparens, mktmp(), Exprblock::opcode, p, putassign(), putout(), putx(), Expression::tag, and TEXPR. Referenced by putx().
00167 {
00168 register expptr e, e1;
00169 register unsigned op;
00170 int t = krparens == 2 ? TYDREAL : p->exprblock.vtype;
00171
00172 op = p->exprblock.opcode;
00173 e = p->exprblock.leftp;
00174 if (e->tag == TEXPR && e->exprblock.opcode == op) {
00175 e1 = (expptr)mktmp(t, ENULL);
00176 putout(putassign(cpexpr(e1), e));
00177 p->exprblock.leftp = e1;
00178 }
00179 else
00180 p->exprblock.leftp = putx(e);
00181
00182 e = p->exprblock.rightp;
00183 if (e->tag == TEXPR && e->exprblock.opcode == op) {
00184 e1 = (expptr)mktmp(t, ENULL);
00185 putout(putassign(cpexpr(e1), e));
00186 p->exprblock.rightp = e1;
00187 }
00188 else
00189 p->exprblock.rightp = putx(e);
00190 return p;
00191 }
|
|
|
Definition at line 1179 of file putpcc.c. References Chain::datap, ENULL, fixtype(), frexpr(), Addrblock::isarray, ISERROR, Expression::listblock, Listblock::listp, Addrblock::memoffset, Chain::nextp, p, putx(), Addrblock::tag, TERROR, UNAM_REF, and Addrblock::uname_tag. Referenced by putcall(), putchop(), putcxop(), putop(), and putx().
01181 {
01182 register Addrp p;
01183 chainp cp;
01184
01185 if (!(p = (Addrp)p0))
01186 return ENULL;
01187
01188 if( p->tag==TERROR || (p->memoffset!=NULL && ISERROR(p->memoffset)) )
01189 {
01190 frexpr((expptr)p);
01191 return ENULL;
01192 }
01193 if (p->isarray && p->memoffset)
01194 if (p->uname_tag == UNAM_REF) {
01195 cp = p->memoffset->listblock.listp;
01196 for(; cp; cp = cp->nextp)
01197 cp->datap = (char *)fixtype((tagptr)cp->datap);
01198 }
01199 else
01200 p->memoffset = putx(p->memoffset);
01201 return (expptr) p;
01202 }
|
|
||||||||||||
|
Definition at line 1680 of file putpcc.c. References Expression::addrblock, addrfix(), Argtypes::atypes, CHNULL, CLPROC, CLUNKNOWN, cpexpr(), Chain::datap, ENULL, err, erri(), Expression::exprblock, fixtype(), frexpr(), get_argtypes(), Expression::headblock, hookup(), ICON, init_ac, ISCHAR, ISCOMPLEX, ISCONST, ISERROR, ISICON, Exprblock::leftp, Expression::listblock, Listblock::listp, mkchain(), mkconv(), mkexpr(), mklist(), mktmp(), Argtypes::nargs, Chain::nextp, OPCCALL, OPCHARCAST, Exprblock::opcode, OPCOMMA_ARG, OPCONV, p, Addrblock::parenused, PTHISPROC, putaddr(), putassign(), putchop(), putconst(), putcxop(), putout(), putx(), revchain(), Exprblock::rightp, saveargtypes(), STGARG, STGREG, TADDR, Expression::tag, TCONST, TEXPR, TLIST, TYLENG, Atype::type, UNAM_CONST, UNAM_NAME, Addrblock::uname_tag, Addrblock::user, Headblock::vclass, Exprblock::vleng, Headblock::vleng, Addrblock::vstg, Headblock::vstg, and Headblock::vtype. Referenced by putch1(), putcx1(), putop(), and putx().
01682 {
01683 register Exprp p = (Exprp)p0;
01684 chainp arglist; /* Pointer to actual arguments, if any */
01685 chainp charsp; /* List of copies of the variables which
01686 hold the lengths of character
01687 parameters (other than procedure
01688 parameters) */
01689 chainp cp; /* Iterator over argument lists */
01690 register expptr q; /* Pointer to the current argument */
01691 Addrp fval; /* Function return value */
01692 int type; /* type of the call - presumably this was
01693 set elsewhere */
01694 int byvalue; /* True iff we don't want to massage the
01695 parameter list, since we're calling a C
01696 library routine */
01697 char *s;
01698 Argtypes *at, **at0, **at1;
01699 Atype *At, *Ate;
01700
01701 type = p -> vtype;
01702 charsp = NULL;
01703 byvalue = (p->opcode == OPCCALL);
01704
01705 /* Verify the actual parameters */
01706
01707 if (p == (Exprp) NULL)
01708 err ("putcall: NULL call expression");
01709 else if (p -> tag != TEXPR)
01710 erri ("putcall: expected TEXPR, got '%d'", p -> tag);
01711
01712 /* Find the argument list */
01713
01714 if(p->rightp && p -> rightp -> tag == TLIST)
01715 arglist = p->rightp->listblock.listp;
01716 else
01717 arglist = NULL;
01718
01719 /* Count the number of explicit arguments, including lengths of character
01720 variables */
01721
01722 if (!byvalue) {
01723 get_argtypes(p, &at0, &at1);
01724 At = Ate = 0;
01725 if ((at = *at0) && at->nargs >= 0) {
01726 At = at->atypes;
01727 Ate = At + at->nargs;
01728 At += init_ac[type];
01729 }
01730 for(cp = arglist ; cp ; cp = cp->nextp) {
01731 q = (expptr) cp->datap;
01732 if( ISCONST(q) ) {
01733
01734 /* Even constants are passed by reference, so we need to put them in the
01735 literal table */
01736
01737 q = (expptr) putconst((Constp)q);
01738 cp->datap = (char *) q;
01739 }
01740
01741 /* Save the length expression of character variables (NOT character
01742 procedures) for the end of the argument list */
01743
01744 if( ISCHAR(q) &&
01745 (q->headblock.vclass != CLPROC
01746 || q->headblock.vstg == STGARG
01747 && q->tag == TADDR
01748 && q->addrblock.uname_tag == UNAM_NAME
01749 && q->addrblock.user.name->vprocclass == PTHISPROC)
01750 && (!At || At->type % 100 % TYSUBR == TYCHAR))
01751 {
01752 p0 = cpexpr(q->headblock.vleng);
01753 charsp = mkchain((char *)p0, charsp);
01754 if (q->headblock.vclass == CLUNKNOWN
01755 && q->headblock.vstg == STGARG)
01756 q->addrblock.user.name->vpassed = 1;
01757 else if (q->tag == TADDR
01758 && q->addrblock.uname_tag == UNAM_CONST)
01759 p0->constblock.Const.ci
01760 += q->addrblock.user.Const.ccp1.blanks;
01761 }
01762 if (At && ++At == Ate)
01763 At = 0;
01764 }
01765 }
01766 charsp = revchain(charsp);
01767
01768 /* If the routine is a CHARACTER function ... */
01769
01770 if(type == TYCHAR)
01771 {
01772 if( ISICON(p->vleng) )
01773 {
01774
01775 /* Allocate a temporary to hold the return value of the function */
01776
01777 fval = mktmp(TYCHAR, p->vleng);
01778 }
01779 else {
01780 err("adjustable character function");
01781 if (temp)
01782 *temp = 0;
01783 return 0;
01784 }
01785 }
01786
01787 /* If the routine is a COMPLEX function ... */
01788
01789 else if( ISCOMPLEX(type) )
01790 fval = mktmp(type, ENULL);
01791 else
01792 fval = NULL;
01793
01794 /* Write the function name, without taking its address */
01795
01796 p -> leftp = putx(fixtype(putaddr(p->leftp)));
01797
01798 if(fval)
01799 {
01800 chainp prepend;
01801
01802 /* Prepend a copy of the function return value buffer out as the first
01803 argument. */
01804
01805 prepend = mkchain((char *)putx(putaddr(cpexpr((expptr)fval))), arglist);
01806
01807 /* If it's a character function, also prepend the length of the result */
01808
01809 if(type==TYCHAR)
01810 {
01811
01812 prepend->nextp = mkchain((char *)putx(mkconv(TYLENG,
01813 p->vleng)), arglist);
01814 }
01815 if (!(q = p->rightp))
01816 p->rightp = q = (expptr)mklist(CHNULL);
01817 q->listblock.listp = prepend;
01818 }
01819
01820 /* Scan through the fortran argument list */
01821
01822 for(cp = arglist ; cp ; cp = cp->nextp)
01823 {
01824 q = (expptr) (cp->datap);
01825 if (q == ENULL)
01826 err ("putcall: NULL argument");
01827
01828 /* call putaddr only when we've got a parameter for a C routine or a
01829 memory resident parameter */
01830
01831 if (q -> tag == TCONST && !byvalue)
01832 q = (expptr) putconst ((Constp)q);
01833
01834 if(q->tag==TADDR && (byvalue || q->addrblock.vstg!=STGREG) ) {
01835 if (q->addrblock.parenused
01836 && !byvalue && q->headblock.vtype != TYCHAR)
01837 goto make_copy;
01838 cp->datap = (char *)putaddr(q);
01839 }
01840 else if( ISCOMPLEX(q->headblock.vtype) )
01841 cp -> datap = (char *) putx (fixtype(putcxop(q)));
01842 else if (ISCHAR(q) )
01843 cp -> datap = (char *) putx (fixtype((expptr)putchop(q)));
01844 else if( ! ISERROR(q) )
01845 {
01846 if(byvalue) {
01847 if (q->tag == TEXPR && q->exprblock.opcode == OPCONV) {
01848 if (ISCOMPLEX(q->exprblock.leftp->headblock.vtype)
01849 && q->exprblock.leftp->tag == TEXPR)
01850 q->exprblock.leftp = putcxop(q->exprblock.leftp);
01851 else
01852 q->exprblock.leftp = putx(q->exprblock.leftp);
01853 }
01854 else
01855 cp -> datap = (char *) putx(q);
01856 }
01857 else if (q->tag == TEXPR && q->exprblock.opcode == OPCHARCAST)
01858 cp -> datap = (char *) putx(q);
01859 else {
01860 expptr t, t1;
01861
01862 /* If we've got a register parameter, or (maybe?) a constant, save it in a
01863 temporary first */
01864 make_copy:
01865 t = (expptr) mktmp(q->headblock.vtype, q->headblock.vleng);
01866
01867 /* Assign to temporary variables before invoking the subroutine or
01868 function */
01869
01870 t1 = putassign( cpexpr(t), q );
01871 if (doin_setbound)
01872 t = mkexpr(OPCOMMA_ARG, t1, t);
01873 else
01874 putout(t1);
01875 cp -> datap = (char *) t;
01876 } /* else */
01877 } /* if !ISERROR(q) */
01878 }
01879
01880 /* Now adjust the lengths of the CHARACTER parameters */
01881
01882 for(cp = charsp ; cp ; cp = cp->nextp)
01883 cp->datap = (char *)addrfix(putx(
01884 /* in case MAIN has a character*(*)... */
01885 (s = cp->datap) ? mkconv(TYLENG,(expptr)s)
01886 : ICON(0)));
01887
01888 /* ... and add them to the end of the argument list */
01889
01890 hookup (arglist, charsp);
01891
01892 /* Return the name of the temporary used to hold the results, if any was
01893 necessary. */
01894
01895 if (temp) *temp = fval;
01896 else frexpr ((expptr)fval);
01897
01898 saveargtypes(p);
01899
01900 return (expptr) p;
01901 }
|
|
||||||||||||
|
Definition at line 1086 of file putpcc.c. References call4(), cpexpr(), ENULL, frtemp(), ICON, mktmpn(), ncat(), p, p1_comment(), putconst(), putct1(), and putx(). Referenced by putch1(), and putcheq().
01088 {
01089 register Addrp lhs = (Addrp)lhs0;
01090 int n, tyi;
01091 Addrp length_var, string_var;
01092 expptr p;
01093 static char Writing_concatenation[] = "Writing concatenation";
01094
01095 /* Create the temporary arrays */
01096
01097 n = ncat(rhs);
01098 length_var = mktmpn(n, tyioint, ENULL);
01099 string_var = mktmpn(n, TYADDR, ENULL);
01100 frtemp((Addrp)cpexpr((expptr)length_var));
01101 frtemp((Addrp)cpexpr((expptr)string_var));
01102
01103 /* Initialize the arrays */
01104
01105 n = 0;
01106 /* p1_comment scribbles on its argument, so we
01107 * cannot safely pass a string literal here. */
01108 p1_comment(Writing_concatenation);
01109 putct1(rhs, length_var, string_var, &n);
01110
01111 /* Create the invocation */
01112
01113 tyi = tyint;
01114 tyint = tyioint; /* for -I2 */
01115 p = putx (call4 (TYSUBR, "s_cat",
01116 (expptr)lhs,
01117 (expptr)string_var,
01118 (expptr)length_var,
01119 (expptr)putconst((Constp)ICON(n))));
01120 tyint = tyi;
01121
01122 return p;
01123 }
|
|
|
Definition at line 917 of file putpcc.c. References badop(), badtag(), cpexpr(), ENULL, Fatal(), frexpr(), Expression::headblock, ICON, INT, ISICON, lencat(), mkexpr(), mktmp(), OPASSIGN, OPCALL, OPCCALL, OPCONCAT, OPCONV, p, putcall(), putcat(), putconst(), putop(), putout(), q, TADDR, TCONST, TEXPR, and Headblock::vtype. Referenced by putchop(), putct1(), and putx().
00919 {
00920 Addrp t;
00921 expptr e;
00922
00923 switch(p->tag)
00924 {
00925 case TCONST:
00926 return( putconst((Constp)p) );
00927
00928 case TADDR:
00929 return( (Addrp) p );
00930
00931 case TEXPR:
00932 switch(p->exprblock.opcode)
00933 {
00934 expptr q;
00935
00936 case OPCALL:
00937 case OPCCALL:
00938
00939 p = putcall(p, &t);
00940 putout (p);
00941 break;
00942
00943 case OPCONCAT:
00944 t = mktmp(TYCHAR, ICON(lencat(p)));
00945 q = (expptr) cpexpr(p->headblock.vleng);
00946 p = putcat( cpexpr((expptr)t), p );
00947 /* put the correct length on the block */
00948 frexpr(t->vleng);
00949 t->vleng = q;
00950 putout (p);
00951 break;
00952
00953 case OPCONV:
00954 if(!ISICON(p->exprblock.vleng)
00955 || p->exprblock.vleng->constblock.Const.ci!=1
00956 || ! INT(p->exprblock.leftp->headblock.vtype) )
00957 Fatal("putch1: bad character conversion");
00958 t = mktmp(TYCHAR, ICON(1));
00959 e = mkexpr(OPCONV, (expptr)t, ENULL);
00960 e->headblock.vtype = TYCHAR;
00961 p = putop( mkexpr(OPASSIGN, cpexpr(e), p));
00962 putout (p);
00963 break;
00964 default:
00965 badop("putch1", p->exprblock.opcode);
00966 }
00967 return(t);
00968
00969 default:
00970 badtag("putch1", p->tag);
00971 }
00972 /* NOT REACHED */ return 0;
00973 }
|
|
|
Definition at line 1040 of file putpcc.c. References badtag(), call2(), ENULL, Expression::headblock, ICON, ISONE, mkexpr(), OPCONV, p, putop(), TEXPR, TYINT, Headblock::vleng, and Headblock::vtype. Referenced by putx().
01042 {
01043 expptr lp, rp;
01044
01045 if(p->tag != TEXPR)
01046 badtag("putchcmp", p->tag);
01047
01048 lp = p->exprblock.leftp;
01049 rp = p->exprblock.rightp;
01050
01051 if(ISONE(lp->headblock.vleng) && ISONE(rp->headblock.vleng) ) {
01052 lp = mkexpr(OPCONV, lp, ENULL);
01053 rp = mkexpr(OPCONV, rp, ENULL);
01054 lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
01055 }
01056 else {
01057 lp = call2(TYINT,"s_cmp", lp, rp);
01058 rp = ICON(0);
01059 }
01060 p->exprblock.leftp = lp;
01061 p->exprblock.rightp = rp;
01062 p = putop(p);
01063 return p;
01064 }
|
|
|
Definition at line 999 of file putpcc.c. References badchleng(), badtag(), call2(), charptr, ENULL, Expression::exprblock, free, frexpr(), Expression::headblock, ISONE, mkexpr(), OPASSIGN, Exprblock::opcode, OPCONCAT, OPCONV, p, putcat(), putop(), putx(), Expression::tag, TEXPR, Headblock::vleng, and Headblock::vtype. Referenced by putx().
01001 {
01002 expptr lp, rp;
01003 int nbad;
01004
01005 if(p->tag != TEXPR)
01006 badtag("putcheq", p->tag);
01007
01008 lp = p->exprblock.leftp;
01009 rp = p->exprblock.rightp;
01010 frexpr(p->exprblock.vleng);
01011 free( (charptr) p );
01012
01013 /* If s = t // u, don't bother copying the result, write it directly into
01014 this buffer */
01015
01016 nbad = badchleng(lp) + badchleng(rp);
01017 if( rp->tag==TEXPR && rp->exprblock.opcode==OPCONCAT )
01018 p = putcat(lp, rp);
01019 else if( !nbad
01020 && ISONE(lp->headblock.vleng)
01021 && ISONE(rp->headblock.vleng) ) {
01022 lp = mkexpr(OPCONV, lp, ENULL);
01023 rp = mkexpr(OPCONV, rp, ENULL);
01024 lp->headblock.vtype = rp->headblock.vtype = TYCHAR;
01025 p = putop(mkexpr(OPASSIGN, lp, rp));
01026 }
01027 else
01028 p = putx( call2(TYSUBR, "s_copy", lp, rp) );
01029 return p;
01030 }
|
|
|
Definition at line 984 of file putpcc.c. References p, putaddr(), and putch1(). Referenced by iosetc(), and putcall().
|
|
||||||||||||||||
|
Definition at line 148 of file putpcc.c. References CNULL, execerr(), ISINT, and p1comp_goto(). Referenced by excall(), and yyparse().
|
|
||||||||||||||||||||
|
Definition at line 1137 of file putpcc.c. References addrof(), charptr, cpexpr(), free, frexpr(), i, ICON, Addrblock::memoffset, mkexpr(), OPCONCAT, OPPLUS, PAIR, putassign(), putch1(), putout(), q, szleng, and TEXPR. Referenced by putcat().
01139 {
01140 int i;
01141 Addrp length_copy, string_copy;
01142 expptr e;
01143 extern int szleng;
01144
01145 if(q->tag==TEXPR && q->exprblock.opcode==OPCONCAT)
01146 {
01147 putct1(q->exprblock.leftp, length_var, string_var,
01148 ip);
01149 putct1(q->exprblock.rightp, length_var, string_var,
01150 ip);
01151 frexpr (q -> exprblock.vleng);
01152 free ((charptr) q);
01153 }
01154 else
01155 {
01156 i = (*ip)++;
01157 e = cpexpr(q->headblock.vleng);
01158 if (!e)
01159 return; /* error -- character*(*) */
01160 length_copy = (Addrp) cpexpr((expptr)length_var);
01161 length_copy->memoffset =
01162 mkexpr(OPPLUS,length_copy->memoffset, ICON(i*szleng));
01163 string_copy = (Addrp) cpexpr((expptr)string_var);
01164 string_copy->memoffset =
01165 mkexpr(OPPLUS, string_copy->memoffset,
01166 ICON(i*typesize[TYADDR]));
01167 putout (PAIR (putassign((expptr)length_copy, e),
01168 putassign((expptr)string_copy, addrof((expptr)putch1(q)))));
01169 }
01170 }
|
|
|
Definition at line 662 of file putpcc.c. References Expression::addrblock, addressable(), badop(), badtag(), charptr, Addrblock::cmplx_sub, cpexpr(), ENULL, Addrblock::Field, free, frexpr(), ICON, imagpart(), intdouble(), Addrblock::isarray, ISCOMPLEX, ISINT, M, Addrblock::memoffset, mkexpr(), mkintcon(), mkrealcon(), mktmp(), ONEOF, OPASSIGN, OPCALL, OPCCALL, OPCOMMA, OPCONV, OPMINUS, OPNEG, OPNEG1, OPPLUS, OPSLASH, OPSTAR, p, PAIR, putassign(), putcall(), putconst(), putcxeq(), putout(), q, r, realpart(), Addrblock::skip_offset, STGCOMMON, STGEQUIV, TADDR, Addrblock::tag, TCONST, TERROR, TEXPR, UNAM_NAME, UNAM_REF, Addrblock::uname_tag, Addrblock::user, Addrblock::vstg, and Addrblock::vtype. Referenced by putcxcmp(), putcxeq(), putcxop(), putop(), and putx().
00664 {
00665 expptr q;
00666 Addrp lp, rp;
00667 register Addrp resp;
00668 int opcode;
00669 int ltype, rtype;
00670 long ts, tskludge;
00671
00672 if(p == NULL)
00673 return(NULL);
00674
00675 switch(p->tag)
00676 {
00677 case TCONST:
00678 if( ISCOMPLEX(p->constblock.vtype) )
00679 p = (expptr) putconst((Constp)p);
00680 return( (Addrp) p );
00681
00682 case TADDR:
00683 resp = &p->addrblock;
00684 if (addressable(p))
00685 return (Addrp) p;
00686 ts = tskludge = 0;
00687 if (q = resp->memoffset) {
00688 if (resp->uname_tag == UNAM_REF) {
00689 q = cpexpr((tagptr)resp);
00690 q->addrblock.vtype = tyint;
00691 q->addrblock.cmplx_sub = 1;
00692 p->addrblock.skip_offset = 1;
00693 resp->user.name->vsubscrused = 1;
00694 resp->uname_tag = UNAM_NAME;
00695 tskludge = typesize[resp->vtype]
00696 * (resp->Field ? 2 : 1);
00697 }
00698 else if (resp->isarray
00699 && resp->vtype != TYCHAR) {
00700 if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
00701 && resp->uname_tag == UNAM_NAME)
00702 q = mkexpr(OPMINUS, q,
00703 mkintcon(resp->user.name->voffset));
00704 ts = typesize[resp->vtype]
00705 * (resp->Field ? 2 : 1);
00706 q = resp->memoffset = mkexpr(OPSLASH, q,
00707 ICON(ts));
00708 }
00709 }
00710 resp = mktmp(tyint, ENULL);
00711 putout(putassign(cpexpr((expptr)resp), q));
00712 p->addrblock.memoffset = tskludge
00713 ? mkexpr(OPSTAR, (expptr)resp, ICON(tskludge))
00714 : (expptr)resp;
00715 if (ts) {
00716 resp = &p->addrblock;
00717 q = mkexpr(OPSTAR, resp->memoffset, ICON(ts));
00718 if (ONEOF(resp->vstg, M(STGCOMMON)|M(STGEQUIV))
00719 && resp->uname_tag == UNAM_NAME)
00720 q = mkexpr(OPPLUS, q,
00721 mkintcon(resp->user.name->voffset));
00722 resp->memoffset = q;
00723 }
00724 return (Addrp) p;
00725
00726 case TEXPR:
00727 if( ISCOMPLEX(p->exprblock.vtype) )
00728 break;
00729 resp = mktmp(p->exprblock.vtype, ENULL);
00730 /*first arg of above mktmp call was TYDREAL before 19950102 */
00731 putout (putassign( cpexpr((expptr)resp), p));
00732 return(resp);
00733
00734 case TERROR:
00735 return NULL;
00736
00737 default:
00738 badtag("putcx1", p->tag);
00739 }
00740
00741 opcode = p->exprblock.opcode;
00742 if(opcode==OPCALL || opcode==OPCCALL)
00743 {
00744 Addrp t;
00745 p = putcall(p, &t);
00746 putout(p);
00747 return t;
00748 }
00749 else if(opcode == OPASSIGN)
00750 {
00751 return putcxeq (p);
00752 }
00753
00754 /* BUG (inefficient) Generates too many temporary variables */
00755
00756 resp = mktmp(p->exprblock.vtype, ENULL);
00757 if(lp = putcx1(p->exprblock.leftp) )
00758 ltype = lp->vtype;
00759 if(rp = putcx1(p->exprblock.rightp) )
00760 rtype = rp->vtype;
00761
00762 switch(opcode)
00763 {
00764 case OPCOMMA:
00765 frexpr((expptr)resp);
00766 resp = rp;
00767 rp = NULL;
00768 break;
00769
00770 case OPNEG:
00771 case OPNEG1:
00772 putout (PAIR (
00773 putassign( (expptr)realpart(resp),
00774 mkexpr(OPNEG, (expptr)realpart(lp), ENULL)),
00775 putassign( imagpart(resp),
00776 mkexpr(OPNEG, imagpart(lp), ENULL))));
00777 break;
00778
00779 case OPPLUS:
00780 case OPMINUS: { expptr r;
00781 r = putassign( (expptr)realpart(resp),
00782 mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp) ));
00783 if(rtype < TYCOMPLEX)
00784 q = putassign( imagpart(resp), imagpart(lp) );
00785 else if(ltype < TYCOMPLEX)
00786 {
00787 if(opcode == OPPLUS)
00788 q = putassign( imagpart(resp), imagpart(rp) );
00789 else
00790 q = putassign( imagpart(resp),
00791 mkexpr(OPNEG, imagpart(rp), ENULL) );
00792 }
00793 else
00794 q = putassign( imagpart(resp),
00795 mkexpr(opcode, imagpart(lp), imagpart(rp) ));
00796 r = PAIR (r, q);
00797 putout (r);
00798 break;
00799 } /* case OPPLUS, OPMINUS: */
00800 case OPSTAR:
00801 if(ltype < TYCOMPLEX)
00802 {
00803 if( ISINT(ltype) )
00804 lp = intdouble(lp);
00805 putout (PAIR (
00806 putassign( (expptr)realpart(resp),
00807 mkexpr(OPSTAR, cpexpr((expptr)lp),
00808 (expptr)realpart(rp))),
00809 putassign( imagpart(resp),
00810 mkexpr(OPSTAR, cpexpr((expptr)lp), imagpart(rp)))));
00811 }
00812 else if(rtype < TYCOMPLEX)
00813 {
00814 if( ISINT(rtype) )
00815 rp = intdouble(rp);
00816 putout (PAIR (
00817 putassign( (expptr)realpart(resp),
00818 mkexpr(OPSTAR, cpexpr((expptr)rp),
00819 (expptr)realpart(lp))),
00820 putassign( imagpart(resp),
00821 mkexpr(OPSTAR, cpexpr((expptr)rp), imagpart(lp)))));
00822 }
00823 else {
00824 putout (PAIR (
00825 putassign( (expptr)realpart(resp), mkexpr(OPMINUS,
00826 mkexpr(OPSTAR, (expptr)realpart(lp),
00827 (expptr)realpart(rp)),
00828 mkexpr(OPSTAR, imagpart(lp), imagpart(rp)))),
00829 putassign( imagpart(resp), mkexpr(OPPLUS,
00830 mkexpr(OPSTAR, (expptr)realpart(lp), imagpart(rp)),
00831 mkexpr(OPSTAR, imagpart(lp),
00832 (expptr)realpart(rp))))));
00833 }
00834 break;
00835
00836 case OPSLASH:
00837 /* fixexpr has already replaced all divisions
00838 * by a complex by a function call
00839 */
00840 if( ISINT(rtype) )
00841 rp = intdouble(rp);
00842 putout (PAIR (
00843 putassign( (expptr)realpart(resp),
00844 mkexpr(OPSLASH, (expptr)realpart(lp), cpexpr((expptr)rp))),
00845 putassign( imagpart(resp),
00846 mkexpr(OPSLASH, imagpart(lp), cpexpr((expptr)rp)))));
00847 break;
00848
00849 case OPCONV:
00850 if (!lp)
00851 break;
00852 if(ISCOMPLEX(lp->vtype) )
00853 q = imagpart(lp);
00854 else if(rp != NULL)
00855 q = (expptr) realpart(rp);
00856 else
00857 q = mkrealcon(TYDREAL, "0");
00858 putout (PAIR (
00859 putassign( (expptr)realpart(resp), (expptr)realpart(lp)),
00860 putassign( imagpart(resp), q)));
00861 break;
00862
00863 default:
00864 badop("putcx1", opcode);
00865 }
00866
00867 frexpr((expptr)lp);
00868 frexpr((expptr)rp);
00869 free( (charptr) p );
00870 return(resp);
00871 }
|
|
|
Definition at line 884 of file putpcc.c. References badtag(), charptr, fixexpr(), free, imagpart(), ISCONST, mkexpr(), OPAND, OPEQ, OPOR, p, putcx1(), putx(), q, realpart(), and TEXPR. Referenced by putx().
00886 {
00887 int opcode;
00888 register Addrp lp, rp;
00889 expptr q;
00890
00891 if(p->tag != TEXPR)
00892 badtag("putcxcmp", p->tag);
00893
00894 opcode = p->exprblock.opcode;
00895 lp = putcx1(p->exprblock.leftp);
00896 rp = putcx1(p->exprblock.rightp);
00897
00898 q = mkexpr( opcode==OPEQ ? OPAND : OPOR ,
00899 mkexpr(opcode, (expptr)realpart(lp), (expptr)realpart(rp)),
00900 mkexpr(opcode, imagpart(lp), imagpart(rp)) );
00901
00902 free( (charptr) lp);
00903 free( (charptr) rp);
00904 free( (charptr) p );
00905 if (ISCONST(q))
00906 return q;
00907 return putx( fixexpr((Exprp)q) );
00908 }
|
|
|
Definition at line 615 of file putpcc.c. References badtag(), charptr, free, frexpr(), imagpart(), ISCOMPLEX, mkexpr(), OPCOMMA, p, putassign(), putcx1(), putout(), realpart(), and TEXPR. Referenced by putcx1(), and putx().
00617 {
00618 register Addrp lp, rp;
00619 expptr code;
00620
00621 if(p->tag != TEXPR)
00622 badtag("putcxeq", p->tag);
00623
00624 lp = putcx1(p->exprblock.leftp);
00625 rp = putcx1(p->exprblock.rightp);
00626 code = putassign ( (expptr)realpart(lp), (expptr)realpart(rp));
00627
00628 if( ISCOMPLEX(p->exprblock.vtype) )
00629 {
00630 code = mkexpr (OPCOMMA, code, putassign
00631 (imagpart(lp), imagpart(rp)));
00632 }
00633 putout (code);
00634 frexpr((expptr)rp);
00635 free ((charptr) p);
00636 return lp;
00637 }
|
|
|
Definition at line 649 of file putpcc.c. References p, putaddr(), and putcx1(). Referenced by putcall(), and putx().
|
|
||||||||||||
|
Definition at line 64 of file putpcc.c. References CLMAIN, NO, p1_head(), and YES. Referenced by entrypt(), startproc(), and yyparse().
|
|
||||||||||||
|
Definition at line 81 of file putpcc.c. References err, fixtype(), ISLOGICAL, mem(), new_endif(), p, p1_elif(), P1_ELSEIFSTART, p1_if(), p1put(), putx(), and TYERROR. Referenced by exelif(), and exif().
00083 {
00084 register int k;
00085 int n;
00086 long where;
00087
00088 if (else_if_p) {
00089 p1put(P1_ELSEIFSTART);
00090 where = ftell(pass1_file);
00091 }
00092 if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype )) )
00093 {
00094 if(k != TYERROR)
00095 err("non-logical expression in IF statement");
00096 }
00097 else {
00098 if (else_if_p) {
00099 if (ei_next >= ei_last)
00100 {
00101 k = ei_last - ei_first;
00102 n = k + 100;
00103 ei_next = mem(n,0);
00104 ei_last = ei_first + n;
00105 if (k)
00106 memcpy(ei_next, ei_first, k);
00107 ei_first = ei_next;
00108 ei_next += k;
00109 ei_last = ei_first + n;
00110 }
00111 p = putx(p);
00112 if (*ei_next++ = ftell(pass1_file) > where) {
00113 p1_if(p);
00114 new_endif();
00115 }
00116 else
00117 p1_elif(p);
00118 }
00119 else {
00120 p = putx(p);
00121 p1_if(p);
00122 }
00123 }
00124 }
|
|
|
Definition at line 1913 of file putpcc.c. References addressable(), arg, badtag(), charptr, cpexpr(), Chain::datap, ENULL, Expression::exprblock, fixexpr(), frchain(), free, frexpr(), ISCONST, mkconv(), mkexpr(), mktmp(), Chain::nextp, Exprblock::opcode, OPCOMMA, OPDMAX, OPDMIN, OPLT, OPMAX2, OPMIN, OPMIN2, p, p1_comment(), putassign(), putout(), putx(), and TEXPR. Referenced by putx().
01915 {
01916 int op, op2, type;
01917 expptr arg, qp, temp;
01918 chainp p0, p1;
01919 Addrp sp, tp;
01920 char comment_buf[80];
01921 char *what;
01922
01923 if(p->tag != TEXPR)
01924 badtag("putmnmx", p->tag);
01925
01926 type = p->exprblock.vtype;
01927 op = p->exprblock.opcode;
01928 op2 = op == OPMIN ? OPMIN2 : OPMAX2;
01929 p0 = p->exprblock.leftp->listblock.listp;
01930 free( (charptr) (p->exprblock.leftp) );
01931 free( (charptr) p );
01932
01933 /* special case for two addressable operands */
01934
01935 if (addressable((expptr)p0->datap)
01936 && (p1 = p0->nextp)
01937 && addressable((expptr)p1->datap)
01938 && !p1->nextp) {
01939 if (type == TYREAL && forcedouble)
01940 op2 = op == OPMIN ? OPDMIN : OPDMAX;
01941 p = mkexpr(op2, mkconv(type, cpexpr((expptr)p0->datap)),
01942 mkconv(type, cpexpr((expptr)p1->datap)));
01943 frchain(&p0);
01944 return p;
01945 }
01946
01947 /* general case */
01948
01949 sp = mktmp(type, ENULL);
01950
01951 /* We only need a second temporary if the arg list has an unaddressable
01952 value */
01953
01954 tp = (Addrp) NULL;
01955 qp = ENULL;
01956 for (p1 = p0 -> nextp; p1; p1 = p1 -> nextp)
01957 if (!addressable ((expptr) p1 -> datap)) {
01958 tp = mktmp(type, ENULL);
01959 qp = mkexpr(op2, cpexpr((expptr)sp), cpexpr((expptr)tp));
01960 qp = fixexpr((Exprp)qp);
01961 break;
01962 } /* if */
01963
01964 /* Now output the appropriate number of assignments and comparisons. Min
01965 and max are implemented by the simple O(n) algorithm:
01966
01967 min (a, b, c, d) ==>
01968 { <type> t1, t2;
01969
01970 t1 = a;
01971 t2 = b; t1 = (t1 < t2) ? t1 : t2;
01972 t2 = c; t1 = (t1 < t2) ? t1 : t2;
01973 t2 = d; t1 = (t1 < t2) ? t1 : t2;
01974 }
01975 */
01976
01977 if (!doin_setbound) {
01978 switch(op) {
01979 case OPLT:
01980 case OPMIN:
01981 case OPDMIN:
01982 case OPMIN2:
01983 what = "IN";
01984 break;
01985 default:
01986 what = "AX";
01987 }
01988 sprintf (comment_buf, "Computing M%s", what);
01989 p1_comment (comment_buf);
01990 }
01991
01992 p1 = p0->nextp;
01993 temp = (expptr)p0->datap;
01994 if (addressable(temp) && addressable((expptr)p1->datap)) {
01995 p = mkconv(type, cpexpr(temp));
01996 arg = mkconv(type, cpexpr((expptr)p1->datap));
01997 temp = mkexpr(op2, p, arg);
01998 if (!ISCONST(temp))
01999 temp = fixexpr((Exprp)temp);
02000 p1 = p1->nextp;
02001 }
02002 p = putassign (cpexpr((expptr)sp), temp);
02003
02004 for(; p1 ; p1 = p1->nextp)
02005 {
02006 if (addressable ((expptr) p1 -> datap)) {
02007 arg = mkconv(type, cpexpr((expptr)p1->datap));
02008 temp = mkexpr(op2, cpexpr((expptr)sp), arg);
02009 temp = fixexpr((Exprp)temp);
02010 } else {
02011 temp = (expptr) cpexpr (qp);
02012 p = mkexpr(OPCOMMA, p,
02013 putassign(cpexpr((expptr)tp), (expptr)p1->datap));
02014 } /* else */
02015
02016 if(p1->nextp)
02017 p = mkexpr(OPCOMMA, p,
02018 putassign(cpexpr((expptr)sp), temp));
02019 else {
02020 if (type == TYREAL && forcedouble)
02021 temp->exprblock.opcode =
02022 op == OPMIN ? OPDMIN : OPDMAX;
02023 if (doin_setbound)
02024 p = mkexpr(OPCOMMA, p, temp);
02025 else {
02026 putout (p);
02027 p = putx(temp);
02028 }
02029 if (qp)
02030 frexpr (qp);
02031 } /* else */
02032 } /* for */
02033
02034 frchain( &p0 );
02035 return p;
02036 }
|
|
|
Definition at line 395 of file putpcc.c. References badop(), charptr, cpexpr(), Expression::exprblock, fold(), free, frexpr(), Expression::headblock, INT, ISCOMPLEX, ISCONST, ISNUMERIC, ISREAL, Exprblock::leftp, M, mkconv(), mkexpr(), mktmp(), MSKADDR, MSKCHAR, MSKCOMPLEX, MSKINT, MSKREAL, NO, ONEOF, OPADDR, OPASSIGN, OPASSIGNI, OPCALL, Exprblock::opcode, OPCOMMA, OPCONV, OPEQ, OPGE, OPGT, OPLE, OPLT, OPNE, ops2, p, putaddr(), putcall(), putconst(), putcx1(), putout(), putx(), realpart(), TADDR, Expression::tag, TEXPR, Headblock::vleng, Headblock::vtype, and YES. Referenced by putch1(), putchcmp(), putcheq(), and putx().
00397 {
00398 expptr lp, tp;
00399 int pt, lt, lt1;
00400 int comma;
00401 char *hsave;
00402
00403 switch(p->exprblock.opcode) /* check for special cases and rewrite */
00404 {
00405 case OPCONV:
00406 pt = p->exprblock.vtype;
00407 lp = p->exprblock.leftp;
00408 lt = lp->headblock.vtype;
00409
00410 /* Simplify nested type casts */
00411
00412 while(p->tag==TEXPR && p->exprblock.opcode==OPCONV &&
00413 ( (ISREAL(pt)&&ONEOF(lt,MSKREAL|MSKCOMPLEX)) ||
00414 (INT(pt)&&(ONEOF(lt,MSKINT|MSKADDR|MSKCHAR|M(TYSUBR)))) ))
00415 {
00416 if(pt==TYDREAL && lt==TYREAL)
00417 {
00418 if(lp->tag==TEXPR
00419 && lp->exprblock.opcode == OPCONV) {
00420 lt1 = lp->exprblock.leftp->headblock.vtype;
00421 if (lt1 == TYDREAL) {
00422 lp->exprblock.leftp =
00423 putx(lp->exprblock.leftp);
00424 return p;
00425 }
00426 if (lt1 == TYDCOMPLEX) {
00427 lp->exprblock.leftp = putx(
00428 (expptr)realpart(
00429 putcx1(lp->exprblock.leftp)));
00430 return p;
00431 }
00432 }
00433 break;
00434 }
00435 else if (ISREAL(pt) && ISCOMPLEX(lt)) {
00436 p->exprblock.leftp = putx(mkconv(pt,
00437 (expptr)realpart(
00438 putcx1(p->exprblock.leftp))));
00439 break;
00440 }
00441 if(lt==TYCHAR && lp->tag==TEXPR &&
00442 lp->exprblock.opcode==OPCALL)
00443 {
00444
00445 /* May want to make a comma expression here instead. I had one, but took
00446 it out for my convenience, not for the convenience of the end user */
00447
00448 putout (putcall (lp, (Addrp *) &(p ->
00449 exprblock.leftp)));
00450 return putop (p);
00451 }
00452 if (lt == TYCHAR) {
00453 if (ISCONST(p->exprblock.leftp)
00454 && ISNUMERIC(p->exprblock.vtype)) {
00455 hsave = halign;
00456 halign = 0;
00457 p->exprblock.leftp = putx((expptr)
00458 putconst((Constp)
00459 p->exprblock.leftp));
00460 halign = hsave;
00461 }
00462 else
00463 p->exprblock.leftp =
00464 putx(p->exprblock.leftp);
00465 return p;
00466 }
00467 if (pt < lt && ONEOF(lt,MSKINT|MSKREAL))
00468 break;
00469 frexpr(p->exprblock.vleng);
00470 free( (charptr) p );
00471 p = lp;
00472 if (p->tag != TEXPR)
00473 goto retputx;
00474 pt = lt;
00475 lp = p->exprblock.leftp;
00476 lt = lp->headblock.vtype;
00477 } /* while */
00478 if(p->tag==TEXPR && p->exprblock.opcode==OPCONV)
00479 break;
00480 retputx:
00481 return putx(p);
00482
00483 case OPADDR:
00484 comma = NO;
00485 lp = p->exprblock.leftp;
00486 free( (charptr) p );
00487 if(lp->tag != TADDR)
00488 {
00489 tp = (expptr)
00490 mktmp(lp->headblock.vtype,lp->headblock.vleng);
00491 p = putx( mkexpr(OPASSIGN, cpexpr(tp), lp) );
00492 lp = tp;
00493 comma = YES;
00494 }
00495 if(comma)
00496 p = mkexpr(OPCOMMA, p, putaddr(lp));
00497 else
00498 p = (expptr)putaddr(lp);
00499 return p;
00500
00501 case OPASSIGN:
00502 case OPASSIGNI:
00503 case OPLT:
00504 case OPLE:
00505 case OPGT:
00506 case OPGE:
00507 case OPEQ:
00508 case OPNE:
00509 ;
00510 }
00511
00512 if( ops2[p->exprblock.opcode] <= 0)
00513 badop("putop", p->exprblock.opcode);
00514 lp = p->exprblock.leftp = putx(p->exprblock.leftp);
00515 if (p -> exprblock.rightp) {
00516 tp = p->exprblock.rightp = putx(p->exprblock.rightp);
00517 if (ISCONST(tp) && ISCONST(lp))
00518 p = fold(p);
00519 }
00520 return p;
00521 }
|
|
|
Definition at line 131 of file putpcc.c. Referenced by exassign(), intdouble(), krput(), putcall(), putch1(), putct1(), putcx1(), putcxeq(), putmnmx(), putop(), putpower(), and suboffset().
00133 {
00134 p1_expr (p);
00135
00136 /* Used to make temporaries in holdtemps available here, but they */
00137 /* may be reused too soon (e.g. when multiple **'s are involved). */
00138 }
|
|
|
Definition at line 528 of file putpcc.c. References base, charptr, cpexpr(), ENULL, Fatal(), free, frexpr(), Expression::headblock, ISICON, mkexpr(), mktmp(), OPCOMMA, OPSTAR, p, p1_comment(), putassign(), putout(), putsteq(), putx(), and Headblock::vtype. Referenced by putx().
00530 {
00531 expptr base;
00532 Addrp t1, t2;
00533 ftnint k;
00534 int type;
00535 char buf[80]; /* buffer for text of comment */
00536
00537 if(!ISICON(p->exprblock.rightp) ||
00538 (k = p->exprblock.rightp->constblock.Const.ci)<2)
00539 Fatal("putpower: bad call");
00540 base = p->exprblock.leftp;
00541 type = base->headblock.vtype;
00542 t1 = mktmp(type, ENULL);
00543 t2 = NULL;
00544
00545 free ((charptr) p);
00546 p = putassign (cpexpr((expptr) t1), base);
00547
00548 sprintf (buf, "Computing %ld%s power", k,
00549 k == 2 ? "nd" : k == 3 ? "rd" : "th");
00550 p1_comment (buf);
00551
00552 for( ; (k&1)==0 && k>2 ; k>>=1 )
00553 {
00554 p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
00555 }
00556
00557 if(k == 2) {
00558
00559 /* Write the power computation out immediately */
00560 putout (p);
00561 p = putx( mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1)));
00562 } else {
00563 t2 = mktmp(type, ENULL);
00564 p = mkexpr (OPCOMMA, p, putassign(cpexpr((expptr)t2),
00565 cpexpr((expptr)t1)));
00566
00567 for(k>>=1 ; k>1 ; k>>=1)
00568 {
00569 p = mkexpr (OPCOMMA, p, putsteq(t1, t1));
00570 if(k & 1)
00571 {
00572 p = mkexpr (OPCOMMA, p, putsteq(t2, t1));
00573 }
00574 }
00575 /* Write the power computation out immediately */
00576 putout (p);
00577 p = putx( mkexpr(OPSTAR, cpexpr((expptr)t2),
00578 mkexpr(OPSTAR, cpexpr((expptr)t1), cpexpr((expptr)t1))));
00579 }
00580 frexpr((expptr)t1);
00581 if(t2)
00582 frexpr((expptr)t2);
00583 return p;
00584 }
|
|
|
Definition at line 2044 of file putpcc.c. References err, fixtype(), ISLOGICAL, mem(), p, p1_expr(), P1_WHILE1START, P1_WHILE2START, p1put(), putx(), and TYERROR. Referenced by exdo().
02046 {
02047 long where;
02048 int k, n;
02049
02050 if (wh_next >= wh_last)
02051 {
02052 k = wh_last - wh_first;
02053 n = k + 100;
02054 wh_next = mem(n,0);
02055 wh_last = wh_first + n;
02056 if (k)
02057 memcpy(wh_next, wh_first, k);
02058 wh_first = wh_next;
02059 wh_next += k;
02060 wh_last = wh_first + n;
02061 }
02062 p1put(P1_WHILE1START);
02063 where = ftell(pass1_file);
02064 if( !ISLOGICAL((k = (p = fixtype(p))->headblock.vtype)))
02065 {
02066 if(k != TYERROR)
02067 err("non-logical expression in DO WHILE statement");
02068 }
02069 else {
02070 p = putx(p);
02071 *wh_next++ = ftell(pass1_file) > where;
02072 p1put(P1_WHILE2START);
02073 p1_expr(p);
02074 }
02075 }
|
|
|
Definition at line 198 of file putpcc.c. References badop(), badtag(), ENULL, errnode, frexpr(), ICON, INT, ISCHAR, ISCOMPLEX, ISICON, ISREAL, krparens, krput(), log_2(), mkconv(), OPABS, OPADDR, OPAND, OPASSIGN, OPASSIGNI, OPBITAND, OPBITCLR, OPBITNOT, OPBITOR, OPBITSET, OPBITTEST, OPBITXOR, opc, OPCALL, OPCCALL, OPCHARCAST, OPCOLON, OPCOMMA, OPCONCAT, OPCONV, OPDABS, OPDMAX, OPDMIN, OPEQ, OPEQV, OPGE, OPGT, OPIDENTITY, OPLE, OPLSHIFT, OPLT, OPMAX, OPMAX2, OPMIN, OPMIN2, OPMINUS, OPMOD, OPNE, OPNEG, OPNEG1, OPNEQV, OPNOT, OPOR, OPPLUS, OPPLUSEQ, OPPOWER, OPQBITCLR, OPQBITSET, OPQUEST, OPRSHIFT, OPSLASH, OPSTAR, OPSTAREQ, p, putaddr(), putcall(), putch1(), putchcmp(), putcheq(), putconst(), putcx1(), putcxcmp(), putcxeq(), putcxop(), putmnmx(), putop(), putpower(), realpart(), TADDR, TCONST, TERROR, TEXPR, and TYQUAD. Referenced by dim_finish(), exar2(), exarif(), excall(), exdo(), iosetc(), krput(), make_param(), putaddr(), putassign(), putcall(), putcat(), putcheq(), putcxcmp(), putexpr(), putif(), putmnmx(), putop(), putpower(), putsteq(), putwhile(), subskept(), and yyparse().
00200 {
00201 int opc;
00202 int k;
00203
00204 if (p)
00205 switch(p->tag)
00206 {
00207 case TERROR:
00208 break;
00209
00210 case TCONST:
00211 switch(p->constblock.vtype)
00212 {
00213 case TYLOGICAL1:
00214 case TYLOGICAL2:
00215 case TYLOGICAL:
00216 #ifdef TYQUAD
00217 case TYQUAD:
00218 #endif
00219 case TYLONG:
00220 case TYSHORT:
00221 case TYINT1:
00222 break;
00223
00224 case TYADDR:
00225 break;
00226 case TYREAL:
00227 case TYDREAL:
00228
00229 /* Don't write it out to the p2 file, since you'd need to call putconst,
00230 which is just what we need to avoid in the translator */
00231
00232 break;
00233 default:
00234 p = putx( (expptr)putconst((Constp)p) );
00235 break;
00236 }
00237 break;
00238
00239 case TEXPR:
00240 switch(opc = p->exprblock.opcode)
00241 {
00242 case OPCALL:
00243 case OPCCALL:
00244 if( ISCOMPLEX(p->exprblock.vtype) )
00245 p = putcxop(p);
00246 else p = putcall(p, (Addrp *)NULL);
00247 break;
00248
00249 case OPMIN:
00250 case OPMAX:
00251 p = putmnmx(p);
00252 break;
00253
00254
00255 case OPASSIGN:
00256 if(ISCOMPLEX(p->exprblock.leftp->headblock.vtype)
00257 || ISCOMPLEX(p->exprblock.rightp->headblock.vtype)) {
00258 (void) putcxeq(p);
00259 p = ENULL;
00260 } else if( ISCHAR(p) )
00261 p = putcheq(p);
00262 else
00263 goto putopp;
00264 break;
00265
00266 case OPEQ:
00267 case OPNE:
00268 if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) ||
00269 ISCOMPLEX(p->exprblock.rightp->headblock.vtype) )
00270 {
00271 p = putcxcmp(p);
00272 break;
00273 }
00274 case OPLT:
00275 case OPLE:
00276 case OPGT:
00277 case OPGE:
00278 if(ISCHAR(p->exprblock.leftp))
00279 {
00280 p = putchcmp(p);
00281 break;
00282 }
00283 goto putopp;
00284
00285 case OPPOWER:
00286 p = putpower(p);
00287 break;
00288
00289 case OPSTAR:
00290 /* m * (2**k) -> m<<k */
00291 if(INT(p->exprblock.leftp->headblock.vtype) &&
00292 ISICON(p->exprblock.rightp) &&
00293 ( (k = log_2(p->exprblock.rightp->constblock.Const.ci))>0) )
00294 {
00295 p->exprblock.opcode = OPLSHIFT;
00296 frexpr(p->exprblock.rightp);
00297 p->exprblock.rightp = ICON(k);
00298 goto putopp;
00299 }
00300 if (krparens && ISREAL(p->exprblock.vtype))
00301 return krput(p);
00302
00303 case OPMOD:
00304 goto putopp;
00305 case OPPLUS:
00306 if (krparens && ISREAL(p->exprblock.vtype))
00307 return krput(p);
00308 case OPMINUS:
00309 case OPSLASH:
00310 case OPNEG:
00311 case OPNEG1:
00312 case OPABS:
00313 case OPDABS:
00314 if( ISCOMPLEX(p->exprblock.vtype) )
00315 p = putcxop(p);
00316 else goto putopp;
00317 break;
00318
00319 case OPCONV:
00320 if( ISCOMPLEX(p->exprblock.vtype) )
00321 p = putcxop(p);
00322 else if( ISCOMPLEX(p->exprblock.leftp->headblock.vtype) )
00323 {
00324 p = putx( mkconv(p->exprblock.vtype,
00325 (expptr)realpart(putcx1(p->exprblock.leftp))));
00326 }
00327 else goto putopp;
00328 break;
00329
00330 case OPNOT:
00331 case OPOR:
00332 case OPAND:
00333 case OPEQV:
00334 case OPNEQV:
00335 case OPADDR:
00336 case OPPLUSEQ:
00337 case OPSTAREQ:
00338 case OPCOMMA:
00339 case OPQUEST:
00340 case OPCOLON:
00341 case OPBITOR:
00342 case OPBITAND:
00343 case OPBITXOR:
00344 case OPBITNOT:
00345 case OPLSHIFT:
00346 case OPRSHIFT:
00347 case OPASSIGNI:
00348 case OPIDENTITY:
00349 case OPCHARCAST:
00350 case OPMIN2:
00351 case OPMAX2:
00352 case OPDMIN:
00353 case OPDMAX:
00354 case OPBITTEST:
00355 case OPBITCLR:
00356 case OPBITSET:
00357 #ifdef TYQUAD
00358 case OPQBITSET:
00359 case OPQBITCLR:
00360 #endif
00361 putopp:
00362 p = putop(p);
00363 break;
00364
00365 case OPCONCAT:
00366 /* weird things like ichar(a//a) */
00367 p = (expptr)putch1(p);
00368 break;
00369
00370 default:
00371 badop("putx", opc);
00372 p = errnode ();
00373 }
00374 break;
00375
00376 case TADDR:
00377 p = putaddr(p);
00378 break;
00379
00380 default:
00381 badtag("putx", p->tag);
00382 p = errnode ();
00383 }
00384
00385 return p;
00386 }
|
|
||||||||||||||||||||||||||||||||||||||||
|
Definition at line 1428 of file putpcc.c. References Argtype(), atype_squawk(), Argtypes::atypes, bad_atypes(), Argtypes::changes, Atype::cp, Chain::datap, Argtypes::defined, Argtypes::dnargs, gmem(), i, impldcl(), inconsist, init_ac, mem(), Expression::nameblock, Argtypes::nargs, Chain::nextp, proc_argchanges, proc_protochanges, STGEXT, Expression::tag, TNAME, TYFTNLEN, Atype::type, type_fixup(), typekludge(), Nameblock::vdcldone, and Nameblock::vinfproc. Referenced by doentry(), length_comp(), and saveargtypes().
01430 {
01431 Argtypes *at;
01432 chainp cp;
01433 int i, i0, j, k, nargs, nbad, *t, *te;
01434 Atype *atypes;
01435 expptr q;
01436 char buf[208], buf1[32], buf2[32];
01437 static int initargs[4] = {TYCOMPLEX, TYDCOMPLEX, TYCHAR, TYFTNLEN+100};
01438 static int *init_ap[TYSUBR+1] = {0,0,0,0,0,0,0,
01439 #ifdef TYQUAD
01440 0,
01441 #endif
01442 initargs, initargs+1,0,0,0,initargs+2};
01443
01444 i0 = init_ac[type];
01445 t = init_ap[type];
01446 te = t + i0;
01447 if (at = *at0) {
01448 *at1 = at;
01449 nargs = at->nargs;
01450 if (nargs < 0 && type && at->changes & 2 && !at->defined)
01451 --proc_protochanges;
01452 if (at->dnargs >= 0 && zap != 2)
01453 type = 0;
01454 if (nargs < 0) { /* inconsistent usage seen */
01455 if (type)
01456 goto newlist;
01457 return;
01458 }
01459 atypes = at->atypes;
01460 i = nchargs;
01461 for(nbad = 0; t < te; atypes++) {
01462 if (++i > nargs) {
01463 toomany:
01464 i = nchargs + i0;
01465 for(cp = arglist; cp; cp = cp->nextp)
01466 i++;
01467 toofew:
01468 switch(zap) {
01469 case 2: zap = 6; break;
01470 case 1: if (at->defined & 4)
01471 return;
01472 }
01473 sprintf(buf,
01474 "%s%.90s:\n\there %d, previously %d args and string lengths.",
01475 inconsist, fname, i, nargs);
01476 atype_squawk(at, buf);
01477 if (type) {
01478 t = init_ap[type];
01479 goto newlist;
01480 }
01481 return;
01482 }
01483 j = atypes->type;
01484 k = *t++;
01485 if (j != k && j-400 != k) {
01486 cp = 0;
01487 goto badtypes;
01488 }
01489 }
01490 for(cp = arglist; cp; atypes++, cp = cp->nextp) {
01491 if (++i > nargs)
01492 goto toomany;
01493 j = atypes->type;
01494 if (!(q = (expptr)cp->datap))
01495 continue;
01496 k = typekludge(ccall, q, atypes, j);
01497 if (k >= 300 || k == j)
01498 continue;
01499 if (j >= 300) {
01500 if (k >= 200) {
01501 if (k == TYUNKNOWN + 200)
01502 continue;
01503 if (j % 100 != k - 200
01504 && k != TYSUBR + 200
01505 && j != TYUNKNOWN + 300
01506 && !type_fixup(at,atypes,k))
01507 goto badtypes;
01508 }
01509 else if (j % 100 % TYSUBR != k % TYSUBR
01510 && !type_fixup(at,atypes,k))
01511 goto badtypes;
01512 }
01513 else if (k < 200 || j < 200)
01514 if (j) {
01515 if (k == TYUNKNOWN
01516 && q->tag == TNAME
01517 && q->nameblock.vinfproc) {
01518 q->nameblock.vdcldone = 0;
01519 impldcl((Namep)q);
01520 }
01521 goto badtypes;
01522 }
01523 else ; /* fall through to update */
01524 else if (k == TYUNKNOWN+200)
01525 continue;
01526 else if (j != TYUNKNOWN+200)
01527 {
01528 badtypes:
01529 if (++nbad == 1)
01530 bad_atypes(at, fname, i - nchargs,
01531 j, k, "here ", ", previously");
01532 else
01533 fprintf(stderr,
01534 "\targ %d: here %s, previously %s.\n",
01535 i - nchargs, Argtype(k,buf1),
01536 Argtype(j,buf2));
01537 if (!cp)
01538 break;
01539 continue;
01540 }
01541 /* We've subsequently learned the right type,
01542 as in the call on zoo below...
01543
01544 subroutine foo(x, zap)
01545 external zap
01546 call goo(zap)
01547 x = zap(3)
01548 call zoo(zap)
01549 end
01550 */
01551 if (!nbad) {
01552 atypes->type = k;
01553 at->changes |= 1;
01554 }
01555 }
01556 if (i < nargs)
01557 goto toofew;
01558 if (nbad) {
01559 if (type) {
01560 /* we're defining the procedure */
01561 t = init_ap[type];
01562 te = t + i0;
01563 proc_argchanges = 1;
01564 goto newlist;
01565 }
01566 return;
01567 }
01568 if (zap == 1 && (at->changes & 5) != 5)
01569 at->changes = 0;
01570 return;
01571 }
01572 newlist:
01573 i = i0 + nchargs;
01574 for(cp = arglist; cp; cp = cp->nextp)
01575 i++;
01576 k = sizeof(Argtypes) + (i-1)*sizeof(Atype);
01577 *at0 = *at1 = at = stg == STGEXT ? (Argtypes *)gmem(k,1)
01578 : (Argtypes *) mem(k,1);
01579 at->dnargs = at->nargs = i;
01580 at->defined = zap & 6;
01581 at->changes = type ? 0 : 4;
01582 atypes = at->atypes;
01583 for(; t < te; atypes++) {
01584 atypes->type = *t++;
01585 atypes->cp = 0;
01586 }
01587 for(cp = arglist; cp; atypes++, cp = cp->nextp) {
01588 atypes->cp = 0;
01589 atypes->type = (q = (expptr)cp->datap)
01590 ? typekludge(ccall, q, atypes, 0)
01591 : 0;
01592 }
01593 for(; --nchargs >= 0; atypes++) {
01594 atypes->type = TYFTNLEN + 100;
01595 atypes->cp = 0;
01596 }
01597 }
|
|
|
Definition at line 1653 of file putpcc.c. References get_argtypes(), Expression::listblock, Listblock::listp, OPCCALL, p, save_argtypes(), Expression::tag, and TLIST. Referenced by putcall().
01656 {
01657 Argtypes **at0, **at1;
01658 chainp arglist;
01659 expptr rp;
01660 char *fname;
01661
01662 fname = get_argtypes(p, &at0, &at1);
01663 rp = p->rightp;
01664 arglist = rp && rp->tag == TLIST ? rp->listblock.listp : 0;
01665 save_argtypes(arglist, at0, at1, p->opcode == OPCCALL,
01666 fname, p->leftp->addrblock.vstg, 0, 0, 0);
01667 }
|
|
||||||||||||||||
|
Definition at line 1400 of file putpcc.c. References Extsym::arginfo, Entrypoint::entnextp, Entrypoint::entryname, proc_argchanges, and Atype::type. Referenced by argverify(), and save_argtypes().
01402 {
01403 register struct Entrypoint *ep;
01404 if (!infertypes)
01405 return 0;
01406 for(ep = entries; ep; ep = ep->entnextp)
01407 if (ep->entryname && at == ep->entryname->arginfo) {
01408 a->type = k % 100;
01409 return proc_argchanges = 1;
01410 }
01411 return 0;
01412 }
|
|
||||||||||||||||||||
|
Definition at line 1224 of file putpcc.c. References Expression::addrblock, Addrblock::charleng, CLPROC, CLUNKNOWN, Atype::cp, Expression::exprblock, Expression::headblock, i, inferdcl(), iocalladdr, mkchain(), Expression::nameblock, Exprblock::opcode, OPCOMMA_ARG, PTHISPROC, STGARG, STGEXT, TADDR, Expression::tag, TCONST, TEXPR, TNAME, TYFTNLEN, UNAM_NAME, Addrblock::uname_tag, Addrblock::user, Nameblock::vardesc, Nameblock::vclass, Addrblock::vclass, Nameblock::vimpltype, Addrblock::vstg, Nameblock::vstg, and Headblock::vtype. Referenced by save_argtypes().
01227 {
01228 register int i, k;
01229 extern int iocalladdr;
01230 register Namep np;
01231
01232 /* Return value classes:
01233 * < 100 ==> Fortran arg (pointer to type)
01234 * < 200 ==> C arg
01235 * < 300 ==> procedure arg
01236 * < 400 ==> external, no explicit type
01237 * < 500 ==> arg that may turn out to be
01238 * either a variable or a procedure
01239 */
01240
01241 k = q->headblock.vtype;
01242 if (ccall) {
01243 if (k == TYREAL)
01244 k = TYDREAL; /* force double for library routines */
01245 return k + 100;
01246 }
01247 if (k == TYADDR)
01248 return iocalladdr;
01249 i = q->tag;
01250 if ((i == TEXPR && q->exprblock.opcode != OPCOMMA_ARG)
01251 || (i == TADDR && q->addrblock.charleng)
01252 || i == TCONST)
01253 k = TYFTNLEN + 100;
01254 else if (i == TADDR)
01255 switch(q->addrblock.vclass) {
01256 case CLPROC:
01257 if (q->addrblock.uname_tag != UNAM_NAME)
01258 k += 200;
01259 else if ((np = q->addrblock.user.name)->vprocclass
01260 != PTHISPROC) {
01261 if (k && !np->vimpltype)
01262 k += 200;
01263 else {
01264 if (j > 200 && infertypes && j < 300) {
01265 k = j;
01266 inferdcl(np, j-200);
01267 }
01268 else k = (np->vstg == STGEXT
01269 ? extsymtab[np->vardesc.varno].extype
01270 : 0) + 200;
01271 at->cp = mkchain((char *)np, at->cp);
01272 }
01273 }
01274 else if (k == TYSUBR)
01275 k += 200;
01276 break;
01277
01278 case CLUNKNOWN:
01279 if (q->addrblock.vstg == STGARG
01280 && q->addrblock.uname_tag == UNAM_NAME) {
01281 k += 400;
01282 at->cp = mkchain((char *)q->addrblock.user.name,
01283 at->cp);
01284 }
01285 }
01286 else if (i == TNAME && q->nameblock.vstg == STGARG) {
01287 np = &q->nameblock;
01288 switch(np->vclass) {
01289 case CLPROC:
01290 if (!np->vimpltype)
01291 k += 200;
01292 else if (j <= 200 || !infertypes || j >= 300)
01293 k += 300;
01294 else {
01295 k = j;
01296 inferdcl(np, j-200);
01297 }
01298 goto add2chain;
01299
01300 case CLUNKNOWN:
01301 /* argument may be a scalar variable or a function */
01302 if (np->vimpltype && j && infertypes
01303 && j < 300) {
01304 inferdcl(np, j % 100);
01305 k = j;
01306 }
01307 else
01308 k += 400;
01309
01310 /* to handle procedure args only so far known to be
01311 * external, save a pointer to the symbol table entry...
01312 */
01313 add2chain:
01314 at->cp = mkchain((char *)np, at->cp);
01315 }
01316 }
01317 return k;
01318 }
|
Variable Documentation
|
|
Definition at line 1369 of file putpcc.c. Referenced by bad_atypes(), and save_argtypes(). |
|
|
Definition at line 48 of file putpcc.c. Referenced by putcall(), and save_argtypes(). |
|
|
|
|
|
Definition at line 49 of file putpcc.c. Referenced by putop(). |
|
|
Definition at line 50 of file putpcc.c. Referenced by doentry(), save_argtypes(), type_fixup(), and zap_changes(). |
|
|
Definition at line 50 of file putpcc.c. Referenced by atype_squawk(), changedtype(), save_argtypes(), and zap_changes(). |
