├── Examples ├── File.pas ├── Misc.pas ├── RunProgram.pas ├── TestExpr.pas └── ipsupport.dll ├── IP.exe ├── LICENSE.txt ├── README.htm ├── README.md └── Src ├── CmnFunc.pas ├── CmnFunc2.pas ├── CodeX86.pas ├── Common.pas ├── Compiler.pas ├── DebugEventLog.dfm ├── DebugEventLog.pas ├── DebugRegisters.dfm ├── DebugRegisters.pas ├── Debugger.pas ├── DebuggerProcs.pas ├── IP.dpr ├── IPBase.pas ├── IPascal.cfg ├── IPascal.dof ├── IPascal.dpr ├── IPascal.pas ├── IPascal.res ├── Linker.pas ├── LinkerPE.pas ├── Main.dfm └── Main.pas /Examples/File.pas: -------------------------------------------------------------------------------- 1 | program TestFile; 2 | 3 | // This program will create a file named "testfileoutput.txt" in the current 4 | // directory containing the text "Hello!" 5 | 6 | type 7 | UINT = Cardinal; 8 | BOOL = Integer; 9 | DWORD = Cardinal; 10 | THandle = Cardinal; 11 | LPSECURITY_ATTRIBUTES = Integer; 12 | LPOVERLAPPED = Integer; 13 | 14 | function CreateFile(lpFileName: PChar; dwDesiredAccess, dwShareMode: DWORD; 15 | lpSecurityAttributes: LPSECURITY_ATTRIBUTES; dwCreationDisposition, 16 | dwFlagsAndAttributes: DWORD; hTemplateFile: THandle): THandle; stdcall; 17 | external 'kernel32.dll' name 'CreateFileA'; 18 | function WriteFile(hFile: THandle; lpBuffer: PChar; 19 | nNumberOfBytesToWrite: DWORD; var lpNumberOfBytesWritten: DWORD; 20 | lpOverlapped: LPOVERLAPPED): BOOL; stdcall; external 'kernel32.dll'; 21 | function CloseHandle(hObject: THandle): BOOL; stdcall; external 'kernel32.dll'; 22 | procedure ExitProcess(uExitCode: UINT); stdcall; external 'kernel32.dll'; 23 | 24 | const 25 | GENERIC_READ = $80000000; 26 | GENERIC_WRITE = $40000000; 27 | CREATE_ALWAYS = 2; 28 | 29 | var 30 | FileHandle: THandle; 31 | BytesWritten: DWORD; 32 | begin 33 | FileHandle := CreateFile('testfileoutput.txt', GENERIC_READ + GENERIC_WRITE, 34 | 0, 0, CREATE_ALWAYS, 0, 0); 35 | WriteFile(FileHandle, 'Hello!', 6, BytesWritten, 0); 36 | CloseHandle(FileHandle); 37 | 38 | ExitProcess(0); 39 | end. 40 | -------------------------------------------------------------------------------- /Examples/Misc.pas: -------------------------------------------------------------------------------- 1 | program TestCode; 2 | 3 | // This demonstrates displaying of message boxes, as well as procedure, 4 | // constant, and variable declarations. 5 | 6 | // Note: See the file 'limitations.txt' for a list of some of the things that 7 | // aren't supported. 8 | 9 | type 10 | HWND = Integer; 11 | UINT = Cardinal; 12 | BOOL = Integer; 13 | 14 | // Simplified declarations for some functions 15 | function MessageBox(hWnd: HWND; lpText, lpCaption: PChar; 16 | uType: UINT): Integer; stdcall; external 'user32.dll' name 'MessageBoxA'; 17 | function MessageBeep(uType: UINT): BOOL; stdcall; external 'user32.dll'; 18 | function sndPlaySoundA(lpszSound: PChar; fuSound: UINT): BOOL; stdcall; 19 | external 'winmm.dll'; 20 | procedure ExitProcess(uExitCode: UINT); stdcall; external 'kernel32.dll'; 21 | 22 | // Constants for MessageBox 23 | const 24 | MB_ICONINFORMATION = $40; 25 | MB_ICONQUESTION = $20; 26 | 27 | procedure MyProcedure; stdcall; 28 | 29 | procedure NestedProc; stdcall; 30 | const 31 | someconstant = MB_ICONINFORMATION; // this constant is local 32 | begin 33 | MessageBox(0, 'This is NestedProc.', 'Title', someconstant); 34 | end; 35 | 36 | begin 37 | NestedProc; 38 | MessageBox(0, 'This is MyProcedure.', 'Title', MB_ICONINFORMATION); 39 | end; 40 | 41 | var 42 | A, B: Integer; 43 | begin 44 | A := 1; { only simple assignments are currently supported; no expressions } 45 | B := A; 46 | 47 | MyProcedure; 48 | MessageBox(0, 'Now for a chimes sound...', 'Title', MB_ICONQUESTION); 49 | 50 | sndPlaySoundA('chimes.wav', 0); 51 | 52 | { For some reason, on Windows 2000 it will hang if we don't call 53 | ExitProcess after playing a sound. (The RET instruction that Inno 54 | Pascal puts at the end of the code doesn't suffice.) } 55 | ExitProcess(0); 56 | end. 57 | -------------------------------------------------------------------------------- /Examples/RunProgram.pas: -------------------------------------------------------------------------------- 1 | program RunProgram; 2 | 3 | // This program calls CreateProcess to run "notepad.exe" 4 | 5 | type 6 | UINT = Cardinal; 7 | BOOL = Integer; 8 | DWORD = Cardinal; 9 | THandle = Cardinal; 10 | LPSECURITY_ATTRIBUTES = Integer; 11 | LPOVERLAPPED = Integer; 12 | Pointer = Integer; 13 | PByte = Integer; 14 | TStartupInfo = record 15 | cb: DWORD; 16 | lpReserved: Pointer; 17 | lpDesktop: Pointer; 18 | lpTitle: Pointer; 19 | dwX: DWORD; 20 | dwY: DWORD; 21 | dwXSize: DWORD; 22 | dwYSize: DWORD; 23 | dwXCountChars: DWORD; 24 | dwYCountChars: DWORD; 25 | dwFillAttribute: DWORD; 26 | dwFlags: DWORD; 27 | wShowWindow: Word; 28 | cbReserved2: Word; 29 | lpReserved2: PByte; 30 | hStdInput: THandle; 31 | hStdOutput: THandle; 32 | hStdError: THandle; 33 | end; 34 | TProcessInformation = record 35 | hProcess: THandle; 36 | hThread: THandle; 37 | dwProcessId: DWORD; 38 | dwThreadId: DWORD; 39 | end; 40 | 41 | function CreateProcess(lpApplicationName: Integer; lpCommandLine: PChar; 42 | lpProcessAttributes, lpThreadAttributes: LPSECURITY_ATTRIBUTES; 43 | bInheritHandles: BOOL; dwCreationFlags: DWORD; lpEnvironment: Pointer; 44 | lpCurrentDirectory: Integer; var lpStartupInfo: TStartupInfo; 45 | var lpProcessInformation: TProcessInformation): BOOL; stdcall; 46 | external 'kernel32.dll' name 'CreateProcessA'; 47 | function CloseHandle(hObject: THandle): BOOL; stdcall; external 'kernel32.dll'; 48 | procedure ExitProcess(uExitCode: UINT); stdcall; external 'kernel32.dll'; 49 | 50 | var 51 | StartupInfo: TStartupInfo; 52 | ProcessInfo: TProcessInformation; 53 | begin 54 | // yes, a FillChar function would be useful here... 55 | StartupInfo.cb := SizeOf(TStartupInfo); 56 | StartupInfo.lpReserved := 0; 57 | StartupInfo.lpDesktop := 0; 58 | StartupInfo.lpTitle := 0; 59 | StartupInfo.dwFlags := 0; 60 | StartupInfo.cbReserved2 := 0; 61 | StartupInfo.lpReserved2 := 0; 62 | CreateProcess(0, 'notepad.exe', 0, 0, 0, 0, 0, 0, StartupInfo, ProcessInfo); 63 | CloseHandle(ProcessInfo.hProcess); 64 | CloseHandle(ProcessInfo.hThread); 65 | 66 | ExitProcess(0); 67 | end. 68 | -------------------------------------------------------------------------------- /Examples/TestExpr.pas: -------------------------------------------------------------------------------- 1 | program TestExpr; 2 | 3 | // This example evaluates some expressions and displays the results 4 | 5 | type 6 | UINT = Cardinal; 7 | const 8 | SM_CXSCREEN = 0; 9 | 10 | function GetSystemMetrics(nIndex: Integer): Integer; stdcall; external 'user32.dll'; 11 | procedure ipShowInteger(Fmt: PChar; Int: Integer); stdcall; external 'ipsupport.dll'; 12 | procedure ExitProcess(uExitCode: UINT); stdcall; external 'kernel32.dll'; 13 | 14 | var 15 | I, J, K: Integer; 16 | begin 17 | I := 1 + 2 * 4; // this expression will be evaluated entirely at compile time 18 | J := -I * 100; 19 | K := GetSystemMetrics(SM_CXSCREEN) div 2; 20 | 21 | ipShowInteger('I = %d', I); 22 | ipShowInteger('J = %d', J); 23 | ipShowInteger('Half the screen width is %d.', K); 24 | 25 | ExitProcess(0); 26 | end. 27 | -------------------------------------------------------------------------------- /Examples/ipsupport.dll: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smle/inno-pascal/9246bd2ac76ffba4349dadfb8e856aa11f1dc4f3/Examples/ipsupport.dll -------------------------------------------------------------------------------- /IP.exe: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smle/inno-pascal/9246bd2ac76ffba4349dadfb8e856aa11f1dc4f3/IP.exe -------------------------------------------------------------------------------- /LICENSE.txt: -------------------------------------------------------------------------------- 1 | GNU GENERAL PUBLIC LICENSE 2 | Version 2, June 1991 3 | 4 | Copyright (C) 1989, 1991 Free Software Foundation, Inc. 5 | 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 6 | Everyone is permitted to copy and distribute verbatim copies 7 | of this license document, but changing it is not allowed. 8 | 9 | Preamble 10 | 11 | The licenses for most software are designed to take away your 12 | freedom to share and change it. By contrast, the GNU General Public 13 | License is intended to guarantee your freedom to share and change free 14 | software--to make sure the software is free for all its users. This 15 | General Public License applies to most of the Free Software 16 | Foundation's software and to any other program whose authors commit to 17 | using it. (Some other Free Software Foundation software is covered by 18 | the GNU Library General Public License instead.) You can apply it to 19 | your programs, too. 20 | 21 | When we speak of free software, we are referring to freedom, not 22 | price. Our General Public Licenses are designed to make sure that you 23 | have the freedom to distribute copies of free software (and charge for 24 | this service if you wish), that you receive source code or can get it 25 | if you want it, that you can change the software or use pieces of it 26 | in new free programs; and that you know you can do these things. 27 | 28 | To protect your rights, we need to make restrictions that forbid 29 | anyone to deny you these rights or to ask you to surrender the rights. 30 | These restrictions translate to certain responsibilities for you if you 31 | distribute copies of the software, or if you modify it. 32 | 33 | For example, if you distribute copies of such a program, whether 34 | gratis or for a fee, you must give the recipients all the rights that 35 | you have. You must make sure that they, too, receive or can get the 36 | source code. And you must show them these terms so they know their 37 | rights. 38 | 39 | We protect your rights with two steps: (1) copyright the software, and 40 | (2) offer you this license which gives you legal permission to copy, 41 | distribute and/or modify the software. 42 | 43 | Also, for each author's protection and ours, we want to make certain 44 | that everyone understands that there is no warranty for this free 45 | software. If the software is modified by someone else and passed on, we 46 | want its recipients to know that what they have is not the original, so 47 | that any problems introduced by others will not reflect on the original 48 | authors' reputations. 49 | 50 | Finally, any free program is threatened constantly by software 51 | patents. We wish to avoid the danger that redistributors of a free 52 | program will individually obtain patent licenses, in effect making the 53 | program proprietary. To prevent this, we have made it clear that any 54 | patent must be licensed for everyone's free use or not licensed at all. 55 | 56 | The precise terms and conditions for copying, distribution and 57 | modification follow. 58 | 59 | GNU GENERAL PUBLIC LICENSE 60 | TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 61 | 62 | 0. This License applies to any program or other work which contains 63 | a notice placed by the copyright holder saying it may be distributed 64 | under the terms of this General Public License. The "Program", below, 65 | refers to any such program or work, and a "work based on the Program" 66 | means either the Program or any derivative work under copyright law: 67 | that is to say, a work containing the Program or a portion of it, 68 | either verbatim or with modifications and/or translated into another 69 | language. (Hereinafter, translation is included without limitation in 70 | the term "modification".) Each licensee is addressed as "you". 71 | 72 | Activities other than copying, distribution and modification are not 73 | covered by this License; they are outside its scope. The act of 74 | running the Program is not restricted, and the output from the Program 75 | is covered only if its contents constitute a work based on the 76 | Program (independent of having been made by running the Program). 77 | Whether that is true depends on what the Program does. 78 | 79 | 1. You may copy and distribute verbatim copies of the Program's 80 | source code as you receive it, in any medium, provided that you 81 | conspicuously and appropriately publish on each copy an appropriate 82 | copyright notice and disclaimer of warranty; keep intact all the 83 | notices that refer to this License and to the absence of any warranty; 84 | and give any other recipients of the Program a copy of this License 85 | along with the Program. 86 | 87 | You may charge a fee for the physical act of transferring a copy, and 88 | you may at your option offer warranty protection in exchange for a fee. 89 | 90 | 2. You may modify your copy or copies of the Program or any portion 91 | of it, thus forming a work based on the Program, and copy and 92 | distribute such modifications or work under the terms of Section 1 93 | above, provided that you also meet all of these conditions: 94 | 95 | a) You must cause the modified files to carry prominent notices 96 | stating that you changed the files and the date of any change. 97 | 98 | b) You must cause any work that you distribute or publish, that in 99 | whole or in part contains or is derived from the Program or any 100 | part thereof, to be licensed as a whole at no charge to all third 101 | parties under the terms of this License. 102 | 103 | c) If the modified program normally reads commands interactively 104 | when run, you must cause it, when started running for such 105 | interactive use in the most ordinary way, to print or display an 106 | announcement including an appropriate copyright notice and a 107 | notice that there is no warranty (or else, saying that you provide 108 | a warranty) and that users may redistribute the program under 109 | these conditions, and telling the user how to view a copy of this 110 | License. (Exception: if the Program itself is interactive but 111 | does not normally print such an announcement, your work based on 112 | the Program is not required to print an announcement.) 113 | 114 | These requirements apply to the modified work as a whole. If 115 | identifiable sections of that work are not derived from the Program, 116 | and can be reasonably considered independent and separate works in 117 | themselves, then this License, and its terms, do not apply to those 118 | sections when you distribute them as separate works. But when you 119 | distribute the same sections as part of a whole which is a work based 120 | on the Program, the distribution of the whole must be on the terms of 121 | this License, whose permissions for other licensees extend to the 122 | entire whole, and thus to each and every part regardless of who wrote it. 123 | 124 | Thus, it is not the intent of this section to claim rights or contest 125 | your rights to work written entirely by you; rather, the intent is to 126 | exercise the right to control the distribution of derivative or 127 | collective works based on the Program. 128 | 129 | In addition, mere aggregation of another work not based on the Program 130 | with the Program (or with a work based on the Program) on a volume of 131 | a storage or distribution medium does not bring the other work under 132 | the scope of this License. 133 | 134 | 3. You may copy and distribute the Program (or a work based on it, 135 | under Section 2) in object code or executable form under the terms of 136 | Sections 1 and 2 above provided that you also do one of the following: 137 | 138 | a) Accompany it with the complete corresponding machine-readable 139 | source code, which must be distributed under the terms of Sections 140 | 1 and 2 above on a medium customarily used for software interchange; or, 141 | 142 | b) Accompany it with a written offer, valid for at least three 143 | years, to give any third party, for a charge no more than your 144 | cost of physically performing source distribution, a complete 145 | machine-readable copy of the corresponding source code, to be 146 | distributed under the terms of Sections 1 and 2 above on a medium 147 | customarily used for software interchange; or, 148 | 149 | c) Accompany it with the information you received as to the offer 150 | to distribute corresponding source code. (This alternative is 151 | allowed only for noncommercial distribution and only if you 152 | received the program in object code or executable form with such 153 | an offer, in accord with Subsection b above.) 154 | 155 | The source code for a work means the preferred form of the work for 156 | making modifications to it. For an executable work, complete source 157 | code means all the source code for all modules it contains, plus any 158 | associated interface definition files, plus the scripts used to 159 | control compilation and installation of the executable. However, as a 160 | special exception, the source code distributed need not include 161 | anything that is normally distributed (in either source or binary 162 | form) with the major components (compiler, kernel, and so on) of the 163 | operating system on which the executable runs, unless that component 164 | itself accompanies the executable. 165 | 166 | If distribution of executable or object code is made by offering 167 | access to copy from a designated place, then offering equivalent 168 | access to copy the source code from the same place counts as 169 | distribution of the source code, even though third parties are not 170 | compelled to copy the source along with the object code. 171 | 172 | 4. You may not copy, modify, sublicense, or distribute the Program 173 | except as expressly provided under this License. Any attempt 174 | otherwise to copy, modify, sublicense or distribute the Program is 175 | void, and will automatically terminate your rights under this License. 176 | However, parties who have received copies, or rights, from you under 177 | this License will not have their licenses terminated so long as such 178 | parties remain in full compliance. 179 | 180 | 5. You are not required to accept this License, since you have not 181 | signed it. However, nothing else grants you permission to modify or 182 | distribute the Program or its derivative works. These actions are 183 | prohibited by law if you do not accept this License. Therefore, by 184 | modifying or distributing the Program (or any work based on the 185 | Program), you indicate your acceptance of this License to do so, and 186 | all its terms and conditions for copying, distributing or modifying 187 | the Program or works based on it. 188 | 189 | 6. Each time you redistribute the Program (or any work based on the 190 | Program), the recipient automatically receives a license from the 191 | original licensor to copy, distribute or modify the Program subject to 192 | these terms and conditions. You may not impose any further 193 | restrictions on the recipients' exercise of the rights granted herein. 194 | You are not responsible for enforcing compliance by third parties to 195 | this License. 196 | 197 | 7. If, as a consequence of a court judgment or allegation of patent 198 | infringement or for any other reason (not limited to patent issues), 199 | conditions are imposed on you (whether by court order, agreement or 200 | otherwise) that contradict the conditions of this License, they do not 201 | excuse you from the conditions of this License. If you cannot 202 | distribute so as to satisfy simultaneously your obligations under this 203 | License and any other pertinent obligations, then as a consequence you 204 | may not distribute the Program at all. For example, if a patent 205 | license would not permit royalty-free redistribution of the Program by 206 | all those who receive copies directly or indirectly through you, then 207 | the only way you could satisfy both it and this License would be to 208 | refrain entirely from distribution of the Program. 209 | 210 | If any portion of this section is held invalid or unenforceable under 211 | any particular circumstance, the balance of the section is intended to 212 | apply and the section as a whole is intended to apply in other 213 | circumstances. 214 | 215 | It is not the purpose of this section to induce you to infringe any 216 | patents or other property right claims or to contest validity of any 217 | such claims; this section has the sole purpose of protecting the 218 | integrity of the free software distribution system, which is 219 | implemented by public license practices. Many people have made 220 | generous contributions to the wide range of software distributed 221 | through that system in reliance on consistent application of that 222 | system; it is up to the author/donor to decide if he or she is willing 223 | to distribute software through any other system and a licensee cannot 224 | impose that choice. 225 | 226 | This section is intended to make thoroughly clear what is believed to 227 | be a consequence of the rest of this License. 228 | 229 | 8. If the distribution and/or use of the Program is restricted in 230 | certain countries either by patents or by copyrighted interfaces, the 231 | original copyright holder who places the Program under this License 232 | may add an explicit geographical distribution limitation excluding 233 | those countries, so that distribution is permitted only in or among 234 | countries not thus excluded. In such case, this License incorporates 235 | the limitation as if written in the body of this License. 236 | 237 | 9. The Free Software Foundation may publish revised and/or new versions 238 | of the General Public License from time to time. Such new versions will 239 | be similar in spirit to the present version, but may differ in detail to 240 | address new problems or concerns. 241 | 242 | Each version is given a distinguishing version number. If the Program 243 | specifies a version number of this License which applies to it and "any 244 | later version", you have the option of following the terms and conditions 245 | either of that version or of any later version published by the Free 246 | Software Foundation. If the Program does not specify a version number of 247 | this License, you may choose any version ever published by the Free Software 248 | Foundation. 249 | 250 | 10. If you wish to incorporate parts of the Program into other free 251 | programs whose distribution conditions are different, write to the author 252 | to ask for permission. For software which is copyrighted by the Free 253 | Software Foundation, write to the Free Software Foundation; we sometimes 254 | make exceptions for this. Our decision will be guided by the two goals 255 | of preserving the free status of all derivatives of our free software and 256 | of promoting the sharing and reuse of software generally. 257 | 258 | NO WARRANTY 259 | 260 | 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY 261 | FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN 262 | OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES 263 | PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED 264 | OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 265 | MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS 266 | TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE 267 | PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, 268 | REPAIR OR CORRECTION. 269 | 270 | 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING 271 | WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR 272 | REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, 273 | INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING 274 | OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED 275 | TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY 276 | YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER 277 | PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE 278 | POSSIBILITY OF SUCH DAMAGES. 279 | 280 | END OF TERMS AND CONDITIONS 281 | 282 | How to Apply These Terms to Your New Programs 283 | 284 | If you develop a new program, and you want it to be of the greatest 285 | possible use to the public, the best way to achieve this is to make it 286 | free software which everyone can redistribute and change under these terms. 287 | 288 | To do so, attach the following notices to the program. It is safest 289 | to attach them to the start of each source file to most effectively 290 | convey the exclusion of warranty; and each file should have at least 291 | the "copyright" line and a pointer to where the full notice is found. 292 | 293 | 294 | Copyright (C) 19yy 295 | 296 | This program is free software; you can redistribute it and/or modify 297 | it under the terms of the GNU General Public License as published by 298 | the Free Software Foundation; either version 2 of the License, or 299 | (at your option) any later version. 300 | 301 | This program is distributed in the hope that it will be useful, 302 | but WITHOUT ANY WARRANTY; without even the implied warranty of 303 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 304 | GNU General Public License for more details. 305 | 306 | You should have received a copy of the GNU General Public License 307 | along with this program; if not, write to the Free Software 308 | Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA 309 | 310 | 311 | Also add information on how to contact you by electronic and paper mail. 312 | 313 | If the program is interactive, make it output a short notice like this 314 | when it starts in an interactive mode: 315 | 316 | Gnomovision version 69, Copyright (C) 19yy name of author 317 | Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. 318 | This is free software, and you are welcome to redistribute it 319 | under certain conditions; type `show c' for details. 320 | 321 | The hypothetical commands `show w' and `show c' should show the appropriate 322 | parts of the General Public License. Of course, the commands you use may 323 | be called something other than `show w' and `show c'; they could even be 324 | mouse-clicks or menu items--whatever suits your program. 325 | 326 | You should also get your employer (if you work as a programmer) or your 327 | school, if any, to sign a "copyright disclaimer" for the program, if 328 | necessary. Here is a sample; alter the names: 329 | 330 | Yoyodyne, Inc., hereby disclaims all copyright interest in the program 331 | `Gnomovision' (which makes passes at compilers) written by James Hacker. 332 | 333 | , 1 April 1989 334 | Ty Coon, President of Vice 335 | 336 | This General Public License does not permit incorporating your program into 337 | proprietary programs. If your program is a subroutine library, you may 338 | consider it more useful to permit linking proprietary applications with the 339 | library. If this is what you want to do, use the GNU Library General 340 | Public License instead of this License. 341 | -------------------------------------------------------------------------------- /README.htm: -------------------------------------------------------------------------------- 1 | 2 | 3 | Inno Pascal README 4 | 5 | 6 | 7 |

8 | Inno Pascal 0.1.4
9 | Copyright (C) 2000 Jordan Russell
10 | For conditions of distribution and use, see LICENSE.TXT.
11 | Home page: http://www.jrsoftware.org/
12 | Current Inno Pascal home page: http://other.jrsoftware.org/ip/
13 | E-mail: jr @ jrsoftware.org 14 | 15 |

Miscellaneous notes

16 | 17 |

Some limitations of existing features: 18 | 19 |

    20 |
  • The linker currently has a limit of 512 bytes on the code and import data sections. This would not be difficult to fix; I just haven't gotten around to it yet. 21 |
  • Only supported types are Integer, Cardinal, Longint, LongWord, and PChar. (Actually there are smaller types like Bytes, Words, etc. but they don't work yet; don't use them.) 22 |
  • Expressions are supported in variable assignments, but they must be surrounded by "expr()". For example: "A := expr(1 + 2 * 3);". Four operators are currently supported: + - * div; parentheses may also be used. Functions may be called inside expressions. The code generated by expressions is far from optimal; every term is pushed and popped from the stack. 23 |
  • Functions cannot be called inside a function's parameter list, e.g. "MessageBox(0, GetCommandLine, 'Title', MB_ICONQUESTION);". Also, expressions can't currently be used in a function's parameters list either. 24 |
  • While it supports declaration of local variables, they are actually internally stored as global variables (like "static" variables in C). So don't try recursively calling a procedure yet. 25 |
  • Non-external procedures can't take parameters yet (since it doesn't have any stack handling support yet). 26 |
  • stdcall is the only supported calling convention 27 |
28 | 29 |

Important features it's lacking: 30 | 31 |

    32 |
  • "if"s 33 |
  • boolean expressions (i.e. A <> B) 34 |
  • ... and more 35 |
36 | 37 |

Interesting things it already supports: 38 | 39 |

    40 |
  • Compiler warns about uninitialized and unused variables. (Still needs some work, however. "A := MessageBeep(A)" doesn't warn about A being uninitialized.) 41 |
  • Compiler automatically removes unused variables, imports, and procedures. 42 |
  • It supports procedures and nested procedures. Constants, variables, and procedures declared inside a procedure are local only to that procedure. 43 |
44 | 45 | 46 |

Credits

47 | 48 |

Others who have contributed to the project: 49 | 50 |

    51 |
  • Developers of mwEdit/SynEdit - the excellent syntax highlighting code editor used in the IDE. 52 |
  • Michael Hieke - improvements to IDE's editor, debugger, and compiler. 53 |
54 | 55 | 56 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | Inno Pascal 2 | =========== 3 | 4 | Copyright (C) 2000 [Jordan Russell](http://www.jrsoftware.org/). All rights reserved. 5 | 6 | Usage: After unzipping, start IP.exe. Then open one of the files in the Examples subdirectory for a compilable example. 7 | 8 | Project Status: 9 | --------------- 10 | 11 | Discontinued. It was fun but I don't have time to work on it anymore. 12 | 13 | What is it? 14 | ----------- 15 | 16 | Inno Pascal is a simple Pascal compiler for Win32. It produces compact, native-code x86 executables without requiring any external assemblers or linkers. It was written entirely from scratch; it is not based on any other existing compilers. Full source code is included under the GPL license. 17 | 18 | At the present time, it's in an "experimental" phase. There aren't that many things it can do. 19 | -------------------------------------------------------------------------------- /Src/CmnFunc.pas: -------------------------------------------------------------------------------- 1 | unit CmnFunc; 2 | {$B-} 3 | { v2.23b } 4 | { This is a general toolchest of VCL-specific functions I use in my programs. } 5 | 6 | interface 7 | 8 | uses 9 | WinProcs, WinTypes, SysUtils, Forms, Dialogs, Graphics, Controls, Classes, 10 | CmnFunc2; 11 | 12 | {$IFNDEF VER80} {$IFNDEF VER90} {$IFNDEF VER93} 13 | {$DEFINE Delphi3orHigher} 14 | {$ENDIF} {$ENDIF} {$ENDIF} 15 | 16 | type 17 | TMsgBoxType = (mbInformation, mbConfirmation, mbError, mbCriticalError); 18 | 19 | { Useful constant } 20 | const 21 | EnableColor: array[Boolean] of TColor = (clBtnFace, clWindow); 22 | 23 | function MsgBoxP (const Text, Caption: PChar; const Typ: TMsgBoxType; 24 | const Buttons: Cardinal): Integer; 25 | function MsgBox ({$IFDEF WIN32}const{$ENDIF} Text, Caption: String; 26 | const Typ: TMsgBoxType; const Buttons: Cardinal): Integer; 27 | function MsgBoxFmt (const Text: String; const Args: array of const; 28 | const Caption: String; const Typ: TMsgBoxType; const Buttons: Cardinal): Integer; 29 | procedure SetMessageBoxCaption (const Typ: TMsgBoxType; const NewCaption: PChar); 30 | 31 | implementation 32 | 33 | uses 34 | Consts; 35 | 36 | var 37 | MessageBoxCaptions: array[TMsgBoxType] of PChar; 38 | 39 | procedure SetMessageBoxCaption (const Typ: TMsgBoxType; const NewCaption: PChar); 40 | begin 41 | StrDispose (MessageBoxCaptions[Typ]); 42 | MessageBoxCaptions[Typ] := nil; 43 | if Assigned(NewCaption) then 44 | MessageBoxCaptions[Typ] := StrNew(NewCaption); 45 | end; 46 | 47 | function MsgBoxP (const Text, Caption: PChar; const Typ: TMsgBoxType; 48 | const Buttons: Cardinal): Integer; 49 | const 50 | IconFlags: array[TMsgBoxType] of Cardinal = 51 | (MB_ICONINFORMATION, MB_ICONQUESTION, MB_ICONEXCLAMATION, MB_ICONSTOP); 52 | {$IFNDEF Delphi3orHigher} 53 | DefaultCaptions: array[TMsgBoxType] of Word = 54 | (SMsgDlgInformation, SMsgDlgConfirm, SMsgDlgError, SMsgDlgError); 55 | {$ELSE} 56 | DefaultCaptions: array[TMsgBoxType] of Pointer = 57 | (@SMsgDlgInformation, @SMsgDlgConfirm, @SMsgDlgError, @SMsgDlgError); 58 | {$ENDIF} 59 | var 60 | C: PChar; 61 | NewCaption: {$IFNDEF WIN32} array[0..255] of Char; {$ELSE} String; {$ENDIF} 62 | I: Integer; 63 | EnabledList, StayOnTopList: TList; 64 | ActiveCtl: TWinControl; 65 | begin 66 | EnabledList := nil; 67 | StayOnTopList := nil; 68 | try 69 | EnabledList := TList.Create; 70 | StayOnTopList := TList.Create; 71 | { Save focus } 72 | ActiveCtl := Screen.ActiveControl; 73 | try 74 | { Normalize top-mosts, and disable all other forms (to make it modal) } 75 | for I := 0 to Application.ComponentCount-1 do 76 | if Application.Components[I] is TForm then 77 | with TForm(Application.Components[I]) do 78 | if HandleAllocated then begin 79 | { Temporarily disable all forms to make sure the message box is 80 | truly modal. This is needed for projects with multiple modeless 81 | forms visible } 82 | if IsWindowEnabled(Handle) then begin 83 | EnableWindow (Handle, False); 84 | EnabledList.Add (Application.Components[I]); 85 | end; 86 | { Temporarily change all top-most forms back to normal, so that the 87 | message box won't get hidden behind a top-most form. (Delphi 88 | includes a function called 'NormalizeTopMosts' but it doesn't 89 | work correctly in all cases.) } 90 | if IsWindowVisible(Handle) and (FormStyle = fsStayOnTop) then begin 91 | SetWindowPos (Handle, HWND_NOTOPMOST, 92 | 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE); 93 | SetWindowPos (Handle, HWND_TOP, 94 | 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE); 95 | StayOnTopList.Add (Application.Components[I]); 96 | end; 97 | end; 98 | { Show the message box } 99 | C := Caption; 100 | if (C = nil) or (C[0] = #0) then begin 101 | C := MessageBoxCaptions[Typ]; 102 | if C = nil then begin 103 | {$IFNDEF WIN32} 104 | LoadString (HInstance, DefaultCaptions[Typ], NewCaption, SizeOf(NewCaption)); 105 | C := @NewCaption; 106 | {$ELSE} 107 | {$IFNDEF Delphi3orHigher} 108 | NewCaption := LoadStr(DefaultCaptions[Typ]); 109 | {$ELSE} 110 | NewCaption := LoadResString(DefaultCaptions[Typ]); 111 | {$ENDIF} 112 | C := PChar(NewCaption); 113 | {$ENDIF} 114 | end; 115 | end; 116 | Result := Application.MessageBox(Text, C, Buttons or IconFlags[Typ]); 117 | finally 118 | { Reenable forms, restore top mosts, and restore focus } 119 | for I := 0 to StayOnTopList.Count-1 do 120 | SetWindowPos (TForm(StayOnTopList[I]).Handle, HWND_TOPMOST, 121 | 0, 0, 0, 0, SWP_NOACTIVATE or SWP_NOMOVE or SWP_NOSIZE); 122 | for I := 0 to EnabledList.Count-1 do 123 | EnableWindow (TForm(EnabledList[I]).Handle, True); 124 | { Restore focus } 125 | if ActiveCtl <> nil then 126 | SetFocus (ActiveCtl.Handle); 127 | end; 128 | finally 129 | StayOnTopList.Free; 130 | EnabledList.Free; 131 | end; 132 | end; 133 | 134 | function MsgBox ({$IFDEF WIN32}const{$ENDIF} Text, Caption: String; 135 | const Typ: TMsgBoxType; const Buttons: Cardinal): Integer; 136 | begin 137 | Result := MsgBoxP(StringAsPChar(Text), StringAsPChar(Caption), Typ, Buttons); 138 | end; 139 | 140 | function MsgBoxFmt (const Text: String; const Args: array of const; 141 | const Caption: String; const Typ: TMsgBoxType; const Buttons: Cardinal): Integer; 142 | begin 143 | Result := MsgBox(Format(Text, Args), Caption, Typ, Buttons); 144 | end; 145 | 146 | procedure FreeCaptions; far; 147 | var 148 | T: TMsgBoxType; 149 | begin 150 | for T := Low(T) to High(T) do begin 151 | StrDispose (MessageBoxCaptions[T]); 152 | MessageBoxCaptions[T] := nil; 153 | end; 154 | end; 155 | 156 | {$IFDEF WIN32} 157 | initialization 158 | finalization 159 | FreeCaptions; 160 | {$ELSE} 161 | begin 162 | AddExitProc (FreeCaptions); 163 | {$ENDIF} 164 | end. 165 | -------------------------------------------------------------------------------- /Src/CmnFunc2.pas: -------------------------------------------------------------------------------- 1 | unit CmnFunc2; 2 | {$B-} 3 | { v2.25 } 4 | { This is a general toolchest of non-VCL functions I use in my programs. } 5 | 6 | interface 7 | 8 | uses 9 | WinProcs, WinTypes, SysUtils; 10 | 11 | {$IFNDEF VER80} {$IFNDEF VER90} {$IFNDEF VER93} 12 | {$DEFINE Delphi3orHigher} 13 | {$ENDIF} {$ENDIF} {$ENDIF} 14 | 15 | { Delphi 2 and Win32 compatibility types, constants, and functions } 16 | {$IFNDEF WIN32} 17 | type 18 | UINT = Word; 19 | DWORD = Longint; 20 | 21 | const 22 | MAX_PATH = 255; 23 | Full_MAX_PATH = 260; 24 | VK_APPS = 93; 25 | 26 | procedure SetLength (var S: OpenString; NewLength: Integer); 27 | procedure SetString (var S: OpenString; const Buffer: PChar; Len: Integer); 28 | function StringAsPChar (var S: OpenString): PChar; 29 | function Trim (const S: String): String; 30 | function TrimLeft (const S: String): String; 31 | function TrimRight (const S: String): String; 32 | function GetCurrentDir: String; 33 | function SetCurrentDir (const Dir: String): Boolean; 34 | function ExtractFileDrive(const FileName: string): string; 35 | {$ELSE} 36 | const 37 | Full_MAX_PATH = MAX_PATH; 38 | type 39 | StringAsPChar = PChar; 40 | {$ENDIF} 41 | 42 | { Delphi 2.01's RegStr unit should never be used because it contains many 43 | wrong declarations. Delphi 3's RegStr unit doesn't have this problem, but 44 | for backward compatibility, it defines a few of the correct registry key 45 | constants here. } 46 | {$IFDEF WIN32} 47 | const 48 | { Do NOT localize any of these } 49 | NEWREGSTR_PATH_SETUP = 'Software\Microsoft\Windows\CurrentVersion'; 50 | NEWREGSTR_PATH_EXPLORER = NEWREGSTR_PATH_SETUP + '\Explorer'; 51 | NEWREGSTR_PATH_SPECIAL_FOLDERS = NEWREGSTR_PATH_EXPLORER + '\Shell Folders'; 52 | NEWREGSTR_PATH_UNINSTALL = NEWREGSTR_PATH_SETUP + '\Uninstall'; 53 | NEWREGSTR_VAL_UNINSTALLER_DISPLAYNAME = 'DisplayName'; 54 | NEWREGSTR_VAL_UNINSTALLER_COMMANDLINE = 'UninstallString'; 55 | {$ENDIF} 56 | 57 | function DirExists (const Name: String): Boolean; 58 | function FileOrDirExists (const Name: String): Boolean; 59 | function GetIniString ({$IFDEF WIN32}const{$ENDIF} Section, Key, Default, Filename: String): String; 60 | function GetIniInt (const Section, Key: String; const Default, Min, Max: Longint; const Filename: String): Longint; 61 | function GetIniBool (const Section, Key: String; const Default: Boolean; const Filename: String): Boolean; 62 | function IniKeyExists ({$IFDEF WIN32}const{$ENDIF} Section, Key, Filename: String): Boolean; 63 | function IsIniSectionEmpty ({$IFDEF WIN32}const{$ENDIF} Section, Filename: String): Boolean; 64 | function SetIniString ({$IFDEF WIN32}const{$ENDIF} Section, Key, Value, Filename: String): Boolean; 65 | function SetIniInt (const Section, Key: String; const Value: Longint; const Filename: String): Boolean; 66 | function SetIniBool (const Section, Key: String; const Value: Boolean; const Filename: String): Boolean; 67 | procedure DeleteIniEntry ({$IFDEF WIN32}const{$ENDIF} Section, Key, Filename: String); 68 | procedure DeleteIniSection ({$IFDEF WIN32}const{$ENDIF} Section, Filename: String); 69 | function GetEnv (const EnvVar: String): String; 70 | function GetCmdTail: String; 71 | function NewParamCount: Integer; 72 | function NewParamStr (Index: Integer): string; 73 | function AddBackslash (const S: String): String; 74 | function RemoveBackslash (const S: String): String; 75 | function RemoveBackslashUnlessRoot (const S: String): String; 76 | function AddQuotes (const S: String): String; 77 | function RemoveQuotes (const S: String): String; 78 | function GetShortName (const LongName: String): String; 79 | function GetWinDir: String; 80 | function GetSystemDir: String; 81 | function GetTempDir: String; 82 | procedure StringChange (var S: String; const FromStr, ToStr: String); 83 | function AdjustLength (var S: String; const Res: Cardinal): Boolean; 84 | function UsingWinNT: Boolean; 85 | function UsingNewGUI: Boolean; 86 | function FileCopy (const ExistingFile, NewFile: String; const FailIfExists: Boolean; 87 | const AReadMode: Byte): Boolean; 88 | {$IFDEF WIN32} 89 | function UsingWindows4: Boolean; 90 | function RegQueryStringValue (H: HKEY; Name: PChar; var ResultStr: String): Boolean; 91 | function RegQueryMultiStringValue (H: HKEY; Name: PChar; var ResultStr: String): Boolean; 92 | function RegValueExists (H: HKEY; Name: PChar): Boolean; 93 | function RegDeleteKeyIncludingSubkeys (const Key: HKEY; const Name: PChar): Boolean; 94 | function GetShellFolderPath (const FolderID: Integer): String; 95 | function GetProgramFilesPath: String; 96 | function GetCommonFilesPath: String; 97 | function IsAdminLoggedOn: Boolean; 98 | {$ENDIF} 99 | 100 | implementation 101 | 102 | {$IFDEF WIN32} 103 | uses 104 | {$IFDEF VER90} OLE2, {$ELSE} ActiveX, {$ENDIF} ShlObj; 105 | 106 | var 107 | IsWindows4: Boolean; 108 | {$ENDIF} 109 | 110 | {$IFNDEF WIN32} 111 | procedure SetLength (var S: OpenString; NewLength: Integer); 112 | begin 113 | if NewLength > 255 then NewLength := 255; 114 | Byte(S[0]) := NewLength; 115 | end; 116 | 117 | procedure SetString (var S: OpenString; const Buffer: PChar; Len: Integer); 118 | begin 119 | if Len > 255 then Len := 255; 120 | Byte(S[0]) := Len; 121 | if Buffer <> nil then 122 | Move (Buffer^, S[1], Len); 123 | end; 124 | 125 | function StringAsPChar (var S: OpenString): PChar; 126 | begin 127 | if Length(S) = High(S) then Dec (S[0]); 128 | S[Length(S)+1] := #0; 129 | Result := @S[1]; 130 | end; 131 | 132 | function Trim (const S: String): String; 133 | begin 134 | Result := TrimLeft(TrimRight(S)); 135 | end; 136 | 137 | function TrimLeft (const S: String): String; 138 | var 139 | I, L: Integer; 140 | begin 141 | L := Length(S); 142 | I := 1; 143 | while (I <= L) and (S[I] <= ' ') do Inc (I); 144 | Result := Copy(S, I, Maxint); 145 | end; 146 | 147 | function TrimRight (const S: String): String; 148 | begin 149 | Result := S; 150 | while (Result <> '') and (Result[Length(Result)] <= ' ') do 151 | Dec (Result[0]); 152 | end; 153 | 154 | function GetCurrentDir: String; 155 | begin 156 | GetDir (0, Result); 157 | end; 158 | 159 | function SetCurrentDir (const Dir: String): Boolean; 160 | begin 161 | Result := False; 162 | if not DirExists(Dir) then Exit; 163 | try 164 | ChDir (Dir); 165 | except 166 | Exit; 167 | end; 168 | Result := True; 169 | end; 170 | 171 | function ExtractFileDrive(const FileName: string): string; 172 | var 173 | I, J: Integer; 174 | begin 175 | if (Length(FileName) >= 2) and (FileName[2] = ':') then 176 | Result := Copy(FileName, 1, 2) 177 | else if (Length(FileName) >= 2) and (FileName[1] = '\') and 178 | (FileName[2] = '\') then 179 | begin 180 | J := 0; 181 | I := 3; 182 | While (I < Length(FileName)) and (J < 2) do 183 | begin 184 | if FileName[I] = '\' then Inc(J); 185 | if J < 2 then Inc(I); 186 | end; 187 | if FileName[I] = '\' then Dec(I); 188 | Result := Copy(FileName, 1, I); 189 | end else Result := ''; 190 | end; 191 | {$ENDIF} 192 | 193 | function InternalGetFileAttr (const Name: String): Integer; 194 | var 195 | OldErrorMode: UINT; 196 | begin 197 | OldErrorMode := SetErrorMode(SEM_FAILCRITICALERRORS); { Prevent "Network Error" boxes } 198 | try 199 | {$IFDEF WIN32} 200 | Result := GetFileAttributes(PChar(RemoveBackslashUnlessRoot(Name))); 201 | {$ELSE} 202 | Result := FileGetAttr(RemoveBackslashUnlessRoot(Name)); 203 | {$ENDIF} 204 | finally 205 | SetErrorMode (OldErrorMode); 206 | end; 207 | end; 208 | 209 | function DirExists (const Name: String): Boolean; 210 | { Returns True if the specified directory name exists. The specified name 211 | may include a trailing backslash. 212 | NOTE: Delphi's FileCtrl unit has a similar function called DirectoryExists. 213 | However, the implementation is different between Delphi 1 and 2. (Delphi 1 214 | does not count hidden or system directories as existing.) } 215 | var 216 | Attr: Integer; 217 | begin 218 | Attr := InternalGetFileAttr(Name); 219 | Result := (Attr >= 0) and (Attr and faDirectory <> 0); 220 | end; 221 | 222 | function FileOrDirExists (const Name: String): Boolean; 223 | { Returns True if the specified directory or file name exists. The specified 224 | name may include a trailing backslash. } 225 | begin 226 | Result := InternalGetFileAttr(Name) >= 0; 227 | end; 228 | 229 | function GetIniString ({$IFDEF WIN32}const{$ENDIF} Section, Key, Default, Filename: String): String; 230 | {$IFNDEF WIN32} 231 | var 232 | Buf: array[0..255] of Char; 233 | {$ENDIF} 234 | begin 235 | {$IFDEF WIN32} 236 | SetLength (Result, 1023); 237 | if Filename <> '' then 238 | SetLength (Result, GetPrivateProfileString( 239 | StringAsPChar(Section), StringAsPChar(Key), StringAsPChar(Default), 240 | @Result[1], 1024, StringAsPChar(Filename))) 241 | else 242 | SetLength (Result, GetProfileString( 243 | StringAsPChar(Section), StringAsPChar(Key), StringAsPChar(Default), 244 | @Result[1], 1024)); 245 | {$ELSE} 246 | if Filename <> '' then 247 | GetPrivateProfileString (StringAsPChar(Section), StringAsPChar(Key), 248 | StringAsPChar(Default), Buf, SizeOf(Buf), StringAsPChar(Filename)) 249 | else 250 | GetProfileString (StringAsPChar(Section), StringAsPChar(Key), 251 | StringAsPChar(Default), Buf, SizeOf(Buf)); 252 | Result := StrPas(Buf); 253 | {$ENDIF} 254 | end; 255 | 256 | function GetIniInt (const Section, Key: String; 257 | const Default, Min, Max: Longint; const Filename: String): Longint; 258 | { Reads a Longint from an INI file. If the Longint read is not between Min/Max 259 | then it returns Default. If Min=Max then Min/Max are ignored } 260 | var 261 | S: String; 262 | E: Integer; 263 | begin 264 | S := GetIniString(Section, Key, '', Filename); 265 | if S = '' then 266 | Result := Default 267 | else begin 268 | Val (S, Result, E); 269 | if (E <> 0) or ((Min <> Max) and ((Result < Min) or (Result > Max))) then 270 | Result := Default; 271 | end; 272 | end; 273 | 274 | function GetIniBool (const Section, Key: String; const Default: Boolean; 275 | const Filename: String): Boolean; 276 | begin 277 | Result := GetIniInt(Section, Key, Ord(Default), 0, 0, Filename) <> 0; 278 | end; 279 | 280 | function IniKeyExists ({$IFDEF WIN32}const{$ENDIF} Section, Key, Filename: String): Boolean; 281 | function Equals (const Default: PChar): Boolean; 282 | var 283 | Test: array[0..7] of Char; 284 | begin 285 | Test[0] := #0; 286 | if Filename <> '' then 287 | GetPrivateProfileString (StringAsPChar(Section), StringAsPChar(Key), Default, 288 | Test, SizeOf(Test), StringAsPChar(Filename)) 289 | else 290 | GetProfileString (StringAsPChar(Section), StringAsPChar(Key), Default, 291 | Test, SizeOf(Test)); 292 | Result := lstrcmp(Test, Default) = 0; 293 | end; 294 | begin 295 | { If the key does not exist, a default string is returned both times. } 296 | Result := not Equals('x1234x') or not Equals('x5678x'); { <- don't change } 297 | end; 298 | 299 | function IsIniSectionEmpty ({$IFDEF WIN32}const{$ENDIF} Section, Filename: String): Boolean; 300 | var 301 | Test: array[0..255] of Char; 302 | begin 303 | Test[0] := #0; 304 | if Filename <> '' then 305 | GetPrivateProfileString (StringAsPChar(Section), nil, '', Test, 306 | SizeOf(Test), StringAsPChar(Filename)) 307 | else 308 | GetProfileString (StringAsPChar(Section), nil, '', Test, SizeOf(Test)); 309 | Result := Test[0] = #0; 310 | end; 311 | 312 | function SetIniString ({$IFDEF WIN32}const{$ENDIF} Section, Key, Value, Filename: String): Boolean; 313 | begin 314 | if Filename <> '' then 315 | Result := WritePrivateProfileString(StringAsPChar(Section), StringAsPChar(Key), 316 | StringAsPChar(Value), StringAsPChar(Filename)) 317 | else 318 | Result := WriteProfileString(StringAsPChar(Section), StringAsPChar(Key), 319 | StringAsPChar(Value)); 320 | end; 321 | 322 | function SetIniInt (const Section, Key: String; const Value: Longint; 323 | const Filename: String): Boolean; 324 | begin 325 | Result := SetIniString(Section, Key, IntToStr(Value), Filename); 326 | end; 327 | 328 | function SetIniBool (const Section, Key: String; const Value: Boolean; 329 | const Filename: String): Boolean; 330 | begin 331 | Result := SetIniInt(Section, Key, Ord(Value), Filename); 332 | end; 333 | 334 | procedure DeleteIniEntry ({$IFDEF WIN32}const{$ENDIF} Section, Key, Filename: String); 335 | begin 336 | if Filename <> '' then 337 | WritePrivateProfileString (StringAsPChar(Section), StringAsPChar(Key), 338 | nil, StringAsPChar(Filename)) 339 | else 340 | WriteProfileString (StringAsPChar(Section), StringAsPChar(Key), 341 | nil); 342 | end; 343 | 344 | procedure DeleteIniSection ({$IFDEF WIN32}const{$ENDIF} Section, Filename: String); 345 | begin 346 | if Filename <> '' then 347 | WritePrivateProfileString (StringAsPChar(Section), nil, nil, 348 | StringAsPChar(Filename)) 349 | else 350 | WriteProfileString (StringAsPChar(Section), nil, nil); 351 | end; 352 | 353 | function GetEnv (const EnvVar: String): String; 354 | { Gets the value of the specified environment variable. (Just like TP's GetEnv) } 355 | var 356 | {$IFDEF WIN32} 357 | Res: DWORD; 358 | {$ELSE} 359 | Env, Value: PChar; 360 | Len, VarLen, ValueLen: Integer; 361 | {$ENDIF} 362 | begin 363 | {$IFDEF WIN32} 364 | SetLength (Result, 255); 365 | repeat 366 | Res := GetEnvironmentVariable(PChar(EnvVar), PChar(Result), Length(Result)); 367 | if Res = 0 then begin 368 | Result := ''; 369 | Break; 370 | end; 371 | until AdjustLength(Result, Res); 372 | {$ELSE} 373 | Result[0] := #0; 374 | Env := GetDOSEnvironment; 375 | while Env^ <> #0 do begin 376 | Len := StrLen(Env); 377 | Value := StrScan(Env, '='); 378 | if Value <> nil then begin 379 | VarLen := Value-Env; 380 | if VarLen = Length(EnvVar) then begin 381 | if StrLIComp(Env, @EnvVar[1], VarLen) = 0 then begin 382 | ValueLen := Len-VarLen-1; 383 | if ValueLen > 255 then ValueLen := 255; 384 | Byte(Result[0]) := ValueLen; 385 | Inc (Value); 386 | Move (Value^, Result[1], ValueLen); 387 | Break; 388 | end; 389 | end; 390 | end; 391 | Inc (Env, Len+1); 392 | end; 393 | {$ENDIF} 394 | end; 395 | 396 | function GetCmdTail: String; 397 | { Returns all command line parameters passed to the process as a single 398 | string. } 399 | {$IFNDEF WIN32} 400 | var 401 | B: Word; 402 | S: String; 403 | I: Integer; 404 | begin 405 | S := PString(Ptr(PrefixSeg, $80))^; 406 | Result := ''; 407 | for I := 1 to Length(S) do 408 | if not(S[I] in [#9, ' ']) then begin 409 | Result := Copy(S, I, Maxint); 410 | Break; 411 | end; 412 | end; 413 | {$ELSE} 414 | var 415 | CmdLine: PChar; 416 | InQuote: Boolean; 417 | begin 418 | CmdLine := GetCommandLine; 419 | InQuote := False; 420 | while True do begin 421 | case CmdLine^ of 422 | #0: Break; 423 | '"': InQuote := not InQuote; 424 | ' ': if not InQuote then Break; 425 | end; 426 | Inc (CmdLine); 427 | end; 428 | while CmdLine^ = ' ' do 429 | Inc (CmdLine); 430 | Result := CmdLine; 431 | end; 432 | {$ENDIF} 433 | 434 | function GetParamStr (P: PChar; var Param: String): PChar; 435 | var 436 | Len: {$IFDEF WIN32} Integer; {$ELSE} Word; {$ENDIF} 437 | Buffer: array[0..4095] of Char; 438 | begin 439 | while True do begin 440 | while (P[0] <> #0) and (P[0] <= ' ') do Inc (P); 441 | if (P[0] = '"') and (P[1] = '"') then Inc (P, 2) else Break; 442 | end; 443 | Len := 0; 444 | while (P[0] > ' ') and (Len < SizeOf(Buffer)) do 445 | if P[0] = '"' then begin 446 | Inc (P); 447 | while (P[0] <> #0) and (P[0] <> '"') do begin 448 | Buffer[Len] := P[0]; 449 | Inc (Len); 450 | Inc (P); 451 | end; 452 | if P[0] <> #0 then Inc (P); 453 | end 454 | else begin 455 | Buffer[Len] := P[0]; 456 | Inc (Len); 457 | Inc (P); 458 | end; 459 | SetString (Param, Buffer, Len); 460 | Result := P; 461 | end; 462 | 463 | function NewParamCount: Integer; 464 | var 465 | P2: {$IFDEF WIN32} String; {$ELSE} array[0..255] of Char; {$ENDIF} 466 | P: PChar; 467 | S: string; 468 | begin 469 | {$IFDEF WIN32} 470 | P2 := GetCmdTail; 471 | P := PChar(P2); 472 | {$ELSE} 473 | StrPCopy (P2, GetCmdTail); 474 | P := @P2; 475 | {$ENDIF} 476 | Result := 0; 477 | while True do begin 478 | P := GetParamStr(P, S); 479 | if S = '' then Break; 480 | Inc (Result); 481 | end; 482 | end; 483 | 484 | function NewParamStr (Index: Integer): string; 485 | var 486 | {$IFDEF WIN32} 487 | Buffer: array[0..MAX_PATH-1] of Char; 488 | {$ENDIF} 489 | P2: {$IFDEF WIN32} String; {$ELSE} array[0..255] of Char; {$ENDIF} 490 | P: PChar; 491 | begin 492 | if Index = 0 then begin 493 | {$IFDEF WIN32} 494 | SetString (Result, Buffer, GetModuleFileName(0, Buffer, SizeOf(Buffer))); 495 | {$ELSE} 496 | Result := ParamStr(0); 497 | { for some reason the following doesn't work on Win95, only NT... 498 | P := GetDOSEnvironment; 499 | while P^ <> #0 do 500 | Inc (P, StrLen(P)+1); 501 | Inc (P, 3); 502 | Result := StrPas(P); } 503 | {$ENDIF} 504 | end 505 | else begin 506 | {$IFDEF WIN32} 507 | P2 := GetCmdTail; 508 | P := PChar(P2); 509 | {$ELSE} 510 | StrPCopy (P2, GetCmdTail); 511 | P := @P2; 512 | {$ENDIF} 513 | while True do begin 514 | P := GetParamStr(P, Result); 515 | if (Index = 1) or (Result = '') then Break; 516 | Dec (Index); 517 | end; 518 | end; 519 | end; 520 | 521 | function AddBackslash (const S: String): String; 522 | { Adds a trailing backslash to the string, if one wasn't there already. 523 | But if S is an empty string, the function returns an empty string. } 524 | begin 525 | Result := S; 526 | if (Result <> '') and (Result[Length(Result)] <> '\') then 527 | Result := Result + '\'; 528 | end; 529 | 530 | function RemoveBackslash (const S: String): String; 531 | { Removes the trailing backslash from the string, if one exists } 532 | begin 533 | Result := S; 534 | if (Result <> '') and (Result[Length(Result)] = '\') then 535 | {$IFNDEF WIN32} 536 | Dec (Result[0]); 537 | {$ELSE} 538 | SetLength (Result, Length(Result)-1); 539 | {$ENDIF} 540 | end; 541 | 542 | function RemoveBackslashUnlessRoot (const S: String): String; 543 | { Removes the trailing backslash from the string, if one exists and if does 544 | not specify a root directory of a drive (i.e. "C:\"} 545 | begin 546 | Result := S; 547 | if (Length(Result) >= 2) and (Result[Length(Result)] = '\') and 548 | (Result[Length(Result)-1] <> ':') then 549 | {$IFNDEF WIN32} 550 | Dec (Result[0]); 551 | {$ELSE} 552 | SetLength (Result, Length(Result)-1); 553 | {$ENDIF} 554 | end; 555 | 556 | function AddQuotes (const S: String): String; 557 | { Adds a quote (") character to the left and right sides of the string if 558 | the string contains a space and it didn't have quotes already. This is 559 | primarily used when spawning another process with a long filename as one of 560 | the parameters. } 561 | begin 562 | Result := Trim(S); 563 | if (Pos(' ', Result) <> 0) and 564 | ((Result[1] <> '"') or (Result[Length(Result)] <> '"')) then 565 | Result := '"' + Result + '"'; 566 | end; 567 | 568 | function RemoveQuotes (const S: String): String; 569 | { Opposite of AddQuotes; removes any quotes around the string. } 570 | begin 571 | Result := S; 572 | while (Result <> '') and (Result[1] = '"') do 573 | Delete (Result, 1, 1); 574 | while (Result <> '') and (Result[Length(Result)] = '"') do 575 | {$IFNDEF WIN32} 576 | Dec (Result[0]); 577 | {$ELSE} 578 | SetLength (Result, Length(Result)-1); 579 | {$ENDIF} 580 | end; 581 | 582 | function GetShortName (const LongName: String): String; 583 | { Gets the short version of the specified long filename. Does nothing on 584 | Win16 } 585 | {$IFDEF WIN32} 586 | var 587 | Res: DWORD; 588 | {$ENDIF} 589 | begin 590 | {$IFNDEF WIN32} 591 | Result := LongName; 592 | {$ELSE} 593 | SetLength (Result, MAX_PATH); 594 | repeat 595 | Res := GetShortPathName(PChar(LongName), PChar(Result), Length(Result)); 596 | if Res = 0 then begin 597 | Result := LongName; 598 | Break; 599 | end; 600 | until AdjustLength(Result, Res); 601 | {$ENDIF} 602 | end; 603 | 604 | function GetWinDir: String; 605 | { Returns fully qualified path of the Windows directory. Only includes a 606 | trailing backslash if the Windows directory is the root directory. } 607 | var 608 | Buf: array[0..Full_MAX_PATH-1] of Char; 609 | begin 610 | GetWindowsDirectory (Buf, SizeOf(Buf)); 611 | Result := StrPas(Buf); 612 | end; 613 | 614 | function GetSystemDir: String; 615 | { Returns fully qualified path of the Windows System directory. Only includes a 616 | trailing backslash if the Windows System directory is the root directory. } 617 | var 618 | Buf: array[0..Full_MAX_PATH-1] of Char; 619 | begin 620 | GetSystemDirectory (Buf, SizeOf(Buf)); 621 | Result := StrPas(Buf); 622 | end; 623 | 624 | function GetTempDir: String; 625 | { Returns fully qualified path of the temporary directory, with trailing 626 | backslash. This does not use the Win32 function GetTempPath, due to platform 627 | differences. 628 | 629 | Gets the temporary file path as follows: 630 | 1. The path specified by the TMP environment variable. 631 | 2. The path specified by the TEMP environment variable, if TMP is not 632 | defined or if TMP specifies a directory that does not exist. 633 | 3. The Windows directory, if both TMP and TEMP are not defined or specify 634 | nonexistent directories. 635 | } 636 | begin 637 | Result := GetEnv('TMP'); 638 | if (Result = '') or not DirExists(Result) then 639 | Result := GetEnv('TEMP'); 640 | if (Result = '') or not DirExists(Result) then 641 | Result := GetWinDir; 642 | Result := AddBackslash(ExpandFileName(Result)); 643 | end; 644 | 645 | procedure StringChange (var S: String; const FromStr, ToStr: String); 646 | { Change all occurances in S of FromStr to ToStr } 647 | var 648 | StartPos, I: Integer; 649 | label 1; 650 | begin 651 | if FromStr = '' then Exit; 652 | StartPos := 1; 653 | 1:for I := StartPos to Length(S)-Length(FromStr)+1 do begin 654 | if Copy(S, I, Length(FromStr)) = FromStr then begin 655 | Delete (S, I, Length(FromStr)); 656 | Insert (ToStr, S, I); 657 | StartPos := I + Length(ToStr); 658 | goto 1; 659 | end; 660 | end; 661 | end; 662 | 663 | function AdjustLength (var S: String; const Res: Cardinal): Boolean; 664 | { Returns True if successful. Returns False if buffer wasn't large enough, 665 | and called AdjustLength to resize it. } 666 | begin 667 | Result := {$IFDEF WIN32}Integer({$ENDIF} Res {$IFDEF WIN32}){$ENDIF} < Length(S); 668 | SetLength (S, Res); 669 | end; 670 | 671 | function UsingWinNT: Boolean; 672 | { Returns True if system is running any version of Windows NT. Never returns 673 | True on Windows 95 or 3.1. } 674 | begin 675 | {$IFNDEF WIN32} 676 | Result := GetWinFlags and $4000{WF_WINNT} <> 0; 677 | {$ELSE} 678 | Result := Win32Platform = VER_PLATFORM_WIN32_NT; 679 | {$ENDIF} 680 | end; 681 | 682 | {$IFDEF WIN32} 683 | function UsingWindows4: Boolean; 684 | begin 685 | Result := IsWindows4; 686 | end; 687 | {$ENDIF} 688 | 689 | function UsingNewGUI: Boolean; 690 | { Returns True if system is using Windows 95-style GUI. This means it will 691 | return True on Windows 95 or NT 4.0. } 692 | {$IFNDEF WIN32} 693 | const 694 | GUI: (guiOld, guiNew, guiNotChecked) = guiNotChecked; 695 | var 696 | KernelHandle: THandle; 697 | {$ENDIF} 698 | begin 699 | {$IFDEF WIN32} 700 | Result := IsWindows4; 701 | {$ELSE} 702 | if GUI = guiNotChecked then begin 703 | KernelHandle := LoadLibrary('KERNEL'); 704 | Boolean(GUI) := GetProcAddress(KernelHandle, 'GetVersionEx') <> nil; 705 | FreeLibrary (KernelHandle); 706 | end; 707 | Result := Boolean(GUI); 708 | {$ENDIF} 709 | end; 710 | 711 | function FileCopy (const ExistingFile, NewFile: String; 712 | const FailIfExists: Boolean; const AReadMode: Byte): Boolean; 713 | { Copies ExistingFile to NewFile, preserving time stamp and file attributes. 714 | If FailIfExists is True it will fail if NewFile already exists, otherwise it 715 | will overwrite it. 716 | Returns True if succesful; False if not. On Win32, the thread's last error 717 | code is also set. } 718 | {$IFNDEF WIN32} 719 | type 720 | PCopyBuffer = ^TCopyBuffer; 721 | TCopyBuffer = array[0..32767] of Byte; 722 | var 723 | Buffer: PCopyBuffer; 724 | SaveFileMode: Byte; 725 | ExistingF, NewF: File; 726 | NumRead: Word; 727 | FileDate: Longint; 728 | FileAttr: Integer; 729 | {$ENDIF} 730 | begin 731 | {$IFDEF WIN32} 732 | Result := CopyFile(PChar(ExistingFile), PChar(NewFile), FailIfExists); 733 | {$ELSE} 734 | Result := False; 735 | try 736 | if FailIfExists and FileOrDirExists(NewFile) then Exit; 737 | New (Buffer); 738 | SaveFileMode := FileMode; 739 | try 740 | AssignFile (ExistingF, ExistingFile); 741 | FileMode := AReadMode; Reset (ExistingF, 1); 742 | try 743 | AssignFile (NewF, NewFile); 744 | FileMode := fmOpenWrite or fmShareExclusive; Rewrite (NewF, 1); 745 | try 746 | while not Eof(ExistingF) do begin 747 | BlockRead (ExistingF, Buffer^, SizeOf(TCopyBuffer), NumRead); 748 | BlockWrite (NewF, Buffer^, NumRead); 749 | end; 750 | except 751 | CloseFile (NewF); 752 | DeleteFile (NewFile); 753 | raise; 754 | end; 755 | FileDate := FileGetDate(TFileRec(ExistingF).Handle); 756 | FileSetDate (TFileRec(NewF).Handle, FileDate); 757 | CloseFile (NewF); 758 | finally 759 | CloseFile (ExistingF); 760 | end; 761 | finally 762 | FileMode := SaveFileMode; 763 | Dispose (Buffer); 764 | end; 765 | FileAttr := FileGetAttr(ExistingFile); 766 | if FileAttr >= 0 then FileSetAttr (NewFile, FileAttr); 767 | 768 | Result := True; 769 | except 770 | { To maintain compatibility with the Win32 function CopyFile, this 771 | function traps all exceptions. It returns False if unsuccessful. } 772 | end; 773 | {$ENDIF} 774 | end; 775 | 776 | {$IFDEF WIN32} 777 | function InternalRegQueryStringValue (H: HKEY; Name: PChar; var ResultStr: String; 778 | Type1, Type2: DWORD): Boolean; 779 | var 780 | Typ, Size: DWORD; 781 | begin 782 | Result := False; 783 | if (RegQueryValueEx(H, Name, nil, @Typ, nil, @Size) = ERROR_SUCCESS) and 784 | ((Typ = Type1) or (Typ = Type2)) then begin 785 | if Size < 2 then begin {for the following code to work properly, Size can't be 0 or 1} 786 | ResultStr := ''; 787 | Result := True; 788 | end 789 | else begin 790 | SetLength (ResultStr, Size-1); {long strings implicity include a null terminator} 791 | if RegQueryValueEx(H, Name, nil, nil, @ResultStr[1], @Size) = ERROR_SUCCESS then 792 | Result := True 793 | else 794 | ResultStr := ''; 795 | end; 796 | end; 797 | end; 798 | 799 | function RegQueryStringValue (H: HKEY; Name: PChar; var ResultStr: String): Boolean; 800 | { Queries the specified REG_SZ or REG_EXPAND_SZ registry key/value, and returns 801 | the value in ResultStr. Returns True if successful. } 802 | begin 803 | Result := InternalRegQueryStringValue(H, Name, ResultStr, REG_SZ, 804 | REG_EXPAND_SZ); 805 | end; 806 | 807 | function RegQueryMultiStringValue (H: HKEY; Name: PChar; var ResultStr: String): Boolean; 808 | { Queries the specified REG_MULTI_SZ registry key/value, and returns the value 809 | in ResultStr. Returns True if successful. } 810 | begin 811 | Result := InternalRegQueryStringValue(H, Name, ResultStr, REG_MULTI_SZ, 812 | REG_MULTI_SZ); 813 | end; 814 | {$ENDIF} 815 | 816 | {$IFDEF WIN32} 817 | function RegValueExists (H: HKEY; Name: PChar): Boolean; 818 | { Returns True if the specified value exists. Requires KEY_QUERY_VALUE and 819 | KEY_ENUMERATE_SUB_KEYS access to the key. } 820 | var 821 | I: Integer; 822 | EnumName: array[0..1] of Char; 823 | Count: DWORD; 824 | ErrorCode: Longint; 825 | begin 826 | Result := RegQueryValueEx(H, Name, nil, nil, nil, nil) = ERROR_SUCCESS; 827 | if Result and ((Name = nil) or (Name^ = #0)) then begin 828 | { On Win95/98 a default value always exists according to RegQueryValueEx, 829 | so it must use RegQueryValueEx instead to check if a default value 830 | really exists } 831 | Result := False; 832 | I := 0; 833 | while True do begin 834 | Count := SizeOf(EnumName); 835 | ErrorCode := RegEnumValue(H, I, EnumName, Count, nil, nil, nil, nil); 836 | if (ErrorCode <> ERROR_SUCCESS) and (ErrorCode <> ERROR_MORE_DATA) then 837 | Break; 838 | if EnumName[0] = #0 then begin { is it the default value? } 839 | Result := True; 840 | Break; 841 | end; 842 | Inc (I); 843 | end; 844 | end; 845 | end; 846 | {$ENDIF} 847 | 848 | {$IFDEF WIN32} 849 | function RegDeleteKeyIncludingSubkeys (const Key: HKEY; const Name: PChar): Boolean; 850 | var 851 | H: HKEY; 852 | KeyName: String; 853 | KeyNameCount, MaxCount: DWORD; 854 | FT: TFileTime; 855 | I: Integer; 856 | begin 857 | if Win32Platform = VER_PLATFORM_WIN32_NT then begin 858 | Result := False; 859 | if RegOpenKeyEx(Key, Name, 0, KEY_ENUMERATE_SUB_KEYS or KEY_QUERY_VALUE, H) <> ERROR_SUCCESS then 860 | Exit; 861 | if RegQueryInfoKey(H, nil, nil, nil, nil, @MaxCount, nil, nil, nil, nil, 862 | nil, nil) = ERROR_SUCCESS then begin 863 | if MaxCount < 1 then MaxCount := 1; 864 | SetLength (KeyName, MaxCount); 865 | I := 0; 866 | while True do begin 867 | KeyNameCount := MaxCount+1; 868 | if RegEnumKeyEx(H, I, PChar(KeyName), KeyNameCount, nil, nil, nil, @FT) <> ERROR_SUCCESS then 869 | Break; 870 | if not RegDeleteKeyIncludingSubkeys(H, PChar(KeyName)) then 871 | Inc (I); 872 | end; 873 | end; 874 | RegCloseKey (H); 875 | end; 876 | Result := RegDeleteKey(Key, Name) = ERROR_SUCCESS; 877 | end; 878 | {$ENDIF} 879 | 880 | {$IFDEF WIN32} 881 | function GetShellFolderPath (const FolderID: Integer): String; 882 | var 883 | pidl: PItemIDList; 884 | Buffer: array[0..MAX_PATH-1] of Char; 885 | Malloc: IMalloc; 886 | begin 887 | Result := ''; 888 | if not IsWindows4 then Exit; 889 | if FAILED(SHGetMalloc(Malloc)) then 890 | Malloc := nil; 891 | if SUCCEEDED(SHGetSpecialFolderLocation(0, FolderID, pidl)) then begin 892 | if SHGetPathFromIDList(pidl, Buffer) then 893 | Result := Buffer; 894 | if Assigned(Malloc) then 895 | Malloc.Free (pidl); 896 | end; 897 | end; 898 | {$ENDIF} 899 | 900 | {$IFDEF WIN32} 901 | function GetPathFromRegistry (const Name: PChar): String; 902 | var 903 | H: HKEY; 904 | begin 905 | if IsWindows4 and (RegOpenKeyEx(HKEY_LOCAL_MACHINE, 906 | NEWREGSTR_PATH_SETUP, 0, KEY_QUERY_VALUE, H) = ERROR_SUCCESS) then begin 907 | if not RegQueryStringValue(H, Name, Result) then 908 | Result := ''; 909 | RegCloseKey (H); 910 | end 911 | else 912 | Result := ''; 913 | end; 914 | 915 | function GetProgramFilesPath: String; 916 | { Gets path of Program Files. 917 | Returns blank string if not found in registry. } 918 | begin 919 | Result := GetPathFromRegistry('ProgramFilesDir'); 920 | end; 921 | 922 | function GetCommonFilesPath: String; 923 | { Gets path of Common Files. 924 | Returns blank string if not found in registry. } 925 | begin 926 | Result := GetPathFromRegistry('CommonFilesDir'); 927 | end; 928 | {$ENDIF} 929 | 930 | {$IFDEF WIN32} 931 | type 932 | SC_HANDLE = THandle; 933 | function OpenSCManager(lpMachineName, lpDatabaseName: PChar; 934 | dwDesiredAccess: DWORD): SC_HANDLE; stdcall; 935 | external 'advapi32.dll' name 'OpenSCManagerA'; 936 | function CloseServiceHandle(hSCObject: SC_HANDLE): BOOL; stdcall; 937 | external 'advapi32.dll' name 'CloseServiceHandle'; 938 | function IsAdminLoggedOn: Boolean; 939 | { Returns True if an administrator is logged onto the system. Always returns 940 | True on Windows 95/98. } 941 | var 942 | hSC: SC_HANDLE; 943 | begin 944 | if Win32Platform <> VER_PLATFORM_WIN32_NT then 945 | Result := True 946 | else begin 947 | { Try an admin privileged API } 948 | hSC := OpenSCManager(nil, nil, GENERIC_READ or GENERIC_WRITE or GENERIC_EXECUTE); 949 | Result := hSC <> 0; 950 | if Result then CloseServiceHandle (hSC); 951 | end; 952 | end; 953 | {$ENDIF} 954 | 955 | {$IFDEF WIN32} 956 | initialization 957 | IsWindows4 := Lo(GetVersion) >= 4; 958 | {$ENDIF} 959 | end. 960 | -------------------------------------------------------------------------------- /Src/CodeX86.pas: -------------------------------------------------------------------------------- 1 | unit CodeX86; 2 | 3 | { 4 | Inno Pascal 5 | Copyright (C) 2000 Jordan Russell 6 | 7 | www: http://www.jrsoftware.org/ 8 | or http://www.jordanr.cjb.net/ 9 | email: jr@jrsoftware.org 10 | 11 | This program is free software; you can redistribute it and/or 12 | modify it under the terms of the GNU General Public License 13 | as published by the Free Software Foundation; either version 2 14 | of the License, or (at your option) any later version. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | GNU General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with this program; if not, write to the Free Software 23 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 24 | } 25 | 26 | interface 27 | 28 | { x86 code generator } 29 | 30 | uses 31 | Windows, Classes, Common, IPBase; 32 | 33 | type 34 | TX86Register = (rgEAX, rgECX, rgEDX, rgEBX, rgESP, rgEBP, rgESI, rgEDI, 35 | rgAX, rgCX, rgDX, rgBX, rgSP, rgBP, rgSI, rgDI, 36 | rgAL, rgCL, rgDL, rgBL, rgAH, rgCH, rgDH, rgBH); 37 | 38 | TX86CodeGen = class(TIPCustomCodeGen) 39 | private 40 | ConstAddrFixupList, DataAddrFixupList, FuncAddrFixupList: TList; 41 | public 42 | constructor Create; override; 43 | destructor Destroy; override; 44 | procedure ApplyFixups (Funcs: TList; FuncAddress: TCodeAddr; 45 | CodeVA, ConstVA, BSSVA: TVirtualAddress); override; 46 | procedure AsgRegImm (Reg: TX86Register; Value: Longint); 47 | procedure AsgVarAddrOfConst (Addr: TVarAddr; ConstAddr: TConstAddr); 48 | override; 49 | procedure AsgVarFuncResult (Addr: TVarAddr; Size: TSize); override; 50 | procedure AsgVarImm (Addr: TVarAddr; Size: TSize; Value: Longint); override; 51 | procedure AsgVarPop (Addr: TVarAddr; Size: TSize); override; 52 | procedure AsgVarVar (DestAddr: TVarAddr; DestSize: TSize; 53 | SourceAddr: TVarAddr; SourceSize: TSize); override; 54 | procedure CallFunc (const CallData: TCallData); override; 55 | procedure Expression (const Expr: TExpression); override; 56 | procedure FuncEnd; override; 57 | procedure ImportThunk (ImportAddressVA: TVirtualAddress); override; 58 | procedure PopIntoReg (Reg: TX86Register); 59 | procedure PushAddrOfConst (Addr: TConstAddr); 60 | procedure PushAddrOfVar (Addr: TVarAddr); 61 | procedure PushImm (Value: Longint); 62 | procedure PushReg (Reg: TX86Register); 63 | procedure PushVarAtAddr (Addr: TVarAddr); 64 | end; 65 | 66 | implementation 67 | 68 | type 69 | PFuncAddrFixupRec = ^TFuncAddrFixupRec; 70 | TFuncAddrFixupRec = record 71 | FuncIndex: Integer; 72 | CodeAddress: TCodeAddr; 73 | end; 74 | 75 | const 76 | opOperandSizePrefix = $66; 77 | 78 | constructor TX86CodeGen.Create; 79 | begin 80 | inherited; 81 | ConstAddrFixupList := TList.Create; 82 | DataAddrFixupList := TList.Create; 83 | FuncAddrFixupList := TList.Create; 84 | end; 85 | 86 | destructor TX86CodeGen.Destroy; 87 | begin 88 | FuncAddrFixupList.Free; {}{mem leak; needs to free individual items} 89 | ConstAddrFixupList.Free; 90 | DataAddrFixupList.Free; 91 | inherited; 92 | end; 93 | 94 | (*procedure TX86CodeGen.AsgEAXZero; 95 | const 96 | X: array[0..1] of Byte = ($31, $C0); { xor eax, eax } 97 | begin 98 | EmitCode (X, 2); 99 | end;*) 100 | 101 | procedure TX86CodeGen.AsgRegImm (Reg: TX86Register; Value: Longint); 102 | var 103 | X: array[0..4] of Byte; 104 | begin 105 | if Reg in [rgEAX..rgEDI] then begin 106 | { 32-bit reg } 107 | if Value <> 0 then begin 108 | X[0] := $B8 + Ord(Reg); { mov reg32, xxxxxxxx } 109 | Longint((@X[1])^) := Value; 110 | EmitCode (X, 5); 111 | end 112 | else begin 113 | { use a more optimized XOR instruction to assign zero } 114 | X[0] := $31; 115 | X[1] := $C0 or (Ord(Reg) shl 3) or Ord(Reg); 116 | EmitCode (X, 2); 117 | end; 118 | end 119 | else if Reg in [rgAX..rgDI] then begin 120 | { 16-bit reg } 121 | X[0] := opOperandSizePrefix; 122 | Dec (Reg, Ord(rgAX)); 123 | if Value <> 0 then begin 124 | X[1] := $B8 + Ord(Reg); { mov reg32, xxxxxxxx } 125 | Word((@X[2])^) := Value; 126 | EmitCode (X, 4); 127 | end 128 | else begin 129 | { use a more optimized XOR instruction to assign zero } 130 | X[1] := $31; 131 | X[2] := $C0 or (Ord(Reg) shl 3) or Ord(Reg); 132 | EmitCode (X, 3); 133 | end; 134 | end 135 | else begin 136 | { 8-bit reg } 137 | Dec (Reg, Ord(rgAL)); 138 | if Value <> 0 then begin 139 | X[0] := $B0 + Ord(Reg); 140 | X[1] := Byte(Value); 141 | EmitCode (X, 2); 142 | end 143 | else begin 144 | { use a more optimized XOR instruction to assign zero } 145 | X[0] := $30; 146 | X[1] := $C0 or (Ord(Reg) shl 3) or Ord(Reg); 147 | EmitCode (X, 2); 148 | end; 149 | end; 150 | end; 151 | 152 | procedure TX86CodeGen.PushReg (Reg: TX86Register); 153 | var 154 | X: Byte; 155 | begin 156 | Assert (Reg in [rgEAX..rgEDI]); {}{currently there's no support for 8/16-bit regs} 157 | X := $50 + Ord(Reg); 158 | EmitCode (X, 1); 159 | end; 160 | 161 | procedure TX86CodeGen.PopIntoReg (Reg: TX86Register); 162 | var 163 | X: Byte; 164 | begin 165 | Assert (Reg in [rgEAX..rgEDI]); {}{currently there's no support for 8/16-bit regs} 166 | X := $58 + Ord(Reg); 167 | EmitCode (X, 1); 168 | end; 169 | 170 | procedure TX86CodeGen.AsgVarImm (Addr: TVarAddr; Size: TSize; Value: Longint); 171 | { regs used: none } 172 | var 173 | X: array[0..9] of Byte; 174 | begin 175 | case Size of 176 | 4: begin 177 | X[0] := $C7; { mov [xxxxxxxx], yyyyyyyy } 178 | X[1] := $05; 179 | LongWord((@X[2])^) := Addr; 180 | Longint((@X[6])^) := Value; 181 | DataAddrFixupList.Add (Pointer(Length(Code) + 2)); 182 | EmitCode (X, 10); 183 | end; 184 | 2: begin 185 | X[0] := $66; { mov [xxxxxxxx], yyyy } 186 | X[1] := $C7; 187 | X[2] := $05; 188 | LongWord((@X[3])^) := Addr; 189 | Word((@X[7])^) := Word(Value); 190 | DataAddrFixupList.Add (Pointer(Length(Code) + 3)); 191 | EmitCode (X, 9); 192 | end; 193 | 1: begin 194 | X[0] := $C6; { mov [xxxxxxxx], yy } 195 | X[1] := $05; 196 | LongWord((@X[2])^) := Addr; 197 | Byte((@X[6])^) := Byte(Value); 198 | DataAddrFixupList.Add (Pointer(Length(Code) + 2)); 199 | EmitCode (X, 7); 200 | end; 201 | else 202 | Assert (False); 203 | end; 204 | end; 205 | 206 | procedure TX86CodeGen.AsgVarAddrOfConst (Addr: TVarAddr; 207 | ConstAddr: TConstAddr); 208 | { regs used: none } 209 | var 210 | X: array[0..9] of Byte; 211 | begin 212 | X[0] := $C7; { mov [xxxxxxxx], yyyyyyyy } 213 | X[1] := $05; 214 | LongWord((@X[2])^) := Addr; 215 | LongWord((@X[6])^) := ConstAddr; 216 | DataAddrFixupList.Add (Pointer(Length(Code) + 2)); 217 | ConstAddrFixupList.Add (Pointer(Length(Code) + 6)); 218 | EmitCode (X, 10); 219 | end; 220 | 221 | procedure TX86CodeGen.AsgVarVar (DestAddr: TVarAddr; DestSize: TSize; 222 | SourceAddr: TVarAddr; SourceSize: TSize); 223 | { regs used: eax } 224 | var 225 | X: array[0..11] of Byte; 226 | begin 227 | {}{only supports 4-byte types for now!} 228 | Assert ((DestSize = 4) and (SourceSize = 4)); 229 | X[0] := $8B; { mov eax, [xxxxxxxx] } 230 | X[1] := $05; 231 | LongWord((@X[2])^) := SourceAddr; 232 | X[6] := $89; { mov [xxxxxxxx], eax } 233 | X[7] := $05; 234 | LongWord((@X[8])^) := DestAddr; 235 | DataAddrFixupList.Add (Pointer(Length(Code) + 2)); 236 | DataAddrFixupList.Add (Pointer(Length(Code) + 8)); 237 | EmitCode (X, 12); 238 | end; 239 | 240 | procedure TX86CodeGen.AsgVarFuncResult (Addr: TVarAddr; Size: TSize); 241 | { regs used: none } 242 | var 243 | X: array[0..5] of Byte; 244 | begin 245 | {}{only supports 4-byte types for now!} 246 | Assert (Size = 4); 247 | X[0] := $89; { mov [xxxxxxxx], eax } 248 | X[1] := $05; 249 | LongWord((@X[2])^) := Addr; 250 | DataAddrFixupList.Add (Pointer(Length(Code) + 2)); 251 | EmitCode (X, 6); 252 | end; 253 | 254 | procedure TX86CodeGen.AsgVarPop (Addr: TVarAddr; Size: TSize); 255 | { pop into EAX; store EAX in Addr } 256 | begin 257 | {}{only supports 4-byte types for now!} 258 | Assert (Size = 4); 259 | PopIntoReg (rgEAX); 260 | { though the function is named AsgVarFuncResult, what it really does is 261 | assign EAX to a memory location. It will work for our purposes here. } 262 | AsgVarFuncResult (Addr, Size); 263 | end; 264 | 265 | procedure TX86CodeGen.FuncEnd; 266 | { regs used: none } 267 | const 268 | X: Byte = $C3; { ret } 269 | begin 270 | EmitCode (X, 1); 271 | end; 272 | 273 | procedure TX86CodeGen.PushImm (Value: Longint); 274 | var 275 | X: array[0..4] of Byte; 276 | begin 277 | if (Value >= -128) and (Value <= 127) then begin 278 | { If Value is in the range of a signed byte, use a smaller instruction } 279 | X[0] := $6A; { push xx (sign-extended to 32 bits) } 280 | Byte((@X[1])^) := Byte(Value); 281 | EmitCode (X, 2); 282 | end 283 | else begin 284 | X[0] := $68; { push xxxxxxxx } 285 | Longint((@X[1])^) := Value; 286 | EmitCode (X, 5); 287 | end; 288 | end; 289 | 290 | procedure TX86CodeGen.PushAddrOfConst (Addr: TConstAddr); 291 | var 292 | X: array[0..4] of Byte; 293 | begin 294 | Assert (Addr <> $FFFFFFFF); 295 | X[0] := $68; { push xxxxxxxx } 296 | LongWord((@X[1])^) := Addr; 297 | ConstAddrFixupList.Add (Pointer(Length(Code) + 1)); 298 | EmitCode (X, 5); 299 | end; 300 | 301 | procedure TX86CodeGen.PushAddrOfVar (Addr: TVarAddr); 302 | var 303 | X: array[0..4] of Byte; 304 | begin 305 | X[0] := $68; { push xxxxxxxx } 306 | LongWord((@X[1])^) := Addr; 307 | DataAddrFixupList.Add (Pointer(Length(Code) + 1)); 308 | EmitCode (X, 5); 309 | end; 310 | 311 | procedure TX86CodeGen.PushVarAtAddr (Addr: TVarAddr); 312 | var 313 | X: array[0..5] of Byte; 314 | begin 315 | X[0] := $FF; { push [xxxxxxxx] } 316 | X[1] := $35; 317 | LongWord((@X[2])^) := Addr; 318 | DataAddrFixupList.Add (Pointer(Length(Code) + 2)); 319 | EmitCode (X, 6); 320 | end; 321 | 322 | procedure TX86CodeGen.CallFunc (const CallData: TCallData); 323 | var 324 | J: Integer; 325 | X: array[0..4] of Byte; 326 | FixupRec: PFuncAddrFixupRec; 327 | begin 328 | { stdcall - push parameters from right to left } 329 | for J := CallData.ParamCount-1 downto 0 do 330 | Expression (CallData.ParamExpr[J]); 331 | 332 | X[0] := $E8; { call xxxxxxxx (relative address) } 333 | Longint((@X[1])^) := 0; { xxxxxxxx is zero for now } 334 | New (FixupRec); 335 | FixupRec.FuncIndex := CallData.FuncIndex; 336 | FixupRec.CodeAddress := Length(Code) + 1; 337 | FuncAddrFixupList.Add (FixupRec); 338 | EmitCode (X, 5); 339 | end; 340 | 341 | procedure TX86CodeGen.ImportThunk (ImportAddressVA: TVirtualAddress); 342 | var 343 | X: array[0..5] of Byte; 344 | begin 345 | X[0] := $FF; { jmp [xxxxxxxx] } 346 | X[1] := $25; 347 | LongWord((@X[2])^) := ImportAddressVA; 348 | EmitCode (X, 6); 349 | end; 350 | 351 | procedure TX86CodeGen.ApplyFixups (Funcs: TList; FuncAddress: TCodeAddr; 352 | CodeVA, ConstVA, BSSVA: TVirtualAddress); 353 | var 354 | I: Integer; 355 | Diff, Addr: Longint; 356 | FixupRec: PFuncAddrFixupRec; 357 | FixupOffset: PLongint; 358 | begin 359 | for I := 0 to FuncAddrFixupList.Count-1 do begin 360 | FixupRec := FuncAddrFixupList[I]; 361 | Addr := PFuncData(Funcs[FixupRec.FuncIndex]).Address; 362 | Assert (Addr <> -1); 363 | Diff := Addr - Longint(FuncAddress + FixupRec.CodeAddress + 4); 364 | Longint((@Code[FixupRec.CodeAddress+1])^) := Diff; 365 | end; 366 | for I := 0 to ConstAddrFixupList.Count-1 do 367 | Inc (Longint((@Code[Cardinal(ConstAddrFixupList[I])+1])^), 368 | ConstVA); 369 | for I := 0 to DataAddrFixupList.Count-1 do begin 370 | FixupOffset := @Code[Cardinal(DataAddrFixupList[I])+1]; 371 | Assert (FixupOffset^ <> -1); 372 | Inc (FixupOffset^, BSSVA); 373 | end; 374 | end; 375 | 376 | procedure TX86CodeGen.Expression (const Expr: TExpression); 377 | { regs used: eax, ecx, edx. 378 | Result of expression is currently left at the top of the stack } 379 | const 380 | AddEAXtoMESP: array[0..2] of Byte = ($01, $04, $24); { add [esp], eax } 381 | AddECXtoEAX: array[0..1] of Byte = ($01, $C8); { add eax, ecx } 382 | AddMESPtoEAX: array[0..2] of Byte = ($03, $04, $24); { add eax, [esp] } 383 | DivideEAXbyECX: array[0..2] of Byte = ($99,{;} $F7, $F9); { cdq; idiv ecx } 384 | SubtractEAXfromMESP: array[0..2] of Byte = ($29, $04, $24); { sub [esp], eax } 385 | SubtractECXfromEAX: array[0..1] of Byte = ($29, $C8); { sub eax, ecx } 386 | SubtractMESPfromEAX: array[0..2] of Byte = ($2B, $04, $24); { sub eax, [esp] } 387 | MultiplyEAXbyECX: array[0..2] of Byte = ($0F, $AF, $C1); { imul eax, ecx } 388 | MultiplyEAXbyMESP: array[0..3] of Byte = ($0F, $AF, $04, $24); { imul eax, [esp] } 389 | MultiplyECXbyEAX: array[0..2] of Byte = ($0F, $AF, $C8); { imul ecx, eax } 390 | MovEAX_MESP: array[0..2] of Byte = ($8B, $04, $24); { mov eax, [esp] } 391 | MovEAX_MESP4: array[0..3] of Byte = ($8B, $44, $24, $04); { mov eax, [esp+4] } 392 | MovECX_MESP: array[0..2] of Byte = ($8B, $0C, $24); { mov ecx, [esp] } 393 | MovMESP_EAX: array[0..2] of Byte = ($89, $04, $24); { mov [esp], eax } 394 | MovMESP_ECX: array[0..2] of Byte = ($89, $0C, $24); { mov [esp], ecx } 395 | MovMESP_EDX: array[0..2] of Byte = ($89, $14, $24); { mov [esp], edx } 396 | MovMESP4_EAX: array[0..3] of Byte = ($89, $44, $24, $04); { mov [esp+4], eax } 397 | NegEAX: array[0..1] of Byte = ($F7, $D8); { neg eax } 398 | var 399 | P: PExprRec; 400 | begin 401 | P := Expr.First; 402 | while Assigned(P) do begin 403 | case P.Op of 404 | eoPushImm: PushImm (P.Value.AsInteger); 405 | eoPushVar: begin 406 | PushVarAtAddr (P.Value.AsVarAddress); 407 | if efNegate in P.Flags then begin 408 | { quick & ugly hack: pop the var off the stack and push it 409 | back negated } 410 | PopIntoReg (rgEAX); 411 | EmitCode (NegEAX, SizeOf(NegEAX)); 412 | PushReg (rgEAX); 413 | end; 414 | end; 415 | eoPushStrConst: PushAddrOfConst (P.Value.AsConstAddress); 416 | eoPushAddrOfVar: PushAddrOfVar (P.Value.AsVarAddress); 417 | eoPushCall: begin 418 | CallFunc (P.CallData^); 419 | { result of function is in EAX } 420 | if efNegate in P.Flags then 421 | EmitCode (NegEAX, SizeOf(NegEAX)); 422 | PushReg (rgEAX); 423 | end; 424 | eoAdd: begin 425 | PopIntoReg (rgEAX); 426 | EmitCode (AddEAXtoMESP, SizeOf(AddEAXtoMESP)); 427 | end; 428 | eoSubtract: begin 429 | PopIntoReg (rgEAX); 430 | EmitCode (SubtractEAXfromMESP, SizeOf(SubtractEAXfromMESP)); 431 | end; 432 | eoMultiply: begin 433 | PopIntoReg (rgEAX); 434 | EmitCode (MovECX_MESP, SizeOf(MovECX_MESP)); 435 | EmitCode (MultiplyECXbyEAX, SizeOf(MultiplyECXbyEAX)); 436 | EmitCode (MovMESP_ECX, SizeOf(MovMESP_ECX)); 437 | end; 438 | eoDivide: begin 439 | PopIntoReg (rgECX); 440 | EmitCode (MovEAX_MESP, SizeOf(MovEAX_MESP)); 441 | EmitCode (DivideEAXbyECX, SizeOf(DivideEAXbyECX)); 442 | { DivideEAXbyECX saves quotient in EAX, and remainder in EDX } 443 | EmitCode (MovMESP_EAX, SizeOf(MovMESP_EAX)); 444 | end; 445 | eoMod: begin 446 | { eoMod is identical to eoDivide except for the last line } 447 | PopIntoReg (rgECX); 448 | EmitCode (MovEAX_MESP, SizeOf(MovEAX_MESP)); 449 | EmitCode (DivideEAXbyECX, SizeOf(DivideEAXbyECX)); 450 | { DivideEAXbyECX saves quotient in EAX, and remainder in EDX } 451 | EmitCode (MovMESP_EDX, SizeOf(MovMESP_EDX)); 452 | end; 453 | else 454 | Assert (False); 455 | end; 456 | P := P.Next; 457 | end; 458 | end; 459 | 460 | end. 461 | -------------------------------------------------------------------------------- /Src/Common.pas: -------------------------------------------------------------------------------- 1 | unit Common; 2 | 3 | { 4 | Inno Pascal 5 | Copyright (C) 2000 Jordan Russell 6 | 7 | www: http://www.jrsoftware.org/ 8 | or http://www.jordanr.cjb.net/ 9 | email: jr@jrsoftware.org 10 | 11 | This program is free software; you can redistribute it and/or 12 | modify it under the terms of the GNU General Public License 13 | as published by the Free Software Foundation; either version 2 14 | of the License, or (at your option) any later version. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | GNU General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with this program; if not, write to the Free Software 23 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 24 | } 25 | 26 | interface 27 | 28 | { Common declarations for compiler, linker, and code generator } 29 | 30 | uses 31 | SysUtils, Classes, IPBase; 32 | 33 | const 34 | MaxParams = 10; 35 | 36 | type 37 | TSize = type Cardinal; 38 | 39 | PVarAddr = ^TVarAddr; 40 | TVarAddr = type Cardinal; { address relative to start of data section } 41 | TConstAddr = type Cardinal; { address relative to start of constant section } 42 | TCodeAddr = type Cardinal; { address relative to start of code section } 43 | TFuncCodeAddr = type Cardinal; { address relative to start of a function } 44 | TVirtualAddress = type Cardinal; { absolute address } 45 | 46 | THugeint = Int64; 47 | 48 | PLineNumberRec = ^TLineNumberRec; 49 | TLineNumberRec = record 50 | LineNum: Cardinal; 51 | CodeAddr: TFuncCodeAddr; 52 | end; 53 | 54 | TTypeKind = (kdInteger, kdString, kdRecord); 55 | 56 | TExprValue = record 57 | case Integer of 58 | 0: (AsInteger: THugeint); 59 | 1: (AsConstAddress: TConstAddr); 60 | 2: (AsVarAddress: TVarAddr); 61 | end; 62 | 63 | TExprOp = (eoPushImm, eoPushVar, eoPushStrConst, eoPushAddrOfVar, eoPushCall, 64 | eoAdd, eoSubtract, eoMultiply, eoDivide, eoMod); 65 | 66 | PCallData = ^TCallData; 67 | 68 | { A TExprRec specifies either an operand or an operator in an expression. 69 | If Op is eoPush*, it is an operand, otherwise it is an operator. } 70 | PExprRec = ^TExprRec; 71 | TExprRec = record 72 | Next, Prev: PExprRec; 73 | Kind: TTypeKind; { not applicable to eoPush* } 74 | Op: TExprOp; 75 | Flags: set of (efNegate); { efNegate is only valid for eoPushVar and eoPushCall } 76 | ValueStr: String; 77 | CallData: PCallData; 78 | Value: TExprValue; 79 | end; 80 | 81 | TExpression = record 82 | First, Last: PExprRec; 83 | end; 84 | 85 | TCallData = record 86 | FuncIndex: Integer; 87 | ParamCount: Integer; 88 | ParamExpr: array[0..MaxParams-1] of TExpression; 89 | end; 90 | 91 | TIPCustomCodeGen = class; 92 | 93 | PFuncData = ^TFuncData; 94 | TFuncData = record 95 | DLLIndex: Integer; { -1 if the function isn't external } 96 | ImportName: String; 97 | CodeGen: TIPCustomCodeGen; 98 | Address: TCodeAddr; 99 | Called: Boolean; 100 | end; 101 | 102 | TMyStringList = class(TStringList) 103 | public 104 | function IndexOf (const S: String): Integer; override; 105 | end; 106 | 107 | TIPLinkerClass = class of TIPCustomLinker; 108 | TIPCustomLinker = class 109 | protected 110 | ConstSection: AnsiString; 111 | public 112 | LinkOptions: record 113 | ConsoleApp: Boolean; 114 | end; 115 | DataSectionSize: TSize; 116 | DLLList: TMyStringList; 117 | Funcs: TList; 118 | constructor Create; 119 | destructor Destroy; override; 120 | function DoLink (const OutFile: String; 121 | const LineNumberInfo: PLineNumberInfoArray): TSize; virtual; abstract; 122 | function NewStringConst (const S: String): TConstAddr; 123 | end; 124 | 125 | TIPCodeGenClass = class of TIPCustomCodeGen; 126 | TIPCustomCodeGen = class 127 | public 128 | Code: AnsiString; 129 | LineNumbers: TList; 130 | constructor Create; virtual; 131 | destructor Destroy; override; 132 | procedure EmitCode (var X; const Bytes: TSize); 133 | procedure StatementBegin (const LineNum: Cardinal); 134 | { abstract methods: } 135 | procedure ApplyFixups (Funcs: TList; FuncAddress: TCodeAddr; 136 | CodeVA, ConstVA, BSSVA: TVirtualAddress); virtual; abstract; 137 | procedure AsgVarAddrOfConst (Addr: TVarAddr; ConstAddr: TConstAddr); virtual; abstract; 138 | procedure AsgVarFuncResult (Addr: TVarAddr; Size: TSize); virtual; abstract; 139 | procedure AsgVarImm (Addr: TVarAddr; Size: TSize; Value: Longint); virtual; abstract; 140 | procedure AsgVarPop (Addr: TVarAddr; Size: TSize); virtual; abstract; 141 | procedure AsgVarVar (DestAddr: TVarAddr; DestSize: TSize; 142 | SourceAddr: TVarAddr; SourceSize: TSize); virtual; abstract; 143 | procedure CallFunc (const CallData: TCallData); virtual; abstract; 144 | procedure Expression (const Expr: TExpression); virtual; abstract; 145 | procedure FuncEnd; virtual; abstract; 146 | procedure ImportThunk (ImportAddressVA: TVirtualAddress); virtual; abstract; 147 | end; 148 | 149 | implementation 150 | 151 | { TMyStringList } 152 | 153 | function TMyStringList.IndexOf (const S: string): Integer; 154 | { Same as TStrings.IndexOf, but uses SameText instead of AnsiCompareText. We 155 | don't want/need ANSI comparison. } 156 | begin 157 | for Result := 0 to GetCount - 1 do 158 | if SameText(Get(Result), S) then Exit; 159 | Result := -1; 160 | end; 161 | 162 | 163 | { TIPCustomCodeGen } 164 | 165 | constructor TIPCustomCodeGen.Create; 166 | begin 167 | inherited; 168 | LineNumbers := TList.Create; 169 | end; 170 | 171 | destructor TIPCustomCodeGen.Destroy; 172 | begin 173 | LineNumbers.Free; {}{mem leak} 174 | inherited; 175 | end; 176 | 177 | procedure TIPCustomCodeGen.EmitCode (var X; const Bytes: TSize); 178 | var 179 | S: AnsiString; 180 | begin 181 | SetString (S, PChar(@X), Bytes); 182 | Code := Code + S; 183 | end; 184 | 185 | procedure TIPCustomCodeGen.StatementBegin (const LineNum: Cardinal); 186 | var 187 | Rec: PLineNumberRec; 188 | begin 189 | New (Rec); 190 | Rec.LineNum := LineNum; 191 | Rec.CodeAddr := Length(Code); 192 | LineNumbers.Add (Rec); 193 | end; 194 | 195 | 196 | { TIPCustomLinker } 197 | 198 | constructor TIPCustomLinker.Create; 199 | begin 200 | inherited; 201 | DLLList := TMyStringList.Create; 202 | Funcs := TList.Create; 203 | end; 204 | 205 | destructor TIPCustomLinker.Destroy; 206 | begin 207 | Funcs.Free; {}{memory leak! need to free each individual item's data} 208 | DLLList.Free; 209 | inherited; 210 | end; 211 | 212 | function TIPCustomLinker.NewStringConst (const S: String): TConstAddr; 213 | { Adds S to the ConstSection and returns the address of it } 214 | begin 215 | Result := Length(ConstSection); 216 | ConstSection := ConstSection + S + #0; 217 | end; 218 | 219 | end. 220 | -------------------------------------------------------------------------------- /Src/DebugEventLog.dfm: -------------------------------------------------------------------------------- 1 | object DebugEventLogForm: TDebugEventLogForm 2 | Left = 460 3 | Top = 293 4 | Width = 462 5 | Height = 179 6 | BorderStyle = bsSizeToolWin 7 | Caption = 'Event Log' 8 | Color = clBtnFace 9 | Font.Charset = DEFAULT_CHARSET 10 | Font.Color = clWindowText 11 | Font.Height = -11 12 | Font.Name = 'MS Sans Serif' 13 | Font.Style = [] 14 | OldCreateOrder = False 15 | Position = poScreenCenter 16 | PixelsPerInch = 96 17 | TextHeight = 13 18 | object List: TListView 19 | Left = 0 20 | Top = 0 21 | Width = 454 22 | Height = 152 23 | Align = alClient 24 | Columns = < 25 | item 26 | Caption = 'Type' 27 | Width = 96 28 | end 29 | item 30 | Caption = 'Details' 31 | Width = 336 32 | end> 33 | ColumnClick = False 34 | ReadOnly = True 35 | RowSelect = True 36 | PopupMenu = PopupMenu 37 | TabOrder = 0 38 | ViewStyle = vsReport 39 | end 40 | object PopupMenu: TPopupMenu 41 | Left = 344 42 | Top = 64 43 | object Clear1: TMenuItem 44 | Caption = '&Clear' 45 | OnClick = Clear1Click 46 | end 47 | end 48 | end 49 | -------------------------------------------------------------------------------- /Src/DebugEventLog.pas: -------------------------------------------------------------------------------- 1 | unit DebugEventLog; 2 | 3 | { 4 | Inno Pascal 5 | Copyright (C) 2000 Jordan Russell 6 | 7 | www: http://www.jrsoftware.org/ 8 | or http://www.jordanr.cjb.net/ 9 | email: jr@jrsoftware.org 10 | 11 | This program is free software; you can redistribute it and/or 12 | modify it under the terms of the GNU General Public License 13 | as published by the Free Software Foundation; either version 2 14 | of the License, or (at your option) any later version. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | GNU General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with this program; if not, write to the Free Software 23 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 24 | } 25 | 26 | interface 27 | 28 | uses 29 | Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 30 | StdCtrls, ComCtrls, Menus; 31 | 32 | type 33 | TDebugEventLogForm = class(TForm) 34 | List: TListView; 35 | PopupMenu: TPopupMenu; 36 | Clear1: TMenuItem; 37 | procedure Clear1Click(Sender: TObject); 38 | private 39 | { Private declarations } 40 | public 41 | { Public declarations } 42 | procedure Log (const AType, ADetails: String); 43 | end; 44 | 45 | var 46 | DebugEventLogForm: TDebugEventLogForm; 47 | 48 | implementation 49 | 50 | {$R *.DFM} 51 | 52 | procedure TDebugEventLogForm.Log (const AType, ADetails: String); 53 | var 54 | I: TListItem; 55 | begin 56 | if not Visible then 57 | Exit; 58 | I := List.Items.Add; 59 | I.Caption := AType; 60 | I.Subitems.Add (ADetails); 61 | I.Selected := True; 62 | I.MakeVisible (False); 63 | end; 64 | 65 | procedure TDebugEventLogForm.Clear1Click(Sender: TObject); 66 | begin 67 | List.Items.Clear; 68 | end; 69 | 70 | end. 71 | 72 | -------------------------------------------------------------------------------- /Src/DebugRegisters.dfm: -------------------------------------------------------------------------------- 1 | object DebugRegistersForm: TDebugRegistersForm 2 | Left = 192 3 | Top = 103 4 | Width = 120 5 | Height = 248 6 | BorderStyle = bsSizeToolWin 7 | Caption = 'Last Registers' 8 | Color = clBtnFace 9 | Font.Charset = DEFAULT_CHARSET 10 | Font.Color = clWindowText 11 | Font.Height = -11 12 | Font.Name = 'MS Sans Serif' 13 | Font.Style = [] 14 | OldCreateOrder = False 15 | Position = poScreenCenter 16 | PixelsPerInch = 96 17 | TextHeight = 13 18 | object List: TListView 19 | Left = 0 20 | Top = 0 21 | Width = 112 22 | Height = 221 23 | Align = alClient 24 | Columns = < 25 | item 26 | Caption = 'Reg' 27 | Width = 36 28 | end 29 | item 30 | Caption = 'Value' 31 | Width = 64 32 | end> 33 | ColumnClick = False 34 | Items.Data = { 35 | 7E0100000E00000000000000FFFFFFFFFFFFFFFF010000000000000003454158 36 | 0000000000FFFFFFFFFFFFFFFF0100000000000000034542580000000000FFFF 37 | FFFFFFFFFFFF0100000000000000034543580000000000FFFFFFFFFFFFFFFF01 38 | 00000000000000034544580000000000FFFFFFFFFFFFFFFF0100000000000000 39 | 034553490000000000FFFFFFFFFFFFFFFF010000000000000003454449000000 40 | 0000FFFFFFFFFFFFFFFF0100000000000000034542500000000000FFFFFFFFFF 41 | FFFFFF0100000000000000034553500000000000FFFFFFFFFFFFFFFF01000000 42 | 00000000034549500000000000FFFFFFFFFFFFFFFF0100000000000000034546 43 | 4C0000000000FFFFFFFFFFFFFFFF01000000000000000243530000000000FFFF 44 | FFFFFFFFFFFF01000000000000000244530000000000FFFFFFFFFFFFFFFF0100 45 | 0000000000000253530000000000FFFFFFFFFFFFFFFF01000000000000000245 46 | 5300FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF} 47 | ReadOnly = True 48 | RowSelect = True 49 | TabOrder = 0 50 | ViewStyle = vsReport 51 | OnCustomDrawSubItem = ListCustomDrawSubItem 52 | end 53 | end 54 | -------------------------------------------------------------------------------- /Src/DebugRegisters.pas: -------------------------------------------------------------------------------- 1 | unit DebugRegisters; 2 | 3 | { 4 | Inno Pascal 5 | Copyright (C) 2000 Jordan Russell 6 | 7 | www: http://www.jrsoftware.org/ 8 | or http://www.jordanr.cjb.net/ 9 | email: jr@jrsoftware.org 10 | 11 | This program is free software; you can redistribute it and/or 12 | modify it under the terms of the GNU General Public License 13 | as published by the Free Software Foundation; either version 2 14 | of the License, or (at your option) any later version. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | GNU General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with this program; if not, write to the Free Software 23 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 24 | } 25 | 26 | interface 27 | 28 | uses 29 | Windows, Messages, SysUtils, Classes, Graphics, Controls, Forms, Dialogs, 30 | ComCtrls; 31 | 32 | type 33 | TDebugRegistersForm = class(TForm) 34 | List: TListView; 35 | procedure ListCustomDrawSubItem(Sender: TCustomListView; 36 | Item: TListItem; SubItem: Integer; State: TCustomDrawState; 37 | var DefaultDraw: Boolean); 38 | private 39 | { Private declarations } 40 | public 41 | { Public declarations } 42 | procedure NewContext (const Context: TContext); 43 | procedure NoContext; 44 | end; 45 | 46 | var 47 | DebugRegistersForm: TDebugRegistersForm; 48 | 49 | implementation 50 | 51 | {$R *.DFM} 52 | 53 | procedure TDebugRegistersForm.NewContext (const Context: TContext); 54 | var 55 | CW0, CW1: integer; // widths of listview columns 56 | IsVisible: Boolean; 57 | 58 | procedure UpdateSubitemData(AIndex: integer; AText: string); 59 | var 60 | B: boolean; 61 | RC: TRect; 62 | begin 63 | with List.Items[AIndex] do begin 64 | B := Subitems[0] <> AText; 65 | if B then 66 | Subitems[0] := AText; 67 | // reset change mark 68 | if Data <> pointer(B) then begin 69 | Data := pointer(B); 70 | B := TRUE; 71 | end; 72 | if IsVisible and B then begin 73 | // get minimum update rect for column 1 74 | RC := DisplayRect(drBounds); 75 | RC.Left := CW0; 76 | RC.Right := RC.Left + CW1; 77 | // invalidate and update immediately, so that small rects won't be 78 | // combined into one big rect (else lines 1 and 8 would invalidate 1..8) 79 | InvalidateRect(List.Handle, @RC, TRUE); 80 | List.Update; 81 | end; 82 | end; 83 | end; 84 | 85 | begin 86 | Caption := 'Registers'; 87 | List.HandleNeeded; { required or else accessing the list items will cause an AV } 88 | CW0 := List.Columns[0].Width; 89 | CW1 := List.Columns[1].Width; 90 | IsVisible := IsWindowVisible(List.Handle); 91 | // BeginUpdate/EndUpdate is a bad idea, since it will always invalidate 92 | // the whole client area of the listview, even if nothing has changed 93 | UpdateSubitemData(0, IntToHex(Context.Eax, 8)); 94 | UpdateSubitemData(1, IntToHex(Context.Ebx, 8)); 95 | UpdateSubitemData(2, IntToHex(Context.Ecx, 8)); 96 | UpdateSubitemData(3, IntToHex(Context.Edx, 8)); 97 | UpdateSubitemData(4, IntToHex(Context.Esi, 8)); 98 | UpdateSubitemData(5, IntToHex(Context.Edi, 8)); 99 | UpdateSubitemData(6, IntToHex(Context.Ebp, 8)); 100 | UpdateSubitemData(7, IntToHex(Context.Esp, 8)); 101 | UpdateSubitemData(8, IntToHex(Context.Eip, 8)); 102 | UpdateSubitemData(9, IntToHex(Context.EFlags, 8)); 103 | UpdateSubitemData(10, IntToHex(Context.SegCS, 4)); 104 | UpdateSubitemData(11, IntToHex(Context.SegDS, 4)); 105 | UpdateSubitemData(12, IntToHex(Context.SegSS, 4)); 106 | UpdateSubitemData(13, IntToHex(Context.SegES, 4)); 107 | end; 108 | 109 | procedure TDebugRegistersForm.NoContext; 110 | {var 111 | I: Integer;} 112 | begin 113 | Caption := 'Last Registers'; 114 | (* 115 | List.HandleNeeded; { required or else accessing the list items will cause an AV } 116 | List.Items.BeginUpdate; 117 | try 118 | for I := 0 to 13 do 119 | List.Items[I].Subitems[0] := '?'; 120 | finally 121 | List.Items.EndUpdate; 122 | end; 123 | *) 124 | end; 125 | 126 | procedure TDebugRegistersForm.ListCustomDrawSubItem(Sender: TCustomListView; 127 | Item: TListItem; SubItem: Integer; State: TCustomDrawState; 128 | var DefaultDraw: Boolean); 129 | begin 130 | if (SubItem = 1) and not (cdsSelected in State) then begin 131 | if Item.Data <> nil then 132 | Sender.Canvas.Font.Color := clRed 133 | else 134 | Sender.Canvas.Font.Color := clWindowText; 135 | end; 136 | end; 137 | 138 | end. 139 | 140 | -------------------------------------------------------------------------------- /Src/Debugger.pas: -------------------------------------------------------------------------------- 1 | unit Debugger; 2 | 3 | { 4 | Inno Pascal 5 | Copyright (C) 2000 Jordan Russell 6 | 7 | www: http://www.jrsoftware.org/ 8 | or http://www.jordanr.cjb.net/ 9 | email: jr@jrsoftware.org 10 | 11 | This program is free software; you can redistribute it and/or 12 | modify it under the terms of the GNU General Public License 13 | as published by the Free Software Foundation; either version 2 14 | of the License, or (at your option) any later version. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | GNU General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with this program; if not, write to the Free Software 23 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 24 | } 25 | 26 | interface 27 | 28 | uses 29 | Windows, SysUtils; 30 | 31 | procedure StartDebug (const AImageFilename, AParams: String; 32 | const ACommWnd: HWND; const ACommMsg: UINT); 33 | procedure StopDebug; 34 | 35 | const 36 | dmLog = 0; 37 | dmCriticalError = 1; 38 | dmPaused = 2; 39 | dmStopped = 3; 40 | 41 | type 42 | PDebugMsgLogData = ^TDebugMsgLogData; 43 | TDebugMsgLogData = record 44 | Typ, Details: String; 45 | end; 46 | 47 | PDebugMsgPauseData = ^TDebugMsgPauseData; 48 | TDebugMsgPauseData = record 49 | Context: PContext; 50 | Address: Cardinal; 51 | AlwaysWait: Boolean; 52 | end; 53 | 54 | var 55 | { read-only: } 56 | Debugging: Boolean; 57 | DebugContinueEvent: THandle; 58 | { writable: } 59 | DebugSingleStep: Boolean; 60 | DebugWantBreakpointAt: Cardinal; 61 | 62 | implementation 63 | 64 | uses 65 | CmnFunc2, DebuggerProcs; 66 | 67 | var 68 | DebugThread: THandle; 69 | DebugProcess: THandle; 70 | 71 | type 72 | PDebugThreadData = ^TDebugThreadData; 73 | TDebugThreadData = record 74 | ImageFilename, Params: String; 75 | CommWnd: HWND; 76 | CommMsg: UINT; 77 | end; 78 | 79 | function DebugThreadProc (Data: PDebugThreadData): Integer; forward; 80 | 81 | procedure StartDebug (const AImageFilename, AParams: String; 82 | const ACommWnd: HWND; const ACommMsg: UINT); 83 | var 84 | Data: PDebugThreadData; 85 | ThreadId: DWORD; 86 | begin 87 | New (Data); 88 | try 89 | Data.ImageFilename := ExpandFileName(AImageFilename); 90 | Data.Params := AParams; 91 | Data.CommWnd := ACommWnd; 92 | Data.CommMsg := ACommMsg; 93 | DebugProcess := 0; 94 | 95 | if DebugThread <> 0 then begin 96 | { Close handle to last debug thread } 97 | CloseHandle (DebugThread); 98 | DebugThread := 0; 99 | end; 100 | Debugging := True; 101 | DebugThread := BeginThread(nil, 0, @DebugThreadProc, Data, 0, ThreadId); 102 | if DebugThread = 0 then 103 | RaiseLastWin32Error; 104 | Data := nil; { the thread will free Data; prevent it from being freed below } 105 | except 106 | Debugging := False; 107 | FreeMem (Data); 108 | raise; 109 | end; 110 | end; 111 | 112 | procedure StopDebug; 113 | var 114 | Msg: TMsg; 115 | begin 116 | if not Debugging then 117 | Exit; 118 | Win32Check (TerminateProcess(DebugProcess, 0)); 119 | { If paused, upon continuing it'll get an EXIT_PROCESS_DEBUG_EVENT } 120 | SetEvent (DebugContinueEvent); 121 | { Wait for the debug thread to terminate. When a message sent from another 122 | thread is waiting, call PeekMessage so that it gets processed right now. 123 | We have to do that because the debug thread sends WM_Debug* messages 124 | during termination. } 125 | while True do 126 | case MsgWaitForMultipleObjects(1, DebugThread, False, INFINITE, QS_SENDMESSAGE) of 127 | WAIT_OBJECT_0: Break; 128 | WAIT_OBJECT_0 + 1: PeekMessage (Msg, 0, 0, 0, PM_NOREMOVE); 129 | else 130 | RaiseLastWin32Error; 131 | end; 132 | end; 133 | 134 | function DebugThreadProc (Data: PDebugThreadData): Integer; 135 | 136 | procedure DebugLog (const AType, ADetails: String); 137 | var 138 | LogData: TDebugMsgLogData; 139 | begin 140 | LogData.Typ := AType; 141 | LogData.Details := ADetails; 142 | SendMessage (Data.CommWnd, Data.CommMsg, dmLog, LPARAM(@LogData)); 143 | end; 144 | 145 | procedure CriticalError (const Msg: String); 146 | begin 147 | SendMessage (Data.CommWnd, Data.CommMsg, dmCriticalError, LPARAM(Msg)); 148 | end; 149 | 150 | var 151 | ErrorMsg: LPARAM; 152 | CmdLine, S: String; 153 | L: Integer; 154 | StartupInfo: TStartupInfo; 155 | ProcessInfo: TProcessInformation; 156 | DE: TDebugEvent; 157 | ContinueStatus: DWORD; 158 | Process, Thread: THandle; 159 | Context: TContext; 160 | SaveByte: Byte; 161 | BkptAddr, StepBkptAddr: Cardinal; 162 | ImageBase: Cardinal; 163 | FirstBreakpoint: Boolean; 164 | JumpInstr: packed record 165 | Opcode: Word; 166 | JumpAddrAt: LongWord; 167 | end; 168 | ReturnAddr: LongWord; 169 | Buf: Pointer; 170 | Addr, AddrWanted: Pointer; 171 | const 172 | Int3 = $CC; 173 | TraceFlag = $100; 174 | ReadWriteText: array[Boolean] of String = ('Read', 'Write'); 175 | 176 | procedure WriteByte (const VA: Cardinal; const NewByte: Byte; 177 | const OldByte: PByte); 178 | begin 179 | if Assigned(OldByte) then 180 | Win32Check (ReadProcessMemory (Process, Pointer(VA), OldByte, 1, Cardinal(nil^))); 181 | Win32Check (WriteProcessMemory (Process, Pointer(VA), @NewByte, 1, Cardinal(nil^))); 182 | Win32Check (FlushInstructionCache (Process, nil, 0)); 183 | end; 184 | 185 | procedure Pause (const WaitOnlyIfSourceLineFound: Boolean); 186 | var 187 | PauseData: TDebugMsgPauseData; 188 | begin 189 | PauseData.Context := @Context; 190 | PauseData.Address := Context.Eip - ImageBase; 191 | PauseData.AlwaysWait := not WaitOnlyIfSourceLineFound; 192 | ResetEvent (DebugContinueEvent); 193 | if SendMessage(Data.CommWnd, Data.CommMsg, dmPaused, 194 | LPARAM(@PauseData)) = 1 then begin 195 | { If "1" was returned, a source code line was found matching Context.Eip. 196 | Now wait until the user chooses the next course of action (continue 197 | single stepping, run, stop, etc.) } 198 | WaitForSingleObject (DebugContinueEvent, INFINITE); 199 | { Did the user choose "Run to Cursor"? If so, set up a breakpoint on the 200 | next single step exception. (Can't set breakpoint now, or else it would 201 | get the breakpoint over and over on the same instruction if the user 202 | chose "Run to Cursor" on the line it was already stopped on.) } 203 | StepBkptAddr := InterlockedExchange(Integer(DebugWantBreakpointAt), 0); 204 | if StepBkptAddr <> 0 then begin 205 | Inc (StepBkptAddr, ImageBase); 206 | Context.EFlags := Context.EFlags or TraceFlag; 207 | Context.ContextFlags := CONTEXT_CONTROL; 208 | Win32Check (SetThreadContext (Thread, Context)); 209 | end; 210 | end; 211 | end; 212 | 213 | begin 214 | Result := 0; 215 | ErrorMsg := 0; 216 | Process := 0; 217 | Thread := 0; 218 | try 219 | FillChar (StartupInfo, SizeOf(StartupInfo), 0); 220 | StartupInfo.cb := SizeOf(StartupInfo); 221 | CmdLine := AddQuotes(Data.ImageFilename); 222 | if Data.Params <> '' then 223 | CmdLine := CmdLine + ' ' + Data.Params; 224 | Win32Check (CreateProcess(nil, PChar(CmdLine), 225 | nil, nil, False, {DEBUG_PROCESS or} DEBUG_ONLY_THIS_PROCESS, 226 | nil, Pointer(ExtractFilePath(Data.ImageFilename)), StartupInfo, ProcessInfo)); 227 | DebugProcess := ProcessInfo.hProcess; 228 | CloseHandle (ProcessInfo.hThread); 229 | 230 | BkptAddr := 0; 231 | StepBkptAddr := 0; 232 | FirstBreakpoint := True; 233 | SaveByte := 0; 234 | ImageBase := 0; 235 | while WaitForDebugEvent(DE, INFINITE) do begin 236 | ContinueStatus := DBG_EXCEPTION_NOT_HANDLED; 237 | case DE.dwDebugEventCode of 238 | CREATE_PROCESS_DEBUG_EVENT: begin 239 | Process := DE.CreateProcessInfo.hProcess; 240 | Thread := DE.CreateProcessInfo.hThread; 241 | ImageBase := Cardinal(DE.CreateProcessInfo.lpBaseOfImage); 242 | DebugLog ('Process created', Format('Base: $%.8x', [ImageBase])); 243 | CloseHandle (DE.CreateProcessInfo.hFile); 244 | Assert (Process <> 0); 245 | Assert (Thread <> 0); 246 | end; 247 | EXIT_PROCESS_DEBUG_EVENT: begin 248 | DebugLog ('Process exited', ''); 249 | Break; 250 | end; 251 | CREATE_THREAD_DEBUG_EVENT: begin 252 | DebugLog ('Thread created', ''); 253 | end; 254 | EXIT_THREAD_DEBUG_EVENT: begin 255 | DebugLog ('Thread exited', ''); 256 | end; 257 | LOAD_DLL_DEBUG_EVENT: begin 258 | //DebugLog ('DLL loaded', Format('Base: $%.8x', [Cardinal(DE.LoadDll.lpBaseOfDll)])); 259 | Addr := DE.LoadDll.lpBaseOfDll; 260 | AddrWanted := DebugGetPreferredLoadAddress(DebugProcess, Addr); 261 | s := Format('%s, Base: $%.8x', 262 | [DebugProcessGetModuleName(DebugProcess, Addr), Cardinal(Addr)]); 263 | if (AddrWanted <> nil) and (AddrWanted <> Addr) then 264 | s := s + Format(', Relocated from $%.8x', [Cardinal(AddrWanted)]); 265 | DebugLog ('DLL loaded', s); 266 | S := ''; 267 | CloseHandle (DE.LoadDll.hFile); 268 | end; 269 | UNLOAD_DLL_DEBUG_EVENT: begin 270 | DebugLog ('DLL unloaded', ''); 271 | end; 272 | OUTPUT_DEBUG_STRING_EVENT: begin 273 | ContinueStatus := DBG_CONTINUE; 274 | with DE.DebugString do begin 275 | L := nDebugStringLength - 1; { don't need the terminating null character } 276 | if fUniCode <> 0 then 277 | L := L * 2; 278 | GetMem (Buf, L); 279 | try 280 | if not ReadProcessMemory(Process, lpDebugStringData, Buf, L, Cardinal(nil^)) then 281 | S := '' 282 | else begin 283 | if fUnicode = 0 then 284 | SetString (S, PAnsiChar(Buf), L) 285 | else 286 | WideCharLenToStrVar (PWideChar(Buf), L div 2, S); 287 | end; 288 | DebugLog ('String', S); 289 | S := ''; 290 | finally 291 | FreeMem (Buf); 292 | end; 293 | end; 294 | end; 295 | EXCEPTION_DEBUG_EVENT: begin 296 | case DE.Exception.ExceptionRecord.ExceptionCode of 297 | EXCEPTION_BREAKPOINT: begin 298 | ContinueStatus := DBG_CONTINUE; 299 | if FirstBreakpoint then begin 300 | { When a process starts, the system generates its own 301 | breakpoint exception. Use this opportunity to set up 302 | an initial breakpoint in our program. } 303 | FirstBreakpoint := False; 304 | BkptAddr := InterlockedExchange(Integer(DebugWantBreakpointAt), 0); 305 | if BkptAddr <> 0 then 306 | Inc (BkptAddr, ImageBase) 307 | else if DebugSingleStep then 308 | { Set a breakpoint at the program's entry point, so single 309 | stepping can begin there. } 310 | BkptAddr := ImageBase + $2000; 311 | if BkptAddr <> 0 then 312 | WriteByte (BkptAddr, Int3, @SaveByte); 313 | end 314 | else begin 315 | Context.ContextFlags := CONTEXT_CONTROL or CONTEXT_INTEGER or 316 | CONTEXT_SEGMENTS; 317 | Win32Check (GetThreadContext (Thread, Context)); 318 | { When a breakpoint exception is raised, EIP points to the 319 | instruction following the breakpoint instruction (INT3). 320 | So, if EIP is one byte past BkptAddr, we have gotten to 321 | the breakpoint we were waiting for. } 322 | if (BkptAddr <> 0) and (Context.Eip = BkptAddr + 1) then begin 323 | { Move EIP back to the INT3 byte ($CC), and replace it 324 | with the original byte. } 325 | Context.Eip := BkptAddr; 326 | WriteByte (BkptAddr, SaveByte, nil); 327 | BkptAddr := 0; 328 | Pause (True); 329 | if DebugSingleStep then 330 | Context.EFlags := Context.EFlags or TraceFlag; 331 | Context.ContextFlags := CONTEXT_CONTROL; 332 | Win32Check (SetThreadContext (Thread, Context)); 333 | end; 334 | end; 335 | end; 336 | EXCEPTION_SINGLE_STEP: begin 337 | ContinueStatus := DBG_CONTINUE; 338 | if StepBkptAddr <> 0 then begin 339 | BkptAddr := StepBkptAddr; 340 | StepBkptAddr := 0; 341 | WriteByte (BkptAddr, Int3, @SaveByte); 342 | end; 343 | if DebugSingleStep then begin 344 | Context.ContextFlags := CONTEXT_CONTROL or CONTEXT_INTEGER or 345 | CONTEXT_SEGMENTS; 346 | GetThreadContext (Thread, Context); 347 | { Note: When a single step exception is raised, EIP points 348 | to the instruction that will be executed next. } 349 | 350 | if (Context.Eip < ImageBase + $2000) or 351 | (Context.Eip >= ImageBase + $3000) then begin 352 | { We've left our code! Stop single stepping. } 353 | //OutputDebugString (PChar(Format('untracable step - %.8x', [Context.Eip]))); 354 | end 355 | else begin 356 | //OutputDebugString (PChar(Format('step - %.8x', [Context.Eip]))); 357 | Pause (True); 358 | if DebugSingleStep then begin 359 | { Don't trace into jmp [xxxxxxxx] instructions that are 360 | outside our code; instead set a breakpoint on the return 361 | address at the top of the stack to resume single 362 | stepping there. } 363 | if ReadProcessMemory(Process, Pointer(Context.Eip), @JumpInstr, SizeOf(JumpInstr), Cardinal(nil^)) and 364 | (JumpInstr.Opcode = $25FF) and 365 | ReadProcessMemory(Process, Pointer(Context.Esp), @ReturnAddr, SizeOf(ReturnAddr), Cardinal(nil^)) then begin 366 | BkptAddr := ReturnAddr; 367 | WriteByte (BkptAddr, Int3, @SaveByte); 368 | end 369 | else begin 370 | { The trace flag is reset after each single step 371 | exception, so we have to set it back in order to 372 | continue single stepping. } 373 | Context.EFlags := Context.EFlags or TraceFlag; 374 | Context.ContextFlags := CONTEXT_CONTROL; 375 | SetThreadContext (Thread, Context); 376 | end; 377 | end; 378 | end; 379 | end; 380 | end; 381 | EXCEPTION_ACCESS_VIOLATION: begin 382 | Context.ContextFlags := CONTEXT_CONTROL or CONTEXT_INTEGER or 383 | CONTEXT_SEGMENTS; 384 | GetThreadContext (Thread, Context); 385 | CriticalError (Format('Access violation in process at %.8x. %s of address %.8x.', 386 | [Context.Eip, 387 | ReadWriteText[DE.Exception.ExceptionRecord.ExceptionInformation[0] <> 0], 388 | DE.Exception.ExceptionRecord.ExceptionInformation[1]])); 389 | Pause (False); 390 | end; 391 | else 392 | {DebugLog ('Unhandled exception', 393 | IntToHex(DE.Exception.ExceptionRecord.ExceptionCode, 8));} 394 | CriticalError (Format('Unhandled exception %.8x in process.', 395 | [DE.Exception.ExceptionRecord.ExceptionCode])); 396 | end; 397 | end; 398 | else 399 | DebugLog (Format('Unknown (%d)', [DE.dwDebugEventCode]), ''); 400 | end; 401 | if not ContinueDebugEvent(DE.dwProcessId, DE.dwThreadId, ContinueStatus) then 402 | Exit; 403 | end; 404 | except 405 | on E: Exception do 406 | ErrorMsg := LPARAM(StrNew(PChar(E.ClassName + ': ' + E.Message))); 407 | end; 408 | 409 | if Process <> 0 then 410 | CloseHandle (Process); 411 | if Thread <> 0 then 412 | CloseHandle (Thread); 413 | Debugging := False; 414 | CloseHandle (DebugProcess); 415 | DebugProcess := 0; 416 | 417 | SendMessage (Data.CommWnd, Data.CommMsg, dmStopped, ErrorMsg); 418 | Dispose (Data); 419 | end; 420 | 421 | initialization 422 | DebugContinueEvent := CreateEvent(nil, True, False, nil); 423 | finalization 424 | CloseHandle (DebugContinueEvent); 425 | DebugContinueEvent := 0; 426 | if DebugThread <> 0 then 427 | CloseHandle (DebugThread); 428 | end. 429 | -------------------------------------------------------------------------------- /Src/DebuggerProcs.pas: -------------------------------------------------------------------------------- 1 | unit DebuggerProcs; 2 | 3 | { 4 | Inno Pascal 5 | Copyright (C) 2000 Jordan Russell 6 | 7 | www: http://www.jrsoftware.org/ 8 | or http://www.jordanr.cjb.net/ 9 | email: jr@jrsoftware.org 10 | 11 | This program is free software; you can redistribute it and/or 12 | modify it under the terms of the GNU General Public License 13 | as published by the Free Software Foundation; either version 2 14 | of the License, or (at your option) any later version. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | GNU General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with this program; if not, write to the Free Software 23 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 24 | } 25 | 26 | // created 2000-09-27 by Michael Hieke, mghie@gmx.net, 27 | // based on code Copyright Matt Pietrek 1995 28 | 29 | interface 30 | 31 | uses 32 | Windows; 33 | 34 | function DebugReadProcessMemory(AProcess: THandle; const ABaseAddress: Pointer; 35 | ABuffer: Pointer; ASize: DWORD): boolean; 36 | function DebugProcessGetModuleName(AProcess: THandle; 37 | AModuleAsPtr: Pointer): string; 38 | function DebugGetPreferredLoadAddress(AProcess: THandle; 39 | AModuleAsPtr: Pointer): Pointer; 40 | 41 | implementation 42 | 43 | function DebugReadProcessMemory(AProcess: THandle; const ABaseAddress: Pointer; 44 | ABuffer: Pointer; ASize: DWORD): boolean; 45 | var 46 | BytesRead: DWORD; 47 | begin 48 | Result := ReadProcessMemory(AProcess, ABaseAddress, ABuffer, ASize, BytesRead) and 49 | (BytesRead = ASize); 50 | end; 51 | 52 | function GetModuleHeader(AProcess: THandle; AModuleAsPtr: Pointer; 53 | AImageNTHeaders: PImageNtHeaders): boolean; 54 | var 55 | DH: TImageDosHeader; 56 | begin 57 | if DebugReadProcessMemory(AProcess, AModuleAsPtr, @DH, SizeOf(TImageDosHeader)) then 58 | Result := DebugReadProcessMemory(AProcess, Pointer(DWORD(AModuleAsPtr) + 59 | DWORD(DH._lfanew)), AImageNTHeaders, SizeOf(TImageNTHeaders)) 60 | else 61 | Result := FALSE; 62 | end; 63 | 64 | function DebugProcessGetModuleName(AProcess: THandle; AModuleAsPtr: Pointer): string; 65 | var 66 | IH: TImageNtHeaders; 67 | IED: TImageExportDirectory; 68 | ExportsRVA: DWORD; 69 | s: string; 70 | begin 71 | Result := ''; 72 | if GetModuleHeader(AProcess, AModuleAsPtr, @IH) then begin 73 | ExportsRVA := IH.OptionalHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_EXPORT].VirtualAddress; 74 | if (ExportsRVA <> 0) and DebugReadProcessMemory(AProcess, 75 | Pointer(DWORD(AModuleAsPtr) + ExportsRVA), @IED, SizeOf(TImageExportDirectory)) then 76 | begin 77 | SetLength(s, 64); 78 | if DebugReadProcessMemory(AProcess, Pointer(DWORD(AModuleAsPtr) + IED.Name), @s[1], 64) then 79 | Result := PChar(s); 80 | end; 81 | end; 82 | end; 83 | 84 | function DebugGetPreferredLoadAddress(AProcess: THandle; AModuleAsPtr: Pointer): Pointer; 85 | var 86 | IH: TImageNtHeaders; 87 | begin 88 | if GetModuleHeader(AProcess, AModuleAsPtr, @IH) then 89 | Result := Pointer(IH.OptionalHeader.ImageBase) 90 | else 91 | Result := nil; 92 | end; 93 | 94 | end. 95 | -------------------------------------------------------------------------------- /Src/IP.dpr: -------------------------------------------------------------------------------- 1 | program IP; 2 | 3 | uses 4 | Controls, 5 | Forms, 6 | Compiler in 'Compiler.pas', 7 | Main in 'Main.pas' {MainForm}, 8 | CodeX86 in 'CodeX86.pas', 9 | DebugEventLog in 'DebugEventLog.pas' {DebugEventLogForm}, 10 | DebugRegisters in 'DebugRegisters.pas' {DebugRegistersForm}, 11 | Debugger in 'Debugger.pas', 12 | LinkerPE in 'LinkerPE.pas', 13 | Common in 'Common.pas', 14 | IPascal in 'IPascal.pas', 15 | IPBase in 'IPBase.pas'; 16 | 17 | {$R *.RES} 18 | 19 | begin 20 | Application.Initialize; 21 | Application.Title := 'Inno Pascal'; 22 | Application.CreateForm(TMainForm, MainForm); 23 | Application.CreateForm(TDebugEventLogForm, DebugEventLogForm); 24 | Application.CreateForm(TDebugRegistersForm, DebugRegistersForm); 25 | Application.Run; 26 | end. 27 | -------------------------------------------------------------------------------- /Src/IPBase.pas: -------------------------------------------------------------------------------- 1 | unit IPBase; 2 | 3 | { 4 | Inno Pascal 5 | Copyright (C) 2000 Jordan Russell 6 | 7 | www: http://www.jrsoftware.org/ 8 | or http://www.jordanr.cjb.net/ 9 | email: jr@jrsoftware.org 10 | 11 | This program is free software; you can redistribute it and/or 12 | modify it under the terms of the GNU General Public License 13 | as published by the Free Software Foundation; either version 2 14 | of the License, or (at your option) any later version. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | GNU General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with this program; if not, write to the Free Software 23 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 24 | } 25 | 26 | interface 27 | 28 | { Declarations for applications } 29 | 30 | uses 31 | SysUtils, Classes; 32 | 33 | type 34 | EIPCompilerError = class(Exception) 35 | public 36 | Filename: String; 37 | Line, Ch: Integer; 38 | ErrorText: String; 39 | end; 40 | 41 | PLineNumberInfoArray = ^TLineNumberInfoArray; 42 | TLineNumberInfoArray = array[1..$1FFFFFFF] of Cardinal; 43 | 44 | TCompilerStatusType = (stWarning, stHint); 45 | TCompilerStatusProc = procedure(AType: TCompilerStatusType; 46 | const AFilename: String; ALine, ACh: Integer; const AMsg: String) of object; 47 | 48 | implementation 49 | 50 | end. 51 | -------------------------------------------------------------------------------- /Src/IPascal.cfg: -------------------------------------------------------------------------------- 1 | -$A+ 2 | -$B- 3 | -$C+ 4 | -$D+ 5 | -$E- 6 | -$F- 7 | -$G+ 8 | -$H+ 9 | -$I+ 10 | -$J+ 11 | -$K- 12 | -$L+ 13 | -$M- 14 | -$N+ 15 | -$O+ 16 | -$P+ 17 | -$Q- 18 | -$R- 19 | -$S- 20 | -$T- 21 | -$U- 22 | -$V+ 23 | -$W- 24 | -$X+ 25 | -$YD 26 | -$Z1 27 | -cg 28 | -AWinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; 29 | -H+ 30 | -W+ 31 | -M 32 | -$M16384,1048576 33 | -K$00400000 34 | -LE"d:\delphi5\Projects\Bpl" 35 | -LN"d:\delphi5\Projects\Bpl" 36 | -------------------------------------------------------------------------------- /Src/IPascal.dof: -------------------------------------------------------------------------------- 1 | [Compiler] 2 | A=1 3 | B=0 4 | C=1 5 | D=1 6 | E=0 7 | F=0 8 | G=1 9 | H=1 10 | I=1 11 | J=1 12 | K=0 13 | L=1 14 | M=0 15 | N=1 16 | O=1 17 | P=1 18 | Q=0 19 | R=0 20 | S=0 21 | T=0 22 | U=0 23 | V=1 24 | W=0 25 | X=1 26 | Y=1 27 | Z=1 28 | ShowHints=1 29 | ShowWarnings=1 30 | UnitAliases=WinTypes=Windows;WinProcs=Windows;DbiTypes=BDE;DbiProcs=BDE;DbiErrs=BDE; 31 | [Linker] 32 | MapFile=0 33 | OutputObjs=0 34 | ConsoleApp=1 35 | DebugInfo=0 36 | RemoteSymbols=0 37 | MinStackSize=16384 38 | MaxStackSize=1048576 39 | ImageBase=4194304 40 | ExeDescription= 41 | [Directories] 42 | OutputDir= 43 | UnitOutputDir= 44 | PackageDLLOutputDir= 45 | PackageDCPOutputDir= 46 | SearchPath= 47 | Packages=Vcl50;Vclx50;VclSmp50;Vcldb50;Vclbde50;vclie50;Inetdb50;Inet50;NMFast50;Icsdel50;TeeQR50 48 | Conditionals= 49 | DebugSourceDirs= 50 | UsePackages=0 51 | [Parameters] 52 | RunParams= 53 | HostApplication= 54 | [Language] 55 | ActiveLang= 56 | ProjectLang=$00000409 57 | RootDir= 58 | [Version Info] 59 | IncludeVerInfo=0 60 | AutoIncBuild=0 61 | MajorVer=1 62 | MinorVer=0 63 | Release=0 64 | Build=0 65 | Debug=0 66 | PreRelease=0 67 | Special=0 68 | Private=0 69 | DLL=0 70 | Locale=1033 71 | CodePage=1252 72 | [Version Info Keys] 73 | CompanyName= 74 | FileDescription= 75 | FileVersion=1.0.0.0 76 | InternalName= 77 | LegalCopyright= 78 | LegalTrademarks= 79 | OriginalFilename= 80 | ProductName= 81 | ProductVersion=1.0.0.0 82 | Comments= 83 | -------------------------------------------------------------------------------- /Src/IPascal.dpr: -------------------------------------------------------------------------------- 1 | program IPascal; 2 | 3 | uses 4 | Controls, 5 | Forms, 6 | Compiler in 'Compiler.pas', 7 | Main in 'Main.pas' {MainForm}, 8 | CodeX86 in 'CodeX86.pas', 9 | DebugEventLog in 'DebugEventLog.pas' {DebugEventLogForm}, 10 | DebugRegisters in 'DebugRegisters.pas' {DebugRegistersForm}, 11 | Debugger in 'Debugger.pas', 12 | Linker in 'Linker.pas', 13 | Common in 'Common.pas'; 14 | 15 | {$R *.RES} 16 | 17 | begin 18 | Application.Initialize; 19 | Application.Title := 'Inno Pascal'; 20 | Application.CreateForm(TMainForm, MainForm); 21 | Application.CreateForm(TDebugEventLogForm, DebugEventLogForm); 22 | Application.CreateForm(TDebugRegistersForm, DebugRegistersForm); 23 | Application.Run; 24 | end. 25 | -------------------------------------------------------------------------------- /Src/IPascal.pas: -------------------------------------------------------------------------------- 1 | unit IPascal; 2 | 3 | { 4 | Inno Pascal 5 | Copyright (C) 2000 Jordan Russell 6 | 7 | www: http://www.jrsoftware.org/ 8 | or http://www.jordanr.cjb.net/ 9 | email: jr@jrsoftware.org 10 | 11 | This program is free software; you can redistribute it and/or 12 | modify it under the terms of the GNU General Public License 13 | as published by the Free Software Foundation; either version 2 14 | of the License, or (at your option) any later version. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | GNU General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with this program; if not, write to the Free Software 23 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 24 | } 25 | 26 | interface 27 | 28 | { Main application interface } 29 | 30 | uses 31 | Compiler, Common, IPBase; 32 | 33 | const 34 | InnoPascalVersion = '0.1.5'; 35 | 36 | function IPCompileAndLink (const Filename: String; const Src: PChar; 37 | const OutFile: String; TotalLines: Integer; 38 | var LineNumberInfo: PLineNumberInfoArray; 39 | const StatusProc: TCompilerStatusProc; const LinkerClass: TIPLinkerClass; 40 | const CodeGenClass: TIPCodeGenClass): Cardinal; 41 | 42 | implementation 43 | 44 | function IPCompileAndLink (const Filename: String; const Src: PChar; 45 | const OutFile: String; TotalLines: Integer; 46 | var LineNumberInfo: PLineNumberInfoArray; 47 | const StatusProc: TCompilerStatusProc; const LinkerClass: TIPLinkerClass; 48 | const CodeGenClass: TIPCodeGenClass): Cardinal; 49 | var 50 | Linker: TIPCustomLinker; 51 | Comp: TIPCompiler; 52 | begin 53 | GetMem (LineNumberInfo, TotalLines * SizeOf(Cardinal)); 54 | try 55 | FillChar (LineNumberInfo^, TotalLines * SizeOf(Cardinal), $FF); { fill with -1 } 56 | Linker := LinkerClass.Create; 57 | try 58 | Comp := TIPCompiler.Create; 59 | try 60 | Comp.DoCompile (Linker, CodeGenClass, Filename, Src, StatusProc); 61 | Result := Linker.DoLink(OutFile, LineNumberInfo); 62 | finally 63 | Comp.Free; 64 | end; 65 | finally 66 | Linker.Free; 67 | end; 68 | except 69 | FreeMem (LineNumberInfo); 70 | LineNumberInfo := nil; 71 | raise; 72 | end; 73 | end; 74 | 75 | end. 76 | -------------------------------------------------------------------------------- /Src/IPascal.res: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/smle/inno-pascal/9246bd2ac76ffba4349dadfb8e856aa11f1dc4f3/Src/IPascal.res -------------------------------------------------------------------------------- /Src/Linker.pas: -------------------------------------------------------------------------------- 1 | unit Linker; 2 | 3 | { 4 | Inno Pascal 5 | Copyright (C) 2000 Jordan Russell 6 | 7 | www: http://www.jrsoftware.org/ 8 | or http://www.jordanr.cjb.net/ 9 | email: jr@jrsoftware.org 10 | 11 | This program is free software; you can redistribute it and/or 12 | modify it under the terms of the GNU General Public License 13 | as published by the Free Software Foundation; either version 2 14 | of the License, or (at your option) any later version. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | GNU General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with this program; if not, write to the Free Software 23 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 24 | } 25 | 26 | {$I+} 27 | 28 | interface 29 | 30 | uses 31 | Compiler; 32 | 33 | type 34 | PLineNumberInfoArray = ^TLineNumberInfoArray; 35 | TLineNumberInfoArray = array[1..$1FFFFFFF] of Cardinal; 36 | 37 | TIPLinker = class 38 | private 39 | FOutFile: String; 40 | procedure WritePEHeader (const Compiler: TIPCompiler; 41 | const LineNumberInfo: PLineNumberInfoArray; var F: File); 42 | function DoLink (const Compiler: TIPCompiler; 43 | const LineNumberInfo: PLineNumberInfoArray): Cardinal; 44 | end; 45 | 46 | function IPCompileAndLink (const Filename: String; const Src: PChar; 47 | const OutFile: String; TotalLines: Integer; 48 | var LineNumberInfo: PLineNumberInfoArray; 49 | const StatusProc: TCompilerStatusProc): Cardinal; 50 | 51 | implementation 52 | 53 | uses 54 | Windows, SysUtils, Common, CodeX86; 55 | 56 | type 57 | PImageImportDescriptor = ^TImageImportDescriptor; 58 | TImageImportDescriptor = packed record 59 | Characteristics: DWORD; 60 | { ^ union OriginalFirstThunk: DWORD;} 61 | TimeDateStamp: DWORD; 62 | ForwarderChain: DWORD; 63 | Name: DWORD; 64 | FirstThunk: DWORD; 65 | end; 66 | 67 | const 68 | xFileAlignment = $200; 69 | 70 | 71 | procedure WriteZeroes (var F: File; Count: Cardinal); 72 | var 73 | Buf: array[0..4095] of Byte; 74 | C: Cardinal; 75 | begin 76 | FillChar (Buf, SizeOf(Buf), 0); 77 | while Count <> 0 do begin 78 | C := Count; 79 | if C > SizeOf(Buf) then C := SizeOf(Buf); 80 | BlockWrite (F, Buf, C); 81 | end; 82 | end; 83 | 84 | function IPCompileAndLink (const Filename: String; const Src: PChar; 85 | const OutFile: String; TotalLines: Integer; 86 | var LineNumberInfo: PLineNumberInfoArray; 87 | const StatusProc: TCompilerStatusProc): Cardinal; 88 | var 89 | Linker: TIPLinker; 90 | Comp: TIPCompiler; 91 | begin 92 | GetMem (LineNumberInfo, TotalLines * SizeOf(Cardinal)); 93 | try 94 | FillChar (LineNumberInfo^, TotalLines * SizeOf(Cardinal), $FF); { fill with -1 } 95 | Comp := TIPCompiler.Create; 96 | try 97 | Comp.DoCompile (Filename, Src, StatusProc); 98 | Linker := TIPLinker.Create; 99 | try 100 | Linker.FOutFile := OutFile; 101 | Result := Linker.DoLink(Comp, LineNumberInfo); 102 | finally 103 | Linker.Free; 104 | end; 105 | finally 106 | Comp.Free; 107 | end; 108 | except 109 | FreeMem (LineNumberInfo); 110 | LineNumberInfo := nil; 111 | raise; 112 | end; 113 | end; 114 | 115 | 116 | { TIPLinker } 117 | 118 | function TIPLinker.DoLink (const Compiler: TIPCompiler; 119 | const LineNumberInfo: PLineNumberInfoArray): Cardinal; 120 | var 121 | F: File; 122 | begin 123 | AssignFile (F, FOutFile); 124 | FileMode := fmOpenReadWrite or fmShareExclusive; 125 | {$I-} 126 | Rewrite (F, 1); 127 | {$I+} 128 | if IOResult <> 0 then begin 129 | { Sometimes the EXE is still in use if it was terminated right before 130 | DoLink was called again. Delay 100 msec and try again. } 131 | Sleep (100); 132 | Rewrite (F, 1); 133 | end; 134 | try 135 | WritePEHeader (Compiler, LineNumberInfo, F); 136 | Result := FileSize(F); 137 | finally 138 | CloseFile (F); 139 | end; 140 | end; 141 | 142 | procedure TIPLinker.WritePEHeader (const Compiler: TIPCompiler; 143 | const LineNumberInfo: PLineNumberInfoArray; var F: File); 144 | 145 | procedure PadForFileAlignment; 146 | var 147 | I: Integer; 148 | Slack: array[0..xFileAlignment-1] of Byte; 149 | begin 150 | I := xFileAlignment - (FilePos(F) mod xFileAlignment); 151 | if I > 0 then begin 152 | FillChar (Slack, I, 0); 153 | BlockWrite (F, Slack, I); 154 | end; 155 | end; 156 | 157 | const 158 | PESig: DWORD = $00004550; 159 | 160 | DOSStub: array[0..111] of Byte = ( 161 | $4D, $5A, $6C, $00, $01, $00, $00, $00, $04, $00, $11, $00, $FF, $FF, 162 | $03, $00, $00, $01, $00, $00, $00, $00, $00, $00, $40, $00, $00, $00, 163 | $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, 164 | $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, 165 | $00, $00, $00, $00, $70, $00, $00, $00, $0E, $1F, $BA, $0E, $00, $B4, 166 | $09, $CD, $21, $B8, $00, $4C, $CD, $21, $54, $68, $69, $73, $20, $70, 167 | $72, $6F, $67, $72, $61, $6D, $20, $72, $65, $71, $75, $69, $72, $65, 168 | $73, $20, $57, $69, $6E, $33, $32, $0D, $0A, $24, $2D, $49, $50, $2D); 169 | 170 | IDataRVA = $1000; 171 | CodeRVA = $2000; 172 | BSSRVA = $3000; 173 | var 174 | PEHeader: TImageFileHeader; 175 | OptHeader: TImageOptionalHeader; 176 | Sec: TImageSectionHeader; 177 | ImportDir: array of TImageImportDescriptor; 178 | LookupTableRVA, AddressTableRVA, NameTableRVA: DWORD; 179 | LookupTable: array of DWORD; 180 | NameTable: String; 181 | 182 | function AllocName (const IsFuncName: Boolean; const S: String): DWORD; 183 | begin 184 | Result := NameTableRVA + DWORD(Length(NameTable)); 185 | if not IsFuncName then 186 | NameTable := NameTable + S + #0 187 | else 188 | NameTable := NameTable + #0#0 + S + #0; 189 | if Length(NameTable) and 1 <> 0 then { need word alignment } 190 | NameTable := NameTable + #0; 191 | end; 192 | 193 | label 1; 194 | var 195 | I, J, D: Integer; 196 | L: Cardinal; 197 | TotalCode, OptHeaderOfs, IDataOfs, IDataSize: Cardinal; 198 | HasCalledProcs: Boolean; 199 | FuncData: PFuncData; 200 | ConstSectionOffset: Cardinal; 201 | LineNumberRec: PLineNumberRec; 202 | begin 203 | BlockWrite (F, DOSStub, SizeOf(DOSStub)); 204 | 205 | BlockWrite (F, PESig, SizeOf(PESig)); 206 | 207 | FillChar (PEHeader, SizeOf(PEHeader), 0); 208 | PEHeader.Machine := IMAGE_FILE_MACHINE_I386; 209 | PEHeader.NumberOfSections := 3; {FIXME} 210 | PEHeader.TimeDateStamp := 0; 211 | PEHeader.PointerToSymbolTable := 0; 212 | PEHeader.NumberOfSymbols := 0; 213 | PEHeader.SizeOfOptionalHeader := SizeOf(OptHeader); 214 | PEHeader.Characteristics := $818E or IMAGE_FILE_RELOCS_STRIPPED; 215 | BlockWrite (F, PEHeader, SizeOf(PEHeader)); 216 | 217 | FillChar (OptHeader, SizeOf(OptHeader), 0); 218 | OptHeader.Magic := $010B; 219 | OptHeader.MajorLinkerVersion := 0; 220 | OptHeader.MinorLinkerVersion := 0; 221 | OptHeader.SizeOfCode := 0; { set later } 222 | OptHeader.SizeOfInitializedData := 0; 223 | OptHeader.SizeOfUninitializedData := 0; 224 | OptHeader.AddressOfEntryPoint := CodeRVA; {FIXME} 225 | OptHeader.BaseOfCode := CodeRVA; {FIXME} 226 | OptHeader.BaseOfData := 0;//$1000; {FIXME} 227 | OptHeader.ImageBase := $400000; 228 | OptHeader.SectionAlignment := $1000; 229 | OptHeader.FileAlignment := xFileAlignment; 230 | OptHeader.MajorOperatingSystemVersion := 1; 231 | OptHeader.MinorOperatingSystemVersion := 0; 232 | OptHeader.MajorImageVersion := 0; 233 | OptHeader.MajorImageVersion := 0; 234 | OptHeader.MajorSubsystemVersion := 4; 235 | OptHeader.Win32VersionValue := 0; 236 | OptHeader.SizeOfImage := $1000 {address of first section} + 237 | $3000; 238 | // (DWORD(PEHeader.NumberOfSections) * OptHeader.SectionAlignment); {FIXME} 239 | { ^ won't handle sections with size > OptHeader.SectionAlignment properly } 240 | OptHeader.SizeOfHeaders := $200; //FilePos(F) + SizeOf(OptHeader); {test} 241 | OptHeader.CheckSum := 0; 242 | if not Compiler.LinkOptions.ConsoleApp then 243 | OptHeader.Subsystem := IMAGE_SUBSYSTEM_WINDOWS_GUI 244 | else 245 | OptHeader.Subsystem := IMAGE_SUBSYSTEM_WINDOWS_CUI; 246 | OptHeader.DllCharacteristics := 0; 247 | OptHeader.SizeOfStackReserve := $100000; 248 | OptHeader.SizeOfStackCommit := $4000; 249 | OptHeader.SizeOfHeapReserve := $100000; 250 | OptHeader.SizeOfHeapCommit := $1000; 251 | OptHeader.LoaderFlags := 0; 252 | OptHeader.NumberOfRvaAndSizes := IMAGE_NUMBEROF_DIRECTORY_ENTRIES; 253 | OptHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress := IDataRVA; 254 | OptHeaderOfs := FilePos(F); 255 | BlockWrite (F, OptHeader, SizeOf(OptHeader)); 256 | 257 | FillChar (Sec, SizeOf(Sec), 0); 258 | StrPCopy (@Sec.Name, '.idata'); 259 | Sec.Misc.VirtualSize := $1000; 260 | Sec.VirtualAddress := IDataRVA; 261 | Sec.SizeOfRawData := $200; { must be multiple of file alignment } 262 | Sec.PointerToRawData := $200; 263 | Sec.Characteristics := IMAGE_SCN_CNT_INITIALIZED_DATA or IMAGE_SCN_MEM_READ or 264 | IMAGE_SCN_MEM_WRITE; 265 | BlockWrite (F, Sec, SizeOf(Sec)); 266 | 267 | FillChar (Sec, SizeOf(Sec), 0); 268 | StrPCopy (@Sec.Name, '.text'); 269 | Sec.Misc.VirtualSize := $1000; 270 | Sec.VirtualAddress := CodeRVA; 271 | Sec.SizeOfRawData := $200; { must be multiple of file alignment } 272 | Sec.PointerToRawData := $400; 273 | Sec.Characteristics := IMAGE_SCN_CNT_CODE or IMAGE_SCN_MEM_EXECUTE or 274 | IMAGE_SCN_MEM_READ; 275 | BlockWrite (F, Sec, SizeOf(Sec)); 276 | 277 | (*FillChar (Sec, SizeOf(Sec), 0); 278 | StrPCopy (@Sec.Name, '.reloc'); 279 | Sec.Misc.VirtualSize := $1000; 280 | Sec.VirtualAddress := $2000; 281 | Sec.SizeOfRawData := $200; { must be multiple of file alignment } 282 | Sec.PointerToRawData := 0; 283 | Sec.Characteristics := //$50000040 <- wrong? 284 | IMAGE_SCN_CNT_INITIALIZED_DATA or IMAGE_SCN_MEM_READ or IMAGE_SCN_MEM_DISCARDABLE; 285 | BlockWrite (F, Sec, SizeOf(Sec));*) 286 | 287 | FillChar (Sec, SizeOf(Sec), 0); 288 | StrPCopy (@Sec.Name, '.bss'); 289 | Sec.Misc.VirtualSize := Compiler.DataSectionSize; //$1000; 290 | Sec.VirtualAddress := BSSRVA; 291 | Sec.SizeOfRawData := 0; { must be multiple of file alignment } 292 | Sec.PointerToRawData := $400; 293 | Sec.Characteristics := IMAGE_SCN_CNT_UNINITIALIZED_DATA or IMAGE_SCN_MEM_READ or 294 | IMAGE_SCN_MEM_WRITE; 295 | BlockWrite (F, Sec, SizeOf(Sec)); 296 | 297 | PadForFileAlignment; 298 | 299 | { -- IMPORT TABLE -- } 300 | 301 | NameTable := ''; 302 | D := 0; 303 | L := 0; 304 | for I := 0 to Compiler.DLLList.Count-1 do begin 305 | HasCalledProcs := False; 306 | for J := 0 to Compiler.Funcs.Count-1 do begin 307 | FuncData := Compiler.Funcs[J]; 308 | if (FuncData.DLLIndex = I) and FuncData.Called then begin 309 | HasCalledProcs := True; 310 | Inc (L); 311 | end; 312 | end; 313 | if HasCalledProcs then begin 314 | Inc (L); 315 | Compiler.DLLList.Objects[I] := Pointer(1); { non-zero means the DLL is used } 316 | Inc (D); 317 | end; 318 | end; 319 | SetLength (ImportDir, D + 1); 320 | SetLength (LookupTable, L); 321 | 322 | LookupTableRVA := IDataRVA + (Length(ImportDir) * SizeOf(ImportDir[0])); 323 | AddressTableRVA := LookupTableRVA + (Cardinal(Length(LookupTable)) * SizeOf(LookupTable[0])); 324 | NameTableRVA := AddressTableRVA + (Cardinal(Length(LookupTable)) * SizeOf(LookupTable[0])); 325 | 326 | FillChar (ImportDir[0], Length(ImportDir) * SizeOf(ImportDir[0]), 0); 327 | L := 0; 328 | D := 0; 329 | for I := 0 to Compiler.DLLList.Count-1 do begin 330 | if Compiler.DLLList.Objects[I] = nil then { Objects[I] will be zero if DLL isn't used } 331 | Continue; 332 | ImportDir[D].Characteristics := LookupTableRVA + (L * SizeOf(DWORD)); 333 | ImportDir[D].Name := AllocName(False, Compiler.DLLList[I]); 334 | ImportDir[D].FirstThunk := AddressTableRVA + (L * SizeOf(DWORD)); 335 | for J := 0 to Compiler.Funcs.Count-1 do begin 336 | FuncData := PFuncData(Compiler.Funcs[J]); 337 | if (FuncData.DLLIndex = I) and FuncData.Called then begin 338 | LookupTable[L] := AllocName(True, FuncData.ImportName); 339 | FuncData.CodeGen := TX86CodeGen.Create; 340 | FuncData.CodeGen.ImportThunk (OptHeader.ImageBase + AddressTableRVA + 341 | (L * SizeOf(DWORD))); 342 | Inc (L); 343 | end; 344 | end; 345 | LookupTable[L] := 0; 346 | Inc (L); 347 | Inc (D); 348 | end; 349 | 350 | IDataOfs := FilePos(F); 351 | BlockWrite (F, ImportDir[0], Length(ImportDir) * SizeOf(ImportDir[0])); 352 | BlockWrite (F, LookupTable[0], Length(LookupTable) * SizeOf(LookupTable[0])); 353 | BlockWrite (F, LookupTable[0], Length(LookupTable) * SizeOf(LookupTable[0])); 354 | BlockWrite (F, PChar(NameTable)^, Length(NameTable)); 355 | IDataSize := Cardinal(FilePos(F)) - IDataOfs; 356 | if IDataSize > $200 then 357 | raise Exception.Create('Too many imports'); {} 358 | PadForFileAlignment; 359 | 360 | { -- CODE -- } 361 | 362 | { Calculate total size of code section, and assign each used function a 363 | relative address } 364 | TotalCode := 0; 365 | for I := 0 to Compiler.Funcs.Count-1 do begin 366 | FuncData := Compiler.Funcs[I]; 367 | if FuncData.Called and Assigned(FuncData.CodeGen) then begin 368 | FuncData.Address := TotalCode; 369 | Inc (TotalCode, Length(FuncData.CodeGen.Code)); 370 | for J := 0 to FuncData.CodeGen.LineNumbers.Count-1 do begin 371 | LineNumberRec := FuncData.CodeGen.LineNumbers[J]; 372 | if LineNumberInfo[LineNumberRec.LineNum] = $FFFFFFFF then 373 | LineNumberInfo[LineNumberRec.LineNum] := CodeRVA + FuncData.Address + 374 | LineNumberRec.CodeAddr; 375 | end; 376 | end; 377 | end; 378 | ConstSectionOffset := TotalCode; 379 | Inc (TotalCode, Length(Compiler.ConstSection)); 380 | if TotalCode > $200 then 381 | raise Exception.Create('Too much code'); {} 382 | 383 | { Apply fixups } 384 | for I := Compiler.Funcs.Count-1 downto 0 do begin 385 | FuncData := Compiler.Funcs[I]; 386 | if FuncData.Called and Assigned(FuncData.CodeGen) then begin 387 | FuncData.CodeGen.ApplyFixups (Compiler.Funcs, 388 | FuncData.Address, 389 | OptHeader.ImageBase + CodeRVA, 390 | OptHeader.ImageBase + CodeRVA + ConstSectionOffset, 391 | OptHeader.ImageBase + BSSRVA); 392 | end; 393 | end; 394 | 395 | { Write out all functions, then constants } 396 | for I := 0 to Compiler.Funcs.Count-1 do begin 397 | FuncData := Compiler.Funcs[I]; 398 | if FuncData.Called and Assigned(FuncData.CodeGen) then 399 | BlockWrite (F, PChar(FuncData.CodeGen.Code)^, Length(FuncData.CodeGen.Code)); 400 | end; 401 | BlockWrite (F, PChar(Compiler.ConstSection)^, Length(Compiler.ConstSection)); 402 | PadForFileAlignment; 403 | 404 | { -- FINALIZE -- } 405 | 406 | { Go back and rewrite opt header with correct section sizes } 407 | 408 | OptHeader.SizeOfCode := TotalCode; 409 | OptHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].Size := IDataSize; 410 | Seek (F, OptHeaderOfs); 411 | BlockWrite (F, OptHeader, SizeOf(OptHeader)); 412 | end; 413 | 414 | end. 415 | -------------------------------------------------------------------------------- /Src/LinkerPE.pas: -------------------------------------------------------------------------------- 1 | unit LinkerPE; 2 | 3 | { 4 | Inno Pascal 5 | Copyright (C) 2000 Jordan Russell 6 | 7 | www: http://www.jrsoftware.org/ 8 | or http://www.jordanr.cjb.net/ 9 | email: jr@jrsoftware.org 10 | 11 | This program is free software; you can redistribute it and/or 12 | modify it under the terms of the GNU General Public License 13 | as published by the Free Software Foundation; either version 2 14 | of the License, or (at your option) any later version. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | GNU General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with this program; if not, write to the Free Software 23 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 24 | } 25 | 26 | {$I+} 27 | 28 | interface 29 | 30 | { Win32 PE linker } 31 | 32 | uses 33 | Windows, Common, IPBase; 34 | 35 | type 36 | TIPPELinker = class(TIPCustomLinker) 37 | private 38 | procedure WritePEHeader (const LineNumberInfo: PLineNumberInfoArray; var F: File); 39 | public 40 | function DoLink (const OutFile: String; 41 | const LineNumberInfo: PLineNumberInfoArray): TSize; override; 42 | end; 43 | 44 | implementation 45 | 46 | uses 47 | SysUtils, CodeX86; 48 | 49 | type 50 | PImageImportDescriptor = ^TImageImportDescriptor; 51 | TImageImportDescriptor = packed record 52 | Characteristics: DWORD; 53 | { ^ union OriginalFirstThunk: DWORD;} 54 | TimeDateStamp: DWORD; 55 | ForwarderChain: DWORD; 56 | Name: DWORD; 57 | FirstThunk: DWORD; 58 | end; 59 | 60 | const 61 | xFileAlignment = $200; 62 | 63 | 64 | procedure WriteZeroes (var F: File; Count: Cardinal); 65 | var 66 | Buf: array[0..4095] of Byte; 67 | C: Cardinal; 68 | begin 69 | FillChar (Buf, SizeOf(Buf), 0); 70 | while Count <> 0 do begin 71 | C := Count; 72 | if C > SizeOf(Buf) then C := SizeOf(Buf); 73 | BlockWrite (F, Buf, C); 74 | end; 75 | end; 76 | 77 | 78 | { TIPLinker } 79 | 80 | function TIPPELinker.DoLink (const OutFile: String; 81 | const LineNumberInfo: PLineNumberInfoArray): TSize; 82 | var 83 | F: File; 84 | begin 85 | AssignFile (F, OutFile); 86 | FileMode := fmOpenReadWrite or fmShareExclusive; 87 | {$I-} 88 | Rewrite (F, 1); 89 | {$I+} 90 | if IOResult <> 0 then begin 91 | { Sometimes the EXE is still in use if it was terminated right before 92 | DoLink was called again. Delay 100 msec and try again. } 93 | Sleep (100); 94 | Rewrite (F, 1); 95 | end; 96 | try 97 | WritePEHeader (LineNumberInfo, F); 98 | Result := FileSize(F); 99 | finally 100 | CloseFile (F); 101 | end; 102 | end; 103 | 104 | procedure TIPPELinker.WritePEHeader (const LineNumberInfo: PLineNumberInfoArray; var F: File); 105 | 106 | procedure PadForFileAlignment; 107 | var 108 | I: Integer; 109 | Slack: array[0..xFileAlignment-1] of Byte; 110 | begin 111 | I := xFileAlignment - (FilePos(F) mod xFileAlignment); 112 | if I > 0 then begin 113 | FillChar (Slack, I, 0); 114 | BlockWrite (F, Slack, I); 115 | end; 116 | end; 117 | 118 | const 119 | PESig: DWORD = $00004550; 120 | 121 | DOSStub: array[0..111] of Byte = ( 122 | $4D, $5A, $6C, $00, $01, $00, $00, $00, $04, $00, $11, $00, $FF, $FF, 123 | $03, $00, $00, $01, $00, $00, $00, $00, $00, $00, $40, $00, $00, $00, 124 | $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, 125 | $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, $00, 126 | $00, $00, $00, $00, $70, $00, $00, $00, $0E, $1F, $BA, $0E, $00, $B4, 127 | $09, $CD, $21, $B8, $00, $4C, $CD, $21, $54, $68, $69, $73, $20, $70, 128 | $72, $6F, $67, $72, $61, $6D, $20, $72, $65, $71, $75, $69, $72, $65, 129 | $73, $20, $57, $69, $6E, $33, $32, $0D, $0A, $24, $2D, $49, $50, $2D); 130 | 131 | IDataRVA = $1000; 132 | CodeRVA = $2000; 133 | BSSRVA = $3000; 134 | var 135 | PEHeader: TImageFileHeader; 136 | OptHeader: TImageOptionalHeader; 137 | Sec: TImageSectionHeader; 138 | ImportDir: array of TImageImportDescriptor; 139 | LookupTableRVA, AddressTableRVA, NameTableRVA: DWORD; 140 | LookupTable: array of DWORD; 141 | NameTable: String; 142 | 143 | function AllocName (const IsFuncName: Boolean; const S: String): DWORD; 144 | begin 145 | Result := NameTableRVA + DWORD(Length(NameTable)); 146 | if not IsFuncName then 147 | NameTable := NameTable + S + #0 148 | else 149 | NameTable := NameTable + #0#0 + S + #0; 150 | if Length(NameTable) and 1 <> 0 then { need word alignment } 151 | NameTable := NameTable + #0; 152 | end; 153 | 154 | label 1; 155 | var 156 | I, J, D: Integer; 157 | L: Cardinal; 158 | TotalCode, OptHeaderOfs, IDataOfs, IDataSize: Cardinal; 159 | HasCalledProcs: Boolean; 160 | FuncData: PFuncData; 161 | ConstSectionOffset: Cardinal; 162 | LineNumberRec: PLineNumberRec; 163 | begin 164 | BlockWrite (F, DOSStub, SizeOf(DOSStub)); 165 | 166 | BlockWrite (F, PESig, SizeOf(PESig)); 167 | 168 | FillChar (PEHeader, SizeOf(PEHeader), 0); 169 | PEHeader.Machine := IMAGE_FILE_MACHINE_I386; 170 | PEHeader.NumberOfSections := 3; {FIXME} 171 | PEHeader.TimeDateStamp := 0; 172 | PEHeader.PointerToSymbolTable := 0; 173 | PEHeader.NumberOfSymbols := 0; 174 | PEHeader.SizeOfOptionalHeader := SizeOf(OptHeader); 175 | PEHeader.Characteristics := $818E or IMAGE_FILE_RELOCS_STRIPPED; 176 | BlockWrite (F, PEHeader, SizeOf(PEHeader)); 177 | 178 | FillChar (OptHeader, SizeOf(OptHeader), 0); 179 | OptHeader.Magic := $010B; 180 | OptHeader.MajorLinkerVersion := 0; 181 | OptHeader.MinorLinkerVersion := 0; 182 | OptHeader.SizeOfCode := 0; { set later } 183 | OptHeader.SizeOfInitializedData := 0; 184 | OptHeader.SizeOfUninitializedData := 0; 185 | OptHeader.AddressOfEntryPoint := CodeRVA; {FIXME} 186 | OptHeader.BaseOfCode := CodeRVA; {FIXME} 187 | OptHeader.BaseOfData := 0;//$1000; {FIXME} 188 | OptHeader.ImageBase := $400000; 189 | OptHeader.SectionAlignment := $1000; 190 | OptHeader.FileAlignment := xFileAlignment; 191 | OptHeader.MajorOperatingSystemVersion := 1; 192 | OptHeader.MinorOperatingSystemVersion := 0; 193 | OptHeader.MajorImageVersion := 0; 194 | OptHeader.MajorImageVersion := 0; 195 | OptHeader.MajorSubsystemVersion := 4; 196 | OptHeader.Win32VersionValue := 0; 197 | OptHeader.SizeOfImage := $1000 {address of first section} + 198 | $3000; 199 | // (DWORD(PEHeader.NumberOfSections) * OptHeader.SectionAlignment); {FIXME} 200 | { ^ won't handle sections with size > OptHeader.SectionAlignment properly } 201 | OptHeader.SizeOfHeaders := $200; //FilePos(F) + SizeOf(OptHeader); {test} 202 | OptHeader.CheckSum := 0; 203 | if not LinkOptions.ConsoleApp then 204 | OptHeader.Subsystem := IMAGE_SUBSYSTEM_WINDOWS_GUI 205 | else 206 | OptHeader.Subsystem := IMAGE_SUBSYSTEM_WINDOWS_CUI; 207 | OptHeader.DllCharacteristics := 0; 208 | OptHeader.SizeOfStackReserve := $100000; 209 | OptHeader.SizeOfStackCommit := $4000; 210 | OptHeader.SizeOfHeapReserve := $100000; 211 | OptHeader.SizeOfHeapCommit := $1000; 212 | OptHeader.LoaderFlags := 0; 213 | OptHeader.NumberOfRvaAndSizes := IMAGE_NUMBEROF_DIRECTORY_ENTRIES; 214 | OptHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].VirtualAddress := IDataRVA; 215 | OptHeaderOfs := FilePos(F); 216 | BlockWrite (F, OptHeader, SizeOf(OptHeader)); 217 | 218 | FillChar (Sec, SizeOf(Sec), 0); 219 | StrPCopy (@Sec.Name, '.idata'); 220 | Sec.Misc.VirtualSize := $1000; 221 | Sec.VirtualAddress := IDataRVA; 222 | Sec.SizeOfRawData := $200; { must be multiple of file alignment } 223 | Sec.PointerToRawData := $200; 224 | Sec.Characteristics := IMAGE_SCN_CNT_INITIALIZED_DATA or IMAGE_SCN_MEM_READ or 225 | IMAGE_SCN_MEM_WRITE; 226 | BlockWrite (F, Sec, SizeOf(Sec)); 227 | 228 | FillChar (Sec, SizeOf(Sec), 0); 229 | StrPCopy (@Sec.Name, '.text'); 230 | Sec.Misc.VirtualSize := $1000; 231 | Sec.VirtualAddress := CodeRVA; 232 | Sec.SizeOfRawData := $200; { must be multiple of file alignment } 233 | Sec.PointerToRawData := $400; 234 | Sec.Characteristics := IMAGE_SCN_CNT_CODE or IMAGE_SCN_MEM_EXECUTE or 235 | IMAGE_SCN_MEM_READ; 236 | BlockWrite (F, Sec, SizeOf(Sec)); 237 | 238 | (*FillChar (Sec, SizeOf(Sec), 0); 239 | StrPCopy (@Sec.Name, '.reloc'); 240 | Sec.Misc.VirtualSize := $1000; 241 | Sec.VirtualAddress := $2000; 242 | Sec.SizeOfRawData := $200; { must be multiple of file alignment } 243 | Sec.PointerToRawData := 0; 244 | Sec.Characteristics := //$50000040 <- wrong? 245 | IMAGE_SCN_CNT_INITIALIZED_DATA or IMAGE_SCN_MEM_READ or IMAGE_SCN_MEM_DISCARDABLE; 246 | BlockWrite (F, Sec, SizeOf(Sec));*) 247 | 248 | FillChar (Sec, SizeOf(Sec), 0); 249 | StrPCopy (@Sec.Name, '.bss'); 250 | Sec.Misc.VirtualSize := DataSectionSize; //$1000; 251 | Sec.VirtualAddress := BSSRVA; 252 | Sec.SizeOfRawData := 0; { must be multiple of file alignment } 253 | Sec.PointerToRawData := $400; 254 | Sec.Characteristics := IMAGE_SCN_CNT_UNINITIALIZED_DATA or IMAGE_SCN_MEM_READ or 255 | IMAGE_SCN_MEM_WRITE; 256 | BlockWrite (F, Sec, SizeOf(Sec)); 257 | 258 | PadForFileAlignment; 259 | 260 | { -- IMPORT TABLE -- } 261 | 262 | NameTable := ''; 263 | D := 0; 264 | L := 0; 265 | for I := 0 to DLLList.Count-1 do begin 266 | HasCalledProcs := False; 267 | for J := 0 to Funcs.Count-1 do begin 268 | FuncData := Funcs[J]; 269 | if (FuncData.DLLIndex = I) and FuncData.Called then begin 270 | HasCalledProcs := True; 271 | Inc (L); 272 | end; 273 | end; 274 | if HasCalledProcs then begin 275 | Inc (L); 276 | DLLList.Objects[I] := Pointer(1); { non-zero means the DLL is used } 277 | Inc (D); 278 | end; 279 | end; 280 | SetLength (ImportDir, D + 1); 281 | SetLength (LookupTable, L); 282 | 283 | LookupTableRVA := IDataRVA + (Length(ImportDir) * SizeOf(ImportDir[0])); 284 | AddressTableRVA := LookupTableRVA + (Cardinal(Length(LookupTable)) * SizeOf(LookupTable[0])); 285 | NameTableRVA := AddressTableRVA + (Cardinal(Length(LookupTable)) * SizeOf(LookupTable[0])); 286 | 287 | FillChar (ImportDir[0], Length(ImportDir) * SizeOf(ImportDir[0]), 0); 288 | L := 0; 289 | D := 0; 290 | for I := 0 to DLLList.Count-1 do begin 291 | if DLLList.Objects[I] = nil then { Objects[I] will be zero if DLL isn't used } 292 | Continue; 293 | ImportDir[D].Characteristics := LookupTableRVA + (L * SizeOf(DWORD)); 294 | ImportDir[D].Name := AllocName(False, DLLList[I]); 295 | ImportDir[D].FirstThunk := AddressTableRVA + (L * SizeOf(DWORD)); 296 | for J := 0 to Funcs.Count-1 do begin 297 | FuncData := PFuncData(Funcs[J]); 298 | if (FuncData.DLLIndex = I) and FuncData.Called then begin 299 | LookupTable[L] := AllocName(True, FuncData.ImportName); 300 | FuncData.CodeGen := TX86CodeGen.Create; 301 | FuncData.CodeGen.ImportThunk (OptHeader.ImageBase + AddressTableRVA + 302 | (L * SizeOf(DWORD))); 303 | Inc (L); 304 | end; 305 | end; 306 | LookupTable[L] := 0; 307 | Inc (L); 308 | Inc (D); 309 | end; 310 | 311 | IDataOfs := FilePos(F); 312 | BlockWrite (F, ImportDir[0], Length(ImportDir) * SizeOf(ImportDir[0])); 313 | BlockWrite (F, LookupTable[0], Length(LookupTable) * SizeOf(LookupTable[0])); 314 | BlockWrite (F, LookupTable[0], Length(LookupTable) * SizeOf(LookupTable[0])); 315 | BlockWrite (F, Pointer(NameTable)^, Length(NameTable)); 316 | IDataSize := Cardinal(FilePos(F)) - IDataOfs; 317 | if IDataSize > $200 then 318 | raise Exception.Create('Too many imports'); {} 319 | PadForFileAlignment; 320 | 321 | { -- CODE -- } 322 | 323 | { Calculate total size of code section, and assign each used function a 324 | relative address } 325 | TotalCode := 0; 326 | for I := 0 to Funcs.Count-1 do begin 327 | FuncData := Funcs[I]; 328 | if FuncData.Called and Assigned(FuncData.CodeGen) then begin 329 | FuncData.Address := TotalCode; 330 | Inc (TotalCode, Length(FuncData.CodeGen.Code)); 331 | for J := 0 to FuncData.CodeGen.LineNumbers.Count-1 do begin 332 | LineNumberRec := FuncData.CodeGen.LineNumbers[J]; 333 | if LineNumberInfo[LineNumberRec.LineNum] = $FFFFFFFF then 334 | LineNumberInfo[LineNumberRec.LineNum] := CodeRVA + FuncData.Address + 335 | LineNumberRec.CodeAddr; 336 | end; 337 | end; 338 | end; 339 | ConstSectionOffset := TotalCode; 340 | Inc (TotalCode, Length(ConstSection)); 341 | if TotalCode > $200 then 342 | raise Exception.Create('Too much code'); {} 343 | 344 | { Apply fixups } 345 | for I := Funcs.Count-1 downto 0 do begin 346 | FuncData := Funcs[I]; 347 | if FuncData.Called and Assigned(FuncData.CodeGen) then begin 348 | FuncData.CodeGen.ApplyFixups (Funcs, 349 | FuncData.Address, 350 | OptHeader.ImageBase + CodeRVA, 351 | OptHeader.ImageBase + CodeRVA + ConstSectionOffset, 352 | OptHeader.ImageBase + BSSRVA); 353 | end; 354 | end; 355 | 356 | { Write out all functions, then constants } 357 | for I := 0 to Funcs.Count-1 do begin 358 | FuncData := Funcs[I]; 359 | if FuncData.Called and Assigned(FuncData.CodeGen) then 360 | BlockWrite (F, Pointer(FuncData.CodeGen.Code)^, Length(FuncData.CodeGen.Code)); 361 | end; 362 | BlockWrite (F, Pointer(ConstSection)^, Length(ConstSection)); 363 | PadForFileAlignment; 364 | 365 | { -- FINALIZE -- } 366 | 367 | { Go back and rewrite opt header with correct section sizes } 368 | 369 | OptHeader.SizeOfCode := TotalCode; 370 | OptHeader.DataDirectory[IMAGE_DIRECTORY_ENTRY_IMPORT].Size := IDataSize; 371 | Seek (F, OptHeaderOfs); 372 | BlockWrite (F, OptHeader, SizeOf(OptHeader)); 373 | end; 374 | 375 | end. 376 | -------------------------------------------------------------------------------- /Src/Main.dfm: -------------------------------------------------------------------------------- 1 | object MainForm: TMainForm 2 | Left = 206 3 | Top = 97 4 | Width = 369 5 | Height = 311 6 | Caption = '*' 7 | Color = clBtnFace 8 | Font.Charset = DEFAULT_CHARSET 9 | Font.Color = clWindowText 10 | Font.Height = -11 11 | Font.Name = 'MS Sans Serif' 12 | Font.Style = [] 13 | Menu = MainMenu1 14 | OldCreateOrder = True 15 | Position = poDefault 16 | Scaled = False 17 | OnCloseQuery = FormCloseQuery 18 | OnCreate = FormCreate 19 | OnDestroy = FormDestroy 20 | PixelsPerInch = 96 21 | TextHeight = 13 22 | object TopDock: TDock97 23 | Left = 0 24 | Top = 0 25 | Width = 361 26 | Height = 27 27 | BoundLines = [blTop] 28 | object MainToolbar: TToolbar97 29 | Left = 0 30 | Top = 0 31 | Caption = 'Main' 32 | DefaultDock = TopDock 33 | DockPos = 0 34 | ParentShowHint = False 35 | ShowHint = True 36 | TabOrder = 0 37 | object NewButton: TToolbarButton97 38 | Left = 0 39 | Top = 0 40 | Width = 23 41 | Height = 22 42 | Hint = 'New' 43 | Glyph.Data = { 44 | 36030000424D3603000000000000360000002800000010000000100000000100 45 | 1800000000000003000000000000000000000000000000000000C6C7C6C6C7C6 46 | C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7 47 | C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6 48 | C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6 49 | 0000000000000000000000000000000000000000000000000000000000000000 50 | 00C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6000000FFFFFFFFFFFFFFFFFFFFFFFFFF 51 | FFFFFFFFFFFFFFFFFFFFFFFFFFFF000000C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6 52 | 000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000 53 | 00C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6000000FFFFFFFFFFFFFFFFFFFFFFFFFF 54 | FFFFFFFFFFFFFFFFFFFFFFFFFFFF000000C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6 55 | 000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000 56 | 00C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6000000FFFFFFFFFFFFFFFFFFFFFFFFFF 57 | FFFFFFFFFFFFFFFFFFFFFFFFFFFF000000C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6 58 | 000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000 59 | 00C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6000000FFFFFFFFFFFFFFFFFFFFFFFFFF 60 | FFFFFFFFFFFFFFFFFFFFFFFFFFFF000000C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6 61 | 000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF0000 62 | 00C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6000000FFFFFFFFFFFFFFFFFFFFFFFFFF 63 | FFFFFFFFFF000000000000000000000000C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6 64 | 000000FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF000000FFFFFF000000C6C7 65 | C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6000000FFFFFFFFFFFFFFFFFFFFFFFFFF 66 | FFFFFFFFFF000000000000C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6 67 | 000000000000000000000000000000000000000000000000C6C7C6C6C7C6C6C7 68 | C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6 69 | C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6} 70 | OnClick = FNewClick 71 | end 72 | object OpenButton: TToolbarButton97 73 | Left = 23 74 | Top = 0 75 | Width = 23 76 | Height = 22 77 | Hint = 'Open' 78 | Glyph.Data = { 79 | 36030000424D3603000000000000360000002800000010000000100000000100 80 | 1800000000000003000000000000000000000000000000000000C6C7C6C6C7C6 81 | C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7 82 | C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6 83 | C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6000000000000 84 | 000000000000000000000000000000000000000000000000000000C6C7C6C6C7 85 | C6C6C7C6C6C7C6C6C7C600000000000000868400868400868400868400868400 86 | 8684008684008684008684000000C6C7C6C6C7C6C6C7C6C6C7C600000000FFFF 87 | 0000000086840086840086840086840086840086840086840086840086840000 88 | 00C6C7C6C6C7C6C6C7C6000000FFFFFF00FFFF00000000868400868400868400 89 | 8684008684008684008684008684008684000000C6C7C6C6C7C600000000FFFF 90 | FFFFFF00FFFF0000000086840086840086840086840086840086840086840086 91 | 84008684000000C6C7C6000000FFFFFF00FFFFFFFFFF00FFFF00000000000000 92 | 000000000000000000000000000000000000000000000000000000000000FFFF 93 | FFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFF000000C6C7C6C6C7 94 | C6C6C7C6C6C7C6C6C7C6000000FFFFFF00FFFFFFFFFF00FFFFFFFFFF00FFFFFF 95 | FFFF00FFFFFFFFFF000000C6C7C6C6C7C6C6C7C6C6C7C6C6C7C600000000FFFF 96 | FFFFFF00FFFF000000000000000000000000000000000000000000C6C7C6C6C7 97 | C6C6C7C6C6C7C6C6C7C6C6C7C6000000000000000000C6C7C6C6C7C6C6C7C6C6 98 | C7C6C6C7C6C6C7C6C6C7C6C6C7C6000000000000000000C6C7C6C6C7C6C6C7C6 99 | C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7 100 | C6000000000000C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6 101 | C7C6000000C6C7C6C6C7C6C6C7C6000000C6C7C6000000C6C7C6C6C7C6C6C7C6 102 | C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6000000000000000000C6C7 103 | C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6 104 | C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6} 105 | OnClick = FOpenClick 106 | end 107 | object SaveButton: TToolbarButton97 108 | Left = 46 109 | Top = 0 110 | Width = 23 111 | Height = 22 112 | Hint = 'Save' 113 | Glyph.Data = { 114 | 36030000424D3603000000000000360000002800000010000000100000000100 115 | 1800000000000003000000000000000000000000000000000000008600008600 116 | 0086000086000086000086000086000086000086000086000086000086000086 117 | 0000860000860000860000860000860000000000000000000000000000000000 118 | 0000000000000000000000000000000000000000000000008600008600000000 119 | 008684008684000000000000000000000000000000000000C6C7C6C6C7C60000 120 | 0000868400000000860000860000000000868400868400000000000000000000 121 | 0000000000000000C6C7C6C6C7C6000000008684000000008600008600000000 122 | 008684008684000000000000000000000000000000000000C6C7C6C6C7C60000 123 | 0000868400000000860000860000000000868400868400000000000000000000 124 | 0000000000000000000000000000000000008684000000008600008600000000 125 | 0086840086840086840086840086840086840086840086840086840086840086 126 | 8400868400000000860000860000000000868400868400000000000000000000 127 | 0000000000000000000000000000008684008684000000008600008600000000 128 | 008684000000C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C60000 129 | 00008684000000008600008600000000008684000000C6C7C6C6C7C6C6C7C6C6 130 | C7C6C6C7C6C6C7C6C6C7C6C6C7C6000000008684000000008600008600000000 131 | 008684000000C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C60000 132 | 00008684000000008600008600000000008684000000C6C7C6C6C7C6C6C7C6C6 133 | C7C6C6C7C6C6C7C6C6C7C6C6C7C6000000008684000000008600008600000000 134 | 008684000000C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C6C6C7C60000 135 | 00000000000000008600008600000000008684000000C6C7C6C6C7C6C6C7C6C6 136 | C7C6C6C7C6C6C7C6C6C7C6C6C7C6000000C6C7C6000000008600008600000000 137 | 0000000000000000000000000000000000000000000000000000000000000000 138 | 0000000000000000860000860000860000860000860000860000860000860000 139 | 8600008600008600008600008600008600008600008600008600} 140 | OnClick = FSaveClick 141 | end 142 | object MainSep1: TToolbarSep97 143 | Left = 69 144 | Top = 0 145 | end 146 | object CompileButton: TToolbarButton97 147 | Left = 75 148 | Top = 0 149 | Width = 23 150 | Height = 22 151 | Action = actCompile 152 | DisplayMode = dmGlyphOnly 153 | Glyph.Data = { 154 | F6000000424DF600000000000000760000002800000010000000100000000100 155 | 04000000000080000000C40E0000C40E00001000000000000000000000000000 156 | 8000008000000080800080000000800080008080000080808000C0C0C0000000 157 | FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00888888888888 158 | 88888888888888888888800000000000000080FFFFFFFFFFFFF080F0F0F0F0F0 159 | F0F080FFFFFFFFFFFFF080F0F0F0F0F0F0F080FFFFFFFFFFFFF0800000000000 160 | 0000884888884888884884448884448884448848484848484848884888884888 161 | 8848888888888888888888488888488888488888888888888888} 162 | end 163 | object RunButton: TToolbarButton97 164 | Left = 104 165 | Top = 0 166 | Width = 23 167 | Height = 22 168 | Action = actRun 169 | DisplayMode = dmGlyphOnly 170 | Glyph.Data = { 171 | DE010000424DDE01000000000000760000002800000026000000120000000100 172 | 04000000000068010000C40E0000C40E00001000000000000000000000000000 173 | 80000080000000808000800000008000800080800000C0C0C000808080000000 174 | FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333 175 | 3333333333333333333333333300333333333333333333333333333333333333 176 | 330033333333333333333333333333333333333333003338F333333333333333 177 | 3333333333333333330033380FF33333333333333333FF333333333333003338 178 | 077FF3333333333333388FFF33333333330033380AA77FF3333333333338888F 179 | FF333333330033380AAAA77FF3333333333888888FFF3333330033380AAAAAA7 180 | 7F33333333388888888FFF33330033380AAAAAAAA00333333338888888888333 181 | 330033380AAAAAA0088333333338888888833333330033380AAAA00883333333 182 | 3338888883333333330033380AA0088333333333333888833333333333003338 183 | 0008833333333333333883333333333333003338088333333333333333333333 184 | 3333333333003338833333333333333333333333333333333300333333333333 185 | 3333333333333333333333333300333333333333333333333333333333333333 186 | 3300} 187 | NumGlyphs = 2 188 | end 189 | object StopButton: TToolbarButton97 190 | Left = 127 191 | Top = 0 192 | Width = 23 193 | Height = 22 194 | Action = actStop 195 | DisplayMode = dmGlyphOnly 196 | Glyph.Data = { 197 | DE010000424DDE01000000000000760000002800000026000000120000000100 198 | 04000000000068010000CE0E0000C40E00001000000000000000000000000000 199 | 80000080000000808000800000008000800080800000C0C0C000808080000000 200 | FF0000FF000000FFFF00FF000000FF00FF00FFFF0000FFFFFF00333333333333 201 | 3333333333333333333333333300333333333333333333333333333333333333 202 | 330033333333333333333333333333333333333333003333FFFFFFFFFFF33333 203 | 333FFFFFFFFFF333330033380777777777F33333338888888888F33333003338 204 | 0999999997F33333338888888888F333330033380999999997F3333333888888 205 | 8888F333330033380999999997F33333338888888888F3333300333809999999 206 | 97F33333338888888888F333330033380999999997F33333338888888888F333 207 | 330033380999999997F33333338888888888F333330033380999999997F33333 208 | 338888888888F333330033380999999997F33333338888888888F33333003338 209 | 0000000007F33333338888888888333333003338888888888833333333333333 210 | 3333333333003333333333333333333333333333333333333300333333333333 211 | 3333333333333333333333333300333333333333333333333333333333333333 212 | 3300} 213 | NumGlyphs = 2 214 | end 215 | object ToolbarSep971: TToolbarSep97 216 | Left = 98 217 | Top = 0 218 | end 219 | end 220 | end 221 | object RightDock: TDock97 222 | Left = 352 223 | Top = 27 224 | Width = 9 225 | Height = 209 226 | Position = dpRight 227 | end 228 | object BottomDock: TDock97 229 | Left = 0 230 | Top = 236 231 | Width = 361 232 | Height = 9 233 | Position = dpBottom 234 | end 235 | object LeftDock: TDock97 236 | Left = 0 237 | Top = 27 238 | Width = 9 239 | Height = 209 240 | Position = dpLeft 241 | end 242 | object StatusBar: TStatusBar 243 | Left = 0 244 | Top = 245 245 | Width = 361 246 | Height = 20 247 | Panels = < 248 | item 249 | Alignment = taCenter 250 | Text = ' 1: 1' 251 | Width = 64 252 | end 253 | item 254 | Alignment = taCenter 255 | Width = 64 256 | end 257 | item 258 | Alignment = taCenter 259 | Text = 'Insert' 260 | Width = 64 261 | end 262 | item 263 | Width = 50 264 | end> 265 | SimplePanel = False 266 | end 267 | object OuterPanel: TPanel 268 | Left = 9 269 | Top = 27 270 | Width = 343 271 | Height = 209 272 | Align = alClient 273 | BevelOuter = bvNone 274 | TabOrder = 0 275 | object Splitter: TSplitter 276 | Left = 0 277 | Top = 158 278 | Width = 343 279 | Height = 3 280 | Cursor = crVSplit 281 | Align = alBottom 282 | ResizeStyle = rsUpdate 283 | end 284 | object Memo: TSynMemo 285 | Left = 0 286 | Top = 0 287 | Width = 343 288 | Height = 158 289 | Cursor = crIBeam 290 | Align = alClient 291 | Font.Charset = DEFAULT_CHARSET 292 | Font.Color = clWindowText 293 | Font.Height = -13 294 | Font.Name = 'Courier New' 295 | Font.Style = [] 296 | ParentColor = False 297 | ParentFont = False 298 | PopupMenu = MemoPopup 299 | TabOrder = 0 300 | Highlighter = Highlighter 301 | Keystrokes = < 302 | item 303 | Command = ecUp 304 | ShortCut = 38 305 | ShortCut2 = 0 306 | end 307 | item 308 | Command = ecSelUp 309 | ShortCut = 8230 310 | ShortCut2 = 0 311 | end 312 | item 313 | Command = ecScrollUp 314 | ShortCut = 16422 315 | ShortCut2 = 0 316 | end 317 | item 318 | Command = ecDown 319 | ShortCut = 40 320 | ShortCut2 = 0 321 | end 322 | item 323 | Command = ecSelDown 324 | ShortCut = 8232 325 | ShortCut2 = 0 326 | end 327 | item 328 | Command = ecScrollDown 329 | ShortCut = 16424 330 | ShortCut2 = 0 331 | end 332 | item 333 | Command = ecLeft 334 | ShortCut = 37 335 | ShortCut2 = 0 336 | end 337 | item 338 | Command = ecSelLeft 339 | ShortCut = 8229 340 | ShortCut2 = 0 341 | end 342 | item 343 | Command = ecWordLeft 344 | ShortCut = 16421 345 | ShortCut2 = 0 346 | end 347 | item 348 | Command = ecSelWordLeft 349 | ShortCut = 24613 350 | ShortCut2 = 0 351 | end 352 | item 353 | Command = ecRight 354 | ShortCut = 39 355 | ShortCut2 = 0 356 | end 357 | item 358 | Command = ecSelRight 359 | ShortCut = 8231 360 | ShortCut2 = 0 361 | end 362 | item 363 | Command = ecWordRight 364 | ShortCut = 16423 365 | ShortCut2 = 0 366 | end 367 | item 368 | Command = ecSelWordRight 369 | ShortCut = 24615 370 | ShortCut2 = 0 371 | end 372 | item 373 | Command = ecPageDown 374 | ShortCut = 34 375 | ShortCut2 = 0 376 | end 377 | item 378 | Command = ecSelPageDown 379 | ShortCut = 8226 380 | ShortCut2 = 0 381 | end 382 | item 383 | Command = ecPageBottom 384 | ShortCut = 16418 385 | ShortCut2 = 0 386 | end 387 | item 388 | Command = ecSelPageBottom 389 | ShortCut = 24610 390 | ShortCut2 = 0 391 | end 392 | item 393 | Command = ecPageUp 394 | ShortCut = 33 395 | ShortCut2 = 0 396 | end 397 | item 398 | Command = ecSelPageUp 399 | ShortCut = 8225 400 | ShortCut2 = 0 401 | end 402 | item 403 | Command = ecPageTop 404 | ShortCut = 16417 405 | ShortCut2 = 0 406 | end 407 | item 408 | Command = ecSelPageTop 409 | ShortCut = 24609 410 | ShortCut2 = 0 411 | end 412 | item 413 | Command = ecLineStart 414 | ShortCut = 36 415 | ShortCut2 = 0 416 | end 417 | item 418 | Command = ecSelLineStart 419 | ShortCut = 8228 420 | ShortCut2 = 0 421 | end 422 | item 423 | Command = ecEditorTop 424 | ShortCut = 16420 425 | ShortCut2 = 0 426 | end 427 | item 428 | Command = ecSelEditorTop 429 | ShortCut = 24612 430 | ShortCut2 = 0 431 | end 432 | item 433 | Command = ecLineEnd 434 | ShortCut = 35 435 | ShortCut2 = 0 436 | end 437 | item 438 | Command = ecSelLineEnd 439 | ShortCut = 8227 440 | ShortCut2 = 0 441 | end 442 | item 443 | Command = ecEditorBottom 444 | ShortCut = 16419 445 | ShortCut2 = 0 446 | end 447 | item 448 | Command = ecSelEditorBottom 449 | ShortCut = 24611 450 | ShortCut2 = 0 451 | end 452 | item 453 | Command = ecToggleMode 454 | ShortCut = 45 455 | ShortCut2 = 0 456 | end 457 | item 458 | Command = ecCopy 459 | ShortCut = 16429 460 | ShortCut2 = 0 461 | end 462 | item 463 | Command = ecPaste 464 | ShortCut = 8237 465 | ShortCut2 = 0 466 | end 467 | item 468 | Command = ecDeleteChar 469 | ShortCut = 46 470 | ShortCut2 = 0 471 | end 472 | item 473 | Command = ecCut 474 | ShortCut = 8238 475 | ShortCut2 = 0 476 | end 477 | item 478 | Command = ecDeleteLastChar 479 | ShortCut = 8 480 | ShortCut2 = 0 481 | end 482 | item 483 | Command = ecDeleteLastChar 484 | ShortCut = 8200 485 | ShortCut2 = 0 486 | end 487 | item 488 | Command = ecDeleteLastWord 489 | ShortCut = 16392 490 | ShortCut2 = 0 491 | end 492 | item 493 | Command = ecUndo 494 | ShortCut = 32776 495 | ShortCut2 = 0 496 | end 497 | item 498 | Command = ecRedo 499 | ShortCut = 40968 500 | ShortCut2 = 0 501 | end 502 | item 503 | Command = ecLineBreak 504 | ShortCut = 13 505 | ShortCut2 = 0 506 | end 507 | item 508 | Command = ecSelectAll 509 | ShortCut = 16449 510 | ShortCut2 = 0 511 | end 512 | item 513 | Command = ecCopy 514 | ShortCut = 16451 515 | ShortCut2 = 0 516 | end 517 | item 518 | Command = ecBlockIndent 519 | ShortCut = 24649 520 | ShortCut2 = 0 521 | end 522 | item 523 | Command = ecLineBreak 524 | ShortCut = 16461 525 | ShortCut2 = 0 526 | end 527 | item 528 | Command = ecInsertLine 529 | ShortCut = 16462 530 | ShortCut2 = 0 531 | end 532 | item 533 | Command = ecDeleteWord 534 | ShortCut = 16468 535 | ShortCut2 = 0 536 | end 537 | item 538 | Command = ecBlockUnindent 539 | ShortCut = 24661 540 | ShortCut2 = 0 541 | end 542 | item 543 | Command = ecPaste 544 | ShortCut = 16470 545 | ShortCut2 = 0 546 | end 547 | item 548 | Command = ecCut 549 | ShortCut = 16472 550 | ShortCut2 = 0 551 | end 552 | item 553 | Command = ecDeleteLine 554 | ShortCut = 16473 555 | ShortCut2 = 0 556 | end 557 | item 558 | Command = ecDeleteEOL 559 | ShortCut = 24665 560 | ShortCut2 = 0 561 | end 562 | item 563 | Command = ecUndo 564 | ShortCut = 16474 565 | ShortCut2 = 0 566 | end 567 | item 568 | Command = ecRedo 569 | ShortCut = 24666 570 | ShortCut2 = 0 571 | end 572 | item 573 | Command = ecGotoMarker0 574 | ShortCut = 16432 575 | ShortCut2 = 0 576 | end 577 | item 578 | Command = ecGotoMarker1 579 | ShortCut = 16433 580 | ShortCut2 = 0 581 | end 582 | item 583 | Command = ecGotoMarker2 584 | ShortCut = 16434 585 | ShortCut2 = 0 586 | end 587 | item 588 | Command = ecGotoMarker3 589 | ShortCut = 16435 590 | ShortCut2 = 0 591 | end 592 | item 593 | Command = ecGotoMarker4 594 | ShortCut = 16436 595 | ShortCut2 = 0 596 | end 597 | item 598 | Command = ecGotoMarker5 599 | ShortCut = 16437 600 | ShortCut2 = 0 601 | end 602 | item 603 | Command = ecGotoMarker6 604 | ShortCut = 16438 605 | ShortCut2 = 0 606 | end 607 | item 608 | Command = ecGotoMarker7 609 | ShortCut = 16439 610 | ShortCut2 = 0 611 | end 612 | item 613 | Command = ecGotoMarker8 614 | ShortCut = 16440 615 | ShortCut2 = 0 616 | end 617 | item 618 | Command = ecGotoMarker9 619 | ShortCut = 16441 620 | ShortCut2 = 0 621 | end 622 | item 623 | Command = ecSetMarker0 624 | ShortCut = 24624 625 | ShortCut2 = 0 626 | end 627 | item 628 | Command = ecSetMarker1 629 | ShortCut = 24625 630 | ShortCut2 = 0 631 | end 632 | item 633 | Command = ecSetMarker2 634 | ShortCut = 24626 635 | ShortCut2 = 0 636 | end 637 | item 638 | Command = ecSetMarker3 639 | ShortCut = 24627 640 | ShortCut2 = 0 641 | end 642 | item 643 | Command = ecSetMarker4 644 | ShortCut = 24628 645 | ShortCut2 = 0 646 | end 647 | item 648 | Command = ecSetMarker5 649 | ShortCut = 24629 650 | ShortCut2 = 0 651 | end 652 | item 653 | Command = ecSetMarker6 654 | ShortCut = 24630 655 | ShortCut2 = 0 656 | end 657 | item 658 | Command = ecSetMarker7 659 | ShortCut = 24631 660 | ShortCut2 = 0 661 | end 662 | item 663 | Command = ecSetMarker8 664 | ShortCut = 24632 665 | ShortCut2 = 0 666 | end 667 | item 668 | Command = ecSetMarker9 669 | ShortCut = 24633 670 | ShortCut2 = 0 671 | end 672 | item 673 | Command = ecNormalSelect 674 | ShortCut = 24654 675 | ShortCut2 = 0 676 | end 677 | item 678 | Command = ecColumnSelect 679 | ShortCut = 24643 680 | ShortCut2 = 0 681 | end 682 | item 683 | Command = ecLineSelect 684 | ShortCut = 24652 685 | ShortCut2 = 0 686 | end 687 | item 688 | Command = ecTab 689 | ShortCut = 9 690 | ShortCut2 = 0 691 | end 692 | item 693 | Command = ecShiftTab 694 | ShortCut = 8201 695 | ShortCut2 = 0 696 | end 697 | item 698 | Command = ecMatchBracket 699 | ShortCut = 24642 700 | ShortCut2 = 0 701 | end> 702 | WantTabs = True 703 | OnChange = MemoChange 704 | OnPaint = MemoPaint 705 | OnSpecialLineColors = MemoSpecialLineColors 706 | OnStatusChange = MemoStatusChange 707 | end 708 | object MessageList: TListBox 709 | Left = 0 710 | Top = 161 711 | Width = 343 712 | Height = 48 713 | Align = alBottom 714 | ItemHeight = 13 715 | TabOrder = 1 716 | OnDblClick = MessageListDblClick 717 | end 718 | end 719 | object OpenDialog: TOpenDialog 720 | DefaultExt = 'pas' 721 | Filter = 'Inno Pascal unit (*.pas)|*.pas' 722 | Options = [ofHideReadOnly, ofPathMustExist, ofFileMustExist] 723 | Left = 40 724 | Top = 48 725 | end 726 | object MainMenu1: TMainMenu 727 | Left = 8 728 | Top = 48 729 | object FMenu: TMenuItem 730 | Caption = '&File' 731 | OnClick = FMenuClick 732 | object FNew: TMenuItem 733 | Caption = '&New' 734 | ShortCut = 16462 735 | OnClick = FNewClick 736 | end 737 | object FOpen: TMenuItem 738 | Caption = '&Open...' 739 | ShortCut = 16463 740 | OnClick = FOpenClick 741 | end 742 | object FSave: TMenuItem 743 | Caption = '&Save' 744 | ShortCut = 16467 745 | OnClick = FSaveClick 746 | end 747 | object FSaveAs: TMenuItem 748 | Caption = 'Save &As...' 749 | OnClick = FSaveAsClick 750 | end 751 | object N1: TMenuItem 752 | Caption = '-' 753 | end 754 | object FMRUSep: TMenuItem 755 | Caption = '-' 756 | Visible = False 757 | end 758 | object FExit: TMenuItem 759 | Caption = 'E&xit' 760 | OnClick = FExitClick 761 | end 762 | end 763 | object EMenu: TMenuItem 764 | Caption = '&Edit' 765 | OnClick = EMenuClick 766 | object EUndo: TMenuItem 767 | Action = actUndo 768 | end 769 | object N3: TMenuItem 770 | Caption = '-' 771 | end 772 | object ECut: TMenuItem 773 | Action = actCut 774 | end 775 | object ECopy: TMenuItem 776 | Action = actCopy 777 | end 778 | object EPaste: TMenuItem 779 | Action = actPaste 780 | end 781 | object EDelete: TMenuItem 782 | Caption = 'De&lete' 783 | OnClick = actDeleteClick 784 | end 785 | object ESelectAll: TMenuItem 786 | Caption = 'Select &All' 787 | ShortCut = 16449 788 | OnClick = ESelectAllClick 789 | end 790 | object N4: TMenuItem 791 | Caption = '-' 792 | end 793 | object EFind: TMenuItem 794 | Caption = '&Find...' 795 | ShortCut = 16454 796 | OnClick = EFindClick 797 | end 798 | object EFindNext: TMenuItem 799 | Caption = 'Find &Next' 800 | ShortCut = 114 801 | OnClick = EFindNextClick 802 | end 803 | object EReplace: TMenuItem 804 | Caption = '&Replace...' 805 | ShortCut = 16456 806 | OnClick = EReplaceClick 807 | end 808 | end 809 | object VMenu: TMenuItem 810 | Caption = '&View' 811 | OnClick = VMenuClick 812 | object VToolbar: TMenuItem 813 | Caption = '&Toolbar' 814 | OnClick = VToolbarClick 815 | end 816 | object VCompilerMessages: TMenuItem 817 | Caption = 'Compiler &Messages' 818 | OnClick = VCompilerMessagesClick 819 | end 820 | object N2: TMenuItem 821 | Caption = '-' 822 | end 823 | object VD: TMenuItem 824 | Caption = '&Debug Windows' 825 | object VDEventLog: TMenuItem 826 | Caption = '&Event Log' 827 | OnClick = VDEventLogClick 828 | end 829 | object VDRegisters: TMenuItem 830 | Caption = '&Registers' 831 | OnClick = VDRegistersClick 832 | end 833 | end 834 | object VEditorOptions: TMenuItem 835 | Caption = '&Editor Options' 836 | Visible = False 837 | OnClick = VEditorOptionsClick 838 | object VEHorizCaret: TMenuItem 839 | Caption = 'Horizontal Caret Shape' 840 | OnClick = VEHorizCaretClick 841 | end 842 | end 843 | end 844 | object Project1: TMenuItem 845 | Caption = '&Project' 846 | object PCompile: TMenuItem 847 | Action = actCompile 848 | end 849 | object PBuild: TMenuItem 850 | Action = actBuild 851 | end 852 | end 853 | object Run1: TMenuItem 854 | Caption = '&Run' 855 | object RRun: TMenuItem 856 | Action = actRun 857 | end 858 | object RStop: TMenuItem 859 | Action = actStop 860 | end 861 | object N6: TMenuItem 862 | Caption = '-' 863 | end 864 | object RStepOver: TMenuItem 865 | Action = actStepOver 866 | end 867 | object RRunToCursor: TMenuItem 868 | Action = actRunToCursor 869 | end 870 | object N5: TMenuItem 871 | Caption = '-' 872 | end 873 | object RParameters: TMenuItem 874 | Caption = '&Parameters...' 875 | OnClick = RParametersClick 876 | end 877 | end 878 | object Help1: TMenuItem 879 | Caption = '&Help' 880 | object HReadme: TMenuItem 881 | Caption = '&Readme.txt' 882 | OnClick = HReadmeClick 883 | end 884 | object HLicense: TMenuItem 885 | Caption = '&License.txt' 886 | OnClick = HLicenseClick 887 | end 888 | object N7: TMenuItem 889 | Caption = '-' 890 | end 891 | object HAbout: TMenuItem 892 | Caption = '&About...' 893 | OnClick = HAboutClick 894 | end 895 | end 896 | end 897 | object SaveDialog: TSaveDialog 898 | DefaultExt = 'pas' 899 | Filter = 'Inno Pascal unit (*.pas)|*.pas' 900 | Options = [ofHideReadOnly, ofPathMustExist, ofFileMustExist] 901 | Left = 72 902 | Top = 48 903 | end 904 | object FindDialog: TFindDialog 905 | OnFind = FindDialogFind 906 | Left = 104 907 | Top = 48 908 | end 909 | object ReplaceDialog: TReplaceDialog 910 | OnFind = FindDialogFind 911 | OnReplace = ReplaceDialogReplace 912 | Left = 136 913 | Top = 48 914 | end 915 | object Highlighter: TSynPasSyn 916 | DefaultFilter = 'Pascal files (*.pas,*.dpr,*.dpk,*.inc)|*.pas;*.dpr;*.dpk;*.inc' 917 | CommentAttri.Foreground = clNavy 918 | CommentAttri.Style = [fsItalic] 919 | KeyAttri.Style = [fsBold] 920 | Left = 264 921 | Top = 32 922 | end 923 | object ActionList: TActionList 924 | Left = 136 925 | Top = 80 926 | object actRun: TAction 927 | Category = 'Run' 928 | Caption = '&Run' 929 | Hint = 'Run' 930 | ShortCut = 120 931 | OnExecute = actRunClick 932 | end 933 | object actStop: TAction 934 | Category = 'Run' 935 | Caption = '&Stop' 936 | Enabled = False 937 | Hint = 'Stop' 938 | ShortCut = 16497 939 | OnExecute = actStopClick 940 | end 941 | object actStepOver: TAction 942 | Category = 'Run' 943 | Caption = 'Step &Over' 944 | Hint = 'Step Over' 945 | ShortCut = 119 946 | OnExecute = actStepOverClick 947 | end 948 | object actCompile: TAction 949 | Category = 'Project' 950 | Caption = '&Compile' 951 | Hint = 'Compile' 952 | ShortCut = 16504 953 | OnExecute = actCompileClick 954 | end 955 | object actBuild: TAction 956 | Category = 'Project' 957 | Caption = '&Build' 958 | Hint = 'Build' 959 | OnExecute = actBuildClick 960 | end 961 | object actRunToCursor: TAction 962 | Category = 'Run' 963 | Caption = 'Run to &Cursor' 964 | Hint = 'Run to Cursor' 965 | ShortCut = 115 966 | OnExecute = actRunToCursorExecute 967 | end 968 | object actUndo: TAction 969 | Category = 'Edit' 970 | Caption = '&Undo' 971 | Hint = 'Undo' 972 | ShortCut = 16474 973 | OnExecute = actUndoClick 974 | end 975 | object actCut: TAction 976 | Category = 'Edit' 977 | Caption = 'Cu&t' 978 | Hint = 'Cut' 979 | ShortCut = 16472 980 | OnExecute = actCutClick 981 | end 982 | object actCopy: TAction 983 | Category = 'Edit' 984 | Caption = '&Copy' 985 | Hint = 'Copy' 986 | ShortCut = 16451 987 | OnExecute = actCopyClick 988 | end 989 | object actPaste: TAction 990 | Category = 'Edit' 991 | Caption = '&Paste' 992 | Hint = 'Paste' 993 | ShortCut = 16470 994 | OnExecute = actPasteClick 995 | end 996 | object actDelete: TAction 997 | Category = 'Edit' 998 | Caption = 'De&lete' 999 | Hint = 'Delete' 1000 | OnExecute = actDeleteClick 1001 | end 1002 | end 1003 | object MemoPopup: TPopupMenu 1004 | Left = 8 1005 | Top = 80 1006 | object MPUndo: TMenuItem 1007 | Action = actUndo 1008 | end 1009 | object N8: TMenuItem 1010 | Caption = '-' 1011 | end 1012 | object MPCut: TMenuItem 1013 | Action = actCut 1014 | end 1015 | object MPCopy: TMenuItem 1016 | Action = actCopy 1017 | end 1018 | object MPPaste: TMenuItem 1019 | Action = actPaste 1020 | end 1021 | object MPDelete: TMenuItem 1022 | Action = actDelete 1023 | end 1024 | end 1025 | end 1026 | -------------------------------------------------------------------------------- /Src/Main.pas: -------------------------------------------------------------------------------- 1 | unit Main; 2 | 3 | { 4 | Inno Pascal 5 | Copyright (C) 2000 Jordan Russell 6 | 7 | www: http://www.jrsoftware.org/ 8 | or http://www.jordanr.cjb.net/ 9 | email: jr@jrsoftware.org 10 | 11 | This program is free software; you can redistribute it and/or 12 | modify it under the terms of the GNU General Public License 13 | as published by the Free Software Foundation; either version 2 14 | of the License, or (at your option) any later version. 15 | 16 | This program is distributed in the hope that it will be useful, 17 | but WITHOUT ANY WARRANTY; without even the implied warranty of 18 | MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 19 | GNU General Public License for more details. 20 | 21 | You should have received a copy of the GNU General Public License 22 | along with this program; if not, write to the Free Software 23 | Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. 24 | } 25 | 26 | interface 27 | 28 | uses 29 | WinTypes, WinProcs, SysUtils, Messages, Classes, Graphics, Controls, 30 | Forms, Dialogs, StdCtrls, ExtCtrls, Menus, Buttons, TB97Tlbr, TB97Ctls, 31 | TB97, ComCtrls, SynEdit, SynMemo, SynEditHighlighter, SynHighlighterPas, 32 | IPascal, IPBase, ActnList; 33 | 34 | const 35 | MRUListMaxCount = 8; 36 | WM_DebugMsg = WM_USER + 1111; 37 | 38 | type 39 | TMainForm = class(TForm) 40 | OpenDialog: TOpenDialog; 41 | MainMenu1: TMainMenu; 42 | FMenu: TMenuItem; 43 | FNew: TMenuItem; 44 | FOpen: TMenuItem; 45 | FSave: TMenuItem; 46 | FSaveAs: TMenuItem; 47 | N1: TMenuItem; 48 | FExit: TMenuItem; 49 | EMenu: TMenuItem; 50 | EUndo: TMenuItem; 51 | N3: TMenuItem; 52 | ECut: TMenuItem; 53 | ECopy: TMenuItem; 54 | EPaste: TMenuItem; 55 | EDelete: TMenuItem; 56 | N4: TMenuItem; 57 | ESelectAll: TMenuItem; 58 | VMenu: TMenuItem; 59 | EFind: TMenuItem; 60 | EFindNext: TMenuItem; 61 | EReplace: TMenuItem; 62 | Help1: TMenuItem; 63 | HAbout: TMenuItem; 64 | SaveDialog: TSaveDialog; 65 | FMRUSep: TMenuItem; 66 | VCompilerMessages: TMenuItem; 67 | FindDialog: TFindDialog; 68 | ReplaceDialog: TReplaceDialog; 69 | MessageList: TListBox; 70 | VToolbar: TMenuItem; 71 | TopDock: TDock97; 72 | MainToolbar: TToolbar97; 73 | NewButton: TToolbarButton97; 74 | OpenButton: TToolbarButton97; 75 | SaveButton: TToolbarButton97; 76 | MainSep1: TToolbarSep97; 77 | CompileButton: TToolbarButton97; 78 | RunButton: TToolbarButton97; 79 | StopButton: TToolbarButton97; 80 | RightDock: TDock97; 81 | BottomDock: TDock97; 82 | LeftDock: TDock97; 83 | Project1: TMenuItem; 84 | RRun: TMenuItem; 85 | PCompile: TMenuItem; 86 | RStop: TMenuItem; 87 | StatusBar: TStatusBar; 88 | ToolbarSep971: TToolbarSep97; 89 | Memo: TSynMemo; 90 | Highlighter: TSynPasSyn; 91 | VEditorOptions: TMenuItem; 92 | VEHorizCaret: TMenuItem; 93 | N2: TMenuItem; 94 | Run1: TMenuItem; 95 | N5: TMenuItem; 96 | RStepOver: TMenuItem; 97 | ActionList: TActionList; 98 | actRun: TAction; 99 | actStop: TAction; 100 | actStepOver: TAction; 101 | actCompile: TAction; 102 | RParameters: TMenuItem; 103 | VD: TMenuItem; 104 | VDEventLog: TMenuItem; 105 | VDRegisters: TMenuItem; 106 | PBuild: TMenuItem; 107 | actBuild: TAction; 108 | N6: TMenuItem; 109 | actRunToCursor: TAction; 110 | RRunToCursor: TMenuItem; 111 | OuterPanel: TPanel; 112 | Splitter: TSplitter; 113 | N7: TMenuItem; 114 | HReadme: TMenuItem; 115 | HLicense: TMenuItem; 116 | MemoPopup: TPopupMenu; 117 | actUndo: TAction; 118 | actCut: TAction; 119 | actCopy: TAction; 120 | actPaste: TAction; 121 | MPUndo: TMenuItem; 122 | N8: TMenuItem; 123 | MPCut: TMenuItem; 124 | MPCopy: TMenuItem; 125 | MPPaste: TMenuItem; 126 | actDelete: TAction; 127 | MPDelete: TMenuItem; 128 | procedure FormCreate(Sender: TObject); 129 | procedure FormDestroy(Sender: TObject); 130 | procedure FormCloseQuery(Sender: TObject; var CanClose: Boolean); 131 | procedure FExitClick(Sender: TObject); 132 | procedure FOpenClick(Sender: TObject); 133 | procedure actUndoClick(Sender: TObject); 134 | procedure EMenuClick(Sender: TObject); 135 | procedure actCutClick(Sender: TObject); 136 | procedure actCopyClick(Sender: TObject); 137 | procedure actPasteClick(Sender: TObject); 138 | procedure actDeleteClick(Sender: TObject); 139 | procedure FSaveClick(Sender: TObject); 140 | procedure ESelectAllClick(Sender: TObject); 141 | procedure FNewClick(Sender: TObject); 142 | procedure FSaveAsClick(Sender: TObject); 143 | procedure actCompileClick(Sender: TObject); 144 | procedure FMenuClick(Sender: TObject); 145 | procedure FMRUClick(Sender: TObject); 146 | procedure VCompilerMessagesClick(Sender: TObject); 147 | procedure HAboutClick(Sender: TObject); 148 | procedure EFindClick(Sender: TObject); 149 | procedure FindDialogFind(Sender: TObject); 150 | procedure EReplaceClick(Sender: TObject); 151 | procedure ReplaceDialogReplace(Sender: TObject); 152 | procedure EFindNextClick(Sender: TObject); 153 | procedure VMenuClick(Sender: TObject); 154 | procedure VToolbarClick(Sender: TObject); 155 | procedure actRunClick(Sender: TObject); 156 | procedure actStopClick(Sender: TObject); 157 | procedure MemoSpecialLineColors(Sender: TObject; Line: Integer; 158 | var Special: Boolean; var FG, BG: TColor); 159 | procedure MemoStatusChange(Sender: TObject; 160 | Changes: TSynStatusChanges); 161 | procedure VEditorOptionsClick(Sender: TObject); 162 | procedure VEHorizCaretClick(Sender: TObject); 163 | procedure actStepOverClick(Sender: TObject); 164 | procedure RParametersClick(Sender: TObject); 165 | procedure VDEventLogClick(Sender: TObject); 166 | procedure VDRegistersClick(Sender: TObject); 167 | procedure MemoPaint(Sender: TObject; ACanvas: TCanvas); 168 | procedure actBuildClick(Sender: TObject); 169 | procedure MemoChange(Sender: TObject); 170 | procedure actRunToCursorExecute(Sender: TObject); 171 | procedure MessageListDblClick(Sender: TObject); 172 | procedure HReadmeClick(Sender: TObject); 173 | procedure HLicenseClick(Sender: TObject); 174 | private 175 | { Private declarations } 176 | FBreakLine: Integer; 177 | FDebugBreaked: Boolean; 178 | FErrorLine: Integer; 179 | FFilename: String; 180 | FModifiedSinceLastCompile, FModifiedWhileDebugging: Boolean; 181 | FMRUMenuItems: array[0..MRUListMaxCount-1] of TMenuItem; 182 | FMRUList: TStringList; 183 | FLineNumberInfo: PLineNumberInfoArray; 184 | FLineNumberInfoCount: Integer; 185 | FParameters: String; 186 | procedure AddToMRUList (const AFilename: String); 187 | function AskToSaveModifiedFile: Boolean; 188 | function AskToRestartIfModified: Boolean; 189 | procedure Compile; 190 | function CompileIfNecessary: Boolean; 191 | procedure CompilerStatusProc (AType: TCompilerStatusType; 192 | const AFilename: String; ALine, ACh: Integer; const AMsg: String); 193 | function GetOutFilename: String; 194 | procedure HideError; 195 | procedure NewFile; 196 | procedure OpenFile (AFilename: String); 197 | procedure ResetEditorState; 198 | procedure Run (const SingleStep: Boolean); 199 | function SaveFile (const SaveAs: Boolean): Boolean; 200 | procedure SetBreakLine (ALine: Integer); 201 | procedure SetErrorLine (ALine: Integer); 202 | procedure SetMessageListVisible (const AVisible: Boolean); 203 | procedure Stop; 204 | procedure UpdateCaption; 205 | procedure UpdateRunActions (const ADebugBreaked: Boolean); 206 | procedure WMDebugMsg (var Message: TMessage); message WM_DebugMsg; 207 | public 208 | { Public declarations } 209 | end; 210 | 211 | var 212 | MainForm: TMainForm; 213 | 214 | implementation 215 | 216 | uses 217 | Clipbrd, ShellApi, Registry, CmnFunc, CmnFunc2, 218 | LinkerPE, CodeX86, Debugger, DebugEventLog, DebugRegisters; 219 | 220 | {$R *.DFM} 221 | 222 | const 223 | HistoryListSize = 8; 224 | 225 | SCompilerFormCaption = 'Inno Pascal'; 226 | SNewLine = #13#10; 227 | SNewLine2 = #13#10#13#10; 228 | 229 | procedure TMainForm.FormCreate(Sender: TObject); 230 | var 231 | I: Integer; 232 | NewItem: TMenuItem; 233 | Ini: TRegIniFile; 234 | S: String; 235 | R: TRect; 236 | WindowPlacement: TWindowPlacement; 237 | Settings: TStringList; 238 | UseDelphiHighlightSettings: Boolean; 239 | begin 240 | FModifiedSinceLastCompile := True; 241 | FBreakLine := -1; 242 | 243 | MessageList.Height := 0; 244 | 245 | { For some reason, if AutoScroll=False is set on the form Delphi ignores the 246 | 'poDefault' Position setting } 247 | AutoScroll := False; 248 | 249 | { Append 'Del' to the end of the Delete item. Don't actually use Del as 250 | the shortcut key so that the Del key still works when the menu item is 251 | disabled because there is no selection. } 252 | EDelete.Caption := EDelete.Caption + #9 + ShortCutToText(VK_DELETE); 253 | 254 | FMRUList := TStringList.Create; 255 | for I := 0 to High(FMRUMenuItems) do begin 256 | NewItem := TMenuItem.Create(Self); 257 | NewItem.OnClick := FMRUClick; 258 | FMenu.Insert (FMenu.IndexOf(FMRUSep), NewItem); 259 | FMRUMenuItems[I] := NewItem; 260 | end; 261 | 262 | UpdateCaption; 263 | 264 | Ini := TRegIniFile.Create('Software\Jordan Russell\Inno Pascal'); 265 | try 266 | { Don't localize! } 267 | for I := 0 to High(FMRUMenuItems) do begin 268 | S := Ini.ReadString('FileHistory', 'History' + IntToStr(I), ''); 269 | if S <> '' then FMRUList.Add (S); 270 | end; 271 | 272 | MainToolbar.Visible := Ini.ReadBool('Options', 'ShowToolbar', True); 273 | UseDelphiHighlightSettings := Ini.ReadBool('Options', 'UseDelphiHighlightSettings', True); 274 | 275 | R.Left := Ini.ReadInteger('Options', 'MainPosLeft', Left); 276 | R.Right := Ini.ReadInteger('Options', 'MainPosRight', Left + Width); 277 | R.Top := Ini.ReadInteger('Options', 'MainPosTop', Top); 278 | R.Bottom := Ini.ReadInteger('Options', 'MainPosBottom', Top + Height); 279 | WindowPlacement.length := SizeOf(WindowPlacement); 280 | GetWindowPlacement (Handle, @WindowPlacement); 281 | if Ini.ReadBool('Options', 'Maximized', False) then 282 | WindowPlacement.showCmd := SW_SHOWMAXIMIZED; 283 | WindowPlacement.rcNormalPosition := R; 284 | SetWindowPlacement (Handle, @WindowPlacement); 285 | finally 286 | Ini.Free; 287 | end; 288 | 289 | if UseDelphiHighlightSettings then begin 290 | Settings := TStringList.Create; 291 | try 292 | Highlighter.EnumUserSettings(Settings); 293 | if Settings.Count > 0 then 294 | Highlighter.UseUserSettings(Settings.Count - 1); 295 | finally 296 | Settings.Free; 297 | end; 298 | end; 299 | 300 | if ParamStr(1) <> '' then 301 | OpenFile (ParamStr(1)); 302 | end; 303 | 304 | procedure TMainForm.FormDestroy(Sender: TObject); 305 | var 306 | Ini: TRegIniFile; 307 | I: Integer; 308 | S: String; 309 | WindowPlacement: TWindowPlacement; 310 | begin 311 | Ini := TRegIniFile.Create('Software\Jordan Russell\Inno Pascal'); 312 | try 313 | { Don't localize! } 314 | for I := 0 to High(FMRUMenuItems) do begin 315 | if I < FMRUList.Count then 316 | S := FMRUList[I] 317 | else 318 | S := ''; 319 | Ini.WriteString ('FileHistory', 'History' + IntToStr(I), 320 | S {work around Delphi 2 bug:} + #0); 321 | end; 322 | 323 | Ini.WriteBool ('Options', 'ShowToolbar', MainToolbar.Visible); 324 | 325 | WindowPlacement.length := SizeOf(WindowPlacement); 326 | GetWindowPlacement (Handle, @WindowPlacement); 327 | Ini.WriteInteger ('Options', 'MainPosLeft', WindowPlacement.rcNormalPosition.Left); 328 | Ini.WriteInteger ('Options', 'MainPosRight', WindowPlacement.rcNormalPosition.Right); 329 | Ini.WriteInteger ('Options', 'MainPosTop', WindowPlacement.rcNormalPosition.Top); 330 | Ini.WriteInteger ('Options', 'MainPosBottom', WindowPlacement.rcNormalPosition.Bottom); 331 | Ini.WriteBool ('Options', 'Maximized', WindowState = wsMaximized); 332 | finally 333 | Ini.Free; 334 | end; 335 | 336 | FMRUList.Free; 337 | end; 338 | 339 | procedure TMainForm.FormCloseQuery(Sender: TObject; 340 | var CanClose: Boolean); 341 | begin 342 | if Debugging then begin 343 | Application.MessageBox ('You must stop the running process before exiting.', 344 | nil, MB_OK or MB_ICONEXCLAMATION); 345 | CanClose := False; 346 | Exit; 347 | end; 348 | CanClose := AskToSaveModifiedFile; 349 | end; 350 | 351 | procedure TMainForm.UpdateCaption; 352 | var 353 | NewCaption: String; 354 | begin 355 | NewCaption := ExtractFileName(FFilename); 356 | if NewCaption = '' then NewCaption := 'Untitled'; 357 | NewCaption := NewCaption + ' - ' + SCompilerFormCaption + ' ' + 358 | InnoPascalVersion; 359 | if Debugging then begin 360 | if not FDebugBreaked then 361 | NewCaption := NewCaption + ' [Run]' 362 | else 363 | NewCaption := NewCaption + ' [Break]'; 364 | end; 365 | Caption := NewCaption; 366 | Application.Title := NewCaption; 367 | end; 368 | 369 | procedure TMainForm.ResetEditorState; 370 | { Called after entirely new text is loaded into the editor } 371 | begin 372 | FModifiedSinceLastCompile := True; 373 | Memo.Modified := False; 374 | StatusBar.Panels[1].Text := ''; { clear the 'Modified' indicator } 375 | StatusBar.Panels[3].Text := ''; { clear the compilation status } 376 | HideError; 377 | SetMessageListVisible (False); 378 | MessageList.Clear; 379 | end; 380 | 381 | procedure TMainForm.NewFile; 382 | begin 383 | Memo.Lines.Clear; 384 | ResetEditorState; 385 | FFilename := ''; 386 | UpdateCaption; 387 | end; 388 | 389 | procedure TMainForm.OpenFile (AFilename: String); 390 | begin 391 | AFilename := ExpandFileName(AFilename); 392 | AddToMRUList (AFilename); 393 | try 394 | Memo.Lines.LoadFromFile (AFilename); 395 | except 396 | on EInvalidOperation do begin 397 | MsgBox ('Script file is too large to open in the Inno Setup editor.', 398 | SCompilerFormCaption, mbError, MB_OK); 399 | Exit; 400 | end; 401 | end; 402 | ResetEditorState; 403 | FFilename := AFilename; 404 | UpdateCaption; 405 | end; 406 | 407 | function TMainForm.SaveFile (const SaveAs: Boolean): Boolean; 408 | begin 409 | Result := False; 410 | if SaveAs or (FFilename = '') then begin 411 | SaveDialog.Filename := FFilename; 412 | if not SaveDialog.Execute then Exit; 413 | Memo.Lines.SaveToFile (SaveDialog.Filename); 414 | FFilename := SaveDialog.Filename; 415 | UpdateCaption; 416 | end 417 | else 418 | Memo.Lines.SaveToFile (FFilename); 419 | Memo.Modified := False; 420 | Memo.ClearUndo; 421 | StatusBar.Panels[1].Text := ''; 422 | Result := True; 423 | AddToMRUList (FFilename); 424 | end; 425 | 426 | function TMainForm.AskToSaveModifiedFile: Boolean; 427 | var 428 | FileTitle: String; 429 | begin 430 | Result := True; 431 | if Memo.Modified then begin 432 | FileTitle := FFilename; 433 | if FileTitle = '' then FileTitle := 'Untitled'; 434 | case MsgBox('The text in the ' + FileTitle + ' file has changed.'#13#10#13#10 + 435 | 'Do you want to save the changes?', SCompilerFormCaption, mbError, 436 | MB_YESNOCANCEL) of 437 | ID_YES: Result := SaveFile(False); 438 | ID_NO: ; 439 | else 440 | Result := False; 441 | end; 442 | end; 443 | end; 444 | 445 | procedure TMainForm.AddToMRUList (const AFilename: String); 446 | var 447 | I: Integer; 448 | begin 449 | I := 0; 450 | while I < FMRUList.Count do begin 451 | if CompareText(FMRUList[I], AFilename) = 0 then 452 | FMRUList.Delete (I) 453 | else 454 | Inc (I); 455 | end; 456 | FMRUList.Insert (0, AFilename); 457 | while FMRUList.Count > High(FMRUMenuItems)+1 do 458 | FMRUList.Delete (FMRUList.Count-1); 459 | end; 460 | 461 | procedure TMainForm.FMenuClick(Sender: TObject); 462 | var 463 | I: Integer; 464 | begin 465 | FMRUSep.Visible := FMRUList.Count <> 0; 466 | for I := 0 to High(FMRUMenuItems) do 467 | with FMRUMenuItems[I] do begin 468 | if I < FMRUList.Count then begin 469 | Visible := True; 470 | Caption := '&' + IntToStr(I+1) + ' ' + FMRUList[I]; 471 | end 472 | else 473 | Visible := False; 474 | end; 475 | end; 476 | 477 | procedure TMainForm.FNewClick(Sender: TObject); 478 | begin 479 | if not AskToSaveModifiedFile then Exit; 480 | NewFile; 481 | end; 482 | 483 | procedure TMainForm.FOpenClick(Sender: TObject); 484 | begin 485 | OpenDialog.Filename := ''; 486 | if not AskToSaveModifiedFile or not OpenDialog.Execute then 487 | Exit; 488 | OpenFile (OpenDialog.Filename); 489 | end; 490 | 491 | procedure TMainForm.FSaveClick(Sender: TObject); 492 | begin 493 | SaveFile (False); 494 | end; 495 | 496 | procedure TMainForm.FSaveAsClick(Sender: TObject); 497 | begin 498 | SaveFile (True); 499 | end; 500 | 501 | function TMainForm.GetOutFilename: String; 502 | begin 503 | if FFilename <> '' then 504 | Result := ChangeFileExt(FFilename, '.exe') 505 | else 506 | Result := 'noname.exe'; 507 | end; 508 | 509 | procedure TMainForm.CompilerStatusProc (AType: TCompilerStatusType; 510 | const AFilename: String; ALine, ACh: Integer; const AMsg: String); 511 | const 512 | TypeText: array[TCompilerStatusType] of String = ('Warning', 'Hint'); 513 | begin 514 | SetMessageListVisible (True); 515 | MessageList.Items.AddObject (Format('%s: %s[%d,%d]: %s', 516 | [TypeText[AType], AFilename, ALine, ACh, AMsg]), Pointer(ALine)); 517 | end; 518 | 519 | procedure TMainForm.Compile; 520 | var 521 | S: String; 522 | NumWritten: Cardinal; 523 | I: Integer; 524 | StartTime, EndTime, Freq: Int64; 525 | InCurrentFile: Boolean; 526 | begin 527 | MessageList.Clear; 528 | StatusBar.Panels[3].Text := ''; 529 | SetErrorLine(-1); 530 | FreeMem (FLineNumberInfo); 531 | FLineNumberInfo := nil; 532 | Memo.InvalidateGutter; 533 | try 534 | FLineNumberInfoCount := Memo.Lines.Count; 535 | S := Memo.Text; 536 | I := Length(S); 537 | { Memo.Text puts a CR/LF at the end of the last line, even if there is 538 | no blank line after it. We have to remove the CR/LF so that we don't get 539 | error messages on lines past the end of the file. 540 | (Note: I'm not using TrimRight to do this because it causes a second 541 | string to be allocated.) } 542 | while (I > 0) and (S[I] <= ' ') do 543 | Dec (I); 544 | SetLength (S, I); 545 | QueryPerformanceFrequency (Freq); 546 | QueryPerformanceCounter (StartTime); 547 | NumWritten := IPCompileAndLink(FFilename, PChar(S), GetOutFilename, 548 | FLineNumberInfoCount, FLineNumberInfo, CompilerStatusProc, TIPPELinker, 549 | TX86CodeGen); 550 | QueryPerformanceCounter (EndTime); 551 | except 552 | on E: EIPCompilerError do begin 553 | { Move the caret to the line number the error occured on } 554 | SetMessageListVisible (True); 555 | InCurrentFile := E.Filename = FFilename; 556 | MessageList.Items.AddObject (Format('Error: %s[%d,%d]: %s', 557 | [E.Filename, E.Line, E.Ch, E.ErrorText]), Pointer(E.Line * Ord(InCurrentFile))); 558 | if InCurrentFile then begin 559 | Memo.CaretXY := Point(E.Ch, E.Line); 560 | Memo.SetFocus; 561 | SetErrorLine(E.Line); 562 | end; 563 | Abort; 564 | Exit; 565 | end; 566 | end; 567 | FModifiedSinceLastCompile := False; 568 | StatusBar.Panels[3].Text := 569 | Format('Successful compile - %d bytes written, %.3f seconds', 570 | [NumWritten, (EndTime - StartTime) / Freq]); 571 | if MessageList.Items.Count = 0 then 572 | SetMessageListVisible (False); 573 | Memo.InvalidateGutter; 574 | end; 575 | 576 | function TMainForm.CompileIfNecessary: Boolean; 577 | begin 578 | Result := FModifiedSinceLastCompile; 579 | if Result then 580 | Compile 581 | else 582 | StatusBar.Panels[3].Text := 'No changes to source, skipping compile'; 583 | FModifiedWhileDebugging := False; 584 | end; 585 | 586 | procedure TMainForm.actCompileClick(Sender: TObject); 587 | begin 588 | if not Debugging then 589 | CompileIfNecessary; 590 | end; 591 | 592 | procedure TMainForm.actBuildClick(Sender: TObject); 593 | begin 594 | if not Debugging then 595 | Compile; 596 | end; 597 | 598 | procedure TMainForm.FMRUClick(Sender: TObject); 599 | var 600 | I: Integer; 601 | begin 602 | if not AskToSaveModifiedFile then Exit; 603 | for I := 0 to High(FMRUMenuItems) do 604 | if FMRUMenuItems[I] = Sender then begin 605 | OpenFile (FMRUList[I]); 606 | Break; 607 | end; 608 | end; 609 | 610 | procedure TMainForm.FExitClick(Sender: TObject); 611 | begin 612 | Close; 613 | end; 614 | 615 | procedure TMainForm.EMenuClick(Sender: TObject); 616 | var 617 | HasFocus, HasSel: Boolean; 618 | begin 619 | HasFocus := Memo.Focused; 620 | HasSel := HasFocus and Memo.SelAvail; 621 | EUndo.Enabled := HasFocus and Memo.CanUndo; 622 | ECut.Enabled := HasSel; 623 | ECopy.Enabled := HasSel; 624 | EDelete.Enabled := HasSel; 625 | EPaste.Enabled := HasFocus and Clipboard.HasFormat(CF_TEXT); 626 | end; 627 | 628 | procedure TMainForm.actUndoClick(Sender: TObject); 629 | begin 630 | if Memo.Focused then 631 | Memo.Undo; 632 | end; 633 | 634 | procedure TMainForm.actCutClick(Sender: TObject); 635 | begin 636 | if Memo.Focused then 637 | Memo.CutToClipboard; 638 | end; 639 | 640 | procedure TMainForm.actCopyClick(Sender: TObject); 641 | begin 642 | if Memo.Focused then 643 | Memo.CopyToClipboard; 644 | end; 645 | 646 | procedure TMainForm.actPasteClick(Sender: TObject); 647 | begin 648 | if Memo.Focused then 649 | Memo.PasteFromClipboard; 650 | end; 651 | 652 | procedure TMainForm.actDeleteClick(Sender: TObject); 653 | begin 654 | if Memo.Focused then 655 | Memo.ClearSelection; 656 | end; 657 | 658 | procedure TMainForm.ESelectAllClick(Sender: TObject); 659 | begin 660 | Memo.SelectAll; 661 | end; 662 | 663 | procedure TMainForm.VMenuClick(Sender: TObject); 664 | begin 665 | VToolbar.Checked := MainToolbar.Visible; 666 | VCompilerMessages.Checked := MessageList.Height > 0; 667 | end; 668 | 669 | procedure TMainForm.VToolbarClick(Sender: TObject); 670 | begin 671 | MainToolbar.Visible := not MainToolbar.Visible; 672 | end; 673 | 674 | procedure TMainForm.SetMessageListVisible (const AVisible: Boolean); 675 | begin 676 | if AVisible then begin 677 | if MessageList.Height = 0 then 678 | MessageList.Height := MessageList.ItemHeight * 4 + 4; 679 | end 680 | else begin 681 | MessageList.Height := 0; 682 | { Don't let Status move above the splitter; force it to the bottom } 683 | MessageList.Top := OuterPanel.ClientHeight + 1; 684 | end; 685 | end; 686 | 687 | procedure TMainForm.VCompilerMessagesClick(Sender: TObject); 688 | begin 689 | SetMessageListVisible (MessageList.Height = 0); 690 | end; 691 | 692 | procedure TMainForm.HReadmeClick(Sender: TObject); 693 | begin 694 | ShellExecute (0, 'open', PChar(ExtractFilePath(ParamStr(0)) + 'README.htm'), 695 | nil, nil, SW_SHOW); 696 | end; 697 | 698 | procedure TMainForm.HLicenseClick(Sender: TObject); 699 | begin 700 | ShellExecute (0, 'open', PChar(ExtractFilePath(ParamStr(0)) + 'LICENSE.txt'), 701 | nil, nil, SW_SHOW); 702 | end; 703 | 704 | procedure TMainForm.HAboutClick(Sender: TObject); 705 | begin 706 | { Removing the About box or modifying the text inside it is a violation of the 707 | Inno Setup license agreement; see LICENSE.TXT. However, adding additional 708 | lines to the About box is permitted. } 709 | MsgBox ('Inno Pascal Compiler version ' + InnoPascalVersion + SNewLine + 710 | 'Copyright (C) 2000 Jordan Russell. All rights reserved.' + SNewLine2 + 711 | 'Home page:' + SNewLine + 712 | 'http://www.jrsoftware.org/', 713 | 'About Inno Pascal', mbInformation, MB_OK); 714 | end; 715 | 716 | (*procedure TCompileForm.CompileStatusProc (const S: String); 717 | var 718 | DC: HDC; 719 | Size: TSize; 720 | begin 721 | with Status do begin 722 | try 723 | TopIndex := Items.Add(S); 724 | except 725 | on EOutOfResources do begin 726 | Clear; 727 | SendMessage (Handle, LB_SETHORIZONTALEXTENT, 0, 0); 728 | Items.Add ('*** Log size limit reached, list reset.'); 729 | TopIndex := Items.Add(S); 730 | end; 731 | end; 732 | DC := GetDC(0); 733 | try 734 | SelectObject (DC, Font.Handle); 735 | GetTextExtentPoint (DC, PChar(S), Length(S), Size); 736 | finally 737 | ReleaseDC (0, DC); 738 | end; 739 | Inc (Size.cx, 5); 740 | if Size.cx > SendMessage(Handle, LB_GETHORIZONTALEXTENT, 0, 0) then 741 | SendMessage (Handle, LB_SETHORIZONTALEXTENT, Size.cx, 0); 742 | end; 743 | end;*) 744 | 745 | function FindOptionsToSearchOptions (const FindOptions: TFindOptions): TSynSearchOptions; 746 | begin 747 | Result := []; 748 | if frMatchCase in FindOptions then 749 | Include (Result, ssoMatchCase); 750 | if frWholeWord in FindOptions then 751 | Include (Result, ssoWholeWord); 752 | if frReplace in FindOptions then 753 | Include (Result, ssoReplace); 754 | if frReplaceAll in FindOptions then 755 | Include (Result, ssoReplaceAll); 756 | if not(frDown in FindOptions) then 757 | Include (Result, ssoBackwards); 758 | end; 759 | 760 | procedure TMainForm.EFindClick(Sender: TObject); 761 | begin 762 | ReplaceDialog.CloseDialog; 763 | FindDialog.Execute; 764 | end; 765 | 766 | procedure TMainForm.EFindNextClick(Sender: TObject); 767 | begin 768 | if FindDialog.FindText = '' then 769 | EFindClick (Sender) 770 | else 771 | FindDialogFind (FindDialog); 772 | end; 773 | 774 | procedure TMainForm.FindDialogFind(Sender: TObject); 775 | begin 776 | { this event handler is shared between FindDialog & ReplaceDialog } 777 | with Sender as TFindDialog do 778 | if Memo.SearchReplace(FindText, '', FindOptionsToSearchOptions(Options)) = 0 then 779 | MsgBoxFmt ('Cannot find "%s"', [FindText], '', mbError, MB_OK); 780 | end; 781 | 782 | procedure TMainForm.EReplaceClick(Sender: TObject); 783 | begin 784 | MsgBox ('Replace isn''t currently implemented.', '', mbError, MB_OK); 785 | exit; 786 | {}{ It doesn't work quite right... } 787 | FindDialog.CloseDialog; 788 | ReplaceDialog.Execute; 789 | end; 790 | 791 | procedure TMainForm.ReplaceDialogReplace(Sender: TObject); 792 | begin 793 | with ReplaceDialog do begin 794 | {if AnsiCompareText(Memo.SelText, FindText) = 0 then 795 | Memo.SelText := ReplaceText;} 796 | if Memo.SearchReplace(FindText, ReplaceText, FindOptionsToSearchOptions(Options)) = 0 then 797 | MsgBoxFmt ('Cannot find "%s"', [FindText], '', mbError, MB_OK); 798 | end; 799 | end; 800 | 801 | procedure TMainForm.WMDebugMsg (var Message: TMessage); 802 | var 803 | I, L: Integer; 804 | Wait: Boolean; 805 | begin 806 | Message.Result := 0; 807 | case Message.WParam of 808 | dmLog: begin 809 | DebugEventLogForm.Log (PDebugMsgLogData(Message.LParam).Typ, 810 | PDebugMsgLogData(Message.LParam).Details); 811 | end; 812 | dmCriticalError: begin 813 | Application.MessageBox (PChar(String(Message.LParam)), 'Debugger', 814 | MB_OK or MB_ICONSTOP); 815 | end; 816 | dmPaused: begin 817 | with PDebugMsgPauseData(Message.LParam)^ do begin 818 | Wait := AlwaysWait; 819 | SetBreakLine (-1); 820 | L := -1; 821 | if Assigned(FLineNumberInfo) then 822 | for I := 1 to FLineNumberInfoCount do 823 | if FLineNumberInfo[I] = Address then begin 824 | Wait := True; 825 | L := I; 826 | Break; 827 | end; 828 | if Wait then begin 829 | UpdateRunActions (True); 830 | SetBreakLine (L); 831 | DebugRegistersForm.NewContext (Context^); 832 | Message.Result := 1; 833 | end; 834 | end; 835 | end; 836 | dmStopped: begin 837 | SetBreakLine (-1); 838 | UpdateRunActions (False); 839 | 840 | if Message.LParam <> 0 then begin 841 | Application.MessageBox (PChar(Message.LParam), 'Fatal Debugger Error', 842 | MB_OK or MB_ICONSTOP); 843 | StrDispose (PChar(Message.LParam)); 844 | end; 845 | end; 846 | end; 847 | end; 848 | 849 | procedure TMainForm.UpdateRunActions (const ADebugBreaked: Boolean); 850 | { Enables/disables actions like Compile, Run, and Stop to match the current 851 | debugger state. Also updates caption. } 852 | begin 853 | FDebugBreaked := ADebugBreaked; 854 | actCompile.Enabled := not Debugging; 855 | actBuild.Enabled := not Debugging; 856 | actRun.Enabled := not Debugging or ADebugBreaked; 857 | actStepOver.Enabled := not Debugging or ADebugBreaked; 858 | actRunToCursor.Enabled := not Debugging or ADebugBreaked; 859 | actStop.Enabled := Debugging; 860 | UpdateCaption; 861 | end; 862 | 863 | procedure TMainForm.Run (const SingleStep: Boolean); 864 | begin 865 | SetBreakLine (-1); 866 | DebugRegistersForm.NoContext; 867 | if not Debugging then begin 868 | CompileIfNecessary; 869 | FModifiedWhileDebugging := False; 870 | 871 | DebugSingleStep := SingleStep; 872 | StartDebug (GetOutFilename, FParameters, Handle, WM_DebugMsg); 873 | UpdateRunActions (False); 874 | end 875 | else begin 876 | DebugSingleStep := SingleStep; 877 | UpdateRunActions (False); 878 | SetEvent (DebugContinueEvent); 879 | end; 880 | end; 881 | 882 | procedure TMainForm.Stop; 883 | begin 884 | if not Debugging then 885 | Exit; 886 | 887 | StopDebug; 888 | UpdateCaption; 889 | end; 890 | 891 | function TMainForm.AskToRestartIfModified: Boolean; 892 | begin 893 | Result := True; 894 | if Debugging and FModifiedWhileDebugging then 895 | case Application.MessageBox('The source has been modified. ' + 896 | 'Rebuild and restart now?', 'Source Modified', 897 | MB_YESNOCANCEL or MB_ICONQUESTION) of 898 | ID_YES: Stop; 899 | ID_NO: FModifiedWhileDebugging := False; 900 | else 901 | Result := False; 902 | end; 903 | end; 904 | 905 | procedure TMainForm.actRunClick(Sender: TObject); 906 | begin 907 | if AskToRestartIfModified then 908 | Run (False); 909 | end; 910 | 911 | procedure TMainForm.actStepOverClick(Sender: TObject); 912 | begin 913 | if AskToRestartIfModified then 914 | Run (True); 915 | end; 916 | 917 | procedure TMainForm.actRunToCursorExecute(Sender: TObject); 918 | var 919 | A: Cardinal; 920 | L: Integer; 921 | begin 922 | if not AskToRestartIfModified then 923 | Exit; 924 | if not Debugging then 925 | { Need to compile now so that LineNumberInfo will be valid } 926 | CompileIfNecessary; 927 | L := Memo.CaretY; 928 | A := $FFFFFFFF; 929 | if Assigned(FLineNumberInfo) and (L <= FLineNumberInfoCount) then 930 | A := FLineNumberInfo[L]; 931 | if A = $FFFFFFFF then begin 932 | Application.MessageBox ('Cannot run to cursor; no code was generated ' + 933 | 'for the current line.', 'Run to Cursor', MB_OK or MB_ICONEXCLAMATION); 934 | Exit; 935 | end; 936 | DebugWantBreakpointAt := A; 937 | Run (False); 938 | end; 939 | 940 | procedure TMainForm.actStopClick(Sender: TObject); 941 | begin 942 | Stop; 943 | end; 944 | 945 | procedure TMainForm.MemoSpecialLineColors(Sender: TObject; Line: Integer; 946 | var Special: Boolean; var FG, BG: TColor); 947 | begin 948 | if FErrorLine = Line then begin 949 | Special := True; 950 | FG := clWhite; 951 | BG := clMaroon; 952 | end 953 | else 954 | if FBreakLine = Line then begin 955 | Special := True; 956 | FG := clWhite; 957 | BG := clBlue; 958 | end; 959 | end; 960 | 961 | procedure TMainForm.SetErrorLine (ALine: Integer); 962 | begin 963 | if FErrorLine <> ALine then begin 964 | if FErrorLine > 0 then 965 | Memo.InvalidateLine (FErrorLine); 966 | FErrorLine := ALine; 967 | if FErrorLine > 0 then 968 | Memo.InvalidateLine (FErrorLine); 969 | end; 970 | end; 971 | 972 | procedure TMainForm.SetBreakLine (ALine: Integer); 973 | begin 974 | if FBreakLine <> ALine then begin 975 | if FBreakLine > 0 then 976 | Memo.InvalidateLine (FBreakLine); 977 | FBreakLine := ALine; 978 | if FBreakLine > 0 then begin 979 | Memo.InvalidateLine (FBreakLine); 980 | Memo.CaretXY := Point(1, FBreakLine); 981 | Memo.SetFocus; 982 | end; 983 | end; 984 | end; 985 | 986 | procedure TMainForm.HideError; 987 | begin 988 | SetErrorLine (-1); 989 | end; 990 | 991 | procedure TMainForm.MemoStatusChange(Sender: TObject; 992 | Changes: TSynStatusChanges); 993 | const 994 | InsertText: array[Boolean] of String = ('Overwrite', 'Insert'); 995 | begin 996 | if (scCaretX in Changes) or (scCaretY in Changes) then begin 997 | HideError; 998 | StatusBar.Panels[0].Text := Format('%4d:%4d', [Memo.CaretY, Memo.CaretX]); 999 | end; 1000 | if scModified in Changes then begin 1001 | if Memo.Modified then 1002 | StatusBar.Panels[1].Text := 'Modified' 1003 | else 1004 | StatusBar.Panels[1].Text := ''; 1005 | end; 1006 | if scInsertMode in Changes then 1007 | StatusBar.Panels[2].Text := InsertText[Memo.InsertMode]; 1008 | end; 1009 | 1010 | procedure TMainForm.MemoChange(Sender: TObject); 1011 | begin 1012 | FModifiedSinceLastCompile := True; 1013 | if Debugging then 1014 | FModifiedWhileDebugging := True 1015 | else 1016 | { Modified while not debugging; free the line number info and clear the dots } 1017 | if Assigned(FLineNumberInfo) then begin 1018 | FreeMem (FLineNumberInfo); 1019 | FLineNumberInfo := nil; 1020 | Memo.InvalidateGutter; 1021 | end; 1022 | { Need HideError here because we don't get an OnStatusChange event when the 1023 | Delete key is pressed } 1024 | HideError; 1025 | end; 1026 | 1027 | procedure TMainForm.VEditorOptionsClick(Sender: TObject); 1028 | begin 1029 | VEHorizCaret.Checked := Memo.InsertCaret = ctHorizontalLine; 1030 | end; 1031 | 1032 | procedure TMainForm.VEHorizCaretClick(Sender: TObject); 1033 | begin 1034 | if Memo.InsertCaret <> ctHorizontalLine then 1035 | Memo.InsertCaret := ctHorizontalLine 1036 | else 1037 | Memo.InsertCaret := ctVerticalLine; 1038 | end; 1039 | 1040 | procedure TMainForm.RParametersClick(Sender: TObject); 1041 | begin 1042 | InputQuery ('Run Parameters', 'Parameters:', FParameters); 1043 | end; 1044 | 1045 | procedure TMainForm.VDEventLogClick(Sender: TObject); 1046 | begin 1047 | DebugEventLogForm.Show; 1048 | end; 1049 | 1050 | procedure TMainForm.VDRegistersClick(Sender: TObject); 1051 | begin 1052 | DebugRegistersForm.Show; 1053 | end; 1054 | 1055 | procedure TMainForm.MemoPaint(Sender: TObject; ACanvas: TCanvas); 1056 | var 1057 | CR: TRect; 1058 | H, Y, I: Integer; 1059 | begin 1060 | ACanvas.Pen.Color := clGreen; 1061 | ACanvas.Brush.Color := clLime; 1062 | H := Memo.LineHeight; 1063 | Y := 0; 1064 | CR := ACanvas.ClipRect; 1065 | for I := Memo.TopLine to Memo.Lines.Count do begin 1066 | if Y >= CR.Bottom then 1067 | Break; 1068 | if (Y + H > CR.Top) and Assigned(FLineNumberInfo) and 1069 | (I <= FLineNumberInfoCount) and (FLineNumberInfo[I] <> $FFFFFFFF) then 1070 | ACanvas.Rectangle (19, Y + (H div 2) - 1, 22, Y + (H div 2) + 2); 1071 | Inc (Y, H); 1072 | end; 1073 | end; 1074 | 1075 | procedure TMainForm.MessageListDblClick(Sender: TObject); 1076 | var 1077 | I, L: Integer; 1078 | begin 1079 | I := MessageList.ItemIndex; 1080 | if I = -1 then 1081 | Exit; 1082 | L := Integer(MessageList.Items.Objects[I]); 1083 | Memo.CaretXY := Point(1, L); 1084 | Memo.SetFocus; 1085 | SetErrorLine (L); 1086 | end; 1087 | 1088 | end. 1089 | --------------------------------------------------------------------------------