home *** CD-ROM | disk | FTP | other *** search
/ ProfitPress Mega CDROM2 …eeware (MSDOS)(1992)(Eng) / ProfitPress-MegaCDROM2.B6I / UTILITY / SYSTEM / PORTS13.ZIP / PORTS13.PAS < prev   
Encoding:
Pascal/Delphi Source File  |  1991-10-10  |  6.5 KB  |  213 lines
  1. {$A-,B-,D-,E-,F-,I-,L-,N-,O-,R-,S-,V-}
  2. {$M 8096,0,0}
  3.  
  4. program Ports;
  5.  
  6. (***********************************************************************
  7.  NOTICE
  8.  ======
  9.      This program and every file distributed with it are copyright (C)
  10.  by the authors, who retain authorship both of the pre-compiled and
  11.  compiled codes.  Their use and distribution are unrestricted, as long
  12.  as nobody gets any richer in the process.  Although these programs
  13.  were developed to the best of the authors abilities, no guarantees
  14.  can be given as to their performance.  By using them, the user
  15.  accepts all risks and the authors decline all liability.
  16. ************************************************************************)
  17.  
  18. uses crt;
  19.  
  20. const
  21.   num : integer = 0;
  22.  
  23. var
  24.   p1, p2, p3, p4, p5, p6, p7 : string;
  25.   code               : word;
  26.   port1, port2       : word;
  27.   i, by, by2         : byte;
  28.   byt, wrd           : word;
  29.  
  30.  
  31. procedure error;
  32. begin
  33.   writeln('Program Ports v. 1.3');
  34.   writeln('Copyright (c) 1991. J. Campione/C.R.Parkinson.');
  35.   writeln('September 17 1991.');
  36.   inc(Textattr,128);
  37.   write('  WARNING!');
  38.   dec(Textattr,128);
  39.   writeln(' This program can modify the memory and the chips in your computer...');
  40.   writeln('  - Byte IN (from port): Ports i $INPT <!> <return>');
  41.   writeln('  - Byte OUT (to port) : Ports o $OUTP <byte val> <!> <return>');
  42.   writeln('  - Bytes OUT/IN       : Ports u $OUTP <byte val> $INPT <!> <return>');
  43.   writeln('  - Bytes OUT/OUT      : Ports a $OUTP <byte val> $OUTP <byte val> <!> <return>');
  44.   writeln('  - Word OUT (to port) : Ports w $OUTP <word val> <!> <return>');
  45.   writeln('  The last byte value is returned as the errorlevel (exept with "Ports w").');
  46.   writeln('  The INPT, OUTP addresses can be entered as $hex or dec numbers.');
  47.   writeln('  The optional "!" parameter causes the display of the port byte value.');
  48.   writeln('  The optional "#xxxx" parameter operates only with "u" and "a". The "xxxx"');
  49.   writeln('  represents 0-9999 miliseconds of delay between the two port accesses.');
  50.   halt(1);
  51. end;
  52.  
  53.  
  54. { ************************************************** }
  55. { Tranforms a word into a hex number string.         }
  56. { Taken from MEMMAP in PC Mag, Jun 12 1990, p. 343.  }
  57. { -Jose-                                             }
  58. { ************************************************** }
  59. function w2x(w: word): string;
  60. const hexdigit: array[0..15] of char = '0123456789ABCDEF';
  61. begin
  62.   w2x:= hexdigit[hi(w) shr 4] + hexdigit[hi(w) and $0F] +
  63.         hexdigit[lo(w) shr 4] + hexdigit[lo(w) and $0F];
  64. end;
  65.  
  66.  
  67. { ************************************************** }
  68. { Tranforms a byte into a binary number string.      }
  69. { This one may not be as elegant but it is mine...   }
  70. { -Jose-                                             }
  71. { ************************************************** }
  72.  
  73. function power(a,b:real):real;
  74. begin
  75.   power:= exp(b * ln(a));
  76. end;
  77.  
  78. function byte2binstr(by: byte): string;
  79. var
  80.   i: integer;
  81.   pow : integer;
  82.   bit : byte;
  83.   strbit : string[1];
  84.   strbin : string[8];
  85. begin
  86.   strbin:= '';
  87.   for i:= 7 downto 0 do begin
  88.     pow:= round(power(2,i));
  89.     bit:= by div pow;
  90.     str(bit,strbit);
  91.     strbin:= strbin + strbit;
  92.     by:= by - pow * bit;
  93.   end;
  94.   byte2binstr:= strbin;
  95. end;
  96.  
  97.  
  98. begin
  99.  
  100.   p1:= paramstr(1);
  101.   p2:= paramstr(2);
  102.   p3:= paramstr(3);
  103.   p4:= paramstr(4);
  104.   p5:= paramstr(5);
  105.   p6:= paramstr(6);
  106.   p7:= paramstr(7);
  107.  
  108.   { *********************** }
  109.   { Process first parameter }
  110.   { *********************** }
  111.   if (ord(p1[0]) <> 1) then error;
  112.   case upcase(p1[1]) of
  113.    'I' : if (paramcount < 2) then error;
  114.    'O' : if (paramcount < 3) then error;
  115.    'U' : if (paramcount < 4) then error;
  116.    'A' : if (paramcount < 5) then error;
  117.    'W' : if (paramcount < 3) then error;
  118.    else error;
  119.   end;
  120.  
  121.   { ********************************** }
  122.   { process second parameter (port1)   }
  123.   { ********************************** }
  124.   val(p2,port1,code);
  125.   if (code <> 0) then error;
  126.  
  127.   { ********************************** }
  128.   { Process 3rd parameter (byte value) }
  129.   { ********************************** }
  130.   if upcase(p1[1]) in ['O','U','A'] then begin
  131.     val(p3,byt,code);
  132.     if (byt > 255) or (byt < 0) then error else by:= byt;
  133.     if code <> 0 then error;
  134.   end;
  135.  
  136.   { ********************************** }
  137.   { Process 3rd parameter (word value) }
  138.   { ********************************** }
  139.   if upcase(p1[1]) in ['W'] then begin
  140.     val(p3,byt,code);
  141.     if (byt < 0) then error else wrd:= byt;
  142.     if code <> 0 then error;
  143.   end;
  144.  
  145.   { ********************************** }
  146.   { Process 4th parameter (port2)      }
  147.   { ********************************** }
  148.   if upcase(p1[1]) in ['U','A'] then begin
  149.     val(p4,port2,code);
  150.     if code <> 0 then error;
  151.   end;
  152.  
  153.   { ********************************** }
  154.   { Process 5th parameter (byte value) }
  155.   { ********************************** }
  156.   if upcase(p1[1]) in ['A'] then begin
  157.     val(p5,byt,code);
  158.     if (byt > 255) or (byt < 0) then error else by2:= byt;
  159.     if code <> 0 then error;
  160.   end;
  161.  
  162.   { ************************************* }
  163.   { Process 6th parameter (delay in msec) }
  164.   { ************************************* }
  165.   if upcase(p1[1]) in ['A','U'] then begin
  166.     if p6[1] = '#' then begin
  167.       val(copy(p6,2,ord(p6[0])-1),num,code);
  168.       if (num < 0) or (num > 9999) then error;
  169.       if code <> 0 then error;
  170.     end;
  171.   end;
  172.  
  173.   { ***************************** }
  174.   { Take action and report result }
  175.   { ***************************** }
  176.   case upcase(p1[1]) of
  177.    'I' : by:= port[port1];
  178.    'O' : port[port1]:= by;
  179.    'U' : if num = 0 then begin
  180.            port[port1]:= by;
  181.            by:= port[port2];
  182.          end else begin
  183.            port[port1]:= by;
  184.            delay(num);
  185.            by:= port[port2];
  186.          end;
  187.    'A' : if num = 0 then begin
  188.            port[port1]:= by;
  189.            port[port2]:= by2;
  190.            by:= by2;
  191.          end else begin
  192.            port[port1]:= by;
  193.            delay(num);
  194.            port[port2]:= by2;
  195.            by:= by2;
  196.          end;
  197.    'W' : begin
  198.            portw[port1]:= wrd;
  199.            by:= 0;
  200.          end;
  201.   end;
  202.   i:= 0;
  203.   while i < paramcount do begin
  204.     inc(i);
  205.     if paramstr(i) = '!' then
  206.       if upcase(p1[1]) = 'W' then writeln('Port word = ',wrd,'d, ',w2x(wrd),'h.')
  207.       else writeln('Port byte = ',by,'d, ',w2x(by),'h, ',byte2binstr(by),'b.');
  208.   end;
  209.   if ((p7[1] = '!') and (p6[1] = '#')) or
  210.      ((p6[1] = '!') and (p5[1] = '#')) then
  211.      writeln('delay = ',num,' msecs.');
  212.   halt(by);
  213. end.