{****************************************************}
{* простой компилятор на машину                     *}
{* Stas Sidorenko (2:5045/6.38)                     *}
{****************************************************}
{* запуск:                                          *}
{*   sc.exe < 1.sc > 1.out                          *}
{****************************************************}

{----------- тулзы и обработка ошибок ---------------}
function HexB(b : byte): string;
const
  Hex: array[0..$F] of char = '0123456789ABCDEF';
begin
  HexB[0] := #2;
  HexB[1] := Hex[b shr 4];
  HexB[2] := Hex[b and $F];
end;

function HexW(w : word): string;
begin
  HexW:=HexB(hi(w))+HexB(lo(w));
end;

procedure SetFlag(var Flags : Byte; FlagMask : Byte);
begin
  Flags := Flags or FlagMask;
end;

function FlagIsSet(Flags : Byte; FlagMask : Byte) : Boolean;
begin
  FlagIsSet := (Flags and FlagMask) <> 0;
end;

const
  ceUndefErr     = 4;
  ceRParenExp    = 4;
  ceThenExp      = 6;
  ceErrInExpr    = 7;
  ceExpectEql    = 8;
  ceUnexpectedEOF=10;

procedure Error(err: integer);
begin
  writeLn(^M^J^G,'Error: ',err,'.');
  Halt;
end;

{--- программная модель гипотетического процессора --}
const
  {машинные команды}
  _movAxVar=$01; _movAxImm=$02; _movAxBx =$03; _movBxAx =$04; _movVarAx=$05;
  _pushAx  =$11; _popAx   =$12; _popBx   =$13;
  _addBx   =$21; _subAxBx =$22; _mulBx   =$23; _divBx   =$24;
  _setE    =$31; _setNe   =$32;   { =  <> }
  _setLss  =$33; _setLea  =$34;   { <  <= }
  _jmp     =$41; _jz      =$42;
  _orAxAx  =$51; _xorAxAx =$52; _cmpBx   =$53;
  _wrtAX   =$61; _wrtLn   =$62;
  _hlt     =$FF;

const
  {маски флагов}
  ZF = $40;    {флаг нуля}
  SF = $80;    {флаг отрицательного числа}

var
  Memory: array[0..$7FFF] of byte;

  CS, DS, SS: word;   {сегментные регистры}
  IP, DP, SP: word;   {группа PI}
  AX, BX: integer;    {общие регистры}
  F: byte;            {регистр флагов}
  IR: byte;           {выполняемая комманда}

  operand: word;      {костанта, адрес перехода, переменной}
  running: boolean;   {программа выполняется пока running}

procedure FetchAdr;
begin
  operand:=Memory[IP]*$100+Memory[IP+1];
  inc(IP,2);
end;

procedure push(i: integer);
begin
  dec(SP,2);
  Memory[SP+1]:=hi(i);
  Memory[SP]:=lo(i);
end;

function pop: integer;
begin
  pop:=Memory[SP]+Memory[SP+1]*$100;
  inc(SP,2);
end;

procedure Test(i: integer);
begin
  F:=0;
  if i<0 then
    SetFlag(F, SF)
  else if i=0 then
    SetFlag(F, ZF)
end;

procedure Execute;
begin
  case IR of
    _movAxVar: begin FetchAdr; AX:=Memory[operand]*$100+Memory[operand+1]; end;
    _movVarAx: begin FetchAdr; Memory[operand]:=hi(AX); Memory[operand+1]:=lo(AX); end;
    _movAxImm: begin FetchAdr; AX:=operand; end;
    _movAxBx:  AX:=BX;
    _movBxAx:  BX:=AX;

    _pushAx:   push(AX);
    _popAx:    AX:=pop;
    _popBx:    BX:=pop;

    _addBx:    AX:=AX+BX;
    _subAxBx:  AX:=AX-BX;
    _mulBx:    AX:=AX*BX;
    _divBx:    AX:=AX div BX;

    _jmp:      begin FetchAdr; IP:=operand; end;
    _jz:       if FlagIsSet(F, ZF) then begin
                 FetchAdr;
                 IP:=operand;
               end else
                 inc(IP,2);
    _orAxAx:   Test(AX);
    _xorAxAx:  begin AX:=0; Test(AX); end;
    _cmpBx:    Test(AX-BX);
    _setE:     begin
                 AX:=0;
                 if FlagIsSet(F, ZF) then
                   AX:=1;
               end;
    _setNe:    begin
                 AX:=0;
                 if not FlagIsSet(F, ZF) then
                   AX:=1;
               end;
    _setLss:   begin
                 AX:=0;
                 if FlagIsSet(F, SF) then
                   AX:=1;
               end;
    _setLea:   begin
                 AX:=0;
                 if FlagIsSet(F, SF) or FlagIsSet(F, ZF) then
                   AX:=1;
               end;
    _wrtAX:    write(AX, ' ');
    _wrtLn:    writeln;
    _hlt:      running:=false;
  end;
end;

procedure Fetch;
begin
  IR:=Memory[IP];
  inc(IP);
end;

procedure Run;
begin
  running:=true;
  IP:=0;
  while running do begin
    Fetch;      {выборка очередной команды}
    {здесь можно вставить сопроцессор}
    Execute;    {выполнение команды}
    {здесь реакцицю на прерывания}
  end;
end;

procedure ListCmd;
begin
  case IR of
    _movAxVar: begin FetchAdr; writeln(#9'MOV'#9'AX, [',HexW(operand),']'); end;
    _movVarAx: begin FetchAdr; writeln(#9'MOV'#9'[',HexW(operand),'], AX'); end;
    _movAxImm: begin FetchAdr; writeln(#9'MOV'#9'AX, ',operand);  end;
    _movAxBx:  begin writeln(#9'MOV'#9'AX, BX'); end;
    _movBxAx:  begin writeln(#9'MOV'#9'BX, AX'); end;

    _pushAx:   writeln(#9'PUSH'#9'AX');
    _popAx:    writeln(#9'POP'#9'AX');
    _popBx:    writeln(#9'POP'#9'BX');

    _addBx:    writeln(#9'ADD'#9'BX');
    _subAxBx:  writeln(#9'SUB'#9'AX, BX');
    _mulBx:    writeln(#9'MUL'#9'BX');
    _divBx:    writeln(#9'DIV'#9'BX');

    _jmp:      begin FetchAdr; writeln(#9'JMP'#9,HexW(operand)); end;
    _jz:       begin FetchAdr; writeln(#9'JZ'#9,HexW(operand)); end;

    _orAxAx:   writeln(#9'OR'#9'AX, AX');
    _xorAxAx:  writeln(#9'XOR'#9'AX, AX');
    _cmpBx:    begin writeln(#9'CMP'#9'AX, BX') end;

    _setE:     writeln(#9,'SETE'#9'AX');
    _setNE:    writeln(#9,'SETNE'#9'AX');
    _setLss:   writeln(#9,'SETLSS'#9'AX');
    _setLea:   writeln(#9,'SETLEA'#9'AX');

    _wrtAx:    writeln(#9,'WRT'#9'AX');
    _wrtLn:    writeln(#9,'WRTLN');
    _hlt:      begin writeln(#9'HLT'); running:=false; end;
  end;
end;

procedure List;
begin
  writeln;
  writeln('; Программа ...');
  running:=true;
  IP:=0;
  while running do begin
    write(HexW(IP));
    Fetch;
    ListCmd;
  end;
end;

{------- процедуры для работы с таблицей имен --------}
const
  maxCount = 99;
  _keyword = 0;
  _ident   = 1;

type
  {элемент таблицы имен}
  tNameTable = record
    Name: string[10];   {имя переменной}
    Obj:  byte;         {_ident, _keyword}
    case byte of
      _ident:   (Adr:  word);  {адрес в сегменте данных}
      _keyword: (Tok:  byte);  {номер keyword}
  end;

var
  tnCount: byte;
  NameTable: array[0..MaxCount] of tNameTable;

function AddObject(Name: string; Obj: byte; Adr: word): word;
begin
  inc(tnCount);
  NameTable[tnCount].Name:=Name;
  NameTable[tnCount].Obj:=Obj;
  case Obj of
    _ident:   begin
                Adr:=DS+DP;
                inc(DP, 2);
                NameTable[tnCount].Adr:=Adr;
              end;
    _keyword: NameTable[tnCount].Tok:=byte(Adr);
  end;
  AddObject:=Adr;
end;

function Find(Name: string; var ENT: tNameTable): boolean;
var
  i: byte;
begin
  Find:=true;
  i:=tnCount;
  NameTable[0].Name:=Name;
  while NameTable[i].Name<>Name do
    dec(i);
  ENT:=NameTable[i];
  if i=0 then
    Find:=false;
end;

function LockKey(Name: string): byte;
var
  ENT: tNameTable;
begin
  LockKey:=_ident;
  if Find(Name, ENT) then
    if ENT.Obj=_keyword then
      LockKey:=ENT.Tok;
end;

function LockVar(Name: string; var Adr: word): boolean;
var
  ENT: tNameTable;
begin
  LockVar:=Find(Name, ENT);
  Adr:=ENT.Adr;
end;

{------------- лексический анализатор ---------------}
const
  {типы лексем}
  _lparent = 2; _rparent = 3; _integer = 4; _unknow   = 10;
  _plus  =11;  _minus   =12; _mul     =13; _div     =14; _comma    = 15;

  { =         <>           <           <=        }
  _eql = 21; _neg  = 22; _lss   = 23; _lea   = 24;
  _begin=31; _if   = 32; _then  = 33; _else  = 34;
  _while=35; _end  = 36; _write = 37;

var
  p: word;
  ch: char;

  tTok: byte;      {тип лексемы}
  sTok: string;    {строковое представление лексемы}
  iTok: integer;   {если лексема число - ее числовое значение}

function NextCh: char;
var
  ch: char;
begin
  read(ch);
  NextCh:=ch;
end;

procedure Get;

  procedure GetIdent;
  begin
    while upcase(ch) in ['A'..'Z', '0'..'9'] do begin
      sTok:=sTok+upcase(ch);
      ch:=NextCh;
    end;
    tTok:=LockKey(sTok)
  end;

  procedure GetNum;
  var
    e: integer;
  begin
    while ch in ['0'..'9'] do begin
      sTok:=sTok+ch;
      ch:=NextCh;
    end;
    val(sTok, iTok, e);
    tTok:=_integer;
  end;

begin
  sTok:='';

  while (ch in [#9,#32,#10,#13]) do
    ch:=NextCh;

  case upcase(ch) of
    'A'..'Z': GetIdent;
    '0'..'9': GetNum;
    ',': begin tTok:=_comma; ch:=Nextch; end;
    '+': begin tTok:=_plus; ch:=Nextch; end;
    '-': begin tTok:=_minus; ch:=Nextch; end;
    '*': begin tTok:=_mul; ch:=Nextch; end;
    '/': begin tTok:=_div; ch:=Nextch; end;
    '(': begin tTok:=_lparent; ch:=Nextch; end;
    ')': begin tTok:=_rparent; ch:=Nextch; end;
    '=': begin tTok:=_eql; ch:=Nextch; end;
    '<': begin   { <, <=, <> }
           ch:=NextCh;
           if ch= '=' then begin
             tTok:=_lea;
             ch:=NextCh
           end else
             if ch= '>' then begin
               tTok:=_neg;
               ch:=NextCh;
             end else
               tTok:=_lss;
         end;
    #26: Error(ceUnexpectedEOF);
    else begin
           tTok:=_unknow;
         end;
  end;
end;

{------------- генерация кода на машину --------------}
procedure Emit(cmd: integer);
begin
  Memory[IP+CS]:=cmd;
  inc(IP);
end;

procedure Emit2(cmd, val: integer);
begin
  Emit(cmd);
  Emit(hi(val));
  Emit(lo(val));
end;

procedure FixUp(adr, val: integer);
{ - правка операнда для команд типа jmp}
begin
  Memory[adr+1]:=hi(val);
  Memory[adr+2]:=lo(val);
end;

{- синтаксический анализатор, тобишь компилятор кода -}
procedure BoolExpression; Forward;

procedure Factor;
var
  adr: word;
begin
  if tTok=_ident then
    if LockVar(sTok, Adr) then
      Emit2(_movAxVar, adr)
    else begin
      adr:=AddObject(sTok, _ident, 0);
      Emit2(_movAxVar, adr)
    end
  else
    case tTok of
      _integer: Emit2(_movAxImm, iTok);  {load const}
      _lparent: begin
                  Get;
                  BoolExpression;
                  if tTok<>_rparent then
                    error(ceRParenExp)
                end;
      else
        error(ceErrInExpr);
    end;
  Get;
end;

procedure Term;
var
  op: byte;
begin
  Factor;
  while tTok in [_mul, _div] do begin
    op:=tTok;
    Emit(_pushAx);
    Get;
    Factor;
    case op of
      _mul: begin
              Emit(_popBx);
              Emit(_mulBx);
            end;
      _div: begin
              Emit(_movBxAx);
              Emit(_popAx);
              Emit(_divBx);
            end;
    end;
  end;
end;

procedure Expression;
var
  op: byte;
begin
  if tTok in [_plus, _minus] then
    Emit(_xorAxAx)
  else
    Term;
  while tTok in [_plus, _minus] do begin
    op:=tTok;
    Emit(_pushAx);
    Get;
    Term;
    case op of
      _plus:  begin
                Emit(_popBx);
                Emit(_addBx);
              end;
      _minus: begin
                Emit(_movBxAx);
                Emit(_popAx);
                Emit(_subAxBx);
              end;
    end;
  end;
end;

procedure BoolExpression;
var
  op: byte;
begin
  Expression;
  if tTok in [_eql, _neg, _lss, _lea] then begin
    op:=tTok;
    Emit(_pushAx);
    Get;
    Expression;
    Emit(_movBxAx);
    Emit(_popAx);
    Emit(_cmpBx);
    case op of
      _eql: Emit(_setE);
      _neg: Emit(_setNe);
      _lss: Emit(_setLss);
      _lea: Emit(_setLea);
    end;
  end;
end;

procedure Statement; Forward;

procedure Print;
{ - реализация простейшего варианта writeln}
begin
  Get;
  BoolExpression;
  Emit(_wrtAX);
  while tTok=_comma do begin
    Get;
    BoolExpression;
    Emit(_wrtAX);
  end;
  Emit(_wrtLn);
end;

procedure Assignment;
{ - операция присваивания (типа a:=...)}
var
  adr: word;
begin
  {получить адрес переменной в сегменте данных и если ее там нет - добавить}
  if not LockVar(sTok, adr) then
    adr:=AddObject(sTok, _ident, 0);
  Get;
  if tTok=_eql then
    Get
  else
    Error(ceExpectEql);
  BoolExpression;
  Emit2(_movVarAx, adr); {запомнить результат}
end;

procedure WhileState;
var
  pc1,pc2: integer;
begin
  Get;
  pc1:=IP;            {запомнить начало while}
  BoolExpression;     {вычислить выражение}
  Emit(_orAxAx);      {если AX=0 устанавливается флаг Z}
  pc2:=IP;            {запомнить адрес команды}
  Emit2(_jz, 0);      {если AX=0 выйти из while, адрес уточним потом}
  Statement;
  Emit2(_jmp,pc1);    {вернуться в начало while}
  FixUp(pc2, IP);     {выставляем адрес}
end;

procedure IfState;
var
  pc1,pc2: integer;
begin
  Get;
  BoolExpression;     {вычислить выражение}
  Emit(_orAxAx);      {если AX=0 устанавливается флаг Z}
  pc1:=IP;            {запомнить адрес JMP - чтобы потом исправить адрес}
  Emit2(_jz, 0);      {обойти блок THEN если условие нее выполняется}
  if TTok=_then then
    Get
  else
    error(ceThenExp);
  Statement;          {блок THEN}
  if TTok<>_else then
    FixUp(pc1, IP)    {исправляем адрес - блока ELSE нет}
  else begin
    Get;
    pc2:=IP;          {запомнить адрес конца блока THEN}
    Emit2(_jmp, 0);   {вставить команду JMP из конструкции IF_THEN_ELSE}
    FixUp(pc1, IP);
    Statement;        {блок ELSE}
    FixUp(pc2, IP);   {выставляем адрес}
  end;
end;

procedure BeginState;
{ - обработка begin ... end}
begin
  Get;
  repeat
    if tTok<>_end then
      Statement;
  until tTok = _end;
end;

procedure Statement;
begin
  case tTok of
    _begin: BeginState;
    _while: WhileState;
    _if:    IfState;
    _write: Print;
    _ident: Assignment;
    else  Error(ceUndefErr);
  end;
end;

procedure Init;
var
  adr: word;
begin
  {init Get}
  p:=0;
  ch:=NextCh;

  {init Mashin}
  CS:=0;       IP:=0;
  DS:=$1FFF;   DP:=0;
  SS:=$3FFF;   SP:=SS;

  {инициализаци таблицы имен}
  tnCount:=0;
  adr:=AddObject('BEGIN', _keyword, _begin);
  adr:=AddObject('ELSE',  _keyword, _else);
  adr:=AddObject('END',   _keyword, _end);
  adr:=AddObject('IF',    _keyword, _if);
  adr:=AddObject('THEN',  _keyword, _then);
  adr:=AddObject('WHILE', _keyword, _while);
  adr:=AddObject('WRITE', _keyword, _write);
end;

procedure Compile;
begin
  Get;          {здесь по идее хорошобы разместить пролог программы}
  Statement;
  Emit(_hlt);   {это, есно, эпилог}
end;

begin
  Init;
  Compile;
  List;
  Run;
  writeln('-----');
end.
