{ TBL--writes arbitrary blocks of memory to an object file

  John Fritz 
  MCV Academic Computing
  Medical College of Virignia
  Box 16, MCV Station
  Richmond, VA   23298
  (804) 786-9843
  }

{@+ .doc
This set of routines allows you to write a data from memory to an object
file. In situations where a system needs to reference a data structure that
is small enough to be kept entirely in memory and that changes infrequently,
it is often useful to write one program that builds the data structure
and writes it out to an object file, which is then linked into the program
that references the structure.

The simplest use of the routines is to write a single data structure to
a single psect. For example, you could write the variable Table to the file 
TABLE.OBJ by:

   TBL_open_table(context,'TABLE');
   TBL_define_symbol(context,'TABLE');
   TBL_store_data(context,Table,size(Table));
   TBL_close_table(context);
                                                 
You can, however:

   supply additional information to TBL_open_table, such as
      a version number, a creator name, and a filename different from the
      module name;

   switch psects with TBL_set_psect (psects are identified by numbers, from 0 to
      255); 

   put more than one variable in a psect with repeated calls to
      TBL_define_symbol and TBL_store_data; 

   make sure that variables are properly aligned with TBL_align_counter; 

   set a psect to be readonly, writeable, FORTRAN COMMON, or
      some unorthodox combination of flags, and set a psect's name with
      tbl_set_psect_info.

The TBL routines operate on contexts, which are pointers to object files
variables and a collection of information about the file. TBL keeps track
of the current psect, and for each psect, its current relocation counter,
the maximum alignment requested for it, its flags, and its name.

The current psect after you call TBL_open_table is psect 0; it (and any
other psect you reference) has the following values:

   Relocation counter:	0;
			The relocation counter starts at zero, and is
			incremented when you call TBL_store_data. A separate
			relocation counter is kept for each psect. The current
			value of the relocation counter is used as the value 
			of the symbol defined when you call TBL_define_symbol.

   Maximum alignment:	no alignment requested 
			If you never call TBL_align_counter for that psect,
			the linker will be asked to align the psect itself
			on a longword boundary; otherwise it will be aligned 
			on the largest boundary requested.

   Flags:		TBL_readonly
			This is a combination of flags which compilers use
			for code and constant data. You can also specify
			flag values of TBL_writable for static writeable
			data and TBL_common for data in FORTRAN COMMON.
			You can also roll your own flag values by using
			the GPS$M_xxx constant definitions in STARLET.
			
   Name:		No name specified.
			If you do not explicitly set a name, TBL will pick
			a name based on the value of the flags: $CODE for
			TBL_readonly, $LOCAL for TBL_writeable, and $BLANK
			for TBL_common. If you roll your own flags, you
			will be much better off if you make up your own
			name; otherwise TBL will make up a name which is
			unintelligible, dependant on the value of the flags
			and the psect's alignment. 


{@- .doc}               

{@+ .msg
.FACILITY TBL, TBL$_FACILITY/PREFIX=TBL__
.TITLE TBLMSG
.SEVERITY FATAL
psectNumber/FATAL    "Psect number must be between 0 and 255"
recordSize/WARNING   "Maximum record size must be between 64 and 2048"
alignment/WARNING    "Alignment must be between 0 and 9"
statusNumber/WARNING "Status number must be between 0 and 255"
moduleTrunc/WARNING  "Module name truncated"
versionTrunc/WARNING "Version name truncated"
creatorTrunc/WARNING "Creator name truncated"
psecTrunc/WARNING    "Psect name truncated"
symbolTrunc/ERROR    "Symbol name truncated"
.END

{@- .msg}
{@+ .pas}
[inherit('sys$library:starlet','mcv:rtl','tblmsg'),check(all)]
module TBL;

{@+ .def}

[hidden] const
   maxModule = 31;
   maxVersion = 31;
   maxSymbol = 31;
   maxPsect = 255;
   tir = chr(OBJ$C_TIR);
                                    
[hidden] type
   uWord = [word] 0..2**16-1;
   twoBytes = packed array[1..2] of char;
   fourBytes = packed array[1..4] of char;
   psectPointer = ^psectContext;
   psectContext = record
      current: integer;
      alignment: integer;
      pflags: uWord;
      pName: varying[maxSymbol] of char;
      end;
   context = record
      psect: array[0..maxPsect] of psectPointer;
      currentPsect: integer;
      recSize: integer;
      f: text;
      end;
type
   TBL_context = @context;

const
   TBL_readOnly  = GPS$M_PIC+GPS$M_REL+GPS$M_RD+GPS$M_SHR+GPS$M_EXE;
   TBL_writeable = GPS$M_PIC+GPS$M_REL+GPS$M_RD+GPS$M_WRT;
   TBL_common    = TBL_writeable+GPS$M_OVR;

[hidden]
const
   newPsect = psectContext(
      0,		{Relocation counter starts at 0}
     -1,		{No alignment requested}
      TBL_readOnly,	{Psect is readonly by default}
      '');		{No psect name}

{@+  .doc .def}

[global]
procedure TBL_set_psect(
   context: TBL_context;
   ps: integer);

{Sets the relocation counter to the current location in psect ps}
{@- .doc .def}
begin with context^ do begin
   if not((0 <= ps) and (ps <= maxPsect)) then lib$stop(TBL__psectNumber);
   if psect[ps] = nil then begin new(psect[ps]); psect[ps]^ := newPsect end;
   with psect[ps]^ do begin
      if currentPsect <> ps then begin
         currentPsect := ps;
         {Set the relocation counter}
            writeln(f,
               tir+chr(TIR$C_STA_PL)+chr(ps)+current::fourBytes+
               chr(TIR$C_CTL_SETRB));
         end;
      end;
   end end;

{@+ .doc .def}

[hidden]
const
   defaultVersion = '01';
   defaultCreator = 'Table Writer V1.1, MCV/VCU';
   defaultRecSize = 512;

[global] 
procedure TBL_open_table(
    var context:    TBL_context;
           {pointer to context information}
        moduleName: [class_s] packed array[m1..mN: integer] of char;
           {module name string for object file header record}
        version:    [class_s,truncate] packed array[v1..vN: integer] of char;
           {Version string for object file header record}
           {default: defaultVersion}
        creator:    [class_s,truncate] packed array[c1..cN: integer] of char;
           {Creator name string for object file header record}
           {default: defaultCreator}
        fileName:   [class_s,truncate] packed array[f1..fN: integer] of char;
           {Name of object file}
           {default: moduleName+'OBJ'}
        inRecSize:  [truncate] integer);
           {Maximum object file reocrd size}
           {default: defaultRecSize}

{Opens an object file and writes the header records;
 Sets the relocation counter to psect 0, byte 0}
{@- .doc .def}

type
   dateType = packed array[1..17] of char;
const
   minRecSize = 64;
   lastPatch = dateType(repeat chr(0));
var
   date: dateType;
   i: integer;
begin
   new(context);
   with context^ do begin
      {calculate record size}
         if not present(inRecSize) then recSize := defaultRecSize
         else begin
            if inRecSize < minRecSize then begin
               lib$signal(TBL__recordSize);
               recSize := minRecSize
               end
            else if inRecSize > OBJ$C_MAXRECSIZ then begin
               lib$signal(TBL__recordSize);
               recSize := OBJ$C_MAXRECSIZ;
               end
            else recSize := inRecSize;
            end;
      {open the object file}
         if present(fileName) then
            open(f,fileName,default:=moduleName+'.obj',
                   record_length:=recSize,history:=new)
         else open(f,moduleName+'.obj',record_length:=recSize,history:=new);
         rewrite(f);
      {Write module header record}
         $asctim(,date);
         if mN > maxModule then lib$signal(TBL__moduleTrunc);
         str$upCase(moduleName,moduleName);
         write(f,
            chr(OBJ$C_HDR)+chr(MHD$C_MHD)+chr(OBJ$C_STRLVL)+
            chr(recSize mod 256)+chr(recSize div 256)+
            chr(mN)+substr(moduleName,1,min(mN,maxModule)));
         if not present(version) then 
            write(f,chr(length(defaultVersion))+defaultVersion)
         else begin
            if vN > maxVersion then lib$signal(TBL__versionTrunc);
            write(f,chr(vN)+substr(version,1,min(maxVersion,vN)));
            end;
         writeln(f,date+lastPatch);
      {Write language processor name}
         if not present(creator) then
            writeln(f,chr(OBJ$C_HDR)+chr(MHD$C_LNM)+defaultCreator)
         else begin
            if cN > recSize-2 then lib$signal(TBL__creatorTrunc);
            writeln(f,chr(OBJ$C_HDR)+chr(MHD$C_LNM)+
               substr(creator,1,min(cN,recSize-2)))
            end;
      {Set all psect pointers to nil}
         for i := 0 to maxPsect do psect[i] := nil;
      {Set current psect to 0}
         currentPsect := -1; TBL_set_psect(context,0);
      end;
   end; {openObject}

{@+ .doc .def}

[hidden]
const
   minAlign = 0;
   maxAlign = 9;

[global]
procedure TBL_align_counter(
   context: TBL_context;
   align: integer);

{Sets the relocation counter to the least number greater than or equal to
 its present value that is evenly divisible by 2**align.
 Saves the maximum requested alignment for each psect. The alignment
 specified for the psect as whole will be this maximum alignment; if
 no alignment adjustment is requested for a psect, the alignment specified
 will be 2 (i.e. the psect will begin on an address divisible by 4}
{@- .doc .def}

var
   target,pad: integer;
   exp2: [static,readonly] array[minAlign..maxAlign] of integer
      := (1,2,4,8,16,32,64,128,256,512);
begin with context^ do begin
   with psect[currentPsect]^ do begin
      if not((minAlign <= align) and (align <= maxAlign)) then begin
         lib$signal(TBL__alignment);
         if align < minAlign then align := minAlign
         else if maxAlign < align then align := maxAlign
         end;
      if alignment < align then alignment := align;
      target := exp2[align];
      pad := (current+target-1) div target * target - current;
      if pad <> 0 then begin {Adjust the relocation counter}
         writeln(f,tir+chr(TIR$C_CTL_AUGRB)+pad::fourBytes);
         current := current+pad;
         end;
      end;
   end end;

{@+ .doc .def}

[global]
procedure TBL_define_symbol(
   context:   TBL_context;
   gloSym:     [class_s] packed array[s0..sN: integer] of char);

{Defines the global symbol gloSym as a relocatable symobl with a
 value corresonding to the relocation counter for the current psect}
{@- .doc .def}

const
   flg = GSY$M_DEF+GSY$M_REL;	{relocatable definition}
var
   gsy_flags: [static,readonly] packed array[1..2] of char :=
      chr(flg mod 256)+chr(flg div 256);
begin with context^ do begin
   if sN > maxSymbol then lib$signal(TBL__symbolTrunc)
   else with psect[currentPsect]^ do begin
      str$upcase(gloSym,gloSym);
      writeln(f,
         chr(OBJ$C_GSD)+			{global symbol dictionary}
         chr(GSD$C_SYM)+			{global symbol specification}
            chr(0)+				{unknown data type}
            gsy_flags +				{relocatable definition}
            chr(currentPsect)+			{current psect}
            current::fourBytes+			{current offset from psect base}
            chr(sN)+gloSym);			{name of symbol}
      end;
   end end;

{@+ .doc .def}

[external]                                      
procedure TBL_store_data(
        context: TBL_context;
   %ref data:     [unsafe,readonly] packed array[lo..hi: integer] of char;
        dataSize: integer);

{Writes dataSize bytes from data to the object file, breaking data up
 into as many TIR records as necessary. The data will start at the point
 of the current relocation counter, and the relocation counter will be
 increased by dataSize}
{@- .doc .def}
   extern;   

[hidden,global(TBL_store_data)]
procedure tbl_store_data_x(
        context:  TBL_context;
   var  data:     [readonly,volatile] char;
        dataSize: integer);
type
   fake = packed array[1..OBJ$C_MAXRECSIZ] of char;
   chars = ^fake;
const
   maxTir = 128;
var
   recLen,gulp,next,limit: integer;
   store: [byte] -maxTir..maxTir-1;
begin with context^ do if dataSize > 0 then begin
   {write out the data's bytes}
      write(f,tir); recLen := 1;
      next := iaddress(data);
      limit := next+dataSize;
      repeat
         gulp := min(recSize-1-reclen,limit-next,maxTir);
         if gulp <= 0 then begin
            writeln(f); write(f,tir); recLen := 1;
            gulp := min(recSize-1-reclen,limit-next,maxTir);
            end;
         store := -gulp;
         write(f,store::char,substr(next::chars^,1,gulp));
         next := next+gulp;
         recLen := recLen+gulp+1;
         until next = limit;
      writeln(f);
   with psect[currentPsect]^ do current := current+dataSize;
   end end;

{@+ .doc .def}

[global]
procedure TBL_set_psect_info(
   context:   TBL_context;
   flags:     uword;
   name:      [class_s,truncate] packed array[n0..nN: integer] of char);

{Sets the psect flags (and psect name, if supplied) for the current psect}

{The most common flags combinations are supplied as the constants
 TBL_readOnly, TBL_writeable, and TBL_common.
 The default name for a psect depends on its flags. If the flags are equal
 to TBL_readOnly then the default pname is '$CODE'; if TBL_writeable then 
 '$LOCAL'; and if TBL_common then '$BLANK'. If an unorthodox flag combination
 is used and a psect name is not supplied, then an arbitrary name dependant
 on the flags and the psect alignment will be used.}
{@- .doc .def} 

begin with context^,psect[currentPsect]^ do begin
   pflags := flags;
   if present(name) then begin
      if nN > maxSymbol then lib$signal(TBL__psecTrunc);
      str$upcase(name,name);
      pName := substr(name,1,min(nN,maxSymbol));
      end;
   end end;

{@+ .doc .def}

const
   TBL_success = 0;
   TBL_warning = 1;
   TBL_error = 2;
   TBL_abort = 3;

[global]
procedure TBL_close_table(
   context: TBL_context;
   error: [truncate] integer);

{Closes the object file.
 If error is not supplied it defaults to TBL_success; the values
 TBL_warning, TBL_error, and TBL_abort can be used to indicate a
 'compile' time error to the linker, which will issue an appropriate
 message and in the case of TBL_error will refuse to create the executable
 file, and in the case of TBL_abort, will abort the link operation
 without reading any other object files}
{@- .doc .def}

var
   lim,err,i: integer;
begin with context^ do begin
   lim := maxPsect+1; repeat lim := lim-1 until psect[lim] <> nil;
   for i := 0 to lim do begin
      if psect[i] = nil then writeln(f,''(
         OBJ$C_GSD,			{global symbol dictionary}
         GSD$C_PSC,			{psect definition}
         0,	                	{alignment}
         0,0,				{psect flags}
         0,0,0,0,			{allocation}
         8)'. NONE .')			{psect name}
      else with psect[i]^ do begin
         if alignment < 0 then alignment := 2;
         write(f,                       
            chr(OBJ$C_GSD)+		{global symbol dictionary}
            chr(GSD$C_PSC)+		{psect definition}
            chr(alignment)+		{alignment}
            pflags::twoBytes+		{psect flags}
            current::fourBytes);	{allocation}
         if pname.length = 0 then begin
            if pflags = TBL_readOnly then pname := '$CODE'
            else if pflags = TBL_writeable then pname := '$LOCAL'
            else if pflags = TBL_common then pname := '$BLANK'
            else pname := '_TBL_'+hex(pflags,4,4)+chr(ord('0')+alignment);
            end;
         writeln(f,chr(pname.length),pname);
         end;
      end;
   if not present(error) then err := 0
   else begin
      err := error;
      if not((0 <= err) and (err <= 255)) then begin
         lib$signal(TBL__statusNumber);
         err := TBL_warning
         end;
      end;
   writeln(f,chr(OBJ$C_EOM)+chr(err));
   end end;

end.
{@- .pas}
