Commit 62acfe92 authored by Bernd Paysan's avatar Bernd Paysan

Naming conventions and definers for TO: and DEFER: actions

parent 0c534a7a
Pipeline #115 failed with stage
in 4 minutes and 42 seconds
......@@ -129,9 +129,9 @@ false [IF]
: homeloc <{: w^ a w^ b w^ c :}h a b c ;> ;
1 2 3 homeloc >r ? ? ? r> free throw cr
: A {: w^ k x1 x2 x3 x4 x5 | w^ B :} recursive
k @ 0<= IF x4 execute x5 execute f+ ELSE
B k x1 x2 x3 x4 [{: B k x1 x2 x3 x4 :}L
: A {: w^ k x1 x2 x3 xt: x4 xt: x5 | w^ B :} recursive
k @ 0<= IF x4 x5 f+ ELSE
B k x1 x2 x3 action-of x4 [{: B k x1 x2 x3 x4 :}L
-1 k +!
k @ B @ x1 x2 x3 x4 A ;] dup B !
execute THEN ;
......
......@@ -715,6 +715,8 @@ Variable comp-state
: pi-undefined -1 ABORT" Plugin undefined" ;
[IFDEF] value! ' value! alias value-to [THEN]
: Plugin ( -- : pluginname )
Create
\ for normal cross-compiling only one action
......@@ -724,12 +726,7 @@ Variable comp-state
['] pi-undefined , \ action
['] pi-undefined , \ target plugin action
8765 , \ plugin magic
[IFDEF] set-to
['] value! set-to
[THEN]
[IFDEF] !to
['] value! !to
[THEN]
['] value-to set-to
DOES> perform ;
Plugin DummyPlugin
......@@ -3022,7 +3019,7 @@ ghost user,
ghost defer,
2drop
ghost u-compile,
ghost u-to
ghost uvalue-to
2drop
ghost field+,
ghost abi-code,
......@@ -3037,9 +3034,9 @@ ghost i/c>comp
2drop
ghost no-to
ghost no-defer@
ghost >body@
ghost defer-defer@
2drop drop
ghost value!
ghost value-to
ghost umethod,
2drop
ghost umethod!
......@@ -3320,7 +3317,7 @@ T has? rom H [IF]
Builder (Value)
Build: ( n -- ) ;Build
by: :dovalue ( target-body-addr -- n ) T @ @ H ;DO
vt: [G'] value, gset-optimizer [G'] value! gset-to ;vt
vt: [G'] value, gset-optimizer [G'] value-to gset-to ;vt
Builder Value
Build: T here 0 A, H switchram T align here swap ! , H ;Build
......@@ -3333,7 +3330,7 @@ T has? rom H [IF]
Builder (Value)
Build: ( n -- ) ;Build
by: :dovalue ( target-body-addr -- n ) T @ H ;DO
vt: [G'] value, gset-optimizer [G'] value! gset-to ;vt
vt: [G'] value, gset-optimizer [G'] value-to gset-to ;vt
Builder Value
BuildSmart: T , H ;Build
......@@ -3347,7 +3344,7 @@ T has? rom H [IF]
Builder UValue
Build: 0 u, T , H ;Build
DO: X @ tup@ + X @ ;DO
vt: [G'] u-compile, gset-optimizer [G'] u-to gset-to ;vt
vt: [G'] u-compile, gset-optimizer [G'] uvalue-to gset-to ;vt
Defer texecute
......@@ -3361,8 +3358,8 @@ T has? rom H [IF]
[THEN]
vt:
[G'] defer, gset-optimizer
[G'] value! gset-to
[G'] >body@ gset-defer@ ;vt
[G'] value-to gset-to
[G'] defer-defer@ gset-defer@ ;vt
\ Sturctures 23feb95py
......
......@@ -186,7 +186,7 @@ is ?warning
: ~~Value ( n "name" -- )
\G Value that will be watched on every access
Value [: ~~ >body ! ; opt: drop ]] Literal ~~ >body ! [[ ;] set-to ;
Value [: >body ~~ ! ; to-opt: >body ]] Literal ~~ ! [[ ;] set-to ;
\ trace lines
......
......@@ -63,10 +63,17 @@
\G @i{f} in the space.
here 1 floats allot f! ;
: comp-fval ( xt -- ) >body postpone Literal postpone f@ ;
: FLiteral ( compilation r -- ; run-time -- r ) \ float f-literal
\G Compile appropriate code such that, at run-time, @i{r} is placed
\G on the (floating-point) stack. Interpretation semantics are undefined.
here cell+ dup faligned <> IF postpone noop THEN
postpone flit f, ; immediate
: opt-fcon ( xt -- ) >body f@ postpone FLiteral ;
: opt-fval ( xt -- ) >body postpone Literal postpone f@ ;
: fconstant ( r "name" -- ) \ float f-constant
Create f, ['] comp-fval set-optimizer
Create f, ['] opt-fcon set-optimizer
DOES> ( -- r )
f@ ;
......@@ -74,24 +81,18 @@ DOES> ( -- r )
Create f!-table ' f! , ' f+! ,
: fvalue! ( xt xt-deferred -- ) \ gforth defer-store
to: fvalue-to ( xt xt-deferred -- ) \ gforth defer-store
>body f!-table to-!exec ;
opt: drop >body postpone ALiteral f!-table to-!, ;
to-opt: >body postpone ALiteral f!-table to-!, ;
: fvalue ( r "name" -- ) \ float-ext f-value
fconstant ['] fvalue! set-to ['] comp-fval set-optimizer ;
fconstant ['] fvalue-to set-to ['] opt-fval set-optimizer ;
: fdepth ( -- +n ) \ float f-depth
\G @i{+n} is the current number of (floating-point) values on the
\G floating-point stack.
fp0 @ fp@ - [ 1 floats ] Literal / ;
: FLiteral ( compilation r -- ; run-time -- r ) \ float f-literal
\G Compile appropriate code such that, at run-time, @i{r} is placed
\G on the (floating-point) stack. Interpretation semantics are undefined.
here cell+ dup faligned <> IF postpone noop THEN
postpone flit f, ; immediate
&15 Value precision ( -- u ) \ float-ext
\G @i{u} is the number of significant digits currently used by
\G @code{F.} @code{FE.} and @code{FS.}
......
......@@ -350,16 +350,17 @@ variable locals-dp \ so here's the special dp for locals.
Create 2!-table ' 2! , ' 2+! ,
Create c!-table ' c! , ' c+! ,
: to-w: ( -- ) -14 throw ;
opt: ( !!?addr!! ) drop POSTPONE laddr# >body @ lp-offset, !-table to-!, ;
: to-d: ( -- ) -14 throw ;
opt: ( !!?addr!! ) drop POSTPONE laddr# >body @ lp-offset, 2!-table to-!, ;
: to-c: ( -- ) -14 throw ;
opt: ( !!?addr!! ) drop POSTPONE laddr# >body @ lp-offset, c!-table to-!, ;
: to-f: ( -- ) -14 throw ;
opt: ( !!?addr!! ) drop POSTPONE laddr# >body @ lp-offset, f!-table to-!, ;
: defer@-xt: ( -- ) -14 throw ;
opt: drop POSTPONE laddr# >body @ lp-offset, postpone @ ;
to: to-w: ( -- ) -14 throw ;
to-opt: ( !!?addr!! ) POSTPONE laddr# >body @ lp-offset, !-table to-!, ;
to: to-d: ( -- ) -14 throw ;
to-opt: ( !!?addr!! ) POSTPONE laddr# >body @ lp-offset, 2!-table to-!, ;
to: to-c: ( -- ) -14 throw ;
to-opt: ( !!?addr!! ) POSTPONE laddr# >body @ lp-offset, c!-table to-!, ;
to: to-f: ( -- ) -14 throw ;
to-opt: ( !!?addr!! ) POSTPONE laddr# >body @ lp-offset, f!-table to-!, ;
defer@: defer@-xt: ( -- ) -14 throw ;
defer@-opt: POSTPONE laddr# >body @ lp-offset, postpone @ ;
: val-part-off ( -- ) val-part off ;
......
......@@ -461,16 +461,16 @@ Variable to-style# 0 to-style# !
: !!?addr!! ( -- ) to-style# @ -1 = -2056 and throw ;
: u-to ( n uvalue-xt -- ) !!?addr!! >body @ next-task + !-table to-!exec ;
: uvalue-to ( n uvalue-xt -- ) !!?addr!! >body @ next-task + !-table to-!exec ;
opt: ( uvalue-xt to-xt -- )
!!?addr!! drop >body @ postpone useraddr , !-table to-!, ;
\g u-to is the to-method for user values; it's xt is only
\g uvalue-to is the to-method for user values; it's xt is only
\g there to be consumed by @code{set-to}.
: u-compile, ( xt -- ) >body @ postpone user@ , ;
: UValue ( "name" -- )
\G Define a per-thread value
Create cell uallot , ['] u-to set-to
Create cell uallot , ['] uvalue-to set-to
['] u-compile, set-optimizer
DOES> @ next-task + @ ;
......@@ -487,7 +487,7 @@ opt: ( uvalue-xt to-xt -- )
defer defer-default ( -- )
' abort is defer-default
\ default action for deferred words (overridden by a warning later)
: Defer ( "name" -- ) \ gforth
\G Define a deferred word @i{name}; its execution semantics can be
\G set with @code{defer!} or @code{is} (and they have to, before first
......@@ -495,7 +495,7 @@ defer defer-default ( -- )
Header Reveal dodefer, ?noname-vt
['] defer-default A, ;
: >body@ >body @ ;
: defer-defer@ >body @ ;
opt: drop >body lit, postpone @ ;
: Defers ( compilation "name" -- ; run-time ... -- ... ) \ gforth
......@@ -599,6 +599,11 @@ interpret/compile: opt:
interpret/compile: comp:
( compilation colon-sys1 -- colon-sys2 ; run-time nest-sys -- ) \ gforth
: to-opt: ( -- colon-sys ) start-xt set-optimizer postpone drop ;
' to-opt: alias defer@-opt:
: to: : ;
' to: alias defer@:
\ defer and friends
' (int-to) alias defer! ( xt xt-deferred -- ) \ gforth defer-store
......@@ -613,11 +618,11 @@ interpret/compile: comp:
\g effect.
dup >namevt @ >vtto @ compile, ;
: value! ( n value-xt -- ) \ gforth value-store
: value-to ( n value-xt -- ) \ gforth value-store
\g this is the TO-method for normal values; it's tickable, but
\g the only purpose of its xt is to be consumed by @code{set-to}.
>body !-table to-!exec ;
opt: ( value-xt to-xt -- )
opt: ( value-xt -- ) \ run-time: ( n -- )
drop >body postpone ALiteral !-table to-!, ;
: <IS> ( "name" xt -- ) \ gforth
......
......@@ -24,11 +24,12 @@ Defer default-method ' noop IS default-method
\ template for methods and ivars
Create o 0 , DOES> @ o#+ [ 0 , ] + ;
comp: >body @ postpone o#+ , ;
: to-m >body @ + ! ;
opt: >body @ postpone o#+ , ;
to: m-to >body @ + ! ;
to-opt: >body @ postpone lit+ , postpone ! ;
Create m 0 , DOES> @ o#+ [ -1 cells , ] @ + perform ;
comp: >body @ cell/ postpone o#exec , ;
' to-m set-to
opt: >body @ cell/ postpone o#exec , ;
' m-to set-to
' o Value var-xt
' m Value method-xt
: current-o ['] o to var-xt ['] m to method-xt ;
......@@ -37,7 +38,7 @@ comp: >body @ cell/ postpone o#exec , ;
: o+field, ( addr body -- addr' )
@ o + ;
comp: drop @ postpone o#+ , ;
opt: drop @ postpone o#+ , ;
\ core system
......
......@@ -21,7 +21,7 @@ Defer +field,
: standard+field, ( addr body -- addr' )
@ + ;
comp: drop @ ?dup-IF ['] lit+ peephole-compile, , THEN ;
opt: drop @ ?dup-IF ['] lit+ peephole-compile, , THEN ;
warnings @ warnings off
: standard:field ( -- )
......@@ -41,7 +41,7 @@ standard:field
: create+defer ( n1 addr "name" -- n3 )
create+value
[: ( addr -- xt ) >body vfield-int, @ ;
opt: drop >body vfield-comp, postpone @ ;] set-defer@ ;
defer@-opt: >body vfield-comp, postpone @ ;] set-defer@ ;
: wrapper-xts ( xt@ !-table -- xt-does xt-opt xt-to ) { xt@ xt! }
:noname ]] vfield-int, [[ xt@ compile, postpone ; \ xt-does
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment