unit uSXB2XB;

{
This code is part of the TiCodEd Application, designed to develop for the
TI-99/4a Homecomputer in a modern, structured way.

BSD License
Copyright (c) 2026, Stefan Bauch, TiCodEd <at> lizardware <dot> de


Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:

1. Redistributions of source code must retain the above copyright notice, this
   list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright notice,
   this list of conditions and the following disclaimer in the documentation
   and/or other materials provided with the distribution.

THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND
ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR
ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES
(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;
LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND
ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

}

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils;

const reserved : widestring = ' ABS ACCEP1 ACCEP2 ACCEPT ACCSCP ADD AMATCH AND ASC ASTRN1 ASTRN2 ASTRNG AT AT1 AT1A AT2 AT3 AT4 ATPNTR BACK BEEP BEEP1 BKINT BKPDSR BLWPWS CALL CALL1 CALL2 CALLS1 CALLS2 CALLSB CEQ CEQ1 CGE CGT CHAR CHAR2 CHAR2A CHAR2B CHAR2C CHAR2E CHARP1 CHARP2 CHARPA CHARPB CHARSE CHARTB CHPAT2 CHRS CHRSE1 CHRSE3 CHRSED CHRSRT CHSET2 CHSET3 CHSETD' +
  ' CHSETL CHSETZ CLE CLEAR CLEAR1 CLEAR2 CLLADR CLOSE CLOSE2 CLRLN CLRLN1 CLRLN2 CLRSC1 CLRSCN CLT CLT1 CMPAR1 CMPAR2 CMPAR3 CMPAR4 CMPAR5 CMPAR6 CMPAR7 CMPAR8 CMPARE CNE CNS CNS1 CNS1A CNS2 CNS3 CNS7 CNS8 CNS9 CODE CODEND COIALL COINC COLON COLOR COLOR1 COLOR2 COLORA COLORC COLORD COMDLY COMMA COMMA1 COMMA2 COMMA5 COMMA6 COMMA7 COMMA8 CON' +
  ' CONCA1 CONCA2 CONCA3 CONCA4 CONCA5 CONCAT CRAWL CRSPOS CSN CSN1 CSN2 CSN3 CSN4 CSN5 CWRIT1 CWRIT2 CWRIT3 CWRIT8 CWRITE CYAN DATPNT DELAY DELAY1 DELAY2 DELS1A DELSP1 DELSP2 DELSPR DERRLN DFWND1 DFWNDW DIRECT DISP3B DISP3C DISP3E DISP3F DISP4D DISP4E DISPL1 DISPL2 DISPLA DISPLY DISTA1 DISTAN DIVID1 DIVID2 DIVID3 DIVID4 DIVID5 DIVID6 DIVIDE DLINK1 DLINK2' +
  ' DLINK3 DLY12 DLY42 DONE DONEX DR3LB DRCTL2 DRCTL3 DRCTL4 DRCTL5 DSKBUF DSRAD1 DSRADD DSREND DSRLNK DSRWS DWIND DWNROW EA5 EA5B EA5B1 EA5C EA5D EA5WS EAINT EARLRT EARLYC ELSS ELSS1 ENDCC ENDIF EOF EOF1 EOF2 EOF3 EORT ERR ERRLN ERROR ERROR1 ERROR5 ERRRPT FAC FILERR FOR FORX1 FORX2 FORX3 FORX4 FORX5 FREEZE FRSTDT FRSTLN FRSTST GARBA1 GARBA2' +
  ' GARBA3 GARBA4 GARBA5 GARBA6 GARBAG GASIZ1 GASIZ2 GASIZE GCHAR GET0 GET1 GET2 GET3 GET4 GETAR GETAR1 GETAR2 GETARR GETSTK GLINK1 GLNKWS GODSR GODSR1 GODSR2 GODSRE GOSUB GOSUB1 GOSUB2 GOTO GPBUFF GPLCHR GPLLNK GPLWS GR4 GR4LB GR6 GSTAT GTAR1A GTAR1B GTPABA GTSPNO GXMLAD H0360 H10 H2320 H2C00 H4000 H8000 HCHAR HCHAR1 HCHAR2 HCHAR3' +
  ' HCHAR4HCHARX HCHARY HCHGAD HEADER HEXDE2 HEXDE3 HEXDEC HIGH HILIT1 HILITE HX0010 HX0018 HX001E HX0051 HX0300 HX6080 HX8000 HX8080 HXFFF0 IF IF2 IF3 IF4 INP13A INPTN1 INPTN2 INPTN5 INPTNL INPU10 INPU11 INPU12 INPU13 INPU14 INPU4A INPU4B INPU5A INPUT INPUT2 INPUT3 INPUT4 INPUT5 INPUT6 INPUT7 INPUT8 INPUT9 INPUTN INT INVID INVID1 INVTX1 INVTXS IRND JOYST JSTADR KEY' +
  ' KEY1 KEY2 KEY3 KEYBP KSC1 KSCAN LASTDT LASTLN LCDEFS LDCLR LDCLR1 LDGADD LDRGST LEN LEN1 LET LET1 LET2 LIMZRO LINPTN LINPUT LOAD LOAD1 LOADLP LOADSP LOCATE LOW MAGNIF MATCH MAX MAX0 MAX2 MAX3 MIN MINUS MLTPLY MONIT3 MONIT4 MONIT5 MONITG MONITR MONWS MOTION NAMLEN NBR NEXT NEXT1 NEXT10 NEXT11 NEXT12 NEXT13 NEXT2 NEXTSP NOCOI1 NOCOIN' +
  ' NOPLAY NOT NOWNDW NULLST NXTPHR NXTSTR OLDCHR OLDINT ONE ONGOS1 ONGOSU ONGOTO OPEN OPEN1 OPENBK OPTBAS OR OUT PAB PABADR PATTER PEEK PEEK1 PI PLAY PLYR1 PLYR1A PLYR1B PLYR2 POS POS0 POS1 POS2 POS3 POSITI PRIN7B PRIN9A PRINB3 PRINB4 PRINBK PRINT PRINT2 PRINT3 PRINT4 PRINT5 PRINT6 PRINT7 PRINT8 PRINT9 PRINTN PRN5A PRNTN1 PRNTN8 PRNTN9 PUTSTK QMARK RAND1' +
  ' RAND2 RAND3 RAND4 RAND5 RANDBK RDSCR1 RDSCR2 READ READ2 READBK READER READSP RESTO1 RESTO2 RESTOR RETUR1 RETURN RGSTRS RND RPTER1 RPTER2 RPTERR RPTS RPTS1 RPTS2 RPTS5 RTN RTNAD RUN RUN1 RUN10 RUN2Q RUNEA RUNEA5 RUNV SAY SAY1 SAY1A SAY1T SAY2 SAY3T SAY4T SAY5T SAY6T SBTRCT SC1CLR SC1DC SC2CLR SC2DC SCPXD2 SCPXDN SCPXL2 SCPXLF SCPXR2 SCPXRT SCPXS2' +
  ' SCPXS4 SCPXS8 SCPXSB SCPXU2 SCPXU3 SCPXU4 SCPXU5 SCPXUP SCREE1 SCREE2 SCREEN SCRENE SCRLA2 SCRLAT SCRLBK SCRLDN SCRLF1 SCRLF2 SCRLF4 SCRLFS SCRLLF SCRLP SCRLRT SCRLS1 SCRLUP SCRN1 SCRN1A SCRN1B SCRN2 SCRN2A SCRN2Z SCRNPT SCRNRT SCROB SCROB4 SCROB5 SCROLL SCRUP1 SCRUP2 SCRUP3 SCRUP4 SCRUP5 SEARC1 SEARCH SEGS SEGS1 SEGS2 SEGS3 SEMI SETADR SETEQ SETSI1' +
  ' SETSI2 SETSI4 SETSI6 SETSI7 SETSI8 SETSI9 SETSIZ SGN SGN1 SGN2 SIZE SIZLTH SLIST1 SLIST2 SLIST3 SLIST4 SLIST5 SLOFF SLOFF1 SLOFF2 SLP2 SLP2A SNDOFF SOUND SOUND1 SOUND2 SOUND3 SOUND4 SOUND5 SOUND6 SOUND7 SOUND8 SPACE1 SPACES SPCHRD SPCHWT SPCOL SPDIS1 SPDIS2 SPDIST SPDOVR SPEAK SPEAK1 SPGET SPGET1 SPGET2 SPGET3 SPGET5 SPGFLG SPINI1 SPINI2 SPINI3 SPINIT SPLOC SPLOC1' +
  ' SPPAT SPPAT1 SPPAT2 SPRIT1 SPRIT2 SPRIT3 SPRITE SPRMO SPRMO1 SQR SQR1 SQR2 SQR5 SQRERR STAR0 STAR1 STAR10 STAR2 STAR3 STAR4 STAR5 STAR6 STAR7 STAR8 STAR9 STKPNT STOP STRN STRPAD STRS STRST1 STRST2 STRST3 STRST4 STRSTR SUBEN1 SUBEN2 SUBEN3 SUBEND SUBEXI SWPPA1 SWPPAD SWPSC1 SWPSC3 SWPSC4 SWPSCR SYNC SYNC1 SYNTH TAB TAB1 TAB2 THAW TYPE VAL VALID VCHAR' +
  ' VCHAR1 VLDRO1 VLDRO2 VLDRO3 VLDRO4 VLDROU VLDSTR VMBR VMBR1 VMBR1A VMBR1B VMBR2 VMBR5 VMBW VMBW1 VMBW1A VMBW1B VMBW2 VMBW5 VMWLP1 VMWLP2 VRD VREAD VREAD1 VSB4 VSBR VSBR1 VSBR2 VSBW VSBW2 VSBW96 VSCR1A VSCR1Z VSCR2A VSCR2X VSCR3A VSCRL1 VSCRL2 VSCRLB VSCRM1 VSCRM2 VSCRM4 VSCRMU VSCROL VSFLAG VWA VWRITE VWTR VWTR1 WAIT WAIT1' +
  ' WAIT2 WFRSTR WHIGHT WINDO1 WINDO2 WINDO3 WINDOW WKSP WKSP1 WLASTR WLCOL WRCOL WWIDTH XB255A XBEA5 XBRTN XBRTN1 XBRTN2 XBRTN3 XMLRTN XOR XPONE1 XPONE2 XPONE6 XPONE8 XPONE9 XPONEN XPONEX XPONEY XPONEZ XTAB27 ZERO' ;

   StdCalls = ' CHAR HCHAR PATTERN CHARPAT INIT PEEK CHARSET JOYST POSITION CLEAR KEY SAY COINC LINK SCREEN COLOR LOAD SOUND DELSPRITE LOCATE SPGET DISTANCE MAGNIFY SPRITE ERR MOTION VCHAR GCHAR HCHAR VERSION ';


type TLogProc = Procedure(l:Integer; txt:ShortString);

     TLine = Record
       nr   : integer;
       lbl  : String[32];
       stmt : String;
       src  : Integer;
     end;

     lkind = (lwhile,lrepeat);
     TLoop = Record
       kind : lkind;
       num  : Integer;
       cond : String[64];
     end;

     TPkgLine = Record
       cll : String[32];
       par : Boolean;
       lnk : String[32];
     end;

     TAsmPar = Record
       name : string[6];
       strg : boolean;
       ret  : boolean;
       reg  : byte;
     end;

Var debug : Boolean = true;
    prg   : Array[1..2048] of TLine;
    maxl  : Integer;

Function SXBtoXB(sxbin,xbout: String;linestart,lineinc,LineGOSUB,LineSUB:Integer;WriteLogProc:TLogProc;PkgFile,LibFile,Options:String):Integer;
function PosUnquoted(sub,s:string):Integer;
function FmtInt(i,l:Integer):String;
procedure ReplaceIdent(f, t: String; var s: String);


implementation

uses ctype,FileUtil,uTICharset,strutils,math,types;


Type  TLbl = Record
               txt : String[32];
               line: Integer;
             end;

VAR  WriteLog : TLogProc;
     sxb : TStringList;
     sxbline : Integer;
     xb : Textfile;
     lstack : Array[0..31] of TLoop;
     lstptr : Integer = 0;
     pkg : Array[0..255] of TPkgLine;
     PkgActive,UsrLibActive,StdLibActive : Boolean;
     Subr : array[0..255] of String[16];
     Subc : Integer;
     IntSub : WideString;
     BaseDir : String;
     AsmPar : Array[1..10] of TAsmPar;
     AsmParN: Integer;
     asmfile: shortstring;
     AsmStrIdx : Integer;

     sln     : integer;
     oos     : TStringList;
     asmb    : TStringList;
     asmlst  : TStringList;
     consts  : TStringList;
     beginlvl: Integer;
     blocknr : Integer;
     EndElse : Integer;

     CaseCond  : String;
     CaseLine  : String;
     CasePrefix: String;
     CaseCount : Integer;
     CaseVar   : String;
     CaseOpen  : Boolean;
     lclink    : Boolean;
     AsmActive : Boolean;



Procedure dbg(l:Integer; txt:ShortString);
begin
  writelog(l,txt);
end;


function eofsxb:boolean;
begin
  Result := sxbline>=sxb.Count;
end;

function isstop(c:char):boolean;
begin
  if c in [' ',':','(',','] then isstop := true
                            else isstop := false;
end;

procedure lpush(lk : lkind; nm : Integer; c:String);
begin
  lstack[lstptr].kind := lk;
  lstack[lstptr].num  := nm;
  lstack[lstptr].cond := c;
  if (lk=lwhile) and (length(c)>64) then dbg(1,'ERROR: WHILE condition too long (max 64 char).');
  inc(lstptr);
end;

procedure lpop(VAR lk : lkind; VAR nm : Integer; VAR c:String);
begin
  dec(lstptr);
  if lstptr>=0 then begin
    lk := lstack[lstptr].kind;
    nm := lstack[lstptr].num;
    c  := lstack[lstptr].cond;
  end else dbg(1,'ERROR: REPEAT/WHILE nesting error.');
end;


function cmdend(s:string):Integer;
var inquote:boolean;
    i:Integer;
begin
  inquote := false;
  i := 1;
  s:=s+' ';
  if uppercase(leftstr(s,5))='DATA ' then cmdend:=length(s)-1 else begin
     for i:=1 to length(s) do begin
       if s[i]='"' then inquote := not inquote;
       if inquote then s[i]:='*'
     end;
     if pos('::',s)= 0 then cmdend:=length(s)-1
                       else cmdend:=pos('::',s)-1
  end;
end;


function PosUnquoted(sub,s:string):Integer;
var inquote:boolean;
    i:Integer;
begin
  inquote := false;
  sub := uppercase(sub);
  s:=uppercase(s)+' ';
  if leftstr(s,5)='DATA ' then PosUnquoted:=0 else begin
       for i:=1 to length(s) do begin
         if s[i]='"' then inquote := not inquote;
         if inquote then s[i]:=#255;
       end;

   if leftstr(s,1)='*' then s:='';
   i := pos('//',s);
   if (i>0) and (sub<>'//') then s:=copy(s,1,i-1);
   i := pos('!',s);
   if (i>0) and (sub<>'!')  then s:=copy(s,1,i-1);
   PosUnquoted := pos(sub,s);
  end;
end;


function FmtInt(i,l:Integer):String;
begin
  Result := copy('0000000000',1,l-length(IntToStr(i)))+IntToStr(i);
end;

Procedure SXBInclude(s:string);
var fn,fqn : String;
    incl : TStringList;
    i : integer;
begin
  fn  := trim(copy(s,9,128));
  fqn := fn;
  // first check project directory
  if FileExists(BaseDir+DirectorySeparator+fn) then fqn := BaseDir+DirectorySeparator+fn
  else if FileExists(ExtractFileDir(ParamStr(0))+DirectorySeparator+'inc'+DirectorySeparator+fn)
     then fqn := ExtractFileDir(ParamStr(0))+DirectorySeparator+'inc'+DirectorySeparator+fn;
  dbg(5,'#INLCUDE: '+fqn);

  if FileExists(fqn) then begin
    incl := TStringList.create;
    incl.LoadFromFile(fqn);
    dbg(3,'#INCLUDE read, '+IntToStr(incl.Count)+' lines read.');
    for i:=0 to incl.Count-1 do begin
       sxb.Insert(sxbline+i,incl.Strings[i]);
       dbg(5,'    +('+inttostr(i)+'):'+incl.Strings[i]);
    end;
    incl.Destroy;
  end else dbg(1,'Error: #INCLUDE '+fqn+' not found!');
end;

procedure ReplaceIdent( f, t: String; var s: String);
var i :integer;
    r,z : shortstring;
begin
  r := '';
  z := s;
  i := PosUnquoted(f,z);
  while i>0 do begin
     if ((i=1) or not (z[i-1] in ['A'..'Z','a'..'z'])) and
        ((i+length(f)-1=length(z)) or not (z[i+length(f)] in ['A'..'Z','a'..'z','0'..'9']))
        then begin // identifier found
           r := r + leftstr(z,i-1)+t;
           z := RightStr(z,length(z)-i-length(f)+1);
        end else begin
           r := r + leftstr(z,i+length(f)-1);
           z := RightStr(z,length(z)-i-length(f)+1);
        end;
     i := PosUnquoted(f,z);
  end;
  if r<>'' then s:=r+z;
end;

function asmline(lbl,code,comment: Shortstring):shortstring;
var s: String;
begin
  s:=trim(lbl);
  s:=s+copy('          ',1,7-length(s))+code;
  s:=s+copy('                      ',1,20-length(s))+'  '+comment;
  asmline := s;
end;

function ValList(v,l,op:String):String;
var b : Integer;
    s,con : string;                   // 1,2,3   -> (v=1 or v=2 or v=3)
begin
  b := PosUnquoted(',',l);
  if op='=' then con := ' OR '
            else con := ' AND ' ;
  s := '';
  if b=0 then s := trim(v)+'='+trim(l)
  else begin
    while b>0 do begin
      s := s + v + op + trim(copy(l,1,b-1)) + con;
      l := trim(copy(l,b+1,255));
      b := PosUnquoted(',',l);
    end;
    s := s + v + op + l;
  end;
  Result := s;
end;


procedure CheckXBLine(stmt:String);
VAR s,t : String;
    i   : Integer;
    inquote,err : Boolean;

begin
  inquote := false;
  err := false;
  i := 1;
  t := '';
  s:=uppercase(stmt);
  if leftstr(s,5)<>'DATA ' then begin
       i:=PosUnquoted('//',s);
       if i>0 then s:=copy(s,1,i-1);
       for i:=1 to length(s) do begin
         if s[i]='"' then inquote := not inquote;
         if not inquote and (s[i]<>' ') then t:=t+s[i];
       end;
       if (PosUnquoted('::::',t)>0) and (PosUnquoted('print',t)=0) then Dbg(1,'Warning: Double-Double-Colon: '+stmt);

       if (PosUnquoted('::REM',t)>0) and (PosUnquoted('print',t)=0) then Dbg(1,'Warning: <:: REM> will not compile: '+stmt);

       if (rightstr(t,1)=';') and (PosUnquoted('print',t)=0) and (PosUnquoted('display',t)=0) then
         Dbg(1,'Warning: Trailing semicolon found: '+stmt);

       if (rightstr(t,2)='::') and (PosUnquoted('print',t)=0) and (PosUnquoted('display',t)=0) then
         Dbg(1,'Warning: Trailing double-colon found: '+stmt);

       s:=stmt;
       while PosUnquoted(' CHAR(',s)>0 do begin
         i:=PosUnquoted(' CHAR(',s)+6;
         inquote:=false;
         while (i<=length(s)) and (s[i]<>')') do begin
           if s[i]='"' then inquote:=not inquote;
           if inquote and (s[i] in ['a'..'z']) then err := true;
           inc(i);
         end;
         s:=copy(s,i,255);
       end;
       if err then Dbg(1,'Warning: Lower-Case used in CALL CHAR: '+stmt);
  end;

end;

Procedure CheckCall(s:String);
var i,j,k : Integer;
    sub : string;
begin
  s:=trim(UpperCase(s));
  if (leftstr(s,4)='SUB ') or (leftstr(s,4)='ASM ') then begin // delete locally defined subroutines
    j:=5;
    while (j<=length(s)) and (isalnum(s[j]) or (s[j]='_')) do inc(j);
    sub := copy(s,5,j-5);
    k:=0;
    while (subr[k]<>sub) and (k<=subc) do inc(k);
    if subr[k]=sub then begin
       subr[k]:='!'+subr[k]; // keep voided for Isabella-Checks
       dbg(4,'Found local User Subroutine '+sub);
    end;
  end;
  i:=PosUnquoted('CALL ',s);
  while i>0 do begin
    i:=i+5; j:=1;
    while (i+j<=length(s)) and (isalnum(s[i+j]) or (s[i+j]='_')) do inc(j);
    sub := trim(copy(s,i,j));
    dbg(5,'Found CALL '+ sub);
    if (Pos(' '+sub+' ',stdcalls)=0)
       and  (Pos(' '+sub+' ',IntSub)=0) then begin
       // add user-defined subroutine to list
       k:=0;
       while (subr[k]<>sub) and (subr[k]<>'!'+sub) and (k<=subc) do inc(k);
       if (subr[k]<>sub) and (subr[k]<>'!'+sub)  then begin
          subr[subc]:=sub;
          inc(subc);
          dbg(4,'Found User Subroutine '+sub);
       end;
    end;
    s := copy(s,i+j,255);
    i:=PosUnquoted('CALL ',s);
  end;
end;


procedure PkgReplace(VAR s:String);
var i,j,k,lvl : integer;
    sb,sa,par,sl : String;
begin
  i:=0;
  while pkg[i].cll <> 'EOL' do begin
    j := PosUnquoted(pkg[i].cll,s);
    if j>0 then begin // isolate before, after and parameter
       dbg(5,'Pkg: '+s);
       sb := copy(s,1,j-1); // string before
       sl := pkg[i].lnk;
       if lclink then begin // if Lowercase-LINK is checked convert name
         k := pos('"',sl) + 1;
         repeat
           sl[k] := lowercase(sl[k]);
           inc(k);
         until (k>length(sl)) or (sl[k]='"');
       end;
       if pkg[i].par then begin
         j:=j+length(pkg[i].cll);
         k := j;
         lvl := 1;
         repeat
           inc(k);
           if s[k]='(' then inc(lvl);
           if s[k]=')' then dec(lvl);
         until (lvl=0) or (k=length(s));
         par:= copy(s,j,k-j+1);
         sa := copy(s,k+1,255);
         s := sb + sl + par + sa;
       end else begin // no parameter .. easy case
         sa := copy(s,j+length(pkg[i].cll),255);
         par:= '';
         s := sb + sl + sa;
       end;
       dbg(5,'  -> '+s);
       i:=0; // and start again to look for possible substitutions
    end;
    inc(i);
  end;
end;

Procedure LoadLibraries(PkgFile,LibFile,Options:String);
var lf : Textfile;
    s : String;
    i,p : Integer;
    pkgs : TStringDynArray;

begin
  for i:=0 to 255 do Subr[i]:='';
  subc := 0;
  IntSub := '';
  pkgactive := false;

  if PkgFile <> '' then begin
    dbg(3,'Read Package file '+PkgFile);
    pkgs := SplitString(PkgFile,';');
    i:=0;
    for p:=0 to length(pkgs)-2 do begin
      assign(lf,Pkgs[p]);
      dbg(4,'Package #'+inttostr(p)+': '+Pkgs[p]);
      reset(lf);
      pkgactive := true;
      while not EOF(lf) do begin
        readln(lf,s);
        s:=Uppercase(trim(s));
        if (leftstr(s,5)='CALL ') and (PosUnquoted('->',s)>0) then begin
          pkg[i].cll:=trim(leftstr(s,pos(' -> ',s)-1));
          pkg[i].lnk:=trim(copy(s,pos(' -> ',s)+4,255));
          if Pos('(P)',pkg[i].cll)>0 then begin
            pkg[i].par:=true;
            pkg[i].cll:=leftstr(pkg[i].cll,length(pkg[i].cll)-2);
            pkg[i].lnk:=leftstr(pkg[i].lnk,length(pkg[i].lnk)-2);
          end else pkg[i].par:=false;
          dbg(5,s+'   >>>   '+pkg[i].cll+' => ' + pkg[i].lnk);
          inc(i);
        end;
        if leftstr(s,10)='INTERNAL: ' then begin
          IntSub := IntSub + ' ' + trim(copy(s,10,250)) + ' ';
          dbg(5,'Internal: '+trim(copy(s,10,250)))
        end;
      end;
      close(lf);
    end;
    pkg[i].cll:='EOL';
    if IntSub <> '' then dbg(3,'Additional internal Subroutines: '+Intsub);
  end; // Read Package File

  if (Libfile <> '')
    then UsrLibActive := true
    else UsrLibActive := false;

  if (Pos('-STDLIB ',Options)>0)
    then StdLibActive := true
    else StdLibActive := false;
end;



Procedure PrepareSXBline(s:String; VAR l : Integer);
VAR i,j,k : Integer;
    t,u,v : String;
    quote : Boolean;
begin

  // init line-record
  prg[l].nr   := 0;
  prg[l].lbl  := '';
  prg[l].stmt := '';
  prg[l].src  := sln;

  // check for illegal characters
  for i:=1 to length(s) do begin
    if (byte(s[i]) and $80)>0 then dbg(0,'ERROR: Unrecognized character in Pos.'+IntToStr(i)+' <'+s+'>');
    if (byte(s[i]) = $09) then s[i] := ' ';
  end;

  // process embedded assembly: special comment and skip
  if (PosUnquoted('ASM ',s)>0) and (leftstr(s,1)<>'*')   then begin
    AsmActive:=true;
    CheckCall(s); // register as SUB/ASM routine for CALL
  end;
  if AsmActive then begin
    if (PosUnquoted('ASMEND ',s)>0) and (leftstr(s,1)<>'*') then AsmActive:=false;
    prg[l].stmt := '//ASM: '+s;
    dbg(5,prg[l].stmt);
    inc(l);
    exit;
  end;

  s := trim(s) + ' '; // blank to avoid checking length in s[i+1]

  // replace constants with actual values
  for i:=0 to consts.Count-1 do ReplaceIdent(consts.Names[i],consts.Values[consts.Names[i]],s);

  // Replace hex $xxxx and $xx values with decimals
  i:=2;
  quote:=false;
  while i<length(s) do begin
    if s[i]='"' then quote:=not quote;
    if s[i]='$' then
      if (not quote) and (not (char(s[i-1]) in ['0'..'9','A'..'Z','a'..'z'])) then begin
        j:=1;
        while (j<5) and (i+j<=length(s)) and (s[i+j] in ['0'..'9','A'..'F','a'..'f']) do inc(j);
        if (j=3) or (j=5) then begin
          u:=copy(s,i+1,j-1);
          k:=hex2dec(u);
          if k>32767 then k:=k-65536;
          dbg(5,'Hex: $'+u+' replaced with '+inttostr(k));
          u:=copy(s,i+j,255);
          s:=copy(s,1,i-1)+inttostr(k);
          i:=length(s);
          s:=s+u;
        end;
      end;
    inc(i);
  end;


  if CaseOpen and (beginLvl=0) then begin
    i:=PosUnquoted(' endcase ',' '+s+' ');
    if i>0 then begin
      dbg(4,'ENDCASE found.');
      CaseOpen := false;
      CaseCond := StringReplace(CaseCond,'-1*(','-(',[rfIgnoreCase]);
      s:= CasePrefix+'ON '+CaseCond+' GOSUB '+CaseLine;
    end else begin
      t := trim(copy(s,1,pos(':',s)-1));
      u := 'BLOCK'+format('%.3d',[BlockNr]);
      dbg(4,'Case Value: '+t);
      if LeftStr(trim(uppercase(s)),4)='ELSE' then begin // CASE-ELSE branch
         s := StringReplace(s,'else',':',[rfIgnoreCase]);
         CaseCond := '1' + CaseCond;
         CaseLine := u + ', ' + CaseLine ;
      end else begin
        inc(CaseCount);
        CaseCond := CaseCond + '-'+IntToStr(CaseCount)+'*('+ValList(CaseVar,t,'=')+')';
        if CaseLine = ''
           then CaseLine := u
           else CaseLine := CaseLine + ', ' + u;
      end;
      v := trim(copy(s,pos(':',s)+1,255));
      if UpperCase(v)='BEGIN' then begin
          dbg(4,'Case BEGIN found.');
          inc(beginlvl);
          oos.add(u+':');
        end else begin
           t := u + ': ' + v ;
           if beginlvl=0 then
             if trim(uppercase(v))<>'RETURN' then t:= t + ':: RETURN';
           oos.add(t);
           dbg(4,'Case Command: '+t);
       end;
       s := '// ' + s;
       inc(blocknr);
    end;
  end;

  i:=PosUnquoted(' case ',' '+s+' ');
  if (i>0) and (beginlvl=0) then begin
    j := 0;
    inc(i,5);
    while not isstop(s[i+j]) and (i+j<length(s)) do inc(j);
    CaseVar  := copy(s,i,j);
    CaseOpen := true;
    CaseLine := '';
    CaseCond := '';
    CaseCount:= 0;
    CasePrefix:=copy(s,1,i-6);
    dbg(4,'CASE found. Variable: '+CaseVar);
    s := '// ' + s;
  end;


  i:=PosUnquoted(' end ',' '+s+' ');
  if beginlvl>0 then
    if (i>0) and (copy(s,1,2) <> '//') and (beginlvl=1) then
    begin
      dbg(4,'END found: '+s);
      t:=trim(copy(s,1,i-1));
      if t<>'' then begin
        oos.add(t);
        dbg(4,' > '+t);
      end;
      oos.add('RETURN');
      dbg(4,' > RETURN');
      s := copy(s,i+4,255);
      dbg(4,s);
      beginlvl := 0;
      if copy(uppercase(trim(s)),1,4)='ELSE' then
        if copy(uppercase(trim(s)),6,5)='BEGIN' then begin
          dbg(4,'ELSE BEGIN found ... updating line '+IntToStr(EndElse));
          beginlvl := 1;
          i:=PosUnquoted(' begin ',' '+s+' ');
          t := copy(s,1,i-1) + 'GOSUB BLOCK'+format('%.3d',[BlockNr]);
          oos.Add('BLOCK'+format('%.3d',[BlockNr])+': '+ copy(s,i+6,255));
          dbg(4,'-> '+t);
          dbg(4,'-> '+'BLOCK'+format('%.3d',[BlockNr])+': '+ copy(s,i+6,255));
          prg[EndElse].stmt := prg[EndElse].stmt +' ' + t;
          s:='';
          inc(BlockNr);
        end else begin
           dbg(4,'ELSE found ... updating line '+IntToStr(EndElse));
           prg[EndElse].stmt := prg[EndElse].stmt +' ' + s;
           s:='';
           dbg(4,'--> '+prg[EndElse].stmt);
        end;
    end else begin
       if PosUnquoted(' begin ',' '+s+' ')>0 then inc(beginlvl);
       if PosUnquoted(' end '  ,' '+s+' ')>0 then dec(beginlvl);
       oos.Add(s);
       dbg(4,' > // '+s);
       s := '// '+s;
    end;

    i:=PosUnquoted(' begin ',' '+s+' ');
    if (i>0) and (copy(s,1,2) <> '//') then begin
      if PosUnquoted(' end ',s)>i then begin // same line begin-end: remove
         dbg(4,'Remove same-line BEGIN-END sequence: ');
         dbg(4,'   '+s);
         s := StringReplace(s,' begin ',' ',[rfIgnoreCase]);
         s := StringReplace(s,' end ',' ',[rfIgnoreCase]);
         dbg(4,'-> '+s);
      end else begin // Out-of-Sequence section starts
        beginlvl := 1;
        dbg(4,'Substitute BEGIN with GOSUB.');
        dbg(4,'  '+s);
        t := copy(s,1,i-1) + 'GOSUB BLOCK'+format('%.3d',[BlockNr]);
        oos.Add('BLOCK'+format('%.3d',[BlockNr])+': '+ copy(s,i+6,255));
        dbg(4,'-> '+t);
        dbg(4,'-> '+'BLOCK'+format('%.3d',[BlockNr])+': '+ copy(s,i+7,255));
        s:=t;
        endelse := l; // remember the line if there is an ELSE after the END
        inc(BlockNr);
      end;
    end;

    i := PosUnquoted(' IN[',s);                // any use of IN?
    while i>0 do begin
      i := PosUnquoted(' NOT IN[',s);          // IF X NOT IN[1,2,3,4] THEN 350
      if i>0 then begin
        j := i;
        while (i>1) and (s[i]=' ') do dec(i);
        while (i>1) and (isalnum(s[i]) or (s[i]='$')) do dec(i);
        inc(i);
        v := copy(s,i,j-i);
        k := PosUnquoted(']',s);
        s := copy(s,1,i-1) + ValList(v,copy(s,j+8,k-j-8),'<>')+copy(s,k+1,255);
      end else begin
        i := PosUnquoted(' IN[',s);            // IF X IN[1,2,3,4] THEN 350
        if i>0 then begin
          j := i;
          while (i>1) and (s[i]=' ') do dec(i);
          while (i>1) and (isalnum(s[i]) or (s[i]='$')) do dec(i);
          inc(i);
          v := copy(s,i,j-i);
          k := PosUnquoted(']',s);
          s := copy(s,1,i-1) + ValList(v,copy(s,j+4,k-j-4),'=')+copy(s,k+1,255);
        end;
      end;
      i := PosUnquoted(' IN[',s);              // another IN left?
    end;

  // handle constants
  i := PosUnquoted('CONST ',s);
  if i>0 then begin
    t := trim(copy(s,i+6,255));
    if pos('=',t)=0 then dbg(1,'No equal-sign in CONST declaration: '+t);
    repeat
      t := StringReplace(t,' =','=',[],k);
    until k=0;
    repeat
      t := StringReplace(t,'= ','=',[],k);
    until k=0;
    dbg(4,'CONST: '+t);
    consts.Add(t);
    s := '// ' + s;
  end;

  // exchange logical character definitions #CHAR1083:2 with hex string from Char-Tab
  i := PosUnquoted('#CHAR',s);
  while i>0 do begin
    if copy(s,i+9,1)=':' then t:=copy(s,i,11)
                         else t:=copy(s,i,9);
    u := '"'+GetChar(t)+'"';
    dbg(4,'CHAR: Replace '+t+' with '+u+'.');
    s:=StringReplace(s,t,u,[rfreplaceall,rfignorecase]);
    i := PosUnquoted('#CHAR',s);
  end;

  i:=1;
  // Line-Number ?
  while (i<length(s)) and isdigit(s[i]) do inc(i);
  if (i>1) and (s[i]=#32) then begin
     t := leftstr(s,i-1);
     dbg(4,'Line-nr: '+t);
     prg[l].nr   := Strtoint(t);
     prg[l].stmt := trim(copy(s,i+1,255)) + ' ';
  end else begin // Label ?
    i:=1;
    while (i<length(s)) and (isalnum(s[i]) or (s[i]='_')) do inc(i);
    if (i>1) and (s[i]=':') and (copy(s,i+1,1)<>':') then begin
       t := uppercase(leftstr(s,i-1));
       dbg(4,'Label: '+t);
       prg[l].lbl  := t;
       prg[l].stmt := trim(copy(s,i+1,255)) + ' ';
    end else prg[l].stmt:=s;
  end;
  dbg(4,'Statement: '+prg[l].stmt);
  if PkgActive then PkgReplace(prg[l].stmt);
  if UsrLibActive or StdLibActive then Checkcall(prg[l].stmt);
  if (Uppercase(trim(prg[l].stmt))='WHILE') then begin
     // Create additional line for WHILE-Label
     dbg(5,'Create addtional Line for WHILE-Label');
     inc(l);
     prg[l].nr   := 0;
     prg[l].lbl  := '<WHILE>';
     prg[l].stmt := '';
  end;
  if (copy(prg[l].stmt,1,1)='#') then if debug
     then prg[l].stmt := trim(copy(prg[l].stmt,2,254))
     else prg[l].stmt := '// ' + prg[l].stmt;

  // some additional checks
  CheckXBLine(prg[l].stmt);

  inc(l);
end;

Procedure ReadLibFile(lfn:String;VAR l:Integer);
VAR     lf : textfile;
        s,sub : String;
        cp : Boolean;
        i,j,k : Integer;

begin
  if FileExists(lfn) then begin
    assign(lf,lfn);
    reset(lf);
    while not eof(lf) do begin
       readln(lf,s);
       i := PosUnquoted('SUB ',s)+PosUnquoted('ASM ',s);
       if i>0 then begin
         j:=1;
         while (i+4+j<=length(s)) and (isalnum(s[i+4+j])) do inc(j);
         sub := UpperCase(copy(s,i+4,j));
         // is this Subroutine needed?
         cp:=false;
         for k:=0 to subc do if subr[k] = sub then begin
            cp := true;
            subr[k] := '<done>';
         end;
         if cp then begin
            dbg(4,'Found Sub-Routine '+sub);
            dbg(5,'   '+s);
            PrepareSXBline(s,l);
            while not eof(lf) and (PosUnquoted('SUBEND',s)=0) and (PosUnquoted('ASMEND',s)=0) do begin
               readln(lf,s);
               dbg(5,'   '+s);
               PrepareSXBline(s,l);
            end;
         end;
       end;
    end;
    close(lf);
  end else dbg(1,'WARNING: Library '+lfn+' not found. Check installation.')
end;


procedure AsmBlock(var l: LongInt);
var s,t,pname : shortstring;
    i,j,k : integer;
begin
  s := copy(prg[l].stmt,8,255);
  if LeftStr(uppercase(trim(s)),4)='ASM ' then begin // create entry and parameters
    asmb.add(' ');
    i:=1;
    s := copy(TrimLeft(s),5,255);  // delete 'ASM '
    while (i<=length(s)) and (s[i]<>' ') and (s[i]<>'(') do inc(i);
    pname := uppercase(copy(s,1,i-1));
    pname := copy(pname,1,6);
    dbg(5,'ASM Procedure: '+ pname);
    asmlst.add(pname);
    j := 1;
    if (s[i]='(') then while (i<length(s)) and (s[i]<>')') do begin
      inc(i);
      k:=i;
      while (i<length(s)) and (s[i]<>')') and (s[i]<>',') do inc(i);
      AsmPar[j].name:=uppercase(copy(s,k,i-k));
      AsmPar[j].strg:=(pos('$',AsmPar[j].name)>0);
      dbg(5,'   Par.'+inttostr(j)+': '+AsmPar[j].name);
      inc(j);
    end;
    AsmParN := j-1;

    if AsmParN>0 then asmb.add(asmline(pname,'BL @GET'+inttostr(min(AsmParN,4)),'Get parameter: '+uppercase(s)))
                 else asmb.add(asmline(pname,'','* No parameter.'));

    AsmStrIdx := asmb.Count;
    for i:=1 to min(AsmParN,4) do begin
       AsmPar[i].reg:=6-AsmParN+i;
       AsmPar[i].ret:=false;
    end;

  end else if LeftStr(uppercase(trim(s)),6)='ASMEND' then begin // Return variable
     s := uppercase(trim(copy(s,8,250)));

     if pos('$(',s)>0
        then   t := copy(s,1,pos('$',s))
        else   t := s;
     dbg(5,'   Return variable: '+t);
     i:=1;
     while (i<10) and (AsmPar[i].name<>t) do inc(i);
     dbg(5,'   Register: R'+inttostr(AsmPar[i].reg));
     if pos('$',t)>0 then begin
       AsmPar[i].ret := true;
       pname:=trim(copy(s,pos('(',s)+1,20));
       pname:=leftstr(pname,length(pname)-1);
       dbg(5,'   Buffer: '+pname);
       asmb.add('');
       asmb.add(asmline('','LI R0,'+pname,'Prepare to return string buffer'));
       asmb.add(asmline('','MOV R'+inttostr(AsmPar[i].reg)+',R1',''));
       asmb.add(asmline('','BLWP @STRSTR',''));

       for i:=1 to min(AsmParN,4) do begin
          if (AsmPar[i].strg) and not (AsmPar[i].ret) then
             asmb.Insert(AsmStrIdx,asmline('','MOV *R'+inttostr(6-AsmParN+i)+',R'+inttostr(6-AsmParN+i),'Load actual string address.'));
       end;
     end;
     asmb.add('');
     asmb.add(asmline('','B @RTN','Back to compiler.'));
  end else begin
     if uppercase(copy(s,8,5))='BREAK' then s:=copy(s,1,7)+'DATA >0113'+copy(s,13,255);
     asmb.Add(s);
  end;
end;

Procedure buildlist(lstart,linc,LineGOSUB,LineSUB: Integer; libfile, PkgFile:string);
var s,t: string;
    i,j,l : Integer;
    nm, loopcount,maxlbl,llast : Integer;
    lk : lkind;
    sorted,isnum: boolean;
    labtab: Array[0..500] of Tlbl;
    templab : Tlbl;
    Pkgs : TStringDynArray;


begin
  l := 1;
  loopcount := 0;
  CaseOpen  := false;
  AsmActive := false;
  beginlvl  := 0;
  BlockNr   := 0;
  sln       := 0;
  llast     := -123;
  oos.Clear;
  asmb.Clear;
  consts.Clear;

  oos.Add(inttostr(LineGOSUB));

  if eofsxb then dbg(0,'Error reading SXB input file') else
  while not eofsxb do begin
    s := sxb.Strings[sxbline];
    inc(sxbline);
    inc(sln);
    if AsmActive then s := ReplaceStr(s,#09,'       ')
                 else s := trim(s); // do not trim ASM code
    t := '';
    // check for TiDBiT-like multiline statements
//  while not EOFsxb and ((s='') or (rightstr(s,2)='::') or (rightstr(s,2)='..')
    while not EOFsxb and not AsmActive and ((s='') or (rightstr(s,2)='::') or (rightstr(s,2)='..')
          or (UpperCase(rightstr(s,4))='THEN') or (UpperCase(rightstr(s,4))='ELSE'))
          and (PosUnquoted('//',s)=0) and (PosUnquoted('!',s)=0)  and (PosUnquoted('REM ',s)=0)
       do begin
       if (rightstr(s,2)='..') then s:=copy(s,1,length(s)-2);
       t := sxb.Strings[sxbline];
       inc(sxbline);
       inc(sln);
       s := s + ' ' + trim(t);
    end;

    // s := s + ' ! L'+inttostr(sln);

    // Process #INCLUDE
    if leftstr(UpperCase(s),8)='#INCLUDE' then begin
      SXBInclude(s);
      s := '// '+s;
    end;



    if (oos.count>0) AND ((Uppercase(LeftStr(trim(s),4))='SUB ') or EOFsxb) then begin
      dbg(3,'Inserting Out-of-Sequence statements (generated GOSUB lines)');
      if EOFsxb then begin
         dbg(4,'No SUB-Routines. Finish program first.');
         if s<>'' then PrepareSXBline(s,l);
         s:='';
      end;

      // insert END before the GOSUB-Block to avoid accidental execution at programs end.
      j:=1;
      while (trim(prg[l-j].stmt)='') do inc(j); // skip empty lines
      if trim(Uppercase(prg[l-j].stmt)) <> 'END' THEN PrepareSXBline('END',l);


      while oos.Count>0 do begin
         t := oos[0];
         PrepareSXBline(t,l);
         oos.Delete(0);
      end;

      PrepareSXBline(IntToStr(LineSUB),l);
    end;

    // now for the SUB Block ... Each SUB gets its own GOSUB block,
    // SUBEND gets substituted with SUBEXIT, after the last RETURN the
    // subroutine ends with SUBEND
    if (oos.count>0) and (PosUnquoted('SUBEND',s)>0) then begin
      s := StringReplace(s,'SUBEND','SUBEXIT',[rfReplaceAll,rfIgnoreCase]);
      PrepareSXBline(s,l);
      while oos.Count>0 do begin
         t := oos[0];
         PrepareSXBline(t,l);
         oos.Delete(0);
      end;
      s:='SUBEND';
    end;
    PrepareSXBline(s,l);
  end;



  // check for reserved words in XB compiler
  for i:=0 to subc-1 do begin
     if subr[i,1]='!' then t := ' ' + copy(subr[i],2,16) + ' '
                      else t := ' ' + subr[i] + ' ';
     if pos(t,reserved)>0 then dbg(1,'Warning:'+t+'is a reserved word in XB Compiler.');
  end;

  // Check for 6 byte length limit
  for i:=0 to subc-1 do begin
       if subr[i,1]='!' then s := copy(subr[i],2,6)
                        else s := copy(subr[i],1,6);
       for j:=i+1 to subc do begin
          if subr[j,1]='!' then t := copy(subr[j],2,6)
                           else t := copy(subr[j],1,6);
          if s=t then dbg(1,'Warning: ' + subr[i] + ' and ' + subr[j] + ' too similar for XB Compiler (only 6 significant chars)');
       end;
  end;

  // Check for 6 byte length limit against standard subroutines
  for i:=0 to subc-1 do begin
       if subr[i,1]='!' then s := copy(subr[i],2,6)
                        else s := copy(subr[i],1,6);
           if (Pos(' '+s+' ',' PATTER CHARPA CHARSE POSITI SCREEN DELSPRI LOCATE DISTAN MAGNIF SPRITE MOTION VERSIO ')>0)
              then dbg(1,'Warning: ' + subr[i] + ' is too similar to standard routine for XB Compiler (only 6 significant chars)');
   end;


  // check for illegal number-labels
  for i:=0 to subc-1 do begin
     if subr[i,1]='!' then s := copy(subr[i],2,16)
                      else s := subr[i];
     if s[1]='L' then t := copy(s,1,1)
                 else t := copy(s,1,2);
     if pos(' ' + t + ' ' ,' NC NV NA SC SV SA L ')>0 then begin
       isnum := true;
       for j:=length(t)+1 to length(s) do if not isdigit(s[j]) then isnum:=false;
       if isnum then dbg(1,'Warning: '+s+' is invalid in XB Compiler.');
     end;
  end;

  j := 0;
  dbg(5,'List of SUB-Routines:');
  // move local subroutines to the end
  for i:=0 to subc-1 do begin
    dbg(5,'   '+subr[i]);
    if (subr[i,1]<>'!') then begin
        subr[j] := subr[i];
        if i<>j then subr[i] := '<local>';
        inc(j);
     end;
  end;

  dbg(4,'Looking in Library for: ');
  subc := j; // rest is now local
  for i:=0 to subc-1 do dbg(4,'   '+subr[i]);



  // read user-library file
  if UsrLibActive then begin
    dbg(3,'Read User-libfile '+libfile);
    ReadLibFile(libfile,l);
  end;


  // read Package-libraries file for specific SUB-routines
  if pkgfile <>'' then begin
    dbg(3,'Read Package-libfile '+pkgfile);
    pkgs := SplitString(pkgfile,';');
    for i:=0 to length(pkgs)-2 do ReadLibFile(pkgs[i],l);
  end;

  // read standard-library file
  if StdLibActive then begin
    t := ProgramDirectory + 'lib'+PathDelim+'StdLib.xblib';
    dbg(3,'Read Standard-libfile '+t);
    ReadLibFile(t,l);
  end;

  // create AUTOCHAR routine from the Char Tab
  for i:=0 to subc-1 do if (subr[i]<>'<local>') and (subr[i]<>'<done>') then
    if subr[i]='AUTOCHAR' then begin
      PrepareSXBline('SUB AUTOCHAR',l);
      s:='';
      for j:=32 to 159 do begin
        t := GetCharIfDefined(0,j);
        if (s='') and (t<>'') then s:='  CALL CHAR('+IntToStr(j)+',"'+t
        else if (s<>'') and (t<>'') then s:=s+t;
        if ((s<>'') and (t='')) or (length(s)-Pos('"',s)>48) or ((j=159) and (s<>'')) then begin
          s:=s+'")';
          PrepareSXBline(s,l);
          s:='';
        end;
      end;
        for j:=0 to 255 do begin // XB256 page
        t := GetCharIfDefined(1,j);
        if (s='') and (t<>'') then s:='  CALL LINK("CHAR2",'+IntToStr(j)+',"'+t
        else if (s<>'') and (t<>'') then s:=s+t;
        if ((s<>'') and (t='')) or (length(s)-Pos('"',s)>80) or ((j=255) and (s<>'')) then begin
          s:=s+'")';
          PrepareSXBline(s,l);
          s:='';
        end;
      end;
      PrepareSXBline('SUBEND',l);
    end else dbg(1,'Warning: Subroutine '+ subr[i] + ' not declared.');


  maxl := l - 1;

  l:=1;
  repeat
    if LeftStr(prg[l].stmt,6)='//ASM:' then AsmBlock(l);
    j := PosUnquoted('//',prg[l].stmt);
    if j>0 then begin
       dbg(4,'Remove comment '+copy(prg[l].stmt,j,255));
       prg[l].stmt := copy(prg[l].stmt,1,j-1);
    end;
    inc(l);
  until l>maxl;

  // Replaces REPEAT ... UNTIL
  for l:=1 to maxl do begin
    if Uppercase(leftstr(prg[l].stmt,7))='REPEAT ' then begin
      prg[l].stmt := trim(copy(prg[l].stmt,7,255))+' ';
      inc(loopcount);
      lpush(lrepeat,loopcount,'');
      prg[l].lbl  := 'REPEAT'+format('%.3d',[loopcount]);
      dbg(3,'REPEAT: '+prg[l].lbl+':')
    end else if Uppercase(leftstr(prg[l].stmt,6))='UNTIL ' then begin
      lpop(lk,nm,t);
      t := trim(copy(prg[l].stmt,7,cmdend(prg[l].stmt)-7));
      if lk=lwhile then dbg(0,'ERROR in Nesting: ENDWHILE expected in line '+inttostr(i));
      dbg(3,'UNTIL ['+t+']');
      prg[l].stmt := 'IF NOT ('+t+') THEN REPEAT'+format('%.3d',[nm])+copy(prg[l].stmt,cmdend(prg[l].stmt),255);
      dbg(4,prg[l].stmt);
    end;
  end;

  // Replaces WHILE ... ENDWHILE / WEND
  for l:=1 to maxl do begin
    if Uppercase(leftstr(prg[l].stmt,6))='WHILE ' then begin
      inc(loopcount);
      t := copy(prg[l].stmt,7,cmdend(prg[l].stmt)-7);
      lpush(lwhile,loopcount,t);
      dbg(3,'WHILE ['+t+']');
      prg[l].stmt  := 'GOTO ENDWHILE'+format('%.3d',[loopcount]);
      prg[l+1].lbl := 'WHILE'+format('%.3d',[loopcount]);
    end else if (Uppercase(leftstr(prg[l].stmt,9))='ENDWHILE ') or
                (Uppercase(leftstr(prg[l].stmt,5))='WEND ') then begin
      lpop(lk,nm,t);
      if lk=lrepeat then dbg(0,'ERROR in Nesting: UNTIL expected in line '+inttostr(i));
      prg[l].lbl:='ENDWHILE'+format('%.3d',[nm]);
      prg[l].stmt := 'IF '+t+' THEN WHILE'+format('%.3d',[nm]);
    end;
  end;


  // Assign Line-Numbers to all lines, -1 means empty line to be skipped
  if (prg[1].nr<>0) then lstart:=prg[1].nr;   // use start only if first line has no number
  for l:=1 to maxl do with prg[l] do begin
     if nr=llast then dbg(0,'ERROR in line-numbering! '+inttostr(lstart)+' used twice.');
     if (trim(stmt) = '') and (nr=0) then nr := -1
    else if nr=0 then begin
      if lstart=llast then inc(lstart,linc);
      nr := lstart;
    end else if nr>lstart then begin
       if lstart+linc <> nr then dbg(4,'Overwriting Line-Number '+inttostr(lstart)+' with '+inttostr(nr));
       lstart := nr;
       if trim(stmt)='' then nr:=-1;
    end else if nr<lstart then dbg(0,'ERROR in line-numbering! '+inttostr(lstart)+' larger than '+inttostr(nr));
    if nr>0 then llast:=nr;
  end;

  if lstart>32535 then dbg(0,'Error: Line-Number out of range! (1-32536).');

  // Build table of Labels with Line-Numbers
  dbg(3,'');
  dbg(3,'Line Number Table');
  maxlbl := 0;
  for l:=1 to maxl do with prg[l] do
     if (lbl<>'') then begin
        j:=l;
        // assign the next valid line-number
        while prg[j].nr=-1 do inc(j);
        labtab[maxlbl].txt  := lbl;
        labtab[maxlbl].line := prg[j].nr;
        // check for uniqueness
        for i:=0 to maxlbl-1 do if labtab[i].txt=labtab[maxlbl].txt then
           dbg(0,'Error: Label '+labtab[i].txt+' not unique.');
        inc(maxlbl);
     end;
  dec(maxlbl);
  // Sort Labels by descending length
  repeat
     sorted := true;
     for j:=0 to maxlbl-1 do
       if length(labtab[j].txt)<length(labtab[j+1].txt) then begin
         templab     := labtab[j];
         labtab[j]   := labtab[j+1];
         labtab[j+1] := templab;
         sorted      := false;
       end;
  until sorted;

  for j:=0 to maxlbl do dbg(3,'   '+        labtab[j].txt+' -> '+inttostr(labtab[j].line));

  // Replace Labels with Line-Numbers
  for l:=1 to maxl do
    if prg[l].nr>0 then begin
      for j:=0 to maxlbl do begin
         if pos('on a',prg[l].stmt)>0
            then i:=1;
         i := PosUnquoted(labtab[j].txt, prg[l].stmt);
         if i=1 then i:=0; // Line can't begin with a substituted line-number
         if (i>1) and not isstop(prg[l].stmt[i-1])
            then i:=0;     // must have a stop-char in front
         if (i>1) and (i+length(labtab[j].txt)<length(prg[l].stmt)) and not isstop(prg[l].stmt[i+length(labtab[j].txt)])
            then i:=0;     // must be last or have a stop-char following

         while i > 0  do begin
            dbg(4,'Label replace: <'+labtab[j].txt+'> => '+inttostr(labtab[j].line));
            dbg(4,'     '+ prg[l].stmt);
            prg[l].stmt := copy(prg[l].stmt,1,i-1)
                         + inttostr(labtab[j].line)
                         + copy(prg[l].stmt,i+length(labtab[j].txt),255);
            i := PosUnquoted(labtab[j].txt, prg[l].stmt);
            if (i>1) and not isstop(prg[l].stmt[i-1])
               then i:=0;     // must have a stop-char in front
            if (i>1) and (i+length(labtab[j].txt)<length(prg[l].stmt)) and not isstop(prg[l].stmt[i+length(labtab[j].txt)])
               then i:=0;     // must be last or have a stop-char following
            dbg(4,'  -> ' + prg[l].stmt);
         end;
      end;
    end;

  dbg(4,'');
  dbg(4,'Standard Extended Basic:');
  dbg(4,'');
  // write XB File
  for i:=1 to maxl do with prg[i] do if nr>0 then begin
    dbg(4,inttostr(nr)+' '+stmt);
    writeln(xb,nr,' ',trim(stmt));
  end;
  dbg(4,'');
  dbg(4,'Internal lines used: '+inttostr(maxl));

  if asmb.Count>0 then begin
    dbg(2,'Embedded Assembler: File '+asmfile+' written');
    asmb.SaveToFile(asmfile);
    asmlst.SaveToFile(ChangeFileExt(asmfile,'.lst'));
  end;
end;



Function SXBtoXB(sxbin,xbout: String;linestart,lineinc,LineGOSUB,LineSUB:Integer;WriteLogProc:TLogProc;PkgFile,LibFile,Options:String):Integer;
var i: Integer;
begin
  WriteLog := WriteLogProc;
  sxb    := TStringList.Create;
  sxb.LoadFromFile(sxbin);
  sxbline := 0;
  BaseDir := ExtractFileDir(sxbin);

  assign(xb,xbout);
  rewrite(xb);
  oos    := TStringList.Create;
  asmb   := TStringList.Create;
  asmlst := TStringList.Create;
  consts := TStringList.Create;
  asmfile:= '';


  if pos('-DEBUG', UpperCase(Options)) > 0 then debug := true
                                           else debug := false;
  if pos('-LCLINK',UpperCase(Options)) > 0 then lclink := true
                                           else lclink := false;

  i := pos('-ASMFILE="',UpperCase(Options));
  if i > 0 then begin
    inc(i,10);
    while (i<length(Options)) and (Options[i]<>'"') do begin
       asmfile := asmfile + Options[i];
       inc(i);
    end;

  end;


  dbg(2,'starting to convert SXB to XB ....');
  if debug then dbg(3,'Debug is active: Lines starting # will be included');

  LoadLibraries(PkgFile,LibFile,Options);
  buildlist(linestart,lineinc,LineGOSUB,LineSUB,libFile,PkgFile);

  system.close(xb);

  if asmb.Count>0 then sxbtoXB := 1
                  else sxbtoXB := 0;
  while oos.Count>0 do dbg(5,'>>> '+oos.pop);

  sxb.Destroy;
  oos.Destroy;
  asmb.Destroy;
  asmlst.Destroy;
  consts.Destroy;

end;

end.

