rpiboot.fs (10707B) - raw
1 code : pushret, ] code pushret, ] ; 2 code noop exit, 3 code dup dup, exit, 4 : swap, PSP) @!, ; code swap swap, exit, 5 : nip, 4 ps+, ; code nip nip, exit, 6 : drop, PSP) @, nip, ; code drop drop, exit, 7 : 2drop, PSP) 4 +) @, 8 ps+, ; code 2drop 2drop, exit, 8 : rot, PSP) @!, PSP) 4 +) @!, ; code rot rot, exit, 9 code rot> PSP) 4 +) @!, PSP) @!, exit, 10 : over, dup, PSP) 4 +) @, ; code over over, exit, 11 code tuck swap, over, exit, 12 code 2dup -8 ps+, PSP) 4 +) !, PSP) 8 +) @, PSP) !, PSP) 4 +) @, exit, 13 14 code @ W) @, exit, 15 code16b HERE @ W) 16b) @, exit, 16 code8b HERE @ W) 8b) @, exit, 17 code c@ branch, drop 18 code w@ branch, drop 19 20 code ! W>A, PSP) @, A) !, 2drop, exit, 21 code16b HERE @ W>A, PSP) @, A) 16b) !, 2drop, exit, 22 code8b HERE @ W>A, PSP) @, A) 8b) !, 2drop, exit, 23 code c! branch, drop 24 code w! branch, drop 25 26 code +! W>A, drop, A) +, A) !, drop, exit, 27 code16b W>A, drop, A) 16b) +, A) 16b) !, drop, exit, 28 code8b W>A, drop, A) 8b) +, A) 8b) !, drop, exit, 29 code 1+! 1 W) [+n], drop, exit, 30 code16b 1 W) 16b) [+n], drop, exit, 31 code8b 1 W) 8b) [+n], drop, exit, 32 code 1-! -1 W) [+n], drop, exit, 33 code16b -1 W) 16b) [+n], drop, exit, 34 code8b -1 W) 8b) [+n], drop, exit, 35 code @! W>A, drop, A) @!, exit, 36 code16b W>A, drop, A) 16b) @!, exit, 37 code8b W>A, drop, A) 8b) @!, exit, 38 code @+ W>A, A) @, W<>A, 4 W+n, dup, W<>A, exit, 39 code16b W>A, A) 16b) @, W<>A, 2 W+n, dup, W<>A, exit, 40 code8b HERE @ W>A, A) 8b) @, W<>A, 1 W+n, dup, W<>A, exit, 41 code c@+ branch, drop 42 43 code !+ W>A, drop, A) !, W<>A, 4 W+n, exit, 44 code16b W>A, drop, A) 16b) !, W<>A, 2 W+n, exit, 45 code8b HERE @ W>A, drop, A) 8b) !, W<>A, 1 W+n, exit, 46 code c!+ branch, drop 47 48 code @@+ W>A, A) [@], 4 A) [+n], exit, 49 code16b W>A, A) 16b) [@], 2 A) [+n], exit, 50 code8b W>A, A) 8b) [@], 1 A) [+n], exit, 51 code @!+ W>A, drop, A) [!], 4 A) [+n], drop, exit, 52 code16b W>A, drop, A) 16b) [!], 2 A) [+n], drop, exit, 53 code8b W>A, drop, A) 8b) [!], 1 A) [+n], drop, exit, 54 55 code + PSP) +, nip, exit, 56 code - -W, PSP) +, nip, exit, 57 : -^ swap - ; 58 : e>w 4 + ; 59 : e>wlen 5 - ; 60 : w>e 4 - ; 61 : current sysdict @ e>w ; 62 code 1+ 1 W+n, exit, 63 code 1- -1 W+n, exit, 64 : immediate sysdict @ e>wlen dup c@ $80 or swap c! ; 65 : EMETA_16B $11 ; : EMETA_8B $10 ; 66 : 16b EMETA_16B MOD ! ; immediate 67 : 8b EMETA_8B MOD ! ; immediate 68 : :8b code8b ] ; 69 : :16b code16b ] ; 70 71 : , HERE @!+ ; :16b HERE 16b @!+ ; :8b HERE 8b @!+ ; : c, 8b , ; 72 73 code execute W>A, drop, branchA, 74 code not W=0>Z, Z) C>W, exit, 75 code bool W=0>Z, NZ) C>W, exit, 76 : if W>A, drop, A=0>Z, 0 Z) branchC, ; immediate 77 : ahead 0 branch, ; immediate 78 : then HERE @ swap branch! ; immediate 79 code ?dup W=0>Z, 0 Z) branchC, dup, then exit, 80 : ' word sysdict @ find dup not if (wnf) then ; 81 : ['] ' litn ; immediate 82 : compile ' litn ['] execute, execute, ; immediate 83 : [compile] ' execute, ; immediate 84 : allot HERE +! ; 85 : else [compile] ahead HERE @ rot branch! ; immediate 86 : begin HERE @ ; immediate 87 : again branch, drop ; immediate 88 : until W>A, drop, A=0>Z, Z) branchC, drop ; immediate 89 : _ code PSP) compare, C>W, nip, exit, ; 90 Z) _ = NZ) _ <> >) _ < <) _ > >=) _ <= <=) _ >= 91 92 : \ begin in< $20 < until ; immediate 93 \ hello, this is a comment! 94 : exit popret, exit, ; immediate 95 : ( begin 96 word dup c@ 1 = if 97 1+ c@ ')' = if exit then else drop then 98 again ; immediate 99 ( hello, another comment! ) 100 101 \ Arithmetic 102 : 0>= $80000000 < ; 103 : 0< 0>= not ; 104 : / /mod nip ; 105 : mod /mod drop ; 106 : ?swap ( n n -- l h ) 2dup > if swap then ; 107 : min ?swap drop ; : max ?swap nip ; 108 : max0 ( n -- n ) dup 0< if drop 0 then ; 109 : =><= ( n l h -- f ) over - rot> ( h n l ) - >= ; 110 code neg -W, exit, 111 : ^ -1 xor ; 112 : and? bool swap bool and ; 113 : or? or bool ; 114 : upcase ( c -- c ) dup 'a' - 26 < if $df and then ; 115 116 \ Stack 117 : rdrop 4 rs+, ; immediate 118 : 2rdrop 8 rs+, ; immediate 119 : r! -4 rs+, RSP) !, ; immediate 120 : r@ dup, RSP) @, ; immediate 121 : r> [compile] r@ [compile] rdrop ; immediate 122 : >r [compile] r! drop, ; immediate 123 code scnt pushret, dup, PSP) addr, ] PSTOP -^ >> >> 1- ; 124 code rcnt pushret, dup, RSP) addr, ] RSTOP -^ >> >> ; 125 126 : while [compile] if swap ; immediate 127 : repeat [compile] again [compile] then ; immediate 128 129 : case ( -- then-stopgap ) 0 [compile] >r ; immediate 130 : of ( -- jump-addr ) [compile] r@ word compword [compile] if ; immediate 131 : endof [compile] else ; immediate 132 : endcase ( then-stopgap jump1? jump2? ... jumpn? -- ) 133 ?dup if begin [compile] then ?dup not until then [compile] rdrop ; immediate 134 135 \ Local variables + beginning of compiling words 136 code (cell) pushret, r> popret, exit, 137 : create code pushret, compile (cell) ; 138 : const code litn exit, ; 139 4 const CELLSZ 140 141 \ execword param: addr 142 \ compileword param: HAL operand 143 create toptr 0 , \ pointer to 8b struct [execword, compileword] 144 : _@, ( operand -- ) dup, @, ; :16b dup, 16b) @, ; :8b dup, 8b) @, ; 145 create toptrdef ' @ , ' _@, , 146 : toptr@ ( -- w ) 147 0 toptr @! ?dup not if toptrdef then 148 compiling if CELLSZ + then @ findmod ; 149 : var, ( off -- ) RSP) swap [rcnt] @ neg CELLSZ - -^ +) toptr@ execute ; 150 : V1 0 var, ; immediate : V2 4 var, ; immediate 151 : V3 8 var, ; immediate : V4 12 var, ; immediate 152 153 \ Compiling words 154 create _ 0 , 155 code (does) pushret, r> W>A, W) @, W<>A, CELLSZ W+n, branchA, 156 : doer code pushret, compile (does) HERE @ _ ! CELLSZ allot ; 157 : does> r> ( exit current definition ) _ @ ! ; 158 : does' ( w -- 'data ) DOESSZ + ; 159 160 : _to doer ' , ' , immediate does> toptr ! ; 161 : _!, !, drop, ; :16b 16b) !, drop, ; :8b 8b) !, drop, ; 162 _to to ! _!, 163 : _+!, dup +, _!, ; :16b dup 16b) +, 16b _!, ; :8b dup 8b) +, 8b _!, ; 164 _to to+ +! _+!, 165 : _1+!, 1 swap [+n], ; :16b 1 swap 16b) [+n], ; :8b 1 swap 8b) [+n], ; 166 _to to1+ 1+! _1+!, 167 : _1-!, -1 swap [+n], ; :16b -1 swap 16b) [+n], ; :8b -1 swap 8b) [+n], ; 168 _to to1- 1-! _1-!, 169 _to to@! @! @!, 170 : _@@+, dup, dup [@], 4 swap [+n], ; 171 :16b dup, dup 16b) [@], 2 swap [+n], ; 172 :8b dup, dup 8b) [@], 1 swap [+n], ; 173 _to to@+ @@+ _@@+, 174 : _@!+, dup [!], 4 swap [+n], drop, ; 175 :16b dup 16b) [!], 2 swap [+n], drop, ; 176 :8b dup 8b) [!], 1 swap [+n], drop, ; 177 _to to!+ @!+ _@!+, 178 : _addr, dup, addr, ; :16b dup, addr, ; :8b dup, addr, ; 179 _to to' noop _addr, 180 : _toexec ( a -- ) compiling if m) then toptr@ execute ; 181 : value doer , immediate does> _toexec ; 182 : here HERE _toexec ; immediate 183 : alias ' code branch, drop ; 184 185 alias @ llnext 186 : llend ( ll -- lastll ) begin dup llnext ?dup while nip repeat ( ll ) ; 187 : llappend ( elem ll -- ) llend ! ; 188 : lladd ( ll -- newll ) here swap llappend here 0 , ; 189 190 \ Entry metadata 191 : &+ ( n -- ) code W+n, exit, ; 192 : &+@ ( n -- ) code W+n, W) @, exit, ; 193 -4 &+@ emeta 194 -4 &+ 'emeta 195 : metaadd ( id entry -- ) 'emeta lladd drop , ; 196 197 : realias ( 'new 'tgt -- ) to@! here swap branch, drop to here ; 198 : :realias ' sysdict curword entry here swap realias pushret, ] ; 199 : _ ( w -- w-or-0 ) dup ['] noop = if drop 0 then ; 200 : chain ( w1 w2 -- w ) 201 _ swap _ tuck over and? if 202 here rot execute, swap branch, drop else ?swap nip then ; 203 alias noop idle 204 205 alias execute | immediate 206 : bi dup, ['] swap, ; immediate 207 : bi+ dup, ['] over, ; immediate 208 : tri dup, ['] rot, ['] over, ; immediate 209 : _ [compile] r> ; 210 : dip [compile] >r ['] _ ; immediate 211 212 \ Iteration 213 : xtcomp [compile] ] begin word runword compiling not until ; 214 : ivar, ( off -- ) RSP) swap +) toptr@ execute ; 215 : i 4 ivar, ; immediate : j 8 ivar, ; immediate : k 12 ivar, ; immediate 216 : :iterator doer immediate xtcomp does> ( w -- yieldjmp loopaddr ) 217 -16 rs+, RSP) !, LIT>W, RSP) @!, 218 [compile] ahead \ jump to yield 219 [compile] begin ( loop ) ; 220 0 value _breaklbl 221 : next ( yieldjmp loopaddr -- ) 222 swap [compile] then [compile] yield [compile] again 223 12 rs+, 4 [rcnt] +! 0 to@! _breaklbl ?dup drop ; immediate 224 : unyield BRSZ RSP) [+n], ; immediate 225 : break 16 rs+, [compile] ahead to _breaklbl ; immediate 226 227 :iterator for ( n -- ) [ 228 1 W+n, RSP) 4 +) !, drop, ahead 229 begin yield swap then -1 RSP) 4 +) [+n], NZ) branchC, drop 230 unyield popret, exit, 231 232 :iterator for2 ( lo hi -- ) 233 to j to i i j < if begin yield to1+ i i j >= until then unyield ; 234 235 code fill ( a u c -- ) 236 W>A, PSP) 4 +) @, W<>A, 1 PSP) [+n], begin \ A=a W=c P+0=u+1 237 -1 PSP) [+n], 0 NZ) branchC, 8 ps+, drop, exit, then 238 A) 8b) !, 1 A+n, branch, drop 239 240 : allot0 ( n -- ) here over 0 fill allot ; 241 : nc, ( n -- ) for word runword c, next ; 242 243 code [c]? ( c a u -- i ) 244 W=0>Z, 0 Z) branchC, 245 PSP) @!, W>A, 0 LIT>W, dup, begin \ P+8=c P+4=u P+0=i A=a 246 A) 8b) @, PSP) 8 +) 8b) compare, 0 NZ) branchC, drop, 8 ps+, exit, then 247 1 A+n, 1 PSP) [+n], PSP) @, PSP) 4 +) compare, NZ) branchC, drop 248 drop, then 249 8 ps+, -1 LIT>W, exit, 250 251 \ For RPI model 1 252 $20000000 const MMIO_BASE 253 MMIO_BASE $200000 + const GPIO_BASE 254 GPIO_BASE $94 + const GPPUD 255 GPIO_BASE $98 + const GPPUDCLK0 256 GPIO_BASE $1000 + const UART0_BASE 257 UART0_BASE const UART0_DR 258 UART0_BASE $18 + const UART0_FR 259 UART0_BASE $24 + const UART0_IBRD 260 UART0_BASE $28 + const UART0_FBRD 261 UART0_BASE $2c + const UART0_LCRH 262 UART0_BASE $30 + const UART0_CR 263 UART0_BASE $38 + const UART0_IMSC 264 UART0_BASE $44 + const UART0_ICR 265 266 : delay ( n -- ) begin 1- ?dup not until ; 267 : uartinit 268 0 UART0_CR ! \ Disable UART0 269 0 GPPUD ! 100 delay \ Disable pull up/down for all GPIO pins 270 $c000 GPPUDCLK0 ! 100 delay \ Disable pull up/down for pins 14,15 271 \ Write 0 to GPPUD and GPPUDCLK0 to make it take effect. 272 0 GPPUD ! 0 GPPUDCLK0 ! 273 $7ff UART0_ICR ! \ Clear pending interrupts. 274 \ Set integer & fractional part of baud rate. 275 \ UART_CLOCK on rpi1 is 48Mhz 276 \ Divider = UART_CLOCK/(16 * Baud) 277 \ Fraction part register = 64th of the unit 278 \ Baud = 115200. 279 \ Divider = 48000000 / (16 * 115200) = 26.042 280 26 UART0_IBRD ! 281 3 UART0_FBRD ! 282 $70 UART0_LCRH ! \ Enable FIFO & 8N1 283 $7f2 UART0_IMSC ! \ Mask all interrupts 284 $301 UART0_CR ! ; \ Enable UART0, receive & transfer part of UART. 285 286 : emit begin UART0_FR @ $20 and not until UART0_DR ! ; 287 : key begin UART0_FR @ $10 and not until UART0_DR c@ ; 288 289 \ Emitting 290 $20 const SPC $0d const CR $0a const LF $08 const BS $1b const ESC 291 \ alias drop emit 292 : nl> LF emit ; : spc> SPC emit ; 293 :realias rtype ( a u ) for c@+ emit next drop ; 294 : stype ( str -- ) c@+ rtype ; 295 create _escapes 3 nc, 'n' 'r' '0' 296 create _repl 3 nc, LF CR 0 297 : "< ( -- c ) 298 in< dup '"' = if drop -1 else dup '\' = if 299 drop in< dup _escapes 3 [c]? dup 0>= if nip _repl + c@ else drop then 300 then then ; 301 : ," begin "< dup -1 <> while c, repeat drop ; 302 : ,[ [compile] ahead here [compile] [ ; immediate 303 : ], ( jmp a -- ) here over - rot 0 align4 [compile] then swap litn litn ] ; 304 : S" 305 compiling if [compile] ahead then 306 here 1 allot here ," here -^ ( a len ) over c! 307 compiling if swap 0 align4 [compile] then litn then ; immediate 308 : ." 309 compiling if [compile] S" compile stype else 310 begin "< dup 0>= while emit repeat drop then ; immediate 311 312 : foo ." foo!" ; 313 : bar ." bar!" ; 314 : prompt ." Hello World!" ; 315 uartinit prompt ' key ' in< realias