Menu
▾
▴
[Win32forth-cvs] win32forth/src numconv.f,NONE,1.1 Class.f,1.3,1.4 Extend.f,1.4,1.5 FLOAT.F,1.1,1.2 Primutil.f,1.3,1.4
|
From: Alex M. <ale...@us...> - 2005-04-26 19:56:58
|
Update of /cvsroot/win32forth/win32forth/src In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv3549/src Modified Files: Class.f Extend.f FLOAT.F Primutil.f Added Files: numconv.f Log Message: arm: major change to number conversion routines (but not float); see numconv.f Index: Primutil.f =================================================================== RCS file: /cvsroot/win32forth/win32forth/src/Primutil.f,v retrieving revision 1.3 retrieving revision 1.4 diff -C2 -d -r1.3 -r1.4 *** Primutil.f 12 Mar 2005 09:09:57 -0000 1.3 --- Primutil.f 26 Apr 2005 19:56:49 -0000 1.4 *************** *** 119,124 **** : not 0= ; - : d0= or 0= ; - : get-commandline ( -- ) \ initialize TIB from the commandline 0 to source-id --- 119,122 ---- *************** *** 270,275 **** 2 * 1+ dup>r roll r> roll ; - : D>S ( d1 -- n1 ) - drop ; 0 value olddepth --- 268,271 ---- *************** *** 558,562 **** new-chain mouse-chain \ chain of things to do on mouse down new-chain forth-io-chain \ chain of things to to to restore forth-io ! new-chain number?-chain \ chain of number conversion options new-chain ledit-chain \ line editor function key chain new-chain msg-chain \ chain of forth key messages --- 554,558 ---- new-chain mouse-chain \ chain of things to do on mouse down new-chain forth-io-chain \ chain of things to to to restore forth-io ! \ new-chain number?-chain \ chain of number conversion options new-chain ledit-chain \ line editor function key chain new-chain msg-chain \ chain of forth key messages *************** *** 621,625 **** : winver-init ( -- n ) \ get windows version 148 dup _localalloc dup>r ! \ set length of structure ! r@ rel>abs call GetVersionEx \ call os for version 0= abort" call failed" r@ 4 cells+ @ \ get osplatformid --- 617,621 ---- : winver-init ( -- n ) \ get windows version 148 dup _localalloc dup>r ! \ set length of structure ! r@ call GetVersionEx \ call os for version 0= abort" call failed" r@ 4 cells+ @ \ get osplatformid *************** *** 674,813 **** DEPRECATED - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - \ A super version of number that detect the 0x00 'C' style of hex numbers - \ as well as ascii characters in the 'A' format. - \ A HEX number ending in 'L' automatically has the 'L' removed. This is - \ done so Forth can accept 0x1234L format numbers as they are encountered - \ in 'C' header files. - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - - : new-number? ( a1 n1 f1 -- d1 TRUE | a1 n1 FALSE ) - dup ?exit drop - 2dup number? - if 2swap 2drop TRUE - else 2drop FALSE - then ; - - number?-chain chain-add new-number? \ first item in NUMBER? chain - - \ October 19th, 2000 - 9:39 tjz - \ per a suggestion from Anton Ertl <an...@a0...>, I have - \ modified 0xNUMBER? to allow the following syntax; - \ - \ old way still works new way also works - \ 0x-23 -0x23 - \ - \ old ways didn't work anyway new way works - \ '-a' -'a' -'a' - \ - - : 0xNUMBER? { adr len flg \ adr2 len2 -- d1 TRUE | a1 n1 FALSE } - flg \ leave if already converted - IF adr len flg - EXIT - THEN - adr c@ ascii - = dup >r \ if preceeded by '-' - IF adr len 1 /string \ then strip it off - ELSE adr len - THEN to len2 to adr2 \ new string to use - adr2 c@ ascii ' = \ test for leading tick (') - IF len2 3 = \ and length is three - adr2 2 + c@ ascii ' = and \ and trailing tick (') - IF adr2 1+ c@ 0 TRUE - ELSE adr2 len2 flg - THEN - ELSE base @ >r \ preserve base - adr2 len2 - adr2 2 S" 0X" str= \ if start with 0x - IF hex \ use hex number base - 2 /string \ remove 0x - 2dup + 1- c@ ascii L = \ if have trailing 'L' - IF 1- 0 max \ then remove that also - THEN - ELSE adr2 1 S" $" str= \ if start with $ - IF hex \ use hex number base - 1 /string \ remove $ - THEN - THEN - FALSE new-number? - r> base ! \ restore base - THEN - IF r> \ converted, so get '-' flag - IF DNEGATE \ if true, then negate result - THEN TRUE \ and return a true flag - ELSE r>drop \ didn't convert, discard '-' flag - 2drop \ discard the string - adr len \ replace with original string - FALSE \ and return a false flag - THEN ; - - number?-chain chain-add 0xNUMBER? - - \ Each number conversion check on the "number?-chain" checks to see if the - \ string a1,n1 has already been converted (f1=TRUE), if it has, then they - \ simply exit. If string a1,n1 hasn't been converted, then they attempt - \ conversion. If conversion fails, they return the original string a1,n1 - \ and a f1=FLASE flag. If conversion succeeds, then they return their - \ result, either on the data stack, or the floating point stack, and return - \ f1=TRUE to say conversion was completed properly. In the case of a - \ floating point conversion, a global flag is set to be used later by - \ NUMBER, when it goes to compile the number. This is needed since - \ floating point numbers are returned on the floating point stack instead - \ of on the data stack. The chain number conversion technique allow number - \ conversion to be easily extended to support additional forms of number - \ conversion. - - : _discard-number ( d1 -- ) \ discard a converted number - 2drop ; - - defer discard-number - ' _discard-number is discard-number - - : super-number? ( a1 n1 -- d f1 ) - FALSE to double? - FALSE number?-chain do-chain ; - - : new-number ( ^str -- d ) \ an extensible version of NUMBER - ?UPPERCASE count super-number? ?missing ; - - ' new-number is number \ replace normal number conversion - \ with the new chain scheme - - - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - \ -------------------- Windows Constant Server -------------------- - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - - WinLibrary 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** - - \ Linkage for Windows Constant server through the number chain - - : wincon-number? ( a1 n1 f1 -- d1 TRUE | a1 n1 FALSE ) - { \ con$ WinVal -- } - MAXSTRING LocalAlloc: con$ \ allocate a buffer the con name - dup ?EXIT drop - 2dup con$ place \ lay string in buffer - 2dup swap rel>abs - &of WinVal rel>abs -rot \ under adr & len - Call wcFindWin32Constant \ find it - IF 2drop - WinVal 0 TRUE \ return constant, zero and TRUE - ELSE s" A" con$ +place \ append an 'A' - con$ count swap rel>abs - &of WinVal rel>abs -rot \ under adr & len - Call wcFindWin32Constant \ find it - IF 2drop - WinVal 0 TRUE - ELSE FALSE - THEN - THEN ; - - number?-chain chain-add wincon-number? \ windows constant server - \ -------------------- Load Standard Libraries -------------------- --- 670,673 ---- *************** *** 994,1055 **** defer (dialogunlock) ' noop is (dialogunlock) - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - \ Additional words for printing - \ \\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\\ - - \ Replaced by printsupport.f - - \s - WINLIBRARY W32FPRINT.DLL - 1 PROC p_printdlg as print-setup ( hwnd -- PintDC ) - \ bring up the printer page setup - 0 PROC p_startprint - 0 PROC p_pageprint - 0 PROC p_endprint - 1 PROC p_initprint - 0 PROC p_closeprint - \ if n1 >0 then n1 = printer resolution in DPI - \ if n1 <0 then n1 = device indepentant code, -1 = draft to -4 = high - 0 PROC p_qualityprint as quality-print ( -- n1 ) \ return the print quality code - 0 PROC p_startapage - 0 PROC p_endapage - 0 PROC p_printcopies as get-copies ( -- n1 ) - 0 PROC p_printfrompages as get-frompage ( -- n1 ) - 0 PROC p_printtopages as get-topage ( -- n1 ) - 1 PROC p_orientation as PRINT-ORIENTATION ( f1 -- hDC ) \ true = landscape - 4 PROC p_initprint2 - \ rls February 4th, 2002 - 5:47 - 0 PROC p_printflags as print-flags ( -- flag ) - \ true if selection radio button chosen - - : print-start ( -- ) \ start printing a new page & doc - call p_startprint drop ; - - : print-page ( -- ) \ finish current page start new page - call p_pageprint drop ; - - : print-end ( -- ) \ finish printing page and doc - call p_endprint drop ; - - : print-init ( -- printDC ) \ initialize the printer, return DC - 0 call p_initprint ; - - \ rls February 4th, 2002 - 20:24 - : print-init2 ( bitmapped flags topage -- printDC ) - 0 call p_initprint2 ; \ initialize the printer, return DC - - : auto-print-init ( -- printDC ) \ initialize the printer, return DC - 1 call p_initprint ; - - : print-close ( -- ) \ close the printer - call p_closeprint drop ; - - : start-page ( -- ) - call p_startapage drop ; - - : end-page ( -- ) - call p_endapage drop ; - - - |
