\ A compile-only Forth system
\ Joshua Grams <josh@qualdan.com>
\ 2008-10-17
\
\ Invoke with "compile-only-forth"


( wordlist manipulation )

: add-wordlist ( wid -- )  >r get-order r> swap 1 + set-order ;
: use-wordlist ( wid -- )  add-wordlist definitions ;


( avoid masking the standard interpreter words )

get-current
wordlist constant *compile-only
*compile-only use-wordlist


( control-flow stack balance checking )

: cs-depth depth ;  \ only care about balance, not how big they are.
variable cs-depth0
: mark depth cs-depth0 ! ;
: balanced? ( -- flag )  depth cs-depth0 @ = ;


( temporary compilation buffer )

\ exchange the contents of the cells at addr1 and addr2.
: exchange ( addr1 addr2 -- )  over @ over @ swap  rot ! swap ! ;

variable other-dp
: compute-temp-dp ( -- )  unused 2 / here + other-dp ! ;
compute-temp-dp
: temp? ( -- flag )  here other-dp @ u> ;
: switch ( -- )
	temp? 0= if compute-temp-dp then
	dp other-dp exchange ;

: >temporary switch :noname mark ;
: >permanent postpone ; switch execute ;
: cleanup postpone [ temp? if switch then ;

\ I don't use [ ] in my Forth code, so I'm reusing those names
\ for the compile-only versions (note that neither is immediate).
-22 constant CS-MISMATCH
: [  temp? 0= if >temporary then ;
: ]  temp? if balanced? 0= CS-MISMATCH and throw  >permanent then ;
: ][ ] [ ;
: ?][ balanced? temp? and if >permanent >temporary then ;
: prompt balanced? 0= temp? and if ." ..." else ."  ok" then cr ;


( search the dictionary )

create name 80 chars allot
: find ( c-addr u -- c-addr u false | xt syntax true )
	2dup name place  name find dup if 2nip 1 = true else nip then ;


( convert string to number )

: sign ( c-addr u -- c-addr' u' +-1 )
	dup if over c@
		dup [char] + = if drop 1 /string then
		[char] - = if 1 /string -1 exit then
	then 1 ;
: number ( c-addr u -- c-addr u false | n true )
	sign >r  0 s>d 2over >number nip 0=  ( c-addr u ud number? )
	if 2nip d>s r> * true else 2drop r> drop false then  ;


( actions for the interpreter )

: compile compile, ;
: literal postpone literal ;
: not-found -13 throw ;


( interpret input )

: interpret-line
	begin parse-word dup while
		find if
			( syntax? ) if execute else compile then
		else
			number if literal else not-found then
		then
	repeat 2drop ?][ ;

: interpret [ begin interpret-line prompt refill 0= until ] ;


( for defining compile-only words )

: syntax immediate ;

: same ( "name" -- )
	>in @ >r : r> >in !  ' compile,  postpone ; ;
: same-syntax ( "name" -- )
	>in @ >r : r> >in !  postpone postpone  postpone ; syntax ;


( invoke the interpreter )

s" returning to standard forth" exception constant end-compile-only

wordlist constant *forth  \ a wordlist for the compile-only words

dup set-current  \ restore host system's default compilation wordlist

: compile-only-forth
	*forth 1 set-order definitions
		['] interpret catch
	cleanup -1 set-order also forth definitions
	." RETURNING TO STANDARD FORTH" cr
	dup end-compile-only <> and throw ;


( ***** populate our wordlist ***** )

*forth set-current

: standard-forth  end-compile-only throw ; syntax


( syntax words )

same syntax

same-syntax postpone

\ See above under "temporary compilation buffer"
same [ syntax
same ] syntax

: : ] : ; syntax
: ; postpone ; [ ; syntax
same :noname syntax
same create syntax
same-syntax does>
: constant ] constant [ ; syntax
: value ] value [ ; syntax
: marker ] marker [ ; syntax

same-syntax \
same-syntax (  \ ... )

same-syntax ."  \ ... "
: " postpone s" ; syntax

: ' ' literal ; syntax

: evaluate ( i*x c-addr u -- j*x )  ['] interpret execute-parsing ;
: included ( i*x c-addr u -- j*x )
	r/o open-file throw dup >r
	['] interpret execute-parsing-file
	r> close-file throw ;
: include ( i*x "name" -- j*x )  parse-word included ; syntax

same-syntax if
same-syntax then
same-syntax else
same-syntax ahead

same-syntax begin
same-syntax again
same-syntax until
same-syntax while
same-syntax repeat

same-syntax do
same-syntax ?do
same-syntax i
same-syntax j
same-syntax unloop
same-syntax leave
same-syntax loop
same-syntax +loop

same-syntax >r
same-syntax r>
same-syntax r@
same-syntax 2>r
same-syntax 2r>
same-syntax 2r@
same-syntax exit
same-syntax recurse

same-syntax abort"  \ ... "


( common words )

same dup
same drop
same over
same swap
same nip
same tuck
same rot
same ?dup
same depth

same 2dup
same 2drop
same 2over
same 2swap
same 2nip
same 2tuck

same @
same !
same +!
same ,
same cells
1 cells constant cell
same aligned
same here
same unused
same align
same allot

same c@
same c!
same c,
same count

same 2@
same 2!

same .
same u.

same +
same -
same negate

same abs
same max
same min

same *
same /
same mod
same */
same /mod

same and
same or
same xor
same invert
same lshift
same rshift

same <
same >
same =
same <>
same u<
same u>
same <=
same >=
same u<=
same u>=
same true
same false
same within

same >body

same find

same >in
same source

same key
same accept

same fill
same move

same bl
same cr
same emit
same type

same environment?

same execute

same pad

same refill

same abort


( programming tools words )

same .s
same bye


( search order words )

same wordlist

same search-wordlist

same get-current
same set-current
same get-order
same set-order

same previous
same definitions

same add-wordlist
same use-wordlist


previous set-current