{Portable Prolog Data Base Manager}

{Comment flags:      VAX EMAS APM}

!VAX! %include "Prolog_Interpreter:GDec.Inc"
!EMAS!%include "ECSC56.GDec#Inc"
{APM} %include "IPlog:GDec.Inc"

%external %STRING(255) %spec ERRORMES

%constant %integer REFBITS = 16_80000000, 
                   DBIT    = 16_20000000

%external %integer %spec LCL0, 
                         GLB0, 
                         SKEL0, 
                         ATOM0, 
                         COMMATAG, 
                         CALLTAG,
                         ARROWTAG,
                         VRA, 
                         VRZ

%EXTERNALINTEGERFNSPEC ARGV(%INTEGER T,F,%INTEGERNAME AF)
%EXTERNALINTEGERFNSPEC GETSP(%INTEGER L)
%EXTERNALROUTINESPEC RELEASEP(%INTEGER P, L)
%EXTERNALROUTINESPEC RELEASEC(%INTEGER P)

{-RECORD-}

%external %integer %function RECORD (%INTEGER KEY, T, RK, AORZ)

   %INTEGER %ARRAY VID (0:256), 
                   VN  (0:256)
   %INTEGER NVARS, 
            LEV, 
            R, 
            I, 
            K, 
            NT,
            NL, 
            NG, 
            TOO MANY, 
            REFS FLG, 
            HEAD, 
            BODY,
            ON HEAD,
            F,
            G

   %constant %integer OCCURS TWICE   = 1, 
                      OCCURS ON HEAD = 2, 
                      OCCURS ON BODY = 4, 
                      GLOBAL VAR     = 8

   {-LOOK UP-}

   %INTEGERFN LOOKUP(%INTEGER VI)
      ! lookup a variable
      %INTEGER I

      I = -1
      %WHILE I < NVARS %CYCLE
         I = I + 1
         %RESULT=I %IF VID (I) = VI
      %REPEAT
      TOOMANY = 1 %AND %RESULT = 254 %IF NVARS = 254
      NVARS = NVARS + 1
      VID (NVARS) = VI
      VN (NVARS) = 0
      %RESULT = NVARS
   %END {Look Up}

   {-HEAPIFY-}

   %INTEGERFN HEAPIFY(%INTEGER T,G)
      %INTEGER N,P1,P2,F

      REFS FLG = 1 %IF T < 0 %AND %c
                       T&INT0 = REF BITS
      %RESULT = T %IF T < SKEL0
      %IF INTEGER (T) = 0 %START
         N = LOOK UP (T)
         P2 = VN (N)
         P2 = P2!OCCURS TWICE %IF P2 # 0
         %IF ON HEAD # 0 %THEN P2 = P2!OCCURS ON HEAD %C
                         %ELSE P2 = P2!OCCURS ON BODY
         P2 = P2!GLOBAL VAR %IF LEV > 1
         VN (N) = P2
         P2 = GLB0 + N
            {Changed ! to +}
         %IF LEV = 0 %AND %c
             ON HEAD = 0 %START
            P1 = GET SP (8)
            INTEGER (P1) = CALL TAG
            INTEGER (P1 + 4) = P2
            %RESULT = P1
         %FINISH

         %RESULT = P2
      %FINISH
      G = INTEGER (T + 4) %AND T = INTEGER (T) %IF T >= GLB0
      N = BYTE INTEGER (INTEGER (T) + ARITY OF FE)
      P1 = GET SP ((N + 1)<<2)
      INTEGER (P1) = INTEGER (T)
      P2 = P1
      LEV = LEV + 1
      %WHILE N > 0 %CYCLE
         P2 = P2 + 4
         T = T + 4
         INTEGER (P2) = HEAPIFY (ARGV (T, G, F), F)
         N = N - 1
      %REPEAT
      LEV = LEV - 1
      %RESULT = P1
   %END {Heapify}

   {-HEAPIFY BODY-}

   %integer %function Heapify Body (%integer T, G)
      %INTEGER P1, F
   
      %RESULT = HEAPIFY (T, G) %IF T < SKEL0 %OR %c
                                   INTEGER (T) = 0
      G = INTEGER (T + 4) %AND T = INTEGER (T) %IF T >= GLB0
      %IF INTEGER (T) = COMMA TAG %START
         P1 = GET SP (12)
         INTEGER (P1) = COMMA TAG
         INTEGER (P1 + 4) = HEAPIFY (ARGV (T + 4, G, F), F)
         INTEGER (P1 + 8) = HEAPIFY BODY (ARGV (T + 8, G, F), F)
         %RESULT=P1
      %FINISH
      %RESULT = HEAPIFY (T, G)
   %END {Heapify Body}

   {-SCAN-}

   %ROUTINE SCAN (%INTEGER C)
      %INTEGER N,
               Offset

      %IF INTEGER (C) >= GLB0 %START

         Offset = INTEGER (C)
{*         %if Offset >= LCL0 %start
{*            Offset = Offset - LCL0
{*         %else
Print String ("Help Ma Boab in DBASE") %and %stop %unless GLB0 <= Offset < LCL0
            Offset = Offset - GLB0
{*         %finish
         INTEGER (C) = VN (Offset)
         %RETURN
      %FINISH
      %RETURN %IF INTEGER (C) < SKEL0
      C = INTEGER (C)
      N = BYTE INTEGER (INTEGER (C) + ARITY OF FE)
      %WHILE N > 0 %CYCLE
         C = C + 4
         SCAN (C)
         N = N - 1
      %REPEAT
   %END {Scan}

   {-MAIN CODE OF RECORD-}


   NVARS = -1
   TOO MANY = 0
   REFS FLG = 0
   G = INTEGER (T + 4) %AND T = INTEGER (T) %IF T >= GLB0 %AND %c
                                                INTEGER (T) # 0
   -> DBASE %IF KEY=DB OF FE

   {Asserting a clause}
   LEV=0
   ONHEAD=1
   %IF T>=SKEL0 %AND %c
       INTEGER(T)=ARROWTAG %START
      HEAD = HEAPIFY (ARGV(T + 4, G, F), F)
      ON HEAD = 0
      BODY = HEAPIFY BODY (ARGV (T + 8, G, F), F)
   %ELSE
      HEAD=HEAPIFY(T,G)
      BODY=0
   %FINISH

   %IF HEAD>=GLB0 %START
      ERROR MES="! Clause Head is a variable (Assert)"
      ->ERROR EXIT
   %FINISH
   %IF HEAD<0 %START
      ERROR MES = "! Clause Head is an integer (Assert)"
      -> ERROR EXIT
   %FINISH
   R = INTEGER (HEAD)
   %IF BYTE INTEGER (R + FLGS OF FE)&RESERVED FLAG # 0 %START
      ERROR MES = "! Attempt to redefine a system predicate"
      ->ERROR EXIT
   %FINISH

   %IF RK # 0 %AND %c
       TOO MANY = 0 %AND %c
       REFSFLG = 0 %START
      {reconsulting}
      I = VRA
      %WHILE I < VRZ %CYCLE
         -> Done %IF INTEGER (I) = R 
         I=I+4
      %REPEAT
      I = INTEGER (R + DEFSOFFE)
      %WHILE I#0 %CYCLE
         %IF BYTE INTEGER (I + INF OF CL) = 0 %START
            RELEASE C (INTEGER (I + BDY OF CL))
            RELEASE C (INTEGER (I + HD OF CL))
            RELEASEP (I, SZ OF CL)
         %ELSE 
            BYTE INTEGER (I + INF OF CL) = %c
               BYTE INTEGER (I + INF OF CL) ! ERASE FLAG
         %finish
         I = INTEGER (I + ALT OF CL)
      %REPEAT
      INTEGER (VRZ) = R
      VRZ = VRZ + 4
      INTEGER (R + DEFS OF FE) = 0
   %FINISH

DONE: 
   RK = R
   -> INSERT
   
DBASE:         {inserting a item on the data base}
   %IF RK>=GLB0 %START
      RK=INTEGER(RK)
      RK=INTEGER(RK) %IF RK>=SKEL0
   %FINISH
   ERRORMES="! Illegal key (Record)" %AND %RESULT=0 %UNLESS ATOM0<=RK<GLB0
   HEAD=RK
   LEV=1
   BODY=HEAPIFY(T,G)
   
INSERT:

   %IF TOO MANY # 0 %START
     ERROR MES = "! Too many variables in term or clause being recorded" 
     -> ERROR EXIT
   %FINISH
   %IF REFS FLG # 0 %START
      ERROR MES = "! Term or clause being recorded contains references"
      -> ERROR EXIT
   %FINISH

   R = GET SP (SZ OF CL)
   INTEGER (R + HD OF CL) = HEAD
   INTEGER (R + BDY OF CL) = BODY
   NG = 0
   NL = 0
   NT = 0
   I  = -1
   %WHILE NVARS > I %CYCLE
      I = I + 1
      %IF VN (I)&GLOBAL VAR # 0 %START
         VN(I) = GLB0 + (NG<<2)
            {Changed from ! to +}
         NG = NG + 1
      %ELSE
         %IF VN (I)&OCCURS ON BODY # 0 %START
            VN (I) = LCL0 + V1 OF CF + NL<<2
            NL = NL + 1
         %ELSE 
            VN (I) = NT<<2 
            NT = NT + 1
         %finish
      %FINISH
   %REPEAT
   %IF NT > 0 %START
      K = LCL0 + V1 OF CF + NL<<2
      %for I= 0, 1, NVARS %cycle
         VN (I) = VN (I) + K %IF VN (I) < 1024
      %REPEAT
   %FINISH
   BYTE INTEGER (R + INF OF CL) = 0             {Information}
   BYTE INTEGER (R + LT  OF CL) = NL + NT       {Locals and Temps}
   BYTE INTEGER (R + LV  OF CL) = NL            {Locals}
   BYTE INTEGER (R + GV  OF CL) = NG            {Globals}

   SCAN (ADDR (BODY)) %IF BODY # 0
   SCAN (ADDR (HEAD)) %IF KEY = DEFSOFFE

   %IF INTEGER (RK + KEY) = 0 %START
      INTEGER (R + ALT OF CL) = 0
      INTEGER (RK + KEY) = R
      -> EXIT
   %FINISH
   %IF A OR Z # 0 %START
      INTEGER (R + ALT OF CL) = INTEGER (RK + KEY)
      INTEGER (RK + KEY) = R
      ->EXIT
   %FINISH
   I = INTEGER (RK + KEY)
   I = INTEGER (I + ALT OF CL) %WHILE INTEGER (I + ALT OF CL) # 0
   INTEGER (I + ALT OF CL) = R
   INTEGER (R + ALT OF CL) = 0
EXIT:  
   R = (R - SKEL0)!REFBITS

   R = R!DBIT %IF KEY = DB OF FE
   %RESULT=R
   
ERROR EXIT: 
   RELEASE C (HEAD)
   RELEASE C (BODY)
   %RESULT=0
%END {-Record-}

{-ERASE-}

{erase term pointed to by reference r}

%external %integer %function Erase (%INTEGER R)
   %INTEGER KEY,C,K

   %IF R&INT0#REFBITS %START
     ERRORMES="! Erase arg is not a reference"
     %RESULT=0
   %FINISH
   %IF R&DBIT#0 %THEN KEY=DBOFFE %c
                %ELSE KEY=DEFSOFFE

   {-hazard-}
!!!Print String ("Passing possible hazard in ERASE"); New Line
   C=R&16_FFFFFFF+SKEL0
   {-drazah-}

   R=INTEGER(C+HDOFCL)
   R=INTEGER(R) %IF KEY=DEFSOFFE
   %IF BYTEINTEGER(R+FLGSOFFE)&RESERVEDFLAG#0 %START
     ERRORMES="! Attempt to erase a system flag"
     %RESULT=0
   %FINISH
   R=R+KEY
   R=INTEGER(R)+ALTOFCL %WHILE R#0 %AND INTEGER(R)#C
   %IF R=0 %START
     ERROR MES="! Arg of erase or retract has already been erased"
    %RESULT=0
   %FINISH
   INTEGER(R)=INTEGER(C+ALTOFCL)
   BYTEINTEGER(C+INFOFCL)=BYTEINTEGER(C+INFOFCL)!ERASEFLAG
   %RESULT=1
%END {Erase}

%ENDOFFILE
