planckforth/bootstrap.fs

1691 lines
40 KiB
Forth
Raw Normal View History

2021-01-04 14:23:54 +01:00
h@l@h@!h@C+h!k1k0-h@$k:k0-h@k1k0-+$h@C+h!ih@!h@C+h!kefh@!h@C+h!l!
2020-12-30 13:17:09 +01:00
h@l@h@!h@C+h!k1k0-h@$k h@k1k0-+$h@C+h!ih@!h@C+h!kefh@!h@C+h!l!
2020-12-30 12:09:11 +01:00
2020-12-30 16:52:36 +01:00
h@l@ h@!h@C+h! k1k0-h@$ k\h@k1k0-+$ h@C+h!
2020-12-30 14:00:20 +01:00
i h@!h@C+h!
kkf h@!h@C+h!
kLf h@!h@C+h!
k:k0- h@!h@C+h!
k=f h@!h@C+h!
kJf h@!h@C+h!
k0k5-C* h@!h@C+h!
kef h@!h@C+h!
l!
\ **Now we can use single-line comments!**
\ planckforth -
2021-01-02 05:29:46 +01:00
\ Copyright (C) 2021 nineties
2020-12-30 14:00:20 +01:00
2021-01-02 05:14:16 +01:00
\ This project aims to bootstrap a Forth interpreter
\ from hand-written tiny ELF binary.
2020-12-30 14:38:27 +01:00
\ In the 1st stage, only single character words are registered
\ in the dictionary.
\ List of builtin words:
2021-01-02 01:35:07 +01:00
\ 'Q' ( -- ) Exit the process
\ 'C' ( -- n ) The size of Cells
\ 'h' ( -- a-addr ) The address of 'here' cell
\ 'l' ( -- a-addr ) The address of 'latest' cell
\ 'k' ( -- c ) Read character
\ 't' ( c -- ) Print character
\ 'j' ( -- ) Unconditional branch
\ 'J' ( n -- ) Jump if a == 0
\ 'f' ( c -- xt ) Get execution token of c
\ 'x' ( xt -- ... ) Run the execution token
\ '@' ( a-addr -- w ) Load value from addr
\ '!' ( w a-addr -- ) Store value to addr
\ '?' ( c-addr -- c ) Load byte from addr
\ '$' ( c c-addr -- ) Store byte to addr
\ 'd' ( -- a-addr ) Get data stack pointer
\ 'D' ( a-addr -- ) Set data stack pointer
\ 'r' ( -- a-addr ) Get return stack pointer
\ 'R' ( a-addr -- ) Set return stack pointer
\ 'i' ( -- a-addr ) Get the interpreter function
\ 'e' ( -- ) Exit current function
\ 'L' ( -- u ) Load immediate
2021-01-04 14:21:48 +01:00
\ 'S' ( -- c-addr ) Load string literal
2021-01-02 01:35:07 +01:00
\ '+' ( a b -- c ) c = (a + b)
\ '-' ( a b -- c ) c = (a - b)
\ '*' ( a b -- c ) c = (a * b)
\ '/' ( a b -- c ) c = (a / b)
\ '%' ( a b -- c ) c = (a % b)
\ '&' ( a b -- c ) c = (a & b)
\ '|' ( a b -- c ) c = (a | b)
\ '^' ( a b -- c ) c = (a ^ b)
\ '<' ( a b -- c ) c = (a < b)
2021-01-02 05:14:16 +01:00
\ '=' ( a b -- c ) c = (a == b)
2020-12-30 14:38:27 +01:00
\ The 1st stage interpreter repeats execution of k, f and x.
\ There following line is an example program of planckforth
\ which prints "Hello World!\n"
\ --
\ kHtketkltkltkotk tkWtkotkrtkltkdtk!tk:k0-tQ
\ --
\ This code repeats that 'k' reads a character and 't' prints it.
\ Note that ':' (58) minus '0' (48) is '\n' (10).
2021-01-02 05:14:16 +01:00
\ The structure of the dictionary.
2020-12-30 14:38:27 +01:00
\ +------+----------+---------+------------+---------------+
\ | link | len+flag | name... | padding... | code field ...|
\ +------+----------+---------+------------+---------------+
\ - link pointer to the previous entry (CELL byte)
2021-01-01 10:37:41 +01:00
\ - length of the name (6 bits)
\ - smudge bit (1 bit)
\ - immediate bit (1 bit)
2020-12-30 14:38:27 +01:00
\ - characters of the name (N bits)
\ - padding to align CELL boundary if necessary.
\ - codewords and datawords (CELL-bye aligned)
\ The code group at the beginning of this file
\ defines ' ' and '\n' as no-op operation and
\ '\' to read following characters until '\n'.
\ Since I couldn't write a comment at the beginning,
\ I repost the definition of '\' for explanation.
\ --
\ h@ ( save addr of new entry )
\ l@ h@!h@C+h! ( set link pointer. *here++ = latest )
2020-12-30 14:41:49 +01:00
\ k1k0-h@$ k\h@k1k0-+$ h@C+h! ( write the name '\' and its length )
2020-12-30 14:38:27 +01:00
\ i h@!h@C+h! ( docol )
\ kkf h@!h@C+h! ( key )
\ kLf h@!h@C+h! ( lit )
\ k:k0- h@!h@C+h! ( '\n' )
\ k=f h@!h@C+h! ( = )
\ kJf h@!h@C+h! ( branch )
\ k0k5-C* h@!h@C+h! ( -5*CELL )
\ kef h@!h@C+h! ( exit )
\ l! ( set latest to this new entry. )
\ --
2020-12-30 14:48:07 +01:00
\ That's all for the brief explanation. Let's restart bootstrap!
2020-12-30 14:51:29 +01:00
\ The COMMA operator
\ ',' ( a -- ) Store a to 'here' and increment 'here' CELL bytes.
2020-12-30 16:52:36 +01:00
h@l@ h@!h@C+h! k1k0-h@$ k,h@k1k0-+$ h@C+h!
2020-12-30 14:51:29 +01:00
i h@!h@C+h! \ docol
2020-12-30 15:23:07 +01:00
\ store 'a' to here
2020-12-30 14:51:29 +01:00
khf h@!h@C+h!
k@f h@!h@C+h!
2020-12-30 15:23:07 +01:00
k!f h@!h@C+h!
\ here <- here + CELL
2020-12-30 14:51:29 +01:00
khf h@!h@C+h!
k@f h@!h@C+h!
kCf h@!h@C+h!
2020-12-30 15:23:07 +01:00
k+f h@!h@C+h!
2020-12-30 14:51:29 +01:00
khf h@!h@C+h!
2020-12-30 15:23:07 +01:00
k!f h@!h@C+h!
\ exit
kef h@!h@C+h!
2020-12-30 14:51:29 +01:00
l!
2020-12-30 15:42:38 +01:00
\ TICK-like operator
\ '\'' ( "c" -- xt ) Get execution token of following character
\ NB: This definition is different from the usual definition of tick
\ because it does not skip leading spaces and can read only a single
\ character. It will be redefined in later stage.
2020-12-30 16:52:36 +01:00
h@l@, k1k0-h@$ k'h@k1k0-+$ h@C+h!
2020-12-30 15:42:38 +01:00
i, kkf, kff, kef,
l!
2020-12-30 16:52:53 +01:00
\ Utility for defining a word
\ 'c' ( "c" -- w )
\ Read character, create new word then push its address.
\ 'latest' will not be updated.
h@l@, k1k0-h@$ kch@k1k0-+$ h@C+h!
i, 'h, '@, 'l, '@, ',,
'L, k1k0-, 'h, '@, '$, \ fill 1
'k, 'h, '@, 'L, k1k0-, '+, '$, \ fill "c"
'L, k0k0-, 'h, '@, 'L, k2k0-, '+, '$, \ fill "\0"
2020-12-31 00:26:06 +01:00
'h, '@, 'C, '+, 'h, '!,
'e, l!
2020-12-30 16:52:53 +01:00
2020-12-30 16:59:24 +01:00
\ '_' ( a -- ) DROP
c_ i, 'd, 'C, '+, 'D, 'e, l!
2020-12-30 22:25:40 +01:00
\ '#' ( a -- a a ) DUP
c# i, 'd, '@, 'e, l!
\ Implementations of TOR and FROMR are a bit tricky.
\ Since return-address will be placed at the top of return stack,
\ the code in the body of these function have to manipulate
\ 2nd element of the stack.
\ '{' ( a -- R:a ) TOR
\ Move value from data stack to return stack.
2020-12-31 00:26:06 +01:00
c{ i,
2020-12-30 22:25:40 +01:00
'r, 'r, '@, \ ( a rsp ret )
2020-12-30 22:36:20 +01:00
'r, 'C, '-, '#, \ ( a rsp ret rsp-1 rsp-1 )
'R, \ ( a rsp+1 ret rsp ) extend return stack
'!, \ ( a rsp+1 ) store return address to the top
2020-12-30 22:25:40 +01:00
'!, \ store a to the 2nd
2020-12-31 00:26:06 +01:00
'e, l!
2020-12-30 22:25:40 +01:00
\ '}' ( R:a -- a ) FROMR
\ Move value from return stack to data stack.
2020-12-31 00:26:06 +01:00
c} i,
2020-12-30 22:25:40 +01:00
'r, 'C, '+, '@, \ ( a ) load 2nd value
'r, '@, \ ( a ret ) load return addr
2020-12-30 22:36:20 +01:00
'r, 'C, '+, '#, \ ( a ret rsp+1 rsp+1 )
2020-12-30 22:25:40 +01:00
'R, \ ( a ret rsp ) reduce return stack
'!, \ ( a , R:ret ) store return addr to top of return stack
2020-12-31 00:26:06 +01:00
'e, l!
2020-12-30 22:25:40 +01:00
2020-12-30 22:39:43 +01:00
\ 'o' ( a b -- a b a ) OVER
co i, 'd, 'C, '+, '@, 'e, l!
2020-12-30 22:37:08 +01:00
\ '~' ( a b -- b a ) SWAP
c~ i,
2020-12-30 22:39:43 +01:00
'o, \ ( a b a )
2020-12-30 22:37:08 +01:00
'{, \ ( a b , R:a )
'd, 'C, '+, \ ( a b sp+1 , R:a )
'!, \ ( b , R:a )
'}, \ ( b a )
2020-12-31 00:26:06 +01:00
'e, l!
2020-12-30 22:37:08 +01:00
2020-12-30 23:50:02 +01:00
\ 'B' ( c -- ) C-COMMA
\ Store byte 'c' to here and increment it
2020-12-31 01:40:29 +01:00
cB i, 'h, '@, '$, 'h, '@, 'L, k1k0-, '+, 'h, '!, 'e, l!
2020-12-30 22:39:43 +01:00
2021-01-02 10:01:01 +01:00
\ 'm' ( c-addr u -- ) CMOVE,
2020-12-31 11:36:45 +01:00
\ Copy u bytes from c-addr to here,
\ increment here u bytes.
2020-12-31 05:10:18 +01:00
cm i,
\ <loop>
2020-12-31 11:36:45 +01:00
'#, 'J, k>k0-C*, \ goto <exit> if u=0
2020-12-31 05:10:18 +01:00
'{, \ preserve u
2020-12-31 11:36:45 +01:00
'#, '?, 'B, \ copy byte
'L, k1k0-, '+, \ increment c-addr
2020-12-31 05:10:18 +01:00
'}, 'L, k1k0-, '-, \ decrement u
2020-12-31 11:36:45 +01:00
'j, k0k?-C*, \ goto <loop>
2020-12-31 05:10:18 +01:00
\ <exit>
2020-12-31 11:36:45 +01:00
'_, '_,
2020-12-31 05:10:18 +01:00
'e, l!
2020-12-31 00:09:22 +01:00
\ 'a' ( c-addr -- a-addr ) ALIGNED
2020-12-31 16:42:30 +01:00
\ Round up to a nearlest multiple of CELL
2020-12-31 00:09:22 +01:00
ca i,
2020-12-31 00:13:42 +01:00
'L, Ck1k0--, '+, \ ( a+CELL-1 )
'L, k0k0-C-, \ ( a+CELL-1 ~(CELL-1) )
2020-12-31 00:26:06 +01:00
'&,
'e, l!
2020-12-31 00:09:22 +01:00
\ 'A' ( -- ) ALIGN
2020-12-31 16:42:30 +01:00
\ Round up 'here' to a nearlest multiple of CELL
2020-12-31 00:09:22 +01:00
cA i, 'h, '@, 'a, 'h, '!, 'e, l!
\ 'E' ( c-addr1 c-addr2 -- flag ) STR=
\ Compate null-terminated strings.
2020-12-31 01:40:42 +01:00
\ Return 1 if they are same 0 otherwise.
cE i,
\ <loop>
'o, '?, 'o, '?, \ ( c-addr1 c-addr2 c1 c2 )
'o, '=, 'J, k=k0-C*, \ goto <not_equal> if c1<>c2
'J, kAk0-C*, \ goto <equal> if c1==0
'L, k1k0-, '+, '~, \ increment c-addr2
'L, k1k0-, '+, '~, \ increment c-addr1
'j, k0kC-C*, \ goto <loop>
2020-12-31 01:40:42 +01:00
\ <not_equal>
'_, '_, '_, 'L, k0k0-, 'e,
\ <equal>
'_, '_, 'L, k1k0-, 'e,
l!
\ 'z' ( c-addr -- u ) STRLEN
\ Calculate length of string
cz i,
'L, k0k0-, \ 0
\ <loop>
'o, '?, 'J, k;k0-C*, \ goto <exit> if '\0'
'L, k1k0-, '+, '~, \ increment u
'L, k1k0-, '+, '~, \ increment c-addr
'j, k0k=-C*, \ goto <loop>
\ <exit>
'~, '_, 'e,
2020-12-31 01:40:42 +01:00
l!
2020-12-31 03:59:09 +01:00
\ 's' ( c -- n)
\ Return 1 if c==' ' or c=='\n', 0 otherwise.
cs i, '#, 'L, k , '=, '~, 'L, k:k0-, '=, '|, 'e, l!
\ 'W' ( "name" -- c-addr )
2020-12-31 03:59:09 +01:00
\ Skip leading spaces (' ' and '\n'),
\ Read name, then return its address and length.
2021-01-01 10:37:41 +01:00
\ The maximum length of the name is 63. The behavior is undefined
\ when the name exceeds 63 characters,
2020-12-31 03:59:09 +01:00
\ Note that it returns the address of statically allocated buffer,
\ so the content will be overwritten each time 'w' executed.
\ Allocate buffer of 63+1 bytes or more,
2020-12-31 03:59:09 +01:00
\ push the address for compilation of 'w'
h@ # kpk0-+ h! A
2020-12-31 06:44:39 +01:00
cW~
2020-12-31 03:59:09 +01:00
i,
\ skip leading spaces
'k, '#, 's, 'J, k4k0-C*, '_, 'j, k0k7-C*,
\ p=address of buffer
'L, #, '~,
\ <loop>
\ ( p c )
'o, '$, \ store c to p
'L, k1k0-, '+, \ increment p
'k, '#, 's, 'J, k0k9-C*, \ goto <loop> if c is not space
'_,
'L, k0k0-, 'o, '$, \ fill \0
'_, 'L, , \ return buf
2020-12-31 03:59:09 +01:00
'e, l!
\ 'F' ( c-addr -- w )
2020-12-31 05:27:25 +01:00
\ Lookup multi-character word from dictionary.
2020-12-31 07:10:54 +01:00
\ Return 0 if the word is not found.
2021-01-01 10:37:41 +01:00
\ Entries with smudge-bit=1 are ignored.
2020-12-31 05:27:25 +01:00
cF i,
2020-12-31 06:45:02 +01:00
'l, '@,
\ <loop> ( addr it )
'#, 'J, kEk0-C*, \ goto <exit> if it=NULL
'#, 'C, '+, '?, \ ( addr it len+flag )
2021-01-01 10:37:41 +01:00
'L, k@, '&, \ test smudge-bit of it
'J, k4k0-C*,
2020-12-31 05:27:25 +01:00
\ <1>
2021-01-01 10:37:41 +01:00
\ smudge-bit=1
'@, \ load link
'j, k0k>-C*, \ goto <loop>
\ <2>
\ smudge-bit=0
'o, 'o, \ ( addr it addr it )
'L, Ck1k0-+, '+, \ address of name
\ ( addr1 it addr1 addr2 )
'E, 'J, k0k:-C*, \ goto <1> if different name
2020-12-31 05:27:25 +01:00
\ <exit>
'{, '_, '}, \ Drop addr, return it
2020-12-31 05:27:25 +01:00
'e, l!
2020-12-31 05:10:18 +01:00
2020-12-31 07:10:54 +01:00
\ 'G' ( w -- xt )
\ Get CFA of the word
cG i,
'C, '+, '#, '?, \ ( addr len+flag )
2021-01-01 10:37:41 +01:00
'L, kok0-, '&, \ take length
2020-12-31 07:10:54 +01:00
'+, \ add length to the addr
'L, k2k0-, '+, \ add 2 to the addr (len+field and \0)
2020-12-31 07:10:54 +01:00
'a, \ align
'e, l!
2020-12-31 07:52:39 +01:00
2021-01-04 14:37:28 +01:00
\ 'M' ( -- a-addr)
2020-12-31 09:46:11 +01:00
\ The state variable
2020-12-31 07:52:39 +01:00
\ 0: immediate mode
\ 1: compile mode
2020-12-31 09:46:11 +01:00
h@ k0k0-, \ allocate 1 cell and fill 0
cM~ i, 'L, , 'e, l!
2020-12-31 07:52:39 +01:00
2020-12-31 10:04:08 +01:00
\ 'I'
\ The 2nd Stage Interpreter
cI i,
\ <loop>
2020-12-31 10:23:02 +01:00
'W, \ read name from input
'F, \ find word
'M, '@, \ read state
'J, kAk0-C*, \ goto <immediate> if state=0
\ <compile>
'#, 'C, '+, '?, \ ( w len+flag )
'L, k@k@+, '&, \ test immediate bit
'L, k0k0-, '=,
'J, k5k0-C*, \ goto <immediate> if immediate-bit=1
2021-01-02 06:09:18 +01:00
'G, ',, \ compile
2020-12-31 12:22:51 +01:00
'j, k0kE-C*, \ goto <loop>
2020-12-31 10:23:02 +01:00
\ <immediate>
2021-01-02 06:09:18 +01:00
'G, 'x, \ execute
2020-12-31 10:23:02 +01:00
'j, k0kI-C*, \ goto <loop>
2020-12-31 10:04:08 +01:00
l!
2020-12-31 11:01:57 +01:00
I \ Enter 2nd Stage
\ === 2nd Stage Interpreter ===
r C + R \ Drop 1st stage interpreter from call stack
2020-12-31 13:06:22 +01:00
\ '\'' ( "name" -- xt )
\ Redefine existing '\'' which uses 'k' and 'f'
\ to use 'W' and 'F'.
c ' i , ' W , ' F , ' G , ' e , l !
\ [ immediate ( -- )
\ Switch to immediate mode
c [ i , ' L , k 0 k 0 - , ' M , ' ! , ' e , l !
2020-12-31 15:32:07 +01:00
\ Set immediate-bit of [
2020-12-31 13:06:22 +01:00
l @ C + # { ? k @ k @ + | } $
\ ] ( -- )
\ Switch to compile mode
c ] i , ' L , k 1 k 0 - , ' M , ' ! , ' e , l !
2020-12-31 12:23:08 +01:00
2021-01-01 10:37:41 +01:00
\ : ( "name" -- ) COLON
\ Read name, create word with smudge=1,
2020-12-31 12:23:08 +01:00
\ compile 'docol' and enter compile mode.
c : i ,
' A , \ align here
2020-12-31 16:23:27 +01:00
' h , ' @ ,
' l , ' @ , ' , , \ fill link
' l , ' ! , \ update latest
' W , \ read name ( addr )
' # , ' z , ' # , \ ( addr len len )
' L , k @ , ' | , \ set smudge-bit
' B , \ fill length + smudge-bit
' m , \ fill name
' L , k 0 k 0 - , ' B , \ fill \0
' A , \ align here
' i , ' , , \ compile docol
' ] , \ enter compile mode
2020-12-31 12:23:08 +01:00
' e , l !
2021-01-01 10:37:41 +01:00
\ ; ( -- ) SEMICOLON
\ Compile 'exit', unsmudge latest, and enter immediate mode.
2020-12-31 12:23:08 +01:00
c ; i ,
2021-01-02 07:48:47 +01:00
' A , \ align here
2020-12-31 12:23:08 +01:00
' L , ' e , ' , , \ compile exit
2021-01-01 10:37:41 +01:00
' l , ' @ ,
' C , ' + , ' # , ' ? ,
' L , k [ k d + , \ 0xbf
' & , ' ~ , ' $ , \ unsmudge
' [ , \ enter immediate mode
2020-12-31 12:23:08 +01:00
' e , l !
2020-12-31 15:32:07 +01:00
\ Set immediate-bit of ';'
2020-12-31 12:23:08 +01:00
l @ C + # { ? k @ k @ + | } $
2021-01-01 10:37:41 +01:00
: immediate-bit [ ' L , k @ k @ + , ] ; \ 0x80
: smudge-bit [ ' L , k @ , ] ; \ 0x40
: length-mask [ ' L , k o k 0 - , ] ; \ 0x3f
2020-12-31 15:34:56 +01:00
\ ( "name" -- )
: set-immediate
W F C + # { ? immediate-bit | } $
;
\ Set immediate-bit of single-line comment word \
\ so that we can write comments in compile-mode.
set-immediate \
2020-12-31 15:47:37 +01:00
2021-01-01 10:37:41 +01:00
\ Set immediate-bit of 'latest'
2021-01-01 00:23:45 +01:00
: immediate
2021-01-01 10:37:41 +01:00
l @ C + # { ? immediate-bit | } $
2021-01-01 00:23:45 +01:00
;
2020-12-31 15:47:37 +01:00
: alias-builtin \ ( "name-new" "name-old" -- )
\ Create new word "name-new".
\ Copy code pointer of builtin word "name-old" to
\ the new word "name-new".
\ "name-old" must not be a FORTH word.
A h @ l @ , l ! \ fill link, update latest
W # z # B m \ fill length and chars of "name-new"
[ ' L , k 0 k 0 - , ] B \ fill \0
A
W F G @ , \ fill code-pointer of "name-old"
2020-12-31 15:47:37 +01:00
;
2020-12-31 16:04:21 +01:00
\ Add new names to builtin primities.
\ Instead of defining as a new FORTH word like shown below,
\ the aliases ared created by copying their code-pointer.
\ : new-name old-name ;
\ Primitive operators which manipulate program counter and return stack
\ can not be defined as a FORTH word.
2020-12-31 15:47:37 +01:00
alias-builtin bye Q
alias-builtin cell C
alias-builtin &here h
alias-builtin &latest l
2020-12-31 15:47:37 +01:00
alias-builtin key k
alias-builtin emit t
alias-builtin branch j
alias-builtin 0branch J
alias-builtin execute x
alias-builtin c@ ?
alias-builtin c! $
alias-builtin sp@ d
alias-builtin sp! D
alias-builtin rp@ r
alias-builtin rp! R
alias-builtin docol i
alias-builtin exit e
alias-builtin lit L
2021-01-03 01:36:41 +01:00
alias-builtin litstring S
2020-12-31 15:47:37 +01:00
alias-builtin div /
alias-builtin mod %
alias-builtin and &
alias-builtin or |
alias-builtin xor ^
2021-01-01 10:37:41 +01:00
\ Rename existing FORTH words
2021-01-01 18:42:59 +01:00
: word W ;
: find F ;
: >cfa G ;
: c, B ;
2021-01-02 10:01:01 +01:00
: cmove, m ;
: strlen z ;
2021-01-05 01:19:04 +01:00
: str= E ;
2021-01-02 02:25:16 +01:00
: state M ;
: aligned a ;
: align A ;
2021-01-01 10:37:41 +01:00
: here &here @ ;
: latest &latest @ ;
2021-01-01 10:37:41 +01:00
\ === Compilers ===
\ compile: ( n -- )
\ runtime: ( -- n )
: literal
lit lit , \ compile lit
, \ compile n
; immediate
\ compile: ( "name" -- )
\ '[compile] word' compiles word *now* even if it is immediate
: [compile]
' ,
; immediate
\ ( xt -- )
\ postpone compilation of xt
2021-01-01 18:43:20 +01:00
: compile-helper
2021-01-01 10:37:41 +01:00
[compile] literal \ compile 'literal'
[ ' , ] literal , \ compile ,
;
\ compile: ( "name" -- )
\ 'compile word' compiles word *later* even if it is immediate
: compile
2021-01-01 18:43:20 +01:00
' compile-helper
2021-01-01 10:37:41 +01:00
; immediate
\ ( -- xt )
: :noname
align
here
2021-01-01 10:37:41 +01:00
[ docol ] literal , \ compile docol
] \ enter compile mode
;
\ ( "name" -- xt )
\ compile time tick
: [']
' \ read name and get xt
[compile] literal \ call literal
; immediate
\ === Constants ===
2021-01-01 10:54:42 +01:00
\ Since we don't have integer literals yet,
\ define small integer words for convenience
\ and readability.
2021-01-02 14:01:44 +01:00
: 0 [ key 0 key 0 - ] literal ;
: 1 [ key 1 key 0 - ] literal ;
: 2 [ key 2 key 0 - ] literal ;
: 3 [ key 3 key 0 - ] literal ;
2021-01-02 15:52:47 +01:00
: 4 [ key 4 key 0 - ] literal ;
2021-01-02 14:01:44 +01:00
: 10 [ key : key 0 - ] literal ;
: 16 [ key @ key 0 - ] literal ;
: -1 [ key 0 key 1 - ] literal ;
2021-01-01 10:37:41 +01:00
: true 1 ;
: false 0 ;
\ === Address Arithmetic ===
: cell+ cell + ;
: cell- cell - ;
: cells cell * ;
\ === Stack Manipulation ===
: drop sp@ cell+ sp! ; \ ( w -- )
: dup sp@ @ ; \ ( w -- w w )
: >r rp@ rp@ @ rp@ cell - dup rp! ! ! ; \ ( w -- R:w )
: r> rp@ cell + @ rp@ @ rp@ cell + dup rp! ! ; \ ( R:w -- w)
: swap sp@ cell + dup @ >r ! r> ; \ ( a b -- b a )
: rot >r swap r> swap ; \ ( a b c -- b c a )
: -rot swap >r swap r> ; \ ( a b c -- c a b )
: nip swap drop ; \ ( a b -- a )
: over >r dup r> swap ; \ ( a b -- a b a )
: tuck dup -rot ; \ ( a b -- b a b )
: pick cells sp@ swap + cell + @ ; \ ( wu ... x0 u -- xu ... x0 xu )
: 2drop drop drop ; \ ( a b -- )
: 2dup over over ; \ ( a b -- a b a b )
: 2swap >r -rot r> -rot ; \ ( a b c d -- c d a b )
: 2nip 2swap 2drop ; \ ( a b c d -- c d )
: 2over 3 pick 3 pick ; \ ( a b c d -- a b c d a b )
: 2tuck 2swap 2over ; \ ( a b c d -- c d a b c d )
: 2rot >r >r 2swap r> r> 2swap ; \ ( a b c d e f -- c d e f a b )
: -2rot 2swap >r >r 2swap r> r> ; \ ( a b c d e f -- e f a b c d )
: rdrop r> rp@ ! ; \ ( R:w -- )
\ ( -- a-addr )
\ The bottom address of stacks.
\ sp@ and rp@ points bottom if implementation so far is correct.
2021-01-01 10:54:42 +01:00
: sp0 [ sp@ ] literal ;
: rp0 [ rp@ ] literal ;
2021-01-01 10:37:41 +01:00
\ === Integer Arithmetic ===
: 1+ 1 + ;
: 1- 1 - ;
\ ( a b -- (a mod b) (a / b) )
: /mod 2dup mod -rot / ;
2021-01-01 10:37:41 +01:00
\ ( n -- -n )
: negate 0 swap - ;
\ ( n1 -- n2 )
: not false = ;
2021-01-04 01:31:24 +01:00
\ ( n1 -- n2 )
\ bitwise invert
: invert -1 xor ;
: > swap < ;
: <= > not ;
: >= < not ;
: <> = not ;
: 0= 0 = ;
: 0<> 0 <> ;
: 0< 0 < ;
: 0> 0 > ;
: 0<= 0 <= ;
: 0>= 0 >= ;
\ ( a b c -- (a<=c & c<b) )
: within tuck > -rot <= and ;
\ === Conditional Branch ===
\ <condition> if <if-true> then
\ <condition> if <if-true> else <if-false> then
\ <condition> unless <if-false> then
\ <condition> unless <if-false> else <if-true> then
\ compile: ( -- orig )
\ runtime: ( n -- )
: if
compile 0branch
here 0 , \ save location of offset, fill dummy
; immediate
\ compile: ( orig -- )
\ runtime: ( -- )
: then
here \ ( orig dest )
over - \ ( orig offset )
swap ! \ fill offset to orig
; immediate
\ compile: ( orig1 -- orig2 )
\ runtime: ( -- )
: else
compile branch
here 0 , \ save location of offset, fill dummy
swap
\ fill offset, here-orig1, to orig1
here
over -
swap !
; immediate
\ compile: ( -- orig )
\ runtime: ( n -- )
: unless
compile not
[compile] if
; immediate
2021-01-01 12:47:08 +01:00
\ ( n -- n n | n )
\ duplicate if n<>0
: ?dup dup if dup then ;
\ === Loops ===
\ begin <body> <condition> until
\ begin <body> again
\ begin <condition> while <body> repeat
\ compile: ( -- dest )
\ runtime: ( -- )
: begin
here \ save location
; immediate
\ compile: ( dest -- )
\ runtime: ( n -- )
: until
compile 0branch
here - , \ fill offset
; immediate
\ compile: ( dest -- )
\ runtime: ( -- )
: again
compile branch
here - , \ fill offset
; immediate
\ compile: ( dest -- dest orig )
\ runtime: ( n -- )
\ dest=location of begin
\ orig=location of while
: while
compile 0branch
here 0 , \ save location, fill dummy
; immediate
\ compile: ( dest orig -- )
\ runtime: ( -- )
\ dest=location of begin
\ orig=location of while
: repeat
swap
compile branch
here - , \ fill offset from here to begin
here over - swap ! \ backfill offset from while to here
; immediate
2021-01-01 12:11:47 +01:00
\ === Recursive Call ===
2021-01-01 10:37:41 +01:00
2021-01-01 12:18:45 +01:00
\ recursive call.
\ compiles xt of current definition
2021-01-01 12:11:47 +01:00
: recurse
latest >cfa ,
2021-01-01 12:11:47 +01:00
; immediate
2021-01-01 10:37:41 +01:00
2021-01-01 13:40:59 +01:00
\ === Case ===
\ ---
\ <value> case
\ <value1> of <case1> endof
\ <value2> of <case2> endof
\ ...
\ <default case>
\ endcase
\ ---
\ This is equivalent to
\ ---
\ <value>
\ <value1> over = if drop <case1> else
\ <value2> over = if drop <case2> else
\ ...
\ <default case>
\ then ... then then
\ ---
\ compile: ( -- 0 )
\ runtime: ( n -- )
: case
0 \ push 0 to indicate there is no more case
; immediate
\ compile: ( -- orig )
: of
compile over
compile =
[compile] if
compile drop
; immediate
2021-01-01 14:12:45 +01:00
\ <value> a b rangeof <body> endof
\ Execute <body> when
\ a <= <value> and <value> <= b
: rangeof
compile 2
compile pick
compile >=
compile swap
compile 2
compile pick
compile <=
compile and
[compile] if
compile drop
; immediate
2021-01-01 13:40:59 +01:00
\ compile: ( orig1 -- orig2 )
: endof
[compile] else
; immediate
: endcase
compile drop
begin ?dup while
[compile] then
repeat
; immediate
2021-01-01 12:35:09 +01:00
\ === Multiline Comment ===
: '(' [ key ( ] literal ;
: ')' [ key ) ] literal ;
: (
1 \ depth counter
begin ?dup while
key case
'(' of 1+ endof \ increment depth
')' of 1- endof \ decrement depth
endcase
repeat
2021-01-01 12:35:09 +01:00
; immediate
2021-01-01 12:18:45 +01:00
2021-01-01 12:35:09 +01:00
(
Now we can use multiline comment with ( nests. )
)
2021-01-01 12:18:45 +01:00
2021-01-01 18:44:57 +01:00
( === Memory Operation === )
: +! ( n a-addr -- ) tuck @ + swap ! ;
: -! ( n a-addr -- ) tuck @ - swap ! ;
\ allocate n bytes
: allot ( n -- c-addr )
here swap
&here +!
2021-01-01 18:44:57 +01:00
;
2021-01-01 18:45:27 +01:00
( === create and does> === )
\ no-operation
: nop ;
\ ( "name" -- )
\ Read name and create new dictionary entry.
\ When the word is executed, it pushs value of here
\ at the end of the entry.
: create
2021-01-02 07:48:47 +01:00
align
latest , \ fill link
here cell- &latest ! \ update latest
2021-01-04 22:59:58 +01:00
word dup strlen
dup c, cmove, 0 c, align \ fill length, name and \0
docol , \ compile docol
2021-01-01 18:45:27 +01:00
['] lit ,
here 3 cells + , \ compile the address
['] nop , \ does>, if any, will fill this cell
['] exit , \ compile exit
2021-01-01 18:45:27 +01:00
;
: does>-helper
latest >cfa
2021-01-03 09:51:07 +01:00
3 cells + ! \ replace nop
2021-01-01 18:45:27 +01:00
;
: does>
2021-01-02 07:48:47 +01:00
align
2021-01-01 18:45:27 +01:00
0 [compile] literal \ literal for xt
here cell- \ save addr of xt
2021-01-01 18:45:27 +01:00
2021-01-03 09:51:07 +01:00
\ replace nop with xt at runtime
2021-01-01 18:45:27 +01:00
compile does>-helper
[compile] ; \ finish compilation of initialization part
:noname \ start compilation of does> part
swap ! \ backfill xt to the operand of literal
; immediate
2021-01-02 01:08:59 +01:00
( === Variable and Constant === )
\ ( "name" -- )
: variable create 0 , ;
\ ( n "name" -- )
2021-01-01 18:45:27 +01:00
: constant create , does> @ ;
2021-01-02 12:03:40 +01:00
( === Throw and Catch === )
\ 'xt catch' saves data stack pointer and a marker
\ to indicate where to return on return stack
\ then execute 'xt'.
\ When 'n throw' is executed, the catch statement returns
\ 'n'. If no throw is executed, returns 0.
\ At the beginning of execution of 'xt', return stack
\ contains following information.
\ +-------------------------+
\ | original return address |
\ | saved stack pointer |
\ | exception marker | <- top of return stack
\ +-------------------------+
\ If no 'throw' is called, after execution of 'xt'
\ program goes to the exception-marker because it is
\ on the top of return stack.
\ The exception-marker drops 'saved stack pointer',
\ push 0 to indicate no error and return to the
\ 'original return address'.
\ When 'n throw' is called, it scans return stack
\ to find the exception-marker, restore return stack pointer
\ and data stack pointer, push error code, and returns to
\ the 'original return address'
create exception-marker
' rdrop , \ drop saved stack pointer
0 literal \ push 0 to indicate no-error
' exit ,
: catch ( xt -- n )
sp@ cell+ >r \ save stack pointer
exception-marker >r \ push exception marker
execute
;
2021-01-04 07:42:14 +01:00
: success 0 ;
2021-01-04 07:35:55 +01:00
2021-01-02 12:03:40 +01:00
: throw ( w -- )
?dup unless exit then \ do nothing if no error
rp@
begin
dup rp0 cell- < \ rp < rp0
while
dup @ \ load return stack entry
exception-marker = if
rp! \ restore return stack pointer
rdrop \ drop exception marker
\ Reserve enough working space of data stack since
\ following code manipulates data stack pointer
\ and write value to data stack directly via
\ address.
dup dup dup dup
r> \ original stack pointer
\ ( n sp )
cell- \ allocate space for error code
tuck ! \ store error code of top of stack
sp! \ restore data stack pointer
exit
then
cell+
repeat
drop
;
2021-01-02 18:01:26 +01:00
( === Printing Numbers === )
2021-01-02 17:56:02 +01:00
\ Skip reading spaces, read characters and returns first character
: char ( <spces>ccc -- c ) word c@ ;
2021-01-02 17:56:02 +01:00
\ compile-time version of char
: [char] ( compile: <spaces>ccc -- ; runtime: --- c )
char
[compile] literal
; immediate
: '\n' [ key : key 0 - ] literal ; \ neline (10)
: bl [ key P key 0 - ] literal ; \ space (32)
: '"' [char] "" ;
: cr '\n' emit ;
: space bl emit ;
2021-01-02 14:01:44 +01:00
variable base \ number base
: decimal 10 base ! ;
: hex 16 base ! ;
decimal \ set default to decimal
: '0' [char] 0 ;
: '9' [char] 9 ;
: 'a' [char] a ;
: 'x' [char] x ;
: 'z' [char] z ;
: 'A' [char] A ;
: 'Z' [char] Z ;
: '-' [char] - ;
: '&' [char] & ;
: '#' [char] # ;
: '%' [char] % ;
: '$' [char] $ ;
: '\'' [char] ' ;
2021-01-02 14:01:44 +01:00
\ Display unsigned integer u2 with number base u1.
: print-uint ( u1 u2 -- )
over /mod ( base mod quot )
?dup if
\ mod base quot base
>r over r>
recurse
then
dup 10 < if '0' + else 10 - 'a' + then emit
drop
;
\ Display signed integer n with number base u.
: print-int ( u n -- )
dup 0< if '-' emit negate then
print-uint
;
\ Display unsigned integer followed by a space.
: u. ( u -- ) base @ swap print-uint space ;
\ Display n followed by a space.
: . ( n -- ) base @ swap print-int space ;
\ Display n as a signed decimal number followed by a space.
: dec. ( n -- ) 10 swap print-int space ;
\ Display u as an unsigned hex number prefixed with $
\ and followed by a space.
: hex. ( u -- ) '$' emit 16 swap print-uint space ;
\ Number of characters of u in 'base'
: uwidth ( u -- u )
base @ /
?dup if recurse 1+ else 1 then
;
: spaces ( n -- )
begin dup 0> while space 1- repeat drop
;
\ Display unsigned integer u right aligned in n characters.
: u.r ( u n -- )
over uwidth
- spaces base @ swap print-uint
2021-01-02 14:01:44 +01:00
;
\ Display signed integer n1 right aligned in n2 characters.
: .r ( n1 n2 -- )
over 0>= if
u.r
else
swap negate
dup uwidth 1+
rot swap - spaces
'-' emit
base @ swap print-uint
2021-01-02 14:01:44 +01:00
then
;
2021-01-02 15:52:47 +01:00
( === Parsing Numbers === )
\ Parse string c-addr as an unsigned integer with base u
2021-01-02 15:52:47 +01:00
\ and return n. f represents the conversion is success or not.
: parse-uint ( u c-addr -- n f )
2021-01-02 15:52:47 +01:00
0 \ accumulator
begin over c@ while
\ ( base addr acc )
2021-01-02 15:52:47 +01:00
>r \ save acc
dup c@ swap 1+ >r \ load char, increment addr and save
dup case
'0' '9' rangeof '0' - endof
'a' 'z' rangeof 'a' - 10 + endof
'A' 'Z' rangeof 'A' - 10 + endof
\ failed to convert
2drop r> r> swap drop false
2021-01-02 15:52:47 +01:00
exit
endcase
2dup
\ ( base n base n )
0 -rot
\ ( base n 0 base n )
within unless
\ failed to convert
2drop r> r> swap drop false
2021-01-02 15:52:47 +01:00
exit
then
\ ( base addr n acc )
r> swap r>
3 pick * +
2021-01-02 15:52:47 +01:00
repeat
\ success
swap drop
swap drop
true
;
\ Parse string as number.
\ This function interprets prefixes that specifies number base.
: >number ( c-addr -- n f )
dup c@ unless
drop
2021-01-02 15:52:47 +01:00
0 false
exit
then
dup c@ case
2021-01-02 15:52:47 +01:00
'-' of
1+
2021-01-02 15:52:47 +01:00
recurse if
negate true
else
false
then
endof
'&' of 1+ 10 swap parse-uint endof
'#' of 1+ 10 swap parse-uint endof
'%' of 1+ 2 swap parse-uint endof
2021-01-02 15:52:47 +01:00
'0' of
\ hexadecimal
\ ( addr )
1+
dup c@ unless
drop 0 true exit
2021-01-02 15:52:47 +01:00
then
dup c@ 'x' = if
1+ 16 swap parse-uint exit
2021-01-02 15:52:47 +01:00
then
drop 0 false exit
2021-01-02 15:52:47 +01:00
endof
'\'' of
\ character code
\ ( addr )
1+
dup c@ unless
drop 0 false exit
then
dup c@ swap 1+
c@ case
0 of true exit endof
'\'' of true exit endof
2021-01-02 15:52:47 +01:00
drop 0 false
endcase
endof
\ default case
\ ( addr base )
drop base @ swap parse-uint
dup \ need this because endcase drops top of stack
2021-01-02 15:52:47 +01:00
endcase
;
2021-01-02 18:01:26 +01:00
( === String === )
2021-01-03 09:24:34 +01:00
\ ( c-from c-to u -- )
\ Copy u bytes from c-from to c-to.
\ The memory regions must not be overlapped.
: cmove
begin dup 0> while
1- >r \ decrement u, save
over c@
over c! \ copy character
1+ >r \ increment c-to, save
1+ \ increment c-from
r> r>
repeat
drop drop drop
;
\ we already have cmove,
\ ( c-from c-to -- )
\ copy nul terminated string from c-from to c-to
: strcpy
begin over c@ dup while
\ ( c-from c-to c )
over c!
1+ swap 1+ swap
2021-01-05 01:56:59 +01:00
repeat
over c!
drop drop
2021-01-03 09:24:34 +01:00
;
\ ( c-addr -- )
\ copy string to here including \0
: strcpy,
begin dup c@ dup while
c, 1+
2021-01-04 15:00:16 +01:00
repeat 2drop
0 c,
;
2021-01-03 09:24:34 +01:00
2021-01-02 18:01:26 +01:00
\ Print string
: type ( c-addr -- )
begin dup c@ dup while \ while c<>\0
emit 1+
2021-01-02 18:01:26 +01:00
repeat
2drop
;
\ Allocate a buffer for string literal
bl constant s-buffer-size \ 1024
2021-01-03 09:51:30 +01:00
create s-buffer s-buffer-size allot drop
\ Will define the error message corresponds to this error later
\ because we can't write string literal yet.
2021-01-04 03:10:46 +01:00
char 0 char B - constant STRING-OVERFLOW-ERROR \ -18
2021-01-02 18:01:26 +01:00
\ Parse string delimited by "
\ compile mode: the string is stored as operand of 'string' operator.
\ immediate mode: the string is stored to temporary buffer.
: s"
state @ if
2021-01-03 01:36:41 +01:00
compile litstring
2021-01-02 18:01:26 +01:00
here 0 , \ save location of length and fill dummy
2021-01-05 01:18:53 +01:00
0 \ length of the string + 1 (\0)
2021-01-02 18:01:26 +01:00
begin key dup '"' <> while
c, \ store character
1+ \ increment length
repeat drop
0 c, \ store \0
2021-01-05 01:18:53 +01:00
1+
2021-01-02 18:01:26 +01:00
swap ! \ back-fill length
align
else
s-buffer dup \ save start address
2021-01-02 18:01:26 +01:00
begin key dup '"' <> while
2dup swap - s-buffer-size >= if
2021-01-04 03:10:46 +01:00
throw STRING-OVERFLOW-ERROR
then
2021-01-02 18:01:26 +01:00
over c! \ store char
1+ \ increment address
repeat drop
0 swap c! \ store \0
2021-01-02 18:01:26 +01:00
then
; immediate
\ Print string delimited by "
: ."
[compile] s"
state @ if
compile type
else
type
then
; immediate
2021-01-03 00:17:41 +01:00
( === Error Code and Messages === )
\ Single linked list of error code and messages.
\ Thre structure of each entry:
\ | link | code | message ... |
2021-01-03 00:17:41 +01:00
variable error-list
0 error-list !
2021-01-03 09:24:34 +01:00
: error>next ( a-addr -- a-addr) @ ;
: error>message ( a-addr -- c-addr ) 2 cells + ;
2021-01-03 09:24:34 +01:00
: error>code ( a-addr -- n ) cell+ @ ;
: add-error ( n c-addr -- )
2021-01-03 00:17:41 +01:00
error-list here
2021-01-04 15:00:16 +01:00
( n c-addr )
2021-01-03 00:17:41 +01:00
over @ , \ fill link
swap ! \ update error-list
2021-01-04 15:00:16 +01:00
swap , \ fill error-code
strcpy, \ fill message
2021-01-03 00:17:41 +01:00
;
: def-error ( n c-addr "name" -- )
create over ,
2021-01-04 03:10:46 +01:00
add-error
does> @
;
2021-01-03 00:17:41 +01:00
2021-01-04 03:10:46 +01:00
decimal
STRING-OVERFLOW-ERROR s" Too long string literal" add-error
s" -13" >number drop s" Undefined word" def-error UNDEFINED-WORD-ERROR
2021-01-03 10:40:30 +01:00
2021-01-03 00:17:41 +01:00
variable next-user-error
s" -256" >number drop next-user-error !
\ Create new user defined error and returns error code.
: exception ( c-addr -- n )
2021-01-03 00:17:41 +01:00
next-user-error @ -rot add-error
next-user-error @
1 next-user-error -!
;
2021-01-03 10:40:30 +01:00
( === 3rd Stage Interpreter === )
2021-01-04 14:41:22 +01:00
create word-buffer s" 64" >number drop cell+ allot drop
2021-01-03 10:40:30 +01:00
: interpret
word \ read name from input
\ ( addr )
dup word-buffer strcpy \ save input
dup find \ lookup dictionary
2021-01-03 10:40:30 +01:00
?dup if
\ Found the word
swap drop
2021-01-03 10:40:30 +01:00
state @ if
\ compile mode
dup cell+ c@ immediate-bit and if
\ execute immediate word
>cfa execute
else
\ compile the word
>cfa ,
then
else
\ immediate mode
>cfa execute
then
else
>number unless
2021-01-04 03:10:46 +01:00
UNDEFINED-WORD-ERROR throw
2021-01-03 10:40:30 +01:00
then
\ Not found
state @ if
\ compile mode
[compile] literal
then
then
;
: main
2021-01-03 10:44:51 +01:00
rdrop \ drop 2nd stage
2021-01-03 10:40:30 +01:00
begin
['] interpret catch
?dup if
\ lookup error code
error-list @
begin ?dup while
\ ( error-code error-entry )
dup error>code
2 pick = if
error>message type
." : "
word-buffer type cr
2021-01-03 10:40:30 +01:00
bye
then
error>next
repeat
." Unknown error code: " . cr
bye
then
again
;
main
2021-01-04 01:32:16 +01:00
( === Dump of data stack === )
: .s ( -- )
sp0 sp@ - cell- cell / ( depth of the stack )
'<' emit 0 u.r '>' emit space
sp@ sp0 ( beg end )
begin 2dup < while
cell- dup @ .
repeat 2drop
;
2021-01-04 02:20:51 +01:00
( === Data Structure === )
2021-01-04 07:35:55 +01:00
\ align n1 to u-byte boundary
: aligned-by ( n1 u -- n2 )
1- dup invert \ ( n1 u-1 ~(u-1) )
-rot + and
;
\ align here to u-byte boundary
: align-by ( u -- )
here swap aligned-by &here !
;
2021-01-04 02:20:51 +01:00
: struct ( -- offset )
0
;
2021-01-04 07:35:55 +01:00
\ struct ... end-struct new-word
\ defines new-word as a operator
\ that returns alignment and size of the struct.
\ new-word: ( -- align size )
2021-01-04 02:20:51 +01:00
: end-struct ( offset "name" -- )
2021-01-04 07:35:55 +01:00
create , does> @ cell swap
2021-01-04 02:20:51 +01:00
;
2021-01-04 07:35:55 +01:00
: cell% ( -- align size ) cell cell ;
: char% ( -- align size ) 1 1 ;
\ allocate user memory
: %allot ( align size -- addr )
swap align-by allot
;
2021-01-04 02:20:51 +01:00
2021-01-04 07:35:55 +01:00
: field ( offset1 align size "name" -- offset2 )
\ align offset with 'align'
-rot aligned-by \ ( size offset )
2021-01-04 02:20:51 +01:00
create
2021-01-04 07:35:55 +01:00
dup , \ fill offset
2021-01-04 03:11:56 +01:00
+ \ return new offset
2021-01-04 02:20:51 +01:00
does> @ +
;
2021-01-04 07:35:55 +01:00
( === File I/O Abstraction === )
decimal
2021-01-04 23:51:02 +01:00
-39 s" Unexpected end of file" def-error UNEXPECTED-EOF-ERROR
2021-01-04 07:35:55 +01:00
-68 s" FLUSH-FILE" def-error FLUSH-FILE-ERROR
-70 s" READ-FILE" def-error READ-FILE-ERROR
2021-01-04 09:05:48 +01:00
-71 s" READ-LINE" def-error READ-LINE-ERROR
2021-01-04 07:35:55 +01:00
-75 s" WRITE-FILE" def-error WRITE-FILE-ERROR
2021-01-04 23:25:08 +01:00
-1 constant EOF
2021-01-04 07:35:55 +01:00
\ file access methods (fam)
0x00 constant R/O \ read-only
0x01 constant R/W \ read-write
0x02 constant W/O \ write-only
\ File
struct
2021-01-04 09:05:48 +01:00
cell% field file>read-file ( c-addr u1 file -- u2 e )
cell% field file>read-line ( c-addr u1 file -- u2 flag e )
cell% field file>key-file ( file -- c e )
cell% field file>write-file ( c-addr u1 file -- e )
cell% field file>flush-file ( file -- e )
2021-01-04 07:35:55 +01:00
char% field file>fam
\ will add other fields later
end-struct file%
: writable? ( file -- f ) file>fam c@ R/O <> ;
: readable? ( file -- f ) file>fam c@ W/O <> ;
2021-01-04 23:25:08 +01:00
\ Write bytes from buffer c-addr u1 to file, return error-code.
2021-01-04 07:35:55 +01:00
: write-file ( c-addr u1 file -- e )
dup writable? if
2021-01-04 09:05:48 +01:00
dup file>write-file @ execute
2021-01-04 07:35:55 +01:00
else
WRITE-FILE-ERROR
then
;
2021-01-04 23:25:08 +01:00
\ Read u1-bytes at most from file, write it to c-addr.
\ Return number of bytes read and error-code.
2021-01-04 07:35:55 +01:00
: read-file ( c-addr u1 file -- u2 e )
dup readable? if
2021-01-04 09:05:48 +01:00
dup file>read-file @ execute
2021-01-04 07:35:55 +01:00
else
2021-01-04 09:05:48 +01:00
0 READ-FILE-ERROR
2021-01-04 07:35:55 +01:00
then
;
2021-01-04 23:25:08 +01:00
\ Flush output buffer of file, return error-code.
2021-01-04 07:35:55 +01:00
: flush-file ( file -- e )
dup writable? if
2021-01-04 09:05:48 +01:00
dup file>flush-file @ execute
2021-01-04 07:35:55 +01:00
else
FLUSH-FILE-ERROR
then
;
2021-01-04 23:25:08 +01:00
\ Read a character. Return EOF at end of input.
2021-01-04 23:00:13 +01:00
: key-file ( file -- c ) dup file>key-file @ execute throw ;
2021-01-04 09:05:48 +01:00
2021-01-04 23:25:08 +01:00
\ Read characters from 'file' to the buffer c-addr u1
\ until reaches '\n' or end of file.
\ The last '\n' is not stored to the buffer.
\ u2 is the number of characters written to the buffer.
\ flag=true if it reaches '\n'.
\ e is error code.
2021-01-04 09:05:48 +01:00
: read-line ( c-addr u1 file -- u2 flag e )
dup readable? if
dup file>read-line @ execute
else
READ-LINE-ERROR
then
;
2021-01-04 07:35:55 +01:00
\ Temporary implementation stdin and stdout using 'key' and 'type'
s" Not implemented" exception constant NOT-IMPLEMENTED
: not-implemented NOT-IMPLEMENTED throw ;
create stdin_ file% %allot drop
R/O stdin_ file>fam c!
2021-01-04 09:05:48 +01:00
' not-implemented stdin_ file>write-file !
' not-implemented stdin_ file>flush-file !
2021-01-04 07:35:55 +01:00
\ Read u byte from stdin to c-addr.
:noname ( c-addr u file -- u e )
drop
dup >r
begin dup 0> while
\ c-addr u c
key 2 pick c!
1- swap 1+ swap
2021-01-04 07:35:55 +01:00
repeat
2drop
2021-01-04 07:42:14 +01:00
r> success \ 0: no-error
2021-01-04 09:05:48 +01:00
; stdin_ file>read-file !
2021-01-04 07:35:55 +01:00
2021-01-04 09:38:25 +01:00
:noname ( c-addr u1 file -- u2 flag e )
drop 0
begin
( c-addr u1 u2 )
over 0<= if
-rot dup dup false success
exit
then
key
dup '\n' = if
( c-addr u1 u2 c )
drop -rot drop drop true success
exit
then
3 pick c!
1+ >r 1- swap 1+ swap r>
2021-01-04 09:38:25 +01:00
again
; stdin_ file>read-line !
:noname ( file -- c e )
2021-01-04 23:00:13 +01:00
drop key success
2021-01-04 09:38:25 +01:00
; stdin_ file>key-file !
2021-01-04 07:35:55 +01:00
create stdout_ file% %allot drop
W/O stdout_ file>fam c!
2021-01-04 09:05:48 +01:00
' not-implemented stdout_ file>read-file !
' not-implemented stdout_ file>read-line !
' not-implemented stdout_ file>key-file !
2021-01-04 07:35:55 +01:00
\ Write u byte from c-addr to stdout.
:noname ( c-addr u file -- e )
2021-01-04 07:42:14 +01:00
drop type success
2021-01-04 09:05:48 +01:00
; stdout_ file>write-file !
2021-01-04 07:35:55 +01:00
2021-01-04 07:42:14 +01:00
\ do nothing
2021-01-04 09:05:48 +01:00
:noname drop success ; stdout_ file>flush-file !
2021-01-04 08:14:14 +01:00
( === Input Stream === )
\ input stream stack
struct
cell% field input>next
cell% field input>file
cell% field input>lineno
2021-01-04 23:00:32 +01:00
end-struct inputstream%
2021-01-04 08:14:14 +01:00
2021-01-04 23:01:40 +01:00
variable inputstreams
0 inputstreams !
2021-01-04 08:14:14 +01:00
2021-01-04 23:01:40 +01:00
: push-inputstream ( file -- )
2021-01-04 23:00:32 +01:00
inputstream% %allot \ addr
2021-01-04 08:14:14 +01:00
swap over input>file !
0 over input>lineno !
2021-01-04 23:01:40 +01:00
inputstreams @ over input>next !
inputstreams !
2021-01-04 08:14:14 +01:00
;
2021-01-04 23:01:40 +01:00
: pop-inputstream ( -- )
inputstreams @ inputstreams !
2021-01-04 08:14:14 +01:00
;
2021-01-04 23:01:40 +01:00
stdin_ push-inputstream
2021-01-04 23:51:02 +01:00
\ Rewrite existing functions that reads inputs using inputstream.
2021-01-04 23:01:53 +01:00
: key ( -- c )
inputstreams @ input>file @ key-file
;
2021-01-04 23:51:02 +01:00
\ Read a word from input stream, return address of the string
\ and error-code.
: word ( -- c-addr e )
2021-01-04 23:01:53 +01:00
inputstreams @ input>file @
\ skip leading spaces
0
begin
drop
dup key-file \ ( file c )
dup bl <> over '\n' <> and
until
2021-01-04 23:51:02 +01:00
dup EOF = if
drop word-buffer UNEXPECTED-EOF-ERROR
then
2021-01-04 23:01:53 +01:00
word-buffer tuck c!
1+
begin
\ ( file p )
over key-file
dup bl = over '\n' = or if
drop
0 swap c! \ store \0
2021-01-04 23:51:02 +01:00
drop word-buffer success
exit
2021-01-04 23:01:53 +01:00
then
over c!
1+
again
;
2021-01-04 23:51:02 +01:00
: ' ( "name" -- xt ) word throw find >cfa ;
2021-01-04 23:01:53 +01:00
: : ( "name -- )
align
here latest , &latest !
2021-01-04 23:51:02 +01:00
word throw dup strlen
2021-01-04 23:01:53 +01:00
smudge-bit or c,
strcpy,
align
docol ,
]
;
: create ( "name" -- )
align
here latest , &latest !
2021-01-04 23:51:02 +01:00
word throw dup strlen c, strcpy,
2021-01-04 23:01:53 +01:00
align
docol ,
compile lit
here 3 cells + ,
compile nop
compile exit
;
2021-01-04 23:51:02 +01:00
: char ( "ccc" -- c ) word throw c@ ;
( === 4th Stage Interpreter === )
-56 s" Bye" def-error QUIT
: interpret
2021-01-05 00:17:54 +01:00
word \ read name from input
2021-01-04 23:51:02 +01:00
2021-01-05 00:17:54 +01:00
\ EOF at this point is not an error
UNEXPECTED-EOF-ERROR = if QUIT throw then
2021-01-04 23:51:02 +01:00
dup word-buffer strcpy \ save input
dup find \ lookup dictionary
?dup if
\ Found the word
swap drop
state @ if
\ compile mode
dup cell+ c@ immediate-bit and if
\ execute immediate word
>cfa execute
else
\ compile the word
>cfa ,
then
else
\ immediate mode
>cfa execute
then
else
>number unless
UNDEFINED-WORD-ERROR throw
then
\ Not found
state @ if
\ compile mode
[compile] literal
then
then
;
: interpret-loop
begin
['] interpret catch
?dup if
\ lookup error code
dup QUIT = if throw then
error-list @
begin ?dup while
\ ( error-code error-entry )
dup error>code
2 pick = if
error>message type
." : "
word-buffer type cr
bye
then
error>next
repeat
." Unknown error code: " . cr
bye
then
again
;
: switch-to-4th-stage
rdrop \ drop 3rd stage
2021-01-05 00:17:54 +01:00
['] interpret-loop catch bye
2021-01-04 23:51:02 +01:00
;
switch-to-4th-stage
2021-01-04 23:01:53 +01:00
2021-01-05 01:19:04 +01:00
( === [if]..[else]..[then] === )
: [if] ( f -- )
unless
\ skip inputs until corresponding [else] or [then]
0 \ depth
begin
word throw
dup s" [if]" str= if
drop 1+
else dup s" [else]" str= if
drop
dup 0= if drop exit then
else s" [then]" str= if
dup 0= if drop exit then
1-
then then then
again
then
; immediate
: [else]
\ If the condition is false, [else] is skipped by [if].
\ So when the execution reaches [else] it means that
\ the condition was true.
\ skip inputs until corresponding [then]
0 \ depth
begin
word throw
dup s" [if]" str= if
drop 1+
else s" [then]" str= if
dup 0= if drop exit then
1-
then then
again
; immediate
: [then] ; immediate \ do nothing
." Ready" cr