fork download
copy 
  1.  program uASM;   // 2021.06.30. 6:24:22
  2.  uses sysutils;                         // <- strToInt
  3.  
  4.   const
  5.    BASE    =  64;                       // memoria merete, byte-ban        
  6.    DATMAX  = (BASE div 4)-2;            // Adatszegmens kapacitasa 
  7.    INITIP  =  BASE div 4;               // Origin (10h)
  8.  
  9.   var 
  10.    Ch      : Char;                      // bejovo karakter puffere 
  11.    Token   : string;                    // token  puffere 
  12.    DATCount: integer = 0;               // Valtozok szamlaloja 
  13.    NonDAT  : boolean = false; 
  14.    IP      : byte    =  1;              // mem[0] foglalva a visszateresi cimnek 
  15.                                         // igy az elso DATA cime a mem[1]! 
  16.    MEM     : array[0..(BASE-1)]of byte; // Memoria (64, 128 vagy 256 byte)
  17.    LBL     : array[0..9] of byte;       // labels addresses
  18.  
  19.  Procedure Error(s: string);            // hiba
  20.  begin
  21.    writeln(s);  halt;
  22.  end; 
  23.  
  24.  function GetLblAddr(i: byte): byte;    // Get
  25.  begin
  26.    if (i > 9) then Error(' Unknown label or >9? ')  
  27.     else            
  28.    GetLblAddr := LBL[i]; 
  29.  end;  
  30.  
  31.  procedure SetLblAddr(i: byte);         // Set
  32.  begin
  33.    if (i > 9) or (LBL[i] > 0) then Error(' Duplicated Lbl or >9') 
  34.     else 
  35.    LBL[i] := IP; 
  36.  end;  
  37.  
  38.  Procedure GetCh;
  39.  begin
  40.    Read(Ch);
  41.  end;
  42.  
  43.  function AlphaBet(c : char) : boolean;
  44.  begin
  45.    AlphaBet := UpCase(c) in ['A'..'Z'];
  46.  end;
  47.  
  48.  function Numeric(c : char) : boolean;
  49.  begin
  50.    Numeric := (c in ['0'..'9']);
  51.  end;
  52.  
  53.  function Labels(c : char) : boolean;
  54.  begin
  55.    Labels := (c in ['#']);
  56.  end;
  57.  
  58.  
  59.  procedure DropWhite;
  60.  begin
  61.    while  Ch in [' ',#09] do GetCh;
  62.  end;
  63.  
  64.  // -----------------------------------------------
  65.  function GetKeyWord : string;
  66.  var
  67.    i  : byte = 0;
  68.  begin
  69.    GetKeyWord := '';
  70.    while AlphaBet(Ch) do
  71.    begin   
  72.     GetKeyWord := GetKeyWord + UpCase(Ch);
  73.     GetCh;
  74.     inc(i);
  75.    end;
  76.    if (i <> 3) then error(' Keyword error: '+GetKeyWord );
  77.  end;
  78.  
  79.  function GetNumber : string;
  80.  var
  81.    i  : byte = 0;
  82.  begin
  83.    GetNumber := '';
  84.    while Numeric(Ch) do
  85.    begin
  86.     GetNumber := GetNumber + Ch;
  87.     GetCh;
  88.     inc(i);
  89.    end;
  90.    if (i > 3) then error(' Error (number length?)');
  91.  end;
  92.  
  93.  function GetLbl : string; 
  94.  begin
  95.   GetLbl := Ch; GetCh;  
  96.   Getlbl:= Getlbl+Ch;  GetCh; 
  97.   if Ch = ':' then GetLbl := GetLbl + Ch;   
  98.  end;
  99.  
  100.  function GetToken : string;
  101.  begin
  102.    DropWhite;
  103.    if AlphaBet(Ch) then GetToken := GetKeyWord
  104.    else
  105.    if Numeric(Ch)  then GetToken := GetNumber
  106.    else
  107.    if Labels(Ch)   then GetToken := GetLbl
  108.    else   
  109.    begin
  110.     GetToken := Ch;
  111.     GetCh;
  112.    end;
  113.    DropWhite;
  114.  end;
  115.  
  116.  procedure MemLoad(key: string);
  117.  begin 
  118.    case Upcase(key) of
  119.     'SUB':  MEM[IP]:= $AA;  
  120.     'ADD':  MEM[IP]:= $AD;  
  121.     'CMP':  MEM[IP]:= $C0;  
  122.     'JMP':  MEM[IP]:= $EA;  
  123.     'JZR':  MEM[IP]:= $E0;  
  124.     'LDA':  MEM[IP]:= $AB;  
  125.     'STA':  MEM[IP]:= $BA;  
  126.     'RET':  MEM[IP]:= $FF;  
  127.     'DAT':  if (DATCount < DATMAX) then inc(DATCount) else  error(' Too much Vars?');
  128.    else error('Unknown keyword: '+key);
  129.    end; {case} 
  130.  
  131.    if UpCase(key) <> 'DAT' then inc(IP);
  132.  end;
  133.  
  134.  procedure MemSaveToFile;
  135.  var i: byte;
  136.      f: file of byte;
  137.  begin
  138.    Assign(f,paramstr(1)); rewrite(f,1);
  139.    for i := 0 to BASE-1 do write(f,MEM[i]);
  140.    close(f);
  141.  end; 
  142.   // -----------------  
  143.  begin
  144.    GetCh;
  145.  
  146.    repeat
  147.      Token := GetToken;
  148.  
  149.      if (Token = ';') or (Ch = ':') then while (Ch <> #10) do GetCh;  // comment szuro      
  150.      if (Token <> #13) and (Token <> #10) and (token <> ';') then
  151.      begin     
  152.        if Alphabet(Token[1]) then                               // ha kulcsszo
  153.        begin
  154.         if (Token[1] <> 'D') then NonDAT := true;           
  155.         if (NonDAT = true) and (IP < INITIP) then IP := INITIP;
  156.         if (IP <= BASE-1) then MemLoad(Token)  else error(' program is too big');
  157.        end
  158.  
  159.        else     
  160.  
  161.        if Numeric(Token[1]) then                                // ha parameter 
  162.        begin
  163.         if (StrToInt(Token) <= 255)  then MEM[IP]:= StrToInt(Token) else  error(' BIG integer? ');
  164.         inc(IP);
  165.        end        
  166.        else       
  167.        if Labels(Token[1]) then                                 // ha label
  168.        begin
  169.          if length(Token) > 2 then SetLblAddr(StrToInt(Token[2])) 
  170.          else 
  171.          begin 
  172.           MEM[IP] := GetLblAddr(StrToInt(Token[2])); 
  173.           Inc(IP,1); 
  174.          end;
  175.        end       
  176.        else Error(' Unknown token: '+Token);     
  177.      end;   //  if token <> CR
  178.    until EOF(input); 
  179.  
  180.    MemSaveToFile;
  181.  end.
  182.  
Success #stdin #stdout 0s 5548KB
comments (?)
stdin
copy 
; label test
; ----------
DAT  2; 
DAT  5;
DAT 32;
JMP 30;
#1:
ADD  1;
ADD  2;
STA  8;
ret; 
#2:
add 3;
sta 6;
ret;
JMP #2;
JMP #1;
jmp 63;
stdout
copy 
 �����������?
https://ideone.com/agEx2i
language:
Pascal (fpc 3.0.4)
created:
2 years ago
visibility:
public

Share or Embed source code

Discover > Sphere Engine API

The brand new service which powers Ideone!

Discover > IDE Widget

Widget for compiling and running the source code in a web browser!