home *** CD-ROM | disk | FTP | other *** search
/ ftp.barnyard.co.uk / 2015.02.ftp.barnyard.co.uk.tar / ftp.barnyard.co.uk / cpm / walnut-creek-CDROM / CPM / LANGUAGS / PASCAL-P / PP319UPD.LBR / TEST319.PZS / TEST319.PAS
Pascal/Delphi Source File  |  2000-06-30  |  4KB  |  119 lines
  1. PROGRAM testunsigned(input, output);
  2. (* Test PascalP 3.1.9 std. procedures UADD, USUB, UMULT, UDIV  *)
  3. (* UCOMPARE and demonstate the GETMEM, STRINGCP (compare),     *)
  4. (* LENGTH and string read facilities. All new PascalP features *)
  5. (* are ISO standard compatible, in that their usage can be     *)
  6. (* replaced by procedures written in standard Pascal, at the   *)
  7. (* expense of efficiency.  Main programs need not be changed.  *)
  8. (*   C.B. Falconer, 87/01/08      (203) 281-1438               *)
  9.  
  10.   CONST
  11.     maxstring    = 80;
  12.     xmaxstring   = 81;       (* maxstring + 1, for end marker *)
  13. (*$s- non-standard usage *)
  14.     eostring     = (:0:);    (* use chr(0) in standard Pascal *)
  15. (*$s+*)
  16.  
  17.   TYPE
  18.     unsigned     = integer;
  19.     string       = ARRAY[1..xmaxstring] OF char;
  20.     stringp      = ^string;
  21.  
  22.   VAR
  23.     u1, u2, u3   : unsigned;
  24.     line         : string;    (* input buffer *)
  25.     p1, p2       : stringp;   (* pointers to strings in heap *)
  26.     icmp         : -1..+1;    (* results of string compares *)
  27.  
  28.   (* 1---------------1 *)
  29.  
  30.   PROCEDURE wrtunsigned(VAR f : text; n : unsigned; fld : integer);
  31.   (* Acts just like std Pascal write(f, integer : fld) procedure *)
  32.  
  33.     (* 2---------------2 *)
  34.  
  35.     PROCEDURE writeout(n : unsigned);
  36.  
  37.       BEGIN (* writeout *)
  38.       IF n <> 0 THEN BEGIN
  39.         writeout(udiv(n, 10));
  40.         write(chr(usub(n, umult(udiv(n, 10), 10)) + ord('0'))); END;
  41.       END; (* writeout *)
  42.  
  43.     (* 2---------------2 *)
  44.  
  45.     BEGIN (* wrtunsigned *)
  46.     IF n >= 0 THEN write(f, n : fld)  (* no special handling *)
  47.     ELSE BEGIN
  48.       IF fld > 5 THEN write(f, ' ' : fld-5);
  49.       writeout(n); END;
  50.     END; (* wrtunsigned *)
  51.  
  52.   (* 1---------------1 *)
  53.  
  54.   PROCEDURE rdunsigned(VAR f : text; VAR u : unsigned);
  55.   (* Acts just like standard Pascal read(f, integer) procedure *)
  56.  
  57.     BEGIN (* rdunsigned *)
  58.     WHILE f^ = ' ' DO get(f);  (* skipping eolns also *)
  59.     u := 0;
  60.     IF (f^ IN ['0'..'9']) THEN
  61.       REPEAT
  62.         u := uadd(umult(u, 10), ord(f^) - ord ('0')); get(f);
  63.       UNTIL NOT (f^ IN ['0'..'9'])
  64.     ELSE BEGIN
  65.       writeln('Illegal char - RDUNSIGNED'); terminate; END;
  66.     END; (* rdunsigned *)
  67.  
  68.   (* 1---------------1 *)
  69.  
  70.   PROCEDURE save(VAR ln : string; VAR p : stringp);
  71.   (* saving a string, with no wasted memory. If you copy *)
  72.   (* too much of the string over you will cause crashes. *)
  73.  
  74.     BEGIN (* save *)
  75.     getmem(p, succ(length(ln)));  (* 1 extra for end marker *)
  76.     IF p <> NIL THEN moveto(p^, ln, succ(length(ln)))
  77.     ELSE BEGIN
  78.       writeln('Heap overflow'); terminate; END;
  79.     END; (* save *)
  80.  
  81.   (* 1---------------1 *)
  82.  
  83.   BEGIN (* testunsigned *)
  84.   writeln('Enter 2 lines, of any text');
  85.  
  86.   readln(line); save(line, p1);  (* line is nul padded *)
  87.   readln(line); save(line, p2);
  88.  
  89.   icmp := stringcp(p1^, p2^);
  90.   write(p1^ : length(p1^));
  91.   IF icmp < 0 THEN write(' < ')
  92.   ELSE IF icmp = 0 THEN write (' = ')
  93.   ELSE (* > 0 *) write(' > ');
  94.   writeln(p2^ : length(p2^));
  95.  
  96.   dispose(p1); dispose(p2);  (* you can give up the memory *)
  97.  
  98.   writeln;
  99.   writeln('Enter numeric unsigned pairs, space or <cr> separators');
  100.   writeln('CTL-Z at line left terminates');
  101.   WHILE NOT eof DO BEGIN
  102.     rdunsigned(input, u1); rdunsigned(input, u2); readln;
  103.  
  104.     u3 := uadd(u1, u2);
  105.     writeln('u1' : 10, 'u2' : 10, 'sum' : 10, 'diff' : 10,
  106.                                   'prod' : 10, 'quotient' : 10);
  107.     icmp := ucompare(u1, u2);
  108.     wrtunsigned(output, u1, 10);
  109.     IF icmp < 0 THEN write(' < ')
  110.     ELSE IF icmp = 0 THEN write (' = ')
  111.     ELSE (* > 0 *) write(' > ');
  112.     wrtunsigned(output, u2, 7);
  113.     wrtunsigned(output, u3, 10);
  114.     wrtunsigned(output, usub(u1, u2), 10);
  115.     wrtunsigned(output, umult(u1, u2), 10);
  116.     wrtunsigned(output, udiv(u1, u2), 10);
  117.     writeln; END;
  118.   END. (* testunsigned *)
  119. öò