Inlined more words.

This commit is contained in:
Brad Nelson
2022-02-06 18:59:45 -08:00
parent 4abd02ba94
commit 505a5c8c26
5 changed files with 57 additions and 38 deletions

View File

@ -20,17 +20,14 @@
: constant ( n "name" -- ) create , does> @ ;
: variable ( "name" -- ) create 0 , ;
( System Variables )
: sys: ( a -- a' "name" ) dup constant cell+ ;
'sys sys: 'heap sys: current sys: 'context
sys: 'latestxt sys: 'notfound
sys: 'heap-start sys: 'heap-size sys: 'stack-cells
sys: 'boot sys: 'boot-size
sys: 'tib sys: #tib sys: >in
sys: state sys: base
sys: 'argc sys: 'argv sys: 'runner
: context ( -- a ) 'context @ cell+ ;
: latestxt ( -- xt ) 'latestxt @ ;
( Stack Baseline )
sp@ constant sp0
rp@ constant rp0
fp@ constant fp0
: depth ( -- n ) sp@ sp0 - cell/ ;
: fdepth ( -- n ) fp@ fp0 - 4 / ;
( Useful heap size words )
: remaining ( -- n ) 'heap-start @ 'heap-size @ + 'heap @ - ;
: used ( -- n ) 'heap @ sp@ 'stack-cells @ cells + - 28 + ;
@ -64,13 +61,6 @@
: immediate? ( xt -- f ) >flags 1 and 0= 0= ;
: postpone ' dup immediate? if , else aliteral ['] , , then ; immediate
( Stack Convience )
sp@ constant sp0
rp@ constant rp0
fp@ constant fp0
: depth ( -- n ) sp@ sp0 - cell/ ;
: fdepth ( -- n ) fp@ fp0 - 4 / ;
( Rstack nest depth )
variable nest-depth

View File

@ -77,6 +77,18 @@
: >name ( xt -- a n ) dup >name-length swap >link& over aligned - swap ;
: >body ( xt -- a ) dup @ [ ' >flags @ ] literal = 2 + cells + ;
( System Variables )
: sys: ( a -- a' "name" ) dup constant cell+ ;
'sys sys: 'heap sys: current sys: 'context
sys: 'latestxt sys: 'notfound
sys: 'heap-start sys: 'heap-size sys: 'stack-cells
sys: 'boot sys: 'boot-size
sys: 'tib sys: #tib sys: >in
sys: state sys: base
sys: 'argc sys: 'argv sys: 'runner
: context ( -- a ) 'context @ cell+ ;
: latestxt ( -- xt ) 'latestxt @ ;
: f= ( r r -- f ) f- f0= ;
: f< ( r r -- f ) f- f0< ;
: f> ( r r -- f ) fswap f< ;

View File

@ -70,4 +70,24 @@
X(">link&", TOLINKAT, tos = (cell_t) TOLINK(tos)) \
X(">link", TOLINK, tos = *TOLINK(tos)) \
X(">name", TONAME, DUP; *sp = (cell_t) TONAME(tos); tos = *TONAMELEN(tos)) \
X(">body", TOBODY, tos = (cell_t) TOBODY(tos))
X(">body", TOBODY, tos = (cell_t) TOBODY(tos)) \
XV(internals, "'heap", THEAP, DUP; tos = (cell_t) &g_sys.heap) \
Y(current, DUP; tos = (cell_t) &g_sys.current) \
XV(internals, "'context", TCONTEXT, DUP; tos = (cell_t) &g_sys.context) \
XV(internals, "'latestxt", TLATESTXT, DUP; tos = (cell_t) &g_sys.latestxt) \
XV(internals, "'notfound", TNOTFOUND, DUP; tos = (cell_t) &g_sys.notfound) \
XV(internals, "'heap-start", THEAP_START, DUP; tos = (cell_t) &g_sys.heap_start) \
XV(internals, "'heap-size", THEAP_SIZE, DUP; tos = (cell_t) &g_sys.heap_size) \
XV(internals, "'stack-cells", TSTACK_CELLS, DUP; tos = (cell_t) &g_sys.stack_cells) \
XV(internals, "'boot", TBOOT, DUP; tos = (cell_t) &g_sys.boot) \
XV(internals, "'boot-size", TBOOT_SIZE, DUP; tos = (cell_t) &g_sys.boot_size) \
XV(internals, "'tib", TTIB, DUP; tos = (cell_t) &g_sys.tib) \
X("#tib", NTIB, DUP; tos = (cell_t) &g_sys.ntib) \
X(">in", TIN, DUP; tos = (cell_t) &g_sys.tin) \
Y(state, DUP; tos = (cell_t) &g_sys.state) \
Y(base, DUP; tos = (cell_t) &g_sys.base) \
XV(internals, "'argc", ARGC, DUP; tos = (cell_t) &g_sys.argc) \
XV(internals, "'argv", ARGV, DUP; tos = (cell_t) &g_sys.argv) \
XV(internals, "'runner", RUNNER, DUP; tos = (cell_t) &g_sys.runner) \
Y(context, DUP; tos = (cell_t) (g_sys.context + 1)) \
Y(latestxt, DUP; tos = (cell_t) g_sys.latestxt)

View File

@ -108,11 +108,6 @@ e: check-boot
out: next
out: for
out: nest-depth
out: fdepth
out: depth
out: fp0
out: rp0
out: sp0
out: postpone
out: recurse
out: aft
@ -134,13 +129,11 @@ e: check-boot
out: [
out: used
out: remaining
out: latestxt
out: context
out: base
out: state
out: >in
out: #tib
out: current
out: fdepth
out: depth
out: fp0
out: rp0
out: sp0
out: variable
out: constant
out: \
@ -208,6 +201,14 @@ e: check-extra-opcodes
out: >link
out: >name
out: >body
out: current
out: #tib
out: >in
out: state
out: base
out: context
out: latestxt
;e
e: check-core-opcodes

View File

@ -49,19 +49,15 @@ variable scope scope context cell - !
transfer{
xt-find& xt-hide xt-transfer
voc-stack-end last-vocabulary
'context 'notfound notfound
voc-stack-end last-vocabulary notfound
immediate? input-buffer ?echo ?arrow. arrow
evaluate-buffer
'sys 'heap aliteral 'heap-start 'heap-size
'stack-cells 'boot 'boot-size 'latestxt
'argc 'argv 'runner 'tib
evaluate-buffer aliteral
leaving( )leaving leaving leaving,
(do) (?do) (+loop)
parse-quote digit $@ raw.s
tib-setup input-limit
[SKIP] [SKIP]' raw-ok
$place zplace sys: BUILTIN_MARK
$place zplace BUILTIN_MARK
}transfer
forth definitions