Why Not Assembler 1.1

 program wnASSEMBLER; // 2021.07.03. 23:06:53
                      // Fresh News: LABELS, 3 New Instruct, ORIGIN & a FLAG
                      // wn means: Why Not?
                      // ++ > Hex input. Format: $00 - $FF
  uses sysutils;                        // <- strToInt
  const
   BASE    =  96;
   PAGES   =  6;                        // oszto
   DATMAX  = (BASE div PAGES)-2;        // Adatszegmens kapacitasa
   INITIP  =  BASE div PAGES;           // Origin (10h)
   PREHEX  = '$';                       // Hex num. prefixe. Csak '$' lehet!!!
                                        // igy nem kell konverzios fuggv.-t irni.
  var
   Ch      : Char;                      // bejovo karakter puffere
   Token   : string;                    // token  puffere
   DATCount: integer = 0;               // Valtozok szamlaloja
   NonDAT  : boolean = false;
   IP      : byte    = 1;               // mem[00] foglalva a visszateresi cimnek
                                        // igy az elso DATA cime a mem[01]!
   ORIGIP  : byte    = 0;               // foprogram cime
   MEM     : array[0..(BASE-1)]of byte; // Memoria (64, 96, 128 vagy 256 byte)
   LBL     : array[0..9] of byte;       // labelek cimei

 Procedure Error(s: string);            // hiba
 begin
   writeln(s);
   halt;
 end;

 function GetLabelAddr(i: byte): byte;  // az i altal indexelt helyrol kiolvassaa az i label cimet.
 begin
   if (i > 9) then Error(' Unknown label or >9')  // ha i kisebb v egyenlo 9
    else
   GetLabelAddr := LBL[i];
 end;

 procedure SetLabelAddr(i: byte);       // az i altal indexelt helyre beirja i azonosítoju label cimet
 begin
   if (i > 9) or (LBL[i] > 0) then Error(' Duplicated Label or >9')
    else
   LBL[i] := IP;
 end;

 Procedure GetCh;                       // Egy karaktert olvas a STD bemenetrol
 begin
   Read(Ch);                            // a Ch nevu Char tip. valtozoba
 end;

 function AlphaBet(c : char) : boolean; // true-val ter vissza, ha a c eleme A..Z halmaznak
 begin
   AlphaBet := UpCase(c) in ['A'..'Z'];
 end;

 function Numeric(c : char) : boolean;  // true-val ter vissza, ha c eleme a 0..9 halmaznak
 begin
   Numeric := (Upcase(c) in ['0'..'9','A'..'F',PREHEX]);
 end;

 function Labels(c : char) : boolean;   // true-val ter vissza, ha a c egy label prefix karaktere
 begin
   Labels := (c = '#');
 end;

 procedure DropWhite;                   // kiejti a feldolgozasbol a space es TAB karaktereket
 begin
   while  Ch in [' ',#09] do GetCh;
 end;

 function GetKeyWord : string;          // ha token elso Ch key akkor ez kiegesziti
 var
   i  : byte = 0;
 begin
   GetKeyWord := '';
   while AlphaBet(Ch) do
   begin
    GetKeyWord := GetKeyWord + UpCase(Ch);
    GetCh;
    inc(i);
   end;
   if (i <> 3) then error(' Keyword error: '+GetKeyWord );
 end;

 function GetNumber : string;           // ha token elso Ch NUM akkor ez kiegesziti
 var
   i  : byte = 0;
 begin
   GetNumber := '';
   while Numeric(Ch) do
   begin
    GetNumber := GetNumber + Ch;
    GetCh;
    inc(i);
   end;
   if (i > 3) then error(' Error (number length?)');
 end;

 function GetLabel : string;         // ha token elso Ch Label akkor ez kiegesziti
 begin
  GetLabel := Ch;
  GetCh;
  if (numeric(Ch) <> true) then Error(' Label error: #'+Ch);
  Getlabel:= Getlabel+Ch;
  GetCh;
  if Ch = ':' then GetLabel := GetLabel+Ch;
 end;

 function GetToken : string;                    // a Token tipusanak szelektora
 begin
   DropWhite;
   if AlphaBet(Ch) then GetToken := GetKeyWord
     else
   if Numeric(Ch)  then GetToken := GetNumber
     else
   if Labels(Ch)   then GetToken := GetLabel
     else
     begin GetToken := Ch; GetCh; end;
   DropWhite;
 end;

 procedure MemLoad(key: string);
 begin
   case key of
    'INC': MEM[IP]:= $F1;
    'DEC': MEM[IP]:= $F0;
    'SWP': MEM[IP]:= $CD;
    'ORG': begin ORIGIP := IP; dec(IP); end;
     //----------------------- orig. instructions:
    'SUB': MEM[IP]:= $AA;
    'ADD': MEM[IP]:= $AD;
    'CMP': MEM[IP]:= $C0;
    'JMP': MEM[IP]:= $EA;
    'JZR': MEM[IP]:= $E0;
    'LDA': MEM[IP]:= $AB;
    'STA': MEM[IP]:= $BA;
    'RET': MEM[IP]:= $FF;
    'DAT': if (DATCount < DATMAX) then inc(DATCount) else  error(' Too much Vars?');
     else error('Unknown keyword: '+key);
   end; {case}
   if (key <> 'DAT') then inc(IP);
 end;

  procedure CheckDAT;
 begin
   if (Token[1] <> 'D') then NonDAT := true;
   if (NonDAT = true) and (IP < INITIP) then IP := INITIP;
 end;

 procedure MemSaveToFile;  // binary file borning. This is the GENESIS!
 var i: byte;
     f: file of byte;
 begin
   Assign(f,paramstr(1));
   rewrite(f,1);
   MEM[00] := ORIGIP;
   for i := 0 to BASE-1 do write(f,MEM[i]);
   close(f);
 end;
  // -----------------  Please, fasten Your safety Belt!
 begin
   GetCh;             //  The first step
   repeat
     Token := GetToken;

     if (Token = ';') or (Ch = ':') then while (Ch <> #10) do GetCh; // decommenter
     if (Token <> #13) and (Token <> #10) and (token <> ';') then
     begin
       if Alphabet(Token[1]) then                               // if keyWord
       begin
        CheckDAT;
        if (IP <= BASE-1) then MemLoad(Upcase(Token))  else error(' program is too big');
       end
       else
       if Numeric(Token[1]) then                                // if ADDR or param
       begin
       if (Token[2] = PREHEX) or (Token[3] = PREHEX) then  error(' Invalid HEX');
        if (StrToInt(Token) < 256) then MEM[IP]:= StrToInt(Token) else  error(' BIG int?');
        inc(IP);
       end
       else
       if Labels(Token[1]) then                                 // if Label
       begin
        CheckDAT;
         if (length(Token) > 2) then SetLabelAddr(StrToInt(Token[2]))
         else
         begin
          MEM[IP] := GetLabelAddr(StrToInt(Token[2]));
          Inc(IP);
         end;
       end
       else Error(' Hurray, its a BRAVE NEW token: '+Token);
     end;   //  if (token <> #13)
   until EOF(input);

   MemSaveToFile;
 end.