From: em Date: Tue, 27 Nov 1984 22:11:59 +0000 (+0000) Subject: The version of basic copied from Martin Kerstens directory. X-Git-Tag: release-5-5~5954 X-Git-Url: https://git.ndcode.org/public/gitweb.cgi?a=commitdiff_plain;h=4301dfb7bf444071cceb80244014a0a63804cd7e;p=ack.git The version of basic copied from Martin Kerstens directory. --- diff --git a/lang/basic/src.old/Makefile b/lang/basic/src.old/Makefile new file mode 100644 index 000000000..69776f23a --- /dev/null +++ b/lang/basic/src.old/Makefile @@ -0,0 +1,14 @@ +CFLAGS = -c + +FILES= bem.o y.tab.o symbols.o initialize.o compile.o \ + parseparams.o yywrap.o gencode.o util.o graph.o \ + eval.o func.o split.o + +../bem: $(FILES) + cc -o ../bem $(FILES) + +y.tab.o : y.tab.c lex.c + cc $(CFLAGS) y.tab.c + +y.tab.c : basic.yacc + yacc -d basic.yacc diff --git a/lang/basic/src.old/basic.lex b/lang/basic/src.old/basic.lex new file mode 100644 index 000000000..ebdb3c82a --- /dev/null +++ b/lang/basic/src.old/basic.lex @@ -0,0 +1,464 @@ +/* This file contains the new lexical analizer */ +typedef struct { + char *name; + int token, classvalue,length; +} Key; + +Key keywords [] ={ +"abs", FUNCTION, ABSSYM, 0, +"and", BOOLOP, ANDSYM, 0, +"asc", FUNCTION, ASCSYM, 0, +"as", ASSYM, 0, 0, +"atn", FUNCTION, ATNSYM, 0, +"auto", ILLEGAL, 0, 0, +"base", BASESYM, 0, 0, +"call", CALLSYM, 0, 0, +"cdbl", FUNCTION, CDBLSYM, 0, +"chain", ILLEGAL, 0, 0, +"chr", FUNCTION, CHRSYM, 0, +"cint", FUNCTION, CINTSYM, 0, +"clear", CLEARSYM, 0, 0, +"cload", ILLEGAL, 0, 0, +"close", ILLEGAL, 0, 0, +"common", ILLEGAL, 0, 0, +"cont", ILLEGAL, 0, 0, +"cos", FUNCTION, COSSYM, 0, +"csng", FUNCTION, CSNGSYM, 0, +"csave", ILLEGAL, 0, 0, +"cvi", FUNCTION, CVISYM, 0, +"cvs", FUNCTION, CVSSYM, 0, +"cvd", FUNCTION, CVDSYM, 0, +"data", DATASYM, 0, 0, +"defint", DEFINTSYM, 0, 0, +"defsng", DEFSNGSYM, 0, 0, +"defdbl", DEFDBLSYM, 0, 0, +"defstr", DEFSTRSYM, 0, 0, +"def", DEFSYM, 0, 0, +"delete", ILLEGAL, 0, 0, +"dim", DIMSYM, 0, 0, +"edit", ILLEGAL, 0, 0, +"else", ELSESYM, 0, 0, +"end", ENDSYM, 0, 0, +"eof", FUNCTION, EOFSYM, 0, +"erase", ILLEGAL, 0, 0, +"error", ERRORSYM, 0, 0, +"err", ERRSYM, 0, 0, +"erl", ERLSYM, 0, 0, +"else", ELSESYM, 0, 0, +"eqv", BOOLOP, EQVSYM, 0, +"exp", FUNCTION, EXPSYM, 0, +"field", FIELDSYM, 0, 0, +"fix", FUNCTION, FIXSYM, 0, +"for", FORSYM, 0, 0, +"fre", FUNCTION, FRESYM, 0, +"get", GETSYM, 0, 0, +"gosub", GOSUBSYM, 0, 0, +"goto", GOTOSYM, 0, 0, +"hex", FUNCTION, HEXSYM, 0, +"if", IFSYM, 0, 0, +"imp", BOOLOP, IMPSYM, 0, +"inkey", INKEYSYM, 0, 0, +"input", INPUTSYM, 0, 0, +"inp", FUNCTION, INPSYM, 0, +"instr", FUNCTION, INSTRSYM, 0, +"int", FUNCTION, INTSYM, 0, +"kill", ILLEGAL, 0, 0, +"left", FUNCTION, LEFTSYM, 0, +"len", FUNCTION, LENSYM, 0, +"let", LETSYM, 0, 0, +"line", LINESYM, 0, 0, +"list", LISTSYM, 0, 0, +"llist", ILLEGAL, 0, 0, +"load", LOADSYM, 0, 0, +"loc", FUNCTION, LOCSYM, 0, +"log", FUNCTION, LOGSYM, 0, +"lpos", FUNCTION, LPOSSYM, 0, +"lprint", ILLEGAL, 0, 0, +"lset", LSETSYM, 0, 0, +"merge", MERGESYM, 0, 0, +"mid", MIDSYM, 0, 0, +"mki", FUNCTION, MKISYM, 0, +"mks", FUNCTION, MKSSYM, 0, +"mkd", FUNCTION, MKDSYM, 0, +"mod", MODSYM, 0, 0, +"name", ILLEGAL, 0, 0, +"new", ILLEGAL, 0, 0, +"next", NEXTSYM, 0, 0, +"not", NOTSYM, 0, 0, +"null", ILLEGAL, 0, 0, +"on", ONSYM, 0, 0, +"oct", FUNCTION, OCTSYM, 0, +"open", OPENSYM, 0, 0, +"option", OPTIONSYM, 0, 0, +"or", BOOLOP, ORSYM, 0, +"out", FUNCTION, OUTSYM, 0, +"peek", PEEKSYM, 0, 0, +"poke", POKESYM, 0, 0, +"print", PRINTSYM, 0, 0, +"pos", FUNCTION, POSSYM, 0, +"put", PUTSYM, 0, 0, +"randomize", RANDOMIZESYM, 0, 0, +"read", READSYM, 0, 0, +"rem", REMSYM, 0, 0, +"renum", ILLEGAL, 0, 0, +"ren", ILLEGAL, 0, 0, +"restore", RESTORESYM, 0, 0, +"resume", ILLEGAL, 0, 0, +"return", RETURNSYM, 0, 0, +"right", FUNCTION, RIGHTSYM, 0, +"rnd", FUNCTION, RNDSYM, 0, +"run", ILLEGAL, 0, 0, +"save", ILLEGAL, 0, 0, +"step", STEPSYM, 0, 0, +"sgn", FUNCTION, SGNSYM, 0, +"sin", FUNCTION, SINSYM, 0, +"space", FUNCTION, SPACESYM, 0, +"spc", FUNCTION, SPCSYM, 0, +"sqr", FUNCTION, SQRSYM, 0, +"stop", STOPSYM, 0, 0, +"string", FUNCTION, STRINGSYM, 0, +"str", FUNCTION, STRSYM, 0, +"swap", SWAPSYM, 0, 0, +"tab", FUNCTION, TABSYM, 0, +"tan", FUNCTION, TANSYM, 0, +"then", THENSYM, 0, 0, +"to", TOSYM, 0, 0, +"tron", TRONOFFSYM, TRONSYM, 0, +"troff", TRONOFFSYM, TROFFSYM, 0, +"using", USINGSYM, 0, 0, +"usr", FUNCTION, USRSYM, 0, +"val", FUNCTION, VALSYM, 0, +"varptr", FUNCTION, VARPTRSYM, 0, +"wait", ILLEGAL, 0, 0, +"while", WHILESYM, 0, 0, +"wend", WENDSYM, 0, 0, +"width", ILLEGAL, 0, 0, +"write", WRITESYM, 0, 0, +"xor", BOOLOP, XORSYM, 0, +0, 0, 0, 0 +}; + +/* Keyword index table */ + +int kex[27]; + +/* Initialize the keyword table */ +fillkex() +{ + Key *k; + int i; + for(k=keywords;k->name;k++) + k->length= strlen(k->name); + k=keywords; + for(i=0;k->name && i<='z'-'a';i++) + { + for(;k->name && *k->namename!=i+'a') continue; + kex[*k->name-'a']=k-keywords; + for(;k->name && *k->name==i+'a';k++); + kex[*(k-1)->name-'a'+1]=k-keywords; + } + if(debug) + { + for(i=0;i<27;i++) + printf("%c:%d\n",'a'+i,kex[i]); + } +} + +#include + +/* Get each line separately into the buffer */ +/* Lines too long are terminated and flagged illegal */ + +#define MAXLINELENGTH 1024 + +char inputline[MAXLINELENGTH]; /* current source line */ +char *cptr; /* next character to decode */ +int yylineno=0; /* source line counter */ + +getline() +{ + /* get next input line */ + + if( fgets(inputline,MAXLINELENGTH,yyin) == NULL) + return(FALSE); + yylineno ++; + if( index(inputline,'\n') == 0) + error("source line too long"); + inputline[MAXLINELENGTH-1]=0; + if( listing) + fputs(inputline,stdout); + cptr= inputline; + return(TRUE); +} +yyerror(str) +char *str; +{ + error("Syntax error"); +} + +typechar() +{ + switch(*cptr) + { + case '$': + cptr++; return( STRINGTYPE); + case '%': + cptr++; return( INTTYPE); + case '!': + cptr++; return( FLOATTYPE); + case '#': + cptr++; return( DOUBLETYPE); + } + return(0); +} + +/* symbols in Microsoft are significant for the first 40 characters */ +#define SIGNIFICANT 40 +char name[SIGNIFICANT+1]; + +lookup() +{ + Key *k; + Symbol *s; + char *c; + int i, typech; + + sval= name; + for(c=cptr; *c && isalnum(*c);c++) + if( isupper(*c) ) + *c= tolower((*c)); + for(k= keywords+kex[*cptr-'a']; *(k->name)== *cptr;k++) + if( strncmp(cptr,k->name,k->length)==0) + { + /* check functions first*/ + if( isalnum( *(cptr+k->length) ) && + k->token==FUNCTION) continue; + cptr += k->length; + yylval= k->classvalue; + if(debug) printf("lookup:%d %d\n", + k->classvalue,k->token); + if( k->token == FUNCTION) + { + /* stripp type character */ + typech=typechar(); + } + /* illegals + rem */ + if( k->token == REMSYM || k->token==ILLEGAL) + while( *cptr && *cptr!=':' && *cptr!='\n') + cptr++; + return( k->token); + } + /* Is it a function name ? */ + c=cptr; + /* Identifier found, update the symbol table */ + i=0; + while( isalnum(*c) || *c == '.') + if( isymtype!=DEFAULTTYPE) + { + if(typech && typech!=s->symtype && wflag) + warning("type re-declared,ignored"); + } + if( typech) + s->symtype=typech; + if(debug) printf("lookup:%d Identifier\n",s); + if( (name[0]=='f' || name[0]=='F') && + (name[1]=='n' || name[1]=='N') ) + return(FUNCTID); + return(IDENTIFIER); +} + +/* Parsing unsigned numbers */ +readconstant() +{ + /* read HEX and OCTAL numbers */ + char *c; + cptr++; + if( *cptr == 'H' || *cptr=='h') + { + /* HEX */ + cptr++; + c=cptr; + while( isdigit(*cptr) || + (*cptr>='a' && *cptr<='f' ) || + (*cptr>='A' && *cptr<='F' ) )cptr++; + sscanf(c,"%x",&ival); + } else + if( *cptr == 'O' || *cptr == 'o') + { + /* OCTAL */ + cptr++; + c=cptr; + while( isdigit(*cptr) ) cptr++; + sscanf(c,"%o",&ival); + } else + error("H or O expected"); + return(INTVALUE); +} + +number() +{ + long i1; + double f,dec; + int minflag; + register char *c; + + i1=0; + c=cptr; + while(isdigit(*c)){ + i1= i1*10 + *c-'0'; + c++; + } + cptr=c; + if( *c != '.'){ + if( i1> MAXINT || i1': + if( *(c+1)=='='){ + c++;c++;cptr=c; yylval= GESYM;return(RELOP); + } + yylval= '>'; + cptr++; + return(RELOP); + break; + case '<': + if( *(c+1)=='='){ + c++; c++; cptr=c; yylval=LESYM; return(RELOP); + } else + if( *(c+1)=='>'){ + c++; c++; cptr=c; yylval=NESYM; return(RELOP); + } + yylval= '<'; + cptr++; + return(RELOP); + } + return(*cptr++); +} diff --git a/lang/basic/src.old/basic.yacc b/lang/basic/src.old/basic.yacc new file mode 100644 index 000000000..a8288579c --- /dev/null +++ b/lang/basic/src.old/basic.yacc @@ -0,0 +1,461 @@ +%token ILLEGAL +%token ASSYM +%token BASESYM +%token CALLSYM +%token CLEARSYM +%token CLOSESYM +%token DATASYM +%token DEFINTSYM +%token DEFSNGSYM +%token DEFDBLSYM +%token DEFSTRSYM +%token DEFSYM +%token DIMSYM +%token ELSESYM +%token ERRSYM +%token ERLSYM +%token ERRORSYM +%token ELSESYM +%token FIELDSYM +%token FORSYM +%token FUNCTION +%token FUNCTID +%token INKEYSYM +%token GETSYM +%token GOSUBSYM +%token GOTOSYM +%token IFSYM +%token INPUTSYM +%token LETSYM +%token LINESYM +%token LSETSYM +%token MIDSYM +%token NEXTSYM +%token ONSYM +%token OPENSYM +%token OPTIONSYM +%token PRINTSYM +%token POKESYM +%token PUTSYM +%token RANDOMIZESYM +%token READSYM +%token REMSYM +%token RESTORESYM +%token RETURNSYM +%token ENDSYM +%token STOPSYM +%token STEPSYM +%token SWAPSYM +%token THENSYM +%token TOSYM +%token TRONOFFSYM +%token USINGSYM +%token USRSYM +%token WHILESYM +%token WENDSYM +%token WRITESYM +/* special tokens */ +%token EOLN +%token INTVALUE +%token FLTVALUE +%token DBLVALUE +%token STRVALUE +%token UNARYSYM +%token IDENTIFIER +%token ANDSYM +%token ORSYM +%token VARPTR + +%left BOOLOP +%left NOTSYM +%left RELOP '=' '<' '>' LESYM GESYM NESYM +%left '+' '-' +%left '*' '/' '\\' MODSYM +%left '^' +%left UNARYMINUS + +%{ +#define YYDEBUG +#include "bem.h" + +int ival; /* parser temporary values */ +double dval; +char *sval; +int e1,e2; +int chann; /* input/output channel */ +int deftype; /* predefined type declarer */ + +char *formatstring; /* formatstring used for printing */ +Symbol *s; /* Symbol dummy */ +%} +%% +programline : INTVALUE {newblock(ival); newemblock(ival);} stmts EOLN + | '#' INTVALUE STRVALUE EOLN + | EOLN + ; + + +stmts : singlestmt + | stmts ':' singlestmt + ; + +singlestmt : callstmt + | clearstmt + | closestmt + | datastmt + | deffnstmt + | defvarstmt + | defusrstmt + | dimstmt + | ERRORSYM expression {errorstmt($2);} + | fieldstmt + | forstmt + | getstmt + | gosubstmt + | ongotostmt + | ifstmt + | illegalstmt + | inputstmt + | letstmt + | lineinputstmt + | lsetstmt + | midstmt + | exceptionstmt + | nextstmt + | GOTOSYM INTVALUE {gotostmt(ival);} + | openstmt + | optionstmt + | pokestmt + | printstmt + | randomizestmt + | readstmt + | REMSYM + | restorestmt + | returnstmt + | ENDSYM { emcode("loc","0"); + emcode("cal","$_hlt"); + emcode("asp",EMINTSIZE);} + | STOPSYM { emcode("cal","$_stop");} + | swapstmt + | TRONOFFSYM { tronoff=$1;} + | whilestmt + | wendstmt + | writestmt + | /* EMPTY STATEMENT */ + ; + +illegalstmt: ILLEGAL {illegalcmd();} + +callstmt: CALLSYM IDENTIFIER parmlist ')' + { + emcode("cal",proclabel(((Symbol *) $2)->symname)); + while($3 -- >0) emcode("asp",EMPTRSIZE); + } + | CALLSYM IDENTIFIER + { emcode("cal",proclabel(((Symbol *) $2)->symname));} + +parmlist: '(' variable { $$=1;} + | parmlist ',' variable { $$= $1+1;} + +clearstmt: CLEARSYM {warning("statement ignored");} + | CLEARSYM ',' expression {warning("statement ignored");} + | CLEARSYM ',' expression ',' expression {warning("statement ignored");} +closestmt: CLOSESYM filelist + | CLOSESYM {emcode("cal","$_close");} + +filelist: cross intvalue { emcode("loc",$2); + emcode("cal","$_clochn"); + emcode("asp",EMINTSIZE);} + | filelist ',' cross intvalue { emcode("loc",$4); + emcode("cal","$_clochn"); + emcode("asp",EMINTSIZE);} + +datastmt: DATASYM {datastmt();} datalist {fprintf(datfile,"\n");} + +dataelm : INTVALUE {fprintf(datfile,"%d",ival);} + | '-' INTVALUE {fprintf(datfile,"%d",-ival);} + | FLTVALUE {fprintf(datfile,"%f",dval);} + | '-' FLTVALUE {fprintf(datfile,"%f",-dval);} + | STRVALUE {fprintf(datfile,"\"%s\"",sval);} + | IDENTIFIER {fprintf(datfile,"\"%s\"",sval);} + ; + +datalist: dataelm + | datalist ',' {fputc(',',datfile);} dataelm + ; + +deffnstmt: DEFSYM heading '=' expression {endscope($4);} + +heading : FUNCTID { newscope($1); heading();} + | FUNCTID {newscope($1);} '(' idlist ')' { heading();} + +idlist : IDENTIFIER { dclparm($1);} + | idlist ',' IDENTIFIER { dclparm($3);} + ; + +defvarstmt: DEFINTSYM { setdefaulttype( INTTYPE);} + | DEFSNGSYM { setdefaulttype( FLOATTYPE);} + | DEFDBLSYM { setdefaulttype( DOUBLETYPE);} + | DEFSTRSYM { setdefaulttype( STRINGTYPE);} + +defusrstmt: DEFSYM USRSYM error ':' {illegalcmd();} + +dimstmt: DIMSYM arraydcl ')' {dclarray($2);} + | dimstmt ',' arraydcl ')' {dclarray($3);} + ; + +arraydcl : IDENTIFIER '(' INTVALUE {$$=$1; s= (Symbol *) $1; + s->dimlimit[s->dimensions]=ival; + s->dimensions++; + } + | arraydcl ',' INTVALUE {$$=$1; s=(Symbol *) $1; + if(s->dimensionsdimlimit[s->dimensions]=ival; + s->dimensions++; + } else + error("too many dimensions"); + } + + + +fieldstmt: FIELDSYM cross intvalue {setchannel(ival);} ',' fieldlist {notyetimpl();} + +fieldlist: intvalue ASSYM variable + | fieldlist ',' intvalue ASSYM variable + ; + +forstmt: FORSYM IDENTIFIER {forinit($2);} '=' expression {forexpr($5);} + TOSYM expression {forlimit($8);} step + ; + +step : STEPSYM expression {forstep($2);} + | /*EMPTY*/ {emcode("loc","1"); forstep(INTTYPE);} + ; + +nextstmt: NEXTSYM IDENTIFIER {nextstmt($2);} + | NEXTSYM { nextstmt(0);} + | nextstmt ',' IDENTIFIER { nextstmt($3);} + +getstmt: getput {emcode("loc",itoa(0)); + emcode("cal",$1); + emcode("asp",EMINTSIZE);} + | getput ',' intvalue + { /* position seek pointer first*/ + emcode("loc",itoa(ival)); + emcode("cal",$1); + emcode("asp",EMINTSIZE); + } +getput: GETSYM cross intvalue { setchannel(ival); $$= (YYSTYPE)"$_getrec";} + | PUTSYM cross intvalue { setchannel(ival); $$= (YYSTYPE)"$_putsym";} + +gosubstmt: GOSUBSYM INTVALUE {gosubstmt(ival);} + +returnstmt: RETURNSYM {returnstmt();} + +ifstmt: IFSYM expression {$1=ifstmt($2);} thenpart + {$1=thenpart($1);} elsepart {elsepart($1);} + ; + +thenpart: THENSYM INTVALUE {gotostmt(ival);} + | THENSYM stmts + | GOTOSYM INTVALUE {gotostmt(ival);} + ; +elsepart: ELSESYM INTVALUE {gotostmt(ival);} + | ELSESYM stmts + | /* empty */ + ; + +inputstmt: INPUTSYM semiprompt readlist + | INPUTSYM '#' intvalue {setchannel(ival);}',' readlist + ; + +semiprompt : semi STRVALUE ';' { loadstr($2); prompt(1);} + | semi STRVALUE ',' { loadstr($2); prompt(0);} + | /*EMPTY*/ { setchannel(-1); + emcode("cal","$_qstmark");} + +semi : ';' | /* empty */ ; + +letstmt: LETSYM {e1=where();} variable {e2=where();} + '=' expression {assign($3,$6);} + | {e1=where();} variable {e2=where();} + '=' expression {assign($2,$5);} + +lineinputstmt: LINESYM INPUTSYM semiprompt {setchannel(-1);} variable {linestmt($5);} + | LINESYM '#' intvalue {setchannel(ival);} ',' variable {linestmt($6);} + ; + +readlist: readelm + | readlist ',' readelm + ; +readelm: variable {readelm($1);} + +lsetstmt: LSETSYM variable '=' expression {notyetimpl();} + +midstmt: MIDSYM '$' midparms '=' expression + { emcode("cal","$_midstmt"); + emcode("asp",EMINTSIZE); + emcode("asp",EMINTSIZE); + emcode("asp",EMPTRSIZE); + emcode("asp",EMPTRSIZE);} + +midparms: '(' midfirst midsec midthird ')' + +midfirst: expression { conversion($1,STRINGTYPE); } +midsec: ',' expression { conversion($2,INTTYPE); } +midthird: ',' expression { conversion($2,INTTYPE); } + | /* empty */ { emcode("loc","-1");} + +exceptionstmt: ONSYM ERRORSYM GOTOSYM INTVALUE {exceptstmt(ival);} + +ongotostmt: ONSYM expression + GOSUBSYM constantlist {ongosubstmt($2);} + | ONSYM expression + GOTOSYM constantlist {ongotostmt($2);} + +constantlist: INTVALUE {jumpelm(ival);} + | constantlist ',' INTVALUE { jumpelm(ival);} + +openstmt: OPENSYM mode openchannel expression + { conversion($4,STRINGTYPE); openstmt(0);} + | OPENSYM mode openchannel + expression {conversion($4,STRINGTYPE);} + INTVALUE { openstmt(ival);} + +openchannel: cross INTVALUE ',' { setchannel(ival);} + +mode : expression ',' {conversion($1,STRINGTYPE);} + | ',' { emcode("lae","_iomode");} + ; + +optionstmt: OPTIONSYM BASESYM intvalue { optionbase($3);} + +printstmt: PRINTSYM {setchannel(-1);emcode("cal","$_nl");} + | PRINTSYM file format printlist + { if( $4) emcode("cal","$_nl");} +file : '#' intvalue ',' {setchannel(ival);} + | /* empty */ {setchannel(-1);} + ; +format : USINGSYM STRVALUE ';' { loadstr($2);} + | USINGSYM variable ';' { + if($2!=STRINGTYPE) error("string variable expected");} + | /* empty */ {formatstring=0;} + +printlist: expression { printstmt($1); $$=1;} + | ',' { zone(0); $$=0;} + | ';' { zone(1); $$=0;} + | printlist expression { printstmt($2); $$=1;} + | printlist ',' { zone(1);$$=0;} + | printlist ';' { zone(0);$$=0;} + ; +pokestmt: POKESYM expression ',' expression {pokestmt($2,$4);} + ; +randomizestmt: RANDOMIZESYM + { emcode("cal","$_randomize");} + | RANDOMIZESYM expression + { conversion($2,INTTYPE); + emcode("cal","$_setrandom"); + emcode("asp",EMINTSIZE);} + +readstmt: READSYM {setchannel(0);} variable { readelm($3);} + | readstmt ',' variable { readelm($3);} + +restorestmt: RESTORESYM INTVALUE { restore(ival);} + | RESTORESYM { restore(0);} + +swapstmt: SWAPSYM variable ',' variable { swapstmt($2,$4);} + +whilestmt: WHILESYM {whilestart();} expression {whiletst($3);} + ; + +wendstmt : WENDSYM {wend();} + +writestmt: WRITESYM {setchannel(-1);emcode("cal","$_wrnl");} + | WRITESYM file writelist {emcode("cal","$_wrnl");} + ; + +writelist: expression {writestmt($1,0);} + | writelist ',' expression {writestmt($3,1);} + ; + +cross: '#' | /* empty */ + +intvalue: INTVALUE + ; + +variable: identifier { $$=loadaddr($1);} + | indexed ')' {$$=endarrayload();} + | ERRSYM {emcode("lae","_errsym"); $$= INTTYPE;} + | ERLSYM {emcode("lae","_erlsym"); $$= INTTYPE;} + ; +indexed : identifier '(' {newarrayload($1);} + expression {loadarray($4); $$=$1;} + | indexed ',' expression {loadarray($3); $$=$1;} + ; + + +expression: negation + | negation BOOLOP expression {$$=boolop($1,$3,$2);} + +negation: NOTSYM compare {$$=boolop($2,0,NOTSYM);} + | compare + ; +compare : sum + | sum RELOP sum {$$=relop($1,$3,$2);} + | sum '=' sum {$$=relop($1,$3,'=');} + +sum : term + | term '-' sum {$$=plusmin($1,$3,'-');} + | term '+' sum {$$=plusmin($1,$3,'+');} +term : factor + | factor '^' factor {$$=power($1,$3);} + | factor '*' term {$$=muldiv($1,$3,'*');} + | factor '\\' term {$$=muldiv($1,$3,'\\');} + | factor '/' term {$$=muldiv($1,$3,'/');} + | factor MODSYM term {$$=muldiv($1,$3,MODSYM);} +factor : INTVALUE {$$=loadint(ival);} + | '(' expression ')' {$$=$2;} + | '-' factor { $$=negate($2);} + | FLTVALUE {$$=loaddbl(dval);} + | STRVALUE {$$=loadstr($1);} + | variable {$$=loadvar($1);} + | INKEYSYM '$' { emcode("cal","$_inkey"); + emcode("lfr",EMPTRSIZE); + $$= STRINGTYPE; + } + | VARPTR '(' '#' intvalue ')' { warning("Not supported"); $$=INTTYPE;} + | FUNCTION {$$= callfcn($1,0);} + | FUNCTION '(' cross exprlist')' {$$=callfcn($1,$4);} + | funcname { $$=fcnend($1);} + | funcname funccall ')' { $$=fcnend($1,$2);} + | MIDSYM '$' midparms + { emcode("cal","$_mid"); + emcode("asp",itoa($3)); + emcode("lfr",EMPTRSIZE); + $$= STRINGTYPE; + } + | INPUTSYM '$' '(' expression inputtail + { + emcode("cal","$_inpfcn"); + emcode("asp",EMINTSIZE); + emcode("asp",EMINTSIZE); + emcode("asp",EMPTRSIZE); + $$= STRINGTYPE; + } +inputtail: ',' expression ')' { conversion($2,INTTYPE); $$= INTTYPE;} + | ',' '#' expression ')' { conversion($3,INTTYPE); $$= INTTYPE;} + | ')' { emcode("loc","-1"); $$= INTTYPE;} + +funcname: FUNCTID {$$=fcncall($1);} + +funccall: '(' expression { callparm(0,$2); $$=1;} + | funccall ',' expression { callparm($1,$3); $$=$1+1;} + +identifier: IDENTIFIER { dcltype($1); $$=$1;} + +exprlist: expression { typetable[0]= $1; $$=1;} + | exprlist ',' expression { typetable[$1]=$3;$$=$1+1;} + +%% +#include "lex.c" diff --git a/lang/basic/src.old/bem.c b/lang/basic/src.old/bem.c new file mode 100644 index 000000000..a3be73033 --- /dev/null +++ b/lang/basic/src.old/bem.c @@ -0,0 +1,38 @@ +#include "bem.h" + +/* Author: M.L. Kersten +** +** This is the main routine for the BASIC-EM frontend. +** Program parameters are decoded, the BASIC program is parsed +** and compiled to an executable program +** +** Bem expects at least three parameters. One ending with '.i' is considered +** the input to the compiler, '.e' denotes the file to be generated, +** and the last name denotes the name of the user supplied file name. +** The latter is used to store the data entries. +** Additional flags may be supplied, see parseparms. +*/ + +char *program; + +char datfname[MAXFILENAME] ; +char tmpfname[MAXFILENAME] ; + +char *inpfile, *outfile; +main(argc,argv) +int argc; +char **argv; +{ + extern int errorcnt; + + /* parseparams */ + parseparams(argc,argv); + /* initialize the system */ + initialize(); + /* compile source programs */ + compileprogram(program); + linewarnings(); + if( errorcnt) exit(-1); + /* process em object files */ + simpleprogram(); +} diff --git a/lang/basic/src.old/bem.h b/lang/basic/src.old/bem.h new file mode 100644 index 000000000..9a70c3ade --- /dev/null +++ b/lang/basic/src.old/bem.h @@ -0,0 +1,59 @@ +#include +#include +#include + +/* Author: M.L. Kersten +** Here all the global objects are defined. +*/ +#include "symbols.h" +#include "graph.h" +#include "y.tab.h" + +#define POINTERSIZE 4 +#define MAXINT 32768 +#define MININT -32767 +#define EMINTSIZE "EM_WSIZE" +#define EMPTRSIZE "EM_PSIZE" +#define EMFLTSIZE "EM_DSIZE" + +#define MAXPIECES 100 +#define MAXFILENAME 200 + +#define CHANNEL 0 +#define THRESHOLD 40 /* for splitting blocks */ + +extern char *program; /* name of source program */ +extern char *inpfile; /* input tko compiler */ +extern char *outfile; /* output from compiler */ + +extern char datfname[MAXFILENAME]; /* data statements file */ +extern char tmpfname[MAXFILENAME]; /* temporary statements file */ + +extern FILE *emfile; /* EM output file */ +extern FILE *datfile; /* data file */ +extern FILE *tmpfile; /* compiler temporary */ +extern FILE *yyin; /* Compiler input */ + +extern int endofinput; +extern int wflag; +extern int hflag; +extern int traceflag; +extern int yydebug; +extern int yylineno; +extern int listing; +extern int nolins; +extern int threshold; +extern int debug; +extern int tronoff; + +extern int emlinecount; /* counts lines on tmpfile */ +extern int dataused; +extern int typetable[10]; /* parameters to standard functions */ + +extern Linerecord *currline; + + +extern char *itoa(); +extern char *datalabel(); +extern char *instrlabel(); +extern char *typesize(); diff --git a/lang/basic/src.old/compile.c b/lang/basic/src.old/compile.c new file mode 100644 index 000000000..0ff30393b --- /dev/null +++ b/lang/basic/src.old/compile.c @@ -0,0 +1,13 @@ +#include "bem.h" + +/* compile the next program in the list */ + +FILE *yyin; + +compileprogram() +{ + + while( getline()) + yyparse(); + fclose(yyin); +} diff --git a/lang/basic/src.old/eval.c b/lang/basic/src.old/eval.c new file mode 100644 index 000000000..fb609cd16 --- /dev/null +++ b/lang/basic/src.old/eval.c @@ -0,0 +1,437 @@ +#include "bem.h" + +/* Here you find all routines to evaluate expressions and + generate code for assignment statements +*/ + +exprtype(ltype,rtype) +int ltype,rtype; +{ + /* determine the result type of an expression */ + if( ltype== STRINGTYPE || rtype==STRINGTYPE) + { + if( ltype!=rtype) + error("type conflict, string expected"); + return( STRINGTYPE); + } + /* take maximum */ + if( ltype': genbool("zgt"); break; + case '=': genbool("zeq"); break; + case NESYM: genbool("zne"); break; + case LESYM: genbool("zle"); break; + case GESYM: genbool("zge"); break; + default: error("relop:unexpected operator"); + } + return(INTTYPE); +} +plusmin(ltype,rtype,operator) +int ltype,rtype,operator; +{ + int result; + result= exprtype(ltype,rtype); + + if( result== STRINGTYPE) + { + if( operator== '+') + { + emcode("cal","$_concat"); + emcode("asp",EMPTRSIZE); + emcode("asp",EMPTRSIZE); + emcode("lfr",EMPTRSIZE); + } else error("illegal operator"); + } else { + extraconvert(ltype,result,rtype); + conversion(rtype,result); + if( result== INTTYPE) + { + if( operator=='+') + emcode("adi",EMINTSIZE); + else emcode("sbi",EMINTSIZE); + } else{ + if( operator=='+') + emcode("adf",EMFLTSIZE); + else emcode("sbf",EMFLTSIZE); + } + } + return(result); +} +muldiv(ltype,rtype,operator) +int ltype,rtype,operator; +{ + int result; + + result= exprtype(ltype,rtype); + if(operator==MODSYM || operator== '\\') result=INTTYPE; + extraconvert(ltype,result,rtype); + conversion(rtype,result); + if( result== INTTYPE) + { + if( operator=='/') + { + result= DOUBLETYPE; + extraconvert(ltype,result,rtype); + conversion(rtype,result); + emcode("dvf",EMFLTSIZE); + } else + if( operator=='\\') + emcode("dvi",EMINTSIZE); + else + if( operator=='*') + emcode("mli",EMINTSIZE); + else + if( operator==MODSYM) + emcode("rmi",EMINTSIZE); + else error("illegal operator"); + } else{ + if( operator=='/') + emcode("dvf",EMFLTSIZE); + else + if( operator=='*') + emcode("mlf",EMFLTSIZE); + else error("illegal operator"); + } + return(result); +} +negate(type) +int type; +{ + switch(type) + { + case INTTYPE: + emcode("ngi",EMINTSIZE); break; + case DOUBLETYPE: + case FLOATTYPE: + emcode("ngf",EMFLTSIZE); break; + default: + error("Illegal operator"); + } + return(type); +} +power(ltype,rtype) +int ltype,rtype; +{ + extraconvert(ltype,DOUBLETYPE,rtype); + conversion(rtype,DOUBLETYPE); + emcode("cal","$_power"); + emcode("asp",EMFLTSIZE); + emcode("asp",EMFLTSIZE); + emcode("lfr",EMFLTSIZE); + return(DOUBLETYPE); +} +char *typesize(ltype) +int ltype; +{ + switch( ltype) + { + case INTTYPE: + return(EMINTSIZE); + case FLOATTYPE: + case DOUBLETYPE: + return(EMFLTSIZE); + case STRINGTYPE: + return(EMPTRSIZE); + default: + error("typesize:unexpected"); + if(debug) printf("type received %d\n",ltype); + } + return(EMINTSIZE); +} +/* +loadptr(s) +Symbol *s; +{ + if( POINTERSIZE==WORDSIZE) + fprintf(tmpfile," loe l%d\n",s->symalias); + else + if( POINTERSIZE== 2*WORDSIZE) + fprintf(tmpfile," lde l%d\n",s->symalias); + else error("loadptr:unexpected pointersize"); +} +*/ +char *typestring(type) +int type; +{ + switch(type) + { + case INTTYPE: + return(EMINTSIZE); + case FLOATTYPE: + case DOUBLETYPE: + return(EMFLTSIZE); + case STRINGTYPE: + return(EMPTRSIZE); + default: + error("typestring: unexpected type"); + } + return("0"); +} +loadvar(type) +int type; +{ + /* load a simple variable its address is on the stack*/ + emcode("loi",typestring(type)); + return(type); +} +loadint(value) +int value; +{ + emcode("loc",itoa(value)); + return(INTTYPE); +} +loaddbl(value) +double value; +{ + int index; + index= genlabel(); + fprintf(emfile,"l%d\n bss 8,%fF8,1\n",index,value); + emcode("lae",datalabel(index)); + emcode("loi",EMFLTSIZE); + return(DOUBLETYPE); +} +loadstr(value) +int value; +{ + emcode("lae",datalabel(value)); + return(STRINGTYPE); +} +loadaddr(s) +Symbol *s; +{ + extern Symbol *fcn; + int i,j; + + if(debug) printf("load %s %d\n",s->symname,s->symtype); + if( s->symalias>0) + emcode("lae",datalabel(s->symalias)); + else{ + j= -s->symalias; + if(debug) printf("load parm %d\n",j); + fprintf(tmpfile," lal "); + for(i=fcn->dimensions;i>j;i--) + fprintf(tmpfile,"%s+",typesize(fcn->dimlimit[i-1])); + fprintf(tmpfile,"0\n"); + emlinecount++; + /* + emcode("lal",datalabel(fcn->dimalias[-s->symalias])); + */ + } + return(s->symtype); +} +assign(type,lt) +int type,lt; +{ + extern int e1,e2; + conversion(lt,type); + exchange(e1,e2); + /* address is on stack already */ + emcode("sti",typestring(type) ); +} +storevar(lab,type) +int lab,type; +{ + /*store value back */ + emcode("lae",datalabel(lab)); + emcode("sti",typestring(type)); +} + +/* maintain a stack of array references */ +int dimstk[MAXDIMENSIONS], dimtop= -1; +Symbol *arraystk[MAXDIMENSIONS]; + +newarrayload(s) +Symbol *s; +{ + if( dimtopdimensions==0) + { + s->dimensions=1; + defarray(s); + } + dimstk[dimtop]= s->dimensions; + arraystk[dimtop]= s; + emcode("lae",datalabel(s->symalias)); +} +endarrayload() +{ + return(arraystk[dimtop--]->symtype); +} +loadarray(type) +int type; +{ + int dim; + Symbol *s; + + if( dimtop<0 || dimtop>=MAXDIMENSIONS) + fatal("too many nested array references"); + /* index expression is on top of stack */ + s=arraystk[dimtop]; + dim= dimstk[dimtop]; + if( dim==0) + { + error("too many indices"); + dimstk[dim--]=0; + return; + } + conversion(type,INTTYPE); + dim--; + /* first check index range */ + fprintf(tmpfile," lae r%d\n",s->dimalias[dim]); + emlinecount++; + emcode("rck",EMINTSIZE); + emcode("lae",datalabel(s->dimalias[dim])); + emcode("aar",EMINTSIZE); + dimstk[dimtop]--; +} +storearray(type) +{ + /* used only in let statement */ + extern int e1,e2; + exchange(e1,e2); + emcode("sti",typestring(type)); +} diff --git a/lang/basic/src.old/func.c b/lang/basic/src.old/func.c new file mode 100644 index 000000000..e55332d67 --- /dev/null +++ b/lang/basic/src.old/func.c @@ -0,0 +1,214 @@ +#include "bem.h" + +/* expression types for predefined functions are assembled */ +int typetable[10]; +int exprlimit; + +/* handle all predefined functions */ +#define cv(X) conversion(type,X); pop=X +#define cl(X) emcode("cal",X); + +parm(cnt) +int cnt; +{ + if( cnt> exprlimit) + error("Not enough arguments"); + if( cnt < exprlimit) + error("Too many arguments"); +} + +callfcn(fcnnr,cnt) +int fcnnr,cnt; +{ + int pop=DOUBLETYPE; + int res=DOUBLETYPE; + int type; + + + type= typetable[0]; + exprlimit=cnt; + if(debug) printf("fcn=%d\n",fcnnr); + switch(fcnnr) + { + case ABSSYM: cv(DOUBLETYPE); + cl("$_abr"); + parm(1); + break; + case ASCSYM: cv(STRINGTYPE); + cl("$_asc"); res=INTTYPE; + parm(1); + break; + case ATNSYM: cv(DOUBLETYPE); + cl("$_atn"); + parm(1); + break; + case CDBLSYM: cv(DOUBLETYPE); return(DOUBLETYPE);; + case CHRSYM: cv(INTTYPE); + cl("$_chr"); res=STRINGTYPE; + parm(1); + break; + case CSNGSYM: + cv(DOUBLETYPE); return(DOUBLETYPE); + case CINTSYM: cv(INTTYPE); return(INTTYPE); + case COSSYM: cv(DOUBLETYPE); + cl("$_cos"); + parm(1); + break; + case CVISYM: cv(STRINGTYPE); + cl("$_cvi"); res=INTTYPE; + parm(1); + break; + case CVSSYM: cv(STRINGTYPE); + cl("$_cvd"); res=DOUBLETYPE; + parm(1); + break; + case CVDSYM: cv(STRINGTYPE); + cl("$_cvd"); res=DOUBLETYPE; + parm(1); + break; + case EOFSYM: + if( cnt==0) + { + res= INTTYPE; + pop= INTTYPE; + emcode("loc","-1"); + } else cv(INTTYPE); + cl("$_ioeof"); res=INTTYPE; + break; + case EXPSYM: cv(DOUBLETYPE); + cl("$_exp"); + parm(1); + break; + case FIXSYM: cv(DOUBLETYPE); + cl("$_fix"); res=INTTYPE; + parm(1); + break; + case INPSYM: + case LPOSSYM: + case FRESYM: pop=0; + warning("function not supported"); + parm(1); + break; + case HEXSYM: cv(INTTYPE); + cl("$_hex"); res=STRINGTYPE; + parm(1); + break; + case OUTSYM: + case INSTRSYM: cv(DOUBLETYPE); + cl("$_instr"); res=STRINGTYPE; + parm(1); + break; + case INTSYM: cv(DOUBLETYPE); + cl("$_fcint"); + parm(1); + break; + case LEFTSYM: parm(2); + extraconvert(type, STRINGTYPE,typetable[1]); + type= typetable[1]; + cv(INTTYPE); + cl("$_left"); res=STRINGTYPE; + emcode("asp",EMPTRSIZE); + emcode("asp",EMINTSIZE); + emcode("lfr",EMPTRSIZE); + return(STRINGTYPE); + case LENSYM: cv(STRINGTYPE); + cl("$_len"); res=INTTYPE; + parm(1); + break; + case LOCSYM: cv(INTTYPE); + cl("$_loc"); res=INTTYPE; + parm(1); + break; + case LOGSYM: cv(DOUBLETYPE); + cl("$_log"); + parm(1); + break; + case MKISYM: cv(INTTYPE); + cl("$_mki"); res=STRINGTYPE; + parm(1); + break; + case MKSSYM: cv(DOUBLETYPE); + cl("$_mkd"); res=STRINGTYPE; + parm(1); + break; + case MKDSYM: cv(DOUBLETYPE); + cl("$_mkd"); res=STRINGTYPE; + parm(1); + break; + case OCTSYM: cv(INTTYPE); + cl("$_oct"); res=STRINGTYPE; + parm(1); + break; + case PEEKSYM: cv(INTTYPE); + cl("$_peek"); res=INTTYPE; + parm(1); + break; + case POSSYM: emcode("asp",typestring(type)); + emcode("exa","_pos"); + emcode("loe","_pos"); + return(INTTYPE); + case RIGHTSYM: parm(2); + extraconvert(type, STRINGTYPE,typetable[1]); + type= typetable[1]; + cv(INTTYPE); + cl("$_right"); res=STRINGTYPE; + emcode("asp",EMINTSIZE); + emcode("asp",EMPTRSIZE); + emcode("lfr",EMPTRSIZE); + return(STRINGTYPE); + case RNDSYM: if( cnt==1) pop=type; else pop=0; + cl("$_rnd"); res= DOUBLETYPE; + break; + case SGNSYM: cv(DOUBLETYPE); + cl("$_sgn"); res=INTTYPE; + parm(1); + break; + case SINSYM: cv(DOUBLETYPE); + cl("$_sin"); + parm(1); + break; + case SPACESYM: cv(INTTYPE); + cl("$_space"); res=STRINGTYPE; + parm(1); + break; + case SPCSYM: cv(INTTYPE); + cl("$_spc"); res=0; + parm(1); + break; + case SQRSYM: cv(DOUBLETYPE); + cl("$_sqt"); + parm(1); + break; + case STRSYM: cv(DOUBLETYPE); + cl("$_str"); + parm(1); + break; + case STRINGSYM: cv(STRINGTYPE); + cl("$_string"); res=STRINGTYPE; + parm(1); + break; + case TABSYM: cv(INTTYPE); + cl("$_tab"); res=0; + parm(1); + break; + case TANSYM: cv(DOUBLETYPE); + cl("$_tan"); + parm(1); + break; + case VALSYM: cv(STRINGTYPE); + cl("$atol"); res=INTTYPE; + parm(1); + break; + case VARPTRSYM: cv(DOUBLETYPE); + cl("$_valptr"); + parm(1); + break; + default: error("unknown function"); + } + if(pop) + emcode("asp",typestring(pop)); + if(res) + emcode("lfr",typestring(res)); + return(res); +} + diff --git a/lang/basic/src.old/gencode.c b/lang/basic/src.old/gencode.c new file mode 100644 index 000000000..16aa0030c --- /dev/null +++ b/lang/basic/src.old/gencode.c @@ -0,0 +1,561 @@ +#include "bem.h" + +/* Here we find all routines dealing with pure EM code generation */ + +static int emlabel=1; +genlabel() { return(emlabel++);} + + +genemlabel() +{ + int l; + + l=genlabel(); + fprintf( emfile,"l%d\n",l); + return(l); +} +genrom() +{ + int l; + l= genemlabel(); + fprintf(emfile," rom "); + return(l); +} + +where() +{ + return(emlinecount); +} +exchange(blk1,blk2) +int blk1,blk2; +{ + /* exchange assembler blocks */ + if(debug) printf("exchange %d %d %d\n",blk1,blk2,emlinecount); + fprintf(tmpfile," exc %d,%d\n",blk2-blk1,emlinecount-blk2); + emlinecount++; +} + +/* routines to manipulate the tmpfile */ +int emlinecount; /* count number of lines generated */ + /* this value can be used to generate EXC */ +int tronoff=0; +newemblock(nr) +int nr; +{ + /* save location on tmpfile */ + currline->offset= ftell(tmpfile); + fprintf(tmpfile,"%d\n",currline->emlabel); + fprintf(tmpfile," lin %d\n",nr); + emlinecount += 2; + if( tronoff || traceflag) emcode("cal","$_trace"); +} + +emcode(operation,params) +char *operation,*params; +{ + fprintf(tmpfile," %s %s\n",operation,params); + emlinecount++; +} +/* Handle data statements */ +int dataused=0; +List *datalist=0; +datastmt() +{ + List *l,*l1; + l= (List *) salloc(sizeof(List)); + l->linenr= currline->linenr; + l->emlabel= (long) ftell(datfile); + if( datalist==0) + { + datalist=l; + datfile= fopen(datfname,"w"); + if( datfile==NULL) fatal("improper file creation permission"); + }else{ + l1= datalist; + while(l1->nextlist) l1= l1->nextlist; + l1->nextlist=l; + } + + dataused=1; +} +datatable() +{ + List *l; + int line=0; + + /* called at end to generate the data seek table */ + fprintf(emfile," exa _seektable\n"); + fprintf(emfile,"_seektable\n"); + l= datalist; + while(l) + { + fprintf(emfile," rom %d,%d\n", l->linenr,line++); + l= l->nextlist; + } + fprintf(emfile," rom 0,0\n"); +} + +/* ERROR and exception handling */ +exceptstmt(lab) +int lab; +{ + /* exceptions to subroutines are supported only */ + extern int gosubcnt; + List *l; + + emcode("loc",itoa(gosubcnt)); + l= (List *) gosublabel(); + l->emlabel= gotolabel(lab); + emcode("cal","$_trpset"); + emcode("asp",EMINTSIZE); +} + +errorstmt(exprtype) +int exprtype; +{ + /* convert expression to a valid error number */ + /* obtain the message and print it */ + emcode("cal","$error"); + emcode("asp",typesize(exprtype)); +} + +/* BASIC IO */ +openstmt(recsize) +int recsize; +{ + emcode("loc",itoa(recsize)); + emcode("cal","$_opnchn"); + emcode("asp",EMPTRSIZE); + emcode("asp",EMPTRSIZE); + emcode("asp",EMINTSIZE); +} + + +printstmt(exprtype) +int exprtype; +{ + switch(exprtype) + { + case INTTYPE: + emcode("cal","$_prinum"); + emcode("asp",typestring(INTTYPE)); + break; + case FLOATTYPE: + case DOUBLETYPE: + emcode("cal","$_prfnum"); + emcode("asp",typestring(DOUBLETYPE)); + break; + case STRINGTYPE: + emcode("cal","$_prstr"); + emcode("asp",EMPTRSIZE); + break; + case 0: /* result of tab function etc */ + break; + default: + error("printstmt:unexpected"); + } +} +zone(i) +int i; +{ + if( i)emcode("cal","$_zone"); +} +writestmt(exprtype,comma) +int exprtype,comma; +{ + if( comma) emcode("cal","$_wrcomma"); + switch(exprtype) + { + case INTTYPE: + emcode("cal","$_wrint"); + break; + case FLOATTYPE: + case DOUBLETYPE: + emcode("cal","$_wrint"); + break; + case STRINGTYPE: + emcode("cal","$_wrstr"); + break; + default: + error("printstmt:unexpected"); + } + emcode("asp",EMPTRSIZE); +} +restore(lab) +int lab; +{ + /* save this information too */ + + emcode("loc",itoa(0)); + emcode("cal","$_setchannel"); + emcode("asp",EMINTSIZE); + emcode("loc",itoa(lab)); + emcode("cal","$_restore"); + emcode("asp",EMINTSIZE); +} +prompt(qst) +int qst; +{ + setchannel(-1); + emcode("cal","$_prstr"); + emcode("asp",EMPTRSIZE); + if(qst) emcode("cal","$_qstmark"); +} +linestmt(type) +int type; +{ + if( type!= STRINGTYPE) + error("String variable expected"); + emcode("cal","$_rdline"); + emcode("asp",EMPTRSIZE); +} +readelm(type) +int type; +{ + switch(type) + { + case INTTYPE: + emcode("cal","$_readint"); + break; + case FLOATTYPE: + case DOUBLETYPE: + emcode("cal","$_readflt"); + break; + case STRINGTYPE: + emcode("cal","$_readstr"); + break; + default: + error("readelm:unexpected type"); + } + emcode("asp",EMPTRSIZE); +} + +/* Swap exchanges the variable values */ +swapstmt(ltype,rtype) +int ltype, rtype; +{ + if( ltype!= rtype) + error("Type mismatch"); + else + switch(ltype) + { + case INTTYPE: + emcode("cal","$_intswap"); + break; + case FLOATTYPE: + case DOUBLETYPE: + emcode("cal","$_fltswap"); + break; + case STRINGTYPE: + emcode("cal","$_strswap"); + break; + default: + error("swap:unexpected"); + } + emcode("asp",EMPTRSIZE); + emcode("asp",EMPTRSIZE); +} + +/* input/output handling */ +setchannel(val) +int val; +{ /* obtain file descroption */ + emcode("loc",itoa(val)); + emcode("cal","$_setchannel"); + emcode("asp",EMINTSIZE); +} +/* The if-then-else statements */ +ifstmt(type) +int type; +{ + /* This BASIC follows the True= -1 rule */ + int nr; + + nr= genlabel(); + if( type == INTTYPE) + emcode("zeq",instrlabel(nr)); + else + if( type == FLOATTYPE) + { + emcode("lae","fltnull"); + emcode("loi",EMFLTSIZE); + emcode("cmf",EMFLTSIZE); + emcode("zeq",instrlabel(nr)); + } + else error("Integer or Float expected"); + return(nr); +} +thenpart( elselab) +int elselab; +{ + int nr; + + nr=genlabel(); + emcode("bra",instrlabel(nr)); + fprintf(tmpfile,"%d\n",elselab); + emlinecount++; + return(nr); +} +elsepart(lab)int lab; +{ + fprintf(tmpfile,"%d\n",lab); emlinecount++; +} +/* generate code for the for-statement */ +#define MAXFORDEPTH 20 +struct FORSTRUCT{ + Symbol *loopvar; /* loop variable */ + int initaddress; + int limitaddress; + int stepaddress; + int fortst; /* variable limit test */ + int forinc; /* variable increment code */ + int forout; /* end of loop */ +} fortable[MAXFORDEPTH]; +int forcnt= -1; + +forinit(s) +Symbol *s; +{ + int type; + struct FORSTRUCT *f; + + dcltype(s); + type= s->symtype; + forcnt++; + if( (type!=INTTYPE && type!=FLOATTYPE && type!=DOUBLETYPE) || + s->dimensions) + error("Illegal loop variable"); + if( forcnt >=MAXFORDEPTH) + error("too many for statements"); + else{ + f=fortable+forcnt; + f->loopvar=s; + f->fortst=genlabel(); + f->forinc=genlabel(); + f->forout=genlabel(); + /* generate space for temporary objects */ + f->initaddress= dclspace(type); + f->limitaddress= dclspace(type); + f->stepaddress= dclspace(type); + } +} +forexpr(type) +int type; +{ + /* save start value of loop variable in a save place*/ + /* to avoid clashing with final value and step expression */ + int result; + result= fortable[forcnt].loopvar->symtype; + conversion(type,result); + storevar(fortable[forcnt].initaddress, result); +} +forlimit(type) +int type; +{ + /* save the limit value too*/ + int result; + result= fortable[forcnt].loopvar->symtype; + conversion(type,result); + storevar(fortable[forcnt].limitaddress, result); +} +forskipped(f) +struct FORSTRUCT *f; +{ + int type; + type= f->loopvar->symtype; + /* evaluate lower bound times sign of step */ + emcode("lae",datalabel(f->initaddress)); + loadvar(type); + conversion(type,DOUBLETYPE); + emcode("lae",datalabel(f->stepaddress)); + loadvar(type); + conversion(type,DOUBLETYPE); + emcode("cal","$_sgn"); + emcode("asp",EMFLTSIZE); + emcode("lfr",EMINTSIZE); + conversion(INTTYPE,DOUBLETYPE); + emcode("mlf",EMFLTSIZE); + /* evaluate higher bound times sign of step */ + emcode("lae",datalabel(f->limitaddress)); + loadvar(type); + conversion(type,DOUBLETYPE); + emcode("lae",datalabel(f->stepaddress)); + loadvar(type); + conversion(type,DOUBLETYPE); + emcode("cal","$_sgn"); + emcode("asp",EMFLTSIZE); + emcode("lfr",EMINTSIZE); + conversion(INTTYPE,DOUBLETYPE); + emcode("mlf",EMFLTSIZE); + /* skip condition */ + emcode("cmf",EMFLTSIZE); + emcode("zgt",instrlabel(f->forout)); +} +forstep(type) +int type; +{ + int result; + int varaddress; + struct FORSTRUCT *f; + + f= fortable+forcnt; + result= f->loopvar->symtype; + varaddress= f->loopvar->symalias; + conversion(type,result); + storevar(f->stepaddress, result); + /* all information available, generate for-loop head */ + /* test for ingoring loop */ + forskipped(f); + /* set initial value */ + emcode("lae",datalabel(f->initaddress)); + loadvar(result); + emcode("lae",datalabel(varaddress)); + emcode("sti",typestring(result)); + emcode("bra",instrlabel(f->fortst)); + /* increment loop variable */ + fprintf(tmpfile,"%d\n",f->forinc); + emlinecount++; + emcode("lae",datalabel(varaddress)); + loadvar(result); + emcode("lae",datalabel(f->stepaddress)); + loadvar(result); + if(result == INTTYPE) + emcode("adi",EMINTSIZE); + else emcode("adf",EMFLTSIZE); + emcode("lae",datalabel(varaddress)); + emcode("sti",typestring(result)); + /* test boundary */ + fprintf(tmpfile,"%d\n",f->fortst); + emlinecount++; + emcode("lae",datalabel(varaddress)); + loadvar(result); + emcode("lae",datalabel(f->limitaddress)); + loadvar(result); + if(result == INTTYPE) + emcode("cmi",EMINTSIZE); + else emcode("cmf",EMFLTSIZE); + emcode("zgt",instrlabel(f->forout)); +} +nextstmt(s) +Symbol *s; +{ + if(forcnt>MAXFORDEPTH || forcnt<0 || + ( s && s!= fortable[forcnt].loopvar)) + error("NEXT without FOR"); + else{ + /* address of variable is on top of stack ! */ + emcode("bra",instrlabel(fortable[forcnt].forinc)); + fprintf(tmpfile,"%d\n",fortable[forcnt].forout); + forcnt--; + } +} + +pokestmt(type1,type2) +int type1,type2; +{ + conversion(type1,INTTYPE); + conversion(type2,INTTYPE); + emcode("cal","$_poke"); + emcode("asp",EMINTSIZE); + emcode("asp",EMINTSIZE); +} + +/* generate code for the while statement */ +#define MAXDEPTH 20 + +int whilecnt, whilelabels[MAXDEPTH][2]; /*0=head,1=out */ + +whilestart() +{ + whilecnt++; + if( whilecnt==MAXDEPTH) + fatal("too many nestings"); + /* gendummy label in graph */ + newblock(-1); + whilelabels[whilecnt][0]= currline->emlabel; + whilelabels[whilecnt][1]= genlabel(); + fprintf(tmpfile,"%d\n", whilelabels[whilecnt][0]); + emlinecount++; +} +whiletst(exprtype) +int exprtype; +{ + /* test expression type */ + conversion(exprtype,INTTYPE); + fprintf(tmpfile," zeq *%d\n",whilelabels[whilecnt][1]); + emlinecount++; +} +wend() +{ + if( whilecnt<1) + error("not part of while statement"); + else{ + fprintf(tmpfile," bra *%d\n",whilelabels[whilecnt][0]); + fprintf(tmpfile,"%d\n",whilelabels[whilecnt][1]); + emlinecount++; + emlinecount++; + whilecnt--; + } +} + +/* generate code for the final version */ +prologcode() +{ + /* generate the EM prolog code */ + fprintf(emfile,"fltnull\n con 0,0,0,0\n"); + fprintf(emfile,"dummy2\n con 0,0,0,0\n"); + fprintf(emfile,"tronoff\n con 0\n"); + fprintf(emfile,"dummy1\n con 0,0,0,0\n"); + fprintf(emfile," exa _iomode\n_iomode\n rom \"O\"\n"); + fprintf(emfile," exa _errsym\n"); + fprintf(emfile,"_errsym\n bss 2,0,1\n"); + fprintf(emfile," exa _erlsym\n"); + fprintf(emfile,"_erlsym\n bss 2,0,1\n"); +} + +prolog2() +{ + fprintf(emfile," exp $main\n"); + fprintf(emfile," pro $main,0\n"); + fprintf(emfile," mes 3\n"); + fprintf(emfile," mes 9,0\n"); + /* Trap handling */ + fprintf(emfile," cal $_ini_trp\n"); + fprintf(emfile," exa trpbuf\n"); + fprintf(emfile," lae trpbuf\n"); + fprintf(emfile," cal $setjmp\n"); + fprintf(emfile," asp 4\n"); + fprintf(emfile," lfr %s\n",EMINTSIZE); + fprintf(emfile," dup %s\n",EMINTSIZE); + fprintf(emfile," zeq *0\n"); + fprintf(emfile," lae returns\n"); + fprintf(emfile," csa %s\n",EMINTSIZE); + fprintf(emfile,"0\n"); + fprintf(emfile," asp EM_WSIZE\n"); + /* when data lists are used open its file */ + if( dataused) + { + fprintf(emfile," loc 0\n"); + fprintf(emfile," cal $_setchannel\n"); + fprintf(emfile," asp EM_WSIZE\n"); + fprintf(emfile,"datfname\n rom \"%s\"\n", datfname); + fprintf(emfile," lae datfname\n"); + fprintf(emfile," cal $_opnchn\n"); + fprintf(emfile," asp EM_PSIZE\n"); + } + datatable(); +} + +epilogcode() +{ + /* finalization code */ + int nr; + nr= genlabel(); + fprintf(emfile," bra *%d\n",nr); + genreturns(); + fprintf(emfile,"%d\n",nr); + fprintf(emfile," loc 0\n"); + fprintf(emfile," cal $_hlt\n"); + fprintf(emfile," end 0\n"); + fprintf(emfile," mes 4,4\n"); +} diff --git a/lang/basic/src.old/graph.c b/lang/basic/src.old/graph.c new file mode 100644 index 000000000..7801da73e --- /dev/null +++ b/lang/basic/src.old/graph.c @@ -0,0 +1,279 @@ +#include "bem.h" + +List *forwardlabel=0; + +/* Line management is handled here */ + +Linerecord *srchline(nr) +int nr; +{ + Linerecord *l; + for(l=firstline;l && l->linenr<=nr;l= l->nextline) + if( l->linenr== nr) return(l); + return(0); +} +List *srchforward(nr) +int nr; +{ + List *l; + for(l=forwardlabel;l ;l=l->nextlist) + if( l->linenr== nr) return(l); + return(0); +} +linewarnings() +{ + List *l; + extern int errorcnt; + l= forwardlabel; + while(l) + { + if( !srchline(l->linenr)) + { + printf("ERROR: line %d not defined\n",l->linenr); + errorcnt++; + } + l=l->nextlist; + } +} + +newblock(nr) +int nr; +{ + Linerecord *l; + List *frwrd; + + if( debug) printf("newblock at %d\n",nr); + if( nr>0 && currline && currline->linenr>= nr) + { + if( debug) printf("old line:%d\n",currline->linenr); + error("Lines out of sequence"); + } + + frwrd=srchforward(nr); + if( frwrd && debug) printf("forward found %d\n",frwrd->emlabel); + l= srchline(nr); + if( l) + { + error("Line redefined"); + nr= -genlabel(); + } + + /* make new EM block structure */ + l= (Linerecord *) salloc(sizeof(*l)); + l->emlabel= frwrd? frwrd->emlabel: genlabel(); + l->linenr= nr; + /* save offset into tmpfile too */ + l->offset = (long) ftell(tmpfile); + l->codelines= emlinecount; + + /* insert this record */ + if( firstline) + { + currline->nextline=l; + l->prevline= currline; + lastline= currline=l; + } else + firstline = lastline =currline=l; +} + +gotolabel(nr) +int nr; +{ + /* simulate a goto statement in the line record table */ + Linerecord *l1; + List *ll; + + if(debug) printf("goto label %d\n",nr); + /* update currline */ + ll= (List *) salloc( sizeof(*ll)); + ll-> linenr=nr; + ll-> nextlist= currline->gotos; + currline->gotos= ll; + + /* try to generate code */ + l1= srchline(nr); + if( (ll=srchforward(nr))!=0) + nr= ll->emlabel; + else + if( l1==0) + { + /* declare forward label */ + if(debug) printf("declare forward %d\n",nr); + ll= (List *) salloc( sizeof(*ll)); + ll->emlabel= genlabel(); + ll-> linenr=nr; + ll->nextlist= forwardlabel; + forwardlabel= ll; + nr= ll->emlabel; + } else + nr= l1->emlabel; + return(nr); +} +gotostmt(nr) +int nr; +{ + emcode("bra",instrlabel(gotolabel(nr))); +} +/* GOSUB-return, assume that proper entries are made to subroutines + only. The return statement is triggered by a fake constant label */ + +List *gosubhead, *gotail; +int gosubcnt=1; + +List *gosublabel() +{ + List *l; + int n; + + l= (List *) salloc(sizeof(List)); + l->nextlist=0; + l->emlabel=genlabel(); + if( gotail){ + gotail->nextlist=l; + gotail=l; + } else gotail= gosubhead=l; + gosubcnt++; + return(l); +} +gosubstmt(lab) +int lab; +{ + List *l; + int nr,n; + + n=gosubcnt; + l= gosublabel(); + nr=gotolabel(lab); + emcode("loc",itoa(n)); /*return index */ + emcode("cal","$_gosub"); /* administer legal return */ + emcode("asp",EMINTSIZE); + emcode("bra",instrlabel(nr)); + fprintf(tmpfile,"%d\n",l->emlabel); + emlinecount++; +} +genreturns() +{ + int nr; + nr= genlabel(); + fprintf(emfile,"returns\n"); + fprintf(emfile," rom *%d,1,%d\n",nr,gosubcnt-1); + while( gosubhead) + { + fprintf(emfile," rom *%d\n",gosubhead->emlabel); + gosubhead= gosubhead->nextlist; + } + fprintf(emfile,"%d\n",nr); + fprintf(emfile," loc 1\n"); + fprintf(emfile," cal $error\n"); +} +returnstmt() +{ + emcode("cal","$_retstmt"); /* ensure legal return*/ + emcode("lfr",EMINTSIZE); + fprintf(tmpfile," lae returns\n"); + emlinecount++; + emcode("csa",EMINTSIZE); +} +/* compound goto-gosub statements */ +List *jumphead,*jumptail; +int jumpcnt; + +jumpelm(nr) +int nr; +{ + List *l; + + l= (List *) salloc(sizeof(List)); + l->emlabel= gotolabel(nr); + l->nextlist=0; + if( jumphead==0) jumphead= jumptail= l; + else { + jumptail->nextlist=l; + jumptail=l; + } + jumpcnt++; +} +ongotostmt(type) +int type; +{ + /* generate the code itself, index in on top of the stack */ + /* blurh, store the number of entries in the descriptor */ + int firstlabel; + int descr; + List *l; + /* create descriptor first */ + descr= genlabel(); + firstlabel=genlabel(); + fprintf(tmpfile,"l%d\n",descr); emlinecount++; + fprintf(tmpfile," rom *%d,1,%d\n",firstlabel,jumpcnt); emlinecount++; + l= jumphead; + while( l) + { + fprintf(tmpfile," rom *%d\n",l->emlabel); emlinecount++; + l= l->nextlist; + } + jumphead= jumptail=0; jumpcnt=0; + if(debug) printf("ongotst:%d labels\n", jumpcnt); + conversion(type,INTTYPE); + emcode("lae",datalabel(descr)); + emcode("csa",EMINTSIZE); + fprintf(tmpfile,"%d\n",firstlabel); emlinecount++; +} +ongosubstmt(type) +int type; +{ + List *l; + int firstlabel; + int descr; + /* create descriptor first */ + descr= genlabel(); + firstlabel=genlabel(); + fprintf(tmpfile,"l%d\n",descr); emlinecount++; + fprintf(tmpfile," rom *%d,1,%d\n",firstlabel,jumpcnt); emlinecount++; + l= jumphead; + while( l) + { + fprintf(tmpfile," rom *%d\n",l->emlabel); emlinecount++; + l= l->nextlist; + } + jumphead= jumptail=0; jumpcnt=0; + + l= (List *) salloc(sizeof(List)); + l->nextlist=0; + l->emlabel=firstlabel; + if( gotail){ + gotail->nextlist=l; + gotail=l; + } else gotail= gosubhead=l; + /* save the return point of the gosub */ + emcode("loc",itoa(gosubcnt)); + emcode("cal","$_gosub"); + emcode("asp",EMINTSIZE); + gosubcnt++; + /* generate gosub */ + conversion(type,INTTYPE); + emcode("lae",datalabel(descr)); + emcode("csa",EMINTSIZE); + fprintf(tmpfile,"%d\n",firstlabel); + emlinecount++; +} + +/* REGION ANALYSIS and FINAL VERSION GENERATION */ + +simpleprogram() +{ + char buf[512]; + int length; + + /* a small EM programs has been found */ + prologcode(); + prolog2(); + fclose(tmpfile); + tmpfile= fopen(tmpfname,"r"); + if( tmpfile==NULL) + fatal("tmp file disappeared"); + while( (length=fread(buf,1,512,tmpfile)) != 0) + fwrite(buf,1,length,emfile); + epilogcode(); + unlink(tmpfname); +} diff --git a/lang/basic/src.old/initialize.c b/lang/basic/src.old/initialize.c new file mode 100644 index 000000000..26fd2e70b --- /dev/null +++ b/lang/basic/src.old/initialize.c @@ -0,0 +1,23 @@ +#include "bem.h" + +/* generate temporary files etc */ + +FILE *emfile; +FILE *tmpfile; +FILE *datfile; + +initialize() +{ + sprintf(tmpfname,"/tmp/abc%d",getpid()); + strcpy(datfname,program); + strcat(datfname,".d"); + yyin= fopen(inpfile,"r"); + emfile= fopen(outfile,"w"); + tmpfile= fopen(tmpfname,"w"); + if( yyin==NULL || emfile== NULL || tmpfile== NULL ) + fatal("Improper file permissions"); + fillkex(); /* initialize symbol table */ + fprintf(emfile,"#\n"); + fprintf(emfile," mes 2,EM_WSIZE,EM_PSIZE\n"); + initdeftype(); /* set default symbol declarers */ +} diff --git a/lang/basic/src.old/parsepar.c b/lang/basic/src.old/parsepar.c new file mode 100644 index 000000000..e0bfdae65 --- /dev/null +++ b/lang/basic/src.old/parsepar.c @@ -0,0 +1,51 @@ +#include "bem.h" + +int listing; /* -l listing required */ +int debug; /* -d compiler debugging */ +int wflag=1; /* -w no warnings */ +int hflag=0; /* -h to split EM program */ +int traceflag=0; /* generate line tracing code */ +int nolins=0; /* generate no LIN statements */ + +parseparams(argc,argv) +int argc; +char **argv; +{ + int i,j,k; + char *ext; + + j=k=0; + if(argc< 4) + { + fprintf(stderr,"usage %s .i .e \n", argv[0]); + exit(-1); + } + for(i=1;inextline) + if( lr->linenr == lnr) + lr->fixed=1; +} + +fixblock(l) +List *l; +{ + while(l) + { + fix(l->linenr); + l=l->nextlist; + } +} +phase1() +{ + /* copy all offloaded blocks */ + Linerecord *lr, *lf,*lr2; + int blksize; + + lf= lr= firstline; + blksize= lr->codelines; + while( lr) + { + if( lr->fixed){ + if( !lf->fixed && blksize>threshold) + { + /*move block */ + if(debug) printf("%d %d->%d moved\n", + blksize,lf->linenr, lr->linenr); + } + lf= lr; + blksize= lr->codelines; + } + lr= lr->nextline; + } +} +phase2() +{ + /* copy main procedure */ + prolog2(); + epilogcode(); +} +split() +{ + /* selectively copy the intermediate code to procedures */ + Linerecord *lr; + + if( debug) printf("split EM code using %d\n",threshold); + + /* First consolidate the goto's and caller's */ + lr= firstline; + while(lr) + { + fixblock(lr->callers); + fixblock(lr->gotos); + lr= lr->nextline; + } + + /* Copy the temporary file piecewise */ + prologcode(); + phase1(); + phase2(); +} diff --git a/lang/basic/src.old/symbols.c b/lang/basic/src.old/symbols.c new file mode 100644 index 000000000..4e79fb035 --- /dev/null +++ b/lang/basic/src.old/symbols.c @@ -0,0 +1,285 @@ +#include "bem.h" +/* Symboltable management module */ + +int deftype[128]; /* default type declarer */ + /* which may be set by OPTION BASE */ + +initdeftype() +{ + int i; + for(i='a';i<='z';i++) deftype[i]= DOUBLETYPE; + for(i='A';i<='Z';i++) deftype[i]= DOUBLETYPE; +} + +int indexbase=0; /* start of array subscripting */ + +Symbol *firstsym = NIL; +Symbol *alternate = NIL; + +Symbol *srchsymbol(str) +char *str; +{ + Symbol *s; + /* search symbol table entry or create it */ + if(debug) printf("srchsymbol %s\n",str); + s=firstsym; + while(s) + { + if( strcmp(s->symname,str)==0) return(s); + s= s->nextsym; + } + /* search alternate list */ + s=alternate; + while(s) + { + if( strcmp(s->symname,str)==0) return(s); + s= s->nextsym; + } + /* not found, create an emty slot */ + s= (Symbol *) salloc(sizeof(Symbol)); + s->symtype= DEFAULTTYPE; + s->nextsym= firstsym; + s->symname= (char *) salloc(strlen(str)+1); + strcpy(s->symname,str); + firstsym= s; + if(debug) printf("%s allocated\n",str); + return(s); +} + +dcltype(s) +Symbol *s; +{ + /* type declarer */ + int type; + if( s->isparam) return; + type=s->symtype; + if(type==DEFAULTTYPE) + /* use the default rule */ + type= deftype[*s->symname]; + /* generate the emlabel too */ + if( s->symalias==0) + s->symalias= dclspace(type); + s->symtype= type; + if(debug) printf("symbol set to %d\n",type); +} +dclarray(s) +Symbol *s; +{ + int i; int size; + + if( s->symtype==DEFAULTTYPE) s->symtype= DOUBLETYPE; + if(debug) printf("generate space and descriptors for %d\n",s->symtype); + if(debug) printf("dim %d\n",s->dimensions); + s->symalias= genlabel(); + /* generate descriptors */ + size=1; + for(i=0;idimensions;i++) + s->dimalias[i]= genlabel(); + for(i=s->dimensions-1;i>=0;i--) + { + fprintf(emfile,"l%d\n rom %d,%d,%d*%s\n", + s->dimalias[i], + indexbase, + s->dimlimit[i]-indexbase, + size, typesize(s->symtype)); + size = size* (s->dimlimit[i]+1-indexbase); + } + if(debug) printf("size=%d\n",size); + /* size of stuff */ + fprintf(emfile,"l%d\n bss %d*%s,0,1\n", + s->symalias,size,typesize(s->symtype)); + /* Generate the range check descriptors */ + for( i= 0; idimensions;i++) + fprintf(emfile,"r%d\n rom %d,%d\n", + s->dimalias[i], + indexbase, + s->dimlimit[i]); + +} +defarray(s) +Symbol *s; +{ + /* array is used without dim statement, set default limits */ + int i; + for(i=0;idimensions;i++) s->dimlimit[i]=10; + dclarray(s); +} +dclspace(type) +{ + int nr; + nr= genemlabel(); + switch( type) + { + case STRINGTYPE: + fprintf(emfile," bss %s,0,1\n",EMPTRSIZE); + break; + case INTTYPE: + fprintf(emfile," bss %s,0,1\n",EMINTSIZE); + break; + case FLOATTYPE: + case DOUBLETYPE: + fprintf(emfile," bss 8,0.0F %s,1\n",EMFLTSIZE); + break; + } + return(nr); +} + +/* SOME COMPILE TIME OPTIONS */ +optionbase(ival) +int ival; +{ + if( ival<0 || ival>1) + error("illegal option base value"); + else indexbase=ival; +} + +setdefaulttype(type) +int type; +{ + extern char *cptr; + char first,last,i; + + /* handcrafted parser for letter ranges */ + if(debug) printf("deftype:%s\n",cptr); + while( isspace(*cptr)) cptr++; + if( !isalpha(*cptr)) + error("letter expected"); + first= *cptr++; + if(*cptr=='-') + { + /* letter range */ + cptr++; + last= *cptr; + if( !isalpha(last)) + error("letter expected"); + else for(i=first;i<=last;i++) deftype[i]= type; + cptr++; + } else deftype[first]=type; + if( *cptr== ',') + { + cptr++; + setdefaulttype(type); /* try again */ + } +} + +Symbol *fcn; + +newscope(s) +Symbol *s; +{ + if(debug) printf("new scope for %s\n",s->symname); + alternate= firstsym; + firstsym = NIL; + fcn=s; + s->isfunction=1; + if( fcn->dimensions) + error("Array redeclared"); + if( fcn->symtype== DEFAULTTYPE) + fcn->symtype=DOUBLETYPE; +} +/* User defined functions */ +heading( ) +{ + char procname[50]; + sprintf(procname,"$_%s",fcn->symname); + emcode("pro",procname); + if( fcn->symtype== DEFAULTTYPE) + fcn->symtype= DOUBLETYPE; +} +fcnsize(s) +Symbol *s; +{ + /* generate portable function size */ + int i; + for(i=0;idimensions;i++) + fprintf(tmpfile,"%s+",typesize(fcn->dimlimit[i])); + fprintf(tmpfile,"0\n"); emlinecount++; +} +endscope(type) +int type; +{ + Symbol *s; + + if( debug) printf("endscope"); + conversion(type,fcn->symtype); + emcode("ret", typestring(fcn->symtype)); + /* generate portable EM code */ + fprintf(tmpfile," end "); + fcnsize(fcn); + s= firstsym; + while(s) + { + firstsym = s->nextsym; + free(s); + s= firstsym; + } + firstsym= alternate; + alternate = NIL; + fcn=NIL; +} + +dclparm(s) +Symbol *s; +{ + int i,size=0; + if( s->symtype== DEFAULTTYPE) + s->symtype= DOUBLETYPE; + s->isparam=1; + fcn->dimlimit[fcn->dimensions]= s->symtype; + fcn->dimensions++; + /* + OLD STUFF + for(i=fcn->dimensions;i>0;i--) + fcn->dimalias[i]= fcn->dimalias[i-1]; + */ + /*fcn->parmsize += typesize(s->symtype);*/ + /* fcn->dimalias[0]= -typesize(s->symtype)-fcn->dimalias[1];*/ + s->symalias= -fcn->dimensions; + if( debug) printf("parameter %d offset %d\n",fcn->dimensions-1,-size); +} +/* unfortunately function calls have to be stacked as well */ +#define MAXNESTING 50 +Symbol *fcntable[MAXNESTING]; +int fcnindex= -1; + +fcncall(s) +Symbol *s; +{ + if( !s->isfunction) + error("Function not declared"); + else{ + fcn= s; + fcnindex++; + fcntable[fcnindex]=s; + } +} +fcnend(fcntype, parmcount) +int fcntype, parmcount; +{ + int type; + /* check number of arguments */ + if( parmcount dimensions) + error("not enough parameters"); + if( parmcount >fcn->dimensions) + error("too many parameters"); + fprintf(tmpfile," cal $_%s\n",fcn->symname); + emlinecount++; + fprintf(tmpfile," asp "); + fcnsize(fcn); + emcode("lfr",typestring(fcn->symtype)); + type= fcn->symtype; + fcnindex--; + if( fcnindex>=0) + fcn= fcntable[fcnindex]; + return(type); +} +callparm(ind,type) +int ind,type; +{ + if( fcnindex<0) error("unexpected parameter"); + + if( ind >= fcn->dimensions) + error("too many parameters"); + else + conversion(type,fcn->dimlimit[ind]); +} diff --git a/lang/basic/src.old/util.c b/lang/basic/src.old/util.c new file mode 100644 index 000000000..b53007156 --- /dev/null +++ b/lang/basic/src.old/util.c @@ -0,0 +1,74 @@ +#include "bem.h" + +#define abs(X) (X>=0?X:-X) +/* Miscelaneous routines can be found here */ + +int errorcnt; + +warning(str) +char *str; +{ + printf("WARNING:%s\n",str); +} +error(str) +char *str; +{ + extern int listing,yylineno; + if( !listing) printf("LINE %d:",yylineno); + printf("ERROR:%s\n",str); + errorcnt++; +} +fatal(str) +char *str; +{ + printf("FATAL:%s\n",str); + exit(-1); +} +notyetimpl() +{ + printf("WARNING: not yet implemented\n"); +} +illegalcmd() +{ + printf("WARNING: illegal command\n"); +} +char *itoa(i) +int i; +{ + static char buf[30]; + sprintf(buf,"%d",i); + return(buf); +} +char *instrlabel(i) +int i; +{ + static char buf[30]; + sprintf(buf,"*%d",i); + return(buf); +} +char *datalabel(i) +int i; +{ + static char buf[30]; + if( i>0) + sprintf(buf,"l%d",i); + else sprintf(buf,"%d",-i); + return(buf); +} + +char *salloc(length) +int length; +{ + char *s,*c; + s=c= (char *) malloc(length); + while(length-->0)*c++ =0; + return(s); +} + +char * proclabel(str) +char *str; +{ + static char buf[50]; + sprintf(buf,"$%s",str); + return(buf); +} diff --git a/lang/basic/src.old/yywrap.c b/lang/basic/src.old/yywrap.c new file mode 100644 index 000000000..b08ecc0c7 --- /dev/null +++ b/lang/basic/src.old/yywrap.c @@ -0,0 +1,17 @@ +#include "bem.h" + +/* Author: M.L. Kersten +** yywrap is called upon encountering endoffile on yyin. +** when more input files are present, it moves to the next +** otherwise -1 is returned and simultaneous endofinput is set +*/ +int endofinput =0; + + +yywrap() +{ + if( fclose(yyin) == EOF) + fatal("fclose problems "); + /* check for next input file */ + return(-1); +}