DataMuseum.dk

top - metrics - download

    Length: 2304 (0x900)
    Types: TextFile
    Names: »esw«

└─⟦621cfb9a2⟧ Bits:30002817 RC8000 Dump tape fra HCØ.  Detaljer om "HC8000" projekt.
    └─⟦0364f57e3⟧ 
        └─⟦this⟧ »esw« 

TextFile

program forth(input,output);
const
 maxcol    = 79;
 maxstack  = 999;
type
 alpha     = packed arrayÆ0..9Å of char;
 pentry    = ^entry;
 entry     = record
              name  : alpha;
              link  : pentry;
              code  : integer;
             end;
 string    =  arrayÆ0..maxcolÅ of char;
var
 finish    : boolean;
 H0,H      : pentry;
 stack     : arrayÆ0..maxstackÅ of integer;
 sidx      : integer;
 ss  : string;
 a   : integer;
procedure readstring(var s:string);
 var
  idx  : integer;
 begin
  idx:=0;
  while not eoln(input) do
  begin
  read(input,sÆidxÅ);
  idx:=idx+1;
  end;
  readln;
 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);
 begin
  case no of
  1   : write(" Stack underflow");
  end;
 end;

 procedure entstdnames(n:alpha;c:integer);
 var
  ent  : pentry;
 begin
  new(ent);
  H :=ent;
  with ent^ do
  begin
   name:=n;
   link:=H0;
   code:=c;
  end;
  H0:=H;
 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 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;

(* relations *)
(* tos operations *)
procedure swap;
var
 a,b   : integer;
begin
 pop(a);
 pop(b);
 push(a);
 push(b);
end;
begin
 sidx:=0;
 stackÆsidxÅ:=0;
 finish     :=false;
 repeat
  writeln(":");
  blankfill(ss);
  readstring(ss);
  writeln(">");
  writestring(ss);
 until finish;
end.
▶EOF◀