(* hashs.pas: Please see the end of Draak.pas for copyright information       *)
(* This file may NOT be distributed without Draak.pas and is under the same   *)
(* licence agreement as Draak.pas.                                            *)
unit hashs;

interface
uses error;

Const HashSize = 50;
type
  AtomType = (Macro, Terminal, NonTerminal, id, str, num, hex, oct, bin);

  strArr = array of string;
  varArr = array[0..9] of string;

  PHashAtom = ^RHashAtom;
  RHashAtom = record
    next: PHashAtom;
    optional, star: boolean;
    case term: AtomType of
      Terminal: (terminal: PChar);
      NonTerminal: (nonTerminal: PChar; hashCode: word);
      Macro: (Macro: PChar;)
  end;

  PHashNode = ^RHashNode;
  RHashNode = record
    name: string;
    next: PHashNode;
    special: boolean;
    RHS, lastRHS: PHashAtom;
    Macros, lastMacro: PHashAtom;
  end;


  PHash = ^THash;
  THash = class
    private
      optin, star{, plus}: boolean;
      table: array[0..HashSize] of PHashNode;
      current: PHashNode;
    public
      procedure add(const named: string);
      procedure addRHS(const inS: string);
      procedure addToRHS(const s: string);
      procedure addMacro(const s: string);
      procedure clearCurrent;
      function hashLookup(const S: string): PHashNode; overload;
      function hashLookup(const S: string; hint: word; count: word = 0): PHashNode; overload;
  end;

  PVarNode = ^RVarNode;
  RVarNode = record
    name: string;
    next: PVarNode;
    isvar: boolean;
    baseType, nameType: string;
    equiv: strArr;
    local: varArr;
    typePtr: PVarNode;
    size: word;
    context: pointer;
    RHS, lastRHS: PHashAtom;
    LHS, lastLHS: PHashAtom;
//    ALT,
    lastALT: PHashAtom;
    ALT: array of PHashAtom;
    Decl, lastDecl: PHashAtom;
    altDecl, lastAltDecl: PHashAtom;
  end;

  PVars = ^TVars;
  TVars = class
    private
      name: string;
      table: array[0..HashSize] of PVarNode;
      current: PVarNode;
      hard: boolean;
      next: TVars;
      first: TVars;
      err: TError;
    public
      property harden: boolean write hard;
      constructor Create(const named: string; nextHash: TVars; error: TError);
      destructor destroy; override;
      procedure addVar(const named: string; const typed: string);
      procedure addType(const named: string; const base: string);
      procedure addBasedType(const named: string; const base: string);
      procedure attachType(const s: string);
      procedure addLHS(const s: string);
      procedure addRHS(const s: string);
      procedure addALT(const s: string);
      procedure addDecl(const s: string);
      procedure addAltDecl(const s: string);
      procedure clearCurrent;
      function pop: TVars;
      function isEquiv(const s, base: string): boolean;
      procedure addEquiv(const s, base: string);
      procedure saveLocal(const s: varArr);
      function getLocal(const s: string): varArr;
      procedure saveContext(context: TVars);
      function loadContext(const s: string): TVars;
      function hashLookup(const S: string; deep: integer = -1): PVarNode;
      procedure dump;
      procedure rmVar(const named: string);
//TODO      function getVarBlock(const S: string): TVars;
  end;

  PStringHash = ^RStringHash;
  RStringHash = record
    name: string;
    data: strArr;
    next: PStringHash;
  end;
 
  TStringHash = class
    private
      table: array[0..HashSize] of PStringHash;
    public
      destructor destroy; override;
      procedure add(s: string; data: string);
      procedure remove(s: string);
      procedure removeStr(s: string; data: string);
      procedure removeStrEnd(s: string; data: string);
      procedure inc(s, num: string);
      procedure append(s, data: string);
      procedure strictAppend(s, data: string);
      procedure insert(s, data: string);
      function first(s: string): string;
      function last(s: string): string;
      function len(s: string): string;
      function pos(s, data: string): string;
      function getSubStr(s: string; n: word): string;
      function lookup(s: string): strArr;
  end;

  function hash(s: string): word;

implementation

uses SysUtils, StrUtils, classes, draak;

function hash(s: string): word;
const hashCode = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789';
var i: word; tempHash: integer;
begin
  tempHash := 0; s := AnsiUpperCase(s);
  for i := 1 to length(s) do
  begin
    tempHash := tempHash + AnsiPos(s[i], hashCode);
  end;
  result := tempHash MOD HashSize;
end;

procedure THash.add(const named: string);
var dumbNode: PHashNode;
  hashCode: word;
begin
  new(dumbNode);
  dumbNode.special := false;
  dumbNode.name := named;
  hashCode := hash(named);
  dumbNode.next := table[hashCode];
  dumbNode.RHS := nil; dumbNode.lastRHS := nil;
  dumbNode.Macros := nil; dumbNode.lastMacro := nil;
  table[hashCode] := dumbNode;
  current := dumbNode;
end;

procedure THash.addRHS(const inS: string);
var s, tempS: string;
  posStr: word;
begin
  optin := false;
  s := inS;
  while s <> '' do
  begin
    case s[1] of
     ' ':
      begin
        delete(s, 1, 1);
        continue;
      end;
     '{':
      begin
        delete(s, 1, 1);
        optin := true;
      end;
     '}':
      begin
        delete(s, 1, 1);
        optin := false;
      end;
     '*':
      begin
       star := false;
       optin := false;
       delete(s, 1, 1);
      end;
     '<':
      begin
        posStr := AnsiPos('>', s);
        if s[posStr+1] = '*' then star := true else star := false;
        addToRHS(leftStr(s, posStr));
        delete(s, 1, posStr);
        tempS := '';
      end;
     else
      begin
        posStr := AnsiPos('<', s);
        if (s[1] = '\') AND (s[2] = '*') then
          delete(s, 1, 1);
        if posStr <> 0 then
        begin
          if s[posStr-1] = '\' then
          begin
            delete(s, posStr-1, 1);
            tempS := tempS + leftStr(s, posStr-1);
            delete(s, 1, posStr-1);
            continue;
          end else
          if s[posStr-1] = '{' then
            dec(posStr);
        end else posStr := length(s)+1;
        if tempS <> '' then if tempS[1] = '<' then insert(' ', tempS, 1);
        addToRHS(tempS + leftStr(s, posStr-1));
        delete(s, 1, posStr-1);
      end;
    end;
  end;
  if tempS = '<' then
    addToRHS(' <');
end;

procedure THash.addToRHS(const s: string);
var dumbAtom: PHashAtom;
begin
  if current = nil then exit;
  new(dumbAtom);
  dumbAtom.next := nil;
  dumbAtom.optional := optin;
  dumbAtom.star := star;
  if star = true then dumbAtom.optional := true;
//  dumbAtom.plus := plus;
  if AnsiSameText(s, '<id>') = true then
  begin
    dumbAtom.term := id;
    dumbAtom.nonTerminal := nil;
  end else
  if AnsiSameText(s, '<str>') = true then
  begin
    dumbAtom.term := str;
    dumbAtom.nonTerminal := nil;
  end else
  if AnsiSameText(s, '<num>') = true then
  begin
    dumbAtom.term := num;
    dumbAtom.nonTerminal := nil;
  end else
  if AnsiSameText(s, '<hex>') = true then
  begin
    dumbAtom.term := hex;
    dumbAtom.nonTerminal := nil;
  end else
  if AnsiSameText(s, '<oct>') = true then
  begin
    dumbAtom.term := oct;
    dumbAtom.nonTerminal := nil;
  end else
  if AnsiSameText(s, '<bin>') = true then
  begin
    dumbAtom.term := bin;
    dumbAtom.nonTerminal := nil;
  end else
  if s[1] = '<' then
  begin
    dumbAtom.term := nonTerminal;
    getMem(dumbAtom.nonTerminal, length(s)+1);
    strcopy(dumbAtom.nonTerminal, PChar(trim(s)));
    dumbAtom.hashCode := hash(s);
  end else
  begin
    dumbAtom.term := terminal;
    getMem(dumbAtom.terminal, length(s)+1);
    strcopy(dumbAtom.terminal, PChar(trim(s)));
  end;
  if current.lastRHS = nil then
  begin
    current.RHS := dumbAtom;
    current.lastRHS := dumbAtom;
  end else
  begin
    current.lastRHS.next := dumbAtom;
    current.lastRHS := dumbAtom;
  end;
end;

procedure THash.addMacro(const s: string);
var dumbAtom: PHashAtom;
begin
  trim(s);
  if current = nil then exit;
  new(dumbAtom);
  dumbAtom.next := nil;
  dumbAtom.term := macro;
  getMem(dumbAtom.macro, length(s)+1);
  strcopy(dumbAtom.macro, PChar(trim(s)));
  if current.lastMacro = nil then
  begin
    current.Macros := dumbAtom;
    current.lastMacro := dumbAtom;
  end else
  begin
    current.lastMacro.next := dumbAtom;
    current.lastMacro := dumbAtom;
  end;
end;

procedure THash.clearCurrent;
begin
  current := nil;
end;

function THash.hashLookup(const s: string): PHashNode;
begin
  result := hashLookup(s, hash(s));
end;

function THash.hashLookup(const s: string; hint: word; count: word): PHashNode;
var i: word;
begin
  result := table[hint];
  for i := 0 to count do
  begin
    while (result <> nil) and (AnsiCompareText(result.name, s) <> 0) do
    begin
      result := result.next;
    end;
    if result = nil then exit;
    if i <> count then
      result := result.next;
  end;
end;

constructor TVars.Create(const named: string; nextHash: TVars; error: TError);
begin
  next := nextHash;
  name := named;
  err := error;
  if nextHash = nil then first := self
  else first := nextHash.first;
end;

destructor TVars.Destroy;
var i: cardinal;
  dumbNode, nextNode: PVarNode;
begin
  if assigned(next) then next.destroy;
  for i := 0 to hashSize do
  begin
    dumbNode := table[i];
    while dumbNode <> nil do
    begin
      nextNode := dumbNode.next;
      if assigned(dumbNode.context) then
        TVars(dumbNode.context).destroy;
      dispose(dumbNode);
      dumbNode := nextNode;
    end;
  end;
end;

procedure TVars.addVar(const named: string; const typed: string);
var dumbNode: PVarNode;
  hashCode: word;
begin
  if assigned(self.hashLookup(named)) then
    err.err('Variable already exists: '+named);
  new(dumbNode);
  dumbNode.isvar := true;
  dumbNode.name := named;
  dumbNode.typePtr := hashLookup(typed);
  if dumbNode.typePtr = nil then
  begin
    err.err('No such type: ' + typed);
    exit;
  end;
  dumbNode.nameType := dumbNode.typePtr.name;
  dumbNode.baseType := dumbNode.typePtr.baseType;
  hashCode := hash(named);
  dumbNode.next := table[hashCode];
  dumbNode.context := nil;
  dumbNode.RHS := nil; dumbNode.lastRHS := nil;
  dumbNode.LHS := nil; dumbNode.lastLHS := nil;
  dumbNode.ALT := nil; dumbNode.lastALT := nil;
  dumbNode.Decl := nil; dumbNode.lastDecl := nil;
  dumbNode.altDecl := nil; dumbNode.lastAltDecl := nil;
  setLength(dumbNode.equiv, 0);
  table[hashCode] := dumbNode;
  current := dumbNode;
end;

procedure TVars.addBasedType(const named: string; const base: string);
var dumbNode, basePtr: PVarNode;
  hashCode: word;
begin
  new(dumbNode);
  dumbNode.name := named;
  dumbNode.isVar := false;
  hashCode := hash(named);
  dumbNode.next := table[hashCode];
  setLength(dumbNode.equiv, 0);
  if base[1] = '$' then
  begin
    err.err('Can not @T a basic type ('+base+').');
  end;
  basePtr := hashLookup(base);
  if basePtr = nil then
  begin
    err.err('No such type: '+base);
    exit;
  end;
  dumbNode.baseType := basePtr.baseType;
  dumbNode.equiv := copy(basePtr.equiv, 0, length(basePtr.equiv));

  dumbNode.nameType := base;
  dumbNode.typePtr := nil;
  dumbNode.context := nil;
  dumbNode.RHS := basePtr.RHS; dumbNode.lastRHS := basePtr.lastRHS;
  dumbNode.LHS := basePtr.LHS; dumbNode.lastLHS := basePtr.lastLHS;
  dumbNode.ALT := basePtr.ALT; dumbNode.lastALT := basePtr.lastALT;
  dumbNode.Decl := basePtr.Decl; dumbNode.lastDecl := basePtr.lastDecl;
  dumbNode.altDecl := basePtr.altDecl; dumbNode.lastAltDecl := basePtr.lastAltDecl;
  setLength(dumbNode.equiv, length(dumbNode.equiv)+1);
  dumbNode.equiv[length(dumbNode.equiv)-1] := base;
  table[hashCode] := dumbNode;
  current := dumbNode;
end;

procedure TVars.addType(const named: string; const base: string);
var dumbNode, basePtr: PVarNode;
  hashCode: word;
begin
  new(dumbNode);
  dumbNode.name := named;
  dumbNode.isVar := false;
  hashCode := hash(named);
  dumbNode.next := table[hashCode];
  setLength(dumbNode.equiv, 0);
  if base[1] <> '$' then
  begin
    basePtr := hashLookup(base);
    if basePtr = nil then
    begin
      err.err('No such type: '+base);
      exit;
    end;
    dumbNode.baseType := basePtr.baseType;
    dumbNode.equiv := copy(basePtr.equiv, 0, length(basePtr.equiv));
  end else
    dumbNode.baseType := named;
  dumbNode.nameType := base;
  dumbNode.typePtr := nil;
  dumbNode.context := nil;
  dumbNode.RHS := nil; dumbNode.lastRHS := nil;
  dumbNode.LHS := nil; dumbNode.lastLHS := nil;
  dumbNode.ALT := nil; //dumbNode.lastALT := nil;
  dumbNode.Decl := nil; dumbNode.lastDecl := nil;
  dumbNode.altDecl := nil; dumbNode.lastAltDecl := nil;
  setLength(dumbNode.equiv, length(dumbNode.equiv)+1);
  dumbNode.equiv[length(dumbNode.equiv)-1] := base;
  table[hashCode] := dumbNode;
  current := dumbNode;
end;

procedure TVars.attachType(const s: string);
var dumbNode, basePtr: PVarNode;
begin
  basePtr := hashLookup(s);
  if basePtr = nil then
  begin
    err.err('No such type: '+s);
    exit;
  end;
  dumbNode := Self.current;
  if dumbNode.RHS = nil then
    dumbNode.RHS := basePtr.RHS; dumbNode.lastRHS := basePtr.lastRHS;
  if dumbNode.LHS = nil then
    dumbNode.LHS := basePtr.LHS; dumbNode.lastLHS := basePtr.lastLHS;
  if dumbNode.ALT = nil then
    dumbNode.ALT := basePtr.ALT; dumbNode.lastALT := basePtr.lastALT;
  if dumbNode.Decl = nil then
    dumbNode.Decl := basePtr.Decl; dumbNode.lastDecl := basePtr.lastDecl;
  if dumbNode.altDecl = nil then
    dumbNode.altDecl := basePtr.altDecl; dumbNode.lastAltDecl := basePtr.lastAltDecl;
end;

procedure TVars.addLHS(const s: string);
var dumbAtom: PHashAtom;
begin
  trim(s);
  if current = nil then exit;
  new(dumbAtom);
  dumbAtom.next := nil;
  getMem(dumbAtom.Macro, length(s)+1);
  strcopy(dumbAtom.Macro, PChar(trim(s)));
  if current.lastLHS = nil then
    current.LHS := dumbAtom
  else
    current.lastLHS.next := dumbAtom;
  current.lastLHS := dumbAtom;
end;

procedure TVars.addRHS(const s: string);
var dumbAtom: PHashAtom;
begin
  trim(s);
  if current = nil then exit;
  new(dumbAtom);
  dumbAtom.next := nil;
  getMem(dumbAtom.Macro, length(s)+1);
  strcopy(dumbAtom.Macro, PChar(trim(s)));
  if current.lastRHS = nil then
    current.RHS := dumbAtom
  else
    current.lastRHS.next := dumbAtom;
  current.lastRHS := dumbAtom;
end;

procedure TVars.addALT(const s: string);
var dumbAtom: PHashAtom;
begin
//  trim(s);
  if current = nil then exit;
{  if s  = '' then
  begin
     setLength(current.ALT, length(current.ALT)+1);
     current.lastALT := nil;
  end else}
  case s[1] of
    '!', '@', '+', '*':
      if length(current.ALT) = 0 then
      begin
        setLength(current.ALT, 1);
  new(dumbAtom);
  dumbAtom.next := nil;
  dumbAtom.Macro := '';
        current.lastALT := dumbAtom;
        current.ALT[0] := dumbAtom;
      end;
   else
   begin
     setLength(current.ALT, length(current.ALT)+1);