(* DRAAK.PAS: Please read the bottom of this program for Copyright details. *)
(* Draak: The compiler brain child of Jon Gentle. Hopefully it will work.   *)
(* This would be the third time i have restarted, and will confuse anyone   *)
(* That is trying to use it, because it will, although similar, be diffrant *)
(* Note to self: Draak is a cute rock monster maybe three feet tall.        *)

program Draak;

uses dos, strings, pcatgets;

{Consts}
const
build = '#5';

{Types}
type
 PDef = ^defCmd;
 PAct = ^act;
 PSyn = ^Syntax;
 PVar = ^vars;
 PTyp = ^types;
 defCmd = record
  command: PChar;
  actions: PAct;
  nextDef: PDef;
 end;
 act = record
  asmln: PChar;
  nextAct: PAct;
 end;
 Syntax = record
  synType: pchar;
  synVal: pchar;
  nextSyntax: PSyn;
 end;
 vars = record
  varVal: PChar;
  varType: PChar;
  varDira: PVar;
  nextVar: PVar;
 end;
 types = record
  prevType: PChar;
  newType: PChar;
  nextType: PTyp;
 end;

{Vars}
var
 stacksize, i, iid, verbose     : word;
 outCode, outData, outSource    : text;
 Cheader, DAct, THead           : PAct; {It's not just cheese}
 stest                          : string; {These are bad! Use PChar if Possible}
 momVars                        : PVar;
 momTypes                       : PTyp;
 {For Error Easy...}
 workFile, workLine             : string;
 lineNum, strNum, jmpNum        : word;
 globalDef                      : PDef;
 gdefChar                       : char;
 diraCheat                      : integer;
 currReg                        : array[0..5] of char;
 jmpQue                         : array[0..32] of word;

 openDefs: array[0..4] of
 record
  extension: array[0..3 ] of char;
  defPtr: PDef;
 end;

{Procedures Forwards}
{This is just easier}
{draak .pas}
function Vala(inhere: PChar): word; forward;
function Stra(inhere: integer): string; forward;
procedure error(errcode: byte); forward;
procedure processFile(inFile: string); forward;
procedure processLine(icode: PChar); forward;
{parser.pas}
function parseDefFile(infile: PChar): PDef; forward;
procedure destroyAct(inAct: PAct); forward;
function splitLine(unsplit: string): PChar; forward;
function replaceSyn(icode: PChar; syn: PSyn): PChar; forward;
{syntax.pas}
function isChar(inchar: char): boolean; forward;
function isChare(inchar: char): boolean; forward;
function checkSyntax(icode: PChar; defs, retDef: PDef): PSyn; forward;
procedure handleAct(def: PDef; syns: PSyn); forward;
procedure actCase(acts: PAct; syns: PSyn); forward;
procedure destroySyn(inSyn: PSyn); forward;
{handle.pas}
procedure handleCmd(acts: PAct; syns: PSyn); forward;
function abstra(acts: PAct; syns: PSyn): PVar; forward;
procedure strip(acts: PAct; syns: PSyn); forward;
procedure localVars(acts: PAct; syns: PSyn); forward;
procedure codePrep(acts: PAct; syns: PSyn); forward;
procedure define(acts: PAct; syns: PSyn); forward;
function determineSize(typed: PChar): byte; forward;
function findVar(inName: PChar): PVar; forward;
procedure stringalize(acts: PAct; syns: PSyn); forward;
procedure evaulate(acts: PAct; syns: PSyn); forward;
procedure evalOne(acts:PAct; syns: PSyn); forward;
{procedure hinclude(incode: PChar); forward;}
{diract.pas}
procedure handleDira(acts: PAct; syns: PSyn); forward;
procedure diraIf(acts: PAct; syns: PSyn); forward;
procedure getStuff(acts: PAct; syns: PSyn); forward;

{Procedures}
{To break the code up, i'm putting diffrant parts in}
{to the following files.  Please see them for specifics.}
{$I parser.pas}
{$I diract.pas}
{$I syntax.pas}
{$I handle.pas}
{$I info.pas}

{Getting Val is easier with Vala}
function Vala(inhere: PChar): word;
var w,c: word;
begin val(strPas(inHere), w, c); Vala := w; end;

function Stra(inhere: integer): string;
var s: string; begin str(inhere, s); Stra := s; end;

{For producing error messages via Cats...}
procedure error(errcode: byte);
var catd: nl_catd;
begin
 catd := catopen ('cats', 1);
 if catd < 1 then catd := catopen('.\cats.en',1);
 if catd < 1 then
 begin
  writeln('Sorry, This program has problems, but i don''t know what they are');
  writeln('because some moron forgot to give you the file that has all of my error');
  writeln('definations in it.  If you wanted to know, it was error #', Stra(errcode),'.');
  halt(errcode);
 end;
 writeln(catgets(catd, 1, errcode, ''));
 writeln('  ', workFile, '(', lineNum, '): ', workLine);
 catClose(catd);
 close(outCode);
 close(outData);
 halt(1);
end;

procedure processFile(inFile: string);
var ext: extStr; path: pathStr; die1: nameStr; die2: dirStr;
 defFile: PChar; parseDef: PDef;
 inSource: text; blockLn: string;
 pcharLn: PChar; curLnNum: word;
begin
 curLnNum := 0; jmpNum := 1;
 path := inFile; parseDef := nil;
 fSplit(path, die2, die1, ext);
 getMem(defFile, 9);
 strPCopy(defFile, ext);
 for i := 0 to 4 do
 if strComp(openDefs[i].extension, defFile)=0 then
 parseDef := openDefs[i].defPtr
 else if openDefs[i].defPtr = nil then break;
 if ((parseDef = nil) AND (i = 4)) then error(4);
 if parseDef = nil then
 begin
  defFile := defFile+length(ext);
  strPCopy(defFile, '.def');
  defFile := defFile-length(ext)+1;
  parseDef := parseDefFile(defFile);
  if i <> 0 then destroyAct(THead) else cheader := Thead;
  THead := nil;
  openDefs[i].defPtr := parseDef;
  strPCopy(openDefs[i].extension, ext);
{  freeMem(defFile-1, 9);}
  defFile := defFile-1;
 end;
 freeMem(defFile, 9);
 assign(inSource, inFile);
 reset(inSource);
 while (NOT(eof(inSource))) do
 begin
  currReg := 'ax';
  workFile := inFile; lineNum := curLnNum + 1; curLnNum := LineNum;
  readLn(inSource, blockLn);
  workLine := blockLn;
  if verbose = 2 then writeLn(outCode, ';'+workFile+'  '+stra(lineNum)+' '+blockLn);
  pcharLn := splitLine(blockLn);
  globalDef := parseDef;
  processLine(pcharLn);
  i := strLen(pcharLn)+1;
  freeMem(pcharLn, i);
 end;
 close(insource);
end;

procedure processLine(icode: PChar);
var parseDef, def: PDef;
 place, last: PChar;
 currSyn: PSyn;
begin
 place := icode; parseDef := globalDef;
 while strScan(place, #13) <> nil do
 begin
  last := strScan(place, #13);
  last^ := #0;
  new(def);
  currSyn := checkSyntax(place, parseDef, def);
  handleAct(def^.nextDef, currSyn);
  dispose(def);
  destroySyn(currSyn);
  last^ := #13; place := last+1;
 end;
end;

begin
 versions;
 stackSize := 2048; strNum := 0;
 filemode := 0;
 assign(outData, 'data.$$$');
 rewrite(outData);
 assign(outCode, 'code.$$$');
 rewrite(outcode);
 assign(outSource, paramStr(2));

 new(momVars); new(momTypes);
 momVars^.nextVar := nil; momVars^.varVal := nil; momVars^.varType := nil;
 momTypes^.prevType := nil; momTypes^.newType := nil; momTypes^.nextType := nil;

 processFile(paramStr(1));

 rewrite(outsource);
 DAct := Cheader;
 while DAct <> nil do
 begin
  writeln(outsource, DAct^.asmln);
  DAct := DAct^.nextAct;
 end;

 filemode := 1;
 reset(outData);
 reset(outCode);

 while (not(eof(outCode))) do
 begin readln(outCode, stest); writeln(outSource, stest); end;

 writeln(outSource,'');
 writeln(outSource,'SEGMENT DATA');

 while (not(eof(outData))) do
 begin readln(outData, stest); writeln(outSource, stest); end;

 writeln(outSource, '');
 writeln(outSource, 'SEGMENT stack stack');
 writeln(outSource, 'resb ', stackSize);
 writeln(outSource, ' stacktop:');

 close(outSource);
 close(outCode);
 close(outData);
 erase(outData);
 erase(outCode);

{ error(1);}
end.

(* ************************************************************ *)
(* Copyright (c) 1999-2000 Jon Gentle, All right reserved.      *)
(* ************************************************************ *)
(* This software is given As-Is.  No warranties of any kind,    *)
(* implied or expressed, are given to anyone.  The author(s)    *)
(* shall not be held for any liability under any circumstances. *)
(* Permission is granted to anyone who wishes to alter, use or  *)
(* distribute this software, as long as the following           *)
(* restrictions are met:                                        *)
(*                                                              *)
(* 1) The above copyright and this notice must appear in the    *)
(* software, both in binary and source code form.  Under no     *)
(* circumstance are these to be removed.                        *)
(* 2) Anyone other then the copyright owner that alters source  *)
(* code must mark the source code as altered.                   *)
(* 3) All altered source code must be released for easy acsess. *)
(* 4) Original authorship of part or whole must not be          *)
(* misrepresented.                                              *)
(* ************************************************************ *)