diff --git a/femto.tal b/femto.tal index cf2ad92..83dfd08 100644 --- a/femto.tal +++ b/femto.tal @@ -72,6 +72,7 @@ &tab-adjust $2 ( how many "extra" spaces; tab-width - 1 ) &insert-tabs $1 ( tab key inserts tabs when true ) &color $2 ( digits of highlight color in reverse order ) + &red $2 ( digits of color for line/EOF markers in reverse order ) ] ( tracks information related to the buffer's view of data ) @@ -143,7 +144,10 @@ #0004 .config/tab-width STZ2 #0003 .config/tab-adjust STZ2 #00 .config/insert-tabs STZ - #3333 .config/color STZ2 +( #3333 .config/color STZ2 ) +( #3133 .config/red STZ2 ) + #3033 .config/color STZ2 + #3033 .config/red STZ2 ;data .buffer/offset STZ2 ( start reading the filename from argv ) @@ -156,10 +160,10 @@ ( ERROR HANDLING ) -( using error! will print the given message before causing ) +( using errorq will print the given message before causing ) ( the interpreter to halt. ) -@error! ( msg* -> ) - emit-! sp ;print JSR2 nl dbg BRK +@errorq ( msg* -> ) + emit-! sp print nl dbg BRK ( open the given file at editor start up ) ( ) @@ -172,10 +176,10 @@ ;data .File/read DEO2 .File/success DEI2 #0000 EQU2 .state/modified STZ - .File/success DEI2 #ce81 LTH2 ,&ok JCN + .File/success DEI2 #ce81 LTH2 ?&ok crlf - ;messages/input-error ;print JSR2 - ;filename ;print JSR2 crlf quit! + ;messages/input-error print + ;filename print crlf quit! ( calculate buffer limit address using start + size ) &ok .File/success DEI2 ;data ADD2 .buffer/limit STZ2 @@ -187,8 +191,8 @@ ( ) ( TODO: consider supporting terminal resizing ) @setup-terminal-size ( -> ) - #03e7 DUP2 ;term-move-cursor JSR2 - ;term-get-cursor-position JSR2 + #03e7 DUP2 term-move-cursor + term-get-cursor-position ;tmp/data .tmp/pos STZ2 ;receive-terminal-size .Console/vector DEO2 JMP2r @@ -200,7 +204,7 @@ .Console/read DEI .state/key STZ .state/key LDZ .tmp/pos LDZ2 STA .tmp/pos LDZ2 INC2 .tmp/pos STZ2 - .state/key LDZ LIT "R EQU ;parse-terminal-size JCN2 + .state/key LDZ LIT "R EQU ?parse-terminal-size BRK ( parse and store terminal size information ) @@ -208,17 +212,17 @@ ( called by ;receive-terminal-size after complete message received ) @parse-terminal-size ( -> ) #0000 ,&acc STR2 - .tmp/data LDZk #1b NEQ ,&parse-error JCN ( i ) INC - LDZk LIT "[ NEQ ,&parse-error JCN ( i ) INC + .tmp/data LDZk #1b NEQ ?&parse-error ( i ) INC + LDZk LIT "[ NEQ ?&parse-error ( i ) INC &loop - LDZk LIT "; EQU ,&parse-col JCN - LIT2r :&loop ,&read JMP + LDZk LIT "; EQU ?&parse-col + LIT2r :&loop !&read &parse-col INC ,&acc LDR2 #0002 SUB2 .term/rows STZ2 #0000 ,&acc STR2 &loop2 - LDZk LIT "R EQU ,&done JCN - LIT2r :&loop2 ,&read JMP + LDZk LIT "R EQU ?&done + LIT2r :&loop2 !&read &read LDZk LIT "0 SUB #00 SWP ,&acc LDR2 #000a MUL2 ADD2 ,&acc STR2 @@ -226,19 +230,19 @@ &done ,&acc LDR2 .term/cols STZ2 POP ;on-key .Console/vector DEO2 - ;draw-all JSR2 + draw-all BRK [ &acc $2 ] &parse-error POP .tmp/data LDZ2 - ;messages/term-size-parse-error ;error! JMP2 + ;messages/term-size-parse-error !errorq @count-c ( c^ -> n* ) #0000 ,&count STR2 STH ;data - &loop LDAk #00 EQU ,&done JCN - LDAk STHkr NEQ ,&next JCN + &loop LDAk #00 EQU ?&done + LDAk STHkr NEQ ?&next ,&count LDR2 INC2 ,&count STR2 - &next INC2 ,&loop JMP + &next INC2 !&loop &done POP2 POPr ,&count LDR2 JMP2r [ &count $2 ] ( save count of number of lines in input file ) @@ -246,8 +250,8 @@ ( this method also detects whether \t characters are used, ) ( and uses this to initialize config/insert-tabs. ) @setup-linecount ( -> ) - #0a ;count-c JSR2 INC2 .buffer/line-count STZ2 - #09 ;count-c JSR2 #0000 GTH2 .config/insert-tabs STZ + #0a count-c INC2 .buffer/line-count STZ2 + #09 count-c #0000 GTH2 .config/insert-tabs STZ JMP2r ( reads filename from the program's argv ) @@ -259,78 +263,78 @@ ( - launching femto without a file name ) ( - closing the given file and opening a new one ) @read-filename ( -> ) - #12 DEI #0a EQU ,&execute JCN ( did we read \n ? ) + #12 DEI #0a EQU ?&execute ( did we read \n ? ) #12 DEI .tmp/pos LDZ2 STA ( no, so save in buffer ) .tmp/pos LDZ2 INC2 .tmp/pos STZ2 ( pos++ ) BRK ( return ) &execute ( we saw a newline, so do something ) #00 .tmp/pos LDZ2 STA ( null terminate str ) - ;filename ;open-file JSR2 ( open file ) - ;setup-linecount JSR2 ( determine # of lines ) - ;setup-terminal-size JSR2 ( detect terminal dimensions ) + ;filename open-file ( open file ) + setup-linecount ( determine # of lines ) + setup-terminal-size ( detect terminal dimensions ) BRK ( jump to beginning of line ) @bol ( -> ) #0000 .cursor/col STZ2 - ;redraw-statusbar-and-cursor JSR2 - ;return JMP2 + redraw-statusbar-and-cursor + !return ( jump to beginning of line ) @eol ( -> ) - ;cur-len JSR2 .cursor/col STZ2 - ;redraw-statusbar-and-cursor JSR2 - ;return JMP2 + cur-len .cursor/col STZ2 + redraw-statusbar-and-cursor + !return @forward ( -> ) - ;go-forward JSR2 ;return JMP2 + go-forward !return ( move forward by one character ) @go-forward ( -> ) - ;cur-pos JSR2 ;last-pos JSR2 GTH2 ( ;return JCN2 ) ,&noop JCN - ;redraw-statusbar-and-cursor JSR2 - ;cur-col JSR2 ;cur-len JSR2 LTH2 ,&normal JCN + cur-pos last-pos GTH2 ( ?return ) ?&noop + redraw-statusbar-and-cursor + cur-col cur-len LTH2 ?&normal #0000 .cursor/col STZ2 .cursor/row LDZ2 INC2 .cursor/row STZ2 - ;ensure-visible-cursor JMP2 + !ensure-visible-cursor &normal - ;cur-col JSR2 INC2 .cursor/col STZ2 + cur-col INC2 .cursor/col STZ2 &noop JMP2r ( move backward by one character ) @back ( -> ) - ;go-back JSR2 ;return JMP2 + go-back !return ( internal implementation shared by ;back and ;backspace ) @go-back ( -> ) - ;cur-pos JSR2 ;data EQU2 ,&noop JCN - ;cur-col JSR2 #0001 LTH2 ,&next-line JCN - ;cur-col JSR2 #0001 SUB2 .cursor/col STZ2 - ;redraw-statusbar-and-cursor JMP2 + cur-pos ;data EQU2 ?&noop + cur-col #0001 LTH2 ?&next-line + cur-col #0001 SUB2 .cursor/col STZ2 + !redraw-statusbar-and-cursor &next-line .cursor/row LDZ2k #0001 SUB2 ROT STZ2 - ;cur-len JSR2 .cursor/col STZ2 - ;ensure-visible-cursor JSR2 - ;redraw-statusbar-and-cursor JSR2 + cur-len .cursor/col STZ2 + ensure-visible-cursor + redraw-statusbar-and-cursor &noop JMP2r ( move up by one line ) @up ( -> ) - .cursor/row LDZ2 #0000 EQU2 ;return JCN2 + .cursor/row LDZ2 #0000 EQU2 ?return .cursor/row LDZ2 #0001 SUB2 .cursor/row STZ2 - ;ensure-visible-cursor JSR2 - ;redraw-statusbar-and-cursor JSR2 - ;return JMP2 + ensure-visible-cursor + redraw-statusbar-and-cursor + !return ( move down by one line ) @down ( -> ) .cursor/row LDZ2 - .buffer/line-count LDZ2 #0001 SUB2 EQU2 ;return JCN2 + .buffer/line-count LDZ2 #0001 SUB2 EQU2 ?return .cursor/row LDZ2 INC2 .cursor/row STZ2 - ;ensure-visible-cursor JSR2 - ;redraw-statusbar-and-cursor JSR2 - ;return JMP2 + ensure-visible-cursor + redraw-statusbar-and-cursor + !return @is-word-char ( c^ -> bool^ ) DUP #2f GTH OVR #3a LTH AND STH @@ -338,88 +342,88 @@ DUP #60 GTH SWP #7b LTH AND STHr ORA JMP2r @not-word-char ( c^ -> bool^ ) - ;is-word-char JSR2 #00 EQU JMP2r + is-word-char #00 EQU JMP2r @forward-by-word ( -> ) - ;cur-pos JSR2 + cur-pos &first - LDAk #00 EQU ,&done JCN - LDAk ;is-word-char JSR2 ,&second JCN - INC2 ;go-forward JSR2 ,&first JMP + LDAk #00 EQU ?&done + LDAk is-word-char ?&second + INC2 go-forward !&first &second - LDAk #00 EQU ,&done JCN - LDAk ;not-word-char JSR2 ,&done JCN - INC2 ;go-forward JSR2 ,&second JMP + LDAk #00 EQU ?&done + LDAk not-word-char ?&done + INC2 go-forward !&second &done - POP2 ;return JMP2 + POP2 !return @back-by-word ( -> ) - ;cur-pos JSR2 #0001 SUB2 + cur-pos #0001 SUB2 &first - DUP2 ;data LTH2 ,&done JCN - LDAk ;is-word-char JSR2 ,&second JCN - #0001 SUB2 ;go-back JSR2 ,&first JMP + DUP2 ;data LTH2 ?&done + LDAk is-word-char ?&second + #0001 SUB2 go-back !&first &second - DUP2 ;data LTH2 ,&done JCN - LDAk ;not-word-char JSR2 ,&done JCN - #0001 SUB2 ;go-back JSR2 ,&second JMP + DUP2 ;data LTH2 ?&done + LDAk not-word-char ?&done + #0001 SUB2 go-back !&second &done - POP2 ;return JMP2 + POP2 !return @help #01 .state/in-help STZ - ;term-erase-all JSR2 - #0000 #0000 ;term-move-cursor JSR2 - ;emit-color-bold JSR2 - ;help-text ;print JSR2 - ;emit-reset JSR2 - ;redraw-all JSR2 + term-erase-all + #0000 #0000 term-move-cursor + emit-color-bold + ;help-text print + emit-reset + redraw-all BRK ( center buffer view on the current line ) @center-view .term/rows LDZ2 INC2 #0002 DIV2 STH2k - .cursor/row LDZ2 LTH2 ,&standard JCN + .cursor/row LDZ2 LTH2 ?&standard POP2r #0000 .buffer/line-offset STZ2 ;data .buffer/offset STZ2 - ,&done JMP + !&done &standard .cursor/row LDZ2 STH2r SUB2 DUP2 .buffer/line-offset STZ2 - ;abs-line JSR2 .buffer/offset STZ2 + abs-line .buffer/offset STZ2 &done - ;redraw-all JSR2 ;return JMP2 + redraw-all !return ( move up by one page ) @page-up ( -> ) .term/rows LDZ2 #0002 SUB2 STH2k - .buffer/line-offset LDZ2 LTH2 ,&move-full JCN + .buffer/line-offset LDZ2 LTH2 ?&move-full POP2r - ;zero-row JSR2 + zero-row #0000 .cursor/col STZ2 - ,&done JMP + !&done &move-full .cursor/row LDZ2 STH2kr SUB2 .cursor/row STZ2 .buffer/line-offset LDZ2 STH2r SUB2 DUP2 .buffer/line-offset STZ2 - ;abs-line JSR2 .buffer/offset STZ2 + abs-line .buffer/offset STZ2 &done - ;redraw-all JSR2 ;return JMP2 + redraw-all !return ( move down by one page ) @page-down - ;eof-is-visible JSR2 ,&near-eof JCN + eof-is-visible ?&near-eof .term/rows LDZ2 #0002 SUB2 STH2k .buffer/line-offset LDZ2 ADD2 DUP2 .buffer/line-offset STZ2 - ;abs-line JSR2 .buffer/offset STZ2 + abs-line .buffer/offset STZ2 .cursor/row LDZ2 STH2r ADD2 .cursor/row STZ2 - ;redraw-all JSR2 ;return JMP2 + redraw-all !return &near-eof .buffer/line-count LDZ2 #0001 SUB2 .cursor/row STZ2 - ;cur-len JSR2 .cursor/col STZ2 - ;redraw-cursor JSR2 ;return JMP2 + cur-len .cursor/col STZ2 + redraw-cursor !return ( return true if the end of the file is visible ) @eof-is-visible ( -> bool^ ) @@ -430,9 +434,9 @@ ( beginning quitting femto, prompting if unsaved changes ) @quit #01 .state/quitting STZ - .state/modified LDZ #00 EQU ;quit-now JCN2 - ;messages/quit-prompt ;messages/null ;do-quit ;start-prompt JSR2 - ;redraw-prompt-and-cursor JSR2 ;return JMP2 + .state/modified LDZ #00 EQU ?quit-now + ;messages/quit-prompt ;messages/null ;do-quit start-prompt + redraw-prompt-and-cursor !return ( display two strings on the message line ) ( ) @@ -441,15 +445,15 @@ ( use messages/null for the second string if only one is needed. ) @send-message ( s1* s2* -> ) #01 .state/message STZ - ;move-to-message-line JSR2 - SWP2 ;print JSR2 ;print JMP2 + move-to-message-line + SWP2 print !print ( callback executed in response to the quit prompt. ) @do-quit - .tmp/data LDZ LIT "n EQU ;quit-now JCN2 - .tmp/data LDZ LIT "y EQU ;save JCN2 + .tmp/data LDZ LIT "n EQU ?quit-now + .tmp/data LDZ LIT "y EQU ?save #00 .state/quitting STZ - ;messages/unknown-input ;tmp/data ;send-message JSR2 + ;messages/unknown-input ;tmp/data send-message BRK ( label that calls quit! ) @@ -467,16 +471,16 @@ ( ) ( this should not be called for newlines, see ;newline ) @insert ( c^ -> ) - ;cur-pos JSR2 ;shift-right JSR2 - ;cur-col JSR2 INC2 .cursor/col STZ2 - ;redraw-all JSR2 ;return JMP2 + cur-pos shift-right + cur-col INC2 .cursor/col STZ2 + redraw-all !return ( insert the given character in the prompt ) @insert-prompt ( c^ -> ) .tmp/pos LDZ2 STH2k STA ( data[pos] <- c ) INC2r #00 STH2kr STA ( data[pos+1] <- 0 ) STH2r .tmp/pos STZ2 ( pos <- pos+1 ) - ;redraw-prompt-and-cursor JSR2 ;return JMP2 + redraw-prompt-and-cursor !return ( insert a tab at the cursor position ) ( ) @@ -484,48 +488,48 @@ ( either call ;insert with \t or else insert a number of ) ( spaces based on .config/tab-width. ) @insert-tab ( -> ) - .config/insert-tabs LDZ ,&use-tabs JCN + .config/insert-tabs LDZ ?&use-tabs #0000 .config/tab-width LDZ2 SUB2 &loop - DUP2 #0000 EQU2 ,&done JCN - #20 ;cur-pos JSR2 ;shift-right JSR2 - INC2 ,&loop JMP + DUP2 #0000 EQU2 ?&done + #20 cur-pos shift-right + INC2 !&loop &done - ;cur-col JSR2 .config/tab-width LDZ2 ADD2 .cursor/col STZ2 - ;redraw-all JSR2 ;return JMP2 + cur-col .config/tab-width LDZ2 ADD2 .cursor/col STZ2 + redraw-all !return &use-tabs - #09 ;insert JMP2 + #09 !insert ( insert a newline at the cursor position ) @newline ( c^ -> ) - #0a ;cur-pos JSR2 ;shift-right JSR2 + #0a cur-pos shift-right #0000 .cursor/col STZ2 .cursor/row LDZ2 INC2 .cursor/row STZ2 .buffer/line-count LDZ2k INC2 ROT STZ2 - ;ensure-visible-cursor JSR2 - ;redraw-all JSR2 ;return JMP2 + ensure-visible-cursor + redraw-all !return ( delete the character to the left of the cursor, if any ) @backspace ( -> ) - ;cur-pos JSR2 ;data EQU2 ;return JCN2 - ;go-back JSR2 ;delete JMP2 + cur-pos ;data EQU2 ?return + go-back !delete ( delete the last character in the prompt ) @backspace-prompt ( -> ) - .tmp/pos LDZ2 ;tmp/data EQU2 ,&skip JCN ( ;return JCN2 ) + .tmp/pos LDZ2 ;tmp/data EQU2 ?&skip ( ?return ) #00 .tmp/pos LDZ2 #0001 SUB2 ( 0 pos-1 ) STH2k STA ( data[pos-1] <- 0 ) STH2r .tmp/pos STZ2 ( pos <- pos-1 ) - &skip ;redraw-prompt-and-cursor JSR2 ;return JMP2 + &skip redraw-prompt-and-cursor !return ( delete the character under the cursor, if any ) @delete ( -> ) - ;last-pos JSR2 ;cur-pos JSR2 LTH2 ;return JCN2 - ;cur-pos JSR2 LDAk STH ( cur [c] ) - ;shift-left JSR2 ( [c] ) - STHr #0a NEQ ,¬-newline JCN + last-pos cur-pos LTH2 ?return + cur-pos LDAk STH ( cur [c] ) + shift-left ( [c] ) + STHr #0a NEQ ?¬-newline .buffer/line-count LDZ2k #0001 SUB2 ROT STZ2 - ¬-newline ;redraw-all JSR2 ;return JMP2 + ¬-newline redraw-all !return ( used at the start of an escape sequence to set up state. ) ( ) @@ -540,44 +544,44 @@ ( move to the end of the file ) @goto-end ( -> ) .buffer/line-count LDZ2 #0001 SUB2 .cursor/row STZ2 - .buffer/line-count LDZ2 .term/rows LDZ2 LTH2k ,&use-zero JCN - SUB2 #0002 ADD2 ,&continue JMP + .buffer/line-count LDZ2 .term/rows LDZ2 LTH2k ?&use-zero + SUB2 #0002 ADD2 !&continue &use-zero POP2 POP2 #0000 &continue DUP2 .buffer/line-offset STZ2 - ;abs-line JSR2 .buffer/offset STZ2 - ;cur-len JSR2 .cursor/col STZ2 - ;redraw-all JSR2 ;return JMP2 + abs-line .buffer/offset STZ2 + cur-len .cursor/col STZ2 + redraw-all !return ( move to the start of the file ) @goto-start ( -> ) - ;zero-row JSR2 + zero-row #0000 .cursor/col STZ2 - ;redraw-all JSR2 ;return JMP2 + redraw-all !return ( prompt for a line number and move to that line ) @goto-line ( -> ) - ;messages/goto-line ;messages/null ;do-goto-line ;start-prompt JSR2 - ;redraw-prompt-and-cursor JSR2 ;return JMP2 + ;messages/goto-line ;messages/null ;do-goto-line start-prompt + redraw-prompt-and-cursor !return ( parse the given string as a decimal number ) ( ) ( returns the number as a short followed by whether parsing was ok ) @parse-decimal-number ( addr* -> n* ok^ ) - LDAk ,&non-empty JCN + LDAk ?&non-empty #00 JMP2r &non-empty LIT2r 0000 &loop - LDAk ,&continue JCN + LDAk ?&continue POP2 STH2r #01 JMP2r &continue - LDAk LIT "0 LTH ,&fail JCN - LDAk LIT "9 GTH ,&fail JCN + LDAk LIT "0 LTH ?&fail + LDAk LIT "9 GTH ?&fail LIT2r 000a MUL2r LDAk LIT "0 SUB #00 SWP STH2 ADD2r - INC2 ,&loop JMP + INC2 !&loop &fail POP2r #00 JMP2r @@ -585,55 +589,55 @@ ( ) ( this is used as a callback from the goto-line prompt ) @do-goto-line ( n* -> ) - ;tmp/data ;parse-decimal-number JSR2 - ,&ok JCN - ;messages/unknown-input ;tmp/data ;send-message JSR2 - ;return JMP2 + ;tmp/data parse-decimal-number + ?&ok + ;messages/unknown-input ;tmp/data send-message + !return &ok #0001 SUB2 ( convert 1-indexing to 0-indexing ) - DUP2 .buffer/line-count LDZ2 LTH2 ,&within JCN - POP2 ;goto-end JMP2 + DUP2 .buffer/line-count LDZ2 LTH2 ?&within + POP2 !goto-end &within - ;jump-to-line JSR2 - ;redraw-all JSR2 ;return JMP2 + jump-to-line + redraw-all !return ( move the cursor to the given coordinates ) ( ) ( this won't move the display if the given coordinates are visible. ) @move-to-coord ( col* row* -> ) - DUP2 ;line-is-visible JSR2 ;jump-to-coord/short JCN2 - ;jump-to-coord JMP2 + DUP2 line-is-visible ?jump-to-coord/short + !jump-to-coord ( move the cursor to the given coordinates ) ( ) ( this will always ensure the display is centered on the given coordinates ) @jump-to-coord ( x* y* -> ) - .term/rows LDZ2 INC2 #0002 DIV2 LTH2k ( x y rows/2 ylines-rows? ) - ,&late JCN ( x y y-rows/2 lines-rows ) - POP2 ,&finish JMP + ?&late ( x y y-rows/2 lines-rows ) + POP2 !&finish &early ( x y rows/2 ) - POP2 #0000 ,&finish JMP ( x y 0000 ) + POP2 #0000 !&finish ( x y 0000 ) &late ( x y y-rows/2 lines-rows ) NIP2 &finish ( x y o ) - ;redraw-all JSR2 + redraw-all SUB2k STH2 DUP2 ( x y o o [y-o] ) .buffer/line-offset STZ2 ( x y o [y-o] ) - ;abs-line JSR2 .buffer/offset STZ2 ( x y [y-o] ) + abs-line .buffer/offset STZ2 ( x y [y-o] ) POP2r &short - ;redraw-statusbar-and-cursor JSR2 + redraw-statusbar-and-cursor .cursor/row STZ2 ( x ) .cursor/col STZ2 JMP2r ( jump to the given line number ) @jump-to-line ( n* -> ) - #0000 SWP2 ;jump-to-coord JMP2 + #0000 SWP2 !jump-to-coord ( ensure the cursor is visibe ) ( ) @@ -641,21 +645,21 @@ ( centered on the cursor's coordinates. ) @ensure-visible-cursor .cursor/row LDZ2 .buffer/line-offset LDZ2 - SUB2 .term/rows LDZ2 LTH2 ,&noop JCN - .cursor/row LDZ2 ;jump-to-line JSR2 - ;redraw-all JSR2 + SUB2 .term/rows LDZ2 LTH2 ?&noop + .cursor/row LDZ2 jump-to-line + redraw-all &noop JMP2r ( currently used to print stack information. ) @debug - ;messages/input-error ;error! JMP2 + ;messages/input-error !errorq ( move the terminal's cursor to the message line ) ( ) ( this low level method does not change any editor state (such as ) ( the cursor) but is used to display messages. ) @move-to-message-line ( -> ) - #0000 .term/rows LDZ2 #0002 ADD2 ;term-move-cursor JMP2 + #0000 .term/rows LDZ2 #0002 ADD2 !term-move-cursor ( start a prompt on the message line ) ( ) @@ -668,10 +672,10 @@ ( ) ( when called vector should end in a BRK instructinon. ) @start-prompt ( prompt* default* vector* -> ) - .prompt/active LDZ ,&is-active JCN + .prompt/active LDZ ?&is-active #01 .prompt/active STZ ( prompt/active <- 1 ) .prompt/vector STZ2 ( prompt/vector <- vector ) - ;tmp/data ;str-copy JSR2 ( tmp/data <- default ) + ;tmp/data str-copy ( tmp/data <- default ) ;tmp/data ADD2 .tmp/pos STZ2 ( tmp/pos <- len(default)+data ) .prompt/string STZ2 ( prompt/string <- prompt ) JMP2r @@ -682,24 +686,24 @@ @cancel-prompt ( -> ) #00 .prompt/active STZ #00 .state/quitting STZ - ;clear-message-line JSR2 - ;redraw-prompt-and-cursor JSR2 - ;return JMP2 + clear-message-line + redraw-prompt-and-cursor + !return ( finishes prompt and executes callback ) ( ) ( when called vector should end in a BRK instruction ) @finish-prompt ( -> ) #00 .prompt/active STZ - ;clear-message-line JSR2 - ;redraw-prompt-and-cursor JSR2 + clear-message-line + redraw-prompt-and-cursor .prompt/vector LDZ2 JMP2 ( begin saving the file, prompting the user for a fiel name ) @save - ;messages/save-prompt ;filename ;do-save ;start-prompt JSR2 - ;redraw-prompt-and-cursor JSR2 - ;return JMP2 + ;messages/save-prompt ;filename ;do-save start-prompt + redraw-prompt-and-cursor + !return ( save the file with the filename found in tmp/data ) @do-save ( -> ) @@ -708,57 +712,57 @@ STH2kr .File/length DEO2 ;data .File/write DEO2 - .File/success DEI2 STH2r EQU2 ,&ok JCN - ;messages/save-failed ,&finish JMP + .File/success DEI2 STH2r EQU2 ?&ok + ;messages/save-failed !&finish &ok #00 .state/modified STZ - ;tmp/data ;filename ;str-copy JSR2 POP2 + ;tmp/data ;filename str-copy POP2 ;messages/save-ok &finish - ;tmp/data ;send-message JSR2 - .state/quitting LDZ ;quit-now JCN2 + ;tmp/data send-message + .state/quitting LDZ ?quit-now #03 .state/redraw STZ ( FIXME: why do we have to do this? ) - ;return JMP2 + !return ( begin a search, prompting for a search string ) @search ( -> ) - ;messages/search-prompt ;messages/null ;do-search ;start-prompt JSR2 - ;redraw-prompt-and-cursor JSR2 - ;return JMP2 + ;messages/search-prompt ;messages/null ;do-search start-prompt + redraw-prompt-and-cursor + !return ( execute a search, using the given search string ) @do-search ( -> ) .cursor/row LDZ2 .searching/orig-row STZ2 .cursor/col LDZ2 .searching/orig-col STZ2 #0000 .searching/regex STZ2 - ;move-to-next-match JSR2 ,&found JCN - ;move-to-prev-match JSR2 ,&found JCN - ;messages/no-matches-found ;tmp/data ;send-message JSR2 BRK + move-to-next-match ?&found + move-to-prev-match ?&found + ;messages/no-matches-found ;tmp/data send-message BRK &found #01 .searching/active STZ - ;redraw-matches JSR2 - ;return JMP2 + redraw-matches + !return ( begin a search, prompting for a regular expression ) @regex-search ( -> ) - ;messages/regex-search-prompt ;messages/null ;do-regex-search ;start-prompt JSR2 - ;redraw-prompt-and-cursor JSR2 ;return JMP2 + ;messages/regex-search-prompt ;messages/null ;do-regex-search start-prompt + redraw-prompt-and-cursor !return ( execute a search, using the given regular expressions ) ( ) ( TODO: handle invalid regular expressions that fail to compile ) @do-regex-search ( -> ) - ;cur-pos JSR2 DUP2 .searching/start STZ2 .searching/end STZ2 + cur-pos DUP2 .searching/start STZ2 .searching/end STZ2 .cursor/row LDZ2 .searching/orig-row STZ2 .cursor/col LDZ2 .searching/orig-col STZ2 - ;tmp/data ;compile JSR2 .searching/regex STZ2 - ;move-to-next-regex-match JSR2 ,&found JCN - ;move-to-prev-regex-match JSR2 ,&found JCN - ;messages/no-matches-found ;tmp/data ;send-message JSR2 BRK + ;tmp/data compile .searching/regex STZ2 + move-to-next-regex-match ?&found + move-to-prev-regex-match ?&found + ;messages/no-matches-found ;tmp/data send-message BRK &found #01 .searching/active STZ - ;redraw-matches JSR2 - ;return JMP2 + redraw-matches + !return ( toggle the color used by the terminal ) ( ) @@ -772,10 +776,13 @@ ( - cyan ) ( - white ) @toggle-color ( -> ) - .config/color LDZ2 #3733 EQU2 ,&wrap-around JCN - .config/color LDZ2 #0100 ADD2 .config/color STZ2 ,&done JMP - &wrap-around #3033 .config/color STZ2 - &done ;redraw-all JSR2 ;return JMP2 + .config/color LDZ2 #3733 EQU2 ?{ + .config/color LDZ2 #0100 ADD2 DUP2 .config/color STZ2 + DUP2 #3733 LTH2 ?{ .config/red STZ2 !&done } + POP2 #3133 .config/red STZ2 !&done + } + #3033 DUP2 .config/color STZ2 .config/red STZ2 + &done redraw-all !return ( toggle whether to use literal tab characters ) ( ) @@ -783,7 +790,7 @@ ( characters are found, and 00 otherwise. ) @toggle-tabs ( -> ) .config/insert-tabs LDZk #00 EQU SWP STZ - ;redraw-statusbar-and-cursor JSR2 ;return JMP2 + redraw-statusbar-and-cursor !return ( interpret user input as an escaped sequence ) ( ) @@ -792,17 +799,18 @@ ( TODO: maybe M-% for search&replace ) @on-key-escaped ( -> ) #00 .state/saw-esc STZ - .state/key LDZ LIT "< EQU ( M-< ) ;goto-start JCN2 - .state/key LDZ LIT "> EQU ( M-> ) ;goto-end JCN2 - .state/key LDZ LIT "b EQU ( M-b ) ;back-by-word JCN2 - .state/key LDZ LIT "c EQU ( M-c ) ;toggle-color JCN2 - .state/key LDZ LIT "f EQU ( M-f ) ;forward-by-word JCN2 - .state/key LDZ LIT "g EQU ( M-g ) ;goto-line JCN2 - .state/key LDZ LIT "s EQU ( M-s ) ;regex-search JCN2 - .state/key LDZ LIT "t EQU ( M-t ) ;toggle-tabs JCN2 - .state/key LDZ LIT "u EQU ( M-u ) ;undo JCN2 - .state/key LDZ LIT "v EQU ( M-v ) ;page-up JCN2 - .state/key LDZ LIT "[ EQU ( M-[ ) ;xterm JCN2 + .state/key LDZ LIT "< EQU ( M-< ) ?goto-start + .state/key LDZ LIT "> EQU ( M-> ) ?goto-end + .state/key LDZ LIT "b EQU ( M-b ) ?back-by-word + .state/key LDZ LIT "c EQU ( M-c ) ?toggle-color + .state/key LDZ LIT "f EQU ( M-f ) ?forward-by-word + .state/key LDZ LIT "g EQU ( M-g ) ?goto-line + .state/key LDZ LIT "h EQU ( M-h ) ?help + .state/key LDZ LIT "s EQU ( M-s ) ?regex-search + .state/key LDZ LIT "t EQU ( M-t ) ?toggle-tabs + .state/key LDZ LIT "u EQU ( M-u ) ?undo + .state/key LDZ LIT "v EQU ( M-v ) ?page-up + .state/key LDZ LIT "[ EQU ( M-[ ) ?xterm BRK ( set our input to expect xterm control sequences ) @@ -823,25 +831,25 @@ ( the relevant action. ) @on-key-vt ( -> ) .state/saw-vt LDZk STH #00 SWP STZ - .state/key LDZ LIT "~ EQU ,&ok JCN + .state/key LDZ LIT "~ EQU ?&ok POPr BRK &ok - STHr DUP LIT "1 NEQ ,¬-1 JCN - ( ^[[1~ -> home ) POP ;bol JMP2 - ¬-1 DUP LIT "2 NEQ ,¬-2 JCN + STHr DUP LIT "1 NEQ ?¬-1 + ( ^[[1~ -> home ) POP !bol + ¬-1 DUP LIT "2 NEQ ?¬-2 ( ^[[2~ -> insert ) POP BRK - ¬-2 DUP LIT "3 NEQ ,¬-3 JCN - ( ^[[3~ -> delete ) POP ;delete JMP2 - ¬-3 DUP LIT "4 NEQ ,¬-4 JCN - ( ^[[4~ -> end ) POP ;eol JMP2 - ¬-4 DUP LIT "5 NEQ ,¬-5 JCN - ( ^[[5~ -> page up ) POP ;page-up JMP2 - ¬-5 DUP LIT "6 NEQ ,¬-6 JCN - ( ^[[6~ -> page down ) POP ;page-down JMP2 - ¬-6 DUP LIT "7 NEQ ,¬-7 JCN - ( ^[[7~ -> home ) POP ;bol JMP2 - ¬-7 DUP LIT "8 NEQ ,¬-8 JCN - ( ^[[8~ -> end ) POP ;eol JMP2 + ¬-2 DUP LIT "3 NEQ ?¬-3 + ( ^[[3~ -> delete ) POP !delete + ¬-3 DUP LIT "4 NEQ ?¬-4 + ( ^[[4~ -> end ) POP !eol + ¬-4 DUP LIT "5 NEQ ?¬-5 + ( ^[[5~ -> page up ) POP !page-up + ¬-5 DUP LIT "6 NEQ ?¬-6 + ( ^[[6~ -> page down ) POP !page-down + ¬-6 DUP LIT "7 NEQ ?¬-7 + ( ^[[7~ -> home ) POP !bol + ¬-7 DUP LIT "8 NEQ ?¬-8 + ( ^[[8~ -> end ) POP !eol ¬-8 ( ??? ) POP BRK @@ -853,14 +861,14 @@ ( to continue (or end) the sequence. ) @on-key-xterm ( -> ) #00 .state/saw-xterm STZ - .state/key LDZ LIT "A EQU ( ^[[A -> up ) ;up JCN2 - .state/key LDZ LIT "B EQU ( ^[[B -> down ) ;down JCN2 - .state/key LDZ LIT "C EQU ( ^[[C -> right ) ;forward JCN2 - .state/key LDZ LIT "D EQU ( ^[[D -> left ) ;back JCN2 - .state/key LDZ LIT "F EQU ( ^[[F -> end ) ;eol JCN2 - .state/key LDZ LIT "H EQU ( ^[[H -> home ) ;bol JCN2 - .state/key LDZ LIT "0 LTH ;ignore JCN2 - .state/key LDZ LIT "8 GTH ;ignore JCN2 + .state/key LDZ LIT "A EQU ( ^[[A -> up ) ?up + .state/key LDZ LIT "B EQU ( ^[[B -> down ) ?down + .state/key LDZ LIT "C EQU ( ^[[C -> right ) ?forward + .state/key LDZ LIT "D EQU ( ^[[D -> left ) ?back + .state/key LDZ LIT "F EQU ( ^[[F -> end ) ?eol + .state/key LDZ LIT "H EQU ( ^[[H -> home ) ?bol + .state/key LDZ LIT "0 LTH ?ignore + .state/key LDZ LIT "8 GTH ?ignore .state/key LDZ .state/saw-vt STZ ( ^[[1 through ^[[8 ) BRK @@ -872,9 +880,9 @@ ( ) ( if state/message is unset this is a no-op. ) @clear-message-line - .state/message LDZ #00 EQU ,&done JCN - ;move-to-message-line JSR2 - ;term-erase-line JSR2 + .state/message LDZ #00 EQU ?&done + move-to-message-line + term-erase-line #00 .state/message STZ &done JMP2r @@ -883,9 +891,9 @@ ( this method unsets searching/active and also restores ) ( the original cursor position. ) @cancel-search - .searching/orig-row LDZ2 ;jump-to-line JSR2 + .searching/orig-row LDZ2 jump-to-line .searching/orig-col LDZ2 .cursor/col STZ2 - ,finish-search JMP + !finish-search ( cancel the active search ) ( ) @@ -893,7 +901,7 @@ ( this leaves the cursor where it is. ) @finish-search #00 .searching/active STZ - ;reset-arena JSR2 ;redraw-all JSR2 ;return JMP2 + reset-arena redraw-all !return ( TODO: i haven't decided how to solve the problem of ) ( overlapping matches yet. i don't really want to maintain ) @@ -911,34 +919,34 @@ ( moves the cursor forward to the next match. if there are no ) ( further matches the cursor does not move. ) @jump-to-next-match ( -> ) - .searching/regex LDZ2 ORA ,&is-regex JCN - ;move-to-next-match JSR2 POP ;return JMP2 + .searching/regex LDZ2 ORA ?&is-regex + move-to-next-match POP !return &is-regex - ;move-to-next-regex-match JSR2 POP ;return JMP2 + move-to-next-regex-match POP !return ( jump backward to the previous match, if any. ) ( ) ( moves the cursor backward to the previous match. if there are ) ( no further matches the cursor does not move. ) @jump-to-prev-match ( -> ) - .searching/regex LDZ2 ORA ,&is-regex JCN - ;move-to-prev-match JSR2 POP ;return JMP2 + .searching/regex LDZ2 ORA ?&is-regex + move-to-prev-match POP !return &is-regex - ;move-to-prev-regex-match JSR2 POP ;return JMP2 + move-to-prev-regex-match POP !return ( move to the next substring match. ) ( ) ( called by ;jump-to-next-match. ) @move-to-next-match ( -> ok^ ) .buffer/limit LDZ2 - ;cur-pos JSR2 INC2 + cur-pos INC2 &loop - GTH2k #00 EQU ,&fail JCN - DUP2 ;matches-at JSR2 - ORA ,&found JCN - INC2 ,&loop JMP + GTH2k #00 EQU ?&fail + DUP2 matches-at + ORA ?&found + INC2 !&loop &found - NIP2 ;jump-to-pos JSR2 #01 JMP2r + NIP2 jump-to-pos #01 JMP2r &fail POP2 POP2 #00 JMP2r @@ -947,14 +955,14 @@ ( called by ;jump-to-prev-match. ) @move-to-prev-match ( -> ok^ ) ;data - ;cur-pos JSR2 #0001 SUB2 + cur-pos #0001 SUB2 &loop - GTH2k ,&fail JCN - DUP2 ;matches-at JSR2 - ORA ,&found JCN - #0001 SUB2 ,&loop JMP + GTH2k ?&fail + DUP2 matches-at + ORA ?&found + #0001 SUB2 !&loop &found - NIP2 ;jump-to-pos JSR2 #01 JMP2r + NIP2 jump-to-pos #01 JMP2r &fail POP2 POP2 #00 JMP2r @@ -963,15 +971,15 @@ ( called by ;jump-to-next-match. ) @move-to-next-regex-match ( -> ok^ ) .searching/end LDZ2 .buffer/limit LDZ2 OVR2 - GTH2 ,&ok JCN + GTH2 ?&ok POP2 #00 JMP2r &ok - .searching/regex LDZ2 ;rx-search JSR2 ,&found JCN + .searching/regex LDZ2 rx-search ?&found #00 JMP2r &found ;search-end LDA2 .searching/end STZ2 ;search-start LDA2 DUP2 .searching/start STZ2 - ;jump-to-pos JSR2 #01 JMP2r + jump-to-pos #01 JMP2r ( move to the previous substring match. ) ( ) @@ -987,19 +995,19 @@ ( and then taking the last match before the cursor works. ) @move-to-prev-regex-match ( -> ok^ ) LITr 00 - ;cur-pos JSR2 ;data ( limit pos [res] ) + cur-pos ;data ( limit pos [res] ) &loop ( limit pos [res] ) - GTH2k #00 EQU ,&done JCN ( limit pos ) - DUP2 .searching/regex LDZ2 ;rx-search JSR2 ( limit pos match? ) - #00 EQU ,&done JCN ( limit pos ) - OVR2 ;search-end LDA2 LTH2 ,&done JCN + GTH2k #00 EQU ?&done ( limit pos ) + DUP2 .searching/regex LDZ2 rx-search ( limit pos match? ) + #00 EQU ?&done ( limit pos ) + OVR2 ;search-end LDA2 LTH2 ?&done POP2 POPr LITr 01 ;search-start LDA2 .searching/start STZ2 ;search-end LDA2 DUP2 .searching/end STZ2 - ,&loop JMP + !&loop &done - POP2 POP2 STHr DUP #00 EQU ,&fail JCN - .searching/start LDZ2 ;jump-to-pos JSR2 + POP2 POP2 STHr DUP #00 EQU ?&fail + .searching/start LDZ2 jump-to-pos &fail JMP2r @@ -1011,14 +1019,14 @@ ( - end the search leaving the cursor where it is (enter) ) ( - cancel the search restoring the cursor (C-g) ) @on-key-searching - .state/key LDZ #07 EQU ( C-g ) ;cancel-search JCN2 - .state/key LDZ #08 EQU ( C-h ) ;help JCN2 - .state/key LDZ #0d EQU ( \r ) ;finish-search JCN2 - .state/key LDZ #12 EQU ( C-r ) ;jump-to-prev-match JCN2 - .state/key LDZ #13 EQU ( C-s ) ;jump-to-next-match JCN2 - .state/key LDZ #6e EQU ( n ) ;jump-to-next-match JCN2 - .state/key LDZ #70 EQU ( p ) ;jump-to-prev-match JCN2 - ;ignore JMP2 + .state/key LDZ #07 EQU ( C-g ) ?cancel-search + .state/key LDZ #08 EQU ( C-h ) ?help + .state/key LDZ #0d EQU ( \r ) ?finish-search + .state/key LDZ #12 EQU ( C-r ) ?jump-to-prev-match + .state/key LDZ #13 EQU ( C-s ) ?jump-to-next-match + .state/key LDZ #6e EQU ( n ) ?jump-to-next-match + .state/key LDZ #70 EQU ( p ) ?jump-to-prev-match + !ignore ( on-key event handler to use when prompt is active ) ( ) @@ -1034,13 +1042,13 @@ ( C-a, C-d, etc. however, it's enough extra work to enable ) ( this that for now i haven't done it. ) @on-key-prompt - .state/key LDZ #07 EQU ( C-g ) ;cancel-prompt JCN2 - .state/key LDZ #08 EQU ( C-h ) ;help JCN2 - .state/key LDZ #0d EQU ( \r ) ;finish-prompt JCN2 - .state/key LDZ #7f EQU ( DEL ) ;backspace-prompt JCN2 - .state/key LDZ #20 LTH ;ignore JCN2 ( ignore for now ) - .state/key LDZ #7e GTH ;ignore JCN2 ( ignore for now ) - .state/key LDZ ( printable ASCII ) ;insert-prompt JMP2 + .state/key LDZ #07 EQU ( C-g ) ?cancel-prompt + .state/key LDZ #08 EQU ( C-h ) ?help + .state/key LDZ #0d EQU ( \r ) ?finish-prompt + .state/key LDZ #7f EQU ( DEL ) ?backspace-prompt + .state/key LDZ #20 LTH ?ignore ( ignore for now ) + .state/key LDZ #7e GTH ?ignore ( ignore for now ) + .state/key LDZ ( printable ASCII ) !insert-prompt BRK ( on-key event handler ) @@ -1059,34 +1067,34 @@ @on-key #00 .state/in-undo STZ .Console/read DEI .state/key STZ - ;clear-message-line JSR2 - .state/in-help LDZ #00 .state/in-help STZ ;return JCN2 - .searching/active LDZ ;on-key-searching JCN2 - .prompt/active LDZ ;on-key-prompt JCN2 - .state/saw-vt LDZ ;on-key-vt JCN2 - .state/saw-xterm LDZ ;on-key-xterm JCN2 - .state/saw-esc LDZ ;on-key-escaped JCN2 - .state/key LDZ #01 EQU ( C-a ) ;bol JCN2 - .state/key LDZ #02 EQU ( C-b ) ;back JCN2 - .state/key LDZ #04 EQU ( C-d ) ;delete JCN2 - .state/key LDZ #05 EQU ( C-e ) ;eol JCN2 - .state/key LDZ #06 EQU ( C-f ) ;forward JCN2 - .state/key LDZ #08 EQU ( C-h ) ;help JCN2 - .state/key LDZ #09 EQU ( \t ) ;insert-tab JCN2 - .state/key LDZ #0c EQU ( C-l ) ;center-view JCN2 - .state/key LDZ #0d EQU ( \r ) ;newline JCN2 - .state/key LDZ #0e EQU ( C-n ) ;down JCN2 - .state/key LDZ #0f EQU ( C-o ) ;save JCN2 - .state/key LDZ #10 EQU ( C-p ) ;up JCN2 - .state/key LDZ #13 EQU ( C-s ) ;search JCN2 - .state/key LDZ #16 EQU ( C-v ) ;page-down JCN2 - .state/key LDZ #18 EQU ( C-x ) ;quit JCN2 - .state/key LDZ #1a EQU ( C-z ) ;debug JCN2 - .state/key LDZ #1b EQU ( ESC ) ;escape JCN2 - .state/key LDZ #7f EQU ( DEL ) ;backspace JCN2 - .state/key LDZ #20 LTH ;ignore JCN2 ( ignore for now ) - .state/key LDZ #7e GTH ;ignore JCN2 ( ignore for now ) - .state/key LDZ ( printable ASCII ) ;insert JMP2 + clear-message-line + .state/in-help LDZ #00 .state/in-help STZ ?return + .searching/active LDZ ?on-key-searching + .prompt/active LDZ ?on-key-prompt + .state/saw-vt LDZ ?on-key-vt + .state/saw-xterm LDZ ?on-key-xterm + .state/saw-esc LDZ ?on-key-escaped + .state/key LDZ #01 EQU ( C-a ) ?bol + .state/key LDZ #02 EQU ( C-b ) ?back + .state/key LDZ #04 EQU ( C-d ) ?delete + .state/key LDZ #05 EQU ( C-e ) ?eol + .state/key LDZ #06 EQU ( C-f ) ?forward + .state/key LDZ #08 EQU ( C-h ) ?help + .state/key LDZ #09 EQU ( \t ) ?insert-tab + .state/key LDZ #0c EQU ( C-l ) ?center-view + .state/key LDZ #0d EQU ( \r ) ?newline + .state/key LDZ #0e EQU ( C-n ) ?down + .state/key LDZ #0f EQU ( C-o ) ?save + .state/key LDZ #10 EQU ( C-p ) ?up + .state/key LDZ #13 EQU ( C-s ) ?search + .state/key LDZ #16 EQU ( C-v ) ?page-down + .state/key LDZ #18 EQU ( C-x ) ?quit + .state/key LDZ #1a EQU ( C-z ) ?debug + .state/key LDZ #1b EQU ( ESC ) ?escape + .state/key LDZ #7f EQU ( DEL ) ?backspace + .state/key LDZ #20 LTH ?ignore ( ignore for now ) + .state/key LDZ #7e GTH ?ignore ( ignore for now ) + .state/key LDZ ( printable ASCII ) !insert ( return the smaller of two short values ) @min2 ( x* y* -> min* ) @@ -1105,90 +1113,90 @@ ( ) ( these don't perform a redraw right away, but instead ) ( signal that the next drawing should include that part. ) -@redraw-cursor ( -> ) #01 ,redraw-add JMP -@redraw-statusbar-and-cursor ( -> ) #03 ,redraw-add JMP -@redraw-prompt-and-cursor ( -> ) #05 ,redraw-add JMP -@redraw-matches ( -> ) #08 ,redraw-add JMP -@redraw-all ( -> ) #1f ,redraw-add JMP +@redraw-cursor ( -> ) #01 !redraw-add +@redraw-statusbar-and-cursor ( -> ) #03 !redraw-add +@redraw-prompt-and-cursor ( -> ) #05 !redraw-add +@redraw-matches ( -> ) #08 !redraw-add +@redraw-all ( -> ) #1f !redraw-add ( draw the current cursor location ) @draw-cursor ( -> ) .prompt/active LDZ #00 EQU JMP JMP2r ( TODO: handle long lines ) - ;cur-w-col JSR2 lmargin ADD2 + cur-w-col lmargin ADD2 .cursor/row LDZ2 .buffer/line-offset LDZ2 SUB2 - ;term-move-cursor JMP2 + !term-move-cursor ( current column in terms of display width ) ( ) ( this is different than ;cur-col due to tabs ) @cur-w-col ( -> col* ) LIT2r 0000 ( [0] ) - ;cur-line JSR2 DUP2 ;cur-col JSR2 ADD2 SWP2 ( lim s [0] ) - &loop GTH2k ,&next JCN + cur-line DUP2 cur-col ADD2 SWP2 ( lim s [0] ) + &loop GTH2k ?&next POP2 POP2 STH2r JMP2r - &next LDAk #09 EQU ,&tabs JCN INC2 INC2r ,&loop JMP - &tabs INC2 .config/tab-width LDZ2 STH2 ADD2r ,&loop JMP + &next LDAk #09 EQU ?&tabs INC2 INC2r !&loop + &tabs INC2 .config/tab-width LDZ2 STH2 ADD2r !&loop ( move the terminal cursor to the statusbar line ) @move-to-statusbar ( -> ) - #0000 .term/rows LDZ2 ;term-move-cursor JMP2 + #0000 .term/rows LDZ2 !term-move-cursor ( draw the full statusbar ) @draw-statusbar ( -> ) - ;move-to-statusbar JSR2 - ;emit-color-reverse JSR2 + move-to-statusbar + emit-color-reverse LIT2r 2018 .term/cols LDZ2 #0001 ( cols i [2018] ) - &loop LTH2k ,&done JCN DEOkr INC2 ,&loop JMP + &loop LTH2k ?&done DEOkr INC2 !&loop &done POP2 POP2 POP2r ( ) - ;move-to-statusbar JSR2 + move-to-statusbar ( display ** if the buffer has unsaved changes, -- otherwise ) #2d .state/modified LDZ #00 NEQ #03 MUL SUB DUP emit emit sp - ;filename ;print JSR2 + ;filename print sp emit-[ - .buffer/limit LDZ2 ;data SUB2 ;emit-dec2 JSR2 - ;messages/bytes ;print JSR2 + .buffer/limit LDZ2 ;data SUB2 emit-dec2 + ;messages/bytes print sp - .buffer/line-count LDZ2 ;emit-dec2 JSR2 - ;messages/lines ;print JSR2 + .buffer/line-count LDZ2 emit-dec2 + ;messages/lines print sp emit-lpar - ;cur-col JSR2 INC2 ;emit-dec2 JSR2 + cur-col INC2 emit-dec2 emit-, - .cursor/row LDZ2 INC2 ;emit-dec2 JSR2 + .cursor/row LDZ2 INC2 emit-dec2 emit-rpar sp emit-[ LIT "s .config/insert-tabs LDZ ADD emit emit-] sp - ;messages/help-msg ;print JSR2 - ;emit-reset JMP2 + ;messages/help-msg print + !emit-reset @draw-prompt ( -> ) - ;clear-message-line JSR2 - .prompt/active LDZ ,&is-active JCN + clear-message-line + .prompt/active LDZ ?&is-active JMP2r &is-active #01 .state/message STZ - ;move-to-message-line JSR2 - ;emit-color-bold JSR2 - .prompt/string LDZ2 ;print JSR2 - ;emit-reset JSR2 - ;tmp/data ;print JSR2 + move-to-message-line + emit-color-bold + .prompt/string LDZ2 print + emit-reset + ;tmp/data print JMP2r @draw-linenum ( n* -> ) - ;emit-reset JSR2 - ;emit-color JSR2 - ;emit-dec2-pad JSR2 sp - ;emit-reset JMP2 + emit-reset + emit-color + emit-dec2-pad sp + !emit-reset @matches-at ( s* -> limit* ) LIT2r :tmp/data - &loop LDAkr STHr #00 EQU ,&done JCN - LDAk LDAkr STHr NEQ ,&fail JCN - INC2 INC2r ,&loop JMP + &loop LDAkr STHr #00 EQU ?&done + LDAk LDAkr STHr NEQ ?&fail + INC2 INC2r !&loop &fail POP2 #0000 &done POP2r JMP2r @@ -1196,93 +1204,93 @@ @draw-region ( offset* limit* col* row* -> ) OVR2 ( offset limit col row col ) .term/cols LDZ2 SWP2 SUB2 STH2 ( offset limit col row [cols-col] ) - ;term-move-cursor JSR2 ( offset limit [cols-col] ) + term-move-cursor ( offset limit [cols-col] ) OVR2 STH2r ADD2 ( offset limit offset+cols-col ) - ;min2 JSR2 STH2 ( offset [cutoff] ) + min2 STH2 ( offset [cutoff] ) &loop ( i [cutoff] ) - DUP2 STH2kr LTH2 #00 EQU ,&done JCN - LDAk #00 EQU ,&done JCN - LDAk #18 DEO INC2 ,&loop JMP + DUP2 STH2kr LTH2 #00 EQU ?&done + LDAk #00 EQU ?&done + LDAk #18 DEO INC2 !&loop &done POP2 POP2r JMP2r @screen-limit ( -> sc-limit* ) .term/rows LDZ2 .buffer/line-offset LDZ2 ADD2 ( row0+rows ) - DUP2 .buffer/line-count LDZ2 LTH2 ,¬-end JCN + DUP2 .buffer/line-count LDZ2 LTH2 ?¬-end POP2 .buffer/limit LDZ2 JMP2r ¬-end - ;abs-line JMP2 + !abs-line @draw-regex-matches ( -> ) - ;emit-color-reverse-bold JSR2 ( ) - ;screen-limit JSR2 .buffer/offset LDZ2 ( limit pos ) + emit-color-reverse-bold ( ) + screen-limit .buffer/offset LDZ2 ( limit pos ) &loop ( limit pos ) GTH2k #00 EQU ( limit pos limit>pos=0? ) - ,&done JCN ( limit pos ) + ?&done ( limit pos ) DUP2 .searching/regex LDZ2 ( limit pos pos rx ) - ;rx-search JSR2 #00 EQU ( limit pos found=0? ) - ,&done JCN ( limit pos ) + rx-search #00 EQU ( limit pos found=0? ) + ?&done ( limit pos ) POP2 ;search-start LDA2 ( limit start ) GTH2k #00 EQU ( limit start limit>start=0? ) - ,&done JCN ( limit start ) + ?&done ( limit start ) ;search-end LDA2 OVR2 ( limit start end start ) - ;pos-to-row-col JSR2 ( limit start end row col ) + pos-to-row-col ( limit start end row col ) lmargin ADD2 ( limit start end row col+lm ) SWP2 .buffer/line-offset LDZ2 SUB2 ( limit start end col+lm row-lo ) - ;draw-region JSR2 ( limit ) - ;search-end LDA2 ( limit end ) ,&loop JMP + draw-region ( limit ) + ;search-end LDA2 ( limit end ) !&loop &done ( limit pos ) POP2 POP2 JMP2r @draw-matches ( -> ) ( return if not searching ) - .searching/active LDZ #00 EQU ,&return JCN ( ) - .searching/regex LDZ2 ORA ;draw-regex-matches JCN2 - ;emit-color-reverse-bold JSR2 + .searching/active LDZ #00 EQU ?&return ( ) + .searching/regex LDZ2 ORA ?draw-regex-matches + emit-color-reverse-bold lmargin ,&x STR2 #0000 ,&y STR2 ( x <- 0, y <- 0 ) .buffer/offset LDZ2 DUP2 - ;screen-limit JSR2 SUB2 STH2 ( offset [-count] ) + screen-limit SUB2 STH2 ( offset [-count] ) &loop ( offset [-count] ) - STH2kr #0000 EQU2 ,&done JCN - DUP2 ;matches-at JSR2 ( offset mlim [-count] ) - DUP2 ORA ,&found JCN + STH2kr #0000 EQU2 ?&done + DUP2 matches-at ( offset mlim [-count] ) + DUP2 ORA ?&found POP2 ( offset [-count] ) - LDAk #0a EQU ,&newline JCN - ,&count-tabs JSR - #0001 ,&next JMP ( offset n [-count] ) + LDAk #0a EQU ?&newline + draw-matches/count-tabs + #0001 !&next ( offset n [-count] ) &found ( offset mlim [-count] ) STH2k ( offset mlim [mlim -count] ) OVR2 SWP2 ,&x LDR2 ,&y LDR2 ( offset offset mlim x y [mlim -count] ) - ;draw-region JSR2 ( offset [mlim -count] ) + draw-region ( offset [mlim -count] ) STH2r ( offset mlim [-count] ) OVR2 SUB2 ( offset mlim-offset [-count] ) &next ( offset n [-count] ) DUP2 ,&x LDR2 ADD2 ,&x STR2 ( offset n [-count ) STH2k ( offset n [n -count] ) ADD2 ADD2r ( offset+n [n-count] ) - ,&loop JMP + !&loop &newline ( offset [-count] ) lmargin ,&x STR2 ,&y LDR2 INC2 ,&y STR2 INC2 INC2r - ,&loop JMP + !&loop &done POP2 POP2r - ;emit-reset JSR2 + emit-reset &return JMP2r [ &x $2 &y $2 ] &count-tabs ( offset -> offset ) - LDAk #09 NEQ ,&count-tabs/done JCN + LDAk #09 NEQ ?&count-tabs/done ,&x LDR2 .config/tab-adjust LDZ2 ADD2 ,&x STR2 &count-tabs/done JMP2r @emit-tab ( -> ) #0000 .config/tab-width LDZ2 SUB2 LIT2r 2018 - &loop ORAk ,&next JCN POP2 POP2r JMP2r - &next DEOkr INC2 ,&loop JMP + &loop ORAk ?&next POP2 POP2r JMP2r + &next DEOkr INC2 !&loop ( ANSI terminal notes ) @@ -1298,152 +1306,152 @@ ( ANSI control sequence to move the cursor to the given coord ) ( ESC [ $row ; $col H ) @term-move-cursor ( col* row* -> ) - ansi INC2 ( row+1 ) ;emit-dec2 JSR2 - emit-; INC2 ( col+1 ) ;emit-dec2 JSR2 + ansi INC2 ( row+1 ) emit-dec2 + emit-; INC2 ( col+1 ) emit-dec2 emit-H JMP2r ( ANSI control sequence to move N positions right ) ( ESC [ $n C ) @term-move-right ( n* -> ) - ansi ;emit-dec2 JSR2 emit-C JMP2r + ansi emit-dec2 emit-C JMP2r ( ANSI control sequence to get the cursor position ) ( ESC [ 6 n ) @term-get-cursor-position ( -> ) - LIT2 00 "n LIT "6 ,ansi-emit JMP + LIT2 00 "n LIT "6 !ansi-emit ( ANSI control sequence to erase entire screen ) ( ESC [ 2 J ) @term-erase-all ( -> ) - LIT2 00 "J LIT "2 ,ansi-emit JMP + LIT2 00 "J LIT "2 !ansi-emit ( ANSI control sequence to erase the current line ) ( ESC [ 2 K ) @term-erase-line ( -> ) - LIT2 00 "K LIT "2 ,ansi-emit JMP + LIT2 00 "K LIT "2 !ansi-emit @ansi-emit ( 00 cn ... c1 c0 -> ) LITr 18 ( Console/write ) #5b1b STHkr DEO STHkr DEO ( ESC [ ) - &loop DUP ,&next JCN POP POPr JMP2r - &next STHkr DEO ,&loop JMP + &loop DUP ?&next POP POPr JMP2r + &next STHkr DEO !&loop ( ESC [ 3 1 m ) @emit-red ( -> ) - LIT2 00 "m LIT2 "1 "3 ,ansi-emit JMP + LIT2 00 "m .config/red LDZ2 !ansi-emit ( ESC [ 0 m ) @emit-reset ( -> ) - #00 LIT2 "m "0 ,ansi-emit JMP + #00 LIT2 "m "0 !ansi-emit ( ESC [ 1 m $ ESC [ 0 m ) @emit-red-dollar ( -> ) - ,emit-red JSR emit-$ ,emit-reset JMP + emit-red emit-$ !emit-reset ( ESC [ 3 $x ; 7 m ) ( $x is 0-7 ) @emit-color-reverse ( -> ) - LIT2 00 "m LIT2 "7 "; .config/color LDZ2 ,ansi-emit JMP + LIT2 00 "m LIT2 "7 "; .config/color LDZ2 !ansi-emit @emit-color ( -> ) - LIT2 00 "m .config/color LDZ2 ,ansi-emit JMP + LIT2 00 "m .config/color LDZ2 !ansi-emit ( ESC [ 3 $x ; 1 m ) ( $x is 0-7 ) @emit-color-bold ( -> ) - LIT2 00 "m LIT2 "1 "; .config/color LDZ2 ,ansi-emit JMP + LIT2 00 "m LIT2 "1 "; .config/color LDZ2 !ansi-emit ( ESC [ 3 $x ; 1 ; 7 m ) ( $x is 0-7 ) @emit-color-reverse-bold ( -> ) - LIT2 00 "m LIT2 "7 "; LIT2 "1 "; .config/color LDZ2 ,ansi-emit JMP + LIT2 00 "m LIT2 "7 "; LIT2 "1 "; .config/color LDZ2 !ansi-emit @draw-all ( -> ) - ;term-erase-all JSR2 - #0000 #0000 ;term-move-cursor JSR2 + term-erase-all + #0000 #0000 term-move-cursor .buffer/line-offset LDZ2 STH2 LIT2r 0001 ( [k line-offset] ) .buffer/offset LDZ2 &bol - ADD2kr STH2r ;draw-linenum JSR2 + ADD2kr STH2r draw-linenum lmargin INC2 ,&x STR2 &loop ( offset [k line-offset] ) - LDAk #00 EQU ,&eof JCN - LDAk #0a EQU ,&eol JCN + LDAk #00 EQU ?&eof + LDAk #0a EQU ?&eol ,&x LDR2 .term/cols LDZ2 - LTH2k ,&ok JCN - GTH2 ,&skip JCN - ;emit-red-dollar JSR2 ,&x LDR2 INC2 ,&x STR2 + LTH2k ?&ok + GTH2 ?&skip + emit-red-dollar ,&x LDR2 INC2 ,&x STR2 &skip INC2 - ,&loop JMP + !&loop &ok POP2 POP2 - LDAk #09 EQU ,&do-tab JCN + LDAk #09 EQU ?&do-tab LDAk emit INC2 ,&x LDR2 INC2 ,&x STR2 - ,&loop JMP + !&loop &eol INC2r - STH2kr .term/rows LDZ2 GTH2 ,&done JCN - crlf INC2 ,&bol JMP - &do-tab ;emit-tab JSR2 INC2 + STH2kr .term/rows LDZ2 GTH2 ?&done + crlf INC2 !&bol + &do-tab emit-tab INC2 .config/tab-width LDZ2 ,&x LDR2 ADD2 ,&x STR2 - ,&loop JMP + !&loop [ &x $2 ] &eof - ;emit-red JSR2 + emit-red &eof-loop - STH2kr .term/rows LDZ2 GTH2 ,&done JCN + STH2kr .term/rows LDZ2 GTH2 ?&done crlf - lmargin ;term-move-right JSR2 + lmargin term-move-right emit-~ INC2r - ,&eof-loop JMP + !&eof-loop &done POP2 POP2r POP2r - ;emit-reset JSR2 - ;draw-matches JSR2 - ;draw-statusbar JSR2 - ;draw-prompt JSR2 - ;draw-cursor JMP2 + emit-reset + draw-matches + draw-statusbar + draw-prompt + !draw-cursor ( handler completion code to do necessary drawing and BRK ) @return ( -> ) .state/redraw LDZ - DUP #10 AND ,&draw-all JCN - DUP #08 AND ,&do-8 JCN ,&skip-8 JMP &do-8 ;draw-matches JSR2 - &skip-8 DUP #04 AND ,&do-4 JCN ,&skip-4 JMP &do-4 ;draw-prompt JSR2 - &skip-4 DUP #02 AND ,&do-2 JCN ,&skip-2 JMP &do-2 ;draw-statusbar JSR2 - &skip-2 DUP #01 AND ,&do-1 JCN ,&finish JMP &do-1 ;draw-cursor JSR2 ,&finish JMP - &draw-all ;draw-all JSR2 + DUP #10 AND ?&draw-all + DUP #08 AND ?&do-8 !&skip-8 &do-8 draw-matches + &skip-8 DUP #04 AND ?&do-4 !&skip-4 &do-4 draw-prompt + &skip-4 DUP #02 AND ?&do-2 !&skip-2 &do-2 draw-statusbar + &skip-2 DUP #01 AND ?&do-1 !&finish &do-1 draw-cursor !&finish + &draw-all draw-all &finish POP #00 .state/redraw STZ BRK @str-copy ( src* dst* -> len* ) STH2 DUP2 ( src src [dst] ) - &loop LDAk #00 EQU ,&done JCN + &loop LDAk #00 EQU ?&done LDAk STH2kr STA - INC2 INC2r ,&loop JMP + INC2 INC2r !&loop &done ( src src+n [dst+n] ) SWP2 SUB2 #00 STH2r STA JMP2r @print ( s* -> ) - &loop LDAk #00 EQU ,&eof JCN - LDAk #18 DEO INC2 ,&loop JMP + &loop LDAk #00 EQU ?&eof + LDAk #18 DEO INC2 !&loop &eof POP2 JMP2r @cur-len ( -> n* ) - ;cur-line JSR2 ;line-len JMP2 + cur-line !line-len @line-len ( s* -> n* ) #0000 STH2 - &loop LDAk #00 EQU ,&end JCN - LDAk #0a EQU ,&end JCN - INC2 INC2r ,&loop JMP + &loop LDAk #00 EQU ?&end + LDAk #0a EQU ?&end + INC2 INC2r !&loop &end POP2 STH2r JMP2r @line-is-visible ( n* -> bool^ ) - .buffer/line-offset LDZ2 LTH2k ,&no JCN + .buffer/line-offset LDZ2 LTH2k ?&no .term/rows LDZ2 ADD2 LTH2 JMP2r &no POP2 POP2 #00 JMP2r @jump-to-pos ( s* -> ) - ;pos-to-logical-row-col JSR2 SWP2 ;move-to-coord JMP2 + pos-to-logical-row-col SWP2 !move-to-coord @pos-to-display-row-col ( s* -> row* col* ) .config/tab-width LDZ2 ;pos-to-row-col/tab-width STA2 !pos-to-row-col @@ -1456,19 +1464,19 @@ #0000 ,&col STR2 ;data &loop ( s pos ) - GTH2k #00 EQU ,&done JCN - LDAk #0a EQU ,&newline JCN - LDAk #09 EQU ,&tab JCN + GTH2k #00 EQU ?&done + LDAk #0a EQU ?&newline + LDAk #09 EQU ?&tab #0001 &inc ,&col LDR2 ADD2 ,&col STR2 - INC2 ,&loop JMP + INC2 !&loop &newline #0000 ,&col STR2 ,&row LDR2 INC2 ,&row STR2 - INC2 ,&loop JMP + INC2 !&loop &tab - LIT2 [ &tab-width $2 ] ,&inc JMP + LIT2 [ &tab-width $2 ] !&inc &done POP2 POP2 ,&row LDR2 ,&col LDR2 JMP2r @@ -1478,47 +1486,47 @@ @line-to-pos ( addr* y* -> s* ) #0000 SWP2 SUB2 STH2 ( addr [-y] ) &newline ( addr [-y] ) - STH2kr ORA ,&loop JCN ,&done JMP + STH2kr ORA ?&loop !&done &loop ( addr [-y] ) - LDAk #00 EQU ,¬-found JCN ( addr [-y] ) - LDAk #0a EQU ,&found JCN ( addr [-y] ) - INC2 ,&loop JMP ( addr+1 [-y] ) - &found INC2 INC2r ,&newline JMP + LDAk #00 EQU ?¬-found ( addr [-y] ) + LDAk #0a EQU ?&found ( addr [-y] ) + INC2 !&loop ( addr+1 [-y] ) + &found INC2 INC2r !&newline &done POP2r JMP2r ¬-found POP2 POP2r #0000 JMP2r ( find string pointer for absolute y coordinate ) @abs-line ( y* -> s* ) - ;data SWP2 ;line-to-pos JMP2 + ;data SWP2 !line-to-pos ( return a pointer to the current line ) @cur-line ( -> s* ) - .cursor/row LDZ2 .buffer/line-offset LDZ2 LTH2k ,&early JCN + .cursor/row LDZ2 .buffer/line-offset LDZ2 LTH2k ?&early ( if cursor/row is later than line-offset ) ( we can save some time by starting at ) ( buffer/offset instead of the beginning ) - SUB2 .buffer/offset LDZ2 SWP2 ;line-to-pos JMP2 + SUB2 .buffer/offset LDZ2 SWP2 !line-to-pos &early ( if cursor/row is earlier than line-offset ) ( we need to use the absolute y coordinate ) - POP2 ;abs-line JMP2 + POP2 !abs-line ( return a pointer to the current cursor position ) @cur-pos ( -> s* ) - ;cur-line JSR2 ;cur-col JSR2 ADD2 JMP2r + cur-line cur-col ADD2 JMP2r ( insert one character at the cursor position ) @shift-right ( c^ addr* -> ) #01 .state/modified STZ ROT STH ( addr [prev^] ) - ;last-pos JSR2 SWP2 ( last addr [prev^] ) - .state/in-undo LDZ ,&loop JCN - STH2k #00 STH2r ;u-push JSR2 - &loop LTH2k ,&done JCN ( last addr [prev^] ) + last-pos SWP2 ( last addr [prev^] ) + .state/in-undo LDZ ?&loop + STH2k #00 STH2r u-push + &loop LTH2k ?&done ( last addr [prev^] ) LDAk STH SWPr ( last addr [prev^ curr^] ) DUP2 STHr ( last addr addr prev^ [curr^] ) ROT ROT STA ( last addr [curr^] ) - INC2 ,&loop JMP ( last addr+1 [curr^] ) + INC2 !&loop ( last addr+1 [curr^] ) &done NIP2 DUP2 ( addr addr [prev^] ) STHr ROT ROT ( addr prev^ addr ) STA INC2 ( addr+1 ) @@ -1530,15 +1538,15 @@ ( TODO: change last/addr order and GTH -> LTH to remove hack ) @shift-left ( addr* -> ) #01 .state/modified STZ - ;last-pos JSR2 SWP2 ( last addr ) - .state/in-undo LDZ ,&loop JCN - STH2k ;cur-pos JSR2 LDA STH2r ;u-push JSR2 - &loop GTH2k ,&next JCN ( last addr ) - ,&done JMP ( last addr ) + last-pos SWP2 ( last addr ) + .state/in-undo LDZ ?&loop + STH2k cur-pos LDA STH2r u-push + &loop GTH2k ?&next ( last addr ) + !&done ( last addr ) &next DUP2 INC2 LDAk ( last addr addr+1 c1^ ) STH SWP2 STHr ( last addr+1 addr c1^ ) ROT ROT ( last addr+1 c1^ addr ) - STA ,&loop JMP ( last addr+1 ) + STA !&loop ( last addr+1 ) &done POP2 ( last ) .buffer/limit STZ2 ( ) #00 .buffer/limit LDZ2 STA ( ensure null termination ) @@ -1546,7 +1554,7 @@ ( current column in terms of bytes in buffer ) @cur-col ( -> col* ) - .cursor/col LDZ2 ;cur-len JSR2 ;min2 JMP2 + .cursor/col LDZ2 cur-len !min2 ( jump to the first line in the buffer ) @zero-row ( -> ) @@ -1564,11 +1572,11 @@ LITr 00 ( n [0] ) &read ( n [k] ) #000a DIV2k STH2k MUL2 SUB2 STH2r INCr ( n%10 n/10 [k+1] ) - DUP2 ORA ,&read JCN + DUP2 ORA ?&read 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 + STHkr ?&write POPr JMP2r ( emit a short as a decimal with leading spaces ) @@ -1576,12 +1584,12 @@ LITr 00 ( n [0] ) &read ( n [k] ) #000a DIV2k STH2k MUL2 SUB2 STH2r INCr ( n%10 n/10 [k+1] ) - STHkr #05 LTH ,&read JCN + STHkr #05 LTH ?&read POP2 ( top element was 0000 ) &write0 ( n0 n1 ... nk [k+1] ) - DUP2 ORA ,emit-dec2/write JCN + DUP2 ORA ?emit-dec2/write POP2 sp LITr 01 SUBr - STHkr ,&write0 JCN + STHkr ?&write0 POPr JMP2r ( various string constants used as messages for the user ) @@ -1630,19 +1638,19 @@ ( perform the undo action ) @undo ( -> ) #01 .state/in-undo STZ - ;undo-stack/pos LDA2 ;undo-stack/data EQU2 ,&noop JCN + ;undo-stack/pos LDA2 ;undo-stack/data EQU2 ?&noop ;undo-stack/pos LDA2 #0003 SUB2 DUP2 ;undo-stack/pos STA2 LDA2k STH2 ( pos [addr] ) INC2 INC2 LDA STH2r ( c addr ) - ;jump-to-pos JSR2 - DUP #00 EQU ,&delete JCN - DUP #0a EQU ,&newline JCN - DUP #09 EQU ,&tab JCN - ;insert JMP2 - &newline POP ;newline JMP2 - &tab POP ;insert-tab JMP2 - &delete POP ;delete JMP2 + jump-to-pos + DUP #00 EQU ?&delete + DUP #0a EQU ?&newline + DUP #09 EQU ?&tab + !insert + &newline POP !newline + &tab POP !insert-tab + &delete POP !delete &noop BRK ( free up space in the undo stack by evicting the oldest entry ) @@ -1650,15 +1658,15 @@ ;undo-stack/data STH2k #0003 ADD2 ( st+3 [st] ) &loop LDAk STH2kr STA INC2 INC2r - DUP2 ;undo-stack/pos LDA2 LTH2 ,&loop JCN + DUP2 ;undo-stack/pos LDA2 LTH2 ?&loop ;undo-stack/pos LDA2k #0003 SUB2 SWP2 STA2 POP2 POP2r JMP2r ( push a new item on the undo stack ) @u-push ( c^ addr* -> ) ;undo-stack/pos DUP2 LDA2 ( c^ addr* top* pos* ) - GTH2 ( c^ addr* top>pos^ ) ,&has-room JCN ( c^ addr* ) - ;u-free JSR2 + GTH2 ( c^ addr* top>pos^ ) ?&has-room ( c^ addr* ) + u-free &has-room ;undo-stack/pos LDA2 ( c^ addr* pos* ) STH2k ( c addr pos [pos] ) STA2 ( c [pos] ) diff --git a/fix16.tal b/fix16.tal index b6d6c91..33dcd02 100644 --- a/fix16.tal +++ b/fix16.tal @@ -361,6 +361,12 @@ 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 diff --git a/regex.tal b/regex.tal index 731ab95..e7c850b 100644 --- a/regex.tal +++ b/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,11 +771,11 @@ ( 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 ) @@ -810,10 +810,10 @@ #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-bot $400 @arena-top ( holds up to 1024 bytes ) @@ -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 diff --git a/term.tal b/term.tal index f536b48..d0289cf 100644 --- a/term.tal +++ b/term.tal @@ -172,7 +172,7 @@ @setup-debugging ( -> ) .debug LDZ ?&continue JMP2r &continue - #99 #010e DEO ( put 99 in wst so #010e DEO reliably logs ) +( #99 #010e DEO ) ( put 99 in wst so #010e DEO reliably logs ) ;debug-log .File1/name DEO2 #01 .File1/append DEO JMP2r diff --git a/test-fix16.py b/test-fix16.py index a8015fa..70ef6bd 100644 --- a/test-fix16.py +++ b/test-fix16.py @@ -10,7 +10,7 @@ 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'} +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 @@ -46,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)) @@ -178,32 +179,32 @@ def main(): 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) - 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'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)], u16, x16_sqrt, eq=releq) - test(p, trials, b's', [('x', p16)], u16, x16_sin, eq=sineq) - test(p, trials, b'c', [('x', p16)], u16, x16_cos, eq=sineq) - 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'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() diff --git a/wave.tal b/wave.tal index 0f18d3e..f96dfc5 100644 --- a/wave.tal +++ b/wave.tal @@ -38,6 +38,7 @@ ( |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 &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 @@ -45,7 +46,6 @@ @pos $2 @is-stereo $1 @is-8bit $1 - @bytes-per-ms $2 |0100 ;filename .pos STZ2 @@ -76,9 +76,9 @@ LIT2 =reload/resample STA2 ( ; save resample function ) LIT2r =reload/sft STAr ( ; save shift size ) #2274 .File/len DEO2 - #2274 ;len0 STA2 #2274 ;buf0 zero-buf-u8 - #2274 ;len1 STA2 #2274 ;buf1 zero-buf-u8 - !play0 + #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*] ) @@ -103,70 +103,84 @@ @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 #2274 EQU2 ?&end ( b-addr* read* ; if we read 0x2274 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 ( ) - #2274 SWP2 zero-buf-u8 ( ) - #2274 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 ADD 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 LITr 00 STH INC2 - LDAk LITr 00 STH 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 ) @bytes-to-millis ( samples* -> ms* ) #01b9 DIV2 #000a MUL2 JMP2r -@output ( len* addr* -> ) +@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 ) - #ff .Audio0/vol DEO ( ; <- play 100% volume ) + #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 ) @@ -176,6 +190,9 @@ ( end up with static, popping, or other problems. ) @filename $100 @header $2c -@len0 $2 @buf0 $2274 -@len1 $2 @buf1 $2274 +( @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 ]