Menu
▾
▴
win32forth-cvs
|
From: George H. <geo...@us...> - 2007-04-30 07:49:32
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv32749/win32forth-stc/src Modified Files: Class.f primutil.f Added Files: COLORS.F Dc.f GENERIC.F Menu.f Utils.f Window.f Log Message: gah:Added the rest of the gdi functions and some other class files updated primutil.f with extra utilities needed for GUI and bugfixes/extensions to class.f --- NEW FILE: GENERIC.F --- \ $Id: GENERIC.F,v 1.1 2007/04/30 07:49:26 georgeahubert Exp $ \ *D doc\classes\ \ *! Generic \ *T Generic-Window -- Base class for all window objects. \ *P Generic-Window is the base class for all window objects. This class \ ** contains a single ivar, hWnd, that is the (MS Windows) handle for the \ ** window. This class encapsulates all the Win32 API calls that specify a \ ** window handle. There will be the following subclasses of Generic-Window: \ *W <ul> \ *W <li><a href="Window.htm">Window</a> Adds a device context and the ablility to display text and graphics output.</li> \ *W <li><a href="Dialog.htm">Dialog</a> Support for dialog boxes</li> \ *W <li><a href="Control.htm">Control</a> Adds support for the standard Win32 controls with subclassing.</li> \ *W </ul> \ *P Since Generic-Window is a generic class it should not be used to create \ ** any instances. \n \ ** The Global Rectangle objects wRect and WndRect ( originally \ ** defined in Window.f ) have been replaced by a Rectangle IVAR WinRect so that \ ** Windows in different threads don't interfere with each other's drawing \ ** operations. \n \ ** For backwards compatibility wRect is defined as an int which is set \ ** to the address of WinRect by the ClassInit: method ( and WndRect is defined as \ ** an alias of wRect in Window.f. Also ) however WinRect should be used in new \ ** code since it uses early binding. ClientRect in class EditControl ( in Controls.f ) \ ** is also defined as an alias of wRect for compatibility. \n \ ** We also provide wRect as an alias of TempRect for compatibility. \n \ ** Temporarily added new generic class Dialog&Control and moved some code into it and \ ** duplicated the same code in Class Window so that Ivar offsets in Class Window are \ ** the same for temporary compatibility. \ *S Glossary cr .( Loading Generic Window...) only forth also definitions decimal Needs Dc.f in-application \ Linked list, to hold all dictionary window objects. VARIABLE windows-link windows-link OFF \ Linked list, to hold all modeless dialog, Frame window and MDI child window objects \ that respond to dialog messages. VARIABLE dialog-link dialog-link OFF \ Normally wRect is called by methods and : definitions inside generic-window, however the \ original global object is used by Lib\RegistryWindowPos.f so we define it \ as an alias for backward compatibility. ' TempRect Alias wRect in-system :CLASS Generic-Window <Super Object \ *G Base class for all window objects. \ Macros for backward compatibility : wRect.addrof s" addrof: winrect" evaluate ; immediate : wRect.left s" left: winrect" evaluate ; immediate : wRect.right s" right: winrect" evaluate ; immediate : wRect.top s" top: winrect" evaluate ; immediate : wRect.bottom s" bottom: winrect" evaluate ; immediate synonym TempRect.addrof wRect.addrof synonym TempRect.left wRect.left synonym TempRect.right wRect.right synonym TempRect.top wRect.top synonym TempRect.bottom wRect.bottom in-application \ ----------------------------------------------------------------- \ *N Instance Variables \ ----------------------------------------------------------------- \ WARNING: DO NOT ADD ANY INSTANCE VARIABLES TO THIS CLASS BEFORE HWND \ HWND MUST BE THE FIRST IVAR. THIS IS ESSENTIAL TO THE \ WINDOW PROCEDURE OF CLASS WINDOW AND THE SUBCLASSING TECHNIQUE \ USED BY CLASS CONTROL. int hWnd \ *G handle to Win32 window object \ ----------------------------------------------------------------- \ ----------------------------------------------------------------- in-system : static-window? ( -- f1 ) \ is this a static window self adp in-space? self sdp in-space? or ; : link-window ( -- ) static-window? \ only link in static windows if windows-link link, \ link into list self , then ; : trim-windows ( nfa -- nfa ) \ for forgetting dup windows-link full-trim ; forget-chain chain-add trim-windows : trim-dialogs ( nfa -- nfa ) dup Dialog-link full-trim ; forget-chain chain-add trim-dialogs in-application : SendMessage:Self ( lParam wParam message -- result ) \ *G Send a windows message to our self. hWnd call SendMessage ; : SendMessage:SelfDrop ( lParam wParam message -- ) \ *G Send a windows message to our self and discard the result. SendMessage:Self drop ; \ ----------------------------------------------------------------- \ *N Methods \ ----------------------------------------------------------------- :M Classinit: ( -- ) \ *G Initialise the class. ClassInit: super 0 to hWnd turnkeyed? 0= \ only dynamic windows can be used in a \in-system-ok if link-window then \ turnkeyed application so skip linking ;M :M GetHandle: ( -- hWnd ) \ *G Get the window handle. hWnd ;M :M PutHandle: ( hWnd -- ) \ *G Set the window handle. Normally handled by the system. to hWnd ;M :M ZeroWindow: ( -- ) \ *G Clear the window handle. Normally handled by the system. At start-up all window \ ** objects are zeroed automatically. 0 to hWnd ;M :M DestroyWindow: ( -- ) \ *G Destroy the window. The handle is always zero after executing this method. In a \ ** mult-tasking application this method causes an error if executed by a task that \ ** didn't create the window. hWnd if hWnd Call DestroyWindow ?win-error 0 to hWnd then ;M :M Close: ( -- ) \ *G Close the window. DestroyWindow: self ;M :M Paint: ( -- ) \ *G Force window repaint. A WM_PAINT message is posted to the message queue. hWnd if 1 0 hWnd Call InvalidateRect ?win-error then ;M :M SetRedraw: ( f -- ) \ *G Set the redraw state of the window. \ *P \i f \d Specifies the redraw state. If this parameter is TRUE, the \ ** content can be redrawn after a change. If this parameter is FALSE, \ ** the content cannot be redrawn after a change. 0 swap WM_SETREDRAW hWnd call SendMessage drop ;M :M Show: ( state -- ) \ *G The ShowWindow function sets the specified window's show state. \n \ ** Possible values for state are: \ *L \ *| SW_FORCEMINIMIZE | Windows 2000: Minimizes a window, even if the thread that owns the window is hung. This flag should only be used when minimizing windows from a different thread. | \ *| SW_HIDE | Hides the window and activates another window. | \ *| SW_MAXIMIZE | Maximizes the specified window. | \ *| SW_MINIMIZE | Minimizes the specified window and activates the next top-level window in the Z order. | \ *| SW_RESTORE | Activates and displays the window. If the window is minimized or maximized, the system restores it to its original size and position. An application should specify this flag when restoring a minimized window. | \ *| SW_SHOW | Activates the window and displays it in its current size and position. | \ *| SW_SHOWDEFAULT | Sets the show state based on the SW_ value specified in the STARTUPINFO structure passed to the CreateProcess function by the program that started the application. | \ *| SW_SHOWMAXIMIZED | Activates the window and displays it as a maximized window. | \ *| SW_SHOWMINIMIZED | Activates the window and displays it as a minimized window. | \ *| SW_SHOWMINNOACTIVE | Displays the window as a minimized window. This value is similar to SW_SHOWMINIMIZED, except the window is not activated. | \ *| SW_SHOWNA | Displays the window in its current size and position. This value is similar to SW_SHOW, except the window is not activated. | \ *| SW_SHOWNOACTIVATE | Displays a window in its most recent size and position. This value is similar to SW_SHOWNORMAL, except the window is not actived. | \ *| SW_SHOWNORMAL | Activates and displays a window. If the window is minimized or maximized, the system restores it to its original size and position. An application should specify this flag when displaying the window for the first time. | \ *P If the window belongs to a different task or application the WM_SHOW is posted to the \ ** the message queue to prevent the current task hanging. If the window belongs to the \ ** current task the message is sent. hWnd if 0 hWnd call GetWindowThreadProcessId call GetCurrentThreadId = if hWnd Call ShowWindow else hWnd call ShowWindowAsync then then drop ;M :M GDIFlush: ( -- ) \ *G The GdiFlush function flushes the calling thread's current batch. Call GdiFlush ?win-error ;M :M Update: ( -- ) \ *G The UpdateWindow function updates the client area of the window by sending \ ** a WM_PAINT message to the window if the window's update region is not empty. The \ ** function sends a WM_PAINT message directly to the window procedure of the window, \ ** bypassing the application queue. If the update region is empty, no message is sent. hWnd if hWnd Call UpdateWindow ?win-error then ;M :M Scroll: { x y -- } \ *G The ScrollWindow function scrolls the contents of the specified window's client area. hWnd if 0 0 y x hWnd Call ScrollWindow drop then ;M :M Move: { x y w h -- } \ *G The MoveWindow function changes the position and dimensions of window. \ ** For a top-level window, the position and dimensions are relative to the upper-left corner \ ** of the screen. For a child window, they are relative to the upper-left corner of the parent \ ** window's client area. hWnd if 1 ( repaint flag ) h w y x hWnd Call MoveWindow ?win-error then ;M :M SetWindowPos: { x y -- } \ *G The SetWindowPos function changes the position of a child, pop-up, or top-level window. \n \ ** X Specifies the new position of the left side of the window, in client coordinates. \n \ ** Y Specifies the new position of the top of the window, in client coordinates. hWnd if [ SWP_NOSIZE SWP_SHOWWINDOW or SWP_NOZORDER or ] literal 0 0 \ no size specified y x 0 \ insert parameter not used hWnd Call SetWindowPos ?win-error \ April 27th, 1998 - 9:14 tjz removed, reported by Bruno Gauthier \ else 2drop then ;M (( :M GetWindowRect: ( -- left top right bottom ) hWnd if EraseRect: WinRect AddrOf: WinRect hWnd Call GetWindowRect ?win-error Left: WinRect Top: WinRect Right: WinRect Bottom: WinRect else 0 0 0 0 then ;M )) :M SetMenu: ( MenuHandle -- ) \ *G The SetMenu function assigns a new menu to the window. \ ** If MenuHandle is NULL, the window's current menu is removed. hWnd -if Call SetMenu ?win-error else 2drop then ;M :M SetText: { addr len \ text$ -- } \ *G The SetWindowText function changes the text of the window's title bar (if it has one). \ ** If the window is a control, the text of the control is changed. hWnd if MAXSTRING localAlloc: text$ addr len text$ place text$ +NULL text$ 1+ hWnd Call SetWindowText ?win-error then ;M maxstring newuser gettext$ :M GetText: ( -- addr len ) \ *G The GetWindowText function copies the text of the window's title bar (if it has one) \ ** into a buffer. If the window is a control, the text of the control is copied. gettext$ hWnd -if over MAXCOUNTED 3reverse Call GetWindowText then ;M : (SetTextAlign) ( flag hwnd -- ) dup>r Call GetDC >r ( flag ) case 1 of [ TA_RIGHT TA_UPDATECP or ] literal endof 2 of [ TA_CENTER TA_UPDATECP or ] literal endof [ TA_LEFT TA_UPDATECP or ] literal swap endcase r@ Call SetTextAlign r> r> Call ReleaseDC 2drop ; :M SetTextAlign: ( flag -- ) \ *G Set the text-alignment for the window. \n \ ** The current position is updated after each text output call. \ ** The current position is used as the reference point. \ ** Possible values for flag are: \ *L \ *| 0 | The reference point will be on the left edge of the bounding rectangle. | \ *| 1 | The reference point will be on the right edge of the bounding rectangle. | \ *| 2 | The reference point will be aligned horizontally with the center of the bounding rectangle. | hwnd (SetTextAlign) ;M :M GetDC: ( -- hdc ) \ *G The GetDC function retrieves a handle to a display device context (DC) \ ** for the client area of the window. \n \ ** You have to call ReleaseDC when the DC isn't needed any longer. hWnd Call GetDC ;M :M GetWindowDC: ( -- hdc ) \ *G The GetWindowDC function retrieves the device context (DC) for the entire \ ** window, including title bar, menus, and scroll bars. A window device context \ ** permits painting anywhere in a window, because the origin of the device context \ ** is the upper-left corner of the window instead of the client area. \n \ ** GetWindowDC assigns default attributes to the window device context each time it \ ** retrieves the device context. Previous attributes are lost. \n \ ** You have to call ReleaseDC when the DC isn't needed any longer. hWnd Call GetWindowDC ;M :M ReleaseDC: ( hdc -- ) \ *G The ReleaseDC function releases the device context (DC) of the window. \n \ ** Call only after GetDC or GetWindowDC. hWnd Call ReleaseDC ?win-error ;M :M BeginPaint: ( ps -- hdc ) \ *G The BeginPaint function prepares the window for painting and fills a \ ** PAINTSTRUCT (ps) structure with information about the painting. hWnd Call BeginPaint ;M :M EndPaint: ( ps -- ) \ *G The EndPaint function marks the end of painting in the window. This function is \ ** required for each call to the BeginPaint function, but only after painting is complete. hWnd Call EndPaint drop ;M :M GetClientRect: ( rect -- ) \ *G The GetClientRect function retrieves the coordinates of the window's client area. The \ ** client coordinates specify the upper-left and lower-right corners of the client area. \ ** Because client coordinates are relative to the upper-left corner of a window's client \ ** area, the coordinates of the upper-left corner are (0,0). hWnd Call GetClientRect ?win-error ;M :M GetWindowLong: ( index -- value ) \ *G The GetWindowLong function retrieves information about the window. The function \ ** also retrieves the 32-bit (long) value at the specified offset into the extra \ ** window memory. \n \ ** Index Specifies the zero-based offset to the value to be retrieved. Valid values are \ ** in the range zero through the number of bytes of extra window memory, minus four; for \ ** example, if you specified 12 or more bytes of extra memory, a value of 8 would be an \ ** index to the third 32-bit integer. To retrieve any other value, specify one of the \ ** following values. \ *L \ *| GWL_EXSTYLE | Retrieves the extended window styles. For more information, see CreateWindowEx. | \ *| GWL_STYLE | Retrieves the window styles. | \ *| GWL_WNDPROC | Retrieves the address of the window procedure, or a handle representing the address of the window procedure. You must use the CallWindowProc function to call the window procedure. | \ *| GWL_HINSTANCE | Retrieves a handle to the application instance. | \ *| GWL_HWNDPARENT | Retrieves a handle to the parent window, if any. | \ *| GWL_ID | Retrieves the identifier of the window. | \ *| GWL_USERDATA | Retrieves the 32-bit value associated with the window. Each window has a corresponding 32-bit value intended for use by the application that created the window. This value is initially zero. | hWnd Call GetWindowLong ;M :M SetWindowLong: ( value index -- oldval ) \ *G The SetWindowLong function changes an attribute of the window. The function also sets the \ ** 32-bit (long) value at the specified offset into the extra window memory. \ *L \ *| GWL_EXSTYLE | Sets a new extended window style. For more information, see CreateWindowEx. | \ *| GWL_STYLE | Sets a new window style. | \ *| GWL_WNDPROC | Sets a new address for the window procedure. Windows NT/2000: You cannot change this attribute if the window does not belong to the same process as the calling thread. | \ *| GWL_HINSTANCE | Sets a new application instance handle. | \ *| GWL_ID | Sets a new identifier of the window. | \ *| GWL_USERDATA | Sets the 32-bit value associated with the window. Each window has a corresponding 32-bit value intended for use by the application that created the window. This value is initially zero. | hWnd Call SetWindowLong ;M :M GetStyle: ( -- style ) \ *G Retrieves the window styles. GWL_STYLE GetWindowLong: self ;M :M SetStyle: ( style -- ) \ *G Sets a new window style. GWL_STYLE SetWindowLong: self drop ;M :M +Style: ( style -- ) \ *G Add a window style. GetStyle: self OR SetStyle: self ;M :M -Style: ( style -- ) \ *G Remove a window style. INVERT GetStyle: self AND SetStyle: self ;M :M SetFocus: ( -- ) \ *G The SetFocus function sets the keyboard focus to the window. The window must be \ ** attached to the calling thread's message queue. hWnd Call SetFocus drop ;M :M SetForegroundWindow: ( -- ) \ *G The SetForegroundWindow function puts the thread that created the specified window \ ** into the foreground and activates the window. Keyboard input is directed to the window, \ ** and various visual cues are changed for the user. The system assigns a slightly higher \ ** priority to the thread that created the foreground window than it does to other threads. \n \ ** The foreground window is the window at the top of the Z order. It is the window that the \ ** user is working with. In a preemptive multitasking environment, you should generally let the \ ** user control which window is the foreground window. \n \ ** Windows 98, Windows 2000: The system restricts which processes can set the foreground window. \ ** A process can set the foreground window only if one of the following conditions is true: \n \ ** - The process is the foreground process. \n \ ** - The process was started by the foreground process. \n \ ** - The process received the last input event. \n \ ** - There is no foreground process. \n \ ** - The foreground process is being debugged. \n \ ** - The foreground is not locked (see LockSetForegroundWindow). \n \ ** - The foreground lock time-out has expired (see SPI_GETFOREGROUNDLOCKTIMEOUT in SystemParametersInfo). \n \ ** - Windows 2000: No menus are active. \n \ ** With this change, an application cannot force a window to the foreground while the user is \ ** working with another window. Instead, SetForegroundWindow will activate the window (see SetActiveWindow) \ ** and call the FlashWindowEx function to notify the user. For more information, see Foreground and \ ** Background Windows. \n \ ** A process that can set the foreground window can enable another process to set the foreground window by \ ** calling the AllowSetForegroundWindow function. The process specified by dwProcessId loses the ability to \ ** set the foreground window the next time the user generates input, unless the input is directed at that \ ** process, or the next time a process calls AllowSetForegroundWindow, unless that process is specified. \n \ ** The foreground process can disable calls to SetForegroundWindow by calling the LockSetForegroundWindow function. hWnd (SetForegroundWindow) ;M :M SetActiveWindow: ( -- ) \ *G The SetActiveWindow function activates a window. The window must be attached to the calling thread's message queue. \n \ ** The SetActiveWindow function activates a window, but not if the application is in the background. The window will be \ ** brought into the foreground (top of Z order) if its application is in the foreground when the system activates the window. \n \ ** If the window identified by the hWnd parameter was created by the calling thread, the active window status of the calling \ ** thread is set to hWnd. Otherwise, the active window status of the calling thread is set to NULL. \n \ ** By using the AttachThreadInput function, a thread can attach its input processing to another thread. \ ** This allows a thread to call SetActiveWindow to activate a window attached to another thread's message queue. hWnd (SetActiveWindow) ;M :M MessageBox: ( szText szTitle style -- result ) \ *G The MessageBox function creates, displays, and operates a message box. The message box contains an \ ** application-defined message and title, plus any combination of predefined icons and push buttons. \ *L \ *| szText | Pointer to a null-terminated string that contains the message to be displayed. | \ *| szTitle | Pointer to a null-terminated string that contains the dialog box title. If this parameter is NULL, the default title Error is used. | \ *| Type | Specifies the contents and behavior of the dialog box. This parameter can be a combination of flags from the following groups of flags. | \ *P To indicate the buttons displayed in the message box, specify one of the following values. | \ *L \ *| MB_ABORTRETRYIGNORE | The message box contains three push buttons: Abort, Retry, and Ignore. | \ *| MB_CANCELTRYCONTINUE | Windows 2000: The message box contains three push buttons: Cancel, Try Again, Continue. Use this message box type instead of MB_ABORTRETRYIGNORE. | \ *| MB_HELP | Adds a Help button to the message box. When the user clicks the Help button or presses F1, the system sends a WM_HELP message to the owner. | \ *| MB_OK | The message box contains one push button: OK. This is the default. | \ *| MB_OKCANCEL | The message box contains two push buttons: OK and Cancel. | \ *| MB_RETRYCANCEL | The message box contains two push buttons: Retry and Cancel. | \ *| MB_YESNO | The message box contains two push buttons: Yes and No. | \ *| MB_YESNOCANCEL | The message box contains three push buttons: Yes, No, and Cancel. | \ *P To display an icon in the message box, specify one of the following values. \ *L \ *| MB_ICONEXCLAMATION, MB_ICONWARNING | An exclamation-point icon appears in the message box. | \ *| MB_ICONINFORMATION, MB_ICONASTERISK | An icon consisting of a lowercase letter i in a circle appears in the message box. | \ *| MB_ICONQUESTION | A question-mark icon appears in the message box. | \ *| MB_ICONSTOP, MB_ICONERROR, MB_ICONHAND | A stop-sign icon appears in the message box. | \ *P To indicate the default button, specify one of the following values. \ *L \ *| MB_DEFBUTTON1 | The first button is the default button. MB_DEFBUTTON1 is the default unless MB_DEFBUTTON2, MB_DEFBUTTON3, or MB_DEFBUTTON4 is specified. \ *| MB_DEFBUTTON2 | The second button is the default button. | \ *| MB_DEFBUTTON3 | The third button is the default button. | \ *| MB_DEFBUTTON4 | The fourth button is the default button. | \ *P To specify other options, use one or more of the following values. \ *L \ *| MB_RIGHT | The text is right-justified. | \ *| MB_SETFOREGROUND | The message box becomes the foreground window. Internally, the system calls the SetForegroundWindow function for the message box. | \ *| MB_TOPMOST | The message box is created with the WS_EX_TOPMOST window style. | \ *P If the function succeeds, the return value is one of the following menu-item values. \ *L \ *| IDABORT | Abort button was selected. | \ *| IDCANCEL | Cancel button was selected. | \ *| IDCONTINUE | Continue button was selected. | \ *| IDIGNORE | Ignore button was selected. | \ *| IDNO No | button was selected. | \ *| IDOK OK | button was selected. | \ *| IDRETRY | Retry button was selected. | \ *| IDTRYAGAIN | Try Again button was selected. | \ *| IDYES | Yes button was selected. | 3reverse hWnd Call MessageBox ;M :M InvalidateRect: ( bgflag rectangle -- ) \ *G The InvalidateRect function adds a rectangle to the window's update region. \ ** The update region represents the portion of the window's client area that must be redrawn. \ *L \ *| lpRect | Pointer to a RECT structure that contains the client coordinates of the rectangle to be added to the update region. If this parameter is NULL, the entire client area is added to the update region. | \ *| bErase | Specifies whether the background within the update region is to be erased when the update region is processed. If this parameter is TRUE, the background is erased when the BeginPaint function is called. | hWnd call InvalidateRect ?win-error ;M :M GetDlgItem: ( id -- handle ) \ *G The GetDlgItem function retrieves a handle of the control (id) in the window. hWnd Call GetDlgItem ;M :M GetDlgItemText: ( addr len id -- len ) \ *G The GetDlgItemText function retrieves the title or text associated with a control in the window. >r swap r> hWnd Call GetDlgItemText ;M :M SetDlgItemText: ( addr len id -- ) \ *G The SetDlgItemText function sets the title or text of a control in then window. >r asciiz r> hWnd Call SetDlgItemText drop ;M :M SetDlgItemFocus: ( id -- ) \ *G Set the focus to the control (id) in the window. GetDlgItem: self Call SetFocus drop ;M :M SelectDlgItemAll: ( id -- ) \ *G Selects all characters in the edit control (id). You can use this forn an edit control \ ** or a rich edit control. >r -1 0 EM_SETSEL r> hWnd Call SendDlgItemMessage drop ;M :M IsDlgButtonChecked: ( id -- f1 ) \ *G The IsDlgButtonChecked function determines whether a button control has a check mark next to \ ** it or whether a three-state button control is grayed, checked, or neither. hWnd Call IsDlgButtonChecked ;M :M CheckDlgButton: ( uCheck id -- ) \ *G The CheckDlgButton function changes the check state of a button control. \ ** Possible values for uCheck are: \ *L \ *| BST_CHECKED | Sets the button state to checked. | \ *| BST_INDETERMINATE | Sets the button state to grayed, indicating an indeterminate state. Use this value only if the button has the BS_3STATE or BS_AUTO3STATE style. | \ *| BST_UNCHECKED | Sets the button state to cleared | hWnd Call CheckDlgButton drop ;M :M SetDlgItemAlign: ( flag id -- ) \ *G Set the text-alignment for a control (id) in the window. \n \ ** The current position is updated after each text output call. \ ** The current position is used as the reference point. \ ** Possible values for flag are: \ *L \ *| 0 | The reference point will be on the left edge of the bounding rectangle. | \ *| 1 | The reference point will be on the right edge of the bounding rectangle. | \ *| 2 | The reference point will be aligned horizontally with the center of the bounding rectangle. | GetDlgItem: self (SetTextAlign) ;M :M SetAlign: ( flag id -- ) \ DEPRECATED \ *G Obsolescent Method use SetDlgItemAlign: instead. SetDlgItemAlign: self ;M DEPRECATED :M EnableDlgItem: ( flag id -- ) \ *G Enable or disable a control (id) in the window. \ ** Possible values for flag are: \ *L \ *| 0 | disable | \ *| 1 | enable | GetDlgItem: self Call EnableWindow drop ;M :M ShowDlgItem: ( flag id -- ) \ *G Hide or show a control (id) in the window. \ ** Possible values for flag are: \ *L \ *| 0 | hide | \ *| 1 | show | swap if SW_SHOWNORMAL else SW_HIDE then swap GetDlgItem: self Call ShowWindow drop ;M :M CheckRadioButton: ( check_id first_id last_id -- ) \ *G The CheckRadioButton function adds a check mark to (checks) a specified radio button \ ** in a group and removes a check mark from (clears) all other radio buttons in the group. \ *L \ *| check_id | Specifies the identifier of the radio button to select. | \ *| first_id | Specifies the identifier of the first radio button in the group. | \ *| last_id | Specifies the identifier of the last radio button in the group. | swap hWnd Call CheckRadioButton drop ;M :M SendDlgItemMessage: ( lParam wParam message id -- long ) \ *G Send a message to the control (id) in the window. hWnd Call SendDlgItemMessage ;M :M SetDlgItemFont: ( FontObject id -- ) \ *G Specify the font that the control (id) is to use when drawing text. \n \ ** FontObject must be the HANDLE of a font. If this parameter is NULL, the control uses the \ ** default system font to draw text. 1 -rot WM_SETFONT swap SendDlgItemMessage: self ;M (( \ The following definitions are for handling Dialog messages and have been moved \ here rather than have multiple copies of the code in different descendants : +DialogList ( -- ) \ link into dialog list (dialoglock) Dialog-link link, self , Dialog-link @ (dialogunlock) to mydialoglink ; : -DialogList ( -- ) \ Unlink from dialog list (dialoglock) mydialoglink Dialog-link un-link drop (dialogunlock) ; )) : DoDialogMsg { pMsg flag -- pMsg f | pMsg FALSE } (dialoglock) Dialog-link \ all dialog handles begin @ dup 0<> \ while not end of chain flag and \ and haven't found a handler while dup>r cell+ @ Gethandle: generic-window -if pMsg swap Call IsDialogMessage then 0= to flag r> repeat (dialogunlock) drop pMsg flag ; msg-chain chain-add DoDialogMsg ;CLASS \ *G End of generic-window class : zero-windows ( -- ) \ Zero all window handles. windows-link begin @ ?dup while dup cell+ @ ZeroWindow: [ ] repeat ; initialization-chain chain-add zero-windows in-system \ *W <a name="DIALOG&CONTROL"></a> \ *S Generic class for Dialog- and Control-Window objects. |CLASS DIALOG&CONTROL <SUPER Generic-Window \ *G Base class for all dialog and control objects. \ *P Since DIALOG&CONTROL is a generic class it should not be used to create \ ** any instances. in-application int mydialoglink \ The following is for backward compatibility. Use WinRect for new code since it will \ be early bound whereas wRect will be latebound. int wRect Rectangle WinRect synonym tempRect wRect :M Classinit: ( -- ) \ *G Initialise the class. ClassInit: super 0 to mydialoglink \ added Sonntag, Juni 04 2006 dbu addr: WinRect to wRect ;M :M GetWindowRect: ( -- left top right bottom ) \ *G The GetWindowRect method retrieves the dimensions of the bounding rectangle of the window. \ ** The dimensions are given in screen coordinates that are relative to the upper-left corner \ ** of the screen. hWnd if EraseRect: WinRect AddrOf: WinRect hWnd Call GetWindowRect ?win-error Left: WinRect Top: WinRect Right: WinRect Bottom: WinRect else 0 0 0 0 then ;M \ Temporarily moved here to overcome problem with offset of ints in Window.f : +DialogList ( -- ) \ link into dialog list (dialoglock) Dialog-link link, self , Dialog-link @ (dialogunlock) to mydialoglink ; : -DialogList ( -- ) \ Unlink from dialog list (dialoglock) mydialoglink Dialog-link un-link drop (dialogunlock) ; ;CLASS \ *G End of DIALOG&CONTROL class \ *Z --- NEW FILE: Utils.f --- \ $Id: Utils.f,v 1.1 2007/04/30 07:49:26 georgeahubert Exp $ \ UTILS.F A file to hold some utilities by Tom Zimmer \ -rbs globalized path init \ Changes February 14th, 2002 - 1:37 - rls \ utils.f beta 2.0A 2002/08/31 arm windows ANS file words \ utils.f beta 2.9G 2002/09/24 arm release for testing \ utils.f beta 3.3D 2002/10/08 arm Consolidated cr .( Loading Utility Words...) only forth also definitions needs GdiTools.f needs Class.f in-application : screen-size ( -- width height ) \ get windows screen size SM_CXSCREEN call GetSystemMetrics \ screen width SM_CYSCREEN call GetSystemMetrics ; \ screen height \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 5 Display the deferred words in the system, and their *current function \ along with the default function. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IN-SYSTEM \ : .deferred ( -- ) \ defer-list @ \ begin ?dup \ while cr ." Deferred: " \ dup cell - dup body> .NAME \ 23 col ." does: " @ .NAME \ 45 col ." defaults to: " dup cell+ @ .NAME \ @ \ start/stop \ repeat ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 5a Display the current file \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ : .cur-file ( -- ) \ ." The current file is: " cur-file count type ; \ \ synonym .file .cur-file \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : .platform ( -- ) cr ." Platform: Windows " winver case WIN95 of ." 95" endof WIN98 of ." 98" endof WINME of ." ME" endof WINNT351 of ." NT3.51" endof WINNT4 of ." NT4" endof WIN2K of ." 2000" endof WINXP of ." XP" endof WIN2003 of ." 2003" endof endcase ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 7 Display the files loaded into the system \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ also hidden \ \ : .loaded ( -- ) \ also files \ screendelay 0 to screendelay \ false to with-tabs? \ _words \ previous to screendelay ; \ previous \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ display a Message Box \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IN-APPLICATION : MessageBox ( szText szTitle style hOwnerWindow -- result ) dup NULL = if drop call GetActiveWindow then \ better use a valid handle >r 3reverse r> Call MessageBox ; : ?MessageBox ( flag adr len -- ) asciiz swap if z" Notice!" [ MB_OK MB_ICONINFORMATION or MB_TASKMODAL or ] literal NULL MessageBox then drop ; \ : ?ErrorBox ( flag adr len -- ) asciiz swap if z" Application Error" [ MB_OKCANCEL MB_ICONWARNING or MB_TASKMODAL or ] literal NULL MessageBox IDCANCEL = if bye then abort else drop then ; \ : ?TerminateBox ( flag adr len -- ) asciiz swap if z" Error Notice!" [ MB_OK MB_ICONSTOP or MB_TASKMODAL or ] literal NULL MessageBox drop bye else drop then ; \ : ErrorBox ( adr len -- ) asciiz z" Application Error" [ MB_TASKMODAL MB_ICONERROR or ] literal NULL MessageBox drop ; \ : .ErrorBox ( n - ) \ displays n in a MessageBox 0 (d.) ErrorBox ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ primitive utilities to support VIEW, BROWSE, EDIT and LOCATE \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ variable cur-line cur-line off INTERNAL \ internal definitions start here IN-SYSTEM (( : editor-wait { \ ?deadlook -- } \ wait until the editor is ready to accept messages 0 to ?deadlook \ return's after 10 seconds even when the editor is not ready begin 100 ms WINPAUSE ?deadlook 1+ dup to ?deadlook 100 = editor-present? or until ; : editor-run ( addr -- ) $exec 0= if editor-wait \ wait for the editor to be ready 0 ED_ALIVE editor-message \ tell the Editor that we are ready to compile then ; : do-edit ( -- ) editor-present? \ TRUE if editor is loaded if cur-file count "path-file drop ed-filename place cur-line @ ed-line ! 0 ED_OPEN_EDIT editor-message else editor$ editor-run \ startup the editor then ; : do-browse ( -- ) editor-present? \ TRUE if editor is loaded if cur-file count "path-file drop ed-filename place cur-line @ ed-line ! ed-column off 0 ED_OPEN_BROWSE editor-message else browse$ editor-run \ startup the editor then ; )) [defined] watched-cfa [if] : do-watch { \ pocket$ -- } MAXSTRING LocalAlloc: pocket$ \ a place to preserve pocket pocket pocket$ MAXSTRING move \ get current pocket contents editor-present? \ TRUE if editor is loaded if cur-file count "path-file if 2drop cur-file count then ed-filename place watched-cfa >name nfa-count ed-name place cur-line @ ed-line ! ed-column off 0 ED_WATCH editor-message else ed-ptr if watched-cfa >name nfa-count ed-name place then browse$ editor-run \ startup the editor then pocket$ pocket MAXSTRING move ; \ restore contents of pocket [else] : do-watch ; [then] IN-APPLICATION (( \ changed to work with blanks in filename \ September 9th, 2003 - 15:05 dbu : [$edit] { line_number file_name edit_cfa -- } file_name -1 <> if \ don't know for what this is good, but it keep us working with \ blanks in filenames. September 9th, 2003 - 15:05 dbu \ file_name count bl skip 2dup bl scan 2dup 2>r nip - \ "CLIP" cur-file place \ 2r> bl skip dup \ if number? 2drop 1 max to line_number \ else 2drop \ then file_name count bl skip "CLIP" cur-file place line_number &linenum ! \ set the line# variables line_number cur-line ! edit_cfa execute \ execute the editor then ; EXTERNAL \ external definitions start here : $edit ( line filename | dummy -1 -- ) ['] do-edit [$edit] ; : $browse ( line filename | dummy -1 -- ) ['] do-browse [$edit] ; INTERNAL )) in-system [defined] $watch [if] : _$watch ( line filename -- ) ['] do-watch [$edit] ; ' _$watch is $watch \ link watch into the debugger [then] : locate-height ( -- n1 ) getcolrow nip 8 - 20 min ; : locate-header ( -- n1 ) locate-height 4 / ; -1 value orig-loc (( : $locate ( line# filename | dummy -1 -- ) { line# file$ \ loc$ locHdl lcnt -- } file$ ( 0< ) -1 = ?EXIT \ September 9th, 2003 - 15:18 dbu max-path LocalAlloc: loc$ file$ $open abort" Couldn't open source file!" to locHdl 0 to lcnt base @ >r decimal cls ." From file: " cur-file count type ." At line: " line# . line# cur-line ! cr horizontal-line line# locate-header - 0 max 0 ?do loc$ MAXCOUNTED locHdl read-line abort" Read Error" nip 0= ?leave 1 +to lcnt loop locate-height 0 do loc$ dup MAXCOUNTED locHdl read-line abort" Read Error" if cols 1- min 1 +to lcnt lcnt orig-loc = if horizontal-line type cr horizontal-line else type cr then getxy nip getcolrow nip 4 - > ?leave else 2drop leave then loop horizontal-line locHdl close-file drop r> base ! ; )) in-application EXTERNAL \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 9 Handle error returned by window functions \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ defer win-abort ' abort is win-abort : ?win-error ( f1 -- ) \ f1=0=failed \ ?win-error can only be used right after a CALL. It looks at the CALL word, \ finds the PROC and extracts the name of the function. It's a pretty nasty \ bit of code! The bit that does it is: \ \ r@ 2 cells - @ .proc-name \ \ Fetches the current IP, then goes 2 cells back (the pointer is always a \ cell ahead at the next word, so 1 cell back is the ?win-error word, 2 \ cells is the CALL). This is the pointer to the CALL CFA in the PROC; then \ it fetches the PROC address and displays the name. Horrible. 0= ?win-error-enabled and if \ build string for error message debugging WinErrMsg @ WinErrMsg OFF GetLastWinErr SWAP WinErrMsg ! DUP NO_ERROR <> if false to ?win-error-enabled \+ debug-io debug-io cr ." On Function: " \ r@ 2 cells - @ \ \+ .proc-name .proc-name \ Horrible... ( \- .proc-name h. ) ." Unspecified " ." Windows Returned Error: " . temp$ count type tabbing-off forth-io win-abort \+ restore-io restore-io else drop then then ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : copyfile { \ from$ to$ -<from to>- } \ copy a file to a directory max-path localAlloc: from$ max-path localAlloc: to$ /parse-s$ count from$ place /parse-s$ count to$ place to$ ?+\ from$ count "to-pathend" to$ +place from$ +NULL to$ +NULL cr ." Copying: " from$ count type cr ." To: " to$ count type false to$ 1+ from$ 1+ Call CopyFile 0= abort" The COPY Failed!" ; in-system \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 11 More primitive utilities to support view, browse and edit \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ (( : $.viewinfo ( cfa -- line filename ) get-viewfile 0= abort" Undefined word!" ." loaded from: " over 0< if 2drop consfile count type 0 -1 else base @ >r decimal dup ?uppercase count type 15 ?cr ." at line: " swap dup . swap r> base ! dup count cur-file place then ; : .viewinfo ( -<name>- line filename ) bl word anyfind if $.viewinfo else c@ abort" Undefined word!" cur-line @ cur-file then over to orig-loc ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 12 Highlevel words used to view, browse and edit words and file \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : where ( -<name>- ) \ tell me WHERE the source for a word is .viewinfo drop cur-line ! ; synonym .v where : locate ( -<name>- ) \ show some source lines of word .viewinfo $locate ; synonym l locate synonym ll locate : n ( -- ) \ show the next bunch of lines cur-line @ locate-height 4 - + cur-file $locate ; \ removed B because it's a valid HEX number \ September 23rd, 2003 - 10:44 dbu \ : b ( -- ) \ show the previous bunch of lines \ cur-line @ locate-height 4 - - 0 max cur-file $locate ; : linelist ( n1 -- ) cur-file $locate ; : view ( -<name>- ) \ VIEW the source for a word .viewinfo $browse ; synonym v view \ V is an synonym for VIEW synonym Vv view \ Vv is an synonym for VIEW jap : ed ( -<name>- ) \ EDIT the source for a word .viewinfo $edit ; \ removed E because it's a valid HEX number \ September 23rd, 2003 - 10:44 dbu \ synonym e ed \ E is a synonym for EDIT : edit ( -<filename>- ) \ EDIT a particular file 0 word c@ if cur-line off 0 pocket else cur-line @ cur-file then $edit ; synonym z edit \ Z is a synonym for EDIT : browse ( -<filename>- ) \ BROWSE a particular file 0 word c@ if cur-line off 0 pocket else cur-line @ cur-file then $browse ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 13 Compiler utilities \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 14 Utility to allow loading a file starting at a specified line number \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ VARIABLE START-LINE \ Allows you to start including a file at a line number \ other than 1. Can't think of a serious use for it. \ Not ANS. Dangerious, We are advised - don't use it. : >LINE ( n1 -- ) \ move to line n1, 1 based 1- 0 MAX ?DUP IF 0 DO REFILL DROP LOOP THEN ; : #fload ( n1 -<name>- ) \ load file "name" from line n1, 1 based start-line ! \ set start line /parse-s$ $fload ; \ do the load : lineload ( n1 -- ) \ load the current file from line n1 start-line ! cur-file $fload ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 15 Linkage to automatically invoke the editor on a compile error \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : _edit-error ( -- ) loadline @ loadfile $edit ; : autoediton ( -- ) \ link into deferred auto edit on error word ['] _edit-error is edit-error ; autoediton : autoeditoff ( -- ) \ disable automatic edit on error ['] noop is edit-error ; in-application \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 16 A simple error number extension to error handling \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ : ?error ( f1 n1 -- ) \ abort with error code n1 if f1=true \ now as ?THROW in kernel; ?error is unused \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 17 ANSI Save and Restore Input Functions \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ In kernel \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ Compile time stack depth checking (Part 2 for Part 1 see Primeutil.f) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IN-SYSTEM \ add stack message increased THROW_MSGS LINK, -4103 ( WARN_STACK ) , ," stack depth increased" : _stack-check ( -- ) loading? 0= \ if we are not loading state @ or \ or we are in compile state, \ then don't check stack depth change olddepth 0< or ?exit \ or if olddepth is below zero \ or if assembling context @ [ ' assembler vcfa>voc ] literal = ?exit depth olddepth > \ if stack depth has increased if \ then warn of extra item on stack -4103 ( WARN_STACK ) WARNMSG cr ." Stack: " .s cr then depth to olddepth ; \ If interpretation of files is done in a TURNKEYed application this must be \ reset to NOOP \in-system-ok ' _stack-check is stack-check )) \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 19 Time control words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ IN-APPLICATION 16 constant TIME-LEN next-user dup @ aligned swap ! time-len newuser TIME-BUF \ +0 year \ +2 month \ +4 day of week \ +6 day of month \ +8 hour \ +10 minute \ +12 second \ +14 milliseconds 32 newuser date$ 32 newuser time$ : get-local-time ( -- ) \ get the local computer date and time time-buf call GetLocalTime drop ; create compile-version time-len allot \ a place to save the compile time (global) get-local-time \ save as part of compiled image time-buf compile-version time-len move \ move time into buffer : time&date ( -- sec min hour day month year ) get-local-time time-buf 12 + w@ \ seconds time-buf 10 + w@ \ minutes time-buf 8 + w@ \ hours time-buf 6 + w@ \ day of month time-buf 2 + w@ \ month of year time-buf w@ ; \ year : .#" ( n1 n2 -- a1 n3 ) >r 0 <# r> 0 ?do # loop #> ; : >date" ( time_structure -- ) >r 31 date$ null \ z" ddddd',' MMMM dd yyyy" r> null LOCALE_USER_DEFAULT call GetDateFormat date$ swap 1- ; : .date ( -- ) \ *G Print date in short format, based on regional setting. get-local-time time-buf >date" type ; : >month,day,year" ( time_structure -- ) >r 31 date$ z" ddddd',' MMMM dd yyyy" r> null LOCALE_USER_DEFAULT call GetDateFormat date$ swap 1- ; : .month,day,year ( -- ) \ *G Print day and date in full. get-local-time time-buf >month,day,year" type ; : >time" ( time_structure -- ) >r 31 time$ null r> null LOCALE_USER_DEFAULT call GetTimeFormat time$ swap 1- ; : .time ( -- ) \ *G Print time in 24hr format. get-local-time time-buf >time" type ; : >am/pm" ( time_structure -- ) >r 31 time$ z" h':'mmtt" r> null LOCALE_USER_DEFAULT call GetTimeFormat time$ swap 1- ; : .am/pm ( -- ) \ *G Print time in 12hr format. get-local-time time-buf >am/pm" type ; : .cversion ( -- ) cr ." Compiled: " compile-version dup >month,day,year" type ." , " >am/pm" type ; : ms@ ( -- ms ) get-local-time time-buf dup 8 + w@ 60 * \ hours over 10 + w@ + 60 * \ minutes over 12 + w@ + 1000 * \ seconds swap 14 + w@ + ; \ milli-seconds 0 value start-time : time-reset ( -- ) ms@ to start-time ; ' time-reset alias timer-reset : .elapsed ( -- ) ." Elapsed time: " ms@ start-time - 1000 /mod 60 /mod 60 /mod 2 .#" type ." :" 2 .#" type ." :" 2 .#" type ." ." 3 .#" type ; : elapse ( -<commandline>- ) time-reset interpret cr .elapsed ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ module \s internal fload builtby.f external : .Builtby ( -- ) \ print the name of the person who built this copy of w32f builtby count ?dup if cr ." Built by: " type else drop then ; \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 20 Random number generator for Win32Forth \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ 3141592 value SEED1 6535897 value SEED2 9323846 value SEED3 : RANDOM ( n1 -- n2 ) \ W32F Utils \ *G Get a pseudo random number between 0 and n1 as n2. n2 has the same sign as n1. dup 0= if 1+ then SEED1 177 /MOD 2* SWAP 171 * SWAP - DUP to SEED1 SEED2 176 /MOD 35 * SWAP 172 * SWAP - DUP to SEED2 SEED3 178 /MOD 63 * SWAP 170 * SWAP - DUP to SEED3 + + SWAP MOD ; : RANDOM-INIT ( -- ) \ W32F Utils \ *G Initialize the random number generator from the system clock. This is performed at \ ** program initialisation. get-local-time time-buf 3 cells + @ to SEED1 time-buf 2 cells + @ to SEED2 time-buf 1 cells + @ to SEED3 ; INITIALIZATION-CHAIN CHAIN-ADD RANDOM-INIT \ randomize at boot time \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 21 Delay Time Words \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ old Win32s support removed \ September 17th, 2003 - 10:38 dbu : _MS ( u -- ) \ delay u milli-seconds or forever if u=-1. Call Sleep drop ; ' _MS IS MS : SECONDS ( n1 -- ) 0max 0 ?do 10 0 do 100 ms key? if key drop unloop unloop EXIT then loop loop ; IN-SYSTEM : pause-seconds ( n1 -- ) cr ." Delaying: " dup . ." seconds, press a key to HOLD " 30 min 1 max 10 * 0 ?do 100 ms key? if cr ." HOLDING, Space=continue delaying, Enter=cancel pause, ESC=abort" key dup k_ESC = if cr ." Aborted" abort then K_CR = ?leave key dup k_ESC = if cr ." Aborted" abort then K_CR = ?leave cr ." Press a key to pause " then loop ; synonym ?keypause start/stop \ from F-PC, pauses if a key is pressed \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 22 File type \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : "ftype { \ locHdl typ$ -<name>- } \ type file "name" to the console max-path LocalAlloc: typ$ "open abort" Couldn't open file!" to locHdl cur-line off cr ." Typing file: " open-path$ count type cr begin typ$ dup MAXCOUNTED locHdl read-line abort" Read Error" nuf? 0= and while type cr 10 ms repeat locHdl close-file 3drop ; : ftype ( -<filename>- ) \ W32F System Utils \ *G Type the contents of file -<filename>- at the console. If no extension is supplied \ ** then the default extension (.f) is applied. Relative paths are relative to the Forth \ ** search path. /parse-s$ count "ftype ; synonym flist ftype \ *G Alternate name. \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ 23 An addition to CASE OF ENDOF ENDCASE, to allow testing ranges \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ : _of-range ( n1 n2 n3 -- n1 f1 ) 2 pick -rot between ; : of-range ( n1 n2 n3 -- n1 ) \ extension to CASE for a range ?comp POSTPONE _of-range POSTPONE ?branch >mark 4 ; immediate in-application \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ EXTERNAL : make-cursor ( cursor_constant appinst -- ) create , , does> dup cell+ @ swap @ if z" w32fConsole.dll" Call GetModuleHandle else NULL then Call LoadCursor Call SetCursor drop ; \ Standard Win32 API Cursors IDC_APPSTARTING FALSE make-cursor appstarting-cursor IDC_ARROW FALSE make-cursor arrow-cursor IDC_CROSS FALSE make-cursor cross-cursor IDC_HELP FALSE make-cursor help-cursor IDC_IBEAM FALSE make-cursor ibeam-cursor IDC_NO FALSE make... [truncated message content] |
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X