\ vandys
\ extend.f
\ More CORE-ish stuff not implemented in kernel.f
\ Return canonical TRUE/FALSE values
-1 constant true
0 constant false
\ Emulate FIG check for compiling
: ?comp compiling? 0= abort" Compile only" ; immediate
\ Emulate FIG compile stack checking
: ?pairs = not abort" Mismatched control structure" ;
\ vandys
\ Get next extended key event
\ For our encoding, all chars except Escape are returned directly.
\ Escape is encoded as 256 + the following key
: ekey ( -- u )
key dup 27 = if drop 256 key + then ;
\ Tell if there is data available via ekey
\ Note that for an escape sequence, we return true as soon as the
\ escape is typed, not when the complete sequence is available
\ via ekey. A bug, probably.
: ekey? ( -- bool ) key? ;
\ Convert ekey value to a simple character
: ekey>char ( u -- u false | c true ) dup 256 < ;
\ vandys
\ TTY operations, using TTY driver vectors
: page 3 'ttyops @execute ; \ Clear screen
: at-xy 4 'ttyops @execute ; \ Position cursor
: blot drop 5 'ttyops @execute ; \ Clear to end of line
: inv-on 1 6 'ttyops @execute ; \ Start standout
: inv-off 0 6 'ttyops @execute ; \ End standout
: putpage 8 'ttyops @execute ; \ Bulk put to TTY screen
\ Print number in hex without changing selected base
: h. ( u -- ) base @ swap hex . base ! ;
\ vandys
\ Greater than
: > ( n n -- bool ) swap < ;
\ Greater than or equal
: >= ( n n -- bool ) < not ;
\ Less than or equal
: <= ( n n -- bool ) > not ;
\ Put byte at HERE and advance
: c, ( c -- ) here c! 1 allot ;
\ vandys
\ Initialize to blanks
: blank ( a u -- ) bl fill ;
\ Pick up code address within compilation
: ['] ' [compile] literal ; immediate compile-only
\ Patch compiled entry to jump to assembly code
: (;code) r> last @ name> call! ;
\ Define building action for a word
: does> (compile) (;code) ['] doLIST call, (compile) cell+
; immediate compile-only
\ defer/is
: (unresolved) 1 abort" Unresolved word" ;
: defer token $,n overt ['] doLIST call,
['] (unresolved) , 0 , ['] (;) , ;
: is ( cfa -- ) 2 cells + ' 2 cells + ['] branch over ! cell+ !
;
: :noname ( -- cfa ) last off here ['] doLIST call, ] !csp ;
\ vandys
: vocabulary ( -- )
token $,n overt ['] doLIST call, ['] doVOC , here 0 ,
current cell+ dup @ , ! ;
: also ( -- ) context dup cell+ #VOCS 1- cells move ;
: -also ( -- ) context cell+ cell+ @ 0= abort" Order empty"
context dup cell+ swap #VOCS 1- cells move
context #VOCS 1- cells + off ;
: (.voc) ( ca -- ) ?dup if voc>nfa 1 spaces .id then ;
: order ( -- ) ." Search: "
context #VOCS 0 do dup i cells + @ (.voc) loop drop cr
." Definitions: " current @ (.voc) cr ;
\ vandys
\ Set vocabulary to receive definitions
: definitions context @ current ! ('endDef) @execute ;
\ "only" is defined in kernel.f, as it is needed by the metacompilation
\ process.
\ vandys
\ Push string pointer and count; implement by mapping c"
: s" [compile] c" (compile) count ; immediate compile-only
\ No-op
: nop ;
\ Create namespace for drivers
vocabulary drivers
\ Namespace for OS functions
vocabulary os
\ Non-core extensions
vocabulary extensions
\ Filesystem
vocabulary fs
\ vandys
( Case Words )
( Found in Taygeta archives, ported from FIG to eForth by Andy Valencia )
: (of) over = if drop r> cell+ >r else r> @ >r then ;
: case csp @ !csp 4 ; immediate compile-only
: of 4 ?pairs (compile) (of) here 0 , 5 ; immediate compile-only
: endof 5 ?pairs (compile) branch
here 0 , swap [compile] then 4 ; immediate compile-only
\ vandys
: endcase 4 ?pairs
(compile) drop
begin sp@ csp @ <> while
[compile] then
repeat csp ! ; immediate compile-only
( CASE 1 OF do something ENDOF {repeat as necessary} )
( may do something if no case match ENDCASE )
\ vandys
\ "Conversion" to units of characters
: chars ;
: char+ 1+ ;
: char- 1- ;
\ Prepare to EXIT from a routine from within a loop
\ (drop loop address and low and high parameters for loop...
\ restore return address from this word after dropping them.)
: unloop r> r> drop r> drop r> drop >r ;
\ Process triples on stack
: 3dup ( n1 n2 n3 -- n1 n2 n3 n1 n2 n3 ) >r 2dup r@ -rot r> ;
: 3drop ( n1 n2 n3 -- ) 2drop drop ;
: (rollback) ( n ... count -- ... n ) abs
dup tmp ! begin ?dup while
swap >r 1- repeat
tmp @ begin ?dup while r> -rot 1- repeat ;
: roll ( ... n count -- ...n... ) dup 0< if (rollback) exit then
dup tmp ! begin ?dup while 1- rot >r repeat
tmp @ begin ?dup while 1- r> swap repeat ;
\ vandys
: evaluate ( a u -- )
>r >r blk @ #tib @ tib @ >in @
'prompt @ ['] nop 'prompt !
0 blk ! r> tib ! r> #tib !
0 >in ! eval
'prompt ! >in ! tib ! #tib !
blk ! ;
create fence
here _fence ! 0 ,
: (forget-entries) ( nfap -- ) begin dup @ ?dup while
tmp @ over <= if nfa>lfa @ over ! else nip nfa>lfa then
repeat drop ;
: forget ' ca>nfa dup fence @ <= abort" Below fence"
tmp ! current begin cell+ dup @ ?dup while
tmp @ over <= if cell+ @ over ! cell- else
nip dup (forget-entries) then
repeat drop tmp @ nfa>cfa cp ! ;
\ Some numeric utilities, word-oriented dumping vandys
: s>d ( u -- d ) 0 ;
: 0> ( u -- bool ) 0 > ;
: 0<> ( u -- bool ) 0 = not ;
: d= ( xd1 xd2 -- bool ) >r rot = swap r> = and ;
: (dumpw) ( a u -- )
base @ -rot hex tuck 0 do
i cells over + i 4 mod 0= if dup 8 u.r ." : " then
@ 8 u.r i 1+ 4 mod 0= if cr else bl emit then
loop drop 4 mod if cr then base ! ;
: dumpw ( a u -- ) cr (dumpw) ;
\ vandys
\ Compile time "char"
: [char] char [compile] literal ; immediate
\ FPC/F83 utility words
: bounds ( a n -- a' a ) over + swap ;
: (exec:) ( n -- | Returns to caller of calling word )
cells r> + @execute ;
: exec: 10000 gensusp ! (compile) (exec:) ; immediate
\ Conditional number parsing
: number? ( a -- n T | F ) 'number @ catch 0= ;
\ Other variations of unsigned compare
: u> u<= not ;
: u>= u< not ;
\ vandys
code bcmp ( a1 a2 n -- <bool> )
ecx pop
edi pop
eax pop
esi push eax esi mov
repz byte cmps
3 $ jne
1 $ jecxz
3 $:
1 # eax mov
2 $ jmp
1 $: 0 # eax mov
2 $:
esi pop
eax push
next c;
\ vandys
code _strpos ( a ptr u -- n )
\ 16 12 8
4 [esp] eax mov esi push eax push
1 $: 8 [esp] ecx mov ecx ecx or 4 $ jle
ecx ecx xor 16 [esp] esi mov 0 [esi] cl mov esi inc
12 [esp] edi mov repz byte cmps
2 $ jne 5 $ jecxz
2 $: 8 [esp] dec 12 [esp] inc 1 $ jmp
5 $: 12 [esp] eax mov ebx pop ebx eax sub 3 $ jmp
4 $: eax pop -1 # eax mov
3 $: esi pop 12 # esp add eax push next c;
: strpos ( a ptr u -- n ) rot dup >r -rot r> c@ 1- - _strpos ;
\ vandys
code _strrpos ( a ptr u -- ptr' )
\ 12 8 4
esi push
1 $: 4 [esp] ecx mov ecx ecx or 4 $ jle
ecx ecx xor 12 [esp] esi mov 0 [esi] cl mov esi inc
8 [esp] edi mov repz byte cmps
2 $ jne 5 $ jecxz
2 $: 4 [esp] dec 8 [esp] dec 1 $ jmp
5 $: 4 [esp] eax mov eax dec 3 $ jmp
4 $: -1 # eax mov
3 $: esi pop 12 # esp add eax push next c;
: strrpos ( a ptr u -- n ) rot dup >r -rot r> c@
1- - swap over + 1- swap _strrpos ;
\ Conditional compilation constructs vvandys
: ($streq) ( s1 s2 -- ? ) 2dup c@ swap c@ - if 2drop false exit then
char+ swap count 0 do 2dup c@ swap c@ - if
unloop 2drop false exit then
char+ swap char+ loop 2drop true ;
: (unhook) ( -- ) tmp1 @ 'eval ! ;
: ($preproc) ( a -- ) c" [if]" over ($streq) if
drop 1 tmp2 inc exit then
c" [else]" over ($streq) if drop
tmp2 @ 1 = if (unhook) then exit then
c" [then]" ($streq) if tmp2 dec
tmp2 @ 0= if (unhook) then then ;
: (prehook) ( -- ) 'eval @ tmp1 ! 1 tmp2 !
['] ($preproc) 'eval ! ;
: [if] ( ? -- ) 0= if (prehook) then ; immediate
: [else] ( -- ) (prehook) ; immediate
: [then] ( -- ) ; immediate
: [ifdef] ( -- ) token name? nip [compile] [if] ; immediate
: [ifndef] ( -- ) token name? nip 0= [compile] [if] ; immediate
\ Double math vvandys
code d+ ( d1 d2 -- d ) edx pop eax pop 4 [esp] eax add
0 [esp] edx adc eax 4 [esp] mov edx 0 [esp] mov next c;
code d< ( d1 d2 -- ? ) ebx pop eax pop edx pop ecx pop
ebx edx cmp 1 $ je 2 $ jg
3 $: true push# next
1 $: eax ecx cmp 2 $ je 3 $ jl
2 $: false push# next c;
: vocabulary Create a vocabulary
Build vocabulary entry
Link onto list of all vocabularies
: also Duplicate head of vocabulary list
: -also Pop head off vocabulary search list, but always keep two
: (.voc) Back up pointer, get vocabulary name, and print
: order Display order of vocabularies and current definition target
: 3dup Duplicate top three items on stack
: 3drop Drop top three items on stack
: (rollback) Roll number back out of position on stack. Non-standard.
Note: can't use do...loop's, as we are using the return stack.
: roll Insert item into position on stack
vandys
: evaluate Load source from string
Save old state
Set prompt to quiet
Point to input string
Process this line
Restore input state
fence--safety net for what can be forgotten
: (forget-entries) Walk a vocabulary name chain and delete entries
which are at or above the forgotten entry.
: forget Forget the named word, and all above it. Handles forgetting
a vocabulary, but not the case where the vocabulary is still in
the search order (or the current definition vocabulary)
Restore "here" to start of this word's allocation
: s>d Convert single precision to double
Compare to 0
: d= Compare double numbers
: (dumpw) Dump cells instead of dump's byte orientation, in hex
Dump in hex, iterate across count of words
Next address, display it every 4
Display contents, terminate after every 4
Iterate... at end, put a trailing CR if needed, restore base
: dumpw User friendly; put a CR first
Pop arguments; esi gets popped into eax so we can save the
old value
code strpos Location of counted string at "a" is found in the buffer
at "ptr" whose length is "u" bytes. An index from 0 to u, or -1.
Set up for search; keep old base pointer to generate found index.
Also record ESI, as wel will be using this in the string instructions
Check count, leave if we're off the end of the buffer to search
Search for the target string at this position in the buffer
Loop iteration; advance buffer pointer and decrement buffer count
Search success, generate buffer index for successful search
Search failure, return -1
Restore ESI and return result.
: strpos We fix up the buffer count so the string length does not index
beyond the end of the buffer
code strpos Location of counted string at "a" is found in the buffer
at "ptr" whose length is "u" bytes. An index from 0 to u, or -1.
Set up for search; keep old base pointer to generate found index.
Also record ESI, as wel will be using this in the string instructions
Check count, leave if we're off the end of the buffer to search
Search for the target string at this position in the buffer
Loop iteration; advance buffer pointer and decrement buffer count
Search success, generate buffer index for successful search
Search failure, return -1
Restore ESI and return result.
: strpos We fix up the buffer count so the string length does not index
beyond the end of the buffer
: ($streq) $strcmp ain't available here (groan) and we don't need
to know about lexical ordering, so here's a quick & dirty compare
: (unhook) Restore 'eval vector at completion of conditional compilation
: ($preproc) Implement conditional compilation constructs
[if] Nest one level deeper (nest count in tmp2)
[else] Start processing source normally if at level 1 (skipped
[if] part due to false condition), otherwise just update count
: (prehook) Hook up our preprocessor 'eval vector, saving the old
one for when we're done.
: [if] If true, just let text get eaten, otherwise start
discarding text by invoking (prehook)
: [else] This would've been eaten if we were in [if] (prehook) mode,
so here it means the [if] part was true and *now* we start (prehook).
: [then] No-op; [then]'s action is implemented by being recognized in
($preproc) above.
: [ifdef] Test for presence of ID; lets us skip having flag names
sitting around some common cases
Double compare d2 -> ebx/eax d1 -> edx/ecx