unit tidbit;

{
 Released under the 3-Clause BSD License:
    Copyright 2010-2019 Matthew Hagerty (matthew <at> dnotq <dot> io)
    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.

    3. Neither the name of the copyright holder nor the names of its
    contributors may be used to endorse or promote products derived from this
    software without specific prior written permission.

    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 HOLDER 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.

    Ported to Pascal/ Lazarus by Stefan Bauch, 2020

    Original PHP Source code included for reference as comments.

}

{$mode objfpc}{$H+}

interface

uses
  Classes, SysUtils;

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

Function ExportXB(sxb,xbout: String;linestart,lineinc:Integer;WriteLogProc:TLogProc;Options:String):Integer;

implementation

uses
  {$IFDEF UNIX}{$IFDEF UseCThreads}
  cthreads,
  {$ENDIF}{$ENDIF}
  ctype
  { you can add units after this };

//class
//tidbit
//{
//    const SS_START      = 1;
//    const SS_IN_STRING  = 2;
//    const SS_IN_EXP     = 3;
//    const SS_IN_THEN    = 4;
//    const SS_IN_ELSE    = 5;
//    const SS_IN_GOTO    = 6;
//    const SS_IN_GOSUB   = 7;
//    const SS_IN_RETURN  = 8;
//    const SS_IN_ERROR   = 9;
//    const SS_IN_RESTORE = 10;
//    const SS_IN_BREAK   = 11;
//    const SS_IN_UNBREAK = 12;
//    const SS_DONE       = 13;
//    const MAX_LINE_NUM  = 32767;

const
   SS_START      = 1;
   SS_IN_STRING  = 2;
   SS_IN_EXP     = 3;
   SS_IN_THEN    = 4;
   SS_IN_ELSE    = 5;
   SS_IN_GOTO    = 6;
   SS_IN_GOSUB   = 7;
   SS_IN_RETURN  = 8;
   SS_IN_ERROR   = 9;
   SS_IN_RESTORE = 10;
   SS_IN_BREAK   = 11;
   SS_IN_UNBREAK = 12;
   SS_DONE       = 13;

   MAX_LINE_NUM  = 32767;

//    private $labels;
//    private $code_in;
//    private $head;
//    private $tail;
//    private $len;
//    private $debug;

TYPE
    TLabel = Record
               name : String[32];
               line : Longint;
             end;

    TCode = Record
               line : String;
               lnr  : Longint;
            end;


VAR
    labels: Array[1..100] of TLabel;
    loops:  Array[1..10] of String[10];
    code_in: String;
    head: Longint;
    tail: Longint;
    len: Longint;
    loopctr, sp : Integer;
    debug: Boolean = true;
    WriteLog : TLogProc;

// Additional Variables for Pascal Implementation
    i : Longint;
    txt,xb : textfile;
    NumLabels : Integer = 0;

//    private $sname = array(
//            1 => 'START',
//            2 => 'STRING',
//            3 => 'EXP',
//            4 => 'THEN',
//            5 => 'ELSE',
//            6 => 'GOTO',
//            7 => 'GOSUB',
//            8 => 'RETURN',
//            9 => 'ERROR',
//            10 => 'RESTORE',
//            11 => 'BREAK',
//            12 => 'UNBREAK'
//        );
    sname : array[1..12] of String[10] = (
            'START',
            'STRING',
            'EXP',
            'THEN',
            'ELSE',
            'GOTO',
            'GOSUB',
            'RETURN',
            'ERROR',
            'RESTORE',
            'BREAK',
            'UNBREAK'
        );

//    private $reserved_words = array(
//        'abs', 'accept', 'all', 'and', 'append', 'asc', 'at', 'atn',
//        'base', 'beep', 'break', 'bye',
//        'call', 'chr$', 'close', 'con', 'continue', 'cos',
//        'data', 'def', 'delete', 'digit', 'dim', 'display',
//        'else', 'end', 'eof', 'erase', 'error', 'exp',
//        'fixed', 'for',
//        'go', 'gosub', 'goto',
//        'if', 'image', 'input', 'int', 'internal',
//        'len', 'let', 'linput', 'list', 'log',
//        'max', 'merge', 'min',
//        'new', 'next', 'not', 'num', 'number', 'numeric',
//        'old', 'on', 'open', 'option', 'or', 'output',
//        'permanent', 'pi', 'pos', 'print',
//        'randomize', 'read', 'rec', 'relative', 'rem', 'res', 'resequence', 'restore', 'return', 'rnd', 'rpt$', 'run',
//        'save', 'seg$', 'sequential', 'sgn', 'sin', 'size', 'sqr', 'step', 'stop', 'str$', 'sub', 'subend', 'subexit',
//        'tab', 'tan', 'then', 'to', 'trace',
//        'ualpha', 'unbreak', 'untrace', 'update', 'using',
//        'val', 'validate', 'variable',
//        'warning',
//        'xor'
//        );
    reserved_words: array[1..104] of String[10] = (
        'abs', 'accept', 'all', 'and', 'append', 'asc', 'at', 'atn',
        'base', 'beep', 'break', 'bye',
        'call', 'chr$', 'close', 'con', 'continue', 'cos',
        'data', 'def', 'delete', 'digit', 'dim', 'display',
        'else', 'end', 'eof', 'erase', 'error', 'exp',
        'fixed', 'for',
        'go', 'gosub', 'goto',
        'if', 'image', 'input', 'int', 'internal',
        'len', 'let', 'linput', 'list', 'log',
        'max', 'merge', 'min',
        'new', 'next', 'not', 'num', 'number', 'numeric',
        'old', 'on', 'open', 'option', 'or', 'output',
        'permanent', 'pi', 'pos', 'print',
        'randomize', 'read', 'rec', 'relative', 'rem', 'res', 'resequence', 'restore', 'return', 'rnd', 'rpt$', 'run',
        'save', 'seg$', 'sequential', 'sgn', 'sin', 'size', 'sqr', 'step', 'stop', 'str$', 'sub', 'subend', 'subexit',
        'tab', 'tan', 'then', 'to', 'trace',
        'ualpha', 'unbreak', 'untrace', 'update', 'using',
        'val', 'validate', 'variable',
        'warning',
        'xor'
        );

//
//
//    /**
//     * Constructor
//     */
//    public function
//    __construct($debug=false)
//    {
//        $this->debug = $debug;
//    }
//    // __construct()
//
//
//    private function
//    dbg($text)
//    {
//        if ( $this->debug == True ) print "$text\n";
//    }
//    // dbg()
Procedure dbg(txt:String);
begin
  if debug then writelog(2,txt);
end;

Function Getlabel(s : String):String;
var col,i: integer;
    is_label: boolean;
begin
  is_label := false;
  col := pos(':',s);
  i:=1;
  if (col > 0) then
    if (length(s)>col) and (s[col+1]=':') then is_label := false
    else
      repeat
        is_label := (isalnum(s[i])) or (s[i]='_');
        inc(i);
      until (i>=col) or not is_label;
  if is_label then Getlabel := leftstr(s,col)
              else Getlabel := '';
end;

Function IdxLabel(s:String):longint;
var i : Integer;
begin
  i := numlabels;
  s := UpperCase(s);
  while (i>0) and (Labels[i].name<>s) do dec(i);
  if i>0 then IdXLabel := labels[i].line
         else IdXLabel := -1;
end;

Procedure AddLabel(s:String;l:Longint);
VAR i: integer;
begin
  s := Uppercase(s);
  i := numlabels;
  while (i>0) and (Labels[i].name<>s) do dec(i);
  if i<=0 then begin
      if numlabels<100 then inc(numlabels)
                       else dbg('Error: More than 100 labels used!');
      i:=numlabels;
  end;
  labels[i].name := s;
  labels[i].line := l;
end;

// Helper Functions for REPEAT and WHILE Extensions
Procedure PushLoop(s:String);
begin
  loops[sp] := s;
  inc(sp);
end;

Function PopLoop:String;
begin
  PopLoop := loops[sp];
  dec(sp);
end;

//
//    private function
//    getline()
Function getline:String;
VAR line:String;

Begin
  if eof(txt)
    then line:='FALSE'
    else readln(txt,line);

  // Convert any white space characters to a space.
  for i:=1 to length(line) do if isspace(line[i]) then line[i]:=#32;
  getline := line;
end;
//    {
//        $line = FALSE;
//
//        if ( $this->tail >= $this->len )
//            return $line;
//
//        // Find the next end of line.  CR, LF, CRLF
//        while ( $this->tail < $this->len )
//        {
//            // Check for a newline.
//            if ( $this->code_in[$this->tail== "\r" || $this->code_in[$this->tail] == "\n" )
//            {
//                // Don't include the newline.
//                $line = substr($this->code_in, $this->head, $this->tail - $this->head);
//
//                // Check for CRLF and increment the tail.
//                if ( $this->code_in[$this->tail] == "\r" && ($this->tail + 1) < $this->len &&
//                $this->code_in[$this->tail + 1] == "\n" )
//                    $this->tail++;
//
//                // Skip the newline and adjust the head.
//                $this->tail++;
//                $this->head = $this->tail;
//                break;
//            }
//
//            // Convert any white space characters to a space.
//            else if ( $this->isspace($this->code_in[$this->tail]) )
//                $this->code_in[$this->tail] = ' ';
//
//            $this->tail++;
//        }
//
//        // Catch the end of data condition that does not end with a newline.
//        if ( $this->head < $this->tail )
//        {
//            $line = substr($this->code_in, $this->head, $this->tail - $this->head);
//            $this->head = $this->tail;
//        }
//
//        return $line;
//    }

Function parse(buf:String; linenum:longint):string; FORWARD;

//
//    /**
//     * Translate the code.
//     *
//     * @param[in] $code_in      Input code
//     * @param[in] $line_num     Starting line number
//     * @param[in] $line_inc     Line number increment
//     */
//    public function
//    translate($code_in, $line_num = 100, $line_inc = 10)

Procedure translate(line_num, line_inc : Longint);
VAR code_out, labl : String;
    code   : Array[1..1000] of TCode;
    // Labels : Array[1..100] of String[32];
    fixup  : Array[1..10] of String[32];
    proc_inc : Longint = 1000;
    lines : Longint = 0;
    cont, lookahead, trailing, buf, a_buf, nextline, line : String;
    max_line_len : Longint;
    in_string, is_label : Boolean;
    co : Integer = 1;

begin

//    {
//        if ( $line_num < 1 || $line_num > self::MAX_LINE_NUM )
//            $line_num = 100;
//
//        if ( $line_inc < 1 || $line_inc > 100 )
//            $line_inc = 10;

    if ( line_num < 1 ) OR (line_num > MAX_LINE_NUM ) then line_num := 100;
    if ( line_inc < 1 ) OR (line_inc > 100 ) then line_inc := 10;


//        $this->code_in = $code_in;
//        $this->len = strlen($code_in);
//        $this->head = 0;
//        $this->tail = 0;
//
//        $code_out = '';
//        $code = array();
//        $this->labels = array();
//        $fixup = array();
//        $lines = 0;
//        $proc_inc = 1000;
//        $cont = '';
//        $lookahead = '';
//        $trailing = '';
//        $max_line_len = 140;

      //? $this->code_in = $code_in;
      // len := strlen($code_in); // File-Size?
      head := 0;
      tail := 0;
      code_out := '';
      proc_inc := 1000;
      cont := '';
      lookahead := '';
      trailing := '';
      max_line_len := 140;
      for i:=1 to 10 do fixup[i]:='';
      sp := 0;
      loopctr := 0;

//
//        $this->dbg("\nPass 1, find all labels and assign line numbers\n");
      dbg('Pass 1, find all labels and assign line numbers');

//
//        // Pass 1, find all labels and assign line numbers.
//        $nextline = $this->getline();
      nextline := getline;
//        while ( ($buf = $nextline) !== FALSE )
//        {
      while ( nextline <> 'FALSE' ) do
      begin
         buf := nextline;
//            $lines++;
//            $buf = trim($buf);
         inc(lines);
         buf := trim(buf);

//            while ( TRUE )
//            {
//                $nextline = $this->getline();
//                if ( $nextline === FALSE ) { $lookahead = ''; break; }
//
//                // The look-ahead needs to skip blank lines, lines that start with //,
//                // or lines that only contain pseudo tokens (ENDIF)
//                $lookahead = trim($nextline);
//                if ( $lookahead == '' || substr($lookahead, 0, 2) == '//' || strtoupper($lookahead) == 'ENDIF' )
//                {
//                    $lines++;
//                    $this->dbg("Look-ahead skipping blank line, comment, or pseudo token.\n");
//                    continue;
//                }
//
//                break;
//            }

          while ( TRUE ) do
          begin
              nextline := getline;
              if ( nextline = 'FALSE' ) then begin lookahead := ''; break; end;

              // The look-ahead needs to skip blank lines, lines that start with //,
              // or lines that only contain pseudo tokens (ENDIF)
              lookahead := trim(nextline);
              if ( lookahead = '') OR (copy(lookahead, 0, 2) = '//') OR (UpperCase(lookahead) = 'ENDIF' ) then
              begin
                  inc(lines);
                  dbg('Look-ahead skipping blank line, comment, or pseudo token.');
                  continue
              end;
              break;
          end;

//            // Skip blank lines, lines that start with //, or lines that only
//            // contain pseudo tokens (ENDIF)
//            if ( $buf == '' || substr($buf, 0, 2) == '//' || strtoupper($buf) == 'ENDIF' )
//            {
//                $this->dbg("Skipping blank line, comment, or pseudo token.\n");
//                continue;
//            }
          if ( buf = '') OR (copy(buf, 0, 2) = '//') OR (UpperCase(buf) = 'ENDIF' ) then
          begin
              dbg('Skipping blank line, comment, or pseudo token.');
              continue;
          end;

//            // If a line starts with a line number, remove it and override the current
//            // line number *only* if the override line number is greater than or equal
//            // to the current line number.  This prevents accidentally overriding code.
//            if ( preg_match('/^([0-9]+)(.*)/', $buf, $a_buf) == 1 )
//            {
//                // If there is continuation text (multiple lines being joined), do not
//                // over-ride the line number counter, but do strip the line number from
//                // the input.
//                if ( $cont == '' )
//                {
//                    if ( (int)$a_buf[1] >= $line_num )
//                    {
//                        $this->dbg("Overriding line number: [$line_num] with [" . (int)$a_buf[1] . "]\n");
//                        $line_num = (int)$a_buf[1];
//                    }
//
//                    else
//                        $this->dbg("Ignoring line number override: [" . (int)$a_buf[1] . "], " .
//                                    "keeping line number: [$line_num]\n");
//                }
//
//                $buf = trim($a_buf[2]);
//            }
           i:=1;
           while isdigit(buf[i]) do inc(i);
           if i>1 then
           begin
             a_buf := copy(buf,1,i-1);
             if cont = '' then begin
               if strtoint(a_buf) >= line_num then begin
                  dbg('Overriding line number: ['+IntToStr(line_num)+'] with ['+a_buf+'].');
                  line_num := strtoint(a_buf)
               end else begin
                  dbg('Ignoring line number override: ['+IntToStr(line_num)+'].  keeping line number: ['+a_buf+'].');
               end;
             end;
             buf := trim(copy(buf,i-1,length(buf)-i))
           end;

//
//            // Blank the label and check for REM before anything else.
//            $label = '';
           labl := '';
//            // Retain REM lines without further processing.
//            if ( substr($buf, 0, 3) != "REM" || (strlen($buf) > 3 && $buf[3] != ' ') )
//            {
           if ( uppercase(copy(buf, 1, 3)) <> 'REM' ) OR ((length(buf) > 3) AND (buf[3] <> ' ')) then
           begin

//                // Skip joining lines if there is an ! outside of a string,
//                // which is an XB trailing line remark.
//                $in_string = FALSE;
//                $len = strlen($buf);
//                for ( $i = 0 ; $i < $len ; $i++ )
//                {
//                    // Check if in a string, being careful to support double quote escape ""
//                    if ( $buf[$i] == '"' )
//                    {
//                        if ( $in_string == FALSE )
//                            $in_string = TRUE;
//
//                        // If escaped doubled quote, skip the second quote and continue.
//                        else if ( ($i+1) < $len && $buf[$i+1] == '"' )
//                            $i++;
//
//                        else
//                            $in_string = FALSE;
//
//                        continue;
//                    }
              in_string := FALSE;
              len := length(buf);
              i := 1;
              while (i<=len) do
              begin
                  // Check if in a string, being careful to support double quote escape ""
                  if ( buf[i] = '"' ) then
                  begin
                     if ( in_string = FALSE ) then in_string := TRUE
                     // If escaped doubled quote, skip the second quote and continue.
                     else if ( (i+1) < len ) AND (buf[i+1] = '"' ) then inc(i)
                     else in_string := FALSE;
                     inc(i);
                     continue;
                  end;

//                    if ( $buf[$i] == '!' && $in_string == FALSE )
//                    {
//                        // Strip and save the trailing remarks.
//                        if ( $trailing == '' )
//                            $trailing = ($i > 0 && $buf[$i - 1] == ' ') ? ' !' : '!';
//
//                        $trailing .= substr($buf, $i + 1);
//                        $buf = trim(substr($buf, 0, $i));
//                        break;
//                    }
                  if ( buf[i] = '!') AND (in_string = FALSE ) then
                  begin
                      // Strip and save the trailing remarks.
                      if ( trailing = '' ) then
                         if (i > 1) AND( buf[i - 1] = ' ')
                            then trailing := ' !'
                            else trailing := '!';
                      trailing := trailing + copy(buf, i + 1,255);
                      buf := trim(copy(buf, 1, i));
                      break;
                  end;

//                    // Ignore anything on a line after a //
//                    if ( $buf[$i] == '/' && $in_string == FALSE && ($i + 1) < $len && $buf[$i+1] == '/' )
//                    {
//                        // Strip the trailing // comment.
//                        $buf = trim(substr($buf, 0, $i));
//                        break;
//                    }
//                }
                  // Ignore anything on a line after a //
                  if ( buf[i] = '/') AND (in_string = FALSE) AND ((i + 1) < len) AND (buf[i+1] = '/' ) then
                  begin
                      // Strip the trailing // comment.
                      buf := trim(copy(buf, 1, i-1));
                      break;
                  end;
                  inc(i);
               end;

//                // Combine lines that end with tidbit's special continuation operator ..,
//                // XB's multi-statement operator ::, an IF statement's THEN or ELSE, or
//                // where the next line is an ELSE statement.
//                if ( substr($buf, -2) == '..' )
//                {
//                    // Discard the ..
//                    $cont .= substr($buf, 0, -2);
//                    $this->dbg("Continuation text: [$cont]\n");
//                    continue;
//                }
                if (rightstr(buf, 2) = '..' ) then
                begin
                    // Discard the ..
                    cont := cont + rightstr(buf, 2);
                    dbg('Continuation text: ['+cont+']');
                    continue;
                end;

//                if ( substr($buf, -2) == '::' ||
//                strtoupper(substr($buf, -4)) == 'THEN' ||
//                strtoupper(substr($buf, -4)) == 'ELSE' ||
//                (strlen($lookahead) == 4 && strtoupper(substr($lookahead, 0, 4)) == 'ELSE') ||
//                (strlen($lookahead) > 4  && strtoupper(substr($lookahead, 0, 5)) == 'ELSE ') )
//                {
//                    // Retain the ::, THEN, ELSE, or add a space for the next line.
//                    $cont .= $buf . ' ';
//                    $this->dbg("Continuation text: [$cont]\n");
//                    continue;
//                }
                if ( rightstr(buf, 2) = '::') OR
                (uppercase(rightstr(buf, 4)) = 'THEN') OR
                (uppercase(rightstr(buf, 4)) = 'ELSE') OR
                ((length(lookahead) = 4) AND (uppercase(leftstr(lookahead, 4)) = 'ELSE')) OR
                ((length(lookahead) > 4) AND (uppercase(leftstr(lookahead, 5)) = 'ELSE ') ) then
                begin
                    // Retain the ::, THEN, ELSE, or add a space for the next line.
                    cont := cont + buf + ' ';
                    dbg('Continuation text: ['+cont+']');
                    continue;
                end;

//                if ( $cont != '' )
//                {
//                    $buf = $cont . $buf;
//                    $cont = '';
//                    $this->dbg("Found line: [$buf]\n");
//                }
                if ( cont <> '' ) then
                begin
                    buf  := cont + buf;
                    cont := '';
                    dbg('Found line: ['+buf+']');
                end;

           end;
//            }
//
//
//            // See if a line starts a label.  If a double colon is found, this is
//            // NOT a label.
//            if (
//            preg_match('/^([A-Za-z0-9_-]+:)[^:].*/', $buf, $a_buf) == 1 ||
//            preg_match('/^([A-Za-z0-9_-]+:)$/', $buf, $a_buf) == 1 )
           a_buf := getlabel(buf);
           if a_buf <> '' then
           begin
//                // The $label var is used below to see if the label is alone
//                // on the line.
//                $label = $a_buf[1];
//                $idx = substr($a_buf[1], 0, -1);
//                if ( isset($this->labels[$idx]) )
//                {
//                    $this->dbg("WARNING: Ignoring duplicate label [$label] " .
//                                "on line [$lines]\n\n");
//                    $label = '';
//                }
//                // Silently ignore labels that are reserved words.  This will ignore
//                // the valid PRINT: statement which has the syntax of a label.
//                elseif ( !in_array(strtolower($idx), $this->reserved_words) )
//                {
//                    $this->labels[$idx] = $line_num;
//                    $this->dbg("Label: [$idx] on line: $line_num\n");
//                }
//
//                else
//                {
//                    $this->dbg("WARNING: Ignoring reserved word label [$label] " .
//                                "on line [$lines]\n\n");
//                    $label = '';
//                }
//            }
               labl := a_buf;
               if IdxLabel(a_buf)>0 then begin
                  dbg('WARNING: Ignoring duplicate label ['+labl+'] on line ['+inttostr(lines)+']');
                  labl := '';
               end else if Uppercase(labl) = 'PRINT:' then begin { TODO : Check other reserved words beside PRINT }
                  dbg('WARNING: Ignoring reserved word label ['+labl+'] on line ['+IntToStr(lines)+']');
                  labl := '';
               end else begin
                  AddLabel(labl,line_num);
                  dbg('Label: ['+labl+'] on line: '+IntToStr(line_num));
               end;
           end;
//
//            // If the label was alone on a line, store the label name to have its
//            // line number adjusted by the first line with some code on it.  This
//            // was added when the line number override was added, since a line
//            // following a label could force a line number, the label could end up
//            // having a non-existent line number reference.
//            if ( $label != '' && $buf == $label )
//            {
//                $fixup[] = substr($a_buf[1], 0, -1);
//                $this->dbg("Needs fixup: [" . substr($a_buf[1], 0, -1) . "]\n");
//            }
            if (labl<>'') and (buf=labl) then begin
               i := 1;
               while fixup[i]<>'' do inc(i);
               fixup[i]:=labl;
               dbg('Needs fixup: ['+labl+']');
            end else if (buf<>labl) OR (trailing<>'') then begin
//            // Save the line if the label is not the only text on the line.
//            else if ( $buf != $label || $trailing != '' )
//            {
//                // Fix up any empty labels that preceded this line.
//                foreach ( $fixup as $idx )
//                {
//                    $this->labels[$idx] = $line_num;
//                    $this->dbg("Fixup: [$idx] = $line_num\n");
//                }
               i := 1;
               while fixup[i]<>'' do begin
                 AddLabel(fixup[i],line_num);
                 dbg('Fixup: ['+fixup[i]+'] = '+IntTostr(line_num));
                 fixup[i]:='';
                 inc(i);
               end;
//                $fixup = array();
//
//                // Remove any label.
//                if ( $label != '' )
//                    $buf = trim(substr($buf, strlen($label)));
               if labl<>'' then buf := trim(rightstr(buf,length(buf)-length(labl)));

//
//                // Re-append any ! comment.
//                $buf .= $trailing;
//                $trailing = '';
               buf := buf + trailing;
               trailing := '';

//
//                $len = strlen($line_num . $buf);
//                if ( $len > $max_line_len )
//                {
//                    $this->dbg("WARNING: Source line [$lines], BASIC line [$line_num] " .
//                        "is too long: [$len]\n");
//                }
               if length(IntToStr(line_num)+buf) > max_line_len then
                   dbg('WARNING: Source line ['+IntToStr(lines)+'], BASIC line ['+IntToStr(line_num)+'] is too long');

               dbg('Code: '+IntToStr(line_num)+' '+ buf);
//
//                $this->dbg("Code: $line_num $buf\n");
//
//                $code[$line_num] = $buf;
//                $line_num += $line_inc;

               code[co].lnr  := line_num;
               code[co].line := buf;
               inc(co);
               inc(line_num, line_inc);

               if line_num > Max_Line_Num then begin
                  code_out := 'FATAL ERROR: line number exceeds maximum of ' + IntToStr(MAX_LINE_NUM);
                  break;
               end;
//                if ( $line_num > self::MAX_LINE_NUM )
//                {
//                    $code_out = "FATAL ERROR: line number exceeds maximum of " . self::MAX_LINE_NUM . "\n";
//                    $code = array();
//                    break;
//                }
            end;
//            }
//        }
          end;
//
//        $this->dbg("\nLabels:\n");
//        $this->dbg(print_r($this->labels, TRUE));
          dbg(' ');
          dbg('Labels:');
          for i:= 1 to NumLabels do dbg(labels[i].name+' '+inttostr(labels[i].line));

//        $this->dbg("\n\nProgram Code:\n");
//        $this->dbg(print_r($code, TRUE));

          dbg(' ');
          dbg('Program Code:');
          for i:= 1 to co-1 do dbg(inttostr(code[i].lnr) + ' ' + code[i].line);


//
//        $this->dbg("\nPass 2, replace labels with line numbers...\n");
          dbg(' ');
          dbg('Pass 2, replace labels with line numbers...');


//
//        // Pass 2, replace labels with line numbers.
//        foreach ( $code as $linenum => $buf )
          for i:=1 to co-1 do begin
//        {
//            // Look for statements that use line numbers:
//            // THEN, ELSE, GOTO, GOSUB, ERROR
//            // Make sure these are NOT in a string.
//            $line = $this->parse($buf, $linenum);
//            $this->dbg("$linenum $line\n");
//            $code_out .= "$linenum $line\n";
              line := parse(code[i].line,code[i].lnr);
              dbg(inttostr(code[i].lnr)+' '+ line);
              writeln(xb,code[i].lnr,' ',line);
           end;


//        }
//
//        return $code_out;
//    }
//    // translate()

end;   // translate()


//
//    /**
//     * Parse a line and replace labels with line numbers.
//     */
//    private function
//    parse($buf, $linenum)
Function parse(buf:String; linenum:longint):string;
VAR len,i,j,depth,idx : Integer;
    tok,utok,newbuf,n : String;
    c : char;
    state_next, state : integer;
    save : boolean;
begin
//    {
//        // Add a space to $buf to make EOL parsing easier.
//        $buf .= ' ';
//        $len = strlen($buf);
//        $tok = '';
//        $newbuf = '';
//        $state = self::SS_START;
//        $state_next = self::SS_START;
//        $depth = 0;

          buf := buf + ' ';
          len := length(buf);
          tok := '';
          newbuf := '';
          state := SS_START;
          state_next := SS_START;
          depth := 0;
          j := 1;


//        // Scan each character and detect tokens.
//        for ( $i = 0, $j = 0 ; $i < $len ; $i++ )
          i:=1;
          while i <=len do
          begin
//        {
//            // Get the current and next character.
//            $c = $buf[$i];
//            if ( $i + 1 < $len ) $n = $buf[$i + 1]; else $n = '';
              c := buf[i];
              if (i+1<len)
                 then n := buf[i+1]
                 else n := '' ;
//
//            // Determine the token.
//            switch ( $state )
              case state of
//            {
//            case self::SS_START :
              SS_START : begin
//
//                // Skip trailing spaces.
//                if ( $this->isspace($c) && $i == $j )
//                    $j++;
                  if isspace(c) AND (i=j) then inc(j)
//
//                // Capture and ignore to the end of the line.
//                else if ( $c == '!' )
//                    $i = $len - 2;
                  else if c = '!' then i := len - 2
//
//                else if ( $c == '"' )
//                    $state = self::SS_IN_STRING;
                  else if c='"' then state := SS_IN_STRING
//
//                // Check for expressions or functions, and skip them.
//                else if ( $c == '(' )
//                {
//                    $state = self::SS_IN_EXP;
//                    $depth = 1;
//                }
                  else if c='(' then begin
                     state := SS_IN_EXP;
                     depth := 1;
                  end
//
//                // Check for the double colon for multiple statements on a line.
//                else if ( $c == ":" && $n == ":" )
                  else if ( c=':' ) AND ( n=':') then
                  begin
//                {
//                    if ( $i > $j )
//                    {
//                        $tok = substr($buf, $j, $i - $j);
//                        $newbuf .= $tok;
//                        $this->dbg("LITERAL: [$tok]");
//                    }
                      if i>j then
                      begin
                         tok := copy(buf,j,i-j);
                         newbuf := newbuf + tok;
                         dbg('LITERAL: ['+tok+']');
                      end;
//
//                    $this->dbg("LITERAL: [::]");
                      dbg('LITERAL: [::]');

//
//                    // Trim the buffer before adding the "::", unless the buffer
//                    // ends with a colon.  This is to support a PRINT : : ::
//                    // statement, which is valid.
//                    $newbuf = trim($newbuf);
//                    if ( substr($newbuf, -1) == ':' ) $newbuf .= ' ';
//                    $newbuf .= '::';
//                    $i++;
//                    $j = $i + 1;
                      newbuf := trim(newbuf);
                      if ( rightstr(newbuf, 1) = ':' ) then newbuf := newbuf + ' ';
                      newbuf := newbuf + '::';
                      inc(i);
                      j := i + 1;
//                }
                  end
//
//                // Spaces appear between tokens and a final space was added to the
//                // input buffer as a sentinel.
//                else if ( $this->isspace($c) || $c == ',' )
                  else if (isspace(c)) OR (c=',') then
                  begin
//                {
//                    $tok = substr($buf, $j, $i - $j);
//                    $save = TRUE;
//                    $utok = strtoupper($tok);
                      tok  := copy(buf,j,i-j);
                      save := true;
                      utok := UpperCase(tok);
//
//                    // Add support for, and skip, an ENDIF token.
//                    if ( $utok == 'ENDIF' ) {$save = FALSE; $state = self::SS_START;}
                      if ( utok = 'ENDIF' ) then begin
                          save  := FALSE;
                          state := SS_START;
                      end;

//
//                    // Check for a reserved word.
//
//                    // If the token is a label, replace it.
//                    if ( isset($this->labels[$tok]) )
                      idx := IdxLabel(utok+':');
                      if (idx>0) then
                      begin
//                    {
//                        $newbuf .= $this->labels[$tok] . $c;
//                        $save = FALSE;
//                        $this->dbg("LABEL: [$tok]");
//                    }
                          newbuf := newbuf + IntToStr(idx) + c;
                          save := false;
                          dbg('LABEL: ['+utok+'] line '+ IntToStr(idx))
                      end
//
//                    else
//                        $this->dbg("LITERAL: [$tok]");
                      else dbg('LITERAL: ['+tok+']');

//                    if ( $save == TRUE ) $newbuf .= $tok . $c;
//                    $j = $i + 1;
                      if save then newbuf := newbuf + tok + c;
                      j := i + 1;
//                }
                  end;
//
//                break;
              end; // CASE SS_START
//
//            case self::SS_IN_STRING :
              SS_IN_STRING :
//
//                if ( $c == '"' )
//                {
//                    // If double "", skip both and stay in the string.
//                    if  ( $n == $c )
//                        $i++;
//                    else
//                    {
//                        if ( $state_next == self::SS_START )
//                            $this->dbg("STRING: " . substr($buf, $j, $i - $j + 1));
//
//                        $state = $state_next;
//                        $state_next = self::SS_START;
//                    }
//                }
                if c='"' then
                  if c=n then inc(i)
                  else begin
                      if (state_next=SS_START) then dbg('STRING: ' + copy(buf, j, i - j + 1));
                      state      := state_next;
                      state_next := SS_START;
                  end;
//                break;
//
//            case self::SS_IN_EXP :
              SS_IN_EXP :
                begin
//                // Watch for and ignore strings inside expressions or function calls.
//                if ( $c == '"' )
//                {
//                    $state = self::SS_IN_STRING;
//                    // Return to this state once the string is complete.
//                    $state_next = self::SS_IN_EXP;
//                }
                  if c='"' then
                  begin
                    state := SS_IN_STRING;
                    state_next := SS_IN_EXP;
                  end
//
//                // Count the open and close parens.  Exit state when the count is 0.
//                else if ( $c == '(' )
//                    $depth++;
                  else if c='(' then inc(depth)
//                else if ( $c == ')' )
//                    $depth--;
                  else if c=')' then dec(depth);
//
//                if ( $depth == 0 )
//                {
//                    $this->dbg("EXPRESSION: " . substr($buf, $j, $i - $j + 1));
//                    $state = self::SS_START;
//                    $newbuf .= substr($buf, $j, $i - $j + 1);
//                    if ( $n == ' ' ) $newbuf .= $n;
//                    $j = $i + 1;
//                }
                  if ( depth = 0 ) then
                  begin
                      dbg('EXPRESSION: ' + copy(buf, j, i - j + 1));
                      state := SS_START;
                      newbuf := newbuf + copy(buf, j, i - j + 1);
                      if ( n = ' ' ) then newbuf := newbuf + n;
                      j := i + 1;
                  end;

//
//                break;
                end
              else writeln('Scanner Bug!');
//            default :
//                print "Scanner bug!\n\n";
//                exit;
//            }
              end; // case
//        }
          inc(i);
          end; // for/while
//
//        return trim($newbuf);
          parse := newbuf;
//    }
end;  // Parse
//    // parse()
//
//// tidbit_model



Function ExportXB(sxb,xbout: String;linestart,lineinc:Integer;WriteLogProc:TLogProc;Options:String):Integer;

begin
  WriteLog := WriteLogProc;
  assign(txt,sxb);
  reset(txt);
  assign(xb,xbout);
  rewrite(xb);

  translate(linestart,lineinc);

  system.close(txt);
  system.close(xb);
end;




end.

