Menu
▾
▴
[Win32forth-cvs] win32forth-stc/src 486asm.f, NONE, 1.1 asmmac.f, NONE, 1.1 asmwin32.f, NONE, 1.1 callback.f, NONE, 1.1 console.f, NONE, 1.1 dis486.f, NONE, 1.1 dotwords.f, NONE, 1.1 exception.f, NONE, 1.1 extend.f, NONE, 1.1 float.f, NONE, 1.1 forget.f, NONE, 1.1 imagehds.f, NONE, 1.1 imageman.f, NONE, 1.1 interpif.f, NONE, 1.1 lineedit.f, NONE, 1.1 module.f, NONE, 1.1 numconv.f, NONE, 1.1 primutil.f, NONE, 1.1 task.f, NONE, 1.1
|
From: Dirk B. <db...@us...> - 2006-09-21 16:26:36
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv2950/src Added Files: 486asm.f asmmac.f asmwin32.f callback.f console.f dis486.f dotwords.f exception.f extend.f float.f forget.f imagehds.f imageman.f interpif.f lineedit.f module.f numconv.f primutil.f task.f Log Message: win32forth-stc base comit --- NEW FILE: exception.f --- \ $Id: exception.f,v 1.1 2006/09/21 16:26:33 dbu_de Exp $ 0 [IF] --------------------------- Change Block ------------------------------- arm 15/08/2005 22:56:45 First version 0.1 STC based kernel ------------------------- End Change Block ----------------------------- Experimental: a fully optimising, STC based, ANS Forth compliant kernel Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com) This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or <at your option> any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ------------------------------------------------------------------------ [THEN] cr .( Loading exception handler...) sourcefilename type 0 [IF] Exception Handling ------------------ Exeption handling now uses a process wide exception handler to trap all OS generated errors in Win32Forth. The sequence of events is as follows: 1. Exception handler set by call to SET-EXCEPT SET-EXCEPT points to a callbnack IN-EXCEPT that does most of the work. 2. Code executes, hits some error IN-EXCEPT gets called with 1 parameter. This points to two words: DWORD Exception Record DWORD Context Record The first is a "machine independent" record of the error, the second a copy of the machine state on entry. 3. If the execption is GUARD_PAGE, then we just retry after incrementing a counter 4. If the exception is ACCESS_VIOLATION, and this is a write error (not read!) then an attempt is made to VirtualAllocate the page that is faulting. 5. If the attempt is succesful, retry at the point of failure. Otherwise, call HANDLE-EXCEPT 6. HANDLE-EXCEPT saves both the exception and context records in a dynamic buffer, and points to them. 7. Calls .EXCEPTION to print out the exception information 8. Calls RECOVER-EXCEPT to attempt a recovery. RECOVER-EXCEPT emulates an "9998 THROW". 9. Returns to OS to undertake the recovery. Trapping Memory Write Errors ---------------------------- This code supports RESERVEing memory using VirtualAlloc, without COMMITting it first. First, reserve a range of a process's virtual address space. Reserving address space does not allocate any physical storage, but it prevents other allocation operations from using the specified range. Reserving pages prevents needless consumption of physical storage, while allowing a process to reserve a range of its address space into which a dynamic data structure can grow. Reserved but uncommitted memory will cause ACCESS VIOLATIONS if it is addressed. Once the memory is then committed, it is backed by swap pages and is mapped into the virtual address space. Now it can be used (written and read). The support provided here allows storage be reserved only. If a block of storage is reserved, and it is then written to, the exception handler traps the error and automatically commits the memory and retries the failing instruction. For instance: PAGE_NOACCESS MEM_RESERVE 0x400000 0 CALL VirtualAlloc CONSTANT LARGEAREA This reserves but does not consume memory resources. 10 LARGEAREA 0x4000 + ! This causes an exception, the memory is COMMITed as PAGE_EXECUTE_READWRITE. Only the page (4K) at LARGEAREA 0x4000 + requires swap and memory resources. Catching Errors --------------- The use of THROW makes it easy to catch system errors in code. For instance: : x -4 @ ; \ will cause an access exception : y ['] x catch if ." Error" else ." OK" then ; If you don't do a CATCH, then the last CATCH executed will be run. Here's some sample output: 0 @ \ fetch from absolute zero EXCEPTION 0xC0000005 ACCESS_VIOLATION Version: 6.09.02 Registers: Eax: 0040147C Ebx: TOS 00000000 top of stack Ecx: 0013748A Edx: USER 00127FB0 user area Edi: 00000000 Esi: IP 0040F4C8 Forth ip Esp: SP@ 00126F80 stack ptr Ebp: RP@ 0012FF90 rstack ptr Eip: PC 00401480 machine ip Access addr: 00000000 READ violation Backtracking: CONSOLE-STATUSBAR-INTERPRET+0 QUERY-INTERPRET+2 CATCH+14 [UNKNOWN]+-1048578 Data stack: 0 0 0 0 Primitive @ loaded from: SRC\FKERNEL.F at line: 488 Invoking word CONSOLE-STATUSBAR-INTERPRET loaded from: ...SRC\CONSOLE\CONSOLESTATBAR.F at line: 92 fails at word _INTERPRET loaded from: SRC\FKERNEL.F at line: 4238 For TURNKEYed applications, only the registers are shown. User Words ---------- .EXCEPTION Show the results of the last exception executed .EXCEPTION-CODE Show just the exception code CLEAR-EXCEPTION Clear the exception UNSET-EXCEPTION Suspend exception processing, will return to OS on error SHOW-EXCEPTION ON | OFF Turn the output from an exception on or off (on is default) RECOVER-EXCEPTION ON | OFF Recover from exception. ON is default, OFF will return to OS EXCEPT-IO Defered word to redirect error io. [THEN] only forth also definitions IN-APPLICATION 1 CONSTANT EXCEPTION_EXECUTE_HANDLER \ no longer in wincon.dll, now macros in 0 CONSTANT EXCEPTION_CONTINUE_SEARCH \ windows -1 CONSTANT EXCEPTION_CONTINUE_EXECUTION : \IN-SYSTEM-OK ; immediate \ temporary 9998 CONSTANT THROW_WINEXCEPT \ " Windows exception trapped" THROW_MSGS LINK, THROW_WINEXCEPT , ," Windows exception trapped" defer except-io ' forth-io is except-io \ where print exception goes INTERNAL 0 nostack1 \ exception record cell field+ exc-code cell field+ exc-flags cell field+ exc-record cell field+ exc-address cell field+ exc-numparms cell field+ exc-parms 14 cells+ constant exc-reclen 0 nostack1 \ context record cell + \ field+ ContextFlags cell + \ field+ Dr0 cell + \ field+ Dr1 cell + \ field+ Dr2 cell + \ field+ Dr3 cell + \ field+ Dr6 cell + \ field+ Dr7 0 + \ field+ FloatSaveArea cell + \ field+ FloatControl cell + \ field+ FloatStatus cell + \ field+ FloatTag cell + \ field+ FloatErrorOffset cell + \ field+ FloatErrorSelector cell + \ field+ FloatDataOffset 80 + \ field+ FloatDataSelector cell + \ field+ FloatRegisterArea cell + \ field+ FloatCr0NpxState cell + \ field+ SegGs cell + \ field+ SegFs cell + \ field+ SegEs cell + \ field+ SegDs cell field+ edi cell field+ esi cell field+ ebx cell field+ edx cell field+ ecx cell field+ eax cell field+ ebp cell field+ eip cell + \ field+ SegCs cell + \ field+ EFlags cell field+ esp cell + \ field+ SegSs constant ContextRecLen 0 nostack1 \ our save area exc-RecLen field+ off-recexcept ContextRecLen field+ off-reccontext cell field+ off-up@save cell field+ off-ebp@save cell field+ off-handler 4 cells field+ off-rstack 4 cells field+ off-stack constant ExceptBufflen : except-buffer ( -- a1 ) \ return the address of the &exrec @ off-recexcept ; \ exception handler's exception buffer : context-buffer ( -- a1 ) \ return the address of the &exrec @ off-reccontext ; \ exception handler's context buffer : upsave-buffer ( -- a1 ) \ return the address of the &exrec @ off-up@save ; \ save area for up : ebp@save-buffer ( -- a1 ) \ return the address of the &exrec @ off-ebp@save ; \ save area for ebp@ 0 value ?exceptioning \ detect recursive call to handler : .exhex ( n -- ) space [char] $ emit h.8 space ; EXTERNAL variable show-exception show-exception on \ show exception? variable recover-exception \ recover from exception? recover-exception on : .exception-code ( n -- ) \ get the last exception cr ." Exception" dup .exhex case EXCEPTION_ACCESS_VIOLATION of ." ACCESS_VIOLATION" endof EXCEPTION_INT_DIVIDE_BY_ZERO of ." INT_DIVIDE_BY_ZERO" endof EXCEPTION_FLT_DIVIDE_BY_ZERO of ." FLT_DIVIDE_BY_ZERO" endof EXCEPTION_FLT_STACK_CHECK of ." FLT_STACK_CHECK" endof EXCEPTION_FLT_INEXACT_RESULT of ." FLT_INEXACT_RESULT" endof EXCEPTION_FLT_UNDERFLOW of ." FLT_UNDERFLOW" endof EXCEPTION_FLT_DENORMAL_OPERAND of ." FLT_DENORMAL_OPERAND" endof EXCEPTION_FLT_INVALID_OPERATION of ." FLT_INVALID_OPERATION" endof EXCEPTION_FLT_OVERFLOW of ." FLT_OVERFLOW" endof EXCEPTION_ILLEGAL_INSTRUCTION of ." ILLEGAL_INSTRUCTION" endof EXCEPTION_DATATYPE_MISALIGNMENT of ." DATATYPE_MISALIGNMENT" endof \ EXCEPTION_GUARD_PAGE of ." GUARD_PAGE" endof EXCEPTION_BREAKPOINT of ." BREAKPOINT (INT 3)" endof \ EXCEPTION_SINGLE_STEP of ." SINGLE_STEP" endof \ EXCEPTION_NONCONTINUABLE of ." NONCONTINUABLE" endof EXCEPTION_PRIV_INSTRUCTION of ." PRIV_INSTRUCTION" endof \ EXCEPTION_IN_PAGE_ERROR of ." IN_PAGE_ERROR" endof \ EXCEPTION_STACK_OVERFLOW of ." STACK_OVERFLOW" endof \ EXCEPTION_INVALID_DISPOSITION of ." INVALID_DISPOSITION" endof \ EXCEPTION_ARRAY_BOUNDS_EXCEEDED of ." ARRAY_BOUNDS_EXCEEDED" endof \ EXCEPTION_NONCONTINUABLE_EXCEPTION of ." NONCONTINUABLE_EXCEPTION" endof EXCEPTION_INT_OVERFLOW of ." INT_OVERFLOW" endof EXCEPTION_INVALID_HANDLE of ." INVALID_HANDLE" endof endcase ; : clear-exception ( -- ) \ clear any previous exception &except off ; INTERNAL IN-SYSTEM : .addr-info ( xt -- ) \ print off code info dup .exhex \ print the address dup code>name \ see if we can find the nfa dup if \ yes dup>r dup count type \ type the name name>xt - [char] + emit $. \ and the offset r> .viewinfo else 2drop then ; : except-stack ( a1 -- ) \ print off the stack dup 4 cells+ swap ?do i @ \ possibly addr of something in code cr 4 spaces .addr-info cell +loop ; IN-APPLICATION : except-presskey ( -- ) cr ." Press any key to exit..." wait ; EXTERNAL : .exreg ( n -- ) @ .addr-info ; : .exception ( -- ) \ print exception info &except @ 0= if cr ." * No exception has occurred *" else except-io cr .version cr &except @ dup .exception-code EXCEPTION_ACCESS_VIOLATION = if cr ." Access addr:" except-buffer exc-Parms cell+ @ .exhex except-buffer exc-Parms @ if ." WRITE" else ." READ" then ." violation" then context-buffer cr ." Registers:" cr dup eax ." eax" .exreg cr dup ebx ." ebx" .exreg cr dup ecx ." ecx" .exreg cr dup edx ." edx" .exreg cr dup edi ." edi" .exreg cr dup esi ." esi" .exreg cr dup ebp ." ebp" .exreg cr dup esp ." esp" .exreg cr ." Backtracking:" cr dup eip ." eip" .exreg \ TURNKEYED? IF DROP EXIT THEN \IN-SYSTEM-OK &exrec @ off-rstack except-stack &exrec @ off-stack cr ." Data stack:" except-stack then ; INTERNAL : recover-except ( con-ptr -- n ) \ recovery handler, modify registers for retry ['] throw over eip ! \ get address of throw throw_winexcept over eax ! \ exception to top of stack for throw upsave-buffer @ over ebx ! \ recover saved up, best we can do! drop EXCEPTION_CONTINUE_EXECUTION ; \ attempt recovery 1 callback: handle-except ( exception-ptr -- ropt ) \ error routine called by os, save & setup except-io ?exceptioning if \ catch errors on error routine cr ." Recursive exception" except-presskey EXCEPTION_CONTINUE_SEARCH exit \ terminate exception then true to ?exceptioning dup @ dup>r @ \ get the exception code &except ! \ save exception for later r> \ fetch exception record except-buffer exc-RecLen move \ save it dup cell+ @ dup>r \ fetch context record context-buffer ContextRecLen move \ save the context record context-buffer esp @ dup>r \ get esp from new context stack &exrec @ off-rstack 4 cells move \ move rstack context-buffer ebp @ \ get ebp from new context stack &exrec @ off-stack 4 cells move \ move stack r> @ EBP@Save-Buffer ! \ save what esp points at show-exception @ if .exception then \ call exception print recover-exception @ if r> recover-except >r \ attempt recovery else r>drop EXCEPTION_CONTINUE_SEARCH >r \ no recovery then false to ?exceptioning \ no longer exceptioning show-exception @ if except-presskey then \ wait if we're showing... r> \ recover? from recovery option ; EXTERNAL 1 proc SetUnhandledExceptionFilter : SET-EXCEPT ( -- ) \ set exception routine handler ExceptBufflen malloc &exrec ! \ get a buffer for the context ['] handle-except call SetUnhandledExceptionFilter &exrec @ off-handler ! \ save exception handler up@ &exrec @ off-up@save ! \ save UP for recovery ; : UNSET-EXCEPT ( prev-except-addr -- ) \ unset exception routine &exrec @ off-handler @ \ get old exception handler call SetUnhandledExceptionFilter drop &exrec @ release &exrec off ; \ clear execution record address INTERNAL set-except initialization-chain chain-add set-except \ unload-chain chain-add unset-except MODULE only forth also definitions --- NEW FILE: asmmac.f --- ( Miscellaneous macros for Win32FORTH 486ASM version 1.26 ) ( copyright [c] 1994 by Jim Schneider ) ( This file version 1.21 ) ( This program is free software; you can redistribute it and/or modify ) ( it under the terms of the GNU General Public License as published by ) ( the Free Software Foundation; either version 2 of the License, or ) ( <at your option> any later version. ) ( ) ( This program is distributed in the hope that it will be useful, ) ( but WITHOUT ANY WARRANTY; without even the implied warranty of ) ( MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ) ( GNU General Public License for more details. ) ( ) ( You should have received a copy of the GNU General Public License ) ( along with this program; if not, write to the Free Software ) ( Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ) macro: ;m postpone ;macro endm immediate macro: al, al , ;m macro: cl, cl , ;m macro: dl, dl , ;m macro: bl, bl , ;m macro: ah, ah , ;m macro: ch, ch , ;m macro: dh, dh , ;m macro: bh, bh , ;m macro: ax, ax , ;m macro: cx, cx , ;m macro: dx, dx , ;m macro: bx, bx , ;m macro: sp, sp , ;m macro: bp, bp , ;m macro: si, si , ;m macro: di, di , ;m macro: eax, eax , ;m macro: ecx, ecx , ;m macro: edx, edx , ;m macro: ebx, ebx , ;m macro: esp, esp , ;m macro: ebp, ebp , ;m macro: esi, esi , ;m macro: edi, edi , ;m macro: [bx+si], [bx+si] , ;m macro: [bx+di], [bx+di] , ;m macro: [bp+si], [bp+si] , ;m macro: [bp+di], [bp+di] , ;m macro: [si], [si] , ;m macro: [di], [di] , ;m macro: [bp], [bp] , ;m macro: [bx], [bx] , ;m macro: [eax], [eax] , ;m macro: [ecx], [ecx] , ;m macro: [edx], [edx] , ;m macro: [ebx], [ebx] , ;m macro: [esp], [esp] , ;m macro: [ebp], [ebp] , ;m macro: [esi], [esi] , ;m macro: [edi], [edi] , ;m macro: [eax*2], [eax*2] , ;m macro: [ecx*2], [ecx*2] , ;m macro: [edx*2], [edx*2] , ;m macro: [ebx*2], [ebx*2] , ;m macro: [ebp*2], [ebp*2] , ;m macro: [esi*2], [esi*2] , ;m macro: [edi*2], [edi*2] , ;m macro: [eax*4], [eax*4] , ;m macro: [ecx*4], [ecx*4] , ;m macro: [edx*4], [edx*4] , ;m macro: [ebx*4], [ebx*4] , ;m macro: [ebp*4], [ebp*4] , ;m macro: [esi*4], [esi*4] , ;m macro: [edi*4], [edi*4] , ;m macro: [eax*8], [eax*8] , ;m macro: [ecx*8], [ecx*8] , ;m macro: [edx*8], [edx*8] , ;m macro: [ebx*8], [ebx*8] , ;m macro: [ebp*8], [ebp*8] , ;m macro: [esi*8], [esi*8] , ;m macro: [edi*8], [edi*8] , ;m macro: es, es , ;m macro: cs, cs , ;m macro: ss, ss , ;m macro: ds, ds , ;m macro: fs, fs , ;m macro: gs, gs , ;m macro: cr0, cr0 , ;m macro: cr2, cr2 , ;m macro: cr3, cr3 , ;m macro: cr4, cr4 , ;m macro: dr0, dr0 , ;m macro: dr1, dr1 , ;m macro: dr2, dr2 , ;m macro: dr3, dr3 , ;m macro: dr6, dr6 , ;m macro: dr7, dr7 , ;m macro: tr3, tr3 , ;m macro: tr4, tr4 , ;m macro: tr5, tr5 , ;m macro: tr6, tr6 , ;m macro: tr7, tr7 , ;m macro: st, st , ;m macro: st(0), st(0) , ;m macro: st(1), st(1) , ;m macro: st(2), st(2) , ;m macro: st(3), st(3) , ;m macro: st(4), st(4) , ;m macro: st(5), st(5) , ;m macro: st(6), st(6) , ;m macro: st(7), st(7) , ;m --- NEW FILE: callback.f --- \ $Id: callback.f,v 1.1 2006/09/21 16:26:33 dbu_de Exp $ \ CALLBACK.F Windows Callback support by Tom Zimmer \ arm 21/12/2004 21:21:09 Callback support -- moved out of kernel cr .( Loading Windows Callback...) \ --------------------------- Windows callback support ---------------------- \ Windows API externals interface words \ When Windows calls back into user code, the address passed as one of the \ parameters to the call to windows is the address of a routine to handle \ the callback. We must save the caller's registers, and set up the new data \ stack. \ n callback: <name> ... ; \ identifies a word as callable by Windows (and, by implication, \ not callable by Forth directly!). \ ' xt n export <ExternalName> \ marks the xt word as externally callable (primarily for DLLs \ and callbacks). The name is case sensitive. n represents the number \ of cells passed as parameters. Sets up the stacks to meet \ the internal requirements of Win32Forth. The word <ExternalName> \ is not callable directly from Forth, and is defined in a \ case-sensitive vocabulary; but call-proc can be used \ to test the word. See the example. \ Because of the way the callback restores registers on exit, the stack does \ not need to be clean on exit; the value on the top of the stack is taken as \ the return value. There is a limit of around 4K or 1024 parameters maximum \ on the stack (referenced by ebp), so be carefule that very deep nesting may \ well overrun the stack. \ See the .fonts example for standard use. To test a callback; \ \ : sum3 ( a b c -- d ) + + ; \ ' sum3 3 export Sum3 \ also exports \ 10 20 30 ' Sum3 call-proc . \ Callback entry and exit macros \ This could well be written as gcode and "move-code"d into place in the kernel. in-system : cb-entry { n -- } \ variable part of entry code macro[ push ebp \ caller's regs; push ebx \ save std regs push esi push edi mov ebx, fs: $14 \ get UP from TIB push sp0 [up] \ save sp0 push rp0 [up] \ save rp0 lea ebp, -4092 [esp] \ room for call mov sp0 [up], ebp \ new sp0 mov rp0 [up], esp \ new rp0 ]macro n if \ any params? n 0 ?do macro[ \ generate n fetches mov eax, n 6 + i - cells [esp] \ recover parm n ]macro i n <> if macro[ \ if not TOS in eax mov i 1+ cells negate [ebp], eax \ save on stack ]macro then loop macro[ lea ebp, n 1- cells negate [ebp] \ adjust stack ]macro then ; macro: cb-exit { n -- } \ exit code pop rp0 [up] \ restore rp0 pop sp0 [up] \ and sp0 pop edi \ restore regs pop esi pop ebx pop ebp \ original ebp ret n cells ;m : callback: { n -- } \ generate callback head : \ start definition macro[ n cb-entry call @@m1 \ call the code n cb-exit @@m1: \ code to be called here ]macro ; \ back to compiler : export { xt n -- } \ generate callback head also exports get-current >r definitions : \ start definition macro[ n cb-entry call xt \ call the code n cb-exit ]macro r> set-current previous \ original definitions postpone ; ; \ back to compiler in-application \ ---------------- allow Forth to handle windows messages ----------------- -1 value WM_WIN32FORTH 1 PROC TranslateMessage 1 PROC DispatchMessage 4 PROC DefWindowProc 1 callback: HandleMessages ( pMsg -- 0 ) TRUE msg-chain do-chain if dup Call TranslateMessage drop Call DispatchMessage then ; 4 callback: HandleWindowsMessages ( hwnd msg wparam lparam -- res ) over WM_WIN32FORTH <> if call DefWindowProc \ use default handler else 4dup forth-msg-chain do-chain 0 then ; 0 callback: byebye bye ; \ callback to terminate forth \ These messages are sent by the current console DLL. : HandleMessages-init ( -- ) ['] HandleMessages &CB-MSG ! ['] HandleWindowsMessages &CB-WINMSG ! ['] byebye &CB-BYE ! ; HandleMessages-init initialization-chain chain-add HandleMessages-init in-system : _DefaultWindowProc ( hwnd msg wparam lparam -- res ) call DefWindowProc ; defer DefaultWindowProc ' _DefaultWindowProc is DefaultWindowProc \ ----------------- An example of how to use a callback ------------------- \ this callback as specified by "EnumFonts" passes four (4) parameters to \ the callback procedure, so we must say "4 CallBack: FontFunc" to define \ a callback that accepts four parameters. \ in-application 4 PROC EnumFonts \ must be in-application for WinEd !!! \ in-system \ The "EnumFonts" windows call requires an application callback that will be \ called repeatedly to process each font in the system. We are just \ displaying the fonts, so we just look at the "dwType" to decide how to \ display each font. 4 callback: FontFunc1 { lpData dwType lptm lplf -- int } cr \ rls - many additions dwType dup TRUETYPE_FONTTYPE and IF ." " ELSE ." Non-" THEN ." TrueType " dup RASTER_FONTTYPE and IF ." Raster " ELSE ." Vector " THEN DEVICE_FONTTYPE and IF ." Device " ELSE ." GDI " THEN lplf 28 + LF_FACESIZE 2dup 0 scan nip - type cr 5 spaces lplf dup @ 4 .r \ height 4 + dup @ 4 .r \ width 4 + dup @ 6 .r.1 \ escapement angle 4 + dup @ 6 .r.1 \ orientation angle 4 + dup @ 4 .r \ weight 4 + dup c@ 1 and 2 .r \ italics 1 + dup c@ 1 and 2 .r \ underline 1 + dup c@ 1 and 2 .r \ strike-out 1 + dup c@ 4 .r \ character set 1 + dup c@ 2 .r \ output precision 1 + dup c@ 4 .r \ clip precision 1 + dup c@ 2 .r \ output quality 1 + c@ 4 h.r \ family and pitch 1 ; \ return "1=success" flag to windows : .fonts ( -- ) cr 5 spaces ." ht wide esc ornt wt I U S set p cp q fp" 0 ['] FontFunc1 \ the callback 0 conDC \ the Device Context of the DC call EnumFonts drop ; in-application --- NEW FILE: lineedit.f --- \ LEDIT.SEQ Line Editor Utility by Tom Zimmer cr .( Loading Line Editor...) \ 07-18-95 SMuB replaced getxy and gotoxy calls with _legetxy, _legotoxy. \ These routines use buffer coordinates instead of screen coordinates \ since screen coordinates are volatile. (( Here is a relatively simple editor for editing one line strings. Support is provided for strings up to 255 characters in length, with full word and character operations using keypad or WordStar keys as follows: Ctrl-A Left word Ctrl-S Left character Ctrl-D Right character Ctrl-F Right word Ctrl-G Forward delete Ctrl-T Word delete Ctrl-Y Line delete or clear Left arrow Left character Ctrl-Left arrow Left word Right arrow Right character Ctrl-Right arrow Right word Home Beginning of line End End of line ESC Discard changes and leave Return/Enter Save changes and leave The parameters needed by LINEEDIT are as follows: lineeditor ( x y a1 n1 --- ) x = char pos on row, zero = left edge y = row number, zero = top line a1 = counted string n1 = edit limit length, maximum value = 80 Here is an example of a command that would edit a line of text in SAMPLEBUFFER, with a maximum length of 12 characters, at location row 10 column 5 on the screen. 5 10 samplebuffer 12 lineedit Two auto resetting flags can be used to control the behavior of the line editor in special ways. The STRIPING_BL'S boolean "VALUE" determines whether the line editor will strip trailing blanks from an edited string at the completion of the edit. this VALUE defaults to TRUE, do strip trailing blanks. false to STRIPPING_BL'S will prevent line edit from stripping spaces. The AUTOCLEAR boolean "VALUE" determines whether the line edit buffer will be automatically cleared if the first character you enter on starting an edit is a normal text char. This is used to ease the users life in the situation where you want to give them the option of re-using a string or easily entering a new one without having to delete the old string first. This VALUE defaults to FALSE, no autoclear. true to AUTOCLEAR will cause line edit to automatically clear the edit string if a letter if the first thing entered. )) \ only forth also definitions \ anew -lineedit.f INTERNAL \ internal words start here EXTERNAL true value stripping_bl's \ are we stripping trailing blanks? false value autoclear \ automatically clear line if first true value insertmode \ insert/overwrite mode flag INTERNAL \ internal words start here variable saveflg \ are we saving the results 0 value ?ldone \ is line edit done? 0 value lchar \ recent line edit character 0 value ledit-x \ where we are editing X 0 value ledit-y \ where we are editing Y 0 value lenlimit \ line edit length limit defer ledbutton ' noop is ledbutton MAXCOUNTED constant maxedit create editbuf MAXSTRING allot \ our edit buffer, editbuf off \ 255 characters max 0 value editpos \ current edit position in buffer : _legetxy ( --- x ~y ) \ Negative y indicates buffer coordinates getxy getrowoff + invert ; : _legotoxy ( x y --- ) \ Goto screen or buffer coordinates dup 0< if \ if y is negative, go to buffer coordinates (x,~y) invert dup getrowoff dup rows + 1- between 0= if \ If the desired buffer y is not in the window, scroll it in dup rows - 1+ setrowoff then getrowoff - then gotoxy ; : lcalcx ( -- x ) \ calculate cursor x positon editpos COLS /mod drop ledit-x + ; : lcalcy ( -- y ) \ calculate cursor y positon editpos COLS / ledit-y - getrowoff 0= if 1- then ; \ rewritten for better line wraping \ Sonntag, Januar 16 2005 dbu : .lecursor ( --- ) \ show the cursor editpos to accept-cnt lcalcx lcalcy _legotoxy ; : .leline ( --- ) \ redisplay edit line ledit-x ledit-y _legotoxy editbuf count type lenlimit ledit-x + COLS 1- min SP>COL ; : __le-ldel ( -- ) \ Line delete 0 editbuf c! 0 to editpos ; : _lichar ( c1 -- ) autoclear \ should we clear the line on the if __le-ldel \ first character typed? false to autoclear then insertmode if editbuf 1+ editpos + dup 1+ maxedit editpos - move editbuf c@ 1+ lenlimit min editbuf c! then editbuf 1+ editpos + c! \ removed 'COLS 1- min' for better line wraping \ Sonntag, Januar 16 2005 dbu editpos 1+ lenlimit min ( COLS 1- min ) to editpos editpos editbuf c@ max editbuf c! ; : ?lechar ( --- ) \ handle normal keys, insert them lchar bl 0xFF between if lchar _lichar then ; : _le-home ( --- ) \ beginning of line 0 to editpos ; : _le-end ( --- ) \ End of line editbuf c@ to editpos ; : _le-right ( --- ) \ right a character \ removed 'COLS 1- min' for better line wraping \ Sonntag, Januar 16 2005 dbu editpos 1+ editbuf c@ min ( COLS 1- min ) to editpos ; : _le-left ( --- ) \ left a character editpos 1- 0MAX to editpos ; : _ledone ( --- ) \ flag edit is finished, save changes true to ?ldone saveflg on ; : _lequit ( false --- true ) \ flag edit is finished, discard chngs true to ?ldone mark-none saveflg off ; defer _le-ret ' _ledone is _le-ret defer _le-tab ' _ledone is _le-tab defer _le-quit ' _lequit is _le-quit defer _le-LF ' noop is _le-LF defer _le-pgup ' noop is _le-pgup defer _le-pgdn ' noop is _le-pgdn defer _le-up ' noop is _le-up defer _le-down ' noop is _le-down defer _le-ldel ' __le-ldel is _le-ldel : _le-fdel ( --- ) \ Forward delete editpos 1+ editbuf c@ max editbuf c! editbuf 1+ editpos + dup 1+ swap maxedit editpos - move -1 editbuf c+! ; : >to=bl ( --- ) \ forward to a blank editbuf 1+ dup maxedit + swap editpos + ?do i c@ bl = ?leave 1 +to editpos loop editbuf c@ editpos min to editpos ; : >to<>bl ( --- ) \ forward to a non blank editbuf 1+ dup maxedit + swap editpos + ?do i c@ bl <> ?leave 1 +to editpos loop editbuf c@ editpos min to editpos ; : _le-rword ( --- ) \ Forward to next word >to=bl >to<>bl ; : <to=bl+1 ( --- ) \ back to char following BL editpos 1- 0MAX to editpos editbuf 1+ dup editpos + 1- editbuf 1+ max ?do i c@ bl = ?leave -1 +to editpos -1 +loop ; : <to<>bl ( --- ) \ Back to non blank editpos 1- 0MAX to editpos editbuf 1+ dup editpos + 1- editbuf 1+ max ?do i c@ bl <> ?leave -1 +to editpos loop ; : _le-lword ( --- ) \ back a word <to<>bl <to=bl+1 ; : _le-bdel ( --- ) \ back delete editpos editbuf c@ max editbuf c! editpos ( --- f1 ) _le-left ( --- f1 ) if insertmode \ if we are in insertmode if _le-fdel \ then delete the character else bl editbuf 1+ editpos + c! \ else change char to blank then else beep then ; : _le-wdel ( --- ) \ word delete begin editpos editbuf c@ < editbuf 1+ editpos + c@ bl <> and while _le-fdel repeat begin editpos editbuf c@ < editbuf 1+ editpos + c@ bl = and while _le-fdel repeat ; : strip_bl's ( --- ) \ strip blanks from editbuf editpos >r _le-end begin _le-left editbuf 1+ editpos + c@ bl = editpos 0<> and while _le-fdel repeat editbuf c@ r> min 0MAX to editpos editbuf c@ 1 = \ count=1 & char=blank editbuf 1+ c@ bl = and if 0 editbuf c! \ then reset buffer to empty then ; : _le-ins ( --- ) \ toggle insert mode insertmode 0= dup to insertmode if big-cursor else norm-cursor then ; : _le-any ( --- ) \ handle any character entry ; : ?control ( --- ) \ handle control characters lchar bl < if false to autoclear \ no auto clear now lchar exec: \ 0 null 1 a 2 b 3 c 4 d 5 e 6 f noop _le-lword noop _le-pgdn _le-right _le-up _le-rword \ 7 g 8 h 9 i LF 11 k 12 l Enter _le-fdel _le-bdel _le-tab _le-LF noop noop _le-ret \ 14 n 15 o 16 p 17 q 18 r 19 s 20 t noop noop noop noop _le-pgup _le-left _le-wdel \ 21 u 22 v 23 w 24 x 25 y 26 z Esc noop _le-ins noop _le-down _le-ldel noop _le-quit \ 28 \ 29 ] 30 ^ 31 _ noop noop noop noop then ; : ?func ( --- ) \ handle function keys \ if function key bit is set lchar function_mask special_mask or and \ func or special lchar shift_mask and shift_mask = or \ or Shift mask lchar bl < or \ or control key if \ or other keypad key false to autoclear \ no auto clear now \ "ledit-chain" allows addingto or over-riding a function ckey at Forth commandline \ use CHAIN-ADD to add a function test, and CHAIN-ADD-BEFORE to over-ride an \ existing functionkey during commandline editing. lchar FALSE ledit-chain do-chain 0= if case k_home of _le-home endof \ Home k_up of _le-up endof \ Up arrow k_pgup of _le-PgUp endof \ PgDn k_left of _le-left endof \ Left arrow k_right of _le-right endof \ Right arrow k_end of _le-end endof \ End k_down of _le-down endof \ Down arrow k_pgdn of _le-PgDn endof \ PgDn k_insert of _le-ins endof \ Ins k_delete of _le-fdel endof \ Del k_left +k_control of _le-lword endof \ Ctrl Left arrow k_right +k_control of _le-rword endof \ Ctrl Right arrow endcase else drop \ already handled, discard key value 0 to lchar then then ; \ c1 = keyboard character \ f1 = true for done editing : _le-key ( c1 --- ) \ process a key to lchar ?lechar \ handle normal ascii ?func \ function characters ?control ; \ control chars \ x = char pos on row \ y = line number \ a1 = counted string \ n1 = edit limit length : <ledit> ( x y a1 n1 --- ) \ Edit line currently in EDITBUF. lenlimit >r get-cursor >r over c@ editpos min to editpos maxedit min to lenlimit \ save max edit length dup >r \ save source address editbuf over c@ lenlimit min 1+ move editbuf c@ lenlimit min editbuf c! dup 0< 0= \ SMuB if getrowoff + invert \ SMuB then \ SMuB to ledit-y to ledit-x \ save origin _le-ins _le-ins false to ?ldone begin .leline .lecursor key _le-key ?ldone until saveflg @ dup \ proper save exit if stripping_bl's \ do we want to strip blanks? if strip_bl's then true to stripping_bl's \ force it next time editbuf r@ over c@ lenlimit min 1+ move then r>drop r> set-cursor ( --- f1 ) r> to lenlimit false to autoclear ; \ no automatic line clear EXTERNAL \ externally available words start here \ x = char pos on row \ y = line number \ a1 = counted string \ n1 = edit limit length \ f1 = true for saved changes \ f1 = false for canceled with ESC : lineeditor ( x y a1 n1 --- f1 ) \ Edit line in a1 defer@ _le-quit >r ['] _lequit is _le-quit defer@ _le-LF >r ['] noop is _le-LF 0 to editpos <ledit> r> is _le-LF r> is _le-quit ; INTERNAL MAXSTRING constant b/accept \ each commandline is MAXSTRING bytes 31 constant n/accept \ save 31 previous command lines \ use 31 to make it fit in 8k bytes 0 value accept# 0 value accepted? b/accept n/accept * Pointer prev-accept-buf : accept-init ( -- ) 0 to accept# prev-accept-buf b/accept n/accept * erase ; initialization-chain chain-add accept-init \ add to init chain create laccept-buf b/accept allot laccept-buf off : +accept# ( n1 -- ) accept# + n/accept mod to accept# ; : prev-accept-buf" ( -- a1 n1 ) prev-accept-buf accept# b/accept * + count ; : accept-lup ( -- ) false to accepted? -1 +accept# prev-accept-buf" editbuf place editbuf c@ to editpos ; : accept-ldown ( -- ) accepted? 0= if 1 +accept# then false to accepted? prev-accept-buf" editbuf place editbuf c@ to editpos ; : __laccept ( a1 n1 -- ) 0 ED_READY editor-message \ notify editor we are ready ['] accept-lup is _le-up ['] accept-ldown is _le-down laccept-buf c@ \ backup current line if laccept-buf count prev-accept-buf accept# b/accept * + place 1 +accept# then true to accepted? swap >r >r _legetxy laccept-buf dup off r> lineeditor if laccept-buf count r@ swap move laccept-buf c@ _legetxy nip _legotoxy else editbuf off _legetxy nip 0 swap 2dup _legotoxy cols 1- sp>col _legotoxy 1 +accept# then r>drop laccept-buf c@ ; : _laccept ( a1 n1 -- n2 ) \ line editor version of accept defer@ _le-up >r defer@ _le-down >r ['] __laccept catch \ -- f1 r> is _le-down \ restore these functions r> is _le-up ( -- f1 ) throw ; ' _laccept is accept ' _laccept to defaultAccept \ make this the default handler MODULE \s variable samplebuffer 128 allot : sample ( --- ) s" Zimmer, Harold" samplebuffer place true to autoclear 10 04 samplebuffer 24 lineeditor drop cr samplebuffer count type ; --- NEW FILE: numconv.f --- \ $Id: numconv.f,v 1.1 2006/09/21 16:26:33 dbu_de Exp $ 0 [IF] --------------------------- Change Block ------------------------------- arm 15/08/2005 22:56:45 First version 0.1 STC based kernel ------------------------- End Change Block ----------------------------- Experimental: a fully optimising, STC based, ANS Forth compliant kernel Copyright [c] 2005 by Alex McDonald (alex at rivadpm dot com) Tom Zimmer This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or <at your option> any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ------------------------------------------------------------------------ [THEN] cr .( Loading number conversions... ) sourcefilename type \ Each number conversion routine on the "number?-chain" chain is sent a string \ ( addr len) and can attempt to convert the number. If the conversion fails \ the routine performs a -1 THROW to indicate that it can't convert the string; \ the next routine is then tried until success or the chain is exhausted. If \ the chain is exhausted, then a -13 THROW (undefined) is executed. \ If conversion succeeds, then a double number must be returned. If the number \ is truly a double, then set the DOUBLE? flag to true, otherwise the number will \ be considered a single, and the high order cell will be discarded. \ For numbers with a decimal point, the value DPL can be set to indicate \ where it's located in the input string. \ If desired, the flag -ve-num? can be set to true; the number will be negated \ before it is used. This is to avoid keeping flags to indicate that the sign \ has been detected in each routine separately. \ Floating point numbers are returned in the floating point stack; there is \ no return value, and the variable FLOAT? is set. See FLOAT.F for details; \ the code is in that file, not here. NOTE - even floating point routines must \ return a double value; it's ignored if FLOAT? is set. \ The chain number conversion technique allow number conversion to be easily \ extended to support additional forms of number conversion. This code is \ added very early, so you can normally only use words in the kernel here. \ [Historical note] Earlier versions of W32F used a similar chain technique, but \ carried a flag that was checked to see if the preceding routine had done the \ conversion. Performing a THROW on failure is much easier, hence the change. \ following defined in kernel; \ 0 VALUE DOUBLE? \ double value \ -1 VALUE DPL \ decimal point location \ 0 value -ve-num? \ negate value flag new-chain number?-chain : -ifzerothrow ( n -- n ) dup 0= throw \ -1 throw if zero length ; : -ve-test ( addr len -- addr' len' ) \ skip possible - sign, set -ve-num? -ifzerothrow \ stop if nothing to convert over c@ [char] - = \ check for sign if -ve-num? throw \ if already negative, throw true to -ve-num? 1 /string \ bump past -ifzerothrow \ nothing left is error then ; : run-numchain ( addr len -- d1 ) \ run number chain; \ d1 is number, or -13 throw (undefined) 2>r \ save string on rstack number?-chain \ run the number chain begin @ dup while num-init \ clear the flags dup 2r@ rot \ string xt cell+ @ catch \ do the xt 0= if \ leave if no error 2r> 2drop \ clean the rstack rot drop \ drop the address -ve-num? if dnegate then \ make negative if asked to exit then 2drop \ clear out failed conversion repeat -13 throw \ failed to convert ; \ ------------------------ dotted number -------------------------------------- : dotted-number? ( addr len -- d1 ) -ve-test 0 0 2SWAP >NUMBER \ convert number dup if OVER C@ [CHAR] . = \ next char is a '.' ? if dup 1- to DPL true to double? 1 /string >number \ convert the rest then dup 0<> throw \ check no string then 2drop \ otherwise, drop string ; \ ------------------------ based-number $&% ----------------------------------- \ Can be used to force number recognition in any base \ $ -- hex prefix \ & -- decimal \ % -- binary : base-tonum ( addr len base -- d1 ) base @ >r base ! \ save base, set base ['] dotted-number? catch \ convert r> base ! \ restore base throw \ throw if in error ; : xbase-convert ( addr len base -- d1 ) >r 1 /string r> \ past base char base-tonum ; : base-number? ( addr len -- d1 ) \ [-][$&%#][-]n[n*][.n*] -ve-test \ might start with - over c@ case [char] $ of 16 xbase-convert endof [char] & of 10 xbase-convert endof [char] # of 10 xbase-convert endof [char] % of 2 xbase-convert endof drop dotted-number? dup endcase ; : new-number ( str len -- d1 ) \ d1 is number, or -13 throw (undefined) localbuff >r r@ place r> ?uppercase count \ uppercase a copy run-numchain ; \ run the chain \ ------------------------ 0x[L] hex number ----------------------------------- : lastchar ( addr len -- addr len char ) 2dup 1- + c@ ; : 0x-number? ( addr len -- d1 ) -ve-test \ might start with - over 2 s" 0X" str= 0= throw \ start with 0X? 2 /string \ bump past 0x -ifzerothrow \ throw if too short lastchar [char] L = + \ end in L? trim off if so 16 base-tonum \ convert hex string ; \ -------------------------- xH hex number ------------------------------------ : hex-number? ( addr len -- d1 ) \ xxxxH type numbers -ifzerothrow \ throw if too short lastchar [char] H <> throw \ end in H? 1- 16 base-tonum \ trim off, convert ; \ --------------------------- '.' number -------------------------------------- : quoted-number? ( addr len -- d1 ) \ 'x' type numbers -ve-test \ might be negative 3 <> throw \ not 3 chars 'x' dup dup c@ swap 2 + c@ \ fetch first and third chars over = swap [char] ' = and invert throw \ equal and ', otherwise error 1+ c@ 0 \ fetch the character ; \ ------------------------ Windows Constant Server ---------------------------- library wincon.dll \ winlib-last @ constant WinConLib 3 proc wcFindWin32Constant \ winproc-last @ constant WinConPtr \ for **WORDS.F** 3 proc wsEnumWin32Constants \ winproc-last @ constant WinEnumPtr \ for **WORDS.F** : wincon-call ( a1 -- n f ) \ call to find constant >r 0 sp@ r> count swap \ point at result on stack call wcFindWin32Constant \ find it ; : wincon-number? ( a1 n1 -- d ) \ find constant; already uppercased maxstring localalloc dup>r \ allocate a buffer place r@ wincon-call 0= \ find constant if drop \ drop returned value s" A" r@ +place \ append an 'A' r@ wincon-call \ find it 0= throw \ can't find it then r>drop 0 \ make a double ; \ ------------------- Dotted IP notation (a.b.c.d) ------------------------------ : ip-seg ( addr len -- addr' len' n ) \ IP segment before . dup >r \ save length 0 0 2swap >number \ convert to number 2swap d>s \ save string & convert to single over r> <> \ check lengths differ before & after over 0 256 within \ and range check it and 0= throw \ flag; true=error ; : ip-number? ( addr len -- d ) \ convert ip address 8 24 do \ 3 dotted segments ip-seg \ convert up to dot i lshift \ shift the value, -rot \ addr string to top -ifzerothrow \ string too short? over c@ [char] . <> throw \ check for a dot, error if not 1 /string \ move past . -8 +loop \ next shift ip-seg \ convert what's left -rot throw \ should be nothing left drop or or or 0 \ ors to get result, make double ; number?-chain chain-add base-number? number?-chain chain-add quoted-number? number?-chain chain-add hex-number? number?-chain chain-add 0x-number? number?-chain chain-add wincon-number? \ windows constant server number?-chain chain-add ip-number? \ dotted IP notation ' new-number is number \ replace normal number conversion \ with the new chain scheme \ ------------------- Compatability layer -------------------------------------- defer discard-number ' 2drop is discard-number \ for doubles; see float.f for floats : number? ( addr len -- d f ) \ to support >float num-init ['] dotted-number? catch 0= double? 0= and \ october 1st, 1996 - 10:51 tjz & am ; \ double exponent not allowed : is-number? ( addr len -- f ) \ number check ['] run-numchain catch >r discard-number r> 0= ; \ ----------------------- Floating point --------------------------------------- \ defined in FLOAT.F \ ----------------------- Number display --------------------------------------- : (xud,.) ( ud commas -- a1 n1 ) >r <# \ every 'commas' digits from right r@ 0 do # 2dup d0= ?leave loop begin 2dup d0= 0= \ while not a double zero while [char] , hold r@ 0 do # 2dup d0= ?leave loop repeat #> r> drop ; : (ud,.) ( ud -- a1 n1 ) base @ \ get the base dup 10 = \ if decimal use comma every 3 digits swap 8 = or \ or octal use comma every 3 digits 4 + (xud,.) ; \ display commas every 3 or 4 digits : ud,.r ( ud l -- ) \ right justified, with ',' >r (ud,.) r> over - spaces type ; : u,.r ( n1 n2 -- ) \ display double unsigned, justified in field 0 swap ud,.r ; : ud. ( ud -- ) \ display double unsigned 0 ud,.r ; : ud.r ( ud l -- ) \ right justified, without ',' >r 16 (xud,.) r> over - spaces type ; : (d.#) ( d1 n1 -- a1 n1 ) \ display d1 with n1 places behind dp >r <# \ n1=negative will display'.' but no digits r> ?dup \ if not zero, then display places if 0 max 0 ?do # loop [char] . hold then #s #> ; : d.r.# ( d1 n1 n2 -- ) \ print d1 in a field of n1 characters, \ displ... [truncated message content] |
