From 4d8574c1fec4956a7d905b6798b2e15daeec59f0 Mon Sep 17 00:00:00 2001 From: Virgil Dupras Date: Sun, 26 Apr 2020 13:57:44 -0400 Subject: [PATCH] recipe/rc2014: use core libs from blkfs --- blk/357 | 13 --- blk/358 | 29 +++--- blk/359 | 28 +++--- blk/360 | 11 ++- forth/blk.fs | 95 ------------------- forth/cmp.fs | 42 --------- forth/core.fs | 203 ---------------------------------------- forth/fmt.fs | 73 --------------- forth/parse.fs | 76 --------------- forth/print.fs | 38 -------- recipes/rc2014/Makefile | 10 +- recipes/rc2014/xcomp.fs | 5 + 12 files changed, 44 insertions(+), 579 deletions(-) delete mode 100644 forth/blk.fs delete mode 100644 forth/cmp.fs delete mode 100644 forth/core.fs delete mode 100644 forth/fmt.fs delete mode 100644 forth/parse.fs delete mode 100644 forth/print.fs diff --git a/blk/357 b/blk/357 index 8d2e723..2915f14 100644 --- a/blk/357 +++ b/blk/357 @@ -1,14 +1 @@ -0x20 CONSTANT ACIABUFSZ - -( Points to ACIA buf ) -: ACIA( [ ACIA_MEM 4 + LITN ] ; -( Points to ACIA buf end ) -: ACIA) [ ACIA_MEM 6 + LITN ] ; -( Read buf pointer. Pre-inc ) -: ACIAR> [ ACIA_MEM LITN ] ; -( Write buf pointer. Post-inc ) -: ACIAW> [ ACIA_MEM 2 + LITN ] ; -( This means that if W> == R>, buffer is full. - If R>+1 == W>, buffer is empty. ) - 358 360 LOADR diff --git a/blk/358 b/blk/358 index ec8e5c9..7399fb7 100644 --- a/blk/358 +++ b/blk/358 @@ -1,16 +1,13 @@ -: ACIA$ - H@ DUP DUP ACIA( ! ACIAR> ! - 1+ ACIAW> ! ( write index starts one position later ) - ACIABUFSZ ALLOT - H@ ACIA) ! -( setup ACIA - CR7 (1) - Receive Interrupt enabled - CR6:5 (00) - RTS low, transmit interrupt disabled. - CR4:2 (101) - 8 bits + 1 stop bit - CR1:0 (10) - Counter divide: 64 ) - 0b10010110 ACIA_CTL PC! -( setup interrupt ) - 0xc3 0x4e RAM+ C! ( c3==JP, 4e==INTJUMP ) - ['] ~ACIA 0x4f RAM+ ! - (im1) -; +0x20 CONSTANT ACIABUFSZ + +( Points to ACIA buf ) +: ACIA( [ ACIA_MEM 4 + LITN ] ; +( Points to ACIA buf end ) +: ACIA) [ ACIA_MEM 6 + LITN ] ; +( Read buf pointer. Pre-inc ) +: ACIAR> [ ACIA_MEM LITN ] ; +( Write buf pointer. Post-inc ) +: ACIAW> [ ACIA_MEM 2 + LITN ] ; +( This means that if W> == R>, buffer is full. + If R>+1 == W>, buffer is empty. ) + diff --git a/blk/359 b/blk/359 index 7fe518d..ec8e5c9 100644 --- a/blk/359 +++ b/blk/359 @@ -1,14 +1,16 @@ -: KEY - ( inc then fetch ) - ACIAR> @ 1+ DUP ACIA) @ = IF - DROP ACIA( @ - THEN - - ( As long as R> == W>-1, it means that buffer is empty ) - BEGIN DUP ACIAW> @ = NOT UNTIL - - ACIAR> ! - ACIAR> @ C@ +: ACIA$ + H@ DUP DUP ACIA( ! ACIAR> ! + 1+ ACIAW> ! ( write index starts one position later ) + ACIABUFSZ ALLOT + H@ ACIA) ! +( setup ACIA + CR7 (1) - Receive Interrupt enabled + CR6:5 (00) - RTS low, transmit interrupt disabled. + CR4:2 (101) - 8 bits + 1 stop bit + CR1:0 (10) - Counter divide: 64 ) + 0b10010110 ACIA_CTL PC! +( setup interrupt ) + 0xc3 0x4e RAM+ C! ( c3==JP, 4e==INTJUMP ) + ['] ~ACIA 0x4f RAM+ ! + (im1) ; - - diff --git a/blk/360 b/blk/360 index 63c84af..6be060e 100644 --- a/blk/360 +++ b/blk/360 @@ -1,7 +1,16 @@ +: KEY + ( inc then fetch ) + ACIAR> @ 1+ DUP ACIA) @ = IF + DROP ACIA( @ + THEN + ( As long as R> == W>-1, it means that buffer is empty ) + BEGIN DUP ACIAW> @ = NOT UNTIL + ACIAR> ! + ACIAR> @ C@ +; : EMIT ( As long at CTL bit 1 is low, we are transmitting. wait ) BEGIN ACIA_CTL PC@ 0x02 AND UNTIL ( The way is clear, go! ) ACIA_IO PC! ; - diff --git a/forth/blk.fs b/forth/blk.fs deleted file mode 100644 index 365b98e..0000000 --- a/forth/blk.fs +++ /dev/null @@ -1,95 +0,0 @@ -( I/O blocks ) - -: BLKMEM+ 0x57 RAM+ @ + ; -( n -- Fetches block n and write it to BLK( ) -: BLK@* 0 BLKMEM+ ; -( n -- Write back BLK( to storage at block n ) -: BLK!* 2 BLKMEM+ ; -( Current blk pointer in ( ) -: BLK> 4 BLKMEM+ ; -( Whether buffer is dirty ) -: BLKDTY 6 BLKMEM+ ; -: BLK( 8 BLKMEM+ ; - -: BLK$ - H@ 0x57 RAM+ ! - ( 1024 for the block, 8 for variables ) - 1032 ALLOT - ( LOAD detects end of block with ASCII EOT. This is why - we write it there. EOT == 0x04 ) - 4 C, - 0 BLKDTY ! - -1 BLK> ! -; - -( -- ) -: BLK! - BLK> @ BLK!* @ EXECUTE - 0 BLKDTY ! -; - -( n -- ) -: BLK@ - DUP BLK> @ = IF DROP EXIT THEN - BLKDTY @ IF BLK! THEN - DUP BLK> ! BLK@* @ EXECUTE -; - -: BLK!! 1 BLKDTY ! ; - -: .2 DUP 10 < IF SPC THEN . ; - -: LIST - BLK@ - 16 0 DO - I 1+ .2 SPC - 64 I * BLK( + (print) - CRLF - LOOP -; - -: _ - (boot<) - DUP 4 = IF - ( We drop our char, but also "a" from WORD: it won't - have the opportunity to balance PSP because we're - EXIT!ing. ) - 2DROP - ( We're finished interpreting ) - EXIT! - THEN -; - -: LOAD - ( save restorable variables to RSP ) - BLK> @ >R - 0x08 RAM+ @ >R - 0x06 RAM+ @ >R ( CR ( boot ptr ) - BLK@ - ( Point to beginning of BLK ) - BLK( 0x2e RAM+ ! - ( 08 == C<* override ) - ['] _ 0x08 RAM+ ! - ( While we interpret, don't print "ok" after every word ) - 1 0x06 RAM+ ! ( 06 == C 0x2e RAM+ ! - R> 0x06 RAM+ ! - ( Before we restore C<* are we restoring it to "_"? - if yes, it means we're in a nested LOAD which means we - should also load back the saved BLK>. Otherwise, we can - ignore the BLK> from RSP. ) - I 0x08 RAM+ @ = IF - ( nested load ) - R> DROP ( C<* ) - R> BLK@ - ELSE - ( not nested ) - R> 0x08 RAM+ ! - R> DROP ( BLK> ) - THEN -; - -( b1 b2 -- ) -: LOADR 1+ SWAP DO I DUP . CRLF LOAD LOOP ; diff --git a/forth/cmp.fs b/forth/cmp.fs deleted file mode 100644 index eecad15..0000000 --- a/forth/cmp.fs +++ /dev/null @@ -1,42 +0,0 @@ -( Words useful for complex comparison operations ) - -: >= < NOT ; -: <= > NOT ; -: 0>= 0< NOT ; - -( n1 -- n1 true ) -: <>{ 1 ; - -( n1 f -- f ) -: <>} SWAP DROP ; - - -: _|& - ( n1 n2 cell ) - >R >R DUP R> R> ( n1 n1 n2 cell ) - @ EXECUTE ( n1 f ) -; - -( n1 f n2 -- n1 f ) -: _| - CREATE , DOES> - ( n1 f n2 cell ) - ROT IF 2DROP 1 EXIT THEN ( n1 true ) - _|& -; - -: _& - CREATE , DOES> - ( n1 f n2 cell ) - ROT NOT IF 2DROP 0 EXIT THEN ( n1 true ) - _|& -; - -( All words below have this signature: - n1 f n2 -- n1 f ) -' = _| |= -' = _& &= -' > _| |> -' > _& &> -' < _| |< -' < _& &< diff --git a/forth/core.fs b/forth/core.fs deleted file mode 100644 index fc98f78..0000000 --- a/forth/core.fs +++ /dev/null @@ -1,203 +0,0 @@ -: H@ HERE @ ; -: IMMEDIATE - CURRENT @ 1- - DUP C@ 128 OR SWAP C! -; -: [ INTERPRET ; IMMEDIATE -: ] R> DROP ; -: LITS 34 , SCPY ; -: LIT< WORD LITS ; IMMEDIATE -: LITA 36 , , ; -: ' - WORD (find) (?br) [ 4 , ] EXIT - LIT< (wnf) (find) DROP EXECUTE -; -: ['] ' LITA ; IMMEDIATE -: COMPILE ' LITA ['] , , ; IMMEDIATE -: [COMPILE] ' , ; IMMEDIATE -: BEGIN H@ ; IMMEDIATE -: AGAIN COMPILE (br) H@ - , ; IMMEDIATE -: UNTIL COMPILE (?br) H@ - , ; IMMEDIATE -: _ BEGIN LIT< ) WORD S= UNTIL ; IMMEDIATE -40 CURRENT @ 4 - C! -( Hello, hello, krkrkrkr... do you hear me? - Ah, voice at last! Some lines above need comments - BTW: Forth lines limited to 64 cols because of default - input buffer size in Collapse OS - - "_": words starting with "_" are meant to be "private", - that is, only used by their immediate surrondings. - - 40 is ASCII for '('. We do this to simplify XPACK's task of - not mistakenly consider '(' definition as a comment. - LITS: 34 == litWord - LITA: 36 == addrWord - COMPILE: Tough one. Get addr of caller word (example above - (br)) and then call LITA on it. ) - -: +! SWAP OVER @ + SWAP ! ; -: -^ SWAP - ; -: ALLOT HERE +! ; - -: IF ( -- a | a: br cell addr ) - COMPILE (?br) - H@ ( push a ) - 2 ALLOT ( br cell allot ) -; IMMEDIATE - -: THEN ( a -- | a: br cell addr ) - DUP H@ -^ SWAP ( a-H a ) - ! -; IMMEDIATE - -: ELSE ( a1 -- a2 | a1: IF cell a2: ELSE cell ) - COMPILE (br) - 2 ALLOT - DUP H@ -^ SWAP ( a-H a ) - ! - H@ 2- ( push a. -2 for allot offset ) -; IMMEDIATE - -( During a CASE, the stack grows by 1 at each ENDOF so that - we can fill all those ENDOF branching addrs. So that we - know when to stop, we put a 0 on PSP. That's our stopgap. ) -: CASE 0 COMPILE >R ; IMMEDIATE -: OF - COMPILE I COMPILE = - [COMPILE] IF -; IMMEDIATE -: ENDOF [COMPILE] ELSE ; IMMEDIATE - -( At this point, we have something like "0 e1 e2 e3 val". We - want top drop val, and then call THEN as long as we don't - hit 0. ) -: ENDCASE - BEGIN - DUP NOT IF - DROP COMPILE R> COMPILE DROP EXIT - THEN - [COMPILE] THEN - AGAIN -; IMMEDIATE - -: CREATE - (entry) ( empty header with name ) - 11 ( 11 == cellWord ) - C, ( write it ) -; - -( We run this when we're in an entry creation context. Many - things we need to do. - 1. Change the code link to doesWord - 2. Leave 2 bytes for regular cell variable. - 3. Write down RS' RTOS to entry. - 4. exit parent definition -) -: DOES> - ( Overwrite cellWord in CURRENT ) - ( 43 == doesWord ) - 43 CURRENT @ C! - ( When we have a DOES>, we forcefully place HERE to 4 - bytes after CURRENT. This allows a DOES word to use "," - and "C," without messing everything up. ) - CURRENT @ 3 + HERE ! - ( HERE points to where we should write R> ) - R> , - ( We're done. Because we've popped RS, we'll exit parent - definition ) -; - -: VARIABLE CREATE 2 ALLOT ; -: CONSTANT CREATE , DOES> @ ; -: / /MOD SWAP DROP ; -: MOD /MOD DROP ; - -( In addition to pushing H@ this compiles 2 >R so that loop - variables are sent to PS at runtime ) -: DO - COMPILE SWAP COMPILE >R COMPILE >R - H@ -; IMMEDIATE - -( Increase loop counter and returns whether we should loop. ) -: _ - R> ( IP, keep for later ) - R> 1+ ( ip i+1 ) - DUP >R ( ip i ) - I' = ( ip f ) - SWAP >R ( f ) -; - -( One could think that we should have a sub word to avoid all - these COMPILE, but we can't because otherwise it messes with - the RS ) -: LOOP - COMPILE _ COMPILE (?br) - H@ - , - COMPILE R> COMPILE DROP COMPILE R> COMPILE DROP -; IMMEDIATE - -: LEAVE R> R> DROP I 1- >R >R ; - -: ROLL - DUP NOT IF EXIT THEN - 1+ DUP PICK ( n val ) - SWAP 2 * (roll) ( val ) - SWAP DROP -; - -: 2DUP OVER OVER ; -: 2OVER 3 PICK 3 PICK ; -: 2SWAP 3 ROLL 3 ROLL ; - -( a1 a2 u -- ) -: MOVE - ( u ) 0 DO - SWAP DUP I + C@ ( a2 a1 x ) - ROT SWAP OVER I + ( a1 a2 x a2 ) - C! ( a1 a2 ) - LOOP - 2DROP -; - -: DELW - 1- 0 SWAP C! -; - -: PREV - 3 - DUP @ ( a o ) - - ( a-o ) -; - -: WORD( - DUP 1- C@ ( name len field ) - 127 AND ( 0x7f. remove IMMEDIATE flag ) - 3 + ( fixed header len ) - - -; - -: FORGET - ' DUP ( w w ) - ( HERE must be at the end of prev's word, that is, at the - beginning of w. ) - WORD( HERE ! ( w ) - PREV CURRENT ! -; - -: EMPTY - LIT< _sys (find) NOT IF ABORT THEN - DUP HERE ! CURRENT ! -; - -( Drop RSP until I-2 == INTERPRET. ) -: EXIT! - ['] INTERPRET ( I ) - BEGIN ( I ) - DUP ( I I ) - R> DROP I 2- @ ( I I a ) - = UNTIL - DROP -; - -( a -- a+1 c ) -: C@+ DUP C@ SWAP 1+ SWAP ; diff --git a/forth/fmt.fs b/forth/fmt.fs deleted file mode 100644 index ad42f0c..0000000 --- a/forth/fmt.fs +++ /dev/null @@ -1,73 +0,0 @@ -( requires core, parse, cmp ) - -: _ - 999 SWAP ( stop indicator ) - DUP 0 = IF '0' EXIT THEN ( 0 is a special case ) - BEGIN - DUP 0 = IF DROP EXIT THEN - 10 /MOD ( r q ) - SWAP '0' + SWAP ( d q ) - AGAIN -; - -: . ( n -- ) - ( handle negative ) - DUP 0< IF '-' EMIT -1 * THEN - _ - BEGIN - DUP '9' > IF DROP EXIT THEN ( stop indicator, we're done ) - EMIT - AGAIN -; - -: ? @ . ; - -: _ - DUP 9 > IF 10 - 'a' + - ELSE '0' + THEN -; - -( For hex display, there are no negatives ) - -: .x - 256 MOD ( ensure < 0x100 ) - 16 /MOD ( l h ) - _ EMIT ( l ) - _ EMIT -; - -: .X - 256 /MOD ( l h ) - .x .x -; - -( a -- a+8 ) -: _ - DUP ( save for 2nd loop ) - ':' EMIT DUP .x SPC - 4 0 DO - DUP @ - 256 /MOD SWAP - .x .x - SPC - 2+ - LOOP - DROP - 8 0 DO - C@+ - DUP <>{ 0x20 &< 0x7e |> <>} - IF DROP '.' THEN - EMIT - LOOP - CRLF -; - -( n a -- ) -: DUMP - LF - BEGIN - OVER 1 < IF 2DROP EXIT THEN - _ - SWAP 8 - SWAP - AGAIN -; diff --git a/forth/parse.fs b/forth/parse.fs deleted file mode 100644 index 9e9d631..0000000 --- a/forth/parse.fs +++ /dev/null @@ -1,76 +0,0 @@ -( requires core, str ) -( string being sent to parse routines are always null - terminated ) - -: (parsec) ( a -- n f ) - ( apostrophe is ASCII 39 ) - DUP C@ 39 = NOT IF 0 EXIT THEN ( a 0 ) - DUP 2+ C@ 39 = NOT IF 0 EXIT THEN ( a 0 ) - ( surrounded by apos, good, return ) - 1+ C@ 1 ( n 1 ) -; - -( returns negative value on error ) -: _ ( c -- n ) - ( '0' is ASCII 48 ) - 48 - - DUP 0< IF EXIT THEN ( bad ) - DUP 10 < IF EXIT THEN ( good ) - ( 'a' is ASCII 97. 59 = 97 - 48 ) - 49 - - DUP 0< IF EXIT THEN ( bad ) - DUP 6 < IF 10 + EXIT THEN ( good ) - ( bad ) - 255 - -; - -: (parseh) ( a -- n f ) - ( '0': ASCII 0x30 'x': 0x78 0x7830: 30768 ) - DUP @ 30768 = NOT IF 0 EXIT THEN ( a 0 ) - ( We have "0x" prefix ) - 2+ - 0 ( a r ) - BEGIN - SWAP C@+ ( r a+1 c ) - DUP NOT IF 2DROP 1 EXIT THEN ( r, 1 ) - _ ( r a n ) - DUP 0< IF ROT 2DROP 0 EXIT THEN ( a 0 ) - ROT 16 * + ( a r*16+n ) - AGAIN -; - -( returns negative value on error ) -: _ ( c -- n ) - ( '0' is ASCII 48 ) - 48 - - DUP 0< IF EXIT THEN ( bad ) - DUP 2 < IF EXIT THEN ( good ) - ( bad ) - 255 - -; - -: (parseb) ( a -- n f ) - ( '0': ASCII 0x30 'b': 0x62 0x6230: 25136 ) - DUP @ 25136 = NOT IF 0 EXIT THEN ( a 0 ) - ( We have "0b" prefix ) - 2+ - 0 ( a r ) - BEGIN - SWAP C@+ ( r a+1 c ) - DUP NOT IF 2DROP 1 EXIT THEN ( r 1 ) - _ ( r a n ) - DUP 0< IF ROT 2DROP 0 EXIT THEN ( a 0 ) - ROT 2 * + ( a r*2+n ) - AGAIN -; - -: (parse) ( a -- n ) - (parsec) IF EXIT THEN - (parseh) IF EXIT THEN - (parseb) IF EXIT THEN - (parsed) IF EXIT THEN - ( nothing works ) - LIT< (wnf) (find) IF EXECUTE ELSE ABORT THEN -; - -' (parse) (parse*) ! diff --git a/forth/print.fs b/forth/print.fs deleted file mode 100644 index 0989625..0000000 --- a/forth/print.fs +++ /dev/null @@ -1,38 +0,0 @@ -( Words allowing printing strings. Require core ) -( This used to be in core, but some drivers providing EMIT - are much much easier to write with access to core words, - and these words below need EMIT... ) - -: (print) - BEGIN - C@+ ( a+1 c ) - ( exit if null ) - DUP NOT IF 2DROP EXIT THEN - EMIT ( a ) - AGAIN -; - -: ," - BEGIN - C< - ( 34 is ASCII for " ) - DUP 34 = IF DROP EXIT THEN C, - AGAIN ; - -: ." - 34 , ( 34 == litWord ) ," 0 C, - COMPILE (print) -; IMMEDIATE - -: ABORT" [COMPILE] ." COMPILE ABORT ; IMMEDIATE - -: (uflw) ABORT" stack underflow" ; - -: BS 8 EMIT ; -: LF 10 EMIT ; -: CR 13 EMIT ; -: CRLF CR LF ; -: SPC 32 EMIT ; - -: (wnf) (print) SPC ABORT" word not found" ; -: (ok) SPC ." ok" CRLF ; diff --git a/recipes/rc2014/Makefile b/recipes/rc2014/Makefile index 0825dd6..8846423 100644 --- a/recipes/rc2014/Makefile +++ b/recipes/rc2014/Makefile @@ -5,15 +5,7 @@ EDIR = $(BASEDIR)/emul STAGE2 = $(EDIR)/stage2 EMUL = $(BASEDIR)/emul/hw/rc2014/classic -PATHS = \ - $(FDIR)/core.fs \ - $(FDIR)/cmp.fs \ - $(FDIR)/parse.fs \ - $(BASEDIR)/drv/acia.fs \ - $(FDIR)/print.fs \ - $(FDIR)/fmt.fs \ - $(FDIR)/link.fs \ - run.fs +PATHS = $(FDIR)/link.fs run.fs STRIPFC = $(BASEDIR)/tools/stripfc .PHONY: all diff --git a/recipes/rc2014/xcomp.fs b/recipes/rc2014/xcomp.fs index a3fbebe..6618429 100644 --- a/recipes/rc2014/xcomp.fs +++ b/recipes/rc2014/xcomp.fs @@ -24,4 +24,9 @@ H@ XOFF ! (entry) _ ( Update LATEST ) H@ XOFF @ - XOFF @ 8 + ! +422 441 XPACKR ( core cmp ) +446 452 XPACKR ( parse ) +358 360 XPACKR ( acia.fs ) +442 445 XPACKR ( print ) +459 463 XPACKR ( fmt ) H@ 256 /MOD 2 PC! 2 PC!