Code Comments
Programming Forum and web based access to our favorite programming groups.
latest eforth in osimplay
This is Linux eforth in osimplay, formerly shasm, an x86 assember in Bash.
I'm guessing it's about half debugged. It doesn't get to a Forth OK
prompt. It gets about halfway through the init sequence.
It should be easier than H3sm to install as a Linux kernel daemon because
it doesn't have any symbols GNU tools can see.
# osimplay eforth dictionary header macros
frefi=0 # fwd ref uniquifier
_user=0
# reset per pass
__CODE () { # 3 args... len 4thname labelname
HL
HL
frefi=$((frefi+1))
aq ${fref[frefi]} # CFA
aq $LFA # LFA
LFA=$H # LFA for next word
ab $1 # length byte
ascii $2 # Forth name string
L $3 # code
fref[frefi]=$H
# second pass will be fwd-ref-able
}
__USER () { # code word uvars, easy as osimplay
__CODE $1 $2 $3
hike_xtp
push B
= $((suser+_user)) to B
next_
_user=$((_user+4))
}
__COLON () {
__CODE $1 $2 $3
call DOLST
}
hike_xtp () { # Enter Threader, hike xtp
+ 4 to SI
}
next_ () {
jump SI # x86 only does indirect absolute with a reg
}
truefl=-1 # True flag
compbit=0x40 # Lexicon compile - only bit
immedbit=0x80 # ...immediate
cellmask=-4 # Mask offset within cell
cbits=32 # bits in a word ( cell )
vocs=8 # Depth of vocabulary stack
# ASCII constants
BKSPP=8 # Backspace
DELETE=127 # Delete
LF=0xA # Line feed
_CR_=0xD # Carriage return
ERR=0x1B # Error escape
CALLL=0xE8909090 # CALL opcode , padded with NOPs to word
LFA=0 # first link field, zero
ELF # unix executable header
# That's the linker.
# osimplay has one segment.
# above heap (in mem) is unallocated.
L main # main(), _start...
increasing
= 0xFEDAC0ED to B
= B to @ $suser
= @ $suser to B
= 4 to C
= 1 to D
= 4 to DI
push B
push B
# Linuxism, set user variable imsp to whatever the OS gave us.
= SP to @ $imsp
= suser to BP
= COLD1 to SI
next_ back into the threader
__CODE 3 "bye" BYE
= 0 to B
L lxEXIT
= 1 to A
submit 0x80
halt
jump lxEXIT
L IOBuf
aq 0
L BAIL # unheadered threadable x86 osimplay regspew
# register dump to stderr
regspew
= 1 to A
submit 128
__CODE 3 "?rx" QRX # ( -- c T | F )
hike_xtp
push B
= 3 to A # SYS_read
= 0 to B # from stdin
push B # only low byte may be non - zero
= SP to C # into Input Buffer
= 1 to D # 1 char
submit 0x80 # call Linux
increasing # wtf
negate A # !!! truefl is -1
when not zero qrx1
pull B # pop the input buffer
L qrx1
= A to B
next_
__CODE 3 "tx!" TXSTO # ( c -- )
hike_xtp
# movzbl BL to B
ab 0x0f 0xb6 0xdb
push B
= 4 to A # SYS_write
= 1 to B # to stdout
address @ SP to C # from output buffer # !!!
= B to D # 1 char# !!! %ebx must contain 1
submit 0x80
increasing # wtf
pull A # pop the output buffer
pull B
next_
__CODE 3 "!io" STOIO # Initialize the serial I/O devices
hike_xtp # looks wtf broke
next_
__CODE $((compbit+5)) "doVar" DOVAR # ( -- a )
hike_xtp
push B
= SI to B
# = @ BP to SI # OSIMPLAY BUG
ab 0x8b 0x75 0
+ 4 to BP
next_
__CODE 2 "up" UP # ( -- a ) Pointer to the user area.
hike_xtp
push B
= up2 to B
next_
L up2 # root unalloc USER range
aq UPP
#__CODE $((compbit+6)) "doUser" DOUSE
# hike_xtp
# = @ SI to A # assembles OK, xtp to A
# + up2 to A # address of abs addr of user unalloc area
# # added to
# push B
# = A to B
# = @ BP to SI # OSIMPLAY BUG
# ab 0x8b 0x75 0
# + 4 to BP
# next_
__CODE $((compbit+5)) "doLit" DOLIT ##
push B # TOSC to SOS
= @ 4 + SI to B # lit to TOSCache
+ 8 to SI # 2hike xtp
next_
__CODE $((compbit+6)) "doList" DOLST
# This is "call"ed & grabs its ret addy
hike_xtp # + 4 to SI
- 4 to BP # push current PC on forth return stack
# = SI to @ BP # wtf OSIMPLAY BUG
ab 0x89 0x75 0 # per gas
pull SI # ret address in caller to xt ptr
next_ # jump indirect absolute SI
__CODE $((compbit+4)) "next" DONXT
hike_xtp
- 1 to @ BP
when carry nextf
= @ SI to SI
next_
L nextf
+ 4 to BP
+ 4 to SI
next_
__CODE $((compbit+7)) "?branch" ZBRANCH
# got here OK
OR B to B # zero?
pull B # drop
when zero BRAN
+ 8 to SI
next_
__CODE $((compbit+6)) "branch" BRAN
hike_xtp
= @ SI to SI
next_
__CODE 7 "execute" EXECU
# swap B to @ SP
ab 0x87 0x1c 0x24
return
__CODE 4 "exit" EXIT
hike_xtp
# = @ BP to SI # OSIMPLAY BUG
ab 0x8b 0x75 0
+ 4 to BP
next_
__CODE 1 "!" STORE
hike_xtp
pull @ B
pull B
next_
__CODE 1 "@" AT
hike_xtp
= @ B to B
next_
__CODE 2 "c!" CSTOR
hike_xtp
pull A
= byte AL to @ B
pull B
next_
__CODE 2 "c@" CAT
hike_xtp
# movzbl @ B to B
ab 0x0f 0xb6 0x1b
next_
__CODE 3 "rp@" RPAT
hike_xtp
push B
= BP to B
next_
__CODE $((compbit+3)) "rp!" RPSTO
hike_xtp
= B to BP
pull B
next_
__CODE $((compbit+2)) "r>" RFROM
hike_xtp
push B
# = @ BP to B #osimplay bug
ab 0x8b 0x5d 0x00
+ 4 to BP
next_
__CODE 2 "r@" RAT
hike_xtp
push B
# = @ BP to B #osimplay bug
ab 0x8b 0x5d 0x00
next_
__CODE $((compbit+2)) ">r" TOR
hike_xtp
- 4 to BP
# = B to @ BP #osimplay bug
ab 0x89 0x5d 0
pull B # clever stack cell decr.
next_
__CODE 3 "sp@" SPAT
hike_xtp
push B
= SP to B
next_
__CODE 3 "sp!" SPSTO
hike_xtp
= B to SP # Forth data stack
pull B
next_
__CODE 4 "drop" DROP
hike_xtp
pull B
next_
__CODE 3 "dup" DUPP
hike_xtp
push B
next_
__CODE 4 "swap" SWAP
hike_xtp
# swap B to @ SP
ab 0x87 0x1c 0x24
next_
__CODE 4 "over" OVER
hike_xtp
push B
= 4 @ SP to B
next_
__CODE 2 "0<" ZLESS
hike_xtp
= B to A
# cdq
ab 0x99
= D to B
next_
__CODE 3 "and" ANDD
hike_xtp
pull A
AND A to B
next_
__CODE 2 "or" ORR
hike_xtp
pull A
OR A to B
next_
__CODE 3 "xor" XORR
hike_xtp
pull A
next_
__CODE 3 "um+" UPLUS
hike_xtp
+ B to @ SP
address 0 to B
+carry B to B
next_
__CODE 5 "cmove" CMOVE # ( src dst rng --- ) bytewise move segm
hike_xtp
= B to C # TOS to count
pull DI # 2OS to dest
pull A # 3OS to accu
push SI # stash xtp
= A to SI # 3OS to source
copies bytes # blammo
pull SI # snatch xtp#
pull B # cache new TOS in B
next_
__CODE 4 "fill" FILL
hike_xtp
= B to A
pull C
pull DI
fill bytes
pull B
# wtf no next_ ?
__CODE 1 " + " PLUS
hike_xtp
pull A
+ A to B
next_
__CODE 1 "=" EQUAL
hike_xtp
pull A
-test A to B
when not zero sfalse
= $truefl to B
next_
__CODE 1 "<" LESS
hike_xtp
pull A
-test B to A # beware the inversion !!!
# jge ## hence the obscure test I guess
ab 0x0f 0x8d
branch sfalse 4
= $truefl to B
next_
L sfalse
= 0 to B
next_
__CODE 5 "cell+" CELLP
hike_xtp
+ 4 to B
next_
__CODE 5 "cell-" CELLM
hike_xtp
- 4 to B
next_
__CODE 5 "cells" CELLS
hike_xtp
upshift 2 to B
next_
_user=0
__USER 3 "uu0" UUzero
__USER 3 "uu1" UUone
__USER 3 "uu2" UUtwo
__USER 3 "uu3" UUthree
__USER 3 "sp0" SZERO
__USER 3 "rp0" RZERO
__USER 5 "'?key" TQKEY
__USER 5 "'emit" TEMIT
__USER 7 "'expect" TEXPE
__USER 4 "'tap" TTAP
__USER 5 "'echo" TECHO
__USER 7 "'prompt" TPROM
__USER 4 "base" BASE
__USER $((compbit+3)) "tmp" TEMP
__USER 4 "span" SPAN
__USER 3 ">in" INN
__USER 4 "#tib" NTIB
_user=$((_user+4))
__USER 3 "csp" CSP
__USER 5 "'eval" TEVAL
__USER 7 "'number" TNUMB
__USER 3 "hld" HLD
__USER 7 "handler" HANDL
__USER 7 "context" CNTXT # vocs stack?
_user=$((_user+vocs*4))
__USER 7 "current" CRRNT
_user=$((_user+4))
__USER 2 "cp" CP
__USER 2 "np" NP
__USER 4 "last" LAST
__USER 4 "argc" CARGC
__USER 4 "argv" CARGV
__USER 7 "environ" CENVIRON
L UZERO
HL
aq 0 0 0 0
L imsp
HL
aq 0 # initial Machine Stack Pointer
aq suser
aq QRX
aq TXSTO
HL
aq ACCEP
aq KTAP
aq ACCEP
aq KTAP
HL
aq TXSTO
aq DOTOK
aq 10 # BASEE
aq 0
HL
aq 0
aq 0
aq 0
aq TIBB
HL
aq 0
aq INTER
aq NUMBQ
aq 0
HL
aq 0
aq 0
HL
aq 0 0 0 0 0 0 0 0 # CNTXT voc stack
HL
aq 0
aq 0
HL
aq CTOP
aq NTOP
aq LASTN
L ULAST
__COLON $((compbit+5)) "doVoc" DOVOC
aq RFROM CNTXT STORE EXIT
__COLON 5 "Forth" FORTH
aq DOVOC
aq 0
aq 0
__COLON 4 "?dup" QDUP
aq DUPP
aq ZBRANCH QDUP1
aq DUPP
L QDUP1
aq EXIT
__COLON 3 "rot" ROT
aq TOR SWAP RFROM SWAP EXIT
__COLON 5 "2drop" DDROP
aq DROP DROP EXIT
__COLON 4 "2dup" DDUP
aq OVER OVER EXIT
__COLON 3 "not" INVER
aq DOLIT -1 XORR EXIT
__COLON 6 "negate" NEGAT
aq INVER DOLIT 1 PLUS EXIT
__COLON 7 "dnegate" DNEGA
aq INVER TOR INVER
aq DOLIT 1 UPLUS
aq RFROM PLUS EXIT
__COLON 1 "-" SUBB
aq NEGAT PLUS EXIT
__COLON 3 "abs" ABSS
aq DUPP ZLESS
aq ZBRANCH ABS1
aq NEGAT
L ABS1
aq EXIT
__COLON 2 "u<" ULESS
aq DDUP XORR ZLESS
aq ZBRANCH ULES1
aq SWAP DROP ZLESS EXIT
L ULES1
aq SUBB ZLESS EXIT
__COLON 3 "max" MAX
aq DDUP LESS
aq ZBRANCH MAX1
aq SWAP
L MAX1
aq DROP EXIT
__COLON 3 "min" MIN
aq DDUP SWAP LESS
aq ZBRANCH MIN1
aq SWAP
L MIN1
aq DROP EXIT
__COLON 6 "within" WITHI
aq OVER SUBB TOR
aq SUBB RFROM ULESS EXIT
__COLON 6 "um/mod" UMMOD
aq DDUP ULESS
aq ZBRANCH UMM4
aq NEGAT DOLIT cbits -1 TOR
L UMM1
aq TOR DUPP UPLUS
aq TOR TOR DUPP UPLUS
aq RFROM PLUS DUPP
aq RFROM RAT SWAP TOR
aq UPLUS RFROM ORR
aq ZBRANCH UMM2
aq TOR DROP DOLIT 1 PLUS RFROM
aq BRAN UMM3
L UMM2
aq DROP
L UMM3
aq RFROM
aq DONXT UMM1
aq DROP SWAP EXIT
L UMM4
aq DROP DDROP
aq DOLIT -1 DUPP EXIT
__COLON 5 "m/mod" MSMOD
aq DUPP ZLESS DUPP TOR
aq ZBRANCH MMOD1
aq NEGAT TOR DNEGA RFROM
L MMOD1
aq TOR DUPP ZLESS
aq ZBRANCH MMOD2
aq RAT PLUS
L MMOD2
aq RFROM UMMOD RFROM
aq ZBRANCH MMOD3
aq SWAP NEGAT SWAP
L MMOD3
aq EXIT
__COLON 4 "/mod" SLMOD
aq OVER ZLESS SWAP MSMOD EXIT
__COLON 3 "mod" MODD
aq SLMOD DROP EXIT
__COLON 1 "/" SLASH
aq SLMOD SWAP DROP EXIT
__COLON 3 "um*" UMSTA
aq DOLIT 0 SWAP DOLIT cbits -1 TOR
L UMST1
aq DUPP UPLUS TOR TOR
aq DUPP UPLUS RFROM PLUS RFROM
aq ZBRANCH UMST2
aq TOR OVER UPLUS RFROM PLUS
L UMST2
aq DONXT UMST1
aq ROT DROP EXIT
__COLON 1 "\*" STAR
aq UMSTA DROP EXIT
__COLON 2 "m*" MSTAR
aq DDUP XORR ZLESS TOR
aq ABSS SWAP ABSS UMSTA
aq RFROM
aq ZBRANCH MSTA1
aq DNEGA
L MSTA1
aq EXIT
__COLON 5 "*/mod" SSMOD
aq TOR MSTAR RFROM MSMOD EXIT
__COLON 2 "*/" STASL
aq SSMOD SWAP DROP EXIT
__COLON 7 "aligned" ALGND
aq DUPP DOLIT 0 DOLIT 4
aq UMMOD DROP DUPP
aq ZBRANCH ALGN1
aq DOLIT 4 SWAP SUBB
L ALGN1
aq PLUS EXIT
__COLON 2 "bl" BLANK
aq DOLIT 32 EXIT
__COLON 5 ">char" TCHAR
aq DOLIT 0x7F ANDD DUPP
aq DOLIT 0x7F BLANK WITHI
aq ZBRANCH TCHA1
aq DROP DOLIT 95
L TCHA1
aq EXIT
__COLON 5 "depth" DEPTH
aq SPAT SZERO AT SWAP SUBB
aq DOLIT 4 SLASH EXIT
__COLON 4 "pick" PICK
aq DOLIT 1 PLUS CELLS
aq SPAT PLUS AT EXIT
__COLON 2 "+!" PSTOR
aq SWAP OVER AT PLUS
aq SWAP STORE EXIT
__COLON 2 "2!" DSTOR
aq SWAP OVER STORE
aq CELLP STORE EXIT
__COLON 2 "2@" DAT
aq DUPP CELLP AT
aq SWAP AT EXIT
__COLON 5 "count" COUNT
aq DUPP DOLIT 1 PLUS
aq SWAP CAT EXIT
__COLON 4 "here" HERE
aq CP AT EXIT
__COLON 3 "tib" TIB
aq NTIB CELLP AT EXIT
__COLON 8 "@execute" ATEXE
aq AT QDUP
aq ZBRANCH EXE1
aq EXECU
L EXE1
aq EXIT
next_
__COLON 9 "-trailing" DTRAI
aq TOR
aq BRAN DTRA2
L DTRA1
aq BLANK OVER RAT PLUS CAT LESS
aq ZBRANCH DTRA2
aq RFROM DOLIT 1 PLUS EXIT
L DTRA2
aq DONXT DTRA1
aq DOLIT 0 EXIT
__COLON 5 "pack\$" PACKS
aq ALGND DUPP TOR
aq OVER DUPP DOLIT 0
aq DOLIT 4 UMMOD DROP
aq SUBB OVER PLUS
aq DOLIT 0 SWAP STORE
aq DDUP CSTOR DOLIT 1 PLUS
aq SWAP CMOVE RFROM EXIT
__COLON 5 "digit" DIGIT
aq DOLIT 9 OVER LESS
aq DOLIT 7 ANDD PLUS
aq DOLIT 48 PLUS EXIT
__COLON 7 "extract" EXTRC
aq DOLIT 0 SWAP UMMOD
aq SWAP DIGIT EXIT
__COLON 2 "<#" BDIGS
aq PAD HLD STORE EXIT
__COLON 4 "hold" HOLD
aq HLD AT DOLIT 1 SUBB
aq DUPP HLD STORE CSTOR EXIT
__COLON 1 "#" DIG
aq BASE AT EXTRC HOLD EXIT
__COLON 2 "#s" DIGS
L DIGS1
aq DIG DUPP
aq ZBRANCH DIGS2
aq BRAN DIGS1
L DIGS2
aq EXIT
__COLON 4 "sign" SIGN
aq ZLESS
aq ZBRANCH SIGN1
aq DOLIT 45 HOLD
L SIGN1
aq EXIT
__COLON 2 "#>" EDIGS
aq DROP HLD AT
aq PAD OVER SUBB EXIT
__COLON 3 "str" STR
aq DUPP TOR ABSS
aq BDIGS DIGS RFROM
aq SIGN EDIGS EXIT
__COLON 3 "hex" HEX
aq DOLIT 16 BASE STORE EXIT
__COLON 7 "decimal" DECIM
aq DOLIT 10 BASE STORE EXIT
__COLON 6 "digit?" DIGTQ
aq TOR DOLIT 48 SUBB
aq DOLIT 9 OVER LESS
aq ZBRANCH DGTQ1
aq DOLIT 7 SUBB
aq DUPP DOLIT 10 LESS ORR
L DGTQ1
aq DUPP RFROM ULESS EXIT
__COLON 7 "number?" NUMBQ
aq BASE AT TOR DOLIT 0 OVER COUNT
aq OVER CAT DOLIT 36 EQUAL
aq ZBRANCH NUMQ1
aq HEX SWAP DOLIT 1 PLUS
aq SWAP DOLIT 1 SUBB
L NUMQ1
aq OVER CAT DOLIT 45 EQUAL TOR
aq SWAP RAT SUBB SWAP RAT PLUS QDUP
aq ZBRANCH NUMQ6
aq DOLIT 1 SUBB TOR
L NUMQ2
aq DUPP TOR CAT BASE AT DIGTQ
aq ZBRANCH NUMQ4
aq SWAP BASE AT STAR PLUS RFROM
aq DOLIT 1 PLUS
aq DONXT NUMQ2
aq RAT SWAP DROP
aq ZBRANCH NUMQ3
aq NEGAT
L NUMQ3
aq SWAP
aq BRAN NUMQ5
L NUMQ4
aq RFROM RFROM DDROP DDROP DOLIT 0
L NUMQ5
aq DUPP
L NUMQ6
aq RFROM DDROP
aq RFROM BASE STORE EXIT
__COLON 4 "?key" QKEY
aq TQKEY ATEXE EXIT
__COLON 3 "key" KEY
L KEY1
aq QKEY
aq ZBRANCH KEY1
aq EXIT
__COLON 4 "emit" EMIT
aq TEMIT ATEXE EXIT
__COLON 4 "nuf?" NUFQ
aq QKEY DUPP
aq ZBRANCH NUFQ1
aq DDROP KEY
aq DUPP DOLIT LF EQUAL SWAP
aq DOLIT _CR_ EQUAL ORR
L NUFQ1
aq EXIT
__COLON 4 "pace" PACE
aq DOLIT 11 EMIT EXIT
__COLON 5 "space" SPACE
aq BLANK EMIT EXIT
__COLON 6 "spaces" SPACES
aq DOLIT 0 MAX TOR
aq BRAN CHAR2
L CHAR1
aq SPACE
L CHAR2
aq DONXT CHAR1
aq EXIT
__COLON 4 "type" TYPES
aq TOR
aq BRAN TYPE2
L TYPE1
aq DUPP CAT EMIT
aq DOLIT 1 PLUS
L TYPE2
aq DONXT TYPE1
aq DROP EXIT
__COLON 2 "cr" CR
aq DOLIT LF EMIT
aq EXIT
__COLON $((compbit+3)) "do\$" DOSTR
aq RFROM RAT RFROM COUNT PLUS
aq ALGND TOR SWAP TOR EXIT
__COLON $((compbit+3)) "\$\$|" STRQP
aq DOSTR EXIT
__COLON $((compbit+3)) ".\"|" DOTQP
aq DOSTR COUNT TYPES EXIT
__COLON 2 ".r" DOTR
aq TOR STR RFROM OVER SUBB
aq SPACES TYPES EXIT
__COLON 3 "u.r" UDOTR
aq TOR BDIGS DIGS EDIGS
aq RFROM OVER SUBB
aq SPACES TYPES EXIT
__COLON 2 "u." UDOT
aq BDIGS DIGS EDIGS
aq SPACE TYPES EXIT
__COLON 1 "." DOT
aq BASE AT DOLIT 10 XORR
aq ZBRANCH DOT1
aq UDOT EXIT
L DOT1
aq STR SPACE TYPES EXIT
__COLON 1 "?" QUEST
aq AT DOT EXIT
__COLON 5 "PARSE" PARS
aq TEMP STORE OVER TOR DUPP
aq ZBRANCH PARS8
aq DOLIT 1 SUBB TEMP AT BLANK EQUAL
aq ZBRANCH PARS3
aq TOR
L PARS1
aq BLANK OVER CAT
aq SUBB ZLESS INVER
aq ZBRANCH PARS2
aq DOLIT 1 PLUS
aq DONXT PARS1
aq RFROM DROP DOLIT 0 DUPP EXIT
L PARS2
aq RFROM
L PARS3
aq OVER SWAP
aq TOR
L PARS4
aq TEMP AT OVER CAT SUBB
aq TEMP AT BLANK EQUAL
aq ZBRANCH PARS5
aq ZLESS
L PARS5
aq ZBRANCH PARS6
aq DOLIT 1 PLUS
aq DONXT PARS4
aq DUPP TOR
aq BRAN PARS7
L PARS6
aq RFROM DROP DUPP
aq DOLIT 1 PLUS TOR
L PARS7
aq OVER SUBB
aq RFROM RFROM SUBB EXIT
L PARS8
aq OVER RFROM SUBB EXIT
__COLON 5 "parse" PARSE
aq TOR TIB INN AT PLUS
aq NTIB AT INN AT SUBB
aq RFROM PARS
aq INN PSTOR EXIT
__COLON $((immedbit+2)) ".(" DOTPR
aq DOLIT 41 PARSE TYPES EXIT
__COLON $((immedbit+1)) "(" PAREN
aq DOLIT 41 PARSE DDROP EXIT
__COLON $((immedbit+1)) "\\" BKSLA
aq NTIB AT INN STORE EXIT
__COLON 4 "char" CHAR
aq BLANK PARSE DROP CAT EXIT
__COLON 5 "token" TOKEN
aq BLANK PARSE
aq DOLIT 31 MIN
aq NP AT OVER SUBB CELLM
aq PACKS
aq EXIT
__COLON 4 "word" WORDD
aq PARSE HERE PACKS EXIT
__COLON 5 "name>" NAMET
aq CELLM CELLM AT EXIT
__COLON 5 "same?" SAMEQ
aq TOR
aq BRAN SAME2
L SAME1
aq OVER RAT CELLS PLUS AT
aq OVER RAT CELLS PLUS AT
aq SUBB QDUP
aq ZBRANCH SAME2
aq RFROM DROP EXIT
L SAME2
aq DONXT SAME1
aq DOLIT 0 EXIT
__COLON 5 "name?" NAMEQ
aq CNTXT DUPP DAT XORR
aq ZBRANCH NAMQ1
aq CELLM
L NAMQ1
aq TOR
L NAMQ2
aq RFROM CELLP DUPP TOR
aq AT QDUP
aq ZBRANCH NAMQ3
aq FIND QDUP
aq ZBRANCH NAMQ2
aq RFROM DROP EXIT
L NAMQ3
aq RFROM DROP
aq DOLIT 0 EXIT
__COLON 2 "^h" BKSP
aq TOR OVER RFROM SWAP OVER XORR
aq ZBRANCH BACK1
aq DOLIT BKSPP TECHO ATEXE DOLIT 1 SUBB
aq BLANK TECHO ATEXE
aq DOLIT BKSPP TECHO ATEXE
L BACK1
aq EXIT
__COLON 3 "tap" TAP
aq OVER CSTOR DOLIT 1 PLUS EXIT
__COLON 4 "kTap" KTAP
aq DUPP DOLIT LF XORR
aq ZBRANCH KTAP2
aq DOLIT DELETE XORR
aq ZBRANCH KTAP1
aq BLANK TAP EXIT
L KTAP1
aq BKSP EXIT
L KTAP2
aq DROP SWAP DROP DUPP EXIT
__COLON 6 "accept" ACCEP
aq OVER PLUS OVER
L ACCP1
aq DDUP XORR
aq ZBRANCH ACCP4
aq KEY DUPP
aq BLANK DOLIT 127 WITHI
aq ZBRANCH ACCP2
aq TAP
aq BRAN ACCP3
L ACCP2
aq TTAP ATEXE
L ACCP3
aq BRAN ACCP1
L ACCP4
aq DROP OVER SUBB EXIT
__COLON 6 "expect" EXPEC
aq TEXPE ATEXE SPAN STORE DROP EXIT
__COLON 5 "query" QUERY
# aq TIB DOLIT 80 TEXPE ATEXE NTIB STORE
aq TIB DOLIT 80 ACCEP NTIB STORE
aq DROP DOLIT 0 INN STORE EXIT
__COLON 5 "catch" CATCH
aq SPAT TOR HANDL AT TOR
aq RPAT HANDL STORE EXECU
aq RFROM HANDL STORE
aq RFROM DROP DOLIT 0 EXIT
__COLON 5 "throw" THROW
aq HANDL AT RPSTO
aq RFROM HANDL STORE
aq RFROM SWAP TOR SPSTO
aq DROP RFROM EXIT
__COLON 5 "null\$" NULLS
aq DOVAR
aq 0
ab 99 111 121 111 116 101
__COLON 5 "abort" ABORT
aq NULLS THROW
__COLON $((compbit+6)) "abort\"" ABORQ
aq ZBRANCH ABOR1
aq DOSTR THROW
L ABOR1
aq DOSTR DROP EXIT
__COLON 10 "\$interpret" INTER
aq NAMEQ QDUP # ?defined
aq ZBRANCH INTE1
aq AT DOLIT compbit ANDD # ?compile only lexicon bits
aq ABORQ
ab 13
ascii "_compile_only"
align 4 # wtf
aq EXECU EXIT
L INTE1
aq TNUMB ATEXE
aq ZBRANCH INTE2
aq EXIT
L INTE2
aq THROW
__COLON $((immedbit+1)) "[" LBRAC
aq DOLIT INTER TEVAL STORE EXIT
__COLON 3 ".ok" DOTOK
aq DOLIT INTER TEVAL AT EQUAL
aq ZBRANCH DOTO1
aq DOTQP
ab 9
ascii "___ok"
align 4 # wtf
L DOTO1
aq CR EXIT
__COLON 6 "?stack" QSTAC
aq DEPTH ZLESS
aq ABORQ
ab 10
ascii "_underflow"
align 4 # wtf
aq EXIT
__COLON 4 "eval" EVAL
L EVAL1
aq TOKEN DUPP CAT # ?input stream empty
aq ZBRANCH EVAL2
aq TEVAL ATEXE QSTAC # evaluate input check stack
aq BRAN EVAL1
L EVAL2
aq DROP TPROM ATEXE EXIT
# Reset data stack pointer and the terminal input buffer.
__COLON 6 "preset" PRESE
aq SZERO AT
aq SPSTO
aq DOLIT TIBB NTIB CELLP STORE
aq EXIT
__COLON $((compbit+3)) "xio" XIO
aq DOLIT ACCEP TEXPE DSTOR
aq TECHO DSTOR EXIT
__COLON 4 "file" FILE
aq DOLIT PACE DOLIT DROP
aq DOLIT KTAP XIO EXIT
__COLON 4 "hand" HAND
aq DOLIT DOTOK DOLIT EMIT
aq DOLIT KTAP XIO EXIT
__COLON 3 "i/o" ISLO
aq DOVAR
aq QRX TXSTO
__COLON 7 "console" CONSO
aq ISLO DAT TQKEY DSTOR
aq HAND EXIT
__COLON 4 "quit" QUIT
aq RZERO AT RPSTO
L QUIT1
aq LBRAC
L QUIT2
aq QUERY BYE
aq DOLIT EVAL CATCH QDUP BYE
aq ZBRANCH QUIT2
aq TPROM AT TOR
aq CONSO NULLS OVER XORR
aq ZBRANCH QUIT3
aq SPACE COUNT TYPES
aq DOTQP
ab 3
ascii "?"
align 4 # wtf
L QUIT3
aq RFROM DOLIT DOTOK XORR
aq ZBRANCH QUIT4
aq DOLIT ERR EMIT
L QUIT4
aq PRESE
aq BRAN QUIT1
__COLON 1 "'" TICK
aq TOKEN NAMEQ
aq ZBRANCH TICK1
aq EXIT
L TICK1
aq THROW
__COLON 5 "allot" ALLOT
aq CP PSTOR EXIT
__COLON 1 "," COMMA
aq HERE DUPP CELLP
aq CP STORE STORE EXIT
__COLON $((immedbit+9)) "[compile]" BCOMP
aq TICK COMMA EXIT
__COLON $((compbit+7)) "compile" COMPI
aq RFROM DUPP AT COMMA
aq CELLP TOR EXIT
__COLON $((immedbit+7)) "literal" LITER
aq COMPI DOLIT COMMA EXIT
__COLON 3 "\$," STRCQ
aq DOLIT 34 WORDD
aq COUNT PLUS ALGND
aq CP STORE EXIT
__COLON $((immedbit+7)) "recurse" RECUR
aq LAST AT NAMET COMMA EXIT
__COLON $((immedbit+3)) "for" FOR
aq COMPI TOR HERE EXIT
__COLON $((immedbit+5)) "begin" BEGIN
aq HERE EXIT
__COLON $((immedbit+4)) "next" NEXT
aq COMPI DONXT COMMA EXIT
__COLON $((immedbit+5)) "until" UNTIL
aq COMPI ZBRANCH COMMA EXIT
__COLON $((immedbit+5)) "again" AGAIN
aq COMPI BRAN COMMA EXIT
__COLON $((immedbit+2)) "if" IFF
aq COMPI ZBRANCH HERE
aq DOLIT 0 COMMA EXIT
__COLON $((immedbit+5)) "ahead" AHEAD
aq COMPI BRAN HERE DOLIT 0 COMMA EXIT
__COLON $((immedbit+6)) "repeat" REPEA
aq AGAIN HERE SWAP STORE EXIT
__COLON $((immedbit+4)) "then" THENN
aq HERE SWAP STORE EXIT
__COLON $((immedbit+3)) "aft" AFT
aq DROP AHEAD BEGIN SWAP EXIT
__COLON $((immedbit+4)) "else" ELSEE
aq AHEAD SWAP THENN EXIT
__COLON $((immedbit+5)) "while" WHILE
aq IFF SWAP EXIT
__COLON $((immedbit+6)) "abort\"" ABRTQ
aq COMPI ABORQ STRCQ EXIT
__COLON $((immedbit+2)) "\$\"" STRQ
aq COMPI STRQP STRCQ EXIT
__COLON $((immedbit+2)) ".\"" DOTQ
aq COMPI DOTQP STRCQ EXIT
__COLON 7 "?unique" UNIQU
aq DUPP NAMEQ
aq ZBRANCH UNIQ1
aq DOTQP
ab 7
ascii "reDef"
align 4 # wtf
aq OVER COUNT TYPES
L UNIQ1
aq DROP EXIT
__COLON 3 "\$,n" SNAME
aq DUPP CAT
aq ZBRANCH PNAM1
aq UNIQU
aq DUPP LAST STORE
aq HERE ALGND SWAP
aq CELLM
aq CRRNT AT AT OVER STORE
aq CELLM DUPP NP STORE
aq STORE EXIT
L PNAM1
aq STRQP
ab 5
ascii "name"
align 4 # wtf
aq THROW
__COLON 8 "\$compile" SCOMP
aq NAMEQ QDUP
aq ZBRANCH SCOM2
aq AT DOLIT immedbit ANDD
aq ZBRANCH SCOM1
aq EXECU EXIT
L SCOM1
aq COMMA EXIT
L SCOM2
aq TNUMB ATEXE
aq ZBRANCH SCOM3
aq LITER EXIT
L SCOM3
aq THROW
__COLON 5 "overt" OVERT
aq LAST AT CRRNT AT STORE EXIT
__COLON $((immedbit+compbit+1)) "#" SEMIS
aq COMPI EXIT LBRAC OVERT EXIT
__COLON 1 "]" RBRAC
aq DOLIT SCOMP TEVAL STORE EXIT
__COLON 5 "call," CALLC
aq DOLIT CALLL COMMA HERE
aq CELLP SUBB COMMA EXIT
__COLON 1 ":" COLON
aq TOKEN SNAME DOLIT DOLST
aq CALLC RBRAC EXIT
__COLON 9 "immediate" IMMED
aq DOLIT immedbit LAST AT AT ORR
aq LAST AT STORE EXIT
__COLON 4 "user" USER
aq TOKEN SNAME OVERT
aq DOLIT DOLST CALLC
aq DOLIT DOUSE COMMA
aq COMMA EXIT
__COLON 6 "create" CREAT
aq TOKEN SNAME OVERT
aq DOLIT DOLST CALLC
aq DOLIT DOVAR COMMA EXIT
__COLON 8 "variable" VARIA
aq CREAT DOLIT 0 COMMA EXIT
__COLON 5 "_type" UTYPE
aq TOR
aq BRAN UTYP2
L UTYP1
aq DUPP CAT TCHAR EMIT
aq DOLIT 1 PLUS
L UTYP2
aq DONXT UTYP1
aq DROP EXIT
__COLON 3 "dm+" DUMPP
aq OVER DOLIT 4 UDOTR
aq SPACE TOR
aq BRAN PDUM2
L PDUM1
aq DUPP CAT DOLIT 3 UDOTR
aq DOLIT 1 PLUS
L PDUM2
aq DONXT PDUM1
aq EXIT
__COLON 4 "dump" DUMP
aq BASE AT TOR HEX
aq DOLIT 16 SLASH
aq TOR
L DUMP1
aq CR DOLIT 16 DDUP DUMPP
aq ROT ROT
aq DOLIT 2 SPACES UTYPE
aq DONXT DUMP1
aq BRAN DUMP3
L DUMP2
aq RFROM DROP
L DUMP3
aq DROP RFROM BASE STORE
aq EXIT
__COLON 2 ".s" DOTS
aq CR DEPTH
aq TOR
aq BRAN DOTS2
L DOTS1
aq RAT PICK DOT
L DOTS2
aq DONXT DOTS1
aq DOTQP
ab 4
ascii "<sp"
align 4 # wtf
aq EXIT
__COLON 4 "!csp" STCSP
aq SPAT CSP STORE EXIT
__COLON 4 "?csp" QCSP
aq SPAT CSP AT XORR
aq ABORQ
ab 6
ascii "stacks"
align 4 # wtf
aq EXIT
__COLON 5 ">name" TNAME
aq CRRNT
L TNAM1
aq CELLP AT QDUP
aq ZBRANCH TNAM4
aq DDUP
L TNAM2
aq AT DUPP
aq ZBRANCH TNAM3
aq DDUP NAMET XORR
aq ZBRANCH TNAM3
aq CELLM
aq BRAN TNAM2
L TNAM3
aq SWAP DROP QDUP
aq ZBRANCH TNAM1
aq SWAP DROP SWAP DROP EXIT
L TNAM4
aq DROP DOLIT 0 EXIT
__COLON 3 ".id" DOTID
aq QDUP
aq ZBRANCH DOTI1
aq COUNT DOLIT 0x1F ANDD
aq UTYPE EXIT
L DOTI1
aq DOTQP
ab 9
ascii "{noName}"
align 4 # wtf
aq EXIT
__COLON 3 "see" SEE
aq TICK
aq CELLP
aq DUPP CELLP DOT DOLIT 10 SPACES
L SEELOOP
aq CELLP
aq DUPP AT
aq ZBRANCH DONESEE
aq DUPP AT
aq TNAME
aq DUPP ZBRANCH CHECKEND
aq DOTID DOLIT 2 SPACES
aq BRAN SEELOOP
L CHECKEND
aq DROP DUPP AT
aq DOLIT 0xE82E2E2E
aq EQUAL INVER
aq ZBRANCH DONESEE
aq SPACE
aq DUPP AT DOT
aq CR DUPP DOT DOLIT 10 SPACES
aq BRAN SEELOOP
L DONESEE
aq DROP EXIT
__COLON 5 "words" WORDS
aq CR CNTXT AT
L WORS1
aq AT QDUP
aq ZBRANCH WORS2
aq DUPP SPACE DOTID
aq CELLM
aq BRAN WORS1
aq DROP
L WORS2
aq EXIT
__COLON 3 "ver" VERSN
aq DOLIT 257 EXIT
__COLON 2 "hi" HI
aq STOIO
aq CR DOTQP
ab 11
ascii "eForth_v"
ab 49
ascii "."
ab 49
align 4 # wtf
aq CR EXIT
__COLON 5 "'boot" TBOOT
aq DOVAR
aq STOIO
__COLON 4 "find" FIND
aq SWAP DUPP CAT
aq DOLIT 4 SLASH TEMP STORE
aq DUPP AT TOR CELLP SWAP
L FIND1
aq AT DUPP
aq ZBRANCH FIND6
aq DUPP AT DOLIT 0x7F7F7F1F ANDD RAT XORR
aq ZBRANCH FIND2
aq CELLP DOLIT -1
aq BRAN FIND3
L FIND2
aq CELLP TEMP AT SAMEQ
L FIND3
aq BRAN FIND4
L FIND6
aq RFROM DROP
aq SWAP CELLM SWAP EXIT
L FIND4
aq ZBRANCH FIND5
aq CELLM CELLM
aq BRAN FIND1
L FIND5
aq RFROM DROP SWAP DROP
aq CELLM
aq DUPP NAMET SWAP EXIT
__COLON 4 "cold" COLD
L COLD1
aq DOLIT UZERO DOLIT suser
aq DOLIT 200
HL
aq CMOVE
aq PRESE # first __COLON in init flow
aq TBOOT
aq ATEXE
aq FORTH CNTXT
aq AT DUPP
aq CRRNT
aq DSTOR OVERT
aq QUIT
aq BRAN COLD1
HL
heap # unallocated space
allot 10000 # threading stack
L suser # dividing point between USER & Tstack
L UPP
userspan=200
allot $userspan
allot 10
L TIBB
allot 1000
memmax=$H
--
Rick (Richard Allen) Hohensee
platform ftp://linux01.gwdg.de/pub/cLIeNUX/interim/platform2
personal webpage http://linux01.gwdg.de/~rhohen
active in Usenet alt.politics colorg on IRC
humbubba@smart.net Maryland, USA
write-in candidate, President of the United States of America
Ground troops out of Iraq Put the CIA under INS Save Darfur
Semi-legalize drugs Prosecute Bush Tighten the borders
Isolate Israel Tax churches halve military aquisitions
government jobs for Iraq-wounded soldiers and 9-11 survivors
please email my platform to friends, blogs and countrymen
-------------------------------------------------------------
Post Follow-up to this message
Sponsored Links
Show a Printable Version
Email This Page to Someone!
Receive updates to this thread
Powered by vBulletin
Copyright 2000-2006 Jelsoft Enterprises Limited.
