home *** CD-ROM | disk | FTP | other *** search
/ CP/M / CPM_CDROM.iso / cpm / languags / pascal-p / profiler.lbr / TOD.PZS / TOD.PAS
Pascal/Delphi Source File  |  1987-01-14  |  2KB  |  75 lines
  1. PROGRAM tod(input, output);
  2. (* simplified from SETTIMER.INC *)
  3.  
  4. (*$n-,d-,p+*)
  5. (* Allows entries of the form "hr:min" and "y/m/d"  *)
  6. (*   when intermediate prompts are avoided.         *)
  7. (* Note side effects of readx and getvalue funcs.   *)
  8.  
  9.   LABEL 1, 2;
  10.  
  11.   VAR
  12.     i, hr, min : integer;
  13.     ch         : char;
  14.     d          : ARRAY[0..2] OF integer;
  15.     dl         : PACKED ARRAY[1..15] OF char;
  16.  
  17.   (* 1--------------1 *)
  18.  
  19.   FUNCTION getvalue(VAR v : integer; min, max : integer) : boolean;
  20.   (* input a value in range, terminate on eof. signal any error *)
  21.  
  22.     VAR
  23.       ok    : boolean;
  24.  
  25.     BEGIN (* getvalue *)
  26.     IF readx(v) THEN ok := false
  27.     ELSE ok := (v >= min) AND (v <= max);
  28.     IF NOT ok THEN BEGIN
  29.       readln; writeln('Invalid'); END;
  30.     getvalue := ok;
  31.     END; (* getvalue *)
  32.  
  33.   (* 1--------------1 *)
  34.  
  35.   FUNCTION notswallow(ch : char) : boolean;
  36.  
  37.     BEGIN (* notswallow *)
  38.     IF input^ = ch THEN BEGIN
  39.       get(input); notswallow := false; END
  40.     ELSE BEGIN 
  41.       notswallow := true; readln; END;
  42.     END; (* notswallow *)
  43.  
  44.   (* 1--------------1 *)
  45.  
  46.   BEGIN (* tod *)
  47.   i := 0;
  48.   REPEAT
  49.  1: prompt('year(0..99)=?');
  50.     IF getvalue(i, 0, 99) THEN d[2] := i
  51.     ELSE GOTO 1;
  52.     IF notswallow('/') THEN prompt('month(1..12)=?');
  53.     IF getvalue(i, 1, 12) THEN d[1] := i
  54.     ELSE GOTO 1;
  55.     IF notswallow('/') THEN prompt('day(0..99)=?');
  56.     IF getvalue(i, 1, 31) THEN d[0] := i
  57.     ELSE GOTO 1;
  58.     dateset(d);
  59.     IF eoln THEN (* illegal label use *)
  60. 2:   prompt('hour(0..23)=?');
  61.     IF getvalue(i, 0, 23) THEN hr := i
  62.     ELSE GOTO 2;
  63.     IF notswallow(':') THEN prompt('min(0..59)=?');
  64.     IF getvalue(i, 0, 59) THEN min := i
  65.     ELSE GOTO 2;
  66.     readln;
  67.     timeset(hr, min);
  68.     dater(dl);
  69.     (* check actual time returned, allowing for systems *)
  70.     (* that forbid altering master timer, eg HP3000     *)
  71.     write(dl);
  72.     prompt(' Correct(y/n)?'); readln(ch);
  73.   UNTIL (ch IN ['Y', 'y']);
  74.   END. (* tod *)
  75. ƍ