/* Operations on reals and strings are pretty broken. This has been tested for integers only. TODO: - parameter passing for strings - equality checks for strings -- further string operations */ #include #include #include #include #include //----- constraints #define MAXTOKENS_PER_LINE 32 #define MAX_STRINGLENGTH 255 #define MAXLINES 10000 #define MAXVARS 1000 #define SIGVARCHARS 20 #define MAX_RECURSION 170000 //----- available libraries and options #define HAVECLOCKLIB 1 #undef HAVEMATHLIB #define TOKENDEBUG 1 //----- clock functions, require -lrt compilation long getclocktime() { #ifdef HAVECLOCKLIB struct timespec ts; (void) clock_gettime (0, &ts); return ts.tv_sec * 1000 + ts.tv_nsec / 1E6; #else return 0L; #endif } //----- C extensions typedef enum bool { FALSE=0, TRUE=1 } boolean; #define real double // float #define FLOATSCAN "%lf" // of "%f" for simple floats #define integer int // or long... but be careful #define round(x) ((int)(x)) typedef char *string; typedef char sstring[ MAX_STRINGLENGTH ]; #define stralloc() ((string) malloc( (MAX_STRINGLENGTH+1)*sizeof(char) )) #define strfree( s ) (free(s)) #define MAXSTAX 512 typedef struct Stakk { short sbase[ MAXSTAX ]; int smax; int sptr; } stakk; typedef struct Dyn_Stakk { short *sbase; int smax; int sptr; } dynstakk; #define SMake( s, i ) ((s).sbase = malloc( ((s).smax = i) * sizeof(*((s).sbase)) )) // create dyn. stack #define SInit( s ) ((s).sptr = 0, (s).smax = MAXSTAX) // clear static stack #define SPush( s, n ) ((s).sbase[ (s).sptr++ ] = (short) (n)) // put element on top #define SPop( s ) ((s).sbase[ --(s).sptr ]) // take top element #define STop( s ) ((s).sbase[ (s).sptr-1 ]) // read top element without removing #define SDrop( s ) (--(s).sptr) // just remove top element #define SSize( s ) ((s).smax) // allotted space #define SKill( s ) (free( (s).sbase )) // dynamic only!! #define SCheck( s ) ((s).smax-(s).sptr) // free space on stack //----- composite and enumerative data types typedef enum TokenType { c_Nihil, c_Paenitent, c_Age, c_Cantus, c_Amen, c_Redde, c_Clandestinus, c_Incipit, c_Finit, c_Obscura, c_Illumina, c_Illuminando, c_Ora, c_Si, c_Nisi, c_Dum, c_Numera, c_Proxim, // loops c_Alias, c_Ab, c_De, c_Ad, c_Et, c_Vel, c_Non, c_Sine, c_Cum, c_Initio, c_Usque, c_Apud, c_Op_Add, c_Op_Mul, c_Op_Sub, c_Op_Div, c_Op_Mod, // ops c_Radix, c_Sinus, c_Cosinus, c_Tangens, c_ArcSinus, c_ArcCosinus, c_ArcTangens, c_Fiat, c_Equ, c_Neq, c_Gtr, c_Lsr, // ops2 c_Geq, c_Leq, c_Klauf, c_Klzu, c_Comment, c_Lege, c_Scribe, c_Frange, // IO c_CInt, c_CReal, c_CString, c_VInt, c_VReal, c_VString, c_Label, c_Invocetur, c_Comma, c_Colon, c_Semicolon, c_Ego, c_Te, c_Absolvo, c_Impossibilis } tokentype; static char *token_repr[] = { "", "PAENITENTIAM", "AGE", "CANTUS", "AMEN", "REDDE", "CLANDESTINUS", "INCIPIT", "FINIT", "OBSCURA", "ILLUMINA", "ILLUMINANDO", "ORA", "SI", "NISI", "DUM", "NUMERABIS", "PROCEDE", "ALIAS", "AB", "DE", "AD", "ET", "VEL", "NON", "SINE", "CUM", "INITIO", "USQUE", "APUD", "+", "*", "-", "/", "MOD", "RADIX", "SINUS", "COSINUS", "TANGENS", "ARCUSSINUS", "ARCUSCOSINUS", "ARCUSTANGENS", "FIAT", "EQUALIS", "INEQUALIS", "MAIOR", "MINOR", "MAIEQU", "MINEQU", "(", ")", "#", "LEGE", "SCRIBE", "FRANGE", " int const ", " real const ", " str const ", " int var (%) ", " real var (!) ", " str var ($) ", " label ", "INVOCETUR", ",", ":", ";", "EGO", "TE", "ABSOLVO", "how did you do that?" }; typedef struct TokenStruct { // any token from the input stream int t_sourceline; tokentype t_type; integer t_int; real t_real; string t_string; string t_varname; unsigned int t_varindex; // for swifter access #ifdef TOKENDEBUG unsigned short t_n; #endif } tokenstruct, *tokenstructptr; #ifdef TOKENDEBUG static unsigned short TOQOUNT = 0; #define TOQNUM( n ) ((n)->t_n) #else #define TOQNUM( n ) (n) #endif typedef struct TokenArray { int ta_size, ta_used; tokenstructptr ta_data; } tokenarray, *tokenarrayptr; typedef struct Variable { boolean v_used; char v_name[ SIGVARCHARS ]; integer v_int; real v_real; char v_string[ MAX_STRINGLENGTH ]; } variab, *variabptr, vartab[ MAXVARS ]; typedef struct Label { // a procedure boolean l_used; tokentype l_type; // type of return value of procedure char l_name[ SIGVARCHARS ]; // name of procedure int l_index; // access index struct { tokentype p_type; // parameter type char p_name[ SIGVARCHARS ]; // parameter name unsigned int p_varindex; // parameters's index } l_params[ MAXTOKENS_PER_LINE ]; // for each parameter unsigned int l_paramc; // number of parameters int l_start; // here it begins } label, *labelptr, labtab[ MAXVARS ]; //---------------- The Cathol VM // registers: static int PC = 0, // program counter VM_LINUM = 0, // program size (lines) ENTRY = 0; // program entry point static tokenstruct RETREG; // for return from functions static tokenarrayptr list; // all the tokens, arranged in a rectangular array // symbol tables static vartab IVartab, RVartab, SVartab; // structure for enumerative loops typedef struct Looplet { int L_pc; variabptr L_runner; int L_max; } looplet, *loddl; static looplet LOOPS[ MAXSTAX ]; static int LOOPC = 0; // branching typedef struct Dichotomy { short what_if_true, what_if_not; } dichotomy, dichotab[ MAXLINES ], *dichoptr; static dichotab jumpT; #define UNDEFINED_JUMP ((short)(-1)) // procedures static labtab labelT, labelII; static dynstakk callstack; // obscuration (see below) typedef struct Tee { // element of a linked list struct Tee *Tprev, *Tnext; int Tamount; // how many elements of data... variabptr Tvar; // ...does this point to struct Dvandva *Tfast; // here the indices and types of the stored variables are deposited } tee, *teeptr; static tee Tanchor = { NULL, NULL, 0, NULL }, *Tptr = &Tanchor; // for storage strategy, also see below typedef struct Dvandva { int vinx; tokentype vtyp; } dvandva; //------ prototyping ----------------------------- static boolean stringcomp( string s1, string s2 ); static boolean stringcomplim( string s1, string s2, int max ); static void stringcopy( string s1, string s2 ); static void stringcopylim( string s1, string s2, int max ); static int split_up( string sourc, int linumber, tokenarrayptr dest ); static void clear_ta( tokenarrayptr l ); static void remove_ta( tokenarrayptr l ); static void dump_tokenarray( tokenarrayptr l ); static void glob_obscure( int *argv, tokentype *ttyv, int argc ); static void glob_obsc_dummy( void ); static void glob_illuminate( void ); static teeptr free_tee( teeptr t ); static teeptr new_tee( teeptr t ); static real _eval_real( tokenstructptr *first, int used ); static int _eval_int( tokenstructptr *first, int used ); static string _eval_str( tokenstructptr *first, int used ); static real eval_real( tokenstructptr first, int size, int used ); static int eval_int( tokenstructptr first, int size, int used ); static string eval_str( tokenstructptr first, int size, int used ); static void callproc( label proc, int argc, tokenstructptr argv ); static void amenproc( void ); static boolean execute_line( int this_line, int linum ); //----------------------------------- //------ faster C library replacements static boolean stringcomp( string s1, string s2 ) { register char *c1 = s1, *c2 = s2; while (*c1) if (*c1++ != *c2++) return FALSE; return (*c1++ == *c2++); // this also tests for equal length :-) } static boolean stringcomplim( string s1, string s2, int max ) { register char *c1 = s1, *c2 = s2; while (*c1 && max-->0) if (*c1++ != *c2++) return FALSE; return (*c1++ == *c2++); } static void stringcopy( string s1, string s2 ) { // copy s1 to s2 register char *c1 = s1, *c2 = s2; while (*c1) if (!(*c2++ = *c1++)) break; *c2 ='\0'; // don't forget terminal null } static void stringcopylim( string s1, string s2, int max ) { register char *c1 = s1, *c2 = s2; while (*c1 && max-->0) if (!(*c2++ = *c1++)) return; *c2 ='\0'; // don't forget terminal null } static void strappend( string main, string add, int max ) { int i = 0; while (i < max && *main) main++; // advance to end of string while (i < max && *add) *main++ = *add++; *main = '\0'; // don't forget terminal null } //------ The scanner. --------------------------------- /* split_up takes a source string, the line number of this string, and an array of tokens or rather a pointer to a piece of memory where tokens may be stored. */ static int split_up( string sourc, int linumber, tokenarrayptr dest ) { // printf("split_up\n"); // first, see that the destination array is in proper form if (!sourc) return 0; // just skip such a line if (!strlen(sourc)) return 0; if (!dest) return -2; // mistake: array must be passed if (dest->ta_size < 0) return -3; // other mistake // printf("do it - 0x%08lx, 0x%08lx\n",dest, dest->ta_data); if (dest->ta_data) free( dest->ta_data ); if (!(dest->ta_data = (tokenstruct *) malloc( ((dest->ta_size=MAXTOKENS_PER_LINE)+1) * sizeof(tokenstruct) ))) return -4; // printf("so so... ta_size is now %i\n",dest->ta_size); // int charc = 0; char su_hook[ MAX_STRINGLENGTH ]; int killa; for ( killa = 0; killa < MAX_STRINGLENGTH; killa++ ) su_hook[ killa ] = '\0'; boolean quotemode = FALSE; for ( charc = 0; charc <= strlen( sourc ); charc++ ) { // caution: must be null terminated char su_ch = *(sourc+charc); if (quotemode) { // read in string, ignore delimiters if (su_ch == '\"') { // final " // add token dest->ta_data[(dest->ta_used)].t_type = c_CString; // is a string constant dest->ta_data[(dest->ta_used)].t_varname = NULL; if (!(dest->ta_data[(dest->ta_used)].t_string = stralloc())) return -5; // allocate memory or cause some error // copy and clear buffer // printf("Assigning %s to tadest[%i]\n",su_hook,dest->ta_used); for ( killa = 0; killa < MAX_STRINGLENGTH; killa++ ) { dest->ta_data[(dest->ta_used)].t_string[ killa ] = su_hook[ killa ]; su_hook[ killa ] = '\0'; } dest->ta_data[ (dest->ta_used)++ ].t_sourceline = linumber; quotemode = FALSE; } else { // further component of string: add it // ought to check for length here sprintf( su_hook, "%s%c", su_hook, su_ch ); } } else { // no quote mode, read in up to delimiter if (su_ch == ' ' || su_ch == '\t' || su_ch == '\r' || su_ch == '\n' || su_ch == '\f' || su_ch == '\0') { // whitespace detected label0815: if (strlen(su_hook) > 0) { // terminate nascent chain tokentype seeker; boolean tfound = FALSE; dest->ta_data[(dest->ta_used)].t_type = c_Nihil; for ( seeker = c_Nihil; seeker < c_Impossibilis; seeker++ ) { string sought = token_repr[ seeker ]; if (sought) if (strlen(sought)) { if (stringcomp( sought, su_hook )) { // token is cmd // printf("Token %s identified as %i\n",su_hook, seeker); dest->ta_data[(dest->ta_used)].t_type = seeker; dest->ta_data[(dest->ta_used)].t_varname = dest->ta_data[(dest->ta_used)].t_string = NULL; dest->ta_data[ (dest->ta_used)++ ].t_sourceline = linumber; tfound = TRUE; break; } } } // rof // if this is not a valid token... if (!tfound) { // printf("No valid token found for '%s'\n",su_hook); int mover; char valu[ MAX_STRINGLENGTH ]; switch (*su_hook) { case '!': // float var // printf("float var or const in '%s' suspected\n",su_hook); for ( mover = 1; mover <= strlen(su_hook); mover++ ) *(valu+mover-1) = *(su_hook+mover); // printf("\"%s\" - %c\n",valu,*valu); if ('0' <= *valu && *valu <= '9') { // const sscanf( valu, "%lf", &(dest->ta_data[(dest->ta_used)].t_real) ); // printf("[%i] is now (float)%lf\n",dest->ta_used,dest->ta_data[(dest->ta_used)].t_real); dest->ta_data[(dest->ta_used)].t_type = c_CReal; dest->ta_data[(dest->ta_used)++].t_sourceline = linumber; } else { // var dest->ta_data[(dest->ta_used)].t_varname = stralloc(); int n; for ( n=0; nta_data[(dest->ta_used)].t_varname[ n ] = valu[ n ]; dest->ta_data[(dest->ta_used)].t_type = c_VReal; dest->ta_data[(dest->ta_used)++].t_sourceline = linumber; } break; case '@': // subroutine call for ( mover = 1; mover <= strlen(su_hook); mover++ ) *(valu+mover-1) = *(su_hook+mover); dest->ta_data[(dest->ta_used)].t_varname = stralloc(); int n; for ( n=0; nta_data[(dest->ta_used)].t_varname[ n ] = valu[ n ]; dest->ta_data[(dest->ta_used)].t_type = c_Label; dest->ta_data[(dest->ta_used)++].t_sourceline = linumber; // printf("Call to sub '%s' in line %i\n", valu, linumber ); break; case '$': // string var or const for ( mover = 1; mover <= strlen(su_hook); mover++ ) *(valu+mover-1) = *(su_hook+mover); // add token dest->ta_data[(dest->ta_used)].t_type = c_VString; // is a string variable // allocate memory or cause some error: if (!(dest->ta_data[(dest->ta_used)].t_varname = stralloc())) return -8; // copy and clear buffer // printf("Assigning '%s' to tadest[%i]\n",su_hook,dest->ta_used); for ( killa = 0; killa < MAX_STRINGLENGTH; killa++ ) { dest->ta_data[(dest->ta_used)].t_varname[ killa ] = valu[ killa ]; su_hook[ killa ] = '\0'; } dest->ta_data[ (dest->ta_used)++ ].t_sourceline = linumber; break; case '%': // integer var (default assumption) for ( mover = 1; mover <= strlen(su_hook); mover++ ) *(valu+mover-1) = *(su_hook+mover); // printf("integer var or const in '%s' suspected\n",su_hook); // printf("\"%s\" - %c\n",valu,*valu); if ('0' <= *valu && *valu <= '9') { // const sscanf( valu, "%ld", &(dest->ta_data[(dest->ta_used)].t_int) ); // printf("[%i] is now (int)%li\n",dest->ta_used,dest->ta_data[(dest->ta_used)].t_int); dest->ta_data[(dest->ta_used)].t_type = c_CInt; dest->ta_data[(dest->ta_used)++].t_sourceline = linumber; } else { // var dest->ta_data[(dest->ta_used)].t_varname = stralloc(); int n; for ( n=0; nta_data[(dest->ta_used)].t_varname[ n ] = valu[ n ]; dest->ta_data[(dest->ta_used)].t_type = c_VInt; dest->ta_data[(dest->ta_used)++].t_sourceline = linumber; } break; default: { // without specification: may be intvar, int const, or float const boolean has_comma = FALSE; for ( mover = 0; mover <= strlen(su_hook); has_comma = has_comma || *(su_hook+mover)=='.' ) *(valu+mover) = *(su_hook+mover++); if ('0' <= *valu && *valu <= '9') { // const if (has_comma) { sscanf( valu, FLOATSCAN, &(dest->ta_data[(dest->ta_used)].t_real) ); dest->ta_data[(dest->ta_used)].t_type = c_CReal; // printf("real: %f\n",dest->ta_data[(dest->ta_used)].t_real); } else { sscanf( valu, "%ld", &(dest->ta_data[(dest->ta_used)].t_int) ); dest->ta_data[(dest->ta_used)].t_type = c_CInt; // printf("int: %i\n", dest->ta_data[(dest->ta_used)].t_int); } dest->ta_data[(dest->ta_used)++].t_sourceline = linumber; /* { // const sscanf( valu, "%ld", &(dest->ta_data[(dest->ta_used)].t_int) ); // printf("[%i] is now (int)%li\n",dest->ta_used,dest->ta_data[(dest->ta_used)].t_int); dest->ta_data[(dest->ta_used)].t_type = c_CInt; dest->ta_data[(dest->ta_used)++].t_sourceline = linumber; } */ } else { // var dest->ta_data[(dest->ta_used)].t_varname = stralloc(); int n; for ( n=0; nta_data[(dest->ta_used)].t_varname[ n ] = valu[ n ]; dest->ta_data[(dest->ta_used)].t_type = c_VInt; dest->ta_data[(dest->ta_used)++].t_sourceline = linumber; } break; } } // esac } // fi } // if strlen for ( killa = 0; killa < MAX_STRINGLENGTH; killa++ ) // clear nascent su_hook[ killa ] = '\0'; } else if (su_ch == '\"') { // su_hook[ 0 ] = '$'; su_hook[ 1 ] = '\0'; quotemode = TRUE; } else if (su_ch == '(' || su_ch == ')' || su_ch == '[' || su_ch == ']' || su_ch == '{' || su_ch == '}' || su_ch == '+' || su_ch == '-' || su_ch == '*' || su_ch == '/' || su_ch == ':' || su_ch == ',' || su_ch == ';' || su_ch == '#') { // special char if (strlen( su_hook )) { --charc; goto label0815; } else { // at beginning char sp[3]; sprintf( sp, "%c", su_ch ); tokentype seeker; boolean sfound = FALSE; dest->ta_data[(dest->ta_used)].t_type = c_Nihil; for ( seeker = c_Nihil; seeker < c_Impossibilis; seeker++ ) { char sought = *(token_repr[ seeker ]); if (*sp == sought) { // token is cmd // printf("now token %s identified as %i\n",sp, seeker); dest->ta_data[(dest->ta_used)].t_type = seeker; dest->ta_data[(dest->ta_used)].t_varname = dest->ta_data[(dest->ta_used)].t_string = NULL; dest->ta_data[ (dest->ta_used)++ ].t_sourceline = linumber; sfound = TRUE; break; } } // rof } // fi } else { // alphanumeric sprintf( su_hook, "%s%c", su_hook, su_ch ); } // if not whitespace } // if not quotemode } // rof return 0; } //------ Handling token arrays static void clear_ta( tokenarrayptr l ) { if (l) { l->ta_size = l->ta_used = 0; l->ta_data = NULL; } } static void remove_ta( tokenarrayptr l ) { if (l) { l->ta_size = l->ta_used = 0; if (l->ta_data) { free(l->ta_data); l->ta_data = NULL; } } } static void dump_tokenarray( tokenarrayptr l ) { printf( "\n\ttokenarray at 0x%08lx\n", l ); if (!l) return; printf( "\tta_size = %i\n", l->ta_size ); printf( "\tta_used = %i\n", l->ta_used ); printf( "\tta_data = 0x%08lx\n\n", l->ta_data ); int i; for ( i=0; ita_used; i++ ) { printf( "\n\t%3i\t#%03i (%02i: %8s) in line %3i: %8i,\t%f,\t0x%08lx,\t0x%08lx", i, l->ta_data[i].t_n, l->ta_data[i].t_type, token_repr[l->ta_data[i].t_type], l->ta_data[i].t_sourceline, l->ta_data[i].t_int, l->ta_data[i].t_real, l->ta_data[i].t_string, l->ta_data[i].t_varname ); if (l->ta_data[i].t_string) printf( "\t'%s'\t", l->ta_data[i].t_string); if (l->ta_data[i].t_type == c_VInt) printf( "\t%%" ); if (l->ta_data[i].t_type == c_VReal) printf( "\t!" ); if (l->ta_data[i].t_type == c_VString) printf( "\t$" ); if (l->ta_data[i].t_varname) printf( "%s", l->ta_data[i].t_varname); } printf("\n"); } #define ty( t, n ) (((n) >= (t)->ta_used)? c_Nihil: (t)->ta_data[ (n) ].t_type) #define TY( t, n ) (((n) >= (t).ta_used)? c_Nihil: (t).ta_data[ (n) ].t_type) //---------------- static void clear_jumptab( dichotab dt ) { int i; for ( i = 0; iv_used) { // found // printf("Found %s at 0x%08lx!\n",tn->v_name,tn->v_name); if (*(tn->v_name) == *desig) if (stringcomplim( tn->v_name, desig, SIGVARCHARS )) return tn; } else break; } printf("Not found!\n"); if (nv_used) { // found if (*(tn->v_name) == *desig) if (stringcomplim( tn->v_name, desig, SIGVARCHARS )) return n; } else { // enter it table[n].v_used = TRUE; register int sh; for ( sh = 0; sh<=SIGVARCHARS; sh++ ) table[n].v_name[ sh ] = desig[ sh ]; for ( sh = 0; sht_type, to_params->t_varname); for ( n=0; nl_used) { // found if (*(ii->l_name) == *lanam) if (stringcomplim( ii->l_name, lanam, SIGVARCHARS )) { printf( "Duplicate definition of %s in line %i is tabooized\n", lanam, linum ); exit(1); } } else break; } // we may enter it // printf( "Entering definition of %s in line %i at n=%i\n", lanam, linum, n ); iitab[n].l_used = TRUE; register int sh; for ( sh = 0; sh<=SIGVARCHARS; sh++ ) // remember the name iitab[n].l_name[ sh ] = lanam[ sh ]; iitab[n].l_type = retval; // remember the expected return type iitab[n].l_start = linum; // remember the address iitab[n].l_paramc = paramc; // printf("Now %i parameters\n", paramc); if (to_params) { int parc; for ( parc = 0; parc < paramc && parc < MAXTOKENS_PER_LINE; parc++ ) { // enter the parameter variables iitab[ n ].l_params[ parc ].p_type = to_params[ parc ].t_type; for ( sh = 0; sh <= SIGVARCHARS; sh++ ) { iitab[n].l_params[parc].p_name[sh] = to_params[parc].t_varname[sh]; } iitab[n].l_params[parc].p_varindex = to_params[parc].t_varindex; // must still be 0 :-) // printf("%s:%i\n",iitab[n].l_params[parc].p_name,iitab[n].l_params[parc].p_varindex); } } } /* The following routine may be invoked only after complete parsing, when all labels have been set. Otherwise no forward jumps are possible. Therefore, the interims label table has to be passed to this function. */ static int label2inx( labtab table, labtab interims_table, register string desig ) { register int n; // printf("Looking for %s in labtab...\n",desig); for ( n=0; nl_used) { // found // printf("\n%i is used: %s\n",n,lp->l_name); if (*(lp->l_name) == *desig) if (stringcomplim( lp->l_name, desig, SIGVARCHARS )) { break; } } else break; } if (nv_int) // for direct access from a variabptr: #define fast_var_int( v ) (access_x( IVartab, (v)->t_varindex )->v_int) #define fast_var_real( v ) (access_x( RVartab, (v)->t_varindex )->v_real) #define fast_var_str( v ) (access_x( SVartab, (v)->t_varindex )->v_string) // get a variabptrfrom name/index and type: #define varp_from_x( x, t ) ((t)==c_VInt?&(IVartab[(x)]):((t)==c_VReal?&(RVartab[(x)]):&(SVartab[(x)]))) #define varp_from_n( n, t ) ((t)==c_VInt?var_int(n):((t)==c_VReal?var_real(n):var_str(n))) static real var_real( string vname ) { variabptr v = access_v( RVartab, vname ); if (v) return v->v_real; else ; } /* For a discussion of how eval_int and eval_real are used to evaluate expressions, see the comments on eval_str. eval_int and eval_real are simpler in that they do not require handling of dynamic storage but otherwise rather similar. The processing strategy is as follows: FIAT a (2+3)*(4+5) a is an integer var, therefor eval_int is calles arguments: "(", "2", "+", "3", ")", "*", "(", "4", "+", "5", ")" "(" detected -> recursive call arguments: "2", "+", "3", ")", "*", "(", "4", "+", "5", ")" "2" detected -> r is set to 2 "+" detected -> recursive call to get other parameter arguments: "3", ")", "*", "(", "4", "+", "5", ")" "3" detected -> r' is set to 3 ")" detected -> quit eval, return r' other parameter is found to evaluate to 3 addition performed: r is now 5 argument list now reduced to "*", "(", "4", "+", "5", ")" "*" detected -> recursive call to get other parameter "(" detected -> recursive call arguments: "4", "+", "5", ")" "4" detected -> r'' is set to 4 "+" detected -> recursive call to get other parameter "5" detected -> r''' is set to 5 ")" detected -> quit eval, return r'' addition performed: r' is now 9 argument list now reduced to empty list (argc==0) quit eval, return r' other parameter is found to evaluate to 9 addition performed: r is now 45 return r evaluation is complete: 45 What about function calls? E.g. in FIAT fibres (@fibo (n-1))+(@fibo (n-2)) Whenever a function call is encountered, all the remaining tokens are considered as parameters for this function. So the line FIAT fibres @fibo (n-1) + @fibo (n-2) would implicitly evaluate to fibo( n-1 + fibo( n-2 ) ). Brackets around the function call are required to define bindings properly. In the example above, a recursive call is invoked to evaluate "@fibo (n-1))+(@fibo (n-2))". This is further analyzed as "@fibo" plus "(n-1))+(@fibo (n-2))", which again sparks off a recursive call to evaluate "n-1))+(@fibo (n-2))". This second call evaluates... in a complex manner... n and 1 and returns n-1 when it reaches the ")". In the primary recursion, the parameter list is now ")+(@fibo (n-2))". The primary recursion level is bent on finding parameters for the invocation of "@fibo", so it stores the value of n-1 as first parameter. Upon searching for a second parameter, however, it encounters ")". So @fibo is called, passing just the value of n-1 (which happens to match the parameters). The primary recursion level then terminates, returning the function value of @fibo so that the basic level can store this in r. The arglist has by now been reduced to "+(@fibo (n-2))", and upon perception of the "+" the basic level again initiates recursion in order to process "(@fibo (n-2))" and add the evaluate of this to r... There's a little refinement in this. The flag "have_had_atom" is used to check whether there has just been an evaluatble expression or not. In the former case, evaluation must be canceled and the rover rewound. E.g.: In the expression 2+3 7*8, we have the flag set after processing of 2. The next token is a "+" operator, which does not care about the flag and gets the next one after that. So after 2+3, it is set again. Then the subsequent token is "7", a CInt. Obeying the flag, _eval_int terminates, returning 5 and leaving 7*8 in waiting. This is important when functions with more than one parameter are called. Internally, values to be returned are always copied into RETREG. */ static int _eval_int( register tokenstructptr *rover, int used ) { // no operator precedence // printf("_eval_int( 0x%08lx, %i )\n",rover,used); register int r = 0; register boolean have_had_atom = FALSE; while (used>0) { // printf("\tused=%i\trover->t_type=<%s>\t->t_int=%i\n",used,token_repr[(*rover)->t_type],(*rover)->t_int); register tokentype tty = (*rover)->t_type; if (tty == c_CInt) { if (have_had_atom) { --*rover; break; } r = (*rover)->t_int; have_had_atom = TRUE; } else if (tty == c_VInt) { if (have_had_atom) { --*rover; break; } r = fast_var_int( *rover ); have_had_atom = TRUE; } else if (tty == c_CReal) { // convert real->int if (have_had_atom) { --*rover; break; } r = round( (*rover)->t_real ); have_had_atom = TRUE; } else if (tty == c_VReal) { // convert real->int if (have_had_atom) { --*rover; break; } r = round( fast_var_real( *rover ) ); have_had_atom = TRUE; } else if (tty == c_CString) { // convert str->int int R; if (have_had_atom) { --*rover; break; } sscanf( (*rover)->t_string, "%d", &R ); r = R; have_had_atom = TRUE; } else if (tty == c_VString) { // convert str->int // NYI exit(9); } else if (tty == c_Klauf) { if (have_had_atom) { --*rover; break; } ++*rover; r = _eval_int( rover, used-1 ); have_had_atom = TRUE; } else if (tty == c_Klzu) { break; // this returns the evalue after correcting arglist } else if (tty == c_Label) { // function call int arg_collctr = 0; // e.g. @function (a+1) (b+1)... labelptr proc = &labelT[ (*rover)->t_varindex ]; // points now to repr. of "function" tokenstruct argcollect[ MAXTOKENS_PER_LINE ], iiR; // interims result for the collecting of arguments int parameters = proc->l_paramc; while (used && parameters--) { // What are the types of the arguments? They ought to match those of the parameters... tokentype iiRtype = proc->l_params[ arg_collctr ].p_type; ++(*rover); switch (iiRtype) { case c_VInt: case c_CInt: // honestly, there are only variables to be expected iiR.t_type = c_CInt; iiR.t_int = _eval_int( rover, used-1 ); iiR.t_varname = NULL; // the collected stuff is "constantized" break; case c_VReal: case c_CReal: // printf("Trying to get a REAL arg\n"); iiR.t_type = c_CReal; iiR.t_real = _eval_real( rover, used-1 ); iiR.t_varname = NULL; break; case c_VString: case c_CString: iiR.t_type = c_CString; iiR.t_varname = NULL; exit(99); // NYI break; case c_Nihil: default: printf("Illegal token %s in paramlist\n", token_repr[iiRtype]); exit(1); break; } // evaluation of the above will terminate after the first ")", leaving (b+1) in the arglist. // We are now to store r in argcollect and go on evaluating. argcollect[ arg_collctr++ ] = iiR; --used; } /*** Now for the invocation proper. ***/ callproc( *proc, arg_collctr, argcollect ); /* This is a bit of an awkward situation. Normally, all work is done in an infinite loop within run_file which calls execute_line over and over again. However, we need the return value NOW, before ending this line. There is no reasonably simple alternative... we must take over control here. */ // printf("Putsch!\n"); ++PC; do ; while (!execute_line( PC, VM_LINUM )); // printf("Putsch unblutig beendet!\n"); /*** And now get the return value. We ought to add some checks here too. ***/ switch (RETREG.t_type) { case c_VInt: case c_CInt: // honestly, there are only variables to be expected r = RETREG.t_int; // printf("Retörning %i\n",r); break; case c_VReal: case c_CReal: // printf("Trying to get a REAL arg\n"); r = RETREG.t_real; printf("Retörning %i from real\n",r); break; case c_VString: case c_CString: { integer R; sscanf( RETREG.t_string, "%ld", R ); r = R; printf("Retörning %i from string\n",r); break; } case c_Nihil: printf( "SOS -- function returned nothing at all\n" ); exit( 123 ); default: printf( "SOS -- function returned very weird thing %s\n", token_repr[ RETREG.t_type ] ); exit( 123 ); } } else if (tty == c_Op_Add) { ++(*rover); r += _eval_int( rover, used-1 ); have_had_atom = TRUE; } else if (tty == c_Op_Mul) { ++(*rover); r *= _eval_int( rover, used-1 ); have_had_atom = TRUE; } else if (tty == c_Op_Sub) { ++(*rover); r -= _eval_int( rover, used-1 ); have_had_atom = TRUE; } else if (tty == c_Op_Div) { ++(*rover); r /= _eval_int( rover, used-1 ); have_had_atom = TRUE; } else if (tty == c_Op_Mod) { ++(*rover); r %= _eval_int( rover, used-1 ); have_had_atom = TRUE; } else if (tty == c_Equ) { ++(*rover); r = (r == _eval_int( rover, used-1 )); have_had_atom = TRUE; } else if (tty == c_Neq) { ++(*rover); r = (r != _eval_int( rover, used-1 )); have_had_atom = TRUE; } else if (tty == c_Gtr) { ++(*rover); r = (r > _eval_int( rover, used-1 )); have_had_atom = TRUE; } else if (tty == c_Lsr) { ++(*rover); r = (r < _eval_int( rover, used-1 )); have_had_atom = TRUE; } else if (tty == c_Geq) { ++(*rover); r = (r >= _eval_int( rover, used-1 )); have_had_atom = TRUE; } else if (tty == c_Leq) { ++(*rover); r = (r <= _eval_int( rover, used-1 )); have_had_atom = TRUE; } else if (tty == c_Et) { ++(*rover); r = (r && _eval_int( rover, used-1 )); have_had_atom = TRUE; } else if (tty == c_Vel) { ++(*rover); r = (r || _eval_int( rover, used-1 )); have_had_atom = TRUE; } ++(*rover); --used; } // printf("returning %i from _eval_int\n",r); return r; } static int eval_int( tokenstructptr first, int size, int used ) { return _eval_int( &first, used ); } static real _eval_real( register tokenstructptr *rover, int used ) { // no operator precedence register real r = 0; while (used>0) { // printf("Remain=%i\trover->t_type=%i\tr=%i\n",remain,(*rover)->t_type,r); register tokentype tty = (*rover)->t_type; if (tty == c_CInt) { r = (real) (*rover)->t_int; // printf("%i yields %f\n",(*rover)->t_int,r); } else if (tty == c_VInt) { r = (real) fast_var_int( *rover ); // printf("VInt %f\n",r); } else if (tty == c_CReal) { r = (*rover)->t_real; // printf("CReal %f\n",r); } else if (tty == c_VReal) { r = fast_var_real( *rover ); // printf("VReal %f\n",r); } else if (tty == c_Klauf) { ++(*rover); r = _eval_real( rover, used-1 ); } else if (tty == c_Klzu) { break; } else if (tty == c_Op_Add) { ++(*rover); r += _eval_real( rover, used-1 ); } else if (tty == c_Op_Mul) { ++(*rover); r *= _eval_real( rover, used-1 ); } else if (tty == c_Op_Sub) { ++(*rover); r -= _eval_real( rover, used-1 ); } else if (tty == c_Op_Div) { ++(*rover); r /= _eval_real( rover, used-1 ); } else if (tty == c_Radix) { ++(*rover); r = sqrt( _eval_real( rover, used-1 ) ); } #ifdef HAVEMATHLIB else if (tty == c_Sinus) { ++(*rover); r = sin( _eval_real( rover, used-1 ) ); } else if (tty == c_Cosinus) { ++(*rover); r = cos( _eval_real( rover, used-1 ) ); } else if (tty == c_Tangens) { ++(*rover); r = tan( _eval_real( rover, used-1 ) ); }else if (tty == c_ArcSinus) { ++(*rover); r = arcsin( _eval_real( rover, used-1 ) ); } else if (tty == c_ArcCosinus) { ++(*rover); r = arccos( _eval_real( rover, used-1 ) ); } else if (tty == c_ArcTangens) { ++(*rover); r = arctan( _eval_real( rover, used-1 ) ); } #endif else ; ++(*rover); --used; } // printf("returning %f\n",r); return r; } static real eval_real( tokenstructptr first, int size, int used ) { return _eval_real( &first, used ); } /* Note: eval_int and eval_real return plain and simple values, either integers or floats, which do not require further consideration. eval_str, however, is meant to return a string, in other words, an array of chars. Returning structs and arrays is not supported by C (as these data types do not fit into registers or onto processor stacks), hence we must help ourselves by returning a pointer. But what about the memory to which this pointer points? It must not be local, since local variables are deleted upon return from a procedure. The only technically feasible possibility consists in allocating the space dynamically and returning a pointer to this malloc()ed piece of RAM. Therefore it is necessary that the return value of "eval_str" is free()ed after usage (otherwise we would incur a memory leak). Cathol variables, on the other hand, are treated as static entities living in the heap of the program. This leads to the following strategy during evaluation of a string expression: FIAT $a $b+$c Now "eval_string" is called with a pointer to an amorphous array of tokens (which happen to be "$b", "+", "$c") and the additional information that 3 tokens are "used". It then proceeds in the following fashion: Space for the volatile variable R is allocated. The while loop is entered to process the tokens. $b is identified as having type c_VString; the macro "fast_var_str" is used to access the content of $b, and this is copied into R. The next token is identified as the operator "+" for concatenation. So the routine says 'very nice' and invokes itself to process the remaining tokens. Inside this, the following actions take place: - Space for the volatile variable R' is allocated. - $c is identified as having type c_VString; the macro "fast_var_str" is used to access the content of $c, and this is copied into R'. - R' is returned to the previous instance of "eval_str". Now we are back in the clause of the while loop dedicated to concatenation, where the return value (R') is temporarily bound to "R2". The content of R2 is appended to R, then R2 (and hence R') is deallocated. Sayonara! As there are no further tokens to be processed, the while loop terminates, and R is returned to the calling procedure, the clause within the central for(;;)/switch structure dedicated to handling the "fiat" command. What is to be done there? In this clause, access to $a is enforced, then the content of R is copied into the static memory area belonging to $a. Subsequently, R is also deallocated. */ static string _eval_str( register tokenstructptr *rover, int used ) { register string r = stralloc(); while (used>0) { // printf("Remain=%i\trover->t_type=%i\tr=%i\n",remain,(*rover)->t_type,r); register tokentype tty = (*rover)->t_type; if (tty == c_CString) { stringcopylim( (string) (*rover)->t_string, r, MAX_STRINGLENGTH ); // printf("CCopied '%s'\n",r ); } else if (tty == c_VString) { stringcopylim( (string) fast_var_str( *rover ), r, MAX_STRINGLENGTH ); // printf("VCopied '%s'\n",r ); } else if (tty == c_Klauf) { ++(*rover); r = _eval_str( rover, used-1 ); } else if (tty == c_Klzu) { break; } else if (tty == c_Op_Add) { // in this context: concatenation register string r2; ++(*rover); r2 = _eval_str( rover, used-1 ); // printf("'%s'+'%s' -> ",r,r2); strappend( r, r2, MAX_STRINGLENGTH ); strfree( r2 ); // printf("'%s'\n",r); } else ; ++(*rover); --used; } // printf("returning <%s>\n",r); return r; } static string eval_str( tokenstructptr first, int size, int used ) { return _eval_str( &first, used ); } #define assign_int( vname, ival ) { access_v( IVartab, vname )->v_int = ival; } #define assign_real( vname, rval ) { access_v( RVartab, vname )->v_real = rval; } #define assign_str( vname, rval ) { stringcopy( rval, access_v( SVartab, vname )->v_string ); } #define assign_fast_int( vdex, ival ) { access_x( IVartab, vdex )->v_int = ival; } #define assign_fast_real( vdex, rval ) { access_x( RVartab, vdex )->v_real = rval; } #define loopush( pc, v, to ) { \ register loddl l = LOOPS+LOOPC++; \ l->L_pc = pc; \ l->L_runner = v; \ l->L_max = to; } #define loopop( pc, v, to ) { \ register loddl l = LOOPS+--LOOPC; \ v = l->L_runner; \ to = l->L_max; \ pc = l->L_pc; } #define looptop( pc, v, to ) { \ register loddl l = LOOPS+LOOPC-1; \ v = l->L_runner; \ to = l->L_max; \ pc = l->L_pc; } #define loopdrop() (--LOOPC) //--- subroutine and return functions /* When a procedure is called, this is described by three variables: - the label (containing start line and parameters) - the number of arguments - a pointer to an amorphous array of tokens which are the arguments */ void callproc( label proc, int argc, tokenstructptr argv ) { // printf("gosub %i with %i parameters - 0x%08lx\n", proc.l_start, argc, argv ); /* Obscurate the parameter variables. There is no comprehensive list of these available. Therefore a list must be constructed on the fly, using only the indices: */ if (proc.l_paramc) { int volatile_index_tab[ MAXTOKENS_PER_LINE ]; tokentype volatile_type_tab[ MAXTOKENS_PER_LINE ]; int i; for ( i=0; i0 ) { // printf("%2i:\tArg = [%i] %8s\t%i\tParam = [%i] %8s\n", argc, argv[ argc ].t_type, argv[ argc ].t_varname, argv[ argc ].t_int, proc.l_params[ argc ].p_type, proc.l_params[ argc ].p_name ); register tokentype ttp = proc.l_params[ argc ].p_type; switch (ttp) { case c_VInt: IVartab[ proc.l_params[ argc ].p_varindex ].v_int = eval_int( &(argv[argc]), 1, 1 ); break; case c_VReal: // the hard way: assign_real( proc.l_params[ argc ].p_name, eval_real( &(argv[argc]), 1, 1 ) ); break; case c_VString: break; default: fprintf( stderr, "error in procdef %s in line %i: parameters must be int, real or string vars\n", proc.l_name, proc.l_start ); exit(3); } } SPush( callstack, PC ); PC = proc.l_start; } static void amenproc(void) { PC = SPop( callstack ); // printf("resume %i\n",PC); glob_illuminate(); } //--- obscuration mechanism /* In CATHOL, all variables are basically global. However, the OBSCURA / ILLUMINA mechanism allows to save the contents of a group of variables, or all active variables, to an internal stack from which they max be recovered, thus forming a block with functionally local variables. The notable exception are parameters, which are automatically considered as local and hence obscurated. This, of course, must be taken into consideration when leaving a Cantus. */ static teeptr new_tee( register teeptr t ) { // insert new tee at position // printf("new_tee( 0x%08lx )\n", t ); register teeptr tfurther; if (!(t->Tnext = tfurther = malloc( sizeof(tee) ))) { printf( "Out of cheese error\n" ); exit( 1 ); } tfurther->Tnext = tfurther; // if this was not the last one tfurther->Tprev = t; // establish link backwards tfurther->Tamount = 0; tfurther->Tvar = NULL; t->Tnext->Tfast = NULL; // printf("added at 0x%08lx\n", t->Tnext ); return t->Tnext; } static teeptr free_tee( register teeptr t ) { // remove tee at position // printf("free_tee( 0x%08lx ) ... anchor is 0x%08lx\n", t, &Tanchor ); if (t) if (t != &Tanchor ) { // printf("prev/next=0x%08lx,0x%08lx\n",t->Tprev,t->Tnext); if (t->Tprev) t->Tprev->Tnext = t->Tnext; // unlink if (t->Tnext) t->Tnext->Tprev = t->Tprev; t->Tamount = 0; // printf("OI WOI\n"); teeptr goback = t->Tprev; // printf("GEWALT GESCHRIEN\n"); if (t->Tvar) free( t->Tvar ); // printf("NEBBICH\n"); if (t->Tfast) free( t->Tfast ); // printf("MESCHUGGE\n"); free( t ); // printf("PFFF...\n"); return goback; } } /* Storage strategy: Parameters are counted. Two chunks of memory are then allocated; into one (Tvar) the "variab" descriptions of the variables to be obscured are copied. However, these are just variable contents, identificable only via their name (which is a slow process). either do they contain a type (usually clearly determined by their affiliation with one of the symbol tables). Instead of extending the "variab" data type, the variable indices and types are deposited in the second array (Tfast). Of course, both arrays contain an equal number of corresponding elements. */ static void glob_obscure( int *argv, tokentype *ttyv, int argc ) { int ac; Tptr = new_tee( Tptr ); if (argv) if (ttyv) if (argc) { // has parameters -> obscure these // printf("We must obscure %i variables\n",argc); Tptr->Tamount = argc; if (!(Tptr->Tvar = malloc( argc * sizeof(variab) )) || !(Tptr->Tfast = malloc( argc * sizeof(dvandva) ))) { printf("Out of cheese error while obscurating %i parameter variables\n", argc ); exit( 1 ); } register variabptr storage; for ( ac = 0, storage = Tptr->Tvar; ac < argc; ac++, storage++ ) { tokentype vt = ttyv[ ac ]; register variabptr v = varp_from_x( argv[ac], vt ); storage->v_used = TRUE; switch (vt) { case c_CInt: case c_VInt: storage->v_int = v->v_int; break; case c_CReal: case c_VReal: storage->v_real = v->v_real; break; default: *storage = *v; } register dvandva *fasta = Tptr->Tfast + ac; fasta->vinx = argv[ ac ]; // variable index fasta->vtyp = vt; // variable type } // for ( ac = 0; ac < argc; ac++ ) printf("STORED %i: %s: %i\n",ac,Tptr->Tvar[ac].v_name,Tptr->Tvar[ac].v_int); } else { // zero parameters -> obscure all exit(666); // not yet implemented } } static void glob_obsc_dummy(void) { Tptr = new_tee( Tptr ); } // create dummy link in chain static void glob_illuminate(void) { // reload saved variables: get index and type from Tptr->Tfast, and content from Tptr->Tvar // printf("RESTORE: There are %i variables in store\n",Tptr->Tamount); int ac; for ( ac = 0; ac < Tptr->Tamount; ac++ ) { register dvandva *dv = Tptr->Tfast + ac; register tokentype vt = dv->vtyp; register variabptr v = varp_from_x( dv->vinx, vt ); switch (vt) { case c_CInt: case c_VInt: v->v_int = (Tptr->Tvar + ac)->v_int; break; case c_CReal: case c_VReal: v->v_real = (Tptr->Tvar + ac)->v_real; break; default: *v= *(Tptr->Tvar + ac); } } // dispose of memory Tptr = free_tee( Tptr ); } //--- main loop and friends static boolean execute_line( int this_line, int linum ) { tokenarray curr = list[ this_line ]; register tokentype firstyp = TY( curr, 0 ); register int vnum; static int i_from, i_to; // for loops // dump_tokenarray(&curr); switch (firstyp) { case c_Fiat: switch (TY( curr, 1 )) { case c_VInt: assign_int( curr.ta_data[1].t_varname, eval_int( curr.ta_data+2, curr.ta_size-2, curr.ta_used-2 ) ); // printf("Eviluation was %i\n",eval_int( curr.ta_data+2, curr.ta_size-2, curr.ta_used-2 ) ); break; case c_VReal: assign_real( curr.ta_data[1].t_varname, eval_real( curr.ta_data+2, curr.ta_size-2, curr.ta_used-2 ) ); break; case c_VString: { register string iistring = eval_str( curr.ta_data+2, curr.ta_size-2, curr.ta_used-2 ); assign_str( curr.ta_data[1].t_varname, iistring ); strfree( iistring ); break; } default: ; } break; case c_Si: { if (!eval_int( curr.ta_data+1, curr.ta_size-1, curr.ta_used-1 )) PC = jumpT[ PC ].what_if_not; break; } case c_Alias: { /* When an ALIAS is encountered, we can safely assume that the condition evaluated to true, since otherwise the jump leads to the next line. So there is no need to laboriously store previous conditions. */ PC = jumpT[ PC ].what_if_true; break; } case c_Nisi: // this should never be encontered break; case c_Numera: if (TY( curr, 1 ) == c_VInt) { vnum = curr.ta_data[1].t_varindex; } else { printf("Integer var expected in line %i\n", curr.ta_data[1].t_sourceline); exit( 100 ); } if (TY( curr, 2 ) != c_Ab || TY( curr, 3 ) != c_Initio) { printf("'AB INITIO' expected in line %i\n", curr.ta_data[2].t_sourceline); exit( 101 ); } if (TY( curr, 4 ) == c_VInt || TY( curr, 4 ) == c_CInt) { i_from = eval_int( &(curr.ta_data[4]), 1, 1 ); } else { printf("Integer var or const as loop start expected in line %i\n", curr.ta_data[1].t_sourceline); exit( 102 ); } if (TY( curr, 5 ) != c_Usque || TY( curr, 6 ) != c_Ad) { printf("'USQUE AD' expected in line %i\n", curr.ta_data[5].t_sourceline); exit( 103 ); } if (TY( curr, 7 ) == c_VInt || TY( curr, 7 ) == c_CInt) { i_to = eval_int( &(curr.ta_data[7]), 1, 1 ); } else { printf("Integer var or const as loop end expected in line %i\n", curr.ta_data[1].t_sourceline); exit( 104 ); } register variabptr v = access_x( IVartab, vnum ); v->v_int = i_from; // initalize loop counter loopush( PC, v, i_to ); break; case c_Invocetur: { if (TY( curr, 1 ) == c_Label) { vnum = curr.ta_data[1].t_varindex; } else { printf("Procedure name expected in line %i\n", curr.ta_data[1].t_sourceline); exit( 110 ); } int argc = 0, paramc = labelT[ vnum ].l_paramc; tokenstructptr args = NULL; if (curr.ta_used > 2) { // if it has arguments args = &(curr.ta_data[ 2 ]); argc = curr.ta_used - 2; } if (argc != paramc) { printf( "Error in function call in line %i (%s): %i arguments - %i parameters\n", PC, labelT[ vnum ].l_name, argc, paramc ); exit( 112 ); } callproc( labelT[ vnum ], argc, args ); break; } /* The following three commands terminate a subroutine: AMEN "naturally" and without return value, REDDE with a return value, ILLUMINANDO REDDE with a return value and concurrent restoration of "obscurated" variables. The handling (deallocation) of parameters is performed by the amenproc() function, so we have to care only about explicitly obscurated variables. */ case c_Illuminando: if (TY( curr, 1 ) != c_Redde) { printf( "Syntax error in line %i: ILLUMIANDO without REDDE\n", PC ); exit( 120 ); } amenproc(); break; case c_Redde: // printf("Give it back to you\n"); /* The type to be expected is not to be found here but in the procedures definition. It is memorized as the type of the label. */ switch (RETREG.t_type = TY( curr, 1 )) { case c_VInt: // printf(" redde mihi INT\n"); RETREG.t_int = eval_int( curr.ta_data+1, curr.ta_size-1, curr.ta_used-1 ); // printf("RETREG is now %i\n", RETREG.t_int ); break; case c_VReal: printf(" redde mihi REAL\n"); RETREG.t_real = eval_real( curr.ta_data+2, curr.ta_size-2, curr.ta_used-2 ); break; case c_VString: { printf(" redde mihi STRING\n"); register string iistring = eval_str( curr.ta_data+2, curr.ta_size-2, curr.ta_used-2 ); stringcopylim( iistring, RETREG.t_string, MAXTOKENS_PER_LINE ); strfree( iistring ); break; } default: ; } amenproc(); return TRUE; case c_Amen: amenproc(); break; /* Explicit storage of "local" variables */ case c_Obscura: if (curr.ta_used > 1) { // if the OBSCURA call has arguments int volatile_index_tab[ MAXTOKENS_PER_LINE ]; tokentype volatile_type_tab[ MAXTOKENS_PER_LINE ]; int i; for ( i=1; iv_int < i_to) { // is there more to be done? ++(v->v_int); PC = jumpback+1; // then increase counter and go back } else { // loop completed ++PC; loopdrop(); // skip "procede" clause } return FALSE; // NOT break!! } case c_Frange: printf( "\n" ); break; case c_Ora: break; case c_Scribe: { int oup; for (oup=1; oup linum) return TRUE; // end of program file return FALSE; } static int run_file( char *filename, int lines2Bexpected ) { FILE *fp; int linum = 0; if (!(list = (tokenarray *) malloc( lines2Bexpected * sizeof(tokenarray) ))) exit(1); #ifdef HAVECLOCKLIB long t0, t1; #endif fprintf( stderr, "\n\n\n\n=====================================================\n" ); if (!(fp = fopen( filename, "r" ))) { fprintf( stderr, "could not find program %s\n", filename ); return 1; } // scan the file while (!feof(fp)) { int t, terminator; char *ghostline; int n = 0; getline( &ghostline, &n, fp ); linum++; for ( t = terminator = n; t >= 0; t-- ) if (ghostline[ t ] == '#') terminator = t; for ( t = terminator; t < n; t++ ) ghostline[ t ] = '\0'; clear_ta( &(list[ linum ]) ); int i = split_up( ghostline, linum, &(list[ linum ]) ); } fclose( fp ); VM_LINUM = linum; // initialize clear_jumptab( jumpT ); clear_vartab( IVartab ); clear_vartab( RVartab ); clear_vartab( SVartab ); clear_labtab( labelT ); SMake( callstack, MAX_RECURSION ); ENTRY = -1; // parse it int i; for ( i = 1; i 4) if (TY( curr, 3 ) == c_Cum) { // if it has parameters... params = &(curr.ta_data[ 4 ]); paramc = curr.ta_used - 4; } ca_setlabel( curr.ta_data[ 2 ].t_varname, i, TY( curr, 2 ), params, paramc, labelII ); } else if (TY( curr, 1 ) == c_Age && TY( curr, 0 ) == c_Paenitent) { // program entry point ca_setstart( i ); } } // define if/ifnot jumps ... these are forward jumps stakk if_then, has_alias; for ( i = 1; it_varname) { if (ij->t_type == c_VInt) ij->t_varindex = v_to_x( IVartab, ij->t_varname ); else if (ij->t_type == c_VReal) ij->t_varindex = v_to_x( RVartab, ij->t_varname ); else if (ij->t_type == c_VString) ij->t_varindex = v_to_x( SVartab, ij->t_varname ); else if (ij->t_type == c_Label) ij->t_varindex = label2inx( labelT, labelII, ij->t_varname ); else printf("Something is wrong in line %i: variable name without variable?\n", i ); } } } t0 = getclocktime(); // finally run it if (ENTRY < 0) { printf("No entry point!\n"); exit(1); } PC = ENTRY+1; for (;;) if (execute_line( PC, linum )) break; t1 = getclocktime(); #ifdef HAVECLOCKLIB printf( "\n*** %li msec spent on file %s.\n", t1-t0, filename ); #endif SKill( callstack ); free( list ); } static void prelude(void) { } static void epilude(void) { printf("\n"); } int main( int argc, char **argv ) { char cmdlin[ 512 ]; prelude(); while (--argc) { sprintf( cmdlin, "%s.cath", *++argv ); run_file( cmdlin, MAXLINES ); } epilude(); }