<< Home | About Forth | About TurboForth | Download | Language Reference | Resources | Tutorials | YouTube >>
; _____ _ __ __ _ ; | __ \ (_) \ \ / / | | ; | |__) |__ _ _ __ ___ _ _ __ __ _ \ \ /\ / /___ _ __ __| |___ ; | ___// _` | '__/ __| | '_ \ / _` | \ \/ \/ // _ \| '__/ _` / __| ; | | | (_| | | \__ \ | | | | (_| | \ /\ /| (_) | | | (_| \__ \ ; |_| \__,_|_| |___/_|_| |_|\__, | \/ \/ \___/|_| \__,_|___/ ; __/ | ; |___/ ; Dictionary lookup and associated parsing words ; WORD ( delimiter address -- address length ) ; ; Moves through TIB in VDP memory, discarding leading delimiters, ; looking for a word. A word is identified when a trailing delimiter is ; detected. The identified word is copied from VDP to a buffer in CPU memory. ; Pushes the start address of the word (in CPU memory), and the length of ; the word to the stack. If no word is found (for example if we hit the ; end of the TIB without detecting a word then 0 0 is pushed on the ; stack. _word mov *stack,r0 ; buffer address a @in,r0 ; add offset mov @2(stack),r2 ; delimeter sla r2,8 ; move to high-byte li r6,wrdbuf+1 ; address of cpu word buffer mov r6,@2(stack) ; push it to stack clr r8 ; length counter mov @_span,r7 ; number of chars in buffer jeq noword ; if 0 then there's no word c @in,@_span ; hit end of buffer? jhe noword ; if yes then exit wrd1 bl @wrdgb ; read a character and advance along input inc @in ; advance >IN cb r1,r2 ; was the character a delimiter? jeq wrd1 ; if yes then get another character c @in,@_span ; hit end of buffer? jgt wrdfin ; if yes then quit wrd2 movb r1,*r6+ ; move character to word buffer inc r8 ; increment length c r8,@tibsiz ; have we fully populated the word buffer? jeq wrdfin ; if yes then exit bl @wrdgb ; read a character and advance along input inc @in ; advance >in c @in,@_span ; hit end of buffer? jgt wrdfin ; if yes then quit cb r1,r2 ; was the character a delimeter? jne wrd2 ; if not then get another character wrdfin mov r8,*stack ; push length to stack jmp wrdxit1 ; exit noword clr *stack ; no word found, push 0 length clr @2(stack) ; zero address clr r8 wrdxit1 swpb r8 ; populate length byte (for packed string) movb r8,@wrdbuf wrdxit2 b @retB0 wrdgb mov @source,r15 ; check source jeq vread ; if 0 then read from vdp ; special case: if EVALUATE is active then the evaluation string will be in ; CPU RAM movb *r0+,r1 ; otherwise read from cpu and advance buffer rt ; return to caller vread mov r11,r14 ; save return address vread1 bl @_vsbr ; read from vdp vread2 inc r0 ; advance input buffer address b *r14 ; return to caller ; code for processing \ type comments ; assembly equivalent of : \ >IN @ 64 + -64 AND >IN ! ; IMMEDIATE _trcom mov @blknum,r0 ; loading a block? jeq trcom1 ; jump if not mov @in,r0 ai r0,64 andi r0,-64 mov r0,@in jmp wrdxit2 ; exit (jump is smaller than a branch!) trcom1 mov @tibsiz,@in ; set >IN to the end of the line comxit jmp wrdxit2 ; exit (jump is smaller than a branch!) ; NUMBER ( address length -- (numberMSW) numberLSW error ) ; Attempts to convert the string at cpu address address into a number. ; If fully successful, the number is placed on the stack and flag will be 0. ; If it fails (for example contains an illegal character) then a partial number ; will be placed on the stack (the value computed up until the failure) and ; flag will be -1. This allows neat trapping with ABORT"" ; Thus, if flag<>0 the string failed to parse fully as a number. ; A minus sign is permitted for negative numbers. ; This routine uses BASE to parse numbers in the current BASE. ; Eg. If BASE=16 then digits 0-9 and A-F are considered legal and will be ; parsed properly. ; A facility also exists called 'quick hex' that allows a number to be entered ; in base 16, by placing a $ symbol at the beginning of the string. This avoids ; the need to change BASE to enter a number. E.g. instead of HEX FEED DECIMAL ; you can simply do $FEED. The number will be parsed as a HEX number without the ; need to change BASE. ; The same facility also exists for binary numbers: use a % symbol. ; E.g. %1001 = 9 decimal ; The numbers returned are (by default) singles (16 bits). NUMBER can can also ; return a double (32-bit (2 stack cells)) value by including a period in the ; number string. E.g. 100. 1.00 10.0 .100 will all return 100 decimal as a ; double. ; The various facilities can be mixed. For example, -$.F means -15 as a double. _numbr mov *stack+,r1 ; pop length mov *stack,r0 ; get address from stack ; parse the number string... parsnm clr r6 ; initialise MSW clr r8 ; initialise LSW clr r13 ; clear negative flag clr r12 ; clear 'double required' flag seto @dpl ; assume single precision ; begin ugly hack - check the end of the number for a period character ; if found, set double indicator (R12) to on and reduce length of string ; by 1. Added for TF V1.1 double precision library support mov r0,r15 ; copy string address a r1,0 ; add length dec r0 ; point to last character in the buffer movb *r0+,r2 ; get character from buffer srl r2,8 ; move it to low byte ci r2,'.' ; is it a period character? jne xugly ; if not then skip seto r12 ; otherwise set the double flag to on dec r1 ; and reduce the length for the string so ; that the period will not be seen by the ; number parser seto @dpl ; double integer ; end ugly hack xugly mov r15,r0 mov @base,r14 ; get base dec r14 ; base-1=highest legal digital for base num0 movb *r0+,r2 ; get character from buffer srl r2,8 ; move it to low byte num4 ci r2,'%' ; is it a % sign (binary) jne num5 li r14,1 ; set binary base jmp num3 ; do next character num5 ci r2,'.' ; is it a dot? jne num1 ; skip if not ; double detected - set r12 as flag, and calculate value for DPL seto r12 ; else double is required - set flag mov @2(stack),r15 ; get string length mov r15,r7 ; s r1,r7 ; subtract current position from length s r7,r15 ; get length to the right of the dec. point dec r15 ; correcty length due to decimal point mov r15,@dpl ; store in DPL jmp num3 ; do next character num1 ci r2,'$' ; is it a dollar sign? jne num2 ; skip if not li r14,15 ; force base temporarily to 16-1 for hex jmp num3 ; check next character num2 ci r2,'-' ; is it a negative sign? jne numlz ; skip if not seto r13 ; else set negative flag num3 dec r1 ; decrement counter jmp num0 ; get next character ; digit range checks... numlz ci r2,'0' ; check if ascii code < "0" jl ohshit ; error if yes ci r2,'z' ; check if ascii code > "z" jh ohshit ; error if yes ; check if is numeric digit ci r2,'9' jle numisd ; it IS a digit ; check if is upper case digit ci r2,'A' jhe numt1 jmp ohshit numt1 ci r2,'Z' jle numisl ; ; check if is lower case digit ci r2,'a' jhe numt2 jmp ohshit numt2 ci r2,'z' jhe ohshit ai r2,-87 ; convert to number jmp numgo ; illegal digit ohshit seto r0 ; else illegal digit was detected jmp nexit ; indicate error numisl ai r2,-55 ; convert from upper case to number ; ("A" (65) becomes 10) jmp numgo ; start the conversion numisd ai r2,-48 ; convert from ascii to decimal ; ("0" (48) becomes 0) ; parse the string into a 32 bit number... numgo c r2,r14 ; compare to base jh ohshit ; if digit outside current base's legal ; range then exit a r2,r8 ; add digit to LSW dec r1 ; finished? jeq numend ; jump if yes mov r14,r2 ; base-1 to r2 inc r2 ; correct to base mov r8,r7 ; get our lsw in r7 mpy r2,r7 ; multiply it by current base