reduce-historical/psl-1983/3-1/tests/main1.red

% Simple 1 file test
% This is program MAIN1.RED


IN "XXX-HEADER.RED"$

On SYSLISP;

Procedure FirstCall;
 <<Init();
   PutC Char F;
   PutC Char !a;
   PutC Char !c;
   PutC Char !=;
   PutInt Ifact 10;
   Terpri();
   PutC Char T;
   PutC Char !e;
   PutC Char !s;
   PutC Char !t;
   PutC Char F;
   PutC Char !a;
   PutC Char !c;
   PutC Char !t;
   Terpri();
   TestFact();
   Terpri();
   PutC Char T;
   PutC Char !e;
   PutC Char !s;
   PutC Char !t;
   PutC Char T;
   PutC Char !a;
   PutC Char !k;
   Terpri();
   TestTak();
   Quit;>>;

procedure terpri();
   PutC Char EOL;

Procedure TestFact();
<< PutInt Timc(); 
   Terpri();
   ArithmeticTest 10000;
   PutInt Timc();
   Terpri();
>>;

Procedure ArithmeticTest (N);
 begin scalar I;
    I:= 0;
loop:
    if Igreaterp(I,N) then return NIL;
    Fact 9;
    I := iadd1 I;
    goto loop
end;

procedure TestTak();
 <<PutInt Timc();
   Terpri();
   PutInt TopLevelTak (18,12,6);
   Terpri();
   PutInt Timc();
   Terpri();>>;

syslsp procedure Fact (N);
 If ilessp(N,2) then  1 else LongTimes(N,Fact isub1 N);

syslsp procedure Ifact u;
 Begin scalar m;
   m:=1;
 L1: if u eq 1 then return M;
   M:=LongTimes(U,M);
   u:=u-1;
   PutInt(u);
   Terpri();
   PutInt(M);
   Terpri();
   goto  L1;
 end;

in "pt:tak.sl"$

off syslisp;

procedure UndefinedFunctionAux;
 <<Putc Char U;
   Putc Char !n;
   Putc Char !d;
   Putc Char !e;
   Putc Char !f;
   Putc Char Blank;
   Putint UndefnCode!*;
   Terpri();
   Quit;>>;
  end;