kernel.fs (5434 bytes)
1 \ kernel.fs -- the high-level half of the Forth kernel. kernel.lisp metacompiles this file 2 \ into flash: each : definition becomes a header plus a list of execution tokens. Control 3 \ words (if, begin, do, ...) and ['] [char] ." s" recurse are resolved by the metacompiler 4 \ here; the immediate words of the same names below compile code at run time on the chip. 5 \ Console protocol and word set follow Mecrisp-Stellaris, so lisp.fs loads unchanged. 6 7 : true -1 ; 8 : false 0 ; 9 : bl 32 ; 10 : here dp @ ; 11 : allot dp +! ; 12 : , here ! 4 allot ; 13 : c, here c! 1 allot ; 14 : aligned 3 + -4 and ; 15 : align here aligned dp ! ; 16 : unused dict-limit here - ; 17 : hex 16 base ! ; 18 : decimal 10 base ! ; 19 : within ( n lo hi -- f ) over - >r - r> u< ; 20 : /string ( a n k -- a+k n-k ) rot over + -rot - ; 21 22 \ ---- output ---- 23 : cr 10 emit ; 24 : space bl emit ; 25 : type ( a n -- ) 0 ?do dup c@ emit 1+ loop drop ; 26 : <# padend hld ! ; 27 : hold ( c -- ) -1 hld +! hld @ c! ; 28 : digit ( n -- c ) dup 9 > if 7 + then 48 + ; 29 : # ( lo hi -- lo' hi ) >r base @ u/mod swap digit hold r> ; 30 : #s ( lo hi -- 0 hi ) begin # over 0= until ; 31 : #> ( lo hi -- a n ) 2drop hld @ padend over - ; 32 : sign ( n -- ) 0< if 45 hold then ; 33 : u. 0 <# #s #> type space ; 34 : . dup abs 0 <# #s rot sign #> type space ; 35 : .s depth begin dup 0> while dup pick . 1- repeat drop ; 36 : words latest @ begin dup while dup 5 + count type space @ repeat drop cr ; 37 38 \ ---- input ---- 39 : accept ( addr max -- len ) >r 0 40 begin key dup 13 = over 10 = or 0= while 41 dup 8 = over 127 = or 42 if drop dup if 1- 8 emit space 8 emit then 43 else dup 9 = if drop 32 then 44 over r@ < if dup emit 2 pick 2 pick + c! 1+ else drop then 45 then 46 repeat drop rdrop nip space ; 47 : query tib 512 accept #tib ! 0 >in ! ; 48 : token ( -- addr len ) 49 tib >in @ + tib #tib @ + swap 50 begin 2dup > if dup c@ 33 < else 0 then while 1+ repeat 51 dup begin 2 pick over > if dup c@ 32 > else 0 then while 1+ repeat 52 rot over > if dup 1+ else dup then tib - >in ! over - ; 53 : parse ( c -- addr len ) >r tib >in @ + tib #tib @ + over 54 begin 2dup > if dup c@ r@ <> else 0 then while 1+ repeat rdrop 55 tuck > if dup 1+ else dup then tib - >in ! over - ; 56 57 \ ---- dictionary ---- 58 : upc ( c -- C ) dup 97 123 within if 32 - then ; 59 : name= ( a1 n1 a2 n2 -- f ) rot over <> if 2drop drop 0 exit then 60 0 ?do over i + c@ upc over i + c@ upc <> if 2drop 0 unloop exit then loop 2drop -1 ; 61 : >xt ( header -- xt ) 5 + count + aligned ; 62 : find ( addr len -- xt 1|-1 | addr len 0 ) 63 latest @ begin dup while 64 dup 4 + c@ 64 and 0= if 65 >r 2dup r@ 5 + count name= if 2drop r@ >xt r> 4 + c@ 128 and if 1 else -1 then exit then r> 66 then @ 67 repeat ; 68 : header ( addr len -- ) 2dup find if drop ." Redefine " 2dup type ." . " else 2drop then 69 align here latest @ , latest ! 0 c, dup c, here swap dup allot move align ; 70 : hide latest @ 4 + dup c@ 64 or swap c! ; 71 : reveal latest @ 4 + dup c@ 64 invert and swap c! ; 72 : immediate latest @ 4 + dup c@ 128 or swap c! ; 73 74 \ ---- numbers ---- 75 : digit? ( c -- n true | false ) upc 48 - dup 9 > if 7 - dup 10 < if drop 0 exit then then 76 dup base @ u< if -1 else drop 0 then ; 77 : number ( addr len -- n true | false ) 78 base @ >r 0 nneg ! 79 over c@ 36 = if 16 base ! 1 /string else 80 over c@ 35 = if 10 base ! 1 /string else 81 over c@ 37 = if 2 base ! 1 /string then then then 82 over c@ 45 = if -1 nneg ! 1 /string then 83 dup 0= if 2drop r> base ! 0 exit then 84 0 -rot begin dup while 85 over c@ digit? 0= if 2drop drop r> base ! 0 exit then 86 >r rot base @ * r> + -rot 1 /string 87 repeat 2drop 88 nneg @ if negate then r> base ! -1 ; 89 90 \ ---- outer interpreter ---- 91 : abort sp0 sp! quit ; 92 : notfound ( addr len -- ) space type ." not found." cr abort ; 93 : ?stack depth 0< if ." Stack underflow" cr abort then ; 94 : interpret 95 begin token dup while 96 find ?dup if 97 state @ if 0< if , else execute then else drop execute then 98 else 99 2dup number if nip nip state @ if ['] lit , , then else notfound then 100 then ?stack 101 repeat 2drop ; 102 : quit rp0 rp! 0 state ! begin query interpret ." ok." cr again ; 103 : cold cr ." lisp-forth-lisp Forth kernel for STM32F446 (own Thumb-2 build)" cr quit ; 104 105 \ ---- compiler ---- 106 : [ 0 state ! ; immediate 107 : ] -1 state ! ; 108 : : token header docol , hide ] ; 109 : ; ['] exit , reveal [ ; immediate 110 : ' token find dup 0= if drop notfound then drop ; 111 : ['] ' ['] lit , , ; immediate 112 : literal ['] lit , , ; immediate 113 : [char] token drop c@ ['] lit , , ; immediate 114 : char token drop c@ ; 115 : recurse latest @ >xt , ; immediate 116 : ( 41 parse 2drop ; immediate 117 : \ #tib @ >in ! ; immediate 118 : (s",) 34 parse ['] (s") , dup c, here swap dup allot move align ; 119 : s" state @ if (s",) else 34 parse then ; immediate \ interpreting: the string stays in the input line 120 : ." (s",) ['] type , ; immediate 121 : variable ( x "name" -- ) token header dovar , , ; 122 : constant ( x "name" -- ) token header docon , , ; 123 : buffer: ( n "name" -- ) token header dovar , allot align ; 124 : if ['] 0branch , here 0 , ; immediate 125 : then here swap ! ; immediate 126 : else ['] branch , here 0 , swap here swap ! ; immediate 127 : begin here ; immediate 128 : until ['] 0branch , , ; immediate 129 : again ['] branch , , ; immediate 130 : while ['] 0branch , here 0 , swap ; immediate 131 : repeat ['] branch , , here swap ! ; immediate 132 : do ['] (do) , here 0 , here ; immediate 133 : ?do ['] (?do) , here 0 , here ; immediate 134 : loop ['] (loop) , , here swap ! ; immediate 135 : +loop ['] (+loop) , , here swap ! ; immediate