From 4bd62c7237919755e04d68e8a231f9129b0e4188 Mon Sep 17 00:00:00 2001 From: Raymond Date: Fri, 26 Feb 2010 16:59:05 +0000 Subject: [PATCH] Added PlaySound for Windows, fixed the way errordata is displayed (PascalScript mucks up at returning the right coordinates..) Added Include_once, made it look for includes in more dirs (scriptpath, includepath and the current-file-path, fixed bug in Bitmaps where it would not set the bitmap to 'nil' in the actual BMP array. Fixed bug in ScriptPath (it would not include a trailing delimiter) git-svn-id: http://www.villavu.com/repositories/merlijn/mufasa@558 3f818213-9676-44b0-a9b4-5e4c4e03d09d --- trunk/Projects/SAMufasaGUI/framescript.pas | 18 +-- trunk/Projects/SAMufasaGUI/testunit.pas | 2 +- trunk/Units/MMLAddon/PSInc/Wrappers/other.inc | 18 +++ .../MMLAddon/PSInc/psexportedmethods.inc | 2 + trunk/Units/MMLAddon/mmlpsthread.pas | 132 +++++++++++------- trunk/Units/MMLCore/bitmaps.pas | 3 +- trunk/Units/PascalScript/uPSPreProcessor.pas | 3 +- 7 files changed, 118 insertions(+), 60 deletions(-) diff --git a/trunk/Projects/SAMufasaGUI/framescript.pas b/trunk/Projects/SAMufasaGUI/framescript.pas index 94f8b3c..73856e7 100644 --- a/trunk/Projects/SAMufasaGUI/framescript.pas +++ b/trunk/Projects/SAMufasaGUI/framescript.pas @@ -247,9 +247,7 @@ begin if ErrorData.Module <> '' then begin; if not FileExists(ErrorData.Module) then - ErrorData.Module := ErrorData.IncludePath + ErrorData.Module; - if not FileExists(ErrorData.Module) then - Writeln('ERROR comes from a non-existing file....') + Writeln(Format('ERROR comes from a non-existing file (%s)',[ErrorData.Module])) else begin ErrorData.Module:= SetDirSeparators(ErrorData.Module);// Set it right ;-) @@ -270,13 +268,16 @@ begin end; end; MakeActiveScriptFrame; - ScriptErrorLine:= ErrorData.Line; + ScriptErrorLine:= ErrorData.Row; SynEdit.Invalidate; - SynEdit.SelStart:= ErrorData.Position; - if pos('error',lowercase(ErrorData.Error)) > 0 then - formWriteln(Format('%s at line %d',[ErrorData.Error,ErrorData.Line])) + if ErrorData.Col = -1 then + SynEdit.SelStart:= ErrorData.Position else - formWriteln(Format('Error: %s at line %d',[ErrorData.Error,ErrorData.Line])); + SynEdit.LogicalCaretXY := Point(ErrorData.Col,ErrorData.Row); + if pos('error',lowercase(ErrorData.Error)) > 0 then + formWriteln(Format('%s at line %d',[ErrorData.Error,ErrorData.Row])) + else + formWriteln(Format('Error: %s at line %d',[ErrorData.Error,ErrorData.Row])); end; procedure TScriptFrame.MakeActiveScriptFrame; @@ -342,6 +343,7 @@ begin MarkCaret.IgnoreKeywords := true; end; AddKey(SynEdit,ecCodeCompletion,VK_SPACE,[ssCtrl]); +// TSynPasSyn(SynEdit.Highlighter).NestedComments:= false; Does not work :( end; destructor TScriptFrame.Destroy; diff --git a/trunk/Projects/SAMufasaGUI/testunit.pas b/trunk/Projects/SAMufasaGUI/testunit.pas index 6ac831d..65d71a2 100644 --- a/trunk/Projects/SAMufasaGUI/testunit.pas +++ b/trunk/Projects/SAMufasaGUI/testunit.pas @@ -931,7 +931,7 @@ begin Thread.OnError:= @CurrScript.HandleErrorData; if CurrScript.ScriptFile <> '' then - ScriptPath := ExtractFileDir(CurrScript.ScriptFile); + ScriptPath := IncludeTrailingPathDelimiter(ExtractFileDir(CurrScript.ScriptFile)); if DirectoryExists(PluginsPath) then PluginsGlob.AddPath(PluginsPath); diff --git a/trunk/Units/MMLAddon/PSInc/Wrappers/other.inc b/trunk/Units/MMLAddon/PSInc/Wrappers/other.inc index 84a75b7..2655ed7 100644 --- a/trunk/Units/MMLAddon/PSInc/Wrappers/other.inc +++ b/trunk/Units/MMLAddon/PSInc/Wrappers/other.inc @@ -42,6 +42,24 @@ begin end; {$endif} +procedure PlaySound( Sound : string); extdecl; +begin + {$ifdef MSWINDOWS} + sndPlaySound(PChar(sound),SND_ASYNC or SND_NODEFAULT); + {$else} + Writeln(Format('Playing sound %s (not supported yet on Linux)',[sound]); + {$endif} +end; + +Procedure StopSound; extdecl; +begin; + {$ifdef MSWINDOWS} + sndPlaySoundW(nil,0); + {$else} + Writeln('Stopping sound is not supported yet on Linux'); + {$endif} +end; + procedure ClearDebug; extdecl; begin if Assigned(CurrThread.DebugMemo) then diff --git a/trunk/Units/MMLAddon/PSInc/psexportedmethods.inc b/trunk/Units/MMLAddon/PSInc/psexportedmethods.inc index 220e2fb..4b75d13 100644 --- a/trunk/Units/MMLAddon/PSInc/psexportedmethods.inc +++ b/trunk/Units/MMLAddon/PSInc/psexportedmethods.inc @@ -126,6 +126,8 @@ AddFunction(@DrawBitmapDebugImg,'procedure DrawBitmapDebugImg(bmp: integer);'); AddFunction(@GetDebugBitmap,'function GetDebugBitmap: integer;'); AddFunction(@ps_Random,'function Random(Int: integer): integer;'); AddFunction(@ClearDebug,'procedure ClearDebug;'); +AddFunction(@PlaySound,'procedure PlaySound( Sound : string);'); +AddFunction(@StopSound,'Procedure StopSound;'); diff --git a/trunk/Units/MMLAddon/mmlpsthread.pas b/trunk/Units/MMLAddon/mmlpsthread.pas index e53ebe5..fe14217 100644 --- a/trunk/Units/MMLAddon/mmlpsthread.pas +++ b/trunk/Units/MMLAddon/mmlpsthread.pas @@ -58,7 +58,7 @@ type TErrorType = (errRuntime,errCompile); TOnError = procedure of object; TErrorData = record - Line,Position : integer; + Row,Col,Position : integer; Error : string; ErrType : TErrorType; Module : string; @@ -78,6 +78,7 @@ type DebugTo: TWritelnProc; DebugImg : TDbgImgInfo; ExportedMethods : TExpMethodArr; + Includes : TStringList; procedure LoadPlugin(plugidx: integer); virtual; abstract; public @@ -91,9 +92,9 @@ type OnError : TOnError; //Error handeler CompileOnly : boolean; - procedure HandleError(ErrorAtLine,ErrorPosition : integer; ErrorStr : string; ErrorType : TErrorType; ErrorModule : string); + procedure HandleError(ErrorRow,ErrorCol,ErrorPosition : integer; ErrorStr : string; ErrorType : TErrorType; ErrorModule : string); function ProcessDirective(DirectiveName, DirectiveArgs: string): boolean; - function LoadFile(var filename, contents: string): boolean; + function LoadFile(ParentFile : string; var filename, contents: string): boolean; procedure AddMethod(meth: TExpMethod); virtual; procedure SetScript(Script : string); @@ -174,7 +175,7 @@ implementation uses colour_conv,dtmutil, - {$ifdef mswindows}windows,{$endif} + {$ifdef mswindows}windows, MMSystem,{$endif}//MMSystem -> Sounds uPSC_std, uPSC_controls,uPSC_classes,uPSC_graphics,uPSC_stdctrls,uPSC_forms, uPSC_extctrls, //Compile-libs uPSUtils, @@ -273,6 +274,8 @@ begin CompileOnly := false; OnTerminate := @OnThreadTerminate; OnError:= nil; + Includes := TStringList.Create; + Includes.CaseSensitive:= {$ifdef linux}true{$else}false{$endif}; inherited Create(CreateSuspended); end; @@ -280,14 +283,16 @@ destructor TMThread.Destroy; begin MInternet.Free; Client.Free; + Includes.free; inherited Destroy; end; -procedure TMThread.HandleError(ErrorAtLine, ErrorPosition: integer; ErrorStr: string; ErrorType: TErrorType; ErrorModule : string); +procedure TMThread.HandleError(ErrorRow,ErrorCol, ErrorPosition: integer; ErrorStr: string; ErrorType: TErrorType; ErrorModule : string); begin if OnError = nil then exit; - ErrorData^.Line:= ErrorAtLine; + ErrorData^.Row:= ErrorRow; + ErrorData^.Col := ErrorCol; ErrorData^.Position:= ErrorPosition; ErrorData^.Error:= ErrorStr; ErrorData^.ErrType:= ErrorType; @@ -305,10 +310,57 @@ procedure TMThread.AddMethod(meth: TExpMethod); begin end; +function FindFile(filename : string; Dirs : array of string) : string; //Results '' if not found +var + i : integer; +begin; + if fileexists(filename) then + result := filename + else + begin + for i := 0 to high(Dirs) do + if DirectoryExists(dirs[i]) then + if fileexists(dirs[i] + filename) then + begin + result := dirs[i] + filename; + exit; + end; + end; +end; + +function TMThread.LoadFile(ParentFile : string; var filename, contents: string): boolean; +var + path: string; + f: TFileStream; +begin + path := FindFile(filename,[includepath,ScriptPath,IncludeTrailingPathDelimiter(ExtractFileDir(parentfile))]); + if path = '' then + begin + psWriteln(Path + ' doesn''t exist'); + Result := false; + Exit; + end; + filename := path;//Yeah! + Includes.Add(path); + + try + f:= TFileStream.Create(Path, fmOpenRead or fmShareDenyWrite); + SetLength(contents, f.Size); + f.Read(contents[1], Length(contents)); + result:= true; + f.free; + except + Result := false; + psWriteln('ERROR in TMThread.LoadFile'); + end; +end; + function TMThread.ProcessDirective(DirectiveName, DirectiveArgs: string): boolean; var plugin_idx, i: integer; + path : string; begin + result := false; if CompareText(DirectiveName,'LOADDLL') = 0 then begin if DirectiveArgs <> '' then @@ -316,45 +368,28 @@ begin plugin_idx:= PluginsGlob.LoadPlugin(DirectiveArgs); if plugin_idx < 0 then psWriteln(Format('Your DLL %s has not been found',[DirectiveArgs])) - else + else begin LoadPlugin(plugin_idx); - end; - end; - result:= True; -end; - -function TMThread.LoadFile(var filename, contents: string): boolean; -var - path: string; - f: TFileStream; -begin - if FileExists(filename) then - path:= filename - else - path:= IncludePath + filename; - if not FileExists(path) then + result:= True; + end; + end else + psWriteln('Your LoadDLL directive has no params, thus cannot find the plugin'); + end else + if CompareText(DirectiveName,'INCLUDE_ONCE') = 0 then begin - psWriteln(Path + ' doesn''t exist'); - Result := false; - Exit; - end; - try - f:= TFileStream.Create(Path, fmOpenRead or fmShareDenyWrite); - except - Result := false; - exit; - end; - try - try - SetLength(contents, f.Size); - f.Read(contents[1], Length(contents)); - result:= true; - finally - f.free; + result := true; //Lets to the actual file checking later on in the preprocessor ;-) + if DirectiveArgs <> '' then + begin + path := FindFile(DirectiveArgs,[ScriptPath,IncludePath]); + if path <> '' then + if Includes.Find(path,i) then + begin + psWriteln('Include_Once file already included'); + result := false; + end; end; - except - result:= false; - end; + end else + result := true; end; procedure TMThread.SetDebug(writelnProc: TWritelnProc); @@ -376,8 +411,9 @@ begin FontPath:= FontP; end; -function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant; stdcall; +function ThreadSafeCall(ProcName: string; var V: TVariantArray): Variant; extdecl; begin + Writeln('yo'); CurrThread.SyncInfo^.MethodName:= ProcName; CurrThread.SyncInfo^.V:= V; CurrThread.SyncInfo^.OldThread := CurrThread; @@ -550,7 +586,7 @@ end; function TPSThread.RequireFile(Sender: TObject; const OriginFileName: String; var FileName, OutPut: string): Boolean; begin - result:= LoadFile(FileName,OutPut); + result:= LoadFile(OriginFileName,FileName,OutPut); end; procedure SIRegister_Mufasa(cl: TPSPascalCompiler); @@ -659,7 +695,7 @@ begin b := True; if OnError <> nil then with PSScript.CompilerMessages[l] do - HandleError(Row, Pos, MessageToString,errCompile, ModuleName) + HandleError(Row, Col, Pos, MessageToString,errCompile, ModuleName) else psWriteln(PSScript.CompilerErrorToStr(l) + ' at line ' + inttostr(PSScript.CompilerMessages[l].Row)); end else @@ -682,7 +718,7 @@ begin exit; // if not (ScriptState = SCompiling) then if not PSScript.Execute then - HandleError(PSScript.ExecErrorRow,PSScript.ExecErrorPosition,PSScript.ExecErrorToString, + HandleError(PSScript.ExecErrorRow,PSScript.ExecErrorCol,PSScript.ExecErrorPosition,PSScript.ExecErrorToString, errRuntime, PSScript.ExecErrorFileName) else psWriteln('Succesfully executed'); @@ -733,9 +769,9 @@ end; procedure Interpreter_ErrorHandler(line, pos: integer; err: PChar; runtime: boolean); stdcall; begin if runtime then - CurrThread.HandleError(line,pos,err,errRuntime,'') + CurrThread.HandleError(line,-1,pos,err,errRuntime,'') else - CurrThread.HandleError(line,pos,err,errCompile,'') + CurrThread.HandleError(line,-1,pos,err,errCompile,'') end; constructor TCPThread.Create(CreateSuspended: Boolean; TheSyncInfo : PSyncInfo; plugin_dir: string); diff --git a/trunk/Units/MMLCore/bitmaps.pas b/trunk/Units/MMLCore/bitmaps.pas index c583689..5c66d1d 100644 --- a/trunk/Units/MMLCore/bitmaps.pas +++ b/trunk/Units/MMLCore/bitmaps.pas @@ -395,7 +395,8 @@ begin Writeln(Format('BMP[%d] has been freed.',[number])) else Writeln(Format('BMP[%s] has been freed.',[ToDestroy.BmpName])); - FreeAndNil(ToDestroy); + ToDestroy.Free; + BmpArray[number] := nil; end; function TMufasaBitmap.SaveToFile(const FileName: string): boolean; diff --git a/trunk/Units/PascalScript/uPSPreProcessor.pas b/trunk/Units/PascalScript/uPSPreProcessor.pas index 6be2689..15e5007 100644 --- a/trunk/Units/PascalScript/uPSPreProcessor.pas +++ b/trunk/Units/PascalScript/uPSPreProcessor.pas @@ -611,11 +611,10 @@ begin //-- 20050707_jgv - ask the application AppContinue := True; If @OnProcessDirective <> Nil then OnProcessDirective (Self, Parser, FDefineState.DoWrite, name, s, AppContinue); - If AppContinue then //-- end jgv - if (Name = 'I') or (Name = 'INCLUDE') or (Name = '.INCLUDE') then + if (Name = 'I') or (Name = 'INCLUDE') or (Name = 'INCLUDE_ONCE') then begin if FDefineState.DoWrite then begin