{

*************************************************************************
*                                                                       *
*                                                                       *
*                   *  C P A S  *  S Y S T E M  *                       *
*                                                                       *
*                                                                       *
*          * * *   S t a n d a r d   L i b r a r y   * * *              *
*                                                                       *
*                                                                       *
*                 ---  Listing Manager Library  ---                     *
*              ---  Version  2.2--A -- 30/06/2010 ---                   *
*                                                                       *
*         by :                                                          *
*                                                                       *
*             P. Wolfers                                                *
*                 c.n.r.s.                                              *
*                 Laboratoire de Cristallographie                       *
*                 B.P.  166 X   38042  Grenoble Cedex                   *
*                                             FRANCE.                   *
*                                                                       *
*************************************************************************


/////////////////////////////////////////////////////////////////////////
//                                                                     //
//                                                                     //
//                  Global Public Licence (GPL)                        //
//                                                                     //
//                                                                     //
// This license described in this file overrides all other licenses    //
// that might be specified in other files for this library.            //
//                                                                     //
// This library is free software; you can redistribute it and/or       //
// modify it under the terms of the GNU Lesser General Public          //
// License as published by the Free Software Foundation; either        //
// version 2.1 of the License, or (at your option) any later version.  //
//                                                                     //
// This library is distributed in the hope that it will be useful,     //
// but WITHOUT ANY WARRANTY; without even the implied warranty of      //
// MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU   //
// Library General Public License for more details.                    //
//                                                                     //
// You should have received a copy of the GNU Lesser General Public    //
// License along with this library (see COPYING.LIB); if not, write to //
// the Free Software Foundation :                                      //
//                      Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  //
//                                                                     //
/////////////////////////////////////////////////////////////////////////

}

(*
[inherit ('LIB:BASIC_ENV_STR',		{ string manager def. }
          'LIB:BASIC_ENV_TXF',		{ text file manager def. }
          'LIB:BASIC_ENV_LST')]		{ listing file mcpas_b__lstanager def. }
*)
module BASIC_LST;

{ Basic environment for output listing operation on text file }
{
        P.Wolfers
            Institut Neel
            C.N.R.S. Grenoble
            B.P. 166 X  38042 GRENOBLE CEDEX
                                             FRANCE

}



{ ****************************  Begin of PASCAL System Code Section  **************************** }

%pragma code_option (c_interface,      { To authorize the use of "standard" keyword }
    c_code '#define _FILE_DUPLICATE(fdst,fsrc) fdst = fsrc',
    c_code '#define _FILE_CLEAR(fdst) fdst = NULL'
  );


  procedure DUPLICATE_FILE( f1, f2: $wild_file ); standard '_FILE_DUPLICATE';
  procedure CLEAR_FILE( f: $wild_file ); standard '_FILE_CLEAR';

%pragma code_option noc_interface;              { To disable usage of "standard" keyword }

{ *****************************  End of PASCAL System Code Section  ***************************** }


const

  lst_maxheading =          60;                 { The maximum of maxheading is txf_maxline - 72 }



type
  str_ptr =            ^string;                 { Pointer of string }

  lst_ptr =       ^lst_context;                 { Listing pointer definition }

  lst_flagsty = ( lstf_print,                   { Flag for automatic print out on the Close Time }
                  lstf_terminal,                { Flag for the terminal mode (the file is a terminal device) }
                  lstf_stdout,                  { Flag for the console mode (the Pascal file is output) }
                  lstf_break,                   { Flag for break }
                  lstf_centered,                { Flag for centered mode }
                  lstf_justified,               { Flag for justified mode }
                  lstf_virtual                  { Flag for virtual output list (in memory) }
                );

  lst_flgsetw = set of lst_flagsty;             { A flags word }

  lst_attrflg = ( lsta_nochange,                { Attribute does not change }
                  lsta_enaattr,                 { Attribute is set }
                  lsta_sisattr                  { Attribute is cleared }
                );

  lst_context = record                          { * Listing context cpas_b__lst definition * }
    lst_next:          lst_ptr;                 { Listing link pointer }
    lst_currline,                               { Listing current line }
    lst_heading,                                { Listing page heading pointer }
    lst_title,                                  { Listing title pointer }
    lst_sbttl:         str_ptr;                 { Listing sub title output }
    lst_lncnt,                                  { Line count inside a page }
    lst_pgcnt,                                  { Page count }
    lst_lm,                                     { Listing left margin }
    lst_rm,                                     { Listing right margin }
    lst_lnsize,                                 { Line size in character }
    lst_pgsize:        integer;                 { Page size in line }
    lst_flagsw:    lst_flgsetw;                 { Listing Flags Word }
    case boolean of                             { For virtual output list (in memory) }
      false:
        (lst_file: text);                       { Text file pointer/ or nil if output }
      true:
        (lst_lsthde: $wild_pointer)             { String list pointer }
  end;



var
  lst_current,                                  { Current listing pointer }
  lst_hde:         [global] lst_ptr := nil;     { Used listing list header }

  lst_spc_mode:  [global] flags_file := [];     { Flag file mode to use }

  lst_date,                                     { Current time of day }
  lst_time:            [global] string(14);     { Current date of day }



procedure VLS_NEXTSTRING;
{ Procedure to output a line to a virtual (in memory file) }
{ Must be defined by the user }
external; 



{********************************************************}
{***********   listing managment routines    ************}
{********************************************************}


[global]
procedure STR_COPY_LIM( var trg: str_ptr;
                        var src: [readonly] string;
                            lim: integer );
var
  len: integer;

begin { STR_COPY_LIM }
  if src"address <> nil then len := src.length
                        else len := 0;
  if len > lim then len := lim;
  if trg <> nil then DISPOSE( trg );
  if len > 0 then
  begin
    NEW( trg, len );
    trg^ := src
  end
end STR_COPY_LIM;


[global]
procedure LST_INIT( p: lst_ptr );
begin { LST_INIT }
  with p^ do
  begin
    { lst_next is never initialized here }
    lst_currline := nil;               { No current line defined here }
    lst_heading  := nil;               { No listing default heading }
    lst_title    := nil;               { Listing title pointer }
    lst_sbttl    := nil;               { Listing sub title }
    lst_lncnt    := 0;                 { Line count inside a page }
    lst_pgcnt    := 0;                 { Page count set to 0 }
    lst_lm       := 0;                 { Left margin set to 0 }
    lst_rm       := 0;                 { Right margin set to 0 }
    lst_lnsize   := 0;                 { Line size in character }
    lst_pgsize   := 0;                 { Page size in line }
    lst_flagsw   := [];                { By default set as: No break, true text file, No print }
    CLEAR_FILE( lst_file )             { Initialize the Pascal File Variable } 
  end
end LST_INIT;


[global]
function LST_ALLOCATE: lst_ptr;
{ To allocate a listing, the result is the listing context address }
var p: lst_ptr;
begin { LST_ALLOCATE }
  NEW( p );
  p^.lst_next := lst_hde; lst_hde := p; { link to existing lst file }
  LST_INIT( p );
  LST_ALLOCATE := p
end LST_ALLOCATE;


[global]
procedure LST_FREE( var p: lst_ptr );
{ To free an allocated listing, at result the given address is clear to nil }
var
  pl, pl1: lst_ptr;

begin { LST_FREE }
  pl1 := nil;
  if p <> nil then
  begin
    pl := lst_hde; { look for the lst file to free }
    while (pl <> p) and (pl <> nil) do
    begin
      pl1 := pl; pl := pl^.lst_next
    end
  end else pl := nil;
  if pl <> nil then
  with p^ do
  begin
    if lst_currline <> nil then DISPOSE( lst_currline );
    if lst_heading <> nil then DISPOSE( lst_heading );
    if lst_title <> nil then DISPOSE( lst_title );
    if lst_sbttl <> nil then DISPOSE( lst_sbttl );
    if pl1 = nil then lst_hde := lst_next
                 else pl1^.lst_next := lst_next;
    DISPOSE( p ); p := nil
  end
end LST_FREE;



[global]
procedure LST_CLOSE( var p: lst_ptr; bfree: boolean );
{ to close a listing file with optional deallocation }
var
  disp: flags_file;

begin { LST_CLOSE }
  if p <> nil then
  begin
    with p^ do
    begin
      if lstf_print in lst_flagsw then disp := [print_file]
                                  else disp := [];
      { Close only the directly opened file }
      if [lstf_virtual,lstf_stdout]*lst_flagsw = [] then CLOSE( lst_file, disp );
      DISPOSE( lst_currline ); lst_currline := nil;
      if lst_heading <> nil then begin  DISPOSE( lst_heading ); lst_heading := nil  end;
      if lst_title   <> nil then begin  DISPOSE( lst_title ); lst_title := nil  end;
      if lst_sbttl   <> nil then begin  DISPOSE( lst_sbttl ); lst_sbttl := nil  end
    end;
    if bfree then LST_FREE( p )
             else LST_INIT( p )
  end
end LST_CLOSE;



[global]
procedure LST_OPEN( var p: lst_ptr;
                  in_var fspc, heading, title, sbttl: string := '';
                        lnsize, pgsize: integer;
                        bunknown, bprint, bappend: boolean;
                    var ierr: integer );
{ open a listing file:
  p is the listing context pointer, if nil on call then allocate a context.
  fspc is the file specification pointer,
  an empty string, the listing is defined on the standard output text file,
  heading is the page heading pointer (first line of each page),
  title is the job title (second line of each page),
  sbttl is the sub-job title (third line of each page),
  lnsize is the size of a line in character (cannot be exceed txf_maxline),
  if lnsize < 0 then the effective pgsize is :
    80 for terminal device output,
   132 for other devices.
  pgsize is the size of a page in line ( - the five first lines).
  if pgsize < 0 then the effective pgsize is :
    0 for terminal device output,
   60 for other devices.
  if 0 <= pgsize < 10 then the page handling is suppressed.
  if bunknown then if the file is already existing, then it is supershed,
  if bappend then the file should be append to previously existent file,
  if bprint then the file should be printed on close time.
}
var
  lmax:                      integer;
  ball, blg:                 boolean;
  fmod:                   flags_file;
  phead, ptitl, psbtt: string( 255 );

begin { LST_OPEN }
  if heading"address <> nil then phead := heading else phead := '';
  if  title"address  <> nil then ptitl :=  title  else ptitl := '';
  if  sbttl"address  <> nil then psbtt :=  sbttl  else psbtt := '';
  { The line count and page heading procedure
    must be call for each line to output on a lst text file }
  ball := (p <> nil);
  if p = nil then p := LST_ALLOCATE            { Allocate it if nil pointer }
             else LST_CLOSE( p, false )        { ... else close if already opened };
  with p^ do
  begin
    if fspc.length = 0 then                    { When no file path is provided }
    begin
      DUPLICATE_FILE( lst_file, output );      { ... we use the standard output descriptor ... }
      lst_flagsw := [lstf_stdout];             { ... and flag its use }
      iostatus := 0                            { Force the Success Open Status }
    end
    else
    begin
      fmod := [write_file,error_file] + lst_spc_mode;
      if bprint then lst_flagsw := [lstf_print];       { We set the file specific flags }
      if bappend  then fmod := fmod + [append_file];
      if bunknown then fmod := fmod + [unknown_file];
      OPEN( lst_file, fspc, fmod )             { We open the specified file }
    end;

    if iostatus = 0 then
    begin { No error }
      if TTY_FILE( lst_file ) then 
      begin { Default Terminal Mode }
        lst_flagsw := lst_flagsw + [lstf_terminal];
        lst_flagsw := lst_flagsw - [lstf_print];        { Cannot authorize the print option from terminal }
        if lnsize < 0 then lnsize :=  80;
        if pgsize < 0 then pgsize :=   0       { No page Mng. in default tty mode }
      end
      else
      begin { Default file Mode }
        if lnsize < 0 then lnsize := 132;
        if pgsize < 0 then pgsize :=  -1       { Reported Page Mng. in default file mode }
      end;
      { Set current page size }
      NEW( lst_currline, lnsize );
      lst_currline^.length := 0;
      lmax := lnsize - 1;
      { Set initial page heading }
      STR_COPY_LIM( lst_heading, phead, lst_maxheading );
      { Set initial title }
      STR_COPY_LIM( lst_title, ptitl, lmax );
      { Set initial sub title  }
      STR_COPY_LIM( lst_sbttl, psbtt, lmax );
      { Set page size and line size }
      lst_pgsize := pgsize; lst_lnsize := lnsize;
      lst_rm     := lst_lnsize;                { Right margin set to end of line }
      lst_lncnt  := lst_pgsize;                { To set lst_newline for initial form feed };
      if lst_pgsize < 0 then
      begin
        blg := false;
        if lst_heading <> nil then begin  blg := true; WRITELN( lst_file, '\HEADING ', lst_heading^.length:0, ' ', lst_heading )  end;
        if lst_title <> nil then begin  blg := true; WRITELN( lst_file, '\TITLE ', lst_title^.length:0, ' ', lst_title )  end;
        if lst_sbttl <> nil then begin  blg := true; WRITELN( lst_file, '\SUBTITLE ', lst_sbttl^.length:0, ' ', lst_sbttl )  end;
        if blg then WRITELN( lst_file );
      end;
      ierr := 0
    end
    else ierr := 2000 + iostatus
  end;
  if ierr <> 0 then
    if not ball then LST_FREE( p )
end LST_OPEN;



[global]
procedure LST_NEWLINE;
{ Must be call before to write a new line on a listing }
begin { LST_NEWLINE }
  with lst_current^ do
  if not (lstf_virtual in lst_flagsw) then
  if lst_pgsize >= 10 then                     { Valid page size }
  begin
    lst_lncnt := SUCC( lst_lncnt );
    if lst_lncnt >= lst_pgsize then
    begin
      lst_lncnt := 0;                          { Clear the line count }
      lst_pgcnt := SUCC( lst_pgcnt );          { Set next page number }
      PAGE( lst_file );                        { Skip to next page }
      if lst_heading <> nil then
      begin                                    { Output the heading line on listing file }
        WRITE( lst_file, ' ', lst_heading^ );
        if lst_lnsize < 110 then
        begin  lst_lncnt := 1; WRITELN( lst_file )  end;
        DATE( lst_date ); TIME( lst_time );    { Get current time and date }
        WRITELN( lst_file, ' RUN THE ', lst_date, ' AT ', lst_time, ' ':5,'PAGE ', lst_pgcnt:3 )
      end;
      if lst_title <> nil then WRITE( lst_file, lst_title^ );
      WRITELN( lst_file );
      if lst_sbttl <> nil then
      begin
        WRITELN( lst_file );
        WRITELN( lst_file, lst_sbttl^ );
        lst_lncnt := lst_lncnt + 2
      end;
      WRITELN( lst_file );                     { Keep always an empty line after the page heading }
      lst_lncnt := lst_lncnt + 3               { For heading line, title line, and spacing line }
    end
  end
end LST_NEWLINE;



[global]
procedure LST_EOLN;
{ End a line and output it }
{ To output a line of listing as given in lst_outline }
begin { LST_EOLN }
  LST_NEWLINE;
  with lst_current^, lst_currline^ do
  begin
    if lstf_virtual in lst_flagsw then
    begin                                      { Virtual (in memory) output file }
      VLS_NEXTSTRING;                          { Open the new string in the list }
      lst_flagsw := lst_flagsw - [lstf_break]
    end
    else
    begin                                      { True output file }
      if length > 0 then
      begin
        WRITE( lst_file, lst_currline^ );
        length := 0
      end;
      if lstf_break in lst_flagsw then lst_flagsw := lst_flagsw - [lstf_break]
                                  else WRITELN( lst_file )
    end;
    while length < lst_lm do
    begin
      length := length + 1;
      body[length] := ' '
    end
  end
end LST_EOLN;



[global]
procedure LST_BREAKOUTPUT;
{ Procedure to force the buffer output }
begin
  with lst_current^ do
  begin
    lst_flagsw := lst_flagsw + [lstf_break];
    LST_EOLN
  end
end LST_BREAKOUTPUT;



[global]
procedure LST_PAGE;
begin
  LST_EOLN;
  with lst_current^ do
    if lst_pgsize >= 10 then lst_lncnt := lst_pgsize    { Force a future page skip }
    else
      if not (lstf_virtual in lst_flagsw) then PAGE( lst_file )
end LST_PAGE;



[global]
procedure LST_SET_COLUMN( col: integer );
begin { LST_SET_COLUMN }
  with lst_current^, lst_currline^ do
    if col > lst_rm then
      LST_EOLN                                 { Too large column number }
    else                                       { ... else it is possible }
    begin
      col := col - 1;
      if length > col then LST_EOLN;           { Line overun }
      while length < col do                    { ... fill the current line up to the column }
      begin
        length := length + 1;
        body[length] := ' '
      end
    end
end LST_SET_COLUMN;



[global]
procedure LST_SET_MARGIN( lm, rm: integer );
var
  old_lm: integer;

begin { LST_SET_MARGIN }
  with lst_current^, lst_currline^ do
  if (lm >= 0) and (rm > lm) and (rm <= lst_lnsize) then
  begin
    old_lm := lst_lm;
    lst_lm := lm;                              { Set the left margin }
    lst_rm := rm;                              { Set the right margin }
    if length > old_lm then                    { If the current line is not empty }
      LST_EOLN                                 { ... then output it }
    else                                       { ... else }
      while length < lm do                     { ... fill the current line up to left margin }
      begin
        length := length + 1;
        body[length] := ' '
      end
  end
end LST_SET_MARGIN;



[global]
procedure LST_SKIP_LINE( nli: integer );
begin { LST_SKIP_LINE }
  if lst_current^.lst_pgsize < 0 then
    WRITELN( '\SKIPLINE ', nli:0 )
  else
    while nli > 0 do
    begin
      LST_EOLN; nli := nli - 1
    end
end LST_SKIP_LINE;



[global]
procedure LST_CHANGE_HEADING( in_var str: string );
begin
  with lst_current^ do
  begin
    STR_COPY_LIM( lst_heading, str, lst_maxheading );
    if lst_pgsize < 0 then
    begin
      WRITELN( lst_file, '\HEADING ', lst_heading^.length:0, ' ', lst_heading );
      WRITELN( lst_file )
    end
  end
end  LST_CHANGE_HEADING;



[global]
procedure LST_CHANGE_TITLE( in_var str: string );
begin
  with lst_current^ do
  begin
    STR_COPY_LIM( lst_title, str, lst_lnsize - 1 );
    if lst_pgsize < 0 then
    begin
      WRITELN( lst_file, '\TITLE ', lst_title^.length:0, ' ', lst_title );
      WRITELN( lst_file )
    end
  end
end  LST_CHANGE_TITLE;



[global]
procedure LST_CHANGE_SUBTITLE( in_var str: string );
begin
  with lst_current^ do
  begin
    STR_COPY_LIM( lst_sbttl, str, lst_lnsize - 1 );
    if lst_pgsize < 0 then
    begin
      WRITELN( lst_file, '\SUBTITLE ', lst_sbttl^.length:0, ' ', lst_sbttl );
      WRITELN( lst_file )
    end
  end
end  LST_CHANGE_SUBTITLE;



[global]
procedure LST_SET_CHAR_ATTR( in_var sattr: string );
var
  attr:    array[1..3] of char;
  bool:                boolean;

begin
  with lst_current^ do
  if lst_pgsize < 0 then
  begin
    bool :=  true;
    attr := 'NNN';
    for i := 1 to sattr.length do
      case sattr[i] of
        '+': bool := true;

        '-': bool := false;

        'B', 'b',
        'G', 'g': if bool then attr[1] := 'B'
                          else attr[1] := 'N';

        'I', 'i': if bool then attr[2] := 'I'
                          else attr[2] := 'N';

        'U', 'u',
        'S', 's': if bool then attr[3] := 'S'
                          else attr[3] := 'N';

        'N', 'n': begin  bool := true; attr := 'NNN'  end;

      otherwise
      end;
      WRITELN( '\CHAR_ATTR ', sattr )
  end
end LST_SET_CHAR_ATTR;



[global]
procedure LST_TEST_LINE( iskip, tstli: integer );
begin { LST_SKIP_LINE }
  with lst_current^ do
    if lst_pgsize > 10 then
    begin
      if tstli > lst_pgsize div 2 then tstli := lst_pgsize div 2;
      if iskip > tstli then iskip := tstli;
      if lst_pgsize - lst_lncnt >= tstli then LST_SKIP_LINE( iskip )
                                         else lst_lncnt := lst_pgsize + 1
    end
    else
      if lst_pgsize < 0 then WRITELN( lst_file, '\TEST_LINE ', iskip:0, ' ', tstli:0 )
end LST_TEST_LINE;



[global]
procedure LST_PUT_CHAR( ch: char );
var
 i: integer;

begin { LST_PUT_CHAR }
  with lst_current^, lst_currline^ do
  begin
    if length >= lst_rm then LST_EOLN;         { Auto Wrap }
    length := length + 1; body[length] := ch
  end
end LST_PUT_CHAR;



[global]
procedure LST_PUT_MCHAR( ch: char; m: integer );
begin
  with lst_current^ do
  begin
    if m > 0 then
      while m > 0 do
      begin
        LST_PUT_CHAR( ch );
        m := m - 1
      end
    else
      with lst_currline^ do
      begin
        m :=  -m - 1;
        if m >= capacity then m := 0;
        if length > m  then LST_EOLN;
        while length < m do
        begin
          length := length + 1;
          body[length] := ch
        end
     end
  end
end LST_PUT_MCHAR;



[global]
procedure LST_PUT_STRING( var str: string );
{ Output a string with given left margin }
{ If the line is too long then wrap the line }
var
  isz: integer;

begin { LST_PUT_STRING }
  with lst_current^, lst_currline^ do
  if str.length > 0 then
  begin
    isz := lst_rm - lst_lm;                    { Get the size of an emty line }
    { The current line match in an empty line }
    if isz >= str.length then
    begin
      { This line cannot match in the current line (not empty) }
      if lst_rm - length < str.length then
        LST_EOLN;                              { Then skip to next line }
      for isz := 1 to str.length do
      LST_PUT_CHAR( str.body[isz] )
    end
    else
      for isz := 1 to str.length do
        LST_PUT_CHAR( str.body[isz] )
  end
end LST_PUT_STRING;



[global]
procedure LST_PUT_INT( int, size: integer; base: integer := 0 );
var
  buf: string( 34 );

begin { LST_PUT_INT }
  with lst_current^, lst_currline^ do
  begin
    if lst_rm - length < ABS( size ) then LST_EOLN;
    WRITEV( buf, int:size:base );
    LST_PUT_STRING( buf )
  end { with }
end LST_PUT_INT;



[global]
procedure LST_PUT_FLOAT( dv: double; fs, dcsz, es: integer );
var
  buf: string( 32 );

begin { LST_PUT_FLOAT }
  with lst_current^, lst_currline^ do
  begin
    if lst_rm - length < fs then LST_EOLN;
    WRITEV( buf, dv:fs:dcsz:es );
    LST_PUT_STRING( buf )
  end { with }     
end LST_PUT_FLOAT;



[global]
procedure LST_PUT_FIXED( dv: double; fs, dcsz, dcmin: integer );
var
  buf: string( 32 );

begin { LST_PUT_FIXED }
  with lst_current^, lst_currline^ do
  begin
    if lst_rm - length < fs then LST_EOLN;
    WRITEV( buf, dv:fs:dcsz:dcmin );
    LST_PUT_STRING( buf )
  end { with }
end LST_PUT_FIXED;




{********************************************************}
{**********   common initialization routine   ***********}
{********************************************************}


[global]
procedure LST_G_INIT( var def_lst, def_heading: [readonly] string := '';
                      var ierr: integer );
{ Listing file initialization routine }
begin { LST_G_INIT }
  { set to empty all list headers }
  lst_hde     := nil;    { to init basic_lst_allocation list }
  lst_current := nil     { force the new listing creation };
  { Open the default listing file }
  LST_OPEN( lst_current, def_lst, def_heading,,,       { No title, no sub-title }
            132                                        { Line printer compatible },
            -1                                         { Automatic mode if a file, or ...
                                                          0 (no page handling) if terminal },
            false                                      { New version mode },
            false                                      { No print on close },
            false                                      { No append },
            ierr                                       { Error return } )
end LST_G_INIT;

end.