Menu
▾
▴
[Win32forth-cvs] win32forth-stc/src Class.f, 1.13, 1.14 numconv.f, 1.2, 1.3 paths.f, 1.8, 1.9 xfiledlg.f, 1.1, 1.2
|
From: Alex M. <ale...@us...> - 2007-08-17 02:57:26
|
Update of /cvsroot/win32forth/win32forth-stc/src In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv17159/src Modified Files: Class.f numconv.f paths.f xfiledlg.f Log Message: arm: chnages to support forth200x, add lastchar and -trailchar to kernel Index: numconv.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/numconv.f,v retrieving revision 1.2 retrieving revision 1.3 diff -C2 -d -r1.2 -r1.3 *** numconv.f 21 May 2007 08:38:46 -0000 1.2 --- numconv.f 17 Aug 2007 02:57:20 -0000 1.3 *************** *** 72,109 **** \ 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 ; --- 72,102 ---- \ 0 value -ve-num? \ negate value flag : -ve-test ( addr len -- addr' len' ) \ skip possible - sign, set -ve-num? ! dup 0= throw \ stop if nothing to convert ! over c@ [char] - = if \ check for sign ! -ve-num? throw \ if already negative, throw true to -ve-num? 1 /string \ bump past then ; + new-chain number?-chain + : run-numchain ( addr len -- d1 ) \ run number chain; ! number?-chain >r ! begin r> @ dup>r \ save link address ! while num-init \ clear the flags ! 2dup r@ cell+ @ \ work on copy of the string ! base @ >r \ save the base ! catch \ do the xt ! r> base ! \ restore the base ! if 2drop \ failed, so clear out failed try again ! else ! r>drop 2nip \ clean rstack and clear string -ve-num? if dnegate then \ make negative if asked to exit then repeat -13 throw \ failed to convert ; *************** *** 113,127 **** : 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 ; --- 106,127 ---- : dotted-number? ( addr len -- d1 ) -ve-test ! 0 0 2swap >number \ convert number ! dup if ! over c@ [char] . = if \ next char is a '.' ? ! dup 1- to dpl true to double? 1 /string >number \ convert the rest then then ! dup 0<> throw \ check no string ! 2drop \ drop string ! ; ! ! : quoted-number? ( addr len -- d1 ) \ 'x' type numbers ! 2 <> throw \ not 3 chars 'x' ! dup c@ swap ! 1+ c@ [char] ' <> throw ! 0 ; *************** *** 133,197 **** \ % -- 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 ---------------------------- --- 133,165 ---- \ % -- binary ! create base-list 10 , 16 , 2 , 10 , 0 , ! \ # $ % & ' ! : base-number? ( addr len -- d1 ) \ [-][$%#][-]n[n*][.n*] -ve-test \ might start with - ! over c@ [char] # - dup 5 u< if ! base-list +cells @ base ! \ set base ! 1 /string ! else drop then ! base @ 0= if \ convert ! quoted-number? ! else ! dotted-number? ! then ; ! number?-chain chain-add base-number? ! ' run-numchain is number \ replace normal number conversion ! \ with the new chain scheme \ ------------------------ 0x[L] hex number ----------------------------------- : 0x-number? ( addr len -- d1 ) ! dup 3 < throw \ if too short throw ! over 2 s" 0X" istr= 0= throw \ start with 0X? 2 /string \ bump past 0x ! 2dup + 1- c@ upc 'L' = + \ end in L? trim off if so ! 16 base ! dotted-number? ; ! number?-chain chain-add 0x-number? \ ------------------------ Windows Constant Server ---------------------------- *************** *** 200,206 **** 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 --- 168,172 ---- *************** *** 209,216 **** ; ! : 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' --- 175,181 ---- ; ! : wincon-number? ( a1 n1 -- d ) \ find constant ! localbuff dup>r place r@ ?uppercase \ uppercase a copy ! wincon-call 0= if \ find constant drop \ drop returned value s" A" r@ +place \ append an 'A' *************** *** 220,257 **** ; - \ ------------------- 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 -------------------------------------- --- 185,189 ---- *************** *** 260,264 **** ' 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= --- 192,196 ---- ' 2drop is discard-number \ for doubles; see float.f for floats ! : number? ( addr len -- d f ) \ to support >float; should be done in decimal num-init ['] dotted-number? catch 0= *************** *** 316,317 **** --- 248,294 ---- + + (( unused so far + \ ------------------- 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 ip-number? \ dotted IP notation + )) + + (( unused so far + \ -------------------------- xH hex number ------------------------------------ + + : hex-tonum ( addr len base -- d1 ) + 16 base ! dotted-number? ; + + : hex-number? ( addr len -- d1 ) \ xxxxH type numbers + -ifzerothrow \ throw if too short + lastchar [char] H <> throw \ end in H? + 1- hex-tonum \ trim off, convert + ; + + number?-chain chain-add hex-number? + )) + + Index: xfiledlg.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/xfiledlg.f,v retrieving revision 1.1 retrieving revision 1.2 diff -C2 -d -r1.1 -r1.2 *** xfiledlg.f 3 May 2007 09:10:51 -0000 1.1 --- xfiledlg.f 17 Aug 2007 02:57:20 -0000 1.2 *************** *** 158,165 **** \ August 31st, 2003 - 12:58 dbu (SF-ID 745382) :M SetDir: ( a1 n1 -- ) \ set the dialog directory string max-handle 2 - min szDir place \ lay in the directory szDir +NULL \ null terminate - \ szDir count upper \ make path uppercase - dbu - szDir ?-\ \ remove trailing \ ;M --- 158,164 ---- \ August 31st, 2003 - 12:58 dbu (SF-ID 745382) :M SetDir: ( a1 n1 -- ) \ set the dialog directory string + '\' -trailchars max-handle 2 - min szDir place \ lay in the directory szDir +NULL \ null terminate ;M Index: Class.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/Class.f,v retrieving revision 1.13 retrieving revision 1.14 diff -C2 -d -r1.13 -r1.14 *** Class.f 12 Jul 2007 21:00:18 -0000 1.13 --- Class.f 17 Aug 2007 02:57:20 -0000 1.14 *************** *** 83,87 **** : ?isSel ( str -- str f1 ) \ f1 = true if it's a selector ! dup ':' endchar? ; \ ends in ':' : >selector ( str -- SelID ) \ get a selector from the input stream --- 83,87 ---- : ?isSel ( str -- str f1 ) \ f1 = true if it's a selector ! dup lastchar ':' = ; \ ends in ':' : >selector ( str -- SelID ) \ get a selector from the input stream Index: paths.f =================================================================== RCS file: /cvsroot/win32forth/win32forth-stc/src/paths.f,v retrieving revision 1.8 retrieving revision 1.9 diff -C2 -d -r1.8 -r1.9 *** paths.f 6 Jul 2007 09:06:39 -0000 1.8 --- paths.f 17 Aug 2007 02:57:20 -0000 1.9 *************** *** 60,95 **** 2dup "minus-ext" nip /string ; ! : "TO-PATHEND" ( a1 n1 --- a2 n2 ) \ *G return a2 and count=n1 of filename 2dup \ save originals ! MAX_PATH LOCALALLOC ascii-z dup \ make zstring on the stack call PathFindFileName \ find the file part swap - /string \ remove the chars from caller ; ! ! : endchar? ( a1 char -- flag ) ! \ *G check the end character in a c-string ! swap dup c@ + c@ = ; ! ! : ?-\ ( a1 -- ) ! \ *G delete trailing '\' if present ! dup [char] \ endchar? \ end in '\'? ! if -1 swap c+! \ if so, delete it ! else drop \ else discard a1 ! then ; : ?+\ ( a1 -- ) \ *G append a '\' if not already present ! dup [char] \ endchar? \ end in '\'? ! if drop \ discard a1 ! else s" \" rot +place \ if not, append \ ! then ; : ?+; ( a1 -- ) \ *G append a ';' if not already present ! dup [char] ; endchar? \ end in ';'? ! if drop \ discard a1 ! else s" ;" rot +place \ if not, append ; ! then ; \ ------------------------------------------------------------------------ --- 60,81 ---- 2dup "minus-ext" nip /string ; ! : "to-pathend" ( a1 n1 --- a2 n2 ) \ *G return a2 and count=n1 of filename 2dup \ save originals ! max_path localalloc ascii-z dup \ make zstring on the stack call PathFindFileName \ find the file part swap - /string \ remove the chars from caller ; ! ! : ?c+place ( addr char -- ) \ append char if not present ! over lastchar over <> if swap c+place else 2drop then ; : ?+\ ( a1 -- ) \ *G append a '\' if not already present ! '\' ?c+place ; : ?+; ( a1 -- ) \ *G append a ';' if not already present ! ';' ?c+place ; \ ------------------------------------------------------------------------ |
