⟦fb87e468d⟧

TextFile

program forth(input,output);
const
 maxcol    = 79;
 maxstack  = 999;
type
 pparam    = ^param;
 param     = record
              content : integer;
              next    : pparam;
             end;
 pentry    = ^entry;
 entry     = record
              leng  : integer;
              name  : alfa;
              link  : pentry;
              code  : integer;
              next  : pparam;
             end;
 pinteger  = ^integer;
 string    =  packed arrayÆ0..maxcolÅ of char;
var
 ipc       : pparam;
 curpfa    : pinteger;
 sizein    : integer;
 sentry    : pentry;
 H0        : pentry;
 H         : pentry;
 pfa       : pinteger;
 base      : integer;
 token     : alfa;
  finish    : boolean;
 stack     : arrayÆ0..maxstackÅ of integer;
 sidx      : integer;
 xstack    : arrayÆ0..maxstackÅ of integer;
 xsidx     : integer;
 line      : string;
 tidx      : integer;
 compilemode : boolean;
 contab    : arrayÆ0..63Å of char;
 galias    : record case integer of
             1   :  ( int  : integer);
             2   :  ( pnt  : pinteger);
             3   :  ( pp   : pparam);
             4  :   ( pe   : pentry);
             end;
procedure execute;
forward;
function intable:integer;
forward;
procedure writetoken;
var
 i  : integer;
begin
 for i:=1 to 12 do
 write(tokenÆiÅ);
end;

\f


procedure readstring;
 var
  ch   : char;
  idx  : integer;
 begin
  idx:=0;readln;
  while not eoln(input) do
  begin
  if idx<=maxcol then
  begin
  read(input,ch);
  if ch<>chr(0) then
  lineÆidxÅ:=ch;
  end;
  idx:=idx+1;
  end;
 end;
 procedure writestring(s:string);
 var
  idx  : integer;
 begin
  for idx:=0 to maxcol do
  if sÆidxÅ>chr(0) then write(sÆidxÅ);
  writeln;
 end;
 procedure blankfill(var s:string);
 var
  idx   : integer;
 begin
  for idx:=0 to maxcol do
  sÆidxÅ:=chr(0);
 end;


 procedure error(no:integer);
 var
  i    : integer;
 begin
  if no=2 then
  for i:=1 to 12 do
  write(tokenÆiÅ);
  case no of
  1   : writeln(" Stack underflow");
  2   : writeln(' Undefined');
  3   : writeln(' Address error ');
  4   : writeln(' File');
  5   : writeln(' Unexpected nil');
  end;
 end;
 procedure clearline;
 var
  i   : integer;
 begin
  for i:=0 to maxcol do
  lineÆiÅ:=' ';
 end;
 procedure skipblanks;
 begin
  while (lineÆtidxÅ=' ') and (tidx<maxcol) do
  tidx:=tidx+1;
 end;

 procedure getnext;
 var
  idx   : integer;
  i     : integer;
 begin
  for i:=1 to 12 do
  tokenÆiÅ:=' ';
  idx:=1;sizein:=0;
  while (tidx<maxcol) and (lineÆtidxÅ<>' ') and (lineÆtidxÅ<>chr(0)) do
  begin
   if idx<13 then
   begin
    tokenÆidxÅ:=lineÆtidxÅ;
    idx:=idx+1;
   end;
   tidx:=tidx+1;
   sizein:=sizein+1;
  end;
 end;
 procedure entstdnames(std:boolean;n:alfa;c:integer);
 var
  e     : pentry;
  i,count : integer;
 begin
  if std then
  begin
   count:=0;
   for i:=1 to 12 do
   if nÆiÅ<>' ' then count:=count+1;
  end
  else
  count:=sizein;
  new(e);
  if c=0 then sentry:=e;    (* mark first entry *)
  with e^ do
  begin
   leng:=count;
   name:=n;
   link:=H0;
   code:=c;
   next :=nil;
  end;
  H0:=e;
 end;
 procedure builddir;
 begin
  entstdnames(true,'            ',0);
entstdnames(true,'2swap       ',1);
entstdnames(true,'2drop       ',2);
entstdnames(true,'2rot        ',3);
entstdnames(true,'2dup        ',4);
entstdnames(true,'2over       ',5);
entstdnames(true,'swap        ',6);
entstdnames(true,'drop        ',7);
entstdnames(true,'rot         ',8);
entstdnames(true,'dup         ',9);
entstdnames(true,'over        ',10);
entstdnames(true,'.           ',11);
entstdnames(true,'+           ',12);
entstdnames(true,'-           ',13);
entstdnames(true,'<           ',14);
entstdnames(true,'>           ',15);
entstdnames(true,'=           ',16);
entstdnames(true,'^           ',17);
entstdnames(true,'base        ',18);
entstdnames(true,':           ',19);
entstdnames(true,'interpret   ',20);
entstdnames(true,';           ',21);
entstdnames(true,'''           ',22);
entstdnames(true,'!           ',23);
entstdnames(true,'@           ',24);
entstdnames(true,'variable    ',25);
entstdnames(true,'execute     ',27);
entstdnames(true,'emit        ',28);
entstdnames(true,'*           ',29);
entstdnames(true,'exit        ',30);
entstdnames(true,'/           ',31);
entstdnames(true,'constant    ',32);
entstdnames(true,'forget      ',34);
entstdnames(true,'literal     ',35);
entstdnames(true,'p!          ',36);
entstdnames(true,'p@          ',37);
entstdnames(true,'."          ',38);
entstdnames(true,'"           ',39);
entstdnames(true,'sliteral    ',40);
end;
 procedure push(item:integer);
 begin
  sidx:=sidx+1;
  stackÆsidxÅ:=item;
 end;

 procedure pop(var item:integer);
 begin
  item:=0;
  if sidx<0 then
  begin
   error(1);
   sidx:=0;
  end
  else
  begin
   item:=stackÆsidxÅ;
   sidx:=sidx-1;
  end;
 end;
 procedure xpush(item:integer);
 begin
  xsidx:=xsidx+1;
  xstackÆxsidxÅ:=item;
 end;

 procedure xpop(var item:integer);
 begin
  item:=xstackÆxsidxÅ;
  xsidx:=xsidx-1;
 end;
 procedure load;
 var
  alias  : record case boolean of
            true  : (int  : integer);
            false : (pnt  : pinteger);
           end;
  a      : integer;
  begin
   pop(alias.int);
   push(alias.pnt^);
  end;

  procedure pload;
  var
   alias : record case boolean of
            true  : ( int  : integer);
            false : ( pnt  : pinteger);
           end;
   a     : integer;
  begin
  end;
  procedure store;
  var
   alias  : record case boolean of
             true  : (int : integer);
             false : (pnt : pinteger);
            end;
   a      : integer;
  begin
   pop(alias.int);
   pop(a);
   alias.pnt^:=a;
  end;

  procedure pstore;
  begin
  end;

  procedure cvariable;
  begin
   galias.pnt:=curpfa;
   push(ord(galias.pe^.next));
  end;

  procedure cconstant;
  var p : pparam;
  begin
   galias.pnt:=curpfa;
   p:=galias.pe^.next;
   push(p^.content);
  end;


 procedure cnumber;
 var
  a   : record case boolean of
        true  : (int : integer);
        false : (pnt : pinteger);
        end;
 begin
  push(ipc^.content);
  ipc:=ipc^.next;
 end;

 procedure cstring;
 var
  a    : record case boolean of
          true  : (int : integer);
          false : (pnt : pinteger);
         end;
  l     : integer;
  i     : integer;

  begin
   xpop(a.int);
   l:=a.pnt^;
   for i:=1 to l do
   begin
    a.int:=a.int+2;
    write(chr(a.pnt^));
   end;
   xpush(a.int+2);
  end;


 procedure add;
 var
  a,b  : integer;
 begin
  pop(a);
  pop(b);
  a:=a+b;
  push(a);
 end;

 procedure subtract;
 var
  a,b  : integer;
 begin
  pop(a);
  pop(b);
  b:=b-a;
  push(b);
 end;

 procedure multiply;
 var
  a,b   : integer;
 begin
  pop(a);
  pop(b);
  b:=b*a;
  push(b);
 end;

 procedure divide;
 var
  a,b   : integer;
 begin
  pop(a);
  pop(b);
  b:=b div a;
  push(b);
 end;
procedure less;
var
 a,b     : integer;
begin
 pop(b);
 pop(a);
 if a<b then
 a:=1
 else
 a:=0;
 push(a);
end;

procedure gtr;
var
 a,b     : integer;
begin
 pop(b);
 pop(a);
 if a>b then
 a:=1
 else
 a:=0;
 push(a);
end;

procedure eql;
var
 a,b   : integer;
begin
 pop(a);
 pop(b);
 if a=b then
 push(1)
 else
 push(0);
end;


(* relations *)
(* tos operations *)
procedure swap;
var
 a,b   : integer;
begin
 pop(a);
 pop(b);
 push(a);
 push(b);
end;
procedure drop;
var
 a   : integer;
begin
 pop(a);
end;

procedure rotate;
var
 a,i    : integer;
begin
 a:=stackÆ1Å;
 for i:=2 to sidx do
 stackÆi-1Å:=stackÆiÅ;
 stackÆsidxÅ:=a;
end;
procedure dup;
var
 a    : integer;
begin
 pop(a);
 push(a);
 push(a);
end;

procedure over;
var
 a,b  : integer;
begin
 pop(a);
 pop(b);
 push(b);
 push(a);
 push(b);
end;

procedure swap2;
begin
end;

procedure drop2;
begin
end;

procedure rotate2;
begin
end;

procedure dup2;
begin
end;

procedure over2;
begin
end;

procedure dot;
var
 a    : integer;
begin
 pop(a);
 writeln(a:6);
end;

procedure emit;
var
 a  : integer;
begin
 pop(a);
 writeln(chr(a));
end;

procedure dotq;
var
 pi     : pinteger;
 l      : pinteger;
 i,idx  : integer;
begin
 if compilemode then
 begin
  token:='sliteral    ';
  sizein:=8;
  idx:=intable;
 end
  else
  while lineÆtidxÅ<>'"' do
  begin
   write(lineÆtidxÅ);
   tidx:=tidx+1;
  end;
  writeln;
 end;
procedure shiftbase;
var
 a    : integer;
begin
 pop(a);
 base:=a;
end;


function intable; 
var
 found: boolean;
 sizeofentry : integer;
 p    : pentry;
 alias: record case integer of
        0 : (int : integer);
        1 : (pnt : pinteger);
        2 : (pp  : pentry);
        end;
begin
  p := h0;
  intable := 0;found:=false;
  sentry^.leng := sizein;
  sentry^.name := token;
  while not found do
    begin
    with p^ do
    if leng = sizein then
    begin
      if name = token then
      begin
      found := true;
        alias.pp := p;
        pfa := alias.pnt;
        if p^.code= 0 then
          intable := 0
         else
          intable := alias.int;
      end
     else
      p := link;
    end
   else
    p := link;
  end;
end;
procedure tick;
var
 idx : integer;
begin
 skipblanks;
 getnext;
 idx:=intable;
 if idx>0 then
 push(idx);
end;
procedure place(i:integer);
var
 pe  : pparam;
 p   : pparam;
begin
 writeln(' placing ');
 new(pe);
 pe^.next:=nil;
 if H0^.next=nil then
 begin
  H0^.next:=pe;
 end
 else
 begin
  p:=H0^.next;
  while p^.next<>nil do
  p:=p^.next;
  p^.next:=pe;
 end;
  pe^.content:=i;
end;

procedure variable;
begin
 skipblanks;
 getnext;
 entstdnames(false,token,26);
 place(0);
end;

procedure constant;
var
 a    : integer;
 i    : pinteger;
begin
 skipblanks;
 getnext;
 entstdnames(false,token,33);
 pop(a);
 new(i);
 i^:=a;
end;
procedure forget;
begin
end;





procedure runcolon;
var
 al       :  record case integer of
                0: (int : integer);
                1: ( pnt: pinteger);
                2: (pa  : pparam);
                3: (pe  : pentry);
                end;
begin
 xpush(ord(ipc));
 al.pnt:=curpfa;
 ipc:=al.pe^.next;
 repeat
  push(ipc^.content);
  ipc:=ipc^.next;
  execute;
 until xstackÆxsidxÅ=1;
 xpop(al.int);
 xpop(al.int);
 ipc:=al.pa;
end; (* end of runcolon *)

procedure interpret;
var
 op       : integer;
begin
  runcolon;
end; (* end of runcolon *)

procedure codeexit;
var
 iipc :integer;
begin
 xpush(1);
end; (* end of codeexit *)

procedure compile;
var
 idx      : integer;
 ie       : pinteger;
begin
  compilemode := true;
  skipblanks;
  getnext;
  entstdnames(false,token,20);
end; (* end of compile *)

procedure execute;
var
  alias : record case integer of
            0 : (int : integer);
            1 : (pnt : pinteger);
            2 : (pp  : pentry);
          end;
begin
 pop(alias.int);
 curpfa:=alias.pnt;
 if compilemode then
 begin
  place(ord(curpfa));
  if alias.pp^.code=21 then
  compilemode := false;
 end
else
 begin
(*
 writeln(' exe ',alias.pp^.code:4);
*)
 case alias.pp^.code of
  1: swap2;
  2: drop2;
  3: rotate2;
  4 : dup2;
  5 : over2;
  6 : swap;
  7 : drop;
  8 : rotate;
  9 : dup;
  10: over;
  11: dot;
  12: add;
  13: subtract;
  14: less;
  15: gtr;
  16: eql;
  17: finish := true;
  18: shiftbase;
  19: compile;
  20: interpret;
  21: codeexit;
  22: tick;
  23: store;
  24: load;
  25: variable;
  26: cvariable;
  27: execute;
  28: emit;
  29: multiply;
  30: codeexit;
  31: divide;
  32: constant;
  33: cconstant;
  

  34: forget;
  35: cnumber;
  36: pstore;
  37: pload;
  38: dotq;
  39: ;
  40: cstring;
  end;
 end;
end;
procedure scan;
var
 i      : integer;
 idx    : integer;
 procedure gettoken;
 var
 top   : integer;

 function incontab(ch:char):integer;
 var
  i : integer;
 begin
  incontab:=-1;
  for i:=0 to base-1 do
   if ch=contabÆiÅ then
   incontab:=i;
 end;

 function number:boolean;
 var
  nidx     : integer;
  inumber  : integer;
  pi       : pinteger;
 begin
  number:=true;
  nidx  :=1;
  if incontab(tokenÆnidxÅ)>-1 then
  begin
   inumber  :=0;
   while (incontab(tokenÆnidxÅ)>-1) and (nidx<13) do
   begin
    inumber:=inumber*base+incontab(tokenÆnidxÅ);
    nidx:=nidx+1;
   end;
   if tokenÆnidxÅ<>' ' then
   begin
    number:=false;
   end;
   if compilemode then
   begin
    token:='literal   ';
    sizein:=7;
    idx   :=intable;
    writeln(' Literal idx   ',idx:5);
    if idx>0 then
    begin
     place(idx);
    place(inumber);
    end;
   end
   else
   push(inumber);
  end
  else
   number:=false;
 end;

 begin
  tidx:=0;
  repeat
   skipblanks;
   if tidx<maxcol then
   begin
    getnext;
    idx:=intable;
    if idx>0 then
    begin
     push(idx);
     execute;
    end
    else
    if not number then
     error(2);
   end;
  until (tidx>=maxcol) or (lineÆtidxÅ=chr(0));
 end;

begin
 for i:=1 to 12 do
 tokenÆiÅ:=' ';
 gettoken;
end;

procedure init;
var
 i   : integer;
begin
 sidx:=0;
 stackÆsidxÅ:=0;
 xsidx:=0;
 xstackÆxsidxÅ:=0;
 H0:=nil;
 H :=nil;
 builddir;
 base:=10;
 compilemode:=false;
 for i:=0 to 9 do
 contabÆiÅ:=chr(48+i);
 for i:=10 to 63 do
 contabÆiÅ:=chr(55+i);
end;

begin  (* main program *)
 init;
 repeat
  finish:=false;
  writeln;
  writeln(' ready ');
  blankfill(line);
  readstring;
  scan;
 until finish;
end.
▶EOF◀
DataMuseum.dk

RC4000/8000/9000

⟦fb87e468d⟧ TextFile

Derivation

TextFile
