~rabbits/drifblim

afbcb96818a4da51686d9db258f4dea51eca7aa5 — Devine Lu Linvega 2 months ago 0313cd9 
Ported to JMI, JCI and JSI
patch browse .tar.gz 
3 files changed, 555 insertions(+), 126 deletions(-)

M build.sh
A etc/drifblim-deferred.tal
M src/drifblim.tal

M build.sh => build.sh +1 -2
@@ 7,8 7,7 @@ mkdir bin
if [ -e "$HOME/roms/uxnlin.rom" ]
then
	echo "Linting.."
	# uxncli $HOME/roms/uxnlin.rom src/drifblim.tal
	# uxncli $HOME/roms/uxnlin.rom etc/bh.tal
	uxncli $HOME/roms/uxnlin.rom src/drifblim.tal
fi

uxnasm src/drifblim.tal bin/drifblim-seed.rom


A etc/drifblim-deferred.tal => etc/drifblim-deferred.tal +432 -0
@@ 0,0 1,432 @@
( uxncli drifblim.rom source.tal application.rom )

|10 @Console &vector $2 &read $1 &pad $5 &write $1 &err $1
|a0 @File1 &vector $2 &success $2 &stat $2 &delete $1 &append $1 &name $2 &length $2 &read $2 &write $2

|0000

	@src $30
	@dst $30
	@inc $30
	@program &head $2 &length $2 &write $1

|0100 ( -> )

	( interactive )
	;await-src .Console/vector DEO2
	;dict/input ;pstr JSR2

BRK

@await-src ( -> ) .Console/read DEI .src ;skey JSR2 ,ready-dst JCN BRK
@ready-dst ( -> ) ;await-dst .Console/vector DEO2 ;dict/output ;pstr JSR2 BRK
@await-dst ( -> ) .Console/read DEI .dst ;skey JSR2 ,on-ready JCN BRK

@on-ready ( -> )

	#0a18 DEO
	( pass1 )
	;dict/reset ;scope ;scpy JSR2
	;src ;handle-file JSR2
	( pass2 )
	;dict/reset ;scope ;scpy JSR2
	#01 .program/write STZ
	;src ;handle-file JSR2
	( export )
	;dst .File1/name DEO2
	.program/length LDZ2 #00ff SUB2 .File1/length DEO2
	;rom/start .File1/write DEO2
	;summary JSR2
	( debug ) #010e DEO
	( halt ) #010f DEO

BRK

(
@|generics )

@handle-file ( f* -- )

	.File1/name DEO2
	#0001 .File1/length DEO2
	&s
		;&c .File1/read DEO2
		.File1/success DEI2 #0000 NEQ2 ,&continue JCN JMP2r
		&continue [ LIT &c $1 ] ,handle-char JSR
		,&s JMP

JMP2r

@handle-char ( c -- )

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

JMP2r
	&append ( c -- ) ;token DUP2 ;slen JSR2 #001f LTH2 ;sput JCN2 POP JMP2r
	&run ( t* -- ) DUP2 ,handle-token JSR ;sclr JMP2

@handle-token ( t* -- )

	LDAk LIT "( EQU ,&on-parens JCN
	LDAk LIT ") EQU ,&on-parens JCN
	[ LIT &sleep $1 ] ,&on-sleep JCN
	;parse JSR2

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

(
@|library )

@parse ( t* -- )

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

JMP2r

@library
&do-padabs INC2 ;get-hex JSR2 ;set-head JMP2
&do-padrel INC2 ;get-hex JSR2 ;move-head JMP2
&do-toplab INC2 ;scope OVR2 SWP2 ;scpy JSR2 ;create-label JMP2
&do-sublab INC2 ;make-sublabel JSR2 ;create-label JMP2
&do-litrel #80 ;write JSR2 
&do-rawrel INC2 ;get-ref JSR2 ;get-rel JSR2 INC ;write JMP2
&do-litzep #80 ;write JSR2
&do-rawzep INC2 ;get-ref JSR2 LDA2 NIP ;write JMP2
&do-litabs #a0 ;write JSR2 
&do-rawabs INC2 ;get-ref JSR2 LDA2 ;write-short JMP2
&do-litjmi #20 ;write JSR2 INC2 ;get-ref JSR2 LDA2 ;write-short JMP2
&do-litjci #40 ;write JSR2 INC2 ;get-ref JSR2 LDA2 ;write-short JMP2
&do-litjsi #60 ;write JSR2 ;get-ref JSR2 LDA2 ;write-short JMP2
&do-lithex INC2 DUP2 ;slen JSR2 NIP #02 SFT #a080 ROT [ JMP SWP POP ] ;write JSR2
&do-rawhex ;write-hex JMP2
&do-rawstr INC2 ;write-str JMP2
&do-opcode ;find-opcode JSR2 ;write JMP2
&do-inc INC2k ;inc STH2k ;scpy JSR2 ;sclr JSR2 STH2r ;handle-file JMP2
&do-ignore POP2 JMP2r

(
@|primitives )

@write-str ( str* -- )

	&w
		LDAk ;write JSR2
		INC2 LDAk ,&w JCN
	POP2

JMP2r

@write-hex ( str* -- )

	DUP2 ;slen JSR2 OVR2 ;get-hex JSR2 SWP2 NIP
	DUP #02 EQU ,&byte JCN
	DUP #04 EQU ,&short JCN
	POP POP2
	&err ;err/number ;crash ( .. )

JMP2
	&byte POP NIP2 NIP ;write JMP2
	&short POP NIP2 ;write-short JMP2

@write-short ( short* -- )

	SWP ,write JSR

@write ( byte -- )

	.program/write LDZ #00 EQU ,&no-write JCN
		DUP ;rom .program/head LDZ2 ADD2 STA
		DUP #00 EQU ,&no-write JCN
			.program/head LDZ2 .program/length STZ2
		&no-write
	POP
	( move )
	#0001 ;move-head ( .. )

JMP2

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

	DUP2 ;is-hex JSR2 ,&valid JCN
		;err/number ;crash JMP2
		&valid
	;shex ( .. )

JMP2

@get-rel ( label* -- distance )

	.program/write LDZ #00 EQU ,&fill JCN
	LDA2k .program/head LDZ2 SUB2 #0003 SUB2
	DUP2 #0080 ADD2 POP ,&fail JCN
	NIP2 NIP

JMP2r
	&fail POP2 #0003 ADD2 ;err/distance ;crash JMP2
	&fill POP2 #00 JMP2r

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

	.program/write LDZ ,&no-write JCN
		POP2 ;&fill JMP2r
		&no-write
	LDAk LIT "& NEQ ,&no-sub JCN
		INC2 ;make-sublabel JSR2
		&no-sub
	;find-label JSR2
		INC2k ORA ,&found JCN
			POP2 ;err/reference ;crash JMP2
			&found
	( count )
	INC2k INC2 LDAk INC ROT ROT STA

JMP2r
	&fill 0000 "[empty] $1

@create-label ( name* -- )

	.program/write LDZ ,&skip JCN
	( check duplicate ) DUP2 ;find-label JSR2 INC2 ORA ,&not-unique JCN
	( save addr ) .program/head LDZ2 [ LIT2 &ptr =symbols ] STH2k STA2
	( move ) INC2r INC2r INC2r
	( save name ) DUP2 STH2kr ;scpy JSR2
	( move ) ;slen JSR2 STH2r ADD2 INC2 ,&ptr STR2
	( stats ) [ LIT2 &count $2 ] INC2 ,&count STR2

JMP2r
	&not-unique ;err/duplicate ;crash JMP2
	&skip POP2 JMP2r

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

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

JMP2r

@is-hex ( str* -- f )

	&w
		LDAk ;chex JSR2 INC ,&valid JCN
			POP2 #00 JMP2r &valid
		INC2 LDAk ,&w JCN
	POP2
	#01

JMP2r

@is-opcode ( string* -- f )

	DUP2 ;opcodes/brk ;scmp3 JSR2 ,find-opcode/on-brk JCN

@find-opcode ( name* -- byte )

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

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

@find-modes ( mode* -- byte )

	LITr 00
	&w
		LDAk #20
		OVR LIT "2 EQU ,&end JCN DUP ADD
		OVR LIT "r EQU ,&end JCN DUP ADD
		OVR LIT "k EQU ,&end JCN DUP ADD
		OVR #21 LTH ,&end JCN
			;token ;err/mode ;crash JMP2
		&end NIP STH ORAr
		INC2 LDAk ,&w JCN
	POP2 STHr

JMP2r

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

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

JMP2r
	&found #0003 SUB2 POP2r JMP2r

@move-head ( v* -- )

	.program/head LDZ2 ADD2

@set-head ( v* -- )

	.program/head STZ2

JMP2r

@crash ( id* name* -- )

	;err ;pstr JSR2 ;pstr JSR2
	LIT ": #18 DEO #2018 DEO
	;pstr JSR2 ;dict/in ;pstr JSR2
	;scope ;pstr JSR2 LIT ". #18 DEO #0a18 DEO
	#010f DEO

BRK

@summary ( -- )

	;symbols
	&w
		( ignore uppercased device labels )
		INC2k INC2 INC2 LDA DUP #40 GTH SWP #5b LTH AND ,&used JCN
		INC2k INC2 LDA ,&used JCN
			;dict/unused ;pstr JSR2
			#0003 ADD2 DUP2 ;pstr JSR2 #0a18 DEO
			&used
		;scap JSR2 INC2 INC2k INC2 INC2 LDA ,&w JCN
	POP2
	( result )
	;dict/assembled ;pstr JSR2
	;src ;pstr JSR2
	;dict/spacer ;pstr JSR2
	;dst ;pstr JSR2
	( length )
	;dict/in ;pstr JSR2
	.program/length LDZ2 #0100 SUB2 ;pdec JSR2
	;dict/bytes ;pstr JSR2
	LIT "( #18 DEO
	;create-label/count LDA2 ;pdec JSR2
	;dict/labels ;pstr JSR2
	LIT ") #18 DEO
	LIT ". #18 DEO #0a18 DEO

JMP2r

@save-symbols ( -- )

	;dst ;scap JSR2 ;&ext OVR2 ;scpy JSR2
	;dst .File1/name DEO2
	;symbols
	&l
		#0002 .File1/length DEO2
		DUP2 .File1/write DEO2
		#0003 ADD2
			DUP2 ;slen JSR2 INC2 .File1/length DEO2
			DUP2 .File1/write DEO2
		;scap JSR2 INC2 DUP2 #0003 ADD2 LDA ,&l JCN
	POP2
	#00 ROT ROT STA

JMP2r
	&ext ".sym $1

(
@|stdlib )

@pstr ( str* -- ) LDAk ,&w JCN POP2 JMP2r &w LDAk #18 DEO INC2 LDAk ,&w JCN POP2 JMP2r
@scap ( str* -- end* ) LDAk ,&w JCN JMP2r &w INC2 LDAk ,&w JCN JMP2r
@sput ( chr str* -- ) ,scap JSR INC2k #00 ROT ROT STA STA JMP2r
@slen ( str* -- len* ) DUP2 ,scap JSR SWP2 SUB2 JMP2r
@scat ( src* dst* -- ) ,scap JSR
@scpy ( src* dst* -- ) OVR2 LDA ,&e JCN POP2 POP2 JMP2r &e STH2 &w LDAk STH2kr STA INC2r INC2 LDAk ,&w JCN POP2 #00 STH2r STA JMP2r
@sclr ( str* -- ) LDAk ,&w JCN POP2 JMP2r &w STH2k #00 STH2r STA INC2 LDAk ,&w JCN POP2 JMP2r
@skey ( key buf -- proc ) OVR #21 LTH ,&eval JCN #00 SWP ;sput JSR2 #00 JMP2r &eval POP2 #01 JMP2r
@scmp ( a* b* -- f ) STH2 &l LDAk LDAkr STHr ANDk #00 EQU ,&e JCN NEQk ,&e JCN POP2 INC2 INC2r ,&l JMP &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 JSR STH ADD2r INC2 LDAk ,&w JCN POP2 STH2r JMP2r

@pdec ( short* -- )

	#00 ,&z STR
	#2710 ,&parse JSR
	#03e8 ,&parse JSR
	#0064 ,&parse JSR
	#000a ,&parse JSR
	NIP #30 ADD #18 DEO

JMP2r
	&parse
		DIV2k DUPk [ LIT &z $1 ] EQU ,&skip JCN
		DUP #30 ADD #18 DEO #ff ,&z STR
		&skip POP MUL2 SUB2
	JMP2r

(
@|assets )

@dict
	&input "Input(.tal): 20 $1
	&output "Output(.rom): 20 $1
	&assembled "Assembled 20 $1
	&reset "[reset] $1
	&spacer 20 "-> 20 $1
	&in ", 20 "in 20 $1
	&bytes 20 "bytes $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
	&mode "Mode $1
	&distance "Distance $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
	"| =library/do-padabs "$ =library/do-padrel
	"@ =library/do-toplab "& =library/do-sublab
	", =library/do-litrel "_ =library/do-rawrel
	". =library/do-litzep "- =library/do-rawzep
	"; =library/do-litabs "= =library/do-rawabs
	"! =library/do-litjmi "? =library/do-litjci
	"[ =library/do-ignore "] =library/do-ignore
	"# =library/do-lithex "" =library/do-rawstr
	"~ =library/do-inc
	&err

(
@|memory )

@token $20
@scope $20
@sublabel $20
@symbols $2000 ( addr*, refs, name[], 00 )
@rom $100 &start



M src/drifblim.tal => src/drifblim.tal +122 -124
@@ 14,29 14,29 @@

	( interactive )
	;await-src .Console/vector DEO2
	;dict/input ;pstr JSR2
	;dict/input pstr

BRK

@await-src ( -> ) .Console/read DEI .src ;skey JSR2 ,ready-dst JCN BRK
@ready-dst ( -> ) ;await-dst .Console/vector DEO2 ;dict/output ;pstr JSR2 BRK
@await-dst ( -> ) .Console/read DEI .dst ;skey JSR2 ,on-ready JCN BRK
@await-src ( -> ) .Console/read DEI .src skey ?ready-dst BRK
@ready-dst ( -> ) ;await-dst .Console/vector DEO2 ;dict/output pstr BRK
@await-dst ( -> ) .Console/read DEI .dst skey ?on-ready BRK

@on-ready ( -> )

	#0a18 DEO
	( pass1 )
	;dict/reset ;scope ;scpy JSR2
	;src ;handle-file JSR2
	;dict/reset ;scope scpy
	;src handle-file
	( pass2 )
	;dict/reset ;scope ;scpy JSR2
	;dict/reset ;scope scpy
	#01 .program/write STZ
	;src ;handle-file JSR2
	;src handle-file
	( export )
	;dst .File1/name DEO2
	.program/length LDZ2 #00ff SUB2 .File1/length DEO2
	;rom/start .File1/write DEO2
	;summary JSR2
	print-summary
	( debug ) #010e DEO
	( halt ) #010f DEO



@@ 51,27 51,27 @@ BRK
	#0001 .File1/length DEO2
	&s
		;&c .File1/read DEO2
		.File1/success DEI2 #0000 NEQ2 ,&continue JCN JMP2r
		&continue [ LIT &c $1 ] ,handle-char JSR
		.File1/success DEI2 ORA ?&continue JMP2r
		&continue [ LIT &c $1 ] handle-char
		,&s JMP

JMP2r

@handle-char ( c -- )

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

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

@handle-token ( t* -- )

	LDAk LIT "( EQU ,&on-parens JCN
	LDAk LIT ") EQU ,&on-parens JCN
	[ LIT &sleep $1 ] ,&on-sleep JCN
	;parse JSR2
	LDAk LIT "( EQU ?&on-parens
	LDAk LIT ") EQU ?&on-parens
	[ LIT &sleep $1 ] ?&on-sleep
	parse

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


@@ 86,38 86,38 @@ JMP2r
	( runes )
	;runes/err ;runes
	&l
		LDAk [ LIT &rune $1 ] NEQ ,&no-runic JCN
		LDAk [ LIT &rune $1 ] NEQ ?&no-runic
			NIP2 INC2 LDA2 JMP2
			&no-runic
		#0003 ADD2 GTH2k ,&l JCN
		#0003 ADD2 GTH2k ?&l
	POP2 POP2
	( non-runic )
	DUP2 ;is-hex JSR2 ;library/do-rawhex JCN2
	DUP2 ;is-opcode JSR2 ;library/do-opcode JCN2
	DUP2 is-hex ?library/do-rawhex
	DUP2 is-opcode ?library/do-opcode
	( jsi )
	;library/do-litjsi JSR2
	library/do-litjsi

JMP2r

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

(


@@ 126,72 126,70 @@ JMP2r
@write-str ( str* -- )

	&w
		LDAk ;write JSR2
		INC2 LDAk ,&w JCN
		LDAk write
		INC2 LDAk ?&w
	POP2

JMP2r

@write-hex ( str* -- )

	DUP2 ;slen JSR2 OVR2 ;get-hex JSR2 SWP2 NIP
	DUP #02 EQU ,&byte JCN
	DUP #04 EQU ,&short JCN
	DUP2 slen OVR2 get-hex SWP2 NIP
	DUP #02 EQU ?&byte
	DUP #04 EQU ?&short
	POP POP2
	&err ;err/number ;crash ( .. )

JMP2
	&byte POP NIP2 NIP ;write JMP2
	&short POP NIP2 ;write-short JMP2
	&err ;err/number !crash
	&byte POP NIP2 NIP !write
	&short POP NIP2 !write-short

@write-short ( short* -- )

	SWP ,write JSR
	SWP write

@write ( byte -- )

	.program/write LDZ #00 EQU ,&no-write JCN
	.program/write LDZ #00 EQU ?&no-write
		DUP ;rom .program/head LDZ2 ADD2 STA
		DUP #00 EQU ,&no-write JCN
		DUP #00 EQU ?&no-write
			.program/head LDZ2 .program/length STZ2
		&no-write
	POP
	( move )
	#0001 ;move-head ( .. )
	#0001 !move-head

JMP2
( .. )

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

	DUP2 ;is-hex JSR2 ,&valid JCN
		;err/number ;crash JMP2
	DUP2 is-hex ?&valid
		;err/number !crash
		&valid
	;shex ( .. )
	!shex

JMP2
( .. )

@get-rel ( label* -- distance )

	.program/write LDZ #00 EQU ,&fill JCN
	.program/write LDZ #00 EQU ?&fill
	LDA2k .program/head LDZ2 SUB2 #0003 SUB2
	DUP2 #0080 ADD2 POP ,&fail JCN
	DUP2 #0080 ADD2 POP ?&fail
	NIP2 NIP

JMP2r
	&fail POP2 #0003 ADD2 ;err/distance ;crash JMP2
	&fail POP2 #0003 ADD2 ;err/distance !crash
	&fill POP2 #00 JMP2r

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

	.program/write LDZ ,&no-write JCN
	.program/write LDZ ?&no-write
		POP2 ;&fill JMP2r
		&no-write
	LDAk LIT "& NEQ ,&no-sub JCN
		INC2 ;make-sublabel JSR2
	LDAk LIT "& NEQ ?&no-sub
		INC2 make-sublabel
		&no-sub
	;find-label JSR2
		INC2k ORA ,&found JCN
			POP2 ;err/reference ;crash JMP2
	find-label
		INC2k ORA ?&found
			POP2 ;err/reference !crash
			&found
	( count )
	INC2k INC2 LDAk INC ROT ROT STA


@@ 201,23 199,23 @@ JMP2r

@create-label ( name* -- )

	.program/write LDZ ,&skip JCN
	( check duplicate ) DUP2 ;find-label JSR2 INC2 ORA ,&not-unique JCN
	.program/write LDZ ?&skip
	( check duplicate ) DUP2 find-label INC2 ORA ?&not-unique
	( save addr ) .program/head LDZ2 [ LIT2 &ptr =symbols ] STH2k STA2
	( move ) INC2r INC2r INC2r
	( save name ) DUP2 STH2kr ;scpy JSR2
	( move ) ;slen JSR2 STH2r ADD2 INC2 ,&ptr STR2
	( save name ) DUP2 STH2kr scpy
	( move ) slen STH2r ADD2 INC2 ,&ptr STR2
	( stats ) [ LIT2 &count $2 ] INC2 ,&count STR2

JMP2r
	&not-unique ;err/duplicate ;crash JMP2
	&not-unique ;err/duplicate !crash
	&skip POP2 JMP2r

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

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

JMP2r


@@ 225,9 223,9 @@ JMP2r
@is-hex ( str* -- f )

	&w
		LDAk ;chex JSR2 INC ,&valid JCN
		LDAk chex INC ?&valid
			POP2 #00 JMP2r &valid
		INC2 LDAk ,&w JCN
		INC2 LDAk ?&w
	POP2
	#01



@@ 235,21 233,21 @@ JMP2r

@is-opcode ( string* -- f )

	DUP2 ;opcodes/brk ;scmp3 JSR2 ,find-opcode/on-brk JCN
	DUP2 ;opcodes/brk scmp3 ?find-opcode/on-brk

@find-opcode ( name* -- byte )

	STH2
	#2000
	&l
		#00 OVR #03 MUL ;opcodes ADD2 STH2kr ;scmp3 JSR2 ,&on-found JCN
		INC GTHk ,&l JCN
		#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 JSR ADD JMP2r
		STH2r #0003 ADD2 find-modes ADD JMP2r
	&on-brk POP2 #01 JMP2r

@find-modes ( mode* -- byte )


@@ 257,13 255,13 @@ JMP2r
	LITr 00
	&w
		LDAk #20
		OVR LIT "2 EQU ,&end JCN DUP ADD
		OVR LIT "r EQU ,&end JCN DUP ADD
		OVR LIT "k EQU ,&end JCN DUP ADD
		OVR #21 LTH ,&end JCN
			;token ;err/mode ;crash JMP2
		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 !crash
		&end NIP STH ORAr
		INC2 LDAk ,&w JCN
		INC2 LDAk ?&w
	POP2 STHr

JMP2r


@@ 273,8 271,8 @@ JMP2r
	STH2
	;symbols
	&w
		#0003 ADD2 DUP2 STH2kr ;scmp JSR2 ,&found JCN
		;scap JSR2 INC2 INC2k INC2 INC2 LDA ,&w JCN
		#0003 ADD2 DUP2 STH2kr scmp ?&found
		scap INC2 INC2k INC2 INC2 LDA ?&w
	POP2
	POP2r
	#ffff


@@ 294,38 292,38 @@ JMP2r

@crash ( id* name* -- )

	;err ;pstr JSR2 ;pstr JSR2
	;err pstr pstr
	LIT ": #18 DEO #2018 DEO
	;pstr JSR2 ;dict/in ;pstr JSR2
	;scope ;pstr JSR2 LIT ". #18 DEO #0a18 DEO
	pstr ;dict/in pstr
	;scope pstr LIT ". #18 DEO #0a18 DEO
	#010f DEO

BRK

@summary ( -- )
@print-summary ( -- )

	;symbols
	&w
		( ignore uppercased device labels )
		INC2k INC2 INC2 LDA DUP #40 GTH SWP #5b LTH AND ,&used JCN
		INC2k INC2 LDA ,&used JCN
			;dict/unused ;pstr JSR2
			#0003 ADD2 DUP2 ;pstr JSR2 #0a18 DEO
		INC2k INC2 INC2 LDA DUP #40 GTH SWP #5b LTH AND ?&used
		INC2k INC2 LDA ?&used
			;dict/unused pstr
			#0003 ADD2 DUP2 pstr #0a18 DEO
			&used
		;scap JSR2 INC2 INC2k INC2 INC2 LDA ,&w JCN
		scap INC2 INC2k INC2 INC2 LDA ?&w
	POP2
	( result )
	;dict/assembled ;pstr JSR2
	;src ;pstr JSR2
	;dict/spacer ;pstr JSR2
	;dst ;pstr JSR2
	;dict/assembled pstr
	;src pstr
	;dict/spacer pstr
	;dst pstr
	( length )
	;dict/in ;pstr JSR2
	.program/length LDZ2 #0100 SUB2 ;pdec JSR2
	;dict/bytes ;pstr JSR2
	;dict/in pstr
	.program/length LDZ2 #0100 SUB2 pdec
	;dict/bytes pstr
	LIT "( #18 DEO
	;create-label/count LDA2 ;pdec JSR2
	;dict/labels ;pstr JSR2
	;create-label/count LDA2 pdec
	;dict/labels pstr
	LIT ") #18 DEO
	LIT ". #18 DEO #0a18 DEO



@@ 333,16 331,16 @@ JMP2r

@save-symbols ( -- )

	;dst ;scap JSR2 ;&ext OVR2 ;scpy JSR2
	;dst scap ;&ext OVR2 scpy
	;dst .File1/name DEO2
	;symbols
	&l
		#0002 .File1/length DEO2
		DUP2 .File1/write DEO2
		#0003 ADD2
			DUP2 ;slen JSR2 INC2 .File1/length DEO2
			DUP2 slen INC2 .File1/length DEO2
			DUP2 .File1/write DEO2
		;scap JSR2 INC2 DUP2 #0003 ADD2 LDA ,&l JCN
		scap INC2 DUP2 #0003 ADD2 LDA ?&l
	POP2
	#00 ROT ROT STA



@@ 352,18 350,18 @@ JMP2r
(
@|stdlib )

@pstr ( str* -- ) LDAk ,&w JCN POP2 JMP2r &w LDAk #18 DEO INC2 LDAk ,&w JCN POP2 JMP2r
@scap ( str* -- end* ) LDAk ,&w JCN JMP2r &w INC2 LDAk ,&w JCN JMP2r
@sput ( chr str* -- ) ,scap JSR INC2k #00 ROT ROT STA STA JMP2r
@slen ( str* -- len* ) DUP2 ,scap JSR SWP2 SUB2 JMP2r
@scat ( src* dst* -- ) ,scap JSR
@scpy ( src* dst* -- ) OVR2 LDA ,&e JCN POP2 POP2 JMP2r &e STH2 &w LDAk STH2kr STA INC2r INC2 LDAk ,&w JCN POP2 #00 STH2r STA JMP2r
@sclr ( str* -- ) LDAk ,&w JCN POP2 JMP2r &w STH2k #00 STH2r STA INC2 LDAk ,&w JCN POP2 JMP2r
@skey ( key buf -- proc ) OVR #21 LTH ,&eval JCN #00 SWP ;sput JSR2 #00 JMP2r &eval POP2 #01 JMP2r
@scmp ( a* b* -- f ) STH2 &l LDAk LDAkr STHr ANDk #00 EQU ,&e JCN NEQk ,&e JCN POP2 INC2 INC2r ,&l JMP &e NIP2 POP2r EQU JMP2r
@pstr ( str* -- ) LDAk ?&w POP2 JMP2r &w LDAk #18 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 JMP &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 JSR STH ADD2r INC2 LDAk ,&w JCN POP2 STH2r JMP2r
@shex ( str* -- val* ) LIT2r 0000 &w LITr 40 SFT2r LITr 00 LDAk chex STH ADD2r INC2 LDAk ?&w POP2 STH2r JMP2r

@pdec ( short* -- )



@@ 376,7 374,7 @@ JMP2r

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