/************************************************************************ * * * C Prolog main.c * * ======== ------ * * * * By Fernando Pereira, July 1982. * * EdCAAD, Dept. of Architecture, University of Edinburgh. * * * * Based on the Prolog system written in IMP by Luis Damas for ICL 2900 * * computers, with some contributions by Lawrence Byrd. Stricter types * * and several extensions by Richard O'Keefe, also BACKWARDS support. * * * * Copyright (C) 1982 Fernando Pereira, Luis Damas and Lawrence Byrd. * * Copyright (C) 1984 F.Pereira, L.Damas, L.Byrd and R.A.O'Keefe. * * * ************************************************************************/ #include "pl.h" #include "evalp.h" #include "arith.h" #include #define TEST(c,s,f) {if (c) goto s; else goto f;} #define TRY(c) TEST(c,EXIT,FAIL) /* Variables for communication with read, write and symbol table */ ATOMP BasicAtom[rqrdatoms]; FUNCTORP BasicFunctor[rqrdfuncs]; PTR hasha, atomfp, atprompt, list10; int lc, quoteia, fileerrors, reading; /* execution and start-up flags */ int running = FALSE; int PrologEvent; /* why did we bomb out? */ extern jmp_buf ZeroState; /* where to bomb out to */ /* variables for communication with dbase */ PTR vra, vrz; /* general error message passing string */ char *ErrorMess; /* Heap management block */ extern char Heap[]; /* these are just used to save() and */ extern Sint HeapHeader; /* restore() the heap, not to look inside */ extern PTR HeapTop(); /* Prolog machine registers */ FRAMEP X; /* local frame pointer for parent goal */ FRAMEP V; /* local frame pointer for current goal */ FRAMEP VV; /* local frame pointer for last choice point */ PTR x1; /* global frame pointer for parent goal */ PTR vv1; /* global frame pointer for last choice point */ PTR v1; /* top of global stack */ PTR tr; /* top of trail */ /* main loop variables */ static int usermode; /* are we executing a user or a system predicate? */ static int lev; /* depth of procedure calls */ static int invokno; /* call number (NOT depth) */ static Sint info; /* package of invokno and lev */ static PTR pg; /* the current goal (atom or molecule) */ static PTR g; /* skeleton of the current goal */ static PTR c; /* continuation (points to a skeleton) */ static CLAUSEP d; /* current clause */ static CLAUSEP *fl; /* ^list of alternatives */ #define FailToSelf {register CLAUSEP cl = *fl; fl = &(cl->altofcl); *fl = cl;} /* miscellaneous */ static int carith = 0; /* are arithmetic goals to be "compiled"? */ static int bb; /* flags of current predicate */ #ifdef COUNTING /* recording stack excursion */ #define NEXT_PORT 4 static double totloc, totglo, tottr; static Sint maxloc, maxglo, maxtr; static Sint smpcnt, portct[5], instrct[NPREDS]; static FILE *trace_file; #endif COUNTING /* Variables and constants for the basic debugging package */ #define CALL_PORT 0 #define EXIT_PORT 1 #define BACK_PORT 2 #define FAIL_PORT 3 #define NEVER_SKIP 1000000 static char *portname[] = {"call", "exit", "back", "fail"}; static int portmask[] = {8, 4, 2, 1 }; int debug = FALSE; /* are we debugging (TRUE/FALSE) ? */ int sklev; /* skipped level to return to (set by ^C too) */ static int brklev = 0; /* how many break levels we're inside */ static int unknown = 0; /* fail/error when a predicate has no clauses? */ static int spy = FALSE; /* FALSE for not spying, SPY_ME when spying */ static int port; /* which port is 'message' to return to? */ static int leash = 10; /* which ports is 'message' to stop at? */ int dotrace; /* trace trigger (checked at CALL port) */ static int brtn; /* where is 'break' to return to? */ static int recons = FALSE; /* FALSE -> consulting, TRUE -> reconsulting */ static PTR brkp = NullP; /* points to topmost break state */ static PTR *savead; /* used in saving/restoring break states */ /*----------------------------------------------------------------------+ | | | Entering and leaving breaks, | | saving and restoring memory images. | | | +----------------------------------------------------------------------*/ /* The variables to be saved during a break are divided into two groups: the integers (which are stored in Prolog coded form and converted back when the break is exited) and the pointers (which are stored as is). This relies on all the pointers having sensible Prolog coded values. Because integers are coded, they can only have 29-bit values. Although the `info` variable is declared `int`, it is actually a tagged value. The break level brklev is now maintained by save/rest vars. Note that a file whose index is held in a break state cannot be closed. */ static int *BrkInts[] = { &bb, &brklev, &brtn, &debug, &dotrace, &invokno, &lc, &lev, &port, &recons, &sklev, &spy, &Input, &Output, &usermode, (int*)0 }; static PTR *BrkPtrs[] = { &brkp, &c, &g, &pg, &vra, &vrz, (PTR*)&X, &x1, (PTR*)&V, &v1, (PTR*)&VV, &vv1, &tr, (PTR*)&d, (PTR*)&fl, (PTR*)&info, CellP(0) }; #ifdef DEBUG static void DumpVars(message) char *message; { fprintf(stderr, "bb\t%d\tbrklev\t%d\tbrtn\t%d\tdebug\t%d\n", bb, brklev, brtn, debug); fprintf(stderr, "dotrace\t%d\tinvokno\t%d\tlc\t%d\tlev\t%d\n", dotrace, invokno, lc, lev); fprintf(stderr, "port\t%d\trecons\t%d\tsklev\t%d\tspy\t%d\n", port, recons, sklev, spy); fprintf(stderr, "Input\t%d\tOutput\t%d\tbrkp\t%x\tc\t%x\n", Input, Output, brkp, c); fprintf(stderr, "g\t%x\tpg\t%x\tvra\t%x\tvrz\t%x\n", g, pg, vra, vrz); fprintf(stderr, "x\t%x\tx1\t%x\tv\t%x\tv1\t%x\n", X, x1, V, v1); fprintf(stderr, "vv\t%x\tvv1\t%x\ttr\t%x\n", VV, vv1, tr); fprintf(stderr, "\td\t%x\tfl\t%x\tusermode\t%d\n", d, fl, usermode); fprintf(stderr, "info\t%x\tsavead\t%x\t%s\n", info, savead, message); } #else !DEBUG # define DumpVars(x) #endif DEBUG static void savev(p, n) register PTR *p; /* starting at p */ register int n; /* save n vars */ { while (--n >= 0) *savead++ = *p++; } static void restv(p, n) register PTR *p; /* starting at p */ register int n; /* restore n vars */ { while (--n >= 0) *p++ = *savead++; } static void savevars() /* to enter a break */ { PTR nbrkp; register int **pi; register PTR **pp; savead = CellP(nbrkp = v+MaxFrame); for (pi = BrkInts; *pi; *savead++ = ConsInt(*(*pi++))) ; for (pp = BrkPtrs; *pp; *savead++ = *(*pp++)) ; DumpVars("Before Save"); vra = vrz, V = FrameP(savead), brkp = nbrkp, brklev++; LockChannels(TRUE); /* make Input, Output unclosable */ Input = STDIN, Output = STDOUT; DumpVars("After Save"); } static void restvars() /* to continue from a break */ { register int **pi; register PTR **pp; register PTR dum; /* for XtrInt !!! */ DumpVars("Before Restore"); savead = CellP(brkp); for (pi = BrkInts; *pi; dum = *savead++, *(*pi++) = XtrInt(dum)) ; for (pp = BrkPtrs; *pp; *(*pp++) = *savead++) ; DumpVars("After Restore"); LockChannels(FALSE); /* make Input, Output closable again */ } /*--------------------------------------------------------------------------- saving and restoring the Prolog state. On systems where character pointers and other pointers have different formats, the first argument of fread/fwrite has to be coerced to a character pointer, hence Fread/Fwrite. ---------------------------------------------------------------------------*/ static PTR PArea[NAreas]; /* original boundaries */ static Sint RArea[NAreas]; /* relocation constant */ static Sint LArea[NAreas+1]; /* length of area */ #define Patom PArea[AtomId] #define Paux PArea[AuxId] #define Ptr PArea[TrailId] #define Pheap PArea[HeapId] #define Pglb PArea[GlobalId] #define Plcl PArea[LocalId] #define Ratom RArea[AtomId] #define Raux RArea[AuxId] #define Rtr RArea[TrailId] #define Rheap RArea[HeapId] #define Rglb RArea[GlobalId] #define Rlcl RArea[LocalId] #define Latom LArea[AtomId] #define Laux LArea[AuxId] #define Ltr LArea[TrailId] #define Lheap LArea[HeapId] #define Lglb LArea[GlobalId] #define Llcl LArea[LocalId] #define Lsavep LArea[NAreas] static void save() /* save current prolog state */ { FILE *fa; # define Fwrite(var,sz,len,fl) Ignore fwrite(CharP(var),sz,len,fl) /* open file */ if (!(fa = fopen(AtomToFile(AtomP(X->v1ofcf)),"w"))) { ErrorMess = "! cannot write save-file"; Event(IO_ERROR); } errno = 0; /* no errors right now */ /* save state */ savevars(); /* create a break environment */ Lsavep = savead-CellP(lcl0); savev(CellP(BasicAtom), rqrdatoms); savev(CellP(BasicFunctor), rqrdfuncs); savev(&atprompt, 1); savev(&atomfp, 1); /* compute length of different stacks */ Latom = atomfp-atom0; Laux = vrz-auxstk0; Ltr = tr-tr0; Lheap = HeapTop()-heap0; Lglb = v1-glb0; Llcl = (savead-CellP(lcl0))+2; /* tag the save state with a magic mark and a version number */ Fwrite(savemagic, strlen(savemagic)+1, 1, fa); Fwrite(&saveversion, sizeof saveversion, 1, fa); Fwrite(LArea, sizeof LArea, 1, fa); Fwrite(Origin, sizeof(PTR), NAreas, fa); Fwrite(&list10, sizeof list10, 1, fa); Fwrite(Heap, HeapHeader, 1, fa); Fwrite(&brkp, sizeof brkp, 1, fa); Fwrite(&fileerrors, sizeof fileerrors, 1, fa); Fwrite(&leash, sizeof leash, 1, fa); { register Sint *pl = LArea; register PTR *ps = Origin; register int i = NAreas; while (--i >= 0) Fwrite(*ps++, sizeof(PTR), *pl++, fa); } Ignore fclose(fa); restvars(); if (errno != 0) { ErrorMess = SysError(); Event(IO_ERROR); } #ifdef unix chmod(AtomToFile(AtomP(X->v1ofcf)), 0755); /* on 4.1 or 4.2, saved states are executable */ #endif unix } /* The pause while Prolog loads a saved state is quite noticeable, at around 2 cpu seconds on a VAX 750. We would like it to go faster. Because the partitions in this run need not be the same size as in the run that saved the file, C Prolog has to chase around adding a suitable offset to every pointer. On a byte-addressed machine, or a 16-bit word-addressed machine, this involves scaling each offset by 4 or 2. Instead of letting C handle this, we scale the offsets ourselves once and for all, and do integer addition instead of PTR (or, with the stricter typing, CLAUSEP &c) addition. These macros for type breaking are needed anyway, as p+1 would be any number of words now that the types are stricter than PTR everywhere. There is an unfortunate machine dependency here: C Prolog ASSUMES that p+n = (typeof p)((Sint)p+k*n) for some type-dependent constant k, where p is a pointer. This is NOT true on many machines, such as the Orion, but usually it fails for pointers to 8-bit and 16-bit quantities only. As long as this assumption is true for pointers to 32-bit integers and pointers to other pointers, all should be well. */ #define REMAP1(c,n) *((Sint*)&(c)) += (n) #define REMAP2(c,d,n) *((Sint*)&(c)) = (Sint)(d)+(n) #define REMAPp(c,n) ((c) = (PTR)((Sint)(c)+(n))) #define REMAPc(c) ((c) = (CLAUSEP)((Sint)(c)+Rheap)) /** We can't use the ordinary type testing macros here, with the obvious exception of the macros for primitives, because they refer to the new partition boundaries, not to the boundaries in effect when the state was saved. Wasxxx is thus like Isxxx except it means old boundaries. It turns out that IsVar works as well. WasPtr means that the thing needs relocating; it is not quite the same thing as !IsPrim because on non-BACKWARDS machines we have !IsPrim(NULL) but nevertheless it should *not* be relocated! If C Prolog were a tagged system, or even if we could recognise an empty block, a functor block, a clause block, or a term by looking at the first word, we could remap everything in one linear sweep. However, while we need a recursive function for remapping terms(it is given the address of a pointer to the term), and while we use a hairy set of loops to walk over the data base, most of the time is spent just reading the file in. Not using stdio would make it run faster, but it would be less portable. */ #ifdef BACKWARDS # define WasPtr(c) SC(c,<,0) # define WasAtomic(c) SC(c,>=,Patom) # define WasAux(c) SC(c,<, Pglb) # define WasTr(c) SC(c,>=,Ptr) /* &WasAux */ # define WasHeap(c) SC(c,>=,Pheap) # define WasLcl(c) SC(c,>=,Plcl) /* &!WasAux &!WasHeap */ #else !BACKWARDS # define WasPtr(c) SC(c,>=,Paux) # define WasAtomic(c) SC(c,<, Pheap) # define WasAux(c) SC(c,<, Patom) # define WasTr(c) SC(c,>=,Ptr) # define WasHeap(c) SC(c,< ,Pglb) /* &!WasAux */ # define WasLcl(c) SC(c,>=,Plcl) /* &!WasAux &!WasHeap */ #endif BACKWARDS /* Remap the source term pointed to by tp. It can only be a primitive, an atom, or a pointer to a skeleton. */ static void remap(tp) register PTR *tp; { register PTR t = *tp; if (WasAtomic(t)) { if (WasPtr(t)) REMAP2(*tp,t,Ratom); } else if (!IsVar(t)) { register int n; REMAPp(t, Rheap), *tp = t, tp = CellP(t); REMAP1(*tp, Rheap); n = FunctorP(*tp)->arityoffe; while (--n >= 0) remap(++tp); } } static int restore(sfile) char *sfile; { FILE *fa; # define Fread(var,sz,len,fl) Ignore fread(CharP(var),sz,len,fl) /* Try to open the file. */ if ((fa = fopen(sfile,"r")) == NullF) { ErrorMess = SysError(); return FALSE; } /* Check that it is a saved Prolog state. */ { char magic[80]; Fread(magic, strlen(savemagic)+1, 1, fa); if (strcmp(magic, savemagic) != 0) { Ignore sprintf(ErrorMess = OutBuf, "! File %s is not a saved Prolog state", sfile); return FALSE; } } /* Check that the version is correct. */ { int version; Fread(&version, sizeof version, 1, fa); if (version != saveversion) { Ignore sprintf(ErrorMess = OutBuf, "! File %s is not compatible with this version of Prolog", sfile); return FALSE; } } /* Read and check the lengths. */ { register int a; register Sint newsize; Fread(LArea, sizeof LArea, 1, fa); for (a = NAreas; --a >= 0; ) { newsize = LArea[a] * sizeof (PTR); newsize = (((newsize/1024+1)*4)/3)* 1024; /* 33% extra */ if (newsize > Size[a]) { fprintf(stderr, "%% Expanding %s from %ldK to %ldK\n", AreaName[a], Size[a]/1024, newsize/1024); Size[a] = newsize; } } CreateStacks(); } Fread(PArea, sizeof PArea, 1, fa); Fread(&list10, sizeof list10, 1, fa); Fread(Heap, HeapHeader, 1, fa); Fread(&brkp, sizeof brkp, 1, fa); Fread(&fileerrors, sizeof fileerrors, 1, fa); Fread(&leash, sizeof leash, 1, fa); /* Compute the relocation constants. */ { register Sint *Rareap = RArea; register PTR *Originp = Origin, *Pareap = PArea; register int a = NAreas; while (--a >= 0) *Rareap++ = (Sint)*Originp++ - (Sint)*Pareap++; } /* Extract the stacks from the file. */ { Sint *Lareap = LArea; PTR *Originp = Origin; int a = -1; while (++a < NAreas) { register Sint length = *Lareap++; register PTR *stack = CellP(*Originp++); Fread(stack, sizeof *stack, length, fa); if (a != AtomId && a != HeapId) { /* relocate the stack contents */ while (--length >= 0) { register PTR elem = *stack; if (WasPtr(elem)) REMAPp(elem, WasAux(elem) ? (WasTr(elem) ? Rtr : Raux) : WasHeap(elem) ? (WasAtomic(elem) ? Ratom : Rheap) : (WasLcl(elem) ? Rlcl : Rglb)); *stack++ = elem; } } } } Ignore fclose(fa); savead = CellP(lcl0)+Lsavep; restv(CellP(BasicAtom), rqrdatoms); restv(CellP(BasicFunctor), rqrdfuncs); restv(&atprompt, 1); restv(&atomfp, 1); REMAP1(brkp, Rlcl); restvars(); /* NB: the various registers in the Prolog machine (those referred to in BrkEnv) have already been remapped because savevars() saves the environment in the local stack, whose contents have been remapped above (tricky, this one!) */ /* Remap the free space chains. */ RelocHeap(Rheap); remap(&list10); SetPlPrompt(AtomP(atprompt)->stofae); /* Remap the atom and heap areas. */ { PTR hashp, atomp, funcp; register PTR t; register CLAUSEP remapcl; # define remapfn FunctorP(t) for (hashp = hasha = atom0; hashp < hasha+HashSize; hashp++) { /* Remap this hash chain. */ for (atomp = hashp; /*while*/ *CellP(atomp) != NullP; /*doing*/ atomp = Addr(AtomP(*atomp)->nxtofae) ) { /* Remap all the functors for this atom. */ for (funcp = atomp; /*while*/ t = *CellP(funcp), t != NullP; /*doing*/ funcp = Addr(remapfn->nxtoffe) ) { if (funcp == atomp) { /* update atom block */ REMAPp(t, Ratom); } else { /* update functor block */ REMAPp(t, Rheap); remapfn->gtoffe = t; } /* remapfn is an alias of t */ *CellP(funcp) = t; /* update pointer to me */ REMAP1(remapfn->atoffe, Ratom); /* Remap the clause chain of remapfn, if it has one */ /* Frameless primitives have a non-NullC defsoffe */ /* which is nevertheless not a clause, care needed. */ if (WasPtr(remapcl = remapfn->defsoffe)) { remapfn->defsoffe = REMAPc(remapcl); /* remap each clause in the chain */ for (;; remapcl = remapcl->altofcl) { remap(&(remapcl->hdofcl)); remap(&(remapcl->bdyofcl)); if (remapcl->prevofcl != NullC) REMAPc(remapcl->prevofcl); if (remapcl->altofcl == NullC) break; /*END*/ REMAPc(remapcl->altofcl); if (remapcl->altofcl == remapcl) break; /*LOOP*/ } } /* Remap the record chain of remapfn, if it has one */ if ((remapcl = remapfn->dboffe) != NullC) { remapfn->dboffe = REMAPc(remapcl); /* remap each record */ for (;; remapcl = remapcl->altofcl) { REMAPp(remapcl->hdofcl, funcp == atomp ? Ratom : Rheap); remap(&(remapcl->bdyofcl)); if (remapcl->prevofcl != NullC) REMAPc(remapcl->prevofcl); if (remapcl->altofcl == NullC) break; /*END*/ REMAPc(remapcl->altofcl); } } } } } } return TRUE; } /*----------------------------------------------------------------------+ | | | Miscellaneous functions. | | | +----------------------------------------------------------------------*/ static void ResetTrail() { register PTR *a = CellP(tr0); register PTR *b = CellP(tr); DeclRegisters InitRegisters tr = (PTR)a; while (b != a) { register PTR e = *--b; if (IsRef(e)) { /* variable to reset */ VarVal(e) = NullP; } else { /* clause to erase */ register CLAUSEP cl = XtraDB(e); if (cl->infofcl & ERASED) hide(e); else cl->infofcl &= ~IN_USE; } } } static PTR bread() /* read initialization terms */ { PTR r; V = FrameP(lcl0), v1 = glb0, vrz = auxstk0, reading = FALSE; SetPlPrompt(" >> "); do PromptIfUser("boot>> "); while (!(r = pread(CellP(0)) )); return r; } void Halt(why) int why; /* 0->eval pred, 1->debug, 2->interrupt */ { #ifdef COUNTING int epno; double r = 4.0/(double)smpcnt; #endif COUNTING LockChannels(2); CloseFiles(); #ifdef COUNTING Ignore fclose(trace_file); fprintf(stderr, "\nAssorted counts.\n"); fprintf(stderr, "Max Local + Global stack + Trail = %ld + %ld + %ld\n", maxloc*sizeof(PTR), maxglo*sizeof(PTR), maxtr*sizeof(PTR)); fprintf(stderr, "Avg Local + Global stack + Trail = %ld + %ld + %ld\n", (Sint)(totloc*r), (Sint)(totglo*r), (Sint)(tottr*r) ); fprintf(stderr, "Call %ld Exit %ld Back %ld Fail %ld Next %ld\n", portct[CALL_PORT], portct[EXIT_PORT], portct[BACK_PORT], portct[FAIL_PORT], portct[NEXT_PORT]); fprintf(stderr, "Evaluable predicate counts:\n"); for (epno = 0; epno < NPREDS; epno++) fprintf(stderr, "%3d %5ld%c", epno, instrct[epno], (epno&3)==3 ? '\n' : '\t'); #endif COUNTING fprintf(stderr, "\n%% Prolog execution halted\n"); exit(why); } /*----------------------------------------------------------------------+ | | | The Prolog interpreter. | | It is divided into general initialisation, bootstrap loading, | | the four ports, the debugger interface, and the evaluable | | predicates. The latter are in their own file. | | | +----------------------------------------------------------------------*/ main(ArgC, ArgV) int ArgC; char *ArgV[]; { FUNCTORP f; /* the functor of the current goal (CALL only) */ int PredNo; /* index of evaluable predicate */ char *bn; /* initial file name, then scratch */ PTR k; /* scratch variable */ int n, i; /* scratch variables */ DeclRegisters /* keep glb0, heap0 in registers */ #ifdef COUNTING trace_file = fopen("#trace", "w"); #endif COUNTING /* our first Prolog event will be a cold start */ PrologEvent = COLD_START; /* Prolog events cause execution to resume fom here */ Ignore setjmp(ZeroState); InitRegisters; /* in case longjmp clobbered them */ CatchSignals(); /* prepare to handle signals etc. */ switch (PrologEvent) { /* Prolog event handling. Unix signals are mapped to Prolog events. Event(..) can also be used to force a Prolog event to occur. For conciseness, many of these cases fall through. */ case END_OF_FILE: /* input ended ('Seen' has been called) */ if (reading) { k = EndOfFile; /* return 'end_of_file' */ goto resumeread; /* jump into EvalPred block, UGH */ } ErrorMess = "! Input ended"; case IO_ERROR: /* files error */ if (fileerrors) goto FAIL; case GEN_ERROR: /* general error with message requiring abort */ fprintf(stderr, "\n%s\n", ErrorMess); case ABORT: /* abort */ aborting: fprintf(stderr, "\n\n%% execution aborted\n\n"); ResetTrail(); LockChannels(2); CloseFiles(); goto restart; case ARITH_ERROR: /* error in arithmetic expression */ fprintf(stderr, "\n! Error in arithmetic expression: %s\n", ErrorMess); debug = TRUE, sklev = NEVER_SKIP; goto FAIL; case COLD_START: /* cold start */ break; } InitIO(); /* initialise the I/O system */ /* process command line parameters */ bn = crack(ArgC, ArgV); if (!InBoot) { if (!State[QUIET]) { fprintf(stderr, "%% Restoring file %s\n", bn); } if (restore(bn)) { InitIO(); InitRegisters; /* set up glb0, heap0 registers */ running = TRUE; /* the system is now up and running */ if (brklev != 0) fprintf(stderr, "%% Restarting break (level %d)\n", brklev); TRY(unifyarg(Addr(X->v2ofcf), ConsInt(1), (PTR)0)); } fprintf(stderr, "%s\n", ErrorMess); exit(1); } fprintf(stderr, "%% Bootstrapping session. Initializing from file %s\n", bn); CSee(bn); /* we never need the file name again */ /* Create the memory partitions (normally done in restore) */ CreateStacks(); /* initialise atom area */ hasha = atom0, atomfp = atom0; for (i = HashSize; --i >= 0; *(ATOMP*)(atomfp++) = AtomP(0)) ; /* initialise read/print vars */ lc = TRUE, quoteia = FALSE; /* initialise heap */ InitHeap(); /* initialise I/O system */ fileerrors = FALSE; /* read required atoms */ for (i = 0; i < rqrdatoms; i++) BasicAtom[i] = (ATOMP)bread(); /* read required functors */ for (i = 0; i < rqrdfuncs; i++) BasicFunctor[i] = SkelFuncP(MolP(bread())->Sk); /* create term list10 */ k = list10 = getsp(27); for (i = 9; i > 0; i--) { SkelP(k)->Fn = listfunc, SkelP(k)->Arg1 = SkelGlobal(i), SkelP(k)->Arg2 = k+3, k += 3; } *CellP(list10+26) = SkelGlobal(0); /* Set top level termination */ /* On success: */ Yes->defsofae = ClauseP(_yes_); /* system pred number */ /* On failure: clause $no :- _no_ */ v1 = glb0; *CellP(v1++) = (PTR)No, *CellP(v1++) = ConsInt(_no_); ConsMol(Addr(arrowtag->gtoffe), glb0, pg); if (!record(CLAUSE, pg, (PTR)0, FALSE)) { fprintf(stderr, "\n! Fatal error in startup - consult wizard\n"); Stop(TRUE); } d = No->defsofae; /* Fail to itself */ d->altofcl = d; atprompt = atomnil; running = TRUE; /* boot is now running */ /* restart here after an abort etc. */ restart: InitRegisters; /* glbREG, heapREG */ vrz = auxstk0, tr = tr0, v1 = glb0; FileAtom[STDIN] = FileAtom[STDOUT] = useratom; dotrace = FALSE, brklev = 0, usermode = FALSE; if (!InBoot) { pg = live; goto go; } /* main loop during bootstrap session */ BootLoop: pg = bread(); g = IsaRef(pg) && !IsUnbound(pg) ? VarVal(pg) : pg; if (g == EndOfFile) { Seen(); InBoot = FALSE; goto restart; } if (IsaAtomic(g) || SkelFuncP(g) != provefunc) { if (!record(CLAUSE, pg, (PTR)0, FALSE)) { int telling = Output; fprintf(stderr, "%s\n", ErrorMess); Output = STDERR; pwrite(pg, (PTR) 0, 1200); Put('\n'); Output = telling; } goto BootLoop; } SetPlPrompt("| "); pg = arg(SkelP(g)->Arg1, MolP(pg)->Env); /* go - run the goal pg */ go: { register FRAMEP rV = FrameP(lcl0); X = rV, V = rV, VV = rV; rV->gofcf = (PTR)No, rV->altofcf = &(No->defsofae->altofcl), rV->gfofcf = rV->lcpofcf = rV, rV->gsofcf = vv1 = x1 = glb0, rV->trofcf = tr = tr0, rV->infofcf = FRM0, rV->cofcf = c = (PTR)Yes; } GrowLocal(szofcf); dotrace = FALSE, sklev = NEVER_SKIP, lev = 1, invokno = 0, usermode = FALSE; goto CALL; /*----------------------------------------------------------------------+ | | | CALL port | | | +----------------------------------------------------------------------*/ CALL: { register PTR PG = pg; /* pointer to goal */ if (IsaRef(PG)) x1 = MolP(PG)->Env, PG = MolP(PG)->Sk; g = PG, f = SkelFuncP(PG); } /* Now (g,x1) is a molecule describing the goal, and f is the */ /* principal functor of the goal. pg can be a skeleton or an */ /* atom or a molecule. Skeletons arise from "continuations", */ /* molecules from proper calls. pg is at least nonprimitive. */ #ifdef COUNTING portct[CALL_PORT]++; fprintf(trace_file, "%ld %ld %ld %ld\n", v-lcl0, v1-glb0, x-lcl0, x1-glb0); #endif COUNTING if (!usermode) { info = lev|FRM0; } else { bb = f->flgsoffe; if (!(bb & INVISIBLE)) invokno++; info = (invokno<>1)&1, dotrace &= 1; brtn = 3; savevars(); pg = breakat; goto CALL; } dotrace = FALSE, sklev = NEVER_SKIP; } if (lev <= sklev || (bb&spy)) goto message; ret_call:; /* return here from message */ f = SkelFuncP(g); /* no longer saved */ } } { register CLAUSEP D = f->defsoffe; /* Note: system predicates have numbers 1..255 stored directly, and Null is 0. These satisfy the IsAtomic test, but except on BACKWARDS machines they do NOT satisfy the IsPrim test. */ if (IsaAtomic(D)) { if (D == NullC) { if (!usermode /* running system code */ || !unknown /* not checking */ || bb&SPY_ME /* user is spying it */ || !IsaAtomic(f) && f->moreflgs != 0 ) goto FAIL; /* don't complain */ Ignore sprintf(ErrorMess = OutBuf, "! %s/%d is undefined", f->atoffe->stofae, f->arityoffe); goto ERROR; } PredNo = Signed(D); /* 1..255 */ goto EvalPred; } while (D->infofcl & ERASED) if ((D = D->altofcl) == NullC) goto FAIL; d = D; /* d is the first remaining clause for f */ } { register FRAMEP rV = V; if ((PTR)rV > vmax) NoSpace(LocalId); rV->gofcf = pg, rV->gfofcf = X, rV->lcpofcf = VV, rV->gsofcf = vv1 = v1, rV->trofcf = tr, rV->infofcf = info, rV->cofcf = c, VV = rV; } goto BACK; /*----------------------------------------------------------------------+ | | | try the next clause | | (CALL+REDO ports) | | | +----------------------------------------------------------------------*/ BACK: #ifdef COUNTING portct[BACK_PORT]++; #endif COUNTING { PTR v1t = v1; /* local copy of v1 (which changes) */ #ifdef USEREGS PTR vt = v; /* local copies of v, x, and x1 */ PTR x1t = x1; /* are made on the VAX and Orion */ PTR xt = x; /* to use short fast addresses */ #else !USEREGS # define vt v # define x1t x1 # define xt x #endif USEREGS TryClause: /* Initialse the local and global variables of this clause to NullP */ { register PTR *vp; register int vn; for (vn = d->gvofcl, vp = CellP(v1t); --vn >= 0; *vp++ = NullP) ; v1 = (PTR)vp; for (vn = d->ltofcl, vp = &(V->v1ofcf); --vn >= 0; *vp++ = NullP) ; } /* Try to unify the head of the clause with the goal */ if (!IsaAtomic(g)) { PTR tb = g; PTR ta = d->hdofcl; int arity = SkelFuncP(ta)->arityoffe; register PTR a, b, pa, pb; /* main unification loop */ while (--arity >= 0) { b = NextArg(tb); a = NextArg(ta); if (IsaVar(a)) { pa = FrameVar(a, v1t, vt); while (IsaRef(a = VarVal(pa))) pa = a; if (IsaVar(b)) { pb = FrameVar(b, x1t, xt); while (IsaRef(b = VarVal(pb))) pb = b; if (pa == pb) { } else if (Undef(b)) { if (!Undef(a)) { VarVal(pb) = IsaAtomic(a) ? a : pa; TrailReg(pb); } else if (pa > pb) { VarVal(pa) = pb; TrailReg(pa); } else { VarVal(pb) = pa; TrailReg(pb); } } else if (Undef(a)) { VarVal(pa) = IsaAtomic(b) ? b : pb; TrailReg(pa); } else if (IsaAtomic(a)) { if (a != b) goto TryNextClause; } else if (IsaAtomic(b) || !gunify(a, MolP(pa)->Env, b, MolP(pb)->Env)) goto TryNextClause; } else if (Undef(a)) { if (IsaAtomic(b)) VarVal(pa) = b; else ConsaMol(b, x1t, pb, pa); TrailReg(pa); } else if (IsaAtomic(b)) { if (a != b) goto TryNextClause; } else if (IsaAtomic(a) || !gunify(a, MolP(pa)->Env, b, x1t)) goto TryNextClause; } else if (IsaVar(b)) { pb = FrameVar(b, x1t, xt); while (IsaRef(b = VarVal(pb))) pb = b; if (Undef(b)) { if (IsaAtomic(a)) VarVal(pb) = a; else ConsaMol(a, v1t, pa, pb); TrailReg(pb); } else if (IsaAtomic(b)) { if (a != b) goto TryNextClause; } else if (IsaAtomic(a) || !gunify(a, v1t, b, MolP(pb)->Env)) goto TryNextClause; } else { if (IsaAtomic(a)) { if (a != b) goto TryNextClause; } else if (IsaAtomic(b) || !gunify(a, v1t, b, x1t)) goto TryNextClause; } } } /* end in-line unification */ if (v1 > v1max) NoSpace(GlobalId); /* We found a clause whose head matches, so enter it */ { register CLAUSEP D = d; register PTR C = D->bdyofcl; register FRAMEP rV = V; rV->altofcf = fl = &(D->altofcl); if (!debug && D->altofcl == NullC) VV = rV->lcpofcf, vv1 = VV->gsofcf; V = FrameP((PTR)rV + (szofcf + D->lvofcl)); if (!(D->infofcl & IN_USE)) { D->infofcl |= IN_USE; TrailPtr(ConsaDB(D, CLAUSE)); } if (C == NullP) { pg = rV->gofcf; goto neckfoot; } X = rV, x1 = v1t; if (usermode && !(bb & INVISIBLE)) { if (bb & PROTECTED) usermode = FALSE; else lev++; } if (IsPrim(C)) { PredNo = XtrByte(C); c = NullP; goto EvalPred; } if (SkelFuncP(C) == commatag) { pg = SkelP(C)->Arg1, c = SkelP(C)->Arg2; } else { pg = C, c = NullP; } } goto CALL; /* When the head unification fails, we jump to TryNextClause. */ /* If that finds another candidate, we jump to TryClause. */ /* If not, we proceed to FAIL. This is "shallow backtracking". */ TryNextClause: #ifdef COUNTING portct[NEXT_PORT]++; #endif COUNTING { /* Reset the trail */ register PTR *a = CellP(V->trofcf), *b = CellP(tr); while (b != a) VarVal(*--b) = NullP; tr = (PTR)a; } { /* Look for another clause */ register CLAUSEP D = d; while ((D = D->altofcl) != NullC) if (!(D->infofcl & ERASED)) { d = D, v1 = v1t; goto TryClause; } } VV = V->lcpofcf; goto FAIL; } /*----------------------------------------------------------------------+ | | | EXIT port | | | +----------------------------------------------------------------------*/ /* This seems to be the best place for gathering statistics about the */ /* stack sizes. There are two versions of the exit code proper, both */ /* of them do the same thing, but the non-debugging version should be */ /* rather faster, especially when exit follows exit as often happens. */ EXIT: #ifdef COUNTING { register Sint t; t = v - lcl0; if (t > maxloc) maxloc = t; totloc += t; t = v1 - glb0; if (t > maxglo) maxglo = t; totglo += t; t = tr - tr0; if (t > maxtr ) maxtr = t; tottr += t; smpcnt++; } portct[EXIT_PORT]++; #endif COUNTING if (!debug) { register FRAMEP rX = X; register PTR C = c; while (C == NullP) { if (rX > VV) V = rX; C = rX->cofcf, info = rX->infofcf, rX = rX->gfofcf; } lev = info&LEVEL, usermode = IsVisible(info); X = rX, x1 = rX->gsofcf; if (SkelFuncP(C) == commatag) { pg = SkelP(C)->Arg1, c = SkelP(C)->Arg2; } else { pg = C, c = NullP; } goto CALL; } { register FRAMEP rX = X; register PTR C = c; if (C != NullP) { /* there is a continuation */ x1 = rX->gsofcf; if (SkelFuncP(C) == commatag) { pg = SkelP(C)->Arg1, c = SkelP(C)->Arg2; } else { pg = C, c = NullP; } goto CALL; } if (rX > VV) V = rX; c = rX->cofcf, pg = rX->gofcf, X = rX->gfofcf, info = rX->infofcf; lev = info&LEVEL, usermode = IsVisible(info); } neckfoot: if (debug && usermode) { /* Basic debugging package: trace EXIT */ register PTR PG = pg; if (IsaRef(PG)) { g = MolP(PG)->Sk, x1 = MolP(PG)->Env; } else { g = PG, x1 = X->gsofcf; } port = EXIT_PORT, bb = SkelFuncP(g)->flgsoffe; if ((lev <= sklev || (bb&spy)) && !(bb&(INVISIBLE|UNTRACEABLE))) goto message; /* which returns to EXIT */ } goto EXIT; /*----------------------------------------------------------------------+ | | | FAIL port ! | | +----------------------------------------------------------------------*/ ERROR: fprintf(stderr, "\n%s\n", ErrorMess); debug = TRUE, sklev = NEVER_SKIP; cutfail: if (VV >= X) VV = X->lcpofcf; FAIL: /* deep backtracking */ #ifdef COUNTING portct[FAIL_PORT]++; #endif COUNTING { register FRAMEP rV; /* local copy of VV */ register CLAUSEP D; /* local copy of d */ if (debug) { if (usermode) { /* Basic debugging package: trace FAIL */ port = FAIL_PORT, bb = SkelFuncP(g)->flgsoffe; if ((lev <= sklev || (bb&spy)) && !(bb&(INVISIBLE|UNTRACEABLE))) goto message; ret_fail:; /* message returns here */ } rV = VV; for (D = *(rV->altofcf); D != NullC && (D->infofcl & ERASED); D = D->altofcl) ; i = !(rV == X && c == NullP); /* !fail_parent */ } else { /* ! debug */ for (rV = VV; ; rV = rV->lcpofcf) { for (D = *(rV->altofcf); D != NullC && (D->infofcl & ERASED); D = D->altofcl) ; if (D != NullC) break; } } X = rV->gfofcf, pg = rV->gofcf, c = rV->cofcf, info = rV->infofcf; lev = info&LEVEL, usermode = IsVisible(info), vv1 = v1 = rV->gsofcf, VV = V = rV, d = D; } /* ResetTrail(V->trofcf); */ { register PTR *a = CellP(V->trofcf); register PTR *b = CellP(tr); tr = (PTR)a; while (b != a) { register PTR e = *--b; if (IsaRef(e)) { VarVal(e) = NullP; } else { register CLAUSEP cl = XtraDB(e); if (cl->infofcl & ERASED) hide(e); else cl->infofcl &= ~IN_USE; } } } /* we have arrived back at a likely candidate for retrial */ /* the next thing would be to jump straight to BACK, except */ /* that we want to trace this event. (Almost REDO). */ { register PTR PG = pg; /* pointer to goal */ if (IsaRef(PG)) x1 = MolP(PG)->Env, PG = MolP(PG)->Sk; else /*atom*/ x1 = X->gsofcf; g = PG, bb = SkelFuncP(PG)->flgsoffe; } if (!debug) goto BACK; /* already know d != NullC */ if (i && usermode) { /* Basic debugging package: trace BACK */ port = BACK_PORT; if ((lev < sklev || (bb&spy)) && !(bb&(INVISIBLE|UNTRACEABLE))) goto message; ret_back:; /* message returns here */ } if (d != NullC) goto BACK; VV = VV->lcpofcf; goto FAIL; /*----------------------------------------------------------------------+ | | | A minimal 4-port debugging package. | | This is a quasi-procedure for displaying messages. | | It jumps to ret_call, EXIT, or ret_back, or ret_fail | | | is the goal being traced. | | | +----------------------------------------------------------------------*/ message: Ignore sprintf(OutBuf, "%c%c (%3ld) %2ld %s: ", bb & SPY_ME ? '*' : ' ', /* spy-point? */ lev == sklev ? '>' : ' ', /* return to skip? */ (info>>LEVEL_WIDTH) & CALL_NUMBER, /* sequential call number */ info & LEVEL, /* depth of call */ portname[port]); /* which of the 4 ports? */ { int telling = Output; Output = STDOUT; /* STDERR is not folded drat */ PutString(OutBuf); /* header has to be folded too */ pwrite(g, x1, 1200); if (leash & portmask[port]) { /* ask at this sort of port? */ PutString(" ? "); Output = telling; } else { /* just tracing */ Put('\n'); Output = telling; goto action; } } switch (get_in_char()) { case '\n': case 'c': /* creep */ spy = FALSE, sklev = NEVER_SKIP; goto action; case 'l': /* leap */ spy = SPY_ME, sklev = 0; goto action; case 's': /* skip */ if (port == EXIT_PORT || port == FAIL_PORT) { fprintf(stderr, "! can't skip at this port\n"); goto message; } spy = FALSE, sklev = info&LEVEL; goto action; case 'q': /* quasi-skip */ if (port == EXIT_PORT || port == FAIL_PORT) { fprintf(stderr, "! can't quasi-skip at this port\n"); goto message; } spy = SPY_ME, sklev = info&LEVEL; goto action; case 'r': /* retry */ { register PTR *a; register PTR *b = CellP(tr); FRAMEP fame = VV; int n1, n2, n; n1 = n = get_number(); n2 = invokno = (info>>LEVEL_WIDTH) & CALL_NUMBER; lev = (info & LEVEL); if (n == 0) n = invokno; while (((fame->infofcf>>LEVEL_WIDTH) & CALL_NUMBER) > n) fame = fame->lcpofcf; spy = FALSE; sklev = NEVER_SKIP; if ((port != CALL_PORT || fame != VV) && (port != FAIL_PORT || fame != VV)) { V = fame; X = V->gfofcf; VV = V->lcpofcf; v1 = V->gsofcf; x1 = X->gsofcf; vv1 = VV->gsofcf; pg = V->gofcf; c = V->cofcf; info = V->infofcf; lev = (info & LEVEL); invokno = ((info>>LEVEL_WIDTH) & CALL_NUMBER); /* ResetTrail(V->trofcf); */ a = CellP(V->trofcf); tr = (PTR)a; while (b != a) { register PTR e = *--b; if (IsaRef(e)) { VarVal(e) = NullP; } else { register CLAUSEP cl = XtraDB(e); if (cl->infofcl & ERASED) hide(e); else cl->infofcl &= ~IN_USE; } }}; if (n1 == 0 || n2 == invokno) fprintf(stderr,"[ retry ]\n"); else fprintf(stderr,"[** jump **]\n"); invokno--; goto CALL; } case 'f': /* fail */ if (port == BACK_PORT) VV = VV->lcpofcf; spy = FALSE, sklev = NEVER_SKIP; goto FAIL; case 'e': /* exit */ Halt(0); case 'a': /* abort */ goto aborting; case 'b': /* break */ brtn = 2; savevars(); pg = breakat; goto CALL; case 'g': /* backtrace */ backtrace(); goto message; case 'n': /* turn debug mode off */ debug = FALSE; goto action; default: fprintf(stderr, "! Unknown option. Known ones are\n"); case 'h': /* help */ case '?': fprintf(stderr, "\ creep a abort\n\ c creep f fail\n\ l leap b break\n\ s skip h help\n\ q quasi-skip n nodebug\n\ r retry r retry goal \n\ e exit prolog g write ancestor goals\n"); goto message; } action: switch (port) { case CALL_PORT: goto ret_call; case EXIT_PORT: goto EXIT; case FAIL_PORT: goto ret_fail; case BACK_PORT: goto ret_back; } EvalPred: #include "evalp.c" }