Fuente de Afera (parte 3: nombres de módulo D-G)

Descripción del contenido de la página

Cuarta parte de las fuentes de la biblioteca Afera para Abersoft Forth.

Etiquetas:

Código fuente

.( DECODE )

\ decode.fsb
\ `DECODE` for ZX Spectrum Abersoft Forth

\ Copyright (C) 2015 Marcos Cruz (programandala.net)
\ Copyright (C) 1984 EHR
\ Copyright (C) 1982 Robert Dudley Ackerman

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

\ Adapted and deeply modified from:

\ Z80 CP/M fig-Forth 1.1g (adaptative version by EHR).
\ Original code by Robert Dudley Ackerman, published in
\ Forth Dimensions IV,#2 p28 (1982-07);
\ modified by Dennis L. Wilson.

  \ 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 RECURSE   recurse

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

  \ 2015-04-17: Code copied and adapted from Z80 CP/M fig-Forth
  \ 1.1g. It works fine.
  \
  \ 2015-05-03: Improvement: The current address is shown, in
  \ hex.  Clearer instructions.
  \
  \ 2015-05-04: No hex forced, the current base is used.
  \
  \ 2015-05-07:
  \
  \ The code that handles the special decoding cases and the
  \ key selection have been rewritten with `CASE` structures,
  \ easier to read, maintain and extend.
  \
  \ The check that prevented from decoding `ERROR` has been
  \ removed.
  \
  \ Improvement: The destination address of branches is shown
  \ after the relative value.
  \
  \ The main code has been divided in smaller pieces, easier to
  \ understand and maintain.
  \
  \ 2015-05-13: Fix: the address shown at the left of the colon
  \ was the last value of `DECODE-ADDRESS`. Now it's the nfa of
  \ the definition. The check in `INDENT` is removed.
  \
  \ 2015-05-17: `NEEDS` used. Improved with run-time and
  \ shorter instructions.

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

-->

( DECODE -- variables, indentation and pause control )


FORTH DEFINITIONS DECIMAL

0 VARIABLE DECODE-LEVEL    \ depth of nesting
0 VARIABLE DECODE-ADDRESS  \ in the word being decoded

: INDENT  ( -- )
  CR DECODE-ADDRESS @ U. DECODE-LEVEL @ 2 * SPACES  ;

: INDENT+  ( -- )  1 DECODE-LEVEL +! INDENT ;

-->

( DECODE -- Special cases )

: DECODE-COMPILE  ( a1 -- a2 )  2+ DUP @ 2+ NFA ID.  ;

: DECODE-LITERAL  ( a1 -- a2 )  2+ DUP @ .  ;

: DECODE-BRANCH  ( a1 -- a2 )
  DECODE-LITERAL  ."  \ to " DUP DUP @ + U.  ;

: DECODE-DOT-QUOTE  ( a1 -- a2 )
  2+ DUP COUNT TYPE  DUP C@ + 1 -  ;

-->

( DECODE -- Special cases dispatcher )

: DECODE-SPECIAL-CASES  ( a1 -- a1 | a2 )
  DUP @ CASE
          [ ' COMPILE CFA ] LITERAL OF  DECODE-COMPILE    ENDOF
          [ ' LIT     CFA ] LITERAL OF  DECODE-LITERAL    ENDOF
          [ ' BRANCH  CFA ] LITERAL OF  DECODE-BRANCH     ENDOF
          [ ' 0BRANCH CFA ] LITERAL OF  DECODE-BRANCH     ENDOF
          [ ' (LOOP)  CFA ] LITERAL OF  DECODE-BRANCH     ENDOF
          [ ' (+LOOP) CFA ] LITERAL OF  DECODE-BRANCH     ENDOF
          [ ' (.")    CFA ] LITERAL OF  DECODE-DOT-QUOTE  ENDOF
        ENDCASE  ; 
-->

( DECODE -- checks of the main code )

: DECODE-END?  ( cfa -- f )
  \ Is the given cfa the end of a definition?
  DUP  ' ;S CFA =  SWAP ' (;CODE) CFA =  OR  ;

: COLON-PFA?  ( pfa -- f )
  \ Is the given pfa a colon definition?
  CFA @ ' : CFA @ =  ;

-->

( DECODE -- main code )

: (DECODE)  ( pfa --- )

  \ Decode the definition at the given pfa.

  DUP COLON-PFA? IF
    DUP NFA DECODE-ADDRESS ! INDENT  ." : " DUP NFA ID.
    BEGIN   ( pfa+n ) DUP DECODE-ADDRESS !
            DUP @ DUP ( pfa+n cfa cfa ) DECODE-END? 0=
            \ ( pfa+n cfa f )
    WHILE  \ high level & NOT end of colon definition
      \ ( pfa+n cfa )
      ( pfa+n cfa ) 2+ ( pfa+n pfa' ) DUP INDENT+  NFA ID.
      KEY CASE  [CHAR] Q  OF  SP! QUIT  ENDOF \ Q
                      BL  OF  DROP      ENDOF \ Space
                                 SWAP RECURSE \ Default
          ENDCASE  DECODE-SPECIAL-CASES
      2+  -1 DECODE-LEVEL +!
    REPEAT  INDENT 2+ NFA ID. \ show the last word
  ELSE  ." Not a colon definition."  THEN  DROP  ;  -->

( DECODE -- interface )

: DECODE-USAGE  ( -- )
     \  <------------------------------>
  CR ." Keys: Space=more, Q=quit, other=deeper." CR  ;

: DECODE  ( "name" -- )
  DECODE-USAGE
  -FIND IF    DROP 0 DECODE-LEVEL ! (DECODE)
        ELSE  ." Not Found"  THEN  ;

  \ vim: filetype=abersoftforthafera

.( DEFER )

\ defer.fsb
\ Deferred words 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: Start.
  \
  \ 2015-04-02: Fix.
  \
  \ 2015-07-04: Typo. Simpler `ACTION-OF`.
  \
  \ 2015-07-07: Revised, tested, fixed, simplified (removed
  \ `[IS]` and `<IS>`), documented.
  \
  \ 2015-10-26: Improved and fixed some comments.
  \
  \ 2016-01-25: Layout.

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

-->

( Create and fetch deferred words )

: (DEFER)  ( -- )
  \ Default behaviour of an uninitialized deferred word:
  \ "Definition not finished".
  20 ERROR  ;

: DEFER  ( "name" -- )
  \ Create a deferred word.
  \ Note: using `:` and `;` is more compact and faster
  \ than using `<BUILDS` and `DOES>` in this case.
  [COMPILE] : COMPILE (DEFER) [COMPILE] ;  ;

: DEFER@  ( pfa -- cfa )
  \ pfa = parameter field address of a deferred word
  \ cfa = code field address the deferred word
  \       is set to execute
  @  ;

: DEFERS  ( "name" -- )
  \ Compile the present contents of the deferred word "name"
  \ into the current definition. I.e. this produces static
  \ binding as if "name" was not deferred.
  [COMPILE] ' DEFER@ ,  ; IMMEDIATE

: ACTION-OF  ( Interpretation: "name" -- cfa )
             ( Compilation:    "name" -- )
             ( Runtime:        -- cfa )
  \ "name" = name of a deferred word
  \ cfa = code field address the deferred word
  \       is set to execute
  [COMPILE] '  STATE @ IF    COMPILE DEFER@
                       ELSE  DEFER@  THEN  ; IMMEDIATE

-->

( Set deferred words -- version with CFA )

  \ This version uses a cfa (code field address) to set the
  \ deferred words. This version seems a better compromise than
  \ the pfa version (see next screen), therefore it's loaded by
  \ default.
  \
  \ Note: Since fig-Forth's `'` returns a pfa (parameter field
  \ address) `CFA` must be used to convert it to the
  \ correspondent cfa required by `IS` or `DEFER!`. `:NONAME`
  \ returns a cfa (see the module <noname.fsb>), so it can be
  \ used directly with `IS` and `DEFER!`.
  \
  \ Usage examples:

  \   DEFER MYWORD
  \
  \   ' WHATEVER-0 CFA IS MYWORD
  \   MYWORD  \ execute WHATEVER-0
  \
  \   ' WHATEVER-1 CFA ' MYWORD DEFER!
  \   MYWORD  \ execute WHATEVER-1
  \
  \   :NONAME WHATEVER-2 ;  IS MYWORD
  \   MYWORD  \ execute WHATEVER-2
  \
  \   :NONAME WHATEVER-3 ;  ' MYWORD DEFER!
  \   MYWORD  \ execute WHATEVER-3

: DEFER!  ( cfa pfa -- )  !  ;

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

( Set deferred words -- version with PFA )

  \ This version uses a pfa (parameter field address) to set
  \ the deferred words.
  \
  \ Note: Since `:NONAME` is written after ANS Forth and so it
  \ returns a cfa (see the module <noname.fsb>), `2+` must be
  \ used to convert it to the pfa required by `IS`.
  \
  \ Usage examples:

  \   DEFER MYWORD
  \
  \   ' WHATEVER-0 IS MYWORD
  \   MYWORD  \ execute WHATEVER-0
  \
  \   ' WHATEVER-1 ' MYWORD DEFER!
  \   MYWORD  \ execute WHATEVER-1
  \
  \   :NONAME WHATEVER-2 ;  2+ IS MYWORD
  \   MYWORD  \ execute WHATEVER-2
  \
  \   :NONAME WHATEVER-3 ;  2+ ' MYWORD DEFER!
  \   MYWORD  \ execute WHATEVER-3

: DEFER!  ( pfa1 pfa2 -- )  SWAP CFA SWAP !  ;

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

  \ vim: filetype=abersoftforthafera

\ dminus.fsb
\ `D-` 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.

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

  \ In fig-Forth `DMINUS D+` can be used instead of `D-`,
  \ but `D-` is faster.

  \ -----------------------------------------------------------
  \ History
  
  \ 2015-04-18: Code adapted from Lennart Benschop's Spectrum
  \ Forth-83.
  \
  \ 2015-06-06: New version compiled directly with opcodes,
  \ without the assembler.
  \
  \ 2015-10-26: Fixed the layout.
  
  \ -----------------------------------------------------------

-->

( D- ) \ version compiled with opcodes

CREATE D-  ( d1 d2 -- d3 )
HEX   D9 C,             \ exx
      C1 C,             \ pop bc
      D1 C,             \ pop de
      E1 C,             \ pop hl
      E3 C,             \ ex (sp),hl
      A0 07 + C,        \ and a
      ED C, 52 C,       \ sbc hl,de
      E3 C,             \ ex (sp),hl
      A0 07 + C,        \ and a
      ED C, 42 C,       \ sbc hl,bc
      E5 C,             \ push hl
      D9 C,             \ exx
      C3 C, NEXT ,      \ jp NEXT
      SMUDGE DECIMAL

( D- ) \ assembler version

NEEDS CODE assembler

CODE D-  ( d1 d2 -- d3 )
  EXX
  BC POP
  DE POP
  HL POP
  EXSP
  DE SUBP
  EXSP
  BC SBCP
  HL PUSH
  EXX
  NEXT JP
END-CODE

  \ vim: filetype=abersoftforthafera

.( .RS )

\ dot-rs.fsb
\ `.RS` for ZX Spectrum Abersoft Forth

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

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)

  \ 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-15: Written after the code of `.S`.

[DEFINED] RDEPTH
?\  : RDEPTH  ( -- u )  RP@ R0 @ - -2 /  ;

: .RS   ( -- )

  RDEPTH 2- DUP
  S->D <# [CHAR] > HOLD #S [CHAR] < HOLD #> TYPE SPACE

  IF  RP@ 2- R0 @ 2- DO I @ . -2 +LOOP  THEN  ;

  \ vim: filetype=abersoftforthafera


.( .S )

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

\ Copyright (C) 2015 Marcos Cruz (programandala.net)
\ Copyright (C) 1990-2013 Matteo Vitturi

\ This file is part of
\ Afera (Abersoft Forth Extensions, Resources and Addons)

  \ 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-30: First version.
  \ 2015-04-14: Second version, from Matteo Vitturi's vForth.
  \ 2015-04-19: Combined version.
  \ 2015-10-26: Updated header.

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

: .S   ( -- )

  DEPTH
  DUP S->D <# [CHAR] > HOLD #S [CHAR] < HOLD #> TYPE SPACE

  \ First version:
  \ DEPTH -DUP IF  0 DO  DEPTH I - 1 - PICK .  LOOP  THEN

  \ Second version, from Matteo Vitturi's vForth:
  \ SP@ 2 - S0 @ 2 - DO I @ . -2 +LOOP

  \ Combined version:
  IF  SP@ 2- S0 @ 2- DO I @ . -2 +LOOP  THEN

  ;

  \ vim: filetype=abersoftforthafera

.( .VOCS )

\ dot-vocs.fsb
\ `.VOCS` for ZX Spectrum Abersoft Forth

\ Copyright (C) 1990-2013 Matteo Vitturi

\ 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-17: Copied from Mateo Vitturi's v.Forth 1.3
  \ (1990-2013).

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

: .VOCS  ( -- )
  CR ." Current " CURRENT @ 4 - NFA ID.
  CR ." Context " CONTEXT @ 4 - NFA ID.  ;

  \ vim: filetype=abersoftforthafera

.( DUMP )

\ dump.fsb
\ `DUMP` 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 CSWAP cswap

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

  \ 2015-03-26: Start. Copied from Lennart Benschop's Spectrum
  \ Forth-83.
  \
  \ 2015-03-28: Simple version as a temporary alternative,
  \ until `?DO` is defined.
  \
  \ 2015-04-17: The code from ZX Spectrum Forth-83 has been
  \ adapted, with `IF ... DO` instead of `?DO`.
  \
  \ 2015-04-20: Fix in `H.`.
  \
  \ 2015-05-17: `NEEDS` used.

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

-->

( BS H. STYPE )

: BS  ( -- )  8 EMIT  ;

: H.  ( n -- )
  \ Print n in hexadecimal with four digits.
  BASE @ HEX SWAP S->D <# # # # # #> TYPE SPACE BASE !  ;

HEX

: STYPE  ( ca len -- )
  0 2DUP - IF
    DO
      DUP C@ 7F AND DUP BL < IF  DROP [CHAR] .  THEN  EMIT 1+
    LOOP
  ELSE  2DROP  THEN  DROP  ;

DECIMAL  -->

( DUMP )

: DUMP  ( a len -- )
  7 + -8 AND 8 / 0
  2DUP - IF
    DO
      CR DUP H.
      8 0 DO
        I OVER + @ CSWAP H.
      2 +LOOP
      DUP BS 8 STYPE
      ?TERMINAL IF  LEAVE  THEN
    8 + LOOP
  ELSE  2DROP  THEN  DROP  ;

  \ vim: filetype=abersoftforthafera

\ flags.fsb
\ Boolean flags 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-16: Extracted from the main file of the library.
  \ `ON` and `OFF` are rewritten in Z80.
  \
  \ 2015-04-23: Faster and smaller version of `OFF`.

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

-->

.( FALSE TRUE )

       0 CONSTANT FALSE
FALSE 0= CONSTANT TRUE

-->

.( ON OFF )

CREATE ON   ( a -- )          HEX
  \ TRUE SWAP !
  E1 C,        \ pop hl
  36 C, 01 C,  \ ld (hl),1  ; 10T
  23 C,        \ inc hl     ; 06T
  36 C, 00 C,  \ ld (hl),0  ; 10T
  C3 C, NEXT , \ jp NEXT
  SMUDGE

CREATE OFF  ( a -- )
  \ FALSE SWAP !
  E1 C,        \ pop hl
  A8 07 + C,   \ xor a      ; 04T
  70 07 + C,   \ ld (hl),a  ; 07T
  23 C,        \ inc hl     ; 06T
  70 07 + C,   \ ld (hl),a  ; 07T
  C3 C, NEXT , \ jp NEXT
  SMUDGE                      DECIMAL

  \ vim: filetype=abersoftforthafera

.( G+DOS -- part 1 )

\ gplusdos_1.fsb
\ G+DOS support for ZX Spectrum Abersoft Forth (part 1)

\ Copyright (C) 1988,1994,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 CODE assembler

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

  \ 2015-03-13: Start, based on code already written in 1988
  \ and 1994.
  \
  \ 2015-04-01: Checks.
  \
  \ 2015-04-02: First succesful compilation, after some fixes
  \ in the assembler. Some words renamed. New: alternative
  \ words that don't use `?ERROR` but return the error
  \ parameters.
  \
  \ 2015-04-07: Renamed to <gdos.fsb> (formerly
  \ <gplusdos.fsb>).
  \
  \ 2015-04-14: New: the list of hooks has been completed;
  \ `GDOS?` and `G+DOS?+'.
  \
  \ 2015-04-16: Change: `GDOS?` and `G+DOS?+' are removed.  It
  \ doesn't worth the effort to make the code compatible with
  \ both GDOS and G+DOS, because all low level operations
  \ should be duplicated. Even the word `GDOS?` should use a
  \ different port to page the interface out, DISCiPLE or +D,
  \ depending on its own result!  Only G+DOS will be supported.
  \ File renamed to <g+dos_1.fsb>.
  \
  \ 2015-05-08: Renamed to <gplusdos_1.fsb>, because of an
  \ issue with Makefile.
  \
  \ 2015-05-12: Improvement: `DEVICE` is not a variable to
  \ update UFIA with anymore, but the address of the
  \ correspondent byte in UFIA, faster and shorter.

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

FORTH DEFINITIONS DECIMAL

10 CONSTANT /FILENAME  \ max filename length

1 VARIABLE DRIVE

  \ G+DOS addresses (in it own paged memory).
HEX 3E01 CONSTANT UFIA1 DECIMAL
\ 3E1A CONSTANT UFIA2

2 6 THRU

( UFIA: User File Information Area)

24 CONSTANT /UFIA  /UFIA BUFFER: UFIA  UFIA /UFIA ERASE

  \ Note: The original field names are used, except `DEVICE`,
  \ whose original name is "LSTR1".

UFIA      CONSTANT DSTR1 \ drive: 1 or 2
UFIA 1+   CONSTANT FSTR1 \ program number
UFIA 2+   CONSTANT SSTR1 \ stream number
UFIA 3 +  CONSTANT DEVICE \ device: "D" or "d"
UFIA 4 +  CONSTANT NSTR1 \ directory description
UFIA 5 +  CONSTANT NSTR2 \ file name
UFIA 15 + CONSTANT HD00  \ file type
UFIA 16 + CONSTANT HD0B  \ file length
UFIA 18 + CONSTANT HD0D  \ file start address
  \ XXX OLD -- not needed
  \ UFIA 20 + CONSTANT HD0F  \ BASIC length without variables
  \ UFIA 22 + CONSTANT HD11  \ BASIC autorun line

CHAR d DEVICE C! \ "d" or "D"
2 SSTR1 C! \ stream 2

  \ These variables hold a copy of the HD0B and HD0D UFIA
  \ fields. They are used by `(<DISK)`.
0 VARIABLE FILE-LENGTH
0 VARIABLE FILE-ADDRESS

( File types, directory descriptions and hook codes)

  \ XXX TODO Move all this constants to another file, as
  \ reference. They ocuppy a lot and most of them are not
  \ necessary.

  \ File types

0 CONSTANT BASIC-FILETYPE  1 CONSTANT DATA-ARRAY-FILETYPE
2 CONSTANT STRING-ARRAY-FILETYPE  3 CONSTANT CODE-FILETYPE

  \ Directory descriptions

  01 CONSTANT BASIC-FILE      02 CONSTANT DATA-ARRAY
  03 CONSTANT STRING-ARRAY    04 CONSTANT CODE-FILE
  05 CONSTANT SNAPSHOT-48K    06 CONSTANT MICRODRIVE-FILE
  07 CONSTANT SCREENS$-FILE   08 CONSTANT SPECIAL-FILE
  09 CONSTANT SNAPSHOT-128K   10 CONSTANT OPENTYPE-FILE
  11 CONSTANT EXECUTE-FILE                              HEX

  \ Hook codes

33 CONSTANT HXFER 34 CONSTANT OFSM  35 CONSTANT HOFLE
36 CONSTANT SBYT  37 CONSTANT HSVBK 38 CONSTANT CFSM
39 CONSTANT PNTP  3A CONSTANT COPS  3B CONSTANT HGFLE
3C CONSTANT LBYT  3D CONSTANT HLDBK 3E CONSTANT WSAD
3F CONSTANT SAD   40 CONSTANT REST  41 CONSTANT HERAZ
42 CONSTANT COPS2 43 CONSTANT PCAT  44 CONSTANT HRSAD
45 CONSTANT HWSAD 46 CONSTANT OTFOC 47 CONSTANT PATCH   DECIMAL

( Error checking)

  \ G+DOS Error codes and messages.
  \ Most of them are useless for this implementation.

  \ 0x00  'Nonsense in G+DOS'
  \ 0x01  'Nonsense in GNOS'
  \ 0x02  'Statement END error'
  \ 0x03  'BREAK requested'
  \ 0x04  ',SECTOR error'
  \ 0x05  'FORMAT data lost'
  \ 0x06  'CHECK DISC in drive'
  \ 0x07  'No "+ SYS " file'
  \ 0x08  'Invalid FILE NAME'
  \ 0x09  'Invalid STATION'
  \ 0x0A  'Invalid DEVICE'
  \ 0x0B  'VARIABLE not found'
  \ 0x0C  'VERIFY failed'
  \ 0x0D  'Wrong FILE type'
  \ 0x0E  'MERGE error'
  \ 0x0F  'CODE error'
  \ 0x10  'PUPIL set'
  \ 0x11  'Invalid CODE'
  \ 0x12  'Reading a WRITE file'
  \ 0x13  'Writing a READ file'
  \ 0x14  'O.K. G+DOS'
  \ 0x15  'Network OFF'
  \ 0x16  'Wrong DRIVE'
  \ 0x17  'Disc WRITE protected'
  \ 0x18  'Not enough SPACE on disc'
  \ 0x19  'Directory FULL'
  \ 0x1A  'File NOT FOUND'
  \ 0x1B  'END of file'
  \ 0x1C  'File NAME used'
  \ 0x1D  'NO G+DOS loaded'
  \ 0x1E  'STREAM used'
  \ 0x1F  'CHANNEL used'

: IOR>ERROR  ( ior -- f n )

  \ Convert a DOS ior to a Forth error number.

  \ ior = the AF register returned by a DOS command:
  \     bit 0     = set: error
  \     bits 8-14 = error code
  \     bit 15    = set: ZX Spectrum error; unset: DOS error
  \ f = error?
  \ n = error number:
  \     n<0  = ZX Spectrum error number (negative)
  \     n>99 = DOS error number (plus 100)

  DUP 1 AND    \ error?
  SWAP 255 /   \ error code
  DUP 128 AND  \ ZX Spectrum error?
  IF  MINUS  ELSE  100 +  THEN   ;

: ?DOS-ERROR  ( ior -- )
  \ ior = the AF register returned by a DOS command:
  \   bit 0     = set: error
  \   bits 8-14 = error code
  \   bit 15    = set: ZX Spectrum error; unset: DOS error
  IOR>ERROR ?ERROR  ;

( Drive)

  \ XXX TODO -- Make this compatible with `DRIVE`, the variable
  \ used by the tape and disk common words.

CODE DRIVE@  ( -- n )
  \ Get the current drive (1 or 2).
  BC PUSH  IX PUSH  \ save the Forth registers
  PATCH HOOK
  \ 3E01 LDA  \ XXX OLD
  3ACE LDA  \ XXX NEW
  \ XXX TODO check this method:
  \ bit 0 of 3DD1
  E7 OUT  \ page +D out
  IX POP  BC POP  \ restore the Forth registers
  0 H LD#  A L LD  PUSHHL JP  END-CODE

CODE DRIVE!  ( n -- )
  \ Set the current drive (1 or 2).
  HL POP
  BC PUSH  IX PUSH  \ save the Forth registers
  \ XXX OLD
  \ HL PUSH
  \ PATCH HOOK  HL POP  L A LD  3E01 STA
  \ E7 OUT  \ page +D out
  \ XXX NEW
  L A LD  21 HOOK
  IX POP  BC POP  \ restore the Forth registers
  NEXT JP  END-CODE

( UFIA manipulation)

: -FILENAME  ( -- )
  \ Blank the filename in UFIA.
  NSTR2 /FILENAME BLANKS  ;

: FILENAME!  ( ca len -- )
  \ Store a filename into UFIA.
  \ ca len = filename
  -FILENAME /FILENAME MIN NSTR2 SWAP CMOVE  ;

: >UFIA  ( a1 len1 ca2 len2 -- )
  \ Set the UFIA.
  \ a1 len1   = memory region
  \ ca2 len2  = filename
  3 HD00 C!  4 NSTR1 C!  \ code filetype and dir description
  FILENAME!
  DUP HD0B !  FILE-LENGTH !
  DUP HD0D !  FILE-ADDRESS !
  DRIVE @ DSTR1 C!  ;

: FILENAME>UFIA  ( ca len -- )
  0 0 2SWAP >UFIA  ;

  \ vim: filetype=abersoftforthafera

.( G+DOS -- part 2 )

\ gplusdos_2.fsb
\ G+DOS support for ZX Spectrum Abersoft Forth (part 2)

\ Copyright (C) 1988,1994,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 CODE assembler

  \ -----------------------------------------------------------
  \ Note

  \ "DISC" in Forth words means the Forth RAM-disk, after the
  \ name used by Abersoft Forth's documentation and vocabulary,
  \ e.g.  `INIT-DISC`.
  \
  \ "DISK" means always a G+DOS disk.
  \
  \ In the comments of this library, "disc" is not used, and
  \ the Abersoft Forth RAM-disk is always called "RAM-disk".

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

  \ This module needs the circular string buffer, part of the
  \ module <strings.fsb>. But `NEEDS` can not be used yet
  \ because it must be defined later.

  [UNDEFINED] SAVE-STRING 0 ?ERROR

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

  \ 2015-04-15: Extracted from <gdos_1.fsb>.
  \
  \ 2015-04-16: File renamed to <g+dos_2.fsb>.
  \
  \ 2015-04-30: New version of `RUND` and new word `/RUND`,
  \ after the tape versions `RUNT` and `/RUNT`. `'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: Renamed to <gplusdos_2.fsb>, because of an
  \ issue with Makefile. Some words are renamed.
  \
  \ 2015-05-10: `'BLOCK` changed to `'SCR`, after the changes
  \ in the library.
  \
  \ 2015-05-12:
  \
  \ The "RAM-" prefix is removed from the RAM-disk words, after
  \ the changes in the library. Minor fixes: `EMPTY-BUFFERS`
  \ instead of `FLUSH`; parameter of `/RUND`.
  \
  \ Fix: `(<DISK)`. The problem was the specified parameters,
  \ stored in UFIA, are always overwritten by the file header.
  \ Now they are saved apart and a calculation is done to
  \ decide which start address and file length must be used.
  \
  \ Change: `'SCR` renamed to `DISC-SCR`, after the changes in
  \ the library.
  \
  \ 2015-05-17: New: `FILE?`. Some renamings, after the changes
  \ in the library (common core words for some tape and disk
  \ operations).
  \
  \ 2015-05-18: New: support for 16-KiB RAM-disks in memory
  \ banks.
  \
  \ 2015-05-20: The `CAT` code, still under development, is
  \ moved to its own file.
  \
  \ 2015-08-28: Typo.

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

2 10 THRU

( Save a file)

CODE (>FILE)  ( -- ior )

  \ Save a file to disk using the data hold in UFIA.

  BC PUSH  IX PUSH  \ save the Forth registers
  UFIA IX LDP#
  HOFLE HOOK \ open the file and create its header
  NC IF \ no error?
    HD0D DE LDP \ start
    HD0B BC LDP \ length
    HSVBK HOOK \ save to file
    NC IF  \ no error?
      CFSM HOOK  \ close the file
    THEN
  THEN  IX POP  BC POP  \ restore the Forth registers
  AF PUSH  \ ior
  NEXT JP
  END-CODE

( Load a file -- part 1 )

CODE (<FILE)  ( -- ior )

  \ Load a file from disk, using the data hold in UFIA, the
  \ file header and the parameters specified by the high level
  \ command.

  BC PUSH  IX PUSH  \ save the Forth registers

  UFIA IX LDP#  HGFLE HOOK \ get the file
  NC IF \ no error?  -- load the file header:

    \ Load the file header
    HD00 DE LDP# 9 B LD# \ destination and count
    BEGIN
      LBYT HOOK \ load byte and store it in A
      DE STAP  DE INCP  \ update destination and count
    DSZ

( Load a file -- part 2 )

    \ The start address and length specified
    \ in the command are used by default instead
    \ of those stored in the file header.
    FILE-ADDRESS DE LDP
    FILE-LENGTH BC LDP

    BC TST  \ is the length zero?
    \ If so, use the length of the file header instead:
    Z IF  HD0B BC LDP  THEN

    \ Load the file data
    HLDBK HOOK

  THEN

  IX POP  BC POP  \ restore the Forth registers
  AF PUSH  \ ior
  NEXT JP

END-CODE

( Delete a file)

CODE (-FILE)  ( -- ior )

  \ Delete a disk file using the data hold in UFIA.

  BC PUSH  IX PUSH  \ save the Forth registers
  UFIA IX LDP#
  HERAZ HOOK \ erase the file
  IX POP  BC POP  \ restore the Forth registers
  AF PUSH
  NEXT JP
  END-CODE

( Forth RAM-disk)

: DISC>UFIA  ( ca len -- )  LO 0 2SWAP >UFIA  ;

  \ `DISC-FILENAME` keeps the address and length of the latest
  \ RAM-disk loaded. It is updated by `LOADD?` and used by
  \ `(NEEDS-DISK)` to implement nested requirements between
  \ modules.

0. 2VARIABLE DISC-FILENAME

  \ When the system has been lowered below 0xC000 by
  \ <lowersys.fsb>, in order to use the memory banks, and the
  \ 16-KiB RAM-disks have been installed by <16kramdisks.fsb>,
  \ the G+DOS words that manage the Forth RAM-disk must include
  \ the commands to switch the memory banks.
  \
  \ A flag is calculated to be used by `SAVED?` and `LOAD?`
  \ during compilation. Every word needs to check the flag
  \ twice. The flag can not be put on the stack and duplicated,
  \ because it would be consumed during the compilation, what
  \ would make `;` to stop with an error 20 (definition not
  \ finished). The variable `X1`, only used by `DRAW`, is used
  \ as a temporary storage.

HEX
R0 @ C000 U<      \ Has the system been lowered below 0xC000
/DISC 4000 =  AND \ and the 16-KiB RAM-disks installed?
0= X1 !           \ No? Save it into a temporary storage.
DECIMAL

  \ XXX TODO -- Use a different address to store the flag. One
  \ of the planned modules removes `DRAW` and its variables
  \ from the dictionary and redefines it in Z80.

( Forth RAM-disk -- user interface)

  \ DISC>UFIA  ( ca len -- )
  \
  \ Init the User File Information Area to load or save the
  \ Forth RAM-disk.  Zero length is specified, what will make
  \ `(<FILE)` to use the length of the file header.
  \
  \ ca1 len1 = filename

: SAVED?  ( ca len -- f n )
  \ Save the Forth RAM-disk to disk
  \ (word named after Abersoft Forth's `SAVET`).
  \ ca len  = filename
  \ f       = error?
  \ n       = error
  \ During compilation, as a temporary solution,
  \ `X1` holds a flag: Use the original RAM-disk?
  DISC>UFIA       [ X1 @ ] ?\ DISC-BANK BANK
  (>FILE)    [ X1 @ ] ?\ 0 BANK
  IOR>ERROR  ;

  \ SAVED  ( ca len -- )
  \
  \ Save the Forth RAM-disk to disk
  \ (word named after Abersoft Forth's `SAVET`).
  \ ca len = filename

: SAVED  ( ca len -- )  SAVED? ?ERROR  ;

  \ The latest filename used to load a RAM-disk is saved by
  \ `LOADD?` (the lowest level word) into the circular string
  \ buffer and its address and length are stored into a double
  \ variable.

: LOADD?  ( ca len -- f n )
  \ Load a Forth RAM-disk from disk.
  \ (word named after Abersoft Forth's `LOADT`).
  \ ca len  = filename
  \ f       = error?
  \ n       = error
  \ During compilation, as a temporary solution,
  \ `X1` holds a flag: Use the original RAM-disk?
  SAVE-STRING 2DUP DISC-FILENAME 2!
  DISC>UFIA       [ X1 @ ] ?\ DISC-BANK BANK
  (<FILE)    [ X1 @ ] ?\ 0 BANK
  IOR>ERROR  ;

  \ LOADD  ( ca len -- )
  \
  \ Load a Forth RAM-disk from disk.
  \ (word named after Abersoft Forth's `LOADT`).
  \ ca len = filename

: LOADD  ( ca len -- )  LOADD? ?ERROR  ;

: /RUND  ( ca len n -- )
  \ Read a new RAM-disk from disk and load block 'n'.
  \ ca len = filename
  >R EMPTY-BUFFERS INIT-DISC LOADD R> LOAD  ;

  \ RUND  ( ca len -- )
  \
  \ Read a new RAM-disk from disk and load its first block.
  \ ca len = filename

: RUND  ( ca len -- )  1 /RUND  ;

( User interface: ordinary files )

: <FILE?  ( a1 len1 ca2 len2 -- f n )
  \ Load a file from disk.
  \ a1 len1   = memory region to load
  \ ca2 len2  = filename
  \ f         = error?
  \ n         = error
  >UFIA (<FILE) IOR>ERROR  ;

: <FILE  ( a1 len1 ca2 len2 -- )
  \ Load a file from disk.
  \ a1 len1   = memory region to load
  \ ca2 len2  = filename
  <FILE? ?ERROR  ;

: >FILE?  ( ca1 len1 ca2 len2 -- f n )
  \ Save a file to disk.
  \ a1 len1   = memory region to save
  \ ca2 len2  = filename
  \ f         = error?
  \ n         = error
  >UFIA (>FILE) IOR>ERROR  ;

: >FILE  ( ca1 len1 ca2 len2 -- )
  \ Save a file to disk.
  \ a1 len1   = memory region to save
  \ ca2 len2  = filename
  >FILE? ?ERROR  ;

: -FILE?  ( ca len -- f n )
  \ Delete a disk file.
  \ ca len  = filename
  \ f       = error?
  \ n       = error
  FILENAME>UFIA (-FILE) IOR>ERROR  ;

: -FILE  ( ca len -- )
  \ Delete a disk file.
  \ ca len = filename
  -FILE? ?ERROR  ;

( FILE? )

CODE (FILE?)  ( -- f )

  \ XXX FIXME this changes the current drive to 2! why?

  BC PUSH  IX PUSH  \ save the Forth registers
  PATCH HOOK
  NSTR2 IX LDP#  1146 CALL
  E7 OUT  \ page +D out
  IX POP  BC POP  \ restore the Forth registers
  0 HL LDP#  PUSHHL JPNZ
  HL INCP    PUSHHL JP
  END-CODE

: FILE?  ( ca len -- f )  FILENAME! (FILE?)  ;

  \ CODE DISK-CAPACITY  ( -- n )

  \   \ n = tracks (+128 if double sided)
  \   \
  \   \ XXX OLD -- not useful, it just reads the DOS variable at
  \   \ 0x2001 or 0x2002, depending on the current drive.

  \   PATCH HOOK
  \   0985 CALL
  \   E7 OUT  \ page +D out
  \   0 H LD#  A L LD  PUSHHL JP

  \   END-CODE

( User interface: screens of the Forth RAM-disk )

  : (/LOADD)  ( n ca len -- a len1 ca2 len2 )
    \ Prepare the parameters to load a RAM-disk from disk,
    \ at address of screen n.
    \ Warning: the file will be loaded, no matter its length.
    \ n = first block (1..11)
    ROT FLUSH DISC-SCR 0 2SWAP ;

  : /LOADD  ( n ca len -- )
    \ Load a RAM-disk from disk, at address of screen n.
    \ Warning: the file will be loaded, no matter its length.
    \ n = first screen (1..11)
    (/LOADD) <FILE  ;

  : /LOADD?  ( n ca len -- error? error )
    \ Load a RAM-disk from disk, at address of screen n.
    \ Warning: the file will be loaded, no matter its length.
    \ n = first screen (1..11)
    (/LOADD) <FILE?  ;

  : (/SAVED)  ( n1 n2 ca len -- ca len ca2 len2 )
    \ Prepare the parameters to save a RAM-disk to disk,
    \ from screen n1 to screen n2.
    \ n1 = first screen (1..11)
    \ n2 = last screen (1..11)
    \ ca len = filename
    \ ca2 len2 = memory zone
    2SWAP 1+ DISC-SCR SWAP DISC-SCR DUP ROT SWAP - 2SWAP  ;

  : /SAVED  ( n1 n2 ca len -- )
    \ Save a RAM-disk to disk, from block n1 to block n2.
    \ n1 = first block (1..11)
    \ n2 = last block (1..11)
    \ ca len = filename
    (/SAVED) >FILE  ;

  : /SAVED?  ( n1 n2 ca len -- error? error )
    \ Save a RAM-disk to disk, from block n1 to block n2.
    \ n1 = first block (1..11)
    \ n2 = last block (1..11)
    \ ca len = filename
    (/SAVED) >FILE?  ;


  \ vim: filetype=abersoftforthafera

.( G+DOS -- part 3 )

\ gplusdos_3.fsb
\ G+DOS support for ZX Spectrum Abersoft Forth (part 3)

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

  \ -----------------------------------------------------------
  \ Note

  \ "DISC" in Forth words means the Forth RAM-disk, after the
  \ name used by Abersoft Forth's documentation and vocabulary,
  \ e.g.  `INIT-DISC`.
  \
  \ "DISK" means always a G+DOS disk.
  \
  \ In the comments of this library, "disc" is not used, and
  \ the Abersoft Forth RAM-disk is always called "RAM-disk".

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

  \ `NEEDS` can not be used yet because it's defined in this
  \ module...

  [UNDEFINED] 2>R 0 ?ERROR
  [UNDEFINED] 2R> 0 ?ERROR

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

  \ 2015-05-17: Start.
  \ 2015-05-18: Fix.

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

-->

( NEEDS-DISK )

  \ XXX TODO

  \ (NEEDS-DISK)  ( f "filename" -- )
  \
  \ Disk version of `(NEEDS)`.
  \
  \ f = is there a word needed from the given filename?

  \ XXX FIXME -- This can not work with several nesting levels.
  \ The buffers must be emptied at the start and the current
  \ block must be refreshed at the end.  (new code required to
  \ do it) .

  \ XXX TODO -- Already solved? Try it.

: (NEEDS-DISK)  ( f "filename" -- )
  BL WORD  IF
    DISC-FILENAME 2@ 2>R  OFFSET @ >R
    HERE COUNT RUND
    R> OFFSET !  2R> EMPTY-BUFFERS LOADD
    EMPTY-BUFFERS BLK @ BLOCK DROP
  THEN  ;

' (NEEDS-DISK) CFA ' ?NEEDS !

  \ vim: filetype=abersoftforthafera


.( G+DOS -- CAT )

\ gplusdos_cat.fsb
\ G+DOS `CAT` 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 CODE assembler

  \ -----------------------------------------------------------
  \ Note

  \ "DISC" in Forth words means the Forth RAM-disk, after the
  \ name used by Abersoft Forth's documentation and vocabulary,
  \ e.g.  `INIT-DISC`.
  \
  \ "DISK" means always a G+DOS disk.
  \
  \ In the comments of this library, "disc" is not used, and
  \ the Abersoft Forth RAM-disk is always called "RAM-disk".

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

  \ 2015-05-20: Extracted from <gplusdos_2.fsb>. Finished.
  \
  \ 2015-08-27: Typo.

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

-->

( CAT ACAT )

CODE (CAT)  ( n -- )

  AF POP
  BC PUSH  IX PUSH  \ save the Forth registers
  AF PUSH  PATCH HOOK

  \ Copy Forth UFIA to G+DOS UFIA1.
  UFIA HL LDP#  UFIA1 DE LDP#  /UFIA BC LDP#  LDIR

  HL POP  L A LD  \ CAT type: 2=compact;4=detailed
  24B5 CALL \ CAT_RUN
  168E CALL \ BORD_REST = restore the border

  E7 OUT  \ page +D out
  IX POP  BC POP  \ restore the Forth registers
  NEXT JP  END-CODE

  \ CAT  ( ca len -- )
  \
  \ Show a disk catologue using the given wild-card filename.
  \ See the +D manual for wild-card syntax.
  \
  \ The catalogue can be printed out on a printer by storing
  \ the number 3 into SSTR1 (a field of UFIA that holds the
  \ stream number to use) before doing `CAT`. The default value
  \ is 2 (screen) and should be restored. Example:
  \
  \   3 SSTR1 C! S" FORTH?.*" CAT 2 SSTR C!

: CAT  ( ca len -- )  FILENAME>UFIA  4 (CAT)  ;

  \ ACAT  ( ca len -- )
  \
  \ A variant of `CAT` that shows an abbreviated catalogue.

: ACAT  ( ca len -- )  FILENAME>UFIA  2 (CAT)  ;

DECIMAL

  \ vim: filetype=abersoftforthafera

.( G+DOS support -- +D memory)

\ gplusdos_mem.fsb
\ G+DOS support for ZX Spectrum Abersoft Forth (+D memory)

\ Copyright (C) 1988,1994,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 words to use the memory of the +D
  \ interface: ROM 0x0000..0x1FFFF; RAM 0x2000..0x3FFFF.

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

  NEEDS CODE assembler

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

  \ 2015-05-19: Start.

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

2 5 THRU

( DOSC@ )

CODE DOSC@  ( a -- b )
  \ Fetch the content of +D memory address.
  HL POP
  BC PUSH  IX PUSH  \ save the Forth registers
  HL PUSH
  PATCH HOOK
  HL POP
  (HL) A LD 0 H LD#  A L LD
  E7 OUT  \ page +D out
  IX POP  BC POP  \ restore the Forth registers
  PUSHHL JP
  END-CODE

( DOS@ )

CODE DOS@  ( a -- n )
  \ Fetch the content of +D memory address.
  HL POP
  BC PUSH  IX PUSH  \ save the Forth registers
  HL PUSH
  PATCH HOOK
  HL POP (HL) E LD  HL INCP  (HL) D LD
  E7 OUT  \ page +D out
  IX POP  BC POP  \ restore the Forth registers
  DE PUSH
  NEXT JP
  END-CODE

( DOSC! )

CODE DOSC!  ( b a -- )
  \ Store b into the +D memory address a.
  HL POP  DE POP
  BC PUSH  IX PUSH  \ save the Forth registers
  DE PUSH HL PUSH
  PATCH HOOK
  HL POP  DE POP  E (HL) LD
  E7 OUT  \ page +D out
  IX POP  BC POP  \ restore the Forth registers
  NEXT JP
  END-CODE

( DOS! )

CODE DOS!  ( n a -- )
  \ Store n into the +D memory address a.
  HL POP  DE POP
  BC PUSH  IX PUSH  \ save the Forth registers
  DE PUSH  HL PUSH
  PATCH HOOK
  HL POP  DE POP  E (HL) LD  HL INCP  D (HL) LD
  E7 OUT  \ page +D out
  IX POP  BC POP  \ restore the Forth registers
  NEXT JP
  END-CODE

  \ vim: filetype=abersoftforthafera


.( G+DOS support -- DOS variables)

\ gplusdos_vars.fsb
\ G+DOS support for ZX Spectrum Abersoft Forth (DOS vars)

\ Copyright (C) 1988,1994,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 words to manage the G+DOS system
  \ variables.
  
  \ -----------------------------------------------------------
  \ Requirements

  NEEDS CODE assembler

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

  \ 2015-04-15: Start.
  \
  \ 2015-04-16: File renamed to <g+dos_vars.fsb>.
  \
  \ 2015-05-08: Renamed to <gplusdos_vars.fsb>, because of an
  \ issue with Makefile.
  \
  \ 2015-05-17: `DOSC@` and `DOSC!`are finished.

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

  \ Address of the G+DOS vars in its own memory.
8192 CONSTANT DOS-VARS

2 5 THRU

( DOSVARC@ )

CODE DOSVARC@  ( n -- b )
  \ Fetch the content of G+DOS variable n.
  HL POP
  BC PUSH  IX PUSH  \ save the Forth registers
  HL PUSH
  PATCH HOOK
  HL POP  DOS-VARS DE LDP#  DE ADDP
  (HL) A LD 0 D LD#  A E LD
  E7 OUT  \ page +D out
  IX POP  BC POP  \ restore the Forth registers
  DE PUSH
  NEXT JP
  END-CODE

( DOSVAR@ )

CODE DOSVAR@  ( n1 -- n2 )
  \ Fetch the content of G+DOS variable n1.
  HL POP
  BC PUSH  IX PUSH  \ save the Forth registers
  HL PUSH
  PATCH HOOK
  HL POP  DOS-VARS DE LDP#  DE ADDP
  (HL) E LD  HL INCP  (HL) D LD
  E7 OUT  \ page +D out
  IX POP  BC POP  \ restore the Forth registers
  DE PUSH
  NEXT JP
  END-CODE

( DOSVARC! )

CODE DOSVARC!  ( b n -- )
  \ Store b into the G+DOS variable n.
  HL POP  DE POP
  BC PUSH  IX PUSH  \ save the Forth registers
  DE PUSH HL PUSH
  PATCH HOOK
  HL POP  DOS-VARS DE LDP#  DE ADDP  DE POP
  E (HL) LD
  E7 OUT  \ page +D out
  IX POP  BC POP  \ restore the Forth registers
  NEXT JP
  END-CODE

( DOSVAR! )

CODE DOSVAR!  ( n1 n2 -- )
  \ Store n1 into the G+DOS variable n2.
  HL POP  DE POP
  BC PUSH  IX PUSH  \ save the Forth registers
  DE PUSH  HL PUSH
  PATCH HOOK
  HL POP  DOS-VARS DE LDP#  DE ADDP  DE POP
  E (HL) LD  HL INCP  D (HL) LD
  E7 OUT  \ page +D out
  IX POP  BC POP  \ restore the Forth registers
  NEXT JP
  END-CODE

  \ vim: filetype=abersoftforthafera

\ graphics.fsb
\ Graphic extensions for ZX Spectrum Abersoft Forth

\ Copyright (C) 1985-1987,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: Code extracted from the main file of the
  \ library.
  \
  \ 2015-04-22: `UDG!` is moved to its own file
  \ <udg-store.fsb>.
  \
  \ 2015-10-26: Updated header.

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

-->

.( Graphic extensions )

FORTH DEFINITIONS DECIMAL

  \ System variables and addresses

23677 CONSTANT SYS-COORDS  \ ZX Spectrum system variable
SYS-COORDS    CONSTANT X-COORD
SYS-COORDS 1+ CONSTANT Y-COORD

22528 CONSTANT ATTRIBUTES

 : DRAWL  ( x1 y1 x2 y2 -- )
  \ Draw a line from x1 y1 to x2 y2
  2SWAP PLOT DRAW  ;

: RDRAW  ( inc-x inc-y -- )
  \ Draw a line from the current plot position
  Y-COORD C@ + SWAP X-COORD C@ + SWAP DRAW  ;

: RDRAWL  ( x y inc-x inc-y -- )
  \ Draw a line from x1 y1
  2SWAP PLOT RDRAW  ;

: XY>ATTRA  ( x y -- a )
  \ Convert a pixel coordinate to its attribute address.
  \ XXX TODO Rewrite in Z80, using the ROM routine.
  175 SWAP - 8 / 32 *  SWAP 8 /  + ATTRIBUTES +  ;

  \ vim: filetype=abersoftforthafera