







































































































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