From adea75e50a6009110d2e114b43ab60adfe99b717 Mon Sep 17 00:00:00 2001 From: Virgil Dupras Date: Wed, 28 Oct 2020 15:02:06 -0400 Subject: [PATCH] Add alias and switch word types I'm pretty happy about how lightweight the implementation turns out to be. --- blk/263 | 1 + blk/270 | 3 +-- blk/287 | 3 +++ blk/289 | 3 ++- blk/355 | 2 ++ blk/380 | 2 +- blk/381 | 2 +- blk/394 | 5 +++-- blk/396 | 4 ++-- blk/397 | 17 +++-------------- blk/398 | 30 ++++++++++++++---------------- blk/399 | 29 ++++++++++++++++------------- blk/400 | 13 +++++++++++++ blk/449 | 17 +++++++++-------- cvm/avra.sh | 2 +- cvm/forth.bin | Bin 5275 -> 5289 bytes cvm/vm.c | 31 ++++++++++++++++++++++++------- cvm/zasm.sh | 2 +- doc/asm.txt | 5 +++++ doc/dict.txt | 4 ++++ doc/impl.txt | 9 +++++++-- doc/usage.txt | 40 ++++++++++++++++++++++++++++++++++++---- 22 files changed, 149 insertions(+), 75 deletions(-) create mode 100644 blk/400 diff --git a/blk/263 b/blk/263 index 24b3f1b..f6fb875 100644 --- a/blk/263 +++ b/blk/263 @@ -1,6 +1,7 @@ CREATE XCURRENT 0 , : XCON XCURRENT CURRENT* ! ; : XCOFF 0x02 RAM+ CURRENT* ! ; : (xentry) XCON (entry) XCOFF ; : XCREATE (xentry) 2 C, ; +: X:** (xentry) 5 C, , ; : XCODE XCON CODE XCOFF ; : XIMM XCON IMMEDIATE XCOFF ; : _xapply ( a -- a-off ) DUP ORG @ > IF ORG @ - BIN( @ + THEN ; diff --git a/blk/270 b/blk/270 index 64202a4..52b5ff4 100644 --- a/blk/270 +++ b/blk/270 @@ -7,8 +7,7 @@ : AGAIN XAGAIN ; IMMEDIATE : UNTIL XUNTIL ; IMMEDIATE : LIT" XLIT" ; IMMEDIATE : LITN XLITN ; : IMMEDIATE XIMM ; -: (entry) (xentry) ; -: CREATE XCREATE ; +: (entry) (xentry) ; : CREATE XCREATE ; : :** X:** ; : : [ ' X: , ] ; CURRENT @ XCURRENT ! diff --git a/blk/287 b/blk/287 index 69819b6..930a860 100644 --- a/blk/287 +++ b/blk/287 @@ -3,6 +3,9 @@ lblexec BSET L1 FSET ( B284 ) L2 FSET ( B286 ) LDA(DE), DE INCd, EXDEHL, ( HL points to PFA ) A ORr, IFZ, JP(HL), THEN, A DECr, ( compiled? ) IFNZ, ( no ) + 3 CPi, IFZ, ( alias ) LDDE(HL), JR, lblexec BWR THEN, + IFNC, ( switch ) + LDDE(HL), EXDEHL, LDDE(HL), JR, lblexec BWR THEN, ( cell or does. push PFA ) HL PUSH, A DECr, JRZ, lblnext BWR ( cell ) HL INCd, HL INCd, LDDE(HL), EXDEHL, ( does ) diff --git a/blk/289 b/blk/289 index 40e7ed7..6850943 100644 --- a/blk/289 +++ b/blk/289 @@ -1,4 +1,5 @@ -( 1. Push current IP to RS +( compiled word + 1. Push current IP to RS 2. Set new IP to the second atom of the list 3. Execute the first atom of the list. ) IX INCd, IX INCd, diff --git a/blk/355 b/blk/355 index de827db..434d27a 100644 --- a/blk/355 +++ b/blk/355 @@ -1,4 +1,6 @@ : +! TUCK @ + SWAP ! ; +: *! ( addr alias -- ) 1+ ! ; +: **! ( addr switch -- ) 1+ @ ! ; : / /MOD NIP ; : MOD /MOD DROP ; : ALLOT HERE +! ; diff --git a/blk/380 b/blk/380 index 1cc934d..171c335 100644 --- a/blk/380 +++ b/blk/380 @@ -1 +1 @@ -1 19 LOADR+ ( xcomp core high ) +1 20 LOADR+ ( xcomp core high ) diff --git a/blk/381 b/blk/381 index c3ddc8d..22419f5 100644 --- a/blk/381 +++ b/blk/381 @@ -4,7 +4,7 @@ : (print) C@+ ( a len ) 0 DO C@+ EMIT LOOP DROP ; : BS 8 EMIT ; : LF 10 EMIT ; : CR 13 EMIT ; : CRLF CR LF ; : SPC 32 EMIT ; -: NL 0x0a RAM+ @ ( NLPTR ) EXECUTE ; +0x0a RAM+ :** NL : (uflw) LIT" stack underflow" ERR ; XCURRENT @ _xapply ORG @ 0x06 ( stable ABI uflw ) + ! : (oflw) LIT" stack overflow" ERR ; diff --git a/blk/394 b/blk/394 index e3a1603..27c83a8 100644 --- a/blk/394 +++ b/blk/394 @@ -3,8 +3,9 @@ : LOADR 1+ SWAP DO I DUP . NL LOAD LOOP ; : LOADR+ BLK> @ + SWAP BLK> @ + SWAP LOADR ; ( Now, adev stuff ) -: A@* 0x3e RAM+ ; : A@ A@* @ EXECUTE ; -: A!* 0x40 RAM+ ; : A! A!* @ EXECUTE ; +0x3e RAM+ :** A@ +0x40 RAM+ :** A! + ( src dst u -- ) : AMOVE ( u ) 0 DO diff --git a/blk/396 b/blk/396 index dbf139e..aefaaa5 100644 --- a/blk/396 +++ b/blk/396 @@ -5,10 +5,10 @@ 0 0x08 RAM+ ! ( 08 == C<* override ) 0 0x53 RAM+ ! ( 53 == (emit) override ) 0 0x55 RAM+ ! ( 55 == (key) override ) - ['] CRLF 0x0a RAM+ ! ( NLPTR ) + ['] CRLF ['] NL **! ( 0c == C<* ) ['] (boot<) 0x0c RAM+ ! - ['] C@ A@* ! ['] C! A!* ! + ['] C@ ['] A@ ! ['] C! ['] A! **! ( boot< always has a char waiting. 06 == C IF LIT" br ovfl" (print) ABORT THEN ; -: DO COMPILE 2>R H@ ; IMMEDIATE -: LOOP COMPILE (loop) H@ - _bchk C, ; IMMEDIATE -( LEAVE is implemented in low xcomp ) -: LITN COMPILE (n) , ; -( gets its name at the very end. can't comment afterwards ) -: _ BEGIN LIT" )" WORD S= UNTIL ; IMMEDIATE -: _ ( : will get its name almost at the very end ) - (entry) 1 ( compiled ) C, - BEGIN - WORD DUP LIT" ;" S= IF DROP COMPILE EXIT EXIT THEN - FIND IF ( is word ) DUP IMMED? IF EXECUTE ELSE , THEN - ELSE ( maybe number ) (parse) LITN THEN - AGAIN ; +: :* ( addr -- ) (entry) 4 ( alias ) C, , ; +: :** ( addr -- ) (entry) 5 ( switch ) C, , ; + diff --git a/blk/398 b/blk/398 index 8afba32..e800a57 100644 --- a/blk/398 +++ b/blk/398 @@ -1,16 +1,14 @@ -: IF ( -- a | a: br cell addr ) - COMPILE (?br) H@ 1 ALLOT ( br cell allot ) -; IMMEDIATE -: THEN ( a -- | a: br cell addr ) - DUP H@ -^ _bchk SWAP ( a-H a ) C! -; IMMEDIATE -: ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell ) - COMPILE (br) - 1 ALLOT - [COMPILE] THEN - H@ 1- ( push a. 1- for allot offset ) -; IMMEDIATE -: LIT" - COMPILE (s) H@ 0 C, ," - DUP H@ -^ 1- ( a len ) SWAP C! -; IMMEDIATE +: _bchk DUP 0x7f + 0xff > IF LIT" br ovfl" (print) ABORT THEN ; +: DO COMPILE 2>R H@ ; IMMEDIATE +: LOOP COMPILE (loop) H@ - _bchk C, ; IMMEDIATE +( LEAVE is implemented in low xcomp ) +: LITN COMPILE (n) , ; +( gets its name at the very end. can't comment afterwards ) +: _ BEGIN LIT" )" WORD S= UNTIL ; IMMEDIATE +: _ ( : will get its name almost at the very end ) + (entry) 1 ( compiled ) C, + BEGIN + WORD DUP LIT" ;" S= IF DROP COMPILE EXIT EXIT THEN + FIND IF ( is word ) DUP IMMED? IF EXECUTE ELSE , THEN + ELSE ( maybe number ) (parse) LITN THEN + AGAIN ; diff --git a/blk/399 b/blk/399 index 6bc303f..8afba32 100644 --- a/blk/399 +++ b/blk/399 @@ -1,13 +1,16 @@ -( We don't use ." and ABORT in core, they're not xcomp-ed ) -: ." [COMPILE] LIT" COMPILE (print) ; IMMEDIATE -: ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE -: BEGIN H@ ; IMMEDIATE -: AGAIN COMPILE (br) H@ - _bchk C, ; IMMEDIATE -: UNTIL COMPILE (?br) H@ - _bchk C, ; IMMEDIATE -: [ INTERPRET ; IMMEDIATE -: ] R> DROP ; -: COMPILE ' LITN ['] , , ; IMMEDIATE -: [COMPILE] ' , ; IMMEDIATE -: ['] ' LITN ; IMMEDIATE -':' X' _ 4 - C! ( give : its name ) -'(' X' _ 4 - C! +: IF ( -- a | a: br cell addr ) + COMPILE (?br) H@ 1 ALLOT ( br cell allot ) +; IMMEDIATE +: THEN ( a -- | a: br cell addr ) + DUP H@ -^ _bchk SWAP ( a-H a ) C! +; IMMEDIATE +: ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell ) + COMPILE (br) + 1 ALLOT + [COMPILE] THEN + H@ 1- ( push a. 1- for allot offset ) +; IMMEDIATE +: LIT" + COMPILE (s) H@ 0 C, ," + DUP H@ -^ 1- ( a len ) SWAP C! +; IMMEDIATE diff --git a/blk/400 b/blk/400 new file mode 100644 index 0000000..6bc303f --- /dev/null +++ b/blk/400 @@ -0,0 +1,13 @@ +( We don't use ." and ABORT in core, they're not xcomp-ed ) +: ." [COMPILE] LIT" COMPILE (print) ; IMMEDIATE +: ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE +: BEGIN H@ ; IMMEDIATE +: AGAIN COMPILE (br) H@ - _bchk C, ; IMMEDIATE +: UNTIL COMPILE (?br) H@ - _bchk C, ; IMMEDIATE +: [ INTERPRET ; IMMEDIATE +: ] R> DROP ; +: COMPILE ' LITN ['] , , ; IMMEDIATE +: [COMPILE] ' , ; IMMEDIATE +: ['] ' LITN ; IMMEDIATE +':' X' _ 4 - C! ( give : its name ) +'(' X' _ 4 - C! diff --git a/blk/449 b/blk/449 index 2077e0b..094161d 100644 --- a/blk/449 +++ b/blk/449 @@ -1,14 +1,15 @@ lblexec BSET ( DI -> wordref ) AL [DI] MOVr[], DI INCx, ( PFA ) AL AL ORrr, IFZ, DI JMPr, THEN, ( native ) - AL DECr, IFNZ, ( cell or does ) - DI PUSHx, ( push PFA ) - AL DECr, IFZ, ( cell ) JMPs, lblnext @ RPCs, THEN, - ( does, see B302 ) - DI INCx, DI INCx, DI [DI] MOVx[], + AL DECr, IFNZ, ( not compiled ) + AL DECr, IFZ, ( cell ) + DI PUSHx, JMPs, lblnext @ RPCs, THEN, + AL DECr, IFZ, ( does ) + DI PUSHx, DI INCx, DI INCx, DI [DI] MOVx[], THEN, + ( alias or switch ) DI [DI] MOVx[], + AL DECr, IFNZ, ( switch ) DI [DI] MOVx[], THEN, + JMPs, lblexec @ RPCs, THEN, ( continue to compiled ) - ( compiled ) BP INCx, BP INCx, [BP] 0 DX MOV[]+x, ( pushRS ) DX DI MOVxx, DX INCx, DX INCx, ( --> IP ) - DI [DI] MOVx[], - JMPs, lblexec @ RPCs, + DI [DI] MOVx[], JMPs, lblexec @ RPCs, diff --git a/cvm/avra.sh b/cvm/avra.sh index 72b0d23..1f4ad2e 100755 --- a/cvm/avra.sh +++ b/cvm/avra.sh @@ -1,2 +1,2 @@ #!/bin/sh -echo -e "660 LOAD H@ ORG !\n$(cat -)\nORG @ 256 /MOD 2 PC! 2 PC! H@ 256 /MOD 2 PC! 2 PC! " | ./stage +echo -e "50 LOAD H@ ORG !\n$(cat -)\nORG @ 256 /MOD 2 PC! 2 PC! H@ 256 /MOD 2 PC! 2 PC! " | ./stage diff --git a/cvm/forth.bin b/cvm/forth.bin index 7f5efefd17f0adde4e3f4185f85da192f7e98bae..c8e06f861e33392b519d9501a8b0647fdca99e27 100644 GIT binary patch delta 1951 zcmYjSZERCz6h80mZSQUGZEruu2Idx6%jjC?8WR>q_hakr+R;+lrtK!O07V#K0V%L5 zAv3AcGC>nFe3R+oN9PZ-8eu_``9ldYvXCH>5Q&L@Oy=hg(Mb$qM6!6^+d*8?_B|i( zInR0CbI#uKf8cKd{4+T3%cu1dli;zBnl|z7K&t{AnI&$bLLks;0RswNT?|@ig5O~{ z$5-h4{4w$sZ82UWuhZ|1CyAF1n}*%HjX^M|aHH`vVA3V2A=T(D)64E2L4|z!sdTnq z0TZEQ3Iw4F8Q}rcp+HXv-oY8cO=i%G`8a^b^DH@qJ_R8N!d1A4raA-=lOWVVgHHIF z+~MjN;x`DwFEyAEL^6lB0)*W#T@>2DFhl=iAa1xkHF51k@k@zrQ;|49uUZa&}&v9l8uJ*Q7aa+ z->d-#tiYjgHXhcJQ5T4$q-!hmgt0`0JrNS(fCSy!&`M+HjWMC}Zjz;6|_uNBf zyO&^rcP+YipB=rc!2IuUK`>5%3W~%OZZe_=XavQmMl!AE!Uu?Fur7WrsarGvo|1EX zLTae{dskt>)8tc2o$iv{k|Nc>Be7_A>1nASfqyA&!EavPS3Zw-+K(O|JyP_)?Th29YMjhBqm53QRrC0+wNw2&*-qRc)jbnaNA0|(MVZd-3#RoG+0 z3oKR$BUjBm9eRes7*W zt!yO2^hKppsPM0H8jRCo)SvRtB?Ny%g?K6-&1SOEd;-ikA&o)_|A_b)#|F=I(}Yu5g1=1>;?jVtri2{%G8&=~KZYL&G%rdd2tyGqyjwcl3zA6H~^h z-5Dw0LQa?Do!COGD0!to#^xCZD>Z^pdfIO%!k+VZ4)4Yy%`dIOxo zdb7(=No)+Db(4$a<(}gq5ZqMN} zv)i4Xbq6rfCoUvfX28N)I-B=6V1j&$x@#QMY0-gr$_}Rq<0U*0j;AarG!k}m4~ZE} z<>Sd_-Oxb&&@k*oeqyw+JA^FAkbq-DK-pkK z%_4Rf0}CH-AQ@sh2Gpy7_`JGE-nIhUrDl|@YJv^2Y);*4ACQai2{W8)-H+8~sX+>( zinK`AL^ zwd16yMH5eTQ(tlwPG}~8%zeJur-3bkB6c`f5Y-Ty|F7l~R(UE-zjzzGH{i|;ZaB7)Q1J6bfVw>G< zO}u0QDs3@vnXrx$O`!+lZtnXcsH7I-vh+H*Z$MiM(It$7?7Dkn_YTJ&Lir|FvXgTl^wYVD`>8~SPXrRN2lVt;u;)!%t|B~5gwT%@C$ zid^+j3#UB1NsDdpHt6>~CfMOWBEq9fY|y&~)9jqLQ5ld=NhS=ko8C2JH}pZmo=Nps zm4rZ{!T1E^F1lzxczFx$&_!dK&?M1ZJ9S-ze$uTM+c+zB`}YF%^1T76td-1n=aW_% zoH$FDm-mhGvpsZ5{Q5brIp}T?82Gct_qxe4buHR)9hGf_~Z80uPt0&l$wxQbbW) z4&KBjzX9>~=t{w>O;m`BoL8g%5~t$TQC%3@OU7z$yihV$Lwsv)Thc>i`Id?_^De@3 z(*F+3+4$*G_PM{NW?7!ZAGyxo0>9qmY<*+*{)3T50@cJG`x869pgC*Ht@=#Rm(J@6 z3vWM4WrK7LO>hWHlka118suF^jvuLYroojsbl|}5!$Lf-4h@>zP4vz=nVTR zP&GE9&(r(Yk*kFhl%XGVrJ3YRF4yga0%=-=hF;GAf73E4D_cQaFo{*V!e6enI=qKz zz{srfHoY~E3~2EZ*Hg|(3@LoeWNYOX7iXeDQS?3$=>i3)Qe!aY7zWz6P7kvEn&WAp zPB5jjO`xIm6PigJkm>hfb23{-hzigweQmoEC{o`BBr`qqzH*#(EOV?RM(}H<)W6kP)RA{Emgb|$si<`N;RpW<~_$}$?C9X4*U8$@O#*xn@ z-W5+}H4;h%o2BK!^k%J8rcxM6sFw|W0h&(}d#QX?v{ii?SRPwnBDb|Wl}YZbgb%S* T<%Rm{cWUrH2~PuTtUUTZuhoOJ diff --git a/cvm/vm.c b/cvm/vm.c index a1195a5..3bc6aa0 100644 --- a/cvm/vm.c +++ b/cvm/vm.c @@ -109,19 +109,36 @@ static void pushRS(word val) { // dictionary (doc/dict.txt) static void execute(word wordref) { byte wtype = vm.mem[wordref]; - if (wtype == 0) { // native + switch (wtype) { + case 0: // native vm.nativew[vm.mem[wordref+1]](); - } else if (wtype == 1) { // compiled + break; + + case 1: // compiled pushRS(vm.IP); vm.IP = wordref+1; - } else { // cell or does + break; + + case 2: // cell push(wordref+1); - if (wtype == 3) { - pushRS(vm.IP); - vm.IP = gw(wordref+3); - } + break; + + case 3: // does + push(wordref+1); + pushRS(vm.IP); + vm.IP = gw(wordref+3); + break; + + case 4: // alias + execute(gw(wordref+1)); + break; + + case 5: // switch + execute(gw(gw(wordref+1))); + break; } } + static word find(word daddr, word waddr) { byte len = vm.mem[waddr]; while (1) { diff --git a/cvm/zasm.sh b/cvm/zasm.sh index 6ff130c..38179e8 100755 --- a/cvm/zasm.sh +++ b/cvm/zasm.sh @@ -1,2 +1,2 @@ #!/bin/sh -echo -e "212 LOAD\nH@ 256 /MOD 2 PC! 2 PC!\n$(cat -)\nH@ 256 /MOD 2 PC! 2 PC! " | ./stage +echo -e "5 LOAD\nH@ 256 /MOD 2 PC! 2 PC!\n$(cat -)\nH@ 256 /MOD 2 PC! 2 PC! " | ./stage diff --git a/doc/asm.txt b/doc/asm.txt index 08e850e..5d0ccfa 100644 --- a/doc/asm.txt +++ b/doc/asm.txt @@ -139,6 +139,11 @@ CALL RST DJNZ DI EI EXDEHL EXX HALT NOP RET [,c] RETI RETN SCF +Macros: + +SUBHLd PUSH [0,1,Z,A] HLZ DEZ +LDDE(HL) OUT [HL,DE] + # 8086 assembler Load with "30 LOAD". As with the Z80 assembler, it is incom- diff --git a/doc/dict.txt b/doc/dict.txt index ed89469..c30381e 100644 --- a/doc/dict.txt +++ b/doc/dict.txt @@ -64,6 +64,8 @@ WORD( a -- a Get wordref's beginning addr. # Defining words : x ... ; -- Define a new word +:* x a -- Define a new alias +:** x a -- Define a new switch CREATE x -- Create cell named x. Doesn't allocate a PF. [COMPILE] x -- *I* Compile word x and write it to HERE. IMMEDIATE words are *not* executed. @@ -157,6 +159,8 @@ C@- a -- a-1 c Fetch c from a and dec a. C! c a -- Store byte c in address a C!+ c a -- a+1 Store byte c in a and inc a. C!- c a -- a-1 Store byte c in a and dec a. +*! a al -- Change alias al's addr to a. +**! a sw -- Change switch sw's addr to a. CURRENT -- a Set a to wordref of last added entry. CURRENT* -- a A pointer to active CURRENT*. Useful when we have multiple active dicts. diff --git a/doc/impl.txt b/doc/impl.txt index 97113d0..11c019b 100644 --- a/doc/impl.txt +++ b/doc/impl.txt @@ -82,8 +82,8 @@ below. # Word types -There are 4 word types in Collapse OS. Whenever you have a -wordref, it's pointing to a byte with numbers 0 to 3. This +There are 6 word types in Collapse OS. Whenever you have a +wordref, it's pointing to a byte with numbers 0 to 5. This number is the word type and the word's behavior depends on it. 0: native. This words PFA contains native binary code and is @@ -102,6 +102,11 @@ compiled word. Upon execution, after having pushed its cell addr to PSP, it executes its reference exactly like a compiled word. +4: alias. See usage.txt. PFA is like a cell, but instead of +pushing it to PS, we execute it. + +5: switch. Same as alias, but with an added indirection. + # System variables There are some core variables in the core system that are diff --git a/doc/usage.txt b/doc/usage.txt index bea6278..f3d5eaa 100644 --- a/doc/usage.txt +++ b/doc/usage.txt @@ -52,12 +52,44 @@ Interpreter output is unbuffered and only has EMIT. This word can also be overriden, mostly as a companion to the raison d'etre of your KEY override. +# Aliases and Switches + +A common pattern in Forth is to add an indirection layer with +a pointer word. For example, if you have a word "FOO" for +which you would like to add an indirection layer, you would +rename "FOO" to "_FOO", add a variable "FOO*" pointing to +"_FOO" and re-defining "FOO" as ": FOO FOO* @ EXECUTE". + +This is all well and good, but it is resource intensive and +verbose, which make us want to avoid this pattern for words +that are often used. + +For this purpose, Collapse OS has two special word types: +alias and switches. + +An alias is a variable that contains a pointer to another word. +When invoked, we invoke the specified pointer with minimal over- +head. Using our FOO example above, we would create an alias +with "' _FOO :* FOO". Invoking FOO will then invoke "_FOO". You +can change the alias' pointer with "*!" like this: +"' BAR ' FOO *!". FOO now invokes BAR. + +A switch is like an alias, but with a second level of indi- +rection. The variable points to a cell pointing to our word. +It works like an alias, except you have to use ":**" and "**!". +Switches are used by core code which point to hardcoded +addresses in RAM (because the core code is designed to run from +ROM, we can't have regular variables). You are unlikely to +need switches in regular code. + # Addressed devices -A@ and A! are the indirect versions of C@ and C!. Their target -word is controlled through A@* and A!* and by default point to -C@ and C*. There is also a AMOVE word that is the same as MOVE -but using A@ and A!. +A@ and A! are the indirect versions of C@ and C!. They are +aliases and initially point to C@ and C!. There is also a AMOVE +word that is the same as MOVE but using A@ and A!. + +Addressed device words can be useful to "pipe" processing to +places outside of regular memory. # Disk blocks