names.pas

unit names;
{ Used to read in THING NAMES and 'exit quotes'. }
{$g-,o-,n-,e-,l-,y-,d-,x+,t-,v-,q-,r-,s-}

INTERFACE

uses xlat; { For case translation stuff. XLAT is from SWAG. }

type
  pstring=^string;
  plink=^tlink;
  tlink=record
    next,prev:plink;
    symbol:pstring;
    num:word;
  end;

procedure addsymb(var l:plink;pn:string;aboe:boolean);
procedure writesymb(var l:plink);
function  num_getsymb(var l:plink;n:longint):string;
function  num_entries(var l:plink):word;
procedure dumplist(var l:plink;fn:string);
procedure data_kill(var l:plink);
procedure data_sort(var l:plink);
procedure data_copy(var l1,l2:plink);
procedure data_copy2(var l1,l2:plink); { copies pointers only... }
function  get_line(var l:plink;n:longint):word;
function  find_line(var l:plink;n:longint):word;
function  pos_find(var l:plink;nam:string;ch:char;var num:word):string;

var
  symbol:plink;            { the thing names     }
  symbol2:plink;           { sorted thing names  }
  quotes:plink;            { the exit quotes     }
  debug:plink;             { various debug stuff }

IMPLEMENTATION

var
  oldexit:pointer;
  num_read:word;

procedure mem4string(var ps:pstring;ts:string);
begin
  getmem(ps,succ(ord(ts[0])));
  ps^[0]:=ts[0];
  move(ts[1],ps^[1],ord(ts[0]));
end;

procedure discardstr(var ps:pstring);
begin
  freemem(ps,succ(ord(ps^[0])));
end;

procedure initsymb(var l:plink);
begin
  new(l);
  with(l^)do
  begin
    prev:=nil;
    next:=nil;
    symbol:=nil;
    num:=0;
  end;
end;

procedure addsymb(var l:plink;pn:string;aboe:boolean);
begin
  if(memavail<(sizeof(tlink)+16))then exit;
  translate(pn,lower);
  if(l^.next<>nil)then while(l^.next<>nil)do
  begin
    l:=l^.next;
    if(l^.symbol^=pn)and(aboe)then exit;
  end;
  if(l^.symbol^=pn)and(aboe)then exit;

  new(l^.next);
  l^.next^.prev:=l;
  l:=l^.next;
  with l^ do
  begin
    next:=nil;
    mem4string(symbol,pn);
    inc(num_read);
    num:=num_read;
  end;
end;

procedure writesymb(var l:plink);
var tmp:plink;
begin
  tmp:=l;
  while(tmp^.prev<>nil)do tmp:=tmp^.prev;
  while(tmp^.next<>nil)do
  begin
    tmp:=tmp^.next;
    writeln(tmp^.symbol^,' = ',tmp^.num);
  end;
end;

function num_getsymb(var l:plink;n:longint):string;
var cnt:longint;
begin
  num_getsymb:='error';
  cnt:=0;
  while(l^.prev<>nil)do l:=l^.prev;
  while(l^.next<>nil)and(cnt<n)do
  begin
    l:=l^.next;
    inc(cnt);
  end;
  if(cnt<>n)then exit;
  num_getsymb:=l^.symbol^;
end;

function num_entries(var l:plink):word;
var tmp:word;
begin
  tmp:=0;
  while(l^.prev<>nil)do l:=l^.prev;
  while(l^.next<>nil)do
  begin
    l:=l^.next;
    inc(tmp);
  end;
  num_entries:=tmp;
end;

procedure dumplist(var l:plink;fn:string);
var f:text;
begin
  assign(f,fn); rewrite(f);
  while(l^.prev<>nil)do l:=l^.prev;
  while(l^.next<>nil)do
  begin
    l:=l^.next;
    writeln(f,l^.symbol^,' = ',l^.num);
  end;
  writeln(f,l^.symbol^);
  close(f);
end;

procedure data_kill(var l:plink);
begin
  while(l^.next<>nil)do l:=l^.next;
  while(l^.prev<>nil)do
  begin
    with(l^)do discardstr(symbol);
    l:=l^.prev;
    dispose(l^.next);
  end;
  dispose(l);
end;

procedure swap(var a,b:pstring); assembler;
asm
  push ds
  les di,a
  mov ax,es:[di+0]
  mov bx,es:[di+2]
  les di,b
  mov cx,es:[di+0]
  mov dx,es:[di+2]
  mov es:[di+0],ax
  mov es:[di+2],bx
  les di,a
  mov es:di[+0],cx
  mov es:di[+2],dx
  pop ds
end;

procedure wswap(var a,b:word);assembler;
asm
  push ds
  lds si,a
  les di,b

  mov ax,ds:[si]
  mov bx,es:[di]
  mov ds:[si],bx
  mov es:[di],ax

  pop ds
end;

function larger(a,b:string):boolean; assembler;
asm
  push ds
  lds si,a
  les di,b
  mov cl,ds:[si]
  mov ch,es:[di]
  inc si
  inc di
  cmp cl,ch
  jb @noswap1
  mov cl,ch
@noswap1:
  xor ch,ch
  cld
  rep cmpsb
  xor ax,ax
  dec si
  dec di
  mov cl,ds:[si]
  mov ch,es:[di]
  cmp cl,ch
  jbe @smaller
  inc al
@smaller:
  pop ds
end;

procedure data_sort(var l:plink);
var sorted:boolean;
begin
  repeat
    sorted:=true;
    if(l^.prev<>nil)then while(l^.prev<>nil)do l:=l^.prev;
    while(l^.next<>nil)do
    begin
      if(l^.next<>nil)then l:=l^.next;
      if(l^.next<>nil)and(l^.next^.symbol<>nil)then
      begin
	if(larger(l^.symbol^,l^.next^.symbol^))then
	begin
	  sorted:=false;
	  swap(l^.symbol,l^.next^.symbol);
	  wswap(l^.num,l^.next^.num);
	end;
      end;
    end;
  until(sorted);
end;

procedure data_copy(var l1,l2:plink);
begin
  while(l1^.prev<>nil)do l1:=l1^.prev;
  data_kill(l2);
  initsymb(l2);
  while(l1^.next<>nil)do
  begin
    l1:=l1^.next;
    new(l2^.next);
    l2^.next^.prev:=l2;
    l2^.next^.next:=nil;
    l2:=l2^.next;
    mem4string(l2^.symbol,l1^.symbol^);
    l2^.num:=l1^.num;
  end;
end;

procedure data_copy2(var l1,l2:plink);
begin
  while(l1^.prev<>nil)do l1:=l1^.prev;
  data_kill(l2);
  initsymb(l2);
  while(l1^.next<>nil)do
  begin
    l1:=l1^.next;
    new(l2^.next);
    l2^.next^.prev:=l2;
    l2^.next^.next:=nil;
    l2:=l2^.next;
    l2^.symbol:=l1^.symbol;
    l2^.num:=l1^.num;
  end;
end;

function get_line(var l:plink;n:longint):word;
var cnt:longint;
begin
  get_line:=0;
  cnt:=0;
  while(l^.prev<>nil)do l:=l^.prev;
  while(l^.next<>nil)and(cnt<n)do
  begin
    l:=l^.next;
    inc(cnt);
  end;
  if(cnt<>n)then exit;
  get_line:=l^.num;
end;

function find_line(var l:plink;n:longint):word;
var cnt:longint;
begin
  find_line:=0;
  cnt:=0;
  while(l^.prev<>nil)do l:=l^.prev;
  while(l^.next<>nil)and(l^.num<>n)do
  begin
    l:=l^.next;
    inc(cnt);
  end;
  if(l^.num<>n)then exit;
  find_line:=cnt;
end;

function pos_find(var l:plink;nam:string;ch:char;var num:word):string;
var
  cnt:word;
  tmp:string;
begin
  cnt:=0;
  pos_find:=nam;
  tmp:=nam;
  if(ch<>#0)then tmp:=concat(tmp,ch);
  { start searching for exact hit }
  while(l^.prev<>nil)do l:=l^.prev;
  l:=l^.next;
  while(l^.next<>nil)and(tmp<>l^.symbol^)do
  begin
    l:=l^.next;
    inc(cnt);
  end;
  if(tmp=l^.symbol^)then
  begin
    num:=cnt;
    pos_find:=tmp;
    exit;
  end;
  { no exact hit? Do "fuzzy" search }
  cnt:=0;
  while(l^.prev<>nil)do l:=l^.prev;
  l:=l^.next;
  while(l^.next<>nil)and(pos(tmp,l^.symbol^)<>1)do
  begin
    l:=l^.next;
    inc(cnt);
  end;
  if(pos(tmp,l^.symbol^)<>1)then exit;
  pos_find:=tmp;
  num:=cnt;
end;

begin
  num_read:=0;

  initsymb(symbol);
  initsymb(symbol2);
  initsymb(quotes);
  initsymb(debug);
end.