home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PASCAL / ECO30603.ZIP / ECO30603.LZH / ECOLIBCS / eco_lib.pas < prev    next >
Encoding:
Pascal/Delphi Source File  |  1993-04-12  |  226.8 KB  |  8,038 lines
  1. {$A-,B-,D-,E-,F+,I-,L-,N-,O-,R-,S-,V-}
  2. {$M 65520, 0, 655360}
  3.  
  4. {$DEFINE USETURBODOS}
  5. {$DEFINE USETURBOCRT}
  6.  
  7. unit eco_lib;
  8. interface
  9. uses
  10.   crt
  11.  
  12. {$IFDEF USETURBODOS}
  13.   , dos
  14. {$ENDIF}
  15.  
  16.   ;
  17.  
  18.  
  19.  
  20.  
  21. {$IFNDEF VER40}
  22.   {$IFNDEF VER50}
  23.     {$IFNDEF VER55}
  24.       {$IFDEF VER70}
  25.         {$IFNDEF VER10}
  26.           {$DEFINE VER3HEAP}
  27.         {$ENDIF}
  28.       {$ENDIF}
  29.     {$ENDIF}
  30.   {$ENDIF}
  31. {$ENDIF}
  32.  
  33.  
  34.  
  35.  
  36.  
  37.  
  38. const
  39.   _dosminorver = 0; _dosmajorver = 5;
  40.   none = $00; only = $40; notnone = $80;
  41.  
  42.   _period      = $342E;  _colon       = $273A;  _c_2= $0300;
  43.   _slash       = $352F;  _padslash    = $E02F;  _c_6= $071E;
  44.                                                 _c_minus = $0C1F;
  45.   _left        = $4BE0;  _padleft     = $4B00;
  46.   _cleft       = $73E0;  _cpadleft    = $7300;
  47.   _right       = $4DE0;  _padright    = $4D00;
  48.   _cright      = $74E0;  _cpadright   = $7400;
  49.   _up          = $48E0;  _padup       = $4800;
  50.   _down        = $50E0;  _paddown     = $5000;
  51.   _pgup        = $49E0;  _padpgup     = $4900;
  52.   _pgdn        = $51E0;  _padpgdn     = $5100;
  53.   _home        = $47E0;  _padhome     = $4700;
  54.   _chome       = $7700;  _end         = $4FE0;
  55.   _padend      = $4F00;  _cend        = $7500;
  56.   _ins         = $52E0;  _padins      = $5200;
  57.   _del         = $53E0;  _paddel      = $5300;
  58.   _spaddel     = $532E;  _backspace   = $0E08;
  59.   _minus       = $0C2D;  _padminus    = $4A2D;
  60.   _plus        = $0D2B;  _padplus     = $4E2B;
  61.   _star        = $092A;  _padstar     = $372A;
  62.   _enter       = $1C0D;  _newline     = $1C0A;
  63.   _padenter    = $E00D;
  64.  
  65.   _tab         = $0F09;  _s_tab       = $0F00;  _quote     = $2827;
  66.   _esc         = $011B;  _space       = $3920;  _backquote = $2960;
  67.  
  68.   _a    = $1E61;  _b     = $3062;  _s_a  = $1E41;  _s_b   = $3042;
  69.   _c    = $2E63;  _d     = $2064;  _s_c  = $2E43;  _s_d   = $2044;
  70.   _e    = $1265;  _f     = $2166;  _s_e  = $1245;  _s_f   = $2146;
  71.   _g    = $2267;  _h     = $2368;  _s_g  = $2247;  _s_h   = $2348;
  72.   _i    = $1769;  _j     = $246A;  _s_i  = $1749;  _s_j   = $244A;
  73.   _k    = $256B;  _l     = $266C;  _s_k  = $254B;  _s_l   = $264C;
  74.   _m    = $326D;  _n     = $316E;  _s_m  = $324D;  _s_n   = $314E;
  75.   _o    = $186F;  _p     = $1970;  _s_o  = $184F;  _s_p   = $1950;
  76.   _q    = $1071;  _r     = $1372;  _s_q  = $1051;  _s_r   = $1352;
  77.   _s    = $1F73;  _t     = $1474;  _s_s  = $1F53;  _s_t   = $1454;
  78.   _u    = $1675;  _v     = $2F76;  _s_u  = $1655;  _s_v   = $2F56;
  79.   _w    = $1177;  _x     = $2D78;  _s_w  = $1157;  _s_x   = $2D58;
  80.   _y    = $1579;  _z     = $2C7A;  _s_y  = $1559;  _s_z   = $2C5A;
  81.  
  82.   _c_a  = $1E01;  _c_b   = $3002;  _a_a  = $1E00;  _a_b   = $3000;
  83.   _c_c  = $2E03;  _c_d   = $2004;  _a_c  = $2E00;  _a_d   = $2000;
  84.   _c_e  = $1205;  _c_f   = $2106;  _a_e  = $1200;  _a_f   = $2100;
  85.   _c_g  = $2207;  _c_h   = $2308;  _a_g  = $2200;  _a_h   = $2300;
  86.   _c_i  = $1709;  _c_j   = $240A;  _a_i  = $1700;  _a_j   = $2400;
  87.   _c_k  = $250B;  _c_l   = $260C;  _a_k  = $2500;  _a_l   = $2600;
  88.   _c_m  = $320D;  _c_n   = $310E;  _a_m  = $3200;  _a_n   = $3100;
  89.   _c_o  = $180F;  _c_p   = $1910;  _a_o  = $1800;  _a_p   = $1900;
  90.   _c_q  = $1011;  _c_r   = $1312;  _a_q  = $1000;  _a_r   = $1300;
  91.   _c_s  = $1F13;  _c_t   = $1414;  _a_s  = $1F00;  _a_t   = $1400;
  92.   _c_u  = $1615;  _c_v   = $2F16;  _a_u  = $1600;  _a_v   = $2F00;
  93.   _c_w  = $1117;  _c_x   = $2D18;  _a_w  = $1100;  _a_x   = $2D00;
  94.   _c_y  = $1519;  _c_z   = $2C1A;  _a_y  = $1500;  _a_z   = $2C00;
  95.  
  96.   _f1   = $3B00;  _f2    = $3C00;  _f3   = $3D00;  _f4    = $3E00;
  97.   _f5   = $3F00;  _f6    = $4000;  _f7   = $4100;  _f8    = $4200;
  98.   _f9   = $4300;  _f10   = $4400;
  99.  
  100.   _s_f1 = $5400;  _s_f2  = $5500;  _s_f3 = $5600;  _s_f4  = $5700;
  101.   _s_f5 = $5800;  _s_f6  = $5900;  _s_f7 = $5A00;  _s_f8  = $5B00;
  102.   _s_f9 = $5C00;  _s_f10 = $5D00;
  103.  
  104.   _c_f1 = $5E00;  _c_f2  = $5F00;  _c_f3 = $6000;  _c_f4  = $6100;
  105.   _c_f5 = $6200;  _c_f6  = $6300;  _c_f7 = $6400;  _c_f8  = $6500;
  106.   _c_f9 = $6600;  _c_f10 = $6700;
  107.  
  108.   _a_f1 = $6800;  _a_f2  = $6900;  _a_f3 = $6A00;  _a_f4  = $6B00;
  109.   _a_f5 = $6C00;  _a_f6  = $6D00;  _a_f7 = $6E00;  _a_f8  = $6F00;
  110.   _a_f9 = $7000;  _a_f10 = $7100;
  111.  
  112.   _left_just_str       = 0;
  113.   _right_just_str      = 1;
  114.   _center_str          = 2;
  115.  
  116.   _rem_white_str       = $0001;
  117.   _rem_lead_white_str  = $0002;
  118.   _rem_trail_white_str = $0004;
  119.   _reduce_white_str    = $0008;
  120.   _save_quoted_str     = $0010;
  121.   _to_upcase_str       = $0020;
  122.   _to_lowcase_str      = $0040;
  123.   _discard_str         = $0080;
  124.  
  125.   _usa_dt_str          = 0;
  126.   _euro_dt_str         = 1;
  127.   _year_dt_str         = 2;
  128.   _mont_dt_str         = 3;
  129.   _form_dt_str         = 4;
  130.  
  131.   _12hour_str          = $0001;
  132.   _inc_sec_str         = $0002;
  133.   _inc_tic_str         = $0004;
  134.   _inc_ampm_str        = $0008;
  135.   _standard_str        = $0009;
  136.   _complete_str        = $0006;
  137.   _dos_dir_str         = $0011;
  138.  
  139.   _ampm_str            : array[0..1] of string[3] = (' AM',' PM');
  140.   _ap_str              : string[2] = 'ap';
  141.  
  142.   _fmt_buflen_str      = 256;
  143.  
  144.   _strmonths  : array[1..12] of string[9] = (
  145.     'January', 'February', 'March', 'April', 'May', 'June', 'July',
  146.     'August', 'September', 'October', 'November',  'December'
  147.   );
  148.  
  149.   _strdays    : array[0..6] of string[9] = (
  150.     'Sunday', 'Monday', 'Tuesday', 'Wednesday',
  151.     'Thursday', 'Friday', 'Saturday'
  152.   );
  153.   _colours    : array[0..15] of string[12] = (
  154.     'Black', 'Blue', 'Green', 'Cyan', 'Red', 'Magenta', 'Brown',
  155.     'LightGray', 'Darkgray', 'LightBlue', 'LightGreen', 'LightCyan',
  156.     'LightRed', 'LightMagenta', 'Yellow', 'White'
  157.   );
  158.  
  159.   _strusach   : char = '/';
  160.   _streuroch  : char = '-';
  161.   _strmoneych : char = 'f';
  162.  
  163.   _dirslash   : char = '/';
  164.   _dircase    : word = _to_lowcase_str;
  165.   _slashset   : set of char = ['/', '\'];
  166.  
  167.   fk_ctrl_mark: char = '^';
  168.   nonblock    : char = '-';
  169.   block       : char = 'X';
  170.   maxstr_     =        255;
  171.  
  172. {$IFNDEF USETURBODOS}
  173.  
  174.   (* flags bit masks *)
  175.  
  176.   fcarry     = $0001;
  177.   fparity    = $0004;
  178.   fauxiliary = $0010;
  179.   fzero      = $0040;
  180.   fsign      = $0080;
  181.   foverflow  = $0800;
  182.  
  183.   (* file mode magic numbers *)
  184.  
  185.   fmclosed = $d7b0;
  186.   fminput  = $d7b1;
  187.   fmoutput = $d7b2;
  188.   fminout  = $d7b3;
  189.  
  190.  
  191.   (* file attribute constants *)
  192.   readonly  = $01;
  193.   hidden    = $02;
  194.   sysfile   = $04;
  195.   volumeid  = $08;
  196.   directory = $10;
  197.   archive   = $20;
  198.   anyfile   = $3f;
  199. {$ENDIF}
  200.  
  201.  
  202. type
  203.   stream = file;
  204.  
  205.   searchrecord = record
  206.     attr   :       byte;
  207.     time   :    longint;
  208.     size   :    longint;
  209.     name   : string[12];
  210.    {fill   : array[1..21] of byte; we don't need that!}
  211.   end;
  212.  
  213. {$IFNDEF USETURBOCRT}
  214.   textbuf = array [0..127] of char;
  215.   textrec = record
  216.     handle    : word;
  217.     mode      : word;
  218.     bufsize   : word;
  219.     private   : word;
  220.     bufpos    : word;
  221.     bufend    : word;
  222.     bufptr    : ^textbuf;
  223.     openfunc  : pointer;
  224.     inoutfunc : pointer;
  225.     flushfunc : pointer;
  226.     closefunc : pointer;
  227.     userdata  : array [1..16] of byte;
  228.     name      : array [0..79] of char;
  229.     buffer    : textbuf;
  230.   end;
  231. {$ENDIF}
  232.  
  233.   comstr  = string[127];        { command line string }
  234.   pathstr = string[79];         { full file path string }
  235.   dirstr  = string[67];         { drive and directory string }
  236.   namestr = string[8];          { file name string }
  237.   extstr  = string[4];          { file extension string }
  238.   filestr = string[12];         { file name + extension string }
  239.  
  240. {$IFNDEF USETURBODOS}
  241.   registers = record case integer of
  242.     0 : (ax,bx,cx,dx,bp,si,di,ds,es,flags : word);
  243.     1 : (al,ah,bl,bh,cl,ch,dl,dh : byte);
  244.   end;
  245.   searchrec = record
  246.     fill : array [1..21] of byte;
  247.     attr : byte;
  248.     time : longint;
  249.     size : longint;
  250.     name : string[12];
  251.   end;
  252.  
  253.   datetime = record
  254.     year,month,day,hour,min,sec : word;
  255.   end;
  256. {$ENDIF}
  257.  
  258.   _memorychar = array[1..65534] of char;
  259.   _vectoraddr = record _ofs : word; _seg : word end;
  260.   str3        =              string[3];
  261.   str8        =              string[8];
  262.   str9        =              string[9];
  263.   str32       =             string[32];
  264.   anystr      =                 string;
  265.   asciiz      =  array[0..255] of char;
  266.   asciizptr   =                ^asciiz;
  267.   ar1024      = array[1..1024] of char;
  268.  
  269.  
  270.  
  271. const
  272.   nullchar = $00;
  273.   colon    = ':';
  274.   period   = '.';
  275.   separ    = '·';
  276.   space    = ' ';
  277.   zero     = '0';
  278.   maxtimer =  10;
  279.  
  280. type
  281.   daterecord = record
  282.     year      : word;
  283.     month     : word;
  284.     date      : word;
  285.     dayofweek : word
  286.   end;
  287.  
  288.   timerecord = record
  289.     hour      : word;
  290.     minute    : word;
  291.     second    : word;
  292.     hundredth : word
  293.   end;
  294.  
  295.   clockrecord = record
  296.     clockstartdate : daterecord;
  297.     clockstarttime : timerecord;
  298.     elapsedtime    : timerecord;
  299.     clockisrunning : boolean;
  300.   end;
  301.  
  302. var
  303.   clockarray     : array[0..maxtimer] of clockrecord;
  304.   exitcode       :    word;
  305. {$IFNDEF USETURBODOS}
  306.   doserror       : integer;
  307. {$ENDIF}
  308.   _dosdrv        : integer;
  309.   _dosdrvchar    :    char;
  310.   _doscurpath    : pathstr;
  311.   _dospath       :  string;
  312.   _dosdiscfree,
  313.   _dosdiscsize   : longint;
  314.  
  315.  
  316.  
  317.  
  318.  
  319.  
  320.  
  321.  
  322. { BASE STRING FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  323.   function __leftstr(source : string;   num : word): string;
  324.   function __rightstr(source : string; chpos : word): string;
  325.   function __substr(source : string;   chpos, num: word): string;
  326.   function __midstr(source,target : string; chpos: word): string;
  327.   function __fillstr(
  328.     fillch : char; target : string;
  329.     chpos,num : word
  330.   ): string;
  331.   function __xlatestr(source,table,trans : string) : string;
  332.   function __juststr(
  333.     source : string;  fillch : char;
  334.     fieldsize : word;
  335.     justcode : word
  336.   ): string;
  337.   function __cvtstr(source : string; cvtcode : word) : string;
  338.   function __entabstr(source : string; incr : byte) : string;
  339.   function __detabstr(
  340.     source : string; incr : byte;
  341.     var remstr : string
  342.   ): string;
  343.   function __toradstr(
  344.     intvalue : longint;
  345.     size,radix,width: word
  346.   ): string;
  347.   function __todecstr(intvalue: longint; size: word) : string;
  348.   function __tohexstr(intvalue: longint; size: word) : string;
  349.   function __ptr2str(thisptr: pointer): string;
  350.   function __formstr(mask : string; x : real) : string;
  351.   procedure __initfstr(var fmtfil : text);
  352.   function __retbfstr(var fmtfil : text) : string;
  353.   function locase(ch: char): char;
  354.   function __part(s: string; a, b: byte): string;
  355.  
  356.  
  357.  
  358.  
  359.  
  360.  
  361.  
  362. { SECONDARY STRING FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  363.   procedure __app(var st: string; aps: string);
  364.   function  __backapp(s: string) : string;
  365.   function  __backrem(s: string) : string;
  366.   function  __lastchr(s: string) : char;
  367.  
  368.   function  __comp(s1, s2: string): boolean;
  369.   function  __overtype(n:byte;strs,strt:string):string;
  370.   function  __rep(n: byte; character: char): string;
  371.   function  __nw(s: string): string;
  372.  
  373.   function  __pntstr(n: longint): string;
  374.   function  __up(s: string): string;
  375.   function  __lo(s: string): string;
  376.   function  __uprem(s: string): string;
  377.  
  378.   function  __hexdecstr(hexstr: string): longint;
  379.   function  __str(st: string): integer;
  380.   function  __num(nr: longint): string;
  381.   function  __val(st: string): longint;
  382.   function  __real(st: string): real;
  383.   function  __streal(nr: real; decs: byte): string;
  384.  
  385.   function  __byte2str(b: byte): str8;
  386.   function  __str2byte(s: str8): byte;
  387.   function  __longint2str(l: longint): str32;
  388.   function  __str2longint(s: str32): longint;
  389.  
  390.   procedure __str2obj(s: anystr; var a; length_a: integer);
  391.   procedure __str2arr(s: anystr; var a; length_a: integer);
  392.   function  __readctrls(s: anystr): anystr;
  393.   function  __writectrls(s: anystr): anystr;
  394.   function  __az2str(a: asciiz): string;
  395.   procedure __str2az(s: string; var a : asciiz);
  396.  
  397.   procedure __clr1024(var a: ar1024);
  398.   procedure __app1024(var app: ar1024; s: string);
  399.   function  __len1024(var a: ar1024) : word;
  400.   procedure __del1024(var a: ar1024; b, l: word);
  401.   procedure __ins1024(var a: ar1024; b : word; s: string);
  402.   procedure __write1024(var a: ar1024);
  403.  
  404.   function  __nonascii(s: string): boolean;
  405.   function  __killnonascii(s: string): string;
  406.  
  407.  
  408.  
  409.  
  410.  
  411. { PRIMARY DATA CONVERSION FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  412.   function  __main(b: longint; w: word): longint;
  413.   function  __max(v1, v2: longint): longint;
  414.   function  __min(v1, v2: longint): longint;
  415.   function  __power(x,y: integer): longint;
  416.  
  417.  
  418.  
  419.   function __2longsup(hiword,loword : word): longint;
  420.   inline($58 { pop ax } /$5A); { pop dx          }
  421.  
  422.   function __hiwrdsup(intvalue : longint) : word;
  423.   inline($58 { pop ax } /$58); { pop ax }
  424.  
  425.     function __lowrdsup(intvalue : longint) : word;
  426.   inline($58 { pop ax } /$5A); { pop dx }
  427.  
  428.   function  __2wordsup(hibyte,lobyte : byte) : word;
  429.   inline($58 { pop ax } /$5A { pop dx } /$8A/$E2); { mov ah,dl }
  430.  
  431.   function __2bytesup(hinybble,lonybble : byte) : byte;
  432.   inline(
  433.     $5B/      { pop bx     }  $58/          { pop ax     }
  434.     $32/$E4/  { xor ah,ah  }  $b1/$04/      { mov cl,4   }
  435.     $d3/$E0/  { shl ax,cl  }  $80/$e3/$0f/  { and bl,0fh }
  436.     $0A/$C3   { or  al,bl  }
  437.   );
  438.  
  439.   function  __hinybsup(bytevalue : byte) : byte;
  440.   inline(
  441.     $58 { pop ax } /$32/$E4  { xor ah,ah }
  442.     /$B1/$04 { mov cl,4 } /$D3/$E8 { shr ax,cl }
  443.   );
  444.  
  445.     function __lonybsup(bytevalue : byte) : byte;
  446.   inline($58 { pop ax } /$25/$0F/$00); { and ax,000fh }
  447.  
  448.   procedure __fcallsup(procptr : pointer; var reg : registers);
  449.   inline(
  450.     $8B/$DC/ { mov  bx,sp } $83/$C3/$04/  { add  bx,4 }
  451.     $36/$FF/$1F/ { call dword ptr ss:[bx] } $83/$C4/$04 { add  sp,4 }
  452.   );
  453.  
  454.   procedure __ncallsup(procptr : pointer; var reg : registers);
  455.   inline(
  456.     $8B/$DC { mov  bx,sp } /$83/$C3/$04 { add  bx,4 }
  457.     /$36/$FF/$17 { call word ptr ss:[bx] } /$83/$C4/$04 { add  sp,4 }
  458.   );
  459.  
  460.     function  __caddrsup : pointer;
  461.     inline(
  462.     $8B/$46/$02 { mov ax,[bp + 2] } /$2D/$03/$00 { sub ax,3 }
  463.     /$8B/$56/$04 { mov dx,[bp + 4] }
  464.   );
  465.  
  466.   procedure __iptrsup (var p : pointer; n : longint);
  467.   procedure __dptrsup (var p : pointer; n : longint);
  468.   function  __nptrsup (thisptr : pointer) : pointer;
  469.   function  __ptr2lsup(thisptr : pointer) : longint;
  470.   procedure __fillwsup(var target; count : longint; fillword : word);
  471.   procedure __fillbsup(var target; count : longint; fillbyte : byte);
  472.   procedure __repmsup (var target,source; count : longint; sourcesize : word);
  473.   function  __alphasup(ch : char) : boolean;
  474.  
  475.  
  476.  
  477.  
  478.  
  479.  
  480. { IMPORTANT DOS FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  481. const
  482.   _keep_mode  = -1;        { do not change file mode in fopen }
  483.   _readonly   = $00;       {     share mode dos 3++ and above }
  484.   _denyall    = $10;
  485.   _writeonly  = $01;
  486.   _denywrite  = $20;
  487.   _readwrite  = $02;
  488.   _denyread   = $30;
  489.   _denynone   = $40;
  490.  
  491.   lockregion   = 00;
  492.   unlockregion = 01;
  493.  
  494.  
  495. {typed}const
  496.   casesensitive_env: boolean = false;
  497.  
  498. var
  499.   lastkey     :    char;
  500.   lastscan    :    byte;
  501.   _envseg     :    word;
  502.   envsize_    :    word;
  503.   envmemptr_,
  504.   _envptr,
  505.   envptr      : pointer; { pointer to environment table }
  506.   registeredprogname : string;
  507.  
  508.  
  509. {$IFNDEF USETURBODOS}
  510.   procedure getdate(var year,month,day,dayofweek : word);
  511.   procedure setdate(year,month,day : word);
  512.   procedure gettime(var hour,minute,second,sec100 : word);
  513.   procedure settime(hour,minute,second,sec100 : word);
  514.  
  515.   function  diskfree(drive : byte) : longint;
  516.   function  disksize(drive : byte) : longint;
  517.  
  518.   procedure getfattr(var f;var attr : word);
  519.   procedure setfattr(var f;attr : word);
  520.   procedure getftime(var f;var time : longint);
  521.   procedure setftime(var f;time : longint);
  522.  
  523.   procedure findfirst(path : pathstr;attr : word;var f : searchrec);
  524.   procedure findnext(var f : searchrec);
  525.  
  526.   function  fexpand(path : pathstr) : pathstr;
  527.   procedure fsplit(
  528.     path : pathstr;var dir : dirstr;
  529.     var name : namestr;var ext : extstr
  530.   );
  531.   procedure intr(intno: byte; var regs: registers);
  532.   procedure getintvec(intno: byte;var vector: pointer);
  533.   procedure swapvectors;
  534. {$ENDIF}
  535.  
  536.   function  __existfil(pathname : string) : boolean;
  537.   procedure __erasefil(filename : pathstr; var errorcode : word);
  538.   function  __progname: string;
  539.  
  540.  
  541. type
  542.   _keystatus = record          { keyboard shift status record }
  543.     _rightctrlshift: boolean;  {      right ctrl depressed    }
  544.     _rightaltshift : boolean;  {      right alt  depressed    }
  545.     _insstate      : boolean;  {      insert state is active  }
  546.     _capsstate     : boolean;  {      caps lock key toggled   }
  547.     _numstate      : boolean;  {      num lock key toggled    }
  548.     _scrollstate   : boolean;  {      scroll lock key toggled }
  549.     _altshift      : boolean;  {      alt shift key depressed }
  550.     _ctrlshift     : boolean;  {      ctrl shift depressed    }
  551.     _leftshift     : boolean;  {      left shift key depressed}
  552.     _rightshift    : boolean;  {      right shift depressed   }
  553.     _insshift      : boolean;  {      ins key depressed       }
  554.     _capsshift     : boolean;  {      caps lock key depressed }
  555.     _numshift      : boolean;  {      num lock key depressed  }
  556.     _scrollshift   : boolean;  {      scroll lock depressed   }
  557.     _holdstate     : boolean;  {      suspend state toggled   }
  558.     _sysshift      : boolean;  {      sysreq depressed & held }
  559.     _leftctrlshift : boolean;  {      left ctrl depressed     }
  560.     _leftaltshift  : boolean;  {      left alt depressed      }
  561.   end;
  562.  
  563.  
  564.   function  __dosinkey(var extendedcode : byte) : char;
  565.   function  __retkey: word;
  566.   function  __direction(w: word): boolean;
  567.   function  __retdelaykey(delaytim: byte; default: word): word;  { delay < 60 }
  568.   function  __exinkey(useextended: boolean; var scancode: byte): char;
  569.   function  __exrdykey(
  570.     useextended : boolean;
  571.     var nextch : char;
  572.     var scancode : byte
  573.   ) : boolean;
  574.   function  keypressed : boolean;
  575.   procedure __flushkey;
  576.   function  __queuekey : word;
  577.   procedure __delay(w: word);
  578.   procedure __delaykey(w:word);
  579.   function __spaceutl(
  580.     drive : byte;
  581.     var availclus, totalclus,
  582.     bytespersec, secsperclus: word
  583.   ): longint;
  584.   function __paridutl(var cmdprocid : word) : word;
  585.   function cmdenvseg(var cmdprocid: word): word;
  586.   function __putenutl(envstr: string): string;
  587.   function __retenutl(var envpos : word) : string;
  588.   function __chgenutl(progseg: word; envstr: string; var error: word): string;
  589.   function __envpath(st: string): string; { ends on \ }
  590.   function __getpath(var fname : string) : boolean;
  591.  
  592.   function __address(zone, net, node, point: integer): string;
  593.   procedure __expandnum(
  594.     node : string; var tozone, tonet, tonode, topoint: word
  595.   );
  596.   function __expandchr(st: string; c: char; chh:  string): string;
  597.   function __statkey(var status : _keystatus) : longint;
  598.   function __ctrlkey(status : _keystatus) : longint;
  599.   function  __stuffkey(charstr : string) : string;
  600.   procedure __resetsup(testmem : boolean);
  601.   procedure __resetfil;
  602.  
  603.  
  604.  
  605.  
  606.  
  607.  
  608.  
  609.  
  610.  
  611.   { LOCK FUNCTIONS }
  612.   function fopen(var fv : stream; fn : pathstr; mode : integer) : integer;
  613.   function fclose(var fv : stream) : integer;
  614.   function shareloaded : boolean;
  615.   function filelock(
  616.     handle :    word;
  617.     action :    byte;
  618.     start,
  619.     bytes  : longint;
  620.     var ax : integer
  621.   ): boolean;
  622.  
  623.  
  624.  
  625.  
  626.  
  627. { DATE FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  628.   function  __dt2ststr(year, month, day, datefmt : word): string;
  629.   function  __datestr(var year,month,day: word): string;
  630.   function  __timestr(var hours,minutes,seconds,tics: word): string;
  631.   procedure __st2dtstr(st: string; var year, month, day: word; datefmt: word);
  632.   function  __time2str(hours, mins, secs, tics, format: word): string;
  633.   function  __2timestr(timestr: string; var hours,mins,secs,tics:word): boolean;
  634.  
  635.   function  __retdowstr(dayofweek: word; ful: boolean): string;
  636.   function  __todaystr(ful: boolean): string;
  637.   procedure __jl2dtutl(julian: longint; var year, month, day, weekday: word);
  638.   function  __dt2jlutl(year, month, day : word) : longint;
  639.   function  __daysutl(yr1, mn1, day1 : word; yr2, mn2, day2 : word) : longint;
  640.   function  __retdow(y, m, d: word): word;
  641.   function  __today: byte;
  642.  
  643.   function  __curdate: string;
  644.   function  __curdate2longint: longint;
  645.   function  __longint2date(l: longint): string;
  646.   function  __date2longint(d: string): longint; {     'xx NNN yy  HH:MM.ss' }
  647.                                                 { eg. '22 Aug 69  14:50.11' }
  648.   procedure __longint2datetime(d : longint; var dt : datetime);
  649.   function  format_date(dt : datetime; format : byte): string;
  650.   function  __formatdate(d : longint; format : byte): string;
  651.  
  652.   function  __dbdate: string;
  653.   function  __radate: string;
  654.  
  655. {$IFNDEF USETURBODOS}
  656.   procedure unpacktime(p : longint;var t : datetime);
  657.   procedure packtime(var t : datetime;var p : longint);
  658. {$ENDIF}
  659.  
  660.  
  661.  
  662.  
  663.  
  664. { IMPORTANT TIMER FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  665.   procedure starttimer(whichclock : byte);
  666.   function  getlaptime(whichclock : byte) : string;
  667.   procedure restarttimer(whichclock : byte);
  668.   function  stoptimer(whichclock : byte) : string;
  669.  
  670.  
  671.  
  672.  
  673.  
  674.  
  675. { IMPORTANT FILE FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  676. const
  677.   info : array[0..6] of string[27] = (
  678.     'Successful.',
  679.     'Source and target the same!',
  680.     'Cannot open source!',
  681.     'Unable to create target!',
  682.     'Error during copy!',
  683.     'Cannot allocate buffer!',
  684.     'Not enough free discspace!'
  685.   );
  686.   function  __retdrfil : char;
  687.   function  __attrfilter(fileattr, filter: byte): boolean;
  688.   function  __bak(s: string): string;
  689.   function  __comexebatcmdfilter(s: string): boolean;
  690.   function  __curdir: string;
  691.   function  __deverr: string;
  692.   procedure __drvparm(drv: char);
  693.   procedure __erasefiles(s: string);
  694.   function  __existpath(s: string): boolean;
  695.   function  __has_ext(name : string; var dotpos : word) : boolean;
  696.   function  __def_ext(name, ext : string) : string;
  697.   function  __set_ext(name, ext : string) : string;
  698.   function  __mat2str(var mat; s : byte):string;
  699.   function  __extractext(name: string): str3;
  700.   function  __extractname(s : string): string;
  701.   function  __extractnamext(s : string): string;
  702.   function  __extractpath(s : string): string;
  703.   function  __findfil(f: string; var s: string): boolean;
  704.   function  __inparams(s: string; var i: word): boolean;
  705.   function  __checkstr(pa, en: string; var j, k : word): boolean;
  706.   function  __packfil(str: string; size: byte): string;
  707.   procedure __parsefil(name: filestr; var nam: namestr; var ext: extstr);
  708.   function  __reteqfil(drv: char; var errorcode: byte): char;
  709.   function  __seteqfil(drv: char; var errorcode: byte): char;
  710.   function  __slashfil(s: string): string;
  711.   function  __normfil(filename : pathstr) : pathstr;
  712.   procedure __splitfil(
  713.     pathname     :  pathstr;
  714.     var subdir   :   dirstr;
  715.     var filename :  namestr;
  716.     var fileext  :   extstr
  717.   );
  718.   procedure __srec2srec(s: searchrec; var s2: searchrecord);
  719.   function  __searchrec(
  720.     src                  : searchrec;
  721.     nm, woord, mainsize  :      word;
  722.     takemainsize, extended,
  723.     ampm, show_attr,
  724.     wide                 :   boolean
  725.   ): string;
  726.   function  __sizefil(pt: string): longint;
  727.   function  __strattr(attr: byte; full: boolean): string;
  728.   procedure __uniquefil(               { i.s.o. __tempfil, an unique textfile }
  729.     var pathname: string; var tmpfile: text; var errorcode: word
  730.   );
  731.   function  __copyfil(show: boolean; x1,x2,y,f,b: byte; fs: longint; src, targ: string): byte;
  732.   procedure __renamfil(prevname,newname : pathstr; var errorcode : word);
  733.   function  __slicefil(x1, x2, y, f, b: byte; haksize:longint; src:string): byte;
  734.   function  __isdrvfil(drive : char; var errorcode : word) : boolean;
  735.   function  __retvlfil(drive : char; var volstamp : longint) : string;
  736.   function  __handlfil(var filevar) : word;
  737.   function  __isconfil(handle : word) : boolean;
  738.  
  739.  
  740.  
  741.  
  742.  
  743.  
  744.  
  745.  
  746.  
  747.  
  748.  
  749.  
  750. const
  751.   maxfiles = 4096;
  752.  
  753. type
  754.   filarraytype = array[1..maxfiles] of ^searchrec;
  755.   filarraytypeptr = ^filarraytype;
  756.   sortmethods = (on_name, on_extension, on_datetime, on_size);
  757.   condition_attrstype = record
  758.     show_r_o : boolean;
  759.     show_hid : boolean;
  760.     show_sys : boolean;
  761.     show_arc : boolean;
  762.     show_vol : boolean;
  763.     show_dir : boolean;
  764.     show_non : boolean;
  765.     sort_method : sortmethods;
  766.   end;
  767.  
  768. const
  769.   std_condition_attrs : condition_attrstype = (
  770.     show_r_o    :  true;
  771.     show_hid    :  true;
  772.     show_sys    :  true;
  773.     show_arc    :  true;
  774.     show_vol    :  true;
  775.     show_dir    :  true;
  776.     show_non    :  true;
  777.     sort_method :  on_name
  778.   );
  779.  
  780.  
  781. var
  782.   conditionfuncptr_ : pointer;
  783.   filitems          :    word;
  784.  
  785.   {$F+}
  786.  
  787. const
  788.   renew_space : boolean = true;
  789.  
  790.   procedure set_std_condition_attrs(attrs: condition_attrstype);
  791.   procedure __dirutl(
  792.     comexebatcmdfilter  :         boolean;
  793.     searchpath          :         pathstr;
  794.     var filar           : filarraytypeptr;
  795.     searchattr          :            byte;
  796.     manipulate          :            byte;
  797.     var error,
  798.     counted_dirs        :            word;
  799.     vol_counted         :         boolean;
  800.     condit,
  801.     sorter              :         pointer;
  802.     var totnum          :         longint
  803.   );
  804.   procedure dispose_filarray(var fil: filarraytypeptr);
  805.   procedure new_filarray(var fil: filarraytypeptr);
  806.   function std_sort(var data1, data2): boolean;
  807.   function std_condition(var srec): boolean;
  808.   function no_condition(var srec): boolean;
  809.  
  810.  
  811.  
  812.  
  813.  
  814. { XXXXXXXXXX LOG FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  815. const
  816.   logfilename : pathstr    = 'ECOPURGE.LOG';         { 22 Aug 69  14:50.11 }
  817.   programname : string[40] =     'ECOPURGE';
  818.   purge : byte =   7;
  819.   lines : word = 512;
  820.  
  821. var
  822.   logheader   : array[1..11] of string[62];
  823.   error,
  824.   yr, mo, da : word;
  825.   i          : byte;
  826.  
  827.  
  828.  
  829.   procedure __loginit;
  830.   procedure __logapp(s: string);
  831.   procedure __filapp(fil, s : string);
  832.  
  833.   procedure __setpurge(b: byte);
  834.   procedure __logpurge;
  835.  
  836.   function  __recent(s: string): boolean;
  837.  
  838.  
  839.  
  840.  
  841.  
  842. { XXXXXXXXXXXX FAST SCREEN FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  843.  
  844. type
  845.   _scnpos = record _ch : char; _attr : byte end;
  846.   _scnimage    = array[1..4000] of _scnpos;
  847.   _scnimageptr = ^_scnimage;
  848.   str80 = string[80];
  849.   _monitortype = (
  850.     _nomonitor,
  851.     _monomonitor,      { monochrome monitor             }
  852.     _colormonitor,     { color monitor (composite also) }
  853.     _enhancedmonitor,  { ega enhanced color monitor     }
  854.     _anmonomonitor,    { ps/2 analog monochrome monitor }
  855.     _ancolormonitor    { ps/2 analog color monitor      }
  856.   );
  857.  
  858.  
  859. const
  860.   fcol: byte = 7;
  861.   bcol: byte = 0;
  862.   bt_double    = 15;     bt_single    =  1;
  863.   sh_default   = 255;    sh_high      = 254;   sh_low      = 253;
  864.   black        = 00;     blue         = 01;
  865.   green        = 02;     cyan         = 03;
  866.   red          = 04;     magenta      = 05;
  867.   brown        = 06;     lightgray    = 07;
  868.   darkgray     = 08;     lightblue    = 09;
  869.   lightgreen   = 10;     lightcyan    = 11;
  870.   lightred     = 12;     lightmagenta = 13;
  871.   yellow       = 14;     white        = 15;
  872.   blink        = 128;
  873.  
  874.   _unknown     = $7f;
  875.   _absent      = 0;                 { no adapter installed           }
  876.   _mono        = 1;                 { monochrome type adapter        }
  877.   _color       = 2;                 { color type adapter             }
  878.  
  879.   _biosseg     = $0040;             { segment of bios/dos communica- }
  880.  
  881.  
  882. var
  883.   _hidemouse      : byte;
  884.   baseofscreen,
  885.   vseg, vofs,
  886.   rows, cols,
  887.   _curcolumns,                         { number of screen columns       }
  888.   _currows        : word;              { number of screen rows          }
  889.  
  890.   _scnloc         : _scnimageptr;      { screen adapter memory location }
  891.   _curmonitor     : _monitortype;      { monitor attached to _curdevice }
  892.   _curmode        : byte;              { current video display mode     }
  893.   _curdevice      : byte;              { _mono or _color device         }
  894.   _maxdisplaypage : byte;              { maximum display page number    }
  895.   _curdisplaypage : byte;              { current video display page     }
  896.   _curactivepage  : byte;              { current video active page      }
  897.   _monoadapter    : byte;              { monochrome adapter             }
  898.   _coloradapter   : byte;              { color/graphics adapter         }
  899.   _egaadapter     : byte;              { ega adapter                    }
  900.   _hercadapter    : byte;              { hercules mono graphics card    }
  901.   _vgaadapter     : byte;              { ps/2 video graphics array      }
  902.   _mcgaadapter    : byte;              { ps/2 model 30 adapter          }
  903.   _scrolltab      : word;              { spaces to skip for tab scroll  }
  904.   _tabincr        : word;              { tab increment for _txbufscn    }
  905.   _bufindent      : word;              { left margin for _txbufscn      }
  906.  
  907.   {scnstate_         : scnstat_;    }  { bios video save information    }
  908.   {availcolormodes_  : videomodes_; }  { modes available on color device}
  909.   {availmonomodes_   : videomodes_; }  { modes available on mono device }
  910.   {availcolorrows_   : legalrows_;  }  { rows available on color device }
  911.   {availmonorows_    : legalrows_;  }  { rows available on mono device  }
  912.   {dualdisplay_      : boolean;     }  { two adapters present           }
  913.   egamonitor_        : _monitortype;   { monitor attached: ega          }
  914.   analogmonitor_     : _monitortype;   { monitor attached: vga/mcga     }
  915.   egamemory_         : word;           { 64, 128, 192, or 256 (k)       }
  916.   maxscanline_       : byte;           { current character set size     }
  917.  
  918. var
  919.   scn1, scn2,
  920.   scn3, scn4         : _scnimageptr;
  921.  
  922.  
  923.   function  __attr(f, b: byte): byte;
  924.   function  __loc(x, y : byte; var fore, back : byte): char;
  925.   procedure __scn(col, row, attr: byte; st: str80);
  926.   procedure __vid(col, row:       byte; st: str80);
  927.   procedure changeattr(col,row,attr: byte; number: word);
  928.   function  get_video_mode: byte;
  929.  
  930.   { extended functions, just like in eco_vid, but for small use }
  931.   procedure __attrib(x1, y1, x2, y2, f, b: byte);
  932.   procedure __bandwin(del: boolean; x1,y1,x2,y2,f,b,shadow,bt: byte);
  933.   procedure __betwscn(x1, x2, y, f, b: byte; st: string);
  934.   procedure __hbetwscn(x1, x2, y, f, b, h: byte; st: string);
  935.   procedure __boxscn(x1,y1,x2,y2,boxtype,fore,back : byte);
  936.   procedure __clrscn(x1, y1, x2, y2, f, b: byte; c: char);
  937.   procedure __cls;
  938.   procedure __copyscn(x1, y1, x2, y2, x, y: byte);
  939.  
  940.   procedure __equipscn;
  941.   function __retdvscn(
  942.     var dvmode    : byte;
  943.     var dvcols    : word;
  944.     var dvrows    : word;
  945.     var dbactpage : byte;
  946.     var dvdispage : byte
  947.   ): byte;
  948.  
  949.   procedure __vert(x, y, f, b: byte; s: string);
  950.   procedure __write(col, row, f, b: byte; st: str80);
  951.   procedure __hwrite(x, y, f, b, h: byte; st: string);
  952.  
  953.   procedure __partscn(sc: _scnimageptr; x1, y1, x2, y2: byte; toscreen: boolean);
  954.   procedure __resscn(sc: _scnimageptr);
  955.   procedure __savscn(sc: _scnimageptr);
  956.   procedure __speedscn(
  957.     sourceptr, targetptr     : pointer;
  958.         count, option, attribute :    word;
  959.         wait                     : boolean
  960.   );
  961.   function  __barchoice(x,x1,y,f,b,h : byte; st: string; timeout: byte): byte;
  962.   { error = 255: debugging mode; else no debuginfo display }
  963.   function  __barcheck(s: string; var error: byte): boolean;
  964.   procedure __setblwin(blinkon : boolean);
  965.  
  966.  
  967.  
  968.  
  969.  
  970.  
  971. { XXXXXXXXXXXX CRT FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  972.   procedure __stdio;
  973.  
  974.  
  975.  
  976.  
  977.  
  978.  
  979.  
  980.  
  981.  
  982.  
  983.  
  984.  
  985.   { XXXXXXXXXXXX CRC FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  986.   function __crc32(value: byte; crc: longint) : longint;
  987.   function __crc16(value: byte; crc: word)    :    word;
  988.  
  989.  
  990.  
  991.  
  992.  
  993.  
  994.  
  995.  
  996.  
  997.   { XXXXXXXXXXXX SELECTION FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  998.  
  999. const
  1000.   _fore : byte =  7;
  1001.   _back : byte =  0;
  1002.   _x1   : byte = 10;
  1003.   _y1   : byte =  5;
  1004.   _x2   : byte = 30;
  1005.   _y2   : byte = 15;
  1006.  
  1007.   _noerror_sel     = 0;
  1008.   _nopickrec_sel   = 1;
  1009.   _invwindow_sel   = 2;
  1010.   _invpath_sel     = 3;
  1011.   _dispwin_sel     = 4;
  1012.   _titlewin_sel    = 5;
  1013.   _remwin_sel      = 6;
  1014.   _zapwin_sel      = 7;
  1015.   _memalloc_sel    = 8;
  1016.   _selerror : word = _noerror_sel;
  1017.   _nofilesmsg : string[10] = ' No Files';
  1018.   _name_fmt_sel    = 0;
  1019.   _dos_fmt_sel     = 1;
  1020.  
  1021.  
  1022. type
  1023.   _pickptr = ^_pick;
  1024.   _pick = record
  1025.     _barfore    :       byte;
  1026.     _barback    :       byte;
  1027.     _keyproc    :    pointer;
  1028.     _itemlen    :       word;
  1029.     _numitems   :       word;
  1030.     _itemsize   :       word;
  1031.     _numcols    :       word;
  1032.     _spacing    :       word;
  1033.     _itemaddr   :    pointer;
  1034.     _pointers   :    boolean;
  1035.     _firstpage  :       word;
  1036.     _lastpage   :       word;
  1037.     _curitemnum :       word;
  1038.     _curitemptr :    pointer;
  1039.   end;
  1040.  
  1041.  
  1042. var
  1043.   _initpickkey : word;
  1044.  
  1045.  
  1046.   function  __makesel(
  1047.     x1, y1,
  1048.     x2, y2,
  1049.     fore, back,
  1050.     barfore,
  1051.     barback    :       byte;
  1052.     keyproc    :    pointer;
  1053.     itemlen    :       word;
  1054.     numitems   :       word;
  1055.     itemsize   :       word;
  1056.     numcols    :       word;
  1057.     spacing    :       word;
  1058.     itemaddr   :    pointer;
  1059.     ispointers :    boolean
  1060.   ) : _pickptr;
  1061.  
  1062.   function  __picksel(
  1063.     listpickptr : _pickptr;
  1064.     var retitem :   string;
  1065.     var retkey  :     word
  1066.   ) : word;
  1067.  
  1068.   procedure __itemsel(pickptr: _pickptr; fore, back: byte; itemno: word);
  1069.   function  __zapsel(var pickptr : _pickptr) : boolean;
  1070.  
  1071.  
  1072.  
  1073.  
  1074.  
  1075.  
  1076.  
  1077. { XXXXXXXXXXXX SELECTION FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  1078. type
  1079.   _editctrl = record
  1080.     _viewx1,
  1081.     _viewx2,
  1082.     _viewy1,
  1083.     _vscnfore,
  1084.     _vscnback,
  1085.     _vscncols  :    word;
  1086.     _showflags : boolean;
  1087.     _mask      :  string; { ( * ) }
  1088.   end;
  1089.  
  1090.   { masks are currently not supported }
  1091.   {-------------------------------------------------------------}
  1092.   {                                                             }
  1093.   {  ( * ) masking                                              }
  1094.   {                                                             }
  1095.   {   Format Char    Input Allowed                              }
  1096.   {   -----------------------------------------------------     }
  1097.   {     &            (Any character)                            }
  1098.   {     #            0-9,+,-,.                                  }
  1099.   {     9            0-9                                        }
  1100.   {     X            0-9,+,-,.,A-Z,a-z,#32 (space)              }
  1101.   {     Y            (Same as X, convert to upper case)         }
  1102.   {     y            (Same as X, convert to lower case)         }
  1103.   {     A            A-Z,a-z,#32 (space)                        }
  1104.   {     B            (Same as A, convert to upper case)         }
  1105.   {     b            (Same as A, convert to lower case)         }
  1106.   {     ^            (Escape--treat next character as literal)  }
  1107.   {     *            same as &, but report * as user input (pwd)}
  1108.   {                                                             }
  1109.   {   Literal characters are displayed at the corresponding     }
  1110.   {   position within the data input field and are unaffected   }
  1111.   {   by operator input (the cursor skips over them).  A        }
  1112.   {   format character is treated as a literal character if it  }
  1113.   {   is preceded by a single escape character ('^').           }
  1114.   {                                                             }
  1115.   {   If a mask is specified, InitStr is validated against      }
  1116.   {   the mask, and if found invalid __editline exits with      }
  1117.   {   ErrorCode = 2.  Thereafter, the entire edit buffer        }
  1118.   {   is validated against the mask with each keypress.         }
  1119.   {   Invalid keystrokes cause the system speaker to sound and  }
  1120.   {   leave the edit buffer unchanged.  Inserting or            }
  1121.   {   deleting a character will be disallowed if it 'pushes'    }
  1122.   {   or 'pulls' a character into an invalid position relative  }
  1123.   {   to the mask.                                              }
  1124.   {                                                             }
  1125.   {   Examples of masks:                                        }
  1126.   {                                                             }
  1127.   {   '(999) 999-9999'     (telephone number)                   }
  1128.   {   '99/99/99'           (date)                               }
  1129.   {   '999-99-9999'        (social security number)             }
  1130.   {   'B-99999'            (part number, initial alpha char)    }
  1131.   {   '#########'          (real number)                        }
  1132.   {   'AAAAAAAAAAAAAAAAA'  (name field, alpha only)             }
  1133.   {                                                             }
  1134.   {   Case conversion specified by a mask takes precedence      }
  1135.   {   over case conversion specified with _EditMode.            }
  1136.   {                                                             }
  1137.   {   The editing viewport:  If the length of the field         }
  1138.   {   defined in _editctrl (_ViewX2 - _ViewX1 + 1) is less      }
  1139.   {   than the number of columns in the edit buffer             }
  1140.   {   (_VScnCols), editing may take place in a viewport which   }
  1141.   {   is shorter than the length of the edit buffer.  In such   }
  1142.   {   a case, moving the cursor to a position within the        }
  1143.   {   buffer which is not currently visible causes the          }
  1144.   {   buffer to scroll within the viewport.                     }
  1145.   {_____________________________________________________________}
  1146.  
  1147.  
  1148.   function __editline(var st: string; control: _editctrl): boolean;
  1149.  
  1150.  
  1151.  
  1152.  
  1153.  
  1154.  
  1155. { memory management }
  1156. const
  1157.   _max_getmem = 65520;
  1158.   _alloconfail : word = 0;
  1159.  
  1160. type
  1161.   _xads = record
  1162.     _loword : word;
  1163.     _hibyte : byte
  1164.   end;
  1165.  
  1166.   _progsize = record
  1167.     _codesize    : word;
  1168.     _datasize    : word;
  1169.     _stacksize   : word;
  1170.     _overlaysize : word;
  1171.     _heapsize    : word
  1172.   end;
  1173.  
  1174.   _memctrl = record
  1175.     _header   : char;
  1176.     _ownerpsp : word;
  1177.     _size     : word;
  1178.     _reserved : array[1..11] of byte
  1179.   end;
  1180.  
  1181.   _freerec = record
  1182.     _freeblockptr : pointer;
  1183.     _nextblockptr : pointer
  1184.   end;
  1185.  
  1186.   _freelist = array[0..8190] of _freerec;
  1187.  
  1188.  
  1189.  
  1190.   procedure __totalmem(var dosmemory, extmemory : word);
  1191.   procedure __availmem(
  1192.     var dosmemory, extmemory: word; var memptr: pointer; var extads: _xads
  1193.   );
  1194.   function  __sizemem (var progsize : _progsize) : word;
  1195.   function  __tophpmem(var freesize : word) : longint;
  1196.   procedure __heapmem (
  1197.     heaprequest: longint; var newmaxavail: longint; var errorcode : word
  1198.   );
  1199.   procedure __allocmem(
  1200.     blockreq: word; var memptr: pointer; var allocsize, errorcode: word
  1201.   );
  1202.   procedure __freemem (memptr: pointer; var errorcode: word);
  1203.   procedure __altermem(
  1204.     blockreq: word; memptr : pointer; var altersize, errorcode: word
  1205.   );
  1206.   function  __firstmem : pointer;
  1207.   function  __ctrlmem(memptr: pointer; var memblock: _memctrl): pointer;
  1208.   procedure __hookmem(progseg: word; var hookvecno: integer);
  1209.   function  __rnilmem(blocksize: word): integer;
  1210.   procedure __hgetmem(var p: pointer; blockreq: longint);
  1211.   procedure __hfreemem(p: pointer; blocksize: longint);
  1212.   function  __fetchmem(p: pointer; itemsize: word; itemnum: longint): pointer;
  1213.  
  1214.  
  1215. type
  1216.   _3freerecptr = ^_3freerec;
  1217.   _3freerec    = record
  1218.     _nextfree  : _3freerecptr;
  1219.     _blocksize : pointer
  1220.   end;
  1221.  
  1222.  
  1223.   (*
  1224.     the following variables are used in conjunction with errorexit
  1225.     to provide an exit procedure for __hfreemem and __hgetmem.  this is
  1226.     needed so that a runtime error can be generated for invalid heap
  1227.     operations.  the turbo pascal 5.0 procedure runerror is not used as
  1228.     it is not avaiable for 4.0 and does not report the address of the
  1229.     statement that invokes __hfreemem or __hgetmem.
  1230.   *)
  1231.  
  1232. var
  1233.   prevexitproc_ : pointer;
  1234.   calleraddr_   : pointer;
  1235.  
  1236.  
  1237.  
  1238.  
  1239.  
  1240.  
  1241. { sort management }
  1242. const
  1243.   _default_srt  = $0000;
  1244.   _insert_srt   = $0001;
  1245.   _sortdata_srt = $0002;
  1246.   _variable_srt = $0004;
  1247.   _inmemory_srt = $0008;
  1248.   _leavemem_srt = $0010;
  1249.  
  1250.   _useinsertsrt : word    = 10;
  1251.  
  1252.   _numsortedsrt : word    = 0;
  1253.   _datasrt      : pointer = nil;
  1254.   _datasizesrt  : longint = 0;
  1255.   _ptrsrt       : pointer = nil;
  1256.   _ptrsizesrt   : longint = 0;
  1257.  
  1258.  
  1259.   procedure __isortsrt(
  1260.     dataptr : pointer;
  1261.     numrecords : word;
  1262.     recordsize : word;
  1263.     lessfunction : pointer
  1264.   );
  1265.   procedure __qsortsrt(
  1266.     dataptr : pointer;
  1267.     numrecords : word;
  1268.     recordsize : word;
  1269.     lessfunction : pointer
  1270.   );
  1271.  
  1272.   procedure __addsrt(
  1273.     dataptr : pointer;
  1274.     var errorcode : word
  1275.   );
  1276.  
  1277.   procedure __retsrt(
  1278.     var dataptr : pointer;
  1279.     var errorcode : word
  1280.   );
  1281.  
  1282.   procedure __sortsrt(
  1283.     maxrecords    :    word;
  1284.     recordsize    :    word;
  1285.     lessfunction  : pointer;
  1286.     inputproc     : pointer;
  1287.     outputproc    : pointer;
  1288.     sortcontrol   :    word;
  1289.     var errorcode :    word
  1290.   );
  1291.  
  1292.  
  1293.  
  1294.  
  1295.  
  1296.  
  1297.  
  1298.  
  1299.  
  1300.  
  1301.  
  1302.  
  1303.  
  1304.  
  1305. implementation
  1306.  
  1307.  
  1308.  
  1309.  
  1310.  
  1311.  
  1312.  
  1313.  
  1314.  
  1315.  
  1316.  
  1317.  
  1318.  
  1319.  
  1320.  
  1321.  
  1322.  
  1323.  
  1324. { BASE STRING FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  1325.   function locase(ch: char): char;
  1326.   var j : word;
  1327.   begin
  1328.     if ch in ['A'..'Z'] then locase := chr(ord(ch) + 32) else locase := ch;
  1329.   end;
  1330.  
  1331.  
  1332.  
  1333.   function __part(s: string; a, b: byte): string;
  1334.   begin
  1335.     if b > length(s) then b := length(s);
  1336.     if b < a then a := b;
  1337.     __part := copy(s, a, b-a+1)
  1338.   end;
  1339.  
  1340.  
  1341.  
  1342.   function  __leftstr(source : string; num : word) : string;
  1343.   begin
  1344.     __leftstr := copy(source,1,num)
  1345.   end;
  1346.  
  1347.  
  1348.   function  __rightstr(source : string; chpos : word) : string;
  1349.   begin
  1350.     __rightstr := copy(source,chpos,maxstr_)
  1351.   end;
  1352.  
  1353.  
  1354.   function  __substr(source : string; chpos,num : word) : string;
  1355.   var startpos : word;
  1356.   begin
  1357.     if (chpos <= 0) then startpos := 1 else startpos := chpos;
  1358.     if (chpos <= length(source)) then
  1359.       __substr := copy(source,startpos,num) else __substr := ''
  1360.   end;
  1361.  
  1362.  
  1363.  
  1364.   function  __midstr(source, target : string; chpos : word) : string;
  1365.   var
  1366.     newtarget : string;
  1367.     newtarlen : byte;
  1368.     newlen    : word;
  1369.     newstrptr : ^_memorychar;
  1370.     lensource : word;
  1371.     lentarget : word;
  1372.  
  1373.   begin
  1374.     lensource := length(source);
  1375.     lentarget := length(target);
  1376.     newlen    := lensource + lentarget;
  1377.     getmem(newstrptr,newlen);
  1378.     if (newstrptr = nil) then begin __midstr := ''; exit end;
  1379.     if (chpos < 1) then chpos := 1 else if (chpos > lentarget) then
  1380.       chpos := lentarget + 1;
  1381.     move(target[1],newstrptr^[1],chpos - 1);
  1382.     move(source[1],newstrptr^[chpos],lensource);
  1383.     move(target[chpos],newstrptr^[chpos + lensource],
  1384.                                           lentarget - chpos + 1);
  1385.     if (newlen > maxstr_) then newtarget[0] := chr(maxstr_) else
  1386.       newtarget[0] := chr(newlen);
  1387.     move(newstrptr^,newtarget[1],length(newtarget));
  1388.     __midstr := newtarget;
  1389.     freemem(newstrptr,newlen)
  1390.   end;
  1391.  
  1392.  
  1393.  
  1394.   function __fillstr(
  1395.     fillch : char; target : string;
  1396.     chpos,num : word
  1397.   ) : string;
  1398.   var
  1399.     lentarget : word;
  1400.     startpos  : word;
  1401.  
  1402.   begin
  1403.     if (num <= 0) then exit;
  1404.     lentarget := length(target);
  1405.     if (chpos < 1) then startpos := 1 else if (chpos > lentarget) then
  1406.       startpos := lentarget + 1 else startpos := chpos;
  1407.     if (num > (maxstr_ - startpos + 1)) then num := maxstr_ - startpos + 1;
  1408.     fillchar(target[startpos],num,fillch);
  1409.     if (lentarget < (startpos + num)) then
  1410.       target[0] := chr(startpos + num - 1);
  1411.     __fillstr := target
  1412.   end;
  1413.  
  1414.  
  1415.  
  1416.   function  __xlatestr(source, table, trans : string) : string;
  1417.   const blank = #32;
  1418.   var
  1419.     i,j       : word;
  1420.     lensource : word;
  1421.     lentrans  : word;
  1422.     target    : string;
  1423.  
  1424.   begin
  1425.     lentrans  := length(trans);
  1426.     lensource := length(source);
  1427.     for i := 1 to lensource do begin
  1428.       j := pos(source[i],table);
  1429.       if (j > 0) then if (j > lentrans) then target[i] := blank else
  1430.         target[i] := trans[j] else target[i] := source[i]
  1431.     end;
  1432.     target[0]  := chr(lensource);
  1433.     __xlatestr      := target
  1434.   end;
  1435.  
  1436.  
  1437.  
  1438.   function  __juststr(
  1439.     source : string;
  1440.     fillch : char;
  1441.     fieldsize : word;
  1442.     justcode : word
  1443.   ) : string;
  1444.  
  1445.   var
  1446.     juststring : string;
  1447.     len        : word;
  1448.  
  1449.   begin
  1450.     if (fieldsize > maxstr_) then fieldsize  := maxstr_;
  1451.     fillchar(juststring[1],fieldsize,fillch);
  1452.     juststring[0] := chr(fieldsize);
  1453.     len           := length(source);
  1454.     case justcode of
  1455.       _right_just_str:
  1456.          if (len <= fieldsize) then
  1457.            move(source[1],juststring[fieldsize - len + 1],len) else
  1458.              move(source[len - fieldsize + 1],juststring[1],fieldsize);
  1459.       _center_str:
  1460.          if (len <= fieldsize) then
  1461.            move(source[1],juststring[((fieldsize - len) div 2) + 1],len) else
  1462.              move(
  1463.                source[((len - fieldsize) div 2) + 1],
  1464.                juststring[1],fieldsize
  1465.              );
  1466.       else begin
  1467.         if (len <= fieldsize) then move(source[1],juststring[1],len) else
  1468.           move(source[1],juststring[1],fieldsize)
  1469.       end;
  1470.     end;
  1471.     __juststr := juststring
  1472.   end;
  1473.  
  1474.  
  1475.  
  1476.   function  __cvtstr(source : string; cvtcode : word) : string;
  1477.   const
  1478.     blank    = #32;
  1479.     tab      = #9;
  1480.     quote    = #39;
  1481.     dquote   = #34;
  1482.     nul      = #0;
  1483.     linefeed = #10;
  1484.     vtab     = #11;
  1485.     formfeed = #12;
  1486.     creturn  = #13;
  1487.  
  1488.  
  1489.     function quotecheck(var lastquote : char; ch : char) : boolean;
  1490.     begin
  1491.       if ((ch = quote) or (ch = dquote)) then begin
  1492.         if (ch = lastquote) then begin
  1493.           quotecheck := false;
  1494.           lastquote  := blank
  1495.         end else if ((lastquote <> quote) and (lastquote <> dquote)) then begin
  1496.           quotecheck := true;
  1497.           lastquote  := ch
  1498.         end
  1499.       end else if ((lastquote = quote) or (lastquote = dquote)) then
  1500.         quotecheck := true else quotecheck := false
  1501.     end;
  1502.  
  1503.   var
  1504.     target    : string;
  1505.     isquote   : boolean;
  1506.     quoteon   : boolean;
  1507.     lastquote : char;
  1508.     deleteon  : boolean;
  1509.     i,j,len   : word;
  1510.     ch        : char;
  1511.  
  1512.   begin
  1513.     target    := source;
  1514.     isquote   := (cvtcode and 16) <> 0;
  1515.     quoteon   := false;
  1516.     lastquote := ' ';
  1517.     if ((cvtcode and _rem_white_str) <> 0) then begin
  1518.       len := length(source);
  1519.       i   := 1;
  1520.       j   := 0;
  1521.       while (i <= len) do begin
  1522.         ch := source[i];
  1523.         if (isquote) then quoteon := quotecheck(lastquote,ch);
  1524.         if (((ch <> blank) and (ch <> tab)) or quoteon) then begin
  1525.           inc(j);
  1526.           target[j] := ch
  1527.         end;
  1528.         inc(i);
  1529.       end;
  1530.       target[0] := chr(j)
  1531.     end;
  1532.  
  1533.     if ((cvtcode and _rem_lead_white_str) <> 0) then begin
  1534.       len := length(target);
  1535.       i   := 1;
  1536.       while (
  1537.         (i <= len) and ((target[i] = blank) or (target[i] = tab))
  1538.       ) do inc(i);
  1539.       delete(target,1,i - 1)
  1540.     end;
  1541.  
  1542.     if ((cvtcode and _rem_trail_white_str) <> 0) then begin
  1543.       len := length(target);
  1544.       i   := len;
  1545.       while (
  1546.         (i >= 1) and ((target[i] = blank) or (target[i] = tab))
  1547.       ) do dec(i);
  1548.       target := copy(target,1,i)
  1549.     end;
  1550.  
  1551.     if ((cvtcode and _reduce_white_str) <> 0) then begin
  1552.       deleteon  := false;
  1553.       lastquote := blank;
  1554.       len       := length(target);
  1555.       i         := 1;
  1556.       j         := 0;
  1557.       while (i <= len) do begin
  1558.         ch := target[i];
  1559.         if (isquote) then quoteon := quotecheck(lastquote,ch);
  1560.         if (((ch <> blank) and (ch <> tab)) or quoteon) then begin
  1561.           inc(j);
  1562.           target[j] := ch;
  1563.           deleteon  := false
  1564.         end else if (not deleteon) then begin
  1565.           inc(j);
  1566.           target[j] := blank;
  1567.           deleteon  := true
  1568.         end;
  1569.         inc(i)
  1570.       end;
  1571.       target[0] := chr(j)
  1572.     end;
  1573.  
  1574.     if ((cvtcode and _to_upcase_str) <> 0) then begin
  1575.       lastquote := blank;
  1576.       for i := 1 to length(target) do begin
  1577.         ch := target[i];
  1578.         if (isquote) then quoteon := quotecheck(lastquote,ch);
  1579.         if (not quoteon) then target[i] := upcase(ch)
  1580.       end
  1581.     end;
  1582.  
  1583.     if ((cvtcode and _to_lowcase_str) <> 0) then begin
  1584.       lastquote := blank;
  1585.       for i := 1 to length(target) do begin
  1586.         ch := target[i];
  1587.         if (isquote) then quoteon := quotecheck(lastquote,ch);
  1588.         if (not quoteon) then target[i] := locase(ch)
  1589.       end
  1590.     end;
  1591.  
  1592.     if ((cvtcode and _discard_str) <> 0) then begin
  1593.       lastquote := blank;
  1594.       len       := length(target);
  1595.       i         := 1;
  1596.       j         := 0;
  1597.       while (i <= len) do begin
  1598.         ch := target[i];
  1599.         if (isquote) then quoteon := quotecheck(lastquote,ch);
  1600.         if (quoteon or
  1601.           (
  1602.             (ch <> nul) and
  1603.             (
  1604.               (ch < linefeed) or (ch > creturn))
  1605.             )
  1606.         ) then begin
  1607.           inc(j);
  1608.           target[j] := ch
  1609.         end;
  1610.         inc(i)
  1611.       end;
  1612.       target[0] := chr(j)
  1613.     end;
  1614.     __cvtstr := target
  1615.   end;
  1616.  
  1617.  
  1618.  
  1619.  
  1620.   function __entabstr(source : string; incr : byte) : string;
  1621.   const
  1622.     blank = #32;
  1623.     tab   = #9;
  1624.  
  1625.   var
  1626.     column, numblanks : word;
  1627.     sourceidx         : word;
  1628.     targetidx         : word;
  1629.     thisch            : char;
  1630.  
  1631.   begin
  1632.     if ((length(source) = 0) or (incr <= 0)) then begin
  1633.       __entabstr := source;
  1634.       exit
  1635.     end;
  1636.  
  1637.     column    := 0;
  1638.     numblanks := 0;
  1639.     sourceidx := 0;
  1640.     targetidx := 0;
  1641.  
  1642.     repeat
  1643.       inc(sourceidx);
  1644.       thisch := source[sourceidx];
  1645.       case thisch of
  1646.         blank: begin
  1647.           inc(numblanks);
  1648.           inc(column);
  1649.           if ((incr <= 0) or (column mod incr = 0)) then begin
  1650.             inc(targetidx);
  1651.             if (numblanks > 1) then __entabstr[targetidx] := tab else
  1652.               __entabstr[targetidx] := blank;
  1653.             numblanks := 0
  1654.           end;
  1655.         end;
  1656.         tab: begin
  1657.           inc(targetidx);
  1658.           column                := 0;
  1659.           numblanks             := 0;
  1660.           __entabstr[targetidx] := tab
  1661.         end;
  1662.  
  1663.         else begin
  1664.           inc(column);
  1665.           inc(targetidx);
  1666.           while numblanks > 0 do begin
  1667.             __entabstr[targetidx] := blank;
  1668.             dec(numblanks);
  1669.             inc(targetidx)
  1670.           end;
  1671.           __entabstr[targetidx] := thisch
  1672.         end;
  1673.       end;
  1674.     until (sourceidx = length(source));
  1675.     __entabstr[0] := chr(targetidx)
  1676.   end;
  1677.  
  1678.  
  1679.  
  1680.  
  1681.   function __detabstr(
  1682.     source : string; incr : byte;
  1683.     var remstr : string
  1684.   ) : string;
  1685.  
  1686.   const
  1687.     tab   = #9;
  1688.     blank = #32;
  1689.  
  1690.   var
  1691.     numspaces : word;
  1692.     sourceidx : word;
  1693.     targetidx : word;
  1694.     len       : word;
  1695.     thisch    : char;
  1696.  
  1697.   begin
  1698.     if ((length(source) = 0) or (incr <= 0)) then begin
  1699.       __detabstr := source;
  1700.       remstr     := '';
  1701.       exit
  1702.     end;
  1703.  
  1704.     len       := 0;
  1705.     sourceidx := 0;
  1706.     targetidx := 0;
  1707.  
  1708.     repeat
  1709.       inc(sourceidx);
  1710.       thisch := source[sourceidx];
  1711.       if (thisch = tab) then begin
  1712.         numspaces := incr - (targetidx mod incr);
  1713.         if (numspaces > 0) then
  1714.            repeat
  1715.              inc(targetidx);
  1716.              dec(numspaces);
  1717.              if (targetidx <= maxstr_) then
  1718.                begin
  1719.                  len                   := targetidx;
  1720.                  __detabstr[targetidx] := blank
  1721.                end
  1722.              else
  1723.                numspaces := 0
  1724.            until (numspaces = 0);
  1725.       end else begin
  1726.         inc(targetidx);
  1727.         len := targetidx;
  1728.         __detabstr[targetidx] := thisch
  1729.       end;
  1730.     until ((sourceidx = length(source)) or (targetidx >= maxstr_));
  1731.     if (sourceidx < length(source)) then
  1732.       remstr := copy(source,sourceidx,maxstr_) else remstr := '';
  1733.     __detabstr[0] := chr(len)
  1734.   end;
  1735.  
  1736.  
  1737.  
  1738.  
  1739.  
  1740.  
  1741.   function __toradstr(
  1742.     intvalue : longint;
  1743.     size,radix,width : word
  1744.   ) : string;
  1745.  
  1746.   const
  1747.     max32bit = 4294967296.0;
  1748.  
  1749.   const
  1750.     radcheck : array[1..36] of char =
  1751.       '0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ';
  1752.  
  1753.   var
  1754.     quotient             : word;
  1755.     i, j, ival           : word;
  1756.     rval, rquotient      : real;
  1757.     remainder            : real;
  1758.     tempstr, returnedstr : string;
  1759.  
  1760.   begin
  1761.     if (
  1762.       (radix < 2) or (radix > 36) or
  1763.       (
  1764.         (size <> 1) and (size <> 2) and (size <> 4)
  1765.       )
  1766.     ) then begin
  1767.       __toradstr := '';
  1768.       exit
  1769.     end;
  1770.  
  1771.     i := 0;
  1772.     case size of
  1773.       1,2: begin
  1774.         if (size = 1) then ival := (intvalue shl 24) shr 24 else
  1775.           ival := (intvalue shl 16) shr 16;
  1776.         if (ival = 0) then returnedstr := '0' else repeat
  1777.           inc(i);
  1778.           quotient   := ival div radix;
  1779.           tempstr[i] := radcheck[(ival mod radix) + 1];
  1780.           ival       := quotient;
  1781.         until (ival = 0);
  1782.       end;
  1783.       4 : if (intvalue = 0) then returnedstr := '0' else begin
  1784.         if (intvalue < 0) then rval := intvalue + max32bit else
  1785.           rval := intvalue;
  1786.         repeat
  1787.           inc(i);
  1788.           rquotient := trunc(rval / radix);
  1789.           remainder := trunc(rval - radix * 1.0 * trunc(rval / radix));
  1790.           tempstr[i] := radcheck[round(remainder) + 1];
  1791.           rval := rquotient;
  1792.         until (rval = 0);
  1793.       end;
  1794.     end;
  1795.  
  1796.     returnedstr[0] := chr(i);
  1797.     for j := i downto 1 do returnedstr[j] := tempstr[i - j + 1];
  1798.  
  1799.     if ((width < length(returnedstr)) or (width > maxstr_)) then
  1800.       __toradstr := returnedstr else
  1801.       __toradstr := __juststr(returnedstr,'0',width,_right_just_str)
  1802.   end;
  1803.  
  1804.  
  1805.  
  1806.   function  __todecstr(intvalue : longint; size : word) : string;
  1807.   var width : word;
  1808.   begin
  1809.     case size of
  1810.       1 : width := 3;
  1811.       2 : width := 5;
  1812.       4 : width := 10;
  1813.       else exit;
  1814.     end;
  1815.     __todecstr := __toradstr(intvalue,size,10,width)
  1816.   end;
  1817.  
  1818.  
  1819.  
  1820.   function  __tohexstr(intvalue : longint; size : word) : string;
  1821.   const hexcheck : array[0..15] of char = '0123456789ABCDEF';
  1822.   var
  1823.     i       : integer;
  1824.     tempstr : string[8];
  1825.  
  1826.   begin
  1827.     if ((size <> 1) and (size <> 2) and (size <> 4)) then begin
  1828.       __tohexstr := '';
  1829.       exit
  1830.     end;
  1831.     tempstr[0] := chr(8);
  1832.     for i := 0 to 7 do begin
  1833.       tempstr[8 - i] := hexcheck[intvalue and $000f];
  1834.       intvalue := intvalue shr 4
  1835.     end;
  1836.     i := 2 * size;
  1837.     __tohexstr := copy(tempstr,8 - i + 1,i)
  1838.   end;
  1839.  
  1840.  
  1841.  
  1842.  
  1843.   function  __ptr2str(thisptr : pointer) : string;
  1844.   const colon = ':';
  1845.   begin
  1846.     __ptr2str :=
  1847.       __tohexstr(_vectoraddr(thisptr)._seg,sizeof(word)) + colon +
  1848.       __tohexstr(_vectoraddr(thisptr)._ofs,sizeof(word))
  1849.   end;
  1850.  
  1851.  
  1852.  
  1853.   function  __formstr(mask : string; x : real) : string;
  1854.   const
  1855.     space   = ' ';
  1856.     zero    = '0';
  1857.     right   = 1;
  1858.     left    = 2;
  1859.     inputchars : string[6] = '+-#@*';
  1860.  
  1861.   type
  1862.     signlogic = (default,plus,minus);
  1863.  
  1864.   var
  1865.     retstr    : string;
  1866.     fillch    : char;
  1867.     decch     : char;
  1868.     sepch     : char;
  1869.     signch    : char;
  1870.     i         : byte;
  1871.     j         : byte;
  1872.     intlen    : byte;
  1873.     decpos    : byte;
  1874.     start     : byte;
  1875.     endit     : byte;
  1876.     nfldsize  : byte;
  1877.     dplaces   : byte;
  1878.     signpos   : byte;
  1879.     signflg   : signlogic;
  1880.     done      : boolean;
  1881.     money     : boolean;
  1882.     innum     : boolean;
  1883.     negative  : boolean;
  1884.  
  1885.   begin
  1886.     if (mask = '') then begin
  1887.       __formstr := '';
  1888.       exit
  1889.     end;
  1890.  
  1891.     done       := false;
  1892.     innum      := false;
  1893.     money      := false;
  1894.     signflg    := default;
  1895.     negative   := x < 0;
  1896.     decpos     := 0;
  1897.     i          := 0;
  1898.     start      := 0;
  1899.     fillch     := space;
  1900.     sepch      := #0;
  1901.     decch      := #0;
  1902.     x          := abs(x);
  1903.     inputchars := inputchars + _strmoneych;
  1904.  
  1905.     repeat
  1906.       inc(i);
  1907.       if (
  1908.         ((innum) and ((mask[i] = '.') or (mask[i] = ',') or
  1909.         (mask[i] = space))) or (pos(mask[i],inputchars) > 0)
  1910.       ) then begin
  1911.         innum := true;
  1912.         if (start = 0) then start := i;
  1913.         if (mask[i] = '-') then begin
  1914.           signpos := i;
  1915.           signflg := minus
  1916.         end;
  1917.         if (mask[i] = '+') then begin
  1918.           signpos := i;
  1919.           signflg := plus
  1920.         end;
  1921.         if (mask[i] = _strmoneych) then money := true;
  1922.         if (mask[i] = '@') then if (fillch = space) then fillch := zero;
  1923.         if (mask[i] = '*') then fillch := '*';
  1924.         if ((mask[i] = '.') or (mask[i] = ',') or (mask[i] = space)) then
  1925.           if ((i = length(mask)) or (pos(mask[succ(i)],inputchars) < 3)) then
  1926.             done := true else if (mask[i] = space) then
  1927.               sepch := space else begin
  1928.                 if (decch <> #0) then sepch  := decch;
  1929.                 decch  := mask[i];
  1930.                 decpos := i
  1931.               end;
  1932.       end else if (innum) then done := true;
  1933.     until (i = length(mask)) or done;
  1934.  
  1935.     if (decch = sepch) then begin decpos := 0; decch  := #0 end;
  1936.     if (start = 0) then begin __formstr := mask; exit end;
  1937.     endit := i - ord(done);
  1938.     if (signflg <> default) then if (signpos = endit) then begin
  1939.       inc(decpos, ord(decpos > 0));
  1940.       signpos := right
  1941.     end else signpos := left;
  1942.  
  1943.     if (money) then if (fillch = zero) then fillch := space;
  1944.     nfldsize := succ(endit - start);
  1945.     if (decpos > 0) then begin
  1946.       decpos  := decpos - pred(start);
  1947.       dplaces := nfldsize - decpos
  1948.     end else dplaces := 0;
  1949.  
  1950.     str(x : 0 : dplaces, retstr);
  1951.     if (dplaces > 0) then begin
  1952.       dplaces := length(retstr) - pos('.',retstr);
  1953.       retstr[length(retstr) - dplaces] := decch
  1954.     end;
  1955.  
  1956.     j := 0;
  1957.     if (dplaces > 0) then intlen := length(retstr) - succ(dplaces) else
  1958.       intlen := length(retstr);
  1959.     if (sepch <> #0) then for i := intlen downto 2 do begin
  1960.       inc(j);
  1961.       if (j mod 3 = 0) then insert(sepch,retstr,i);
  1962.     end;
  1963.  
  1964.     if (negative) then signch := '-' else if (signflg = plus) then
  1965.       signch := '+' else signch := space;
  1966.  
  1967.     j := length(retstr) + ord(money) +
  1968.       ord((negative) or (signflg <> default));
  1969.  
  1970.     if (j > nfldsize) then begin
  1971.       for i := start to endit do
  1972.         if ((mask[i] = '+') or (mask[i] = '-')) then mask[i] := signch else
  1973.           if (not ((mask[i] = ',') or (mask[i] = '.') or
  1974.             (mask[i] = space))) then mask[i] := '*';
  1975.       __formstr := mask;
  1976.       exit
  1977.     end;
  1978.  
  1979.     if (money) then retstr := _strmoneych + retstr;
  1980.     if (signflg = default) then begin
  1981.       if ((negative) and (fillch = space)) then retstr := '-' + retstr;
  1982.       while length(retstr) < nfldsize do insert(fillch,retstr,1)
  1983.     end else begin
  1984.       case signpos of
  1985.         right : retstr := retstr + signch;
  1986.         left  : retstr := signch + retstr;
  1987.       end;
  1988.       while length(retstr) < nfldsize do insert(fillch,retstr,signpos)
  1989.     end;
  1990.  
  1991.     if (start > 1) then retstr := copy(mask,1,pred(start)) + retstr;
  1992.     if (endit < length(mask)) then
  1993.       retstr := retstr + copy(mask,succ(endit),length(mask));
  1994.     __formstr := retstr
  1995.   end;
  1996.  
  1997.  
  1998.  
  1999.   function openfmt__(var fmtfil : textrec) : integer;
  2000.   begin
  2001.     with textrec(fmtfil) do begin
  2002.       if (mode <> fmoutput) then begin
  2003.         openfmt__ := 105;
  2004.         exit;
  2005.       end;
  2006.       getmem(bufptr,_fmt_buflen_str);
  2007.       if (bufptr = nil) then begin
  2008.         openfmt__ := 203;
  2009.         exit;
  2010.       end;
  2011.       bufsize := _fmt_buflen_str;
  2012.       bufpos  := 0;
  2013.       bufend  := 0;
  2014.     end;
  2015.     openfmt__ := 0
  2016.   end;
  2017.  
  2018.  
  2019.  
  2020.  
  2021.   function closefmt__(var fmtfil : textrec) : integer;
  2022.   begin
  2023.     with textrec(fmtfil) do begin
  2024.       freemem(bufptr,_fmt_buflen_str);
  2025.       mode := fmclosed;
  2026.     end;
  2027.     closefmt__ := 0;
  2028.   end;
  2029.  
  2030.  
  2031.  
  2032.  
  2033.   function inoutfmt__(var fmtfil : textrec) : integer;
  2034.   begin
  2035.     with textrec(fmtfil) do begin
  2036.       if (bufpos >= _fmt_buflen_str) then inoutfmt__ := 101 else
  2037.         inoutfmt__ := 0;
  2038.     end;
  2039.   end;
  2040.  
  2041.  
  2042.  
  2043.   procedure __initfstr(var fmtfil : text);
  2044.   begin
  2045.     with textrec(fmtfil) do begin
  2046.       handle    := $ffff;
  2047.       mode      := fmclosed;
  2048.       bufsize   := 0;
  2049.       bufptr    := nil;
  2050.       openfunc  := @openfmt__;
  2051.       inoutfunc := @inoutfmt__;
  2052.       flushfunc := @inoutfmt__;
  2053.       closefunc := @closefmt__;
  2054.       name[0]   := #0;
  2055.       rewrite(fmtfil)
  2056.     end;
  2057.   end;
  2058.  
  2059.  
  2060.  
  2061.  
  2062.   function  __retbfstr(var fmtfil : text) : string;
  2063.   var
  2064.     s : string;
  2065.     i : word;
  2066.  
  2067.   begin
  2068.     with textrec(fmtfil) do begin
  2069.       if (mode = fmoutput) then begin
  2070.         i := bufpos; if (i > 255) then i := 255;
  2071.         move(bufptr^,s[1],i);
  2072.         s[0]   := char(i);
  2073.         bufpos := 0;
  2074.         bufend := 0;
  2075.       end else s[0] := #0;
  2076.     end;
  2077.     __retbfstr := s;
  2078.   end;
  2079.  
  2080.  
  2081.  
  2082.  
  2083.  
  2084.  
  2085.  
  2086.  
  2087.  
  2088.  
  2089.  
  2090. { SECONDARY STRING FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  2091.   procedure  __app(var st: string; aps: string);
  2092.   begin
  2093.     st := st + aps;
  2094.   end;
  2095.  
  2096.  
  2097.   function  __backapp(s: string) : string;
  2098.   begin
  2099.     if not(s[length(s)] in ['/', '\']) then __backapp := s + _dirslash else
  2100.       __backapp := s;
  2101.   end;
  2102.  
  2103.  
  2104.   function  __backrem(s: string) : string;
  2105.   begin
  2106.     if (
  2107.       (s[length(s)] in ['\', _dirslash]) and
  2108.       (length(s)>3)
  2109.     ) then __backrem := copy(s, 1, length(s)-1) else __backrem := s;
  2110.   end;
  2111.  
  2112.  
  2113.   function __lastchr(s: string): char;
  2114.   begin
  2115.     __lastchr := s[length(s)];
  2116.   end;
  2117.  
  2118.  
  2119.   function __comp(s1, s2: string): boolean;
  2120.   begin
  2121.     __comp := (
  2122.       __cvtstr(s1, _rem_white_str + _to_upcase_str) =
  2123.       __cvtstr(s2, _rem_white_str + _to_upcase_str)
  2124.     )
  2125.   end;
  2126.  
  2127.  
  2128.  
  2129.  
  2130.   function __hexdecstr;
  2131.   var
  2132.     v : longint;
  2133.     i : shortint;
  2134.  
  2135.    {
  2136.     converts a hexadecimal string into an integer, ready to
  2137.     be processed by __toradstr into the diverse formats
  2138.    }
  2139.  
  2140.     function __power(x,y: integer): longint;
  2141.     begin
  2142.       if x>0 then
  2143.       __power := round(exp(y*ln(x))) else if x<0 then
  2144.         __power := -1 * (y mod 2) * round(exp(y*ln(x)));
  2145.     end;
  2146.  
  2147.  
  2148.     function hexvalue(inchar: char): shortint;
  2149.     begin
  2150.       if ord(inchar) in [65..70] then hexvalue := ord(inchar) - 55
  2151.       else hexvalue := ord(inchar) - 48
  2152.     end;
  2153.  
  2154.   begin
  2155.     v := 0; for i := length(hexstr) downto 1 do
  2156.       v := v + trunc(__power(16,length(hexstr)-i)*hexvalue(upcase(hexstr[i])));
  2157.     __hexdecstr := v
  2158.   end;
  2159.  
  2160.  
  2161.  
  2162.   function  __lo(s: string): string;
  2163.   begin
  2164.     __lo := __cvtstr(s, _to_lowcase_str);
  2165.   end;
  2166.  
  2167.  
  2168.   function  __min(v1, v2: longint): longint;
  2169.   begin
  2170.     if v1 <= v2 then __min := v1 else __min := v2;
  2171.   end;
  2172.  
  2173.  
  2174.   function __num(nr: longint):string;
  2175.   var temp: string;
  2176.   begin
  2177.     str(nr,temp); __num := temp;
  2178.   end;
  2179.  
  2180.  
  2181.  
  2182.   function __real(st: string): real;
  2183.   var
  2184.     code : integer;
  2185.     temp :    real;
  2186.   begin
  2187.     if length(st)=0 then __real := 0 else begin
  2188.       val(st, temp, code);
  2189.       if code = 0 then __real := temp else __real := 0;
  2190.     end;
  2191.   end;
  2192.  
  2193.  
  2194.  
  2195.   function __streal(nr: real; decs: byte): string;
  2196.   var
  2197.     tm1, tm2 : string;
  2198.  
  2199.   begin
  2200.     tm1 := __num(trunc(nr));
  2201.     tm2 := __num(
  2202.       round(
  2203.         (
  2204.           nr - trunc(nr)
  2205.         )
  2206.         *
  2207.         __power(10, decs)
  2208.       )
  2209.     );
  2210.     __streal := tm1 + '.' + tm2;
  2211.   end;
  2212.  
  2213.  
  2214.   function __nw(s: string): string;
  2215.   begin
  2216.     __nw := __cvtstr(s, _rem_white_str);
  2217.   end;
  2218.  
  2219.  
  2220.   function __overtype(n:byte;strs,strt:string):string;
  2221.  
  2222.   var
  2223.     l : byte;
  2224.     strn : string;
  2225.  
  2226.   begin
  2227.     l := n + pred(length(strs));
  2228.     if l < length(strt) then l := length(strt);
  2229.     if l > 255 then __overtype := copy(strt,1,pred(n)) +
  2230.       copy(strs,1,255-n) else begin
  2231.       fillchar(strn[1],l,' ');
  2232.       strn[0] := chr(l);
  2233.       move(strt[1],strn[1],length(strt));
  2234.       move(strs[1],strn[n],length(strs));
  2235.       __overtype := strn;
  2236.     end;
  2237.   end;
  2238.  
  2239.  
  2240.  
  2241.  
  2242.   function __pntstr(n: longint): string;
  2243.   var
  2244.     tmpnrstr,
  2245.     tmpcvtstr   :  string;
  2246.     tab, i,
  2247.     len_numstr,
  2248.     len_pnts    : longint;
  2249.  
  2250.   begin
  2251.     str(n, tmpnrstr); tab := 0;
  2252.     len_numstr := length(tmpnrstr);
  2253.     len_pnts := (len_numstr -1) div 3;
  2254.     tmpcvtstr[0] := chr(len_numstr + len_pnts);
  2255.  
  2256.     tmpcvtstr[len_pnts +len_numstr -tab] := tmpnrstr[len_numstr];
  2257.     for i := len_numstr-1 downto 1 do begin
  2258.       if ((len_numstr -i) mod 3 =0) then begin
  2259.         tmpcvtstr[len_pnts +i -tab] := '.'; inc(tab)
  2260.       end;
  2261.       tmpcvtstr[len_pnts +i -tab] := tmpnrstr[i];
  2262.     end;
  2263.     __pntstr := copy(tmpcvtstr, 1, len_numstr +len_pnts);
  2264.   end;
  2265.  
  2266.  
  2267.  
  2268.  
  2269.   function __str(st: string): integer;
  2270.   var
  2271.     code, temp: integer;
  2272.   begin
  2273.     if length(st)=0 then __str := 0 else begin
  2274.       val(st, temp, code);
  2275.       if code=0 then __str := temp else __str := 0;
  2276.     end;
  2277.   end;
  2278.  
  2279.  
  2280.  
  2281.  
  2282.   function  __up(s: string): string;
  2283.   begin
  2284.     __up := __cvtstr(s, _to_upcase_str);
  2285.   end;
  2286.  
  2287.  
  2288.   function  __uprem(s: string): string;
  2289.   begin
  2290.     __uprem := __cvtstr(s, _to_upcase_str + _rem_white_str);
  2291.   end;
  2292.  
  2293.  
  2294.   function __val(st: string): longint;
  2295.   var
  2296.     code: integer;
  2297.     temp: longint;
  2298.  
  2299.   begin
  2300.     if length(st)=0 then __val := 0 else begin
  2301.       val(st, temp, code);
  2302.       if code=0 then __val := temp else __val := 0;
  2303.     end;
  2304.   end;
  2305.  
  2306.  
  2307.  
  2308.  
  2309.  
  2310.   function  __nonascii(s: string): boolean;
  2311.   var
  2312.     i     :    byte;
  2313.     __b__ : boolean;
  2314.  
  2315.   begin
  2316.     __b__ := false;
  2317.     for i := 1 to length(s) do
  2318.       __b__ := __b__ or (ord(s[i]) in [0..31,128..255]);
  2319.     __nonascii := __b__
  2320.   end;
  2321.  
  2322.  
  2323.  
  2324.   function __killnonascii(s: string): string;
  2325.   var
  2326.     __st__ : string;
  2327.     i      :   byte;
  2328.  
  2329.   begin
  2330.     __st__ := '';
  2331.     for i := 1 to length(s) do
  2332.       if (ord(s[i]) in [32, 127]) then
  2333.         __st__ := __st__ + s[i];
  2334.     __killnonascii := __st__;
  2335.   end;
  2336.  
  2337.  
  2338.  
  2339.  
  2340.  
  2341.  
  2342.  
  2343. { PRIMARY BYTE CONVERSION FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  2344.   function __byte2str(b: byte): str8;
  2345.   var
  2346.     s: str8;
  2347.     i: byte;
  2348.  
  2349.   begin
  2350.     s := __rep(8, nonblock); i := b;
  2351.     if (i and $01) > 0 then s[1] := block;
  2352.     if (i and $02) > 0 then s[2] := block;
  2353.     if (i and $04) > 0 then s[3] := block;
  2354.     if (i and $08) > 0 then s[4] := block;
  2355.     if (i and $10) > 0 then s[5] := block;
  2356.     if (i and $20) > 0 then s[6] := block;
  2357.     if (i and $40) > 0 then s[7] := block;
  2358.     if (i and $80) > 0 then s[8] := block;
  2359.     __byte2str := s
  2360.   end;
  2361.  
  2362.  
  2363.  
  2364.   function __str2byte(s: str8): byte;
  2365.   var l, b: byte;
  2366.   begin
  2367.     l := 0;
  2368.     for b := 1 to 8 do begin
  2369.       l := l shl 1; if not(s[b] in [nonblock, ' ', '-']) then inc(l)
  2370.     end;
  2371.     __str2byte := l;
  2372.   end;
  2373.  
  2374.  
  2375.  
  2376.  
  2377.   {
  2378.     representation 4 user flags, array[1..4] of byte
  2379.     by a string[32], or a longint
  2380.  
  2381.  
  2382.          ·····■·■■·■■·■·■·■·■■■····■■·■·■  =  longint
  2383.          └──fD──┘└──fC──┘└──fB──┘└──fA──┘
  2384.            str8    str8    str8    str8
  2385.            byte    byte    byte    byte
  2386.  
  2387.          │                              │
  2388.          2^31                           1
  2389.  
  2390.     bit 31 (32nd bit) is complementory represented.
  2391.     ( -maxlongint-1 )
  2392.   }
  2393.  
  2394.  
  2395.  
  2396.   function __longint2str(l: longint): str32;
  2397.   const con: array[1..31] of longint = (
  2398.     $00000001, $00000002, $00000004, $00000008,
  2399.     $00000010, $00000020, $00000040, $00000080,
  2400.     $00000100, $00000200, $00000400, $00000800,
  2401.     $00001000, $00002000, $00004000, $00008000,
  2402.     $00010000, $00020000, $00040000, $00080000,
  2403.     $00100000, $00200000, $00400000, $00800000,
  2404.     $01000000, $02000000, $04000000, $08000000,
  2405.     $10000000, $20000000, $40000000
  2406.   );
  2407.   var
  2408.     s : str32;
  2409.     b :  byte;
  2410.  
  2411.   begin
  2412.     s := __rep(32, nonblock); if l < 0 then s[32-31] := block;
  2413.     if l < 0 then l := l + maxlongint + 1;
  2414.     for b := 1 to 31 do if (l and con[b]) >0 then s[32-b+1] := block;
  2415.     __longint2str := s
  2416.   end;
  2417.  
  2418.  
  2419.  
  2420.   function __str2longint(s: str32): longint;
  2421.   var
  2422.     l : longint;
  2423.     b :    byte;
  2424.  
  2425.   begin
  2426.     l := 0;
  2427.     for b := 2 to 32 do begin
  2428.       l := l shl 1; if not(s[b] in [nonblock, ' ', '-']) then inc(l)
  2429.     end;
  2430.     if not(s[1] in [nonblock, ' ', '-']) then l := l - maxlongint - 1;
  2431.     __str2longint := l;
  2432.   end;
  2433.  
  2434.  
  2435.  
  2436.  
  2437.  
  2438.  
  2439.  
  2440.  
  2441. { ASCIIZ AND OTHER FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  2442.   procedure __str2obj(s: anystr; var a; length_a: integer );
  2443.   var
  2444.     i  : integer;
  2445.     aa : packed array[ 1 .. 1 ] of char absolute a;
  2446.  
  2447.   begin
  2448.     fillchar(aa[1], length_a, ' ');
  2449.     move(s[1], aa[1], __min(length_a, length(s)));
  2450.   end;
  2451.  
  2452.  
  2453.   procedure __str2arr(s: anystr; var a; length_a: integer );
  2454.   var
  2455.     i     : integer;
  2456.     len_s : integer;
  2457.     len_a : integer;
  2458.     l     : integer;
  2459.     aa    : packed array[ 1 .. 1 ] of char absolute a;
  2460.  
  2461.   begin
  2462.     len_s := length( s ); len_a := length_a; l := __min(len_a, len_s);
  2463.     for i := 1 to l do begin
  2464.       aa[len_a] := s[len_s]; dec(len_a); dec(len_s)
  2465.     end;
  2466.     for i := len_a downto 1 do aa[i] := ' ';
  2467.   end;
  2468.  
  2469.  
  2470.   function __readctrls(s: anystr): anystr;
  2471.   var
  2472.     t : anystr;
  2473.     i : integer;
  2474.     j : integer;
  2475.     l : integer;
  2476.  
  2477.   begin
  2478.     t:=''; i:=1; j:=0; l:=length(s);
  2479.     while( i <= l ) do begin
  2480.       if ( s[i] = fk_ctrl_mark ) then if ( s[i+1] <> '''' ) then begin
  2481.         inc(i); inc(j); t[j]:=chr( ord(s[i])-64); inc(i)
  2482.       end else begin
  2483.         inc(j); t[j]:=s[i]; t[j+1]:=s[i+1]; t[j+2]:=s[i+2]; inc(i,3); inc(j,2);
  2484.       end else begin
  2485.         inc( j ); t[j]:=s[i]; inc(i)
  2486.       end;
  2487.     end; t[0]:=chr( j ); __readctrls:=t;
  2488.   end;
  2489.  
  2490.  
  2491.  
  2492.   function __writectrls(s: anystr): anystr;
  2493.   var
  2494.     t: anystr;
  2495.     i: integer;
  2496.     j: integer;
  2497.  
  2498.   begin
  2499.     t:=''; j := 0;
  2500.     for i:=1 to length( s ) do begin
  2501.       if ( s[i] in [^@..^_] ) then begin
  2502.         inc(j); t[j] := fk_ctrl_mark; inc(j); t[j] := chr(ord(s[i])+64);
  2503.       end else begin
  2504.         inc(j); t[j]:=s[i]
  2505.       end;
  2506.     end; t[0]:=chr( j ); __writectrls := t;
  2507.   end;
  2508.  
  2509.  
  2510.   function __az2str(a: asciiz): string;
  2511.   var s : string; slen: byte absolute s;
  2512.   begin
  2513.     slen:=0; while a[slen] <> #0 do slen:=succ(slen); move(a, s[1], slen);
  2514.     __az2str:=s;
  2515.   end;
  2516.  
  2517.  
  2518.   procedure __str2az(s : string; var a : asciiz);
  2519.   var slen: byte absolute s;
  2520.   begin
  2521.     move(s[1], a, slen); a[slen]:=#0;
  2522.   end;
  2523.  
  2524.  
  2525.  
  2526.  
  2527.  
  2528.  
  2529.  
  2530. { STRING1024 FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  2531.   procedure __app1024(var app: ar1024; s: string);
  2532.   var i, j : word;
  2533.   begin
  2534.     i := 1; while (app[i] <> #0) and (i < 1024) do inc(i);
  2535.     for j := 1 to length(s) do begin app[i + j - 1] := s[j] end;
  2536.   end;
  2537.  
  2538.  
  2539.  
  2540.   function __len1024(var a: ar1024) : word;
  2541.   var l : word;
  2542.   begin
  2543.     l := 1;
  2544.     while (l < 1024) and (a[l] <> #0) do inc(l); dec(l);
  2545.     __len1024 := l;
  2546.   end;
  2547.  
  2548.  
  2549.  
  2550.   procedure __clr1024(var a: ar1024);
  2551.   begin
  2552.     fillchar(a, sizeof(ar1024), #0);
  2553.   end;
  2554.  
  2555.  
  2556.   procedure __del1024(var a: ar1024; b, l: word);
  2557.   begin
  2558.     move(a[b+l], a[b], 1024 - b)
  2559.   end;
  2560.  
  2561.  
  2562.   procedure __ins1024(var a: ar1024; b : word; s: string);
  2563.   var l, i : byte;
  2564.   begin
  2565.     l := length(s);
  2566.     move(a[b], a[b+l], 1024 - b);
  2567.     for i := 1 to l do a[b + i - 1] := s[i];
  2568.   end;
  2569.  
  2570.  
  2571.   procedure __write1024(var a: ar1024);
  2572.   var l : word;
  2573.   begin
  2574.     l := 1;
  2575.     while (l < 1024) and (a[l] <> #0) do begin write(a[l]); inc(l) end;
  2576.   end;
  2577.  
  2578.  
  2579.  
  2580.  
  2581.  
  2582.  
  2583.  
  2584.  
  2585.  
  2586.  
  2587. { PRIMARY DATA CONVERSION FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  2588.   function __main(b: longint; w: word): longint;
  2589.   begin
  2590.     if b mod w = 0 then __main := b else __main := ((b div w) + 1) * w
  2591.   end;
  2592.  
  2593.  
  2594.   function  __max(v1, v2: longint): longint;
  2595.   begin
  2596.     if v1 >= v2 then __max := v1 else __max := v2;
  2597.   end;
  2598.  
  2599.  
  2600.   function __power(x,y: integer): longint;
  2601.   begin
  2602.     if x>0 then
  2603.     __power := round(exp(y*ln(x))) else if x<0 then
  2604.       __power := -1 * (y mod 2) * round(exp(y*ln(x)));
  2605.   end;
  2606.  
  2607.  
  2608.  
  2609.   procedure __iptrsup(var p : pointer; n : longint);
  2610.   var seg,ofs : word;
  2611.   begin
  2612.     seg := n shr 4;                    { divide by 16 for paragraphs    }
  2613.     ofs := n mod 16;                   { offset                         }
  2614.     inc(seg,_vectoraddr(p)._seg);
  2615.     inc(ofs,_vectoraddr(p)._ofs);
  2616.     p := ptr(seg + (ofs shr 4),ofs and $000f)
  2617.   end;
  2618.  
  2619.  
  2620.   procedure __dptrsup(var p : pointer; n : longint);
  2621.   var seg,ofs : word;
  2622.   begin {__dptrsup}
  2623.     seg := n shr 4;                    { divide by 16 for paragraphs    }
  2624.     ofs := n mod 16;                   { offset                         }
  2625.     p := __nptrsup(ptr(_vectoraddr(p)._seg - seg,
  2626.                        _vectoraddr(p)._ofs - ofs))
  2627.   end;  {__iptrsup}
  2628.  
  2629.  
  2630.   function __nptrsup(thisptr : pointer) : pointer;
  2631.   begin {__nptrsup}
  2632.     __nptrsup := ptr(_vectoraddr(thisptr)._seg +
  2633.       (_vectoraddr(thisptr)._ofs shr 4),
  2634.       _vectoraddr(thisptr)._ofs and $f)
  2635.   end;
  2636.  
  2637.  
  2638.   function __ptr2lsup(thisptr : pointer) : longint;
  2639.   var normptr : pointer;
  2640.   begin
  2641.     normptr    := __nptrsup(thisptr);
  2642.     __ptr2lsup := (longint(_vectoraddr(normptr)._seg) shl 4) +
  2643.                                     longint(_vectoraddr(normptr)._ofs)
  2644.   end;
  2645.  
  2646.  
  2647.   procedure __fillwsup(var target; count : longint; fillword : word); external;
  2648.   procedure __fillbsup(var target; count : longint; fillbyte : byte); external;
  2649.  
  2650.   procedure __repmsup(var target,source; count : longint; sourcesize : word);
  2651.   var
  2652.     targetptr : pointer;
  2653.     i         : longint;
  2654.  
  2655.   begin
  2656.     if (count <= 0) then exit;
  2657.     case sourcesize of
  2658.       0 : exit;
  2659.       1 : __fillbsup(target,count,byte(source));
  2660.       2 : __fillwsup(target,count,word(source));
  2661.       else begin
  2662.         targetptr := @target;
  2663.         for i := 1 to count do begin
  2664.           move(source,targetptr^,sourcesize);
  2665.           __iptrsup(targetptr,sourcesize)
  2666.         end
  2667.       end;
  2668.     end  {case sourcesize}
  2669.   end;  {__repmsup}
  2670.  
  2671.  
  2672.   function __alphasup(ch : char) : boolean;
  2673.   begin
  2674.     if (
  2675.       ((ch > #64) and (ch < #91)) or ((ch > #96) and (ch < #123))
  2676.     ) then __alphasup := true else __alphasup := false;
  2677.   end;
  2678.  
  2679.  
  2680.  
  2681.  
  2682.  
  2683.  
  2684.  
  2685.  
  2686.  
  2687. { DATE FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  2688.   function __datestr(var year,month,day : word) : string;
  2689.   const
  2690.     blank      = #32;
  2691.     comma      = #44;
  2692.  
  2693.   var
  2694.     dayofweek  : word;
  2695.     yearstr    : string[5];
  2696.     daystr     : string[2];
  2697.  
  2698.   begin
  2699.     getdate(year,month,day,dayofweek);
  2700.     str(year:5,yearstr);
  2701.     str(day,daystr);
  2702.     __datestr := _strdays[dayofweek] + blank + _strmonths[month] +
  2703.       blank + daystr + comma + yearstr;
  2704.   end;
  2705.  
  2706.  
  2707.   function  __timestr(
  2708.     var hours, minutes,
  2709.     seconds, tics : word
  2710.   ) : string;
  2711.   var
  2712.     tmphours,tmpmins : word;
  2713.  
  2714.   begin
  2715.     gettime(hours,minutes,seconds,tics);
  2716.     tmphours := hours;
  2717.     tmpmins  := minutes;
  2718.     if (seconds > 30) then begin
  2719.       tmpmins := succ(tmpmins) mod 60;
  2720.       if (tmpmins = 0) then tmphours := succ(tmphours) mod 24
  2721.     end;
  2722.     __timestr := __time2str(tmphours,tmpmins,seconds,0,_standard_str);
  2723.   end;
  2724.  
  2725.  
  2726.  
  2727.   function __dt2ststr(
  2728.     year    : word;
  2729.     month   : word;
  2730.     day     : word;
  2731.     datefmt : word
  2732.   ) : string;
  2733.  
  2734.   const
  2735.     blank = #32;
  2736.     zero  = #48;
  2737.     comma = #44;
  2738.  
  2739.   const
  2740.     strdays: array[1..12] of word = (31,29,31,30,31,30,31,31,30,31,30,31);
  2741.  
  2742.   var
  2743.     yrstr  : string[4];
  2744.     mnstr  : string[2];
  2745.     dystr  : string[2];
  2746.  
  2747.   begin
  2748.     __dt2ststr := '';
  2749.     if (year < 100) then inc(year,1900);
  2750.     if ((month < 1) or (month > 12)) then exit;
  2751.     if (((month = 2) and (day = 29)) and ((year mod 4) <> 0)) then exit;
  2752.     if ((day = 0) or (day > strdays[month])) then exit;
  2753.     str(year,yrstr); str(month:2,mnstr); str(day:2,dystr);
  2754.  
  2755.     if (yrstr[3] = blank) then yrstr[3] := zero;
  2756.     if (mnstr[1] = blank) then mnstr[1] := zero;
  2757.     if (dystr[1] = blank) then dystr[1] := zero;
  2758.  
  2759.     case datefmt of
  2760.       _usa_dt_str: begin
  2761.         __dt2ststr := mnstr + _strusach  + dystr +
  2762.           _strusach + copy(yrstr,3,2);
  2763.       end;
  2764.  
  2765.       _euro_dt_str: begin
  2766.         __dt2ststr := dystr + _streuroch + mnstr +
  2767.           _streuroch + copy(yrstr,3,2);
  2768.       end;
  2769.  
  2770.       _year_dt_str: begin
  2771.         __dt2ststr := mnstr + _strusach + dystr +
  2772.           _strusach + yrstr;
  2773.       end;
  2774.  
  2775.       _mont_dt_str: begin
  2776.         __dt2ststr := dystr + blank + copy(_strmonths[month],1,3) +
  2777.           blank + copy(yrstr,3,2);
  2778.      end;
  2779.  
  2780.       _form_dt_str: begin
  2781.         str(day,dystr);
  2782.         __dt2ststr := _strmonths[month] + blank + dystr +
  2783.           comma + blank + yrstr;
  2784.       end
  2785.     end;
  2786.   end;
  2787.  
  2788.  
  2789.  
  2790.   procedure __st2dtstr(st: string; var year, month, day: word; datefmt: word);
  2791.  
  2792.     function rettoken(
  2793.       var datestr : string;
  2794.       var start : word
  2795.     ) : string;
  2796.  
  2797.     var
  2798.       stop  : boolean;
  2799.       chpos : word;
  2800.  
  2801.     begin
  2802.       rettoken := '';
  2803.       stop  := false;
  2804.       chpos := start;
  2805.       while (
  2806.         (chpos <= length(datestr)) and
  2807.         (datestr[chpos] in ['a'..'z','A'..'Z','0'..'9'])
  2808.       ) do inc(chpos);
  2809.       rettoken := copy(datestr,start,chpos - start);
  2810.       start    := succ(chpos);
  2811.     end;
  2812.  
  2813.  
  2814.   var
  2815.     token   : string[9];
  2816.     temp1   : word;
  2817.     temp2   : word;
  2818.     start   : word;
  2819.     errcode : word;
  2820.     i       : word;
  2821.     match   : boolean;
  2822.  
  2823.   begin
  2824.     month := 0; day   := 0; year  := 0;
  2825.     start := 1;
  2826.     token := rettoken(st,start);
  2827.     case datefmt of
  2828.       _usa_dt_str,
  2829.       _euro_dt_str,
  2830.       _year_dt_str,
  2831.       _mont_dt_str : begin
  2832.         val(token,temp1,errcode);
  2833.         if (errcode <> 0) then exit;
  2834.       end;
  2835.  
  2836.       _form_dt_str : begin
  2837.         i := 1;
  2838.         repeat
  2839.           match := (
  2840.             __cvtstr(token,_to_upcase_str) =
  2841.             __cvtstr(_strmonths[i],_to_upcase_str)
  2842.           );
  2843.           inc(i);
  2844.         until ((i > 12) or (match));
  2845.         if (match) then temp1 := pred(i) else exit;
  2846.       end
  2847.     end;
  2848.  
  2849.     token := rettoken(st, start);
  2850.     case datefmt of
  2851.       _usa_dt_str,
  2852.       _euro_dt_str,
  2853.       _year_dt_str,
  2854.       _form_dt_str : begin
  2855.         val(token,temp2,errcode);
  2856.         if (errcode <> 0) then exit;
  2857.         if (datefmt = _form_dt_str) then inc(start);
  2858.       end;
  2859.       _mont_dt_str : begin
  2860.         i := 1;
  2861.         repeat
  2862.           match := (
  2863.             __cvtstr(token,_to_upcase_str) =
  2864.             __cvtstr(copy(_strmonths[i],1,3), _to_upcase_str)
  2865.           );
  2866.           inc(i);
  2867.         until ((i > 12) or (match));
  2868.         if (match) then temp2 := pred(i) else exit;
  2869.       end;
  2870.     end;
  2871.     token := rettoken(st,start);
  2872.     val(token,year,errcode);
  2873.     if (errcode <> 0) then exit;
  2874.     if (year < 100) then inc(year,1900);
  2875.     case datefmt of
  2876.       _euro_dt_str,
  2877.       _mont_dt_str  : begin
  2878.         month := temp2;
  2879.         day   := temp1
  2880.       end else begin
  2881.         month := temp1;
  2882.         day   := temp2
  2883.       end;
  2884.     end;
  2885.   end;
  2886.  
  2887.  
  2888.  
  2889.   function __time2str(
  2890.     hours, mins : word;
  2891.     secs, tics : word;
  2892.     format : word
  2893.   ) : string;
  2894.  
  2895.   const
  2896.     colon     = ':';
  2897.     period    = '.';
  2898.     point     = '·';
  2899.     space     = ' ';
  2900.     zero      = '0';
  2901.     dirbit    = $0010;
  2902.  
  2903.   var
  2904.     ahrs    : word;
  2905.     i       : word;
  2906.     hstr    : string[2];
  2907.     mstr    : string[2];
  2908.     sstr    : string[2];
  2909.     tstr    : string[2];
  2910.     timestr : string[14];
  2911.  
  2912.   begin
  2913.     hours := hours mod 24;
  2914.     ahrs  := hours;
  2915.     if ((_12hour_str and format) <> 0) then begin
  2916.       if (hours = 0) then hours := 12 else if (hours > 12) then dec(hours,12);
  2917.     end;
  2918.     str(hours,hstr); str((mins mod 60):2,mstr);
  2919.     timestr := hstr + colon + mstr;
  2920.     if ((_inc_sec_str and format) <> 0) then begin
  2921.       str((secs mod 60):2,sstr);
  2922.       timestr := timestr + period + sstr;
  2923.     end;
  2924.     if ((_inc_tic_str and format) <> 0) then begin
  2925.       str((tics mod 100):2,tstr);
  2926.       timestr := timestr + point + tstr;
  2927.     end;
  2928.     for i := 3 to length(timestr) do if (timestr[i] = space) then
  2929.       timestr[i] := zero;
  2930.     if ((_inc_ampm_str and format) <> 0) then
  2931.       timestr := timestr + _ampm_str[ahrs div 12] else
  2932.         if ((dirbit and format) <> 0) then
  2933.           timestr := timestr + _ap_str[succ(ahrs div 12)];
  2934.     __time2str := timestr;
  2935.   end;
  2936.  
  2937.  
  2938.  
  2939.   function __2timestr(
  2940.     timestr : string;
  2941.     var hours,mins : word;
  2942.     var secs,tics : word
  2943.   ) : boolean;
  2944.  
  2945.   const
  2946.     colon     = ':';
  2947.     period    = '.';
  2948.  
  2949.   var
  2950.     i         : word;
  2951.     len       : word;
  2952.     startpos  : word;
  2953.     endpos    : word;
  2954.     ch        : char;
  2955.     errorcode : word;
  2956.     values    : array[1..4] of word;
  2957.  
  2958.   begin
  2959.     __2timestr := false;
  2960.     fillchar(values,sizeof(values),0);
  2961.     len := length(timestr);
  2962.     if (len = 0) then exit;
  2963.     endpos := 0;
  2964.     for i := 1 to 4 do begin
  2965.       startpos := succ(endpos);
  2966.       repeat
  2967.         inc(endpos);
  2968.         ch := timestr[endpos];
  2969.       until ((ch = colon) or (ch = period) or (endpos > len));
  2970.       if ((endpos - startpos) > 0) then begin
  2971.         val(
  2972.           copy(timestr,startpos,endpos - startpos),
  2973.           values[i], errorcode
  2974.         );
  2975.         if (errorcode <> 0) then exit;
  2976.       end;
  2977.     end;
  2978.     hours := values[1]; mins := values[2];
  2979.     secs := values[3]; tics := values[4];
  2980.  
  2981.     if (
  2982.       (values[1] > 23) or (values[2] > 59) or (values[3] > 59) or
  2983.       (values[4] > 99)
  2984.     ) then exit;
  2985.     __2timestr := true;
  2986.   end;
  2987.  
  2988.  
  2989.  
  2990.   function __retdowstr(dayofweek: word; ful: boolean): string;
  2991.   begin
  2992.     if ful then __retdowstr := _strdays[dayofweek] else
  2993.       __retdowstr := copy(_strdays[dayofweek], 1, 3);
  2994.   end;
  2995.  
  2996.  
  2997.   function __todaystr(ful: boolean): string;
  2998.   var y, m, d, dow: word;
  2999.   begin
  3000.     getdate(y, m, d, dow);
  3001.     if ful then __todaystr := _strdays[dow] else
  3002.       __todaystr := copy(_strdays[dow], 1, 3);
  3003.   end;
  3004.  
  3005.  
  3006.   procedure __jl2dtutl(julian: longint; var year, month, day, weekday: word);
  3007.   var temp1 : longint;
  3008.   begin
  3009.     year := 0; month := 0; day := 0; weekday := 0;
  3010.     if (julian < 0) or (julian > 72989) then exit;
  3011.     temp1 := julian * 4 + 3;
  3012.     year  := (temp1 div 1461) + 1900;
  3013.     temp1 := ((temp1 mod 1461) div 4 + 1) * 5 - 3;
  3014.     month := temp1 div 153;
  3015.     day   := temp1 mod 153 div 5 + 1;
  3016.     if (month < 10) then inc(month,3) else begin dec(month,9); inc(year) end;
  3017.     weekday := (julian + 4) mod 7;
  3018.   end;
  3019.  
  3020.  
  3021.   function  __dt2jlutl(year, month, day : word) : longint;
  3022.   const days : array[1..12] of word = (31,29,31,30,31,30,31,31,30,31,30,31);
  3023.   begin
  3024.     __dt2jlutl := -1;
  3025.     if ((year < 1900) and (year > 99)) then exit;
  3026.     if (year < 100) then inc(year,1900);
  3027.     if ((month < 1) or (month > 12)) then exit;
  3028.     if (((month = 2) and (day = 29)) and ((year mod 4) <> 0)) then exit;
  3029.     if ((day = 0) or (day > days[month])) then exit;
  3030.     if ((year = 1900) and (month < 3)) then exit;
  3031.     dec(year,1900);
  3032.     if (month > 2) then dec(month,3) else begin inc(month,9); dec(year) end;
  3033.     __dt2jlutl := (
  3034.       ((longint(1461) * longint(year)) div 4) +
  3035.       ((153 * month + 2) div 5) + day - 1
  3036.     );
  3037.   end;
  3038.  
  3039.  
  3040.   function __daysutl(yr1, mn1, day1 : word; yr2, mn2, day2 : word) : longint;
  3041.   var temp1, temp2 : longint;
  3042.   begin
  3043.     temp1 := __dt2jlutl(yr1,mn1,day1); temp2 := __dt2jlutl(yr2,mn2,day2);
  3044.     if (temp1 < 0) or (temp2 < 0) then __daysutl := -1 else
  3045.       __daysutl := temp2 - temp1;
  3046.   end;
  3047.   {
  3048.     gordon king in dr.dobbsjournal (number 80, june 1983)
  3049.     and originally published in the collected algorithms
  3050.     of the acm by r.g. tantzen in 1963.
  3051.   }
  3052.  
  3053.  
  3054.   function  __dbdate: string;
  3055.   var
  3056.     year, month, day,
  3057.     hour, minute, second, tic :   word;
  3058.     s, s1                     : string;
  3059.  
  3060.   begin
  3061.     s := __datestr(year, month, day);
  3062.     s := __timestr(hour, minute, second, tic);
  3063.     s := __dt2ststr(year, month, day, _usa_dt_str);
  3064.     if length(s1)<8 then s := '0' + s;
  3065.     s1 := __time2str(hour, minute, second, tic, 0);
  3066.     if length(s1)<5 then s1 := '0' + s1;
  3067.     __dbdate := s + ' ' + s1 + '  ';
  3068.   end; { __dbdate }
  3069.  
  3070.  
  3071.   function  __radate: string;
  3072.   var
  3073.     year, month, day,
  3074.     hour, minute, second, tic :   word;
  3075.     s, s1                     : string;
  3076.  
  3077.   begin
  3078.     s := __datestr(year, month, day);
  3079.     s := __timestr(hour, minute, second, tic);
  3080.     s := __dt2ststr(year, month, day, _mont_dt_str);
  3081.     s1 := __time2str(hour, minute, second, tic, _inc_sec_str);
  3082.     if length(s1)<8 then s1 := '0' + s1;
  3083.     __radate := '> ' + s1 + '  ';
  3084.   end; { __radate }
  3085.  
  3086.  
  3087.   function  __curdate: string;
  3088.   var
  3089.     year, month, day,
  3090.     hour, minute, second, tic :   word;
  3091.     s, s1                     : string;
  3092.  
  3093.   begin
  3094.     s := __datestr(year, month, day);
  3095.     s := __timestr(hour, minute, second, tic);
  3096.     s := __dt2ststr(year, month, day, _mont_dt_str);
  3097.     s1 := __time2str(hour, minute, second, tic, _inc_sec_str);
  3098.     if length(s1)<8 then s1 := '0' + s1;
  3099.     __curdate := s + '  ' + s1;
  3100.   end; { __curdate }
  3101.  
  3102.  
  3103.   function  __curdate2longint: longint;
  3104.   var
  3105.     year1, mon1,
  3106.     day1, hour1,
  3107.     min1, sec1,
  3108.     tic1              :     word;
  3109.     s, s1             :   string;
  3110.     datetimepack      : datetime;
  3111.     templong          :  longint;
  3112.  
  3113.   begin
  3114.     s := __datestr(year1, mon1, day1);
  3115.     s := __timestr(hour1, min1, sec1, tic1);
  3116.     with datetimepack do begin
  3117.       year := year1; month := mon1; day := day1;
  3118.       hour := hour1; min := min1; sec := sec1;
  3119.     end; packtime(datetimepack, templong);
  3120.     __curdate2longint := templong;
  3121.   end; { __curdate }
  3122.  
  3123.  
  3124.   function __longint2date(l: longint): string;
  3125.   var dt: datetime;
  3126.   begin
  3127.     unpacktime(l, dt); if dt.year<100 then inc(dt.year, 1900);
  3128.     __longint2date := __juststr(
  3129.       __num(dt.day), '0', 2, _right_just_str
  3130.     ) + ' ' + copy(_strmonths[dt.month], 1, 3) + ' ' +
  3131.       __juststr(__num(dt.year), '0', 2, _right_just_str) + '  ' +
  3132.       __juststr(__num(dt.hour), '0', 2, _right_just_str) + ':' +
  3133.       __juststr(__num(dt.min), '0', 2, _right_just_str) + '.' +
  3134.       __juststr(__num(dt.sec), '0', 2, _right_just_str);
  3135.   end;
  3136.  
  3137.  
  3138.   function __date2longint(d: string): longint;
  3139.   const mons: string[12] = 'JFMAMJJASOND';
  3140.   var                                           {     'xx NNN yy  HH:MM.ss' }
  3141.     st :   string;                              { eg. '22 Aug 69  14:50.11' }
  3142.     dt : datetime;
  3143.     c  :     char;
  3144.     m  :     word;
  3145.     l  :  longint;
  3146.  
  3147.   begin
  3148.     with dt do begin
  3149.       hour := __str(copy(d, 12, 2));
  3150.       min  := __str(copy(d, 15, 2));
  3151.       sec  := __str(copy(d, 18, 2));
  3152.       day  := __str(copy(d, 01, 2));
  3153.       year := __str(copy(d, 08, 2)) + 1900;
  3154.       st := copy(d, 4, 3);
  3155.       c := upcase(d[4]);
  3156.       case c of
  3157.         'A': if st='Apr' then m := 4 else m := 8;
  3158.         'D', 'F', 'N', 'O', 'S': m := pos(c, mons);
  3159.         'J': if st='Jan' then m := 1 else if st='Jun' then m := 6 else m := 7;
  3160.         'M': if st='Mar' then m := 3 else m := 5;
  3161.       end;
  3162.       month := m;
  3163.     end;
  3164.     packtime(dt, l); __date2longint := l;
  3165.   end;
  3166.  
  3167.  
  3168.   (*
  3169.    Format number
  3170.    1 - Xpress method of display last usage date           Mmm DD,YYYY HH:MM:SSap
  3171.    2 - opus display method for date written in messages   Mmm-DD-YY H:MMap
  3172.    3 - Xpress Sysop menu display of last usage.           MM/DD/YY HH:MMap
  3173.    4 - used for opus log                                  DD Mmm HH:MM:SS
  3174.    5 - used for last usage date in user.bbs (opus)        DD Mmm YY HH:MM:SS
  3175.    6 -                                                    Mmm DD, YY
  3176.    7 - used for new files lister in OPUS 1.70             MM/DD/YY
  3177.  
  3178.   *)
  3179.  
  3180.  
  3181.   function format_date(dt:datetime;format : byte):string;
  3182.   var
  3183.     ms, ds, hs,
  3184.     m1s, ss, mhs,
  3185.     ampm          : string[2];
  3186.     ys            : string[4];
  3187.  
  3188.   begin
  3189.     ampm := 'am';
  3190.     with dt do begin
  3191.       str(month:2,ms);
  3192.       str(day:1,ds);
  3193.       str(year:1,ys);
  3194.       str(hour:1,mhs);
  3195.       if format = 4 then if length(mhs)=1 then mhs := '0'+mhs;
  3196.       if format in [3,4,7] then if length(ds)=1  then ds := '0'+ds;
  3197.       if format in [2,5] then ys := copy(ys,3,2);
  3198.  
  3199.       if hour >= 12 then begin
  3200.         ampm := 'pm';
  3201.         if hour > 12 then hour := hour - 12;
  3202.       end;
  3203.       str(hour:1,hs); str(min:2,m1s); str(sec:2,ss);
  3204.       if (format=3) or (format=7) then if hour < 10 then hs := ' '+hs;
  3205.       if m1s[1] = ' ' then m1s[1] := '0';
  3206.       if ss[1] = ' '  then ss[1] := '0';
  3207.       if ms[1] = ' '  then ms[1] := '0';
  3208.       if not (month in [1..12]) then month := 13;
  3209.       if year < 1988 then month := 13;
  3210.       if year > 2000 then month := 13;
  3211.       if (format < 1) or (format > 7) then format := 1;
  3212.       case format of
  3213.        1 : format_date := _strmonths[month]+' '+ds+','+ys+'  '+hs+':'+m1s+':'+ss+ampm;
  3214.        2 : format_date := _strmonths[month]+'-'+ds+'-'+ys+' '+hs+':'+m1s+ampm;
  3215.        3 : format_date := ms+'/'+ds+'/'+copy(ys,3,2)+' '+hs+':'+m1s+ampm;
  3216.        4 : format_date := ds+ ' '+_strmonths[month]+' '+mhs+':'+m1s+':'+ss;
  3217.        5 : format_date := ds+ ' '+_strmonths[month]+' '+ys+' '+mhs+':'+m1s+':'+ss;
  3218.        6 : format_date := _strmonths[month]+' '+ds+','+ys;
  3219.        7 : format_date := ms+'/'+ds+'/'+copy(ys,3,2);
  3220.       end;
  3221.     end;
  3222.   end;
  3223.  
  3224.  
  3225.   procedure __longint2datetime(d: longint; var dt : datetime);
  3226.   var dtst : record date, time : word end absolute d;
  3227.   begin
  3228.     with dtst do begin
  3229.       dt.year  := (hi(date) shr 1) + 1980;
  3230.       dt.month := (date shr 5) and 15;
  3231.       dt.day   := lo(date) and 31;
  3232.       dt.hour  := hi(time) shr 3;
  3233.       dt.min   := (time shr 5) and 63;
  3234.       dt.sec   := (lo(time) and 31) * 2;
  3235.     end;
  3236.   end;
  3237.  
  3238.  
  3239.   function __formatdate(d : longint; format : byte): string;
  3240.   var
  3241.     dt   : datetime;
  3242.   begin
  3243.     __longint2datetime(d, dt);
  3244.     __formatdate := format_date(dt, format);
  3245.   end;
  3246.  
  3247.  
  3248.   function __retdow(y, m, d: word): word;
  3249.   var oy, om, od, odow : word;
  3250.   begin
  3251.     getdate(oy, om, od, odow); setdate(y, m, d); getdate(y, m, d, odow);
  3252.     setdate(oy, om, od);
  3253.     __retdow := odow;
  3254.   end;
  3255.  
  3256.  
  3257.   function __today: byte;
  3258.   var year, month, day, dow: word;
  3259.   begin
  3260.     getdate(year, month, day, dow);
  3261.     __today := dow;
  3262.   end;
  3263.  
  3264.  
  3265.  
  3266.  
  3267.  
  3268.  
  3269.  
  3270.  
  3271.  
  3272. {$IFNDEF USETURBODOS}
  3273. { IMPORTANT DOS FUNCTIONS XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX }
  3274.   procedure getdate(var year,month,day,dayofweek : word); external;
  3275.  
  3276.   procedure setdate(year,month,day : word); external;
  3277.  
  3278.   procedure gettime(var hour,minute,second,sec100 : word); external;
  3279.  
  3280.   procedure settime(hour,minute,second,sec100 : word); external;
  3281.   function  diskfree(drive : byte) : longint; external;
  3282.  
  3283.   function  disksize(drive : byte) : longint; external;
  3284.  
  3285.   procedure getfattr(var f;var attr : word); external;
  3286.  
  3287.   procedure setfattr(var f;attr : word); external;
  3288.  
  3289.   procedure getftime(var f;var time : longint); external;
  3290.  
  3291.   procedure setftime(var f; time : longint); external;
  3292.   procedure findfirst(path : pathstr;attr : word;var f : searchrec); external;
  3293.   procedure findnext(var f : searchrec); external;
  3294.  
  3295.   procedure unpacktime(p : longint;var t : datetime); external;
  3296.  
  3297.   procedure packtime(var t : datetime;var p : longint); external;
  3298.  
  3299.   function  fexpand(path : pathstr) : pathstr; external;
  3300.  
  3301.   procedure fsplit(
  3302.     path : pathstr;var dir : dirstr;
  3303.     var name : namestr;var ext : extstr
  3304.   ); external;
  3305. {$ENDIF}
  3306.  
  3307.  
  3308.   {$F+}
  3309.   function  __existfil(pathname: string): boolean;
  3310.   var fileinfo: searchrec;
  3311.   begin
  3312.     findfirst(__normfil(pathname), anyfile, fileinfo);
  3313.     __existfil := (doserror = 0) and not(
  3314.       ((fileinfo.attr and volumeid) > 0) or
  3315.       ((fileinfo.attr and directory) > 0)
  3316.     )
  3317.   end;
  3318.  
  3319.  
  3320.   function __progname: string;
  3321.   const
  3322.     registered : boolean = false;
  3323.  
  3324.   begin
  3325.     if not registered then begin
  3326.       registeredprogname := __extractname(paramstr(0)); registered := true;
  3327.     end;
  3328.     __progname := registeredprogname;
  3329.   end;
  3330.  
  3331.  
  3332.   procedure __erasefil(filename : pathstr; var errorcode : word);
  3333.   var
  3334.     pathlen : word;
  3335.     reg     : registers;
  3336.  
  3337.   begin
  3338.     pathlen := length(filename);
  3339.     move(filename[1],filename[0],pathlen);
  3340.     filename[pathlen] := #0;
  3341.     with reg do begin
  3342.       ax := $4100; ds := seg(filename); dx := ofs(filename); intr($21, reg);
  3343.       if ((flags and fcarry) <> 0) then errorcode := ax else errorcode := 0
  3344.     end
  3345.   end;
  3346.   {$F-}
  3347.  
  3348.  
  3349. {$IFNDEF USETURBODOS}
  3350.   procedure intr(intno : byte;var regs : registers); external;
  3351.   procedure getintvec(intno: byte;var vector: pointer); external;
  3352.   procedure swapvectors; external;
  3353. {$ENDIF}
  3354.  
  3355.  
  3356.   function  __dosinkey(var extendedcode : byte) : char;
  3357.   var reg : registers;
  3358.   begin
  3359.     with reg do begin
  3360.       ah := $07; intr($21, reg);
  3361.       if (al=0) then begin
  3362.         __dosinkey := chr(0); ah := $07; intr($21,reg)
  3363.       end else __dosinkey := chr(al);
  3364.       extendedcode  := al
  3365.     end
  3366.   end;
  3367.  
  3368.  
  3369.   function  __exrdykey(
  3370.     useextended : boolean;
  3371.     var nextch : char;
  3372.     var scancode : byte
  3373.   ) : boolean;
  3374.   var reg : registers;
  3375.   begin
  3376.     with reg do begin
  3377.       flags := 0;
  3378.       if (useextended) then ah := $11 else ah := $01;
  3379.       intr($16, reg);
  3380.       if ((flags and fzero) = 0) then begin
  3381.         scancode := ah; nextch := char(al); __exrdykey := true
  3382.       end else __exrdykey := false
  3383.     end
  3384.   end;
  3385.  
  3386.  
  3387.  
  3388.   procedure __flushkey;
  3389.   var reg : registers;
  3390.   begin
  3391.     with reg do begin ax := $0c06; dx := $00ff end; intr($21, reg)
  3392.   end;
  3393.  
  3394.  
  3395.  
  3396.  
  3397.  
  3398.   function __queuekey : word;
  3399.   var
  3400.     bufferhead  : word absolute _biosseg:$001a;
  3401.     buffertail  : word absolute _biosseg:$001c;
  3402.     bufferstart : word absolute _biosseg:$0080;
  3403.     bufferend   : word absolute _biosseg:$0082;
  3404.     avail       :                         word;
  3405.  
  3406.   begin
  3407.     if (bufferhead > buffertail) then avail := (bufferhead - buffertail) else
  3408.       avail := (bufferhead + (bufferend - bufferstart) - buffertail);
  3409.     __queuekey := avail;
  3410.   end;
  3411.  
  3412.  
  3413.  
  3414.  
  3415.   function  keypressed : boolean;
  3416.   begin
  3417.     keypressed := crt.keypressed;
  3418.   end;
  3419.  
  3420.  
  3421.  
  3422.  
  3423.   procedure __delay(w: word);
  3424.   var i : word;
  3425.  
  3426.     procedure wait_100; { 01:57:22.13 }
  3427.     begin
  3428.       starttimer(maxtimer);
  3429.       repeat until(__str(copy(getlaptime(maxtimer), 10, 2)) >= 9);
  3430.       stoptimer(maxtimer);
  3431.     end;
  3432.  
  3433.     procedure wait_250; { 01:57:22.13 }
  3434.     begin
  3435.       starttimer(maxtimer);
  3436.       repeat until(__str(copy(getlaptime(maxtimer), 10, 2)) >= 23);
  3437.       stoptimer(maxtimer);
  3438.     end;
  3439.  
  3440.     procedure wait_1000; { 01:57:22.13 }
  3441.     begin
  3442.       starttimer(maxtimer);
  3443.       repeat until(__str(copy(getlaptime(maxtimer), 7, 2)) >= 1);
  3444.       stoptimer(maxtimer);
  3445.     end;
  3446.  
  3447.   begin
  3448.     if (w < 5000) and (w > 100) then
  3449.       for i := 1 to __main(w, 250) div 250 do wait_250 else
  3450.       if (w < 5000) and (w <= 100) then
  3451.         for i := 1 to __main(w, 100) div 100 do wait_100 else
  3452.         for i := 1 to __main(w, 1000) div 1000 do wait_1000;
  3453.   end;
  3454.  
  3455.  
  3456.  
  3457.  
  3458.   procedure __delaykey(w:word);
  3459.   var
  3460.     i, jj : integer;
  3461.     c    :    char;
  3462.  
  3463.   begin
  3464.     i := 1;
  3465.     while i < (w div 250) do begin
  3466.       __delay(250); inc(i);
  3467.       if keypressed then begin i := maxint; __flushkey end;
  3468.     end;
  3469.   end;
  3470.  
  3471.  
  3472.  
  3473.   function __paridutl(var cmdprocid : word) : word;
  3474.   var cmdptr : pointer;
  3475.   begin
  3476.     getintvec($2e,cmdptr);
  3477.     cmdprocid := _vectoraddr(cmdptr)._seg;
  3478.     __paridutl := memw[prefixseg:$16]
  3479.   end;
  3480.  
  3481.  
  3482.  
  3483.   function cmdenvseg(var cmdprocid: word): word;
  3484.   type
  3485.     _memctrl = record
  3486.       _header   : char;
  3487.       _ownerpsp : word;
  3488.       _size     : word;
  3489.       _reserved : array[1..11] of byte
  3490.     end;
  3491.  
  3492.   var
  3493.     memblockptr : ^_memctrl;
  3494.     envseg      : word;
  3495.     parid       : word;
  3496.  
  3497.   begin
  3498.     parid := __paridutl(cmdprocid); memblockptr := ptr(cmdprocid - 1, 0);
  3499.     repeat
  3500.       __iptrsup(
  3501.         pointer(memblockptr),
  3502.         16 * longint(memblockptr^._size + 1)
  3503.       );
  3504.       envseg := _vectoraddr(memblockptr)._seg + 1
  3505.     until (
  3506.       (memblockptr^._ownerpsp = cmdprocid) or
  3507.       (memblockptr^._header = 'Z')
  3508.     );
  3509.     if (memblockptr^._ownerpsp <> cmdprocid) then envseg := 0;
  3510.     cmdenvseg := envseg
  3511.   end;
  3512.  
  3513.  
  3514.  
  3515.  
  3516.   function __spaceutl(
  3517.     drive : byte;
  3518.     var availclus, totalclus,
  3519.     bytespersec, secsperclus: word
  3520.   ): longint;
  3521.   var reg : registers;
  3522.   begin
  3523.     with reg do begin
  3524.       ah := $36; dl := drive; intr($21,reg);
  3525.       if (ax = $ffff) then begin
  3526.         availclus := 0; totalclus := 0; bytespersec := 0;
  3527.         secsperclus := 0; __spaceutl  := -1
  3528.       end else begin
  3529.         availclus := bx; totalclus := dx; bytespersec := cx;
  3530.         secsperclus := ax;
  3531.         __spaceutl  := longint(bx) * longint(cx) * longint(ax)
  3532.       end
  3533.     end
  3534.   end;
  3535.  
  3536.  
  3537.  
  3538.   function __putenutl(envstr: string): string;
  3539.   type
  3540.     _memctrl   = record
  3541.       _header   : char;
  3542.       _ownerpsp : word;
  3543.       _size     : word;
  3544.       _reserved : array[1..11] of byte
  3545.     end;
  3546.  
  3547.     function retmemblock(
  3548.       request: word; var allocbytes: word; var memoryptr: pointer
  3549.     ): pointer;
  3550.     var tempptr : pointer;
  3551.     begin
  3552.       allocbytes := 16 * (request + 1) + 15;
  3553.       getmem(memoryptr,allocbytes);
  3554.       if (memoryptr = nil) then begin
  3555.         allocbytes := 0; retmemblock := nil; exit
  3556.       end;
  3557.       fillchar(memoryptr^,allocbytes,$40);
  3558.       if (_vectoraddr(memoryptr)._ofs <> 0) then
  3559.         tempptr := ptr(_vectoraddr(memoryptr)._seg + 1,0) else
  3560.         tempptr := memoryptr;
  3561.       with _memctrl(tempptr^) do begin
  3562.         _header   := 'M';
  3563.         _ownerpsp := prefixseg;
  3564.         _size     := request;
  3565.         fillchar(_reserved,11,0)
  3566.       end;
  3567.       retmemblock := tempptr
  3568.     end;
  3569.  
  3570.   var
  3571.     envsize      : word;
  3572.     errorcode    : word;
  3573.     tempptr      : pointer;
  3574.     newenvmemptr : pointer;
  3575.  
  3576.   begin
  3577.     __putenutl := '';
  3578.     if (envmemptr_ = nil) then begin
  3579.       envsize := memw[_envseg - 1:3];
  3580.       tempptr := retmemblock(envsize + 16,envsize_,envmemptr_);
  3581.       if (tempptr = nil) then exit;
  3582.       _envptr := ptr(_vectoraddr(tempptr)._seg + 1,0);
  3583.       move(memw[_envseg:0],_envptr^,16 * envsize);
  3584.       memw[prefixseg:$2c] := _vectoraddr(_envptr)._seg;
  3585.       __putenutl := __chgenutl(prefixseg,envstr,errorcode);
  3586.       if (errorcode <> 0) then __putenutl := ''
  3587.     end else begin
  3588.       __putenutl := __chgenutl(prefixseg,envstr,errorcode);
  3589.       if (errorcode <> 2) then exit;
  3590.       tempptr := retmemblock((envsize_ div 16) + 15, envsize, newenvmemptr);
  3591.       if (tempptr = nil) then exit;
  3592.       __iptrsup(tempptr,16);
  3593.       move(_envptr^,tempptr^,envsize_-_vectoraddr(envmemptr_)._ofs - 16);
  3594.       memw[prefixseg:$2c] := _vectoraddr(tempptr)._seg;
  3595.       _envptr := tempptr;
  3596.       freemem(envmemptr_,envsize_);
  3597.       envmemptr_ := newenvmemptr;
  3598.       envsize_   := envsize;
  3599.       __putenutl := __chgenutl(prefixseg,envstr,errorcode);
  3600.       if (errorcode <> 0) then __putenutl := ''
  3601.     end
  3602.   end;
  3603.  
  3604.  
  3605.  
  3606.  
  3607.   function __retenutl(var envpos : word) : string;
  3608.   type environmentptr = ^_memorychar;
  3609.   var
  3610.     envptr  : environmentptr;
  3611.     strlen  : integer;
  3612.     i       : integer;
  3613.     tempch  : char;
  3614.     tempstr : string;
  3615.     tempptr : pointer;
  3616.  
  3617.   begin
  3618.     envptr := environmentptr(_envptr);
  3619.     strlen := 0;
  3620.     i      := envpos;
  3621.     tempch := envptr^[i];
  3622.     while (tempch <> #0) do begin
  3623.       inc(strlen);
  3624.       tempstr[strlen] := tempch;
  3625.       inc(i);
  3626.       tempch := envptr^[i]
  3627.     end;
  3628.  
  3629.     tempstr[0] := chr(strlen);
  3630.     if (strlen <> 0) then envpos  := i + 1;
  3631.     __retenutl := tempstr
  3632.   end;
  3633.  
  3634.  
  3635.  
  3636.   function __chgenutl(progseg: word; envstr: string; var error: word): string;
  3637.   const
  3638.     equal = '=';
  3639.     blank = ' ';
  3640.     tab   = #9;
  3641.  
  3642.   var
  3643.     envseg         : word;
  3644.     cmdprocid      : word;
  3645.     parid          : word;
  3646.     envptr         : ^_memorychar;
  3647.     idstr          : string[127];
  3648.     prevsize       : word;
  3649.     newsize        : word;
  3650.     totalsize      : word;
  3651.     varpos,varsize : integer;
  3652.     i,j            : integer;
  3653.     lenenvstr      : integer;
  3654.     equalpos       : integer;
  3655.     eqsign         : integer;
  3656.     eqpos          : integer;
  3657.     found          : boolean;
  3658.     envvar,retstr  : string;
  3659.     tempch         : char;
  3660.     locenvptr      : pointer;
  3661.  
  3662.   begin
  3663.     __chgenutl := ''; error  := 0;
  3664.     if (progseg = 0) then progseg := prefixseg;
  3665.     if (memw[progseg - 1:1] <> progseg) then begin
  3666.       error := 1; exit;
  3667.     end;
  3668.     envseg := memw[progseg:$2C];
  3669.     if (envseg = 0) then begin
  3670.       envseg := cmdenvseg(cmdprocid);
  3671.       if (progseg <> cmdprocid) then begin
  3672.         error := 1; exit;
  3673.       end
  3674.     end else if (memw[envseg - 1 : 1] <> progseg) then begin
  3675.       error := 1; exit
  3676.     end;
  3677.     locenvptr := _envptr; _envptr := ptr(envseg,0);
  3678.     i := 1; found := true; lenenvstr := length(envstr);
  3679.     while ((i <= lenenvstr) and found) do if (
  3680.       (envstr[i] = blank) or (envstr[i] = tab)
  3681.     ) then inc(i) else found := false;
  3682.     j := i - 1; lenenvstr := lenenvstr - j;
  3683.     eqsign := 0;
  3684.     for i := 1 to lenenvstr do begin
  3685.       tempch := envstr[i + j];
  3686.       if (tempch = equal) then begin inc(eqsign); eqpos  := i end;
  3687.       if (eqsign <> 0) then envstr[i] := tempch else
  3688.         envstr[i] := upcase(tempch)
  3689.     end;
  3690.     if (eqsign <> 1) then begin error := 3; exit end else begin
  3691.       envstr[0]  := chr(lenenvstr);
  3692.       __chgenutl := envstr
  3693.     end;
  3694.     envvar := copy(envstr,1,eqpos - 1); varpos := 0; prevsize := 1;
  3695.     repeat
  3696.       retstr := __retenutl(prevsize);
  3697.       if (length(retstr) <> 0) then begin
  3698.         if (varpos = 0) then if (
  3699.           envvar = copy(retstr,1,pos(equal,retstr) - 1)
  3700.         ) then begin varsize := length(retstr)+1; varpos := prevsize-varsize end;
  3701.       end;
  3702.     until (length(retstr) = 0);
  3703.     if (length(copy(envstr,eqpos + 1,255)) = 0) then begin
  3704.       newsize := prevsize; lenenvstr := 0
  3705.     end else newsize := prevsize + lenenvstr + 1;
  3706.     if (varpos <> 0) then newsize := newsize - varsize;
  3707.     idstr := ''; j := 0;
  3708.     envptr := ptr(envseg,prevsize);
  3709.     if (word(pointer(envptr)^) = 1) then begin
  3710.       __iptrsup(pointer(envptr),2);
  3711.       repeat
  3712.         inc(j);
  3713.         idstr[j] := envptr^[j]
  3714.       until (idstr[j] = #0)
  3715.     end;
  3716.     idstr[0] := char(j);
  3717.     totalsize := newsize + j;
  3718.     if (totalsize > (memw[envseg - 1:3] * 16)) then begin
  3719.       error := 2; __chgenutl := ''; exit
  3720.     end;
  3721.     envptr := ptr(envseg,0);
  3722.     if (varpos = 0) then move(envstr[1],envptr^[prevsize],lenenvstr) else begin
  3723.       move(
  3724.         envptr^[varpos + varsize],
  3725.         envptr^[varpos],prevsize - varpos - varsize
  3726.       );
  3727.       move(envstr[1],envptr^[prevsize - varsize],lenenvstr);
  3728.     end;
  3729.     envptr^[newsize - 1] := chr(0);
  3730.     envptr^[newsize]     := chr(0);
  3731.     if (length(idstr) > 0) then begin
  3732.       envptr^[newsize + 1] := #1;
  3733.       envptr^[newsize + 2] := #0;
  3734.       move(idstr[1],envptr^[newsize + 3],length(idstr))
  3735.     end;
  3736.     _envptr := locenvptr;
  3737.   end;
  3738.  
  3739.  
  3740.  
  3741.   function  __envpath(st: string): string; { ends on \ }
  3742.   var
  3743.     envpos     :   word;
  3744.     tmp, envstr: string;
  3745.  
  3746.   begin
  3747.     envpos := 1; envstr := __retenutl(envpos);
  3748.     while length(envstr) <> 0 do begin
  3749.       if copy(envstr,1, length(st)+1) = (st + '=') then
  3750.         tmp := copy(envstr,length(st)+2,length(envstr)-(length(st)+1));
  3751.       envstr := __retenutl(envpos)
  3752.     end;
  3753.     __envpath := tmp;
  3754.   end; { __envpath }
  3755.  
  3756.  
  3757.  
  3758.   function __getpath(var fname : string) : boolean;
  3759.   { returns the full path and filename for a filename if the file  }
  3760.   { is found in the path. }
  3761.  
  3762.   var
  3763.     found         : boolean;
  3764.     setpath,
  3765.     homedir,
  3766.     extractedpath :  string;
  3767.     i, j, len     :    byte;
  3768.  
  3769.   begin
  3770.     homedir := __normfil(fname);
  3771.     if __existfil(homedir) then begin
  3772.       fname := homedir; __getpath := true; exit;
  3773.     end;
  3774.     setpath := __xlatestr(getenv('PATH'), ';', ' ') + ' ';
  3775.     j := 1; len := length(setpath);
  3776.     repeat
  3777.       inc(j); i := j;
  3778.       while (setpath[j] <> ' ') and (j < len) do inc(j); inc(j);
  3779.       extractedpath := __backapp(copy(setpath, i-1, j-i));
  3780.       found := __existfil(extractedpath + fname);
  3781.     until (found) or (j > len) or (i > len);
  3782.     if found then fname := extractedpath + fname;
  3783.     __getpath := found;
  3784.   end;
  3785.  
  3786.  
  3787.  
  3788.   function __address(zone, net, node, point: integer): string;
  3789.   begin
  3790.    __address :=
  3791.      __num(zone) + ':' + __num(net) + '/' + __num(node) + '.' + __num(point);
  3792.   end;
  3793.  
  3794.  
  3795.  
  3796.   procedure __expandnum(
  3797.     node : string; var tozone, tonet, tonode, topoint: word
  3798.   );
  3799.   var                      { zzzzz:nnnnn/nnnnn.ppppp }
  3800.     i, j : byte;           { eg.  '12:5003/1222.000' }
  3801.  
  3802.   begin
  3803.     i := pos(':', node);
  3804.     tozone := __str(copy(node, 1, i - 1));
  3805.     j := pos('/', node); if j=0 then j := pos('\', node);
  3806.     tonet  := __str(copy(node, i + 1, j - i - 1));
  3807.     i := pos('.', node);
  3808.     if i > 0 then tonode := __str(copy(node, j+1, i-j-1)) else
  3809.       tonode := __str(copy(node, j+1, length(node)-j));
  3810.     topoint := __str(copy(node, i + 1, length(node) - i));
  3811.   end;
  3812.  
  3813.  
  3814.  
  3815.   function __expandchr(st: string; c: char; chh:  string): string;
  3816.   var
  3817.     lenst,
  3818.     j      : byte;
  3819.  
  3820.   begin
  3821.     j := 1; lenst := length(st);
  3822.     while (j <= lenst) do begin
  3823.       while (j <= lenst) and (st[j] <> c) do inc(j);
  3824.       if (j <= lenst) then begin
  3825.         delete(st, j, 1);
  3826.         if j < lenst then insert(chh, st, j) else st := st + chh;
  3827.         inc(lenst, length(chh)); inc(j, length(chh));
  3828.       end;
  3829.     end;
  3830.     __expandchr := st;
  3831.   end;
  3832.  
  3833.  
  3834.  
  3835.   function  __ctrlkey(status : _keystatus) : longint;
  3836.   var
  3837.     statusloc  : word absolute _biosseg:$0017;
  3838.     statusloc2 : byte absolute _biosseg:$0096;
  3839.     statusword : word;
  3840.     statusbyte : byte;
  3841.  
  3842.   begin
  3843.     statusword := 0; statusbyte := 0;
  3844.     with status do begin
  3845.       if (_insstate      ) then statusword := statusword or $8000;
  3846.       if (_capsstate     ) then statusword := statusword or $4000;
  3847.       if (_numstate      ) then statusword := statusword or $2000;
  3848.       if (_scrollstate   ) then statusword := statusword or $1000;
  3849.       if (_altshift      ) then statusword := statusword or $0800;
  3850.       if (_ctrlshift     ) then statusword := statusword or $0400;
  3851.       if (_leftshift     ) then statusword := statusword or $0200;
  3852.       if (_rightshift    ) then statusword := statusword or $0100;
  3853.       if (_insshift      ) then statusword := statusword or $0080;
  3854.       if (_capsshift     ) then statusword := statusword or $0040;
  3855.       if (_numshift      ) then statusword := statusword or $0020;
  3856.       if (_scrollshift   ) then statusword := statusword or $0010;
  3857.       if (_holdstate     ) then statusword := statusword or $0008;
  3858.       if (_sysshift      ) then statusword := statusword or $0004;
  3859.       if (_rightctrlshift) then statusbyte := statusbyte or $0008;
  3860.       if (_rightaltshift ) then statusbyte := statusbyte or $0004;
  3861.       if (_leftctrlshift ) then statusword := statusword or $0002;
  3862.       if (_leftaltshift  ) then statusword := statusword or $0001
  3863.     end;
  3864.     statusloc  := swap(statusword);
  3865.     statusloc2 := statusloc2 or statusbyte;
  3866.     __ctrlkey  := longint(statusword) or (longint(statusbyte) shl 16)
  3867.   end;
  3868.  
  3869.  
  3870.   function  __statkey(var status : _keystatus) : longint;
  3871.   var
  3872.     statusloc  : word absolute _biosseg:$0017;
  3873.     statusloc2 : byte absolute _biosseg:$0096;
  3874.     statusword : word;
  3875.     statusbyte : byte;
  3876.  
  3877.   begin
  3878.     statusword := swap(statusloc);          { 8086 stores "backwords"   }
  3879.     statusbyte := (statusloc2 shr 2) and 3; { flags in 2 low order bits }
  3880.     with status do begin
  3881.       _insstate       := ((statusword and $8000) <> 0);
  3882.       _capsstate      := ((statusword and $4000) <> 0);
  3883.       _numstate       := ((statusword and $2000) <> 0);
  3884.       _scrollstate    := ((statusword and $1000) <> 0);
  3885.       _altshift       := ((statusword and $0800) <> 0);
  3886.       _ctrlshift      := ((statusword and $0400) <> 0);
  3887.       _leftshift      := ((statusword and $0200) <> 0);
  3888.       _rightshift     := ((statusword and $0100) <> 0);
  3889.       _insshift       := ((statusword and $0080) <> 0);
  3890.       _capsshift      := ((statusword and $0040) <> 0);
  3891.       _numshift       := ((statusword and $0020) <> 0);
  3892.       _scrollshift    := ((statusword and $0010) <> 0);
  3893.       _holdstate      := ((statusword and $0008) <> 0);
  3894.       _sysshift       := ((statusword and $0004) <> 0);
  3895.       _leftaltshift   := ((statusword and $0002) <> 0);
  3896.       _leftctrlshift  := ((statusword and $0001) <> 0);
  3897.       _rightctrlshift := ((statusbyte and $01) <> 0);
  3898.       _rightaltshift  := ((statusbyte and $02) <> 0)
  3899.     end;
  3900.     __statkey := (longint(statusbyte) shl 16) or longint(statusword)
  3901.   end;
  3902.  
  3903.  
  3904.  
  3905.   function  __stuffkey;
  3906.   type
  3907.     _keyseq = record _ch : char; _scancode :  byte end;
  3908.  
  3909.     function placekey(keystroke : _keyseq) : boolean;
  3910.     var
  3911.       nextpos     : word;
  3912.       bufferptr   : ^word;
  3913.       bufferhead  : word absolute _biosseg:$001a;
  3914.       buffertail  : word absolute _biosseg:$001c;
  3915.       bufferstart : word absolute _biosseg:$0080;
  3916.       bufferend   : word absolute _biosseg:$0082;
  3917.  
  3918.     begin
  3919.       nextpos := buffertail + 2;                { we have wrap around   }
  3920.       if (nextpos >= bufferend) then nextpos  := bufferstart;
  3921.                                                 { the buffer is full.   }
  3922.       if (nextpos = bufferhead) then placekey := false else begin
  3923.         { put the sequence in right here. }
  3924.         bufferptr := ptr(_biosseg,buffertail);
  3925.         inline($fa);                            { disable interrupts    }
  3926.         bufferptr^ := word(keystroke);
  3927.         buffertail := nextpos;
  3928.         inline($fb);                            { enable interrupts     }
  3929.         placekey := true;
  3930.       end;
  3931.     end;
  3932.  
  3933.   var
  3934.     i,j       : integer;
  3935.     lenstr    : integer;
  3936.     keystroke : _keyseq;
  3937.     stuffed   : boolean;
  3938.  
  3939.   begin
  3940.     lenstr := length(charstr);
  3941.     if (lenstr = 0) then begin         { not much to do, so return       }
  3942.       __stuffkey := charstr;
  3943.       exit
  3944.     end;
  3945.  
  3946.     i := 0;                            { can assume charstr is not empty }
  3947.     repeat
  3948.       inc(i);
  3949.       j := i;                          { save character position in      }
  3950.                { case it cannot be stuffed.     }
  3951.       with keystroke do begin
  3952.         _ch := charstr[i]; _scancode := 0
  3953.       end;
  3954.       stuffed := placekey(keystroke)
  3955.     until ((i = lenstr) or (not stuffed));
  3956.  
  3957.     if (not stuffed) then __stuffkey := copy(charstr,j,lenstr) else
  3958.       __stuffkey := ''
  3959.   end;
  3960.  
  3961.  
  3962.  
  3963.  
  3964.   procedure __resetsup(testmem : boolean);
  3965.   var
  3966.     reset_flag : word absolute $40:$72;
  3967.     ch         : char;
  3968.  
  3969.   begin
  3970.     if testmem then reset_flag := $0000 else reset_flag := $1234;
  3971.     inline($ea/$00/$00/$ff/$ff)        { jmp ffff:0000                  }
  3972.   end;
  3973.  
  3974.  
  3975.  
  3976.  
  3977.   procedure __resetfil;
  3978.   var reg : registers;
  3979.   begin
  3980.     with reg do begin
  3981.       ah := $0d;
  3982.       intr($21, reg)
  3983.     end;
  3984.   end;
  3985.  
  3986.  
  3987.   function fopen; {open untyped file return the dos error code}
  3988.   var fm : byte;
  3989.   begin
  3990.     assign(fv,fn);
  3991.     fm := filemode;
  3992.     if mode <> _keep_mode then filemode := mode;
  3993.     reset(fv,1);
  3994.     fopen := ioresult;
  3995.     filemode := fm;
  3996.   end;
  3997.  
  3998.  
  3999.  
  4000.  
  4001.   function  fclose(var fv : stream) : integer;
  4002.   begin
  4003.     close(fv);
  4004.     fclose := ioresult;
  4005.   end;
  4006.  
  4007.  
  4008.  
  4009.  
  4010.   function shareloaded : boolean;
  4011.   var reg : registers;
  4012.   begin
  4013.     reg.ax := $1000;
  4014.     intr($2f,reg);
  4015.     shareloaded := ((reg.flags and $01) = 0) and (reg.al = $ff);
  4016.   end;
  4017.  
  4018.  
  4019.   {
  4020.     Lock or Unlock region of file.
  4021.     Input         : Handle  - turbo untype file variable handle (filerec(fv).handle)
  4022.     input         : action  - action to take. See constants above;
  4023.     input         : start   - beginging file position to lock.
  4024.     input         : bytes   - number of bytes to lock.
  4025.     output        : ax      - ax register return value
  4026.     returns TRUE if lock is successful, False otherwise (check AX)
  4027.   }
  4028.  
  4029.  
  4030.   function filelock(handle : word; action : byte; start,bytes : longint; var ax : integer): boolean;
  4031.   var reg : registers;
  4032.   begin
  4033.     reg.ax := $5c00 + action;
  4034.     reg.bx := handle;
  4035.     reg.cx := hi(start);
  4036.     reg.dx := lo(start);
  4037.     reg.si := hi(bytes);
  4038.     reg.di := lo(bytes);
  4039.     intr($21,reg);
  4040.     filelock := (reg.flags and $01) = $00;
  4041.     ax := reg.ax;
  4042.    end;
  4043.  
  4044.  
  4045.  
  4046.  
  4047.   function __exinkey(useextended: boolean; var scancode: byte): char;
  4048.   var reg : registers;
  4049.   begin
  4050.     with reg do begin
  4051.       if (useextended) then ah := $10 else ah := 0;
  4052.       al := 0; intr($16, reg); scancode  := ah;
  4053.             __exinkey := char(al)
  4054.     end
  4055.   end;
  4056.  
  4057.  
  4058.   function __retkey: word;
  4059.   var
  4060.     ch: char;
  4061.     sc: byte;
  4062.  
  4063.   begin
  4064.     ch := __exinkey(true, sc);
  4065.     lastkey := ch; lastscan := sc;
  4066.     __retkey := __2wordsup(sc, ord(ch))
  4067.   end;
  4068.  
  4069.   function  __direction;
  4070.   begin
  4071.     __direction := (
  4072.       (w =_up) or    (w =_padup) or
  4073.       (w =_down) or  (w =_paddown) or
  4074.       (w =_right) or (w =_padright) or
  4075.       (w =_left) or  (w =_padleft) or
  4076.       (w =_home) or  (w =_padhome) or
  4077.       (w =_end) or   (w =_padend) or
  4078.       (w =_pgup) or  (w =_padpgup) or
  4079.       (w =_pgdn) or  (w =_padpgdn) or
  4080.       (w =_plus) or  (w =_padplus) or
  4081.       (w =_minus) or (w =_padminus)
  4082.     );
  4083.   end;
  4084.  
  4085.  
  4086.   function  __retdelaykey(delaytim: byte; default: word): word;  { delay < 60 }
  4087.   var
  4088.     ch: char;
  4089.     sc: byte;
  4090.  
  4091.   begin
  4092.     ch := #00;
  4093.     if delaytim = 0 then __retdelaykey := __retkey else begin
  4094.       starttimer(2);
  4095.       repeat __exrdykey(true, ch, sc) until (
  4096.         (delaytim > 0) and (__str(copy(getlaptime(2), 7, 2)) >= delaytim)
  4097.       ) or (ch <> #00);
  4098.       if ch = #00 then begin { timeout occurred }
  4099.         if default > 0 then __retdelaykey := default else __retdelaykey := 0;
  4100.       end else begin
  4101.         lastkey := ch; lastscan := sc;
  4102.         __retdelaykey := __2wordsup(sc, ord(ch)); __flushkey
  4103.       end;
  4104.     end;
  4105.   end;
  4106.  
  4107.  
  4108.  
  4109.   function __attrfilter(fileattr, filter: byte): boolean;
  4110.   {
  4111.     only and notnone may only be used in conjunction with other attribs like
  4112.     readonly, hidden, sysfile, volumeid, directory and archive.
  4113.   }
  4114.   type
  4115.     filterenum = (r_o, hid, sys, vol, dir, arc, only, notnone);
  4116.     filterenumset = set of filterenum;
  4117.  
  4118.   var
  4119.     makefilter : filterenumset;
  4120.     filefilter : filterenumset;
  4121.  
  4122.   begin
  4123.     makefilter := filterenumset(filter);
  4124.     filefilter := filterenumset(fileattr);
  4125.     if (
  4126.       (notnone in makefilter) and ((filefilter - [notnone]) = [])
  4127.     ) then __attrfilter := false else if only in makefilter then
  4128.       __attrfilter := (filefilter + [only] = makefilter) else
  4129.         __attrfilter := (filefilter <= makefilter);
  4130.   end; { __attrfilter }
  4131.  
  4132.  
  4133.  
  4134.   function  __bak(s: string): string;
  4135.   var
  4136.     st : string;
  4137.     i  :   byte;
  4138.  
  4139.   begin
  4140.     st := __extractname(s);
  4141.     if pos('.', st) = 0 then __bak := st + '.BAK' else begin
  4142.       i := length(s);
  4143.       while (i > 0) and (s[i] <> '.') do dec(i);
  4144.       __bak := copy(st, 1, i) + 'BAK';
  4145.     end;
  4146.   end;
  4147.  
  4148.  
  4149.   function  __comexebatcmdfilter;
  4150.   begin
  4151.     __comexebatcmdfilter := (
  4152.       __comp(__extractext(s), 'EXE') or __comp(__extractext(s), 'CMD') or
  4153.       __comp(__extractext(s), 'COM') or __comp(__extractext(s), 'BAT')
  4154.     );
  4155.   end;
  4156.  
  4157.  
  4158.  
  4159.   function __retdrfil : char;
  4160.   var reg : registers;
  4161.   begin
  4162.     with reg do begin
  4163.       ah := $19; intr($21, reg);
  4164.       __retdrfil := char(byte('A') + al)
  4165.     end
  4166.   end;
  4167.  
  4168.  
  4169.   function  __curdir: string;
  4170.   var s: string;
  4171.  
  4172.   begin
  4173.     getdir(0, s); __curdir := s;
  4174.   end;
  4175.  
  4176.  
  4177.  
  4178.   function __deverr: string;
  4179.   begin
  4180.     case doserror of
  4181.       000: __deverr := 'No DosError Detected!';
  4182.       002: __deverr := 'File not found';
  4183.       003: __deverr := 'Path not found';
  4184.       004: __deverr := 'Too many open files';
  4185.       005: __deverr := 'File acces denied';
  4186.       006: __deverr := 'Invalid file handle';
  4187.       012: __deverr := 'Invalid file access code';
  4188.       015: __deverr := 'Invalid drive number';
  4189.       016: __deverr := 'Cannot remove current directory';
  4190.       017: __deverr := 'Cannot rename across drives';
  4191.       018: __deverr := 'No more files found';
  4192.       100: __deverr := 'Disk read error';
  4193.       101: __deverr := 'Disk write error';
  4194.       102: __deverr := 'File not assigned';
  4195.       103: __deverr := 'File not open';
  4196.       104: __deverr := 'File not open for input';
  4197.       105: __deverr := 'File not open for output';
  4198.       106: __deverr := 'Invalid numeric format';
  4199.       150: __deverr := 'Disk is write protected';
  4200.       151: __deverr := 'Unknown unit';
  4201.       152: __deverr := 'Drive not ready';
  4202.       153: __deverr := 'Unknown command';
  4203.       154: __deverr := 'CRC error in data';
  4204.       155: __deverr := 'Bad drive request structure length';
  4205.       156: __deverr := 'Disk seek error';
  4206.       157: __deverr := 'Unknown media type';
  4207.       158: __deverr := 'Sector not found';
  4208.       159: __deverr := 'Printer out of paper';
  4209.       160: __deverr := 'Device write fault';
  4210.       161: __deverr := 'Device read fault';
  4211.       162: __deverr := 'Hardware failure'
  4212.       else __deverr := 'Unrecognised Drive Error . . .'
  4213.     end; { of case }
  4214.   end;
  4215.  
  4216.  
  4217.   procedure __drvparm(drv: char);
  4218.   var
  4219.     regs  : registers;
  4220.     error :      word;
  4221.  
  4222.   begin
  4223.     if drv = ' ' then begin
  4224.       regs.ah := $19;
  4225.       intr($21, regs);
  4226.       _dosdrv := regs.al; inc(_dosdrv);          { dos drive 0 = a         }
  4227.       _dosdrvchar := chr(_dosdrv + 64);          { turbo counts from 1 = a }
  4228.     end else _dosdrv := ord(upcase(drv)) - 64;   { 65 = ascii(upcase(a))   }
  4229.     _dosdiscfree := diskfree(_dosdrv);
  4230.     _dosdiscsize := disksize(_dosdrv);
  4231.     getdir(_dosdrv, _doscurpath)
  4232.   end;
  4233.  
  4234.  
  4235. (*
  4236.   function  __envpath(st: string): string; { ends on \ }
  4237.   var
  4238.     envpos      :   word;
  4239.     tmp, envstr : string;
  4240.  
  4241.   begin
  4242.     envpos := 1; envstr := __retenutl(envpos);
  4243.     while length(envstr) <> 0 do begin
  4244.       if copy(envstr,1, length(st)+1) = (st + '=') then
  4245.         tmp := copy(envstr,length(st)+2,length(envstr)-(length(st)+1));
  4246.       envstr := __retenutl(envpos)
  4247.     end;
  4248.     if tmp[length(tmp)] <> '\' then tmp := tmp + '\';
  4249.     if tmp[length(tmp)] = ' ' then tmp := copy(tmp, 1, length(tmp)-1);
  4250.     __envpath := tmp;
  4251.   end; { __envpath }
  4252. *)
  4253.  
  4254.  
  4255.  
  4256.   procedure __erasefiles(s: string);
  4257.   var
  4258.     error :   word;
  4259.     st    : string;
  4260.  
  4261.   begin
  4262.     while __findfil(s, st) do __erasefil(st, error);
  4263.   end;
  4264.  
  4265.  
  4266.  
  4267. {$I+}
  4268.   function  __existpath(s: string): boolean; { no trailing \ please }
  4269.   var atri : searchrec;
  4270.   begin
  4271.     findfirst(
  4272.       __normfil(__backapp(s) + '*.*'), anyfile, atri
  4273.     );
  4274.     __existpath := (doserror=0)
  4275.   end;
  4276. {$I-}
  4277.  
  4278.  
  4279.  
  4280.  
  4281.   function __has_ext(name : string; var dotpos : word) : boolean;
  4282.     {-return whether and position of extension separator dot in a pathname}
  4283.   var i : word;
  4284.   begin
  4285.     dotpos := 0;
  4286.     for i := length(name) downto 1 do
  4287.       if (name[i] = '.') and (dotpos = 0) then
  4288.         dotpos := i;
  4289.     __has_ext := (dotpos > 0) and (pos('\', copy(name, succ(dotpos), 64)) = 0);
  4290.   end;
  4291.  
  4292.  
  4293.   function __def_ext(name, ext : string) : string;
  4294.     {-return a pathname with the specified extension attached}
  4295.   var dotpos : word;
  4296.   begin
  4297.     if __has_ext(name, dotpos) then __def_ext := name else
  4298.       __def_ext := name+'.'+ext;
  4299.   end;
  4300.  
  4301.  
  4302.   function __set_ext(name, ext : string) : string;
  4303.   {-return a pathname with the specified extension attached}
  4304.   var dotpos : word;
  4305.   begin
  4306.     if __has_ext(name, dotpos) then
  4307.       __set_ext := copy(name, 1, dotpos)+ext else
  4308.         __set_ext := name+'.'+ext;
  4309.   end;
  4310.  
  4311.  
  4312.   function __mat2str(var mat; s : byte):string;
  4313.   {-convert s bytes in mat into a string}
  4314.   type
  4315.     chars = array[1..maxint] of char;
  4316.   var
  4317.     i  :   byte;
  4318.     js : string;
  4319.  
  4320.   begin
  4321.     i := 1;
  4322.     js := '';
  4323.     while (i <= s) and ((chars(mat)[i]) <> chr(0)) do begin
  4324.       js := js + chars(mat)[i]; inc(i);
  4325.     end;
  4326.     __mat2str := js;
  4327.   end;
  4328.  
  4329.  
  4330.  
  4331.   function  __extractext;
  4332.   var p: byte;
  4333.   begin
  4334.     p := length(name);
  4335.     while (not(name[p] in _slashset)) and (p > 0) do dec(p);
  4336.     while (name[p] <> '.') and (p < length(name)) do inc(p);
  4337.     { . or not }
  4338.     if (name[p] <> '.') and (__lastchr(name) <> '.') then
  4339.       __extractext := '' else
  4340.       __extractext := copy(name, p+1, length(name) - p);
  4341.   end;
  4342.  
  4343.  
  4344.  
  4345.   function __extractname(s : string): string;
  4346.   var
  4347.     i, j : byte;
  4348.  
  4349.   begin
  4350.     i := length(s);
  4351.     if pos('.', s) > 0 then while (s[i] <> '.') and (i > 0) do dec(i);
  4352.     j := i;
  4353.     while not(s[j] in _slashset) and (j > 0) do dec(j);
  4354.     __extractname := copy(s, j+1, i-j-1);
  4355.   end;
  4356.  
  4357.  
  4358.  
  4359.   function __extractnamext(s : string): string;
  4360.   var
  4361.     i, j : byte;
  4362.  
  4363.   begin
  4364.     i := length(s); j := i; s := __slashfil(s);
  4365.     if pos(_dirslash, s) > 0 then
  4366.       while (j > 0) and not(s[j] in _slashset) do dec(j);
  4367.     __extractnamext := copy(s, j+1, i-j);
  4368.   end;
  4369.  
  4370.  
  4371.  
  4372.   function __extractpath(s : string): string; { eindigt op \ }
  4373.   var
  4374.     i : byte;
  4375.  
  4376.   begin
  4377.     i := length(s); while (i > 0) and not(s[i] in _slashset) do dec(i);
  4378.     __extractpath := copy(s, 1, i);
  4379.   end;
  4380.  
  4381.  
  4382.  
  4383.  
  4384.  
  4385.   function  __findfil(f: string; var s: string): boolean;
  4386.   var
  4387.     r    : searchrec;
  4388.     l    :    string;
  4389.     j, e :      byte;
  4390.  
  4391.   begin
  4392.     fillchar(r, sizeof(r), #0); findfirst(__normfil(f), $3f, r); e := doserror;
  4393.     if ((r.attr and directory)>0) or ((r.attr and volumeid)>0) then e := 0;
  4394.     j := length(f); f := __slashfil(f);
  4395.     if pos(_dirslash, f) > 0 then while f[j] <> _dirslash do dec(j);
  4396.     if e = 0 then s := copy(f, 1, j) + r.name else s := __num(e);
  4397.     if e = 0 then __findfil := true else __findfil := false;
  4398.   end;
  4399.  
  4400.  
  4401.  
  4402.   function  __inparams(s: string; var i: word): boolean;
  4403.   var
  4404.     j :    byte;
  4405.     t :  string;
  4406.     b : boolean;
  4407.  
  4408.   begin
  4409.     b := false;
  4410.     if casesensitive_env then s := __up(s);
  4411.     for j := 1 to paramcount do begin
  4412.       if casesensitive_env then t := __up(paramstr(j)) else t := paramstr(j);
  4413.       if __comp(s, t) then begin i := j + 1; b := true end;
  4414.     end;
  4415.     __inparams := b;
  4416.   end;
  4417.  
  4418.  
  4419.  
  4420.   function __checkstr(pa, en: string; var j, k : word): boolean;
  4421.   begin
  4422.     j := pos(__up(pa), __up(en));
  4423.     __checkstr := (j > 0) and (length(pa) > 0) and (length(en) > 0);
  4424.     if j > 0 then begin
  4425.       inc(j, length(pa)); while (en[j] = ' ') and (j <= length(en)) do inc(j);
  4426.     end;
  4427.     k := j; while (en[k] <> ' ') and (k <= length(en)) do inc(k);
  4428.     {
  4429.       j..k is parameter after switch "pa" in "en"
  4430.       e.g. PROG /x 12 /u 2
  4431.                 1234567890
  4432.         __checkstr('/x', '/x 12 /u 2', j, k);
  4433.         j = 4
  4434.         k = 5
  4435.     }
  4436.   end;
  4437.  
  4438.  
  4439.  
  4440.   function  __packfil(str: string; size: byte): string;
  4441.   var i,ii: byte;
  4442.   begin
  4443.     if size < 15 then size := 15;
  4444.     str := __xlatestr(__backrem(__normfil(str)), '\', _dirslash);
  4445.     if length(str) <= size then __packfil := str else begin
  4446.       while length(str) > size+1 do begin
  4447.         i := pos(_dirslash,str); inc(i); ii := i;
  4448.         while str[ii] <> _dirslash do inc(ii);
  4449.         inc(ii); delete(str,i,ii-i);
  4450.       end; i := pos(_dirslash,str); delete(str,i,1);
  4451.       __packfil := str
  4452.     end;
  4453.   end;
  4454.  
  4455.  
  4456.  
  4457.   function __reteqfil;
  4458.   var reg: registers;
  4459.        dr: char;
  4460.   begin
  4461.    with reg do begin bl := 1; ah := $44; al := $0e end;
  4462.    intr($21,reg); if reg.al = 0 then dr := drv else dr := chr(64+reg.al);
  4463.    __reteqfil := dr;
  4464.    if reg.al = 0 then errorcode := 2 else begin
  4465.      if drv<>dr then errorcode := 1 else errorcode := 0
  4466.    end;
  4467.   end; {__reteqfil}
  4468.  
  4469.  
  4470.  
  4471.   function __seteqfil(drv: char; var errorcode: byte): char;
  4472.   var reg: registers;
  4473.        dr: char;
  4474.   begin
  4475.    with reg do begin bl := 1; ah := $44; al := $0f end;
  4476.    intr($21, reg); if reg.al = 0 then dr := drv else dr := chr(64+reg.al);
  4477.    __seteqfil := dr;
  4478.    if reg.al = 0 then errorcode := 2 else begin
  4479.      if drv<>dr then errorcode := 1 else errorcode := 0
  4480.    end;
  4481.   end; {__seteqfil}
  4482.  
  4483.  
  4484.  
  4485.   procedure __parsefil(name: filestr; var nam: namestr; var ext: extstr);
  4486.   var p: byte;
  4487.   begin
  4488.     p := pos('.', name); fillchar(nam, 8, ' '); fillchar(ext, 3, ' ');
  4489.     if p = 0 then begin
  4490.       nam := name; ext := '   '
  4491.     end else begin
  4492.       nam := copy(name, 1, p-1);
  4493.       ext := copy(name, p+1, length(name)-p);
  4494.     end;
  4495.   end;
  4496.  
  4497.  
  4498.   function __slashfil;
  4499.   begin
  4500.     s := __cvtstr(__xlatestr(s, '/\', _dirslash+_dirslash), _dircase);
  4501.     __slashfil := s;
  4502.   end;
  4503.  
  4504.  
  4505.   function __normfil(filename : pathstr) : pathstr;
  4506.   const
  4507.     colon   = ':';
  4508.     fslash  = '/';
  4509.     bslash  = '\';
  4510.  
  4511.  
  4512.     procedure getnextdir(
  4513.       filename : pathstr;
  4514.       getdrive : boolean;
  4515.       var startpos : byte;
  4516.       var rettoken : pathstr
  4517.     );
  4518.     var
  4519.       len      : byte;
  4520.       curdrive : char;
  4521.       curdir   : string;
  4522.  
  4523.     begin
  4524.       rettoken := '';
  4525.       if (getdrive) then begin
  4526.         startpos := 1;
  4527.         if ((length(filename) > 1) and (filename[2] = colon)) then begin
  4528.           curdrive := upcase(filename[1]); inc(startpos,2)
  4529.         end else curdrive := __retdrfil;
  4530.         rettoken := curdrive + ':\';
  4531.         if (
  4532.           (startpos > length(filename)) or
  4533.           (
  4534.             (filename[startpos] <> fslash) and
  4535.             (filename[startpos] <> bslash)
  4536.           )
  4537.         ) then begin
  4538.           getdir(byte(curdrive) - 64,curdir);
  4539.           if (ioresult = 0) then rettoken := curdir
  4540.         end
  4541.       end else begin
  4542.         if (startpos > length(filename)) then exit;
  4543.         if (
  4544.           (filename[startpos] = fslash) or
  4545.           (filename[startpos] = bslash)
  4546.         ) then begin
  4547.           len := 1; rettoken[1] := bslash; inc(startpos)
  4548.         end else len := 0;
  4549.         while (
  4550.           (startpos <= length(filename)) and
  4551.           (filename[startpos] <> fslash) and
  4552.           (filename[startpos] <> bslash)
  4553.         ) do begin
  4554.           inc(len);
  4555.           rettoken[len] := upcase(filename[startpos]);
  4556.           inc(startpos)
  4557.         end;
  4558.         rettoken[0] := char(len)
  4559.       end
  4560.     end;   { subproc }
  4561.  
  4562.  
  4563.     procedure putnextdir(
  4564.       token: pathstr;
  4565.       var lastdirpos : byte;
  4566.       var normfile : pathstr
  4567.     );
  4568.     var len : byte;
  4569.     begin
  4570.       if (
  4571.         (token = '.') or (token = '\.') or (length(token) = 0)
  4572.       ) then exit else if ((token = '..') or (token = '\..')) then begin
  4573.         if (lastdirpos > 0) then begin
  4574.           if (lastdirpos = 3) then normfile[0] := char(lastdirpos);
  4575.           dec(lastdirpos);
  4576.           if (lastdirpos > 2) then normfile[0] := char(lastdirpos);
  4577.           while (
  4578.             (lastdirpos >= 1) and
  4579.             (normfile[lastdirpos] <> bslash)
  4580.           ) do dec(lastdirpos)
  4581.         end
  4582.       end else begin
  4583.         len := length(normfile);
  4584.         if ((normfile[len] = bslash) and (token[1] = bslash)) then begin
  4585.           dec(len);
  4586.           normfile[0] := char(len)
  4587.         end else if (
  4588.           (normfile[len] <> bslash) and
  4589.           (token[1] <> bslash)
  4590.         ) then normfile := normfile + bslash;
  4591.         lastdirpos := length(normfile) + 1;
  4592.         normfile   := normfile + token
  4593.       end
  4594.     end;
  4595.  
  4596.  
  4597.   var
  4598.     nextsubdir : byte;
  4599.     lastsubdir : byte;
  4600.     subdir     : pathstr;
  4601.     normalfile : pathstr;
  4602.  
  4603.  
  4604.  
  4605.   begin
  4606.     nextsubdir := 0;
  4607.     getnextdir(filename,true,nextsubdir,normalfile);
  4608.     lastsubdir := length(normalfile) - 1;
  4609.     while (
  4610.       (lastsubdir >= 1) and (normalfile[lastsubdir] <> bslash)
  4611.     ) do dec(lastsubdir);
  4612.     while (nextsubdir <= length(filename)) do begin
  4613.       getnextdir(filename,false,nextsubdir,subdir);
  4614.       putnextdir(subdir,lastsubdir,normalfile);
  4615.     end;
  4616.     __normfil := normalfile
  4617.   end;
  4618.  
  4619.  
  4620.  
  4621.  
  4622.   procedure __splitfil(
  4623.     pathname     :  pathstr;
  4624.     var subdir   :   dirstr;
  4625.     var filename :  namestr;
  4626.     var fileext  :   extstr
  4627.   );
  4628.  
  4629.   const
  4630.     colon   = ':';
  4631.     fslash  = '/';
  4632.     bslash  = '\';
  4633.     period  = '.';
  4634.  
  4635.   var
  4636.     i        : byte;
  4637.     len      : byte;
  4638.     found    : boolean;
  4639.     extpos   : byte;
  4640.     dirpos   : byte;
  4641.     filelen  : byte;
  4642.     thischar : char;
  4643.  
  4644.   begin
  4645.     subdir := ''; filename := ''; fileext := ''; len := length(pathname);
  4646.     found := false; extpos := 0; i := len;
  4647.     while ((not found) and (i >= 1)) do begin
  4648.       thischar := pathname[i];
  4649.       if (thischar = period) then begin
  4650.         found := true;
  4651.         if (
  4652.           (
  4653.             (i > 1) and (pathname[i - 1] <> colon) and
  4654.             (pathname[i - 1] <> period) and (pathname[i - 1] <> fslash) and
  4655.             (pathname[i - 1] <> bslash)
  4656.           ) or
  4657.           (
  4658.             (i < len) and (pathname[i + 1] <> period) and
  4659.             (pathname[i + 1] <> fslash) and (pathname[i + 1] <> bslash)
  4660.           )
  4661.         ) then extpos := i
  4662.       end else dec(i)
  4663.     end;
  4664.     if (extpos > 0) then begin
  4665.       fileext := copy(pathname,extpos,4); i := extpos - 1
  4666.     end else i := len;
  4667.     found := false; dirpos := 0; filelen := 0;
  4668.     while ((not found) and (i >= 1)) do begin
  4669.       thischar := pathname[i];
  4670.       if (
  4671.         (thischar = fslash) or (thischar = bslash) or
  4672.         (thischar = colon) or (thischar = period)
  4673.       ) then begin dirpos := i; found := true end else begin
  4674.         inc(filelen); dec(i)
  4675.       end
  4676.     end;
  4677.     if (filelen > 0) then filename := copy(pathname,dirpos + 1,filelen);
  4678.     if (dirpos > 0) then subdir := copy(pathname,1,dirpos)
  4679.   end;
  4680.  
  4681.  
  4682.  
  4683.  
  4684.  
  4685.  
  4686.   procedure __srec2srec(s: searchrec; var s2: searchrecord);
  4687.   begin
  4688.     with s2 do begin
  4689.       attr := s.attr; time := s.time; size := s.size; name := s.name;
  4690.     end;
  4691.   end;
  4692.  
  4693.  
  4694.  
  4695.   function __searchrec(
  4696.     src                  : searchrec;
  4697.     nm, woord, mainsize  :      word;
  4698.     takemainsize, extended,
  4699.     ampm, show_attr,
  4700.     wide                 :   boolean
  4701.   ): string;
  4702.  
  4703.   const
  4704.     blank  = #32;
  4705.     zero   = #48;
  4706.     period = #46;
  4707.  
  4708.   var
  4709.     i, j     : word;
  4710.     l,
  4711.     tmpstr   : string;
  4712.     ampmch   : string[1];
  4713.     namestr  : string[8];
  4714.     extstr   : string[4];
  4715.     sizestr  : string[26];
  4716.     datestr  : string;
  4717.     hourstr  : string[4];
  4718.     minstr   : string[2];
  4719.     attrstr  : string[18];
  4720.     dt       : datetime;
  4721.  
  4722.  
  4723.   begin {__searchrec}
  4724.     with src do begin
  4725.       fillchar(namestr[1], 8, blank); namestr[0] := #8;
  4726.       fillchar(extstr[1], 4, blank);  extstr[0] := #4;
  4727.       if (name='.') or (name='..') then move(name[1], namestr[1], length(name))
  4728.       else begin
  4729.         {if ((attr and volumeid) <> 0) then j := 1 else j := 2;} j := 2;
  4730.         i := pos('.', name); if (i = 0) then i := succ(length(name))
  4731.         else move(name[succ(i)], extstr[j], length(name) - i);
  4732.         move(name[1], namestr[1], pred(i));
  4733.       end;
  4734.       if (((attr and directory)<>0) and not takemainsize) then
  4735.         sizestr := ' <DIRECTORY> ' else
  4736.         if (((attr and directory)<>0) and takemainsize) then
  4737.           sizestr := '   <DIR>' else
  4738.           if (((attr and volumeid)<>0) and not takemainsize) then
  4739.             sizestr := ' <VOLUMEID>  ' else
  4740.             if (((attr and volumeid)<>0) and takemainsize) then
  4741.               sizestr := '   <VOL>' else
  4742.               if ((size=0) and not takemainsize) then
  4743.                 sizestr := ' <NULFILE>   ' else
  4744.                 if ((size=0) and takemainsize) then
  4745.                   sizestr := '   <NUL>' else
  4746.                   if takemainsize then sizestr := __juststr(
  4747.                     __pntstr(size) + 'K', ' ', 8, _right_just_str
  4748.                   ) else sizestr := __juststr(
  4749.                       __pntstr(size), ' ', 13, _right_just_str
  4750.                     );
  4751.       if extended then begin
  4752.         if (
  4753.           ((attr and directory) <> 0) or ((attr and volumeid) <> 0) or
  4754.           (size = 0)
  4755.         ) then sizestr := sizestr + ' [USED]' else if not takemainsize then
  4756.           sizestr := sizestr + __juststr(
  4757.             __num(__main(size, mainsize) div 1024) + 'K', ' ', 7,
  4758.             _right_just_str
  4759.           );
  4760.       end;
  4761.  
  4762.       unpacktime(time, dt);
  4763.       with dt do begin
  4764.         if extended then datestr := '' else datestr := ' ';
  4765.         if year * month * day <= 0 then
  4766.           datestr := datestr + ' ' + __dt2ststr(1993, 1, 1, woord) else
  4767.           datestr := datestr + ' ' + __dt2ststr(year, month, day, woord);
  4768.         if (hour > 12) and ampm then begin dec(hour, 12); ampmch := 'p' end else
  4769.           if ampm then ampmch := 'a' else ampmch := '';
  4770.         str(hour:4, hourstr); str(min:2, minstr);
  4771.         if (minstr[1] = blank) then minstr[1] := zero
  4772.       end;
  4773.       if not extended then attrstr := '  ' else attrstr := ' ';
  4774.       if show_attr then begin
  4775.         if woord <> 4 then begin
  4776.           if (attr and readonly)>0 then attrstr := attrstr + 'R/O ' else
  4777.             attrstr := attrstr + '    ';
  4778.         end else begin
  4779.           if (attr and readonly)>0 then attrstr := attrstr + 'R' else
  4780.             attrstr := attrstr + ' ';
  4781.         end;
  4782.         if woord <> 4 then begin
  4783.           if (attr and   hidden)>0 then attrstr := attrstr + 'Hid ' else
  4784.             attrstr := attrstr + '    ';
  4785.         end else begin
  4786.           if (attr and   hidden)>0 then attrstr := attrstr + 'H' else
  4787.             attrstr := attrstr + ' ';
  4788.         end;
  4789.         if woord <> 4 then begin
  4790.           if (attr and  sysfile)>0 then attrstr := attrstr + 'Sys ' else
  4791.             attrstr := attrstr + '    ';
  4792.         end else begin
  4793.           if (attr and  sysfile)>0 then attrstr := attrstr + 'S' else
  4794.             attrstr := attrstr + ' ';
  4795.         end;
  4796.         if woord <> 4 then begin
  4797.           if (attr and  archive)>0 then attrstr := attrstr + 'Arc ' else
  4798.             attrstr := attrstr + '    '
  4799.         end else begin
  4800.           if (attr and  archive)>0 then attrstr := attrstr + 'A' else
  4801.             attrstr := attrstr + ' '
  4802.         end;
  4803.       end;
  4804.       if not extended then attrstr := attrstr + ' ';
  4805.       if wide then begin
  4806.         namestr := __nw(namestr); extstr := __nw(extstr);
  4807.       end;
  4808.  
  4809.       if wide and ((attr and directory)=0) then begin
  4810.         tmpstr := __juststr(' ' + namestr + '.'+ extstr, ' ', 16, _left_just_str)
  4811.       end else begin
  4812.         if ((attr and directory) > 0) then begin
  4813.           if wide then tmpstr := __juststr(
  4814.             ' [' + namestr + extstr + ']', ' ', 16, _left_just_str
  4815.           ) else tmpstr := __juststr(
  4816.             ' ' + namestr + extstr, ' ', 14, _left_just_str
  4817.           )
  4818.         end else tmpstr := ' '+ __juststr(namestr, ' ', 8, _left_just_str)+'  '+
  4819.           __juststr(extstr, ' ', 3, _right_just_str);
  4820.       end;
  4821.  
  4822.       l := '';
  4823.       if extended then l := __juststr(__num(nm), ' ', 3, _right_just_str);
  4824.       __searchrec := l + tmpstr + sizestr + datestr + hourstr + ':' +
  4825.         minstr + ampmch + attrstr;
  4826.     end;
  4827.   end;  { __searchrec }
  4828.  
  4829.  
  4830.  
  4831.  
  4832.   function  __sizefil(pt: string): longint;
  4833.   var atri: searchrec;
  4834.   begin
  4835.     findfirst(pt, anyfile, atri);
  4836.     __sizefil := atri.size;
  4837.   end;
  4838.  
  4839.  
  4840.  
  4841.  
  4842.   function  __strattr(attr: byte; full: boolean): string;
  4843.   type
  4844.     filterenum = (r_o, hid, sys, vol, dir, arc, bit6, bit7);
  4845.     fs = set of filterenum;
  4846.  
  4847.   const
  4848.     ats: array[filterenum] of string[9] = (
  4849.       'ReadOnly',  'Hidden',    'System',
  4850.       'VolumeID',  'Directory', 'Archive',
  4851.       'Only',      'NotNone'
  4852.     );
  4853.  
  4854.   var
  4855.     st     : string;
  4856.     len    :   byte;
  4857.     filter :     fs;
  4858.  
  4859.   begin
  4860.     filter := fs(attr); st := '';
  4861.     if full then len := 9 else len := 1;
  4862.     if r_o in filter then st := st +        copy(ats[r_o], 1, len);
  4863.     if hid in filter then st := st + ', ' + copy(ats[hid], 1, len);
  4864.     if sys in filter then st := st + ', ' + copy(ats[sys], 1, len);
  4865.     if vol in filter then st := st + ', ' + copy(ats[vol], 1, len);
  4866.     if dir in filter then st := st + ', ' + copy(ats[dir], 1, len);
  4867.     __strattr := st;
  4868.   end;
  4869.  
  4870.  
  4871.  
  4872.   procedure __uniquefil(               { i.s.o. __tempfil, an unique textfile }
  4873.     var pathname: string; var tmpfile: text; var errorcode: word
  4874.   );
  4875.   var
  4876.     pathz   : pathstr;                             { asciiz string for pathname }
  4877.     pathlen : byte;
  4878.     reg     : registers;
  4879.     frec    : textrec;
  4880.  
  4881.   begin
  4882.     pathlen := length(pathname);
  4883.     if (pathname[pathlen] <> _dirslash) then begin { must have a trailing backslash }
  4884.       pathname := pathname + _dirslash; inc(pathlen)
  4885.     end;
  4886.     pathname := __normfil(pathname);
  4887.     move(pathname[1],pathz,pathlen);
  4888.     pathz[pathlen] := #0;
  4889.     with reg do begin                              { call dos function $5a    }
  4890.       ax := $5a00; ds := seg(pathz); dx := ofs(pathz); cx := {fileattr} 0;
  4891.       intr($21,reg);
  4892.       if ((flags and fcarry) <> 0) then errorcode := ax else with frec do begin
  4893.         fillchar(frec, sizeof(frec), #0);
  4894.         errorcode := 0;
  4895.         mode := fminout;
  4896.         (*recsize := {rsize} 1;*)
  4897.         handle := ax;                                  { the dos file handle  }
  4898.         move(pathz,pathname[1],67);                { return new file path name}
  4899.         move(pathz,name,67);
  4900.         pathname[0] := #67;                        { search for the nul  byte }
  4901.         pathname[0] := chr(pos(#0,pathname));                { and set length }
  4902.         textrec(tmpfile) := frec
  4903.       end;
  4904.     end;
  4905.   end; { __uniquefil }
  4906.  
  4907.  
  4908.   {$I-}
  4909.   function __copyfil(show: boolean; x1,x2,y,f,b: byte; fs: longint; src, targ: string): byte;
  4910.   {
  4911.    return codes:
  4912.      0 successful
  4913.      1 source and target the same
  4914.      2 cannot open source
  4915.      3 unable to create target
  4916.      4 error during copy
  4917.      5 cannot allocate buffer
  4918.   }
  4919.   const
  4920.     bufsize = 16384;
  4921.  
  4922.   type
  4923.     fbuf = array[1..bufsize] of char;
  4924.     fbf  = ^fbuf;
  4925.  
  4926.   var
  4927.     source,
  4928.     target   :    file;
  4929.     bread,
  4930.     bwrite   :    word;
  4931.     filebuf  :    ^fbf;
  4932.     tr       : longint;
  4933.     nr       :    real;
  4934.  
  4935.   begin
  4936.     if memavail > bufsize then new(filebuf) else begin __copyfil := 5; exit end;
  4937.     if src = targ then begin __copyfil := 1; exit end;
  4938.     assign(source, src); reset(source,1);
  4939.     if ioresult <> 0 then begin __copyfil := 2; exit end;
  4940.     assign(target, targ); rewrite(target,1);
  4941.     if ioresult <> 0 then begin __copyfil := 3; exit end;
  4942.     if show then __write(x1+2,y,f,b,__rep(x2-x1-3,'░')); tr := 0;
  4943.     repeat
  4944.       blockread(source,filebuf^,bufsize,bread);
  4945.       tr := tr + bread; nr := tr/fs;
  4946.       nr := nr * (x2-x1-3);
  4947.       if show then __write(x1+2,y,f,b,__rep(trunc(nr), '█'));
  4948.       blockwrite(target,filebuf^,bread,bwrite);
  4949.     until (bread = 0) or (bread <> bwrite);
  4950.     if show then __write(x1+2,y,f,b,__rep((x2-x1-3),'█'));
  4951.     close(source); close(target);
  4952.     if bread <> bwrite then __copyfil := 4 else __copyfil := 0;
  4953.   end;
  4954.   {$I-}
  4955.  
  4956.  
  4957.   procedure __renamfil(prevname,newname : pathstr; var errorcode : word);
  4958.   var
  4959.     pathlen : integer;
  4960.     reg     : registers;
  4961.  
  4962.   begin
  4963.     pathlen := length(prevname);           { first transform to asciiz  }
  4964.     move(prevname[1],prevname[0],pathlen); { strings (i.e., trailing    }
  4965.     prevname[pathlen] := #0;               { nul byte).                 }
  4966.     pathlen := length(newname);
  4967.     move(newname[1],newname[0],pathlen);
  4968.     newname[pathlen] := #0;
  4969.  
  4970.     with reg do begin
  4971.       ax := $5600;
  4972.       ds := seg(prevname);           { pointers to the previous and   }
  4973.       dx := ofs(prevname);           { new asciiz strings             }
  4974.       es := seg(newname);
  4975.       di := ofs(newname);
  4976.       intr($21, reg);
  4977.       if ((flags and fcarry) <> 0) then errorcode := ax else errorcode := 0
  4978.     end
  4979.   end;
  4980.  
  4981.  
  4982.   function __slicefil(
  4983.     x1, x2, y, f, b: byte; haksize: longint; src: string
  4984.   ): byte;
  4985.   {
  4986.    return codes:
  4987.      0 successful
  4988.      1 source and target the same
  4989.      2 cannot open source
  4990.      3 unable to create target
  4991.      4 error during copy
  4992.      5 cannot allocate buffer
  4993.   }
  4994.   const
  4995.     bufsize = 16384;
  4996.     max360  = 0360000;
  4997.     max720  = 0720000;
  4998.     max1200 = 1220000;
  4999.     max1440 = 1440000;
  5000.     max2880 = 2880000;
  5001.  
  5002.  
  5003.   type
  5004.     fbuf = array[1..bufsize] of char;
  5005.     fbf  = ^fbuf;
  5006.     str3 = string[3];
  5007.  
  5008.   var
  5009.     source,
  5010.     target       :    file;
  5011.     bread,
  5012.     bwrite       :    word;
  5013.     filebuf      :    ^fbf;
  5014.     maxondisc,
  5015.     sessionread,
  5016.     vn, tr, fs   : longint;
  5017.     nr           :    real;
  5018.     targ         :  string;
  5019.  
  5020.  
  5021.     function __volgnum(l: longint): str3;
  5022.     begin
  5023.       __volgnum := __juststr(__num(l), '0', 3, _right_just_str)
  5024.     end;
  5025.  
  5026.  
  5027.   begin
  5028.     src := __normfil(src); fs := __sizefil(src); targ := __extractname(src);
  5029.     if diskfree(byte(src[1])-byte('A')+1)<fs then begin __slicefil := 6; exit end;
  5030.     if haksize = 360 then maxondisc := max360;
  5031.     if haksize = 720 then maxondisc := max720;
  5032.     if haksize = 1200 then maxondisc := max1200;
  5033.     if haksize = 1440 then maxondisc := max1440;
  5034.     if haksize = 2880 then maxondisc := max2880;
  5035.     if haksize = 0 then maxondisc := max1440 else maxondisc := __main(haksize, 16384);
  5036.     if memavail > bufsize then new(filebuf) else begin __slicefil := 5; exit end;
  5037.     if src = targ then begin __slicefil := 1; exit end;
  5038.     assign(source, src); reset(source,1);
  5039.     if ioresult <> 0 then begin __slicefil := 2; exit end;
  5040.     __write(x1,y,f,b,__rep(x2-x1-1,'░'));
  5041.     tr := 0; { keeps track on total bytes written for statusbar }
  5042.     vn := 1; { virtual number for numbering the chunks }
  5043.     repeat
  5044.       assign(target, targ + '.' + __volgnum(vn)); rewrite(target,1);
  5045.       if ioresult <> 0 then begin __slicefil := 3; exit end;
  5046.       sessionread := 0; { keeps track on bytes written to ONE CHUNK }
  5047.       __write(50, y, f, b, 'Writing chunk ' + targ + '.' + __volgnum(vn));
  5048.       repeat
  5049.         blockread(source,filebuf^,bufsize,bread);
  5050.         inc(sessionread, bread); inc(tr, bread); nr := tr/fs;
  5051.         nr := nr * (x2-x1-3);
  5052.         __write(x1, y, f, b, __rep(trunc(nr), '█'));
  5053.         blockwrite(target,filebuf^,bread,bwrite);
  5054.       until (bread = 0) or (bread <> bwrite) or (sessionread >= maxondisc);
  5055.       inc(vn);
  5056.       close(target);
  5057.     until (bread = 0) or (bread <> bwrite);
  5058.     __write(x1, y, f, b, __rep((x2-x1-1),'█'));
  5059.     close(source);
  5060.     if bread <> bwrite then __slicefil := 4 else __slicefil := 0;
  5061.   end;
  5062.   {$I-}
  5063.  
  5064.  
  5065.  
  5066.   { $ L rdsector}
  5067.   procedure rdsector(driveno : word; var errorcode : word); external;
  5068.  
  5069.   function  __isdrvfil(drive : char; var errorcode : word) : boolean;
  5070.   const
  5071.     needtoread = 99;
  5072.  
  5073.   var
  5074.     driveno    : word;
  5075.     lastdrive  : word;
  5076.     reg        : registers;
  5077.  
  5078.   begin
  5079.     with reg do begin
  5080.       ah := $19;
  5081.       intr($21, reg);
  5082.  
  5083.       ah := $0e;
  5084.       dl := al;
  5085.       intr($21, reg);
  5086.       dec(al);
  5087.       lastdrive := al
  5088.     end;
  5089.  
  5090.     driveno := word(upcase(drive)) - word('A');
  5091.     if (driveno > lastdrive) then errorcode := 1 else begin
  5092.       errorcode := needtoread;
  5093.       if (_dosmajorver >= 3) then with reg do begin
  5094.         ah := $44;
  5095.         al := $08;
  5096.         bl := driveno + 1;
  5097.         intr($21, reg);
  5098.         if ((flags and fcarry = 0) and (ax = 1)) then errorcode := 0;
  5099.       end;
  5100.       if (errorcode = needtoread) then begin
  5101.         rdsector(driveno,errorcode);
  5102.         if (errorcode <> 0) then if (errorcode = $0207) then begin
  5103.           if (_dosmajorver >= 4) then errorcode := 0 else
  5104.             if (
  5105.               {(_compaq) and} (_dosmajorver >=3 ) and (_dosminorver >= 31)
  5106.             ) then errorcode := 0 else errorcode := 3
  5107.         end else if (errorcode = $8002) then errorcode := 2 else
  5108.           if (errorcode = driveno) then errorcode := 1 else
  5109.             if (errorcode >= 3) then errorcode := 3;
  5110.       end
  5111.     end;
  5112.     __isdrvfil := (errorcode = 0)
  5113.   end;
  5114.  
  5115.  
  5116.  
  5117.   function  __retdtfil : pointer;
  5118.   var reg : registers;
  5119.   begin
  5120.     with reg do begin
  5121.       ah := $2f;
  5122.       intr($21, reg);
  5123.       __retdtfil := ptr(es,bx)
  5124.     end
  5125.   end;
  5126.  
  5127.  
  5128.   procedure __setdtfil(dtaaddress : pointer);
  5129.   var reg : registers;
  5130.   begin
  5131.     with reg do begin
  5132.       ah := $1a;
  5133.       ds := _vectoraddr(dtaaddress)._seg;
  5134.       dx := _vectoraddr(dtaaddress)._ofs
  5135.     end;
  5136.     intr($21, reg)
  5137.   end;
  5138.  
  5139.   function __retvlfil(drive : char; var volstamp : longint) : string;
  5140.   var
  5141.     extendedfcb : array[-7..36] of byte;
  5142.     dtaptr      :               pointer;
  5143.     tempdta     :  array[0..44] of byte;
  5144.     driveno     :                  byte;
  5145.     volname     :                string;
  5146.     reg         :             registers;
  5147.  
  5148.   begin
  5149.     dtaptr  := __retdtfil;
  5150.     __setdtfil(@tempdta);
  5151.     driveno := byte(upcase(drive)) - byte('A') + 1;
  5152.     extendedfcb[-7] := $ff;
  5153.     extendedfcb[-1] := $08;
  5154.     extendedfcb[0]  := driveno;
  5155.     fillchar(extendedfcb[1],11,$3f);
  5156.     fillchar(extendedfcb[12],25,0);
  5157.  
  5158.     with reg do begin
  5159.       ah := $11;
  5160.       ds := seg(extendedfcb);
  5161.       dx := ofs(extendedfcb);
  5162.       intr($21, reg);
  5163.       if (al = $ff) then begin
  5164.         volstamp   := 0;
  5165.         __retvlfil := ''
  5166.       end else begin
  5167.         move(tempdta,extendedfcb[-7],39);
  5168.         move(extendedfcb[1],volname[1],11);
  5169.         volname[0] := #11;
  5170.         __retvlfil := volname;
  5171.         move(extendedfcb[23],volstamp,4);
  5172.       end
  5173.     end;
  5174.     __setdtfil(dtaptr)
  5175.   end;
  5176.  
  5177.  
  5178.  
  5179.   function __handlfil(var filevar) : word;
  5180.   begin
  5181.     if (filerec(filevar).mode = fmclosed) then __handlfil := $ffff else
  5182.       __handlfil := filerec(filevar).handle
  5183.   end;
  5184.  
  5185.  
  5186.   function  __isconfil(handle : word) : boolean;
  5187.   var reg : registers;
  5188.   begin
  5189.     with reg do begin
  5190.       ah := $44;
  5191.       al := 0;
  5192.       bx := handle;
  5193.       intr($21,reg);
  5194.       __isconfil := ((dl and $80) <> 0) and ((dl and $03) <> 0)
  5195.     end
  5196.   end;
  5197.  
  5198.  
  5199.  
  5200.  
  5201.  
  5202.   {$F+}
  5203.   function callcondition(var search): boolean;
  5204.   inline($ff/$1e/conditionfuncptr_);
  5205.  
  5206.  
  5207.  
  5208.   {$F+}
  5209.   function no_condition(var srec): boolean;
  5210.   begin
  5211.     no_condition := true;
  5212.   end;
  5213.  
  5214.  
  5215.  
  5216.   {$F+}
  5217.   function std_condition(var srec): boolean;
  5218.   var sr: searchrec;
  5219.   begin
  5220.     sr := searchrec(srec);
  5221.     with std_condition_attrs do std_condition := (
  5222.       (show_r_o or not((sr.attr and readonly ) > 0)) and
  5223.       (show_hid or not((sr.attr and hidden   ) > 0)) and
  5224.       (show_sys or not((sr.attr and sysfile  ) > 0)) and
  5225.       (show_arc or not((sr.attr and archive  ) > 0)) and
  5226.       (show_vol or not((sr.attr and volumeid ) > 0)) and
  5227.       (show_dir or not((sr.attr and directory) > 0)) and
  5228.       (show_non or (
  5229.           ((sr.attr and readonly) > 0) or
  5230.           ((sr.attr and hidden  ) > 0) or
  5231.           ((sr.attr and archive ) > 0) or
  5232.           ((sr.attr and sysfile ) > 0)
  5233.         )
  5234.       )
  5235.     );
  5236.   end; { std_conditio }
  5237.  
  5238.  
  5239.  
  5240.   {$F+}
  5241.   function std_sort(var data1, data2): boolean;
  5242.   var
  5243.     st1, st2: string[3];
  5244.     in1, in2:   integer;
  5245.     dt1, dt2:  datetime;
  5246.     li1, li2:   longint;
  5247.     sr1, sr2: searchrec;
  5248.  
  5249.   begin
  5250.     sr1 := searchrec(pointer(data1)^);
  5251.     sr2 := searchrec(pointer(data2)^);
  5252.     if (
  5253.       ((sr1.attr and volumeid) > 0) and
  5254.       not( (sr2.attr and volumeid) > 0 )
  5255.     ) then std_sort := true else if (
  5256.       ((sr1.attr and directory) > 0) and
  5257.       not( (sr2.attr and directory) > 0 )
  5258.     ) then std_sort := true else if (
  5259.       not( (sr1.attr and directory) > 0) and
  5260.       ((sr2.attr and directory) > 0 )
  5261.     ) then std_sort := false else if (
  5262.       ((sr1.attr and directory) > 0) and
  5263.       ((sr2.attr and directory) > 0)
  5264.     ) then std_sort := (sr1.name < sr2.name) else
  5265.     case std_condition_attrs.sort_method of
  5266.       on_name: std_sort := sr1.name < sr2.name;
  5267.       on_extension: if __comp(
  5268.         __extractext(sr1.name), __extractext(sr2.name)
  5269.       ) then std_sort := sr1.name < sr2.name else if (
  5270.         (__extractext(sr1.name) <> '') and (__extractext(sr2.name) <> '')
  5271.       ) then std_sort := (__extractext(sr1.name) < __extractext(sr2.name)) else
  5272.         if not __comp(__extractext(sr1.name), '') then std_sort := true else
  5273.           std_sort := false;
  5274.       on_datetime: begin { by date and time }
  5275.         unpacktime(sr1.time, dt1); unpacktime(sr2.time, dt2);
  5276.         li1 := __dt2jlutl(dt1.year, dt1.month, dt1.day);
  5277.         li2 := __dt2jlutl(dt2.year, dt2.month, dt2.day);
  5278.         if li1 <> li2 then std_sort := li1 < li2 else std_sort := (
  5279.           (dt1.hour*10000 + dt1.min*100 + dt1.sec) <
  5280.           (dt2.hour*10000 + dt2.min*100 + dt2.sec)
  5281.         );
  5282.       end;
  5283.       on_size: std_sort := sr1.size < sr2.size; { by size }
  5284.     end; { case }
  5285.   end; { std_sort }
  5286.   {$F-}
  5287.  
  5288.  
  5289.  
  5290.   procedure new_filarray(var fil: filarraytypeptr);
  5291.   var i : word;
  5292.   begin
  5293.     new(fil); for i := 1 to maxfiles do fil^[i] := nil;
  5294.   end;
  5295.  
  5296.  
  5297.   procedure dispose_filarray(var fil: filarraytypeptr);
  5298.   var i : word;
  5299.   begin
  5300.     for i := 1 to maxfiles do begin
  5301.       {writeln(__ptr2str(fil^[i]));}
  5302.       if fil^[i] <> nil then dispose(fil^[i]);
  5303.     end;
  5304.     dispose(fil);
  5305.   end;
  5306.  
  5307.  
  5308.   {$F+}
  5309.   procedure set_std_condition_attrs(attrs: condition_attrstype);
  5310.   begin
  5311.     std_condition_attrs := attrs;
  5312.   end;
  5313.  
  5314.  
  5315.   procedure __dirutl;
  5316.   const
  5317.     no_error      = 0;
  5318.     invalid_path  = 3;
  5319.     mem_error     = 8;
  5320.     no_more_files = 18;
  5321.  
  5322.   var
  5323.     srec : searchrec;
  5324.     i    :      word;
  5325.     tt   :   longint;
  5326.  
  5327.   begin
  5328.     tt := 0;
  5329.     if condit = nil then conditionfuncptr_ := @no_condition else
  5330.       conditionfuncptr_ := condit;
  5331.     filitems := 0; vol_counted := false; error := 0;
  5332.  
  5333.     findfirst(searchpath, searchattr, srec);
  5334.     if (doserror = invalid_path) then begin
  5335.       error := invalid_path; exit
  5336.     end else if (doserror = no_more_files) then exit;
  5337.  
  5338.     tt := 0; counted_dirs := 0;
  5339.  
  5340.     while (doserror = 0) do begin
  5341.       if (
  5342.         (comexebatcmdfilter and __comexebatcmdfilter(srec.name)) or
  5343.         (not comexebatcmdfilter)
  5344.       ) then begin
  5345.         if callcondition(srec) then begin
  5346.           if not(
  5347.             ((srec.attr and volumeid) > 0) or
  5348.             ((srec.attr and directory) > 0)
  5349.           ) then begin
  5350.             if (
  5351.               manipulate = _to_lowcase_str
  5352.             ) then srec.name := __lo(srec.name) else if (
  5353.               manipulate = _to_upcase_str
  5354.             ) then srec.name := __up(srec.name);
  5355.             tt := tt + srec.size;
  5356.           end else srec.name := __up(srec.name);
  5357.           inc(filitems); if renew_space then new(filar^[filitems]);
  5358.           filar^[filitems]^ := srec;
  5359.           if ((srec.attr and volumeid) > 0) then vol_counted := true;
  5360.           if ((srec.attr and directory) > 0) then inc(counted_dirs);
  5361.         end; { test condition, if ok, get it }
  5362.       end;
  5363.       findnext(srec);
  5364.     end;
  5365.     totnum := tt;
  5366.  
  5367.     if sorter <> nil then __qsortsrt(
  5368.       filar, filitems, sizeof(pointer), sorter
  5369.     );
  5370.   end; { __dirutl }
  5371.  
  5372.  
  5373.  
  5374.  
  5375.  
  5376.  
  5377.   procedure addtogethertwotimerecords(
  5378.     timerecordone : timerecord;
  5379.     timerecordtwo : timerecord;
  5380.     var resultrecord  : timerecord
  5381.   ); {this is an internal procedure.}
  5382.   begin {additionoftwotimes}
  5383.     resultrecord.hundredth := (timerecordone.hundredth+timerecordtwo.hundredth);
  5384.     resultrecord.second    := (timerecordone.second   +timerecordtwo.second);
  5385.     resultrecord.minute    := (timerecordone.minute   +timerecordtwo.minute);
  5386.     resultrecord.hour      := (timerecordone.hour     +timerecordtwo.hour);
  5387.     while (resultrecord.hundredth >= 100) do begin
  5388.       dec(resultrecord.hundredth,100); inc(resultrecord.second)
  5389.     end;
  5390.     while (resultrecord.second >= 60) do begin
  5391.       dec(resultrecord.second,60); inc(resultrecord.minute)
  5392.     end;
  5393.     while (resultrecord.minute >= 60) do begin
  5394.       dec(resultrecord.minute,60); inc(resultrecord.hour)
  5395.     end
  5396.   end;
  5397.  
  5398.  
  5399.  
  5400.   procedure addonedaytodate(var thedaterecord : daterecord);
  5401.   begin
  5402.     with thedaterecord do begin
  5403.       inc(date);
  5404.       case month of
  5405.         1,3,5,7,8,10,12: if (date > 31) then begin dec(date,31); inc(month) end;
  5406.         4, 6, 9, 11    : if (date > 30) then begin dec(date,30); inc(month) end;
  5407.         2 : if (date > 29) then begin dec(date,29); month := 3 end else
  5408.           if (
  5409.             (date > 28) and not (((year mod 4) = 0) and
  5410.             (((year mod 100) <> 0) or ((year mod 400) = 0)))
  5411.           ) then begin dec(date,28); month := 3 end
  5412.       end; {case month}
  5413.       while (month > 12) do begin dec(month,12); inc(year) end;
  5414.       inc(dayofweek); dayofweek := (dayofweek mod 7)
  5415.     end {with thedaterec}
  5416.   end;
  5417.  
  5418.  
  5419.  
  5420.   function juliandate(thedate : daterecord) : longint;
  5421.   var templongint : longint;
  5422.   begin
  5423.     templongint := thedate.year;
  5424.     templongint := (templongint * 1000);
  5425.     case thedate.month of
  5426.       02 : inc(templongint,31);
  5427.       03 : inc(templongint,59);
  5428.       04 : inc(templongint,90);
  5429.       05 : inc(templongint,120);
  5430.       06 : inc(templongint,151);
  5431.       07 : inc(templongint,181);
  5432.       08 : inc(templongint,212);
  5433.       09 : inc(templongint,243);
  5434.       10 : inc(templongint,273);
  5435.       11 : inc(templongint,304);
  5436.       12 : inc(templongint,334)
  5437.     end; {case daterecord.month}
  5438.     if (((thedate.year mod 4) = 0) and (thedate.month > 2)) then
  5439.       if (((thedate.year mod 100) <> 0) or ((thedate.year mod 400) = 0))
  5440.         then inc(templongint); {add a day for leapyears}
  5441.     templongint := (templongint + thedate.date);
  5442.     juliandate := templongint
  5443.   end;
  5444.  
  5445.  
  5446.  
  5447.   procedure subtractonedayfromdate(var thedaterecord : daterecord);
  5448.   begin
  5449.     with thedaterecord do begin
  5450.       if date = 1 then begin
  5451.         if month = 1 then begin dec(year); month := 12; date := 31 end else begin
  5452.           dec(month);
  5453.           case month of
  5454.             1, 3, 5, 7, 8, 10, 12 : date := 31;
  5455.             4, 6, 9, 11           : date := 30;
  5456.             2 : if (((year mod 4) = 0) and
  5457.                    (((year mod 100) <> 0) or ((year mod 400) = 0)))
  5458.                  then date := 29 else date := 28
  5459.           end {case month}
  5460.         end
  5461.       end else dec(date);
  5462.       if (dayofweek = 0) then dayofweek := 6 else dec(dayofweek)
  5463.     end {with thedaterec}
  5464.   end;
  5465.  
  5466.  
  5467.  
  5468.  
  5469.   function  converttimetostring(thetimerec : timerecord) : string;
  5470.   var
  5471.     tempstring1 : string;
  5472.     tempstring2 : string;
  5473.     index       :   byte;
  5474.  
  5475.   begin
  5476.     str(thetimerec.hour:2,{var} tempstring1);
  5477.     str(thetimerec.minute:2,{var} tempstring2);
  5478.     tempstring1 := (tempstring1 + colon + tempstring2);
  5479.     str(thetimerec.second:2,{var} tempstring2);
  5480.     tempstring1 := (tempstring1 + period + tempstring2);
  5481.     str(thetimerec.hundredth:2,{var} tempstring2);
  5482.     tempstring1 := (tempstring1 + separ + tempstring2);
  5483.     for index := 1 to length(tempstring1) do
  5484.       if (tempstring1[index] = space) then tempstring1[index] := zero;
  5485.     converttimetostring := tempstring1
  5486.   end;
  5487.  
  5488.  
  5489.  
  5490.  
  5491.   function  datesareequal(
  5492.     daterecord1 : daterecord;
  5493.     daterecord2 : daterecord
  5494.   ) : boolean;
  5495.   begin
  5496.     if (
  5497.       (daterecord1.date = daterecord2.date) and
  5498.       (daterecord1.month = daterecord2.month) and
  5499.       (daterecord1.year = daterecord2.year)
  5500.     ) then datesareequal := true else datesareequal := false
  5501.   end;
  5502.  
  5503.  
  5504.  
  5505.  
  5506.   function  juliantime(timerecord : timerecord) : longint;
  5507.   var
  5508.     templongint  : longint;
  5509.     tempvariable : longint;
  5510.  
  5511.   begin
  5512.     templongint  := timerecord.hour;
  5513.     templongint  := (templongint * 1000000);
  5514.     tempvariable := timerecord.minute;
  5515.     templongint  := (
  5516.       templongint + (tempvariable * 10000) + (timerecord.second * 100) +
  5517.       timerecord.hundredth
  5518.     );
  5519.     juliantime := templongint
  5520.   end;
  5521.  
  5522.  
  5523.  
  5524.  
  5525.   procedure determinelengthbetweentwodatetimes(
  5526.     startdaterecord       : daterecord;
  5527.     starttimerecord       : timerecord;
  5528.     enddaterecord         : daterecord;
  5529.     endtimerecord         : timerecord;
  5530.     var elapsedtimerecord : timerecord
  5531.   );
  5532.   var julianenddate : longint;
  5533.   begin
  5534.     with elapsedtimerecord do begin
  5535.       hour := 0; minute := 0; second := 0; hundredth := 0
  5536.     end;
  5537.     if (
  5538.       (juliandate(startdaterecord) > juliandate(enddaterecord)) or
  5539.       (datesareequal(startdaterecord,enddaterecord) and
  5540.       (juliantime(starttimerecord) > juliantime(endtimerecord)))
  5541.     ) then addonedaytodate({var} enddaterecord);
  5542.     while (endtimerecord.hundredth < starttimerecord.hundredth) do begin
  5543.       inc(endtimerecord.hundredth,100);
  5544.       if (endtimerecord.second = 0) then begin
  5545.         endtimerecord.second := 59;
  5546.         if (endtimerecord.minute = 0) then begin
  5547.           endtimerecord.minute := 59;
  5548.           if (endtimerecord.hour = 0) then begin
  5549.             endtimerecord.hour := 23;
  5550.             subtractonedayfromdate(enddaterecord)
  5551.           end else dec(endtimerecord.hour)
  5552.         end else dec(endtimerecord.minute)
  5553.       end else dec(endtimerecord.second)
  5554.     end;
  5555.     elapsedtimerecord.hundredth := (
  5556.       endtimerecord.hundredth - starttimerecord.hundredth
  5557.     );
  5558.     while (endtimerecord.second < starttimerecord.second) do begin
  5559.       inc(endtimerecord.second,60);
  5560.       if (endtimerecord.minute = 0) then begin
  5561.         endtimerecord.minute := 59;
  5562.         if (endtimerecord.hour = 0) then begin
  5563.           endtimerecord.hour := 23;
  5564.           subtractonedayfromdate(enddaterecord)
  5565.         end else dec(endtimerecord.hour)
  5566.       end else dec(endtimerecord.minute)
  5567.     end;
  5568.  
  5569.     elapsedtimerecord.second := (endtimerecord.second - starttimerecord.second);
  5570.     while (endtimerecord.minute < starttimerecord.minute) do begin
  5571.       inc(endtimerecord.minute,60);
  5572.       if (endtimerecord.hour = 0) then begin
  5573.         endtimerecord.hour := 23;
  5574.         subtractonedayfromdate(enddaterecord)
  5575.       end else dec(endtimerecord.hour)
  5576.     end;
  5577.     elapsedtimerecord.minute := (endtimerecord.minute - starttimerecord.minute);
  5578.     while (endtimerecord.hour < starttimerecord.hour) do begin
  5579.       inc(endtimerecord.hour,24);
  5580.       subtractonedayfromdate(enddaterecord)
  5581.     end; {while (endtimerecord.hour < starttimerecord.hour)}
  5582.     elapsedtimerecord.hour := (endtimerecord.hour - starttimerecord.hour);
  5583.     julianenddate := juliandate(enddaterecord);
  5584.     while (juliandate(startdaterecord) <> julianenddate) do begin
  5585.       inc(elapsedtimerecord.hour,24);
  5586.       addonedaytodate({var} startdaterecord)
  5587.     end
  5588.   end;
  5589.  
  5590.  
  5591.  
  5592.  
  5593.   procedure starttimer (whichclock : byte);
  5594.   begin {starttimer}
  5595.     if (whichclock = 0) then exit else {can't reset the program-timer clock!}
  5596.     with clockarray[whichclock] do begin
  5597.       with clockstartdate do getdate({var} year,month,date,dayofweek);
  5598.       with clockstarttime do gettime({var} hour,minute,second,hundredth);
  5599.       with elapsedtime do begin
  5600.         hour := 0; minute := 0; second := 0; hundredth := 0
  5601.       end;
  5602.       clockisrunning := true
  5603.     end
  5604.   end;
  5605.  
  5606.  
  5607.  
  5608.  
  5609.   function  getlaptime (whichclock : byte) : string;
  5610.   var
  5611.     currentdate : daterecord;
  5612.     currenttime : timerecord;
  5613.     elapsedtime : timerecord;
  5614.     tempstring  : string[3];
  5615.  
  5616.   begin
  5617.     with currentdate do getdate({var} year,month,date,dayofweek);
  5618.     with currenttime do gettime({var} hour,minute,second,hundredth);
  5619.     fillchar(elapsedtime,sizeof(elapsedtime),nullchar);
  5620.     str(whichclock,{var} tempstring);
  5621.  
  5622.     determinelengthbetweentwodatetimes(
  5623.       clockarray[whichclock].clockstartdate,
  5624.       clockarray[whichclock].clockstarttime,
  5625.       currentdate, currenttime,
  5626.       {var} elapsedtime
  5627.     );
  5628.     addtogethertwotimerecords(
  5629.       elapsedtime, clockarray[whichclock].elapsedtime, {var} elapsedtime
  5630.     );
  5631.     getlaptime := converttimetostring(elapsedtime)
  5632.   end;
  5633.  
  5634.  
  5635.  
  5636.  
  5637.   procedure restarttimer (whichclock : byte);
  5638.   begin
  5639.     with clockarray[whichclock] do begin
  5640.       with clockstartdate do getdate({var} year,month,date,dayofweek);
  5641.       with clockstarttime do gettime({var} hour,minute,second,hundredth);
  5642.       clockisrunning := true
  5643.     end
  5644.   end;
  5645.  
  5646.  
  5647.  
  5648.  
  5649.  
  5650.   function  stoptimer (whichclock : byte) : string;
  5651.   const cantstopclockzerotext = 'Can''t stop clock #0!';
  5652.   var
  5653.     currentdate : daterecord;
  5654.     currenttime : timerecord;
  5655.     elapsedtime : timerecord;
  5656.     tempstring  : string[3];
  5657.  
  5658.   begin
  5659.     if (
  5660.       (whichclock = 0) or (not clockarray[whichclock].clockisrunning)
  5661.     ) then stoptimer := (cantstopclockzerotext) else begin
  5662.       with currentdate do getdate({var} year,month,date,dayofweek);
  5663.       with currenttime do gettime({var} hour,minute,second,hundredth);
  5664.       fillchar(elapsedtime,sizeof(elapsedtime),nullchar);
  5665.       str(whichclock,{var} tempstring);
  5666.  
  5667.       determinelengthbetweentwodatetimes(
  5668.         clockarray[whichclock].clockstartdate,
  5669.         clockarray[whichclock].clockstarttime,
  5670.         currentdate, currenttime, {var} elapsedtime
  5671.       );
  5672.  
  5673.       addtogethertwotimerecords(
  5674.         elapsedtime, clockarray[whichclock].elapsedtime,
  5675.         {var} clockarray[whichclock].elapsedtime
  5676.       );
  5677.  
  5678.       clockarray[whichclock].clockisrunning := false;
  5679.       stoptimer := converttimetostring(elapsedtime)
  5680.     end
  5681.   end;
  5682.  
  5683.  
  5684.  
  5685.   procedure __setpurge(b: byte);
  5686.   begin
  5687.     purge := b - 1;
  5688.   end;
  5689.  
  5690.  
  5691.  
  5692.   procedure __filapp(fil, s : string);
  5693.   var
  5694.     i       : byte;
  5695.     logfile : text;
  5696.  
  5697.   begin
  5698.     {$I-}
  5699.     assign(logfile, fil);
  5700.     if __existfil(fil) then append(logfile) else rewrite(logfile);
  5701.     writeln(logfile, s); close(logfile);
  5702.     {$I+}
  5703.   end; { __filapp }
  5704.  
  5705.  
  5706.  
  5707.   procedure __logapp(s: string);
  5708.   var
  5709.     i       : byte;
  5710.     logfile : text;
  5711.  
  5712.   begin
  5713.     assign(logfile, logfilename);
  5714.     if __existfil(logfilename) then append(logfile) else begin
  5715.       rewrite(logfile);
  5716.       for i := 1 to 11 do writeln(logfile, logheader[i]);
  5717.       writeln(logfile);
  5718.       writeln(logfile, __curdate + '  LOGfile for ' + programname + ' created.');
  5719.       writeln(logfile); writeln(logfile);
  5720.     end;
  5721.     if s<>'' then writeln(logfile, __curdate + '  ' + s) else writeln(logfile);
  5722.     close(logfile);
  5723.   end; { __logapp }
  5724.  
  5725.  
  5726.  
  5727.   function __recent(s: string): boolean;
  5728.   var                                           { 27 Jul 91  08:34.12 }
  5729.     c       :   char;
  5730.     y, m, d :   word;
  5731.     st, st2 : string;
  5732.  
  5733.   begin
  5734.     st := 'JFMAMJJASOND'; d := __str(copy(s, 1, 2)); m := mo;
  5735.     c := s[4]; st2 := copy(s, 4, 3);
  5736.     case c of
  5737.       'A': if st2='Apr' then m := 4 else m := 8;
  5738.       'D', 'F', 'N', 'O', 'S': m := pos(c, st);
  5739.       'J': if st2='Jan' then m := 1 else if st2='Jun' then m := 6 else m := 7;
  5740.       'M': if st2='Mar' then m := 3 else m := 5;
  5741.     end;
  5742.     y := __str(copy(s, 8, 2));
  5743.     {
  5744.       use of yr mo & day, because in logpurge, they're set with datestr (today)
  5745.       global variables, within scope of implementation
  5746.     }
  5747.     __recent := abs(__daysutl(yr, mo, da, y, m, d)) <= purge
  5748.   end;
  5749.  
  5750.  
  5751.  
  5752.   procedure __logpurge;
  5753.   type buf = array[1..16386] of char;
  5754.   var
  5755.     tin, tou     :   text;
  5756.     bin, bou     :    buf;
  5757.     lin          : string;
  5758.  
  5759.   begin
  5760.     lin := __datestr(yr, mo, da);
  5761.     assign(tin, logfilename); reset(tin); settextbuf(tin, bin);
  5762.     assign(tou, 'eco_log.$$$'); rewrite(tou); settextbuf(tou, bou);
  5763.     for i := 1 to 15 do begin readln(tin, lin); writeln(tou, lin) end;
  5764.  
  5765.     readln(tin, lin);
  5766.     while not(eof(tin)) and (
  5767.       (lin='') or not(lin[1] in ['0','1','2','3']) or not(__recent(lin))
  5768.     ) do begin inc(lines); readln(tin, lin) end;
  5769.     if not eof(tin) then writeln(tou, lin);
  5770.     while not(eof(tin)) do begin
  5771.       inc(lines); readln(tin, lin); writeln(tou, lin)
  5772.     end;
  5773.     close(tin); close(tou);
  5774.     __erasefil(logfilename, error); rename(tou, logfilename);
  5775.   end;
  5776.  
  5777.  
  5778.  
  5779.   procedure __loginit;
  5780.   begin
  5781.     logheader[01] := '┌────────────────────────────────────────────────────────────┐';
  5782.     logheader[02] := '│ ▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄▄ │';
  5783.     logheader[03] := '│ █                                                        █ │';
  5784.     logheader[04] := '│ █                                                        █ │';
  5785.     logheader[05] := '│ █                 E  C  O  P  U  R  G  E                 █ │';
  5786.     logheader[06] := '│ █                                                        █ │';
  5787.     logheader[07] := '│ █                                                        █ │';
  5788.     logheader[08] := '│ █                                                        █ │';
  5789.     logheader[09] := '│ ▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀▀ │';
  5790.     logheader[10] := '│   All material is protected and licensed.  Version 0.00    │';
  5791.     logheader[11] := '└────────────────────────────────────────────────────────────┘';
  5792.   end;
  5793.  
  5794.  
  5795.  
  5796.  
  5797.   function __rep(n: byte; character: char): string;
  5798.   var tempstr: string;
  5799.   begin
  5800.     if n = 0 then tempstr := '' else begin
  5801.       if (n > 255) then n := 1; fillchar(tempstr,n+1,character);
  5802.       tempstr[0] := chr(n);
  5803.     end; __rep := tempstr;
  5804.   end;
  5805.  
  5806.  
  5807.   function  __loc(x, y : byte; var fore, back : byte): char;
  5808.   var
  5809.     pos : _scnpos;
  5810.  
  5811.   begin
  5812.     pos := _scnloc^[((y-1) * _curcolumns) + x];
  5813.     back := pos._attr; back := back shr 4; fore := pos._attr;
  5814.     fore := fore shl 4; fore := fore shr 4;
  5815.     __loc := pos._ch;
  5816.   end;
  5817.  
  5818.  
  5819.   function __attr(f, b : byte): byte;
  5820.   begin
  5821.     __attr := (b shl 4) or f
  5822.   end;
  5823.  
  5824.   procedure __scn(col,row,attr:byte; st: str80); external;
  5825.   procedure __vid(col,row:     byte; st: str80); external;
  5826.   procedure changeattr(col,row,attr:byte; number:word); external;
  5827.   procedure __speedscn(
  5828.     sourceptr, targetptr     : pointer;
  5829.         count, option, attribute :    word;
  5830.         wait                     : boolean
  5831.   ); external;
  5832.  
  5833.  
  5834.  
  5835.  
  5836.   function  get_video_mode: byte;
  5837.   var regs : registers;
  5838.   begin
  5839.     with regs do begin
  5840.       ax := $0F00; intr($10, regs); get_video_mode := al;
  5841.     end;
  5842.   end;
  5843.  
  5844.  
  5845.   procedure __movescn(
  5846.     x1, y1, x2, y2: byte; bufferptr: pointer; toscreen: boolean
  5847.   );
  5848.   var
  5849.     bufptr      : _scnimageptr absolute bufferptr;
  5850.     scnptr      : _scnimageptr;
  5851.     pagelength  : word absolute _biosseg:$004c;
  5852.     offset      : word;                { offset into video buffer       }
  5853.     width       : word;                { width, in pairs, of each line  }
  5854.     delta       : word;                { increment between data lines   }
  5855.     lines       : word;                { number of lines to access      }
  5856.     wait        : boolean;
  5857.     i,j,k       : word;
  5858.  
  5859.   begin {__movescn}
  5860.     if ((_curmode > 3) and (_curmode <> 7)) then exit; { not textmode }
  5861.     if (x1 < 1) then x1 := 1 else if (x1 > _curcolumns) then x1 := _curcolumns;
  5862.     if (y1 < 1) then y1 := 1 else if (y1 > _currows) then y1 := _currows;
  5863.     if (x2 < x1) then x2 := x1 else if (x2>_curcolumns) then x2 := _curcolumns;
  5864.     if (y2 < y1) then y2 := y1 else if (y2 > _currows) then y2 := _currows;
  5865.     offset := ((y1 - 1) * _curcolumns) + x1;
  5866.     width  := x2 - x1 + 1; delta  := _curcolumns - x2 + x1 - 1;
  5867.     lines  := y2 - y1 + 1;
  5868.     if (_curdisplaypage <> 0) then scnptr := ptr(
  5869.       _vectoraddr(_scnloc)._seg,
  5870.      _vectoraddr(_scnloc)._ofs + (pagelength * _curdisplaypage)
  5871.     ) else scnptr := _scnloc;
  5872.     wait := false;
  5873.  
  5874.     j := offset; k := 1;
  5875.     for i := 1 to lines do begin
  5876.       if (toscreen) then __speedscn(
  5877.         @bufptr^[k], @scnptr^[j], width, 2, 0, wait
  5878.       ) else __speedscn(
  5879.         @scnptr^[j], @bufptr^[k], width, 3, 0, wait
  5880.       );
  5881.       inc(j,width + delta);
  5882.       inc(k,width);
  5883.     end
  5884.   end; { __movescn }
  5885.  
  5886.  
  5887.  
  5888.   procedure __boxscn(x1,y1,x2,y2,boxtype,fore,back : byte);
  5889.   const
  5890.     corners : array[1..4,0..3] of char = (
  5891.       (#218,#214,#213,#201),   { top left corner        }
  5892.       (#191,#184,#183,#187),   { top right corner       }
  5893.       (#192,#211,#212,#200),   { bottom left    }
  5894.       (#217,#189,#190,#188)    { bottom right   }
  5895.     );
  5896.  
  5897.     lines : array[1..2,0..1] of char = (
  5898.       (#196,#205),                 { horizontal         }
  5899.       (#179,#186)
  5900.     );                             { vertical           }
  5901.  
  5902.  
  5903.   var
  5904.     boxcorner     : array[1..4] of char;
  5905.     boxline       : array[1..4] of char;
  5906.     boxchar       : char;
  5907.     horchars      : byte;
  5908.     verchars      : byte;
  5909.     i             : word;
  5910.     cursoron      : boolean;
  5911.     x,y,xtop,xbot : byte;
  5912.  
  5913.   begin
  5914.     if (boxtype > 15) then begin
  5915.       boxchar := chr(boxtype);
  5916.       fillchar(boxcorner,4,boxchar);
  5917.       fillchar(boxline,4,boxchar)
  5918.     end else begin
  5919.       boxcorner[1] := corners[1,(boxtype and 3)];
  5920.       boxcorner[2] := corners[2,((boxtype shr 1) and 3)];
  5921.       boxcorner[3] := corners[3,
  5922.           ((boxtype and 1) or ( 2 * ((boxtype shr 3) and 1)))];
  5923.       boxcorner[4] := corners[4,((boxtype shr 2) and 3)];
  5924.       boxline[1]   := lines[1,((boxtype shr 1) and 1)];
  5925.       boxline[2]   := lines[1,((boxtype shr 3) and 1)];
  5926.       boxline[3]   := lines[2,(boxtype and 1)];
  5927.       boxline[4]   := lines[2,((boxtype shr 2) and 1)]
  5928.     end;
  5929.     horchars := x2 - x1 - 1; verchars := y2 - y1 - 1;
  5930.     __write(x1, y1, fore, back, boxcorner[1]);
  5931.     if (horchars > 0) then __write(x1 + 1, y1, fore, back, __rep(horchars, boxline[1]));
  5932.     __write(x2, y1, fore, back, boxcorner[2]);
  5933.     for i := 1 to verchars do begin
  5934.       __write(x1, y1 + i, fore, back, boxline[3]);
  5935.       __write(x2, y1 + i, fore, back, boxline[4])
  5936.     end;
  5937.     __write(x1, y2, fore, back, boxcorner[3]);
  5938.     if (horchars > 0) then __write(
  5939.       x1 + 1, y2, fore,back, __rep(horchars, boxline[2])
  5940.     );
  5941.     __write(x2, y2, fore, back, boxcorner[4]);
  5942.   end;   { __boxscn }
  5943.  
  5944.  
  5945.  
  5946.  
  5947.   procedure __write(col, row, f, b: byte; st: str80);
  5948.   begin
  5949.     __scn(col, row, __attr(f, b), st);
  5950.   end;
  5951.  
  5952.  
  5953.   procedure __hwrite(x, y, f, b, h: byte; st: string);
  5954.   var
  5955.     c, i,n  :    byte;
  5956.     on      : boolean;
  5957.  
  5958.   begin
  5959.     i := 1; n := 0; c := f; on := false;
  5960.     while i <= length(st) do begin
  5961.       if st[i] = '~' then begin
  5962.         inc(n); on := not on; if on then c := h else c := f
  5963.       end else __write(x+i-1-n, y, c, b, st[i]);
  5964.       inc(i)
  5965.     end;
  5966.   end;
  5967.  
  5968.  
  5969.  
  5970.   { error = 255: debugging mode; else no debuginfo display }
  5971.   function __barcheck(s: string; var error: byte): boolean;
  5972.   var
  5973.     bad      : boolean;
  5974.     i, j, k,
  5975.     len      :    byte;
  5976.     onepart  :  string;
  5977.  
  5978.   begin
  5979.     j := 1; len := length(s); error := 1; i := 1;
  5980.     bad := (pos(' ', s) = 0) or (__cvtstr(s, _rem_white_str) = '');
  5981.     if error = 255 then writeln(s);
  5982.     if not bad then repeat
  5983.       while (s[j] = ' ') and (j < len) do inc(j); i := j;
  5984.       while (s[j] <> ' ') and (j < len) do inc(j);
  5985.       bad := false;
  5986.       onepart := __cvtstr(copy(s, i, j-i), _rem_white_str);
  5987.       if onepart <> '' then begin
  5988.         for k := 1 to 26 do begin { IS er een hoofdletter? }
  5989.           bad := bad or (pos(chr(k+64), onepart) > 0);
  5990.         end;
  5991.         bad := not bad;
  5992.       end;
  5993.       if error = 255 then writeln(i:2,' ', j:2,  ' "', onepart, '"');
  5994.     until bad or (j >= len);
  5995.     error := i;
  5996.     __barcheck := not bad;
  5997.   end;
  5998.  
  5999.  
  6000.  
  6001.   function  __barchoice(x,x1,y,f,b,h : byte; st: string; timeout: byte): byte;
  6002.   const
  6003.     quit: boolean = false;
  6004.  
  6005.   var
  6006.     key           :   word;
  6007.     off,i,j, find :   byte;
  6008.     s             : string;
  6009.  
  6010.     procedure hilite;
  6011.     var i : byte;
  6012.     begin
  6013.       __attrib(x+off, y, x+length(st)-1+off, y, f, b);
  6014.       for i := 1 to length(st) do
  6015.         if ((st[i]=upcase(st[i])) and (upcase(st[i]) in ['A'..'Z'])) then
  6016.           __attrib(x+i-1+off, y, x+i-1+off, y, h, b);
  6017.       i := 1;
  6018.       while st[i]<>s[find] do inc(i);
  6019.       if pos(' ', copy(st, 2, length(st)-2)) <> 0 then begin
  6020.         while st[i]<>' ' do dec(i);
  6021.         j := i-1; inc(i);
  6022.         while st[i]<>' ' do inc(i); dec(i);
  6023.         __attrib(j+x+off, y, i+x+off, y, b, f)
  6024.       end else __attrib(i+x-1+off, y, i+x-1+off, y, b, f);
  6025.     end;
  6026.  
  6027.   begin
  6028.     s := ''; find := 1; quit := false;
  6029.     off := ((x1-x) - length(st)) div 2;
  6030.     for i := 1 to length(st) do begin
  6031.       if (st[i]=upcase(st[i])) and (upcase(st[i]) in ['A'..'Z']) then
  6032.         s := s + st[i];
  6033.       if st[i] <> '_' then __write(x+i-1+off, y, f, b, st[i]);
  6034.     end;
  6035.     repeat
  6036.       hilite;
  6037.       key := __retdelaykey(timeout, _enter);
  6038.       if (key = _left) or (key = _padleft) then begin
  6039.         if find>1 then dec(find) else find := length(s)
  6040.       end else if (key = _right) or (key = _padright) then begin
  6041.         if find<length(s) then inc(find) else find := 1
  6042.       end else if (key = _enter) or (key = _padenter) then begin
  6043.         quit := true
  6044.       end else if (key = _esc) then begin
  6045.         quit := true; find := 0
  6046.       end else if key = _space then begin
  6047.         if find < length(s) then inc(find) else find := 1
  6048.       end else for i := 1 to length(s) do if s[i] = upcase(lastkey) then begin
  6049.         find := i; quit := true
  6050.       end;
  6051.     until quit;
  6052.     if find > 0 then hilite;
  6053.     __barchoice := find;
  6054.   end;
  6055.  
  6056.  
  6057.  
  6058.   procedure __setblwin(blinkon : boolean);
  6059.   var reg : registers;
  6060.   begin
  6061.     if ((_curdevice = _egaadapter) or (_curdevice = _vgaadapter)) then begin
  6062.       with reg do begin
  6063.         ah := $10;
  6064.         al := $03;
  6065.         bl := byte(blinkon);
  6066.         intr($10, reg)
  6067.       end
  6068.     end else begin
  6069.       port[$3b8] := 8; mem[0:$465] := port[$3b8];
  6070.       if blinkon then port[$3b8] := $28;
  6071.     end;
  6072.   end;
  6073.  
  6074.  
  6075. {@}
  6076.   procedure __partscn;
  6077.   var
  6078.     bufptr        :     _scnimageptr absolute sc;
  6079.     scnptr        :                 _scnimageptr;
  6080.     pagelength    : word absolute _biosseg:$004c;
  6081.     offset,
  6082.     width,
  6083.     delta,
  6084.     lines,
  6085.     i, j          :                         word;
  6086.     wait          :                      boolean;
  6087.  
  6088.   begin
  6089.     if ((_curmode > 3) and (_curmode <> 7)) then exit;
  6090.     if (x1<1)  then x1 :=  1 else if (x1> _curcolumns) then x1 := _curcolumns;
  6091.     if (y1<1)  then y1 :=  1 else if (y1> _currows   ) then y1 :=    _currows;
  6092.     if (x2<x1) then x2 := x1 else if (x2> _curcolumns) then x2 := _curcolumns;
  6093.     if (y2<y1) then y2 := y1 else if (y2> _currows   ) then y2 :=    _currows;
  6094.  
  6095.     offset := ((y1 - 1) * _curcolumns) + x1;
  6096.     width  := x2 - x1 + 1;
  6097.     delta  := _curcolumns - x2 + x1 - 1;
  6098.     lines  := y2 - y1 + 1;
  6099.     if (_curdisplaypage <> 0) then scnptr := ptr(_vectoraddr(_scnloc)._seg,
  6100.       _vectoraddr(_scnloc)._ofs + (pagelength * _curdisplaypage)) else
  6101.       scnptr := _scnloc;
  6102.  
  6103.     wait := ((_curdevice = _coloradapter){ and (not _snowlesscga)});
  6104.  
  6105.     j := offset;
  6106.     for i := 1 to lines do begin
  6107.       if toscreen then
  6108.         __speedscn(@bufptr^[j],@scnptr^[j],width,2,0,wait) else
  6109.         __speedscn(@scnptr^[j],@bufptr^[j],width,2,0,wait);
  6110.       inc(j,width + delta);
  6111.     end
  6112.   end;
  6113.  
  6114.  
  6115.  
  6116.   procedure __resscn(sc: _scnimageptr);
  6117.   begin
  6118.     __movescn(1, 1, _curcolumns, _currows, sc, true)
  6119.   end;
  6120.  
  6121.  
  6122.  
  6123.   procedure __savscn(sc: _scnimageptr);
  6124.   begin
  6125.     __movescn(1, 1, _curcolumns, _currows, sc, false)
  6126.   end;
  6127.  
  6128.  
  6129.  
  6130.   procedure __copyscn(x1, y1, x2, y2, x, y: byte);
  6131.   var buffer: _scnimage;
  6132.   begin
  6133.     __movescn(x1, y1, x2, y2, @buffer, false);
  6134.     __movescn(x, y, x+x2-x1, y+y2-y1, @buffer, true);
  6135.   end;
  6136.  
  6137.  
  6138.  
  6139.   procedure __attrib(x1, y1, x2, y2, f, b: byte);
  6140.   var i: byte;
  6141.   begin
  6142.     for i := y1 to y2 do changeattr(x1, i, __attr(f, b), succ(x2-x1))
  6143.   end;
  6144.  
  6145.  
  6146.  
  6147.   procedure __bandwin(del: boolean; x1, y1, x2, y2, f, b, shadow, bt: byte);
  6148.   var
  6149.     br, ht,
  6150.     vt, mih,
  6151.     ff, bb,
  6152.     miv      : byte;
  6153.  
  6154.   begin
  6155.     if del then begin
  6156.       miv := y1 + (y2-y1) div 2; mih := x1 + (x2-x1) div 2;
  6157.       if y2-y1>5 then vt := 2 else vt := 1;
  6158.       if x2-x1>20 then ht := 5 else ht := 3;
  6159.       __clrscn(mih - ht, miv - vt + 1, mih + ht, miv + vt, f, b, ' ');
  6160.       __boxscn(mih - ht, miv - vt + 1, mih + ht, miv + vt, 15, f, b);
  6161.       __delay(100);
  6162.     end;
  6163.     if bt=1 then br := 00 else br := 15;
  6164.     __loc(x1-1, y2+3, ff, bb);
  6165.     if shadow = sh_high then begin
  6166.       if bb = black then shadow := lightgray else shadow := white
  6167.     end;
  6168.     if shadow = sh_low then shadow := lightgray;
  6169.     if shadow = sh_default then begin
  6170.       if bb = black then shadow := darkgray else shadow := black
  6171.     end;
  6172.     if _currows = 25 then begin
  6173.       __attrib(x1-1, y2+3, x2+5, y2+3, lightgray, shadow);
  6174.       __attrib(x2+2, y1-1, x2+5, y2+2, lightgray, shadow);
  6175.       __clrscn(x1-3, y1-2, x2+3, y2+2, f, b, ' ');
  6176.     end else begin
  6177.       __attrib(x1-1, y2+3, x2+3, y2+3, lightgray, shadow);
  6178.       __attrib(x2+3, y1-1, x2+3, y2+2, lightgray, shadow);
  6179.       __clrscn(x1-2, y1-2, x2+2, y2+2, f, b, ' ');
  6180.     end;
  6181.     __boxscn(x1-1, y1-1, x2+1, y2+1, br, f, b);
  6182.   end;
  6183.  
  6184.  
  6185.   procedure __vert(x, y, f, b: byte; s: string);
  6186.   var i: byte;
  6187.   begin
  6188.     for i := 1 to length(s) do __write(x, y + i - 1, f, b, s[i]);
  6189.   end;
  6190.  
  6191.  
  6192.   procedure __betwscn(x1, x2, y, f, b: byte; st: string);
  6193.   var x : integer;
  6194.  
  6195.   begin
  6196.     if length(st) >= x2 - x1 + 1 then __write(x1, y, f, b, st) else begin
  6197.       x := x1 + (x2 - x1 + 1 - length(st)) div 2;
  6198.       __write(x, y, f, b, st);
  6199.     end;
  6200.   end;
  6201.  
  6202.  
  6203.  
  6204.   procedure __hbetwscn(x1, x2, y, f, b, h: byte; st: string);
  6205.   var i, n, x : integer;
  6206.   begin
  6207.     n := 0;
  6208.     for i := 1 to length(st) do if st[i]='~' then inc(n);
  6209.     if length(st) >= x2 - x1 + 1 then __hwrite(x1, y, f, b, h, st) else begin
  6210.       x := x1 + (x2 - x1 + 1 - length(st) - n) div 2;
  6211.       __hwrite(x, y, f, b, h, st);
  6212.     end;
  6213.   end;
  6214.  
  6215.  
  6216.   procedure __clrscn(x1, y1, x2, y2, f, b: byte; c: char);
  6217.   var
  6218.     y      : integer;
  6219.  
  6220.   begin
  6221.     if x2 > 80 then x2 := 80;
  6222.     for y := y1 to y2 do __write(x1, y, f, b, __rep(x2-x1+1, c));
  6223.   end;
  6224.  
  6225.  
  6226.  
  6227.   procedure __cls;
  6228.   begin
  6229.     __clrscn(1, 1, _curcolumns, _currows, 7, 0, ' ');
  6230.   end;
  6231.  
  6232.  
  6233.  
  6234.  
  6235.   procedure __equipscn;
  6236.   const
  6237.     active     = 1;
  6238.     alternate  = 2;
  6239.  
  6240.   var
  6241.     savecursor : word;
  6242.     crtport    : word;
  6243.     adisplay   : byte;
  6244.     i          : integer;
  6245.     regs       : registers;
  6246.  
  6247.  
  6248.   begin
  6249.     _monoadapter    := _unknown;
  6250.     _coloradapter   := _unknown;
  6251.     _egaadapter     := _unknown;
  6252.     _hercadapter    := _unknown;
  6253.     _vgaadapter     := _unknown;
  6254.     _mcgaadapter    := _unknown;
  6255.     egamonitor_     := _nomonitor;
  6256.     analogmonitor_  := _nomonitor;
  6257.     egamemory_      := 0;
  6258.     with regs do begin
  6259.       ax := $1a00;
  6260.       bx := $0000;
  6261.       intr($10,regs);
  6262.       inline($fb);
  6263.       if (al = $1a) then begin
  6264.         _monoadapter  := _absent;
  6265.         _coloradapter := _absent;
  6266.         _egaadapter   := _absent;
  6267.         _hercadapter  := _absent;
  6268.         _mcgaadapter  := _absent;
  6269.         _vgaadapter   := _absent;
  6270.         adisplay := bl;
  6271.         for i := active to alternate do begin
  6272.           case adisplay of
  6273.             $01     : _monoadapter  := _mono;
  6274.             $02     : _coloradapter := _color;
  6275.             $04     : _egaadapter   := _color;
  6276.             $05     : _egaadapter   := _mono;
  6277.             $07,$08 : if (adisplay = bl) then
  6278.                          _vgaadapter := active
  6279.                       else
  6280.                          _vgaadapter := alternate;
  6281.             $0b,$0c : _mcgaadapter  := _color;
  6282.           end;
  6283.           case adisplay of
  6284.             $07,$0b : analogmonitor_ := _anmonomonitor;
  6285.             $08,$0c : analogmonitor_ := _ancolormonitor;
  6286.           end;
  6287.           adisplay := bh
  6288.         end;
  6289.       end else begin
  6290.         _mcgaadapter  := _absent;
  6291.         _vgaadapter   := _absent
  6292.       end;
  6293.       ax := $1200;
  6294.       bx := $ff10;
  6295.       cx := $00ff;
  6296.       intr($10,regs);
  6297.       inline($fb);
  6298.       if (_egaadapter = _unknown) then begin
  6299.         if ((cl < 12) and (bh <= 1) and (bl <= 3)) then begin
  6300.           if (bh = 1) then begin
  6301.             _monoadapter  := _absent;
  6302.             _egaadapter   := _mono;
  6303.             egamonitor_   := _monomonitor
  6304.           end else begin
  6305.             _coloradapter := _absent;
  6306.             _egaadapter   := _color
  6307.           end
  6308.         end else _egaadapter := _absent
  6309.       end;
  6310.       if (_egaadapter <> _absent) then begin
  6311.         egamemory_ := 64 + (64 * bl);
  6312.         if (((cx and $0009) = 9) or ((cx and $0003) = 3)) then
  6313.           egamonitor_ := _enhancedmonitor else
  6314.             if (egamonitor_ <> _monomonitor) then egamonitor_ := _colormonitor
  6315.       end
  6316.     end;
  6317.  
  6318.     if (_monoadapter = _unknown) then begin
  6319.       crtport           := $3b4;
  6320.       port[crtport]     := $f;
  6321.       savecursor        := port[crtport + 1];
  6322.       port[crtport + 1] := 90;
  6323.       if (port[crtport + 1] = 90) then _monoadapter := _mono else
  6324.         _monoadapter := _absent;
  6325.       port[crtport + 1] := savecursor
  6326.     end;
  6327.  
  6328.     if (_coloradapter = _unknown) then begin
  6329.       crtport           := $3d4;
  6330.       port[crtport]     := $f;
  6331.       savecursor        := port[crtport + 1];
  6332.       port[crtport + 1] := 90;
  6333.       if (port[crtport + 1] = 90) then _coloradapter  := _color else
  6334.         _coloradapter := _absent;
  6335.       port[crtport + 1] := savecursor
  6336.     end;
  6337.  
  6338.     if (_vgaadapter > _absent) then with regs do begin
  6339.       ax := $0f00;
  6340.       intr($10,regs);
  6341.       if (_vgaadapter = active) then
  6342.         if ((al = 7) or (al = 15)) then _vgaadapter := _mono else
  6343.          _vgaadapter := _color else if ((al = 7) or (al = 15)) then
  6344.            _vgaadapter := _color else _vgaadapter := _mono
  6345.     end;
  6346.   end;
  6347.  
  6348.  
  6349.  
  6350.  
  6351.   {$F+}
  6352.   function __retdvscn(
  6353.     var dvmode    : byte;
  6354.     var dvcols    : word;
  6355.     var dvrows    : word;
  6356.     var dbactpage : byte;
  6357.     var dvdispage : byte
  6358.   ): byte;
  6359.   var
  6360.     reg         : registers;
  6361.     charheight  :      word;
  6362.  
  6363.   begin
  6364.     with reg do begin
  6365.       fillchar(reg, sizeof(reg), $00);
  6366.       ax := $0F00;
  6367.       intr($10, reg);
  6368.       dvmode := al; dvcols := ah; dbactpage := bh
  6369.     end;
  6370.     if (dvmode = 7) then begin
  6371.       _curdevice := _mono;
  6372.       _scnloc    := ptr($b000,$0000)
  6373.     end else if (dvmode < 13) then begin
  6374.       _curdevice := _color;
  6375.       _scnloc    := ptr($b000,$8000)
  6376.     end else begin
  6377.       if (dvmode = 15) then _curdevice := _mono else _curdevice := _color;
  6378.       _scnloc := ptr($a000,$0000)
  6379.     end;
  6380.     with reg do begin
  6381.       es := _vectoraddr(_scnloc)._seg;
  6382.       di := _vectoraddr(_scnloc)._ofs;
  6383.       ah := $fe;
  6384.       intr($10,reg);
  6385.       inline($fb);
  6386.       _scnloc := ptr(es,di)
  6387.     end;
  6388.     if ((_curdevice = _hercadapter) or (_curdevice = _monoadapter)) then begin
  6389.       _curmonitor := _monomonitor;
  6390.       charheight  := 14
  6391.     end else if (_curdevice = _coloradapter) then begin
  6392.       _curmonitor := _colormonitor;
  6393.       charheight  := 8
  6394.     end else if (
  6395.       _curdevice = _egaadapter
  6396.     ) then _curmonitor := egamonitor_ else if (
  6397.       (_curdevice = _vgaadapter) or
  6398.       (_curdevice = _mcgaadapter)
  6399.     ) then _curmonitor := analogmonitor_ else _curmonitor := _nomonitor;
  6400.     if (
  6401.       (_egaadapter = _curdevice) or (_mcgaadapter = _curdevice) or
  6402.       (_vgaadapter = _curdevice)
  6403.     ) then with reg do begin
  6404.       ax := $1130;
  6405.       bx := 0;
  6406.       intr($10,reg);
  6407.       dvrows := dl + 1;
  6408.       charheight := cx
  6409.     end else dvrows := 25;
  6410.  
  6411.     case dvmode of
  6412.       4..6,8..10,17..19: _maxdisplaypage := 0;
  6413.       0,1: if (dvrows = 50) then _maxdisplaypage := 6 else _maxdisplaypage := 7;
  6414.       2,3,7: begin
  6415.         if (_curdevice = _mono) then _maxdisplaypage := 0 else
  6416.           _maxdisplaypage := 3;
  6417.         if (_curdevice = _vgaadapter) then case dvrows of
  6418.           25    : _maxdisplaypage := 7;
  6419.           43,50 : _maxdisplaypage := 3
  6420.         end;
  6421.         if (_curdevice = _egaadapter) then begin
  6422.           if (egamemory_ > 64) then _maxdisplaypage := 7 else
  6423.             _maxdisplaypage := 3;
  6424.           if (dvrows = 43) then _maxdisplaypage := _maxdisplaypage div 2
  6425.         end
  6426.       end;
  6427.       13: begin
  6428.         _maxdisplaypage := 7;
  6429.         if (_egaadapter = _curdevice) then if (egamemory_ = 64) then
  6430.           _maxdisplaypage := 1 else if (egamemory_ = 128) then
  6431.           _maxdisplaypage := 3;
  6432.       end;
  6433.       14: begin
  6434.         _maxdisplaypage := 3;
  6435.         if (_egaadapter = _curdevice) then if (egamemory_ = 64) then
  6436.           _maxdisplaypage := 0 else if (egamemory_ = 128) then
  6437.           _maxdisplaypage := 1
  6438.       end;
  6439.       15..16: begin
  6440.         _maxdisplaypage := 1;
  6441.         if (_egaadapter = _curdevice) then if (egamemory_ = 64) then
  6442.           _maxdisplaypage := 0;
  6443.       end;
  6444.     end;
  6445.  
  6446.     _curdisplaypage := dvdispage;
  6447.     _curmode        := dvmode;
  6448.     _currows        := dvrows;
  6449.     _curcolumns     := dvcols;
  6450.     _curactivepage  := dbactpage;
  6451.     maxscanline_    := charheight - 1;
  6452.     __retdvscn      := _curdevice
  6453.   end;
  6454.   {$F-}
  6455.  
  6456.  
  6457.   procedure __stdio;
  6458.   begin
  6459.     assign(input, ''); reset(input);
  6460.     assign(output, ''); rewrite(output);
  6461.   end;
  6462.  
  6463.  
  6464.  
  6465.  
  6466.  
  6467.  
  6468.  
  6469.  
  6470.   function  __crc32(value: byte; crc: longint) : longint;
  6471.   const
  6472.     crc32_table : array[0..255] of longint = (
  6473.       $00000000, $77073096, $ee0e612c, $990951ba, $076dc419, $706af48f,
  6474.       $e963a535, $9e6495a3, $0edb8832, $79dcb8a4, $e0d5e91e, $97d2d988,
  6475.       $09b64c2b, $7eb17cbd, $e7b82d07, $90bf1d91, $1db71064, $6ab020f2,
  6476.       $f3b97148, $84be41de, $1adad47d, $6ddde4eb, $f4d4b551, $83d385c7,
  6477.       $136c9856, $646ba8c0, $fd62f97a, $8a65c9ec, $14015c4f, $63066cd9,
  6478.       $fa0f3d63, $8d080df5, $3b6e20c8, $4c69105e, $d56041e4, $a2677172,
  6479.       $3c03e4d1, $4b04d447, $d20d85fd, $a50ab56b, $35b5a8fa, $42b2986c,
  6480.       $dbbbc9d6, $acbcf940, $32d86ce3, $45df5c75, $dcd60dcf, $abd13d59,
  6481.       $26d930ac, $51de003a, $c8d75180, $bfd06116, $21b4f4b5, $56b3c423,
  6482.       $cfba9599, $b8bda50f, $2802b89e, $5f058808, $c60cd9b2, $b10be924,
  6483.       $2f6f7c87, $58684c11, $c1611dab, $b6662d3d, $76dc4190, $01db7106,
  6484.       $98d220bc, $efd5102a, $71b18589, $06b6b51f, $9fbfe4a5, $e8b8d433,
  6485.       $7807c9a2, $0f00f934, $9609a88e, $e10e9818, $7f6a0dbb, $086d3d2d,
  6486.       $91646c97, $e6635c01, $6b6b51f4, $1c6c6162, $856530d8, $f262004e,
  6487.       $6c0695ed, $1b01a57b, $8208f4c1, $f50fc457, $65b0d9c6, $12b7e950,
  6488.       $8bbeb8ea, $fcb9887c, $62dd1ddf, $15da2d49, $8cd37cf3, $fbd44c65,
  6489.       $4db26158, $3ab551ce, $a3bc0074, $d4bb30e2, $4adfa541, $3dd895d7,
  6490.       $a4d1c46d, $d3d6f4fb, $4369e96a, $346ed9fc, $ad678846, $da60b8d0,
  6491.       $44042d73, $33031de5, $aa0a4c5f, $dd0d7cc9, $5005713c, $270241aa,
  6492.       $be0b1010, $c90c2086, $5768b525, $206f85b3, $b966d409, $ce61e49f,
  6493.       $5edef90e, $29d9c998, $b0d09822, $c7d7a8b4, $59b33d17, $2eb40d81,
  6494.       $b7bd5c3b, $c0ba6cad, $edb88320, $9abfb3b6, $03b6e20c, $74b1d29a,
  6495.       $ead54739, $9dd277af, $04db2615, $73dc1683, $e3630b12, $94643b84,
  6496.       $0d6d6a3e, $7a6a5aa8, $e40ecf0b, $9309ff9d, $0a00ae27, $7d079eb1,
  6497.       $f00f9344, $8708a3d2, $1e01f268, $6906c2fe, $f762575d, $806567cb,
  6498.       $196c3671, $6e6b06e7, $fed41b76, $89d32be0, $10da7a5a, $67dd4acc,
  6499.       $f9b9df6f, $8ebeeff9, $17b7be43, $60b08ed5, $d6d6a3e8, $a1d1937e,
  6500.       $38d8c2c4, $4fdff252, $d1bb67f1, $a6bc5767, $3fb506dd, $48b2364b,
  6501.       $d80d2bda, $af0a1b4c, $36034af6, $41047a60, $df60efc3, $a867df55,
  6502.       $316e8eef, $4669be79, $cb61b38c, $bc66831a, $256fd2a0, $5268e236,
  6503.       $cc0c7795, $bb0b4703, $220216b9, $5505262f, $c5ba3bbe, $b2bd0b28,
  6504.       $2bb45a92, $5cb36a04, $c2d7ffa7, $b5d0cf31, $2cd99e8b, $5bdeae1d,
  6505.       $9b64c2b0, $ec63f226, $756aa39c, $026d930a, $9c0906a9, $eb0e363f,
  6506.       $72076785, $05005713, $95bf4a82, $e2b87a14, $7bb12bae, $0cb61b38,
  6507.       $92d28e9b, $e5d5be0d, $7cdcefb7, $0bdbdf21, $86d3d2d4, $f1d4e242,
  6508.       $68ddb3f8, $1fda836e, $81be16cd, $f6b9265b, $6fb077e1, $18b74777,
  6509.       $88085ae6, $ff0f6a70, $66063bca, $11010b5c, $8f659eff, $f862ae69,
  6510.       $616bffd3, $166ccf45, $a00ae278, $d70dd2ee, $4e048354, $3903b3c2,
  6511.       $a7672661, $d06016f7, $4969474d, $3e6e77db, $aed16a4a, $d9d65adc,
  6512.       $40df0b66, $37d83bf0, $a9bcae53, $debb9ec5, $47b2cf7f, $30b5ffe9,
  6513.       $bdbdf21c, $cabac28a, $53b39330, $24b4a3a6, $bad03605, $cdd70693,
  6514.       $54de5729, $23d967bf, $b3667a2e, $c4614ab8, $5d681b02, $2a6f2b94,
  6515.       $b40bbe37, $c30c8ea1, $5a05df1b, $2d02ef8d
  6516.     );
  6517.  
  6518.   begin
  6519.     if crc = 0 then crc := $ffffffff; { must be set high to start with }
  6520.     __crc32 := crc32_table[byte(crc xor longint(value))] xor
  6521.       ((crc shr 8) and $00ffffff);
  6522.   end;
  6523.  
  6524.  
  6525.  
  6526.   function  __crc16(value : byte; crc : word): word;
  6527.   (* crctab calculated by mark g. mendel, network systems corporation *)
  6528.   const
  6529.     crc16_table : array[0..255] of word = (
  6530.        $0000,  $1021,  $2042,  $3063,  $4084,  $50a5,  $60c6,  $70e7,
  6531.        $8108,  $9129,  $a14a,  $b16b,  $c18c,  $d1ad,  $e1ce,  $f1ef,
  6532.        $1231,  $0210,  $3273,  $2252,  $52b5,  $4294,  $72f7,  $62d6,
  6533.        $9339,  $8318,  $b37b,  $a35a,  $d3bd,  $c39c,  $f3ff,  $e3de,
  6534.        $2462,  $3443,  $0420,  $1401,  $64e6,  $74c7,  $44a4,  $5485,
  6535.        $a56a,  $b54b,  $8528,  $9509,  $e5ee,  $f5cf,  $c5ac,  $d58d,
  6536.        $3653,  $2672,  $1611,  $0630,  $76d7,  $66f6,  $5695,  $46b4,
  6537.        $b75b,  $a77a,  $9719,  $8738,  $f7df,  $e7fe,  $d79d,  $c7bc,
  6538.        $48c4,  $58e5,  $6886,  $78a7,  $0840,  $1861,  $2802,  $3823,
  6539.        $c9cc,  $d9ed,  $e98e,  $f9af,  $8948,  $9969,  $a90a,  $b92b,
  6540.        $5af5,  $4ad4,  $7ab7,  $6a96,  $1a71,  $0a50,  $3a33,  $2a12,
  6541.        $dbfd,  $cbdc,  $fbbf,  $eb9e,  $9b79,  $8b58,  $bb3b,  $ab1a,
  6542.        $6ca6,  $7c87,  $4ce4,  $5cc5,  $2c22,  $3c03,  $0c60,  $1c41,
  6543.        $edae,  $fd8f,  $cdec,  $ddcd,  $ad2a,  $bd0b,  $8d68,  $9d49,
  6544.        $7e97,  $6eb6,  $5ed5,  $4ef4,  $3e13,  $2e32,  $1e51,  $0e70,
  6545.        $ff9f,  $efbe,  $dfdd,  $cffc,  $bf1b,  $af3a,  $9f59,  $8f78,
  6546.        $9188,  $81a9,  $b1ca,  $a1eb,  $d10c,  $c12d,  $f14e,  $e16f,
  6547.        $1080,  $00a1,  $30c2,  $20e3,  $5004,  $4025,  $7046,  $6067,
  6548.        $83b9,  $9398,  $a3fb,  $b3da,  $c33d,  $d31c,  $e37f,  $f35e,
  6549.        $02b1,  $1290,  $22f3,  $32d2,  $4235,  $5214,  $6277,  $7256,
  6550.        $b5ea,  $a5cb,  $95a8,  $8589,  $f56e,  $e54f,  $d52c,  $c50d,
  6551.        $34e2,  $24c3,  $14a0,  $0481,  $7466,  $6447,  $5424,  $4405,
  6552.        $a7db,  $b7fa,  $8799,  $97b8,  $e75f,  $f77e,  $c71d,  $d73c,
  6553.        $26d3,  $36f2,  $0691,  $16b0,  $6657,  $7676,  $4615,  $5634,
  6554.        $d94c,  $c96d,  $f90e,  $e92f,  $99c8,  $89e9,  $b98a,  $a9ab,
  6555.        $5844,  $4865,  $7806,  $6827,  $18c0,  $08e1,  $3882,  $28a3,
  6556.        $cb7d,  $db5c,  $eb3f,  $fb1e,  $8bf9,  $9bd8,  $abbb,  $bb9a,
  6557.        $4a75,  $5a54,  $6a37,  $7a16,  $0af1,  $1ad0,  $2ab3,  $3a92,
  6558.        $fd2e,  $ed0f,  $dd6c,  $cd4d,  $bdaa,  $ad8b,  $9de8,  $8dc9,
  6559.        $7c26,  $6c07,  $5c64,  $4c45,  $3ca2,  $2c83,  $1ce0,  $0cc1,
  6560.        $ef1f,  $ff3e,  $cf5d,  $df7c,  $af9b,  $bfba,  $8fd9,  $9ff8,
  6561.        $6e17,  $7e36,  $4e55,  $5e74,  $2e93,  $3eb2,  $0ed1,  $1ef0
  6562.      );
  6563.  
  6564.   begin
  6565.     __crc16 := crc16_table[((crc shr 8) and 255)] xor
  6566.       (crc shl 8) xor value;
  6567.   end;
  6568.  
  6569.  
  6570.  
  6571.  
  6572.  
  6573.  
  6574.  
  6575.  
  6576.  
  6577.  
  6578.  
  6579.  
  6580.  
  6581.   procedure setselerror__(error : word);
  6582.   begin
  6583.     _selerror := error;
  6584.   end;
  6585.  
  6586.  
  6587.  
  6588.  
  6589.   function itemads__(pickptr : _pickptr; itemno : word) : pointer;
  6590.   begin
  6591.     with pickptr^ do begin
  6592.       if (_pointers) then
  6593.         itemads__ := pointer(
  6594.           pointer(longint(_itemaddr) +
  6595.           (pred(itemno) * sizeof(pointer)))^
  6596.         ) else itemads__ := pointer(
  6597.            longint(_itemaddr) + (pred(itemno) * _itemsize)
  6598.         );
  6599.     end;
  6600.   end;
  6601.  
  6602.  
  6603.  
  6604.   procedure uptwnsel__(pickptr : _pickptr);
  6605.   var itemno : word;
  6606.   begin
  6607.     with pickptr^ do begin
  6608.       for itemno := _firstpage to _lastpage do __itemsel(
  6609.         pickptr, _fore, _back, itemno
  6610.       );
  6611.     end;
  6612.   end;
  6613.  
  6614.  
  6615.  
  6616.   procedure __itemsel(pickptr: _pickptr; fore, back: byte; itemno: word);
  6617.   const blank = #32;
  6618.   var
  6619.     x, y, z  : word;
  6620.     dspstr : string;
  6621.  
  6622.   begin
  6623.     with pickptr^ do begin
  6624.       _curitemptr := itemads__(pickptr, itemno);
  6625.       fillchar(dspstr, sizeof(dspstr), blank);
  6626.       z := length(string(_curitemptr^));
  6627.       if (z > _itemlen) then z := _itemlen;
  6628.       move(string(_curitemptr^)[1], dspstr, z);
  6629.       z := (itemno - _firstpage);
  6630.       x := succ(((z mod _numcols) * (_itemlen + _spacing)) + _spacing);
  6631.       y := succ(z div _numcols);
  6632.       __write(_x1+x-1, _y1+y-1, fore, back,
  6633.         __juststr(string(_curitemptr^), ' ', _x2 - _x1 - 1, _center_str)
  6634.       );
  6635.     end;
  6636.   end;
  6637.  
  6638.  
  6639.  
  6640.  
  6641.   function  __makesel(
  6642.     x1, y1,
  6643.     x2, y2,
  6644.     fore, back,
  6645.     barfore,
  6646.     barback    :    byte;
  6647.     keyproc    : pointer;
  6648.     itemlen    :    word;
  6649.     numitems   :    word;
  6650.     itemsize   :    word;
  6651.     numcols    :    word;
  6652.     spacing    :    word;
  6653.     itemaddr   : pointer;
  6654.     ispointers : boolean
  6655.   ) : _pickptr;
  6656.  
  6657.   var
  6658.     pickptr    : _pickptr;
  6659.  
  6660.   begin
  6661.     _fore := fore; _back := back;
  6662.     _x1 := x1; _y1 := y1; _x2 := x2; _y2 := y2;
  6663.     getmem(pickptr, sizeof(_pick));
  6664.     with pickptr^ do begin
  6665.       fillchar(pickptr^, sizeof(_pick), 0);
  6666.       _barfore := barfore; _barback := barback;
  6667.       _keyproc := keyproc; _numitems := numitems;
  6668.       _itemlen := itemlen;
  6669.       if (ispointers) then _itemsize := sizeof(pointer) else
  6670.         _itemsize := itemsize + 1;
  6671.       _numcols := numcols; _spacing := spacing; _itemaddr := itemaddr;
  6672.       _pointers := ispointers; _curitemnum := 1;
  6673.     end;
  6674.     __makesel := pickptr;
  6675.   end;
  6676.  
  6677.  
  6678.  
  6679.   function  __picksel(
  6680.     listpickptr : _pickptr;
  6681.     var retitem :   string;
  6682.     var retkey  :     word
  6683.   ) : word;
  6684.   type strpointer = ^string;
  6685.   var
  6686.     pageitems  :    word;
  6687.     found      : boolean;
  6688.     initkey    : boolean;
  6689.     return     : boolean;
  6690.     key        :    word;
  6691.  
  6692.  
  6693.     procedure redraw(up: boolean; start, stop : word);
  6694.     begin
  6695.       with listpickptr^ do begin
  6696.         if up then __copyscn(_x1, _y1+1, _x2, _y2, _x1, _y1) else
  6697.           __copyscn(_x1, _y1, _x2, _y2-1, _x1, _y1+1);
  6698.         while (start <= stop) do begin
  6699.           __itemsel(listpickptr, _fore, _back, start);
  6700.           inc(start)
  6701.         end;
  6702.       end;
  6703.     end;
  6704.  
  6705.  
  6706.     procedure movebar;
  6707.     var
  6708.       flag    : boolean;
  6709.       hold    : word;
  6710.  
  6711.     begin
  6712.       with listpickptr^ do begin
  6713.         __itemsel(listpickptr, _fore, _back, _curitemnum);
  6714.         case key of
  6715.           _up, _padup : if (_curitemnum > _numcols) then begin
  6716.             dec(_curitemnum, _numcols);
  6717.             if (_curitemnum < _firstpage) then begin
  6718.               dec(_firstpage, _numcols);
  6719.               _lastpage := pred(_firstpage + pageitems);
  6720.               redraw(false, _firstpage, pred(_firstpage + _numcols));
  6721.             end;
  6722.           end;
  6723.  
  6724.           _down, _paddown : if (_curitemnum < _numitems) then begin
  6725.             flag := false;
  6726.             if (_curitemnum + _numcols <= _numitems) then begin
  6727.               inc(_curitemnum, _numcols);
  6728.               flag := true;
  6729.             end;
  6730.             if (
  6731.               (
  6732.                 (_lastpage < _numitems) and (_curitemnum > _lastpage)
  6733.               )
  6734.               or
  6735.               (
  6736.                 ((_curitemnum + _numcols) > _numitems) and
  6737.                 (_curitemnum < _numitems) and
  6738.                 (_lastpage < _numitems) and
  6739.                 (not flag)
  6740.               )
  6741.             ) then begin
  6742.               inc(_firstpage, _numcols); inc(_lastpage, _numcols);
  6743.               if (_lastpage > _numitems) then _lastpage := _numitems;
  6744.               redraw(true, succ(_lastpage - _numcols), _lastpage);
  6745.             end;
  6746.           end;
  6747.  
  6748.           _right, _padright : if (_curitemnum < _numitems) then begin
  6749.             inc(_curitemnum);
  6750.             if (_curitemnum > _lastpage) then begin
  6751.               inc(_firstpage, _numcols); inc(_lastpage, _numcols);
  6752.               if (_lastpage > _numitems) then _lastpage := _numitems;
  6753.               redraw(true, _curitemnum, _lastpage);
  6754.             end;
  6755.           end;
  6756.  
  6757.           _left, _padleft : if (_curitemnum > 1) then begin
  6758.             dec(_curitemnum);
  6759.             if (_curitemnum < _firstpage) then begin
  6760.               dec(_firstpage, _numcols);
  6761.               _lastpage := pred(_firstpage + pageitems);
  6762.               redraw(false, succ(_curitemnum - _numcols), _curitemnum);
  6763.             end;
  6764.           end;
  6765.  
  6766.           _home, _padhome : if (_curitemnum > 1) then begin
  6767.             _curitemnum := 1; _firstpage := 1; _lastpage := pageitems;
  6768.             if (_lastpage > _numitems) then _lastpage := _numitems;
  6769.             uptwnsel__(listpickptr);
  6770.           end;
  6771.  
  6772.           _end, _padend : if (_curitemnum <> _numitems) then begin
  6773.             _curitemnum := _numitems;
  6774.             if (_numitems > pageitems) then begin
  6775.               __copyscn(_x1, _y1+1, _x2, _y2, _x1, _y1);
  6776.               _lastpage  := _curitemnum;
  6777.               _firstpage := {succ}(
  6778.                 _curitemnum - (
  6779.                   pageitems - (
  6780.                     _numcols - (
  6781.                       _curitemnum mod _numcols
  6782.                     )
  6783.                   )
  6784.                 )
  6785.               );
  6786.               uptwnsel__(listpickptr);
  6787.             end;
  6788.           end;
  6789.  
  6790.           _pgup, _padpgup : if (_firstpage > 1) then begin
  6791.             hold := _curitemnum - _firstpage;
  6792.             if (_firstpage < pageitems) then _firstpage := 1 else
  6793.                dec(_firstpage, pageitems - _numcols);
  6794.             _lastpage := pred(_firstpage + pageitems);
  6795.             _curitemnum := _firstpage + hold;
  6796.             uptwnsel__(listpickptr);
  6797.           end;
  6798.  
  6799.           _pgdn, _padpgdn : if (_lastpage < _numitems) then begin
  6800.             hold := _curitemnum - _firstpage;
  6801.             __copyscn(_x1, _y1+1, _x2, _y2, _x1, _y1);
  6802.             inc(_lastpage, pageitems - _numcols);
  6803.             if (_lastpage > _numitems) then begin
  6804.               _lastpage  := _numitems;
  6805.               _firstpage := succ(
  6806.                 _lastpage - (
  6807.                   pageitems - (
  6808.                     _numcols - (
  6809.                       _lastpage mod _numcols
  6810.                     )
  6811.                   )
  6812.                 )
  6813.               );
  6814.               _curitemnum := _firstpage + hold;
  6815.               if (_curitemnum > _numitems) then _curitemnum := _numitems;
  6816.             end else begin
  6817.               inc(_firstpage, pageitems - _numcols);
  6818.               _curitemnum := _firstpage + hold;
  6819.             end;
  6820.             uptwnsel__(listpickptr);
  6821.           end;
  6822.         end; { case }
  6823.         __itemsel(listpickptr, _barfore, _barback, _curitemnum);
  6824.       end;
  6825.     end;
  6826.  
  6827.  
  6828.  
  6829.   begin
  6830.     __picksel := 0; retitem := '';
  6831.     with listpickptr^ do begin
  6832.       pageitems := (_numcols * (_y2 - _y1 + 1));
  6833.       if (pageitems > _numitems) then pageitems := _numitems;
  6834.       if (_firstpage = 0) then _firstpage := _curitemnum;
  6835.       if (_lastpage = 0) then _lastpage  := pageitems;
  6836.       uptwnsel__(listpickptr);
  6837.       __itemsel(listpickptr, _barfore, _barback, _curitemnum);
  6838.       initkey := false; return := false;
  6839.       repeat
  6840.         key := __retkey;
  6841.         retitem := strpointer(_curitemptr)^; found := false; movebar;
  6842.         if (key=_enter) or (key=_padenter) or (key=_esc) then return := true;
  6843.         if (key = _esc) then begin retitem := ''; _curitemnum := 0 end;
  6844.         __picksel := _curitemnum;
  6845.       until (return);
  6846.     end;
  6847.     {
  6848.     if (_selerror = _noerror_sel) then begin
  6849.       with listpickptr^ do __itemsel(listpickptr, _fore, _back, _curitemnum);
  6850.     end;
  6851.     }
  6852.   end;
  6853.  
  6854.  
  6855.  
  6856.  
  6857.   function  __zapsel(var pickptr : _pickptr) : boolean;
  6858.   begin
  6859.     __zapsel := false;
  6860.     freemem(pickptr, sizeof(_pick));
  6861.     pickptr  := nil;
  6862.     __zapsel := true;
  6863.   end;
  6864.  
  6865.  
  6866.  
  6867.  
  6868.  
  6869.  
  6870.  
  6871.  
  6872.   function __editline(var st: string; control: _editctrl): boolean;
  6873.   const
  6874.     insmode : boolean = true;
  6875.     insstrs : array[boolean] of string[3] = ('Ovr', 'Ins');
  6876.  
  6877.   var
  6878.     typekey    : char;
  6879.     strlen,
  6880.     edtlen     : byte;
  6881.     _cur, key  : word;
  6882.  
  6883.   begin
  6884.     _cur := 1;
  6885.     with control do begin
  6886.       strlen := __min(length(st), _vscncols);
  6887.       edtlen := _viewx2 - _viewx1 + 1;
  6888.       fillchar(st[strlen+1], abs(sizeof(st) - _vscncols+1), ' ');
  6889.       __write(
  6890.         _viewx1, _viewy1, _vscnfore, _vscnback,
  6891.         __rep(_viewx2 - _viewx1, ' ')
  6892.       );
  6893.       repeat
  6894.  
  6895.         if _cur <= edtlen then begin
  6896.           gotoxy(_viewx1 + _cur - 1, _viewy1);
  6897.           __write(
  6898.             _viewx1, _viewy1, _vscnfore, _vscnback, copy(st + ' ', 1, edtlen-1)
  6899.           )
  6900.         end else begin
  6901.           gotoxy(_viewx2, _viewy1);
  6902.           __write(
  6903.             _viewx1, _viewy1, _vscnfore, _vscnback,
  6904.             copy(st + ' ', (_cur - edtlen + 1), edtlen-1)
  6905.           );
  6906.         end;
  6907.  
  6908.         if _showflags then begin
  6909.           __write(_viewx1, _viewy1-1, _vscnfore, _vscnback, insstrs[insmode]);
  6910.           if _cur = 1 then __write(
  6911.             _viewx2-3, _viewy1-1, _vscnfore, _vscnback, 'Beg'
  6912.           ) else if _cur >= strlen then __write(
  6913.             _viewx2-3, _viewy1-1, _vscnfore, _vscnback, 'End'
  6914.           ) else __write(
  6915.             _viewx2-3, _viewy1-1, _vscnfore, _vscnback, '   '
  6916.           )
  6917.         end;
  6918.  
  6919.         key := __retkey; typekey := chr(lo(key));
  6920.         if not(
  6921.           (key = _esc) or (key = _padenter) or (key = _enter)
  6922.         ) then case key of
  6923.           _left, _padleft : if _cur > 1 then dec(_cur);
  6924.           _right, _padright : if (
  6925.             (_cur <= strlen) and (_cur < _vscncols)
  6926.           ) then inc(_cur);
  6927.           _home, _padhome: _cur := 1;
  6928.           _end, _padend: _cur := __min(strlen + 1, _vscncols);
  6929.           _del, _paddel : if _cur <= strlen then begin
  6930.             delete(st, _cur, 1); st[strlen] := ' '; dec(strlen);
  6931.             if (_cur > 1) and (_cur > strlen + 1) then dec(_cur);
  6932.           end;
  6933.           _ins, _padins : insmode := not insmode;
  6934.           _backspace : if _cur > 1 then begin
  6935.             if _cur > 1 then dec(_cur); delete(st, _cur, 1); dec(strlen);
  6936.           end;
  6937.           else if (
  6938.             (upcase(typekey) in [#32..#126]) and (_cur <= _vscncols)
  6939.           ) then begin
  6940.             if insmode then begin
  6941.               if strlen < _vscncols then begin
  6942.                 if _cur <= strlen then insert(typekey, st, _cur) else begin
  6943.                   st := st + typekey;
  6944.                 end;
  6945.                 inc(strlen);
  6946.                 if _cur < _vscncols then inc(_cur);
  6947.               end;
  6948.             end else begin
  6949.               if _cur <= strlen then st[_cur] := typekey else
  6950.                 if _cur <= _vscncols then begin
  6951.                   st := st + typekey;
  6952.                   inc(strlen);
  6953.                 end;
  6954.               if _cur < _vscncols then inc(_cur)
  6955.             end;
  6956.           end;
  6957.         end;
  6958.       until (key = _esc) or (key = _padenter) or (key = _enter);
  6959.     end;
  6960.     __editline := (key <> _esc);
  6961.   end;
  6962.  
  6963.  
  6964.  
  6965.  
  6966.  
  6967.  
  6968.   procedure __totalmem;
  6969.   var reg : registers;
  6970.   begin
  6971.     with reg do begin
  6972.       intr($12, reg);
  6973.       dosmemory := ax;
  6974.       if true then begin
  6975.         ax := $8800;
  6976.         intr($15, reg);
  6977.         extmemory := ax
  6978.       end else extmemory := 0
  6979.     end
  6980.   end;
  6981.  
  6982.  
  6983.  
  6984.  
  6985.  
  6986.   procedure __availmem;
  6987.   const
  6988.     copyoff = $12;
  6989.     adsoff  = $2c;
  6990.  
  6991.   var
  6992.     vdiskptr     : pointer;
  6993.     copynotice   : string[5];
  6994.     temp         : longint;
  6995.     reg          : registers;
  6996.     firstmemptr  : pointer;
  6997.     deviceofs    : word;
  6998.     deviceptr    : pointer;
  6999.  
  7000.   begin
  7001.     with reg do begin
  7002.       ah := $48;
  7003.       bx := $ffff;
  7004.       intr($21, reg);
  7005.       dosmemory := bx shr 6;
  7006.       if (dosmemory > 0) then begin
  7007.         ah := $48;
  7008.         intr($21, reg);
  7009.         memptr := ptr(ax, 0);
  7010.         es     := ax;
  7011.         ah     := $49;
  7012.         intr($21, reg)
  7013.       end else memptr := nil;
  7014.       if false  then begin
  7015.         extads._hibyte := 0;
  7016.         extads._loword := 0;
  7017.         extmemory      := 0
  7018.       end else begin
  7019.         ah := $88;
  7020.         intr($15, reg);
  7021.         extmemory := ax;
  7022.         ah := $52;
  7023.         intr($21, reg);
  7024.         firstmemptr := ptr(memw[es:bx - 2] + 1, 0);
  7025.         if (_dosmajorver = 2) then deviceofs := $17 else
  7026.           if (
  7027.             (_dosminorver = 0) and (_dosmajorver = 3)
  7028.           ) then deviceofs := $28 else deviceofs := $22;
  7029.         deviceptr := pointer(meml[es:bx + deviceofs]);
  7030.         with extads do begin
  7031.           _hibyte := $10;
  7032.           _loword := 0
  7033.         end;
  7034.         temp := 0;
  7035.         while (__ptr2lsup(deviceptr) >= __ptr2lsup(firstmemptr)) do begin
  7036.           vdiskptr := ptr(_vectoraddr(deviceptr)._seg, $12);
  7037.           move(vdiskptr^, copynotice[1], 5);
  7038.           copynotice[0] := char(5);
  7039.           if (copynotice = 'VDISK') then begin
  7040.             vdiskptr := ptr(_vectoraddr(deviceptr)._seg, $2c);
  7041.             move(vdiskptr^, extads, 3);
  7042.             with extads do temp := (
  7043.               (
  7044.                 (longint(_loword) + 1023) div 1024) +
  7045.                 64 * longint(_hibyte - $10
  7046.               )
  7047.             );
  7048.           end;
  7049.           deviceptr := pointer(deviceptr^)
  7050.         end;
  7051.         dec(extmemory, word(temp));
  7052.         if (extmemory = 0) then fillchar(extads, sizeof(_xads), 0)
  7053.       end
  7054.     end
  7055.   end;
  7056.  
  7057.  
  7058.  
  7059.  
  7060.  
  7061.   function __sizemem;
  7062.   begin
  7063.     with progsize do begin
  7064.       _codesize  := dseg - prefixseg;
  7065.       _datasize  := sseg - dseg;
  7066. {$IFNDEF VER40}
  7067.       _overlaysize := ovrheapend - ovrheaporg;
  7068. {$ELSE}
  7069.       _overlaysize := 0;
  7070. {$ENDIF}
  7071.       _stacksize := _vectoraddr(heaporg)._seg - sseg - _overlaysize;
  7072.       _heapsize  := memw[prefixseg:2] - _vectoraddr(heaporg)._seg;
  7073.       __sizemem  := _codesize + _datasize + _stacksize +
  7074.         _overlaysize + _heapsize
  7075.     end
  7076.   end;
  7077.  
  7078.  
  7079.  
  7080.  
  7081.  
  7082.   function __tophpmem;
  7083.   var
  7084.     topmem   : word;
  7085.     freeofs  : word;
  7086.     blockptr : _3freerecptr;
  7087.  
  7088.   begin
  7089. {$IFDEF VER3HEAP}
  7090.     freesize := 0;
  7091.     blockptr := freelist;
  7092.     while (blockptr <> heapptr) do with blockptr^ do begin
  7093.       inc(freesize);
  7094.       blockptr := _nextfree
  7095.     end;
  7096.     freesize   := freesize * sizeof(_freerec);
  7097.     __tophpmem := __ptr2lsup(heapend) - __ptr2lsup(heapptr);
  7098. {$ELSE}
  7099.     freeofs := _vectoraddr(freeptr)._ofs;
  7100.     if (freeofs <> 0) then freesize := $ffff - freeofs + 1 else
  7101.       freesize := 0;
  7102.     topmem     := memw[prefixseg:2];
  7103.     __tophpmem := 16 * longint(topmem - _vectoraddr(heapptr)._seg) -
  7104.       longint(_vectoraddr(heapptr)._ofs) - longint(freesize)
  7105. {$ENDIF}
  7106.   end;
  7107.  
  7108.  
  7109.  
  7110.  
  7111.  
  7112.   procedure __heapmem;
  7113.   var
  7114.     newfreeptr       : pointer;
  7115.     freeofs, freetop  : word;
  7116.     freesize, adjust  : word;
  7117.     topmem, newtopmem : word;
  7118.     newprogsize      : word;
  7119.     heapreqpars      : word;
  7120.     newtopptr        : word;
  7121.     freelistaddress  : longint;
  7122.     topheapaddress   : longint;
  7123.     newheapaddress   : longint;
  7124.  
  7125.   begin
  7126.     newmaxavail := maxavail;
  7127.     if (abs(maxavail - heaprequest) < 16) then errorcode := 0 else begin
  7128.       if (heaprequest > $a0000) then heaprequest := $a0000 else
  7129.         if (heaprequest < 0) then heaprequest := 0;
  7130. {$IFNDEF VER3HEAP}
  7131.       inc(heaprequest, freemin);
  7132. {$ENDIF}
  7133.       heapreqpars := word((heaprequest + 15) div 16);
  7134. {$IFDEF VER3HEAP}
  7135.       newtopmem := _vectoraddr(heapptr)._seg + heapreqpars;
  7136.       __altermem(newtopmem - prefixseg, ptr(prefixseg, 0), newprogsize, errorcode);
  7137.       if (errorcode = 8) then newtopmem := newprogsize + prefixseg else
  7138.         if (errorcode <> 0) then exit;
  7139.       heapend           := ptr(newtopmem, 0);
  7140.       memw[prefixseg:2] := newtopmem;
  7141.       newmaxavail       := maxavail;
  7142. {$ELSE}
  7143.       topmem  := memw[prefixseg:2];
  7144.       freeofs := _vectoraddr(freeptr)._ofs;
  7145.       if (freeofs <> 0) then begin
  7146.         freesize := $ffff - freeofs + 1;
  7147.         newtopptr       := _vectoraddr(heapptr)._seg + heapreqpars;
  7148.         newheapaddress  := 16 * longint(newtopptr);
  7149.         freelistaddress := __ptr2lsup(freeptr);
  7150.         topheapaddress  := 16 * longint(topmem);
  7151.         if (
  7152.           (newheapaddress > freelistaddress) and
  7153.           (newheapaddress < topheapaddress)
  7154.         ) then begin
  7155.           errorcode := 10;
  7156.           exit
  7157.         end
  7158.       end else freesize := 0;
  7159.       freetop   := _vectoraddr(heapptr)._ofs + freesize;
  7160.       if ((freetop mod 16) <> 0) then adjust := 16 - (freetop mod 16) else
  7161.         adjust := 0;
  7162.       newtopmem := _vectoraddr(heapptr)._seg + heapreqpars +
  7163.         ((freetop + adjust) div 16);
  7164.       __altermem(newtopmem - prefixseg, ptr(prefixseg, 0), newprogsize, errorcode);
  7165.       if (errorcode = 8) then newtopmem := newprogsize + prefixseg else
  7166.         if (errorcode <> 0) then exit;
  7167.       newfreeptr := ptr(newtopmem - $1000, freeofs);
  7168.       inline($fa);
  7169.       move(freeptr^, newfreeptr^, freesize);
  7170.       freeptr           := newfreeptr;
  7171.       memw[prefixseg:2] := newtopmem;
  7172.       newmaxavail       := maxavail;
  7173.       inline($fb)
  7174. {$ENDIF}
  7175.     end
  7176.   end;
  7177.  
  7178.  
  7179.  
  7180.  
  7181.  
  7182.  
  7183.   procedure __allocmem;
  7184.   var reg : registers;
  7185.   begin
  7186.     with reg do begin
  7187.       ah := $48;
  7188.       bx := blockreq;
  7189.       intr($21, reg);
  7190.       if ((flags and fcarry) <> 0) then begin
  7191.         errorcode := ax;
  7192.         if (ax = 8) then allocsize := bx else allocsize := 0;
  7193.         memptr := nil
  7194.       end else begin
  7195.         allocsize := blockreq;
  7196.         memptr    := ptr(ax, 0);
  7197.         errorcode := 0
  7198.       end
  7199.     end
  7200.   end;
  7201.  
  7202.  
  7203.  
  7204.  
  7205.  
  7206.   procedure __freemem;
  7207.   var reg : registers;
  7208.   begin
  7209.     with reg do begin
  7210.       ah := $49;
  7211.       es := _vectoraddr(memptr)._seg;
  7212.       intr($21, reg);
  7213.       if ((flags and fcarry) <> 0) then errorcode := ax else errorcode := 0
  7214.     end
  7215.   end;
  7216.  
  7217.  
  7218.  
  7219.  
  7220.  
  7221.  
  7222.   procedure __altermem;
  7223.   var reg : registers;
  7224.   begin
  7225.     with reg do begin
  7226.       ah := $4a;
  7227.       bx := blockreq;
  7228.       es := _vectoraddr(memptr)._seg;
  7229.       intr($21, reg);
  7230.       if ((flags and fcarry) <> 0) then begin
  7231.         errorcode := ax;
  7232.         if (ax = 8) then altersize := bx else altersize := 0
  7233.       end else begin
  7234.         altersize := blockreq;
  7235.         errorcode := 0
  7236.       end
  7237.     end
  7238.   end;
  7239.  
  7240.  
  7241.  
  7242.  
  7243.  
  7244.   function __firstmem : pointer;
  7245.   var reg : registers;
  7246.   begin
  7247.     with reg do begin
  7248.       ah := $52;
  7249.       intr($21, reg);
  7250.       __firstmem := ptr(memw[es:bx - 2] + 1, 0)
  7251.     end
  7252.   end;
  7253.  
  7254.  
  7255.  
  7256.  
  7257.  
  7258.  
  7259.   function __ctrlmem;
  7260.   var blockptr : ^_memctrl;
  7261.   begin
  7262.     blockptr := ptr(_vectoraddr(memptr)._seg - 1, _vectoraddr(memptr)._ofs);
  7263.     with blockptr^ do if ((_header <> 'M') and (_header <> 'Z')) then begin
  7264.       __ctrlmem := nil;
  7265.       fillchar(memblock, sizeof(_memctrl), #0)
  7266.     end else begin
  7267.       move(blockptr^, memblock, sizeof(_memctrl));
  7268.       if (_header = 'Z') then __ctrlmem := nil else
  7269.         __ctrlmem := ptr(_vectoraddr(blockptr)._seg + _size + 2, 0)
  7270.     end
  7271.   end;
  7272.  
  7273.  
  7274.  
  7275.  
  7276.  
  7277.   procedure __hookmem;
  7278.   var
  7279.     vectortable : array[0..255] of pointer absolute 0:0;
  7280.     i           : integer;
  7281.     found       : boolean;
  7282.     nextptr     : pointer;
  7283.     thisptr     : pointer;
  7284.     progblock   : _memctrl;
  7285.     beginaddr   : longint;
  7286.     endaddr     : longint;
  7287.     thisaddr    : longint;
  7288.  
  7289.   begin
  7290.     thisptr := ptr(progseg, 0);
  7291.     nextptr := __ctrlmem(thisptr, progblock);
  7292.     with progblock do begin
  7293.       if (_header = #0) then begin
  7294.         hookvecno := -1;
  7295.         exit
  7296.       end;
  7297.       beginaddr := __ptr2lsup(thisptr);
  7298.       endaddr   := beginaddr + (16 * longint(_size));
  7299.     end;
  7300.     i := hookvecno; found := false;
  7301.     if ((i < 0) or (i > 255)) then begin hookvecno := -1; exit end;
  7302.     while ((i <= 255) and (not found)) do begin
  7303.       thisaddr := __ptr2lsup(vectortable[i]);
  7304.       if (
  7305.         (beginaddr <= thisaddr) and (thisaddr <= endaddr)
  7306.       ) then found := true else begin
  7307.         inc(i);
  7308.         if (i = $30) then inc(i, 2)
  7309.       end
  7310.     end;
  7311.     if (found) then hookvecno := i else hookvecno := -1
  7312.   end;
  7313.  
  7314.  
  7315.  
  7316.  
  7317.  
  7318.  
  7319.  
  7320.  
  7321.  
  7322.   function __rnilmem;
  7323.   var
  7324.     newmaxavail  : longint;
  7325.     prevmaxavail : longint;
  7326.     heaprequest  : longint;
  7327.     errorcode    : word;
  7328.  
  7329.   begin
  7330.     if ((_alloconfail = 0) or (blocksize = 0)) then __rnilmem := 1 else begin
  7331.       prevmaxavail := maxavail;
  7332.       if (blocksize > _alloconfail) then heaprequest := blocksize else
  7333.         if (_alloconfail > _max_getmem) then heaprequest := $a0000 else
  7334.           heaprequest := _alloconfail;
  7335.       __heapmem(heaprequest, newmaxavail, errorcode);
  7336.       if (
  7337.         (errorcode = 0) or (
  7338.           (errorcode = 8) and (newmaxavail > prevmaxavail)
  7339.         )
  7340.       ) then __rnilmem := 2 else __rnilmem := 1;
  7341.     end
  7342.   end;
  7343.  
  7344.  
  7345.  
  7346.  
  7347.  
  7348.  
  7349.   procedure errorexit;
  7350.   begin
  7351.     exitproc  := prevexitproc_;
  7352.     erroraddr := calleraddr_;
  7353.     inline($fb)
  7354.   end;
  7355.  
  7356.  
  7357.  
  7358.   procedure __hgetmem(var p : pointer; blockreq : longint);
  7359.   const heapfuncreturn : integer = 0;
  7360.   var
  7361.     numfree, i       : word;
  7362.     lastfreeindex   : integer;
  7363.     found           : boolean;
  7364.     freesize        : longint;
  7365.     thisptr, prevptr : _3freerecptr;
  7366.  
  7367.  
  7368.  
  7369.     procedure hgethalt;
  7370.     begin
  7371.       inline($fa);
  7372.       prevexitproc_ := exitproc;
  7373.       exitproc      := @errorexit;
  7374.       calleraddr_   := __caddrsup;
  7375.       halt(203)
  7376.     end;
  7377.  
  7378.  
  7379.   begin
  7380.     p := nil;
  7381.     if (blockreq <= _max_getmem) then begin
  7382.       getmem(p, word(blockreq));
  7383.       exit
  7384.     end;
  7385.  
  7386.     while (blockreq > maxavail) do if (heaperror=nil) then hgethalt else begin
  7387.       inline(
  7388.         $b8/$ff/$ff/
  7389.         $50/
  7390.         $ff/$1e/heaperror/
  7391.         $a3/heapfuncreturn
  7392.       );
  7393.       case heapfuncreturn of
  7394.         1 : exit;
  7395.         2 : ;
  7396.         else hgethalt
  7397.       end;
  7398.     end;
  7399.  
  7400. {$IFDEF VER3HEAP}
  7401.     i := blockreq mod 8;
  7402.     if (i <> 0) then blockreq := blockreq + (8 - i);
  7403.     found    := false;
  7404.     thisptr  := freelist;
  7405.     prevptr  := freelist;
  7406.     while ((thisptr <> heapptr) and (not found)) do with thisptr^ do begin
  7407.       freesize := __ptr2lsup(_blocksize);
  7408.       if (freesize > blockreq) then begin
  7409.         __dptrsup(_blocksize, blockreq);
  7410.         p     := _blocksize;
  7411.         found := true
  7412.       end else if (freesize = blockreq) then begin
  7413.         p := thisptr;
  7414.         if (prevptr <> freelist) then prevptr^._nextfree := _nextfree else
  7415.           freelist := _nextfree;
  7416.         found := true
  7417.       end;
  7418.       prevptr := thisptr;
  7419.       thisptr := _nextfree
  7420.     end;
  7421.  
  7422.     if (not found) then begin
  7423.       p := heapptr;
  7424.       __iptrsup(heapptr, blockreq);
  7425.       if (freelist = p) then freelist := heapptr;
  7426.     end
  7427.  
  7428. {$ELSE}
  7429.  
  7430.     numfree       := (8192 - (_vectoraddr(freeptr)._ofs shr 3)) mod 8192;
  7431.     lastfreeindex := integer(numfree) - 1;
  7432.     found         := false;
  7433.     i             := 0;
  7434.     while ((not found) and (i <= lastfreeindex)) do begin
  7435.       with _freelist(freeptr^)[i] do freesize := __ptr2lsup(_nextblockptr) -
  7436.         __ptr2lsup(_freeblockptr);
  7437.       if (blockreq > freesize) then inc(i) else found := true
  7438.     end;
  7439.  
  7440.     if (found) then with _freelist(freeptr^)[i] do begin
  7441.       p := _freeblockptr;
  7442.       if (blockreq = freesize) then begin
  7443.         _freelist(freeptr^)[i] := _freelist(freeptr^)[0];
  7444.         freeptr := ptr(_vectoraddr(freeptr)._seg, _vectoraddr(freeptr)._ofs + 8);
  7445.       end else __iptrsup(_freeblockptr, blockreq)
  7446.     end else begin p := heapptr; __iptrsup(heapptr, blockreq) end
  7447. {$ENDIF}
  7448.   end;
  7449.  
  7450.  
  7451.  
  7452.  
  7453.  
  7454.  
  7455.   procedure __hfreemem;
  7456.   var
  7457. {$IFDEF VER3HEAP}
  7458.     i             : word;
  7459.     q             : _3freerecptr;
  7460.     nextblock     : _3freerecptr;
  7461.     nextfree      : _3freerecptr;
  7462.     nextcheck     : pointer;
  7463.     done          : boolean;
  7464. {$ELSE}
  7465.     topheap       : pointer;
  7466.     newfreeptr    : pointer;
  7467.     newfreerec    : _freerec;
  7468.     numfree       : word;
  7469.     lastfreeindex : integer;
  7470.     i             : integer;
  7471.     freelistptr   : ^_freelist absolute freeptr;
  7472. {$ENDIF}
  7473.  
  7474.  
  7475.  
  7476.     procedure hfreehalt;
  7477.     begin
  7478.       inline($fa);
  7479.       prevexitproc_ := exitproc;
  7480.       exitproc      := @errorexit;
  7481.       calleraddr_   := __caddrsup;
  7482.       halt(204)
  7483.     end;
  7484.  
  7485.  
  7486.   begin
  7487. {$IFDEF VER3HEAP}
  7488.     if (p = nil) then runerror(204);
  7489.     if (blocksize <= _max_getmem) then begin
  7490.       freemem(p, word(blocksize));
  7491.       exit
  7492.     end;
  7493.     i := blocksize mod 8;
  7494.     if (i <> 0) then blocksize := blocksize + (8 - i);
  7495.     if (__ptr2lsup(p) < __ptr2lsup(freelist)) then begin
  7496.       with _3freerec(p^) do begin
  7497.         _nextfree := freelist;
  7498.         with _vectoraddr(_blocksize) do begin
  7499.           _seg := blocksize div 16;
  7500.           _ofs := blocksize mod 16
  7501.         end;
  7502.       end;
  7503.       freelist := p
  7504.     end else begin
  7505.       done := false;
  7506.       q    := freelist;
  7507.       while ((q <> heapptr) and (not done)) do with q^ do begin
  7508.         nextblock := q;
  7509.         __iptrsup(pointer(nextblock), __ptr2lsup(_blocksize));
  7510.         if (
  7511.           __ptr2lsup(p) < __ptr2lsup(nextblock)
  7512.         ) then runerror(204) else begin
  7513.           nextcheck := p;
  7514.           __iptrsup(nextcheck, blocksize);
  7515.           if (__ptr2lsup(nextcheck) <= __ptr2lsup(_nextfree)) then begin
  7516.             _3freerec(p^)._nextfree  := _nextfree;
  7517.             with _vectoraddr(_3freerec(p^)._blocksize) do begin
  7518.               _seg := blocksize div 16;
  7519.               _ofs := blocksize mod 16
  7520.             end;
  7521.             _nextfree := p;
  7522.             done := true
  7523.           end else q := _nextfree
  7524.         end
  7525.       end
  7526.     end;
  7527.  
  7528.     q := freelist;
  7529.     while (q <> heapptr) do begin
  7530.       nextfree  := q;
  7531.       nextblock := nextfree;
  7532.       blocksize := 0;
  7533.       repeat
  7534.         inc(blocksize, __ptr2lsup(nextfree^._blocksize));
  7535.         __iptrsup(pointer(nextblock), __ptr2lsup(nextfree^._blocksize));
  7536.         nextfree  := nextfree^._nextfree;
  7537.       until ((nextblock <> nextfree) or (nextfree = heapptr));
  7538.  
  7539.       if (
  7540.         (nextblock = nextfree) and (nextfree = heapptr)
  7541.       ) then heapptr := q else begin
  7542.         with q^ do begin
  7543.           _nextfree  := nextfree;
  7544.           with _vectoraddr(_blocksize) do begin
  7545.             _seg := blocksize div 16;
  7546.             _ofs := blocksize mod 16
  7547.           end
  7548.         end;
  7549.         q := nextfree
  7550.       end
  7551.     end
  7552.  
  7553. {$ELSE}
  7554.  
  7555.     if (
  7556.       _vectoraddr(freeptr)._ofs = 0
  7557.     ) then topheap := ptr(_vectoraddr(freeptr)._seg, $ffff) else
  7558.       topheap := freeptr;
  7559.     __dptrsup(topheap, freemin);
  7560.     if (
  7561.       (blocksize <= 0) or (__ptr2lsup(p) > __ptr2lsup(topheap)
  7562.     ) or (__ptr2lsup(p) < __ptr2lsup(heaporg))) then hfreehalt;
  7563.  
  7564.     if (blocksize <= _max_getmem) then begin
  7565.       freemem(p, word(blocksize));
  7566.       exit
  7567.     end;
  7568.  
  7569.     with newfreerec do begin
  7570.       _freeblockptr := p;
  7571.       _nextblockptr := p;
  7572.       __iptrsup(_nextblockptr, blocksize)
  7573.     end;
  7574.  
  7575.     numfree       := (8192 - (_vectoraddr(freeptr)._ofs shr 3)) mod 8192;
  7576.     lastfreeindex := integer(numfree) - 1;
  7577.     with newfreerec do if (_nextblockptr = heapptr) then begin
  7578.       heapptr := _freeblockptr;
  7579.       for i := 0 to lastfreeindex do if (
  7580.         freelistptr^[i]._nextblockptr = heapptr
  7581.       ) then begin
  7582.         heapptr := freelistptr^[i]._freeblockptr;
  7583.         freelistptr^[i]._freeblockptr := nil
  7584.       end
  7585.     end else begin
  7586.       for i := 0 to lastfreeindex do if (
  7587.         freelistptr^[i]._freeblockptr = _nextblockptr
  7588.       ) then begin
  7589.         _nextblockptr := freelistptr^[i]._nextblockptr;
  7590.         freelistptr^[i]._freeblockptr := nil
  7591.       end else if (freelistptr^[i]._nextblockptr = _freeblockptr) then begin
  7592.         _freeblockptr := freelistptr^[i]._freeblockptr;
  7593.         freelistptr^[i]._freeblockptr := nil
  7594.       end;
  7595.       newfreeptr := ptr(
  7596.         _vectoraddr(freeptr)._seg, _vectoraddr(freeptr)._ofs - 8
  7597.       );
  7598.       if (__ptr2lsup(newfreeptr) < __ptr2lsup(heapptr)) then hfreehalt;
  7599.       freeptr := newfreeptr;
  7600.       inc(lastfreeindex);
  7601.       freelistptr^[0] := newfreerec
  7602.     end;
  7603.  
  7604.     for i := lastfreeindex downto 0 do if (
  7605.       freelistptr^[i]._freeblockptr = nil
  7606.     ) then begin
  7607.       freelistptr^[i] := freelistptr^[0];
  7608.       freeptr         := ptr(
  7609.         _vectoraddr(freeptr)._seg, _vectoraddr(freeptr)._ofs + 8
  7610.       )
  7611.     end
  7612. {$ENDIF}
  7613.   end;
  7614.  
  7615.   {$F+}
  7616.   function __fetchmem; external;
  7617.   {$F-}
  7618.  
  7619.  
  7620.  
  7621.  
  7622.  
  7623.  
  7624. { sort management }
  7625. const
  7626.   comparesrt_  : pointer = nil;
  7627.   iosrt_       : pointer = nil;
  7628.   recsizesrt_  : word    = 0;
  7629.   maxrecsrt_   : word    = 0;
  7630.   lastrecsrt_  : word    = 0;
  7631.   curpossrt_   : longint = 0;
  7632.   sortdatasrt_ : boolean = false;
  7633.   inmemorysrt_ : boolean = false;
  7634.   variablesrt_ : boolean = false;
  7635.   insortsrt_   : boolean = false;
  7636.  
  7637.  
  7638.  
  7639.  
  7640.   function calllesssrt__(var data1, data2): boolean;
  7641.   inline($ff/$1e/comparesrt_);
  7642.  
  7643.  
  7644.   procedure calliosrt__;
  7645.   inline($ff/$1e/iosrt_);
  7646.  
  7647.   {$F+}
  7648.   function  ritemsrt__(
  7649.     p: pointer; itemsize: word; itemnum: word
  7650.   ): pointer; external;
  7651.   {$L RITEMSRT}
  7652.  
  7653.  
  7654.  
  7655.   procedure __isortsrt;
  7656.   var
  7657.     i, j       : word;
  7658.     insertptr : pointer;
  7659.  
  7660.   begin
  7661.     _numsortedsrt := 0;
  7662.     if (numrecords = 0) then exit;
  7663.     comparesrt_ := lessfunction;
  7664.     getmem(insertptr, recordsize);
  7665.     if (insertptr = nil) then exit;
  7666.     for i := 1 to (numrecords - 1) do begin
  7667.       j := i - 1;
  7668.       move(ritemsrt__(dataptr, recordsize, i)^, insertptr^, recordsize);
  7669.       while (
  7670.         (j < i) and
  7671.         calllesssrt__(insertptr^, ritemsrt__(dataptr, recordsize, j)^)
  7672.       ) do begin
  7673.         move(
  7674.           ritemsrt__(dataptr, recordsize, j)^,
  7675.           ritemsrt__(dataptr, recordsize, j + 1)^,
  7676.           recordsize
  7677.         );
  7678.         dec(j)
  7679.       end;
  7680.       move(insertptr^, ritemsrt__(dataptr, recordsize, j + 1)^, recordsize);
  7681.     end;
  7682.     _numsortedsrt := numrecords;
  7683.     freemem(insertptr, recordsize);
  7684.   end;
  7685.  
  7686.  
  7687.  
  7688.  
  7689.   procedure __qsortsrt;
  7690.   const stack_max = 16;
  7691.   type
  7692.     stacksize = 1..stack_max;
  7693.     partition = record
  7694.       lower : word;
  7695.       upper : word
  7696.     end;
  7697.  
  7698.   var
  7699.     parstack      : array[stacksize] of partition;
  7700.     parstacktop   : word;
  7701.     lindex, rindex : word;
  7702.     i, j           : word;
  7703.     lparsize      : word;
  7704.     rparsize      : word;
  7705.     parsize       : word;
  7706.     pivotdataptr  : pointer;
  7707.     tempdataptr   : pointer;
  7708.     tempptr1      : pointer;
  7709.     tempptr2      : pointer;
  7710.  
  7711.   begin
  7712.     if (numrecords <= _useinsertsrt) then begin
  7713.       __isortsrt(dataptr, numrecords, recordsize, lessfunction);
  7714.       exit
  7715.     end;
  7716.     comparesrt_   := lessfunction;
  7717.     _numsortedsrt := 0;
  7718.  
  7719.     getmem(pivotdataptr, recordsize);
  7720.     if (pivotdataptr = nil) then exit;
  7721.     getmem(tempdataptr, recordsize);
  7722.     if (tempdataptr = nil) then begin
  7723.       freemem(pivotdataptr, recordsize);
  7724.       exit
  7725.     end;
  7726.  
  7727.     parstacktop := 1;
  7728.     with parstack[1] do begin
  7729.       lower := 0;
  7730.       upper := numrecords - 1;
  7731.     end;
  7732.  
  7733.     repeat
  7734.       with parstack[parstacktop] do begin
  7735.         lindex := lower;
  7736.         rindex := upper
  7737.       end;
  7738.       dec(parstacktop);
  7739.  
  7740.       repeat
  7741.         i := lindex;
  7742.         j := rindex;
  7743.         move(
  7744.           ritemsrt__(dataptr, recordsize, (lindex + rindex) div 2)^,
  7745.           pivotdataptr^, recordsize
  7746.         );
  7747.  
  7748.         repeat
  7749.           while calllesssrt__(
  7750.             ritemsrt__(dataptr, recordsize, i)^,
  7751.             pivotdataptr^
  7752.           ) do inc(i);
  7753.           while calllesssrt__(
  7754.             pivotdataptr^,
  7755.             ritemsrt__(dataptr, recordsize, j)^
  7756.           ) do dec(j);
  7757.           if (i <= j) then begin
  7758.             tempptr1 := ritemsrt__(dataptr, recordsize, i);
  7759.             tempptr2 := ritemsrt__(dataptr, recordsize, j);
  7760.             move(tempptr2^, tempdataptr^, recordsize);
  7761.             move(tempptr1^, tempptr2^, recordsize);
  7762.             move(tempdataptr^, tempptr1^, recordsize);
  7763.             inc(i);
  7764.             dec(j)
  7765.           end
  7766.         until (i > j);
  7767.  
  7768.         rparsize := rindex - i;
  7769.         lparsize := j - lindex;
  7770.         if (rparsize = 0) then rindex := j else
  7771.           if (lparsize = 0) then lindex := i else
  7772.             if (rparsize > lparsize) then begin
  7773.               if (rparsize <= _useinsertsrt) then __isortsrt(
  7774.                 ritemsrt__(dataptr, recordsize, i),
  7775.                 rparsize + 1, recordsize, lessfunction
  7776.               ) else begin
  7777.                 inc(parstacktop);
  7778.                 with parstack[parstacktop] do begin
  7779.                   lower := i;
  7780.                   upper := rindex
  7781.                 end
  7782.               end;
  7783.               rindex := j
  7784.             end else begin
  7785.               if (lparsize <= _useinsertsrt) then __isortsrt(
  7786.                 ritemsrt__(dataptr, recordsize, lindex),
  7787.                 lparsize + 1, recordsize, lessfunction
  7788.               ) else begin
  7789.                 inc(parstacktop);
  7790.                 with parstack[parstacktop] do begin
  7791.                   lower := lindex;
  7792.                   upper := j
  7793.                 end
  7794.               end;
  7795.               lindex := i
  7796.             end;
  7797.         parsize := rindex - lindex
  7798.       until (parsize <= _useinsertsrt);
  7799.       if (parsize > 0) then __isortsrt(
  7800.         ritemsrt__(dataptr, recordsize, lindex),
  7801.         parsize + 1, recordsize, lessfunction
  7802.       )
  7803.     until (parstacktop = 0);
  7804.     _numsortedsrt := numrecords;
  7805.     freemem(pivotdataptr, recordsize);
  7806.     freemem(tempdataptr, recordsize)
  7807.   end;
  7808.  
  7809.  
  7810.  
  7811.  
  7812.  
  7813.  
  7814.   procedure __addsrt;
  7815.   var
  7816.     tempdataptr : pointer;
  7817.     recordsize  : word;
  7818.  
  7819.   begin
  7820.     if ((dataptr = nil) or (not insortsrt_)) then begin
  7821.       errorcode := 2;
  7822.       exit
  7823.     end else errorcode := 0;
  7824.  
  7825.     if ((not variablesrt_) and (lastrecsrt_ > maxrecsrt_)) then begin
  7826.       errorcode := 1;
  7827.       exit
  7828.     end;
  7829.  
  7830.     if (not inmemorysrt_) then begin
  7831.       tempdataptr := _datasrt;
  7832.       __iptrsup(tempdataptr, curpossrt_);
  7833.       if (not variablesrt_) then recordsize := recsizesrt_ else begin
  7834.         recordsize := byte(dataptr^);
  7835.         inc(recordsize);
  7836.         if ((curpossrt_ + recordsize) > _datasizesrt) then begin
  7837.           errorcode := 1;
  7838.           exit
  7839.         end
  7840.       end;
  7841.       move(dataptr^, tempdataptr^, recsizesrt_);
  7842.       inc(curpossrt_, recordsize)
  7843.     end else tempdataptr := dataptr;
  7844.     if (not sortdatasrt_) then move(
  7845.       tempdataptr, ritemsrt__(_ptrsrt, sizeof(pointer), lastrecsrt_)^,
  7846.       sizeof(pointer)
  7847.     );
  7848.     inc(lastrecsrt_)
  7849.   end;
  7850.  
  7851.  
  7852.  
  7853.  
  7854.   procedure __retsrt;
  7855.   begin
  7856.     if (not insortsrt_) then begin
  7857.       errorcode := 2;
  7858.       exit
  7859.     end else errorcode := 0;
  7860.     if (lastrecsrt_ >= _numsortedsrt) then begin
  7861.       errorcode := 1;
  7862.       exit
  7863.     end;
  7864.  
  7865.     if (not sortdatasrt_) then dataptr := pointer(
  7866.       ritemsrt__(_ptrsrt, sizeof(pointer), lastrecsrt_)^
  7867.     ) else dataptr := ritemsrt__(_datasrt, recsizesrt_, lastrecsrt_);
  7868.     inc(lastrecsrt_)
  7869.   end;
  7870.  
  7871.  
  7872.  
  7873.  
  7874.   procedure __sortsrt;
  7875.   var
  7876.     tempptr : pointer;
  7877.     tempsrt : word;
  7878.  
  7879.   begin
  7880.     _numsortedsrt := 0;
  7881.     errorcode     := 0;
  7882.     if ((_datasrt <> nil) and (_datasizesrt <> 0)) then
  7883.       __hfreemem(_datasrt, _datasizesrt);
  7884.     if ((_ptrsrt <> nil) and (_ptrsizesrt <> 0)) then
  7885.       __hfreemem(_ptrsrt, _ptrsizesrt);
  7886.     recsizesrt_  := recordsize;
  7887.     maxrecsrt_   := maxrecords - 1;
  7888.     lastrecsrt_  := 0;
  7889.     curpossrt_   := 0;
  7890.     variablesrt_ := ((sortcontrol and _variable_srt) <> 0);
  7891.     inmemorysrt_ := ((sortcontrol and _inmemory_srt) <> 0);
  7892.     sortdatasrt_ := (
  7893.       (
  7894.         ((sortcontrol and _sortdata_srt) <> 0) or
  7895.         (recordsize <= 4)
  7896.       ) and
  7897.       (not inmemorysrt_) and (not variablesrt_)
  7898.     );
  7899.  
  7900.     if (sortdatasrt_) then begin
  7901.       _ptrsrt      := nil;
  7902.       _ptrsizesrt  := 0
  7903.     end else begin
  7904.       _ptrsizesrt  := sizeof(pointer) * longint(maxrecords);
  7905.       __hgetmem(_ptrsrt, _ptrsizesrt);
  7906.       if (_ptrsrt = nil) then begin errorcode := 1; exit end
  7907.     end;
  7908.  
  7909.     if (inmemorysrt_) then begin
  7910.       _datasrt     := nil;
  7911.       _datasizesrt := 0
  7912.     end else begin
  7913.       _datasizesrt := recordsize * longint(maxrecords);
  7914.       __hgetmem(_datasrt, _datasizesrt);
  7915.       if (_datasrt = nil) then begin
  7916.         _datasizesrt := maxavail - (3 * recordsize);
  7917.         maxrecsrt_   := _datasizesrt div recordsize;
  7918.         __hgetmem(_datasrt, _datasizesrt);
  7919.         if (_datasrt = nil) then begin errorcode := 1; exit end
  7920.       end
  7921.     end;
  7922.  
  7923.     insortsrt_ := true;
  7924.     if (inputproc <> nil) then begin
  7925.       iosrt_ := inputproc;
  7926.       calliosrt__
  7927.     end else begin
  7928.       errorcode  := 2;
  7929.       insortsrt_ := false;
  7930.       exit
  7931.     end;
  7932.  
  7933.     if ((_datasrt <> nil) and (curpossrt_ < _datasizesrt)) then begin
  7934.       tempptr := _datasrt;
  7935.       tempsrt := curpossrt_ mod 8;
  7936.       if (tempsrt <> 0) then curpossrt_ := curpossrt_ + (8 - tempsrt);
  7937.       __iptrsup(tempptr, curpossrt_);
  7938.       __hfreemem(tempptr, _datasizesrt - curpossrt_);
  7939.       _datasizesrt := curpossrt_
  7940.     end;
  7941.     if ((_ptrsrt <> nil) and (lastrecsrt_ < maxrecords)) then begin
  7942.       tempptr     := _ptrsrt;
  7943.       _ptrsizesrt := longint(lastrecsrt_) * sizeof(pointer);
  7944.       tempsrt := _ptrsizesrt mod 8;
  7945.       if (tempsrt <> 0) then _ptrsizesrt := _ptrsizesrt + (8 - tempsrt);
  7946.       __iptrsup(tempptr, _ptrsizesrt);
  7947.       __hfreemem(tempptr, (longint(maxrecords) * sizeof(pointer)) - _ptrsizesrt)
  7948.     end;
  7949.  
  7950.     if (sortdatasrt_) then __qsortsrt(
  7951.       _datasrt, lastrecsrt_, recsizesrt_, lessfunction
  7952.     ) else __qsortsrt(_ptrsrt, lastrecsrt_, sizeof(pointer), lessfunction);
  7953.  
  7954.     if (outputproc <> nil) then begin
  7955.       lastrecsrt_ := 0;
  7956.       iosrt_      := outputproc;
  7957.       calliosrt__
  7958.     end;
  7959.     insortsrt_ := false;
  7960.  
  7961.     if ((sortcontrol and _leavemem_srt) = 0) then begin
  7962.       if ((_datasrt <> nil) and (_datasizesrt <> 0)) then __hfreemem(
  7963.         _datasrt, _datasizesrt
  7964.       );
  7965.       if ((_ptrsrt <> nil) and (_ptrsizesrt <> 0)) then __hfreemem(
  7966.         _ptrsrt, _ptrsizesrt
  7967.       );
  7968.       _ptrsrt      := nil;
  7969.       _ptrsizesrt  := 0;
  7970.       _datasrt     := nil;
  7971.       _datasizesrt := 0
  7972.     end
  7973.   end;
  7974.  
  7975.  
  7976.  
  7977.  
  7978.  
  7979.  
  7980.  
  7981.  
  7982.   {$F+}
  7983.   procedure eco_lib_init;
  7984.   begin
  7985.     conditionfuncptr_ := @std_condition;
  7986.     _envseg := memw[prefixseg:$2c];
  7987.     _envptr    := ptr(_envseg,0);
  7988.     envmemptr_ := nil;
  7989.     envsize_   := 0;
  7990.     _hidemouse := 0; __equipscn;
  7991.     _currows := 25; _curcolumns := 80;
  7992.     rows := _currows; cols := _curcolumns;
  7993.     _curmode := get_video_mode;
  7994.     if _curmode = 7 then baseofscreen := $b000 else baseofscreen := $b800;
  7995.     _curdevice := __retdvscn(
  7996.       _curmode, _curcolumns, _currows,
  7997.           _curactivepage, _curdisplaypage
  7998.     );
  7999.     vseg := baseofscreen; vofs := 0;
  8000.     { zero-out the clockarray. }
  8001.     fillchar(clockarray, sizeof(clockarray), nullchar);
  8002.     { start the program timer, aka clockarray(0). }
  8003.     with clockarray[0] do begin
  8004.       with clockstartdate do getdate({var} year,month,date,dayofweek);
  8005.       with clockstarttime do gettime({var} hour,minute,second,hundredth);
  8006.       clockisrunning := true
  8007.     end;
  8008.  
  8009.     _curdisplaypage := 0; _curactivepage := 0;
  8010.     if not __isconfil(__handlfil(output)) then __stdio;
  8011.     _dospath := getenv('PATH');
  8012.     __progname;
  8013.   end;
  8014.   {$F-}
  8015.  
  8016.  
  8017.  
  8018.  
  8019.  
  8020.  
  8021.  
  8022. {$IFNDEF USETURBODOS}
  8023.   {$L ECO_LIBD}
  8024.   {$L INTR}
  8025. {$ENDIF}
  8026.  
  8027.  
  8028.   {$L ECO_LIBS}
  8029.  
  8030.   {$L FETCHMEM}
  8031.   {$L RDSECTOR}
  8032.  
  8033.  
  8034.  
  8035. begin
  8036.   eco_lib_init;
  8037. end.
  8038.