{ Date-Support. Author: Antivivisektion@t-online.de / 1.6.1998 }
{ URL: http://home.t-online.de/home/Antivivisektion/date.pas   }
{ NO WARRANTY }

{$R-,S-}

unit AntiDate ;

interface

function IsLeap(Year : word) : boolean ;
function DaysPerYear(Year : word) : word ;
function DaysPerMonth(Month, Year : word) : word ;
function ValidDate(Day, Month, Year : word) : boolean ;
procedure AddDays(var Day, Month, Year : word ; Diff : longint) ;
function DateDiff(d1, m1, y1, d2, m2, y2 : word) : longint ;
function DayOfWeek(Day, Month, Year : word) : word ;


implementation


const DaysBack : array[1..12] of integer =
  (0, 31, 59, 90, 120, 151, 181, 212, 243, 273, 304, 334) ;


function IsLeap(Year : word) : boolean ;
begin { see http://www.merlyn.demon.co.uk/leapyear.htm }
  IsLeap :=
    ((Year mod 4) = 0) xor ((Year mod 100) = 0) xor ((Year mod 400) = 0) end ;


function DaysPerYear(Year : word) : word ;
begin DaysPerYear := 365+word(IsLeap(Year)) end ;


function DaysPerMonth(Month, Year : word) : word ;
begin
  case Month of
    4, 6, 9, 11 : DaysPerMonth := 30 ;
    1, 3, 5, 7, 8, 10, 12 : DaysPerMonth := 31 ;
    2 : begin if IsLeap(Year)
        then DaysPerMonth := 29
        else DaysPerMonth := 28 ;
      end ;
    end ;
  end ;


function ValidDate(Day, Month, Year : word) : boolean ;
begin ValidDate := (Day >= 1) and (Day <= DaysPerMonth(Month, Year)) and
    (Month >= 1) and (Month <= 12) end ;


procedure Abort({$IFDEF VER70}const{$ENDIF} Func : string ;
  Day, Month, Year : word) ; NEAR ;
begin
  Write('Range-check error: Date does not exist!'#13#10) ;
  Write('Unit: Date ; Func: ', Func,
    '(Day: ', Day, ', Month: ', Month, ', Year: ', Year, ')'#13#10) ;
  {$IFDEF VER70}
  asm { AIM: SHOW REAL ERROR-ADDR!}
      leave { on XT: mov sp, bp ; pop bp }
      pop ax
      leave
      mov byte ptr cs:[@A+3], $EA ;
    { CALL SYSTEM:RUNERROR -> JMP SYSTEM:RUNERROR }
    @A:
      end ;
  {$ENDIF}
  RunError(201) ; { Error 201: range-check error. }
  end ;


procedure AddDays(var Day, Month, Year : word ; Diff : longint) ;
begin
  if not(ValidDate(Day, Month, Year)) then
    Abort('AddDays', Day, Month, Year) ;
  Inc(Diff, DaysBack[Month]+Day-1) ;
  if (Month > 2) and IsLeap(Year) then Inc(Diff) ;
  Day := 1 ;
  Month := 1 ;
  while (Diff < 0) do begin
    Inc(Diff, DaysPerYear(Year-1)) ; Dec(Year) end ;
  while (Diff >= DaysPerYear(Year)) do begin
    Dec(Diff, DaysPerYear(Year)) ; Inc(Year) end ;
  while (Diff >= DaysPerMonth(Month, Year)) do begin
    Dec(Diff, DaysPerMonth(Month, Year)) ; Inc(Month) end ;
  Inc(Day, Diff) ;
  end ;


function DateDiff(d1, m1, y1, d2, m2, y2 : word) : longint ;
var Sign : ShortInt ; Diff : longint ; {$IFNDEF VER70} x : integer ; {$ENDIF}
begin
  if not(ValidDate(d1, m1, y1)) then Abort('DateDiff', d1, m1, y1) ;
  if not(ValidDate(d2, m2, y2)) then Abort('DateDiff', d2, m2, y2) ;
  if (y1 > y2) or ((y1 = y2) and ((m1 > m2) or ((m1 = m2) and (d1 > d2))))
    then begin
    Sign := -1 ;
    {$IFDEF VER70}
    asm ;
      mov  ax,y1 ; xchg ax,y2 ; mov y1,ax ;
      mov  ax,m1 ; xchg ax,m2 ; mov m1,ax ;
      mov  ax,d1 ; xchg ax,d2 ; mov d1,ax ;
      end ;
    {$ELSE}
    x := y1 ; y1 := y2 ; x2 := x ;
    x := m1 ; m1 := m2 ; m2 := x ;
    x := d1 ; d1 := d2 ; d2 := x ;
    {$ENDIF}
    end
  else Sign := 1 ;

  Diff := DaysBack[m2]+d2-DaysBack[m1]-d1 ;
  if (m1 > 2) and IsLeap(y1) then Dec(Diff) ;
  if (m2 > 2) and IsLeap(y2) then Inc(Diff) ;
  while (Y1 <> Y2) do begin Inc(Diff, DaysPerYear(Y1)) ; Inc(Y1) end ;
  DateDiff := Sign*Diff ;
  end ;


function DayOfWeek(Day, Month, Year : word) : word ;
begin
  if not(ValidDate(Day, Month, Year)) then
    Abort('DayOfWeek', Day, Month, Year) ;
  DayOfWeek := DateDiff(6, 1, 1000, Day, Month, Year) mod 7 end ;


BEGIN ;
END.