diff --git a/samples/Pascal/cwindirs.pp b/samples/Pascal/cwindirs.pp new file mode 100644 index 00000000..d97895e3 --- /dev/null +++ b/samples/Pascal/cwindirs.pp @@ -0,0 +1,121 @@ + +unit cwindirs; + + + + +interface + +uses + windows, + strings; + +Const + CSIDL_PROGRAMS = $0002; + CSIDL_PERSONAL = $0005; + CSIDL_FAVORITES = $0006; + CSIDL_STARTUP = $0007; + CSIDL_RECENT = $0008; + CSIDL_SENDTO = $0009; + CSIDL_STARTMENU = $000B; + CSIDL_MYMUSIC = $000D; + CSIDL_MYVIDEO = $000E; + CSIDL_DESKTOPDIRECTORY = $0010; + CSIDL_NETHOOD = $0013; + CSIDL_TEMPLATES = $0015; + CSIDL_COMMON_STARTMENU = $0016; + CSIDL_COMMON_PROGRAMS = $0017; + CSIDL_COMMON_STARTUP = $0018; + CSIDL_COMMON_DESKTOPDIRECTORY = $0019; + CSIDL_APPDATA = $001A; + CSIDL_PRINTHOOD = $001B; + CSIDL_LOCAL_APPDATA = $001C; + CSIDL_COMMON_FAVORITES = $001F; + CSIDL_INTERNET_CACHE = $0020; + CSIDL_COOKIES = $0021; + CSIDL_HISTORY = $0022; + CSIDL_COMMON_APPDATA = $0023; + CSIDL_WINDOWS = $0024; + CSIDL_SYSTEM = $0025; + CSIDL_PROGRAM_FILES = $0026; + CSIDL_MYPICTURES = $0027; + CSIDL_PROFILE = $0028; + CSIDL_PROGRAM_FILES_COMMON = $002B; + CSIDL_COMMON_TEMPLATES = $002D; + CSIDL_COMMON_DOCUMENTS = $002E; + CSIDL_COMMON_ADMINTOOLS = $002F; + CSIDL_ADMINTOOLS = $0030; + CSIDL_COMMON_MUSIC = $0035; + CSIDL_COMMON_PICTURES = $0036; + CSIDL_COMMON_VIDEO = $0037; + CSIDL_CDBURN_AREA = $003B; + CSIDL_PROFILES = $003E; + + CSIDL_FLAG_CREATE = $8000; + +Function GetWindowsSpecialDir(ID : Integer) : String; + +implementation + +uses + sysutils; + +Type + PFNSHGetFolderPath = Function(Ahwnd: HWND; Csidl: Integer; Token: THandle; Flags: DWord; Path: PChar): HRESULT; stdcall; + + +var + SHGetFolderPath : PFNSHGetFolderPath = Nil; + CFGDLLHandle : THandle = 0; + +Procedure InitDLL; + +Var + pathBuf: array[0..MAX_PATH-1] of char; + pathLength: Integer; +begin + { Load shfolder.dll using a full path, in order to prevent spoofing (Mantis #18185) + Don't bother loading shell32.dll because shfolder.dll itself redirects SHGetFolderPath + to shell32.dll whenever possible. } + pathLength:=GetSystemDirectory(pathBuf, MAX_PATH); + if (pathLength>0) and (pathLength0) then + begin + Pointer(ShGetFolderPath):=GetProcAddress(CFGDLLHandle,'SHGetFolderPathA'); + If @ShGetFolderPath=nil then + begin + FreeLibrary(CFGDLLHandle); + CFGDllHandle:=0; + end; + end; + end; + If (@ShGetFolderPath=Nil) then + Raise Exception.Create('Could not determine SHGetFolderPath Function'); +end; + +Function GetWindowsSpecialDir(ID : Integer) : String; + +Var + APath : Array[0..MAX_PATH] of char; + +begin + Result:=''; + if (CFGDLLHandle=0) then + InitDLL; + If (SHGetFolderPath<>Nil) then + begin + if SHGetFolderPath(0,ID or CSIDL_FLAG_CREATE,0,0,@APATH[0])=S_OK then + Result:=IncludeTrailingPathDelimiter(StrPas(@APath[0])); + end; +end; + +Initialization +Finalization + if CFGDLLHandle<>0 then + FreeLibrary(CFGDllHandle); +end. + diff --git a/samples/Pascal/gtkextra.pp b/samples/Pascal/gtkextra.pp deleted file mode 100644 index 9f2ebf8c..00000000 --- a/samples/Pascal/gtkextra.pp +++ /dev/null @@ -1,51 +0,0 @@ -{ $Id$ } -{ - --------------------------------------------------------------------------- - gtkextra.pp - GTK(2) widgetset - additional gdk/gtk functions - --------------------------------------------------------------------------- - - This unit contains missing gdk/gtk functions and defines for certain - versions of gtk or fpc. - - --------------------------------------------------------------------------- - - @created(Sun Jan 28th WET 2006) - @lastmod($Date$) - @author(Marc Weustink ) - - ***************************************************************************** - This file is part of the Lazarus Component Library (LCL) - - See the file COPYING.modifiedLGPL.txt, included in this distribution, - for details about the license. - ***************************************************************************** - } - -unit GtkExtra; - -{$mode objfpc}{$H+} - -interface - -{$I gtkdefines.inc} - -{$ifdef gtk1} -{$I gtk1extrah.inc} -{$endif} - -{$ifdef gtk2} -{$I gtk2extrah.inc} -{$endif} - - -implementation - -{$ifdef gtk1} -{$I gtk1extra.inc} -{$endif} - -{$ifdef gtk2} -{$I gtk2extra.inc} -{$endif} - -end. diff --git a/samples/Pascal/large.pp b/samples/Pascal/large.pp new file mode 100644 index 00000000..9e0f4867 --- /dev/null +++ b/samples/Pascal/large.pp @@ -0,0 +1,22 @@ +program large; + + const + max = 100000000; + + type + tlist = array[1..max] of longint; + + var + data : tlist; + i : integer; + +begin + + i := 0; + while(i < max) + do + begin + data[i] := 0; + Writeln(data[i]) + end +end. diff --git a/samples/Pascal/tw27294.pp b/samples/Pascal/tw27294.pp new file mode 100644 index 00000000..34d14f5d --- /dev/null +++ b/samples/Pascal/tw27294.pp @@ -0,0 +1,26 @@ +uses + uw27294; + +var + p : procedure; + +procedure test; + +begin + p:=@test; + writeln('OK'); +end; + +procedure global; +begin + p:=nil; + test; + p(); +end; + +begin + global; + uw27294.global; +end. + +