diff --git a/asm/forth-dictionary.s b/asm/forth-dictionary.s index 4ea0a11..073e56c 100644 --- a/asm/forth-dictionary.s +++ b/asm/forth-dictionary.s @@ -1308,25 +1308,6 @@ dword COMPILECOMMA,"COMPILE,",F_IMMED bra COMMA::code eword -; H: Compilation: ( n -- ) -; H: Execution: ( -- n ) -dword LITERAL,"LITERAL",F_IMMED - jsr _1parm - .if no_fast_lits - ldy #.loword(_LIT) - lda #.hiword(_LIT) - jsr _ccellay ; compile _LIT - bra COMMA::code ; compile actual number - .else - lda STACKBASE+2,x - beq COMMA::code ; compile fast literal - ldy #.loword(_LIT) - lda #.hiword(_LIT) - jsr _ccellay ; compile _LIT - bra COMMA::code ; compile actual number - .endif -eword - ; H: ( char -- ) Compile char into dictionary. dword CCOMMA,"C," jsr _popay @@ -1348,6 +1329,44 @@ dword LCOMMA,"L," bra COMMA::code eword +; H: Compilation: ( n -- ) +; H: Execution: ( -- n ) +dword LITERAL,"LITERAL",F_IMMED + jsr _1parm + .if no_fast_lits + ldy #.loword(_LIT) + lda #.hiword(_LIT) + jsr _ccellay ; compile _LIT + bra COMMA::code ; compile actual number + .else + lda STACKBASE+2,x + beq COMMA::code ; compile fast literal + ldy #.loword(_LIT) + lda #.hiword(_LIT) + jsr _ccellay ; compile _LIT + bra COMMA::code ; compile actual number + .endif +eword + +dword TWOLITERAL,"2LITERAL",F_IMMED + ENTER +do2lit: .dword SWAP + .dword LITERAL + .dword LITERAL + EXIT +eword + +; do LITERAL or 2LITERAL +hword XLITERAL,"XLITERAL" + ENTER + .dword TWO + .dword EQUAL + .dword _IFFALSE + .dword TWOLITERAL::do2lit ; true branch + .dword LITERAL + EXIT +eword + ; H: ( u -- u ) Align u (no-op in this implementation). dword ALIGN,"ALIGN" NEXT @@ -4585,8 +4604,7 @@ dword GNUMBER,">NUMBER" stz XR+2 digit: lda XR ; see if no more chars left beq done - ldy XR+2 - lda [WR],y + lda [WR] and #$FF ; enforce char from 16-bit load cmp #'.' ; IEEE 1275-1994 requires these to be ignored beq ignore ; when embedded in the number @@ -4612,7 +4630,8 @@ digit: lda XR ; see if no more chars left jsr _pushay ; ( -- n ud1h*basel ud1l base ) jsr _umult ; ( -- n ud1h*basel ud1l*basel ud1l*baseh ) jsr _dplus ; ( -- ud2 ) -next: dec XR +next: jsr _incwr + dec XR inc XR+2 bra digit done: ldy WR @@ -6604,8 +6623,8 @@ bad: sty STACKBASE+0,x NEXT eword -; H: ( addr len -- true | n false ) Attmept to convert string to number. -dword dNUMBER,"$NUMBER" +; H: ( addr len -- 0 | n 1 | d 2 ) Attmept to convert string to number. +hword dgNUM,"$>NUM" ENTER .dword OVER .dword CFETCH @@ -6624,17 +6643,42 @@ dword dNUMBER,"$NUMBER" .dword StoD ; ( 0 -- ud ) .dword TWORtoP ; ( ud -- ud c-addr u ) .dword GNUMBER ; ( ud c-addr u -- ud' c-addr' u' ) u' = 0 if no unconverted - .dword _IF ; ( ud' c-addr' u' -- ud' c-addr' ) - .dword okay - .dword THREEDROP ; ( ud' c-addr' -- ) + .dword QDUP ; ( ud' c-addr' u' -- ud' c-addr' u' | ud' c-addr' u' u' ) + .dword _IF + .dword okay ; branch taken: ( ... ud c-addr' ) + .dword ONE ; ( ud' c-addr' u' - ud' c-addr' u' 1 ) + .dword EQUAL ; ( ud' c-addr' u' 1 -- ud' c-addr' f ) + .dword _IF ; ( ud' c-addr' f -- ud' c-addr' ) + .dword notok + .dword CFETCH ; ( ud' c-addr' -- ud' c ) + ONLIT '.' ; ( ud' c -- ud' c '.' ) + .dword EQUAL ; ( ud' c '.' -- ud' f ) + .dword _IFFALSE ; ( ud' f -- ud' ) + .dword dokay ; if true + .dword ZERO ; ( ud' -- ud' 0 ) p/h for THREEDROP +notok: .dword THREEDROP ; ( ud' c-addr' -- ) .dword RDROP ; lose negative - .dword TRUE ; ( -- tf ) + .dword ZERO ; ( -- 0 ) EXIT okay: .dword DROP ; ( ud' c-addr' -- ud' ) .dword DtoS ; ( ud' -- n ) .dword RtoP .dword QNEGATE - .dword FALSE ; ( n -- n ff ) + .dword ONE ; ( n -- n 1 ) + EXIT +dokay: .dword RtoP ; ( ud' -- ud' f ) + .dword _IF ; ( ud' f -- ud' ) + .dword :+ + .dword DNEGATE ; ( ud' -- d ) +: .dword TWO ; ( d -- d 2 ) + EXIT +eword + +; H: ( addr len -- true | n false ) Attmept to convert string to number. +dword dNUMBER,"$NUMBER" + ENTER + .dword dgNUM + .dword ZEROQ EXIT eword @@ -6668,20 +6712,25 @@ chkimm: .dword IMMEDQ ; compiling, immediate? (leaves xt on stack) exec: .dword EXECUTE JUMP loop trynum: .dword TWODUP ; ( c-addr u -- c-addr u c-addr u ) - .dword dNUMBER ; ( c-addr u c-addr u -- c-addr u num false | c-addr u true ) - .dword _IF - .dword goodnum ; false = good number + .dword dgNUM ; ( c-addr u c-addr u -- c-addr u 0 | c-addr u n 1 | c-addr u d 2 ) + .dword QDUP + .dword _IFFALSE + .dword isnum ; nonzero = is number .dword SPACE .dword TYPE ONLIT '?' .dword EMIT - NLIT -13 + ONLIT -13 .dword THROW -goodnum: .dword NIPTWO +isnum: .dword XNPtoR + .dword NIPTWO + .dword XNRtoP .dword _SMART - .dword loop ; if interpreting - .dword LITERAL - JUMP loop + .dword inum + .dword XLITERAL + .dword _SKIP +inum: .dword DROP + JUMP loop conly: .dword _SMART .dword trytemp ; if interpreting, try temporary def JUMP chkimm ; otherwise check immediacy @@ -6689,7 +6738,7 @@ trytemp: .dword TEMPDQ ; has flag for starting temp def .dword _IFFALSE .dword dotemp ; true, so start temporary def .dword DROP ; otherwise bad state, drop XT - NLIT -14 ; and throw exception + ONLIT -14 ; and throw exception .dword THROW null: .dword DROP done: EXIT @@ -6782,20 +6831,23 @@ dword EVAL,"EVAL" bra EVALUATE::code eword -; ( [number< >] n ) Parse number, compile as literal if compiling. +; ( [number< >] n ) Parse number in input stream, compile as literal if compiling. hword nNUM,"#NUM" ENTER .dword PARSE_WORD .dword DUP .dword _IF .dword empty - .dword dNUMBER - .dword _IFFALSE + .dword dgNUM + .dword DUP + .dword _IF .dword bad .dword _SMART .dword interp - .dword LITERAL -interp: EXIT + .dword XLITERAL + .dword _SKIP +interp: .dword DROP + EXIT empty: .dword TWODROP bad: ONLIT -24 .dword THROW diff --git a/test/7.3.4.fs b/test/7.3.4.fs index 65991a9..fd6e721 100644 --- a/test/7.3.4.fs +++ b/test/7.3.4.fs @@ -1,5 +1,7 @@ testing 7.3.4.1 Text input +hex +\ test comment words t{ 1 -> 1 }t ( t{ 1 -> 2 }t ) t{ 2 -> 2 }t t{ 1 -> 1 }t \ t{ 1 -> 2 }t @@ -9,10 +11,28 @@ t{ parse-word test swap 0> -> 4 true }t t{ source 0> swap 0> -> true true }t t{ bl word test count swap 0> -> 4 true }t +\ IEEE 1275-1994 number input + +\ first make sure >number (ANS word) works +t{ 0 s>d s" 123" >number nip -> 123 0 0 }t +t{ 0 s>d s" 123?456" >number nip -> 123 0 4 }t + +t{ 1,234,567 -> 1234567 }t +t{ 1.234.567 -> 1234567 }t +t{ 1234567. -> 1234567 s>d }t +t{ -1234567. -> -1234567 s>d }t + +\ Things that should fail +t{ s" 123," ' eval catch >r clear r> -> -d }t +t{ s" ,123" ' eval catch >r clear r> -> -d }t +t{ s" .123" ' eval catch >r clear r> -> -d }t + testing 7.3.4.2 Console input \ covers: \ t{ \ -> supercalafrag }t \ since 't{' is a nop this should be fine + +\ hard to test stuff t{ ' key? 0= -> false }t t{ ' key 0= -> false }t t{ ' expect 0= -> false }t