home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / VAXTURBO.ZIP / VAXTURBO.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1987-07-22  |  33.6 KB  |  1,175 lines
  1. {
  2. [ENVIRONMENT('VaxTurbo')]
  3. MODULE VaxTurbo ( output );
  4. }
  5.  
  6. TYPE    LString =   VARYING [2048] OF CHAR;
  7.  
  8. { Suplementry String functions and procedures for Turbo Pascal  }
  9. { Extended for VAX Pascal - wml }
  10. (*
  11.        Written by: Tryg Helseth
  12.                    Minneapolis, Minnesota
  13.  
  14.     Last Revision: 1/4/85
  15.  
  16.         Revised for VAX Pascal by: 
  17.                     Walter M. Lamia
  18.                     Digital Equipment Corp.
  19.                     Nashua, NH.
  20.  
  21.                     May 8, 1986
  22.  
  23.  
  24. USAGE NOTES:
  25.  
  26.   The following routines provide common string functions that are
  27.   not supplied with Turbo Pascal.  Many are patterned (and named)
  28.   after the General Electric Information Service COompany (GEISCO)
  29.   FORTRAN 77 string routines; others mimic SNOBOL primatives.
  30.  
  31.   The general calling sequence is:
  32.  
  33.      OutString := Func(InpString[,Parms])
  34.  
  35.   where:
  36.  
  37.      OutString = the output or target string,
  38.           Func = function name,
  39.         InpStr = Input String,
  40.        [Parms] = Additional parameter(s) used by some functions.
  41.  
  42. AVAILABLE FUNCTIONS:
  43.  
  44. #   Copy        Emulates Turbo Pascal Copy built-in.
  45. ##  Pos_        Emulates Turbo Pascal Pos built-in.
  46. **  Str         Converts numeric value to string -- INTEGER ONLY VERSION.
  47. **  Val         Converts string expression to numeric value -- INTEGER ONLY.
  48.  
  49.     LoCase      Convert a single character to lower case.
  50. #   UpCase      Convert a single character to upper case.
  51.     LowerCase   Convert a string to lower case.
  52.     UpperCase   Convert a string to upper case.
  53.     TrimL       Trim Left: remove leading spaces from a string.
  54.     TrimR       Trim Right: remove trailing spaces from a string.
  55.     PadL        Pad Left: Add leading spaces to give desired field length.
  56.     PadR        Pad Right: Add trailing spaces to give desired field length.
  57.     JustL       Left Justify a string within a desired field length.
  58.     JustR       Right Justify a string within a desired field length.
  59.     Center      Center a string within a desired field length.
  60.     GetStr      Get String: Extracts a substring up to a specified delimiter.
  61.     Break       Extracts a substring up to the first of several delimters.
  62.     Span        Extracts a substring of delimiters up to a NON delimiter.
  63.     Compress    Replaces whitespace (tabs and/or spaces) with single space.
  64.     Squish      Trims off leading, trailing spaces and compresses.
  65.  
  66.     Note: GetStr, Span, and Break, modify the input string.  The other
  67.           functions do not modify any parameters.
  68.  
  69. AVAILABLE PROCEDURES:
  70.  
  71. ##  Delete_     Emulates Turbo Pascal Delete built-in.
  72.  
  73. #   Insert      Emulates Turbo Pascal Insert built-in.
  74.  
  75.     GString     Get String: Used by Span and Break functions.  It performs
  76.                 both functions and allows more control by the programmer.
  77.  
  78.     Substitute  Replace one substring with another in target string.
  79.  
  80. **    RealStr     Convert a value of type REAL to a string representation in
  81. **                any base from 2 to 36.
  82. **
  83. **    RealVal     Convert a string representation of a number to a REAL value.
  84. **                The number may be in any base from 2 to 36.
  85. **
  86.  
  87. #  ==> emulations of Turbo built-in's in VAX Pascal
  88. ## ==> emulations, but with "_" appended to name to avoid VAX Pascal conflicts
  89. ** ==> changed in VAX Pascal version to use WRITEV and READV built-ins.
  90.  
  91.  
  92. TYPE DECLARATION:
  93.  
  94.   All strings are of the type, LString, which should be declared in the main
  95.   program as:
  96.  
  97.       Type LString = string[n]            <== for Turbo Pascal
  98.       Type LString = VARYING [n] OF CHAR  <== for VAX Pascal
  99.  
  100.   where n is a constant in the range of 1 to 255 for Turbo Pascal
  101.     "   "  " "     "     "  "    "   "  1 to 65535 for VAX Pascal.
  102.  
  103.   If you wish to use these functions with strings of different declared
  104.   lengths, then you must use the compiler option, $V- (Turbo Pascal),
  105.   or the [UNSAFE] VAX Pascal attribute on function and formal parameter
  106.   declarations (not recommended).  
  107.  
  108.   If you choose to do this, be sure that the defined length of LString is
  109.   greater than or equal to the longest string you will be using. 
  110. *)
  111. (*  STRING FUNCTION DECLARATIONS:   *)
  112. {===========================================}
  113. procedure Delete_ (VAR InpStr : LString;   
  114.                        FieldPos : Integer;  
  115.                        FieldLen : Integer); forward;
  116. {===========================================}
  117. {
  118. N.B. -- Name is "Delete_" to avoid conflict with VAX Delete I/O procedure.
  119.  
  120. Purpose:        Provide same function as Turbo Pascal Delete procedure.
  121.  
  122.                 Remove substring starting at FieldPos, containing
  123.                 FieldLen characters.
  124.  
  125.                 If FieldPos > length(InpStr), no characters are removed.
  126.                 If FieldLen extends beyond end-of-string, only characters
  127.                 within the string are deleted.
  128.  
  129.                 St := 'ABCEDFG';
  130.                 Delete_(St,2,4);  ==> St value of 'AFG'
  131.                 Delete_(St,2,10); ==> St value of 'A'
  132.  
  133. Parameters:
  134.     Input:      InpStr = string from which substring will be removed.
  135.                 FieldPos = starting position of substring to remove.
  136.                 FieldLen = length of substring to remove.
  137.  
  138.     Output:     Modified InpStr, with substring removed.
  139. }
  140.  
  141. {===========================================}
  142. procedure Insert (    ObjStr : LString;  
  143.                   VAR InpStr : LString;  
  144.                       FieldPos : Integer); forward;
  145. {===========================================}
  146. {
  147. Purpose:        Provide same function as Turbo Pascal Insert procedure.
  148.  
  149.                 Inserts substring ObjStr into InpStr at FieldPos.
  150.  
  151.                 If FieldPos > length(InpStr), ObjStr is appended to InpStr.
  152.  
  153.                 St := 'ABCEDFG';
  154.                 Insert ('XX',St,3);  ==> St value of 'ABXXCDEFG'
  155.                 Insert ('XX',St,1);  ==> St value of 'XXABCDEFG'
  156.                 Insert ('XX',St,length(St));  ==> St value of 'ABCDEFXXG'
  157.  
  158. Parameters:
  159.     Input:      ObjStr = substring to insert.
  160.                 InpStr = string in which substring will be inserted.
  161.                 FieldPos = position, left of which substring is inserted.
  162.  
  163.     Output:     Modified InpStr, with substring inserted.
  164. }
  165.  
  166. {===========================================}
  167. function Copy(InpStr: LString;  FieldPos, FieldLen: integer): LString; forward;
  168. {===========================================}
  169. {
  170. Purpose:        Provide same function as Turbo Pascal Copy function.
  171.  
  172.                 Exactly same thing as VAX function 
  173.  
  174.                     Substr(InpStr, FieldPos, FieldLen)
  175.  
  176.                 but with some extra error checking.
  177. }
  178. {===========================================}
  179. function Pos_( ObjStr, InpStr: LString): Integer; forward;
  180. {===========================================}
  181. {
  182. N.B. -- Name is "Pos_" to avoid conflict with VAX Pos function.
  183.  
  184. Purpose:        Provide same function as Turbo Pascal Pos procedure.
  185.  
  186.                 Exactly same thing as VAX function 
  187.  
  188.                    Index(InpStr, ObjStr)
  189.  
  190.                 but with the arguments reversed.
  191. }
  192. {===========================================}
  193. function LoCase(InChar: char): char; forward;
  194. {===========================================}
  195. {
  196. Purpose:        Convert a single character to lower case.
  197.  
  198. Parameters:
  199.      Input:     InChar = character to be converted.
  200.     Output:     none
  201.  
  202. Function Value: LoCase = converted character.
  203. }
  204.  
  205. {===========================================}
  206. function UpCase(InChar: char): char; forward;
  207. {===========================================}
  208. {
  209. Purpose:        Convert a single character to upper case.
  210.  
  211. Parameters:
  212.      Input:     InChar = character to be converted.
  213.     Output:     none
  214.  
  215. Function Value: UpCase = converted character.
  216. }
  217.  
  218. {====================================================}
  219. function LowerCase(InpStr: LString): LString; forward;
  220. {====================================================}
  221. {
  222. Purpose:        Convert a string of characters to lower case.
  223.  
  224. Parameters:
  225.      Input:     InpStr = string to be converted.
  226.     Output:     none
  227.  
  228. Function Value: LowerCase = converted string.
  229. }
  230.  
  231. {====================================================}
  232. function UpperCase(InpStr: LString): LString; forward;
  233. {====================================================}
  234. {
  235. Purpose:        Convert a string of characters to upper case.
  236.  
  237. Parameters:
  238.      Input:     InpStr = string to be converted.
  239.     Output:     none
  240.  
  241. Function Value: UpperCase = converted string.
  242. }
  243.  
  244. {================================================}
  245. function TrimL(InpStr: LString): LString; forward;
  246. {================================================}
  247. {
  248. Purpose:        Trim Left: Remove leading spaces from a string.
  249.  
  250. Parameters:
  251.      Input:     InpStr = string to be trimmed.
  252.     Output:     none
  253.  
  254. Function Value: TrimL = trimmed string.
  255. }
  256.  
  257. {================================================}
  258. function TrimR(InpStr: LString): LString; forward;
  259. {================================================}
  260. {
  261. Purpose:        Trim Right: Remove trailing spaces from a string.
  262.  
  263. Parameters:
  264.      Input:     InpStr = string to be trimmed.
  265.     Output:     none
  266.  
  267. Function Value: TrimR = trimmed string.
  268. }
  269.  
  270. {==================================================================}
  271. function PadL(InpStr: LString; FieldLen: integer): LString; forward;
  272. {==================================================================}
  273. {
  274. Purpose:        Pad Left: Pad a string on the left with spaces to
  275.                 fill it to a desired field length.  Trailing spaces
  276.                 are not removed.
  277. Parameters:
  278.      Input:     InpStr = string to be padded.
  279.     Output:     none
  280.  
  281. Function Value: PadL = padded string.
  282. }
  283.  
  284. {==================================================================}
  285. function PadR(InpStr: LString; FieldLen: integer): LString; forward;
  286. {==================================================================}
  287. {
  288. Purpose:        Pad Right: Pad a string on the right with spaces to
  289.                 fill it to a desired field length.  Leading spaces
  290.                 are not removed.
  291. Parameters:
  292.      Input:     InpStr = string to be padded.
  293.     Output:     none
  294.  
  295. Function Value: PadR = padded string.
  296. }
  297.  
  298. {===================================================================}
  299. function JustL(InpStr: LString; FieldLen: integer): LString; forward;
  300. {===================================================================}
  301. {
  302. Purpose:        Left justify a string within a desired field length.
  303.                 First leading spaces are removed, then the string is
  304.                 padded with trailing spaces to the desired length.
  305. Parameters:
  306.      Input:     InpStr = string to be justified.
  307.     Output:     none
  308.  
  309. Function Value: JustL = justified string.
  310. }
  311.  
  312. {===================================================================}
  313. function JustR(InpStr: LString; FieldLen: integer): LString; forward;
  314. {===================================================================}
  315. {
  316. Purpose:        Right justify a string within a desired field length.
  317.                 First trailing spaces are removed, then leading spaces
  318.                 are inserted fill to the desired length.
  319. Parameters:
  320.      Input:     InpStr = string to be justified.
  321.     Output:     none
  322.  
  323. Function Value: JustR = justified string.
  324. }
  325.  
  326. {====================================================================}
  327. function Center(InpStr: LString; FieldLen: integer): LString; forward;
  328. {====================================================================}
  329. {
  330. Purpose:        Center a string within a desired field length.  First
  331.                 the string is stripped of leading and trailing spaces,
  332.                 then the resultant string is padded equally with
  333.                 leading and trailing spaces.
  334. Parameters:
  335.      Input:     InpStr = string to be justified.
  336.     Output:     none
  337.  
  338. Function Value: Center = centered string.
  339. }
  340.  
  341. {==================================================================}
  342. function GetStr(var InpStr: LString; Delim: Char): LString; forward;
  343. {==================================================================}
  344. {
  345. Purpose:       Strating at the first position of the input string,
  346.                return a substring containing all characters up to
  347.                (but not including) the fisrt occurence of the given
  348.                delimiter.  If the delimiter is not found, then the
  349.                entire input string is returned.  The substring and
  350.                delimiter are then deleted from the input string.
  351.  
  352. Parameters:
  353.      Input:     InpStr = string from which substring is removed.
  354.                 Delim  = delimiter to be used.
  355.     Output:     InStr  = remainder of input string.
  356.  
  357. Function Value: GetStr = Extracted substring.
  358. }
  359.  
  360. {=====================================================================}
  361. function Break(var InpStr: LString; DelStr: LString): LString; forward;
  362. {=====================================================================}
  363. {
  364. Purpose:       Emulates the SNOBOL BREAK function.  Operation is
  365.                similar to GetStr except that several delimiters
  366.                may be used.  The substring returns all characters
  367.                up to the first of any delimiter in DelStr.  Unlike
  368.                GetStr, the Delimiter found is NOT removed from
  369.                the input string.
  370.  
  371. Parameters:
  372.      Input:     InpStr = string from which substring is removed.
  373.                 DelStr = list of delimiters.
  374.     Output:     InStr  = remainder of input string.
  375.  
  376. Function Value: Break  = Extracted substring (Break on delimiter).
  377. }
  378.  
  379. {====================================================================}
  380. function Span(var InpStr: LString; DelStr: LString): LString; forward;
  381. {====================================================================}
  382. {
  383. Purpose:       Emulates the SNOBOL Span function.  Operation is
  384.                is the reverse of Break; The input string is scanned
  385.                for characters IN DelStr.  It returns a  substring
  386.                containing ONLY delimiters found starting at the
  387.                first position up the the first NON delimiter.  That
  388.                character is NOT removed from the input string.
  389.  
  390. Parameters:
  391.      Input:     InpStr = string from which substring is removed.
  392.                 DelStr = list of delimiters.
  393.     Output:     InStr  = remainder of input string.
  394.  
  395. Function Value: Span   = Extracted substring (Span of delimiters).
  396. }
  397.  
  398. {====================================================================}
  399. function Compress(InpStr: LString): LString; forward;
  400. {====================================================================}
  401. {
  402. Purpose:        Replace multiple tabs, spaces in string with single space.
  403.  
  404. Parameters:
  405.      Input:     InpStr = string to be compressed.
  406.     Output:     none.
  407.  
  408. Function Value: Compress = compressed string.
  409. }
  410.  
  411. {====================================================================}
  412. function Squish(InpStr: LString): LString; forward;
  413. {====================================================================}
  414. {
  415. Purpose:        Replace multiple tabs, spaces in string with single space,
  416.                 and delete leading and trailing spaces.
  417.  
  418. Parameters:
  419.      Input:     InpStr = string to be squished.
  420.     Output:     none.
  421.  
  422. Function Value: Squish = squished string.
  423. }
  424.  
  425. {=======================================================================}
  426. procedure GString(InpStr, DelStr: LString; span: boolean;
  427.                   var cpos, dpos: integer; var OutStr: LString); forward;
  428. {=======================================================================}
  429. {
  430. Purpose:       Emulates both the SPAN and BREAK functions of SNOBOL.
  431.  
  432.                SPAN:  If span is true, then starting from position, cpos,
  433.                the input string is scanned for characters in the string,
  434.                DelStr.  These characters are copied to the output string
  435.                until either a character NOT in DelStr is found or the end
  436.                of the string is reached.  Position pointer, cpos, is reset
  437.                to point at the break character.  If the end of the string
  438.                is reached, cpos is set to zero.
  439.  
  440.                BREAK: If span is false, then the input string is scanned
  441.                for characters NOT in the string, DelStr.  The output string
  442.                contains all characters up to the first delimiter.  Position
  443.                pointer, cpos, is set to point at the delimiter found.  If a
  444.                delimiter was not found, cpos is set to zero.
  445.  
  446.                Dpos is set to position in DelStr of the delimiter found.  If
  447.                none found, dpos is set to zero.
  448.  
  449. Parameters:
  450.      Input:     InpStr = string from which substring is Copied.
  451.                 DelStr = delimiters to be used.
  452.                 span   = true = span, false = break.
  453.                 cpos   = starting position in input string.
  454.  
  455.     Output:     cpos   = position past found delimiter.
  456.                 dpos   = which delimiter was found.
  457.                 OutStr = substring copied from the input string.
  458. }
  459. {=================================================}
  460. Procedure Str(    Valu: Integer;
  461.               var OutStr: LString); forward;
  462. {=================================================}
  463. {
  464. Purpose:        Emulates Turbo Pascal Str function, but only for integer values.
  465.                 Converts integer Valu to string representation in OutStr.
  466.                 In addition, the special formatting commands (:n) are
  467.                 NOT available in this version.
  468.  
  469. Parameters:
  470.     Input:      Valu = integer value to convert to string expression.
  471.  
  472.     Output:     OutStr = string that will receive string, with no leading
  473.                          or trailing spaces.
  474. }
  475. {=================================================}
  476. Procedure Val(    InpStr: LString;
  477.               var Valu: Integer;
  478.               var OutCode: Integer); forward;
  479. {=================================================}
  480. {
  481. Purpose:        Emulates Turbo Pascal Val function, but only for integer values.
  482.                 In addition, the return code OutCode is the VAX Pascal
  483.                 STATUSV, NOT the position of the first character in error.
  484.  
  485. Parameters:
  486.     Input:      InpStr = string expression to convert to an integer value.
  487.  
  488.     Output:     Valu = integer value of the expression.
  489.  
  490.                 OutCode = result code, 0 if OK, otherwise value of STATUSV.
  491. }
  492. {=================================================}
  493. Procedure RealStr(Valu: Real; Trail: integer;
  494.                   var OutStr: LString); forward;
  495. {=================================================}
  496. {
  497. Purpose:        Convert a real value to an equivalent string representation.
  498.  
  499. Parameters:
  500.  
  501.      Input:     Valu   = Real value to be converted to a string.
  502.                 Trail  = number of digits to the right of the radix point.
  503.  
  504.     Output:     OutStr = string representation.
  505. }
  506.  
  507. {===========================================================}
  508. Procedure RealVal(InpStr: LString;
  509.                   Var Err: integer; Var Valu: real); forward;
  510. {===========================================================}
  511. {
  512. Purpose:        Convert a string representation of a number to a real value.
  513.  
  514.                 If an illegial character is encounterd, conversion halts
  515.                 and the error condition returned by STATUSV is reported 
  516.                 through the variable, Err. 
  517.  
  518. Parameters:
  519.  
  520.      Input:     InpStr = String representation to be converted to a real value.
  521.  
  522.     Output:     Err    = error code, 0 if OK, otherwise value os STATUSV
  523.                 Valu   = converted value.
  524. }
  525. {===========================================================}
  526. Procedure Substitute( Var line: LString;
  527.                       target, subst: LString); forward;
  528. {===========================================================}
  529. {
  530. Purpose:        Find and replace target substring with subst in line.
  531.  
  532. Parameters:
  533.     Input:      target = substring for which to look in line.
  534.                 subst = substring to replace target with, if found.
  535.  
  536.     Output:     line = updated string.
  537. }
  538. {
  539. FUNCTION BODIES:
  540. }
  541.  
  542. {==============}
  543. procedure Delete_;
  544. {==============}
  545. { remove substring starting at FieldPos, containing FieldLen chars }
  546. begin
  547.     if FieldPos <= length(InpStr) then
  548.         InpStr := Substr(InpStr, 1, FieldPos-1) + 
  549.                   Substr(InpStr, min(FieldPos+FieldLen,length(InpStr)),
  550.                          max(length(InpStr)-FieldPos-FieldLen+1,0) );
  551. end;
  552.  
  553. {================}
  554. procedure Insert;
  555. {================}
  556. { Insert string ObjStr into InpStr at position FieldPos }
  557. begin
  558.     if FieldPos > length(InpStr) then
  559.         InpStr := InpStr + ObjStr
  560.     else
  561.         InpStr := Substr(InpStr, 1, FieldPos-1) +
  562.                   ObjStr +
  563.                   Substr(InpStr, FieldPos, length(InpStr)-(FieldPos-1));
  564. end;
  565.  
  566. {==============}
  567. function Copy;
  568. {==============}
  569. { extracts a substring from input string }
  570. begin
  571.     If FieldPos > length(InpStr) then
  572.         Copy := ''
  573.     else
  574.         Copy := SUBSTR( InpStr, FieldPos, 
  575.                         MIN( FieldLen, length(InpStr)-FieldPos+1 ) );
  576. end;
  577.  
  578. {==============}
  579. function Pos_;
  580. {==============}
  581. { find location of a substring in an input string }
  582. begin
  583.     Pos_ := INDEX( InpStr, ObjStr )
  584. end;
  585.  
  586. {==============}
  587. function UpCase;
  588. {==============}
  589. { convert a character to upper case }
  590. begin
  591.    if InChar IN ['a'..'z'] then
  592.       UpCase := Chr(Ord(Inchar)-32)
  593.    else
  594.       UpCase := InChar
  595. end;
  596.  
  597. {==============}
  598. function LoCase;
  599. {==============}
  600. { convert a character to lower case }
  601. begin
  602.    if InChar IN ['A'..'Z'] then
  603.       LoCase := Chr(Ord(Inchar)+32)
  604.    else
  605.       LoCase := InChar
  606. end;
  607.  
  608. {=================}
  609. function LowerCase;
  610. {=================}
  611.  
  612. { convert a string to lower case characters }
  613.  
  614. var i : integer;
  615.  
  616. begin
  617.    for i := 1 to Length(InpStr) do
  618.        InpStr[i] := LoCase(InpStr[i]);
  619.    LowerCase := InpStr
  620. end;
  621.  
  622. {=================}
  623. function UpperCase;
  624. {=================}
  625.  
  626. { convert a string to upper case characters }
  627.  
  628. var i : integer;
  629.  
  630. begin
  631.    for i := 1 to Length(InpStr) do
  632.        InpStr[i] := UpCase(InpStr[i]);
  633.    UpperCase := InpStr
  634. end;
  635.  
  636. {=============}
  637. function TrimL;
  638. {=============}
  639.  
  640. { strip leading spaces from a string }
  641.  
  642. var i,len : integer;
  643.  
  644. begin
  645.    len := length(InpStr);
  646.    i := 1;
  647.    while (i <= len) and (InpStr[i] = ' ') do
  648.       i := i + 1;
  649.    TrimL := Substr(InpStr,i,len-i+1) 
  650. end;
  651.  
  652. {=============}
  653. function TrimR;
  654. {=============}
  655.  
  656. { strip trailing spaces from a string }
  657.  
  658. var i : integer;
  659.  
  660. begin
  661.    i := length(InpStr);
  662.    while (i >= 1) and (InpStr[i] = ' ') do
  663.       i := i - 1;
  664.    TrimR := Substr(InpStr,1,i)
  665. end;
  666.  
  667. {============}
  668. function PadL;
  669. {============}
  670.  
  671. { Pad string on left with spaces to fill to the desired field length }
  672.  
  673. var  STemp : LString;
  674.          i : integer;
  675.  
  676. begin
  677.    If FieldLen >= Size(InpStr.body) then FieldLen := Size(InpStr.body);
  678.    if length(InpStr) > FieldLen then
  679.       PadL := Substr(InpStr,1,FieldLen)
  680.    else begin
  681.       STemp := InpStr;
  682.       for i := Length(STemp)+1 to FieldLen do
  683.          STemp := ' ' + STemp;
  684.       PadL := STemp
  685.       end
  686. end;
  687.  
  688. {============}
  689. function PadR;
  690. {============}
  691.  
  692. { Pad string on right with spaces to fill to the desired field length }
  693.  
  694. var  STemp : LString;
  695.          i : integer;
  696.  
  697. begin
  698.    If FieldLen >= Size(InpStr.body) then FieldLen := Size(InpStr.body);
  699.    if length(InpStr) > FieldLen then
  700.       PadR := Substr(InpStr,1,FieldLen)
  701.    else begin
  702.       STemp := InpStr;
  703.       for i := Length(STemp)+1 to FieldLen do
  704.          STemp := STemp + ' ';
  705.       PadR := STemp
  706.       end
  707. end;
  708.  
  709. {=============}
  710. function JustL;
  711. {=============}
  712.  
  713. { Left justify the string within the given field length }
  714.  
  715. begin
  716.    JustL := PadR(TrimL(InpStr),FieldLen)
  717. end;
  718.  
  719. {=============}
  720. function JustR;
  721. {=============}
  722.  
  723. { Right justify the string within the given field length }
  724.  
  725. begin
  726.    JustR := PadL(TrimR(InpStr),FieldLen)
  727. end;
  728.  
  729. {==============}
  730. function Center;
  731. {==============}
  732.  
  733. { Center a string within a specified field length;  the string
  734.   is padded on both sides with spaces }
  735.  
  736. var LeadSpaces : integer;
  737.         STemp : LString;
  738. begin
  739.    { strip leading and trailing spaces; determine the
  740.      Number of spaces needed to center the string }
  741.  
  742.    STemp := TrimR(TrimL(InpStr));
  743.    LeadSpaces := (FieldLen - Length(STemp) + 1) div 2;
  744.  
  745.    { insert leading spaces then trailing spaces }
  746.    Center := PadR(PadL(STemp,FieldLen-LeadSpaces),FieldLen)
  747. end;
  748.  
  749. {==============}
  750. function GetStr;
  751. {==============}
  752.  
  753. { Return a string containing all characters starting at the
  754.   first position of the source string up to the first delimiter.
  755. }
  756.  
  757. var i : integer;
  758. begin
  759.    i := Index(InpStr,Delim);
  760.    if i = 0 then begin
  761.       GetStr := InpStr;
  762.       InpStr := ''
  763.       end
  764.    else begin
  765.       GetStr := Substr(InpStr,1,i-1);
  766.       {InpStr := Substr(InpStr,i+1,length(InpStr)-i)}  Delete_(InpStr,1,i)
  767.       end
  768. end;
  769.  
  770. {=============}
  771. function Break;
  772. {=============}
  773.  
  774. { Emulate SNOBOL BREAK function }
  775.  
  776. var cp, dp : integer;
  777.     OutStr : LString;
  778.  
  779. begin
  780.    cp := 1;
  781.    GString(InpStr,DelStr,false,cp,dp,OutStr);
  782.    Break := OutStr;
  783.    if cp = 0 then
  784.       InpStr := ''
  785.    else
  786.       {InpStr := Substr(InpStr,cp,length(InpStr)-cp-1)}  Delete_(InpStr,1,cp-1)
  787. end;
  788.  
  789. {============}
  790. function Span;
  791. {============}
  792.  
  793. { Emulate SNOBOL SPAN function }
  794.  
  795. var cp, dp : integer;
  796.     OutStr : LString;
  797.  
  798. begin
  799.    cp := 1;
  800.    GString(InpStr,DelStr,true,cp,dp,OutStr);
  801.    Span := OutStr;
  802.    if cp = 0 then
  803.       InpStr := ''
  804.    else
  805.       {InpStr := Substr(InpStr,i+1,length(InpStr)-cp-1)}  
  806.       Delete_(InpStr,1,cp-1)
  807. end;
  808.  
  809. {================}
  810. procedure GString;
  811. {================}
  812.  
  813. { Return a string containing all characters starting at position, cpos,
  814.  of the source string up to the first first occurence of any of several
  815.  delimiters.  The position of the found delimiter is returned as well
  816.  as which delimiter.
  817. }
  818. var done : boolean;
  819.  
  820. begin
  821.    OutStr := ''; dpos := 0;
  822.    if cpos > 0 then begin
  823.       done := false;
  824.       while (cpos <= Length(InpStr)) and not done do begin
  825.          dpos := Index(DelStr,InpStr[cpos]);
  826.          if {span xor (dpos = 0) }
  827.             XOR( span, (dpos = 0))
  828.          then begin
  829.             OutStr := OutStr + InpStr[cpos];
  830.             cpos := cpos + 1
  831.             end
  832.          else
  833.             done := true
  834.          end;
  835.       if {(span xor (dpos = 0))}
  836.          XOR( span, (dpos = 0) )
  837.              or (cpos > length(InpStr))
  838.       then cpos := 0
  839.       end
  840. end;
  841.  
  842. {================}
  843. procedure Substitute;
  844. {================}
  845.  
  846. {replaces target with subst in line}
  847.  
  848. var where : integer;
  849.  
  850. begin
  851.      where := Pos_(target, line);
  852.      if where > 0 then
  853.         begin
  854.         delete_(line, where, length(target));
  855.         insert(subst, line, where);
  856.         end;
  857. end;
  858.  
  859. {===============}
  860. function Compress;
  861. {===============}
  862.  
  863. {replaces multiple nonprinting chars with single spaces}
  864.  
  865. var i : integer;
  866.  
  867. begin
  868.      for i := 1 to length(InpStr) do
  869.          if NOT( InpStr[i] IN [' '..'~'] )  then
  870.             InpStr[i] := ' ';
  871.      i := Pos_('  ',InpStr);
  872.      while i <> 0 do
  873.          begin
  874.             Inpstr := Copy(Inpstr,1,i) +
  875.                       Copy(Inpstr,i+2,length(Inpstr)-i-1);
  876.             i := Pos_('  ',Inpstr);
  877.          end;
  878.      Compress := Inpstr;
  879. end;
  880.  
  881. {===============}
  882. function Squish;
  883. {===============}
  884.  
  885. {trims leading and trailing spaces and compresses excess whitespace}
  886.  
  887. begin
  888.      Squish := Compress(TrimR(TrimL(InpStr)))
  889. end;
  890.  
  891. {================}
  892. procedure Str;
  893. {================}
  894. { converts integer value to a string representation }
  895. begin
  896.     WRITEV( OutStr, Valu:1 );
  897. end;
  898.  
  899. {================}
  900. procedure Val;
  901. {================}
  902. { converts a string expression to an integer value, returning STATUSV code }
  903. begin
  904.     READV( InpStr, Valu, ERROR := CONTINUE );
  905.     OutCode := STATUSV;
  906. end;
  907.  
  908. {================}
  909. procedure RealStr;
  910. {================}
  911. { converts real value to a string representation }
  912. begin
  913.     WRITEV( OutStr, Valu:1:Trail )
  914. end;
  915.  
  916. {================}
  917. procedure RealVal;
  918. {================}
  919. { converts a string expression to a real value, returning STATUSV code }
  920. begin
  921.     READV( InpStr, Valu, ERROR := CONTINUE );
  922.     Err := STATUSV
  923. end;
  924.  
  925. (*
  926.     Other VAX Pascal equivalents of Turbo Pascal features
  927. *)
  928.  
  929. CONST     { Terminal control sequences defined here }
  930. CSI_sequence    =   ''(27) + '[';           {''(27) == ESCape char}
  931. ClrEol_sequence =   CSI_sequence + 'K';
  932. ClrScr_sequence =   CSI_sequence + ';H' + CSI_sequence + 'J';
  933. CrtInit_sequence=   ''(27)+'<'+''(27)+'(B'+''(27)+')0'+
  934.                     CSI_sequence+'?1l'+CSI_sequence+'?3l'+''(27)+'>';
  935. CRTExit_sequence    =   CSI_sequence + 'm';
  936. DelLine_sequence    =   '';
  937. InsLine_sequence    =   '';
  938. LowVideo_sequence   =   CSI_sequence + 'm';
  939. NormVideo_sequence  =   CSI_sequence + 'm';
  940. HiVideo_sequence    =   CSI_sequence + '1m';
  941. UnderScoreVideo_sequence    =   CSI_sequence + '4m';
  942. BlinkVideo_sequence         =   CSI_sequence + '5m';
  943. ReverseVideo_sequence       =   CSI_sequence + '7m';
  944. DoubleHighTopVideo_sequence     =   ''(27)+'#3';
  945. DoubleHighBottomVideo_sequence  =   ''(27)+'#4';
  946. SingleHighVideo_sequence        =   ''(27)+'#5';
  947. DoubleWideVideo_sequence        =   ''(27)+'#6';
  948.  
  949. { VAX Pascal equiv.'s to Turbo built-in CRT control routines }
  950.  
  951. PROCEDURE ClrEol;
  952.  
  953.     BEGIN
  954.     WRITE( output, ClrEol_sequence )
  955.     END;
  956.  
  957. PROCEDURE ClrScr;
  958.  
  959.     BEGIN
  960.     WRITE( output, ClrScr_sequence )
  961.     END;
  962.  
  963. PROCEDURE CrtInit;
  964.  
  965.     BEGIN
  966.     OPEN( output, RECORD_LENGTH := 65500 );  { open output for max. rec. size }
  967.     WRITE( output, CrtInit_sequence )
  968.     END;
  969.  
  970. PROCEDURE CrtExit;
  971.  
  972.     BEGIN
  973.     WRITE( output, CrtExit_sequence )
  974.     END;
  975.  
  976. PROCEDURE DelLine;
  977.  
  978.     BEGIN
  979.     WRITE( output, DelLine_sequence )
  980.     END;
  981.  
  982. PROCEDURE InsLine;
  983.  
  984.     BEGIN
  985.     WRITE( output, DelLine_sequence )
  986.     END;
  987.  
  988. PROCEDURE GoToXY( col, row : INTEGER );
  989.  
  990.     BEGIN
  991.     WRITE( output, CSI_sequence, row:1, ';', col:1, 'H' )
  992.     END;
  993.  
  994. PROCEDURE LowVideo;
  995.  
  996.     BEGIN
  997.     WRITE( output, LowVideo_sequence )
  998.     END;
  999.  
  1000. PROCEDURE NormVideo;
  1001.  
  1002.     BEGIN
  1003.     WRITE( output, NormVideo_sequence )
  1004.     END;
  1005.  
  1006. PROCEDURE HiVideo;
  1007.  
  1008.     BEGIN
  1009.     WRITE( output, HiVideo_sequence )
  1010.     END;
  1011.  
  1012. PROCEDURE UnderScoreVideo;
  1013.  
  1014.     BEGIN
  1015.     WRITE( output, UnderScoreVideo_sequence )
  1016.     END;
  1017.   
  1018. PROCEDURE BlinkVideo;
  1019.  
  1020.     BEGIN
  1021.     WRITE( output, BlinkVideo_sequence )
  1022.     END;
  1023.  
  1024. PROCEDURE ReverseVideo;
  1025.  
  1026.     BEGIN
  1027.     WRITE( output, ReverseVideo_sequence )
  1028.     END;
  1029.  
  1030. PROCEDURE DoubleHighVideo( line: LString );
  1031.  
  1032.     BEGIN
  1033.     WRITELN( output, DoubleHighTopVideo_sequence, line );
  1034.     WRITELN( output, DoubleHighBottomVideo_sequence, line );
  1035.     END;
  1036.  
  1037. PROCEDURE SingleHighVideo;
  1038.  
  1039.     BEGIN
  1040.     WRITE( output, SingleHighVideo_sequence )
  1041.     END;
  1042.  
  1043. PROCEDURE DoubleWideVideo;
  1044.  
  1045.     BEGIN
  1046.     WRITE( output, DoubleWideVideo_sequence )
  1047.     END;
  1048.  
  1049. { VAX Pascal equivalents for Turbo arithmetic built-in's }
  1050.  
  1051. FUNCTION Frac (x : REAL) : REAL;
  1052.  
  1053.     BEGIN
  1054.     Frac := x - Trunc( x )
  1055.     END;
  1056.  
  1057. FUNCTION Hi (x : INTEGER) : INTEGER;
  1058.  
  1059.     BEGIN
  1060.     Hi := Int ( UAND( x, %X'FF00') DIV %X'FF' )
  1061.     END;
  1062.  
  1063. FUNCTION Lo (x : INTEGER):INTEGER;
  1064.  
  1065.     BEGIN
  1066.     Lo := Int ( UAND( x, %X'FF') )
  1067.     END;
  1068.  
  1069. FUNCTION Swap (x : INTEGER):INTEGER;
  1070.  
  1071.     BEGIN
  1072.     Swap := ( Lo(x) * %X'FF' ) + Hi(x)
  1073.     END;
  1074.  
  1075. FUNCTION SHL( u1,u2 : UNSIGNED ) : UNSIGNED;
  1076. { VAX replacement for Turbo SHL shift-left operator }
  1077.     BEGIN
  1078.         SHL := u1 * (2**u2)
  1079.     END;
  1080.  
  1081. FUNCTION SHR( u1,u2 : UNSIGNED ) : UNSIGNED;
  1082. { VAX replacement for Turbo SHR shift-right operator }
  1083.     BEGIN
  1084.         SHR := u1 DIV (2**u2)
  1085.     END;
  1086.  
  1087.  
  1088. [HIDDEN] VAR
  1089.     seed : [STATIC] UNSIGNED;
  1090.  
  1091. [HIDDEN,ASYNCHRONOUS,EXTERNAL(MTH$RANDOM)] FUNCTION MTH$RANDOM (
  1092.         VAR SEED : [VOLATILE]UNSIGNED) : REAL; EXTERNAL;
  1093.  
  1094. PROCEDURE Randomize;
  1095.  
  1096.     VAR
  1097.     x    : REAL;
  1098.  
  1099.     BEGIN
  1100.     seed := CLOCK * 2**10;
  1101.     x := MTH$Random ( seed )
  1102.     END;
  1103.  
  1104. FUNCTION Random: REAL;
  1105.  
  1106.     BEGIN
  1107.     Random := MTH$Random( seed )
  1108.     END;
  1109.  
  1110. PROCEDURE Delay (msecs : INTEGER);
  1111.  
  1112.     [ASYNCHRONOUS,EXTERNAL(SYS$HIBER)] FUNCTION $HIBER : INTEGER; EXTERNAL;
  1113.  
  1114.     TYPE        $UQUAD = [QUAD] RECORD
  1115.                                 LO: UNSIGNED;
  1116.                                 HI: UNSIGNED;
  1117.                                 END;
  1118.  
  1119.     [ASYNCHRONOUS,EXTERNAL(SYS$SCHDWK)] FUNCTION $SCHDWK (
  1120.         VAR PIDADR : [VOLATILE]UNSIGNED := %IMMED 0;
  1121.         PRCNAM : [CLASS_S] PACKED ARRAY [$l2..$u2:INTEGER] OF CHAR := %IMMED 0;
  1122.         DAYTIM : $UQUAD;
  1123.         REPTIM : $UQUAD := %IMMED 0) : INTEGER; EXTERNAL;
  1124.  
  1125.     CONST
  1126.     Milliseconds = 10000;
  1127.  
  1128.     VAR
  1129.     sts : INTEGER;
  1130.     DAYTIM : $UQUAD;
  1131.  
  1132.     BEGIN
  1133.     { schedule a wakeup for msecs later }
  1134.       DAYTIM.LO := -(msecs * Milliseconds);
  1135.       DAYTIM.HI := -1;
  1136.       sts := $Schdwk( DAYTIM:=DAYTIM );
  1137.     { hibernate until then }
  1138.       sts := $Hiber;
  1139.     END;
  1140.  
  1141. FUNCTION EXIST (fn : VARYING [l1] OF CHAR) : BOOLEAN;
  1142.  
  1143.     VAR
  1144.         fv : TEXT;
  1145.     BEGIN
  1146.     OPEN( FILE_VARIABLE     := fv,
  1147.           FILE_NAME         := fn,
  1148.           HISTORY           := READONLY,
  1149.           ERROR             := CONTINUE );
  1150.     EXIST := STATUS( fv ) < 1;
  1151.     CLOSE( FILE_VARIABLE     := fv,
  1152.            ERROR             := CONTINUE )
  1153.     END;
  1154.  
  1155. FUNCTION GetTime : LString;
  1156.  
  1157.     VAR
  1158.         str : PACKED ARRAY [1..11] OF CHAR;
  1159.     BEGIN
  1160.     TIME( str );
  1161.     GetTime := str
  1162.     END;
  1163.  
  1164. FUNCTION GetDate : LString;
  1165.  
  1166.     VAR
  1167.         str : PACKED ARRAY [1..11] OF CHAR;
  1168.     BEGIN
  1169.     DATE( str );
  1170.     GetDate := str
  1171.     END;
  1172.  
  1173.  
  1174. { END.   { end of VAXTURBO }
  1175.