d6
/
nxu
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Compare commits

base: d6:main
Branches Tags
d6:main
d6:@
..
compare: d6:@
Branches Tags
d6:main
d6:@

1 Commits
main ... @

Author SHA1 Message Date
erik 0b18bf4539 Update deck demo for screen changes. 2023-09-13 13:07:06 -04:00
30 changed files with 2681 additions and 4545 deletions
Show Stats Expand all files Collapse all files

20
.gitignore vendored
View File

@ -1,20 +0,0 @@
# use glob syntax.
syntax: glob
*.pyc
*.pyo
*~
TAGS
*.rom
img
etc
test-roms
junk
img
.theme
.snarf
*.sym
wave
*.mp3
*.wav
*.mp4
scratch

2
arg.tal
View File

@ -61,7 +61,7 @@
( internal: store character c in the buffer and update position ) ( internal: store character c in the buffer and update position )
&save ( c^ -> ) &save ( c^ -> )
LIT2r =arg/pos LDA2kr STH2r ( c^ addr* [pos*] ) LIT2r :arg/pos LDA2kr STH2r ( c^ addr* [pos*] )
STA LDA2kr INC2r SWP2r ( [addr1* pos*] ; addr<-c ) STA LDA2kr INC2r SWP2r ( [addr1* pos*] ; addr<-c )
STA2r JMP2r ( ; pos<-addr+1 ) STA2r JMP2r ( ; pos<-addr+1 )

100
audio-v2.md
View File

@ -1,100 +0,0 @@
# UXN Audio Proposal (v2)
*(Updated with input from bd and neauoire)*
## Problems
Currently the UXN audio device doesn't work very well for playing
complex music. There are a few reasons for this:
* Note duration is conflated with envelope shape
* Envelope resolution (67ms) limits tempos/subdivisions
* Using audio callback requires scheduling pauses/silence
## Proposal outline
One way to improve the situation is to disentangle the envelope
specification from the note duration, and more generally make it
easier to specify things that a composer will frequently need to
change (pitch, articulation, duration) without having to change the
underlying voice (waveform/envelope settings).
This proposal makes four changes:
1. Add a two-byte `duration` port that configures a note's duration
in milliseconds. The longest possible note is about 66 seconds.
2. Double the size of the `adsr` port. This means replacing the
existing two-byte port with four one-byte ports for `attack`,
`decay`, `sustain`, and `release`. Since we have 4 extra bits per
stage, we will reduce the resolution of each stage from 66ms to
10ms (so 0x01 means 10ms). The longest envelope stage is now about
2.6s (up from 1s previously). We special-case `sustain` and
instead treat its value as a fraction `x/255` (i.e. 0.0 to 1.0).
3. Move various ports around, both to improve the layout and prepare
for future additions. In particular an `expansion` port for
possible MIDI operations and a `detune` port for microtonal music
are likely (but are left unspecified by this proposal).
4. Recommends that emulators use a separate `wst` and `rst` for
evaluating the audio vector (when possible). Code run from the
audio vector should not expect to read existing values from `wst`
or `rst` (and should not leave values behind). This allows
emulators to use a separate audio thread for evaluating callbacks
without needing to pause other execution.
## Note duration and tempo
The `duration` and `vector` ports precisely specify the audio device
behavior. The given note should be played for a number of milliseconds
specified by `duration`, at which point the `vector` should be called
to play the next note (or next silence). For example if the duration
is `0x04b0` then the note should play for 1.2 seconds (1200 ms).
## More flexible envelope settings
The ADSR ports determine how loud the pitch should be at any given
moment. The ADR ports (`attack`, `decay`, and `release`) are all
specified in 10ms increments (e.g. `0x03` is 30ms). The S port for
`sustain` behaves differently: it specifies what how much of the
"leftover" duration to use before the release as a fraction `x/255`.
So with a value of `0xff` the note would hold as long as possible, and
with `0x00` the release would occur just after the decay ends.
(If the duration is short parts of the envelope may be truncated.)
Since each component has its own port, it's also much easier to adjust
one without having to fiddle with bit masks, shifting, etc.
## Appendix A: proposed specification:
ADDR SIZE NAME DESCRIPTION
0x30 2 bytes vector callback address to use when note finishes playing
0x32 2 bytes duration duration to play sound in fractional seconds (1ms resolution)
0x34 1 byte attack envelope: attack duration (vol 0-100%, 10ms resolution)
0x35 1 byte decay envelope: decay duration (vol 100-50%, 10ms resolution)
0x36 1 byte sustain envelope: sustain fraction (vol 50%, x/255 of free time)
0x37 1 byte release envelope: release duration (vol 50-0%, 10ms resolution)
0x38 2 bytes addr address to read waveform data from
0x3a 2 bytes length length of waveform data to read (in bytes)
0x3c 1 byte volume 4-bit volumes for left/right channels (6.7% resolution)
0x3d 1 byte (unused - reserved for expansion)
0x3e 1 byte pitch 1-bit loop and 7-bit MIDI note (0x00 gives silence)
0x3f 1 byte (unused - reserved for detune)
## Appendix B: existing specification
ADDR SIZE NAME DESCRIPTION
0x30 2 bytes vector callback address to use when note finishes playing
0x32 2 bytes position read current position in sample
0x34 1 byte output read envelope loudness at this moment (0x000 to 0x888)
0x35 (unused)
0x36 (unused)
0x37 (unused)
0x38 2 bytes adsr four 4-bit envelope values (attack/decay/sustain/release)
0x3a 2 bytes length length of waveform data to read in bytes
0x3c 2 bytes addr address to read waveform data from
0x3e 1 byte volume 4-bit volumes for left/right channels
0x3f 1 byte pitch 1-bit loop and 7-bit MIDI note

8
cards.tal
View File

@ -149,7 +149,7 @@
STH2kr STA2 ( end* [pos*] ; pos<-n ) STH2kr STA2 ( end* [pos*] ; pos<-n )
STH2r INC2 INC2 ( end pos+2* ) STH2r INC2 INC2 ( end pos+2* )
GTH2k ?&loop ( end* pos+2* ) GTH2k ?&loop ( end* pos+2* )
POP2 POP2 LIT2r =cards/last ( [last*] ) POP2 POP2 LIT2r :cards/last ( [last*] )
LIT2 [ &card $2 ] ( c* [last*] ) LIT2 [ &card $2 ] ( c* [last*] )
STH2kr STA2 INC2r INC2r ( [last+2*] ; last<-c ) STH2kr STA2 INC2r INC2r ( [last+2*] ; last<-c )
LIT2 [ &xy $2 ] ( xy* [last+2*] ) LIT2 [ &xy $2 ] ( xy* [last+2*] )
@ -212,7 +212,7 @@
( returns top card at coords, or 0000 if no card. ) ( returns top card at coords, or 0000 if no card. )
@find-card ( x* y* -> addr* ) @find-card ( x* y* -> addr* )
LIT2r =cards LIT2r =cards/last ( x* y* [limit* first*] ) LIT2r :cards LIT2r :cards/last ( x* y* [limit* first*] )
&loop ( x* y* [limit* pos*] ) &loop ( x* y* [limit* pos*] )
OVR2 OVR2 STH2kr ( x* y* x* y* pos* [limit* pos*] ) OVR2 OVR2 STH2kr ( x* y* x* y* pos* [limit* pos*] )
intersects ?&done ( x* y* [limit* pos*] ) intersects ?&done ( x* y* [limit* pos*] )
@ -249,7 +249,7 @@
@draw-all-cards ( draw* -> ) @draw-all-cards ( draw* -> )
,&draw STR2 ( ) ,&draw STR2 ( )
held-end-offset STH2 ( [limit*] ) held-end-offset STH2 ( [limit*] )
LIT2r =cards ( [limit* pos*] ) LIT2r :cards ( [limit* pos*] )
&loop ( [limit* pos*] ) &loop ( [limit* pos*] )
STH2kr LDA2 INC2r INC2r ( card* [limit* pos+2*] ) STH2kr LDA2 INC2r INC2r ( card* [limit* pos+2*] )
#00 STH2kr LDA INC2r ( card* x* [limit* pos+3*] ) #00 STH2kr LDA INC2r ( card* x* [limit* pos+3*] )
@ -257,7 +257,7 @@
LIT2 [ &draw $2 ] JSR2 ( [limit* pos+4] ) LIT2 [ &draw $2 ] JSR2 ( [limit* pos+4] )
GTH2kr STHr ?&loop ( [limit* pos+4] ) GTH2kr STHr ?&loop ( [limit* pos+4] )
POP2r POP2r ( ) POP2r POP2r ( )
LIT2r =cards/end ( [limit*] ) LIT2r :cards/end ( [limit*] )
held-end-offset STH2 ( [limit* offset*] ) held-end-offset STH2 ( [limit* offset*] )
&mloop ( [limit* pos*] ) &mloop ( [limit* pos*] )
STH2kr LDA2 INC2r INC2r ( card* [limit* pos+2*] ) STH2kr LDA2 INC2r INC2r ( card* [limit* pos+2*] )

1012
femto.tal
View File

File diff suppressed because it is too large Load Diff

59
filetest.tal
View File

@ -1,59 +0,0 @@
|00 @System [ &vec $2 &wst $1 &rst $1 &pad $4 &r $2 &g $2 &b $2 &debug $1 &halt $1 ]
|10 @Console [ &vec $2 &read $1 &pad $4 &type $1 &write $1 &error $1 ]
|a0 @File [ &vec $2 &ok $2 &stat $2 &delete $1 &append $1 &name $2 &length $2 &read $2 &write $2 ]
|0100
;on-console .Console/vec DEO2 BRK
( emit an unsigned short as a decimal )
@decimal ( n* -> )
LIT2r ff00 ( n* [ff^ 0^] )
&r ( ... x* )
#000a DIV2k STH2k ( x* 10* x/10* [ff^ i^ x/10*] )
MUL2 SUB2 NIP #30 ADD ( digit^ x/10* [ff^ i^] )
STH2r INCr ORAk ?&r ( digit^ x/10* [ff^ i+1^] )
POP2 ( d0* ... dn* [ff^ i+1^] )
&w ( d0^ ... dn^ [ff^ j^] )
.Console/write DEO ( d0^ ... dn-1^ [ff^ j^] )
OVRr ADDr STHkr ?&w ( d^ ... dn-1^ [ff^ j-1^] )
POP2r JMP2r ( )
@print ( s* -> )
LDAk ?{ POP2 JMP2r } LDAk .Console/write DEO INC2 !print
@on-console ( -> BRK )
.Console/type DEI #02 NEQ ?run .Console/read DEI append BRK
@append ( c^ -> )
;ptr LDA2 STA ;ptr LDA2k INC2 SWP2 STA2 JMP2r
@not-readable ( -> bool^ )
#0100 .File/length DEO2 ;buf .File/read DEO2 .File/ok DEI2 #0000 EQU2 JMP2r
@writable ( -> bool^ )
#0015 .File/length DEO2 ;dat .File/write DEO2 .File/ok DEI2 #0000 NEQ2 JMP2r
@run ( -> BRK )
#00 append
;path .File/name DEO2
;msg1 print ;path print
LIT "' .Console/write DEO #0a .Console/write DEO
not-readable ?{ ;msg2 print !exit }
;msg3 print
writable ?{ ;msg6 print !exit }
;msg4 print .File/ok DEI2 decimal ;msg5 print ( >> )
@exit ( -> BRK )
#80 .System/halt DEO BRK
@msg1 "Read 20 "path: 20 "' 00
@msg2 "File 20 "was 20 "readable 0a 00
@msg3 "File 20 "was 20 "not 20 "readable 0a 00
@msg4 "File 20 "was 20 "writable, 20 "wrote 20 00
@msg5 20 "bytes. 0a 00
@msg6 "File 20 "was 20 "not 20 "writable 0a 00
@dat "This 20 "is 20 "sample 20 "data. 0a 00
@ptr =path
@buf $100
@path $1000

174
fix16.tal
View File

@ -22,17 +22,12 @@
( #0700 1792/256 7.0000 ) ( #0700 1792/256 7.0000 )
( #7f00 32512/256 127.0000 ) ( #7f00 32512/256 127.0000 )
( #7fff 32767/256 127.9961 ) ( #7fff 32767/256 127.9961 )
( #8000 invalid invalid ) ( #8000 -32768/256 -128.0000 )
( #8001 -32767/256 -127.9961 ) ( #8001 -32767/256 -127.9961 )
( #8100 -32767/256 -127.0000 ) ( #8100 -32767/256 -127.0000 )
( #ff00 -256/256 -1.0000 ) ( #ff00 -256/256 -1.0000 )
( #ffff -1/256 -0.0039 ) ( #ffff -1/256 -0.0039 )
( ) ( )
( due to the limited range operations saturate at the )
( terminal values (i.e. #7fff and #8001). #8000 should )
( never be generated through valid arithmetic, and can be )
( considered an error if present. )
( )
( many 8.8 operations are equivalent to unsigned int16: ) ( many 8.8 operations are equivalent to unsigned int16: )
( * addition ) ( * addition )
( * subtraction ) ( * subtraction )
@ -113,20 +108,21 @@
%x16-pi/2 { #0192 } ( 1.57079... ) %x16-pi/2 { #0192 } ( 1.57079... )
%x16-pi { #0324 } ( 3.14159... ) %x16-pi { #0324 } ( 3.14159... )
%x16-3pi/2 { #04b6 } ( 4.71239... ) %x16-3pi/2 { #04b6 } ( 4.71239... )
%x16-2pi { #0648 } ( 6.28318... ) %x16-pi*2 { #0648 } ( 6.28318... )
%x16-e { #02b8 } ( 2.71828... ) %x16-e { #02b8 } ( 2.71828... )
%x16-phi { #019e } ( 1.61803... ) %x16-phi { #019e } ( 1.61803... )
%x16-sqrt-2 { #016a } ( 1.41421... ) %x16-sqrt-2 { #016a } ( 1.41421... )
%x16-sqrt-3 { #01bb } ( 1.73205... ) %x16-sqrt-3 { #01bb } ( 1.73205... )
%x16-epsilon { #0001 } ( 0.00390... ) %x16-epsilon { #0001 } ( 0.00390... )
%x16-minimum { #8001 } ( -127.99609... ) %x16-minimum { #8000 } ( -128.0 )
%x16-maximum { #7fff } ( 127.99609... ) %x16-maximum { #7fff } ( 127.99609... )
%x16-error { #8000 } ( not a number ) %x16-max-whole { #7f00 } ( 127.0 )
( utils ) ( utils )
@x16-is-non-neg ( x* -> bool^ ) x16-minimum LTH2 JMP2r @x16-is-non-neg ( x* -> bool^ ) x16-minimum LTH2 JMP2r
@x16-is-neg ( x* -> bool^ ) x16-maximum GTH2 JMP2r @x16-is-neg ( x* -> bool^ ) x16-maximum GTH2 JMP2r
@x16-emit-dec-digit ( d^ -> ) #30 ADD #18 DEO JMP2r @x16-emit-dec-digit ( d^ -> ) #30 ADD #18 DEO JMP2r
@error [ #0000 DIV ]
@x16-emit ( x* -> ) @x16-emit ( x* -> )
DUP2 #8000 EQU2 ?&is-min DUP2 #8000 EQU2 ?&is-min
@ -202,66 +198,43 @@
@x16-mul ( x* y* -- xy* ) @x16-mul ( x* y* -- xy* )
;x16-mul-unsigned !x16-signed-op ;x16-mul-unsigned !x16-signed-op
@x16-mul8 ( x^ y^ -> xy* ) @x16-mul-unsigned ( x* y* -- xy* )
#0000 SWP2 ROT SWP MUL2 JMP2r DUP #00 EQU ?x16-mul-unsigned-rhs-whole
SWP2 DUP #00 EQU ?x16-mul-unsigned-rhs-whole
,&y0 STR2 ,&x0 STR2
#00 ,&x0 LDR #00 ,&y0 LDR MUL2 ( acc* )
OVR ?&overflow SWP ( acc* )
#00 ,&x1 LDR #00 ,&y0 LDR MUL2 ADD2 ( acc* )
#00 ,&x0 LDR #00 ,&y1 LDR MUL2 ADD2 ( acc* )
#00 ,&x1 LDR #00 ,&y1 LDR MUL2 #08 SFT2 ADD2 ( acc* )
DUP2 #7fff GTH2 ?&overflow
JMP2r [ &x0 $1 &x1 $1 &y0 $1 &y1 $1 ]
&overflow POP2 #7fff JMP2r
@x16-mul-unsigned ( ab* cd* -> ac+ad+bc+bd* ) @x16-mul-unsigned-rhs-whole ( x0_x1* y0_00* -- xy* )
OVR2 OVR2 STH2 STH2 ROT SWPr ROTr ( a c d b [c b a d] ) #08 SFT2 MUL2 #7fff !unsigned-min
SWP2 x16-mul8 DUP2 #007f GTH2 ?&o1 SWP ( d b acc* [c b a d] )
SWP2 x16-mul8 #08 SFT2 ADD2 ( acc* [c b a d] )
STH2r x16-mul8 ADD2 OVR #7f GTH ?&o3 ( acc* [c d] )
STH2r x16-mul8 ADD2 OVR #7f GTH ?&o4 JMP2r ( acc* )
&o1 POP2 POP2r &o3 POP2r &o4 POP2 #7fff JMP2r ( ; handle overflow )
@x16-div ( x* y* -- x/y* ) @x16-div ( x* y* -- x/y* )
;x16-div-unsigned !x16-signed-op ;x16-div-unsigned !x16-signed-op
( The idea here is a bit complicated. )
( )
( First we look at `x y DIV2`. If that is >255 then we are )
( going to overflow and we can return 7fff and be done. )
( )
( If not, we multiply that result by 256 and start looking )
( for smaller and smaller fractions of y to star chipping )
( away at the remainder, if any. )
( )
( However we want to avoid rounding errors caused by needlessly )
( truncating y. For that reason, if the remainder is less than )
( 0x8000 we will double it rather than diving y. Once it cannot )
( be safely multiplied we will start dividing y by 2. After 16 )
( rounds of multiplying the remainder or dividing the quotient )
( we get our final answer. )
@x16-div-unsigned ( x* y* -> x/y* ) @x16-div-unsigned ( x* y* -> x/y* )
DIV2k DUP2 #007f GTH2 ?&o ( x* y* x/y* ) DIV2k STH2k ( x y x/y [x/y] )
STH2k LITr 80 SFT2r ( x* y* x/y* [div=(x/y)<<8*] ) LITr 80 SFT2r ( x y x/y [div=(x/y)<<8] )
OVR2 STH2 ( x* y* x/y* [div* y*] ) OVR2 STH2 ( x y x/y [y div] )
MUL2 SUB2 ( x%y* [div* y*] ) MUL2 SUB2 ( x%y [y div] )
STH2r LIT2r 0100 ( x%y* y* [div* 0100*] ) STH2r LIT2r 0100 ( x%y y [0100 div] )
( We know rem < y, so start left-shifting rem. )
&ploop ( rem* y* [div* s*] )
STH2kr #0000 EQU2 ?&done ( rem* y* [div* s*] ; done when s=0 )
OVR2 #7fff GTH2 ?&loop ( rem* y* [div* s*] ; rem too big, start shifting y )
SWP2 #10 SFT2 SWP2 ( rem<<1* y* [div* s*] )
LITr 01 SFT2r ( rem<<1* y* [div* s>>1*] )
LTH2k ?&ploop ( rem<<1* y* [div* s>>1*] ; rem too small )
SWP2 OVR2 SUB2 SWP2 ( rem<<1-y* y* [div* s>>1*] )
DUP2r ROT2r ADD2r SWP2r ( rem<<1-y* y* [div+s>>1* s>>1*] )
!&ploop ( rem<<1-y* y* [div+s>>1* s>>1*] )
( We know rem < y, so start right-shifting y. )
&loop ( rem* y* [div* s*] )
STH2kr #0000 EQU2 ?&done ( rem* y* [div* s*] ; done when s=0 )
#01 SFT2 LITr 01 SFT2r ( rem* y>>1* [div* s>>1*] )
LTH2k ?&loop ( rem* y>>1* [div* s>>1**] ; rem too small )
SWP2 OVR2 SUB2 SWP2 ( rem-y>>1* y>>1* [div* s>>1*] )
DUP2r ROT2r ADD2r SWP2r ( rem-y>>1* y>>1* [div+s>>1* s>>1*] )
!&loop ( rem-y>>1* y>>1* [div+s>>1* s>>1*] )
( We know x%y < y, so start right-shifting y. )
&loop DUP2 #0000 EQU2 ?&done
#01 SFT2 LITr 01 SFT2r ( rem yi [shifti div] )
LTH2k ,&loop JCN ( rem yi [shifti div] )
SWP2 OVR2 SUB2 SWP2 ( rem-yi yi [shifti div] )
DUP2r ROT2r ADD2r SWP2r ( rem-yi yi [shifti div+shifti] )
!&loop ( rem-yi yi [shifti div+shifti] )
&done &done
POP2 POP2 POP2r STH2r ( div* )
DUP2 #7fff GTH2 ?&oo JMP2r ( div* ) POP2 POP2 ( [shiftk div] )
&o POP2 POP2 &oo POP2 #7fff JMP2r ( 7fff ; saturate on overflow ) POP2r STH2r JMP2r ( div )
@x16-signed-op ( x* y* f* -> f(x,y)* ) @x16-signed-op ( x* y* f* -> f(x,y)* )
STH2 LIT2r 0001 STH2 LIT2r 0001
@ -272,11 +245,7 @@
JMP2r JMP2r
@x16-quotient ( x* y* -> x//y* ) @x16-quotient ( x* y* -> x//y* )
;x16-quot-unsigned !x16-signed-op DIV2 #80 SFT2 JMP2r
@x16-quot-unsigned ( x* y* -> x//y* )
DIV2 DUP2 #007f GTH2 ?{ #80 SFT2 JMP2r }
POP2 #7fff JMP2r
@x16-remainder ( x* y* -> x%y* ) @x16-remainder ( x* y* -> x%y* )
DIV2k MUL2 SUB2 JMP2r DIV2k MUL2 SUB2 JMP2r
@ -286,10 +255,9 @@
@x16-from-s16 ( n* -> x* ) @x16-from-s16 ( n* -> x* )
DUP2 #ff80 GTH2 ?&neg DUP2 #ff80 GTH2 ?&neg
DUP2 #007f GTH2 ?&error DUP2 #007f GTH2 ?error
NIP #00 SWP JMP2r NIP #00 SWP JMP2r
&neg NIP #ff SWP JMP2r &neg NIP #ff SWP JMP2r
&error POP2 #8000 JMP2r
( 1.5 -> 1, 0.5 -> 0, -1.5 -> -1 ) ( 1.5 -> 1, 0.5 -> 0, -1.5 -> -1 )
@x16-to-s16 ( x* -> whole* ) @x16-to-s16 ( x* -> whole* )
@ -342,31 +310,30 @@
&done ( x* s1* [c* 2*] ) &done ( x* s1* [c* 2*] )
POP2r POP2r NIP2 JMP2r ( s1* ) POP2r POP2r NIP2 JMP2r ( s1* )
@x16-unit-circle ( x* -> x'* )
x16-2pi STH2 ( x* [2pi*] )
DUP2 STH2kr x16-quotient ( x* x/2pi* [2pi*] )
DUP2 #1400 DIV2 STH2 SWP2r ( x* x/2pi* [adj* 2pi*] )
STH2r x16-mul SUB2 ( x-x/2pi* [adj*] )
STH2r LTH2k ?{ SUB2 JMP2r } ( x'* ; 0 <= x' < 2pi )
POP2 POP2 #0000 JMP2r ( x'* ; 0 <= x' < 2pi )
@x16-cos ( x* -> cos[x]* ) @x16-cos ( x* -> cos[x]* )
x16-unit-circle x16-pi/2 ADD2 ( fall-through ) x16-pi/2 ADD2 ( fall-thru )
@x16-sin ( x* -> sin[x]* ) @x16-sin ( x* -> sin[x]* )
DUP2 #8000 LTH2 ?&positive x16-negate x16-sin/positive !x16-negate DUP2 #8000 LTH2 ?&non-negative
&positive x16-unit-circle x16-negate x16-sin/non-negative !x16-negate
DUP2 x16-3pi/2 LTH2 ?{ x16-2pi SWP2 SUB2 x16-sin/q !x16-negate } &non-negative
DUP2 x16-pi LTH2 ?{ x16-pi SUB2 x16-sin/q !x16-negate } x16-pi*2 STH2 ( x [2pi] )
DUP2 x16-pi/2 LTH2 ?{ x16-pi SWP2 SUB2 } DUP2 STH2kr x16-quotient ( x x/2pi [2pi] )
&q DUP2 ADD2 ;x16-sin-table ADD2 LDA2 JMP2r STH2r x16-mul SUB2 ( x' ; 0 <= x' < 2pi )
DUP2 x16-3pi/2 LTH2 ?&c1
( -sin(2pi - x) ) x16-pi*2 SWP2 SUB2 x16-sin-q !x16-negate
&c1 DUP2 x16-pi LTH2 ?&c2
( -sin(x - pi) ) x16-pi SUB2 x16-sin-q !x16-negate
&c2 DUP2 x16-pi/2 LTH2 ?&c3
( sin(pi - x) ) x16-pi SWP2 SUB2 !x16-sin-q
&c3
( sin[x] ) ( fall-thru )
( 0 <= x < 2pi )
@x16-sin-q ( x* -> sin[x] )
DUP2 ADD2 ;x16-sin-table ADD2 LDA2 JMP2r
( there are 1608 8.8 fixed point values between 0 and 2pi. )
( )
( we use 402 tables entries x 4 quadants to get 1608 values. )
( )
( note that the table actually has 403 values just to make )
( boundary conditions a bit easier to deal with. )
@x16-sin-table @x16-sin-table
0000 0001 0002 0003 0004 0005 0006 0007 0008 0009 000a 000b 000c 000d 000e 000f 0000 0001 0002 0003 0004 0005 0006 0007 0008 0009 000a 000b 000c 000d 000e 000f
0010 0011 0012 0013 0014 0015 0016 0017 0018 0019 001a 001b 001c 001d 001e 001f 0010 0011 0012 0013 0014 0015 0016 0017 0018 0019 001a 001b 001c 001d 001e 001f
@ -396,15 +363,26 @@
0100 0100 0100 0100 0100 0100
@x16-tan ( x* -> tan[x]* ) @x16-tan ( x* -> tan[x]* )
x16-unit-circle x16-pi*2 STH2 ( x [2pi] )
DUP2 STH2kr x16-quotient ( x x/2pi [2pi] )
STH2r x16-mul SUB2 ( x' ; 0 <= x' < 2pi )
( tan(pi/2) = tan(3pi/2) = error ) ( tan(pi/2) = tan(3pi/2) = error )
DUP2 x16-3pi/2 EQU2 ?&error DUP2 x16-3pi/2 EQU2 ?error
DUP2 x16-pi/2 EQU2 ?&error DUP2 x16-pi/2 EQU2 ?error
DUP2 x16-3pi/2 LTH2 ?{ x16-2pi SWP2 SUB2 x16-tan/q !x16-negate }
DUP2 x16-pi LTH2 ?{ x16-pi SUB2 !x16-tan/q } DUP2 x16-3pi/2 LTH2 ?&c1
DUP2 x16-pi/2 LTH2 ?{ x16-pi SWP2 SUB2 x16-tan/q !x16-negate } ( -tan(2pi - x) ) x16-pi*2 SWP2 SUB2 x16-tan-q !x16-negate
&q DUP2 ADD2 ;x16-tan-table ADD2 LDA2 JMP2r &c1 DUP2 x16-pi LTH2 ?&c2
&error POP2 #8000 JMP2r ( tan(x - pi) ) x16-pi SUB2 !x16-tan-q
&c2 DUP2 x16-pi/2 LTH2 ?&c3
( -tan(pi - x) ) x16-pi SWP2 SUB2 x16-tan-q !x16-negate
&c3
( tan[x] ) ( fall-thru )
( 0 <= x < 2pi )
@x16-tan-q ( x* -> sin[x] )
DUP2 ADD2 ;x16-tan-table ADD2 LDA2 JMP2r
@x16-tan-table @x16-tan-table
0000 0001 0002 0003 0004 0005 0006 0007 0008 0009 000a 000b 000c 000d 000e 000f 0000 0001 0002 0003 0004 0005 0006 0007 0008 0009 000a 000b 000c 000d 000e 000f
@ -438,7 +416,7 @@
[ DUP2 #0000 GTH2 ] STH [ DUP2 #0000 GTH2 ] STH
[ DUP2 #8000 LTH2 ] STHr AND ?&0<x<128 [ DUP2 #8000 LTH2 ] STHr AND ?&0<x<128
( error ) POP2 #8000 JMP2r ( error ) ( error ) !error
&0<x<128 DUP2 #0800 GTH2 ?&8<x<128 &0<x<128 DUP2 #0800 GTH2 ?&8<x<128
( 0<x<=8 ) DUP2 #0200 GTH2 ?&2<x<=8 ( 0<x<=8 ) DUP2 #0200 GTH2 ?&2<x<=8

235
fix32.tal
View File

@ -1,235 +0,0 @@
( fix32.tal )
( )
( 32-bit fixed point using 1000 as a denominator. )
( )
( LONG FRACTION DECIMAL )
( 0000 0000 0/1000 0.000 )
( 0000 0001 1/1000 0.001 )
( 0000 000a 10/1000 0.010 )
( 0000 0064 100/1000 0.100 )
( 0000 00fa 250/1000 0.250 )
( 0000 01f4 500/1000 0.500 )
( 0000 03e8 1000/1000 1.000 )
( 0000 3e80 16000/1000 16.000 )
( 0001 0000 65536/1000 65.536 )
( 7fff ffff 2147483647/1000 2147483.647 )
( 8000 0000 invalid invalid )
( 8000 0001 -2147483647/1000 -2147483.647 )
( ffff fc18 -1000/1000 -1.000 )
( ffff ffff -1/1000 -0.001 )
( )
( instead of overflowing operations will saturate )
( at the maximum/minimum values. )
( )
( rounding caused by division will round toward )
( the nearest even value. for example: )
( )
( 0.000 / 2 = 0.000 )
( 0.001 / 2 = 0.000 )
( 0.002 / 2 = 0.001 )
( 0.003 / 2 = 0.002 )
( 0.004 / 2 = 0.002 )
( 0.005 / 2 = 0.002 )
( 0.006 / 2 = 0.003 )
( 0.007 / 2 = 0.004 )
( )
( this is done to prevent numerical bias. it is also )
( called banker's rounding, or round-half-to-even. )
( )
( x/** signifies a 32-bit fixed point value. )
( x** signfiies a 32-bit value of any kind. )
%POP4 { POP2 POP2 }
%POP8 { POP2 POP2 POP2 POP2 }
%STH4 { STH2 STH2 }
%STH4r { STH2r STH2r }
%DENOM16 { #03e8 }
%DENOM32 { #0000 #03e8 }
( numerical constants )
( )
( to compute a constant, multiply the value you want )
( by 1000 and take its hex representation. )
( )
( example: python -c 'print(hex(round(13.5 * 1000)))' )
%x32-hundredth { #0000 #000a } ( 0.01 )
%x32-tenth { #0000 #0064 } ( 0.1 )
%x32-half { #0000 #01f4 } ( 0.5 )
%x32-one { #0000 #03e8 } ( 1.0 )
%x32-two { #0000 #07d0 } ( 2.0 )
%x32-three { #0000 #0bb8 } ( 3.0 )
%x32-four { #0000 #0fa0 } ( 4.0 )
%x32-five { #0000 #1388 } ( 5.0 )
%x32-ten { #0000 #2710 } ( 10.0 )
%x32-sqrt2 { #0000 #0586 } ( 1.414 ~ sqrt[2] )
%x32-sqrt3 { #0000 #06c4 } ( 1.732 ~ sqrt[3] )
%x32-e { #0000 #0a9e } ( 2.718 ~ e )
%x32-pi/2 { #0000 #0623 } ( 1.571 ~ pi/2 )
%x32-pi { #0000 #0c46 } ( 3.142 ~ pi )
%x32-3pi/2 { #0000 #1268 } ( 4.712 ~ 3pi/2 )
%x32-2pi { #0000 #188b } ( 6.283 ~ 2pi )
@x32-eq ( x/** y/** -> bool^ ) !u32-eq
@x32-ne ( x/** y/** -> bool^ ) !u32-ne
@x32-is-zero ( x/** -> bool^ ) !u32-is-zero
@x32-non-zero ( x/** -> bool^ ) !u32-non-zero
@x32-is-positive ( x/** -> bool^ ) POP2 #8000 LTH2 JMP2r
@x32-is-negative ( x/** -> bool^ ) POP2 #7fff GTH2 JMP2r
@x32-from-u8 ( x^ -> x/** )
#00 SWP ( >> )
@x32-from-u16 ( x* -> x/** )
#0000 SWP2 ( >> )
@x32-from-u32 ( x** -> x/** )
DENOM32 !u32-mul
@x32-from-s8 ( x^ -> x/** )
DUP #80 AND #07 SFT #ff MUL SWP ( >> )
@x32-from-s16 ( x* -> x/** )
DUP2 #8000 AND2 #0f SFT2 #ffff MUL2 SWP2 ( >> )
@x32-from-s32 ( x** -> x/** )
DENOM32 !u32-mul
@x32-signed-op ( x** y** f* -> f[x,y]** )
STH2 LIT2r 0001 ( x** y** [f* 0^ 1^] )
OVR2 #8000 LTH2 ?{ u32-negate SWPr } ( x** y** [f* ab*] )
ROT2 STH2 ROT2 STH2r ( y** x** [f* ab*] )
OVR2 #8000 LTH2 ?{ u32-negate SWPr } ( y** x** [f* cd*] )
ROT2 STH2 ROT2 STH2r SWP2r ( x** y** [cd* f*] )
STH2r JSR2 ( f[x,y]** [cd*] )
NIPr STHr ?{ u32-negate } JMP2r ( z** )
@x32-prepare-cmp ( x/** y/** -> x/** y/** xp^ yp^ )
OVR2 #8000 LTH2 ,&yp STR STH4
OVR2 #8000 LTH2 ,&xp STR STH4r
LIT2 [ &xp $1 &yp $1 ] JMP2r
( TODO: test these implementations )
@x32-lt-old ( x** y** -> x<y^ )
STH2 SWP2 STH2 EOR2k #8000 LTH2 ?{ ( ; do x and y have different signs? )
POP2r POP2r POP2 #8000 GTH2 JMP2r ( ; signs differ, is x negative? )
} GTH2r STHr ?{ ( ; same signs, is xlo < ylo? )
LTH2 JMP2r ( ; no, is xhi < yhi? )
} GTH2 #00 EQU JMP2r ( ; yes, is xhi <= yhi? )
( TODO: test these implementations )
@x32-gt-old ( x** y** -> x<y^ )
STH2 SWP2 STH2 EOR2k #8000 LTH2 ?{ ( ; do x and y have different signs? )
POP2r POP2r POP2 #8000 LTH2 JMP2r ( ; signs differ, is x positive? )
} LTH2r STHr ?{ ( ; same signs, is xlo > ylo? )
GTH2 JMP2r ( ; no, is xhi > yhi? )
} LTH2 #00 EQU JMP2r ( ; yes, is xhi >= yhi? )
@x32-lt ( x/** y/** -> bool^ )
x32-prepare-cmp NEQk ?{ POP2 !u32-lt } LTH STH POP8 STHr JMP2r
@x32-gt ( x/** y/** -> bool^ )
x32-prepare-cmp NEQk ?{ POP2 !u32-gt } GTH STH POP8 STHr JMP2r
@x32-lteq ( x/** y/** -> bool^ )
x32-prepare-cmp NEQk ?{ POP2 !u32-lteq } LTH STH POP8 STHr JMP2r
@x32-gteq ( x/** y/** -> bool^ )
x32-prepare-cmp NEQk ?{ POP2 !u32-gteq } GTH STH POP8 STHr JMP2r
( TODO: support saturation at +/- infinity )
( TODO: support signed operations )
@x32-add ( x/** y/** -> z/** )
STH4 OVR2 #8000 AND2 ( x** xs* [ylo* yhi*] )
STH2kr #8000 AND2 ( x** xs* ys* [ylo* yhi*] )
EQU2k ?{ POP4 STH4r !u32-add } ( z** xs* ys* [ylo* yhi*] )
POP2 ROT2 ROT2 STH4r ( sign* x** y** )
u32-add ROT2 STH2 ( z** [sign*] )
OVR2 #8000 AND2 STH2kr ( z** zs* sign* [sign*] )
NEQ2 ?{ POP2r JMP2r } ( z** [sign*] )
POP4 POPr STHr ?&negative ( )
#7fff #ffff JMP2r ( 7fff* ffff* )
&negative #8000 #0001 JMP2r ( 8000* 0001* )
@x32-sub ( x/** y/** -> z/** )
u32-negate !x32-add
@x32-negate ( x/** y/** -> z/** )
!u32-negate
@x32-mul ( x/** y/** -> z/** )
;x32-mul-unsigned !x32-signed-op
( [x*y]/1000 = floor[x/1000] + [[x%1000]*y]/1000 )
@x32-mul-unsigned ( x/** y/** -> z/** )
STH4 DENOM32 u32-divmod ( q=x/1000** r=x%1000** [ylo* yhi*] )
STH2kr OVR2r STH2r u32-mul ( q** ry** [ylo* yhi*] )
DENOM32 u32-divmod ( q** rq=ry/1000** rr=ry%1000** [ylo* yhi*] )
NIP2 ,&r1 STR2 ( q** rq** [ylo* yhi*] ; <-rr1 )
ROT2 STH2 ROT2 STH2r ( ry/1000** q** [ylo* yhi*] )
STH4r u32-mul ( ry/1000** qy** )
u32-add ( z=qy+ry/1000** )
DUP2 #0001 AND2 STH2 ( z** [odd*] )
#0000 LIT2 [ &r1 $2 ] ( z** rr** [odd*] )
STH2r ADD2 #01f3 ADD2 ( z** rr+odd+499** )
DENOM32 u32-div ( z** b=rr+odd+499/1000** )
!u32-add ( z+b** )
@x32-div ( x/** y/** -> z/** )
;x32-div-unsigned !x32-signed-op
( [x*1000]/y = floor[x/y]*1000 + [[x%y]*1000]/y )
@x32-div-unsigned ( x/** y/** -> z/** )
STH2k OVR2 STH2 ( x/** y/** [ylo* yhi*] )
u32-divmod ( q=x/y** r=x%y** [ylo* yhi*] )
DENOM32 u32-mul ( q** r1000** [ylo* yhi*] )
STH2kr OVR2r STH2r u32-divmod ( q** rq** rr** [ylo* yhi*] )
,&r1 STR2 ,&r0 STR2 ( q** rq** ; <-rr0 <-rr1 [ylo* yhi*] )
ROT2 STH2 ROT2 STH2r ( rq** q** [ylo* yhi*] )
DENOM32 u32-mul ( rq** q1000** [ylo* yhi*] )
u32-add ( z=rq+q1000** [ylo* yhi*] )
DUP ,&e STR ( z** ; e<-z3^ [ylo* yhi*] )
LIT2 [ &r0 $2 ] LIT2 [ &r1 $2 ] ( z** rr** [ylo* yhi*] )
LIT [ &e $1 ] #01 AND ( z** rr** e^ )
#00 SWP #0000 SWP2 ( z** rr** e** [ylo* yhi*] )
u32-add ( z** w=rr+e** [ylo* yhi*] )
STH2kr OVR2r STH2r ( z** w** y** [ylo* yhi*] )
#0000 #0001 u32-sub ( z** w** y-1** [ylo* yhi*] )
#01 u32-rshift u32-add ( z** v=w+y-1/2** [ylo* yhi*] )
STH4r u32-div !u32-add ( z+v/y** )
( print an x32 number to stdout )
@x32-emit ( x/** -> )
;x32-emit/draw-ch !x32-draw
&draw-ch ( c^ -> ) #18 DEO JMP2r
@x32-draw ( x/** draw-char* -> )
STH2 OVR2 #8000 LTH2 ?{
LIT "- STH2kr JSR2
u32-negate
}
STH2r ( >> )
( draw an x32 number using the given character-drawing subroutine )
@x32-draw-unsigned ( x/** draw-char* -> )
,&f STR2 LITr 00 ( x** [0^] )
&loop ( x1** [... count^] )
#0000 #000a u32-divmod ( q** r** )
NIP2 NIP INCr ( q** r^ [... count+1^] )
LIT "0 ADD STH SWPr ( q** [... c^ count+1^] )
STHkr #03 NEQ ?&next ( q** [... c^ count+1^] )
INCr LITr ". SWPr ( q** [... c^ dot^ count+2^] )
&next ( q** [... count+n^ )
OVR2 OVR2 ( q** q** [... count+n^] )
u32-non-zero ?&loop POP4 ( [... count+n^] )
&pad ( [... count+n^] )
STHkr #04 GTH ?&unroll ( [... count+n^] )
STHkr #03 NEQ ?{ INCr LITr ". SWPr }
INCr LITr "0 SWPr !&pad ( [... 0^ count+n+1^] )
&unroll ( [... x0^] )
STHr ( x0^ [...] )
&uloop ( x^ [... z^] )
STHr LIT2 [ &f $2 ] JSR2 ( x^ [...] ; call f[z] )
#01 SUB DUP ?&uloop ( x-1^ [...] )
POP JMP2r ( )
~math32.tal

186
icn_to_bmp.tal
View File

@ -1,186 +0,0 @@
( icn_to_bmp.tal )
( )
( converts ICN files to BMP files. )
( )
( USAGE: icn_to_bmp.rom $tile-w $tile-h $in-file $out-file )
( )
( EXAMPLE: icn_to_bmp.rom 8 8 icon.icn icon.bmp # convert a 64x64 pixel image )
@System [ |0f &state $1 ]
@Console [ |18 &w $1 ]
|a0 @File1 [ &vec $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|b0 @File2 [ &vec $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|0000
@tile-w $2
@adj-tile-w $2
@tile-h $2
@icn-size $2
@in-file $2
@out-file $2
@row-size-bytes $2
@adj-row-size-bytes $2
|0100
;after-args #0000 arg/init BRK
( load argument parsing )
~arg.tal
( exit immediately )
@exit ( -> BRK )
#01 .System/state DEO BRK
( write null-terminated string to stdout )
@emit ( buf* -> )
LITr -Console/w ( buf* [dev^] )
&loop LDAk ?&ok POP2 POPr JMP2r ( )
&ok LDAk STHkr DEO INC2 !&loop ( buf+1* [dev^] )
@msg
&wrote "wrote 20 00
&bytes-to 20 "bytes 20 "to 20 00
&invalid-width "Invalid 20 "tile 20 "width 00
&invalid-height "Invalid 20 "tile 20 "height 00
&invalid-size "Invalid 20 "size: 20 "ICN 20 "too 20 "large
&write-error "Failed 20 "to 20 "write 20 "data 00
&wrong-number-of-args "Wrong 20 "number 20 "of 20 "args; 20 "expected 20 "four 00
@usage ( reason* -> )
;usage/error emit emit ;usage/message emit !exit
&error "ERROR: 20 00
&message
0a 0a "USAGE: 20 "icn_to_bmp.rom 20 "WIDTH 20 "HEIGHT 20 "ICN 20 "BMP 0a
20 20 "WIDTH 20 "and 20 "HEIGHT 20 "are 20 "given 20 "in 20 "tiles 20 "(each 20 "tile 20 "is 20 "8x8 20 "pixels) 0a
20 20 "maximum 20 "WIDTH/HEIGHT 20 "is 20 "255 20 "tiles 0a
20 20 "ICN/BMP 20 "should 20 "be 20 "paths 20 "(that 20 "are 20 "readable/writable) 0a
20 20 "maximum 20 "ICN 20 "size 20 "is 20 "49152 20 "bytes 0a
0a 00
@str-to-int ( s* -> n* )
LIT2r 0000
&loop LDAk ?&non-null POP2 STH2r JMP2r
&non-null LDAk LIT "0 SUB DUP #09 GTH ?&bad
LIT2r 000a MUL2r LITr 00 STH ADD2r INC2 !&loop
&bad POP2 POP2r #0000 JMP2r
( emit a short as a decimal )
@emit-dec2 ( n* -> )
LITr 00 ( n [0] )
&read ( n [k] )
#000a DIV2k STH2k MUL2 SUB2 STH2r INCr ( n%10 n/10 [k+1] )
DUP2 ORA ,&read JCN
POP2 ( top element was 0000 )
&write ( n0 n1 ... nk [k+1] )
NIP #30 ADD #18 DEO LITr 01 SUBr ( n0 ... n{k-1} [k] )
STHkr ,&write JCN
POPr JMP2r
@after-args ( -> )
;arg/count LDA #04 EQU ?{ ;msg/wrong-number-of-args !usage }
#00 arg/read str-to-int .tile-w STZ2
#01 arg/read str-to-int .tile-h STZ2
#02 arg/read .in-file STZ2
#03 arg/read .out-file STZ2
.tile-w LDZ2 .tile-h LDZ2 MUL2 #30 SFT2 .icn-size STZ2
.tile-w LDZ2 #30 SFT2 .row-size-bytes STZ2
.tile-w LDZ2 #0008 MUL2 #001f ADD2 #0020 DIV2 #0004 MUL2 .adj-tile-w STZ2
.adj-tile-w LDZ2 #30 SFT2 .adj-row-size-bytes STZ2
validate
write-header
read-icn
write-body
;msg/wrote emit
;bmp-header/total-size LDA2 SWP emit-dec2
;msg/bytes-to emit .out-file LDZ2 emit
#0a .Console/w DEO
!exit
@read-icn ( -> ok^ )
.in-file LDZ2 .File1/name DEO2
.icn-size LDZ2 STH2k .File1/len DEO
;icn-dat .File1/r DEO2
.File1/ok DEI2 STH2r EQU2 JMP2r
@convert-tile-row ( src* -> )
.row-size-bytes LDZ2 ( src* size* )
OVR2 ADD2 SWP2 LIT2r =bmp-buf ( limit* src* [dst*] )
&loop ( limit* src* [dst*] )
DUP2 STH2kr convert-row ( limit* src* [dst*] )
#0008 ADD2 INC2r ( limit* src+8* [dst+1*] )
GTH2k ?&loop ( limit* src+8* [dst+1*] )
POP2 POP2 POP2r JMP2r ( )
@convert-row ( src* dst* -> )
LITr -adj-tile-w LDZ2r STH2 ( src* [w* dst*] )
#0001 SUB2 DUP2 #0008 ADD2 ( lim* src+7* [w* dst*] )
&loop ( lim* pos* [w* dst*] )
LDAk STH2kr STA OVR2r ADD2r ( src* pos* [w* dst+w*] ; dst<-pos )
#0001 SUB2 LTH2k ?&loop ( src* pos-1* [w* dst+w*] )
POP2 POP2 POP2r POP2r JMP2r ( )
@write-tile-row ( -> ok^ )
.adj-row-size-bytes LDZ2 STH2k .File2/len DEO2
;bmp-buf .File2/w DEO2
.File2/ok DEI2 STH2r EQU2 JMP2r
@validate ( -> )
.tile-w LDZ2 #0001 SUB2 #00ff LTH2 ?&tile-w-ok ;msg/invalid-width !usage &tile-w-ok
.tile-h LDZ2 #0001 SUB2 #00ff LTH2 ?&tile-h-ok ;msg/invalid-height !usage &tile-h-ok
.icn-size LDZ2 #c001 LTH2 ?&size-ok ;msg/invalid-size !usage &size-ok
JMP2r
( colors are provided in RGB order, written to BMP header in reverse )
@write-color ( r^ g^ b^ addr* -> )
STH2k STA INC2r ( ; addr+0<-b )
STH2kr STA INC2r ( ; addr+1<-g )
STH2r STA JMP2r ( ; addr+2<-r )
@write-header ( -> )
( NOTE: you'll see some swaps just before stores )
( this is because the BMP header uses a little-endian byte order )
.adj-tile-w LDZ2 .tile-h LDZ2 MUL2 ( aw*h )
#30 SFT2 #0020 ADD2 ( 32+aw*h*8 )
SWP ;bmp-header/total-size STA2 ( ; write total-size )
.tile-h LDZ2 #30 SFT2 SWP ;bmp-header/pixel-h STA2 ( ; write height )
.tile-w LDZ2 #30 SFT2 SWP ;bmp-header/pixel-w STA2 ( ; write width )
( these colors are specified in RGB order )
#ff #ff #ff ;bmp-header/color0 write-color ( ; write color 0 )
#00 #00 #00 ;bmp-header/color1 write-color ( ; write color 1 )
( actually write out the BMP header now )
.out-file LDZ2 .File2/name DEO2
#0020 .File2/len DEO2
;bmp-header .File2/w DEO2
.File2/ok DEI2 #0020 EQU2 ?&ok ;msg/write-error !usage
&ok JMP2r
@write-body ( -> )
;icn-dat ( dat* )
.icn-size LDZ2 OVR2 ADD2 ( dat* dat+size* )
.row-size-bytes LDZ2 STH2k SUB2 ( dat* dat+size-row* [row*] )
&loop
DUP2 convert-tile-row
write-tile-row ?&ok2 ;msg/write-error !usage &ok2
STH2kr SUB2 GTH2k ?&done !&loop
&done POP2r POP2 POP2 JMP2r
( fields marked "MOD" will be updated; others will stay the same )
@bmp-header
"BM ( 0: identify bitmap )
&total-size 00 00 00 00 ( 2: total file size in bytes, includes header, MOD )
00 00 ( 6: reserved, zero )
00 00 ( 8: reserved, zero )
20 00 00 00 ( 10: pixel data offset, 32 bytes )
0c 00 00 00 ( 14: header size, 12 bytes )
&pixel-w 00 00 ( 18: width in pixels, MOD )
&pixel-h 00 00 ( 20: height in pixels, MOD )
01 00 ( 22: color planes, 1 )
01 00 ( 24: bits per pixel, 1 )
&color0 ff ff ff ( 26: color 0, blue/green/red MOD )
&color1 00 00 00 ( 29: color 1, blue/green/red MOD )
( 32: start of pixel data MOD )
@bmp-buf $7f8 ( 2040 bytes: buffer for one BMP row )
@icn-dat $c000 ( 49152 bytes: buffer for the entire ICN file )

185
julia.tal
View File

@ -1,185 +0,0 @@
( julia.tal )
( )
( based on mandelbrot.tal by alderwick and d_m )
( )
( uses 4.12 fixed point arithmetic. )
( SCALE LOGICAL SCREENSIZE )
( #0001 21x16 42x32 )
( #0002 42x32 84x64 )
( #0004 84x64 168x128 )
( #0008 168x128 336x256 )
( #0010 336x256 672x512 )
( #0020 672x512 1344x1024 )
%SCALE { #0009 } ( 32 )
%WIDTH { #0015 } ( 21 )
%HEIGHT { #0010 } ( 16 )
%XMIN { #de69 } ( -8601 => -8601/4096 => -2.100 )
%XMAX { #0b33 } ( 2867 => 2867/4096 => 0.700 )
%YMIN { #ecc7 } ( -4915 => -4915/4096 => -1.200 )
%YMAX { #1333 } ( 4915 => 4915/4096 => 1.200 )
|00 @System &vector $2 &wst $1 &rst $1 &eaddr $2 &ecode $1 &pad $1 &r $2 &g $2 &b $2 &debug $1 &halt $1
|20 @Screen &vector $2 &width $2 &height $2 &auto $1 &pad $1 &x $2 &y $2 &addr $2 &pixel $1 &sprite $1
|0100 ( -> )
( set colors )
#00ff .System/r DEO2
#0ff0 .System/g DEO2
#0f0f .System/b DEO2
( set window size )
width #10 SFT2 .Screen/width DEO2
height #10 SFT2 .Screen/height DEO2
( starting c values )
#0630 ;evaluate/cx STA2 #f5e0 ;evaluate/cy STA2
;on-screen .Screen/vector DEO2
BRK
@on-screen ( -> BRK )
#0000 DUP2 .Screen/x DEO2 .Screen/y DEO2
draw-julia
;evaluate/cx LDA2
DUP2 #2000 LTH2 ?&upx
DUP2 #e000 GTH2 ?&upx
#0000 ,&dx LDR2 SUB2 ,&dx STR2
&upx [ LIT2 &dx 0040 ] ADD2 SWP2 STA2
;evaluate/cy LDA2k
DUP2 #2000 LTH2 ?&upy
DUP2 #e000 GTH2 ?&upy
#0000 ,&dy LDR2 SUB2 ,&dy STR2
&upy [ LIT2 &dy 0040 ] ADD2 SWP2 STA2
BRK
( logical width )
@width ( -> w* )
WIDTH SCALE MUL2 JMP2r
( logical height )
@height ( -> h* )
HEIGHT SCALE MUL2 JMP2r
( draw the julia set using 4.12 fixed point numbers )
@draw-julia ( -> )
XMAX XMIN SUB2 width DIV2 ,&dx STR2 ( ; &dx<-{xmax-min}/width )
YMAX YMIN SUB2 height DIV2 ,&dy STR2 ( ; &dy<-{ymax-ymin}/height )
[ LIT2 01 -Screen/auto ] DEO ( ; auto<-1 )
LIT2r 8000 ( [8000] )
YMAX YMIN ( ymax* ymin* [8000] )
&yloop ( ymax* y* [8000] )
XMAX XMIN ( ymax* y* xmax* xmin* [8000] )
&xloop ( ymax* y* xmax* x* [8000] )
ROT2k evaluate ( ymax* y* xmax* x* xmax* count^ [8000] )
draw-px POP2 ( ymax* y* xmax* x* [8000] )
[ LIT2 &dx $2 ] ADD2 ( ymax* y* xmax* x+dx* [8000] )
OVR2 STH2kr ADD2 ( ymax* y* xmax* x+dx* 8000+xmax* [8000] )
OVR2 STH2kr ADD2 ( ymax* y* xmax* x+dx* 8000+xmax* 8000+x+dx* [8000] )
GTH2 ?&xloop ( ymax* y* xmax* x+dx* [8000] )
POP2 POP2 ( ymax* y* [8000] )
#0000 .Screen/x DEO2 ( ymax* y* [8000] ; sc/x<-0 )
.Screen/y ;inc2 adjust ( ymax* y* [8000] ; sc/y<-sy+1 )
[ LIT2 &dy $2 ] ADD2 ( ymax* y+dy* [8000] )
OVR2 STH2kr ADD2 ( ymax* y+dy* 8000+ymax* [8000] )
OVR2 STH2kr ADD2 ( ymax* y+dy* 8000+ymax* 8000+y+dy* [8000] )
GTH2 ?&yloop ( ymax* y+dy* [8000] )
POP2 POP2 POP2r JMP2r ( )
( dithering pattern for 2x2 pixels: )
( )
( |o o| -> |x o| -> |x o| -> |x x| -> |x x| )
( |o o| -> |o o| -> |o x| -> |o x| -> |x x| )
( )
( |[p+3]/4 [px+1]/4| )
( |[p+0]/4 [px+2]/4| )
@draw-px ( px^ -> )
INCk INCk INC ( p+0 p+1 p+3 )
draw-quad draw-quad ( p+0 ; draw NW, NE )
.Screen/y ;inc1 adjust ( ; y<-y+1 )
.Screen/x ;sub2 adjust ( ; x<-x-2 )
INCk INC SWP ( p+2 p+0 )
draw-quad draw-quad ( ; draw SW, SE )
.Screen/y ;sub1 !adjust ( ; y<-y-1 )
( draw one quadrant of a 2x2 area )
@draw-quad ( p^ -> )
#02 SFT .Screen/pixel DEO JMP2r ( ; pixel<-p/4 )
( evaluate the julia function at one point )
@evaluate ( x* y* -> count^ )
LIT2r 20 00 ( x* y* [20 00] )
&loop ( x1* y1* [20 n^] )
OVR2 square STH2 ( x1* y1* [20 n^ xx1*] )
DUP2 square STH2 ( x1* y1* [20 n^ xx1* yy1*] )
ADD2kr STH2r ( x1* y1* xx1+yy1* [20 n^ xx1* yy1*] )
#4000 GTH2 ?&end2 ( x1* y1* [20 n^ xx1* yy1*] )
smul2 DUP2 ADD2 ( 2x1y1* [20 n^ xx1* yy1*] )
LIT2 [ &cy $2 ] ADD2 ( y2=2x1y1+cy* [20 n^ xx1* yy1*] )
SUB2r STH2r ( y2* xx1-yy1* [20 n^] )
LIT2 [ &cx $2 ] ADD2 ( y2* x2=xx1-yy1+cx* [20 n^] )
SWP2 INCr GTHkr STHr ?&loop ( x2* y2* [20 n+1^] )
!&end1 ( x2* y2* [20 n+1^] )
&end2 POP2r POP2r ( x* y* [20 count^] )
&end1 POP2 POP2 NIPr STHr JMP2r ( count^ )
( is x a non-negative signed value? )
@non-negative ( x* -> x* x>=0^ )
DUP2 #8000 LTH2 JMP2r
( multiply two signed 4.12 fixed point numbers )
@smul2 ( a* b* -> ab* )
LIT2r 0001 non-negative ?{ negate SWPr } ( a* |b|* [sign*] )
SWP2 non-negative ?{ negate SWPr } ( |b|* |a|* [sign*] )
smul2-pos STHr ?{ negate } POPr JMP2r ( ab* )
( multiply two non-negative fixed point numbers )
( )
( a * b = {a0/16 + a1/4096} * {b0/16 + b1/4096} )
( = a0b0/256 + a1b0/65536 + a0b1/65536 + a1b1/16777216 )
( = x + y + z + 0 ; the last term is too small to represent, i.e. zero )
( )
( x = a0b0 << 4 )
( y = a1b0 >> 4 )
( z = a0b1 >> 4 )
@smul2-pos ( a* b* -> ab* )
aerate ROT2 aerate ( b0* b1* a0* a1* )
STH2 ROT2k STH2 MUL2r ( b0* b1* a0* b1* a0* [a1b0*] )
MUL2 STH2 ADD2r ( b0* b1* a0* [a1b0+a0b1*] )
NIP2 MUL2 #07ff min #40 SFT2 ( a0b0* [y+z*] )
STH2r #04 SFT2 ADD2 ( x* [y+z*] )
#7fff !min ( ab* )
( equivalent to DUP2 smul2 but faster )
@square ( a* -> aa* )
non-negative ?{ negate } ( |a|* )
aerate ( 00 ahi^ 00 alo^ )
OVR2 MUL2 #03 SFT2 SWP2 ( yz* ahi* )
DUP2 MUL2 #07ff min #40 SFT2 ( x* yz* )
ADD2 #7fff !min ( aa* )
( update a device d^ given a function f: x* -> f[x]* )
@adjust ( d^ f* -> )
STH2 DEI2k STH2r JSR2 ROT DEO2 JMP2r
( return the minimum of two non-negative numbers. )
@min ( x* y* )
GTH2k [ JMP SWP2 ] NIP2 JMP2r
( convert each byte of a a short into a short )
@aerate ( x* -> 00 xhi^ 00 xlo^ )
SWP #0000 ROT SWP2 SWP JMP2r
( negate a fixed point number. doesn't work for #8000 )
@negate ( x* -> -x* )
DUP2k EOR2 SWP2 SUB2 JMP2r
( useful arithmetic operations )
@inc2 ( n* -> n+2* ) INC2
@inc1 ( n* -> n+1* ) INC2 JMP2r
@sub1 ( n* -> n-1* ) #0001 SUB2 JMP2r
@sub2 ( n* -> n-2* ) #0002 SUB2 JMP2r

103
math-notes.txt
View File

@ -1,103 +0,0 @@
Some questions and answers about doing math in UXN
--------------------------------------------------
Q: How can I handle negative integers in UXN?
A: Uxn doesn't have any built-in support for signed integers. However, you can
emulate signed numbers using unsigned numbers by treating some of the values
as having different (negative) values from their unsigned values.
For example, treating unsigned bytes as signed results in the following:
unsigned unsigned signed
hex decimal decimal
#00 0 0
#01 1 1
#02 2 2
... ... ...
#7e 126 126
#7f 127 127
#80 128 -128
#81 129 -127
#82 130 -126
... ... ...
#fd 253 -3
#fe 254 -2
#ff 255 -1
The first 128 integers (0-127) are represented the same as unsigned and signed,
but the latter 128 are different. The basic idea here is that for values
greater than #7f (127) we subtract 256 to get their "signed value":
signed(n) = if n > 127 then n else n - 256
It turns out that many unsigned operations "work" even when treating the values
as signed. (In other words, you get the same result as you would have using a
language with signed integer types.) The following arithmetic instructions work
correctly with "signed" values:
EQU and NEQ
ADD (example: `#13 #ff ADD` returns #12)
SUB (exampel: `#02 #03 SUB` returns #ff)
MUL (example: `#02 #ff MUL` returns #fe)
Other instructions will not handle "negative" integers correctly:
GTH and LTH:
1. these work correctly when comparing values with the same sign
(example: `#80 #ff LTH` returns #01)
2. however, LTH will consider negative values greater than non-negative
values, which is incorrect.
(example: `#ff #00 GTH` returns #01, but -1 is less than 0)
These implementations will safely compare "signed" bytes:
@signed-lth ( x^ y^ -- x<y^ )
DUP2 #8080 AND2 EQU ?&diff LTH JMP2r &diff LTH #00 NEQ JMP2r
@signed-gth ( x^ y^ -- x<y^ )
DUP2 #8080 AND2 EQU ?&diff GTH JMP2r &diff GTH #00 NEQ JMP2r
DIV:
Similarly, division will not correctly handle signed values. The simplest
way to handle this is to make both values non-negative, do unsigned
division (i.e. DIV) and then set the correct sign at the end.
@abs-sign ( x^ -- abs-x^ sign^ )
DUP #7f GTH #fe MUL INC STHk MUL STHr JMP2r
@signed-div ( x^ y^ -- x/y^ )
abs-sign STH SWP abs-sign STH SWP DIV MULr STHr MUL JMP2r
Be careful! The smallest negative value (-128 for bytes, -32768 for shorts)
has no corresponding positive value. This means that some operations will
not work as expected:
`#80 #ff MUL` returns #80 (-128 * -1 = -128)
`#00 #80 SUB` returns #80 (0 - (-128) = -128)
Also, negative and positive values will "wrap around" in the usual way when
dealing with two's-complement representations:
`#7f #01 ADD` returns #80 (127 + 1 = -128)
`#80 #01 SUB` returns #7f (-128 - 1 = 127)
`#80 #80 ADD` returns #00 (-128 + (-128) = 0)
SFT:
The unsigned shift operator treats the sign bit like any other. This means
shifting left will lose the sign bit (reversing the sign) and that shifting
right will convert the sign bit into a value bit.
If you need a sign-aware shift you'll likely want to convert negatives to
positive values, perform a shift, and then restore the sign. Keep in mind
that -128 cannot be converted to a positive value, and may require special
treatment.
Signed numbers will also need their own routines for decimal input and output,
if those are required by your program.
Good luck!

568
math32.tal
View File

@ -20,264 +20,406 @@
( Operations supported: ) ( Operations supported: )
( ) ( )
( NAME STACK EFFECT DEFINITION ) ( NAME STACK EFFECT DEFINITION )
( u32-add x** y** -> z** x + y ) ( add32 x** y** -> z** x + y )
( u32-sub x** y** -> z** x - y ) ( sub32 x** y** -> z** x - y )
( u32-mul x** y** -> z** x * y ) ( mul16 x* y* -> z** x * y )
( u32-mul16 x* y* -> z** x * y ) ( mul32 x** y** -> z** x * y )
( u32-div x** y** -> q** x / y ) ( div32 x** y** -> q** x / y )
( u32-mod x** y** -> r** x % y ) ( mod32 x** y** -> r** x % y )
( u32-divmod x** y** -> q** r** x / y, x % y ) ( divmod32 x** y** -> q** r** x / y, x % y )
( u32-gcd x** y** -> z** gcd[x, y] ) ( gcd32 x** y** -> z** gcd(x, y) )
( u32-negate x** -> z** -x ) ( negate32 x** -> z** -x )
( u32-lshift x** n^ -> z** x<<n ) ( lshift32 x** n^ -> z** x<<n )
( u32-rshift x** n^ -> z** x>>n ) ( rshift32 x** n^ -> z** x>>n )
( u32-and x** y** -> z** x & y ) ( and32 x** y** -> z** x & y )
( u32-or x** y** -> z** x | y ) ( or32 x** y** -> z** x | y )
( u32-xor x** y** -> z** x ^ y ) ( xor32 x** y** -> z** x ^ y )
( u32-complement x** -> z** ~x ) ( complement32 x** -> z** ~x )
( u32-eq x** y** -> bool^ x == y ) ( eq32 x** y** -> bool^ x == y )
( u32-ne x** y** -> bool^ x != y ) ( ne32 x** y** -> bool^ x != y )
( u32-is-zero x** -> bool^ x == 0 ) ( is-zero32 x** -> bool^ x == 0 )
( u32-non-zero x** -> bool^ x != 0 ) ( non-zero32 x** -> bool^ x != 0 )
( u32-lt x** y** -> bool^ x < y ) ( lt32 x** y** -> bool^ x < y )
( u32-gt x** y** -> bool^ x > y ) ( gt32 x** y** -> bool^ x > y )
( u32-lteq x** y** -> bool^ x <= y ) ( lteq32 x** y** -> bool^ x <= y )
( u32-gteq x** y** -> bool^ x >= y ) ( gteq32 x** y** -> bool^ x >= y )
( u8-bitcount x^ -> bool^ floor[log2[x]]+1 ) ( bitcount8 x^ -> bool^ floor(log2(x))+1 )
( u16-bitcount x* -> bool^ floor[log2[x]]+1 ) ( bitcount16 x* -> bool^ floor(log2(x))+1 )
( u32-bitcount x** -> bool^ floor[log2[x]]+1 ) ( bitcount32 x** -> bool^ floor(log2(x))+1 )
( ) ( )
( bitcount: number of bits needed to represent the number. ) ( In addition to the code this file uses 44 bytes of registers )
( this is equivalent to floor[log2[x]] + 1 ) ( to store temporary state: )
( )
( - shared memory, 16 bytes )
( - mul32 memory, 12 bytes )
( - _divmod32 memory, 16 bytes )
@u8-bitcount ( x^ -> n^ ) ( bitcount: number of bits needed to represent number )
LITr 00 &loop DUP ?{ POP STHr JMP2r } #01 SFT INCr !&loop ( equivalent to floor[log2[x]] + 1 )
@u16-bitcount ( x* -> n^ ) @bitcount8 ( x^ -> n^ )
LITr 00 &loop ORAk ?{ POP2 STHr JMP2r } #01 SFT2 INCr !&loop #00 SWP ( n x )
&loop
DUP #00 EQU ( n x x=0 )
,&done JCN ( n x )
#01 SFT ( n x>>1 )
SWP INC SWP ( n+1 x>>1 )
,&loop JMP
&done
POP ( n )
JMP2r
@u32-bitcount ( x** -> n^ ) @bitcount16 ( x* -> n^ )
SWP2 u16-bitcount DUP ?{ POP !u16-bitcount } #10 NIP2 ADD JMP2r SWP ( xlo xhi )
;bitcount8 JSR2 ( xlo nhi )
DUP #00 NEQ ( xlo nhi nhi!=0 )
,&hi-set JCN ( xlo nhi )
SWP ;bitcount8 JSR2 ADD ( nhi+nlo )
JMP2r
&hi-set
NIP #08 ADD ( nhi+8 )
JMP2r
( -- equality ) @bitcount32 ( x** -> n^ )
SWP2 ( xlo* xhi* )
;bitcount16 JSR2 ( xlo* nhi )
DUP #00 NEQ ( xlo* nhi nhi!=0 )
,&hi-set JCN ( xlo* nhi )
ROT ROT ;bitcount16 JSR2 ADD JMP2r ( nhi+nlo )
&hi-set
ROT ROT POP2 #10 ADD ( nhi+16 )
JMP2r
( equality )
( x == y ) ( x == y )
@u32-eq ( xhi* xlo* yhi* ylo* -> bool^ ) @eq32 ( xhi* xlo* yhi* ylo* -> bool^ )
ROT2 EQU2 STH EQU2 STHr AND JMP2r ROT2 EQU2 STH
EQU2 STHr AND JMP2r
( x != y ) ( x != y )
@u32-ne ( xhi* xlo* yhi* ylo* -> bool^ ) @ne32 ( xhi* xlo* yhi* ylo* -> bool^ )
ROT2 NEQ2 STH NEQ2 STHr ORA JMP2r ROT2 NEQ2 STH
NEQ2 STHr ORA JMP2r
( x == 0 ) ( x == 0 )
@u32-is-zero ( x** -> bool^ ) @is-zero32 ( x** -> bool^ )
ORA2 #0000 EQU2 JMP2r ORA2 #0000 EQU2 JMP2r
( x != 0 ) ( x != 0 )
@u32-non-zero ( x** -> bool^ ) @non-zero32 ( x** -> bool^ )
ORA2 ORA JMP2r ORA2 ORA JMP2r
( -- comparisons ) ( comparisons )
( x < y ) ( x < y )
@u32-lt ( x** y** -> bool^ ) @lt32 ( x** y** -> bool^ )
ROT2 SWP2 LTH2 ?{ LTH2 JMP2r } GTH2 #00 EQU JMP2r ROT2 SWP2 ( xhi yhi xlo ylo )
LTH2 ,&lt-lo JCN ( xhi yhi )
LTH2 JMP2r
&lt-lo
GTH2 #00 EQU JMP2r
( x <= y ) ( x <= y )
@u32-lteq ( x** y** -> bool^ ) @lteq32 ( x** y** -> bool^ )
ROT2 SWP2 GTH2 ?{ GTH2 #00 EQU JMP2r } LTH2 JMP2r ROT2 SWP2 ( xhi yhi xlo ylo )
GTH2 ,&gt-lo JCN ( xhi yhi )
GTH2 #00 EQU JMP2r
&gt-lo
LTH2 JMP2r
( x > y ) ( x > y )
@u32-gt ( x** y** -> bool^ ) @gt32 ( x** y** -> bool^ )
ROT2 SWP2 GTH2 ?{ GTH2 JMP2r } LTH2 #00 EQU JMP2r ROT2 SWP2 ( xhi yhi xlo ylo )
GTH2 ,&gt-lo JCN ( xhi yhi )
GTH2 JMP2r
&gt-lo
LTH2 #00 EQU JMP2r
( x > y ) ( x > y )
@u32-gteq ( x** y** -> bool^ ) @gteq32 ( x** y** -> bool^ )
ROT2 SWP2 LTH2 ?{ LTH2 #00 EQU JMP2r } GTH2 JMP2r ROT2 SWP2 ( xhi yhi xlo ylo )
LTH2 ,&lt-lo JCN ( xhi yhi )
LTH2 #00 EQU JMP2r
&lt-lo
GTH2 JMP2r
( -- bitwise operations ) ( bitwise operations )
( x & y ) ( x & y )
@u32-and ( xhi* xlo* yhi* ylo* -> xhi&yhi* xlo&ylo* ) @and32 ( xhi* xlo* yhi* ylo* -> xhi|yhi* xlo|ylo* )
ROT2 AND2 STH2 AND2 STH2r JMP2r ROT2 AND2 STH2 AND2 STH2r JMP2r
( x | y ) ( x | y )
@u32-or ( xhi* xlo* yhi* ylo* -> xhi|yhi* xlo|ylo* ) @or32 ( xhi* xlo* yhi* ylo* -> xhi|yhi* xlo|ylo* )
ROT2 ORA2 STH2 ORA2 STH2r JMP2r ROT2 ORA2 STH2 ORA2 STH2r JMP2r
( x ^ y ) ( x ^ y )
@u32-xor ( xhi* xlo* yhi* ylo* -> xhi^yhi* xlo^ylo* ) @xor32 ( xhi* xlo* yhi* ylo* -> xhi|yhi* xlo|ylo* )
ROT2 EOR2 STH2 EOR2 STH2r JMP2r ROT2 EOR2 STH2 EOR2 STH2r JMP2r
( ~x ) ( ~x )
@u32-complement ( x** -> ~xhi* ~xlo* ) @complement32 ( x** -> ~x** )
SWP2 #ffff EOR2 SWP2 #ffff EOR2 JMP2r SWP2 #ffff EOR2 SWP2 #ffff EOR2 JMP2r
( -- bit-shifting ) ( temporary registers )
( shared by most operations, except mul32 and div32 )
@m32 [ &x0 $1 &x1 $1 &x2 $1 &x3 $1
&y0 $1 &y1 $1 &y2 $1 &y3 $1
&z0 $1 &z1 $1 &z2 $1 &z3 $1
&w0 $1 &w1 $1 &w2 $2 ]
( bit shifting )
( x >> n ) ( x >> n )
@u32-rshift ( x** n^ -> x>>n ) @rshift32 ( x** n^ -> x<<n )
DUP #08 LTH ?u32-shift-0 ( x n ) DUP #08 LTH ;rshift32-0 JCN2 ( x n )
DUP #10 LTH ?u32-rshift-1 ( x n ) DUP #10 LTH ;rshift32-1 JCN2 ( x n )
DUP #18 LTH ?u32-rshift-2 ( x n ) DUP #18 LTH ;rshift32-2 JCN2 ( x n )
!u32-rshift-3 ( x n ) ;rshift32-3 JMP2 ( x n )
( shift by 0-7 bits; used by both lshift and rshift ) ( shift right by 0-7 bits )
@u32-shift-0 ( x** n^ -> x>>n ) @rshift32-0 ( x** n^ -> x<<n )
STH DUP2 STHkr SFT2 ,&z2 STR2 STHk SFT ;m32/z3 STA ( write z3 )
POP DUP2 STHkr SFT2 ,&z2 LDR ORA ,&z2 STR ,&z1 STR #00 STHkr SFT2 #00 ;m32/z3 LDA ORA2 ;m32/z2 STA2 ( write z2,z3 )
POP STHr SFT2 ,&z1 LDR ORA ,&z1 STR #00 STHkr SFT2 #00 ;m32/z2 LDA ORA2 ;m32/z1 STA2 ( write z1,z2 )
LIT [ &z1 $1 ] LIT2 [ &z2 $2 ] JMP2r #00 STHr SFT2 #00 ;m32/z1 LDA ORA2 ( compute z0,z1 )
;m32/z2 LDA2
( shift right by 8-15 bits )
@u32-rshift-1 ( x** n^ -> x>>n )
#08 SUB STH ( stash [n>>8] )
POP DUP2 STHkr SFT2 ,&z2 STR2
POP STHr SFT2 ,&z2 LDR ORA ,&z2 STR
#00 SWP LIT2 [ &z2 $2 ] JMP2r
( shift right by 16-23 bits )
@u32-rshift-2 ( x** n^ -> x>>n )
#10 SUB STH ( stash [n>>16] )
POP2 STHr SFT2 #0000 SWP2 JMP2r
( shift right by 16-23 bits )
@u32-rshift-3 ( x** n^ -> x>>n )
#18 SUB STH ( stash [n>>24] )
POP2 POP STH SWPr SFTr #00 #0000 STHr JMP2r
( x << n )
@u32-lshift ( x** n^ -> x<<n )
DUP #08 LTH ?u32-lshift-0 ( x n )
DUP #10 LTH ?u32-lshift-1 ( x n )
DUP #18 LTH ?u32-lshift-2 ( x n )
!u32-lshift-3 ( x n )
( shift left by 0-7 bits )
@u32-lshift-0 ( x** n^ -> x<<n )
#40 SFT !u32-shift-0
( shift left by 8-15 bits )
@u32-lshift-1 ( x** n^ -> x<<n )
#08 SUB #40 SFT STH ( stash [n-8]<<4 )
DUP2 STHkr SFT2 ,&z1 STR2
POP STHr SFT2 ,&z1 LDR ORA ,&z1 STR
NIP LIT2 [ &z1 $1 &z2 $1 ] #00 JMP2r
( shift left by 16-23 bits )
@u32-lshift-2 ( x** n^ -> x<<n )
#10 SUB #40 SFT STH ( stash [n-16]<<4 )
NIP2 STHr SFT2 #0000 JMP2r
( shift left by 24-31 bits )
@u32-lshift-3 ( x** n^ -> x<<n )
#18 SUB #40 SFT ( stash [n-24]<<4 )
SFT NIP2 NIP #0000 #00 JMP2r
( -- arithmetic )
( x + y )
@u32-add ( xhi* xlo* yhi* ylo* -> zhi* zlo* )
ROT2 STH2k ADD2 STH2k ROT2 ROT2 GTH2r #00 STHr ADD2 ADD2 SWP2 JMP2r
( -x )
@u32-negate ( x** -> -x** )
u32-complement INC2 ORAk ?{ SWP2 INC2 SWP2 } JMP2r
( x - y )
@u32-sub ( x** y** -> z** )
ROT2 STH2k SWP2 SUB2 STH2k ROT2 ROT2 LTH2r #00 STHr ADD2 SUB2 SWP2 JMP2r
( 16-bit multiplication )
@u32-mul16 ( x* y* -> z** )
,&y1 STR ,&y0 STR ( save ylo, yhi )
,&x1 STR ,&x0 STR ( save xlo, xhi )
#0000 ,&z1 STR ,&w0 STR ( reset z1 and w0 )
( x1 * y1 => z1z2 )
LIT2 00 [ &x1 $1 ] LIT2 00 [ &y1 $1 ] MUL2 ,&z3 STR ,&z2 STR
( x0 * y1 => z0z1 )
#00 ,&x0 LDR #00 ,&y1 LDR MUL2 ,&z1 LDR2 ADD2 ,&z1 STR2
( x1 * y0 => w1w2 )
#00 ,&x1 LDR #00 ,&y0 LDR MUL2 ,&w2 STR ,&w1 STR
( x0 * y0 => w0w1 )
LIT2 00 [ &x0 $1 ] LIT2 00 [ &y0 $1 ] MUL2 ,&w0 LDR2 ADD2 ,&w0 STR2
( add z and a<<8 )
#00 LIT2 [ &z1 $1 &z2 $1 ] LIT [ &z3 $1 ]
LIT2 [ &w0 $1 &w1 $1 ] LIT [ &w2 $1 ] #00
!u32-add
( x * y )
@u32-mul ( x** y** -> z** )
ROT2k ( x0* x1* y0* y1* y0* y1* x1* )
u32-mul16 ,&z1 STR2 ,&z0 STR2 POP2 ( x0* x1* y0* y1* ; sum = [x1*y1] )
STH2 ROT2 STH2 ( x1* y0* [y1* x0*] )
MUL2r MUL2 STH2r ADD2 ( x1*y0+y1*x0* )
( [x0*y0]<<32 will completely overflow )
LIT2 [ &z0 $2 ] ADD2 ( sum += [x0*y1+x1*y0]<<16 )
LIT2 [ &z1 $2 ] JMP2r
( x / y )
@u32-div ( x** y** -> q** )
z_u32-divmod ;z_u32-divmod/quo0 LDA2 ;z_u32-divmod/quo1 LDA2 JMP2r
( x % y )
@u32-mod ( x** y** -> r** )
z_u32-divmod ;z_u32-divmod/rem0 LDA2 ;z_u32-divmod/rem1 LDA2 JMP2r
( x / y, x % y )
@u32-divmod ( x** y** -> q** r** )
z_u32-divmod
;z_u32-divmod/quo0 LDA2 ;z_u32-divmod/quo1 LDA2
;z_u32-divmod/rem0 LDA2 ;z_u32-divmod/rem1 LDA2
JMP2r JMP2r
( private: calculate and store x / y and x % y ) ( shift right by 8-15 bits )
@z_u32-divmod ( x** y** -> ) @rshift32-1 ( x** n^ -> x<<n )
( ; store y and x for repeated use ) #08 SUB STH POP
#0000 DUP2 ,&quo0 STR2 ,&quo1 STR2 ( x** y** ; quo<-0 ) STHkr SFT ;m32/z3 STA ( write z3 )
STH2k ,&div1 STR2 STH2k ,&div0 STR2 ( x** [ylo* yhi*] ; div<-y ) #00 STHkr SFT2 #00 ;m32/z3 LDA ORA2 ;m32/z2 STA2 ( write z2,z3 )
OVR2 OVR2 ,&rem1 STR2 ,&rem0 STR2 ( x** [ylo* yhi*] ; rem<-x ) #00 STHr SFT2 #00 ;m32/z2 LDA ORA2 ( compute z1,z2 )
OVR2 OVR2 STH2r STH2r ( x** x** y** ) #00 ROT ROT ;m32/z3 LDA
OVR2 OVR2 STH2 STH2 ( x** x** y** [ylo* yhi*] ) JMP2r
u32-gteq ?{ POP2 POP2 POP2r POP2r JMP2r } ( x** [ylo* yhi*] ; return if x < y )
( ; bitcount[x] - bitcount[y] determines largest multiple of y to try ) ( shift right by 16-23 bits )
u32-bitcount STH2r STH2r u32-bitcount SUB ( shift=rbits-dits^ ) @rshift32-2 ( x** n^ -> x<<n )
#00 DUP2 ( shift^ 0^ shift^ 0^ ) #10 SUB STH POP2
#0000 INC2k ROT2 POP ( shift^ 0^ 0* 1* shift^ ) STHkr SFT ;m32/z3 STA ( write z3 )
u32-lshift ,&cur1 STR2 ,&cur0 STR2 ( shift^ 0^ ; cur<-1<<shift ) #00 STHr SFT2 #00 ;m32/z3 LDA ORA2 ( compute z2,z3 )
,&div0 LDR2 ,&div1 LDR2 ROT2 POP ( div** shift^ ) #0000 SWP2
u32-lshift ,&div1 STR2 ,&div0 STR2 ( ; div<-div<<shift ) JMP2r
( shift right by 16-23 bits )
@rshift32-3 ( x** n^ -> x<<n )
#18 SUB STH POP2 POP ( x0 )
#00 SWP #0000 SWP2 ( 00 00 00 x0 )
STHr SFT
JMP2r
( x << n )
@lshift32 ( x** n^ -> x<<n )
DUP #08 LTH ;lshift32-0 JCN2 ( x n )
DUP #10 LTH ;lshift32-1 JCN2 ( x n )
DUP #18 LTH ;lshift32-2 JCN2 ( x n )
;lshift32-3 JMP2 ( x n )
( shift left by 0-7 bits )
@lshift32-0 ( x** n^ -> x<<n )
#40 SFT STH ( stash n<<4 )
#00 SWP STHkr SFT2 ;m32/z2 STA2 ( store z2,z3 )
#00 SWP STHkr SFT2 #00 ;m32/z2 LDA ORA2 ;m32/z1 STA2 ( store z1,z2 )
#00 SWP STHkr SFT2 #00 ;m32/z1 LDA ORA2 ;m32/z0 STA2 ( store z0,z1 )
STHr SFT ;m32/z0 LDA ORA ( calculate z0 )
;m32/z1 LDA ;m32/z2 LDA2
JMP2r
( shift left by 8-15 bits )
@lshift32-1 ( x** n^ -> x<<n )
#08 SUB #40 SFT STH ( stash [n-8]<<4 )
#00 SWP STHkr SFT2 ;m32/z1 STA2 ( store z1,z2 )
#00 SWP STHkr SFT2 #00 ;m32/z1 LDA ORA2 ;m32/z0 STA2 ( store z0,z1 )
STHr SFT ;m32/z0 LDA ORA ( calculate z0 )
NIP ( x0 unused )
;m32/z1 LDA2 #00
JMP2r
( shift left by 16-23 bits )
@lshift32-2 ( x** n^ -> x<<n )
#10 SUB #40 SFT STH ( stash [n-16]<<4 )
#00 SWP STHkr SFT2 ;m32/z0 STA2 ( store z0,z1 )
STHr SFT ;m32/z0 LDA ORA ( calculate z0 )
STH POP2 STHr
;m32/z1 LDA #0000
JMP2r
( shift left by 24-31 bits )
@lshift32-3 ( x** n^ -> x<<n )
#18 SUB #40 SFT ( x0 x1 x2 x3 r=[n-24]<<4 )
SFT ( x0 x1 x2 x3<<r )
NIP2 NIP #0000 #00
JMP2r
( arithmetic )
( x + y )
@add32 ( xhi* xlo* yhi* ylo* -> zhi* zlo* )
;m32/y2 STA2 ;m32/y0 STA2 ( save ylo, yhi )
;m32/x2 STA2 ;m32/x0 STA2 ( save xlo, xhi )
#0000 DUP2 ;m32/z0 STA2 ;m32/z2 STA2 ( reset zhi, zlo )
( x3 + y3 => z2z3 )
#00 ;m32/x3 LDA #00 ;m32/y3 LDA ADD2 ;m32/z2 STA2
( x2 + y2 + z2 => z1z2 )
#00 ;m32/x2 LDA ;m32/z1 LDA2 ADD2 ;m32/z1 STA2
#00 ;m32/y2 LDA ;m32/z1 LDA2 ADD2 ;m32/z1 STA2
( x1 + y1 + z1 => z0z1 )
#00 ;m32/x1 LDA ;m32/z0 LDA2 ADD2 ;m32/z0 STA2
#00 ;m32/y1 LDA ;m32/z0 LDA2 ADD2 ;m32/z0 STA2
( x0 + y0 + z0 => z0 )
;m32/x0 LDA ;m32/z0 LDA ADD ;m32/z0 STA
;m32/y0 LDA ;m32/z0 LDA ADD ;m32/z0 STA
( load zhi,zlo )
;m32/z0 LDA2 ;m32/z2 LDA2
JMP2r
( -x )
@negate32 ( x** -> -x** )
;complement32 JSR2 ( ~x** )
INC2 ( ~xhi -xlo )
ORAk ( ~xhi -xlo non-zero? )
,&done JCN ( xlo non-zero => don't inc hi )
SWP2 INC2 SWP2 ( -xhi -xlo )
&done
JMP2r
( x - y )
@sub32 ( x** y** -> z** )
;negate32 JSR2 ;add32 JMP2
( 16-bit multiplication )
@mul16 ( x* y* -> z** )
;m32/y1 STA ;m32/y0 STA ( save ylo, yhi )
;m32/x1 STA ;m32/x0 STA ( save xlo, xhi )
#0000 #00 ;m32/z1 STA2 ;m32/z3 STA ( reset z1,z2,z3 )
#0000 #00 ;m32/w0 STA2 ;m32/w2 STA ( reset w0,w1,w2 )
( x1 * y1 => z1z2 )
#00 ;m32/x1 LDA #00 ;m32/y1 LDA MUL2 ;m32/z2 STA2
( x0 * y1 => z0z1 )
#00 ;m32/x0 LDA #00 ;m32/y1 LDA MUL2 ;m32/z1 LDA2 ADD2 ;m32/z1 STA2
( x1 * y0 => w1w2 )
#00 ;m32/x1 LDA #00 ;m32/y0 LDA MUL2 ;m32/w1 STA2
( x0 * y0 => w0w1 )
#00 ;m32/x0 LDA #00 ;m32/y0 LDA MUL2 ;m32/w0 LDA2 ADD2 ;m32/w0 STA2
( add z and a<<8 )
#00 ;m32/z1 LDA2 ;m32/z3 LDA
;m32/w0 LDA2 ;m32/w2 LDA #00
;add32 JMP2
( x * y )
@mul32 ( x** y** -> z** )
,&y1 STR2 ,&y0 STR2 ( save ylo, yhi )
,&x1 STR2 ,&x0 STR2 ( save xlo, xhi )
,&y1 LDR2 ,&x1 LDR2 ;mul16 JSR2 ( [x1*y1] )
,&z1 STR2 ,&z0 STR2 ( sum = x1*y1, save zlo, zhi )
,&y1 LDR2 ,&x0 LDR2 MUL2 ( [x0*y1]<<16 )
,&y0 LDR2 ,&x1 LDR2 MUL2 ( [x1*y0]<<16 )
( [x0*y0]<<32 will completely overflow )
ADD2 ,&z0 LDR2 ADD2 ( sum += x0*y1<<16 + x1*y0<<16 )
,&z1 LDR2
JMP2r
[ &x0 $2 &x1 $2
&y0 $2 &y1 $2
&z0 $2 &z1 $2 ]
@div32 ( x** y** -> q** )
;_divmod32 JSR2
;_divmod32/quo0 LDA2 ;_divmod32/quo1 LDA2
JMP2r
@mod32 ( x** y** -> r** )
;_divmod32 JSR2
;_divmod32/rem0 LDA2 ;_divmod32/rem1 LDA2
JMP2r
@divmod32 ( x** y** -> q** r** )
;_divmod32 JSR2
;_divmod32/quo0 LDA2 ;_divmod32/quo1 LDA2
;_divmod32/rem0 LDA2 ;_divmod32/rem1 LDA2
JMP2r
( calculate and store x / y and x % y )
@_divmod32 ( x** y** -> )
( store y and x for repeated use )
,&div1 STR2 ,&div0 STR2 ( y -> div )
,&rem1 STR2 ,&rem0 STR2 ( x -> rem )
( if x < y then the answer is 0 )
,&rem0 LDR2 ,&rem1 LDR2
,&div0 LDR2 ,&div1 LDR2
;lt32 JSR2 ,&is-zero JCN ,&not-zero JMP
&is-zero
#0000 ,&quo0 STR2 #0000 ,&quo1 STR2 JMP2r
( x >= y so the answer is >= 1 )
&not-zero
#0000 ,&quo0 STR2 #0000 ,&quo1 STR2 ( 0 -> quo )
( bitcount[x] - bitcount[y] determines the largest multiple of y to try )
,&rem0 LDR2 ,&rem1 LDR2 ;bitcount32 JSR2 ( rbits^ )
,&div0 LDR2 ,&div1 LDR2 ;bitcount32 JSR2 ( rbits^ dbits^ )
SUB ( shift=rbits-dits )
#00 DUP2 ( shift 0 shift 0 )
( 1<<shift -> cur )
#0000 INC2k ROT2 POP
;lshift32 JSR2 ,&cur1 STR2 ,&cur0 STR2
( div<<shift -> div )
,&div0 LDR2 ,&div1 LDR2 ROT2 POP
;lshift32 JSR2 ,&div1 STR2 ,&div0 STR2
,&loop JMP
[ &div0 $2 &div1 $2
&rem0 $2 &rem1 $2
&quo0 $2 &quo1 $2
&cur0 $2 &cur1 $2 ]
&loop &loop
( ; if rem >= cur [current divisor], we can subtract it and add to quotient ) ( if rem >= the current divisor, we can subtract it and add to quotient )
( ; otherwise, skip that iteration and reduce cur. ) ,&rem0 LDR2 ,&rem1 LDR2 ,&div0 LDR2 ,&div1 LDR2 ;lt32 JSR2 ( is rem < div? )
LIT2 [ &rem0 $2 ] LIT2 [ &rem1 $2 ] ,&div0 LDR2 ,&div1 LDR2 ,&rem-lt JCN ( if rem < div skip this iteration )
u32-lt ?{
( ; since rem >= div, we have found a multiple of y that divides x ) ( since rem >= div, we have found a multiple of y that divides x )
,&rem0 LDR2 ,&rem1 LDR2 ( rem** ) ,&rem0 LDR2 ,&rem1 LDR2 ,&div0 LDR2 ,&div1 LDR2 ;sub32 JSR2 ,&rem1 STR2 ,&rem0 STR2 ( rem -= div )
LIT2 [ &div0 $2 ] LIT2 [ &div1 $2 ] ( rem** div** ) ,&quo0 LDR2 ,&quo1 LDR2 ,&cur0 LDR2 ,&cur1 LDR2 ;add32 JSR2 ,&quo1 STR2 ,&quo0 STR2 ( quo += cur )
u32-sub ,&rem1 STR2 ,&rem0 STR2 ( ; rem<-rem-div** )
LIT2 [ &quo0 $2 ] LIT2 [ &quo1 $2 ] ( quo** ) &rem-lt
LIT2 [ &cur0 $2 ] LIT2 [ &cur1 $2 ] ( quo** cur** ) ,&div0 LDR2 ,&div1 LDR2 #01 ;rshift32 JSR2 ,&div1 STR2 ,&div0 STR2 ( div >>= 1 )
u32-add ,&quo1 STR2 ,&quo0 STR2 ( ; quo<-quo+cur** ) ,&cur0 LDR2 ,&cur1 LDR2 #01 ;rshift32 JSR2 ,&cur1 STR2 ,&cur0 STR2 ( cur >>= 1 )
} ,&cur0 LDR2 ,&cur1 LDR2 ;non-zero32 JSR2 ,&loop JCN ( if cur>0, loop. else we're done )
,&div0 LDR2 ,&div1 LDR2 #01 u32-rshift ( div>>1** ) JMP2r
,&div1 STR2 ,&div0 STR2 ( ; div<-div>>1 )
,&cur0 LDR2 ,&cur1 LDR2 #01 u32-rshift ( cur>>1** )
OVR2 OVR2 ,&cur1 STR2 ,&cur0 STR2 ( cur>>1** ; cur<-cur>>1 )
u32-non-zero ?&loop JMP2r ( ; loop if cur>0, else we're done )
( greatest common divisor - euclidean algorithm ) ( greatest common divisor - euclidean algorithm )
@u32-gcd ( x** y** -> z** ) @gcd32 ( x** y** -> z** )
&loop OVR2 OVR2 u32-is-zero ?{ ( x** y** ) &loop ( x y )
OVR2 OVR2 STH2 STH2 ( x** y** [y**] ) OVR2 OVR2 ( x y y )
u32-mod ( r=x%y** [y**] ) ;is-zero32 JSR2 ( x y y=0? )
STH2r ROT2 ROT2 ( yhi* rhi* rlo* [ylo*] ) ,&done JCN ( x y )
STH2r ROT2 ROT2 !&loop ( y** r** ) OVR2 OVR2 ( x y y )
} POP2 POP2 JMP2r ( z** ) STH2 STH2 ( x y [y] )
;mod32 JSR2 ( r=x%y [y] )
STH2r ( rhi rlo yhi [ylo] )
ROT2 ( rlo yhi rhi [ylo] )
ROT2 ( yhi rhi rlo [ylo] )
STH2r ( yhi rhi rlo ylo )
ROT2 ( yhi rlo ylo rhi )
ROT2 ( yhi ylo rhi rlo )
,&loop JMP
&done
POP2 POP2 ( x )
JMP2r

6
mksite.sh
View File

@ -1,8 +1,6 @@
#!/bin/sh #!/bin/sh
for STEM in audio audio-v2; do cp audio.md audio.txt
cp $STEM.md $STEM.txt
done
for NAME in about.txt asma.rom math32.tal test-math32.tal test-math32.py \ for NAME in about.txt asma.rom math32.tal test-math32.tal test-math32.py \
primes32.tal regex.tal repl-regex.tal test-regex.tal grep.tal \ primes32.tal regex.tal repl-regex.tal test-regex.tal grep.tal \
@ -17,8 +15,6 @@ for NAME in about.txt asma.rom math32.tal test-math32.tal test-math32.py \
deck.tal cards.tal card-sprites.tal mask-sprites.tal \ deck.tal cards.tal card-sprites.tal mask-sprites.tal \
testing.tal type-abc.tal tar.tal \ testing.tal type-abc.tal tar.tal \
audio.md audio.txt synthdemo.tal \ audio.md audio.txt synthdemo.tal \
audio-v2.md audio-v2.txt \
math-notes.txt \
; do ; do
echo "-> $NAME" echo "-> $NAME"
cp $NAME /var/www/plastic-idolatry.com/html/erik/nxu cp $NAME /var/www/plastic-idolatry.com/html/erik/nxu

296
music.tal
View File

@ -1,296 +0,0 @@
( music.tal )
( )
( this is a simple tracker that can play music correctly using )
( varvara's audio devices. )
( )
( varvara doesn't guarantee that notes started at the "same" )
( time will end at the same time; there is no built-in clock )
( or synchronization, so relying on independent audio callbacks )
( will cause channels to de-sync. )
( )
( the tracker here races the audio callbacks against each other. )
( the first callback at a given time t will trigger all the notes )
( that should happen at time t. it will also update the internal )
( state of all channels to avoid duplicate plays later. )
( )
( to keep it simple there are some simplifying assumptions: )
( )
( 1. the music will loop forever )
( 2. all note durations will be multiples of a single "pulse duration" )
( 3. the tempo/pulse duration won't change during playback )
( 4. the longest note won't be held more than 255x the shortest )
( )
( each track is specified as a sequence of notes; each note is )
( a pitch/count pair. a rest, or silence, uses pitch 00. )
( count must be >= 1. )
( )
( each channel can loop independently; there is no need to keep their )
( lengths in sync with each other. )
( TODO: next-t should be relative, not absolute. )
( requires more book-keeping but makes longer notes possible )
( also makes rescale-time simpler )
|30 @Audio1 [ &vect $2 &pos $2 &out $1 &dur $2 &pad $1 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|40 @Audio2 [ &vect $2 &pos $2 &out $1 &dur $2 &pad $1 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|50 @Audio3 [ &vect $2 &pos $2 &out $1 &dur $2 &pad $1 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|60 @Audio4 [ &vect $2 &pos $2 &out $1 &dur $2 &pad $1 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
( structure layout for channels )
|00 @ch $2 &start $2 &limit $2 &next-t $2
|0000
@dur $2 ( dur: the length of the shortest possible note )
@time $2 ( the current timestamp, in milliseconds )
@events $8 ( timeline: see .ch above )
@ch-1 $8 ( channel 1: see .ch above )
@ch-2 $8 ( channel 2: see .ch above )
@ch-3 $8 ( channel 3: see .ch above )
@ch-4 $8 ( channel 4: see .ch above )
@ch-end ( end of channels )
|0100
#0078 .dur STZ2 ( use 128 ms for 16th notes )
#0000 .time STZ2 ( start at t=0 )
( set up audio callbacks )
;on-audio-1 .Audio1/vect DEO2
;on-audio-2 .Audio2/vect DEO2
;on-audio-3 .Audio3/vect DEO2
;on-audio-4 .Audio4/vect DEO2
( adsr sample slen vol device )
#0231 ;variable #0002 ADD2 #0008 #cc .Audio1 setup-audio
#0231 ;saw #0010 #79 .Audio2 setup-audio
#0231 ;triangle #0004 #75 .Audio3 setup-audio
#011f ;noise #0200 #55 .Audio4 setup-audio
( set up the channel data structures )
;timeline ;track-1 setup-events
;track-1 ;track-2 .ch-1 setup-ch
;track-2 ;track-3 .ch-2 setup-ch
;track-3 ;track-4 .ch-3 setup-ch
;track-4 ;track-end .ch-4 setup-ch
BRK
( play a note and a duration on the given device )
@play-data ( note^ ms* dev^ -> )
STHk #05 ADD DEO2 ( note^ [dev^] ; dev/duration<-ms )
STHr #0f ADD DEO JMP2r ( ; dev/pitch<-note )
( convert pulse count into duration in milliseconds )
@count-to-ms ( count^ -> ms* )
#00 SWP .dur LDZ2 MUL2 JMP2r
( given a channel, find its device )
@ch-to-dev ( ch^ -> dev^ )
.ch-1 SUB #08 DIV #40 SFT #30 ADD JMP2r
( is ch ready to play the next note? )
@ch-is-ready ( ch^ -> bool^ )
.ch/next-t ADD LDZ2 .time LDZ2 EQU2 JMP2r
( increment the channel's position, looping back if needed )
@inc-ch ( ch^ -> )
STHk LDZ2 INC2 INC2 ( pos+2* [ch^] )
STHkr .ch/limit ADD LDZ2 ( pos+2* limit* [ch^] )
OVR2 GTH2 ?&ready ( pos+2* [ch^] ; is limit > pos+2 ? )
POP2 STHkr .ch/start ADD LDZ2 ( start* [ch^] )
&ready STHr STZ2 JMP2r ( ; ch<-inc-pos )
( if ready, play the channel )
@play-ch ( ch^ -> )
STHk ch-is-ready ?{ POPr JMP2r } ( )
STHkr LDZ2 LDA2 count-to-ms ( note^ ms* [ch^] )
DUP2 .time LDZ2 ADD2 ( note^ ms* next* [ch^] )
STHkr .ch/next-t ADD STZ2 ( note^ ms* [ch^] ; ch/next-t<-next )
STHkr ch-to-dev play-data ( [ch^] ; play note)
STHr !inc-ch ( ; increment pos )
@setup-events ( addr* limit* -> )
SWP2 .events STZ2k ( limit* addr* t^ ; t<-addr )
STHk INC INC STZ2 ( limit* addr* [t^] ; t/start<-addr )
STHr .ch/limit ADD STZ2 ( [ch^] ; ch/limit<-limit )
!advance-events
( set up the channel, including playing its first note )
@setup-ch ( addr* limit* ch^ -> )
STH SWP2 STHkr STZ2k ( limit* addr* ch^ [ch^] ; ch<-addr )
INC INC STZ2 ( limit* [ch^] ; ch/start<-addr )
STHkr .ch/limit ADD STZ2 ( [ch^] ; ch/limit<-limit )
STHr !play-ch
( set up the audio parameters )
@setup-audio ( adsr* sample* slen* vol^ dev^ -> )
STHk #0e ORA DEO ( [dev^] ; <-vol )
STHkr #0a ORA DEO2 ( [dev^] ; <-slen )
STHkr #0c ORA DEO2 ( [dev^] ; <-sample )
STHr #08 ORA DEO2 ( ; <-adsr )
JMP2r
@rescale-time ( -> )
.time LDZ2 #0200 GTH2 ?{ JMP2r }
.time adjust-zp-t
.events adjust-ch-next-t
.ch-1 adjust-ch-next-t
.ch-2 adjust-ch-next-t
.ch-3 adjust-ch-next-t
.ch-4 !adjust-ch-next-t
@adjust-ch-next-t ( ch^ -> )
.ch/next-t ADD ( >> )
@adjust-zp-t ( zp^ -> )
LDZ2k #0100 SUB2 ROT STZ2 JMP2r
@change-pulse ( ms* -> )
DUP2 .ch-1 adjust-ch-pulse
DUP2 .ch-2 adjust-ch-pulse
DUP2 .ch-3 adjust-ch-pulse
DUP2 .ch-4 adjust-ch-pulse
.dur STZ2 JMP2r
@adjust-ch-pulse ( ms* ch^ -> )
.ch/next-t ADD STHk LDZ2 ( ms* next-ms* [next-t^] )
.dur LDZ2 DIV2 ( ms* next-p* [next-t^] )
MUL2 STHr STZ2 JMP2r ( )
@on-audio-1 .ch-1 !on-audio
@on-audio-2 .ch-2 !on-audio
@on-audio-3 .ch-3 !on-audio
@on-audio-4 .ch-4 !on-audio
@on-audio ( ch^ -> BRK )
.ch/next-t ADD LDZ2 .time LDZ2 NEQ2k ?&neq
POP2 POP2 BRK
&neq POP2 .time STZ2
rescale-time
advance-events
.ch-1 play-ch
.ch-2 play-ch
.ch-3 play-ch
.ch-4 play-ch
BRK
@inc-events ( -> )
.events ( t^ )
STHk LDZ2 INC2 INC2 INC2 ( pos+3* [t^] )
STHkr .ch/limit ADD LDZ2 ( pos+3* limit* [t^] )
OVR2 GTH2 ?&ready ( pos+3* [t^] ; is limit > pos+2 ? )
POP2 STHkr .ch/start ADD LDZ2 ( start* [ch^] )
&ready STHr STZ2 JMP2r ( ; t<-inc-pos )
@advance-events ( -> )
.events ( t^ )
STHk .ch/next-t ADD LDZ2 .time LDZ2 GTH2 ?&skip ( [t^] ; t/next-t > time? )
STHkr LDZ2 DUP2 LDA2 JSR2 ( addr* [t^] )
INC2 INC2 LDA count-to-ms ( ms* [t^] )
.time LDZ2 ADD2 ( time+ms* [t^] )
STHr .ch/next-t ADD STZ2 ( ; t/next-t<-time+ms )
!inc-events
&skip POPr JMP2r
( this is the actual fun part: the note data for each track )
( @timeline =slowdown 08 )
@timeline =noop 08
( @timeline =vary 08 )
@track-1
2402 2401 2401 2402 2401 2401 2402 2401 2401 2402 2401 2401
2402 2401 2401 2402 2401 2401 2402 2401 2401 2402 2401 2401
2202 2201 2201 2202 2201 2201 2202 2201 2201 2202 2201 2201
2702 2701 2701 2702 2701 2701 2702 2701 2701 2702 2701 2701
@track-2
3c10
370e 3c02
3a10
3f08 4108
@track-3
5b01 4801 4b02 4801 4a01 4b01 4f02 4a01 4b02 4801 4d01 4a01 4b01
@track-4
0104
@track-end
@noop ( -> ) JMP2r
@vary ( -> )
LIT2 [ &addr =variable ] .Audio1/addr DEO2
,&addr LDR2 INC2
DUP2 ;variable/limit LTH2 ?{ POP2 ;variable }
,&addr STR2 JMP2r
@slowdown ( -> )
.dur LDZ2 #0008 ADD2 #010e DEO !change-pulse
@saw ff ee dd cc bb aa 99 88 77 66 55 44 33 22 11 00
@triangle 80 ff 80 00
@square ff ff ff ff ff 00 00 00
@variable ff ff ff ff ff ff ff &limit 00 00 00 00 00 00 00
( 512 random bytes to create noise )
@noise
da 4c 58 30 58 a7 d6 7a fd b1 60 2a 8a de 22 2f
fb 52 8a f3 58 62 37 3b 0a fb 85 2b da 24 d9 a1
88 fa 79 d8 3b 40 0c 58 54 40 14 92 50 44 d2 68
f2 8b b8 50 d1 70 03 74 1e 61 90 96 e6 1a eb b3
09 6b 65 d8 f2 fb af 36 bb b6 9d 90 9b 3e c2 1a
a0 de 1f 20 89 1b 85 53 b9 c9 55 ae f5 c9 4b 0a
5f 11 40 ca 6e b1 b9 35 3e 99 eb 46 6a e0 1a 4f
9a 6e 31 28 cb b2 1f 4a 17 ee 3b 05 4a 6f 6f 56
28 b3 90 07 65 f6 25 ed 4a 43 4b 99 8f 1a 48 19
aa 3c 64 d4 e5 80 c4 c3 ce 52 5f 12 ad 34 78 5c
bb 3a aa 26 d4 ed 0d 81 ee 35 1b c9 17 7f 7c ec
c3 84 2a 0d 1e 9a 74 2c 42 ce 1e 6d 5f e9 7d a5
b2 14 55 5b 57 51 38 1d c2 ad 50 b6 6f 71 b3 a2
7e ae b6 fc 77 7e c6 51 ef ae e7 f5 8f 23 2d 1a
78 b1 fd e3 f4 a6 50 bb 48 91 00 95 2f 8a 3e 64
ab 32 27 03 a1 7a c4 11 30 b1 3e 24 39 b5 22 0f
5f a1 6e 2b 9e e4 43 07 b6 74 c8 f7 17 93 c7 d0
1f 25 e1 80 12 5b c9 10 53 a5 4e 3f 8c 91 c8 c7
51 74 38 99 6c c3 e7 0e 7b 7d 25 bc e7 10 75 d0
b0 ed 33 33 20 fb 4c 5d 1b 23 3b 8a bd ae 31 32
17 0f 38 9b 79 da 8f da af 54 47 8e 68 77 b5 25
47 c9 be 87 3d f1 3d 35 a1 d5 dd 84 ff b8 73 d5
1f 75 e5 b7 2f f3 17 a5 06 39 17 af 4d e5 b8 a1
e7 93 a0 f9 9f 95 b7 f6 d3 b2 04 75 2b 27 f9 86
4b 0a 61 57 77 11 d3 31 91 a9 9e 8f 26 d7 9b fa
7c 36 4e 47 a5 53 ea 86 a6 63 b3 ce 84 03 d1 3c
e6 0b 89 b7 51 dd 33 86 e2 11 6e b8 b4 e0 08 b4
68 8c fe d4 18 d3 ae d4 8e 90 fc 52 f3 8c e9 2c
92 95 44 a9 39 22 20 45 69 fc 30 5e 68 1b 1c b0
cc 76 9e 04 d0 24 7f ea 0a d2 f4 d8 96 98 27 dc
3e 8e 95 5d 78 12 6a 9b b2 f5 f4 a9 52 88 05 8f
38 50 6c f4 bb d9 0f ea f4 de 9d f6 55 fc 99 3a
49 f2 0f 99 e8 f5 3d e9 37 69 fb 92 34 1b 69 46
dd 5b 17 7b 0e 9b 38 9f d7 a3 14 03 ba e7 b0 e1
8a 5a 82 72 ea bf 8e 85 8f d0 06 bc 3b 2b 01 d7
a2 e2 74 ca 28 78 e0 38 59 e2 b8 dc 39 6c a7 f3
3a a1 86 82 4b 1c 78 56 09 14 59 a6 55 39 5e 51
89 07 81 c7 b6 11 d6 26 0b 2f 17 a5 10 af 73 03
6c 68 22 04 32 58 b4 e5 c6 f2 e1 6b 99 d5 bb 4c
2b e1 93 ad 3b 1d 62 e2 f1 6a fa 13 92 3c de 8b
0e 1c 4f 8d ea 20 ba c2 9a 65 b1 b1 29 f0 ce 6f
49 3d 06 f8 18 0b 0d 55 d4 ec 95 d3 fa cb 10 9b
bd 61 d7 3f 07 5b 47 cc bb ae b2 df db f5 20 43
2a 11 54 11 54 05 ff 33 44 0a 1b 92 26 87 f8 58
56 a4 84 2e c4 4f 86 04 b8 d6 bb 0c 82 23 56 8a
d8 77 2f fc 27 30 e2 5f 19 3e ff a5 b8 ca 4e 87
dc b2 e9 6c d8 8f a9 7a be ad 85 6c a2 76 9f 32
e8 d5 b3 de b9 3a ce 23 36 4a de 7a e6 47 40 7c
b3 8c 2c 10 b1 3f c9 81 74 79 0a 4d 5e 73 01 24
ed 17 d3 e8 83 7e 54 bf d9 47 59 f0 0c 60 f7 41
67 52 c2 2a f1 93 c3 ac 00 00 67 87 3a c8 62 d3
33 20 7c 36 d4 88 57 cc fa a5 8a 69 f7 f9 06 7b
56 a6 c9 8f db a0 c0 07 94 0c a2 96 e1 26 7c 49
18 c1 18 4e d1 76 87 e3 43 9a 4b d0 fc cf 11 5e
f8 83 0c 52 05 57 8b 3c 32 84 3b 88 14 75 dc f7
42 ec 6d 5f e9 11 8d 33 76 56 ae 46 f1 99 e9 1d
34 df 4d 7d c6 57 fe 82 fd 9b 97 8e 89 74 ce 5a
fa 85 74 38 b1 3f f5 72 69 87 93 d8 c2 c9 e0 b2
ce e1 de b2 15 f9 21 c4 37 70 1c 4b f4 5e 8c dc
d9 fc f3 13 50 41 b8 8e 90 0b 40 bf a8 57 b8 e8
25 b4 c0 1c 99 96 bd 8b 64 40 6f 42 cd f9 22 f2
9f 80 92 c7 64 73 d9 0d 10 ef 86 c1 9a be aa 12
04 1f 78 e0 20 c4 f1 36 5c cc 7c 3f 53 07 8a 94
fb 97 62 78 fe 6b 3b 3d a1 02 f1 5d e4 ca fe d1

69
primes32.tal
View File

@ -26,15 +26,18 @@
( Smaller primes also run fairly quickly: 0x17b5d was ) ( Smaller primes also run fairly quickly: 0x17b5d was )
( determined to be prime in 0.02 seconds. ) ( determined to be prime in 0.02 seconds. )
%SP { #2018 DEO }
%NL { #0a18 DEO }
%EXIT { #ff0f DEO BRK }
%DUP4 { OVR2 OVR2 } %DUP4 { OVR2 OVR2 }
%POP4 { POP2 POP2 } %POP4 { POP2 POP2 }
|0100 |0100
#ffff #fffb ( n** ; number to check ) ( number to check comes first )
DUP4 is-prime32 ( n** is-prime^ ; test for primality ) #ffff #fffb
STH emit/long #2018 DEO ( [is-prime^] ; emit n ) DUP4 ;is-prime32 JSR2 ( test for primality )
STHr emit/byte #0a18 DEO ( ; emit boolean ) STH ;emit/long JSR2 SP STHr ;emit/byte JSR2 NL
#ff0f DEO BRK ( ; exit ) EXIT
( include 32-bit math library ) ( include 32-bit math library )
~math32.tal ~math32.tal
@ -42,29 +45,37 @@
( return 01 if x is a prime number, else 00 ) ( return 01 if x is a prime number, else 00 )
( works for x >= 2 ) ( works for x >= 2 )
@is-prime32 ( x** -> bool^ ) @is-prime32 ( x** -> bool^ )
DUP4 ,&x1 STR2 ,&x0 STR2 ( x** ; store x ) ,&x1 STR2 ,&x0 STR2 ,&x0 LDR2 ,&x1 LDR2 ( store and reload x )
DUP4 #0000 #0002 ne32 ?{ POP4 #01 JMP2r } ( x** ; return if 2 ) DUP4 #0000 LIT2 &two 0002 ;ne32 JSR2 ( x is 2? )
DUP #01 AND ?{ POP4 #00 JMP2r } ( x** ; return if even ) ,&not-two JCN POP4 #01 JMP2r ( 2 is prime )
DUP4 #0000 #0003 ne32 ?{ POP4 #01 JMP2r } ( x** ; return if 3 ) &not-two DUP #01 AND ( x x&1 )
#0002 ,&inc STR2 ( x** ; inc<-2 ) ,&not-even JCN POP4 #00 JMP2r ( x is even: not prime )
#0000 #0005 DUP4 ,&i1 STR2 ,&i0 STR2 ( x** i** ; i<-5 ) &not-even DUP4 #0000 #0003 ;ne32 JSR2 ( x is 3? )
&loop ( x** i** ) ,&not-three JCN POP4 #01 JMP2r ( 3 is prime )
LIT2 [ &x0 $2 ] LIT2 [ &x1 $2 ] ( x** i** x** ) &not-three #0000 ,&i0 STR2 #0005 ,&i1 STR2 ( x i<-5 )
LIT2 [ &i0 $2 ] LIT2 [ &i1 $2 ] ( x** i** x** i** ) ,&two LDR2 ,&inc STR2
DUP4 mul32 lt32 ( x** i** x<ii^ ) ,&i0 LDR2 ,&i1 LDR2 ( load our candidate, i )
STH DUP2 #ffff EQU2 STHr ORA ( x** i** x<ii|i=0xffff^ ) ,&loop JMP ( jump over register data to loop label )
?{ ( x** i** ) [ &i0 0000 &i1 0000 &x0 0000 &x1 0000 &inc 0000 &mask 0006 ] ( registers )
,&x0 LDR2 ,&x1 LDR2 ,&i0 LDR2 ,&i1 LDR2 ( x** i** x** i** ) &loop ( x i )
mod32 is-zero32 ( x** i** x//i^ ) ,&x0 LDR2 ,&x1 LDR2 ,&i0 LDR2 ,&i1 LDR2 ( x i x i )
STH #0000 ,&inc LDR2 add32 ( x** i+2** [x//i^] ) DUP4 ;mul32 JSR2 ;lt32 JSR2 ( x i x<i*i )
LIT2 [ &inc $2 ] #0006 EOR2 ,&inc STR2 ( x** i+2** [x//i^] ; inc<-inc^6 ) STH DUP2 #ffff EQU2 STHr ORA ( x i x<i*i||i=0xffff )
DUP4 ,&i1 STR2 ,&i0 STR2 STHr ( x** i+2** x//i^ ; i<-i+2 ) ,&finished JCN ( x i )
?{ !&loop } ( x** i+2** ; if x<j*j, loop ) ,&x0 LDR2 ,&x1 LDR2 ,&i0 LDR2 ,&i1 LDR2 ( x i x i )
POP4 POP4 #00 JMP2r ( 0^ ; since i divides x, not prime ) ;mod32 JSR2 ;is-zero32 JSR2 ( x i x//i^ )
} POP4 POP4 #01 JMP2r ( 1^ ; didn't find divisors, prime ) STH #0000 ,&inc LDR2 ;add32 JSR2 ( x i+2 )
,&inc LDR2 ,&mask LDR2 EOR2 ,&inc STR2 ( inc<-inc^6 )
,&i1 STR2 ,&i0 STR2 ,&i0 LDR2 ,&i1 LDR2 ( write i+2 to register )
STHr ( x i+2 x//i^ )
,&i-divides-x JCN ( x j )
,&loop JMP ( if x<j*j, loop )
&i-divides-x POP4 POP4 #00 JMP2r ( since i divides x, not prime )
&finished POP4 POP4 #01 JMP2r ( didn't find divisors, prime )
@emit @emit
&long SWP2 emit/short &long SWP2 ,&short JSR
&short SWP emit/byte &short SWP ,&byte JSR
&byte DUP #04 SFT emit/char &byte DUP #04 SFT ,&char JSR
&char #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO JMP2r &char #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO
JMP2r

408
regex.tal
View File

@ -97,10 +97,10 @@
( using error! will print the given message before causing ) ( using error! will print the given message before causing )
( the interpreter to halt. ) ( the interpreter to halt. )
@errorm ( msg* -> ) @error!! ( msg* -> )
LIT "! emit! space LIT "! emit! space
&loop LDAk #00 EQU ?&done &loop LDAk #00 EQU ,&done JCN
LDAk emit! INC2 !&loop LDAk emit! INC2 ,&loop JMP
&done POP2 newline #ff0e DEO #010f DEO BRK &done POP2 newline #ff0e DEO #010f DEO BRK
( error messages ) ( error messages )
@ -126,34 +126,34 @@
@rx-match ( str* regex* -> bool^ ) @rx-match ( str* regex* -> bool^ )
#01 ;match-multiline STA #01 ;match-multiline STA
#00 ;search-mode STA #00 ;search-mode STA
rx-reset ;rx-reset JSR2
!loop ;loop JMP2
@rx-search-multiline ( str* regex* -> bool^ ) @rx-search-multiline ( str* regex* -> bool^ )
#01 ;match-multiline STA #01 ;match-multiline STA
#01 ;search-mode STA #01 ;search-mode STA
!rx-search/main ,rx-search/main JMP
@rx-search ( str* regex* -> bool^ ) @rx-search ( str* regex* -> bool^ )
#00 ;match-multiline STA #00 ;match-multiline STA
#01 ;search-mode STA #01 ;search-mode STA
&main STH2 ( s* [r*] ) &main STH2 ( s* [r*] )
DUP2 ;string-start STA2 ( s* [r*] ) DUP2 ;string-start STA2 ( s* [r*] )
&loop LDAk #00 EQU ?&eof ( s* [r*] ) &loop LDAk #00 EQU ,&eof JCN ( s* [r*] )
rx-reset ( s* [r*] ) ;rx-reset JSR2 ( s* [r*] )
DUP2 ;search-start STA2 ( s* [r*] ) DUP2 ;search-start STA2 ( s* [r*] )
DUP2 STH2kr loop ( s* b^ [r*] ) DUP2 STH2kr ;loop JSR2 ( s* b^ [r*] )
?&found ( s* [r*] ) ,&found JCN ( s* [r*] )
INC2 !&loop ( s+1* [r*] ) INC2 ,&loop JMP ( s+1* [r*] )
&found POP2 POP2r #01 JMP2r ( 01 ) &found POP2 POP2r #01 JMP2r ( 01 )
&eof rx-reset ( s* [r*] ) &eof ;rx-reset JSR2 ( s* [r*] )
DUP2 ;search-start STA2 ( s* [r*] ) DUP2 ;search-start STA2 ( s* [r*] )
STH2r !loop ( b^ ) STH2r ;loop JMP2 ( b^ )
( reset all "runtime" memory allocated during match/search ) ( reset all "runtime" memory allocated during match/search )
@rx-reset ( -> ) @rx-reset ( -> )
reset-stack ;reset-stack JSR2
!subgroup-reset ;subgroup-reset JMP2
( loop used during matching ) ( loop used during matching )
( ) ( )
@ -163,87 +163,87 @@
( return a boolean, which is where the stack ) ( return a boolean, which is where the stack )
( effects signature comes from. ) ( effects signature comes from. )
@loop ( s* r* -> bool^ ) @loop ( s* r* -> bool^ )
LDAk #01 EQU ?do-empty LDAk #01 EQU ;do-empty JCN2
LDAk #02 EQU ?do-dot LDAk #02 EQU ;do-dot JCN2
LDAk #03 EQU ?do-literal LDAk #03 EQU ;do-literal JCN2
LDAk #04 EQU ?do-or LDAk #04 EQU ;do-or JCN2
LDAk #05 EQU ?do-or ( same code as the or case ) LDAk #05 EQU ;do-or JCN2 ( same code as the or case )
LDAk #06 EQU ?do-caret LDAk #06 EQU ;do-caret JCN2
LDAk #07 EQU ?do-dollar LDAk #07 EQU ;do-dollar JCN2
LDAk #08 EQU ?do-lpar LDAk #08 EQU ;do-lpar JCN2
LDAk #09 EQU ?do-rpar LDAk #09 EQU ;do-rpar JCN2
LDAk #0a EQU ?do-ccls LDAk #0a EQU ;do-ccls JCN2
LDAk #0b EQU ?do-ncls LDAk #0b EQU ;do-ncls JCN2
LDAk #dd ;unknown-node-type errorm LDAk #dd ;unknown-node-type ;error!! JSR2
( used when we hit a dead-end during matching. ) ( used when we hit a dead-end during matching. )
( ) ( )
( if stack is non-empty we have a point we can resume from. ) ( if stack is non-empty we have a point we can resume from. )
@goto-backtrack ( -> bool^ ) @goto-backtrack ( -> bool^ )
stack-exist ?&has-stack ( do we have stack? ) ;stack-exist JSR2 ,&has-stack JCN ( do we have stack? )
#00 JMP2r ( no, return false ) #00 JMP2r ( no, return false )
&has-stack &has-stack
pop4 ;pop4 JSR2
subgroup-backtrack ;subgroup-backtrack JSR2
!goto-next ( yes, resume from the top ) ;goto-next JMP2 ( yes, resume from the top )
( follow the given address (next*) to continue matching ) ( follow the given address (next*) to continue matching )
@goto-next ( str* next* -> bool^ ) @goto-next ( str* next* -> bool^ )
DUP2 #0000 GTH2 ?&has-next DUP2 #0000 GTH2 ,&has-next JCN
POP2 LDAk #00 EQU ?&end-of-string POP2 LDAk #00 EQU ,&end-of-string JCN
;search-mode LDA ?&end-of-search ;search-mode LDA ,&end-of-search JCN
POP2 !goto-backtrack POP2 ;goto-backtrack JMP2
&end-of-search DUP2 ;search-end STA2 &end-of-search DUP2 ;search-end STA2
&end-of-string POP2 #01 JMP2r &end-of-string POP2 #01 JMP2r
&has-next !loop &has-next ;loop JMP2
( handle the empty node -- just follow the next pointer ) ( handle the empty node -- just follow the next pointer )
@do-empty ( str* regex* -> bool^ ) @do-empty ( str* regex* -> bool^ )
INC2 LDA2 ( load next ) INC2 LDA2 ( load next )
!goto-next ( jump to next ) ;goto-next JMP2 ( jump to next )
( FIXME: not currently used ) ( FIXME: not currently used )
@do-lpar ( str* regex* -> bool^ ) @do-lpar ( str* regex* -> bool^ )
STH2 DUP2 ( s s [r] ) STH2 DUP2 ( s s [r] )
INC2r LDA2kr STH2r ( s s i [r+1] ) INC2r LDA2kr STH2r ( s s i [r+1] )
subgroup-start ( s [r+1] ) ;subgroup-start JSR2 ( s [r+1] )
STH2r INC2 INC2 ( s r+3 ) STH2r INC2 INC2 ( s r+3 )
LDA2 !goto-next ( jump to next ) LDA2 ;goto-next JMP2 ( jump to next )
( FIXME: not currently used ) ( FIXME: not currently used )
@do-rpar ( str* regex* -> bool^ ) @do-rpar ( str* regex* -> bool^ )
STH2 DUP2 ( s s [r] ) STH2 DUP2 ( s s [r] )
INC2r LDA2kr STH2r ( s s i [r+1] ) INC2r LDA2kr STH2r ( s s i [r+1] )
subgroup-finish ( s [r+1] ) ;subgroup-finish JSR2 ( s [r+1] )
STH2r INC2 INC2 ( s r+3 ) STH2r INC2 INC2 ( s r+3 )
LDA2 !goto-next ( jump to next ) LDA2 ;goto-next JMP2 ( jump to next )
( handle dot -- match any one character ) ( handle dot -- match any one character )
@do-dot ( str* regex* -> bool^ ) @do-dot ( str* regex* -> bool^ )
INC2 LDA2 STH2 ( load and stash next ) INC2 LDA2 STH2 ( load and stash next )
LDAk #00 NEQ ?&non-empty ( is there a char? ) LDAk #00 NEQ ,&non-empty JCN ( is there a char? )
&backtrack POP2r POP2 !goto-backtrack ( no, clear stacks and backtrack ) &backtrack POP2r POP2 ;goto-backtrack JMP2 ( no, clear stacks and backtrack )
&non-empty LDAk #0a NEQ ?&match ( yes, match unless \n in search-mode ) &non-empty LDAk #0a NEQ ,&match JCN ( yes, match unless \n in search-mode )
;search-mode LDA ?&backtrack ( if \n and search-mode, treat as EOF ) ;search-mode LDA ,&backtrack JCN ( if \n and search-mode, treat as EOF )
&match INC2 STH2r !goto-next ( on match: inc s, restore and jump ) &match INC2 STH2r ;goto-next JMP2 ( on match: inc s, restore and jump )
( hande caret -- match string start (or possibly after newline) without advancing ) ( hande caret -- match string start (or possibly after newline) without advancing )
@do-caret ( str* regex* -> bool^ ) @do-caret ( str* regex* -> bool^ )
INC2 LDA2 STH2 ( load and stash next ) INC2 LDA2 STH2 ( load and stash next )
DUP2 ;string-start LDA2 EQU2 ?&at-start ( at string start? ) DUP2 ;string-start LDA2 EQU2 ,&at-start JCN ( at string start? )
;match-multiline LDA ?&no-match ( are we in multi-line mode? ) ;match-multiline LDA ,&no-match JCN ( are we in multi-line mode? )
DUP2 #0001 SUB2 LDA #0a EQU ?&at-start ( just after newline? ) DUP2 #0001 SUB2 LDA #0a EQU ,&at-start JCN ( just after newline? )
&no-match POP2r POP2 !goto-backtrack ( clear stacks and backtrack ) &no-match POP2r POP2 ;goto-backtrack JMP2 ( clear stacks and backtrack )
&at-start STH2r !goto-next ( go to next without advancing ) &at-start STH2r ;goto-next JMP2 ( go to next without advancing )
( hande dollar -- match string end (or possibly before newline) without advancing ) ( hande dollar -- match string end (or possibly before newline) without advancing )
@do-dollar ( str* regex* -> bool^ ) @do-dollar ( str* regex* -> bool^ )
INC2 LDA2 STH2 ( load and stash next ) INC2 LDA2 STH2 ( load and stash next )
LDAk #00 EQU ?&at-end ( at string end? ) LDAk #00 EQU ,&at-end JCN ( at string end? )
;match-multiline LDA ?&no-match ( are we in multi-line mode? ) ;match-multiline LDA ,&no-match JCN ( are we in multi-line mode? )
LDAk #0a EQU ?&at-end ( at newline? ) LDAk #0a EQU ,&at-end JCN ( at newline? )
&no-match POP2r POP2 !goto-backtrack ( clear stacks and backtrack ) &no-match POP2r POP2 ;goto-backtrack JMP2 ( clear stacks and backtrack )
&at-end STH2r !goto-next ( go to next without advancing ) &at-end STH2r ;goto-next JMP2 ( go to next without advancing )
( handle literal -- match one specific character ) ( handle literal -- match one specific character )
@do-literal ( str* regex* -> bool^ ) @do-literal ( str* regex* -> bool^ )
@ -251,23 +251,23 @@
LDAk STH ( store c ) LDAk STH ( store c )
INC2 LDA2 STH2 ROTr ( store next, move c to top ) INC2 LDA2 STH2 ROTr ( store next, move c to top )
LDAk LDAk
STHr EQU ?&matches ( do we match this char? ) STHr EQU ,&matches JCN ( do we match this char? )
POP2r POP2 !goto-backtrack ( no, clear stacks and backtrack ) POP2r POP2 ;goto-backtrack JMP2 ( no, clear stacks and backtrack )
&matches &matches
INC2 STH2r !goto-next ( yes, inc s, restore and jump ) INC2 STH2r ;goto-next JMP2 ( yes, inc s, restore and jump )
( handle or -- try the left branch but backtrack to the right if needed ) ( handle or -- try the left branch but backtrack to the right if needed )
( ) ( )
( this also handles asteration, since it ends up having the same structure ) ( this also handles asteration, since it ends up having the same structure )
@do-or ( str* regex* -> bool^ ) @do-or ( str* regex* -> bool^ )
INC2 OVR2 OVR2 #0002 ADD2 ( s r+1 s r+3 ) INC2 OVR2 OVR2 #0002 ADD2 ( s r+1 s r+3 )
LDA2 push4 ( save (s, right) in the stack for possible backtracking ) LDA2 ;push4 JSR2 ( save (s, right) in the stack for possible backtracking )
LDA2 !loop ( continue on left branch ) LDA2 ;loop JMP2 ( continue on left branch )
@matches-cls ( str* regex* -> bool^ ) @matches-cls ( str* regex* -> bool^ )
OVR2 LDA ?&not-null OVR2 LDA ,&not-null JCN
( needs to have a character to match ) ( needs to have a character to match )
POP2 POP2 !goto-backtrack POP2 POP2 ;goto-backtrack JMP2
&not-null &not-null
DUP2 INC2 LDA2 STH2 ( str regex [next] ) DUP2 INC2 LDA2 STH2 ( str regex [next] )
OVR2 INC2 STH2 ( str regex [str+1 next] ) OVR2 INC2 STH2 ( str regex [str+1 next] )
@ -275,24 +275,24 @@
#0003 ADD2 LDAk #00 SWP #0002 MUL2 ( r+3 len*2 [c str+1 next] ) #0003 ADD2 LDAk #00 SWP #0002 MUL2 ( r+3 len*2 [c str+1 next] )
SWP2 INC2 STH2k ADD2 STH2r ( r+4+len*2 r+4 [c str+1 next] ) SWP2 INC2 STH2k ADD2 STH2r ( r+4+len*2 r+4 [c str+1 next] )
&loop ( limit addr [c str+1 next] ) &loop ( limit addr [c str+1 next] )
EQU2k ?&missing EQU2k ,&missing JCN
LDAk STHkr GTH ?&next1 INC2 LDAk STHkr GTH ,&next1 JCN INC2
LDAk STHkr LTH ?&next2 !&found LDAk STHkr LTH ,&next2 JCN ,&found JMP
&next1 INC2 &next1 INC2
&next2 INC2 !&loop &next2 INC2 ,&loop JMP
&missing POP2 POP2 POPr ,&negated LDR ?&match &missing POP2 POP2 POPr ,&negated LDR ,&match JCN
&no-match POP2r POP2r !goto-backtrack &no-match POP2r POP2r ;goto-backtrack JMP2
&found POP2 POP2 POPr ,&negated LDR ?&no-match &found POP2 POP2 POPr ,&negated LDR ,&no-match JCN
&match STH2r STH2r !goto-next &match STH2r STH2r ;goto-next JMP2
[ &negated $1 ] [ &negated $1 ]
( ) ( )
@do-ccls ( str* regex* -> bool^ ) @do-ccls ( str* regex* -> bool^ )
#00 ,matches-cls/negated STR !matches-cls #00 ,matches-cls/negated STR ,matches-cls JMP
( ) ( )
@do-ncls ( str* regex* -> bool^ ) @do-ncls ( str* regex* -> bool^ )
#01 ,matches-cls/negated STR !matches-cls #01 ,matches-cls/negated STR ,matches-cls JMP
( REGEX PARSING ) ( REGEX PARSING )
@ -325,9 +325,9 @@
@read ( -> c^ ) @read ( -> c^ )
;pos LDA2k ( pos s ) ;pos LDA2k ( pos s )
LDAk STHk #00 EQU ( pos s c=0 [c] ) LDAk STHk #00 EQU ( pos s c=0 [c] )
?&is-eof ( pos s [c] ) ,&is-eof JCN ( pos s [c] )
INC2 ( pos s+1 [c] ) INC2 ( pos s+1 [c] )
SWP2 STA2 !&return ( [c] ) SWP2 STA2 ,&return JMP ( [c] )
&is-eof POP2 POP2 &is-eof POP2 POP2
&return STHr ( c ) &return STHr ( c )
JMP2r JMP2r
@ -370,8 +370,8 @@
@compile ( expr* -> regex* ) @compile ( expr* -> regex* )
;pos STA2 ;pos STA2
#0000 ;parens STA2 #0000 ;parens STA2
rx-reset ;rx-reset JSR2
!compile-region ;compile-region JMP2
( the basic strategy here is to build a stack of non-or ) ( the basic strategy here is to build a stack of non-or )
( expressions to be joined together at the end of the ) ( expressions to be joined together at the end of the )
@ -385,24 +385,24 @@
( by #ffff #ffff. above that we start with #0000 #0000 ) ( by #ffff #ffff. above that we start with #0000 #0000 )
( to signal an empty node. ) ( to signal an empty node. )
@compile-region ( -> r2* ) @compile-region ( -> r2* )
#ffff #ffff push4 ( stack delimiter ) #ffff #ffff ;push4 JSR2 ( stack delimiter )
#0000 #0000 push4 ( stack frame start ) #0000 #0000 ;push4 JSR2 ( stack frame start )
@compile-region-loop @compile-region-loop
read ;read JSR2
DUP #00 EQU ?c-done DUP #00 EQU ;c-done JCN2
DUP LIT "| EQU ?c-or DUP LIT "| EQU ;c-or JCN2
DUP LIT ". EQU ?c-dot DUP LIT ". EQU ;c-dot JCN2
DUP LIT "^ EQU ?c-caret DUP LIT "^ EQU ;c-caret JCN2
DUP LIT "$ EQU ?c-dollar DUP LIT "$ EQU ;c-dollar JCN2
DUP LIT "( EQU ?c-lpar DUP LIT "( EQU ;c-lpar JCN2
DUP LIT ") EQU ?c-rpar DUP LIT ") EQU ;c-rpar JCN2
DUP LIT "[ EQU ?c-lbrk DUP LIT "[ EQU ;c-lbrk JCN2
DUP LIT "] EQU ?c-rbrk DUP LIT "] EQU ;c-rbrk JCN2
DUP LIT "\ EQU ?c-esc DUP LIT "\ EQU ;c-esc JCN2
DUP LIT "* EQU ?c-star DUP LIT "* EQU ;c-star JCN2
DUP LIT "+ EQU ?c-plus DUP LIT "+ EQU ;c-plus JCN2
DUP LIT "? EQU ?c-qmark DUP LIT "? EQU ;c-qmark JCN2
!c-char ;c-char JMP2
( either finalize the given r0/r1 or else wrap it in ) ( either finalize the given r0/r1 or else wrap it in )
( a star node if a star is coming up next. ) ( a star node if a star is coming up next. )
@ -410,14 +410,14 @@
( we use this look-ahead approach rather than compiling ) ( we use this look-ahead approach rather than compiling )
( star nodes directly since the implementation is simpler. ) ( star nodes directly since the implementation is simpler. )
@c-peek-and-finalize ( r0* r1* -> r2* ) @c-peek-and-finalize ( r0* r1* -> r2* )
peek-to-star ( r0 r1 next-is-star? ) ?&next-is-star ;peek-to-star JSR2 ( r0 r1 next-is-star? ) ,&next-is-star JCN
peek-to-plus ( r0 r1 next-is-plus? ) ?&next-is-plus ;peek-to-plus JSR2 ( r0 r1 next-is-plus? ) ,&next-is-plus JCN
peek-to-qmark ( r0 r1 next-is-qmark? ) ?&next-is-qmark ;peek-to-qmark JSR2 ( r0 r1 next-is-qmark? ) ,&next-is-qmark JCN
!&finally ( r0 r1 ) ,&finally JMP ( r0 r1 )
&next-is-star skip POP2 alloc-star DUP2 !&finally &next-is-star ;skip JSR2 POP2 ;alloc-star JSR2 DUP2 ,&finally JMP
&next-is-plus skip POP2 alloc-plus DUP2 !&finally &next-is-plus ;skip JSR2 POP2 ;alloc-plus JSR2 DUP2 ,&finally JMP
&next-is-qmark skip POP2 alloc-qmark DUP2 !&finally &next-is-qmark ;skip JSR2 POP2 ;alloc-qmark JSR2 DUP2 ,&finally JMP
&finally push-next !compile-region-loop &finally ;push-next JSR2 ;compile-region-loop JMP2
( called when we reach EOF of the input string ) ( called when we reach EOF of the input string )
( ) ( )
@ -427,9 +427,9 @@
( this is where we detect unclosed parenthesis. ) ( this is where we detect unclosed parenthesis. )
@c-done ( c^ -> r2* ) @c-done ( c^ -> r2* )
POP POP
;parens LDA2 #0000 GTH2 ?&mismatched-parens ;parens LDA2 #0000 GTH2 ,&mismatched-parens JCN
unroll-stack POP2 JMP2r ;unroll-stack JSR2 POP2 JMP2r
&mismatched-parens ;mismatched-parens errorm &mismatched-parens ;mismatched-parens ;error!! JSR2
( called when we read "|" ) ( called when we read "|" )
( ) ( )
@ -437,8 +437,8 @@
( we just start a new stack frame and continue. ) ( we just start a new stack frame and continue. )
@c-or ( c^ -> r2* ) @c-or ( c^ -> r2* )
POP POP
#0000 #0000 push4 #0000 #0000 ;push4 JSR2
!compile-region-loop ;compile-region-loop JMP2
( called when we read left parenthesis ) ( called when we read left parenthesis )
( ) ( )
@ -450,7 +450,7 @@
@c-lpar ( c^ -> r2* ) @c-lpar ( c^ -> r2* )
POP POP
;parens LDA2 INC2 ;parens STA2 ( parens++ ) ;parens LDA2 INC2 ;parens STA2 ( parens++ )
!compile-region ;compile-region JMP2
( called when we read right parenthesis ) ( called when we read right parenthesis )
( ) ( )
@ -463,34 +463,34 @@
( 5. continue parsing ) ( 5. continue parsing )
@c-rpar ( c^ -> r2* ) @c-rpar ( c^ -> r2* )
POP POP
;parens LDA2 #0000 EQU2 ?&mismatched-parens ;parens LDA2 #0000 EQU2 ,&mismatched-parens JCN
;parens LDA2 #0001 SUB2 ;parens STA2 ( parens-- ) ;parens LDA2 #0001 SUB2 ;parens STA2 ( parens-- )
unroll-stack ;unroll-stack JSR2
!c-peek-and-finalize ;c-peek-and-finalize JMP2
&mismatched-parens ;mismatched-parens errorm &mismatched-parens ;mismatched-parens ;error!! JSR2
( doesn't support weird things like []abc] or [-abc] or similar. ) ( doesn't support weird things like []abc] or [-abc] or similar. )
( doesn't currently handle "special" escapes such as \n ) ( doesn't currently handle "special" escapes such as \n )
@c-lbrk ( c^ -> r2* ) @c-lbrk ( c^ -> r2* )
POP LITr 00 ;pos LDA2 ( pos [0] ) POP LITr 00 ;pos LDA2 ( pos [0] )
LDAk LIT "^ NEQ ?&normal INCr INC2 ( pos [negated?^] ) LDAk LIT "^ NEQ ,&normal JCN INCr INC2 ( pos [negated?^] )
&normal &normal
#0a STHr ADD ( src* type^ ) #0a STHr ADD ( src* type^ )
;arena-pos LDA2 STH2k ( src* type^ dst* [dst*] ) ;arena-pos LDA2 STH2k ( src* type^ dst* [dst*] )
STA LIT2r 0004 ADD2r ( src* [dst+4] ) STA LIT2r 0004 ADD2r ( src* [dst+4] )
&left-parse ( src* [dst*] ) &left-parse ( src* [dst*] )
LDAk LIT "] EQU ?&done LDAk LIT "] EQU ,&done JCN
LDAk LIT "- EQU ?&error LDAk LIT "- EQU ,&error JCN
LDAk LIT "\ NEQ ?&left INC2 LDAk LIT "\ NEQ ,&left JCN INC2
&left &left
LDAk STH2kr STA INC2r LDAk STH2kr STA INC2r
DUP2 INC2 LDA LIT "- NEQ ?&pre-right INC2 INC2 DUP2 INC2 LDA LIT "- NEQ ,&pre-right JCN INC2 INC2
LDAk LIT "] EQU ?&error LDAk LIT "] EQU ,&error JCN
LDAk LIT "- EQU ?&error LDAk LIT "- EQU ,&error JCN
&pre-right &pre-right
LDAk LIT "\ NEQ ?&right INC2 LDAk LIT "\ NEQ ,&right JCN INC2
&right &right
LDAk STH2kr STA INC2 INC2r !&left-parse LDAk STH2kr STA INC2 INC2r ,&left-parse JMP
&done ( src* [dst*] ) &done ( src* [dst*] )
INC2 ;pos STA2 STH2r ( dst* ) INC2 ;pos STA2 STH2r ( dst* )
DUP2 ;arena-pos LDA2 ( dst dst a ) DUP2 ;arena-pos LDA2 ( dst dst a )
@ -498,7 +498,7 @@
;arena-pos LDA2 STH2k #0003 ADD2 STA ( dst [a] ) ;arena-pos LDA2 STH2k #0003 ADD2 STA ( dst [a] )
;arena-pos STA2 STH2r ( a ) ;arena-pos STA2 STH2r ( a )
#0000 OVR2 INC2 STA2 ( a ) #0000 OVR2 INC2 STA2 ( a )
DUP2 !c-peek-and-finalize DUP2 ;c-peek-and-finalize JMP2
&error &error
#abcd #0000 DIV ( TODO error here ) #abcd #0000 DIV ( TODO error here )
@ -511,24 +511,24 @@
( allocates a dot-node and continues. ) ( allocates a dot-node and continues. )
@c-dot ( c^ -> r2* ) @c-dot ( c^ -> r2* )
POP POP
#02 alloc3 #02 ;alloc3 JSR2
DUP2 !c-peek-and-finalize DUP2 ;c-peek-and-finalize JMP2
( called when we read "^" ) ( called when we read "^" )
( ) ( )
( allocates a caret-node and continues. ) ( allocates a caret-node and continues. )
@c-caret ( c^ -> r2* ) @c-caret ( c^ -> r2* )
POP POP
#06 alloc3 #06 ;alloc3 JSR2
DUP2 !c-peek-and-finalize DUP2 ;c-peek-and-finalize JMP2
( called when we read "$" ) ( called when we read "$" )
( ) ( )
( allocates a dollar-node and continues. ) ( allocates a dollar-node and continues. )
@c-dollar ( c^ -> r2* ) @c-dollar ( c^ -> r2* )
POP POP
#07 alloc3 #07 ;alloc3 JSR2
DUP2 !c-peek-and-finalize DUP2 ;c-peek-and-finalize JMP2
( called when we read "\" ) ( called when we read "\" )
( ) ( )
@ -536,50 +536,50 @@
( ) ( )
( otherwise, allocates a literal of the next character. ) ( otherwise, allocates a literal of the next character. )
@c-esc ( c^ -> r2* ) @c-esc ( c^ -> r2* )
POP read POP ;read JSR2
DUP LIT "a EQU ?&bel DUP LIT "a EQU ,&bel JCN
DUP LIT "b EQU ?&bs DUP LIT "b EQU ,&bs JCN
DUP LIT "t EQU ?&tab DUP LIT "t EQU ,&tab JCN
DUP LIT "n EQU ?&nl DUP LIT "n EQU ,&nl JCN
DUP LIT "v EQU ?&vtab DUP LIT "v EQU ,&vtab JCN
DUP LIT "f EQU ?&ff DUP LIT "f EQU ,&ff JCN
DUP LIT "r EQU ?&cr DUP LIT "r EQU ,&cr JCN
&default !c-char &default ;c-char JMP2
&bel POP #07 !&default &bel POP #07 ,&default JMP
&bs POP #08 !&default &bs POP #08 ,&default JMP
&tab POP #09 !&default &tab POP #09 ,&default JMP
&nl POP #0a !&default &nl POP #0a ,&default JMP
&vtab POP #0b !&default &vtab POP #0b ,&default JMP
&ff POP #0c !&default &ff POP #0c ,&default JMP
&cr POP #0d !&default &cr POP #0d ,&default JMP
( called when we read any other character ) ( called when we read any other character )
( ) ( )
( allocates a literal-node and continues. ) ( allocates a literal-node and continues. )
@c-char ( c^ -> r2* ) @c-char ( c^ -> r2* )
alloc-lit ( lit ) ;alloc-lit JSR2 ( lit )
DUP2 !c-peek-and-finalize DUP2 ;c-peek-and-finalize JMP2
( called if we parse a "*" ) ( called if we parse a "*" )
( ) ( )
( actually calling this means the code broke an invariant somewhere. ) ( actually calling this means the code broke an invariant somewhere. )
@c-star ( c^ -> regex* ) @c-star ( c^ -> regex* )
POP POP
;star-invariant errorm ;star-invariant ;error!! JSR2
( called if we parse a "+" ) ( called if we parse a "+" )
( ) ( )
( actually calling this means the code broke an invariant somewhere. ) ( actually calling this means the code broke an invariant somewhere. )
@c-plus ( c^ -> regex* ) @c-plus ( c^ -> regex* )
POP POP
;plus-invariant errorm ;plus-invariant ;error!! JSR2
( called if we parse a "?" ) ( called if we parse a "?" )
( ) ( )
( actually calling this means the code broke an invariant somewhere. ) ( actually calling this means the code broke an invariant somewhere. )
@c-qmark ( c^ -> regex* ) @c-qmark ( c^ -> regex* )
POP POP
;qmark-invariant errorm ;qmark-invariant ;error!! JSR2
( ALLOCATING REGEX NDOES ) ( ALLOCATING REGEX NDOES )
@ -589,51 +589,51 @@
@alloc3 ( mode^ -> r* ) @alloc3 ( mode^ -> r* )
#0000 ROT ( 00 00 mode^ ) #0000 ROT ( 00 00 mode^ )
#03 alloc ( 00 00 mode^ addr* ) #03 ;alloc JSR2 ( 00 00 mode^ addr* )
STH2k STA ( addr <- mode ) STH2k STA ( addr <- mode )
STH2kr INC2 STA2 ( addr+1 <- 0000 ) STH2kr INC2 STA2 ( addr+1 <- 0000 )
STH2r JMP2r ( return addr ) STH2r JMP2r ( return addr )
@alloc-empty ( -> r* ) @alloc-empty ( -> r* )
#01 !alloc3 #01 ;alloc3 JMP2
@alloc-lit ( c^ -> r* ) @alloc-lit ( c^ -> r* )
#03 #0000 SWP2 ( 0000 c^ 03 ) #03 #0000 SWP2 ( 0000 c^ 03 )
#04 alloc ( 0000 c^ 03 addr* ) #04 ;alloc JSR2 ( 0000 c^ 03 addr* )
STH2k STA ( addr <- 03 ) STH2k STA ( addr <- 03 )
STH2kr INC2 STA ( addr+1 <- c ) STH2kr INC2 STA ( addr+1 <- c )
STH2kr #0002 ADD2 STA2 ( addr+2 <- 0000 ) STH2kr #0002 ADD2 STA2 ( addr+2 <- 0000 )
STH2r JMP2r ( return addr ) STH2r JMP2r ( return addr )
@alloc-or ( right* left* -> r* ) @alloc-or ( right* left* -> r* )
#05 alloc STH2 ( r l [x] ) #05 ;alloc JSR2 STH2 ( r l [x] )
#04 STH2kr STA ( r l [x] ) #04 STH2kr STA ( r l [x] )
STH2kr INC2 STA2 ( r [x] ) STH2kr INC2 STA2 ( r [x] )
STH2kr #0003 ADD2 STA2 ( [x] ) STH2kr #0003 ADD2 STA2 ( [x] )
STH2r JMP2r STH2r JMP2r
@alloc-star ( expr* -> r* ) @alloc-star ( expr* -> r* )
#05 alloc STH2 ( expr [r] ) #05 ;alloc JSR2 STH2 ( expr [r] )
#05 STH2kr STA ( expr [r] ) #05 STH2kr STA ( expr [r] )
DUP2 STH2kr INC2 STA2 ( expr [r] ) DUP2 STH2kr INC2 STA2 ( expr [r] )
#0000 STH2kr #0003 ADD2 STA2 ( expr [r] ) #0000 STH2kr #0003 ADD2 STA2 ( expr [r] )
STH2kr SWP2 ( r expr [r] ) STH2kr SWP2 ( r expr [r] )
set-next ( [r] ) ;set-next JSR2 ( [r] )
STH2r JMP2r STH2r JMP2r
@alloc-plus ( expr* -> r* ) @alloc-plus ( expr* -> r* )
#05 alloc STH2 ( expr [r] ) #05 ;alloc JSR2 STH2 ( expr [r] )
#05 STH2kr STA ( expr [r] ) #05 STH2kr STA ( expr [r] )
DUP2 STH2kr INC2 STA2 ( expr [r] ) DUP2 STH2kr INC2 STA2 ( expr [r] )
#0000 STH2kr #0003 ADD2 STA2 ( expr [r] ) #0000 STH2kr #0003 ADD2 STA2 ( expr [r] )
STH2r SWP2 STH2k ( r expr [expr] ) STH2r SWP2 STH2k ( r expr [expr] )
set-next ( [expr] ) ;set-next JSR2 ( [expr] )
STH2r JMP2r STH2r JMP2r
@alloc-qmark ( expr* -> r* ) @alloc-qmark ( expr* -> r* )
alloc-empty STH2k ( expr e [e] ) ;alloc-empty JSR2 STH2k ( expr e [e] )
OVR2 set-next ( expr [e] ) OVR2 ;set-next JSR2 ( expr [e] )
#05 alloc STH2 ( expr [r e] ) #05 ;alloc JSR2 STH2 ( expr [r e] )
#04 STH2kr STA ( expr [r e] ) #04 STH2kr STA ( expr [r e] )
STH2kr INC2 STA2 ( [r e] ) STH2kr INC2 STA2 ( [r e] )
SWP2r STH2r STH2kr ( e r [r] ) SWP2r STH2r STH2kr ( e r [r] )
@ -642,7 +642,7 @@
( if r is 0000, allocate an empty node ) ( if r is 0000, allocate an empty node )
@alloc-if-null ( r* -> r2* ) @alloc-if-null ( r* -> r2* )
ORAk ?&return POP2 alloc-empty &return JMP2r ORAk ,&return JCN POP2 ;alloc-empty JSR2 &return JMP2r
( unroll one region of the parsing stack, returning ) ( unroll one region of the parsing stack, returning )
( a single node consisting of an alternation of ) ( a single node consisting of an alternation of )
@ -651,23 +651,23 @@
( this unrolls until it hits #ffff #ffff, which it ) ( this unrolls until it hits #ffff #ffff, which it )
( also removes from the stack. ) ( also removes from the stack. )
@unroll-stack ( -> start* end* ) @unroll-stack ( -> start* end* )
pop4 STH2 ( r ) ;pop4 JSR2 STH2 ( r )
#00 STH ( count items in stack frame ) #00 STH ( count items in stack frame )
alloc-if-null ( replace 0000 with empty ) ;alloc-if-null JSR2 ( replace 0000 with empty )
&loop ( r* ) &loop ( r* )
pop4 POP2 ( r x ) ;pop4 JSR2 POP2 ( r x )
DUP2 #ffff EQU2 ( r x x-is-end? ) ?&done DUP2 #ffff EQU2 ( r x x-is-end? ) ,&done JCN
INCr ( items++ ) INCr ( items++ )
alloc-or ( r|x ) !&loop ;alloc-or JSR2 ( r|x ) ,&loop JMP
&done &done
( r ffff ) ( r ffff )
POP2 POP2
STHr ?&is-or STHr ,&is-or JCN
STH2r JMP2r STH2r JMP2r
&is-or &is-or
POP2r POP2r
alloc-empty OVR2 OVR2 SWP2 ( r empty empty r ) ;alloc-empty JSR2 OVR2 OVR2 SWP2 ( r empty empty r )
set-next-or ;set-next-or JSR2
JMP2r JMP2r
( add r to the top of the stock. ) ( add r to the top of the stock. )
@ -675,21 +675,21 @@
( in particular, this will write r into tail.next ) ( in particular, this will write r into tail.next )
( before replacing tail with r. ) ( before replacing tail with r. )
@push-next ( r0 r1 -> ) @push-next ( r0 r1 -> )
pop4 ( r0 r1 x0 x1 ) ;pop4 JSR2 ( r0 r1 x0 x1 )
DUP2 #0000 EQU2 ( r0 r1 x0 x1 x1=0? ) ?&is-zero DUP2 #0000 EQU2 ( r0 r1 x0 x1 x1=0? ) ,&is-zero JCN
STH2 ROT2 STH2r ( r1 x0 r0 x1 ) STH2 ROT2 STH2r ( r1 x0 r0 x1 )
set-next SWP2 ( x0 r1 ) ;set-next JSR2 SWP2 ( x0 r1 )
push4 ;push4 JSR2
JMP2r JMP2r
&is-zero POP2 POP2 !push4 &is-zero POP2 POP2 ;push4 JMP2
( load the given address: ) ( load the given address: )
( ) ( )
( 1. if it points to 0000, update it to target ) ( 1. if it points to 0000, update it to target )
( 2. otherwise, call set-next on it ) ( 2. otherwise, call set-next on it )
@set-next-addr ( target* addr* -> ) @set-next-addr ( target* addr* -> )
LDA2k #0000 EQU2 ( target addr addr=0? ) ?&is-zero LDA2k #0000 EQU2 ( target addr addr=0? ) ,&is-zero JCN
LDA2 !set-next LDA2 ;set-next JMP2
&is-zero STA2 JMP2r &is-zero STA2 JMP2r
( set regex.next to target ) ( set regex.next to target )
@ -703,18 +703,18 @@
( back up we only bother taking the left branch. otherwise ) ( back up we only bother taking the left branch. otherwise )
( you can end up double-appending things. ) ( you can end up double-appending things. )
@set-next ( target* regex* -> ) @set-next ( target* regex* -> )
LDAk #01 LTH ?&unknown LDAk #01 LTH ,&unknown JCN
LDAk #0b GTH ?&unknown LDAk #0b GTH ,&unknown JCN
LDAk #09 GTH ?&cc LDAk #09 GTH ,&cc JCN
LDAk #00 SWP ;rx-node-sizes ADD2 LDAk #00 SWP ;rx-node-sizes ADD2
LDA #00 SWP ADD2 #0002 SUB2 LDA #00 SWP ADD2 #0002 SUB2
!set-next-addr ;set-next-addr JMP2
&cc INC2 !set-next-addr &cc INC2 ;set-next-addr JMP2
&unknown LDAk #ee ;unknown-node-type errorm &unknown LDAk #ee ;unknown-node-type ;error!! JSR2
@set-next-or-addr ( target* addr* -> ) @set-next-or-addr ( target* addr* -> )
LDA2k #0000 EQU2 ( target addr addr=0? ) ?&is-zero LDA2k #0000 EQU2 ( target addr addr=0? ) ,&is-zero JCN
LDA2 !set-next-or LDA2 ;set-next-or JMP2
&is-zero STA2 JMP2r &is-zero STA2 JMP2r
( this is used when first building or-nodes ) ( this is used when first building or-nodes )
@ -722,10 +722,10 @@
( [x1, [x2, [x3, ..., [xm, xn]]]] ) ( [x1, [x2, [x3, ..., [xm, xn]]]] )
( so we recurse on the right side but not the left. ) ( so we recurse on the right side but not the left. )
@set-next-or ( target* regex* -> ) @set-next-or ( target* regex* -> )
LDAk #04 NEQ ?&!4 LDAk #04 NEQ ,&!4 JCN
OVR2 OVR2 INC2 set-next-addr OVR2 OVR2 INC2 ;set-next-addr JSR2
#0003 ADD2 !set-next-or-addr #0003 ADD2 ;set-next-or-addr JMP2
&!4 !set-next &!4 ;set-next JMP2
( STACK OPERATIONS ) ( STACK OPERATIONS )
( ) ( )
@ -741,7 +741,7 @@
( push 4 bytes onto the stack ) ( push 4 bytes onto the stack )
@push4 ( str* regex* -> ) @push4 ( str* regex* -> )
assert-stack-avail ( check for space ) ;assert-stack-avail JSR2 ( check for space )
;stack-pos LDA2 #0002 ADD2 STA2 ( cell[2:3] <- regex ) ;stack-pos LDA2 #0002 ADD2 STA2 ( cell[2:3] <- regex )
;stack-pos LDA2 STA2 ( cell[0:1] <- str ) ;stack-pos LDA2 STA2 ( cell[0:1] <- str )
;stack-pos LDA2 #0004 ADD2 ;stack-pos STA2 ( pos += 4 ) ;stack-pos LDA2 #0004 ADD2 ;stack-pos STA2 ( pos += 4 )
@ -749,7 +749,7 @@
( pop 4 bytes from the stack ) ( pop 4 bytes from the stack )
@pop4 ( -> str* regex* ) @pop4 ( -> str* regex* )
assert-stack-exist ( check for space ) ;assert-stack-exist JSR2 ( check for space )
;stack-pos LDA2 ( load stack-pos ) ;stack-pos LDA2 ( load stack-pos )
#0002 SUB2 LDA2k STH2 ( pop and stash regex ) #0002 SUB2 LDA2k STH2 ( pop and stash regex )
#0002 SUB2 LDA2k STH2 ( pop and stash str ) #0002 SUB2 LDA2k STH2 ( pop and stash str )
@ -771,14 +771,14 @@
( error if stack is full ) ( error if stack is full )
@assert-stack-avail ( -> ) @assert-stack-avail ( -> )
stack-avail ?&ok ;stack-is-full errorm &ok JMP2r ;stack-avail JSR2 ,&ok JCN ;stack-is-full ;error!! JSR2 &ok JMP2r
( error is stack is empty ) ( error is stack is empty )
@assert-stack-exist ( -> ) @assert-stack-exist ( -> )
stack-exist ?&ok ;stack-is-empty errorm &ok JMP2r ;stack-exist JSR2 ,&ok JCN ;stack-is-empty ;error!! JSR2 &ok JMP2r
( stack-pos points to the next free stack position (or the top if full). ) ( stack-pos points to the next free stack position (or the top if full). )
@stack-pos =stack-bot ( the next position to insert at ) @stack-pos :stack-bot ( the next position to insert at )
( stack-bot is the address of the first stack position. ) ( stack-bot is the address of the first stack position. )
( stack-top is the address of the first byte beyond the stack. ) ( stack-top is the address of the first byte beyond the stack. )
@ -810,12 +810,12 @@
#00 SWP ( size* ) #00 SWP ( size* )
;arena-pos LDA2 STH2k ADD2 ( pos+size* [pos] ) ;arena-pos LDA2 STH2k ADD2 ( pos+size* [pos] )
DUP2 ;arena-top GTH2 ( pos+size pos+size>top? [pos] ) DUP2 ;arena-top GTH2 ( pos+size pos+size>top? [pos] )
?&error ( pos+size [pos] ) ,&error JCN ( pos+size [pos] )
;arena-pos STA2 ( pos += size [pos] ) ;arena-pos STA2 ( pos += size [pos] )
STH2r JMP2r ( pos ) STH2r JMP2r ( pos )
&error POP2 POP2r ;arena-is-full errorm &error POP2 POP2r ;arena-is-full ;error!! JSR2
@arena-pos =arena-bot ( the next position to allocate ) @arena-pos :arena-bot ( the next position to allocate )
@arena-bot $400 @arena-top ( holds up to 1024 bytes ) @arena-bot $400 @arena-top ( holds up to 1024 bytes )
( SUBGROUP OPERATIONS ) ( SUBGROUP OPERATIONS )
@ -870,7 +870,7 @@
@subgroup-start ( s* i^ -> ) @subgroup-start ( s* i^ -> )
;subgroup-pos LDA2 STH2k ( s* i^ pos* [pos*] ) ;subgroup-pos LDA2 STH2k ( s* i^ pos* [pos*] )
;subgroup-top LTH2 ?&next #0000 DIV ( too many subgroups ) ;subgroup-top LTH2 ,&next JCN #0000 DIV ( too many subgroups )
&next ( s* i^ [pos*] ) &next ( s* i^ [pos*] )
STH2kr STA STH2kr STA
STH2r INC2 STA2 STH2r INC2 STA2
@ -878,9 +878,9 @@
@subgroup-finish ( s* i^ -> ) @subgroup-finish ( s* i^ -> )
;subgroup-pos LDA2 STH2k ( s* i^ pos* [pos*] ) ;subgroup-pos LDA2 STH2k ( s* i^ pos* [pos*] )
;subgroup-top LTH2 ?&next #0000 DIV ( too many subgroups ) ;subgroup-top LTH2 ,&next JCN #0000 DIV ( too many subgroups )
&next ( s* i^ [pos*] ) &next ( s* i^ [pos*] )
STH2kr LDA EQU ?&ok #0000 DIV ( mismatched subgroups ) STH2kr LDA EQU ,&ok JCN #0000 DIV ( mismatched subgroups )
&ok ( s* [pos*] ) &ok ( s* [pos*] )
STH2kr #0003 ADD2 STA2 STH2kr #0003 ADD2 STA2
STH2r #0005 ADD2 ;subgroup-pos STA2 STH2r #0005 ADD2 ;subgroup-pos STA2
@ -888,7 +888,7 @@
@subgroup-branch ( -> ) @subgroup-branch ( -> )
;subgroup-pos LDA2 STH2k ( pos* [pos*] ) ;subgroup-pos LDA2 STH2k ( pos* [pos*] )
;subgroup-top LTH2 ?&next #0000 DIV ( too many subgroups ) ;subgroup-top LTH2 ,&next JCN #0000 DIV ( too many subgroups )
&next &next
#00 STH2kr STA ( [*pos] ) #00 STH2kr STA ( [*pos] )
STH2r #0005 ADD2 ;subgroup-pos STA2 STH2r #0005 ADD2 ;subgroup-pos STA2
@ -897,9 +897,9 @@
@subgroup-backtrack ( -> ) @subgroup-backtrack ( -> )
;subgroup-bot ;subgroup-pos LDA2 ( bot* pos* ) ;subgroup-bot ;subgroup-pos LDA2 ( bot* pos* )
&loop ( bot* pos* ) &loop ( bot* pos* )
EQU2k ?&done EQU2k ,&done JCN
LDAk #00 EQU ?&done LDAk #00 EQU ,&done JCN
#0005 SUB2 !&loop #0005 SUB2 ,&loop JMP
&done ( bot* pos* ) &done ( bot* pos* )
NIP2 ;subgroup-pos STA2 NIP2 ;subgroup-pos STA2
JMP2r JMP2r
@ -909,5 +909,5 @@
;subgroup-bot ;subgroup-pos STA2 ;subgroup-bot ;subgroup-pos STA2
JMP2r JMP2r
@subgroup-pos =subgroup-bot ( the position of the first unallocated subgroup item ) @subgroup-pos :subgroup-bot ( the position of the first unallocated subgroup item )
@subgroup-bot $280 @subgroup-top ( holds up to 128 subgroup assignments (640 bytes) ) @subgroup-bot $280 @subgroup-top ( holds up to 128 subgroup assignments (640 bytes) )

34
tal.nanorc
View File

@ -13,40 +13,32 @@ syntax tal ".*\.tal"
comment "( | )" comment "( | )"
# raw values # raw values
color green "\B\"\S+" color pink "\"[^ ]+"
color green "\<[0-9a-f]{2}{1,2}\>" color pink "'[^ ]"
color green "\<_\S+" color pink "\<[0-9a-f]{2}{1,2}\>"
color green "\B-\S+"
color green "\B=\S+"
# literals # literals
color bold,green "\B#[0-9a-f]{2}{1,2}\>" color bold,green "#[0-9a-f]{2}{1,2}\>"
# addresses (absolute, relative, zero-page) # absolute addresses
color yellow "\B;\S+" color bold,yellow "(;&?|\.)\S+"
color yellow "\B,\S+" color bold,orange ",&?\S+"
color yellow "\B\.\S+" color bold,orange "/\S+"
# relative pads # relative pads
color yellow "\B\$[0-9a-f]{1,4}\>\>" color yellow "\$[0-9a-f]{1,4}\>"
# instructions # instructions
color cyan "\<(BRK|LIT|INC|POP|DUP|NIP|SWP|OVR|ROT|EQU|NEQ|GTH|LTH|JMP|JCN|JSR|STH|LDZ|STZ|LDR|STR|LDA|STA|DEI|DEO|ADD|SUB|MUL|DIV|AND|ORA|EOR|SFT)[2kr]*\>" color bold,cyan "\<(BRK|LIT|INC|POP|DUP|NIP|SWP|OVR|ROT|EQU|NEQ|GTH|LTH|JMP|JCN|JSR|STH|LDZ|STZ|LDR|STR|LDA|STA|DEI|DEO|ADD|SUB|MUL|DIV|AND|ORA|EOR|SFT)2?k?r?\>"
# label definitions # label definitions
color bold,blue "(^|\s)(@|&)\S+" color bold,blue "(^|\s)(@|&)\S+"
# macros # macros
color bold,magenta "\B%\S+" color bold,magenta "%\S+"
# absolute pads # absolute pads
color yellow "\B\|[0-9a-f]{1,4}\>" color yellow "\|[0-9a-f]{2}{1,2}\>"
# immediate syntax
color bold,yellow "\?\S+"
color bold,yellow "!\S+"
color bold,yellow "\B\{\B"
color bold,yellow "\B\}\B"
# comments # comments
color red start="\B\(\s" end="\s\)\B" color red start="\(\s" end="\s\)"

511
tar.tal
View File

@ -2,291 +2,165 @@
( ) ( )
( by d_m ) ( by d_m )
( ) ( )
( see https://en.wikipedia.org/wiki/Tar_(computing)#UStar_format ) ( currently only supports listing the contents of tar files )
( )
( TODO: )
( - check for "ustar" header )
( - handle filename-prefix )
( - handle 'L' entries )
( - support creating archives )
( - arg validation should depend on mode )
( - validate checksums )
( - better error messages on unsupported files, e.g. symlinks )
( - better usage message )
( - support using "-" for stdin/stdout? )
( - option to ignore symlinks? )
( File1 is used to read/write the tar file ) ( File1 is used to read the tar file )
( File2 is used to read/write files and directories ) ( File2 is used to write files and directories )
|a0 @File1 [ &vec $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ] |a0 @File1 [ &vec $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|b0 @File2 [ &vec $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ] |b0 @File2 [ &vec $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|0100 |0100
;arg-callback ;on-stdin arg/init BRK ;arg-callback ;on-stdin arg/init BRK
( exit abnormally )
@panic ( -> $exit )
#010e DEO #010f DEO BRK
( handle all provided command-line arguments )
@arg-callback ( -> )
;arg/count LDA
DUP #00 EQU ?&missing-mode
DUP #01 EQU ?&missing-file
#02 GTH ?&toomany !run
&missing-mode ;missing-mode !&error
&missing-file ;missing-filename !&error
&toomany ;too-many-arguments
&error print ;usage print #01 !exit
( run the program )
@run ( -> BRK )
#01 arg/read .File1/name DEO2
#00 arg/read LDA
DUP LIT "t NEQ ?{ list-entries #00 !exit }
DUP LIT "x NEQ ?{ expand-entries #00 !exit }
POP ;invalid-mode print ;usage print #00 !exit
( exit normally )
@exit ( code^ -> BRK ) @exit ( code^ -> BRK )
#80 ORA #0f DEO BRK #80 ORA #0f DEO BRK
( ignore stdin once we've processed the args ) @arg-callback ( -> )
@on-stdin ( -> BRK ) ;arg/count LDA
BRK DUP #00 EQU ?&missing
DUP #01 GTH ?&toomany
POP !run
&missing ;missing-filename !&error
&toomany ;too-many-arguments
&error print ;usage print #01 !exit
@run ( -> )
#00 arg/read .File1/name DEO2 list #00 !exit
@on-stdin ( -> BRK ) BRK
@usage "usage: 20 "uxncli 20 "tar.rom 20 "FILENAME 0a 00
@missing-filename "error: 20 "missing 20 "filename 0a 00
@too-many-arguments "error: 20 "too 20 "many 20 "arguments 0a 00
@unsupported "unsupported 20 "format 20 00
@panic ( -> $exit )
#010e DEO #010f DEO BRK
( print a null-terminated string )
@print ( s* -> ) @print ( s* -> )
&loop LDAk ?{ POP2 JMP2r } &loop LDAk #00 EQU ,&eof JCN
LDAk #18 DEO INC2 !&loop LDAk #18 DEO INC2 ,&loop JMP
&eof POP2 JMP2r
( print up to `len` bytes from string. stops on NUL. )
@lprint ( s* len* -> )
OVR2 ADD2 SWP2 ( limit* s* )
&loop LDAk ?{ !&done } ( limit* s* )
LDAk #18 DEO INC2 GTH2k ?&loop ( limit* s+1* )
&done POP2 POP2 JMP2r ( )
( read 512 bytes of header for the next tar entry. )
( assumes .File1/name is already set. )
@read-header ( -> ok^ ) @read-header ( -> ok^ )
( assume .File1/name was already written )
#0200 .File1/len DEO2 #0200 .File1/len DEO2
;header .File1/r DEO2 ;header .File1/r DEO2
( TODO validate checksum )
.File1/ok DEI2 #0200 EQU2 JMP2r .File1/ok DEI2 #0200 EQU2 JMP2r
( list all the entries in the tar archive ) @list ( -> )
@list-entries ( -> ) read-header ?&ok JMP2r &ok
read-header ?{ JMP2r }
;header/filename LDA ?&non-null ;header/filename LDA ?&non-null
#800f DEO BRK #800f DEO BRK
&non-null &non-null
;header/type LDA ( type^ ) ;header/type LDA ( type^ )
DUP #00 EQU ?list-file-v ( type^ ) DUP #00 EQU ?list-file ( )
DUP LIT "0 EQU ?list-file-v ( type^ ) DUP LIT "0 EQU ?list-file ( )
DUP LIT "5 EQU ?list-dir-v ( type^ ) DUP LIT "5 EQU ?list-dir ( )
DUP LIT "7 EQU ?list-file-v ( type^ ) !list-unsupported ( )
!list-unsupported-v
( !fail-unsupported ) ( )
( non-verbose file entry listing )
@list-file ( 00^ -> ) @list-file ( 00^ -> )
POP POP
LIT "f #18 DEO #2018 DEO LIT "f #18 DEO #2018 DEO
;header/filename #0064 lprint #0a18 DEO ;header/filename print #0a18 DEO
;header/size load-octal11 round-up-to-512 skip !list-entries ;header/size load-octal11
round-up-to-512 skip !list
( non-verbose directory entry listing )
@list-dir ( 00^ -> ) @list-dir ( 00^ -> )
POP POP
LIT "d #18 DEO #2018 DEO LIT "d #18 DEO #2018 DEO
;header/filename #0064 lprint #0a18 DEO ;header/filename print #0a18 DEO
!list-entries !list
( verbose file entry listing ) @list-unsupported ( type^ -> )
@list-unsupported-v ( type^ -> ) ;unsupported print emit/byte #0a18 DEO !panic
( POP ) !list
( LIT "f ) #18 DEO #2018 DEO
;header/size load-octal11 dump-longer #2018 DEO
;header/filename #0064 lprint #0a18 DEO
;header/size load-octal11 round-up-to-512
( dump-header ) ( write data from memory into the tar file )
@write-memory ( filename* size* data* -> )
STH2 STH2k write-file-header ( [data* size*] )
STH2r STH2r write-file-body JMP2r ( )
.File1/len
;header/size .File2/name DEO2 @write-file-header ( filename* size* -> )
;header/size load-octal11 STH2k skip SWP2 ;header/filename copy JMP2r
STH2r remainder-512 skip-lo !list-entries write-size-2
( TODO: checksum )
LIT "0 ;header/type STA
#00 ;header/linkname STA
JMP2r
( verbose file entry listing ) @write-file-body ( size* data* -> )
@list-file-v ( type^ -> ) SWP2 .File1/len DEO2 .File1/w DEO2 JMP2r
POP
LIT "f #18 DEO #2018 DEO
;header/size load-octal11 dump-longer #2018 DEO
;header/filename #0064 lprint #0a18 DEO
;header/size load-octal11 round-up-to-512 skip !list-entries
( verbose directory entry listing ) @mod ( x* y* -> x%y* )
@list-dir-v ( 00^ -> ) DIV2k MUL2 SUB2 JMP2r
POP
LIT "d #18 DEO #2018 DEO
;header/size load-octal11 dump-longer #2018 DEO
;header/filename #0064 lprint #0a18 DEO
!list-entries
( handle unsupported directory entry listing ) @write-size-2 ( size* -> )
@fail-unsupported ( type^ -> ) ;header/size STH2 ( size* [start*] )
;unsupported print DUP emit/byte #2018 DEO LIT2r 000a ADD2r ( size* [start* last*] )
LIT2 "[ 18 DEO #18 DEO LIT2 "] 18 DEO &loop ( size* [start* pos*] )
#0a18 DEO LTH2kr STHr ?&done ( size* [start* pos*] )
dump-header !panic DUP2 #0007 AND2 ( size* size%8* [start* pos*] )
NIP LIT "0 ADD ( size* octal^ [start* pos*] )
STH2kr STA ( size* [start* pos*] )
#03 SFT2 ( size/8* [start* pos*] )
LIT2 0001 SUB2 !&loop ( size/8* [start* pos-1*] )
&done ( zero* [start* pos*] )
POP2 POP2r POP2r JMP2r ( )
( expand a .tar archive in the current working directory ) @copy ( src* dst* -> )
@expand-entries ( -> ) STH2
read-header ?{ JMP2r } &loop
;header/filename LDA ?&non-null LDAk DUP STH2kr STA2 ?&ok
#800f DEO BRK POP2 POP2r JMP2r
&non-null &ok INC2 INC2r !&loop
;header/type LDA ( type^ )
DUP #00 EQU ?expand-file ( type^ )
DUP LIT "0 EQU ?expand-file ( type^ )
DUP LIT "5 EQU ?expand-dir ( type^ )
DUP LIT "7 EQU ?expand-file ( type^ )
!expand-unsupported
( !fail-unsupported ) ( )
( remove leading / of an absolute path ) @read-error "error 20 "reading 20 "data 0a 00
@sanitize-path ( s* -> s1* )
LDAk LIT "/ NEQ JMP INC2 JMP2r
@remainder-512 ( n* -> extra* ) ( skips n bytes, specified as a 5-byte integer )
#01ff AND2 #0200 DUP2 ROT2 SUB2 NEQ2k ?{ POP2 #0000 } NIP2 JMP2r
@expand-file ( type^ -> )
POP
;header/filename sanitize-path
DUP2 #0064 lprint #0a18 DEO
.File2/name DEO2
;header/size load-octal11 STH2k write
STH2r remainder-512 skip-lo !expand-entries
@expand-dir ( type^ -> )
POP
;header/filename sanitize-path
DUP2 #0064 lprint #0a18 DEO
.File2/name DEO2
#0004 .File2/len DEO2
#0001 .File2/w DEO2
!expand-entries
@expand-unsupported ( type^ -> )
;skipped-unsupported print
#18 DEO LIT2 ": 18 DEO #2018 DEO
;header/filename sanitize-path
DUP2 #0064 lprint
#0a18 DEO
.File2/name DEO2
;header/size load-octal11 round-up-to-512 skip
!expand-entries
( src and dst should be paths )
@compress-entries ( src* dst* -> )
POP2 POP2 JMP2r
( writes `n` bytes from File1 to File2 )
( uses a 32k internal buffer )
@write ( carry^ hi* lo* -> )
;write-buf ;write-lo/writer STA2
write-lo write-hi ?write-4g JMP2r
( writes up to 32768 bytes of; limited by the size of buf )
@write-buf ( n* -> )
ORAk ?{ POP2 JMP2r } ( n* )
DUP2 .File1/len DEO2 ( n* )
;buffer .File1/r DEO2 ( n* )
DUP2 .File1/ok DEI2 EQU2 ?&ok ( n* )
POP2 ;read-error print !panic ( )
&ok ( n* )
DUP2 .File2/len DEO2 ( n* )
;buffer .File2/w DEO2 ( n* )
.File2/ok DEI2 EQU2 ?&ok2 ( )
;write-error print !panic ( )
&ok2 JMP2r ( )
( skips `n` bytes forward in File1, specified as a 5-byte integer )
( )
( since we can only actually read 32k at a time, and since we can )
( only easily work with 2-byte shorts, we first read the lowest )
( two bytes and skip that much. then, for the higher byte, we can )
( do two skips of 32k for each unit found. )
@skip ( carry^ hi* lo* -> ) @skip ( carry^ hi* lo* -> )
;skip-buf ;write-lo/writer STA2 skip-lo ( carry^ hi* )
write-lo write-hi ?write-4g JMP2r skip-hi ( carry^ )
?skip-4g JMP2r ( )
@skip-4g ( -> ) skip-2g ( fall-through )
@skip-2g ( -> ) #8000 !skip-hi
( skips hi*2^16 bytes )
@skip-hi ( hi* -> )
#0000 SWP2 SUB2 ( -hi* )
&loop ORAk ?&ok POP2 JMP2r ( )
&ok skip-64k INC2 !&loop ( -hi+1* )
@skip-64k ( -> ) skip-32k ( fall-through )
@skip-32k ( -> ) #8000 !skip-buf
@skip-lo ( lo* -> ) @skip-lo ( lo* -> )
;skip-buf ;write-lo/writer STA2 !write-lo DUP2 #8000 GTH2 ?&double !skip-buf
&double #8000 SUB2 skip-buf !skip-32k
( skips up to 32768 bytes of; limited by the size of buf ) ( skips lo bytes )
@skip-buf ( n* -> ) @skip-buf ( lo* -> )
ORAk ?{ POP2 JMP2r } ORAk ?&non-zero POP2 JMP2r &non-zero
DUP2 .File1/len DEO2 DUP2 .File1/len DEO2
;buffer .File1/r DEO2 ;buffer .File1/r DEO2
.File1/ok DEI2 EQU2 ?&ok .File1/ok DEI2 EQU2 ?&ok
;read-error print !panic ;read-error print !panic
&ok JMP2r &ok JMP2r
( unconditionally write 4GiB, that is 4294967296 bytes )
@write-4g ( -> ) write-2g ( >> )
( unconditionally write 2GiB, that is 2147483648 bytes )
@write-2g ( -> ) #8000 !write-hi
( writes `hi*65536` bytes )
( - 0001 will write 65536 bytes )
( - 0010 will write 1048576 bytes )
( - ffff will write 4294901760 bytes )
@write-hi ( hi* -> )
#0000 SWP2 SUB2 ( -hi* )
&loop ORAk ?&ok POP2 JMP2r ( )
&ok write-64k INC2 !&loop ( -hi+1* )
( writes exactly 65536 bytes )
@write-64k ( -> ) write-32k ( >> )
( writes exactly 32768 bytes )
@write-32k ( -> ) #8000 ( >> )
( write up to 65536 bytes )
@write-lo ( lo* -> )
DUP2 #8001 LTH2 ?{ write-32k #8000 SUB2 } LIT2 [ &writer =write-buf ] JMP2
( '0' -> 00 )
( '1' -> 01 )
( ... )
( '7' -> 07 )
( anything else -> 00 )
@octal-digit ( char^ -> oct^ ) @octal-digit ( char^ -> oct^ )
LIT "0 SUB DUP #08 LTH ?{ POP #00 } JMP2r LIT "0 DUP2 LTH ?&zero SUB JMP2r &zero POP2 #00 JMP2r
( returns values between #00:0000:0000 and #01:ffff:ffff ) ( returns values between #00:0000:0000 and #01:ffff:ffff )
( )
( octal11 of 77777777777 = #01 #ffff #ffff, max value )
( octal11 of 37777777777 = #00 #ffff #ffff )
( octal11 of 00000177777 = #00 #0000 #ffff )
( octal11 of 00000000377 = #00 #0000 #00ff )
( octal11 of 00000000000 = #00 #0000 #0000, min value )
@load-octal11 ( addr* -> carry^ hi* lo* ) @load-octal11 ( addr* -> carry^ hi* lo* )
INC2k load-octal10 ( addr* hi* lo* ; load addr+1 ) INC2k load-octal10 ( addr* hi* lo* )
STH2 STH2 ( addr* [lo* hi*] ) STH2 STH2 ( addr* [lo* hi*] )
LDA octal-digit STH2r STH ( octal^ a^ [lo* b^] ) LDA ( LIT "0 SUB ) octal-digit STH2r STH ( octal^ a^ [lo* b^] )
#20 SFT #02 SFT2 STHr STH2r ( carry^ hi* lo* ) #20 SFT #02 SFT2 STHr STH2r ( carry^ hi* lo* )
JMP2r ( carry^ hi* lo* ) JMP2r ( carry^ hi* lo* )
( returns values between #0000:0000 and #3fff:ffff ) ( returns values between #0000:0000 and #3fff:ffff )
( )
( octal10 of 7777777777 = #3fff #ffff, max value )
( octal10 of 0000177777 = #0000 #ffff )
( octal10 of 0000000377 = #0000 #00ff )
( octal10 of 0000000000 = #0000 #0000, min value )
@load-octal10 ( addr* -> hi* lo* ) @load-octal10 ( addr* -> hi* lo* )
#0005 OVR2 ADD2 ( addr* addr+5* ) #0005 OVR2 ADD2 ( addr* addr+5* )
load-octal5 STH2 ( addr* [cd*] ) load-octal5 STH2 ( addr* [cd*] )
@ -296,10 +170,6 @@
JMP2r ( hi* lo* ) JMP2r ( hi* lo* )
( returns values between #0000 and #7fff ) ( returns values between #0000 and #7fff )
( )
( octal5 of 77777 = #7fff, max value )
( octal5 of 00377 = #00ff )
( octal5 of 00000 = #0000, min value )
@load-octal5 ( addr* -> num* ) @load-octal5 ( addr* -> num* )
#1000 LIT2r 0000 ( addr* place* [sum*] ) #1000 LIT2r 0000 ( addr* place* [sum*] )
&loop ( pos* place* [sum*] ) &loop ( pos* place* [sum*] )
@ -312,155 +182,54 @@
( emit 1, 2, 4, or 5 bytes as a decimal number ) ( emit 1, 2, 4, or 5 bytes as a decimal number )
@emit @emit
&1+long STH2 STH2 /byte STH2r STH2r &1+long STH2 STH2 ,&byte JSR STH2r STH2r
&long SWP2 /short &long SWP2 ,&short JSR
&short SWP /byte &short SWP ,&byte JSR
&byte DUP #04 SFT /char &byte DUP #04 SFT ,&char JSR
&char #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO &char #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO
JMP2r JMP2r
( round a given 5-byte size up to multiples of 512 ) ( round a given 5-byte size up to multiples of 512 )
@round-up-to-512 ( carry^ hi* lo* -> chl^** ) @round-up-to-512 ( carry^ hi* lo* -> )
DUP2 #01ff AND2 ORA ?{ JMP2r } DUP2 #fe00 GTH2 ?&round-hi
DUP2 #fe00 GTH2 ?{ #0200 OVR2 #01ff AND2 SUB2 ADD2 JMP2r } #0200 OVR2 #01ff AND2 SUB2 ADD2 JMP2r
POP2 DUP2 #ffff EQU2 ?{ INC2 #0000 JMP2r } &round-hi
POP2 INC #0000 #0000 JMP2r POP2 DUP2 #ffff EQU2 ?&round-carry INC2 #0000 JMP2r
&round-carry
POP2 DUP #ff EQU ?&overflow INC #0000 #0000 JMP2r
&overflow #0000 DIV
( since 4-byte integers are called `long` values, ) ( header/size is 11 octal digits; 12th digit is NUL )
( i'm calling a 5-byte integer a `longer` value. ) ( octal 77777777777 = #01 #ffff #ffff )
( octal 37777777777 = #ffff #ffff )
( octal 00000177777 = #ffff )
( octal 00000000377 = #ff )
( octal 00000000000 = #00 )
@dump-longer ( carry^ long** -- ) ( header/type -- only 0 and 5 are supported )
STH2 STH2 dump-byte STH2r STH2r ( >> ) ( '0' normal file; also could be NUL )
@dump-long ( long** -- ) ( '1' hard link )
SWP2 dump-short ( >> ) ( '2' symlink )
@dump-short ( short* -- ) ( '3' character device )
SWP dump-byte ( >> ) ( '4' block device )
@dump-byte ( byte^ -- ) ( '5' directory )
DUP #04 SFT /hex #0f AND ( >> ) ( '6' fifo )
&hex #30 ADD DUP #39 GTH #27 MUL ADD #18 DEO ( '7' contiguous file )
JMP2r
@dump-mem ( start* size* -> ) ( header is always exactly 512 bytes )
OVR2 ADD2 SWP2 ( lim* start* ) @header
LDAk dump-byte INC2 ( lim* start+1* ) &filename $64
&loop GTH2k ?&ok POP2 POP2 #0a18 DEO JMP2r ( lim^ pos^ ) &mode $8 ( octal )
&ok #2018 DEO LDAk dump-byte INC2 !&loop ( lim^ pos+1^ ) &owner $8 ( octal )
&group $8 ( octal )
@dump-mem0 ( start* size* -> ) &size $c ( octal )
#0001 SUB2 OVR2 ADD2 SWP2 &mtime $c ( octal )
&loop GTH2k ?{ NIP2 LDA #18 DEO #2018 DEO JMP2r } &checksum $8
LDAk #30 GTH ?{ #2018 DEO INC2 !&loop } &type $1 ( item type )
LDAk #18 DEO INC2 ( >> ) &linkname $64
&loop2 GTH2k ?{ NIP2 LDA #18 DEO #2018 DEO JMP2r }
LDAk #18 DEO INC2 !&loop2
@dump-body1 ( -> )
@dump-header ( -> )
LIT2 "- 18 DEOk DEOk DEOk DEOk DEO #0a18 DEO
;header/filename #0064 dump-mem
;header/mode #0008 dump-mem
;header/owner #0008 dump-mem
;header/group #0008 dump-mem
;header/size #000c dump-mem
;header/mtime #000c dump-mem
;header/checksum #0008 dump-mem
;header/type #0001 dump-mem
;header/linkname #0064 dump-mem
LIT2 "+ 18 DEOk DEOk DEOk DEOk DEO #0a18 DEO
;uheader/ustar #0006 dump-mem
;uheader/version #0002 dump-mem
;uheader/owner-name #0020 dump-mem
;uheader/group-name #0020 dump-mem
;uheader/major #0008 dump-mem
;uheader/minor #0008 dump-mem
;uheader/filename-prefix #009b dump-mem
;uheader/pad #000c dump-mem
LIT2 "- 18 DEOk DEOk DEOk DEOk DEO #0a18 DEO
JMP2r
( some handy string constants )
@usage "usage: 20 "uxncli 20 "tar.rom 20 "t|x 20 "FILENAME 0a 00
@missing-mode "error: 20 "missing 20 "mode 0a 00
@missing-filename "error: 20 "missing 20 "filename 0a 00
@too-many-arguments "error: 20 "too 20 "many 20 "arguments 0a 00
@invalid-mode "error: 20 "invalid 20 "mode 0a 00
@unsupported "unsupported 20 "format 20 00
@read-error "error 20 "reading 20 "data 0a 00
@write-error "error 20 "writing 20 "data 0a 00
@skipped-unsupported "skipped 20 "unsupported 20 "type 20 00
( load argument parser ) ( load argument parser )
~arg.tal ~arg.tal
( HEADER DETAILS ) ( buffer for reading up to 32k bytes of data )
( )
( header -- basic v7 tar header )
( /filename - name of file, null-terminated. if ustar, check prefix )
( /mode - file permissions, ignored by uxn )
( /owner - owner ID, ignored by uxn )
( /group - group ID, ignored by uxn )
( /size - file size as 11 octal digits. max size is 8GiB. )
( /mtime - last modification time, ignored by uxn )
( /checksum - 6 octal digits followed by NUL, then space )
( /type -- only 0, 5, and 7 are supported )
( '0' [or NUL] normal file )
( '1' hard link )
( '2' symlink )
( '3' character device )
( '4' block device )
( '5' directory )
( '6' fifo )
( '7' contiguous file -- treat as normal file )
( 'g' global extended header with metadata; POSIX.1-2001 )
( 'x' extended header with metadata for next file; POSIX.1-2001 )
( 'A' solaris ACL )
( 'D' gnu dump dir )
( 'E' solaris extended attrs )
( 'I' inode metadata )
( 'K' this entry's data is the long link location of next file, null-terminated? )
( 'L' this entry's data is the long filename of next file, null-terminated )
( 'M' continuation file )
( 'N' old gnu for long names )
( 'S' sparse files )
( 'V' tape/volume header )
( 'X' extended attrs, sun )
( /linkname -- for hardlinks, the file containing the linked data )
( uheader -- ustar header, found in v7 padding bytes )
( /ustar -- ustar indiciator, should be "ustar " )
( /version -- ustar version )
( /owner-name -- owner name string, ignored by uxn )
( /group-name -- group name string, ignored by uxn )
( /major -- major device number, ignored by uxn )
( /minor -- minor device number, ignored by uxn )
( /filename-prefix -- if non-null, true path is prefix+"/"+filename )
( )
( the v7 header is always 512 bytes even if ustar indicator is absent. )
@header
&filename $64 ( 0x00: filename, string, 100 byte )
&mode $8 ( 0x64: mode, octal-1, 8 bytes )
&owner $8 ( 0x6c: owner, octal-1, 8 bytes )
&group $8 ( 0x74: group, octal-1, 8 bytes )
&size $c ( 0x7c: size, octal-1, 12 bytes )
&mtime $c ( 0x88: mtime, octal-1, 12 bytes )
&checksum $8 ( 0x94: checksum, octal-2, 8 bytes )
&type $1 ( 0x9c: file type, 1 byte )
&linkname $64 ( 0x9d: linked filename, string, 100 bytes )
( >> )
@uheader
&ustar $6 ( 0x101: ustar indicator, non-terminated string, 6 bytes, "ustar " )
&version $2 ( 0x107: ustar version, non-terminated string, 2 bytes )
&owner-name $20 ( 0x109: owner name, string, 32 bytes )
&group-name $20 ( 0x129: group name, string, 32 bytes )
&major $8 ( 0x149: device major number, octal? )
&minor $8 ( 0x151: device minor number, octal? )
&filename-prefix $9b ( 0x159: prefix before filename, string, 155 bytes )
&pad $c ( 0x1f4: padding, 12 bytes )
&end ( 0x200: end of header )
( buffer for up to 4096 characters of long names/paths )
|7000 @long-buf $1000
( buffer for reading up to 32k bytes of data at a time )
|8000 @buffer $8000 |8000 @buffer $8000

148
term.tal
View File

@ -76,32 +76,13 @@
( ESC [ ? 1060 l -> unset legacy keyboard emulation ) ( ESC [ ? 1060 l -> unset legacy keyboard emulation )
( ESC [ ? 1061 h -> set VT220 keyboard emulation ) ( ESC [ ? 1061 h -> set VT220 keyboard emulation )
|00 @System [ |00 @System [ &vect $2 &expansion $2 &title $2 &metadata $2 &r $2 &g $2 &b $2 ]
&vect $2 &expansion $2 &title $2 &metadata $2 |10 @Console [ &vect $2 &r $1 &exec $2 &mode $1 &dead $1 &exit $1 &w $1 ]
&r $2 &g $2 &b $2 ] |20 @Screen [ &vect $2 &w $2 &h $2 &auto $1 &pad $1 &x $2 &y $2 &addr $2 &px $1 &sprite $1 ]
|80 @Controller [ &vect $2 &button $1 &key $1 &fn $1 ]
|10 @Console [ |90 @Mouse [ &vect $2 &x $2 &y $2 &state $1 &pad $3 &scrollx $2 &scrolly $2 ]
&vect $2 &stdin $1 &pad1 $4 &type $1 |a0 @File1 [ &vect $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
&stdout $1 &stderr $1 &proc-put $1 &pad2 $1 &param $2 &opts $1 &host-put $1 ] |b0 @File2 [ &vect $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|20 @Screen [
&vect $2 &w $2 &h $2 &auto $1 &pad $1
&x $2 &y $2 &addr $2 &px $1 &sprite $1 ]
|80 @Controller [
&vect $2 &button $1 &key $1 &fn $1 ]
|90 @Mouse [
&vect $2 &x $2 &y $2 &state $1 &pad1 $1
&pad2 $2 &scrollx $2 &scrolly $2 &pad3 $2 ]
|a0 @File1 [
&vect $2 &ok $2 &stat $2 &del $1 &append $1
&name $2 &len $2 &r $2 &w $2 ]
|b0 @File2 [
&vect $2 &ok $2 &stat $2 &del $1 &append $1
&name $2 &len $2 &r $2 &w $2 ]
|0000 |0000
@tint $1 ( draw mode. 01=regular, 04=inverted ) @tint $1 ( draw mode. 01=regular, 04=inverted )
@ -143,17 +124,13 @@
@visual-bell $1 ( flash visual bell? otherwise do nothing ) @visual-bell $1 ( flash visual bell? otherwise do nothing )
@border-pad $2 ( use border? should be 0000 or 0010 ) @border-pad $2 ( use border? should be 0000 or 0010 )
( subprocess )
@put-port $1
@get-type $1
|0100 |0100
( metadata ) ( metadata )
;meta .System/metadata DEO2 ;meta .System/metadata DEO2
;meta/name .System/title DEO2 ;meta/name .System/title DEO2
( user configuration defaults ) ( user configuration defaults )
#00 .debug STZ #01 .debug STZ
#01 .show-banner STZ #01 .show-banner STZ
( #0010 .border-pad STZ2 ) ( #0010 .border-pad STZ2 )
#0000 .border-pad STZ2 #0000 .border-pad STZ2
@ -179,54 +156,23 @@
;on-mouse .Mouse/vect DEO2 ( set up mouse callback ) ;on-mouse .Mouse/vect DEO2 ( set up mouse callback )
;on-read .Console/vect DEO2 ( set up stdin callback ) ;on-read .Console/vect DEO2 ( set up stdin callback )
setup-shell ( set up experimental subprocess support ) setup-subprocess ( set up experimental subprocess support )
reset-terminal ( initialize terminal state and settings ) reset-terminal ( initialize terminal state and settings )
setup-debugging ( set up debugging if requested ) setup-debugging ( set up debugging if requested )
draw-banner ( draw banner if requested ) draw-banner ( draw banner if requested )
BRK BRK
@env "TERM=ansi 00
@query
( expansion cmd ) 03
( console device ) 10
( uuid ) 0123 1250 d878 4462 bc41 d092 7645 a2fa
( version ) 00
( flags ) &flags 0000
@has-subprocess ( -> bool^ )
;query .System/expansion DEO2
;query/flags LDA2 #00ff EQU2 JMP2r
( these only work with a patched uxnemu ) ( these only work with a patched uxnemu )
( on other emulators they should be no-ops ) ( on other emulators they should be no-ops )
@setup-shell ( -> ) @setup-subprocess ( -> )
has-subprocess ?{ ;shell .Console/exec DEO2 ( set up bash subprocess )
( without subprocess, just use stdin/stdout ) #80 .Console/mode DEO ( start bash subprocess )
.Console/stdout .put-port STZ
#01 .get-type STZ
JMP2r
}
( with subprocess, use proc put/get )
.Console/proc-put .put-port STZ
#21 .get-type STZ
( setenv 'TERM=ansi' )
;env .Console/param DEO2
#11 .Console/host-put DEO
( exec 'bash -i' )
#81 .Console/opts DEO
;shell .Console/param DEO2
#01 .Console/host-put DEO
( TODO: run stty to communicate terminal size? )
JMP2r JMP2r
@setup-debugging ( -> ) @setup-debugging ( -> )
.debug LDZ ?&continue JMP2r &continue .debug LDZ ?&continue JMP2r &continue
#99 #010e DEO ( put 99 in wst so #010e DEO reliably logs )
;debug-log .File1/name DEO2 ;debug-log .File1/name DEO2
#01 .File1/append DEO #01 .File1/append DEO
JMP2r JMP2r
@ -278,7 +224,7 @@
.rows LDZ2 #000c MUL2 ADD2 .Screen/h DEO2 .rows LDZ2 #000c MUL2 ADD2 .Screen/h DEO2
JMP2r JMP2r
@shell "bash 20 "-l 20 "-i 00 @shell "bash 00 "-i 00 00
@load-theme ( -> ) @load-theme ( -> )
;&path .File1/name DEO2 ;&path .File1/name DEO2
@ -435,18 +381,18 @@
( send ESC [ $c ) ( send ESC [ $c )
@arrow ( c^ -> ) @arrow ( c^ -> )
( .Console/proc-put ) .put-port LDZ STH .Console/w STH
#1b STHkr DEO LIT "[ STHkr DEO STHr DEO #1b STHkr DEO LIT "[ STHkr DEO STHr DEO
JMP2r JMP2r
@paste-from-buf ( size* -> ) @paste-from-buf ( size* -> )
;paste-buf SWP2 OVR2 ADD2 SWP2 ( limit* start* ) ;paste-buf SWP2 OVR2 ADD2 SWP2 ( limit* start* )
&loop ( limit* pos* ) &loop ( limit* pos* )
LDAk ( .Console/proc-put ) .put-port LDZ DEO INC2 ( limit* pos+1* ) LDAk .Console/w DEO INC2 ( limit* pos+1* )
GTH2k ?&loop POP2 POP2 JMP2r GTH2k ?&loop POP2 POP2 JMP2r
@bracket-paste ( c^ -> ) @bracket-paste ( c^ -> )
( .Console/proc-put ) .put-port LDZ STH .Console/w STH
#1b STHkr DEO #1b STHkr DEO
LIT "[ STHkr DEO LIT "[ STHkr DEO
LIT "2 STHkr DEO LIT "2 STHkr DEO
@ -661,16 +607,16 @@
.Controller/key DEI .Controller/key DEI
DUP #08 NEQ ?&done DUP #08 NEQ ?&done
POP #7f ( send DEL instead of BS ) POP #7f ( send DEL instead of BS )
&done ( .Console/proc-put ) .put-port LDZ DEO BRK &done .Console/w DEO BRK
@ctrl ( -> is-down? ) .Controller/button DEI #01 AND JMP2r @ctrl ( -> is-down? ) .Controller/button DEI #01 AND JMP2r
@alt ( -> is-down? ) .Controller/button DEI #02 AND JMP2r @alt ( -> is-down? ) .Controller/button DEI #02 AND JMP2r
( alt-XYZ emits ESC and then emits XYZ ) ( alt-XYZ emits ESC and then emits XYZ )
@on-alt-key ( -> BRK ) @on-alt-key ( -> BRK )
#1b ( .Console/proc-put ) .put-port LDZ DEO #1b .Console/w DEO
ctrl ?on-ctrl-key ctrl ?on-ctrl-key
.Controller/key DEI ( .Console/proc-put ) .put-port LDZ DEO BRK .Controller/key DEI .Console/w DEO BRK
( control seqs: ) ( control seqs: )
( ctrl-sp -> 00 ) ( ctrl-sp -> 00 )
@ -705,15 +651,10 @@
&rs #1e !&done &rs #1e !&done
&us #1f !&done &us #1f !&done
&c1 LIT "@ SUB &c1 LIT "@ SUB
&done ( .Console/proc-put ) .put-port LDZ DEO BRK &done .Console/w DEO BRK
@read-or-brk ( -> BRK? )
.Console/type DEI .get-type LDZ EQU ?{ BRK } JMP2r
@on-read-priv ( -> BRK ) @on-read-priv ( -> BRK )
read-or-brk .Console/r DEI
( .Console/type DEI #21 EQU ?{ BRK } )
.Console/stdin DEI
DUP LIT "; EQU ?next-arg DUP LIT "; EQU ?next-arg
DUP LIT "0 LTH ?end-arg-priv DUP LIT "0 LTH ?end-arg-priv
DUP LIT "9 GTH ?end-arg-priv DUP LIT "9 GTH ?end-arg-priv
@ -723,9 +664,7 @@
POP ;on-read-priv .Console/vect DEO2 BRK POP ;on-read-priv .Console/vect DEO2 BRK
@on-read-csi ( -> BRK ) @on-read-csi ( -> BRK )
read-or-brk .Console/r DEI
( .Console/type DEI #21 EQU ?{ BRK } )
.Console/stdin DEI
DUP LIT "? EQU ?start-priv DUP LIT "? EQU ?start-priv
DUP LIT "; EQU ?next-arg DUP LIT "; EQU ?next-arg
DUP LIT "0 LTH ?end-arg DUP LIT "0 LTH ?end-arg
@ -733,9 +672,7 @@
!add-to-arg !add-to-arg
@on-read-osc ( -> BRK ) @on-read-osc ( -> BRK )
read-or-brk .Console/r DEI
( .Console/type DEI #21 EQU ?{ BRK } )
.Console/stdin DEI
DUP #07 ( bell ) EQU ?&end-osc DUP #07 ( bell ) EQU ?&end-osc
#9c ( esc-\ ) EQU ?&end-osc BRK #9c ( esc-\ ) EQU ?&end-osc BRK
&end-osc ;on-read .Console/vect DEO2 BRK &end-osc ;on-read .Console/vect DEO2 BRK
@ -936,12 +873,12 @@
@dsr ( n* -> ) @dsr ( n* -> )
#0006 NEQ2 ?&done #0006 NEQ2 ?&done
#1b ( .Console/proc-put ) .put-port LDZ DEO #1b .Console/w DEO
LIT "[ ( .Console/proc-put ) .put-port LDZ DEO LIT "[ .Console/w DEO
.cur-y LDZ2 INC2 emit-dec2 .cur-y LDZ2 INC2 emit-dec2
LIT "; ( .Console/proc-put ) .put-port LDZ DEO LIT "; .Console/w DEO
.cur-x LDZ2 INC2 emit-dec2 .cur-x LDZ2 INC2 emit-dec2
LIT "R ( .Console/proc-put ) .put-port LDZ DEO LIT "R .Console/w DEO
&done BRK &done BRK
@cnl ( n* -> ) clear-cursor #0000 .cur-x STZ2 !down-n @cnl ( n* -> ) clear-cursor #0000 .cur-x STZ2 !down-n
@ -1011,9 +948,7 @@
JMP2r JMP2r
@on-read-esc ( -> BRK ) @on-read-esc ( -> BRK )
read-or-brk .Console/r DEI
( .Console/type DEI #21 EQU ?{ BRK } )
.Console/stdin DEI
DUP debug-esc DUP debug-esc
DUP LIT "D EQU ?exec-ind DUP LIT "D EQU ?exec-ind
DUP LIT "E EQU ?exec-nel DUP LIT "E EQU ?exec-nel
@ -1060,9 +995,7 @@
POP reset-args ;on-read-osc .Console/vect DEO2 BRK POP reset-args ;on-read-osc .Console/vect DEO2 BRK
@on-read ( -> BRK ) @on-read ( -> BRK )
read-or-brk .Console/r DEI read BRK
( .Console/type DEI #21 EQU ?{ BRK } )
.Console/stdin DEI read BRK
@read ( c^ -> ) @read ( c^ -> )
DUP debug-read DUP debug-read
@ -1290,7 +1223,7 @@
JMP2r ( ) JMP2r ( )
@highlight-cell ( cell* -> ) @highlight-cell ( cell* -> )
NIP LITr 07 ( c^ [tint^] ) NIP LITr 47 ( c^ [tint^] )
#00 SWP #40 SFT2 ;cp437 ADD2 ( addr* [tint^] ) #00 SWP #40 SFT2 ;cp437 ADD2 ( addr* [tint^] )
.Screen/addr DEO2k ( addr* s^ [tint^] ) .Screen/addr DEO2k ( addr* s^ [tint^] )
STHkr .Screen/sprite DEO ( addr* s^ [tint^] ) STHkr .Screen/sprite DEO ( addr* s^ [tint^] )
@ -1323,21 +1256,14 @@
( emit a signed short as a decimal ) ( emit a signed short as a decimal )
@emit-sdec2 ( n* -> ) @emit-sdec2 ( n* -> )
DUP2k #1f SFT2 EQUk ?&s LIT "- ( .Console/proc-put ) .put-port LDZ DEO DUP2k #1f SFT2 EQUk ?&s LIT2 "- 18 DEO
&s MUL2 SUB2 ( fall-through to emit-dec2 ) &s MUL2 SUB2 ( fall-through to emit-dec2 )
( emit an unsigned short as a decimal ) ( emit an unsigned short as a decimal )
@emit-dec2 ( n* -> ) @emit-dec2 ( n* -> )
LIT2r ff00 ( n* [ff^ 0^] ) LITr ff00 &read #000a DIV2k STH2k MUL2 SUB2 STH2r INCr ORAk ?&read
&read ( ... x* ) POP2 &write NIP #30 ADD #18 DEO OVRr ADDr STHkr ?&write
#000a DIV2k STH2k ( x* 10* x/10* [ff^ i^ x/10*] ) POP2r JMP2r
MUL2 SUB2 STH2r ( x%10* x/10* [ff^ i^] )
INCr ORAk ?&read ( x%10* x/10* [ff^ i+1^] )
POP2 ( x0* ... xn* [ff^ i+1^] )
&write
NIP #30 ADD ( .Console/proc-put ) .put-port LDZ DEO ( x0* ... xn-1* [ff^ j^] )
OVRr ADDr STHkr ?&write ( x* ... xn-1* [ff^ j-1^] )
POP2r JMP2r ( )
@debug-log "debug_term.log 00 @debug-log "debug_term.log 00
@scratch $40 &pos $2 @scratch $40 &pos $2
@ -1374,9 +1300,9 @@
0d 0a 0d 0a
20 20 c9 cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd bb 0d 0a 20 20 c9 cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd bb 0d 0a
20 20 ba 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ba 0d 0a 20 20 ba 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ba 0d 0a
20 20 ba 20 20 "d "e "t "e "r "m 20 20 "v "1 "2 20 20 ba 0d 0a 20 20 ba 20 20 "d "e "t "e "r "m 20 20 "v "1 "0 20 20 ba 0d 0a
20 20 ba 20 20 20 20 "b "y 20 "d "_ "m 20 20 20 20 20 ba 0d 0a 20 20 ba 20 20 20 20 "b "y 20 "d "_ "m 20 20 20 20 20 ba 0d 0a
20 20 ba 20 20 "1 "5 20 "d "e "c 20 "2 "0 "2 "3 20 20 ba 0d 0a 20 20 ba 20 20 "1 "8 20 "m "a "r 20 "2 "0 "2 "3 20 20 ba 0d 0a
20 20 ba 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ba 0d 0a 20 20 ba 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 ba 0d 0a
20 20 c8 cd cd cb cd cd cd cd cd cd cd cd cd cb cd cd bc 0d 0a 20 20 c8 cd cd cb cd cd cd cd cd cd cd cd cd cb cd cd bc 0d 0a
20 20 c9 cb cb ce cb cb cb cb cb cb cb cb cb ce cb cb bb 0d 0a 20 20 c9 cb cb ce cb cb cb cb cb cb cb cb cb ce cb cb bb 0d 0a

99
test-fix16.py
View File

@ -4,16 +4,15 @@ from math import ceil, copysign, cos, floor, log, sin, sqrt, tan
from os import environ from os import environ
from random import randint from random import randint
from subprocess import Popen, PIPE, run from subprocess import Popen, PIPE, run
from sys import argv, exit
def tosigned(x): def tosigned(x):
return x if x < 32768 else x - 65536 return x if x < 32768 else x - 65536
u8 = {'sz': 1 << 8, 'fmt': b'%02x'} u8 = {'sz': 1 << 8, 'fmt': b'%02x'}
x16 = {'sz': 1 << 16, 'fmt': b'%04x'} u16 = {'sz': 1 << 16, 'fmt': b'%04x'}
z16 = {'sz': 1 << 16, 'fmt': b'%04x'} # non-zero z16 = {'sz': 1 << 16, 'fmt': b'%04x'}
p16 = {'sz': 1 << 16, 'fmt': b'%04x'} # positive p16 = {'sz': 1 << 16, 'fmt': b'%04x'}
t16 = {'sz': 1 << 16, 'fmt': b'%04x'} # tangent, must not be pi/2 t16 = {'sz': 1 << 16, 'fmt': b'%04x'}
def eq(got, expected): def eq(got, expected):
return got == expected return got == expected
@ -26,7 +25,7 @@ def releq(got0, expected0):
else: else:
error = abs(got - expected) / (abs(expected) + 0.001) error = abs(got - expected) / (abs(expected) + 0.001)
return error < 0.01 return error < 0.01
def sineq(got0, expected0): def abseq(got0, expected0):
got, expected = tosigned(got0), tosigned(expected0) got, expected = tosigned(got0), tosigned(expected0)
if (expected - 10) <= got and got <= (expected + 10): if (expected - 10) <= got and got <= (expected + 10):
return True return True
@ -46,7 +45,6 @@ def testcase(p, sym, args, out, f, eq):
val = randint(0, g['sz'] - 1) val = randint(0, g['sz'] - 1)
while ((val == 0 and (g is z16 or g is p16)) or while ((val == 0 and (g is z16 or g is p16)) or
(val >= 0x8000 and g is p16) or (val >= 0x8000 and g is p16) or
(val == 0x8000 and g is x16) or
(g is t16 and ((val >= 804) or ((val % 804) == 402)))): (g is t16 and ((val >= 804) or ((val % 804) == 402)))):
val = randint(0, g['sz'] - 1) val = randint(0, g['sz'] - 1)
vals.append((name, g, val)) vals.append((name, g, val))
@ -81,24 +79,6 @@ def test(p, trials, sym, args, out, f, eq=eq):
else: else:
print('%s failed %d/%d trials (%r)' % (name, fails, trials, cases)) print('%s failed %d/%d trials (%r)' % (name, fails, trials, cases))
def fromfix(n):
assert 0 <= n and n <= 65535
if n >= 32768:
res = (n - 65536) / 256
else:
res = n / 256
return res
bound = 32767 / 256
def tofix(x):
y = min(max(x, -bound), bound)
if y < 0:
res = int(ceil(65536 + y * 256))
else:
res = int(y * 256)
return res % 65536
def pipe(): def pipe():
return Popen(['uxncli', 'run.rom'], stdin=PIPE, stdout=PIPE) return Popen(['uxncli', 'run.rom'], stdin=PIPE, stdout=PIPE)
@ -107,17 +87,11 @@ def x16_add(x, y):
def x16_sub(x, y): def x16_sub(x, y):
return (x - y) % 65536 return (x - y) % 65536
def x16_mul(x, y): def x16_mul(x, y):
return tofix(fromfix(x) * fromfix(y)) return ((x * y) // 256) % 65536
def x16_div(x, y): def x16_div(x, y):
return tofix(fromfix(x) / fromfix(y)) return ((x * 256) // y) % 65536
def x16_quot(x, y): def x16_quot(x, y):
n = x16_div(x, y) return x16_div(x, y) & 0xff00
if n < 0x7fff:
return n & 0xff00
elif n > 0x8001:
return (n + 255) & 0xff00
else:
return n
def x16_rem(x, y): def x16_rem(x, y):
return x % y return x % y
def x16_is_whole(x): def x16_is_whole(x):
@ -173,38 +147,33 @@ def x16_trunc8(x):
return floor(x / 256) return floor(x / 256)
def main(): def main():
trials = int(argv[1]) if argv[1:] else 100 trials = 1000
e = run(['uxnasm', 'test-fix16.tal', 'run.rom']) run(['uxnasm', 'test-fix16.tal', 'run.rom'])
if e.returncode != 0:
print('the command `uxnasm test-fix16.tal run.rom` failed!')
exit(e.returncode)
p = pipe() p = pipe()
test(p, trials, b'+', [('x', x16), ('y', x16)], x16, x16_add) test(p, trials, b'+', [('x', u16), ('y', u16)], u16, x16_add)
test(p, trials, b'-', [('x', x16), ('y', x16)], x16, x16_sub) test(p, trials, b'-', [('x', u16), ('y', u16)], u16, x16_sub)
test(p, trials, b'*', [('x', x16), ('y', x16)], x16, x16_mul) test(p, trials, b'*', [('x', u16), ('y', u16)], u16, x16_mul)
test(p, trials, b'/', [('x', x16), ('y', z16)], x16, x16_div) test(p, trials, b'/', [('x', u16), ('y', z16)], u16, x16_div, eq=releq)
test(p, trials, b'\\', [('x', x16), ('y', z16)], x16, x16_quot) test(p, trials, b'\\', [('x', u16), ('y', z16)], u16, x16_quot)
test(p, trials, b'%', [('x', x16), ('y', z16)], x16, x16_rem) test(p, trials, b'%', [('x', u16), ('y', z16)], u16, x16_rem)
test(p, trials, b'w', [('x', x16)], u8, x16_is_whole, eq=booleq) test(p, trials, b'w', [('x', u16)], u8, x16_is_whole, eq=booleq)
test(p, trials, b'N', [('x', x16)], x16, x16_negate) test(p, trials, b'N', [('x', u16)], u16, x16_negate)
test(p, trials, b'=', [('x', x16), ('y', x16)], u8, x16_eq) test(p, trials, b'=', [('x', u16), ('y', u16)], u8, x16_eq)
test(p, trials, b'!', [('x', x16), ('y', x16)], u8, x16_ne) test(p, trials, b'!', [('x', u16), ('y', u16)], u8, x16_ne)
test(p, trials, b'<', [('x', x16), ('y', x16)], u8, x16_lt) test(p, trials, b'<', [('x', u16), ('y', u16)], u8, x16_lt)
test(p, trials, b'>', [('x', x16), ('y', x16)], u8, x16_gt) test(p, trials, b'>', [('x', u16), ('y', u16)], u8, x16_gt)
test(p, trials, b'{', [('x', x16), ('y', x16)], u8, x16_lteq) test(p, trials, b'{', [('x', u16), ('y', u16)], u8, x16_lteq)
test(p, trials, b'}', [('x', x16), ('y', x16)], u8, x16_gteq) test(p, trials, b'}', [('x', u16), ('y', u16)], u8, x16_gteq)
test(p, trials, b'F', [('x', x16)], x16, x16_floor) test(p, trials, b'r', [('x', p16)], u16, x16_sqrt, eq=releq)
test(p, trials, b'C', [('x', x16)], x16, x16_ceil) test(p, trials, b's', [('x', p16)], u16, x16_sin, eq=abseq)
test(p, trials, b'R', [('x', x16)], x16, x16_round) test(p, trials, b'c', [('x', p16)], u16, x16_cos, eq=abseq)
test(p, trials, b'8', [('x', x16)], x16, x16_trunc8) test(p, trials, b't', [('x', t16)], u16, x16_tan, eq=taneq)
test(p, trials, b'T', [('x', x16)], x16, x16_trunc16) test(p, trials, b'l', [('x', p16)], u16, x16_log, eq=releq)
# the next five are known to be somewhat inaccurate and use test(p, trials, b'F', [('x', u16)], u16, x16_floor)
# a "relaxed" equality predicate for testing purposes. test(p, trials, b'C', [('x', u16)], u16, x16_ceil)
test(p, trials, b'r', [('x', p16)], x16, x16_sqrt, eq=releq) test(p, trials, b'R', [('x', u16)], u16, x16_round)
test(p, trials, b's', [('x', p16)], x16, x16_sin, eq=sineq) test(p, trials, b'8', [('x', u16)], u16, x16_trunc8)
test(p, trials, b'c', [('x', p16)], x16, x16_cos, eq=sineq) test(p, trials, b'T', [('x', u16)], u16, x16_trunc16)
test(p, trials, b't', [('x', t16)], x16, x16_tan, eq=taneq)
test(p, trials, b'l', [('x', p16)], x16, x16_log, eq=releq)
p.stdin.write(b'\n\n') p.stdin.write(b'\n\n')
p.stdin.flush() p.stdin.flush()
p.stdin.close() p.stdin.close()

98
test-fix32.tal
View File

@ -1,98 +0,0 @@
( test-fix32.tal )
( )
( methods for testing math32 and emitting output )
( TODO: consider rounding modes. currently we always round toward zero )
( program )
|0100
#00 x32-from-u8 x32-emit #0a18 DEO ( 0.0 )
#01 x32-from-u8 x32-emit #0a18 DEO ( 1.0 )
#0a x32-from-u8 x32-emit #0a18 DEO ( 10.0 )
#ff x32-from-u8 x32-emit #0a18 DEO ( 255.0 )
#0100 x32-from-u16 x32-emit #0a18 DEO ( 256.0 )
#1000 x32-from-u16 x32-emit #0a18 DEO ( 4096.0 )
#7fff x32-from-u16 x32-emit #0a18 DEO ( 32767.0 )
#8000 x32-from-u16 x32-emit #0a18 DEO ( 32768.0 )
#ffff x32-from-u16 x32-emit #0a18 DEO ( 65535.0 )
#01 x32-from-s8 x32-emit #0a18 DEO ( 10.0 )
#0a x32-from-s8 x32-emit #0a18 DEO ( 10.0 )
#80 x32-from-s8 x32-emit #0a18 DEO ( -128.0 )
#ff x32-from-s8 x32-emit #0a18 DEO ( -1.0 )
#0a18 DEO
#0000 #03e8 #0000 #07d0 LIT "+ ;x32-add #0000 #0bb8 test-binop ( 1 + 2 = 3 )
#ffff #fc18 #ffff #fc18 LIT "+ ;x32-add #ffff #f830 test-binop ( -1 + -1 = -2 )
#7fff #ffff #7fff #ffff LIT "+ ;x32-add #7fff #ffff test-binop ( inf + inf = inf )
#8000 #0001 #8000 #0001 LIT "+ ;x32-add #8000 #0001 test-binop ( -inf + -inf = -inf )
#0001 #e078 #ffff #a628 LIT "+ ;x32-add #0001 #86a0 test-binop ( 123.0 + -23.0 = 100.0 )
#0a18 DEO
#0000 #03e8 #0000 #03e8 LIT "* ;x32-mul #0000 #03e8 test-binop ( 1 * 1 = 1 )
#0000 #07d0 #0000 #0bb8 LIT "* ;x32-mul #0000 #1770 test-binop ( 2 * 3 = 6 )
#0000 #4a38 #0000 #6978 LIT "* ;x32-mul #0007 #d3d8 test-binop ( 19 * 27 = 513 )
#0000 #0064 #0000 #0064 LIT "* ;x32-mul #0000 #000a test-binop ( 0.1 * 0.1 = 0.01 )
#0000 #01f4 #0000 #0001 LIT "* ;x32-mul #0000 #0000 test-binop ( 0.5 * 0.001 = 0.0 )
#0000 #01f4 #0000 #0003 LIT "* ;x32-mul #0000 #0002 test-binop ( 0.5 * 0.003 = 0.002 )
#0000 #01f4 #0000 #0005 LIT "* ;x32-mul #0000 #0002 test-binop ( 0.5 * 0.005 = 0.002 )
#0000 #01f4 #0000 #0007 LIT "* ;x32-mul #0000 #0004 test-binop ( 0.5 * 0.007 = 0.004 )
#0000 #01f4 #0000 #0009 LIT "* ;x32-mul #0000 #0004 test-binop ( 0.5 * 0.009 = 0.004 )
#0000 #0bb8 #ffff #f830 LIT "* ;x32-mul #ffff #e890 test-binop ( 3 * -2 = -6 )
#ffff #fc18 #ffff #fc18 LIT "* ;x32-mul #0000 #03e8 test-binop ( -1 * -1 = 1 )
#0a18 DEO
#0000 #1d4c #0000 #05dc LIT "/ ;x32-div #0000 #1388 test-binop ( 7.5 / 1.5 = 5.0 )
#0000 #03e8 #0000 #0001 LIT "/ ;x32-div #000f #4240 test-binop ( 1.0 / 0.001 = 1000.0 )
#0000 #03e8 #0000 #0bb8 LIT "/ ;x32-div #0000 #014d test-binop ( 1.0 / 3.0 = 0.333 )
#0000 #07d0 #0000 #0bb8 LIT "/ ;x32-div #0000 #029b test-binop ( 2.0 / 3.0 = 0.667 )
#ffff #adf8 #0000 #1b58 LIT "/ ;x32-div #ffff #f448 test-binop ( -21.0 / 7.0 = -3.0 )
#0000 #0003 #0000 #07d0 LIT "/ ;x32-div #0000 #0002 test-binop ( 0.003 / 2 = 0.002 )
#0000 #0005 #0000 #07d0 LIT "/ ;x32-div #0000 #0002 test-binop ( 0.005 / 2 = 0.002 )
#0000 #0007 #0000 #07d0 LIT "/ ;x32-div #0000 #0004 test-binop ( 0.007 / 2 = 0.004 )
#0000 #0009 #0000 #07d0 LIT "/ ;x32-div #0000 #0004 test-binop ( 0.009 / 2 = 0.004 )
#ffff #fffd #0000 #07d0 LIT "/ ;x32-div #ffff #fffe test-binop ( -0.003 / 2 = -0.002 )
#ffff #fffb #0000 #07d0 LIT "/ ;x32-div #ffff #fffe test-binop ( -0.005 / 2 = -0.002 )
#ffff #fff9 #0000 #07d0 LIT "/ ;x32-div #ffff #fffc test-binop ( -0.007 / 2 = -0.004 )
#ffff #fff7 #0000 #07d0 LIT "/ ;x32-div #ffff #fffc test-binop ( -0.009 / 2 = -0.004 )
#0a18 DEO
#0000 #0001 x32-emit #0a18 DEO ( 0.001 )
#0000 #03e8 x32-emit #0a18 DEO ( 1.000 )
#0000 #0586 x32-emit #0a18 DEO ( 1.414 )
#0000 #0623 x32-emit #0a18 DEO ( 1.571 )
#0000 #06c4 x32-emit #0a18 DEO ( 1.732 )
#0000 #0a9e x32-emit #0a18 DEO ( 2.718 )
#0000 #0c46 x32-emit #0a18 DEO ( 3.142 )
#0000 #1268 x32-emit #0a18 DEO ( 4.712 )
#0000 #188b x32-emit #0a18 DEO ( 6.283 )
#0001 #0000 x32-emit #0a18 DEO ( 65.536 )
#0001 #e078 x32-emit #0a18 DEO ( 123.000 )
#0123 #4567 x32-emit #0a18 DEO ( 19088.743 )
#7fff #ffff x32-emit #0a18 DEO ( 2147483.647 )
#8000 #0001 x32-emit #0a18 DEO ( -2147483.647 )
#ffff #fc18 x32-emit #0a18 DEO ( -1.000 )
#ffff #ffff x32-emit #0a18 DEO ( -0.001 )
#800f DEO BRK
~fix32.tal
@test-binop ( x** y** op^ f* z** -> x** y** )
STH2 STH2 ,&f STR2 ,&op STR ( x** y** [z1* z0*] )
STH2 STH2 OVR2 OVR2 emit/long ( x** [z1* z0* y1* z0*] ; emit x )
#2018 DEO ( x** [z1* z0* y1* y0*] ; emit space )
LIT [ &op $1 ] #18 DEO ( x** [z1* z0* y1* y0*] ; emit operator symbol )
#2018 DEO ( x** [z1* z0* y1* y0*] ; emit space )
STH2r STH2r OVR2 OVR2 emit/long ( x** y** [z1* z0*] ; emit y )
#2018 DEO ( x** y** [z1* z0*] ; emit space )
LIT "= #18 DEO ( x** y** [z1* z0*] ; emit = )
#2018 DEO ( x** y** [z1* z0*] ; emit space )
LIT2 [ &f $2 ] JSR2 ( f[x,y]** [z1* z0*] )
emit/long ( [z1* z0*] ; emit f[x,y] )
STH2r STH2r #2018 DEO ( z** ; emit space )
LIT "[ #18 DEO ( z** ; emit [ )
emit/long ( ; emit z )
LIT "] #18 DEO ( ; emit ] )
#0a18 DEO JMP2r ( ; emit newline )
@emit
&long SWP2 /short
&short SWP ,&byte JSR
&byte DUP #04 SFT ,&char JSR
&char #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO
JMP2r

108
unihex2uf2
View File

@ -1,108 +0,0 @@
#!/usr/bin/env python3
import os
import re
import sys
line_re = re.compile(r'^([0-9A-Fa-f]{4}):((?:[0-9A-Fa-f]{32}){1,2})$')
def parse(line):
m = line_re.match(line)
if not m:
raise Exception('could not parse line: %r' % line)
n = int(m.group(1), 16)
data = m.group(2)
return (n, data)
blank_line = ' '.join(['00'] * 16)
def split16(data):
return ' '.join([data[i:i+2] for i in range(0, 32, 2)])
def split(data):
if len(data) == 32:
return (split16(data),)
elif len(data) == 64:
return (split16(data[0:32]), split16(data[32:64]))
else:
raise Exception('invalid data length: %d' % len(data))
def run(path, start):
limit = start + 256
widths = [8] * 256
lines = []
def emit(n, line1, line2):
lines.append(('( %04x ) ' % n) + line1)
lines.append(' ' + line2)
with open(path, 'r') as f:
seeking = start
for line in f:
n, data = parse(line.lower())
if n < seeking:
continue
if n > seeking:
for i in range(seeking, min(limit, seeking)):
emit(i, blank_line, blank_line)
if n >= limit:
break
tpl = split(data)
if len(tpl) == 1:
emit(n, tpl[0], blank_line)
widths[n - start] = 8
else:
emit(n, tpl[0], tpl[1])
widths[n - start] = 16
seeking = n + 1
for i in range(seeking, limit):
emit(i, blank_line, blank_line)
print('( unifont: %04x to %04x )' % (start, limit - 1))
print('')
print('( widths )')
for i in range(16):
j = i * 16
width_line = ' '.join([('%02x' % widths[k]) for k in range(j, j + 16)])
print(('( %04x ) ' % j) + width_line)
print('')
print('( font data, 2x2 tiles )')
for line in lines:
print(line)
def usage(message=None):
if message:
print('ERROR: %s' % message)
print('')
print('USAGE: %s PATH START' % sys.argv[0])
print('')
print(' PATH is a hex file, e.g. /usr/share/unifont/unifont.hex')
print(' START is a code point in hex, e.g. 0, 3c0, 7f00, etc.')
print('')
print(' each .uf2 file contains 256 characters, so the output')
print(' will contains widths and data for all characters from')
print(' START to START+255 (inclusive).')
print('')
sys.exit(1)
def main():
args = sys.argv[1:]
if len(args) != 2:
return usage()
path, start = args
if not os.path.exists(path):
return usage('could not read .hex file: %s' % path)
try:
n = int(start, 16)
except:
return usage('could not parse start character: %s' % start)
if n < 0:
return usage('start must be >= 0: %s' % start)
if n > 65280:
return usage('start must be <= ff00: %s' % start)
run(path, n)
if __name__ == "__main__":
main()

1215
uxnbot.lua Normal file
View File

File diff suppressed because it is too large Load Diff

155
uxnrepl.py
View File

@ -1,155 +0,0 @@
#!/usr/bin/python
from os import system
import re
from socket import socket, AF_INET, SOCK_STREAM
from subprocess import run, TimeoutExpired
from sys import argv, stdin, stdout
from tempfile import mkdtemp, mkstemp
sandbox = None
irc = None
template = '''
|0100
;on-console #10 DEO2
( start ) %s ( end ) BRK
@on-console ( -> BRK )
#05 DEI ,emit-wst/n STR
;wst print
@dump-wst
#04 DEI #01 GTH ?&next !emit-wst &next STH !dump-wst
@emit-wst
#05 DEI LIT [ &n $1 ] GTH ?&next #0a18 DEO !start-rst
&next STHr emit #2018 DEO !emit-wst
@start-rst
;rst print
@dump-rst
#05 DEI #00 GTH ?&next !emit-rst &next STHr !dump-rst
@emit-rst
#04 DEI #01 GTH ?&next #0a18 DEO #800f DEO BRK
&next emit #2018 DEO !emit-rst
@print ( addr* -> )
LDAk DUP ?{ POP POP2 JMP2r } #18 DEO INC2 !print
@emit
DUP #04 SFT ,&ch JSR
&ch #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO JMP2r
@rst "rst 20 00
@wst "wst 20 00
'''
def write_rom(path, s):
f = open(path, 'w')
prog = template % s
f.write(prog)
f.close()
def execute(s, sandbox=None, timeout=2.0):
_, tmp_tal = mkstemp(suffix='.tal', prefix='uxnrepl')
_, tmp_rom = mkstemp(suffix='.rom', prefix='uxnrepl')
write_rom(tmp_tal, s)
try:
res = run(['uxnasm', tmp_tal, tmp_rom], cwd=sandbox, capture_output=True, timeout=timeout)
except TimeoutExpired:
return b'uxnasm: timed out'
if res.returncode != 0:
return res.stderr
try:
res = run(['uxncli', tmp_rom, 'trigger'], cwd=sandbox, capture_output=True, timeout=timeout)
except TimeoutExpired:
return b'uxncli: timed out'
return res.stdout
def repl():
print('uxnrepl (ctrl-d to exit)')
while True:
stdout.write('> ')
stdout.flush()
s = stdin.readline()
if not s:
print('bye!')
break
stdout.write(execute(s).decode('utf-8'))
stdout.flush()
ping_re = re.compile(br'PING (.+)$')
def send(msg, quiet=False):
if not quiet:
print('>>> %r' % msg)
irc.send(msg + b'\r\n')
def recv():
msg = irc.recv(2040)
if not ping_re.match(msg):
print('<<< %r' % msg)
return msg
def evaluate(msg):
output = execute(msg.decode('utf-8'), sandbox=sandbox)
lines = [s.strip() for s in output.split(b'\n')]
interesting = [s for s in lines if s and s != 'wst' and s != 'rst']
result = b' | '.join(interesting)
print('*** executing %r gave %r -> %r -> %r' % (msg, output, interesting, result))
return result
def ircbot(server, nick, channel):
global sandbox, irc
sandbox = mkdtemp(prefix='uxnrepl')
irc = socket(AF_INET, SOCK_STREAM)
irc.connect((server, 6667))
send(b"USER %s %s %s :bot for testing uxntal code" % (nick, nick, nick))
send(b"NICK %s" % nick)
send(b"JOIN %s" % channel)
chan_msg_re = re.compile(br':([^!]+)![^ ]+ PRIVMSG ([^ ]+) :' + nick + br': (.*)$')
priv_msg_re = re.compile(br':([^!]+)![^ ]+ PRIVMSG ' + nick + br' :(.*)$')
while True:
text = recv()
m = ping_re.match(text)
if m:
send(b'PONG %s' % m.group(1).strip(), quiet=True)
continue
m = chan_msg_re.match(text)
if m and m.group(2) == channel:
user = m.group(1)
msg = m.group(3).strip()
result = evaluate(msg)
send(b'PRIVMSG %s :%s: %s' % (channel, user, result))
continue
m = priv_msg_re.match(text)
if m:
user = m.group(1)
msg = m.group(2).strip()
result = evaluate(msg)
send(b'PRIVMSG %s :%s' % (user, result))
continue
def main():
if argv[1:] == [] or argv[1:] == ["repl"]:
repl()
elif argv[1] == "bot" and len(argv) == 5:
server, nick, channel = argv[2:]
ircbot(server, nick.encode('utf-8'), channel.encode('utf-8'))
else:
print("usage: %s [repl]" % argv[0])
print(" %s bot <server> <nick> <channel>" % argv[0])
exit(1)
if __name__ == "__main__":
main()

363
uxntal.1
View File

@ -1,363 +0,0 @@
.\" Manpage reference for uxntal.
.\" by Eiríkr Åsheim
.\" Contact d_m@plastic-idolatry.com to correct errors or typos.
.TH uxntal 1 "05 Aug 2024" "1.0" "Uxntal Reference Guide"
.SH NAME
uxntal \- assembly langauge for Varvara virtual machine
.SH DESCRIPTION
Uxntal is an 8-bit instruction set for programming the Varvara virtual machine.
It uses the lower 5-bits to specify an opcode, and the upper 3-bits to specify
optional modes.
ROMs consist of a 16-bit address space of bytes. Any byte can be interpreted as either data or an instruction. A 2-byte program counter (\fIpc\fP) determines the address of the next instruction to decode and run.
Instructions manipulate data using two stacks: a working stack (\fBwst\fP) and a return stack (\fBrst\fP). Each stack consists of 256 bytes, and in the case of overflow or underflow the stack pointer will wrap (the stacks are circular).
There are also 256 bytes of device memory, which are used to interact with the virtual machine and its devices.
Instructions deal with unsigned 8-bit values (\fIbytes\fP) and unsigned 16-bit values (\fIshorts\fP). There are no other built-in data types.
.SH INSTRUCTION LAYOUT
0x01 ----
0x02 \\
0x04 +- \fIopcode\fP
0x08 /
0x10 ----
0x20 ---- 2: \fIshort mode\fP
0x40 ---- r: \fIreturn mode\fP
0x80 ---- k: \fIkeep mode\fP
.SH OPCODE LAYOUT
There are 32 base values for opcodes:
0x00 \fBBRK*\fP 0x08 \fBEQU\fP 0x10 \fBLDZ\fP 0x18 \fBADD\fP
0x01 \fBINC\fP 0x09 \fBNEQ\fP 0x11 \fBSTZ\fP 0x19 \fBSUB\fP
0x02 \fBPOP\fP 0x0a \fBGTH\fP 0x12 \fBLDR\fP 0x1a \fBMUL\fP
0x03 \fBNIP\fP 0x0b \fBLTH\fP 0x13 \fBSTR\fP 0x1b \fBDIV\fP
0x04 \fBSWP\fP 0x0c \fBJMP\fP 0x14 \fBLDA\fP 0x1c \fBAND\fP
0x05 \fBROT\fP 0x0d \fBJCN\fP 0x15 \fBSTA\fP 0x1d \fBORA\fP
0x06 \fBDUP\fP 0x0e \fBJSR\fP 0x16 \fBDEI\fP 0x1e \fBEOR\fP
0x07 \fBOVR\fP 0x0f \fBSTH\fP 0x17 \fBDEO\fP 0x1f \fBSFT\fP
The "complete" opcode's value can be derived by combining the base value with its flags.
For example, \fBADD2k\fP is \fB(ADD | 2 | k)\fP = \fB(0x18 | 0x20 | 0x80)\fP = \fB0xb8\fP.
Unlike other opcodes, \fB0x00\fP (\fBBRK*\fP) is contextual: its meaning depends on the \fImode\fP bits provided:
0x00 \fBBRK\fP 0x80 \fBLIT\fP
0x20 \fBJCI\fP 0xa0 \fBLIT2\fP
0x40 \fBJMI\fP 0xc0 \fBLITr\fP
0x60 \fBJSI\fP 0xe0 \fBLIT2r\fP
.SH STACK EFFECTS
.BR
.SS NOTATION
Given a stack effect \fB( a^ b^ c^ -- c^ a^ b^ )\fP here is what each symbol means:
\fB(\fP and \fB)\fP are comment delimiters
\fBa^\fP, \fBb^\fP, and \fBc^\fP are values on the stack
\fB^\fP indicates that each value is a \fIbyte\fP (\fB*\fP would indicate \fIshort\fP)
\fB--\fP separates the "before" and "after" of the stack effect
The effect here is to move the top byte of the stack below the next two bytes, which could be achieved with \fBROT ROT\fP.
By default stack effects describe the effect on \fBwst\fP. When \fBrst\fP is involved we use \fB[]\fP to differentiate the stacks. For example \fB( a* [b*] -- a+1* [b+1*] )\fP will increment the top short of both \fBwst\fP and \fBrst\fP.
.SS EFFECTS AND MODES
Regular instructions have a single stack effect which is modified in a predictable way by any additional modes.
For example the generic effect for \fBADD\fP is ( x y -- x+y ). The eight combinations of modes have the following effects:
\fBADD\fP ( x^ y^ -- x+y^ ) sum two bytes using \fBwst\fP
\fBADDr\fP ( [x^ y^] -- [x+y^] ) sum two bytes using \fBrst\fP
\fBADD2\fP ( x* y* -- x+y* ) sum two shorts using \fBwst\fP
\fBADD2r\fP ( [x* y*] -- [x+y*] ) sum two shorts using \fBrst\fP
\fBADDk\fP ( x^ y^ -- x^ y^ x+y^ ) sum two bytes using \fBwst\fP, retain arguments
\fBADDkr\fP ( [x^ y^] -- [x^ y^ x+y^] ) sum two bytes using \fBrst\fP, retain arguments
\fBADD2k\fP ( x* y* -- x* y* x+y* ) sum two shorts using \fBwst\fP, retain arguments
\fBADD2kr\fP ( [x* y*] -- [x* y* x+y*] ) sum two shorts using \fBrst\fP, retain arguments
Thus for regular instructions writing a "generic" effect (leaving sigils off values whose size depends on \fIshort mode\fP) is sufficient to describe its behavior across all eight variations. Note that some instructions always read values of a fixed size. For example the boolean condition read by \fBJCN\fP is always one byte, no matter what modes are used.
In \fIreturn mode\fP the stacks are reversed. Effects on \fBwst\fP will instead affect \fBrst\fP, and effects on \fBrst\fP will instead affect \fBwst\fP. For example, \fBSTH\fP reads a byte from \fBwst\fP and writes it to \fBrst\fP, but \fBSTHr\fP reads a byte from \fBrst\fP and writes it to \fBwst\fP.
In \fIkeep mode\fP all the values on the left-hand side of the stack effect will also appear on the right-hand side before the outputs. For example, \fBSWP\fP is \fB(x y -- y x)\fP but \fBSWPk\fP is \fB(x y -- x y y x)\fP.
.SS TERMINOLOGY
We consider the top of the stack to be the first value of the stack, and count back from there. For example, given the stack effect \fB( a b c -- )\fP we would say that \fBc\fP is the top of the stack, \fBb\fP is the second value (second from the top), and \fBa\fP is the third value (third from the top).
.SH REGULAR INSTRUCTIONS
.BR
.SS INC
( x -- x+1 )
Increment the top value of the stack by 1.
Overflow will be truncated, so \fB#ff INC\fP will evaluate to \fB0x00\fP.
.SS POP
( x -- )
Remove the top value of the stack.
\fBPOPk\fP is guaranteed to have no effect (it will not change the stack).
.SS NIP
( x y -- y )
Remove the second value of the stack.
\fBNIPk\fP is guaranteed to have no effect (it will not change the stack).
.SS SWP
( x y -- y x )
Swap the top two values of the stack.
.SS ROT
( x y z -- y z x )
Rotate the top three values of the stack. The lowest becomes the top and the others are each shifted down one place.
.SS DUP
( x -- x x )
Place a copy of the top value of the stack on top of the stack.
.SS OVR
( x y -- x y x )
Place a copy of the second value of the stack on top of the stack.
.SS EQU
( x y -- x==y^ )
Test whether the top two values of the stack are equal.
Result is guaranteed to be boolean (\fB0x00\fP or \fB0x01\fP).
.SS NEQ
( x y -- x!=y^ )
Test whether the top two values of the stack are not equal.
Result is guaranteed to be boolean (\fB0x00\fP or \fB0x01\fP).
.SS GTH
( x y -- x>y^ )
Test whether the second value of the stack is greater than the top.
Result is guaranteed to be boolean (\fB0x00\fP or \fB0x01\fP).
.SS LTH
( x y -- x<y^ )
Test whether the second value of the stack is less than the top.
Result is guaranteed to be boolean (\fB0x00\fP or \fB0x01\fP).
.SS JMP
( x -- ; pc <- x )
Jump to a location.
The program counter (\fIpc\fP) is unconditionally updated. When \fIx\fP is a byte, it is treated as relative (\fBpc += x\fP) and when \fIx\fP is a short it is treated as absolute (\fBpc = x\fP).
It is common to \fBJMP\fP with boolean bytes (0-1) to handle simple conditionals. For example:
@max ( x^ y^ -- max^ ) GTHk JMP SWP POP JMP2r
.SS JCN
( x bool^ -- ; pc <- x if bool )
Jump to a location when a condition is true.
The program counter (\fIpc\fP) is updated when \fIbool\fP is non-zero. When \fIx\fP is a byte, it is treated as relative (\fBpc += x\fP) and when \fIx\fP is a short it is treated as absolute (\fBpc = x\fP).
.SS JSR
( x -- [pc+1*] )
Jump to a location, saving a reference to return to.
Stores the next address to execute before unconditionally updating the program counter (\fIpc\fP). This instruction is usually used to invoke subroutines, which use the \fBJMP2r\fP to return. When \fIx\fP is a byte, it is treated as relative (\fBpc += x\fP) and when \fIx\fP is a short it is treated as absolute (\fBpc = x\fP).
The saved address will always be a short regardless of \fIshort mode\fP.
.SS STH
( x -- [x] )
Move the top value of the stack to the return stack.
.SS LDZ
( zp^ -- x )
Load data from a zero-page address (\fB0x00 - 0xff\fP).
.SS STZ
( x zp^ -- )
Store data at a zero-page address (\fB0x00 - 0xff\fP).
.SS LDR
( rel^ -- x )
Load data from a relative address (\fBpc + x\fP).
Note that unlike \fBLDZk\fP and \fBLDAk\fP the \fBLDRk\fP instruction is not very useful, since a relative address is usually only meaningful when run from a particular address (i.e. for a particular \fIpc\fP value).
.SS STR
( x rel^ -- )
Store data at a relative address (\fBpc + x\fP).
Note that unlike \fBSTZk\fP and \fBSTAk\fP the \fBSTRk\fP instruction is not very useful, since a relative address is usually only meaningful when run from a particular address (i.e. for a particular \fIpc\fP value).
.SS LDA
( abs* -- x )
Load data from an absolute address (\fB0x0000 - 0xffff\fP).
.SS STA
( x abs* -- )
Store data at an absolute address (\fB0x0000 - 0xffff\fP).
.SS DEI
( dev^ -- x )
Read data from a device port (\fB0x00 - 0xff\fP).
Reading from some ports may have an effect on the underlying VM; in other cases it will simply read values from device memory. See Varvara device documentation for more details.
.SS DEO
( x dev^ -- )
Write data to a device port (\fB0x00 - 0xff\fP).
Writing to some ports may have an effect on the underlying VM; in other cases it will simply write values to device memory. See Varvara device documentation for more details.
.SS ADD
( x y -- x+y )
Add the top two values of the stack.
Overflow will be truncated, so \fB#ff #03 ADD\fP will evaluate to \fB0x02\fP.
.SS SUB
( x y -- x-y )
Subtract the top of the stack from the second value of the stack.
Underflow will be truncated, so \fB#01 #03 SUB\fP will evaluate to \fB0xfe\fP.
.SS MUL
( x y -- xy )
Multiply the top two values of the stack.
Overflow will be truncated, so \fB#11 #11 MUL\fP will evaluate to \fB0x21\fP.
.SS DIV
( x y -- x/y )
Divide the second value of the stack by the top of the stack.
\fBDIV\fP implements \fIEuclidean division\fP, which is also known as \fIinteger division\fP. It returns whole numbers, so \fB#08 #09 DIV\fP evaluates to \fB0x00\fP.
Division by zero will return zero (instead of signaling an error).
Unlike \fBADD\fP, \fBSUB\fP, and \fBMUL\fP, \fBDIV\fP does not behave correctly for numbers which should be treated as signed. For example, the signed byte representation of \fB-2\fP is \fB0xfe\fP, but \fB#06 #fe DIV\fP evaluates to \fB0x00\fP (\fB6 / 254 = 0\fP). For signed values the correct result should instead be \fB0xfd\fP (\fB6 / -2 = -3\fP).
There is no \fIremainder\fP instruction, but the phrase \fBDIVk MUL SUB\fP can be used to compute the remainder.
.SS AND
( x y -- x&y )
Compute the bitwise union of the top two values of the stack.
.SS ORA
( x y -- x|y )
Compute the bitwise intersection of the top two values of the stack.
.SS EOR
( x y -- x^y )
Compute the bitwise exclusive-or (\fIxor\fP) of the top two values of the stack.
.SS SFT
( x rl^ -- (x>>l)<<r )
Compute a bit shift of the second value of the stack; the directions and distances are determined by the top value of the stack.
Given a byte \fIrl\fP consisting of a low nibble (\fIl\fP) and a high nibble (\fIr\fP), this instruction shifts \fIx\fP left by \fIl\fP and then right by \fIr\fP.
Right shifts are unsigned (they introduce zero bits). There are no signed shifts.
For 16-bit (and 8-bit) values, one nibble (\fB0x0 - 0xf\fP) is sufficient to express all useful left or right shifts.
Right: \fB#ff #03 SFT\fP evaluates to \fB0x1f\fP
Left: \fB#ff #20 SFT\fP evaluates to \fB0xfc\fP
Both: \fB#ff #23 SFT\fP evaluates to \fB0x7c\fP
.SH SPECIAL INSTRUCTIONS
These instructions do not accept all mode flags (some do not accept any).
.SS BRK
The break instruction is used to end a vector call and return control to the virtual machine.
.SS JCI, JMI, and JSI
The "immediate jump" instructions are produced by the assembler. They interpret the next 2 bytes of the ROM as a relative address (\fIaddr\fP) and have the following effects:
\fBJMI\fP ( -- ) jump to \fIaddr\fP unconditionally
\fBJCI\fP ( bool^ -- ) jump to \fIaddr\fP if \fIbool\fP is non-zero
\fBJSI\fP ( -- [pc*] ) jump to \fIaddr\fP saving the current address (\fIpc\fP) on the return stack
(The instruction pointer will be moved forward 2 bytes, past the relative address.)
These instructions are created by the assembler from special syntax:
\fB!dest\fP produces \fBJMI wx yz\fP
\fB?dest\fP produces \fBJCI wx yz\fP
\fBdest\fP produces \fBJSI wx yz\fP (assuming \fBdest\fP is not a macro or reserved)
.SS LIT, LIT2, LITr, and LIT2r
Push a literal value on the stack.
The "literal" instructions are used to push new data onto the stacks. They interpret the next 1-2 bytes of the ROM (\fIwx\fP, \fIwxyz\fP) as data and push it onto the corresponding stack:
\fBLIT\fP ( -- wx^ ) push literal byte \fIwx\fP onto the \fBwst\fP
\fBLITr\fP ( -- [wx^] ) push literal byte \fIwx\fP onto the \fBrst\fP
\fBLIT2\fP ( -- wxyz* ) push literal short \fIwxyz\fP (2 bytes) onto the \fBwst\fP
\fBLIT2r\fP ( -- [wxyz*] ) push literal short \fIwxyz\fP (2 bytes) onto the \fBrst\fP
(The instruction pointer will be moved forward 1-2 bytes, past the literal data.)
Literal values can be updated dynamically using store instructions:
#abcd ;x STA2
( later on... )
LIT2 [ @x $2 ]
.SH SEE ALSO
https://wiki.xxiivv.com/site/uxntal_opcodes.html \fIUxntal Opcodes\fP
https://wiki.xxiivv.com/site/uxntal_syntax.html \fIUxntal Syntax\fP
https://wiki.xxiivv.com/site/uxntal_modes.html \fIUxntal Modes\fP
https://wiki.xxiivv.com/site/uxntal_immediate.html \fIImmediate opcodes\fP
https://wiki.xxiivv.com/site/varvara.html \fIVarvara\fP

336
uxntal.7
View File

@ -1,336 +0,0 @@
.\" Manpage reference for uxntal.
.\" by Eiríkr Åsheim
.\" Contact d_m@plastic-idolatry.com to correct errors or typos.
.TH uxntal 7 "05 Aug 2024" "1.0" "Uxntal Reference Guide"
.SH NAME
uxntal \- assembly langauge for Varvara virtual machine
.SH DESCRIPTION
Uxntal is an 8-bit instruction set for programming the Varvara virtual machine.
It uses the lower 5-bits to specify an opcode, and the upper 3-bits to specify
optional modes.
ROMs consist of a 16-bit address space of bytes. Any byte can be interpreted as either data or an instruction. A 2-byte program counter (\fIpc\fP) determines the address of the next instruction to decode and run.
Instructions manipulate data using two stacks: a working stack (\fBwst\fP) and a return stack (\fBrst\fP). Each stack consists of 256 bytes, and in the case of overflow or underflow the stack pointer will wrap (the stacks are circular).
There are also 256 bytes of device memory, which are used to interact with the virtual machine and its devices.
Instructions deal with unsigned 8-bit values (\fIbytes\fP) and unsigned 16-bit values (\fIshorts\fP). There are no other built-in data types.
.SH INSTRUCTION LAYOUT
0x01 ----
0x02 \\
0x04 +- \fIopcode\fP
0x08 /
0x10 ----
0x20 ---- 2: \fIshort mode\fP
0x40 ---- r: \fIreturn mode\fP
0x80 ---- k: \fIkeep mode\fP
.SH OPCODE LAYOUT
There are 32 base values for opcodes:
0x00 \fBBRK*\fP 0x08 \fBEQU\fP 0x10 \fBLDZ\fP 0x18 \fBADD\fP
0x01 \fBINC\fP 0x09 \fBNEQ\fP 0x11 \fBSTZ\fP 0x19 \fBSUB\fP
0x02 \fBPOP\fP 0x0a \fBGTH\fP 0x12 \fBLDR\fP 0x1a \fBMUL\fP
0x03 \fBNIP\fP 0x0b \fBLTH\fP 0x13 \fBSTR\fP 0x1b \fBDIV\fP
0x04 \fBSWP\fP 0x0c \fBJMP\fP 0x14 \fBLDA\fP 0x1c \fBAND\fP
0x05 \fBROT\fP 0x0d \fBJCN\fP 0x15 \fBSTA\fP 0x1d \fBORA\fP
0x06 \fBDUP\fP 0x0e \fBJSR\fP 0x16 \fBDEI\fP 0x1e \fBEOR\fP
0x07 \fBOVR\fP 0x0f \fBSTH\fP 0x17 \fBDEO\fP 0x1f \fBSFT\fP
The "complete" opcode's value can be derived by combining the base value with its flags.
For example, \fBADD2k\fP is \fB(ADD | 2 | k)\fP = \fB(0x18 | 0x20 | 0x80)\fP = \fB0xb8\fP.
Unlike other opcodes, \fB0x00\fP (\fBBRK*\fP) is contextual: its meaning depends on the \fImode\fP bits provided:
0x00 \fBBRK\fP 0x80 \fBLIT\fP
0x20 \fBJCI\fP 0xa0 \fBLIT2\fP
0x40 \fBJMI\fP 0xc0 \fBLITr\fP
0x60 \fBJSI\fP 0xe0 \fBLIT2r\fP
.SH STACK EFFECTS
.BR
.SS NOTATION
Given a stack effect \fB( a^ b^ c^ -- c^ a^ b^ )\fP here is what each symbol means:
\fB(\fP and \fB)\fP are comment delimiters
\fBa^\fP, \fBb^\fP, and \fBc^\fP are values on the stack
\fB^\fP indicates that each value is a \fIbyte\fP (\fB*\fP would indicate \fIshort\fP)
\fB--\fP separates the "before" and "after" of the stack effect
The effect here is to move the top byte of the stack below the next two bytes, which could be achieved with \fBROT ROT\fP.
By default stack effects describe the effect on \fBwst\fP. When \fBrst\fP is involved we use \fB[]\fP to differentiate the stacks. For example \fB( a* [b*] -- a+1* [b+1*] )\fP will increment the top short of both \fBwst\fP and \fBrst\fP.
.SS EFFECTS AND MODES
Regular instructions have a single stack effect which is modified in a predictable way by any additional modes.
For example the generic effect for \fBADD\fP is ( x y -- x+y ). The eight combinations of modes have the following effects:
.nf
\fBADD\fP ( x^ y^ -- x+y^ ) sum bytes from \fBwst\fP
\fBADDr\fP ( [x^ y^] -- [x+y^] ) sum bytes from \fBrst\fP
\fBADD2\fP ( x* y* -- x+y* ) sum shorts from \fBwst\fP
\fBADD2r\fP ( [x* y*] -- [x+y*] ) sum shorts from \fBrst\fP
\fBADDk\fP ( x^ y^ -- x^ y^ x+y^ ) sum and keep bytes from \fBwst\fP
\fBADDkr\fP ( [x^ y^] -- [x^ y^ x+y^] ) sum and keep bytes from \fBrst\fP
\fBADD2k\fP ( x* y* -- x* y* x+y* ) sum and keep shorts from \fBwst\fP
\fBADD2kr\fP ( [x* y*] -- [x* y* x+y*] ) sum and keep shorts from \fBrst\fP
.fi
Thus for regular instructions writing a "generic" effect (leaving sigils off values whose size depends on \fIshort mode\fP) is sufficient to describe its behavior across all eight variations. Note that some instructions always read values of a fixed size. For example the boolean condition read by \fBJCN\fP is always one byte, no matter what modes are used.
In \fIreturn mode\fP the stacks are reversed. Effects on \fBwst\fP will instead affect \fBrst\fP, and effects on \fBrst\fP will instead affect \fBwst\fP. For example, \fBSTH\fP reads a byte from \fBwst\fP and writes it to \fBrst\fP, but \fBSTHr\fP reads a byte from \fBrst\fP and writes it to \fBwst\fP.
In \fIkeep mode\fP all the values on the left-hand side of the stack effect will also appear on the right-hand side before the outputs. For example, \fBSWP\fP is \fB(x y -- y x)\fP but \fBSWPk\fP is \fB(x y -- x y y x)\fP.
.SS TERMINOLOGY
We consider the top of the stack to be the first value of the stack, and count back from there. For example, given the stack effect \fB( a b c -- )\fP we would say that \fBc\fP is the top of the stack, \fBb\fP is the second value (second from the top), and \fBa\fP is the third value (third from the top).
.SH REGULAR INSTRUCTIONS
.BR
.SS INC ( x -- x+1 )
Increment the top value of the stack by 1.
Overflow will be truncated, so \fB#ff INC\fP will evaluate to \fB0x00\fP.
.SS POP ( x -- )
Remove the top value of the stack.
\fBPOPk\fP is guaranteed to have no effect (it will not change the stack).
.SS NIP ( x y -- y )
Remove the second value of the stack.
\fBNIPk\fP is guaranteed to have no effect (it will not change the stack).
.SS SWP ( x y -- y x )
Swap the top two values of the stack.
.SS ROT ( x y z -- y z x )
Rotate the top three values of the stack. The lowest becomes the top and the others are each shifted down one place.
.SS DUP ( x -- x x )
Place a copy of the top value of the stack on top of the stack.
.SS OVR ( x y -- x y x )
Place a copy of the second value of the stack on top of the stack.
.SS EQU ( x y -- x==y^ )
Test whether the top two values of the stack are equal.
Result is guaranteed to be boolean (\fB0x00\fP or \fB0x01\fP).
.SS NEQ ( x y -- x!=y^ )
Test whether the top two values of the stack are not equal.
Result is guaranteed to be boolean (\fB0x00\fP or \fB0x01\fP).
.SS GTH ( x y -- x>y^ )
Test whether the second value of the stack is greater than the top.
Result is guaranteed to be boolean (\fB0x00\fP or \fB0x01\fP).
.SS LTH ( x y -- x<y^ )
Test whether the second value of the stack is less than the top.
Result is guaranteed to be boolean (\fB0x00\fP or \fB0x01\fP).
.SS JMP ( x -- ; pc <- x )
Jump to a location.
The program counter (\fIpc\fP) is unconditionally updated. When \fIx\fP is a byte, it is treated as relative (\fBpc += x\fP) and when \fIx\fP is a short it is treated as absolute (\fBpc = x\fP).
It is common to \fBJMP\fP with boolean bytes (0-1) to handle simple conditionals. For example:
@max ( x^ y^ -- max^ ) GTHk JMP SWP POP JMP2r
.SS JCN ( x bool^ -- ; pc <- x if bool )
Jump to a location when a condition is true.
The program counter (\fIpc\fP) is updated when \fIbool\fP is non-zero. When \fIx\fP is a byte, it is treated as relative (\fBpc += x\fP) and when \fIx\fP is a short it is treated as absolute (\fBpc = x\fP).
.SS JSR ( x -- [pc+1*] )
Jump to a location, saving a reference to return to.
Stores the next address to execute before unconditionally updating the program counter (\fIpc\fP). This instruction is usually used to invoke subroutines, which use the \fBJMP2r\fP to return. When \fIx\fP is a byte, it is treated as relative (\fBpc += x\fP) and when \fIx\fP is a short it is treated as absolute (\fBpc = x\fP).
The saved address will always be a short regardless of \fIshort mode\fP.
.SS STH ( x -- [x] )
Move the top value of the stack to the return stack.
.SS LDZ ( zp^ -- x )
Load data from a zero-page address (\fB0x00 - 0xff\fP).
.SS STZ ( x zp^ -- )
Store data at a zero-page address (\fB0x00 - 0xff\fP).
.SS LDR ( rel^ -- x )
Load data from a relative address (\fBpc + x\fP).
Note that unlike \fBLDZk\fP and \fBLDAk\fP the \fBLDRk\fP instruction is not very useful, since a relative address is usually only meaningful when run from a particular address (i.e. for a particular \fIpc\fP value).
.SS STR ( x rel^ -- )
Store data at a relative address (\fBpc + x\fP).
Note that unlike \fBSTZk\fP and \fBSTAk\fP the \fBSTRk\fP instruction is not very useful, since a relative address is usually only meaningful when run from a particular address (i.e. for a particular \fIpc\fP value).
.SS LDA ( abs* -- x )
Load data from an absolute address (\fB0x0000 - 0xffff\fP).
.SS STA ( x abs* -- )
Store data at an absolute address (\fB0x0000 - 0xffff\fP).
.SS DEI ( dev^ -- x )
Read data from a device port (\fB0x00 - 0xff\fP).
Reading from some ports may have an effect on the underlying VM; in other cases it will simply read values from device memory. See Varvara device documentation for more details.
.SS DEO ( x dev^ -- )
Write data to a device port (\fB0x00 - 0xff\fP).
Writing to some ports may have an effect on the underlying VM; in other cases it will simply write values to device memory. See Varvara device documentation for more details.
.SS ADD ( x y -- x+y )
Add the top two values of the stack.
Overflow will be truncated, so \fB#ff #03 ADD\fP will evaluate to \fB0x02\fP.
.SS SUB ( x y -- x-y )
Subtract the top of the stack from the second value of the stack.
Underflow will be truncated, so \fB#01 #03 SUB\fP will evaluate to \fB0xfe\fP.
.SS MUL ( x y -- xy )
Multiply the top two values of the stack.
Overflow will be truncated, so \fB#11 #11 MUL\fP will evaluate to \fB0x21\fP.
.SS DIV ( x y -- x/y )
Divide the second value of the stack by the top of the stack.
\fBDIV\fP implements \fIEuclidean division\fP, which is also known as \fIinteger division\fP. It returns whole numbers, so \fB#08 #09 DIV\fP evaluates to \fB0x00\fP.
Division by zero will return zero (instead of signaling an error).
Unlike \fBADD\fP, \fBSUB\fP, and \fBMUL\fP, \fBDIV\fP does not behave correctly for numbers which should be treated as signed. For example, the signed byte representation of \fB-2\fP is \fB0xfe\fP, but \fB#06 #fe DIV\fP evaluates to \fB0x00\fP (\fB6 / 254 = 0\fP). For signed values the correct result should instead be \fB0xfd\fP (\fB6 / -2 = -3\fP).
There is no \fIremainder\fP instruction, but the phrase \fBDIVk MUL SUB\fP can be used to compute the remainder.
.SS AND ( x y -- x&y )
Compute the bitwise union of the top two values of the stack.
.SS ORA ( x y -- x|y )
Compute the bitwise intersection of the top two values of the stack.
.SS EOR ( x y -- x^y )
Compute the bitwise exclusive-or (\fIxor\fP) of the top two values of the stack.
.SS SFT ( x rl^ -- (x>>l)<<r )
Compute a bit shift of the second value of the stack; the directions and distances are determined by the top value of the stack.
Given a byte \fIrl\fP consisting of a low nibble (\fIl\fP) and a high nibble (\fIr\fP), this instruction shifts \fIx\fP left by \fIl\fP and then right by \fIr\fP.
Right shifts are unsigned (they introduce zero bits). There are no signed shifts.
For 16-bit (and 8-bit) values, one nibble (\fB0x0 - 0xf\fP) is sufficient to express all useful left or right shifts.
Right: \fB#ff #03 SFT\fP evaluates to \fB0x1f\fP
Left: \fB#ff #20 SFT\fP evaluates to \fB0xfc\fP
Both: \fB#ff #23 SFT\fP evaluates to \fB0x7c\fP
.SH SPECIAL INSTRUCTIONS
These instructions do not accept all mode flags (some do not accept any).
.SS BRK
The break instruction is used to end a vector call and return control to the virtual machine.
.SS JCI, JMI, and JSI
The "immediate jump" instructions are produced by the assembler. They interpret the next 2 bytes of the ROM as a relative address (\fIaddr\fP) and have the following effects:
\fBJMI\fP ( -- ) jump to \fIaddr\fP unconditionally
\fBJCI\fP ( bool^ -- ) jump to \fIaddr\fP if \fIbool\fP is non-zero
\fBJSI\fP ( -- [pc*] ) jump to \fIaddr\fP saving the current address (\fIpc\fP) on \fIrst\fP
(The instruction pointer will be moved forward 2 bytes, past the relative address.)
These instructions are created by the assembler from special syntax:
\fB!dest\fP produces \fBJMI wx yz\fP
\fB?dest\fP produces \fBJCI wx yz\fP
\fBdest\fP produces \fBJSI wx yz\fP (assuming \fBdest\fP is not a macro or reserved)
.SS LIT, LIT2, LITr, and LIT2r
Push a literal value on the stack.
The "literal" instructions are used to push new data onto the stacks. They interpret the next 1-2 bytes of the ROM (\fIwx\fP, \fIwxyz\fP) as data and push it onto the corresponding stack:
\fBLIT\fP ( -- wx^ ) push literal byte \fIwx\fP onto the \fBwst\fP
\fBLITr\fP ( -- [wx^] ) push literal byte \fIwx\fP onto the \fBrst\fP
\fBLIT2\fP ( -- wxyz* ) push literal short \fIwxyz\fP (2 bytes) onto the \fBwst\fP
\fBLIT2r\fP ( -- [wxyz*] ) push literal short \fIwxyz\fP (2 bytes) onto the \fBrst\fP
(The instruction pointer will be moved forward 1-2 bytes, past the literal data.)
Literal values can be updated dynamically using store instructions:
#abcd ;x STA2
( later on... )
LIT2 [ @x $2 ]
.SH SEE ALSO
https://wiki.xxiivv.com/site/uxntal_opcodes.html \fIUxntal Opcodes\fP
https://wiki.xxiivv.com/site/uxntal_syntax.html \fIUxntal Syntax\fP
https://wiki.xxiivv.com/site/uxntal_modes.html \fIUxntal Modes\fP
https://wiki.xxiivv.com/site/uxntal_immediate.html \fIImmediate opcodes\fP
https://wiki.xxiivv.com/site/varvara.html \fIVarvara\fP

148
wave.tal
View File

@ -37,8 +37,10 @@
( |00 @System [ &vec $2 &wst $1 &rst $1 &pad $4 &r $2 &g $2 &b $2 &dbg $1 &halt $1 ] ) ( |00 @System [ &vec $2 &wst $1 &rst $1 &pad $4 &r $2 &g $2 &b $2 &dbg $1 &halt $1 ] )
|10 @Console [ &vec $2 &read $1 &pad $5 &out $1 &err $1 ] |10 @Console [ &vec $2 &read $1 &pad $5 &out $1 &err $1 ]
|30 @Audio0 [ &vec $2 &pos $2 &out $1 &dur $2 &pad $1 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ] |30 @Audio0 [ &vec $2 &pos $2 &out $1 &pad $3 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|40 @Audio1 [ &vec $2 &pos $2 &out $1 &dur $2 &pad $1 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ] |40 @Audio1 [ &vec $2 &pos $2 &out $1 &pad $3 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|50 @Audio2 [ &vec $2 &pos $2 &out $1 &pad $3 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|60 @Audio3 [ &vec $2 &pos $2 &out $1 &pad $3 &adsr $2 &len $2 &addr $2 &vol $1 &pitch $1 ]
|a0 @File [ &vec $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ] |a0 @File [ &vec $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|0000 |0000
@ -75,10 +77,10 @@
&done &done
LIT2 =reload/resample STA2 ( ; save resample function ) LIT2 =reload/resample STA2 ( ; save resample function )
LIT2r =reload/sft STAr ( ; save shift size ) LIT2r =reload/sft STAr ( ; save shift size )
#2274 .File/len DEO2 #2000 .File/len DEO2
#2274 DUP2 ;a/len STA2 DUP2 ;a/l-buf zero-buf-u8 DUP2 ;a/r-buf zero-buf-u8 #2000 ;len0 STA2 #2000 ;buf0 zero-buf-u8
DUP2 ;b/len STA2 DUP2 ;b/l-buf zero-buf-u8 ;b/r-buf zero-buf-u8 #2000 ;len1 STA2 #2000 ;buf1 zero-buf-u8
!play-a !play0
@zero-buf-u8 ( len* buf* -> ) @zero-buf-u8 ( len* buf* -> )
STH2k ADD2 STH2 SWP2r ( [limit=buf+len* buf*] ) STH2k ADD2 STH2 SWP2r ( [limit=buf+len* buf*] )
@ -103,96 +105,68 @@
@hdr-eq2 ( offset* v* -> eq^ ) @hdr-eq2 ( offset* v* -> eq^ )
STH2 ;header ADD2 LDA2 STH2r EQU2 JMP2r STH2 ;header ADD2 LDA2 STH2r EQU2 JMP2r
@reload ( l-addr* bl-addr* br-addr* -> ) @reload ( l-addr* b-addr* -> )
SWP2 STH2 STH2 ( l-addr* [bl-addr* br-addr*] ) .done LDZ ?&skip ( l-addr* b-addr* )
.done LDZ ?&skip ( l-addr* [bl-addr* br-addr*] ) SWP2 ( b-addr* l-addr* )
;scratch .File/r DEO2 ( l-addr* [bl-addr* br-addr*] ) ;scratch .File/r DEO2 ( b-addr* l-addr* )
.File/ok DEI2 ( l-addr* read* [bl-addr* br-addr*] ) .File/ok DEI2 ( b-addr* l-addr* read* )
DUP2 LIT &sft $1 SFT2 ( l-addr* read* read>>sft [bl-addr* br-addr*] ) DUP2 LIT &sft $1 SFT2 ( b-addr* l-addr* read* read>>sft )
ROT2 STA2 ( read* [bl-addr* br-addr*] ; l-addr<-read>>sft ) ROT2 STA2 ( b-addr* read* ; l-addr<-read>>sft )
DUP2 #2274 EQU2 ?&end ( read* [bl-addr* br-addr*] ; if we read 0x2274 we are not done ) DUP2 #2000 EQU2 ?&end ( b-addr* read* ; if we read 0x2000 we are not done )
#01 .done STZ ( read* [bl-addr* br-addr*] ; done<-1 ) #01 .done STZ ( b-addr* read* ; done<-1 )
&end ( read* [bl-addr* br-addr*] ) &end ( b-addr* read* )
;scratch ( read* scratch* [bl-addr* br-addr*] ) SWP2 STH2 ;scratch ( read* scratch* [b-addr*] )
DUP2 ROT2 ADD2 SWP2 ( limit=scratch+read* scratch* [bl-addr* br-addr*] ) DUP2 ROT2 ADD2 SWP2 ( limit=scratch+read* scratch* [b-addr*] )
INC2 ( limit* scratch+1* [bl-addr* br-addr*] ) INC2 ( limit* scratch+1* [b-addr*] )
&loop ( limit* pos* [bl-pos* br-pos*] ) &loop ( limit* pos* [bpos*] )
LIT2 [ &resample $2 ] JSR2 ( limit* pos+n* l-sample^ r-sample^ [bl-pos* br-pos*] ) LIT2 &resample $2 JSR2 ( limit* pos+n* sample^ [bpos*] )
STH2kr STA INC2 SWP2r ( limit* pos+n* [br-pos+1* bl-pos*] ; br-pos<-sample ) STH2kr STA ( limit* pos+n* [bpos*] ; bpos<-sample )
STH2kr STA INC2 SWP2r ( limit* pos+n* [bl-pos+1* br-pos+1*] ; bl-pos<-sample ) INC2r GTH2k ?&loop ( limit* pos+n* [bpos+1*] )
GTH2k ?&loop ( limit* pos+n* [bl-pos+1* br-pos+1*] ) POP2r ( limit* pos+n* )
POP2r POP2r POP2 POP2 JMP2r ( ) POP2 POP2 JMP2r
&skip ( l-addr* [bl-addr* br-addr*] ) &skip ( )
#2274 DUP2 STH2r zero-buf-u8 ( l-addr* #2274 [bl-addr*] ; clear br-addr ) #2000 SWP2 zero-buf-u8 ( )
DUP2 STH2r zero-buf-u8 ( l-addr* #2274 ; clear bl-addr ) #2000 SWP2 STA2 JMP2r ( )
SWP2 STA2 JMP2r ( ; l-addr<-2274 )
@mono-u8-to-u8 ( pos* -> pos+1* l-sample^ r-sample^ ) @mono-u8-to-u8 ( pos* -> pos+1* sample^ )
LDAk STH INC2 ( pos+1* [s^] ) LDAk STH INC2 STHr JMP2r
STHr DUP JMP2r ( pos+1 l-s^ r-s^ )
@mono-s16-to-u8 ( pos* -> pos+2* l-sample^ r-sample^ ) @mono-s16-to-u8 ( pos* -> pos+2* sample^ )
LDAk #80 ADD STH INC2 INC2 ( pos+2* [s^] ) LDAk #80 EOR STH INC2 INC2 STHr JMP2r
STHr DUP JMP2r ( pos+2* l-s^ r-s^ )
@stereo-u8-to-u8 ( pos* -> pos+2* l-sample^ r-sample^ ) @stereo-u8-to-u8 ( pos* -> pos+2* sample^ )
INC2k SWP2 LDA STH ( pos+1* [l-s^] ) LDAk #00 SWP STH2 INC2
INC2k SWP2 LDA STH ( pos+2* [l-s^ r-s^] ) LDAk #00 SWP STH2 INC2
STH2r JMP2r ( pos+2* l-s^ r-s^ ) ADD2r LITr 01 SFT2r NIPr STHr JMP2r
@stereo-s16-to-u8 ( pos* -> pos+4* sample^ ) @stereo-s16-to-u8 ( pos* -> pos+4* sample^ )
LDAk #80 ADD STH INC2 INC2 ( pos+2* [l-s^] ) LDAk #80 EOR #00 SWP STH2 INC2 INC2
LDAk #80 ADD STH INC2 INC2 ( pos+4* [l-s^ r-s^] ) LDAk #80 EOR #00 SWP STH2 INC2 INC2
STH2r JMP2r ( pos+4* l-s^ r-s^ ) ADD2r LITr 01 SFT2r NIPr STHr JMP2r
@play-a ( -> ) ;play-b ;a !play-base @play0 ( -> ) ;play1 ;len0 ;buf0 !play
@play-b ( -> ) ;play-a ;b !play-base @play1 ( -> ) ;play0 ;len1 ;buf1 !play
@play-base ( next* base* -> ) @play ( next* l-addr* b-addr* -> )
SWP2 .Audio0/vec DEO2 ( base* ; vec<-next ) OVR2 LDA2 ORAk ?&nonzero ( next* l-addr* b-addr* n* )
INC2k INC2 STH2k ( l-addr* lb-addr* [lb-addr*] ) POP2 POP2 POP2 POP2 ( ; clear stack )
#2274 ADD2 STH2 ( l-addr* [lb-addr* rb-addr*] ) #010f BRK ( ; exit )
( LDA2k ORAk ?&non-zero ( l-addr* n* [lb-addr* rb-addr*] ) &nonzero ( next* l-addr b-addr* n* )
POP2 POP2 POP2r POP2r ( ; clear stack ) OVR2 output ( next* l-addr b-addr* ; play buf1 )
#010f BRK ( ; exit ) reload ( next* ; load more data )
&non-zero ( l-addr* n* [lb-addr* rb-addr*] ) ) .Audio0/vec DEO2 ( ; Audio0/vec<-next )
DUP2 STH2kr r-output SWP2r ( l-addr* n* [rb-addr* lb-addr*] ; play rb-addr ) BRK ( )
STH2kr l-output SWP2r ( l-addr* [lb-addr* rb-addr*] ; play lb-addr )
SWP2r STH2r STH2r reload BRK ( ; load more data )
@bytes-to-millis ( samples* -> ms* ) @output ( len* addr* -> )
#01b9 DIV2 #000a MUL2 JMP2r .Audio0/addr DEO2 ( ; <- write buf addr )
.Audio0/len DEO2 ( ; <- write len )
@l-output ( len* addr* -> ) #0000 .Audio0/adsr DEO2 ( ; <- write ignore envelope )
.Audio0/addr DEO2 ( ; <- write buf addr ) #ff .Audio0/vol DEO ( ; <- play 100% volume )
DUP2 .Audio0/len DEO2 ( ; <- write length in bytes/samples ) #bc .Audio0/pitch DEO ( ; <- play standard sample once )
bytes-to-millis .Audio0/dur DEO2 ( ; <- write duration in milliseconds )
#00f0 .Audio0/adsr DEO2 ( ; <- write ignore envelope )
#f0 .Audio0/vol DEO ( ; <- play 100% volume )
#bc .Audio0/pitch DEO ( ; <- play standard sample once )
JMP2r JMP2r
@r-output ( len* addr* -> )
.Audio1/addr DEO2 ( ; <- write buf addr )
DUP2 .Audio1/len DEO2 ( ; <- write length in bytes/samples )
bytes-to-millis .Audio1/dur DEO2 ( ; <- write duration in milliseconds )
#00f0 .Audio1/adsr DEO2 ( ; <- write ignore envelope )
#0f .Audio1/vol DEO ( ; <- play 100% volume )
#bc .Audio1/pitch DEO ( ; <- play standard sample once )
JMP2r
( buffer size is 0x2274, i.e. 8820. )
( this is an important number: 8820 = 4 * 5 * 441. )
( since it is divisible by 4 we know that the buffer will read )
( an exact number of samples, even with 16-bit stereo. and since )
( it is divisble by 441 we know it will always contain a multiple )
( 10 milliseconds of audio. these assumptions help ensure we don't )
( end up with static, popping, or other problems. )
@filename $100 @filename $100
@header $2c @header $2c
( @len0 $2 @buf0 $2274 @len0 $2 @buf0 $2000
@len1 $2 @buf1 $2274 ) @len1 $2 @buf1 $2000
@scratch $2274 @scratch $2000
@a [ &len $2 &l-buf $2274 &r-buf $2274 ]
@b [ &len $2 &l-buf $2274 &r-buf $2274 ]

315
zenochat.tal
View File

@ -1,315 +0,0 @@
( zenochat.tal )
( )
( USAGE: uxnemu zenochat.rom ADDR PORT NICK )
( )
( COMMANDS DESCRIPTION )
( /help show help message )
( /names list the current people in the chat )
( /rename NICK change nickname to NICK )
( /quit exit the program )
( )
( DETAILS )
( - max nickname is 8 characters long, not including null )
( - no history, no scrolling )
( - no direct messages, yet )
( )
( MESSAGES )
( - 27 visible lines, 80 chars per line )
( - 5 chars: time "12:34" )
( - 1 char: space )
( - 8 chars: username "theodore" )
( - 1 char: space )
( - 65 chars: message line )
( )
( HISTORY LINE )
( - each history line is 80 bytes )
( - 1 byte: flags, 0x80 is-system, 0x01 is-continued )
( - 2 bytes: padding )
( - 2 bytes: hour [0-23] and minute [0-59] )
( - 9 bytes: nickname + null terminator; empty means system )
( - 66 bytes: text + null terminator )
( - window dimensions: 30 rows by 80 columns )
( - 27 visible lines; 65 text columns )
( )
( USER LIST )
( - 9 bytes, nickname + null terminator )
|00 @System [ &vect $2 &expansion $2 &title $2 &metadata $2 &r $2 &g $2 &b $2 &dbg $1 &st $1 ]
|10 @Console [ &vect $2 &r $1 &pad $4 &type $1 &w $1 &e $1 ]
|20 @Screen [ &vect $2 &w $2 &h $2 &auto $1 &pad $1 &x $2 &y $2 &addr $2 &px $1 &sprite $1 ]
|80 @Controller [ &vect $2 &button $1 &key $1 &fn $1 ]
|90 @Mouse [ &vect $2 &x $2 &y $2 &state $1 &pad $3 &scrollx $2 &scrolly $2 ]
|a0 @File1 [ &vect $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|b0 @File2 [ &vect $2 &ok $2 &stat $2 &del $1 &append $1 &name $2 &len $2 &r $2 &w $2 ]
|c0 @DateTime [ &year $2 &month $1 &day $1 &hr $1 &min $1 &sec $1 &dotw $1 &doty $2 &dst $1 ]
|0000
@pos $2
@dirty $1
@last-sec $1
|0100
( system settings )
#0280 .Screen/w DEO2
#0168 .Screen/h DEO2
#27ff .System/r DEO2
#039b .System/g DEO2
#1107 .System/b DEO2
( zero page )
#01 .dirty STZ
;input .pos STZ2
( vectors )
;on-refresh .Screen/vect DEO2
;on-key .Controller/vect DEO2
;read-args .Console/vect DEO2
BRK
@usage "usage: 20 "zenochat.rom 20 "chat.server.net 20 "9999 20 "nick 0a 00
@usage-and-exit ( -> BRK )
;usage emit #01 .System/st DEO BRK
@read-arg ( -> BRK )
.Console/r DEI .pos LDZ2 STA
.pos LDZ2k INC2 ROT STZ2 BRK
@save-arg ( dst* maxlen* -> )
#00 .pos LDZ2 STA
.pos LDZ2 ;input SUB2
LTH2 ?usage-and-exit
;input emit #0a18 DEO
;input SWP2 copy
;input .pos STZ2 JMP2r
@read-args ( -> BRK )
.Console/type DEI #00 EQU ?usage-and-exit
.Console/type DEI #01 EQU ?usage-and-exit
.Console/type DEI #02 EQU ?read-arg
( state is 3 or 4 )
;addr LDA #00 EQU ?&addr
;port LDA #00 EQU ?&port
;nick LDA #00 EQU ?&nick
!usage-and-exit
&addr ;addr #00ff save-arg BRK
&port ;port #0005 save-arg BRK
&nick ;nick #000f save-arg
.Console/type DEI #04 NEQ ?usage-and-exit
;read-stdin .Console/vect DEO2
BRK
@read-stdin ( -> BRK ) BRK
@start-client ( -> BRK ) BRK
@update-clock ( -> )
LITr -last-sec STHkr LDZ ( ls^ [zp^] )
.DateTime/sec DEI DUP STHr STZ ( ls^ s^ ; zp<-s )
NEQ .dirty STZ JMP2r ( ; dirty<-s!=ls )
@on-refresh ( -> BRK )
update-clock
.dirty LDZ ?&refresh BRK
&refresh
redraw
#00 .dirty STZ BRK
@on-key ( -> BRK )
.Controller/key DEI
DUP #0d EQU ?&enter
DUP #08 EQU ?&backspace
DUP #20 LTH ?&skip
DUP #7f GTH ?&skip
.pos LDZ2 STA
.pos LDZ2 INC2 .pos STZ2
#00 .pos LDZ2 STA redraw BRK
&enter POP send-msg redraw BRK
&skip POP BRK
&backspace
;input .pos LDZ2 EQU2 ?&skip
POP
.pos LDZ2 #0001 SUB2 .pos STZ2
#00 .pos LDZ2 STA #0028 #015c #4b clear-line redraw BRK
@clear-line ( x* y* len^ -> )
#00 SWP SUB STH ( x* y* [-len^] )
.Screen/y DEO2 .Screen/x DEO2 ( [-len^] )
&loop ( [-i^] )
#03 #20 draw-char ( [-i^] )
.Screen/x DEI2k ( dev^ x* [-i^] )
#0008 ADD2 ROT DEO2 ( [-i^] ; dev<-x+8 )
INCr STHkr ?&loop ( [-i+1^] )
POPr JMP2r ( )
@send-msg
( ;input .pos LDZ2 #010e DEO POP2 POP2 )
!clear-input
@clear-input ( -> )
#0028 #015c #4b clear-line
#0000 ;input STA2
;input .pos STZ2 JMP2r
( TODO: write to intermediary buffers, then write to final topbar buffer )
( this will allow us to handle "long" strings better, e.g. hostnames )
( also consider reorder fields, put people before address )
( write clock last unconditionally with leading space + glyph )
@gui
&topbar
20 15 20 "z "e "n "o "c "h "a "t 20
20 02 20
&username
"c "a "r "o "l "i "n "e 20
20 03 20
&users
"1 "2 "9 20 "p "e "o "p "l "e 20
20 1d 20
&server
( 2001:0db8:85a3:0000:0000:8a2e:0370:7334 - 39 characters long )
( fe80::3210:b3ff:fe77:c5c6/64 )
( 123.156.189.123 - 15 characters long )
"1 "2 "3 ". "1 "5 "6 ". "1 "8 "9 ". "1 "2 "3 20 "1 "9 "9 "9 "9 20 20 20 20 20 20
20 0f 20
&hour
"2 "2 ":
&minute
"0 "3 ":
&second
"0 "9
20 00
&separator
cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd
cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd
cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd
cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd
cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd cd
00
&time1 "21:58 20 00
&u1 "alice 20 00
&msg1 "Isn't 20 "this 20 "whole 20 "thing 20 "kind 20 "of 20 "weird? 00
&time2 "21:59 20 00
&u2 "bob 20 00
&msg2 "Nah. 00
&info1 20 c4 c4 20 "013 20 "has 20 "connected 20 c4 c4 00
&time3 "22:02 20 00
&u3 "caroline 20 00
&msg3 "Well, 20 "I 20 "do 20 "think 20 "it's 20 "pretty 20 "wild... 00
&info2 20 c4 c4 20 "013 20 "is 20 "now 20 "called 20 "danny 20 c4 c4 00
&say "Say: 20 00
&edit "This 20 "is 20 "a 20 "test. 00
@draw-str-at ( tint^ s* x* y* -> )
.Screen/y DEO2 .Screen/x DEO2 !draw-str
@two-digit-copy ( n^ s* -> )
STH2 DUP #0a DIVk MUL SUB ( n^ n%10^ [s*] )
LIT "0 ADD STH2kr INC2 STA ( n^ [s*] ; s+1<-asc[n%10] )
#0a DIV LIT "0 ADD STH2r STA ( ; s<-asc[n/10] )
JMP2r ( )
@redraw ( -> )
.DateTime/hr DEI ;gui/hour two-digit-copy
.DateTime/min DEI ;gui/minute two-digit-copy
.DateTime/sec DEI ;gui/second two-digit-copy
#06 ;gui/topbar #0000 #0000 draw-str-at
#03 ;gui/time1 #0000 #000c draw-str-at
#02 ;gui/u1 #0030 #000c draw-str-at
#03 ;gui/msg1 #0078 #000c draw-str-at
#03 ;gui/time2 #0000 #0018 draw-str-at
#02 ;gui/u2 #0030 #0018 draw-str-at
#03 ;gui/msg2 #0078 #0018 draw-str-at
#01 ;gui/info1 #0000 #0024 draw-str-at
#03 ;gui/time3 #0000 #0030 draw-str-at
#02 ;gui/u3 #0030 #0030 draw-str-at
#03 ;gui/msg3 #0078 #0030 draw-str-at
#01 ;gui/info2 #0000 #003c draw-str-at
#03 ;gui/edit #0078 #0048 draw-str-at
#03 ;gui/edit #0078 #0054 draw-str-at
#03 ;gui/edit #0078 #0060 draw-str-at
#03 ;gui/edit #0078 #006c draw-str-at
#03 ;gui/edit #0078 #0078 draw-str-at
#03 ;gui/edit #0078 #0084 draw-str-at
#03 ;gui/edit #0078 #0090 draw-str-at
#03 ;gui/edit #0078 #009c draw-str-at
#03 ;gui/edit #0078 #00a8 draw-str-at
#03 ;gui/edit #0078 #00b4 draw-str-at
#03 ;gui/edit #0078 #00c0 draw-str-at
#03 ;gui/edit #0078 #00cc draw-str-at
#03 ;gui/edit #0078 #00d8 draw-str-at
#03 ;gui/edit #0078 #00e4 draw-str-at
#03 ;gui/edit #0078 #00f0 draw-str-at
#03 ;gui/edit #0078 #00fc draw-str-at
#03 ;gui/edit #0078 #0108 draw-str-at
#03 ;gui/edit #0078 #0114 draw-str-at
#03 ;gui/edit #0078 #0120 draw-str-at
#03 ;gui/edit #0078 #012c draw-str-at
#03 ;gui/edit #0078 #0138 draw-str-at
#03 ;gui/edit #0078 #0144 draw-str-at
#01 ;gui/separator #0000 #0150 draw-str-at
#01 ;gui/say #0000 #015c draw-str-at
#03 ;input #0028 #015c draw-str-at
#08 #20 draw-char ( cursor )
JMP2r
@draw-lit #0000 DIV
@draw-str ( tint^ s* -> )
STH2 ( tint^ [s*] )
&loop DUP STH2kr LDA DUP ?&ok ( tint^ tint^ c^ [pos*] )
POP POP2 POP2r JMP2r ( )
&ok draw-char INC2r ( tint^ [pos+1*] )
.Screen/x DEI2k #0008 ADD2 ( tint^ s/x^ x+8* [pos+1*] )
ROT DEO2 !&loop ( tint^ [pos+1*] )
@draw-char ( tint^ c^ -> )
SWP STH ( c^ [tint^] )
#00 SWP #40 SFT2 ;cp437 ADD2 ( addr* [tint^] )
.Screen/addr DEO2k ( addr* s/a^ [tint^] )
STHkr .Screen/sprite DEO ( addr* s/a^ [tint^] )
.Screen/y DEI2k #0004 ADD2 ROT DEO2 ( addr* s/a^ [tint^] )
STH #0004 ADD2 STHr DEO2 ( [tint^] )
STHr .Screen/sprite DEO ( )
.Screen/y DEI2k #0004 SUB2 ROT DEO2 ( )
JMP2r ( )
@history-append-msg ( user* msg* -> )
JMP2r
@history-append-sys ( msg* -> )
JMP2r
~zenoutil.tal
( 256 chars x 2 tiles/char x 8 bytes/tile = 4096 bytes )
( second tile only uses top 50% )
@cp437
~cp437.tal
( input and args )
@addr $100
@port $10
@nick $20
@input $1000
( compose buffer )
@compose $51 &limit
( 640x480 resolution means 80 x 40 = 3200 characters )
@history $c80 &start =history &limit =history

214
zenosrv.tal
View File

@ -1,214 +0,0 @@
( zenochat.tal )
( )
( uses uxnet protocol, see uxnet.txt for details )
( )
( the server assumes its assigned idxs are exactly 3 bytes long. )
( this is an implementation detail of uxnet.py not currently )
( required by the spec. )
( )
( clients send messages to the server using the > command. )
( each type of messages is identified by its first ASCII )
( character, which is otherwise ignored: )
( )
( CHAR MEANING )
( N sets username to $text )
( B broadcasts a chat message of $text )
( C notifies that user $text has connected )
( D notifies that user $text has disconnected )
( R expects $prev/$curr, user $prev is renamed to $curr )
( )
( nicknames are not allowed to have slashes, i.e. /, and must )
( be 16 bytes or fewer long. messages are not allowed to contain )
( the NULL byte, and are not expected to contain newlines. )
|10 @Console [ &vect $2 &r $1 &pad $4 &type $1 &w $1 &e $1 ]
|0000
@interpret $2
@pos $2
@next-client $2
|0100
;before-start .interpret STZ2
;addr .pos STZ2
;clients .next-client STZ2
;read-args .Console/vect DEO2
BRK
( we don't expect anything )
@before-start ( -> )
#0000 DIV JMP2r
( we expect to read $/ )
@when-starting ( -> )
;input LDAk LIT "$ NEQ ?&error
INC2 LDAk LIT "/ NEQ ?&error
POP2
( TODO: validate input )
;when-listening .interpret STZ2 JMP2r
&error #010f DEO BRK
( we expect to read $ # < )
@when-listening ( -> )
;input LDAk LIT "$ EQU ?connect
LDAk LIT "# EQU ?disconnect
LDAk LIT "< EQU ?receive
POP2 #0000 DIV
@connect ( input* -> )
( TODO: validate input )
INC2 !add-client
@disconnect ( input* -> )
( TODO: validate input )
INC2 !rm-client
( expect: <999/N...\0 )
( or: <999/B...\0 )
@receive ( input* -> )
( TODO: validate input )
INC2 DUP2 find-client ( msg=input+1* maybe* )
ORAk ?&found POP2 emit JMP2r ( )
&found ( msg* client* )
SWP2 #0004 ADD2 ( client* body=msg+4 )
LDAk LIT "N EQU ?rename ( client* body* )
LDAk LIT "B EQU ?broadcast ( client* body* )
POP2 POP2 JMP2r ( )
@broadcast ( client* body* -> )
INC2 SWP2 #0003 ADD2 ( data=body+1* name=client+3* )
start-output copy-dst0 ( data* dst+n* ; copy name into dst+5 )
#3a20 OVR2 STA2 ( data* dst+n-1* ; dst+n-1<-": " )
INC2 INC2 copy ( ; copy data into dst+n+1 )
!send-to-all ( )
( sends ;output to all clients )
( fn should have shape: client* -> )
@send-to-all ( -> )
.next-client LDZ2 ;clients ( limit* start* )
&loop GTH2k ?&ok POP2 POP2 JMP2r ( )
&ok DUP2 send-to #0014 ADD2 !&loop ( limit* pos+20* )
POP2 POP2 JMP2r ( )
( sends ;output to a client )
@send-to ( client* -> )
;output STH2k INC2 ( client* output+1* [output*] )
idx-copy ( [output*] ; copy idx into output+1 )
STH2r emit ( ; emit output )
( #0a18 DEO JMP2r ( need newline for interactive testing ) )
#0018 DEO JMP2r
@rename-msg 20 "is 20 "now 20 "called 20 00
@start-output ( -> dst* )
LIT2r :output
LIT "> STH2kr STA INC2r
LIT2 "00 STH2kr STA2 INC2r INC2r
LIT2 "0/ STH2kr STA2 INC2r INC2r
STH2r JMP2r
@rename ( client* body* -> )
OVR2 #0003 ADD2 ( client* body* name=client+3* )
start-output copy-dst0 ( client* body* dst* ; copy old name to output )
;rename-msg SWP2 copy-dst0 ( client* body* dst2* )
STH2 INC2 STH2k #00 STH2kr ( client* data=body+1* 0^ data* [dst2* data*] )
#0010 ADD2 STA ( client* data* ; data+16<-0 [dst2* data*] )
SWP2 #0003 ADD2 copy ( [dst2* data*] ; copy data into client+3 )
STH2r STH2r ( data* dst2* )
copy !send-to-all ( ; copy data into dst2 and send )
( we expect to read addr then port )
@read-args ( -> BRK )
.Console/type DEI #04 EQU ?start-server
.Console/type DEI #03 EQU ?&end-addr
.Console/r DEI .pos LDZ2 STA ( ; write c into buf )
.pos LDZ2k INC2 ROT STZ2 BRK ( BRK ; increment buf pos )
&end-addr ;port .pos STZ2 BRK ( BRK ; start raeding port port )
@read-stdin
( .Console/r DEI #0a NEQ ?&continue ( ; did we read null? ) )
.Console/r DEI ?&continue ( ; did we read null? )
#00 .pos LDZ2 STA ( ; write null )
.interpret LDZ2 JSR2 ( ; interpret message )
;input .pos STZ2 BRK ( ; reset input buffer )
&continue ( )
.Console/r DEI .pos LDZ2 STA ( ; write c into input buffer )
.pos LDZ2k INC2 ROT STZ2 BRK ( ; increment input buffer )
@start-server ( -> BRK )
LIT "@ .Console/w DEO ;addr emit
LIT "/ .Console/w DEO ;port emit
( #0a .Console/w DEO )
#00 .Console/w DEO
;input .pos STZ2
;when-starting .interpret STZ2
;read-stdin .Console/vect DEO2
BRK
( assumes idxs are 3 bytes long )
@idx-eq ( idx1* idx2* -> bool^ )
STH2 LDAk LDAkr STHr NEQ ?&nope
INC2 INC2r LDAk LDAkr STHr NEQ ?&nope
INC2 INC2r LDA LDAr STHr EQU JMP2r
&nope #00 JMP2r
( assumes idxs are 3 bytes long )
@idx-copy ( idx* dst* -> )
STH2 LDAk STH2kr STA INC2 INC2r ( idx+1* [dst+1*] ; dst<-idx )
LDAk STH2kr STA INC2 INC2r ( idx+2* [dst+2*] ; dst+1<-idx+1 )
LDA STH2r STA JMP2r ( ; dst+2<-idx+2 )
@connect-msg 20 "has 20 "connected 00
@add-client ( idx* -> )
LITr -next-client LDZ2r ( idx* [next*] )
DUP2 STH2kr copy-slash ( idx* [next*] ; copy idx to client-idx )
STH2kr #0003 ADD2 copy-slash ( [next*] ; copy idx to client-name )
#00 STH2kr #0006 ADD2 STA ( [next*] ; null terminate )
STH2kr #0003 ADD2 ( next+3* [next*] )
start-output copy-dst0 ( dst* [next*] ; start message )
;connect-msg SWP2 copy ( [next*] ; finish message )
STH2r #0014 ADD2 .next-client STZ2 ( ; next-client<-next+20 )
!send-to-all ( )
@disconnect-msg 20 "has 20 "disconnected 00
@rm-client ( idx* -> )
find-client ORAk ?&found ( addr* )
POP2 JMP2r ( )
&found ( addr* )
DUP2 #0003 ADD2 start-output ( addr* addr+3* dst* )
copy-dst0 ( addr* dst2* )
;disconnect-msg SWP2 copy ( addr* )
.next-client LDZ2 #0014 SUB2 SWP2 ( limit* addr* )
&loop GTH2k ?&ok !&done ( limit* pos* )
&ok DUP2 #0014 ADD2 LDA2 ( limit* pos* cc* )
OVR2 STA2 INC2 INC2 !&loop ( limit* pos+2* )
&done .next-client STZ2 POP2 ( )
!send-to-all ( )
( returns client addr or 0000 on failure )
( finds client based on 3 byte idx )
@find-client ( idx* -> addr* )
STH2 .next-client LDZ2 ;clients ( limit* clients* [idx*] )
&loop ( limit* c* [idx*] )
DUP2 STH2kr idx-eq ?&found ( limit* c* [idx*] )
#0014 ADD2 GTH2k ?&loop ( limit* c+20* [idx*] )
POP2r POP2 DUP2 EOR2 JMP2r ( 0* )
&found NIP2 POP2r JMP2r ( c* )
~zenoutil.tal
@addr $100
@port $6
@input $1000
@output $1000
( client layout: )
( - bytes 1-3: idx )
( - bytes 4-20: nickname\0 )
( every idx is 3 bytes )
( max username is 16 chars )
( username is null-terminated; idx is not )
( max # of clients is 64 )
@clients $500 &limit

49
zenoutil.tal
View File

@ -1,49 +0,0 @@
( copy null-terminated string from src into dst )
( includes the null terminator. )
( returns first unwritten address. )
@copy-dst ( src* dst* -> dst2* )
STH2 &loop ( in* [out*] )
LDAk DUP STH2kr STA ( in* c^ [out*] )
INC2r STH INC2 ( in+1* [out+1* c^] )
STHr ?&loop ( in+1 [out+1*] )
POP2 STH2r JMP2r ( dst2=out+1* )
( copy-dst but without null termination )
@copy-dst0 ( src* dst* -> dst2* )
copy-dst #0001 SUB2 JMP2r
( copy null-terminated string from src into dst )
( includes the null terminator. )
@copy ( src* dst* -> )
copy-dst POP2 JMP2r
( copy slash-terminated string from src into dst. )
( writes a null terminator. )
@copy-slash ( src/* dst* -> )
STH2 &loop LDAk LIT "/ EQU ?&done ( in* [out*] )
LDAk STH2kr STA INC2 INC2r !&loop ( in+1* [out+1*] )
&done #00 STH2r STA POP2 JMP2r ( )
( compare two null-terminated strings )
@eq ( s* t* -> eq^ )
STH2 ( s1* [s2*] )
&l LDAk LDAkr STHr NEQk ?&d ( s1* c1^ c2^ [s2*] )
DUP EOR EQUk ?&d ( s1* c1^ 0^ [s2*] )
POP2 INC2 INC2r !&l ( s1+1* [s2+1*] )
&d NIP2 POP2r EQU JMP2r ( eq^ )
( compare slash-terminated string against null-terminated )
( slash terminated string cannot contain nulls )
@eq-slash ( s/* str* -> )
STH2 ( s/* [str*] )
&loop LDAk LIT "/ EQU ?&end ( s/* [str*] )
LDAk LDAkr STHr NEQk ?&done ( s/* c1^ c2^ [str*] )
POP2 INC2 INC2r !&loop ( s/+1* [str+1*] )
&end LDAkr STHr DUPk EOR ( s/* c2^ 0^ [str*] )
&done NIP2 POP2r EQU JMP2r ( 0^ )
( write null-terminated string to stdout )
@emit ( buf* -> )
LITr -Console/w ( buf* [dev^] )
&loop LDAk ?&ok POP2 POPr JMP2r ( )
&ok LDAk STHkr DEO INC2 !&loop ( buf+1* [dev^] )