1 files changed, 38 insertions(+), 33 deletions(-)

M src/main.tal

@@ 29,11 29,10 @@
 %SET-CELL  { ROT ROT GET-INDEX DATA-CELLS ++ STA } ( x y char -- )
 %GET-TYPE  { GET-INDEX DATA-TYPES ++ LDA } ( x y -- type )
 %SET-TYPE  { ROT ROT GET-INDEX DATA-TYPES ++ STA } ( x y type -- )
-%GET-LOCK  { GET-INDEX DATA-LOCKS ++ LDA } ( x y -- type )
-%SET-LOCK  { ROT ROT GET-INDEX DATA-LOCKS ++ STA } ( x y type -- )
-%GET-PORT-LEFT  { DUP2 PORTEL-TYPE SET-TYPE GET-CELL GET-VALUE } ( x y -- char )
-%GET-PORT-RIGHT { DUP2 PORTER-TYPE SET-TYPE DUP2 #01 SET-LOCK GET-CELL GET-VALUE } ( x y -- char )
-%GET-PORT-RIGHT-RAW { DUP2 PORTER-TYPE SET-TYPE DUP2 #01 SET-LOCK GET-CELL } ( x y -- char )
+
+( keep )
+%GET-LOCK  { DATA-LOCKS ++ LDA } ( cell* -- type )
+%SET-LOCK  { DATA-LOCKS ++ STA } ( type cell* -- )
 
 ( devices )
 


@@ 575,15 574,15 @@ RTN
 	DUP CHAR-DOT ! ,&not-dot JCN
 		POP POP2 RTN
 		&not-dot
-	( skip locked )
-	.head/addr LDZ2 DATA-LOCKS ++ LDA #00 = ,&not-locked JCN
-		POP POP2 RTN
-		&not-locked
 	( skip numbers )
 	DUP #30 < ,&no-num JCN
 	DUP #39 > ,&no-num JCN
 		POP POP2 RTN
 		&no-num
+	( skip locked )
+	.head/addr LDZ2 GET-LOCK #00 = ,&not-locked JCN
+		POP POP2 RTN
+		&not-locked
 	( lowercase )
 	DUP #61 < ,&no-lc JCN
 	DUP #7a > ,&no-lc JCN


@@ 593,8 592,8 @@ RTN
 	( uppercase )
 	DUP #41 < ,&no-uc JCN
 	DUP #5a > ,&no-uc JCN
-		STH DUP2 OPERATOR-TYPE SET-TYPE &run STHr
-		DUP GET-VALUE #0a - 2* TOS ;operations ++ LDA2 JMP2
+		STH DUP2 OPERATOR-TYPE SET-TYPE 
+		&run STHr DUP GET-VALUE #0a - 2* TOS ;operations ++ LDA2 JMP2
 		&no-uc
 	( special )
 	CHAR-BANG =~ ;op-bang JCN2


@@ 624,7 623,7 @@ RTN
 
 @set-port-output ( value addr* -- )
 
-	( set lock ) DUP2 #01 ROT ROT DATA-LOCKS ++ STA
+	( set lock ) DUP2 #01 ROT ROT SET-LOCK
 	( set type ) DUP2 OUTPUT-TYPE ROT ROT DATA-TYPES ++ STA
 	( set data ) DATA-CELLS ++ STA
 


@@ 632,7 631,7 @@ RTN
 
 @set-port-raw ( value addr* -- )
 
-	( set lock ) DUP2 #01 ROT ROT DATA-LOCKS ++ STA
+	( set lock ) DUP2 #01 ROT ROT SET-LOCK
 	( set type ) DUP2 #00 ROT ROT DATA-TYPES ++ STA
 	( set data ) DATA-CELLS ++ STA
 


@@ 654,7 653,7 @@ RTN
 
 @get-port-right-raw ( addr* -- value )
 
-	( set lock ) DUP2 #01 ROT ROT DATA-LOCKS ++ STA
+	( set lock ) DUP2 #01 ROT ROT SET-LOCK
 	( set type ) DUP2 PORTER-TYPE ROT ROT DATA-TYPES ++ STA
 	( get data ) DATA-CELLS ++ LDA
 


@@ 662,7 661,7 @@ RTN
 
 @get-port-right-value ( addr* -- value )
 
-	( set lock ) DUP2 #01 ROT ROT DATA-LOCKS ++ STA
+	( set lock ) DUP2 #01 ROT ROT SET-LOCK
 	( set type ) DUP2 PORTER-TYPE ROT ROT DATA-TYPES ++ STA
 	( get data ) DATA-CELLS ++ LDA GET-VALUE
 


@@ 779,7 778,7 @@ RTN
 
 	POP POP2
 	( output ) .head/addr LDZ2 BELOW
-	( set lock ) DUP2 #01 ROT ROT DATA-LOCKS ++ STA
+	( set lock ) DUP2 #01 ROT ROT SET-LOCK
 	( set type ) OUTPUT-TYPE ROT ROT DATA-TYPES ++ STA
 
 RTN


@@ 888,7 887,7 @@ RTN
 	#00
 	&loop
 		#00 OVR STH2kr BELOW ++ STH2
-		( lock ) #01 STH2kr DATA-LOCKS ++ STA
+		( lock ) #01 STH2kr SET-LOCK
 		( type ) LOCKED-TYPE STH2r DATA-TYPES ++ STA
 		INC GTHk ,&loop JCN
 	POP


@@ 955,7 954,7 @@ RTN
 	#00
 	&loop
 		#00 OVR STH2kr INC2 ++ STH2
-		( lock ) #01 STH2kr DATA-LOCKS ++ STA
+		( lock ) #01 STH2kr SET-LOCK
 		( type ) LOCKED-TYPE STH2r DATA-TYPES ++ STA
 		INC GTHk ,&loop JCN
 	POP


@@ 1061,7 1060,7 @@ RTN
 	#00 .grid/width LDZ .head/x LDZ - ++
 	STH2r INC2
 	&loop
-		( set lock ) DUP2 #01 ROT ROT DATA-LOCKS ++ STA
+		( set lock ) DUP2 #01 ROT ROT SET-LOCK
 		( set type ) DUP2 LOCKED-TYPE ROT ROT DATA-TYPES ++ STA
 		( stop at hash ) DUP2 DATA-CELLS ++ LDA CHAR-HASH = ,&end JCN
 		INC2 GTH2k ,&loop JCN


@@ 1084,23 1083,29 @@ RTN
 
 RTN
 
-@op-midi ( x y char -- ) ( TODO )
+@op-midi ( x y char -- )
 
-	POP
-	( get channel ) DUP2 [ SWP INC SWP ] GET-PORT-RIGHT STH
-	( get octave ) DUP2 [ SWP #02 + SWP ] GET-PORT-RIGHT [ #0c * ] STH
-	( get note ) DUP2 [ SWP #03 + SWP ] GET-PORT-RIGHT-RAW
-		( req note ) DUP CHAR-DOT ! ,&is-active JCN [ POP POP2 POP2r RTN ] &is-active GET-NOTE STH
-	( req bang ) ;get-bang JSR2 ,&is-bang JCN [ POP2 POP2r POPr RTN ] &is-bang
-	IO-TYPE SET-TYPE
-	ADDr
-	( note on ) OVRr STHr .Console/write DEO STHkr .Console/write DEO #7f .Console/write DEO
-	( note off ) OVRr STHr .Console/write DEO STHkr .Console/write DEO #00 .Console/write DEO
-	POP2r
+	POP POP2
+	.head/addr LDZ2 STH2k
+	( channel ) INC2 ;get-port-right-value JSR2 [ ,&ch STR ]
+	( octave ) STH2kr #0002 ++ ;get-port-right-value JSR2
+	( note ) STH2r #0003 ++ ;get-port-right-raw JSR2
+	( has note ) DUP CHAR-DOT ! ,&has-note JCN [ POP2 RTN ] &has-note
+	( has bang ) ;get-bang JSR2 ,&is-bang JCN [ POP2 RTN ] &is-bang
+	( get note ) GET-NOTE SWP [ #0c * ] +
+	( get channel ) [ LIT &ch $1 ]
+	( note on )
+	DUP #90 + .Console/write DEO 
+	OVR .Console/write DEO 
+	#7f .Console/write DEO
+	( note off )
+	#80 + .Console/write DEO 
+	OVR .Console/write DEO 
+	#00 .Console/write DEO
 
 RTN
 
-@op-note ( x y char -- ) ( TODO )
+@op-note ( x y char -- )
 
 	POP POP2
 	.head/addr LDZ2 STH2k


@@ 1112,7 1117,7 @@ RTN
 
 RTN
 
-@op-byte ( x y char -- ) ( TODO )
+@op-byte ( x y char -- )
 
 	POP POP2
 	.head/addr LDZ2 STH2k