Menu
▾
▴
[Win32forth-cvs] win32forth-stc/src POINTER.F, NONE, 1.1 extend.f, 1.5, 1.6 primutil.f, 1.7, 1.8 task.f, 1.2, 1.3
|
From: George H. <geo...@us...> - 2006-10-04 12:00:09
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv24528/win32forth-stc/src Modified Files: extend.f primutil.f task.f Added Files: POINTER.F Log Message: gah:Added Pointer.f and updated Task.f to match newest ITC version Index: task.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/task.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** task.f 25 Sep 2006 11:57:53 -0000 1.2 --- task.f 4 Oct 2006 12:00:03 -0000 1.3 *************** *** 5,29 **** cr .( Loading Task Support...) \ -------------------- Task Control Block Offsets -------------------- ! cell ! cell field+ task>parm ( thread -- addr ) \ thread parameter ! cell field+ task>id ( thread -- addr ) \ thread id ! cell field+ task>handle ( thread -- addr ) \ thread handle ! cell field+ task>stop ( thread -- addr ) \ the stop flag drop ! : task>parm@ ( task-block -- parm ) \ extract the parameter task>parm @ ; \ -------------------- Task Start Initialisation -------------------- ! 1 proc ExitThread as exit-task ( n -- ) \ exit the thread : (task) ( parm cfa -- ) \ helper routine catch \ execute cfa and catch errors gah 27nov03 ! Exit-Task \ and exit the thread, never returns ; code begin-task ( -- ) \ thread management. init a new thread/task push ebp \ save regs --- 5,116 ---- cr .( Loading Task Support...) + \ *D doc + \ *! p-task W32F Task + \ *T Using the Task Wordset + + \ *P The multi-tasker is not loaded in the system by default so the file TASK.F in the lib + \ ** folder should be included in any program that multi-tasks, unless using the file + \ ** MULTITHR.F (also in the lib folder) which includes it automatically. + \ *P Multi-tasking in Win32Forth is accomplished by using the Windows\_® \d multi-tasker. + \ ** This is a pre-emptive multi-tasker. + + \ *S The Task Control Block + + \ *P The task control block (also known as task-block or TCB) is a small structure either + \ ** alloted in the dictionary or allocated on the heap containing information about a task. + \ *B The xt and parameter variables are set when the task-block is created. + \ *B The stop flag can be set by other tasks and is used to signal the task that it has + \ ** been asked to finish. + \ *B The ID is set when the task is created and is valid only until the task terminates. + \ *B The handle is set when the task is created and is valid until it is closed by the + \ ** API CloseHandle function, even after the task has terminated. The operating system + \ ** does not free the OS resources allocated to a task until all handles (except for + \ ** the pseudohandle returned by the API GetCurrentThread) are closed and + \ ** the task has terminated. Programs should close the handle as soon as it's no longer + \ ** needed (if it's never used close it at the start of the task word). + + \ *S The User Area + + \ *P When a task is created the operating system allocates a stack for the task. + \ ** Win32Forth splits this stack into three regions, a return stack, a User area + \ ** and a data stack. The address of this User area is stored in thread local + \ ** storage so that callbacks have access to the correct User area for the task + \ ** (Versions prior to V6.05 always used the main task's User area for callbacks). + \ ** When a task starts the contents of the User area are undefined except + \ *B Base is set to decimal. + \ *B The exception handler is set so the task exits if an exception is thrown, returning + \ ** the error code to the operating system. + \ *B TCB is set to the task control block of the task. + \ *B RP0 is set to the base of the return stack. + \ *B SP0 is set to the base of the data stack. + \ *P All other User variables used by a task should be explicitly set before use. + \ ** If the task uses floating-point words then FINIT should be called first. + + \ *S Glossary + \ -------------------- Task Control Block Offsets -------------------- ! cell checkstack ! cell field+ task>parm ( task-block -- addr ) \ W32F Task ! \ *G Convert the task-block address into the address of the thread parameter ! cell field+ task>id ( task-block -- addr ) \ W32F Task ! \ *G Convert the task-block address into the address of the thread id ! cell field+ task>handle ( task-block -- addr ) \ W32F Task ! \ *G Convert the task-block address into the address of the thread handle ! cell field+ task>stop ( task-block -- addr ) \ W32F Task ! \ *G Convert the task-block address into the address of the the stop flag drop ! : task>parm@ ( task-block -- parm ) \ W32F Task ! \ *G Fetch the parameter from the task-block. task>parm @ ; \ -------------------- Task Start Initialisation -------------------- ! 1 proc ExitThread as exit-task ( n -- ) \ W32F Task ! \ *G Exit the current task returning the value n to the operating system, which can be retrieved ! \ ** by calling GetExitCodeThread. The stacks and user area for the thread are freed and ! \ ** DLLs are detatched. If the thread is the last active thread of the process then the ! \ ** process is terminated. : (task) ( parm cfa -- ) \ helper routine catch \ execute cfa and catch errors gah 27nov03 ! exit-task \ and exit the thread, never returns ; + \ ===========================ITC ONLY===================================================== + + \ cfa-code BEGIN-TASK ( -- ) \ thread management. init a new thread/task + \ push ebp \ save regs + \ push ebx + \ push edi + \ push esi + \ mov ebp, esp + \ call TASK-ENTRY \ setup stacks, error-handler etc (in kernel) + \ mov eax, 5 cells [ebp] \ get task block + \ mov TCB [UP] , eax \ save in TCB + \ mov ebx, 4 [eax] \ parameter + \ push ebx \ save it + \ mov ebx, 0 [eax] \ cfa = tos + \ mov eax, # ' (task) \ get helper entry point + \ exec c; \ go do it + \ + \ -------------------- Task Management -------------------- + \ + \ : (create-task) ( thread state -- flag ) \ create a task + \ swap \ state addr + \ dup task>stop off \ turn off stop flag + \ dup>r \ put address of task on rstack + \ task>id \ threadid pointer + \ swap ( CREATE_SUSPENDED | 0 ) \ run it later? from state on stack + \ r@ \ parameter (ptr to cfa/parm pair) + \ begin-task \ task entry code + \ 0 0 \ stack, thread attributes + \ call CreateThread dup + \ r> task>handle ! \ save in threadid + \ 0<> ; \ and set the flag, true=ok + + \ ===========================STC ONLY===================================================== + code begin-task ( -- ) \ thread management. init a new thread/task push ebp \ save regs *************** *** 58,82 **** 0<> ; \ and set the flag, true=ok ! : create-task ( addr -- flag ) \ create task suspended CREATE_SUSPENDED (create-task) ; ! : run-task ( addr -- flag ) \ create task running 0 (create-task) ; ! : suspend-task ( addr -- flag ) \ suspend a task task>handle @ \ point at thread handle call SuspendThread -1 <> ; \ true=0K ! : resume-task ( addr -- flag ) \ suspend a task task>handle @ \ point at thread handle call ResumeThread -1 <> ; \ true=0K ! : stop-task ( addr -- ) \ stop the task task>stop on ; \ stop flag ! : task-sleep ( n -- ) \ sleep the task for n ms call Sleep drop ; ! : (task-block) ( parm cfa-task addr -- len ) \ build a task block at addr dup>r ! \ cfa r@ cell+ ! \ parameter for the task --- 145,180 ---- 0<> ; \ and set the flag, true=ok ! \ ======================================================================================== ! ! : create-task ( task-block -- flag ) \ W32F Task ! \ *G Create a new task which is suspended. Flag is true if successful. CREATE_SUSPENDED (create-task) ; ! : run-task ( task-block -- flag ) \ W32F Task ! \ *G Create a new task and run it. Flag is true if successful. 0 (create-task) ; ! : suspend-task ( task-block -- flag ) \ W32F Task ! \ *G Suspend a task. Flag is true if successful. task>handle @ \ point at thread handle call SuspendThread -1 <> ; \ true=0K ! : resume-task ( task-block -- flag ) \ W32F Task ! \ *G Resume a task. Flag is true if successful. task>handle @ \ point at thread handle call ResumeThread -1 <> ; \ true=0K ! : stop-task ( task-block -- ) \ W32F Task ! \ *G Set the stop flag of the task block to true. task>stop on ; \ stop flag ! : task-sleep ( n -- ) \ W32F Task ! \ *G Suspend the current task for at least n msec. If n is INFINITE (-1) the task is suspended ! \ ** forever. call Sleep drop ; ! : (task-block) ( parm cfa-task addr -- len ) \ W32F Task ! \ *G Build a task block at the supplied address, initialise the parameter and xt and ! \ ** return the size of the task block. dup>r ! \ cfa r@ cell+ ! \ parameter for the task *************** *** 87,91 **** ; ! : task-block ( parm cfa-task -- addr ) \ a task-block here >r \ return this block's address , \ cfa to execute as task --- 185,191 ---- ; ! : task-block ( parm cfa-task -- addr ) \ W32F Task ! \ *G Build a task block in the dictionary, initialise the parameter and xt and return ! \ ** the address of the block. here >r \ return this block's address , \ cfa to execute as task *************** *** 96,100 **** r> ; \ return structure ! : task-stop? ( task-block -- ) \ pause, stop if we're told task>stop @ ; \ check, exit if stop set --- 196,202 ---- r> ; \ return structure ! : task-stop? ( task-block -- flag ) \ W32F Task ! \ *G Flag is true if stop-task has been set by another task. In this case the task should ! \ ** do any necessary clean-up and exit. task>stop @ ; \ check, exit if stop set *************** *** 109,131 **** external ! : lock ( lock -- ) \ lock on a lock call EnterCriticalSection drop ; ! : unlock ( lock -- ) \ unlock a lock call LeaveCriticalSection drop ; ! : trylock ( lock -- fl ) \ try a lock ! call TryEnterCriticalSection 0<> ; \ 0 -- lock is blocked internal : init-lock ( lock -- ) 0 swap call InitializeCriticalSectionAndSpinCount drop ; external in-system ! : make-lock ( -<name>- -- ) \ create a lock create here lock-size ( 6 cells ) allot \ gah --- 211,268 ---- external ! \ *S Locking Resources ! ! \ *P Since the multi-tasker is pre-emptive it is sometimes necessary to restrict access ! \ ** to resources to a single task to prevent inteference between different tasks. ! \ ** Win32Forth provides a set of words for efficiently locking sections of code. ! \ ** The system also contains some locks used internally that are transparent to the user. ! ! \ *S Glossary ! ! : lock ( lock -- ) \ W32F Lock ! \ *G If another thread owns the lock wait until it's free, ! \ ** then if the lock is free claim it for this thread, ! \ ** then increment the lock count. call EnterCriticalSection drop ; ! : unlock ( lock -- ) \ W32F Lock ! \ *G Decrement the lock count and free the lock if the resultant count is zero. call LeaveCriticalSection drop ; ! winver winnt4 < [if] ! \ sorry, TryEnterCriticalSection() is only avaible for NT4 and later !!! ! ! : trylock ( lock -- fl ) ! lock true ; internal : init-lock ( lock -- ) + call InitializeCriticalSection drop ; + + [else] + + : trylock ( lock -- fl ) \ W32F Lock + \ *G \b For NT4, w2k and XP; \d + \ ** If the lock is owned by another thread return false. \n + \ ** If the lock is free claim it for this thread, + \ ** then increment the lock count and return true. \n + \ ** \b For Win9x, and NT<4; \d + \ ** Perform the action of LOCK and return true. + call TryEnterCriticalSection 0<> ; + + internal + + : init-lock ( lock -- ) \ Initialise a lock 0 swap call InitializeCriticalSectionAndSpinCount drop ; + [then] + external in-system ! : make-lock ( compiling: -<name>- -- runtime: -- lock ) \ W32F Lock ! \ *G Create a new lock. When executed the lock returns it's identifier. create here lock-size ( 6 cells ) allot \ gah *************** *** 137,143 **** internal ! : init-lock-from-list ( addr -- ) lock-size - init-lock ; ! : init-locks ['] init-lock-from-list lock-list do-link ; initialization-chain chain-add init-locks --- 274,282 ---- internal ! : init-lock-from-list ( addr -- ) \ Initialise a lock given address of link ! lock-size - init-lock ; ! : init-locks ( -- ) \ Initialise all the locks ! ['] init-lock-from-list lock-list do-link ; initialization-chain chain-add init-locks *************** *** 147,185 **** \ of dialog linking and control subclasssing ! make-lock mem-lock \ to make mem allocation thread safe make-lock control-lock \ to make control subclassing thread safe ! make-lock dialog-lock \ to make linling dialogs thread safe ! : _memlock mem-lock lock ; \ for overriding defered lock memory word ! : _memunlock mem-lock unlock ; \ for overriding defered unlock memory word ! : _controllock control-lock lock ; \ for overriding deferred lock subclassing word ! : _controlunlock control-lock unlock ; \ for overriding deferred unlock subclassing word ! : _dialoglock dialog-lock lock ; \ for overriding deferred lock dialog linking word ! : _dialogunlock dialog-lock unlock ; \ for overriding deferred unlock dialog linking word ! : init-system-locks \ initialize system locks for multitasking ! ['] _memlock is (memlock) ! ['] _memunlock is (memunlock) ! ['] _controllock is (controllock) ! ['] _controlunlock is (controlunlock) ! ['] _dialoglock is (dialoglock) ! ['] _dialogunlock is (dialogunlock) ; init-system-locks initialization-chain chain-add init-system-locks ! \ -------------------- Forgetting Locks ----------------------------- ! \ WARNING Before using FORGET or executing MARKER words Unlock any locks which are ! \ about to be forgotten to avoid memory leaks AND exit any threads which will be ! \ forgotten to avoid CRASHING !! YOU HAVE BEEN WARNED ! ! module ! ! \s in-system ! \s : delete-locks ( nfa link -- nfa ) \ delete lock if created after nfa 2dup trim? if lock-size - call DeleteCriticalSection then drop ; --- 286,337 ---- \ of dialog linking and control subclasssing ! make-lock mem-lock \ to make memory allocation thread safe make-lock control-lock \ to make control subclassing thread safe ! make-lock dialog-lock \ to make linking dialogs thread safe ! make-lock classname-lock \ to make unique window class naming thread safe ! make-lock pointer-lock \ to make allocating pointers thread safe ! make-lock dyn-lock \ to make new$ thread safe ! : _memlock ( -- ) mem-lock lock ; \ for overriding defered lock memory word ! : _memunlock ( -- ) mem-lock unlock ; \ for overriding defered unlock memory word ! : _controllock ( -- ) control-lock lock ; \ for overriding deferred lock subclassing word ! : _controlunlock ( -- ) control-lock unlock ; \ for overriding deferred unlock subclassing word ! : _dialoglock ( -- ) dialog-lock lock ; \ for overriding deferred lock dialog linking word ! : _dialogunlock ( -- ) dialog-lock unlock ; \ for overriding deferred unlock dialog linking word ! : _classnamelock ( -- ) classname-lock lock ; \ ! : _classnameunlock ( -- ) classname-lock unlock ; ! : _pointerlock ( -- ) pointer-lock lock ; ! : _pointerunlock ( -- ) pointer-lock unlock ; ! : _dynlock ( -- ) dyn-lock lock ; ! : _dynunlock ( -- ) dyn-lock unlock ; ! ! : init-system-locks ( -- ) \ initialize system locks for multitasking ! ['] _memlock is (memlock) ! ['] _memunlock is (memunlock) ! ['] _controllock is (controllock) ! ['] _controlunlock is (controlunlock) ! ['] _dialoglock is (dialoglock) ! ['] _dialogunlock is (dialogunlock) ! ['] _classnamelock is (classnamelock) ! ['] _classnameunlock is (classnameunlock) ! ['] _pointerlock is (pointerlock) ! ['] _pointerunlock is (pointerunlock) ! ['] _dynlock is (dynlock) ! ['] _dynunlock is (dynunlock) ; init-system-locks initialization-chain chain-add init-system-locks ! \s ========================STC DOESN'T HAVE FORGET YET==================================== \ -------------------- Forgetting Locks ----------------------------- ! \ *S WARNING ! \ *P Before using FORGET or executing MARKER words unlock any locks which are ! \ ** about to be forgotten to avoid memory leaks AND exit any threads which will be ! \ ** forgotten to avoid \b CRASHING !! YOU HAVE BEEN WARNED \d in-system ! : delete-locks ( nfa link -- nfa ) \ delete lock if created after nfa 2dup trim? if lock-size - call DeleteCriticalSection then drop ; *************** *** 194,195 **** --- 346,348 ---- module + \ *Z --- NEW FILE: POINTER.F --- \ $Id: POINTER.F,v 1.1 2006/10/04 12:00:03 georgeahubert Exp $ \ POINTER.F External memory allocation and management by Tom Zimmer \ For STC G.Hubert Sunday, October 01 2006 cr .( Loading Memory Pointer...) \ BODY +0 +4 +8 | \ [ phy_pointer ][ link ][ size_bytes ] | in-application internal VARIABLE PHEAD PHEAD OFF :NONAME ( LINK -- ) \ POINTERS-INIT CELL- OFF \ clear the pointer ; : POINTERS-INIT ( -- ) \ clear each pointer in turn LITERAL [ !CSP ] \ make sure CSP is adjusted PHEAD DO-LINK ; \ from noname above initialization-chain chain-add pointers-init external : Pointer ( bytes -<name>- ) \ make a pointer "name" >APPLICATION \ always in app space 128 max \ at least 160 bytes create ( header DoPointer compile, ) 0 , \ initialize to unallocated HERE PHEAD @ , PHEAD ! \ link into chain , \ lay in size in bytes APPLICATION> does> \ back to where we came from \ cfa-func DoPointer ( -- address ) \ it's location dup @ if @ exit then \ ok, straight fetch dup (pointerlock) @ if (pointerunlock) @ exit then \ another task won the race dup 2 cells+ @ allocate 0= if dup off \ set first cell to zeros tuck swap ! (pointerunlock) exit then (pointerunlock) 1- abort" Failed to allocate POINTER" ; \ Forgetting and decompiling to be done. \ in-system \ \ : TRIM-POINTERS ( a1 -- a1 ) \ PHEAD \ BEGIN @ ?DUP \ WHILE 2DUP TRIM? \ IF DUP CELL- @ ?DUP \ IF RELEASE \ THEN \ THEN \ REPEAT DUP PHEAD FULL-TRIM ; \ \ forget-chain chain-add trim-pointers \ \ : (.Pointer) ( pfa -- ) \ dup 2 cells+ @ 10 U,.R ." bytes at: " \ @ ?DUP \ IF 13 H.R \ ELSE ." <unallocated>" \ THEN ; \ \ : .Pointer ( cfa -- ) \ ." POINTER " dup .name >body (.Pointer) ; \ \ external \ \ :NONAME ( link -- ) \ .POINTERS \ cr CELL- dup>r (.Pointer) ." for: " R> body> .NAME \ ; : .POINTERS ( -- ) \ LITERAL [ !CSP ] \ make sure CSP is adjusted \ PHEAD DO-LINK ; \ from noname above \ \ internal \ : (IsPointer?) ( plink -- plink ) \ check for valid pointer structure \ DUP @ Dopointer <> \ IF DUP CR h. \ .name \ ." is NOT a valid POINTER structure!" \ ABORT \ THEN ; \ in-application : IsPointer? ( cfa -- cfa ) ; immediate \ check for valid pointer structure \ \in-system-ok TURNKEYED? ?EXIT (IsPointer?) ; \ no point if this is turnkeyed external : %UnPointer ( cfa -- ) \ deallocate pointer given the cfa IsPointer? >BODY DUP @ 0<> \ only if non-zero (added missing 0<> February 6th, 2004 - 18:35 dbu) IF DUP @ release \ release the memory off \ clear the memory pointer ELSE DROP THEN ; : >POINTER ( cfa -- ptr ) \ move to ptr IsPointer? >BODY 2 cells+ ; : %SizeOf! ( bytes cfa -- ) \ set the size of pointer "cfa" >POINTER ! ; : %SizeOf@ ( cfa -- bytes ) \ get the size of pointer "cfa" >POINTER @ ; : (ResizePointer) ( size size pointer -- f ) dup>r 2 cells+ ! \ first, adjust the size of the desired pointer r@ @ 0= IF r>drop \ if it isn't allocated yet, just leave drop FALSE \ things went just fine. EXIT \ April 15th, 1999 - 10:51 tjz corrected THEN r@ @ (pointerlock) realloc 0= if r> ! FALSE else drop r>drop TRUE then (pointerunlock) ; : ResizePointer ( size -<Pointer>- flag ) \ return FALSE if all went ok dup ' >body (resizepointer) compilation> drop postpone dup ' >body postpone literal postpone (resizepointer) ; \ in-system \ These words need to be compile\interpret words \ : UnPointer> ( name -- ) \ deallocate a pointer name following \ ' STATE @ \ IF POSTPONE LITERAL \ POSTPONE %UNPOINTER \ ELSE %UNPOINTER \ THEN ; IMMEDIATE : UnPointer> ( name -- ) \ deallocate a pointer name following ' %unpointer compilation> drop ' postpone literal postpone %unpointer ; : SizeOf!> ( bytes | name -- ) \ set size of the following pointer \ ' STATE @ \ IF POSTPONE LITERAL \ POSTPONE %SIZEOF! \ ELSE %SIZEOF! \ THEN ; IMMEDIATE ' %sizeof! compilation> drop ' postpone literal postpone %sizeof! ; : SizeOf@> ( -<name>- bytes ) \ get size of the following pointer \ ' STATE @ \ IF POSTPONE LITERAL \ POSTPONE %SIZEOF@ \ ELSE %SIZEOF@ \ THEN ; IMMEDIATE ' %sizeof@ compilation> drop ' postpone literal postpone %sizeof@ ; : named-new$ ( -<name>- ) \ a semi-static buffer of MAXSTRING length MAXSTRING Pointer ; in-application \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Dynamic String Support Words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ The dynamic string buffer is allocated when it is first used, and automatically \ released when the program terminates. 32768 constant max-dyn-string \ dynamic string space is this big (increased for tasks) max-dyn-string Pointer dyn-ptr \ the dynamic string buffer 0 value dyn-offset \ top of the dynamic string buffer : DynAlloc ( n1 -- a1 ) \ allocate space in dynamic buffer \ return a1 a buffer of n1 bytes dup max-dyn-string 16 / > \ limit one string to 1/16 of total abort" Can't allocate a dynamic string this large" (dynlock) dyn-offset over + max-dyn-string >= if 0 to dyn-offset then dyn-ptr dyn-offset + swap +to dyn-offset (dynunlock) ; : _new$ ( -- a1 ) \ allocate the next MAXSTRING buffer MAXSTRING DynAlloc ; : init-new$ ( -- ) ['] _new$ is new$ ; init-new$ initialization-chain chain-add init-new$ module \ *Z Index: extend.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/extend.f,v retrieving revision 1.5 retrieving revision 1.6 diff -C2 -d -r1.5 -r1.6 *** extend.f 24 Sep 2006 08:42:03 -0000 1.5 --- extend.f 4 Oct 2006 12:00:03 -0000 1.6 *************** *** 19,22 **** --- 19,23 ---- sys-FLOAD src\dis486.f \ load the disassembler + FLOAD src\pointer.f \ pointer support ( w/o forgetting and decompiling ) fload src\callback.f \ windows callback support fload src\exception.f \ utility words to support windows exception handling *************** *** 39,43 **** \ FLOAD src\paths.f \ multi path support words *** to be done *** \ sys-FLOAD src\nforget.f \ forget words *** to be done *** - \ FLOAD src\pointer.f \ pointer support *** depends on nforget \ sys-FLOAD src\dbgsrc1.f \ source level debugging support part one *** to be done *** --- 40,43 ---- Index: primutil.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/primutil.f,v retrieving revision 1.7 retrieving revision 1.8 diff -C2 -d -r1.7 -r1.8 *** primutil.f 30 Sep 2006 15:17:33 -0000 1.7 --- primutil.f 4 Oct 2006 12:00:03 -0000 1.8 *************** *** 147,150 **** --- 147,204 ---- reset-stack-chain do-chain ; is reset-stacks \ install in kernel word + \ ---------------- Operating System Checking -------------------------- + + 1 PROC GetVersionEx + + 1 constant win95 + 2 constant win98 + 3 constant winme + 4 constant winnt351 + 5 constant winnt4 + 6 constant win2k + 7 constant winxp + 8 constant win2003 + + \ To check for a version, say Win2K or greater, try WINVER WIN2K >= + + 0 value winver + + : winver-init ( -- n ) \ get windows version + 148 dup _localalloc dup>r ! \ set length of structure + r@ call GetVersionEx \ call os for version + 0= abort" call failed" + r@ 4 cells+ @ \ get osplatformid + case + 1 of \ 95, 98, and me + r@ 2 cells+ @ \ minorversion + case + 0 of win95 endof \ 95 + 10 of win98 endof \ 98 + 90 of winme endof \ me + endcase + endof + + 2 of \ nt, 2k, xp + r@ cell+ @ \ majorversion + case + 3 of winnt351 endof \ nt351 + 4 of winnt4 endof \ nt4 + 5 of + r@ 2 cells+ @ \ minor version + case + 0 of win2k endof \ win2k + 1 of winxp endof \ winxp + 2 of win2003 endof \ 2003 + endcase + endof + endcase + endof + endcase to winver + r>drop _localfree + ; + + initialization-chain chain-add winver-init + winver-init + \ ------------------------------------------------------------------------ \ ------------------------------------------------------------------------ |
