mirror of https://git.sr.ht/~rabbits/uxn
868 lines
25 KiB
Plaintext
868 lines
25 KiB
Plaintext
;tree { search-key 2 max-key-len 1 }
|
|
;assembler { pass 1 state 1 token 2 scope-len 1 scope 80 heap 2 addr 2 subtree 2 vartmp 2 field 2 }
|
|
|
|
%HCF { #0000 DIV }
|
|
%SHORT_FLAG { #20 }
|
|
%RETURN_FLAG { #40 }
|
|
|
|
( devices )
|
|
|
|
|0100 ;System { vector 2 pad 6 r 2 g 2 b 2 }
|
|
|0110 ;Console { vector 2 pad 6 char 1 byte 1 short 2 string 2 }
|
|
|0120 ;Screen { vector 2 width 2 height 2 pad 2 x 2 y 2 addr 2 color 1 }
|
|
|0130 ;Audio { wave 2 envelope 2 pad 4 volume 1 pitch 1 play 1 value 2 delay 2 finish 1 }
|
|
|0140 ;Controller { vector 2 button 1 key 1 }
|
|
|0160 ;Mouse { vector 2 x 2 y 2 state 1 chord 1 }
|
|
|0170 ;File { vector 2 pad 6 name 2 length 2 load 2 save 2 }
|
|
|01a0 ;DateTime { year 2 month 1 day 1 hour 1 minute 1 second 1 dotw 1 doty 2 isdst 1 refresh 1 }
|
|
|
|
( vectors )
|
|
|
|
|0200 ^RESET JMP
|
|
|
|
@RESET
|
|
,assembler-heap-start =assembler.heap
|
|
#0070 =assembler.addr
|
|
|
|
,$read-filename =File.name
|
|
#1000 =File.length
|
|
#f000 =File.load
|
|
|
|
#f000 #1000 ^assemble-chunk JSR
|
|
HCF
|
|
|
|
$read-filename [ etc/assembler-test.usm 00 ]
|
|
|
|
@assemble-chunk ( ptr* len* -- 00 if EOF found in chunk
|
|
OR assembled-up-to-ptr* 01 if reached end of chunk )
|
|
OVR2 ADD2 STH2
|
|
#0001 SUB2
|
|
|
|
$per-token
|
|
DUP2 STH2
|
|
|
|
$loop
|
|
#0001 ADD2
|
|
DUP2 PEK2
|
|
#20 GTH ^$loop JNZ
|
|
|
|
DUP2 OVR2r STH2r LTS2 ^$valid JNZ
|
|
SWP2r POP2r POP2
|
|
STH2r #0001 ADD2
|
|
#01 JMP2r
|
|
|
|
$valid
|
|
DUP2 PEK2 #00 OVR2 POK2
|
|
STH2r #0001 ADD2 ^assemble-token JSR
|
|
^$per-token JNZ
|
|
|
|
POP2 POP2r #00 JMP2r
|
|
|
|
@assemble-macro ( macro-ptr* -- )
|
|
DUP2 ,strlen JSR2 DUP2 #0000 EQU2 ^$end JNZ
|
|
OVR2 ^assemble-token JSR
|
|
ADD2 #0001 ADD2
|
|
^assemble-macro JMP
|
|
|
|
$end
|
|
POP2 POP2
|
|
JMP2r
|
|
|
|
@assemble-token ( string-ptr* -- )
|
|
( get location of tree )
|
|
DUP2
|
|
,state-machine-pointers #00 ~assembler.state ,highest-bit JSR2 #0004 MUL2 ADD2
|
|
DUP2 STH2
|
|
( see if first char is recognised )
|
|
SWP2 #01 ,traverse-tree JSR2
|
|
^$not-found JNZ
|
|
( skip first character of token )
|
|
SWP2 #0001 ADD2 =assembler.token
|
|
( tail call handling function defined in tree )
|
|
POP2r JMP2
|
|
|
|
$not-found
|
|
( not interested in incoming-ptr )
|
|
POP2
|
|
=assembler.token
|
|
( tail call default handling function defined in state-machine-pointers )
|
|
LIT2r [ 0002 ] ADD2r LDR2r
|
|
JMP2r
|
|
|
|
@parse-hex-length ( string-ptr* -- value 01 if one or two hex digits
|
|
OR 00 otherwise )
|
|
DUP2 #0001 ADD2 PEK2 ^parse-hex-string-try-two JNZ
|
|
PEK2 ^parse-hex-digit JSR DUP #04 SFT ^parse-hex-string-fail1 JNZ
|
|
#01 JMP2r
|
|
|
|
@parse-hex-string ( string-ptr* -- value* 02 if four hex digits
|
|
OR value 01 if two hex digits
|
|
OR 00 otherwise )
|
|
DUP2 #0004 ADD2 PEK2 #00 EQU ^$try-four JNZ
|
|
$try-two
|
|
DUP2 #0002 ADD2 PEK2 ^$fail2 JNZ
|
|
$known-two
|
|
DUP2 PEK2 ^parse-hex-digit JSR DUP #04 SFT ^$fail3 JNZ ROT ROT
|
|
#0001 ADD2 PEK2 ^parse-hex-digit JSR DUP #04 SFT ^$fail2 JNZ
|
|
SWP #40 SFT ORA #01 JMP2r
|
|
|
|
$fail3 POP
|
|
$fail2 POP
|
|
$fail1 POP #00 JMP2r
|
|
|
|
$try-four
|
|
DUP2 #0002 ADD2 ^$known-two JSR ^$maybe-four JNZ
|
|
^$try-two JMP
|
|
|
|
$maybe-four
|
|
ROT ROT ^$known-two JSR ^$four JNZ
|
|
^$fail1 JMP
|
|
|
|
$four
|
|
SWP #02 JMP2r
|
|
|
|
@parse-hex-digit ( charcode -- 00-0f if valid hex
|
|
-- 10-ff otherwise )
|
|
DUP #3a LTH ^$digit JNZ
|
|
DUP #60 GTH ^$lowercase JNZ
|
|
DUP #40 GTH ^$uppercase JNZ
|
|
JMP2r
|
|
|
|
$digit ( #30 is #00 )
|
|
#30 SUB JMP2r
|
|
|
|
$lowercase ( #61 is #0a )
|
|
#57 SUB JMP2r
|
|
|
|
$uppercase ( #41 is #0a )
|
|
#37 SUB JMP2r
|
|
|
|
@find-opcode ( name* -- byte 00 if valid opcode name
|
|
OR 01 if not found )
|
|
,opcodes-tree SWP2 #03 ^traverse-tree JSR
|
|
^$nomatch JNZ
|
|
,opcodes-asm SUB2 #0007 DIV2
|
|
SWP JMP2r
|
|
|
|
$nomatch
|
|
DUP2 EQU2 JMP2r
|
|
|
|
@traverse-tree ( tree-ptr* search-key* max-key-len --
|
|
binary-ptr* 00 if key matched
|
|
OR incoming-ptr* 01 if key not found )
|
|
=tree.max-key-len =tree.search-key
|
|
|
|
$loop
|
|
DUP2 LDR2 #0000 NEQ2 ^$valid-node JNZ
|
|
#01 JMP2r
|
|
|
|
$valid-node
|
|
LDR2 DUP2 STH2 #0004 ADD2 ^strcmp-tree JSR
|
|
DUP ^$nomatch JNZ
|
|
POP2r JMP2r
|
|
|
|
$nomatch
|
|
#07 SFT #02 MUL #00 SWP
|
|
STH2r ADD2
|
|
^$loop JMP
|
|
|
|
@strcmp-tree ( node-key* -- order if strings differ
|
|
OR after-node-key* 00 if strings match )
|
|
~tree.search-key STH2
|
|
~tree.max-key-len
|
|
|
|
$loop ( node-key* key-len in wst, search-key* in rst )
|
|
DUP ^$keep-going JNZ
|
|
|
|
( exhausted key-len, match found )
|
|
POP2r
|
|
JMP2r
|
|
|
|
$keep-going
|
|
#01 OVR2 PEK2 DUP2r PEK2r STHr
|
|
DUP2 ORA ^$not-end JNZ
|
|
|
|
( end of C strings, match found )
|
|
POP2r POP ROT POP SWP ADD2 #00
|
|
JMP2r
|
|
|
|
$not-end
|
|
SUB DUP ^$nomatch JNZ
|
|
POP SUB
|
|
LIT2r [ 0001 ] ADD2r STH
|
|
LIT2 [ 0001 ] ADD2 STHr
|
|
^$loop JMP
|
|
|
|
$nomatch
|
|
STH POP2 POP2 STHr POP2r
|
|
JMP2r
|
|
|
|
@highest-bit ( n -- 00 if n is 00
|
|
OR 01 if n is 01
|
|
OR 02 if n is 02..03
|
|
OR 03 if n is 04..07
|
|
OR 04 if n is 08..0f
|
|
..
|
|
OR 08 if n is 80..ff )
|
|
DUP #00 NEQ JMP JMP2r
|
|
DUP #01 SFT ORA
|
|
DUP #02 SFT ORA
|
|
DUP #04 SFT ORA
|
|
#1d MUL #05 SFT #00 SWP ,$lookup ADD2 PEK2
|
|
JMP2r
|
|
|
|
$lookup
|
|
[ 01 06 02 07 05 04 03 08 ]
|
|
|
|
@memcpy ( src-ptr* dest-ptr* length* -- after-dest-ptr* )
|
|
SWP2 STH2
|
|
|
|
$loop
|
|
DUP2 ORA ^$keep-going JNZ
|
|
POP2 POP2 STH2r
|
|
JMP2r
|
|
|
|
$keep-going
|
|
#0001 SUB2
|
|
SWP2 DUP2 PEK2 DUP2r STH2r POK2
|
|
#0001 ADD2 SWP2
|
|
LIT2r [ 0001 ] ADD2r
|
|
^$loop JMP
|
|
|
|
@strcpy ( src-ptr* dest-ptr* -- after-dest-ptr* )
|
|
OVR2 ^strlen JSR #0001 ADD2 ^memcpy JMP
|
|
|
|
@strlen ( string-ptr* -- length* )
|
|
DUP2 #0001 SUB2
|
|
$loop
|
|
#0001 ADD2
|
|
DUP2 PEK2 ^$loop JNZ
|
|
SWP2 SUB2
|
|
JMP2r
|
|
|
|
@append-heap ( string-ptr* -- after-string-ptr* )
|
|
~assembler.heap ,strcpy JSR2
|
|
DUP2 =assembler.heap
|
|
JMP2r
|
|
|
|
@append-tree ( string-ptr* incoming-ptr* -- binary-data* )
|
|
~assembler.heap SWP2 STR2
|
|
,$zero-pointers ~assembler.heap #0004 ^memcpy JSR =assembler.heap
|
|
^append-heap JSR
|
|
JMP2r
|
|
|
|
$zero-pointers [ 0000 0000 ]
|
|
|
|
@add-label ( label-flags string-ptr* tree-ptr* -- )
|
|
OVR2 #ff ,traverse-tree JSR2
|
|
^$new-label JNZ
|
|
|
|
( label already exists, check the flags and addr value )
|
|
SWP2 POP2
|
|
DUP2 #0001 ADD2 LDR2 ~assembler.addr EQU2 ^$addr-okay JNZ
|
|
( FIXME address is different to previous run, or label defined twice )
|
|
$addr-okay
|
|
PEK2 EQU ^$type-okay JNZ
|
|
( FIXME node type is different to before )
|
|
$type-okay
|
|
JMP2r
|
|
|
|
$new-label
|
|
^append-tree JSR
|
|
(
|
|
~assembler.heap SWP2 STR2
|
|
,$zero-pointers ~assembler.heap #0004 ^memcpy JSR =assembler.heap
|
|
~assembler.heap ,strcpy JSR2
|
|
)
|
|
DUP2 STH2 POK2 STH2r
|
|
DUP2 #0001 ADD2 ~assembler.addr SWP2 STR2
|
|
#0003 ADD2 =assembler.heap
|
|
JMP2r
|
|
|
|
@lookup-label ( string-ptr* -- address* node-type if found
|
|
OR false-address* 00 if not found )
|
|
DUP2
|
|
$loop
|
|
DUP2 #0001 ADD2 SWP2 PEK2
|
|
DUP #2e EQU ^$dotted JNZ
|
|
^$loop JNZ
|
|
DUP2 EOR2 ( faster than POP2 #0000 )
|
|
=assembler.field
|
|
|
|
$main
|
|
DUP2 ,label-tree SWP2 #ff ,traverse-tree JSR2
|
|
^$not-found JNZ
|
|
|
|
SWP2 POP2
|
|
~assembler.field #0000 EQU2 ^$end JNZ
|
|
DUP2 PEK2 #80 LTH ^$not-found JNZ
|
|
#0003 ADD2 ~assembler.field #ff ,traverse-tree JSR2
|
|
^$not-found JNZ
|
|
|
|
$end
|
|
DUP2 #0001 ADD2 LDR2 SWP2 PEK2
|
|
JMP2r
|
|
|
|
$not-found
|
|
POP2
|
|
( FIXME complain about missing label )
|
|
POP2
|
|
( false-address is out of reach for JMP )
|
|
~assembler.addr #8765 ADD2
|
|
#00
|
|
JMP2r
|
|
|
|
$dotted
|
|
DUP OVR2 =assembler.field
|
|
EOR ROT ROT #0001 SUB2 POK2
|
|
^$main JMP
|
|
|
|
@write-byte ( byte -- )
|
|
( FIXME ) =Console.byte
|
|
~assembler.addr #0001 ADD2 =assembler.addr
|
|
JMP2r
|
|
|
|
@write-short ( short -- )
|
|
( FIXME ) =Console.short
|
|
~assembler.addr #0002 ADD2 =assembler.addr
|
|
JMP2r
|
|
|
|
@label-tree .l-root
|
|
@macro-tree [ 0000 ]
|
|
|
|
@opcodes
|
|
(
|
|
The code for this section is automatically generated, and needs to be
|
|
regenerated when the opcode list in src/assembler.c is updated.
|
|
|
|
After editing src/assembler.c, run "lua etc/assembler-trees.lua"
|
|
and this file will be edited automatically.
|
|
|
|
This is the first example of a binary tree in this code, so let's
|
|
explore them in general. The format of a tree node in memory is:
|
|
|
|
left-node* right-node* node-key-cstring binary-data
|
|
|
|
and the general algorithm is to compare the key you're looking for
|
|
against node-key-cstring, and move to the node pointed to by left-node*
|
|
or right-node* if the keys don't match. If your key sorts earlier than
|
|
use left-node*, otherwise go to right-node*. When you find a node that
|
|
matches your key, traverse-bintree gives you a pointer to the
|
|
binary-data straight after the node-key-cstring. This data can contain
|
|
anything you want: fixed length fields, executable code... in this case
|
|
of this opcode tree, we store nothing. traverse-bintree is passed the
|
|
maximum length of node-key-cstring, not including the zero, so the zero
|
|
can be omitted if the string is at that maximum length.
|
|
|
|
If the key isn't present in the tree, you'll eventually get to a node
|
|
where the left-node* or right-node* pointer you'll need to follow is
|
|
null (0000). traverse-bintree will give you the location of that
|
|
pointer, so if you want to insert another node, you can write it to the
|
|
heap and overwrite the pointer with the new node's location. This
|
|
approach works even if the tree is completely empty and the pointer
|
|
you've provided to the root node is null, since that pointer gets
|
|
updated to point to the first node without needing any special logic.
|
|
|
|
The ordering of nodes in memory is totally arbitrary, so for pre-
|
|
prepared trees like this one we can have our own meaning for the order
|
|
of the nodes. By ordering the opcodes by their byte value, we can find
|
|
the byte by subtracting $asm from the binary-data pointer and dividing
|
|
by seven (the size of each node). By multiplying the byte value by seven
|
|
and adding to $disasm, we get the opcode name when disassembling too.
|
|
)
|
|
$tree .$op-lth ( opcode tree )
|
|
$start
|
|
$op-brk .$op-add .$op-dup $disasm [ BRK ] $asm
|
|
$op-nop .$op-mul .$op-ovr [ NOP ]
|
|
$op-lit [ 0000 ] [ 0000 ] [ LIT ]
|
|
$op-pop [ 0000 ] [ 0000 ] [ POP ]
|
|
$op-dup .$op-div .$op-eor [ DUP ]
|
|
$op-swp [ 0000 ] [ 0000 ] [ SWP ]
|
|
$op-ovr .$op-ora .$op-pek [ OVR ]
|
|
$op-rot .$op-pop .$op-sft [ ROT ]
|
|
$op-equ .$op-brk .$op-jnz [ EQU ]
|
|
$op-neq [ 0000 ] [ 0000 ] [ NEQ ]
|
|
$op-gth [ 0000 ] [ 0000 ] [ GTH ]
|
|
$op-lth .$op-equ .$op-pok [ LTH ]
|
|
$op-gts .$op-gth .$op-jmp [ GTS ]
|
|
$op-lts [ 0000 ] [ 0000 ] [ LTS ]
|
|
[ 0000 ] [ 0000 ] [ ??? ]
|
|
[ 0000 ] [ 0000 ] [ ??? ]
|
|
$op-pek [ 0000 ] [ 0000 ] [ PEK ]
|
|
$op-pok .$op-nop .$op-sth [ POK ]
|
|
$op-ldr .$op-jsr .$op-lit [ LDR ]
|
|
$op-str [ 0000 ] [ 0000 ] [ STR ]
|
|
$op-jmp [ 0000 ] [ 0000 ] [ JMP ]
|
|
$op-jnz .$op-gts .$op-ldr [ JNZ ]
|
|
$op-jsr [ 0000 ] [ 0000 ] [ JSR ]
|
|
$op-sth .$op-rot .$op-sub [ STH ]
|
|
$op-add [ 0000 ] .$op-and [ ADD ]
|
|
$op-sub .$op-str .$op-swp [ SUB ]
|
|
$op-mul .$op-lts .$op-neq [ MUL ]
|
|
$op-div [ 0000 ] [ 0000 ] [ DIV ]
|
|
$op-and [ 0000 ] [ 0000 ] [ AND ]
|
|
$op-ora [ 0000 ] [ 0000 ] [ ORA ]
|
|
$op-eor [ 0000 ] [ 0000 ] [ EOR ]
|
|
$op-sft [ 0000 ] [ 0000 ] [ SFT ]
|
|
|
|
@state-machine-pointers
|
|
( normal mode 00 )
|
|
.normal-root .normal-main
|
|
( macro definition 01 )
|
|
.macro-root .macro-main
|
|
( macro definition, contents ignored 02 )
|
|
.macro-root .ignore
|
|
( variable definition, expect field size 04 )
|
|
.variable-nul .variable-size
|
|
( variable definition, expect field name 08 )
|
|
.variable-root .variable-name
|
|
( reserved for future use 10 )
|
|
[ 0000 ] .ignore
|
|
( literal data 20 )
|
|
.normal-] .data-main
|
|
( reserved for future use 40 )
|
|
[ 0000 ] .ignore
|
|
( comment 80 )
|
|
.normal-) .ignore
|
|
|
|
(
|
|
Next up, we have the tree of code corresponding to each token's
|
|
first character. Here we do have a binary payload, which is
|
|
the code to run when the assembler considers the token.
|
|
|
|
Some special assembler modes have their own trees. Since comments
|
|
have a very simple tree that only understands the end of comments,
|
|
we reuse the terminal branch of the main tree as the root of
|
|
the comment tree.
|
|
)
|
|
|
|
(
|
|
Left and right parentheses start and end comment sections. They use the
|
|
highest bit in assembler state, so they receive highest priority: it
|
|
doesn't matter what other bits are set, a comment's a comment.
|
|
)
|
|
|
|
@normal-( [ 0000 ] .normal-) [ 28 ]
|
|
~assembler.state #80 ORA =assembler.state
|
|
JMP2r
|
|
|
|
@normal-) [ 0000 ] [ 0000 ] [ 29 ]
|
|
~assembler.state #7f AND =assembler.state
|
|
JMP2r
|
|
|
|
(
|
|
Ampersands introduce global labels, and define the scope for any
|
|
local labels that follow.
|
|
)
|
|
|
|
@normal-@ [ 0000 ] [ 0000 ] [ 40 ]
|
|
#00 ~assembler.token ,label-tree ,add-label JSR2
|
|
|
|
$scope
|
|
~assembler.token ,assembler.scope ,strcpy JSR2
|
|
DUP2 ,assembler.scope SUB2 =assembler.scope-len POP
|
|
#0001 SUB2 #2d SWP POK POP
|
|
JMP2r
|
|
|
|
(
|
|
Dollar signs introduce local labels, which use the scope defined above.
|
|
)
|
|
|
|
@normal-$ .normal-" .normal-, [ 24 ]
|
|
~assembler.token
|
|
,assembler.scope ~assembler.scope-len ADD
|
|
,strcpy JSR2 POP2
|
|
|
|
#00 ,assembler.scope ,label-tree ,add-label JMP2 ( tail call )
|
|
|
|
(
|
|
Hash signs followed by two or four hex digits write a literal.
|
|
)
|
|
|
|
@normal-# [ 0000 ] [ 0000 ] [ 23 ]
|
|
~assembler.token ,parse-hex-string JSR2
|
|
DUP ^$valid JNZ
|
|
( FIXME complain about invalid hex literal )
|
|
POP
|
|
JMP2r
|
|
|
|
$valid
|
|
DUP #01 SUB SHORT_FLAG MUL ( short flag for opcode )
|
|
,opcodes-op-lit ,opcodes-start SUB2 #07 DIV
|
|
ADD ADD ,write-byte JSR2
|
|
|
|
$value
|
|
#02 EQU ^$short JNZ
|
|
,write-byte JMP2 ( tail call )
|
|
|
|
$short
|
|
,write-short JMP2 ( tail call )
|
|
|
|
(
|
|
Left and right square brackets start and end literal data sections.
|
|
)
|
|
|
|
@normal-[ .normal-@ .normal-] [ 5b ]
|
|
~assembler.state #20 ORA =assembler.state
|
|
JMP2r
|
|
|
|
@normal-] [ 0000 ] [ 0000 ] [ 5d ]
|
|
( this is spurious, but ignore it anyway )
|
|
JMP2r
|
|
|
|
@data-] .normal-( [ 0000 ] [ 5d ]
|
|
~assembler.state #df AND =assembler.state
|
|
JMP2r
|
|
|
|
@data-root
|
|
@data-nul [ 0000 ] .data-] [ 00 ]
|
|
JMP2r
|
|
|
|
@data-main
|
|
~assembler.token ,parse-hex-string JSR2
|
|
DUP ^normal-#-value JNZ
|
|
POP
|
|
|
|
~assembler.token
|
|
$loop
|
|
DUP2 PEK2
|
|
DUP ^$keep-going JNZ
|
|
POP POP2 JMP2r
|
|
|
|
$keep-going
|
|
,write-byte JSR2
|
|
#0001 ADD2
|
|
^$loop JMP
|
|
|
|
(
|
|
A pipe moves the current address to the hex value given.
|
|
)
|
|
|
|
@normal-| .normal-{ .normal-} [ 7c ]
|
|
~assembler.token ,parse-hex-string JSR2
|
|
DUP #02 EQU ^$valid JNZ
|
|
#00 EQU JMP POP
|
|
( FIXME complain about invalid hex literal )
|
|
JMP2r
|
|
|
|
$valid
|
|
POP
|
|
DUP2 ~assembler.addr LTH2 ^$backwards JNZ
|
|
( FIXME add zeroes when writing )
|
|
=assembler.addr
|
|
JMP2r
|
|
|
|
$backwards
|
|
( FIXME complain about going backwards )
|
|
POP2
|
|
JMP2r
|
|
|
|
(
|
|
Commas and dots write the label address - the comma precedes this
|
|
with a LIT2 opcode.
|
|
)
|
|
|
|
@normal-, .normal-% .normal-dot [ 2c ]
|
|
,opcodes-op-lit ,opcodes-start SUB2 #07 DIV SHORT_FLAG ADD ,write-byte JSR2 POP
|
|
^normal-dot-main JMP
|
|
|
|
@normal-dot [ 0000 ] .normal-; [ 2e ]
|
|
$main
|
|
~assembler.token ,lookup-label JSR2
|
|
POP ( don't care about node type )
|
|
,write-short JMP2 ( tail call )
|
|
|
|
(
|
|
Caret writes LIT, followed by the label address as an offset.
|
|
)
|
|
|
|
@normal-^ .normal-[ .normal-| [ 5e ]
|
|
,opcodes-op-lit ,opcodes-start SUB2 #07 DIV ,write-byte JSR2 POP
|
|
~assembler.token ,lookup-label JSR2
|
|
POP ( don't care about node type )
|
|
~assembler.addr SUB2
|
|
DUP2 #ff79 GTH2 ^$okay JNZ
|
|
DUP2 #0080 LTH2 ^$okay JNZ
|
|
|
|
( FIXME complain about jump being too far )
|
|
|
|
$okay
|
|
,write-byte JSR2 POP
|
|
JMP2r
|
|
|
|
(
|
|
Tilde and equals are the load and store helpers respectively.
|
|
If the target is in the zero page, use LDR/PEK or STR/POK opcodes,
|
|
otherwise use LDR2/PEK2 or STR2/POK2 opcodes.
|
|
)
|
|
@normal-~ [ 0000 ] [ 0000 ] [ 7e ]
|
|
LIT2r .opcodes-op-ldr LIT2r .opcodes-op-pek
|
|
^normal-=-main JMP
|
|
|
|
@normal-root
|
|
@normal-= .normal-$ .normal-^ [ 3d ]
|
|
LIT2r .opcodes-op-str LIT2r .opcodes-op-pok
|
|
$main
|
|
~assembler.token ,lookup-label JSR2
|
|
DUP #03 AND ^$valid JNZ
|
|
|
|
( FIXME complain about helper not being usable )
|
|
POP2 JMP2r
|
|
|
|
$valid
|
|
#02 AND ^$two-byte JNZ
|
|
SWP2r
|
|
$two-byte
|
|
POP2r
|
|
LIT2r .opcodes-start SUB2r LITr [ 07 ] DIVr
|
|
OVR #00 EQU ^$byte-mode JNZ
|
|
|
|
,write-short SHORT_FLAG ^$end JMP
|
|
|
|
$byte-mode
|
|
SWP POP
|
|
,write-byte #00
|
|
|
|
$end
|
|
,opcodes-op-lit ,opcodes-start SUB2 #07 DIV ADD ADD ,write-byte JSR2
|
|
JSR2
|
|
STHr ,write-byte JSR2
|
|
POPr
|
|
JMP2r
|
|
|
|
(
|
|
Semicolons introduce variables. The variable name is added to the label
|
|
tree as usual, but all of the subfields are collected into their own tree
|
|
pointed to in the variable name's binary data.
|
|
)
|
|
@normal-; [ 0000 ] [ 0000 ] [ 3b ]
|
|
#80 ~assembler.token ,label-tree ,add-label JSR2
|
|
~assembler.heap #0000 OVR2 STR2
|
|
DUP2 =assembler.subtree
|
|
#0002 ADD2 =assembler.heap
|
|
|
|
~assembler.state #0c ORA =assembler.state
|
|
JMP2r
|
|
|
|
@variable-root
|
|
@variable-{ .variable-nul .variable-} [ 7b ]
|
|
JMP2r
|
|
|
|
@variable-nul [ 0000 ] .normal-( [ 00 ]
|
|
JMP2r
|
|
|
|
@variable-} [ 0000 ] [ 0000 ] [ 7d ]
|
|
~assembler.state #f3 AND =assembler.state
|
|
JMP2r
|
|
|
|
@variable-name
|
|
#00 ~assembler.token ~assembler.subtree ,add-label JSR2
|
|
~assembler.heap #0003 SUB2 =assembler.vartmp
|
|
~assembler.state #f7 AND =assembler.state
|
|
JMP2r
|
|
|
|
@variable-size
|
|
~assembler.token ,parse-hex-length JSR2
|
|
^$valid JNZ
|
|
( FIXME complain about invalid size )
|
|
JMP2r
|
|
|
|
$valid
|
|
DUP #02 GTH ^$end JNZ
|
|
DUP ~assembler.vartmp POK2
|
|
^$end JMP
|
|
|
|
$loop
|
|
#00 ,write-byte JSR2
|
|
#01 SUB
|
|
$end
|
|
DUP ^$loop JNZ
|
|
POP
|
|
~assembler.state #0c ORA =assembler.state
|
|
JMP2r
|
|
|
|
(
|
|
Percent signs introduce macros. The macro name is added to the macro tree,
|
|
and all the arguments are collected into a list that follows the label's
|
|
binary data.
|
|
)
|
|
@normal-% [ 0000 ] .normal-( [ 25 ]
|
|
,macro-tree ~assembler.token #ff ,traverse-tree JSR2
|
|
^$new-macro JNZ
|
|
|
|
( macro already exists, we assume defined in a previous pass
|
|
we totally ignore the contents )
|
|
POP2
|
|
~assembler.state #02 ORA =assembler.state
|
|
JMP2r
|
|
|
|
$new-macro
|
|
~assembler.token SWP2 ,append-tree JSR2
|
|
POP2
|
|
~assembler.state #01 ORA =assembler.state
|
|
JMP2r
|
|
|
|
@macro-root
|
|
@macro-{ .macro-nul .macro-} [ 7b ]
|
|
JMP2r
|
|
|
|
@macro-} [ 0000 ] [ 0000 ] [ 7d ]
|
|
~assembler.heap DUP2 #00 ROT ROT POK2
|
|
#0001 ADD2 =assembler.heap
|
|
~assembler.state #fc AND =assembler.state
|
|
JMP2r
|
|
|
|
@macro-nul [ 0000 ] .normal-( [ 00 ]
|
|
JMP2r
|
|
|
|
@macro-main
|
|
~assembler.token ,append-heap JSR2
|
|
POP2
|
|
JMP2r
|
|
|
|
|
|
@normal-" .normal-nul .normal-# [ 22 ]
|
|
( FIXME NYI )
|
|
JMP2r
|
|
|
|
@normal-{ [ 0000 ] [ 0000 ] [ 7b ]
|
|
( these are spurious, but ignore them anyway )
|
|
JMP2r
|
|
|
|
@normal-} [ 0000 ] .normal-~ [ 7d ]
|
|
( these are spurious, but ignore them anyway )
|
|
JMP2r
|
|
|
|
@normal-nul [ 0000 ] [ 0000 ] [ 00 ]
|
|
@ignore
|
|
JMP2r
|
|
|
|
@normal-main
|
|
~assembler.token
|
|
,opcodes-tree OVR2 #03 ,traverse-tree JSR2
|
|
^$not-opcode JNZ
|
|
|
|
,opcodes-asm SUB2 #0007 DIV2
|
|
SWP2 #0003 ADD2
|
|
$flags
|
|
DUP2 PEK2
|
|
DUP #00 EQU ^$end-flags JNZ
|
|
DUP #32 NEQ ^$not-two JNZ
|
|
POP SWP2 SHORT_FLAG ORA SWP2 #0001 ADD2 ^$flags JMP
|
|
$not-two
|
|
DUP #72 NEQ ^$not-r JNZ
|
|
POP SWP2 RETURN_FLAG ORA SWP2 #0001 ADD2 ^$flags JMP
|
|
$not-r
|
|
POP POP2 ~assembler.token SWP2
|
|
^$not-opcode JMP
|
|
|
|
$end-flags
|
|
POP POP2
|
|
,write-byte JSR2
|
|
POP
|
|
JMP2r
|
|
|
|
$not-opcode
|
|
POP2
|
|
,macro-tree SWP2 #ff ,traverse-tree JSR2
|
|
^$not-macro JNZ
|
|
,assemble-macro JMP2 ( tail call )
|
|
|
|
$not-macro
|
|
( FIXME complain about bad opcode / nonexistent macro )
|
|
POP2
|
|
JMP2r
|
|
|
|
(
|
|
Here's the big set of trees relating to labels. Starting from l-root, all
|
|
the devices are stored here, perhaps some helper functions in the future,
|
|
too.
|
|
|
|
left-node* right-node* node-key-cstring binary-data
|
|
|
|
The node-keys are terminated with NUL since, unlike the opcodes and first
|
|
characters, the keys are variable length.
|
|
|
|
The binary-data is either three or five bytes long:
|
|
flags value* [ subtree-pointer* ]
|
|
|
|
The flags byte is divided up into bits:
|
|
|
|
bit 0-1: 00 means store / load helpers cannot be used,
|
|
01 means the helpers use POK / PEK,
|
|
02 means the helpers use STR / LDR,
|
|
03 is invalid;
|
|
bits 2-6 are reserved; and
|
|
bit 7: 80 means there is a subtree.
|
|
|
|
If there is a subtree, it is searched when the reference contains a dot.
|
|
)
|
|
|
|
@l-Audio [ 0000 ] [ 0000 ] [ Audio 00 ] [ 80 ] .Audio .l-Audio-root
|
|
@l-Audio-delay [ 0000 ] [ 0000 ] [ delay 00 ] [ 02 ] .Audio.delay
|
|
@l-Audio-envelope .l-Audio-delay .l-Audio-finish [ envelope 00 ] [ 02 ] .Audio.envelope
|
|
@l-Audio-finish [ 0000 ] [ 0000 ] [ finish 00 ] [ 01 ] .Audio.finish
|
|
@l-Audio-root
|
|
@l-Audio-pitch .l-Audio-envelope .l-Audio-value [ pitch 00 ] [ 01 ] .Audio.pitch
|
|
@l-Audio-play [ 0000 ] [ 0000 ] [ play 00 ] [ 01 ] .Audio.play
|
|
@l-Audio-value .l-Audio-play .l-Audio-volume [ value 00 ] [ 02 ] .Audio.value
|
|
@l-Audio-volume [ 0000 ] .l-Audio-wave [ volume 00 ] [ 01 ] .Audio.volume
|
|
@l-Audio-wave [ 0000 ] [ 0000 ] [ wave 00 ] [ 02 ] .Audio.wave
|
|
@l-Console .l-Audio .l-Controller [ Console 00 ] [ 80 ] .Console .l-Console-root
|
|
@l-Console-byte [ 0000 ] .l-Console-char [ byte 00 ] [ 01 ] .Console.byte
|
|
@l-Console-char [ 0000 ] [ 0000 ] [ char 00 ] [ 01 ] .Console.char
|
|
@l-Console-root
|
|
@l-Console-short .l-Console-byte .l-Console-string [ short 00 ] [ 02 ] .Console.short
|
|
@l-Console-string [ 0000 ] .l-Console-vector [ string 00 ] [ 02 ] .Console.string
|
|
@l-Console-vector [ 0000 ] [ 0000 ] [ vector 00 ] [ 02 ] .Console.vector
|
|
@l-Controller [ 0000 ] [ 0000 ] [ Controller 00 ] [ 80 ] .Controller .l-Controller-root
|
|
@l-Controller-button [ 0000 ] [ 0000 ] [ button 00 ] [ 01 ] .Controller.button
|
|
@l-Controller-root
|
|
@l-Controller-key .l-Controller-button .l-Controller-vector [ key 00 ] [ 01 ] .Controller.key
|
|
@l-Controller-vector [ 0000 ] [ 0000 ] [ vector 00 ] [ 02 ] .Controller.vector
|
|
@l-root
|
|
@l-DateTime .l-Console .l-Mouse [ DateTime 00 ] [ 80 ] .DateTime .l-DateTime-root
|
|
@l-DateTime-day [ 0000 ] [ 0000 ] [ day 00 ] [ 01 ] .DateTime.day
|
|
@l-DateTime-dotw .l-DateTime-day .l-DateTime-doty [ dotw 00 ] [ 01 ] .DateTime.dotw
|
|
@l-DateTime-doty [ 0000 ] .l-DateTime-hour [ doty 00 ] [ 02 ] .DateTime.doty
|
|
@l-DateTime-hour [ 0000 ] [ 0000 ] [ hour 00 ] [ 01 ] .DateTime.hour
|
|
@l-DateTime-root
|
|
@l-DateTime-isdst .l-DateTime-dotw .l-DateTime-refresh [ isdst 00 ] [ 01 ] .DateTime.isdst
|
|
@l-DateTime-minute [ 0000 ] .l-DateTime-month [ minute 00 ] [ 01 ] .DateTime.minute
|
|
@l-DateTime-month [ 0000 ] [ 0000 ] [ month 00 ] [ 01 ] .DateTime.month
|
|
@l-DateTime-refresh .l-DateTime-minute .l-DateTime-second [ refresh 00 ] [ 01 ] .DateTime.refresh
|
|
@l-DateTime-second [ 0000 ] .l-DateTime-year [ second 00 ] [ 01 ] .DateTime.second
|
|
@l-DateTime-year [ 0000 ] [ 0000 ] [ year 00 ] [ 02 ] .DateTime.year
|
|
@l-File [ 0000 ] [ 0000 ] [ File 00 ] [ 80 ] .File .l-File-root
|
|
@l-File-length [ 0000 ] .l-File-load [ length 00 ] [ 02 ] .File.length
|
|
@l-File-load [ 0000 ] [ 0000 ] [ load 00 ] [ 02 ] .File.load
|
|
@l-File-root
|
|
@l-File-name .l-File-length .l-File-save [ name 00 ] [ 02 ] .File.name
|
|
@l-File-save [ 0000 ] .l-File-vector [ save 00 ] [ 02 ] .File.save
|
|
@l-File-vector [ 0000 ] [ 0000 ] [ vector 00 ] [ 02 ] .File.vector
|
|
@l-Mouse .l-File .l-Screen [ Mouse 00 ] [ 80 ] .Mouse .l-Mouse-root
|
|
@l-Mouse-chord [ 0000 ] .l-Mouse-state [ chord 00 ] [ 01 ] .Mouse.chord
|
|
@l-Mouse-state [ 0000 ] [ 0000 ] [ state 00 ] [ 01 ] .Mouse.state
|
|
@l-Mouse-root
|
|
@l-Mouse-vector .l-Mouse-chord .l-Mouse-x [ vector 00 ] [ 02 ] .Mouse.vector
|
|
@l-Mouse-x [ 0000 ] .l-Mouse-y [ x 00 ] [ 02 ] .Mouse.x
|
|
@l-Mouse-y [ 0000 ] [ 0000 ] [ y 00 ] [ 02 ] .Mouse.y
|
|
@l-Screen [ 0000 ] .l-System [ Screen 00 ] [ 80 ] .Screen .l-Screen-root
|
|
@l-Screen-addr [ 0000 ] [ 0000 ] [ addr 00 ] [ 02 ] .Screen.addr
|
|
@l-Screen-color .l-Screen-addr .l-Screen-height [ color 00 ] [ 01 ] .Screen.color
|
|
@l-Screen-height [ 0000 ] [ 0000 ] [ height 00 ] [ 02 ] .Screen.height
|
|
@l-Screen-root
|
|
@l-Screen-vector .l-Screen-color .l-Screen-x [ vector 00 ] [ 02 ] .Screen.vector
|
|
@l-Screen-width [ 0000 ] [ 0000 ] [ width 00 ] [ 02 ] .Screen.width
|
|
@l-Screen-x .l-Screen-width .l-Screen-y [ x 00 ] [ 02 ] .Screen.x
|
|
@l-Screen-y [ 0000 ] [ 0000 ] [ y 00 ] [ 02 ] .Screen.y
|
|
@l-System [ 0000 ] [ 0000 ] [ System 00 ] [ 80 ] .System .l-System-root
|
|
@l-System-b [ 0000 ] [ 0000 ] [ b 00 ] [ 02 ] .System.b
|
|
@l-System-root
|
|
@l-System-g .l-System-b .l-System-r [ g 00 ] [ 02 ] .System.g
|
|
@l-System-r [ 0000 ] .l-System-vector [ r 00 ] [ 02 ] .System.r
|
|
@l-System-vector [ 0000 ] [ 0000 ] [ vector 00 ] [ 02 ] .System.vector
|
|
|
|
@assembler-heap-start
|
|
|