diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 0000000..675b2fb --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,97 @@ +name: CI + +# Run on every push and on pull requests targeting any branch. +on: + push: + pull_request: + +jobs: + test: + name: Build GpProfDll + run DUnit tests (Win32) + runs-on: windows-latest + + env: + # Set the BDS repository variable to the RAD Studio installation root, + # e.g. C:\Program Files (x86)\Embarcadero\Studio\23.0 (Delphi 12 Athens) + # C:\Program Files (x86)\Embarcadero\Studio\22.0 (Delphi 11 Alexandria) + # On a self-hosted runner the variable is usually already set in the system + # environment; override it here as needed via Settings → Variables → Actions. + BDS: ${{ vars.BDS }} + + steps: + - name: Checkout repository + uses: actions/checkout@v4 + + # ----------------------------------------------------------------------- + # Locate the Delphi compiler. We try the BDS repository variable first, + # then fall back to the most common installation paths for Delphi 12/11. + # ----------------------------------------------------------------------- + - name: Locate Delphi installation + id: delphi + shell: pwsh + run: | + $bds = $env:BDS + if (-not $bds) { + $candidates = @( + 'C:\Program Files (x86)\Embarcadero\Studio\23.0', + 'C:\Program Files (x86)\Embarcadero\Studio\22.0', + 'C:\Program Files (x86)\Embarcadero\Studio\21.0', + 'C:\Program Files (x86)\Embarcadero\Studio\20.0' + ) + foreach ($p in $candidates) { + if (Test-Path "$p\bin\DCC32.exe") { $bds = $p; break } + } + } + if (-not $bds -or -not (Test-Path "$bds\bin\DCC32.exe")) { + Write-Error @" +Delphi DCC32.exe not found. +Set the BDS Actions repository variable to your RAD Studio installation directory, +e.g. C:\Program Files (x86)\Embarcadero\Studio\23.0 +or use a self-hosted runner that already has Delphi on PATH. +"@ + exit 1 + } + Write-Host "Delphi found at: $bds" + # Export for subsequent steps + "BDS=$bds" | Out-File -FilePath $env:GITHUB_ENV -Encoding utf8 -Append + + - name: Add MSBuild to PATH + uses: microsoft/setup-msbuild@v2 + + # ----------------------------------------------------------------------- + # Build the profiling instrumentation DLL (Win32, Release). + # ----------------------------------------------------------------------- + - name: Build GpProfDll (Win32 · Release) + shell: pwsh + run: | + msbuild source\gpprof.dll\GpProfDll.dproj ` + /t:Build ` + /p:Config=Release /p:Platform=Win32 ` + /v:minimal /nologo + + # ----------------------------------------------------------------------- + # Build the DUnit test console application (Win32, Release). + # DCC_ExeOutput is set to "." in the project, so the exe lands in + # source\gpprof.dll.tests\ alongside the stub GpProfDllTests.GPI file. + # ----------------------------------------------------------------------- + - name: Build GpProfDllTests (Win32 · Release) + shell: pwsh + run: | + msbuild source\gpprof.dll.tests\GpProfDllTests.dproj ` + /t:Build ` + /p:Config=Release /p:Platform=Win32 ` + /v:minimal /nologo + + # ----------------------------------------------------------------------- + # Run the DUnit tests. + # TextTestRunner.RunRegisteredTests sets ExitCode to + # FailureCount + ErrorCount; exit 0 means all tests passed. + # ----------------------------------------------------------------------- + - name: Run DUnit tests + shell: pwsh + run: | + & .\source\gpprof.dll.tests\GpProfDllTests.exe + if ($LASTEXITCODE -ne 0) { + Write-Error "DUnit tests failed (exit code $LASTEXITCODE)" + exit $LASTEXITCODE + } diff --git a/.gitignore b/.gitignore index 763f2cc..3e51593 100644 --- a/.gitignore +++ b/.gitignore @@ -2,7 +2,7 @@ BIN/gpprof.drc BIN/gpprof.exe BIN/gpprof.map *.~dsk -tests/Win32/Debug/*.* +source/GpProfDllTestApp/Win32/Debug/*.* *.identcache *.rsmres *.res @@ -19,11 +19,19 @@ bin64/*.map BIN/*.map *.dproj.local **/__history -/source/__recovery/__recovery.ini -/source/__recovery/gppMain.dfm -/source/__recovery/gppMain.pas -/source/VirtualTree.Tools/__recovery/__recovery.ini -/source/VirtualTree.Tools/__recovery/virtualTree.tools.statistics.pas +/source/GpProf.UI/__recovery/__recovery.ini +/source/GpProf.UI/__recovery/gppMain.dfm +/source/GpProf.UI/__recovery/gppMain.pas +/source/GpProf.UI/ui/VirtualTree.Tools/__recovery/__recovery.ini +/source/GpProf.UI/ui/VirtualTree.Tools/__recovery/virtualTree.tools.statistics.pas *.dsk *.bk2 /gpprof_2017* +source/gpprof.dll.tests/*.exe +source/gpprof.dll.tests/*.map +source/gpprof.dll.tests/Win32/ +source/gpprof.dll.tests/Win64/ +source/GpProfDllTestApp/Win32/ +source/GpProfDllTestApp/Win64/ +/source/gpprof.dll/Win32/** +/source/gpprof.dll/Win64/** diff --git a/bin64/GPPROF.chm b/bin64/GPPROF.chm deleted file mode 100644 index 980667f..0000000 Binary files a/bin64/GPPROF.chm and /dev/null differ diff --git a/bin64/gpprof.eul b/bin64/gpprof.eul deleted file mode 100644 index 55964e3..0000000 --- a/bin64/gpprof.eul +++ /dev/null @@ -1,1301 +0,0 @@ -ACTIVEX -ACTNLIST -AREAEDIT -ARROWCHA -ARROWEDI -AXCTRLS -AXISINCR -AXMAXMIN -BAREDIT -BDE -BDECONST -BDEMTS -BDEPROV -BISMTP -BRUSHDLG -BUBBLECH -BUBBLEDI -BUTTONS -CALENDAR -CGIAPP -CHART -CHECKLST -CLASSES -CLIPBRD -COLORGRD -COMCONST -COMCORBA -COMCTRLS -COMMCTRL -COMMDLG -COMOBJ -COMSERV -COMSTRS -CONSTS -CONTROLS -COPYPRSR -CORBACON -CORBAOBJ -CORBARDM -CORBASTD -CORBAVCL -CORBCNST -CORBINIT -CPL -CUSTEDIT -DATABKR -DB -DBACTNS -DBCGRIDS -DBCHART -DBCLIENT -DBCOMMON -DBCONSTS -DBCTRLS -DBEDITCH -DBEXCEPT -DBGRIDS -DBINPREQ -DBLOGDLG -DBLOOKUP -DBOLECTL -DBPWDLG -DBTABLES -DBWEB -DCLUSR30 -DCLUSR40 -DDEMAN -DDEML -DDEREG -DIALOGS -DIROUTLN -DLGS -DRINTF -DRTABLE -DSGNINTF -DSGNWNDS -DSINTF -DSNDBCST -DSPROD -EDITCHAR -EDITINTF -EXPTINTF -EXTCTRLS -EXTDLGS -FILECTRL -FILEINTF -FLATSB -FLINEEDI -FORMS -GANTTCH -GANTTEDI -GAUGES -GRAPHICS -GRIDS -HTTPAPP -IBCONST -IBCTRLS -IBEVNTS -IBPROC32 -IEDITCHA -IMAGEHLP -IMGLIST -IMM -INIFILES -ISAPI -ISAPI2 -ISAPIAPP -ISP3 -ISTREAMS -JCONSTS -JPEG -LIBHELP -LZEXPAND -MAPI -MASK -MASKS -MATH -MCONNECT -MENUS -MESSAGES -MIDASCON -MIDCONST -MMSYSTEM -MPLAYER -MSRVR -MTSOBJ -MTSRDM -MTX -MULTIMON -MXARRAYS -MXBUTTON -MXCOMMON -MXCONSTS -MXDB -MXDCUBE -MXDSQL -MXGRAPH -MXGRID -MXPBAR -MXPIVSRC -MXQEDCOM -MXQPARSE -MXSTORE -MXTABLES -NB30 -NMCONST -NMDAYTIM -NMECHO -NMEXTSTR -NMFNGR -NMFTP -NMHTML -NMHTTP -NMMSG -NMNNTP -NMPOP3 -NMSMTP -NMSTRM -NMTIME -NMUDP -NMURL -NMUUE -NS30FIX -NSAPI -OBJBRKR -OCXREG -OLE2 -OLEAUTO -OLECONST -OLECTL -OLECTNRS -OLECTRLS -OLEDLG -OPENGL -ORBPAS -OUTLINE -PENDLG -PENWIN -PICEDIT -PIEEDIT -PRINTERS -PROVIDER -PROXIES -PSOCK -QR2CONST -QR3CONST -QRABOUT -QRALIAS -QRCOMPED -QRCTRLS -QRDATASU -QRENVED -QREXPBLD -QREXPORT -QREXPR -QREXTRA -QRHTML -QRLABLED -QRPREV -QRPRGRES -QRPRNSU -QRPRNTR -QRTEE -QUICKRPT -REGISTRY -REGSTR -REPORT -RICHEDIT -RSCONSTS -SCKTCOMP -SCONNECT -SERIES -SHAPEEDI -SHAREMEM -SHELLAPI -SHLOBJ -SMCONSTS -SMINTF -SPIN -STDACTNS -STDCTRLS -STDVCL -SVCMGR -SYNCOBJS -SYSCONST -SYSINIT -SYSTEM -SYSUTILS -TABNOTBK -TABS -TECANVAS -TEEABOUT -TEECONST -TEEFUNCI -TEEGALLY -TEELISB -TEENGINE -TEEPREVI -TEEPROCS -TEESHAPE -TEEXPORT -TLHELP32 -TOOLINTF -TOOLWIN -TYPINFO -URLMON -VCLCOM -VIRTINTF -WEBCONST -WINDOWS -WININET -WINSOCK -WINSPOOL -WINSVC -VARIANTS -TYPES -COLLECTIONS -STRUTILS -RTLCONSTS -CONTNRS -ACCCTRL -ANSISTRINGS -DATEUTILS -VARUTILS -WINTYPES -WINPROCS -ACTNMAN -THEMES -ACLAPI -OLESERVER -Data.DB -Data.DBByteBuffer -Data.DBCommon -Data.DBCommonTypes -Data.DBConsts -Data.FMTBcd -Data.SqlTimSt -Data.Win.ADOConEd -Data.Win.ADOConst -Data.Win.ADODB -Data.Cloud.AmazonAPI.LifeCycle -Data.Cloud.AmazonAPI -Data.Cloud.AzureAPI -Data.Cloud.AzureAPI.StorageAnalytics -Data.Cloud.CloudAPI -Data.Cloud.CloudResStrs -Data.DBConnAdmin -Data.DBXCDSReaders -Data.DBXClassRegistry -Data.DBXClient -Data.DBXClientResStrs -Data.DBXCommon -Data.DBXCommonIndy -Data.DBXCommonResStrs -Data.DBXCommonTable -Data.DbxCompressionFilter -Data.DBXDataExpressMetaDataProvider -Data.DBXDataSets -Data.DBXDBReaders -Data.DBXDelegate -Data.DBXDynalink -Data.DBXDynalinkNative -Data.DBXEncryption -Data.DbxHTTPLayer -Data.DBXInterbase -Data.DBXInterbaseMetaData -Data.DBXInterbaseMetaDataReader -Data.DBXInterbaseMetaDataWriter -Data.DBXInterbaseReadOnlyMetaData -Data.DBXJSON -Data.DBXJSONCommon -Data.DBXJSONReflect -Data.DBXMessageHandlerCommon -Data.DBXMessageHandlerJSonClient -Data.DBXMessageHandlerJSonCommon -Data.DBXMetaDataCommandFactory -Data.DBXMetadataCommon -Data.DBXMetaDataNames -Data.DBXMetaDataProvider -Data.DBXMetaDataReader -Data.DBXMetaDataUtil -Data.DBXMetaDataWriter -Data.DBXMetaDataWriterFactory -Data.DbxMySql -Data.DBXMySqlMetaData -Data.DBXMySqlMetaDataReader -Data.DBXMySqlMetaDataWriter -Data.DBXMySqlReadOnlyMetaData -Data.DBXOpenSSL -Data.DBXOpenSSLRes -Data.DBXPlatform -Data.DBXPool -Data.DbxSocketChannelNative -Data.DbxSqlite -Data.DBXSqliteMetaData -Data.DBXSqliteMetaDataReader -Data.DBXSqliteMetaDataWriter -Data.DBXSqliteReadOnlyMetaData -Data.DbxSqliteResStrs -Data.DBXSqlScanner -Data.DBXStream -Data.DBXStreamPlatform -Data.DBXTableFactory -Data.DBXTrace -Data.DBXTransport -Data.DBXTransportFilter -Data.DBXTypedTableStorage -Data.DSUtil -Data.SqlConst -Data.SqlExpr -Datasnap.DataBkr -Datasnap.DBClient -Datasnap.DSIntf -Datasnap.Midas -Datasnap.MidConst -Datasnap.Provider -Datasnap.Win.MConnect -Datasnap.Win.MidasCon -Datasnap.Win.MtsRdm -Datasnap.Win.ObjBrkr -Datasnap.Win.SConnect -Datasnap.Win.TConnect -Datasnap.Xmlxform -Web.WebReq -FireDAC.Phys -FireDAC.Phys.SQLGenerator -FireDAC.Phys.SQLPreprocessor -REST.Authenticator.Basic -REST.Authenticator.OAuth -REST.Authenticator.OAuth.WebForm.FMX -REST.Authenticator.OAuth.WebForm.Win -REST.Authenticator.Simple -REST.Backend.BindSource -REST.Backend.Consts -REST.Backend.EMSApi -REST.Backend.EMSConsts -REST.Backend.EMSFireDAC -REST.Backend.EMSFireDACConsts -REST.Backend.EMSMetaTypes -REST.Backend.EMSProvider -REST.Backend.EMSPushDevice -REST.Backend.EMSServices -REST.Backend.EndPoint -REST.Backend.Exception -REST.Backend.KinveyApi -REST.Backend.KinveyMetaTypes -REST.Backend.KinveyProvider -REST.Backend.KinveyPushDevice -REST.Backend.KinveyServices -REST.Backend.MetaTypes -REST.Backend.ParseAPI -REST.Backend.ParseMetaTypes -REST.Backend.ParseProvider -REST.Backend.ParsePushDevice -REST.Backend.ParseServices -REST.Backend.Providers -REST.Backend.PushDevice -REST.Backend.PushTypes -REST.Backend.ServiceComponents -REST.Backend.ServiceFactory -REST.Backend.ServiceTypes -REST.BindSource -REST.Client -REST.Consts -REST.Exception -REST.HttpClient -REST.Json.Interceptors -REST.Json -REST.Json.Types -REST.JsonReflect -REST.OpenSSL -REST.Response.Adapter -REST.Types -REST.Utils -Vcl.DBActns -Vcl.DBCGrids -Vcl.DBClientActns -Vcl.DBCtrls -Vcl.DBGrids -Vcl.DBLogDlg -Vcl.DBOleCtl -Vcl.DBPWDlg -Vcl.recerror -Vcl.VDBConsts -Data.Bind.Components -Data.Bind.Consts -Data.Bind.Controls -Data.Bind.DBLinks -Data.Bind.DBScope -Data.Bind.DBXScope -Data.Bind.Editors -Data.Bind.EngExt -Data.Bind.GenData -Data.Bind.Grid -Data.Bind.Json -Data.Bind.ObjectScope -Data.Bind.ObserverLinks -Fmx.Bind.Consts -Fmx.Bind.DBEngExt -Fmx.Bind.DBLinks -Fmx.Bind.Editors -Fmx.Bind.GenData -Fmx.Bind.Grid -Fmx.Bind.Navigator -Vcl.Bind.Consts -Vcl.Bind.DBEngExt -Vcl.Bind.Editors -Vcl.Bind.GenData -Vcl.Bind.Grid -Vcl.Bind.Navigator -System.Bindings.Consts -System.Bindings.CustomScope -System.Bindings.CustomWrapper -System.Bindings.EvalProtocol -System.Bindings.EvalSys -System.Bindings.Evaluator -System.Bindings.Expression -System.Bindings.ExpressionDefaults -System.Bindings.Factories -System.Bindings.Graph -System.Bindings.Helper -System.Bindings.Manager -System.Bindings.ManagerDefaults -System.Bindings.Methods -System.Bindings.NotifierContracts -System.Bindings.NotifierDefaults -System.Bindings.ObjEval -System.Bindings.Outputs -System.Bindings.Search -FMX.AcceleratorKey -FMX.AcceleratorKey.Win -FMX.ActnList -FMX.AddressBook -FMX.AddressBook.Types -FMX.Advertising -FMX.Analytics.AppAnalytics -FMX.Analytics -FMX.Ani -FMX.ASE.Importer -FMX.ASE.Lexer -FMX.ASE.Model -FMX.BehaviorManager -FMX.Calendar -FMX.Calendar.Style -FMX.CalendarEdit -FMX.CalendarEdit.Style -FMX.Canvas.D2D -FMX.Canvas.GDIP -FMX.Canvas.GPU.Helpers -FMX.Canvas.GPU -FMX.Canvas.Mac -FMX.Clipboard.Mac -FMX.Clipboard -FMX.Clipboard.Win -FMX.Colors -FMX.ComboEdit -FMX.ComboEdit.Style -FMX.ComboTrackBar -FMX.ComboTrackBar.Style -FMX.Consts -FMX.Context.DX11 -FMX.Context.DX9 -FMX.Context.GLES -FMX.Context.Mac -FMX.Controls.Mac -FMX.Controls.Model -FMX.Controls.Ole -FMX.Controls -FMX.Controls.Presentation -FMX.Controls.Win -FMX.Controls3D -FMX.DAE.Importer -FMX.DAE.Model -FMX.DAE.Schema -FMX.DateTimeCtrls -FMX.DateTimeCtrls.Types -FMX.DialogHelper -FMX.Dialogs.Android -FMX.Dialogs.Default -FMX.Dialogs.MAC -FMX.Dialogs -FMX.Dialogs.Win -FMX.DialogService.Async -FMX.DialogService -FMX.DialogService.Sync -FMX.Edit -FMX.Edit.Style -FMX.Edit.Win -FMX.EditBox -FMX.EditBox.Style -FMX.Effects -FMX.ExtCtrls -FMX.Filter.Custom -FMX.Filter.Effects -FMX.Filter -FMX.Filter.Standard -FMX.FontGlyphs.Mac -FMX.FontGlyphs -FMX.FontGlyphs.Win -FMX.Forms.Border.Mac -FMX.Forms.Border -FMX.Forms.Border.Win -FMX.Forms -FMX.Forms3D -FMX.Gestures.Mac -FMX.Gestures -FMX.Gestures.Win -FMX.Graphics -FMX.Grid.iOS -FMX.Grid -FMX.Grid.Style -FMX.Header -FMX.Helpers.Mac -FMX.Helpers.Win -FMX.ImgList -FMX.Import -FMX.InAppPurchase -FMX.InertialMovement -FMX.KeyMapping -FMX.Layers3D -FMX.Layouts -FMX.ListBox -FMX.ListBox.Selection -FMX.ListView.Adapters.Base -FMX.ListView.Appearances -FMX.ListView.DynamicAppearance -FMX.ListView -FMX.ListView.Types -FMX.MagnifierGlass -FMX.Maps.Dummy -FMX.Maps -FMX.Materials.Canvas -FMX.Materials -FMX.MaterialSources -FMX.Media.AVFoundation -FMX.Media.Mac -FMX.Media -FMX.Media.Win -FMX.MediaLibrary.Actions -FMX.MediaLibrary -FMX.Memo -FMX.Memo.Style -FMX.Memo.Types -FMX.Memo.Win -FMX.Menus -FMX.MobilePreview -FMX.MultiResBitmap -FMX.MultiTouch -FMX.MultiTouch.Win -FMX.MultiView -FMX.MultiView.Presentations -FMX.MultiView.Types -FMX.MultiView.Types.Style -FMX.NumberBox -FMX.NumberBox.Style -FMX.OBJ.Importer -FMX.OBJ.Model -FMX.Objects -FMX.Objects3D -FMX.PhoneDialer.Actions -FMX.PhoneDialer -FMX.Pickers.Default -FMX.Pickers -FMX.Platform.Common -FMX.Platform.Mac -FMX.Platform -FMX.Platform.Win -FMX.Presentation.Factory -FMX.Presentation.Messages -FMX.Presentation.Style.Common -FMX.Presentation.Style -FMX.Presentation.Win -FMX.Presentation.Win.Style -FMX.Printer.Mac -FMX.Printer -FMX.Printer.Win -FMX.ScrollBox -FMX.ScrollBox.Style -FMX.ScrollBox.Win -FMX.SearchBox -FMX.SearchBox.Style -FMX.SpellChecker.Mac -FMX.SpellChecker -FMX.SpinBox -FMX.SpinBox.Style -FMX.StdActns -FMX.StdCtrls -FMX.StrokeBuilder -FMX.Styles.Objects -FMX.Styles -FMX.Styles.Switch -FMX.Surfaces -FMX.Switch.Style -FMX.Switch.Win -FMX.TabControl -FMX.Text -FMX.TextLayout.GPU -FMX.TextLayout -FMX.TreeView -FMX.Types -FMX.Types3D -FMX.Utils -FMX.Viewport3D -FMX.VirtualKeyboard.iOS -FMX.VirtualKeyboard -FMX.WebBrowser.Cocoa -FMX.WebBrowser.Delegate.Mac -FMX.WebBrowser -FMX.WebBrowser.Win -FMX.WindowsStore -FMX.ZOrder -FMX.ZOrder.Win -IBX.IB -IBX.IBBatchUpdate -IBX.IBBind.Consts -IBX.IBBind -IBX.IBBlob -IBX.IBConnectionBroker -IBX.IBCSMonitor -IBX.IBCustomDataSet -IBX.IBDatabase -IBX.IBDatabaseInfo -IBX.IBDatabaseINI -IBX.IBErrorCodes -IBX.IBEvents -IBX.IBExternals -IBX.IBExtract -IBX.IBFieldHelper -IBX.IBFilterDialog -IBX.IBFilterSummary -IBX.IBHeader -IBX.IBInputOutput -IBX.IBInstall -IBX.IBInstallHeader -IBX.IBIntf -IBX.IBQuery -IBX.IBScript -IBX.IBServices -IBX.IBSQL -IBX.IBSQLMonitor -IBX.IBStoredProc -IBX.IBSubscription -IBX.IBTable -IBX.IBUpdateSQL -IBX.IBUtils -IBX.IBVisualConst -IBX.IBXConst -IBX.IBXMLHeader -Web.ApacheApp -Web.ApacheConst -Web.ApacheHTTP -Web.AutoDisp -Web.BrkrConst -Web.CGIApp -Web.CGIHTTP -Web.CopyPrsr -Web.DBWeb -Web.DBXpressWeb -Web.DSProd -Web.HTTPApp -Web.HTTPD20 -Web.HTTPD20Impl -Web.HTTPD22 -Web.HTTPD22Impl -Web.HTTPD24 -Web.HTTPD24Impl -Web.HTTPDImpl -Web.HTTPDMethods -Web.HTTPParse -Web.HTTPProd -Web.ReqFiles -Web.ReqMulti -Web.UTF8ContentParser -Web.WebBroker -Web.WebConst -Web.WebFileDispatcher -Web.WebReq -Web.Win.AdsConst -Web.Win.AdsTypes -Web.Win.ISAPIApp -Web.Win.IsapiHTTP -Web.Win.ISAPIThreadPool -System.Actions -System.Analytics.AppAnalytics -System.Analytics -System.AnsiStrings -System.Character -System.Classes -System.Contnrs -System.ConvUtils -System.DateUtils -System.Devices -System.Diagnostics -System.Generics.Collections -System.Generics.Defaults -System.Hash -System.HelpIntfs -System.ImageList -System.IniFiles -System.Internal.DebugUtils -System.Internal.ICU -System.IOUtils -System.JSON.BSON -System.JSON.Builders -System.JSON.Converters -System.JSON -System.JSON.Readers -System.JSON.Serializers -System.JSON.Types -System.JSON.Utils -System.JSON.Writers -System.JSONConsts -System.Mac.Devices -System.Mac.Notification -System.Mac.Sensors -System.Masks -System.MaskUtils -System.Math -System.Math.Vectors -System.Messaging -System.NetEncoding -System.Notification -System.ObjAuto -System.Odbc -System.Permissions -System.PushNotification -System.RegularExpressions -System.RegularExpressionsAPI -System.RegularExpressionsConsts -System.RegularExpressionsCore -System.RTLConsts -System.Rtti -System.Sensors.Components -System.Sensors -System.Sqlite -System.StartUpCopy -System.StdConvs -System.StrUtils -System.SyncObjs -System.Threading -System.TimeSpan -System.TypInfo -System.UIConsts -System.UITypes -System.VarCmplx -System.VarConv -System.WideStrings -System.WideStrUtils -System.Win.ComConst -System.Win.ComObj -System.Win.ComObjWrapper -System.Win.ComServ -System.Win.Crtl -System.Win.Devices -System.Win.HighDpi -System.Win.IEInterfaces -System.Win.InternetExplorer -System.Win.Mtsobj -System.Win.Notification -System.Win.ObjComAuto -System.Win.OleControls -System.Win.OleServers -System.Win.Registry -System.Win.ScktComp -System.Win.Sensors -System.Win.ShareContract -System.Win.StdVCL -System.Win.Taskbar -System.Win.TaskbarCore -System.Win.VCLCom -System.Win.WinRT -System.Zip -System.ZLib -System.ZLibConst -System.Beacon.Common -System.Beacon.Components -System.Beacon -System.Bluetooth.Components -System.Bluetooth -System.Mac.Beacon -System.Mac.Bluetooth -System.Net.FileClient -System.Net.HttpClient.Mac -System.Net.HttpClient -System.Net.HttpClient.Win -System.Net.HttpClientComponent -System.Net.Mime -System.Net.Socket -System.Net.URLClient -System.NetConsts -System.Win.Beacon -System.Win.Bluetooth -System.Win.BluetoothWinRT -Macapi.AppKit -Macapi.AVFoundation -Macapi.Bluetooth -Macapi.CocoaTypes -Macapi.Consts -Macapi.CoreFoundation -Macapi.CoreGraphics -Macapi.CoreLocation -Macapi.CoreMedia -Macapi.CoreServices -Macapi.CoreText -Macapi.CoreVideo -Macapi.Dispatch -Macapi.Foundation -Macapi.Helpers -Macapi.ImageCaptureCore -Macapi.ImageIO -Macapi.IOKit -Macapi.JavaScriptCore -Macapi.KeyCodes -Macapi.Mach -Macapi.MapKit -Macapi.ObjCRuntime -Macapi.ObjectiveC -Macapi.OCBlocks -Macapi.OCMarshal -Macapi.OpenGL -Macapi.PrintCore -Macapi.QTKit -Macapi.Quartz -Macapi.QuartzCore -Macapi.Quicktime -Macapi.Security -Macapi.SystemConfiguration -Macapi.VecLib -Macapi.WebKit -System.Mac.CFUtils -Posix.ArpaInet -Posix.Base -Posix.Dirent -Posix.Dlfcn -Posix.Errno -Posix.Fcntl -Posix.Fnmatch -Posix.Grp -Posix.Iconv -Posix.Langinfo -Posix.Limits -Posix.Locale -Posix.NetDB -Posix.NetIf -Posix.NetinetIcmp6 -Posix.NetinetIn -Posix.NetinetIp6 -Posix.NetinetTCP -Posix.NetinetUDP -Posix.Pthread -Posix.Pwd -Posix.Sched -Posix.Semaphore -Posix.Signal -Posix.StdDef -Posix.Stdio -Posix.Stdlib -Posix.String_ -Posix.StrOpts -Posix.SysMman -Posix.SysSelect -Posix.SysSocket -Posix.SysStat -Posix.SysStatvfs -Posix.SysSysctl -Posix.SysTime -Posix.SysTimes -Posix.SysTypes -Posix.SysUio -Posix.SysUn -Posix.SysUtsname -Posix.SysWait -Posix.Termios -Posix.Time -Posix.Unistd -Posix.Utime -Posix.Wchar -Posix.Wctype -Posix.Wordexp -System.Internal.ExcUtils -System.Internal.JSONHlpr -System.Internal.MachExceptions -System.Internal.StrHlpr -System.Internal.Unwind -System.Internal.Unwinder -System.Internal.VarHlpr -System.Sharemem -System.SimpleShareMem -System.SysConst -System.SysUtils -System.Types -System.Variants -System.VarUtils -Winapi.AccCtrl -Winapi.AclAPI -Winapi.ActiveX -Winapi.ADOInt -Winapi.AspTlb -Winapi.Bluetooth -Winapi.BluetoothLE -Winapi.COMAdmin -Winapi.CommCtrl -Winapi.CommDlg -Winapi.ComSvcs -Winapi.Cor -Winapi.CorError -Winapi.CorHdr -Winapi.Cpl -Winapi.D2D1 -Winapi.D3D10 -Winapi.D3D10_1 -Winapi.D3D11 -Winapi.D3D11on12 -Winapi.D3D11sdklayers -Winapi.D3D11Shader -Winapi.D3D11Shadertracing -Winapi.D3D11_1 -Winapi.D3D11_2 -Winapi.D3D11_3 -Winapi.D3D12 -Winapi.D3D12sdklayers -Winapi.D3D12Shader -Winapi.D3DCommon -Winapi.D3DCompiler -Winapi.D3DX10 -Winapi.D3DX8 -Winapi.D3DX9 -Winapi.DDEml -Winapi.Direct3D -Winapi.Direct3D8 -Winapi.Direct3D9 -Winapi.DirectDraw -Winapi.DirectInput -Winapi.DirectMusic -Winapi.DirectPlay8 -Winapi.DirectShow9 -Winapi.DirectSound -Winapi.Dlgs -Winapi.DwmApi -Winapi.DX7toDX8 -Winapi.DxDiag -Winapi.DXFile -Winapi.DXGI -Winapi.DXGI1_2 -Winapi.DXGI1_3 -Winapi.DXGI1_4 -Winapi.DxgiFormat -Winapi.DxgiType -Winapi.DXTypes -Winapi.FlatSB -Winapi.Functiondiscovery -Winapi.GDIPAPI -Winapi.GDIPOBJ -Winapi.GDIPUTIL -Winapi.ImageHlp -Winapi.Imm -Winapi.IpExport -Winapi.IpHlpApi -Winapi.IpRtrMib -Winapi.IpTypes -Winapi.Isapi -Winapi.Isapi2 -Winapi.KnownFolders -Winapi.Locationapi -Winapi.LZExpand -Winapi.Manipulations -Winapi.Mapi -Winapi.Messages -Winapi.MLang -Winapi.MMSystem -Winapi.MsCTF -Winapi.Mshtmhst -Winapi.MsInkAut -Winapi.MsInkAut15 -Winapi.msxml -Winapi.msxmlIntf -Winapi.Mtx -Winapi.MultiMon -Winapi.Nb30 -Winapi.ObjectArray -Winapi.Ole2 -Winapi.oleacc -Winapi.OleCtl -Winapi.OleDB -Winapi.OleDlg -Winapi.OpenGL -Winapi.OpenGLext -Winapi.PenInputPanel -Winapi.Penwin -Winapi.Portabledevicetypes -Winapi.PropKey -Winapi.PropSys -Winapi.PsAPI -Winapi.Qos -Winapi.RegStr -Winapi.RichEdit -Winapi.RtsCom -Winapi.Sensors -Winapi.Sensorsapi -Winapi.ShellAPI -Winapi.ShellScaling -Winapi.SHFolder -Winapi.ShlObj -Winapi.ShLwApi -Winapi.StructuredQuery -Winapi.StructuredQueryCondition -Winapi.TlHelp32 -Winapi.TpcShrd -Winapi.UrlMon -Winapi.UserEnv -Winapi.UxTheme -Winapi.Wbem -Winapi.Wincodec -Winapi.Windows -Winapi.WinHTTP -Winapi.WinInet -Winapi.Winrt -Winapi.WinrtMetadata -Winapi.Winsafer -Winapi.WinSock -Winapi.Winsock2 -Winapi.WinSpool -Winapi.WinSvc -Winapi.WMF9 -WinAPI.ApplicationModel.Background -Winapi.ApplicationModel.Contacts -WinAPI.ApplicationModel.Core -WinAPI.ApplicationModel.DataTransfer -WinAPI.ApplicationModel -Winapi.CommonNames -WinAPI.CommonTypes -WinAPI.DataRT -Winapi.Devices.AllJoyn -Winapi.Devices.Bluetooth.Advertisement -WinAPI.Devices.Bluetooth -WinAPI.Devices.Enumeration -Winapi.Devices.Geolocation -Winapi.Devices.Midi -WinAPI.Devices -Winapi.Devices.PointOfService -Winapi.Devices.Scanners -Winapi.Devices.Sensors -Winapi.Devices.Sms -WinAPI.Foundation.Collections -WinAPI.Foundation -WinAPI.Foundation.Types -WinAPI.Gaming -WinAPI.Globalization -WinAPI.GraphicsRT -WinAPI.HSTRINGIterables -WinAPI.Management -Winapi.Media.Devices -Winapi.Media.MediaProperties -WinAPI.Media -WinAPI.Networking.Connectivity -WinAPI.Networking.NetworkOperators -WinAPI.Networking -WinAPI.Networking.Proximity -Winapi.Networking.PushNotifications -WinAPI.Networking.Sockets -WinAPI.Networking.Vpn -Winapi.Perception -WinAPI.Security.Credentials -WinAPI.Security.Cryptography -WinAPI.Security -Winapi.ServicesRT -Winapi.ServicesRT.Store -WinAPI.Storage -WinAPI.Storage.Streams -WinAPI.SystemRT -WinAPI.UI.Composition -WinAPI.UI.Core -WinAPI.UI.Input.Inking -WinAPI.UI.Input -WinAPI.UI.Notifications -WinAPI.UI -WinAPI.UI.Text -WinAPI.UI.ViewManagement -WinAPI.UI.WebUI -WinAPI.UI.Xaml -WinAPI.WebRT -WinAPI.WindowsStore -WinAPI.WinRT.Utils -Soap.EncdDecd -Soap.HTTPSOAPToPasBind -Soap.HTTPUtil -Soap.inquire_v1 -Soap.IntfInfo -Soap.InvConst -Soap.Invoker -Soap.InvokeRegistry -Soap.OPConvert -Soap.OpConvertOptions -Soap.OPToSOAPDomConv -Soap.OPToSOAPDomCustom -Soap.Rio -Soap.SOAPAttach -Soap.SOAPAttachIntf -Soap.SOAPConn -Soap.SOAPConst -Soap.SOAPDm -Soap.SOAPDomConv -Soap.SOAPEnv -Soap.SOAPHTTPClient -Soap.SOAPHTTPDisp -Soap.SOAPHTTPPasInv -Soap.SOAPHTTPTrans -Soap.SOAPLinked -Soap.SOAPMidas -Soap.SOAPPasInv -Soap.TypeTrans -Soap.UDDIHelper -Soap.WebBrokerSOAP -Soap.WebNode -Soap.WebServExp -Soap.Win.CertHelper -Soap.WSDLBind -Soap.WSDLIntf -Soap.WSDLItems -Soap.WSDLLookup -Soap.WSDLNode -Soap.WSDLPub -Soap.WSDLSOAP -Soap.WSILIntf -Soap.XSBuiltIns -System.Tether.AppProfile -System.Tether.BluetoothAdapter -System.Tether.Comm -System.Tether.Consts -System.Tether.Manager -System.Tether.NetworkAdapter -System.Tether.TCPProtocol -Vcl.ABAccessibility -Vcl.ActnColorMaps -Vcl.ActnCtrls -Vcl.ActnList -Vcl.ActnMan -Vcl.ActnMenus -Vcl.ActnPopup -Vcl.AppEvnts -Vcl.AxCtrls -Vcl.BandActn -Vcl.BaseImageCollection -Vcl.ButtonGroup -Vcl.Buttons -Vcl.CaptionedDockTree -Vcl.CategoryButtons -Vcl.CheckLst -Vcl.Clipbrd -Vcl.CmAdmCtl -Vcl.ColorGrd -Vcl.ComCtrls -Vcl.ComStrs -Vcl.Consts -Vcl.Controls -Vcl.CustomizeDlg -Vcl.DdeMan -Vcl.Dialogs -Vcl.Direct2D -Vcl.DockTabSet -Vcl.ExtActns -Vcl.ExtCtrls -Vcl.ExtDlgs -Vcl.FileCtrl -Vcl.Forms -Vcl.Graphics -Vcl.GraphUtil -Vcl.Grids -Vcl.HtmlHelpViewer -Vcl.ImageCollection -Vcl.Imaging.GIFConsts -Vcl.Imaging.GIFImg -Vcl.Imaging.JConsts -Vcl.Imaging.jpeg -Vcl.Imaging.pngimage -Vcl.Imaging.pnglang -Vcl.ImgList -Vcl.IMouse -Vcl.JumpList -Vcl.ListActns -Vcl.Mask -Vcl.Menus -Vcl.MPlayer -Vcl.OleAuto -Vcl.OleConst -Vcl.OleCtnrs -Vcl.OleCtrls -Vcl.OleServer -Vcl.Outline -Vcl.PlatformDefaultStyleActnCtrls -Vcl.Printers -Vcl.Samples.Calendar -Vcl.Samples.DirOutln -Vcl.Samples.Gauges -Vcl.Samples.Spin -Vcl.ScreenTips -Vcl.ShadowWnd -Vcl.ShareContract -Vcl.Shell.ShellConsts -Vcl.Shell.ShellCtrls -Vcl.ShellAnimations -Vcl.StdActnMenus -Vcl.StdActns -Vcl.StdCtrls -Vcl.StdStyleActnCtrls -Vcl.Styles -Vcl.SvcMgr -Vcl.SysStyles -Vcl.TabNotBk -Vcl.Tabs -Vcl.Taskbar -Vcl.ThemedActnCtrls -Vcl.Themes -Vcl.ToolWin -Vcl.Touch.GestureConsts -Vcl.Touch.GestureCtrls -Vcl.Touch.GestureMgr -Vcl.Touch.Gestures -Vcl.Touch.Keyboard -Vcl.Touch.KeyboardTypes -Vcl.ValEdit -Vcl.VirtualImageList -Vcl.WindowsStore -Vcl.WinHelpViewer -Vcl.WinXCalendars -Vcl.WinXCtrls -Vcl.WinXPanels -Vcl.WinXPickers -Vcl.XPActnCtrls -Vcl.XPMan -Vcl.XPStyleActnCtrls -Xml.adomxmldom -Xml.DTDSchema -Xml.Internal.AbnfUtils -Xml.Internal.AdomCore_4_3 -Xml.Internal.CodecUtilsWin32 -Xml.Internal.EncodingUtils -Xml.Internal.LangUtils -Xml.Internal.OBufferedStreams -Xml.Internal.OmniXML -Xml.Internal.OmniXMLXPath -Xml.Internal.OTextReadWrite -Xml.Internal.ParserUtilsWin32 -Xml.Internal.TreeUtils -Xml.Internal.UriUtils -Xml.Internal.WideStringUtils -Xml.Internal.XmlRulesUtils -Xml.omnixmldom -Xml.Win.msxmldom -Xml.XDRSchema -Xml.XMLConst -Xml.XMLDataToSchema -Xml.XMLDoc -Xml.xmldom -Xml.XMLIniFile -Xml.XMLIntf -Xml.XMLSchema -Xml.XMLSchema99 -Xml.XMLSchemaTags -Xml.XmlTransform -Xml.xmlutil \ No newline at end of file diff --git a/include/GpProfDllClient.pas b/include/GpProfDllClient.pas new file mode 100644 index 0000000..d00414d --- /dev/null +++ b/include/GpProfDllClient.pas @@ -0,0 +1,351 @@ +{$R-,C-,Q-,O+,H+} + +(* + GpProfile DLL client — dynamic accessor for GpProfDll.dll. + + Provides an object-oriented interface to the shared profiling DLL. + Obtain a context via AcquireGpProfContext and use the returned + IGpProfContext interface to drive all profiling calls. + + Usage + ----- + Add GpProfDllClient to your uses clause. + Ensure GpProfDll32.dll / GpProfDll64.dll is present at run time. + If the DLL is not found, AcquireGpProfContext returns nil and every + method call is a safe no-op. + + var Ctx: IGpProfContext; + Ctx := AcquireGpProfContext; + if Assigned(Ctx) then Ctx.Start; + ... + DisposeGpProfContext(Ctx); // or simply: Ctx := nil + + Loading / unloading + ------------------- + LoadLibrary is called in the unit initialization section. + FreeLibrary is called in the unit finalization section. + All function pointers are checked for Assigned before use, so the + unit is safe when GpProfDll.dll is absent. +*) + +unit GpProfDllClient; + +interface + +{$WARN SYMBOL_PLATFORM OFF} +{$WARN SYMBOL_DEPRECATED OFF} + +{$IF CompilerVersion > 19} + {$DEFINE HAS_NAME_THREAD_FOR_DEBUGGING} + {$DEFINE HAS_THREAD_ID_TYPE} +{$IFEND} + +{$IFNDEF HAS_THREAD_ID_TYPE} +type + TThreadID = Cardinal; +{$ENDIF} + +type + /// + /// Marker interface for a measure point scope. + /// Upon destruction, ProfilerExitMP is called through the DLL. + /// + IMeasurePointScope = interface + ['{9F2A8B7C-1D3E-4F5A-8C6B-7E9D0A2B4C5F}'] + end; + + /// + /// Object-oriented handle to the shared profiling context exposed by the DLL. + /// Mirrors the old per-module state that every statically-linked GpProf unit + /// used to own. Acquire one per module via AcquireGpProfContext; release it + /// by setting the variable to nil (reference-counted) or calling DisposeGpProfContext. + /// + IGpProfContext = interface + ['{B2C3D4E5-F6A7-8B9C-0D1E-2F3A4B5C6D7E}'] + procedure Start; + procedure Stop; + procedure StartThread; + procedure EnterProc(const aProcID: Cardinal); + procedure ExitProc(const aProcID: Cardinal); + procedure EnterMP(const aMeasurePointId: UTF8String); + procedure ExitMP(const aMeasurePointId: UTF8String); + function CreateMeasurePointScope(const aMeasurePointId: string): IMeasurePointScope; + procedure Terminate; +{$IFDEF UNICODE} + procedure NameThread(const AThreadName: AnsiString; AThreadID: TThreadID); overload; + procedure NameThread(const AThreadName: string; AThreadID: TThreadID); overload; +{$ELSE} + procedure NameThread(const AThreadName: string; AThreadID: TThreadID); +{$ENDIF} + end; + +/// +/// Acquires a new IGpProfContext handle for the calling module. +/// Notifies the DLL that a client session has been opened (DllAcquireSession). +/// Release by setting the returned interface to nil, which calls DllReleaseSession. +/// Returns nil when the DLL could not be loaded. +/// +function AcquireGpProfContext: IGpProfContext; + +/// +/// Convenience wrapper: sets Ctx to nil, which triggers reference-counted +/// destruction and calls DllReleaseSession in the DLL. +/// +procedure DisposeGpProfContext(var Ctx: IGpProfContext); + +implementation + +uses + Windows, + SysUtils; + +// --------------------------------------------------------------------------- +// DLL function-pointer types. +// No explicit calling convention is declared here so that Delphi uses the +// same default 'register' convention that GpProf.pas / GpProfDll.dll use. +// --------------------------------------------------------------------------- + +type + TProcNoArgs = procedure; + TProcCardinal = procedure(const aProcID: Cardinal); + TProcUTF8Str = procedure(const aMeasurePointId: UTF8String); + TProcTerminate = procedure; +{$IFDEF UNICODE} + TProcNameThreadA = procedure(const AThreadName: AnsiString; AThreadID: TThreadID); + TProcNameThreadW = procedure(const AThreadName: string; AThreadID: TThreadID); +{$ELSE} + TProcNameThreadW = procedure(const AThreadName: string; AThreadID: TThreadID); +{$ENDIF} + TFnAcquireSession = function: Pointer; + TProcReleaseSession = procedure(session: Pointer); + +var + GpProfDllHandle : HMODULE = 0; + _ProfilerStart : TProcNoArgs = nil; + _ProfilerStop : TProcNoArgs = nil; + _ProfilerStartThread: TProcNoArgs = nil; + _ProfilerEnterProc : TProcCardinal = nil; + _ProfilerExitProc : TProcCardinal = nil; + _ProfilerEnterMP : TProcUTF8Str = nil; + _ProfilerExitMP : TProcUTF8Str = nil; + _ProfilerTerminate : TProcTerminate = nil; +{$IFDEF UNICODE} + _NameThreadForDebuggingA: TProcNameThreadA = nil; +{$ENDIF} + _NameThreadForDebuggingW: TProcNameThreadW = nil; + _DllAcquireSession : TFnAcquireSession = nil; + _DllReleaseSession : TProcReleaseSession = nil; + +// --------------------------------------------------------------------------- +// Client-side scope adapter — no COM interface reference crosses the DLL boundary. +// ProfilerEnterMP is called by CreateMeasurePointScope before creating the +// scope object; ProfilerExitMP is called in the destructor. +// --------------------------------------------------------------------------- + +type + TMeasurePointScopeClient = class(TInterfacedObject, IMeasurePointScope) + private + fMeasurePointId: UTF8String; + public + constructor Create(const aMeasurePointId: UTF8String); + destructor Destroy; override; + end; + +constructor TMeasurePointScopeClient.Create(const aMeasurePointId: UTF8String); +begin + fMeasurePointId := aMeasurePointId; +end; + +destructor TMeasurePointScopeClient.Destroy; +begin + if Assigned(_ProfilerExitMP) then _ProfilerExitMP(fMeasurePointId); + inherited; +end; + +// --------------------------------------------------------------------------- +// TGpProfContextClient — object-oriented wrapper around the DLL function +// pointers. One instance per module (obtained via AcquireGpProfContext). +// Holds an opaque session token returned by DllAcquireSession; releases it +// in the destructor via DllReleaseSession, notifying the DLL. +// --------------------------------------------------------------------------- + +type + TGpProfContextClient = class(TInterfacedObject, IGpProfContext) + private + fSessionToken: Pointer; + public + constructor Create; + destructor Destroy; override; + procedure Start; + procedure Stop; + procedure StartThread; + procedure EnterProc(const aProcID: Cardinal); + procedure ExitProc(const aProcID: Cardinal); + procedure EnterMP(const aMeasurePointId: UTF8String); + procedure ExitMP(const aMeasurePointId: UTF8String); + function CreateMeasurePointScope(const aMeasurePointId: string): IMeasurePointScope; + procedure Terminate; +{$IFDEF UNICODE} + procedure NameThread(const AThreadName: AnsiString; AThreadID: TThreadID); overload; + procedure NameThread(const AThreadName: string; AThreadID: TThreadID); overload; +{$ELSE} + procedure NameThread(const AThreadName: string; AThreadID: TThreadID); +{$ENDIF} + end; + +constructor TGpProfContextClient.Create; +begin + if Assigned(_DllAcquireSession) then + fSessionToken := _DllAcquireSession() + else + fSessionToken := nil; +end; + +destructor TGpProfContextClient.Destroy; +begin + if Assigned(_DllReleaseSession) and (fSessionToken <> nil) then + _DllReleaseSession(fSessionToken); + fSessionToken := nil; + inherited; +end; + +procedure TGpProfContextClient.Start; +begin + if Assigned(_ProfilerStart) then _ProfilerStart; +end; + +procedure TGpProfContextClient.Stop; +begin + if Assigned(_ProfilerStop) then _ProfilerStop; +end; + +procedure TGpProfContextClient.StartThread; +begin + if Assigned(_ProfilerStartThread) then _ProfilerStartThread; +end; + +procedure TGpProfContextClient.EnterProc(const aProcID: Cardinal); +begin + if Assigned(_ProfilerEnterProc) then _ProfilerEnterProc(aProcID); +end; + +procedure TGpProfContextClient.ExitProc(const aProcID: Cardinal); +begin + if Assigned(_ProfilerExitProc) then _ProfilerExitProc(aProcID); +end; + +procedure TGpProfContextClient.EnterMP(const aMeasurePointId: UTF8String); +begin + if Assigned(_ProfilerEnterMP) then _ProfilerEnterMP(aMeasurePointId); +end; + +procedure TGpProfContextClient.ExitMP(const aMeasurePointId: UTF8String); +begin + if Assigned(_ProfilerExitMP) then _ProfilerExitMP(aMeasurePointId); +end; + +function TGpProfContextClient.CreateMeasurePointScope(const aMeasurePointId: string): IMeasurePointScope; +begin + if Assigned(_ProfilerEnterMP) then _ProfilerEnterMP(UTF8String(aMeasurePointId)); + Result := TMeasurePointScopeClient.Create(UTF8String(aMeasurePointId)); +end; + +procedure TGpProfContextClient.Terminate; +begin + if Assigned(_ProfilerTerminate) then _ProfilerTerminate; +end; + +{$IFDEF UNICODE} +procedure TGpProfContextClient.NameThread(const AThreadName: AnsiString; AThreadID: TThreadID); +begin + if Assigned(_NameThreadForDebuggingA) then _NameThreadForDebuggingA(AThreadName, AThreadID); +end; + +procedure TGpProfContextClient.NameThread(const AThreadName: string; AThreadID: TThreadID); +begin + if Assigned(_NameThreadForDebuggingW) then _NameThreadForDebuggingW(AThreadName, AThreadID); +end; +{$ELSE} +procedure TGpProfContextClient.NameThread(const AThreadName: string; AThreadID: TThreadID); +begin + if Assigned(_NameThreadForDebuggingW) then _NameThreadForDebuggingW(AThreadName, AThreadID); +end; +{$ENDIF} + +// --------------------------------------------------------------------------- +// AcquireGpProfContext / DisposeGpProfContext +// --------------------------------------------------------------------------- + +function AcquireGpProfContext: IGpProfContext; +begin + if GpProfDllHandle = 0 then + Result := nil + else + Result := TGpProfContextClient.Create; +end; + +procedure DisposeGpProfContext(var Ctx: IGpProfContext); +begin + Ctx := nil; +end; + +// --------------------------------------------------------------------------- +// DLL lifecycle +// --------------------------------------------------------------------------- + +const +{$IFDEF WIN64} + GPPROFLIB = 'GpProfDll64.dll'; +{$ELSE} + GPPROFLIB = 'GpProfDll32.dll'; +{$ENDIF} + +procedure LoadGpProfDll; +begin + GpProfDllHandle := LoadLibrary(GPPROFLIB); + if GpProfDllHandle = 0 then Exit; + + _ProfilerStart := GetProcAddress(GpProfDllHandle, 'ProfilerStart'); + _ProfilerStop := GetProcAddress(GpProfDllHandle, 'ProfilerStop'); + _ProfilerStartThread := GetProcAddress(GpProfDllHandle, 'ProfilerStartThread'); + _ProfilerEnterProc := GetProcAddress(GpProfDllHandle, 'ProfilerEnterProc'); + _ProfilerExitProc := GetProcAddress(GpProfDllHandle, 'ProfilerExitProc'); + _ProfilerEnterMP := GetProcAddress(GpProfDllHandle, 'ProfilerEnterMP'); + _ProfilerExitMP := GetProcAddress(GpProfDllHandle, 'ProfilerExitMP'); + _ProfilerTerminate := GetProcAddress(GpProfDllHandle, 'ProfilerTerminate'); +{$IFDEF UNICODE} + _NameThreadForDebuggingA := GetProcAddress(GpProfDllHandle, 'NameThreadForDebuggingA'); +{$ENDIF} + _NameThreadForDebuggingW := GetProcAddress(GpProfDllHandle, 'NameThreadForDebuggingW'); + _DllAcquireSession := GetProcAddress(GpProfDllHandle, 'DllAcquireSession'); + _DllReleaseSession := GetProcAddress(GpProfDllHandle, 'DllReleaseSession'); +end; + +procedure UnloadGpProfDll; +begin + if GpProfDllHandle = 0 then Exit; + FreeLibrary(GpProfDllHandle); + GpProfDllHandle := 0; + _ProfilerStart := nil; + _ProfilerStop := nil; + _ProfilerStartThread := nil; + _ProfilerEnterProc := nil; + _ProfilerExitProc := nil; + _ProfilerEnterMP := nil; + _ProfilerExitMP := nil; + _ProfilerTerminate := nil; +{$IFDEF UNICODE} + _NameThreadForDebuggingA := nil; +{$ENDIF} + _NameThreadForDebuggingW := nil; + _DllAcquireSession := nil; + _DllReleaseSession := nil; +end; + +initialization + LoadGpProfDll; + +finalization + UnloadGpProfDll; + +end. diff --git a/source/HISTORY.INC b/source/GpProf.UI/HISTORY.INC similarity index 100% rename from source/HISTORY.INC rename to source/GpProf.UI/HISTORY.INC diff --git a/source/OPTIONS.INC b/source/GpProf.UI/OPTIONS.INC similarity index 100% rename from source/OPTIONS.INC rename to source/GpProf.UI/OPTIONS.INC diff --git a/source/baggage.inc b/source/GpProf.UI/baggage.inc similarity index 100% rename from source/baggage.inc rename to source/GpProf.UI/baggage.inc diff --git a/source/gpprof.dpr b/source/GpProf.UI/gpprof.dpr similarity index 100% rename from source/gpprof.dpr rename to source/GpProf.UI/gpprof.dpr diff --git a/source/gpprof.dproj b/source/GpProf.UI/gpprof.dproj similarity index 96% rename from source/gpprof.dproj rename to source/GpProf.UI/gpprof.dproj index 9f4638e..6353552 100644 --- a/source/gpprof.dproj +++ b/source/GpProf.UI/gpprof.dproj @@ -64,7 +64,7 @@ ..\dcu\$(Platform)-$(Config) ..\bin - ..\include;..\lib\SynEdit\Source;..\lib\SynEdit\Source\Highlighters;..\lib\VirtualTreeView\Source;..\GPComponents\GPNative\source;.\model\sourceCodeAnalysis\Castalia;$(DCC_UnitSearchPath) + ..\..\include;..\..\lib\SynEdit\Source;..\..\lib\SynEdit\Source\Highlighters;..\..\lib\VirtualTreeView\Source;..\..\GPComponents\GPNative\source;..\model\sourceCodeAnalysis\Castalia;$(DCC_UnitSearchPath) Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace) 1033 6 @@ -269,14 +269,14 @@
frmPreferenceMacros
dfm - -
fmSimpleReport
- dfm -
fmUnitWizard
 + +
fmSimpleReport
+ dfm + diff --git a/source/gpprof_Icon.ico b/source/GpProf.UI/gpprof_Icon.ico similarity index 100% rename from source/gpprof_Icon.ico rename to source/GpProf.UI/gpprof_Icon.ico diff --git a/source/help.inc b/source/GpProf.UI/help.inc similarity index 100% rename from source/help.inc rename to source/GpProf.UI/help.inc diff --git a/source/icons/icons8-speedometer-24.ico b/source/GpProf.UI/icons/icons8-speedometer-24.ico similarity index 100% rename from source/icons/icons8-speedometer-24.ico rename to source/GpProf.UI/icons/icons8-speedometer-24.ico diff --git a/source/icons/instrument-open-24.ico b/source/GpProf.UI/icons/instrument-open-24.ico similarity index 100% rename from source/icons/instrument-open-24.ico rename to source/GpProf.UI/icons/instrument-open-24.ico diff --git a/source/icons/instrument-run-24.ico b/source/GpProf.UI/icons/instrument-run-24.ico similarity index 100% rename from source/icons/instrument-run-24.ico rename to source/GpProf.UI/icons/instrument-run-24.ico diff --git a/source/icons/instrument_add-24.ico b/source/GpProf.UI/icons/instrument_add-24.ico similarity index 100% rename from source/icons/instrument_add-24.ico rename to source/GpProf.UI/icons/instrument_add-24.ico diff --git a/source/icons/instrument_load-selection-24.ico b/source/GpProf.UI/icons/instrument_load-selection-24.ico similarity index 100% rename from source/icons/instrument_load-selection-24.ico rename to source/GpProf.UI/icons/instrument_load-selection-24.ico diff --git a/source/icons/instrument_options-24.ico b/source/GpProf.UI/icons/instrument_options-24.ico similarity index 100% rename from source/icons/instrument_options-24.ico rename to source/GpProf.UI/icons/instrument_options-24.ico diff --git a/source/icons/instrument_reload-24.ico b/source/GpProf.UI/icons/instrument_reload-24.ico similarity index 100% rename from source/icons/instrument_reload-24.ico rename to source/GpProf.UI/icons/instrument_reload-24.ico diff --git a/source/icons/instrument_remove-24.ico b/source/GpProf.UI/icons/instrument_remove-24.ico similarity index 100% rename from source/icons/instrument_remove-24.ico rename to source/GpProf.UI/icons/instrument_remove-24.ico diff --git a/source/icons/instrument_run-24.ico b/source/GpProf.UI/icons/instrument_run-24.ico similarity index 100% rename from source/icons/instrument_run-24.ico rename to source/GpProf.UI/icons/instrument_run-24.ico diff --git a/source/icons/instrument_save-selection-24.ico b/source/GpProf.UI/icons/instrument_save-selection-24.ico similarity index 100% rename from source/icons/instrument_save-selection-24.ico rename to source/GpProf.UI/icons/instrument_save-selection-24.ico diff --git a/source/icons/results-copy-24.ico b/source/GpProf.UI/icons/results-copy-24.ico similarity index 100% rename from source/icons/results-copy-24.ico rename to source/GpProf.UI/icons/results-copy-24.ico diff --git a/source/icons/results-delete-24.ico b/source/GpProf.UI/icons/results-delete-24.ico similarity index 100% rename from source/icons/results-delete-24.ico rename to source/GpProf.UI/icons/results-delete-24.ico diff --git a/source/icons/results-export-24.ico b/source/GpProf.UI/icons/results-export-24.ico similarity index 100% rename from source/icons/results-export-24.ico rename to source/GpProf.UI/icons/results-export-24.ico diff --git a/source/icons/results-move-24.ico b/source/GpProf.UI/icons/results-move-24.ico similarity index 100% rename from source/icons/results-move-24.ico rename to source/GpProf.UI/icons/results-move-24.ico diff --git a/source/icons/results-open-24.ico b/source/GpProf.UI/icons/results-open-24.ico similarity index 100% rename from source/icons/results-open-24.ico rename to source/GpProf.UI/icons/results-open-24.ico diff --git a/source/icons/results-options-24.ico b/source/GpProf.UI/icons/results-options-24.ico similarity index 100% rename from source/icons/results-options-24.ico rename to source/GpProf.UI/icons/results-options-24.ico diff --git a/source/icons/results-options-memory.ico b/source/GpProf.UI/icons/results-options-memory.ico similarity index 100% rename from source/icons/results-options-memory.ico rename to source/GpProf.UI/icons/results-options-memory.ico diff --git a/source/icons/results-rescan-24.ico b/source/GpProf.UI/icons/results-rescan-24.ico similarity index 100% rename from source/icons/results-rescan-24.ico rename to source/GpProf.UI/icons/results-rescan-24.ico diff --git a/source/model/GpHugeF.pas b/source/GpProf.UI/model/GpHugeF.pas similarity index 100% rename from source/model/GpHugeF.pas rename to source/GpProf.UI/model/GpHugeF.pas diff --git a/source/model/GpRegistry.pas b/source/GpProf.UI/model/GpRegistry.pas similarity index 100% rename from source/model/GpRegistry.pas rename to source/GpProf.UI/model/GpRegistry.pas diff --git a/source/model/GpVersion.pas b/source/GpProf.UI/model/GpVersion.pas similarity index 100% rename from source/model/GpVersion.pas rename to source/GpProf.UI/model/GpVersion.pas diff --git a/source/model/gpFileEdit.pas b/source/GpProf.UI/model/gpFileEdit.pas similarity index 100% rename from source/model/gpFileEdit.pas rename to source/GpProf.UI/model/gpFileEdit.pas diff --git a/source/model/gpiff.pas b/source/GpProf.UI/model/gpiff.pas similarity index 100% rename from source/model/gpiff.pas rename to source/GpProf.UI/model/gpiff.pas diff --git a/source/model/gppCurrentPrefs.pas b/source/GpProf.UI/model/gppCurrentPrefs.pas similarity index 100% rename from source/model/gppCurrentPrefs.pas rename to source/GpProf.UI/model/gppCurrentPrefs.pas diff --git a/source/model/gppIDT.pas b/source/GpProf.UI/model/gppIDT.pas similarity index 100% rename from source/model/gppIDT.pas rename to source/GpProf.UI/model/gppIDT.pas diff --git a/source/model/gppTree.pas b/source/GpProf.UI/model/gppTree.pas similarity index 100% rename from source/model/gppTree.pas rename to source/GpProf.UI/model/gppTree.pas diff --git a/source/model/gppcommon.pas b/source/GpProf.UI/model/gppcommon.pas similarity index 100% rename from source/model/gppcommon.pas rename to source/GpProf.UI/model/gppcommon.pas diff --git a/source/model/profilingResultParser/gppResult.measurePointRegistry.pas b/source/GpProf.UI/model/profilingResultParser/gppResult.measurePointRegistry.pas similarity index 100% rename from source/model/profilingResultParser/gppResult.measurePointRegistry.pas rename to source/GpProf.UI/model/profilingResultParser/gppResult.measurePointRegistry.pas diff --git a/source/model/profilingResultParser/gppResults.callGraph.pas b/source/GpProf.UI/model/profilingResultParser/gppResults.callGraph.pas similarity index 100% rename from source/model/profilingResultParser/gppResults.callGraph.pas rename to source/GpProf.UI/model/profilingResultParser/gppResults.callGraph.pas diff --git a/source/model/profilingResultParser/gppResults.procs.pas b/source/GpProf.UI/model/profilingResultParser/gppResults.procs.pas similarity index 100% rename from source/model/profilingResultParser/gppResults.procs.pas rename to source/GpProf.UI/model/profilingResultParser/gppResults.procs.pas diff --git a/source/model/profilingResultParser/gppResults.types.pas b/source/GpProf.UI/model/profilingResultParser/gppResults.types.pas similarity index 100% rename from source/model/profilingResultParser/gppResults.types.pas rename to source/GpProf.UI/model/profilingResultParser/gppResults.types.pas diff --git a/source/model/profilingResultParser/gppresults.pas b/source/GpProf.UI/model/profilingResultParser/gppresults.pas similarity index 100% rename from source/model/profilingResultParser/gppresults.pas rename to source/GpProf.UI/model/profilingResultParser/gppresults.pas diff --git a/source/model/sourceCodeAnalysis/gpParser.API.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpParser.API.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpParser.API.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpParser.API.pas diff --git a/source/model/sourceCodeAnalysis/gpParser.BaseProject.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpParser.BaseProject.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpParser.BaseProject.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpParser.BaseProject.pas diff --git a/source/model/sourceCodeAnalysis/gpParser.Defines.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpParser.Defines.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpParser.Defines.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpParser.Defines.pas diff --git a/source/model/sourceCodeAnalysis/gpParser.Procs.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpParser.Procs.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpParser.Procs.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpParser.Procs.pas diff --git a/source/model/sourceCodeAnalysis/gpParser.Selections.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpParser.Selections.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpParser.Selections.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpParser.Selections.pas diff --git a/source/model/sourceCodeAnalysis/gpParser.TextReplacer.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpParser.TextReplacer.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpParser.TextReplacer.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpParser.TextReplacer.pas diff --git a/source/model/sourceCodeAnalysis/gpParser.Types.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpParser.Types.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpParser.Types.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpParser.Types.pas diff --git a/source/model/sourceCodeAnalysis/gpParser.Units.ParserStack.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpParser.Units.ParserStack.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpParser.Units.ParserStack.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpParser.Units.ParserStack.pas diff --git a/source/model/sourceCodeAnalysis/gpParser.Units.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpParser.Units.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpParser.Units.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpParser.Units.pas diff --git a/source/model/sourceCodeAnalysis/gpParser.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpParser.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpParser.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpParser.pas diff --git a/source/model/sourceCodeAnalysis/gpProf.BdsProjReader.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpProf.BdsProjReader.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpProf.BdsProjReader.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpProf.BdsProjReader.pas diff --git a/source/model/sourceCodeAnalysis/gpProf.DProjReader.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpProf.DProjReader.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpProf.DProjReader.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpProf.DProjReader.pas diff --git a/source/model/sourceCodeAnalysis/gpProf.Delphi.RegistryAccessor.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpProf.Delphi.RegistryAccessor.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpProf.Delphi.RegistryAccessor.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpProf.Delphi.RegistryAccessor.pas diff --git a/source/model/sourceCodeAnalysis/gpProf.DofReader.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpProf.DofReader.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpProf.DofReader.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpProf.DofReader.pas diff --git a/source/model/sourceCodeAnalysis/gpProf.ProjectAccessor.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpProf.ProjectAccessor.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpProf.ProjectAccessor.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpProf.ProjectAccessor.pas diff --git a/source/model/sourceCodeAnalysis/gpProf.bdsVersions.pas b/source/GpProf.UI/model/sourceCodeAnalysis/gpProf.bdsVersions.pas similarity index 100% rename from source/model/sourceCodeAnalysis/gpProf.bdsVersions.pas rename to source/GpProf.UI/model/sourceCodeAnalysis/gpProf.bdsVersions.pas diff --git a/source/ui/SimpleReportUnit.dfm b/source/GpProf.UI/ui/SimpleReportUnit.dfm similarity index 100% rename from source/ui/SimpleReportUnit.dfm rename to source/GpProf.UI/ui/SimpleReportUnit.dfm diff --git a/source/ui/SimpleReportUnit.pas b/source/GpProf.UI/ui/SimpleReportUnit.pas similarity index 100% rename from source/ui/SimpleReportUnit.pas rename to source/GpProf.UI/ui/SimpleReportUnit.pas diff --git a/source/ui/VirtualTree.Tools/virtualTree.tools.base.pas b/source/GpProf.UI/ui/VirtualTree.Tools/virtualTree.tools.base.pas similarity index 100% rename from source/ui/VirtualTree.Tools/virtualTree.tools.base.pas rename to source/GpProf.UI/ui/VirtualTree.Tools/virtualTree.tools.base.pas diff --git a/source/ui/VirtualTree.Tools/virtualTree.tools.checkable.pas b/source/GpProf.UI/ui/VirtualTree.Tools/virtualTree.tools.checkable.pas similarity index 100% rename from source/ui/VirtualTree.Tools/virtualTree.tools.checkable.pas rename to source/GpProf.UI/ui/VirtualTree.Tools/virtualTree.tools.checkable.pas diff --git a/source/ui/VirtualTree.Tools/virtualTree.tools.memorystatistics.pas b/source/GpProf.UI/ui/VirtualTree.Tools/virtualTree.tools.memorystatistics.pas similarity index 100% rename from source/ui/VirtualTree.Tools/virtualTree.tools.memorystatistics.pas rename to source/GpProf.UI/ui/VirtualTree.Tools/virtualTree.tools.memorystatistics.pas diff --git a/source/ui/VirtualTree.Tools/virtualTree.tools.timestatistics.pas b/source/GpProf.UI/ui/VirtualTree.Tools/virtualTree.tools.timestatistics.pas similarity index 100% rename from source/ui/VirtualTree.Tools/virtualTree.tools.timestatistics.pas rename to source/GpProf.UI/ui/VirtualTree.Tools/virtualTree.tools.timestatistics.pas diff --git a/source/ui/gpDialogs.Tools.pas b/source/GpProf.UI/ui/gpDialogs.Tools.pas similarity index 100% rename from source/ui/gpDialogs.Tools.pas rename to source/GpProf.UI/ui/gpDialogs.Tools.pas diff --git a/source/ui/gpPrfPlaceholders.pas b/source/GpProf.UI/ui/gpPrfPlaceholders.pas similarity index 100% rename from source/ui/gpPrfPlaceholders.pas rename to source/GpProf.UI/ui/gpPrfPlaceholders.pas diff --git a/source/ui/gppAbout.dfm b/source/GpProf.UI/ui/gppAbout.dfm similarity index 100% rename from source/ui/gppAbout.dfm rename to source/GpProf.UI/ui/gppAbout.dfm diff --git a/source/ui/gppAbout.pas b/source/GpProf.UI/ui/gppAbout.pas similarity index 100% rename from source/ui/gppAbout.pas rename to source/GpProf.UI/ui/gppAbout.pas diff --git a/source/ui/gppExport.dfm b/source/GpProf.UI/ui/gppExport.dfm similarity index 100% rename from source/ui/gppExport.dfm rename to source/GpProf.UI/ui/gppExport.dfm diff --git a/source/ui/gppExport.pas b/source/GpProf.UI/ui/gppExport.pas similarity index 100% rename from source/ui/gppExport.pas rename to source/GpProf.UI/ui/gppExport.pas diff --git a/source/ui/gppLoadProgress.dfm b/source/GpProf.UI/ui/gppLoadProgress.dfm similarity index 100% rename from source/ui/gppLoadProgress.dfm rename to source/GpProf.UI/ui/gppLoadProgress.dfm diff --git a/source/ui/gppLoadProgress.pas b/source/GpProf.UI/ui/gppLoadProgress.pas similarity index 100% rename from source/ui/gppLoadProgress.pas rename to source/GpProf.UI/ui/gppLoadProgress.pas diff --git a/source/ui/gppMain.FrameInstrumentation.SelectionInfo.pas b/source/GpProf.UI/ui/gppMain.FrameInstrumentation.SelectionInfo.pas similarity index 100% rename from source/ui/gppMain.FrameInstrumentation.SelectionInfo.pas rename to source/GpProf.UI/ui/gppMain.FrameInstrumentation.SelectionInfo.pas diff --git a/source/ui/gppMain.FrameInstrumentation.SelectionInfoIF.pas b/source/GpProf.UI/ui/gppMain.FrameInstrumentation.SelectionInfoIF.pas similarity index 100% rename from source/ui/gppMain.FrameInstrumentation.SelectionInfoIF.pas rename to source/GpProf.UI/ui/gppMain.FrameInstrumentation.SelectionInfoIF.pas diff --git a/source/ui/gppMain.dfm b/source/GpProf.UI/ui/gppMain.dfm similarity index 100% rename from source/ui/gppMain.dfm rename to source/GpProf.UI/ui/gppMain.dfm diff --git a/source/ui/gppMain.pas b/source/GpProf.UI/ui/gppMain.pas similarity index 100% rename from source/ui/gppMain.pas rename to source/GpProf.UI/ui/gppMain.pas diff --git a/source/ui/gppPreferencesDlg.dfm b/source/GpProf.UI/ui/gppPreferencesDlg.dfm similarity index 100% rename from source/ui/gppPreferencesDlg.dfm rename to source/GpProf.UI/ui/gppPreferencesDlg.dfm diff --git a/source/ui/gppPreferencesDlg.pas b/source/GpProf.UI/ui/gppPreferencesDlg.pas similarity index 100% rename from source/ui/gppPreferencesDlg.pas rename to source/GpProf.UI/ui/gppPreferencesDlg.pas diff --git a/source/ui/gppPrfPlaceholderDlg.dfm b/source/GpProf.UI/ui/gppPrfPlaceholderDlg.dfm similarity index 100% rename from source/ui/gppPrfPlaceholderDlg.dfm rename to source/GpProf.UI/ui/gppPrfPlaceholderDlg.dfm diff --git a/source/ui/gppPrfPlaceholderDlg.pas b/source/GpProf.UI/ui/gppPrfPlaceholderDlg.pas similarity index 100% rename from source/ui/gppPrfPlaceholderDlg.pas rename to source/GpProf.UI/ui/gppPrfPlaceholderDlg.pas diff --git a/source/ui/gppUnitWizard.dfm b/source/GpProf.UI/ui/gppUnitWizard.dfm similarity index 100% rename from source/ui/gppUnitWizard.dfm rename to source/GpProf.UI/ui/gppUnitWizard.dfm diff --git a/source/ui/gppUnitWizard.pas b/source/GpProf.UI/ui/gppUnitWizard.pas similarity index 100% rename from source/ui/gppUnitWizard.pas rename to source/GpProf.UI/ui/gppUnitWizard.pas diff --git a/source/ui/gppmain.FrameInstrumentation.UnitSelections.pas b/source/GpProf.UI/ui/gppmain.FrameInstrumentation.UnitSelections.pas similarity index 100% rename from source/ui/gppmain.FrameInstrumentation.UnitSelections.pas rename to source/GpProf.UI/ui/gppmain.FrameInstrumentation.UnitSelections.pas diff --git a/source/ui/gppmain.FrameInstrumentation.dfm b/source/GpProf.UI/ui/gppmain.FrameInstrumentation.dfm similarity index 100% rename from source/ui/gppmain.FrameInstrumentation.dfm rename to source/GpProf.UI/ui/gppmain.FrameInstrumentation.dfm diff --git a/source/ui/gppmain.FrameInstrumentation.pas b/source/GpProf.UI/ui/gppmain.FrameInstrumentation.pas similarity index 100% rename from source/ui/gppmain.FrameInstrumentation.pas rename to source/GpProf.UI/ui/gppmain.FrameInstrumentation.pas diff --git a/source/ui/gppmain.FrameMemoryAnalysis.dfm b/source/GpProf.UI/ui/gppmain.FrameMemoryAnalysis.dfm similarity index 100% rename from source/ui/gppmain.FrameMemoryAnalysis.dfm rename to source/GpProf.UI/ui/gppmain.FrameMemoryAnalysis.dfm diff --git a/source/ui/gppmain.FrameMemoryAnalysis.pas b/source/GpProf.UI/ui/gppmain.FrameMemoryAnalysis.pas similarity index 100% rename from source/ui/gppmain.FrameMemoryAnalysis.pas rename to source/GpProf.UI/ui/gppmain.FrameMemoryAnalysis.pas diff --git a/source/ui/gppmain.FramePerformanceAnalysis.dfm b/source/GpProf.UI/ui/gppmain.FramePerformanceAnalysis.dfm similarity index 100% rename from source/ui/gppmain.FramePerformanceAnalysis.dfm rename to source/GpProf.UI/ui/gppmain.FramePerformanceAnalysis.dfm diff --git a/source/ui/gppmain.FramePerformanceAnalysis.pas b/source/GpProf.UI/ui/gppmain.FramePerformanceAnalysis.pas similarity index 100% rename from source/ui/gppmain.FramePerformanceAnalysis.pas rename to source/GpProf.UI/ui/gppmain.FramePerformanceAnalysis.pas diff --git a/source/ui/gppmain.dragNdrop.pas b/source/GpProf.UI/ui/gppmain.dragNdrop.pas similarity index 100% rename from source/ui/gppmain.dragNdrop.pas rename to source/GpProf.UI/ui/gppmain.dragNdrop.pas diff --git a/source/ui/gppmain.types.pas b/source/GpProf.UI/ui/gppmain.types.pas similarity index 100% rename from source/ui/gppmain.types.pas rename to source/GpProf.UI/ui/gppmain.types.pas diff --git a/tests/GPProfTester.dpr b/source/GpProfDllTestApp/GPProfTester.dpr similarity index 100% rename from tests/GPProfTester.dpr rename to source/GpProfDllTestApp/GPProfTester.dpr diff --git a/source/GpProfDllTestApp/GPProfTester.dproj b/source/GpProfDllTestApp/GPProfTester.dproj new file mode 100644 index 0000000..bbb4283 --- /dev/null +++ b/source/GpProfDllTestApp/GPProfTester.dproj @@ -0,0 +1,149 @@ + + + {145295FF-0EE8-4B4A-AA08-CE20E5940A27} + 20.1 + VCL + GPProfTester.dpr + True + Debug + Win32 + 1 + Application + GPProfTester + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + ..\..\include;$(DCC_UnitSearchPath) + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + inet;$(DCC_UsePackage) + System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) + $(BDS)\bin\delphi_PROJECTICON.ico + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png + $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png + GPProfTester + 6 + 10 + 1031 + FileVersion=1.6.0.10 + + + rtl;fmxase;GPNative_d11;vcl;CustomIPTransport;vclactnband;vcldsnap;IndyCore;IndySystem;vclx;bindcomp;tethering;svnui;appanalytics;dsnap;bindcompvcl;SynEdit_R;vclimg;vcltouch;VclSmp;vcldb;bindcompfmx;svn;vclie;bindengine;dbrtl;IndyProtocols;fmx;fmxdae;xmlrtl;fmxobj;vclwinx;$(DCC_UsePackage) + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) + 1033 + none + $(BDS)\bin\default_app.manifest + + + Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) + Debug + 6 + 10 + CompanyName=;FileDescription=Test app for profiler;FileVersion=1.6.0.10;InternalName=GpProfileTestApp;LegalCopyright=(c) 1998, 1999 Primoz Gabrijelcic;LegalTrademarks=;OriginalFilename=;ProductName=GpProfile 2017 Test App;ProductVersion=1.6.0 + true + 1033 + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + 1033 + Debug + PerMonitor + 1 + FileVersion=1.6.0.1 + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + PerMonitor + 1033 + + + + MainSource + + + + + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + + Delphi.Personality.12 + Application + + + + GPProfTester.dpr + + + + True + False + + + 12 + + + + + diff --git a/tests/testMultiDefines.pas b/source/GpProfDllTestApp/testMultiDefines.pas similarity index 100% rename from tests/testMultiDefines.pas rename to source/GpProfDllTestApp/testMultiDefines.pas diff --git a/source/GpProfDllTestApp/testThreads.pas b/source/GpProfDllTestApp/testThreads.pas new file mode 100644 index 0000000..c69c1ee --- /dev/null +++ b/source/GpProfDllTestApp/testThreads.pas @@ -0,0 +1,63 @@ +unit testThreads; + +interface + +uses + System.Classes; + +type + TTestThread = class(TThread) + public + constructor Create(); + protected + procedure Execute; override; + end; + + +procedure TestThreadsGlobalFunc(); + + +implementation + +uses + System.SysUtils, GpProfDllClient; + +procedure TestThreadsGlobalFunc(); +begin +end; + +{ TTestThread } + +constructor TTestThread.Create; +begin + inherited Create(); +end; + +procedure TTestThread.Execute; +var + lPointer: Pointer; + lCtx: IGpProfContext; + lOuterScope: IMeasurePointScope; + lInnerScope: IMeasurePointScope; +begin + lCtx := AcquireGpProfContext; + try + if Assigned(lCtx) then lCtx.NameThread('AwesomeThread', self.ThreadID); + if Assigned(lCtx) then lOuterScope := lCtx.CreateMeasurePointScope('MP_TestThreadExecuteOuter'); + if Assigned(lCtx) then lCtx.NameThread('AwesomeThread-UnicodeChars-☺☼d156exÈ', self.ThreadID); + if Assigned(lCtx) then lInnerScope := lCtx.CreateMeasurePointScope('MP_TestThreadExecuteInner'); + self.namethreadfordebugging('AwesomeThread2-SelfNameReplacement', self.ThreadID); + TThread.NameThreadForDebugging('AwesomeThread3-TThreadReplacement'); + Sleep(1000); + GetMem(lPointer, 1024); + lInnerScope := nil; + Sleep(1000); + FreeMem(lPointer); + lOuterScope := nil; + finally + DisposeGpProfContext(lCtx); + end; + inherited; +end; + +end. diff --git a/tests/testUnit.pas b/source/GpProfDllTestApp/testUnit.pas similarity index 100% rename from tests/testUnit.pas rename to source/GpProfDllTestApp/testUnit.pas diff --git a/source/build.bat b/source/build.bat deleted file mode 100644 index 8c9d967..0000000 --- a/source/build.bat +++ /dev/null @@ -1,56 +0,0 @@ -@echo off -:start - set build_justone=1 - if %1.==gpprof. goto gpprof - set build_justone=0 - -:gpprof - echo Building GpProf - echo. - if exist gpprof.exe del gpprof.exe >nul - if exist gpprof.cfg del gpprof.cfg >nul - :gpprof_brcc_baggage - brcc32 -r baggage.rc >build.log - if not errorlevel 1 goto gpprof_brcc - goto error - :gpprof_brcc - brcc32 gpprof.rc >build.log - if not errorlevel 1 goto gpprof_dcc - type build.log | more - goto error - :gpprof_dcc - DCC32.exe -Q -B gpprof.dpr >build.log - if not errorlevel 1 goto gpprof_dccok - goto error_nolog - :gpprof_dccok - tail build.log 1 - incver gpprof.dof - echo. - :gpprof_ok - aspack gpprof.exe /r+ /b+ /d+ /e+ - if not exist g:\programs\gpprofile\gpprof.exe md g:\programs\gpprofile >nul - copy gpprof.exe g:\programs\gpprofile >nul - copy gpprof.hlp g:\programs\gpprofile >nul - copy gpprof.cnt g:\programs\gpprofile >nul - copy gpprof.pas x:\mstpl\gp >nul - copy gpprofh.pas x:\mstpl\gp >nul - if %build_justone=1 goto loop - -:loop - shift - if %1.=. goto OK - goto start - -:error - type build.log | more -:error_nolog - echo. - echo Error! - goto exit - -:OK - if exist build.log erase build.log >nul - set build_justone= - echo Program(s) built successfully! - -:exit diff --git a/source/gpprof.dll.tests/GpProfDllTests.GPI b/source/gpprof.dll.tests/GpProfDllTests.GPI new file mode 100644 index 0000000..f2c802a --- /dev/null +++ b/source/gpprof.dll.tests/GpProfDllTests.GPI @@ -0,0 +1,2 @@ +[IDTables] +TableName= diff --git a/source/gpprof.dll.tests/GpProfDllTests.dpr b/source/gpprof.dll.tests/GpProfDllTests.dpr new file mode 100644 index 0000000..6e10176 --- /dev/null +++ b/source/gpprof.dll.tests/GpProfDllTests.dpr @@ -0,0 +1,44 @@ +(* + GpProfile DLL - DUnit test runner. + + Runs all registered DUnit tests for the GpProfDll profiling instrumentation. + Two build configurations are supported: + - Default (Debug/Release): console runner using DUnit TextTestRunner. + - DUnitX_GUI: VCL GUI runner using DUnitX.Loggers.GUI.VCL; DUnit tests + are bridged to DUnitX via TDUnitXDUnitBridge.RegisterDUnitTests. +*) + +program GpProfDllTests; + +{$IFNDEF USE_DUNITX_GUI} +{$APPTYPE CONSOLE} +{$ENDIF} + +{$R *.res} + +uses +{$IFDEF USE_DUNITX_GUI} + Vcl.Forms, + DUnitX.Loggers.GUI.VCL, + DUnitX.DUnitCompatibility, +{$ELSE} + TextTestRunner, +{$ENDIF} + TestFramework, + GpProf in '..\include\GpProf.pas', + GpProfH in '..\include\GpProfH.pas', + GpProfCommon in '..\include\GpProfCommon.pas', + GpProfDllClient in '..\include\GpProfDllClient.pas', + testGpProfDll in 'testGpProfDll.pas', + testGpProfDllContext in 'testGpProfDllContext.pas'; + +begin +{$IFDEF USE_DUNITX_GUI} + TDUnitXDUnitBridge.RegisterDUnitTests; + Application.Initialize; + Application.CreateForm(TGUIVCLTestRunner, GUIVCLTestRunner); + Application.Run; +{$ELSE} + TextTestRunner.RunRegisteredTests; +{$ENDIF} +end. diff --git a/source/gpprof.dll.tests/GpProfDllTests.dproj b/source/gpprof.dll.tests/GpProfDllTests.dproj new file mode 100644 index 0000000..8930828 --- /dev/null +++ b/source/gpprof.dll.tests/GpProfDllTests.dproj @@ -0,0 +1,155 @@ + + + {7A8B9C0D-1E2F-3A4B-5C6D-7E8F9A0B1C2D} + 20.1 + None + GpProfDllTests.dpr + True + Debug + Win32 + 1 + Application + GpProfDllTests + + + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_3 + true + true + + + ..\..\include;$(BDS)\source\DUnit\src;$(BDS)\source\DUnitX;$(DCC_UnitSearchPath) + .\$(Platform)\$(Config) + . + false + false + false + false + false + System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace) + GpProfDllTests + 6 + 1031 + FileVersion=1.6.0.0 + + + true + 1033 + $(BDS)\bin\default_app.manifest + + + DEBUG;$(DCC_Define) + true + false + true + true + false + Debug + + + 1033 + FileVersion=1.0.0.0 + none + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + USE_DUNITX_GUI;DEBUG;$(DCC_Define) + $(BDS)\source\DUnitX;$(DCC_UnitSearchPath) + true + false + true + true + false + Debug + + + Vcl;Vcl.Imaging;Winapi;System.Win;$(DCC_Namespace) + vcl;vclimg;vclwinx;$(DCC_UsePackage) + 1033 + FileVersion=1.0.0.0 + none + $(BDS)\bin\default_app.manifest + + + + MainSource + + + + + + + + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + Cfg_3 + Base + + + + Delphi.Personality.12 + Application + + + + GpProfDllTests.dpr + + + Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver + Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server + + + + True + False + + + 12 + + + + diff --git a/source/gpprof.dll.tests/testGpProfDll.pas b/source/gpprof.dll.tests/testGpProfDll.pas new file mode 100644 index 0000000..203da35 --- /dev/null +++ b/source/gpprof.dll.tests/testGpProfDll.pas @@ -0,0 +1,244 @@ +unit testGpProfDll; + +(* + DUnit test cases for the GpProf instrumentation unit. + + Tests are split into two suites: + + TTestGpProfCommon – tests for GpProfCommon.ResolvePrfRuntimePlaceholders. + These are fully self-contained; no .GPI file is needed. + + TTestGpProfDll – tests for the public GpProf API. + When no .GPI file is present, prfDisabled is set to true + and all profiling calls are safe no-ops. +*) + +interface + +uses + TestFramework, + GpProf, + GpProfCommon; + +type + // ----------------------------------------------------------------------- + // Tests for GpProfCommon.ResolvePrfRuntimePlaceholders + // ----------------------------------------------------------------------- + TTestGpProfCommon = class(TTestCase) + published + procedure TestNoPlaceholder; + procedure TestProcessIDPlaceholder; + procedure TestProcessNamePlaceholder; + procedure TestModuleNamePlaceholder; + procedure TestModulePathPlaceholder; + procedure TestMultiplePlaceholders; + procedure TestRepeatedPlaceholder; + end; + + // ----------------------------------------------------------------------- + // Tests for the GpProf public profiling API + // ----------------------------------------------------------------------- + TTestGpProfDll = class(TTestCase) + published + procedure TestProfilerStartStop; + procedure TestProfilerStartStopIdempotent; + procedure TestProfilerEnterExitProc; + procedure TestProfilerEnterExitProcEdgeCaseIDs; + procedure TestProfilerEnterExitMeasurePoint; + procedure TestMeasurePointScopeNotNil; + procedure TestMeasurePointScopeAutoExit; + procedure TestMeasurePointScopeNested; + procedure TestNameThreadForDebugging; + procedure TestNameThreadForDebuggingMultiple; + end; + +implementation + +uses + Windows, + SysUtils; + +{ TTestGpProfCommon } + +procedure TTestGpProfCommon.TestNoPlaceholder; +const + CInput = 'some/path/without/placeholders'; +begin + CheckEquals(CInput, ResolvePrfRuntimePlaceholders(CInput), + 'A string with no placeholders must be returned unchanged'); +end; + +procedure TTestGpProfCommon.TestProcessIDPlaceholder; +var + lResult: string; + lPID: Cardinal; +begin + lResult := ResolvePrfRuntimePlaceholders('$(ProcessID)'); + CheckFalse(lResult = '', '$(ProcessID) must be replaced with a non-empty string'); + CheckFalse(Pos('$(', lResult) > 0, 'Result must not contain an unresolved placeholder'); + lPID := StrToInt(lResult); + CheckEquals(Integer(GetCurrentProcessID), Integer(lPID), + '$(ProcessID) must equal the current process ID'); +end; + +procedure TTestGpProfCommon.TestProcessNamePlaceholder; +var + lResult: string; +begin + lResult := ResolvePrfRuntimePlaceholders('$(ProcessName)'); + CheckFalse(lResult = '', '$(ProcessName) must be replaced with a non-empty string'); + CheckFalse(Pos('$(', lResult) > 0, 'Result must not contain an unresolved placeholder'); + // The process name must not contain a path separator or a file extension dot. + CheckFalse(Pos('\', lResult) > 0, 'Process name must not contain a backslash'); + CheckFalse(Pos('/', lResult) > 0, 'Process name must not contain a forward slash'); +end; + +procedure TTestGpProfCommon.TestModuleNamePlaceholder; +var + lResult: string; +begin + lResult := ResolvePrfRuntimePlaceholders('$(ModuleName)'); + CheckFalse(lResult = '', '$(ModuleName) must be replaced with a non-empty string'); + CheckFalse(Pos('$(', lResult) > 0, 'Result must not contain an unresolved placeholder'); + // Module name is the bare filename without path or extension. + CheckFalse(Pos('\', lResult) > 0, 'Module name must not contain a backslash'); + CheckFalse(Pos('/', lResult) > 0, 'Module name must not contain a forward slash'); + CheckFalse(Pos('.', lResult) > 0, 'Module name must not contain an extension dot'); +end; + +procedure TTestGpProfCommon.TestModulePathPlaceholder; +var + lResult: string; +begin + lResult := ResolvePrfRuntimePlaceholders('$(ModulePath)'); + CheckFalse(lResult = '', '$(ModulePath) must be replaced with a non-empty string'); + CheckFalse(Pos('$(', lResult) > 0, 'Result must not contain an unresolved placeholder'); + // Module path is the full path without extension — it must contain a path separator. + Check(Pos('\', lResult) > 0, 'Module path must contain at least one backslash'); + // The result must not end with a known binary extension. + CheckFalse(SameText(ExtractFileExt(lResult), '.exe'), 'Module path must not include the .exe extension'); + CheckFalse(SameText(ExtractFileExt(lResult), '.dll'), 'Module path must not include the .dll extension'); +end; + +procedure TTestGpProfCommon.TestMultiplePlaceholders; +var + lResult: string; +begin + lResult := ResolvePrfRuntimePlaceholders('pid=$(ProcessID) name=$(ModuleName)'); + CheckFalse(Pos('$(', lResult) > 0, 'All placeholders must be resolved'); + // The literal separating text must still be present. + Check(Pos('pid=', lResult) = 1, 'Prefix text must be preserved'); + Check(Pos(' name=', lResult) > 0, 'Separator text between placeholders must be preserved'); +end; + +procedure TTestGpProfCommon.TestRepeatedPlaceholder; +var + lResult: string; + lExpected: string; + lPID: string; +begin + lPID := IntToStr(GetCurrentProcessID); + lExpected := lPID + '-' + lPID; + lResult := ResolvePrfRuntimePlaceholders('$(ProcessID)-$(ProcessID)'); + CheckEquals(lExpected, lResult, + 'Both occurrences of the same placeholder must be replaced'); +end; + +{ TTestGpProfDll } + +procedure TTestGpProfDll.TestProfilerStartStop; +begin + // Basic start/stop round-trip must not raise. + ProfilerStart; + ProfilerStop; +end; + +procedure TTestGpProfDll.TestProfilerStartStopIdempotent; +begin + // Calling Start/Stop multiple times in a row must be safe. + ProfilerStart; + ProfilerStart; + ProfilerStop; + ProfilerStop; +end; + +procedure TTestGpProfDll.TestProfilerEnterExitProc; +begin + ProfilerStart; + ProfilerEnterProc(1); + ProfilerEnterProc(2); + ProfilerExitProc(2); + ProfilerExitProc(1); + ProfilerStop; +end; + +procedure TTestGpProfDll.TestProfilerEnterExitProcEdgeCaseIDs; +begin + // ID = 0 (calibration sentinel) and large IDs must be handled safely. + ProfilerStart; + ProfilerEnterProc(0); + ProfilerExitProc(0); + ProfilerEnterProc(High(Cardinal)); + ProfilerExitProc(High(Cardinal)); + ProfilerStop; +end; + +procedure TTestGpProfDll.TestProfilerEnterExitMeasurePoint; +begin + ProfilerStart; + ProfilerEnterMP('TestMeasurePoint'); + ProfilerExitMP('TestMeasurePoint'); + ProfilerStop; +end; + +procedure TTestGpProfDll.TestMeasurePointScopeNotNil; +var + lScope: IMeasurePointScope; +begin + lScope := CreateMeasurePointScope('ScopeNotNil'); + CheckNotNull(lScope, 'CreateMeasurePointScope must return a non-nil interface'); +end; + +procedure TTestGpProfDll.TestMeasurePointScopeAutoExit; +var + lScope: IMeasurePointScope; +begin + // Releasing the interface must not raise even when the profiler is disabled. + ProfilerStart; + lScope := CreateMeasurePointScope('AutoExit'); + lScope := nil; // triggers TMeasurePointScope.Destroy → ProfilerExitMP + ProfilerStop; +end; + +procedure TTestGpProfDll.TestMeasurePointScopeNested; +var + lOuter: IMeasurePointScope; + lInner: IMeasurePointScope; +begin + // Nested scopes must be created and released in LIFO order without raising. + ProfilerStart; + lOuter := CreateMeasurePointScope('Outer'); + lInner := CreateMeasurePointScope('Inner'); + lInner := nil; // exit inner first + lOuter := nil; // then exit outer + ProfilerStop; +end; + +procedure TTestGpProfDll.TestNameThreadForDebugging; +begin + // TThreadID(-1) addresses the calling thread. + NameThreadForDebugging('TestThread', TThreadID(-1)); +end; + +procedure TTestGpProfDll.TestNameThreadForDebuggingMultiple; +begin + // Naming the same thread more than once must not raise. + NameThreadForDebugging('FirstName', TThreadID(-1)); + NameThreadForDebugging('SecondName', TThreadID(-1)); +end; + +initialization + RegisterTest('GpProfCommon', TTestGpProfCommon.Suite); + RegisterTest('GpProfDll', TTestGpProfDll.Suite); + +end. diff --git a/source/gpprof.dll.tests/testGpProfDllContext.pas b/source/gpprof.dll.tests/testGpProfDllContext.pas new file mode 100644 index 0000000..428c968 --- /dev/null +++ b/source/gpprof.dll.tests/testGpProfDllContext.pas @@ -0,0 +1,92 @@ +unit testGpProfDllContext; + +(* + DUnit tests for the IGpProfContext / AcquireGpProfContext API in + GpProfDllClient.pas. + + These tests run independently of GpProfDll32/64.dll. When the DLL is + absent (as in a headless CI build), GpProfDllClient's initialization + silently skips DLL loading and every exported function returns nil / + performs a no-op. The tests below verify this graceful degradation. +*) + +interface + +uses + TestFramework, + GpProfDllClient; + +type + TTestGpProfContextAPI = class(TTestCase) + published + /// + /// AcquireGpProfContext must return nil (not raise) when the DLL + /// could not be found on the search path. + /// + procedure TestAcquireContextNilWhenDllAbsent; + + /// + /// DisposeGpProfContext must be safe to call on a nil interface variable. + /// + procedure TestDisposeContextOnNilIsSafe; + + /// + /// DisposeGpProfContext must set the variable to nil. + /// + procedure TestDisposeContextSetsVarNil; + + /// + /// Calling DisposeGpProfContext twice on the same variable must not raise. + /// + procedure TestDisposeContextIdempotent; + end; + +implementation + +{ TTestGpProfContextAPI } + +procedure TTestGpProfContextAPI.TestAcquireContextNilWhenDllAbsent; +var + lCtx: IGpProfContext; +begin + // GpProfDll32/64.dll is not present in the test output directory so the + // LoadLibrary in GpProfDllClient.initialization will fail silently. + // AcquireGpProfContext checks GpProfDllHandle = 0 and returns nil. + lCtx := AcquireGpProfContext; + CheckNull(lCtx, 'AcquireGpProfContext must return nil when the DLL is absent'); +end; + +procedure TTestGpProfContextAPI.TestDisposeContextOnNilIsSafe; +var + lCtx: IGpProfContext; +begin + lCtx := nil; + // Must not raise on a nil variable. + DisposeGpProfContext(lCtx); + CheckNull(lCtx, 'DisposeGpProfContext on nil must leave variable nil'); +end; + +procedure TTestGpProfContextAPI.TestDisposeContextSetsVarNil; +var + lCtx: IGpProfContext; +begin + lCtx := AcquireGpProfContext; // nil when DLL absent — that is fine + DisposeGpProfContext(lCtx); + CheckNull(lCtx, 'DisposeGpProfContext must set the variable to nil'); +end; + +procedure TTestGpProfContextAPI.TestDisposeContextIdempotent; +var + lCtx: IGpProfContext; +begin + lCtx := AcquireGpProfContext; + DisposeGpProfContext(lCtx); + // Second call on an already-nil variable must not raise. + DisposeGpProfContext(lCtx); + CheckNull(lCtx, 'Variable must remain nil after second DisposeGpProfContext call'); +end; + +initialization + RegisterTest('GpProfContextAPI', TTestGpProfContextAPI.Suite); + +end. diff --git a/source/gpprof.dll/GpProfDll.dpr b/source/gpprof.dll/GpProfDll.dpr new file mode 100644 index 0000000..bcd983f --- /dev/null +++ b/source/gpprof.dll/GpProfDll.dpr @@ -0,0 +1,78 @@ +{$R-,C-,Q-,O+,H+} + +(* + GpProfile DLL - profiling instrumentation bundled as a shared library. + + When profiling multiple DLLs, including GpProf.pas directly in each DLL + results in a separate lock and log file per DLL. By linking all profiled + modules against this shared DLL instead, only one lock and one log file are + used across all modules in the process. +*) + +library GpProfDll; + +uses + Windows, + GpProf in '..\..\include\GpProf.pas', + GpProfH in '..\..\include\GpProfH.pas', + GpProfCommon in '..\..\include\GpProfCommon.pas'; + +// --------------------------------------------------------------------------- +// Per-client session tracking. +// +// DllAcquireSession is called by GpProfDllClient.pas when a new context +// object is created (TGpProfContextClient.Create). It returns an opaque +// token — a pointer to a small heap record with a magic signature — that +// the client holds as long as its IGpProfContext is alive. +// +// DllReleaseSession is called by TGpProfContextClient.Destroy. It frees +// the token. Both functions are exported so that GpProfDllClient.pas can +// bind them at run time via GetProcAddress. +// --------------------------------------------------------------------------- + +type + PGpProfSession = ^TGpProfSession; + TGpProfSession = record + Signature: Cardinal; // sanity marker checked in DllReleaseSession + end; + +const + SESSION_SIGNATURE = $47505253; // sanity marker (0x47505253) + +function DllAcquireSession: Pointer; +var + s: PGpProfSession; +begin + New(s); + s^.Signature := SESSION_SIGNATURE; + Result := s; +end; + +procedure DllReleaseSession(session: Pointer); +var + s: PGpProfSession; +begin + s := PGpProfSession(session); + if (s <> nil) and (s^.Signature = SESSION_SIGNATURE) then begin + s^.Signature := 0; + Dispose(s); + end; +end; + +exports + ProfilerStart, + ProfilerStop, + ProfilerStartThread, + ProfilerEnterProc, + ProfilerExitProc, + ProfilerEnterMP, + ProfilerExitMP, + CreateMeasurePointScope, + ProfilerTerminate, + NameThreadForDebugging(const AThreadName: AnsiString; AThreadID: TThreadID) name 'NameThreadForDebuggingA', + NameThreadForDebugging(const AThreadName: string; AThreadID: TThreadID) name 'NameThreadForDebuggingW', + DllAcquireSession, + DllReleaseSession; + +begin +end. diff --git a/source/gpprof.dll/GpProfDll.dproj b/source/gpprof.dll/GpProfDll.dproj new file mode 100644 index 0000000..2bf2d80 --- /dev/null +++ b/source/gpprof.dll/GpProfDll.dproj @@ -0,0 +1,194 @@ + + + {3F8A1C2D-4B5E-4F6A-9D7C-8E9F0A1B2C3D} + 20.1 + None + GpProfDll.dpr + True + Release + Win32 + 3 + Library + GpProfDll + + + true + + + true + Base + true + + + true + Base + true + + + true + Base + true + + + true + Cfg_1 + true + true + + + true + Cfg_1 + true + true + + + true + Base + true + + + true + Cfg_2 + true + true + + + ..\..\include;$(DCC_UnitSearchPath) + .\$(Platform)\$(Config) + .\$(Platform)\$(Config) + false + false + false + false + false + System;Xml;Data;Datasnap;Web;Soap;Winapi;System.Win;$(DCC_Namespace) + GpProfDll + true + 1031 + FileVersion=1.0.0.0 + + + (Ohne) + 1033 + none + + + + (Ohne) + 1033 + none + + + + false + RELEASE;$(DCC_Define) + 0 + 0 + + + 1033 + + + 1033 + + + DEBUG;$(DCC_Define) + true + false + true + true + true + + + false + Debug + + + + MainSource + + + + + + Base + + + Cfg_1 + Base + + + Cfg_2 + Base + + + + Delphi.Personality.12 + DLL + + + + GpProfDll.dpr + + + Microsoft Office 2000 Beispiele für gekapselte Komponenten für Automatisierungsserver + Microsoft Office XP Beispiele für gekapselte Komponenten für Automation Server + + + + True + True + + + 12 + + + + + + <_GpProfDllBitSuffix Condition="'$(Platform)'=='Win32'">32 + <_GpProfDllBitSuffix Condition="'$(Platform)'=='Win64'">64 + <_GpProfDllRenamedName>gpprof$(_GpProfDllBitSuffix).dll + <_GpProfDllBuilt>$([MSBuild]::NormalizePath('$(MSBuildProjectDirectory)', '$(DCC_ExeOutput)', 'GpProfDll.dll')) + <_GpProfDllRenamed>$([MSBuild]::NormalizePath('$(MSBuildProjectDirectory)', '$(DCC_ExeOutput)', '$(_GpProfDllRenamedName)')) + <_TestAppBinDir>$([MSBuild]::NormalizePath('$(MSBuildProjectDirectory)', '..\..\GpProfDllTestApp\$(Platform)\$(Config)')) + + + + + + + + False + + False + copy $(OUTPUTPATH) ..\..\bin\gpProf32.Dll + False + + + + False + + False + copy $(OUTPUTPATH) ..\..\bin\gpProf64.Dll + False + + + + False + + False + copy $(OUTPUTPATH) ..\..\bin\gpProf32.Dll + False + + + + False + + False + copy $(OUTPUTPATH) ..\..\bin\gpProf64.Dll + False + + diff --git a/source/model/sourceCodeAnalysis/CastaliaParserDefines.inc b/source/model/sourceCodeAnalysis/CastaliaParserDefines.inc new file mode 100644 index 0000000..ae9f1df --- /dev/null +++ b/source/model/sourceCodeAnalysis/CastaliaParserDefines.inc @@ -0,0 +1,29 @@ +{$IFDEF VER200} + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} + {$DEFINE D12_NEWER} +{$ENDIF} + +{$IFDEF VER190} + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE D10_NEWER} + {$DEFINE D11_NEWER} +{$ENDIF} + +{$IFDEF VER180} + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} + {$DEFINE 10_NEWER} +{$ENDIF} + +{$IFDEF VER170} + {$DEFINE D8_NEWER} + {$DEFINE D9_NEWER} +{$ENDIF} + +{$IFDEF VER160} + {$DEFINE D8_NEWER} +{$ENDIF} \ No newline at end of file diff --git a/source/model/sourceCodeAnalysis/CastaliaPasLex.pas b/source/model/sourceCodeAnalysis/CastaliaPasLex.pas new file mode 100644 index 0000000..14985b1 --- /dev/null +++ b/source/model/sourceCodeAnalysis/CastaliaPasLex.pas @@ -0,0 +1,2800 @@ +{----------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License Version +1.1 (the "License"); you may not use this file except in compliance with the +License. You may obtain a copy of the License at +http://www.mozilla.org/NPL/NPL-1_1Final.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: mwPasLex.PAS, released August 17, 1999. + +The Initial Developer of the Original Code is Martin Waldenburg +(Martin.Waldenburg@T-Online.de). +Portions created by Martin Waldenburg are Copyright (C) 1998, 1999 Martin +Waldenburg. +All Rights Reserved. + +Contributor(s): James Jacobson _____________________________________. + +Last Modified: mm/dd/yyyy +Current Version: 2.2 + +Notes: This program is a very fast Pascal tokenizer. I'd like to invite the +Delphi community to develop it further and to create a fully featured Object +Pascal parser. + +Modification history: + +Daniel Rolf between 20010723 and 20020116 + +Made ready for Delphi 6 + +platform +deprecated +varargs +local + +Known Issues: +-----------------------------------------------------------------------------} + +unit CastaliaPasLex; + +{$I CastaliaParserDefines.inc} + +interface + +uses + //!! pruned uses + SysUtils, Classes, Controls, CastaliaPasLexTypes; + +var + Identifiers: array[#0..#255] of ByteBool; + mHashTable: array[#0..#255] of Integer; + +type + TmwBasePasLex = class; + TDirectiveEvent = procedure(Sender: TmwBasePasLex) of object; + + PDefineRec = ^TDefineRec; + TDefineRec = record + Defined: Boolean; + StartCount: Integer; + Next: PDefineRec; + end; + + TmwBasePasLex = class(TObject) + private + fCommentState: TCommentState; + fOrigin: PAnsiChar; + fProcTable: array[#0..#255] of procedure of object; + Run: Integer; + RunAhead: Integer; + TempRun: Integer; + fIdentFuncTable: array[0..191] of function: TptTokenKind of object; + fTokenPos: Integer; + fLineNumber: Integer; + FTokenID: TptTokenKind; + fLinePos: Integer; + fExID: TptTokenKind; + FOnMessage: TMessageEvent; + fOnCompDirect: TDirectiveEvent; + fOnElseDirect: TDirectiveEvent; + fOnEndIfDirect: TDirectiveEvent; + fOnIfDefDirect: TDirectiveEvent; + fOnIfNDefDirect: TDirectiveEvent; + fOnResourceDirect: TDirectiveEvent; + fOnIncludeDirect: TDirectiveEvent; + fOnDefineDirect: TDirectiveEvent; + fOnIfOptDirect: TDirectiveEvent; + fOnIfDirect: TDirectiveEvent; + fOnIfEndDirect: TDirectiveEvent; + fOnElseIfDirect: TDirectiveEvent; + fOnUnDefDirect: TDirectiveEvent; + FDirectiveParamOrigin: PAnsiChar; + + fAsmCode : Boolean; // DR 2002-01-14 + + FDefines: TStrings; + FDefineStack: Integer; + FTopDefineRec: PDefineRec; + FUseDefines: Boolean; + + function KeyHash: Integer; + function KeyComp(const aKey: AnsiString): Boolean; + {$IFDEF D8_NEWER} + function Func9: tptTokenKind; + {$ENDIF} + function Func15: TptTokenKind; + function Func19: TptTokenKind; + function Func20: TptTokenKind; + function Func21: TptTokenKind; + function Func23: TptTokenKind; + function Func25: TptTokenKind; + function Func27: TptTokenKind; + function Func28: TptTokenKind; + function Func29: TptTokenKind; + function Func30: TptTokenKind; + function Func32: TptTokenKind; + function Func33: TptTokenKind; + function Func35: TptTokenKind; + function Func36: TptTokenKind; + function Func37: TptTokenKind; + function Func38: TptTokenKind; + function Func39: TptTokenKind; + function Func40: TptTokenKind; + function Func41: TptTokenKind; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + function Func42: TptTokenKind; + {$ENDIF} + function Func43: TptTokenKind; + function Func44: TptTokenKind; + function Func45: TptTokenKind; + function Func46: TptTokenKind; + function Func47: TptTokenKind; + function Func49: TptTokenKind; + function Func52: TptTokenKind; + function Func54: TptTokenKind; + function Func55: TptTokenKind; + function Func56: TptTokenKind; + function Func57: TptTokenKind; + function Func58: TptTokenKind; + function Func59: TptTokenKind; + function Func60: TptTokenKind; + function Func61: TptTokenKind; + function Func62: TptTokenKind; + function Func63: TptTokenKind; + function Func64: TptTokenKind; + function Func65: TptTokenKind; + function Func66: TptTokenKind; + function Func69: TptTokenKind; + function Func71: TptTokenKind; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + function Func72: TptTokenKind; + {$ENDIF} + function Func73: TptTokenKind; + function Func75: TptTokenKind; + function Func76: TptTokenKind; + function Func78: TptTokenKind; + function Func79: TptTokenKind; + function Func81: TptTokenKind; + function Func84: TptTokenKind; + function Func85: TptTokenKind; + function Func86: TptTokenKind; + function Func87: TptTokenKind; + function Func88: TptTokenKind; + {$IFDEF D8_NEWER} + function Func89: TptTokenKind; //JThurman 2004-03-03 + {$ENDIF} + function Func91: TptTokenKind; + function Func92: TptTokenKind; + function Func94: TptTokenKind; + function Func95: TptTokenKind; + function Func96: TptTokenKind; + function Func97: TptTokenKind; + function Func98: TptTokenKind; + function Func99: TptTokenKind; + function Func100: TptTokenKind; + function Func101: TptTokenKind; + function Func102: TptTokenKind; + function Func103: TptTokenKind; + function Func104: TptTokenKind; + function Func105: TptTokenKind; + function Func106: TptTokenKind; + function Func107: TptTokenKind; + function Func108: TptTokenKind; + function Func112: TptTokenKind; + function Func117: TptTokenKind; + function Func123: TptTokenKind; + function Func126: TptTokenKind; + function Func127: TptTokenKind; + function Func128: TptTokenKind; + function Func129: TptTokenKind; + function Func130: TptTokenKind; + function Func132: TptTokenKind; + function Func133: TptTokenKind; + function Func136: TptTokenKind; + function Func141: TptTokenKind; + function Func143: TptTokenKind; + function Func166: TptTokenKind; + function Func167: TptTokenKind; + function Func168: TptTokenKind; + function Func191: TptTokenKind; + function AltFunc: TptTokenKind; + procedure InitIdent; + function GetPosXY: TTokenPoint; // !! changed to TokenPoint //jdj 7/18/1999 + function IdentKind: TptTokenKind; + procedure SetRunPos(Value: Integer); + procedure MakeMethodTables; + procedure AddressOpProc; + {$IFDEF D8_NEWER} //JThurman 2004-04-06 + procedure AmpersandOpProc; + {$ENDIF} + procedure AsciiCharProc; + procedure AnsiProc; + procedure BorProc; + procedure BraceCloseProc; + procedure BraceOpenProc; + procedure ColonProc; + procedure CommaProc; + procedure CRProc; + procedure EqualProc; + procedure GreaterProc; + procedure IdentProc; + procedure IntegerProc; + procedure LFProc; + procedure LowerProc; + procedure MinusProc; + procedure NullProc; + procedure NumberProc; + procedure PlusProc; + procedure PointerSymbolProc; + procedure PointProc; + procedure RoundCloseProc; + procedure RoundOpenProc; + procedure SemiColonProc; + procedure SlashProc; + procedure SpaceProc; + procedure SquareCloseProc; + procedure SquareOpenProc; + procedure StarProc; + procedure StringProc; + procedure StringDQProc; + procedure SymbolProc; + procedure UnknownProc; + function GetToken: string; + function GetTokenLen: Integer; + function GetCommentState: Pointer; + function GetCompilerDirective: string; + procedure SetCommentState(const Value: Pointer); + procedure InitLine; + function GetDirectiveKind: TptTokenKind; + function GetDirectiveParam: string; + function GetStringContent: string; + function GetIsJunk: Boolean; + function GetIsSpace: Boolean; + function GetIsOrdIdent: Boolean; + function GetIsRealType: Boolean; + function GetIsStringType: Boolean; + function GetIsVarantType: Boolean; + function GetIsAddOperator: Boolean; + function GetIsMulOperator: Boolean; + function GetIsRelativeOperator: Boolean; + function GetIsCompilerDirective: Boolean; + function GetIsOrdinalType: Boolean; + function GetGenID: TptTokenKind;procedure SetOnElseIfDirect(const Value: TDirectiveEvent); + + function IsDefined(const ADefine: string): Boolean; + procedure EnterDefineBlock(ADefined: Boolean); + procedure ExitDefineBlock; + procedure CloneDefinesFrom(ALexer: TmwBasePasLex); + + procedure DoProcTable(AChar: AnsiChar); + function IsIdentifiers(AChar: AnsiChar): Boolean; + function HashValue(AChar: AnsiChar): Integer; + protected + procedure SetLine(const Value: Ansistring); virtual; + procedure SetOrigin(NewValue: PAnsiChar); virtual; + procedure SetOnCompDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnDefineDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnElseDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnEndIfDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnIfDefDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnIfNDefDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnIfOptDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnIncludeDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnResourceDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnUnDefDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnIfDirect(const Value: TDirectiveEvent); virtual; + procedure SetOnIfEndDirect(const Value: TDirectiveEvent); virtual; + + public + constructor Create; + destructor Destroy; override; + function CharAhead: AnsiChar; + procedure Next; + procedure NextID(ID: TptTokenKind); + procedure NextNoJunk; + procedure NextNoSpace; + procedure Init; + procedure InitFrom(ALexer: TmwBasePasLex); + function FirstInLine: Boolean; + + procedure AddDefine(const ADefine: string); + procedure RemoveDefine(const ADefine: string); + procedure ClearDefines; + procedure InitDefines; + + property CommentState: Pointer read GetCommentState write SetCommentState; + property CompilerDirective: string read GetCompilerDirective; + property DirectiveParam: string read GetDirectiveParam; + property IsJunk: Boolean read GetIsJunk; + property IsSpace: Boolean read GetIsSpace; + property Line: ansistring write SetLine; + //Note: setting the following two properties does not GO to that line, it just sets the internal counters + property LineNumber: Integer read fLineNumber write fLineNumber; + property LinePos: Integer read fLinePos write fLinePos; + property Origin: PAnsiChar read fOrigin write SetOrigin; + property PosXY: TTokenPoint read GetPosXY; // !! changed to TokenPoint //jdj 7/18/1999 + property RunPos: Integer read Run write SetRunPos; + property Token: string read GetToken; + property TokenLen: Integer read GetTokenLen; + property TokenPos: Integer read fTokenPos; + property TokenID: TptTokenKind read FTokenID; + property ExID: TptTokenKind read fExID; + property GenID: TptTokenKind read GetGenID; + property StringContent: string read GetStringContent; + property IsOrdIdent: Boolean read GetIsOrdIdent; + property IsOrdinalType: Boolean read GetIsOrdinalType; + property IsRealType: Boolean read GetIsRealType; + property IsStringType: Boolean read GetIsStringType; + property IsVariantType: Boolean read GetIsVarantType; + property IsRelativeOperator: Boolean read GetIsRelativeOperator; + property IsAddOperator: Boolean read GetIsAddOperator; + property IsMulOperator: Boolean read GetIsMulOperator; + property IsCompilerDirective: Boolean read GetIsCompilerDirective; + property OnMessage: TMessageEvent read FOnMessage write FOnMessage; + property OnCompDirect: TDirectiveEvent read fOnCompDirect write SetOnCompDirect; + property OnDefineDirect: TDirectiveEvent read fOnDefineDirect write SetOnDefineDirect; + property OnElseDirect: TDirectiveEvent read fOnElseDirect write SetOnElseDirect; + property OnEndIfDirect: TDirectiveEvent read fOnEndIfDirect write SetOnEndIfDirect; + property OnIfDefDirect: TDirectiveEvent read fOnIfDefDirect write SetOnIfDefDirect; + property OnIfNDefDirect: TDirectiveEvent read fOnIfNDefDirect write SetOnIfNDefDirect; + property OnIfOptDirect: TDirectiveEvent read fOnIfOptDirect write SetOnIfOptDirect; + property OnIncludeDirect: TDirectiveEvent read fOnIncludeDirect write SetOnIncludeDirect; + property OnIfDirect: TDirectiveEvent read fOnIfDirect write SetOnIfDirect; + property OnIfEndDirect: TDirectiveEvent read fOnIfEndDirect write + SetOnIfEndDirect; + property OnElseIfDirect: TDirectiveEvent read fOnElseIfDirect write + SetOnElseIfDirect; + property OnResourceDirect: TDirectiveEvent read fOnResourceDirect write SetOnResourceDirect; + property OnUnDefDirect: TDirectiveEvent read fOnUnDefDirect write SetOnUnDefDirect; + + property AsmCode : Boolean read fAsmCode write fAsmCode; // DR 2002-01-14 + property DirectiveParamOrigin: pAnsichar read FDirectiveParamOrigin; + + property UseDefines: Boolean read FUseDefines write FUseDefines; + + end; + + TmwPasLex = class(TmwBasePasLex) + private + fAheadLex: TmwBasePasLex; + function GetAheadExID: TptTokenKind; + function GetAheadGenID: TptTokenKind; + function GetAheadToken: string; + function GetAheadTokenID: TptTokenKind; + function GetStatus: TmwPasLexStatus; + procedure SetStatus(const Value: TmwPasLexStatus); + protected + procedure SetLine(const Value: ansistring); override; + procedure SetOrigin(NewValue: PAnsiChar); override; + procedure SetOnCompDirect(const Value: TDirectiveEvent); override; + procedure SetOnDefineDirect(const Value: TDirectiveEvent); override; + procedure SetOnElseDirect(const Value: TDirectiveEvent); override; + procedure SetOnEndIfDirect(const Value: TDirectiveEvent); override; + procedure SetOnIfDefDirect(const Value: TDirectiveEvent); override; + procedure SetOnIfNDefDirect(const Value: TDirectiveEvent); override; + procedure SetOnIfOptDirect(const Value: TDirectiveEvent); override; + procedure SetOnIncludeDirect(const Value: TDirectiveEvent); override; + procedure SetOnResourceDirect(const Value: TDirectiveEvent); override; + procedure SetOnUnDefDirect(const Value: TDirectiveEvent); override; + public + constructor Create; + destructor Destroy; override; + procedure InitAhead; + procedure AheadNext; + property AheadLex: TmwBasePasLex read fAheadLex; + property AheadToken: string read GetAheadToken; + property AheadTokenID: TptTokenKind read GetAheadTokenID; + property AheadExID: TptTokenKind read GetAheadExID; + property AheadGenID: TptTokenKind read GetAheadGenID; + property Status: TmwPasLexStatus read GetStatus write SetStatus; + end; + +implementation + +uses Windows; + +procedure MakeIdentTable; +var + I, J: Char; +begin + for I := #0 to #255 do + begin + case I of + '_', '0'..'9', 'a'..'z', 'A'..'Z': Identifiers[I] := True; + else Identifiers[I] := False; + end; + J := UpperCase(I)[1]; + case I of + 'a'..'z', 'A'..'Z', '_': mHashTable[I] := Ord(J) - 64; + else mHashTable[Char(I)] := 0; + end; + end; +end; + +function TmwBasePasLex.CharAhead: AnsiChar; +begin + RunAhead := Run; +// while fOrigin[RunAhead] in [#1..#32] do + while (fOrigin[RunAhead] > #0) and (fOrigin[RunAhead] < #33) do + + inc(RunAhead); + Result := fOrigin[RunAhead]; +end; + +procedure TmwBasePasLex.ClearDefines; +var + Frame: PDefineRec; +begin + while FTopDefineRec <> nil do + begin + Frame := FTopDefineRec; + FTopDefineRec := Frame^.Next; + Dispose(Frame); + end; + FDefines.Clear; + FDefineStack := 0; +end; + +procedure TmwBasePasLex.CloneDefinesFrom(ALexer: TmwBasePasLex); +var + Frame, LastFrame, SourceFrame: PDefineRec; +begin + ClearDefines; + FDefines.Assign(ALexer.FDefines); + FDefineStack := ALexer.FDefineStack; + LastFrame := nil; + Frame := nil; + SourceFrame := ALexer.FTopDefineRec; + while SourceFrame <> nil do + begin + New(Frame); + if FTopDefineRec = nil then + FTopDefineRec := Frame + else + LastFrame^.Next := Frame; + Frame^.Defined := SourceFrame^.Defined; + Frame^.StartCount := SourceFrame^.StartCount; + LastFrame := Frame; + + SourceFrame := SourceFrame^.Next; + end; + if Frame <> nil then + Frame^.Next := nil; + +// New(StackFrame); +// StackFrame^.Next := FTopDefineRec; +// StackFrame^.Defined := ADefined; +// StackFrame^.StartCount := FDefineStack; +// FTopDefineRec := StackFrame; +// if not ADefined then +// Inc(FDefineStack); + +end; + +function TmwBasePasLex.GetPosXY: TTokenPoint; +begin //jdj 7/18/1999 + // !! changed setting code + Result.X:= FTokenPos - FLinePos; + Result.Y:= FLineNumber; +end; + +procedure TmwBasePasLex.InitIdent; +var + I: Integer; +begin + for I := 0 to 191 do + case I of + {$IFDEF D8_NEWER} + 9: fIdentFuncTable[I] := Func9; + {$ENDIF} + 15: fIdentFuncTable[I] := Func15; + 19: fIdentFuncTable[I] := Func19; + 20: fIdentFuncTable[I] := Func20; + 21: fIdentFuncTable[I] := Func21; + 23: fIdentFuncTable[I] := Func23; + 25: fIdentFuncTable[I] := Func25; + 27: fIdentFuncTable[I] := Func27; + 28: fIdentFuncTable[I] := Func28; + 29: fIdentFuncTable[I] := Func29; + 30: fIdentFuncTable[I] := Func30; + 32: fIdentFuncTable[I] := Func32; + 33: fIdentFuncTable[I] := Func33; + 35: fIdentFuncTable[I] := Func35; + 36: fIdentFuncTable[I] := Func36; + 37: fIdentFuncTable[I] := Func37; + 38: fIdentFuncTable[I] := Func38; + 39: fIdentFuncTable[I] := Func39; + 40: fIdentFuncTable[I] := Func40; + 41: fIdentFuncTable[I] := Func41; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + 42: fIdentFuncTable[I] := Func42; + {$ENDIF} + 43: fIdentFuncTable[I] := Func43; + 44: fIdentFuncTable[I] := Func44; + 45: fIdentFuncTable[I] := Func45; + 46: fIdentFuncTable[I] := Func46; + 47: fIdentFuncTable[I] := Func47; + 49: fIdentFuncTable[I] := Func49; + 52: fIdentFuncTable[I] := Func52; + 54: fIdentFuncTable[I] := Func54; + 55: fIdentFuncTable[I] := Func55; + 56: fIdentFuncTable[I] := Func56; + 57: fIdentFuncTable[I] := Func57; + 58: fIdentFuncTable[I] := Func58; + 59: fIdentFuncTable[I] := Func59; + 60: fIdentFuncTable[I] := Func60; + 61: fIdentFuncTable[I] := Func61; + 62: fIdentFuncTable[I] := Func62; + 63: fIdentFuncTable[I] := Func63; + 64: fIdentFuncTable[I] := Func64; + 65: fIdentFuncTable[I] := Func65; + 66: fIdentFuncTable[I] := Func66; + 69: fIdentFuncTable[I] := Func69; + 71: fIdentFuncTable[I] := Func71; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + 72: fIdentFuncTable[I] := Func72; + {$ENDIF} + 73: fIdentFuncTable[I] := Func73; + 75: fIdentFuncTable[I] := Func75; + 76: fIdentFuncTable[I] := Func76; + 78: fIdentFuncTable[I] := Func78; + 79: fIdentFuncTable[I] := Func79; + 81: fIdentFuncTable[I] := Func81; + 84: fIdentFuncTable[I] := Func84; + 85: fIdentFuncTable[I] := Func85; + 86: fIdentFuncTable[I] := Func86; + 87: fIdentFuncTable[I] := Func87; + 88: fIdentFuncTable[I] := Func88; + {$IFDEF D8_NEWER} //JThurman 2004-03-03 + 89: fIdentFuncTable[I] := Func89; + {$ENDIF} + 91: fIdentFuncTable[I] := Func91; + 92: fIdentFuncTable[I] := Func92; + 94: fIdentFuncTable[I] := Func94; + 95: fIdentFuncTable[I] := Func95; + 96: fIdentFuncTable[I] := Func96; + 97: fIdentFuncTable[I] := Func97; + 98: fIdentFuncTable[I] := Func98; + 99: fIdentFuncTable[I] := Func99; + 100: fIdentFuncTable[I] := Func100; + 101: fIdentFuncTable[I] := Func101; + 102: fIdentFuncTable[I] := Func102; + 103: fIdentFuncTable[I] := Func103; + 104: fIdentFuncTable[I] := Func104; + 105: fIdentFuncTable[I] := Func105; + 106: fIdentFuncTable[I] := Func106; + 107: fIdentFuncTable[I] := Func107; + 108: fIdentFuncTable[I] := Func108; + 112: fIdentFuncTable[I] := Func112; + 117: fIdentFuncTable[I] := Func117; + 123: fIdentFuncTable[I] := Func123; + 126: fIdentFuncTable[I] := Func126; + 127: fIdentFuncTable[I] := Func127; + 128: fIdentFuncTable[I] := Func128; + 129: fIdentFuncTable[I] := Func129; + 130: fIdentFuncTable[I] := Func130; + 132: fIdentFuncTable[I] := Func132; + 133: fIdentFuncTable[I] := Func133; + 136: fIdentFuncTable[I] := Func136; + 141: fIdentFuncTable[I] := Func141; + 143: fIdentFuncTable[I] := Func143; + 166: fIdentFuncTable[I] := Func166; + 167: fIdentFuncTable[I] := Func167; + 168: fIdentFuncTable[I] := Func168; + 191: fIdentFuncTable[I] := Func191; + else fIdentFuncTable[I] := AltFunc; + end; +end; + +function TmwBasePasLex.KeyHash: Integer; +begin + Result := 0; + while IsIdentifiers(fOrigin[Run]) do + begin + Inc(Result, HashValue(fOrigin[Run])); + //inc(Result, mHashTable[fOrigin[Run]]); + inc(Run); + end; +end; { KeyHash } + +function TmwBasePasLex.KeyComp(const aKey: ansistring): Boolean; +var + I: Integer; + Temp: PAnsiChar; +begin + if Length(aKey) = TokenLen then + begin + Temp := fOrigin + fTokenPos; + Result := True; + for i := 1 to TokenLen do + begin + if mHashTable[Temp^] <> mHashTable[aKey[i]] then + begin + Result := False; + break; + end; + inc(Temp); + end; + end + else Result := False; +end; { KeyComp } + +{$IFDEF D8_NEWER} +function TmwBasePasLex.Func9: tptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Add') then + FExID := ptAdd; +end; +{$ENDIF} + +function TmwBasePasLex.Func15: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('If') then Result := ptIf; +end; + +function TmwBasePasLex.Func19: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Do') then Result := ptDo else + if KeyComp('And') then Result := ptAnd; +end; + +function TmwBasePasLex.Func20: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('As') then Result := ptAs; +end; + +function TmwBasePasLex.Func21: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Of') then Result := ptOf else + if KeyComp('At') then fExID := ptAt; +end; + +function TmwBasePasLex.Func23: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('End') then Result := ptEnd else + if KeyComp('In') then Result := ptIn; +end; + +function TmwBasePasLex.Func25: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Far') then fExID := ptFar; +end; + +function TmwBasePasLex.Func27: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Cdecl') then fExID := ptCdecl; +end; + +function TmwBasePasLex.Func28: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Read') then fExID := ptRead else + if KeyComp('Case') then Result := ptCase else + if KeyComp('Is') then Result := ptIs; +end; + +function TmwBasePasLex.Func29: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('On') then fExID := ptOn; +end; + +function TmwBasePasLex.Func30: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Char') then fExID := ptChar; +end; + +function TmwBasePasLex.Func32: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('File') then Result := ptFile else + if KeyComp('Label') then Result := ptLabel else + if KeyComp('Mod') then Result := ptMod; +end; + +function TmwBasePasLex.Func33: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Or') then Result := ptOr else + if KeyComp('Name') then fExID := ptName else + if KeyComp('Asm') then Result := ptAsm; +end; + +function TmwBasePasLex.Func35: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Nil') then Result := ptNil else + if KeyComp('To') then Result := ptTo else + if KeyComp('Div') then Result := ptDiv; +end; + +function TmwBasePasLex.Func36: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Real') then fExID := ptReal else + if KeyComp('Real48') then fExID := ptReal48; +end; + +function TmwBasePasLex.Func37: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Begin') then Result := ptBegin else + if KeyComp('Break') then fExID := ptBreak; +end; + +function TmwBasePasLex.Func38: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Near') then fExID := ptNear; +end; + +function TmwBasePasLex.Func39: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('For') then Result := ptFor else + if KeyComp('Shl') then Result := ptShl; +end; + +function TmwBasePasLex.Func40: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Packed') then Result := ptPacked; +end; + +function TmwBasePasLex.Func41: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Var') then Result := ptVar else + if KeyComp('Else') then Result := ptElse else + if KeyComp('Halt') then fExID := ptHalt; +end; + +{$IFDEF D8_NEWER} //JThurman 2004-03-2003 +function TmwBasePasLex.Func42: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Final') then + fExID := ptFinal; //TODO: Is this supposed to be an ExID? +end; +{$ENDIF} + +function TmwBasePasLex.Func43: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Int64') then fExID := ptInt64 + else if KeyComp('local') then fExID := ptLocal; +end; + +function TmwBasePasLex.Func44: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Set') then Result := ptSet else + if KeyComp('Package') then fExID := ptPackage; +end; + +function TmwBasePasLex.Func45: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Shr') then Result := ptShr; +end; + +function TmwBasePasLex.Func46: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('PChar') then fExId := ptPChar + {$IFDEF D8_NEWER} //JThurman 2004-03-19 + else + if KeyComp('Sealed') then Result := ptSealed; + {$ELSE} + ; + {$ENDIF} +end; + +function TmwBasePasLex.Func47: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Then') then Result := ptThen else + if KeyComp('Comp') then fExID := ptComp; +end; + +function TmwBasePasLex.Func49: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Not') then Result := ptNot; +end; + +function TmwBasePasLex.Func52: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Byte') then fExID := ptByte else + if KeyComp('Raise') then Result := ptRaise else + if KeyComp('Pascal') then fExID := ptPascal; +end; + +function TmwBasePasLex.Func54: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Class') then Result := ptClass; +end; + +function TmwBasePasLex.Func55: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Object') then Result := ptObject; +end; + +function TmwBasePasLex.Func56: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Index') then fExID := ptIndex else + if KeyComp('Out') then fExID := ptOut else // bug in Delphi's documentation: OUT is a directive + if KeyComp('Abort') then fExID := ptAbort; +end; + +function TmwBasePasLex.Func57: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('While') then Result := ptWhile else + if KeyComp('Xor') then Result := ptXor else + if KeyComp('Goto') then Result := ptGoto; +end; + +function TmwBasePasLex.Func58: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Exit') then fExID := ptExit; +end; + +function TmwBasePasLex.Func59: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Safecall') then fExID := ptSafecall else + if KeyComp('Double') then fExID := ptDouble; +end; + +function TmwBasePasLex.Func60: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('With') then Result := ptWith else + if KeyComp('Word') then fExID := ptWord; +end; + +function TmwBasePasLex.Func61: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Dispid') then fExID := ptDispid; +end; + +function TmwBasePasLex.Func62: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Cardinal') then fExID := ptCardinal; +end; + +function TmwBasePasLex.Func63: TptTokenKind; +begin + Result := ptIdentifier; + case fOrigin[fTokenPos] of + 'P', 'p': if KeyComp('Public') then fExID := ptPublic; + 'A', 'a': if KeyComp('Array') then Result := ptArray; + 'T', 't': if KeyComp('Try') then Result := ptTry; + 'R', 'r': if KeyComp('Record') then Result := ptRecord; + 'I', 'i': if KeyComp('Inline') then + begin + Result := ptInline; + fExID := ptInline; + end; + end; +end; + +function TmwBasePasLex.Func64: TptTokenKind; +begin + Result := ptIdentifier; + case fOrigin[fTokenPos] of + 'B', 'b': if KeyComp('Boolean') then fExID := ptBoolean; + 'D', 'd': if KeyComp('DWORD') then fExID := ptDWORD; + 'U', 'u': if KeyComp('Uses') then Result := ptUses + else + if KeyComp('Unit') then Result := ptUnit; + {$IFDEF D8_NEWER} + 'H', 'h': if KeyComp('Helper') then Result := ptHelper; + {$ENDIF} + end; +end; + +function TmwBasePasLex.Func65: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Repeat') then Result := ptRepeat; +end; + +function TmwBasePasLex.Func66: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Single') then fExID := ptSingle else + if KeyComp('Type') then Result := ptType + {$IFDEF D8_NEWER}//JThurman 2004-03-23 + else + if KeyComp('Unsafe') then Result := ptUnsafe + {$ENDIF} + ; +end; + +function TmwBasePasLex.Func69: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Default') then fExID := ptDefault else + if KeyComp('Dynamic') then fExID := ptDynamic else + if KeyComp('Message') then fExID := ptMessage; +end; + +function TmwBasePasLex.Func71: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('WideChar') then fExID := ptWideChar else + if KeyComp('Stdcall') then fExID := ptStdcall else + if KeyComp('Const') then Result := ptConst; +end; + +{$IFDEF D8_NEWER} //JThurman 2004-03-2003 +function TmwBasePasLex.Func72: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Static') then + fExID := ptStatic; +end; +{$ENDIF} + +function TmwBasePasLex.Func73: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Except') then Result := ptExcept; +end; + +function TmwBasePasLex.Func75: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Write') then fExID := ptWrite; +end; + +function TmwBasePasLex.Func76: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Until') then Result := ptUntil; +end; + +function TmwBasePasLex.Func78: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Integer') then fExID := ptInteger + {$IFDEF D8_NEWER} + else if KeyComp('Remove') then + FExID := ptRemove + {$ENDIF} + ; +end; + +function TmwBasePasLex.Func79: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Finally') then Result := ptFinally + {$IFDEF D12_NEWER} + else if KeyComp('Reference') then fExID := ptReference; + {$ENDIF} + +end; + +function TmwBasePasLex.Func81: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Extended') then fExID := ptExtended else + if KeyComp('Stored') then fExID := ptStored else + if KeyComp('Interface') then Result := ptInterface + else if KeyComp('Deprecated') then fExID := ptDeprecated; // DR 2001-10-20 +end; + +function TmwBasePasLex.Func84: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Abstract') then fExID := ptAbstract; +end; + +function TmwBasePasLex.Func85: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Library') then Result := ptLibrary else + if KeyComp('Forward') then fExID := ptForward else + if KeyComp('Variant') then fExID := ptVariant; +end; + +function TmwBasePasLex.Func87: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('String') then Result := ptString; +end; + +function TmwBasePasLex.Func88: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Program') then Result := ptProgram; +end; + +{$IFDEF D8_NEWER} //JThurman 2004-03-03 +function TmwBasePasLex.Func89: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Strict') then Result := ptStrict; +end; +{$ENDIF} + +function TmwBasePasLex.Func91: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Downto') then Result := ptDownto else + if KeyComp('Private') then fExID := ptPrivate else + if KeyComp('Longint') then fExID := ptLongint; +end; + +function TmwBasePasLex.Func92: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Inherited') then Result := ptInherited else + if KeyComp('LongBool') then fExID := ptLongBool else + if KeyComp('Overload') then fExID := ptOverload; +end; + +function TmwBasePasLex.Func94: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Resident') then fExID := ptResident else + if KeyComp('Readonly') then fExID := ptReadonly else + if KeyComp('Assembler') then fExID := ptAssembler; +end; + +function TmwBasePasLex.Func95: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Contains') then fExID := ptContains else + if KeyComp('Absolute') then fExID := ptAbsolute; +end; + +function TmwBasePasLex.Func96: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('ByteBool') then fExID := ptByteBool else + if KeyComp('Override') then fExID := ptOverride else + if KeyComp('Published') then fExID := ptPublished; +end; + +function TmwBasePasLex.Func97: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Threadvar') then Result := ptThreadvar; +end; + +function TmwBasePasLex.Func98: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Export') then fExID := ptExport else + if KeyComp('Nodefault') then fExID := ptNodefault; +end; + +function TmwBasePasLex.Func99: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('External') then fExID := ptExternal; +end; + +function TmwBasePasLex.Func100: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Automated') then fExID := ptAutomated else + if KeyComp('Smallint') then fExID := ptSmallint; +end; + +function TmwBasePasLex.Func101: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Register') then fExID := ptRegister + else if KeyComp('Platform') then fExID := ptPlatform // DR 2001-10-20 + else if KeyComp('Continue') then fExID := ptContinue; +end; + +function TmwBasePasLex.Func102: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Function') then Result := ptFunction; +end; + +function TmwBasePasLex.Func103: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Virtual') then fExID := ptVirtual; +end; + +function TmwBasePasLex.Func104: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('WordBool') then fExID := ptWordBool; +end; + +function TmwBasePasLex.Func105: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Procedure') then Result := ptProcedure; +end; + +function TmwBasePasLex.Func106: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Protected') then fExID := ptProtected; +end; + +function TmwBasePasLex.Func107: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Currency') then fExID := ptCurrency; +end; + +function TmwBasePasLex.Func108: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Longword') then fExID := ptLongword; + {$IFDEF D8_NEWER} //JThurman 2004-03-20 + if KeyComp('Operator') then fExID := ptOperator; + {$ENDIF} +end; + +function TmwBasePasLex.Func112: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Requires') then fExID := ptRequires; +end; + +function TmwBasePasLex.Func117: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Exports') then Result := ptExports else + if KeyComp('OleVariant') then fExID := ptOleVariant; +end; + +function TmwBasePasLex.Func123: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Shortint') then fExID := ptShortint; +end; + +function TmwBasePasLex.Func126: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Implements') then fExID := ptImplements; +end; + +function TmwBasePasLex.Func127: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Runerror') then fExID := ptRunError; +end; + +function TmwBasePasLex.Func128: TptTokenKind; +begin + if KeyComp('WideString') then fExID := ptWideString; + Result := ptIdentifier; +end; + +function TmwBasePasLex.Func129: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Dispinterface') then Result := ptDispinterface +end; + +function TmwBasePasLex.Func130: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('AnsiString') then fExID := ptAnsiString; +end; + +function TmwBasePasLex.Func132: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Reintroduce') then fExID := ptReintroduce; +end; + +function TmwBasePasLex.Func133: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Property') then Result := ptProperty; +end; + +function TmwBasePasLex.Func136: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Finalization') then Result := ptFinalization; +end; + +function TmwBasePasLex.Func141: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Writeonly') then fExID := ptWriteonly; +end; + +function TmwBasePasLex.Func143: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Destructor') then Result := ptDestructor; +end; + +function TmwBasePasLex.Func166: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Constructor') then Result := ptConstructor else + if KeyComp('Implementation') then Result := ptImplementation; +end; + +function TmwBasePasLex.Func167: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('ShortString') then fExID := ptShortString; +end; + +function TmwBasePasLex.Func168: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Initialization') then Result := ptInitialization; +end; + +function TmwBasePasLex.Func191: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Resourcestring') then Result := ptResourcestring else + if KeyComp('Stringresource') then fExID := ptStringresource; +end; + +function TmwBasePasLex.AltFunc: TptTokenKind; +begin + Result := ptIdentifier; +end; + +function TmwBasePasLex.IdentKind: TptTokenKind; +var + HashKey: Integer; +begin + HashKey := KeyHash; + if HashKey < 192 then + Result := fIdentFuncTable[HashKey] + else Result := ptIdentifier; +end; + +procedure TmwBasePasLex.MakeMethodTables; +var + I: Char; +begin + for I := #0 to #255 do + case I of + #0: fProcTable[I] := NullProc; + #10: fProcTable[I] := LFProc; + #13: fProcTable[I] := CRProc; + #1..#9, #11, #12, #14..#32: + fProcTable[I] := SpaceProc; + '#': fProcTable[I] := AsciiCharProc; + '$': fProcTable[I] := IntegerProc; + #39: fProcTable[I] := StringProc; + '0'..'9': fProcTable[I] := NumberProc; + 'A'..'Z', 'a'..'z', '_': + fProcTable[I] := IdentProc; + '{': fProcTable[I] := BraceOpenProc; + '}': fProcTable[I] := BraceCloseProc; + '!', '"', '%', '&', '('..'/', ':'..'@', '['..'^', '`', '~': + begin + case I of + '(': fProcTable[I] := RoundOpenProc; + ')': fProcTable[I] := RoundCloseProc; + '*': fProcTable[I] := StarProc; + '+': fProcTable[I] := PlusProc; + ',': fProcTable[I] := CommaProc; + '-': fProcTable[I] := MinusProc; + '.': fProcTable[I] := PointProc; + '/': fProcTable[I] := SlashProc; + ':': fProcTable[I] := ColonProc; + ';': fProcTable[I] := SemiColonProc; + '<': fProcTable[I] := LowerProc; + '=': fProcTable[I] := EqualProc; + '>': fProcTable[I] := GreaterProc; + '@': fProcTable[I] := AddressOpProc; + '[': fProcTable[I] := SquareOpenProc; + ']': fProcTable[I] := SquareCloseProc; + '^': fProcTable[I] := PointerSymbolProc; + '"': fProcTable[I] := StringDQProc; // DR 2002-01-14 + {$IFDEF D8_NEWER} //JThurman 2004-04-06 + '&': fProcTable[I] := AmpersandOpProc; + {$ENDIF} + else fProcTable[I] := SymbolProc; + end; + end; + else fProcTable[I] := UnknownProc; + end; +end; + +constructor TmwBasePasLex.Create; +begin + inherited Create; + fOrigin := nil; + InitIdent; + MakeMethodTables; + fExID := ptUnKnown; + + FUseDefines := True; + FDefines := TStringList.Create; + FTopDefineRec := nil; + InitDefines; +end; { Create } + +destructor TmwBasePasLex.Destroy; +begin + ClearDefines; //If we don't do this, we get a memory leak + FDefines.Free; + fOrigin := nil; + inherited Destroy; +end; + +procedure TmwBasePasLex.DoProcTable(AChar: AnsiChar); +begin + if AChar <= #255 then + fProcTable[AChar] + else + begin + IdentProc; + end; +end; + +{ Destroy } + +procedure TmwBasePasLex.SetOrigin(NewValue: PAnsiChar); +begin + fOrigin := NewValue; + Init; + Next; +end; { SetOrigin } + +procedure TmwBasePasLex.SetRunPos(Value: Integer); +begin + Run := Value; + Next; +end; + +procedure TmwBasePasLex.AddDefine(const ADefine: string); +begin + FDefines.Add(ADefine); +end; + +procedure TmwBasePasLex.AddressOpProc; +begin + case FOrigin[Run + 1] of + '@': + begin + fTokenID := ptDoubleAddressOp; + inc(Run, 2); + end; + else + begin + fTokenID := ptAddressOp; + inc(Run); + end; + end; +end; + +procedure TmwBasePasLex.AsciiCharProc; +begin + fTokenID := ptAsciiChar; + inc(Run); + if FOrigin[Run] = '$' then + begin + inc(Run); + while FOrigin[Run] in ['0'..'9', 'A'..'F', 'a'..'f'] do inc(Run); + end else + begin + while FOrigin[Run] in ['0'..'9'] do + inc(Run); + end; +end; + +procedure TmwBasePasLex.BraceCloseProc; +begin + inc(Run); + fTokenId := ptError; + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Illegal character', PosXY.X, PosXY.Y); +end; + +procedure TmwBasePasLex.BorProc; +begin + fTokenID := ptBorComment; + case FOrigin[Run] of + #0: + begin + NullProc; + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unexpected file end', PosXY.X, PosXY.Y); + exit; + end; +{ DR 2001-08-02 + + #10: + begin + LFProc; + exit; + end; + + #13: + begin + CRProc; + exit; + end; +} + end; + + while FOrigin[Run] <> #0 do + case FOrigin[Run] of + '}': + begin + fCommentState := csNo; + inc(Run); + break; + end; +{ DR 2001-08-02 + #10: break; + + #13: break; +} + #10: + begin + inc(Run); + inc(fLineNumber); + fLinePos := Run; + end; + #13: + begin + inc(Run); + if FOrigin[Run] = #10 then inc( Run ); + inc(fLineNumber); + fLinePos := Run; + end; + else inc(Run); + end; +end; + +procedure TmwBasePasLex.BraceOpenProc; +var + Param, Def: string; +begin + case FOrigin[Run + 1] of + '$': fTokenID := GetDirectiveKind; + else + begin + fTokenID := ptBorComment; + fCommentState := csBor; + end; + end; + inc(Run); + while FOrigin[Run] <> #0 do + case FOrigin[Run] of + '}': + begin + fCommentState := csNo; + inc(Run); + break; + end; + #10: + begin + inc(Run); + inc(fLineNumber); + fLinePos := Run; + end; + #13: + begin + inc(Run); + if FOrigin[Run] = #10 then inc( Run ); + inc(fLineNumber); + fLinePos := Run; + end; +{ #10: break; DR 2001-10-12 + + #13: break;} + else inc(Run); + end; + case fTokenID of + PtCompDirect: + begin + if Assigned(fOnCompDirect) then + fOnCompDirect(Self); + end; + PtDefineDirect: + begin + if FUseDefines then + AddDefine(DirectiveParam); + if Assigned(fOnDefineDirect) then + fOnDefineDirect(Self); + end; + PtElseDirect: + begin + if FUseDefines then + begin + if FTopDefineRec <> nil then + begin + if FTopDefineRec^.Defined then + Inc(FDefineStack) + else + if FDefineStack > 0 then + Dec(FDefineStack); + end; + end; + if Assigned(fOnElseDirect) then + fOnElseDirect(Self); + end; + PtEndIfDirect: + begin + if FUseDefines then + ExitDefineBlock; + if Assigned(fOnEndIfDirect) then + fOnEndIfDirect(Self); + end; + PtIfDefDirect: + begin + if FUseDefines then + EnterDefineBlock(IsDefined(DirectiveParam)); + if Assigned(fOnIfDefDirect) then + fOnIfDefDirect(Self); + end; + PtIfNDefDirect: + begin + if FUseDefines then + EnterDefineBlock(not IsDefined(DirectiveParam)); + if Assigned(fOnIfNDefDirect) then + fOnIfNDefDirect(Self); + end; + PtIfOptDirect: + begin + if Assigned(fOnIfOptDirect) then + fOnIfOptDirect(Self); + end; + PtIfDirect: + begin + if FUseDefines then + begin + Param := DirectiveParam; + if Pos('DEFINED', Param) = 1 then + begin + Def := Copy(Param, 9, Length(Param) - 9); + EnterDefineBlock(IsDefined(Def)); + end; + end; + if Assigned(fOnIfDirect) then + fOnIfDirect(Self); + end; + PtIfEndDirect: + begin + if FUseDefines then + ExitDefineBlock; + if Assigned(fOnIfEndDirect) then + fOnIfEndDirect(Self); + end; + PtElseIfDirect: + begin + if FUseDefines then + begin + if FTopDefineRec <> nil then + begin + if FTopDefineRec^.Defined then + Inc(FDefineStack) + else + begin + if FDefineStack > 0 then + Dec(FDefineStack); + Param := DirectiveParam; + if Pos('DEFINED', Param) = 1 then + begin + Def := Copy(Param, 9, Length(Param) - 9); + EnterDefineBlock(IsDefined(Def)); + end; + end; + end; + end; + if Assigned(fOnElseIfDirect) then + fOnElseIfDirect(Self); + end; + PtIncludeDirect: + begin + if Assigned(fOnIncludeDirect) then + fOnIncludeDirect(Self); + end; + PtResourceDirect: + begin + if Assigned(fOnResourceDirect) then + fOnResourceDirect(Self); + end; + PtUndefDirect: + begin + if FUseDefines then + RemoveDefine(DirectiveParam); + if Assigned(fOnUndefDirect) then + fOnUndefDirect(Self); + end; + end; +end; + +procedure TmwBasePasLex.ColonProc; +begin + case FOrigin[Run + 1] of + '=': + begin + inc(Run, 2); + fTokenID := ptAssign; + end; + else + begin + inc(Run); + fTokenID := ptColon; + end; + end; +end; + +procedure TmwBasePasLex.CommaProc; +begin + inc(Run); + fTokenID := ptComma; +end; + +procedure TmwBasePasLex.CRProc; +begin + case fCommentState of + csBor: fTokenID := ptCRLFCo; + csAnsi: fTokenID := ptCRLFCo; + else fTokenID := ptCRLF; + end; + + case FOrigin[Run + 1] of + #10: inc(Run, 2); + else inc(Run); + end; + inc(fLineNumber); + fLinePos := Run; +end; + +procedure TmwBasePasLex.EnterDefineBlock(ADefined: Boolean); +var + StackFrame: PDefineRec; +begin + New(StackFrame); + StackFrame^.Next := FTopDefineRec; + StackFrame^.Defined := ADefined; + StackFrame^.StartCount := FDefineStack; + FTopDefineRec := StackFrame; + if not ADefined then + Inc(FDefineStack); +end; + +procedure TmwBasePasLex.EqualProc; +begin + inc(Run); + fTokenID := ptEqual; +end; + +procedure TmwBasePasLex.ExitDefineBlock; +var + StackFrame: PDefineRec; +begin + StackFrame := FTopDefineRec; + if StackFrame <> nil then + begin + FDefineStack := StackFrame^.StartCount; + FTopDefineRec := StackFrame^.Next; + Dispose(StackFrame); + end; +end; +procedure TmwBasePasLex.GreaterProc; +begin + case FOrigin[Run + 1] of + '=': + begin + inc(Run, 2); + fTokenID := ptGreaterEqual; + end; + else + begin + inc(Run); + fTokenID := ptGreater; + end; + end; +end; + +function TmwBasePasLex.HashValue(AChar: AnsiChar): Integer; +begin + if AChar <= #255 then + Result := mHashTable[fOrigin[Run]] + else + Result := Ord(AChar); +end; + +procedure TmwBasePasLex.IdentProc; +begin + fTokenID := IdentKind; +end; + +procedure TmwBasePasLex.IntegerProc; +begin + inc(Run); + fTokenID := ptIntegerConst; + while FOrigin[Run] in ['0'..'9', 'A'..'F', 'a'..'f'] do + inc(Run); +end; + +function TmwBasePasLex.IsDefined(const ADefine: string): Boolean; +begin + Result := FDefines.IndexOf(ADefine) > -1; +end; + +function TmwBasePasLex.IsIdentifiers(AChar: AnsiChar): Boolean; +begin + if AChar <= #255 then + Result := Identifiers[AChar] + else + Result := True; +end; + +procedure TmwBasePasLex.LFProc; +begin + case fCommentState of + csBor: fTokenID := ptCRLFCo; + csAnsi: fTokenID := ptCRLFCo; + else fTokenID := ptCRLF; + end; + inc(Run); + inc(fLineNumber); + fLinePos := Run; +end; + +procedure TmwBasePasLex.LowerProc; +begin + case FOrigin[Run + 1] of + '=': + begin + inc(Run, 2); + fTokenID := ptLowerEqual; + end; + '>': + begin + inc(Run, 2); + fTokenID := ptNotEqual; + end + else + begin + inc(Run); + fTokenID := ptLower; + end; + end; +end; + +procedure TmwBasePasLex.MinusProc; +begin + inc(Run); + fTokenID := ptMinus; +end; + +procedure TmwBasePasLex.NullProc; +begin + fTokenID := ptNull; +end; + +procedure TmwBasePasLex.NumberProc; +begin + inc(Run); + fTokenID := ptIntegerConst; + while FOrigin[Run] in ['0'..'9', '.', 'e', 'E'] do + begin + case FOrigin[Run] of + '.': + if FOrigin[Run + 1] = '.' then + break + else fTokenID := ptFloat + end; + inc(Run); + end; +end; + +procedure TmwBasePasLex.PlusProc; +begin + inc(Run); + fTokenID := ptPlus; +end; + +procedure TmwBasePasLex.PointerSymbolProc; +begin + inc(Run); + fTokenID := ptPointerSymbol; + + //This is a wierd Pascal construct that rarely appears, but needs to be + //supported. ^M is a valid char reference (#13, in this case) + if FOrigin[Run] in ['a'..'z','A'..'Z'] then + begin + inc(Run); + fTokenID := ptAsciiChar; + end; +end; + +procedure TmwBasePasLex.PointProc; +begin + case FOrigin[Run + 1] of + '.': + begin + inc(Run, 2); + fTokenID := ptDotDot; + end; + ')': + begin + inc(Run, 2); + fTokenID := ptSquareClose; + end; + else + begin + inc(Run); + fTokenID := ptPoint; + end; + end; +end; + +procedure TmwBasePasLex.RemoveDefine(const ADefine: string); +var + I: Integer; +begin + I := FDefines.IndexOf(ADefine); + if I > -1 then + FDefines.Delete(I); +end; + +procedure TmwBasePasLex.RoundCloseProc; +begin + inc(Run); + fTokenID := ptRoundClose; +end; + +procedure TmwBasePasLex.AnsiProc; +begin + fTokenID := ptAnsiComment; + case FOrigin[Run] of + #0: + begin + NullProc; + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unexpected file end', PosXY.X, PosXY.Y); + exit; + end; + +{ DR 2001-08-02 + #10: + begin + LFProc; + exit; + end; + + #13: + begin + CRProc; + exit; + end; +} + end; + + while fOrigin[Run] <> #0 do + case fOrigin[Run] of + '*': + if fOrigin[Run + 1] = ')' then + begin + fCommentState := csNo; + inc(Run, 2); + break; + end + else inc(Run); +{ DR 2001-08-02 + #10: break; + + #13: break; +} + #10: + begin + inc(Run); + inc(fLineNumber); + fLinePos := Run; + end; + #13: + begin + inc(Run); + if FOrigin[Run] = #10 then inc( Run ); + inc(fLineNumber); + fLinePos := Run; + end; + else inc(Run); + end; +end; + +procedure TmwBasePasLex.RoundOpenProc; +begin + inc(Run); + case fOrigin[Run] of + '*': + begin + fTokenID := ptAnsiComment; + if FOrigin[Run + 1] = '$' then + fTokenID := GetDirectiveKind + else fCommentState := csAnsi; + inc(Run); + while fOrigin[Run] <> #0 do + case fOrigin[Run] of + '*': + if fOrigin[Run + 1] = ')' then + begin + fCommentState := csNo; + inc(Run, 2); + break; + end + else inc(Run); +{ DR 2001-08-02 + #10: break; + #13: break; +} + #10: + begin + inc(Run); + inc(fLineNumber); + fLinePos := Run; + end; + #13: + begin + inc(Run); + if FOrigin[Run] = #10 then inc( Run ); + inc(fLineNumber); + fLinePos := Run; + end; + else inc(Run); + end; + end; + '.': + begin + inc(Run); + fTokenID := ptSquareOpen; + end; + else fTokenID := ptRoundOpen; + end; + case fTokenID of + PtCompDirect: + begin + if Assigned(fOnCompDirect) then + fOnCompDirect(Self); + end; + PtDefineDirect: + begin + if Assigned(fOnDefineDirect) then + fOnDefineDirect(Self); + end; + PtElseDirect: + begin + if Assigned(fOnElseDirect) then + fOnElseDirect(Self); + end; + PtEndIfDirect: + begin + if Assigned(fOnEndIfDirect) then + fOnEndIfDirect(Self); + end; + PtIfDefDirect: + begin + if Assigned(fOnIfDefDirect) then + fOnIfDefDirect(Self); + end; + PtIfNDefDirect: + begin + if Assigned(fOnIfNDefDirect) then + fOnIfNDefDirect(Self); + end; + PtIfOptDirect: + begin + if Assigned(fOnIfOptDirect) then + fOnIfOptDirect(Self); + end; + PtIncludeDirect: + begin + if Assigned(fOnIncludeDirect) then + fOnIncludeDirect(Self); + end; + PtResourceDirect: + begin + if Assigned(fOnResourceDirect) then + fOnResourceDirect(Self); + end; + PtUndefDirect: + begin + if Assigned(fOnUndefDirect) then + fOnUndefDirect(Self); + end; + end; +end; + +procedure TmwBasePasLex.SemiColonProc; +begin + inc(Run); + fTokenID := ptSemiColon; +end; + +procedure TmwBasePasLex.SlashProc; +begin + case FOrigin[Run + 1] of + '/': + begin + inc(Run, 2); + fTokenID := ptSlashesComment; + while FOrigin[Run] <> #0 do + begin + case FOrigin[Run] of + #10, #13: break; + end; + inc(Run); + end; + end; + else + begin + inc(Run); + fTokenID := ptSlash; + end; + end; +end; + +procedure TmwBasePasLex.SpaceProc; +begin + inc(Run); + fTokenID := ptSpace; + while FOrigin[Run] in [#1..#9, #11, #12, #14..#32] do + inc(Run); +end; + +procedure TmwBasePasLex.SquareCloseProc; +begin + inc(Run); + fTokenID := ptSquareClose; +end; + +procedure TmwBasePasLex.SquareOpenProc; +begin + inc(Run); + fTokenID := ptSquareOpen; +end; + +procedure TmwBasePasLex.StarProc; +begin + inc(Run); + fTokenID := ptStar; +end; + +procedure TmwBasePasLex.StringProc; +begin + fTokenID := ptStringConst; + repeat + inc(Run); + case FOrigin[Run] of + #0, #10, #13: + begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unterminated string', PosXY.X, PosXY.Y); + break; + end; + #39: + begin + while (FOrigin[Run] = #39) and (FOrigin[Run + 1] = #39) do + begin + inc(Run, 2); + end; + end; + end; + until FOrigin[Run] = #39; + if FOrigin[Run] = #39 then + begin + inc(Run); + if TokenLen = 3 then + begin + fTokenID := ptAsciiChar; + end; + end; +end; + +procedure TmwBasePasLex.SymbolProc; +begin + inc(Run); + fTokenID := ptSymbol; +end; + +procedure TmwBasePasLex.UnknownProc; +begin + inc(Run); + fTokenID := ptUnknown; + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unknown Character', PosXY.X, PosXY.Y); +end; + +procedure TmwBasePasLex.Next; +begin + fExID := ptUnKnown; + fTokenPos := Run; + case fCommentState of + csNo: + begin + DoProcTable(fOrigin[Run]); + (*{$IFDEF D10_NEWER} + if fOrigin[Run] < #256 then + fProcTable[fOrigin[Run]] + else //non-ASCII unicode char + IdentProc; + {$ELSE} + fProcTable[fOrigin[Run]]; + {$ENDIF}*) + end; + else + case fCommentState of + csBor: BorProc; + csAnsi: AnsiProc; + end; + end; +end; + + +function TmwBasePasLex.GetIsJunk: Boolean; +begin + result := IsTokenIDJunk(FTokenID) or (FUseDefines and (FDefineStack > 0) and (TokenID <> ptNull)); +// Result := fTokenID in [ptAnsiComment, ptBorComment, ptCRLF, ptCRLFCo, ptSlashesComment, ptSpace]; //XM 20001210 +end; + +function TmwBasePasLex.GetIsSpace: Boolean; +begin + Result := fTokenID in [ptCRLF, ptSpace]; +end; + +function TmwBasePasLex.GetToken: string; +begin + SetString(Result, (FOrigin + fTokenPos), GetTokenLen); +end; + +function TmwBasePasLex.GetTokenLen: Integer; +begin + Result := Run - fTokenPos; +end; + +procedure TmwBasePasLex.NextID(ID: TptTokenKind); +begin + repeat + case fTokenID of + ptNull: break; + else Next; + end; + until fTokenID = ID; +end; + +procedure TmwBasePasLex.NextNoJunk; +begin + repeat + Next; + until not IsJunk; +end; + +procedure TmwBasePasLex.NextNoSpace; +begin + repeat + Next; + until not IsSpace; +end; + +function TmwBasePasLex.FirstInLine: Boolean; +var + RunBack: Integer; +begin + Result := True; + if fTokenPos = 0 then exit; + RunBack := fTokenPos; + dec(RunBack); + while fOrigin[RunBack] in [#1..#9, #11, #12, #14..#32] do + dec(RunBack); + if RunBack = 0 then exit; + case fOrigin[RunBack] of + #10, #13: exit; + else + begin + Result := False; + exit; + end; + end; +end; + +function TmwBasePasLex.GetCommentState: Pointer; +begin + Result := Pointer(fCommentState); +end; + +function TmwBasePasLex.GetCompilerDirective: string; +var + DirectLen: Integer; +begin + if TokenID <> ptCompDirect then + Result := '' + else + case fOrigin[fTokenPos] of + '(': + begin + DirectLen := Run - fTokenPos - 4; + SetString(Result, (FOrigin + fTokenPos + 2), DirectLen); + Result := UpperCase(Result); + end; + '{': + begin + DirectLen := Run - fTokenPos - 2; + SetString(Result, (FOrigin + fTokenPos + 1), DirectLen); + Result := UpperCase(Result); + end; + end; +end; + +function TmwBasePasLex.GetDirectiveKind: TptTokenKind; +var + TempPos: Integer; +begin + case fOrigin[fTokenPos] of + '(': Run := FTokenPos + 3; + '{': Run := FTokenPos + 2; + end; + FDirectiveParamOrigin := FOrigin + FTokenPos; + TempPos := fTokenPos; + fTokenPos := Run; + case KeyHash of + 9: + if KeyComp('I') then + Result := ptIncludeDirect else + Result := ptCompDirect; + 15: + if KeyComp('IF') then + Result := ptIfDirect else + Result := ptCompDirect; + 18: + if KeyComp('R') then + begin + if not (fOrigin[Run] in ['+', '-']) then + Result := ptResourceDirect else Result := ptCompDirect; + end else Result := ptCompDirect; + 30: + if KeyComp('IFDEF') then + Result := ptIfDefDirect else + Result := ptCompDirect; + 38: + if KeyComp('ENDIF') then + Result := ptEndIfDirect else + if KeyComp('IFEND') then + Result := ptIfEndDirect else + Result := ptCompDirect; + 41: + if KeyComp('ELSE') then + Result := ptElseDirect else + Result := ptCompDirect; + 43: + if KeyComp('DEFINE') then + Result := ptDefineDirect else + Result := ptCompDirect; + 44: + if KeyComp('IFNDEF') then + Result := ptIfNDefDirect else + Result := ptCompDirect; + 50: + if KeyComp('UNDEF') then + Result := ptUndefDirect else + Result := ptCompDirect; + 56: + if KeyComp('ELSEIF') then + Result := ptElseIfDirect else + Result := ptCompDirect; + 66: + if KeyComp('IFOPT') then + Result := ptIfOptDirect else + Result := ptCompDirect; + 68: + if KeyComp('INCLUDE') then + Result := ptIncludeDirect else + Result := ptCompDirect; + 104: + if KeyComp('Resource') then + Result := ptResourceDirect else + Result := ptCompDirect; + else Result := ptCompDirect; + end; + fTokenPos := TempPos; + dec(Run); +end; + +function TmwBasePasLex.GetDirectiveParam: string; +var + EndPos: Integer; + ParamLen: Integer; +begin + // !! without this set... there is a warning? + EndPos:= 0; + case fOrigin[fTokenPos] of + '(': + begin + TempRun := FTokenPos + 3; + EndPos := Run - 2; + end; + '{': + begin + TempRun := FTokenPos + 2; + EndPos := Run - 1; + end; + end; + while IsIdentifiers(fOrigin[TempRun]) do + inc(TempRun); + while fOrigin[TempRun] in ['+', ',', '-'] do + begin + inc(TempRun); + while IsIdentifiers(fOrigin[TempRun]) do + inc(TempRun); + if (fOrigin[TempRun - 1] in ['+', ',', '-']) and (fOrigin[TempRun] = ' ') + then inc(TempRun); + end; + if fOrigin[TempRun] = ' ' then inc(TempRun); + ParamLen := EndPos - TempRun; + SetString(Result, (FOrigin + TempRun), ParamLen); + Result := UpperCase(Result); +end; + +procedure TmwBasePasLex.Init; +begin + fCommentState := csNo; + fLineNumber := 0; + fLinePos := 0; + Run := 0; + InitDefines; +end; + +procedure TmwBasePasLex.InitFrom(ALexer: TmwBasePasLex); +begin + Origin := ALexer.Origin; + fCommentState := ALexer.fCommentState; + fLineNumber := ALexer.fLineNumber; + fLinePos := ALexer.fLinePos; + Run := ALexer.Run; + CloneDefinesFrom(ALexer); +end; + +procedure TmwBasePasLex.InitDefines; +begin + ClearDefines; + //Set up the defines that are defined by the compiler + {$IFDEF VER130} + AddDefine('VER130'); + {$ENDIF} + {$IFDEF VER140} + AddDefine('VER140'); + {$ENDIF} + {$IFDEF VER150} + AddDefine('VER150'); + {$ENDIF} + {$IFDEF VER160} + AddDefine('VER160'); + {$ENDIF} + {$IFDEF VER170} + AddDefine('VER170'); + {$ENDIF} + {$IFDEF VER180} + AddDefine('VER180'); + {$ENDIF} + {$IFDEF VER185} + AddDefine('VER185'); + {$ENDIF} + {$IFDEF VER190} + AddDefine('VER190'); + {$ENDIF} + {$IFDEF VER200} + AddDefine('VER200'); + {$ENDIF} + {$IFDEF WIN32} + AddDefine('WIN32'); + {$ENDIF} + {$IFDEF LINUX} + AddDefine('LINUX'); + {$ENDIF} + {$IFDEF CPU386} + AddDefine('CPU386'); + {$ENDIF} + {$IFDEF MSWINDOWS} + AddDefine('MSWINDOWS'); + {$ENDIF} + {$IFDEF CONDITIONALEXPRESSIONS} + AddDefine('CONDITIONALEXPRESSIONS'); + {$ENDIF} + {$IFDEF UNICODE} + AddDefine('UNICODE'); + {$ENDIF} +end; + +procedure TmwBasePasLex.InitLine; +begin + fLineNumber := 0; + fLinePos := 0; + Run := 0; +end; + +procedure TmwBasePasLex.SetCommentState(const Value: Pointer); +begin + fCommentState := TCommentState(Value); +end; + +procedure TmwBasePasLex.SetLine(const Value: Ansistring); +begin + fOrigin := PAnsiChar(Value); + InitLine; + Next; +end; + +function TmwBasePasLex.GetStringContent: string; +var + TempString: string; + sEnd: Integer; +begin + if TokenID <> ptStringConst then + Result := '' + else + begin + TempString := Token; + sEnd := Length(TempString); + if TempString[sEnd] <> #39 then inc(sEnd); + Result := Copy(TempString, 2, sEnd - 2); + TempString := ''; + end; +end; + +function TmwBasePasLex.GetIsOrdIdent: Boolean; +begin + Result := False; + if fTokenID = ptIdentifier then + Result := fExID in [ptBoolean, ptByte, ptChar, ptDWord, ptInt64, ptInteger, + ptLongInt, ptLongWord, ptPChar, ptShortInt, ptSmallInt, ptWideChar, ptWord] +end; + +function TmwBasePasLex.GetIsOrdinalType: Boolean; +begin + Result := GetIsOrdIdent or (fTokenID in [ptAsciiChar, ptIntegerConst]); +end; + +function TmwBasePasLex.GetIsRealType: Boolean; +begin + Result := False; + if fTokenID = ptIdentifier then + Result := fExID in [ptComp, ptCurrency, ptDouble, ptExtended, ptReal, ptReal48, ptSingle] +end; + +function TmwBasePasLex.GetIsStringType: Boolean; +begin + Result := False; + if fTokenID = ptIdentifier then + Result := fExID in [ptAnsiString, ptWideString] + else + if fTokenID = ptString then + Result := True + else + if fTokenID = ptStringConst then Result := True; +end; + +function TmwBasePasLex.GetIsVarantType: Boolean; +begin + Result := False; + if fTokenID = ptIdentifier then + Result := fExID in [ptOleVariant, ptVariant] +end; + +function TmwBasePasLex.GetIsAddOperator: Boolean; +begin + Result := fTokenID in [ptMinus, ptOr, ptPlus, ptXor]; +end; + +function TmwBasePasLex.GetIsMulOperator: Boolean; +begin + Result := fTokenID in [ptAnd, ptAs, ptDiv, ptMod, ptShl, ptShr, ptSlash, ptStar]; +end; + +function TmwBasePasLex.GetIsRelativeOperator: Boolean; +begin + Result := fTokenID in [ptAs, ptEqual, ptGreater, ptGreaterEqual, ptLower, ptLowerEqual, + ptIn, ptIs, ptNotEqual]; +end; + +function TmwBasePasLex.GetIsCompilerDirective: Boolean; +begin + Result := fTokenID in [ptCompDirect, ptDefineDirect, ptElseDirect, + ptEndIfDirect, ptIfDefDirect, ptIfNDefDirect, ptIfOptDirect, + ptIncludeDirect, ptResourceDirect, ptUndefDirect]; +end; + +function TmwBasePasLex.GetGenID: TptTokenKind; +begin + Result := fTokenID; + if fTokenID = ptIdentifier then + if fExID <> ptUnknown then Result := fExID; +end; + +{ TmwPasLex } + +constructor TmwPasLex.Create; +begin + inherited Create; + fAheadLex := TmwBasePasLex.Create; +end; + +destructor TmwPasLex.Destroy; +begin + fAheadLex.Free; + inherited Destroy; +end; + +procedure TmwPasLex.SetOrigin(NewValue: PAnsiChar); +begin + inherited SetOrigin(NewValue); + fAheadLex.SetOrigin(NewValue); +end; + +procedure TmwPasLex.SetLine(const Value: ansistring); +begin + inherited SetLine(Value); + fAheadLex.SetLine(Value); +end; + +procedure TmwPasLex.AheadNext; +begin + fAheadLex.NextNoJunk; +end; + +function TmwPasLex.GetAheadExID: TptTokenKind; +begin + Result := fAheadLex.ExID; +end; + +function TmwPasLex.GetAheadGenID: TptTokenKind; +begin + Result := fAheadLex.GenID; +end; + +function TmwPasLex.GetAheadToken: string; +begin + Result := fAheadLex.Token; +end; + +function TmwPasLex.GetAheadTokenID: TptTokenKind; +begin + Result := fAheadLex.TokenID; +end; + +procedure TmwPasLex.InitAhead; +begin + fAheadLex.CommentState := CommentState; + fAheadLex.RunPos := RunPos; + FAheadLex.fLineNumber := FLineNumber; + FAheadLex.FLinePos := FLinePos; + + FAheadLex.CloneDefinesFrom(Self); + + //FAheadLex.FTokenPos := FTokenPos; + while fAheadLex.IsJunk do + fAheadLex.Next; +end; + +function TmwPasLex.GetStatus: TmwPasLexStatus; +begin + Result.CommentState := fCommentState; + Result.ExID := fExID; + Result.LineNumber := fLineNumber; + Result.LinePos := fLinePos; + Result.Origin := fOrigin; + Result.RunPos := Run; + Result.TokenPos := fTokenPos; + Result.TokenID := fTokenID; +end; + +procedure TmwPasLex.SetStatus(const Value: TmwPasLexStatus); +begin + fCommentState := Value.CommentState; + fExID := Value.ExID; + fLineNumber := Value.LineNumber; + fLinePos := Value.LinePos; + fOrigin := Value.Origin; + Run := Value.RunPos; + fTokenPos := Value.TokenPos; + fTokenID := Value.TokenID; + fAheadLex.Origin := Value.Origin; +end; + +procedure TmwBasePasLex.SetOnCompDirect(const Value: TDirectiveEvent); +begin + fOnCompDirect := Value; +end; + +procedure TmwBasePasLex.SetOnDefineDirect(const Value: TDirectiveEvent); +begin + fOnDefineDirect := Value; +end; + +procedure TmwBasePasLex.SetOnElseDirect(const Value: TDirectiveEvent); +begin + fOnElseDirect := Value; +end; + +procedure TmwBasePasLex.SetOnElseIfDirect(const Value: TDirectiveEvent); +begin + fOnElseIfDirect := Value; +end; + +procedure TmwBasePasLex.SetOnEndIfDirect(const Value: TDirectiveEvent); +begin + fOnEndIfDirect := Value; +end; + +procedure TmwBasePasLex.SetOnIfDefDirect(const Value: TDirectiveEvent); +begin + fOnIfDefDirect := Value; +end; + +procedure TmwBasePasLex.SetOnIfDirect(const Value: TDirectiveEvent); +begin + FOnIfDirect := Value; +end; + +procedure TmwBasePasLex.SetOnIfEndDirect(const Value: TDirectiveEvent); +begin + FOnIfEndDirect := Value; +end; + +procedure TmwBasePasLex.SetOnIfNDefDirect(const Value: TDirectiveEvent); +begin + fOnIfNDefDirect := Value; +end; + +procedure TmwBasePasLex.SetOnIfOptDirect(const Value: TDirectiveEvent); +begin + fOnIfOptDirect := Value; +end; + +procedure TmwBasePasLex.SetOnIncludeDirect(const Value: TDirectiveEvent); +begin + fOnIncludeDirect := Value; +end; + +procedure TmwBasePasLex.SetOnResourceDirect(const Value: TDirectiveEvent); +begin + fOnResourceDirect := Value; +end; + +procedure TmwBasePasLex.SetOnUnDefDirect(const Value: TDirectiveEvent); +begin + fOnUnDefDirect := Value; +end; + +procedure TmwPasLex.SetOnCompDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnCompDirect := Value; +end; + +procedure TmwPasLex.SetOnDefineDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnDefineDirect := Value; +end; + +procedure TmwPasLex.SetOnElseDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnElseDirect := Value; +end; + +procedure TmwPasLex.SetOnEndIfDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnEndIfDirect := Value; +end; + +procedure TmwPasLex.SetOnIfDefDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnIfDefDirect := Value; +end; + +procedure TmwPasLex.SetOnIfNDefDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnIfNDefDirect := Value; +end; + +procedure TmwPasLex.SetOnIfOptDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnIfOptDirect := Value; +end; + +procedure TmwPasLex.SetOnIncludeDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnIncludeDirect := Value; +end; + +procedure TmwPasLex.SetOnResourceDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnResourceDirect := Value; +end; + +procedure TmwPasLex.SetOnUnDefDirect(const Value: TDirectiveEvent); +begin + inherited; + //AheadLex.OnUnDefDirect := Value; +end; + +function TmwBasePasLex.Func86: TptTokenKind; +begin + Result := ptIdentifier; + if KeyComp('Varargs') then fExID := ptVarargs; +end; + +procedure TmwBasePasLex.StringDQProc; +begin + if not fAsmCode then + begin + SymbolProc; + Exit; + end; + fTokenID := ptStringDQConst; + repeat + inc(Run); + case FOrigin[Run] of + #0, #10, #13: + begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, 'Unterminated string', PosXY.X, PosXY.Y); + break; + end; + '\': + begin + Inc( Run ); + if FOrigin[Run] in [#32..#255] then Inc( Run ); + end; + end; + until FOrigin[Run] = '"'; + if FOrigin[Run] = '"' then + inc(Run); +end; + +{$IFDEF D8_NEWER} //JThurman 2004-04-06 +procedure TmwBasePasLex.AmpersandOpProc; +begin + FTokenID := ptAmpersand; + inc(Run); + while FOrigin[Run] in ['a'..'z', 'A'..'Z','0'..'9'] do + inc(Run); + FTokenID := ptIdentifier; +end; +{$ENDIF} + +initialization + MakeIdentTable; +end. diff --git a/source/model/sourceCodeAnalysis/CastaliaPasLexTypes.pas b/source/model/sourceCodeAnalysis/CastaliaPasLexTypes.pas new file mode 100644 index 0000000..e0c90f3 --- /dev/null +++ b/source/model/sourceCodeAnalysis/CastaliaPasLexTypes.pas @@ -0,0 +1,320 @@ +{--------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License Version +1.1 (the "License"); you may not use this file except in compliance with the +License. You may obtain a copy of the License at +http://www.mozilla.org/NPL/NPL-1_1Final.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: mwPasLexTypes, released November 14, 1999. + +The Initial Developer of the Original Code is Martin Waldenburg +unit CastaliaPasLexTypes; + +----------------------------------------------------------------------------} + +unit CastaliaPasLexTypes; + +interface + +uses SysUtils, TypInfo; + +{$INCLUDE CastaliaParserDefines.inc} + +var + CompTable: array[#0..#255] of byte; + +type + + TMessageEventType = ( meError, meNotSupported ); + + TMessageEvent = procedure(Sender: TObject; const Typ : TMessageEventType; const Msg: string; X, Y: Integer ) of object; //jdj 7/16/1999; DR 2001-11-06 + + TCommentState = (csAnsi, csBor, csNo); + + TTokenPoint = packed record + X : Integer; + Y : Integer; + end; + + TptTokenKind = ( + ptAbort, //JThurman 2004-11-8 (flow control routines) + ptAbsolute, + ptAbstract, + ptAdd, + ptAddressOp, + ptAmpersand, + ptAnd, + ptAnsiComment, + ptAnsiString, + ptArray, + ptAs, + ptAsciiChar, + ptAsm, + ptAssembler, + ptAssign, + ptAt, + ptAutomated, + ptBegin, + ptBoolean, + ptBorComment, + ptBraceClose, + ptBraceOpen, + ptBreak, //JThurman 2004-11-8 (flow control routines) + ptByte, + ptByteBool, + ptCardinal, + ptCase, + ptCdecl, + ptChar, + ptClass, + ptClassForward, + ptClassFunction, + ptClassProcedure, + ptColon, + ptComma, + ptComp, + ptCompDirect, + ptConst, + ptConstructor, + ptContains, + ptContinue, //JThurman 2004-11-8 (flow control routines) + ptCRLF, + ptCRLFCo, + ptCurrency, + ptDefault, + ptDefineDirect, + ptDeprecated, // DR 2001-10-20 + ptDestructor, + ptDispid, + ptDispinterface, + ptDiv, + ptDo, + ptDotDot, + ptDouble, + ptDoubleAddressOp, + ptDownto, + ptDWORD, + ptDynamic, + ptElse, + ptElseDirect, + ptEnd, + ptEndIfDirect, + ptEqual, + ptError, + ptExcept, + ptExit, //JThurman 2004-11-8 (flow control routine) + ptExport, + ptExports, + ptExtended, + ptExternal, + ptFar, + ptFile, + {$IFDEF D8_NEWER} //JThurman 2004-03-20 + ptFinal, + {$ENDIF} + ptFinalization, + ptFinally, + ptFloat, + ptFor, + ptForward, + ptFunction, + ptGoto, + ptGreater, + ptGreaterEqual, + ptHalt, //JThurman 2004-11-8 (flow control routines) + {$IFDEF D8_NEWER} //JThurman 2004-04-06 + ptHelper, + {$ENDIF} + ptIdentifier, + ptIf, + ptIfDirect, + ptIfEndDirect, + ptElseIfDirect, + ptIfDefDirect, + ptIfNDefDirect, + ptIfOptDirect, + ptImplementation, + ptImplements, + ptIn, + ptIncludeDirect, + ptIndex, + ptInherited, + ptInitialization, + ptInline, + ptInt64, + ptInteger, + ptIntegerConst, + ptInterface, + ptIs, + ptLabel, + ptLibrary, + ptLocal, // DR 2001-11-14 + ptLongBool, + ptLongint, + ptLongword, + ptLower, + ptLowerEqual, + ptMessage, + ptMinus, + ptMod, + ptName, + ptNear, + ptNil, + ptNodefault, + ptNone, + ptNot, + ptNotEqual, + ptNull, + ptObject, + ptOf, + ptOleVariant, + ptOn, + {$IFDEF D8_NEWER} //JThurman 2004-03-20 + ptOperator, + {$ENDIF} + ptOr, + ptOut, + ptOverload, + ptOverride, + ptPackage, + ptPacked, + ptPascal, + ptPChar, + ptPlatform, // DR 2001-10-20 + ptPlus, + ptPoint, + ptPointerSymbol, + ptPrivate, + ptProcedure, + ptProgram, + ptProperty, + ptProtected, + ptPublic, + ptPublished, + ptRaise, + ptRead, + ptReadonly, + ptReal, + ptReal48, + ptRecord, + {$IFDEF D12_NEWER} + ptReference, //JThurman 2008-25-07 (anonymous methods) + {$ENDIF} + ptRegister, + ptReintroduce, + ptRemove, + ptRepeat, + ptRequires, + ptResident, + ptResourceDirect, + ptResourcestring, + ptRoundClose, + ptRoundOpen, + ptRunError, //JThurman 2004-11-8 (flow control routines) + ptSafeCall, + {$IFDEF D8_NEWER} //JThurman 2004-03-19 + ptSealed, + {$ENDIF} + ptSemiColon, + ptSet, + ptShl, + ptShortint, + ptShortString, + ptShr, + ptSingle, + ptSlash, + ptSlashesComment, + ptSmallint, + ptSpace, + ptSquareClose, + ptSquareOpen, + ptStar, + {$IFDEF D8_NEWER} //JThurman 2004-03-20 + ptStatic, + {$ENDIF} + ptStdcall, + ptStored, + {$IFDEF D8_NEWER} + ptStrict, //JThurman 2004-03-03 + {$ENDIF} + ptString, + ptStringConst, + ptStringDQConst, // 2002-01-14 + ptStringresource, + ptSymbol, + ptThen, + ptThreadvar, + ptTo, + ptTry, + ptType, + ptUndefDirect, + ptUnit, + ptUnknown, + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + ptUnsafe, + {$ENDIF} + ptUntil, + ptUses, + ptVar, + ptVarargs, // DR 2001-11-14 + ptVariant, + ptVirtual, + ptWhile, + ptWideChar, + ptWideString, + ptWith, + ptWord, + ptWordBool, + ptWrite, + ptWriteonly, + ptXor); + +TmwPasLexStatus = record + CommentState: TCommentState; + ExID: TptTokenKind; + LineNumber: Integer; + LinePos: Integer; + Origin: PAnsiChar; + RunPos: Integer; + TokenPos: Integer; + TokenID: TptTokenKind; +end; + +const ExTypes = [ptDWORD, ptUnknown]; + +function TokenName(Value: TptTokenKind): string; +function ptTokenName(Value: TptTokenKind): string; +function IsTokenIDJunk(const aTokenID : TptTokenKind ) :Boolean; //XM 20001210 + +implementation + +function TokenName(Value: TptTokenKind): string; +begin //jdj 7/18/1999 + Result := Copy(ptTokenName(Value), 3, MaxInt); +end; + +function ptTokenName(Value: TptTokenKind): string; +begin + result := GetEnumName(TypeInfo(TptTokenKind), Integer(Value)); +end; + +function IsTokenIDJunk(const aTokenID : TptTokenKind ) :boolean; //XM 20001210 +begin + Result := aTokenID in [ptAnsiComment, ptBorComment, ptCRLF, ptCRLFCo, ptSlashesComment, ptSpace, + ptIfDirect, + ptIfEndDirect, + ptElseIfDirect, + ptIfDefDirect, + ptIfNDefDirect, + ptEndIfDirect, + ptIfOptDirect, + ptDefineDirect, + ptUndefDirect]; +end; + + +end. + diff --git a/source/model/sourceCodeAnalysis/CastaliaSimplePasPar.pas b/source/model/sourceCodeAnalysis/CastaliaSimplePasPar.pas new file mode 100644 index 0000000..7076118 --- /dev/null +++ b/source/model/sourceCodeAnalysis/CastaliaSimplePasPar.pas @@ -0,0 +1,6207 @@ +{--------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License Version +1.1 (the "License"); you may not use this file except in compliance with the +License. You may obtain a copy of the License at +http://www.mozilla.org/NPL/NPL-1_1Final.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: mwSimplePasPar.pas, released November 14, 1999. + +The Initial Developer of the Original Code is Martin Waldenburg +(Martin.Waldenburg@T-Online.de). +Portions created by Martin Waldenburg are Copyright (C) 1998, 1999 Martin +Waldenburg. +All Rights Reserved. +Portions CopyRight by Robert Zierer. + +Contributor(s): James Jacobson, Dean Hill, Vladimir Churbanov___________________. + +Last Modified: 2002/01/16 +Current Version: 1.02 + +Notes: This program is an early beginning of a Pascal parser. +I'd like to invite the Delphi community to develop it further and to create +a fully featured Object Pascal parser. + +Modification history: + +Jacob Thurman between 20040301 and 20020401 + +Made ready for Delphi 8: + +Added new directives and keywords: static, sealed, final, operator, unsafe. + +Added parsing for custom attributes (based on ECMA C# specification). + +Added support for nested types in class declarations. + +Jeff Rafter between 20020116 and 20020302 + +Added AncestorId and AncestorIdList back in, but now treat them as Qualified +Identifiers per Daniel Rolf's fix. The separation from QualifiedIdentifierList +is need for descendent classes. + +Added VarName and VarNameList back in for descendent classes, fixed to correctly +use Identifiers as in Daniel's verison + +Removed fInJunk flags (they were never used, only set) + +Pruned uses clause to remove windows dependency. This required changing +"TPoint" to "TTokenPoint". TTokenPoint was declared in mwPasLexTypes + +Daniel Rolf between 20010723 and 20020116 + +Made ready for Delphi 6 + +ciClassClass for "class function" etc. +ciClassTypeEnd marks end of a class declaration (I needed that for the delphi-objectif-connector) +ciEnumeratedTypeItem for items of enumerations +ciDirectiveXXX for the platform, deprecated, varargs, local +ciForwardDeclaration for "forward" (until now it has been read but no event) +ciIndexSpecifier for properties +ciObjectTypeEnd marks end of an object declaration +ciObjectProperty property for objects +ciObjectPropertySpecifiers property for objects +ciPropertyDefault marking default of property +ciDispIDSpecifier for dispid + +patched some functions for implementing the above things and patching the following bugs/improv.: + +ObjectProperty handling overriden properties +ProgramFile, UnitFile getting Identifier instead of dropping it +InterfaceHeritage: Qualified identifiers +bugs in variant records +typedconstant failed with complex set constants. simple patch using ConstantExpression + +German localization for the two string constants. Define GERMAN for german string constants. + +Greg Chapman on 20010522 +Better handling of defaut array property +Separate handling of X and Y in property Pixels[X, Y: Integer through identifier "event" +corrected spelling of "ForwardDeclaration" + +James Jacobson on 20010223 +semi colon before finalization fix + +James Jacobson on 20010223 +RecordConstant Fix + +Martin waldenburg on 2000107 +Even Faster lexer implementation !!!! + +James Jacobson on 20010107 + Improper handling of the construct + property TheName: Integer read FTheRecord.One.Two; (stop at second point) + where one and two are "qualifiable" structures. + +James Jacobson on 20001221 + Stops at the second const. + property Anchor[const Section: string; const Ident:string]: string read + changed TmwSimplePasPar.PropertyParameterList + +On behalf of Martin Waldenburg and James Jacobson + Correction in array property Handling (Matin and James) 07/12/2000 + Use of ExId instead of TokenId in ExportsElements (James) 07/12/2000 + Reverting to old behavior in Statementlist [PtintegerConst put back in] (James) 07/12/2000 + +Xavier Masson InnerCircleProject : XM : 08/11/2000 + Integration of the new version delivered by Martin Waldenburg with the modification I made described just below + +Xavier Masson InnerCircleProject : XM : 07/15/2000 + Added "states/events " for spaces( SkipSpace;) CRLFco (SkipCRLFco) and + CRLF (SkipCRLF) this way the parser can give a complete view on code allowing + "perfect" code reconstruction. + (I fully now that this is not what a standard parser will do but I think it is more usefull this way ;) ) + go to www.innercircleproject.com for more explanations or express your critisism ;) + +previous modifications not logged sorry ;) + +Known Issues: +-----------------------------------------------------------------------------} +{---------------------------------------------------------------------------- + Last Modified: 05/22/2001 + Current Version: 1.1 + official version + Maintained by InnerCircle + + http://www.innercircleproject.org + + 02/07/2001 + added property handling in Object types + changed handling of forward declarations in ExportedHeading method +-----------------------------------------------------------------------------} +unit CastaliaSimplePasPar; + +interface + +uses + //!! pruned uses + SysUtils, + Classes, + CastaliaPasLexTypes, + CastaliaPasLex, + CastaliaSimplePasParTypes; + +{$INCLUDE CastaliaParserDefines.inc} + +{$IFDEF GERMAN} // DR 2002-01-16 +resourcestring + rsExpected = '''%s'' erwartet, aber ''%s'' gefunden'; + rsEndOfFile = 'Dateiende'; +{$ELSE} +resourcestring + rsExpected = '''%s'' expected found ''%s'''; + rsEndOfFile = 'end of file'; +{$ENDIF} + +const + + ClassMethodDirectiveEnum = [ptAbstract, ptCdecl, ptDynamic, ptMessage, ptOverride, + ptOverload, ptPascal, ptRegister, ptReintroduce, ptSafeCall, ptStdCall, + ptVirtual, + ptDeprecated, ptLibrary, ptPlatform // DR 2001-10-20 + {$IFDEF D8_NEWER} + , ptStatic //JThurman 2004-11-10 + {$ENDIF} + {$IFDEF D9_NEWER} + , ptInline + {$ENDIF} + ]; //XM 2002-01-29 + +type + ESyntaxError = class(Exception) + private //jdj 7/18/1999 + FPosXY: TTokenPoint; + protected + + public + constructor Create(const Msg: string); + constructor CreateFmt(const Msg: string; const Args: array of const); + constructor CreatePos(const Msg: string; aPosXY: TTokenPoint); + property PosXY: TTokenPoint read FPosXY write FPosXY; + end; + + PDefineRec = ^TDefineRec; + TDefineRec = record + Defined: Boolean; + StartCount: Integer; + Next: PDefineRec; + end; + +type + TmwSimplePasPar = class(TObject) + private + FOnMessage: TMessageEvent; + fLexer: TmwPasLex; + fOwnStream: Boolean; + fStream: TCustomMemoryStream; + fInterfaceOnly: Boolean; + fLastNoJunkPos: Integer; + fLastNoJunkLen: Integer; + + FUseDefines: Boolean; + FDefines: TStrings; + + AheadParse: TmwSimplePasPar; + + + FTopDefineRec: PDefineRec; + procedure EnterDefineBlock(ADefined: Boolean); + procedure ExitDefineBlock; + procedure ClearDefines; + + procedure InitAhead; + + protected + FDefineStack: Integer; + fInRound: Boolean; +// !! removed fInJunk + procedure Expected(Sym: TptTokenKind); virtual; + procedure ExpectedEx(Sym: TptTokenKind); virtual; + procedure ExpectedFatal(Sym: TptTokenKind); virtual; + procedure HandlePtCompDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtDefineDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtElseDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtEndIfDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfDefDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfNDefDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfOptDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIncludeDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtResourceDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtUndefDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtIfEndDirect(Sender: TmwBasePasLex); virtual; + procedure HandlePtElseIfDirect(Sender: TmwBasePasLex); virtual; + procedure NextToken; virtual; + procedure SkipJunk; virtual; + procedure TerminateStream; virtual; + procedure SEMICOLON; virtual; + function GetExID: TptTokenKind; virtual; + function GetTokenID: TptTokenKind; virtual; + function GetGenID: TptTokenKind; virtual; + procedure AccessSpecifier; virtual; + procedure AdditiveOperator; virtual; + procedure AncestorIdList; virtual; // !! Added ancestorIdList back in... + procedure AncestorId; virtual; // !! Added ancestorId back in... + procedure AnonymousMethod; virtual; + procedure AnonymousMethodType; virtual; + procedure ArrayConstant; virtual; + procedure ArrayType; virtual; + procedure AsmStatement; virtual; + procedure Block; virtual; + procedure CaseLabel; virtual; + procedure CaseSelector; virtual; + procedure CaseStatement; virtual; + procedure CharString; virtual; + procedure ClassField; virtual; + procedure ClassForward; virtual; + procedure ClassFunctionHeading; virtual; + procedure ClassHeritage; virtual; + procedure ClassMemberList; virtual; + procedure ClassMethodDirective; virtual; + procedure ClassMethodHeading; virtual; + procedure ClassMethodOrProperty; virtual; + procedure ClassMethodResolution; virtual; + procedure ClassProcedureHeading; virtual; + procedure ClassClass; virtual; + procedure ClassProperty; virtual; + procedure ClassReferenceType; virtual; + procedure ClassType; virtual; + procedure ClassTypeEnd; virtual; // DR 2001-07-31 + procedure ClassVisibility; virtual; + procedure CompoundStatement; virtual; + procedure ConstantColon; virtual; + procedure ConstantDeclaration; virtual; + procedure ConstantEqual; virtual; + procedure ConstantExpression; virtual; + procedure ConstantName; virtual; +//JR added constant type + procedure ConstantType; virtual; + procedure ConstantValue; virtual; + procedure ConstantValueTyped; virtual; + procedure ConstParameter; virtual; + procedure ConstructorHeading; virtual; + procedure ConstructorName; virtual; + procedure ConstSection; virtual; + procedure ContainsClause; virtual; + procedure ContainsExpression; virtual; + procedure ContainsIdentifier; virtual; + procedure ContainsStatement; virtual; + {$IFDEF D8_NEWER} + procedure CustomAttribute; virtual; //JThurman 2004-03-03 + {$ENDIF} + procedure DeclarationSection; virtual; + procedure Designator; virtual; + procedure DestructorHeading; virtual; + procedure DestructorName; virtual; + procedure Directive16Bit; virtual; + procedure DirectiveBinding; virtual; + procedure DirectiveCalling; virtual; + procedure DirectiveDeprecated; virtual; // DR 2001-10-20 + procedure DirectiveLibrary; virtual; // DR 2001-10-20 + procedure DirectiveLocal; virtual; // DR 2001-11-14 + procedure DirectivePlatform; virtual; // DR 2001-10-20 + procedure DirectiveVarargs; virtual; // DR 2001-11-14 + procedure DispInterfaceForward; virtual; + procedure DispIDSpecifier; virtual; // DR 2001-07-26 + procedure EmptyStatement; virtual; + procedure EnumeratedType; virtual; + procedure EnumeratedTypeItem; virtual; // DR 2001-10-29 + procedure ExceptBlock; virtual; + procedure ExceptionBlockElseBranch; virtual; + procedure ExceptionClassTypeIdentifier; virtual; + procedure ExceptionHandler; virtual; + procedure ExceptionHandlerList; virtual; + procedure ExceptionIdentifier; virtual; + procedure ExceptionVariable; virtual; + procedure ExplicitType; virtual; // !! changed spelling to "Explicit" + procedure ExportedHeading; virtual; + procedure ExportsClause; virtual; + procedure ExportsElement; virtual; + procedure Expression; virtual; + procedure ExpressionList; virtual; + procedure ExternalDirective; virtual; + procedure ExternalDirectiveThree; virtual; + procedure ExternalDirectiveTwo; virtual; + procedure Factor; virtual; + procedure FieldDeclaration; virtual; + procedure FieldList; virtual; + procedure FieldNameList; virtual; + procedure FieldName; virtual; + procedure FileType; virtual; + procedure FormalParameterList; virtual; + procedure FormalParameterSection; virtual; + procedure ForStatement; virtual; + procedure ForwardDeclaration; virtual; {GLC: corrected spelling} + procedure FunctionHeading; virtual; + procedure FunctionMethodDeclaration; virtual; + procedure FunctionMethodName; virtual; + procedure FunctionProcedureBlock; virtual; + procedure FunctionProcedureName; virtual; + procedure Identifier; virtual; + procedure IdentifierList; virtual; + procedure IfStatement; virtual; + procedure ImplementationSection; virtual; + procedure IncludeFile; virtual; + procedure IndexSpecifier; virtual; // DR 2001-07-26 + procedure InheritedStatement; virtual; + procedure InitializationSection; virtual; + procedure InlineStatement; virtual; + procedure InParameter; virtual; + procedure InterfaceDeclaration; virtual; + procedure InterfaceForward; virtual; + procedure InterfaceGUID; virtual; + procedure InterfaceHeritage; virtual; + procedure InterfaceMemberList; virtual; + procedure InterfaceSection; virtual; + procedure InterfaceType; virtual; + procedure LabelDeclarationSection; virtual; + procedure LabeledStatement; virtual; + procedure LabelId; virtual; + procedure LibraryFile; virtual; + procedure MainUsedUnitExpression; virtual; + procedure MainUsedUnitName; virtual; + procedure MainUsedUnitStatement; virtual; + procedure MainUsesClause; virtual; + procedure MultiplicativeOperator; virtual; + procedure NewFormalParameterType; virtual; + procedure Number; virtual; + procedure ObjectConstructorHeading; virtual; + procedure ObjectDestructorHeading; virtual; + procedure ObjectField; virtual; + procedure ObjectForward; virtual; + procedure ObjectFunctionHeading; virtual; + procedure ObjectHeritage; virtual; + procedure ObjectMemberList; virtual; + procedure ObjectMethodDirective; virtual; + procedure ObjectMethodHeading; virtual; + procedure ObjectNameOfMethod; virtual; + procedure ObjectProperty; virtual; + procedure ObjectPropertySpecifiers; virtual; + procedure ObjectProcedureHeading; virtual; + procedure ObjectType; virtual; + procedure ObjectTypeEnd; virtual; // DR 2001-08-07 + procedure ObjectVisibility; virtual; + procedure OldFormalParameterType; virtual; + procedure OrdinalIdentifier; virtual; + procedure OrdinalType; virtual; + procedure OutParameter; virtual; + procedure PackageFile; virtual; + procedure ParameterFormal; virtual; + procedure ParameterName; virtual; + procedure ParameterNameList; virtual; + procedure ParseFile; virtual; + procedure PointerType; virtual; + procedure ProceduralDirective; virtual; + procedure ProceduralType; virtual; + procedure ProcedureDeclarationSection; virtual; + procedure ProcedureHeading; virtual; + procedure ProcedureMethodDeclaration; virtual; + procedure ProcedureMethodName; virtual; + procedure ProgramBlock; virtual; + procedure ProgramFile; virtual; + procedure PropertyDefault; virtual; + procedure PropertyInterface; virtual; + procedure PropertyName; virtual; + procedure PropertyParameterConst; virtual; + procedure PropertyParameterList; virtual; + procedure PropertySpecifiers; virtual; + procedure QualifiedIdentifier; virtual; + procedure QualifiedIdentifierList; virtual; + procedure RaiseStatement; virtual; + procedure ReadAccessIdentifier; virtual; + procedure RealIdentifier; virtual; + procedure RealType; virtual; + procedure RecordConstant; virtual; + procedure RecordFieldConstant; virtual; + procedure RecordType; virtual; + procedure RecordVariant; virtual; + procedure RelativeOperator; virtual; + procedure RepeatStatement; virtual; + procedure RequiresClause; virtual; + procedure RequiresIdentifier; virtual; + procedure ResolutionInterfaceName; virtual; + procedure ResourceDeclaration; virtual; + procedure ReturnType; virtual; + procedure SetConstructor; virtual; + procedure SetElement; virtual; + procedure SetType; virtual; + procedure SimpleExpression; virtual; + procedure SimpleStatement; virtual; + procedure SimpleType; virtual; + procedure SkipAnsiComment; virtual; + procedure SkipBorComment; virtual; + procedure SkipSlashesComment; virtual; + procedure SkipSpace; virtual; //XM Jul-2000 + procedure SkipCRLFco; virtual; //XM Jul-2000 + procedure SkipCRLF; virtual; //XM Jul-2000 + procedure Statement; virtual; + procedure StatementList; virtual; + procedure StorageExpression; virtual; + procedure StorageIdentifier; virtual; + procedure StorageDefault; virtual; + procedure StorageNoDefault; virtual; + procedure StorageSpecifier; virtual; + procedure StorageStored; virtual; + procedure StringIdentifier; virtual; + procedure StringStatement; virtual; + procedure StringType; virtual; + procedure StructuredType; virtual; + procedure SubrangeType; virtual; + procedure TagField; virtual; + procedure TagFieldName; virtual; + procedure TagFieldTypeName; virtual; + procedure Term; virtual; + procedure TryStatement; virtual; + procedure TypedConstant; virtual; + procedure TypeDeclaration; virtual; + procedure TypeId; virtual; + procedure TypeKind; virtual; + procedure TypeName; virtual; + //generics + procedure TypeArgs; virtual; + procedure TypeParams; virtual; + procedure TypeParamDecl; virtual; + procedure TypeParamDeclList; virtual; + procedure TypeParamList; virtual; + procedure ConstraintList; virtual; + procedure Constraint; virtual; + //end generics + procedure TypeSection; virtual; + procedure UnitFile; virtual; + procedure UnitId; virtual; + procedure UnitName; virtual; + procedure UsedUnitName; virtual; + procedure UsedUnitsList; virtual; + procedure UsesClause; virtual; + procedure VarAbsolute; virtual; + procedure VarEqual; virtual; + procedure VarDeclaration; virtual; + procedure Variable; virtual; + procedure VariableList; virtual; + procedure VariableReference; virtual; + procedure VariableTwo; virtual; + procedure VariantIdentifier; virtual; + procedure VariantSection; virtual; + procedure VarParameter; virtual; + procedure VarName; virtual; //!! Added VarName and VarNameList back in... + procedure VarNameList; virtual; + procedure VarSection; virtual; + procedure VisibilityAutomated; virtual; + procedure VisibilityPrivate; virtual; + procedure VisibilityProtected; virtual; + procedure VisibilityPublic; virtual; + procedure VisibilityPublished; virtual; + procedure VisibilityUnknown; virtual; + procedure WhileStatement; virtual; + procedure WithStatement; virtual; + procedure WriteAccessIdentifier; virtual; + {$IFDEF D8_NEWER}//JThurman 2004-03-21 + {This is the syntax for custom attributes, based quite strictly on the + ECMA syntax specifications for C#, but with a Delphi expression being + used at the bottom as opposed to a C# expression} + procedure GlobalAttributes; + procedure GlobalAttributeSections; + procedure GlobalAttributeSection; + procedure GlobalAttributeTargetSpecifier; + procedure GlobalAttributeTarget; + procedure Attributes; + procedure AttributeSections; + procedure AttributeSection; + procedure AttributeTargetSpecifier; + procedure AttributeTarget; + procedure AttributeList; + procedure Attribute; + procedure AttributeName; + procedure AttributeArguments; + procedure PositionalArgumentList; + procedure PositionalArgument; + procedure NamedArgumentList; + procedure NamedArgument; + procedure AttributeArgumentExpression; + {$ENDIF} + property ExID: TptTokenKind read GetExID; + property GenID: TptTokenKind read GetGenID; + property TokenID: TptTokenKind read GetTokenID; + public + constructor Create; + destructor Destroy; override; + procedure SynError(Error: TmwParseError); virtual; + procedure Run(UnitName: string; SourceStream: TCustomMemoryStream); virtual; + + procedure InitDefines; + procedure AddDefine(const ADefine: string); + procedure RemoveDefine(const ADefine: string); + function IsDefined(const ADefine: string): Boolean; + + property InterfaceOnly: Boolean read fInterfaceOnly write fInterfaceOnly; + property Lexer: TmwPasLex read fLexer; + property OnMessage: TMessageEvent read FOnMessage write FOnMessage; + property LastNoJunkPos: Integer read fLastNoJunkPos; + property LastNoJunkLen: Integer read fLastNoJunkLen; + + property UseDefines: Boolean read FUseDefines write FUseDefines; + published + end; + +implementation + +uses Windows; + +{ ESyntaxError } + +constructor ESyntaxError.Create(const Msg: string); +begin + // !! changed initialization for TTokenPoint + FPosXY.X:= -1; + FPosXY.Y:= -1; + inherited Create(Msg); +end; + +constructor ESyntaxError.CreateFmt(const Msg: string; const Args: array of const); +begin + // !! changed initialization for TTokenPoint + FPosXY.X:= -1; + FPosXY.Y:= -1; + inherited CreateFmt(Msg, Args); +end; + +constructor ESyntaxError.CreatePos(const Msg: string; aPosXY: TTokenPoint); +begin + Message := Msg; + FPosXY := aPosXY; +end; + +{ TmwSimplePasPar } +(* DR 2002-01-16 +const + cnExpected = 'Expected ''%s'' found ''%s'''; +// cnOrExpected = 'Expected ''%s'' or ''%s'' found ''%s'''; + cnEndOfFile = 'end of file'; {jdj 7/22/1999} +// cnIntegerOverflow = 'Integer constant too large'; {jdj 7/22/1999} +*) + + {range checks a ptIntegerConst-slightly faster than StrToInt} +{function IsValidInteger(const S: string): Boolean; jdj 7/22/1999 +var jdj removed 02/07/2001 + C: Integer; + N: Integer; +begin + Val(S, N, C); + Result := (C = 0); +end;} + +procedure TmwSimplePasPar.ForwardDeclaration; +begin {jdj added method 02/07/2001} + NextToken; + SEMICOLON; +end; + +procedure TmwSimplePasPar.ObjectProperty; +begin {jdj added method 02/07/2001} + // DR 2001-08-07 -> changed. for array-property override failure + Expected(ptProperty); + PropertyName; + case TokenID of + ptColon, ptSquareOpen: + begin + PropertyInterface; + end; + end; + ObjectPropertySpecifiers; + case ExID of + ptDefault: + begin + PropertyDefault; //DR 2001-07-16 + SEMICOLON; + end; + end; +end; + +procedure TmwSimplePasPar.ObjectPropertySpecifiers; +begin {jdj added method 02/07/2001} + if ExID = ptIndex then + begin + IndexSpecifier; // DR 2001-08-07 + end; + while ExID in [ptRead, ptReadOnly, ptWrite, ptWriteOnly] do + begin + AccessSpecifier; + end; + while ExID in [ptDefault, ptNoDefault, ptStored] do + begin + StorageSpecifier; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.Run(UnitName: string; SourceStream: TCustomMemoryStream); +begin + fStream := nil; + fOwnStream := False; + {if SourceStream = nil then + begin + fStream := TMemoryStream.Create; + fOwnStream := True; + fStream.LoadFromFile(UnitName); + end + else} + fStream := SourceStream; + TerminateStream; + fLexer.Origin := fStream.Memory; + ParseFile; + if fOwnStream then + fStream.Free; +end; + +constructor TmwSimplePasPar.Create; +begin + inherited Create; + fLexer := TmwPasLex.Create; + fLexer.OnCompDirect := HandlePtCompDirect; + fLexer.OnDefineDirect := HandlePtDefineDirect; + fLexer.OnElseDirect := HandlePtElseDirect; + fLexer.OnEndIfDirect := HandlePtEndIfDirect; + fLexer.OnIfDefDirect := HandlePtIfDefDirect; + fLexer.OnIfNDefDirect := HandlePtIfNDefDirect; + fLexer.OnIfOptDirect := HandlePtIfOptDirect; + fLexer.OnIncludeDirect := HandlePtIncludeDirect; + fLexer.OnResourceDirect := HandlePtResourceDirect; + fLexer.OnUnDefDirect := HandlePtUndefDirect; + fLexer.OnIfDirect := HandlePtIfDirect; + fLexer.OnIfEndDirect := HandlePtIfEndDirect; + fLexer.OnElseIfDirect := HandlePtElseIfDirect; + + FDefines := TStringList.Create; + with TStringList(FDefines) do + begin + Sorted := True; + Duplicates := dupIgnore; + end; + InitDefines; + FDefineStack := 0; + FUseDefines := False; +end; + +destructor TmwSimplePasPar.Destroy; +begin + ClearDefines; //Must do this here to avoid a memory leak + FDefines.Free; + + AheadParse.Free; + + fLexer.Free; + inherited Destroy; +end; + +{next two check for ptNull and ExpectedFatal for an EOF Error} + +procedure TmwSimplePasPar.Expected(Sym: TptTokenKind); +begin + if Sym <> Lexer.TokenID then + begin + if TokenID = ptNull then + ExpectedFatal(Sym) {jdj 7/22/1999} + else + begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, Format(rsExpected, [TokenName(Sym), fLexer.Token]), + fLexer.PosXY.X, fLexer.PosXY.Y); + end; + end + else + NextToken; +end; + +procedure TmwSimplePasPar.ExpectedEx(Sym: TptTokenKind); +begin + if Sym <> Lexer.ExID then + begin + if Lexer.TokenID = ptNull then + ExpectedFatal(Sym) {jdj 7/22/1999} + else if Assigned(FOnMessage) then + FOnMessage(Self, meError, Format(rsExpected, ['EX:' + TokenName(Sym), fLexer.Token]), + fLexer.PosXY.X, fLexer.PosXY.Y); + end + else + NextToken; +end; + +{Replace Token with cnEndOfFile if TokenId = ptnull} + +procedure TmwSimplePasPar.ExpectedFatal(Sym: TptTokenKind); +var + tS: string; +begin + if Sym <> Lexer.TokenID then + begin + {--jdj 7/22/1999--} + if Lexer.TokenId = ptNull then + tS := rsEndOfFile + else + tS := fLexer.Token; + {--jdj 7/22/1999--} + raise ESyntaxError.CreatePos(Format(rsExpected, [TokenName(Sym), tS]), fLexer.PosXY); + end + else + NextToken; +end; + +procedure TmwSimplePasPar.HandlePtCompDirect(Sender: TmwBasePasLex); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); + // Sender.NextNoJunk; + Sender.Next; //XM Jul-2000 + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtDefineDirect(Sender: TmwBasePasLex); +begin +// if Assigned(FOnMessage) then +// FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); + +// if FUseDefines then +// AddDefine(Lexer.DirectiveParam); +// else + + // Sender.NextNoJunk; + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtElseDirect(Sender: TmwBasePasLex); +begin +// if Assigned(FOnMessage) then +// FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); + +// if FUseDefines then +// begin +// if FTopDefineRec <> nil then +// begin +// if FTopDefineRec^.Defined then +// Inc(FDefineStack) +// else +// if FDefineStack > 0 then +// Dec(FDefineStack); +// end; +// end; + + // Sender.NextNoJunk; + if Sender = Lexer then + NextToken + else + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtElseIfDirect(Sender: TmwBasePasLex); +var + Param: string; + Def: string; +begin +// if FUseDefines then +// begin +// if FTopDefineRec <> nil then +// begin +// if FTopDefineRec^.Defined then +// Inc(FDefineStack) +// else +// begin +// if FDefineStack > 0 then +// Dec(FDefineStack); +// Param := Sender.DirectiveParam; +// if Pos('DEFINED', Param) = 1 then +// begin +// Def := Copy(Param, 9, Length(Param) - 9); +// EnterDefineBlock(IsDefined(Def)); +// end; +// end; +// end; +// end; + + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtEndIfDirect(Sender: TmwBasePasLex); +begin +// if Assigned(FOnMessage) then +// FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); + +// if FUseDefines then +// begin +// ExitDefineBlock; +// end; + + // Sender.NextNoJunk; + if Sender = Lexer then + NextToken + else + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtIfDefDirect(Sender: TmwBasePasLex); +begin +// if Assigned(FOnMessage) then +// FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); +// if FUseDefines then +// begin +// EnterDefineBlock(IsDefined(Sender.DirectiveParam)); +// end; + + // Sender.NextNoJunk; + if Sender = Lexer then + NextToken + else + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtIfDirect(Sender: TmwBasePasLex); +var + Def: string; + Param: string; +begin +// Param := Sender.DirectiveParam; +// if FUseDefines then +// begin +// if Pos('DEFINED', Param) = 1 then +// begin +// Def := Copy(Param, 9, Length(Param) - 9); +// EnterDefineBlock(IsDefined(Def)); +// end; +// end; + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtIfEndDirect(Sender: TmwBasePasLex); +begin +// if FUseDefines then +// ExitDefineBlock; + + if Sender = Lexer then + NextToken + else + Sender.Next; +end; + +procedure TmwSimplePasPar.HandlePtIfNDefDirect(Sender: TmwBasePasLex); +begin +// if Assigned(FOnMessage) then +// FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); +// if FUseDefines then +// begin +// EnterDefineBlock(not IsDefined(Sender.DirectiveParam)); +// end; + + // Sender.NextNoJunk; + if Sender = Lexer then + NextToken + else + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtIfOptDirect(Sender: TmwBasePasLex); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); + // Sender.NextNoJunk; + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtIncludeDirect(Sender: TmwBasePasLex); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); + // Sender.NextNoJunk; + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtResourceDirect(Sender: TmwBasePasLex); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); + // Sender.NextNoJunk; + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.HandlePtUndefDirect(Sender: TmwBasePasLex); +begin +// if Assigned(FOnMessage) then +// FOnMessage(Self, meNotSupported, 'Currently not supported ' + fLexer.Token, fLexer.PosXY.X, fLexer.PosXY.Y); + +// if FUseDefines then +// RemoveDefine(Lexer.DirectiveParam); + + // Sender.NextNoJunk; + Sender.Next; //XM Jul-2000 + + { ToDo } +end; + +procedure TmwSimplePasPar.NextToken; +begin +// if FUseDefines then +// begin +// repeat +// FLexer.Next; +// until (FDefineStack = 0) or (TokenID = ptNull); +// SkipJunk; +// end else +// begin + FLexer.NextNoJunk; + //fLexer.Next; + //SkipJunk; +// end; +end; + +procedure TmwSimplePasPar.SkipJunk; +begin + if Lexer.IsJunk then + begin + case TokenID of + ptAnsiComment: + begin + SkipAnsiComment; + end; + ptBorComment: + begin + SkipBorComment; + end; + ptSlashesComment: + begin + SkipSlashesComment; + end; + ptSpace: + begin + SkipSpace; //XM Jul-2000 + end; + ptCRLFCo: + begin + SkipCRLFco; + end; + ptCRLF: + begin + SkipCRLF; + end; + {$IFDEF D8_NEWER} //JThurman 2004-3-19 + ptSquareOpen: + begin + CustomAttribute; + end; + {$ENDIF} + else + begin + Lexer.Next; + end; + end; + end; + fLastNoJunkPos := Lexer.TokenPos; + fLastNoJunkLen := Lexer.TokenLen; +end; + +procedure TmwSimplePasPar.SkipAnsiComment; +begin + Expected(ptAnsiComment); + while TokenID in [ptAnsiComment] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.SkipBorComment; +begin + Expected(ptBorComment); + while TokenID in [ptBorComment] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.SkipSlashesComment; +begin + Expected(ptSlashesComment); +end; + +procedure TmwSimplePasPar.TerminateStream; +var + aChar: Char; +begin + fStream.Position := fStream.Size; + aChar := #0; + fStream.Write(aChar, sizeof(char)); +end; + +procedure TmwSimplePasPar.SEMICOLON; +begin + case Lexer.TokenID of + ptElse, ptEnd, ptExcept, ptfinally, ptFinalization, ptRoundClose, ptUntil: // jdj 2.23.20001 added ptFinalization + ; + else + Expected(ptSemiColon); + //Check for semicolon before else - common syntax error - JT 11.10.2007 + //Doesn't work here - it fails a CASE statement +// if Lexer.TokenID = ptElse then +// begin +// if Assigned(FOnMessage) then +// begin +// FOnMessage(Self, meError, ''';'' not allowed before ''ELSE''', +// FLexer.PosXY.X, FLexer.PosXY.Y); +// end; +// end; + end; +end; + +function TmwSimplePasPar.GetExID: TptTokenKind; +begin + Result := fLexer.ExID; +end; + +function TmwSimplePasPar.GetTokenID: TptTokenKind; +begin + Result := fLexer.TokenID; +end; + +function TmwSimplePasPar.GetGenID: TptTokenKind; +begin + Result := fLexer.GenID; +end; + +procedure TmwSimplePasPar.SynError(Error: TmwParseError); +begin + if Assigned(FOnMessage) then + FOnMessage(Self, meError, ParserErrorName(Error) + ' found ' + fLexer.Token, fLexer.PosXY.X, + fLexer.PosXY.Y); + +end; + +(****************************************************************************** + This part is oriented at the official grammar of Delphi 4 + and parialy based on Robert Zierers Delphi grammar. + For more information about Delphi grammars take a look at: + http://www.stud.mw.tu-muenchen.de/~rz1/Grammar.html +******************************************************************************) + +procedure TmwSimplePasPar.ParseFile; +var + I: Integer; +begin +// OutputDebugString('ParseFile'); + //Copy the defines into the lexer + for I := 0 to FDefines.Count - 1 do + begin + Lexer.AddDefine(FDefines[I]); + end; + + SkipJunk; + case GenID of + ptLibrary: + begin + LibraryFile; + end; + ptPackage: + begin + PackageFile; + end; + ptProgram: + begin + ProgramFile; + end; + ptUnit: + begin + UnitFile; + end; + else + begin + IncludeFile; + end; + end; +end; + +procedure TmwSimplePasPar.LibraryFile; +begin + Expected(ptLibrary); + Expected(ptIdentifier); + SEMICOLON; + ProgramBlock; + Expected(ptPoint); +end; + +procedure TmwSimplePasPar.PackageFile; +begin + ExpectedEx(ptPackage); + Expected(ptIdentifier); + + {$IFDEF D8_NEWER} + while Lexer.TokenID = ptPoint do + begin + NextToken; + Expected(ptIdentifier); + end; + {$ENDIF} + + SEMICOLON; + case ExID of + ptRequires: + begin + RequiresClause; + end; + end; + case ExID of + ptContains: + begin + ContainsClause; + end; + end; + + {$IFDEF D8_NEWER} + while Lexer.TokenID = ptSquareOpen do + begin + CustomAttribute; + end; + {$ENDIF} + + Expected(ptEnd); + Expected(ptPoint); +end; + +procedure TmwSimplePasPar.ProgramFile; +begin + // DR 2002-01-11 + Expected(ptProgram); + QualifiedIdentifier; + if TokenID = ptRoundOpen then + begin + NextToken; + IdentifierList; + Expected(ptRoundClose); + end; + if not InterfaceOnly then + begin + SEMICOLON; + ProgramBlock; + Expected(ptPoint); + end; +end; + +procedure TmwSimplePasPar.UnitFile; +begin + // DR 2002-01-11 + +//?? + Expected(ptUnit); + UnitName; + + while ExID in [ptDeprecated, ptLibrary, ptPlatform] do + case ExID of + ptDeprecated: DirectiveDeprecated; + ptLibrary: DirectiveLibrary; + ptPlatform: DirectivePlatform; + end; + + SEMICOLON; + InterfaceSection; + if not InterfaceOnly then + begin + ImplementationSection; + InitializationSection; + Expected(ptPoint); + end; +end; + +procedure TmwSimplePasPar.ProgramBlock; +begin + if TokenID = ptUses then + begin + MainUsesClause; + end; + Block; +end; + +procedure TmwSimplePasPar.MainUsesClause; +begin + Expected(ptUses); + MainUsedUnitStatement; + while TokenID = ptComma do + begin + NextToken; + MainUsedUnitStatement; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.MainUsedUnitStatement; +begin + MainUsedUnitName; + if Lexer.TokenID = ptIn then + begin + NextToken; + MainUsedUnitExpression; + end; +end; + +procedure TmwSimplePasPar.MainUsedUnitName; +begin +// Expected(ptIdentifier); + UsedUnitName; //JThurman 2004-11-10 +end; + +procedure TmwSimplePasPar.MainUsedUnitExpression; +begin + ConstantExpression; +end; + +procedure TmwSimplePasPar.UsesClause; +begin + Expected(ptUses); + UsedUnitsList; + SEMICOLON; +end; + +procedure TmwSimplePasPar.UsedUnitsList; +begin + UsedUnitName; + while TokenID = ptComma do + begin + NextToken; + UsedUnitName; + end; +end; + +procedure TmwSimplePasPar.UsedUnitName; +begin + {$IFDEF D8_NEWER} //JThurman 2004-03-03 + Expected(ptIdentifier); + while TokenID = ptPoint do + begin + NextToken; + Expected(ptIdentifier); + end; + {$ELSE} + Expected(ptIdentifier); + {$ENDIF} +end; + +procedure TmwSimplePasPar.Block; +begin + while TokenID in [ptClass, ptConst, ptConstructor, ptDestructor, ptExports, + ptFunction, ptLabel, ptProcedure, ptResourceString, ptThreadVar, ptType, + ptVar{$IFDEF D8_NEWER}, ptSquareOpen{$ENDIF}] do + begin + DeclarationSection; + end; + case TokenID of + ptAsm: + begin + AsmStatement; + end; + else + begin + CompoundStatement; + end; + end; +end; + +procedure TmwSimplePasPar.DeclarationSection; +begin + case TokenID of + ptClass: + begin + ProcedureDeclarationSection; + end; + ptConst: + begin + ConstSection; + end; + ptConstructor: + begin + ProcedureDeclarationSection; + end; + ptDestructor: + begin + ProcedureDeclarationSection; + end; + ptExports: + begin + ExportsClause; + end; + ptFunction: + begin + ProcedureDeclarationSection; + end; + ptLabel: + begin + LabelDeclarationSection; + end; + ptProcedure: + begin + ProcedureDeclarationSection; + end; + ptResourceString: + begin + ConstSection; + end; + ptType: + begin + TypeSection; + end; + ptThreadVar: + begin + VarSection; + end; + ptVar: + begin + VarSection; + end; + {$IFDEF D8_NEWER} //JThurman + ptSquareOpen: + begin + CustomAttribute; + end; + {$ENDIF} + else + begin + SynError(InvalidDeclarationSection); + end; + end; +end; + +procedure TmwSimplePasPar.UnitId; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.UnitName; +begin + Expected(ptIdentifier); + while Lexer.TokenID = ptPoint do + begin + NextToken; + Expected(ptIdentifier); + end; +end; + +procedure TmwSimplePasPar.InterfaceHeritage; +begin + Expected(ptRoundOpen); + AncestorIdList; // JR moved qualified check into ancestorIdList // DR 2001-11-01 can also be qualified! + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.InterfaceGUID; +begin + Expected(ptSquareOpen); + CharString; + Expected(ptSquareClose); +end; + +procedure TmwSimplePasPar.AccessSpecifier; +begin + case ExID of + ptRead: + begin + NextToken; + ReadAccessIdentifier; + end; + ptWrite: + begin + NextToken; + WriteAccessIdentifier; + end; + ptReadOnly: + begin + NextToken; + end; + ptWriteOnly: + begin + NextToken; + end; + {$IFDEF D8_NEWER} + ptAdd: + begin + NextToken; + QualifiedIdentifier; //TODO: AddAccessIdentifier + end; + ptRemove: + begin + NextToken; + QualifiedIdentifier; //TODO: RemoveAccessIdentifier + end; + {$ENDIF} + else + begin + SynError(InvalidAccessSpecifier); + end; + end; +end; + +procedure TmwSimplePasPar.ReadAccessIdentifier; +begin + QualifiedIdentifier; + (* XM removed at Martin suggestion. Martin send a more general fix in QualifiedIdentifier + //jdj 12/05/2000 + if (TokenID = ptSquareOpen) then + begin + ConstantExpression; + end; + //jdj 12/05/2000*) +end; + +procedure TmwSimplePasPar.WriteAccessIdentifier; +begin + QualifiedIdentifier; + (* XM removed at Martin suggestion. Martin send a more general fix in QualifiedIdentifier + //jdj 12/05/2000 + if (TokenID = ptSquareOpen) then + begin + ConstantExpression; + end; + //jdj 12/05/2000*) +end; + +procedure TmwSimplePasPar.StorageSpecifier; +begin + case ExID of + ptStored: + begin + StorageStored; + end; + ptDefault: + begin + StorageDefault; + end; + ptNoDefault: + begin + StorageNoDefault; + end + else + begin + SynError(InvalidStorageSpecifier); + end; + end; +end; + +procedure TmwSimplePasPar.StorageDefault; +begin + ExpectedEx(ptDefault); + StorageExpression; +end; + +procedure TmwSimplePasPar.StorageNoDefault; +begin + ExpectedEx(ptNoDefault); +end; + +procedure TmwSimplePasPar.StorageStored; +begin + ExpectedEx(ptStored); + case TokenID of + ptIdentifier: + begin + StorageIdentifier; + end; + else + if TokenID <> ptSemiColon then + begin + StorageExpression; + end; + end; +end; + +procedure TmwSimplePasPar.StorageExpression; +begin + ConstantExpression; +end; + +procedure TmwSimplePasPar.StorageIdentifier; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.PropertyParameterList; +//changed James Jacobson on 20001221 +begin + Expected(ptSquareOpen); + if TokenID = ptConst then + begin + PropertyParameterConst; + end; + IdentifierList; + Expected(ptColon); + TypeId; + while TokenID = ptSemiColon do + begin + SEMICOLON; + if TokenID = ptConst then + begin //jdj 12-21-2000 + PropertyParameterConst; + end; + IdentifierList; + Expected(ptColon); + TypeId; + end; + Expected(ptSquareClose); +end; + +(*begin + Expected(ptSquareOpen); + if TokenID = ptConst then + begin + PropertyParameterConst; + end; + IdentifierList; + Expected(ptColon); + TypeId; + while TokenID = ptSemiColon do + begin + SEMICOLON; + IdentifierList; + Expected(ptColon); + TypeId; + end; + Expected(ptSquareClose); +end;*) + +procedure TmwSimplePasPar.PropertyParameterConst; +begin + Expected(ptConst); +end; + +procedure TmwSimplePasPar.PropertySpecifiers; +begin + if ExID = ptIndex then + begin + IndexSpecifier; // DR 2001-07-26 + end; + while ExID in [ptRead, ptReadOnly, ptWrite, ptWriteOnly + {$IFDEF D8_NEWER}, ptAdd, ptRemove{$ENDIF}] do + begin + AccessSpecifier; + end; + if ExID = ptDispId then + begin + DispIDSpecifier; // DR 2001-07-26 + end; + while ExID in [ptDefault, ptNoDefault, ptStored] do + begin + StorageSpecifier; + end; + if ExID = ptImplements then + begin + NextToken; + QualifiedIdentifierList; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.PropertyInterface; +begin + if TokenID = ptSquareOpen then + begin + PropertyParameterList; + end; + Expected(ptColon); + TypeID; +end; + +procedure TmwSimplePasPar.ClassMethodHeading; +begin + case TokenID of + ptConstructor: + begin + ConstructorHeading; + end; + ptDestructor: + begin + DestructorHeading; + end; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + ptFunction, ptIdentifier: + begin + if (TokenID = ptIdentifier) and (Lexer.ExID <> ptOperator) then + Expected(ptOperator); + {$ELSE} + ptFunction: + begin + {$ENDIF} + Lexer.InitAhead; + Lexer.AheadNext; + case Lexer.AheadTokenID of + PtPoint: + begin + ClassMethodResolution; + end; + else + begin + ClassFunctionHeading; + end; + end; + end; + ptProcedure: + begin + Lexer.InitAhead; + Lexer.AheadNext; + case Lexer.AheadTokenID of + PtPoint: + begin + ClassMethodResolution; + end; + else + begin + ClassProcedureHeading; + end; + end; + end; + else + SynError(InvalidClassMethodHeading); + end; +end; + +procedure TmwSimplePasPar.ClassFunctionHeading; +begin + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + if (TokenID = ptIdentifier) and (Lexer.ExID = ptOperator) then + Expected(ptIdentifier) else + {$ENDIF} + Expected(ptFunction); + FunctionMethodName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + Expected(ptColon); + ReturnType; + if TokenId = ptSemicolon then // DR 2002-01-14 + SEMICOLON; + if ExID = ptDispId then + begin + DispIDSpecifier; // DR 2001-07-26 + if TokenId = ptSemicolon then // DR 2002-01-14 + SEMICOLON; + end; + if ExID in ClassMethodDirectiveEnum //XM 2002-01-29 + then ClassMethodDirective; //XM 2002-01-26 +end; + +procedure TmwSimplePasPar.FunctionMethodName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ClassProcedureHeading; +begin + Expected(ptProcedure); + ProcedureMethodName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + + if TokenId = ptSemicolon then // DR 2002-01-14 + SEMICOLON; + + if ExID = ptDispId then + begin + DispIDSpecifier; // DR 2001-07-26 + if TokenId = ptSemicolon then // DR 2002-01-14 + SEMICOLON; + end; + if exID in ClassMethodDirectiveEnum then // XM 2002-01-29 + ClassMethodDirective; +end; + +procedure TmwSimplePasPar.ProcedureMethodName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ClassMethodResolution; +begin + case TokenID of + ptFunction: + begin + NextToken; + end; + ptProcedure: + begin + NextToken; + end; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + ptIdentifier: + begin + if Lexer.ExID = ptOperator then + NextToken; + end; + {$ENDIF} + end; + ResolutionInterfaceName; + Expected(ptPoint); + Expected(ptIdentifier); + Expected(ptEqual); + Expected(ptIdentifier); + SEMICOLON; +end; + +procedure TmwSimplePasPar.ResolutionInterfaceName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.Constraint; +begin + while TokenId in [ptConstructor, ptRecord, ptClass, ptIdentifier] do + begin + case TokenId of + ptConstructor, ptRecord, ptClass: NextToken; + ptIdentifier: TypeId; + end; + if TokenId = ptComma then + NextToken; + end; +end; + +procedure TmwSimplePasPar.ConstraintList; +begin + Constraint; + while TokenId = ptComma do + begin + Constraint; + end; +end; + +procedure TmwSimplePasPar.ConstructorHeading; +begin + Expected(ptConstructor); + ConstructorName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + SEMICOLON; + ClassMethodDirective; +end; + +procedure TmwSimplePasPar.ConstructorName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.DestructorHeading; +begin + Expected(ptDestructor); + DestructorName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + SEMICOLON; + ClassMethodDirective; +end; + +procedure TmwSimplePasPar.DestructorName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ClassMethodDirective; +begin + while ExId in ClassMethodDirectiveEnum do + begin + ProceduralDirective; + if TokenId = ptSemicolon then // DR 2002-01-14 + SEMICOLON; + end; +end; + +procedure TmwSimplePasPar.ObjectMethodHeading; +begin + case TokenID of + ptConstructor: + begin + ObjectConstructorHeading; + end; + ptDestructor: + begin + ObjectDestructorHeading; + end; + ptFunction: + begin + ObjectFunctionHeading; + end; + ptProcedure: + begin + ObjectProcedureHeading; + end; + else + begin + SynError(InvalidMethodHeading); + end; + end; +end; + +procedure TmwSimplePasPar.ObjectFunctionHeading; +begin + Expected(ptFunction); + FunctionMethodName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + Expected(ptColon); + ReturnType; + if TokenID = ptSemiColon then SEMICOLON; + ObjectMethodDirective; +end; + +procedure TmwSimplePasPar.ObjectProcedureHeading; +begin + Expected(ptProcedure); + ProcedureMethodName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + if TokenID = ptSemiColon then SEMICOLON; + ObjectMethodDirective; +end; + +procedure TmwSimplePasPar.ObjectConstructorHeading; +begin + Expected(ptConstructor); + ConstructorName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + if TokenID = ptSemiColon then SEMICOLON; + ObjectMethodDirective; +end; + +procedure TmwSimplePasPar.ObjectDestructorHeading; +begin + Expected(ptDestructor); + DestructorName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + if TokenID = ptSemiColon then SEMICOLON; + ObjectMethodDirective; +end; + +procedure TmwSimplePasPar.ObjectMethodDirective; +begin + while ExID in [ptAbstract, ptCdecl, ptDynamic, ptExport, ptExternal, ptFar, + ptMessage, ptNear, + ptOverload, // DR 2001-08-07 + ptPascal, ptRegister, ptSafeCall, ptStdCall, ptVirtual, + ptDeprecated, ptLibrary, ptPlatform // DR 2001-10-20 + {$IFDEF D8_NEWER} + , ptStatic + {$ENDIF} + {$IFDEF D9_NEWER} + , ptInline + {$ENDIF} + ] do + begin + ProceduralDirective; + if TokenID = ptSemiColon then SEMICOLON; + end; +end; + +procedure TmwSimplePasPar.Directive16Bit; +begin + case ExID of + ptNear: + begin + NextToken; + end; + ptFar: + begin + NextToken; + end; + ptExport: + begin + NextToken; + end; + else + begin + SynError(InvalidDirective16Bit); + end; + end; +end; + +procedure TmwSimplePasPar.DirectiveBinding; +begin + case ExID of + ptVirtual: + begin + NextToken; + end; + ptDynamic: + begin + NextToken; + end; + ptMessage: + begin + NextToken; + ConstantExpression; + end; + ptOverride: + begin + NextToken; + end; + ptOverload: + begin + NextToken; + end; + ptReintroduce: + begin + NextToken; + end; + else + begin + SynError(InvalidDirectiveBinding); + end; + end; +end; + +procedure TmwSimplePasPar.ReturnType; +begin + {$IFDEF D8_NEWER} + while TokenID = ptSquareOpen do + CustomAttribute; + {$ENDIF} + case TokenID of + ptString: + begin + StringType; + end; + else + begin + TypeID; + end; + end; +end; + +procedure TmwSimplePasPar.FormalParameterList; +begin + Expected(ptRoundOpen); + FormalParameterSection; + while TokenID = ptSemiColon do + begin + SEMICOLON; + FormalParameterSection; + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.FormalParameterSection; +begin + {$IFDEF D8_NEWER}//JThurman 2004-03-23 + while TokenID = ptSquareOpen do + CustomAttribute; + {$ENDIF} + case TokenID of + ptConst: + begin + ConstParameter; + end; + ptIdentifier: + case ExID of + ptOut: OutParameter; + else + ParameterFormal; + end; + ptIn: + begin + InParameter; + end; + ptVar: + begin + VarParameter; + end; + end; +end; + +procedure TmwSimplePasPar.ConstParameter; +begin + Expected(ptConst); + ParameterNameList; + case TokenID of + ptColon: + begin + NextToken; + NewFormalParameterType; + if TokenID = ptEqual then + begin + NextToken; + TypedConstant; + end; + end + end; +end; + +procedure TmwSimplePasPar.VarParameter; +begin + Expected(ptVar); + ParameterNameList; + case TokenID of + ptColon: + begin + NextToken; + NewFormalParameterType; + end + end; +end; + +procedure TmwSimplePasPar.OutParameter; +begin + ExpectedEx(ptOut); + ParameterNameList; + case TokenID of + ptColon: + begin + NextToken; + NewFormalParameterType; + end + end; +end; + +procedure TmwSimplePasPar.ParameterFormal; +begin + case TokenID of + ptIdentifier: + begin + ParameterNameList; + Expected(ptColon); + NewFormalParameterType; + if TokenID = ptEqual then + begin + NextToken; + TypedConstant; + end; + end; + else + begin + SynError(InvalidParameter); + end; + end; +end; + +procedure TmwSimplePasPar.ParameterNameList; +begin + ParameterName; + while TokenID = ptComma do + begin + NextToken; + ParameterName; + end; +end; + +procedure TmwSimplePasPar.ParameterName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.NewFormalParameterType; +begin + case TokenID of + ptArray: + begin + NextToken; + Expected(ptOf); + case TokenID of + ptConst: (*new in ObjectPascal80*) + begin + NextToken; + end; + else + begin + OldFormalParameterType; + end; + end; + end; + else + begin + OldFormalParameterType; + end; + end; +end; + +procedure TmwSimplePasPar.OldFormalParameterType; +begin + case TokenID of + ptString: + begin + NextToken; + end; + ptFile: + begin + FileType; + end; + else + begin + TypeID; + end; + end; +end; + +procedure TmwSimplePasPar.FunctionMethodDeclaration; +begin + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + if (TokenID = ptIdentifier) and (Lexer.ExID = ptOperator) then + NextToken else + {$ENDIF} + Expected(ptFunction); + Lexer.InitAhead; + if Lexer.AheadTokenID in [ptPoint, ptLower] then + begin + ObjectNameOfMethod; + Expected(ptPoint); + end; + FunctionProcedureName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + case TokenID of + ptSemiColon: + begin + FunctionProcedureBlock; + end; + else + begin + Expected(ptColon); + ReturnType; + FunctionProcedureBlock; + end; + end; +end; + +procedure TmwSimplePasPar.ProcedureMethodDeclaration; +begin + case TokenID of + ptConstructor: + begin + NextToken; + end; + ptDestructor: + begin + NextToken; + end; + ptProcedure: + begin + NextToken; + end; + else + begin + SynError(InvalidProcedureMethodDeclaration); + end; + end; + Lexer.InitAhead; + if Lexer.AheadTokenID in [ptPoint, ptLower] then + begin + ObjectNameOfMethod; + Expected(ptPoint); + end; + FunctionProcedureName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + FunctionProcedureBlock; +end; + +procedure TmwSimplePasPar.FunctionProcedureName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ObjectNameOfMethod; +begin + Expected(ptIdentifier); + {$IFDEF D8_NEWER} //JThurman 2004-03-22 + if TokenId = ptLower then + TypeParams; + Lexer.InitAHead; + Lexer.AheadNext; + if Lexer.AheadTokenID = ptPoint then + begin + Expected(ptPoint); + ObjectNameOfMethod; + end; + {$ENDIF} +end; + +procedure TmwSimplePasPar.FunctionProcedureBlock; +var + NoExternal: Boolean; +begin + NoExternal := True; + if TokenID = ptSemiColon + then SEMICOLON; + case ExID of + ptForward: + ForwardDeclaration; // DR 2001-07-23 + else + while ExID in [ptAbstract, ptCdecl, ptDynamic, ptExport, ptExternal, ptFar, + ptMessage, ptNear, ptOverload, ptOverride, ptPascal, ptRegister, + ptReintroduce, ptSafeCall, ptStdCall, ptVirtual, + ptDeprecated, ptLibrary, ptPlatform, // DR 2001-10-20 + ptLocal, ptVarargs, + ptAssembler //JT 2004-10-29 + {$IFDEF D8_NEWER} + , ptStatic + {$ENDIF} + {$IFDEF D9_NEWER} + , ptInline + {$ENDIF} + ] // DR 2001-11-14 + do + begin + case ExId of + ptExternal: + begin + ProceduralDirective; + if TokenID = ptSemiColon then SEMICOLON; + NoExternal := False; + end; + else + begin + ProceduralDirective; + if TokenID = ptSemiColon then SEMICOLON; + end; + end; + end; + if ExID = ptForward then + ForwardDeclaration // DR 2001-07-23 + else if NoExternal then + begin + if ExId = ptAssembler then + begin + NextToken; + SEMICOLON; + end; + case TokenID of + ptAsm: + begin + AsmStatement; + end; + else + begin + Block; + end; + end; + SEMICOLON; + end; + end; +end; + +procedure TmwSimplePasPar.ExternalDirective; +begin + ExpectedEx(ptExternal); + case TokenID of + ptSemiColon: + begin + SEMICOLON; + end; + else + begin + SimpleExpression; + ExternalDirectiveTwo; + end; + end; +end; + +procedure TmwSimplePasPar.ExternalDirectiveTwo; +begin + case fLexer.ExID of + ptIndex: + begin + NextToken; + end; + ptName: + begin + NextToken; + SimpleExpression; + end; + ptSemiColon: + begin + SEMICOLON; + ExternalDirectiveThree; + end; + end +end; + +procedure TmwSimplePasPar.ExternalDirectiveThree; +begin + case TokenID of + ptMinus: + begin + NextToken; + end; + end; + case TokenID of + ptIdentifier, ptIntegerConst: + begin + NextToken; + end; + end; +end; + +procedure TmwSimplePasPar.ForStatement; +begin + Expected(ptFor); + QualifiedIdentifier; + {$IFDEF D8_NEWER} + if Lexer.TokenID = ptAssign then + begin + Expected(ptAssign); + Expression; + case TokenID of + ptTo: + begin + NextToken; + end; + ptDownTo: + begin + NextToken; + end; + else + begin + SynError(InvalidForStatement); + end; + end; + Expression; + end else + if Lexer.TokenID = ptIn then + begin + Expected(ptIn); + //QualifiedIdentifier; + Expression; + end; + {$ELSE} + Expected(ptAssign); + Expression; + case TokenID of + ptTo: + begin + NextToken; + end; + ptDownTo: + begin + NextToken; + end; + else + begin + SynError(InvalidForStatement); + end; + end; + Expression; + {$ENDIF} + Expected(ptDo); + Statement; +end; + +procedure TmwSimplePasPar.WhileStatement; +begin + Expected(ptWhile); + Expression; + Expected(ptDo); + Statement; +end; + +procedure TmwSimplePasPar.RepeatStatement; +begin + Expected(ptRepeat); + StatementList; + Expected(ptUntil); + Expression; +end; + +procedure TmwSimplePasPar.CaseStatement; +begin + Expected(ptCase); + Expression; + Expected(ptOf); + CaseSelector; + while TokenID = ptSemiColon do + begin + SEMICOLON; + case TokenID of + ptElse, ptEnd: ; + else + CaseSelector; + end; + end; + if TokenID = ptElse then + begin + NextToken; + StatementList; + SEMICOLON; + end; + Expected(ptEnd); +end; + +procedure TmwSimplePasPar.CaseSelector; +begin + CaseLabel; + while TokenID = ptComma do + begin + NextToken; + CaseLabel; + end; + Expected(ptColon); + case TokenID of + ptSemiColon: ; + else + Statement; + end; +end; + +procedure TmwSimplePasPar.CaseLabel; +begin + ConstantExpression; + if TokenID = ptDotDot then + begin + NextToken; + ConstantExpression; + end; +end; + +procedure TmwSimplePasPar.IfStatement; +begin + Expected(ptIf); + Expression; + Expected(ptThen); + Statement; + //This breaks if you have an if statement immediately preceding the else + //clause of a case statement +{ Lexer.InitAhead; + if (TokenID = ptSemicolon) and (Lexer.AheadTokenID = ptElse) then + begin + if Assigned(FOnMessage) then + begin + FOnMessage(Self, meError, ''';'' not allowed before ''ELSE''', + FLexer.PosXY.X, FLexer.PosXY.Y); + end; + end;} + if TokenID = ptElse then + begin + NextToken; + Statement; + end; +end; + +procedure TmwSimplePasPar.ExceptBlock; +begin + case ExID of + ptOn: + begin + ExceptionHandlerList; + ExceptionBlockElseBranch + end; + else + begin + StatementList; + end; + end; +end; + +procedure TmwSimplePasPar.ExceptionHandlerList; +begin + while fLexer.ExID = ptOn do + begin + ExceptionHandler; + SEMICOLON; + end; +end; + +procedure TmwSimplePasPar.ExceptionHandler; +begin + ExpectedEx(ptOn); + ExceptionIdentifier; + Expected(ptDo); + Statement; +end; + +procedure TmwSimplePasPar.ExceptionBlockElseBranch; +begin + case TokenID of + ptElse: + begin + NextToken; + StatementList; + end; + end; +end; + +procedure TmwSimplePasPar.ExceptionIdentifier; +begin + Lexer.InitAhead; + case Lexer.AheadTokenID of + ptPoint: + begin + ExceptionClassTypeIdentifier; + end; + else + begin + ExceptionVariable; + case Lexer.TokenID of + ptColon: + begin + NextToken; + ExceptionClassTypeIdentifier; + end; + end; + end; + end; +end; + +procedure TmwSimplePasPar.ExceptionClassTypeIdentifier; +begin + QualifiedIdentifier; +end; + +procedure TmwSimplePasPar.ExceptionVariable; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.InlineStatement; +begin + Expected(ptInline); + Expected(ptRoundOpen); + Expected(ptIntegerConst); + while (TokenID = ptSlash) do + begin + NextToken; + Expected(ptIntegerConst); + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.InParameter; +begin + Expected(ptIn); + ParameterNameList; + case TokenID of + ptColon: + begin + NextToken; + NewFormalParameterType; + if TokenID = ptEqual then + begin + NextToken; + TypedConstant; + end; + end + end; +end; + +procedure TmwSimplePasPar.AsmStatement; +begin + Lexer.AsmCode := True; + Expected(ptAsm); + { should be replaced with a Assembler lexer } + while TokenID <> ptEnd do + case fLexer.TokenID of + ptBegin, ptCase, ptEnd, ptIf, ptFunction, ptProcedure, ptRepeat, ptwhile: break; + ptAddressOp: + begin + NextToken; + NextToken; + end; + ptDoubleAddressOp: + begin + NextToken; + NextToken; + end; + ptNull: //JThurman 10-26-2004. Need another way out of this. + begin + Expected(ptEnd); + Exit; + end; + else + NextToken; + end; + Lexer.AsmCode := False; + Expected(ptEnd); +end; + +procedure TmwSimplePasPar.RaiseStatement; +begin + Expected(ptRaise); + case TokenID of + ptAddressOp, ptDoubleAddressOp, ptIdentifier, ptPointerSymbol, ptRoundOpen: + begin + Designator; + end; + end; + if ExID = ptAt then + begin + NextToken; + Expression; + end; +end; + +procedure TmwSimplePasPar.TryStatement; +begin + Expected(ptTry); + StatementList; + case TokenID of + ptExcept: + begin + NextToken; + ExceptBlock; + Expected(ptEnd); + end; + ptFinally: + begin + NextToken; + StatementList; + Expected(ptEnd); + end; + else + begin + SynError(InvalidTryStatement); + end; + end; +end; + +procedure TmwSimplePasPar.WithStatement; +begin + Expected(ptWith); + VariableList; + Expected(ptDo); + Statement; +end; + +procedure TmwSimplePasPar.VariableList; +begin + VariableReference; (* acessing func.recordfield not allowed here;as well as UNITNAMEID *) + while fLexer.TokenID = ptComma do + begin + NextToken; + VariableReference; + end; +end; + +procedure TmwSimplePasPar.StatementList; +begin {removed ptIntegerConst jdj-Put back in for labels} + while TokenID in [ptAddressOp, ptAsm, ptBegin, ptCase, ptDoubleAddressOp, + ptFor, ptGoTo, ptIdentifier, ptIf, ptInherited, ptInline, ptIntegerConst, + ptPointerSymbol, ptRaise, ptRoundOpen, ptRepeat, ptSemiColon, ptString, + ptTry, ptWhile, ptWith] do + begin + Statement; + SEMICOLON; + end; +end; + +procedure TmwSimplePasPar.SimpleStatement; +begin + case TokenID of + ptAddressOp, ptDoubleAddressOp, ptIdentifier, ptPointerSymbol, ptRoundOpen: + begin + Designator; + if TokenID = ptAssign then + begin + NextToken; + if TokenID = ptInherited then + begin + NextToken; + end; + Expression; + end; + end; + ptGoTo: + begin + NextToken; + LabelId; + end; + end; +end; + +procedure TmwSimplePasPar.Statement; +begin + case TokenID of + ptAsm: + begin + AsmStatement; + end; + ptBegin: + begin + CompoundStatement; + end; + ptCase: + begin + CaseStatement; + end; + ptFor: + begin + ForStatement; + end; + ptIf: + begin + IfStatement; + end; + ptIdentifier: + begin + fLexer.InitAhead; + case Lexer.AheadTokenID of + ptColon: + begin + LabeledStatement; + end; + else + begin + SimpleStatement; + end; + end; + end; + ptInherited: + begin + InheritedStatement; + end; + ptInLine: + begin + InlineStatement; + end; + ptIntegerConst: + begin + fLexer.InitAhead; + case Lexer.AheadTokenID of + ptColon: + begin + LabeledStatement; + end; + else + begin + SynError(InvalidLabeledStatement); + NextToken; + end; + end; + end; + ptRepeat: + begin + RepeatStatement; + end; + ptRaise: + begin + RaiseStatement; + end; + ptSemiColon: + begin + EmptyStatement; + end; + ptString: + begin + StringStatement; + end; + ptTry: + begin + TryStatement; + end; + ptWhile: + begin + WhileStatement; + end; + ptWith: + begin + WithStatement; + end; + else + begin + SimpleStatement; + end; + end; +end; + +procedure TmwSimplePasPar.EmptyStatement; +begin + { Nothing to do here. + The semicolon will be removed in StatementList } +end; + +procedure TmwSimplePasPar.InheritedStatement; +begin + Expected(ptInherited); + case TokenID of + ptSemiColon: ; + else + begin + Statement; + end; + end; +end; + +procedure TmwSimplePasPar.LabeledStatement; +begin + case TokenID of + ptIdentifier: + begin + NextToken; + Expected(ptColon); + Statement; + end; + ptIntegerConst: + begin + NextToken; + Expected(ptColon); + Statement; + end; + else + begin + SynError(InvalidLabeledStatement); + end; + end; +end; + +procedure TmwSimplePasPar.StringStatement; +begin + Expected(ptString); + Statement; +end; + +procedure TmwSimplePasPar.SetElement; +begin + Expression; + if TokenID = ptDotDot then + begin + NextToken; + Expression; + end; +end; + +procedure TmwSimplePasPar.QualifiedIdentifier; +begin //mw 12/7/2000 + Expected(ptIdentifier); + case TokenID of + ptPoint: + begin + while TokenID = ptPoint do + begin //jdj 1/7/2001 + NextToken; + {$IFDEF D8_NEWER} + if TokenID in [ptAnd, ptArray, ptAs, ptASM, ptBegin, ptCase, ptClass, + ptConst, ptConstructor, ptDestructor, ptDispInterface, ptDiv, ptDo, + ptDOwnto, ptElse, ptEnd, ptExcept, ptExports, ptFile, ptFinal, + ptFinalization, ptFinally, ptFor, ptFunction, ptGoto, ptIf, + ptImplementation, ptIn, ptInherited, ptInitialization, ptInline, + ptInterface, ptIs, ptLabel, ptLibrary, ptMod, ptNil, ptNot, ptObject, + ptOf, ptOr, ptOut, ptPacked, ptProcedure, ptProgram, ptProperty, + ptRaise, ptRecord, ptRepeat, ptResourceString, ptSealed, ptSet, + ptShl, ptShr, ptStatic, ptString, ptThen, ptThreadVar, ptTo, ptTry, + ptType, ptUnit, ptUnsafe, ptUntil, ptUses, ptVar, ptWhile, ptWith, + ptXor] then + NextToken + else + {$ENDIF} + Expected(ptIdentifier); + if (TokenID = ptSquareOpen) then + begin + ConstantExpression; + end; + end; + end; + ptSquareOpen: + begin + ConstantExpression; + end; + end; +(* Expected(ptIdentifier); // old code for information removed in next versions + case TokenID of + ptPoint: + begin + NextToken; + Expected(ptIdentifier); + if (TokenID = ptSquareOpen) then + begin + ConstantExpression; + end; + end; + ptSquareOpen: {MW 20001207} + begin + ConstantExpression; + end; + end;*) + +end; + +procedure TmwSimplePasPar.SetConstructor; +begin + Expected(ptSquareOpen); + SetElement; + while TokenID = ptComma do + begin + NextToken; + SetElement; + end; + Expected(ptSquareClose); +end; + +procedure TmwSimplePasPar.Number; +begin + case TokenID of + ptFloat: + begin + NextToken; + end; + ptIntegerConst: + begin + NextToken; + end; + ptIdentifier: + begin + NextToken; + end; + else + begin + SynError(InvalidNumber); + end; + end; +end; + +procedure TmwSimplePasPar.ExpressionList; +begin + Expression; + if TokenID = ptAssign then //JT Nov 26, 2004 - supporting ole automation syntax + begin + Expected(ptAssign); + Expression; + end; + while TokenID = ptComma do + begin + NextToken; + Expression; + if TokenID = ptAssign then //JT Nov 26, 2004 - supporting ole automation syntax + begin + Expected(ptAssign); + Expression; + end; + end; +end; + +procedure TmwSimplePasPar.Designator; +begin + VariableReference; +end; + +procedure TmwSimplePasPar.MultiplicativeOperator; +begin + case TokenID of + ptAnd: + begin + NextToken; + end; + ptDiv: + begin + NextToken; + end; + ptMod: + begin + NextToken; + end; + ptShl: + begin + NextToken; + end; + ptShr: + begin + NextToken; + end; + ptSlash: + begin + NextToken; + end; + ptStar: + begin + NextToken; + end; + else + begin SynError(InvalidMultiplicativeOperator); + end; + end; +end; + +procedure TmwSimplePasPar.Factor; +begin + case TokenID of + ptAsciiChar, ptStringConst: + begin + CharString; + end; + ptAddressOp, ptDoubleAddressOp, ptIdentifier, ptInherited, ptPointerSymbol, + ptRoundOpen: + begin + Designator; + end; + ptIntegerConst, ptFloat: + begin + Number; + end; + ptNil: + begin + NextToken; + end; + ptMinus: + begin + NextToken; + Factor; + end; + ptNot: + begin + NextToken; + Factor; + end; + ptPlus: + begin + NextToken; + Factor; + end; + ptSquareOpen: + begin + SetConstructor; + end; + ptString: + begin + NextToken; + Factor; + end; + ptFunction, ptProcedure: + AnonymousMethod; + end; +end; + +procedure TmwSimplePasPar.AdditiveOperator; +begin + if TokenID in [ptMinus, ptOr, ptPlus, ptXor] then + begin + NextToken; // DR 2001-12-19 + { + case TokenID of + ptMinus, ptPlus: + begin + while TokenID in [ptMinus, ptPlus] do + case TokenID of + ptMinus: + begin + NextToken; + end; + ptPlus: + begin + NextToken; + end; + end; + end; + ptOr: + begin + NextToken; + end; + ptXor: + begin + NextToken; + end; + end;} + end + else + begin + SynError(InvalidAdditiveOperator); + end; +end; + +procedure TmwSimplePasPar.Term; +begin + Factor; + while TokenID in [ptAnd, ptDiv, ptMod, ptShl, ptShr, ptSlash, ptStar] do + begin + MultiplicativeOperator; + Factor; + end; +end; + +procedure TmwSimplePasPar.RelativeOperator; +begin + case TokenID of + ptAs: + begin + NextToken; + end; + ptEqual: + begin + NextToken; + end; + ptGreater: + begin + NextToken; + end; + ptGreaterEqual: + begin + NextToken; + end; + ptIn: + begin + NextToken; + end; + ptIs: + begin + NextToken; + end; + ptLower: + begin + NextToken; + end; + ptLowerEqual: + begin + NextToken; + end; + ptNotEqual: + begin + NextToken; + end; + else + begin + SynError(InvalidRelativeOperator); + end; + end; +end; + +procedure TmwSimplePasPar.SimpleExpression; +begin +(* while TokenID in [ptMinus, ptPlus] do + begin + NextToken; // DR 2001-12-19 + end; +*) + Term; + while TokenID in [ptMinus, ptOr, ptPlus, ptXor] do + begin + AdditiveOperator; + Term; + end; +end; + +procedure TmwSimplePasPar.Expression; +begin + SimpleExpression; + + //JT 2006-07-17 The Delphi language guide has this as + //Expression -> SimpleExpression [RelOp SimpleExpression]... + //So this needs to be able to repeat itself. + case TokenID of + ptEqual, ptGreater, ptGreaterEqual, ptLower, ptLowerEqual, ptIn, ptIs, + ptNotEqual: + begin + while TokenID in [ptEqual, ptGreater, ptGreaterEqual, ptLower, ptLowerEqual, + ptIn, ptIs, ptNotEqual{, ptColon}] do + begin + RelativeOperator; + SimpleExpression; + end; + end; + ptColon: + begin + case fInRound of + False: ; + True: + while TokenID = ptColon do + begin + NextToken; + SimpleExpression; + end; + end; + end; + end; +end; + +procedure TmwSimplePasPar.VarDeclaration; +begin + // !! Changed back to var name list from IdentifierList + VarNameList; + Expected(ptColon); + TypeKind; + while ExID in [ptDeprecated, ptLibrary, ptPlatform] do // DR 2001-10-20 + case ExID of + ptDeprecated: DirectiveDeprecated; + ptLibrary: DirectiveLibrary; + ptPlatform: DirectivePlatform; + end; + case GenID of + ptAbsolute: + begin + VarAbsolute; + end; + ptEqual: + begin + VarEqual; + end; + end; + while ExID in [ptDeprecated, ptLibrary, ptPlatform] do // DR 2001-10-20 + case ExID of + ptDeprecated: DirectiveDeprecated; + ptLibrary: DirectiveLibrary; + ptPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.VarAbsolute; +begin + ExpectedEx(ptAbsolute); + ConstantValue; +end; + +procedure TmwSimplePasPar.VarEqual; +begin + Expected(ptEqual); + ConstantValueTyped; +end; + +procedure TmwSimplePasPar.VarNameList; +begin + VarName; + while TokenID = ptComma do + begin + NextToken; + VarName; + end; +end; + +procedure TmwSimplePasPar.VarName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.DirectiveCalling; +begin + case ExID of + ptCdecl: + begin + NextToken; + end; + ptPascal: + begin + NextToken; + end; + ptRegister: + begin + NextToken; + end; + ptSafeCall: + begin + NextToken; + end; + ptStdCall: + begin + NextToken; + end; + else + begin + SynError(InvalidDirectiveCalling); + end; + end; +end; + +procedure TmwSimplePasPar.RecordVariant; +begin + ConstantExpression; + while (TokenID = ptComma) do + begin + NextToken; + ConstantExpression; + end; + Expected(ptColon); + Expected(ptRoundOpen); + if TokenID <> ptRoundClose then + begin + FieldList; + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.VariantSection; +begin + Expected(ptCase); + TagField; + Expected(ptOf); + RecordVariant; + while TokenID = ptSemiColon do + begin + SEMICOLON; + case TokenID of //DR 2001-12-11 + ptEnd, ptRoundClose: Break; + else + RecordVariant; + end; + end; +end; + +procedure TmwSimplePasPar.TagField; +begin + TagFieldName; + case fLexer.TokenID of + ptColon: + begin + NextToken; + TagFieldTypeName; + end; + end; +end; + +procedure TmwSimplePasPar.TagFieldName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.TagFieldTypeName; +begin + QualifiedIdentifier; +end; + +procedure TmwSimplePasPar.FieldDeclaration; +begin + //IdentifierList; + FieldNameList; + Expected(ptColon); + TypeKind; + while ExID in [ptDeprecated, ptLibrary, ptPlatform] do // DR 2002-01-09 + case ExID of + ptDeprecated: DirectiveDeprecated; + ptLibrary: DirectiveLibrary; + ptPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.FieldList; +begin + while TokenID = ptIdentifier do + begin + FieldDeclaration; + SEMICOLON; + end; + if TokenID = ptCase then + begin + VariantSection; + end; +end; + +procedure TmwSimplePasPar.FieldName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.FieldNameList; +begin + FieldName; + while TokenID = ptComma do + begin + NextToken; + FieldName; + end; +end; + +procedure TmwSimplePasPar.RecordType; +begin + Expected(ptRecord); + if TokenID = ptSemicolon then + Exit; + {$IFDEF D8_NEWER} + if TokenID = ptRoundOpen then + begin + ClassHeritage; + if TokenID = ptSemicolon then + Exit; + end; + ClassMemberList; + {$ELSE} + FieldList; + {$ENDIF} + Expected(ptEnd); +end; + +procedure TmwSimplePasPar.FileType; +begin + Expected(ptFile); + if TokenID = ptOf then + begin + NextToken; + TypeId; + end; +end; + +procedure TmwSimplePasPar.SetType; +begin + Expected(ptSet); + Expected(ptOf); + OrdinalType; +end; + +procedure TmwSimplePasPar.ArrayType; +begin + Expected(ptArray); + if TokenID = ptSquareOpen then + begin + NextToken; + OrdinalType; + while TokenID = ptComma do + begin + NextToken; + OrdinalType; + end; + Expected(ptSquareClose); + end; + Expected(ptOf); + TypeKind; +end; + +procedure TmwSimplePasPar.EnumeratedType; +begin + Expected(ptRoundOpen); + EnumeratedTypeItem; + while TokenID = ptComma do + begin + NextToken; + EnumeratedTypeItem; + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.SubrangeType; +begin + ConstantExpression; + if TokenID = ptDotDot then + begin + NextToken; + ConstantExpression; + end; +end; + +procedure TmwSimplePasPar.RealIdentifier; +begin + case ExID of + ptReal48: + begin + NextToken; + end; + ptReal: + begin + NextToken; + end; + ptSingle: + begin + NextToken; + end; + ptDouble: + begin + NextToken; + end; + ptExtended: + begin + NextToken; + end; + ptCurrency: + begin + NextToken; + end; + ptComp: + begin + NextToken; + end; + else + begin + SynError(InvalidRealIdentifier); + end; + end; +end; + +procedure TmwSimplePasPar.RealType; +begin + case TokenID of + ptMinus: + begin + NextToken; + end; + ptPlus: + begin + NextToken; + end; + end; + case TokenId of + ptFloat: + begin + NextToken; + end; + else + begin + VariableReference; + end; + end; +end; + +procedure TmwSimplePasPar.OrdinalIdentifier; +begin + case ExID of + ptBoolean: + begin + NextToken; + end; + ptByte: + begin + NextToken; + end; + ptBytebool: + begin + NextToken; + end; + ptCardinal: + begin + NextToken; + end; + ptChar: + begin + NextToken; + end; + ptDWord: + begin + NextToken; + end; + ptInt64: + begin + NextToken; + end; + ptInteger: + begin + NextToken; + end; + ptLongBool: + begin + NextToken; + end; + ptLongInt: + begin + NextToken; + end; + ptLongWord: + begin + NextToken; + end; + ptPChar: + begin + NextToken; + end; + ptShortInt: + begin + NextToken; + end; + ptSmallInt: + begin + NextToken; + end; + ptWideChar: + begin + NextToken; + end; + ptWord: + begin + NextToken; + end; + ptWordbool: + begin + NextToken; + end; + else + begin + SynError(InvalidOrdinalIdentifier); + end; + end; +end; + +procedure TmwSimplePasPar.OrdinalType; +begin + case TokenID of + ptIdentifier: + begin + Lexer.InitAhead; + case Lexer.AheadTokenID of + ptPoint: + begin + Expression; + end; + ptRoundOpen: + begin //jdj + ConstantExpression; + end; + else + begin + TypeID; + end; + end; + end; + ptRoundOpen: + begin + EnumeratedType; + end; + ptSquareOpen: + begin + NextToken; + SubrangeType; + Expected(ptSquareClose); + end; + else + begin + Expression; + end; + end; + if TokenID = ptDotDot then + begin + NextToken; + ConstantExpression; + end; +end; + +procedure TmwSimplePasPar.VariableReference; +begin + case TokenID of + ptAddressOp: + begin + NextToken; + variable; + end; + ptDoubleAddressOp: + begin + NextToken; + variable; + end; + ptPointerSymbol: + begin + NextToken; + case TokenID of + ptRoundClose, ptSquareClose: ; + else + begin + variable; + end; + end; + end; + else + variable; + end; +end; + +procedure TmwSimplePasPar.Variable; (* Attention: could also came from proc_call ! ! *) +begin + case TokenID of + ptInherited: + begin + NextToken; + QualifiedIdentifier; + end; + ptPoint: + begin + VariableTwo; + end; + ptPointerSymbol: + begin + VariableTwo; + end; + ptRoundOpen: + begin + VariableTwo; + end; + ptSquareOpen: + begin + VariableTwo; + end; +//{$IFDEF D11_NEWER} +// ptLower: +// begin +// VariableTwo; +// end; +//{$ENDIF} + else + QualifiedIdentifier; + end; + VariableTwo; + case TokenID of + ptAs: + begin + NextToken; + QualifiedIdentifier; + end; + end; +end; + +procedure TmwSimplePasPar.VariableTwo; +begin + case TokenID of + ptPoint: + begin + NextToken; + case TokenID of + ptAddressOp, ptDoubleAddressOp, ptIdentifier: + begin + VariableReference; + end; + ptPointerSymbol, ptRoundOpen, ptSquareOpen: + begin + VariableTwo; + end; + end; + end; + ptPointerSymbol: + begin + NextToken; + case TokenID of + ptAddressOp, ptDoubleAddressOp, ptIdentifier: + begin + VariableReference; + end; + ptPoint, ptPointerSymbol, ptRoundOpen, ptSquareOpen: + begin + VariableTwo; + end; + end; + end; + ptRoundOpen: + begin + NextToken; + fInRound := True; + case TokenID of + ptRoundClose: + begin + NextToken; + //Expected(ptRoundClose); + fInRound := False; + end; + else + begin + case TokenID of + ptAddressOp, ptDoubleAddressOp: + begin + VariableReference; + end; + ptPoint, ptPointerSymbol, ptRoundOpen, ptSquareOpen: + begin + VariableTwo; + end; + end; + fInRound := True; + ExpressionList; + fInRound := True; + Expected(ptRoundClose); + fInRound := False; + end; + end; + case TokenID of + ptAddressOp, ptDoubleAddressOp: + begin + VariableReference; + end; + ptPoint, ptPointerSymbol, ptRoundOpen, ptSquareOpen: + begin + VariableTwo; + end; + end; + end; + ptSquareOpen: + begin + Lexer.InitAhead; + while Lexer.AheadTokenID <> ptSemiColon do + begin + case Lexer.AheadTokenID of + ptBegin, ptClass, ptConst, ptEnd, ptDotDot, ptIn, ptNull, ptThreadVar, ptType, + ptVar: break; + else + Lexer.AheadNext; + end; + end; + case Lexer.AheadTokenID of + ptDotDot: + begin + SubrangeType; + end; + else + begin + NextToken; + case TokenID of + ptSquareClose: + begin + NextToken; + end; + else + begin + case TokenID of + ptAddressOp, ptDoubleAddressOp: + begin + VariableReference; + end; + ptPoint, ptPointerSymbol, ptRoundOpen, ptSquareOpen: + begin + VariableTwo; + end; + end; + ExpressionList; + Expected(ptSquareClose); + end; + end; + case TokenID of + ptAddressOp, ptDoubleAddressOp: + begin + VariableReference; + end; + ptPoint, ptPointerSymbol, ptRoundOpen, ptSquareOpen: + begin + VariableTwo; + end; + end; + + end; + end; + end; + {$IFDEF D11_NEWER} + ptLower: + begin + InitAhead; + AheadParse.NextToken; + AheadParse.TypeKind; + + if AheadParse.TokenId = ptGreater then + begin + NextToken; + TypeKind; + Expected(ptGreater); + case TokenID of + ptAddressOp, ptDoubleAddressOp, ptIdentifier: + begin + VariableReference; + end; + ptPoint, ptPointerSymbol, ptRoundOpen, ptSquareOpen: + begin + VariableTwo; + end; + end; + end; + end; + {$ENDIF} + end; +end; + +procedure TmwSimplePasPar.InterfaceType; +begin + case TokenID of + ptInterface: + begin + NextToken; + end; + ptDispInterface: + begin + NextToken; + end + else + begin + SynError(InvalidInterfaceType); + end; + end; + case TokenID of + ptEnd: + begin + NextToken; { Direct descendant without new members } + end; + ptRoundOpen: + begin + InterfaceHeritage; + case TokenID of + ptEnd: + begin + NextToken; { No new members } + end; + ptSemiColon: ; { No new members } + else + begin + if TokenID = ptSquareOpen then + begin + InterfaceGUID; + end; + InterfaceMemberList; + Expected(ptEnd); + end; + end; + end; + else + begin + if TokenID = ptSquareOpen then + begin + InterfaceGUID; + end; + InterfaceMemberList; { Direct descendant } + Expected(ptEnd); + end; + end; +end; + +procedure TmwSimplePasPar.InterfaceMemberList; +begin + while TokenID in [ptFunction, ptProcedure, ptProperty] do + begin + ClassMethodOrProperty; + end; +end; + +procedure TmwSimplePasPar.ClassType; +begin + Expected(ptClass); + {$IFDEF D8_NEWER} //JThurman 2004-03-19 + case TokenID of + ptIdentifier: //NASTY hack because Abstract is generally an ExID, except in this case when it should be a keyword. + begin + if Lexer.ExID = ptAbstract then + Expected(ptIdentifier); + end; + ptSealed: + Expected(ptSealed); + ptHelper: + begin + Expected(ptHelper); + Expected(ptFor); + Expected(ptIdentifier); + end; + end; + {$ENDIF} + case TokenID of + ptEnd: + begin + ClassTypeEnd; // DR 2001-07-31 + NextToken; { Direct descendant of TObject without new members } + end; + ptRoundOpen: + begin + ClassHeritage; + case TokenID of + ptEnd: + begin + Expected(ptEnd); // DR 2001-07-31 + ClassTypeEnd; // DR 2001-07-31 + end; + ptSemiColon: ClassTypeEnd; // DR 2001-07-31 + else + begin + ClassMemberList; { Direct descendant of TObject } + Expected(ptEnd); // DR 2001-07-31 + ClassTypeEnd; // DR 2001-07-31 + end; + end; + end; + else + begin + ClassMemberList; { Direct descendant of TObject } + Expected(ptEnd); // DR 2001-07-31 + ClassTypeEnd; // DR 2001-07-31 + end; + end; +end; + +procedure TmwSimplePasPar.ClassHeritage; +begin + Expected(ptRoundOpen); + AncestorIdList; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.ClassVisibility; +begin + {$IFDEF D8_NEWER} //JThurman 2004-03-03 + if TokenID = ptStrict then + Expected(ptStrict); + {$ENDIF} + while ExID in [ptAutomated, ptPrivate, ptProtected, ptPublic, ptPublished] do + begin + Lexer.InitAhead; + case Lexer.AheadExID of + ptColon, ptComma: ; + else + case ExID of + ptAutomated: + begin + VisibilityAutomated; + end; + ptPrivate: + begin + VisibilityPrivate; + end; + ptProtected: + begin + VisibilityProtected; + end; + ptPublic: + begin + VisibilityPublic; + end; + ptPublished: + begin + VisibilityPublished; + end; + end; + end; + end; +end; + +procedure TmwSimplePasPar.VisibilityAutomated; +begin + ExpectedEx(ptAutomated); +end; + +procedure TmwSimplePasPar.VisibilityPrivate; +begin + ExpectedEx(ptPrivate); +end; + +procedure TmwSimplePasPar.VisibilityProtected; +begin + ExpectedEx(ptProtected); +end; + +procedure TmwSimplePasPar.VisibilityPublic; +begin + ExpectedEx(ptPublic); +end; + +procedure TmwSimplePasPar.VisibilityPublished; +begin + ExpectedEx(ptPublished); +end; + +procedure TmwSimplePasPar.VisibilityUnknown; +begin + // +end; + +procedure TmwSimplePasPar.ClassMemberList; +begin + ClassVisibility; + while TokenID in [ptClass, ptConstructor, ptDestructor, ptFunction, + ptIdentifier, ptProcedure, ptProperty + {$IFDEF D8_NEWER}, ptType, ptSquareOpen, ptVar, ptConst, ptStrict, + ptCase{$ENDIF}] do + begin + while (TokenID = ptIdentifier) and + not (ExID in [ptPrivate, ptProtected, ptPublished, ptPublic]) do + begin + ClassField; + SEMICOLON; + ClassVisibility; + end; + while TokenID in [ptClass, ptConstructor, ptDestructor, ptFunction, + ptProcedure, ptProperty{$IFDEF D8_NEWER}, ptSquareOpen, ptVar, ptConst{$ENDIF}] do + begin + ClassMethodOrProperty; + end; + {$IFDEF D8_NEWER}//JThurman 2004-03-22 + {Nested types for D8} + while TokenID = ptType do + TypeSection; + while TokenID = ptCase do + begin + VariantSection; + end; + {$ENDIF} + ClassVisibility; + end; +end; + +procedure TmwSimplePasPar.ClassMethodOrProperty; +begin + {$IFDEF D8_NEWER} + if TokenID = ptSquareOpen then + CustomAttribute; + {$ENDIF} + if TokenID = ptClass + then ClassClass; //DR 2001-07-16 + case TokenID of + ptProperty: + begin + ClassProperty; + end; + {$IFDEF D8_NEWER} + ptVar: + begin + NextToken; + while (TokenID = ptIdentifier) and (ExID = ptUnknown) do + begin + ClassField; + SemiColon; + end; + end; + ptConst: + begin + NextToken; + while (TokenID = ptIdentifier) and (ExID = ptUnknown) do + begin + ConstantDeclaration; + SemiColon; + end; + end; + {$ENDIF} + else + begin + ClassMethodHeading; + end; + end; +end; + +procedure TmwSimplePasPar.ClassProperty; +begin + // DR 2001-07-19 -> changed. for array-property override failure + Expected(ptProperty); + PropertyName; + case TokenID of + ptColon, ptSquareOpen: + begin + PropertyInterface; + end; + end; + PropertySpecifiers; + case ExID of + ptDefault: + begin + PropertyDefault; //DR 2001-07-16 + SEMICOLON; + end; + end; +end; + +procedure TmwSimplePasPar.PropertyName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ClassField; +begin + //IdentifierList; + FieldNameList; + Expected(ptColon); + TypeKind; + while ExID in [ptDeprecated, ptLibrary, ptPlatform] do // DR 2001-10-20 + case ExID of + ptDeprecated: DirectiveDeprecated; + ptLibrary: DirectiveLibrary; + ptPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.ObjectType; +begin + Expected(ptObject); + case TokenID of + ptEnd: + begin + ObjectTypeEnd; // DR 2001-07-31 + NextToken; { Direct descendant without new members } + end; + ptRoundOpen: + begin + ObjectHeritage; + case TokenID of + ptEnd: + begin + Expected(ptEnd); // DR 2001-07-31 + ObjectTypeEnd; // DR 2001-07-31 + end; + ptSemiColon: ObjectTypeEnd; // DR 2001-07-31 + else + begin + ObjectMemberList; { Direct descendant } + Expected(ptEnd); // DR 2001-07-31 + ObjectTypeEnd; // DR 2001-07-31 + end; + end; + end; + else + begin + ObjectMemberList; { Direct descendant } + Expected(ptEnd); // DR 2001-07-31 + ObjectTypeEnd; // DR 2001-07-31 + end; + end; +end; + +procedure TmwSimplePasPar.ObjectHeritage; +begin + Expected(ptRoundOpen); + AncestorIdList; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.ObjectMemberList; +begin {jdj added ptProperty-call to ObjectProperty 02/07/2001} + ObjectVisibility; + while TokenID in [ptConstructor, ptDestructor, ptFunction, ptIdentifier, + ptProcedure, ptProperty] do + begin + while TokenID = ptIdentifier do + begin + ObjectField; + SEMICOLON; + ObjectVisibility; + end; + while TokenID in [ptConstructor, ptDestructor, ptFunction, ptProcedure, ptProperty] do + begin + case TokenID of + ptConstructor, ptDestructor, ptFunction, ptProcedure: + ObjectMethodHeading; + ptProperty: + ObjectProperty; + end; + end; + ObjectVisibility; + end; +end; + +procedure TmwSimplePasPar.ObjectVisibility; +begin + while ExID in [ptPrivate, ptProtected, ptPublic] do + begin + Lexer.InitAhead; + case Lexer.AheadExID of + ptColon, ptComma: ; + else + case ExID of + ptPrivate: + begin + VisibilityPrivate; + end; + ptProtected: + begin + VisibilityProtected; + end; + ptPublic: + begin + VisibilityPublic; + end; + end; + end; + end; +end; + +procedure TmwSimplePasPar.ObjectField; +begin + IdentifierList; + Expected(ptColon); + TypeKind; + while ExID in [ptDeprecated, ptLibrary, ptPlatform] do // DR 2001-10-20 + case ExID of + ptDeprecated: DirectiveDeprecated; + ptLibrary: DirectiveLibrary; + ptPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.ClassReferenceType; +begin + Expected(ptClass); + Expected(ptOf); + TypeId; +end; + +procedure TmwSimplePasPar.VariantIdentifier; +begin + case ExID of + ptOleVariant: + begin + NextToken; + end; + ptVariant: + begin + NextToken; + end; + else + begin + SynError(InvalidVariantIdentifier); + end; + end; +end; + +procedure TmwSimplePasPar.ProceduralType; +var + TheTokenID: TptTokenKind; +begin + case TokenID of + ptFunction: + begin + NextToken; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + Expected(ptColon); + ReturnType; + end; + ptProcedure: + begin + NextToken; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + end; + else + begin + SynError(InvalidProceduralType); + end; + end; + if TokenID = ptOf then + begin + NextToken; + Expected(ptObject); + end; + Lexer.InitAhead; + case TokenID of + ptSemiColon: TheTokenID := Lexer.AheadExID; + else + TheTokenID := ExID; + end; + while TheTokenID in [ptAbstract, ptCdecl, ptDynamic, ptExport, ptExternal, ptFar, + ptMessage, ptNear, ptOverload, ptOverride, ptPascal, ptRegister, + ptReintroduce, ptSafeCall, ptStdCall, ptVirtual + {$IFDEF D8_NEWER}, ptStatic{$ENDIF}{$IFDEF D9_NEWER}, ptInline{$ENDIF} + ] do + // DR 2001-11-14 no checking for deprecated etc. since it's captured by the typedecl + begin + if TokenID = ptSemiColon then SEMICOLON; + ProceduralDirective; + Lexer.InitAhead; + case TokenID of + ptSemiColon: TheTokenID := Lexer.AheadExID; + else + TheTokenID := ExID; + end; + end; +end; + +procedure TmwSimplePasPar.StringIdentifier; +begin + case ExID of + ptAnsiString: + begin + NextToken; + end; + ptShortString: + begin + NextToken; + end; + ptWideString: + begin + NextToken; + end; + else + begin + SynError(InvalidStringIdentifier); + end; + end; +end; + +procedure TmwSimplePasPar.StringType; +begin + case TokenID of + ptString: + begin + NextToken; + if TokenID = ptSquareOpen then + begin + NextToken; + ConstantExpression; + Expected(ptSquareClose); + end; + end; + else + begin + VariableReference; + end; + end; +end; + +procedure TmwSimplePasPar.PointerType; +begin + Expected(ptPointerSymbol); + TypeId; +end; + +procedure TmwSimplePasPar.StructuredType; +begin + if TokenID = ptPacked then + begin + NextToken; + end; + case TokenID of + ptArray: + begin + ArrayType; + end; + ptFile: + begin + FileType; + end; + ptRecord: + begin + RecordType; + end; + ptSet: + begin + SetType; + end; + else + begin + SynError(InvalidStructuredType); + end; + end; +end; + +procedure TmwSimplePasPar.SimpleType; +begin + case TokenID of + ptMinus: + begin + NextToken; + end; + ptPlus: + begin + NextToken; + end; + end; + case fLexer.TokenID of + ptAsciiChar, ptIntegerConst: + begin + OrdinalType; + end; + ptFloat: + begin + RealType; + end; + ptIdentifier: + begin + fLexer.InitAhead; + case Lexer.AheadTokenID of + ptPoint, ptSemiColon: + begin + TypeID; + end; + else + begin + SimpleExpression; + if fLexer.TokenID = ptDotDot then + begin + NextToken; + SimpleExpression; + end; + end; + end; + end; + ptRoundOpen: + begin + EnumeratedType; + end; + ptSquareOpen: + begin + SubrangeType; + end; + else + begin + VariableReference; + end; + end; +end; + +procedure TmwSimplePasPar.RecordFieldConstant; +begin + Expected(ptIdentifier); + Expected(ptColon); + TypedConstant; +end; + +procedure TmwSimplePasPar.RecordConstant; +begin + Expected(ptRoundOpen); + RecordFieldConstant; + while (TokenID = ptSemiColon) do + begin + SEMICOLON; + if TokenId <> ptRoundClose then //jdj 2.23.2001 + RecordFieldConstant; + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.ArrayConstant; +begin + Expected(ptRoundOpen); + TypedConstant; + while (TokenID = ptComma) do + begin + NextToken; + TypedConstant; + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.ClassForward; +begin + Expected(ptClass); +end; + +procedure TmwSimplePasPar.DispInterfaceForward; +begin + Expected(ptDispInterface); +end; + +procedure TmwSimplePasPar.InterfaceForward; +begin + Expected(ptInterface); +end; + +procedure TmwSimplePasPar.ObjectForward; +begin + Expected(ptObject); +end; + +procedure TmwSimplePasPar.TypeDeclaration; +begin + TypeName; + Expected(ptEqual); + if TokenID = ptType then + begin + ExplicitType; + end; + Lexer.InitAhead; + case TokenID of + ptClass: + begin + case Lexer.AheadTokenID of + ptOf: + begin + ClassReferenceType; + end; + ptSemiColon: + begin + ClassForward; + end; + else + begin + ClassType; + end; + end; + end; + ptInterface: + begin + case Lexer.AheadTokenID of + ptSemiColon: + begin + InterfaceForward; + end; + else + begin + InterfaceType; + end; + end; + end; + ptDispInterface: + begin + case Lexer.AheadTokenID of + ptSemiColon: + begin + DispInterfaceForward; + end; + else + begin + InterfaceType; + end; + end; + end; + ptObject: + begin + case Lexer.AheadTokenID of + ptSemiColon: + begin + ObjectForward; + end; + else + begin + ObjectType; + end; + end; + end; + else + begin + {$IFDEF D12_NEWER} + if ExID = ptReference then + AnonymousMethodType + else + {$ENDIF} + TypeKind; + end; + end; + while ExID in [ptDeprecated, ptLibrary, ptPlatform] do // DR 2001-10-20 + case ExID of + ptDeprecated: DirectiveDeprecated; + ptLibrary: DirectiveLibrary; + ptPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.TypeName; +begin + Expected(ptIdentifier); + if TokenId = ptLower then + TypeParams; +end; + +procedure TmwSimplePasPar.ExplicitType; +begin + Expected(ptType); +end; + +procedure TmwSimplePasPar.TypeKind; +begin + case TokenID of + ptAsciiChar, ptFloat, ptIntegerConst, ptMinus, ptNil, ptPlus, ptRoundOpen, + ptSquareOpen, ptStringConst: + begin + SimpleType; + end; + ptArray, ptFile, ptPacked, ptRecord, ptSet: + begin + StructuredType; + end; + ptFunction, ptProcedure: + begin + ProceduralType; + end; + ptIdentifier: + begin + Lexer.InitAhead; + case Lexer.AheadTokenID of + ptPoint, ptSemiColon, ptLower: + begin + TypeId; + end; + else + begin + SimpleExpression; + if Lexer.TokenID = ptDotDot then + begin + NextToken; + SimpleExpression; + end; + end; + end; + end; + ptPointerSymbol: + begin + PointerType; + end; + ptString: + begin + StringType; + end; + else + begin + SynError(InvalidTypeKind); + end; + end; +end; + +procedure TmwSimplePasPar.TypeArgs; +begin + Expected(ptLower); + TypeId; + while TokenId = ptComma do + begin + NextToken; + TypeId; + end; + Expected(ptGreater); +end; + +procedure TmwSimplePasPar.TypedConstant; +begin + case TokenID of + ptRoundOpen: + begin + Lexer.InitAhead; + while Lexer.AheadTokenID <> ptSemiColon do + case Lexer.AheadTokenID of + ptAnd, ptBegin, ptCase, ptColon, ptEnd, ptElse, ptIf, ptMinus, ptNull, + ptOr, ptPlus, ptShl, ptShr, ptSlash, ptStar, ptWhile, ptWith, + ptXor: break; + ptRoundOpen: + begin + repeat + case Lexer.AheadTokenID of + ptBegin, ptCase, ptEnd, ptElse, ptIf, ptNull, ptWhile, ptWith: break; + else + begin + case Lexer.AheadTokenID of + ptRoundClose: + begin + NextToken; + break; + end; + else + Lexer.AheadNext; + end; + end; + end; + until Lexer.AheadTokenID = ptRoundClose; + end; + else + Lexer.AheadNext; + end; + case Lexer.AheadTokenID of + ptColon: + begin + RecordConstant; + end; + ptNull: ; + ptAnd, ptMinus, ptOr, ptPlus, ptShl, ptShr, ptSlash, ptStar, ptXor: + begin + ConstantExpression; + end; + else + begin + ArrayConstant; + end; + end; + end; + ptSquareOpen: + ConstantExpression; // DR 2002-01-11 + + { DR: fails with constructed set constants like + WordDelimiters: set of Char = [#0..#255] - ['a'..'z','A'..'Z','1'..'9','0']; + + (*empty; there mustn't be all fields of a record mentioned*) + begin + NextToken; + if TokenID <> ptSquareClose then + begin + case TokenID of + ptDotDot: + begin + NextToken; + NextToken; + end; + else + NextToken; + case TokenID of + ptDotDot: + begin + NextToken; + NextToken; + end; + end; + end; + while TokenID = ptComma do + begin + NextToken; + NextToken; + case TokenID of + ptDotDot: + begin + NextToken; + NextToken; + end; + end; + end; + Expected(ptSquareClose); + end + else NextToken; + end;} + else + begin + ConstantExpression; + end; + end; +end; + +procedure TmwSimplePasPar.TypeId; +begin + Lexer.InitAhead; + {$IFDEF D8_NEWER} //JThurman 2004-03-03 + while Lexer.AheadTokenID = ptPoint do + begin + //UnitId; + NextToken; + Expected(ptPoint); + Lexer.InitAhead; + end; + {$ELSE} + if Lexer.AheadTokenID = ptPoint then + begin + UnitId; + Expected(ptPoint); + end; + {$ENDIF} + case GenID of + ptBoolean, ptByte, ptChar, ptDWord, ptInt64, ptInteger, ptLongInt, + ptLongWord, ptPChar, ptShortInt, ptSmallInt, ptWideChar, ptWord: + begin + OrdinalIdentifier; + end; + ptComp, ptCurrency, ptDouble, ptExtended, ptReal, ptReal48, ptSingle: + begin + RealIdentifier; + end; + ptAnsiString, ptShortString, ptWideString: + begin + StringIdentifier; + end; + ptOleVariant, ptVariant: + begin + VariantIdentifier; + end; + ptString: + begin + StringType; + end; + else + begin + //Problem: Delphi 8 allows things like 'Object' to be types + //when they are fully qualified (as System.Object, etc...), so + //ptIdentifier doesn't quite work right in this context + //TODO: Come up with a more elegant solution to the 'Object' dilemna + {$IFDEF D8_NEWER}//JThurman 2004-03-03 + NextToken; + {$ELSE} + Expected(ptIdentifier); + {$ENDIF} + if TokenId = ptLower then + TypeArgs; + end; + end; +end; + +procedure TmwSimplePasPar.ConstantExpression; +begin + Expression; +end; + +procedure TmwSimplePasPar.ResourceDeclaration; +begin + Identifier; + Expected(ptEqual); + CharString; + while ExID in [ptDeprecated, ptLibrary, ptPlatform] do // DR 2002-01-10 + case ExID of + ptDeprecated: DirectiveDeprecated; + ptLibrary: DirectiveLibrary; + ptPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.ConstantDeclaration; +begin + ConstantName; + case TokenID of + ptEqual: + begin + ConstantEqual; + end; + ptColon: + begin + ConstantColon; + end; + else + begin + SynError(InvalidConstantDeclaration); + end; + end; + while ExID in [ptDeprecated, ptLibrary, ptPlatform] do // DR 2001-10-20 + case ExID of + ptDeprecated: DirectiveDeprecated; + ptLibrary: DirectiveLibrary; + ptPlatform: DirectivePlatform; + end; +end; + +procedure TmwSimplePasPar.ConstantColon; +begin + Expected(ptColon); +//JR changed to constant Type + ConstantType; + Expected(ptEqual); + ConstantValueTyped; +end; + +procedure TmwSimplePasPar.ConstantEqual; +begin + Expected(ptEqual); + ConstantValue; +end; + +procedure TmwSimplePasPar.ConstantValue; +begin + ConstantExpression; +end; + +procedure TmwSimplePasPar.ConstantValueTyped; +begin + TypedConstant; +end; + +procedure TmwSimplePasPar.ConstantName; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ConstantType; +begin + TypeKind; +end; +procedure TmwSimplePasPar.LabelId; +begin + case TokenID of + ptIntegerConst: + begin + NextToken; + end; + ptIdentifier: + begin + NextToken; + end; + else + begin + SynError(InvalidLabelId); + end; + end; +end; + +procedure TmwSimplePasPar.ProcedureDeclarationSection; +begin + if TokenID = ptClass then + begin + NextToken; + end; + case TokenID of + ptConstructor: + begin + ProcedureMethodDeclaration; + end; + ptDestructor: + begin + ProcedureMethodDeclaration; + end; + ptProcedure: + begin + ProcedureMethodDeclaration; + end; + ptFunction: + begin + FunctionMethodDeclaration; + end; + {$IFDEF D8_NEWER} //JThurman 2004-03-2003 + ptIdentifier: + begin + if Lexer.ExID = ptOperator then + begin + FunctionMethodDeclaration; + end + else + SynError(InvalidProcedureDeclarationSection); + end; + {$ENDIF} + else + begin + SynError(InvalidProcedureDeclarationSection); + end; + end; +end; + +procedure TmwSimplePasPar.LabelDeclarationSection; +begin + Expected(ptLabel); + LabelId; + while (TokenID = ptComma) do + begin + NextToken; + LabelId; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.ProceduralDirective; //TODO: Add STATIC and FINAL +begin + case ExID of + ptAbstract: + begin + NextToken; + end; + ptCdecl, ptPascal, ptRegister, ptSafeCall, ptStdCall: + begin + DirectiveCalling; + end; + ptExport, ptFar, ptNear: + begin + Directive16Bit; + end; + ptExternal: + begin + ExternalDirective; + end; + ptDynamic, ptMessage, ptOverload, ptOverride, ptReintroduce, ptVirtual: + begin + DirectiveBinding; + end; + ptAssembler: + begin + NextToken; + end; + {$IFDEF D8_NEWER} + ptStatic: + begin + NextToken; + end; + {$ENDIF} + {$IFDEF D9_NEWER} + ptInline: + begin + NextToken; + end; + {$ENDIF} + ptDeprecated: + DirectiveDeprecated; // DR 2001-10-20 + ptLibrary: + DirectiveLibrary; // DR 2001-10-20 + ptPlatform: + DirectivePlatform; // DR 2001-10-20 + ptLocal: + DirectiveLocal; // DR 2001-11-14 + ptVarargs: + DirectiveVarargs; // DR 2001-11-14 + else + begin + SynError(InvalidProceduralDirective); + end; + end; +end; + +procedure TmwSimplePasPar.ExportedHeading; +begin + case TokenID of + ptFunction: + begin + FunctionHeading; + end; + ptProcedure: + begin + ProcedureHeading; + end; + else + begin + SynError(InvalidExportedHeading); + end; + end; + if TokenID = ptSemiColon then SEMICOLON; + case ExID of + ptForward: + begin + ForwardDeclaration; //jdj added 02/07/2001 +// NextToken; +// SEMICOLON; + end; + ptAssembler: + begin + NextToken; + SEMICOLON; + if Exid = ptForward then + ForwardDeclaration; //jdj added 02/07/2001 + end; + else //TODO: Add STATIC and FINAL + while ExID in [ptAbstract, ptCdecl, ptDynamic, ptExport, ptExternal, ptFar, + ptMessage, ptNear, ptOverload, ptOverride, ptPascal, ptRegister, + ptReintroduce, ptSafeCall, ptStdCall, ptVirtual, + ptDeprecated, ptLibrary, ptPlatform, // DR 2001-10-20 + ptLocal, ptVarargs // DR 2001-11-14 + {$IFDEF D8_NEWER}, ptStatic{$ENDIF}{$IFDEF D9_NEWER}, ptInline{$ENDIF} + ] do + begin + ProceduralDirective; + if TokenID = ptSemiColon then SEMICOLON; + end; + if ExId = ptForward then + ForwardDeclaration; //jdj added 02/07/2001 + end; +end; + +procedure TmwSimplePasPar.FunctionHeading; +begin + Expected(ptFunction); + FunctionProcedureName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + Expected(ptColon); + ReturnType; +end; + +procedure TmwSimplePasPar.ProcedureHeading; +begin + Expected(ptProcedure); + FunctionProcedureName; + if TokenID = ptRoundOpen then + begin + FormalParameterList; + end; + +end; + +procedure TmwSimplePasPar.VarSection; +begin + case TokenID of + ptThreadVar: + begin + NextToken; + end; + ptVar: + begin + NextToken; + end; + else + begin + SynError(InvalidVarSection); + end; + end; + {$IFDEF D8_NEWER}//JThurman 2004-03-22 + while TokenID in [ptIdentifier, ptSquareOpen] do + begin + if TokenID = ptSquareOpen then + CustomAttribute + else + begin + VarDeclaration; + SEMICOLON; + end; + end; + {$ELSE} + while TokenID = ptIdentifier do + begin + VarDeclaration; + SEMICOLON; + end; + {$ENDIF} +end; + +procedure TmwSimplePasPar.TypeSection; +begin + Expected(ptType); + {$IFDEF D8_NEWER} + while ((TokenID = ptIdentifier) and (Lexer.ExID in ExTypes)) or + (Lexer.TokenID = ptSquareOpen) do + begin + if TokenID = ptSquareOpen then + CustomAttribute + else + begin + TypeDeclaration; + if TokenID = ptEqual then + TypedConstant; + SEMICOLON; + end; + end; + {$ELSE} + while TokenID = ptIdentifier do + begin + TypeDeclaration; + if TokenId = ptEqual then //jdj 8/2/00 + TypedConstant; + SEMICOLON; + end; + {$ENDIF} +end; + +procedure TmwSimplePasPar.TypeParamDecl; +begin + TypeParamList; + if TokenId = ptColon then + begin + NextToken; + ConstraintList; + end; +end; + +procedure TmwSimplePasPar.TypeParamDeclList; +begin + TypeParamDecl; + while TokenId = ptSemicolon do + begin + NextToken; + TypeParamDecl; + end; +end; + +procedure TmwSimplePasPar.TypeParamList; +begin + {$IFDEF D8_NEWER} + if TokenId = ptSquareOpen then + AttributeSection; + {$ENDIF} + Identifier; + while TokenId = ptComma do + begin + NextToken; + {$IFDEF D8_NEWER} + if TokenId = ptSquareOpen then + AttributeSection; + {$ENDIF} + Identifier; + end; +end; + +procedure TmwSimplePasPar.TypeParams; +begin + Expected(ptLower); + TypeParamDeclList; + Expected(ptGreater); +end; + +procedure TmwSimplePasPar.ConstSection; +begin + case TokenID of + ptConst: + begin + NextToken; + {$IFDEF D8_NEWER} //JThurman 2004-03-22 + while TokenID in [ptIdentifier, ptSquareOpen] do + begin + if TokenID = ptSquareOpen then + CustomAttribute + else + begin + ConstantDeclaration; + SEMICOLON; + end; + end; + {$ELSE} + while (TokenID = ptIdentifier) do + begin + ConstantDeclaration; + SEMICOLON; + end; + {$ENDIF} + end; + ptResourceString: + begin + NextToken; + while (TokenID = ptIdentifier) do + begin + ResourceDeclaration; + SEMICOLON; + end; + end + else + begin + SynError(InvalidConstSection); + end; + end; +end; + +procedure TmwSimplePasPar.InterfaceDeclaration; +begin + case TokenID of + ptConst: + begin + ConstSection; + end; + ptFunction: + begin + ExportedHeading; + end; + ptProcedure: + begin + ExportedHeading; + end; + ptResourceString: + begin + ConstSection; + end; + ptType: + begin + TypeSection; + end; + ptThreadVar: + begin + VarSection; + end; + ptVar: + begin + VarSection; + end; + ptExports: + begin + ExportsClause; + end; + {$IFDEF D8_NEWER} //JThurman 2004-03-03 + ptSquareOpen: + begin + CustomAttribute; + end; + {$ENDIF} + else + begin + SynError(InvalidInterfaceDeclaration); + end; + end; +end; + +procedure TmwSimplePasPar.ExportsElement; +begin + Expected(ptIdentifier); + // if TokenID = ptIndex then + if FLexer.ExID = ptIndex then //jdj 20001207 + begin + NextToken; + Expected(ptIntegerConst); + end; + // if TokenID = ptName then + if FLexer.ExID = ptName then //jdj 20001207 + begin + NextToken; + CharString; + end; + // if TokenID = ptResident then + if FLexer.ExID = ptResident then //jdj 20001207 + begin + NextToken; + end; +end; + +procedure TmwSimplePasPar.CompoundStatement; +begin + Expected(ptBegin); + StatementList; + Expected(ptEnd); +end; + +procedure TmwSimplePasPar.ExportsClause; +begin + Expected(ptExports); + ExportsElement; + while TokenID = ptComma do + begin + NextToken; + ExportsElement; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.ContainsClause; +begin + ExpectedEx(ptContains); + ContainsStatement; + while TokenID = ptComma do + begin + NextToken; + ContainsStatement; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.ContainsStatement; +begin + ContainsIdentifier; + if fLexer.TokenID = ptIn then + begin + NextToken; + ContainsExpression; + end; +end; + +procedure TmwSimplePasPar.ContainsIdentifier; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.ContainsExpression; +begin + ConstantExpression; +end; + +procedure TmwSimplePasPar.RequiresClause; +begin + ExpectedEx(ptRequires); + RequiresIdentifier; + while TokenID = ptComma do + begin + NextToken; + RequiresIdentifier; + end; + SEMICOLON; +end; + +procedure TmwSimplePasPar.RequiresIdentifier; +begin + Expected(ptIdentifier); + {$IFDEF D8_NEWER} + while Lexer.TokenID = ptPoint do + begin + NextToken; + Expected(ptIdentifier); + end; + {$ENDIF} +end; + +procedure TmwSimplePasPar.InitializationSection; +begin + case TokenID of + ptInitialization: + begin + NextToken; + StatementList; + if TokenID = ptFinalization then + begin + NextToken; + StatementList; + end; + Expected(ptEnd); + end; + ptBegin: + begin + CompoundStatement; + end; + ptEnd: + begin + NextToken; + end; + else + begin + SynError(InvalidInitializationSection); + end; + end; +end; + +procedure TmwSimplePasPar.ImplementationSection; +begin + Expected(ptImplementation); + if TokenID = ptUses then + begin + UsesClause; + end; + while TokenID in [ptClass, ptConst, ptConstructor, ptDestructor, ptFunction, + ptLabel, ptProcedure, ptResourceString, ptThreadVar, ptType, ptVar, + ptExports + {$IFDEF D8_NEWER}//JThurman 2004-03-22 + , ptSquareOpen + {$ENDIF} + ] do //ptResourceString added jdj + begin + DeclarationSection; + end; +end; + +procedure TmwSimplePasPar.InterfaceSection; +begin + Expected(ptInterface); + if TokenID = ptUses then + begin + UsesClause; + end; + while TokenID in [ptConst, ptFunction, ptResourceString, ptProcedure, + ptThreadVar, ptType, ptVar, ptExports + {$IFDEF D8_NEWER} //JThurman 2004-03-03 + , ptSquareOpen + {$ENDIF} + ] do + begin + InterfaceDeclaration; + end; +end; + +procedure TmwSimplePasPar.IdentifierList; +begin + Identifier; // DR 2001-10-20 + while TokenID = ptComma do + begin + NextToken; + Identifier; + end; +end; + +procedure TmwSimplePasPar.QualifiedIdentifierList; +begin + QualifiedIdentifier; + while (TokenID = ptComma) do + begin + NextToken; + QualifiedIdentifier; + end; +end; + +procedure TmwSimplePasPar.CharString; +begin //updated mw 2/22/00, JThurman 6/24/2004 + case TokenID of + ptAsciiChar, ptIdentifier, ptRoundOpen, ptStringConst: + while TokenID in + [ptAsciiChar, ptIdentifier, ptPlus, ptRoundOpen, ptStringConst, + ptString] do + begin + case TokenID of + ptIdentifier, ptRoundOpen: + begin + VariableReference; + end; + ptString: //JT + begin + StringStatement; + end; + else + NextToken; + end; + {$IFDEF D8_NEWER} + if Lexer.TokenID = ptPoint then + begin + NextToken; + VariableReference; + end; + {$ENDIF} + end; + else + begin + SynError(InvalidCharString); + end; + end; +end; + +(*procedure TmwSimplePasPar.CharString; +begin //updated mw 2/22/00 + case TokenID of + ptAsciiChar, ptIdentifier, ptRoundOpen, ptStringConst: + while TokenID in + [ptAsciiChar, ptIdentifier, ptPlus, ptRoundOpen, ptStringConst] do + begin + case TokenID of + ptIdentifier, ptRoundOpen: + begin + VariableReference; + end; + else + NextToken; + end; + end; + else + begin + SynError(InvalidCharString); + end; + end; +end;*) + +(*procedure TmwSimplePasPar.CharString; +begin + case TokenID of + ptAsciiChar, ptStringConst: + while TokenID in [ptAsciiChar, ptPlus, ptStringConst] do + begin + case TokenID of + ptPlus: + begin + NextToken; + if TokenID = ptIdentifier then + begin + VariableReference; + end; + end; + else + begin + NextToken; + end; + end; + end; + ptIdentifier: + begin + VariableReference; + case TokenID of + ptPlus: + begin + NextToken; + while TokenID in [ptAsciiChar, ptPlus, ptStringConst] do + begin + case TokenID of + ptPlus: + begin + NextToken; + if TokenID = ptIdentifier then + begin + VariableReference; + end; + end; + else + begin + NextToken; + end; + end; + end; + end; + end; + end + else + begin + SynError(InvalidCharString); + end; + end; +end;*) + +procedure TmwSimplePasPar.IncludeFile; +begin + while TokenID <> ptNull do + case TokenID of + ptClass: + begin + ProcedureDeclarationSection; + end; + ptConst: + begin + ConstSection; + end; + ptConstructor: + begin + ProcedureDeclarationSection; + end; + ptDestructor: + begin + ProcedureDeclarationSection; + end; + ptExports: + begin + ExportsClause; + end; + ptFunction: + begin + ProcedureDeclarationSection; + end; + ptIdentifier: + begin + Lexer.InitAhead; + if Lexer.AheadTokenID in [ptColon, ptEqual] then + begin + ConstantDeclaration; + if TokenID = ptSemiColon then SEMICOLON; + end + else + NextToken; + end; + ptLabel: + begin + LabelDeclarationSection; + end; + ptProcedure: + begin + ProcedureDeclarationSection; + end; + ptResourceString: + begin + ConstSection; + end; + ptType: + begin + TypeSection; + end; + ptThreadVar: + begin + VarSection; + end; + ptVar: + begin + VarSection; + end; + else + begin + NextToken; + end; + end; +end; + +procedure TmwSimplePasPar.SkipSpace; //XM Jul-2000 +begin + Expected(ptSpace); + while TokenID in [ptSpace] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.SkipCRLFco; //XM Jul-2000 +begin + Expected(ptCRLFCo); + while TokenID in [ptCRLFCo] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.SkipCRLF; //XM Jul-2000 +begin + Expected(ptCRLF); + while TokenID in [ptCRLF] do + Lexer.Next; +end; + +procedure TmwSimplePasPar.ClassClass; +begin + Expected(ptClass); +end; + +procedure TmwSimplePasPar.PropertyDefault; +begin + ExpectedEx(ptDefault); +end; + +procedure TmwSimplePasPar.DispIDSpecifier; // DR 2001-07-26 +begin + ExpectedEx(ptDispid); + ConstantExpression; +end; + +procedure TmwSimplePasPar.IndexSpecifier; +begin + ExpectedEx(ptIndex); + ConstantExpression; +end; + +procedure TmwSimplePasPar.ClassTypeEnd; +begin +end; + +procedure TmwSimplePasPar.ObjectTypeEnd; +begin +end; + +procedure TmwSimplePasPar.DirectiveDeprecated; +begin + ExpectedEx(ptDeprecated); + if TokenID = ptStringConst then + NextToken; +end; + +procedure TmwSimplePasPar.DirectiveLibrary; +begin + ExpectedEx(ptLibrary); +end; + +procedure TmwSimplePasPar.DirectivePlatform; +begin + ExpectedEx(ptPlatform); +end; + +procedure TmwSimplePasPar.EnumeratedTypeItem; +begin + QualifiedIdentifier; + if TokenID = ptEqual then + begin + Expected(ptEqual); + ConstantExpression; + end; +end; + +procedure TmwSimplePasPar.Identifier; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.DirectiveLocal; +begin + ExpectedEx(ptLocal); +end; + +procedure TmwSimplePasPar.DirectiveVarargs; +begin + ExpectedEx(ptVarargs); +end; + +procedure TmwSimplePasPar.AncestorId; +begin + // !! Although I re-added this function I modified it + // so that it now calls QualifiedIdentifier, per DR's change + QualifiedIdentifier; +end; + +procedure TmwSimplePasPar.AncestorIdList; +begin + // !! Added this function back in + AncestorId; + while(TokenID = ptComma) do + begin + NextToken; + AncestorId; + end; +end; + + + +procedure TmwSimplePasPar.AnonymousMethod; +begin + case TokenID of + ptFunction: + begin + NextToken; + if TokenID = ptRoundOpen then + FormalParameterList; + Expected(ptColon); + ReturnType; + end; + ptProcedure: + begin + NextToken; + if TokenId = ptRoundOpen then + FormalParameterList; + end; + end; + Block; +end; + +procedure TmwSimplePasPar.AnonymousMethodType; +begin +{$IFDEF D11_NEWER} + ExpectedEx(ptReference); //ExID = ptReference + Expected(ptTo); + case TokenID of + ptProcedure: + begin + NextToken; + if TokenID = ptRoundOpen then + FormalParameterList; + end; + ptFunction: + begin + NextToken; + if TokenID = ptRoundOpen then + FormalParameterList; + Expected(ptColon); + ReturnType; + end; + end; +{$ENDIF} +end; + +procedure TmwSimplePasPar.AddDefine(const ADefine: string); +begin + FDefines.Add(ADefine); +end; + +procedure TmwSimplePasPar.RemoveDefine(const ADefine: string); +var + I: Integer; +begin + I := FDefines.IndexOf(ADefine); + if I > -1 then + FDefines.Delete(I); +end; + +function TmwSimplePasPar.IsDefined(const ADefine: string): Boolean; +begin + Result := FDefines.IndexOf(ADefine) > -1; +end; + +procedure TmwSimplePasPar.ClearDefines; +var + Frame: PDefineRec; +begin + FDefines.Clear; + FDefineStack := 0; + while FTopDefineRec <> nil do + begin + Frame := FTopDefineRec; + FTopDefineRec := Frame^.Next; + Dispose(Frame); + end; +end; + +procedure TmwSimplePasPar.InitAhead; +begin + if AheadParse = nil then + AheadParse := TmwSimplePasPar.Create; + AheadParse.Lexer.InitFrom(Lexer); +end; + +procedure TmwSimplePasPar.InitDefines; +begin + ClearDefines; + //Set up the defines that are defined by the compiler +// {$IFDEF VER130} +// AddDefine('VER130'); +// {$ENDIF} +// {$IFDEF VER140} +// AddDefine('VER140'); +// {$ENDIF} +// {$IFDEF VER150} +// AddDefine('VER150'); +// {$ENDIF} +// {$IFDEF VER160} +// AddDefine('VER160'); +// {$ENDIF} +// {$IFDEF VER170} +// AddDefine('VER170'); +// {$ENDIF} +// {$IFDEF VER180} +// AddDefine('VER180'); +// {$ENDIF} +// {$IFDEF VER185} +// AddDefine('VER185'); +// {$ENDIF} +// {$IFDEF VER190} +// AddDefine('VER190'); +// {$ENDIF} +// {$IFDEF VER200} +// AddDefine('VER200'); +// {$ENDIF} +// {$IFDEF WIN32} +// AddDefine('WIN32'); +// {$ENDIF} +// {$IFDEF LINUX} +// AddDefine('LINUX'); +// {$ENDIF} +// {$IFDEF CPU386} +// AddDefine('CPU386'); +// {$ENDIF} +// {$IFDEF MSWINDOWS} +// AddDefine('MSWINDOWS'); +// {$ENDIF} +// {$IFDEF CONDITIONALEXPRESSIONS} +// AddDefine('CONDITIONALEXPRESSIONS'); +// {$ENDIF} +end; + +procedure TmwSimplePasPar.EnterDefineBlock(ADefined: Boolean); +var + StackFrame: PDefineRec; +begin + Exit; + New(StackFrame); + StackFrame^.Next := FTopDefineRec; + StackFrame^.Defined := ADefined; + StackFrame^.StartCount := FDefineStack; + FTopDefineRec := StackFrame; +// if not ADefined then +// begin +// Inc(FDefineStack); +// repeat +// NextToken; +// if TokenID = ptNull then +// Break; +// until FDefineStack = 0; +// end +// else +// NextToken; + if not ADefined then + Inc(FDefineStack); + +// while FDefineStack > 0 do +// begin +// NextToken; +// if TokenID = ptNull then +// Break; +// end; +end; + +procedure TmwSimplePasPar.ExitDefineBlock; +var + StackFrame: PDefineRec; +begin + Exit; + StackFrame := FTopDefineRec; + if StackFrame <> nil then + begin + FDefineStack := StackFrame^.StartCount; + FTopDefineRec := StackFrame^.Next; + Dispose(StackFrame); + end; +end; + +{$IFDEF D8_NEWER} //JThurman 2004-03-03 + +procedure TmwSimplePasPar.GlobalAttributes; +begin + GlobalAttributeSections; +end; + +procedure TmwSimplePasPar.GlobalAttributeSections; +begin + while TokenID = ptSquareOpen do + GlobalAttributeSection; +end; + +procedure TmwSimplePasPar.GlobalAttributeSection; +begin + Expected(ptSquareOpen); + GlobalAttributeTargetSpecifier; + AttributeList; + while TokenID = ptComma do + begin + Expected(ptComma); + GlobalAttributeTargetSpecifier; + AttributeList; + end; + Expected(ptSquareClose); +end; + +procedure TmwSimplePasPar.GlobalAttributeTargetSpecifier; +begin + GlobalAttributeTarget; + Expected(ptColon); +end; + +procedure TmwSimplePasPar.GlobalAttributeTarget; +begin + Expected(ptIdentifier); +end; + +procedure TmwSimplePasPar.Attributes; +begin + AttributeSections; +end; + +procedure TmwSimplePasPar.AttributeSections; +begin + while TokenID = ptSquareOpen do + AttributeSection; +end; + +procedure TmwSimplePasPar.AttributeSection; +begin + Expected(ptSquareOpen); + Lexer.InitAhead; + if Lexer.AheadTokenID = ptColon then + AttributeTargetSpecifier; + AttributeList; + while TokenID = ptComma do + begin + Lexer.InitAhead; + if Lexer.AheadTokenID = ptColon then + AttributeTargetSpecifier; + AttributeList; + end; + Expected(ptSquareClose); +end; + +procedure TmwSimplePasPar.AttributeTargetSpecifier; +begin + AttributeTarget; + Expected(ptColon); +end; + +procedure TmwSimplePasPar.AttributeTarget; +begin + case TokenID of + ptProperty: + Expected(ptProperty); + ptType: + Expected(ptType); + else + Expected(ptIdentifier); + end; +end; + +procedure TmwSimplePasPar.AttributeList; +begin + Attribute; + while TokenID = ptComma do + begin + Expected(ptComma); + AttributeList; + end; +end; + +procedure TmwSimplePasPar.Attribute; +begin + AttributeName; + if TokenID = ptRoundOpen then + AttributeArguments; +end; + +procedure TmwSimplePasPar.AttributeName; +begin + case TokenID of + ptIn, ptOut, ptConst, ptVar: + NextToken; + else + Expected(ptIdentifier); + end; +end; + +procedure TmwSimplePasPar.AttributeArguments; +begin + Expected(ptRoundOpen); + if TokenID <> ptRoundClose then + begin + Lexer.InitAhead; + if Lexer.AheadTokenID = ptEqual then + NamedArgumentList + else + PositionalArgumentList; + if Lexer.TokenID = ptEqual then + NamedArgumentList; + end; + Expected(ptRoundClose); +end; + +procedure TmwSimplePasPar.PositionalArgumentList; +begin + PositionalArgument; + while TokenID = ptComma do + begin + Expected(ptComma); + PositionalArgument; + end; +end; + +procedure TmwSimplePasPar.PositionalArgument; +begin + AttributeArgumentExpression; +end; + +procedure TmwSimplePasPar.NamedArgumentList; +begin + NamedArgument; + while TokenID = ptComma do + begin + Expected(ptComma); + NamedArgument; + end; +end; + +procedure TmwSimplePasPar.NamedArgument; +begin + Expected(ptIdentifier); + Expected(ptEqual); + AttributeArgumentExpression; +end; + +procedure TmwSimplePasPar.AttributeArgumentExpression; +begin + Expression; +end; + +procedure TmwSimplePasPar.CustomAttribute; +begin + AttributeSection;//TODO: Global vs. Local attributes +{ Lexer.InitAhead; + if (Lexer.AheadToken = 'assembly') or (Lexer.AheadToken = 'module') then + GlobalAttributeSections + else} + AttributeSections; + +end; +{$ENDIF} + +end. + diff --git a/source/model/sourceCodeAnalysis/CastaliaSimplePasParTypes.pas b/source/model/sourceCodeAnalysis/CastaliaSimplePasParTypes.pas new file mode 100644 index 0000000..1e44c4b --- /dev/null +++ b/source/model/sourceCodeAnalysis/CastaliaSimplePasParTypes.pas @@ -0,0 +1,328 @@ +{--------------------------------------------------------------------------- +The contents of this file are subject to the Mozilla Public License Version +1.1 (the "License"); you may not use this file except in compliance with the +License. You may obtain a copy of the License at +http://www.mozilla.org/NPL/NPL-1_1Final.html + +Software distributed under the License is distributed on an "AS IS" basis, +WITHOUT WARRANTY OF ANY KIND, either express or implied. See the License for +the specific language governing rights and limitations under the License. + +The Original Code is: mwSimplePasParTypes, released November 14, 1999. + +The Initial Developer of the Original Code is Martin Waldenburg +unit CastaliaPasLexTypes; + +----------------------------------------------------------------------------} + +unit CastaliaSimplePasParTypes; + +interface + +uses SysUtils, TypInfo; + +type + TmwParseError = ( + InvalidAdditiveOperator, + InvalidAccessSpecifier, + InvalidCharString, + InvalidClassMethodHeading, + InvalidConstantDeclaration, + InvalidConstSection, + InvalidDeclarationSection, + InvalidDirective16Bit, + InvalidDirectiveBinding, + InvalidDirectiveCalling, + InvalidExportedHeading, + InvalidForStatement, + InvalidInitializationSection, + InvalidInterfaceDeclaration, + InvalidInterfaceType, + InvalidLabelId, + InvalidLabeledStatement, + InvalidMethodHeading, + InvalidMultiplicativeOperator, + InvalidNumber, + InvalidOrdinalIdentifier, + InvalidParameter, + InvalidParseFile, + InvalidProceduralDirective, + InvalidProceduralType, + InvalidProcedureDeclarationSection, + InvalidProcedureMethodDeclaration, + InvalidRealIdentifier, + InvalidRelativeOperator, + InvalidStorageSpecifier, + InvalidStringIdentifier, + InvalidStructuredType, + InvalidTryStatement, + InvalidTypeKind, + InvalidVariantIdentifier, + InvalidVarSection, + vchInvalidClass, //vch + vchInvalidMethod, //vch + vchInvalidProcedure,//vch + vchInvalidCircuit, //vch + vchInvalidIncludeFile //vch + ); + + TmwPasCodeInfo = ( + ciNone, //: @BUG heresy ! + ciAccessSpecifier, + ciAdditiveOperator, + ciArrayConstant, + ciArrayType, + ciAsmStatement, + ciBlock, + ciCaseLabel, + ciCaseSelector, + ciCaseStatement, + ciCharString, + ciClassClass, //DR 2001-07-16 + ciClassField, + ciClassForward, + ciClassFunctionHeading, + ciClassHeritage, + ciClassMemberList, + ciClassMethodDirective, + ciClassMethodHeading, + ciClassMethodOrProperty, + ciClassMethodResolution, + ciClassProcedureHeading, + ciClassProperty, + ciClassReferenceType, + ciClassType, + ciClassTypeEnd, // DR 2001-07-31 + ciClassVisibility, + ciCompoundStatement, + ciConstantColon, + ciConstantDeclaration, + ciConstantEqual, + ciConstantExpression, + ciConstantName, + ciConstantValue, + ciConstantValueTyped, + ciConstParameter, + ciConstructorHeading, + ciConstructorName, + ciConstSection, + ciContainsClause, + ciContainsExpression, + ciContainsIdentifier, + ciContainsStatement, + ciDeclarationSection, + ciDesignator, + ciDestructorHeading, + ciDestructorName, + ciDirective16Bit, + ciDirectiveBinding, + ciDirectiveCalling, + ciDirectiveDeprecated, // DR 2001-10-20 + ciDirectiveLibrary, // DR 2001-10-20 + ciDirectiveLocal, // DR 2001-11-14 + ciDirectivePlatform, // DR 2001-10-20 + ciDirectiveVarargs, // DR 2001-11-14 + ciDispIDSpecifier, // DR 2001-07-26 + ciDispInterfaceForward, + ciEmptyStatement, + ciEnumeratedType, + ciEnumeratedTypeItem, // DR 2001-10-29 + ciExceptBlock, + ciExceptionBlockElseBranch, + ciExceptionClassTypeIdentifier, + ciExceptionHandler, + ciExceptionHandlerList, + ciExceptionIdentifier, + ciExceptionVariable, + ciExpliciteType, + ciExportedHeading, + ciExportsClause, + ciExportsElement, + ciExpression, + ciExpressionList, + ciExternalDirective, + ciExternalDirectiveThree, + ciExternalDirectiveTwo, + ciFactor, + ciFieldDeclaration, + ciFieldList, + ciFileType, + ciFormalParameterList, + ciFormalParameterSection, + ciForStatement, + ciForwardDeclaration, // DR 2001-07-23 + ciFunctionHeading, + ciFunctionMethodDeclaration, + ciFunctionMethodName, + ciFunctionProcedureBlock, + ciFunctionProcedureName, + ciHandlePtCompDirect, //XM 20001125 + ciHandlePtDefineDirect, //XM 20001125 + ciHandlePtElseDirect, //XM 20001125 + ciHandlePtIfDefDirect, //XM 20001125 + ciHandlePtEndIfDirect, //XM 20001125 + ciHandlePtIfNDefDirect, //XM 20001125 + ciHandlePtIfOptDirect, //XM 20001125 + ciHandlePtIncludeDirect,//XM 20001125 + ciHandlePtResourceDirect,//XM 20001125 + ciHandlePtUndefDirect, //XM 20001125 + ciIdentifier, + ciIdentifierList, + ciIfStatement, + ciImplementationSection, + ciIncludeFile, + ciIndexSpecifier, // DR 2001-07-26 + ciInheritedStatement, + ciInitializationSection, + ciInlineStatement, + ciInterfaceDeclaration, + ciInterfaceForward, + ciInterfaceGUID, + ciInterfaceHeritage, + ciInterfaceMemberList, + ciInterfaceSection, + ciInterfaceType, + ciLabelDeclarationSection, + ciLabeledStatement, + ciLabelId, + ciLibraryFile, + ciMainUsedUnitExpression, + ciMainUsedUnitName, + ciMainUsedUnitStatement, + ciMainUsesClause, + ciMultiplicativeOperator, + ciNewFormalParameterType, + ciNumber, + ciNextToken, //XM 20002512 + ciObjectConstructorHeading, + ciObjectDestructorHeading, + ciObjectField, + ciObjectForward, + ciObjectFunctionHeading, + ciObjectHeritage, + ciObjectMemberList, + ciObjectMethodDirective, + ciObjectMethodHeading, + ciObjectNameOfMethod, + ciObjectProcedureHeading, + ciObjectProperty, // DR 2001-08-07 + ciObjectPropertySpecifiers, // DR 2001-08-07 + ciObjectType, + ciObjectTypeEnd, // DR 2001-08-07 + ciObjectVisibility, + ciOldFormalParameterType, + ciOrdinalIdentifier, + ciOrdinalType, + ciOutParameter, + ciPackageFile, + ciParameterFormal, + ciParameterName, + ciParameterNameList, + ciParseFile, + ciPointerType, + ciProceduralDirective, + ciProceduralType, + ciProcedureDeclarationSection, + ciProcedureHeading, + ciProcedureMethodDeclaration, + ciProcedureMethodName, + ciProgramBlock, + ciProgramFile, + ciPropertyDefault, // DR 2001-07-16 + ciPropertyInterface, + ciPropertyName, + ciPropertyParameterConst, + ciPropertyParameterList, + ciPropertySpecifiers, + ciQualifiedIdentifier, + ciQualifiedIdentifierList, + ciRaiseStatement, + ciReadAccessIdentifier, + ciRealIdentifier, + ciRealType, + ciRecordConstant, + ciRecordFieldConstant, + ciRecordType, + ciRecordVariant, + ciRelativeOperator, + ciRepeatStatement, + ciRequiresClause, + ciRequiresIdentifier, + ciResolutionInterfaceName, + ciResourceDeclaration, + ciReturnType, + ciSEMICOLON, //XM 20002512 + ciSetConstructor, + ciSetElement, + ciSetType, + ciSimpleExpression, + ciSimpleStatement, + ciSimpleType, + ciSkipAnsiComment, + ciSkipBorComment, + ciSkipSlashesComment, + ciSkipSpace, //XM 20002511 + ciSkipCRLFco, //XM 20002511 + ciSkipCRLF, //XM 20002511 + ciStatement, + ciStatementList, + ciStorageExpression, + ciStorageIdentifier, + ciStorageDefault, + ciStorageNoDefault, + ciStorageSpecifier, + ciStorageStored, + ciStringIdentifier, + ciStringStatement, + ciStringType, + ciStructuredType, + ciSubrangeType, + ciTagField, + ciTagFieldName, + ciTagFieldTypeName, + ciTerm, + ciTryStatement, + ciTypedConstant, + ciTypeDeclaration, + ciTypeId, + ciTypeKind, + ciTypeName, + ciTypeSection, + ciUnitFile, + ciUnitId, + ciUsedUnitName, + ciUsedUnitsList, + ciUsesClause, + ciVarAbsolute, + ciVarEqual, + ciVarDeclaration, + ciVariable, + ciVariableList, + ciVariableReference, + ciVariableTwo, + ciVariantIdentifier, + ciVariantSection, + ciVarParameter, + ciVarSection, + ciVisibilityAutomated, + ciVisibilityPrivate, + ciVisibilityProtected, + ciVisibilityPublic, + ciVisibilityPublished, + ciVisibilityUnknown, + ciWhileStatement, + ciWithStatement, + ciWriteAccessIdentifier + ); + +function ParserErrorName(Value: TmwParseError): string; + +implementation + +function ParserErrorName(Value: TmwParseError): string; +begin + result := GetEnumName(TypeInfo(TmwParseError), Integer(Value)); +end; + +end. + diff --git a/source/model/sourceCodeAnalysis/README.txt b/source/model/sourceCodeAnalysis/README.txt new file mode 100644 index 0000000..849f70c --- /dev/null +++ b/source/model/sourceCodeAnalysis/README.txt @@ -0,0 +1,16 @@ +These files make up a hand-written high speed parser for the Object Pascal dialect known as "Delphi." The original work was done byt Martin Waldenburg in the late 1990s, and the project was abandoned sometime before 2003, when I found the code and began working on it. I have kept it updated as necessary to work with my project, called "Castalia." + +More information about Castalia can be found at http://www.twodesk.com/castalia. + +To use the parser, you create a new class that descends from TmwSimplePasPar, and override the virtual methods for the various source code elements that you need to work with. This parser does not produce a syntax tree or a symbol table, but unmodified, it will act as an acceptor for Delphi code. + +!!!!! IMPORTANT !!!!! +One thing to note: The file names are used in the Castalia product, which is incorporated into the Delphi IDE. If you use this code in any Delphi IDE addin or components that will be installed into the Delphi IDE, you will need to change the names of the units to match your own project, or you will cause compatibility problems with other products. + +Once again: YOU MUST CHANGE THE FILENAMES TO SOMETHING UNIQUE TO YOU BEFORE USING THEM. + +Enjoy! + +--Jacob Thurman +jacob@jacobthurman.com +http://www.jacobthurman.com diff --git a/tests/GPProfTester.dproj b/tests/GPProfTester.dproj deleted file mode 100644 index e3daa42..0000000 --- a/tests/GPProfTester.dproj +++ /dev/null @@ -1,1096 +0,0 @@ - - - {145295FF-0EE8-4B4A-AA08-CE20E5940A27} - 20.1 - VCL - GPProfTester.dpr - True - Debug - Win32 - 1 - Application - GPProfTester - - - true - - - true - Base - true - - - true - Base - true - - - true - Base - true - - - true - Cfg_1 - true - true - - - true - Base - true - - - true - Cfg_2 - true - true - - - ..\include;$(DCC_UnitSearchPath) - .\$(Platform)\$(Config) - .\$(Platform)\$(Config) - false - false - false - false - false - inet;$(DCC_UsePackage) - System;Xml;Data;Datasnap;Web;Soap;Vcl;Vcl.Imaging;Vcl.Touch;Vcl.Samples;Vcl.Shell;$(DCC_Namespace) - $(BDS)\bin\delphi_PROJECTICON.ico - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_44.png - $(BDS)\bin\Artwork\Windows\UWP\delphi_UwpDefault_150.png - GPProfTester - - - rtl;fmxase;GPNative_d11;vcl;CustomIPTransport;vclactnband;vcldsnap;IndyCore;IndySystem;vclx;bindcomp;tethering;svnui;appanalytics;dsnap;bindcompvcl;SynEdit_R;vclimg;vcltouch;VclSmp;vcldb;bindcompfmx;svn;vclie;bindengine;dbrtl;IndyProtocols;fmx;fmxdae;xmlrtl;fmxobj;vclwinx;$(DCC_UsePackage) - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;Bde;$(DCC_Namespace) - true - 1033 - $(BDS)\bin\default_app.manifest - - - Winapi;System.Win;Data.Win;Datasnap.Win;Web.Win;Soap.Win;Xml.Win;$(DCC_Namespace) - Debug - CompanyName=;FileDescription=$(MSBuildProjectName);FileVersion=1.0.0.0;InternalName=;LegalCopyright=;LegalTrademarks=;OriginalFilename=;ProgramID=com.embarcadero.$(MSBuildProjectName);ProductName=$(MSBuildProjectName);ProductVersion=1.0.0.0;Comments= - 1033 - - - DEBUG;$(DCC_Define) - true - false - true - true - true - - - false - true - true - 1033 - Debug - PerMonitor - - - false - RELEASE;$(DCC_Define) - 0 - 0 - - - true - PerMonitor - - - - MainSource - - - - - - Base - - - Cfg_1 - Base - - - Cfg_2 - Base - - - - Delphi.Personality.12 - Application - - - - GPProfTester.dpr - - - - True - False - - - - - - 1 - - - Contents\MacOS - 1 - - - 0 - - - - - classes - 64 - - - classes - 64 - - - - - res\xml - 1 - - - res\xml - 1 - - - - - library\lib\armeabi - 1 - - - library\lib\armeabi - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - library\lib\mips - 1 - - - library\lib\mips - 1 - - - - - library\lib\armeabi-v7a - 1 - - - library\lib\arm64-v8a - 1 - - - - - library\lib\armeabi-v7a - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable-anydpi-v21 - 1 - - - res\drawable-anydpi-v21 - 1 - - - - - res\values - 1 - - - res\values - 1 - - - - - res\values-v21 - 1 - - - res\values-v21 - 1 - - - - - res\values-v31 - 1 - - - res\values-v31 - 1 - - - - - res\drawable-anydpi-v26 - 1 - - - res\drawable-anydpi-v26 - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable-anydpi-v33 - 1 - - - res\drawable-anydpi-v33 - 1 - - - - - res\values - 1 - - - res\values - 1 - - - - - res\values-night-v21 - 1 - - - res\values-night-v21 - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable-xxhdpi - 1 - - - res\drawable-xxhdpi - 1 - - - - - res\drawable-xxxhdpi - 1 - - - res\drawable-xxxhdpi - 1 - - - - - res\drawable-ldpi - 1 - - - res\drawable-ldpi - 1 - - - - - res\drawable-mdpi - 1 - - - res\drawable-mdpi - 1 - - - - - res\drawable-hdpi - 1 - - - res\drawable-hdpi - 1 - - - - - res\drawable-xhdpi - 1 - - - res\drawable-xhdpi - 1 - - - - - res\drawable-mdpi - 1 - - - res\drawable-mdpi - 1 - - - - - res\drawable-hdpi - 1 - - - res\drawable-hdpi - 1 - - - - - res\drawable-xhdpi - 1 - - - res\drawable-xhdpi - 1 - - - - - res\drawable-xxhdpi - 1 - - - res\drawable-xxhdpi - 1 - - - - - res\drawable-xxxhdpi - 1 - - - res\drawable-xxxhdpi - 1 - - - - - res\drawable-small - 1 - - - res\drawable-small - 1 - - - - - res\drawable-normal - 1 - - - res\drawable-normal - 1 - - - - - res\drawable-large - 1 - - - res\drawable-large - 1 - - - - - res\drawable-xlarge - 1 - - - res\drawable-xlarge - 1 - - - - - res\values - 1 - - - res\values - 1 - - - - - res\drawable-anydpi-v24 - 1 - - - res\drawable-anydpi-v24 - 1 - - - - - res\drawable - 1 - - - res\drawable - 1 - - - - - res\drawable-night-anydpi-v21 - 1 - - - res\drawable-night-anydpi-v21 - 1 - - - - - res\drawable-anydpi-v31 - 1 - - - res\drawable-anydpi-v31 - 1 - - - - - res\drawable-night-anydpi-v31 - 1 - - - res\drawable-night-anydpi-v31 - 1 - - - - - 1 - - - Contents\MacOS - 1 - - - 0 - - - - - Contents\MacOS - 1 - .framework - - - Contents\MacOS - 1 - .framework - - - Contents\MacOS - 1 - .framework - - - 0 - - - - - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 0 - .dll;.bpl - - - - - 1 - .dylib - - - 1 - .dylib - - - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - Contents\MacOS - 1 - .dylib - - - 0 - .bpl - - - - - 0 - - - 0 - - - 0 - - - 0 - - - 0 - - - Contents\Resources\StartUp\ - 0 - - - Contents\Resources\StartUp\ - 0 - - - Contents\Resources\StartUp\ - 0 - - - 0 - - - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - ..\ - 1 - - - - - Contents - 1 - - - Contents - 1 - - - Contents - 1 - - - - - Contents\Resources - 1 - - - Contents\Resources - 1 - - - Contents\Resources - 1 - - - - - library\lib\armeabi-v7a - 1 - - - library\lib\arm64-v8a - 1 - - - 1 - - - 1 - - - 1 - - - 1 - - - Contents\MacOS - 1 - - - Contents\MacOS - 1 - - - Contents\MacOS - 1 - - - 0 - - - - - library\lib\armeabi-v7a - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - ..\$(PROJECTNAME).app.dSYM\Contents\Resources\DWARF - 1 - - - - - ..\ - 1 - - - ..\ - 1 - - - ..\ - 1 - - - - - 1 - - - 1 - - - 1 - - - - - ..\$(PROJECTNAME).launchscreen - 64 - - - ..\$(PROJECTNAME).launchscreen - 64 - - - - - 1 - - - 1 - - - 1 - - - - - Assets - 1 - - - Assets - 1 - - - - - Assets - 1 - - - Assets - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\LaunchScreenImage.imageset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - ..\$(PROJECTNAME).launchscreen\Assets\AppIcon.appiconset - 1 - - - - - - - - - - - - - - - - - - 12 - - - - -