add create, does>, etc

1 files changed, 31 insertions, 21 deletions

diff --git a/core.fth b/core.fth
index b90287a..96dc0f2 100644
--- a/core.fth
+++ b/core.fth
@@ -85,24 +85,34 @@
 : decimal   10 base ! ;
 : hex       16 base ! ;
 
-: begin    0 here ; immediate
-: while    swap 1+ swap postpone if -rot ; immediate
-: repeat   ['] _jmp , , if postpone then then ; immediate
-: until    ['] _jmp0 , , drop ; immediate
-
-: do       ['] _lit , here 0 , ['] >r , postpone 2>r here ; immediate
-: unloop   postpone 2r> ['] 2drop , ['] r> , ['] drop , ; immediate
-: leave    postpone 2r> ['] 2drop , ['] exit , ; immediate
-: +loop    ['] r> , ['] 2dup , ['] + ,
-           postpone r@ ['] swap , ['] >r ,
-           ['] - , ['] 2dup , ['] + , ['] over , ['] xor ,
-           ['] rot , ['] rot , ['] xor , ['] and , ['] _lit , 0 ,
-           ['] < , ['] _jmp0 , ,
-           postpone unloop here 1 cells - swap ! ; immediate
-: loop     postpone 2r> ['] 1+ , ['] 2dup ,
-           postpone 2>r ['] = , ['] _jmp0 , ,
-           postpone unloop here 1 cells - swap ! ; immediate
-: i        postpone r@ ; immediate
-: j        postpone 2r> ['] r> , postpone r@ ['] swap ,
-           ['] >r , ['] -rot , postpone 2>r ; immediate
-
+: begin     0 here ; immediate
+: while     swap 1+ swap postpone if -rot ; immediate
+: repeat    ['] _jmp , , if postpone then then ; immediate
+: until     ['] _jmp0 , , drop ; immediate
+
+: do        ['] _lit , here 0 , ['] >r , postpone 2>r here ; immediate
+: unloop    postpone 2r> ['] 2drop , ['] r> , ['] drop , ; immediate
+: leave     postpone 2r> ['] 2drop , ['] exit , ; immediate
+: +loop     ['] r> , ['] 2dup , ['] + ,
+            postpone r@ ['] swap , ['] >r ,
+            ['] - , ['] 2dup , ['] + , ['] over , ['] xor ,
+            ['] rot , ['] rot , ['] xor , ['] and , ['] _lit , 0 ,
+            ['] < , ['] _jmp0 , ,
+            postpone unloop here 1 cells - swap ! ; immediate
+: loop      postpone 2r> ['] 1+ , ['] 2dup ,
+            postpone 2>r ['] = , ['] _jmp0 , ,
+            postpone unloop here 1 cells - swap ! ; immediate
+: i         postpone r@ ; immediate
+: j         postpone 2r> ['] r> , postpone r@ ['] swap ,
+            ['] >r , ['] -rot , postpone 2>r ; immediate
+
+: create    : here [ 4 cells ] literal + postpone literal postpone ; 0 , ;
+: >body     [ 2 cells ] literal + @ ;
+
+: _does>    latest dup cell+ @ [ 5 cells ] literal + +
+            ['] _jmp over ! cell+ ! ;
+
+: does>     here 4 cells + postpone literal ['] _does> , 0 , ; immediate
+
+: variable create cell allot ;
+: constant create , does> @ ;