{*
 *  forth.tml
 *  $Id: forth.tml 1.2 1998/05/29 02:50:33 frago Exp frago $
 *
 *  A small forth interpreter for OS-X
 *  Ported from HSPL version 901123 via
 *  Z80 MOS 3.00 version 93-06-23
 *
 *  Revision history:
 *    940930 Francis Gormarker, initial OS-X port.
 *
 *    980528 FrGo, bugfix: in comp() the wrong memory size constant was used.
 *           Improved words() function to print words in multiple columns.
 *           Added "in" and "out" forth words for I/O access. Added RCS ID.
 *           Modified to run with or without OS-X in emulator.
 *}


UNIT forth;

INTERFACE

  PROCEDURE run_forth();

IMPLEMENTATION

  uses
{------------------ Uncomment this to run with OS-X  ----------------------}
    sys,
    sys_rpc,
    io,
{------------ Uncomment this to run in emulator without OS-X  -------------}
{
    system,
    hardware,
}
{--------------------------------------------------------------------------}
    memory;


  const
    version    = "98-05-28";
    stack_size = 1024;
    stackbase  = $8FF0;
    max_tab    = 1098;
    m_min      = $9000;
    m_max      = $FFF0;
    max_mem    = 8192;


  type
    string16 = array[16] of char;

    symbol = record
               imflag : boolean;
               cfa    : pointer;
               name   : string16;
               data   : array[2] of char;
             end;

    symbol_ptr = ^symbol;
    int_ptr = ^int;


  var
    dsp     : int;
    state   : boolean;
    dp      : ^char;
    context : ^pointer;
    current : ^pointer;
    base    : int;
    pad     : int;
    blk     : boolean;
    numtib  : int;
    postib  : int;
    tib     : string;
    abort_p : int;
    quit_p  : int;
    mem_full  : boolean;
    err_flag  : boolean;
    file_id   : pointer;
    file_p    : pointer;
    file_mode : int;
    file_size : int;
    x,y,z     : int;
    stack     : array[stack_size] of int;
    tab       : array[max_tab] of int;
    mem       : array[max_mem] of char;
    line,wbuf : string;
    file_name : string;
    chflag    : char;


  { Convert decimal or hexadecimal string to int }

  FUNCTION val(s: string): int;
   var
     i,sum : int;
  BEGIN
     sum := 0;
     i := 1;
     while i <= length(s) loop
        sum := sum * 10 + int(s[i] - '0');
        inc(i);
     end loop;
     return sum;
  END val;


  FUNCTION scan(source: string; var dest: string; var pos: int);
    var
      len,i     : int;
      breakchar : char;
  BEGIN
    len := length(source);
    while (pos <= len) and (source[pos] = ' ') loop
       inc(pos);
    end loop;
    i := 1;
    if source[pos] = ''' then
       breakchar := ''';
       inc(pos);
       dest[1] := ''';
       i := 2;
    else
       breakchar := ' ';
    end;
    while (pos <= len) and (source[pos] <> breakchar) loop
       if i < 64 then
          dest[i] := source[pos];
          inc(i);
       end;
       inc(pos);
    end loop;
    inc(pos);
    length(dest) := i-1;
  END scan;


  PROCEDURE dpush();
  BEGIN
    inline($EB,$3A,dsp,$6F,$26,$00,$01,stack);
    inline($09,$73,$23,$72,$23,$C6,$02,$32,dsp);
  END;


  PROCEDURE dpop();
  BEGIN
    inline($3A,dsp,$6F,$26,$00,$01,stack);
    inline($09,$2B,$56,$2B,$5E,$D6,$02,$32,dsp,$EB);
  END;


  PROCEDURE sys_push(x: int);
  BEGIN
    inline($FD,$66,$05);
    inline($FD,$6E,$04);
    dpush();
  END;


  PROCEDURE sys_pop(): int;
  BEGIN
    dpop();
  END;


  PROCEDURE check_stack();
  BEGIN
    if (dsp > 128) and (dsp < 200) then
       putln("Stack overflow!");
       dsp := 0;
       err_flag := true;
    elsif dsp >= 200 then
       putln("Stack underflow!");
       dsp := 0;
       err_flag := true;
    end;
  END;


  PROCEDURE comp(x: char);
  BEGIN
    if int(dp) >= int(@mem[max_mem]) then
       mem_full := true;
       err_flag := true;
       putln("Memory full!");
       { longjmp(abort_p); }
       return;
    end;
    dp^ := x;
    inc(int(dp));
  END;


  PROCEDURE compadr(x: int);
  BEGIN
    comp(char(x));
    comp(char(x / 256));
  END;


  PROCEDURE thread(funptr: pointer);
  BEGIN
    comp(#$CD);
    compadr(int(funptr));
  END;


  PROCEDURE num_literal(n: int);
  BEGIN
    comp(#$21);
    compadr(n);
    thread(@dpush);
  END;


  PROCEDURE end_def();
  BEGIN
    context := current;
    int(current) := int(current) + 2;
    comp(#$C9);
    { Test dictionary overflow here }
  END;


  PROCEDURE new_header(name: string; imflag: boolean);
   var
     p   : symbol_ptr;
     cfa : int;
  BEGIN
    p := pointer(dp);
    current^ := p;
    p^.imflag := imflag;
    p^.name := name;
    p^.cfa := @p^.data[2];
    dp := p^.cfa;
  END;


  PROCEDURE new_var(name: string);
   var
     p : symbol_ptr;
  BEGIN
    p := pointer(dp);
    new_header(name,false);
    num_literal(int(@p^.data));
    comp(#$C9);
    end_def(); 
  END;


  PROCEDURE new_const(name: string; value: int);
  BEGIN
    new_header(name,false);
    num_literal(value);
    comp(#$C9);
    end_def(); 
  END;


  PROCEDURE new_fn(name: string; imflag: boolean; cfa: pointer);
  BEGIN
    new_header(name,imflag);
    comp(#$C3);
    compadr(int(cfa));
    end_def(); 
  END;



  {-------------------------------- Primitives ----------------------------------------------}


  PROCEDURE fetch();
  BEGIN
    sys_push(int_ptr(sys_pop())^);
  END;


  PROCEDURE cfetch();
  BEGIN
    sys_push(int_ptr(sys_pop())^ and 255);
  END;


  PROCEDURE store();
   var
     p : ^int;
  BEGIN
    p := pointer(sys_pop());
    p^ := sys_pop();
  END;


  PROCEDURE cstore();
   var
     p : ^char;
  BEGIN
    p := pointer(sys_pop());
    p^ := char(sys_pop());
  END;


  PROCEDURE _dup();
   var
     x : int;
  BEGIN
    x := sys_pop();
    sys_push(x);
    sys_push(x);
  END;


  PROCEDURE swap();
   var
     x,y : int;
  BEGIN
    x := sys_pop();
    y := sys_pop();
    sys_push(x);
    sys_push(y);
  END;


  PROCEDURE over();
   var
     x,y : int;
  BEGIN
    x := sys_pop();
    y := sys_pop();
    sys_push(y);
    sys_push(x);
    sys_push(y);
  END;


  PROCEDURE drop();
  BEGIN
    dpop();
  END;


  PROCEDURE add();
  BEGIN
    sys_push(sys_pop() + sys_pop());
  END;


  PROCEDURE sub();
   var
     x : int;
  BEGIN
    x := sys_pop();
    sys_push(sys_pop() - x);
  END;


  PROCEDURE mult();
  BEGIN
    sys_push(sys_pop() * sys_pop());
  END;


  PROCEDURE idiv();
   var
     x : int;
  BEGIN
    x := sys_pop();
    sys_push(sys_pop() / x);
  END;


  PROCEDURE imod();
   var
     x : int;
  BEGIN
    x := sys_pop();
    sys_push(sys_pop() mod x);
  END;


  PROCEDURE eq();
  BEGIN
    sys_push(int(sys_pop() = sys_pop()));
  END;


  PROCEDURE _not();
  BEGIN
    sys_push(int(sys_pop() = int(false)));
  END;


  PROCEDURE _and();
  BEGIN
    sys_push(sys_pop() and sys_pop());
  END;


  PROCEDURE _or();
  BEGIN
    sys_push(sys_pop() or sys_pop());
  END;


  PROCEDURE less();
   var
     x : int;
  BEGIN
    x := sys_pop();
    sys_push(int(sys_pop() < x));
  END;


  PROCEDURE great();
   var
     x : int;
  BEGIN
    x := sys_pop();
    sys_push(int(sys_pop() > x));
  END;


  { Write byte to I/O port, value on stack top, address below }
  PROCEDURE _out();
   var
     x : int;
  BEGIN
    x := sys_pop();
    out(sys_pop(),char(x));
  END;


  { Read byte from I/O port }
  PROCEDURE _in();
  BEGIN
    sys_push(int(in(sys_pop())));
  END;


  PROCEDURE dot();
  BEGIN
    put(sys_pop());
  END;


  PROCEDURE emit();
  BEGIN
    put(char(sys_pop()));
  END;


  PROCEDURE key();
  BEGIN
    sys_push(int(getchar()));
  END;


  PROCEDURE _type();
   var
     s : ^string;
  BEGIN
    s := pointer(sys_pop());
    if s = nil then
       put("(NIL)");
    else
       put(s^);
    end;
  END;


  PROCEDURE expect();
   var
     s : ^string;
  BEGIN
    s := pointer(sys_pop());
    if s <> nil then
       gets(s^);
    end;
  END;


  {*
   *  Scan a word from tib into wbuf, return pointer to string.
   *  (separator -- ptr)
   *}

  PROCEDURE word();
   var
     i,pos     : int;
     separator : char;
  BEGIN
    separator := char(sys_pop());
    pos := postib;
    while (tib[pos] = separator) and (pos <= numtib) loop
       inc(pos);
    end loop;
    i := 1;
    while (tib[pos] <> separator) and (pos <= numtib) loop
       wbuf[i] := tib[pos];
       inc(i);
       inc(pos);
    end loop;
    if pos <= numtib then
       { Skip the separator char }
       inc(pos);
    end;
    length(wbuf) := i-1;
    postib := pos;
    sys_push(int(@wbuf));
    {putln("word: ",wbuf);}
  END;


  PROCEDURE words();
   var
     p       : ^symbol_ptr;
     sp      : ^string;
     i,n,pos : int;
  BEGIN
    p := @tab;
    pos := 0;
    while int(p) <= int(context) loop
       sp := @p^^.name;
       n := length(sp^);
       if (pos + n) > 75 then
          putln();
       end;
       put(sp^);

       n := 20 - n;
       for i := 0 while i < n do inc(i) loop
          put(' ');
       end;

       {putln('[',p^^.cfa,"] ",string(p^^.name)," imflag = ",p^^.imflag);}
       int(p) := int(p) + sizeof(pointer);
    end loop;
  END;


  PROCEDURE find(name: string): symbol_ptr;
   var
     p : ^symbol_ptr;
  BEGIN
    p := pointer(context);
    while int(p) > int(@tab) loop
       if name = string(p^^.name) then
          {putln("find: ",name,": ",int(p^));}
          return p^;
       end;
       int(p) := int(p) - sizeof(pointer);
    end loop;
    {putln("find: ",name,": not found");}
    return nil;
  END;


  PROCEDURE query();
  BEGIN
    put("Forth>");
    gets(tib);
    numtib := length(tib);
    postib := 1;
    err_flag := false;
  END;


  PROCEDURE abort(); forward;  


  PROCEDURE interpret();
   var
     funp    : pointer;
     entry   : symbol_ptr;
     numflag : boolean;
     num,i   : int;
  BEGIN
    sys_push(int(' '));
    word();
    drop();
    while (length(wbuf) <> 0) and not err_flag loop
       funp := nil;
       numflag := false;
       entry := find(wbuf);
       if entry <> nil then
          funp := entry^.cfa;
       else
          i := 1;
          numflag := true;
          while numflag and (i <= length(wbuf)) loop
             numflag := (wbuf[i] >= '0') and (wbuf[i] <= '9');
             inc(i);
          end loop;
          num := val(wbuf);
       end;
       if state then
          { Compile mode }
          if numflag then
             num_literal(num);
          elsif entry = nil then
             putln(wbuf,": undefined.");
             dp := current^;
             state := false;
             blk := false;
             err_flag := true;
          else
             if entry^.imflag then
                { Call immediate function }
                call(funp);
                check_stack();
             else
                { Compile function }
                thread(funp);
             end;
          end;
       else
          { Eval mode }
          if numflag then
             sys_push(num);
          elsif entry = nil then
             putln(wbuf," ?");
             err_flag := true;
          else
             call(funp);
             check_stack();
          end;
       end;
       if not err_flag then
          sys_push(int(' '));
          word();
          drop();
       end;
    end loop;
    if err_flag then
       state := false;
       blk := false;
       { Close input file if open by calling abort }
       abort();
    elsif not blk then
       if state then
          putln();
          put('>');
       else
          putln(" ok");
       end;
    end;
  END;


  PROCEDURE quit();
  BEGIN    
    { Setup / restore stack here }
    err_flag := false;
    putln("ok");
    loop
      query();
      interpret();
    end loop;
  END;


  PROCEDURE abort();
  BEGIN
    state := false;
    blk := false;
    { Close input file if open }
    dsp := 0;
    quit();
  END;


  PROCEDURE colon();
  BEGIN
    state := true;
    sys_push(int(' '));
    word();
    drop();
    new_header(wbuf,false);
  END;


  PROCEDURE semicolon();
  BEGIN
    state := false;
    end_def();
  END;


  PROCEDURE comma();
  BEGIN
    compadr(sys_pop());
  END;


  PROCEDURE ccomma();
  BEGIN
    comp(char(sys_pop()));
  END;


  PROCEDURE branch();
  BEGIN
    comp(#$C3);
  END;


  PROCEDURE qbranch();
  BEGIN
    thread(@dpop);
    comp(#$7C);
    comp(#$B5);
    comp(#$20);
    comp(#$03);
    comp(#$C3);
  END;


  PROCEDURE _begin();
  BEGIN
    sys_push(int(dp));
  END;


  PROCEDURE _until();
  BEGIN
    qbranch();
    compadr(sys_pop());
  END;


  PROCEDURE _if();
  BEGIN
    qbranch();
    _begin();
    compadr(0);
  END;


  PROCEDURE _then();
  BEGIN
    _begin();
    swap();
    store();
  END;


  PROCEDURE _else();
  BEGIN
    branch();
    _begin();
    compadr(0);
    swap();
    _begin();
    swap();
    store();
  END;


  PROCEDURE variable();
  BEGIN
    sys_push(int(' '));
    word();
    drop();
    new_var(wbuf);
  END;


  PROCEDURE allot();
  BEGIN
    int(dp) := int(dp) + sys_pop();
  END;


  PROCEDURE constant();
  BEGIN
    sys_push(int(' '));
    word();
    drop();
    new_const(wbuf,sys_pop());
  END;


  PROCEDURE _exit(); forward;


  {*
   *  Scan a quoted string, save it at dp
   *  and return a pointer to the string.
   *  Works for compile mode too.
   *  (--ptr)
   *}

  PROCEDURE quote();
   var
     p,patch : pointer;
  BEGIN
    if state then
       sys_push(int('"'));
       word();
       drop();
       comp(#$C3);
       patch := dp;
       compadr(0);
       p := dp;
       copy(@wbuf,dp,length(wbuf) + 1);
       int(dp) := int(dp) + length(wbuf) + 1;
       set(int(patch),int(dp));
       num_literal(int(p));
    else
       sys_push(int('"'));
       word();
       drop();
       copy(@wbuf,dp,length(wbuf) + 1);
       sys_push(int(dp));
    end;
  END;


  PROCEDURE dotq();
  BEGIN
    quote();
    if state then
       thread(@_type);
    else
       _type();
    end;
  END;


  PROCEDURE immediate();
  BEGIN
    symbol_ptr(context^)^.imflag := true;
  END;


  PROCEDURE install();
  BEGIN
    new_const("dsp",int(@dsp));
    new_const("dp",int(@dp));
    new_const("state",int(@state));
    new_const("tib",int(@tib));
    new_const("wbuf",int(@wbuf));
    new_const("true",1);
    new_const("false",0);
    new_const("nil",0);

    new_fn("dpop",false,@dpop);
    new_fn("dpush",false,@dpush);
    new_fn("@",false,@fetch);
    new_fn("c@",false,@cfetch);
    new_fn("!",false,@store);
    new_fn("c!",false,@cstore);
    new_fn("dup",false,@_dup);
    new_fn("swap",false,@swap);
    new_fn("over",false,@over);
    new_fn("drop",false,@drop);
    new_fn("+",false,@add);
    new_fn("-",false,@sub);
    new_fn("*",false,@mult);
    new_fn("/",false,@idiv);
    new_fn("mod",false,@imod);

    new_fn("and",false,@_and);
    new_fn("or",false,@_or);
    new_fn("not",false,@_not);
    new_fn(">",false,@great);
    new_fn("<",false,@less);
    new_fn("=",false,@eq);

    new_fn("in",false,@_in);
    new_fn("out",false,@_out);

    new_fn(".",false,@dot);
    new_fn("key",false,@key);
    new_fn("expect",false,@expect);
    new_fn("emit",false,@emit);
    new_fn("type",false,@_type);

    new_fn(",",true,@comma);
    new_fn("c,",true,@ccomma);
    new_fn(":",false,@colon);
    new_fn(";",true,@semicolon);
    new_fn("begin",true,@_begin);
    new_fn("until",true,@_until);
    new_fn("if",true,@_if);
    new_fn("else",true,@_else);
    new_fn("then",true,@_then);
    new_fn("var",true,@variable);
    new_fn("const",true,@constant);
    new_fn("allot",true,@allot);
    new_fn("abort",true,@abort);
    new_fn("exit",false,@_exit);
    new_fn("word",false,@word);
    new_fn("words",false,@words);
    new_fn("""",true,@quote);
    new_fn(".""",true,@dotq);
    new_fn("immediate",false,@immediate);
  END;

  PROCEDURE run_forth();
  BEGIN
    putln();
    putln("Z80 Forth version ",version);
    putln("$Id: forth.tml 1.2 1998/05/29 02:50:33 frago Exp frago $");
    dp := @mem;
    base := 10;
    context := @tab;
    current := @tab;
    state := false;
    blk := false;
    mem_full := false;
    install();
    abort();
  END;


{------------ Uncomment this to run in emulator without OS-X  -------------}
{

  PROCEDURE _exit();
  BEGIN
    putln("Can't exit Forth!");
  END;


  PROCEDURE tty_read(): char;
  BEGIN
    while in(ttycmd) = #0 loop
    end loop;
    return in(ttydat);
  END;


  PROCEDURE tty_write(ch: char);
  BEGIN
    out(ttydat,ch);
  END;


BEGIN
  inline($F3,$31,stack_base);    { Setup stack }
  inline(map0c0,set_map_reg0);
  inline(map0c1,set_map_reg1);   { Setup page map registers }
  inline(map0c2,set_map_reg2);
  inline(map0c3,set_map_reg3);
  init_hardware();
  init_system(tty_read,tty_write);
  run_forth();
END forth;
}

{----------------- Uncomment this to run with OS-X  ----------------------}


  PROCEDURE _exit();
  BEGIN
    putln("Z80 Forth terminating...");
    exit(0);
  END;


BEGIN
  run_forth();
END forth;