Why Gemfury? Push, build, and install  RubyGems npm packages Python packages Maven artifacts PHP packages Go Modules Debian packages RPM packages NuGet packages

Repository URL to install this package:

Details    
fpc-src / usr / share / fpcsrc / 3.2.0 / tests / test / cg / tnot.pp
Size: Mime:
{****************************************************************}
{  CODE GENERATOR TEST PROGRAM                                   }
{****************************************************************}
{ NODE TESTED : secondnot()                                      }
{****************************************************************}
{ PRE-REQUISITES: secondload()                                   }
{                 secondassign()                                 }
{****************************************************************}
{ DEFINES:   VERBOSE = Write test information to screen          }
{            FPC     = Target is FreePascal compiler             }
{****************************************************************}
{ REMARKS:                                                       }
{                                                                }
{                                                                }
{                                                                }
{****************************************************************}
Program tnot;

{----------------------------------------------------}
{ Cases to test:                                     }
{   CURRENT NODE (result)                            }
{     - LOC_REGISTER                                 }
{     - LOC_FLAGS                                    }
{   LEFT NODE (value to complement)                  }
{     possible cases : int64,byte,word,longint       }
{                      boolean                       }
{     - LOC_CREGISTER                                }
{     - LOC_REFERENCE / LOC_MEM                      }
{     - LOC_REGISTER                                 }
{     - LOC_FLAGS                                    }
{     - LOC_JUMP                                     }
{----------------------------------------------------}


{$IFNDEF FPC}
type  smallint = integer;
{$ENDIF}

function getintres : smallint;
begin
 getintres := $7F7F;
end;

function getbyteboolval : bytebool;
begin
  getbyteboolval := TRUE;
end;

function getbooleanval : boolean;
begin
  getbooleanval := TRUE;
end;

procedure test(value, required: longint);
begin
  if value <> required then
    begin
      writeln('Got ',value,' instead of ',required);
      halt(1);
    end
  else
    writeln('Passed!');
end;

const
  lb = longbool(false);

var
 longres :  longint;
 intres : smallint;
 booleanval  : boolean;
 byteboolval : bytebool;
 wordboolval : wordbool;
 longboolval : longbool;
 booleanres  : boolean;
 byteboolres : bytebool;
 wordboolres : wordbool;
 longboolres : longbool;
{$ifdef fpc}
 int64res : int64;
{$endif}
Begin
   WriteLn('------------------------------ LONGINT --------------------------------');
   { CURRENT NODE: REGISTER }
   { LEFT NODE : REFERENCE  }
   WriteLn('(current) : LOC_REGISTER; (left) : LOC_REFERENCE');
   longres := $7F7F7F7F;
   longres := not longres;
   Write('Value should be $80808080...');

   { the following test give range check errors }
   {$R-}
   test(longres,$80808080);

   { CURRENT NODE : REGISTER }
   { LEFT NODE : REGISTER    }
   WriteLn('(current) : LOC_REGISTER; (left) : LOC_REGISTER');
   longres := not getintres;
   Write('Value should be $8080...');
   test(longres, $FFFF8080);

   WriteLn('----------------------------- BOOLEAN -----------------------------------');

   { CURRENT NODE : LOC_REGISTER }
   { LEFT NODE :  LOC_REFERENCE  }
   WriteLn('(current) : LOC_REGISTER; (left) : LOC_REFERENCE');
   booleanval := TRUE;
   booleanres := not booleanval;
   Write('Value should be FALSE...');
   test(ord(booleanres),0);

   byteboolval := TRUE;
   byteboolres := not byteboolval;
   Write('Value should be FALSE...');
   test(ord(byteboolres),0);

   wordboolval := TRUE;
   wordboolres := not wordboolval;
   Write('Value should be FALSE...');
   test(longint(wordboolres),0);

   longboolval := TRUE;
   longboolres := not longboolval;
   Write('Value should be FALSE...');
   test(longint(longboolres),0);

   { CURRENT NODE : LOC_REGISTER }
   { LEFT NODE :  LOC_REGISTER  }
   WriteLn('(current) : LOC_REGISTER; (left) : LOC_REGISTER');
   longboolres := not getbyteboolval;
   Write('Value should be FALSE...');
   test(longint(longboolres),0);

   { CURRENT NODE : LOC_FLAGS }
   { LEFT NODE :  LOC_FLAGS  }
   WriteLn('(current) : LOC_FLAGS; (left) : LOC_FLAGS');
   intres := 1;
   booleanres := TRUE;
   booleanres:= not ((intres = 1));
   Write('Value should be FALSE...');
   test(ord(booleanres),0);

   intres := 1;
   byteboolres := TRUE;
   byteboolres:= not ((intres = 1));
   Write('Value should be FALSE...');
   test(ord(byteboolres),0);

  longboolres:=not(lb);
  Write('Value should be $ffffffff...');
  test(ord(longboolres),-1);

  { !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! }
  { CURRENT_NODE : LOC_JUMP }
  { ???????????????????????}

  { !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! }
  { CURRENT_NODE : LOC_FLAGS          }
  { LEFT NODE : <> LOC_FLAGS          }
  { !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! }
{$IFDEF FPC}
   WriteLn('------------------------------  INT64  ----------------------------------');
   { CURRENT NODE: REGISTER }
   { LEFT NODE : REFERENCE  }
   WriteLn('(current) : LOC_REGISTER; (left) : LOC_REFERENCE');
   int64res := $7F7F7F7F;
   int64res := not int64res;
   Write('Value should be $80808080...');
   test(int64res and $FFFFFFFF,$80808080);

   { CURRENT NODE : REGISTER }
   { LEFT NODE : REGISTER    }
   WriteLn('(current) : LOC_REGISTER; (left) : LOC_REGISTER');
   int64res := not (word(getintres));
   Write('Value should be $8080...');
   test(int64res and $FFFFFFFF,$00008080);
{$ENDIF}
end.