/************************************************************************ * * * The SB-Prolog System * * Copyright SUNY at Stony Brook, 1986 * * * ************************************************************************/ /*----------------------------------------------------------------- SB-Prolog is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY. No author or distributor accepts responsibility to anyone for the consequences of using it or for whether it serves any particular purpose or works at all, unless he says so in writing. Refer to the SB-Prolog General Public License for full details. Everyone is granted permission to copy, modify and redistribute SB-Prolog, but only under the conditions described in the SB-Prolog General Public License. A copy of this license is supposed to have been given to you along with SB-Prolog so you can know your rights and responsibilities. It should be in a file named COPYING. Among other things, the copyright notice and this notice must be preserved on all copies. ------------------------------------------------------------------ */ /* main.c */ #include "simdef.h" #include "aux.h" #include "inst.h" #define system_up 1 #define pad lpcreg++ #define opregno (*lpcreg++) #define regc(regno) (follow(rreg+regno)) #define opregc (regc(opregno)) #define opreg ((word)(rreg+opregno)) #define opvarno (*lpcreg++) #define varc(varno) follow(le_reg+(-(long)varno)) #define opvarc varc(opvarno) #define opvar ((word)(le_reg+(-(long)opvarno))) #define opbyte *lpcreg++ #define op2word op2 = *(pw)lpcreg; lpcreg+=4 #define op3word op3 = *(pw)lpcreg; lpcreg+=4 #define nparse_opPVRv pad; op1 = opvarc; op2 = opregc #define nparse_opPRRv pad; op1 = opregc; op2 = opregc #define nparse_opVWv op1 = opvarc; op2word #define nparse_opRWv op1 = opregc; op2word #define nparse_opRv op1 = opregc #define nparse_opVv op1 = opvarc #define nparse_opPW pad; op2word /* note op2! */ #define nparse_opBW op1 = opbyte; op2word #define nparse_opB op1 = opbyte extern byte *set_intercode(); extern double floatval(); extern word makefloat(); extern prettymuch_equal(); int current_opcode; main(argc, argv) int argc; char *argv[]; { /* start main */ struct psc_rec *psc; pw opr; register byte *lpcreg; register word *le_reg; register word *rreg; /* for SUN */ register word *sreg; /* */ register pw top; register word op1, op2; word op3; short int i, arity; /* to unify subfields of op1 and op2 */ arm_intercept(); init_sim(argc, argv); init_jump_table(); init_parse_routine(); init_load_routine(); init_builtin(); init_loading(argc, argv); if (disassem) { dis( ); printf("The byte code file is dumped in the file dump.pil\n"); exit(0); } lpcreg = inst_begin; le_reg = (pw)ereg; rreg = (pw)®[0]; /* for SUN */ while ( system_up ) { /* the main loop */ contcase: switch ( *lpcreg++ ) { case getpvar00: /* PVR */ pad; op1 = opvarno; varc(op1) = opregc; goto contcase; case getpval00: /* PVR */ nparse_opPVRv; goto nunify; case getstrv00: /* VW */ nparse_opVWv; goto nunify_with_str; case gettval00: /* PRR */ nparse_opPRRv; goto nunify; case getcon00: /* RW */ nparse_opRWv; goto nunify_with_con; case getnil00: /* R */ nparse_opRv; goto nunify_with_nil; case getstr00: /* RW */ nparse_opRWv; goto nunify_with_str; case getlist00: /* R */ nparse_opRv; goto nunify_with_list_sym; case unipvar00: /* V */ if (flag == WRITEFLAG) { opvarc = (word)hreg; new_heap_free; } else opvarc = *sreg++; goto contcase; case unipval00: /* V */ nparse_opVv; if ( flag == WRITEFLAG ) goto nbldval; else { op2 = *sreg++; goto nunify; } case unitvar00: /* R */ if ( flag == WRITEFLAG ) {opregc = (word)hreg; new_heap_free;} else opregc = *sreg++; goto contcase; case unitval00: /* R */ nparse_opRv; if ( flag == WRITEFLAG ) goto nbldval; else { op2 = *sreg++; goto nunify; } case unicon00: /* PW */ nparse_opPW; /* note goes to op2! */ if ( flag == WRITEFLAG ) new_heap_con(op2); else { /* op2 already set */ op1 = *sreg++; goto nunify_with_con;} goto contcase; case uninil00: /* P */ pad; if ( flag == WRITEFLAG ) new_heap_node(nil_sym); else { op1 = *sreg++; goto nunify_with_nil;} goto contcase; case getnumcon: /* RW */ nparse_opRWv; goto nunify_with_int; case getival: /* RW */ nparse_opRWv; goto nunify; case putnumcon: /* RW */ op1 = opregno; regc(op1) = makeint(*(pw)lpcreg); lpcreg+=4; goto contcase; case putpvar00: /* PVR */ pad; op1 = opvar; follow(op1) = op1; opregc = op1; goto contcase; case putpval00: /* PVR */ pad; op1 = opvarno; opregc = varc(op1); goto contcase; case puttvar00: /* PRR */ pad; opregc = (word)hreg; opregc = (word)hreg; new_heap_free; goto contcase; case putstrv00: /* VW */ opvarc = (word)hreg | CS_TAG; new_heap_node(*(pw)lpcreg); lpcreg+=4; goto contcase; case putcon00: /* RW */ op1 = opregno; regc(op1) = (*(pw)lpcreg) | CS_TAG; lpcreg+=4; goto contcase; case putnil00: /* R */ opregc = nil_sym; goto contcase; case putstr00: /* RW */ opregc = (word)hreg | CS_TAG; new_heap_node(*(pw)lpcreg); lpcreg+=4; goto contcase; case putlist00: /* R */ opregc = (word)hreg | LIST_TAG; goto contcase; case bldpvar00: /* V */ opvarc = (word)hreg; new_heap_free; goto contcase; case bldpval00: /* V */ nparse_opVv; goto nbldval; case bldtvar00: /* R */ opregc = (word)hreg; new_heap_free; goto contcase; case bldtval00: /* R */ nparse_opRv; goto nbldval; case bldcon00: /* PW */ pad; new_heap_con(*(pw)lpcreg); lpcreg+=4; goto contcase; case bldnil00: /* P */ pad; new_heap_node(nil_sym); goto contcase; case getlist_tvar_tvar: /* BBB */ op1 = opregc; glrr: switch ((int)(op1 & 3)) { case FREE: nderef(op1, glrr); follow(op1) = (word)hreg | LIST_TAG; pushtrail(op1); opregc = (word)hreg; new_heap_free; opregc = (word)hreg; new_heap_free; break; case CS: case NUM: Fail1; break; case LIST: sreg = (pw)(untagged(op1)); opregc = *sreg++; opregc = *sreg; break; } /* end getlist_tvar_tvar */ goto contcase; case getcomma: /* R */ nparse_opRv; op2 = (word)comma_psc; goto nunify_with_str; case getcomma_tvar_tvar: /* BBB */ op1 = opregc; gcrr: switch ((int) (op1 & 3)) { case FREE: nderef(op1, gcrr); follow(op1) = (word)hreg | CS_TAG; pushtrail(op1); new_heap_node(((word)comma_psc)); pushtrail(op1); opregc = (word)hreg; new_heap_free; opregc = (word)hreg; new_heap_free; break; case CS: untag(op1); if (follow(op1) == (word)comma_psc) { sreg = (pw)(op1+4); opregc = *sreg++; opregc = *sreg; break; } case NUM: case LIST: Fail1; break; } /* end getcomma_tvar_tvar */ goto contcase; case uninumcon: /* PL */ nparse_opPW; /* num in op2 */ if ( flag == WRITEFLAG ) new_heap_int(op2); else { /* op2 set */ op1 = *sreg++; goto nunify_with_int;} goto contcase; case bldnumcon: /* PL */ nparse_opPW; /* num to op2 */ new_heap_int(op2); goto contcase; case getfloatcon: /* RW */ nparse_opRWv; goto nunify_with_float; case putfloatcon: /* RW */ op1 = opregno; regc(op1) = (*(pw)lpcreg); lpcreg+=4; /* float already tagged */ goto contcase; case unifloatcon: /* PL */ nparse_opPW; /* float in op2 */ if ( flag == WRITEFLAG ) new_heap_float(op2); else { /* op2 set */ op1 = *sreg++; goto nunify_with_float;} goto contcase; case bldfloatcon: /* PL */ nparse_opPW; /* float to op2 */ new_heap_float(op2); goto contcase; case trymeelse: /* BA */ nparse_opBW; goto subtryme; case retrymeelse: /* BA */ op1 = *lpcreg++; *(breg+1) = *(pw)lpcreg; lpcreg+=4; goto rerestore; case trustmeelsefail: /* B */ nparse_opB; goto trrestore; case try: /* BA */ op1 = *lpcreg++; op2 = (word)lpcreg + 4; lpcreg = *(pb *)lpcreg; goto subtryme; case retry: /* BA */ op1 = *lpcreg++; *(breg+1) = (word)lpcreg+4; lpcreg = *(pb *)lpcreg; goto rerestore; case trust: /* BA */ op1 = *lpcreg++; lpcreg = *(pb *)lpcreg; goto trrestore; case getpbreg: /* V */ opvarc = (word)breg | NUM_TAG; goto contcase; case gettbreg: /* R */ opregc = (word)breg | NUM_TAG; goto contcase; case putpbreg: /* V */ nparse_opVv; deref(op1); breg = (pw)(untagged(op1)); hbreg = (pw)*(breg + 3); goto contcase; case puttbreg: /* R */ nparse_opRv; deref(op1); breg = (pw)(untagged(op1)); hbreg = (pw)*(breg + 3); goto contcase; case jumptbreg: /* RW */ opregc = (word)breg | NUM_TAG; lpcreg = *(byte **)lpcreg; goto contcase; case switchonterm: /* RWW */ op1 = opregc; sotd: switch((int) (op1&3)) { case FREE: nderef(op1, sotd); lpcreg += 8; break; case NUM: lpcreg = *(pb *)lpcreg; break; case CS: if (get_str_arity(op1) == 0) { lpcreg = *(pb *)lpcreg; break; } case LIST: /* include structure case here */ lpcreg += 4; lpcreg = *(pb *)lpcreg; break; } goto contcase; case switchonbound: /* RWW */ op1 = opregc; sotd1: switch((int) (op1&3)) { case FREE: nderef(op1, sotd1); lpcreg += 8; goto sotd2; case NUM: op1 = numval(op1); break; case LIST: op1 = *((pw)untagged(list_str)); /* op1 = untagged(list_str); */ break; case CS: op1 = (word)get_str_psc(op1); /* if (get_str_arity(op1) != 0) op1 = (word)get_str_psc(op1); else op1 = untagged(op1); op1 = untagged(op1); */ break; } op2 = *(pw)(lpcreg); lpcreg += 4; op3 = *(pw)(lpcreg); lpcreg = *(pb *)(ihash(op1, op3) * 4 + op2); sotd2: goto contcase; case switchoncon: nparse_opPW; printf("Switchoncon not implemented\n"); goto contcase; case switchonstr: nparse_opPW; printf("Switchonstr not implemented\n"); goto contcase; case movreg: /* PRR */ pad; op1 = opregno; opregc = regc(op1); goto contcase; case addreg: /* PRR */ pad; op1 = opregc; op3 = opreg; op2 = follow(op3); deref(op1); deref(op2); if (!isnum(op1) || !isnum(op2)) {printf("add: number required\n"); Fail1;} else { reset_floatflag; set_psw_if_float(op1); set_psw_if_float(op2); follow(op3) = makenum(numval(op2) + numval(op1)); }; goto contcase; case subreg: /* PRR */ pad; op1 = opregc; op3 = opreg; op2 = follow(op3); deref(op1); deref(op2); if (!isnum(op1) || !isnum(op2)) {printf("sub: number required\n"); Fail1;} else { reset_floatflag; set_psw_if_float(op1); set_psw_if_float(op2); follow(op3) = makenum(numval(op2) - numval(op1)); }; goto contcase; case mulreg: /* PRR */ pad; op1 = opregc; op3 = opreg; op2 = follow(op3); deref(op1); deref(op2); if (!isnum(op1) || !isnum(op2)) {printf("mul: number required\n"); Fail1;} else { reset_floatflag; set_psw_if_float(op1); set_psw_if_float(op2); follow(op3) = makenum(numval(op2) * numval(op1)); }; goto contcase; case divreg: /* PRR */ pad; op1 = opregc; op3 = opreg; op2 = follow(op3); deref(op1); deref(op2); if (!isnum(op1) || !isnum(op2)) {printf("div: number required\n"); Fail1;} else { reset_floatflag; set_psw_if_float(op1); set_psw_if_float(op2); follow(op3) = makenum(numval(op2) / numval(op1)); }; goto contcase; case putdval00: /* PVR */ pad; op1 = opvarc; deref(op1); opregc = op1; goto contcase; case putuval00: /* PVR */ pad; op1 = opvarc; deref(op1); if (((op1&3) != 0) || (op1 < (word)hreg) || (op1 >= (word)le_reg)) opregc = op1; else {follow(op1) = opregc = (word)hreg; pushtrail(op1); new_heap_free; } goto contcase; case call: /* PW */ nparse_opPW; cpreg = lpcreg; psc = (struct psc_rec *)op2; goto call_sub; case allocate: pad; if ((pw)breg < le_reg) op1 = (word)breg; else op1 = (word)(le_reg - *(cpreg-5)); follow(op1) = (word)le_reg; follow(op1-4) = (word)cpreg; le_reg = (pw)op1; if (le_reg < hreg+100) if (!overflow_f) {overflow_f = 1; lpcreg = set_intercode(2); goto contcase;} goto contcase; case deallocate: pad; cpreg = (byte *)*(pw)(le_reg-1); le_reg = *(pw *)le_reg; goto contcase; case proceed: pad; lpcreg = cpreg; goto contcase; case execute: nparse_opPW; psc = (struct psc_rec *)op2; goto call_sub; case unexec: /* PWW, builds str on heap, and executes 2nd arg simulates exec(op2(op1(A1,A2,..,An)) for intercepting calls */ pad; op2word; op3 = (word)hreg; /* save addr of new structure rec */ new_heap_node(op2); /* set str psc ptr */ for ( i=1; i<=get_arity((struct psc_rec *)op2); i++) { op1 = regc(i); unebld: if ((op1 & 3) == 0) { nderef(op1, unebld); follow(op1) = (word)hreg; pushtrail(op1); new_heap_free; } else new_heap_node(op1); } regc(1) = op3 | CS_TAG; /* ptr to new structure on heap */ op2word; psc = (struct psc_rec *)op2; goto call_sub; case unexeci: /* PWW, builds str on heap with last arg a var, and executes 2nd arg; for interpreting; simulates exec(op2(op1(A1,A2,..,An-1,B),B) */ pad; op2word; op3 = (word)hreg; /* save addr of new structure rec */ new_heap_node(op2); /* set str psc ptr */ for ( i=1; i 0) lpcreg = *(byte **)lpcreg; else lpcreg+=4; goto contcase; case jumpge: op3 = opregc; if (numval(op3) >= 0) lpcreg = *(byte **)lpcreg; else lpcreg+=4; goto contcase; case fail: pad; Fail1; goto contcase; case noop: nparse_opB; lpcreg += op1; lpcreg += op1; goto contcase; case halt: pad; printf("\nHalt. Program terminated normally\n"); exit(0); goto contcase; case builtin: nparse_opB; pcreg=lpcreg; ereg = le_reg; /* printf("Builtin# %d\n", (byte)op1); */ Builtin((byte)op1); lpcreg=pcreg; goto contcase; case calld: pad; cpreg = lpcreg+4; lpcreg = *(pb *)lpcreg; if (hitrace == 1) printf(" call direct: address %x\n", lpcreg) ; goto contcase; case lshiftr: pad; op1 = opregc; op3 = opreg; op2 = follow(op3); deref(op1); deref(op2); if (!isinteger(op1) ||!isinteger(op2)) {printf("lshiftr: integer required\n"); Fail1;} else follow(op3) = makeint((intval(op2)) >> intval(op1)); goto contcase; case lshiftl: pad; op1 = opregc; op3 = opreg; op2 = follow(op3); deref(op1); deref(op2); if (!isinteger(op1) || !isinteger(op2)) {printf("lshiftl: integer required\n"); Fail1;} else follow(op3) = makeint((intval(op2)) << intval(op1)); goto contcase; case or: pad; op1 = opregc; op3 = opreg; op2 = follow(op3); deref(op1); deref(op2); if (!isinteger(op1) || !isinteger(op2)) {printf("or: integer required\n"); Fail1;} else follow(op3) = makeint(intval(op2) | intval(op1)); goto contcase; case and: pad; op1 = opregc; op3 = opreg; op2 = follow(op3); deref(op1); deref(op2); if (!isinteger(op1) || !isinteger(op2)) {printf("and: integer required\n"); Fail1;} else follow(op3) = makeint(intval(op2) & intval(op1)); goto contcase; case negate: op1 = opregno; op2 = regc(op1); deref(op2); if (!isinteger(op2)) {printf("negate: integer required\n"); Fail1;} else regc(op1) = makeint(~intval(op2)); goto contcase; case endfile: nparse_opPW; goto contcase; case getcon01 : case getnil01 : case getstr01 : case getlist01 : case unipvar01 : case unipval01 : case unitvar01 : case unitval01 : case unicon01 : case uninil01 : case putpvar01 : case putpval01 : case puttvar01 : case putcon01 : case putnil01 : case putstr01 : case putlist01 : case bldpvar01 : case bldpval01 : case bldtvar01 : case bldtval01 : case bldcon01 : case bldnil01 : case getpvar10 : case getpval10 : case gettval10 : case getcon10 : case getnil10 : case getstr10 : case getlist10 : case unicon10 : case uninil10 : case putpvar10 : case putpval10 : case puttvar10 : case putcon10 : case putnil10 : case putstr10 : case putlist10 : case bldpvar10 : case bldpval10 : case bldtvar10 : case bldtval10 : case bldcon10 : case bldnil10 : case getpvar11 : case getpval11 : case gettval11 : case getcon11 : case getnil11 : case getstr11 : case getlist11 : case unipvar11 : case unipval11 : case unitvar11 : case unitval11 : case unicon11 : case uninil11 : case putpvar11 : case putpval11 : case puttvar11 : case putcon11 : case putnil11 : case putstr11 : case putlist11 : case bldpvar11 : case bldpval11 : case bldtvar11 : case bldtval11 : case bldcon11 : case bldnil11 : default: printf("\nIllegal opcode hex %x at %x\n", *--lpcreg, lpcreg); exit(1); } /* end switch */ } /* end main instruction loop */ nunify: /* ( op1, op2 ) */ /* word op1, op2 */ switch ((int) (op1 & 3)) { case FREE: /* op1 */ nderef(op1, nunify); nunify_with_free: /* op1 is a dereffed free node */ switch ((int) (op2 & 3)) { case FREE: /* op1 = free var, op2 = free var */ nderef(op2, nunify_with_free); if ( op1 != op2 ) { if ( op1 < op2 ) { if ( op1 < (word)hreg ) /* op1 not in loc stack */ {follow(op2) = op1; pushtrail(op2);} else /* op1 points to op2 */ {follow(op1) = op2; pushtrail(op1);} } else { /* op1 > op2 */ if ( op2 < (word)hreg ) {follow(op1) = op2; pushtrail(op1);} else {follow(op2) = op1; pushtrail(op2);} } } break; /* op1=free, op2=free */ case CS: /* op1=free, op2=con/str */ case LIST: /* op1=free, op2=list */ case NUM: /* op1=free, op2=num */ follow(op1) = op2; pushtrail(op1); break; /* op1=free, op2=c/s,list,num */ } break; /* op1=free */ case CS: /* op1=c/s */ nu2: switch ((int)(op2 & 3)) { case FREE: /* op1=con/str, op2=free */ nderef(op2, nu2); follow(op2) = op1; pushtrail(op2); break; /* op1=con/str, op2=free */ case CS: /* op1=con/str, op2=con/str */ if (op1 != op2) { /* a != b */ untag(op1); untag(op2); if (follow(op1) != follow(op2)) { /* 0(a) != 0(b) */ Fail1; break; /* op1=c/s, op2=c/s */ } else { arity = get_str_arity(op1); for ( i=1; i <= arity; i++ ) if(!unify(*((pw)op1+i), *((pw)op2+i))) {Fail1; goto nbreakconcon;} /* break out of BOTH for and case */ } } nbreakconcon: break; /* out of con/str, con/str */ case LIST: /* op1 = con/str, op2 = list */ case NUM: Fail1; break; /* op1=c/s, op2=list, */ } /* end case op1=c/s */ break; case LIST: /* op1=list */ nu3: switch ((int)(op2 & 3)) { case FREE: /* op1=list, op2=free */ nderef(op2, nu3); follow(op2) = op1; pushtrail(op2); break; /* op1-list, op2=free */ case CS: /* op1=list, op2=con/str */ case NUM: /* op1=list, op2=num */ Fail1; break; /* op1=list, op2=c/s,num */ case LIST: /* op1=list, op2=list */ if (op1 != op2) { untag(op1); untag(op2); if ( !unify(*(pw)op1, *(pw)op2) || !unify( *(((pw)op1)+1), *(((pw)op2)+1) ) ) {Fail1; break;} } break; /* op1=list, op2=list */ } break; /* op1=list */ case NUM: /* op1=num */ nwn: switch ((int)(op2 & 3)) { case FREE: /* op1=num, op2=free */ nderef(op2, nwn); follow(op2) = op1; pushtrail(op2); break; /* op1=num, op2=free */ case NUM: /*op1=num, op2=num */ if (op1 == op2) break; /* op1=num, op2=num */ else if ((isfloat(op1) || isfloat(op2)) && prettymuch_equal((double)numval(op2), (double)numval(op1))) break; case CS: case LIST: Fail1; break; /* op1=num, op2=c/s,list */ } /* disp on op2 */ break; /* disp on op1 */ } /* end of disp on op1 */ goto contcase; /* end of nunify */ nunify_with_con: /* op1, op2=(untagged)con */ switch((int) (op1 & 3)) { case FREE: /* op2=(untagged)con, op1=free */ nderef(op1, nunify_with_con); follow(op1) = op2 | CS_TAG; pushtrail(op1); break; /* op1=free */ case CS: /* op2=(untagged)con, op1=con/str */ untag(op1); if (op1 != op2) { /* a != b */ if (follow(op2) != follow(op1)) /* 0(a) != 0(b) */ {Fail1;} /* else must be converted temp const and are same */ } break; /* out of con/str, con/str */ case LIST: /* op2 = con/str, op1 = list */ case NUM: Fail1; break; } /* end case nunify_with_con */ goto contcase; nunify_with_int: /* op1 is general, op2 has integer (untagged) */ switch ((int) (op1 & 3)) { case FREE: /* op1=free */ nderef(op1, nunify_with_int); follow(op1) = makeint(op2); pushtrail(op1); break; /* op2=num, op1=free */ case NUM: /*op2=num, op1=num */ if (isinteger(op1) && (intval(op1) == op2)) break; else if (isfloat(op1) && prettymuch_equal((double)numval(op1), (double)op2)) break; case CS: case LIST: Fail1; break; } /* disp on op1 */ goto contcase; /* end of nunify_with_int */ nunify_with_float: /* op1 is general, op2 is tagged float in WAM format */ switch ((int) (op1 & 3)) { case FREE: /* op1=free */ nderef(op1, nunify_with_float); follow(op1) = op2; pushtrail(op1); break; /* op2 = float, op1 = free */ case NUM: if (prettymuch_equal(numval(op1), numval(op2))) break; case CS: case LIST: Fail1; break; } /* disp on op1 */ goto contcase; /* end of nunify_with_float */ nunify_with_nil: /* op1, nil_sym(tagged) */ switch((int) (op1 & 3)) { case FREE: /* op1=free */ nderef(op1, nunify_with_nil); follow(op1) = nil_sym; pushtrail(op1); break; /* op1=free */ case CS: /* op1=con/str */ if (op1 == nil_sym) break; /* a == [] */ case LIST: case NUM: Fail1; break; } /* end case nunify_with_nil */ goto contcase; nunify_with_str: /* (op1, op2 as psc_ptr) */ /* struct psc_rec *str_ptr; using op2 */ switch ((int) (op1 & 3)) { case FREE: nderef(op1, nunify_with_str); follow(op1) = (word)hreg | CS_TAG; pushtrail(op1); /**/ new_heap_node(op2); flag = WRITEFLAG; break; case CS: untag(op1); if (follow(op1) == op2) { flag = READFLAG; sreg = ((pw) op1) + 1; /**/ break; } case LIST: case NUM: Fail1; break; } /* case for nunify_with_str */ goto contcase; nunify_with_list_sym: /* (op1) */ switch ((int) (op1 & 3)) { case FREE: nderef(op1, nunify_with_list_sym); follow(op1) = (word)hreg | LIST_TAG; pushtrail(op1); flag = WRITEFLAG; break; case CS: case NUM: Fail1; break; case LIST: sreg = (pw)(untagged(op1)); flag = READFLAG; break; } /* end nunify_with_list_sym */ goto contcase; nbldval: if ((op1 & 3) == 0) {nderef(op1, nbldval); follow(op1) = (word)hreg; pushtrail(op1); new_heap_free;} else new_heap_node(op1); goto contcase; subtryme: { register word *b; if (breg < le_reg) b = breg; else b = le_reg - *(cpreg - 5) ; /* 1st arg. of call instruction */ if (b < hreg+100) if (!overflow_f) {overflow_f = 1; lpcreg = set_intercode(2); goto contcase;} for (i = 1; i <= op1; i++) { *b-- = regc(i); /* b = b + 1; */ } *b-- = (word)le_reg; *b-- = (word)cpreg; *b-- = (word)trreg; *b-- = (word)hreg; *b-- = (word)breg; *b-- = op2; /* next process' entry pt. */ breg = b; /* next free space was b+6*/ hbreg = hreg;} goto contcase; /* end of subtryme */ rerestore: { register word *b; word *oldtr; b = breg + 3; hreg = (pw)*(b); oldtr = (pw)*(++b); while (trreg != oldtr) { top = (pw)(*(++trreg)); *(pw *)top = top; } cpreg = (pb)*(++b); le_reg = (pw)(*(++b)); for (i = op1; i >= 1;i--) { regc(i) = *(++b); /* b = b - 1; */ } } goto contcase; trrestore: { register word *b; word *oldtr; b = breg + 3; hreg = (pw)*(b); oldtr = (pw)*(++b); while (trreg != oldtr) { top = (pw)*(++trreg); *(pw *)top = top; } cpreg = (pb)*(++b); le_reg = (pw)*(++b); for (i = op1; i >= 1;i--) { regc(i) = *(++b); } } breg = (pw)*(breg + 2); hbreg = (pw)*(breg + 3); goto contcase; call_sub: /* (psc)*/ if (interrupt_code > 0) { /* combine with call_intercept check! */ build_call(psc); lpcreg = set_intercode(1); interrupt_code = 0; arm_intercept(); psc = interrupt_psc; } else if (is_PRED(psc) || is_DYNA(psc)) lpcreg = get_ep(psc); else if (is_BUFF(psc)) lpcreg = (byte *)get_name(psc)+4; else { build_call(psc); lpcreg = set_intercode(0); psc = interrupt_psc; } if (call_intercept) { if (hitrace) { printf("call/exec: "); writepname(stdout, get_name(psc), get_length(psc) ); printf("/%d(", get_arity(psc)); for (i=1; i <= get_arity(psc); i++) { printterm( regc(i), 1 ); if (i < get_arity(psc)) printf(" "); } printf(")\n"); } if (trace_sta) { if (hreg > mheaptop) mheaptop = hreg; if (ereg < mlocaltop) mlocaltop = ereg; if (breg < mlocaltop) mlocaltop = breg; if (trreg < mtrailtop) mtrailtop = trreg; } } goto contcase; } /* end main */