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

@@ -247,9 +247,7 @@ begin
   if ErrorData.Module <> '' then
   begin;
     if not FileExists(ErrorData.Module) then
-      ErrorData.Module := ErrorData.IncludePath + ErrorData.Module;
+      Writeln(Format('ERROR comes from a non-existing file (%s)',[ErrorData.Module]))
-    if not FileExists(ErrorData.Module) then
-      Writeln('ERROR comes from a non-existing file....')
     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 ErrorData.Col = -1 then
-  if pos('error',lowercase(ErrorData.Error)) > 0 then
+    SynEdit.SelStart:= ErrorData.Position
-    formWriteln(Format('%s at line %d',[ErrorData.Error,ErrorData.Line]))
   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;

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);

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

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;');
 
 
 

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;
+      end;
-
+    end else
-function TMThread.LoadFile(var filename, contents: string): boolean;
+      psWriteln('Your LoadDLL directive has no params, thus cannot find the plugin');
-var
+  end else
-  path: string;
+  if CompareText(DirectiveName,'INCLUDE_ONCE') = 0 then
-  f: TFileStream;
-begin
-  if FileExists(filename) then
-    path:= filename
-  else
-    path:= IncludePath + filename;
-  if not FileExists(path) then
   begin
-    psWriteln(Path + ' doesn''t exist');
+    result := true; //Lets to the actual file checking later on in the preprocessor ;-)
-    Result := false;
+    if DirectiveArgs <> '' then
-    Exit;
+    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;
-  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;
-    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);

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;

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