aarch64-forth/program.fs at main · mental32/aarch64-forth · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
\ Core primitives implemented in Forth
include prelude.fth
include kernel.fth
include read-line.fth

: init-dict  ( -- )
  &bss_end &dict_here !
  0 &state ! ;

: prompt  79 emit 75 emit 62 emit 32 emit ;  \ emit "ok> " directly

: dump-dict  ( -- )
  &latest @
  begin
    dup 0<> while
      dup 8 + c@ emit          \ emit name length for trace
      dup 10 + c@ emit         \ emit first char of name
      dup @                    \ follow link
    repeat
  drop ;

\ Token classification helpers
: char-token=  ( addr len ch -- flag )
  >r
  dup 1 = IF
    drop
    c@ r> =
  ELSE
    drop drop
    r> drop
    FALSE
  THEN ;

: is-colon-token      ( addr len -- flag )
  58 char-token= ;
: is-semicolon-token  ( addr len -- flag )
  59 char-token= ;

\ Core interpreter/compiler actions
: interpret-token  ( addr len -- )
  \ Use find-name's flag semantics:
  \   0  -> not found
  \  -1  -> found, normal word
  \   1  -> found, immediate word
  2dup find-name              \ addr len xt flag
  dup IF                      \ non-zero => found
    drop                      \ drop flag, keep xt
    >r 2drop r> execute
  ELSE
    drop                      \ drop flag
    drop                      \ drop xt
    \ try to parse as number
    2dup parse-num IF
      >r drop drop r>
    ELSE
      drop drop drop
      ." ?"
    THEN
  THEN ;

: compile-token  ( addr len -- )
  2dup find-name              \ addr len xt flag
  dup IF                      \ non-zero => found
    >r                        \ R: flag
    >r                        \ R: xt flag
    drop drop                 \ drop addr len
    r>                        \ xt
    r>                        \ flag
    0< IF                     \ normal word: compile XT
      ,
    ELSE                      \ immediate word: execute at compile time
      execute
    THEN
  ELSE
    drop                      \ flag
    drop                      \ xt
    drop drop                 \ addr len
    ." ?"
  THEN ;

: start-colon  ( -- )
  next-token IF               \ addr len
    start-header              \ hdr
    dup &latest ! drop        \ latest = hdr
    &forth_docol ,                  \ CFA: colon entry code
    TRUE &state !
  ELSE
    drop drop
    ." : name missing" cr
  THEN ;

: end-colon  ( -- )
  &xt_forth_exit ,                  \ ensure colon definition returns
  0 &state ! ;

: handle-token  ( addr len -- )
  2dup is-colon-token IF
    drop drop
    &state @ 0= IF
      start-colon
    ELSE
      ." nested : not allowed" cr
    THEN
  ELSE
    2dup is-semicolon-token IF
      drop drop
      &state @ 0<> IF
        end-colon
      ELSE
        ." ; without matching :" cr
      THEN
    ELSE
      &state @ 0= IF
        interpret-token
      ELSE
        compile-token
      THEN
    THEN
  THEN ;

: interpret  ( -- )
  ;

: boot  ( -- )
  init-dict
  bye ;