Re: Anonymous code/data/create-does

From	mhx@iae.nl (Marcel Hendrix)
Subject	Re: Anonymous code/data/create-does
Newsgroups	comp.lang.forth
Message-ID	<02591300998434@frunobulax.edu> (permalink)
Date	2013-04-03 22:44 +0200
References	<93571201998434@frunobulax.edu>
Organization	Wanadoo

Show all headers | View raw

The old [: ... ;] could not have locals, but knew ho to access the locals of the
host definition. As this seems to be quite useful, a second variant was added:
<: ... :>. Such blocks support having locals and also support EXIT. However,
a <: .. :> block can not access outer locals.

The ^{ .. }^ word was a mistake. The new ^, word ( does-xt -- child-xt ) 
creates an anonymous child and returns it xt. The data for the child is 
supposed to be at HERE. When putting both [: ... ;], ^, and (e.g.) "," 
inside a definer-word, children can be dynamically created. Such children
inherit the anonymous code and have a data field (at HERE) that can be 
initialized from the data passed to the definer word (e.g. with ",").

With indirection, a single data area can have any number of anonymous
code blocks attached.

It is now possible to "freeze" any amount of environmental data of the 
host word when a child is created. This is under programmer control (not
done automatically, and used memory is not garbage collected).

The code has not grown in size. SELF is removed.

I found factors of the anonymous blocks hidden in the iForth sources. 
Apparently the concept was just waiting for vocalization.

-marcel

-- ----------
(*
 * LANGUAGE    : ANS Forth with extensions
 * PROJECT     : Forth Environments
 * DESCRIPTION : Primitive form of anonymous words
 * CATEGORY    : Experiment 
 * AUTHOR      : Marcel Hendrix 
 * LAST CHANGE : Wednesday, April 03, 2013, 19:27, Marcel Hendrix; added locals and EXIT 
 * LAST CHANGE : Monday, April 01, 2013, 17:07, Marcel Hendrix 
 *)



	NEEDS -miscutil

	REVISION -anons "--- Anonymous words     Version 0.02 ---"

	PRIVATES

DOC
(*
	CALL here
	  [ here TO dict ]
          >R 
	  ...code...
          R> ret
        here:

	LOCALs in a definition that builds anonymous words can be a problem when you compile
	a reference to a local before *all* locals are defined.

	An anonymous code block can have its own locals, and it can access outer locals.

	-- An anonymous code block
	: test1  
	  0 LOCAL xt
	  [: +  2+ 3 AND ;] TO xt
	  #11 #12 xt EXECUTE . ;

	-- An anonymous CREATE DOES> structure
	: test-createdoes ( val -- xt2 ) 
	[: DUP @  1 ROT +! ;] ( val xt1 -- ) 	\ define code (does>)
	^, ( val xt2 -- ) SWAP , ;		\ create new var, initialize, leave xt of object

	1 test-createdoes CONSTANT counter

	counter EXECUTE . ( 1)
	counter EXECUTE . ( 2)
*)
ENDDOC

0 VALUE dict  PRIVATE  : MYSELF ( -- ) dict 5 + POSTPONE LITERAL  POSTPONE EXECUTE ; IMMEDIATE
ALSO ASSEMBLER 
: <:   ([:) -OPT AHEAD, OVER TO dict  POSTPONE >R  -OPT ; IMMEDIATE ( own locals )
: [:        -OPT AHEAD, OVER TO dict  POSTPONE >R  -OPT ; IMMEDIATE ( reuse outer locals )
: ;>   POSTPONE R>  -OPT  (;]) $C3 ( ret) C,  ENDIF,  $E8 ( call) dict C! ; IMMEDIATE \ modify jump to call
: ;]   POSTPONE R>  -OPT       $C3 ( ret) C,  ENDIF,  $E8 ( call) dict C! ; IMMEDIATE 
: ^,   ( xt-does -- xt-child ) 
       HERE SWAP  POSTPONE >R -OPT  $90909090 32B, $90 C, ( 5 nops) ALIGN -5 ALLOT  
       $E8 ( call) C,  9 + ( skip >R)  HERE 4 + - 32B, ( rel call of does> code) ; 
PREVIOUS

NESTING @ 1 = 
  [IF] -- Examples

-- "1"
: test [: +  2+ 3 AND ;] #11 #12 ROT EXECUTE . ;

-- 11 12 test1 gives "a = 11 b = 12 result = 25"
-- Here we want access to outer locals.
: test1 ( a b -- ) 
	LOCALS| b a |  
	CR ." a = " a . ." b = " b .  
	[: a b +  2+ ." result = " . ;] EXECUTE ;

-- 11 12 test2 
--   a = 11 b = 12 xt = $01406F80
--   first  : result = 134
--   second : result = 245  ok
-- Here we want access to outer locals.
: test2 ( a b -- ) 
	0 LOCALS| xt b a |  
	." a = " a . ." b = " b .
	[: a b +  ( offs) + ." result = " . ;] TO xt
	." xt = " xt H. 
	CR ." first  : " #111 xt EXECUTE 
	CR ." second : " #222 xt EXECUTE ;

-- Does work; there is code between the local setups, but we don't compile references then.
: test3 PI FLOCAL p 
	[: F+ F+ ;]
	[: F- F- ;]
	[: F* F* ;] LOCALS| xt* xt- xt+ |
	11e 2e 3e xt+ EXECUTE F.  
	11e 2e 3e xt- EXECUTE F. 
	11e 2e 3e xt* EXECUTE F. 
	p F. ;

: test-recursion ( flag -- )
	#10 SWAP
	   IF  [: ( n1 -- n2 ) DUP 1 > IF  DUP 1-  MYSELF  SWAP 2-  MYSELF +  ENDIF ;] \ fib
	 ELSE  [: ( n1 -- n2 ) DUP     IF  DUP 1-  MYSELF  SWAP *   ELSE  1+  ENDIF ;] \ fac
	ENDIF  EXECUTE . ;

-- Does not work; setup locals *before* referencing them (ANS :-)
: test4a pi FLOCAL p
	[: F+ F+ p F+ ;]
	[: F- F- p F- ;]
	[: F* F* p F* ;] LOCALS| xt* xt- xt+ |
	11e 2e 3e xt+ EXECUTE F.  
	11e 2e 3e xt- EXECUTE F. 
	11e 2e 3e xt* EXECUTE F. ;

-- Correct usage, this works.
: test4b pi FLOCAL p
	0 0 0 LOCALS| xt* xt- xt+ |
	[: F+ F+ p F+ ;] TO xt+
	[: F- F- p F- ;] TO xt-
	[: F* F* p F* ;] TO xt*
	11e 2e 3e xt+ EXECUTE F.  
	11e 2e 3e xt- EXECUTE F. 
	11e 2e 3e xt* EXECUTE F. ;

: ptest	( F: r -- )
	[: F+ F+ ;] >S
	[: F- F- ;] >S
	[: F* F* ;] >S
	FLOCAL p
	11e 2e 3e  S> EXECUTE  F.  
	11e 2e 3e  S> EXECUTE  F. 
	11e 2e 3e  S> EXECUTE  F. 
	p F. ;

: ntest	( F: r -- )
	FLOCAL p
	[: F+ F+ ;] >R   11e 2e 3e  R> EXECUTE  F.  
	[: F- F- ;] >R   11e 2e 3e  R> EXECUTE  F. 
	[: F* F* ;] >R   11e 2e 3e  R> EXECUTE  F. 
	p F. ;

: int-ntest	( n -- )
	LOCAL p
	[: + + ;] >R   #11 2 3  R> EXECUTE  .  
	[: - - ;] >R   #11 2 3  R> EXECUTE  . 
	[: * * ;] >R   #11 2 3  R> EXECUTE  . 
	p . ;

DEFER do-this
DEFER do-that

: generic do-this do-that ;

: mode-1 [: CR ." x"     ;] [IS] do-this [: ." y"     ;] [IS] do-that ;
: mode-2 [: CR ." this " ;] [IS] do-this [: ." that " ;] [IS] do-that ;

: TEST-generic  mode-1 generic  mode-2 generic ;

-- Can we emulate DOES> and LIST> ?
\ : list>    ( thread -- element ) 
\  BEGIN  @ dup  WHILE  dup r@ execute 
\  REPEAT  drop r> drop ; 
\ : print-elements ( a -)   list> .element ;

: ITERATE ( addr xt -- ) >R  BEGIN  DUP WHILE  DUP @ SWAP CELL+  R@ EXECUTE  REPEAT DROP  -R ;

0 VALUE data
: LINK,  ALIGN HERE data , TO data ;

0 TO data
	LINK, ," ! "
	LINK, ," World"
	LINK, ," Hello, "
 data =: privatedata1

0 TO data
	LINK, ," ? "
	LINK, ," Wereld"
	LINK, ," Hallo, "
data =: privatedata2  

: .elements ( addr -- )  [: COUNT TYPE ;]  ITERATE ; 
: .dump     ( addr -- )  [: #20 DUMP ;]  ITERATE ; 
: #elements ( addr -- )  0 LOCAL #cnt  [: DROP  1 +TO #cnt ;] ITERATE  #cnt . ." elements." ;
: .bytes    ( addr -- )  0 LOCAL #cnt  [: C@ +TO #cnt ;] ITERATE  #cnt . ." bytes used." ;

\ privatedata2 .elements Hallo, Wereld?  ok
\ privatedata1 .elements Hello, World!  ok
\ privatedata1 #elements 3 elements. ok
\ privatedata2 #elements 3 elements. ok
\ privatedata2 .bytes 15 bytes used. ok
\ privatedata1 .bytes 14 bytes used. ok

: test-5 22 11 0 LOCALS| xt a b |
	[:  a b +  2* ;] TO xt  
			    xt EXECUTE .  
	#33 TO a  #44 TO b  xt EXECUTE . ;  ( prints 66 154 )

: foo ( n -- xt1 xt2 ) LOCAL n  [: n ;]  [: TO n ;] ;

DEFER x
DEFER to-x

-- This works although the Locals stack is accessed in an uncontrolled way.
-- May overwrite local values of other words higher up the call-chain.
: test-undef ( -- )
	CR ." undefined behavior "
	5 foo [IS] to-x [IS] x
	CR x .
	6 to-x CR x . ;

: foo-too ( n -- child@ child! ) 
	HERE SWAP , LOCAL 'n
	[: @ @ ;] 
	[: @ ! ;] 
	SWAP ^, 'n , ( xt-store child@ )
	SWAP ^, 'n , ( child@ child! ) ;

: test-undef-too ( -- )
	5 foo-too [IS] to-x [IS] x
	CR x .
	6 to-x CR x . ;

-- An anonymous can have its own locals (EXIT works!).
: test-locals ( a b -- xt )
	0 LOCALS| xt  b a |  
	CR ." a + b = " a b + .  

	<: LOCALS| d c | 
	   CR ." c + d = " c d + . 
	;> TO xt  

	#11 #22 xt EXECUTE  
	a   b   xt EXECUTE 
	c   d   xt EXECUTE ( garbage :-)

	xt ;


-- Anonymous CREATE DOES> like
: test-createdoes ( val -- xt2 ) [: DUP @  1 ROT +! ;] ( val xt1 -- ) ^, ( val xt2 -- ) SWAP , ;

  1 test-createdoes =: counter1
#11 test-createdoes =: counter11

CR .( expect 1 2 11 3 12) 
CR .( result )
counter1  EXECUTE . counter1 EXECUTE .
counter11 EXECUTE . counter1 EXECUTE . counter11 EXECUTE .


:ABOUT	CR ." Try: test           -- Prints `16.000000 12.000000 66.000000 3.141593`"
     	CR ."      mode-1 generic -- Prints `xy`" 
	CR ."      mode-2 generic -- Prints `this that`" ;

[ELSE]

:ABOUT	CR ." [:      -- open anon"
     	CR ." ;]      -- finish anon, leaves xt at compile-time" 
	CR ." ^{ }^   -- allows data section, picked up by code"
	CR ." MYSELF  -- recurse a anon" 
	CR ." SELF    -- refer to last data section defined by ^{ " ;

[THEN]
		.ABOUT -anons CR
		DEPRIVE

                              (* End of Source *)

Back to comp.lang.forth | Previous | Next — Previous in thread | Next in thread | Find similar

Thread

Anonymous code/data/create-does mhx@iae.nl (Marcel Hendrix) - 2013-04-02 23:46 +0200
  Re: Anonymous code/data/create-does "WJ" <w_a_x_man@yahoo.com> - 2013-04-02 22:51 +0000
  Re: Anonymous code/data/create-does "WJ" <w_a_x_man@yahoo.com> - 2013-04-02 23:00 +0000
  Re: Anonymous code/data/create-does Gerry Jackson <gerry@jackson9000.fsnet.co.uk> - 2013-04-03 11:07 +0100
    Re: Anonymous code/data/create-does m.a.m.hendrix@tue.nl - 2013-04-03 06:53 -0700
      Re: Anonymous code/data/create-does Alex McDonald <blog@rivadpm.com> - 2013-04-03 13:43 -0700
        Re: Anonymous code/data/create-does Gerry Jackson <gerry@jackson9000.fsnet.co.uk> - 2013-04-04 18:07 +0100
    Re: Anonymous code/data/create-does mhx@iae.nl (Marcel Hendrix) - 2013-04-04 00:38 +0200
      Re: Anonymous code/data/create-does Gerry Jackson <gerry@jackson9000.fsnet.co.uk> - 2013-04-04 18:18 +0100
        Re: Anonymous code/data/create-does mhx@iae.nl (Marcel Hendrix) - 2013-04-04 20:29 +0200
          Re: Anonymous code/data/create-does mhx@iae.nl (Marcel Hendrix) - 2013-04-06 20:40 +0200
            Re: Anonymous code/data/create-does Alex McDonald <blog@rivadpm.com> - 2013-04-06 14:09 -0700
              Re: Anonymous code/data/create-does mhx@iae.nl (Marcel Hendrix) - 2013-04-07 02:04 +0200
                Re: Anonymous code/data/create-does Alex McDonald <blog@rivadpm.com> - 2013-04-06 20:34 -0700
                Re: Anonymous code/data/create-does mhx@iae.nl (Marcel Hendrix) - 2013-04-07 14:00 +0200
                Re: Anonymous code/data/create-does kenney@cix.compulink.co.uk - 2013-04-08 02:38 -0500
                Re: Anonymous code/data/create-does Roelf Toxopeus <rt4all@notthis.hetnet.nl> - 2013-04-08 10:58 +0200
                Re: Anonymous code/data/create-does Alex McDonald <blog@rivadpm.com> - 2013-04-08 14:57 -0700
                Re: Anonymous code/data/create-does Bernd Paysan <bernd.paysan@gmx.de> - 2013-04-08 19:26 +0200
                Re: Anonymous code/data/create-does kenney@cix.compulink.co.uk - 2013-04-09 02:07 -0500
  Re: Anonymous code/data/create-does mhx@iae.nl (Marcel Hendrix) - 2013-04-03 22:44 +0200
    Re: Anonymous code/data/create-does Lars Brinkhoff <lars.spam@nocrew.org> - 2013-04-04 12:42 +0200
      Re: Anonymous code/data/create-does Andrew Haley <andrew29@littlepinkcloud.invalid> - 2013-04-04 07:04 -0500
        Re: Anonymous code/data/create-does Andrew Haley <andrew29@littlepinkcloud.invalid> - 2013-04-04 07:07 -0500

csiph-web