Verified Commit 62acfe92 authored by Bernd Paysan's avatar Bernd Paysan
Browse files

Naming conventions and definers for TO: and DEFER: actions

parent 0c534a7a

closures.fs

+3 −3
Original line number Diff line number Diff line
@@ -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 ;

cross.fs

+11 −14
Original line number Diff line number Diff line
@@ -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

debugs.fs

+1 −1
Original line number Diff line number Diff line
@@ -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

float.fs

+12 −11
Original line number Diff line number Diff line
@@ -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.}

glocals.fs

+11 −10
Original line number Diff line number Diff line
@@ -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 ;