$! ------------------ CUT HERE -----------------------
$ v='f$verify(f$trnlnm("SHARE_VERIFY"))'
$!
$! This archive created by VMS_SHARE Version 7.2-007  22-FEB-1990
$!   On 26-MAY-1992 17:15:53.12   By user MASLIB 
$!
$! This VMS_SHARE Written by:
$!    Andy Harper, Kings College London UK
$!
$! Acknowledgements to:
$!    James Gray       - Original VMS_SHARE
$!    Michael Bednarek - Original Concept and implementation
$!
$!+ THIS PACKAGE DISTRIBUTED IN 14 PARTS, TO KEEP EACH PART
$!  BELOW 30 BLOCKS
$!
$! TO UNPACK THIS SHARE FILE, CONCATENATE ALL PARTS IN ORDER
$! AND EXECUTE AS A COMMAND PROCEDURE  (  @name  )
$!
$! THE FOLLOWING FILE(S) WILL BE CREATED AFTER UNPACKING:
$!       1. M1.PAS;1
$!       2. M10.PAS;1
$!       3. M2.PAS;1
$!       4. M3.PAS;1
$!       5. M4.PAS;1
$!       6. M5.PAS;1
$!       7. M6.PAS;1
$!       8. M7.PAS;1
$!       9. M7_2.PAS;1
$!      10. M7_3.PAS;1
$!      11. M9.PAS;1
$!      12. M9_2.PAS;1
$!      13. MON.PAS;1
$!      14. XBUILD.COM;6
$!      15. XLINK.COM;1
$!      16. XPAS.COM;1
$!
$set="set"
$set symbol/scope=(nolocal,noglobal)
$f=f$parse("SHARE_TEMP","SYS$SCRATCH:.TMP_"+f$getjpi("","PID"))
$e="write sys$error  ""%UNPACK"", "
$w="write sys$output ""%UNPACK"", "
$ if f$trnlnm("SHARE_LOG") then $ w = "!"
$ ve=f$getsyi("version")
$ if ve-f$extract(0,1,ve) .ges. "4.4" then $ goto START
$ e "-E-OLDVER, Must run at least VMS 4.4"
$ v=f$verify(v)
$ exit 44
$UNPACK: SUBROUTINE ! P1=filename, P2=checksum
$ if f$search(P1) .eqs. "" then $ goto file_absent
$ e "-W-EXISTS, File ''P1' exists. Skipped."
$ delete 'f'*
$ exit
$file_absent:
$ if f$parse(P1) .nes. "" then $ goto dirok
$ dn=f$parse(P1,,,"DIRECTORY")
$ w "-I-CREDIR, Creating directory ''dn'."
$ create/dir 'dn'
$ if $status then $ goto dirok
$ e "-E-CREDIRFAIL, Unable to create ''dn'. File skipped."
$ delete 'f'*
$ exit
$dirok:
$ w "-I-PROCESS, Processing file ''P1'."
$ if .not. f$verify() then $ define/user sys$output nl:
$ EDIT/TPU/NOSEC/NODIS/COM=SYS$INPUT 'f'/OUT='P1'
PROCEDURE Unpacker ON_ERROR ENDON_ERROR;SET(FACILITY_NAME,"UNPACK");SET(
SUCCESS,OFF);SET(INFORMATIONAL,OFF);f:=GET_INFO(COMMAND_LINE,"file_name");b:=
CREATE_BUFFER(f,f);p:=SPAN(" ")@r&LINE_END;POSITION(BEGINNING_OF(b));
LOOP EXITIF SEARCH(p,FORWARD)=0;POSITION(r);ERASE(r);ENDLOOP;POSITION(
BEGINNING_OF(b));g:=0;LOOP EXITIF MARK(NONE)=END_OF(b);x:=ERASE_CHARACTER(1);
IF g=0 THEN IF x="X" THEN MOVE_VERTICAL(1);ENDIF;IF x="V" THEN APPEND_LINE;
MOVE_HORIZONTAL(-CURRENT_OFFSET);MOVE_VERTICAL(1);ENDIF;IF x="+" THEN g:=1;
ERASE_LINE;ENDIF;ELSE IF x="-" THEN IF INDEX(CURRENT_LINE,"+-+-+-+-+-+-+-+")=
1 THEN g:=0;ENDIF;ENDIF;ERASE_LINE;ENDIF;ENDLOOP;t:="0123456789ABCDEF";
POSITION(BEGINNING_OF(b));LOOP r:=SEARCH("`",FORWARD);EXITIF r=0;POSITION(r);
ERASE(r);x1:=INDEX(t,ERASE_CHARACTER(1))-1;x2:=INDEX(t,ERASE_CHARACTER(1))-1;
COPY_TEXT(ASCII(16*x1+x2));ENDLOOP;WRITE_FILE(b,GET_INFO(COMMAND_LINE,
"output_file"));ENDPROCEDURE;Unpacker;QUIT;
$ delete/nolog 'f'*
$ CHECKSUM 'P1'
$ IF CHECKSUM$CHECKSUM .eqs. P2 THEN $ EXIT
$ e "-E-CHKSMFAIL, Checksum of ''P1' failed."
$ ENDSUBROUTINE
$START:
$ create 'f'
X`5BInherit('Sys$Library:Starlet',
X         'Sys$Library:Pascal$Smg_Routines',
X         'Sys$Library:Pascal$Lib_Routines',
X         'Sys$Library:Pascal$Mth_Routines'),
X Environment('M1')`5D
X
XModule M1;
X
XConst
X  DivLine = '---------------------------------------';
X           (*1234567890123456789012345678901234567890*)
XType
X  Short_String_Type = Varying`5B20`5D Of Char;
X  String_Type = Varying`5B80`5D Of Char;
X  Long_String_Type = Varying`5B256`5D Of Char;
X
X  $Byte = `5BByte`5D -128..127;
X  $Word = `5BWord`5D -32768..32767;
X  $UByte = `5BByte`5D 0..255;
X  $UWord = `5BWord`5D 0..65535;
X  $ULong = `5BLong`5D Unsigned;
X
X  $UQuad = Record
X    Q1, Q2 : $ULong;
X  End;
X
X
X`5BHidden`5D
XVar
X  Seed : Unsigned;
X  OutChan : $UWord;
X  Kbd_Id : Unsigned;
X  InLine : Long_String_Type := '';
X  Prompt : String_Type := '';
X  PrnPrompt : Boolean := True;
X  InputFromFile : Boolean := False;
X  OutputToFile  : Boolean := False;
X  InputFile  : Text;
X  OutputFile : Text;
X  TimerContext : Unsigned;
X
X`5BExternal, Hidden`5D
XProcedure Driver; External;
X
XProcedure SysCall( S : `5BUnsafe`5D Unsigned );
XBegin
X  If Not Odd(S) Then Lib$Signal(S);
XEnd;
X
XProcedure Wait(Sec : Real);
XBegin
X  SysCall( Lib$Wait(Sec) );
XEnd;
X
XFunction Rnd(Max : $UWord): $UWord;
XBegin
X  Rnd := Round(Mth$Random(Seed)*Max);
XEnd;
X
X(* String function *)
X
XFunction LowCase(S : String_Type): String_Type;
XVar I : $UWord;
XBegin
X  If S.Length > 0 Then For I := 1 To S.Length Do
X    If S`5BI`5D In `5B'A'..'Z'`5D Then
X      S`5BI`5D := Chr(Ord('a') + ( Ord(S`5BI`5D) - Ord('A') ));
X  LowCase := S;
XEnd;
X
XFunction PadStr(S : String_Type; Pos : $UWord): String_Type;
XVar I : $UWord;
XBegin
X  If S.Length < Pos Then For I := S.Length + 1 To Pos Do
X    S := S + ' ';
X  PadStr := S;
XEnd;
X
XFunction Slead(S : String_Type): String_Type;
XVar I : $UWord; Done : Boolean := False;
XBegin
X  I := 0;
X  While Not Done Do Begin
X    I := I + 1;
X    If I > S.Length Then Done := True
X    Else Done := ( (S`5BI`5D <> ' ') And (S`5BI`5D <> Chr(9)) );
X  End;
X  If I > S.Length Then Slead := ''
X  Else Slead := Substr(S, I, S.Length - I + 1);
XEnd;
X
XFunction Trim(S : String_Type): String_Type;
XVar I : $UWord; Done : Boolean := False;
XBegin
X  I := S.Length + 1;
X  While Not Done Do Begin
X    I := I - 1;
X    If I = 0 Then Done := True
X    Else Done := ( (S`5BI`5D <> ' ') And (S`5BI`5D <> Chr(9)) );
X  End;
X  If I = 0 Then Trim := ''
X  Else Trim := Substr(S, 1, I);
XEnd;
X
XFunction Bite(Var S : String_Type; I : $UWord := 0): String_Type;
XVar Done : Boolean := False;
XBegin
X  While Not Done Do Begin
X    I := I + 1;
X    If I > S.Length Then Done := True
X    Else Done := (S`5BI`5D = ' ');
X  End;
X  If I > S.Length Then Begin
X    Bite := S; S := '';  End
X  Else Begin
X    Bite := Slead(Trim(Substr(S, 1, I)));
X    S := Slead(Trim(Substr(S, I+1, S.Length - I)));
X  End;
XEnd;
X
X`5BHidden`5D
XFunction ParseStr(S : String_Type; S1 : String_Type; Var Pos : $UWord;
X   Var Exact : Boolean): Boolean;
XVar  Done, Term : Boolean := False;
XBegin
X  S := LowCase(S); S1 := LowCase(S1); Pos := 1;
X  If (S.Length = 0) Or (S1.Length = 0) Then Begin
X    ParseStr := False;  Pos := 0;  Exact := False;  End
X  Else While Not Done Do
X    If (Pos > S1.Length) Then Begin           (* parse exact *)
X      Done := True; ParseStr := True; Pos := Pos - 1; Exact := True;  End
X    Else If (Pos > S.Length) Then Begin       (* parse match *)
X      Done := True; ParseStr := True; Pos := Pos - 1; Exact := False;  End
X    Else If (S`5BPos`5D <> S1`5BPos`5D) Then Begin    (* maybe, maybe not *)
X      Done := True;
X      If (S`5BPos`5D = ' ') Then Begin                (* match *)
X        ParseStr := True; Pos := Pos - 1; Exact := False;  End
X      Else If Term Then Begin                     (* match *)
X        ParseStr := True;  Pos := Pos - 2; Exact := False; End
X      Else Begin                                  (* no match *)
X        ParseStr := False; Pos := Pos - 1; Exact := False;
X      End;  End
X    Else Begin                                (* keep going *)
X      Term := (S`5BPos`5D = ' '); Pos := Pos + 1;  End;
XEnd;
X
XFunction ParseLine(Var S1 : String_Type; Var Index : $UWord;
X  IsFirst : Boolean := False; IsLast : Boolean := False): Boolean;
XVar S : `5BStatic`5D String_Type; Log, Pos, NewPos : `5BStatic`5D $UWord;
X  FoundOne, FoundExact, Exact : `5BStatic`5D Boolean;
XBegin
X  If IsFirst Then Begin      (* first call *)
X    S := S1; Log := 0; Pos := 0; NewPos := 0; FoundOne := False;
X    FoundExact := False; Exact := False; ParseLine := False;  End
X  Else If IsLast Then Begin  (* last call *)
X    If FoundOne Then Begin
X      Bite(S1, Pos); Index := Log; ParseLine := True; End
X    Else Begin
X      S1 := ''; Index := 0; ParseLine := False;
X    End;  End
X  Else If ParseStr(S, S1, NewPos, Exact) Then Begin  (* parsing *)
X    If Not FoundOne Then Begin          (* first found *)
X      Log := Index; FoundOne := True;
X      FoundExact := Exact; Pos := NewPos;  End
X    Else If (NewPos > Pos) Then Begin    (* more likely match *)
X      Log := Index; FoundExact := Exact; Pos := NewPos;  End
X    Else If (NewPos = Pos) And
X       (Exact And Not FoundExact) Then Begin  (* exact match *)
X      Log := Index; FoundExact := True;  End;
X    ParseLine := False;
X  End;
XEnd;
X
XFunction ParseTable(Table : Array`5BLower..Upper: Integer`5D Of Short_String
V_Type;
X   Var S : String_Type; Var Index : $UWord): Boolean;
XVar I, N : $UWord; Tmp : String_Type;
XBegin
X  ParseLine(S, Index, TRUE, FALSE);
X  For I := Lower To Upper Do Begin
X    Tmp := Table`5BI`5D; N := I; ParseLine(Tmp, N);
X  End;
X  ParseTable := ParseLine(S, Index, FALSE, TRUE);
XEnd;
X
XFunction NumberW(Var S : String_Type): $UWord;
XVar I, Num : $UWord; Head : String_Type;
XBegin
X  I := Index(S, ' ');
X  If (I > 1) Then Begin
X    Head := Trim(SubStr(S, 1, I));
X    S := Slead(SubStr(S, I, S.Length - I + 1));  End
X  Else Begin
X    Head := S;  S := '';
X  End;
X  ReadV(Head, Num, Error := Continue);
X  NumberW := Num;
XEnd;
X
XFunction NumberI(Var S : String_Type): Integer;
XVar I, Num : Integer; Head : String_Type;
XBegin
X  I := Index(S, ' ');
X  If (I > 1) Then Begin
X    Head := Trim(SubStr(S, 1, I));
X    S := Slead(SubStr(S, I, S.Length - I + 1));  End
X  Else Begin
X    Head := S;  S := '';
X  End;
X  ReadV(Head, Num, Error := Continue);
X  NumberI := Num;
XEnd;
X
X(* Screen management function *)
X
XProcedure PutLine(S : Long_String_Type; ExtraLine : $UWord := 0);
XVar Msg : Packed Array`5B1..256`5D Of Char; Len, I : $UWord;
XBegin
X  If OutputToFile Then
X    Writeln(OutputFile, S, Error := Continue);
X  If (ExtraLine > 0) Then For I := 1 To ExtraLine Do
X    S := S + Chr(13) + Chr(10);
X  Msg := Chr(13) + Chr(10) + S;  Len := Length(s) + 2;
X  SysCall( $Qiow(, OutChan, IO$_WRITEVBLK,,,, Msg, Len,,,,) );
X  PrnPrompt := True;
XEnd;
X
X`5BHidden`5D
XProcedure PutChars(S : Long_String_Type);
XVar Msg : Packed Array`5B1..256`5D Of Char; Len : $UWord;
XBegin
X  Msg := S;  Len := Length(S);
X  SysCall( $Qiow(, OutChan, IO$_WRITEVBLK,,,, Msg, Len,,,,) );
XEnd;
X
X`5BHidden`5D
XFunction KeyGet : Char;
XVar Term : `5BStatic`5D $UWord := 0;
XBegin
X  If PrnPrompt Then Begin
X    PutChars(Chr(13)+Chr(10)+Prompt+InLine); PrnPrompt := False;
X  End;
X  If ( Smg$Read_Keystroke(Kbd_Id, Term,, 0,,,) Mod 2 ) = 0 Then KeyGet := Ch
Vr(0)
X  Else KeyGet := Chr(Term);
XEnd;
X
X`5BHidden`5D
XFunction KeyStroke : Char;
XVar Ch : Char;
XBegin
X  Ch := KeyGet;
X  While Ch = Chr(0) Do Begin
X    Driver; Wait(0.1); Ch := KeyGet;
X  End;
X  KeyStroke := Ch;
XEnd;
X
X`5BHidden`5D `20
XProcedure Grab_Line_Prime(Var S : String_Type);
XVar Ch : Char;
XBegin
X  PrnPrompt := True;
X  Ch := KeyStroke;
X  While (Ch <> Chr(13)) And (Length(InLine) < 72) Do Begin
X    If (Ch = Chr(8)) Or (Ch = Chr(127)) Then Begin       (* Delete character
V *)
X      If InLine.Length = 1 Then Begin
X        InLine := ''; PutChars(Chr(8)+' '+Chr(8)); End
X      Else If InLine.Length > 1 Then Begin
X        InLine := Substr(InLine, 1, InLine.Length-1);
X        PutChars(Chr(8)+' '+Chr(8));
X      End;  End
X    Else if Ch = Chr(21) Then Begin                      (* Delete line *)
X      InLine := ''; PutChars(Chr(13)+Chr(27)+'`5BK'+Prompt);  End
X    Else If ((Ord(Ch)>31) And (Ord(Ch)<127)) Then Begin  (* Default *)
X      InLine := InLine + Ch; PutChars(Ch);
X    End;
X    Ch := KeyStroke;
X  End;
X  PutChars(Chr(13)); PrnPrompt := True; S := InLine;
X  If OutputToFile Then Writeln(OutputFile, Prompt+InLine, Error := Continue)
V;
X  InLine := '';
XEnd;
X
X(* Input/Output function *)
X
X`5BHidden`5D
XFunction ReadFromFile(Var S : String_Type): Boolean;
XVar Done, ReadIn : Boolean := False;
XBegin
X  Done := Eof(InputFile);
X  While Not Done Do Begin
X    ReadLn(InputFile, S);
X    If (S.Length = 0) Then ReadIn := False
X    Else If (S`5B1`5D <> ';') Then ReadIn := True
X    Else ReadIn := False;
X    Done := ReadIn Or Eof(InputFile);
X    PutLine('%'+S);
X  End;
X  If ReadIn Then ReadFromFile := True
X  Else Begin
X    ReadFromFile := False;  InputFromFile := False;  Close(InputFile);
X  End;
XEnd;
X
XProcedure GrabLine(NewPrompt : String_Type; Var S : String_Type;
X   Process : Boolean := True);
XBegin
X  Prompt := NewPrompt;
X  If (S.Length > 0) Then Driver
X  Else If Not InputFromFile Then Grab_Line_Prime(S)
X  Else If Not ReadFromFile(S) Then Grab_Line_Prime(S);
X  If Process Then S := Slead(Trim(S));
XEnd;
X
XFunction GrabNumberW(Prompt : String_Type; Var S : String_Type): $UWord;
XBegin
X  While S.Length = 0 Do GrabLine(Prompt, S);
X  GrabNumberW := NumberW(S);
XEnd;
X
XFunction GrabNumberI(Prompt : String_Type; Var S : String_Type): Integer;
XBegin
X  While S.Length = 0 Do GrabLine(Prompt, S);
X  GrabNumberI := NumberI(S);
XEnd;
X
XFunction GrabBoolean(Prompt : String_Type; Var S : String_Type): Boolean;
XBegin
X  While S.Length = 0 Do GrabLine(Prompt, S);
X  If (S`5B1`5D = 'T') Or (S`5B1`5D = 't') Then Begin
X    GrabBoolean := True;
X    Bite(S);
X  End Else Begin
X    GrabBoolean := False;
X    S := '';
X  End;
XEnd;
X
XFunction GrabShortStr(Prompt : String_Type; Var S : String_Type): Short_Stri
Vng_Type;
XBegin
X  While S.Length = 0 Do GrabLine(Prompt, S);
X  GrabShortStr := Bite(S);
XEnd;
X
XProcedure PrintTable(Table : Array`5BLower..Upper: Integer`5D Of Short_Strin
Vg_Type);
XVar I : $UWord; Tmp : Long_String_Type := ''; S : String_Type := '';
XBegin
X  For I := Lower To Upper Do Begin
X    Tmp := Tmp + PadStr(Table`5BI`5D, 21);
X    If Tmp.Length < 80 Then S := Tmp
X    Else Begin
X      Putline(S); Tmp := PadStr(Table`5BI`5D, 21);
X    End;
X  End;
X  PutLine(Tmp);
XEnd;
X
XProcedure PrintStr(Str : String_Type := '');
XVar S : `5BStatic`5D String_Type := ''; Tmp : `5BStatic`5D Long_String_Type
V := '';
XBegin
X  If Str.Length = 0 Then Begin
X    Putline(Tmp); S := ''; Tmp := '';  End
X  Else Begin
X    Tmp := Tmp + PadStr(Str, 21);
X    If Tmp.Length < 80 Then S := Tmp
X    Else Begin
X      PutLine(S); Tmp := PadStr(Str, 21);
X    End;
X  End;
XEnd;
X
XFunction GrabTable(Prompt : String_Type;
X   Table : Array`5BLower..Upper:Integer`5D Of Short_String_Type;
+-+-+-+-+-+-+-+-  END  OF PART 1 +-+-+-+-+-+-+-+-