Compare commits
94 Commits
Author | SHA1 | Date |
---|---|---|
~d6 | 12b6a5c3e6 | |
~d6 | 4f0a9dfdbe | |
~d6 | 03bb613e4e | |
~d6 | b674f3932e | |
~d6 | 873ced6cbf | |
~d6 | 7b75c65087 | |
~d6 | f8c728d331 | |
~d6 | b9c2a4501f | |
~d6 | d4562c34a7 | |
~d6 | a206871a07 | |
~d6 | 4b643ea646 | |
~d6 | 077ee3d109 | |
~d6 | 0071604b2c | |
Erik Osheim | 377cc5a30a | |
~d6 | b06908c2fd | |
~d6 | 96e98f82ba | |
~d6 | 6febc83848 | |
~d6 | 62cc1ffd12 | |
~d6 | dd7a610c83 | |
~d6 | ed895d9756 | |
~d6 | ba462deeed | |
~d6 | e2d4e0506e | |
~d6 | 5551e6c695 | |
~d6 | f5b129c7a2 | |
Erik Osheim | c7cfeb8d18 | |
~d6 | 626aac3d65 | |
~d6 | a8a0c57c2d | |
~d6 | ccc3b8b806 | |
~d6 | 03c6d96e62 | |
~d6 | 3d0ca1c548 | |
~d6 | 84587cd6a2 | |
~d6 | b497e72d56 | |
~d6 | 93e75ca024 | |
~d6 | d2bb5ca255 | |
~d6 | ebb6889d48 | |
~d6 | 28f27e7fcf | |
~d6 | 2d0db6fe6f | |
~d6 | d6a02946cc | |
~d6 | 8b5854c43b | |
~d6 | d1dd621ba0 | |
~d6 | d1ac45feae | |
~d6 | a6e0b734d5 | |
~d6 | a6551d1af6 | |
~d6 | 2dedf3b050 | |
~d6 | cf9e72d8e4 | |
~d6 | ade8cf1d0b | |
~d6 | b5dadc84eb | |
~d6 | 10a4dcc2af | |
~d6 | 0b372d2e85 | |
~d6 | 6e3e5f5c81 | |
~d6 | 989db7f039 | |
~d6 | 5f56e2f6bf | |
~d6 | b0aa04874a | |
~d6 | 0f57e455ac | |
~d6 | 85d538a738 | |
~d6 | 773c5abfcb | |
~d6 | d758578ef3 | |
~d6 | 4f6b71d641 | |
~d6 | 586d14bc69 | |
~d6 | 7e624d550b | |
~d6 | 589fbebf3e | |
~d6 | 1bdc4ec719 | |
~d6 | 224acb4461 | |
~d6 | c962f31f15 | |
~d6 | 8610a0f419 | |
~d6 | 15d34122b3 | |
~d6 | 0bb4f7967b | |
~d6 | e1714aceff | |
~d6 | 1010f8c00c | |
~d6 | d18c563187 | |
~d6 | 230eb91c74 | |
~d6 | d278dcf58e | |
~d6 | 06332929f6 | |
~d6 | 29186973c8 | |
~d6 | 1dddbf6cf9 | |
~d6 | f8fbae1af1 | |
~d6 | 2392745f6f | |
~d6 | 3993dbc80a | |
~d6 | 2fe1d7d770 | |
~d6 | 1d0bb3da6e | |
~d6 | 436f6dc7bf | |
~d6 | 36a5ca5212 | |
~d6 | dd368c12ec | |
~d6 | 0e85bd16c0 | |
~d6 | 35e1bf5b56 | |
~d6 | 186a14d443 | |
~d6 | f955e92bb9 | |
~d6 | 8cea231772 | |
~d6 | 64ccfc1aa2 | |
~d6 | feac155257 | |
~d6 | 8046ed022f | |
~d6 | 357da0a3a4 | |
~d6 | 5c7c43e56b | |
~d6 | 4a50aca68b |
|
@ -0,0 +1,20 @@
|
|||
# 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
2
arg.tal
|
@ -61,7 +61,7 @@
|
|||
|
||||
( internal: store character c in the buffer and update position )
|
||||
&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 )
|
||||
STA2r JMP2r ( ; pos<-addr+1 )
|
||||
|
||||
|
|
|
@ -0,0 +1,100 @@
|
|||
# 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
|
|
@ -149,7 +149,7 @@
|
|||
STH2kr STA2 ( end* [pos*] ; pos<-n )
|
||||
STH2r INC2 INC2 ( 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*] )
|
||||
STH2kr STA2 INC2r INC2r ( [last+2*] ; last<-c )
|
||||
LIT2 [ &xy $2 ] ( xy* [last+2*] )
|
||||
|
@ -212,7 +212,7 @@
|
|||
|
||||
( returns top card at coords, or 0000 if no card. )
|
||||
@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*] )
|
||||
OVR2 OVR2 STH2kr ( x* y* x* y* pos* [limit* pos*] )
|
||||
intersects ?&done ( x* y* [limit* pos*] )
|
||||
|
@ -249,7 +249,7 @@
|
|||
@draw-all-cards ( draw* -> )
|
||||
,&draw STR2 ( )
|
||||
held-end-offset STH2 ( [limit*] )
|
||||
LIT2r :cards ( [limit* pos*] )
|
||||
LIT2r =cards ( [limit* pos*] )
|
||||
&loop ( [limit* pos*] )
|
||||
STH2kr LDA2 INC2r INC2r ( card* [limit* pos+2*] )
|
||||
#00 STH2kr LDA INC2r ( card* x* [limit* pos+3*] )
|
||||
|
@ -257,7 +257,7 @@
|
|||
LIT2 [ &draw $2 ] JSR2 ( [limit* pos+4] )
|
||||
GTH2kr STHr ?&loop ( [limit* pos+4] )
|
||||
POP2r POP2r ( )
|
||||
LIT2r :cards/end ( [limit*] )
|
||||
LIT2r =cards/end ( [limit*] )
|
||||
held-end-offset STH2 ( [limit* offset*] )
|
||||
&mloop ( [limit* pos*] )
|
||||
STH2kr LDA2 INC2r INC2r ( card* [limit* pos+2*] )
|
||||
|
|
|
@ -0,0 +1,59 @@
|
|||
|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
|
176
fix16.tal
176
fix16.tal
|
@ -22,12 +22,17 @@
|
|||
( #0700 1792/256 7.0000 )
|
||||
( #7f00 32512/256 127.0000 )
|
||||
( #7fff 32767/256 127.9961 )
|
||||
( #8000 -32768/256 -128.0000 )
|
||||
( #8000 invalid invalid )
|
||||
( #8001 -32767/256 -127.9961 )
|
||||
( #8100 -32767/256 -127.0000 )
|
||||
( #ff00 -256/256 -1.0000 )
|
||||
( #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: )
|
||||
( * addition )
|
||||
( * subtraction )
|
||||
|
@ -60,7 +65,7 @@
|
|||
( - tan() is mostly supported )
|
||||
( - tan(#0192) and tan(#04b6) throw an error )
|
||||
( - a few tan() values are inaccurate due to range )
|
||||
( + values "next to" pi/2 and 3pi/2 are affected )
|
||||
( + values "next to" pi/2 and 3pi/2 are affected )
|
||||
( + tan(#0191) returns 127.996 not 227.785 )
|
||||
( + tan(#0193) returns -127.996 not -292.189 )
|
||||
( + etc. )
|
||||
|
@ -108,21 +113,20 @@
|
|||
%x16-pi/2 { #0192 } ( 1.57079... )
|
||||
%x16-pi { #0324 } ( 3.14159... )
|
||||
%x16-3pi/2 { #04b6 } ( 4.71239... )
|
||||
%x16-pi*2 { #0648 } ( 6.28318... )
|
||||
%x16-2pi { #0648 } ( 6.28318... )
|
||||
%x16-e { #02b8 } ( 2.71828... )
|
||||
%x16-phi { #019e } ( 1.61803... )
|
||||
%x16-sqrt-2 { #016a } ( 1.41421... )
|
||||
%x16-sqrt-3 { #01bb } ( 1.73205... )
|
||||
%x16-epsilon { #0001 } ( 0.00390... )
|
||||
%x16-minimum { #8000 } ( -128.0 )
|
||||
%x16-minimum { #8001 } ( -127.99609... )
|
||||
%x16-maximum { #7fff } ( 127.99609... )
|
||||
%x16-max-whole { #7f00 } ( 127.0 )
|
||||
%x16-error { #8000 } ( not a number )
|
||||
|
||||
( utils )
|
||||
@x16-is-non-neg ( x* -> bool^ ) x16-minimum LTH2 JMP2r
|
||||
@x16-is-neg ( x* -> bool^ ) x16-maximum GTH2 JMP2r
|
||||
@x16-emit-dec-digit ( d^ -> ) #30 ADD #18 DEO JMP2r
|
||||
@error [ #0000 DIV ]
|
||||
|
||||
@x16-emit ( x* -> )
|
||||
DUP2 #8000 EQU2 ?&is-min
|
||||
|
@ -198,43 +202,66 @@
|
|||
@x16-mul ( x* y* -- xy* )
|
||||
;x16-mul-unsigned !x16-signed-op
|
||||
|
||||
@x16-mul-unsigned ( x* y* -- xy* )
|
||||
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-mul8 ( x^ y^ -> xy* )
|
||||
#0000 SWP2 ROT SWP MUL2 JMP2r
|
||||
|
||||
@x16-mul-unsigned-rhs-whole ( x0_x1* y0_00* -- xy* )
|
||||
#08 SFT2 MUL2 #7fff !unsigned-min
|
||||
@x16-mul-unsigned ( ab* cd* -> ac+ad+bc+bd* )
|
||||
OVR2 OVR2 STH2 STH2 ROT SWPr ROTr ( a c d b [c b a d] )
|
||||
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-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* )
|
||||
DIV2k STH2k ( x y x/y [x/y] )
|
||||
LITr 80 SFT2r ( x y x/y [div=(x/y)<<8] )
|
||||
OVR2 STH2 ( x y x/y [y div] )
|
||||
MUL2 SUB2 ( x%y [y div] )
|
||||
STH2r LIT2r 0100 ( x%y y [0100 div] )
|
||||
DIV2k DUP2 #007f GTH2 ?&o ( x* y* x/y* )
|
||||
STH2k LITr 80 SFT2r ( x* y* x/y* [div=(x/y)<<8*] )
|
||||
OVR2 STH2 ( x* y* x/y* [div* y*] )
|
||||
MUL2 SUB2 ( x%y* [div* y*] )
|
||||
STH2r LIT2r 0100 ( x%y* y* [div* 0100*] )
|
||||
|
||||
( 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
|
||||
|
||||
POP2 POP2 ( [shiftk div] )
|
||||
POP2r STH2r JMP2r ( div )
|
||||
POP2 POP2 POP2r STH2r ( div* )
|
||||
DUP2 #7fff GTH2 ?&oo JMP2r ( div* )
|
||||
&o POP2 POP2 &oo POP2 #7fff JMP2r ( 7fff ; saturate on overflow )
|
||||
|
||||
@x16-signed-op ( x* y* f* -> f(x,y)* )
|
||||
STH2 LIT2r 0001
|
||||
|
@ -245,7 +272,11 @@
|
|||
JMP2r
|
||||
|
||||
@x16-quotient ( x* y* -> x//y* )
|
||||
DIV2 #80 SFT2 JMP2r
|
||||
;x16-quot-unsigned !x16-signed-op
|
||||
|
||||
@x16-quot-unsigned ( x* y* -> x//y* )
|
||||
DIV2 DUP2 #007f GTH2 ?{ #80 SFT2 JMP2r }
|
||||
POP2 #7fff JMP2r
|
||||
|
||||
@x16-remainder ( x* y* -> x%y* )
|
||||
DIV2k MUL2 SUB2 JMP2r
|
||||
|
@ -255,9 +286,10 @@
|
|||
|
||||
@x16-from-s16 ( n* -> x* )
|
||||
DUP2 #ff80 GTH2 ?&neg
|
||||
DUP2 #007f GTH2 ?error
|
||||
DUP2 #007f GTH2 ?&error
|
||||
NIP #00 SWP JMP2r
|
||||
&neg NIP #ff SWP JMP2r
|
||||
&error POP2 #8000 JMP2r
|
||||
|
||||
( 1.5 -> 1, 0.5 -> 0, -1.5 -> -1 )
|
||||
@x16-to-s16 ( x* -> whole* )
|
||||
|
@ -310,30 +342,31 @@
|
|||
&done ( x* s1* [c* 2*] )
|
||||
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-pi/2 ADD2 ( fall-thru )
|
||||
x16-unit-circle x16-pi/2 ADD2 ( fall-through )
|
||||
|
||||
@x16-sin ( x* -> sin[x]* )
|
||||
DUP2 #8000 LTH2 ?&non-negative
|
||||
x16-negate x16-sin/non-negative !x16-negate
|
||||
&non-negative
|
||||
x16-pi*2 STH2 ( x [2pi] )
|
||||
DUP2 STH2kr x16-quotient ( x x/2pi [2pi] )
|
||||
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
|
||||
DUP2 #8000 LTH2 ?&positive x16-negate x16-sin/positive !x16-negate
|
||||
&positive x16-unit-circle
|
||||
DUP2 x16-3pi/2 LTH2 ?{ x16-2pi SWP2 SUB2 x16-sin/q !x16-negate }
|
||||
DUP2 x16-pi LTH2 ?{ x16-pi SUB2 x16-sin/q !x16-negate }
|
||||
DUP2 x16-pi/2 LTH2 ?{ x16-pi SWP2 SUB2 }
|
||||
&q 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
|
||||
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
|
||||
|
@ -363,26 +396,15 @@
|
|||
0100 0100 0100
|
||||
|
||||
@x16-tan ( x* -> tan[x]* )
|
||||
x16-pi*2 STH2 ( x [2pi] )
|
||||
DUP2 STH2kr x16-quotient ( x x/2pi [2pi] )
|
||||
STH2r x16-mul SUB2 ( x' ; 0 <= x' < 2pi )
|
||||
|
||||
x16-unit-circle
|
||||
( tan(pi/2) = tan(3pi/2) = error )
|
||||
DUP2 x16-3pi/2 EQU2 ?error
|
||||
DUP2 x16-pi/2 EQU2 ?error
|
||||
|
||||
DUP2 x16-3pi/2 LTH2 ?&c1
|
||||
( -tan(2pi - x) ) x16-pi*2 SWP2 SUB2 x16-tan-q !x16-negate
|
||||
&c1 DUP2 x16-pi LTH2 ?&c2
|
||||
( 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
|
||||
DUP2 x16-3pi/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-pi/2 LTH2 ?{ x16-pi SWP2 SUB2 x16-tan/q !x16-negate }
|
||||
&q DUP2 ADD2 ;x16-tan-table ADD2 LDA2 JMP2r
|
||||
&error POP2 #8000 JMP2r
|
||||
|
||||
@x16-tan-table
|
||||
0000 0001 0002 0003 0004 0005 0006 0007 0008 0009 000a 000b 000c 000d 000e 000f
|
||||
|
@ -416,7 +438,7 @@
|
|||
|
||||
[ DUP2 #0000 GTH2 ] STH
|
||||
[ DUP2 #8000 LTH2 ] STHr AND ?&0<x<128
|
||||
( error ) !error
|
||||
( error ) POP2 #8000 JMP2r ( error )
|
||||
|
||||
&0<x<128 DUP2 #0800 GTH2 ?&8<x<128
|
||||
( 0<x<=8 ) DUP2 #0200 GTH2 ?&2<x<=8
|
||||
|
|
|
@ -0,0 +1,235 @@
|
|||
( 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
|
|
@ -0,0 +1,186 @@
|
|||
( 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 )
|
|
@ -0,0 +1,185 @@
|
|||
( 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
|
|
@ -0,0 +1,103 @@
|
|||
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!
|
486
math32.tal
486
math32.tal
|
@ -20,406 +20,264 @@
|
|||
( Operations supported: )
|
||||
( )
|
||||
( NAME STACK EFFECT DEFINITION )
|
||||
( add32 x** y** -> z** x + y )
|
||||
( sub32 x** y** -> z** x - y )
|
||||
( mul16 x* y* -> z** x * y )
|
||||
( mul32 x** y** -> z** x * y )
|
||||
( div32 x** y** -> q** x / y )
|
||||
( mod32 x** y** -> r** x % y )
|
||||
( divmod32 x** y** -> q** r** x / y, x % y )
|
||||
( gcd32 x** y** -> z** gcd(x, y) )
|
||||
( negate32 x** -> z** -x )
|
||||
( lshift32 x** n^ -> z** x<<n )
|
||||
( rshift32 x** n^ -> z** x>>n )
|
||||
( and32 x** y** -> z** x & y )
|
||||
( or32 x** y** -> z** x | y )
|
||||
( xor32 x** y** -> z** x ^ y )
|
||||
( complement32 x** -> z** ~x )
|
||||
( eq32 x** y** -> bool^ x == y )
|
||||
( ne32 x** y** -> bool^ x != y )
|
||||
( is-zero32 x** -> bool^ x == 0 )
|
||||
( non-zero32 x** -> bool^ x != 0 )
|
||||
( lt32 x** y** -> bool^ x < y )
|
||||
( gt32 x** y** -> bool^ x > y )
|
||||
( lteq32 x** y** -> bool^ x <= y )
|
||||
( gteq32 x** y** -> bool^ x >= y )
|
||||
( bitcount8 x^ -> bool^ floor(log2(x))+1 )
|
||||
( bitcount16 x* -> bool^ floor(log2(x))+1 )
|
||||
( bitcount32 x** -> bool^ floor(log2(x))+1 )
|
||||
( u32-add x** y** -> z** x + y )
|
||||
( u32-sub x** y** -> z** x - y )
|
||||
( u32-mul x** y** -> z** x * y )
|
||||
( u32-mul16 x* y* -> z** x * y )
|
||||
( u32-div x** y** -> q** x / y )
|
||||
( u32-mod x** y** -> r** x % y )
|
||||
( u32-divmod x** y** -> q** r** x / y, x % y )
|
||||
( u32-gcd x** y** -> z** gcd[x, y] )
|
||||
( u32-negate x** -> z** -x )
|
||||
( u32-lshift x** n^ -> z** x<<n )
|
||||
( u32-rshift x** n^ -> z** x>>n )
|
||||
( u32-and x** y** -> z** x & y )
|
||||
( u32-or x** y** -> z** x | y )
|
||||
( u32-xor x** y** -> z** x ^ y )
|
||||
( u32-complement x** -> z** ~x )
|
||||
( u32-eq x** y** -> bool^ x == y )
|
||||
( u32-ne x** y** -> bool^ x != y )
|
||||
( u32-is-zero x** -> bool^ x == 0 )
|
||||
( u32-non-zero x** -> bool^ x != 0 )
|
||||
( u32-lt x** y** -> bool^ x < y )
|
||||
( u32-gt x** y** -> bool^ x > y )
|
||||
( u32-lteq x** y** -> bool^ x <= y )
|
||||
( u32-gteq x** y** -> bool^ x >= y )
|
||||
( u8-bitcount x^ -> bool^ floor[log2[x]]+1 )
|
||||
( u16-bitcount x* -> bool^ floor[log2[x]]+1 )
|
||||
( u32-bitcount x** -> bool^ floor[log2[x]]+1 )
|
||||
( )
|
||||
( In addition to the code this file uses 44 bytes of registers )
|
||||
( to store temporary state: )
|
||||
( )
|
||||
( - shared memory, 16 bytes )
|
||||
( - mul32 memory, 12 bytes )
|
||||
( - _divmod32 memory, 16 bytes )
|
||||
( bitcount: number of bits needed to represent the number. )
|
||||
( this is equivalent to floor[log2[x]] + 1 )
|
||||
|
||||
( bitcount: number of bits needed to represent number )
|
||||
( equivalent to floor[log2[x]] + 1 )
|
||||
@u8-bitcount ( x^ -> n^ )
|
||||
LITr 00 &loop DUP ?{ POP STHr JMP2r } #01 SFT INCr !&loop
|
||||
|
||||
@bitcount8 ( x^ -> n^ )
|
||||
#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
|
||||
@u16-bitcount ( x* -> n^ )
|
||||
LITr 00 &loop ORAk ?{ POP2 STHr JMP2r } #01 SFT2 INCr !&loop
|
||||
|
||||
@bitcount16 ( x* -> n^ )
|
||||
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
|
||||
@u32-bitcount ( x** -> n^ )
|
||||
SWP2 u16-bitcount DUP ?{ POP !u16-bitcount } #10 NIP2 ADD JMP2r
|
||||
|
||||
@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 )
|
||||
( -- equality )
|
||||
|
||||
( x == y )
|
||||
@eq32 ( xhi* xlo* yhi* ylo* -> bool^ )
|
||||
ROT2 EQU2 STH
|
||||
EQU2 STHr AND JMP2r
|
||||
@u32-eq ( xhi* xlo* yhi* ylo* -> bool^ )
|
||||
ROT2 EQU2 STH EQU2 STHr AND JMP2r
|
||||
|
||||
( x != y )
|
||||
@ne32 ( xhi* xlo* yhi* ylo* -> bool^ )
|
||||
ROT2 NEQ2 STH
|
||||
NEQ2 STHr ORA JMP2r
|
||||
@u32-ne ( xhi* xlo* yhi* ylo* -> bool^ )
|
||||
ROT2 NEQ2 STH NEQ2 STHr ORA JMP2r
|
||||
|
||||
( x == 0 )
|
||||
@is-zero32 ( x** -> bool^ )
|
||||
@u32-is-zero ( x** -> bool^ )
|
||||
ORA2 #0000 EQU2 JMP2r
|
||||
|
||||
( x != 0 )
|
||||
@non-zero32 ( x** -> bool^ )
|
||||
@u32-non-zero ( x** -> bool^ )
|
||||
ORA2 ORA JMP2r
|
||||
|
||||
( comparisons )
|
||||
( -- comparisons )
|
||||
|
||||
( x < y )
|
||||
@lt32 ( x** y** -> bool^ )
|
||||
ROT2 SWP2 ( xhi yhi xlo ylo )
|
||||
LTH2 ,<-lo JCN ( xhi yhi )
|
||||
LTH2 JMP2r
|
||||
<-lo
|
||||
GTH2 #00 EQU JMP2r
|
||||
@u32-lt ( x** y** -> bool^ )
|
||||
ROT2 SWP2 LTH2 ?{ LTH2 JMP2r } GTH2 #00 EQU JMP2r
|
||||
|
||||
( x <= y )
|
||||
@lteq32 ( x** y** -> bool^ )
|
||||
ROT2 SWP2 ( xhi yhi xlo ylo )
|
||||
GTH2 ,>-lo JCN ( xhi yhi )
|
||||
GTH2 #00 EQU JMP2r
|
||||
>-lo
|
||||
LTH2 JMP2r
|
||||
@u32-lteq ( x** y** -> bool^ )
|
||||
ROT2 SWP2 GTH2 ?{ GTH2 #00 EQU JMP2r } LTH2 JMP2r
|
||||
|
||||
( x > y )
|
||||
@gt32 ( x** y** -> bool^ )
|
||||
ROT2 SWP2 ( xhi yhi xlo ylo )
|
||||
GTH2 ,>-lo JCN ( xhi yhi )
|
||||
GTH2 JMP2r
|
||||
>-lo
|
||||
LTH2 #00 EQU JMP2r
|
||||
@u32-gt ( x** y** -> bool^ )
|
||||
ROT2 SWP2 GTH2 ?{ GTH2 JMP2r } LTH2 #00 EQU JMP2r
|
||||
|
||||
( x > y )
|
||||
@gteq32 ( x** y** -> bool^ )
|
||||
ROT2 SWP2 ( xhi yhi xlo ylo )
|
||||
LTH2 ,<-lo JCN ( xhi yhi )
|
||||
LTH2 #00 EQU JMP2r
|
||||
<-lo
|
||||
GTH2 JMP2r
|
||||
@u32-gteq ( x** y** -> bool^ )
|
||||
ROT2 SWP2 LTH2 ?{ LTH2 #00 EQU JMP2r } GTH2 JMP2r
|
||||
|
||||
( bitwise operations )
|
||||
( -- bitwise operations )
|
||||
|
||||
( x & y )
|
||||
@and32 ( xhi* xlo* yhi* ylo* -> xhi|yhi* xlo|ylo* )
|
||||
@u32-and ( xhi* xlo* yhi* ylo* -> xhi&yhi* xlo&ylo* )
|
||||
ROT2 AND2 STH2 AND2 STH2r JMP2r
|
||||
|
||||
( x | y )
|
||||
@or32 ( xhi* xlo* yhi* ylo* -> xhi|yhi* xlo|ylo* )
|
||||
@u32-or ( xhi* xlo* yhi* ylo* -> xhi|yhi* xlo|ylo* )
|
||||
ROT2 ORA2 STH2 ORA2 STH2r JMP2r
|
||||
|
||||
( x ^ y )
|
||||
@xor32 ( xhi* xlo* yhi* ylo* -> xhi|yhi* xlo|ylo* )
|
||||
@u32-xor ( xhi* xlo* yhi* ylo* -> xhi^yhi* xlo^ylo* )
|
||||
ROT2 EOR2 STH2 EOR2 STH2r JMP2r
|
||||
|
||||
( ~x )
|
||||
@complement32 ( x** -> ~x** )
|
||||
@u32-complement ( x** -> ~xhi* ~xlo* )
|
||||
SWP2 #ffff EOR2 SWP2 #ffff EOR2 JMP2r
|
||||
|
||||
( 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 )
|
||||
( -- bit-shifting )
|
||||
|
||||
( x >> n )
|
||||
@rshift32 ( x** n^ -> x<<n )
|
||||
DUP #08 LTH ;rshift32-0 JCN2 ( x n )
|
||||
DUP #10 LTH ;rshift32-1 JCN2 ( x n )
|
||||
DUP #18 LTH ;rshift32-2 JCN2 ( x n )
|
||||
;rshift32-3 JMP2 ( x n )
|
||||
@u32-rshift ( x** n^ -> x>>n )
|
||||
DUP #08 LTH ?u32-shift-0 ( x n )
|
||||
DUP #10 LTH ?u32-rshift-1 ( x n )
|
||||
DUP #18 LTH ?u32-rshift-2 ( x n )
|
||||
!u32-rshift-3 ( x n )
|
||||
|
||||
( shift right by 0-7 bits )
|
||||
@rshift32-0 ( x** n^ -> x<<n )
|
||||
STHk SFT ;m32/z3 STA ( write z3 )
|
||||
#00 STHkr SFT2 #00 ;m32/z3 LDA ORA2 ;m32/z2 STA2 ( write z2,z3 )
|
||||
#00 STHkr SFT2 #00 ;m32/z2 LDA ORA2 ;m32/z1 STA2 ( write z1,z2 )
|
||||
#00 STHr SFT2 #00 ;m32/z1 LDA ORA2 ( compute z0,z1 )
|
||||
;m32/z2 LDA2
|
||||
JMP2r
|
||||
( shift by 0-7 bits; used by both lshift and rshift )
|
||||
@u32-shift-0 ( x** n^ -> x>>n )
|
||||
STH DUP2 STHkr SFT2 ,&z2 STR2
|
||||
POP DUP2 STHkr SFT2 ,&z2 LDR ORA ,&z2 STR ,&z1 STR
|
||||
POP STHr SFT2 ,&z1 LDR ORA ,&z1 STR
|
||||
LIT [ &z1 $1 ] LIT2 [ &z2 $2 ] JMP2r
|
||||
|
||||
( shift right by 8-15 bits )
|
||||
@rshift32-1 ( x** n^ -> x<<n )
|
||||
#08 SUB STH POP
|
||||
STHkr SFT ;m32/z3 STA ( write z3 )
|
||||
#00 STHkr SFT2 #00 ;m32/z3 LDA ORA2 ;m32/z2 STA2 ( write z2,z3 )
|
||||
#00 STHr SFT2 #00 ;m32/z2 LDA ORA2 ( compute z1,z2 )
|
||||
#00 ROT ROT ;m32/z3 LDA
|
||||
JMP2r
|
||||
@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 )
|
||||
@rshift32-2 ( x** n^ -> x<<n )
|
||||
#10 SUB STH POP2
|
||||
STHkr SFT ;m32/z3 STA ( write z3 )
|
||||
#00 STHr SFT2 #00 ;m32/z3 LDA ORA2 ( compute z2,z3 )
|
||||
#0000 SWP2
|
||||
JMP2r
|
||||
@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 )
|
||||
@rshift32-3 ( x** n^ -> x<<n )
|
||||
#18 SUB STH POP2 POP ( x0 )
|
||||
#00 SWP #0000 SWP2 ( 00 00 00 x0 )
|
||||
STHr SFT
|
||||
JMP2r
|
||||
@u32-rshift-3 ( x** n^ -> x>>n )
|
||||
#18 SUB STH ( stash [n>>24] )
|
||||
POP2 POP STH SWPr SFTr #00 #0000 STHr 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 )
|
||||
@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 )
|
||||
@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
|
||||
@u32-lshift-0 ( x** n^ -> x<<n )
|
||||
#40 SFT !u32-shift-0
|
||||
|
||||
( shift left by 8-15 bits )
|
||||
@lshift32-1 ( x** n^ -> x<<n )
|
||||
@u32-lshift-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
|
||||
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 )
|
||||
@lshift32-2 ( x** n^ -> x<<n )
|
||||
@u32-lshift-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
|
||||
NIP2 STHr SFT2 #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
|
||||
@u32-lshift-3 ( x** n^ -> x<<n )
|
||||
#18 SUB #40 SFT ( stash [n-24]<<4 )
|
||||
SFT NIP2 NIP #0000 #00 JMP2r
|
||||
|
||||
( arithmetic )
|
||||
( -- 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
|
||||
@u32-add ( xhi* xlo* yhi* ylo* -> zhi* zlo* )
|
||||
ROT2 STH2k ADD2 STH2k ROT2 ROT2 GTH2r #00 STHr ADD2 ADD2 SWP2 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
|
||||
@u32-negate ( x** -> -x** )
|
||||
u32-complement INC2 ORAk ?{ SWP2 INC2 SWP2 } JMP2r
|
||||
|
||||
( x - y )
|
||||
@sub32 ( x** y** -> z** )
|
||||
;negate32 JSR2 ;add32 JMP2
|
||||
@u32-sub ( x** y** -> z** )
|
||||
ROT2 STH2k SWP2 SUB2 STH2k ROT2 ROT2 LTH2r #00 STHr ADD2 SUB2 SWP2 JMP2r
|
||||
|
||||
( 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 )
|
||||
@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 )
|
||||
#00 ;m32/x1 LDA #00 ;m32/y1 LDA MUL2 ;m32/z2 STA2
|
||||
LIT2 00 [ &x1 $1 ] LIT2 00 [ &y1 $1 ] MUL2 ,&z3 STR ,&z2 STR
|
||||
|
||||
( x0 * y1 => z0z1 )
|
||||
#00 ;m32/x0 LDA #00 ;m32/y1 LDA MUL2 ;m32/z1 LDA2 ADD2 ;m32/z1 STA2
|
||||
#00 ,&x0 LDR #00 ,&y1 LDR MUL2 ,&z1 LDR2 ADD2 ,&z1 STR2
|
||||
|
||||
( x1 * y0 => w1w2 )
|
||||
#00 ;m32/x1 LDA #00 ;m32/y0 LDA MUL2 ;m32/w1 STA2
|
||||
#00 ,&x1 LDR #00 ,&y0 LDR MUL2 ,&w2 STR ,&w1 STR
|
||||
|
||||
( x0 * y0 => w0w1 )
|
||||
#00 ;m32/x0 LDA #00 ;m32/y0 LDA MUL2 ;m32/w0 LDA2 ADD2 ;m32/w0 STA2
|
||||
LIT2 00 [ &x0 $1 ] LIT2 00 [ &y0 $1 ] MUL2 ,&w0 LDR2 ADD2 ,&w0 STR2
|
||||
|
||||
( add z and a<<8 )
|
||||
#00 ;m32/z1 LDA2 ;m32/z3 LDA
|
||||
;m32/w0 LDA2 ;m32/w2 LDA #00
|
||||
;add32 JMP2
|
||||
#00 LIT2 [ &z1 $1 &z2 $1 ] LIT [ &z3 $1 ]
|
||||
LIT2 [ &w0 $1 &w1 $1 ] LIT [ &w2 $1 ] #00
|
||||
!u32-add
|
||||
|
||||
( 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 )
|
||||
@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 )
|
||||
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 ]
|
||||
LIT2 [ &z0 $2 ] ADD2 ( sum += [x0*y1+x1*y0]<<16 )
|
||||
LIT2 [ &z1 $2 ] JMP2r
|
||||
|
||||
@div32 ( x** y** -> q** )
|
||||
;_divmod32 JSR2
|
||||
;_divmod32/quo0 LDA2 ;_divmod32/quo1 LDA2
|
||||
( 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
|
||||
|
||||
@mod32 ( x** y** -> r** )
|
||||
;_divmod32 JSR2
|
||||
;_divmod32/rem0 LDA2 ;_divmod32/rem1 LDA2
|
||||
JMP2r
|
||||
( private: calculate and store x / y and x % y )
|
||||
@z_u32-divmod ( x** y** -> )
|
||||
( ; store y and x for repeated use )
|
||||
#0000 DUP2 ,&quo0 STR2 ,&quo1 STR2 ( x** y** ; quo<-0 )
|
||||
STH2k ,&div1 STR2 STH2k ,&div0 STR2 ( x** [ylo* yhi*] ; div<-y )
|
||||
OVR2 OVR2 ,&rem1 STR2 ,&rem0 STR2 ( x** [ylo* yhi*] ; rem<-x )
|
||||
OVR2 OVR2 STH2r STH2r ( x** x** y** )
|
||||
OVR2 OVR2 STH2 STH2 ( x** x** y** [ylo* yhi*] )
|
||||
u32-gteq ?{ POP2 POP2 POP2r POP2r JMP2r } ( x** [ylo* yhi*] ; return if x < y )
|
||||
|
||||
@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 ,¬-zero JMP
|
||||
&is-zero
|
||||
#0000 ,&quo0 STR2 #0000 ,&quo1 STR2 JMP2r
|
||||
|
||||
( x >= y so the answer is >= 1 )
|
||||
¬-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 ]
|
||||
( ; bitcount[x] - bitcount[y] determines largest multiple of y to try )
|
||||
u32-bitcount STH2r STH2r u32-bitcount SUB ( shift=rbits-dits^ )
|
||||
#00 DUP2 ( shift^ 0^ shift^ 0^ )
|
||||
#0000 INC2k ROT2 POP ( shift^ 0^ 0* 1* shift^ )
|
||||
u32-lshift ,&cur1 STR2 ,&cur0 STR2 ( shift^ 0^ ; cur<-1<<shift )
|
||||
,&div0 LDR2 ,&div1 LDR2 ROT2 POP ( div** shift^ )
|
||||
u32-lshift ,&div1 STR2 ,&div0 STR2 ( ; div<-div<<shift )
|
||||
|
||||
&loop
|
||||
( if rem >= the current divisor, we can subtract it and add to quotient )
|
||||
,&rem0 LDR2 ,&rem1 LDR2 ,&div0 LDR2 ,&div1 LDR2 ;lt32 JSR2 ( is rem < div? )
|
||||
,&rem-lt JCN ( if rem < div skip this iteration )
|
||||
|
||||
( since rem >= div, we have found a multiple of y that divides x )
|
||||
,&rem0 LDR2 ,&rem1 LDR2 ,&div0 LDR2 ,&div1 LDR2 ;sub32 JSR2 ,&rem1 STR2 ,&rem0 STR2 ( rem -= div )
|
||||
,&quo0 LDR2 ,&quo1 LDR2 ,&cur0 LDR2 ,&cur1 LDR2 ;add32 JSR2 ,&quo1 STR2 ,&quo0 STR2 ( quo += cur )
|
||||
|
||||
&rem-lt
|
||||
,&div0 LDR2 ,&div1 LDR2 #01 ;rshift32 JSR2 ,&div1 STR2 ,&div0 STR2 ( div >>= 1 )
|
||||
,&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 )
|
||||
JMP2r
|
||||
( ; if rem >= cur [current divisor], we can subtract it and add to quotient )
|
||||
( ; otherwise, skip that iteration and reduce cur. )
|
||||
LIT2 [ &rem0 $2 ] LIT2 [ &rem1 $2 ] ,&div0 LDR2 ,&div1 LDR2
|
||||
u32-lt ?{
|
||||
( ; since rem >= div, we have found a multiple of y that divides x )
|
||||
,&rem0 LDR2 ,&rem1 LDR2 ( rem** )
|
||||
LIT2 [ &div0 $2 ] LIT2 [ &div1 $2 ] ( rem** div** )
|
||||
u32-sub ,&rem1 STR2 ,&rem0 STR2 ( ; rem<-rem-div** )
|
||||
LIT2 [ &quo0 $2 ] LIT2 [ &quo1 $2 ] ( quo** )
|
||||
LIT2 [ &cur0 $2 ] LIT2 [ &cur1 $2 ] ( quo** cur** )
|
||||
u32-add ,&quo1 STR2 ,&quo0 STR2 ( ; quo<-quo+cur** )
|
||||
}
|
||||
,&div0 LDR2 ,&div1 LDR2 #01 u32-rshift ( div>>1** )
|
||||
,&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 )
|
||||
@gcd32 ( x** y** -> z** )
|
||||
&loop ( x y )
|
||||
OVR2 OVR2 ( x y y )
|
||||
;is-zero32 JSR2 ( x y y=0? )
|
||||
,&done JCN ( x y )
|
||||
OVR2 OVR2 ( x y y )
|
||||
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
|
||||
@u32-gcd ( x** y** -> z** )
|
||||
&loop OVR2 OVR2 u32-is-zero ?{ ( x** y** )
|
||||
OVR2 OVR2 STH2 STH2 ( x** y** [y**] )
|
||||
u32-mod ( r=x%y** [y**] )
|
||||
STH2r ROT2 ROT2 ( yhi* rhi* rlo* [ylo*] )
|
||||
STH2r ROT2 ROT2 !&loop ( y** r** )
|
||||
} POP2 POP2 JMP2r ( z** )
|
||||
|
|
|
@ -1,6 +1,8 @@
|
|||
#!/bin/sh
|
||||
|
||||
cp audio.md audio.txt
|
||||
for STEM in audio audio-v2; do
|
||||
cp $STEM.md $STEM.txt
|
||||
done
|
||||
|
||||
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 \
|
||||
|
@ -15,6 +17,8 @@ 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 \
|
||||
testing.tal type-abc.tal tar.tal \
|
||||
audio.md audio.txt synthdemo.tal \
|
||||
audio-v2.md audio-v2.txt \
|
||||
math-notes.txt \
|
||||
; do
|
||||
echo "-> $NAME"
|
||||
cp $NAME /var/www/plastic-idolatry.com/html/erik/nxu
|
||||
|
|
|
@ -0,0 +1,296 @@
|
|||
( 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
69
primes32.tal
|
@ -26,18 +26,15 @@
|
|||
( Smaller primes also run fairly quickly: 0x17b5d was )
|
||||
( determined to be prime in 0.02 seconds. )
|
||||
|
||||
%SP { #2018 DEO }
|
||||
%NL { #0a18 DEO }
|
||||
%EXIT { #ff0f DEO BRK }
|
||||
%DUP4 { OVR2 OVR2 }
|
||||
%POP4 { POP2 POP2 }
|
||||
|
||||
|0100
|
||||
( number to check comes first )
|
||||
#ffff #fffb
|
||||
DUP4 ;is-prime32 JSR2 ( test for primality )
|
||||
STH ;emit/long JSR2 SP STHr ;emit/byte JSR2 NL
|
||||
EXIT
|
||||
#ffff #fffb ( n** ; number to check )
|
||||
DUP4 is-prime32 ( n** is-prime^ ; test for primality )
|
||||
STH emit/long #2018 DEO ( [is-prime^] ; emit n )
|
||||
STHr emit/byte #0a18 DEO ( ; emit boolean )
|
||||
#ff0f DEO BRK ( ; exit )
|
||||
|
||||
( include 32-bit math library )
|
||||
~math32.tal
|
||||
|
@ -45,37 +42,29 @@
|
|||
( return 01 if x is a prime number, else 00 )
|
||||
( works for x >= 2 )
|
||||
@is-prime32 ( x** -> bool^ )
|
||||
,&x1 STR2 ,&x0 STR2 ,&x0 LDR2 ,&x1 LDR2 ( store and reload x )
|
||||
DUP4 #0000 LIT2 &two 0002 ;ne32 JSR2 ( x is 2? )
|
||||
,¬-two JCN POP4 #01 JMP2r ( 2 is prime )
|
||||
¬-two DUP #01 AND ( x x&1 )
|
||||
,¬-even JCN POP4 #00 JMP2r ( x is even: not prime )
|
||||
¬-even DUP4 #0000 #0003 ;ne32 JSR2 ( x is 3? )
|
||||
,¬-three JCN POP4 #01 JMP2r ( 3 is prime )
|
||||
¬-three #0000 ,&i0 STR2 #0005 ,&i1 STR2 ( x i<-5 )
|
||||
,&two LDR2 ,&inc STR2
|
||||
,&i0 LDR2 ,&i1 LDR2 ( load our candidate, i )
|
||||
,&loop JMP ( jump over register data to loop label )
|
||||
[ &i0 0000 &i1 0000 &x0 0000 &x1 0000 &inc 0000 &mask 0006 ] ( registers )
|
||||
&loop ( x i )
|
||||
,&x0 LDR2 ,&x1 LDR2 ,&i0 LDR2 ,&i1 LDR2 ( x i x i )
|
||||
DUP4 ;mul32 JSR2 ;lt32 JSR2 ( x i x<i*i )
|
||||
STH DUP2 #ffff EQU2 STHr ORA ( x i x<i*i||i=0xffff )
|
||||
,&finished JCN ( x i )
|
||||
,&x0 LDR2 ,&x1 LDR2 ,&i0 LDR2 ,&i1 LDR2 ( x i x i )
|
||||
;mod32 JSR2 ;is-zero32 JSR2 ( x i x//i^ )
|
||||
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 )
|
||||
DUP4 ,&x1 STR2 ,&x0 STR2 ( x** ; store x )
|
||||
DUP4 #0000 #0002 ne32 ?{ POP4 #01 JMP2r } ( x** ; return if 2 )
|
||||
DUP #01 AND ?{ POP4 #00 JMP2r } ( x** ; return if even )
|
||||
DUP4 #0000 #0003 ne32 ?{ POP4 #01 JMP2r } ( x** ; return if 3 )
|
||||
#0002 ,&inc STR2 ( x** ; inc<-2 )
|
||||
#0000 #0005 DUP4 ,&i1 STR2 ,&i0 STR2 ( x** i** ; i<-5 )
|
||||
&loop ( x** i** )
|
||||
LIT2 [ &x0 $2 ] LIT2 [ &x1 $2 ] ( x** i** x** )
|
||||
LIT2 [ &i0 $2 ] LIT2 [ &i1 $2 ] ( x** i** x** i** )
|
||||
DUP4 mul32 lt32 ( x** i** x<ii^ )
|
||||
STH DUP2 #ffff EQU2 STHr ORA ( x** i** x<ii|i=0xffff^ )
|
||||
?{ ( x** i** )
|
||||
,&x0 LDR2 ,&x1 LDR2 ,&i0 LDR2 ,&i1 LDR2 ( x** i** x** i** )
|
||||
mod32 is-zero32 ( x** i** x//i^ )
|
||||
STH #0000 ,&inc LDR2 add32 ( x** i+2** [x//i^] )
|
||||
LIT2 [ &inc $2 ] #0006 EOR2 ,&inc STR2 ( x** i+2** [x//i^] ; inc<-inc^6 )
|
||||
DUP4 ,&i1 STR2 ,&i0 STR2 STHr ( x** i+2** x//i^ ; i<-i+2 )
|
||||
?{ !&loop } ( x** i+2** ; if x<j*j, loop )
|
||||
POP4 POP4 #00 JMP2r ( 0^ ; since i divides x, not prime )
|
||||
} POP4 POP4 #01 JMP2r ( 1^ ; didn't find divisors, prime )
|
||||
|
||||
@emit
|
||||
&long SWP2 ,&short JSR
|
||||
&short SWP ,&byte JSR
|
||||
&byte DUP #04 SFT ,&char JSR
|
||||
&char #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO
|
||||
JMP2r
|
||||
&long SWP2 emit/short
|
||||
&short SWP emit/byte
|
||||
&byte DUP #04 SFT emit/char
|
||||
&char #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO JMP2r
|
||||
|
|
408
regex.tal
408
regex.tal
|
@ -97,10 +97,10 @@
|
|||
|
||||
( using error! will print the given message before causing )
|
||||
( the interpreter to halt. )
|
||||
@error!! ( msg* -> )
|
||||
@errorm ( msg* -> )
|
||||
LIT "! emit! space
|
||||
&loop LDAk #00 EQU ,&done JCN
|
||||
LDAk emit! INC2 ,&loop JMP
|
||||
&loop LDAk #00 EQU ?&done
|
||||
LDAk emit! INC2 !&loop
|
||||
&done POP2 newline #ff0e DEO #010f DEO BRK
|
||||
|
||||
( error messages )
|
||||
|
@ -126,34 +126,34 @@
|
|||
@rx-match ( str* regex* -> bool^ )
|
||||
#01 ;match-multiline STA
|
||||
#00 ;search-mode STA
|
||||
;rx-reset JSR2
|
||||
;loop JMP2
|
||||
rx-reset
|
||||
!loop
|
||||
|
||||
@rx-search-multiline ( str* regex* -> bool^ )
|
||||
#01 ;match-multiline STA
|
||||
#01 ;search-mode STA
|
||||
,rx-search/main JMP
|
||||
!rx-search/main
|
||||
|
||||
@rx-search ( str* regex* -> bool^ )
|
||||
#00 ;match-multiline STA
|
||||
#01 ;search-mode STA
|
||||
&main STH2 ( s* [r*] )
|
||||
DUP2 ;string-start STA2 ( s* [r*] )
|
||||
&loop LDAk #00 EQU ,&eof JCN ( s* [r*] )
|
||||
;rx-reset JSR2 ( s* [r*] )
|
||||
&loop LDAk #00 EQU ?&eof ( s* [r*] )
|
||||
rx-reset ( s* [r*] )
|
||||
DUP2 ;search-start STA2 ( s* [r*] )
|
||||
DUP2 STH2kr ;loop JSR2 ( s* b^ [r*] )
|
||||
,&found JCN ( s* [r*] )
|
||||
INC2 ,&loop JMP ( s+1* [r*] )
|
||||
DUP2 STH2kr loop ( s* b^ [r*] )
|
||||
?&found ( s* [r*] )
|
||||
INC2 !&loop ( s+1* [r*] )
|
||||
&found POP2 POP2r #01 JMP2r ( 01 )
|
||||
&eof ;rx-reset JSR2 ( s* [r*] )
|
||||
&eof rx-reset ( s* [r*] )
|
||||
DUP2 ;search-start STA2 ( s* [r*] )
|
||||
STH2r ;loop JMP2 ( b^ )
|
||||
STH2r !loop ( b^ )
|
||||
|
||||
( reset all "runtime" memory allocated during match/search )
|
||||
@rx-reset ( -> )
|
||||
;reset-stack JSR2
|
||||
;subgroup-reset JMP2
|
||||
reset-stack
|
||||
!subgroup-reset
|
||||
|
||||
( loop used during matching )
|
||||
( )
|
||||
|
@ -163,87 +163,87 @@
|
|||
( return a boolean, which is where the stack )
|
||||
( effects signature comes from. )
|
||||
@loop ( s* r* -> bool^ )
|
||||
LDAk #01 EQU ;do-empty JCN2
|
||||
LDAk #02 EQU ;do-dot JCN2
|
||||
LDAk #03 EQU ;do-literal JCN2
|
||||
LDAk #04 EQU ;do-or JCN2
|
||||
LDAk #05 EQU ;do-or JCN2 ( same code as the or case )
|
||||
LDAk #06 EQU ;do-caret JCN2
|
||||
LDAk #07 EQU ;do-dollar JCN2
|
||||
LDAk #08 EQU ;do-lpar JCN2
|
||||
LDAk #09 EQU ;do-rpar JCN2
|
||||
LDAk #0a EQU ;do-ccls JCN2
|
||||
LDAk #0b EQU ;do-ncls JCN2
|
||||
LDAk #dd ;unknown-node-type ;error!! JSR2
|
||||
LDAk #01 EQU ?do-empty
|
||||
LDAk #02 EQU ?do-dot
|
||||
LDAk #03 EQU ?do-literal
|
||||
LDAk #04 EQU ?do-or
|
||||
LDAk #05 EQU ?do-or ( same code as the or case )
|
||||
LDAk #06 EQU ?do-caret
|
||||
LDAk #07 EQU ?do-dollar
|
||||
LDAk #08 EQU ?do-lpar
|
||||
LDAk #09 EQU ?do-rpar
|
||||
LDAk #0a EQU ?do-ccls
|
||||
LDAk #0b EQU ?do-ncls
|
||||
LDAk #dd ;unknown-node-type errorm
|
||||
|
||||
( used when we hit a dead-end during matching. )
|
||||
( )
|
||||
( if stack is non-empty we have a point we can resume from. )
|
||||
@goto-backtrack ( -> bool^ )
|
||||
;stack-exist JSR2 ,&has-stack JCN ( do we have stack? )
|
||||
stack-exist ?&has-stack ( do we have stack? )
|
||||
#00 JMP2r ( no, return false )
|
||||
&has-stack
|
||||
;pop4 JSR2
|
||||
;subgroup-backtrack JSR2
|
||||
;goto-next JMP2 ( yes, resume from the top )
|
||||
pop4
|
||||
subgroup-backtrack
|
||||
!goto-next ( yes, resume from the top )
|
||||
|
||||
( follow the given address (next*) to continue matching )
|
||||
@goto-next ( str* next* -> bool^ )
|
||||
DUP2 #0000 GTH2 ,&has-next JCN
|
||||
POP2 LDAk #00 EQU ,&end-of-string JCN
|
||||
;search-mode LDA ,&end-of-search JCN
|
||||
POP2 ;goto-backtrack JMP2
|
||||
DUP2 #0000 GTH2 ?&has-next
|
||||
POP2 LDAk #00 EQU ?&end-of-string
|
||||
;search-mode LDA ?&end-of-search
|
||||
POP2 !goto-backtrack
|
||||
&end-of-search DUP2 ;search-end STA2
|
||||
&end-of-string POP2 #01 JMP2r
|
||||
&has-next ;loop JMP2
|
||||
&has-next !loop
|
||||
|
||||
( handle the empty node -- just follow the next pointer )
|
||||
@do-empty ( str* regex* -> bool^ )
|
||||
INC2 LDA2 ( load next )
|
||||
;goto-next JMP2 ( jump to next )
|
||||
!goto-next ( jump to next )
|
||||
|
||||
( FIXME: not currently used )
|
||||
@do-lpar ( str* regex* -> bool^ )
|
||||
STH2 DUP2 ( s s [r] )
|
||||
INC2r LDA2kr STH2r ( s s i [r+1] )
|
||||
;subgroup-start JSR2 ( s [r+1] )
|
||||
subgroup-start ( s [r+1] )
|
||||
STH2r INC2 INC2 ( s r+3 )
|
||||
LDA2 ;goto-next JMP2 ( jump to next )
|
||||
LDA2 !goto-next ( jump to next )
|
||||
|
||||
( FIXME: not currently used )
|
||||
@do-rpar ( str* regex* -> bool^ )
|
||||
STH2 DUP2 ( s s [r] )
|
||||
INC2r LDA2kr STH2r ( s s i [r+1] )
|
||||
;subgroup-finish JSR2 ( s [r+1] )
|
||||
subgroup-finish ( s [r+1] )
|
||||
STH2r INC2 INC2 ( s r+3 )
|
||||
LDA2 ;goto-next JMP2 ( jump to next )
|
||||
LDA2 !goto-next ( jump to next )
|
||||
|
||||
( handle dot -- match any one character )
|
||||
@do-dot ( str* regex* -> bool^ )
|
||||
INC2 LDA2 STH2 ( load and stash next )
|
||||
LDAk #00 NEQ ,&non-empty JCN ( is there a char? )
|
||||
&backtrack POP2r POP2 ;goto-backtrack JMP2 ( no, clear stacks and backtrack )
|
||||
&non-empty LDAk #0a NEQ ,&match JCN ( yes, match unless \n in search-mode )
|
||||
;search-mode LDA ,&backtrack JCN ( if \n and search-mode, treat as EOF )
|
||||
&match INC2 STH2r ;goto-next JMP2 ( on match: inc s, restore and jump )
|
||||
LDAk #00 NEQ ?&non-empty ( is there a char? )
|
||||
&backtrack POP2r POP2 !goto-backtrack ( no, clear stacks and backtrack )
|
||||
&non-empty LDAk #0a NEQ ?&match ( yes, match unless \n in search-mode )
|
||||
;search-mode LDA ?&backtrack ( if \n and search-mode, treat as EOF )
|
||||
&match INC2 STH2r !goto-next ( on match: inc s, restore and jump )
|
||||
|
||||
( hande caret -- match string start (or possibly after newline) without advancing )
|
||||
@do-caret ( str* regex* -> bool^ )
|
||||
INC2 LDA2 STH2 ( load and stash next )
|
||||
DUP2 ;string-start LDA2 EQU2 ,&at-start JCN ( at string start? )
|
||||
;match-multiline LDA ,&no-match JCN ( are we in multi-line mode? )
|
||||
DUP2 #0001 SUB2 LDA #0a EQU ,&at-start JCN ( just after newline? )
|
||||
&no-match POP2r POP2 ;goto-backtrack JMP2 ( clear stacks and backtrack )
|
||||
&at-start STH2r ;goto-next JMP2 ( go to next without advancing )
|
||||
DUP2 ;string-start LDA2 EQU2 ?&at-start ( at string start? )
|
||||
;match-multiline LDA ?&no-match ( are we in multi-line mode? )
|
||||
DUP2 #0001 SUB2 LDA #0a EQU ?&at-start ( just after newline? )
|
||||
&no-match POP2r POP2 !goto-backtrack ( clear stacks and backtrack )
|
||||
&at-start STH2r !goto-next ( go to next without advancing )
|
||||
|
||||
( hande dollar -- match string end (or possibly before newline) without advancing )
|
||||
@do-dollar ( str* regex* -> bool^ )
|
||||
INC2 LDA2 STH2 ( load and stash next )
|
||||
LDAk #00 EQU ,&at-end JCN ( at string end? )
|
||||
;match-multiline LDA ,&no-match JCN ( are we in multi-line mode? )
|
||||
LDAk #0a EQU ,&at-end JCN ( at newline? )
|
||||
&no-match POP2r POP2 ;goto-backtrack JMP2 ( clear stacks and backtrack )
|
||||
&at-end STH2r ;goto-next JMP2 ( go to next without advancing )
|
||||
LDAk #00 EQU ?&at-end ( at string end? )
|
||||
;match-multiline LDA ?&no-match ( are we in multi-line mode? )
|
||||
LDAk #0a EQU ?&at-end ( at newline? )
|
||||
&no-match POP2r POP2 !goto-backtrack ( clear stacks and backtrack )
|
||||
&at-end STH2r !goto-next ( go to next without advancing )
|
||||
|
||||
( handle literal -- match one specific character )
|
||||
@do-literal ( str* regex* -> bool^ )
|
||||
|
@ -251,23 +251,23 @@
|
|||
LDAk STH ( store c )
|
||||
INC2 LDA2 STH2 ROTr ( store next, move c to top )
|
||||
LDAk
|
||||
STHr EQU ,&matches JCN ( do we match this char? )
|
||||
POP2r POP2 ;goto-backtrack JMP2 ( no, clear stacks and backtrack )
|
||||
STHr EQU ?&matches ( do we match this char? )
|
||||
POP2r POP2 !goto-backtrack ( no, clear stacks and backtrack )
|
||||
&matches
|
||||
INC2 STH2r ;goto-next JMP2 ( yes, inc s, restore and jump )
|
||||
INC2 STH2r !goto-next ( yes, inc s, restore and jump )
|
||||
|
||||
( 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 )
|
||||
@do-or ( str* regex* -> bool^ )
|
||||
INC2 OVR2 OVR2 #0002 ADD2 ( s r+1 s r+3 )
|
||||
LDA2 ;push4 JSR2 ( save (s, right) in the stack for possible backtracking )
|
||||
LDA2 ;loop JMP2 ( continue on left branch )
|
||||
LDA2 push4 ( save (s, right) in the stack for possible backtracking )
|
||||
LDA2 !loop ( continue on left branch )
|
||||
|
||||
@matches-cls ( str* regex* -> bool^ )
|
||||
OVR2 LDA ,¬-null JCN
|
||||
OVR2 LDA ?¬-null
|
||||
( needs to have a character to match )
|
||||
POP2 POP2 ;goto-backtrack JMP2
|
||||
POP2 POP2 !goto-backtrack
|
||||
¬-null
|
||||
DUP2 INC2 LDA2 STH2 ( str regex [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] )
|
||||
SWP2 INC2 STH2k ADD2 STH2r ( r+4+len*2 r+4 [c str+1 next] )
|
||||
&loop ( limit addr [c str+1 next] )
|
||||
EQU2k ,&missing JCN
|
||||
LDAk STHkr GTH ,&next1 JCN INC2
|
||||
LDAk STHkr LTH ,&next2 JCN ,&found JMP
|
||||
EQU2k ?&missing
|
||||
LDAk STHkr GTH ?&next1 INC2
|
||||
LDAk STHkr LTH ?&next2 !&found
|
||||
&next1 INC2
|
||||
&next2 INC2 ,&loop JMP
|
||||
&missing POP2 POP2 POPr ,&negated LDR ,&match JCN
|
||||
&no-match POP2r POP2r ;goto-backtrack JMP2
|
||||
&found POP2 POP2 POPr ,&negated LDR ,&no-match JCN
|
||||
&match STH2r STH2r ;goto-next JMP2
|
||||
&next2 INC2 !&loop
|
||||
&missing POP2 POP2 POPr ,&negated LDR ?&match
|
||||
&no-match POP2r POP2r !goto-backtrack
|
||||
&found POP2 POP2 POPr ,&negated LDR ?&no-match
|
||||
&match STH2r STH2r !goto-next
|
||||
[ &negated $1 ]
|
||||
|
||||
( )
|
||||
@do-ccls ( str* regex* -> bool^ )
|
||||
#00 ,matches-cls/negated STR ,matches-cls JMP
|
||||
#00 ,matches-cls/negated STR !matches-cls
|
||||
|
||||
( )
|
||||
@do-ncls ( str* regex* -> bool^ )
|
||||
#01 ,matches-cls/negated STR ,matches-cls JMP
|
||||
#01 ,matches-cls/negated STR !matches-cls
|
||||
|
||||
( REGEX PARSING )
|
||||
|
||||
|
@ -325,9 +325,9 @@
|
|||
@read ( -> c^ )
|
||||
;pos LDA2k ( pos s )
|
||||
LDAk STHk #00 EQU ( pos s c=0 [c] )
|
||||
,&is-eof JCN ( pos s [c] )
|
||||
?&is-eof ( pos s [c] )
|
||||
INC2 ( pos s+1 [c] )
|
||||
SWP2 STA2 ,&return JMP ( [c] )
|
||||
SWP2 STA2 !&return ( [c] )
|
||||
&is-eof POP2 POP2
|
||||
&return STHr ( c )
|
||||
JMP2r
|
||||
|
@ -370,8 +370,8 @@
|
|||
@compile ( expr* -> regex* )
|
||||
;pos STA2
|
||||
#0000 ;parens STA2
|
||||
;rx-reset JSR2
|
||||
;compile-region JMP2
|
||||
rx-reset
|
||||
!compile-region
|
||||
|
||||
( the basic strategy here is to build a stack of non-or )
|
||||
( expressions to be joined together at the end of the )
|
||||
|
@ -385,24 +385,24 @@
|
|||
( by #ffff #ffff. above that we start with #0000 #0000 )
|
||||
( to signal an empty node. )
|
||||
@compile-region ( -> r2* )
|
||||
#ffff #ffff ;push4 JSR2 ( stack delimiter )
|
||||
#0000 #0000 ;push4 JSR2 ( stack frame start )
|
||||
#ffff #ffff push4 ( stack delimiter )
|
||||
#0000 #0000 push4 ( stack frame start )
|
||||
@compile-region-loop
|
||||
;read JSR2
|
||||
DUP #00 EQU ;c-done JCN2
|
||||
DUP LIT "| EQU ;c-or JCN2
|
||||
DUP LIT ". EQU ;c-dot JCN2
|
||||
DUP LIT "^ EQU ;c-caret JCN2
|
||||
DUP LIT "$ EQU ;c-dollar JCN2
|
||||
DUP LIT "( EQU ;c-lpar JCN2
|
||||
DUP LIT ") EQU ;c-rpar JCN2
|
||||
DUP LIT "[ EQU ;c-lbrk JCN2
|
||||
DUP LIT "] EQU ;c-rbrk JCN2
|
||||
DUP LIT "\ EQU ;c-esc JCN2
|
||||
DUP LIT "* EQU ;c-star JCN2
|
||||
DUP LIT "+ EQU ;c-plus JCN2
|
||||
DUP LIT "? EQU ;c-qmark JCN2
|
||||
;c-char JMP2
|
||||
read
|
||||
DUP #00 EQU ?c-done
|
||||
DUP LIT "| EQU ?c-or
|
||||
DUP LIT ". EQU ?c-dot
|
||||
DUP LIT "^ EQU ?c-caret
|
||||
DUP LIT "$ EQU ?c-dollar
|
||||
DUP LIT "( EQU ?c-lpar
|
||||
DUP LIT ") EQU ?c-rpar
|
||||
DUP LIT "[ EQU ?c-lbrk
|
||||
DUP LIT "] EQU ?c-rbrk
|
||||
DUP LIT "\ EQU ?c-esc
|
||||
DUP LIT "* EQU ?c-star
|
||||
DUP LIT "+ EQU ?c-plus
|
||||
DUP LIT "? EQU ?c-qmark
|
||||
!c-char
|
||||
|
||||
( either finalize the given r0/r1 or else wrap it in )
|
||||
( a star node if a star is coming up next. )
|
||||
|
@ -410,14 +410,14 @@
|
|||
( we use this look-ahead approach rather than compiling )
|
||||
( star nodes directly since the implementation is simpler. )
|
||||
@c-peek-and-finalize ( r0* r1* -> r2* )
|
||||
;peek-to-star JSR2 ( r0 r1 next-is-star? ) ,&next-is-star JCN
|
||||
;peek-to-plus JSR2 ( r0 r1 next-is-plus? ) ,&next-is-plus JCN
|
||||
;peek-to-qmark JSR2 ( r0 r1 next-is-qmark? ) ,&next-is-qmark JCN
|
||||
,&finally JMP ( r0 r1 )
|
||||
&next-is-star ;skip JSR2 POP2 ;alloc-star JSR2 DUP2 ,&finally JMP
|
||||
&next-is-plus ;skip JSR2 POP2 ;alloc-plus JSR2 DUP2 ,&finally JMP
|
||||
&next-is-qmark ;skip JSR2 POP2 ;alloc-qmark JSR2 DUP2 ,&finally JMP
|
||||
&finally ;push-next JSR2 ;compile-region-loop JMP2
|
||||
peek-to-star ( r0 r1 next-is-star? ) ?&next-is-star
|
||||
peek-to-plus ( r0 r1 next-is-plus? ) ?&next-is-plus
|
||||
peek-to-qmark ( r0 r1 next-is-qmark? ) ?&next-is-qmark
|
||||
!&finally ( r0 r1 )
|
||||
&next-is-star skip POP2 alloc-star DUP2 !&finally
|
||||
&next-is-plus skip POP2 alloc-plus DUP2 !&finally
|
||||
&next-is-qmark skip POP2 alloc-qmark DUP2 !&finally
|
||||
&finally push-next !compile-region-loop
|
||||
|
||||
( called when we reach EOF of the input string )
|
||||
( )
|
||||
|
@ -427,9 +427,9 @@
|
|||
( this is where we detect unclosed parenthesis. )
|
||||
@c-done ( c^ -> r2* )
|
||||
POP
|
||||
;parens LDA2 #0000 GTH2 ,&mismatched-parens JCN
|
||||
;unroll-stack JSR2 POP2 JMP2r
|
||||
&mismatched-parens ;mismatched-parens ;error!! JSR2
|
||||
;parens LDA2 #0000 GTH2 ?&mismatched-parens
|
||||
unroll-stack POP2 JMP2r
|
||||
&mismatched-parens ;mismatched-parens errorm
|
||||
|
||||
( called when we read "|" )
|
||||
( )
|
||||
|
@ -437,8 +437,8 @@
|
|||
( we just start a new stack frame and continue. )
|
||||
@c-or ( c^ -> r2* )
|
||||
POP
|
||||
#0000 #0000 ;push4 JSR2
|
||||
;compile-region-loop JMP2
|
||||
#0000 #0000 push4
|
||||
!compile-region-loop
|
||||
|
||||
( called when we read left parenthesis )
|
||||
( )
|
||||
|
@ -450,7 +450,7 @@
|
|||
@c-lpar ( c^ -> r2* )
|
||||
POP
|
||||
;parens LDA2 INC2 ;parens STA2 ( parens++ )
|
||||
;compile-region JMP2
|
||||
!compile-region
|
||||
|
||||
( called when we read right parenthesis )
|
||||
( )
|
||||
|
@ -463,34 +463,34 @@
|
|||
( 5. continue parsing )
|
||||
@c-rpar ( c^ -> r2* )
|
||||
POP
|
||||
;parens LDA2 #0000 EQU2 ,&mismatched-parens JCN
|
||||
;parens LDA2 #0000 EQU2 ?&mismatched-parens
|
||||
;parens LDA2 #0001 SUB2 ;parens STA2 ( parens-- )
|
||||
;unroll-stack JSR2
|
||||
;c-peek-and-finalize JMP2
|
||||
&mismatched-parens ;mismatched-parens ;error!! JSR2
|
||||
unroll-stack
|
||||
!c-peek-and-finalize
|
||||
&mismatched-parens ;mismatched-parens errorm
|
||||
|
||||
( doesn't support weird things like []abc] or [-abc] or similar. )
|
||||
( doesn't currently handle "special" escapes such as \n )
|
||||
@c-lbrk ( c^ -> r2* )
|
||||
POP LITr 00 ;pos LDA2 ( pos [0] )
|
||||
LDAk LIT "^ NEQ ,&normal JCN INCr INC2 ( pos [negated?^] )
|
||||
LDAk LIT "^ NEQ ?&normal INCr INC2 ( pos [negated?^] )
|
||||
&normal
|
||||
#0a STHr ADD ( src* type^ )
|
||||
;arena-pos LDA2 STH2k ( src* type^ dst* [dst*] )
|
||||
STA LIT2r 0004 ADD2r ( src* [dst+4] )
|
||||
&left-parse ( src* [dst*] )
|
||||
LDAk LIT "] EQU ,&done JCN
|
||||
LDAk LIT "- EQU ,&error JCN
|
||||
LDAk LIT "\ NEQ ,&left JCN INC2
|
||||
LDAk LIT "] EQU ?&done
|
||||
LDAk LIT "- EQU ?&error
|
||||
LDAk LIT "\ NEQ ?&left INC2
|
||||
&left
|
||||
LDAk STH2kr STA INC2r
|
||||
DUP2 INC2 LDA LIT "- NEQ ,&pre-right JCN INC2 INC2
|
||||
LDAk LIT "] EQU ,&error JCN
|
||||
LDAk LIT "- EQU ,&error JCN
|
||||
DUP2 INC2 LDA LIT "- NEQ ?&pre-right INC2 INC2
|
||||
LDAk LIT "] EQU ?&error
|
||||
LDAk LIT "- EQU ?&error
|
||||
&pre-right
|
||||
LDAk LIT "\ NEQ ,&right JCN INC2
|
||||
LDAk LIT "\ NEQ ?&right INC2
|
||||
&right
|
||||
LDAk STH2kr STA INC2 INC2r ,&left-parse JMP
|
||||
LDAk STH2kr STA INC2 INC2r !&left-parse
|
||||
&done ( src* [dst*] )
|
||||
INC2 ;pos STA2 STH2r ( dst* )
|
||||
DUP2 ;arena-pos LDA2 ( dst dst a )
|
||||
|
@ -498,7 +498,7 @@
|
|||
;arena-pos LDA2 STH2k #0003 ADD2 STA ( dst [a] )
|
||||
;arena-pos STA2 STH2r ( a )
|
||||
#0000 OVR2 INC2 STA2 ( a )
|
||||
DUP2 ;c-peek-and-finalize JMP2
|
||||
DUP2 !c-peek-and-finalize
|
||||
&error
|
||||
#abcd #0000 DIV ( TODO error here )
|
||||
|
||||
|
@ -511,24 +511,24 @@
|
|||
( allocates a dot-node and continues. )
|
||||
@c-dot ( c^ -> r2* )
|
||||
POP
|
||||
#02 ;alloc3 JSR2
|
||||
DUP2 ;c-peek-and-finalize JMP2
|
||||
#02 alloc3
|
||||
DUP2 !c-peek-and-finalize
|
||||
|
||||
( called when we read "^" )
|
||||
( )
|
||||
( allocates a caret-node and continues. )
|
||||
@c-caret ( c^ -> r2* )
|
||||
POP
|
||||
#06 ;alloc3 JSR2
|
||||
DUP2 ;c-peek-and-finalize JMP2
|
||||
#06 alloc3
|
||||
DUP2 !c-peek-and-finalize
|
||||
|
||||
( called when we read "$" )
|
||||
( )
|
||||
( allocates a dollar-node and continues. )
|
||||
@c-dollar ( c^ -> r2* )
|
||||
POP
|
||||
#07 ;alloc3 JSR2
|
||||
DUP2 ;c-peek-and-finalize JMP2
|
||||
#07 alloc3
|
||||
DUP2 !c-peek-and-finalize
|
||||
|
||||
( called when we read "\" )
|
||||
( )
|
||||
|
@ -536,50 +536,50 @@
|
|||
( )
|
||||
( otherwise, allocates a literal of the next character. )
|
||||
@c-esc ( c^ -> r2* )
|
||||
POP ;read JSR2
|
||||
DUP LIT "a EQU ,&bel JCN
|
||||
DUP LIT "b EQU ,&bs JCN
|
||||
DUP LIT "t EQU ,&tab JCN
|
||||
DUP LIT "n EQU ,&nl JCN
|
||||
DUP LIT "v EQU ,&vtab JCN
|
||||
DUP LIT "f EQU ,&ff JCN
|
||||
DUP LIT "r EQU ,&cr JCN
|
||||
&default ;c-char JMP2
|
||||
&bel POP #07 ,&default JMP
|
||||
&bs POP #08 ,&default JMP
|
||||
&tab POP #09 ,&default JMP
|
||||
&nl POP #0a ,&default JMP
|
||||
&vtab POP #0b ,&default JMP
|
||||
&ff POP #0c ,&default JMP
|
||||
&cr POP #0d ,&default JMP
|
||||
POP read
|
||||
DUP LIT "a EQU ?&bel
|
||||
DUP LIT "b EQU ?&bs
|
||||
DUP LIT "t EQU ?&tab
|
||||
DUP LIT "n EQU ?&nl
|
||||
DUP LIT "v EQU ?&vtab
|
||||
DUP LIT "f EQU ?&ff
|
||||
DUP LIT "r EQU ?&cr
|
||||
&default !c-char
|
||||
&bel POP #07 !&default
|
||||
&bs POP #08 !&default
|
||||
&tab POP #09 !&default
|
||||
&nl POP #0a !&default
|
||||
&vtab POP #0b !&default
|
||||
&ff POP #0c !&default
|
||||
&cr POP #0d !&default
|
||||
|
||||
( called when we read any other character )
|
||||
( )
|
||||
( allocates a literal-node and continues. )
|
||||
@c-char ( c^ -> r2* )
|
||||
;alloc-lit JSR2 ( lit )
|
||||
DUP2 ;c-peek-and-finalize JMP2
|
||||
alloc-lit ( lit )
|
||||
DUP2 !c-peek-and-finalize
|
||||
|
||||
( called if we parse a "*" )
|
||||
( )
|
||||
( actually calling this means the code broke an invariant somewhere. )
|
||||
@c-star ( c^ -> regex* )
|
||||
POP
|
||||
;star-invariant ;error!! JSR2
|
||||
;star-invariant errorm
|
||||
|
||||
( called if we parse a "+" )
|
||||
( )
|
||||
( actually calling this means the code broke an invariant somewhere. )
|
||||
@c-plus ( c^ -> regex* )
|
||||
POP
|
||||
;plus-invariant ;error!! JSR2
|
||||
;plus-invariant errorm
|
||||
|
||||
( called if we parse a "?" )
|
||||
( )
|
||||
( actually calling this means the code broke an invariant somewhere. )
|
||||
@c-qmark ( c^ -> regex* )
|
||||
POP
|
||||
;qmark-invariant ;error!! JSR2
|
||||
;qmark-invariant errorm
|
||||
|
||||
( ALLOCATING REGEX NDOES )
|
||||
|
||||
|
@ -589,51 +589,51 @@
|
|||
|
||||
@alloc3 ( mode^ -> r* )
|
||||
#0000 ROT ( 00 00 mode^ )
|
||||
#03 ;alloc JSR2 ( 00 00 mode^ addr* )
|
||||
#03 alloc ( 00 00 mode^ addr* )
|
||||
STH2k STA ( addr <- mode )
|
||||
STH2kr INC2 STA2 ( addr+1 <- 0000 )
|
||||
STH2r JMP2r ( return addr )
|
||||
|
||||
@alloc-empty ( -> r* )
|
||||
#01 ;alloc3 JMP2
|
||||
#01 !alloc3
|
||||
|
||||
@alloc-lit ( c^ -> r* )
|
||||
#03 #0000 SWP2 ( 0000 c^ 03 )
|
||||
#04 ;alloc JSR2 ( 0000 c^ 03 addr* )
|
||||
#04 alloc ( 0000 c^ 03 addr* )
|
||||
STH2k STA ( addr <- 03 )
|
||||
STH2kr INC2 STA ( addr+1 <- c )
|
||||
STH2kr #0002 ADD2 STA2 ( addr+2 <- 0000 )
|
||||
STH2r JMP2r ( return addr )
|
||||
|
||||
@alloc-or ( right* left* -> r* )
|
||||
#05 ;alloc JSR2 STH2 ( r l [x] )
|
||||
#05 alloc STH2 ( r l [x] )
|
||||
#04 STH2kr STA ( r l [x] )
|
||||
STH2kr INC2 STA2 ( r [x] )
|
||||
STH2kr #0003 ADD2 STA2 ( [x] )
|
||||
STH2r JMP2r
|
||||
|
||||
@alloc-star ( expr* -> r* )
|
||||
#05 ;alloc JSR2 STH2 ( expr [r] )
|
||||
#05 alloc STH2 ( expr [r] )
|
||||
#05 STH2kr STA ( expr [r] )
|
||||
DUP2 STH2kr INC2 STA2 ( expr [r] )
|
||||
#0000 STH2kr #0003 ADD2 STA2 ( expr [r] )
|
||||
STH2kr SWP2 ( r expr [r] )
|
||||
;set-next JSR2 ( [r] )
|
||||
set-next ( [r] )
|
||||
STH2r JMP2r
|
||||
|
||||
@alloc-plus ( expr* -> r* )
|
||||
#05 ;alloc JSR2 STH2 ( expr [r] )
|
||||
#05 alloc STH2 ( expr [r] )
|
||||
#05 STH2kr STA ( expr [r] )
|
||||
DUP2 STH2kr INC2 STA2 ( expr [r] )
|
||||
#0000 STH2kr #0003 ADD2 STA2 ( expr [r] )
|
||||
STH2r SWP2 STH2k ( r expr [expr] )
|
||||
;set-next JSR2 ( [expr] )
|
||||
set-next ( [expr] )
|
||||
STH2r JMP2r
|
||||
|
||||
@alloc-qmark ( expr* -> r* )
|
||||
;alloc-empty JSR2 STH2k ( expr e [e] )
|
||||
OVR2 ;set-next JSR2 ( expr [e] )
|
||||
#05 ;alloc JSR2 STH2 ( expr [r e] )
|
||||
alloc-empty STH2k ( expr e [e] )
|
||||
OVR2 set-next ( expr [e] )
|
||||
#05 alloc STH2 ( expr [r e] )
|
||||
#04 STH2kr STA ( expr [r e] )
|
||||
STH2kr INC2 STA2 ( [r e] )
|
||||
SWP2r STH2r STH2kr ( e r [r] )
|
||||
|
@ -642,7 +642,7 @@
|
|||
|
||||
( if r is 0000, allocate an empty node )
|
||||
@alloc-if-null ( r* -> r2* )
|
||||
ORAk ,&return JCN POP2 ;alloc-empty JSR2 &return JMP2r
|
||||
ORAk ?&return POP2 alloc-empty &return JMP2r
|
||||
|
||||
( unroll one region of the parsing stack, returning )
|
||||
( a single node consisting of an alternation of )
|
||||
|
@ -651,23 +651,23 @@
|
|||
( this unrolls until it hits #ffff #ffff, which it )
|
||||
( also removes from the stack. )
|
||||
@unroll-stack ( -> start* end* )
|
||||
;pop4 JSR2 STH2 ( r )
|
||||
pop4 STH2 ( r )
|
||||
#00 STH ( count items in stack frame )
|
||||
;alloc-if-null JSR2 ( replace 0000 with empty )
|
||||
alloc-if-null ( replace 0000 with empty )
|
||||
&loop ( r* )
|
||||
;pop4 JSR2 POP2 ( r x )
|
||||
DUP2 #ffff EQU2 ( r x x-is-end? ) ,&done JCN
|
||||
pop4 POP2 ( r x )
|
||||
DUP2 #ffff EQU2 ( r x x-is-end? ) ?&done
|
||||
INCr ( items++ )
|
||||
;alloc-or JSR2 ( r|x ) ,&loop JMP
|
||||
alloc-or ( r|x ) !&loop
|
||||
&done
|
||||
( r ffff )
|
||||
POP2
|
||||
STHr ,&is-or JCN
|
||||
STHr ?&is-or
|
||||
STH2r JMP2r
|
||||
&is-or
|
||||
POP2r
|
||||
;alloc-empty JSR2 OVR2 OVR2 SWP2 ( r empty empty r )
|
||||
;set-next-or JSR2
|
||||
alloc-empty OVR2 OVR2 SWP2 ( r empty empty r )
|
||||
set-next-or
|
||||
JMP2r
|
||||
|
||||
( add r to the top of the stock. )
|
||||
|
@ -675,21 +675,21 @@
|
|||
( in particular, this will write r into tail.next )
|
||||
( before replacing tail with r. )
|
||||
@push-next ( r0 r1 -> )
|
||||
;pop4 JSR2 ( r0 r1 x0 x1 )
|
||||
DUP2 #0000 EQU2 ( r0 r1 x0 x1 x1=0? ) ,&is-zero JCN
|
||||
pop4 ( r0 r1 x0 x1 )
|
||||
DUP2 #0000 EQU2 ( r0 r1 x0 x1 x1=0? ) ?&is-zero
|
||||
STH2 ROT2 STH2r ( r1 x0 r0 x1 )
|
||||
;set-next JSR2 SWP2 ( x0 r1 )
|
||||
;push4 JSR2
|
||||
set-next SWP2 ( x0 r1 )
|
||||
push4
|
||||
JMP2r
|
||||
&is-zero POP2 POP2 ;push4 JMP2
|
||||
&is-zero POP2 POP2 !push4
|
||||
|
||||
( load the given address: )
|
||||
( )
|
||||
( 1. if it points to 0000, update it to target )
|
||||
( 2. otherwise, call set-next on it )
|
||||
@set-next-addr ( target* addr* -> )
|
||||
LDA2k #0000 EQU2 ( target addr addr=0? ) ,&is-zero JCN
|
||||
LDA2 ;set-next JMP2
|
||||
LDA2k #0000 EQU2 ( target addr addr=0? ) ?&is-zero
|
||||
LDA2 !set-next
|
||||
&is-zero STA2 JMP2r
|
||||
|
||||
( set regex.next to target )
|
||||
|
@ -703,18 +703,18 @@
|
|||
( back up we only bother taking the left branch. otherwise )
|
||||
( you can end up double-appending things. )
|
||||
@set-next ( target* regex* -> )
|
||||
LDAk #01 LTH ,&unknown JCN
|
||||
LDAk #0b GTH ,&unknown JCN
|
||||
LDAk #09 GTH ,&cc JCN
|
||||
LDAk #01 LTH ?&unknown
|
||||
LDAk #0b GTH ?&unknown
|
||||
LDAk #09 GTH ?&cc
|
||||
LDAk #00 SWP ;rx-node-sizes ADD2
|
||||
LDA #00 SWP ADD2 #0002 SUB2
|
||||
;set-next-addr JMP2
|
||||
&cc INC2 ;set-next-addr JMP2
|
||||
&unknown LDAk #ee ;unknown-node-type ;error!! JSR2
|
||||
!set-next-addr
|
||||
&cc INC2 !set-next-addr
|
||||
&unknown LDAk #ee ;unknown-node-type errorm
|
||||
|
||||
@set-next-or-addr ( target* addr* -> )
|
||||
LDA2k #0000 EQU2 ( target addr addr=0? ) ,&is-zero JCN
|
||||
LDA2 ;set-next-or JMP2
|
||||
LDA2k #0000 EQU2 ( target addr addr=0? ) ?&is-zero
|
||||
LDA2 !set-next-or
|
||||
&is-zero STA2 JMP2r
|
||||
|
||||
( this is used when first building or-nodes )
|
||||
|
@ -722,10 +722,10 @@
|
|||
( [x1, [x2, [x3, ..., [xm, xn]]]] )
|
||||
( so we recurse on the right side but not the left. )
|
||||
@set-next-or ( target* regex* -> )
|
||||
LDAk #04 NEQ ,&!4 JCN
|
||||
OVR2 OVR2 INC2 ;set-next-addr JSR2
|
||||
#0003 ADD2 ;set-next-or-addr JMP2
|
||||
&!4 ;set-next JMP2
|
||||
LDAk #04 NEQ ?&!4
|
||||
OVR2 OVR2 INC2 set-next-addr
|
||||
#0003 ADD2 !set-next-or-addr
|
||||
&!4 !set-next
|
||||
|
||||
( STACK OPERATIONS )
|
||||
( )
|
||||
|
@ -741,7 +741,7 @@
|
|||
|
||||
( push 4 bytes onto the stack )
|
||||
@push4 ( str* regex* -> )
|
||||
;assert-stack-avail JSR2 ( check for space )
|
||||
assert-stack-avail ( check for space )
|
||||
;stack-pos LDA2 #0002 ADD2 STA2 ( cell[2:3] <- regex )
|
||||
;stack-pos LDA2 STA2 ( cell[0:1] <- str )
|
||||
;stack-pos LDA2 #0004 ADD2 ;stack-pos STA2 ( pos += 4 )
|
||||
|
@ -749,7 +749,7 @@
|
|||
|
||||
( pop 4 bytes from the stack )
|
||||
@pop4 ( -> str* regex* )
|
||||
;assert-stack-exist JSR2 ( check for space )
|
||||
assert-stack-exist ( check for space )
|
||||
;stack-pos LDA2 ( load stack-pos )
|
||||
#0002 SUB2 LDA2k STH2 ( pop and stash regex )
|
||||
#0002 SUB2 LDA2k STH2 ( pop and stash str )
|
||||
|
@ -771,14 +771,14 @@
|
|||
|
||||
( error if stack is full )
|
||||
@assert-stack-avail ( -> )
|
||||
;stack-avail JSR2 ,&ok JCN ;stack-is-full ;error!! JSR2 &ok JMP2r
|
||||
stack-avail ?&ok ;stack-is-full errorm &ok JMP2r
|
||||
|
||||
( error is stack is empty )
|
||||
@assert-stack-exist ( -> )
|
||||
;stack-exist JSR2 ,&ok JCN ;stack-is-empty ;error!! JSR2 &ok JMP2r
|
||||
stack-exist ?&ok ;stack-is-empty errorm &ok JMP2r
|
||||
|
||||
( 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-top is the address of the first byte beyond the stack. )
|
||||
|
@ -810,12 +810,12 @@
|
|||
#00 SWP ( size* )
|
||||
;arena-pos LDA2 STH2k ADD2 ( pos+size* [pos] )
|
||||
DUP2 ;arena-top GTH2 ( pos+size pos+size>top? [pos] )
|
||||
,&error JCN ( pos+size [pos] )
|
||||
?&error ( pos+size [pos] )
|
||||
;arena-pos STA2 ( pos += size [pos] )
|
||||
STH2r JMP2r ( pos )
|
||||
&error POP2 POP2r ;arena-is-full ;error!! JSR2
|
||||
&error POP2 POP2r ;arena-is-full errorm
|
||||
|
||||
@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 )
|
||||
|
||||
( SUBGROUP OPERATIONS )
|
||||
|
@ -870,7 +870,7 @@
|
|||
|
||||
@subgroup-start ( s* i^ -> )
|
||||
;subgroup-pos LDA2 STH2k ( s* i^ pos* [pos*] )
|
||||
;subgroup-top LTH2 ,&next JCN #0000 DIV ( too many subgroups )
|
||||
;subgroup-top LTH2 ?&next #0000 DIV ( too many subgroups )
|
||||
&next ( s* i^ [pos*] )
|
||||
STH2kr STA
|
||||
STH2r INC2 STA2
|
||||
|
@ -878,9 +878,9 @@
|
|||
|
||||
@subgroup-finish ( s* i^ -> )
|
||||
;subgroup-pos LDA2 STH2k ( s* i^ pos* [pos*] )
|
||||
;subgroup-top LTH2 ,&next JCN #0000 DIV ( too many subgroups )
|
||||
;subgroup-top LTH2 ?&next #0000 DIV ( too many subgroups )
|
||||
&next ( s* i^ [pos*] )
|
||||
STH2kr LDA EQU ,&ok JCN #0000 DIV ( mismatched subgroups )
|
||||
STH2kr LDA EQU ?&ok #0000 DIV ( mismatched subgroups )
|
||||
&ok ( s* [pos*] )
|
||||
STH2kr #0003 ADD2 STA2
|
||||
STH2r #0005 ADD2 ;subgroup-pos STA2
|
||||
|
@ -888,7 +888,7 @@
|
|||
|
||||
@subgroup-branch ( -> )
|
||||
;subgroup-pos LDA2 STH2k ( pos* [pos*] )
|
||||
;subgroup-top LTH2 ,&next JCN #0000 DIV ( too many subgroups )
|
||||
;subgroup-top LTH2 ?&next #0000 DIV ( too many subgroups )
|
||||
&next
|
||||
#00 STH2kr STA ( [*pos] )
|
||||
STH2r #0005 ADD2 ;subgroup-pos STA2
|
||||
|
@ -897,9 +897,9 @@
|
|||
@subgroup-backtrack ( -> )
|
||||
;subgroup-bot ;subgroup-pos LDA2 ( bot* pos* )
|
||||
&loop ( bot* pos* )
|
||||
EQU2k ,&done JCN
|
||||
LDAk #00 EQU ,&done JCN
|
||||
#0005 SUB2 ,&loop JMP
|
||||
EQU2k ?&done
|
||||
LDAk #00 EQU ?&done
|
||||
#0005 SUB2 !&loop
|
||||
&done ( bot* pos* )
|
||||
NIP2 ;subgroup-pos STA2
|
||||
JMP2r
|
||||
|
@ -909,5 +909,5 @@
|
|||
;subgroup-bot ;subgroup-pos STA2
|
||||
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) )
|
||||
|
|
34
tal.nanorc
34
tal.nanorc
|
@ -13,32 +13,40 @@ syntax tal ".*\.tal"
|
|||
comment "( | )"
|
||||
|
||||
# raw values
|
||||
color pink "\"[^ ]+"
|
||||
color pink "'[^ ]"
|
||||
color pink "\<[0-9a-f]{2}{1,2}\>"
|
||||
color green "\B\"\S+"
|
||||
color green "\<[0-9a-f]{2}{1,2}\>"
|
||||
color green "\<_\S+"
|
||||
color green "\B-\S+"
|
||||
color green "\B=\S+"
|
||||
|
||||
# literals
|
||||
color bold,green "#[0-9a-f]{2}{1,2}\>"
|
||||
color bold,green "\B#[0-9a-f]{2}{1,2}\>"
|
||||
|
||||
# absolute addresses
|
||||
color bold,yellow "(;&?|\.)\S+"
|
||||
color bold,orange ",&?\S+"
|
||||
color bold,orange "/\S+"
|
||||
# addresses (absolute, relative, zero-page)
|
||||
color yellow "\B;\S+"
|
||||
color yellow "\B,\S+"
|
||||
color yellow "\B\.\S+"
|
||||
|
||||
# relative pads
|
||||
color yellow "\$[0-9a-f]{1,4}\>"
|
||||
color yellow "\B\$[0-9a-f]{1,4}\>\>"
|
||||
|
||||
# instructions
|
||||
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?\>"
|
||||
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]*\>"
|
||||
|
||||
# label definitions
|
||||
color bold,blue "(^|\s)(@|&)\S+"
|
||||
|
||||
# macros
|
||||
color bold,magenta "%\S+"
|
||||
color bold,magenta "\B%\S+"
|
||||
|
||||
# absolute pads
|
||||
color yellow "\|[0-9a-f]{2}{1,2}\>"
|
||||
color yellow "\B\|[0-9a-f]{1,4}\>"
|
||||
|
||||
# immediate syntax
|
||||
color bold,yellow "\?\S+"
|
||||
color bold,yellow "!\S+"
|
||||
color bold,yellow "\B\{\B"
|
||||
color bold,yellow "\B\}\B"
|
||||
|
||||
# comments
|
||||
color red start="\(\s" end="\s\)"
|
||||
color red start="\B\(\s" end="\s\)\B"
|
||||
|
|
515
tar.tal
515
tar.tal
|
@ -2,165 +2,291 @@
|
|||
( )
|
||||
( by d_m )
|
||||
( )
|
||||
( currently only supports listing the contents of tar files )
|
||||
( see https://en.wikipedia.org/wiki/Tar_(computing)#UStar_format )
|
||||
( )
|
||||
( 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 the tar file )
|
||||
( File2 is used to write files and directories )
|
||||
( File1 is used to read/write the tar file )
|
||||
( File2 is used to read/write files and directories )
|
||||
|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 ]
|
||||
|
||||
|0100
|
||||
;arg-callback ;on-stdin arg/init BRK
|
||||
|
||||
@exit ( code^ -> BRK )
|
||||
#80 ORA #0f DEO BRK
|
||||
|
||||
@arg-callback ( -> )
|
||||
;arg/count LDA
|
||||
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
|
||||
|
||||
( exit abnormally )
|
||||
@panic ( -> $exit )
|
||||
#010e DEO #010f DEO BRK
|
||||
|
||||
@print ( s* -> )
|
||||
&loop LDAk #00 EQU ,&eof JCN
|
||||
LDAk #18 DEO INC2 ,&loop JMP
|
||||
&eof POP2 JMP2r
|
||||
( 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 )
|
||||
#80 ORA #0f DEO BRK
|
||||
|
||||
( ignore stdin once we've processed the args )
|
||||
@on-stdin ( -> BRK )
|
||||
BRK
|
||||
|
||||
( print a null-terminated string )
|
||||
@print ( s* -> )
|
||||
&loop LDAk ?{ POP2 JMP2r }
|
||||
LDAk #18 DEO INC2 !&loop
|
||||
|
||||
( 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^ )
|
||||
( assume .File1/name was already written )
|
||||
#0200 .File1/len DEO2
|
||||
;header .File1/r DEO2
|
||||
( TODO validate checksum )
|
||||
.File1/ok DEI2 #0200 EQU2 JMP2r
|
||||
|
||||
@list ( -> )
|
||||
read-header ?&ok JMP2r &ok
|
||||
( list all the entries in the tar archive )
|
||||
@list-entries ( -> )
|
||||
read-header ?{ JMP2r }
|
||||
;header/filename LDA ?&non-null
|
||||
#800f DEO BRK
|
||||
&non-null
|
||||
;header/type LDA ( type^ )
|
||||
DUP #00 EQU ?list-file ( )
|
||||
DUP LIT "0 EQU ?list-file ( )
|
||||
DUP LIT "5 EQU ?list-dir ( )
|
||||
!list-unsupported ( )
|
||||
DUP #00 EQU ?list-file-v ( type^ )
|
||||
DUP LIT "0 EQU ?list-file-v ( type^ )
|
||||
DUP LIT "5 EQU ?list-dir-v ( type^ )
|
||||
DUP LIT "7 EQU ?list-file-v ( type^ )
|
||||
!list-unsupported-v
|
||||
( !fail-unsupported ) ( )
|
||||
|
||||
( non-verbose file entry listing )
|
||||
@list-file ( 00^ -> )
|
||||
POP
|
||||
LIT "f #18 DEO #2018 DEO
|
||||
;header/filename print #0a18 DEO
|
||||
;header/size load-octal11
|
||||
round-up-to-512 skip !list
|
||||
;header/filename #0064 lprint #0a18 DEO
|
||||
;header/size load-octal11 round-up-to-512 skip !list-entries
|
||||
|
||||
( non-verbose directory entry listing )
|
||||
@list-dir ( 00^ -> )
|
||||
POP
|
||||
LIT "d #18 DEO #2018 DEO
|
||||
;header/filename print #0a18 DEO
|
||||
!list
|
||||
;header/filename #0064 lprint #0a18 DEO
|
||||
!list-entries
|
||||
|
||||
@list-unsupported ( type^ -> )
|
||||
;unsupported print emit/byte #0a18 DEO !panic
|
||||
!list
|
||||
( verbose file entry listing )
|
||||
@list-unsupported-v ( type^ -> )
|
||||
( 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
|
||||
|
||||
( 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
|
||||
( dump-header )
|
||||
|
||||
@write-file-header ( filename* size* -> )
|
||||
SWP2 ;header/filename copy JMP2r
|
||||
write-size-2
|
||||
( TODO: checksum )
|
||||
LIT "0 ;header/type STA
|
||||
#00 ;header/linkname STA
|
||||
JMP2r
|
||||
;header/size .File2/name DEO2
|
||||
;header/size load-octal11 STH2k skip
|
||||
STH2r remainder-512 skip-lo !list-entries
|
||||
|
||||
@write-file-body ( size* data* -> )
|
||||
SWP2 .File1/len DEO2 .File1/w DEO2 JMP2r
|
||||
( verbose file entry listing )
|
||||
@list-file-v ( type^ -> )
|
||||
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
|
||||
|
||||
@mod ( x* y* -> x%y* )
|
||||
DIV2k MUL2 SUB2 JMP2r
|
||||
( verbose directory entry listing )
|
||||
@list-dir-v ( 00^ -> )
|
||||
POP
|
||||
LIT "d #18 DEO #2018 DEO
|
||||
;header/size load-octal11 dump-longer #2018 DEO
|
||||
;header/filename #0064 lprint #0a18 DEO
|
||||
!list-entries
|
||||
|
||||
@write-size-2 ( size* -> )
|
||||
;header/size STH2 ( size* [start*] )
|
||||
LIT2r 000a ADD2r ( size* [start* last*] )
|
||||
&loop ( size* [start* pos*] )
|
||||
LTH2kr STHr ?&done ( size* [start* pos*] )
|
||||
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 ( )
|
||||
( handle unsupported directory entry listing )
|
||||
@fail-unsupported ( type^ -> )
|
||||
;unsupported print DUP emit/byte #2018 DEO
|
||||
LIT2 "[ 18 DEO #18 DEO LIT2 "] 18 DEO
|
||||
#0a18 DEO
|
||||
dump-header !panic
|
||||
|
||||
@copy ( src* dst* -> )
|
||||
STH2
|
||||
&loop
|
||||
LDAk DUP STH2kr STA2 ?&ok
|
||||
POP2 POP2r JMP2r
|
||||
&ok INC2 INC2r !&loop
|
||||
( expand a .tar archive in the current working directory )
|
||||
@expand-entries ( -> )
|
||||
read-header ?{ JMP2r }
|
||||
;header/filename LDA ?&non-null
|
||||
#800f DEO BRK
|
||||
&non-null
|
||||
;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 ) ( )
|
||||
|
||||
@read-error "error 20 "reading 20 "data 0a 00
|
||||
( remove leading / of an absolute path )
|
||||
@sanitize-path ( s* -> s1* )
|
||||
LDAk LIT "/ NEQ JMP INC2 JMP2r
|
||||
|
||||
( skips n bytes, specified as a 5-byte integer )
|
||||
@remainder-512 ( n* -> extra* )
|
||||
#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-lo ( carry^ hi* )
|
||||
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-buf ;write-lo/writer STA2
|
||||
write-lo write-hi ?write-4g JMP2r
|
||||
|
||||
@skip-lo ( lo* -> )
|
||||
DUP2 #8000 GTH2 ?&double !skip-buf
|
||||
&double #8000 SUB2 skip-buf !skip-32k
|
||||
;skip-buf ;write-lo/writer STA2 !write-lo
|
||||
|
||||
( skips lo bytes )
|
||||
@skip-buf ( lo* -> )
|
||||
ORAk ?&non-zero POP2 JMP2r &non-zero
|
||||
( skips up to 32768 bytes of; limited by the size of buf )
|
||||
@skip-buf ( n* -> )
|
||||
ORAk ?{ POP2 JMP2r }
|
||||
DUP2 .File1/len DEO2
|
||||
;buffer .File1/r DEO2
|
||||
.File1/ok DEI2 EQU2 ?&ok
|
||||
;read-error print !panic
|
||||
&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^ )
|
||||
LIT "0 DUP2 LTH ?&zero SUB JMP2r &zero POP2 #00 JMP2r
|
||||
LIT "0 SUB DUP #08 LTH ?{ POP #00 } JMP2r
|
||||
|
||||
( 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* )
|
||||
INC2k load-octal10 ( addr* hi* lo* )
|
||||
INC2k load-octal10 ( addr* hi* lo* ; load addr+1 )
|
||||
STH2 STH2 ( addr* [lo* hi*] )
|
||||
LDA ( LIT "0 SUB ) octal-digit STH2r STH ( octal^ a^ [lo* b^] )
|
||||
LDA octal-digit STH2r STH ( octal^ a^ [lo* b^] )
|
||||
#20 SFT #02 SFT2 STHr STH2r ( carry^ hi* lo* )
|
||||
JMP2r ( carry^ hi* lo* )
|
||||
|
||||
( 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* )
|
||||
#0005 OVR2 ADD2 ( addr* addr+5* )
|
||||
load-octal5 STH2 ( addr* [cd*] )
|
||||
|
@ -170,6 +296,10 @@
|
|||
JMP2r ( hi* lo* )
|
||||
|
||||
( 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* )
|
||||
#1000 LIT2r 0000 ( addr* place* [sum*] )
|
||||
&loop ( pos* place* [sum*] )
|
||||
|
@ -182,54 +312,155 @@
|
|||
|
||||
( emit 1, 2, 4, or 5 bytes as a decimal number )
|
||||
@emit
|
||||
&1+long STH2 STH2 ,&byte JSR STH2r STH2r
|
||||
&long SWP2 ,&short JSR
|
||||
&short SWP ,&byte JSR
|
||||
&byte DUP #04 SFT ,&char JSR
|
||||
&1+long STH2 STH2 /byte STH2r STH2r
|
||||
&long SWP2 /short
|
||||
&short SWP /byte
|
||||
&byte DUP #04 SFT /char
|
||||
&char #0f AND DUP #09 GTH #27 MUL ADD #30 ADD #18 DEO
|
||||
JMP2r
|
||||
|
||||
( round a given 5-byte size up to multiples of 512 )
|
||||
@round-up-to-512 ( carry^ hi* lo* -> )
|
||||
DUP2 #fe00 GTH2 ?&round-hi
|
||||
#0200 OVR2 #01ff AND2 SUB2 ADD2 JMP2r
|
||||
&round-hi
|
||||
POP2 DUP2 #ffff EQU2 ?&round-carry INC2 #0000 JMP2r
|
||||
&round-carry
|
||||
POP2 DUP #ff EQU ?&overflow INC #0000 #0000 JMP2r
|
||||
&overflow #0000 DIV
|
||||
@round-up-to-512 ( carry^ hi* lo* -> chl^** )
|
||||
DUP2 #01ff AND2 ORA ?{ JMP2r }
|
||||
DUP2 #fe00 GTH2 ?{ #0200 OVR2 #01ff AND2 SUB2 ADD2 JMP2r }
|
||||
POP2 DUP2 #ffff EQU2 ?{ INC2 #0000 JMP2r }
|
||||
POP2 INC #0000 #0000 JMP2r
|
||||
|
||||
( header/size is 11 octal digits; 12th digit is NUL )
|
||||
( octal 77777777777 = #01 #ffff #ffff )
|
||||
( octal 37777777777 = #ffff #ffff )
|
||||
( octal 00000177777 = #ffff )
|
||||
( octal 00000000377 = #ff )
|
||||
( octal 00000000000 = #00 )
|
||||
( since 4-byte integers are called `long` values, )
|
||||
( i'm calling a 5-byte integer a `longer` value. )
|
||||
|
||||
( header/type -- only 0 and 5 are supported )
|
||||
( '0' normal file; also could be NUL )
|
||||
( '1' hard link )
|
||||
( '2' symlink )
|
||||
( '3' character device )
|
||||
( '4' block device )
|
||||
( '5' directory )
|
||||
( '6' fifo )
|
||||
( '7' contiguous file )
|
||||
@dump-longer ( carry^ long** -- )
|
||||
STH2 STH2 dump-byte STH2r STH2r ( >> )
|
||||
@dump-long ( long** -- )
|
||||
SWP2 dump-short ( >> )
|
||||
@dump-short ( short* -- )
|
||||
SWP dump-byte ( >> )
|
||||
@dump-byte ( byte^ -- )
|
||||
DUP #04 SFT /hex #0f AND ( >> )
|
||||
&hex #30 ADD DUP #39 GTH #27 MUL ADD #18 DEO
|
||||
JMP2r
|
||||
|
||||
( header is always exactly 512 bytes )
|
||||
@header
|
||||
&filename $64
|
||||
&mode $8 ( octal )
|
||||
&owner $8 ( octal )
|
||||
&group $8 ( octal )
|
||||
&size $c ( octal )
|
||||
&mtime $c ( octal )
|
||||
&checksum $8
|
||||
&type $1 ( item type )
|
||||
&linkname $64
|
||||
@dump-mem ( start* size* -> )
|
||||
OVR2 ADD2 SWP2 ( lim* start* )
|
||||
LDAk dump-byte INC2 ( lim* start+1* )
|
||||
&loop GTH2k ?&ok POP2 POP2 #0a18 DEO JMP2r ( lim^ pos^ )
|
||||
&ok #2018 DEO LDAk dump-byte INC2 !&loop ( lim^ pos+1^ )
|
||||
|
||||
@dump-mem0 ( start* size* -> )
|
||||
#0001 SUB2 OVR2 ADD2 SWP2
|
||||
&loop GTH2k ?{ NIP2 LDA #18 DEO #2018 DEO JMP2r }
|
||||
LDAk #30 GTH ?{ #2018 DEO INC2 !&loop }
|
||||
LDAk #18 DEO INC2 ( >> )
|
||||
&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 )
|
||||
~arg.tal
|
||||
|
||||
( buffer for reading up to 32k bytes of data )
|
||||
( HEADER DETAILS )
|
||||
( )
|
||||
( 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
|
||||
|
|
148
term.tal
148
term.tal
|
@ -76,13 +76,32 @@
|
|||
( ESC [ ? 1060 l -> unset legacy keyboard emulation )
|
||||
( ESC [ ? 1061 h -> set VT220 keyboard emulation )
|
||||
|
||||
|00 @System [ &vect $2 &expansion $2 &title $2 &metadata $2 &r $2 &g $2 &b $2 ]
|
||||
|10 @Console [ &vect $2 &r $1 &exec $2 &mode $1 &dead $1 &exit $1 &w $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 ]
|
||||
|00 @System [
|
||||
&vect $2 &expansion $2 &title $2 &metadata $2
|
||||
&r $2 &g $2 &b $2 ]
|
||||
|
||||
|10 @Console [
|
||||
&vect $2 &stdin $1 &pad1 $4 &type $1
|
||||
&stdout $1 &stderr $1 &proc-put $1 &pad2 $1 ¶m $2 &opts $1 &host-put $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 &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
|
||||
@tint $1 ( draw mode. 01=regular, 04=inverted )
|
||||
|
@ -124,13 +143,17 @@
|
|||
@visual-bell $1 ( flash visual bell? otherwise do nothing )
|
||||
@border-pad $2 ( use border? should be 0000 or 0010 )
|
||||
|
||||
( subprocess )
|
||||
@put-port $1
|
||||
@get-type $1
|
||||
|
||||
|0100
|
||||
( metadata )
|
||||
;meta .System/metadata DEO2
|
||||
;meta/name .System/title DEO2
|
||||
|
||||
( user configuration defaults )
|
||||
#01 .debug STZ
|
||||
#00 .debug STZ
|
||||
#01 .show-banner STZ
|
||||
( #0010 .border-pad STZ2 )
|
||||
#0000 .border-pad STZ2
|
||||
|
@ -156,23 +179,54 @@
|
|||
;on-mouse .Mouse/vect DEO2 ( set up mouse callback )
|
||||
;on-read .Console/vect DEO2 ( set up stdin callback )
|
||||
|
||||
setup-subprocess ( set up experimental subprocess support )
|
||||
setup-shell ( set up experimental subprocess support )
|
||||
reset-terminal ( initialize terminal state and settings )
|
||||
setup-debugging ( set up debugging if requested )
|
||||
draw-banner ( draw banner if requested )
|
||||
|
||||
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 )
|
||||
( on other emulators they should be no-ops )
|
||||
@setup-subprocess ( -> )
|
||||
;shell .Console/exec DEO2 ( set up bash subprocess )
|
||||
#80 .Console/mode DEO ( start bash subprocess )
|
||||
@setup-shell ( -> )
|
||||
has-subprocess ?{
|
||||
( without subprocess, just use stdin/stdout )
|
||||
.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
|
||||
|
||||
@setup-debugging ( -> )
|
||||
.debug LDZ ?&continue JMP2r &continue
|
||||
#99 #010e DEO ( put 99 in wst so #010e DEO reliably logs )
|
||||
;debug-log .File1/name DEO2
|
||||
#01 .File1/append DEO
|
||||
JMP2r
|
||||
|
@ -224,7 +278,7 @@
|
|||
.rows LDZ2 #000c MUL2 ADD2 .Screen/h DEO2
|
||||
JMP2r
|
||||
|
||||
@shell "bash 00 "-i 00 00
|
||||
@shell "bash 20 "-l 20 "-i 00
|
||||
|
||||
@load-theme ( -> )
|
||||
;&path .File1/name DEO2
|
||||
|
@ -381,18 +435,18 @@
|
|||
|
||||
( send ESC [ $c )
|
||||
@arrow ( c^ -> )
|
||||
.Console/w STH
|
||||
( .Console/proc-put ) .put-port LDZ STH
|
||||
#1b STHkr DEO LIT "[ STHkr DEO STHr DEO
|
||||
JMP2r
|
||||
|
||||
@paste-from-buf ( size* -> )
|
||||
;paste-buf SWP2 OVR2 ADD2 SWP2 ( limit* start* )
|
||||
&loop ( limit* pos* )
|
||||
LDAk .Console/w DEO INC2 ( limit* pos+1* )
|
||||
LDAk ( .Console/proc-put ) .put-port LDZ DEO INC2 ( limit* pos+1* )
|
||||
GTH2k ?&loop POP2 POP2 JMP2r
|
||||
|
||||
@bracket-paste ( c^ -> )
|
||||
.Console/w STH
|
||||
( .Console/proc-put ) .put-port LDZ STH
|
||||
#1b STHkr DEO
|
||||
LIT "[ STHkr DEO
|
||||
LIT "2 STHkr DEO
|
||||
|
@ -607,16 +661,16 @@
|
|||
.Controller/key DEI
|
||||
DUP #08 NEQ ?&done
|
||||
POP #7f ( send DEL instead of BS )
|
||||
&done .Console/w DEO BRK
|
||||
&done ( .Console/proc-put ) .put-port LDZ DEO BRK
|
||||
|
||||
@ctrl ( -> is-down? ) .Controller/button DEI #01 AND JMP2r
|
||||
@alt ( -> is-down? ) .Controller/button DEI #02 AND JMP2r
|
||||
|
||||
( alt-XYZ emits ESC and then emits XYZ )
|
||||
@on-alt-key ( -> BRK )
|
||||
#1b .Console/w DEO
|
||||
#1b ( .Console/proc-put ) .put-port LDZ DEO
|
||||
ctrl ?on-ctrl-key
|
||||
.Controller/key DEI .Console/w DEO BRK
|
||||
.Controller/key DEI ( .Console/proc-put ) .put-port LDZ DEO BRK
|
||||
|
||||
( control seqs: )
|
||||
( ctrl-sp -> 00 )
|
||||
|
@ -651,10 +705,15 @@
|
|||
&rs #1e !&done
|
||||
&us #1f !&done
|
||||
&c1 LIT "@ SUB
|
||||
&done .Console/w DEO BRK
|
||||
&done ( .Console/proc-put ) .put-port LDZ DEO BRK
|
||||
|
||||
@read-or-brk ( -> BRK? )
|
||||
.Console/type DEI .get-type LDZ EQU ?{ BRK } JMP2r
|
||||
|
||||
@on-read-priv ( -> BRK )
|
||||
.Console/r DEI
|
||||
read-or-brk
|
||||
( .Console/type DEI #21 EQU ?{ BRK } )
|
||||
.Console/stdin DEI
|
||||
DUP LIT "; EQU ?next-arg
|
||||
DUP LIT "0 LTH ?end-arg-priv
|
||||
DUP LIT "9 GTH ?end-arg-priv
|
||||
|
@ -664,7 +723,9 @@
|
|||
POP ;on-read-priv .Console/vect DEO2 BRK
|
||||
|
||||
@on-read-csi ( -> BRK )
|
||||
.Console/r DEI
|
||||
read-or-brk
|
||||
( .Console/type DEI #21 EQU ?{ BRK } )
|
||||
.Console/stdin DEI
|
||||
DUP LIT "? EQU ?start-priv
|
||||
DUP LIT "; EQU ?next-arg
|
||||
DUP LIT "0 LTH ?end-arg
|
||||
|
@ -672,7 +733,9 @@
|
|||
!add-to-arg
|
||||
|
||||
@on-read-osc ( -> BRK )
|
||||
.Console/r DEI
|
||||
read-or-brk
|
||||
( .Console/type DEI #21 EQU ?{ BRK } )
|
||||
.Console/stdin DEI
|
||||
DUP #07 ( bell ) EQU ?&end-osc
|
||||
#9c ( esc-\ ) EQU ?&end-osc BRK
|
||||
&end-osc ;on-read .Console/vect DEO2 BRK
|
||||
|
@ -873,12 +936,12 @@
|
|||
|
||||
@dsr ( n* -> )
|
||||
#0006 NEQ2 ?&done
|
||||
#1b .Console/w DEO
|
||||
LIT "[ .Console/w DEO
|
||||
#1b ( .Console/proc-put ) .put-port LDZ DEO
|
||||
LIT "[ ( .Console/proc-put ) .put-port LDZ DEO
|
||||
.cur-y LDZ2 INC2 emit-dec2
|
||||
LIT "; .Console/w DEO
|
||||
LIT "; ( .Console/proc-put ) .put-port LDZ DEO
|
||||
.cur-x LDZ2 INC2 emit-dec2
|
||||
LIT "R .Console/w DEO
|
||||
LIT "R ( .Console/proc-put ) .put-port LDZ DEO
|
||||
&done BRK
|
||||
|
||||
@cnl ( n* -> ) clear-cursor #0000 .cur-x STZ2 !down-n
|
||||
|
@ -948,7 +1011,9 @@
|
|||
JMP2r
|
||||
|
||||
@on-read-esc ( -> BRK )
|
||||
.Console/r DEI
|
||||
read-or-brk
|
||||
( .Console/type DEI #21 EQU ?{ BRK } )
|
||||
.Console/stdin DEI
|
||||
DUP debug-esc
|
||||
DUP LIT "D EQU ?exec-ind
|
||||
DUP LIT "E EQU ?exec-nel
|
||||
|
@ -995,7 +1060,9 @@
|
|||
POP reset-args ;on-read-osc .Console/vect DEO2 BRK
|
||||
|
||||
@on-read ( -> BRK )
|
||||
.Console/r DEI read BRK
|
||||
read-or-brk
|
||||
( .Console/type DEI #21 EQU ?{ BRK } )
|
||||
.Console/stdin DEI read BRK
|
||||
|
||||
@read ( c^ -> )
|
||||
DUP debug-read
|
||||
|
@ -1223,7 +1290,7 @@
|
|||
JMP2r ( )
|
||||
|
||||
@highlight-cell ( cell* -> )
|
||||
NIP LITr 47 ( c^ [tint^] )
|
||||
NIP LITr 07 ( c^ [tint^] )
|
||||
#00 SWP #40 SFT2 ;cp437 ADD2 ( addr* [tint^] )
|
||||
.Screen/addr DEO2k ( addr* s^ [tint^] )
|
||||
STHkr .Screen/sprite DEO ( addr* s^ [tint^] )
|
||||
|
@ -1256,14 +1323,21 @@
|
|||
|
||||
( emit a signed short as a decimal )
|
||||
@emit-sdec2 ( n* -> )
|
||||
DUP2k #1f SFT2 EQUk ?&s LIT2 "- 18 DEO
|
||||
DUP2k #1f SFT2 EQUk ?&s LIT "- ( .Console/proc-put ) .put-port LDZ DEO
|
||||
&s MUL2 SUB2 ( fall-through to emit-dec2 )
|
||||
|
||||
( emit an unsigned short as a decimal )
|
||||
@emit-dec2 ( n* -> )
|
||||
LITr ff00 &read #000a DIV2k STH2k MUL2 SUB2 STH2r INCr ORAk ?&read
|
||||
POP2 &write NIP #30 ADD #18 DEO OVRr ADDr STHkr ?&write
|
||||
POP2r JMP2r
|
||||
LIT2r ff00 ( n* [ff^ 0^] )
|
||||
&read ( ... x* )
|
||||
#000a DIV2k STH2k ( x* 10* x/10* [ff^ i^ x/10*] )
|
||||
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
|
||||
@scratch $40 &pos $2
|
||||
|
@ -1300,9 +1374,9 @@
|
|||
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 "d "e "t "e "r "m 20 20 "v "1 "0 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 20 20 "b "y 20 "d "_ "m 20 20 20 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 "1 "5 20 "d "e "c 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 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
|
||||
|
|
|
@ -4,15 +4,16 @@ from math import ceil, copysign, cos, floor, log, sin, sqrt, tan
|
|||
from os import environ
|
||||
from random import randint
|
||||
from subprocess import Popen, PIPE, run
|
||||
from sys import argv, exit
|
||||
|
||||
def tosigned(x):
|
||||
return x if x < 32768 else x - 65536
|
||||
|
||||
u8 = {'sz': 1 << 8, 'fmt': b'%02x'}
|
||||
u16 = {'sz': 1 << 16, 'fmt': b'%04x'}
|
||||
z16 = {'sz': 1 << 16, 'fmt': b'%04x'}
|
||||
p16 = {'sz': 1 << 16, 'fmt': b'%04x'}
|
||||
t16 = {'sz': 1 << 16, 'fmt': b'%04x'}
|
||||
x16 = {'sz': 1 << 16, 'fmt': b'%04x'}
|
||||
z16 = {'sz': 1 << 16, 'fmt': b'%04x'} # non-zero
|
||||
p16 = {'sz': 1 << 16, 'fmt': b'%04x'} # positive
|
||||
t16 = {'sz': 1 << 16, 'fmt': b'%04x'} # tangent, must not be pi/2
|
||||
|
||||
def eq(got, expected):
|
||||
return got == expected
|
||||
|
@ -25,7 +26,7 @@ def releq(got0, expected0):
|
|||
else:
|
||||
error = abs(got - expected) / (abs(expected) + 0.001)
|
||||
return error < 0.01
|
||||
def abseq(got0, expected0):
|
||||
def sineq(got0, expected0):
|
||||
got, expected = tosigned(got0), tosigned(expected0)
|
||||
if (expected - 10) <= got and got <= (expected + 10):
|
||||
return True
|
||||
|
@ -45,6 +46,7 @@ def testcase(p, sym, args, out, f, eq):
|
|||
val = randint(0, g['sz'] - 1)
|
||||
while ((val == 0 and (g is z16 or 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)))):
|
||||
val = randint(0, g['sz'] - 1)
|
||||
vals.append((name, g, val))
|
||||
|
@ -79,6 +81,24 @@ def test(p, trials, sym, args, out, f, eq=eq):
|
|||
else:
|
||||
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():
|
||||
return Popen(['uxncli', 'run.rom'], stdin=PIPE, stdout=PIPE)
|
||||
|
||||
|
@ -87,11 +107,17 @@ def x16_add(x, y):
|
|||
def x16_sub(x, y):
|
||||
return (x - y) % 65536
|
||||
def x16_mul(x, y):
|
||||
return ((x * y) // 256) % 65536
|
||||
return tofix(fromfix(x) * fromfix(y))
|
||||
def x16_div(x, y):
|
||||
return ((x * 256) // y) % 65536
|
||||
return tofix(fromfix(x) / fromfix(y))
|
||||
def x16_quot(x, y):
|
||||
return x16_div(x, y) & 0xff00
|
||||
n = x16_div(x, y)
|
||||
if n < 0x7fff:
|
||||
return n & 0xff00
|
||||
elif n > 0x8001:
|
||||
return (n + 255) & 0xff00
|
||||
else:
|
||||
return n
|
||||
def x16_rem(x, y):
|
||||
return x % y
|
||||
def x16_is_whole(x):
|
||||
|
@ -147,33 +173,38 @@ def x16_trunc8(x):
|
|||
return floor(x / 256)
|
||||
|
||||
def main():
|
||||
trials = 1000
|
||||
run(['uxnasm', 'test-fix16.tal', 'run.rom'])
|
||||
trials = int(argv[1]) if argv[1:] else 100
|
||||
e = 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()
|
||||
test(p, trials, b'+', [('x', u16), ('y', u16)], u16, x16_add)
|
||||
test(p, trials, b'-', [('x', u16), ('y', u16)], u16, x16_sub)
|
||||
test(p, trials, b'*', [('x', u16), ('y', u16)], u16, x16_mul)
|
||||
test(p, trials, b'/', [('x', u16), ('y', z16)], u16, x16_div, eq=releq)
|
||||
test(p, trials, b'\\', [('x', u16), ('y', z16)], u16, x16_quot)
|
||||
test(p, trials, b'%', [('x', u16), ('y', z16)], u16, x16_rem)
|
||||
test(p, trials, b'w', [('x', u16)], u8, x16_is_whole, eq=booleq)
|
||||
test(p, trials, b'N', [('x', u16)], u16, x16_negate)
|
||||
test(p, trials, b'=', [('x', u16), ('y', u16)], u8, x16_eq)
|
||||
test(p, trials, b'!', [('x', u16), ('y', u16)], u8, x16_ne)
|
||||
test(p, trials, b'<', [('x', u16), ('y', u16)], u8, x16_lt)
|
||||
test(p, trials, b'>', [('x', u16), ('y', u16)], u8, x16_gt)
|
||||
test(p, trials, b'{', [('x', u16), ('y', u16)], u8, x16_lteq)
|
||||
test(p, trials, b'}', [('x', u16), ('y', u16)], u8, x16_gteq)
|
||||
test(p, trials, b'r', [('x', p16)], u16, x16_sqrt, eq=releq)
|
||||
test(p, trials, b's', [('x', p16)], u16, x16_sin, eq=abseq)
|
||||
test(p, trials, b'c', [('x', p16)], u16, x16_cos, eq=abseq)
|
||||
test(p, trials, b't', [('x', t16)], u16, x16_tan, eq=taneq)
|
||||
test(p, trials, b'l', [('x', p16)], u16, x16_log, eq=releq)
|
||||
test(p, trials, b'F', [('x', u16)], u16, x16_floor)
|
||||
test(p, trials, b'C', [('x', u16)], u16, x16_ceil)
|
||||
test(p, trials, b'R', [('x', u16)], u16, x16_round)
|
||||
test(p, trials, b'8', [('x', u16)], u16, x16_trunc8)
|
||||
test(p, trials, b'T', [('x', u16)], u16, x16_trunc16)
|
||||
test(p, trials, b'+', [('x', x16), ('y', x16)], x16, x16_add)
|
||||
test(p, trials, b'-', [('x', x16), ('y', x16)], x16, x16_sub)
|
||||
test(p, trials, b'*', [('x', x16), ('y', x16)], x16, x16_mul)
|
||||
test(p, trials, b'/', [('x', x16), ('y', z16)], x16, x16_div)
|
||||
test(p, trials, b'\\', [('x', x16), ('y', z16)], x16, x16_quot)
|
||||
test(p, trials, b'%', [('x', x16), ('y', z16)], x16, x16_rem)
|
||||
test(p, trials, b'w', [('x', x16)], u8, x16_is_whole, eq=booleq)
|
||||
test(p, trials, b'N', [('x', x16)], x16, x16_negate)
|
||||
test(p, trials, b'=', [('x', x16), ('y', x16)], u8, x16_eq)
|
||||
test(p, trials, b'!', [('x', x16), ('y', x16)], u8, x16_ne)
|
||||
test(p, trials, b'<', [('x', x16), ('y', x16)], u8, x16_lt)
|
||||
test(p, trials, b'>', [('x', x16), ('y', x16)], u8, x16_gt)
|
||||
test(p, trials, b'{', [('x', x16), ('y', x16)], u8, x16_lteq)
|
||||
test(p, trials, b'}', [('x', x16), ('y', x16)], u8, x16_gteq)
|
||||
test(p, trials, b'F', [('x', x16)], x16, x16_floor)
|
||||
test(p, trials, b'C', [('x', x16)], x16, x16_ceil)
|
||||
test(p, trials, b'R', [('x', x16)], x16, x16_round)
|
||||
test(p, trials, b'8', [('x', x16)], x16, x16_trunc8)
|
||||
test(p, trials, b'T', [('x', x16)], x16, x16_trunc16)
|
||||
# the next five are known to be somewhat inaccurate and use
|
||||
# a "relaxed" equality predicate for testing purposes.
|
||||
test(p, trials, b'r', [('x', p16)], x16, x16_sqrt, eq=releq)
|
||||
test(p, trials, b's', [('x', p16)], x16, x16_sin, eq=sineq)
|
||||
test(p, trials, b'c', [('x', p16)], x16, x16_cos, eq=sineq)
|
||||
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.flush()
|
||||
p.stdin.close()
|
||||
|
|
|
@ -0,0 +1,98 @@
|
|||
( 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
|
|
@ -0,0 +1,108 @@
|
|||
#!/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
1215
uxnbot.lua
File diff suppressed because it is too large
Load Diff
|
@ -0,0 +1,155 @@
|
|||
#!/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()
|
|
@ -0,0 +1,363 @@
|
|||
.\" 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
|
|
@ -0,0 +1,336 @@
|
|||
.\" 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
148
wave.tal
|
@ -37,10 +37,8 @@
|
|||
|
||||
( |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 ]
|
||||
|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 &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 ]
|
||||
|30 @Audio0 [ &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 &dur $2 &pad $1 &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 ]
|
||||
|
||||
|0000
|
||||
|
@ -77,10 +75,10 @@
|
|||
&done
|
||||
LIT2 =reload/resample STA2 ( ; save resample function )
|
||||
LIT2r =reload/sft STAr ( ; save shift size )
|
||||
#2000 .File/len DEO2
|
||||
#2000 ;len0 STA2 #2000 ;buf0 zero-buf-u8
|
||||
#2000 ;len1 STA2 #2000 ;buf1 zero-buf-u8
|
||||
!play0
|
||||
#2274 .File/len DEO2
|
||||
#2274 DUP2 ;a/len STA2 DUP2 ;a/l-buf zero-buf-u8 DUP2 ;a/r-buf zero-buf-u8
|
||||
DUP2 ;b/len STA2 DUP2 ;b/l-buf zero-buf-u8 ;b/r-buf zero-buf-u8
|
||||
!play-a
|
||||
|
||||
@zero-buf-u8 ( len* buf* -> )
|
||||
STH2k ADD2 STH2 SWP2r ( [limit=buf+len* buf*] )
|
||||
|
@ -105,68 +103,96 @@
|
|||
@hdr-eq2 ( offset* v* -> eq^ )
|
||||
STH2 ;header ADD2 LDA2 STH2r EQU2 JMP2r
|
||||
|
||||
@reload ( l-addr* b-addr* -> )
|
||||
.done LDZ ?&skip ( l-addr* b-addr* )
|
||||
SWP2 ( b-addr* l-addr* )
|
||||
;scratch .File/r DEO2 ( b-addr* l-addr* )
|
||||
.File/ok DEI2 ( b-addr* l-addr* read* )
|
||||
DUP2 LIT &sft $1 SFT2 ( b-addr* l-addr* read* read>>sft )
|
||||
ROT2 STA2 ( b-addr* read* ; l-addr<-read>>sft )
|
||||
DUP2 #2000 EQU2 ?&end ( b-addr* read* ; if we read 0x2000 we are not done )
|
||||
#01 .done STZ ( b-addr* read* ; done<-1 )
|
||||
&end ( b-addr* read* )
|
||||
SWP2 STH2 ;scratch ( read* scratch* [b-addr*] )
|
||||
DUP2 ROT2 ADD2 SWP2 ( limit=scratch+read* scratch* [b-addr*] )
|
||||
INC2 ( limit* scratch+1* [b-addr*] )
|
||||
&loop ( limit* pos* [bpos*] )
|
||||
LIT2 &resample $2 JSR2 ( limit* pos+n* sample^ [bpos*] )
|
||||
STH2kr STA ( limit* pos+n* [bpos*] ; bpos<-sample )
|
||||
INC2r GTH2k ?&loop ( limit* pos+n* [bpos+1*] )
|
||||
POP2r ( limit* pos+n* )
|
||||
POP2 POP2 JMP2r
|
||||
&skip ( )
|
||||
#2000 SWP2 zero-buf-u8 ( )
|
||||
#2000 SWP2 STA2 JMP2r ( )
|
||||
@reload ( l-addr* bl-addr* br-addr* -> )
|
||||
SWP2 STH2 STH2 ( l-addr* [bl-addr* br-addr*] )
|
||||
.done LDZ ?&skip ( l-addr* [bl-addr* br-addr*] )
|
||||
;scratch .File/r DEO2 ( l-addr* [bl-addr* br-addr*] )
|
||||
.File/ok DEI2 ( l-addr* read* [bl-addr* br-addr*] )
|
||||
DUP2 LIT &sft $1 SFT2 ( l-addr* read* read>>sft [bl-addr* br-addr*] )
|
||||
ROT2 STA2 ( read* [bl-addr* br-addr*] ; l-addr<-read>>sft )
|
||||
DUP2 #2274 EQU2 ?&end ( read* [bl-addr* br-addr*] ; if we read 0x2274 we are not done )
|
||||
#01 .done STZ ( read* [bl-addr* br-addr*] ; done<-1 )
|
||||
&end ( read* [bl-addr* br-addr*] )
|
||||
;scratch ( read* scratch* [bl-addr* br-addr*] )
|
||||
DUP2 ROT2 ADD2 SWP2 ( limit=scratch+read* scratch* [bl-addr* br-addr*] )
|
||||
INC2 ( limit* scratch+1* [bl-addr* br-addr*] )
|
||||
&loop ( limit* pos* [bl-pos* br-pos*] )
|
||||
LIT2 [ &resample $2 ] JSR2 ( limit* pos+n* l-sample^ r-sample^ [bl-pos* br-pos*] )
|
||||
STH2kr STA INC2 SWP2r ( limit* pos+n* [br-pos+1* bl-pos*] ; br-pos<-sample )
|
||||
STH2kr STA INC2 SWP2r ( limit* pos+n* [bl-pos+1* br-pos+1*] ; bl-pos<-sample )
|
||||
GTH2k ?&loop ( limit* pos+n* [bl-pos+1* br-pos+1*] )
|
||||
POP2r POP2r POP2 POP2 JMP2r ( )
|
||||
&skip ( l-addr* [bl-addr* br-addr*] )
|
||||
#2274 DUP2 STH2r zero-buf-u8 ( l-addr* #2274 [bl-addr*] ; clear br-addr )
|
||||
DUP2 STH2r zero-buf-u8 ( l-addr* #2274 ; clear bl-addr )
|
||||
SWP2 STA2 JMP2r ( ; l-addr<-2274 )
|
||||
|
||||
@mono-u8-to-u8 ( pos* -> pos+1* sample^ )
|
||||
LDAk STH INC2 STHr JMP2r
|
||||
@mono-u8-to-u8 ( pos* -> pos+1* l-sample^ r-sample^ )
|
||||
LDAk STH INC2 ( pos+1* [s^] )
|
||||
STHr DUP JMP2r ( pos+1 l-s^ r-s^ )
|
||||
|
||||
@mono-s16-to-u8 ( pos* -> pos+2* sample^ )
|
||||
LDAk #80 EOR STH INC2 INC2 STHr JMP2r
|
||||
@mono-s16-to-u8 ( pos* -> pos+2* l-sample^ r-sample^ )
|
||||
LDAk #80 ADD STH INC2 INC2 ( pos+2* [s^] )
|
||||
STHr DUP JMP2r ( pos+2* l-s^ r-s^ )
|
||||
|
||||
@stereo-u8-to-u8 ( pos* -> pos+2* sample^ )
|
||||
LDAk #00 SWP STH2 INC2
|
||||
LDAk #00 SWP STH2 INC2
|
||||
ADD2r LITr 01 SFT2r NIPr STHr JMP2r
|
||||
@stereo-u8-to-u8 ( pos* -> pos+2* l-sample^ r-sample^ )
|
||||
INC2k SWP2 LDA STH ( pos+1* [l-s^] )
|
||||
INC2k SWP2 LDA STH ( pos+2* [l-s^ r-s^] )
|
||||
STH2r JMP2r ( pos+2* l-s^ r-s^ )
|
||||
|
||||
@stereo-s16-to-u8 ( pos* -> pos+4* sample^ )
|
||||
LDAk #80 EOR #00 SWP STH2 INC2 INC2
|
||||
LDAk #80 EOR #00 SWP STH2 INC2 INC2
|
||||
ADD2r LITr 01 SFT2r NIPr STHr JMP2r
|
||||
LDAk #80 ADD STH INC2 INC2 ( pos+2* [l-s^] )
|
||||
LDAk #80 ADD STH INC2 INC2 ( pos+4* [l-s^ r-s^] )
|
||||
STH2r JMP2r ( pos+4* l-s^ r-s^ )
|
||||
|
||||
@play0 ( -> ) ;play1 ;len0 ;buf0 !play
|
||||
@play1 ( -> ) ;play0 ;len1 ;buf1 !play
|
||||
@play-a ( -> ) ;play-b ;a !play-base
|
||||
@play-b ( -> ) ;play-a ;b !play-base
|
||||
|
||||
@play ( next* l-addr* b-addr* -> )
|
||||
OVR2 LDA2 ORAk ?&nonzero ( next* l-addr* b-addr* n* )
|
||||
POP2 POP2 POP2 POP2 ( ; clear stack )
|
||||
#010f BRK ( ; exit )
|
||||
&nonzero ( next* l-addr b-addr* n* )
|
||||
OVR2 output ( next* l-addr b-addr* ; play buf1 )
|
||||
reload ( next* ; load more data )
|
||||
.Audio0/vec DEO2 ( ; Audio0/vec<-next )
|
||||
BRK ( )
|
||||
@play-base ( next* base* -> )
|
||||
SWP2 .Audio0/vec DEO2 ( base* ; vec<-next )
|
||||
INC2k INC2 STH2k ( l-addr* lb-addr* [lb-addr*] )
|
||||
#2274 ADD2 STH2 ( l-addr* [lb-addr* rb-addr*] )
|
||||
( LDA2k ORAk ?&non-zero ( l-addr* n* [lb-addr* rb-addr*] )
|
||||
POP2 POP2 POP2r POP2r ( ; clear stack )
|
||||
#010f BRK ( ; exit )
|
||||
&non-zero ( l-addr* n* [lb-addr* rb-addr*] ) )
|
||||
DUP2 STH2kr r-output SWP2r ( l-addr* n* [rb-addr* lb-addr*] ; play rb-addr )
|
||||
STH2kr l-output SWP2r ( l-addr* [lb-addr* rb-addr*] ; play lb-addr )
|
||||
SWP2r STH2r STH2r reload BRK ( ; load more data )
|
||||
|
||||
@output ( len* addr* -> )
|
||||
.Audio0/addr DEO2 ( ; <- write buf addr )
|
||||
.Audio0/len DEO2 ( ; <- write len )
|
||||
#0000 .Audio0/adsr DEO2 ( ; <- write ignore envelope )
|
||||
#ff .Audio0/vol DEO ( ; <- play 100% volume )
|
||||
#bc .Audio0/pitch DEO ( ; <- play standard sample once )
|
||||
@bytes-to-millis ( samples* -> ms* )
|
||||
#01b9 DIV2 #000a MUL2 JMP2r
|
||||
|
||||
@l-output ( len* addr* -> )
|
||||
.Audio0/addr DEO2 ( ; <- write buf addr )
|
||||
DUP2 .Audio0/len DEO2 ( ; <- write length in bytes/samples )
|
||||
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
|
||||
|
||||
@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
|
||||
@header $2c
|
||||
@len0 $2 @buf0 $2000
|
||||
@len1 $2 @buf1 $2000
|
||||
@scratch $2000
|
||||
( @len0 $2 @buf0 $2274
|
||||
@len1 $2 @buf1 $2274 )
|
||||
@scratch $2274
|
||||
|
||||
@a [ &len $2 &l-buf $2274 &r-buf $2274 ]
|
||||
@b [ &len $2 &l-buf $2274 &r-buf $2274 ]
|
||||
|
|
|
@ -0,0 +1,315 @@
|
|||
( 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
|
||||
|
|
@ -0,0 +1,214 @@
|
|||
( 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
|
|
@ -0,0 +1,49 @@
|
|||
( 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^] )
|
Loading…
Reference in New Issue