diff --git a/boot.jim b/boot.jim index 7b334ac..da58d90 100755 Binary files a/boot.jim and b/boot.jim differ diff --git a/debug.jim b/debug.jim index 2fa93e3..8b03b7c 100755 Binary files a/debug.jim and b/debug.jim differ diff --git a/defs.jim b/defs.jim index 77009d4..69ac9fb 100755 Binary files a/defs.jim and b/defs.jim differ diff --git a/jazz2.sbi b/jazz2.sbi new file mode 100755 index 0000000..36fda4c Binary files /dev/null and b/jazz2.sbi differ diff --git a/jopl.c b/jopl.c index f83d596..c8d82f0 100755 --- a/jopl.c +++ b/jopl.c @@ -88,6 +88,17 @@ void f_dtextemitattr() { dtext_emitattr(dtext_attr); } +void f_poll_ser() { + static char line[128] = { 0 }; + + if (ser_getline(line)) { + PUSHS(line); + f_runstring("DBG send"); + f_taskloop(); + line[0] = '\0'; + } +} + void do_repl(char *exe) { adlib_init(); @@ -130,6 +141,7 @@ void do_repl(char *exe) { f_execcp(ontick); } } + f_poll_ser(); f_taskloop(); } } diff --git a/jopl.exe b/jopl.exe index 018a306..caa0ada 100755 Binary files a/jopl.exe and b/jopl.exe differ diff --git a/jopl.jim b/jopl.jim new file mode 100755 index 0000000..578785f Binary files /dev/null and b/jopl.jim differ diff --git a/jopl.jor b/jopl.jor index 403a02a..bb6b551 100755 --- a/jopl.jor +++ b/jopl.jor @@ -1,4 +1,6 @@ ' putc task-emit ! +:noname s" debug.jor" loadfile ; execute + s" jopl.log" open seekend fdeactivate const LOGFILE : emit-log fdeactivate LOGFILE factivate fputc fdeactivate drop factivate ; : quit LOGFILE factivate close _quit ; @@ -6,13 +8,20 @@ s" jopl.log" open seekend fdeactivate const LOGFILE : DBG :| ' seremit task-emit ! execute cr |; 0 task-emit preserving ; : DTYPE ' type DBG ; +: dorepl begin receive loadstring s" ok" type cr again ; : start-repl activate ' putc task-emit ! ' emit-log task-echo ! s" .:: J O P L ( jean OPL2 print loop) ::." type cr - begin receive loadstring s" ok" type cr again ; + dorepl ; task const REPL REPL start-repl +: start-dbg activate ' seremit task-emit ! + s" .:: J D B G ( jean debugger) ::." type cr + dorepl ; +task const DBG +DBG start-dbg + var voice var op @@ -48,12 +57,20 @@ var op >r r@ 4 + b@ r@ 3 + b@ r@ 2 + b@ r@ 1 + b@ - dup dup 5 + op1 readop op2 readop + array b, b, b, b, b, b, b, b, b, b, b, ; +: blank-instrument array 11 allot ; +: copy-instrument ( s d -- ) + 0 11 for over i + b@ over i + b! next drop drop ; +: loadinst ( p -- ) dup dup 5 + op1 readop op2 readop 10 + b@ ar-alg adlib! ; 0 0x01 0x10 0xf0 0x77 0 0x01 0x00 0xf0 0x77 0 instrument default +blank-instrument current +: current! current copy-instrument ; +: swap-op ( inst -- ) + 0 5 for dup ub@ over 5 + ub@ >r over 5 + b! > 0x03 & swap 2 << | 0x20 | ar-note adlib! ; @@ -76,23 +93,35 @@ array semitones : note dup 12 / 8 % swap 12 % cells semitones + @ 440 swap *r 0 stopkeys ! key-start begin @@ -265,16 +310,15 @@ var stopkeys 0x4f textattr ! :| stoponesc voicekeys ' setnote onkeynote - 41 key-pressed if 0xfd setnote then - 52 key-down if 0xf0 setnote then + ^~ key-pressed if 0xfd setnote then + ^. key-down if 0xf0 setnote then |; dokeys 0x1f textattr ! ; userword : jamkeys stoponesc voicekeys ' noteon onkeynote - 41 key-pressed if noteoff then - 88 key-pressed if rndinst then ; + ^~ key-pressed if noteoff then ; : jam ( todo: print? ) ' jamkeys dokeys ; userword @@ -316,10 +360,10 @@ defer onselect : key-menu ( -- redraw ) :| 0 ( redraw ) - 72 key-pressed if -1 change-selection then - 80 key-pressed if 1 change-selection then - 73 key-pressed if -10 page-selection then - 81 key-pressed if 10 page-selection then + ^UP key-pressed if -1 change-selection then + ^DOWN key-pressed if 1 change-selection then + ^PGUP key-pressed if -10 page-selection then + ^PGDN key-pressed if 10 page-selection then |; draw-menu ; : draw-filemenu ( glob -- ) @@ -333,14 +377,118 @@ defer onselect :| s" *.sbi" draw-filemenu :| jamkeys key-menu if s" *.sbi" draw-filemenu then - 28 key-pressed if 1 stopkeys ! then + ^ENTER key-pressed if 1 stopkeys ! then |; dokeys |; 66 1 13 menu-at ; userword -: dune ( -- ) s" dune" chdir inst s" .." chdir ; userword +: shift-from-mask ( mask -- shift ) + 0 swap begin dup 1 & not while 1 >> swap 1 + swap repeat drop ; + +: bf! ( v addr mask -- ) + >r dup ub@ r@ ~ & r ub@ r@ & > ; + +: poly! ( v [...] get set -- ) swap drop execute ; +: poly@ ( [...] get set -- v ) drop execute ; +: poly-bf ' bf@ ' bf! ; +: poly-noop ' 0 ' drop ; + +: bitfield ( byteoffset mask -- ) + create b, b, does> ( addr bf -- addr mask ) + >r r@ 1 + ub@ + ( l ) dup cell + swap @ if + @ ( link creation mode done; fetch the head ) + else ( make new link ) + here over @ , swap ! latest , + then ; +: endwordchain ( cp -- ) 2 cells + 1 swap ! ; +: linkedval ( link -- val ) cell + @ ; +: nth-linkedval ( link c -- val ) + begin dup while 1 - swap @ swap repeat drop linkedval ; + +wordchain opbits +4 0x80 bitfield @ampmod opbits +4 0x40 bitfield @vib opbits +4 0x20 bitfield @egtype opbits +4 0x10 bitfield @ksr opbits +4 0x0f bitfield @mod-freq-mult opbits +3 0xc0 bitfield @scaling-level opbits +3 0x3f bitfield @output-level opbits +2 0xf0 bitfield @attack opbits +2 0x0f bitfield @decay opbits +1 0xf0 bitfield @sustain opbits +1 0x0f bitfield @release opbits +0 0x03 bitfield @wave opbits +' opbits endwordchain + +array instreg ' ar-wave , ' ar-sr , ' ar-ad , ' ar-level , ' ar-flags , + +: c+op current op @ not if 5 + then ; + +: count-links 0 swap links each swap 1 + swap more ; +opbits count-links const #opbits + +wordchain algbits +10 0x0e bitfield @feedback algbits +10 0x01 bitfield @decay-alg algbits +' algbits endwordchain +algbits count-links const #algbits + +: lookup-nth-bitfield ( n inst link -- p mask ) +