home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / GET10.ZIP / GETFNS.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1988-11-09  |  21.6 KB  |  804 lines
  1. {$B-,D-,F-,I-,L+,N-,R-,S-,T-,V-} {TP4 directives}
  2.  
  3. Unit GetFns; {functions}
  4. {
  5.   Uses routines by Richard Sadowsky (Tools v1.0) and Jim LeMay (Maxmin)
  6. }
  7. Interface
  8.  
  9. Uses Dos;
  10.  
  11.  
  12. Type
  13.  
  14.   edit =
  15.  
  16.   (help,            {help!}
  17.    other,           {not a valid command, don't do anything}
  18.    escapefrom,      {escape}
  19.    goto_top,        {cursor to top of file}
  20.    goto_bottom,     {cursor to end file}
  21.    leftchar,        {cursor left one character}
  22.    rightchar,       {cursor right one character}
  23.    upchar,          {accept string as is and exit with current cursor pos}
  24.    downchar,        { as above }
  25.    scrollup,        {scroll display up}
  26.    scrolldown,      {scroll display down}
  27.    pageup,          {page display up}
  28.    pagedown,        {page display down}
  29.    abort,           {abandon edits, restore original string}
  30.    exit_screen,     {}
  31.    quit,            {}
  32.    oops,            {undo edits}
  33.    reset,           {reset: relax validation e.g.}
  34.    tabover,         {tab}
  35.    tabback,         {tab back}
  36.    goto_start,      {cursor to the start of the string}
  37.    goto_end,        {cursor to the end of the string}
  38.    carriage_return, {accept string and exit with cursor set to position 1}
  39.    enter_default,   {enter default value if there is one}
  40.    insert_line,     {insert a line}
  41.    leftword,        {cursor left one word}
  42.    rightword,       {cursor right one word}
  43.    backspace,       {delete character to the left}
  44.    del_char,        {delete character under the cursor}
  45.    del_to_start,    {delete to the beginning of the line}
  46.    del_to_end,      {delete to the end of the line}
  47.    del_line,        {delete the line}
  48.    del_word,        {delete the next word}
  49.    del_block,       {delete block, e.g. date field = block of 3 fields}
  50.    restore_block,   {block equivalent of oops}
  51.    toggle_mode,     {toggle between insert and overwrite modes}
  52.    post_letter);    {enter a letter in the string}
  53.  
  54.  
  55.   screen_text  = string[255];
  56.   numstring    = string[40];
  57.  
  58.   Str3         = String[3];  {RS}
  59.   Str80        = String[80]; {"}
  60.   Path         = String[70]; {"}
  61.  
  62.  
  63. Const
  64.  
  65.    maxword        = 65535;     {maxlongint and maxint already defined}
  66.    maxbyte        = 255;
  67.    maxshortint    = 127;
  68.    billion        = 1000000000;
  69.  
  70.    strminlongint  = '-2147483648';
  71.    strmaxlongint  =  '2417483647';
  72.  
  73.   _EQUAL_        = 0; {RSadowsky}
  74.  
  75.   Alt_A = $011E; Alt_B = $0130; Alt_C = $012E; Alt_D = $0120; Alt_E = $0112;
  76.   Alt_F = $0121; Alt_G = $0122; Alt_H = $0123; Alt_I = $0117; Alt_J = $0124;
  77.   Alt_K = $0125; Alt_L = $0126; Alt_M = $0132; Alt_N = $0131; Alt_O = $0118;
  78.   Alt_P = $0119; Alt_Q = $0110; Alt_R = $0113; Alt_S = $011F; Alt_T = $0114;
  79.   Alt_U = $0116; Alt_V = $012F; Alt_W = $0111; Alt_X = $012D; Alt_Y = $0115;
  80.   Alt_Z = $012C;
  81.  
  82.   UpKey        = $0148; DownKey       = $0150;
  83.   LeftKey      = $014B; RightKey      = $014D;
  84.   Ctrl_LeftKey = $0173; Ctrl_RightKey = $0174;
  85.   InsKey       = $0152; DelKey        = $0153;
  86.   HomeKey      = $0147; EndKey        = $014F;
  87.   PgUpKey      = $0149; PgDnKey       = $0151;
  88.   Ctrl_HomeKey = $0177; Ctrl_EndKey   = $0175;
  89.   Ctrl_PgUpKey = $0184; Ctrl_PgDnKey  = $0176;
  90.  
  91.   F1 = $013B; F2 = $013C; F3 = $013D; F4 = $013E; F5 = $013F; 
  92.   F6 = $0140; F7 = $0141; F8 = $0142; F9 = $0143; F10= $0144;
  93.  
  94.   Shift_F1 = $0154; Shift_F2 = $0155; Shift_F3 = $0156; Shift_F4 = $0157;
  95.   Shift_F5 = $0158; Shift_F6 = $0159; Shift_F7 = $015A; Shift_F8 = $015B;
  96.   Shift_F9 = $015C; Shift_F10= $015D;
  97.  
  98.   Alt_F1 = $0168; Alt_F2 = $0169; Alt_F3 = $016A; Alt_F4 = $016B;
  99.   Alt_F5 = $016C; Alt_F6 = $016D; Alt_F7 = $016E; Alt_F8 = $016F;
  100.   Alt_F9 = $0170; Alt_F10= $0171;
  101.  
  102.   Ctrl_F1 = $015E; Ctrl_F2 = $015F; Ctrl_F3 = $0160; Ctrl_F4 = $0161;
  103.   Ctrl_F5 = $0162; Ctrl_F6 = $0163; Ctrl_F7 = $0164; Ctrl_F8 = $0165;
  104.   Ctrl_F9 = $0166; Ctrl_F10= $0167;
  105.  
  106.  
  107. Var
  108.  
  109.     action:         edit;
  110.  
  111.     asciicode,
  112.     scancode:        byte;
  113.     command:         word absolute asciicode;
  114.  
  115.     ExtendedKey,     { Returns true if last key was extended false if not }
  116.     ASCIIKey:        Boolean; { Returns exactly opposite of ExtendedKey }
  117.  
  118.  
  119.  
  120. function length_without_tears (message: screen_text; sentinel: char): byte;
  121. function get_edit (var cmd: word): edit;
  122. function trunk (number: real): longint;
  123. function powerof (number,power: integer): integer;
  124. function log (lnum: real): real; {log base 10}
  125. function reallog (number, base: real): real;
  126. function RoundTo (number: real; places: byte): real;
  127. function FracToInt (infrac: real; places: integer): longint;
  128. function IntToFrac (inint: integer): real;
  129. function digits (fingers: real): longint;
  130. procedure strval (var number: real; decimal_places: integer);
  131. function RealToString (inreal: real;decimal_places: integer): numstring;
  132. function StrLastChar (instr: string): char;
  133.  
  134. {Jim LeMay's MaxMin functions}
  135.  
  136. function MaxW (Value1,Value2: word): word;
  137. function MinW (Value1,Value2: word): word;
  138. function MaxI (Value1,Value2: integer): integer;
  139. function MinI (Value1,Value2: integer): integer;
  140. function MaxL (Value1,Value2: longint): longint;
  141. function MinL (Value1,Value2: longint): longint;
  142.  
  143. { Neil Rubenking's function to pad a string with spaces }
  144.  
  145. function PadString (s:string; n:byte):string;
  146.  
  147. {Richard Sadowsky's tools}
  148.  
  149. function UpperCase(S : String) : String;
  150.  
  151. function CompMem(var Block1,Block2; Size : Word) : Word;
  152. {
  153.  return 0 if Block1 and Block2 are equal for Size bytes
  154.  if not equal, return the position of first non matching byte
  155.  the first byte is considered to be 1
  156. }
  157.  
  158. function ExpandTabs(var S : String) : String;
  159. { expands each tab into a single space. Used before parsing }
  160.  
  161. function Trim(var S : String) : String;
  162. { FAST assembly language Trim routine, trims leading and trailing }
  163.  
  164. function SearchBlock(var FindStr; FindSize : Word; var Block;
  165.             BlockSize : Word) : Word;
  166. { generic Block search routine.  Takes untyped VAR parameters }
  167.  
  168. procedure ReplaceString(StrToFind,StrToRep : Str80; var S : String);
  169. { Finds StrToFind and replaces it with StrToRep in string S. }
  170. { ignores case when searching for the string to replace.     }
  171.  
  172. function RightStr(S : String; Number : Word) : String;
  173. { returns all characters to the right of character Number }
  174.  
  175. function LeftStr(_S : String; Number : Word) : String;
  176. {
  177.   returns all the characters from beginning of str to the
  178.   character at position Number.  A NULL string is returned if
  179.   Number is Number = 0, _S = ''.  If Number is greater than
  180.   the length of _S then the entire string _S is returned.
  181. }
  182.  
  183. function ParseWord(var S : String; DelimChar : Char) : String;
  184. { parses input string S up to the first occurance of DelimChar. }
  185. { The parsed string is returned, and chopped out of the string S}
  186. { see WordOnLine implementation for sample use of ParseWord     }
  187.  
  188. function WordOnLine(var The_Word,The_Line : String) : Boolean;
  189. { returns TRUE if The_Word appears on The_Line }
  190.  
  191. function FileExt(PName : Path; Extension : Str3) : Path;
  192. { force a file extension }
  193.  
  194. function InKey(var ScanCode : Byte) : Char;
  195. { return character and scancode with a single call }
  196.  
  197. { adapted from David Bennett's extkey }
  198.  
  199. function ExtendKey : Word;
  200. {
  201.   Return ascii value and scan code; sets booleans ASCIIkey and ExtendedKey.
  202.   If extendedkey: high byte returned with $01.
  203. }
  204.  
  205. {PON's continuted}
  206.  
  207. function StringIsBlank(blankstr: string): boolean;
  208.  
  209. function TestBit (var bite: byte; bitnumber: byte): boolean;
  210. function ByteToStr (Bite: byte): string;
  211. function StrToByte (bitstr: string): byte;
  212.  
  213. procedure SetBit (var bite: byte; bitnumber: byte);
  214. procedure ClearBit (var bite: byte; bitnumber: byte);
  215.  
  216.  
  217. procedure value
  218.  
  219.     (instr:   numstring;
  220. var number:   longint;
  221.     maxvalue: longint;
  222. var code:     integer);
  223.  
  224. procedure real_value
  225.  
  226.     (instr:   numstring;
  227. var number:   real;
  228. var code:     integer);
  229.  
  230.  
  231. Implementation
  232.  
  233. { JLM's routine's}
  234.  
  235. {$L MaxW.obj}
  236. function MaxW;  external;
  237. {$L MinW.obj}
  238. function MinW;  external;
  239.  
  240. {$L MaxI.obj}
  241. function MaxI;  external;
  242. {$L MinI.obj}
  243. function MinI;  external;
  244.  
  245. {$L MaxL.obj}
  246. function MaxL;  external;
  247. {$L MinL.obj}
  248. function MinL;  external;
  249.  
  250. { end of JLM's code }
  251.  
  252. {** R. Sadowsky's: }
  253.  
  254. {$L UCASE.OBJ}
  255. {$L MEMCOMP.OBJ}
  256. {$L EXPTABS.OBJ}
  257. {$L TRIM.OBJ}
  258. {$L SEARCH.OBJ}
  259. {$L PARSE.OBJ}
  260. {$L INKEY.OBJ}
  261. {$L RIGHTSTR.OBJ}
  262. {$L LEFTSTR.OBJ}
  263.  
  264. function UpperCase(S : String) : String; External;
  265.  
  266. function CompMem(var Block1,Block2; Size : Word) : Word; External;
  267.  
  268. function ExpandTabs(var S : String) : String; External;
  269.  
  270. function Trim(var S : String) : String; External;
  271.  
  272. function SearchBlock(var FindStr; FindSize : Word; var Block;
  273.             BlockSize : Word) : Word; External;
  274.  
  275. function ParseWord(var S : String; DelimChar : Char) : String; External;
  276.  
  277. function InKey(var ScanCode : Byte) : Char; External;
  278.  
  279. function RightStr(S : String; Number : Word) : String; External;
  280.  
  281. function LeftStr(_S : String; Number : Word) : String; External;
  282.  
  283. procedure ReplaceString(StrToFind,StrToRep : Str80; var S : String);
  284.  
  285. var
  286.   L,P              : Word;
  287.   SS               : String; {scratch string }
  288.   STF,STR          : Str80;
  289.  
  290. begin
  291.   SS := UpperCase(S); {use the scratch string }
  292.   STF := UpperCase(StrToFind);
  293.   STR  := UpperCase(StrToRep);
  294.   L := Length(SS);
  295.   P := SearchBlock(STF[1],Length(STF),SS[1],L);
  296.  
  297.   if P > 0 then begin
  298.     Delete(S,P,Length(StrToFind));
  299.     if Length(StrToRep) > 0 then
  300.       Insert(StrToRep,S,P);
  301.   end;
  302.  
  303. end;
  304.  
  305. function WordOnLine(var The_Word,The_Line : String) : Boolean;
  306. { returns TRUE if The_Word appears on The_Line }
  307.  
  308. var
  309.   S                : String; {scratch string }
  310.   Wrd              : Str80;  { the parsed word }
  311.  
  312. begin
  313.   S := Trim(The_Line);
  314.   while Length(S) > 0 do begin
  315.     Wrd := ParseWord(S,' ');
  316.     S := Trim(S);
  317.     if CompMem(Wrd,The_Word,
  318.                Succ(Length(Wrd))) = _EQUAL_ then begin
  319.       WordOnLine := TRUE;
  320.       Exit;
  321.     end;
  322.   end;
  323.   WordOnLine := FALSE;
  324. end;
  325.  
  326. function FileExt(PName : Path; Extension : Str3) : Path;
  327.  
  328. var
  329.   Position,L       : Word;
  330.  
  331.   PathName         : Path;
  332.  
  333. const
  334.   Period           : String[1] = '.';
  335.  
  336. begin
  337.   PathName := PName;
  338.   Position := Pos(Period,PathName);
  339.   if Position > 0 then begin
  340.     L := Length(PathName);
  341.     PathName[0] := Char(L - Succ(L - Position));
  342.   end;
  343.   FileExt := PathName + '.' + Extension;
  344. end;
  345.  
  346. {** end of R. Sadowsky's **}
  347.  
  348.  
  349. function PadString (s:string; n:byte):string;
  350. begin
  351.   if length(s) < n then
  352.     fillchar(s[succ(length(s))], n-length(s), ' ');
  353.   s[0] := chr(n);
  354.   padstring := s;
  355. end;
  356.  
  357.  
  358. Function ExtendKey : Word;
  359. {
  360.   David Bennett's extendkey modified to use Richard Sadowksy's inkey.
  361. }
  362. Var
  363.   asciivalue: char;
  364.   scanvalue:  byte;
  365.  
  366. begin
  367.   asciivalue  := inkey(scanvalue);
  368.   extendedkey := (asciivalue = #0);
  369.   asciikey    := not extendedkey;
  370.  
  371.   if extendedkey then
  372.     extendkey := $0100+Ord(scanvalue)
  373.   else
  374.     extendkey := Ord(asciivalue);
  375. end;
  376.  
  377.  
  378.  
  379. function get_edit (var cmd: word): edit;
  380. {
  381.   Given a command as input this function returns either the editing
  382.   action to be taken or the character to be entered in a string.
  383.   WordStar commands are supported, with the following extension:
  384.  
  385.   Delete to the beginning of the line/string: ^Q^H or ^Q<backspace>
  386. }
  387. var a: edit;
  388. begin
  389.   if scancode = 0 then {not an extended key}
  390.  
  391.     case asciicode of
  392.       $00    : a := quit;
  393.       $01    : a := leftword;        { ^A }
  394.       $03    : a := pagedown;        { ^C }
  395.       $04    : a := rightchar;       { ^D }
  396.       $05    : a := upchar;          { ^E }
  397.       $06    : a := rightword;       { ^F }
  398.       $07    : a := del_char;        { ^G }
  399.       $08,$7F: a := backspace;       { ^H }
  400.       $09    : a := tabover;         { ^I }
  401.       $0A    : a := enter_default;   { ^J }
  402.       $0D    : a := carriage_return; { ^M }
  403.       $0E    : a := insert_line;     { ^N }
  404.       $10    : begin                 { ^P }
  405.                  {insert literal}
  406.                  cmd := extendkey;
  407.                  if scancode = 0 then
  408.                    a := post_letter
  409.                  else a := other;
  410.                end;
  411.       $11    : begin                 { ^Q }
  412.                  cmd := extendkey;
  413.                  case asciicode of
  414.                    $12,$72,52  : a := goto_top;     { ^R, R, r }
  415.                    $03,$63,$43 : a := goto_bottom;  { ^C, C, c }
  416.                    $13,$73,$53 : a := goto_start;   { ^S, S, s }
  417.                    $04,$64,$44 : a := goto_end;     { ^D, D, d }
  418.                    $0C,$6C,$4C : a := oops;         { ^L, L, l }
  419.                    $19,$79,$59 : a := del_to_end;   { ^Y, Y, y }
  420.                    $08,$7F     : a := del_to_start; { ^H, del  }
  421.                  else a := other;
  422.                  end; {case}
  423.                end;
  424.       $12    : a := pageup;      { ^R }
  425.       $13    : a := leftchar;    { ^S }
  426.       $14    : a := del_word;    { ^T }
  427.       $15    : a := oops;        { ^U }
  428.       $16    : a := toggle_mode; { ^V }
  429.       $17    : a := scrolldown;  { ^W }
  430.       $18    : a := downchar;    { ^X }
  431.       $19    : a := del_line;    { ^Y }
  432.       $1A    : a := scrollup;    { ^Z }
  433.       $1B    : a := escapefrom;  { ^[ <Esc> }
  434.     else
  435.       if (ord(asciicode) > 31) and (ord(asciicode) < 256) then
  436.         a := post_letter
  437.       else a := other;
  438.     end {case}
  439.  
  440.   else {extended key}
  441.  
  442.     begin
  443.  
  444.       case asciicode of
  445.         $3B: a := help;          { F1-Help! }
  446.         $0F: a := tabback;       { shift tab }
  447.         $52: a := toggle_mode;   { Insert/Overwrite }
  448.         $53: a := del_char;      { Delete character }
  449.         $73: a := leftword;      { ctrl left arrow }
  450.         $74: a := rightword;     { ctrl right arrow }
  451.         $77: a := goto_top;      { ^home }
  452.         $75: a := goto_bottom;   { ^end }
  453.         $47: a := goto_start;    { home }
  454.         $4F: a := goto_end;      { end }
  455.         $48: a := upchar;        { up arrow }
  456.         $50: a := downchar;      { down arrow }
  457.         $4B: a := leftchar;      { left arrow }
  458.         $4D: a := rightchar;     { right arrow }
  459.         $49: a := pageup;        { PgUp }
  460.         $51: a := pagedown;      { PgDn }
  461.         $84: a := scrollup;      { Ctrl PgUp }
  462.         $76: a := scrolldown;    { Ctrl PgDn }
  463.         $13: a := reset;         { Alt-R }
  464.         $15: a := del_block;     { Alt-Y }
  465.         $16: a := restore_block; { Alt-U }
  466.         $2D: a := exit_screen;   { Alt-X }
  467.       else a := other
  468.       end; {case}
  469.  
  470.     end;
  471.  
  472.   get_edit := a;
  473. end;
  474.  
  475.  
  476. function length_without_tears (message: screen_text; sentinel: char): byte;
  477. var I,J: byte;
  478. {
  479.   Returns the length of a string minus sentinel characters
  480. }
  481. begin
  482.   I := length(message);
  483.   J := I;
  484.   while I > 0 do
  485.     begin
  486.       if message[I] = sentinel then
  487.         dec(J);
  488.       dec(I);
  489.     end;
  490.   length_without_tears := J;
  491. end;
  492.  
  493.  
  494. function trunk (number: real): longint;
  495. {
  496.   Replacement for built-in 'trunc' procedure which bombs if given -2147483648
  497. }
  498. begin
  499.   if number <= pred(-maxlongint) then
  500.     trunk := pred(-maxlongint)
  501.   else if number >= maxlongint then
  502.          trunk := maxlongint
  503.        else trunk := trunc(number);
  504. end;
  505.  
  506.  
  507. function powerof (number,power: integer): integer;
  508. {
  509.   Note: natural log of a negative number is undefined. Use error handler.
  510.   Enable 1st IF clause if powerof is changed to return real numbers (and
  511.   remove round from 1st ELSE clause).
  512. }
  513. begin
  514. {
  515.    if power < 0 then
  516.      powerof := 1 div powerof(number,abs(power))
  517.    else 
  518. }
  519.      if power = 0 then
  520.        powerof := 1
  521.      else powerof := round(exp(power * ln(number)));
  522. end;
  523.  
  524.  
  525. function log (lnum: real): real;
  526. const e = 0.43429448191; {base 10 conversion constant}
  527. begin
  528.   if lnum <= 0 then
  529.     log := lnum { or use error handler }
  530.   else log := ln(lnum) * e;
  531. end;
  532.  
  533.  
  534. function reallog (number, base: real): real;
  535. {
  536.   Calculate log to any positive base other than 1.0
  537. }
  538. begin
  539.   reallog := ln(number) / ln(base);
  540. end;
  541.  
  542.  
  543. function RoundTo (number: real; places: byte): real;
  544. {
  545.   The built-in procedures Round or Trunc will do for converting a real to 
  546.   an integer. This procedure will round a real to a given number of places.
  547. }
  548. var I: integer;
  549. begin
  550.   for I := 1 to abs(places) do
  551.     if places > 0 then
  552.       number := number * 10.0
  553.     else number := number / 10.0;
  554.  
  555.   number := int(number + ord(number > 0) - 0.5);
  556.  
  557.   for I := 1 to abs(places) do
  558.     if places > 0 then
  559.       number := number / 10.0
  560.     else number := number * 10.0;
  561.  
  562.   RoundTo := number;
  563. end;
  564.  
  565.  
  566. function FracToInt (infrac: real;places: integer): longint;
  567. {
  568.   Converts the decimal part (up to 10 places) of a real to an integer.
  569.   Multiplying by 10 until the remainder is 0 doesn't work!
  570. }
  571. var outint:   integer;
  572.     fstr:     numstring;
  573.     negative: boolean;
  574.  
  575. begin
  576.   negative := infrac < 0;
  577.   infrac := abs(frac(infrac));
  578.  
  579.   if not places in [0..10] then
  580.     places := 10; {maxlongint is 10 long}
  581.  
  582.   str(infrac:0:places,fstr);
  583.   delete(fstr,1,2); {remove '0.'}
  584.  
  585.   while(fstr[length(fstr)] = '0') do
  586.     dec(ord(fstr[0])); {remove trailing 0s}
  587.  
  588.   outint := 0;
  589.  
  590.   while length(fstr) > 0 do
  591.     begin
  592.       outint := outint * 10 + ord(fstr[1]) - 48;
  593.       delete(fstr,1,1);
  594.     end;
  595.  
  596.   if negative then
  597.     outint := -outint;
  598.  
  599.   FracToInt := outint;
  600. end;
  601.  
  602.  
  603. function IntToFrac (inint: integer): real;
  604. {
  605.   Converts integer to decimal fraction, e.g. 247 to 0.247
  606. }
  607. var outfrac: real;
  608. begin
  609.   outfrac := inint;
  610.   while abs(int(outfrac)) > 0 do
  611.     outfrac := outfrac / 10;
  612.   IntToFrac := outfrac;
  613. end;
  614.  
  615.  
  616. function digits (fingers: real): longint;
  617. {
  618.   Returns the number of digits in an integer, minus sign counts as one digit.
  619.   Integer input expected. Type real of fingers is for log function.
  620. }
  621. var sign: integer;
  622. begin
  623.   if fingers < 0 then
  624.     sign := 1
  625.   else sign := 0;
  626.   if fingers = 0 then
  627.     digits := 1 {sore thumb}
  628.   else digits := sign + succ(trunk(int(log(abs(fingers)))));
  629. end;
  630.  
  631.  
  632. function StringIsBlank (blankstr: string): boolean;
  633. {
  634.   Tests if a string is blank. String with just spaces is considered blank.
  635. }
  636. begin
  637.   StringIsBlank := trim(blankstr) = '';
  638. end;
  639.  
  640.  
  641. function StrLastChar (instr: string): char;
  642. begin
  643.   StrLastChar := instr[ord(instr[0])];
  644. end;
  645.  
  646.  
  647. function TestBit (var bite: byte; bitnumber: byte): boolean;
  648. {
  649.   Tests a bit in a byte for true or false. Bits numbered 7 to 0.
  650. }
  651. begin
  652.   TestBit := bite AND (1 SHL bitnumber) <> 0;
  653. end;
  654.  
  655.  
  656. procedure SetBit (var bite: byte; bitnumber: byte);
  657. begin
  658.   bite := bite OR (1 SHL bitnumber);
  659. end;
  660.  
  661.  
  662. procedure ClearBit(var bite: byte; bitnumber: byte);
  663. begin
  664.   bite := bite AND not (1 SHL bitnumber);
  665. end;
  666.  
  667.  
  668. function ByteToStr (bite: byte): string;
  669. var
  670.   I,bit: byte;
  671. begin
  672.   ByteToStr[0] := chr(8);
  673.   I := 8;
  674.   for bit := 0 to 7 do
  675.     begin
  676.       ByteToStr[I] := chr(48 + ord(Testbit(bite,bit)));
  677.       dec(I);
  678.     end;
  679. end;
  680.  
  681.  
  682. function StrToByte (bitstr: string): byte;
  683. {
  684.   Packs a string of (0 to 8) 0s and 1s into a byte, right justified.
  685. }
  686. var I,J,strbyte: byte;
  687. begin
  688.   strbyte := $0;
  689.   I := ord(bitstr[0]);
  690.   J := 0;
  691.   while I > 0 do
  692.     begin
  693.       if bitstr[I] = '1' then
  694.         setbit(strbyte,J);
  695.       dec(I);
  696.       inc(J);
  697.     end;
  698.   StrToByte := strbyte;
  699. end;
  700.  
  701.  
  702. procedure strval (var number: real; decimal_places: integer);
  703. {
  704.   This procedure is used to ensure the arithmetic equivalence of numeric
  705.   and string representations of real numbers.
  706. }
  707. var tempstr: numstring;
  708.     width,
  709.     code:    integer;
  710. begin
  711.  
  712.   width := digits(number) + decimal_places;
  713.   str(number:width:decimal_places,tempstr);
  714.  
  715.   str(number,tempstr);
  716.   val(tempstr,number,code);
  717. end;
  718.  
  719.  
  720. function RealToString (inreal: real;decimal_places: integer): numstring;
  721. var rstring:  numstring;
  722. begin
  723.   str(inreal:digits(inreal):decimal_places,rstring);
  724.   RealToString := rstring;
  725. end;
  726.  
  727.  
  728. procedure value
  729.  
  730.     (instr:   numstring;
  731. var number:   longint;
  732.     maxvalue: longint;
  733. var code:     integer);
  734. {
  735.   Converts numeric string instr to number. Used by getnumber procedure (e.g.)
  736.   Returns code = -1 if number is outside range for type implied by maxvalue
  737. }
  738. var minvalue:  longint;
  739.     triminstr: string;
  740. begin
  741.   if (maxvalue = maxword) or (maxvalue = maxbyte) then
  742.     minvalue := 0
  743.   else minvalue := pred(- maxvalue);
  744.  
  745.   triminstr := instr;
  746.   instr := trim(triminstr) ;
  747.  
  748.   if (instr = '') or (instr = '-') then
  749.     instr := '0';
  750.  
  751.   if instr = strminlongint then {'-2147483648'}
  752.     begin
  753.       number := pred(-maxlongint);
  754.       code := 0;
  755.     end
  756.     {needed because of TP4 val bug: converts to 0}
  757.   else val(instr,number,code); {string -> number}
  758.  
  759.   if code = 0 then {range check for implied type}
  760.     if (number < minvalue) or (number > maxvalue) then
  761.       dec(code);
  762. end;
  763.  
  764.  
  765. procedure real_value
  766.  
  767.     (instr:   numstring;
  768. var number:   real;
  769. var code:     integer);
  770. {
  771.   Used to constrain size of reals. Checks that integer part of string
  772.   real is within range for longint type. Decimal part expected to be
  773.   zero if integer part is maxlongint or minlongint. Note number will
  774.   be rounded by Turbo if attempt is made to exceed 11 digit precision
  775.   of reals.
  776.  
  777.   anyreal := -214743647.99; write(anyreal:10:2); -> -2147483648.00
  778. }
  779. var value_number: longint;
  780.     cutoff:       integer;
  781.     tmpinstr:     numstring;
  782. begin
  783.   value_number := trunk(number);
  784.  
  785.   if (instr = '') or (instr = '-') then
  786.     instr := '0'; {for val}
  787.   if StrLastChar(instr) = '.' then
  788.     instr := instr + '0';                        {also for val}
  789.  
  790.   cutoff := pos('.',instr);
  791.   if cutoff = 0 then
  792.     cutoff := length(instr)
  793.   else dec(cutoff);
  794.  
  795.   tmpinstr := copy(instr,1,cutoff);
  796.   value(tmpinstr,value_number,maxlongint,code);
  797.   if code = 0 then
  798.     val(instr,number,code);
  799. end;
  800.  
  801.  
  802. end. {unit}
  803.  
  804.