Miscellany

256 constant input-buffer-size
assemble-start

\ word structure: (xt is address of type flag)
\   pointer to previous word or 0 for first word
\   counted-string name
\   type flag
\   primitive-byte or program

\ type:
\   1: immediate
\   2: not immediate
\   3: not immediate, xt is a primitive

:program-name
    .s' Virtual Forth 0.1'

:input-buffer
    .dw 0
\    .org [ data-index input-buffer-size + ]

:>in
    .db 0

:input-count
    .db 0

:in-index
    .dw 0

:immediate-flag
    .dw -1

:state
    .dw :count
    .s' state'
    .db 2
:state-code
    lit :immediate-flag ret

:+
    .dw 0
    .s' +'
    .db 3 +

:count ( c-addr1 -- c-addr2 u )
    .dw :+
    .s' count'
    .db 2
:count-code
    dup c@ swap 1+ swap ret

:min ( n1 n2 -- n3 )
    .dw :count
    .s' min'
    .db 2
:min-code
    over over
    > jz :min-less
    swap drop
    ret
:min-less
    drop ret

:compare-count
    .db 0
:compare-addr1
    .dw 0
:compare-count1
    .db 0
:compare-addr2
    .dw 0
:compare-count2
    .db 0
:compare ( c-addr1 u1 c-addr2 u2 -- n )
    .dw :min
    .s' compare'
    .db 2
:compare-code
    lit :compare-count2 c! lit :compare-addr2 !
    lit :compare-count1 c! lit :compare-addr1 !
    lit :compare-count1 c@ lit :compare-count2 c@ call :min-code
    lit :compare-count c!
:compare-next
    lit :compare-count c@ jnz :compare-char
:compare-length
    lit :compare-count1 c@ lit :compare-count2 c@ < jnz :compare-less
    lit :compare-count1 c@ lit :compare-count2 c@ > jnz :compare-greater
    jump :compare-equal
:compare-char
    lit :compare-addr1 @ c@ lit :compare-addr2 @ c@ < jnz :compare-less
    lit :compare-addr1 @ c@ lit :compare-addr2 @ c@ > jnz :compare-less
    lit :compare-addr1 dup @ 1+ swap !
    lit :compare-addr2 dup @ 1+ swap !
    lit :compare-count c@ 1- lit :compare-count c!
    jump :compare-next
:compare-less
    lit -1 ret
:compare-greater
    lit 1 ret
:compare-equal
    lit 0 ret

:find-word-address
    .dw :compare
:find-word-count
    .db 0
:find-word ( c-addr u -- false  |  xt true )
    .dw :compare
    .s' find-word'
    .db 2
:find-word-code
    lit :find-word-count c!
    lit :find-word-address !
    lit :last-word @
:find-word-next
    dup lit 2 + call :count-code
    lit :find-word-address @ lit :find-word-count c@ call :compare-code
    jnz :find-word-step
    lit 2 + call :count-code + lit -1 ret
:find-word-step
    @ dup jnz :find-word-next
    ret

:type ( c-addr u -- )
    .dw :find-word
    .s' type'
    .db 2
:type-code
    dup jz :type-end
    swap dup c@ emit 1+ swap 1-
    jump :type-code
:type-end
    drop
    drop
    ret

:move-count
    .dw 0
:move-addr1
    .dw 0
:move-addr2
    .dw 0
:move ( addr1 addr2 count -- )
    .dw :type
    .s' move'
    .db 2
:move-code
    lit :move-count !
    lit :move-addr2 !
    lit :move-addr1 !
:move-start
    lit :move-count @ jz :move-end
    lit :move-addr1 @ c@ lit :move-addr2 @ c!
    lit :move-addr1 dup @ 1+ swap !
    lit :move-addr2 dup @ 1+ swap !
    lit :move-count dup @ 1+ swap !
    jump :move-start
:move-end
    ret

:execute ( xt -- )
    .dw :move
    .s' execute'
    .db 2
:execute-code
    dup c@ lit 3 = jnz :execute-primitive
    1+ pop-call ret
:execute-primitive
    1+ c@ execute ret

:is-whitespace
    lit 32 =
    ret

:skip-while-whitespace
    lit :>in c@ lit :input-count c@ = jnz :skip-while-whitespace-end
    lit :>in c@ lit :input-buffer @ + c@
    call :is-whitespace jz :skip-while-whitespace-end
    lit :>in dup c@ 1+ swap c!
    jump :skip-while-whitespace
:skip-while-whitespace-end
    ret

:skip-until-whitespace
    lit :>in c@ lit :input-count c@ = jnz :skip-until-whitespace-end
    lit :>in c@ lit :input-buffer @ + c@
    call :is-whitespace jnz :skip-until-whitespace-end
    lit :>in dup c@ 1+ swap c!
    jump :skip-until-whitespace
:skip-until-whitespace-end
    ret

:parse-number-neg
    .db 0
:parse-number-result
    .dw 0
:parse-number-word
    .dw 0
:parse-number-count
    .db 0
:parse-number ( addr u -- number -1 | 0 )
    \ check for empty string
    dup jnz :parse-number-at-least-one-char
    swap drop ret
:parse-number-at-least-one-char
    \ init variables
    lit :parse-number-count c!
    lit :parse-number-word !
    lit 0 lit :parse-number-result !
    lit 0 lit :parse-number-neg c!
    \ if first character is "-", then increment pointer and set flag
    lit :parse-number-word @ c@ lit 45 = jz :parse-number-positive
    lit -1 lit :parse-number-neg c!
    lit :parse-number-count dup c@ 1- swap c!
    lit :parse-number-word dup @ 1+ swap !
:parse-number-positive
    \ check for empty string after possible "-"
    lit :parse-number-count c@ jnz :parse-number-positive2
    lit 0 ret
:parse-number-positive2
    \ shift current result
    lit :parse-number-result dup @ lit 10 * swap !
    \ check next digit
    lit :parse-number-word @ c@
    lit 48 - dup lit 0 < over lit 9 > or jz :parse-number-valid-digit
    drop lit 0 ret
:parse-number-valid-digit
    \ add digit
    lit :parse-number-result @ + lit :parse-number-result !
    \ increment pointer
    lit :parse-number-count dup c@ 1- swap c!
    lit :parse-number-word dup @ 1+ swap !
    \ test for last character
    lit :parse-number-count c@ jnz :parse-number-positive2
    \ was last character, test negate flag
    lit :parse-number-result @ lit :parse-number-neg c@ jz :parse-number-valid
    negate
:parse-number-valid
    lit -1 ret

:next-word ( -- 0 | c-addr u -1 )
    call :skip-while-whitespace
    lit :>in c@ lit :input-count c@ = jz :next-word-until-whitespace
    lit 0 ret
:next-word-until-whitespace
    lit :>in c@ dup lit :input-buffer @ + swap
    call :skip-until-whitespace
    lit :>in c@ swap - lit -1 ret

:,
    .dw :execute
    .s' ,'
    .db 2
:,-code
    here ! lit 2 allot ret

:c,
    .dw :,
    .s' c,'
    .db 2
:c,-code
    here c! lit 1 allot ret

::
    .dw :c,
    .s' :'
    .db 2
::-code
    \ store pointer to previous word and update last word pointer
    here lit :last-word @ call :,-code lit :last-word !
    \ read word name and copy it
    call :next-word jz ::-error
    dup call :c,-code swap over here swap call :move-code allot
    \ set type flag
    lit 2 call :c,-code
    \ set compile mode
    lit 0 lit :immediate-flag !
    ret
::-error
    \ TODO: handle EOF errors
    ret

:;
    .dw ::
    .s' ;'
    .db 1
:;-code
    \ finish word
    lit ret call :c,-code
    \ set immediate mode
    lit -1 lit :immediate-flag !
    ret

:evaluate-number ( n -- n | )
    lit :immediate-flag @ jz :compile-number
    ret
:compile-number
    lit lit call :c, call :,
    ret

:evaluate-word ( xt -- )
    lit :immediate-flag @ jz :compile-word
    call :execute-code
    ret
:compile-word
    dup c@ lit 1 = jz :compile-word-no-immediate
    1+ c@ pop-call ret
:compile-word-no-immediate
    dup c@ lit 2 = jz :compile-word-primtive
    lit call call :c,
    1+ call :, ret
:compile-word-primtive
    c@ call :c, ret

:evaluate ( c-addr u -- )
    .dw :;
    .s' evaluate'
    .db 2
:evaluate-code
    \ set input buffer
    lit :input-count c! lit :input-buffer ! lit 0 lit :>in c!
:evaluate-next
    \ get next word
    call :next-word jz :evaluate-end
    \ try to evaluate it as a word
    over over call :find-word-code jz :evaluate-try-number
    swap drop swap drop call :evaluate-word jump :evaluate-next
:evaluate-try-number
    \ try to evaluate it as a number
    call :parse-number jz :evaluate-error
    call :evaluate-number
:evaluate-error
    \ evaluate error: ignore
    jump :evaluate-next
:evaluate-end
    ret

:last-word
    .dw :evaluate

:data-start

.end