Groups | Search | Server Info | Keyboard shortcuts | Login | Register [http] [https] [nntp] [nntps]
Groups > comp.lang.forth > #21325
| From | mhx@iae.nl (Marcel Hendrix) |
|---|---|
| Subject | Anonymous code/data/create-does |
| Newsgroups | comp.lang.forth |
| Message-ID | <93571201998434@frunobulax.edu> (permalink) |
| Date | 2013-04-02 23:46 +0200 |
| Organization | Wanadoo |
Another take on anonymous definitions and anonymous create-does structures.
Certainly not portable, but interesting to think about.
It is possible to define anonymous data sections and anonymous code blocks,
and even to have anonymous create-does like structures.
Not possible: to dynamically create a data-object attached to
centralized anonymous code ( We have CREATE DOES> for that :-)
Also not-possible: dynamically *create* objects with data passed
at run-time. This can be doen I think, but I ran out of spare time.
This code contains various ideas vented in CLF over the past 3 years.
-marcel
-- ---------------------------------------
(*
* LANGUAGE : ANS Forth with extensions
* PROJECT : Forth Environments
* DESCRIPTION : Primitive form of quotations
* CATEGORY : Experiment
* AUTHOR : Marcel Hendrix
* LAST CHANGE : Monday, April 01, 2013, 17:07, Marcel Hendrix
*)
NEEDS -miscutil
REVISION -quotations "--- Quotations Version 0.01 ---"
PRIVATES
DOC
(*
AHEAD
[ here TO dict ]
>R
...code...
R> ret
THEN
( modify ahead to call )
LOCALs in a definition that builds quotations can be a problem when you compile
a reference to a local before *all* locals are defined.
An anonymous code block can not have its own locals, but it can access the outer
locals.
-- anonymous code block
: test1
0 LOCAL xt
[: + 2+ 3 AND ;] TO xt
#11 #12 xt EXECUTE . ;
-- anonymous create does like
: test2
0 LOCAL xt
[:
^{ [ #111 , ] }^
DUP @ 1 ROT +!
;] TO xt
xt EXECUTE .
xt EXECUTE . ;
*)
ENDDOC
0 VALUE dict PRIVATE
0 VALUE dictd PRIVATE
: MYSELF ( -- ) dict 5 + POSTPONE LITERAL POSTPONE EXECUTE ; IMMEDIATE
: SELF ( -- ) dictd POSTPONE LITERAL ; IMMEDIATE
ALSO ASSEMBLER
: [: -OPT AHEAD, OVER TO dict POSTPONE >R ; IMMEDIATE
: ;] POSTPONE R>
-OPT $C3 ( ret) C, ENDIF,
$E8 dict C! ; IMMEDIATE \ modify jmp to call
: NOP-ALLOT ( u -- ) 0 ?DO =NOP C, LOOP ;
: ^{ 5 NOP-ALLOT ALIGN -5 ALLOT AHEAD, OVER TO dictd ; IMMEDIATE
: }^ ENDIF, $E8 dictd C! 5 +TO dictd ; IMMEDIATE
PREVIOUS
NESTING @ 1 =
[IF] -- Examples
-- "1"
: test [: + 2+ 3 AND ;] #11 #12 ROT EXECUTE . ;
-- 11 12 test1 gives "a = 11 b = 12 result = 25"
: 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
: 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 setup, but we don't compile references.
: 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 ;
DOC
(*
Man-or-Boy in Modula 3
MODULE Main;IMPORT IO;
TYPE Function = PROCEDURE ():INTEGER;
PROCEDURE A(k: INTEGER; x1, x2, x3, x4, x5: Function): INTEGER =
PROCEDURE B(): INTEGER =
BEGIN DEC(k);
RETURN A(k, B, x1, x2, x3, x4);
END B;
BEGIN IF k <= 0 THEN RETURN x4() + x5();
ELSE RETURN B();
END;
END A;
PROCEDURE F0(): INTEGER = BEGIN RETURN 0; END F0;
PROCEDURE F1(): INTEGER = BEGIN RETURN 1; END F1;
PROCEDURE Fn1(): INTEGER = BEGIN RETURN -1; END Fn1;
BEGIN
IO.PutInt(A(10, F1, Fn1, Fn1, F1, F0)); IO.Put("\n");
END Main.
*)
ENDDOC
DEFER A
0 VALUE B
:NONAME 0 ; =: F0
WARNING @ WARNING OFF
:NONAME 1 ; =: F1
WARNING !
:NONAME -1 ; =: Fn1
-- iForth is a boy :-(
-- The code is wrong
-- B is obviously a constant. Putting B in the parameter list for A does nothing special.
-- The closure B should make copies of A locals and save them in the heap. Refs to such locals
-- in B refer to the copies in the heap. Not doing this will let a ref to 'x1' refer to
-- the local in the last executed A, not to the saved 'x1' at the moment B was put in the
-- parameter list.
:NONAME ( k x1 x2 x3 x4 x5 -- n )
LOCALS| x5 x4 x3 x2 x1 k |
[: LSP@ @ 0= ABORT" no locals" -1 +TO k k B x1 x2 x3 x4 A ;] TO B
k 0<= IF x4 EXECUTE x5 EXECUTE + ELSE B EXECUTE ENDIF ; IS A
1 VALUE calldepth \ 0, 1, 2 .. 3 works, higher crash!
: ManOrBoy ( -- ) CR calldepth ( #10 ) F1 Fn1 Fn1 F1 F0 A . ;
-- 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 ;
: privatedata1 ( -- addr )
[: [ 0 TO data
LINK, ," ! "
LINK, ," World"
LINK, ," Hello, "
] ;] drop [ data ] LITERAL ;
: privatedata2 ( -- addr )
[: [ 0 TO data
LINK, ," ? "
LINK, ," Wereld"
LINK, ," Hallo, "
] ;] drop [ data ] LITERAL ;
: .elements ( addr -- ) [: COUNT TYPE ;] ITERATE ;
: #elements ( addr -- ) 0 local #cnt [: DROP 1 +TO #cnt ;] ITERATE #cnt . ." elements." ;
: .dump ( addr -- ) [: #20 DUMP ;] ITERATE ;
: .bytes ( addr -- ) 0 local #cnt [: C@ +TO #cnt ;] ITERATE #cnt . ." bytes used." ;
\ FORTH> privatedata2 .elements Hallo, Wereld? ok
\ FORTH> privatedata1 .elements Hello, World! ok
\ FORTH> privatedata1 #elements 3 elements. ok
\ FORTH> privatedata2 #elements 3 elements. ok
\ FORTH> privatedata2 .bytes 15 bytes used. ok
\ FORTH> 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 -- fetch-xt store-xt )
[: ^{ [ 0 , ] }^ ;] EXECUTE !
[: SELF @ ;]
[: SELF ! ;] ;
: test-undef-too ( -- )
5 foo-too [IS] to-x [IS] x
CR x .
6 to-x CR x . ;
-- Anonymous create does like
: test-createdoes ( -- )
0 LOCAL xt
[: ^{ [ 111 , ] }^
DUP @ 1 ROT +!
;] TO xt
xt EXECUTE .
xt 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 quotation"
CR ." ;] -- finish quotation, leaves xt at compile-time"
CR ." ^{ }^ -- allows data section, picked up by code"
CR ." MYSELF -- recurse a quotation" ;
[THEN]
.ABOUT -quotations CR
DEPRIVE
(* End of Source *)
Back to comp.lang.forth | Previous | Next — Next in thread | Find similar
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