Solo Forth development history in 2016-04
Description of the page content
Solo Forth development history in 2016-04.
Tags:
2016-04-02
Factored default-header from nextname-header and added it to cold in order to restore the default behaviour after a cold restart. This fixes a rare but possible bug, detected during the development of indexer.
Started the indexer tool.
Factored new-needed-word from needed. This change was needed for indexer.
2016-04-03
Made need and related words deferred. Factored new-needed-word from needed. These changes were needed for indexer.
defer reneeded ( ca len -- )
\ doc{
\
\ reneeded ( ca len -- )
\
\ Load the first block whose header contains the string _ca
\ len_ (surrounded by spaces). If not found, throw an
\ exception -268 ("required, but not located").
\
\ This is a deferred word whose default behaviour is
\ `locate-reneeded`.
\
\ }doc
: locate-reneeded ( ca len -- ) located ?located load ;
\ doc{
\
\ locate-reneeded ( ca len -- )
\
\ Locate the first block whose header contains the string _ca
\ len_ (but surrounded by spaces), and load it. If not found,
\ throw an exception -268 ("required, but not located").
\
\ This is the default behaviour of the deferred word
\ `reneeded`.
\
\ }doc
defer reneed ( "name" -- )
\ doc{
\
\ reneed ( ca len -- )
\
\ Load the first block whose header contains "name" (but
\ surrounded by spaces).
\
\ This is a deferred word whose default behaviour is
\ `locate-reneed`.
\
\ }doc
: locate-reneed ( "name" -- )
parse-name save-string reneeded ;
\ doc{
\
\ locate-reneed ( ca len -- )
\
\ Locate the first block whose header contains "name" (but
\ surrounded by spaces), and load it. If not found, throw an
\ exception -268 ("required, but not located").
\
\ This is the default behaviour of the deferred word
\ `reneed`.
\
\ }doc
-->
( needed-word [needed] [unneeded] )
2variable needed-word
\ XXX TODO -- make `[needed]` and `[unneeded]` optional.
: [needed] ( "name" -- wf )
parse-name needed-word 2@ 2dup or
if compare 0= exit then 2drop 2drop true ; immediate
\ doc{
\
\ [needed] ( "name" -- wf )
\
\ Is "name" the needed word specified by the last execution
\ of `need` or `needed`?
\
\ }doc
: [unneeded] ( "name" -- wf )
postpone [needed] 0= ; immediate
\ doc{
\
\ [unneeded] ( "name" -- wf )
\
\ Is "name" different than the needed word specified by the
\ last execution of `need` or `needed`?
\
\ }doc
: new-needed-word ( ca len -- ca len )
-trailing -leading save-string 2dup needed-word 2! ;
-->
( needed need )
defer needed ( ca len -- )
\ doc{
\
\ needed ( ca len -- )
\
\ If the string _ca len_ is not the name of a word found in
\ the current search order, load the first block of the
\ library where "name" is included in the block header
\ (but surrounded by spaces).
\ If not found, throw an
\ exception -268 ("required, but not located").
\
\ This is a deferred word whose default behaviour is
\ `locate-needed`.
\
\ }doc
: locate-needed ( ca len -- )
needed-word 2@ 2>r new-needed-word 2dup undefined?
if locate-reneeded else 2drop then 2r> needed-word 2! ;
\ doc{
\
\ locate-needed ( ca len -- )
\
\ If the string _ca len_ is not the name of a word found in
\ the current search order, locate the first block of the
\ library where "name" is included in the block header (but
\ surrounded by spaces), and load it. If not found, throw an
\ exception -268 ("required, but not located").
\
\ This is the default behaviour of the deferred word
\ `needed`.
\
\ }doc
defer need ( "name" -- )
\ doc{
\
\ need ( "name" -- )
\
\ If "name" is not found in the current search order, locate
\ the first block of the library where "name" is included is
\ the block header (but surrounded by spaces), and load it.
\ If not found, throw an exception -268 ("required, but not
\ located").
\
\ This is a deferred word whose default behaviour is
\ `locate-need`.
\
\ }doc
: locate-need ( "name" -- ) parse-name needed ;
\ doc{
\
\ locate-need ( "name" -- )
\
\ If "name" is not found in the current search order, locate
\ the first block of the library where "name" is included is
\ the block header (but surrounded by spaces), and load it.
\ If not found, throw an exception -268 ("required, but not
\ located").
\
\ This is the default behaviour of the deferred word `need`.
\
\ }doc
: set-located-need ( -- )
['] locate-reneeded ['] reneeded defer!
['] locate-reneed ['] reneed defer!
['] locate-need ['] need defer!
['] locate-needed ['] needed defer! ;
\ doc{
\
\ set-located-need ( -- )
\
\ Set the default behaviour of `need`, `needed`, `reneed` and
\ `reneeded`: Use `locate` for searching the library.
\
\ The alternative, provided by the optional `indexer` tool,
\ is set by `set-indexed-need`.
\
\ }doc
set-located-need
Added string/, useful for a check done by indexer:
( string/ )
code string/ ( ca1 len1 len2 -- ca2 len2 )
\ ; T B
\ ; -- --
D9 c, C1 c, D1 c, E1 c,
\ exx ; save IP ; 04 01
\ pop bc ; len2 ; 10 01
\ pop de ; len1 ; 10 01
\ pop hl ; ca1 ; 10 01
19 c, A7 c, ED c, 42 c,
\ add hl,de ; 11 01
\ and a ; cy=0 ; 04 01
\ sbc hl,bc ; hl=ca2 ; 15 02
E5 c, C5 c,
\ push hl ; 11 01
\ push bc ; 11 01
D9 c, jpnext
\ exx ; restore IP ; 04 01
\ jp (ix) ; 08 02
\ ; -- --
\ ; 98 13 Total
end-code
\ doc{
\
\ string/ ( ca1 len1 len2 -- ca2 len2 )
\
\ Return the _len2_ ending characters of string _ca1 len1_.
\
\ }doc
exit
\ Slower version, 1 byte shorter
\
\ Credit: code from Galope.
: string/ ( ca1 len1 len2 -- ca2 len2 )
>r + r@ - r> ;
\ Return the _len2_ ending characters of string _ca1 len1_.
Splitted and renamed the error codes files, in order to make sure they are included in the right order.
Finished the indexer tool:
( indexer )
only forth definitions
need loader need s= need alias need string/
need get-order need set-order
wordlist constant index-wordlist
\ Words of the blocks index.
: search-index ( ca len -- 0 | xt 1 | xt -1 )
index-wordlist search-wordlist ;
\ Search the index for word _ca len_.
: name-indexed? ( ca len -- f )
search-index 0<> dup if nip then ;
\ Is word _ca len_ in the index?
variable indexed-block
: (index-name) ( ca len -- )
2dup name-indexed? if 2drop exit then
nextname indexed-block @ loader ;
\ Add word _ca len_ to the blocks index, if not done before.
\ The current word list is supposed to be `index-wordlist`.
-->
( indexer )
wordlist dup constant indexer-wordlist set-current
\ Words to parse the block index lines.
: ( ( "ccc<space><paren><space|eof>" -- )
begin parse-name 2dup s" )" s= 0=
while (index-name) repeat 2drop ;
\ Parse and index the names until the next right paren name.
' ( alias .(
: \ ( "ccc<space><backslash><space|eof>" -- )
begin parse-name 2dup s" \" s= 0=
while (index-name) repeat 2drop ;
\ Parse and index the names until the next backslash name.
-->
( indexer )
forth-wordlist set-current
: index-reneeded ( ca len -- )
search-index 0= #-277 ?throw execute ;
\ doc{
\
\ index-reneeded ( ca len-- )
\
\ Search the index word list for word _ca len_. If found,
\ execute it, causing its associated block be loaded. If not
\ found, throw an exception -277 ("required, but not
\ indexed").
\
\ This is an alternative behaviour of the deferred word
\ `reneeded`.
\
\ }doc
: index-reneed ( "name" -- ) parse-name index-reneeded ;
\ doc{
\
\ index-reneed ( "name" -- )
\
\ Search the index word list for word "name". If found,
\ execute it, causing its associated block be loaded. If not
\ found, throw an exception -277 ("required, but not
\ indexed").
\
\ This is an alternative behaviour of the deferred word
\ `reneed`.
\
\ }doc
: index-needed ( ca len -- )
needed-word 2@ 2>r new-needed-word 2dup undefined?
if index-reneeded else 2drop then 2r> needed-word 2! ;
\ doc{
\
\ index-needed ( ca len -- )
\
\ If word _ca len_ is found in the current search order, do
\ nothing. Otherwise search the index word list for it. If
\ found, execute it, causing its associated block be loaded.
\ If not found, throw an exception -277 ("required, but not
\ indexed").
\
\ This is an alternative behaviour of the deferred word
\ `needed`.
\
\ }doc
: index-need ( "name" -- ) parse-name index-needed ;
\ doc{
\
\ index-need ( "name" -- )
\
\ If word "name" is found in the current search order, do
\ nothing. Otherwise search the index word list for it. If
\ found, execute it, causing its associated block be loaded.
\ If not found, throw an exception -277 ("required, but not
\ indexed").
\
\ This is an alternative behaviour of the deferred word
\ `need`.
\
\ }doc
: set-indexed-need ( -- )
['] index-reneeded ['] reneeded defer!
['] index-reneed ['] reneed defer!
['] index-need ['] need defer!
['] index-needed ['] needed defer! ;
\ doc{
\
\ set-indexed-need ( -- )
\
\ Set the alternative behaviour of `need`, `needed`, `reneed`
\ and `reneeded`: Use the library index created by `indexer`.
\ In fact `indexer` executes `set-indexed-need` after
\ creating the index.
\
\ The default behaviour can be restored by
\ `set-located-need`.
\
\ }doc
-->
( indexer )
: valid-block-header? ( ca len -- f )
-trailing dup 0= #-278 ?throw
2 string/ 2dup s" )" s= >r s" \" s= r> or ;
\ Is block header _ca len_ valid?
\ Valid block headers end with " )" or " /".
\ If it's empty, throw error -278 in order to quit
\ the indexing.
: index-block-header ( ca len -- )
2dup valid-block-header? if evaluate exit then 2drop ;
\ Index block header _ca len_, if it's valid.
: index-block ( +n -- )
dup indexed-block ! 0 swap line>string index-block-header ;
\ Index block _+n_.
: (indexer) ( -- )
last-locatable @ 1+ first-locatable @
?do i index-block loop ;
\ Create the blocks index.
: indexer ( -- )
get-current get-order
index-wordlist set-current indexer-wordlist 1 set-order
['] (indexer) catch dup #-278 <> swap ?throw
set-order set-current set-indexed-need ;
\ doc{
\
\ indexer ( -- )
\ Create the blocks index and activate it. The the current
\ word list and the current search order are preserved.
\
\ }doc
indexer improves the default behaviour of need, needed, reneed and reneeded: It creates a word list from the names that are on the index (header) line of every searchable block, ignoring duplicates. These words will load the block they belong to. This way, after indexing all of the disk blocks only once, need will search the word list and execute the word found, instead of searching all of the blocks every time.
At the time of writing, indexing the whole library (677 blocks) takes less than one minute and uses 3600 bytes of dictionary space.
Finished rewriting the file headers of the library modules that are based on other people's code, based on the documentation and credits of the original versions.
2016-04-05
Added cell/ to the library.
Fixed a recently introduced bug in jppushl.
Added the pseudo-random number generator from IsForth.
Fixed the maximum y coordinate of (random-coords), part of rng-benchmark.
Added d10* to the library.
2016-04-07
Added bits, a generic version of pixels:
( bits )
\ Credit:
\
\ Based on a pixels counter written by Juan Antonio Paz,
\ published on Microhobby, issue 170 (1988-05), page 21:
\ http://microhobby.org/numero170.htm
\ http://microhobby.speccy.cz/mhf/170/MH170_21.jpg
need z80-asm
code bits ( ca len -- u )
0 hl ldp# \ init bit count
exx \ save IP and count
de pop hl pop \ memory zone
begin cr .s
d a ld e or nz if cr .s
08 b ld# \ bits per byte
begin m rrc cy if exx hl incp exx then step
hl incp de decp \ next byte
2swap again then
\ Note: `2swap` is needed because `begin again` and `if
\ then` are not nested.
exx jppushhl end-code
\ doc{
\
\ bits ( ca len -- u )
\
\ Count the number of bits set in memory zone _ca len_.
\
\ }doc
2016-04-08
Added a new 8-bit crnd, adapted from libzx Sebastian Mihai's libzx library. But the results of Joe Wingbermuehle's code are better.
( opt2-libzx-crnd )
\ Credit:
\ Original code from the ZX Spectrum libzx library,
\ written by Sebastian Mihai, 2016
\ 2016-04-09: Adapted to Solo Forth. Optimized and modified
\ the original code.
need z80-asm need os-seed need random-pix-benchmark
variable rom-pointer rom-pointer off os-seed off
code opt2-libzx-crnd ( -- b )
\ Gets an 8-bit random number.
\ It is computed using a combination of:
\ - the last returned random number
\ - a byte from ROM, in increasing order
\ - current values of various registers
\ - a flat incremented value
bc push af push
\ save Forth IP and the AF register
\ 1) advance ROM pointer
rom-pointer hl ftp hl incp
h a ld %00111111 and a h ld hl rom-pointer stp
\ ld hl,(romPointer)
\ inc hl
\ ld a, h
\ and %00111111
\ ld h, a ; H := H mod %00111111
\ ; essentially, HL := HL mod 16384, to make sure
\ ; HL points at a ROM location
\ ld (romPointer), hl ; save new location
\ 2) compute the random number
bc pop c rlc b rlc os-seed fta
\ pop bc ; BC := AF
\ rlc c
\ rlc b
\ ld a, (lastRandomNumber)
47 add# b add c add d add e add h add l add
\ add a, 47
\ add a, b ; current register values are "pretty random"
\ add a, c ; so add them in the mix
\ add a, d
\ add a, e
\ add a, h
\ add a, l
rom-pointer hl ldp# m add
\ ld hl, romPointer
\ add a, (hl) ; the contents of the ROM are "pretty random"
\ ; so add it in the mix
os-seed sta
\ ld (lastRandomNumber), a ; save this number
bc pop pusha jp end-code
: libzx-random-pix-benchmark ( -- )
rom-pointer off os-seed off s" libzx opt2 (8 bit)"
['] opt2-libzx-crnd random-pix-benchmark ;
libzx-random-pix-benchmark \ XXX TMP --
( opt1-libzx-crnd )
\ Credit:
\ Original code from the ZX Spectrum libzx library,
\ written by Sebastian Mihai, 2016
\ 2016-04-09: Adapted to Solo Forth. Optimized the original
\ code.
need z80-asm need os-seed need random-pix-benchmark
variable rom-pointer 3 rom-pointer ! 33 os-seed c!
code opt1-libzx-crnd ( -- b )
\ Gets an 8-bit random number.
\ It is computed using a combination of:
\ - the last returned random number
\ - a byte from ROM, in increasing order
\ - current values of various registers
\ - a flat incremented value
bc push af push
\ save Forth IP and the AF register
\ 1) advance ROM pointer
rom-pointer bc ftp 3 hl ldp# bc addp
\ ld bc,(romPointer)
\ ld hl,3
\ add hl,bc ; HL := ROM pointer advanced by 3
h a ld %00111111 and a h ld hl rom-pointer stp
\ ld a, h
\ and %00111111
\ ld h, a ; H := H mod %00111111
\ ; essentially, HL := HL mod 16384, to make sure
\ ; HL points at a ROM location
\ ld (romPointer), hl ; save new location
\ 2) compute the random number
bc pop c rlc b rlc os-seed fta
\ pop bc ; BC := AF
\ rlc c
\ rlc b
\ ld a, (lastRandomNumber)
47 add# b add c add d add e add h add l add
\ add a, 47
\ add a, b ; current register values are "pretty random"
\ add a, c ; so add them in the mix
\ add a, d
\ add a, e
\ add a, h
\ add a, l
rom-pointer hl ldp# m add
\ ld hl, romPointer
\ add a, (hl) ; the contents of the ROM are "pretty random"
\ ; so add it in the mix
os-seed sta
\ ld (lastRandomNumber), a ; save this number
bc pop pusha jp end-code
: libzx-random-pix-benchmark ( -- )
3 rom-pointer ! 33 os-seed c!
s" libzx opt1 (8 bit)"
['] opt1-libzx-crnd random-pix-benchmark ;
( libzx-crnd )
\ Credit:
\ Original code from the ZX Spectrum libzx library,
\ written by Sebastian Mihai, 2016
\ 2016-04-09: Adapted to Solo Forth.
need z80-asm need os-seed need random-pix-benchmark
variable rom-pointer 3 rom-pointer ! 33 os-seed c!
code libzx-crnd ( -- b )
\ Gets an 8-bit random number.
\ It is computed using a combination of:
\ - the last returned random number
\ - a byte from ROM, in increasing order
\ - current values of various registers
\ - a flat incremented value
bc push af push
\ save Forth IP and the AF register
\ 1) advance ROM pointer
rom-pointer hl ldp#
m c ld hl incp m b ld 3 hl ldp# bc addp
\ XXX TODO -- simpler
\ XXX REMARK -- original code is not optimized
\ ld hl, romPointer
\ ld c, (hl)
\ inc hl
\ ld b, (hl) ; BC := word (romPointer)
\ ld hl, 3
\ add hl, bc ; HL := ROM pointer advanced by 3
h a ld %00111111 and a h ld hl rom-pointer stp
\ ld a, h
\ and %00111111
\ ld h, a ; H := H mod %00111111
\ ; essentially, HL := HL mod 16384, to make sure
\ ; HL points at a ROM location
\ ld (romPointer), hl ; save new location
\ 2) compute the random number
bc pop c rlc b rlc os-seed fta
\ pop bc ; BC := AF
\ rlc c
\ rlc b
\ ld a, (lastRandomNumber)
47 add# b add c add d add e add h add l add
\ add a, 47
\ add a, b ; current register values are "pretty random"
\ add a, c ; so add them in the mix
\ add a, d
\ add a, e
\ add a, h
\ add a, l
rom-pointer hl ldp# m add
\ ld hl, romPointer
\ add a, (hl) ; the contents of the ROM are "pretty random"
\ ; so add it in the mix
os-seed ldp# m a ld
\ ld hl, lastRandomNumber
\ ld (hl), a ; save this number
\ XXX REMARK -- original code is not optimized
bc pop 0 h ld# a l ld jppushhl end-code
: libzx-random-pix-benchmark ( -- )
3 rom-pointer ! 33 os-seed c!
s" libzx (8 bit)" ['] libzx-crnd random-pix-benchmark ;
2016-04-09
Released version 0.3.0.
Splitted the assembler library module into three files: z80-asm assembler, z80-asm-comma assembler and common tools.
Fixed the title of two 8-bit pseudo-random number generator benchmarks.
Fixed the name of the base-execute library module.
Released version 0.3.1.
Fixed, improved and finished the arguments implementation of locals.
Released version 0.3.2.
2016-04-10
Fixed the tape support. There were two bugs: 1) The parameter passed to the ROM routine in the HL register was wrong. 2) The status of the display was not saved and restored, and the system crashed at the end because of the message "Start tape, then press any key" printed by the ROM routine (which will be avoided in the next version).
( write-tape-file read-tape-file )
17 constant /tape-header
\ bytes per tape header
create tape-header /tape-header 2 * allot
\ save (=new) and load (=old) headers
10 constant /tape-filename \ filename max length
: tape-filetype ( -- ca ) tape-header ;
: tape-filename ( -- ca ) tape-header 1+ ;
: tape-length ( -- a ) tape-header 11 + ;
: tape-start ( -- a ) tape-header 13 + ;
3 tape-filetype c! \ "code" filetype by default
-->
( write-tape-file read-tape-file )
code (tape) ( n -- )
E1 c, C5 c, 78 05 + c,
\ pop hl
\ push bc ; save Forth IP
\ ld a,l ; 0=save, 1=load, 2=verify
DD c, 21 c, tape-header , 2A c, tape-start ,
\ ld ix,tape_header
\ ld hl,(tape_start)
32 c, 5C74 , CD c, 075A ,
\ ld (5C74),A ; T_ADDR system variable
\ call 075A ; SA_ALL ROM routine
C1 c, DD c, 21 c, next ,
\ pop bc ; restore Forth IP
\ ld ix,next ; restore the address of Forth next
jpnext end-code
\ doc{
\
\ (tape) ( n -- )
\
\ Tape primitive that uses the data stored at `tape-header`
\ to save (n=0), load (n=1) or verify (n=2) a tape file.
\
\ }doc
-->
( write-tape-file read-tape-file )
: -tape-filename ( -- ) tape-filename /tape-filename blank ;
\ doc{
\
\ -tape-filename ( -- )
\
\ Blank the filename of the tape header.
\
\ }doc
: set-tape-filename ( ca len -- )
-tape-filename /tape-filename min
tape-filename swap cmove ;
\ doc{
\
\ set-tape-filename ( ca len -- )
\
\ Store a filename into the tape header.
\
\ }doc
: any-tape-filename ( -- ) 255 tape-filename c! ;
\ Configure the tape header to load any filename,
\ by replacing the first char of the filename with 255.
-->
( write-tape-file read-tape-file )
need save-display need restore-display
: transfer-tape-file ( ca len n -- )
save-display
>r tape-length ! tape-start ! r> (tape)
restore-display ;
\ doc{
\
\ : transfer-tape-file ( ca len n -- )
\
\ Read or write the tape file whose filename and filetype
\ have been already set in `tape-header`. _n_ is 0 for
\ writing or 1 for reading; _ca len_ is the memory zone.
\
\ }doc
: read-tape-file ( ca1 len1 ca2 len2 -- )
dup if set-tape-filename
else 2drop any-tape-filename
then 1 transfer-tape-file ;
\ doc{
\
\ read-tape-file ( ca1 len1 ca2 len2 -- )
\
\ Read a tape file _ca2 len2_ (_len2_ is zero if filename is
\ unspecified) into a memory region _ca1 len1_.
\
\ _ca1_ is zero if the address must be taken from the file
\ header instead, which is the address the file was saved
\ from. _len1_ is zero if is unspecified.
\
\ }doc
: write-tape-file ( ca1 len1 ca2 len2 -- )
set-tape-filename 0 transfer-tape-file ;
\ doc{
\
\ write-tape-file ( ca1 len1 ca2 len2 -- )
\
\ Write a memory region _ca1 len1_ into a tape file _ca2
\ len2_.
\
\ }doc
New words were needed for the tape support. They are defined in its own library module, graphics.display.fsb:
( nonfull-display full-display save-display restore-display )
: nonfull-display ( -- ) 2 23659 c! ;
\ doc{
\
\ nonfull-display ( -- )
\
\ Set the nonfull screen mode: 2 lines in the lower screen
\ and 22 lines in the upper main screen, which is the default
\ configuration in BASIC.
\
\ }doc
\ Note: 23659 is the system variable DF_SZ (lines in the
\ lower screen).
: full-display ( -- ) 0 23659 c! ;
\ doc{
\
\ full-display ( -- )
\
\ Set the full screen mode: no lines in the lower screen,
\ thus 24 lines in the upper main screen, which is the
\ default configuration in Solo Forth.
\
\ }doc
\ Note: 23659 is the system variable DF_SZ (lines in the
\ lower screen).
: save-display ( -- ) ( R: -- col row )
r> xy 2>r >r save-mode nonfull-display ;
\ doc{
\
\ save-display ( -- ) ( R: -- col row )
\
\ Save the status of the display. This word is intended to
\ be used before calling a ROM routine that uses the display.
\ The display can be restored to its previous status with
\ `restore-display`.
\
\ }doc
: restore-display ( -- ) ( R: col row -- )
display full-display restore-mode r> 2r> at-xy >r ;
\ doc{
\
\ restore-display ( -- ) ( R: col row -- )
\
\ Restore the status of the display, saved by `save-display`.
\ Intended to be used after calling a ROM routine that uses
\ the display.
\
\ }doc
Released version 0.4.0.
Improved the tape support: The message "Start tape, then press any key" does not appear anymore. Instead, writing to tape starts inmmediately. New version of the code:
( write-tape-file read-tape-file )
17 constant /tape-header
\ bytes per tape header
create tape-header /tape-header 2 * allot
\ save (=new) and load (=old) headers
10 constant /tape-filename \ filename max length
: tape-filetype ( -- ca ) tape-header ;
: tape-filename ( -- ca ) tape-header 1+ ;
: tape-length ( -- a ) tape-header 11 + ;
: tape-start ( -- a ) tape-header 13 + ;
3 tape-filetype c! \ "code" filetype by default
-->
( write-tape-file read-tape-file )
: -tape-filename ( -- ) tape-filename /tape-filename blank ;
\ doc{
\
\ -tape-filename ( -- )
\
\ Blank the filename of the tape header.
\
\ }doc
: set-tape-filename ( ca len -- )
-tape-filename /tape-filename min
tape-filename swap cmove ;
\ doc{
\
\ set-tape-filename ( ca len -- )
\
\ Store a filename into the tape header.
\
\ }doc
: any-tape-filename ( -- ) 255 tape-filename c! ;
\ doc{
\
\ any-tape-filename ( -- )
\
\ Configure the tape header to load any filename,
\ by replacing the first char of the filename with 255.
\
\ }doc
: set-tape-memory ( ca len -- )
tape-length ! tape-start ! ;
\ doc{
\
\ set-tape-memory ( ca len -- )
\
\ Configure the tape header with the memomy zone _ca len_ (to
\ be read or written).
\
\ }doc
-->
( write-tape-file read-tape-file )
code (read-tape-file) ( -- )
C5 c, DD c, 21 c, tape-header , 2A c, tape-start ,
\ push bc ; save Forth IP
\ ld ix,tape_header
\ ld hl,(tape_start)
3E c, 01 c, 32 c, 5C74 , CD c, 075A ,
\ ld a,1 ; 1=load
\ ld (5C74),A ; T_ADDR system variable
\ call 075A ; SA_ALL ROM routine
C1 c, DD c, 21 c, next ,
\ pop bc ; restore Forth IP
\ ld ix,next ; restore the address of Forth `next`
jpnext end-code
: read-tape-file ( ca1 len1 ca2 len2 -- )
dup if set-tape-filename else 2drop any-tape-filename
then set-tape-memory (read-tape-file) ;
\ doc{
\
\ read-tape-file ( ca1 len1 ca2 len2 -- )
\
\ Read a tape file _ca2 len2_ (_len2_ is zero if filename is
\ unspecified) into a memory region _ca1 len1_.
\
\ _ca1_ is zero if the address must be taken from the file
\ header instead, which is the address the file was saved
\ from. _len1_ is zero if is unspecified.
\
\ }doc
-->
( write-tape-file read-tape-file )
code (write-tape-file) ( -- )
C5 c, DD c, 21 c, tape-header ,
\ push bc ; save Forth IP
\ ld ix,tape_header
A8 07 + c, 32 c, 5C74 ,
\ xor a ; 0=save
\ ld (5C74),a ; T_ADDR system variable
21 c, here 0A + , E5 c,
\ ld hl,return_from_ROM
\ push hl ; simulate a call
2A c, tape-start , E5 c,
\ ld hl,(tape_start) ; start of data
\ push hl ; needed by entry point $0984,
\ ; because it's done at the main entry point $0970
C3 c, 0984 ,
\ jp $0984 ; alternative entry point to SA_ALL, after the save message
\ ; note: `jp` is used, but it works as a `call`,
\ ; because the return address has been pushed
\ return_from_ROM:
C1 c, DD c, 21 c, next ,
\ pop bc ; restore Forth IP
\ ld ix,next ; restore address of Forth `next`
jpnext end-code
: write-tape-file ( ca1 len1 ca2 len2 -- )
set-tape-filename set-tape-memory (write-tape-file) ;
\ doc{
\
\ write-tape-file ( ca1 len1 ca2 len2 -- )
\
\ Write a memory region _ca1 len1_ into a tape file _ca2
\ len2_.
\
\ }doc
2016-04-11
Released version 0.4.1.
Moved macro to its own module, since its definition is identical in both versions of the assembler, and can be useful without an assembler:
( macro )
need get-order
get-order get-current
only forth definitions also assembler
: macro ( "name" -- ) : asm ;
: endm ( -- ) end-asm postpone ; ; immediate
set-current set-order
Started plusd-in, plusd-out plusd-in,, plusd-out,.
Removed a wrong and unnecessary Z80 instruction from end-calc.
Checked the implementation of floating point based on the ROM calculator.
2016-04-12
Started f. and f,.
2016-04-13
Finished f. and f,.
Wrote .fs, f*, -frot.
Fixed fover and frot.
Made calc end-calc independent from the assemblers and moved it to the floating point module. Formerly it was defined in both assemblers.
Fixed execute-hl, which was not adapted from ITC yet, and did not save the Forth IP. It will be made independent from the assemblers too. The version for the second assembler has been renamed with a trailing comma.
macro execute-hl ( -- )
0000 bc stp |mark \ save the Forth IP
0000 bc ldp# |mark \ point IP to phony_compiled_word
jphl \ execute the xt in HL
>resolve \ phony_compiled_word
here cell+ , \ point to the phony xt following
0000 bc ldp# |resolve \ restore the Forth IP
endm
\ Compile an `execute` with the xt hold in HL.
The fixing of execute-hl made all floating point logical operators work.
The version numbering has been modified, converting the optional pre-release field release candidate to simple pre-release.
Factored the most common ROM calculator commands into assembler macros, in order to make the floating point more legible and easier to maintain.
Wrote first working versions of fmax and fmin.
Wrote a program to patch the source of the BASIC loader with the current load and entry addresses compiled in the kernel. So far those addresses were hardcoded in the source of the loader. Now the loader is automatically updated by Makefile when needed.
Wrote f0>, which was missing.
Fixed the problem with non-integer floating point numbers: the reason was the alternate registers set is used by the calculator, and the Forth IP was saved and restored with exx in calc and end-calc. Now the stack is used instead.
2016-04-14
Restored the file exceptions.fsb from the repository. It was removed from version 0.3.0+20160409 by mistake. Updated the headers and the documentation. Renamed (.throw) to .throw-message and msg-scr to error-messages-block. Fixed error>ordinal (codes below -255 were displaced by one).
Fixed the file error_codes.0256.system.fsb, which still contained also the standard errors.
Documented some sound words.
Renamed many library files. The goal is to build a logical hierarchy, easy to search and extend, without using subdirectories, in order to make it easy to select and link only the files needed by the application. The task is not finished: Math, system, media, DOS and other library files still have temporary names.
2016-04-15
Benchmarked the current primitive m+ and an alternative high level definition, which results 1.44 slower but saves 4 bytes.
Added j and k, which were missing since before version 0.1.0, after converting the fig-Forth do to Forth-83:
; ----------------------------------------------
_code_header i_,'I'
; Credit:
; Code adapted from Spectrum Forth-83.
ld hl,(return_stack_pointer)
i.hl: ; entry point for `j` and `k`
ld e,(hl)
inc hl
ld d,(hl) ; de= current index, wich is: (index-limit) xor $8000
inc hl
inc hl
inc hl
ld a,(hl)
add a,e ; read limit and add to index
ld e,a
inc hl
ld a,(hl)
adc a,d
xor $80 ; flip most significant bit, getting true index value
ld d,a
push de ; result
_jp_next
; ----------------------------------------------
_code_header j_,'J'
ld hl,(return_stack_pointer)
ld de,3*cell
add hl,de
jp i.hl
; ----------------------------------------------
_code_header k_,'K'
ld hl,(return_stack_pointer)
ld de,6*cell
add hl,de
jp i.hl
But they better be in the library. A constant in the kernel is enough to move them:
; ----------------------------------------------
_constant_header paren_i,'(I)'
; doc{
;
; (i) ( -- a )
;
; A constant that holds the address of the machine code entry
; point of `i` that calculates the `do` index from the address
; pointed by the HL register. Used by `j` and `k`.
;
; }doc
dw i.hl
The new versions in the library, documented:
( j )
code j ( -- n|u ) ( R: do-sys1 do-sys2 -- do-sys1 do-sys2 )
2A c, rp , 11 c, 3 cells , 19 c, C3 c, (i) ,
\ ld hl,(return_stack_pointer)
\ ld de,3*cell
\ add hl,de
\ jp i.hl
end-code
\ doc{
\
\ j ( -- n|u ) ( R: loop-sys1 loop-sys2 -- loop-sys1 loop-sys2 )
\
\ Return a copy _n|u_ of the next-outer loop index.
\
\ Origin: Forth-83 (Required word set), Forth-94 (CORE),
\ Forth-2012 (CORE). Note: `k` was also in Forth-79
\ (Reference word set), but returned a signed number.
\
\ }doc
( k )
code k ( -- n|u )
( R: loop-sys1..loop-sys3 -- loop-sys1..loop-sys3 )
2A c, rp , 11 c, 6 cells , 19 c, C3 c, (i) ,
\ ld hl,(return_stack_pointer)
\ ld de,6*cell
\ add hl,de
\ jp i.hl
end-code
\ doc{
\
\ k ( -- n|u ) ( R: loop-sys1..loop-sys3 -- loop-sys1..loop-sys3 )
\
\ Return a copy _n|u_ of the second outer loop index.
\
\ Origin: Forth-83 (Controlled reference words). Note: `k`
\ was also in Forth-79 (Reference word set), but returned a
\ signed number.
\
\ }doc
associative-list, based on code by Wil Baden (published on Forth Dimensions, volume 17, number 4, page 36, 1995-11), had been adapted and included in 2015-11, but now it has been improved with different types of data. A strange bug was discovered during the chanegs, related to (;code). Using the new variable last, which is updated by header,, instead of using fig-Forth's latest, which fetchs current, solves the problem.
Fixed decode-compile (from the decode utility), which had not been converted from ITC to DTC.
Fixed dump (the loop printed one byte more than requested). Improved ascii-type (now also characters above 127 are printed as dots, not masked).
Removed the old user variable #emit.
After fixing the problem of (;code), it was possible to finish associative-list:
( associative-list item? item create-entry )
: associative-list ( "name" -- ) wordlist constant ;
\ Create a new associative list "name".
: item? ( ca len wid -- false | xt true )
search-wordlist 0<> ;
\ Is _ca len_ an item of associative list _wid_?
\ If so return its _xt_ and _true_, else return _false_.
: item ( ca len wid -- i*x )
item? 0= #-13 ?throw execute ;
\ If _ca len_ is an item of associative list _wid_, return
\ its value _i*x_; else throw exception -13, "undefined
\ word".
: create-entry ( i*x wid xt "name" -- )
get-current >r swap set-current
create execute
r> set-current ;
\ Create an entry "name" in associative list _wid_,
\ using _xt_ to store its value _i*x_.
-->
( entry char-entry double-entry string-entry )
: entry ( x wid "name" -- )
['] , create-entry does> ( -- x ) ( pfa ) @ ;
\ Create a cell entry "name" in associative list
\ _wid_, with value _x_.
: char-entry ( c wid "name" -- )
['] c, create-entry does> ( -- c ) ( pfa ) c@ ;
\ Create a character entry "name" in associative list
\ _wid_, with value _c_.
: double-entry ( dx wid "name" -- )
['] 2, create-entry does> ( -- dx ) ( pfa ) 2@ ;
\ Create a double-cell entry "name" in associative list
\ _wid_, with value _dx_.
: string-entry ( ca len wid "name" -- )
['] s, create-entry does> ( -- ca len ) ( pfa ) count ;
\ Create a string entry "name" in associative list
\ _wid_, with value _ca len_.
( items )
need alias need wordlist-words
' wordlist-words alias items ( wid -- )
\ List items of associative list _wid_.
( associative-list-demo )
need associative-list need items
associative-list stuff
1887 stuff entry year
char E stuff char-entry letter
s" Saluton" stuff string-entry hello
314159. stuff double-entry pi
cr .( Keys:) cr stuff items cr
cr .( Values: ) cr
s" year" stuff item . cr
s" letter" stuff item emit cr
s" hello" stuff item type cr
s" pi" stuff item d. cr
2016-04-16
Fixed two minor problems in Makefile and Makefile.pasmo.
Revised for and dfor.
Finished times:
( times )
variable times-xt \ the _xt_ executed by `times`
: times ( i*x n -- j*x )
rp@ @ dup cell+ rp@ ! @ times-xt !
0 ?do times-xt perform loop ; compile-only
\ doc{
\
\ times ( i*x n -- j*x )
\
\ Repeat the next compiled instruction _n_ times. If _n_ is
\ zero, continue executing the following instruction.
\
\ `times` is useful to implement complicated math operations,
\ like shifts, multiply, divide and square root, from
\ appropriate math step instructions. It is also useful in
\ repeating auto-indexing memory instructions.
\
\ Usage example:
\
\ ----
\ : blink ( -- ) 7 0 do i border loop 0 border ;
\ : blinking ( -- ) 100 times blink ." Done" cr ;
\ ----
\
\ }doc
Improved Makefile in order to patch the +3DOS BASIC loader after the method used for G+DOS.
2016-04-17
Added -!:
( -! )
code -! ( n a -- )
E1 c, D1 c,
\ pop hl ; address
\ pop de ; number
7E c, 90 03 + c, 70 07 + c, 23 c,
\ ld a,(hl)
\ sub a,e
\ ld (hl),a
\ inc hl
7E c, 98 02 + c, 70 07 + c,
\ ld a,(hl)
\ sbc a,d
\ ld (hl),a
jpnext end-code
Fixed >name. So far it never returned when the search failed, because the ending condition was wrong. Beside, it has been rewritten for clarity, and it's 2 bytes shorter:
_code_header to_name_,'>NAME'
; doc{
;
; >name ( xt -- nt | 0 )
;
; Try to find the name token _nt_ of the word represented by
; execution token _xt_. Return 0 if it fails.
;
; This word searches all headers, from the oldest to the newest,
; for the first one whose _xtp_ (xt pointer) contains _xt_.
;
; Origin: Gforth.
;
; }doc
; XXX TODO -- Search backwards from `last @`?
call bank.system ; page in the memory bank
pop de ; xt
push bc ; save Forth IP
; save the names pointer for later:
ld a,(names_pointer)
ld (to_name.names_pointer_low_byte),a
ld a,(names_pointer+1)
ld (to_name.names_pointer_high_byte),a
ld b,0
ld hl, names_bank_address
to_name.begin:
; compare HL with the names pointer
; if they are equals, there are no more names to check
to_name.names_pointer_high_byte equ $+1
ld a,0
cp h
jr nz,to_name.check_xt
to_name.names_pointer_low_byte equ $+1
ld a,0
sub l
jr nz,to_name.check_xt
; no words left
; a=0
ld h,a
ld l,a ; hl = 0
jr to_name.end
to_name.check_xt
; Check if the xt pointed by HL is the one searched for
; hl = xtp
ld a,(hl) ; low byte of xt
inc hl
cp e ; equal?
jr nz,to_name.next ; not equal
ld a,(hl) ; high byte of xt
cp d ; equal?
jr nz,to_name.next ; not equal
; xt found
; hl = xtp+1
inc hl ; lfa
inc hl
inc hl ; nfa
to_name.end:
; hl = nt or zero
call bank.default ; page in the default memory bank
pop bc ; restore Forth IP
_jp_pushhl
to_name.next:
; hl = xtp+1
inc hl ; lfa
inc hl
inc hl ; nfa
ld a,(hl) ; name field byte length
and word_length_mask ; name length
ld c,a ; name length
inc c ; plus the length byte
add hl,bc ; xtp of the next word
jr to_name.begin
Moved !s and c!s to the library (src/lib/memory.bank.fsb). They are not needed in the kernel:
( !s c!s )
: !s ( x a -- ) system-bank ! default-bank ;
\ doc{
\
\ !s ( x a -- )
\
\ Store _x_ into address _a_ of the system bank.
\
\ }doc
: c!s ( c ca -- ) system-bank c! default-bank ;
\ doc{
\
\ c!s ( c ca -- )
\
\ Store _c_ into address _ca_ of the system bank.
\
\ }doc
Added (source-id), which returns the address of the value returned by source-id. This makes the code clearer, makes it simpler to manipulate source-id and saves one byte.
Moved recurse to the library and updated the library modules that need it.
Improved alias. Now aliases have the same execution token of the original word:
( alias )
need name>> need !s
: alias ( xt "name" -- ) header reveal latest name>> !s ;
name>> had to bee added, to get the xtp from a nt:
( >>link name>> )
[unneeded] >>link dup ?\ need alias
?\ ' cell+ alias >>link ( xtp -- lfa )
[unneeded] name>>
?\ : name>> ( nt -- xtp ) [ 2 cells ] literal - ;
Finally, the old definition of alias was renamed to deferred:
( deferred )
: deferred ( xt "name" -- ) defer latest name> defer! ;
\ doc{
\
\ deferred ( xt "name" -- )
\
\ Create a deferred word _name_ that will execute _xt_. The
\ effect is the same than `defer name xt ' name defer!`.
\
\ }doc
2016-04-18
Wrote realias, to reconfigure aliases:
: realias ( xt "name" -- )
defined dup 0= #-13 ?throw name>> !s ;
\ doc{
\
\ realias ( xt "name" -- )
\
\ Set the alias _name_ to execute _xt_.
\
\ See `alias`.
\
\ }doc
Updated the definition of aliases in the kernel. They were created as deferred words, in conformity with the old version of alias. Now they are actual aliases. The assembler macros _header and _alias_header have been modified. Aliases don't have a code field, so they save the 3 bytes of the Z80 instruction jp used by deferred words. 48 bytes have been saved in the kernel.
_header: macro _base_label,_name,_flags,_xt
; In dictionary:
if nul _xt
_base_label: ; execution token
else
_base_label equ _xt ; execution token of an alias
endif
local _dp_backup
local _name_address
local _address_after_name
_dp_backup: equ $
; In memory bank:
org np
_base_label##xtp:
if nul _xt
dw _base_label ; execution token pointer
else
dw _xt ; execution token pointer of an alias
endif
_base_label##lfa: ; link field address
dw nt_of_the_previous_word ; link field
_base_label##nt: ; name token
; Length byte with optional immediate bit:
if nul _flags
db _address_after_name-_name_address
else
db _address_after_name-_name_address+_flags
endif
_name_address: equ $
db _name ; name field
_address_after_name: equ $
np: defl $ ; new value of the names pointer
; Update the names pointer:
org names_pointer
dw np ; overwrite names_pointer
dw np ; overwrite names_pointer_init_value
; In dictionary:
org _dp_backup
nt_of_the_previous_word: defl _base_label##nt
endm
_alias_header: macro _base_label,_name,_flags,_xt
_header _base_label,_name,_flags,_xt
endm
Discovered the bug of the floating-point module: .fs added a zero to the floating-point stack for every number in it which is non-integer and less than 1. The reason is there's a bug in the PRINT-FP ROM routine, called "unbalaced stack error". It's documented in the disassembly:
; the branch was here when 'int x' was found to be zero as in say 0.5.
; The zero has been fetched from the calculator stack but not deleted and
; this should occur now. This omission leaves the stack unbalanced and while
; that causes no problems with a simple PRINT statement, it will if str$ is
; being used in an expression e.g. 2 + STR$ 0.5 gives the result 0.5
; instead of the expected result 20.5.
; credit Tony Stratton, 1982.
; A DEFB 02 delete is required immediately on using the calculator.
;; PF-SMALL
L2E24: RST 28H ;; FP-CALC int x = 0.
L2E25: DEFB $E2 ;;get-mem-2 int x = 0, x-int x.
DEFB $38 ;;end-calc
Fixed ftrunc. So far its behaviour was done by fround. fround and floor are not defined yet.
( fround floor ftrunc )
need calc need f0= need f0< need fdup need fnegate
: fround ( F: r1 -- r2 ) ;
\ XXX TODO --
\ doc{
\
\ fround ( r1 -- r2 )
\
\ Round _r1_ to an integral value using the "round to
\ nearest" rule, giving _r2_.
\
\ Origin: Forth-2012 (FLOATING).
\
\ }doc
: floor ( F: r1 -- r2 ) ;
\ XXX TODO --
\ doc{
\
\ floor ( F: r1 -- r2 )
\
\ Round _r1_ to an integral value using the "round toward
\ negative infinity" rule, giving _r2_.
\
\ Origin: Forth-2012 (FLOATING).
\
\ }doc
code ftrunc ( F: r1 -- r2 )
calc 3A c, end-calc jpnext end-code
\ doc{
\
\ floor ( F: r1 -- r2 )
\
\ Round _r1_ to an integral value using the "round toward
\ zero" rule, giving _r2_.
\
\ Origin: Forth-2012 (FLOATING).
\
\ }doc
\ Example from the documentation of Forth-2012:
\ : ftrunc ( F: r1 -- r2 )
\ fdup f0= 0= if
\ fdup f0< if fnegate floor fnegate else floor then
\ then ;
\ From Gforth:
\
\ : ftrunc ( F: r1 -- r2 ) f>d d>f ;
Renamed the math library modules with the common root "math.", and extracted the code of the ROM calculator to its own file, in order to reuse it.
Improved the ROM calculator support and the floating-point support. The ROM calculator module has been rewritten. Now it uses ordinary words, in its own word list, including if else then. The floating-point support has been modified and improved accordingly.
Added floating-point floor and ROM calculator int.
2016-04-19
Fixed circular prerequisite of f>s.
Fixed fmax.
2016-04-20
Fixed fconstant.
Wrote calculator-command>flag and rewrote f=, f<>, f<, f<=, f> and f>= after it, because calling the equivalents command of the ROM calculator directly always returned a true flag; the details of the debugging are noted in the ROM calculator module.
( calculator-command>flag )
need calculator need f>flag need call-xt
: calculator-command>flag ( b -- )
$C5 c, $06 c, c,
\ push bc ; save the Forth IP
\ ld b,command
calculator $3B c,
\ `fp-calc-2` calculator command, which executes the
\ calculator command stored in the b register.
[ calculator-wordlist >order ] end-calculator [ previous ]
$C1 c,
\ pop bc ; restore the Forth IP
['] f>flag call-xt
[ also assembler ] jpnext [ previous ] ;
\ doc{
\
\ calculator-command>flag ( b -- )
\
\ Compile the assembler instructions needed to execute the
\ _b_ command of the ROM calculator and to return the
\ floating-point result as a flag on the data stack.
\
\ }doc
( f= f<> )
need calculator-command>flag
code f= ( -- f ) ( F: r1 r2 -- )
0E calculator-command>flag end-code
\ `nos-eql` calculator command
code f<> ( -- f ) ( F: r1 r2 -- )
0B calculator-command>flag end-code
\ `nos-neql` calculator command
\ code f~ \ XXX TODO
( f< f<= f> f>= )
need calculator-command>flag
code f< ( -- f ) ( F: r1 r2 -- )
0D calculator-command>flag end-code
\ `no-less` calculator command
code f<= ( -- f ) ( F: r1 r2 -- )
09 calculator-command>flag end-code
\ `no-l-eql` calculator command
code f> ( -- f ) ( F: r1 r2 -- )
0C calculator-command>flag end-code
\ `no-grtr` calculator command
code f>= ( -- f ) ( F: r1 r2 -- )
0A calculator-command>flag end-code
\ `no-gr-eql` calculator command
The calculator's if compiled the "jump-true" calculator command, which does a branch when calculator TOS is not zero, the opposite of what it should be. 0branch has been added to fix this, after the names used in the kernel:
( calculator )
: ?branch ( -- ) $00 c, ;
\ Compile the `jump-true` ROM calculator command.
: 0branch ( -- ) 0= ?branch ;
\ Compile the ROM calculator commands to do a branch if
\ the TOS of the calculator stack is zero.
: branch ( -- ) $33 c, ;
\ Compile the `jump` ROM calculator command.
-->
( calculator )
: >mark ( -- a ) here 0 c, ;
\ Compile space for the displacement of a ROM calculator
\ forward branch which will later be resolved by
\ `>resolve`.
\
\ Typically used after either `branch` or
\ `?branch`.
: from-here ( a -- n )
here [ also forth ] swap - [ previous ] ;
\ Calculate the displacement _n_ from the current data-space
\ pointer to address _a_.
: >resolve ( a -- )
[ also forth ] dup [ previous ] from-here
[ also forth ] swap [ previous ] c! ;
\ Resolve a ROM calculator forward branch by placing the
\ displacement to the current position into the space
\ compiled by `>mark`.
' here alias <mark ( -- a )
\ Leave the address of the current data-space pointer as the
\ destination of a ROM calculator backward branch which will
\ later be resolved by `<resolve`.
\
\ Typically used before either `branch` or `?branch`.
: <resolve ( a -- ) from-here c, ;
\ Resolve a ROM calculator backward branch by compiling the
\ displacement from the current position to address _a_,
\ which was left by `<mark`.
: if ( -- a ) 0branch >mark ;
: else ( a1 -- a2 )
branch >mark [ also forth ] swap [ previous ] >resolve ;
' >resolve alias then ( a -- )
The bug of if affected fmax and fmin, buy these words had to be modified also because they used the calculator's operators > and < directly, what causes problems (the details are in the source of the calculator module). calculator-command was factored from calculator-command>flag for this:
( calculator-command )
need calculator
: calculator-command ( b -- )
$C5 c, $06 c, c,
\ push bc ; save the Forth IP
\ ld b,command
calculator $3B c,
\ `fp-calc-2` calculator command, which executes the
\ calculator command stored in the b register.
[ calculator-wordlist >order ] end-calculator [ previous ]
$C1 c, ;
\ pop bc ; restore the Forth IP
\ doc{
\
\ calculator-command ( b -- )
\
\ Compile the assembler instructions needed to execute the
\ _b_ command of the ROM calculator.
\
\ }doc
( calculator-command>flag )
need calculator-command need f>flag need call-xt
: calculator-command>flag ( b -- )
calculator-command ['] f>flag call-xt
[ also assembler ] jpnext [ previous ] ;
\ doc{
\
\ calculator-command>flag ( b -- )
\
\ Compile the assembler instructions needed to execute the
\ _b_ command of the ROM calculator and to return the
\ floating-point result as a flag on the data stack.
\
\ }doc
( fmax )
need calculator need calculator-command
code fmax ( F: r1 r2 -- r1|r2 )
calculator 2dup end-calculator
0C calculator-command ( F: r1 r2 rf -- )
\ `no-grtr` ROM calculator command
calculator
if drop ( F: r1 )
else swap drop ( F: r2 )
then
end-calculator jpnext end-code
\ XXX OLD -- Original, simpler version. The problem is the
\ calculator's `>`. See the calculator module for details of
\ the problem.
\ code fmax ( F: r1 r2 -- r1|r2 )
\ calculator
\ 2dup > ( F: r1 r2 rf -- )
\ if drop ( F: r1 )
\ else swap drop ( F: r2 )
\ then
\ end-calculator jpnext end-code
( fmin )
need calculator need calculator-command
code fmin ( F: r1 r2 -- r1|r2 )
calculator 2dup end-calculator
0D calculator-command ( F: r1 r2 rf -- )
\ `no-less` ROM calculator command
calculator
if drop ( F: r1 )
else swap drop ( F: r2 )
then
end-calculator jpnext end-code
\ XXX OLD -- Original, simpler version. The problem is the
\ calculator's `<`. See the calculator module for details of
\ the problem.
\ code fmin ( F: r1 r2 -- r1|r2 )
\ calculator
\ 2dup < ( F: r1 r2 rf -- )
\ if drop ( F: r1 )
\ else swap drop ( F: r2 )
\ then
\ end-calculator jpnext end-code
Improved upper and system-bank: two simples changes save same bytes and T-cycles. For example:
; XXX OLD
; T B
; call bank.system ; 17 03
; _jp_next ; 08 02
; XXX NEW
; T B
push ix ; 15 02 ; make next `ret` jump to `next`
Added wait-for-key, with a routine used by key:
; ----------------------------------------------
_code_header wait_for_key_,'WAIT-FOR-KEY'
; doc{
;
; wait-for-key ( -- )
;
; Wait for a valid key and discard it.
;
; }doc
; XXX TODO -- make it compatible with the future multitasking
push ix ; make next `ret` jump to `next`
wait_for_key:
; output: A = key code
bit 5,(iy+1) ; FLAGS system variable: new key available?
jr z,wait_for_key
ld a,(sys_last_k) ; return the key in register A
res 5,(iy+1) ; no new key available anymore
ret
Replaced the current definition of dnegate with a faster one that was commented out and needs only one additional byte. Added conditional assembling depending on the assembly label size_optimization.
2016-04-21
Fixed, finished and improved the implementation of user and moved it to the library:
( ?user uallot ucreate user 2user )
: ?user ( -- )
udp @ dup /user > #-279 ?throw \ user area overflow?
0< #-280 ?throw ; \ user area underflow?
\ doc{
\
\ ?user ( -- )
\
\ Throw an exception if the user area pointer is out of bounds.
\
\ }doc
: uallot ( n -- ) udp +! ?user ;
\ doc{
\
\ uallot ( n -- )
\
\ If _n_ is greater than zero, reserve _n_ address units of
\ user data space. If _n_ is less than zero, release _n_
\ address units of user data space. If _n_ is zero, leave the
\ user data-space pointer unchanged. An exception is thrown
\ if the user-data pointer is out of bounds after the
\ operation.
\
\ }doc
: ucreate ( "name" -- ) udp @ (user) ;
\ doc{
\
\ ucreate ( "name" -- )
\
\ Create a header _name_ which points to the first available
\ offset within the user area. Execution of _name_ leaves
\ its absolute user area storage address. No user space is
\ allocated. See: `uallot`, `user`.
\
\ }doc
: user ( "name" -- ) ucreate cell uallot ;
\ doc{
\
\ user ( n "name" -- )
\
\ Create a user variable _name_ in the first available offset
\ within the user area. Execution of _name_ leaves its
\ absolute user area storage address.
\
\ }doc
: 2user ( "name" -- ) ucreate [ 2 cells ] literal uallot ;
\ doc{
\
\ 2user ( "name" -- )
\
\ Create a user double variable _name_ in the first available
\ offset within the user area. Execution of _name_ leaves
\ its absolute user area storage address.
\
\ }doc
Only (user) is in the kernel:
_colon_header paren_user_,'(USER)'
; doc{
;
; (user) ( +n "name" -- )
;
; Create a user variable _name_. _+n_ is the offset within the
; user area where the value for _name_ is stored. Execution of
; _name_ leaves its absolute user area storage address.
;
; This is a factor of `user`. It works like `user` in:
; fig-Forth, Forth-79 (Reference Word Set) and Forth-83
; (Uncontrolled Reference Words).
;
; }doc
; XXX TODO -- rename, maybe to `+user`?
dw c_constant_
dw paren_semicolon_code_
do_user:
pop hl
ld e,(hl)
ld d,$00 ; de = index of the user variable
ld hl,(user_variables_pointer)
add hl,de ; hl= address of the user variable
_jp_pushhl
Added fround:
: fround ( F: r1 -- r2 ) fdup fsgn fhalf f* f+ ftrunc ;
\ doc{
\
\ fround ( r1 -- r2 )
\
\ Round _r1_ to an integral value using the "round to
\ nearest" rule, giving _r2_.
\
\ Origin: Forth-94 (FLOATING), Forth-2012 (FLOATING).
\
\ }doc
Added f~, f~abs, f~rel, f~relabs and f==:
( f~abs f~rel f~relabs f== )
\ Credit:
\
\ Most of this code is based on the words `f~`, `f~abs` and
\ `f~rel` implemented in Gforth 0.7.3. Parts have been
\ factored and adapted.
need frot need f- need fabs need fswap need f< need fover
need f+ need f* need fp@ need float- need float need s=
need fdrop need fsgn
: f~abs ( -- f ) ( F: r1 r2 r3 -- )
frot frot f- fabs fswap f< ;
\ doc{
\
\ f~abs ( -- f ) ( F: r1 r2 r3 -- )
\
\ Approximate equality with absolute error: `|r1-r2|<r3`.
\
\ Flag _f_ is true if the absolute value of _r1-r2_ is less
\ than _r3_.
\
\ Origin: Gforth.
\
\ }doc
: f~rel ( -- f ) ( F: r1 r2 r3 -- )
frot frot fover fabs fover fabs f+
frot frot f- fabs frot frot f* f< ;
\ doc{
\
\ f~rel ( -- f ) ( F: r1 r2 r3 -- )
\
\ Approximate equality with relative error:
\ `|r1-r2|<r3*|r1+r2|`.
\
\ Flag _f_ is true if the absolute value of _r1-r2_ is less
\ than the value of _r3_ times the sum of the absolute values
\ of _r1_ and _r2_.
\
\ }doc
: f~relabs ( -- f ) ( F: r1 r2 r3 -- ) fabs f~rel ;
\ XXX TODO -- better name
\ doc{
\
\ f~relabs ( -- f ) ( F: r1 r2 r3 -- )
\
\ Approximate equality with relative error:
\ `|r1-r2|<|r3|*|r1+r2|`.
\
\ Flag _f_ is true if the absolute value of _r1-r2_ is less
\ than the absolute value of _r3_ times the sum of the
\ absolute values of _r1_ and _r2_.
\
\ }doc
: f== ( -- f ) ( F: r1 r2 -- )
fp@ dup float- float tuck s= fdrop fdrop ;
\ doc{
\
\ f== ( -- f ) ( F: r1 r2 -- )
\
\ Exact bitwise equality.
\
\ Are _r1_ and _r2_ exactly identical? Flag _f_ is true if
\ the bitwise comparison of _r1_ and _r2_ is succesful.
\
\ }doc
( f~ )
need f~abs need f== need f~relabs
' f~abs ,
here ' f== ,
' f~relabs ,
constant (f~) \ execution table of `f~`
: f~ ( -- f ) ( F: r1 r2 r3 -- )
fdup fsgn f>s cells (f~) + perform ;
\ doc{
\
\ f~ ( -- f ) ( F: r1 r2 r3 -- )
\
\ Medley for comparing _r1_ and _r2_ for equality:
\
\ - _r3_>0: `f~abs`;
\ - _r3_=0: `f==`;
\ - _r3_<0: `f~relabs`.
\
\ See: `f~abs`, `f==`, `f~rel`,`f~relabs`.
\
\ Origin: Forth-94 (FLOATING EXT), Forth-2012 (FLOATING EXT).
\
\ }doc
2016-04-22
Released version 0.5.0.
2016-04-23
Improve the Pong game: the ball rolls.
Revise and improve the module that defines UDG and the module that prints them at graphic coordinates.
Add emit-0udg to the kernel, a useful alternative to emit-udg.
Improve type with ?do: faster and smaller.
Add c-!:
code c-! ( c ca -- )
hl pop de pop m a ld e sub a m ld jpnext end-code
\ doc{
\
\ c-! ( c ca - )
\
\ Subtract _c_ from the char at _ca_
\
\ }doc
Fix c+!.
2016-04-24
Add 0udg[ and udg[, which make it possible to define several UDG in compact form.
( 0udg[ udg[ )
need os-udg
variable first-udg
variable current-udg
variable current-scan
[defined] binary ?\ : binary ( -- ) 2 base ! ;
: 0udg[ ( b -- )
dup first-udg ! current-udg ! current-scan off binary ;
\ doc{
\
\ 0udg[ ( b -- )
\
\ Start a set of UDG definitions, from UDG number _b_
\ (0..255).
\
\ See: `udg[`, `|`, `||`, `||]`.
\
\ }doc
: udg[ ( c -- ) 128 - 0udg[ ;
\ doc{
\
\ udg[ ( c -- )
\
\ Start a set of UDG definitions, from UDG character _c_
\ (128..255).
\
\ See: `0udg[`, `|`, `||`, `||]`.
\
\ Usage example:
\
\ ----
\ 140 udg[ \ define UDG 140..144
\
\ 00111100 | 00111100 | 00111100 | 00111100 | 00111100 ||
\ 01111110 | 01111110 | 01111110 | 01111110 | 01011110 ||
\ 11111111 | 11111111 | 11111111 | 10111111 | 10111111 ||
\ 11111111 | 11111111 | 10111111 | 10111111 | 11111111 ||
\ 11111111 | 10111111 | 10111111 | 11111111 | 11111111 ||
\ 11001111 | 11011111 | 11111111 | 11111111 | 11111111 ||
\ 01111110 | 01111110 | 01111110 | 01111110 | 01111110 ||
\ 00111100 | 00111100 | 00111100 | 00111100 | 00111100 ||]
\ ----
\
\ }doc
: | ( b -- )
os-udg @ current-udg @ 8 * current-scan @ + + c!
1 current-udg +! ;
\ doc{
\
\ | ( b -- )
\
\ Store scan _b_ into the current UDG being defined.
\
\ See: `0udg[`, `udg[`, `||`, `||]`.
\
\ }doc
: || ( b -- )
| 1 current-scan +! first-udg @ current-udg ! ;
\ doc{
\
\ || ( b -- )
\
\ Store scan _b_ into the current UDG being defined and start
\ a new row of scans.
\
\ See: `0udg[`, `udg[`, `|`, `||]`.
\
\ }doc
: ||] ( b -- ) || decimal ;
\ doc{
\
\ ||] ( b -- )
\
\ Store scan _b_ into the current UDG being defined and stop
\ defining UDGs.
\
\ See: `0udg[`, `udg[`, `|`, `||`.
\
\ }doc
Fix dump: nothing was printed when the length was less than 8.
Add support for 2literal to decode.
Improve 2, and 2literal.
Fix 2lit: it returned the low and high parts in reverse order.
Add some words to compile constants as literals:
( ]l ]2l exec eval )
need [if]
[needed] ]l [if]
: ]l ( x -- ) ] postpone literal ; immediate compile-only
\ doc{
\
\ ]l ( x -- )
\
\ A short form of the idiom `] literal`.
\
\ }doc
[then]
[needed] ]2l [if]
: ]2l ( xd -- ) ] postpone 2literal ; immediate compile-only
\ doc{
\
\ ]2l ( xd -- )
\
\ A short form of the idiom `] 2literal`.
\
\ }doc
[then]
[needed] exec [if]
: exec ( "name" -- i*x )
parse-name find-name ?dup 0= #-13 ?throw name> execute ;
\ doc{
\
\ exec ( "name" -- i*x )
\
\ Parse, find and execute "name".
\
\ }doc
[then]
[needed] eval [if]
: eval ( i*x "name" -- j*x ) parse-name evaluate ;
\ doc{
\
\ exec ( i*x "name" -- j*x )
\
\ Parse and evaluate "name".
\
\ This is a common factor of `[const]`, `[2const]` and
\ `[cconst]`.
\
\ }doc
[then]
( [const] [2const] [cconst] )
need eval need [if]
[needed] [const] [if]
: [const] ( "name" -- )
eval postpone literal ; immediate compile-only
\ doc{
\
\ [const] ( "name" -- )
\
\ Evaluate "name". Then compile the single-cell value left on
\ the stack.
\
\ This word is intented to compile constants as literals, in
\ order to gain execution speed.
\
\ Usage example:
\
\ ----
\ 48 constant zx
\ : test ( -- ) [const] zx . ;
\ ----
\
\ }doc
[then]
[needed] [2const] [if]
: [2const] ( "name" -- )
eval postpone 2literal ; immediate compile-only
\ doc{
\
\ [2const] ( "name" -- )
\
\ Evaluate "name". Then compile the double-cell value left on
\ the stack.
\
\ This word is intented to compile double-cell constants as
\ literals, in order to gain execution speed.
\
\ Usage example:
\
\ ----
\ 48. 2constant zx
\ : test ( -- ) [2const] zx d. ;
\ ----
\
\ }doc
[then]
[needed] [cconst] [if]
: [cconst] ( "name" -- )
eval postpone cliteral ; immediate compile-only
\ doc{
\
\ [cconst] ( "name" -- )
\
\ Evaluate "name". Then compile the char left
\ on the stack.
\
\ This word is intented to compile char constants as literals, in
\ order to gain execution speed.
\
\ Usage example:
\
\ ----
\ 48 cconstant zx
\ : test ( -- ) [cconst] zx emit ;
\ ----
\
\ }doc
[then]
Move get-default-bank and set-default-bank to the library.
Move :noname to the library.
Add lastxt and latestxt.
Fix :noname: now it updates lastxt and last.
Fix recurse: now it works in words created with :noname.
Move nextname, nextname-header and nextname-string to the library.
Move char and [char] to the library.
By the first time, the unused data space after cold is more than 32 KiB: 32774 B.
2016-04-25
First working version of marker.
Clearer exception messages: a carriage return is printed before the offending word and before the message; default messages show no "Exception" text, and use the same backslash as the text messages.
2016-04-26
Improve located: when the user press the break key, throw exception -28 (user interrupt); formerly the ordinary -268 (required, but not located) was thrown by the calling word.
Rename old fig-Forth latest to current-latest and move it to the library. Write new latest after Gforth. Change the few cases that depend on the old behaviour.
2016-04-27
Add char-in-string? and char-position?:
( char-in-string? char-position? )
need -rot need [if]
[needed] char-in-string? [if]
: char-in-string? ( ca len c -- f )
-rot bounds
?do dup i c@ = if drop true unloop exit then loop
drop false ;
\ doc{
\
\ char-in-string? ( ca len c -- f )
\
\ Is char _c_ in string _ca len_?
\
\ }doc
[then]
[needed] char-position? [if]
: char-position? ( ca len c -- +n true | false )
-rot 0 ?do
2dup i + c@ = if 2drop i true unloop exit then
loop 2drop false ;
\ doc{
\
\ char-position? ( ca len c -- +n true | false )
\
\ If char _c_ is in string _ca len_, return its first
\ position _+n_ and _true_; else return _false_.
\
\ }doc
[then]
Move ascii-char? and control-char? to module "chars.fsb". Move ascii-type to module "printing.type.fsb" and rename it to type-ascii.
Replace bs, used by dump, with backspace, which is part of the library.
Add /!, *!, 2/!, 2*!:
( /! *! 2/! 2*! )
[unneeded] /!
?\ : /! ( n a -- ) tuck @ swap / swap ! ;
\ doc{
\
\ /! ( n a -- )
\
\ Divide _n_ by the single-cell number at _a_ and store
\ the quotient in _a_
\
\ }doc
[unneeded] *!
?\ : *! ( n a -- ) tuck @ swap * swap ! ;
\ doc{
\
\ *! ( n|u a -- )
\
\ Multiply _n|u_ by the single-cell number at _a_ and store
\ the product in _a_
\
\ }doc
[unneeded] 2*!
?\ : 2*! ( a -- ) dup @ 2* swap ! ;
\ doc{
\
\ 2*! ( a -- )
\
\ Do a `2*` shift to the single-cell number at _a_.
\
\ See `2*`.
\
\ }doc
[unneeded] 2/! ?exit
need 2/
: 2/! ( a -- ) dup @ 2/ swap ! ;
\ doc{
\
\ 2/! ( a -- )
\
\ Do a `2/` shift to the single-cell number at _a_.
\
\ See `2/`.
\
\ }doc
Release version 0.6.0.
Add sgn and <=>:
( sgn <=> )
: sgn ( n -- -1|0|1 )
dup 0= ?exit 0< ?dup ?exit 1 ;
\ doc{
\
\ sgn ( n -- -1|0|1 )
\
\ If _n_ is zero, return zero.
\ If _n_ is negative, return negative one.
\ If _n_ is positive, return positive one.
\
\ }doc
[unneeded] <=> ?exit
: <=> ( n1 n2 -- -1|0|1 ) swap - sgn ;
\ doc{
\
\ <=> ( n1 n2 -- -1|0|1 )
\
\ If _n1_ equals _n2_, return zero.
\ If _n1_ is less than _n2_, return negative one.
\ If _n1_ is greater than _n2_, return positive one.
\
\ }doc
Add either and neither:
( either neither )
\ Credit:
\
\ Code from IsForth (version 1.23b).
need [if]
[needed] either [if]
: either ( n1|u1 n2|u2 n3|u3 -- f )
-rot over = -rot = or ;
\ doc{
\
\ either ( n1|u1 n2|u2 n3|u3 -- f )
\
\ Return _true_ if _n1|u1_ equals either _n2|u2_ or _n3|u3_;
\ else return _false_.
\
\ }doc
[then]
[needed] neither [if]
: neither ( n1|u1 n2|u2 n3|u3 -- f )
-rot over <> -rot <> and ;
\ doc{
\
\ neither ( n1|u1 n2|u2 n3|u3 -- f )
\
\ Return _true_ if _n1|u1_ is not equal to either _n2|u2_ or
\ _n3|u3_; else return _false_.
\
\ }doc
[then]
Improve the documentation of some optional control structures. Rename nextcase to repeatcase, and other> to othercase>.
Factor .error-word from error, in order to reuse it in the new optional warnings control, which is moved to the library:
( warnings )
need user need search-wordlist
user warnings \ flag
\ doc{
\
\ warnings ( -- a )
\
\ User variable that holds a flag. If it's zero, no warning
\ is shown when a compiled word is not unique in the
\ `current` vocabulary.
\
\ }doc
: no-warnings? ( -- f ) warnings @ 0= ;
\ doc{
\
\ no-warnings? ( -- f )
\
\ Are the warnings deactivated?
\
\ }doc
: not-redefined? ( ca len -- ca len xt false | ca len true )
2dup get-current search-wordlist 0= ;
\ doc{
\
\ not-redefined? ( ca len -- ca len xt false | ca len true )
\
\ Is the word name _ca len_ not yet defined in the
\ current compilation word list?
\
\ }doc
: ?warn ( ca len -- ca len | ca len xt )
no-warnings? if unnest exit ( ca len ) then
not-redefined? if unnest then
( ca len | ca len xt ) ;
\ doc{
\
\ ?warn ( ca len -- ca len | ca len xt )
\
\ A common factor of `warn.throw`, `warn.message` and
\ `warn-throw`. Check if a warning about the redefinition of
\ the word name _ca len_ is needed. If no warning is needed,
\ unnest the calling definition and return _ca len_. If a
\ warning is needed, return _ca len_ and the _xt_ of the word
\ found in the current compilation wordlist.
\
\ See `warn.throw`, `warn-throw`, `warn.message`.
\
\ }doc
( warn.throw warn.message )
need warnings need [if]
[needed] warn.throw [if]
: warn.throw ( ca len -- ca len )
?warn ( ca len xt ) drop 2drop .error-word #-257 .throw ;
\ doc{
\
\ warn.throw ( ca len -- ca len )
\
\ Alternative behaviour for the deferred word `warn`. If the
\ contents of the user variable `warnings` is not zero and
\ the word name _ca len_ is already defined in the current
\ compilation word list, print throw error #-257, without
\ actually throwing an error.
\
\ See `warn-throw`, `warn.message`.
\
\ }doc
' warn.throw ' warn defer! warnings on
[then]
[needed] warn.message [if]
: warn.message ( ca len -- ca len )
?warn ( ca len xt ) ." redefined " >name .name ;
\ doc{
\
\ warn.message ( ca len -- ca len )
\
\ Alternative behaviour for the deferred word `warn`. If the
\ contents of the user variable `warnings` is not zero and
\ the word name _ca len_ is already defined in the current
\ compilation word list, print a warning message.
\
\ See `warn.throw`, `warn-throw`.
\
\ }doc
' warn.message ' warn defer! warnings on
[then]
( warn-throw )
need warnings need [if]
[needed] warn-throw [if]
: warn-throw ( ca len -- ca len )
?warn ( ca len xt ) #-257 throw ;
\ doc{
\
\ warn-throw ( ca len -- ca len )
\
\ Alternative behaviour for the deferred word `warn`. If the
\ contents of the user variable `warnings` is not zero and
\ the word name _ca len_ is already defined in the current
\ compilation word list, throw error #-257 instead of
\ printing a warning message.
\
\ See `warn.throw`, `warn.message`.
\
\ }doc
' warn-throw ' warn defer! warnings on
[then]
2016-04-28
Factored .unused from greeting:
; ----------------------------------------------
_colon_header greeting_,'GREETING'
; doc{
;
; greeting ( -- )
;
; Print the boot message.
;
; }doc
dw paren_dot_quote_
_string "Solo Forth\rVersion "
dw dot_version_
dw paren_dot_quote_
_string "\rBy Marcos Cruz\r(programandala.net), 2015, 2016\r"
dw dot_unused_
dw exit_
; ----------------------------------------------
_colon_header dot_unused_,'.UNUSED'
; doc{
;
; .unused ( -- )
;
; Display the amount of space remaining in the region addressed
; by `here`, in address units.
;
; ----
; : .unused ( -- )
; unused u. ." B free" ;
; ----
;
; }doc
dw unused_,u_dot_
dw paren_dot_quote_
_string "B free"
dw exit_
First working versions of type-left, type-center and type-right:
( drop-type padding-spaces type-left )
[unneeded] drop-type
?\ : drop-type ( ca len x -- ) drop type ; exit
: padding-spaces ( len1 len2 -- )
swap - 0 max spaces ;
\ doc{
\
\ : padding-spaces ( len1 len2 -- )
\
\ If _len2_ minus _len1_ is a positive number, print that
\ number of spaces; else do nothing.
\
\ }doc
[needed] padding-spaces ?exit
: type-left ( ca len1 len2 -- )
2dup 2>r min type 2r> padding-spaces ;
\ doc{
\
\ type-left ( ca len1 len2 -- )
\
\ Type string _ca len1_ at the left of a field of _len2_
\ characters.
\
\ }doc
( type-right )
need padding-spaces need drop-type need <=>
: type-right-crop ( ca len1 len2 -- )
over swap - /string type ;
\ doc{
\
\ type-right-crop ( ca len1 len2 -- )
\
\ Type string _ca len1_ at the right of a field of _len2_
\ characters, which is shorter than the string.
\
\ }doc
: type-right-fit ( ca len1 len2 -- )
2dup 2>r padding-spaces 2r> min type ;
\ doc{
\
\ type-right-fit ( ca len1 len2 -- )
\
\ Type string _ca len1_ at the right of a field of _len2_
\ characters, which is longer than the string.
\
\ }doc
' type-right-fit ,
here ' drop-type ,
' type-right-crop ,
constant type-right-cases
\ Execution table of `type-right`.
: type-right ( ca len1 len2 -- )
2dup <=> cells type-right-cases + perform ;
\ doc{
\
\ type-right ( ca len1 len2 -- )
\
\ Type string _ca len1_ at the right of a field of _len2_
\ characters.
\
\ }doc
( type-center )
need drop-type need <=>
: type-center-fit ( ca len1 len2 -- )
over - 2 /mod dup >r + spaces type r> spaces ;
\ doc{
\
\ type-center-fit ( ca len1 len2 -- )
\
\ Type string _ca len1_ at the center of a field of _len2_
\ characters, which is longer than the string.
\
\ }doc
: type-center-crop ( ca len1 len2 -- )
over swap - 2 /mod dup >r + /string r> - type ;
\ doc{
\
\ type-center-crop ( ca len1 len2 -- )
\
\ Type string _ca len1_ at the center of a field of _len2_
\ characters, which is shorter than the string.
\
\ }doc
' type-center-fit ,
here ' drop-type ,
' type-center-crop ,
constant type-center-cases
\ Execution table of `type-center`.
: type-center ( ca len1 len2 -- )
2dup <=> cells type-center-cases + perform ;
\ doc{
\
\ type-center ( ca len1 len2 -- )
\
\ Type string _ca len1_ at the center of a field of _len2_
\ characters.
\
\ }doc
Add 0max:
( 0max )
\ Credit:
\ Idea taken from IsForth.
code 0max ( n -- n | 0 )
E1 c,
\ pop hl
CB c, 10 05 + c,
\ rl h ; negative?
DA c, ' false ,
\ jp c,false_
CB c, 18 05 + c,
\ rr h
jppushhl
\ jp push_hl
end-code
\ doc{
\
\ 0max ( n -- n | 0 )
\
\ If _n_ is negative, return 0; else return _n_.
\ This is a faster alternative to the idiom `0 max`.
\
\ }doc
Rename set to storer. Though this usage of set was mentioned in Forth-79 and Forth-83, it's seldom used, while set is a comus name to define a set of data, a more useful feature which will be implemented. storer is an obvious name for the old set. Beside, it has been improved with double-cell operators, faster and shorter:
( storer )
: storer ( x a "name" -- )
create 2,
does> ( -- ) ( pfa ) 2@ ! ;
\ doc{
\
\ storer ( x a "name" -- )
\
\ Define a word "name" which, when executed, will cause the
\ value _x_ to be stored at _a_.
\
\ Origin: word `set` found in Forth-79 (Reference Word Set)
\ and Forth-83 (Appendix B. Uncontrolled Reference Words).
\
\ }doc
Write ccase, ?ccase and ccase0:
\ -----------------------------------------------------------
\ Description
\ `ccase` is a positional control structure that uses the
\ position of a character in a string as key, and has a
\ mandatory default option at the end. Data space used
\ (without requirements): 69 bytes.
\
\ `ccase0` is a simpler variant of `ccase` that uses the
\ first compiled option as a mandatory default option. Data
\ space used (without requirements): 44 bytes.
\
\ `?ccase` is a simpler variant of `ccase` with no default
\ option. Data space used (without requirements): 34 bytes.
Simplify type-right.
2016-04-29
Add ruler:
( ruler )
: ruler ( c len -- ca len )
dup allocate-string swap 2dup 2>r rot fill 2r> ;
\ doc{
\
\ ruler ( c len -- ca len )
\
\ Return a string _ca len_ of characters _c_.
\
\ }doc
Add lineload:
: lineblock>source ( n1 n2 -- ) blk ! c/l * >in ! ;
\ doc{
\
\ lineblock>source ( n1 n2 -- )
\
\ Set block _n2_ as the current source, starting from its
\ line _n1_.
\
\ }doc
: lineload ( n1 n2 -- )
dup 0= #-259 ?throw
nest-source lineblock>source interpret unnest-source ;
\ doc{
\
\ lineload ( n1 n2 -- )
\
\ Begin interpretation at line _n1_ of block _n2_.
\
\ Origin: Forth-83 (Uncontrolled Reference Words).
\
\ }doc
Add split and join:
( split join )
code split ( x -- b1 b2 )
E1 c,
\ pop hl
16 c, 00 c, 58 05 + c,
\ ld d,0
\ ld e,l
68 04 + c, 26 c, 00 c,
\ ld l,h
\ ld h,0
C3 c, pushhlde ,
\ jp push_hlde
end-code
\ doc{
\
\ split ( x -- b1 b2 )
\
\ Get _b1_ and _b2_ from the 2 bytes which compose _x_: _b1_
\ is the high-order byte and _b2_ is the low-order byte.
\
\ See `join`.
\
\ Origin: IsForth.
\
\ }doc
code join ( b1 b2 -- x )
D1 c, 60 03 + c, D1 c, 68 03 + c,
\ pop de
\ ld h,e
\ pop de
\ ld l,e
jppushhl
\ jp push_hl
end-code
\ doc{
\
\ join ( b1 b2 -- x )
\
\ _b1_ is the low-order byte of _x_, and _b2_ is the
\ high-order byte of _x_.
\
\ See `split`.
\
\ Origin: IsForth.
\
\ }doc
During the development of a system benchmark, a non-parsing method to redefine an alias was needed, as an alternative to realias. alias!, analogous to the standard word defer!, is a common factor of alias and realias.
( alias! alias realias )
need name>> need !s
: alias! ( xt nt -- ) name>> !s ;
\ doc{
\
\ alias! ( xt nt -- )
\
\ Set the alias _nt_ to execute _xt_.
\
\ See `alias`, `realias`.
\
\ }doc
: alias ( xt "name" -- ) header reveal latest alias! ;
\ doc{
\
\ alias ( xt "name" -- )
\
\ Create an alias _name_ that will execute _xt_.
\
\ Aliases have the execution token _xt_ of the original word,
\ but don't inherit its precedence (set by `immediate`) and
\ restricted (set by `compile-only`) attributes.
\
\ See `realias`, `alias!`.
\
\ Origin: Gforth.
\
\ }doc
: realias ( xt "name" -- )
defined dup 0= #-13 ?throw alias! ;
\ doc{
\
\ realias ( xt "name" -- )
\
\ Set the alias _name_ to execute _xt_.
\
\ See `alias`, `alias!`.
\
\ }doc
Replace the current version of u<, which was adapted from DZX-Forth, with a version adapted from Z88 CamelForth, which is faster (0.96 relative speed).