home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / pascal / library / dos / multtsk / cpm25d / rsctest.pas < prev    next >
Pascal/Delphi Source File  |  1994-04-28  |  2KB  |  85 lines
  1. {$I cpmswitc.inc}
  2.  
  3. {--------------------------------------------------------------------------
  4.  
  5. RSCTEST.PAS  (Program for testing the resource functions)
  6.  
  7. This program requires the CPMULTI Multitasking Toolkit and Turbo Pascal
  8. 5.0 or later.
  9.  
  10. January 1994
  11.  
  12. Copyright (C) 1994 (USA)        Copyright (C) 1989-1994
  13. Hypermetrics                    Christian Philipps Software-Technik
  14. PO Box 9700 Suite 363           Duesseldorfer Str. 316
  15. Austin, TX  78758-9700          D-47447 Moers
  16.                                 Germany
  17.  
  18. This program demonstrates the basic use of the resource functions
  19. in the CPMulti kernel.
  20.  
  21. ---------------------------------------------------------------------------}
  22.  
  23. program RscTest;
  24.  
  25. uses Dos, Crt, CpMulti;
  26.  
  27. var ScreenRsc : Pointer;
  28.  
  29. {----------------------------------------------------------------------}
  30.  
  31. procedure Recurse(Txt:String;Depth:Byte);
  32.  
  33. { For demonstration purposes the resource in this procedure ??
  34.   recursion. So long as the owner absetzt the wiederholten call, 
  35.   this will not lead to a block. The concurrency is ausgeschaltet, 
  36.   until the end of further recursion is reached; therefore no more
  37.   screen output is getätigt.
  38. }
  39.  
  40. begin
  41.   if Depth = 0 then
  42.   begin
  43.     if ReleaseRsc(ScreenRsc) <> Rsc_OK then
  44.       Writeln('Recurse: Error in ReleaseRsc!');
  45.     Exit;
  46.   end;
  47.   if RequestRsc(ScreenRsc,Wait) <> Rsc_OK then
  48.     Writeln('Recurse: Error in RequestRsc!');
  49.   Writeln(Txt,' Depth ',Depth);
  50.   Sleep(1);
  51.   Recurse(Txt,Depth-1);
  52. end;
  53.  
  54. {-----------------------------------------------------------------------------}
  55.  
  56. {$F+}
  57. procedure SubTask(P:Pointer);
  58.  
  59. begin
  60.   Recurse('Sub:',5);
  61.   Recurse('Sub:',5);
  62.   Recurse('Sub:',5);
  63. end;
  64. {$F-}
  65.  
  66. {-----------------------------------------------------------------------------}
  67.  
  68. begin
  69.   ClrScr;
  70.   if CreateRsc(ScreenRsc) <> Rsc_OK then
  71.   begin
  72.     Writeln('Error in CreateRsc!');
  73.     Halt(1);
  74.   end;
  75.   if CreateTask(SubTask,NIL,Pri_User,2000) < 0 then
  76.   begin
  77.     Writeln('Error in CreateTask!');
  78.     Halt(1);
  79.   end;
  80.   Sleep(1);
  81.   Recurse('Main:',5);
  82.   Recurse('Main:',5);
  83.   Recurse('Main:',5); 
  84. end.
  85.