lang/basic/src/symbols.c

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