├── README.md ├── SynCommons.pas ├── SynCrypto.pas ├── SynDoubleToText.inc ├── SynFPCTypInfo.pas ├── SynGdiPlus.pas ├── SynLZ.pas ├── SynPdf.pas ├── SynTable.pas ├── SynZip.pas ├── Synopse.inc ├── SynopseCommit.inc ├── crc32c64.obj ├── deflate.obj ├── mORMotReport.pas ├── sha512-x64sse4.obj ├── sha512-x86.obj └── trees.obj /README.md: -------------------------------------------------------------------------------- 1 | SynPDF 2 | ====== 3 | 4 | Synopse PDF engine is a fully featured *Open Source* PDF document creation library for Delphi, embedded in one unit. 5 | 6 | It's used e.g. in our [*mORMot* framework](https://github.com/synopse/mORMot), for creating PDF files from generated reports. 7 | But you can use it stand-alone, without our main ORM/SOA framework. 8 | 9 | If you download the whole *mORMot* source code, you do not need this separate package: ensure you get rid of any existing separated *SynPDF* installation, and use the PDF units as available in the main *mORMot* trunk. 10 | This *SynPDF* distribution/GitHub account targets only people needing PDF writing, without other *mORMot* features, under Delphi. 11 | 12 | If you plan using any part of the framework (e.g. *SynLog*, *SynDB* or the *ORM*/*SOA*), don't use this repository, but use the main [*mORMot* framework](https://github.com/synopse/mORMot). Having the two repositories on the same environement may be a source of unexpected version conflict. Just use and trust the main *mORMot* repository, which will be updated much more often. 13 | 14 | **For long-term support, and FPC compatibility, check the [*mORMot 2* mormot.ui.pdf.pas unit](https://github.com/synopse/mORMot2/blob/master/src/ui/mormot.ui.pdf.pas)** 15 | 16 | Features 17 | -------- 18 | 19 | * Pure Delphi code, with no external .dll, and adding very small code size to your executable; 20 | * Targets Delphi 6 and up, including Unicode versions of Delphi, for Win32 and Win64 platforms, with full source code provided; 21 | * Includes most vectorial drawing commands, including text, lines or curves; 22 | * Renders bitmaps, and metafiles (even most .emf files with clipping and regioning); 23 | * Introduce metadata, bookmarks and outline information; 24 | * Produce very small .pdf files; 25 | * Optionally [encrypt and secure the .pdf content](http://blog.synopse.info?post/2013/06/19/SynPDF-now-implements-40-bit-and-128-bit-security) using 40 bit or 128 bit keys; 26 | * Fast file generation with low memory overhead (tested with several thousands of pages); 27 | * Access a true VCL TCanvas instance to create the PDF content; 28 | * Optionally embed True Type fonts subsets; 29 | * Unicode ready, even with pre-Unicode versions of Delphi, including advanced [Uniscribe Glyph shading and Font fallback](http://blog.synopse.info/tag/Uniscribe); 30 | * Can publish PDF/A-1 archive files; 31 | * Used in a lot of applications, with regular enhancements, mainly from active end-users; 32 | * Licensed under a [MPL/GPL/LGPL tri-license](https://synopse.info/forum/viewtopic.php?id=27). 33 | 34 | Sample Code 35 | ----------- 36 | 37 | In fact, you have at least three ways of generating pdfs using the library: 38 | * [Directly call](https://synopse.info/forum/viewtopic.php?pid=370#p370) of a `TPdfCanvas` as published by a `TPdfDocument` instance - this is the most direct but also more difficult way of rendering; 39 | * [Use regular VCL `TCanvas` methods](https://synopse.info/forum/viewtopic.php?pid=1909#p1909) thanks to `TMetaFile` support - see `TPdfDocumentGDI.VCLCanvas` property and the `TPdfCanvas.RenderMetaFile` method - this is very easy if you want to use "regular" `TCanvas` methods to draw the page content, especially if you have some existing printing code; 40 | * [Use `TGDIPages` of the supplied `mORMotReport.pas` unit](http://blog.synopse.info?post/2010/06/30/Making-report-from-code) (extracted from our *mORMot* ORM/SOA framework) to easily create the content from code, with some report-oriented methods (including complex rtf with `TGDIPages.AppendRichEdit`) - for basic reporting features, it is pretty much the solution. 41 | 42 | The 2nd and 3rd ways are preferred, for most applications. 43 | 44 | Relevant Forks 45 | -------------- 46 | 47 | Some users did fork the project, and add some nice features, useful for some particular needs, but which were not merged yet to ease maintenance and ensure backward compatibility. 48 | 49 | * EvaF made a [texture-based fork](https://github.com/Eva-F/SynPDF/tree/Eva-F-texture-pattern) - see [this forum thread](https://synopse.info/forum/viewtopic.php?id=4932) and [the documents sub-folder](https://github.com/Eva-F/SynPDF/tree/Eva-F-texture-pattern/documents). 50 | 51 | Documentation 52 | ------------- 53 | 54 | For detailed documentation of the unit, see the corresponding pages in the "[Software Architecture Document](https://synopse.info/fossil/wiki?name=Downloads)" of *mORMot* official documentation, or directly in the interface part of the unit, as methods comments. 55 | 56 | Including the report generation pages within the "*SynFile Main Demo*" description. 57 | 58 | Dedicated Blog and Forum 59 | ------------------------ 60 | 61 | A blog is available at http://blog.synopse.info, and will notify any evolution of this component. 62 | 63 | A forum is dedicated to this component, and is available on [https://synopse.info](https://synopse.info/forum/viewforum.php?id=1) 64 | 65 | This is the main entry point for support: first search for an existing answer, then ask your question in a new thread. 66 | 67 | -------------------------------------------------------------------------------- /SynDoubleToText.inc: -------------------------------------------------------------------------------- 1 | /// efficient double to text conversion using the GRISU-1 algorithm 2 | // - as a complement to SynCommons, which tended to increase too much 3 | // - licensed under a MPL/GPL/LGPL tri-license; version 1.18 4 | 5 | { 6 | Implement 64-bit floating point (double) to ASCII conversion using the 7 | GRISU-1 efficient algorithm. 8 | 9 | Original Code in flt_core.inc flt_conv.inc flt_pack.inc from FPC RTL. 10 | Copyright (C) 2013 by Max Nazhalov 11 | Licenced with LGPL 2 with the linking exception. 12 | If you don't agree with these License terms, disable this feature 13 | by undefining DOUBLETOSHORT_USEGRISU in Synopse.inc 14 | 15 | GRISU Original Algorithm 16 | Copyright (c) 2009 Florian Loitsch 17 | 18 | We extracted a double-to-ascii only cut-down version of those files, 19 | and made a huge refactoring to reach the best performance, especially 20 | tuning the Intel target with some dedicated asm and code rewrite. 21 | 22 | With Delphi 10.3 on Win32: (no benefit) 23 | 100000 FloatToText in 38.11ms i.e. 2,623,570/s, aver. 0us, 47.5 MB/s 24 | 100000 str in 43.19ms i.e. 2,315,082/s, aver. 0us, 50.7 MB/s 25 | 100000 DoubleToShort in 45.50ms i.e. 2,197,367/s, aver. 0us, 43.8 MB/s 26 | 100000 DoubleToAscii in 42.44ms i.e. 2,356,045/s, aver. 0us, 47.8 MB/s 27 | 28 | With Delphi 10.3 on Win64: 29 | 100000 FloatToText in 61.83ms i.e. 1,617,233/s, aver. 0us, 29.3 MB/s 30 | 100000 str in 53.20ms i.e. 1,879,663/s, aver. 0us, 41.2 MB/s 31 | 100000 DoubleToShort in 18.45ms i.e. 5,417,998/s, aver. 0us, 108 MB/s 32 | 100000 DoubleToAscii in 18.19ms i.e. 5,496,921/s, aver. 0us, 111.5 MB/s 33 | 34 | With FPC on Win32: 35 | 100000 FloatToText in 115.62ms i.e. 864,842/s, aver. 1us, 15.6 MB/s 36 | 100000 str in 57.30ms i.e. 1,745,109/s, aver. 0us, 39.9 MB/s 37 | 100000 DoubleToShort in 23.88ms i.e. 4,187,078/s, aver. 0us, 83.5 MB/s 38 | 100000 DoubleToAscii in 23.34ms i.e. 4,284,490/s, aver. 0us, 86.9 MB/s 39 | 40 | With FPC on Win64: 41 | 100000 FloatToText in 76.92ms i.e. 1,300,052/s, aver. 0us, 23.5 MB/s 42 | 100000 str in 27.70ms i.e. 3,609,456/s, aver. 0us, 82.6 MB/s 43 | 100000 DoubleToShort in 14.73ms i.e. 6,787,944/s, aver. 0us, 135.4 MB/s 44 | 100000 DoubleToAscii in 13.78ms i.e. 7,253,735/s, aver. 0us, 147.2 MB/s 45 | 46 | With FPC on Linux x86_64: 47 | 100000 FloatToText in 81.48ms i.e. 1,227,249/s, aver. 0us, 22.2 MB/s 48 | 100000 str in 36.98ms i.e. 2,703,871/s, aver. 0us, 61.8 MB/s 49 | 100000 DoubleToShort in 13.11ms i.e. 7,626,601/s, aver. 0us, 152.1 MB/s 50 | 100000 DoubleToAscii in 12.59ms i.e. 7,942,180/s, aver. 0us, 161.2 MB/s 51 | 52 | - Our rewrite is twice faster than original flt_conv.inc from FPC RTL (str) 53 | - Delphi Win32 has trouble making 64-bit computation - no benefit since it 54 | has good optimized i87 asm (but slower than our code with FPC/Win32) 55 | - FPC is more efficient when compiling integer arithmetic; we avoided slow 56 | division by calling our Div100(), but Delphi Win64 is still far behind 57 | - Delphi Win64 has very slow FloatToText and str() 58 | 59 | } 60 | 61 | 62 | // Controls printing of NaN-sign. 63 | // Undefine to print NaN sign during float->ASCII conversion. 64 | // IEEE does not interpret the sign of a NaN, so leave it defined. 65 | {$define GRISU1_F2A_NAN_SIGNLESS} 66 | 67 | // Controls rounding of generated digits when formatting with narrowed 68 | // width (either fixed or exponential notation). 69 | // Traditionally, FPC and BP7/Delphi use "roundTiesToAway" mode. 70 | // Undefine to use "roundTiesToEven" approach. 71 | {$define GRISU1_F2A_HALF_ROUNDUP} 72 | 73 | // This one is a hack against Grusu sub-optimality. 74 | // It may be used only strictly together with GRISU1_F2A_HALF_ROUNDUP. 75 | // It does not violate most general rules due to the fact that it is 76 | // applicable only when formatting with narrowed width, where the fine 77 | // view is more desirable, and the precision is already lost, so it can 78 | // be used in general-purpose applications. 79 | // Refer to its implementation. 80 | {$define GRISU1_F2A_AGRESSIVE_ROUNDUP} // Defining this fixes several tests. 81 | 82 | // Undefine to enable SNaN support. 83 | // Note: IEEE [754-2008, page 31] requires (1) to recognize "SNaN" during 84 | // ASCII->float, and (2) to generate the "invalid FP operation" exception 85 | // either when SNaN is printed as "NaN", or "SNaN" is evaluated to QNaN, 86 | // so it would be preferable to undefine these settings, 87 | // but the FPC RTL is not ready for this right now.. 88 | {$define GRISU1_F2A_NO_SNAN} 89 | 90 | /// If Value=0 would just store '0', whatever frac_digits is supplied. 91 | {$define GRISU1_F2A_ZERONOFRACT} 92 | 93 | 94 | {$ifndef FPC} 95 | 96 | // those functions are intrinsics with FPC :) 97 | 98 | function BSRdword(c: cardinal): cardinal; 99 | asm 100 | {$ifdef CPU64} 101 | .noframe 102 | mov eax, c 103 | {$endif} 104 | bsr eax, eax 105 | end; // in our code below, we are sure that c<>0 106 | 107 | function BSRqword(const q: qword): cardinal; 108 | asm 109 | {$ifdef CPU32} 110 | bsr eax, [esp + 8] 111 | jz @1 112 | add eax, 32 113 | ret 114 | @1: bsr eax, [esp + 4] 115 | @2: {$else} 116 | .noframe 117 | mov rax, q 118 | bsr rax, rax 119 | {$endif} 120 | end; // in our code below, we are sure that q<>0 121 | 122 | 123 | {$endif FPC} 124 | 125 | const 126 | // TFloatFormatProfile for double 127 | nDig_mantissa = 17; 128 | nDig_exp10 = 3; 129 | 130 | type 131 | // "Do-It-Yourself Floating Point" structures 132 | TDIY_FP = record 133 | f: qword; 134 | e: integer; 135 | end; 136 | 137 | TDIY_FP_Power_of_10 = record 138 | c: TDIY_FP; 139 | e10: integer; 140 | end; 141 | PDIY_FP_Power_of_10 = ^TDIY_FP_Power_of_10; 142 | 143 | const 144 | ROUNDER = $80000000; 145 | 146 | {$ifdef CPUINTEL} // our faster version using 128-bit x86_64 multiplication 147 | 148 | procedure d2a_diy_fp_multiply(var x, y: TDIY_FP; normalize: boolean; 149 | out result: TDIY_FP); {$ifdef HASINLINE} inline; {$endif} 150 | var 151 | p: THash128Rec; 152 | begin 153 | mul64x64(x.f, y.f, p); // fast x86_64 / i386 asm 154 | if (p.c1 and ROUNDER) <> 0 then 155 | inc(p.h); 156 | result.f := p.h; 157 | result.e := PtrInt(x.e) + PtrInt(y.e) + 64; 158 | if normalize then 159 | if (PQWordRec(@result.f)^.h and ROUNDER) = 0 then 160 | begin 161 | result.f := result.f * 2; 162 | dec(result.e); 163 | end; 164 | end; 165 | 166 | {$else} // regular Grisu method - optimized for 32-bit CPUs 167 | 168 | procedure d2a_diy_fp_multiply(var x, y: TDIY_FP; normalize: boolean; out result: TDIY_FP); 169 | var 170 | _x: TQWordRec absolute x; 171 | _y: TQWordRec absolute y; 172 | r: TQWordRec absolute result; 173 | ac, bc, ad, bd, t1: TQWordRec; 174 | begin 175 | ac.v := qword(_x.h) * _y.h; 176 | bc.v := qword(_x.l) * _y.h; 177 | ad.v := qword(_x.h) * _y.l; 178 | bd.v := qword(_x.l) * _y.l; 179 | t1.v := qword(ROUNDER) + bd.h + bc.l + ad.l; 180 | result.f := ac.v + ad.h + bc.h + t1.h; 181 | result.e := x.e + y.e + 64; 182 | if normalize then 183 | if (r.h and ROUNDER) = 0 then 184 | begin 185 | inc(result.f, result.f); 186 | dec(result.e); 187 | end; 188 | end; 189 | 190 | {$endif CPUINTEL} 191 | 192 | const 193 | // alpha =-61; gamma = 0 194 | // full cache: 1E-450 .. 1E+432, step = 1E+18 195 | // sparse = 1/10 196 | C_PWR10_DELTA = 18; 197 | C_PWR10_COUNT = 50; 198 | 199 | type 200 | TDIY_FP_Cached_Power10 = record 201 | base: array [ 0 .. 9 ] of TDIY_FP_Power_of_10; 202 | factor_plus: array [ 0 .. 1 ] of TDIY_FP_Power_of_10; 203 | factor_minus: array [ 0 .. 1 ] of TDIY_FP_Power_of_10; 204 | // extra mantissa correction [ulp; signed] 205 | corrector: array [ 0 .. C_PWR10_COUNT - 1 ] of shortint; 206 | end; 207 | 208 | const 209 | CACHED_POWER10: TDIY_FP_Cached_Power10 = ( 210 | base: ( 211 | ( c: ( f: qword($825ECC24C8737830); e: -362 ); e10: -90 ), 212 | ( c: ( f: qword($E2280B6C20DD5232); e: -303 ); e10: -72 ), 213 | ( c: ( f: qword($C428D05AA4751E4D); e: -243 ); e10: -54 ), 214 | ( c: ( f: qword($AA242499697392D3); e: -183 ); e10: -36 ), 215 | ( c: ( f: qword($9392EE8E921D5D07); e: -123 ); e10: -18 ), 216 | ( c: ( f: qword($8000000000000000); e: -63 ); e10: 0 ), 217 | ( c: ( f: qword($DE0B6B3A76400000); e: -4 ); e10: 18 ), 218 | ( c: ( f: qword($C097CE7BC90715B3); e: 56 ); e10: 36 ), 219 | ( c: ( f: qword($A70C3C40A64E6C52); e: 116 ); e10: 54 ), 220 | ( c: ( f: qword($90E40FBEEA1D3A4B); e: 176 ); e10: 72 ) 221 | ); 222 | factor_plus: ( 223 | ( c: ( f: qword($F6C69A72A3989F5C); e: 534 ); e10: 180 ), 224 | ( c: ( f: qword($EDE24AE798EC8284); e: 1132 ); e10: 360 ) 225 | ); 226 | factor_minus: ( 227 | ( c: ( f: qword($84C8D4DFD2C63F3B); e: -661 ); e10: -180 ), 228 | ( c: ( f: qword($89BF722840327F82); e: -1259 ); e10: -360 ) 229 | ); 230 | corrector: ( 231 | 0, 0, 0, 0, 1, 0, 0, 0, 1, -1, 232 | 0, 1, 1, 1, -1, 0, 0, 1, 0, -1, 233 | 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, 234 | -1, 0, 0, -1, 0, 0, 0, 0, 0, -1, 235 | 0, 0, 0, 0, 1, 0, 0, 0, -1, 0 236 | )); 237 | CACHED_POWER10_MIN10 = -90 -360; 238 | // = ref.base[low(ref.base)].e10 + ref.factor_minus[high(ref.factor_minus)].e10 239 | 240 | // return normalized correctly rounded approximation of the power of 10 241 | // scaling factor, intended to shift a binary exponent of the original number 242 | // into selected [ alpha .. gamma ] range 243 | procedure d2a_diy_fp_cached_power10(exp10: integer; out factor: TDIY_FP_Power_of_10); 244 | var 245 | i, xmul: integer; 246 | A, B: PDIY_FP_Power_of_10; 247 | cx: PtrInt; 248 | ref: ^TDIY_FP_Cached_Power10; 249 | begin 250 | ref := @CACHED_POWER10; // much better code generation on PIC/x86_64 251 | // find non-sparse index 252 | if exp10 <= CACHED_POWER10_MIN10 then 253 | i := 0 254 | else 255 | begin 256 | i := (exp10 - CACHED_POWER10_MIN10) div C_PWR10_DELTA; 257 | if i * C_PWR10_DELTA + CACHED_POWER10_MIN10 <> exp10 then 258 | inc(i); // round-up 259 | if i > C_PWR10_COUNT - 1 then 260 | i := C_PWR10_COUNT - 1; 261 | end; 262 | // generate result 263 | xmul := i div length(ref.base); 264 | A := @ref.base[i - (xmul * length(ref.base))]; // fast mod 265 | dec(xmul, length(ref.factor_minus)); 266 | if xmul = 0 then 267 | begin 268 | // base 269 | factor := A^; 270 | exit; 271 | end; 272 | // surrogate 273 | if xmul > 0 then 274 | begin 275 | dec(xmul); 276 | B := @ref.factor_plus[xmul]; 277 | end 278 | else 279 | begin 280 | xmul := -(xmul + 1); 281 | B := @ref.factor_minus[xmul]; 282 | end; 283 | factor.e10 := A.e10 + B.e10; 284 | if A.e10 <> 0 then 285 | begin 286 | d2a_diy_fp_multiply(A.c, B.c, true, factor.c); 287 | // adjust mantissa 288 | cx := ref.corrector[i]; 289 | if cx <> 0 then 290 | inc(int64(factor.c.f), int64(cx)); 291 | end 292 | else 293 | // exact 294 | factor.c := B^.c; 295 | end; 296 | 297 | 298 | procedure d2a_unpack_float(const f: double; out minus: boolean; out result: TDIY_FP); 299 | {$ifdef HASINLINE} inline;{$endif} 300 | type 301 | TSplitFloat = packed record 302 | case byte of 303 | 0: (f: double); 304 | 1: (b: array[0..7] of byte); 305 | 2: (w: array[0..3] of word); 306 | 3: (d: array[0..1] of cardinal); 307 | 4: (l: qword); 308 | end; 309 | var 310 | doublebits: TSplitFloat; 311 | begin 312 | {$ifdef FPC_DOUBLE_HILO_SWAPPED} 313 | // high and low cardinal are swapped when using the arm fpa 314 | doublebits.d[0] := TSplitFloat(f).d[1]; 315 | doublebits.d[1] := TSplitFloat(f).d[0]; 316 | {$else not FPC_DOUBLE_HILO_SWAPPED} 317 | doublebits.f := f; 318 | {$endif FPC_DOUBLE_HILO_SWAPPED} 319 | {$ifdef endian_big} 320 | minus := (doublebits.b[0] and $80 <> 0); 321 | result.e := (doublebits.w[0] shr 4) and $7FF; 322 | {$else endian_little} 323 | minus := (doublebits.b[7] and $80 <> 0); 324 | result.e := (doublebits.w[3] shr 4) and $7FF; 325 | {$endif endian} 326 | result.f := doublebits.l and $000FFFFFFFFFFFFF; 327 | end; 328 | 329 | const 330 | C_FRAC2_BITS = 52; 331 | C_EXP2_BIAS = 1023; 332 | C_DIY_FP_Q = 64; 333 | C_GRISU_ALPHA = -61; 334 | C_GRISU_GAMMA = 0; 335 | 336 | C_EXP2_SPECIAL = C_EXP2_BIAS * 2 + 1; 337 | C_MANT2_INTEGER = qword(1) shl C_FRAC2_BITS; 338 | 339 | type 340 | TAsciiDigits = array[0..47] of byte; 341 | PAsciiDigits = ^TAsciiDigits; 342 | 343 | // convert unsigned integers into decimal digits 344 | 345 | {$ifdef FPC_64} // leverage efficient FPC 64-bit division as mul reciprocal 346 | 347 | function d2a_gen_digits_64(buf: PAsciiDigits; x: qword): PtrInt; 348 | var 349 | tab: PWordArray; 350 | P: PAnsiChar; 351 | c100: qword; 352 | begin 353 | tab := @TwoDigitByteLookupW; // 0..99 value -> two byte digits (0..9) 354 | P := PAnsiChar(@buf[24]); // append backwards 355 | repeat 356 | if x >= 100 then 357 | begin 358 | dec(P, 2); 359 | c100 := x div 100; 360 | dec(x, c100 * 100); 361 | PWord(P)^ := tab[x]; 362 | if c100 = 0 then 363 | break; 364 | x := c100; 365 | continue; 366 | end; 367 | if x < 10 then 368 | begin 369 | dec(P); 370 | P^ := AnsiChar(x); 371 | break; 372 | end; 373 | dec(P, 2); 374 | PWord(P)^ := tab[x]; 375 | break; 376 | until false; 377 | PQWordArray(buf)[0] := PQWordArray(P)[0]; // faster than MoveSmall(P,buf,result) 378 | PQWordArray(buf)[1] := PQWordArray(P)[1]; 379 | PQWordArray(buf)[2] := PQWordArray(P)[2]; 380 | result := PAnsiChar(@buf[24]) - P; 381 | end; 382 | 383 | {$else not FPC_64} // use three 32-bit groups of digit 384 | 385 | function d2a_gen_digits_32(buf: PAsciiDigits; x: dword; pad_9zero: boolean): PtrInt; 386 | const 387 | digits: array[0..9] of cardinal = ( 388 | 0, 10, 100, 1000, 10000, 100000, 1000000, 10000000, 100000000, 1000000000); 389 | var 390 | n: PtrInt; 391 | m: cardinal; 392 | {$ifdef FPC} 393 | z: cardinal; 394 | {$else} 395 | d100: TDiv100Rec; 396 | {$endif FPC} 397 | tab: PWordArray; 398 | begin 399 | // Calculate amount of digits 400 | if x = 0 then 401 | n := 0 // emit nothing if padding is not required 402 | else 403 | begin 404 | n := integer((BSRdword(x) + 1) * 1233) shr 12; 405 | if x >= digits[n] then 406 | inc(n); 407 | end; 408 | if pad_9zero and (n < 9) then 409 | n := 9; 410 | result := n; 411 | if n = 0 then 412 | exit; 413 | // Emit digits 414 | dec(PByte(buf)); 415 | tab := @TwoDigitByteLookupW; 416 | m := x; 417 | while (n >= 2) and (m <> 0) do 418 | begin 419 | dec(n); 420 | {$ifdef FPC} // FPC will use fast mul reciprocal 421 | z := m div 100; // compute two 0..9 digits 422 | PWord(@buf[n])^ := tab^[m - z * 100]; 423 | m := z; 424 | {$else} 425 | Div100(m, d100); // our asm is faster than Delphi div operation 426 | PWord(@buf[n])^ := tab^[d100.M]; 427 | m := d100.D; 428 | {$endif FPC} 429 | dec(n); 430 | end; 431 | if n = 0 then 432 | exit; 433 | if m <> 0 then 434 | begin 435 | if m > 9 then 436 | m := m mod 10; // compute last 0..9 digit 437 | buf[n] := m; 438 | dec(n); 439 | if n = 0 then 440 | exit; 441 | end; 442 | repeat 443 | buf[n] := 0; // padding with 0 444 | dec(n); 445 | until n = 0; 446 | end; 447 | 448 | function d2a_gen_digits_64(buf: PAsciiDigits; const x: qword): PtrInt; 449 | var 450 | n_digits: PtrInt; 451 | temp: qword; 452 | splitl, splitm, splith: cardinal; 453 | begin 454 | // Split X into 3 unsigned 32-bit integers; lower two should be < 10 digits long 455 | n_digits := 0; 456 | if x < 1000000000 then 457 | splitl := x 458 | else 459 | begin 460 | temp := x div 1000000000; 461 | splitl := x - temp * 1000000000; 462 | if temp < 1000000000 then 463 | splitm := temp 464 | else 465 | begin 466 | splith := temp div 1000000000; 467 | splitm := cardinal(temp) - splith * 1000000000; 468 | n_digits := d2a_gen_digits_32(buf, splith, false); // Generate hi digits 469 | end; 470 | inc(n_digits, d2a_gen_digits_32(@buf[n_digits], splitm, n_digits <> 0)); 471 | end; 472 | // Generate digits 473 | inc(n_digits, d2a_gen_digits_32(@buf[n_digits], splitl, n_digits <> 0)); 474 | result := n_digits; 475 | end; 476 | 477 | {$endif FPC_64} 478 | 479 | // Performs digit sequence rounding, returns decimal point correction 480 | function d2a_round_digits(var buf: TAsciiDigits; var n_current: integer; 481 | n_max: PtrInt; half_round_to_even: boolean = true): PtrInt; 482 | var 483 | n: PtrInt; 484 | dig_round, dig_sticky: byte; 485 | {$ifdef GRISU1_F2A_AGRESSIVE_ROUNDUP} 486 | i: PtrInt; 487 | {$endif} 488 | begin 489 | result := 0; 490 | n := n_current; 491 | n_current := n_max; 492 | // Get round digit 493 | dig_round := buf[n_max]; 494 | {$ifdef GRISU1_F2A_AGRESSIVE_ROUNDUP} 495 | // Detect if rounding-up the second last digit turns the "dig_round" 496 | // into "5"; also make sure we have at least 1 digit between "dig_round" 497 | // and the second last. 498 | if not half_round_to_even then 499 | if (dig_round = 4) and (n_max < n - 3) then 500 | if buf[n - 2] >= 8 then // somewhat arbitrary... 501 | begin 502 | // check for only "9" are in between 503 | i := n - 2; 504 | repeat 505 | dec(i); 506 | until (i = n_max) or (buf[i] <> 9); 507 | if i = n_max then 508 | // force round-up 509 | dig_round := 9; // any value ">=5" 510 | end; 511 | {$endif GRISU1_F2A_AGRESSIVE_ROUNDUP} 512 | if dig_round < 5 then 513 | exit; 514 | // Handle "round half to even" case 515 | if (dig_round = 5) and half_round_to_even and 516 | ((n_max = 0) or (buf[n_max - 1] and 1 = 0)) then 517 | begin 518 | // even and a half: check if exactly the half 519 | dig_sticky := 0; 520 | while (n > n_max + 1) and (dig_sticky = 0) do 521 | begin 522 | dec(n); 523 | dig_sticky := buf[n]; 524 | end; 525 | if dig_sticky = 0 then 526 | exit; // exactly a half -> no rounding is required 527 | end; 528 | // Round-up 529 | while n_max > 0 do 530 | begin 531 | dec(n_max); 532 | inc(buf[n_max]); 533 | if buf[n_max] < 10 then 534 | begin 535 | // no more overflow: stop now 536 | n_current := n_max + 1; 537 | exit; 538 | end; 539 | // continue rounding 540 | end; 541 | // Overflow out of the 1st digit, all n_max digits became 0 542 | buf[0] := 1; 543 | n_current := 1; 544 | result := 1; 545 | end; 546 | 547 | 548 | // format the number in the fixed-point representation 549 | procedure d2a_return_fixed(str: PAnsiChar; minus: boolean; var digits: TAsciiDigits; 550 | n_digits_have, fixed_dot_pos, frac_digits: integer); 551 | var 552 | p: PAnsiChar; 553 | d: PByte; 554 | cut_digits_at, n_before_dot, n_before_dot_pad0, n_after_dot_pad0, 555 | n_after_dot, n_tail_pad0: integer; 556 | begin 557 | // Round digits if necessary 558 | cut_digits_at := fixed_dot_pos + frac_digits; 559 | if cut_digits_at < 0 then 560 | // zero 561 | n_digits_have := 0 562 | else if cut_digits_at < n_digits_have then 563 | // round digits 564 | inc(fixed_dot_pos, d2a_round_digits(digits, n_digits_have, cut_digits_at 565 | {$ifdef GRISU1_F2A_HALF_ROUNDUP}, false {$endif} )); 566 | // Before dot: digits, pad0 567 | if (fixed_dot_pos <= 0) or (n_digits_have = 0) then 568 | begin 569 | n_before_dot := 0; 570 | n_before_dot_pad0 := 1; 571 | end 572 | else if fixed_dot_pos > n_digits_have then 573 | begin 574 | n_before_dot := n_digits_have; 575 | n_before_dot_pad0 := fixed_dot_pos - n_digits_have; 576 | end 577 | else 578 | begin 579 | n_before_dot := fixed_dot_pos; 580 | n_before_dot_pad0 := 0; 581 | end; 582 | // After dot: pad0, digits, pad0 583 | if fixed_dot_pos < 0 then 584 | n_after_dot_pad0 := -fixed_dot_pos 585 | else 586 | n_after_dot_pad0 := 0; 587 | if n_after_dot_pad0 > frac_digits then 588 | n_after_dot_pad0 := frac_digits; 589 | n_after_dot := n_digits_have - n_before_dot; 590 | n_tail_pad0 := frac_digits - n_after_dot - n_after_dot_pad0; 591 | p := str + 1; 592 | // Sign 593 | if minus then 594 | begin 595 | p^ := '-'; 596 | inc(p); 597 | end; 598 | // Integer significant digits 599 | d := @digits; 600 | if n_before_dot > 0 then 601 | repeat 602 | p^ := AnsiChar(d^ + ord('0')); 603 | inc(p); 604 | inc(d); 605 | dec(n_before_dot); 606 | until n_before_dot = 0; 607 | // Integer 0-padding 608 | if n_before_dot_pad0 > 0 then 609 | repeat 610 | p^ := '0'; 611 | inc(p); 612 | dec(n_before_dot_pad0); 613 | until n_before_dot_pad0 = 0; 614 | // 615 | if frac_digits <> 0 then 616 | begin 617 | // Dot 618 | p^ := '.'; 619 | inc(p); 620 | // Pre-fraction 0-padding 621 | if n_after_dot_pad0 > 0 then 622 | repeat 623 | p^ := '0'; 624 | inc(p); 625 | dec(n_after_dot_pad0); 626 | until n_after_dot_pad0 = 0; 627 | // Fraction significant digits 628 | if n_after_dot > 0 then 629 | repeat 630 | p^ := AnsiChar(d^ + ord('0')); 631 | inc(p); 632 | inc(d); 633 | dec(n_after_dot); 634 | until n_after_dot = 0; 635 | // Tail 0-padding 636 | if n_tail_pad0 > 0 then 637 | repeat 638 | p^ := '0'; 639 | inc(p); 640 | dec(n_tail_pad0); 641 | until n_tail_pad0 = 0; 642 | end; 643 | // Store length 644 | str[0] := AnsiChar(p - str - 1); 645 | end; 646 | 647 | // formats the number as exponential representation 648 | procedure d2a_return_exponential(str: PAnsiChar; minus: boolean; 649 | digits: PByte; n_digits_have, n_digits_req, d_exp: PtrInt); 650 | var 651 | p, exp: PAnsiChar; 652 | begin 653 | p := str + 1; 654 | // Sign 655 | if minus then 656 | begin 657 | p^ := '-'; 658 | inc(p); 659 | end; 660 | // Integer part 661 | if n_digits_have > 0 then 662 | begin 663 | p^ := AnsiChar(digits^ + ord('0')); 664 | dec(n_digits_have); 665 | end 666 | else 667 | p^ := '0'; 668 | inc(p); 669 | // Dot 670 | if n_digits_req > 1 then 671 | begin 672 | p^ := '.'; 673 | inc(p); 674 | end; 675 | // Fraction significant digits 676 | if n_digits_req < n_digits_have then 677 | n_digits_have := n_digits_req; 678 | if n_digits_have > 0 then 679 | begin 680 | repeat 681 | inc(digits); 682 | p^ := AnsiChar(digits^ + ord('0')); 683 | inc(p); 684 | dec(n_digits_have); 685 | until n_digits_have = 0; 686 | while p[-1] = '0' do 687 | dec(p); // trim #.###00000 -> #.### 688 | if p[-1] = '.' then 689 | dec(p); // #.0 -> # 690 | end; 691 | // Exponent designator 692 | p^ := 'E'; 693 | inc(p); 694 | // Exponent sign (+ is not stored, as in Delphi) 695 | if d_exp < 0 then 696 | begin 697 | p^ := '-'; 698 | d_exp := -d_exp; 699 | inc(p); 700 | end; 701 | // Exponent digits 702 | exp := pointer(SmallUInt32UTF8[d_exp]); // 0..999 range is fine 703 | PCardinal(p)^ := PCardinal(exp)^; 704 | inc(p, PStrLen(exp - _STRLEN)^); 705 | // Store length 706 | str[0] := AnsiChar(p - str - 1); 707 | end; 708 | 709 | /// set one of special results with proper sign 710 | procedure d2a_return_special(str: PAnsiChar; sign: integer; const spec: shortstring); 711 | begin 712 | // Compute length 713 | str[0] := spec[0]; 714 | if sign <> 0 then 715 | inc(str[0]); 716 | inc(str); 717 | // Sign 718 | if sign <> 0 then 719 | begin 720 | if sign > 0 then 721 | str^ := '+' 722 | else 723 | str^ := '-'; 724 | inc(str); 725 | end; 726 | // Special text (3 chars) 727 | PCardinal(str)^ := PCardinal(@spec[1])^; 728 | end; 729 | 730 | 731 | // Calculates the exp10 of a factor required to bring the binary exponent 732 | // of the original number into selected [ alpha .. gamma ] range: 733 | // result := ceiling[ ( alpha - e ) * log10(2) ] 734 | function d2a_k_comp(e, alpha{, gamma}: integer): integer; 735 | var 736 | dexp: double; 737 | const 738 | D_LOG10_2: double = 0.301029995663981195213738894724493027; // log10(2) 739 | var 740 | x, n: integer; 741 | begin 742 | x := alpha - e; 743 | dexp := x * D_LOG10_2; 744 | // ceil( dexp ) 745 | n := trunc(dexp); 746 | if x > 0 then 747 | if dexp <> n then 748 | inc(n); // round-up 749 | result := n; 750 | end; 751 | 752 | 753 | /// raw function to convert a 64-bit double into a shortstring, stored in str 754 | // - implements Fabian Loitsch's Grisu algorithm dedicated to double values 755 | // - currently, SynCommnons only set min_width=0 (for DoubleToShortNoExp to avoid 756 | // any scientific notation ) or min_width=C_NO_MIN_WIDTH (for DoubleToShort to 757 | // force the scientific notation when the double cannot be represented as 758 | // a simple fractinal number) 759 | procedure DoubleToAscii(min_width, frac_digits: integer; const v: double; str: PAnsiChar); 760 | var 761 | w, D: TDIY_FP; 762 | c_mk: TDIY_FP_Power_of_10; 763 | n, mk, dot_pos, n_digits_need, n_digits_have: integer; 764 | n_digits_req, n_digits_sci: integer; 765 | minus: boolean; 766 | fl, one_maskl: qword; 767 | one_e: integer; 768 | {$ifdef CPU32} 769 | one_mask, f: cardinal; // run a 2nd loop with 32-bit range 770 | {$endif CPU32} 771 | buf: TAsciiDigits; 772 | begin 773 | // Limit parameters 774 | if frac_digits > 216 then 775 | frac_digits := 216; // Delphi compatible 776 | if min_width <= C_NO_MIN_WIDTH then 777 | min_width := -1 // no minimal width 778 | else if min_width < 0 then 779 | min_width := 0; // minimal width is as short as possible 780 | // Format profile: select "n_digits_need" (and "n_digits_exp") 781 | n_digits_req := nDig_mantissa; 782 | // number of digits to be calculated by Grisu 783 | n_digits_need := nDig_mantissa; 784 | if n_digits_req < n_digits_need then 785 | n_digits_need := n_digits_req; 786 | // number of mantissa digits to be printed in exponential notation 787 | if min_width < 0 then 788 | n_digits_sci := n_digits_req 789 | else 790 | begin 791 | n_digits_sci := min_width -1 {sign} -1 {dot} -1 {E} -1 {E-sign} - nDig_exp10; 792 | if n_digits_sci < 2 then 793 | n_digits_sci := 2; // at least 2 digits 794 | if n_digits_sci > n_digits_req then 795 | n_digits_sci := n_digits_req; // at most requested by real_type 796 | end; 797 | // Float -> DIY_FP 798 | d2a_unpack_float(v, minus, w); 799 | // Handle Zero 800 | if (w.e = 0) and (w.f = 0) then 801 | begin 802 | {$ifdef GRISU1_F2A_ZERONOFRACT} 803 | PWord(str)^ := 1 + ord('0') shl 8; // just return '0' 804 | {$else} 805 | if frac_digits >= 0 then 806 | d2a_return_fixed(str, minus, buf, 0, 1, frac_digits) 807 | else 808 | d2a_return_exponential(str, minus, @buf, 0, n_digits_sci, 0); 809 | {$endif GRISU1_F2A_ZERONOFRACT} 810 | exit; 811 | end; 812 | // Handle specials 813 | if w.e = C_EXP2_SPECIAL then 814 | begin 815 | n := 1 - ord(minus) * 2; // default special sign [-1|+1] 816 | if w.f = 0 then 817 | d2a_return_special(str, n, C_STR_INF) 818 | else 819 | begin 820 | // NaN [also pseudo-NaN, pseudo-Inf, non-normal for floatx80] 821 | {$ifdef GRISU1_F2A_NAN_SIGNLESS} 822 | n := 0; 823 | {$endif} 824 | {$ifndef GRISU1_F2A_NO_SNAN} 825 | if (w.f and (C_MANT2_INTEGER shr 1)) = 0 then 826 | return_special(str, n, C_STR_SNAN) 827 | else 828 | {$endif GRISU1_F2A_NO_SNAN} 829 | d2a_return_special(str, n, C_STR_QNAN); 830 | end; 831 | exit; 832 | end; 833 | // Handle denormals 834 | if w.e <> 0 then 835 | begin 836 | // normal 837 | w.f := w.f or C_MANT2_INTEGER; 838 | n := C_DIY_FP_Q - C_FRAC2_BITS - 1; 839 | end 840 | else 841 | begin 842 | // denormal (w.e=0) 843 | n := 63 - BSRqword(w.f); // we are sure that w.f<>0 - see Handle Zero above 844 | inc(w.e); 845 | end; 846 | // Final normalization 847 | w.f := w.f shl n; 848 | dec(w.e, C_EXP2_BIAS + n + C_FRAC2_BITS); 849 | // 1. Find the normalized "c_mk = f_c * 2^e_c" such that 850 | // "alpha <= e_c + e_w + q <= gamma" 851 | // 2. Define "V = D * 10^k": multiply the input number by "c_mk", do not 852 | // normalize to land into [ alpha .. gamma ] 853 | // 3. Generate digits ( n_digits_need + "round" ) 854 | if (C_GRISU_ALPHA <= w.e) and (w.e <= C_GRISU_GAMMA) then 855 | begin 856 | // no scaling required 857 | D := w; 858 | c_mk.e10 := 0; 859 | end 860 | else 861 | begin 862 | mk := d2a_k_comp(w.e, C_GRISU_ALPHA{, C_GRISU_GAMMA} ); 863 | d2a_diy_fp_cached_power10(mk, c_mk); 864 | // Let "D = f_D * 2^e_D := w (*) c_mk" 865 | if c_mk.e10 = 0 then 866 | D := w 867 | else 868 | d2a_diy_fp_multiply(w, c_mk.c, false, D); 869 | end; 870 | // Generate digits: integer part 871 | n_digits_have := d2a_gen_digits_64(@buf, D.f shr (-D.e)); 872 | dot_pos := n_digits_have; 873 | // Generate digits: fractional part 874 | {$ifdef CPU32} 875 | f := 0; // "sticky" digit 876 | {$endif CPU32} 877 | if D.e < 0 then 878 | repeat 879 | // MOD by ONE 880 | one_e := D.e; 881 | one_maskl := qword(1) shl (-D.e) - 1; 882 | fl := D.f and one_maskl; 883 | // 64-bit loop (very efficient on x86_64, slower on i386) 884 | while {$ifdef CPU32} (one_e < -29) and {$endif} 885 | (n_digits_have < n_digits_need + 1) and (fl <> 0) do 886 | begin 887 | // f := f * 5; 888 | inc(fl, fl shl 2); 889 | // one := one / 2 890 | one_maskl := one_maskl shr 1; 891 | inc(one_e); 892 | // DIV by one 893 | buf[n_digits_have] := fl shr (-one_e); 894 | // MOD by one 895 | fl := fl and one_maskl; 896 | // next 897 | inc(n_digits_have); 898 | end; 899 | {$ifdef CPU32} 900 | if n_digits_have >= n_digits_need + 1 then 901 | begin 902 | // only "sticky" digit remains 903 | f := ord(fl <> 0); 904 | break; 905 | end; 906 | one_mask := cardinal(one_maskl); 907 | f := cardinal(fl); 908 | // 32-bit loop 909 | while (n_digits_have < n_digits_need + 1) and (f <> 0) do 910 | begin 911 | // f := f * 5; 912 | inc(f, f shl 2); 913 | // one := one / 2 914 | one_mask := one_mask shr 1; 915 | inc(one_e); 916 | // DIV by one 917 | buf[n_digits_have] := f shr (-one_e); 918 | // MOD by one 919 | f := f and one_mask; 920 | // next 921 | inc(n_digits_have); 922 | end; 923 | {$endif CPU32} 924 | until true; 925 | {$ifdef CPU32} 926 | // Append "sticky" digit if any 927 | if (f <> 0) and (n_digits_have >= n_digits_need + 1) then 928 | begin 929 | // single "<>0" digit is enough 930 | n_digits_have := n_digits_need + 2; 931 | buf[n_digits_need + 1] := 1; 932 | end; 933 | {$endif CPU32} 934 | // Round to n_digits_need using "roundTiesToEven" 935 | if n_digits_have > n_digits_need then 936 | inc(dot_pos, d2a_round_digits(buf, n_digits_have, n_digits_need)); 937 | // Generate output 938 | if frac_digits >= 0 then 939 | begin 940 | d2a_return_fixed(str, minus, buf, n_digits_have, dot_pos - c_mk.e10, 941 | frac_digits); 942 | exit; 943 | end; 944 | if n_digits_have > n_digits_sci then 945 | inc(dot_pos, d2a_round_digits(buf, n_digits_have, n_digits_sci 946 | {$ifdef GRISU1_F2A_HALF_ROUNDUP}, false {$endif} )); 947 | d2a_return_exponential(str, minus, @buf, n_digits_have, n_digits_sci, 948 | dot_pos - c_mk.e10 - 1); 949 | end; 950 | 951 | -------------------------------------------------------------------------------- /SynFPCTypInfo.pas: -------------------------------------------------------------------------------- 1 | /// wrapper around FPC typinfo.pp unit for SynCommons.pas and mORMot.pas 2 | // - this unit is a part of the freeware Synopse mORMot framework, 3 | // licensed under a MPL/GPL/LGPL tri-license; version 1.18 4 | unit SynFPCTypInfo; 5 | 6 | { 7 | This file is part of Synopse mORMot framework. 8 | 9 | Synopse mORMot framework. Copyright (c) Arnaud Bouchez 10 | Synopse Informatique - https://synopse.info 11 | 12 | *** BEGIN LICENSE BLOCK ***** 13 | Version: MPL 1.1/GPL 2.0/LGPL 2.1 14 | 15 | The contents of this file are subject to the Mozilla Public License Version 16 | 1.1 (the "License"); you may not use this file except in compliance with 17 | the License. You may obtain a copy of the License at 18 | http://www.mozilla.org/MPL 19 | 20 | Software distributed under the License is distributed on an "AS IS" basis, 21 | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 22 | for the specific language governing rights and limitations under the License. 23 | 24 | The Original Code is Synopse mORMot framework. 25 | 26 | The Initial Developer of the Original Code is Alfred Glaenzer. 27 | 28 | Portions created by the Initial Developer are Copyright (c) 29 | the Initial Developer. All Rights Reserved. 30 | 31 | Contributor(s): 32 | - Arnaud Bouchez 33 | 34 | 35 | Alternatively, the contents of this file may be used under the terms of 36 | either the GNU General Public License Version 2 or later (the "GPL"), or 37 | the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), 38 | in which case the provisions of the GPL or the LGPL are applicable instead 39 | of those above. if you wish to allow use of your version of this file only 40 | under the terms of either the GPL or the LGPL, and not to allow others to 41 | use your version of this file under the terms of the MPL, indicate your 42 | decision by deleting the provisions above and replace them with the notice 43 | and other provisions required by the GPL or the LGPL. if you do not delete 44 | the provisions above, a recipient may use your version of this file under 45 | the terms of any one of the MPL, the GPL or the LGPL. 46 | 47 | ***** END LICENSE BLOCK ***** 48 | 49 | Unit created to avoid polluting the SynCommons.pas/mORMot.pas namespace 50 | with overloaded typinfo.pp types. 51 | 52 | } 53 | 54 | interface 55 | 56 | {$ifndef FPC} 57 | 'this unit is for FPC only - do not include it in any Delphi project!' 58 | {$endif FPC} 59 | 60 | {$I Synopse.inc} // define HASINLINE CPU32 CPU64 OWNNORMTOUPPER 61 | 62 | uses 63 | SysUtils, 64 | TypInfo; 65 | 66 | {$ifdef FPC_PROVIDE_ATTR_TABLE} 67 | type 68 | // if you have a compilation error here, your FPC trunk is too old 69 | // - TTypeData.AttributeTable was introduced in SVN 42356-42411 (2019/07) 70 | // -> undefine FPC_PROVIDE_ATTR_TABLE in Synopse.inc and recompile 71 | PFPCAttributeTable = TypInfo.PAttributeTable; 72 | {$endif FPC_PROVIDE_ATTR_TABLE} 73 | 74 | {$ifdef HASALIGNTYPEDATA} 75 | function AlignTypeData(p: pointer): pointer; inline; 76 | function AlignTypeDataClean(p: pointer): pointer; inline; 77 | {$else} 78 | type 79 | AlignTypeData = pointer; 80 | AlignTypeDataClean = pointer; 81 | {$endif HASALIGNTYPEDATA} 82 | 83 | 84 | {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} 85 | function AlignToPtr(p: pointer): pointer; inline; 86 | function AlignPTypeInfo(p: pointer): pointer; inline; 87 | {$else FPC_REQUIRES_PROPER_ALIGNMENT} 88 | type 89 | AlignToPtr = pointer; 90 | AlignPTypeInfo = pointer; 91 | {$endif FPC_REQUIRES_PROPER_ALIGNMENT} 92 | 93 | type 94 | /// some type definition to avoid inclusion of TypInfo in SynCommons/mORMot.pas 95 | PFPCInterfaceData = TypInfo.PInterfaceData; 96 | PFPCVmtMethodParam = TypInfo.PVmtMethodParam; 97 | PFPCIntfMethodTable = TypInfo.PIntfMethodTable; 98 | PFPCIntfMethodEntry = TypInfo.PIntfMethodEntry; 99 | {$ifdef FPC_NEWRTTI} 100 | PFPCRecInitData = TypInfo.PRecInitData; 101 | 102 | {$endif FPC_NEWRTTI} 103 | 104 | procedure FPCDynArrayClear(var a: Pointer; TypeInfo: Pointer); 105 | procedure FPCFinalizeArray(p: Pointer; TypeInfo: Pointer; elemCount: PtrUInt); 106 | procedure FPCFinalize(Data: Pointer; TypeInfo: Pointer); 107 | procedure FPCRecordCopy(const Source; var Dest; TypeInfo: pointer); 108 | procedure FPCRecordAddRef(var Data; TypeInfo : pointer); 109 | 110 | 111 | implementation 112 | 113 | procedure FPCDynArrayClear(var a: Pointer; TypeInfo: Pointer); 114 | external name 'FPC_DYNARRAY_CLEAR'; 115 | procedure FPCFinalizeArray(p: Pointer; TypeInfo: Pointer; elemCount: PtrUInt); 116 | external name 'FPC_FINALIZE_ARRAY'; 117 | procedure FPCFinalize(Data: Pointer; TypeInfo: Pointer); 118 | external name 'FPC_FINALIZE'; 119 | procedure FPCRecordCopy(const Source; var Dest; TypeInfo: pointer); 120 | external name 'FPC_COPY'; 121 | procedure FPCRecordAddRef(var Data; TypeInfo : pointer); 122 | external name 'FPC_ADDREF'; 123 | 124 | {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} // copied from latest typinfo.pp 125 | function AlignToPtr(p: pointer): pointer; 126 | begin 127 | result := align(p,sizeof(p)); 128 | end; 129 | 130 | function AlignTypeData(p: pointer): pointer; 131 | {$packrecords c} 132 | type 133 | TAlignCheck = record // match RTTI TTypeInfo definition 134 | b : byte; // = TTypeKind 135 | q : qword; // = this is where the PTypeData begins 136 | end; 137 | {$packrecords default} 138 | begin 139 | {$ifdef VER3_0} 140 | result := Pointer(align(p,SizeOf(Pointer))); 141 | {$else VER3_0} 142 | result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).q))); 143 | {$endif VER3_0} 144 | {$ifdef FPC_PROVIDE_ATTR_TABLE} 145 | inc(PByte(result),SizeOf(PFPCAttributeTable)); // ignore attributes table 146 | result := Pointer(align(result,PtrInt(@TAlignCheck(nil^).q))); 147 | {$endif FPC_PROVIDE_ATTR_TABLE} 148 | end; 149 | {$else} 150 | {$ifdef FPC_PROVIDE_ATTR_TABLE} 151 | function AlignTypeData(p: pointer): pointer; 152 | begin 153 | result := p; 154 | inc(PByte(result),SizeOf(PFPCAttributeTable)); // ignore attributes table 155 | end; 156 | {$endif FPC_PROVIDE_ATTR_TABLE} 157 | {$endif FPC_REQUIRES_PROPER_ALIGNMENT} 158 | 159 | {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} // copied from latest typinfo.pp 160 | 161 | function AlignTypeDataClean(p: pointer): pointer; 162 | {$packrecords c} 163 | type 164 | TAlignCheck = record // match RTTI TTypeInfo definition 165 | b : byte; // = TTypeKind 166 | q : qword; // = this is where the PTypeData begins 167 | end; 168 | {$packrecords default} 169 | begin 170 | {$ifdef VER3_0} 171 | result := Pointer(align(p,SizeOf(Pointer))); 172 | {$else VER3_0} 173 | result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).q))); 174 | {$endif VER3_0} 175 | end; 176 | 177 | function AlignPTypeInfo(p: pointer): pointer; inline; 178 | {$packrecords c} 179 | type 180 | TAlignCheck = record 181 | b : byte; 182 | p : pointer; 183 | end; 184 | {$packrecords default} 185 | begin 186 | Result := Pointer(align(p,PtrInt(@TAlignCheck(nil^).p))) 187 | 188 | end; 189 | 190 | {$else} 191 | {$ifdef HASALIGNTYPEDATA} 192 | function AlignTypeDataClean(p: pointer): pointer; 193 | begin 194 | result := p; 195 | end; 196 | {$endif HASALIGNTYPEDATA} 197 | 198 | {$endif FPC_REQUIRES_PROPER_ALIGNMENT} 199 | 200 | end. 201 | -------------------------------------------------------------------------------- /SynLZ.pas: -------------------------------------------------------------------------------- 1 | /// SynLZ Compression routines 2 | // - licensed under a MPL/GPL/LGPL tri-license; version 1.18 3 | unit SynLZ; 4 | 5 | { 6 | This file is part of Synopse SynLZ Compression. 7 | 8 | Synopse SynLZ Compression. Copyright (c) Arnaud Bouchez 9 | Synopse Informatique - https://synopse.info 10 | 11 | *** BEGIN LICENSE BLOCK ***** 12 | Version: MPL 1.1/GPL 2.0/LGPL 2.1 13 | 14 | The contents of this file are subject to the Mozilla Public License Version 15 | 1.1 (the "License"); you may not use this file except in compliance with 16 | the License. You may obtain a copy of the License at 17 | http://www.mozilla.org/MPL 18 | 19 | Software distributed under the License is distributed on an "AS IS" basis, 20 | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 21 | for the specific language governing rights and limitations under the License. 22 | 23 | The Original Code is Synopse SynLZ Compression. 24 | 25 | The Initial Developer of the Original Code is Arnaud Bouchez. 26 | 27 | Portions created by the Initial Developer are Copyright (c) 28 | the Initial Developer. All Rights Reserved. 29 | 30 | Contributor(s): 31 | 32 | Alternatively, the contents of this file may be used under the terms of 33 | either the GNU General Public License Version 2 or later (the "GPL"), or 34 | the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), 35 | in which case the provisions of the GPL or the LGPL are applicable instead 36 | of those above. If you wish to allow use of your version of this file only 37 | under the terms of either the GPL or the LGPL, and not to allow others to 38 | use your version of this file under the terms of the MPL, indicate your 39 | decision by deleting the provisions above and replace them with the notice 40 | and other provisions required by the GPL or the LGPL. If you do not delete 41 | the provisions above, a recipient may use your version of this file under 42 | the terms of any one of the MPL, the GPL or the LGPL. 43 | 44 | ***** END LICENSE BLOCK ***** 45 | 46 | 47 | SynLZ Compression / Decompression library 48 | ========================================= 49 | 50 | * SynLZ is a very FAST lossless data compression library 51 | written in optimized pascal code for FPC and Delphi 3 and up 52 | with a tuned asm version available 53 | * symetrical compression and decompression speed (which is 54 | very rare above all other compression algorithms in the wild) 55 | * good compression rate (usualy better than LZO) 56 | * fastest averrage compression speed (ideal for xml/text communication, e.g.) 57 | 58 | SynLZ implements a new LZ compression algorithm with the following features: 59 | * hashing+dictionary compression in one pass, with no huffman table 60 | * optimized 32bits control word, embedded in the data stream 61 | * in-memory compression (the dictionary is the input stream itself) 62 | * compression and decompression have the same speed (both use hashing) 63 | * thread safe and lossless algorithm 64 | * supports overlapping compression and in-place decompression 65 | * code size for compression/decompression functions is smaller than LZO's 66 | 67 | Implementation notes: 68 | - this format is NOT stream compatible with any lz* official format 69 | => meant for proprietary server-side content real-time compression 70 | => use it internally in your application, not as exchange format 71 | => consider our SynLizard.pas unit for Lizard (LZ5) compression standard 72 | - very small code size (less than 1KB for both compressor/decompressor) 73 | - the uncompressed data length is stored in the beginning of the stream 74 | and can be retrieved easily for proper out_p memory allocation 75 | - please give correct data to the decompressor (i.e. first CRC in_p data) 76 | => we recommend crc32c() from SynCommons, or a zip-like container 77 | - a 2nd more tuned algorithm is included, but is somewhat slower in practice 78 | => use SynLZ[de]compres1*() functions in your applications 79 | - tested and benchmarked with a lot of data types/sizes 80 | => use the asm code, which is very tuned: SynLZ[de]compress1asm() 81 | - a hashing limitation makes SynLZ sometimes unable to pack continuous 82 | blocks of same byte -> SynLZ is perfect for xml/text (e.g. log files), 83 | but SynZip or SynLizard may be prefered for database files 84 | - if you include it in your application, please give me some credits: 85 | "use SynLZ compression by https://synopse.info" 86 | - use at your own risk! 87 | 88 | Benchmark update - introducing LZ4 at http://code.google.com/p/lz4 89 | 190 MB file containing pascal sources, on a Core 2 duo PC, using x86 asm: 90 | LZ4 compression = 1.25 sec, comp. size = 71 MB, decompression = 0.44 sec 91 | SynLZ compression = 1.09 sec, comp. size = 63 MB, decompression = 0.51 sec 92 | zip (1) compression = 6.44 sec, comp. size = 52 MB, decompression = 1.49 sec 93 | zip (6) compression = 20.1 sec, comp. size = 42 MB, decompression = 1.35 sec 94 | Note: zip decompression here uses fast asm optimized version of SynZip.pas 95 | Decompression is slower in SynLZ, due to the algorithm used: it does recreate 96 | the hash table even at decompression, while it is not needed by LZ4. 97 | Having the hash table at hand allows more patterns to be available, so 98 | compression ratio is better, at the expand of a slower speed. 99 | 100 | Conclusion: 101 | SynLZ compresses better than LZ4, SynLZ is faster to compress than LZ4, 102 | but slower to decompress than LZ4. So SynLZ is still very competitive for 103 | our Client-Server mORMot purpose, since it is a simple pascal unit with 104 | no external .obj/.o/.dll dependency. ;) 105 | 106 | Updated benchmarks on a Core i7, with the 2017/08 x86 and x64 optimized asm: 107 | Win32 Processing devpcm.log = 98.7 MB 108 | Snappy compress in 125.07ms, ratio=84%, 789.3 MB/s 109 | Snappy uncompress in 70.35ms, 1.3 GB/s 110 | SynLZ compress in 103.61ms, ratio=93%, 952.8 MB/s 111 | SynLZ uncompress in 68.71ms, 1.4 GB/s 112 | Win64 Processing devpcm.log = 98.7 MB 113 | Snappy compress in 107.13ms, ratio=84%, 921.5 MB/s 114 | Snappy uncompress in 61.06ms, 1.5 GB/s 115 | SynLZ compress in 97.25ms, ratio=93%, 1015.1 MB/s 116 | SynLZ uncompress in 61.27ms, 1.5 GB/s 117 | 118 | } 119 | 120 | interface 121 | 122 | {$I Synopse.inc} 123 | 124 | /// get maximum possible (worse) compressed size for out_p 125 | function SynLZcompressdestlen(in_len: integer): integer; 126 | 127 | /// get uncompressed size from lz-compressed buffer (to reserve memory, e.g.) 128 | function SynLZdecompressdestlen(in_p: PAnsiChar): integer; 129 | 130 | /// 1st compression algorithm uses hashing with a 32bits control word 131 | function SynLZcompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 132 | 133 | /// 1st compression algorithm uses hashing with a 32bits control word 134 | // - this is the fastest pure pascal implementation 135 | function SynLZdecompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 136 | 137 | /// 1st compression algorithm uses hashing with a 32bits control word 138 | // - this overload function is slower, but will allow to uncompress only the start 139 | // of the content (e.g. to read some metadata header) 140 | // - it will also check for dst buffer overflow, so will be more secure than 141 | // other functions, which expect the content to be verified (e.g. via CRC) 142 | function SynLZdecompress1partial(src: PAnsiChar; size: integer; dst: PAnsiChar; 143 | maxDst: integer): integer; 144 | 145 | {$ifdef CPUINTEL} 146 | /// optimized x86/x64 asm version of the 1st compression algorithm 147 | function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 148 | /// optimized x86/x64 asm version of the 1st compression algorithm 149 | function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 150 | {$else} 151 | var 152 | /// fast redirection to pure pascal SynLZ compression (using 1st algorithm) 153 | SynLZCompress1: function( 154 | src: PAnsiChar; size: integer; dst: PAnsiChar): integer = SynLZcompress1pas; 155 | 156 | /// fast redirection to pure pascal SynLZ decompression (using 1st algorithm) 157 | SynLZDecompress1: function( 158 | src: PAnsiChar; size: integer; dst: PAnsiChar): integer = SynLZDecompress1pas; 159 | {$endif CPUINTEL} 160 | 161 | /// 2nd compression algorithm optimizing pattern copy 162 | // - this algorithm is a bit smaller, but slower, so the 1st method is preferred 163 | function SynLZcompress2(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 164 | /// 2nd compression algorithm optimizing pattern copy 165 | // - this algorithm is a bit smaller, but slower, so the 1st method is preferred 166 | function SynLZdecompress2(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 167 | 168 | 169 | implementation 170 | 171 | function SynLZcompressdestlen(in_len: integer): integer; 172 | begin // get maximum possible (worse) compressed size for out_p 173 | result := in_len+in_len shr 3+16; 174 | end; 175 | 176 | type // some cross-platform and cross-compiler definitions 177 | {$ifndef FPC} 178 | PtrInt = {$ifdef CPU64}NativeInt{$else}integer{$endif}; 179 | PtrUInt = {$ifdef CPU64}NativeUInt{$else}cardinal{$endif}; 180 | {$endif} 181 | {$ifdef DELPHI5OROLDER} // Delphi 5 doesn't have those base types defined :( 182 | PByte = ^Byte; 183 | PWord = ^Word; 184 | PInteger = ^integer; 185 | PCardinal = ^Cardinal; 186 | IntegerArray = array[0..$effffff] of integer; 187 | PIntegerArray = ^IntegerArray; 188 | {$endif} 189 | TOffsets = array[0..4095] of PAnsiChar; // 16KB/32KB hashing code 190 | 191 | function SynLZdecompressdestlen(in_p: PAnsiChar): integer; 192 | begin // get uncompressed size from lz-compressed buffer (to reserve memory, e.g.) 193 | result := PWord(in_p)^; 194 | if result and $8000<>0 then 195 | result := (result and $7fff) or (integer(PWord(in_p+2)^) shl 15); 196 | end; 197 | 198 | {$ifdef CPUINTEL} 199 | // using direct x86 jmp also circumvents Internal Error C11715 for Delphi 5 200 | {$ifdef CPUX86} 201 | function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 202 | {$ifdef FPC} nostackframe; assembler; {$endif} 203 | asm 204 | push ebp 205 | push ebx 206 | push esi 207 | push edi 208 | push eax 209 | add esp, -4092 210 | push eax 211 | add esp, -4092 212 | push eax 213 | add esp, -4092 214 | push eax 215 | add esp, -4092 216 | push eax 217 | add esp, -4092 218 | push eax 219 | add esp, -4092 220 | push eax 221 | add esp, -4092 222 | push eax 223 | add esp, -4092 224 | push eax 225 | add esp, -32 226 | mov esi, eax // esi=src 227 | mov edi, ecx // edi=dst 228 | mov [esp+08H], ecx 229 | mov eax, edx 230 | cmp eax, 32768 231 | jl @@0889 232 | or ax, 8000H 233 | mov [edi], eax 234 | mov eax, edx 235 | shr eax, 15 236 | mov [edi+2], eax 237 | add edi, 4 238 | jmp @@0891 239 | @@0890: mov eax, 2 240 | jmp @@0904 241 | @@0889: mov [edi], eax 242 | test eax, eax 243 | jz @@0890 244 | add edi, 2 245 | @@0891: lea eax, [edx+esi] 246 | mov [esp+18H], edi 247 | mov [esp+0CH], eax 248 | sub eax, 11 249 | mov [esp+4], eax 250 | lea ebx, [esp+24H] 251 | xor eax, eax 252 | mov ecx, 1024 253 | @@089I: mov [ebx], eax // faster than FillChar / stosb 254 | mov [ebx+4], eax 255 | mov [ebx+8], eax 256 | mov [ebx+12], eax 257 | add ebx, 16 258 | dec ecx 259 | jnz @@089I 260 | mov [edi], eax 261 | add edi, 4 262 | mov ebx, 1 // ebx=1 shl CWbit 263 | // main loop: 264 | cmp esi, [esp+4] 265 | ja @@0900 266 | @@0892: mov edx, [esi] 267 | mov eax, edx 268 | shr edx, 12 269 | xor edx, eax 270 | and edx, 0FFFH 271 | mov ebp, [esp+edx*4+24H] 272 | mov ecx, [esp+edx*4+4024H] 273 | mov [esp+edx*4+24H], esi 274 | xor ecx, eax 275 | test ecx, 0FFFFFFH 276 | mov [esp+edx*4+4024H], eax 277 | jnz @@0897 278 | mov eax, esi 279 | or ebp, ebp 280 | jz @@0897 281 | sub eax, ebp 282 | mov ecx, [esp+18H] 283 | cmp eax, 2 284 | jle @@0897 285 | lea esi, [esi+2] 286 | or dword ptr[ecx], ebx 287 | mov ecx, [esp+0CH] 288 | add ebp, 2 289 | mov eax, 1 290 | sub ecx, esi 291 | dec ecx 292 | mov [esp], ecx 293 | cmp ecx, 271 294 | jl @@0894 295 | mov dword ptr [esp], 271 296 | jmp @@0894 297 | @@0893: inc eax 298 | @@0894: mov ecx, [ebp+eax] 299 | cmp cl, [esi+eax] 300 | jnz @@0895 301 | cmp eax, [esp] 302 | jge @@0895 303 | inc eax 304 | cmp ch, [esi+eax] 305 | jnz @@0895 306 | shr ecx, 16 307 | cmp eax, [esp] 308 | jge @@0895 309 | inc eax 310 | cmp cl, [esi+eax] 311 | jnz @@0895 312 | cmp eax, [esp] 313 | jge @@0895 314 | inc eax 315 | cmp ch, [esi+eax] 316 | jnz @@0895 317 | cmp eax, [esp] 318 | jl @@0893 319 | @@0895: add esi, eax 320 | shl edx, 4 321 | cmp eax, 15 322 | jg @@0896 323 | or eax, edx 324 | mov word ptr [edi], ax 325 | add edi, 2 326 | jmp @@0898 327 | @@0896: sub eax, 16 328 | mov [edi], dx 329 | mov [edi+2H], al 330 | add edi, 3 331 | jmp @@0898 332 | @@0897: mov al, [esi] // movsb is actually slower! 333 | mov [edi], al 334 | inc esi 335 | inc edi 336 | @@0898: add ebx, ebx 337 | jz @@0899 338 | cmp esi, [esp+4] 339 | jbe @@0892 340 | jmp @@0900 341 | @@0899: mov [esp+18H], edi 342 | mov [edi], ebx 343 | inc ebx 344 | add edi, 4 345 | cmp esi, [esp+4] 346 | jbe @@0892 347 | @@0900: cmp esi, [esp+0CH] 348 | jnc @@0903 349 | @@0901: mov al, [esi] 350 | mov [edi], al 351 | inc esi 352 | inc edi 353 | add ebx, ebx 354 | jz @@0902 355 | cmp esi, [esp+0CH] 356 | jc @@0901 357 | jmp @@0903 358 | @@0902: mov [edi], ebx 359 | inc ebx 360 | add edi, 4 361 | cmp esi, [esp+0CH] 362 | jc @@0901 363 | @@0903: mov eax, edi 364 | sub eax, [esp+08H] 365 | @@0904: add esp, 32804 366 | pop edi 367 | pop esi 368 | pop ebx 369 | pop ebp 370 | {$else CPUX86} 371 | function SynLZcompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 372 | var off: TOffsets; 373 | cache: array[0..4095] of cardinal; // uses 32KB+16KB=48KB on stack 374 | asm // rcx=src, edx=size, r8=dest 375 | {$ifdef win64} // additional registers to preserve 376 | push rdi 377 | push rsi 378 | {$else} // Linux 64-bit ABI 379 | mov r8, rdx 380 | mov rdx, rsi 381 | mov rcx, rdi 382 | {$endif win64} 383 | push rbx 384 | push r12 385 | push r13 386 | push r14 387 | push r15 388 | mov r15, r8 // r8=dest r15=dst_beg 389 | mov rbx, rcx // rbx=src 390 | cmp edx, 32768 391 | jc @03 392 | mov eax, edx 393 | and eax, 7FFFH 394 | or eax, 8000H 395 | mov word ptr [r8], ax 396 | mov eax, edx 397 | shr eax, 15 398 | mov word ptr [r8+2H], ax 399 | add r8, 4 400 | jmp @05 401 | @03: mov word ptr [r8], dx 402 | test edx, edx 403 | jnz @04 404 | mov r15d, 2 405 | jmp @19 406 | nop 407 | @04: add r8, 2 408 | @05: lea r9, [rdx+rbx] // r9=src_end 409 | lea r10, [r9-0BH] // r10=src_endmatch 410 | mov ecx, 1 // ecx=CWBits 411 | mov r11, r8 // r11=CWpoint 412 | mov dword ptr [r8], 0 413 | add r8, 4 414 | pxor xmm0, xmm0 415 | mov eax, 32768-64 416 | @06: movaps dqword ptr [off+rax-48], xmm0 // stack is aligned to 16 bytes 417 | movaps dqword ptr [off+rax-32], xmm0 418 | movaps dqword ptr [off+rax-16], xmm0 419 | movaps dqword ptr [off+rax], xmm0 420 | sub eax, 64 421 | jae @06 422 | cmp rbx, r10 423 | ja @15 424 | @07: mov edx, dword ptr [rbx] 425 | mov rax, rdx 426 | mov r12, rdx 427 | shr rax, 12 428 | xor rax, rdx 429 | and rax, 0FFFH // rax=h 430 | mov r14, qword ptr [off+rax*8] // r14=o 431 | mov edx, dword ptr [cache+rax*4] 432 | mov qword ptr [off+rax*8], rbx 433 | mov dword ptr [cache+rax*4], r12d 434 | xor rdx, r12 435 | test r14, r14 436 | lea rdi, [r9-1] 437 | je @12 438 | and rdx, 0FFFFFFH 439 | jne @12 440 | mov rdx, rbx 441 | sub rdx, r14 442 | cmp rdx, 2 443 | jbe @12 444 | or dword ptr[r11], ecx 445 | add rbx, 2 446 | add r14, 2 447 | mov esi, 1 448 | sub rdi, rbx 449 | cmp rdi, 271 450 | jc @09 451 | mov edi, 271 452 | jmp @09 453 | @08: inc rsi 454 | @09: mov edx, dword ptr [r14+rsi] 455 | cmp dl, byte ptr [rbx+rsi] 456 | jnz @10 457 | cmp rsi, rdi 458 | jge @10 459 | inc rsi 460 | cmp dh, byte ptr [rbx+rsi] 461 | jnz @10 462 | shr edx, 16 463 | cmp rsi, rdi 464 | jge @10 465 | inc rsi 466 | cmp dl, byte ptr [rbx+rsi] 467 | jnz @10 468 | cmp rsi, rdi 469 | jge @10 470 | inc rsi 471 | cmp dh, byte ptr [rbx+rsi] 472 | jnz @10 473 | cmp rsi, rdi 474 | jc @08 475 | @10: add rbx, rsi 476 | shl rax, 4 477 | cmp rsi, 15 478 | ja @11 479 | or rax, rsi 480 | mov word ptr [r8], ax 481 | add r8, 2 482 | jmp @13 483 | @11: sub rsi, 16 484 | mov word ptr [r8], ax 485 | mov byte ptr [r8+2H], sil 486 | add r8, 3 487 | jmp @13 488 | @12: mov al, byte ptr [rbx] 489 | mov byte ptr [r8], al 490 | add rbx, 1 491 | add r8, 1 492 | @13: add ecx, ecx 493 | jnz @14 494 | mov r11, r8 495 | mov [r8], ecx 496 | add r8, 4 497 | add ecx, 1 498 | @14: cmp rbx, r10 499 | jbe @07 500 | @15: cmp rbx, r9 501 | jnc @18 502 | @16: mov al, byte ptr [rbx] 503 | mov byte ptr [r8], al 504 | add rbx, 1 505 | add r8, 1 506 | add ecx, ecx 507 | jnz @17 508 | mov [r8], ecx 509 | add r8, 4 510 | add ecx, 1 511 | @17: cmp rbx, r9 512 | jc @16 513 | @18: sub r8, r15 514 | mov r15, r8 515 | @19: mov rax, r15 516 | pop r15 517 | pop r14 518 | pop r13 519 | pop r12 520 | pop rbx 521 | {$ifdef win64} // additional registers to preserve 522 | pop rsi 523 | pop rdi 524 | {$endif win64} 525 | {$endif CPUX86} 526 | end; 527 | {$endif CPUINTEL} 528 | 529 | function SynLZcompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 530 | var dst_beg, // initial dst value 531 | src_end, // real last byte available in src 532 | src_endmatch, // last byte to try for hashing 533 | o: PAnsiChar; 534 | CWbit: byte; 535 | CWpoint: PCardinal; 536 | v, h, cached, t, tmax: PtrUInt; 537 | offset: TOffsets; 538 | cache: array[0..4095] of cardinal; // 16KB+16KB=32KB on stack (48KB under Win64) 539 | begin 540 | dst_beg := dst; 541 | // 1. store in_len 542 | if size>=$8000 then begin // size in 32KB..2GB -> stored as integer 543 | PWord(dst)^ := $8000 or (size and $7fff); 544 | PWord(dst+2)^ := size shr 15; 545 | inc(dst,4); 546 | end else begin 547 | PWord(dst)^ := size ; // size<32768 -> stored as word 548 | if size=0 then begin 549 | result := 2; 550 | exit; 551 | end; 552 | inc(dst,2); 553 | end; 554 | // 2. compress 555 | src_end := src+size; 556 | src_endmatch := src_end-(6+5); 557 | CWbit := 0; 558 | CWpoint := pointer(dst); 559 | PCardinal(dst)^ := 0; 560 | inc(dst,sizeof(CWpoint^)); 561 | fillchar(offset,sizeof(offset),0); // fast 16KB reset to 0 562 | // 1. main loop to search using hash[] 563 | if src<=src_endmatch then 564 | repeat 565 | v := PCardinal(src)^; 566 | h := ((v shr 12) xor v) and 4095; 567 | o := offset[h]; 568 | offset[h] := src; 569 | cached := v xor cache[h]; // o=nil if cache[h] is uninitialized 570 | cache[h] := v; 571 | if (cached and $00ffffff=0) and (o<>nil) and (src-o>2) then begin 572 | CWpoint^ := CWpoint^ or (cardinal(1) shl CWbit); 573 | inc(src,2); 574 | inc(o,2); 575 | t := 1; 576 | tmax := src_end-src-1; 577 | if tmax>=(255+16) then 578 | tmax := (255+16); 579 | while (o[t]=src[t]) and (t0 584 | if t<=15 then begin // mark 2 to 17 bytes -> size=1..15 585 | PWord(dst)^ := integer(t or h); 586 | inc(dst,2); 587 | end else begin // mark 18 to (255+16) bytes -> size=0, next byte=t 588 | dec(t,16); 589 | PWord(dst)^ := h; // size=0 590 | dst[2] := ansichar(t); 591 | inc(dst,3); 592 | end; 593 | end else begin 594 | dst^ := src^; 595 | inc(src); 596 | inc(dst); 597 | end; 598 | if CWbit<31 then begin 599 | inc(CWbit); 600 | if src<=src_endmatch then continue else break; 601 | end else begin 602 | CWpoint := pointer(dst); 603 | PCardinal(dst)^ := 0; 604 | inc(dst,sizeof(CWpoint^)); 605 | CWbit := 0; 606 | if src<=src_endmatch then continue else break; 607 | end; 608 | until false; 609 | // 2. store remaining bytes 610 | if src0 then begin 664 | result := (result and $7fff) or (integer(PWord(src)^) shl 15); 665 | inc(src,2); 666 | end; 667 | // 2. decompress 668 | last_hashed := dst-1; 669 | CWbit := 32; 670 | nextCW: 671 | CW := PCardinal(src)^; 672 | inc(src,4); 673 | CWbit := CWbit-32; 674 | if src=src_end then break; 685 | while last_hashed=src_end then break; 695 | if last_hashed=dst; 724 | inc(dst,t); 725 | if src>=src_end then break; 726 | last_hashed := dst-1; 727 | inc(CWbit); 728 | CW := CW shr 1; 729 | if CWbit<32 then 730 | continue else 731 | goto nextCW; 732 | end; 733 | until false; 734 | // assert(result=dst-dst_beg); 735 | end; 736 | 737 | {$ifdef CPUINTEL} 738 | {$ifdef CPUX86} 739 | // using direct x86 jmp also circumvents Internal Error C11715 for Delphi 5 740 | function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 741 | {$ifdef FPC} nostackframe; assembler; {$endif} 742 | asm 743 | push ebp 744 | push ebx 745 | push esi 746 | push edi 747 | push eax 748 | add esp, -4092 749 | push eax 750 | add esp, -4092 751 | push eax 752 | add esp, -4092 753 | push eax 754 | add esp, -4092 755 | push eax 756 | add esp, -24 757 | mov esi, ecx 758 | mov ebx, eax 759 | add edx, eax 760 | mov [esp+8H], esi 761 | mov [esp+10H], edx 762 | movzx eax, word ptr [ebx] 763 | mov [esp], eax 764 | or eax,eax 765 | je @@0917 766 | add ebx, 2 767 | mov eax, [esp] 768 | test ah, 80H 769 | jz @@0907 770 | and eax, 7FFFH 771 | movzx edx, word ptr [ebx] 772 | shl edx, 15 773 | or eax, edx 774 | mov [esp], eax 775 | add ebx, 2 776 | @@0907: lea ebp, [esi-1] 777 | @@0908: mov ecx, [ebx] 778 | add ebx, 4 779 | mov [esp+14H], ecx 780 | mov edi, 1 // edi=CWbit 781 | cmp ebx, [esp+10H] 782 | jnc @@0917 783 | @@0909: mov ecx, [esp+14H] 784 | @@090A: test ecx, edi 785 | jnz @@0911 786 | mov al, [ebx] 787 | inc ebx 788 | mov [esi], al 789 | inc esi 790 | cmp ebx, [esp+10H] 791 | lea eax, [esi-3] 792 | jnc @@0917 793 | cmp eax, ebp 794 | jbe @@0910 795 | inc ebp 796 | mov eax, [ebp] 797 | mov edx, eax 798 | shr eax, 12 799 | xor eax, edx 800 | and eax, 0FFFH 801 | mov [esp+eax*4+1CH], ebp 802 | @@0910: add edi, edi 803 | jnz @@090A 804 | jmp @@0908 805 | @@0911: movzx edx, word ptr [ebx] 806 | add ebx, 2 807 | mov eax, edx 808 | and edx, 0FH 809 | add edx, 2 810 | shr eax, 4 811 | cmp edx,2 812 | jnz @@0912 813 | movzx edx, byte ptr [ebx] 814 | inc ebx 815 | add edx, 18 816 | @@0912: mov eax, [esp+eax*4+1CH] 817 | mov ecx, esi 818 | mov [esp+18H], edx 819 | sub ecx, eax 820 | cmp ecx, edx 821 | jl @@0913 822 | cmp edx, 32 // inlined optimized move() 823 | ja @large 824 | sub edx, 8 825 | jg @9_32 826 | mov ecx, [eax] 827 | mov eax, [eax+4] // always copy 8 bytes for 0..8 828 | mov [esi], ecx // safe since src_endmatch := src_end-(6+5) 829 | mov [esi+4], eax 830 | jmp @movend 831 | @9_32: fild qword ptr[eax+edx] 832 | fild qword ptr[eax] 833 | cmp edx, 8 834 | jle @16 835 | fild qword ptr[eax+8] 836 | cmp edx, 16 837 | jle @24 838 | fild qword ptr[eax+16] 839 | fistp qword ptr[esi+16] 840 | @24: fistp qword ptr[esi+8] 841 | @16: fistp qword ptr[esi] 842 | fistp qword ptr[esi+edx] 843 | jmp @movend 844 | nop 845 | @large: push esi 846 | fild qword ptr[eax] 847 | lea eax, [eax+edx-8] 848 | lea edx, [esi+edx-8] 849 | fild qword ptr[eax] 850 | push edx 851 | neg edx 852 | and esi, -8 853 | lea edx, [edx+esi+8] 854 | pop esi 855 | @lrgnxt:fild qword ptr[eax+edx] 856 | fistp qword ptr[esi+edx] 857 | add edx, 8 858 | jl @lrgnxt 859 | fistp qword ptr[esi] 860 | pop esi 861 | fistp qword ptr[esi] 862 | @movend:cmp esi, ebp 863 | jbe @@0916 864 | @@0915: inc ebp 865 | mov edx, [ebp] 866 | mov eax, edx 867 | shr edx, 12 868 | xor eax, edx 869 | and eax, 0FFFH 870 | mov [esp+eax*4+1CH], ebp 871 | cmp esi, ebp 872 | ja @@0915 873 | @@0916: add esi, [esp+18H] 874 | cmp ebx, [esp+10H] 875 | jnc @@0917 876 | add edi, edi 877 | lea ebp, [esi-1] 878 | jz @@0908 879 | jmp @@0909 880 | @@0913: push ebx 881 | xor ecx, ecx 882 | @s: dec edx 883 | mov bl, [eax+ecx] 884 | mov [esi+ecx], bl 885 | lea ecx,[ecx+1] 886 | jnz @s 887 | pop ebx 888 | jmp @movend 889 | @@0917: mov eax, [esp] 890 | add esp, 16412 891 | pop edi 892 | pop esi 893 | pop ebx 894 | pop ebp 895 | {$else CPUX86} 896 | function SynLZdecompress1(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 897 | var off: TOffsets; 898 | asm // rcx=src, edx=size, r8=dest 899 | {$ifdef win64} // additional registers to preserve 900 | push rsi 901 | push rdi 902 | {$else} // Linux 64-bit ABI 903 | mov r8, rdx 904 | mov rdx, rsi 905 | mov rcx, rdi 906 | {$endif win64} 907 | push rbx 908 | push r12 909 | push r13 910 | push r14 911 | push r15 912 | movzx eax, word ptr [rcx] // rcx=src eax=result 913 | lea r9, [rcx+rdx] // r9=src_end 914 | test eax, eax 915 | je @35 916 | add rcx, 2 917 | mov r10d, eax 918 | and r10d, 8000H 919 | jz @21 920 | movzx ebx, word ptr [rcx] 921 | shl ebx, 15 922 | mov r10d, eax 923 | and r10d, 7FFFH 924 | or r10d, ebx 925 | mov eax, r10d 926 | add rcx, 2 927 | @21: lea r10, [r8-1H] // r10=last_hashed r8=dest 928 | @22: mov edi, dword ptr [rcx] // edi=CW 929 | add rcx, 4 930 | mov r13d, 1 // r13d=CWBit 931 | cmp rcx, r9 932 | jnc @35 933 | @23: test r13d, edi 934 | jnz @25 935 | mov bl, byte ptr [rcx] 936 | mov byte ptr [r8], bl 937 | add rcx, 1 938 | lea rbx, [r8-2H] 939 | add r8, 1 940 | cmp rcx, r9 941 | jnc @35 942 | cmp rbx, r10 943 | jbe @24 944 | add r10, 1 945 | mov esi, dword ptr [r10] 946 | mov rbx, rsi 947 | shr esi, 12 948 | xor ebx, esi 949 | and ebx, 0FFFH 950 | mov qword ptr [off+rbx*8], r10 951 | @24: shl r13d, 1 952 | jnz @23 953 | jmp @22 954 | @25: movzx r11, word ptr [rcx] // r11=t 955 | add rcx, 2 956 | mov ebx, r11d // ebx=h 957 | shr ebx, 4 958 | and r11, 0FH 959 | lea r11, [r11+2H] 960 | jnz @26 961 | movzx r11, byte ptr [rcx] 962 | add rcx, 1 963 | lea r11, [r11+12H] 964 | @26: mov r14, qword ptr [off+rbx*8] // r14=o 965 | mov rbx, r8 966 | xor rsi, rsi 967 | sub rbx, r14 968 | mov r12, r11 969 | mov r15, r11 970 | cmp rbx, r11 971 | jc @29 972 | shr r12, 3 973 | jz @30 974 | @27: mov rbx, qword ptr [r14+rsi] // inline move by 8 bytes 975 | mov qword ptr [r8+rsi], rbx 976 | add rsi, 8 977 | dec r12 978 | jnz @27 979 | mov rbx, qword ptr [r14+rsi] // 1..7 remaining bytes 980 | and r15, 7 981 | jz @31 982 | @28: mov byte ptr [r8+rsi], bl 983 | shr rbx, 8 984 | inc rsi 985 | dec r15 986 | jnz @28 987 | jmp @31 988 | @29: mov bl, byte ptr [r14+rsi] // overlaping move 989 | mov byte ptr [r8+rsi], bl 990 | inc rsi 991 | dec r12 992 | jnz @29 993 | cmp rcx, r9 994 | jnz @33 995 | jmp @35 996 | @30: mov rbx, qword ptr [r14] 997 | mov qword ptr [r8], rbx 998 | @31: cmp rcx, r9 999 | jz @35 1000 | cmp r10, r8 1001 | jnc @34 1002 | @32: add r10, 1 1003 | mov ebx, dword ptr [r10] 1004 | mov rsi, rbx 1005 | shr ebx, 12 1006 | xor esi, ebx 1007 | and esi, 0FFFH 1008 | mov qword ptr [off+rsi*8], r10 1009 | @33: cmp r10, r8 1010 | jc @32 1011 | @34: add r8, r11 1012 | lea r10, [r8-1H] 1013 | shl r13d, 1 1014 | jnz @23 1015 | jmp @22 1016 | @35: pop r15 1017 | pop r14 1018 | pop r13 1019 | pop r12 1020 | pop rbx 1021 | {$ifdef win64} // additional registers to preserve 1022 | pop rdi 1023 | pop rsi 1024 | {$endif win64} 1025 | {$endif CPUX86} 1026 | end; 1027 | {$endif CPUINTEL} 1028 | 1029 | // better code generation with sub-functions for raw decoding 1030 | procedure SynLZdecompress1passub(src, src_end, dst: PAnsiChar; var offset: TOffsets); 1031 | var last_hashed: PAnsiChar; // initial src and dst value 1032 | {$ifdef CPU64} 1033 | o: PAnsiChar; 1034 | {$endif} 1035 | CW, CWbit: cardinal; 1036 | v, t, h: PtrUInt; 1037 | label nextCW; 1038 | begin 1039 | last_hashed := dst-1; 1040 | nextCW: 1041 | CW := PCardinal(src)^; 1042 | inc(src,4); 1043 | CWbit := 1; 1044 | if src=src_end then break; 1051 | if last_hashed0 then 1058 | continue else 1059 | goto nextCW; 1060 | end else begin 1061 | h := PWord(src)^; 1062 | inc(src,2); 1063 | t := (h and 15)+2; 1064 | h := h shr 4; 1065 | if t=2 then begin 1066 | t := ord(src^)+(16+2); 1067 | inc(src); 1068 | end; 1069 | {$ifdef CPU64} 1070 | o := offset[h]; 1071 | if PtrUInt(dst-o)8 then // safe since src_endmatch := src_end-(6+5) 1080 | move(offset[h]^,dst^,t) else 1081 | PInt64(dst)^ := PInt64(offset[h])^; // much faster in practice 1082 | {$endif} 1083 | if src>=src_end then break; 1084 | if last_hashed=dst; 1090 | inc(dst,t); 1091 | last_hashed := dst-1; 1092 | CWbit := CWbit shl 1; 1093 | if CWbit<>0 then 1094 | continue else 1095 | goto nextCW; 1096 | end; 1097 | until false; 1098 | end; 1099 | 1100 | function SynLZdecompress1pas(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 1101 | var offset: TOffsets; 1102 | src_end: PAnsiChar; 1103 | begin 1104 | src_end := src+size; 1105 | result := PWord(src)^; 1106 | if result=0 then exit; 1107 | inc(src,2); 1108 | if result and $8000<>0 then begin 1109 | result := (result and $7fff) or (integer(PWord(src)^) shl 15); 1110 | inc(src,2); 1111 | end; 1112 | SynLZdecompress1passub(src, src_end, dst, offset); 1113 | end; 1114 | 1115 | procedure SynLZdecompress1partialsub(src, dst, src_end, dst_end: PAnsiChar; var offset: TOffsets); 1116 | var last_hashed: PAnsiChar; // initial src and dst value 1117 | CWbit, CW: integer; 1118 | v, t, h: PtrUInt; 1119 | {$ifdef CPU64} 1120 | o: PAnsiChar; 1121 | {$endif} 1122 | label nextCW; 1123 | begin 1124 | last_hashed := dst-1; 1125 | nextCW: 1126 | CW := PCardinal(src)^; 1127 | inc(src,4); 1128 | CWbit := 1; 1129 | if src=src_end) or (dst>=dst_end) then 1136 | break; 1137 | if last_hashed0 then 1144 | continue else 1145 | goto nextCW; 1146 | end else begin 1147 | h := PWord(src)^; 1148 | inc(src,2); 1149 | t := (h and 15)+2; 1150 | h := h shr 4; 1151 | if t=2 then begin 1152 | t := ord(src^)+(16+2); 1153 | inc(src); 1154 | end; 1155 | if dst+t>=dst_end then begin // avoid buffer overflow by all means 1156 | movechars(offset[h],dst,dst_end-dst); 1157 | break; 1158 | end; 1159 | {$ifdef CPU64} 1160 | o := offset[h]; 1161 | if (t<=8) or (PtrUInt(dst-o)=src_end then 1170 | break; 1171 | if last_hashed=dst; 1177 | inc(dst,t); 1178 | last_hashed := dst-1; 1179 | CWbit := CWbit shl 1; 1180 | if CWbit<>0 then 1181 | continue else 1182 | goto nextCW; 1183 | end; 1184 | until false; 1185 | end; 1186 | 1187 | function SynLZdecompress1partial(src: PAnsiChar; size: integer; dst: PAnsiChar; maxDst: integer): integer; 1188 | var offset: TOffsets; 1189 | src_end: PAnsiChar; 1190 | begin 1191 | src_end := src+size; 1192 | result := PWord(src)^; 1193 | if result=0 then exit; 1194 | inc(src,2); 1195 | if result and $8000<>0 then begin 1196 | result := (result and $7fff) or (integer(PWord(src)^) shl 15); 1197 | inc(src,2); 1198 | end; 1199 | if maxDst0 then 1202 | SynLZdecompress1partialsub(src, dst, src_end, dst+result, offset); 1203 | end; 1204 | 1205 | 1206 | function SynLZcompress2(src: PAnsiChar; size: integer; dst: PAnsiChar): integer; 1207 | var dst_beg, // initial dst value 1208 | src_end, // real last byte available in src 1209 | src_endmatch, // last byte to try for hashing 1210 | o: PAnsiChar; 1211 | CWbit: byte; 1212 | CWpoint: PCardinal; 1213 | h, v, cached: integer; 1214 | t, tmax, tdiff, i: integer; 1215 | offset: TOffsets; // 16KB+16KB=32KB hashing code 1216 | cache: array[0..4095] of integer; 1217 | label dotdiff; 1218 | begin 1219 | dst_beg := dst; 1220 | // 1. store in_len 1221 | if size>=$8000 then begin 1222 | PWord(dst)^ := $8000 or (size and $7fff); 1223 | PWord(dst+2)^ := size shr 15; 1224 | inc(dst,4); 1225 | end else begin 1226 | PWord(dst)^ := size ; // src<32768 -> stored as word, otherwise as integer 1227 | if size=0 then begin 1228 | result := 2; 1229 | exit; 1230 | end; 1231 | inc(dst,2); 1232 | end; 1233 | // 2. compress 1234 | src_end := src+size; 1235 | src_endmatch := src_end-(6+5); 1236 | CWbit := 0; 1237 | CWpoint := pointer(dst); 1238 | PCardinal(dst)^ := 0; 1239 | inc(dst,sizeof(CWpoint^)); 1240 | tdiff := 0; 1241 | fillchar(offset,sizeof(offset),0); // fast 16KB reset to 0 1242 | // 1. main loop to search using hash[] 1243 | if src<=src_endmatch then 1244 | repeat 1245 | v := PCardinal(src)^; 1246 | h := ((v shr 12) xor v) and 4095; 1247 | o := offset[h]; 1248 | offset[h] := src; 1249 | cached := v xor cache[h]; 1250 | cache[h] := v; 1251 | if (cached and $00ffffff=0) and (o<>nil) and (src-o>2) then begin 1252 | // SetBit(CWpoint,CWbit); 1253 | // asm movzx eax,byte ptr CWbit; bts [CWpoint],eax; end 1254 | if tdiff<>0 then begin 1255 | dec(src,tdiff); 1256 | dotdiff:v := tdiff; 1257 | if v<=8 then begin 1258 | if CWBit+v>31 then begin 1259 | for i := CWBit to 31 do begin 1260 | dst^ := src^; 1261 | inc(dst); 1262 | inc(src); 1263 | end; 1264 | CWpoint := pointer(dst); 1265 | PCardinal(dst)^ := 0; 1266 | inc(dst,4); 1267 | CWBit := (CWBit+v) and 31; 1268 | for i := 1 to CWBit do begin 1269 | dst^ := src^; 1270 | inc(dst); 1271 | inc(src); 1272 | end; 1273 | end else begin 1274 | inc(CWBit,v); 1275 | for i := 1 to v do begin 1276 | dst^ := src^; 1277 | inc(dst); 1278 | inc(src); 1279 | end; 1280 | end; 1281 | end else begin 1282 | CWpoint^ := CWpoint^ or (cardinal(1) shl CWbit); 1283 | dec(v,9); 1284 | if v>15 then begin 1285 | v := 15; // v=9..24 -> h=0..15 1286 | dst^ := #$ff; // size=15 -> tdiff 1287 | end else 1288 | dst^ := ansichar((v shl 4) or 15); // size=15 -> tdiff 1289 | inc(dst); 1290 | pInt64(dst)^ := pInt64(src)^; 1291 | inc(dst,8); 1292 | inc(src,8); 1293 | for i := 1 to v+1 do begin 1294 | dst^ := src^; 1295 | inc(dst); 1296 | inc(src); 1297 | end; 1298 | if CWBit<31 then 1299 | inc(CWBit) else begin 1300 | CWpoint := pointer(dst); 1301 | PCardinal(dst)^ := 0; 1302 | inc(dst,4); 1303 | CWbit := 0; 1304 | end; 1305 | dec(tdiff,24); 1306 | if tdiff>0 then 1307 | goto dotdiff; 1308 | end; 1309 | end; 1310 | // assert(PWord(o)^=PWord(src)^); 1311 | tdiff := 0; 1312 | CWpoint^ := CWpoint^ or (cardinal(1) shl CWbit); 1313 | inc(src,2); 1314 | inc(o,2); 1315 | t := 0; // t=matchlen-2 1316 | tmax := src_end-src; 1317 | if tmax>=(255+15) then 1318 | tmax := (255+15); 1319 | while (o[t]=src[t]) and (t0); 1324 | // here we have always t>0 1325 | if t<15 then begin // store t=1..14 -> size=t=1..14 1326 | PWord(dst)^ := integer(t or h); 1327 | inc(dst,2); 1328 | end else begin // store t=15..255+15 -> size=0, next byte=matchlen-15-2 1329 | dst[2] := ansichar(t-15); 1330 | PWord(dst)^ := h; // size=0 1331 | inc(dst,3); 1332 | end; 1333 | if CWbit<31 then begin 1334 | inc(CWbit); 1335 | if src<=src_endmatch then continue else break; 1336 | end else begin 1337 | CWpoint := pointer(dst); 1338 | PCardinal(dst)^ := 0; 1339 | inc(dst,4); 1340 | CWbit := 0; 1341 | if src<=src_endmatch then continue else break; 1342 | end; 1343 | end else begin 1344 | inc(src); 1345 | inc(tdiff); 1346 | if src<=src_endmatch then continue else break; 1347 | end; 1348 | until false; 1349 | // 2. store remaining bytes 1350 | dec(src,tdiff); // force store trailing bytes 1351 | if src0 then begin 1391 | result := (result and $7fff) or (integer(PWord(src)^) shl 15); 1392 | inc(src,2); 1393 | end; 1394 | // 2. decompress 1395 | last_hashed := dst-1; 1396 | nextCW: 1397 | CW := PCardinal(src)^; 1398 | inc(src,4); 1399 | CWbit := 1; 1400 | if src=src_end then break; 1407 | if last_hashed0 then 1414 | continue else 1415 | goto nextCW; 1416 | end else begin 1417 | case ord(src^) and 15 of // get size 1418 | 0: begin // size=0 -> next byte=matchlen-15-2 1419 | h := PWord(src)^ shr 4; 1420 | t := ord(src[2])+(15+2); 1421 | inc(src,3); 1422 | if dst-offset[h] tdiff 1428 | inc(src); 1429 | dst^ := src^; 1430 | inc(dst); 1431 | end; 1432 | inc(src); 1433 | if src>=src_end then break; 1434 | while last_hashed0 then 1441 | continue else 1442 | goto nextCW; 1443 | end; 1444 | else begin // size=1..14=matchlen-2 1445 | h := PWord(src)^; 1446 | inc(src,2); 1447 | t := (h and 15)+2; 1448 | h := h shr 4; 1449 | if dst-offset[h]=dst; 1460 | inc(dst,t); 1461 | if src>=src_end then break; 1462 | last_hashed := dst-1; 1463 | CWbit := CWbit shl 1; 1464 | if CWbit<>0 then 1465 | continue else 1466 | goto nextCW; 1467 | end; 1468 | until false; 1469 | {$ifopt C+} 1470 | assert(result=dst-dst_beg); 1471 | {$endif} 1472 | end; 1473 | 1474 | end. 1475 | -------------------------------------------------------------------------------- /Synopse.inc: -------------------------------------------------------------------------------- 1 | { 2 | This file is part of Synopse framework. 3 | 4 | Synopse framework. Copyright (c) Arnaud Bouchez 5 | Synopse Informatique - https://synopse.info 6 | 7 | *** BEGIN LICENSE BLOCK ***** 8 | Version: MPL 1.1/GPL 2.0/LGPL 2.1 9 | 10 | The contents of this file are subject to the Mozilla Public License Version 11 | 1.1 (the "License"); you may not use this file except in compliance with 12 | the License. You may obtain a copy of the License at 13 | http://www.mozilla.org/MPL 14 | 15 | Software distributed under the License is distributed on an "AS IS" basis, 16 | WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License 17 | for the specific language governing rights and limitations under the License. 18 | 19 | The Original Code is Synopse framework. 20 | 21 | The Initial Developer of the Original Code is Arnaud Bouchez. 22 | 23 | Portions created by the Initial Developer are Copyright (c) 24 | the Initial Developer. All Rights Reserved. 25 | 26 | Contributor(s): 27 | Alfred Glaenzer (alf) 28 | 29 | Alternatively, the contents of this file may be used under the terms of 30 | either the GNU General Public License Version 2 or later (the "GPL"), or 31 | the GNU Lesser General Public License Version 2.1 or later (the "LGPL"), 32 | in which case the provisions of the GPL or the LGPL are applicable instead 33 | of those above. If you wish to allow use of your version of this file only 34 | under the terms of either the GPL or the LGPL, and not to allow others to 35 | use your version of this file under the terms of the MPL, indicate your 36 | decision by deleting the provisions above and replace them with the notice 37 | and other provisions required by the GPL or the LGPL. If you do not delete 38 | the provisions above, a recipient may use your version of this file under 39 | the terms of any one of the MPL, the GPL or the LGPL. 40 | 41 | ***** END LICENSE BLOCK ***** 42 | } 43 | 44 | 45 | (********************** User-Trigerred Conditionals **********************) 46 | 47 | { Those conditionals below can be enabled in your project Options, 48 | to tune the compilation depending your setup or your project expectations. } 49 | 50 | {.$define PUREPASCAL} 51 | // define this if your compiler doesn't support Delphi's x86 asm 52 | // - is set automaticaly in case of a 64 bits compiler (only FPC exists now) 53 | 54 | {$define USENORMTOUPPER} 55 | // if defined, text functions will use the NormToUpper[] array, as defined 56 | // in our custom SysUtils.pas (not the LVCL version) -> when using LVCL, 57 | // define the global LVCL compiler directive, and this unit will initialize 58 | // its own NormToUpper[] array 59 | // -> define ENHANCEDRTL conditional below if our Enhanced RTL IS installed 60 | // -> in practice, this conditional is ALWAYS DEFINED, since needed by SQLite3 61 | 62 | {.$define ENHANCEDRTL} 63 | // define this if you DID install our Enhanced Runtime library or the LVCL: 64 | // - it's better to define this conditional globaly in the Project/Options window 65 | // - we need to hack the "legacy" LoadResString() procedure and add a 66 | // LoadResStringTranslate() function, for on the fly resourcestring i18n 67 | // - it will also define the TwoDigitLookup[] array and some very fast x86 asm 68 | // IntToStr() and other functions, available in our Enhanced Runtime library 69 | // (and our LVCL library) 70 | // - it will be unset automaticaly (see below) for Delphi 2009 and up 71 | // - this conditional must be defined in both SQLite3Commons and SQLite3i18n units, 72 | // or (even better) globally in the Project options 73 | 74 | {.$define USEPACKAGES} 75 | // define this if you compile the unit within a Delphi package 76 | // - it will avoid error like "[DCC Error] E2201 Need imported data reference ($G) 77 | // to access 'VarCopyProc' from unit 'SynCommons'" 78 | // - shall be set at the package options level, and left untouched by default 79 | // - note: you should probably also set "Generate DCUs only" in Project Options 80 | // -> Delphi Compiler -> Output C/C++ -> C/C++ output file generation 81 | 82 | {.$define DOPATCHTRTL} 83 | // if defined, some low-level patches are applied to Delphi or FPC RTL 84 | // - you should better use it, but we have unset it by default 85 | 86 | {.$define NEWRTTINOTUSED} 87 | // if defined, the new RTTI (available since Delphi 2010) won't be linked to 88 | // the executable: resulting file size will be much smaller, and mORMot won't 89 | // be affected (unless you use the enhanced RTTI for record/dynamic array JSON 90 | // serialization) - left undefined by default to ensure minimal impact 91 | 92 | {.$define NOSETTHREADNAME} 93 | // if defined, SetThreadName() would not raise the exception used to set the 94 | // thread name: to be defined if you have issues when debugging your application 95 | 96 | {.$define NOEXCEPTIONINTERCEPT} 97 | // if defined, exceptions shall not be intercepted and logged 98 | 99 | {.$define USELOCKERDEBUG} 100 | // by default, some IAutoLocker instances would use TAutoLocker, unless this 101 | // conditional is defined to use more verbose TAutoLockerDebug 102 | // (may be used for race condition debugging, in multi-threaded apps) 103 | 104 | {.$define OLDTEXTWRITERFORMAT} 105 | // force TTextWriter.Add(Format) to handle the alternate deprecated $ % tags 106 | 107 | {.$define FORCE_STRSSE42} 108 | // sse4.2 string instructions may read up to 16 bytes after the actual end buffer 109 | // -> define this if you want StrLen/StrComp/strspn/strcspn to use SSE4.2 opcodes 110 | // but you would eventually experiment weird random GPF in your project, raising 111 | // unexpected SIGABRT/SIGSEGV under POSIX system: so is disabled below for our 112 | // LINUX conditional - and use at your own risk under Windows! 113 | 114 | {.$define DISABLE_SSE42} 115 | // if defined, no SSE4.2 nor AES-NI instruction will be used, i.e. disable 116 | // FORCE_STRSSE42 and all crc32c opcodes - is set for FPC DARWIN target 117 | 118 | {.$define WITH_ERMS} 119 | // you may define this to enable REP MOVSB/STOSB for Fillchar/Move if cfERMS 120 | // flag is available in Intel's CpuFeatures 121 | // -> disabled by default, since in practice it is (much) slower for small blocks 122 | 123 | {.$define NOXPOWEREDNAME} 124 | // define this to avoid sending "X-Powered-By: Synopse mORMot" HTTP header 125 | 126 | {.$define SQLVIRTUALLOGS} 127 | // enable low-level logging of SQlite3 virtual table query planner costs 128 | // -> to be defined only for internal debugging 129 | 130 | {.$define NOSYNDBZEOS} 131 | // made SynDBZeos.pas a "void" unit - defined for FPC/Lazarus packages only 132 | 133 | {.$define DDDNOSYNDB} 134 | // SynDB / external SQL DB won't be linked to the executable by dddInfraSettings 135 | {.$define DDDNOMONGODB} 136 | // Mongo DB client won't be linked to the executable by dddInfraSettings 137 | 138 | 139 | {$ifdef FPC} 140 | 141 | (********************** FPC Conditionals **********************) 142 | 143 | { Free Pascal adaptation notes: 144 | - we use the Delphi compatibility mode 145 | - from system.pp use these constants (Win32/64 values listed): 146 | LineEnding = #13#10; 147 | DirectorySeparator = '\'; 148 | - for Cross-Platform and all CPU: 149 | integer is NOT CPU-dependent (thanks to objpas), i.e. always 32 bits 150 | cardinal is NOT CPU-dependent (thanks to objpas), i.e. always 32 bits 151 | PtrUInt is an unsigned integer type of same size as a pointer / register 152 | -> must be used for pointer arithmetic 153 | -> may be used in loops 154 | PtrInt is a signed integer type of same size as a pointer / register 155 | -> must be used for pointer arithmetic 156 | -> may be used in loops 157 | all 32 bits x86 asm code is replaced by a pascal only version, if the 158 | conditional PUREPASCAL is defined (e.g. for CPUX64) 159 | } 160 | 161 | {$ifndef FPC_DELPHI} 162 | {$MODE DELPHI} // e.g. for asm syntax - disabled for FPC 2.6 compatibility 163 | {$endif} 164 | 165 | {$INLINE ON} 166 | {$MINENUMSIZE 1} 167 | {$PACKRECORDS DEFAULT} // force normal alignment 168 | {$PACKSET 1} 169 | {$PACKENUM 1} 170 | {$CODEPAGE UTF8} // otherwise unexpected behavior occurs in most cases 171 | 172 | {$undef ENHANCEDRTL} // there is no version of our Enhanced RTL for FPC 173 | {$define HASINLINE} 174 | {$define HASUINT64} 175 | {$define HASINLINENOTX86} 176 | {$define NODELPHIASM} // ignore low-level System.@LStrFromPCharLen calls 177 | {$define HASTTHREADSTART} 178 | {$define HASINTERFACEASTOBJECT} 179 | {$define EXTENDEDTOSHORT_USESTR} // FloatToText uses str() in FPC 180 | {$define DOUBLETOSHORT_USEGRISU} // fast double to text 181 | {$define DELPHI5ORFPC} 182 | {$define FPC_OR_PUREPASCAL} 183 | {$define FPC_OR_KYLIX} 184 | {$define FPC_OR_UNICODE} 185 | {$define USERECORDWITHMETHODS} 186 | {$define FPC_OR_DELPHIXE} 187 | {$define FPC_OR_DELPHIXE4} 188 | {$define FPC_ENUMHASINNER} 189 | {$define USE_VTYPE_STATIC} // in our inlined VarClear() 190 | 191 | // $if FPC_FULLVERSION>20700 breaks Delphi 6-7 and SynProject :( 192 | {$ifdef VER2_7} 193 | {$define ISFPC27} 194 | {$endif} 195 | {$ifdef VER3_0} 196 | {$define ISFPC27} 197 | {$define ISFPC30} 198 | {$define HASDIRECTTYPEINFO} 199 | // PTypeInfo would be stored with no pointer de-reference 200 | // => Delphi and newer FPC uses a pointer reference to ease exe linking 201 | {$endif} 202 | {$ifdef VER3_1} // trunk before 3.2 203 | {$define ISFPC27} 204 | {$define ISFPC30} 205 | {.$define HASDIRECTTYPEINFO} 206 | // define this for trunk revisions older than June 2016 - see 207 | // http://wiki.freepascal.org/User_Changes_Trunk#RTTI_Binary_format_change 208 | {$endif} 209 | {$ifdef VER3_1_1} // if FPC_FULLVERSION>30100 ... ifend is not Delphi 5 compatible :( 210 | {$define ISFPC32} 211 | {$endif} 212 | {$ifdef VER3_2} 213 | {$define ISFPC27} 214 | {$define ISFPC30} 215 | {$define ISFPC32} 216 | {$ifdef VER3_2_2} 217 | {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet 218 | {$endif VER3_2_2} 219 | {$endif} 220 | {$ifdef VER3_3} // trunk before 3.4 221 | {$define ISFPC27} 222 | {$define ISFPC30} 223 | {$define ISFPC32} 224 | {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet 225 | {$endif} 226 | {$ifdef VER3_4} 227 | {$define ISFPC27} 228 | {$define ISFPC30} 229 | {$define ISFPC32} 230 | {$define ISFPC34} 231 | {$define FPC_PROVIDE_ATTR_TABLE} // introducing TTypeData.AttributeTable 232 | {$define STRCNT32} // 32-bit TAnsiRec.RefCnt even on 64-bit CPU 233 | {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet 234 | {$endif} 235 | {$if not defined(VER3_0) and not defined(VER3_2) and not defined(VER2)} 236 | {.$define FPC_PROVIDE_ATTR_TABLE} // to be defined since SVN 42356-42411 237 | // on compilation error in SynFPCTypInfo, undefine the above conditional 238 | // see https://lists.freepascal.org/pipermail/fpc-announce/2019-July/000612.html 239 | {$define STRCNT32} // 32-bit TAnsiRec.RefCnt even on 64-bit CPU 240 | // see https://gitlab.com/freepascal.org/fpc/source/-/issues/38018 241 | {$ifend} 242 | 243 | {$ifdef ANDROID} 244 | {$define LINUX} // a Linux-based system 245 | {$endif} 246 | 247 | // define FPCSQLITE3STATIC to enable static-linked SQLite3 engine for FPC 248 | // -> expect *.o files download from https://synopse.info/files/sqlite3fpc.7z 249 | // -> could be disabled to force external .so/.dll linking 250 | {$ifdef MSWINDOWS} 251 | {$ifdef CPUX86} 252 | {$define FPCSQLITE3STATIC} // use static\i386-win32\sqlite3.o 253 | {$else} 254 | {$define FPCSQLITE3STATIC} // use static\x86_64-win64\sqlite3.o 255 | {$endif} 256 | {$endif} 257 | {$ifdef LINUX} 258 | {$ifdef CPUX86} 259 | {$define FPCSQLITE3STATIC} // use static/i386-linux\sqlite3.o 260 | {$endif} 261 | {$ifdef CPUX64} 262 | {$define FPCSQLITE3STATIC} // use static/x86_64-linux\sqlite3.o 263 | {$endif} 264 | {$ifdef CPUARM} 265 | {$define FPCSQLITE3STATIC} // use static/arm-linux\sqlite3.o 266 | {$endif} 267 | {$ifdef CPUAARCH64} 268 | {$define FPCSQLITE3STATIC} // use:static/aarch64-linux\sqlite3.o 269 | {$endif} 270 | {$endif} 271 | 272 | {$ifdef BSD} 273 | // LINUX conditional includes Darwin and BSD family like FreeBSD 274 | {$define LINUX} // not true, but a POSIX/BSD system - see LINUXNOTBSD 275 | {$undef FORCE_STRSSE42} // fails otherwise for sure 276 | {$define ABSOLUTEPASCAL} // NO asm nor redirection (until stabilized) 277 | {$ifdef DARWIN} 278 | {$define FPCSQLITE3STATIC} // we supply Darwin static libs 279 | {$ifdef CPUINTEL} 280 | {$define FPC_PIC} // may have not be defined by the compiler options 281 | {$endif} 282 | {$else} 283 | {$define BSDNOTDARWIN} // OSX has some non-standard API calls 284 | {$endif} 285 | {$ifdef FREEBSD} 286 | {$ifdef CPUX86} 287 | {$define FPCSQLITE3STATIC} // we supply i386 static libs 288 | {$endif CPUX86} 289 | {$ifdef CPUX64} 290 | {$define FPCSQLITE3STATIC} // we supply x64 static libs 291 | {$endif CPUX64} 292 | {$endif} 293 | {$ifdef OPENBSD} 294 | {$ifdef CPUX86} 295 | {$define FPCSQLITE3STATIC} // we supply i386 static libs 296 | {$endif CPUX86} 297 | {$ifdef CPUX64} 298 | {$define FPCSQLITE3STATIC} // we supply x64 static libs 299 | {$endif CPUX64} 300 | {$endif} 301 | {$else} 302 | {$ifdef LINUX} 303 | {$define LINUXNOTBSD} // e.g. to disable epoll API 304 | {$define FPCLINUXNOTBSD} 305 | {$endif} 306 | {$endif} 307 | 308 | {$ifdef LINUX} 309 | {$undef FORCE_STRSSE42} // avoid fatal SIGABRT/SIGSEGV on POSIX systems 310 | {$define FPCLINUX} 311 | {$ifdef CPUX64} 312 | {$define CPUX64LINUX} // e.g. for tuned server-side asm 313 | {$endif CPUX64} 314 | {$endif} 315 | {$ifdef FPC_PIC} 316 | {$define PUREPASCAL} // most asm code is not PIC-safe with global constants 317 | {$endif} 318 | 319 | {$ifdef MSWINDOWS} 320 | {$ifdef FPC_X64MM} 321 | {$ifndef FPC_X64MM_WIN} // SynFPCx64MM not yet fully validated on Windows 322 | {$undef FPC_X64MM} 323 | {$endif FPC_X64MM_WIN} 324 | {$endif FPC_X64MM} 325 | {$endif MSWINDOWS} 326 | 327 | {$ifdef CPU64} 328 | {$define FPC_64} 329 | {$define PUREPASCAL} // e.g. x64, AARCH64 330 | {$ifdef CPUX64} 331 | {$define CPUINTEL} 332 | {$define FPC_CPUINTEL} 333 | {$ifndef BSD} 334 | {$define CPUX64ASM} // Delphi XE4 or Darwin asm are buggy :( 335 | {$define ASMX64AVX} // only FPC supports AVX/AVX2/AVX512 336 | {$define HASAESNI} // SynCrypto rejected by Darwin asm 337 | {$endif BSD} 338 | {$define FPC_X64} // supports AVX/AVX2/AVX512 - which Delphi doesn't 339 | {$ASMMODE INTEL} // to share asm code with Delphi 340 | {$endif CPUX64} 341 | {$ifdef CPUAARCH64} 342 | {$define CPUARM3264} 343 | {$endif CPUAARCH64} 344 | {$else} 345 | {$define FPC_32} 346 | {$define STRCNT32} // 32-bit TAnsiRec.RefCnt on 32-bit CPU 347 | {$define DACNT32} // 32-bit dynarray refcnt on 32-bit CPU 348 | {$ifdef CPUARM} 349 | {$define PUREPASCAL} // ARM32 350 | {$define CPUARM3264} 351 | {$endif CPUARM} 352 | {$ifdef CPUX86} 353 | {$define CPUINTEL} 354 | {$define FPC_CPUINTEL} 355 | {$define FPC_X86} 356 | {$define TSYNEXTENDED80} // only 32-bit has a true x87 extended type 357 | {$ASMMODE INTEL} // as Delphi expects 358 | {$define HASAESNI} // should be commented to test project with valgrind 359 | {$ifndef FPC_PIC} 360 | {$define CPUX86NOTPIC} // use "absolute" instead of local register 361 | {$endif FPC_PIC} 362 | {$ifndef OPENBSD} 363 | {$define FPC_X86ASM} // if assembler knows popcnt/crc32c opcodes 364 | {$endif OPENBSD} 365 | {$endif CPUX86} 366 | {$endif CPU64} 367 | 368 | {$ifdef CPUARM3264} 369 | {$ifdef BSD} 370 | {$undef USE_VTYPE_STATIC} // circumvent bug in VarClear() on BSD + ARM 371 | {$endif BSD} 372 | {$endif CPUARM3264} 373 | 374 | {$ifdef ISFPC30} 375 | {$ifndef MSWINDOWS} 376 | // define FPCUSEVERSIONINFO to link low-level executable file information 377 | // units in SynCommons.pas 378 | // => disabled by default, to reduce the executable overhead 379 | {.$define FPCUSEVERSIONINFO} 380 | {$endif MSWINDOWS} 381 | {$endif ISFPC30} 382 | 383 | {$ifdef ISFPC32} 384 | // FPC has its own RTTI layout only since late 3.x 385 | {$define FPC_NEWRTTI} 386 | // when http://bugs.freepascal.org/view.php?id=26774 has been fixed 387 | {$ifdef CPUINTEL} 388 | {$define HASINTERFACERTTI} 389 | {$endif} 390 | {$ifdef CPUARM3264} 391 | {$define HASINTERFACERTTI} 392 | {$endif} 393 | {$endif} 394 | 395 | {$ifdef FPC_NEWRTTI} 396 | {$define ISDELPHI2010_OR_FPC_NEWRTTI} 397 | {$else} 398 | {$define DELPHI_OR_FPC_OLDRTTI} 399 | {$define FPC_OLDRTTI} 400 | {$endif} 401 | {$define ISDELPHI2010_OR_FPC} // eltype2 field 402 | 403 | {$ifdef FPC_HAS_CPSTRING} 404 | // see http://wiki.freepascal.org/FPC_Unicode_support 405 | {$define HASCODEPAGE} // UNICODE means {$mode delphiunicode} 406 | {$endif} 407 | {$ifdef ISFPC27} 408 | {$define ISFPC271} 409 | {$define HASVARUSTRING} 410 | {$define HASVARUSTRARG} 411 | // defined if the http://mantis.freepascal.org/view.php?id=26773 bug is fixed 412 | // you should use 2.7.1/trunk branch in revision 28995 from 2014-11-05T22:17:54 413 | // => this will change the TInvokeableVariantType.SetProperty() signature 414 | {$define FPC_VARIANTSETVAR} 415 | {$endif ISFPC27} 416 | {$ifdef FPC_PROVIDE_ATTR_TABLE} 417 | {$define HASALIGNTYPEDATA} // to ignore attributes RTTI table 418 | {$endif FPC_PROVIDE_ATTR_TABLE} 419 | {$ifdef FPC_REQUIRES_PROPER_ALIGNMENT} 420 | {$define FPC_ENUMHASINNER} 421 | {$define HASALIGNTYPEDATA} // to ensure proper RTTI alignment 422 | {$endif FPC_REQUIRES_PROPER_ALIGNMENT} 423 | 424 | 425 | {$else FPC} 426 | 427 | (********************** Delphi Conditionals **********************) 428 | 429 | {$define DELPHI_OR_FPC_OLDRTTI} 430 | {$define USE_VTYPE_STATIC} // "and VTYPE_STATIC" test before VarClear() 431 | {$define STRCNT32} // always 32-bit TAnsiRec.RefCnt on Delphi 432 | {$define DACNT32} // always 32-bit dynarray refcnt on Delphi 433 | {$undef FPC_X64MM} // this is a FPC-specific memory manager 434 | 435 | {$A+} // force normal alignment 436 | 437 | {$ifdef LVCL} 438 | {$define OWNNORMTOUPPER} // NormToUpper[] exists only in our enhanced RTL 439 | {$define NOVARIANTS} // LVCL does not support variants 440 | {$define EXTENDEDTOSHORT_USESTR} // no FloatToText implemented in LVCL 441 | {$endif LVCL} 442 | 443 | {$ifdef UNICODE} 444 | {$undef ENHANCEDRTL} // Delphi 2009 and up don't have our Enhanced Runtime library 445 | {$define HASVARUSTRING} 446 | {$define HASCODEPAGE} 447 | {$define FPC_OR_UNICODE} 448 | {$define USERECORDWITHMETHODS} 449 | { due to a bug in Delphi 2009+, we need to fake inheritance of record, 450 | since TDynArrayHashed = object(TDynArray) fails to initialize 451 | http://blog.synopse.info/post/2011/01/29/record-and-object-issue-in-Delphi-2010 } 452 | {$define UNDIRECTDYNARRAY} 453 | {$endif UNICODE} 454 | 455 | {$ifndef PUREPASCAL} 456 | {$define CPUINTEL} // Delphi only for Intel by now 457 | {$endif} 458 | {$ifdef CPUX64} 459 | {$define CPU64} // Delphi compiler for 64 bit CPU 460 | {$define CPU64DELPHI} 461 | {$undef CPU32} 462 | {$define PUREPASCAL} // no x86 32 bit asm to be used 463 | {$define EXTENDEDTOSHORT_USESTR} // FloatToText() much slower in x64 mode 464 | {$define DOUBLETOSHORT_USEGRISU} // fast double to text 465 | {$else CPUX64} 466 | {$define CPU32} // Delphi compiler for 32 bit CPU 467 | {$define CPU32DELPHI} 468 | {$undef CPU64} 469 | {$define CPUX86} // for compatibility with older versions of Delphi 470 | {$define CPUX86NOTPIC} // use "absolute" instead of local register 471 | {$define TSYNEXTENDED80} // only 32-bit has a true x87 extended type 472 | {$endif CPUX64} 473 | 474 | {$IFDEF CONDITIONALEXPRESSIONS} // Delphi 6 or newer 475 | {$define HASINTERFACERTTI} // interface RTTI (not FPC) 476 | {$ifdef LINUX} 477 | {$if RTLVersion = 14.5} 478 | {$define KYLIX3} 479 | {$define FPC_OR_KYLIX} 480 | // Kylix 3 will be handled just like Delphi 7 481 | {$undef ENHANCEDRTL} // Enhanced Runtime library not fully tested yet 482 | {$define EXTENDEDTOSHORT_USESTR} 483 | {$define DOPATCHTRTL} // nice speed up for server apps 484 | {$define NOVARCOPYPROC} 485 | {$define NOSQLITE3STATIC} // Kylix will use external sqlite3.so 486 | {$define LINUXNOTBSD} // e.g. to disable epoll API 487 | {$else} 488 | Kylix1/2 or Delphi Tokyo/ARC are unsupported 489 | {$ifend} 490 | {$else} 491 | {$ifdef VER140} 492 | {$define ISDELPHI6ANDUP} // Delphi 6 or newer 493 | {$define DELPHI6OROLDER} 494 | {$define NOVARCOPYPROC} 495 | {$undef ENHANCEDRTL} // Delphi 6 doesn't have our Enhanced Runtime library 496 | {$define EXTENDEDTOSHORT_USESTR} // no TFormatSettings before Delphi 7 497 | {$else} 498 | {$define ISDELPHI7ANDUP} // Delphi 7 or newer 499 | {$define WITHUXTHEME} // VCL handle UI theming 500 | {$define HASUINT64} 501 | {$warn UNSAFE_CODE OFF} // Delphi for .Net does not exist any more! 502 | {$warn UNSAFE_TYPE OFF} 503 | {$warn UNSAFE_CAST OFF} 504 | {$warn DUPLICATE_CTOR_DTOR OFF} // avoid W1029 unneeded hints 505 | {$endif} 506 | {$ifdef USEPACKAGES} 507 | {$undef DOPATCHTRTL} 508 | {$endif} 509 | {$endif LINUX} 510 | {$if CompilerVersion >= 17} 511 | {$define ISDELPHI2005ANDUP} // Delphi 2005 or newer 512 | {$if CompilerVersion >= 18} 513 | {$define ISDELPHI2006ANDUP} // Delphi 2006 or newer 514 | {$define HASNEWFILEAGE} 515 | {$define HASINLINE} 516 | {$define HASINLINEDELPHI} 517 | {$define HASINLINENOTX86} 518 | {$define HASREGION} 519 | {$define HASFASTMM4} 520 | // try to define this so that GetMemoryInfo/TSynMonitorMemory returns 521 | // low-level FastMM4 information 522 | {.$define WITH_FASTMM4STATS} 523 | {$ifend} 524 | {$ifdef VER180} 525 | {$define ISDELPHI20062007} // to circumvent some specific bugs 526 | {$endif} 527 | {$ifdef VER185} 528 | {$define ISDELPHI20062007} 529 | {$endif} 530 | {$if CompilerVersion > 18} 531 | {$define ISDELPHI2007ANDUP} // Delphi 2007 or newer 532 | {$ifend} 533 | {$if CompilerVersion = 20} 534 | {$define ISDELPHI20092010} // specific compilation issues 535 | {$ifend} 536 | {$if CompilerVersion = 21} 537 | {$define ISDELPHI20092010} //specific compilation issues 538 | {$ifend} 539 | {$if CompilerVersion >= 21.0} 540 | {$define ISDELPHI2010} 541 | {$define ISDELPHI2010_OR_FPC} // eltype2 field 542 | {$define ISDELPHI2010_OR_FPC_NEWRTTI} 543 | {$define HASTTHREADSTART} 544 | {$define HASINTERFACEASTOBJECT} 545 | {$ifdef NEWRTTINOTUSED} // option reduce EXE size by disabling much RTTI 546 | {$WEAKLINKRTTI ON} 547 | {$RTTI EXPLICIT METHODS([]) PROPERTIES([]) FIELDS([])} 548 | {$endif NEWRTTINOTUSED} 549 | {$ifend} 550 | {$if CompilerVersion >= 22.0} 551 | {$define FPC_OR_DELPHIXE} // Delphi 2007/2009/2010 inlining bugs 552 | {$define ISDELPHIXE} 553 | {$ifend} 554 | {$if CompilerVersion >= 23.0} 555 | // Delphi XE2 has some cross-platform features 556 | // e.g. {$ifdef ISDELPHIXE2}VCL.Graphics{$else}Graphics{$endif} 557 | {$define ISDELPHIXE2} 558 | {$define HASVARUSTRARG} 559 | {$define HASTTHREADTERMINATESET} // introduced TThread.TerminateSet 560 | {$ifend} 561 | {$if CompilerVersion >= 24.0} 562 | {$define ISDELPHIXE3} 563 | {$ifend} 564 | {$if CompilerVersion >= 25.0} 565 | {$define ISDELPHIXE4} 566 | {$define FPC_OR_DELPHIXE4} // circumvent Internal Error: C2130 on XE3 567 | {$define HASAESNI} 568 | {$ifend} 569 | {$if CompilerVersion >= 26.0} 570 | {$define ISDELPHIXE5} 571 | {$define PUBLISHRECORD} 572 | // if defined, will handle RTTI available only since Delphi XE5 for 573 | // record published properties 574 | {$ifend} 575 | {$if CompilerVersion >= 27.0} 576 | {$define ISDELPHIXE6} 577 | {$ifend} 578 | {$if CompilerVersion >= 28.0} 579 | {$define ISDELPHIXE7} 580 | {$ifdef CPU64} 581 | {$define CPUX64ASM} // e.g. Delphi XE4 SSE asm is buggy :( 582 | {$endif} 583 | {$ifend} 584 | {$if CompilerVersion >= 29.0} 585 | {$define ISDELPHIXE8} 586 | {$ifend} 587 | {$if CompilerVersion >= 30.0} 588 | {$define ISDELPHI10} 589 | {$ifend} 590 | {$if CompilerVersion >= 31.0} 591 | {$define ISDELPHI101} 592 | {$ifend} 593 | {$if CompilerVersion >= 32.0} 594 | {$define ISDELPHI102} 595 | {$ifdef CPUX64} 596 | {$ifdef VER320withoutAprilUpdate} 597 | // circumvent early Delphi 10.2 Tokyo Win64 compiler bug 598 | {$undef HASINLINE} 599 | {$define HASINLINENOTX86} 600 | {$endif} 601 | {$endif} 602 | {$ifend} 603 | {$if CompilerVersion >= 33.0} 604 | {$define ISDELPHI103} 605 | {$ifend} 606 | {$if CompilerVersion >= 34.0} 607 | {$define ISDELPHI104} 608 | {$ifend} 609 | {$if CompilerVersion >= 35.0} 610 | {$define ISDELPHI11} 611 | {$ifend} 612 | {$ifend CompilerVersion >= 17} 613 | {$ifopt O-} // if we don't expect fast code, don't optimize the framework 614 | {$undef ENHANCEDRTL} 615 | {$undef DOPATCHTRTL} 616 | {$endif} 617 | {$ELSE} 618 | // Delphi 5 or older 619 | {$define DELPHI6OROLDER} 620 | {$define DELPHI5OROLDER} 621 | {$define DELPHI5ORFPC} 622 | {$define MSWINDOWS} 623 | {$define NOVARIANTS} 624 | {$define NOVARCOPYPROC} 625 | {$undef ENHANCEDRTL} // Delphi 5 doesn't have our Enhanced Runtime library 626 | {$define EXTENDEDTOSHORT_USESTR} // no TFormatSettings before Delphi 7 627 | {$undef DOPATCHTRTL} 628 | {$ENDIF CONDITIONALEXPRESSIONS} 629 | 630 | {$endif FPC} 631 | 632 | 633 | (********************** Shared Conditionals **********************) 634 | 635 | {$ifdef PUREPASCAL} 636 | {$define NODELPHIASM} 637 | {$define FPC_OR_PUREPASCAL} 638 | {$else} 639 | {$endif PUREPASCAL} 640 | 641 | {$H+} // we use long strings 642 | {$R-} // disable Range checking in our code 643 | {$S-} // disable Stack checking in our code 644 | {$X+} // expect extended syntax 645 | {$W-} // disable stack frame generation 646 | {$Q-} // disable overflow checking in our code 647 | {$B-} // expect short circuit boolean 648 | {$V-} // disable Var-String Checking 649 | {$T-} // Typed @ operator 650 | {$Z1} // enumerators stored as byte by default 651 | 652 | {$ifndef FPC} 653 | {$P+} // Open string params 654 | {$ifdef VER150} 655 | {$WARN SYMBOL_DEPRECATED OFF} 656 | {$WARN UNSAFE_TYPE OFF} 657 | {$WARN UNSAFE_CODE OFF} 658 | {$WARN UNSAFE_CAST OFF} 659 | {$ENDIF} 660 | {$ifdef CONDITIONALEXPRESSIONS} // Delphi 6 or newer 661 | {$WARN SYMBOL_PLATFORM OFF} 662 | {$WARN UNIT_PLATFORM OFF} 663 | {$endif} 664 | {$endif FPC} 665 | 666 | {$ifdef CPUINTEL} 667 | {$ifdef CPUX86} // safest to reset x87 exceptions 668 | {$ifndef PUREPASCAL} 669 | {$ifndef DELPHI5OROLDER} 670 | {$define RESETFPUEXCEPTION} 671 | {$endif} 672 | {$endif} 673 | {$endif} 674 | {$ifdef DISABLE_SSE42} 675 | {$undef FORCE_STRSSE42} 676 | {$endif DISABLE_SSE42} 677 | {$else} 678 | {$undef HASAESNI} // AES-NI is an Intel-specific feature 679 | {$define ABSOLUTEPASCALORNOTINTEL} 680 | {$endif CPUINTEL} 681 | 682 | {$ifdef ABSOLUTEPASCAL} 683 | {$define ABSOLUTEORPUREPASCAL} 684 | {$define ABSOLUTEPASCALORNOTINTEL} 685 | {$define PUREPASCAL} 686 | {$endif ABSOLUTEPASCAL} 687 | {$ifdef PUREPASCAL} 688 | {$define ABSOLUTEORPUREPASCAL} 689 | {$endif PUREPASCAL} 690 | 691 | {$define WITHLOG} 692 | // if defined, logging will be supported via the TSQLLog family 693 | // - should be left defined: TSQLog.Family.Level default setting won't log 694 | // anything, so there won't be any noticeable performance penalty to have 695 | // this WITHLOG conditional defined, which is expected by high-level part 696 | // of the framework, like DDD or UI units 697 | 698 | {$ifdef FPC} 699 | {$ifndef FPCSQLITE3STATIC} // see above about this FPC-specific conditional 700 | {$define NOSQLITE3STATIC} 701 | {$endif} 702 | {$else} 703 | // there is a linking bug with Delphi XE4 on Win64 704 | {$ifdef CPUX64} 705 | {$if CompilerVersion = 25.0} // exactly XE4 706 | {$define NOSQLITE3STATIC} 707 | // :( to avoid "Fatal: F2084 Internal Error: AV004A7B1F-R03BDA7B0-0" 708 | {$ifend} 709 | {$endif} // other Win32/Win64 Delphi platforms should work as expected 710 | {$endif FPC} 711 | 712 | {$ifdef NOSQLITE3STATIC} 713 | // our proprietary crypto expects a statically linked custom sqlite3.c 714 | {$define NOSQLITE3ENCRYPT} 715 | {$endif NOSQLITE3STATIC} 716 | 717 | {$ifdef MSWINDOWS} 718 | {$define USEWININET} // publish TWinINet/TWinHttp/TWinHttpAPI classes 719 | {.$define ONLYUSEHTTPSOCKET} // for testing (no benefit vs http.sys) 720 | {.$define USELIBCURL} // for testing (no benefit vs WinHTTP) 721 | {$else} 722 | {$define ONLYUSEHTTPSOCKET} // http.sys server is Windows-specific 723 | // cross-platform libcurl for https -> TCurlHttp and TSQLHttpClientCurl 724 | {$define USELIBCURL} 725 | {$ifdef ANDROID} 726 | // for Android, consider using https://github.com/gcesarmza/curl-android-ios 727 | // static libraries and force USELIBCURL in the project conditionals 728 | {$define LIBCURLSTATIC} 729 | {$endif ANDROID} 730 | {$endif MSWINDOWS} 731 | 732 | {$ifdef USELIBCURL} 733 | {.$define LIBCURLMULTI} 734 | // enable https://curl.haxx.se/libcurl/c/libcurl-multi.html interface 735 | {$endif USELIBCURL} 736 | 737 | -------------------------------------------------------------------------------- /SynopseCommit.inc: -------------------------------------------------------------------------------- 1 | '1.18.7650' 2 | -------------------------------------------------------------------------------- /crc32c64.obj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/synopse/SynPDF/97c032be44239f026914e437d2ff7a033bd70e85/crc32c64.obj -------------------------------------------------------------------------------- /deflate.obj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/synopse/SynPDF/97c032be44239f026914e437d2ff7a033bd70e85/deflate.obj -------------------------------------------------------------------------------- /mORMotReport.pas: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/synopse/SynPDF/97c032be44239f026914e437d2ff7a033bd70e85/mORMotReport.pas -------------------------------------------------------------------------------- /sha512-x64sse4.obj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/synopse/SynPDF/97c032be44239f026914e437d2ff7a033bd70e85/sha512-x64sse4.obj -------------------------------------------------------------------------------- /sha512-x86.obj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/synopse/SynPDF/97c032be44239f026914e437d2ff7a033bd70e85/sha512-x86.obj -------------------------------------------------------------------------------- /trees.obj: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/synopse/SynPDF/97c032be44239f026914e437d2ff7a033bd70e85/trees.obj --------------------------------------------------------------------------------