~rabbits/drifblim

3654ef2f0c4143df2962e463395509f153f2b474 — Devine Lu Linvega a month ago 0f7c1d9 
Added drifloon
patch browse .tar.gz 
1 files changed, 429 insertions(+), 0 deletions(-)

A src/drifloon.tal

A src/drifloon.tal => src/drifloon.tal +429 -0
@@ 0,0 1,429 @@
( uxncli drifloon.rom )

|10 @Console &vector $2 &read $1 &pad $5 &write $1 &err $1

|0100

	;on-console .Console/vector DEO2

BRK

@on-console ( -> )

	.Console/read DEI
	DUP [ LIT2 &buffer =source ] STA
	;&buffer LDA2k INC2 SWP2 STA2
	#0a NEQ ?&end
		assemble
		print-summary
		&end

BRK

@on-error ( id* name* -> )

	#0a19 DEO
	( print ) ;err pstr pstr #2019 DEO pstr ;dict/in pstr ;scope pstr ;dict/dot pstr
	( halt ) #010f DEO

BRK

(
@|generics )

@handle-source ( -- )

	;source
	&w
		LDAk handle-char
		INC2 LDAk ?&w
	POP2
JMP2r

@handle-char ( c -- )

	#20 GTHk NIP ?&append POP
	;token LDAk ?&run POP2

JMP2r
	&append ( c -- ) ;token DUP2 slen #001f LTH2 ?sput POP JMP2r
	&run ( t* -- ) DUP2 handle-token !sclr

@handle-token ( t* -- )

	LDAk LIT "( EQU ?&on-parens
	LDAk LIT ") EQU ?&on-parens
	[ LIT &sleep $1 ] ?&on-sleep

!parse
	&on-parens ( t* -- ) LDA LIT "( EQU ,&sleep STR JMP2r
	&on-sleep ( t* -- ) POP2 JMP2r

(
@|core )

@assemble ( -- )

	( pass1 )
	#0100 set-head
	;dict/reset ;scope scpy
	handle-source
	( pass2 )
	#0100 set-head
	;dict/reset ;scope scpy
	#00 ;write/skip STA
	handle-source

JMP2r

@parse ( t* -- )

	LDAk ,&rune STR
	( runes )
	;runes/err ;runes
	&l
		LDAk [ LIT &rune $1 ] NEQ ?&no-runic
			NIP2 INC2 LDA2 JMP2
			&no-runic
		#0003 ADD2 GTH2k ?&l
	POP2 POP2
	( non-runic )
	DUP2 is-hex ?lib/rawhex
	DUP2 is-opcode ?lib/opcode
	lib/litjsi

JMP2r

@lib
	&padabs INC2 get-hex write-pad !set-head
	&padrel INC2 get-hex !write-fill
	&toplab INC2 ;scope OVR2 SWP2 scpy !create-label
	&sublab INC2 make-sublabel !create-label
	&litrel #80 write
	&rawrel INC2 get-ref get-rel INC !write
	&litzep #80 write
	&rawzep INC2 get-ref LDA2 NIP !write
	&litabs #a0 write
	&rawabs INC2 get-ref LDA2 !write-short
	&litjci #20 write INC2 !write-call
	&litjmi #40 write INC2 !write-call
	&litjsi #60 write !write-call
	&lithex INC2 DUP2 slen NIP #02 SFT #a080 ROT [ JMP SWP POP ] write
	&rawhex !write-hex
	&rawstr INC2 !write-str
	&opcode find-opcode !write
	&ignore POP2 JMP2r

(
@|primitives )

@write-pad ( addr* -- dest* )

	;write/head LDA2
	LTH2k ?&no-pad
		SUB2k write-fill POP2 JMP2r
		&no-pad
	OVR2 #0100 LTH2 ?&no-err
		;token ;err/rewind !on-error
		&no-err
	POP2

JMP2r

@write-fill ( len* -- )

	#0000 EQU2k ?&skip
	&l
		#00 write
		INC2 GTH2k ?&l
	&skip
	POP2 POP2

JMP2r

@write-str ( str* -- )

	&w
		LDAk write
		INC2 LDAk ?&w
	POP2

JMP2r

@write-call ( str* -- )

	get-ref LDA2 ;write/head LDA2 INC2 INC2 SUB2

!write-short

@write-hex ( str* -- )

	DUP2 slen OVR2 get-hex SWP2 NIP
	DUP #02 EQU ?&byte
	DUP #04 EQU ?&short
	POP POP2
	;err/number !on-error
	&byte POP NIP2 NIP !write
	&short POP NIP2 ( fall through )

@write-short ( short* -- )

	SWP write

@write ( byte -- )

	,&b STR
	[ LIT2 &head 0100 ] #0100 LTH2 ?&ignore
	[ LIT &skip 01 ] ?&pass1
	[ LIT2 &length $2 ] ,&head LDR2 LTH2 ?&ignore
	( pass2 ) ,&b LDR #18 DEO
	&ignore

!move-head

&pass1 ( -- )

	[ LIT &b $1 ] #00 EQU ?&no-record
		,&head LDR2 ;write/length STA2
		&no-record

!move-head

(
@|helpers )

@get-hex ( str* -- value* )

	DUP2 is-hex ?&valid
		;err/number !on-error
		&valid

!shex

@get-rel ( label* -- distance )

	;write/skip LDA ?&fill
	LDA2k ;write/head LDA2 SUB2 #0003 SUB2
	DUP2 #0080 ADD2 POP ?&fail
	NIP2 NIP

JMP2r
	&fail POP2 #0003 ADD2 ;err/distance !on-error
	&fill POP2 #ff JMP2r

@get-ref ( token* -- <label*> )

	;write/skip LDA #00 EQU ?&no-write
		POP2 ;&fill JMP2r
		&no-write
	LDAk LIT "& NEQ ?&no-sub
		INC2 make-sublabel
		&no-sub
	find-label
		INC2k ORA ?&found
			POP2 ;err/reference !on-error
			&found
	( count )
	INC2k INC2 LDAk INC ROT ROT STA

JMP2r
	&fill ffff "[empty] $1

@create-label ( name* -- )

	;write/skip LDA #00 EQU ?&skip
	( not hex ) DUP2 is-hex ?&invalid
	( not opc ) DUP2 is-opcode ?&invalid
	( not dup ) DUP2 find-label INC2 ORA ?&not-unique
	( save addr ) ;write/head LDA2 [ LIT2 &ptr =symbols ] STH2k STA2
	( move ) INC2r INC2r INC2r
	( save name ) DUP2 STH2kr scpy
	( move ) slen STH2r ADD2 INC2 ,&ptr STR2
	( stats ) [ LIT2 &count $2 ] INC2 ,&count STR2

JMP2r
	&invalid ;err/invalid !on-error
	&not-unique ;err/duplicate !on-error
	&skip POP2 JMP2r

@make-sublabel ( name* -- sublabel* )

	;scope ;sublabel STH2k scpy
	LIT "/ STH2kr sput
	STH2kr scat
	STH2r

JMP2r

@is-hex ( str* -- f )

	&w
		LDAk chex INC ?&valid
			POP2 #00 JMP2r &valid
		INC2 LDAk ?&w
	POP2
	#01

JMP2r

@is-opcode ( string* -- f )

	DUP2 ;opcodes/brk scmp3 ?find-opcode/on-brk

@find-opcode ( name* -- byte )

	STH2
	#2000
	&l
		#00 OVR #03 MUL ;opcodes ADD2 STH2kr scmp3 ?&on-found
		INC GTHk ?&l
	POP2 POP2r #00

JMP2r
	&on-found
		NIP ( LITk ) DUP #00 EQU #70 SFT ADD
		STH2r #0003 ADD2 find-modes ADD JMP2r
	&on-brk POP2 #01 JMP2r

@find-modes ( mode* -- byte )

	LITr 00
	&w
		LDAk #20
		OVR LIT "2 EQU ?&end DUP ADD
		OVR LIT "r EQU ?&end DUP ADD
		OVR LIT "k EQU ?&end DUP ADD
		OVR #21 LTH ?&end
			;token ;err/mode !on-error
		&end NIP STH ORAr
		INC2 LDAk ?&w
	POP2 STHr

JMP2r

@find-label ( name* -- <addr*> )

	STH2
	;symbols
	&w
		#0003 ADD2 DUP2 STH2kr scmp ?&found
		scap INC2 INC2k INC2 INC2 LDA ?&w
	POP2
	POP2r
	#ffff

JMP2r
	&found #0003 SUB2 POP2r JMP2r

@move-head ( -- )

	;write/head LDA2 INC2

@set-head ( v* -- )

	;write/head STA2

JMP2r

@print-summary ( -- )

	;symbols
	&w
		( ignore uppercased device labels )
		INC2k INC2 INC2 LDA DUP #40 GTH SWP #5b LTH AND ?&used
		INC2k INC2 LDA ?&used
			;dict/unused pstr
			#0003 ADD2 DUP2 pstr #0a19 DEO
			&used
		scap INC2 INC2k INC2 INC2 LDA ?&w
	POP2
	( result )
	;dict/assembled pstr ;write/length LDA2 #00ff SUB2 pdec ;dict/bytes pstr
	;create-label/count LDA2 pdec ;dict/labels pstr
	;dict/end pstr

JMP2r

(
@|stdlib )

@pstr ( str* -- ) LDAk ?&w POP2 JMP2r &w LDAk #19 DEO INC2 LDAk ?&w POP2 JMP2r
@scap ( str* -- end* ) LDAk ?&w JMP2r &w INC2 LDAk ?&w JMP2r
@sput ( chr str* -- ) scap INC2k #00 ROT ROT STA STA JMP2r
@slen ( str* -- len* ) DUP2 scap SWP2 SUB2 JMP2r
@scat ( src* dst* -- ) scap
@scpy ( src* dst* -- ) OVR2 LDA ?&e POP2 POP2 JMP2r &e STH2 &w LDAk STH2kr STA INC2r INC2 LDAk ?&w POP2 #00 STH2r STA JMP2r
@sclr ( str* -- ) LDAk ?&w POP2 JMP2r &w STH2k #00 STH2r STA INC2 LDAk ?&w POP2 JMP2r
@skey ( key buf -- proc ) OVR #21 LTH ?&eval #00 SWP sput #00 JMP2r &eval POP2 #01 JMP2r
@scmp ( a* b* -- f ) STH2 &l LDAk LDAkr STHr ANDk #00 EQU ?&e NEQk ?&e POP2 INC2 INC2r !&l &e NIP2 POP2r EQU JMP2r
@scmp3 ( a* b* -- f ) LDA2k ROT2 LDA2k ROT2 EQU2 STH INC2 LDA2 SWP2 INC2 LDA2 EQU2 STHr AND JMP2r
@chex ( c -- val|ff ) LIT "0 SUB DUP #09 GTH [ JMP JMP2r ] #27 SUB DUP #0f GTH [ JMP JMP2r ] POP #ff JMP2r
@shex ( str* -- val* ) LIT2r 0000 &w LITr 40 SFT2r LITr 00 LDAk chex STH ADD2r INC2 LDAk ?&w POP2 STH2r JMP2r

@pdec ( short* -- )

	#00 ,&z STR
	#2710 pdec/parse
	#03e8 pdec/parse
	#0064 pdec/parse
	#000a pdec/parse
	NIP #30 ADD #19 DEO

JMP2r

&parse ( short* den* -- short* )

	DIV2k DUPk [ LIT &z $1 ] EQU ?&skip
	DUP #30 ADD #19 DEO #ff ,&z STR
	&skip POP MUL2 SUB2

JMP2r

(
@|assets )

@dict
	&assembled "Assembled 20 $1
	&reset "INIT $1
	&bytes 20 "bytes( $1
	&in ", 20 "in 20 $1
	&end ") &dot ". 0a $1
	&labels 20 "labels $1
	&unused "-- 20 "Unused 20 "label: 20 $1

@err "!! 20 "Error: 20 $1
	&duplicate "Duplicate  $1
	&number "Number $1
	&reference "Reference $1
	&distance "Distance $1
	&invalid "Invalid $1
	&mode "Mode $1
	&rewind "Rewind $1

@opcodes
	"LIT "INC "POP "NIP "SWP "ROT "DUP "OVR
	"EQU "NEQ "GTH "LTH "JMP "JCN "JSR "STH
	"LDZ "STZ "LDR "STR "LDA "STA "DEI "DEO
	"ADD "SUB "MUL "DIV "AND "ORA "EOR "SFT
	&brk "BRK

@runes
	"| =lib/padabs "$ =lib/padrel
	"@ =lib/toplab "& =lib/sublab
	", =lib/litrel "_ =lib/rawrel
	". =lib/litzep "- =lib/rawzep
	"; =lib/litabs "= =lib/rawabs
	"? =lib/litjci "! =lib/litjmi
	"[ =lib/ignore "] =lib/ignore
	"# =lib/lithex "" =lib/rawstr
	&err

(
@|memory )

@token $20
@scope $20
@sublabel $20
@source $4000
@symbols ( addr*, refs, name[], 00 )