Changeset 235b9862054e9eae6b27742f5c736ba30e746ab3

	d05441d54436f7e8789bdd0e06cb78d8e36f2040		235b9862054e9eae6b27742f5c736ba30e746ab3
1	VM = ../retro	1	VM = ../../retro
2	STATS = --opstats build.stats --callstats	2	STATS = --opstats build.stats --callstats
3		3
4	default: image errors	4	default: core image
5		5
6	image:	6	core:
7	cp pristine retroImage	7	@echo Building core image...
8	$(VM) --shrink --with build.retro >build.log	8	@cp coreImage source_core
9		9	@cd source_core && $(VM) --with build.retro coreImage --shrink >../build.log
10	initial: base errors	10	@cat build.log \| grep -v ok
		11	@mv source_core/coreImage .
11		12
12	base:	13	image:
13	cp pristine retroImage	14	@echo Extending core image...
14	$(VM) --shrink --with minimal.retro >build.log	15	@cp coreImage source_rest/retroImage
15	cp retroImage pristine	16	@cd source_rest && $(VM) --with build.retro --shrink >../build.log
		17	@cat build.log \| grep -v ok
		18	@mv source_rest/retroImage .
16		19
17	errors:
18	cat build.log \| grep -v ok
19		20
20	js: image	21	js: full
21	$(VM) --with tools/image2js.retro >js0	22	cd tools && $(VM) --with image2js.retro ../retroImage >../js0
22	sed '1,10d' js0 \| grep -v ok >retroImage.js	23	sed '1,10d' js0 \| grep -v ok >retroImage.js
23	rm -f js0	24	rm -f js0
24		25
25	midp: image	26	midp: image
		27	cd tools && $(VM) --with image2midp.retro ../retroImage >../js0
26	$(VM) --with tools/image2midp.retro >js0	28	$(VM) --with tools/image2midp.retro >js0
27	sed '1,10d' js0 \| sed s'/ \]/\]/g' \| sed 's/ \;/\;/g' \| grep -v ok >Img.java	29	sed '1,10d' js0 \| sed s'/ \]/\]/g' \| sed 's/ \;/\;/g' \| grep -v ok >Img.java
28	rm -f js0	30	cd tools && $(VM) --with image2midp2.retro ../retroImage >../js0
29	$(VM) --with tools/image2midp2.retro >js0
30	sed '1,10d' js0 \| sed s'/ \]/\]/g' \| sed 's/ \;/\;/g' \| grep -v ok >Img2.java	31	sed '1,10d' js0 \| sed s'/ \]/\]/g' \| sed 's/ \;/\;/g' \| grep -v ok >Img2.java
31	rm -f js0	32	rm -f js0
32		33
33	stats:
34	$(VM) $(STATS) --with build.retro >build.log
35
36	clean:	34	clean:
37	@rm -f build.log retroImage.js Img.java Img2.java build.stats	35	@rm -f build.log retroImage.js Img.java Img2.java build.stats

	d05441d54436f7e8789bdd0e06cb78d8e36f2040		235b9862054e9eae6b27742f5c736ba30e746ab3
		1	include meta.retro
		2	include core.retro
		3	include stage2.retro
		4	include vocabs.retro
		5	save bye

	d05441d54436f7e8789bdd0e06cb78d8e36f2040		235b9862054e9eae6b27742f5c736ba30e746ab3
		1	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		2	( Retro )
		3	( Copyright [c] 2009 - 2010, Charles Childers )
		4	( License: ISC )
		5	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		6
		7	' meta open
		8
		9	2580 constant TIB
		10	3072 constant HEAP
		11
		12	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		13	mark-dictionary ( Pointer to the most recent dictionary )
		14	variable last ( header )
		15	HEAP variable: heap ( Starting address of the data/code heap )
		16	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		17	variable which ( Pointer to dictionary header of the most )
		18	( recently looked up word )
		19	variable compiler ( Is the compiler on or off? )
		20	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		21	label: copytag " RETRO" $,
		22	label: okmsg " ok " $,
		23	padding
		24	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		25	t: dup ( n-nn ) dup, ; t: 1+ ( n-n ) 1+, ;
		26	t: 1- ( n-n ) 1-, ; t: swap ( xy-yx ) swap, ;
		27	t: drop ( n- ) drop, ; t: and ( xy-n ) and, ;
		28	t: or ( xy-n ) or, ; t: xor ( xy-n ) xor, ;
		29	t: @ ( a-n ) @, ; t: ! ( na- ) !, ;
		30	t: + ( xy-n ) +, ; t: - ( xy-n ) -, ;
		31	t: * ( xy-n ) *, ; t: /mod ( xy-qr ) /mod, ;
		32	t: << ( xy-n ) <<, ; t: >> ( xy-n ) >>, ;
		33	t: out ( np- ) out, ; t: in ( p-n ) in, ;
		34
		35	t: wait ( - ) 0 # 0 # out, wait, ;
		36
		37	t: nip ( xy-y ) swap, drop, ;
		38	t: over ( xy-xyx ) push, dup, pop, swap, ;
		39	t: 2drop ( nn- ) drop, drop, ;
		40	t: not ( x-y ) -1 # xor, ;
		41	t: rot ( xyz-yzx ) push, swap, pop, swap, ;
		42	t: -rot ( xyz-xzy ) swap, push, swap, pop, ;
		43	t: tuck ( xy-yxy ) dup, -rot ;
		44	t: 2dup ( x-xx ) over over ;
		45	t: on ( a- ) -1 # swap, !, ;
		46	t: off ( a- ) 0 # swap, !, ;
		47	t: / ( xy-q ) /mod, nip ;
		48	t: mod ( xy-r ) /mod, drop, ;
		49	t: neg ( x-y ) -1 # *, ;
		50	t: execute ( a- ) 1-, push, ;
		51	t: later ( - ) pop, pop, swap, push, push, ;
		52	t: @+ ( a-ac ) dup, 1+, swap, @, ;
		53	t: !+ ( ca-a ) dup, 1+, push, !, pop, ;
		54	t: +! ( na- ) dup, push, @, +, pop, !, ;
		55	t: -! ( na- ) dup, push, @, swap, -, pop, !, ;
		56	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		57	t: t-here ( -a ) heap # @, ;
		58	t: t-, ( n- ) t-here !, t-here 1+, heap # !, ;
		59	t: ] ( - ) compiler # on ;
		60	t: [ ( - ) compiler # off ;
		61	t: ;; ( - ) 9 # t-, ;
		62	t: t-; ( - ) ;; [ ;
		63	t: ($,) ( a-a ) repeat @+ 0; t-, again ;
		64	t: $ ( a- ) ($,) drop, 0 # t-, ;
		65	t: t-push ( n- ) 5 # t-, ;
		66	t: t-pop ( -n ) 6 # t-, ;
		67	t: compile ( a- ) t-, ;
		68	t: literal, ( n- ) 1 # t-, t-, ;
		69	t: (if) ( -a )
		70	t-, t-here 0 # t-, ;
		71	t: t-=if ( R: xy- C: -a )
		72	12 # jump: (if)
		73	t: t->if ( R: xy- C: -a )
		74	11 # jump: (if)
		75	t: t-<if ( R: xy- C: -a )
		76	10 # jump: (if)
		77	t: t-!if ( R: xy- C: -a )
		78	13 # jump: (if)
		79	t: t-then ( R: - C: a- )
		80	t-here swap, !, ;
		81	t: t-repeat ( R: - C: -a )
		82	t-here ;
		83	t: t-again ( R: - C: a- )
		84	8 # t-, t-, ;
		85	t: until ( R: f- C: a- )
		86	1 # t-, 0 # t-, 13 # t-, t-here 3 # +, t-, 8 # t-, t-, ;
		87	t: t-0; ( n-n \|\| n - ) 25 # t-, ;
		88
		89	t: .word ( a- )
		90	compiler # @, if t-, ; then jump: execute
		91	t: .macro ( a- )
		92	jump: execute
		93	t: .data ( a- )
		94	compiler # @, 0; drop, jump: literal,
		95
		96	' .word 'WORD set-class
		97	' .macro 'MACRO set-class
		98	' .data 'DATA set-class
		99	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		100	-1 variable: update
		101	t: redraw ( - ) update # @, 0; drop, 0 # 3 # out, ;
		102	t: emit ( c- ) 1 # 2 # out, wait redraw ;
		103	t: cr ( - ) 10 # emit ;
		104	t: clear ( - ) -1 # emit ;
		105	t: (type) ( a-a ) repeat @+ 0; emit again ;
		106	t: type ( a- ) update # off (type) drop, update # on redraw ;
		107	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		108	variable break ( Holds the delimiter for 'accept' )
		109	-1 variable: whitespace ( Allow extended whitespace )
		110
		111	t: remap-keys ( c-c ) ;
		112	t: ws ( c-c )
		113	dup, 127 # =if drop, 8 # then
		114	dup, 13 # =if drop, 10 # then
		115	whitespace # @, 0; drop,
		116	dup, 9 # =if drop, 32 # then
		117	dup, 10 # =if drop, 32 # then
		118	;
		119
		120	t: key ( -c )
		121	repeat
		122	1 # 1 # out,
		123	wait 1 # in,
		124	dup, 0 # !if remap-keys ws ; then drop,
		125	again
		126	;
		127
		128	t: ekey ( -c ) key dup, emit ;
		129
		130	t: emit? dup, 8 # =if drop, break # @, ; then dup, emit ;
		131
		132	t: eat-leading ( a-a )
		133	repeat
		134	key emit? dup,
		135	break # @, !if swap, !+ ; then drop,
		136	again ;
		137
		138	t: guard? dup, 1+, TIB # <if drop, TIB # ; then 8 # emit ;
		139
		140	t: (accept) ( a-a )
		141	repeat
		142	key
		143	dup, 8 # =if drop, 1-, guard? jump: (accept) then
		144	dup, emit
		145	dup, break # @, =if drop, ; then
		146	swap, !+
		147	again ;
		148
		149	t: accept ( c- )
		150	break # !, TIB # eat-leading (accept) 0 # swap, !+ drop, ;
		151	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		152	t: d->class ( a-a ) 1+, ;
		153	t: d->xt ( a-a ) 1+, 1+, ;
		154	t: d->name ( a-a ) 1+, 1+, 1+, ;
		155	t: create ( "- ) t-here ( Entry Start )
		156	last # @, t-, ( Link to previous )
		157	last # !, ( Set as newest )
		158	' .data # t-, ( Class = .data )
		159	t-here 0 # t-, ( XT )
		160	32 # accept TIB # $ ( Name )
		161	t-here swap, !, ; ( Patch XT to HERE )
		162	t: (:) ( - ) last # @, d->class !, ] 0 # t-, 0 # t-, ;
		163	t: : ( "- ) create ' .word # (:) ;
		164	t: t-( ( "- ) char: ) # accept ;
		165	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		166	( A more readable "compare":
		167
		168	t: get-set [ ab-xy ] @, swap, @, ;
		169	t: next-set [ ab-cd ] 1+, swap, 1+, ;
		170	t: compare [ $$-f ]
		171	repeat
		172	2dup get-set
		173	2dup !if 2drop 2drop 0 # ; then
		174	+, 0 # =if 2drop -1 # ; then
		175	next-set
		176	again
		177	;
		178
		179	We use the less readable one below for performance
		180	reasons.
		181	)
		182
		183	t: compare ( $$-f )
		184	repeat
		185	dup, @, push, 1+, swap,
		186	dup, @, push, 1+, pop, dup, pop,
		187	!if drop, drop, dup, xor, ; then
		188	0 # 12 m, m,
		189	drop, drop, -1 #
		190	;
		191
		192	t: count ( a-a ) repeat @+ 0; drop, again ;
		193	t: getLength ( a-n ) dup, count 1-, swap, -, ;
		194	t: pad ( -a ) heap # @, 4096 # +, ;
		195
		196	t: tempString ( a-a )
		197	heap # @, swap, pad heap # !,
		198	$ heap # !, pad ;
		199
		200	t: keepString ( a-a )
		201	dup, getLength 1+, 1+, 1+, t-here +,
		202	8 # t-, t-, t-here swap, $
		203	;
		204
		205	t: t-" ( "-a )
		206	char: " # accept TIB # tempString ;
		207	t: s" ( R: -a C: "- )
		208	t-" keepString literal, ;
		209	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		210	variable #value variable num
		211	variable negate? variable flag
		212
		213	label: nums " 0123456789ABCDEF" $,
		214	label: base 10 m,
		215
		216	t: digits
		217	1- repeat dup, push, nums # +, @, over =if num # on then pop, 0; 1-, again ;
		218	t: (digit)
		219	base # @,
		220	dup, 10 # =if digits ; then
		221	dup, 16 # =if digits ; then
		222	dup, 8 # =if digits ; then
		223	dup, 2 # =if digits ; then
		224	drop,
		225	;
		226	t: digit?
		227	num # off (digit) drop, num # @, ;
		228
		229	t: char>digit ( c-n )
		230	char: 0 # -,
		231	base # @, 16 # =if dup, 16 # >if 7 # -, then then ;
		232
		233	t: isNegative?
		234	( a-a+1 )
		235	dup, @, char: - # =if -1 # negate? # !, 1+, ; then
		236	1 # negate? # !, ;
		237
		238	t: (convert)
		239	repeat
		240	dup, @, 0; char>digit #value # @, base # @, *, +,
		241	#value # !, 1+,
		242	again ;
		243
		244	t: >number ( $-n )
		245	isNegative? 0 # #value # !, (convert) drop,
		246	#value # @, negate? # @, *, ;
		247
		248	t: (isnumber)
		249	repeat
		250	dup, @, 0; digit? flag # @, and, flag # !, 1+,
		251	again ;
		252
		253	t: isnumber?
		254	isNegative? -1 # flag # !, (isnumber) drop,
		255	flag # @, ;
		256
		257	t: <#> repeat base # @, /mod, swap, nums # +, @, swap, 0; again ;
		258	t: neg? dup, 0 # >if ; then 45 # emit -1 # *, ;
		259	t: display repeat 0; emit again ;
		260	t: (.) neg? 0 # swap, <#> display ;
		261	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		262	variable found
		263
		264	t: (search)
		265	repeat
		266	dup, d->name TIB # compare if which # !, found # on ; then
		267	@, 0;
		268	again
		269	;
		270
		271	t: search
		272	found # off last # @, (search) ;
		273
		274	t: t-' ( "-a )
		275	32 # accept search
		276	found # @, if which # @, d->xt @, ; then 0 #
		277	found # on ;
		278	t: t-['] ( R: -a C: "- )
		279	t-' literal, ;
		280	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		281	t: :devector ( a- ) dup, 0 # swap, !, 1+, 0 # swap, !, ;
		282	t: :is ( aa- ) dup, 8 # swap, !, 1+, !, ;
		283	t: devector ( "- ) t-' :devector ;
		284	t: is ( a"- ) t-' :is ;
		285	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		286	t: save ( - ) 1 # 4 # out, wait ;
		287	t: bye ( - ) cr -9 # 5 # out, wait, ;
		288	t: depth ( -n )
		289	-5 # 5 # out, wait, 5 # in, ;
		290	t: reset ( ...- )
		291	depth repeat 0; push, drop, pop, 1-, again ;
		292	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		293	t: include 32 # accept TIB # 2 # 4 # out, wait ;
		294	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		295	variable #mem ( Amount of memory provided )
		296	variable fb ( canvas present? )
		297	variable fw ( framebuffer width )
		298	variable fh ( framebuffer height )
		299
		300	t: boot ( - ) copytag # type cr ;
		301	t: capability: ( n-n ) 5 # out, wait, 5 # in, ;
		302	t: time ( -n ) -8 # capability: ;
		303	t: run-on-boot ( - )
		304	-1 # capability: #mem # !, ( Memory Size )
		305	-2 # capability: fb # !, ( Canvas Present? )
		306	-3 # capability: fw # !, ( Canvas Width )
		307	-4 # capability: fh # !, ( Canvas Height )
		308	boot ;
		309	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		310	t: with-class ( ac- ) jump: execute
		311	t: notfound ( - ) cr TIB # type 32 # emit char: ? # emit cr ;
		312	t: the->xt ( a-n ) which # @, d->xt @, ;
		313	t: the->class ( a-n ) which # @, d->class @, ;
		314	t: tib->number? ( -f ) TIB # isnumber? ;
		315	t: tib->number ( -n ) TIB # >number ' .data # jump: with-class
		316
		317	t: word? ( - )
		318	found # @, 0; drop, the->xt the->class jump: with-class
		319	t: number? ( - )
		320	found # @, not 0; drop,
		321	tib->number? if tib->number ; then notfound ;
		322	t: ok ( - )
		323	compiler # @, 0 # =if cr okmsg # type then ;
		324	t: listen ( - )
		325	repeat ok 32 # accept search word? number? again ;
		326	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		327
		328	' 1+ word: 1+ ' 1- word: 1-
		329	' swap word: swap ' drop word: drop
		330	' and word: and ' or word: or
		331	' xor word: xor ' @ word: @
		332	' ! word: ! ' + word: +
		333	' - word: - ' * word: *
		334	' /mod word: /mod ' << word: <<
		335	' >> word: >> ' nip word: nip
		336	' dup word: dup ' in word: in
		337	' out word: out ' accept word: accept
		338	' t-here word: here ' t-, word: ,
		339	' ] word: ] ' create word: create
		340	' : word: : ' later word: later
		341	' cr word: cr ' emit word: emit
		342	' type word: type ' clear word: clear
		343	' over word: over ' 2drop word: 2drop
		344	' not word: not ' rot word: rot
		345	' -rot word: -rot ' tuck word: tuck
		346	' 2dup word: 2dup ' on word: on
		347	' off word: off ' / word: /
		348	' mod word: mod ' neg word: neg
		349	' execute word: execute ' (.) word: (.)
		350	' t-" word: " ' compare word: compare
		351	' wait word: wait ' t-' word: '
		352	' @+ word: @+ ' !+ word: !+
		353	' +! word: +! ' -! word: -!
		354	' :is word: :is ' :devector word: :devector
		355	' is word: is ' devector word: devector
		356	' compile word: compile ' literal, word: literal,
		357	' tempString word: tempString ' redraw word: redraw
		358	' keepString word: keepString ' getLength word: getLength
		359	' bye word: bye ' remap-keys word: remap-keys
		360	' with-class word: with-class ' .word word: .word
		361	' .macro word: .macro ' .data word: .data
		362	' d->class word: d->class ' d->xt word: d->xt
		363	' d->name word: d->name ' boot word: boot
		364	' depth word: depth ' reset word: reset
		365	' notfound word: notfound ' save word: save
		366	' >number word: >number ' ok word: ok
		367	' listen word: listen ' isnumber? word: isNumber?
		368	' key word: key ' ekey word: ekey
		369	' time word: time ' include word: include
		370
		371	' s" macro: s" ' [ macro: [
		372	' t-; macro: ; ' ;; macro: ;;
		373	' t-=if macro: =if ' t->if macro: >if
		374	' t-<if macro: <if ' t-!if macro: !if
		375	' t-then macro: then ' t-repeat macro: repeat
		376	' t-again macro: again ' t-0; macro: 0;
		377	' t-push macro: push ' t-pop macro: pop
		378	' t-['] macro: ['] ' t-( macro: (
		379	' until macro: until
		380
		381	last data: last compiler data: compiler
		382	TIB data: tib update data: update
		383	fb data: fb fw data: fw
		384	fh data: fh #mem data: #mem
		385	heap data: heap which data: which
		386	whitespace data: whitespace base data: base
		387
		388	main: run-on-boot jump: listen
		389
		390	patch-dictionary
		391	boot-new

	d05441d54436f7e8789bdd0e06cb78d8e36f2040		235b9862054e9eae6b27742f5c736ba30e746ab3
		1	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		2	( Assembler and Metacompiler for Retro )
		3	( Copyright [c] 2009 - 2010, Charles Childers )
		4	( License: ISC )
		5	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		6
		7	vocab meta
		8	((
		9	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		10	( Configuration )
		11	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		12	4096 constant IMAGE-SIZE
		13
		14	: ok. cr depth . ." ok " ; ' ok. is ok
		15
		16	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		17	( Perform a check to see if we have enough free memory to )
		18	( actually build a new image. )
		19	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		20	: check ( - )
		21	#mem @ here - 4096 IMAGE-SIZE +
		22	<if cr ." Error: insufficent heap space" bye then ;
		23	check forget check
		24
		25
		26	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		27	( Variables used in the target image [classes, dictionary, etc)
		28	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		29	7 elements target origin 'WORD 'MACRO 'DATA link chain
		30
		31
		32	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		33	( The assembler )
		34	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		35	: m, ( n- ) target @ ! target ++ ;
		36	: vm: ( n"- ) ` : .data ` m, ` ; ;
		37
		38	0 vm: nop, 1 vm: lit, 2 vm: dup,
		39	3 vm: drop, 4 vm: swap, 5 vm: push,
		40	6 vm: pop, 7 vm: call, 8 vm: jump,
		41	9 vm: ;, 10 vm: >jump, 11 vm: <jump,
		42	12 vm: !jump, 13 vm: =jump, 14 vm: @,
		43	15 vm: !, 16 vm: +, 17 vm: -,
		44	18 vm: *, 19 vm: /mod, 20 vm: and,
		45	21 vm: or, 22 vm: xor, 23 vm: <<,
		46	24 vm: >>, 25 vm: 0; 26 vm: 1+,
		47	27 vm: 1-, 28 vm: in, 29 vm: out,
		48	30 vm: wait, 98 vm: halt,
		49
		50	: t-here ( -n ) target @ origin @ - ;
		51	: main: ( - ) t-here cr ." MAIN @ " dup . origin @ 1+ ! ;
		52	: label: ( "- ) t-here constant ;
		53	: # ( n- ) lit, m, ;
		54	: $, ( $- ) dup getLength for dup @ m, 1+ next 0 m, drop ;
		55
		56
		57	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		58	( And now the metacompiler )
		59	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		60	{{
		61	variable getxt
		62	: .colon getxt @ if getxt off ;then m, ;
		63	---reveal---
		64	: t: ( "- ) label: nop, nop, ['] .colon last @ d->class ! ;
		65	: t' ( "-a ) getxt on ;
		66	}}
		67
		68	{{
		69	: cond ( -a ) target @ 0 m, ;
		70	---reveal---
		71	: =if ( -a ) !jump, cond ;
		72	: <if ( -a ) >jump, cond ;
		73	: >if ( -a ) <jump, cond ;
		74	: !if ( -a ) =jump, cond ;
		75	: if ( -a ) 0 # !if ;
		76	: then ( a- ) t-here swap ! ;
		77	}}
		78
		79	: jump: ( "- ) jump, ' m, ;
		80	: repeat ( -a ) t-here ;
		81	: again ( a- ) jump, m, ;
		82
		83	: variable: ( n"- ) label: m, ;
		84	: variable ( "- ) 0 variable: ;
		85
		86	: entry ( a"- ) t-here link @ m, link ! m, m, 32 accept tib $, ;
		87	: word: ( a"- ) 'WORD @ entry ;
		88	: macro: ( a"- ) 'MACRO @ entry ;
		89	: data: ( a"- ) 'DATA @ entry ;
		90	: patch-dictionary ( - ) link @ chain @ ! ;
		91	: mark-dictionary ( - ) target @ chain ! ;
		92
		93	: set-class ( aa- ) ! ;
		94
		95
		96	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		97	( The last bit is the trickiest: we need to safely relocate )
		98	( the new image over the old one. Since we can't use any )
		99	( code that calls into the old image, we must redefine all )
		100	( words necessary here. )
		101	( )
		102	( If you're not targeting a different VM, use "store-and-quit")
		103	( instead of "boot-new" )
		104	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		105	{{
		106	: @+ ( a-ac ) dup 1+ swap @ ;
		107	: !+ ( ca-a ) dup 1+ push ! pop ;
		108	: copy ( aan- ) for push @+ pop !+ next drop drop ;
		109	: wait ( - ) 0 0 out [ 30 , ] ;
		110	: save ( - ) 1 4 out 0 0 out wait -9 5 out wait ;
		111	: relocate ( - ) origin @ 0 IMAGE-SIZE copy ;
		112	---reveal---
		113	: boot-new ( - ) relocate [ 0 , ] ;
		114	: save-and-quit ( - ) relocate save ;
		115	}}
		116
		117	: padding 129 t-here - for 0 m, next ;
		118
		119	: ; ;, ;; [
		120
		121	here IMAGE-SIZE zallot target ! target @ origin !
		122	jump, 0 m,
		123	))
		124	' meta shut

	d05441d54436f7e8789bdd0e06cb78d8e36f2040		235b9862054e9eae6b27742f5c736ba30e746ab3
		1	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		2	( Copyright [c] 2009 - 2010, Charles Childers )
		3	( License: ISC )
		4	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		5	( This contains the second stage of the Retro language. It's )
		6	( a collection of useful words and tools that make things )
		7	( nicer overall. )
		8	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		9
		10
		11	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		12	( Allows Retro to "forget" a word, and anything defined after )
		13	( it. )
		14	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		15	: forget ( "- ) ' 0; drop which @ dup heap ! @ last ! ;
		16
		17
		18	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		19	( Get a dictionary pointer for a word )
		20	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		21	: d' ( "-a ) ' drop which @ ;
		22
		23
		24	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		25	( Allow changing the class of a word )
		26	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		27	: reclass ( a- ) last @ d->class ! ;
		28	: reclass: ( a"- ) d' d->class ! ;
		29
		30
		31	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		32	( Special class for words that correspond to opcodes. Inlines )
		33	( if compiling, calls if interpreting. )
		34	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		35	: .primitive ( a- )
		36	dup @ 0 =if compiler @ -1 =if 2 + @ , ;; then then .word ;
		37
		38	: p: ( "- ) ['] .primitive reclass: ;
		39	p: 1+ p: 1- p: swap p: drop
		40	p: and p: or p: xor p: @
		41	p: ! p: + p: - p: *
		42	p: /mod p: << p: >> p: dup
		43	p: in p: out
		44	forget p:
		45
		46
		47	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		48	( Make the most recently created word run only if the compiler)
		49	( is on. )
		50	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		51	: .compiler ( a- ) compiler @ -1 =if execute ;; then drop ;
		52	: compile-only ( "- ) ['] .compiler reclass ;
		53
		54	: c: ['] .compiler reclass: ;
		55	c: =if c: >if c: <if c: !if
		56	c: then c: pop c: push c: 0;
		57	c: ;; c: ; c: s" c: [']
		58	c: repeat c: until c: again
		59	forget c:
		60
		61
		62	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		63	( Make the most recently created word execute into a compiler )
		64	( macro. )
		65	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		66	: immediate ( - ) ['] .macro reclass ;
		67
		68
		69	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		70	( Return ASCII value of a character )
		71	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		72	: char: ( "-c ) 32 accept tib @ .data ; immediate
		73
		74
		75	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		76	( Shortcuts for incrementing and decrementing variables )
		77	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		78	: ++ ( a- ) 1 swap +! ;
		79	: -- ( a- ) 1 swap -! ;
		80
		81
		82	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		83	( These words provide a limited degree of control over the )
		84	( visibility of words. )
		85	( )
		86	( In older versions of Retro, these were called loc: and ;loc )
		87	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		88	( ... global scope .... )
		89	( )
		90	( { ... start local scope, level 1 )
		91	( )
		92	( { ... start local scope, level 2 )
		93	( } ... words in scope level 2 are no longer )
		94	( ... visible )
		95	( )
		96	( } ... words in scope level 1 are no longer )
		97	( ... visible )
		98	( )
		99	( ... back to global scope ... )
		100	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		101	create <list> ( -a ) 0 , 0 , 0 , 0 , 0 ,
		102	: { ( - ) last @ <list> @ 1+ <list> + ! <list> ++ ;
		103	: } ( - ) <list> -- <list> @ 1+ <list> + @ last ! ;
		104
		105
		106	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		107	( A somewhat more powerful scoping system )
		108	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		109	( ... global scope ... )
		110	( {{ )
		111	( ... local scope ... )
		112	( ---reveal--- )
		113	( ... global scope, with local scope still visible ... )
		114	( }} )
		115	( ... global scope, local words not visible ... )
		116	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		117	: {{ ( - ) last @ <list> ! ;
		118	: ---reveal--- ( - ) last @ <list> 1+ ! ;
		119	here ] last repeat @ dup @ <list> 1+ @ =if ;; then again ;
		120	: }} ( - ) <list> @ [ compile ] ! ;
		121
		122
		123	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		124	( These allow a more readable way to create variables and )
		125	( constants. It also makes constants more efficient. )
		126	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		127	: variable: ( n"- ) create , ;
		128	: variable ( "- ) 0 variable: ;
		129	: constant ( n"- ) create last @ d->xt ! ;
		130
		131
		132	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		133	( A simple word to allocate memory in a linear fashion. It's )
		134	( useful for arrays and similar things. )
		135	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		136	: allot ( n- ) heap +! ;
		137	: zallot ( n- ) dup 0 <if allot ;; then repeat 0; 1- 0 , again ;
		138
		139
		140	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		141	( ` is similar to POSTPONE in ANS FORTH. It compiles code to )
		142	( execute the following word with its class handler. )
		143	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		144	: ` ( "- )
		145	' dup 0 !if literal, which @ d->class @ compile ;; then
		146	drop tib >number literal, ['] .data compile ; compile-only
		147
		148
		149	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		150	( Additional Looping Constructs )
		151	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		152	{{
		153	: i pop pop pop 2dup push push swap - swap push ;
		154	---reveal---
		155	: for ( R: n- C: -a )
		156	here ` push ; compile-only
		157	: next ( R: - C: a- )
		158	` pop ` 1- ` dup ` until ` drop ; compile-only
		159	: fori ( n- ) ` dup ` push ` for ` i ; compile-only
		160	: nexti ( - ) ` next ` pop ` drop ; compile-only
		161	}}
		162
		163
		164
		165	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		166	( Copy a block of memory from one location to another. )
		167	( Takes source, dest, and a count. )
		168	( Fill a memory range with a specific value. )
		169	( Takes an address, a value, and a count. )
		170	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		171	: copy ( aan- ) for push @+ pop !+ next 2drop ;
		172	: fill ( ann- ) swap here ! for here @ swap !+ next drop ;
		173
		174
		175	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		176	( stub creates an empty word that exists as a vector point )
		177	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		178	: stub ( "- ) ` : ` ; ;
		179
		180
		181	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		182	( Retro has some simple conditional forms, which tie the )
		183	( comparisons to the flow control. It's often useful to have )
		184	( separate functions for the comparisons, so I define them )
		185	( here. )
		186	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		187	: ahead ( -a ) 8 , here 0 , ;
		188	: if ( f- ) 0 literal, ` !if ; compile-only
		189	: if; ( f- ) ` not ` 0; ` drop ; compile-only
		190	: ;then ( a- ) ` ;; ` then ; compile-only
		191	: else ( a-a ) ahead swap ` then ; compile-only
		192
		193	: = ( xy-f ) =if -1 ;then 0 ;
		194	: <> ( xy-f ) !if -1 ;then 0 ;
		195	: > ( xy-f ) >if -1 ;then 0 ;
		196	: < ( xy-f ) <if -1 ;then 0 ;
		197
		198
		199	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		200	( pow = b^p )
		201	( r = fetch copy of top value on return stack )
		202	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		203	: pow ( bp-n ) over here ! 1- 0; for here @ * next ;
		204	: r ( -n ) ` pop ` dup ` push ; compile-only
		205	: rdrop ( - ) ` pop ` drop ; compile-only
		206
		207	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		208	( Useful for range checking )
		209	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		210	: within ( xlu-f ) push over pop < push > pop + -2 = ;
		211
		212	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		213	( This is a rather common word that can be used to easily )
		214	( display a string. )
		215	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		216	: ." ( "- )
		217	compiler @ if ` s" ` type ;then " type ; immediate
		218
		219
		220	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		221	( Numeric Bases )
		222	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		223	: decimal ( - ) 10 base ! ;
		224	: hex ( - ) 16 base ! ;
		225	: octal ( - ) 8 base ! ;
		226	: binary ( - ) 2 base ! ;
		227
		228
		229	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		230	( Search for a word by name )
		231	( It takes a string containing the name of the word to look )
		232	( for and returns an address and a flag. If true, the address )
		233	( is the dictionary header of the word being looked for. If )
		234	( false, just discard the address. )
		235	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		236	{{
		237	variable name
		238	variable found
		239	: prepare ( a-a ) found off name ! last @ ;
		240	: done ( -af ) which @ found @ ;
		241	: match? ( $-$f ) dup d->name name @ compare ;
		242	: search ( $- ) repeat match? if which ! found on ;then @ 0; again ;
		243	---reveal---
		244	: find ( "-af ) prepare search done ;
		245	}}
		246
		247
		248	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		249	( Find the dictionary header corresponding to a specific xt )
		250	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		251	{{
		252	: skim ( a-a ) last repeat @ 2dup d->xt @ =if nip ;then 0; again ;
		253	---reveal---
		254	: xt->d ( a-d \|\| a-0 ) dup skim 2dup =if - ;then nip ;
		255	}}
		256
		257
		258	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		259	( does> )
		260	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		261	: .does ( C: aa- R: aa-a )
		262	compiler @ if swap literal, compile rdrop ;then drop ;
		263	: does> ( -a )
		264	1 , here 0 , ` reclass ` ;; here swap ! here literal, ` .does ; compile-only
		265
		266
		267	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		268	( Display a space )
		269	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		270	: space ( - ) 32 emit ;
		271
		272
		273	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		274	( Add . to display a number with a trailing space )
		275	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		276	: . ( n- ) (.) space ;
		277
		278
		279	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		280	( A routine to evaluate a string of text as input )
		281	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		282	{{
		283	variable count
		284	variable buffer
		285	: restore ( - )
		286	['] emit :devector
		287	['] key :devector ok ;
		288	: get ( -c ) buffer @ @ ;
		289	: next ( -c )
		290	count @ 0 =if 32 restore ;then
		291	count -- get buffer ++ ;
		292	: replace ( - )
		293	['] drop ['] emit :is
		294	['] next ['] key :is ;
		295	---reveal---
		296	: eval ( an- ) count ! buffer ! replace ;
		297	}}
		298
		299
		300	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		301	( Conditionally execute code if a word exists )
		302	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		303	{{
		304	: defined ( "-f ) 32 accept tib find nip ;
		305	: evalTib ( - ) tib dup getLength eval ;
		306	: block ( "- ) key char: { =if char: { emit char: } accept else ." Invalid Syntax" cr then ;
		307	: evalBlock ( "- ) block evalTib ;
		308	: ifBlock ( f"- ) if evalBlock ;then block ;
		309	---reveal---
		310	: ifDefined ( "- ) defined ifBlock ;
		311	: ifNotDefined ( "- ) defined not ifBlock ;
		312	}}
		313
		314
		315	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		316	( Use this before drawing a large amount of text; it'll delay )
		317	( all video updates until the caller exits )
		318	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		319	{{
		320	: fast ( - ) ;
		321	---reveal---
		322	: fastRender ( - )
		323	['] fast ['] redraw :is later ['] redraw :devector redraw ;
		324	}}
		325
		326
		327	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		328	( Elements are equivalent to variables, but are contiguous. )
		329	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		330	{{
		331	: list ( n-a ) here swap zallot ;
		332	: setxt ( a- ) last @ d->xt ! ;
		333	: element ( a-a ) create dup setxt 1+ ;
		334	---reveal---
		335	: elements ( n"- ) dup list swap for element next drop ;
		336	}}
		337
		338
		339	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		340	( >last and expose -- move a dictionary header to the top of )
		341	( the dictionary. )
		342	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		343	{{
		344	: after ( a-a ) last repeat @ 2dup @ =if nip ;then again ;
		345	: remove ( a- ) dup @ swap after ! ;
		346	: replace ( a- ) last @ over ! last ! ;
		347	---reveal---
		348	: >last ( a- ) dup remove replace ;
		349	: expose ( "- ) d' >last ;
		350	}}

	d05441d54436f7e8789bdd0e06cb78d8e36f2040		235b9862054e9eae6b27742f5c736ba30e746ab3
		1	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		2	( A vocab word is a word that can be used to open and shut a )
		3	( vocabulary section from the dictionary. It consists of )
		4	( three fields which point to three dictionary headers: the )
		5	( word before the vocabulary starts, the first word to be )
		6	( hidden, and the first word not to be hidden. )
		7	( ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ )
		8	{{
		9	3 elements shown hidden before
		10	create nest 24 allot
		11	variable depth
		12	: tod ( -a ) last @ ;
		13	: current ( -a ) shown @ ;
		14	: .shown ( -a ) current d->xt @ ;
		15	: .hidden ( -a ) .shown 1+ ;
		16	: .before ( -a ) .shown 1+ 1+ ;
		17	: after ( a-a ) last repeat @ 2dup @ =if nip ;then again ;
		18	: remove ( a- ) current dup @ swap after ! ;
		19	: replace ( a- ) current tod over ! last ! ;
		20	: fields ( - ) shown .shown 3 copy ;
		21	: open ( a- ) @ shown ! .hidden @ .shown @ ! ;
		22	: shut ( a- ) @ shown ! .before @ .shown @ ! ;
		23	: :find ( a-af ) last repeat @ 2dup =if drop @ -1 ;then dup 0; drop again ;
		24	: open? ( a-af ) dup 1+ @ :find nip ;
		25	: toggle ( a- ) open? if shut ;then open ;
		26	: descend ( - ) shown depth @ 3 * nest + 3 copy depth ++ ;
		27	: ascend ( - ) depth -- depth @ 3 * nest + shown 3 copy ;
		28	---reveal---
		29	expose open expose shut
		30	: .vocab ( a- ) .data ` toggle ;
		31	: vocab ( "- ) create 3 allot ['] .vocab reclass ;
		32	: (( ( - ) descend tod shown ! tod @ before ! 0 hidden ! fields ;
		33	: )) ( - ) tod hidden ! fields remove replace ascend ;
		34	: >vocab ( aa- ) push last @ dup @ last ! dup r 1+ dup @ -rot ! swap ! pop open ;
		35	}}
		36
		37
		38	vocab retro
		39	((
		40	expose expose expose >last
		41	expose elements expose fastRender
		42	expose nexti expose fori
		43	expose ifDefined expose ifNotDefined
		44	expose eval expose space
		45	expose does> expose .does
		46	expose xt->d expose .
		47	expose find expose binary
		48	expose octal expose hex
		49	expose decimal expose ."
		50	expose within expose rdrop
		51	expose r expose pow
		52	expose < expose >
		53	expose <> expose =
		54	expose ahead
		55	expose else expose ;then
		56	expose if; expose if
		57	expose stub expose `
		58	expose fill expose copy
		59	expose zallot expose allot
		60	expose constant expose variable
		61	expose variable: expose }}
		62	expose ---reveal---
		63	expose {{ expose }
		64	expose { expose <list>
		65	expose -- expose ++
		66	expose char: expose immediate
		67	expose compile-only
		68	expose .compiler expose .primitive
		69	expose reclass: expose reclass
		70	expose d' expose forget
		71
		72	expose base expose whitespace
		73	expose which expose heap
		74	expose #mem expose fh
		75	expose fw expose fb
		76	expose update expose tib
		77	expose compiler expose last
		78	expose until
		79	expose ( expose next
		80	expose for expose [']
		81	expose pop expose push
		82	expose 0; expose again
		83	expose repeat expose then
		84	expose !if expose <if
		85	expose >if expose =if
		86	expose ;; expose ;
		87	expose [ expose s"
		88
		89	expose include expose time
		90	expose ekey expose key
		91	expose isNumber? expose listen
		92	expose ok expose >number
		93	expose save expose notfound
		94	expose reset expose depth
		95	expose boot expose d->name
		96	expose d->xt expose d->class
		97	expose .data expose .macro
		98	expose .word expose with-class
		99	expose remap-keys expose bye
		100	expose getLength expose keepString
		101	expose redraw expose tempString
		102	expose literal, expose compile
		103	expose devector expose is
		104	expose :devector expose :is
		105	expose -! expose +!
		106	expose !+ expose @+
		107	expose ' expose wait
		108	expose compare expose "
		109	expose (.) expose execute
		110	expose neg expose mod
		111	expose / expose off
		112	expose on expose 2dup
		113	expose tuck expose -rot
		114	expose rot expose not
		115	expose 2drop expose over
		116	expose clear expose type
		117	expose emit expose cr
		118	expose later expose :
		119	expose create expose ]
		120	expose , expose here
		121	expose accept expose out
		122	expose in expose dup
		123	expose nip expose >>
		124	expose << expose /mod
		125	expose * expose -
		126	expose + expose !
		127	expose @ expose xor
		128	expose or expose and
		129	expose drop expose swap
		130	expose 1- expose 1+
		131	))

	d05441d54436f7e8789bdd0e06cb78d8e36f2040		235b9862054e9eae6b27742f5c736ba30e746ab3
		1	include prefix.retro
		2	include editor.retro
		3	include files.retro
		4	include debug.retro
		5	include canvas.retro
		6	include sockets.retro
		7	save bye

	d05441d54436f7e8789bdd0e06cb78d8e36f2040		235b9862054e9eae6b27742f5c736ba30e746ab3
		1	vocab canvas
		2	((
		3	( Mouse Support )
		4	: mouse ( -xy ) 1 7 out wait ;
		5	: click? ( -f ) 2 7 out wait ;
		6
		7	( Canvas Support )
		8	: setColor ( c- ) 1 6 out wait ;
		9	: pixel ( xy- ) 2 6 out wait ;
		10	: box ( xyhw- ) 3 6 out wait ;
		11	: solidBox ( xyhw- ) 4 6 out wait ;
		12	: vline ( xyh- ) 5 6 out wait ;
		13	: hline ( xyw- ) 6 6 out wait ;
		14	: circle ( xyw- ) 7 6 out wait ;
		15	: solidCircle ( xyw- ) 8 6 out wait ;
		16
		17	( Colors )
		18	: black 0 setColor ;
		19	: blue 1 setColor ;
		20	: green 2 setColor ;
		21	: cyan 3 setColor ;
		22	: red 4 setColor ;
		23	: purple 5 setColor ;
		24	: brown 6 setColor ;
		25	: gray 7 setColor ;
		26	: darkgray 8 setColor ;
		27	: brightblue 9 setColor ;
		28	: brightgreen 10 setColor ;
		29	: brightcyan 11 setColor ;
		30	: brightred 12 setColor ;
		31	: magenta 13 setColor ;
		32	: yellow 14 setColor ;
		33	: white 15 setColor ;
		34	))
		35	' canvas shut

	d05441d54436f7e8789bdd0e06cb78d8e36f2040		235b9862054e9eae6b27742f5c736ba30e746ab3
		1	vocab files
		2	((
		3	0 constant :r 1 constant :r+ 2 constant :w
		4	3 constant :w+ 4 constant :a 5 constant :a+
		5
		6	{{
		7	: file.io ( n-f ) 4 out wait 4 in ;
		8	---reveal---
		9	: fopen ( $m-f ) -1 file.io ;
		10	: fread ( h-f ) -2 file.io ;
		11	: fwrite ( ch-f ) -3 file.io ;
		12	: fclose ( h -f ) -4 file.io ;
		13	: fpos ( h -n ) -5 file.io ;
		14	: fseek ( nh-f ) -6 file.io ;
		15	: fsize ( h-n ) -7 file.io ;
		16	}}
		17	))
		18
		19	' files shut

	d05441d54436f7e8789bdd0e06cb78d8e36f2040		235b9862054e9eae6b27742f5c736ba30e746ab3
		1	vocab net
		2	((
		3	: net.socket ( -s ) -1 8 out wait ;
		4	: net.bind ( sp-f ) -2 8 out wait ;
		5	: net.listen ( s-f ) -3 8 out wait ;
		6	: net.accept ( s-f ) -4 8 out wait ;
		7	: net.close ( s-f ) -5 8 out wait ;
		8	: net.send ( $s-f ) -6 8 out wait ;
		9	: net.recv ( s-c ) -7 8 out wait ;
		10	: net.connect ( $ps-f ) -8 8 out wait ;
		11	))
		12	' net shut

Retro Forth

Affected files

image/Makefile Download diff

image/source_core/build.retro Download diff

image/source_core/core.retro Download diff

image/source_core/meta.retro Download diff

image/source_core/stage2.retro Download diff

image/source_core/vocabs.retro Download diff

image/source_rest/build.retro Download diff

image/source_rest/canvas.retro Download diff

image/source_rest/debug.retro Download diff

image/source_rest/editor.retro Download diff

image/source_rest/files.retro Download diff

image/source_rest/prefix.retro Download diff

image/source_rest/sockets.retro Download diff