Fonto de Afera (parto 1: modjul-nomoj 0-9)

Priskribo de la ĉi-paĝa enhavo

Dua parto de la fontoj de la biblioteko Afera por Abersoft Forth.

Etikedoj:

Fontkodo

.( Two 16-KiB RAM-disks )

\ 16kramdisks.fsb
\ Two 16-KiB RAM-disks 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 uses one 11-KiB RAM-disk at the top of the
  \ memory map.  This module, suitable only for ZX Spectrum
  \ 128K (or later), modifies the system in order to use two
  \ 16-KiB RAM-disks instead, using the additional memory
  \ banks.
  \
  \ The 11 KiB of memory used by the original RAM-disk are
  \ freed for the Forth dictionary.

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

  49152 R0 @ U<  ?NEEDS lowersys
  NEEDS BANK bank

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

  \ 2015-05-11: Start.
  \
  \ 2015-05-12:
  \
  \ Fix: the second check was missing in `DISC-BLOCK`, what
  \ caused `LIST` could be used with screen numbers greater
  \ than 16.
  \
  \ Fix: Also `(TAPE)` needed a patch, the same way the module
  \ <tape.fsb> does.
  \
  \ First working version.
  \
  \ Improvement: Second drive. The fig-Forth word `DR1` is
  \ added.
  \
  \ Improvement: The contents of the old RAM-disk are moved to
  \ the new one, thus the module must not quit after doing its
  \ job, and other modules can be automatically loaded after
  \ this one.
  \
  \ 2015-05-13: Change: The banks used are 4 and 6 (uncontended
  \ memory) instead of 1 and 3 (contended memory).
  \
  \ 2015-05-17: Change: The banks used are 3 and 4. Simpler
  \ calculation. Anyway, contended memory banks are different
  \ in 128K and +3.
  \
  \ 2015-05-17: `NEEDS` and `?NEEDS` used. Improved: the
  \ current permanent paper color is used to hide the screen
  \ during the RAM-disk copying, instead of white; this way any
  \ screen color set in the main file of the library will work.
  \
  \ 2015-06-02: Simpler method for patches, with `]` and `[`.
  \
  \ 2015-06-06: Fix: the patch of `R/W` can not use `]` and
  \ `[`, because  it's done in `INSTALL`, during compilation!
  \
  \ 2015-06-13: Fix: `DISC-BANK` did a wrong calculation. New:
  \ `B/DR`.

  \ -----------------------------------------------------------
  \ TO-DO 

  \ `MESSAGE` would need a patch to get the messages always
  \ from the first RAM-disk, not from the current one.

-->

( DISC DR1 DISC-BANK INIT-DISC )

0 CONSTANT B/DR \ blocks per drive (will be updated later)

: DR1  ( -- )
  \ Select the second RAM-disk.
  B/DR OFFSET !  ;

: DISC-BANK  ( -- n )
  \ Memory bank of the current RAM-disk.
  1 OFFSET @ B/DR 1- > 2* + ;

: (INIT-DISC)  ( -- )
  \ Blank the current RAM-disk, that must be already paged in.
  LO /DISC BLANKS ;

HERE
  \ Compile the patch for `INIT-DISC`
  \ (the original word occupies the same):
  ]  DISC-BANK BANK (INIT-DISC) 0 BANK  [
  \ Move it:
DUP  ' INIT-DISC OVER HERE SWAP - CMOVE
DP ! \ restore the disctionary pointer

-->

( LOADT SAVET VERIFY )

  \ Patch the tape words to use the new RAM-disk.

: (BANK-TAPE)   ( n -- )
  \ Do a RAM-disk tape operation
  \ with the proper memory bank paged in.
  \ n = 0 for loading; 1 for saving; 2 for verifying
  DISC-BANK BANK (TAPE) 0 BANK  ;

' (BANK-TAPE) CFA ' LOADT  2+  !
' (BANK-TAPE) CFA ' SAVET  4 + !
' (BANK-TAPE) CFA ' VERIFY 2+  !

-->

( INSTALL -- part 1 )

HEX

: INSTALL  ( -- )

  \ Intall the two 16-KiB RAM-disks.
  \
  \ This long word, that forgets itself at the end, does all
  \ operations that have to be done in one single step, while
  \ no disk block is being interpreted, otherwise the system
  \ could be affected. It includes also some simple patches
  \ that could be done previously without risk, but that depend
  \ on the new values of some constants, in order to use them
  \ as literals, and those constants are modified here.

  \ Update the length and bounds of the RAM-disk:
  4000 ' /DISC !        \ 16 KiB length
  C000 ' LO !           \ lowest address, when paged
  LO /DISC + 1- ' HI !  \ highest address, when paged

  \ Update the number of screens per drive (RAM-disk):
  10 ' SCR/DR !

  \ Update the number of blocks per drive (RAM-disk):
  SCR/DR B/SCR * ' B/DR !

  \ Make sure the buffers are empty before patching `R/W`:
  EMPTY-BUFFERS

  \ `(R/W)` was defined by the main file of the library,
  \ with additional space required to patch it now
  \ with the new code required by the 128K version.

  HERE  ' DISC-BANK CFA , ' BANK CFA , ' CMOVE CFA ,
  ' 0 CFA , ' BANK CFA ,

  DUP ' (R/W) 08 + OVER HERE SWAP - CMOVE  DP !

-->

( INSTALL -- part 2 )

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

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

  \ Patch the tape load header
  \ with the new length and start address:
  /DISC 75E6 0B + !  LO 75E6 0D + !

  \ Patch `(TAPE)` with the new default file start address:
  LO 7619 !

  \ The word `FREE` returns the free dictionary space.  Its
  \ original definition, according to the original memory map,
  \ is:
  \
  \   : FREE  ( -- n )  SP@ HERE -  ;
  \
  \ After been patched by the module <lowersys.fsb>, its
  \ definition is:
  \
  \   : FREE  ( -- n )  LO HERE -  ;
  \
  \ It has to be modified once more because now all RAM is
  \ free, so '0' must be used instead of 'LO':
  ' 0 CFA ' FREE !

  \ Move the contents of the old RAM-disk to the new one.  This
  \ makes it possible to use this module transparently, and
  \ load other modules after it.
  \
  \ The first 6 KiB of the display (the bitmap) are used as a
  \ buffer.

  \ Save the display contents to bank 4.
  4000 C000 1B00 4 BANK CMOVE 0 BANK

  \ Set all the display attributes to the current permanent
  \ paper color.  This way display garbage caused by the
  \ copying will not be seen.
  \   5C8D = system variable ATTR P (bits: 0-2=ink, 3-5=paper,
  \   6=bright, 7=flash)
  5800 300  5C8D C@ 38 AND DUP 8 / +  FILL

  \ Copy the old RAM-disk (screens 1-6) to the display.
  D000 4000 1800 CMOVE
  \ Copy it from the display to the current RAM-disk bank.
  4000 C000 1800 DISC-BANK BANK CMOVE 0 BANK
  \ Copy the old RAM-disk (screens 7-11) to the display.
  D000 1800 + 4000 1400 CMOVE
  \ Copy it from the display to the current RAM-disk bank.
  4000 C000 1800 + 1400 DISC-BANK BANK CMOVE 0 BANK

  \ Restore the display contents from bank 4.
  C000 4000 1B00 4 BANK CMOVE 0 BANK

  \ Make this word to forget itself.

  [ LATEST ] LITERAL DUP DP ! PFA LFA @ CURRENT @ !

  \ System words have been patched with new ones,
  \ therefore the changes must be protected.

  EXTEND  DECIMAL  ;  INSTALL

  \ vim: filetype=abersoftforthafera

.( 2NIP )

\ 2nip.fsb
\ '2NIP` 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).

CREATE 2NIP  ( x1 x2 x3 x4 -- x3 x4 )

HEX   E1 C,           \ pop hl
      D1 C,           \ pop de
      F1 C,           \ pop af
      F1 C,           \ pop af
      C3 C, PUSHDE ,  \ jp PUSHDE
      SMUDGE          DECIMAL

      \ vim: filetype=abersoftforthafera

\ 2rdrop.fsb
\ `2RDROP` 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-10: Start. Written with conditional compilation to
  \ reuse the code of `UNLOOP`, if present.

-->

.( 2RDROP )

CREATE 2RDROP  ( R: x1 x2 -- )

SMUDGE

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

  \ UNLOOP 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

.( 2R 2>R 2R> )

\ 2r.fsb
\ `2R`, `2>R` and `2R>` 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: First version 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.
  \
  \ 2015-10-26: Updated some comments.

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

  \ Address of the return stack pointer, returned by `RP@`.
[DEFINED] RP  ?\ HEX  5E68 CONSTANT RP  DECIMAL

-->

( 2R )

CREATE 2R  ( -- d ) ( R: d -- d )

  HEX

  D9 C,               \ exx ; preserve bc
  2A C, RP ,          \ ld hl,(RP) ; return stack pointer
  4E C, 23 C,         \ ld c,(hl) / inc hl
  46 C, 23 C,         \ ld b,(hl) / inc hl
  5E C, 23 C,         \ ld e,(hl) / inc hl
  56 C, 23 C,         \ ld d,(hl) / inc hl
  D5 C,               \ push de ; high part
  C5 C,               \ push bc ; low part
  D9 C,               \ exx ; restore bc
  C3 C, NEXT ,        \ jp NEXT

  SMUDGE DECIMAL -->

  \ XXX OLD -- High level version
  \ : 2R  ( -- d ) ( R: d -- d )  RP @ 2@  ;

( 2>R )

CREATE 2>R  ( d -- ) ( R: -- d )

  HEX

  D9 C,               \ exx ; preserve bc
  C1 C, D1 C,         \ pop bc / pop de
  \ bc = low part, de = high part
  2A C, RP ,          \ ld hl,(RP) ; return stack pointer
  2B C, 70 02 + C,    \ dec hl / ld (hl),d
  2B C, 70 03 + C,    \ dec hl / ld (hl),e
  2B C, 70 00 + C,    \ dec hl / ld (hl),b
  2B C, 70 01 + C,    \ dec hl / ld (hl),c
  22 C, RP ,          \ ld (RP),hl ; update the pointer
  D9 C,               \ exx ; restore bc
  C3 C, NEXT ,        \ jp NEXT

  SMUDGE DECIMAL -->

  \ XXX OLD -- High level version
  \ : 2>R  ( d -- ) ( R: -- d )
  \   COMPILE SWAP COMPILE >R COMPILE >R  ; IMMEDIATE

( 2R> )

CREATE 2R>  ( -- d ) ( R: d -- )

  HEX

  D9 C,               \ exx ; preserve bc
  2A C, RP ,          \ ld hl,(RP) ; return stack pointer
  4E C, 23 C,         \ ld c,(hl) / inc hl
  46 C, 23 C,         \ ld b,(hl) / inc hl
  5E C, 23 C,         \ ld e,(hl) / inc hl
  56 C, 23 C,         \ ld d,(hl) / inc hl
  D5 C,               \ push de ; high part
  C5 C,               \ push bc ; low part
  22 C, RP ,          \ ld (RP),hl ; update the pointer
  D9 C,               \ exx ; restore bc
  C3 C, NEXT ,        \ jp NEXT

  SMUDGE DECIMAL

  \ XXX OLD -- High level version
  \ : 2R>  ( -- d ) ( R: d -- )
  \  COMPILE R>  COMPILE R> COMPILE SWAP  ; IMMEDIATE

  \ vim: filetype=abersoftforthafera

\ 2slash.fsb
\ `2/` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)
\ Copyright (C) 1988 Lennart Benschop
\ 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

  \ 2015-04-16: Code written in the main file of the library,
  \ adapted from code written by Edmund Ramm (1985-05-07) for
  \ the Z80 fig-Forth implementation written by Dennis L.
  \ Wilson (1980-09-07).
  \
  \ 2015-04-23: Code fixed. Negative numbers didn't work
  \ because a wrong relative jump.
  \
  \ 2015-05-05: Extracted from the main file of the library.
  \
  \ 2015-08-12: New version, from Lennart Benschop's Spectrum
  \ Forth-83 (1988).

-->

.( 2/ )

  \ Code adapted from Lennart Benschop's Spectrum Forth-83
  \ (1988).

CREATE 2/  ( n1 -- n2 )
  HEX
  E1 C,           \ pop hl
  CB C, 2C C,     \ sra h
  CB C, 1D C,     \ rr l ; asr hl
  C3 C, PUSHHL ,  \ jp PUSHHL
  SMUDGE  DECIMAL

  \ XXX OLD -- previous version, adapted adapted from code
  \ written by Edmund Ramm (1985).

  \ CREATE 2/  ( n1 -- n2 )
  \   HEX
  \   E1 C,           \ pop hl
  \   CB C, 7C C,     \ bit 7,h ; negative?
  \   18 C, 01 C,     \ jr z,twosl1 ; no
  \   23 C,           \ inc hl ; yes, add 1
  \   \ twosl1:
  \   CB C, 2C C,     \ sra h
  \   CB C, 1D C,     \ rr l ; asr hl
  \   C3 C, PUSHHL ,  \ jp PUSHHL
  \   SMUDGE  DECIMAL

  \ vim: filetype=abersoftforthafera

.( 48K? 128K? )

\ 48kq.fsb
\ Memory size checks for ZX Spectrum's Abersoft Forth
\ and related system patches

\ 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 BANK bank

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

  \ 2015-04-07: Start. Code adapted from Lennart Benschop's
  \ Spectrum Forth-83.
  \ 
  \ 2015-05-07: Code moved to its own file, separated from
  \ `BANK`.
  \
  \ 2015-05-11: New: `CPUK`, `.CPUK` and patch for `.CPU`.
  \
  \ 2015-05-14: Already integrated into the main file of the
  \ library.
  \
  \ 2015-05-15: Restored.

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

HEX

: 48K?  (  -- f )

  \ Running on a 48K Spectrum?

  \ An address in range 0xC000..0xFFFF is modified, then
  \ checked after paging a different memory bank in, and
  \ finally restored. If the contents of the address changed,
  \ that means the paging had no effect, so it's a 48K.
  \
  \ This code was adapted from Lennart Benschop's Spectrum
  \ Forth-83.

  0 BANK FFFE @ 0 FFFE !  1 BANK FFFE @ 1 FFFE !
  0 BANK FFFE @ >R  1 BANK FFFE !  0 BANK FFFE !  R>  ;

: 128K?  (  -- f )  48K? 0=  ;

DECIMAL  -->

( CPUK .CPUK )

: CPUK  ( -- n )  \ KiB of the machine.
  48 128K? 80 * + ;

: .CPUK  ( -- )  \ Print the computer family, 48K or 128K.
  BASE @ DECIMAL SPACE CPUK 2 .R ." K" BASE !  ;

  \ Substitute the temporary `NOOP` that was added after the
  \ new message of `.CPU`:
' .CPUK CFA ' .CPU 14 + !

EXTEND \ protect the patches

  \ vim: filetype=abersoftforthafera