RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page    1
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (1)

-LINE-IDC-PL-SL-

00001   C  0  0 (*  CMS:  DEC/CMS REPLACEMENT HISTORY, Element RCS_ROUTINES.PAS  *)
00002   C  0  0 (*  CMS:  *5     3-DEC-1991 13:21:11 PAYNE "Removed invalid source lines, (AGAIN)!"  *)
00003   C  0  0 (*  CMS:  *4    26-JUL-1991 12:45:11 SYSTEM "Removed bad source lines and recompiled."  *)
00004   C  0  0 (*  CMS:  *3     4-MAY-1990 14:59:10 PAYNE "List file created."  *)
00005   C  0  0 (*  CMS:  *2    26-MAR-1990 07:38:30 PAYNE "testing completed."  *)
00006   C  0  0 (*  CMS:  *1    15-MAR-1990 15:58:22 PAYNE "RCS utility functions."  *)
00007   C  0  0 (*  CMS:  DEC/CMS REPLACEMENT HISTORY, Element RCS_ROUTINES.PAS  *)
00008      0  0 [ environment ( 'RCS_Routines' ),
00009      0  0   ident ( '1-002' ),
00010      0  0   inherit(
00011      0  0     'Sys$Library:STARLET',
00012      0  0     'Sys$Library:RCS_RTL' )
00013      0  0   ]
00014      0  0 
00015      0  0 
00016      0  0 
00017      0  0 module RCS_Routines ( output );
00018      0  0 
00019      0  0 
00020      0  0 
00021   C  0  0 (*  Title:       General Purpose Utility Routines.
00022   C  0  0 
00023   C  0  0     Version:     1-002
00024   C  0  0 
00025   C  0  0     Facility:    VAX Pascal Support
00026   C  0  0 
00027   C  0  0     Abstract:    Declarations of convenient utility procedures, including
00028   C  0  0                  appropriate   constant   and   type   declarations.
00029   C  0  0 
00030   C  0  0     Environment: VAX Pascal, V3.9 or later.
00031   C  0  0                  VAX/VMS V5.3, or later.
00032   C  0  0                  NB: Some symbols are operating system dependent.  This module
00033   C  0  0                      may require recompilation or alteration whenever VAX/VMS
00034   C  0  0                      changes.  Programs referring to this environment must be
00035   C  0  0                      linked with Sys$System:SYS.STB, and may need to be relinked
00036   C  0  0                      whenever VAX/VMS changes.
00037   C  0  0                  User mode, nonprivileged code.
00038   C  0  0 
00039   C  0  0     Author:      Seth Stern, 26-Feb-1990
00040   C  0  0 
00041   C  0  0     Modified by:
00042   C  0  0 
00043   C  0  0       1-001  26-Feb-1990  Seth Stern
00044   C  0  0              Original.  Based on RRC.PAS V1-020.
00045   C  0  0 
00046   C  0  0       1-002  01-Mar-1990  Jeffrey Payne
00047   C  0  0              Added RCS_Get_VM_With_Descriptor and RCS_Free_VM_With_Descriptor
00048   C  0  0              to provide a structure containing a class-s descriptor which
00049   C  0  0              describes virtual address space from Lib$Get_VM.
00050   C  0  0   *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page    2
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (2)

-LINE-IDC-PL-SL-

00052      0  0 const
00053      0  0 
00054   C  0  0   (*  The following constants are used with the comparison routines.  *)
00055      0  0 
00056      0  0   RCS_K_Str_Less    = -1;
00057      0  0   RCS_K_Str_Equal   =  0;
00058      0  0   RCS_K_Str_Greater =  1;
00059      0  0 
00060      0  0 
00061      0  0 
00062   C  0  0 (*  The following declarations are based on modules extracted from
00063   C  0  0   Sys$Library:LIB.MLB for VAX/VMS V4.2.
00064   C  0  0   $IHDDEF, $IHADEF, $IHSDEF, $IFDDEF.
00065   C  0  0   *)
00066      0  0 
00067   C  0  0 (*  Memory is used as follows:
00068   C  0  0 
00069   C  0  0   CTL$GL_ImgHdrBf: MMG$ImgHdrBuf
00070   C  0  0 
00071   C  0  0   MMG$ImgHdrBuf:   IHD_Address
00072   C  0  0   MMG$ImgHdrBuf+4: IFD_Address
00073   C  0  0   MMG$ImgHdrBuf+8: <unused>
00074   C  0  0   Followed by the IHD, IHA, IHS, IHI, IHP, IFD and image file
00075   C  0  0     specification, as applicable.
00076   C  0  0 
00077   C  0  0   CTL$GL_ImgHdrBf   and   MMG$ImgHdrBuf   are defined in Sys$System:SYS.STB.
00078   C  0  0   *)
00079      0  0 
00080      0  0 type
00081      0  0   IHD$_LnkFlags = ( IHD$V_LnkDebug, IHD$V_LnkNoTfr, IHD$V_NoP0Bufs,
00082      0  0     IHD$V_PICImg, IHD$V_P0Image, IHD$V_DbgDmt, IHD$V_IniShr,
00083      0  0     IHD$V_Bit_7, IHD$V_Bit_8, IHD$V_Bit_9,
00084      0  0     IHD$V_Bit_10, IHD$V_Bit_11, IHD$V_Bit_12, IHD$V_Bit_13, IHD$V_Bit_14,
00085      0  0     IHD$V_Bit_15, IHD$V_Bit_16, IHD$V_Bit_17, IHD$V_Bit_18, IHD$V_Bit_19,
00086      0  0     IHD$V_Bit_20, IHD$V_Bit_21, IHD$V_Bit_22, IHD$V_Bit_23, IHD$V_Bit_24,
00087      0  0     IHD$V_Bit_25, IHD$V_Bit_26, IHD$V_Bit_27, IHD$V_Bit_28, IHD$V_Bit_29,
00088      0  0     IHD$V_Bit_30, IHD$V_Bit_31 );
00089      0  0 
00090      0  0   IHD$_Record = packed record
00091   C  0  0     (*  Image header descriptor.  *)
00092      0  0     IHD$W_Size      : uword;
00093      0  0     IHD$W_ActivOff  : uword;
00094      0  0     IHD$W_SymDbgOff : uword;
00095      0  0     IHD$W_ImgIdOff  : uword;
00096      0  0     IHD$W_PatchOff  : uword;
00097      0  0     IHD$W_Spare_1   : uword;
00098      0  0     IHD$W_MajorId   : packed array [ 1 .. 2 ] of char;
00099      0  0     IHD$W_MinorId   : packed array [ 1 .. 2 ] of char;
00100      0  0     IHD$B_HdrBlkCnt : ubyte;
00101      0  0     IHD$B_ImgType   : ubyte;
00102      0  0     IHD$W_Spare_2   : uword;
00103      0  0     IHD$Q_PrivReqs  : quadword;
00104      0  0     IHD$W_IOChanCnt : uword;
00105      0  0     IHD$W_ImgIOCnt  : uword;
00106      0  0     IHD$L_LnkFlags  : set of ihd$_lnkflags;

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page    3
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (2)

-LINE-IDC-PL-SL-

00107      0  0     IHD$L_Ident     : unsigned;
00108      0  0     IHD$L_SysVer    : packed array [ 1 .. 4 ] of char;
00109      0  0     IHD$L_IAFVA     : unsigned;
00110      0  0     end;  (*  IHD$_Record  *)
00111      0  0 
00112      0  0   IHD$_Pointer = ^IHD$_Record;
00113      0  0 
00114      0  0   IHA$_Record = packed record
00115   C  0  0     (*  Image header transfer address array.  *)
00116   C  0  0     (*  Order: debugger (if any), initialization (if any), user image.  *)
00117      0  0     IHA$L_TfrAdr1 : unsigned;
00118      0  0     IHA$L_TfrAdr2 : unsigned;
00119      0  0     IHA$L_TfrAdr3 : unsigned;
00120      0  0     IHA$L_TfrAdr4 : unsigned   (*  Always 0.  *)
00121      0  0     end;  (*  IHA$_Record  *)
00122      0  0 
00123      0  0   IHA$_Pointer = ^IHA$_Record;
00124      0  0 
00125      0  0   IHS$_Record = packed record
00126   C  0  0     (*  Image header symbol table and debug section.  *)
00127      0  0     IHS$L_DSTVBN : unsigned;
00128      0  0     IHS$L_GSTVBN : unsigned;
00129      0  0     IHS$W_DSTBlks : uword;
00130      0  0     IHS$W_GSTRecs : uword
00131      0  0     end;  (*  IHS$_Record  *)
00132      0  0 
00133      0  0   IHS$_Pointer = ^IHS$_Record;
00134      0  0 
00135      0  0   IHI$_Record = packed record
00136   C  0  0     (*  Image header identification section.  *)
00137      0  0     IHI$T_ImgNam   : packed array [ 1 .. 40 ] of char;  (*  ASCIC.  *)
00138      0  0     IHI$T_ImgId    : packed array [ 1 .. 16 ] of char;  (*  ASCIC.  *)
00139      0  0     IHI$Q_LinkTime : quadword;
00140      0  0     IHI$T_LinkId   : packed array [ 1 .. 16 ] of char  (*  ASCIC.  *)
00141      0  0     end;  (*  IHI$Record  *)
00142      0  0 
00143      0  0   IHI$_Pointer = ^IHI$_Record;
00144      0  0 
00145      0  0   IFD$_Record = packed record
00146   C  0  0     (*  Image file descriptor block.  *)
00147      0  0     IFD$W_Size      : uword;
00148      0  0     IFD$W_FilNamOff : uword;
00149      0  0     IFD$W_Spare_1   : uword;
00150      0  0     IFD$W_Spare_2   : uword;
00151      0  0     IFD$W_Chan      : uword;
00152      0  0     IFD$W_CMChan    : uword;
00153      0  0     IFD$L_CMKFIADR  : unsigned;
00154      0  0     IFD$L_Flags     : unsigned;
00155      0  0     IFD$Q_CurProg   : quadword  (*  Descriptor.  *)
00156      0  0     end;  (*  IFD$_Record  *)
00157      0  0 
00158      0  0   IFD$_Pointer = ^IFD$_Record;
00159      0  0 
00160      0  0 const
00161   C  0  0   (*  Major and minor identifications for this image header format.  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page    4
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (2)

-LINE-IDC-PL-SL-

00162      0  0   IHD$K_MajorId = '02';
00163      0  0   IHD$K_MinorId = '05';
00164   C  0  0   (*  First and last values in   IHD$L_LnkFlags .  *)
00165      0  0   IHD$V_First_Bit = IHD$V_LnkDebug;
00166      0  0   IHD$V_Last_Bit  = IHD$V_Bit_31;
00167   C  0  0   (*  Values for   IHD$B_ImgType .  *)
00168      0  0   IHD$K_Exe = 1;
00169      0  0   IHD$K_LIM = 2;

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page    5
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (3)

-LINE-IDC-PL-SL-

00171      1  0 [global] function RCS_GetJPI_Numeric(
00172      1  0   Item_Code : unsigned
00173      1  0   ) : unsigned;
00174      0  0   forward;
00175      0  0 
00176      1  0 [global] function RCS_Trim(
00177      1  0   Data : varying[ u1 ] of char
00178      1  0   ) : varying_string;
00179      0  0   forward;
00180      0  0 
00181      1  0 [global] function RCS_Trim_Leading(
00182      1  0   Data : varying [ u1 ] of char
00183      1  0   ) : varying_string;
00184      0  0   forward;
00185      0  0 

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page    6
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (4)

-LINE-IDC-PL-SL-

00187      1  0 [global] function RCS_ASCII_To_Id( Id : varying_string ) : unsigned;
00188      1  0 
00189   C  1  0   (*  Returns the longword value for the specified identifier.
00190   C  1  0     If no identifier is found then zero is returned.  Other errors are
00191   C  1  0     signalled.  *)
00192      1  0 
00193      1  0   var
00194      1  0     Status : integer;
00195      1  0     Value : unsigned;
00196      1  0 
00197      1  1   begin  (*  RCS_ASCII_To_Id  *)
00198      1  1 
00199      1  1     Status := $asctoid( name := Id, id := Value );
00200      1  1     if Status = ss$_normal then
00201      1  1       RCS_ASCII_To_Id := Value
00202      1  1     else if Status = ss$_nosuchid then
00203      1  1       RCS_ASCII_To_Id := 0
00204      1  1     else
00205      1  1       lib$signal( Status )
00206      1  1 
00207      0  0   end;  (*  RCS_ASCII_To_Id  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page    7
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (5)

-LINE-IDC-PL-SL-

00209      1  0 [ global ] procedure RCS_Display_Image_List;
00210      1  0 
00211   C  1  0   (*  Display a list of all of the images that the image activator has
00212   C  1  0     processed.  *)
00213      1  0 
00214   C  1  0   (*?  Add list of change mode dispatchers.  ?*)
00215      1  0 
00216   C  1  0   (*  Private Image Control Block (ICB) definitions.  *)
00217      1  0 
00218      1  0   const
00219      1  0 
00220   C  1  0     (*  ICB$B_Act_Mode values.  *)
00221      1  0     ICB$K_Main_Program = 1;	(*  Object of RUN command.  *)
00222      1  0     ICB$K_Merged_Image = 2;	(*  Additional image mapped.  *)
00223      1  0     ICB$K_Global_Image_Section = 3;(*  Image described by global ISD.  *)
00224      1  0 
00225   C  1  0     (*  ICB$L_Flags bits.  *)
00226      1  0     ICB$M_ExpReg = 1;		(*  Image mapped at end of address space.  *)
00227      1  0     ICB$M_Shareable = 2;		(*  Image installed /SHAREABLE.  *)
00228      1  0     ICB$M_Open_For_Write = 4;	(*  Image will be opened for write.  *)
00229      1  0     ICB$M_Res_Header = 8;		(*  Image header already decoded.  *)
00230      1  0     ICB$M_Load_Image = 16;	(*  Load image from sequential device.  *)
00231      1  0     ICB$M_Initialize = 32;	(*  Image contains initialization code.  *)
00232      1  0     ICB$M_Done = 64;		(*  Image is completely activated.  *)
00233      1  0     ICB$M_Sys_STB = 128;		(*  Image is linked against SYS.STB.  *)
00234      1  0     ICB$V_ExpReg = 0;		(*  Image mapped at end of address space.  *)
00235      1  0     ICB$V_Shareable = 1;		(*  Image installed /SHAREABLE.  *)
00236      1  0     ICB$V_Open_For_Write = 2;	(*  Image will be opened for write.  *)
00237      1  0     ICB$V_Res_Header = 3;		(*  Image header already decoded.  *)
00238      1  0     ICB$V_Load_Image = 4;		(*  Load image from sequential device.  *)
00239      1  0     ICB$V_Initialize = 5;		(*  Image contains initialization code.  *)
00240      1  0     ICB$V_Done = 6;		(*  Image is completely activated.  *)
00241      1  0     ICB$V_Sys_STB = 7;		(*  Image is linked against SYS.STB.  *)
00242      1  0 
00243      1  0   type
00244      1  0 
00245   C  1  0     (*  From VAX/VMS V4.5 microfiche (437 F 2).  *)
00246      1  0     ICB_Act_Mode_Type = ( Undefined, Main_Program, Merged_Image,
00247      1  0       Global_Image_Section );
00248      1  0     ICB_Flags_Type = ( ExpReg, Shareable, Open_For_Write,
00249      1  0       Res_Header, Load_Image, Initialize, Done, Sys_STB );
00250      1  0     ICB_Type = packed record
00251      1  0       ICB$L_FLink : ^icb_type;  (*  Forward link in list.  *)
00252      1  0       ICB$L_BLink : ^icb_type;  (*  Backward link in list.  *)
00253      1  0       ICB$W_Size : word;  (*  Size of ICB in bytes.  *)
00254      1  0       ICB$B_Type : byte;  (*  Structure type for ICB.  *)
00255      1  0       ICB$B_ICB_1 : byte;  (*  Spare for alignment.  *)
00256      1  0       ICB$B_Access_Mode : byte;  (*  Access mode of image.  *)
00257      1  0       ICB$B_Act_Mode : [byte] icb_act_mode_type;  (*  Activation code.  *)
00258      1  0       ICB$W_Chan : word;  (*  Channel on which image file is opened.  *)
00259      1  0       ICB$L_Flags : [long] set of icb_flags_type;  (*  Name attributes.  *)
00260      1  0       ICB$T_Image_Name : packed array [ 1 .. 40 ] of char;  (*  Name string, ASCIC.  *)
00261      1  0       ICB$L_Fill_1 : unsigned;
00262      1  0       ICB$Q_Ident : packed record
00263      1  0         ICB$L_Match_Control : [long] 0 .. 2;

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page    8
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (5)

-LINE-IDC-PL-SL-

00264      1  0         ICB$L_Version : packed record
00265      1  0           ICB$L_Minor_Id : [ byte(3) ] 0 .. 2**24-1;
00266      1  0           ICB$B_Major_Id : byte;
00267      1  0           end;
00268      1  0         end;
00269      1  0       ICB$L_Start_Address : unsigned;
00270      1  0       ICB$L_End_Address : unsigned;
00271      1  0       ICB$L_IHD : unsigned;  (*  Address of IHD for image.  *)
00272      1  0       ICB$L_KFE : unsigned;  (*  Address of KFE for image.  *)
00273      1  0       ICB$L_Context : unsigned;  (*  Address of context block.  *)
00274      1  0       ICB$L_Base_Address : unsigned;  (*  Base address at which image is mapped.  *)
00275      1  0       ICB$L_Initialize : unsigned;  (*  Address of initialization code.  *)
00276      1  0       end;  (*  ICB_Type  *)
00277      1  0 
00278      1  0   var
00279      1  0     Bit_Name : varying [ 62 ] of char;
00280      1  0     Flag_Bit : icb_flags_type;
00281      1  0     IAC$GL_Image_List : [external] ^icb_type;
00282      1  0     ICB_Entry : ^icb_type;
00283      1  0     String : varying [ 254 ] of char;
00284      1  0 
00285      1  1   begin  (*  RCS_Display_Image_List  *)
00286      1  1 
00287      1  1   writeln( 'Activated images:' );
00288      1  1 
00289   C  1  1   (*  Get the list head from the control region.  *)
00290      1  1   ICB_Entry := IAC$GL_Image_List;
00291      1  1 
00292   C  1  1   (*  Traverse the list displaying each node.  *)
00293      1  2   while ICB_Entry <> IAC$GL_Image_List^.ICB$L_BLink do begin
00294      1  2     writeln;
00295      1  3     with ICB_Entry^ do begin
00296      1  3 
00297   C  1  3       (*  Display image name, ident, address range and activation mode.  *)
00298      1  3       write( 'Image: ',
00299      1  3         substr( ICB$T_Image_Name, 2, ord( ICB$T_Image_Name[ 1 ] ) ),
00300      1  3         '   [', hex( ICB$L_Start_Address, 8, 8 ), ':',
00301      1  3         hex( ICB$L_End_Address, 8, 8 ), ']  ' );
00302      1  3 
00303      1  3       if ICB$Q_Ident.ICB$L_Version.ICB$B_Major_Id >= 100 then
00304      1  3         write( ICB$Q_Ident.ICB$L_Version.ICB$B_Major_Id:1, '-' )
00305      1  3       else
00306      1  3         write( udec( ICB$Q_Ident.ICB$L_Version.ICB$B_Major_Id, 2, 2 ), '-' );
00307      1  3       if ICB$Q_Ident.ICB$L_Version.ICB$L_Minor_Id >= 1000 then
00308      1  3         write( ICB$Q_Ident.ICB$L_Version.ICB$L_Minor_Id:1 )
00309      1  3       else
00310      1  3         write( udec( ICB$Q_Ident.ICB$L_Version.ICB$L_Minor_Id, 3, 3 ) );
00311      1  3 
00312      1  4       case ICB$Q_Ident.ICB$L_Match_Control of
00313      1  4         sec$k_matall : write( ' (match all)' );
00314      1  4         sec$k_matequ : write( ' (match equal)' );
00315      1  4         sec$k_matleq : write( ' (match leq)' );
00316      1  3         end;
00317      1  3 
00318      1  3       writev( Bit_Name, ICB$B_Act_Mode );

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page    9
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (5)

-LINE-IDC-PL-SL-

00319      1  3       writeln( '  ', rcs_trim_leading( Bit_Name ) );
00320      1  3 
00321   C  1  3       (*  Display the base address only if different from the start address.  *)
00322      1  3       if ICB$L_Base_Address <> ICB$L_Start_Address then
00323      1  3         writeln( '  Base address: ', hex( ICB$L_Base_Address, 8, 8 ) );
00324      1  3 
00325   C  1  3       (*  Display the flags, if any.  *)
00326      1  4       if ICB$L_Flags <> [] then begin
00327      1  4         String := '';
00328      1  4         for Flag_Bit := expreg to sys_stb do
00329      1  5           if Flag_Bit in ICB$L_Flags then begin
00330      1  5             writev( Bit_Name, Flag_Bit );
00331      1  5             String := String + ', ' + rcs_trim_leading( Bit_Name )
00332      1  4             end;
00333      1  4         write( '  Flags: ', substr( String, 3, length( String ) - 2 ) )
00334      1  3         end;
00335      1  4       case ICB$B_Access_Mode of
00336      1  4         psl$c_user   : writeln( '  (User mode)' );
00337      1  4         psl$c_super  : writeln( '  (Supervisor mode)' );
00338      1  4         psl$c_exec   : writeln( '  (Executive mode)' );
00339      1  4         psl$c_kernel : writeln( '  (Kernel mode)' )
00340      1  3         end;
00341      1  3 
00342   C  1  3       (*  Display the initialization entry point, if any.  *)
00343      1  3       if ICB$L_Initialize <> 0 then
00344      1  3         writeln( '  Initialization entry point: ',
00345      1  3           hex( ICB$L_Initialize, 8, 8 ) )
00346      1  3 
00347      1  2       end;  (*  with ICB_Entry^ do  *)
00348      1  2     ICB_Entry := ICB_Entry^.ICB$L_FLink
00349      1  2     end  (*  while ICB_Entry <> IAC$GL_Image_List^.ICB$L_Blink do  *)
00350      1  2 
00351      0  0   end;  (*  RCS_Display_Image_List  *)
00352      0  0 

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   10
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (6)

-LINE-IDC-PL-SL-

00354      1  0 [global] function RCS_Equal(
00355      1  0   String_1 : varying[ u1 ] of char;
00356      1  0   String_2 : varying[ u2 ] of char
00357      1  0   ) : boolean;
00358      1  0 
00359   C  1  0   (*  Returns   true   if both   String_1   equals   String_2 .  *)
00360      1  0 
00361      1  1   begin  (*  RCS_Equal  *)
00362      1  1 
00363      1  1     RCS_Equal := false;
00364      1  1     if length( String_1 ) = length( String_2 ) then
00365      1  1       if String_1 = String_2 then
00366      1  1         RCS_Equal := true
00367      1  1 
00368      0  0   end;  (*  RCS_Equal  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   11
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (7)

-LINE-IDC-PL-SL-

00370      1  0 [global] procedure RCS_Free_VM_With_Descriptor(
00371      1  0   var VM_Descr_Ptr : RCS_VM_With_Descriptor_Pointer );
00372      1  0 
00373   C  1  0   (*  Release virtual memory associated with the descriptor and dispose
00374   C  1  0       of the VM_Descr_Ptr pointer. *)
00375      1  0 
00376      1  0   var
00377      1  0     Free_VM_Status : unsigned;
00378      1  0     Number_Of_Bytes : integer;
00379      1  0 
00380      1  1   begin  (*  RCS_Free_VM_With_Descriptor  *)
00381      1  1 
00382      1  1     Number_Of_Bytes := 0;
00383      1  1     Number_Of_Bytes := VM_Descr_Ptr^.class_s.dsc$w_length;
00384      1  1 
00385      1  1     Free_VM_Status := lib$free_vm(
00386      1  1                         number_of_bytes := Number_Of_Bytes,
00387      1  1                         base_address := VM_Descr_Ptr^.VM );
00388      1  1     if not odd( Free_VM_Status ) then 
00389      1  1       lib$signal( Free_VM_Status );
00390      1  1 
00391      1  1     dispose( VM_Descr_Ptr );
00392      1  1 
00393      1  1     VM_Descr_Ptr := nil
00394      1  1 
00395      0  0   end;  (*  Procedure RCS_Free_VM_With_Descriptor *)
00396      0  0 

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   12
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (8)

-LINE-IDC-PL-SL-

00398      1  0 [global] function RCS_Get_ASCIC(
00399      1  0   Source : packed array [ l1 .. u1 : integer ] of char
00400      1  0   ) : varying_string;
00401      1  0 
00402   C  1  0   (*  The data in the counted ASCII string   Source   is returned
00403   C  1  0     as a varying string.  *)
00404      1  0 
00405      1  1   begin  (*  RCS_Get_ASCIC  *)
00406      1  1 
00407      1  1     RCS_Get_ASCIC := substr( Source, L1 + 1, ord( Source[ L1 ] ) )
00408      1  1 
00409      0  0   end;  (*  RCS_Get_ASCIC  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   13
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (9)

-LINE-IDC-PL-SL-

00411      1  0 [global] function RCS_Get_Diskquota(
00412      1  0   Device_Name   : varying_string;
00413      1  0   var Flags     : unsigned;
00414      1  0   var Usage     : unsigned;
00415      1  0   var Permquota : unsigned;
00416      1  0   var Overdraft : unsigned
00417      1  0   ) : unsigned;
00418      1  0 
00419   C  1  0   (*  This function looks up the current user's diskquota entry on the
00420   C  1  0     specified device.  The device name may be either a physical device
00421   C  1  0     name, or a logical name.  The function returns the quota information
00422   C  1  0     through parameters and a completion code as the function value.
00423   C  1  0     The caller should be prepared to cope with the following values:
00424   C  1  0 
00425   C  1  0 	SS$_Normal	normal successful completion
00426   C  1  0 	SS$_QFNotAct	disk quotas not enabled on this volume
00427   C  1  0 	SS$_NoDiskQuota	no disk quota entry for this UIC
00428   C  1  0     *)
00429      1  0 
00430      1  0   type
00431      1  0     DQF_Record = packed record
00432      1  0       DQF$L_Flags     : unsigned;
00433      1  0       DQF$L_UIC       : unsigned;
00434      1  0       DQF$L_Usage     : unsigned;
00435      1  0       DQF$L_PermQuota : unsigned;
00436      1  0       DQF$L_Overdraft : unsigned;
00437      1  0       DQF$L_Spare_1   : unsigned;
00438      1  0       DQF$L_Spare_2   : unsigned;
00439      1  0       DQF$L_Spare_3   : unsigned
00440      1  0       end;  (*  DQF_Record  *)
00441      1  0 
00442      1  0   var
00443      1  0     Status    : unsigned;
00444      1  0     IOSB      : packed array [ 0 .. 3 ] of uword;
00445      1  0     Channel   : uword;
00446      1  0     FIB       : fib$type;
00447      1  0     DQF       : dqf_record;
00448      1  0     FIB_Descriptor : rcs_descriptor_record;
00449      1  0     DQF_Descriptor : rcs_descriptor_record;
00450      1  0 
00451      1  1   begin  (*  RCS_Get_Diskquota  *)
00452      1  1 
00453      1  1     establish( lib$sig_to_ret );
00454      1  1     RCS_Get_Diskquota := ss$_normal;
00455      1  1 
00456   C  1  1     (*  Assign a channel to the device in question.  *)
00457      1  1     Status := $assign( chan := Channel, devnam := Device_Name );
00458      1  1     if not odd( Status ) then
00459      1  1       lib$signal( Status );
00460      1  1 
00461   C  1  1     (*  Build the File Information Block.  *)
00462      1  2     with FIB_Descriptor do begin
00463      1  2       DSC$W_Length  := size( FIB );
00464      1  2       DSC$B_DType   := dsc$k_dtype_z;
00465      1  2       DSC$B_Class   := dsc$k_class_z;

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   14
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (9)

-LINE-IDC-PL-SL-

00466      1  2       DSC$A_Pointer := iaddress( FIB )
00467      1  1       end;
00468      1  1 
00469      1  1     FIB := zero;
00470   C  1  1     (*  The file identification for the MFD is always (4,4,0).  *)
00471      1  2     with FIB do begin
00472      1  2       FIB$W_DID_Num := 4;
00473      1  2       FIB$W_DID_Seq := 4;
00474      1  2       FIB$W_DID_RVN := 0;
00475      1  2       FIB$W_ExCtl := fib$c_exa_quota  (*  Aka FIB.FIB$W_CntrlFunc.  *)
00476      1  1       end;
00477      1  1 
00478   C  1  1     (*  Build the diskquota record.  *)
00479      1  2     with DQF_Descriptor do begin
00480      1  2       DSC$W_Length  := size( DQF );
00481      1  2       DSC$B_DType   := dsc$k_dtype_z;
00482      1  2       DSC$B_Class   := dsc$k_class_z;
00483      1  2       DSC$A_Pointer := iaddress( DQF )
00484      1  1       end;
00485      1  1 
00486      1  1     DQF := zero;
00487      1  1     DQF.DQF$L_UIC := rcs_getjpi_numeric( jpi$_uic );
00488      1  1 
00489   C  1  1     (*  Request the quota record from the disk ACP (XQP).  *)
00490      1  1     Status := $qiow(
00491      1  1       chan := Channel,
00492      1  1       func := io$_acpcontrol,
00493      1  1       iosb := IOSB,
00494      1  1       p1   := %ref FIB_Descriptor,
00495      1  1       p2   := %ref DQF_Descriptor,
00496      1  1       p4   := %ref DQF_Descriptor );
00497      1  1     if not odd( Status ) then
00498      1  1       lib$signal( Status );
00499      1  1     if not odd( IOSB[ 0 ] ) then
00500      1  1       lib$signal( IOSB[ 0 ] );
00501      1  1 
00502   C  1  1     (*  Dispose of the channel to the disk.  *)
00503      1  1     Status := $dassgn( chan := Channel );
00504      1  1     if not odd( Status ) then
00505      1  1       lib$signal( Status );
00506      1  1 
00507   C  1  1     (*  Return the items of interest.  *)
00508      1  2     with DQF do begin
00509      1  2       Flags     := DQF$L_Flags;
00510      1  2       Usage     := DQF$L_Usage;
00511      1  2       Permquota := DQF$L_PermQuota;
00512      1  2       Overdraft := DQF$L_Overdraft
00513      1  2       end
00514      1  2 
00515      0  0   end;  (*  RCS_Get_Diskquota  *)
00516      0  0 

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   15
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (10)

-LINE-IDC-PL-SL-

00518   C  0  0 (************************************************************************
00519   C  0  0 *									*
00520   C  0  0 *   Entry point:	RCS_Get_File_Dates				*
00521   C  0  0 *									*
00522   C  0  0 *   Description:							*
00523   C  0  0 *									*
00524   C  0  0 *	This routine gets the backup, creation, expiration, and 	*
00525   C  0  0 *	revision dates for the specified file.  The dates are returned  *
00526   C  0  0 *	as quadword; the system service SYS$ASCTIM can be used to 	*
00527   C  0  0 * 	them to ASCII.							*
00528   C  0  0 *									*
00529   C  0  0 *   Arguments:								*
00530   C  0  0 *									*
00531   C  0  0 *	Filespec							*
00532   C  0  0 *	  String containing the name of the file.			*
00533   C  0  0 *									*
00534   C  0  0 *	Backup								*
00535   C  0  0 *	  Date of backup.						*
00536   C  0  0 *									*
00537   C  0  0 *	Creation							*
00538   C  0  0 *	  Date of creation.						*
00539   C  0  0 *									*
00540   C  0  0 *	Expiration							*
00541   C  0  0 *	  Date of expiration.						*
00542   C  0  0 *									*
00543   C  0  0 *	Revision							*
00544   C  0  0 *	  Date of revision.						*
00545   C  0  0 *									*
00546   C  0  0 *   Return values:							*
00547   C  0  0 *									*
00548   C  0  0 *	ss$_normal	Success -- dates valid.				*
00549   C  0  0 *	ss$_abort	Failure -- dates not valid.			*
00550   C  0  0 *									*
00551   C  0  0 *-----------------------------------------------------------------------*
00552   C  0  0 *									*
00553   C  0  0 *   Notes:								*
00554   C  0  0 *									*
00555   C  0  0 *	A user open is used to add an XAB address to the FAB before	*
00556   C  0  0 *	the file is actually opened.					*
00557   C  0  0 *									*
00558   C  0  0 *************************************************************************)
00559      0  0 
00560      1  0 [global] function RCS_Get_File_Dates
00561      1  0   (
00562      1  0   Filespec       : varying_string;
00563      1  0   var Revision   : quadword;
00564      1  0   var Creation   : [truncate] quadword;
00565      1  0   var Backup     : [truncate] quadword;
00566      1  0   var Expiration : [truncate] quadword
00567      1  0   ) : unsigned;
00568      1  0 
00569      1  0   var
00570      1  0     File_Ptr : text;
00571      1  0     Stat     : unsigned;
00572      1  0     XAB      : [static] xab$type;

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   16
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (10)

-LINE-IDC-PL-SL-

00573      1  0 
00574      2  0   function User_Open(
00575      2  0     var FAB : fab$type;
00576      2  0     var RAB : rab$type;
00577      2  0     var File_Ptr : text
00578      2  0     ) : unsigned;
00579      2  0 
00580      2  0     var
00581      2  0       Stat : unsigned;
00582      2  0 
00583      2  1     begin
00584      2  1       FAB.FAB$L_XAB := iaddress( XAB );
00585      2  1       Stat := $open( FAB );
00586      2  1       if odd( Stat ) then Stat := $connect( RAB );
00587      2  1       User_Open := Stat;
00588      1  0     end;
00589      1  0 
00590      1  1   begin  (*  RCS_Get_File_Dates  *)
00591      1  1 
00592      1  1     if present( Backup ) then
00593      1  1       Backup := zero;
00594      1  1     if present( Creation ) then
00595      1  1       Creation := zero;
00596      1  1     if present( Expiration ) then
00597      1  1       Expiration := zero;
00598      1  1     Revision   := zero;
00599      1  1 
00600      1  1     XAB.XAB$B_COD := xab$c_dat;
00601      1  1     XAB.XAB$B_BLN := xab$c_datlen;
00602      1  1 
00603      1  1     open( file_variable := File_Ptr,
00604      1  1           file_name     := Filespec,
00605      1  1           error         := continue,
00606      1  1           user_action   := User_Open );
00607      1  1 
00608      1  1     Stat := status( File_Ptr );
00609      1  1 
00610      1  2     if Stat <= 0 then begin
00611      1  2       close( File_Ptr );
00612      1  2 
00613      1  2       if present( Backup ) then
00614      1  2         Backup     := XAB.XAB$Q_BDT::quadword;
00615      1  2       if present( Creation ) then
00616      1  2         Creation   := XAB.XAB$Q_CDT::quadword;
00617      1  2       if present( Expiration ) then
00618      1  2         Expiration := XAB.XAB$Q_EDT::quadword;
00619      1  2       Revision   := XAB.XAB$Q_RDT::quadword;
00620      1  2 
00621      1  2       RCS_Get_File_Dates := ss$_normal
00622      1  2 
00623      1  2       end  (*  if Stat <= 0 then  *)
00624      1  1     else
00625      1  1       RCS_Get_File_Dates := ss$_abort;
00626      1  1 
00627      0  0   end;  (*  RCS_Get_File_Dates  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   17
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (11)

-LINE-IDC-PL-SL-

00629      1  0 [global] function RCS_Get_Ident : varying_string;
00630      1  0 
00631   C  1  0   (*  Returns the   IDENT   string for the current image.  *)
00632      1  0 
00633      1  0   var
00634      1  0     IHI_Pointer : ihi$_pointer;
00635      1  0     MMG$ImgHdrBuf : [external,readonly] ihd$_pointer;
00636      1  0 
00637      1  1   begin  (*  RCS_Get_Ident  *)
00638      1  1 
00639      1  1     if iaddress( MMG$ImgHdrBuf ) = 0 then
00640   C  1  1       (*  The image was not linked with Sys$System:SYS.STB.  *)
00641      1  1       lib$signal( ss$_abort );
00642      1  1 
00643      1  2     with MMG$ImgHdrBuf^ do begin
00644      1  2       if ( ihd$k_majorid <> IHD$W_MajorId ) or
00645      1  2          ( ihd$k_minorid <> IHD$W_MinorId ) then
00646   C  1  2         (*  Unknown image header format.  *)
00647      1  2         lib$signal( ss$_abort );
00648      1  2       IHI_Pointer := ( MMG$ImgHdrBuf::unsigned + ihd$w_imgidoff )::ihi$_pointer
00649      1  1       end;
00650      1  1 
00651      1  1     RCS_Get_Ident := rcs_get_ascic( IHI_Pointer^.IHI$T_ImgId )
00652      1  1 
00653      0  0   end;  (*  RCS_Get_Ident  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   18
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (12)

-LINE-IDC-PL-SL-

00655      1  0 [global] function RCS_Get_Node_Name : varying_string;
00656      1  0 
00657   C  1  0   (*  Returns the node name of the executing node.  The node name
00658   C  1  0     includes two trailing colons.  Errors are signalled.  *)
00659      1  0 
00660      1  0   var
00661      1  0     Item_List : array [ 1 .. 2 ] of rcs_item_list_3;
00662      1  0     Node_Name : [volatile] varying [ 6 ] of char;
00663      1  0     Status    : unsigned;
00664      1  0     IOSB      : packed array [ 0 .. 3 ] of uword;
00665      1  0 
00666      1  1   begin  (*  RCS_Get_Node_Name  *)
00667      1  1 
00668      1  1     Item_List := zero;
00669      1  2     with Item_List[ 1 ] do begin
00670      1  2       Buffer_Length  := size( Node_Name.Body );
00671      1  2       Item_Code      := syi$_scsnode;
00672      1  2       Buffer_Address := iaddress( Node_Name.Body );
00673      1  2       Return_Length_Address := iaddress( Node_Name.Length )
00674      1  1       end;
00675      1  1 
00676      1  1     Status := $getsyiw(
00677      1  1       itmlst := Item_List,
00678      1  1       iosb   := IOSB );
00679      1  1     if not odd( Status ) then lib$signal( Status );
00680      1  1     if not odd( IOSB[ 0 ] ) then lib$signal( IOSB[ 0 ] );
00681      1  1 
00682      1  1     RCS_Get_Node_Name := rcs_trim( Node_Name ) + '::'
00683      1  1 
00684      0  0   end;  (*  RCS_Get_Node_Name  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   19
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (13)

-LINE-IDC-PL-SL-

00686      1  0 [global] function RCS_Get_System_Version : varying_string;
00687      1  0 
00688   C  1  0   (*  Returns, as a character string, the software version number of the
00689   C  1  0       VAX/VMS operating system that is running on the VAX node.  This
00690   C  1  0       information is only returned for the local VAX node.
00691   C  1  0       Errors are signalled. *)
00692      1  0 
00693      1  0   const
00694      1  0     Version_Length = 8;
00695      1  0 
00696      1  0   var
00697      1  0     Item_List : array [ 1 .. 2 ] of rcs_item_list_3;
00698      1  0     Version   : [volatile] varying [ version_length ] of char;
00699      1  0     Status    : unsigned;
00700      1  0     IOSB      : packed array [ 0 .. 3 ] of uword;
00701      1  0 
00702      1  1   begin  (*  RCS_Get_System_Version  *)
00703      1  1 
00704      1  1     Item_List := zero;
00705      1  2     with Item_List[ 1 ] do begin
00706      1  2       Buffer_Length  := size( Version.Body );
00707      1  2       Item_Code      := syi$_version;
00708      1  2       Buffer_Address := iaddress( Version.Body );
00709      1  2       Return_Length_Address := iaddress( Version.Length )
00710      1  1       end;
00711      1  1 
00712      1  1     Status := $getsyiw(
00713      1  1       itmlst := Item_List,
00714      1  1       iosb   := IOSB );
00715      1  1     if not odd( Status ) then lib$signal( Status );
00716      1  1     if not odd( IOSB[ 0 ] ) then lib$signal( IOSB[ 0 ] );
00717      1  1 
00718      1  1     RCS_Get_System_Version := rcs_trim( Version )
00719      1  1 
00720      0  0   end;  (*  RCS_Get_System_Version  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   20
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (14)

-LINE-IDC-PL-SL-

00722      1  0 [global] function RCS_Get_Terminal : varying_string;
00723      1  0 
00724   C  1  0   (*  Returns the terminal name for the current process, if any,
00725   C  1  0     otherwise the null string is returned, e.g. for a batch job.
00726   C  1  0     The device name always ends in a colon and may be up to eight
00727   C  1  0     characters long.  There is no leading underscore.  If virtual
00728   C  1  0     terminals are enabled then the name of the virtual terminal
00729   C  1  0     is returned.  Errors are signalled.  *)
00730      1  0 
00731      1  0   var
00732      1  0     Item_List : array [ 1 .. 2 ] of rcs_item_list_3;
00733      1  0     Terminal  : [volatile] varying [ 8 ] of char;
00734      1  0     Status    : unsigned;
00735      1  0     IOSB      : packed array [ 0 .. 3 ] of uword;
00736      1  0 
00737      1  1   begin  (*  RCS_Get_Terminal  *)
00738      1  1 
00739      1  1     Item_List := zero;
00740      1  2     with Item_List[ 1 ] do begin
00741      1  2       Buffer_Length  := size( Terminal.Body );
00742      1  2       Item_Code      := jpi$_terminal;
00743      1  2       Buffer_Address := iaddress( Terminal.Body );
00744      1  2       Return_Length_Address := iaddress( Terminal.Length )
00745      1  1       end;
00746      1  1 
00747      1  1     Status := $getjpiw(
00748      1  1       itmlst := Item_List,
00749      1  1       iosb   := IOSB );
00750      1  1     if not odd( Status ) then lib$signal( Status );
00751      1  1     if not odd( IOSB[ 0 ] ) then lib$signal( IOSB[ 0 ] );
00752      1  1 
00753      1  1     Terminal := rcs_trim( Terminal );
00754      1  1     if ( Terminal.Length > 0 ) and ( index( Terminal, ':' ) > 0 ) then
00755      1  1       RCS_Get_Terminal := Terminal
00756      1  1     else
00757      1  1       RCS_Get_Terminal := Terminal + ':'
00758      1  1 
00759      0  0   end;  (*  RCS_Get_Terminal  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   21
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (15)

-LINE-IDC-PL-SL-

00761      1  0 [global] function RCS_Get_Username : varying_string;
00762      1  0 
00763   C  1  0   (*  Returns the username of the calling process.  Errors are signalled.  *)
00764      1  0 
00765      1  0   var
00766      1  0     Item_List : array [ 1 .. 2 ] of rcs_item_list_3;
00767      1  0     Username  : [volatile] varying [ 32 ] of char;
00768      1  0     Status    : unsigned;
00769      1  0     IOSB      : packed array [ 0 .. 3 ] of uword;
00770      1  0 
00771      1  1   begin  (*  RCS_Get_Username  *)
00772      1  1 
00773      1  1     Item_List := zero;
00774      1  2     with Item_List[ 1 ] do begin
00775      1  2       Buffer_Length  := size( Username.Body );
00776      1  2       Item_Code      := jpi$_username;
00777      1  2       Buffer_Address := iaddress( Username.Body );
00778      1  2       Return_Length_Address := iaddress( Username.Length )
00779      1  1       end;
00780      1  1 
00781      1  1     Status := $getjpiw(
00782      1  1       itmlst := Item_List,
00783      1  1       iosb   := IOSB );
00784      1  1     if not odd( Status ) then lib$signal( Status );
00785      1  1     if not odd( IOSB[ 0 ] ) then lib$signal( IOSB[ 0 ] );
00786      1  1 
00787      1  1     RCS_Get_Username := rcs_trim( Username )
00788      1  1 
00789      0  0   end;  (*  RCS_Get_Username  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   22
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (16)

-LINE-IDC-PL-SL-

00791      1  0 [global] function RCS_Get_VM_With_Descriptor(
00792      1  0   Number_Of_Bytes : integer
00793      1  0   ) : RCS_VM_With_Descriptor_Pointer;
00794      1  0 
00795   C  1  0   (*  Allocate virtual memory via Lib$Get_VM and build a class-s descriptor
00796   C  1  0       for it.  *)
00797      1  0 
00798      1  0   var
00799      1  0     Get_VM_Status : unsigned;
00800      1  0     VM_Descr_Ptr : rcs_vm_with_descriptor_pointer;
00801      1  0 
00802      1  1   begin  (*  RCS_Get_VM_With_Descriptor  *)
00803      1  1 
00804      1  1     new( VM_Descr_Ptr );
00805      1  1     VM_Descr_Ptr^ := zero;
00806      1  1 
00807      1  1     Get_VM_Status := lib$get_vm(
00808      1  1                        number_of_bytes := Number_Of_Bytes,
00809      1  1                        base_address := VM_Descr_Ptr^.VM );
00810      1  1     if not odd( Get_VM_Status ) then
00811      1  1       lib$signal( Get_VM_Status );
00812      1  1 
00813   C  1  1     (*  Fill in the class-s descriptor portion of the record.  *)
00814      1  2     with VM_Descr_Ptr^.Class_S do begin
00815      1  2       dsc$w_length := Number_Of_Bytes;
00816      1  2       dsc$b_dtype := DSC$K_DTYPE_BU;  (*  Assume unsigned byte.  *)
00817      1  2       dsc$b_class := DSC$K_CLASS_S;
00818      1  2       dsc$a_pointer := VM_Descr_Ptr^.VM
00819      1  1       end;  (*  with VM_Descr_Ptr^.Class_S do  *)
00820      1  1 
00821      1  1     RCS_Get_VM_With_Descriptor := VM_Descr_Ptr
00822      1  1 
00823      0  0   end;  (*  function RCS_Get_VM_With_Descriptor  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   23
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (17)

-LINE-IDC-PL-SL-

00825      1  0 function RCS_GetJPI_Numeric;
00826   C  1  0   (*  [global] function RCS_GetJPI_Numeric( Item_Code : unsigned ) : unsigned;  *)
00827      1  0 
00828   C  1  0   (*  Retrieves a numeric item for the current process from $GetJPIW.  *)
00829      1  0 
00830      1  0   var
00831      1  0     IOSB : rcs_generic_iosb;
00832      1  0     Item_List : array [ 1 .. 2 ] of rcs_item_list_3;
00833      1  0     Return_Value : [volatile] unsigned;
00834      1  0     Status : unsigned;
00835      1  0 
00836      1  1   begin  (*  RCS_GetJPI_Numeric  *)
00837      1  1 
00838      1  1     RCS_GetJPI_Numeric := 0;
00839      1  1     Return_Value := 0;  (*  To accomodate short values.  *)
00840      1  1 
00841      1  1     Item_List := zero;
00842      1  2     with Item_List[ 1 ] do begin
00843      1  2       Item_Code      := Item_Code;
00844      1  2       Buffer_Address := iaddress( Return_Value );
00845      1  2       Buffer_Length  := size( Return_Value )
00846      1  1       end;
00847      1  1 
00848      1  1     Status := $getjpiw(
00849      1  1       itmlst := Item_List,
00850      1  1       iosb   := IOSB );
00851      1  1     if not odd( Status ) then
00852      1  1       lib$signal( Status );
00853      1  1     if not odd( IOSB.Condition_Value ) then
00854      1  1       lib$signal( IOSB.Condition_Value );
00855      1  1 
00856      1  1     RCS_GetJPI_Numeric := Return_Value
00857      1  1 
00858      0  0   end;  (*  RCS_GetJPI_Numeric  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   24
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (18)

-LINE-IDC-PL-SL-

00860      1  0 [global] function RCS_Id_To_ASCII( Id : unsigned ) : varying_string;
00861      1  0 
00862   C  1  0   (*  Returns the string corresponding to the specified identifier.
00863   C  1  0     If no identifier is found then the null string is returned.  Other
00864   C  1  0     errors are signalled.  *)
00865      1  0 
00866      1  0   var
00867      1  0     Status : integer;
00868      1  0     Length : uword;
00869      1  0     Buffer : packed array [ 1 .. 31 ] of char;
00870      1  0 
00871      1  1   begin  (*  RCS_Id_To_ASCII  *)
00872      1  1 
00873      1  1     Status := $idtoasc( id := Id, namlen := Length, nambuf := Buffer );
00874      1  1     if Status = ss$_normal then
00875      1  1       RCS_Id_To_ASCII := substr( Buffer, 1, Length )
00876      1  1     else if Status = ss$_nosuchid then
00877      1  1       RCS_Id_To_ASCII := ''
00878      1  1     else
00879      1  1       lib$signal( Status )
00880      1  1 
00881      0  0   end;  (*  RCS_Id_To_ASCII  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   25
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (19)

-LINE-IDC-PL-SL-

00883      1  0 [global] function RCS_Parse_Date(
00884      1  0   Date_Input : varying[ u1 ] of char;
00885      1  0   var Date_Output : varying[ u2 ] of char;
00886      1  0   var Date_Binary : quadword
00887      1  0   ) : unsigned;
00888      1  0 
00889   C  1  0   (*  RCS_Parse_Date returns a system service status code.
00890   C  1  0     Two parameters are used to return the resultant date in both
00891   C  1  0     DD-Mmm-YY and quadword system time formats.  Input strings are:
00892   C  1  0     MM/DD/YY   or   DD-MMM-YY .  If the year is less than 100 then
00893   C  1  0     1900 is added.  TODAY, YESTERDAY and TOMORROW are also handled.  *)
00894      1  0 
00895      1  0   const
00896      1  0     Midnight = ' 00:00:00.00';
00897      1  0     Downcase = ord( 'a' ) - ord( 'A' );
00898      1  0     Zero = ord( '0' );
00899      1  0     Months = 'JANFEBMARAPRMAYJUNJULAUGSEPOCTNOVDEC';
00900      1  0 
00901      1  0   type
00902      1  0     State_Variable = ( s_initial, s_first_field, s_hyphen_1, s_slash_1,
00903      1  0       s_field_2_alpha, s_field_2_num, s_hyphen_2, s_slash_2, s_field_3,
00904      1  0       s_done, s_error );
00905      1  0     Class_Variable = ( c_digit, c_letter, c_hyphen, c_slash,
00906      1  0       c_character, c_eol );
00907      1  0 
00908      1  0   var
00909      1  0     VMS_Date_Time : packed array [ 1 .. 23 ] of char;
00910      1  0     Date_String, Output_String : varying[ 64 ] of char;
00911      1  0     Output_Binary : quadword;
00912      1  0     Day, Month, Year, Subscript, Status : integer;
00913      1  0     Month_String : varying[ 64 ] of char;
00914      1  0     Character : char;
00915      1  0     State : state_variable;
00916      1  0     Class : class_variable;
00917      1  0 
00918      2  0   procedure Get_Character;
00919      2  0 
00920   C  2  0     (*  Load   Character   and   Class .  *)
00921      2  0 
00922      2  1     begin  (*  Get_Character  *)
00923      2  1 
00924      2  2       if Subscript > length( Date_String ) then begin
00925      2  2         Character := ' ';
00926      2  2         Class := c_eol
00927      2  2         end
00928      2  2       else begin
00929      2  2         Character := Date_String[ Subscript ];
00930      2  2         Subscript := Subscript + 1;
00931      2  2         if Character in [ '0' .. '9' ] then
00932      2  2           Class := c_digit
00933      2  2         else if Character in [ 'A' .. 'Z' ] then
00934      2  2           Class := c_letter
00935      2  2         else if Character in [ '-' ] then
00936      2  2           Class := c_hyphen
00937      2  2         else if Character in [ '/' ] then

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   26
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (19)

-LINE-IDC-PL-SL-

00938      2  2           Class := c_slash
00939      2  2         else
00940      2  2           Class := c_character
00941      2  2         end
00942      2  2 
00943      2  2 
00944      1  0     end;  (*  Get_Character  *)
00945      1  0 
00946      1  1   begin  (*  RCS_Parse_Date  *)
00947      1  1 
00948      1  1     RCS_Parse_Date := ss$_normal;
00949      1  1     Output_String := '';
00950      1  2     with Output_Binary do begin
00951      1  2       L0 := 0;  L1 := 0
00952      1  1       end;
00953      1  1 
00954   C  1  1     (* Initialize values to make compiler happy. *)
00955      1  1     Character := ' ';
00956      1  1     Class := c_eol;
00957      1  1 
00958      1  1     str$upcase( Date_String, Date_Input );
00959      1  1 
00960      1  2     if RCS_equal( Date_String, 'TODAY' ) then begin
00961      1  2       $asctim( timbuf := VMS_Date_Time );
00962      1  2       VMS_Date_Time := substr( VMS_Date_Time, 1, 11 ) + midnight;
00963      1  2       $bintim( timbuf := VMS_Date_Time, timadr := Output_Binary );
00964      1  2       VMS_Date_Time[ 5 ] := chr( ord( VMS_Date_Time[ 5 ] ) + downcase );
00965      1  2       VMS_Date_Time[ 6 ] := chr( ord( VMS_Date_Time[ 6 ] ) + downcase );
00966      1  2       Output_String := substr( VMS_Date_Time, 1, 7 ) +
00967      1  2         substr( VMS_Date_Time, 10, 2 )
00968      1  2       end
00969      1  2 
00970      1  2     else if RCS_equal( Date_String, 'YESTERDAY' ) then begin
00971      1  2       $asctim( timbuf := VMS_Date_Time );
00972      1  2       VMS_Date_Time := substr( VMS_Date_Time, 1, 11 ) + midnight;
00973      1  2       $bintim( timbuf := VMS_Date_Time, timadr := Output_Binary );
00974      1  3       if Output_Binary.L0 >= 711573504 then begin
00975      1  3         Output_Binary.L0 := Output_Binary.L0 - 711573504;
00976      1  3         Output_Binary.L1 := Output_Binary.L1 - 201
00977      1  3         end
00978      1  3       else begin
00979      1  3         Output_Binary.L0 := Output_Binary.L0 + 3583393792;
00980      1  3         Output_Binary.L1 := Output_Binary.L1 - 202
00981      1  2         end;
00982      1  2       $asctim( timbuf := VMS_Date_Time, timadr := Output_Binary );
00983      1  2       VMS_Date_Time[ 5 ] := chr( ord( VMS_Date_Time[ 5 ] ) + downcase );
00984      1  2       VMS_Date_Time[ 6 ] := chr( ord( VMS_Date_Time[ 6 ] ) + downcase );
00985      1  2       Output_String := substr( VMS_Date_Time, 1, 7 ) +
00986      1  2         substr( VMS_Date_Time, 10, 2 )
00987      1  2       end
00988      1  2 
00989      1  2     else if RCS_equal( Date_String, 'TOMORROW' ) then begin
00990      1  2       $asctim( timbuf := VMS_Date_Time );
00991      1  2       VMS_Date_Time := substr( VMS_Date_Time, 1, 11 ) + midnight;
00992      1  2       $bintim( timbuf := VMS_Date_Time, timadr := Output_Binary );

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   27
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (19)

-LINE-IDC-PL-SL-

00993      1  3       if Output_Binary.L0 < 3583393792 then begin
00994      1  3         Output_Binary.L0 := Output_Binary.L0 + 711573504;
00995      1  3         Output_Binary.L1 := Output_Binary.L1 + 201
00996      1  3         end
00997      1  3       else begin
00998      1  3         Output_Binary.L0 := Output_Binary.L0 - 3583393792;
00999      1  3         Output_Binary.L1 := Output_Binary.L1 + 202
01000      1  2         end;
01001      1  2       $asctim( timbuf := VMS_Date_Time, timadr := Output_Binary );
01002      1  2       VMS_Date_Time[ 5 ] := chr( ord( VMS_Date_Time[ 5 ] ) + downcase );
01003      1  2       VMS_Date_Time[ 6 ] := chr( ord( VMS_Date_Time[ 6 ] ) + downcase );
01004      1  2       Output_String := substr( VMS_Date_Time, 1, 7 ) +
01005      1  2         substr( VMS_Date_Time, 10, 2 )
01006      1  2       end
01007      1  2 
01008      1  2     else begin
01009   C  1  2       (*  Either   MM/DD/YY   or   DD-MMM-YYYY   format.  *)
01010      1  2       Subscript := 1;
01011      1  2       Day := 0;  Month := 0;  Year := 0;
01012      1  2       Month_String := '';
01013      1  2       State := s_initial;
01014      1  3       repeat
01015      1  3         get_character;
01016      1  4         case State of
01017      1  5           s_initial       : case Class of
01018      1  6                               c_digit  : begin  (*  Assume DD-MMM-YYYY.  *)
01019      1  6                                          Day := ord( Character ) - zero;
01020      1  6                                          State := s_first_field
01021      1  6                                          end
01022      1  5                               otherwise State := s_error
01023      1  4                               end;
01024      1  5           s_first_field   : case Class of
01025      1  5                               c_digit  : Day := 10 * Day + ord( Character ) - zero;
01026      1  5                               c_hyphen : State := s_hyphen_1;
01027      1  6                               c_slash  : begin  (*  Oops, try MM/DD/YY.  *)
01028      1  6                                          Month := Day;
01029      1  6                                          Day := 0;
01030      1  6                                          State := s_slash_1
01031      1  6                                          end
01032      1  5                               otherwise State := s_error
01033      1  4                               end;
01034      1  5           s_hyphen_1      : case Class of
01035      1  6                               c_letter : begin
01036      1  6                                          Month_String := Character;
01037      1  6                                          State := s_field_2_alpha
01038      1  6                                          end
01039      1  5                               otherwise State := s_error
01040      1  4                               end;
01041      1  5           s_field_2_alpha : case Class of
01042      1  5                               c_letter : Month_String := Month_String + Character;
01043      1  6                               c_hyphen : begin
01044      1  6                                          Month := index( Months, Month_String );
01045      1  6                                          if Month mod 3 <> 1 then
01046      1  6                                            State := s_error
01047      1  7                                          else begin

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   28
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (19)

-LINE-IDC-PL-SL-

01048      1  7                                            Month := ( Month + 2 ) div 3;
01049      1  7                                            State := s_hyphen_2
01050      1  7                                            end
01051      1  6                                          end
01052      1  5                               otherwise State := s_error
01053      1  4                               end;
01054      1  5           s_hyphen_2      : case Class of
01055      1  6                               c_digit  : begin
01056      1  6                                          Year := ord( Character ) - zero;
01057      1  6                                          State := s_field_3
01058      1  6                                          end
01059      1  5                               otherwise State := s_error
01060      1  4                               end;
01061      1  5           s_slash_1       : case Class of
01062      1  6                               c_digit  : begin
01063      1  6                                          Day := ord( Character ) - zero;
01064      1  6                                          State := s_field_2_num
01065      1  6                                          end
01066      1  5                               otherwise State := s_error
01067      1  4                               end;
01068      1  5           s_field_2_num   : case Class of
01069      1  5                               c_digit  : Day := 10 * Day + ord( Character ) - zero;
01070      1  5                               c_slash  : State := s_slash_2
01071      1  5                               otherwise State := s_error
01072      1  4                               end;
01073      1  5           s_slash_2       : case Class of
01074      1  6                               c_digit  : begin
01075      1  6                                          Year := ord( Character ) - zero;
01076      1  6                                          State := s_field_3
01077      1  6                                          end
01078      1  5                               otherwise State := s_error
01079      1  4                               end;
01080      1  5           s_field_3       : case Class of
01081      1  5                               c_digit  : Year := 10 * Year + ord( Character ) - zero;
01082      1  5                               c_eol    : State := s_done
01083      1  5                               otherwise State := s_error
01084      1  5                               end
01085      1  4           end  (*  case State of  *)
01086      1  2         until State in [ s_done, s_error ];
01087      1  2 
01088      1  3       if State = s_error then begin
01089      1  3         Output_String := '';
01090      1  4         with Output_Binary do begin
01091      1  4           L0 := 0;  L1 := 0
01092      1  3           end;
01093      1  3         RCS_Parse_Date := ss$_ivtime
01094      1  3         end
01095      1  3       else begin
01096      1  3         if Month in [ 1 .. 12 ] then
01097      1  3           Month_String := substr( Months, 3 * Month - 2, 3 );
01098      1  4         if length( Month_String ) = 0 then begin
01099      1  4           Output_String := '';
01100      1  5           with Output_Binary do begin
01101      1  5             L0 := 0;  L1 := 0
01102      1  4             end;

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   29
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (19)

-LINE-IDC-PL-SL-

01103      1  4           RCS_Parse_Date := ss$_ivtime
01104      1  4           end
01105      1  4         else begin
01106      1  4           if Year < 100 then
01107      1  4             Year := Year + 1900;
01108      1  4           writev( Date_String,
01109      1  4             Day:2, '-', Month_String, '-', Year:4, midnight );
01110      1  4           VMS_Date_Time := pad( Date_String, ' ', 23 );
01111      1  4           Status := $bintim( timbuf := VMS_Date_Time, timadr := Output_Binary );
01112      1  5           if not odd( Status ) then begin
01113      1  5             Output_String := '';
01114      1  6             with Output_Binary do begin
01115      1  6               L0 := 0;  L1 := 0
01116      1  5               end;
01117      1  5             RCS_Parse_Date := Status
01118      1  5             end
01119      1  5           else begin
01120      1  5             VMS_Date_Time[ 5 ] := chr( ord( VMS_Date_Time[ 5 ] ) + downcase );
01121      1  5             VMS_Date_Time[ 6 ] := chr( ord( VMS_Date_Time[ 6 ] ) + downcase );
01122      1  5             Output_String := substr( VMS_Date_Time, 1, 7 ) +
01123      1  5               substr( VMS_Date_Time, 10, 2 )
01124      1  5             end  (*  if not odd( Status ) else  *)
01125      1  4           end  (*  if length( Month_String ) = 0 else  *)
01126      1  3         end  (*  if State = s_error else  *)
01127      1  3 
01128      1  1       end;
01129      1  1 
01130      1  1     if iaddress( Date_String ) <> 0 then
01131      1  1       Date_Output := Output_String;
01132      1  1 
01133      1  1     if iaddress( Date_Binary ) <> 0 then
01134      1  1       Date_Binary := Output_Binary
01135      1  1 
01136      0  0   end;  (*  RCS_Parse_Date  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   30
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (20)

-LINE-IDC-PL-SL-

01138      1  0 [global] function RCS_Put_ASCIC(
01139      1  0   var Destination : packed array [ l1 .. u1 : integer ] of char;
01140      1  0   Source : varying [ u2 ] of char
01141      1  0   ) : unsigned;
01142      1  0 
01143   C  1  0   (*  RCS_Put_ASCII returns a system service completion code.
01144   C  1  0     The data from   Source   is copied into a counted ASCII string in
01145   C  1  0     Destination .  *)
01146      1  0 
01147      1  1   begin  (*  RCS_Put_ASCIC  *)
01148      1  1 
01149      1  2     if length( Source ) > ( U1 - L1 ) then begin
01150      1  2       RCS_Put_ASCIC := ss$_badparam;
01151      1  2       Destination := pad( '', '*', U1 - L1 + 1 )
01152      1  2       end
01153      1  2     else begin
01154      1  2       RCS_Put_ASCIC := ss$_normal;
01155      1  2       Destination := pad( chr( length( Source ) ) + Source, ' ', U1 - L1 + 1 )
01156      1  2       end
01157      1  2 
01158      0  0   end;  (*  RCS_Put_ASCIC  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   31
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (21)

-LINE-IDC-PL-SL-

01160      1  0 [global] function RCS_String_To_Integer(
01161      1  0   Buffer : varying [ Upper_Bound ] of char;
01162      1  0   var Value : integer
01163      1  0   ) : boolean;
01164      1  0 
01165   C  1  0   (*  Convert the contents of   Buffer   to an integer and return the
01166   C  1  0     result in   Value .  The value of   RCS_String_To_Integer   is   true
01167   C  1  0     if the conversion is successful, otherwise the value is false and
01168   C  1  0     Value   contains -1.  *)
01169      1  0 
01170      1  0   const
01171      1  0     Zero = ord( '0' );
01172      1  0 
01173      1  0   var
01174      1  0     Subscript, Sum, Digit : integer;
01175      1  0     Loop : boolean;
01176      1  0 
01177      1  1   begin  (*  RCS_String_To_Integer  *)
01178      1  1 
01179      1  1     Subscript := 1;
01180      1  1     Sum := 0;
01181      1  1     RCS_String_To_Integer := true;
01182      1  1 
01183      1  1     if length( Buffer ) > 0 then
01184      1  1       Loop := ( Buffer[ 1 ] in [ '0' .. '9' ] )
01185      1  1     else
01186      1  1       Loop := false;
01187      1  1 
01188      1  2     if not Loop then begin
01189      1  2       RCS_String_To_Integer := false;
01190      1  2       Sum := -1
01191      1  1       end;
01192      1  1 
01193      1  2     while Loop do begin
01194      1  2       Digit := ord( Buffer[ Subscript ] ) - Zero;
01195      1  2       if ( ( Sum < maxint div 10 ) or
01196      1  3         ( ( Sum = maxint div 10 ) and ( Digit <= maxint mod 10 ) ) ) then begin
01197   C  1  3         (*  Sum the digit.  *)
01198      1  3         Sum := Sum * 10 + Digit;
01199      1  3         Subscript := Subscript + 1;
01200      1  3         if Subscript > upper_bound then
01201      1  3           Loop := false
01202      1  3         else
01203      1  3           Loop := ( Buffer[ Subscript ] in [ '0' .. '9' ] )
01204      1  3         end
01205      1  3       else begin
01206   C  1  3         (*  Integer overflow.  *)
01207      1  3         Loop := false;
01208      1  3         RCS_String_To_Integer := false;
01209      1  3         Sum := -1
01210      1  3         end
01211      1  1       end;  (*  while Loop do  *)
01212      1  1 
01213      1  1     Value := Sum
01214      1  1 

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   32
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (21)

-LINE-IDC-PL-SL-

01215      0  0   end;  (*  RCS_String_To_Integer  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   33
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (22)

-LINE-IDC-PL-SL-

01217      1  0 [global] function RCS_Translate(
01218      1  0   Logical_Name    : varying[ u1 ] of char;
01219      1  0   Access_Mode     : ubyte := psl$c_user;
01220      1  0   Table_Name      : varying[ u3 ] of char := 'LNM$FILE_DEV';
01221      1  0   Index           : [volatile] integer := 0;
01222      1  0   var Translation : varying[ u5 ] of char;
01223      1  0   var Max_Index   : [truncate] integer
01224      1  0   ) : unsigned;
01225      1  0 
01226   C  1  0   (*  Translates   Logical_Name   and returns   Translation .  The translation
01227   C  1  0     is iterative if   Index   is 0, otherwise only one level of translation
01228   C  1  0     is performed and the specified equivalence name is returned.  This routine
01229   C  1  0     treats index 1 as the first equivalence name rather than index 0 as
01230   C  1  0     Sys$TrnLnm does.  All translations are case insensitive.
01231   C  1  0 
01232   C  1  0     The following status codes are returned:
01233   C  1  0 
01234   C  1  0       SS$_Abort        An unexpected error occurred.
01235   C  1  0       SS$_BadParam     Index   exceeded   Max_Index .
01236   C  1  0       SS$_NoLogNam     No logical name was found.
01237   C  1  0                          ( Translation   is set to   Logical_Name .)
01238   C  1  0       SS$_Normal       Normal successful completion.
01239   C  1  0       SS$_TooManyLNam  The maximum translation depth was exceeded.
01240   C  1  0       STS$K_Info       Successful completion with terminal attribute.
01241   C  1  0     *)
01242      1  0 
01243      1  0   const
01244      1  0     Escape = chr( 27 );  (*  ASCII escape.  *)
01245      1  0     Maximum_Translation_Depth = 10;
01246      1  0 
01247      1  0   var
01248      1  0     Item_List : packed array [ 1 .. 5 ] of rcs_item_list_3;
01249      1  0     Logical_Attribute : [volatile] unsigned;
01250      1  0     Equivalence_Name : [volatile] varying [ 512 ] of char;
01251      1  0     Maximum_Translations : integer;
01252      1  0     Exit_Status, Status : unsigned;
01253      1  0     Count : integer;
01254      1  0     Logical_Temp : varying[ 512 ] of char;
01255      1  0     Tmp_Max_Index : [volatile] integer;
01256      1  0 
01257      1  1   begin  (*  RCS_Translate  *)
01258      1  1 
01259      1  1     Exit_Status := 0;
01260      1  1     Count := 0;
01261      1  1     Logical_Temp := Logical_Name;
01262      1  1 
01263   C  1  1     (*  In order to be precise, the code handles   Maximum_Translations
01264   C  1  1       somewhat oddly.  The point is to guaratee that a logical name
01265   C  1  1       gets all of the translations due to it, and that any subsequent
01266   C  1  1       translation would fail.  This requires that we perform one
01267   C  1  1       additional translation, if we are iterating, and check to ensure
01268   C  1  1       that it fails.  *)
01269      1  1 
01270      1  1     if Index = 0 then
01271      1  1       Maximum_Translations := maximum_translation_depth

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   34
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (22)

-LINE-IDC-PL-SL-

01272      1  2     else begin
01273      1  2       Maximum_Translations := 1;
01274      1  2       Index := Index - 1;
01275      1  1       end;
01276      1  1 
01277      1  1     Item_List := zero;
01278      1  1 
01279      1  1     Item_List[1].Buffer_Length         := size( Index );
01280      1  1     Item_List[1].Item_Code             := lnm$_index;
01281      1  1     Item_List[1].Buffer_Address        := iaddress( Index );
01282      1  1 
01283      1  1     Item_List[2].Buffer_Length         := size( Equivalence_Name.Body );
01284      1  1     Item_List[2].Item_Code             := lnm$_string;
01285      1  1     Item_List[2].Buffer_Address        := iaddress( Equivalence_Name.Body ) ;
01286      1  1     Item_List[2].Return_Length_Address := iaddress( Equivalence_Name.Length );
01287      1  1 
01288      1  1     Item_List[3].Buffer_Length         := size( Tmp_Max_Index );
01289      1  1     Item_List[3].Item_Code             := lnm$_max_index;
01290      1  1     Item_List[3].Buffer_Address        := iaddress( Tmp_Max_Index ) ;
01291      1  1 
01292      1  1     Item_List[4].Buffer_Length         := size( Logical_Attribute );
01293      1  1     Item_List[4].Item_Code             := lnm$_attributes;
01294      1  1     Item_List[4].Buffer_Address        := iaddress( Logical_Attribute );
01295      1  1 
01296      1  2     repeat
01297      1  2 
01298      1  2       Status := $trnlnm(
01299      1  2          attr   := lnm$m_case_blind,
01300      1  2          tabnam := Table_Name,
01301      1  2          lognam := Logical_Temp,
01302      1  2          acmode := Access_Mode,
01303      1  2          itmlst := Item_List );
01304      1  2 
01305      1  2       if not odd( Status ) then
01306   C  1  2         (*  Translation failed.  *)
01307      1  2         if Status = ss$_nolognam then
01308      1  2           Exit_Status := ss$_nolognam
01309      1  2         else
01310      1  2           Exit_Status := ss$_abort
01311      1  2 
01312      1  3       else begin
01313   C  1  3         (*  Successful $trnlnm call.  *)
01314      1  3         if Index > Tmp_Max_Index then
01315      1  3           Exit_Status := ss$_badparam
01316      1  4         else begin
01317   C  1  4           (*  Index   is valid.  *)
01318      1  4           Count := Count + 1;
01319      1  4           if uand( Logical_Attribute, lnm$m_terminal ) <> 0 then
01320      1  4             Exit_Status := sts$k_info
01321      1  4           else
01322      1  4             Logical_Temp := Equivalence_Name;
01323      1  4           if ( Exit_Status = 0 ) and ( Equivalence_Name.Length > 0 ) then
01324      1  4             if Equivalence_Name[ 1 ] = escape then
01325   C  1  4               (*  Process permanent file, remove the escape and IFI later.  *)
01326      1  4               Exit_Status := ss$_normal;

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   35
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (22)

-LINE-IDC-PL-SL-

01327      1  3           end; (*  if Index > Tmp_Max_Index else  *)
01328      1  2         end; (*  if not odd( Status ) else  *)
01329      1  2 
01330      1  2       if ( Exit_Status = 0 ) and
01331      1  2         ( ( ( Count = 1 ) and ( Maximum_Translations = 1 ) ) or
01332      1  2         ( Count > Maximum_Translations ) ) then
01333      1  2         Exit_Status := ss$_normal
01334      1  2 
01335      1  1       until ( Exit_Status <> 0 );
01336      1  1 
01337      1  2     if Count > 0 then begin
01338   C  1  2       (*  At least one translation, count > 0.  *)
01339      1  2       if ( Maximum_Translations <> 1 ) then
01340      1  2         if Count > Maximum_Translations then
01341      1  2           if Exit_Status = ss$_nolognam then
01342   C  1  2             (*  Translation ended at   maximum_translation_depth .  *)
01343      1  2             Exit_Status := ss$_normal
01344      1  3           else begin
01345   C  1  3             (*  Translation continues beyond   maximum_translation_depth .  *)
01346      1  3             Exit_Status := ss$_toomanylnam;
01347      1  3             Translation := '';
01348      1  3             Tmp_Max_Index := -1
01349      1  3             end
01350      1  2         else if Exit_Status <> sts$k_info then
01351   C  1  2           (*  Translation ended before   maximum_translation_depth .  *)
01352      1  2           Exit_Status := ss$_normal
01353      1  1       end;  (*  At least one translation.  *)
01354      1  1 
01355      1  2     if ( Exit_Status = ss$_normal ) or ( Exit_Status = sts$k_info ) then begin
01356   C  1  2       (*  Success, copy data to the output parameters.  *)
01357      1  2       if Equivalence_Name[ 1 ] = escape then
01358   C  1  2         (*  Process permanent file, remove escape and IFI.  *)
01359      1  2         Translation := substr( Equivalence_Name, 5, Equivalence_Name.Length - 4 )
01360      1  2       else
01361   C  1  2         (*  Normal equivalence name.  *)
01362      1  2         Translation := Equivalence_Name;
01363      1  2       Tmp_Max_Index := Tmp_Max_Index + 1
01364      1  2       end
01365      1  2     else begin
01366   C  1  2       (*  Error, clear the output parameters.  *)
01367      1  2       Translation := '';
01368      1  2       Tmp_Max_Index := -1
01369      1  1       end;
01370      1  1 
01371      1  1     if present( Max_Index ) then
01372      1  1       Max_Index := Tmp_Max_Index;
01373      1  1     RCS_Translate := Exit_Status
01374      1  1 
01375      0  0   end;  (*  RCS_Translate  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   36
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (23)

-LINE-IDC-PL-SL-

01377      1  0 function RCS_Trim;
01378      1  0 
01379   C  1  0   (*  [global] function RCS_Trim(
01380   C  1  0         Data : varying[ u1 ] of char
01381   C  1  0         ) : varying_string;  *)
01382      1  0 
01383      1  0   var
01384      1  0     Trimmed_String : varying_string;
01385      1  0 
01386   C  1  0   (*  Trim trailing blanks and tabs from   Data .  *)
01387      1  0 
01388      1  1   begin  (*  RCS_Trim  *)
01389      1  1 
01390      1  1     str$trim( Trimmed_String, Data );
01391      1  1     RCS_Trim := Trimmed_String
01392      1  1 
01393      0  0   end;  (*  RCS_Trim  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   37
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (24)

-LINE-IDC-PL-SL-

01395      1  0 function RCS_Trim_Leading;
01396      1  0 
01397   C  1  0    (*   [global] function RCS_Trim_Leading(
01398   C  1  0           Data : varying [ u1 ] of char
01399   C  1  0           ) : varying_string;  *)
01400      1  0 
01401   C  1  0   (*  Trim leading blanks and tabs from   Data .  *)
01402      1  0 
01403      1  0   var
01404      1  0     Subscript : integer;
01405      1  0     Table : [static] packed array [ 0 .. 255 ] of ubyte := (
01406      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 1, 0, 0, 0, 0, 0, 0,
01407      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01408      1  0       1, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01409      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01410      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01411      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01412      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01413      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01414      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01415      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01416      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01417      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01418      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01419      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01420      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0,
01421      1  0       0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 );
01422      1  0 
01423      1  1   begin  (*  RCS_Trim_Leading  *)
01424      1  1 
01425      1  1     Subscript := lib$spanc( Data, Table, -1 );
01426      1  1     if Subscript = 0 then
01427      1  1       RCS_Trim_Leading := ''
01428      1  1     else
01429      1  1       RCS_Trim_Leading := substr( Data, Subscript,
01430      1  1         length( Data ) - Subscript + 1 )
01431      1  1 
01432      0  0   end;  (*  RCS_Trim_Leading  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   38
1-002                           Source Listing                   3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (25)

-LINE-IDC-PL-SL-

01434      1  0 [global] function RCS_Upcase(
01435      1  0   Data : varying[ u1 ] of char
01436      1  0   ) : varying_string;
01437      1  0 
01438      1  0   var
01439      1  0     Upcased_String : varying_string;
01440      1  0 
01441   C  1  0   (*  Upcase all letters in   Data .  *)
01442      1  0 
01443      1  1   begin  (*  RCS_Upcase  *)
01444      1  1 
01445      1  1     str$upcase( Upcased_String, Data );
01446      1  1     RCS_Upcase := Upcased_String
01447      1  1 
01448      0  0   end;  (*  RCS_Upcase  *)
01449      0  0 
01450      0  0 
01451      0  0 
01452      0  0 end.  (*   Module RCS_Routines.  *)

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   39
1-002                           Pascal Compilation Statistics    3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (25)

PSECT SUMMARY

        Name                     Bytes                         Attributes

$CODE                                9285  NOVEC,NOWRT,  RD,  EXE,  SHR,  LCL,  REL,  CON,  PIC,ALIGN(2)
$LOCAL                                356  NOVEC,  WRT,  RD,NOEXE,NOSHR,  LCL,  REL,  CON,  PIC,ALIGN(2)


ENVIRONMENT STATISTICS

                                                       -------- Symbols --------
        File                                           Total    Loaded   Percent

SYS$COMMON:[SYSLIB]STARLET.PEN;2                       34364      1205         4
MANAGER:[SYSLIB]RCS_RTL.PEN;5                            989        93         9


COMMAND QUALIFIERS

  PASCAL/CHECK=ALL/USAGE=ALL/LIST/ENVIRONMENT RCS_ROUTINES

  /CHECK=(BOUNDS,CASE_SELECTORS,DECLARATIONS,OVERFLOW,POINTERS,SUBRANGE)
  /DEBUG=(NOSYMBOLS,TRACEBACK)
  /NODESIGN
  /SHOW=(DICTIONARY,INCLUDE,NOINLINE,HEADER,SOURCE,STATISTICS,TABLE_OF_CONTENTS)
  /OPTIMIZE
  /STANDARD=NONE
  /TERMINAL=(NOFILE_NAME,NOROUTINE_NAME,NOSTATISTICS)
  /USAGE=(UNUSED,UNINITIALIZED,UNCERTAIN)
  /NOANALYSIS_DATA
  /ENVIRONMENT=USERDISK:[DECUS.RCS.SYSLIB]RCS_ROUTINES.PEN;5
  /LIST=USERDISK:[DECUS.RCS.SYSLIB]RCS_ROUTINES.LIS;5
  /OBJECT=USERDISK:[DECUS.RCS.SYSLIB]RCS_ROUTINES.OBJ;2
  /NOCROSS_REFERENCE /ERROR_LIMIT=30 /NOG_FLOATING /NOMACHINE_CODE /NOOLD_VERSION /WARNINGS


COMPILER INTERNAL TIMING

  Phase                 Faults       CPU Time      Elapsed Time
  Initialization          209        00:00.1          00:00.3
  Source Analysis        2727        00:03.8          00:07.8
  Source Listing           67        00:00.7          00:01.3
  Tree Construction       289        00:00.4          00:00.5
  Flow Analysis            93        00:00.3          00:00.3
  Value Propagation        23        00:00.1          00:00.1
  Profit Analysis          64        00:00.2          00:00.2
  Context Analysis        462        00:02.4          00:03.0
  Name Packing              7        00:00.1          00:00.1
  Code Selection          176        00:00.5          00:00.6
  Final                   149        00:01.0          00:01.7
  TOTAL                  4272        00:09.7          00:15.9


COMPILATION STATISTICS

  CPU Time:       00:09.7         (9028 Lines/Minute)
  Elapsed Time:   00:15.9

RCS_ROUTINES                                                     2-Dec-1992 14:00:33    VAX Pascal V4.3-76                 Page   40
1-002                           Pascal Compilation Statistics    3-Dec-1991 13:20:46    [DECUS.RCS.SYSLIB]RCS_ROUTINES.PAS;1 (25)

  Page Faults:    4272
  Pages Used:     3760
  Compilation Complete
