symbols.c 6.2 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376
  1. /*
  2. * (c) copyright 1987 by the Vrije Universiteit, Amsterdam, The Netherlands.
  3. * See the copyright notice in the ACK home directory, in the file "Copyright".
  4. */
  5. #include "bem.h"
  6. #ifndef NORSCID
  7. static char rcs_id[] = "$Id$" ;
  8. #endif
  9. /* Symboltable management module */
  10. int deftype[128]; /* default type declarer */
  11. /* which may be set by OPTION BASE */
  12. initdeftype()
  13. {
  14. int i;
  15. for(i='a';i<='z';i++) deftype[i]= DOUBLETYPE;
  16. for(i='A';i<='Z';i++) deftype[i]= DOUBLETYPE;
  17. }
  18. int indexbase=0; /* start of array subscripting */
  19. Symbol *firstsym = NIL;
  20. Symbol *alternate = NIL;
  21. Symbol *srchsymbol(str)
  22. char *str;
  23. {
  24. Symbol *s;
  25. /* search symbol table entry or create it */
  26. if (debug) print("srchsymbol %s\n",str);
  27. s=firstsym;
  28. while (s)
  29. {
  30. if ( strcmp(s->symname,str)==0) return(s);
  31. s= s->nextsym;
  32. }
  33. /* search alternate list */
  34. s=alternate;
  35. while (s)
  36. {
  37. if ( strcmp(s->symname,str)==0) return(s);
  38. s= s->nextsym;
  39. }
  40. /* not found, create an empty slot */
  41. s = (Symbol *) salloc(sizeof(Symbol));
  42. s->symtype= DEFAULTTYPE;
  43. s->nextsym= firstsym;
  44. s->symname= (char *) salloc((unsigned) strlen(str)+1);
  45. strcpy(s->symname,str);
  46. firstsym= s;
  47. if (debug) print("%s allocated\n",str);
  48. return(s);
  49. }
  50. dcltype(s)
  51. Symbol *s;
  52. {
  53. /* type declarer */
  54. int type;
  55. if ( s->isparam) return;
  56. type=s->symtype;
  57. if (type==DEFAULTTYPE)
  58. /* use the default rule */
  59. type= deftype[*s->symname];
  60. /* generate the emlabel too */
  61. if ( s->symalias==0)
  62. s->symalias= dclspace(type);
  63. s->symtype= type;
  64. if (debug) print("symbol set to %d\n",type);
  65. }
  66. dclarray(s)
  67. Symbol *s;
  68. {
  69. int i; int size;
  70. if ( s->symtype==DEFAULTTYPE) s->symtype= DOUBLETYPE;
  71. if (debug) print("generate space and descriptors for %d\n",s->symtype);
  72. if (debug) print("dim %d\n",s->dimensions);
  73. s->symalias= genlabel();
  74. /* generate descriptors */
  75. size=1;
  76. for(i=0;i<s->dimensions;i++) {
  77. s->dimalias[i]= genlabel();
  78. }
  79. for(i=s->dimensions-1;i>=0;i--)
  80. {
  81. C_df_dlb((label)(s->dimalias[i]));
  82. C_rom_cst((arith)indexbase);
  83. C_rom_cst((arith)(s->dimlimit[i]-indexbase));
  84. C_rom_cst((arith)(size*typesize(s->symtype)));
  85. size = size* (s->dimlimit[i]+1-indexbase);
  86. }
  87. if (debug) print("size=%d\n",size);
  88. /* size of stuff */
  89. C_df_dlb((label)s->symalias);
  90. get_space(s->symtype,size); /* Van ons. */
  91. }
  92. get_space(type,size)
  93. int type,size;
  94. {
  95. switch ( type ) {
  96. case INTTYPE:
  97. C_bss_cst((arith)BEMINTSIZE*size,
  98. (arith)0,
  99. 1);
  100. break;
  101. case FLOATTYPE:
  102. case DOUBLETYPE:
  103. C_bss_fcon((arith)BEMFLTSIZE*size,
  104. "0.0",
  105. (arith)BEMFLTSIZE,
  106. 1);
  107. break;
  108. case STRINGTYPE: /* Note: this is ugly. Gertjan */
  109. C_bss_icon((arith)BEMPTRSIZE*size,
  110. "0",
  111. (arith)BEMPTRSIZE,
  112. 1);
  113. break;
  114. default:
  115. error("Space allocated for unknown type. Coredump.");
  116. abort(); /* For debugging purposes */
  117. }
  118. }
  119. defarray(s)
  120. Symbol *s;
  121. {
  122. /* array is used without dim statement, set default limits */
  123. int i;
  124. for(i=0;i<s->dimensions;i++) s->dimlimit[i]=10;
  125. dclarray(s);
  126. }
  127. dclspace(type)
  128. {
  129. int nr;
  130. nr= genemlabel();
  131. switch( type)
  132. {
  133. case STRINGTYPE:
  134. C_bss_icon((arith)BEMPTRSIZE,"0",(arith)BEMPTRSIZE,1);
  135. break;
  136. case INTTYPE:
  137. C_bss_cst((arith)BEMINTSIZE,(arith)0,1);
  138. break;
  139. case FLOATTYPE:
  140. case DOUBLETYPE:
  141. C_bss_fcon((arith)BEMFLTSIZE,"0.0",(arith)BEMFLTSIZE,1);
  142. break;
  143. }
  144. return(nr);
  145. }
  146. /* SOME COMPILE TIME OPTIONS */
  147. optionbase(ival)
  148. int ival;
  149. {
  150. if ( ival<0 || ival>1)
  151. error("illegal option base value");
  152. else indexbase=ival;
  153. }
  154. setdefaulttype(type)
  155. int type;
  156. {
  157. extern char *cptr;
  158. char first,last,i;
  159. /* handcrafted parser for letter ranges */
  160. if (debug) print("deftype:%s\n",cptr);
  161. while ( isspace(*cptr)) cptr++;
  162. if ( !isalpha(*cptr))
  163. error("letter expected");
  164. first= *cptr++;
  165. if (*cptr=='-')
  166. {
  167. /* letter range */
  168. cptr++;
  169. last= *cptr;
  170. if ( !isalpha(last))
  171. error("letter expected");
  172. else for(i=first;i<=last;i++) deftype[i]= type;
  173. cptr++;
  174. } else deftype[first]=type;
  175. if ( *cptr== ',')
  176. {
  177. cptr++;
  178. setdefaulttype(type); /* try again */
  179. }
  180. }
  181. Symbol *fcn;
  182. newscope(s)
  183. Symbol *s;
  184. {
  185. if (debug) print("new scope for %s\n",s->symname);
  186. alternate= firstsym;
  187. firstsym = NIL;
  188. fcn=s;
  189. s->isfunction=1;
  190. if ( fcn->dimensions)
  191. error("Array redeclared");
  192. if ( fcn->symtype== DEFAULTTYPE)
  193. fcn->symtype=DOUBLETYPE;
  194. }
  195. /* User defined functions */
  196. heading( )
  197. {
  198. char procname[50];
  199. (void) sprint(procname,"_%s",fcn->symname);
  200. C_pro_narg(procname);
  201. if ( fcn->symtype== DEFAULTTYPE)
  202. fcn->symtype= DOUBLETYPE;
  203. }
  204. int fcnsize()
  205. {
  206. /* generate portable function size */
  207. int i,sum; /* sum is NEW */
  208. sum = 0;
  209. for(i=0;i<fcn->dimensions;i++)
  210. sum += typesize(fcn->dimlimit[i]);
  211. return(sum);
  212. }
  213. endscope(type)
  214. int type;
  215. {
  216. Symbol *s;
  217. if ( debug) print("endscope");
  218. conversion(type,fcn->symtype);
  219. C_ret((arith) typestring(fcn->symtype));
  220. /* generate portable EM code */
  221. C_end( (arith)fcnsize() );
  222. s= firstsym;
  223. while (s)
  224. {
  225. firstsym = s->nextsym;
  226. (void) free((char *)s);
  227. s= firstsym;
  228. }
  229. firstsym= alternate;
  230. alternate = NIL;
  231. fcn=NIL;
  232. }
  233. dclparm(s)
  234. Symbol *s;
  235. {
  236. int size=0;
  237. if ( s->symtype== DEFAULTTYPE)
  238. s->symtype= DOUBLETYPE;
  239. s->isparam=1;
  240. fcn->dimlimit[fcn->dimensions]= s->symtype;
  241. fcn->dimensions++;
  242. s->symalias= -fcn->dimensions;
  243. if ( debug) print("parameter %d offset %d\n",fcn->dimensions-1,-size);
  244. }
  245. /* unfortunately function calls have to be stacked as well */
  246. #define MAXNESTING 50
  247. Symbol *fcntable[MAXNESTING];
  248. int fcnindex= -1;
  249. fcncall(s)
  250. Symbol *s;
  251. {
  252. if ( !s->isfunction)
  253. error("Function not declared");
  254. else{
  255. fcn= s;
  256. fcnindex++;
  257. fcntable[fcnindex]=s;
  258. }
  259. return(s->symtype);
  260. }
  261. fcnend(parmcount)
  262. int parmcount;
  263. {
  264. int type;
  265. static char concatbuf[50]; /* NEW */
  266. /* check number of arguments */
  267. if ( parmcount <fcn->dimensions)
  268. error("not enough parameters");
  269. if ( parmcount >fcn->dimensions)
  270. error("too many parameters");
  271. (void) sprint(concatbuf,"_%s",fcn->symname);
  272. C_cal(concatbuf);
  273. C_asp((arith)fcnsize());
  274. C_lfr((arith) typestring(fcn->symtype));
  275. type= fcn->symtype;
  276. fcnindex--;
  277. if ( fcnindex>=0)
  278. fcn= fcntable[fcnindex];
  279. return(type);
  280. }
  281. callparm(ind,type)
  282. int ind,type;
  283. {
  284. if ( fcnindex<0) error("unexpected parameter");
  285. if ( ind >= fcn->dimensions)
  286. error("too many parameters");
  287. else
  288. conversion(type,fcn->dimlimit[ind]);
  289. }