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(). |