recipe/rc2014: use core libs from blkfs

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

blk/358

@@ -1,16 +1,13 @@
-: ACIA$
+0x20 CONSTANT ACIABUFSZ
-    H@ DUP DUP ACIA( ! ACIAR> !
+
-    1+ ACIAW> !  ( write index starts one position later )
+( Points to ACIA buf )
-    ACIABUFSZ ALLOT
+: ACIA( [ ACIA_MEM 4 + LITN ] ;
-    H@ ACIA) !
+( Points to ACIA buf end )
-( setup ACIA
+: ACIA) [ ACIA_MEM 6 + LITN ] ;
-  CR7 (1) - Receive Interrupt enabled
+( Read buf pointer. Pre-inc )
-  CR6:5 (00) - RTS low, transmit interrupt disabled.
+: ACIAR> [ ACIA_MEM LITN ] ;
-  CR4:2 (101) - 8 bits + 1 stop bit
+( Write buf pointer. Post-inc )
-  CR1:0 (10) - Counter divide: 64 )
+: ACIAW> [ ACIA_MEM 2 + LITN ] ;
-    0b10010110 ACIA_CTL PC!
+( This means that if W> == R>, buffer is full.
-( setup interrupt )
+  If R>+1 == W>, buffer is empty. )
-    0xc3 0x4e RAM+ C!  ( c3==JP, 4e==INTJUMP )
+
-    ['] ~ACIA 0x4f RAM+ !
-    (im1)
-;

blk/359

@@ -1,14 +1,16 @@
-: KEY
+: ACIA$
-    ( inc then fetch )
+    H@ DUP DUP ACIA( ! ACIAR> !
-    ACIAR> @ 1+ DUP ACIA) @ = IF
+    1+ ACIAW> !  ( write index starts one position later )
-        DROP ACIA( @
+    ACIABUFSZ ALLOT
-    THEN
+    H@ ACIA) !
-
+( setup ACIA
-    ( As long as R> == W>-1, it means that buffer is empty )
+  CR7 (1) - Receive Interrupt enabled
-    BEGIN DUP ACIAW> @ = NOT UNTIL
+  CR6:5 (00) - RTS low, transmit interrupt disabled.
-
+  CR4:2 (101) - 8 bits + 1 stop bit
-    ACIAR> !
+  CR1:0 (10) - Counter divide: 64 )
-    ACIAR> @ C@
+    0b10010110 ACIA_CTL PC!
+( setup interrupt )
+    0xc3 0x4e RAM+ C!  ( c3==JP, 4e==INTJUMP )
+    ['] ~ACIA 0x4f RAM+ !
+    (im1)
 ;
-
-

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!
 ;
-

forth/blk.fs

@@ -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  ( C<? )
-    0x2e RAM+ @ >R  ( 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<? )
-    INTERPRET
-    R> 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 ;

forth/cmp.fs

@@ -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 )
-' = _| |=
-' = _& &=
-' > _| |>
-' > _& &>
-' < _| |<
-' < _& &<

forth/core.fs

@@ -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 ;

forth/fmt.fs

@@ -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
-;

forth/parse.fs

@@ -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*) !

forth/print.fs

@@ -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 ;

recipes/rc2014/Makefile

@@ -5,15 +5,7 @@ EDIR = $(BASEDIR)/emul
 STAGE2 = $(EDIR)/stage2
 EMUL = $(BASEDIR)/emul/hw/rc2014/classic
 
-PATHS = \
+PATHS = $(FDIR)/link.fs run.fs
-	$(FDIR)/core.fs \
-	$(FDIR)/cmp.fs \
-	$(FDIR)/parse.fs \
-	$(BASEDIR)/drv/acia.fs \
-	$(FDIR)/print.fs \
-	$(FDIR)/fmt.fs \
-	$(FDIR)/link.fs \
-	run.fs
 STRIPFC = $(BASEDIR)/tools/stripfc
 
 .PHONY: all

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!