├── CodeGen.pas ├── Common.pas ├── LICENSE ├── Linker.pas ├── LitePascal.lpi ├── LitePascal.lps ├── LitePascal.pas ├── Parser.pas ├── README.md ├── Scanner.pas ├── docs ├── grammar.puml └── grammar.svg └── units ├── SysUtils.pas └── System.pas /CodeGen.pas: -------------------------------------------------------------------------------- 1 | // Based on XD Pascal (2020) original code by Vasiliy Tereshkov 2 | // Refactoring and extensions by Wanderlan 3 | {$I-,H-} 4 | unit CodeGen; 5 | 6 | interface 7 | 8 | uses 9 | Common; 10 | 11 | const 12 | MAXCODESIZE = 1024 * 1024; 13 | 14 | var 15 | Code: array [0..MAXCODESIZE - 1] of Byte; 16 | 17 | procedure InitializeCodeGen; 18 | function GetCodeSize: Longint; 19 | procedure PushConst(Value: Longint); 20 | procedure PushRealConst(Value: Double); 21 | procedure PushRelocConst(Value: Longint; RelocType: TRelocType); 22 | procedure Relocate(CodeDeltaAddr, InitDataDeltaAddr, UninitDataDeltaAddr, ImportDeltaAddr: Integer); 23 | procedure PushFunctionResult(ResultType: Integer); 24 | procedure MoveFunctionResultFromFPUToEDXEAX(DataType: Integer); 25 | procedure MoveFunctionResultFromEDXEAXToFPU(DataType: Integer); 26 | procedure PushVarPtr(Addr: Integer; Scope: TScope; DeltaNesting: Byte; RelocType: TRelocType); 27 | procedure DerefPtr(DataType: Integer); 28 | procedure GetArrayElementPtr(ArrType: Integer); 29 | procedure GetFieldPtr(Offset: Integer); 30 | procedure GetCharAsTempString(Depth: Integer); 31 | procedure SaveStackTopToEAX; 32 | procedure RestoreStackTopFromEAX; 33 | procedure SaveStackTopToEDX; 34 | procedure RestoreStackTopFromEDX; 35 | procedure RaiseStackTop(NumItems: Byte); 36 | procedure DiscardStackTop(NumItems: Byte); 37 | procedure DuplicateStackTop; 38 | procedure SaveCodePos; 39 | procedure GenerateIncDec(proc: TPredefProc; Size: Byte; BaseTypeSize: Integer = 0); 40 | procedure GenerateRound(TruncMode: Boolean); 41 | procedure GenerateDoubleFromInteger(Depth: Byte); 42 | procedure GenerateDoubleFromSingle; 43 | procedure GenerateSingleFromDouble; 44 | procedure GenerateMathFunction(func: TPredefProc; ResultType: Integer); 45 | procedure GenerateUnaryOperator(op: TTokenKind; ResultType: Integer); 46 | procedure GenerateBinaryOperator(op: TTokenKind; ResultType: Integer); 47 | procedure GenerateRelation(rel: TTokenKind; ValType: Integer); 48 | procedure GenerateAssignment(DesignatorType: Integer); 49 | procedure GenerateForAssignmentAndNumberOfIterations(CounterType: Integer; Down: Boolean); 50 | procedure GenerateStructuredAssignment(DesignatorType: Integer); 51 | procedure GenerateInterfaceFieldAssignment(Offset: Integer; PopValueFromStack: Boolean; Value: Longint; RelocType: TRelocType); 52 | procedure InitializeCStack; 53 | procedure PushToCStack(SourceStackDepth: Integer; DataType: Integer; PushByValue: Boolean); 54 | procedure ConvertSmallStructureToPointer(Addr: Longint; Size: Longint); 55 | procedure ConvertPointerToSmallStructure(Size: Longint); 56 | procedure GenerateImportFuncStub(EntryPoint: Longint); 57 | procedure GenerateCall(EntryPoint: Longint; CallerNesting, CalleeNesting: Integer); 58 | procedure GenerateIndirectCall(CallAddressDepth: Integer); 59 | procedure GenerateReturn(TotalParamsSize, Nesting: Integer); 60 | procedure GenerateForwardReference; 61 | procedure GenerateForwardResolution(CodePos: Integer); 62 | procedure GenerateIfCondition; 63 | procedure GenerateIfProlog; 64 | procedure GenerateElseProlog; 65 | procedure GenerateIfElseEpilog; 66 | procedure GenerateCaseProlog; 67 | procedure GenerateCaseEpilog(NumCaseStatements: Integer); 68 | procedure GenerateCaseEqualityCheck(Value: Longint); 69 | procedure GenerateCaseRangeCheck(Value1, Value2: Longint); 70 | procedure GenerateCaseStatementProlog; 71 | procedure GenerateCaseStatementEpilog; 72 | procedure GenerateWhileCondition; 73 | procedure GenerateWhileProlog; 74 | procedure GenerateWhileEpilog; 75 | procedure GenerateRepeatCondition; 76 | procedure GenerateRepeatProlog; 77 | procedure GenerateRepeatEpilog; 78 | procedure GenerateForCondition; 79 | procedure GenerateForProlog; 80 | procedure GenerateForEpilog(CounterType: Integer; Down: Boolean); 81 | procedure GenerateGotoProlog; 82 | procedure GenerateGoto(LabelIndex: Integer); 83 | procedure GenerateGotoEpilog; 84 | procedure GenerateShortCircuitProlog(op: TTokenKind); 85 | procedure GenerateShortCircuitEpilog; 86 | procedure GenerateNestedProcsProlog; 87 | procedure GenerateNestedProcsEpilog; 88 | procedure GenerateFPUInit; 89 | procedure GenerateStackFrameProlog(PreserveRegs: Boolean); 90 | procedure GenerateStackFrameEpilog(TotalStackStorageSize: Longint; PreserveRegs: Boolean); 91 | procedure GenerateBreakProlog(LoopNesting: Integer); 92 | procedure GenerateBreakCall(LoopNesting: Integer); 93 | procedure GenerateBreakEpilog(LoopNesting: Integer); 94 | procedure GenerateContinueProlog(LoopNesting: Integer); 95 | procedure GenerateContinueCall(LoopNesting: Integer); 96 | procedure GenerateContinueEpilog(LoopNesting: Integer); 97 | procedure GenerateExitProlog; 98 | procedure GenerateExitCall; 99 | procedure GenerateExitEpilog; 100 | 101 | implementation 102 | 103 | const 104 | MAXINSTRSIZE = 15; 105 | MAXPREVCODESIZES = 10; 106 | MAXRELOCS = 20000; 107 | MAXGOTOS = 100; 108 | MAXLOOPNESTING = 20; 109 | MAXBREAKCALLS = 100; 110 | 111 | type 112 | TRelocatable = record 113 | RelocType: TRelocType; 114 | Pos: Longint; 115 | Value: Longint; 116 | end; 117 | TGoto = record 118 | Pos: Longint; 119 | LabelIndex: Integer; 120 | ForLoopNesting: Integer; 121 | end; 122 | TBreakContinueExitCallList = record 123 | NumCalls: Integer; 124 | Pos: array [1..MAXBREAKCALLS] of Longint; 125 | end; 126 | TRegister = (EAX, ECX, EDX, ESI, EDI, EBP); 127 | 128 | var 129 | CodePosStack: array [0..1023] of Integer; 130 | CodeSize, CodePosStackTop: Integer; 131 | PrevCodeSizes: array [1..MAXPREVCODESIZES] of Integer; 132 | NumPrevCodeSizes: Integer; 133 | Reloc: array [1..MAXRELOCS] of TRelocatable; 134 | NumRelocs: Integer; 135 | Gotos: array [1..MAXGOTOS] of TGoto; 136 | NumGotos: Integer; 137 | BreakCall, ContinueCall: array [1..MAXLOOPNESTING] of TBreakContinueExitCallList; 138 | ExitCall: TBreakContinueExitCallList; 139 | 140 | procedure InitializeCodeGen; 141 | begin 142 | CodeSize := 0; 143 | CodePosStackTop := 0; 144 | NumPrevCodeSizes := 0; 145 | NumRelocs := 0; 146 | NumGotos := 0; 147 | end; 148 | 149 | function GetCodeSize: Longint; 150 | begin 151 | Result := CodeSize; 152 | NumPrevCodeSizes := 0; 153 | end; 154 | 155 | procedure Gen(b: Byte); 156 | begin 157 | Code[CodeSize] := b; 158 | Inc(CodeSize); 159 | end; 160 | 161 | procedure GenNew(b: Byte); 162 | var 163 | i: Integer; 164 | begin 165 | if CodeSize + MAXINSTRSIZE >= MAXCODESIZE then 166 | Error('Maximum code size exceeded'); 167 | if NumPrevCodeSizes < MAXPREVCODESIZES then 168 | Inc(NumPrevCodeSizes) 169 | else 170 | for i := 1 to MAXPREVCODESIZES - 1 do 171 | PrevCodeSizes[i] := PrevCodeSizes[i + 1]; 172 | PrevCodeSizes[NumPrevCodeSizes] := CodeSize; 173 | Gen(b); 174 | end; 175 | 176 | procedure GenAt(Pos: Longint; b: Byte); 177 | begin 178 | Code[Pos] := b; 179 | end; 180 | 181 | procedure GenWord(w: Integer); 182 | var 183 | i: Integer; 184 | begin 185 | for i := 1 to 2 do begin 186 | Gen(Byte(w and $FF)); 187 | w := w shr 8; 188 | end; 189 | end; 190 | 191 | procedure GenWordAt(Pos: Longint; w: Integer); 192 | var 193 | i: Integer; 194 | begin 195 | for i := 0 to 1 do begin 196 | GenAt(Pos + i, Byte(w and $FF)); 197 | w := w shr 8; 198 | end; 199 | end; 200 | 201 | procedure GenDWord(dw: Longint); 202 | var 203 | i: Integer; 204 | begin 205 | for i := 1 to 4 do begin 206 | Gen(Byte(dw and $FF)); 207 | dw := dw shr 8; 208 | end; 209 | end; 210 | 211 | procedure GenDWordAt(Pos: Longint; dw: Longint); 212 | var 213 | i: Integer; 214 | begin 215 | for i := 0 to 3 do begin 216 | GenAt(Pos + i, Byte(dw and $FF)); 217 | dw := dw shr 8; 218 | end; 219 | end; 220 | 221 | procedure GenRelocDWord(dw: Longint; RelocType: TRelocType); 222 | begin 223 | Inc(NumRelocs); 224 | if NumRelocs > MAXRELOCS then 225 | Error('Maximum number of relocations exceeded'); 226 | Reloc[NumRelocs].RelocType := RelocType; 227 | Reloc[NumRelocs].Pos := CodeSize; 228 | Reloc[NumRelocs].Value := dw; 229 | GenDWord(dw); 230 | end; 231 | 232 | function PrevInstrByte(Depth, Offset: Integer): Byte; 233 | begin 234 | Result := 0; 235 | // The last generated instruction starts at Depth = 0, Offset = 0 236 | if Depth < NumPrevCodeSizes then 237 | Result := Code[PrevCodeSizes[NumPrevCodeSizes - Depth] + Offset]; 238 | end; 239 | 240 | function PrevInstrDWord(Depth, Offset: Integer): Longint; 241 | begin 242 | Result := 0; 243 | // The last generated instruction starts at Depth = 0, Offset = 0 244 | if Depth < NumPrevCodeSizes then 245 | Result := PLongInt(@Code[PrevCodeSizes[NumPrevCodeSizes - Depth] + Offset])^; 246 | end; 247 | 248 | function PrevInstrRelocDWordIndex(Depth, Offset: Integer): Integer; 249 | var 250 | i: Integer; 251 | Pos: Longint; 252 | begin 253 | Result := 0; 254 | // The last generated instruction starts at Depth = 0, Offset = 0 255 | if Depth < NumPrevCodeSizes then begin 256 | Pos := PrevCodeSizes[NumPrevCodeSizes - Depth] + Offset; 257 | for i := NumRelocs downto 1 do 258 | if Reloc[i].Pos = Pos then begin 259 | Result := i; 260 | Exit; 261 | end; 262 | end; 263 | end; 264 | 265 | procedure RemovePrevInstr(Depth: Integer); 266 | begin 267 | if Depth >= NumPrevCodeSizes then 268 | Error('Internal fault: previous instruction not found'); 269 | CodeSize := PrevCodeSizes[NumPrevCodeSizes - Depth]; 270 | NumPrevCodeSizes := NumPrevCodeSizes - Depth - 1; 271 | end; 272 | 273 | procedure PushConst(Value: Longint); 274 | begin 275 | GenNew($68); GenDWord(Value); // push Value 276 | end; 277 | 278 | procedure PushRealConst(Value: Double); 279 | type 280 | TIntegerArray = array [0..1] of Longint; 281 | PIntegerArray = ^TIntegerArray; 282 | var 283 | IntegerArray: PIntegerArray; 284 | begin 285 | IntegerArray := PIntegerArray(@Value); 286 | PushConst(IntegerArray^[1]); 287 | PushConst(IntegerArray^[0]); 288 | end; 289 | 290 | procedure PushRelocConst(Value: Longint; RelocType: TRelocType); 291 | begin 292 | GenNew($68); GenRelocDWord(Value, RelocType); // push Value ; relocatable 293 | end; 294 | 295 | procedure Relocate(CodeDeltaAddr, InitDataDeltaAddr, UninitDataDeltaAddr, ImportDeltaAddr: Integer); 296 | var 297 | i, DeltaAddr: Integer; 298 | begin 299 | DeltaAddr := 0; 300 | for i := 1 to NumRelocs do begin 301 | case Reloc[i].RelocType of 302 | CODERELOC: DeltaAddr := CodeDeltaAddr; 303 | INITDATARELOC: DeltaAddr := InitDataDeltaAddr; 304 | UNINITDATARELOC: DeltaAddr := UninitDataDeltaAddr; 305 | IMPORTRELOC: DeltaAddr := ImportDeltaAddr 306 | else Error('Internal fault: Illegal relocation type'); 307 | end; 308 | GenDWordAt(Reloc[i].Pos, Reloc[i].Value + DeltaAddr); 309 | end; 310 | end; 311 | 312 | procedure GenPushReg(Reg: TRegister); 313 | begin 314 | case Reg of 315 | EAX: GenNew($50); // push eax 316 | ECX: GenNew($51); // push ecx 317 | EDX: GenNew($52); // push edx 318 | ESI: GenNew($56); // push esi 319 | EDI: GenNew($57); // push edi 320 | EBP: GenNew($55) // push ebp 321 | else Error('Internal fault: Illegal register'); 322 | end; 323 | end; 324 | 325 | procedure GenPopReg(Reg: TRegister); 326 | function OptimizePopReg: Boolean; 327 | var 328 | HasPushRegPrefix: Boolean; 329 | Value, Addr: Longint; 330 | ValueRelocIndex: Integer; 331 | PrevOpCode: Byte; 332 | begin 333 | Result := False; 334 | PrevOpCode := PrevInstrByte(0, 0); 335 | // Optimization: (push Reg) + (pop Reg) -> 0 336 | if ((Reg = EAX) and (PrevOpCode = $50)) or // Previous: push eax 337 | ((Reg = ECX) and (PrevOpCode = $51)) or // Previous: push ecx 338 | ((Reg = EDX) and (PrevOpCode = $52)) or // Previous: push edx 339 | ((Reg = ESI) and (PrevOpCode = $56)) or // Previous: push esi 340 | ((Reg = EDI) and (PrevOpCode = $57)) or // Previous: push edi 341 | ((Reg = EBP) and (PrevOpCode = $55)) // Previous: push ebp 342 | then begin 343 | RemovePrevInstr(0); // Remove: push Reg 344 | Result := True; 345 | Exit; 346 | end 347 | // Optimization: (push eax) + (pop ecx) -> (mov ecx, eax) 348 | else 349 | if (Reg = ECX) and (PrevOpCode = $50) then begin // Previous: push eax 350 | RemovePrevInstr(0); // Remove: push eax 351 | GenNew($89); Gen($C1); // mov ecx, eax 352 | Result := True; 353 | Exit; 354 | end 355 | // Optimization: (push eax) + (pop esi) -> (mov esi, eax) 356 | else 357 | if (Reg = ESI) and (PrevOpCode = $50) then begin // Previous: push esi 358 | RemovePrevInstr(0); // Remove: push eax 359 | // Special case: (mov eax, [epb + Addr]) + (push eax) + (pop esi) -> (mov esi, [epb + Addr]) 360 | if (PrevInstrByte(0, 0) = $8B) and (PrevInstrByte(0, 1) = $85) then begin // Previous: mov eax, [epb + Addr] 361 | Addr := PrevInstrDWord(0, 2); 362 | RemovePrevInstr(0); // Remove: mov eax, [epb + Addr] 363 | GenNew($8B); Gen($B5); GenDWord(Addr); // mov esi, [epb + Addr] 364 | end 365 | else begin 366 | GenNew($89); Gen($C6); // mov esi, eax 367 | end; 368 | Result := True; 369 | Exit; 370 | end 371 | // Optimization: (push esi) + (pop eax) -> (mov eax, esi) 372 | else 373 | if (Reg = EAX) and (PrevOpCode = $56) then begin // Previous: push esi 374 | RemovePrevInstr(0); // Remove: push esi 375 | GenNew($89); Gen($F0); // mov eax, esi 376 | Result := True; 377 | Exit; 378 | end 379 | // Optimization: (push Value) + (pop eax) -> (mov eax, Value) 380 | else 381 | if (Reg = EAX) and (PrevOpCode = $68) then begin // Previous: push Value 382 | Value := PrevInstrDWord(0, 1); 383 | ValueRelocIndex := PrevInstrRelocDWordIndex(0, 1); 384 | // Special case: (push esi) + (push Value) + (pop eax) -> (mov eax, Value) + (push esi) 385 | HasPushRegPrefix := PrevInstrByte(1, 0) = $56; // Previous: push esi 386 | RemovePrevInstr(0); // Remove: push Value 387 | if HasPushRegPrefix then 388 | RemovePrevInstr(0); // Remove: push esi 389 | GenNew($B8); GenDWord(Value); // mov eax, Value 390 | if HasPushRegPrefix then begin 391 | if ValueRelocIndex <> 0 then 392 | Dec(Reloc[ValueRelocIndex].Pos); // Relocate Value if necessary 393 | GenPushReg(ESI); // push esi 394 | end; 395 | Result := True; 396 | Exit; 397 | end 398 | // Optimization: (push [esi]) + (pop eax) -> (mov eax, [esi]) 399 | else 400 | if (Reg = EAX) and (PrevInstrByte(0, 0) = $FF) and (PrevInstrByte(0, 1) = $36) then begin // Previous: push [esi] 401 | RemovePrevInstr(0); // Remove: push [esi] 402 | GenNew($8B); Gen($06); // mov eax, [esi] 403 | Result := True; 404 | Exit; 405 | end 406 | // Optimization: (push [esi + 4]) + (mov eax, [esi]) + (pop edx) -> (mov eax, [esi]) + (mov edx, [esi + 4]) 407 | else 408 | if (Reg = EDX) and (PrevInstrByte(1, 0) = $FF) and (PrevInstrByte(1, 1) = $76) and (PrevInstrByte(1, 2) = $04) // Previous: push [esi + 4] 409 | and (PrevInstrByte(0, 0) = $8B) and (PrevInstrByte(0, 1) = $06) // Previous: mov eax, [esi] 410 | then begin 411 | RemovePrevInstr(1); // Remove: push [esi + 4], mov eax, [esi] 412 | GenNew($8B); Gen($06); // mov eax, [esi] 413 | GenNew($8B); Gen($56); Gen($04); // mov edx, [esi + 4] 414 | Result := True; 415 | Exit; 416 | end 417 | // Optimization: (push Value) + (pop ecx) -> (mov ecx, Value) 418 | else 419 | if (Reg = ECX) and (PrevOpCode = $68) then begin // Previous: push Value 420 | Value := PrevInstrDWord(0, 1); 421 | ValueRelocIndex := PrevInstrRelocDWordIndex(0, 1); 422 | // Special case: (push eax) + (push Value) + (pop ecx) -> (mov ecx, Value) + (push eax) 423 | HasPushRegPrefix := PrevInstrByte(1, 0) = $50; // Previous: push eax 424 | RemovePrevInstr(0); // Remove: push Value 425 | if HasPushRegPrefix then 426 | RemovePrevInstr(0); // Remove: push eax / push [ebp + Addr] 427 | GenNew($B9); GenDWord(Value); // mov ecx, Value 428 | if HasPushRegPrefix then begin 429 | if ValueRelocIndex <> 0 then 430 | Dec(Reloc[ValueRelocIndex].Pos); // Relocate Value if necessary 431 | GenPushReg(EAX); // push eax 432 | end; 433 | Result := True; 434 | Exit; 435 | end 436 | // Optimization: (push Value) + (pop esi) -> (mov esi, Value) 437 | else 438 | if (Reg = ESI) and (PrevOpCode = $68) then begin // Previous: push Value 439 | Value := PrevInstrDWord(0, 1); 440 | RemovePrevInstr(0); // Remove: push Value 441 | GenNew($BE); GenDWord(Value); // mov esi, Value 442 | Result := True; 443 | Exit; 444 | end 445 | // Optimization: (push Value) + (mov eax, [Addr]) + (pop esi) -> (mov esi, Value) + (mov eax, [Addr]) 446 | else 447 | if (Reg = ESI) and (PrevInstrByte(1, 0) = $68) and (PrevInstrByte(0, 0) = $A1) then begin // Previous: push Value, mov eax, [Addr] 448 | Value := PrevInstrDWord(1, 1); 449 | Addr := PrevInstrDWord(0, 1); 450 | RemovePrevInstr(1); // Remove: push Value, mov eax, [Addr] 451 | GenNew($BE); GenDWord(Value); // mov esi, Value 452 | GenNew($A1); GenDWord(Addr); // mov eax, [Addr] 453 | Result := True; 454 | Exit; 455 | end 456 | // Optimization: (push esi) + (mov eax, [ebp + Value]) + (pop esi) -> (mov eax, [ebp + Value]) 457 | else 458 | if (Reg = ESI) and (PrevInstrByte(1, 0) = $56) // Previous: push esi 459 | and (PrevInstrByte(0, 0) = $8B) and (PrevInstrByte(0, 1) = $85) then begin // Previous: mov eax, [ebp + Value] 460 | Value := PrevInstrDWord(0, 2); 461 | RemovePrevInstr(1); // Remove: push esi, mov eax, [ebp + Value] 462 | GenNew($8B); Gen($85); GenDWord(Value); // mov eax, [ebp + Value] 463 | Result := True; 464 | Exit; 465 | end 466 | // Optimization: (push dword ptr [esp]) + (pop esi) -> (mov esi, [esp]) 467 | else 468 | if (Reg = ESI) and (PrevInstrByte(0, 0) = $FF) and (PrevInstrByte(0, 1) = $34) and (PrevInstrByte(0, 2) = $24) then 469 | begin // Previous: push dword ptr [esp] 470 | RemovePrevInstr(0); // Remove: push dword ptr [esp] 471 | GenNew($8B); Gen($34); Gen($24); // mov esi, [esp] 472 | Result := True; 473 | Exit; 474 | end; 475 | end; 476 | 477 | begin // GenPopReg 478 | if not OptimizePopReg then 479 | case Reg of 480 | EAX: GenNew($58); // pop eax 481 | ECX: GenNew($59); // pop ecx 482 | EDX: GenNew($5A); // pop edx 483 | ESI: GenNew($5E); // pop esi 484 | EDI: GenNew($5F); // pop edi 485 | EBP: GenNew($5D) // pop ebp 486 | else Error('Internal fault: Illegal register'); 487 | end; 488 | end; 489 | 490 | procedure GenPushToFPU; 491 | function OptimizeGenPushToFPU: Boolean; 492 | begin 493 | Result := False; 494 | // Optimization: (fstp qword ptr [esp]) + (fld qword ptr [esp]) -> (fst qword ptr [esp]) 495 | if (PrevInstrByte(0, 0) = $DD) and (PrevInstrByte(0, 1) = $1C) and (PrevInstrByte(0, 2) = $24) then // Previous: fstp dword ptr [esp] 496 | begin 497 | RemovePrevInstr(0); // Remove: fstp dword ptr [esp] 498 | GenNew($DD); Gen($14); Gen($24); // fst qword ptr [esp] 499 | Result := True; 500 | end 501 | // Optimization: (push [esi + 4]) + (push [esi]) + (fld qword ptr [esp]) -> (fld qword ptr [esi]) + (sub esp, 8) 502 | else 503 | if (PrevInstrByte(1, 0) = $FF) and (PrevInstrByte(1, 1) = $76) and (PrevInstrByte(1, 2) = $04) and // Previous: push [esi + 4] 504 | (PrevInstrByte(0, 0) = $FF) and (PrevInstrByte(0, 1) = $36) // Previous: push [esi] 505 | then begin 506 | RemovePrevInstr(1); // Remove: push [esi + 4], push [esi] 507 | GenNew($DD); Gen($06); // fld qword ptr [esi] 508 | RaiseStackTop(2); // sub esp, 8 509 | Result := True; 510 | end; 511 | end; 512 | 513 | begin 514 | if not OptimizeGenPushToFPU then begin 515 | GenNew($DD); Gen($04); Gen($24); // fld qword ptr [esp] 516 | end; 517 | end; 518 | 519 | procedure GenPopFromFPU; 520 | begin 521 | GenNew($DD); Gen($1C); Gen($24); // fstp qword ptr [esp] 522 | end; 523 | 524 | procedure PushFunctionResult(ResultType: Integer); 525 | begin 526 | if Types[ResultType].Kind = REALTYPE then 527 | GenPushReg(EDX) // push edx 528 | else 529 | if Types[ResultType].Kind = BOOLEANTYPE then begin 530 | GenNew($83); Gen($E0); Gen($01); // and eax, 1 531 | end 532 | else 533 | case TypeSize(ResultType) of 534 | 1: if Types[ResultType].Kind in UnsignedTypes then begin 535 | GenNew($0F); Gen($B6); Gen($C0); // movzx eax, al 536 | end 537 | else begin 538 | GenNew($0F); Gen($BE); Gen($C0); // movsx eax, al 539 | end; 540 | 2: if Types[ResultType].Kind in UnsignedTypes then begin 541 | GenNew($0F); Gen($B7); Gen($C0); // movzx eax, ax 542 | end 543 | else begin 544 | GenNew($0F); Gen($BF); Gen($C0); // movsx eax, ax 545 | end; 546 | end; // case 547 | GenPushReg(EAX); // push eax 548 | end; 549 | 550 | procedure MoveFunctionResultFromFPUToEDXEAX(DataType: Integer); 551 | begin 552 | if Types[DataType].Kind = REALTYPE then begin 553 | RaiseStackTop(2); // sub esp, 8 ; expand stack 554 | GenPopFromFPU; // fstp qword ptr [esp] ; [esp] := st; pop 555 | GenNew($8B); Gen($04); Gen($24); // mov eax, [esp] 556 | GenNew($8B); Gen($54); Gen($24); Gen($04); // mov edx, [esp + 4] 557 | DiscardStackTop(2); // add esp, 8 ; shrink stack 558 | end 559 | else 560 | if Types[DataType].Kind = SINGLETYPE then begin 561 | RaiseStackTop(1); // sub esp, 4 ; expand stack 562 | GenNew($D9); Gen($1C); Gen($24); // fstp dword ptr [esp] ; [esp] := single(st); pop 563 | GenNew($8B); Gen($04); Gen($24); // mov eax, [esp] 564 | DiscardStackTop(1); // add esp, 4 ; shrink stack 565 | end 566 | else 567 | Error('Internal fault: Illegal type'); 568 | end; 569 | 570 | procedure MoveFunctionResultFromEDXEAXToFPU(DataType: Integer); 571 | begin 572 | if Types[DataType].Kind = REALTYPE then begin 573 | GenPushReg(EDX); // push edx 574 | GenPushReg(EAX); // push eax 575 | GenPushToFPU; // fld qword ptr [esp] 576 | DiscardStackTop(2); // add esp, 8 ; shrink stack 577 | end 578 | else 579 | if Types[DataType].Kind = SINGLETYPE then begin 580 | GenPushReg(EAX); // push eax 581 | GenNew($D9); Gen($04); Gen($24); // fld dword ptr [esp] 582 | DiscardStackTop(1); // add esp, 4 ; shrink stack 583 | end 584 | else 585 | Error('Internal fault: Illegal type'); 586 | end; 587 | 588 | procedure PushVarPtr(Addr: Integer; Scope: TScope; DeltaNesting: Byte; RelocType: TRelocType); 589 | const 590 | StaticLinkAddr = 2 * 4; 591 | var 592 | i: Integer; 593 | begin 594 | // EAX must be preserved 595 | case Scope of 596 | GLOBAL: // Global variable 597 | PushRelocConst(Addr, RelocType); 598 | LOCAL: begin 599 | if DeltaNesting = 0 then // Strictly local variable 600 | begin 601 | GenNew($8D); Gen($B5); GenDWord(Addr); // lea esi, [ebp + Addr] 602 | end 603 | else // Intermediate level variable 604 | begin 605 | GenNew($8B); Gen($75); Gen(StaticLinkAddr); // mov esi, [ebp + StaticLinkAddr] 606 | for i := 1 to DeltaNesting - 1 do begin 607 | GenNew($8B); Gen($76); Gen(StaticLinkAddr); // mov esi, [esi + StaticLinkAddr] 608 | end; 609 | GenNew($8D); Gen($B6); GenDWord(Addr); // lea esi, [esi + Addr] 610 | end; 611 | GenPushReg(ESI); // push esi 612 | end; 613 | end; // case 614 | end; 615 | 616 | procedure DerefPtr(DataType: Integer); 617 | function OptimizeDerefPtr: Boolean; 618 | var 619 | Addr, Offset: Longint; 620 | AddrRelocIndex: Integer; 621 | begin 622 | Result := False; 623 | // Global variable loading 624 | // Optimization: (mov esi, Addr) + (mov... eax, ... ptr [esi]) -> (mov... eax, ... ptr [Addr]) ; relocatable 625 | if PrevInstrByte(0, 0) = $BE then begin // Previous: mov esi, Addr 626 | Addr := PrevInstrDWord(0, 1); 627 | AddrRelocIndex := PrevInstrRelocDWordIndex(0, 1); 628 | RemovePrevInstr(0); // Remove: mov esi, Addr 629 | case TypeSize(DataType) of 630 | 1: if Types[DataType].Kind in UnsignedTypes then begin 631 | GenNew($0F); Gen($B6); Gen($05); // movzx eax, byte ptr ... 632 | end 633 | else begin 634 | GenNew($0F); Gen($BE); Gen($05); // movsx eax, byte ptr ... 635 | end; 636 | 2: if Types[DataType].Kind in UnsignedTypes then begin 637 | GenNew($0F); Gen($B7); Gen($05); // movzx eax, word ptr ... 638 | end 639 | else begin 640 | GenNew($0F); Gen($BF); Gen($05); // movsx eax, word ptr ... 641 | end; 642 | 4: GenNew($A1)// mov eax, dword ptr ... 643 | else Error('Internal fault: Illegal designator size'); 644 | end; 645 | GenDWord(Addr); // ... [Addr] 646 | // Relocate Addr if necessary 647 | if (AddrRelocIndex <> 0) and (TypeSize(DataType) <> 4) then 648 | with Reloc[AddrRelocIndex] do 649 | Pos := Pos + 2; 650 | Result := True; 651 | Exit; 652 | end 653 | // Local variable loading 654 | // Optimization: (lea esi, [ebp + Addr]) + (mov... eax, ... ptr [esi]) -> (mov... eax, ... ptr [ebp + Addr]) 655 | else 656 | if (PrevInstrByte(0, 0) = $8D) and (PrevInstrByte(0, 1) = $B5) then // Previous: lea esi, [ebp + Addr] 657 | begin 658 | Addr := PrevInstrDWord(0, 2); 659 | RemovePrevInstr(0); // Remove: lea esi, [ebp + Addr] 660 | 661 | case TypeSize(DataType) of 662 | 663 | 1: if Types[DataType].Kind in UnsignedTypes then begin 664 | GenNew($0F); Gen($B6); Gen($85); // movzx eax, byte ptr [ebp + ... 665 | end 666 | else begin 667 | GenNew($0F); Gen($BE); Gen($85); // movsx eax, byte ptr [ebp + ... 668 | end; 669 | 670 | 2: if Types[DataType].Kind in UnsignedTypes then begin 671 | GenNew($0F); Gen($B7); Gen($85); // movzx eax, word ptr [ebp + ... 672 | end 673 | else begin 674 | GenNew($0F); Gen($BF); Gen($85); // movsx eax, word ptr [ebp + ... 675 | end; 676 | 677 | 4: begin 678 | GenNew($8B); Gen($85); // mov eax, dword ptr [ebp + ... 679 | end 680 | else Error('Internal fault: Illegal designator size'); 681 | end; 682 | GenDWord(Addr); // ... + Addr] 683 | Result := True; 684 | Exit; 685 | end 686 | // Record field loading 687 | // Optimization: (add esi, Offset) + (mov... eax, ... ptr [esi]) -> (mov... eax, ... ptr [esi + Offset]) 688 | else 689 | if (PrevInstrByte(0, 0) = $81) and (PrevInstrByte(0, 1) = $C6) then // Previous: add esi, Offset 690 | begin 691 | Offset := PrevInstrDWord(0, 2); 692 | RemovePrevInstr(0); // Remove: add esi, Offset 693 | case TypeSize(DataType) of 694 | 1: if Types[DataType].Kind in UnsignedTypes then begin 695 | GenNew($0F); Gen($B6); Gen($86); // movzx eax, byte ptr [esi + ... 696 | end 697 | else begin 698 | GenNew($0F); Gen($BE); Gen($86); // movsx eax, byte ptr [esi + ... 699 | end; 700 | 2: if Types[DataType].Kind in UnsignedTypes then begin 701 | GenNew($0F); Gen($B7); Gen($86); // movzx eax, word ptr [esi + ... 702 | end 703 | else begin 704 | GenNew($0F); Gen($BF); Gen($86); // movsx eax, word ptr [esi + ... 705 | end; 706 | 4: begin 707 | GenNew($8B); Gen($86); // mov eax, dword ptr [esi + ... 708 | end 709 | else Error('Internal fault: Illegal designator size'); 710 | end; 711 | GenDWord(Offset); // ... + Offset] 712 | Result := True; 713 | Exit; 714 | end; 715 | end; 716 | 717 | begin // DerefPtr 718 | GenPopReg(ESI); // pop esi 719 | if Types[DataType].Kind = REALTYPE then // Special case: Double 720 | begin 721 | GenNew($FF); Gen($76); Gen($04); // push [esi + 4] 722 | GenNew($FF); Gen($36); // push [esi] 723 | end 724 | else // General rule 725 | begin 726 | if not OptimizeDerefPtr then 727 | case TypeSize(DataType) of 728 | 1: if Types[DataType].Kind in UnsignedTypes then begin 729 | GenNew($0F); Gen($B6); Gen($06); // movzx eax, byte ptr [esi] 730 | end 731 | else begin 732 | GenNew($0F); Gen($BE); Gen($06); // movsx eax, byte ptr [esi] 733 | end; 734 | 2: if Types[DataType].Kind in UnsignedTypes then begin 735 | GenNew($0F); Gen($B7); Gen($06); // movzx eax, word ptr [esi] 736 | end 737 | else begin 738 | GenNew($0F); Gen($BF); Gen($06); // movsx eax, word ptr [esi] 739 | end; 740 | 4: begin 741 | GenNew($8B); Gen($06); // mov eax, dword ptr [esi] 742 | end 743 | else Error('Internal fault: Illegal designator size'); 744 | end; 745 | GenPushReg(EAX); // push eax 746 | end; 747 | end; 748 | 749 | procedure GetArrayElementPtr(ArrType: Integer); 750 | function OptimizeGetArrayElementPtr: Boolean; 751 | var 752 | BaseAddr, IndexAddr: Longint; 753 | Index: Integer; 754 | begin 755 | Result := False; 756 | // Global arrays 757 | // Optimization: (push BaseAddr) + (mov eax, [ebp + IndexAddr]) + (pop esi) -> (mov esi, BaseAddr) + (mov eax, [ebp + IndexAddr]) 758 | if (PrevInstrByte(1, 0) = $68) and (PrevInstrByte(0, 0) = $8B) and (PrevInstrByte(0, 1) = $85) then // Previous: push BaseAddr, mov eax, [ebp + IndexAddr] 759 | begin 760 | BaseAddr := PrevInstrDWord(1, 1); 761 | IndexAddr := PrevInstrDWord(0, 2); 762 | RemovePrevInstr(1); // Remove: push BaseAddr, mov eax, [ebp + IndexAddr] 763 | GenNew($BE); GenDWord(BaseAddr); // mov esi, BaseAddr ; suilable for relocatable addresses (instruction length is the same as for push BaseAddr) 764 | GenNew($8B); Gen($85); GenDWord(IndexAddr); // mov eax, [ebp + IndexAddr] 765 | Result := True; 766 | end 767 | // Optimization: (push BaseAddr) + (mov eax, Index) + (pop esi) -> (mov esi, BaseAddr) + (mov eax, Index) 768 | else 769 | if (PrevInstrByte(1, 0) = $68) and (PrevInstrByte(0, 0) = $B8) then // Previous: push BaseAddr, mov eax, Index 770 | begin 771 | BaseAddr := PrevInstrDWord(1, 1); 772 | Index := PrevInstrDWord(0, 1); 773 | RemovePrevInstr(1); // Remove: push BaseAddr, mov eax, Index 774 | GenNew($BE); GenDWord(BaseAddr); // mov esi, BaseAddr ; suitable for relocatable addresses (instruction length is the same as for push BaseAddr) 775 | GenNew($B8); GenDWord(Index); // mov eax, Index 776 | Result := True; 777 | end 778 | // Local arrays 779 | // Optimization: (mov eax, [ebp + BaseAddr]) + (push eax) + (mov eax, [ebp + IndexAddr]) + (pop esi) -> (mov esi, [ebp + BaseAddr]) + (mov eax, [ebp + IndexAddr]) 780 | else 781 | if (PrevInstrByte(2, 0) = $8B) and (PrevInstrByte(2, 1) = $85) and // Previous: mov eax, [ebp + BaseAddr] 782 | (PrevInstrByte(1, 0) = $50) and // Previous: push eax 783 | (PrevInstrByte(0, 0) = $8B) and (PrevInstrByte(0, 1) = $85) // Previous: mov eax, [ebp + IndexAddr] 784 | then begin 785 | BaseAddr := PrevInstrDWord(2, 2); 786 | IndexAddr := PrevInstrDWord(0, 2); 787 | RemovePrevInstr(2); // Remove: mov eax, [ebp + BaseAddr], push eax, mov eax, [ebp + IndexAddr] 788 | GenNew($8B); Gen($B5); GenDWord(BaseAddr); // mov esi, [ebp + BaseAddr] 789 | GenNew($8B); Gen($85); GenDWord(IndexAddr); // mov eax, [ebp + IndexAddr] 790 | Result := True; 791 | end 792 | // Optimization: (mov eax, [ebp + BaseAddr]) + (push eax) + (mov eax, Index) + (pop esi) -> (mov esi, [ebp + BaseAddr]) + (mov eax, Index) 793 | else 794 | if (PrevInstrByte(2, 0) = $8B) and (PrevInstrByte(2, 1) = $85) and // Previous: mov eax, [ebp + BaseAddr] 795 | (PrevInstrByte(1, 0) = $50) and // Previous: push eax 796 | (PrevInstrByte(0, 0) = $B8) // Previous: mov eax, Index 797 | then begin 798 | BaseAddr := PrevInstrDWord(2, 2); 799 | Index := PrevInstrDWord(0, 1); 800 | RemovePrevInstr(2); // Remove: mov eax, [ebp + BaseAddr], push eax, mov eax, Index 801 | GenNew($8B); Gen($B5); GenDWord(BaseAddr); // mov esi, [ebp + BaseAddr] 802 | GenNew($B8); GenDWord(Index); // mov eax, Index 803 | Result := True; 804 | end; 805 | end; 806 | 807 | function Log2(x: Longint): Shortint; 808 | var 809 | i: Integer; 810 | begin 811 | for i := 0 to 31 do 812 | if x = 1 shl i then begin 813 | Result := i; 814 | Exit; 815 | end; 816 | Result := -1; 817 | end; 818 | 819 | var 820 | BaseTypeSize, IndexLowBound: Integer; 821 | Log2BaseTypeSize: Shortint; 822 | begin 823 | GenPopReg(EAX); // pop eax ; Array index 824 | if not OptimizeGetArrayElementPtr then 825 | GenPopReg(ESI); // pop esi ; Array base offset 826 | BaseTypeSize := TypeSize(Types[ArrType].BaseType); 827 | IndexLowBound := LowBound(Types[ArrType].IndexType); 828 | if IndexLowBound = 1 then 829 | GenNew($48) // dec eax 830 | else 831 | if IndexLowBound <> 0 then begin 832 | GenNew($2D); GenDWord(IndexLowBound); // sub eax, IndexLowBound 833 | end; 834 | if (BaseTypeSize <> 1) and (BaseTypeSize <> 2) and (BaseTypeSize <> 4) and (BaseTypeSize <> 8) then begin 835 | Log2BaseTypeSize := Log2(BaseTypeSize); 836 | if Log2BaseTypeSize > 0 then begin 837 | GenNew($C1); Gen($E0); Gen(Log2BaseTypeSize); // shl eax, Log2BaseTypeSize 838 | end 839 | else begin 840 | GenNew($69); Gen($C0); GenDWord(BaseTypeSize); // imul eax, BaseTypeSize 841 | end; 842 | end; // if 843 | GenNew($8D); Gen($34); // lea esi, [esi + eax * ... 844 | case BaseTypeSize of 845 | 1: Gen($06); // ... * 1] 846 | 2: Gen($46); // ... * 2] 847 | 4: Gen($86); // ... * 4] 848 | 8: Gen($C6) // ... * 8] 849 | else Gen($06) // ... * 1] ; already multiplied above 850 | end; 851 | GenPushReg(ESI); // push esi 852 | end; 853 | 854 | procedure GetFieldPtr(Offset: Integer); 855 | function OptimizeGetFieldPtr: Boolean; 856 | var 857 | Addr: Longint; 858 | BaseTypeSizeCode: Byte; 859 | begin 860 | Result := False; 861 | // Optimization: (lea esi, [ebp + Addr]) + (add esi, Offset) -> (lea esi, [ebp + Addr + Offset]) 862 | if (PrevInstrByte(0, 0) = $8D) and (PrevInstrByte(0, 1) = $B5) then // Previous: lea esi, [ebp + Addr] 863 | begin 864 | Addr := PrevInstrDWord(0, 2); 865 | RemovePrevInstr(0); // Remove: lea esi, [ebp + Addr] 866 | GenNew($8D); Gen($B5); GenDWord(Addr + Offset); // lea esi, [ebp + Addr + Offset] 867 | Result := True; 868 | end 869 | // Optimization: (lea esi, [esi + eax * BaseTypeSize]) + (add esi, Offset) -> (lea esi, [esi + eax * BaseTypeSize + Offset]) 870 | else 871 | if (PrevInstrByte(0, 0) = $8D) and (PrevInstrByte(0, 1) = $34) then // Previous: lea esi, [esi + eax * BaseTypeSize] 872 | begin 873 | BaseTypeSizeCode := PrevInstrDWord(0, 2); 874 | RemovePrevInstr(0); // Remove: lea esi, [esi + eax * BaseTypeSize] 875 | GenNew($8D); Gen($B4); Gen(BaseTypeSizeCode); GenDWord(Offset); // lea esi, [esi + eax * BaseTypeSize + Offset] 876 | Result := True; 877 | end; 878 | end; 879 | 880 | begin // GetFieldPtr 881 | if Offset <> 0 then begin 882 | GenPopReg(ESI); // pop esi 883 | if not OptimizeGetFieldPtr then begin 884 | GenNew($81); Gen($C6); GenDWord(Offset); // add esi, Offset 885 | end; 886 | GenPushReg(ESI); // push esi 887 | end; 888 | end; 889 | 890 | procedure GetCharAsTempString(Depth: Integer); 891 | begin 892 | if (Depth <> 0) and (Depth <> SizeOf(Longint)) then 893 | Error('Internal fault: Illegal depth'); 894 | GenPopReg(ESI); // pop esi ; Temporary string address 895 | if Depth = SizeOf(Longint) then 896 | GenPopReg(ECX); // pop ecx ; Some other string address 897 | GenPopReg(EAX); // pop eax ; Character 898 | GenNew($88); Gen($06); // mov byte ptr [esi], al 899 | GenNew($C6); Gen($46); Gen($01); Gen($00); // mov byte ptr [esi + 1], 0 900 | GenPushReg(ESI); // push esi 901 | if Depth = SizeOf(Longint) then 902 | GenPushReg(ECX); // push ecx ; Some other string address 903 | end; 904 | 905 | procedure SaveStackTopToEAX; 906 | begin 907 | GenPopReg(EAX); // pop eax 908 | end; 909 | 910 | procedure RestoreStackTopFromEAX; 911 | begin 912 | GenPushReg(EAX); // push eax 913 | end; 914 | 915 | procedure SaveStackTopToEDX; 916 | begin 917 | GenPopReg(EDX); // pop edx 918 | end; 919 | 920 | procedure RestoreStackTopFromEDX; 921 | begin 922 | GenPushReg(EDX); // push edx 923 | end; 924 | 925 | procedure RaiseStackTop(NumItems: Byte); 926 | begin 927 | GenNew($81); Gen($EC); GenDWord(SizeOf(Longint) * NumItems); // sub esp, 4 * NumItems 928 | end; 929 | 930 | procedure DiscardStackTop(NumItems: Byte); 931 | function OptimizeDiscardStackTop: Boolean; 932 | var 933 | Value: Longint; 934 | begin 935 | Result := False; 936 | // Optimization: (push Reg) + (add esp, 4 * NumItems) -> (add esp, 4 * (NumItems - 1)) 937 | if PrevInstrByte(0, 0) in [$50, $51, $52, $56, $57, $55] then begin // Previous: push Reg 938 | RemovePrevInstr(0); // Remove: push Reg 939 | if NumItems > 1 then begin 940 | GenNew($81); Gen($C4); GenDWord(SizeOf(Longint) * (NumItems - 1)); // add esp, 4 * (NumItems - 1) 941 | end; 942 | Result := True; 943 | end 944 | // Optimization: (sub esp, Value) + (add esp, 4 * NumItems) -> (add esp, 4 * NumItems - Value) 945 | else 946 | if (PrevInstrByte(0, 0) = $81) and (PrevInstrByte(0, 1) = $EC) then // Previous: sub esp, Value 947 | begin 948 | Value := PrevInstrDWord(0, 2); 949 | RemovePrevInstr(0); // Remove: sub esp, Value 950 | 951 | if SizeOf(Longint) * NumItems <> Value then begin 952 | GenNew($81); Gen($C4); GenDWord(SizeOf(Longint) * NumItems - Value); // add esp, 4 * NumItems - Value 953 | end; 954 | 955 | Result := True; 956 | end; 957 | end; 958 | 959 | 960 | begin // DiscardStackTop 961 | if not OptimizeDiscardStackTop then begin 962 | GenNew($81); Gen($C4); GenDWord(SizeOf(Longint) * NumItems); // add esp, 4 * NumItems 963 | end; 964 | end; 965 | 966 | 967 | procedure DiscardStackTopAt(Pos: Longint; NumItems: Byte); 968 | begin 969 | GenAt(Pos, $81); GenAt(Pos + 1, $C4); GenDWordAt(Pos + 2, SizeOf(Longint) * NumItems); // add esp, 4 * NumItems 970 | end; 971 | 972 | 973 | procedure DuplicateStackTop; 974 | begin 975 | GenNew($FF); Gen($34); Gen($24); // push dword ptr [esp] 976 | end; 977 | 978 | 979 | procedure SaveCodePos; 980 | begin 981 | Inc(CodePosStackTop); 982 | CodePosStack[CodePosStackTop] := GetCodeSize; 983 | end; 984 | 985 | 986 | function RestoreCodePos: Longint; 987 | begin 988 | Result := CodePosStack[CodePosStackTop]; 989 | Dec(CodePosStackTop); 990 | end; 991 | 992 | 993 | procedure GenerateIncDec(proc: TPredefProc; Size: Byte; BaseTypeSize: Integer = 0); 994 | begin 995 | GenPopReg(ESI); // pop esi 996 | 997 | if BaseTypeSize <> 0 then // Special case: typed pointer 998 | begin 999 | GenNew($81); // ... dword ptr ... 1000 | 1001 | case proc of 1002 | INCPROC: Gen($06); // add ... [esi], ... 1003 | DECPROC: Gen($2E); // sub ... [esi], ... 1004 | end; 1005 | 1006 | GenDWord(BaseTypeSize); // ... BaseTypeSize 1007 | end 1008 | else // General rule 1009 | begin 1010 | case Size of 1011 | 1: GenNew($FE);// ... byte ptr ... 1012 | 1013 | 2: begin 1014 | GenNew($66); Gen($FF); // ... word ptr ... 1015 | end; 1016 | 4: GenNew($FF);// ... dword ptr ... 1017 | 1018 | end; 1019 | 1020 | case proc of 1021 | INCPROC: Gen($06); // inc ... [esi] 1022 | DECPROC: Gen($0E); // dec ... [esi] 1023 | end; 1024 | end; 1025 | end; 1026 | 1027 | 1028 | procedure GenerateRound(TruncMode: Boolean); 1029 | begin 1030 | GenPushToFPU; // fld qword ptr [esp] ; st = operand 1031 | DiscardStackTop(1); // add esp, 4 ; shrink stack 1032 | 1033 | if TruncMode then begin 1034 | GenNew($66); Gen($C7); Gen($44); Gen($24); Gen(Byte(-4)); GenWord($0F7F); // mov word ptr [esp - 4], 0F7Fh 1035 | GenNew($D9); Gen($6C); Gen($24); Gen(Byte(-4)); // fldcw word ptr [esp - 4] 1036 | end; 1037 | 1038 | GenNew($DB); Gen($1C); Gen($24); // fistp dword ptr [esp] ; [esp] := round(st); pop 1039 | 1040 | if TruncMode then begin 1041 | GenNew($66); Gen($C7); Gen($44); Gen($24); Gen(Byte(-4)); GenWord($037F); // mov word ptr [esp - 4], 037Fh 1042 | GenNew($D9); Gen($6C); Gen($24); Gen(Byte(-4)); // fldcw word ptr [esp - 4] 1043 | end; 1044 | 1045 | end;// GenerateRound 1046 | 1047 | 1048 | procedure GenerateDoubleFromInteger(Depth: Byte); 1049 | begin 1050 | if Depth = 0 then begin 1051 | GenNew($DB); Gen($04); Gen($24); // fild dword ptr [esp] ; st := double(operand) 1052 | RaiseStackTop(1); // sub esp, 4 ; expand stack 1053 | GenPopFromFPU; // fstp qword ptr [esp] ; [esp] := st; pop 1054 | end 1055 | else 1056 | if Depth = SizeOf(Double) then begin 1057 | GenPushToFPU; // fld qword ptr [esp] ; st := operand2 1058 | GenNew($DB); Gen($44); Gen($24); Gen(Depth); // fild dword ptr [esp + Depth] ; st := double(operand), st(1) = operand2 1059 | RaiseStackTop(1); // sub esp, 4 ; expand stack 1060 | GenNew($DD); Gen($5C); Gen($24); Gen(Depth); // fstp qword ptr [esp + Depth] ; [esp + Depth] := operand; pop 1061 | GenPopFromFPU; // fstp qword ptr [esp] ; [esp] := operand2; pop 1062 | end 1063 | else 1064 | Error('Internal fault: Illegal stack depth'); 1065 | end;// GenerateDoubleFromInteger 1066 | 1067 | 1068 | procedure GenerateDoubleFromSingle; 1069 | begin 1070 | GenNew($D9); Gen($04); Gen($24); // fld dword ptr [esp] ; st := double(operand) 1071 | RaiseStackTop(1); // sub esp, 4 ; expand stack 1072 | GenPopFromFPU; // fstp qword ptr [esp] ; [esp] := st; pop 1073 | end; // GenerateDoubleFromSingle 1074 | 1075 | procedure GenerateSingleFromDouble; 1076 | begin 1077 | GenPushToFPU; // fld qword ptr [esp] ; st := operand 1078 | DiscardStackTop(1); // add esp, 4 ; shrink stack 1079 | GenNew($D9); Gen($1C); Gen($24); // fstp dword ptr [esp] ; [esp] := single(st); pop 1080 | end; // GenerateDoubleFromSingle 1081 | 1082 | procedure GenerateMathFunction(func: TPredefProc; ResultType: Integer); 1083 | begin 1084 | if Types[ResultType].Kind = REALTYPE then // Real type 1085 | begin 1086 | GenPushToFPU; // fld qword ptr [esp] ; st = operand 1087 | case func of 1088 | ABSFUNC: begin 1089 | GenNew($D9); Gen($E1); // fabs 1090 | end; 1091 | SQRFUNC: begin 1092 | GenNew($DC); Gen($C8); // fmul st, st 1093 | end; 1094 | SINFUNC: begin 1095 | GenNew($D9); Gen($FE); // fsin 1096 | end; 1097 | COSFUNC: begin 1098 | GenNew($D9); Gen($FF); // fcos 1099 | end; 1100 | ARCTANFUNC: begin 1101 | GenNew($D9); Gen($E8); // fld1 1102 | GenNew($D9); Gen($F3); // fpatan ; st := arctan(x / 1.0) 1103 | end; 1104 | EXPFUNC: begin 1105 | GenNew($D9); Gen($EA); // fldl2e 1106 | GenNew($DE); Gen($C9); // fmul 1107 | GenNew($D9); Gen($C0); // fld st 1108 | GenNew($D9); Gen($FC); // frndint 1109 | GenNew($DD); Gen($D2); // fst st(2) ; st(2) := round(x * log2(e)) 1110 | GenNew($DE); Gen($E9); // fsub 1111 | GenNew($D9); Gen($F0); // f2xm1 ; st := 2 ^ frac(x * log2(e)) - 1 1112 | GenNew($D9); Gen($E8); // fld1 1113 | GenNew($DE); Gen($C1); // fadd 1114 | GenNew($D9); Gen($FD); // fscale ; st := 2 ^ frac(x * log2(e)) * 2 ^ round(x * log2(e)) = exp(x) 1115 | end; 1116 | LNFUNC: begin 1117 | GenNew($D9); Gen($ED); // fldln2 1118 | GenNew($D9); Gen($C9); // fxch 1119 | GenNew($D9); Gen($F1); // fyl2x ; st := ln(2) * log2(x) = ln(x) 1120 | end; 1121 | SQRTFUNC: begin 1122 | GenNew($D9); Gen($FA); // fsqrt 1123 | end; 1124 | end;// case 1125 | GenPopFromFPU; // fstp qword ptr [esp] ; [esp] := st; pop 1126 | end 1127 | else // Ordinal types 1128 | case func of 1129 | ABSFUNC: begin 1130 | GenPopReg(EAX); // pop eax 1131 | GenNew($83); Gen($F8); Gen($00); // cmp eax, 0 1132 | GenNew($7D); Gen($02); // jge +2 1133 | GenNew($F7); Gen($D8); // neg eax 1134 | GenPushReg(EAX); // push eax 1135 | end; 1136 | SQRFUNC: begin 1137 | GenPopReg(EAX); // pop eax 1138 | GenNew($F7); Gen($E8); // imul eax 1139 | GenPushReg(EAX); // push eax 1140 | end; 1141 | end;// case 1142 | end; // GenerateMathFunction 1143 | 1144 | procedure GenerateUnaryOperator(op: TTokenKind; ResultType: Integer); 1145 | begin 1146 | if Types[ResultType].Kind = REALTYPE then begin // Real type 1147 | if op = MINUSTOK then begin 1148 | GenPushToFPU; // fld qword ptr [esp] ; st = operand 1149 | GenNew($D9); Gen($E0); // fchs 1150 | GenPopFromFPU; // fstp qword ptr [esp] ; [esp] := st; pop 1151 | end; 1152 | end 1153 | else begin // Ordinal types 1154 | GenPopReg(EAX); // pop eax 1155 | case op of 1156 | MINUSTOK: begin 1157 | GenNew($F7); Gen($D8); // neg eax 1158 | end; 1159 | NOTTOK: begin 1160 | GenNew($F7); Gen($D0); // not eax 1161 | end; 1162 | end;// case 1163 | if Types[ResultType].Kind = BOOLEANTYPE then begin 1164 | GenNew($83); Gen($E0); Gen($01); // and eax, 1 1165 | end; 1166 | GenPushReg(EAX); // push eax 1167 | end;// else 1168 | end; 1169 | 1170 | procedure GenerateBinaryOperator(op: TTokenKind; ResultType: Integer); 1171 | begin 1172 | if Types[ResultType].Kind = REALTYPE then begin // Real type 1173 | GenPushToFPU; // fld qword ptr [esp] ; st = operand2 1174 | DiscardStackTop(2); // add esp, 8 1175 | GenPushToFPU; // fld qword ptr [esp] ; st(1) = operand2; st = operand1 1176 | case op of 1177 | PLUSTOK: begin 1178 | GenNew($DE); Gen($C1); // fadd ; st(1) := st(1) + st; pop 1179 | end; 1180 | MINUSTOK: begin 1181 | GenNew($DE); Gen($E1); // fsubr ; st(1) := st - st(1); pop 1182 | end; 1183 | MULTOK: begin 1184 | GenNew($DE); Gen($C9); // fmul ; st(1) := st(1) * st; pop 1185 | end; 1186 | DIVTOK: begin 1187 | GenNew($DE); Gen($F1); // fdivr ; st(1) := st / st(1); pop 1188 | end; 1189 | end;// case 1190 | GenPopFromFPU; // fstp dword ptr [esp] ; [esp] := st; pop 1191 | end // if 1192 | else begin // Ordinal types 1193 | // For commutative operators, use reverse operand order for better optimization 1194 | if (op = PLUSTOK) or (op = ANDTOK) or (op = ORTOK) or (op = XORTOK) then begin 1195 | GenPopReg(EAX); // pop eax 1196 | GenPopReg(ECX); // pop ecx 1197 | end 1198 | else begin 1199 | GenPopReg(ECX); // pop ecx 1200 | GenPopReg(EAX); // pop eax 1201 | end; 1202 | case op of 1203 | PLUSTOK: begin 1204 | GenNew($03); Gen($C1); // add eax, ecx 1205 | end; 1206 | MINUSTOK: begin 1207 | GenNew($2B); Gen($C1); // sub eax, ecx 1208 | end; 1209 | MULTOK: begin 1210 | GenNew($F7); Gen($E9); // imul ecx 1211 | end; 1212 | IDIVTOK, MODTOK: begin 1213 | GenNew($99); // cdq 1214 | GenNew($F7); Gen($F9); // idiv ecx 1215 | if op = MODTOK then begin 1216 | GenNew($8B); Gen($C2); // mov eax, edx ; save remainder 1217 | end; 1218 | end; 1219 | SHLTOK: begin 1220 | GenNew($D3); Gen($E0); // shl eax, cl 1221 | end; 1222 | SHRTOK: begin 1223 | GenNew($D3); Gen($E8); // shr eax, cl 1224 | end; 1225 | ANDTOK: begin 1226 | GenNew($23); Gen($C1); // and eax, ecx 1227 | end; 1228 | ORTOK: begin 1229 | GenNew($0B); Gen($C1); // or eax, ecx 1230 | end; 1231 | XORTOK: begin 1232 | GenNew($33); Gen($C1); // xor eax, ecx 1233 | end; 1234 | end;// case 1235 | if Types[ResultType].Kind = BOOLEANTYPE then begin 1236 | GenNew($83); Gen($E0); Gen($01); // and eax, 1 1237 | end; 1238 | GenPushReg(EAX); // push eax 1239 | end;// else 1240 | end; 1241 | 1242 | procedure GenerateRelation(rel: TTokenKind; ValType: Integer); 1243 | function OptimizeGenerateRelation: Boolean; 1244 | var 1245 | Value: Longint; 1246 | begin 1247 | Result := False; 1248 | // Optimization: (mov ecx, Value) + (cmp eax, ecx) -> (cmp eax, Value) 1249 | if PrevInstrByte(0, 0) = $B9 then begin // Previous: mov ecx, Value 1250 | Value := PrevInstrDWord(0, 1); 1251 | RemovePrevInstr(0); // Remove: mov ecx, Value 1252 | GenNew($3D); GenDWord(Value); // cmp eax, Value 1253 | Result := True; 1254 | end; 1255 | end; 1256 | 1257 | begin 1258 | if Types[ValType].Kind = REALTYPE then // Real type 1259 | begin 1260 | GenPushToFPU; // fld dword ptr [esp] ; st = operand2 1261 | DiscardStackTop(2); // add esp, 8 1262 | GenPushToFPU; // fld dword ptr [esp] ; st(1) = operand2; st = operand1 1263 | DiscardStackTop(2); // add esp, 8 1264 | GenNew($DE); Gen($D9); // fcompp ; test st - st(1) 1265 | GenNew($DF); Gen($E0); // fnstsw ax 1266 | GenNew($9E); // sahf 1267 | GenNew($B8); GenDWord(1); // mov eax, 1 ; TRUE 1268 | case rel of 1269 | EQTOK: GenNew($74); // je ... 1270 | NETOK: GenNew($75); // jne ... 1271 | GTTOK: GenNew($77); // ja ... 1272 | GETOK: GenNew($73); // jae ... 1273 | LTTOK: GenNew($72); // jb ... 1274 | LETOK: GenNew($76); // jbe ... 1275 | end;// case 1276 | end 1277 | else begin // Ordinal types 1278 | GenPopReg(ECX); // pop ecx 1279 | GenPopReg(EAX); // pop eax 1280 | if not OptimizeGenerateRelation then begin 1281 | GenNew($39); Gen($C8); // cmp eax, ecx 1282 | end; 1283 | GenNew($B8); GenDWord(1); // mov eax, 1 ; TRUE 1284 | case rel of 1285 | EQTOK: GenNew($74); // je ... 1286 | NETOK: GenNew($75); // jne ... 1287 | GTTOK: GenNew($7F); // jg ... 1288 | GETOK: GenNew($7D); // jge ... 1289 | LTTOK: GenNew($7C); // jl ... 1290 | LETOK: GenNew($7E); // jle ... 1291 | end;// case 1292 | end;// else 1293 | Gen($02); // ... +2 1294 | GenNew($31); Gen($C0); // xor eax, eax ; FALSE 1295 | GenPushReg(EAX); // push eax 1296 | end; 1297 | 1298 | procedure GenerateAssignment(DesignatorType: Integer); 1299 | function OptimizeGenerateRealAssignment: Boolean; 1300 | begin 1301 | Result := False; 1302 | // Optimization: (fstp qword ptr [esp]) + (pop eax) + (pop edx) + (pop esi) + (mov [esi], eax) + (mov [esi + 4], edx) -> (add esp, 8) + (pop esi) + (fstp qword ptr [esi]) 1303 | if (PrevInstrByte(0, 0) = $DD) and (PrevInstrByte(0, 1) = $1C) and (PrevInstrByte(0, 2) = $24) then begin // Previous: fstp dword ptr [esp] 1304 | RemovePrevInstr(0); // Remove: fstp dword ptr [esp] 1305 | DiscardStackTop(2); // add esp, 8 1306 | GenPopReg(ESI); // pop esi 1307 | GenNew($DD); Gen($1E); // fstp qword ptr [esi] 1308 | Result := True; 1309 | end; 1310 | end; 1311 | 1312 | function OptimizeGenerateAssignment: Boolean; 1313 | var 1314 | IsMov, IsMovPush: Boolean; 1315 | Value: Longint; 1316 | ValueRelocIndex: Integer; 1317 | begin 1318 | Result := False; 1319 | IsMov := PrevInstrByte(0, 0) = $B8; // Previous: mov eax, Value 1320 | IsMovPush := (PrevInstrByte(1, 0) = $B8) and (PrevInstrByte(0, 0) = $56); // Previous: mov eax, Value, push esi 1321 | if IsMov then begin 1322 | Value := PrevInstrDWord(0, 1); 1323 | ValueRelocIndex := PrevInstrRelocDWordIndex(0, 1); 1324 | end 1325 | else begin 1326 | Value := PrevInstrDWord(1, 1); 1327 | ValueRelocIndex := PrevInstrRelocDWordIndex(1, 1); 1328 | end; 1329 | // Optimization: (mov eax, Value) + [(push esi) + (pop esi)] + (mov [esi], al/ax/eax) -> (mov byte/word/dword ptr [esi], Value) 1330 | if (IsMov or IsMovPush) and (ValueRelocIndex = 0) then begin // Non-relocatable Value only 1331 | if IsMovPush then 1332 | GenPopReg(ESI); // pop esi ; destination address 1333 | RemovePrevInstr(0); // Remove: mov eax, Value 1334 | if IsMov then 1335 | GenPopReg(ESI); // pop esi ; destination address 1336 | case TypeSize(DesignatorType) of 1337 | 1: begin 1338 | GenNew($C6); Gen($06); Gen(Byte(Value)); // mov byte ptr [esi], Value 1339 | end; 1340 | 2: begin 1341 | GenNew($66); Gen($C7); Gen($06); GenWord(Word(Value)); // mov word ptr [esi], Value 1342 | end; 1343 | 4: begin 1344 | GenNew($C7); Gen($06); GenDWord(Value); // mov dword ptr [esi], Value 1345 | end 1346 | else Error('Internal fault: Illegal designator size'); 1347 | end; // case 1348 | Result := True; 1349 | end; 1350 | end; 1351 | 1352 | begin 1353 | if Types[DesignatorType].Kind = REALTYPE then // Special case: 64-bit real type 1354 | begin 1355 | if not OptimizeGenerateRealAssignment then begin 1356 | GenPopReg(EAX); // pop eax ; source value 1357 | GenPopReg(EDX); // pop edx ; source value 1358 | GenPopReg(ESI); // pop esi ; destination address 1359 | GenNew($89); Gen($06); // mov [esi], eax 1360 | GenNew($89); Gen($56); Gen($04); // mov [esi + 4], edx 1361 | end; 1362 | end 1363 | else // General rule: 8, 16, 32-bit types 1364 | if not OptimizeGenerateAssignment then begin 1365 | GenPopReg(EAX); // pop eax ; source value 1366 | GenPopReg(ESI); // pop esi ; destination address 1367 | case TypeSize(DesignatorType) of 1368 | 1: begin 1369 | GenNew($88); Gen($06); // mov [esi], al 1370 | end; 1371 | 2: begin 1372 | GenNew($66); Gen($89); Gen($06); // mov [esi], ax 1373 | end; 1374 | 4: begin 1375 | GenNew($89); Gen($06); // mov [esi], eax 1376 | end 1377 | else Error('Internal fault: Illegal designator size'); 1378 | end; // case 1379 | end; 1380 | end; 1381 | 1382 | procedure GenerateForAssignmentAndNumberOfIterations(CounterType: Integer; Down: Boolean); 1383 | function OptimizeGenerateForAssignmentAndNumberOfIterations: Boolean; 1384 | var 1385 | InitialValue, FinalValue: Longint; 1386 | InitialValueRelocIndex, FinalValueRelocIndex: Longint; 1387 | begin 1388 | Result := False; 1389 | // Optimization: (push InitialValue) + (push FinalValue) + ... -> ... (constant initial and final values) 1390 | if (PrevInstrByte(1, 0) = $68) and (PrevInstrByte(0, 0) = $68) then begin // Previous: push InitialValue, push FinalValue 1391 | InitialValue := PrevInstrDWord(1, 1); 1392 | InitialValueRelocIndex := PrevInstrRelocDWordIndex(1, 1); 1393 | FinalValue := PrevInstrDWord(0, 1); 1394 | FinalValueRelocIndex := PrevInstrRelocDWordIndex(0, 1); 1395 | if (InitialValueRelocIndex = 0) and (FinalValueRelocIndex = 0) then begin // Non-relocatable values only 1396 | RemovePrevInstr(1); // Remove: push InitialValue, push FinalValue 1397 | GenPopReg(ESI); // pop esi ; counter address 1398 | case TypeSize(CounterType) of 1399 | 1: begin 1400 | GenNew($C6); Gen($06); Gen(Byte(InitialValue)); // mov byte ptr [esi], InitialValue 1401 | end; 1402 | 2: begin 1403 | GenNew($66); Gen($C7); Gen($06); GenWord(Word(InitialValue)); // mov word ptr [esi], InitialValue 1404 | end; 1405 | 4: begin 1406 | GenNew($C7); Gen($06); GenDWord(InitialValue); // mov dword ptr [esi], InitialValue 1407 | end 1408 | else Error('Internal fault: Illegal designator size'); 1409 | end; // case 1410 | // Number of iterations 1411 | if Down then 1412 | PushConst(InitialValue - FinalValue + 1) 1413 | else 1414 | PushConst(FinalValue - InitialValue + 1); 1415 | Result := True; 1416 | end; 1417 | end; 1418 | end; 1419 | 1420 | begin 1421 | if not OptimizeGenerateForAssignmentAndNumberOfIterations then begin 1422 | GenPopReg(EAX); // pop eax ; final value 1423 | GenPopReg(ECX); // pop ecx ; initial value 1424 | GenPopReg(ESI); // pop esi ; counter address 1425 | case TypeSize(CounterType) of 1426 | 1: begin 1427 | GenNew($88); Gen($0E); // mov [esi], cl 1428 | end; 1429 | 2: begin 1430 | GenNew($66); Gen($89); Gen($0E); // mov [esi], cx 1431 | end; 1432 | 4: begin 1433 | GenNew($89); Gen($0E); // mov [esi], ecx 1434 | end 1435 | else Error('Internal fault: Illegal designator size'); 1436 | end; // case 1437 | // Number of iterations 1438 | if Down then begin 1439 | GenNew($29); Gen($C1); // sub ecx, eax 1440 | GenNew($41); // inc ecx 1441 | GenPushReg(ECX); // push ecx 1442 | end 1443 | else begin 1444 | GenNew($2B); Gen($C1); // sub eax, ecx 1445 | GenNew($40); // inc eax 1446 | GenPushReg(EAX); // push eax 1447 | end; 1448 | end; 1449 | end; 1450 | 1451 | procedure GenerateStructuredAssignment(DesignatorType: Integer); 1452 | begin 1453 | // ECX should be preserved 1454 | GenPopReg(ESI); // pop esi ; source address 1455 | GenPopReg(EDI); // pop edi ; destination address 1456 | // Copy source to destination 1457 | GenPushReg(ECX); // push ecx 1458 | GenNew($B9); GenDWord(TypeSize(DesignatorType)); // mov ecx, TypeSize(DesignatorType) 1459 | GenNew($FC); // cld ; increment esi, edi after each step 1460 | GenNew($F3); Gen($A4); // rep movsb 1461 | GenPopReg(ECX); // pop ecx 1462 | end; 1463 | 1464 | procedure GenerateInterfaceFieldAssignment(Offset: Integer; PopValueFromStack: Boolean; Value: Longint; RelocType: TRelocType); 1465 | begin 1466 | if PopValueFromStack then begin 1467 | GenPopReg(ESI); // pop esi 1468 | GenNew($89); Gen($B5); GenDWord(Offset); // mov dword ptr [ebp + Offset], esi 1469 | GenPushReg(ESI); // push esi 1470 | end 1471 | else begin 1472 | GenNew($C7); Gen($85); GenDWord(Offset); GenRelocDWord(Value, RelocType); // mov dword ptr [ebp + Offset], Value 1473 | end; 1474 | end; 1475 | 1476 | procedure InitializeCStack; 1477 | begin 1478 | GenNew($89); Gen($E1); // mov ecx, esp 1479 | end; 1480 | 1481 | procedure PushToCStack(SourceStackDepth: Integer; DataType: Integer; PushByValue: Boolean); 1482 | var 1483 | ActualSize: Integer; 1484 | begin 1485 | if PushByValue and (Types[DataType].Kind in StructuredTypes) then begin 1486 | ActualSize := Align(TypeSize(DataType), SizeOf(Longint)); 1487 | // Copy structure to the C stack 1488 | RaiseStackTop(ActualSize div SizeOf(Longint)); // sub esp, ActualSize 1489 | GenNew($8B); Gen($B1); GenDWord(SourceStackDepth); // mov esi, [ecx + SourceStackDepth] 1490 | GenNew($89); Gen($E7); // mov edi, esp 1491 | GenPushReg(EDI); // push edi ; destination address 1492 | GenPushReg(ESI); // push esi ; source address 1493 | GenerateStructuredAssignment(DataType); 1494 | end 1495 | else 1496 | if PushByValue and (Types[DataType].Kind = REALTYPE) then begin 1497 | GenNew($FF); Gen($B1); GenDWord(SourceStackDepth + SizeOf(Longint)); // push [ecx + SourceStackDepth + 4] 1498 | GenNew($FF); Gen($B1); GenDWord(SourceStackDepth); // push [ecx + SourceStackDepth] 1499 | end 1500 | else begin 1501 | GenNew($FF); Gen($B1); GenDWord(SourceStackDepth); // push [ecx + SourceStackDepth] 1502 | end; 1503 | end; 1504 | 1505 | procedure ConvertSmallStructureToPointer(Addr: Longint; Size: Longint); 1506 | begin 1507 | // Converts a small structure in EDX:EAX into a pointer in EAX 1508 | if Size <= SizeOf(Longint) then begin 1509 | GenNew($89); Gen($85); GenDWord(Addr); // mov [ebp + Addr], eax 1510 | end 1511 | else 1512 | if Size <= 2 * SizeOf(Longint) then begin 1513 | GenNew($89); Gen($85); GenDWord(Addr); // mov [ebp + Addr], eax 1514 | GenNew($89); Gen($95); GenDWord(Addr + SizeOf(Longint)); // mov [ebp + Addr + 4], edx 1515 | end 1516 | else 1517 | Error('Internal fault: Structure is too large to return in EDX:EAX'); 1518 | GenNew($8D); Gen($85); GenDWord(Addr); // lea eax, [ebp + Addr] 1519 | end; 1520 | 1521 | procedure ConvertPointerToSmallStructure(Size: Longint); 1522 | begin 1523 | // Converts a pointer in EAX into a small structure in EDX:EAX 1524 | if Size <= SizeOf(Longint) then begin 1525 | GenNew($8B); Gen($00); // mov eax, [eax] 1526 | end 1527 | else 1528 | if Size <= 2 * SizeOf(Longint) then begin 1529 | GenNew($8B); Gen($50); Gen(Byte(SizeOf(Longint))); // mov edx, [eax + 4] 1530 | GenNew($8B); Gen($00); // mov eax, [eax] 1531 | end 1532 | else 1533 | Error('Internal fault: Structure is too large to return in EDX:EAX'); 1534 | end; 1535 | 1536 | procedure GenerateImportFuncStub(EntryPoint: Longint); 1537 | begin 1538 | GenNew($FF); Gen($25); GenRelocDWord(EntryPoint, IMPORTRELOC); // jmp ds:EntryPoint ; relocatable 1539 | end; 1540 | 1541 | procedure GenerateCall(EntryPoint: Longint; CallerNesting, CalleeNesting: Integer); 1542 | const 1543 | StaticLinkAddr = 2 * 4; 1544 | var 1545 | CodePos: Integer; 1546 | i: Integer; 1547 | begin 1548 | if (CallerNesting < 0) or (CalleeNesting < 1) or (CallerNesting - CalleeNesting < -1) then 1549 | Error('Internal fault: Illegal nesting level'); 1550 | if CalleeNesting > 1 then // If a nested routine is called, push static link as the last hidden parameter 1551 | if CallerNesting - CalleeNesting = -1 then // The caller and the callee's enclosing routine are at the same nesting level 1552 | GenPushReg(EBP)// push ebp 1553 | else begin // The caller is deeper 1554 | GenNew($8B); Gen($75); Gen(StaticLinkAddr); // mov esi, [ebp + StaticLinkAddr] 1555 | for i := 1 to CallerNesting - CalleeNesting do begin 1556 | GenNew($8B); Gen($76); Gen(StaticLinkAddr); // mov esi, [esi + StaticLinkAddr] 1557 | end; 1558 | GenPushReg(ESI); // push esi 1559 | end; 1560 | // Call the routine 1561 | CodePos := GetCodeSize; 1562 | GenNew($E8); GenDWord(EntryPoint - (CodePos + 5)); // call EntryPoint 1563 | end; 1564 | 1565 | procedure GenerateIndirectCall(CallAddressDepth: Integer); 1566 | begin 1567 | GenNew($8B); Gen($B4); Gen($24); GenDWord(CallAddressDepth); // mov esi, dword ptr [esp + CallAddressDepth] 1568 | GenNew($FF); Gen($16); // call [esi] 1569 | end; 1570 | 1571 | procedure GenerateReturn(TotalParamsSize, Nesting: Integer); 1572 | begin 1573 | GenNew($C2); // ret ... 1574 | if Nesting = 1 then 1575 | GenWord(TotalParamsSize) // ... TotalParamsSize 1576 | else 1577 | GenWord(TotalParamsSize + 4); // ... TotalParamsSize + 4 ; + 4 is for static link 1578 | end; 1579 | 1580 | procedure GenerateForwardReference; 1581 | begin 1582 | GenNew($90); // nop ; jump to the procedure entry point will be inserted here 1583 | GenNew($90); // nop 1584 | GenNew($90); // nop 1585 | GenNew($90); // nop 1586 | GenNew($90); // nop 1587 | end; 1588 | 1589 | procedure GenerateForwardResolution(CodePos: Integer); 1590 | begin 1591 | GenAt(CodePos, $E9); GenDWordAt(CodePos + 1, GetCodeSize - (CodePos + 5)); // jmp GetCodeSize 1592 | end; 1593 | 1594 | procedure GenerateForwardResolutionToDestination(CodePos, DestPos: Integer); 1595 | begin 1596 | GenAt(CodePos, $E9); GenDWordAt(CodePos + 1, DestPos - (CodePos + 5)); // jmp DestPos 1597 | end; 1598 | 1599 | procedure GenerateIfCondition; 1600 | function OptimizeGenerateIfCondition: Boolean; 1601 | var 1602 | JumpOpCode: Byte; 1603 | begin 1604 | Result := False; 1605 | JumpOpCode := PrevInstrByte(1, 0); 1606 | // Optimization: (mov eax, 1) + (jxx +2) + (xor eax, eax) + (test eax, eax) + (jne +5) -> (jxx +5) 1607 | if (PrevInstrByte(2, 0) = $B8) and (PrevInstrDWord(2, 1) = 1) and // Previous: mov eax, 1 1608 | (JumpOpCode in [$74, $75, $77, $73, $72, $76, $7F, $7D, $7C, $7E]) and (PrevInstrByte(1, 1) = $02) and // Previous: jxx +2 1609 | (PrevInstrByte(0, 0) = $31) and (PrevInstrByte(0, 1) = $C0) then begin // Previous: xor eax, eax 1610 | RemovePrevInstr(2); // Remove: mov eax, 1, jxx +2, xor eax, eax 1611 | GenNew(JumpOpCode); Gen($05); // jxx +5 1612 | Result := True; 1613 | end; 1614 | end; 1615 | 1616 | begin 1617 | GenPopReg(EAX); // pop eax 1618 | if not OptimizeGenerateIfCondition then begin 1619 | GenNew($85); Gen($C0); // test eax, eax 1620 | GenNew($75); Gen($05); // jne +5 1621 | end; 1622 | end; 1623 | 1624 | procedure GenerateIfProlog; 1625 | begin 1626 | SaveCodePos; 1627 | GenNew($90); // nop ; jump to the IF block end will be inserted here 1628 | GenNew($90); // nop 1629 | GenNew($90); // nop 1630 | GenNew($90); // nop 1631 | GenNew($90); // nop 1632 | end; 1633 | 1634 | procedure GenerateElseProlog; 1635 | var 1636 | CodePos: Integer; 1637 | begin 1638 | CodePos := RestoreCodePos; 1639 | GenAt(CodePos, $E9); GenDWordAt(CodePos + 1, GetCodeSize - (CodePos + 5) + 5); // jmp (IF..THEN block end) 1640 | GenerateIfProlog; 1641 | end; 1642 | 1643 | procedure GenerateIfElseEpilog; 1644 | var 1645 | CodePos: Integer; 1646 | begin 1647 | CodePos := RestoreCodePos; 1648 | GenAt(CodePos, $E9); GenDWordAt(CodePos + 1, GetCodeSize - (CodePos + 5)); // jmp (IF..THEN block end) 1649 | end; 1650 | 1651 | procedure GenerateCaseProlog; 1652 | begin 1653 | GenPopReg(ECX); // pop ecx ; CASE switch value 1654 | GenNew($B0); Gen($00); // mov al, 00h ; initial flag mask 1655 | end; 1656 | 1657 | procedure GenerateCaseEpilog(NumCaseStatements: Integer); 1658 | var 1659 | i: Integer; 1660 | begin 1661 | for i := 1 to NumCaseStatements do 1662 | GenerateIfElseEpilog; 1663 | end; 1664 | 1665 | procedure GenerateCaseEqualityCheck(Value: Longint); 1666 | begin 1667 | GenNew($81); Gen($F9); GenDWord(Value); // cmp ecx, Value 1668 | GenNew($9F); // lahf 1669 | GenNew($0A); Gen($C4); // or al, ah 1670 | end; 1671 | 1672 | procedure GenerateCaseRangeCheck(Value1, Value2: Longint); 1673 | begin 1674 | GenNew($81); Gen($F9); GenDWord(Value1); // cmp ecx, Value1 1675 | GenNew($7C); Gen($0A); // jl +10 1676 | GenNew($81); Gen($F9); GenDWord(Value2); // cmp ecx, Value2 1677 | GenNew($7F); Gen($02); // jg +2 1678 | GenNew($0C); Gen($40); // or al, 40h ; set zero flag on success 1679 | end; 1680 | 1681 | procedure GenerateCaseStatementProlog; 1682 | begin 1683 | GenNew($24); Gen($40); // and al, 40h ; test zero flag 1684 | GenNew($75); Gen($05); // jnz +5 ; if set, jump to the case statement 1685 | GenerateIfProlog; 1686 | end; 1687 | 1688 | procedure GenerateCaseStatementEpilog; 1689 | var 1690 | StoredCodeSize: Longint; 1691 | begin 1692 | StoredCodeSize := GetCodeSize; 1693 | GenNew($90); // nop ; jump to the CASE block end will be inserted here 1694 | GenNew($90); // nop 1695 | GenNew($90); // nop 1696 | GenNew($90); // nop 1697 | GenNew($90); // nop 1698 | GenerateIfElseEpilog; 1699 | Inc(CodePosStackTop); 1700 | CodePosStack[CodePosStackTop] := StoredCodeSize; 1701 | end; 1702 | 1703 | procedure GenerateWhileCondition; 1704 | begin 1705 | GenerateIfCondition; 1706 | end; 1707 | 1708 | procedure GenerateWhileProlog; 1709 | begin 1710 | GenerateIfProlog; 1711 | end; 1712 | 1713 | 1714 | procedure GenerateWhileEpilog; 1715 | var 1716 | CodePos, CurPos, ReturnPos: Integer; 1717 | begin 1718 | CodePos := RestoreCodePos; 1719 | GenAt(CodePos, $E9); GenDWordAt(CodePos + 1, GetCodeSize - (CodePos + 5) + 5); // jmp (WHILE..DO block end) 1720 | 1721 | ReturnPos := RestoreCodePos; 1722 | CurPos := GetCodeSize; 1723 | GenNew($E9); GenDWord(ReturnPos - (CurPos + 5)); // jmp ReturnPos 1724 | end; 1725 | 1726 | procedure GenerateRepeatCondition; 1727 | begin 1728 | GenerateIfCondition; 1729 | end; 1730 | 1731 | procedure GenerateRepeatProlog; 1732 | begin 1733 | SaveCodePos; 1734 | end; 1735 | 1736 | procedure GenerateRepeatEpilog; 1737 | var 1738 | CurPos, ReturnPos: Integer; 1739 | begin 1740 | ReturnPos := RestoreCodePos; 1741 | CurPos := GetCodeSize; 1742 | GenNew($E9); GenDWord(ReturnPos - (CurPos + 5)); // jmp ReturnPos 1743 | end; 1744 | 1745 | procedure GenerateForCondition; 1746 | begin // Check remaining number of iterations 1747 | GenNew($83); Gen($3C); Gen($24); Gen($00); // cmp dword ptr [esp], 0 1748 | GenNew($7F); Gen($05); // jg +5 1749 | end; 1750 | 1751 | procedure GenerateForProlog; 1752 | begin 1753 | Inc(ForLoopNesting); 1754 | GenerateIfProlog; 1755 | end; 1756 | 1757 | procedure GenerateForEpilog(CounterType: Integer; Down: Boolean); 1758 | begin 1759 | // Increment/decrement counter variable 1760 | if Down then 1761 | GenerateIncDec(DECPROC, TypeSize(CounterType)) 1762 | else 1763 | GenerateIncDec(INCPROC, TypeSize(CounterType)); 1764 | // Decrement remaining number of iterations 1765 | GenNew($FF); Gen($0C); Gen($24); // dec dword ptr [esp] 1766 | GenerateWhileEpilog; 1767 | Dec(ForLoopNesting); 1768 | end; 1769 | 1770 | procedure GenerateGotoProlog; 1771 | begin 1772 | NumGotos := 0; 1773 | end; 1774 | 1775 | procedure GenerateGoto(LabelIndex: Integer); 1776 | begin 1777 | Inc(NumGotos); 1778 | Gotos[NumGotos].Pos := GetCodeSize; 1779 | Gotos[NumGotos].LabelIndex := LabelIndex; 1780 | Gotos[NumGotos].ForLoopNesting := ForLoopNesting; 1781 | GenNew($90); // nop ; the remaining numbers of iterations of all nested FOR loops will be removed from stack here 1782 | GenNew($90); // nop 1783 | GenNew($90); // nop 1784 | GenNew($90); // nop 1785 | GenNew($90); // nop 1786 | GenNew($90); // nop 1787 | GenerateForwardReference; 1788 | end; 1789 | 1790 | procedure GenerateGotoEpilog; 1791 | var 1792 | CodePos: Longint; 1793 | i: Integer; 1794 | begin 1795 | for i := 1 to NumGotos do begin 1796 | CodePos := Gotos[i].Pos; 1797 | DiscardStackTopAt(CodePos, Gotos[i].ForLoopNesting - Ident[Gotos[i].LabelIndex].ForLoopNesting); // Remove the remaining numbers of iterations of all nested FOR loops 1798 | GenerateForwardResolutionToDestination(CodePos + 6, Ident[Gotos[i].LabelIndex].Address); 1799 | end; 1800 | end; 1801 | 1802 | procedure GenerateShortCircuitProlog(op: TTokenKind); 1803 | begin 1804 | GenPopReg(EAX); // pop eax 1805 | GenNew($85); Gen($C0); // test eax, eax 1806 | case op of 1807 | ANDTOK: GenNew($75); // jne ... 1808 | ORTOK: GenNew($74); // je ... 1809 | end; 1810 | Gen($05); // ... +5 1811 | GenerateIfProlog; 1812 | end; 1813 | 1814 | procedure GenerateShortCircuitEpilog; 1815 | begin 1816 | GenPopReg(EAX); // pop eax 1817 | GenerateIfElseEpilog; 1818 | GenPushReg(EAX); // push eax 1819 | end; 1820 | 1821 | procedure GenerateNestedProcsProlog; 1822 | begin 1823 | GenerateIfProlog; 1824 | end; 1825 | 1826 | procedure GenerateNestedProcsEpilog; 1827 | begin 1828 | GenerateIfElseEpilog; 1829 | end; 1830 | 1831 | procedure GenerateFPUInit; 1832 | begin 1833 | GenNew($DB); Gen($E3); // fninit 1834 | end; 1835 | 1836 | procedure GenerateStackFrameProlog(PreserveRegs: Boolean); 1837 | begin 1838 | GenPushReg(EBP); // push ebp 1839 | GenNew($8B); Gen($EC); // mov ebp, esp 1840 | SaveCodePos; 1841 | GenNew($90); // nop ; actual stack storage size will be inserted here 1842 | GenNew($90); // nop 1843 | GenNew($90); // nop 1844 | GenNew($90); // nop 1845 | GenNew($90); // nop 1846 | GenNew($90); // nop 1847 | if PreserveRegs then begin 1848 | GenPushReg(ESI); // push esi 1849 | GenPushReg(EDI); // push edi 1850 | end; 1851 | end; 1852 | 1853 | procedure GenerateStackFrameEpilog(TotalStackStorageSize: Longint; PreserveRegs: Boolean); 1854 | var 1855 | CodePos: Integer; 1856 | begin 1857 | CodePos := RestoreCodePos; 1858 | GenAt(CodePos, $81); GenAt(CodePos + 1, $EC); GenDWordAt(CodePos + 2, TotalStackStorageSize); // sub esp, TotalStackStorageSize 1859 | if PreserveRegs then begin 1860 | GenPopReg(EDI); // pop edi 1861 | GenPopReg(ESI); // pop esi 1862 | end; 1863 | GenNew($8B); Gen($E5); // mov esp, ebp 1864 | GenPopReg(EBP); // pop ebp 1865 | end; 1866 | 1867 | procedure GenerateBreakProlog(LoopNesting: Integer); 1868 | begin 1869 | BreakCall[LoopNesting].NumCalls := 0; 1870 | end; 1871 | 1872 | procedure GenerateBreakCall(LoopNesting: Integer); 1873 | begin 1874 | Inc(BreakCall[LoopNesting].NumCalls); 1875 | BreakCall[LoopNesting].Pos[BreakCall[LoopNesting].NumCalls] := GetCodeSize; 1876 | GenerateForwardReference; 1877 | end; 1878 | 1879 | procedure GenerateBreakEpilog(LoopNesting: Integer); 1880 | var 1881 | i: Integer; 1882 | begin 1883 | for i := 1 to BreakCall[LoopNesting].NumCalls do 1884 | GenerateForwardResolution(BreakCall[LoopNesting].Pos[i]); 1885 | end; 1886 | 1887 | procedure GenerateContinueProlog(LoopNesting: Integer); 1888 | begin 1889 | ContinueCall[LoopNesting].NumCalls := 0; 1890 | end; 1891 | 1892 | procedure GenerateContinueCall(LoopNesting: Integer); 1893 | begin 1894 | Inc(ContinueCall[LoopNesting].NumCalls); 1895 | ContinueCall[LoopNesting].Pos[ContinueCall[LoopNesting].NumCalls] := GetCodeSize; 1896 | GenerateForwardReference; 1897 | end; 1898 | 1899 | procedure GenerateContinueEpilog(LoopNesting: Integer); 1900 | var 1901 | i: Integer; 1902 | begin 1903 | for i := 1 to ContinueCall[LoopNesting].NumCalls do 1904 | GenerateForwardResolution(ContinueCall[LoopNesting].Pos[i]); 1905 | end; 1906 | 1907 | procedure GenerateExitProlog; 1908 | begin 1909 | ExitCall.NumCalls := 0; 1910 | end; 1911 | 1912 | procedure GenerateExitCall; 1913 | begin 1914 | DiscardStackTop(ForLoopNesting); // Remove the remaining numbers of iterations of all nested FOR loops 1915 | Inc(ExitCall.NumCalls); 1916 | ExitCall.Pos[ExitCall.NumCalls] := GetCodeSize; 1917 | GenerateForwardReference; 1918 | end; 1919 | 1920 | procedure GenerateExitEpilog; 1921 | var 1922 | i: Integer; 1923 | begin 1924 | for i := 1 to ExitCall.NumCalls do 1925 | GenerateForwardResolution(ExitCall.Pos[i]); 1926 | end; 1927 | 1928 | end. 1929 | -------------------------------------------------------------------------------- /Common.pas: -------------------------------------------------------------------------------- 1 | // Based on XD Pascal (2020) original code by Vasiliy Tereshkov 2 | // Refactoring and extensions by Wanderlan 3 | {$I-,H-} 4 | unit Common; 5 | 6 | interface 7 | 8 | const 9 | VERSION = '2023.07.06'; 10 | TARGET = 'x86-win32'; 11 | POINTER_SIZE = 4; 12 | NUMKEYWORDS = 43; 13 | MAXSTRLENGTH = 255; 14 | MAXSETELEMENTS = 256; 15 | MAXENUMELEMENTS = 256; 16 | MAXIDENTS = 2000; 17 | MAXTYPES = 2000; 18 | MAXUNITS = 100; 19 | MAXFOLDERS = 10; 20 | MAXBLOCKNESTING = 10; 21 | MAXPARAMS = 30; 22 | MAXFIELDS = 100; 23 | MAXWITHNESTING = 20; 24 | MAXINITIALIZEDDATASIZE = 1 * 1024 * 1024; 25 | MAXUNINITIALIZEDDATASIZE = 1024 * 1024 * 1024; 26 | MAXSTACKSIZE = 16 * 1024 * 1024; 27 | 28 | type // Eliminar alias 29 | TCharacter = Char; 30 | PCharacter = PChar; 31 | TString = String; 32 | TShortString = String; 33 | TGenericString = String; 34 | PLongInt = ^Longint; 35 | TInFile = file; 36 | TOutFile = file; 37 | TTokenKind = (EMPTYTOK, 38 | // Delimiters 39 | OPARTOK, CPARTOK, MULTOK, PLUSTOK, COMMATOK, MINUSTOK, PERIODTOK, RANGETOK, DIVTOK, COLONTOK, ASSIGNTOK, 40 | SEMICOLONTOK, LTTOK, LETOK, NETOK, EQTOK, GTTOK, GETOK, ADDRESSTOK, OBRACKETTOK, CBRACKETTOK, DEREFERENCETOK, 41 | // Keywords 42 | ANDTOK, ARRAYTOK, BEGINTOK, CASETOK, CONSTTOK, IDIVTOK, DOTOK, DOWNTOTOK, ELSETOK, ENDTOK, FILETOK, FORTOK, FUNCTIONTOK, GOTOTOK, IFTOK, IMPLEMENTATIONTOK, INTOK, 43 | INTERFACETOK, LABELTOK, MODTOK, NILTOK, NOTTOK, OFTOK, ORTOK, PACKEDTOK, PROCEDURETOK, PROGRAMTOK, RECORDTOK, REPEATTOK, SETTOK, SHLTOK, SHRTOK, STRINGTOK, THENTOK, 44 | TOTOK, TYPETOK, UNITTOK, UNTILTOK, USESTOK, VARTOK, WHILETOK, WITHTOK, XORTOK, 45 | // User tokens 46 | IDENTTOK, INTNUMBERTOK, REALNUMBERTOK, CHARLITERALTOK, STRINGLITERALTOK); 47 | 48 | TToken = record 49 | Name: TString; 50 | case Kind: TTokenKind of 51 | IDENTTOK: (NonUppercaseName: TShortString); 52 | INTNUMBERTOK: (OrdValue: Longint); // For all ordinal types 53 | REALNUMBERTOK: (RealValue: Double); 54 | STRINGLITERALTOK: (StrAddress: Integer; 55 | StrLength: Integer); 56 | end; 57 | TTypeKind = (EMPTYTYPE, ANYTYPE, INTEGERTYPE, SMALLINTTYPE, SHORTINTTYPE, WORDTYPE, BYTETYPE, CHARTYPE, BOOLEANTYPE, REALTYPE, SINGLETYPE, 58 | POINTERTYPE, FILETYPE, ARRAYTYPE, RECORDTYPE, INTERFACETYPE, SETTYPE, ENUMERATEDTYPE, SUBRANGETYPE, PROCEDURALTYPE, METHODTYPE, FORWARDTYPE); 59 | 60 | const 61 | // Predefined type indices 62 | ANYTYPEINDEX = 1; // Untyped parameter, or base type for untyped pointers and files 63 | INTEGERTYPEINDEX = 2; 64 | SMALLINTTYPEINDEX = 3; 65 | SHORTINTTYPEINDEX = 4; 66 | WORDTYPEINDEX = 5; 67 | BYTETYPEINDEX = 6; 68 | CHARTYPEINDEX = 7; 69 | BOOLEANTYPEINDEX = 8; 70 | REALTYPEINDEX = 9; // Basic real type: 64-bit double (all temporary real results are of this type) 71 | SINGLETYPEINDEX = 10; 72 | POINTERTYPEINDEX = 11; // Untyped pointer, compatible with any other pointers 73 | FILETYPEINDEX = 12; // Untyped file, compatible with text files 74 | STRINGTYPEINDEX = 13; // String of maximum allowed length 75 | 76 | type 77 | TByteSet = set of Byte; 78 | TConst = packed record 79 | case Kind: TTypeKind of 80 | INTEGERTYPE: (OrdValue: Longint); // For all ordinal types 81 | REALTYPE: (RealValue: Double); 82 | SINGLETYPE: (SingleValue: Single); 83 | ARRAYTYPE: (StrValue: TShortString); 84 | SETTYPE: (SetValue: TByteSet); // For all set types 85 | end; 86 | TPassMethod = (EMPTYPASSING, VALPASSING, CONSTPASSING, VARPASSING); 87 | 88 | TParam = record 89 | Name: TString; 90 | DataType: Integer; 91 | PassMethod: TPassMethod; 92 | Default: TConst; 93 | end; 94 | PParam = ^TParam; 95 | 96 | PParams = array [1..MAXPARAMS] of PParam; 97 | TIdentKind = (EMPTYIDENT, GOTOLABEL, CONSTANT, USERTYPE, VARIABLE, PROC, FUNC); 98 | TScope = (EMPTYSCOPE, GLOBAL, LOCAL); 99 | TRelocType = (EMPTYRELOC, CODERELOC, INITDATARELOC, UNINITDATARELOC, IMPORTRELOC); 100 | TCallConv = (DEFAULTCONV, STDCALLCONV, CDECLCONV); 101 | TPredefProc = (EMPTYPROC, 102 | // Procedures 103 | INCPROC, DECPROC, READPROC, WRITEPROC, READLNPROC, WRITELNPROC, NEWPROC, DISPOSEPROC, BREAKPROC, CONTINUEPROC, EXITPROC, HALTPROC, 104 | // Functions 105 | SIZEOFFUNC, ORDFUNC, CHRFUNC, LOWFUNC, HIGHFUNC, PREDFUNC, SUCCFUNC, ROUNDFUNC, TRUNCFUNC, ABSFUNC, SQRFUNC, SINFUNC, COSFUNC, ARCTANFUNC, EXPFUNC, LNFUNC, SQRTFUNC); 106 | 107 | TSignature = record 108 | NumParams: Integer; 109 | NumDefaultParams: Integer; 110 | Param: PParams; 111 | ResultType: Integer; 112 | CallConv: TCallConv; 113 | end; 114 | 115 | TIdentifier = record 116 | Kind: TIdentKind; 117 | Name: TString; 118 | DataType: Integer; 119 | Address: Longint; 120 | ConstVal: TConst; 121 | UnitIndex: Integer; 122 | Block: Integer; // Index of a block in which the identifier is defined 123 | NestingLevel: Byte; 124 | ReceiverName: TString; // Receiver variable name for a method 125 | ReceiverType: Integer; // Receiver type for a method 126 | Scope: TScope; 127 | RelocType: TRelocType; 128 | PassMethod: TPassMethod; // Value, CONST or VAR parameter status 129 | Signature: TSignature; 130 | ResultIdentIndex: Integer; 131 | ProcAsBlock: Integer; 132 | PredefProc: TPredefProc; 133 | IsUsed: Boolean; 134 | IsUnresolvedForward: Boolean; 135 | IsExported: Boolean; 136 | IsTypedConst: Boolean; 137 | IsInCStack: Boolean; 138 | ForLoopNesting: Integer; // Number of nested FOR loops where the label is defined 139 | end; 140 | 141 | TField = record 142 | Name: TString; 143 | DataType: Integer; 144 | Offset: Integer; 145 | end; 146 | PField = ^TField; 147 | 148 | TType = record 149 | Block: Integer; 150 | BaseType: Integer; 151 | AliasType: Integer; 152 | case Kind: TTypeKind of 153 | SUBRANGETYPE: (Low, High: Integer); 154 | ARRAYTYPE: (IndexType: Integer; IsOpenArray: Boolean); 155 | RECORDTYPE, 156 | INTERFACETYPE: (NumFields: Integer; Field: array [1..MAXFIELDS] of PField); 157 | PROCEDURALTYPE: (Signature: TSignature; SelfPointerOffset: Longint); // For interface method variables as temporary results 158 | METHODTYPE: (MethodIdentIndex: Integer); // For static methods as temporary results 159 | FORWARDTYPE: (TypeIdentName: TShortString); 160 | end; 161 | 162 | TBlock = record 163 | Index: Integer; 164 | LocalDataSize, ParamDataSize, TempDataSize: Longint; 165 | end; 166 | 167 | TUnit = record 168 | Name: TString; 169 | end; 170 | 171 | TUnitStatus = record 172 | Index: Integer; 173 | UsedUnits: set of Byte; 174 | end; 175 | 176 | TWithDesignator = record 177 | TempPointer: Integer; 178 | DataType: Integer; 179 | IsConst: Boolean; 180 | end; 181 | TWriteProc = procedure(ClassInstance: Pointer; const Msg: TString); 182 | 183 | const 184 | // Operator sets 185 | MultiplicativeOperators = [MULTOK, DIVTOK, IDIVTOK, MODTOK, SHLTOK, SHRTOK, ANDTOK]; 186 | AdditiveOperators = [PLUSTOK, MINUSTOK, ORTOK, XORTOK]; 187 | UnaryOperators = [PLUSTOK, MINUSTOK]; 188 | RelationOperators = [EQTOK, NETOK, LTTOK, LETOK, GTTOK, GETOK]; 189 | OperatorsForIntegers = MultiplicativeOperators - [DIVTOK] + AdditiveOperators + RelationOperators + [NOTTOK]; 190 | OperatorsForReals = [MULTOK, DIVTOK, PLUSTOK, MINUSTOK] + RelationOperators; 191 | OperatorsForBooleans = [ANDTOK, ORTOK, XORTOK, NOTTOK] + RelationOperators; 192 | // Type sets 193 | IntegerTypes = [INTEGERTYPE, SMALLINTTYPE, SHORTINTTYPE, WORDTYPE, BYTETYPE]; 194 | OrdinalTypes = IntegerTypes + [CHARTYPE, BOOLEANTYPE, SUBRANGETYPE, ENUMERATEDTYPE]; 195 | UnsignedTypes = [WORDTYPE, BYTETYPE, CHARTYPE]; 196 | NumericTypes = IntegerTypes + [REALTYPE]; 197 | StructuredTypes = [ARRAYTYPE, RECORDTYPE, INTERFACETYPE, SETTYPE, FILETYPE]; 198 | CastableTypes = OrdinalTypes + [POINTERTYPE, PROCEDURALTYPE]; 199 | 200 | var 201 | Ident: array [1..MAXIDENTS] of TIdentifier; 202 | Types: array [1..MAXTYPES] of TType; 203 | InitializedGlobalData: array [0..MAXINITIALIZEDDATASIZE - 1] of Byte; 204 | Units: array [1..MAXUNITS] of TUnit; 205 | Folders: array [1..MAXFOLDERS] of TString; 206 | BlockStack: array [1..MAXBLOCKNESTING] of TBlock; 207 | WithStack: array [1..MAXWITHNESTING] of TWithDesignator; 208 | NumIdent, NumTypes, NumUnits, NumFolders, NumBlocks, BlockStackTop, ForLoopNesting, WithNesting, InitializedGlobalDataSize, UninitializedGlobalDataSize: Integer; 209 | IsConsoleProgram: Boolean; 210 | 211 | procedure InitializeCommon; 212 | procedure FinalizeCommon; 213 | procedure CopyParams(var LeftSignature, RightSignature: TSignature); 214 | procedure DisposeParams(var Signature: TSignature); 215 | procedure DisposeFields(var DataType: TType); 216 | function GetTokSpelling(TokKind: TTokenKind): TString; 217 | function GetTypeSpelling(DataType: Integer): TString; 218 | function Align(Size, Alignment: Integer): Integer; 219 | procedure SetWriteProcs(ClassInstance: Pointer; NewNoticeProc, NewWarningProc, NewErrorProc: TWriteProc); 220 | procedure Notice(const Msg: TString); 221 | procedure Warning(const Msg: TString); 222 | procedure Error(const Msg: TString); 223 | procedure DefineStaticString(const StrValue: TString; var Addr: Longint; FixedAddr: Longint = -1); 224 | procedure DefineStaticSet(const SetValue: TByteSet; var Addr: Longint; FixedAddr: Longint = -1); 225 | function IsString(DataType: Integer): Boolean; 226 | function LowBound(DataType: Integer): Integer; 227 | function HighBound(DataType: Integer): Integer; 228 | function TypeSize(DataType: Integer): Integer; 229 | function GetTotalParamSize(const Signature: TSignature; IsMethod, AlwaysTreatStructuresAsReferences: Boolean): Integer; 230 | function GetCompatibleType(LeftType, RightType: Integer): Integer; 231 | function GetCompatibleRefType(LeftType, RightType: Integer): Integer; 232 | procedure CheckOperator(const Tok: TToken; DataType: Integer); 233 | procedure CheckSignatures(var Signature1, Signature2: TSignature; const Name: TString; CheckParamNames: Boolean = True); 234 | procedure SetUnitStatus(var NewUnitStatus: TUnitStatus); 235 | function GetUnitUnsafe(const UnitName: TString): Integer; 236 | function GetUnit(const UnitName: TString): Integer; 237 | function GetKeyword(const KeywordName: TString): TTokenKind; 238 | function GetIdentUnsafe(const IdentName: TString; AllowForwardReference: Boolean = False; RecType: Integer = 0): Integer; 239 | function GetIdent(const IdentName: TString; AllowForwardReference: Boolean = False; RecType: Integer = 0): Integer; 240 | function GetFieldUnsafe(RecType: Integer; const FieldName: TString): Integer; 241 | function GetField(RecType: Integer; const FieldName: TString): Integer; 242 | function GetFieldInsideWith(var RecPointer: Integer; var RecType: Integer; var IsConst: Boolean; const FieldName: TString): Integer; 243 | function GetMethodUnsafe(RecType: Integer; const MethodName: TString): Integer; 244 | function GetMethod(RecType: Integer; const MethodName: TString): Integer; 245 | function GetMethodInsideWith(var RecPointer: Integer; var RecType: Integer; var IsConst: Boolean; const MethodName: TString): Integer; 246 | function FieldOrMethodInsideWithFound(const Name: TString): Boolean; 247 | 248 | implementation 249 | 250 | const 251 | Keyword: array [1..NUMKEYWORDS] of TString = ( 252 | 'AND', 'ARRAY', 'BEGIN', 'CASE', 'CONST', 'DIV', 'DO', 'DOWNTO', 'ELSE', 'END', 'FILE', 'FOR', 'FUNCTION', 'GOTO', 'IF', 'IMPLEMENTATION', 'IN', 'INTERFACE', 'LABEL', 253 | 'MOD', 'NIL', 'NOT', 'OF', 'OR', 'PACKED', 'PROCEDURE', 'PROGRAM', 'RECORD', 'REPEAT', 'SET', 'SHL', 'SHR', 'STRING', 'THEN', 'TO', 'TYPE', 'UNIT', 'UNTIL', 'USES', 254 | 'VAR', 'WHILE', 'WITH', 'XOR'); 255 | 256 | var 257 | NoticeProc, WarningProc, ErrorProc: TWriteProc; 258 | WriteProcsClassInstance: Pointer; 259 | UnitStatus: TUnitStatus; 260 | 261 | procedure InitializeCommon; 262 | begin 263 | FillChar(Ident, SizeOf(Ident), #0); 264 | FillChar(Types, SizeOf(Types), #0); 265 | FillChar(Units, SizeOf(Units), #0); 266 | FillChar(InitializedGlobalData, SizeOf(InitializedGlobalData), #0); 267 | NumIdent := 0; 268 | NumTypes := 0; 269 | NumUnits := 0; 270 | NumFolders := 0; 271 | NumBlocks := 0; 272 | BlockStackTop := 0; 273 | ForLoopNesting := 0; 274 | WithNesting := 0; 275 | InitializedGlobalDataSize := 0; 276 | UninitializedGlobalDataSize := 0; 277 | IsConsoleProgram := True; // Console program by default 278 | end; 279 | 280 | procedure FinalizeCommon; 281 | var 282 | i: Integer; 283 | begin 284 | // Dispose of dynamically allocated parameter data 285 | for i := 1 to NumIdent do 286 | if (Ident[i].Kind = PROC) or (Ident[i].Kind = FUNC) then 287 | DisposeParams(Ident[i].Signature); 288 | // Dispose of dynamically allocated parameter and field data 289 | for i := 1 to NumTypes do 290 | if Types[i].Kind = PROCEDURALTYPE then 291 | DisposeParams(Types[i].Signature) 292 | else 293 | if Types[i].Kind in [RECORDTYPE, INTERFACETYPE] then 294 | DisposeFields(Types[i]); 295 | end; 296 | 297 | procedure CopyParams(var LeftSignature, RightSignature: TSignature); 298 | var 299 | i: Integer; 300 | begin 301 | for i := 1 to RightSignature.NumParams do begin 302 | New(LeftSignature.Param[i]); 303 | LeftSignature.Param[i]^ := RightSignature.Param[i]^; 304 | end; 305 | end; 306 | 307 | procedure DisposeParams(var Signature: TSignature); 308 | var 309 | i: Integer; 310 | begin 311 | for i := 1 to Signature.NumParams do 312 | Dispose(Signature.Param[i]); 313 | end; 314 | 315 | procedure DisposeFields(var DataType: TType); 316 | var 317 | i: Integer; 318 | begin 319 | for i := 1 to DataType.NumFields do 320 | Dispose(DataType.Field[i]); 321 | end; 322 | 323 | function GetTokSpelling(TokKind: TTokenKind): TString; 324 | begin 325 | case TokKind of 326 | EMPTYTOK: Result := 'no token'; 327 | OPARTOK: Result := '('; 328 | CPARTOK: Result := ')'; 329 | MULTOK: Result := '*'; 330 | PLUSTOK: Result := '+'; 331 | COMMATOK: Result := ','; 332 | MINUSTOK: Result := '-'; 333 | PERIODTOK: Result := '.'; 334 | RANGETOK: Result := '..'; 335 | DIVTOK: Result := '/'; 336 | COLONTOK: Result := ':'; 337 | ASSIGNTOK: Result := ':='; 338 | SEMICOLONTOK: Result := ';'; 339 | LTTOK: Result := '<'; 340 | LETOK: Result := '<='; 341 | NETOK: Result := '<>'; 342 | EQTOK: Result := '='; 343 | GTTOK: Result := '>'; 344 | GETOK: Result := '>='; 345 | ADDRESSTOK: Result := '@'; 346 | OBRACKETTOK: Result := '['; 347 | CBRACKETTOK: Result := ']'; 348 | DEREFERENCETOK: Result := '^'; 349 | ANDTOK..XORTOK: Result := Keyword[Ord(TokKind) - Ord(ANDTOK) + 1]; 350 | IDENTTOK: Result := 'identifier'; 351 | INTNUMBERTOK, REALNUMBERTOK: Result := 'number'; 352 | CHARLITERALTOK: Result := 'character literal'; 353 | STRINGLITERALTOK: Result := 'string literal' 354 | else Result := 'unknown token'; 355 | end; 356 | end; 357 | 358 | function GetTypeSpelling(DataType: Integer): TString; 359 | begin 360 | case Types[DataType].Kind of 361 | EMPTYTYPE: Result := 'no type'; 362 | ANYTYPE: Result := 'any type'; 363 | INTEGERTYPE: Result := 'integer'; 364 | SMALLINTTYPE: Result := 'small integer'; 365 | SHORTINTTYPE: Result := 'short integer'; 366 | WORDTYPE: Result := 'word'; 367 | BYTETYPE: Result := 'byte'; 368 | CHARTYPE: Result := 'character'; 369 | BOOLEANTYPE: Result := 'Boolean'; 370 | REALTYPE: Result := 'real'; 371 | SINGLETYPE: Result := 'single-precision real'; 372 | POINTERTYPE: begin 373 | Result := 'pointer'; 374 | if Types[Types[DataType].BaseType].Kind <> ANYTYPE then 375 | Result := Result + ' to ' + GetTypeSpelling(Types[DataType].BaseType); 376 | end; 377 | FILETYPE: begin 378 | Result := 'file'; 379 | if Types[Types[DataType].BaseType].Kind <> ANYTYPE then 380 | Result := Result + ' of ' + GetTypeSpelling(Types[DataType].BaseType); 381 | end; 382 | ARRAYTYPE: Result := 'array of ' + GetTypeSpelling(Types[DataType].BaseType); 383 | RECORDTYPE: Result := 'record'; 384 | INTERFACETYPE: Result := 'interface'; 385 | SETTYPE: Result := 'set of ' + GetTypeSpelling(Types[DataType].BaseType); 386 | ENUMERATEDTYPE: Result := 'enumeration'; 387 | SUBRANGETYPE: Result := 'subrange of ' + GetTypeSpelling(Types[DataType].BaseType); 388 | PROCEDURALTYPE: Result := 'procedural type'; 389 | else Result := 'unknown type'; 390 | end; 391 | end; 392 | 393 | function Align(Size, Alignment: Integer): Integer; 394 | begin 395 | Result := ((Size + (Alignment - 1)) div Alignment) * Alignment; 396 | end; 397 | 398 | procedure SetWriteProcs(ClassInstance: Pointer; NewNoticeProc, NewWarningProc, NewErrorProc: TWriteProc); 399 | begin 400 | WriteProcsClassInstance := ClassInstance; 401 | NoticeProc := NewNoticeProc; 402 | WarningProc := NewWarningProc; 403 | ErrorProc := NewErrorProc; 404 | end; 405 | 406 | procedure Notice(const Msg: TString); 407 | begin 408 | NoticeProc(WriteProcsClassInstance, Msg); 409 | end; 410 | 411 | procedure Warning(const Msg: TString); 412 | begin 413 | WarningProc(WriteProcsClassInstance, Msg); 414 | end; 415 | 416 | procedure Error(const Msg: TString); 417 | begin 418 | ErrorProc(WriteProcsClassInstance, Msg); 419 | end; 420 | 421 | procedure DefineStaticString(const StrValue: TString; var Addr: Longint; FixedAddr: Longint = -1); 422 | var 423 | Len: Integer; 424 | begin 425 | Len := Length(StrValue); 426 | if FixedAddr <> -1 then 427 | Addr := FixedAddr 428 | else begin 429 | if Len + 1 > MAXINITIALIZEDDATASIZE - InitializedGlobalDataSize then 430 | Error('Not enough memory for static string'); 431 | Addr := InitializedGlobalDataSize; // Relocatable 432 | InitializedGlobalDataSize := InitializedGlobalDataSize + Len + 1; 433 | end; 434 | Move(StrValue[1], InitializedGlobalData[Addr], Len); 435 | InitializedGlobalData[Addr + Len] := 0; // Add string termination character 436 | end; 437 | 438 | procedure DefineStaticSet(const SetValue: TByteSet; var Addr: Longint; FixedAddr: Longint = -1); 439 | var 440 | i: Integer; 441 | ElementPtr: ^Byte; 442 | begin 443 | if FixedAddr <> -1 then 444 | Addr := FixedAddr 445 | else begin 446 | if MAXSETELEMENTS div 8 > MAXINITIALIZEDDATASIZE - InitializedGlobalDataSize then 447 | Error('Not enough memory for static set'); 448 | Addr := InitializedGlobalDataSize; 449 | InitializedGlobalDataSize := InitializedGlobalDataSize + MAXSETELEMENTS div 8; 450 | end; 451 | for i := 0 to MAXSETELEMENTS - 1 do 452 | if i in SetValue then begin 453 | ElementPtr := @InitializedGlobalData[Addr + i shr 3]; 454 | ElementPtr^ := ElementPtr^ or (1 shl (i and 7)); 455 | end; 456 | end; 457 | 458 | function IsString(DataType: Integer): Boolean; 459 | begin 460 | Result := (Types[DataType].Kind = ARRAYTYPE) and (Types[Types[DataType].BaseType].Kind = CHARTYPE); 461 | end; 462 | 463 | function LowBound(DataType: Integer): Integer; 464 | begin 465 | Result := 0; 466 | case Types[DataType].Kind of 467 | INTEGERTYPE: Result := -2147483647 - 1; 468 | SMALLINTTYPE: Result := -32768; 469 | SHORTINTTYPE: Result := -128; 470 | WORDTYPE: Result := 0; 471 | BYTETYPE: Result := 0; 472 | CHARTYPE: Result := 0; 473 | BOOLEANTYPE: Result := 0; 474 | SUBRANGETYPE: Result := Types[DataType].Low; 475 | ENUMERATEDTYPE: Result := Types[DataType].Low 476 | else Error('Ordinal type expected') 477 | end; 478 | end; 479 | 480 | function HighBound(DataType: Integer): Integer; 481 | begin 482 | Result := 0; 483 | case Types[DataType].Kind of 484 | INTEGERTYPE: Result := 2147483647; 485 | SMALLINTTYPE: Result := 32767; 486 | SHORTINTTYPE: Result := 127; 487 | WORDTYPE: Result := 65535; 488 | BYTETYPE: Result := 255; 489 | CHARTYPE: Result := 255; 490 | BOOLEANTYPE: Result := 1; 491 | SUBRANGETYPE: Result := Types[DataType].High; 492 | ENUMERATEDTYPE: Result := Types[DataType].High 493 | else Error('Ordinal type expected') 494 | end; 495 | end; 496 | 497 | function TypeSize(DataType: Integer): Integer; 498 | var 499 | CurSize, BaseTypeSize, FieldTypeSize: Integer; 500 | NumElements, FieldOffset, i: Integer; 501 | begin 502 | Result := 0; 503 | case Types[DataType].Kind of 504 | INTEGERTYPE: Result := SizeOf(Integer); 505 | SMALLINTTYPE: Result := SizeOf(Smallint); 506 | SHORTINTTYPE: Result := SizeOf(Shortint); 507 | WORDTYPE: Result := SizeOf(Word); 508 | BYTETYPE: Result := SizeOf(Byte); 509 | CHARTYPE: Result := SizeOf(TCharacter); 510 | BOOLEANTYPE: Result := SizeOf(Boolean); 511 | REALTYPE: Result := SizeOf(Double); 512 | SINGLETYPE: Result := SizeOf(Single); 513 | POINTERTYPE: Result := POINTER_SIZE; 514 | FILETYPE: Result := SizeOf(TString) + SizeOf(Integer); // Name + Handle 515 | SUBRANGETYPE: Result := TypeSize(Types[DataType].BaseType); 516 | ARRAYTYPE: begin 517 | if Types[DataType].IsOpenArray then 518 | Error('Illegal type'); 519 | NumElements := HighBound(Types[DataType].IndexType) - LowBound(Types[DataType].IndexType) + 1; 520 | BaseTypeSize := TypeSize(Types[DataType].BaseType); 521 | if (NumElements > 0) and (BaseTypeSize > HighBound(INTEGERTYPEINDEX) div NumElements) then 522 | Error('Type size is too large'); 523 | Result := NumElements * BaseTypeSize; 524 | end; 525 | RECORDTYPE, INTERFACETYPE: for i := 1 to Types[DataType].NumFields do begin 526 | FieldOffset := Types[DataType].Field[i]^.Offset; 527 | FieldTypeSize := TypeSize(Types[DataType].Field[i]^.DataType); 528 | if FieldTypeSize > HighBound(INTEGERTYPEINDEX) - FieldOffset then 529 | Error('Type size is too large'); 530 | CurSize := FieldOffset + FieldTypeSize; 531 | if CurSize > Result then 532 | Result := CurSize; 533 | end; 534 | SETTYPE: Result := MAXSETELEMENTS div 8; 535 | ENUMERATEDTYPE: Result := SizeOf(Byte); 536 | PROCEDURALTYPE: Result := POINTER_SIZE 537 | else Error('Illegal type') 538 | end; 539 | end; 540 | 541 | function GetTotalParamSize(const Signature: TSignature; IsMethod, AlwaysTreatStructuresAsReferences: Boolean): Integer; 542 | var 543 | i: Integer; 544 | begin 545 | if (Signature.CallConv <> DEFAULTCONV) and IsMethod then 546 | Error('Internal fault: Methods cannot be STDCALL/CDECL'); 547 | Result := 0; 548 | // For a method, Self is a first (hidden) VAR parameter 549 | if IsMethod then 550 | Result := Result + SizeOf(Longint); 551 | // Allocate space for structured Result as a hidden VAR parameter (except STDCALL/CDECL functions returning small structures in EDX:EAX) 552 | with Signature do 553 | if (ResultType <> 0) and (Types[ResultType].Kind in StructuredTypes) and ((CallConv = DEFAULTCONV) or (TypeSize(ResultType) > 2 * SizeOf(Longint))) then 554 | Result := Result + SizeOf(Longint); 555 | // Any parameter occupies 4 bytes (except structures in the C stack) 556 | if (Signature.CallConv <> DEFAULTCONV) and not AlwaysTreatStructuresAsReferences then 557 | for i := 1 to Signature.NumParams do 558 | if Signature.Param[i]^.PassMethod = VALPASSING then 559 | Result := Result + Align(TypeSize(Signature.Param[i]^.DataType), SizeOf(Longint)) 560 | else 561 | Result := Result + SizeOf(Longint) 562 | else 563 | for i := 1 to Signature.NumParams do 564 | if (Signature.Param[i]^.PassMethod = VALPASSING) and (Types[Signature.Param[i]^.DataType].Kind = REALTYPE) then 565 | Result := Result + SizeOf(Double) 566 | else 567 | Result := Result + SizeOf(Longint); 568 | end; 569 | 570 | function GetCompatibleType(LeftType, RightType: Integer): Integer; 571 | begin 572 | Result := 0; 573 | // General rule 574 | if LeftType = RightType then 575 | Result := LeftType 576 | // Special cases 577 | // All types are compatible with their aliases 578 | else 579 | if Types[LeftType].AliasType <> 0 then 580 | Result := GetCompatibleType(Types[LeftType].AliasType, RightType) 581 | else 582 | if Types[RightType].AliasType <> 0 then 583 | Result := GetCompatibleType(LeftType, Types[RightType].AliasType) 584 | // Sets are compatible with other sets having a compatible base type, or with an empty set constructor 585 | else 586 | if (Types[LeftType].Kind = SETTYPE) and (Types[RightType].Kind = SETTYPE) then begin 587 | if Types[RightType].BaseType = ANYTYPEINDEX then 588 | Result := LeftType 589 | else 590 | if Types[LeftType].BaseType = ANYTYPEINDEX then 591 | Result := RightType 592 | else begin 593 | GetCompatibleType(Types[LeftType].BaseType, Types[RightType].BaseType); 594 | Result := LeftType; 595 | end; 596 | end 597 | // Strings are compatible with any other strings 598 | else 599 | if IsString(LeftType) and IsString(RightType) then 600 | Result := LeftType 601 | // Untyped pointers are compatible with any pointers or procedural types 602 | else 603 | if (Types[LeftType].Kind = POINTERTYPE) and (Types[LeftType].BaseType = ANYTYPEINDEX) and (Types[RightType].Kind in [POINTERTYPE, PROCEDURALTYPE]) then 604 | Result := LeftType 605 | else 606 | if (Types[RightType].Kind = POINTERTYPE) and (Types[RightType].BaseType = ANYTYPEINDEX) and (Types[LeftType].Kind in [POINTERTYPE, PROCEDURALTYPE]) then 607 | Result := RightType 608 | // Typed pointers are compatible with any pointers to a reference-compatible type 609 | else 610 | if (Types[LeftType].Kind = POINTERTYPE) and (Types[RightType].Kind = POINTERTYPE) then 611 | Result := GetCompatibleRefType(Types[LeftType].BaseType, Types[RightType].BaseType) 612 | // Procedural types are compatible if their Self pointer offsets are equal and their signatures are compatible 613 | else 614 | if (Types[LeftType].Kind = PROCEDURALTYPE) and (Types[RightType].Kind = PROCEDURALTYPE) and (Types[LeftType].SelfPointerOffset = 615 | Types[RightType].SelfPointerOffset) then begin 616 | CheckSignatures(Types[LeftType].Signature, Types[RightType].Signature, 'procedural variable', False); 617 | Result := LeftType; 618 | end 619 | // Subranges are compatible with their host types 620 | else 621 | if Types[LeftType].Kind = SUBRANGETYPE then 622 | Result := GetCompatibleType(Types[LeftType].BaseType, RightType) 623 | else 624 | if Types[RightType].Kind = SUBRANGETYPE then 625 | Result := GetCompatibleType(LeftType, Types[RightType].BaseType) 626 | // Integers 627 | else 628 | if (Types[LeftType].Kind in IntegerTypes) and (Types[RightType].Kind in IntegerTypes) then 629 | Result := LeftType 630 | // Booleans 631 | else 632 | if (Types[LeftType].Kind = BOOLEANTYPE) and (Types[RightType].Kind = BOOLEANTYPE) then 633 | Result := LeftType 634 | // Characters 635 | else 636 | if (Types[LeftType].Kind = CHARTYPE) and (Types[RightType].Kind = CHARTYPE) then 637 | Result := LeftType; 638 | if Result = 0 then 639 | Error('Incompatible types: ' + GetTypeSpelling(LeftType) + ' and ' + GetTypeSpelling(RightType)); 640 | end; 641 | 642 | function GetCompatibleRefType(LeftType, RightType: Integer): Integer; 643 | begin 644 | // This function is asymmetric and implies Variable(LeftType) := Variable(RightType) 645 | Result := 0; 646 | // General rule 647 | if LeftType = RightType then 648 | Result := RightType 649 | // Special cases 650 | // All types are compatible with their aliases 651 | else 652 | if Types[LeftType].AliasType <> 0 then 653 | Result := GetCompatibleRefType(Types[LeftType].AliasType, RightType) 654 | else 655 | if Types[RightType].AliasType <> 0 then 656 | Result := GetCompatibleRefType(LeftType, Types[RightType].AliasType) 657 | // Open arrays are compatible with any other arrays of the same base type 658 | else 659 | if (Types[LeftType].Kind = ARRAYTYPE) and (Types[RightType].Kind = ARRAYTYPE) and Types[LeftType].IsOpenArray and 660 | (Types[LeftType].BaseType = Types[RightType].BaseType) then 661 | Result := RightType 662 | // Untyped pointers are compatible with any other pointers 663 | else 664 | if (Types[LeftType].Kind = POINTERTYPE) and (Types[RightType].Kind = POINTERTYPE) and ((Types[LeftType].BaseType = Types[RightType].BaseType) or 665 | (Types[LeftType].BaseType = ANYTYPEINDEX)) then 666 | Result := RightType 667 | // Untyped files are compatible with any other files 668 | else 669 | if (Types[LeftType].Kind = FILETYPE) and (Types[RightType].Kind = FILETYPE) and (Types[LeftType].BaseType = ANYTYPEINDEX) then 670 | Result := RightType 671 | // Untyped parameters are compatible with any type 672 | else 673 | if Types[LeftType].Kind = ANYTYPE then 674 | Result := RightType; 675 | if Result = 0 then 676 | Error('Incompatible types: ' + GetTypeSpelling(LeftType) + ' and ' + GetTypeSpelling(RightType)); 677 | end; 678 | 679 | procedure CheckOperator(const Tok: TToken; DataType: Integer); 680 | begin 681 | with Types[DataType] do 682 | if Kind = SUBRANGETYPE then 683 | CheckOperator(Tok, BaseType) 684 | else begin 685 | if not (Kind in OrdinalTypes) and (Kind <> REALTYPE) and (Kind <> POINTERTYPE) and (Kind <> PROCEDURALTYPE) then 686 | Error('Operator ' + GetTokSpelling(Tok.Kind) + ' is not applicable to ' + GetTypeSpelling(DataType)); 687 | if ((Kind in IntegerTypes) and not (Tok.Kind in OperatorsForIntegers)) or ((Kind = REALTYPE) and not (Tok.Kind in OperatorsForReals)) or 688 | ((Kind = CHARTYPE) and not (Tok.Kind in RelationOperators)) or ((Kind = BOOLEANTYPE) and not (Tok.Kind in OperatorsForBooleans)) or 689 | ((Kind = POINTERTYPE) and not (Tok.Kind in RelationOperators)) or ((Kind = ENUMERATEDTYPE) and not (Tok.Kind in RelationOperators)) or 690 | ((Kind = PROCEDURALTYPE) and not (Tok.Kind in RelationOperators)) then 691 | Error('Operator ' + GetTokSpelling(Tok.Kind) + ' is not applicable to ' + GetTypeSpelling(DataType)); 692 | end; 693 | end; 694 | 695 | procedure CheckSignatures(var Signature1, Signature2: TSignature; const Name: TString; CheckParamNames: Boolean = True); 696 | var 697 | i: Integer; 698 | begin 699 | if Signature1.NumParams <> Signature2.NumParams then 700 | Error('Incompatible number of parameters in ' + Name); 701 | if Signature1.NumDefaultParams <> Signature2.NumDefaultParams then 702 | Error('Incompatible number of default parameters in ' + Name); 703 | for i := 1 to Signature1.NumParams do begin 704 | if (Signature1.Param[i]^.Name <> Signature2.Param[i]^.Name) and CheckParamNames then 705 | Error('Incompatible parameter names in ' + Name); 706 | if Signature1.Param[i]^.DataType <> Signature2.Param[i]^.DataType then 707 | if not Types[Signature1.Param[i]^.DataType].IsOpenArray or not Types[Signature2.Param[i]^.DataType].IsOpenArray or 708 | (Types[Signature1.Param[i]^.DataType].BaseType <> Types[Signature2.Param[i]^.DataType].BaseType) then 709 | Error('Incompatible parameter types in ' + Name + ': ' + GetTypeSpelling(Signature1.Param[i]^.DataType) + ' and ' + GetTypeSpelling(Signature2.Param[i]^.DataType)); 710 | if Signature1.Param[i]^.PassMethod <> Signature2.Param[i]^.PassMethod then 711 | Error('Incompatible CONST/VAR modifiers in ' + Name); 712 | if Signature1.Param[i]^.Default.OrdValue <> Signature2.Param[i]^.Default.OrdValue then 713 | Error('Incompatible default values in ' + Name); 714 | end; // if 715 | if Signature1.ResultType <> Signature2.ResultType then 716 | Error('Incompatible result types in ' + Name + ': ' + GetTypeSpelling(Signature1.ResultType) + ' and ' + GetTypeSpelling(Signature2.ResultType)); 717 | if Signature1.CallConv <> Signature2.CallConv then 718 | Error('Incompatible calling convention in ' + Name); 719 | end; 720 | 721 | procedure SetUnitStatus(var NewUnitStatus: TUnitStatus); 722 | begin 723 | UnitStatus := NewUnitStatus; 724 | end; 725 | 726 | function GetUnitUnsafe(const UnitName: TString): Integer; 727 | var 728 | UnitIndex: Integer; 729 | begin 730 | for UnitIndex := 1 to NumUnits do 731 | if Units[UnitIndex].Name = UnitName then begin 732 | Result := UnitIndex; 733 | Exit; 734 | end; 735 | Result := 0; 736 | end; 737 | 738 | function GetUnit(const UnitName: TString): Integer; 739 | begin 740 | Result := GetUnitUnsafe(UnitName); 741 | if Result = 0 then 742 | Error('Unknown unit ' + UnitName); 743 | end; 744 | 745 | function GetKeyword(const KeywordName: TString): TTokenKind; 746 | var 747 | Max, Mid, Min: Integer; 748 | Found: Boolean; 749 | begin 750 | Result := EMPTYTOK; 751 | // Binary search 752 | Min := 1; 753 | Max := NUMKEYWORDS; 754 | repeat 755 | Mid := (Min + Max) div 2; 756 | if KeywordName > Keyword[Mid] then 757 | Min := Mid + 1 758 | else 759 | Max := Mid - 1; 760 | Found := KeywordName = Keyword[Mid]; 761 | until Found or (Min > Max); 762 | if Found then 763 | Result := TTokenKind(Ord(ANDTOK) - 1 + Mid); 764 | end; 765 | 766 | function GetIdentUnsafe(const IdentName: TString; AllowForwardReference: Boolean = False; RecType: Integer = 0): Integer; 767 | var 768 | IdentIndex: Integer; 769 | begin 770 | for IdentIndex := NumIdent downto 1 do 771 | with Ident[IdentIndex] do 772 | if ((UnitIndex = UnitStatus.Index) or (IsExported and (UnitIndex in UnitStatus.UsedUnits))) and (AllowForwardReference or 773 | (Kind <> USERTYPE) or (Types[DataType].Kind <> FORWARDTYPE)) and (ReceiverType = RecType) and // Receiver type for methods, 0 otherwise 774 | (Name = IdentName) then begin 775 | Result := IdentIndex; 776 | Exit; 777 | end; 778 | Result := 0; 779 | end; 780 | 781 | function GetIdent(const IdentName: TString; AllowForwardReference: Boolean = False; RecType: Integer = 0): Integer; 782 | begin 783 | Result := GetIdentUnsafe(IdentName, AllowForwardReference, RecType); 784 | if Result = 0 then 785 | Error('Unknown identifier ' + IdentName); 786 | end; 787 | 788 | function GetFieldUnsafe(RecType: Integer; const FieldName: TString): Integer; 789 | var 790 | FieldIndex: Integer; 791 | begin 792 | for FieldIndex := 1 to Types[RecType].NumFields do 793 | if Types[RecType].Field[FieldIndex]^.Name = FieldName then begin 794 | Result := FieldIndex; 795 | Exit; 796 | end; 797 | Result := 0; 798 | end; 799 | 800 | function GetField(RecType: Integer; const FieldName: TString): Integer; 801 | begin 802 | Result := GetFieldUnsafe(RecType, FieldName); 803 | if Result = 0 then 804 | Error('Unknown field ' + FieldName); 805 | end; 806 | 807 | function GetFieldInsideWith(var RecPointer: Integer; var RecType: Integer; var IsConst: Boolean; const FieldName: TString): Integer; 808 | var 809 | FieldIndex, WithIndex: Integer; 810 | begin 811 | for WithIndex := WithNesting downto 1 do begin 812 | RecType := WithStack[WithIndex].DataType; 813 | FieldIndex := GetFieldUnsafe(RecType, FieldName); 814 | if FieldIndex <> 0 then begin 815 | RecPointer := WithStack[WithIndex].TempPointer; 816 | IsConst := WithStack[WithIndex].IsConst; 817 | Result := FieldIndex; 818 | Exit; 819 | end; 820 | end; 821 | Result := 0; 822 | end; 823 | 824 | function GetMethodUnsafe(RecType: Integer; const MethodName: TString): Integer; 825 | begin 826 | Result := GetIdentUnsafe(MethodName, False, RecType); 827 | end; 828 | 829 | function GetMethod(RecType: Integer; const MethodName: TString): Integer; 830 | begin 831 | Result := GetIdent(MethodName, False, RecType); 832 | if (Ident[Result].Kind <> PROC) and (Ident[Result].Kind <> FUNC) then 833 | Error('Method expected'); 834 | end; 835 | 836 | function GetMethodInsideWith(var RecPointer: Integer; var RecType: Integer; var IsConst: Boolean; const MethodName: TString): Integer; 837 | var 838 | MethodIndex, WithIndex: Integer; 839 | begin 840 | for WithIndex := WithNesting downto 1 do begin 841 | RecType := WithStack[WithIndex].DataType; 842 | MethodIndex := GetMethodUnsafe(RecType, MethodName); 843 | if MethodIndex <> 0 then begin 844 | RecPointer := WithStack[WithIndex].TempPointer; 845 | IsConst := WithStack[WithIndex].IsConst; 846 | Result := MethodIndex; 847 | Exit; 848 | end; 849 | end; 850 | Result := 0; 851 | end; 852 | 853 | function FieldOrMethodInsideWithFound(const Name: TString): Boolean; 854 | var 855 | RecPointer: Integer; 856 | RecType: Integer; 857 | IsConst: Boolean; 858 | begin 859 | Result := (GetFieldInsideWith(RecPointer, RecType, IsConst, Name) <> 0) or (GetMethodInsideWith(RecPointer, RecType, IsConst, Name) <> 0); 860 | end; 861 | 862 | end. 863 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | MIT License 2 | 3 | Copyright (c) 2023 Wanderlan Santos dos Anjos 4 | 5 | Permission is hereby granted, free of charge, to any person obtaining a copy 6 | of this software and associated documentation files (the "Software"), to deal 7 | in the Software without restriction, including without limitation the rights 8 | to use, copy, modify, merge, publish, distribute, sublicense, and/or sell 9 | copies of the Software, and to permit persons to whom the Software is 10 | furnished to do so, subject to the following conditions: 11 | 12 | The above copyright notice and this permission notice shall be included in all 13 | copies or substantial portions of the Software. 14 | 15 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR 16 | IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, 17 | FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE 18 | AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER 19 | LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, 20 | OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE 21 | SOFTWARE. 22 | -------------------------------------------------------------------------------- /Linker.pas: -------------------------------------------------------------------------------- 1 | // Based on XD Pascal (2020) original code by Vasiliy Tereshkov 2 | // Refactoring and extensions by Wanderlan 3 | {$I-,H-} 4 | unit Linker; 5 | 6 | interface 7 | 8 | uses 9 | Common, CodeGen; 10 | 11 | procedure InitializeLinker; 12 | procedure SetProgramEntryPoint; 13 | function AddImportFunc(const ImportLibName, ImportFuncName: TString): Longint; 14 | procedure Link(const ExeName: TString); 15 | 16 | implementation 17 | 18 | const 19 | IMGBASE = $400000; 20 | SECTALIGN = $1000; 21 | FILEALIGN = $200; 22 | MAXIMPORTLIBS = 100; 23 | MAXIMPORTS = 2000; 24 | 25 | type 26 | TDOSStub = array [0..127] of Byte; 27 | 28 | TPEHeader = packed record 29 | PE: array [0..3] of TCharacter; 30 | Machine: Word; 31 | NumberOfSections: Word; 32 | TimeDateStamp: Longint; 33 | PointerToSymbolTable: Longint; 34 | NumberOfSymbols: Longint; 35 | SizeOfOptionalHeader: Word; 36 | Characteristics: Word; 37 | end; 38 | 39 | TPEOptionalHeader = packed record 40 | Magic: Word; 41 | MajorLinkerVersion: Byte; 42 | MinorLinkerVersion: Byte; 43 | SizeOfCode: Longint; 44 | SizeOfInitializedData: Longint; 45 | SizeOfUninitializedData: Longint; 46 | AddressOfEntryPoint: Longint; 47 | BaseOfCode: Longint; 48 | BaseOfData: Longint; 49 | ImageBase: Longint; 50 | SectionAlignment: Longint; 51 | FileAlignment: Longint; 52 | MajorOperatingSystemVersion: Word; 53 | MinorOperatingSystemVersion: Word; 54 | MajorImageVersion: Word; 55 | MinorImageVersion: Word; 56 | MajorSubsystemVersion: Word; 57 | MinorSubsystemVersion: Word; 58 | Win32VersionValue: Longint; 59 | SizeOfImage: Longint; 60 | SizeOfHeaders: Longint; 61 | CheckSum: Longint; 62 | Subsystem: Word; 63 | DllCharacteristics: Word; 64 | SizeOfStackReserve: Longint; 65 | SizeOfStackCommit: Longint; 66 | SizeOfHeapReserve: Longint; 67 | SizeOfHeapCommit: Longint; 68 | LoaderFlags: Longint; 69 | NumberOfRvaAndSizes: Longint; 70 | end; 71 | 72 | TDataDirectory = packed record 73 | VirtualAddress: Longint; 74 | Size: Longint; 75 | end; 76 | 77 | TPESectionHeader = packed record 78 | Name: array [0..7] of TCharacter; 79 | VirtualSize: Longint; 80 | VirtualAddress: Longint; 81 | SizeOfRawData: Longint; 82 | PointerToRawData: Longint; 83 | PointerToRelocations: Longint; 84 | PointerToLinenumbers: Longint; 85 | NumberOfRelocations: Word; 86 | NumberOfLinenumbers: Word; 87 | Characteristics: Longint; 88 | end; 89 | 90 | THeaders = packed record 91 | Stub: TDOSStub; 92 | PEHeader: TPEHeader; 93 | PEOptionalHeader: TPEOptionalHeader; 94 | DataDirectories: array [0..15] of TDataDirectory; 95 | CodeSectionHeader, DataSectionHeader, BSSSectionHeader, ImportSectionHeader: TPESectionHeader; 96 | end; 97 | 98 | TImportLibName = array [0..15] of TCharacter; 99 | TImportFuncName = array [0..31] of TCharacter; 100 | 101 | TImportDirectoryTableEntry = packed record 102 | Characteristics: Longint; 103 | TimeDateStamp: Longint; 104 | ForwarderChain: Longint; 105 | Name: Longint; 106 | FirstThunk: Longint; 107 | end; 108 | 109 | TImportNameTableEntry = packed record 110 | Hint: Word; 111 | Name: TImportFuncName; 112 | end; 113 | 114 | TImport = record 115 | LibName, FuncName: TString; 116 | end; 117 | 118 | TImportSectionData = record 119 | DirectoryTable: array [1..MAXIMPORTLIBS + 1] of TImportDirectoryTableEntry; 120 | LibraryNames: array [1..MAXIMPORTLIBS] of TImportLibName; 121 | LookupTable: array [1..MAXIMPORTS + MAXIMPORTLIBS] of Longint; 122 | NameTable: array [1..MAXIMPORTS] of TImportNameTableEntry; 123 | NumImports, NumImportLibs: Integer; 124 | end; 125 | 126 | var 127 | Headers: THeaders; 128 | Import: array [1..MAXIMPORTS] of TImport; 129 | ImportSectionData: TImportSectionData; 130 | LastImportLibName: TString; 131 | ProgramEntryPoint: Longint; 132 | 133 | const 134 | DOSStub: TDOSStub = ( 135 | $4D, $5A, $90, $00, $03, $00, $00, $00, $04, $00, $00, $00, $FF, $FF, $00, $00, 136 | $B8, $00, $00, $00, $00, $00, $00, $00, $40, $00, $00, $00, $00, $00, $00, $00, 137 | $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, 138 | $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $80, $00, $00, $00, 139 | $0E, $1F, $BA, $0E, $00, $B4, $09, $CD, $21, $B8, $01, $4C, $CD, $21, $54, $68, 140 | $69, $73, $20, $70, $72, $6F, $67, $72, $61, $6D, $20, $63, $61, $6E, $6E, $6F, 141 | $74, $20, $62, $65, $20, $72, $75, $6E, $20, $69, $6E, $20, $44, $4F, $53, $20, 142 | $6D, $6F, $64, $65, $2E, $0D, $0D, $0A, $24, $00, $00, $00, $00, $00, $00, $00); 143 | 144 | procedure Pad(var f: file; Size, Alignment: Integer); 145 | var 146 | i: Integer; 147 | b: Byte; 148 | begin 149 | b := 0; 150 | for i := 0 to Align(Size, Alignment) - Size - 1 do 151 | BlockWrite(f, b, 1); 152 | end; 153 | 154 | procedure FillHeaders(CodeSize, InitializedDataSize, UninitializedDataSize, ImportSize: Integer); 155 | const 156 | IMAGE_FILE_MACHINE_I386 = $14C; 157 | IMAGE_FILE_RELOCS_STRIPPED = $0001; 158 | IMAGE_FILE_EXECUTABLE_IMAGE = $0002; 159 | IMAGE_FILE_32BIT_MACHINE = $0100; 160 | IMAGE_SCN_CNT_CODE = $00000020; 161 | IMAGE_SCN_CNT_INITIALIZED_DATA = $00000040; 162 | IMAGE_SCN_CNT_UNINITIALIZED_DATA = $00000080; 163 | IMAGE_SCN_MEM_EXECUTE = $20000000; 164 | IMAGE_SCN_MEM_READ = $40000000; 165 | IMAGE_SCN_MEM_WRITE = $80000000; 166 | begin 167 | FillChar(Headers, SizeOf(Headers), #0); 168 | with Headers do begin 169 | Stub := DOSStub; 170 | with PEHeader do begin 171 | PE[0] := 'P'; 172 | PE[1] := 'E'; 173 | Machine := IMAGE_FILE_MACHINE_I386; 174 | NumberOfSections := 4; 175 | SizeOfOptionalHeader := SizeOf(PEOptionalHeader) + SizeOf(DataDirectories); 176 | Characteristics := IMAGE_FILE_RELOCS_STRIPPED or IMAGE_FILE_EXECUTABLE_IMAGE or IMAGE_FILE_32BIT_MACHINE; 177 | end; 178 | with PEOptionalHeader do begin 179 | Magic := $10B; // PE32 180 | MajorLinkerVersion := 3; 181 | SizeOfCode := CodeSize; 182 | SizeOfInitializedData := InitializedDataSize; 183 | SizeOfUninitializedData := UninitializedDataSize; 184 | AddressOfEntryPoint := Align(SizeOf(Headers), SECTALIGN) + ProgramEntryPoint; 185 | BaseOfCode := Align(SizeOf(Headers), SECTALIGN); 186 | BaseOfData := Align(SizeOf(Headers), SECTALIGN) + Align(CodeSize, SECTALIGN); 187 | ImageBase := IMGBASE; 188 | SectionAlignment := SECTALIGN; 189 | FileAlignment := FILEALIGN; 190 | MajorOperatingSystemVersion := 4; 191 | MajorSubsystemVersion := 4; 192 | SizeOfImage := Align(SizeOf(Headers), SECTALIGN) + Align(CodeSize, SECTALIGN) + Align(InitializedDataSize, SECTALIGN) + 193 | Align(UninitializedDataSize, SECTALIGN) + Align(ImportSize, SECTALIGN); 194 | SizeOfHeaders := Align(SizeOf(Headers), FILEALIGN); 195 | Subsystem := 2 + Ord(IsConsoleProgram); // Win32 GUI/console 196 | SizeOfStackReserve := $1000000; 197 | SizeOfStackCommit := $100000; 198 | SizeOfHeapReserve := $1000000; 199 | SizeOfHeapCommit := $100000; 200 | NumberOfRvaAndSizes := 16; 201 | end; 202 | with DataDirectories[1] do // Import directory 203 | begin 204 | VirtualAddress := Align(SizeOf(Headers), SECTALIGN) + Align(CodeSize, SECTALIGN) + Align(InitializedDataSize, SECTALIGN) + Align(UninitializedDataSize, SECTALIGN); 205 | Size := ImportSize; 206 | end; 207 | with CodeSectionHeader do begin 208 | Name[0] := '.'; 209 | Name[1] := 't'; 210 | Name[2] := 'e'; 211 | Name[3] := 'x'; 212 | Name[4] := 't'; 213 | VirtualSize := CodeSize; 214 | VirtualAddress := Align(SizeOf(Headers), SECTALIGN); 215 | SizeOfRawData := Align(CodeSize, FILEALIGN); 216 | PointerToRawData := Align(SizeOf(Headers), FILEALIGN); 217 | Characteristics := Longint(IMAGE_SCN_CNT_CODE or IMAGE_SCN_MEM_READ or IMAGE_SCN_MEM_EXECUTE); 218 | end; 219 | with DataSectionHeader do begin 220 | Name[0] := '.'; 221 | Name[1] := 'd'; 222 | Name[2] := 'a'; 223 | Name[3] := 't'; 224 | Name[4] := 'a'; 225 | VirtualSize := InitializedDataSize; 226 | VirtualAddress := Align(SizeOf(Headers), SECTALIGN) + Align(CodeSize, SECTALIGN); 227 | SizeOfRawData := Align(InitializedDataSize, FILEALIGN); 228 | PointerToRawData := Align(SizeOf(Headers), FILEALIGN) + Align(CodeSize, FILEALIGN); 229 | Characteristics := Longint(IMAGE_SCN_CNT_INITIALIZED_DATA or IMAGE_SCN_MEM_READ or IMAGE_SCN_MEM_WRITE); 230 | end; 231 | with BSSSectionHeader do begin 232 | Name[0] := '.'; 233 | Name[1] := 'b'; 234 | Name[2] := 's'; 235 | Name[3] := 's'; 236 | VirtualSize := UninitializedDataSize; 237 | VirtualAddress := Align(SizeOf(Headers), SECTALIGN) + Align(CodeSize, SECTALIGN) + Align(InitializedDataSize, SECTALIGN); 238 | SizeOfRawData := 0; 239 | PointerToRawData := Align(SizeOf(Headers), FILEALIGN) + Align(CodeSize, FILEALIGN) + Align(InitializedDataSize, FILEALIGN); 240 | Characteristics := Longint(IMAGE_SCN_CNT_UNINITIALIZED_DATA or IMAGE_SCN_MEM_READ or IMAGE_SCN_MEM_WRITE); 241 | end; 242 | with ImportSectionHeader do begin 243 | Name[0] := '.'; 244 | Name[1] := 'i'; 245 | Name[2] := 'd'; 246 | Name[3] := 'a'; 247 | Name[4] := 't'; 248 | Name[5] := 'a'; 249 | VirtualSize := ImportSize; 250 | VirtualAddress := Align(SizeOf(Headers), SECTALIGN) + Align(CodeSize, SECTALIGN) + Align(InitializedDataSize, SECTALIGN) + Align(UninitializedDataSize, SECTALIGN); 251 | SizeOfRawData := Align(ImportSize, FILEALIGN); 252 | PointerToRawData := Align(SizeOf(Headers), FILEALIGN) + Align(CodeSize, FILEALIGN) + Align(InitializedDataSize, FILEALIGN); 253 | Characteristics := Longint(IMAGE_SCN_CNT_INITIALIZED_DATA or IMAGE_SCN_MEM_READ or IMAGE_SCN_MEM_WRITE); 254 | end; 255 | end; 256 | end; 257 | 258 | procedure InitializeLinker; 259 | begin 260 | FillChar(Import, SizeOf(Import), #0); 261 | FillChar(ImportSectionData, SizeOf(ImportSectionData), #0); 262 | LastImportLibName := ''; 263 | ProgramEntryPoint := 0; 264 | end; 265 | 266 | procedure SetProgramEntryPoint; 267 | begin 268 | if ProgramEntryPoint <> 0 then 269 | Error('Duplicate program entry point'); 270 | ProgramEntryPoint := GetCodeSize; 271 | end; 272 | 273 | function AddImportFunc(const ImportLibName, ImportFuncName: TString): Longint; 274 | begin 275 | with ImportSectionData do begin 276 | Inc(NumImports); 277 | if NumImports > MAXIMPORTS then 278 | Error('Maximum number of import functions exceeded'); 279 | Import[NumImports].LibName := ImportLibName; 280 | Import[NumImports].FuncName := ImportFuncName; 281 | if ImportLibName <> LastImportLibName then begin 282 | Inc(NumImportLibs); 283 | if NumImportLibs > MAXIMPORTLIBS then 284 | Error('Maximum number of import libraries exceeded'); 285 | LastImportLibName := ImportLibName; 286 | end; 287 | Result := (NumImports - 1 + NumImportLibs - 1) * SizeOf(Longint); // Relocatable 288 | end; 289 | end; 290 | 291 | procedure FillImportSection(var ImportSize, LookupTableOffset: Integer); 292 | var 293 | ImportIndex, ImportLibIndex, LookupIndex: Integer; 294 | LibraryNamesOffset, NameTableOffset: Integer; 295 | begin 296 | with ImportSectionData do begin 297 | LibraryNamesOffset := SizeOf(DirectoryTable[1]) * (NumImportLibs + 1); 298 | LookupTableOffset := LibraryNamesOffset + SizeOf(LibraryNames[1]) * NumImportLibs; 299 | NameTableOffset := LookupTableOffset + SizeOf(LookupTable[1]) * (NumImports + NumImportLibs); 300 | ImportSize := NameTableOffset + SizeOf(NameTable[1]) * NumImports; 301 | LastImportLibName := ''; 302 | ImportLibIndex := 0; 303 | LookupIndex := 0; 304 | for ImportIndex := 1 to NumImports do begin 305 | // Add new import library 306 | if (ImportLibIndex = 0) or (Import[ImportIndex].LibName <> LastImportLibName) then begin 307 | if ImportLibIndex <> 0 then 308 | Inc(LookupIndex); // Add null entry before the first thunk of a new library 309 | Inc(ImportLibIndex); 310 | DirectoryTable[ImportLibIndex].Name := LibraryNamesOffset + SizeOf(LibraryNames[1]) * (ImportLibIndex - 1); 311 | DirectoryTable[ImportLibIndex].FirstThunk := LookupTableOffset + SizeOf(LookupTable[1]) * LookupIndex; 312 | Move(Import[ImportIndex].LibName[1], LibraryNames[ImportLibIndex], Length(Import[ImportIndex].LibName)); 313 | LastImportLibName := Import[ImportIndex].LibName; 314 | end; // if 315 | // Add new import function 316 | Inc(LookupIndex); 317 | if LookupIndex > MAXIMPORTS + MAXIMPORTLIBS then 318 | Error('Maximum number of lookup entries exceeded'); 319 | LookupTable[LookupIndex] := NameTableOffset + SizeOf(NameTable[1]) * (ImportIndex - 1); 320 | Move(Import[ImportIndex].FuncName[1], NameTable[ImportIndex].Name, Length(Import[ImportIndex].FuncName)); 321 | end; 322 | end; 323 | end; 324 | 325 | procedure FixupImportSection(VirtualAddress: Longint); 326 | var 327 | i: Integer; 328 | begin 329 | with ImportSectionData do begin 330 | for i := 1 to NumImportLibs do 331 | with DirectoryTable[i] do begin 332 | Name := Name + VirtualAddress; 333 | FirstThunk := FirstThunk + VirtualAddress; 334 | end; 335 | for i := 1 to NumImports + NumImportLibs do 336 | if LookupTable[i] <> 0 then 337 | LookupTable[i] := LookupTable[i] + VirtualAddress; 338 | end; 339 | end; 340 | 341 | procedure Link(const ExeName: TString); 342 | var 343 | OutFile: TOutFile; 344 | CodeSize, ImportSize, LookupTableOffset: Integer; 345 | begin 346 | if ProgramEntryPoint = 0 then 347 | Error('Program entry point not found'); 348 | CodeSize := GetCodeSize; 349 | FillImportSection(ImportSize, LookupTableOffset); 350 | FillHeaders(CodeSize, InitializedGlobalDataSize, UninitializedGlobalDataSize, ImportSize); 351 | Relocate(IMGBASE + Headers.CodeSectionHeader.VirtualAddress, 352 | IMGBASE + Headers.DataSectionHeader.VirtualAddress, 353 | IMGBASE + Headers.BSSSectionHeader.VirtualAddress, 354 | IMGBASE + Headers.ImportSectionHeader.VirtualAddress + LookupTableOffset); 355 | FixupImportSection(Headers.ImportSectionHeader.VirtualAddress); 356 | // Write output file 357 | Assign(OutFile, TGenericString(ExeName)); 358 | Rewrite(OutFile, 1); 359 | if IOResult <> 0 then 360 | Error('Unable to open output file ' + ExeName); 361 | BlockWrite(OutFile, Headers, SizeOf(Headers)); 362 | Pad(OutFile, SizeOf(Headers), FILEALIGN); 363 | BlockWrite(OutFile, Code, CodeSize); 364 | Pad(OutFile, CodeSize, FILEALIGN); 365 | BlockWrite(OutFile, InitializedGlobalData, InitializedGlobalDataSize); 366 | Pad(OutFile, InitializedGlobalDataSize, FILEALIGN); 367 | with ImportSectionData do begin 368 | BlockWrite(OutFile, DirectoryTable, SizeOf(DirectoryTable[1]) * (NumImportLibs + 1)); 369 | BlockWrite(OutFile, LibraryNames, SizeOf(LibraryNames[1]) * NumImportLibs); 370 | BlockWrite(OutFile, LookupTable, SizeOf(LookupTable[1]) * (NumImports + NumImportLibs)); 371 | BlockWrite(OutFile, NameTable, SizeOf(NameTable[1]) * NumImports); 372 | end; 373 | Pad(OutFile, ImportSize, FILEALIGN); 374 | Close(OutFile); 375 | end; 376 | 377 | end. 378 | -------------------------------------------------------------------------------- /LitePascal.lpi: -------------------------------------------------------------------------------- 1 | 2 | 3 | 4 | 5 | 6 | 7 | 8 | 9 | 10 | 11 | 12 | 13 | 14 | <UseAppBundle Value="False"/> 15 | <ResourceType Value="res"/> 16 | </General> 17 | <BuildModes> 18 | <Item Name="Default" Default="True"/> 19 | </BuildModes> 20 | <PublishOptions> 21 | <Version Value="2"/> 22 | <UseFileFilters Value="True"/> 23 | </PublishOptions> 24 | <RunParams> 25 | <FormatVersion Value="2"/> 26 | </RunParams> 27 | <Units> 28 | <Unit> 29 | <Filename Value="LitePascal.pas"/> 30 | <IsPartOfProject Value="True"/> 31 | </Unit> 32 | </Units> 33 | </ProjectOptions> 34 | <CompilerOptions> 35 | <Version Value="11"/> 36 | <PathDelim Value="\"/> 37 | <Target> 38 | <Filename Value="LitePascal"/> 39 | </Target> 40 | <SearchPaths> 41 | <IncludeFiles Value="$(ProjOutDir)"/> 42 | <UnitOutputDirectory Value="lib\$(TargetCPU)-$(TargetOS)"/> 43 | </SearchPaths> 44 | <Parsing> 45 | <SyntaxOptions> 46 | <UseAnsiStrings Value="False"/> 47 | </SyntaxOptions> 48 | </Parsing> 49 | <CodeGeneration> 50 | <Optimizations> 51 | <OptimizationLevel Value="0"/> 52 | </Optimizations> 53 | </CodeGeneration> 54 | <Linking> 55 | <Debugging> 56 | <DebugInfoType Value="dsDwarf2Set"/> 57 | </Debugging> 58 | </Linking> 59 | </CompilerOptions> 60 | <Debugging> 61 | <Exceptions> 62 | <Item> 63 | <Name Value="EAbort"/> 64 | </Item> 65 | <Item> 66 | <Name Value="ECodetoolError"/> 67 | </Item> 68 | <Item> 69 | <Name Value="EFOpenError"/> 70 | </Item> 71 | </Exceptions> 72 | </Debugging> 73 | </CONFIG> 74 | -------------------------------------------------------------------------------- /LitePascal.lps: -------------------------------------------------------------------------------- 1 | <?xml version="1.0" encoding="UTF-8"?> 2 | <CONFIG> 3 | <ProjectSession> 4 | <PathDelim Value="\"/> 5 | <Version Value="12"/> 6 | <BuildModes Active="Default"/> 7 | <Units> 8 | <Unit> 9 | <Filename Value="LitePascal.pas"/> 10 | <IsPartOfProject Value="True"/> 11 | <IsVisibleTab Value="True"/> 12 | <TopLine Value="58"/> 13 | <CursorPos X="38" Y="79"/> 14 | <UsageCount Value="25"/> 15 | <Loaded Value="True"/> 16 | </Unit> 17 | <Unit> 18 | <Filename Value="Common.pas"/> 19 | <EditorIndex Value="6"/> 20 | <TopLine Value="522"/> 21 | <CursorPos X="43" Y="536"/> 22 | <UsageCount Value="12"/> 23 | <Loaded Value="True"/> 24 | </Unit> 25 | <Unit> 26 | <Filename Value="C:\lazarus\fpc\3.2.2\source\rtl\win\sysutils.pp"/> 27 | <UnitName Value="SysUtils"/> 28 | <EditorIndex Value="-1"/> 29 | <UsageCount Value="10"/> 30 | </Unit> 31 | <Unit> 32 | <Filename Value="Scanner.pas"/> 33 | <EditorIndex Value="5"/> 34 | <UsageCount Value="12"/> 35 | <Loaded Value="True"/> 36 | </Unit> 37 | <Unit> 38 | <Filename Value="Parser.pas"/> 39 | <EditorIndex Value="4"/> 40 | <TopLine Value="351"/> 41 | <CursorPos X="91" Y="372"/> 42 | <UsageCount Value="12"/> 43 | <Loaded Value="True"/> 44 | </Unit> 45 | <Unit> 46 | <Filename Value="CodeGen.pas"/> 47 | <EditorIndex Value="3"/> 48 | <TopLine Value="1355"/> 49 | <CursorPos Y="1368"/> 50 | <UsageCount Value="12"/> 51 | <Loaded Value="True"/> 52 | </Unit> 53 | <Unit> 54 | <Filename Value="Linker.pas"/> 55 | <EditorIndex Value="2"/> 56 | <CursorPos X="33" Y="131"/> 57 | <UsageCount Value="12"/> 58 | <Loaded Value="True"/> 59 | </Unit> 60 | <Unit> 61 | <Filename Value="units\System.pas"/> 62 | <EditorIndex Value="1"/> 63 | <TopLine Value="130"/> 64 | <CursorPos X="8" Y="153"/> 65 | <UsageCount Value="11"/> 66 | <Loaded Value="True"/> 67 | </Unit> 68 | <Unit> 69 | <Filename Value="C:\Clean Pascal\source\Common.pas"/> 70 | <EditorIndex Value="-1"/> 71 | <TopLine Value="671"/> 72 | <CursorPos X="44" Y="685"/> 73 | <UsageCount Value="10"/> 74 | </Unit> 75 | <Unit> 76 | <Filename Value="C:\Clean Pascal\source\Parser.pas"/> 77 | <EditorIndex Value="-1"/> 78 | <TopLine Value="471"/> 79 | <CursorPos X="30" Y="484"/> 80 | <UsageCount Value="10"/> 81 | </Unit> 82 | </Units> 83 | <JumpHistory HistoryIndex="27"> 84 | <Position> 85 | <Filename Value="Common.pas"/> 86 | <Caret Line="227" Column="10" TopLine="213"/> 87 | </Position> 88 | <Position> 89 | <Filename Value="CodeGen.pas"/> 90 | <Caret Line="1367" Column="41" TopLine="1354"/> 91 | </Position> 92 | <Position> 93 | <Filename Value="CodeGen.pas"/> 94 | <Caret Line="1377" Column="80" TopLine="1355"/> 95 | </Position> 96 | <Position> 97 | <Filename Value="Common.pas"/> 98 | <Caret Line="227" Column="10" TopLine="213"/> 99 | </Position> 100 | <Position> 101 | <Filename Value="CodeGen.pas"/> 102 | <Caret Line="1367" Column="7" TopLine="1355"/> 103 | </Position> 104 | <Position> 105 | <Filename Value="CodeGen.pas"/> 106 | <Caret Line="1368" TopLine="1355"/> 107 | </Position> 108 | <Position> 109 | <Filename Value="Common.pas"/> 110 | <Caret Line="500" TopLine="485"/> 111 | </Position> 112 | <Position> 113 | <Filename Value="Common.pas"/> 114 | <Caret Line="501" TopLine="485"/> 115 | </Position> 116 | <Position> 117 | <Filename Value="Common.pas"/> 118 | <Caret Line="502" TopLine="485"/> 119 | </Position> 120 | <Position> 121 | <Filename Value="Common.pas"/> 122 | <Caret Line="503" TopLine="485"/> 123 | </Position> 124 | <Position> 125 | <Filename Value="Common.pas"/> 126 | <Caret Line="538" TopLine="488"/> 127 | </Position> 128 | <Position> 129 | <Filename Value="CodeGen.pas"/> 130 | <Caret Line="1368" TopLine="1355"/> 131 | </Position> 132 | <Position> 133 | <Filename Value="Common.pas"/> 134 | <Caret Line="500" TopLine="488"/> 135 | </Position> 136 | <Position> 137 | <Filename Value="Common.pas"/> 138 | <Caret Line="501" TopLine="488"/> 139 | </Position> 140 | <Position> 141 | <Filename Value="Common.pas"/> 142 | <Caret Line="502" TopLine="488"/> 143 | </Position> 144 | <Position> 145 | <Filename Value="Common.pas"/> 146 | <Caret Line="503" TopLine="488"/> 147 | </Position> 148 | <Position> 149 | <Filename Value="CodeGen.pas"/> 150 | <Caret Line="1368" TopLine="1355"/> 151 | </Position> 152 | <Position> 153 | <Filename Value="Common.pas"/> 154 | <Caret Line="500" TopLine="488"/> 155 | </Position> 156 | <Position> 157 | <Filename Value="Common.pas"/> 158 | <Caret Line="201" Column="3" TopLine="187"/> 159 | </Position> 160 | <Position> 161 | <Filename Value="Common.pas"/> 162 | <Caret Line="147" Column="3" TopLine="133"/> 163 | </Position> 164 | <Position> 165 | <Filename Value="Common.pas"/> 166 | <Caret Line="502" Column="11" TopLine="436"/> 167 | </Position> 168 | <Position> 169 | <Filename Value="Common.pas"/> 170 | <Caret Line="11" Column="23"/> 171 | </Position> 172 | <Position> 173 | <Filename Value="Common.pas"/> 174 | <Caret Line="11" Column="23"/> 175 | </Position> 176 | <Position> 177 | <Filename Value="Common.pas"/> 178 | <Caret Line="513" Column="41" TopLine="500"/> 179 | </Position> 180 | <Position> 181 | <Filename Value="Common.pas"/> 182 | <Caret Line="28" Column="6" TopLine="16"/> 183 | </Position> 184 | <Position> 185 | <Filename Value="Common.pas"/> 186 | <Caret Line="513" Column="41" TopLine="500"/> 187 | </Position> 188 | <Position> 189 | <Filename Value="Common.pas"/> 190 | <Caret Line="536" Column="43" TopLine="522"/> 191 | </Position> 192 | <Position> 193 | <Filename Value="LitePascal.pas"/> 194 | <Caret Line="74" Column="48" TopLine="58"/> 195 | </Position> 196 | </JumpHistory> 197 | <RunParams> 198 | <FormatVersion Value="2"/> 199 | <Modes ActiveMode="default"> 200 | <Mode Name="default"> 201 | <local> 202 | <CommandLineParams Value="LitePascal.pas"/> 203 | </local> 204 | </Mode> 205 | </Modes> 206 | </RunParams> 207 | <HistoryLists> 208 | <List Name="WorkingDirectory" Type="File" Count="1"/> 209 | <List Name="LaunchingApplication" Type="File" Count="1"> 210 | <Item1 Value="C:\Windows\System32\cmd.exe /C ${TargetCmdLine}"/> 211 | </List> 212 | <List Name="CommandLineParameters" Count="2"> 213 | <Item1 Value="LitePascal.pas"/> 214 | <Item2 Value="LitePascal"/> 215 | </List> 216 | </HistoryLists> 217 | </ProjectSession> 218 | <Debugging> 219 | <BreakPoints> 220 | <Item> 221 | <Kind Value="bpkSource"/> 222 | <WatchScope Value="wpsLocal"/> 223 | <WatchKind Value="wpkWrite"/> 224 | <Source Value="CodeGen.pas"/> 225 | <Line Value="643"/> 226 | </Item> 227 | <Item> 228 | <Kind Value="bpkSource"/> 229 | <WatchScope Value="wpsLocal"/> 230 | <WatchKind Value="wpkWrite"/> 231 | <Source Value="CodeGen.pas"/> 232 | <Line Value="680"/> 233 | </Item> 234 | <Item> 235 | <Kind Value="bpkSource"/> 236 | <WatchScope Value="wpsLocal"/> 237 | <WatchKind Value="wpkWrite"/> 238 | <Source Value="CodeGen.pas"/> 239 | <Line Value="709"/> 240 | </Item> 241 | <Item> 242 | <Kind Value="bpkSource"/> 243 | <WatchScope Value="wpsLocal"/> 244 | <WatchKind Value="wpkWrite"/> 245 | <Source Value="CodeGen.pas"/> 246 | <Line Value="743"/> 247 | </Item> 248 | <Item> 249 | <Kind Value="bpkSource"/> 250 | <WatchScope Value="wpsLocal"/> 251 | <WatchKind Value="wpkWrite"/> 252 | <Source Value="CodeGen.pas"/> 253 | <Line Value="1346"/> 254 | </Item> 255 | <Item> 256 | <Kind Value="bpkSource"/> 257 | <WatchScope Value="wpsLocal"/> 258 | <WatchKind Value="wpkWrite"/> 259 | <Source Value="CodeGen.pas"/> 260 | <Line Value="1378"/> 261 | </Item> 262 | <Item> 263 | <Kind Value="bpkSource"/> 264 | <WatchScope Value="wpsLocal"/> 265 | <WatchKind Value="wpkWrite"/> 266 | <Source Value="CodeGen.pas"/> 267 | <Line Value="1409"/> 268 | </Item> 269 | </BreakPoints> 270 | </Debugging> 271 | </CONFIG> 272 | -------------------------------------------------------------------------------- /LitePascal.pas: -------------------------------------------------------------------------------- 1 | // Based on XD Pascal (2020) original code by Vasiliy Tereshkov 2 | // Refactoring and extensions by Wanderlan 3 | {$APPTYPE CONSOLE} 4 | {$I-,H-} // /(^(\r\n|\n|\r)$)|(^(\r\n|\n|\r))|^\s*$/gm 5 | program LitePascal; 6 | 7 | uses 8 | SysUtils, Common, Scanner, Parser, CodeGen, Linker; 9 | 10 | procedure SplitPath(const Path: TString; var Folder, Name, Ext: TString); 11 | var 12 | DotPos, SlashPos, i: Integer; 13 | begin 14 | Folder := ''; 15 | Name := Path; 16 | Ext := ''; 17 | DotPos := 0; 18 | SlashPos := 0; 19 | for i := Length(Path) downto 1 do 20 | if (Path[i] = '.') and (DotPos = 0) then 21 | DotPos := i 22 | else 23 | if (Path[i] = '\') and (SlashPos = 0) then 24 | SlashPos := i; 25 | if DotPos > 0 then begin 26 | Name := Copy(Path, 1, DotPos - 1); 27 | Ext := Copy(Path, DotPos, Length(Path) - DotPos + 1); 28 | end; 29 | if SlashPos > 0 then begin 30 | Folder := Copy(Path, 1, SlashPos); 31 | Name := Copy(Path, SlashPos + 1, Length(Name) - SlashPos); 32 | end; 33 | end; 34 | 35 | procedure NoticeProc(ClassInstance: Pointer; const Msg: TString); 36 | begin 37 | WriteLn(Msg); 38 | end; 39 | 40 | procedure WarningProc(ClassInstance: Pointer; const Msg: TString); 41 | begin 42 | if NumUnits >= 1 then 43 | Notice(ScannerFileName + ' (' + IntToStr(ScannerLine) + ') Warning: ' + Msg) 44 | else 45 | Notice('Warning: ' + Msg); 46 | end; 47 | 48 | procedure ErrorProc(ClassInstance: Pointer; const Msg: TString); 49 | begin 50 | if NumUnits >= 1 then 51 | Notice(ScannerFileName + ' (' + IntToStr(ScannerLine) + ') Error: ' + Msg) 52 | else 53 | Notice('Error: ' + Msg); readln; 54 | Halt(1); 55 | end; 56 | 57 | var 58 | CompilerPath, CompilerFolder, CompilerName, CompilerExt, PasPath, PasFolder, PasName, PasExt, ExePath: TString; 59 | 60 | begin 61 | SetWriteProcs(nil, @NoticeProc, @WarningProc, @ErrorProc); // Eliminar 62 | Notice('Lite Pascal ' + VERSION + ' for ' + TARGET); 63 | if ParamCount < 1 then begin 64 | Notice('Usage: LitePascal <file.pas>'); 65 | Halt(1); 66 | end; 67 | CompilerPath := TString(ParamStr(0)); 68 | SplitPath(CompilerPath, CompilerFolder, CompilerName, CompilerExt); 69 | PasPath := TString(ParamStr(1)); 70 | SplitPath(PasPath, PasFolder, PasName, PasExt); 71 | InitializeCommon; 72 | InitializeLinker; 73 | InitializeCodeGen; 74 | Folders[1] := PasFolder; 75 | Folders[2] := CompilerFolder + 'units\'; 76 | NumFolders := 2; 77 | Compile('system.pas'); 78 | Compile(PasName + PasExt); 79 | ExePath := PasFolder + PasName + '.exe'; 80 | Link(ExePath); 81 | Notice('Complete. Code size: ' + IntToStr(GetCodeSize) + ' bytes. Data size: ' + IntToStr(InitializedGlobalDataSize + UninitializedGlobalDataSize) + ' bytes'); 82 | // repeat 83 | // FinalizeScanner 84 | // until not RestoreScanner; 85 | // FinalizeCommon; 86 | end. 87 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # LitePascal 2 | Self host Object Pascal compiler for x86_windows (32 bit) target with < 8000 sloc. 3 | This code is based on brilliant [XD-Pascal](https://github.com/vtereshkov/xdpw) (Vasiliy Tereshkov), compatible with Turbo Pascal 5. 4 | 5 | ## Roadmap 6 | ### Beta 1 7 | - Lite OOP (Golang semantic) using simplified Pascal syntax 8 | - Fluent interface pattern 9 | - Implicit overload 10 | - Revised String type implementation 11 | - Multi-line strings 12 | - Strings with char codes 13 | - Case statements with any type and interface type 14 | - Unit initialization 15 | - PR with these contributions for XD-Pascal project 16 | ### Beta 2 17 | - Lite error handling 18 | - Embedded length for open array parameters 19 | - Low and High functions for open arrays 20 | - Conditional compilation 21 | - Include files 22 | - Macros 23 | - Lite generics 24 | - Inline procedures/functions 25 | - Short procedures/functions 26 | - PR with these contributions for XD-Pascal project 27 | ### Beta 3 28 | - More FPC/Delphi compatibility 29 | - Even smaller minimal executables 30 | - Library using unit syntax 31 | - Library (dll/so) building 32 | ### Release 1 33 | - x64_windows target 34 | - PR with these contributions for XD-Pascal project 35 | ### Release 2 36 | - x64_linux and x86_linux targets 37 | - PR with these contributions for XD-Pascal project 38 | ### Release 3 39 | - SIMD support 40 | - Benchmarks game samples 41 | ### Release 5 42 | - coroutines support (based on goroutines) 43 | - LiteHTTP server (based on miniHttp(Rust) server) 44 | ### Release 4 45 | - HTMX, HyperScript and Hyperview support 46 | - SQLite support 47 | - Very simple IDE (LiteIDE) in LitePascal, HTMX, HyperScript and CodeMirror 48 | ![LitePascal](https://github.com/wanderlan/LitePascal/blob/main/docs/grammar.svg) 49 | -------------------------------------------------------------------------------- /Scanner.pas: -------------------------------------------------------------------------------- 1 | // Based on XD Pascal (2020) original code by Vasiliy Tereshkov 2 | // Refactoring and extensions by Wanderlan 3 | {$I-,H-} 4 | unit Scanner; 5 | 6 | interface 7 | 8 | uses 9 | Common; 10 | 11 | var 12 | Tok: TToken; 13 | 14 | procedure InitializeScanner(const Name: TString); 15 | function SaveScanner: Boolean; 16 | function RestoreScanner: Boolean; 17 | procedure FinalizeScanner; 18 | procedure NextTok; 19 | procedure CheckTok(ExpectedTokKind: TTokenKind); 20 | procedure EatTok(ExpectedTokKind: TTokenKind); 21 | procedure AssertIdent; 22 | function ScannerFileName: TString; 23 | function ScannerLine: Integer; 24 | 25 | implementation 26 | 27 | type 28 | TBuffer = record 29 | Ptr: PCharacter; 30 | Size, Pos: Integer; 31 | end; 32 | 33 | TScannerState = record 34 | Token: TToken; 35 | FileName: TString; 36 | Line: Integer; 37 | Buffer: TBuffer; 38 | ch, ch2: TCharacter; 39 | EndOfUnit: Boolean; 40 | end; 41 | 42 | const 43 | SCANNERSTACKSIZE = 10; 44 | 45 | var 46 | ScannerState: TScannerState; 47 | ScannerStack: array [1..SCANNERSTACKSIZE] of TScannerState; 48 | ScannerStackTop: Integer = 0; 49 | 50 | const 51 | Digits: set of TCharacter = ['0'..'9']; 52 | HexDigits: set of TCharacter = ['0'..'9', 'A'..'F']; 53 | Spaces: set of TCharacter = [#1..#31, ' ']; 54 | AlphaNums: set of TCharacter = ['A'..'Z', 'a'..'z', '0'..'9', '_']; 55 | 56 | procedure InitializeScanner(const Name: TString); 57 | var 58 | F: TInFile; 59 | ActualSize: Integer; 60 | FolderIndex: Integer; 61 | begin 62 | ScannerState.Buffer.Ptr := nil; 63 | // First search the source folder, then the units folder, then the folders specified in $UNITPATH 64 | FolderIndex := 1; 65 | repeat 66 | Assign(F, TGenericString(Folders[FolderIndex] + Name)); 67 | Reset(F, 1); 68 | if IOResult = 0 then 69 | Break; 70 | Inc(FolderIndex); 71 | until FolderIndex > NumFolders; 72 | if FolderIndex > NumFolders then 73 | Error('Unable to open source file ' + Name); 74 | with ScannerState do begin 75 | FileName := Name; 76 | Line := 1; 77 | with Buffer do begin 78 | Size := FileSize(F); 79 | Pos := 0; 80 | GetMem(Ptr, Size); 81 | ActualSize := 0; 82 | BlockRead(F, Ptr^, Size, ActualSize); 83 | Close(F); 84 | if ActualSize <> Size then 85 | Error('Unable to read source file ' + Name); 86 | end; 87 | ch := ' '; 88 | ch2 := ' '; 89 | EndOfUnit := False; 90 | end; 91 | end; 92 | 93 | function SaveScanner: Boolean; 94 | begin 95 | Result := False; 96 | if ScannerStackTop < SCANNERSTACKSIZE then begin 97 | Inc(ScannerStackTop); 98 | ScannerStack[ScannerStackTop] := ScannerState; 99 | Result := True; 100 | end; 101 | end; 102 | 103 | function RestoreScanner: Boolean; 104 | begin 105 | Result := False; 106 | if ScannerStackTop > 0 then begin 107 | ScannerState := ScannerStack[ScannerStackTop]; 108 | Dec(ScannerStackTop); 109 | Tok := ScannerState.Token; 110 | Result := True; 111 | end; 112 | end; 113 | 114 | procedure FinalizeScanner; 115 | begin 116 | ScannerState.EndOfUnit := True; 117 | with ScannerState.Buffer do 118 | if Ptr <> nil then begin 119 | FreeMem(Ptr); 120 | Ptr := nil; 121 | end; 122 | end; 123 | 124 | procedure AppendStrSafe(var s: TString; ch: TCharacter); 125 | begin 126 | if Length(s) >= MAXSTRLENGTH - 1 then 127 | Error('String is too long'); 128 | s := s + ch; 129 | end; 130 | 131 | procedure ReadChar(var ch: TCharacter); 132 | begin 133 | if ScannerState.ch = #10 then 134 | Inc(ScannerState.Line); // End of line found 135 | ch := #0; 136 | with ScannerState.Buffer do 137 | if Pos < Size then begin 138 | ch := PCharacter(Integer(Ptr) + Pos)^; 139 | Inc(Pos); 140 | end 141 | else 142 | ScannerState.EndOfUnit := True; 143 | end; 144 | 145 | procedure ReadUppercaseChar(var ch: TCharacter); 146 | begin 147 | ReadChar(ch); 148 | ch := UpCase(ch); 149 | end; 150 | 151 | procedure ReadLiteralChar(var ch: TCharacter); 152 | begin 153 | ReadChar(ch); 154 | if (ch = #0) or (ch = #10) then 155 | Error('Unterminated string'); 156 | end; 157 | 158 | procedure ReadSingleLineComment; 159 | begin 160 | with ScannerState do 161 | while (ch <> #10) and not EndOfUnit do 162 | ReadChar(ch); 163 | end; 164 | 165 | procedure ReadMultiLineComment; 166 | begin 167 | with ScannerState do 168 | while (ch <> '}') and not EndOfUnit do 169 | ReadChar(ch); 170 | end; 171 | 172 | procedure ReadDirective; 173 | var 174 | Text: TString; 175 | begin 176 | with ScannerState do begin 177 | Text := ''; 178 | repeat 179 | AppendStrSafe(Text, ch); 180 | ReadUppercaseChar(ch); 181 | until not (ch in AlphaNums); 182 | if Text = '$APPTYPE' then begin // Console/GUI application type directive 183 | Text := ''; 184 | ReadChar(ch); 185 | while (ch <> '}') and not EndOfUnit do begin 186 | if (ch = #0) or (ch > ' ') then 187 | AppendStrSafe(Text, UpCase(ch)); 188 | ReadChar(ch); 189 | end; 190 | if Text = 'CONSOLE' then 191 | IsConsoleProgram := True 192 | else 193 | if Text = 'GUI' then 194 | IsConsoleProgram := False 195 | else 196 | Error('Unknown application type ' + Text); 197 | end 198 | else 199 | if Text = '$UNITPATH' then begin // Unit path directive 200 | Text := ''; 201 | ReadChar(ch); 202 | while (ch <> '}') and not EndOfUnit do begin 203 | if (ch = #0) or (ch > ' ') then 204 | AppendStrSafe(Text, UpCase(ch)); 205 | ReadChar(ch); 206 | end; 207 | Inc(NumFolders); 208 | if NumFolders > MAXFOLDERS then 209 | Error('Maximum number of unit paths exceeded'); 210 | Folders[NumFolders] := Folders[1] + Text; 211 | end 212 | else // All other directives are ignored 213 | ReadMultiLineComment; 214 | end; 215 | end; 216 | 217 | procedure ReadHexadecimalNumber; 218 | var 219 | Num, Digit: Integer; 220 | NumFound: Boolean; 221 | begin 222 | with ScannerState do begin 223 | Num := 0; 224 | NumFound := False; 225 | while ch in HexDigits do begin 226 | if Num and $F0000000 <> 0 then 227 | Error('Numeric constant is too large'); 228 | if ch in Digits then 229 | Digit := Ord(ch) - Ord('0') 230 | else 231 | Digit := Ord(ch) - Ord('A') + 10; 232 | Num := Num shl 4 or Digit; 233 | NumFound := True; 234 | ReadUppercaseChar(ch); 235 | end; 236 | if not NumFound then 237 | Error('Hexadecimal constant is not found'); 238 | Token.Kind := INTNUMBERTOK; 239 | Token.OrdValue := Num; 240 | end; 241 | end; 242 | 243 | procedure ReadDecimalNumber; 244 | var 245 | Num, Expon, Digit: Integer; 246 | Frac, FracWeight: Double; 247 | NegExpon, RangeFound, ExponFound: Boolean; 248 | begin 249 | with ScannerState do begin 250 | Num := 0; 251 | Frac := 0; 252 | Expon := 0; 253 | NegExpon := False; 254 | while ch in Digits do begin 255 | Digit := Ord(ch) - Ord('0'); 256 | if Num > (HighBound(INTEGERTYPEINDEX) - Digit) div 10 then 257 | Error('Numeric constant is too large'); 258 | Num := 10 * Num + Digit; 259 | ReadUppercaseChar(ch); 260 | end; 261 | if (ch <> '.') and (ch <> 'E') then begin // Integer number 262 | Token.Kind := INTNUMBERTOK; 263 | Token.OrdValue := Num; 264 | end 265 | else begin 266 | // Check for '..' token 267 | RangeFound := False; 268 | if ch = '.' then begin 269 | ReadUppercaseChar(ch2); 270 | if ch2 = '.' then begin // Integer number followed by '..' token 271 | Token.Kind := INTNUMBERTOK; 272 | Token.OrdValue := Num; 273 | RangeFound := True; 274 | end; 275 | if not EndOfUnit then 276 | Dec(Buffer.Pos); 277 | end; // if ch = '.' 278 | if not RangeFound then begin // Fractional number 279 | // Check for fractional part 280 | if ch = '.' then begin 281 | FracWeight := 0.1; 282 | ReadUppercaseChar(ch); 283 | while ch in Digits do begin 284 | Digit := Ord(ch) - Ord('0'); 285 | Frac := Frac + FracWeight * Digit; 286 | FracWeight := FracWeight / 10; 287 | ReadUppercaseChar(ch); 288 | end; 289 | end; // if ch = '.' 290 | // Check for exponent 291 | if ch = 'E' then begin 292 | ReadUppercaseChar(ch); 293 | // Check for exponent sign 294 | if ch = '+' then 295 | ReadUppercaseChar(ch) 296 | else 297 | if ch = '-' then begin 298 | NegExpon := True; 299 | ReadUppercaseChar(ch); 300 | end; 301 | ExponFound := False; 302 | while ch in Digits do begin 303 | Digit := Ord(ch) - Ord('0'); 304 | Expon := 10 * Expon + Digit; 305 | ReadUppercaseChar(ch); 306 | ExponFound := True; 307 | end; 308 | if not ExponFound then 309 | Error('Exponent is not found'); 310 | if NegExpon then 311 | Expon := -Expon; 312 | end; // if ch = 'E' 313 | Token.Kind := REALNUMBERTOK; 314 | Token.RealValue := (Num + Frac) * exp(Expon * ln(10)); 315 | end; // if not RangeFound 316 | end; // else 317 | end; 318 | end; 319 | 320 | procedure ReadNumber; 321 | begin 322 | with ScannerState do 323 | if ch = '$' then begin 324 | ReadUppercaseChar(ch); 325 | ReadHexadecimalNumber; 326 | end 327 | else 328 | ReadDecimalNumber; 329 | end; 330 | 331 | procedure ReadCharCode; 332 | begin 333 | with ScannerState do begin 334 | ReadUppercaseChar(ch); 335 | if not (ch in Digits + ['$']) then 336 | Error('Character code is not found'); 337 | ReadNumber; 338 | if (Token.Kind = REALNUMBERTOK) or (Token.OrdValue < 0) or (Token.OrdValue > 255) then 339 | Error('Illegal character code'); 340 | Token.Kind := CHARLITERALTOK; 341 | end; 342 | end; 343 | 344 | procedure ReadKeywordOrIdentifier; 345 | var 346 | Text, NonUppercaseText: TString; 347 | CurToken: TTokenKind; 348 | begin 349 | with ScannerState do begin 350 | Text := ''; 351 | NonUppercaseText := ''; 352 | repeat 353 | AppendStrSafe(NonUppercaseText, ch); 354 | ch := UpCase(ch); 355 | AppendStrSafe(Text, ch); 356 | ReadChar(ch); 357 | until not (ch in AlphaNums); 358 | CurToken := GetKeyword(Text); 359 | if CurToken <> EMPTYTOK then // Keyword found 360 | Token.Kind := CurToken 361 | else begin // Identifier found 362 | Token.Kind := IDENTTOK; 363 | Token.Name := Text; 364 | Token.NonUppercaseName := NonUppercaseText; 365 | end; 366 | end; 367 | end; 368 | 369 | procedure ReadCharOrStringLiteral; 370 | var 371 | Text: TString; 372 | EndOfLiteral: Boolean; 373 | begin 374 | with ScannerState do begin 375 | Text := ''; 376 | EndOfLiteral := False; 377 | repeat 378 | ReadLiteralChar(ch); 379 | if ch <> '''' then 380 | AppendStrSafe(Text, ch) 381 | else begin 382 | ReadChar(ch2); 383 | if ch2 = '''' then // Apostrophe character found 384 | AppendStrSafe(Text, ch) 385 | else begin 386 | if not EndOfUnit then 387 | Dec(Buffer.Pos); // Discard ch2 388 | EndOfLiteral := True; 389 | end; 390 | end; 391 | until EndOfLiteral; 392 | if Length(Text) = 1 then begin 393 | Token.Kind := CHARLITERALTOK; 394 | Token.OrdValue := Ord(Text[1]); 395 | end 396 | else begin 397 | Token.Kind := STRINGLITERALTOK; 398 | Token.Name := Text; 399 | Token.StrLength := Length(Text); 400 | DefineStaticString(Text, Token.StrAddress); 401 | end; 402 | ReadUppercaseChar(ch); 403 | end; 404 | end; 405 | 406 | procedure NextTok; 407 | begin 408 | with ScannerState do begin 409 | Token.Kind := EMPTYTOK; 410 | // Skip spaces, comments, directives 411 | while (ch in Spaces) or (ch = '{') or (ch = '/') do begin 412 | if ch = '{' then begin // Multi-line comment or directive 413 | ReadUppercaseChar(ch); 414 | if ch = '$' then 415 | ReadDirective 416 | else 417 | ReadMultiLineComment; 418 | end 419 | else 420 | if ch = '/' then begin 421 | ReadUppercaseChar(ch2); 422 | if ch2 = '/' then 423 | ReadSingleLineComment // Double-line comment 424 | else begin 425 | if not EndOfUnit then 426 | Dec(Buffer.Pos); // Discard ch2 427 | Break; 428 | end; 429 | end; 430 | ReadChar(ch); 431 | end; 432 | // Read token 433 | case ch of 434 | '0'..'9', '$': ReadNumber; 435 | '#': ReadCharCode; 436 | 'A'..'Z', 'a'..'z', '_': ReadKeywordOrIdentifier; 437 | '''': ReadCharOrStringLiteral; 438 | ':': // Single- or double-character tokens 439 | begin 440 | Token.Kind := COLONTOK; 441 | ReadUppercaseChar(ch); 442 | if ch = '=' then begin 443 | Token.Kind := ASSIGNTOK; 444 | ReadUppercaseChar(ch); 445 | end; 446 | end; 447 | '>': begin 448 | Token.Kind := GTTOK; 449 | ReadUppercaseChar(ch); 450 | if ch = '=' then begin 451 | Token.Kind := GETOK; 452 | ReadUppercaseChar(ch); 453 | end; 454 | end; 455 | '<': begin 456 | Token.Kind := LTTOK; 457 | ReadUppercaseChar(ch); 458 | if ch = '=' then begin 459 | Token.Kind := LETOK; 460 | ReadUppercaseChar(ch); 461 | end 462 | else 463 | if ch = '>' then begin 464 | Token.Kind := NETOK; 465 | ReadUppercaseChar(ch); 466 | end; 467 | end; 468 | '.': begin 469 | Token.Kind := PERIODTOK; 470 | ReadUppercaseChar(ch); 471 | if ch = '.' then begin 472 | Token.Kind := RANGETOK; 473 | ReadUppercaseChar(ch); 474 | end; 475 | end 476 | else // Double-character tokens 477 | case ch of 478 | '=': Token.Kind := EQTOK; 479 | ',': Token.Kind := COMMATOK; 480 | ';': Token.Kind := SEMICOLONTOK; 481 | '(': Token.Kind := OPARTOK; 482 | ')': Token.Kind := CPARTOK; 483 | '*': Token.Kind := MULTOK; 484 | '/': Token.Kind := DIVTOK; 485 | '+': Token.Kind := PLUSTOK; 486 | '-': Token.Kind := MINUSTOK; 487 | '^': Token.Kind := DEREFERENCETOK; 488 | '@': Token.Kind := ADDRESSTOK; 489 | '[': Token.Kind := OBRACKETTOK; 490 | ']': Token.Kind := CBRACKETTOK 491 | else Error('Unexpected character or end of file'); 492 | end; // case 493 | ReadChar(ch); 494 | end; // case 495 | end; 496 | Tok := ScannerState.Token; 497 | end; // NextTok 498 | 499 | procedure CheckTok(ExpectedTokKind: TTokenKind); 500 | begin 501 | with ScannerState do 502 | if Token.Kind <> ExpectedTokKind then 503 | Error(GetTokSpelling(ExpectedTokKind) + ' expected but ' + GetTokSpelling(Token.Kind) + ' found'); 504 | end; 505 | 506 | procedure EatTok(ExpectedTokKind: TTokenKind); 507 | begin 508 | CheckTok(ExpectedTokKind); 509 | NextTok; 510 | end; 511 | 512 | procedure AssertIdent; 513 | begin 514 | with ScannerState do 515 | if Token.Kind <> IDENTTOK then 516 | Error('Identifier expected but ' + GetTokSpelling(Token.Kind) + ' found'); 517 | end; 518 | 519 | function ScannerFileName: TString; 520 | begin 521 | Result := ScannerState.FileName; 522 | end; 523 | 524 | function ScannerLine: Integer; 525 | begin 526 | Result := ScannerState.Line; 527 | end; 528 | 529 | end. 530 | -------------------------------------------------------------------------------- /docs/grammar.puml: -------------------------------------------------------------------------------- 1 | @startebnf 2 | title Lite Pascal Grammar 3 | (*Future implementations are in dashed blocks*) 4 | 5 | LitePascal = program | unit; 6 | 7 | Program = ["program", Ident, ";"], [UsesClause], Block, "."; 8 | 9 | Unit = "unit", Ident, ";", "interface", [Uses], {Declarations}, 10 | "implementation", [Uses], Block, "."; 11 | 12 | Uses = "uses", Ident, {",", Ident}, ";"; 13 | 14 | Block = {Declarations}, (CompoundStatement | "end"); 15 | 16 | Declarations = Labels | Consts | Types | Vars | Procedure | Function; 17 | 18 | Labels = "label", Ident, {",", Ident}, ";"; 19 | 20 | Consts = "const", {UntypedConsts | TypedConsts}-; 21 | 22 | UntypedConsts = Ident, "=", ConstExpression, ";"; 23 | 24 | TypedConsts = Ident, ":", Type, "=", Initializer, ";"; 25 | 26 | Initializer = ConstExpression | StringLiteral | 27 | "(", Initializer, {",", Initializer}, ")" | 28 | "(", Ident, ":", Initializer, {";", Ident, ":", Initializer}, ")" | 29 | SetConstructor; 30 | 31 | Types = "type", {Ident, "=", Type, ";"}-; 32 | 33 | Vars = ("var" | ?threadvar?), {IdentList, ":", Type, ["=", Initializer], ";"}-; 34 | 35 | Procedure = "procedure", [?TypeIdent?, ?.?], Ident, [?Generics?], [FormalParams], [CallModifier], (";", (Directive | Block) | ?=, SimpleStatement?), ";"; 36 | 37 | Function = "function", [?TypeIdent?, ?.?], Ident, [?Generics?], [FormalParams], ":", TypeIdent, [CallModifier], (";", (Directive | Block) | ?=, Expression?), ";"; 38 | 39 | Generics = ?<?, ?TypeIdent?, {?,?, ?TypeIdent?}, ?>?; 40 | 41 | 42 | CallModifier = "stdcall" | "cdecl"; 43 | 44 | Directive = "forward" | "external", ConstExpression | ?inline?; 45 | 46 | ActualParams = "(", [(Expression | Designator), {",", (Expression | Designator)}], ")"; 47 | 48 | FormalParams = "(", FormalParamList, {";", FormalParamList}, ")"; 49 | 50 | FormalParamList = ["const" | "var" | ?out?], IdentList, [":", ["array", "of"], TypeIdent], ["=", ConstExpression]; 51 | 52 | IdentList = Ident, {",", Ident}; 53 | 54 | Type = "(", Ident, {",", Ident}, ")" | "^", TypeIdent | 55 | ["packed"], "array", "[", Type, {",", Type}, "]", "of", Type | 56 | ["packed"], "record", [?(?, ?TypeIdent?, ?)?], Fields, "end" | 57 | "interface", [?(?, ?TypeIdent?, {?,?, ?TypeIdent?}, ?)?], {?Prototypes?}, "end" | 58 | ["packed"], "set", "of", TypeIdent | 59 | ["packed"], "string", ["[", ConstExpression, "]"] | 60 | ["packed"], "file", ["of", TypeIdent] | 61 | ConstExpression, "..", ConstExpression | 62 | ("procedure" | "function"), [FormalParams], [":", TypeIdent], [CallModifier] | 63 | Ident; 64 | 65 | Prototypes = ("procedure" | "function"), Ident, [?Generics?], [FormalParams], [":", TypeIdent], ";"; 66 | 67 | Fields = FixedFields, ["case", [Ident, ":"], Type, "of", CaseField, {";", CaseField}], [";"]; 68 | 69 | CaseField = CaseLabel, {",", CaseLabel}, ":", "(", Fields, ")"; 70 | 71 | CaseLabel = ConstExpression, ["..", ConstExpression]; 72 | 73 | FixedFields = IdentList, ":", Type, {";", IdentList, ":", Type}; 74 | 75 | TypeIdent = "string" | "file" | Ident, [?Generics?]; 76 | 77 | Designator = (Ident | TypeIdent, "(", Expression, ")"), {Selector}; 78 | 79 | Selector = "^" | "[", Expression, {",", Expression}, "]" | ".", Ident | ActualParams; 80 | 81 | Statement = Ident, ":" | SimpleStatement | CompoundStatement | If | Case | While | Repeat | For | Goto | With; 82 | 83 | SimpleStatement = Designator, [(":="|?+=?|?-=?|?*=?|?/=?), Expression]; 84 | 85 | StatementList = Statement, {";", Statement}; 86 | 87 | CompoundStatement = "begin", StatementList, "end"; 88 | 89 | If = "if", Expression, "then", Statement, ["else", Statement]; 90 | 91 | Case = "case", Expression, "of", CaseElement, {";", CaseElement}, [";"], ["else", StatementList], [";"], "end"; 92 | 93 | While = "while", Expression, "do", Statement; 94 | 95 | Repeat = "repeat", StatementList, "until", Expression; 96 | 97 | For = "for", [?var?], Ident, ":=", Expression, ("to" | "downto"), Expression, "do", Statement; 98 | 99 | Goto = "goto", Ident; 100 | 101 | With = "with", Designator, {",", Designator}, "do", Statement; 102 | 103 | CaseElement = CaseLabel, {",", CaseLabel}, ":", Statement; 104 | 105 | ConstExpression = Expression; 106 | 107 | Expression = SimpleExpression, [("="|"<>"|"<"|"<="|">"|">="|"in"|?"is"?|?"as"?), SimpleExpression]; 108 | 109 | SimpleExpression = ["+"|"-"], Term ,{("+"|"-"|"or"|"xor"), Term} | 110 | ?"if"?, ?Expression?, ?"then"?, ?Expression?, ?"else"?, ?Expression?; 111 | 112 | Term = Factor, {("*"|"/"|"div"|"mod"|"shl"|"shr"|"and"), Factor}; 113 | 114 | Factor = ["@"], Designator | Number | CharLiteral | StringLiteral | 115 | "(", Expression, ")" | "not", Factor | SetConstructor | "nil"; 116 | 117 | SetConstructor = "[", [Expression, ["..", Expression], {",", Expression, ["..", Expression]}], "]"; 118 | 119 | Ident = (Letter | "_"), {Letter | "_" | Digit}; 120 | 121 | Number = "$", {HexDigit}- | {Digit}-, [".", {Digit}-], ["e", ["+" | "-"], {Digit}-]; 122 | 123 | CharLiteral = "'", (Character | "'", "'"), "'" | "#", Number; 124 | 125 | StringLiteral = {"'", {Character | "'", "'"}, "'" | "#", Number}-; 126 | <style> 127 | element { 128 | ebnf { 129 | LineColor blue 130 | Fontcolor blue 131 | Backgroundcolor #FEFEFE/#B6D8EB 132 | note {Backgroundcolor yellow} 133 | } 134 | } 135 | </style> 136 | @endebnf 137 | -------------------------------------------------------------------------------- /units/SysUtils.pas: -------------------------------------------------------------------------------- 1 | unit SysUtils; 2 | 3 | interface 4 | 5 | type 6 | TFloatFormat = (ffGeneral, ffFixed); 7 | Ansichar = Char; 8 | Pansichar = PChar; 9 | Widechar = Word; 10 | Pwidechar = ^Widechar; 11 | WideString = array [1..MaxStrLength + 1] of Widechar; 12 | 13 | function IntToStr(n: Integer): String; 14 | function StrToInt(const s: String): Integer; 15 | function FloatToStr(x: Real): String; 16 | function FloatToStrF(x: Real; Format: TFloatFormat; Precision, Digits: Integer): String; 17 | function StrToFloat(const s: String): Real; 18 | function StrToPWideChar(const s: String): Pwidechar; 19 | function PWideCharToStr(p: Pwidechar): String; 20 | 21 | implementation 22 | 23 | var 24 | WideStringBuf: WideString; 25 | 26 | function IntToStr(n: Integer): String; 27 | begin 28 | IStr(n, Result); 29 | end; 30 | 31 | function StrToInt(const s: String): Integer; 32 | var 33 | Code: Integer; 34 | begin 35 | IVal(s, Result, Code); 36 | if Code <> 0 then 37 | Halt(1); 38 | end; 39 | 40 | function FloatToStr(x: Real): String; 41 | begin 42 | if abs(ln(abs(x)) / ln(10)) > 9 then 43 | Str(x, Result) 44 | else 45 | Str(x, Result, 0, 16); 46 | end; 47 | 48 | function FloatToStrF(x: Real; Format: TFloatFormat; Precision, Digits: Integer): String; 49 | begin 50 | case Format of 51 | ffGeneral: Result := FloatToStr(x); 52 | ffFixed: 53 | if Digits > Precision then 54 | Str(x, Result) 55 | else 56 | Str(x, Result, 0, Digits); 57 | end; 58 | end; 59 | 60 | function StrToFloat(const s: String): Real; 61 | var 62 | Code: Integer; 63 | begin 64 | Val(s, Result, Code); 65 | if Code <> 0 then 66 | Halt(1); 67 | end; 68 | 69 | function StrToPWideChar(const s: String): Pwidechar; 70 | var 71 | i: Integer; 72 | begin 73 | i := 0; 74 | repeat 75 | Inc(i); 76 | WideStringBuf[i] := Ord(s[i]); 77 | until s[i] = #0; 78 | Result := @WideStringBuf[1]; 79 | end; 80 | 81 | function PWideCharToStr(p: Pwidechar): String; 82 | var 83 | i: Integer; 84 | begin 85 | i := 0; 86 | repeat 87 | Inc(i); 88 | Result[i] := Char(p^); 89 | p := Pwidechar(Integer(p) + SizeOf(Widechar)); 90 | until Result[i] = #0; 91 | end; 92 | 93 | end. 94 | -------------------------------------------------------------------------------- /units/System.pas: -------------------------------------------------------------------------------- 1 | unit System; 2 | 3 | interface 4 | 5 | const 6 | // Windows API constants 7 | STD_INPUT_HANDLE = -10; 8 | STD_OUTPUT_HANDLE = -11; 9 | FILE_ATTRIBUTE_NORMAL = 128; 10 | CREATE_ALWAYS = 2; 11 | OPEN_EXISTING = 3; 12 | GENERIC_READ = $80000000; 13 | GENERIC_WRITE = $40000000; 14 | INVALID_HANDLE_VALUE = -1; 15 | FILE_BEGIN = 0; 16 | FILE_CURRENT = 1; 17 | FILE_END = 2; 18 | 19 | // Other constants 20 | Pi = 3.141592653589793; 21 | MaxStrLength = 255; 22 | MaxSetElements = 256; 23 | MaxSetIndex = MaxSetElements div 32 - 1; 24 | 25 | type 26 | Longint = Integer; 27 | Double = Real; 28 | Extended = Real; 29 | Text = file; 30 | PChar = ^Char; 31 | TFileRec = record 32 | Name: String; 33 | Handle: Longint; 34 | end; 35 | PFileRec = ^TFileRec; 36 | TStream = record 37 | Data: PChar; 38 | Index: Integer; 39 | end; 40 | PStream = ^TStream; 41 | TSetStorage = array [0..MaxSetIndex] of Integer; 42 | 43 | var 44 | StdInputFile, StdOutputFile: file; 45 | DecimalSeparator: Char = '.'; 46 | 47 | // Windows API functions 48 | function GetCommandLineA: Pointer stdcall; external 'KERNEL32.DLL'; 49 | function GetModuleFileNameA(hModule: Longint; var lpFilename: String; nSize: Longint): Longint stdcall; external 'KERNEL32.DLL'; 50 | function GetProcessHeap: Longint stdcall; external 'KERNEL32.DLL'; 51 | function HeapAlloc(hHeap, dwFlags, dwBytes: Longint): Pointer stdcall; external 'KERNEL32.DLL'; 52 | procedure HeapFree(hHeap, dwFlags: Longint; lpMem: Pointer) stdcall; external 'KERNEL32.DLL'; 53 | function GetStdHandle(nStdHandle: Integer): Longint stdcall; external 'KERNEL32.DLL'; 54 | procedure SetConsoleMode(hConsoleHandle: Longint; dwMode: Longint) stdcall; external 'KERNEL32.DLL'; 55 | function CreateFileA(const lpFileName: String; dwDesiredAccess: Longint; dwShareMode: Longint; lpSecurityAttributes: Pointer; 56 | dwCreationDisposition, dwFlagsAndAttributes, hTemplateFile: Longint): Longint stdcall; external 'KERNEL32.DLL'; 57 | function SetFilePointer(hFile: Longint; lDistanceToMove: Longint; pDistanceToMoveHigh: Pointer; dwMoveMethod: Longint): Longint stdcall; external 'KERNEL32.DLL'; 58 | function GetFileSize(hFile: Longint; lpFileSizeHigh: Pointer): Longint stdcall; external 'KERNEL32.DLL'; 59 | procedure WriteFile(hFile: Longint; lpBuffer: Pointer; nNumberOfBytesToWrite: Longint; var lpNumberOfBytesWritten: Longint; lpOverlapped: Longint) stdcall; 60 | external 'KERNEL32.DLL'; 61 | procedure ReadFile(hFile: Longint; lpBuffer: Pointer; nNumberOfBytesToRead: Longint; var lpNumberOfBytesRead: Longint; lpOverlapped: Longint) stdcall; external 'KERNEL32.DLL'; 62 | procedure CloseHandle(hObject: Longint) stdcall; external 'KERNEL32.DLL'; 63 | function GetLastError: Longint stdcall; external 'KERNEL32.DLL'; 64 | function LoadLibraryA(const lpLibFileName: String): Longint stdcall; external 'KERNEL32.DLL'; 65 | function GetProcAddress(hModule: Longint; const lpProcName: String): Pointer stdcall; external 'KERNEL32.DLL'; 66 | function GetTickCount: Longint stdcall; external 'KERNEL32.DLL'; 67 | procedure ExitProcess(uExitCode: Integer) stdcall; external 'KERNEL32.DLL'; 68 | 69 | // Other functions 70 | procedure InitSystem; 71 | function Timer: Longint; 72 | procedure GetMem(var P: Pointer; Size: Integer); 73 | procedure FreeMem(var P: Pointer); 74 | procedure Randomize; 75 | function Random: Real; 76 | function Length(const s: String): Integer; 77 | procedure SetLength(var s: String; NewLength: Integer); 78 | procedure AssignStr(var Dest: String; const Source: String); 79 | procedure AppendStr(var Dest: String; const Source: String); 80 | procedure ConcatStr(const s1, s2: String; var s: String); 81 | function CompareStr(const s1, s2: String): Integer; 82 | procedure Move(var Source; var Dest; Count: Integer); 83 | function Copy(const S: String; Index, Count: Integer): String; 84 | procedure FillChar(var Data; Count: Integer; Value: Char); 85 | function ParseCmdLine(Index: Integer; var Str: String): Integer; 86 | function ParamCount: Integer; 87 | function ParamStr(Index: Integer): String; 88 | procedure IStr(Number: Integer; var s: String); 89 | procedure Str(Number: Real; var s: String; MinWidth: Integer = 0; DecPlaces: Integer = 0); 90 | procedure Val(const s: String; var Number: Real; var Code: Integer); 91 | procedure IVal(const s: String; var Number: Integer; var Code: Integer); 92 | procedure Assign(var F: file; const Name: String); 93 | procedure Rewrite(var F: file; BlockSize: Integer = 1); 94 | procedure Reset(var F: file; BlockSize: Integer = 1); 95 | procedure Close(var F: file); 96 | procedure BlockWrite(var F: file; var Buf; Len: Integer); 97 | procedure BlockRead(var F: file; var Buf; Len: Integer; var LenRead: Integer); 98 | procedure Seek(var F: file; Pos: Integer); 99 | function FileSize(var F: file): Integer; 100 | function FilePos(var F: file): Integer; 101 | function EOF(var F: file): Boolean; 102 | function IOResult: Integer; 103 | procedure WriteRec(var F: file; P: PStream; var Buf; Len: Integer); 104 | procedure WriteStringF(var F: file; P: PStream; const S: String; MinWidth, DecPlaces: Integer); 105 | procedure WriteIntF(var F: file; P: PStream; Number: Integer; MinWidth, DecPlaces: Integer); 106 | procedure WritePointerF(var F: file; P: PStream; Number: Integer; MinWidth, DecPlaces: Integer); 107 | procedure WriteRealF(var F: file; P: PStream; Number: Real; MinWidth, DecPlaces: Integer); 108 | procedure WriteBooleanF(var F: file; P: PStream; Flag: Boolean; MinWidth, DecPlaces: Integer); 109 | procedure WriteNewLine(var F: file; P: PStream); 110 | procedure ReadRec(var F: file; P: PStream; var Buf; Len: Integer); 111 | procedure ReadCh(var F: file; P: PStream; var ch: Char); 112 | procedure ReadInt(var F: file; P: PStream; var Number: Integer); 113 | procedure ReadSmallInt(var F: file; P: PStream; var Number: Smallint); 114 | procedure ReadShortInt(var F: file; P: PStream; var Number: Shortint); 115 | procedure ReadWord(var F: file; P: PStream; var Number: Word); 116 | procedure ReadByte(var F: file; P: PStream; var Number: Byte); 117 | procedure ReadBoolean(var F: file; P: PStream; var Value: Boolean); 118 | procedure ReadReal(var F: file; P: PStream; var Number: Real); 119 | procedure ReadSingle(var F: file; P: PStream; var Number: Single); 120 | procedure ReadString(var F: file; P: PStream; var s: String); 121 | procedure ReadNewLine(var F: file; P: PStream); 122 | function UpCase(ch: Char): Char; 123 | procedure InitSet(var SetStorage: TSetStorage); 124 | procedure AddToSet(var SetStorage: TSetStorage; FromElement, ToElement: Integer); 125 | function InSet(Element: Integer; var SetStorage: TSetStorage): Boolean; 126 | procedure SetUnion(const SetStorage1, SetStorage2: TSetStorage; var SetStorage: TSetStorage); 127 | procedure SetDifference(const SetStorage1, SetStorage2: TSetStorage; var SetStorage: TSetStorage); 128 | procedure SetIntersection(const SetStorage1, SetStorage2: TSetStorage; var SetStorage: TSetStorage); 129 | function CompareSets(const SetStorage1, SetStorage2: TSetStorage): Integer; 130 | function TestSubset(const SetStorage1, SetStorage2: TSetStorage): Integer; 131 | function TestSuperset(const SetStorage1, SetStorage2: TSetStorage): Integer; 132 | 133 | implementation 134 | 135 | var 136 | RandSeed: Integer; 137 | Heap: Longint; 138 | IOError: Integer = 0; 139 | StdInputHandle, StdOutputHandle: Longint; 140 | StdInputBuffer: String = ''; 141 | StdInputBufferPos: Integer = 1; 142 | LastReadChar: Char = ' '; 143 | 144 | procedure PtrStr(Number: Integer; var s: String); forward; 145 | 146 | // Initialization 147 | procedure InitSystem; 148 | var 149 | FileRecPtr: PFileRec; 150 | begin 151 | Heap := GetProcessHeap; 152 | StdInputHandle := GetStdHandle(STD_INPUT_HANDLE); 153 | FileRecPtr := PFileRec(@StdInputFile); 154 | FileRecPtr^.Handle := StdInputHandle; 155 | StdOutputHandle := GetStdHandle(STD_OUTPUT_HANDLE); 156 | FileRecPtr := PFileRec(@StdOutputFile); 157 | FileRecPtr^.Handle := StdOutputHandle; 158 | end; 159 | 160 | // Timer 161 | function Timer: Longint; 162 | begin 163 | Result := GetTickCount; 164 | end; 165 | 166 | // Heap routines 167 | procedure GetMem(var P: Pointer; Size: Integer); 168 | begin 169 | P := HeapAlloc(Heap, 0, Size); 170 | end; 171 | 172 | procedure FreeMem(var P: Pointer); 173 | begin 174 | HeapFree(Heap, 0, P); 175 | end; 176 | 177 | // Random number generator routines 178 | procedure Randomize; 179 | begin 180 | RandSeed := Timer; 181 | end; 182 | 183 | function Random: Real; 184 | begin 185 | RandSeed := 1975433173 * RandSeed; 186 | Result := 0.5 * (RandSeed / $7FFFFFFF + 1.0); 187 | end; 188 | 189 | // String manipulation routines 190 | function Length(const s: String): Integer; 191 | begin 192 | Result := 0; 193 | while s[Result + 1] <> #0 do 194 | Inc(Result); 195 | end; 196 | 197 | procedure SetLength(var s: String; NewLength: Integer); 198 | begin 199 | if NewLength >= 0 then 200 | s[NewLength + 1] := #0; 201 | end; 202 | 203 | procedure AssignStr(var Dest: String; const Source: String); 204 | begin 205 | Move(Source, Dest, Length(Source) + 1); 206 | end; 207 | 208 | procedure AppendStr(var Dest: String; const Source: String); 209 | var 210 | DestLen, i: Integer; 211 | begin 212 | DestLen := Length(Dest); 213 | i := 0; 214 | repeat 215 | Inc(i); 216 | Dest[DestLen + i] := Source[i]; 217 | until Source[i] = #0; 218 | end; 219 | 220 | procedure ConcatStr(const s1, s2: String; var s: String); 221 | begin 222 | s := s1; 223 | AppendStr(s, s2); 224 | end; 225 | 226 | function CompareStr(const s1, s2: String): Integer; 227 | var 228 | i: Integer; 229 | begin 230 | Result := 0; 231 | i := 0; 232 | repeat 233 | Inc(i); 234 | Result := Integer(s1[i]) - Integer(s2[i]); 235 | until (s1[i] = #0) or (s2[i] = #0) or (Result <> 0); 236 | end; 237 | 238 | procedure Move(var Source; var Dest; Count: Integer); 239 | var 240 | S, D: ^String; 241 | i: Integer; 242 | begin 243 | S := @Source; 244 | D := @Dest; 245 | if S = D then 246 | Exit; 247 | for i := 1 to Count do 248 | D^[i] := S^[i]; 249 | end; 250 | 251 | function Copy(const S: String; Index, Count: Integer): String; 252 | begin 253 | Move(S[Index], Result, Count); 254 | Result[Count + 1] := #0; 255 | end; 256 | 257 | procedure FillChar(var Data; Count: Integer; Value: Char); 258 | var 259 | D: ^String; 260 | i: Integer; 261 | begin 262 | D := @Data; 263 | for i := 1 to Count do 264 | D^[i] := Value; 265 | end; 266 | 267 | function ParseCmdLine(Index: Integer; var Str: String): Integer; 268 | var 269 | CmdLine: String; 270 | CmdLinePtr: ^String; 271 | ParamPtr: array [0..7] of ^String; 272 | i, NumParam, CmdLineLen: Integer; 273 | begin 274 | CmdLinePtr := GetCommandLineA; 275 | CmdLineLen := Length(CmdLinePtr^); 276 | Move(CmdLinePtr^, CmdLine, CmdLineLen + 1); 277 | NumParam := 1; 278 | ParamPtr[NumParam - 1] := @CmdLine; 279 | for i := 1 to CmdLineLen do begin 280 | if CmdLine[i] <= ' ' then 281 | CmdLine[i] := #0; 282 | if (i > 1) and (CmdLine[i] > ' ') and (CmdLine[i - 1] = #0) then begin 283 | Inc(NumParam); 284 | ParamPtr[NumParam - 1] := Pointer(@CmdLine[i]); 285 | end; 286 | end; 287 | if Index < NumParam then 288 | Str := ParamPtr[Index]^ 289 | else 290 | Str := ''; 291 | Result := NumParam; 292 | end; 293 | 294 | function ParamCount: Integer; 295 | var 296 | Str: String; 297 | begin 298 | Result := ParseCmdLine(0, Str) - 1; 299 | end; 300 | 301 | function ParamStr(Index: Integer): String; 302 | begin 303 | if Index = 0 then 304 | GetModuleFileNameA(0, Result, SizeOf(Result)) 305 | else 306 | ParseCmdLine(Index, Result); 307 | end; 308 | 309 | // File and console I/O routines 310 | procedure Assign(var F: file; const Name: String); 311 | var 312 | FileRecPtr: PFileRec; 313 | begin 314 | FileRecPtr := PFileRec(@F); 315 | FileRecPtr^.Name := Name; 316 | end; 317 | 318 | procedure Rewrite(var F: file; BlockSize: Integer = 1); 319 | var 320 | FileRecPtr: PFileRec; 321 | begin 322 | FileRecPtr := PFileRec(@F); 323 | FileRecPtr^.Handle := CreateFileA(FileRecPtr^.Name, GENERIC_WRITE, 0, nil, CREATE_ALWAYS, FILE_ATTRIBUTE_NORMAL, 0); 324 | if FileRecPtr^.Handle = INVALID_HANDLE_VALUE then 325 | IOError := -2; 326 | end; 327 | 328 | procedure Reset(var F: file; BlockSize: Integer = 1); 329 | var 330 | FileRecPtr: PFileRec; 331 | begin 332 | FileRecPtr := PFileRec(@F); 333 | FileRecPtr^.Handle := CreateFileA(FileRecPtr^.Name, GENERIC_READ or GENERIC_WRITE, 0, nil, OPEN_EXISTING, FILE_ATTRIBUTE_NORMAL, 0); 334 | if FileRecPtr^.Handle = INVALID_HANDLE_VALUE then 335 | IOError := -2; 336 | end; 337 | 338 | procedure Close(var F: file); 339 | var 340 | FileRecPtr: PFileRec; 341 | begin 342 | FileRecPtr := PFileRec(@F); 343 | CloseHandle(FileRecPtr^.Handle); 344 | end; 345 | 346 | procedure BlockWrite(var F: file; var Buf; Len: Integer); 347 | var 348 | FileRecPtr: PFileRec; 349 | LenWritten: Integer; 350 | begin 351 | FileRecPtr := PFileRec(@F); 352 | WriteFile(FileRecPtr^.Handle, @Buf, Len, LenWritten, 0); 353 | end; 354 | 355 | procedure BlockRead(var F: file; var Buf; Len: Integer; var LenRead: Integer); 356 | var 357 | FileRecPtr: PFileRec; 358 | begin 359 | FileRecPtr := PFileRec(@F); 360 | ReadFile(FileRecPtr^.Handle, @Buf, Len, LenRead, 0); 361 | end; 362 | 363 | procedure Seek(var F: file; Pos: Integer); 364 | var 365 | FileRecPtr: PFileRec; 366 | begin 367 | FileRecPtr := PFileRec(@F); 368 | Pos := SetFilePointer(FileRecPtr^.Handle, Pos, nil, FILE_BEGIN); 369 | end; 370 | 371 | function FileSize(var F: file): Integer; 372 | var 373 | FileRecPtr: PFileRec; 374 | begin 375 | FileRecPtr := PFileRec(@F); 376 | Result := GetFileSize(FileRecPtr^.Handle, nil); 377 | end; 378 | 379 | function FilePos(var F: file): Integer; 380 | var 381 | FileRecPtr: PFileRec; 382 | begin 383 | FileRecPtr := PFileRec(@F); 384 | Result := SetFilePointer(FileRecPtr^.Handle, 0, nil, FILE_CURRENT); 385 | end; 386 | 387 | function EOF(var F: file): Boolean; 388 | var 389 | FileRecPtr: PFileRec; 390 | begin 391 | FileRecPtr := PFileRec(@F); 392 | if (FileRecPtr^.Handle = StdInputHandle) or (FileRecPtr^.Handle = StdOutputHandle) then 393 | Result := False 394 | else 395 | Result := FilePos(F) >= FileSize(F); 396 | end; 397 | 398 | function IOResult: Integer; 399 | begin 400 | Result := IOError; 401 | IOError := 0; 402 | end; 403 | 404 | procedure WriteRec(var F: file; P: PStream; var Buf; Len: Integer); 405 | begin 406 | BlockWrite(F, Buf, Len); 407 | end; 408 | 409 | procedure WriteCh(var F: file; P: PStream; ch: Char); 410 | var 411 | Dest: PChar; 412 | begin 413 | if P = nil then // Console or file output 414 | BlockWrite(F, ch, 1) 415 | else // String stream output 416 | begin 417 | Dest := PChar(Integer(P^.Data) + P^.Index); 418 | Dest^ := ch; 419 | Inc(P^.Index); 420 | end; 421 | end; 422 | 423 | procedure WriteString(var F: file; P: PStream; const S: String); 424 | var 425 | Dest: PChar; 426 | begin 427 | if P = nil then // Console or file output 428 | BlockWrite(F, S, Length(S)) 429 | else // String stream output 430 | begin 431 | Dest := PChar(Integer(P^.Data) + P^.Index); 432 | Move(S, Dest^, Length(S)); 433 | P^.Index := P^.Index + Length(S); 434 | end; 435 | end; 436 | 437 | procedure WriteStringF(var F: file; P: PStream; const S: String; MinWidth, DecPlaces: Integer); 438 | var 439 | Spaces: String; 440 | i, NumSpaces: Integer; 441 | begin 442 | NumSpaces := MinWidth - Length(S); 443 | if NumSpaces < 0 then 444 | NumSpaces := 0; 445 | for i := 1 to NumSpaces do 446 | Spaces[i] := ' '; 447 | Spaces[NumSpaces + 1] := #0; 448 | WriteString(F, P, Spaces + S); 449 | end; 450 | 451 | function WriteInt(var F: file; P: PStream; Number: Integer): Integer; 452 | var 453 | Digit, Weight: Integer; 454 | Skip: Boolean; 455 | begin 456 | // Returns the string length 457 | if Number = 0 then begin 458 | WriteCh(F, P, '0'); 459 | Result := 1; 460 | end 461 | else begin 462 | Result := 0; 463 | if Number < 0 then begin 464 | WriteCh(F, P, '-'); 465 | Inc(Result); 466 | Number := -Number; 467 | end; 468 | Weight := 1000000000; 469 | Skip := True; 470 | while Weight >= 1 do begin 471 | if Number >= Weight then 472 | Skip := False; 473 | if not Skip then begin 474 | Digit := Number div Weight; 475 | WriteCh(F, P, Char(Shortint('0') + Digit)); 476 | Inc(Result); 477 | Number := Number - Weight * Digit; 478 | end; 479 | Weight := Weight div 10; 480 | end; // while 481 | end; // else 482 | end; 483 | 484 | procedure WriteIntF(var F: file; P: PStream; Number: Integer; MinWidth, DecPlaces: Integer); 485 | var 486 | S: String; 487 | begin 488 | IStr(Number, S); 489 | WriteStringF(F, P, S, MinWidth, DecPlaces); 490 | end; 491 | 492 | procedure WritePointer(var F: file; P: PStream; Number: Integer); 493 | var 494 | i, Digit: Shortint; 495 | begin 496 | for i := 7 downto 0 do begin 497 | Digit := (Number shr (i shl 2)) and $0F; 498 | if Digit <= 9 then 499 | Digit := Shortint('0') + Digit else Digit := Shortint('A') + Digit - 10; 500 | WriteCh(F, P, Char(Digit)); 501 | end; 502 | end; 503 | 504 | procedure WritePointerF(var F: file; P: PStream; Number: Integer; MinWidth, DecPlaces: Integer); 505 | var 506 | S: String; 507 | begin 508 | PtrStr(Number, S); 509 | WriteStringF(F, P, S, MinWidth, DecPlaces); 510 | end; 511 | 512 | function WriteReal(var F: file; P: PStream; Number: Real; MinWidth, DecPlaces: Integer): Integer; 513 | const 514 | MaxDecPlaces = 16; 515 | ExponPlaces = 3; 516 | var 517 | Integ, Digit, IntegExpon: Integer; 518 | Expon, Frac: Real; 519 | WriteExpon: Boolean; 520 | begin 521 | // Returns the string length 522 | Result := 0; 523 | Expon := ln(abs(Number)) / ln(10); 524 | WriteExpon := (DecPlaces = 0) or (Expon > 9); 525 | // Write sign 526 | if Number < 0 then begin 527 | WriteCh(F, P, '-'); 528 | Inc(Result); 529 | Number := -Number; 530 | end 531 | else 532 | if WriteExpon then begin 533 | WriteCh(F, P, ' '); 534 | Inc(Result); 535 | end; 536 | // Normalize number 537 | if not WriteExpon then begin 538 | IntegExpon := 0; 539 | if DecPlaces > MaxDecPlaces then 540 | DecPlaces := MaxDecPlaces; 541 | end 542 | else begin 543 | DecPlaces := MaxDecPlaces; 544 | if Number = 0 then 545 | IntegExpon := 0 546 | else begin 547 | IntegExpon := Trunc(Expon); 548 | Number := Number / exp(IntegExpon * ln(10)); 549 | if Number >= 10 then begin 550 | Number := Number / 10; 551 | Inc(IntegExpon); 552 | end 553 | else 554 | if Number < 1 then begin 555 | Number := Number * 10; 556 | Dec(IntegExpon); 557 | end; 558 | end; 559 | end; 560 | // Write integer part 561 | Integ := Trunc(Number); 562 | Frac := Number - Integ; 563 | Result := Result + WriteInt(F, P, Integ); 564 | // Write decimal separator 565 | WriteCh(F, P, DecimalSeparator); 566 | Inc(Result); 567 | // Truncate fractional part if needed 568 | if (MinWidth > 0) and WriteExpon and (Result + DecPlaces + 2 + ExponPlaces > MinWidth) then // + 2 for "e+" or "e-" 569 | begin 570 | DecPlaces := MinWidth - Result - 2 - ExponPlaces; 571 | if DecPlaces < 1 then 572 | DecPlaces := 1; 573 | end; 574 | // Write fractional part 575 | while DecPlaces > 0 do begin 576 | Frac := Frac * 10; 577 | Digit := Trunc(Frac); 578 | if Digit > 9 then 579 | Digit := 9; 580 | WriteCh(F, P, Char(Shortint('0') + Digit)); 581 | Inc(Result); 582 | Frac := Frac - Digit; 583 | Dec(DecPlaces); 584 | end; // while 585 | // Write exponent 586 | if WriteExpon then begin 587 | WriteCh(F, P, 'e'); 588 | if IntegExpon >= 0 then 589 | WriteCh(F, P, '+') 590 | else begin 591 | WriteCh(F, P, '-'); 592 | IntegExpon := -IntegExpon; 593 | end; 594 | // Write leading zeros 595 | if IntegExpon < 100 then 596 | WriteCh(F, P, '0'); 597 | if IntegExpon < 10 then 598 | WriteCh(F, P, '0'); 599 | WriteInt(F, P, IntegExpon); 600 | Result := Result + 2 + ExponPlaces; 601 | end; 602 | end; 603 | 604 | procedure WriteRealF(var F: file; P: PStream; Number: Real; MinWidth, DecPlaces: Integer); 605 | var 606 | S: String; 607 | begin 608 | Str(Number, S, MinWidth, DecPlaces); 609 | WriteStringF(F, P, S, MinWidth, DecPlaces); 610 | end; 611 | 612 | procedure WriteBoolean(var F: file; P: PStream; Flag: Boolean); 613 | begin 614 | if Flag then 615 | WriteString(F, P, 'TRUE') else WriteString(F, P, 'FALSE'); 616 | end; 617 | 618 | procedure WriteBooleanF(var F: file; P: PStream; Flag: Boolean; MinWidth, DecPlaces: Integer); 619 | begin 620 | if Flag then 621 | WriteStringF(F, P, 'TRUE', MinWidth, DecPlaces) else WriteStringF(F, P, 'FALSE', MinWidth, DecPlaces); 622 | end; 623 | 624 | procedure WriteNewLine(var F: file; P: PStream); 625 | begin 626 | WriteCh(F, P, #13); WriteCh(F, P, #10); 627 | end; 628 | 629 | procedure ReadRec(var F: file; P: PStream; var Buf; Len: Integer); 630 | var 631 | LenRead: Integer; 632 | begin 633 | BlockRead(F, Buf, Len, LenRead); 634 | end; 635 | 636 | procedure ReadCh(var F: file; P: PStream; var ch: Char); 637 | var 638 | Len: Integer; 639 | Dest: PChar; 640 | FileRecPtr: PFileRec; 641 | begin 642 | FileRecPtr := PFileRec(@F); 643 | if P <> nil then // String stream input 644 | begin 645 | Dest := PChar(Integer(P^.Data) + P^.Index); 646 | ch := Dest^; 647 | Inc(P^.Index); 648 | end 649 | else 650 | if FileRecPtr^.Handle = StdInputHandle then // Console input 651 | begin 652 | if StdInputBufferPos > Length(StdInputBuffer) then begin 653 | BlockRead(F, StdInputBuffer, SizeOf(StdInputBuffer) - 1, Len); 654 | StdInputBuffer[Len] := #0; // Replace LF with end-of-string 655 | StdInputBufferPos := 1; 656 | end; 657 | ch := StdInputBuffer[StdInputBufferPos]; 658 | Inc(StdInputBufferPos); 659 | end 660 | else // File input 661 | begin 662 | BlockRead(F, ch, 1, Len); 663 | if ch = #10 then 664 | BlockRead(F, ch, 1, Len); 665 | if Len <> 1 then 666 | ch := #0; 667 | end; 668 | LastReadChar := ch; // Required by ReadNewLine 669 | end; 670 | 671 | procedure ReadInt(var F: file; P: PStream; var Number: Integer); 672 | var 673 | Ch: Char; 674 | Negative: Boolean; 675 | begin 676 | Number := 0; 677 | // Skip spaces 678 | repeat ReadCh(F, P, Ch) until (Ch = #0) or (Ch > ' '); 679 | // Read sign 680 | Negative := False; 681 | if Ch = '+' then 682 | ReadCh(F, P, Ch) 683 | else 684 | if Ch = '-' then begin 685 | Negative := True; 686 | ReadCh(F, P, Ch); 687 | end; 688 | // Read number 689 | while (Ch >= '0') and (Ch <= '9') do begin 690 | Number := Number * 10 + Shortint(Ch) - Shortint('0'); 691 | ReadCh(F, P, Ch); 692 | end; 693 | if Negative then 694 | Number := -Number; 695 | end; 696 | 697 | procedure ReadSmallInt(var F: file; P: PStream; var Number: Smallint); 698 | var 699 | IntNumber: Integer; 700 | begin 701 | ReadInt(F, P, IntNumber); 702 | Number := IntNumber; 703 | end; 704 | 705 | procedure ReadShortInt(var F: file; P: PStream; var Number: Shortint); 706 | var 707 | IntNumber: Integer; 708 | begin 709 | ReadInt(F, P, IntNumber); 710 | Number := IntNumber; 711 | end; 712 | 713 | procedure ReadWord(var F: file; P: PStream; var Number: Word); 714 | var 715 | IntNumber: Integer; 716 | begin 717 | ReadInt(F, P, IntNumber); 718 | Number := IntNumber; 719 | end; 720 | 721 | procedure ReadByte(var F: file; P: PStream; var Number: Byte); 722 | var 723 | IntNumber: Integer; 724 | begin 725 | ReadInt(F, P, IntNumber); 726 | Number := IntNumber; 727 | end; 728 | 729 | procedure ReadBoolean(var F: file; P: PStream; var Value: Boolean); 730 | var 731 | IntNumber: Integer; 732 | begin 733 | ReadInt(F, P, IntNumber); 734 | Value := IntNumber <> 0; 735 | end; 736 | 737 | procedure ReadReal(var F: file; P: PStream; var Number: Real); 738 | var 739 | Ch: Char; 740 | Negative, ExponNegative: Boolean; 741 | Weight: Real; 742 | Expon: Integer; 743 | begin 744 | Number := 0; 745 | Expon := 0; 746 | // Skip spaces 747 | repeat ReadCh(F, P, Ch) until (Ch = #0) or (Ch > ' '); 748 | // Read sign 749 | Negative := False; 750 | if Ch = '+' then 751 | ReadCh(F, P, Ch) 752 | else 753 | if Ch = '-' then begin 754 | Negative := True; 755 | ReadCh(F, P, Ch); 756 | end; 757 | // Read integer part 758 | while (Ch >= '0') and (Ch <= '9') do begin 759 | Number := Number * 10 + Shortint(Ch) - Shortint('0'); 760 | ReadCh(F, P, Ch); 761 | end; 762 | if Ch = DecimalSeparator then // Fractional part found 763 | begin 764 | ReadCh(F, P, Ch); 765 | // Read fractional part 766 | Weight := 0.1; 767 | while (Ch >= '0') and (Ch <= '9') do begin 768 | Number := Number + Weight * (Shortint(Ch) - Shortint('0')); 769 | Weight := Weight / 10; 770 | ReadCh(F, P, Ch); 771 | end; 772 | end; 773 | if (Ch = 'E') or (Ch = 'e') then begin // Exponent found 774 | // Read exponent sign 775 | ExponNegative := False; 776 | ReadCh(F, P, Ch); 777 | if Ch = '+' then 778 | ReadCh(F, P, Ch) 779 | else 780 | if Ch = '-' then begin 781 | ExponNegative := True; 782 | ReadCh(F, P, Ch); 783 | end; 784 | // Read exponent 785 | while (Ch >= '0') and (Ch <= '9') do begin 786 | Expon := Expon * 10 + Shortint(Ch) - Shortint('0'); 787 | ReadCh(F, P, Ch); 788 | end; 789 | if ExponNegative then 790 | Expon := -Expon; 791 | end; 792 | if Expon <> 0 then 793 | Number := Number * exp(Expon * ln(10)); 794 | if Negative then 795 | Number := -Number; 796 | end; 797 | 798 | procedure ReadSingle(var F: file; P: PStream; var Number: Single); 799 | var 800 | RealNumber: Real; 801 | begin 802 | ReadReal(F, P, RealNumber); 803 | Number := RealNumber; 804 | end; 805 | 806 | procedure ReadString(var F: file; P: PStream; var s: String); 807 | var 808 | i: Integer; 809 | Ch: Char; 810 | begin 811 | i := 1; 812 | ReadCh(F, P, Ch); 813 | while Ch <> #13 do begin 814 | s[i] := Ch; 815 | Inc(i); 816 | ReadCh(F, P, Ch); 817 | end; 818 | s[i] := #0; 819 | end; 820 | 821 | procedure ReadNewLine(var F: file; P: PStream); 822 | var 823 | Ch: Char; 824 | begin 825 | Ch := LastReadChar; 826 | while not EOF(F) and (Ch <> #13) do 827 | ReadCh(F, P, Ch); 828 | LastReadChar := #0; 829 | end; 830 | 831 | // Conversion routines 832 | procedure Val(const s: String; var Number: Real; var Code: Integer); 833 | var 834 | Stream: TStream; 835 | begin 836 | Stream.Data := PChar(@s); 837 | Stream.Index := 0; 838 | ReadReal(StdInputFile, @Stream, Number); 839 | if Stream.Index - 1 <> Length(s) then 840 | Code := Stream.Index else Code := 0; 841 | end; 842 | 843 | procedure Str(Number: Real; var s: String; MinWidth: Integer = 0; DecPlaces: Integer = 0); 844 | var 845 | Stream: TStream; 846 | begin 847 | Stream.Data := PChar(@s); 848 | Stream.Index := 0; 849 | WriteReal(StdOutputFile, @Stream, Number, MinWidth, DecPlaces); 850 | s[Stream.Index + 1] := #0; 851 | end; 852 | 853 | procedure IVal(const s: String; var Number: Integer; var Code: Integer); 854 | var 855 | Stream: TStream; 856 | begin 857 | Stream.Data := PChar(@s); 858 | Stream.Index := 0; 859 | ReadInt(StdInputFile, @Stream, Number); 860 | if Stream.Index - 1 <> Length(s) then 861 | Code := Stream.Index else Code := 0; 862 | end; 863 | 864 | procedure IStr(Number: Integer; var s: String); 865 | var 866 | Stream: TStream; 867 | begin 868 | Stream.Data := PChar(@s); 869 | Stream.Index := 0; 870 | WriteInt(StdOutputFile, @Stream, Number); 871 | s[Stream.Index + 1] := #0; 872 | end; 873 | 874 | procedure PtrStr(Number: Integer; var s: String); 875 | var 876 | Stream: TStream; 877 | begin 878 | Stream.Data := PChar(@s); 879 | Stream.Index := 0; 880 | WritePointer(StdOutputFile, @Stream, Number); 881 | s[Stream.Index + 1] := #0; 882 | end; 883 | 884 | function UpCase(ch: Char): Char; 885 | begin 886 | if (ch >= 'a') and (ch <= 'z') then 887 | Result := Chr(Ord(ch) - Ord('a') + Ord('A')) 888 | else 889 | Result := ch; 890 | end; 891 | 892 | // Set manipulation routines 893 | procedure InitSet(var SetStorage: TSetStorage); 894 | begin 895 | FillChar(SetStorage, SizeOf(SetStorage), #0); 896 | end; 897 | 898 | procedure AddToSet(var SetStorage: TSetStorage; FromElement, ToElement: Integer); 899 | var 900 | Element: Integer; 901 | ElementPtr: ^Integer; 902 | begin 903 | ElementPtr := @SetStorage[FromElement shr 5]; 904 | ElementPtr^ := ElementPtr^ or (1 shl (FromElement and 31)); 905 | if ToElement > FromElement then 906 | for Element := FromElement + 1 to ToElement do begin 907 | ElementPtr := @SetStorage[Element shr 5]; 908 | ElementPtr^ := ElementPtr^ or (1 shl (Element and 31)); 909 | end; 910 | end; 911 | 912 | function InSet(Element: Integer; var SetStorage: TSetStorage): Boolean; 913 | begin 914 | Result := SetStorage[Element shr 5] and (1 shl (Element and 31)) <> 0; 915 | end; 916 | 917 | procedure SetUnion(const SetStorage1, SetStorage2: TSetStorage; var SetStorage: TSetStorage); 918 | var 919 | i: Integer; 920 | begin 921 | for i := 0 to MaxSetIndex do 922 | SetStorage[i] := SetStorage1[i] or SetStorage2[i]; 923 | end; 924 | 925 | procedure SetDifference(const SetStorage1, SetStorage2: TSetStorage; var SetStorage: TSetStorage); 926 | var 927 | i: Integer; 928 | begin 929 | for i := 0 to MaxSetIndex do 930 | SetStorage[i] := SetStorage1[i] and not SetStorage2[i]; 931 | end; 932 | 933 | procedure SetIntersection(const SetStorage1, SetStorage2: TSetStorage; var SetStorage: TSetStorage); 934 | var 935 | i: Integer; 936 | begin 937 | for i := 0 to MaxSetIndex do 938 | SetStorage[i] := SetStorage1[i] and SetStorage2[i]; 939 | end; 940 | 941 | function CompareSets(const SetStorage1, SetStorage2: TSetStorage): Integer; 942 | var 943 | i: Integer; 944 | begin 945 | Result := 0; 946 | for i := 0 to MaxSetIndex do 947 | if SetStorage1[i] <> SetStorage2[i] then begin 948 | Result := 1; 949 | Exit; 950 | end; 951 | end; 952 | 953 | function TestSubset(const SetStorage1, SetStorage2: TSetStorage): Integer; 954 | var 955 | IntersectionStorage: TSetStorage; 956 | begin 957 | SetIntersection(SetStorage1, SetStorage2, IntersectionStorage); 958 | if CompareSets(SetStorage1, IntersectionStorage) = 0 then 959 | Result := -1 else Result := 1; 960 | end; 961 | 962 | function TestSuperset(const SetStorage1, SetStorage2: TSetStorage): Integer; 963 | var 964 | IntersectionStorage: TSetStorage; 965 | begin 966 | SetIntersection(SetStorage1, SetStorage2, IntersectionStorage); 967 | if CompareSets(SetStorage2, IntersectionStorage) = 0 then 968 | Result := 1 else Result := -1; 969 | end; 970 | 971 | end. 972 | --------------------------------------------------------------------------------