Solo Forth development history in 2015-08
2015-08-11
Fixed a silly bug in parsed that crashed the system.
Checked the search order words, based on F83 and already implemented in the kernel. Removed their old versions from the library disk.
First draft of get-order and set-order, in the library disk.
Fixed next,, pushhl,, pushde, and fetchhl,: they were defined as constants.
Fixed message: error>line was used in error instead of message, therefore message printed a wrong message number, because it was already converted to its line.
Fixed perform: the position of the check was wrong and the fetched cfa got corrupted.
Finished, documented and checked case: and associative:, adapted from F83.
2015-08-12
New: lshift.
Change: the code of 2/, adapted from DZX-Forth, was too complex, because its origin is DX-Forth, that uses instructions compatible with the 8080.
_code_header two_slash_,'2/'
; doc{
;
; 2/ ( x1 -- x2 ) \ ANS Forth
;
; _x2_ is the result of shifting _x1_ one bit toward the
; least-significant bit, leaving the most-significant bit
; unchanged.
;
; This is the same as `s>d 2 fm/mod swap drop`. It is not the same
; as `2 /`, nor is it the same as `1 rshift`.
;
; }doc
; [Code from DZX-Forth. Documentation partly based on lina
; ciforth.]
pop hl
call sra_hl
jp push_hl
; Shift right arithmetic
sra_hl:
ld a,h
rlca
rrca
sra_hl.1:
; cy=sign bit of hl
; a=h
rra
ld h,a
ld a,l
rra
ld l,a
ret
Beside, the routine is not used yet by other words (DZX-Forth does). The new code is adapted from Spectrum Forth-83:
pop hl
sra h
rr l
jp push_hl
The Abersoft Forth case is removed from the kernel. It was already in the library disk, and other versions will be added:
; ----------------------------------------------
_colon_header case_,'CASE',immediate
dw question_comp_
dw csp_,fetch_,store_csp_
dw c_lit_
db 0x04
dw semicolon_s_
; ----------------------------------------------
_colon_header of_,'OF',immediate
dw c_lit_
db 0x04
dw question_pairs_
dw compile_,over_
dw compile_,equals_
dw compile_,zero_branch_
dw forward_mark_
dw compile_,drop_
dw c_lit_
db 0x05
dw semicolon_s_
; ----------------------------------------------
_colon_header endof_,'ENDOF',immediate
dw c_lit_
db 0x05
dw question_pairs_
dw compile_,branch_
dw forward_mark_
dw swap_
dw two_ ; error checking number
dw then_
dw c_lit_
db 0x04
dw semicolon_s_
; ----------------------------------------------
_colon_header endcase_,'ENDCASE',immediate
dw c_lit_
db 0x04
dw question_pairs_
dw compile_,drop_
endcase.compile_then: ; begin
dw sp_fetch_,csp_,fetch_,not_equals_ ; while
dw question_branch_,endcase.end
dw two_,then_
dw branch_,endcase.compile_then ; repeat
endcase.end:
dw csp_,store_
dw semicolon_s_
The Abersoft Forth version of case includes security checks during compilation and needs 112 bytes of dictionary. The ANS Forth version (adapted from the ANS Forth documentation) does no compilation check and needs only 56 bytes.
Improvement: now the fig-Forth compiler security checks are optional, with conditional compilation in the kernel.
Fixed cold: Since the search order was implemented, and root and assembler were created, cold didn't restored the original lastest definitions of the vocabularies.
Improved abort: Now it does not show the greeting message (cold does it instead), does not check the stack (it was useless) and does not change the search order or current. It simply does what ANS Forth says.
Renamed ?terminal (the original fig-Forth name) to break-key? (clearer) and moved it off the kernel to the library disk.
Removed old unused config options of the kernel and their related code:
fig_vocabulary?. No way back to the chained vocabularies of the fig-Forth model.
fig_null_word?. No way back to the fig-Forth's null character as end of input buffers. The current null-word method, implemented in 2015-06, is simpler and easier for parsing words, beside compatible with the old fig-Forth method. Nevertheless the final goal is to implement a method that does not need any special mark at the end of the input buffer.
fig_does?. No way back to fig-Forth's<builds does>.
Added ahead and modified else with it.
Moved label to the forth vocabulary.
2015-08-13
First draft of ANS Forth version of key and key?. First changes to convert the original key to an alternative version with additional features.
New: >number, from DZX-Forth.
Converted at to ANS-Forth at-xy.
Fixed border: it didn't update the BORDCR system variable, what caused G+DOS could not restore the border color (G+DOS, by default, changes the border color during disk operations).
_code_header border_,'BORDER'
pop hl
ld a,l
out(0xFE),a
; The system variable that holds the attributes of the lower
; part of the screen, unnecessary in Solo Forth, must be
; updated. The reason is G+DOS, after disk operations that
; make the border change, restores the border color with the
; value of this system variable. We use the border color as
; paper and set a a contrast ink (black or white), to make
; sure the lower part of the screen is usable after returning
; to BASIC.
cp 4 ; cy = dark color (0..3)?
ld a,7 ; white ink
jr c,border.end
xor a ; black ink
border.end:
add hl,hl
add hl,hl
add hl,hl ; paper
ld l,a ; ink
ld (sys_bordcr),hl
_jp_next
Removed #whiles and all related code, an approach to implement multiple while in control structures, already deactivated with conditional compilation. It was a bad idea that introduced new problems.
Added du.r, u.r, and du. to the library disk. They probably will be moved to the kernel.
2015-08-14
Improved dnegate: saved one byte!
Fixed a recent bug in decode: sp0 sp! was used when quitting, instead of sp0 @ sp!!
Checked the for step structure, that was adapted from Z88 CamelForth:
; ----------------------------------------------
_code_header paren_step_,'(STEP)'
ld hl,(return_stack_pointer)
ld e,(hl)
inc hl
ld d,(hl) ; de = loop index
dec de
ld (hl),d
dec hl
ld (hl),e ; update the loop index
ld a,d
or e ; zero?
jp nz,branch_pfa ; loop again if not zero
; done, discard loop index
inc hl
inc hl
ld (return_stack_pointer),hl
; skip branch offset
inc bc
inc bc
_jp_next
; ----------------------------------------------
_colon_header for_,'FOR',immediate
dw compile_,to_r_,backward_mark_
if fig_compiler_security?
dw c_lit_
db 6 ; error checking number
endif
dw semicolon_s_
; ----------------------------------------------
_colon_header step_,'STEP',immediate
if fig_compiler_security?
dw c_lit_
db 6 ; error checking number
dw question_pairs_
endif
dw compile_,paren_step_,backward_resolve_
dw semicolon_s_
Moved it off the kernel to the library disk, improved it (after Gforth: now the index is checked before decrementing it), removed the fig-Forth compiler security checks and documented it:
( for step )
\ [Code adapted from Z88 CamelForth. Modified to do the check
\ before decrementing the index.]
code (step) ( R: n -- n' )
\ doc{
\
\ (step)
\
\ The run-time procedure compiled by `step`.
\
\ Run-time: ( R: u -- u' )
\
\ If the loop index is zero, discard the loop parameters and
\ continue execution after the loop. Otherwise decrement the
\ loop index and continue execution at the beginning of the
\ loop.
\
\ }doc
2A c, rp ,
\ ld hl,(return_stack_pointer)
5E c, 23 c, 56 c,
\ ld e,(hl)
\ inc hl
\ ld d,(hl) ; de = loop index
7A c, B3 c,
\ ld a,d
\ or e ; z=already zero?
1B c, 72 c, 2B c, 73 c,
\ dec de
\ ld (hl),d
\ dec hl
\ ld (hl),e ; update the loop index
C2 c, ' branch cfa>pfa ,
\ jp nz,branch_pfa ; loop again if not zero
\ ; done, discard loop index:
23 c, 23 c, 22 c, rp ,
\ inc hl
\ inc hl
\ ld (return_stack_pointer),hl
\ ; skip branch offset and jump to next
03 c, 03 c, next,
\ inc bc
\ inc bc
\ jp next
end-code
: for ( n -- ) postpone >r <mark ; immediate
\ doc{
\
\ for Compilation: ( R: -- dest ) Run-time: ( u -- )
\
\ Start of a `for step` loop, that will iterate _u+1_ times,
\ starting with _u_ and ending with 0.
\
\ The current value of the index can be retrieved with `i`.a
\
\ }doc
: step ( -- ) postpone (step) <resolve ; immediate
\ doc{
\
\ step
\
\ Compilation: ( dest -- )
\
\ Append the run-time semantics given below to the current
\ definition. Resolve the destination of `for`.
\
\ Run-time: ( R: u -- u' )
\
\ If the loop index is zero, discard the loop parameters and
\ continue execution after the loop. Otherwise decrement the
\ loop index and continue execution at the beginning of the
\ loop.
\
\ }doc
Compared the current code of D+, from Abersoft Forth, with an alternative from Z80 fig-Forth 1.1g, that is faster and smaller and will be used instead:
_code_header d_plus_,'D+'
; Code from Abersoft Forth
; t B
; -- --
ld hl,0x0006 ; 10 03
add hl,sp ; 11 01
ld e,(hl) ; 07 01
ld (hl),c ; 07 01
inc hl ; 06 01
ld d,(hl) ; 07 01
ld (hl),b ; 07 01
pop bc ; 10 01
pop hl ; 10 01
add hl,de ; 11 01
ex de,hl ; 04 01
pop hl ; 10 01
adc hl,bc ; 15 01
pop bc ; 10 01
jp push_hlde ; 10 03
; 11 ; push de
; 11 ; push hl
; --- --
; 157 19 TOTALS
if 0
; Alternative from fig-Forth 1.1g
; t B
; -- --
exx ; save ip 04 01
pop bc ; (bc)<--d2h 10 01
pop hl ; (hl)<--d2l 10 01
pop af ; (af)<--d1h 10 01
pop de ; (de)<--d1l 10 01
push af ; (s1)<--d1h 11 01
add hl,de ; (hl)<--d2l+d1l=d3l 11 01
ex de,hl ; (de)<--d3l 04 01
pop hl ; (hl)<--d1h 10 01
adc hl,bc ; (hl)<--d1h+d2h+carry=d3h 15 02
push de ; (s2)<--d3l 11 01
push hl ; (s1)<--d3h 11 01
exx ; restore ip 04 01
jp_next ; 08 02 ; jp (ix)
; --- --
; 134 15 TOTALS
endif
First changes to make true -1 instead of 1. Conditional compilation is used at the moment.
Added under+ and k to the library, after Gforth.
Renamed gover to overwrite. The less cryptic names the better; names don't waste dictionary space.
Fixed and improved emitted (the equivalent of the ZX Spectrum SCREEN$() function). Faster and configurable for any charset or set of user defined graphics. It will be moved to the library disk, maybe adapted to the Forth assembler.
; ----------------------------------------------
_code_header emitted_,'EMITTED'
; [Code adapted and modified from the ZX Spectrum ROM routine
; S-SCRN$-S at 0x2535.]
; doc{
;
; emitted ( col row -- n | 0 )
;
; Return the ordinal number _n_ (first is 1) of the character
; printed at the given screen coordinates, or 0 if no character
; can be recognized on that position of the screen.
;
; This word must be configured by `emitted-charset` and
; `#emitted-chars`, that set the address of the first character
; and the number of characters to compare with. By default the
; printable ASCII chars of the ROM charset are used.
;
; The result _n_ is the ordinal number (first is 1) of the
; recognized char in the specified charset. Example: with the
; default configuration, a recognized space char would return 1;
; a "!" char, 2; a "A", 34...
;
; This word is meant to be used with user defined graphics.
;
; }doc
; XXX TODO improve the result number?
;
; XXX TODO move to the disk
;
; XXX TODO rename?: `ocr`, `recognized`, `on-xy`, `xy-char`?
; The reason is a name clash with the fig-Forth `out` counter,
; that was going to be called `emitted` or `#emitted`.
pop de ; row
pop hl ; col
push bc ; save the Forth IP
ld b,l ; column
ld c,e ; row
ld hl,(emitted_charset_pfa) ; address of first printable char in the charset
ld a,c ; row
rrca
rrca
rrca ; multiply by 0x20
and %11100000
xor b ; combine with column (0x00..0x1F)
ld e,a ; low byte of top row = 0x20 * (line mod 8) + column
ld a,c ; row is copied to a again
and 0x18
xor 0x40
ld d,a ; high byte of top row = 64 + 8*int (line/8)
; de = screen address
ld a,(hash_emitted_chars_pfa) ; number of chars in the charset
ld b,a
emitted.do:
push bc ; save the characters count
push de ; save the screen pointer
push hl ; save the character set pointer (bitmap start)
ld a,(de) ; get first scan of screen character
xor (hl) ; match with scan from character set
jp z,emitted.match ; jump if direct match found
; if inverse, a=0xFF
inc a ; inverse? (if inverse, a=0)
jp nz,emitted.next_char ; jump if inverse match not found
; inverse match
dec a ; restore 0xFF
emitted.match:
ld c,a ; inverse mask (0x00 or 0xFF)
ld b,0x07 ; count 7 more character rows
emitted.scans:
inc d ; next screen scan (add 0x100)
inc hl ; next bitmap address
ld a,(de) ; screen scan
xor (hl) ; will give 0x00 or 0xFF (inverse)
xor c ; inverse mask to include the inverse status
jp nz,emitted.next_char ; jump if no match
djnz emitted.scans ; jump back till all scans done
; character match
pop bc ; discard character set pointer
pop bc ; discard screen pointer
pop bc ; final count
ld a,(hash_emitted_chars_pfa) ; number of chars in the charset
sub b ; ordinal number of the matched character (1 is the first)
ld l,a
jp emitted.end
emitted.next_char:
pop hl ; restore character set pointer
ld de,0x0008 ; move it on 8 bytes
add hl,de ; to the next character in the set
pop de ; restore the screen pointer
pop bc ; restore the counter
djnz emitted.do ; loop back for the 96 characters
; no match
ld l,b ; zero
emitted.end:
pop bc ; restore the Forth IP
ld h,0
jp push_hl
; ----------------------------------------------
_variable_header emitted_charset_,'EMITTED-CHARSET'
; doc{
;
; emitted-charset ( -- a )
;
; Variable that holds the address of the first printable char in
; the charset used by `emitted`. By default it contains 0x3D00, the
; address of the space char in the ROM charset.
;
; }doc
dw 0x3D00 ; address of the space in the ROM charset
; ----------------------------------------------
_variable_header hash_emitted_chars_,'#EMITTED-CHARS'
; doc{
;
; #emitted-charset ( -- a )
;
; Variable that holds the number of printable chars in the
; charset used by `emitted`. By default it contais 0x5F, the
; number of printable ASCII chars in the ROM charset.
;
; }doc
dw 0x5F ; printable ASCII chars in the ROM charset
Fixed an old bug in the new, faster and smaller, definition of stream-end. The old definition was still in use because of the bug.
Renamed #buff to buffers.
Factor flush to save-buffers.
Removed the useless user variable fence from the kernel, and the useless forget from the library.
Converted the user variables tib and tib to a constant and a variable, after ANS Forth.
Added ANS Forth's source to the library.
Changed the disk block interface. So far the fig-Forth r/w was used:
_colon_header read_write_,'R/W'
; doc{
;
; r/w ( a block wf -- )
;
; The disk read-write linkage. _a_ specifies the source or
; destination block buffer, _block_ is the sequential number of
; the referenced block; and _wf_ is a flag: false=write,
; true=read. `r/w` determines the location on mass storage,
; performs the read-write and performs any error checking.
;
; }doc
_literal 0x45
dw swap_
if true=1
dw minus_
else
dw plus_
endif
dw lit_,read_write_sector_command,c_store_
dw block_to_sector_
dw paren_read_write_
dw semicolon_s_
paren_read_write_:
; Headerless word with the low level code of `R/W`.
; ( a sector -- )
; sector (high byte) = track 0..79, +128 if side 1
; (low byte) = sector 1..10
dw paren_read_write_pfa ; code field
paren_read_write_pfa:
pop de ; d = track 0..79, +128 if side 1
; e = sector 1..10
pop ix ; address
push bc ; save the Forth IP
ld a,2 ; drive ; XXX TMP
rst 8 ; G+DOS hook
read_write_sector_command:
; G+DOS command already patched:
db 0x44 ; 0x44 = read ; 0x45 = write
pop bc ; restore the Forth IP
ld ix,next
_jp_next
The new interface is clearer, but it needs 7 more bytes:
; ----------------------------------------------
_colon_header read_block_,'READ-BLOCK'
; doc{
;
; read-block ( a n -- )
;
; Read disk block _n_ to buffer _a_.
;
; }doc
_literal 0x44 ; G+DOS command to read a disk sector
dw transfer_block_
dw semicolon_s_
; ----------------------------------------------
_colon_header write_block_,'WRITE-BLOCK'
; doc{
;
; write-block ( a n -- )
;
; Write buffer _a_ to disk block _n_.
;
; }doc
_literal 0x45 ; G+DOS command to write a disk sector
dw transfer_block_
dw semicolon_s_
; ----------------------------------------------
_colon_header transfer_block_,'TRANSFER-BLOCK'
; doc{
;
; transfer-block ( a n b -- )
;
; The disk read-write linkage.
;
; a = source or destination block buffer
; n = sequential number of the referenced disk block
; b = G+DOS command to read or write a sector
;
; }doc
dw lit_,read_write_sector_command,c_store_
dw block_to_sector_
dw paren_transfer_block_
dw semicolon_s_
paren_transfer_block_:
; Headerless word with the low level code of `transfer-block`.
dw paren_transfer_block_pfa ; code field
; ( a sector -- )
; sector (high byte) = track 0..79, +128 if side 1
; (low byte) = sector 1..10
paren_transfer_block_pfa:
pop de ; d = track 0..79, +128 if side 1
; e = sector 1..10
pop ix ; address
push bc ; save the Forth IP
ld a,2 ; drive ; XXX TMP
rst 8 ; G+DOS hook
read_write_sector_command:
; G+DOS command already patched:
db 0x44 ; 0x44 = read ; 0x45 = write
pop bc ; restore the Forth IP
ld ix,next
_jp_next
2015-08-15
Currently Solo Forth uses two 512-byte disk buffers. I thought using only one buffer would make many things simpler, so I implemented alternative code and tried it with conditional compilation:
; ----------------------------------------------
_colon_header update_,'UPDATE'
; doc{
;
; update ( -- ) \ ANS-Forth
;
; Mark the most recently referenced block (pointed to by `prev`) as
; altered. The block will subsequently be transferred automatically to
; disk should its buffer be required for storage of a different block.
;
; }doc
; XXX TODO move to the disk?
if buffers=1
dw first_,fetch_
dw lit_,0x8000,or_
dw first_,store_
else
dw prev_,fetch_,fetch_
dw lit_,0x8000,or_
dw prev_,fetch_,store_
endif
dw semicolon_s_
if buffers=1
; ----------------------------------------------
_colon_header updated_question_,'UPDATED?'
; doc{
;
; updated? ( -- f )
;
; Is the current disk buffer marked as modified?
;
; }doc
dw first_,fetch_,zero_less_than_
endif
; ----------------------------------------------
_colon_header empty_buffers_,'EMPTY-BUFFERS'
if buffers=1
; doc{
;
; empty-buffers ( -- )
;
; Unassign all block buffers. Do not transfer the contents of
; any updated block to mass storage.
;
; }doc
dw lit_,0x7FFF,first_,store_
else
; doc{
;
; empty-buffers ( -- )
;
; Unassign all block buffers. Do not transfer the contents of
; any updated block to mass storage. All buffers are filled with
; blanks.
;
; }doc
dw first_,limit_,over_,minus_,blank_
dw limit_,first_
dw paren_do_
empty_buffers.do:
dw lit_,0x7FFF,i_,store_
; Store a null word after the end of the buffer:
dw i_,lit_,data_bytes_per_buffer+2,plus_,stream_end_
dw lit_,total_bytes_per_buffer
dw paren_plus_loop_,empty_buffers.do
endif
dw semicolon_s_
if buffers=1
; ----------------------------------------------
_colon_header block_number_,'BLOCK-NUMBER'
; doc{
;
; block-number ( n1 -- n2 )
;
; Remove the update bit from the block number _n1_.
;
; }doc
_literal 0x7FFF
dw and_
dw semicolon_s_
; ----------------------------------------------
_colon_header free_buffer_,'FREE-BUFFER'
; doc{
;
; free-buffer ( n1 n2 -- )
;
; Free the disk buffer, currently assigned to block _n2_,
; and assign it to block _n1_.
;
; }doc
dw dup_,zero_less_than_ ; updated?
dw zero_branch_,free_buffer.not_updated
dw block_number_,first_,cell_plus_,swap_,write_block_
dw branch_,free_buffer.end
free_buffer.not_updated:
dw drop_
free_buffer.end:
dw first_,store_
dw semicolon_s_
endif
; ----------------------------------------------
_colon_header buffer_,'BUFFER'
; doc{
;
; buffer ( n -- a )
;
; Obtain the next block buffer and assign it to block _n_. If the
; contents of the buffer were marked as updated, it is written to the
; disk. The block _n_ is not read from the disk. The address left on
; stack is the first cell in the buffer for data storage.
;
; }doc
if buffers=1 ; XXX NEW
dw first_,fetch_ ; current block assigned to the buffer
dw two_dup_,block_number_,equals_
dw zero_branch_,buffer.not_equals
; The requested block is the one already in the buffer.
dw two_drop_
dw branch_,buffer.end
buffer.not_equals:
dw free_buffer_
buffer.end:
dw first_,cell_plus_ ; first cell of data in the buffer
dw semicolon_s_
else ; XXX OLD
dw use_,fetch_
dw dup_,to_r_
buffer.begin:
; XXX NOTE: `+buf` won't work if single buffer
dw plus_buf_
dw zero_branch_,buffer.begin ; until
dw use_,store_
dw r_fetch_,fetch_
dw zero_less_than_ ; updated?
dw zero_branch_,buffer.end
; The buffer was updated, it must be saved to disk.
dw r_fetch_,two_plus_ ; first cell of data in the buffer
dw r_fetch_,fetch_
dw lit_,0x7FFF,and_ ; discard the update bit, leave the block number
if 1 ; new_read_write?
dw write_block_
else
dw false_,read_write_ ; write
endif
buffer.end:
dw r_fetch_,store_
dw r_fetch_,prev_,store_
dw from_r_,two_plus_ ; first cell of data in the buffer
dw semicolon_s_
endif
; ----------------------------------------------
_colon_header block_,'BLOCK'
; doc{
;
; block ( n -- a )
; Leave the memory address _a_ of the block buffer containing
; block _n_. If the block is not already in memory, it is
; transferred from disk to which ever buffer was least recently
; written. If the block occupying that buffer has been marked as
; updated, it is rewritten to disc before block _n_ is read into
; the buffer.
;
; }doc
if buffers=1
dw dup_,first_,fetch_,block_number_,equals_
dw zero_branch_,block.not_equals
dw drop_
dw branch_,block.end
block.not_equals:
dw save_buffers_,first_,two_dup_,store_,cell_plus_,swap_,read_block_
block.end:
dw first_,cell_plus_
dw semicolon_s_
else
dw to_r_
dw prev_,fetch_ ; most recently accessed buffer
dw dup_,fetch_ ; its block number (bit 15, the update indicator, may be set)
dw r_fetch_,minus_ ; compare to the required block
dw two_star_ ; discard the left most bit, which is the update indicator
dw zero_branch_,block.end
; Block number _n_ is not the previously referenced.
; Prepare disk access.
block.begin:
; Scan the buffers and look for a buffer which might contain
; block _n_ already.
dw plus_buf_,zero_equals_ ; advance a buffer
dw zero_branch_,branch_destination_0x71E5
; This buffer is pointed to by `prev`, all buffers scanned.
dw drop_ ; discard the buffer address
dw r_fetch_,buffer_ ; find the disk sector, update the sector if necessary
dw dup_,r_fetch_
if 1 ; new_read_write?
dw read_block_
else
dw true_,read_write_ ; read one sector from the disk
endif
dw two_minus_ ; backup to the buffer address of block n
branch_destination_0x71E5:
dw dup_,fetch_ ; beginning address of the buffer, with a block number in it
dw r_fetch_,minus_ ; compare to the block number _n_
dw two_star_ ; discard the left most bit, with is the update indicator
dw question_branch_,block.begin ; until
dw dup_,prev_,store_ ; store the buffer address in `prev`
block.end:
dw r_drop_
dw two_plus_ ; get the address where data begin
dw semicolon_s_
endif
; ----------------------------------------------
_colon_header save_buffers_,'SAVE-BUFFERS'
; doc{
;
; save-buffers ( -- ) \ ANS Forth
;
; Transfer the contents of each updated block buffer to disk.
; Mark all buffers as unmodified.
;
; }doc
if buffers=1
dw updated_question_,zero_equals_ ; not updated?
dw question_exit_ ; exit if not updated
; Updated
dw first_,first_,fetch_,block_number_,two_dup_,write_block_
dw swap_,store_
dw semicolon_s_
else
; XXX TODO -- Check. It seems this original version is not ANS
; Forth compliant, because it modifies the buffers.
dw buffers_,one_plus_,zero_
dw paren_do_
save_buffers.do:
dw zero_,buffer_,drop_
dw paren_loop_,save_buffers.do ; loop
dw semicolon_s_
endif
A simple benchmark revealed using one single buffer was faster:
| 512-byte buffers | Benchmark 1 | Benchmark 2 |
|---|---|---|
| 1 | 431 | 392 |
| 2 | 492 | 475 |
| 3 | 473 | 439 |
| 4 | 476 | 445 |
| 10 | 491 | 471 |
- Benchmark 1:
frames0 require decode frames@ d. - Benchmark 2:
frames0 require dump frames@ d.
Removed the conditional compilation: no way back to several buffers. Eventually I will try a 1 KiB buffer, but I think it will be slower, because a G+DOS disk sector is 512 bytes long.
Removed all unnecesary words (+buff, prev, use). After some factoring and renaming, the Forth code (the original version written before including it into the kernel) looks like this:
: block-number ( x -- n ) 7FFF and ;
\ Convert the buffer id _x_ to its block number _n_
\ by removing the update bit.
: buffer-data ( -- a ) disk-buffer cell+ ;
\ First data address of the disk buffer.
: buffer-id ( -- x ) disk-buffer @ ;
\ Id of the disk buffer.
: buffer-block ( -- n ) buffer-id block-number ;
\ Block associated to the disk buffer.
: write-buffer ( n -- ) buffer-data swap write-block ;
: read-buffer ( n -- ) buffer-data swap read-block ;
: free-buffer ( n1 n2 -- )
\ Free the disk buffer, currently assigned to block _n2_,
\ and assign it to block _n1_.
\ XXX TODO rewrite
dup 0< \ updated?
if block-number write-buffer
else drop
then disk-buffer ! ;
: buffer ( n -- a )
buffer-id 2dup block-number = ( n n0 f )
if 2drop
else free-buffer
then buffer-data ;
: updated? ( -- f ) buffer-id 0< ;
: save-buffers ( -- )
updated? 0= ?exit \ exit if not updated
buffer-block dup write-buffer disk-buffer ! ;
: block ( n --- a )
dup buffer-block =
if drop
else save-buffers dup read-buffer disk-buffer !
then buffer-data ;
New result of benchmark 1: 443 frames, a bit slower, because of the factoring, but stil faster than the 2-buffer method. The free memory is 33910 bytes, more than ever before, and growing (finally all words regarded as optional will be moved off kernel).
2015-08-16
Serious problems with the Pasmo assembler. The other day version 0.5.3 suddenly started to change some addresses of jumps and calls in the binary, though the labels were fine in the symbols file created by the assembler! I switched to version 0.5.4 beta2 and the problem disappeared, but after a while then the Forth system started crashing at the start. After a lot of debugging, I conclude the problem is the assembler.
2015-08-17
Converted the 8000-line source code to GNU binutils, with the help of Vim.
Had some problems with the conversion of the _header macro. Asked for help in the World of Spectrum forum. The problem seemed to vanish but not really...
2015-08-18
After a lot of breakpoints and step by step execution with the Fuse's monitor/debugger, I found the bug that crashed the system at the start: the output channel was not open, and the rst 0x10 in (emit) failed. Can not guess when and how this bug was introduced. The problems with Pasmo made this bug difficult to find out, because the error conditions seemed to change every time. It has been easier with GNU binutils.
2015-08-19
Discovered how to to compile the length of strings in a macro, with GNU binutils. Only local labels work:
; string_length.z80s
;
; GNU binutils test
;
; Marcos Cruz (programandala.net)
;
; 2015-08-19
.text
db message_0_end-$-1 ; works, compiles 7
db "message"
message_0_end: defl $
_macro_message: macro
db _macro_message_end-$-1 ; works, compiles 13
db "macro message"
_macro_message_end: defl $
endm
_any_message: macro _string
db _any_message_end-$-1 ; works only the first time
db "\_string"
_any_message_end: defl $
endm
_any_message_with_local: macro _string
db 0f-$-1
db "\_string"
0:
endm
_macro_message ; works
_any_message "any" ; works, compiles 3
_any_message "message" ; fails, compiles 0xFF
_any_message "fails" ; fails, compiles 0xFF
; Several more tries confirmed that only the first call to
; `_any_message` works.
_any_message_with_local "0any" ; works, compiles 4
_any_message_with_local "0message" ; works, compiles 8
_any_message_with_local "0works" ; works, compiles 6
New problem: the Z80 assembler of GNU binutils does not escape special chars in strings. The documentation says: A backslash `\` is an ordinary character for the Z80 assembler.
Two word names in Solo Forth are just a null character. With Pasmo, "\x00" worked. Other names contain double quotes. With Pasmo, single or double quotes can be used for strings, but GNU binutils allows double quotes only...
The solution is to write wrapper macros for the _header macro, that accept a name in three parts (a prefix string, a char and a suffix string). Example:
_code_header_with_special_name: .macro _base_label,_name0,_name1,_name2,_immediate=0
_header_with_special_name \_base_label,"\_name0",\_name1,"\_name2",\_immediate
dw \_base_label\()pfa ; code field
\_base_label\()pfa: ; parameter field address
.endm
The new macro _header_with_special_name does the same than _header except the name is compiled this way:
; Name field
db 0f-$-1+\_immediate
db "\_name0",\_name1,"\_name2"
0:
Solo Forth runs again!
Fixed \: it worked only while loading a block.
; doc{
;
; \ ( -- )
;
; Discard the rest of the parse area.
;
; }doc
dw blk_,fetch_
dw question_branch_,backslash.loading
; Interpreting
dw span_,fetch_,to_in_,store_
dw semicolon_s_
backslash.loading:
; Loading
dw to_in_,fetch_,c_slash_l_,mod_
dw c_slash_l_,swap_,minus_
dw to_in_,plus_store_
dw semicolon_s_
Problems: something gets broken after loading from disk: the next word to be executed executes the input string in the circular string buffer instead.
2015-08-20
The field names of new definitions are not compiled. It seems it has something to do with the assembler sections, but I can not find out the problem.
Back to Pasmo. Updated its last source with a Vim diff. Everything seems to work fine.
bye still resets the system. Can not guess when this bug was introduced.
- Compared register pairs IY and HL', memory paging and stack, both at cold start and bye. They are identical.
- Compared the system variables (saved them and used vbindiff). They differ. But loading the start version before returning to BASIC doesn't make any difference.
- Added 1 KiB of memory to BASIC, just in case, but nothing changed.
Nevertheless the effect changes: system freeze, 48K reset, 128K reset... No pattern yet.
2015-08-21
The problem vanished after compiling with Pasmo 0.54beta2: bye works fine. But then I changed back to Pasmo 0.53, compiled and bye still works too. The binaries produced by both versions are identical. I don't understand.
Fixed plot.
First drafts for circle.
2015-08-22
Converted dp to an ordinary variable. In fig-Forth it was an user variable.
Adapted Spectrum Forth-83's draw:
( rdraw )
\ [Code adapted from Spectrum Forth-83's `DRAW`.]
require fasmo \ assembler
code rdraw ( x y -- )
\ Draw a line.
\ x y = relative coordinates from the current position
\ XXX TODO -- use the whole screen
hl pop de pop bc push
de bc mvp
\ hl = y
\ bc = x
1 e ld
7 b bit \ negative x?
nz if c a mv neg -1 e ld a c mv then \ negative x
l b mv \ y
1 d ld
7 h bit \ negative y?
nz if b a mv neg -1 d ld a b mv then \ negative y
24BA call \ alternative entry to the DRAW-LINE ROM routine
bc pop
next, end-code
Fixed cls (a factor of page): it didn't set the graphics coordinates to zero.
Adapted Abersoft Forth's draw:
( adraw )
\ [Code adapted from Abersoft Forth's `DRAW`.]
require plot
2variable x1 2variable incx 2variable y1 2variable incy
\ Note: 23677 = system variable COORDX
\ 23678 = system variable COORDY
: adraw ( x y -- )
\ x y = absolute coordinates
23678 c@ ( y0 ) dup 0 swap y1 2! - dup abs rot
\ ( +-ydiff ydiff x )
23677 c@ ( x0 ) dup 0 swap x1 2! - dup abs rot
\ ( +-ydiff +-xdiff xdiff ydiff )
max >r dup 0< \ negative xdiff?
if abs 0 swap r@ m/mod dnegate
else 0 swap r@ m/mod then
incx 2! drop dup 0< \ negative ydiff?
if abs 0 swap r@ m/mod dnegate
else 0 swap r@ m/mod then
incy 2! drop r> 1+ 0
do x1 @ y1 @ plot
x1 2@ incx 2@ d+ x1 2!
y1 2@ incy 2@ d+ y1 2! loop ;
Until rdraw is fixed to use the whole screen, adraw and rdraw can not be used together without additional code.
Discovered, while debugging adraw, that the new code of d+, included some days ago, has a bug: The calculation 0 0 0 1 d+ should leave 0 1 on the stack, but it leaves 0 -1. Restored the original Abersoft Forth version of d+.
Converted the code of plotted? from hex opcodes to assembler, and modified it to return -1 instead of 1.
Updated the assembler after Fasmo, the Z80 assembler for Gforth, based on the same code.
2015-08-23
Removed ?comp from >mark, <mark, >resolve and <resolve, otherwise they can not work in assembler definitions.
Moved the assembler words from the kernel to the library, including the assembler vocabulary, and modified the actual assembler accordingly. But it didn't work because the assembler itselfs requires some library low-level words that are compiled with code end-code and , c,... Restored the previous situation: the kernel provides the assembler vocabulary and all core words required to code in Z80 by hand. Library words that require the actual assembler must do require z80-asm.
Fixed warm. The problem was the same as cold's: somehow channel 2 was not open.
Moved update and flush to the library.
Removed the graphic word emmitted from the kernel. It must be adapted to the Forth assembler.
Converted dp into an user variable again, after asking about it in comp.lang.forth.
Added cconstant, and used it in user instead of constant.
; ----------------------------------------------
_colon_header c_constant_,'CCONSTANT'
dw create_,c_comma_
dw paren_semicolon_code_
do_constant:
inc de ; de=pfa
ex de,hl ; hl=pfa
jp c_fetch.hl
2015-08-25
Added another sound effect to the library, and also the music words from Spectrum Forth-83. Not tested yet.
Fixed a strange new bug that was introduced two days ago: the system crashes after pressing the Enter key. It was necessary to update the version of the source for GNU binutils, comparing it with the current version for Pasmo. The stupid mistake was I had written the user variable index of dp in decimal, but with hex notation.
Rewrote part of the error message system: Renamed warning to warnings. Converted the msg-scr constant to a user variable and made message to print text messages only if msg-scr is not zero. Wrote warning to print warnings depending on warnings. Modified header and error accordingly. This way, warnings can be turned off completely, error messages are independent from warnings, and messages can be used for other purposes, even by different tasks. Eventually, throw and catch will be implemented.
; ----------------------------------------------
_colon_header warning_,'WARNING'
; doc{
;
; warning ( n -- )
;
; }doc
dw warnings_,fetch_
dw question_branch_,message_pfa
dw drop_
dw semicolon_s_
; ----------------------------------------------
_colon_header message_,'MESSAGE'
; doc{
;
; message ( n -- )
;
; }doc
dw msg_scr_,fetch_
dw zero_branch_,message.number_only
dw error_to_line_,msg_scr_,fetch_,dot_line_,space_
dw semicolon_s_
message.number_only:
dw paren_dot_quote_
_string 'MSG # '
dw base_,fetch_,swap_,decimal_,dot_,base_,store_
dw semicolon_s_
Now scr is updated also by (load). The new library word reload uses it, what is useful during debugging.
Fix: moved asm to the forth vocabulary.
Moved !csp and ?csp from code end-code to asm end-asm, since the later structure is included in the former one, and the check is useful also when asm end-asm are used directly.
Finished the code conversion of two new sound effects added to the library:
( laser-gun )
\ Laser gun sound for ZX Spectrum 48K.
\ Author of the original code: Álvaro Corredor Lanas.
\ Published in Microhobby, issue 126 (1987), page 7:
\ http://microhobby.org/numero126.htm
\ http://microhobby.speccy.cz/mhf/126/MH126_07.jpg
require z80-asm
code laser-gun ( -- )
bc push
5 b ld#
0500 hl ldp#
<mark 0001 de ldp#
hl push 03B5 call hl pop
0010 de ldp# de subp
jrnz
bc pop next ix ldp# next,
end-code
( white-noise )
\ White noise for ZX Spectrum 48K.
\ Author of the original code: Ricardo Serral Wigge.
\ Published in Microhobby, issue 125 (1987), page 26:
\ http://microhobby.org/numero125.htm
\ http://microhobby.speccy.cz/mhf/125/MH125_26.jpg
\ The original code was called "explosion" and had a fixed
\ duration of 768 sample bytes, thus equivalent to `768
\ white-noise`.
require z80-asm
code white-noise ( u -- )
\ u = duration in number of sample bytes
de pop
bc push \ save the Forth IP
de bc ldp 0000 hl ldp# \ bc=duration, hl=start of ROM
5C48 fta a sra a sra a sra 07 and# a d ld
\ d = border color (in bits 0-2)
<mark m e ld hl incp bc decp bc push
08 b ld# \ bit counter
<mark e a ld 10 and# e rl d or FE out \ beep
djnz
bc pop c a ld b or
jrnz
bc pop next, \ restore the Forth IP and go next
end-code
Added versatile alternatives to plot:
( set-pixel )
\ Set a pixel without changing the color attributes.
\ Author of the original code: José Manuel Lazo.
\ Published in Microhobby, issue 85 (1986-07), page 24:
\ http://microhobby.org/numero085.htm
\ http://microhobby.speccy.cz/mhf/085/MH085_24.jpg
require pixel-add require z80-asm
code set-pixel ( xc yc -- )
hl pop de pop bc push
l b ld e c ld pixel-add call
a b ld b inc 1 a ld#
<mark a rrc djnz
m or a m ld \ combine pixel with byte in the screen
bc pop next,
end-code
( reset-pixel )
\ Reset a pixel without changing the color attributes.
\ Based on code written by José Manuel Lazo,
\ published in Microhobby, issue 85 (1986-07), page 24:
\ http://microhobby.org/numero085.htm
\ http://microhobby.speccy.cz/mhf/085/MH085_24.jpg
require pixel-add require z80-asm
code reset-pixel ( xc yc -- )
hl pop de pop bc push
l b ld e c ld pixel-add call
a b ld b inc 1 a ld#
<mark a rrc djnz
cpl m and a m ld \ combine pixel with byte in the screen
bc pop next,
end-code
( toggle-pixel )
\ Toggle a pixel without changing the color attributes.
\ Based on code written by José Manuel Lazo,
\ published in Microhobby, issue 85 (1986-07), page 24:
\ http://microhobby.org/numero085.htm
\ http://microhobby.speccy.cz/mhf/085/MH085_24.jpg
require pixel-add require z80-asm
code toggle-pixel ( xc yc -- )
hl pop de pop bc push
l b ld e c ld pixel-add call
a b ld b inc 1 a ld#
<mark a rrc djnz
m xor a m ld \ combine pixel with byte in the screen
bc pop next,
end-code
Renamed plotted? to pixel?.
Added d>s to the kernel.
2015-08-26
Finished the conversion of some 128K sound effects, and the word play to play them.
( waves shoot helicopter train )
\ `waves` and `shoot` are
\ adapted from code written by Juan José Ruiz,
\ published in Microhobby, issue 139 (1987-07), page 7:
\ http://microhobby.org/numero139.htm
\ http://microhobby.speccy.cz/mhf/139/MH139_07.jpg
create waves ( -- a )
0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 7 c,
71 c, 20 c, 20 c, 20 c, 0 c, 38 c, 14 c,
create shoot ( -- a )
10 c, 0 c, 177 c, 0 c, 191 c, 0 c, 31 c,
71 c, 20 c, 20 c, 20 c, 92 c, 28 c, 3 c,
\ `helicopter` and `train` are
\ adapted from code written by José Ángel Martín,
\ published in Microhobby, issue 172 (1988-09), page 22:
\ http://microhobby.org/numero172.htm
\ http://microhobby.speccy.cz/mhf/172/MH172_22.jpg
create helicopter ( -- a )
200 c, 15 c, 200 c, 15 c, 200 c, 15 c, 0 c,
7 c, 23 c, 23 c, 23 c, 255 c, 1 c, 12 c,
create train ( -- a )
100 c, 120 c, 48 c, 97 c, 12 c, 200 c, 55 c,
15 c, 9 c, 11 c, 55 c, 180 c, 4 c, 8 c,
( play )
\ Code inspired by the article
\ "Las posibilidades sonoras del 128 K",
\ written by Juan José Rosado Recio,
\ published in Microhobby, issue 147 (1987-10), page 24:
\ http://microhobby.org/numero147.htm
\ http://microhobby.speccy.cz/mhf/147/MH147_24.jpg
require !p
[defined] sound-register-port
?\ 65533 constant sound-register-port
[defined] sound-write-port
?\ 49149 constant sound-write-port
: play ( a -- )
\ a = address of a table with 14 bytes
14 0 do
i sound-register-port !p dup c@ sound-write-port !p 1+
loop drop ;
Renamed next, to jpnext, clearer.
Removed pushhl,, pushhlde, and fetchhl, from the kernel. The word definitions that used them have been updated (example, C3 c, pushhl , instead of pushhl,.
2015-08-27
Included all G+DOS modules from Afera and started the first changes in the code.
Added some graphic effects to the library.
2015-08-28
Finished two of the new graphic effects:
( horizontal-curtain )
\ [Code adapted from a routine written by Alejandro Mora,
\ published in Microhobby, issue 128 (1987-05), page 7:
\ http://microhobby.org/numero128.htm
\ http://microhobby.speccy.cz/mhf/128/MH128_07.jpg]
require z80-asm
code horizontal-curtain ( b -- )
\ Wash the screen with the given color
\ attribute _b_ from the top and bottom
\ rows to the middle.
de pop bc push
e a ld 5800 de ldp# 5AFF hl ldp#
0C b ld#
begin bc push 20 b ld#
begin a m ld de stap
bc push 02 b ld#
begin bc push FF b ld# begin step
bc pop step
bc pop de incp hl decp step
bc pop step
bc pop jpnext
end-code
( vertical-curtain )
\ [Code adapted from a routine written by Alejandro Mora,
\ published in Microhobby, issue 128 (1987-05), page 7:
\ http://microhobby.org/numero128.htm
\ http://microhobby.speccy.cz/mhf/128/MH128_07.jpg]
require z80-asm
code vertical-curtain ( b -- )
\ Wash the screen with the given color
\ attribute _b_ from the left and right
\ columns to the middle.
\ b = color attribute
\ XXX FIXME crash!
de pop bc push
e a ld 5800 de ldp# 5AFF hl ldp# 10 b ld#
begin bc push 18 b ld# de push hl push
begin a m ld de stap bc push 02 b ld#
begin bc push FF b ld# begin step
bc pop step
20 b ld#
begin de incp hl decp step
bc pop step
hl pop de pop bc pop de incp hl decp step
bc pop jpnext end-code
![http://microhobby.speccy.cz/mhf/128/MH128_07.jpg]](http://microhobby.speccy.cz/mhf/128/MH128_07.jpg]){kind=link}
Added a new sound effect:
( ambulance )
\ Ambulance sound for ZX Spectrum 48K.
\ Author of the original code: Líder Software.
\ Published in Microhobby, issue 142 (1987-09), page 7:
\ http://microhobby.org/numero142.htm
\ http://microhobby.speccy.cz/mhf/142/MH142_07.jpg
require z80-asm
code ambulance ( n -- )
\ n = times
de pop bc push e b ld
begin bc push 0320 hl ldp# 000A de ldp#
<mark hl push
03B5 call \ ROM beeper
hl pop hl decp
h a ld l or
jrnz
bc pop
step
bc pop next ix ldp# jpnext
end-code
2015-08-30
Fixed wrong Z80 instructions in <file and >file.
Added pusha to the kernel and improved three words in the library with it.
Fixed file?: it still returned 1 as a true flag and didn't restored the border color.
Added u.s to the library, a variant of .s that uses u..
Renamed cat and acat as wcat and wacat; added cat and acat to call them with a default wildcard to list all files.
2015-08-31
Modified ior>error: now the offset for G+DOS errors is 31 instead of 100. The G+DOS error messages have been added to the library, and they are printed when msg-scr points to the correspondent screen.
Finished the definitions of set-order and get-order. At the moment get-order uses #vocs instead of the actual number of vocs in the search order. Beside, set-order is not ANS Forth compliant because of the different words included in the minimum search order.
: (get-order) ( n -- widn..wid1 n)
\ Do get the search order.
1- -1 swap do context i cells + @ -1 +loop ;
: get-order ( -- 0 | widn..wid1 n)
\ Get the search order.
#vocs ?dup if (get-order) then #vocs ;
: (set-order) ( widn..wid1 n -- )
\ Do set a search order.
0 do context i cells + ! loop ;
: set-order ( -1 | 0 | widn..wid1 n -- )
\ Set a search order.
dup -1 = if drop only exit then -order
?dup if (set-order) then ;
Started adapting the FZX driver written by Andrew Owen and Einar Saukas. This way arbitrary sized and proportional fonts will be supported, as an option to the default printing routines provided by the ROM.
Factored >relmark with just-here in the assembler, because several times >relmark was used to resolve a branch, not to mark its origin.
Added rld to the assembler.
Moved defer and (defer) to the kernel, in order to make emit and cr defered words.