home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / INFO / PASCAL / CONVERT.ZIP / CONVERT.PAS
Encoding:
Pascal/Delphi Source File  |  1985-12-28  |  12.1 KB  |  392 lines
  1. {$U-,C-,I-}
  2. PROGRAM convert;
  3.  
  4.  
  5. {------------------------------------------------------------------------------
  6.  
  7.     WARNING  WARNING  WARNING  WARNING  WARNING  WARNING  WARNING  WARNING
  8.  
  9.       This program has been tested on many different forms of procedures
  10.   and functions, but may not work on the particular one you have created.  If
  11.   your procedure does not work make sure that there are no nested procedures
  12.   and that there is enough memory to load the full procedure in.
  13.  
  14.   Specifically for version 2.00B of the generic MS-DOS or IBM PC-DOS
  15.   implementations Turbo Pascal.  It would be easy to convert this for other
  16.   versions of those same implementations.  See Consideration #4 below.  If
  17.   anyone wants to convert this for the CP/M 86 implementation, you are welcome
  18.   to do so and UPLoad it here.
  19.  
  20.  ------------------------------------------------------------------------------
  21.  
  22.  
  23.       Convert is used to change precompiled chain files into a format that is
  24.  callable by a Turbo program as an external .COM file.  There is a loader
  25.  ( LOADER.INC ) that must be included ie.  $I LOADER.INC  by the program that
  26.  is to use the .COM files created by Convert.
  27.  
  28.  
  29.       There are just a few considerations and precautions that must be taken
  30.  for the external created by Convert to work properly :
  31.  
  32.    1 : The files to be converted must be chain files.
  33.    2 : The procedure should have a dummy BEGIN END. to be compiled. Do
  34.        NOT put anything inside the BEGIN END. of the external procedure.
  35.    3 : Each procedure or function cannot have nested procedures or functions
  36.        inside of it.
  37.       013D
  38.    4 : The program Convert must have the CONST LibrarySize set to the ending
  39.        of the Turbo RUN-TIME library ( $2828 for the PC 2.00B, $2565 for
  40.        the generic MS-DOS implementation of Turbo Pascal version 2.00B ).
  41.    5 : Each program that uses the loader and an external procedure cannot
  42.        be run twice within Turbo,  unless a recompilation occurs.
  43.  
  44.  For an example of an external and a calling program read the file CONVRT.DOC.
  45.  
  46.                                                      Written by
  47.                                                      Jim McCarthy
  48.                                                      Technical Support
  49.                                                      Borland International
  50.  
  51. ------------------------------------------------------------------------------}
  52.  
  53.   CONST
  54.     LibrarySize = $2954;               { Size of RUN-TIME library }
  55.     ProcStart   = $296A;               { LibrarySize + $16 }
  56.  
  57.   TYPE
  58.     str3  = string[ 3 ];
  59.     str80 = string[ 80 ];
  60.     chararr15 = array [ 0..15 ] of char;
  61.     ptr   = ^proc;
  62.     proc  = record
  63.               byte_val : byte;
  64.               setaddr : boolean;
  65.               next : ptr;
  66.             end;
  67.  
  68.   CONST
  69.     HexStr : CharArr15 = '0123456789ABCDEF';
  70.  
  71.   VAR
  72.     proc_top, proc_current, proc_temp,
  73.     head_top, head_current, head_temp    : ptr;
  74.     cmdline                              : str80 absolute cseg:$0080;
  75.     filename, outfile, base              : str80;
  76.     extension                            : str3;
  77.     element, byte_buff                   : byte;
  78.     inp, out                             : file of byte;
  79.     i, j, size, address, table_size,
  80.     table_addr, current_addr, num_calls,
  81.     prog_size, size_file                 : integer;
  82.  
  83.   PROCEDURE init;
  84.  
  85.     VAR
  86.       i : integer;
  87.  
  88.     BEGIN
  89.       For i := 1 to 5 Do writeln;
  90.       head_top := nil;
  91.       proc_top := nil;
  92.       num_calls := 0;
  93.       i := $100;
  94.       prog_size := 0;
  95.       table_addr := 1;
  96.       current_addr := 0;
  97.     END;
  98.  
  99.  
  100.   PROCEDURE Report( filename : str80; error : integer );
  101.  
  102.     BEGIN
  103.       Case ( error ) of
  104.         1 : writeln( 'Disk Full.' );
  105.         2 : writeln( 'File must not be a .COM file.' );
  106.         3 : writeln( 'Cannot open file : ''', filename, '''.' );
  107.         4 : writeln( 'Read error on file : ''',filename,'''.' );
  108.         5 : writeln( 'Write error on file : ''',filename,'''.' );
  109.       End;
  110.       writeln( 'Program ending.' );
  111.       close( inp );
  112.       close( out );
  113.       Halt;
  114.     END;
  115.  
  116.   PROCEDURE TruncForSp( var buffer : str80 );
  117.  
  118.     VAR
  119.       i, j, len : integer;
  120.  
  121.     BEGIN
  122.       i := 1;
  123.       len := length( buffer );
  124.       While ( buffer[ i ] = ' ' ) and ( i <= len ) Do
  125.         i := i + 1;
  126.       For j := 1 to len - i + 1 Do
  127.         buffer[ j ] := buffer[ i + j - 1 ];
  128.       buffer[ 0 ] := chr(len - i + 1);
  129.     END;
  130.  
  131.   FUNCTION HexAddr( address : integer ) : str80;
  132.  
  133.     VAR
  134.       buffer : str80;
  135.       low1nib, low2nib, high1nib, high2nib : byte;
  136.  
  137.     BEGIN
  138.       low1nib := address and $F;
  139.       high1nib := ( address and $F0 ) shr 4;
  140.       low2nib := ( address and $F00 ) shr 8;
  141.       high2nib := ( address and $F000 ) shr 12;
  142.       HexAddr := HexStr[ high2nib ] + HexStr[ low2nib ] +
  143.                  HexStr[ high1nib ] + HexStr[ low1nib ];
  144.     END;
  145.  
  146.   PROCEDURE GetFileBase( var filename : str80;  var base : str80;
  147.                          var extension : str3 );
  148.  
  149.     VAR
  150.       i, j : integer;
  151.  
  152.     BEGIN
  153.       i := 1;
  154.       While ( not ( filename[ i ] in [ '.', ' ' ] )) and
  155.             ( i <= length( filename )) Do
  156.         Begin
  157.           filename[ i ] := Upcase( filename[ i ] );
  158.           base[ i ] := filename[ i ];
  159.           base[ 0 ] := chr( i );
  160.           i := i + 1;
  161.         End;
  162.       If ( filename[ i ] = '.' ) then
  163.         Begin
  164.           i := i + 1;
  165.           j := 1;
  166.           While ( not ( filename[ i ] in [ ' ', '.' ] )) and
  167.                 ( i <= length( filename )) and ( j <= 3 ) Do
  168.             Begin
  169.               filename[ i ] := UpCase( filename[ i ] );
  170.               extension[ j ] := filename[ i ];
  171.               extension[ 0 ] := chr( j );
  172.               j := j + 1;
  173.               i := i + 1;
  174.             End;
  175.         End;
  176.     END;
  177.  
  178.   PROCEDURE SetUpFiles( filename : str80 );
  179.  
  180.     BEGIN
  181.       assign( inp, filename );
  182.       reset( inp );
  183.       If ( IOResult <> 0 ) then Report( filename, 3 );
  184.       GetFileBase( filename, base, extension );
  185.       If ( extension <> 'COM' ) then
  186.         outfile := base + '.COM'
  187.       else Report( '', 2 );
  188.       assign( out, outfile );
  189.       rewrite( out );
  190.       If ( IOResult <> 0 ) then Report( '', 1 );
  191.     END;
  192.  
  193.    PROCEDURE AddHeadPtr( value : byte; setcall : boolean );
  194.  
  195.      BEGIN
  196.        New( head_temp );
  197.        head_temp^.byte_val := value;
  198.        head_temp^.setaddr := setcall;
  199.        If ( head_top <> nil ) then
  200.          head_current^.next := head_temp
  201.        else
  202.          head_top := head_temp;
  203.        head_current := head_temp;
  204.        head_current^.next := nil;
  205.      END;
  206.  
  207.    PROCEDURE AddProcPtr( value : byte; setcall : boolean );
  208.  
  209.      BEGIN
  210.        New( proc_temp );
  211.        proc_temp^.byte_val := value;
  212.        proc_temp^.setaddr := setcall;
  213.        If ( proc_top <> nil ) then
  214.          proc_current^.next := proc_temp
  215.        else
  216.          proc_top := proc_temp;
  217.        proc_current := proc_temp;
  218.        proc_current^.next := nil;
  219.      END;
  220.  
  221.    PROCEDURE DumpPtr( top : ptr );
  222.  
  223.      VAR
  224.        current, temp : ptr;
  225.        value : byte;
  226.        i : integer;
  227.  
  228.      BEGIN
  229.        i := 0;
  230.        current := top;
  231.        While ( current <> nil ) Do
  232.          Begin
  233.            temp := current;
  234.            value := current^.byte_val;
  235.            write( out, value );
  236.            If ( IOResult <> 0 ) then Report( outfile, 5 );
  237.            current := current^.next;
  238.            i := i + 1;
  239.          End;
  240.      END;
  241.  
  242.   PROCEDURE CreatHeader( var header_size : integer; numcalls : integer );
  243.  
  244.     VAR
  245.       temp, temp1, temp2 : ptr;
  246.       i, current_addr : integer;
  247.  
  248.     BEGIN
  249.       current_addr := 0;
  250.       header_size := 0;
  251.       temp := proc_top;
  252.       i := 0;
  253.       While ( temp <> nil ) and ( i <= numcalls ) Do
  254.         Begin
  255.           If ( temp^.byte_val = $E8 ) or ( temp^.byte_val = $E9 ) then
  256.             Begin
  257.               temp1 := temp^.next;
  258.               temp2 := temp1^.next;
  259.               address := ( temp2^.byte_val shl 8 ) + temp1^.byte_val;
  260.               address := ( ProcStart + current_addr + 2 ) - ( address xor $FFFF );
  261.               If ( temp^.byte_val = $E9 ) then
  262.                 write( 'JMP made to  : ', HexAddr( address ))
  263.               else
  264.                 write( 'CALL made to : ', HexAddr( address ));
  265.               If ( address < LibrarySize ) and ( address > $100 ) then
  266.                 Begin
  267.                   writeln( '  Address to be changed.' );
  268.                   temp^.setaddr := true;
  269.                   AddHeadPtr( $E9, false );
  270.                   AddHeadPtr( address and $FF, false );
  271.                   AddHeadPtr(( address and $FF00 ) shr 8, false );
  272.                   header_size := header_size + 3;
  273.                   i := i + 1;
  274.                 End
  275.               else
  276.                 writeln( '  Address not changed.' );
  277.               current_addr := current_addr + 2;
  278.               temp := temp2^.next;
  279.             End
  280.           else temp := temp^.next;
  281.           current_addr := current_addr + 1;
  282.         End;
  283.       writeln;
  284.     END;
  285.  
  286.   PROCEDURE SetProcCalls( header_size, numcalls : integer );
  287.  
  288.     VAR
  289.       address, current_addr, curr_proc_addr,
  290.       curr_head_addr, i, line                  : integer;
  291.       temp, temp1, temp2                       : ptr;
  292.  
  293.     BEGIN
  294.       temp := proc_top;
  295.       curr_head_addr := 3;
  296.       curr_proc_addr := header_size + 3;
  297.       current_addr := 0;
  298.       line := 1;
  299.       i := 0;
  300.       While ( temp <> nil ) and ( i <= numcalls ) Do
  301.         Begin
  302.           If (( temp^.byte_val = $E8 ) or ( temp^.byte_val = $E9 )) and
  303.              ( temp^.setaddr = true ) then
  304.             Begin
  305.               temp1 := temp^.next;
  306.               temp2 := temp1^.next;
  307.               temp := temp2^.next;
  308.               address := ( curr_proc_addr - curr_head_addr + 2 ) xor $FFFF;
  309.               temp1^.byte_val := ( address and $FF );
  310.               temp2^.byte_val := ( address and $FF00 ) shr 8;
  311.               current_addr := current_addr + 2;
  312.               curr_head_addr := curr_head_addr + 3;
  313.               curr_proc_addr := curr_proc_addr + 2;
  314.               i := i + 1;
  315.             End
  316.           else
  317.             temp := temp^.next;
  318.           curr_proc_addr := curr_proc_addr + 1;
  319.           current_addr := current_addr + 1;
  320.           line := line + 1;
  321.         End;
  322.     END;
  323.  
  324.   PROCEDURE PointToStart;
  325.  
  326.     VAR
  327.       i : integer;
  328.       byte_val : byte;
  329.  
  330.     BEGIN
  331.       For i := 0 to $15 Do
  332.         Begin
  333.           read( inp, byte_val );
  334.           If ( IOResult <> 0 ) then Report( filename, 4 );
  335.         End;
  336.     END;
  337.  
  338.   PROCEDURE SetHeaderSize( table_size : integer );
  339.  
  340.     VAR
  341.       element : byte;
  342.  
  343.     BEGIN
  344.       element := $E9;
  345.       write( out, element );
  346.       element := table_size and $FF;
  347.       write( out, element );
  348.       element := ( table_size and $FF00 ) shr 8;
  349.       write( out, element );
  350.     END;
  351.  
  352.   BEGIN
  353.     LowVideo;
  354.     filename := cmdline;
  355.     If ( length( filename ) = 0 ) then
  356.       Begin
  357.         write( 'Chain file name to convert to .COM file : ' );
  358.         HighVideo;
  359.         readln( filename );
  360.         LowVideo;
  361.         writeln;
  362.       End;
  363.     TruncForSp( filename );
  364.     If ( length( filename ) > 0 ) then
  365.       Begin
  366.         Init;
  367.         SetUpFiles( filename );
  368.         PointToStart;
  369.         size_file := filesize( inp );
  370.         While ( not eof( inp )) and ( memavail > 10 ) and
  371.               ( prog_size < size_file - $1C ) Do
  372.           Begin
  373.             read( inp, byte_buff );
  374.             AddProcPtr( byte_buff, false );
  375.             If ( byte_buff = $E8 ) or ( byte_buff = $E9 ) then
  376.               num_calls := num_calls + 1;
  377.             prog_size := prog_size + 1;
  378.           End;
  379.         writeln( 'Bytes of program read : ', HexAddr( prog_size ));
  380.         writeln( 'Calls  or  Jumps made : ', HexAddr( num_calls ));
  381.         writeln;
  382.         CreatHeader( table_size, num_calls );
  383.         writeln( 'Header size : ', HexAddr( table_size ));
  384.         SetProcCalls( table_size, num_calls );
  385.         SetHeaderSize( table_size );
  386.         DumpPtr( head_top );
  387.         DumpPtr( proc_top );
  388.         close( inp );
  389.         close( out );
  390.       End;
  391.   END.
  392.