+ support of compiler intrinsic sar* using a patch by Benjamin Rosseaux, resolves #15606

git-svn-id: trunk@14834 -

.gitattributes

@@ -8576,6 +8576,7 @@ tests/test/cg/traise4.pp svneol=native#text/plain
 tests/test/cg/traise5.pp svneol=native#text/plain
 tests/test/cg/traise6.pp svneol=native#text/plain
 tests/test/cg/treadwrt.pp svneol=native#text/plain
+tests/test/cg/tsar1.pp svneol=native#text/pascal
 tests/test/cg/tshlshr.pp svneol=native#text/plain
 tests/test/cg/tstr.pp svneol=native#text/plain
 tests/test/cg/tsubst.pp svneol=native#text/plain

compiler/compinnr.inc

@@ -79,7 +79,8 @@ const
    in_objc_selector_x   = 69;
    in_objc_protocol_x   = 70;
    in_objc_encode_x     = 71;
-
+   in_sar_x_y           = 72;
+   in_sar_x             = 73;
 
 { Internal constant functions }
    in_const_sqr        = 100;

compiler/ncginl.pas

@@ -55,6 +55,7 @@ interface
           procedure second_trunc_real; virtual;
           procedure second_abs_long; virtual;
           procedure second_rox; virtual;
+          procedure second_sar; virtual;
        end;
 
 implementation
@@ -165,6 +166,9 @@ implementation
             in_ror_x,
             in_ror_x_x:
               second_rox;
+            in_sar_x,
+            in_sar_x_y:
+              second_sar;
             else internalerror(9);
          end;
       end;
@@ -768,6 +772,46 @@ implementation
           cg.a_op_const_reg(current_asmdata.CurrAsmList,op,location.size,1,location.register);
       end;
 
+
+    procedure tcginlinenode.second_sar;
+      var
+        {hcountreg : tregister;}
+        op1,op2 : tnode;
+      begin
+        if (left.nodetype=callparan) and
+           assigned(tcallparanode(left).right) then
+          begin
+            op1:=tcallparanode(tcallparanode(left).right).left;
+            op2:=tcallparanode(left).left;
+          end
+        else
+          begin
+            op1:=left;
+            op2:=nil;
+          end;
+        secondpass(op1);
+        { load left operator in a register }
+        location_copy(location,op1.location);
+
+        location_force_reg(current_asmdata.CurrAsmList,location,location.size,false);
+
+        if not(assigned(op2)) then
+          cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,location.size,1,location.register)
+        else
+          begin
+            secondpass(op2);
+            { shifting by a constant directly coded: }
+            if op2.nodetype=ordconstn then
+              cg.a_op_const_reg(current_asmdata.CurrAsmList,OP_SAR,location.size,
+                                  tordconstnode(op2).value.uvalue and (resultdef.size*8-1),location.register)
+            else
+              begin
+                location_force_reg(current_asmdata.CurrAsmList,op2.location,location.size,false);
+                cg.a_op_reg_reg(current_asmdata.CurrAsmList,OP_SAR,location.size,op2.location.register,location.register);
+             end;
+          end;
+      end;
+
 begin
    cinlinenode:=tcginlinenode;
 end.

compiler/ninl.pas

@@ -1417,6 +1417,60 @@ implementation
         end;
 
 
+      function handle_const_sar : tnode;
+        var
+          vl,vl2    : TConstExprInt;
+          bits,shift: integer;
+          mask : qword;
+          def : tdef;
+        begin
+          result:=nil;
+          if (left.nodetype=ordconstn) or ((left.nodetype=callparan) and (tcallparanode(left).left.nodetype=ordconstn)) then
+            begin
+              if (left.nodetype=callparan) and
+                 assigned(tcallparanode(left).right) then
+                begin
+                  if (tcallparanode(tcallparanode(left).right).left.nodetype=ordconstn) then
+                    begin
+                      def:=tcallparanode(tcallparanode(left).right).left.resultdef;
+                      vl:=tordconstnode(tcallparanode(left).left).value;
+                      vl2:=tordconstnode(tcallparanode(tcallparanode(left).right).left).value;
+                    end
+                  else
+                    internalerror(2010013101);
+                end
+              else
+                begin
+                  def:=left.resultdef;
+                  vl:=1;
+                  vl2:=tordconstnode(left).value;
+                end;
+
+              bits:=def.size*8;
+              shift:=vl.svalue and (bits-1);
+              case bits of
+                 8:
+                   mask:=$ff;
+                 16:
+                   mask:=$ffff;
+                 32:
+                   mask:=$ffffffff;
+                 64:
+                   mask:=$ffffffffffffffff;
+                 else 
+                   mask:=qword(1 shl bits)-1;
+              end;
+              if shift=0 then 
+                result:=cordconstnode.create(vl2.svalue,def,false)
+              else if vl2.svalue<0 then
+                result:=cordconstnode.create(((vl2.svalue shr shift) or (mask shl (bits-shift))) and mask,def,false)
+              else
+                result:=cordconstnode.create((vl2.svalue shr shift) and mask,def,false);
+            end
+          else
+        end;
+
+
       var
         hp        : tnode;
         vl,vl2    : TConstExprInt;
@@ -1814,6 +1868,11 @@ implementation
                     { we need a valid node, so insert a nothingn }
                     result:=cnothingnode.create;
                 end;
+              in_sar_x,
+              in_sar_x_y :
+                begin
+                  result:=handle_const_sar;
+                end;
             end;
           end;
       end;
@@ -2468,13 +2527,15 @@ implementation
                   resultdef:=voidpointertype;
                 end;
               in_rol_x,
-              in_ror_x:
+              in_ror_x,
+              in_sar_x:
                 begin
                   set_varstate(left,vs_read,[vsf_must_be_valid]);
                   resultdef:=left.resultdef;
                 end;
               in_rol_x_x,
-              in_ror_x_x:
+              in_ror_x_x,
+              in_sar_x_y:
                 begin
                   set_varstate(tcallparanode(left).left,vs_read,[vsf_must_be_valid]);
                   set_varstate(tcallparanode(tcallparanode(left).right).left,vs_read,[vsf_must_be_valid]);
@@ -2844,7 +2905,9 @@ implementation
          in_rol_x,
          in_rol_x_x,
          in_ror_x,
-         in_ror_x_x:
+         in_ror_x_x,
+         in_sar_x,
+         in_sar_x_y:
            expectloc:=LOC_REGISTER;
          else
            internalerror(89);

compiler/options.pas

@@ -2419,6 +2419,11 @@ begin
   def_system_macro('FPC_HAS_INTERNAL_ROX');
 {$endif}
 
+{ these cpus have an inline sar implementaion }
+{$if defined(x86) or defined(arm) or defined(powerpc) or defined(powerpc64)}
+  def_system_macro('FPC_HAS_INTERNAL_SAR');
+{$endif}
+
 {$ifdef powerpc64}
   def_system_macro('FPC_HAS_LWSYNC');
 {$endif}

compiler/pp.lpi

@@ -23,7 +23,8 @@
     <RunParams>
       <local>
         <FormatVersion Value="1"/>
-        <LaunchingApplication PathPlusParams="/usr/X11R6/bin/xterm -T 'Lazarus Run Output' -e $(LazarusDir)/tools/runwait.sh $(TargetCmdLine)"/>
+        <CommandLineParams Value="-n @\home\florian\bin\fpc.cfg \home\florian\fpc\tests\test\cg\tsar1.pp"/>
+        <LaunchingApplication PathPlusParams="\usr\bin\xterm -T 'Lazarus Run Output' -e $(LazarusDir)\tools\runwait.sh $(TargetCmdLine)"/>
       </local>
     </RunParams>
     <Units Count="2">

rtl/inc/generic.inc

@@ -2229,3 +2229,43 @@ function RolQWord(Const AValue : QWord;Dist : Byte): QWord;{$ifdef SYSTEMINLINE}
 {$endif FPC_SYSTEM_HAS_ROX_QWORD}
 {$endif FPC_HAS_INTERNAL_ROX_QWORD}
 
+{$ifndef FPC_HAS_INTERNAL_SAR_BYTE}
+{$ifndef FPC_SYSTEM_HAS_SAR_BYTE}
+function SarShortint(Const AValue : Shortint;Shift : Byte): Shortint;
+  begin
+    Shift:=Shift and 7;
+    Result:=shortint(byte(byte(byte(AValue) shr Shift) or (byte(shortint(byte(0-byte(byte(AValue) shr 7)) and byte(shortint(0-(ord(Shift<>0){ and 1}))))) shl (8-Shift))));
+  end;
+{$endif FPC_HAS_INTERNAL_SAR_BYTE}
+{$endif FPC_SYSTEM_HAS_SAR_BYTE}
+
+{$ifndef FPC_HAS_INTERNAL_SAR_WORD}
+{$ifndef FPC_SYSTEM_HAS_SAR_WORD}
+function SarSmallint(Const AValue : Smallint;Shift : Byte): Smallint;
+  begin
+    Shift:=Shift and 15;
+    Result:=smallint(word(word(word(AValue) shr Shift) or (word(smallint(word(0-word(word(AValue) shr 15)) and word(smallint(0-(ord(Shift<>0){ and 1}))))) shl (16-Shift))));
+  end;
+{$endif FPC_HAS_INTERNAL_SAR_WORD}
+{$endif FPC_SYSTEM_HAS_SAR_WORD}
+
+{$ifndef FPC_HAS_INTERNAL_SAR_DWORD}
+{$ifndef FPC_SYSTEM_HAS_SAR_DWORD}
+function SarLongint(Const AValue : Longint;Shift : Byte): Longint;
+  begin
+    Shift:=Shift and 31;
+    Result:=longint(dword(dword(dword(AValue) shr Shift) or (dword(longint(dword(0-dword(dword(AValue) shr 31)) and dword(longint(0-(ord(Shift<>0){ and 1}))))) shl (32-Shift))));
+  end;
+{$endif FPC_HAS_INTERNAL_SAR_DWORD}
+{$endif FPC_SYSTEM_HAS_SAR_DWORD}
+
+{$ifndef FPC_HAS_INTERNAL_SAR_QWORD}
+{$ifndef FPC_SYSTEM_HAS_SAR_QWORD}
+function SarInt64(Const AValue : Int64;Shift : Byte): Int64;
+  begin
+    Shift:=Shift and 63;
+    Result:=int64(qword(qword(qword(AValue) shr Shift) or (qword(int64(qword(0-qword(qword(AValue) shr 63)) and qword(int64(0-(ord(Shift<>0){ and 1}))))) shl (64-Shift))));
+  end;
+{$endif FPC_HAS_INTERNAL_SAR_QWORD}
+{$endif FPC_SYSTEM_HAS_SAR_QWORD}
+

rtl/inc/innr.inc

@@ -80,6 +80,8 @@ const
    fpc_objc_selector_x      = 69;
    fpc_objc_protocol_x      = 70;
    fpc_objc_encode_x        = 71;
+   fpc_in_sar_x_y           = 72;
+   fpc_in_sar_x             = 73;
 
 { Internal constant functions }
    fpc_in_const_sqr        = 100;

rtl/inc/systemh.inc

@@ -710,6 +710,52 @@ function RolQWord(Const AValue : QWord): QWord;{$ifdef SYSTEMINLINE}inline;{$end
 function RolQWord(Const AValue : QWord;Dist : Byte): QWord;{$ifdef SYSTEMINLINE}inline;{$endif}
 {$endif FPC_HAS_INTERNAL_ROX_QWORD}
 
+{$ifdef FPC_HAS_INTERNAL_SAR}
+
+{$if defined(cpux86_64) or defined(cpui386)}
+{$define FPC_HAS_INTERNAL_SAR_BYTE}
+{$define FPC_HAS_INTERNAL_SAR_WORD}
+{$endif defined(cpux86_64) or defined(cpui386)}
+
+{$if defined(cpux86_64) or defined(cpui386) or defined(arm) or defined(powerpc) or defined(powerpc64)}
+{$define FPC_HAS_INTERNAL_SAR_DWORD}
+{$endif defined(cpux86_64) or defined(cpui386) or defined(arm) or defined(powerpc) or defined(powerpc64)}
+
+{$if defined(cpux86_64) or defined(powerpc64)}
+{$define FPC_HAS_INTERNAL_SAR_QWORD}
+{$endif defined(cpux86_64) or defined(powerpc64)}
+
+{$endif FPC_HAS_INTERNAL_SAR}
+
+{$ifdef FPC_HAS_INTERNAL_SAR_BYTE}
+function SarShortint(Const AValue : Shortint): Shortint;[internproc:fpc_in_sar_x];
+function SarShortint(Const AValue : Shortint;Shift : Byte): Shortint;[internproc:fpc_in_sar_x_y];
+{$else FPC_HAS_INTERNAL_ROX_BYTE}
+function SarShortint(Const AValue : Shortint;Shift : Byte = 1): Shortint;
+{$endif FPC_HAS_INTERNAL_ROX_BYTE}
+
+{$ifdef FPC_HAS_INTERNAL_SAR_WORD}
+function SarSmallint(Const AValue : Smallint): Smallint;[internproc:fpc_in_sar_x];
+function SarSmallint(Const AValue : Smallint;Shift : Byte): Smallint;[internproc:fpc_in_sar_x_y];
+{$else FPC_HAS_INTERNAL_SAR_WORD}
+function SarSmallint(Const AValue : Smallint;Shift : Byte = 1): Smallint;
+{$endif FPC_HAS_INTERNAL_SAR_WORD}
+
+{$ifdef FPC_HAS_INTERNAL_SAR_DWORD}
+function SarLongint(Const AValue : Longint): Longint;[internproc:fpc_in_sar_x];
+function SarLongint(Const AValue : Longint;Shift : Byte): Longint;[internproc:fpc_in_sar_x_y];
+{$else FPC_HAS_INTERNAL_SAR_DWORD}
+function SarLongint(Const AValue : Longint;Shift : Byte = 1): Longint;
+{$endif FPC_HAS_INTERNAL_SAR_DWORD}
+
+{$ifdef FPC_HAS_INTERNAL_SAR_QWORD}
+function SarInt64(Const AValue : Int64): Int64;[internproc:fpc_in_sar_x];
+function SarInt64(Const AValue : Int64;Shift : Byte): Int64;[internproc:fpc_in_sar_x_y];
+{$else FPC_HAS_INTERNAL_SAR_QWORD}
+function SarInt64(Const AValue : Int64;Shift : Byte = 1): Int64;
+{$endif FPC_HAS_INTERNAL_SAR_QWORD}
+
+
 {$ifndef FPUNONE}
 { float math routines }
 {$I mathh.inc}

tests/test/cg/tsar1.pp

@@ -0,0 +1,492 @@
+program tsar1;
+{$mode objfpc}
+{$o-}
+var
+  c0,c4,c7,c15,c31,c63,c36,c20,c68,c12 : integer;
+
+begin
+ c0:=0;
+ c4:=4;
+ c7:=7;
+ c15:=15;
+ c31:=31;
+ c63:=63;
+ c36:=36;
+ c20:=20;
+ c68:=68;
+ c12:=12;
+ writeln('Testing constant SarInt64...');
+ if SarInt64(-$3FFFFFFFFFFFFFFF,4)<>-$400000000000000 then begin
+  writeln('Fail!');
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64($3FFFFFFFFFFFFFFF,4)<>$3FFFFFFFFFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64(-$3FFFFFFFFFFFFFF0,4)<>-$3FFFFFFFFFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64($3FFFFFFFFFFFFFF0,4)<>$3FFFFFFFFFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64(-$3FFFFFFFFFFFFFFF,0)<>-$3FFFFFFFFFFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64($3FFFFFFFFFFFFFFF,0)<>$3FFFFFFFFFFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64(-$3FFFFFFFFFFFFFFF,63)<>-1 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64($3FFFFFFFFFFFFFFF,63)<>0 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64(-$3FFFFFFFFFFFFFFF)<>-$2000000000000000 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64($3FFFFFFFFFFFFFFF)<>$1FFFFFFFFFFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ writeln;
+
+ writeln('Testing constant SarLongint...');
+ if SarLongint(-$3FFFFFFF,4)<>-$4000000 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint($3FFFFFFF,4)<>$3FFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint(-$3FFFFFF0,4)<>-$3FFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint($3FFFFFF0,4)<>$3FFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint(-$3FFFFFFF,0)<>-$3FFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint($3FFFFFFF,0)<>$3FFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint(-$3FFFFFFF,31)<>-1 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint($3FFFFFFF,31)<>0 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint(-$3FFFFFFF)<>-$20000000 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint($3FFFFFFF)<>$1FFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ writeln;
+
+ writeln('Testing constant SarSmallint...');
+ if SarSmallint(-$3FFF,4)<>-$400 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint($3FFF,4)<>$3FF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint(-$3FF0,4)<>-$3FF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint($3FF0,4)<>$3FF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint(-$3FFF,0)<>-$3FFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint($3FFF,0)<>$3FFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint(-$3FFF,15)<>-1 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint($3FFF,15)<>0 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint(-$3FFF)<>-$2000 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint($3FFF)<>$1FFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ writeln;
+
+ writeln('Testing constant SarShortint...');
+ if SarShortint(-$3F,4)<>-$4 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint($3F,4)<>$3 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint(-$30,4)<>-$3 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint($30,4)<>$3 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint(-$3F,0)<>-$3F then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint($3F,0)<>$3F then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint(-$3F,7)<>-1 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint($3F,7)<>0 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint(-$3F)<>-$20 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint($3F)<>$1F then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ writeln;
+
+ writeln('Testing constant shifting overflows');
+ if SarInt64($3fffffffffffffff,68)<>$3ffffffffffffff then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint($3fffffff,36)<>$3ffffff then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint($3fff,20)<>$3ff then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint($3f,12)<>$3 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ writeln;
+
+ writeln('Testing SarInt64...');
+ if SarInt64(-$3FFFFFFFFFFFFFFF,c4)<>-$400000000000000 then begin
+  writeln('Fail!');
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64($3FFFFFFFFFFFFFFF,c4)<>$3FFFFFFFFFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64(-$3FFFFFFFFFFFFFF0,c4)<>-$3FFFFFFFFFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64($3FFFFFFFFFFFFFF0,c4)<>$3FFFFFFFFFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64(-$3FFFFFFFFFFFFFFF,c0)<>-$3FFFFFFFFFFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64($3FFFFFFFFFFFFFFF,c0)<>$3FFFFFFFFFFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64(-$3FFFFFFFFFFFFFFF,c63)<>-1 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64($3FFFFFFFFFFFFFFF,c63)<>0 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64(-$3FFFFFFFFFFFFFFF)<>-$2000000000000000 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarInt64($3FFFFFFFFFFFFFFF)<>$1FFFFFFFFFFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ writeln;
+
+ writeln('Testing SarLongint...');
+ if SarLongint(-$3FFFFFFF,c4)<>-$4000000 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint($3FFFFFFF,c4)<>$3FFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint(-$3FFFFFF0,c4)<>-$3FFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint($3FFFFFF0,c4)<>$3FFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint(-$3FFFFFFF,c0)<>-$3FFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint($3FFFFFFF,c0)<>$3FFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint(-$3FFFFFFF,c31)<>-1 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint($3FFFFFFF,c31)<>0 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint(-$3FFFFFFF)<>-$20000000 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint($3FFFFFFF)<>$1FFFFFFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ writeln;
+
+ writeln('Testing SarSmallint...');
+ if SarSmallint(-$3FFF,c4)<>-$400 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint($3FFF,c4)<>$3FF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint(-$3FF0,c4)<>-$3FF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint($3FF0,c4)<>$3FF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint(-$3FFF,c0)<>-$3FFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint($3FFF,c0)<>$3FFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint(-$3FFF,c15)<>-1 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint($3FFF,c15)<>0 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint(-$3FFF)<>-$2000 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint($3FFF)<>$1FFF then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ writeln;
+
+ writeln('Testing SarShortint...');
+ if SarShortint(-$3F,c4)<>-$4 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint($3F,c4)<>$3 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint(-$30,c4)<>-$3 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint($30,c4)<>$3 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint(-$3F,c0)<>-$3F then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint($3F,c0)<>$3F then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint(-$3F,c7)<>-1 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint($3F,c7)<>0 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint(-$3F)<>-$20 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint($3F)<>$1F then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ writeln;
+
+
+ { the overflow behaviour is different for different CPUs
+ writeln('Testing shifting overflows');
+ if SarInt64($3fffffffffffffff,c68)<>$3ffffffffffffff then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarLongint($3fffffff,c36)<>$3ffffff then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarSmallint($3fff,c20)<>$3ff then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ if SarShortint($3f,c12)<>$3 then begin
+  halt(1);
+ end else begin
+  writeln('Pass!');
+ end;
+ }
+
+ writeln('All passed');
+end.
+