Source of Afera (part 5: module names O-Z)

Description of the page content

Sixth part of the Afera library sources for Abersoft Forth.

Tags:

Source code

.( PICK )

\ pick.fsb
\ `PICK` for ZX Spectrum Abersoft Forth

\ Copyright (C) 1987,2015 Marcos Cruz (programandala.net)
\ Copyright (C) 1985 Edmund Ramm

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 1987-01-09: First version.
  \ 2015-03: Code included in the main file of the library.
  \ 2015-04-16: Code rewritten in Z80.
  \ 2015-05-02: Code moved to this file.

  \ -----------------------------------------------------------

CREATE PICK  ( u -- x )

  \ 1+ 2 * SP@ + @

  \ Adapted from the `PICK` written on 1985-05-07 by Edmund
  \ Ramm for the Z80 fig-Forth implementation written by Dennis
  \ L.  Wilson (1980-09-07).

  HEX
  E1 C, 29 C,          \ pop hl / add hl,hl
  39 C,                \ add hl,sp  ; offset into stack
  5E C, 23 C, 56 C,    \ ld e,(hl) / inc hl / ld d,(hl)
  EB C, C3 C, PUSHHL , \ ex de, hl / jp PUSHHL
  SMUDGE
  DECIMAL

  \ vim: filetype=abersoftforthafera


\ plot.fsb
\ Faster `PLOT` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)
\ Copyright (C) 1988 Lennart Benschop.

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-05-01: Start.
  \
  \ 2015-05-04: Adapted from Lennart Benschop's Spectrum
  \ Forth-83.  Benchmark: it runs in 84% the time of the
  \ original version. Change: Instead of creating a new word,
  \ the cfa of the original word is patched with the address of
  \ the new code.
  \
  \ 2015-05-06: New method: the original definition is
  \ overwritten with the new code. No space used.

  \ -----------------------------------------------------------

-->

.( Faster PLOT )

HEX  HERE ' PLOT  ( a pfa )

  DUP , \ new code field, pointing to the current pfa

  D9 C,           \ exx
  E1 C,           \ pop hl
  C1 C,           \ pop bc
  40 05 + C,      \ ld b,l
  DD C, E5 C,     \ push ix
  CD C, 22E5 ,    \ call 0x22E5 ; plot-sub
  DD C, E1 C,     \ pop ix
  D9 C,           \ exx
  C3 C, NEXT ,    \ jp next

  CFA OVER SWAP OVER HERE SWAP - CMOVE  \ overwrite the word
  ( a ) DP !  \ restore the dictionary pointer

DECIMAL

  \ vim: filetype=abersoftforthafera

.( Whole screen mode )

\ plusscreen.fsb
\ Whole screen mode for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)
\ Copyright (C) 1988 Lennart Benschop

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ Requirements

NEEDS AT@ at-fetch

  \ -----------------------------------------------------------
  \ History

  \ 2015-04-15: Code extracted from the main file of the
  \ library.

  \ 2015-04-19: The scroll control words are moved to
  \ <scroll.fsb>.
  \
  \ 2015-05-02: No constant created for the system variable.
  \
  \ 2015-05-06: `AT` modified with `EXIT` instead of `ELSE`: 2
  \ bytes saved, and faster.
  \
  \ 2015-05-19: Fix: Now `-SCREEN` changes the print position
  \ if it at the lower part of the screen.

  \ -----------------------------------------------------------

-->

( >CHAN )

CREATE >CHAN  ( c -- )

  \ Send the character with ASCII code c to the current channel.

  \ This word is copied from `TOCH`, from Lennart Benschop's
  \ Spectrum Forth-83. It is needed by the new version of `AT`,
  \ because Abersoft Forth's `EMIT' changes the current
  \ channel.

  HEX
  E1 C,                     \ pop hl
  7D C,                     \ ld a,l
  FD C, 36 C, 52 C, FF C,   \ ld (iy+0x52),0xFF ; set SCR CT
  D7 C,                     \ rst 0x10
  C3 C, NEXT ,              \ jp NEXT
  SMUDGE DECIMAL

-->

( AT -- version 1 )

  \ Finally, also `AT` must be patched.  Its original
  \ definition is the following (from Don Thomasson's book
  \ "Advanced Spectrum Forth", page 127):

  \ : AT ( line col -- )
  \   ABS DUP 31 >
  \   IF    2DROP
  \   ELSE  SWAP ABS DUP 21 >
  \         IF  2DROP  ELSE  22 EMIT EMIT EMIT  THEN
  \   THEN  ;

  \ The number 21 (0x15) must be changed to 23 (0x17):
  \
  \ HEX  17 7BFA !  DECIMAL
  \
  \ But it's not enough: line 23 needs special treatment.  The
  \ new version of `AT` is adapted from Lennart Benschop's
  \ Spectrum Forth-83.

  \ This version of `AT` is longer than the original one (62
  \ bytes instead of 52). Otherwise it could be possible to
  \ overwrite the original word.

: AT ( line col -- )

  \ Adapted from Lennart Benschop's Spectrum Forth-83.

  \ Warning: The system will crash if the coordinates are out
  \ of screen. For the sake of speed, no check is done.  A
  \ wrapper secure word can be written if needed.

  SWAP DUP 23 -  \ not the last line?
  IF  22 >CHAN >CHAN >CHAN EXIT  THEN
  \ Last line:
  1- DUP >CHAN >CHAN 0 >CHAN CR
  \ System variable:
  \ address in display file of print position.
  DUP 23684 +!
  \ System variable:
  \ 33 minus column number for print position.
  33 SWAP - 23688 C!  ;

-->

( AT -- version 2 ) -->  \ XXX TODO

  \ With a bit of factorization, the new word could fit the
  \ original one.

  \ 19 bytes:
: (AT)  ( col line -- )  22 >CHAN >CHAN >CHAN  ;

  \ 52 bytes: \ XXX TODO check
: NEW-AT ( line col -- )

  \ Adapted from Lennart Benschop's Spectrum Forth-83.

  \ Warning: The system will crash if the coordinates are
  \ out of screen. For the sake of speed, no check is done.
  \ A wrapper secure word can be written if needed.

  SWAP DUP 23 -  \ not the last line?
  IF  (AT) EXIT  THEN
  \ Last line:
  1- DUP >CHAN >CHAN 0 >CHAN CR
  \ System variable:
  \ address in display file of print position.
  DUP 23684 +!
  \ System variable:
  \ 33 minus column number for print position.
  33 SWAP - 23688 C!  ;

  \ Overwrite the code of the original `AT` with the code
  \ of `NEW-AT` and forget the word:

  \ ' NEW-AT ' AT OVER HERE SWAP - CMOVE
  \ FORGET NEW-AT

-->

( +SCREEN -SCREEN and patches )

  \ 23659 is the address of the system variable DF SZ, that
  \ holds the number of lines in the lower part of the screen
  \ (2 by default):

: +SCREEN  ( -- )
  \ Turn whole screen mode on.
  0 23659 C!  ;

: -SCREEN  ( -- )
  \ Turn whole screen mode off.
  \ Make sure the print position is above the lower part of the
  \ screen. Otherwise the system will exit to BASIC with an
  \ error "Out of screen", because of the way `EMIT` works.
  AT@ SWAP 21 MIN SWAP AT
  2 23659 C!  ;

: SCREEN?  ( -- f )
  \ Is the whole screen mode on?
  23659 C@ 0=  ;

  \ The DF SZ system variable must have its original value
  \ restored before returning to BASIC, else the system will
  \ crash.

: MON  ( -- )  -SCREEN MON  ;

  \ The definition of `CLS` has to be patched: it calls the ROM
  \ routine CLS (0x0D6B), but CL-ALL (0x0DAF) must be used
  \ instead (otherwise the system will crash):

HEX  0DAF 75C0 !  DECIMAL

+SCREEN

  \ vim: filetype=abersoftforthafera

.( Faster POINT )

\ point.fsb
\ Faster `POINT` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ Description

  \ The original code of `POINT` is slow: it makes sure the y
  \ coordinate is less than 0xB0; then calls the ROM routine
  \ POINT-SUB (0x22CE), that stores its result on the BASIC
  \ calculator stack; then calls FIND-INT (0x1E94) to fetch the
  \ result; finally, it doesn't jump directly to PUSHHL, but
  \ first pushes HL and then jumps to NEXT...

  \ This alternative is much faster because the y coordinate is
  \ not forced (the program must do it, if needed); the
  \ POINT-SUB ROM routine is replicated without using the BASIC
  \ calculator stack at the end; and PUSHHL is used as Forth
  \ re-entry point.

  \ -----------------------------------------------------------
  \ History
  \
  \ 2015-05-01: Start.
  \
  \ 2015-05-02: Tested.
  \
  \ 2015-05-04: Benchmark: it runs in 32% the time of the
  \ original version. Change: Instead of creating a new word,
  \ the cfa of the original word is patched with the address of
  \ the new code.
  \
  \ 2015-05-06: Improved: There was no need to save the IX
  \ register. The Y coordinate check is removed too. Finally,
  \ the new code overwrites the original (formerly the code was
  \ one byte bigger): no dictionary space is used.  The
  \ execution time is still almost the same, only one system
  \ frame less.
  \
  \ 2015-07-05: Fix: the y coordinate was not converted at the
  \ start.

  \ -----------------------------------------------------------

-->

( Faster POINT -- part 1 )

HERE  \ save the current dictionary pointer

  \ POINT  ( x y -- )
  HEX
  E1 C,               \ pop hl ; l = y coordinate
  D1 C,               \ pop de ; e = x coordinate
  C5 C,               \ push bc ; save the Forth IP
  40 05 + C,          \ ld b,l ; b = y coordinate
  48 03 + C,          \ ld c,e ; c = x coordinate
  \ ; C = x coordinate
  \ ; B = y coordinate
  3E C, AF C,         \ ld a,175 ; max y coordinate
  90 00 + C,          \ sub b
  CD C, 22AA 6 + ,    \ call PIXELADD ; +6 to skip BASIC error
  \ ; HL = screen address
  \ ; A = pixel position in HL

  -->

( Faster POINT -- part 2 )

  40 07 + C,          \ ld b,a
  04 C,               \ inc b
  7E C,               \ ld a,(hl)
  \ rotate:
  07 C,               \ rlca
  10 C, FD C,         \ djnz rotate
  E6 C, 01 C,         \ and 1
  \ finish:
  26 C, 00 C,         \ ld h,0
  68 07 + C,          \ ld l,a
  C1 C,               \ pop bc
  C3 C, PUSHHL ,      \ jp PUSHHL

  DUP ' POINT OVER HERE SWAP - CMOVE  \ move the code
  DP !  DECIMAL  \ restore the dictionary pointer

  \ vim: filetype=abersoftforthafera

.( POSTPONE )
\ postpone.fsb
\ `POSTPONE` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-07-14: Written.

  \ -----------------------------------------------------------

: POSTPONE  ( "name" -- )
  -FIND 0= 0 ?ERROR  ( pfa b )  \ error if not found
  64 AND 0=  \ non-immediate word?
  IF  COMPILE COMPILE  THEN  \ if so, compile `compile`
  CFA ,  \ compile the cfa
  ; IMMEDIATE

  \ vim: filetype=abersoftforthafera

\ prefixes.fsb
\ Number prefixes for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ Description

  \ This module provides some words to create number prefixes
  \ for hex numbers, control charactes and ASCII characters.
  \
  \ Contrary to the other modules, the words are not compiled
  \ when the module is loaded. The required code must be copied
  \ and pasted into the user application.

  \ -----------------------------------------------------------
  \ History

  \ 2015-05-01: Code taken from Albert van der Horst's lina
  \ Forth.
  \
  \ 2015-05-07: New: Prefix "0x" for hex.
  \
  \ 2015-06-06: Improved: the current value of `WIDTH` is
  \ preserved instead of using the default 0x1F.
  \
  \ 2015-10-26: Updated header and license info. Added `'.`,
  \ reorganized the screens. Added description.
  \
  \ 2015-11-18: Updated header and license info. Added `NEEDS`.

  \ -----------------------------------------------------------

( C>HEX )

  \ Note: `C>HEX` is needed by `$..`, `$....`, `0x..` and
  \ `0x....`.

HEX

: C>HEX  ( c -- n )
  \ Convert a character to its hexadecimal value.
  30 - DUP 9 > IF 7 - THEN  ;

DECIMAL

( $.. $.... )

NEEDS C>HEX prefixes

WIDTH @  1 WIDTH !

: $..
  \ Leave hex number; example: $0A leaves 0AH
  HERE 2 + C@ C>HEX 10 * HERE 3 + C@ C>HEX + [COMPILE] LITERAL
  ; IMMEDIATE

: $....
  \ Leave 16-bit hex number; example: $0AFF leaves 0AFFH
  0 HERE 6 + HERE 2 + DO 10 * I C@ C>HEX + LOOP
  [COMPILE] LITERAL
  ; IMMEDIATE

WIDTH ! DECIMAL

( 0x.. 0x.... )

NEEDS C>HEX prefixes

HEX  WIDTH @ 2 WIDTH !

: 0x..  \ Leave hex number; example: 0x0A leaves 0AH
  HERE 3 + C@ C>HEX 10 * HERE 4 + C@ C>HEX + [COMPILE] LITERAL
  ; IMMEDIATE

: 0x....  \ Leave hex number; example: 0x0AFF leaves 0AFFH
  0 HERE 7 + HERE 3 + DO 10 * I C@ C>HEX + LOOP
  [COMPILE] LITERAL
  ; IMMEDIATE

WIDTH ! DECIMAL

( ". )

HEX  WIDTH @ 1 WIDTH !

: ".
  \ Leave ASCII character; example: "A leaves 41H
  HERE 2 + C@ [COMPILE] LITERAL  ; IMMEDIATE

WIDTH ! DECIMAL

( '. )

HEX  WIDTH @ 1 WIDTH !

: '.
  \ Leave ASCII character; example: 'A leaves 41H
  HERE 2 + C@ [COMPILE] LITERAL  ; IMMEDIATE

WIDTH ! DECIMAL

( ^. )

HEX  WIDTH @ 1 WIDTH !

: ^.  \ Leave control character; example: ^A leaves 01H
  HERE 2 + C@ 1F AND [COMPILE] LITERAL  ; IMMEDIATE

WIDTH ! DECIMAL

  \ vim: filetype=abersoftforthafera

.( ?EXIT )

\ qexit.fsb
\ `?EXIT` for ZX Spectrum's Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-03-29: Written, after Gforth.
  \ 2015-05-11: Extracted from the main file of the library.

  \ -----------------------------------------------------------

: ?EXIT  ( f -- )
  \ Exit the current word if the given flag is not zero.
  [COMPILE] IF  COMPILE EXIT  [COMPILE] THEN  ; IMMEDIATE

  \ vim: filetype=abersoftforthafera

.( ?RSTACK  )

\ qrstack.fsb
\ `?RSTACK` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History of this code/file

  \ 2015-03-31: Code written.
  \ 2015-04-14: Code extracted from the main file of the library
  \ to <rstack.fsb>.
  \ 2015-05-03: Code moved to its own file <qrstack.fsb>.

  \ -----------------------------------------------------------

: ?RSTACK  ( -- )
  \ Issue an error message
  \ if the return stack is out of bounds.
  \ Written after `?STACK`, as shown in Don Thomasson's book
  \ "Spectrum Advanced Forth".
  R0 @ RP@ U< 1 ?ERROR      \ stack empty
  RP@ @ S0 U< 7 ?ERROR  ;   \ stack full

  \ vim: filetype=abersoftforthafera


.( Random number generator )

\ random.fsb
\ Random number generator for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-04-02: Start, with the code of `RND`, moved from the
  \ main file of the library.
  \
  \ 2015-04-16: Reference of the Leo Brodie's implementation.
  \
  \ 2015-05-17: Reference of the Matteo Vitturi's
  \ implementation.
  \
  \ 2015-07-04: The version based on Leo Brodie's code is the
  \ default one.
  \
  \ 2015-10-26: Updated copyright notices and comments. Fixed
  \ the default `RANDOM`.

  \ -----------------------------------------------------------

  \ Code adapted from Leo Brodie's "Starting Forth" (second
  \ edition, 1987, chapter 10, page 235), and Gforth's
  \ <random.fs>.

23670 CONSTANT SYS-SEED

: RND  ( -- n )
  SYS-SEED @ 31421 * 6927 +  DUP SYS-SEED !  ;

: RANDOM  ( u -- 0..u-1 )  RND U* NIP  ;

: RANDOMIZE  ( n -- )  SYS-SEED !  ;

( Alternative: RND of Abersoft Forth )

  \ Code from "Bertie", the demo program bundled with Abersoft
  \ Forth (1983).

  \ Copyright (C) 1983 John Jones-Steele

23670 CONSTANT SYS-SEED

: RND  ( u1 -- u2 )
  SYS-SEED @ 75 U* 75 0 D+
  OVER OVER U< - - 1 - DUP SYS-SEED !
  U* NIP ;

( Alternative: RND of vForth )

  \ Code from Matteo Vitturi's vForth 1.3 (1990-2015).

  \ Copyright (C) 1990-2015 Matteo Vitturi

23670 CONSTANT SYS-SEED

: RND  ( n1 -- n2 )
  1+ 8195 23672 @ U* 1 0 D+
  16383 U/ DROP DUP SYS-SEED !
  SWAP MOD ;

: SEED  ( n -- ) SYS-SEED ! ;

  \ vim: filetype=abersoftforthafera

.( RDEPTH )

\ rdepth.fsb
\ `RDEPTH` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-03: Code written in the main file of the library.
  \
  \ 2015-04-14: Code moved to <rstack.fsb> with all return
  \ stack words.
  \
  \ 2015-05-10: Code moved to its own file.

  \ -----------------------------------------------------------

: RDEPTH  ( -- n )
  RP@ R0 @ - -2 /  ;

  \ vim: filetype=abersoftforthafera

\ rdrop.fsb
\ `RDROP` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-03: Code written in the main file of the library.
  \
  \ 2015-04-14: Code moved to <rstack.fsb> with all return
  \ stack words.
  \
  \ 2015-05-10: Code moved to this file and rewritten in Z80.
  \ `EXIT` is patched to execute `RDROP`.
  \
  \ 2015-06-17: Fix: `EXIT` can not execute the code of
  \ `RDROP`. `EXIT` is a colon definition, thus it removes its
  \ own nesting; but `RDROP` is a primitive, thus it does not
  \ adds a nesting level. The patch is removed.
  \
  \ 2015-07-12: Fix: `SMUDGE` was missing!

  \ -----------------------------------------------------------

-->

.( RDROP )


CREATE RDROP  ( -- ) ( R: x -- )

  HEX

  2A C, 5E68 ,  \ ld hl,(RP) ; return stack pointer
  23 C,         \ inc hl
  23 C,         \ inc hl
  22 C, 5E68 ,  \ ld (RP),hl ; update the pointer
  C3 C, NEXT ,  \ jp NEXT

  SMUDGE DECIMAL

  \ vim: filetype=abersoftforthafera

.( RECURSE )

\ recurse.fsb
\ `RECURSE` for ZX Spectrum's Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-03: Written.
  \ 2015-05-11: Extracted from the main file of the library.

: RECURSE  ( -- )
  \ Compile a call to the word being defined.
  LATEST PFA CFA ,  ; IMMEDIATE

  \ vim: filetype=abersoftforthafera

.( Renamings)

\ renamings.fsb
\ Renaming of some words of ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ Description

  \ This module substitutes the names of three fig-Forth words
  \ with their modern versions. No memory is used.

  \ -----------------------------------------------------------
  \ History

  \ 2015-03: `BYE`.
  \
  \ 2015-03-29: Extracted from the main file of the library.
  \ New: `WORDS`, `?DUP`.
  \
  \ 2015-06-13: Fix: the start bit was missing in the first
  \ letter of the new names!

  \ -----------------------------------------------------------

( MON>BYE )

: MON>BYE  ( -- )
  \ Rename `MON` to `BYE`:
  [ -FIND MON ] 0= ?EXIT
  ' MON NFA 1+  [CHAR] B 128 + OVER C!
                [CHAR] Y OVER 1+ C!
                [CHAR] E 128 + SWAP 2+ C!
  ;  MON>BYE  FORGET MON>BYE

-->

( VLIST>WORDS )

: VLIST>WORDS  ( -- )
  \ Rename `VLIST` to `WORDS`:
  [ -FIND MON ] 0= ?EXIT
  [ -FIND VLIST ] 0= ?EXIT
  ' VLIST NFA 1+  [CHAR] W 128 + OVER C!
                  [CHAR] O OVER 1+ C!
                  [CHAR] R OVER 2+ C!
                  [CHAR] D OVER 3 + C!
                  [CHAR] S 128 + SWAP 4 + C!
  ;  VLIST>WORDS  FORGET VLIST>WORDS

-->

( -DUP>?DUP )

: -DUP>?DUP  ( -- )
  \ Rename `-DUP` to `?DUP`:
  [ -FIND -DUP ] 0= ?EXIT
  ' -DUP NFA 1+  [CHAR] ? 128 + SWAP C!
  ;  -DUP>?DUP  FORGET -DUP>?DUP

  \ vim: filetype=abersoftforthafera


.( ROLL )

\ roll.fsb
\ `ROLL` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-03: Code written in the main file of the library,
  \ using `RECURSE`, after the definition of `ROLL` in Gforth.
  \ A faster version with `CMOVE` is unfinished.
  \
  \ 2015-05-02: Code moved to this file.
  \
  \ 2015-10-26: Reorganized the screens. Added `NEEDS`.

  \ -----------------------------------------------------------

NEEDS RECURSE recurse

: ROLL  ( xu xu-1 ... x0 u -- xu-1 ... x0 xu )
  DUP 1 <
  IF    DROP
  ELSE  SWAP >R 1 - RECURSE R> SWAP
  THEN  ;  ;S

  \ XXX TODO -- In DZX-Forth
  \ (http://programandala.net/en.program.dzx-forth.html)
  \ there's a version written in Z80.

  \ XXX OLD -- unfinished version
  \ : ROLL  ( xu xu-1 ... x0 u -- xu-1 ... x0 xu )
  \ 2 * 4 + DUP SP@ + DUP @ ROT 1 - DUP 2 + ROT 2 -
  \ CMOVE DROP  ;

( Spectrum Forth-83 ROLL )

  \ XXX TODO -- Compare with the version of DZX-Forth.

CODE ROLL ( u ---)
     EXX    \ Use shadow registers.
    EXSP    \ Operand now in HL
   H INC
  H ADDP    \ Add 1 and multiply by 2.
  H B LD
  L C LD    \ Byte count in BC = 2*(u+1)
 SP ADDP    \ Add to SP,
            \ Address of cell to pick up and move to top.
  M E LD
   H INC
  M D LD    \ Read the cell that must be moved to top.
  D PUSH    \ Save it.
  L E LD

( Spectrum Forth-83 ROLL )

  H D LD
   H DEC
   H DEC    \ Source address is destination address - 2.
  B A LD
    C OR
   NZ IF    \ Test for byte count zero is unnecessary
            \ BC=2 even for 0 ROLL.
       LDDR \ Move the remaining stack cells up.
   THEN
   H POP    \ Get saved top.
   B POP    \ Remove junk cell.
    EXSP    \ Put top back.
     EXX      \ Back to normal registers
    JPIX ;C

  \ vim: filetype=abersoftforthafera

.( +SCROLL -SCROLL )

\ scroll.fsb
\ Scroll control for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-04-19: Code extracted from <plusscreen.fsb>.
  \ 2015-05-04: The names are exchanged. More logical.

  \ -----------------------------------------------------------

  \ Two words to toggle the scroll prompt.

  \ Note: 23692 is the system variable SCR CT.

  : -SCROLL  ( -- )    0 23692 C!  ;
  : +SCROLL  ( -- )  255 23692 C!  ;

\ vim: filetype=abersoftforthafera

.( S= )

\ s-equals.fsb
\ `S=` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-07-16: Code moved from the <strings.fsb> module.
  \ 2015-08-28: Typo.

  \ -----------------------------------------------------------
  \ Requirements

[DEFINED] LENGTHS ?-->

: LENGTHS  ( ca1 len1 ca2 len2 -- ca1 len1 ca2 len2 len1 len2 )
  2OVER NIP OVER  ;

  \ -----------------------------------------------------------

-->

( S= )

: S=  ( ca1 len1 ca2 len2 -- f )
  LENGTHS -  \ different lengths?
  IF    2DROP 2DROP FALSE EXIT
  ELSE  DROP [ CONTEXT @ EDITOR ] -TEXT [ CONTEXT ! ] 0= 0=
  THEN  ;

  \ vim: filetype=abersoftforthafera

.( SGN )

\ sgn.fsb
\ `SGN` for ZX Spectrum's Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-03: Written.
  \
  \ 2015-05-11: Extracted from the main file of the library.
  \ Modified to use `2*` if defined.
  \
  \ 2015-05-17: Updated: `2*` is part of the main file of the
  \ library.

  \ -----------------------------------------------------------

: SGN  ( n1 -- -1|0|1 )  DUP IF  0<  2*  1+  THEN  ;

  \ vim: filetype=abersoftforthafera


( /LOADT )

\ slash-load-t.fsb
\ `/LOADT` tape extension for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-03-28: First working version, in the module
  \ <tape.fsb>.
  \
  \ 2015-05-19: Moved to its own file.
  \
  \ 2015-10-26: Fixed comment. Renamed file.

  \ -----------------------------------------------------------

NEEDS <TAPE  tape
NEEDS S"     strings

: /LOADT  ( n -- )
  \ Load the Forth RAM-disk from tape, at address of screen n.
  \ Warning: the file will be loaded, no matter its length.
  \ n = first screen
  EMPTY-BUFFERS DISC-SCR 0 S" DISC" <TAPE  ;

  \ vim: filetype=abersoftforthafera

( /SAVET )

\ slash-save-t.fsb
\ `/SAVET` tape extension for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-03-28: First working version, in the module
  \ <tape.fsb>.
  \
  \ 2015-05-19: Moved to its own file.
  \
  \ 2015-10-26: Fixed comment. File renamed.

  \ -----------------------------------------------------------

NEEDS >TAPE  tape
NEEDS S"     strings

: /SAVET  ( n1 n2 -- )
  \ Save the Forth RAM-disk to tape,
  \ from screen n1 to screen n2.
  \ n1 = first screen
  \ n2 = last screen
  FLUSH 1+ DISC-SCR SWAP DISC-SCR
  DUP ROT SWAP -  S" DISC" >TAPE  ;

  \ vim: filetype=abersoftforthafera

.( S+ )

\ s-plus.fsb
\ String concatenation operator for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-05-18: Moved from the module <strings.fsb>.

  \ -----------------------------------------------------------
  \ Requirements

NEEDS MOVE              move
NEEDS ALLOCATE-STRING   csb
NEEDS PICK              pick

[DEFINED] LENGTHS ?-->

: LENGTHS  ( ca1 len1 ca2 len2 -- ca1 len1 ca2 len2 len1 len2 )
  2OVER NIP OVER  ;

  \ -----------------------------------------------------------

-->

( SMOVE S+ )

: SMOVE  ( ca1 len ca2 -- )  SWAP MOVE  ;

: S+  ( ca1 len1 ca2 len2 -- ca3 len3 )
  \ Append the string ca2 len2 to the end of string ca1 len1
  \ returning the string ca3 len3.
  LENGTHS + >R          ( ca1 len2 ca2 len2 ) ( R: len3 )
  R ALLOCATE-STRING >R  ( R: len3 ca3 )
  2 PICK R +            ( ca1 len1 ca2 len2 len1+ca3 )
  SMOVE                 ( ca1 len1 )  \ 2nd string to buffer
  R SMOVE               \  1st string to buffer
  R> R>  ;

  \ vim: filetype=abersoftforthafera

\ sqrt.fsb
\ 'SQRT` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-05-13: Code copied from DZX-Forth
  \ (http://programandala.net/en.program.dzx-forth.html).

  \ -----------------------------------------------------------

-->

.( SQRT )

: SQRT ( +n -- root rem )
  \ 16-bit fast integer square root.
  \ Return root and remainder, or 0 -1 if n is negative
  \ From: Forth Dimensions 14/5
  DUP 0<
  IF  DROP 0 -1  ELSE
    0 SWAP 16384 ( 2^14 )
    BEGIN
      >R  DUP  2 PICK  -  R -  DUP 0<
      IF    DROP SWAP 2/
      ELSE  NIP  SWAP 2/  R +  THEN
      SWAP  R> 2/
      2/  DUP 0=
    UNTIL  DROP
  THEN  ;

  \ vim: filetype=abersoftforthafera

.( Strings )

\ strings.fsb
\ Strings for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ Requirements

NEEDS MOVE    move
NEEDS FALSE   flags
NEEDS 2>R     2r
NEEDS 2R>     2r

  \ -----------------------------------------------------------
  \ History

  \ 2015-03: `CHAR`, `[CHAR]`, `PARSE-TEXT`, `PARSE-NAME`,
  \ `SLIT`, `S,`, `SLITERAL`, `.(`, `(S)`, `S"`, `S'`.
  \
  \ 2015-03-28: File created with code extracted from the main
  \ file of the library. New: `STR=`, after Gforth.
  \
  \ 2015-03-29: New: 'PLACE' and '+PLACE', after Gforth;
  \ circular string buffer and related tools, adapted from csb8
  \ (http://programandala.net/en.program.csb8.html).
  \
  \ 2015-03-30: `.(`is moved to the main extend module, in
  \ order to use it at block headers.
  \
  \ 2015-03-31: New: `/STRING`.
  \
  \ 2015-04-03: Change: `CHAR` and `[CHAR]` are moved to the
  \ main file of the library.
  \
  \ 2015-04-14: New: `CMOVE>`, `MOVE`.
  \
  \ 2015-05-15: `CMOVE>` and `MOVE` are moved to <move.fsb>.
  \ `2>R` and `2>R` are already available and used.
  \ Improvement: The circular string buffer is configurable; it
  \ must be initialized.
  \
  \ 2015-05-17: `NEEDS` used.
  \
  \ 2015-05-18: The circular string buffer is moved to its own
  \ file.  This way, applications that just need transient
  \ strings do not waste the dictionary space occupied by the
  \ code of the buffer.
  \
  \ 2015-05-26: `STR=` is renamed as `S=`.
  \
  \ 2015-06-22: Fix: `S,` didn't compile the count byte.
  \
  \ 2015-07-16: `S=` is moved to its own file.
  \
  \ 2016-11-17: Fix `+PLACE`.

2 3 THRU

( PARSE-TEXT PARSE-NAME S, SLITERAL PLACE +PLACE /STRING )

: PARSE-TEXT  ( c "ccc<c>" -- ca len )  TEXT PAD COUNT  ;
: PARSE-NAME  ( "name" -- ca len )  BL PARSE-TEXT  ;

: SLIT  ( -- ca len )  R COUNT DUP 1+ R> + >R  ;
: S,  ( ca len -- )  DUP C, SWAP HERE ROT DUP ALLOT CMOVE  ;
: SLITERAL  ( ca len -- )  COMPILE SLIT S,  ; IMMEDIATE

: PLACE  ( ca1 len1 ca2 )  2DUP C! 1+ SWAP MOVE  ;
: +PLACE  ( ca1 len1 ca2 )
  2DUP 2>R COUNT + SWAP MOVE 2R> DUP C@ ROT + SWAP C!  ;

: /STRING  ( ca1 len1 n -- ca2 len2 )
  DUP >R - SWAP R> + SWAP  ;

( S" S' )

  \ XXX FIXME -- 2015-06-22: Empty strings' length is one,
  \ because of `WORD`.  A version that does not skips initial
  \ delimiters is needed.

: (S) ( Compilation: c "ccc<c>" -- ) ( Run-time:  -- ca len )
  STATE @
  IF    COMPILE SLIT WORD HERE C@ 1+ ALLOT
  ELSE  PARSE-TEXT  THEN  ;

: S"  ( Compilation: "ccc<">" -- ) ( Run-time:  -- ca len )
  [CHAR] " (S)  ; IMMEDIATE

: S'  ( Compilation: "ccc<'>" -- ) ( Run-time:  -- ca len )
  [CHAR] ' (S)  ; IMMEDIATE

  \ vim: filetype=abersoftforthafera

.( Tape extensions )

\ tape.fsb
\ Tape extensions for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ Description

  \ Abersoft Forth only includes two tape words: `LOADT` and
  \ `SAVET`, that load and save its 11-KiB RAM-disk with the
  \ name "DISC".  It includes no word to load or save any code
  \ files, any name and size, what is especially useful in
  \ order to include graphics or data during the compilation of
  \ a Forth program.
  \
  \ This module defines `>TAPE` ("to tape") and `<TAPE` ("from
  \ tape"). The approach used was to patch the tape load header
  \ of Abersoft Forth, passed to the ROM routine, and restore
  \ its default values after the operation.
  \
  \ Two more words, `/LOADT` and `/SAVET`, let improved
  \ manipulation of the RAM-disk. As they are less needed, they
  \ are defined in their own files, <slash-loadt.fsb> and
  \ <slash-savet.fsb>.

  \ -----------------------------------------------------------
  \ Requirements

NEEDS   S"        strings

  \ -----------------------------------------------------------
  \ History

  \ 2015-03-26: Start.
  \
  \ 2015-03-28: First working version.
  \
  \ 2015-04-23: Some comments are improved.
  \
  \ 2015-04-30: `'BLOCK` instead of `BLOCK>A`, after the change
  \ in the main file of the library.
  \
  \ 2015-05-03: Simpler word names: no "MEM" affix.
  \
  \ 2015-05-08: Some words are renamed.
  \
  \ 2015-05-10: `INCLUDET` is removed; not useful with tapes.
  \ `'SCR` instead of `'BLOCK`, after the change in the main
  \ file of the library.
  \
  \ 2015-05-12: Change: `'SCR` renamed to `DISC-SCR`, after the
  \ changes in the library.
  \
  \ 2015-05-17: `NEEDS` used.  Some renamings, after the
  \ changes in the library (common core words for some tape and
  \ disk operations).
  \
  \ 2015-12-23: Fixed mistake in comment about the tape header.

  \ -----------------------------------------------------------
  \ Development documentation

  \ Dictionary references from Don Thomasson's book
  \ _Advanced Spectrum Forth_:
  \
  \ 340 (page 119): (TAPE)
  \
  \ pop hl
  \ push bc
  \ push ix
  \ ld a,l ; 1=LOAD, 0=SAVE
  \ ; this instruction is at 0x7618:
  \ ld hl,D000  ; start address to save or load
  \ ld ix,start-of-header-area
  \ ; ld a,(5C72) ; XXX this is a mistake in the book
  \ ; XXX fixed:
  \ ld (5C74),A
  \ call 075A
  \ pop ix
  \ pop bc
  \ jp next1
  \
  \ 344 (page 120): LOADT
  \
  \ 1 (TAPE)

  \ 345 (page 120): SAVET
  \
  \ 0 (TAPE)

  \ The load header (pointed by IX before calling the ROM
  \ routine) is at address 30182 (0x75E6).  Its contents are:

  \ +00 : 3 (identifier of code file type)
  \ +01 : "DISC      " = 10-char filename, padded with spaces
  \ +11 : 11263 (0x2BFF)  = length
  \ +13 : 53248 (0xD0FF)  = start address
  \ +15 : "  " (2 spaces) = not used for code files

  \ The save header (pointed by the ROM routine, by adding 0x11
  \ to IX) is right after the load header, at address 30199
  \ (0x75F7).

  \ -----------------------------------------------------------

2 4 THRU

( Headers )

30182 CONSTANT TAPE-LOAD-HEADER \ load header
17 CONSTANT /TAPE-HEADER  \ header length
  \ XXX OLD -- Save header, not needed.
  \ TAPE-LOAD-HEADER /TAPE-HEADER + CONSTANT TAPE-SAVE-HEADER

10 CONSTANT /TAPE-FILENAME \ filename max length

: >TAPE-FILENAME  ( a1 -- a2 )   1+   ;
: >TAPE-LENGTH    ( a1 -- a2 )  11 +  ;
: >TAPE-START     ( a1 -- a2 )  13 +  ;

  \ Keep a copy of both tape headers:
0 VARIABLE TAPE-HEADERS-BACKUP  /TAPE-HEADER 2* 2- ALLOT
TAPE-LOAD-HEADER TAPE-HEADERS-BACKUP /TAPE-HEADER 2* CMOVE

( Tools )

  \ Address of the file start address
   \ in the code of the word `(TAPE)`:
30233 CONSTANT (TAPE)-START

: TAPE-RESTORE  ( -- )
  \ Restore the original contents of both tape headers:
  TAPE-HEADERS-BACKUP TAPE-LOAD-HEADER /TAPE-HEADER 2* CMOVE
  \ Unpatch `(TAPE)`
  LO (TAPE)-START !  ;

: -TAPE-FILENAME  ( -- )
  \ Blank the filename of the load header.
  TAPE-LOAD-HEADER >TAPE-FILENAME /TAPE-FILENAME BLANKS ;

  \  XXX TODO use the file execution table
  \  to share one word with the disk support?
: TAPE-FILENAME!  ( ca len -- )
  \ Store a filename into the load header.
  -TAPE-FILENAME  /TAPE-FILENAME MIN
  TAPE-LOAD-HEADER >TAPE-FILENAME SWAP CMOVE  ;

: ANY-TAPE-FILENAME  ( -- )
  \ Configure the load header to load any filename.
  255 TAPE-LOAD-HEADER >TAPE-FILENAME C!  ;

: TAPE-LENGTH!  ( len -- )
  \ Set the given code length for the next tape loading,
  \ storing it into the load header.
  TAPE-LOAD-HEADER >TAPE-LENGTH !  ;

: TAPE-START!  ( a -- )
  \ Set the given code start for the next tape loading,
  \ storing it into the load header and patching
  \ the code of the word `(TAPE)`.
  DUP (TAPE)-START !  TAPE-LOAD-HEADER >TAPE-START !  ;

( <TAPE >TAPE )

: <TAPE  ( a1 len1 ca2 len2 -- )
  \ Load a file from tape.
  \ a1       = destination
  \ len1     = length (or zero if unspecified)
  \ ca2 len2 = filename (len2 is zero if unspecified)
  DUP IF  TAPE-FILENAME!  ELSE  2DROP ANY-TAPE-FILENAME  THEN
  TAPE-LENGTH! TAPE-START!  1 (TAPE)  TAPE-RESTORE  ;

: >TAPE  ( a1 len1 ca2 len2 -- )
  \ Save a memory region into a tape file.
  \ a1       = start
  \ len1     = length
  \ ca2 len2 = filename
  TAPE-FILENAME! TAPE-LENGTH! TAPE-START!
  0 (TAPE)  TAPE-RESTORE  ;

  \ vim: filetype=abersoftforthafera

\ time.fsb
\ Time extensions for ZX Spectrum Abersoft Forth.

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-07-02: Start, with the code of `MS`, moved from the
  \ main file of the library.
  \
  \ 2015-04-03: New: `TIME@`, `TIME!` and `TIME0`.
  \
  \ 2015-07-16: Moved `MS` to its own file.

  \ -----------------------------------------------------------

-->

.( Time extensions )

FORTH DEFINITIONS  DECIMAL

[DEFINED] SYS-FRAMES ?\ 23672 CONSTANT SYS-FRAMES

: TIME@  ( -- d )
  \ System frames counter (incremented every 20 ms).
  SYS-FRAMES @ [ SYS-FRAMES 2+ ] LITERAL C@  ;

: TIME!  ( d -- )
  \ Set the system frames counter.
  [ SYS-FRAMES 2+ ] LITERAL C! SYS-FRAMES !  ;

: TIME0  ( -- )
  \ Reset the system frames counter.
  0. TIME!  ;

  \ vim: filetype=abersoftforthafera

.( End transient code )

\ transient-end.fsb
\ Transient code tool for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-05-17: Start.
  \ 2015-05-18: `NEEDS`.

  \ -----------------------------------------------------------

NEEDS TRANSIENT[ transient

]TRANSIENT

  \ vim: filetype=abersoftforthafera


.( TRANSIENT )
\ transient.fsb
\ Transient code for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)
\ Copyright (C) 1988 Lennart Benschop

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-03-15: Start. Code adapted from the <TASM> file of
  \ Lennart Benschop's Spectrum Forth-83 (1988).
  \
  \ 2015-05-01: Rewritten. New approach to make it a generic
  \ tool.
  \
  \ 2015-05-08: Improved to work also when the system has been
  \ lowered below 0xC000 by the module <lowersys.fsb>. 
  \
  \ 2015-05-09: The unlinking done by `-TRANSIENT` was fixed
  \ and adapted to fig-Forth with the help of Lennart Benschop.

  \ -----------------------------------------------------------

-->

( TRANSIENT -- variables )

0 VARIABLE OLD-DP
0 VARIABLE OLD-LATEST
0 VARIABLE OLD-VOC-LINK

-->

( TRANSIENT -- main )

: TRANSIENT[  ( u -- )

  \ Start transient code, reserving u bytes for it (including
  \ dictionary space and data stack).
  \
  \ This word must be used before compiling the transient code.
  \ The compiled size of the transient code must be known in
  \ advance, and sum say 128 bytes to it for the data stack.
  \
  \ Note: Adding data stack space to u is unnecessary when the
  \ system has been lowered below 0xC000 by the <lowersys.fsb>
  \ module.

  HERE        OLD-DP !
  LATEST      OLD-LATEST !
  VOC-LINK @  OLD-VOC-LINK !

  \ The free dictionary space top limit is `SP@` in the
  \ standard memory map. But when the system has been lowered
  \ by the module <lowersys.fsb>, it's `LO` instead (the start
  \ of RAM-disk). And when the system uses 16-KiB RAM-disks,
  \ the limit is the top of the memory.  `FREE` is used to get
  \ the current value, because the first word compiled in its
  \ pfa returns the top address `SP@`, `LO` or `0`).

  ' FREE @ EXECUTE

  SWAP - DP !  ;

: ]TRANSIENT  ( -- )

  \ End the transient code.
  \
  \ This word must be used after compiling the transient code.

  OLD-DP @ DP !  ;

: -TRANSIENT  ( -- )

  \ Remove the transient code, unlinking the dictionary space
  \ that was reserved for it.
  \
  \ This word must be used when the transient code is not going
  \ to be used any more.

  OLD-VOC-LINK @ VOC-LINK !

  \ Store the nfa of the latest word created
  \ before compiling the transient code,
  \ into the lfa of the first word created
  \ after the transient code was finished
  \ by `]TRANSIENT`.

  OLD-LATEST @ OLD-DP @ PFA LFA !  ;

  \ vim: filetype=abersoftforthafera

.( Remove transient code )

\ transient-remove.fsb
\ Transient code tool for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-05-17: Start.
  \ 2015-05-18: `NEEDS`.

  \ -----------------------------------------------------------

NEEDS TRANSIENT[ transient

-TRANSIENT

  \ vim: filetype=abersoftforthafera

.( 4096 bytes for transient code )

\ transient-start-4096.fsb
\ Transient code tool for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-05-17: Written.
  \ 2015-05-18: `NEEDS`.

  \ -----------------------------------------------------------

NEEDS TRANSIENT[ transient

4096 TRANSIENT[

  \ vim: filetype=abersoftforthafera

\ traverse.fsb
\ Faster `TRAVERSE` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ Description

  \ This module patches `TRAVERSE`, originally written in
  \ Forth, with much faster Z80 code. But in practice, because
  \ of the usage of this word, the speed gain is unimportant.

  \ -----------------------------------------------------------
  \ History

  \ 2015-05-06: First version.
  \
  \ 2015-10-26: Added description.

  \ -----------------------------------------------------------

-->

.( Faster TRAVERSE )

HERE ' TRAVERSE  ( a pfa )
  DUP , \ the new cfa points to the code at pfa

  \ TRAVERSE  ( a1 n -- a2 )
  \ n = 1 | -1
  HEX
  D1 C,                   \ pop de
  E1 C,                   \ pop hl
                          \ do:
  19 C,                   \ add hl,de
  CB C, 46 8 7 * + C,     \ bit 7,(hl)
  CA C, ' TRAVERSE 2+ ,   \ jp z,do
  C3 C, PUSHHL ,          \ jp PUSHHL

  CFA OVER SWAP OVER HERE SWAP - CMOVE  \ overwrite the word
  ( a ) DP !  \ restore the dictionary pointer

  \ vim: filetype=abersoftforthafera

.( UDG! )

\ udg-store.fsb
\ `UDG!` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ Description

  \ `UDG!` defines UDG graphics with data in the usual order
  \ (top row first). This makes same things easier. When binary
  \ is used, the graphic can be shown in the source code.

  \ -----------------------------------------------------------
  \ History

  \ 2015-03: Code written.
  \
  \ 2015-03-28: Code moved from the main file of the library
  \ to <graphics.fsb>.
  \
  \ 2015-04-22: Code moved to its own file.
  \
  \ 2015-05-08: Description.

  \ -----------------------------------------------------------

: UDG!  ( b0..b7 c -- )
  \ Store the given 8 bytes into the UDG char c.
  \ b0 = first (top) scan
  \ b7 = last (bottom) scan
  \ c = 144..164
  144 - 8 * UDG + 1 - DUP 8 + DO  I C!  -1 +LOOP  ;

  \ vim: filetype=abersoftforthafera


\ unloop.fsb
\ `UNLOOP` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-04-21: First high level version written in the main
  \ file of the library.  2015-04-21: First draft in Z80.
  \
  \ 2015-04-25: First working version in Z80.
  \
  \ 2015-05-03: Code moved to its own file.
  \
  \ 2015-05-10: Conditional compilation to reuse the code of
  \ `2RDROP`, if present.

  \ -----------------------------------------------------------

-->

.( UNLOOP )

CREATE UNLOOP  ( R: x1 x2 -- )

  \ Discard the loop control parameters for the current nesting
  \ level. An `UNLOOP` is required for each nesting level
  \ before the definition may be exited with `EXIT`.
  \
  \ In fig-Forth, the top of the return stack is the loop
  \ index, and the value below it is the loop limit.
  \
  \ A high level version of `UNLOOP` would need to preserve the
  \ return address of the word:
  \
  \   R> R> DROP R> DROP >R
  \
  \ But the low level version doesn't.

SMUDGE

[UNDEFINED] 2RDROP  \ if 2RDROP is not defined,
  \ then ignore this line, that reuses its code and exit:
  ?\  ' 2RDROP ' UNLOOP CFA ! ;S

  \ 2RDROP is not defined, so create new code:

  HEX

  2A C, 5E68 ,  \ ld hl,(RP) ; return stack pointer
  23 C,         \ inc hl
  23 C,         \ inc hl
  23 C,         \ inc hl
  23 C,         \ inc hl
  22 C, 5E68 ,  \ ld (RP),hl ; update the pointer
  C3 C, NEXT ,  \ jp NEXT

  DECIMAL

  \ vim: filetype=abersoftforthafera

\ upperc.fsb
\ `UPPERC` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-04-23: First version.

  \ -----------------------------------------------------------

-->

.( UPPERC )

HEX

CREATE UPPERC   ( c -- c' )
  \ Convert an ASCII character to uppercase.
  E1 C,           \ pop hl
  78 05 + C,      \ ld a,l
  FE C, 61 C,     \ cp 'a'
  38 C, 06 C,     \ jr c,end
  FE C, 7B C,     \ cp 'z'+1
  30 C, 02 C,     \ jr nc,end
  E6 C, DF C,     \ and %11011111 ; reset bit 5
  \ end:
  68 07 + C,      \ ld l,a
  C3 C, PUSHHL ,  \ jp PUSHHL
  SMUDGE

DECIMAL

  \ vim: filetype=abersoftforthafera


.( UPPERS )

\ uppers.fsb
\ `UPPERS` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-05-06: First version.
  \
  \ 2015-05-18: Added `NEEDS`.

  \ -----------------------------------------------------------
  \ Requirements

NEEDS UPPERC upperc

  \ -----------------------------------------------------------

: UPPERS   ( ca len -- )
  \ Convert a string to uppercase.
  \ XXX FIXME -- use `?DO` when available
  BOUNDS DO  I C@ UPPERC I C!  LOOP  ;

  \ vim: filetype=abersoftforthafera


.( VALUE )

\ value.fsb
\ `VALUE` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)
\ http://programandala.net/en.program.afera.html

  \ Copying and distribution of this file, with or without
  \ modification, are permitted in any medium without royalty
  \ provided the copyright notice and this notice are
  \ preserved.  This file is offered as-is, without any
  \ warranty.

  \ -----------------------------------------------------------
  \ History

  \ 2015-04-15: Code extracted from the main file of the
  \ library.
  \
  \ 2015-04-21: Fix: `[TO]` does not need to compile `LITERAL`,
  \ because in fig-Forth `'` compiles its result.
  \
  \ 2015-04-30: Three alternative non-parsing versions.
  \
  \ 2015-07-07: Simplified: removed `[TO]` and `<TO>` from the
  \ default parsing version. Updated and tested de version with
  \ `DEFER`.
  \
  \ 2015-09-08: Fixed stack comments.
  \
  \ 2015-10-27: Updated license info.
  \
  \ 2015-10-28: Modified comment.
  \
  \ 2015-11-18: Updated header and license info.

  \ -----------------------------------------------------------

2 LOAD

( VALUE with parsing and state-smart TO )

\ This implementation, with parsing and state-smart `TO`,
\ conforms to ANS Forth.  ANS Forth explicitly requires that
\ `TO` must parse.

  \ 45 bytes of dictionary space are used.

: VALUE  ( n "name"  -- )  CONSTANT  ;

: TO  ( Interpretation: n "name" -- )
      ( Compilation: "name" -- )
  [COMPILE] '  STATE @ IF  COMPILE !  ELSE  !  THEN
  ; IMMEDIATE

( VALUE with non-parsing TO -- version with flag )

\ This non-parsing alternative implementation is taken from
\ Albert van der Horst's lina Forth.

  \ 85 bytes of dictionary space are used.

0 VARIABLE TO-MESSAGE
: FROM  ( -- )  0 TO-MESSAGE !  ;
: TO    ( -- )  1 TO-MESSAGE !  ;
: VALUE  ( n "name" -- )
  <BUILDS ,  DOES>  TO-MESSAGE @ IF  !  ELSE  @  THEN  FROM  ;

( VALUE with non-parsing TO -- version with EXECUTE )

\ This non-parsing alternative implementation is a modified
\ version of the lina implementation above.

  \ 82 bytes of dictionary space are used.

0 VARIABLE (VALUE)
: FROM  ( -- )  ' @ CFA (VALUE) !  ;  FROM
: TO    ( -- )  ' ! CFA (VALUE) !  ;
: VALUE  ( n "name" -- )
  <BUILDS ,  DOES>   (VALUE) @ EXECUTE  FROM  ;

( VALUE with non-parsing TO -- version with DEFER )

\ This non-parsing alternative implementation is a modified
\ version of the lina implementation above.

  \ 84 bytes of dictionary space are used.

DEFER (VALUE)
: FROM  ( -- )  ' @ CFA ' (VALUE) DEFER!  ;  FROM
: TO    ( -- )  ' ! CFA ' (VALUE) DEFER!  ;
: VALUE  ( n "name" -- )
  <BUILDS ,  DOES>  (VALUE) FROM  ;

  \ vim: filetype=abersoftforthafera