befebd5950/image/rx-core/core.retro
Commiter: Charles Childers
Author: Charles Childers
Revision: befebd5950
File Size: 28.4 KB
(May 01, 2010 04:55 UTC) About 2 years ago
add "10.6" vocabulary; update to latest rx-core
Showing without highlighting since it looks like a big file and may slow your browser - show with highlighting
Show/hide line numbers( Retro Experimental Core ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Copyright [c] 2008 - 2010, Charles Childers )
( Copyright [c] 2009 - 2010, Luke Parrish )
( Copyright [c] 2010, Marc Simpson )
( Copyright [c] 2010, Jay Skeer )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Assembler and Metacompiler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
vocab meta
((
4096 constant IMAGE-SIZE
( Remap some of the prompts and such for debugging purposes )
: <ok> ( - ) cr depth . ." ok " ;
: <nf> ( - ) cr ." ERROR: " tib type cr ;
' <ok> is ok
' <nf> is notfound
( Assembler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
7 elements target origin 'WORD 'MACRO 'DATA link chain
: m, ( n- ) target @ ! target ++ ;
: vm: ( n"- ) ` : .data ` m, ` ; ;
0 vm: nop, 1 vm: lit, 2 vm: dup,
3 vm: drop, 4 vm: swap, 5 vm: push,
6 vm: pop, 7 vm: call, 8 vm: jump,
9 vm: ;, 10 vm: >jump, 11 vm: <jump,
12 vm: !jump, 13 vm: =jump, 14 vm: @,
15 vm: !, 16 vm: +, 17 vm: -,
18 vm: *, 19 vm: /mod, 20 vm: and,
21 vm: or, 22 vm: xor, 23 vm: <<,
24 vm: >>, 25 vm: 0; 26 vm: 1+,
27 vm: 1-, 28 vm: in, 29 vm: out,
30 vm: wait,
: t-here ( -n ) target @ origin @ - ;
: main: ( - ) t-here cr ." MAIN @ " dup . origin @ 1+ ! ;
: label: ( "- ) t-here constant ;
: # ( n- ) lit, m, ;
: $, ( $- ) dup getLength for dup @ m, 1+ next 0 m, drop ;
( Metacompiler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
variable getxt
: .colon ( a- || a-a ) getxt @ if getxt off ;then m, ;
---reveal---
: t: ( "- ) label: nop, nop, ['] .colon reclass ;
: t' ( "-a ) getxt on ;
}}
{{
: cond ( -a ) target @ 0 m, ;
---reveal---
: =if ( -a ) !jump, cond ;
: <if ( -a ) >jump, cond ;
: >if ( -a ) <jump, cond ;
: !if ( -a ) =jump, cond ;
: if ( -a ) 0 # !if ;
: then ( a- ) t-here swap ! ;
}}
: jump: ( "- ) jump, ' m, ;
: repeat ( -a ) t-here ;
: again ( a- ) jump, m, ;
: variable: ( n"- ) label: m, ;
: variable ( "- ) 0 variable: ;
: entry ( a"- )
t-here link @ m, link ! m, m, 32 accept tib $, ;
: word: ( a"- ) 'WORD @ entry ;
: macro: ( a"- ) 'MACRO @ entry ;
: data: ( a"- ) 'DATA @ entry ;
: patch-dictionary ( - ) link @ dup cr ." Dictionary ends at " . chain @ ! ;
: mark-dictionary ( - ) target @ chain ! ;
: set-class ( aa- ) ! ;
: padding ( - ) 129 t-here - for 0 m, next ;
( Image Relocator ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
: @+ ( a-ac ) dup 1+ swap @ ;
: !+ ( ca-a ) dup 1+ push ! pop ;
: copy ( aan- ) for push @+ pop !+ next drop drop ;
: wait ( - ) 0 0 out [ 30 , ] ;
: save ( - ) 1 4 out 0 0 out wait -9 5 out wait ;
: relocate ( - ) origin @ 0 IMAGE-SIZE copy ;
---reveal---
: boot-new ( - ) relocate [ 0 , ] ;
: save-and-quit ( - ) relocate save ;
}}
: ; ( - ) ;, ;; [
here IMAGE-SIZE allot target ! target @ origin !
jump, 0 m,
))
( Retro Core ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
2560 constant CORE
CORE 0000 + constant TIB
CORE 512 + constant HEAP
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
mark-dictionary ( Pointer to the most recent dictionary )
variable last ( header )
HEAP variable: heap ( Starting address of the data/code heap )
variable which ( Pointer to dictionary header of the )
( most recently looked up word )
variable compiler ( Is the compiler on or off? )
label: copytag " RETRO" $,
label: okmsg " ok " $,
padding
( Primitives ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: dup ( n-nn ) dup, ; t: 1+ ( n-n ) 1+, ;
t: 1- ( n-n ) 1-, ; t: swap ( xy-yx ) swap, ;
t: drop ( n- ) drop, ; t: and ( xy-n ) and, ;
t: or ( xy-n ) or, ; t: xor ( xy-n ) xor, ;
t: @ ( a-n ) @, ; t: ! ( na- ) !, ;
t: + ( xy-n ) +, ; t: - ( xy-n ) -, ;
t: * ( xy-n ) *, ; t: /mod ( xy-qr ) /mod, ;
t: << ( xy-n ) <<, ; t: >> ( xy-n ) >>, ;
t: out ( np- ) out, ; t: in ( p-n ) in, ;
t: wait ( - ) 0 # 0 # out, wait, ;
t: nip ( xy-y ) swap, drop, ;
t: over ( xy-xyx ) push, dup, pop, swap, ;
t: 2drop ( nn- ) drop, drop, ;
t: not ( x-y ) -1 # xor, ;
t: rot ( xyz-yzx ) push, swap, pop, swap, ;
t: -rot ( xyz-xzy ) swap, push, swap, pop, ;
t: tuck ( xy-yxy ) dup, -rot ;
t: 2dup ( x-xx ) over over ;
t: on ( a- ) -1 # swap, !, ;
t: off ( a- ) 0 # swap, !, ;
t: / ( xy-q ) /mod, nip ;
t: mod ( xy-r ) /mod, drop, ;
t: neg ( x-y ) -1 # *, ;
t: execute ( a- ) 1-, push, ;
t: later ( - ) pop, pop, swap, push, push, ;
t: @+ ( a-ac ) dup, 1+, swap, @, ;
t: !+ ( ca-a ) dup, 1+, push, !, pop, ;
t: +! ( na- ) dup, push, @, +, pop, !, ;
t: -! ( na- ) dup, push, @, swap, -, pop, !, ;
( Core Compiler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: t-here ( -a ) heap # @, ;
t: t-, ( n- ) t-here !, t-here 1+, heap # !, ;
t: ] ( - ) compiler # on ;
t: [ ( - ) compiler # off ;
t: ;; ( - ) 9 # t-, ;
t: t-; ( - ) ;; [ ;
t: ($,) ( a-a ) repeat @+ 0; t-, again ;
t: $ ( a- ) ($,) drop, 0 # t-, ;
t: push ( n- ) 5 # t-, ;
t: pop ( -n ) 6 # t-, ;
t: compile ( a- ) t-, ;
t: literal, ( n- ) 1 # t-, t-, ;
( Conditionals and Flow Control ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: (if) ( -a )
t-, t-here 0 # t-, ;
t: t-=if ( R: xy- C: -a )
12 # jump: (if)
t: t->if ( R: xy- C: -a )
11 # jump: (if)
t: t-<if ( R: xy- C: -a )
10 # jump: (if)
t: t-!if ( R: xy- C: -a )
13 # jump: (if)
t: t-then ( R: - C: a- )
t-here swap, !, ;
t: t-repeat ( R: - C: -a )
t-here ;
t: t-again ( R: - C: a- )
8 # t-, t-, ;
t: until ( R: f- C: a- )
1 # t-, 0 # t-, 13 # t-, t-here 3 # +, t-, 8 # t-, t-, ;
t: t-0; ( n-n || n- ) 25 # t-, ;
( Word Classes ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: with-class ( ac- ) jump: execute
t: .word ( a- ) compiler # @, if t-, ; then jump: execute
t: .macro ( a- ) jump: execute
t: .data ( a- ) compiler # @, 0; drop, jump: literal,
' .word 'WORD set-class
' .macro 'MACRO set-class
' .data 'DATA set-class
( Console Output ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
-1 variable: update
t: redraw ( - ) update # @, 0; drop, 0 # 3 # out, ;
t: emit ( c- ) 1 # 2 # out, wait redraw ;
t: cr ( - ) 10 # emit ;
t: (type) ( a-a ) repeat @+ 0; emit again ;
t: type ( a- ) update # off (type) drop, update # on redraw ;
( Console Input ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
variable break ( Holds the delimiter for 'accept' )
-1 variable: whitespace ( Allow extended whitespace )
t: remap-keys ( c-c ) ;
t: ws ( c-c )
dup, 127 # =if drop, 8 # then
dup, 13 # =if drop, 10 # then
whitespace # @, 0; drop,
dup, 9 # =if drop, 32 # then
dup, 10 # =if drop, 32 # then ;
t: key ( -c )
repeat
1 # 1 # out,
wait 1 # in,
dup, 0 # !if remap-keys ws ; then drop,
again ;
t: emit? dup, 8 # =if drop, break # @, ; then dup, emit ;
t: eat-leading ( a-a )
repeat
key emit? dup,
break # @, !if swap, !+ ; then drop,
again ;
t: guard? dup, 1+, TIB # <if drop, TIB # ; then 8 # emit ;
t: (accept) ( a-a )
repeat
key
dup, 8 # =if drop, 1-, guard? jump: (accept) then
dup, emit
dup, break # @, =if drop, ; then
swap, !+
again ;
t: accept ( c- )
break # !, TIB # eat-leading (accept) 0 # swap, !+ drop, ;
( Colon Compiler ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: d->class ( a-a ) 1+, ;
t: d->xt ( a-a ) 1+, 1+, ;
t: d->name ( a-a ) 1+, 1+, 1+, ;
t: create ( "- ) t-here ( Entry Start )
last # @, t-, ( Link to previous )
last # !, ( Set as newest )
' .data # t-, ( Class = .data )
t-here 0 # t-, ( XT )
32 # accept TIB # $ ( Name )
t-here swap, !, ; ( Patch XT to HERE )
t: (:) ( - ) last # @, d->class !, ] 0 # t-, 0 # t-, ;
t: : ( "- ) create ' .word # (:) ;
t: t-( ( "- ) char: ) # accept ;
( Strings ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: compare ( $$-f )
repeat
dup, @, push, 1+, swap,
dup, @, push, 1+, pop, dup, pop,
!if drop, drop, dup, xor, ; then
0 # 12 m, m,
drop, drop, -1 # ;
t: count ( a-a ) repeat @+ 0; drop, again ;
t: getLength ( a-n ) dup, count 1-, swap, -, ;
t: pad ( -a ) heap # @, 4096 # +, ;
t: tempString ( a-a )
heap # @, swap, pad heap # !,
$ heap # !, pad ;
t: keepString ( a-a )
dup, getLength 1+, 1+, 1+, t-here +,
8 # t-, t-, t-here swap, $ ;
t: t-" ( "-a )
char: " # accept TIB # tempString ;
t: s" ( R: -a C: "- )
t-" keepString literal, ;
( Numbers [Parsing & Display] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
variable #value variable num
variable negate? variable flag
label: nums " 0123456789ABCDEF" $,
label: base 10 m,
t: (digits) nums # +, @, over =if num # on then ;
t: digits 1- repeat dup, push, (digits) pop, 0; 1- again ;
t: (digit)
base # @,
dup, 10 # =if digits ; then
dup, 16 # =if digits ; then
dup, 8 # =if digits ; then
dup, 2 # =if digits ; then
drop, ;
t: digit?
num # off (digit) drop, num # @, ;
t: char>digit ( c-n )
char: 0 # -,
base # @, 16 # =if dup, 16 # >if 7 # -, then then ;
t: isNegative? ( a-a )
dup, @, char: - # =if -1 # negate? # !, 1+, ; then
1 # negate? # !, ;
t: (convert)
repeat
dup, @, 0; char>digit #value # @, base # @, *, +,
#value # !, 1+,
again ;
t: >number ( $-n )
isNegative? 0 # #value # !, (convert) drop,
#value # @, negate? # @, *, ;
t: (isnumber)
repeat
dup, @, 0; digit? flag # @, and, flag # !, 1+,
again ;
t: isnumber?
isNegative? -1 # flag # !, (isnumber) drop,
flag # @, ;
t: <#>
repeat base # @, /mod, swap, nums # +, @, swap, 0; again ;
t: neg? dup, 0 # >if ; then 45 # emit -1 # *, ;
t: display repeat 0; emit again ;
t: (.) neg? 0 # swap, <#> display ;
( Startup ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
variable #mem ( Amount of memory provided )
variable fb ( canvas present? )
variable fw ( framebuffer width )
variable fh ( framebuffer height )
t: boot ( - ) copytag # type cr ;
t: query ( n-n ) 5 # out, wait, 5 # in, ;
t: time ( -n ) -8 # query ;
t: run-on-boot ( - )
-1 # query #mem # !, ( Memory Size )
-2 # query fb # !, ( Canvas Present? )
-3 # query fw # !, ( Canvas Width )
-4 # query fh # !, ( Canvas Height )
boot ;
( Dictionary Search ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
variable name
variable found
t: prepare ( a-a ) found # off name # !, last # @, ;
t: done ( -af ) which # @, found # @, ;
t: match? ( $-$f ) dup, d->name name # @, compare ;
t: <search> ( $- )
repeat match? if which # !, found # on ; then @ 0; again ;
t: find ( "-af ) prepare <search> done ;
t: t-' ( "-a )
32 # accept TIB # find if d->xt @, ; then drop, 0 # ;
t: t-['] ( R: -a C: "- )
t-' literal, ;
( Word Prefixes and "Not Found" ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
label: ___ " ___" $,
t: get ( $-$ ) dup, @, ___ # 2 # +, !, 1+, ;
t: try ( - )
TIB # get find
if d->xt @, ___ # find
if dup, d->xt @, swap, d->class @, with-class pop, pop, 2drop ; then
drop,
then drop, ;
t: filter ( - ) TIB # getLength 2 # >if try then ;
t: notfound ( - ) filter char: ? # emit cr ;
t: __& ( a-n ) .data ;
t: __+ ( a- ) .data ' +! # .word ;
t: __- ( a- ) .data ' -! # .word ;
t: __@ ( a-n ) .data ' @ # .word ;
t: __! ( a-n ) .data ' ! # .word ;
( Listener ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
t: ok ( - )
compiler # @, 0 # =if cr okmsg # type then ;
t: <word> ( d- ) dup, d->xt @, swap, d->class @, jump: with-class
t: <number> ( - )
TIB # isnumber?
if TIB # >number ' .data # jump: with-class then
notfound ;
t: process ( af- ) if <word> ; then drop <number> ;
t: listen ( - ) repeat ok 32 # accept TIB # find process again ;
( Initial Dictionary ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
' 1+ word: 1+ ' 1- word: 1-
' swap word: swap ' drop word: drop
' and word: and ' or word: or
' xor word: xor ' @ word: @
' ! word: ! ' + word: +
' - word: - ' * word: *
' /mod word: /mod ' << word: <<
' >> word: >> ' nip word: nip
' dup word: dup ' in word: in
' out word: out ' accept word: accept
' t-here word: here ' t-, word: ,
' ] word: ] ' create word: create
' : word: : ' later word: later
' cr word: cr ' emit word: emit
' remap-keys word: remap-keys ' type word: type
' over word: over ' 2drop word: 2drop
' not word: not ' rot word: rot
' -rot word: -rot ' tuck word: tuck
' 2dup word: 2dup ' on word: on
' off word: off ' / word: /
' mod word: mod ' neg word: neg
' execute word: execute ' (.) word: (.)
' t-" word: " ' compare word: compare
' wait word: wait ' t-' word: '
' @+ word: @+ ' !+ word: !+
' +! word: +! ' -! word: -!
' compile word: compile ' literal, word: literal,
' tempString word: tempString ' redraw word: redraw
' keepString word: keepString ' getLength word: getLength
' with-class word: with-class ' .word word: .word
' .macro word: .macro ' .data word: .data
' d->class word: d->class ' d->xt word: d->xt
' d->name word: d->name ' boot word: boot
' >number word: >number ' ok word: ok
' listen word: listen ' isnumber? word: isNumber?
' key word: key ' find word: find
' notfound word: notfound ' time word: time
' s" macro: s" ' [ macro: [
' t-; macro: ; ' ;; macro: ;;
' t-=if macro: =if ' t->if macro: >if
' t-<if macro: <if ' t-!if macro: !if
' t-then macro: then ' t-repeat macro: repeat
' t-again macro: again ' t-0; macro: 0;
' push macro: push ' pop macro: pop
' t-['] macro: ['] ' t-( macro: (
' until macro: until ' __& macro: __&
' __+ macro: __+ ' __- macro: __-
' __@ macro: __@ ' __! macro: __!
last data: last compiler data: compiler
TIB data: tib update data: update
fb data: fb fw data: fw
fh data: fh #mem data: #mem
heap data: heap which data: which
whitespace data: whitespace base data: base
patch-dictionary
( Finish Metacompiled Part ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
main: run-on-boot jump: listen
boot-new
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Ok, at this point the new image should be in control so we )
( have a normal Retro environment from here on. )
( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
( Scope ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
create list ( -a ) 0 , 0 , 0 , 0 , 0 ,
: { ( - ) @last @list 1+ list + ! 1 +list ;
: } ( - ) 1 -list @list 1+ list + @ last ! ;
: {{ ( - ) @last !list ;
: ---reveal--- ( - ) last @ list 1+ ! ;
here ] last repeat @ dup @ list 1+ @ =if ;; then again ;
: }} ( - ) @list [ compile ] ! ;
( Misc. Words ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: save ( - ) 1 4 out wait ;
: bye ( - ) cr -9 5 out wait ;
: depth ( -n ) -5 5 out wait 5 in ;
: reset ( ...- ) depth repeat 0; 1- nip again ;
: include ( "- ) 32 accept tib 2 4 out wait ;
( Vectored Execution ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: :devector ( a- ) dup 0 swap ! 1+ 0 swap ! ;
: :is ( aa- ) dup 8 swap ! 1+ ! ;
: devector ( "- ) ' 0; :devector ;
: is ( a"- ) ' 0; :is ;
( Dictionary ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: forget ( "- ) ' 0; drop @which dup !heap @ !last ;
: d' ( "-a ) ' drop @which ;
{{
: after ( a-a ) last repeat @ 2dup @ =if nip ;; then again ;
: remove ( a- ) dup @ swap after ! ;
: replace ( a- ) @last over ! !last ;
---reveal---
: >last ( a- ) dup remove replace ;
: expose ( "- ) d' >last ;
}}
( Classes ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: .primitive ( a- )
dup @ 0 =if @compiler -1 =if 2 + @ , ;; then then .word ;
: .compiler ( a- ) @compiler -1 =if execute ;; then drop ;
: reclass ( a- ) @last d->class ! ;
: reclass: ( a"- ) d' d->class ! ;
: immediate ( - ) &.macro reclass ;
: compile-only ( "- ) &.compiler reclass ;
: p: ( "- ) &.primitive reclass: ;
p: 1+ p: 1- p: swap p: drop
p: and p: or p: xor p: @
p: ! p: + p: - p: *
p: /mod p: << p: >> p: dup
p: in p: out
forget p:
: c: &.compiler reclass: ;
c: =if c: >if c: <if c: !if
c: then c: pop c: push c: 0;
c: ;; c: ; c: s" c: [']
c: repeat c: until c: again
forget c:
( Compiler Macros ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: ` ( "- )
' dup 0 !if literal, @which d->class @ compile ;; then
drop tib >number literal, &.data compile ; compile-only
: stub ( "- ) ` : ` ; ;
: r ( -n ) ` pop ` dup ` push ; compile-only
: rdrop ( - ) ` pop ` drop ; compile-only
( Counted Loops ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
: i pop pop pop 2dup push push swap - swap push ;
---reveal---
: for ( R: n- C: -a )
here ` push ; compile-only
: next ( R: - C: a- )
` pop ` 1- ` dup ` until ` drop ; compile-only
: fori ( n- ) ` dup ` push ` for ` i ; compile-only
: nexti ( - ) ` next ` pop ` drop ; compile-only
}}
( Parsing ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: char: ( "-c ) 32 accept tib @ .data ; immediate
( Data Structures ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: ++ ( a- ) 1 swap +! ;
: -- ( a- ) 1 swap -! ;
: variable: ( n"- ) create , ;
: variable ( "- ) 0 variable: ;
: constant ( n"- ) create last @ d->xt ! ;
: allot ( n- ) dup 0 <if +heap ;; then repeat 0; 1- 0 , again ;
{{
: list ( n-a ) here swap allot ;
: element ( a-a ) create dup @last d->xt ! 1+ ;
---reveal---
: elements ( n"- ) dup list swap for element next drop ;
}}
( Memory Blocks ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: copy ( aan- ) for push @+ pop !+ next 2drop ;
: fill ( ann- ) swap here ! for here @ swap !+ next drop ;
( Conditionals ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: ahead ( -a ) 8 , here 0 , ;
: if ( f- ) 0 literal, ` !if ; compile-only
: if; ( f- ) ` not ` 0; ` drop ; compile-only
: ;then ( a- ) ` ;; ` then ; compile-only
: else ( a-a ) ahead swap ` then ; compile-only
: = ( xy-f ) =if -1 ;then 0 ;
: <> ( xy-f ) !if -1 ;then 0 ;
: > ( xy-f ) >if -1 ;then 0 ;
: < ( xy-f ) <if -1 ;then 0 ;
: within ( xlu-f ) push over pop < push > pop + -2 = ;
( Numbers and Math ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: decimal ( - ) 10 !base ;
: hex ( - ) 16 !base ;
: octal ( - ) 8 !base ;
: binary ( - ) 2 !base ;
: pow ( bp-n ) over here ! 1- 0; for here @ * next ;
( Dictionary Headers ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
: skim ( a-a ) last repeat @ 2dup d->xt @ =if nip ;then 0; again ;
---reveal---
: xt->d ( a-d || a-0 ) dup skim 2dup =if - ;then nip ;
}}
( does> ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: .does ( C: aa- R: aa-a )
@compiler if swap literal, compile rdrop ;then drop ;
: does> ( -a )
1 , here 0 , ` reclass ` ;; here swap ! here literal, ` .does ; compile-only
( Output ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: clear ( - ) -1 emit ;
: space ( - ) 32 emit ;
: . ( n- ) (.) space ;
: ." ( "- )
compiler @ if ` s" ` type ;then " type ; immediate
( Evaluate A String ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
variable count
variable buffer
: restore ( - )
&emit :devector
&key :devector ok ;
: get ( -c ) @buffer @ ;
: next ( -c )
count @ 0 =if 32 restore ;then
count -- get buffer ++ ;
: replace ( - )
&drop &emit :is
&next &key :is ;
---reveal---
: eval ( an- ) !count !buffer replace ;
}}
( Conditional Execution ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
: defined ( "-f ) 32 accept tib find nip ;
: evalTib ( - ) tib dup getLength eval ;
: block ( "- )
key char: { =if char: { emit char: } accept else
." Invalid Syntax" cr then ;
: evalBlock ( "- ) block evalTib ;
: ifBlock ( f"- ) if evalBlock ;then block ;
---reveal---
: ifDefined ( "- ) defined ifBlock ;
: ifNotDefined ( "- ) defined not ifBlock ;
}}
( Vocabularies ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
3 elements shown hidden before
create nest 24 allot
variable depth
: .shown ( -a ) @shown d->xt @ ;
: .hidden ( -a ) .shown 1+ ;
: .before ( -a ) .shown 1+ 1+ ;
: after ( a-a ) last repeat @ 2dup @ =if nip ;then again ;
: remove ( a- ) @shown dup @ swap after ! ;
: replace ( a- ) @shown @last over ! !last ;
: fields ( - ) shown .shown 3 copy ;
: open ( a- ) @ !shown .hidden @ .shown @ ! ;
: shut ( a- ) @ !shown .before @ .shown @ ! ;
: :find ( a-af ) last repeat @ 2dup =if drop @ -1 ;then dup 0; drop again ;
: open? ( a-af ) dup 1+ @ :find nip ;
: toggle ( a- ) open? if shut ;then open ;
: descend ( - ) shown @depth 3 * nest + 3 copy depth ++ ;
: ascend ( - ) depth -- @depth 3 * nest + shown 3 copy ;
---reveal---
expose open expose shut
: .vocab ( a- ) .data ` toggle ;
: vocab ( "- ) create 3 allot ['] .vocab reclass ;
: (( ( - ) descend @last !shown @last @ !before 0 !hidden fields ;
: )) ( - ) @last !hidden fields remove replace ascend ;
: >vocab ( aa- ) push @last dup @ !last dup r 1+ dup @ -rot ! swap ! pop open ;
}}
( Debugging ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
{{
: (.s) ( - )
depth 0; drop push (.s) pop dup . ;
: <depth> char: < emit depth (.) char: > emit space ;
---reveal---
: .s ( - ) <depth> (.s) cr ;
: words ( - ) last repeat @ 0; dup d->name type space again ;
}}
( Retro Vocabulary ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
stub rx
vocab retro
((
expose .s expose words
expose elements expose >vocab
expose )) expose ((
expose vocab expose .vocab
expose shut expose open
expose expose expose >last
expose nexti expose fori
expose ifDefined expose ifNotDefined
expose eval expose space
expose does> expose .does
expose xt->d expose .
expose find expose binary
expose octal expose hex
expose decimal expose ."
expose within expose rdrop
expose r expose pow
expose < expose >
expose <> expose =
expose ahead expose allot
expose else expose ;then
expose if; expose if
expose stub expose `
expose fill expose copy
expose constant expose variable
expose variable: expose }}
expose ---reveal---
expose {{ expose }
expose { expose list
expose -- expose ++
expose char: expose immediate
expose compile-only
expose .compiler expose .primitive
expose reclass: expose reclass
expose d' expose forget
expose base expose whitespace
expose which expose heap
expose #mem expose fh
expose fw expose fb
expose update expose tib
expose compiler expose last
expose until
expose ( expose next
expose for expose [']
expose pop expose push
expose 0; expose again
expose repeat expose then
expose !if expose <if
expose >if expose =if
expose ;; expose ;
expose [ expose s"
expose key
expose include expose time
expose isNumber? expose listen
expose ok expose >number
expose save expose notfound
expose reset expose depth
expose boot expose d->name
expose d->xt expose d->class
expose .data expose .macro
expose .word expose with-class
expose remap-keys expose bye
expose getLength expose keepString
expose redraw expose tempString
expose literal, expose compile
expose devector expose is
expose :devector expose :is
expose -! expose +!
expose !+ expose @+
expose ' expose wait
expose compare expose "
expose (.) expose execute
expose neg expose mod
expose / expose off
expose on expose 2dup
expose tuck expose -rot
expose rot expose not
expose 2drop expose over
expose clear expose type
expose emit expose cr
expose later expose :
expose create expose ]
expose , expose here
expose accept expose out
expose in expose dup
expose nip expose >>
expose << expose /mod
expose * expose -
expose + expose !
expose @ expose xor
expose or expose and
expose drop expose swap
expose 1- expose 1+
))
( Prefixes ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
vocab prefixes
((
expose __@ expose __!
expose __+ expose __-
expose __&
))
: prefix ( - ) &prefixes >vocab &prefixes shut &prefixes open ;
' retro >vocab
( Files ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
vocab files
((
0 constant :r 1 constant :r+ 2 constant :w
3 constant :w+ 4 constant :a 5 constant :a+
{{
: file.io ( n-f ) 4 out wait 4 in ;
---reveal---
: fopen ( $m-f ) -1 file.io ;
: fread ( h-f ) -2 file.io ;
: fwrite ( ch-f ) -3 file.io ;
: fclose ( h -f ) -4 file.io ;
: fpos ( h -n ) -5 file.io ;
: fseek ( nh-f ) -6 file.io ;
: fsize ( h-n ) -7 file.io ;
}}
))
' files shut
( Sockets ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
vocab net
((
: net.socket ( -s ) -1 8 out wait ;
: net.bind ( sp-f ) -2 8 out wait ;
: net.listen ( s-f ) -3 8 out wait ;
: net.accept ( s-f ) -4 8 out wait ;
: net.close ( s-f ) -5 8 out wait ;
: net.send ( $s-f ) -6 8 out wait ;
: net.recv ( s-c ) -7 8 out wait ;
: net.connect ( $ps-f ) -8 8 out wait ;
))
' net shut
( Canvas Words ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
vocab canvas
((
( Mouse ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: mouse ( -xy ) 1 7 out wait ;
: click? ( -f ) 2 7 out wait ;
( Drawing ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: setColor ( c- ) 1 6 out wait ;
: pixel ( xy- ) 2 6 out wait ;
: box ( xyhw- ) 3 6 out wait ;
: solidBox ( xyhw- ) 4 6 out wait ;
: vline ( xyh- ) 5 6 out wait ;
: hline ( xyw- ) 6 6 out wait ;
: circle ( xyw- ) 7 6 out wait ;
: solidCircle ( xyw- ) 8 6 out wait ;
( Colors ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
: black 0 setColor ; : blue 1 setColor ;
: green 2 setColor ; : cyan 3 setColor ;
: red 4 setColor ; : purple 5 setColor ;
: brown 6 setColor ; : gray 7 setColor ;
: darkgray 8 setColor ; : brightblue 9 setColor ;
: brightgreen 10 setColor ; : brightcyan 11 setColor ;
: brightred 12 setColor ; : magenta 13 setColor ;
: yellow 14 setColor ; : white 15 setColor ;
))
' canvas shut
save bye |