Solo Forth development history in 2015-09
Description of the page content
Solo Forth development history in 2015-09.
2015-09-01
Modified the assembler: Included a 1- in >relresolve, so the parameter can be here; removed just-here. Simpler.
Added a word to scroll the screen one pixel up. This word may be useful to improve the FZX driver.
( scroll-1px-up )
\ [Code adapted from a routine written by Iván Sansa,
\ published in Microhobby, issue 122 (1987-03), page 7:
\ http://microhobby.org/numero122.htm
\ http://microhobby.speccy.cz/mhf/122/MH122_07.jpg]
require z80-asm
create (scroll-1px-up) ( -- a )
\ Scroll the whole screen one pixel up.
\ This is the Z80 routine that can be called from code words.
asm
4000 hl ldp# BF b ld#
begin
bc push hl de ldp h inc h a ld F8 and# h cp
z if 8 b ld# b sub rra rra rra a h ld 0020 bc ldp#
bc addp h a ld rla rla rla a h ld
then hl push 0020 bc ldp# ldir hl pop bc pop
step
end-asm
code scroll-1px-up ( -- )
\ Scroll the whole screen one pixel up.
bc push \ Forth IP
' (scroll-1px-up) cfa>pfa call
bc pop jpnext end-code
![http://microhobby.speccy.cz/mhf/122/MH122_07.jpg]](http://microhobby.speccy.cz/mhf/122/MH122_07.jpg]){kind=link}
Finished the alternative definition of pixel-add, that does not jump to the ROM routine. It's faster but bigger. The previous version is the default one.
( pixel-add )
create pixel-add ( -- a )
\ This Z80 routine is an alternative entry point to the
\ "pixel-add" ROM routine (0x22AA), to let the range of the y
\ coordinate to be 0..191 instead of 0..175.
\ a = address of the routine
\ Input registers:
\ c = x cordinate (0..255)
\ b = y coordinate (0..191)
\ Output registers:
\ hl = address of the pixel byte in the screen bitmap
\ a = position of the pixel in the byte address (0..7),
\ note: position 0=bit 7, position 7=bit 0.
asm
3E c, BF c, \ ld a,191 ; max Y coordinate
90 00 + c, \ sub b
C3 c, 22B0 , \ jp 0x22B0 ; and return
end-asm
( pixel-add )
require z80-asm
create pixel-add ( -- a )
\ This Z80 routine is a modified copy of the "pixel-add" ROM
\ routine (0x22AA), to let the range of the y coordinate to
\ be 0..191 instead of 0..175. Calling this code is a bit
\ faster than calling the version that uses the ROM, because
\ the necessary jump is saved and a useless `and a` has been
\ removed.
\ a = address of the routine
\ Input registers:
\ c = x cordinate (0..255)
\ b = y coordinate (0..191)
\ Output registers:
\ hl = address of the pixel byte in the screen bitmap
\ a = position of the pixel in the byte address (0..7),
\ note: position 0=bit 7, position 7=bit 0.
asm
BF a ld# b sub
\ b= adjusted Y coordinate (0..191)
a b ld rra scf rra a and rra
\ the line number from top of screen to B
\ 0xxxxxxx
\ set carry flag
\ 10xxxxxx
\ clear carry flag
\ 010xxxxx
b xor F8 and# b xor a h ld
\
\ keep the top 5 bits 11111000
\ 010xxbbb
\ transfer high byte to H
c a ld
\ the x value 0..255
rlca rlca rlca b xor C7 and#
\ the y value
\ apply mask 11000111
b xor rlca rlca
\ restore unmasked bits xxyyyxxx
\ rotate to xyyyxxxx
\ required position yyyxxxxx
a l ld
\ low byte to L
c a ld 07 and#
\ form the pixel position in A
ret
end-asm
Moved defer! and defer@ from the library to the kernel. defer! is needed to implement the word that restores the default printing mode, that must be in the kernel. Anyway, since also defer had to be moved to the kernel, it seems logical to be able to manipulate the deferred words without library code. defers and action-of are kept in the library.
Removed the old code, already deactivated with conditional compilation, related to the experimental implementation of a 255-character font in paged memory. This could be an optional printing mode in the library.
Converted at-xy and home to deferred words. This was needed in order to make it possible to change the printing mode. cls needed a little modification, because it is written in Z80 and calls home at the end.
2015-09-02
Finished accept, after ANS Forth. This will eventually replace query and expect, that will be moved to the library.
_colon_header accept_,'ACCEPT'
; doc{
;
; accept ( ca1 len1 -- len2 ) \ ANS Forth
;
; Receive a string of at most _len1_ characters. No characters
; are received or transferred if _len1_ is zero. Display
; graphic characters as they are received.
;
; Input terminates when an implementation-defined line
; terminator is received. When input terminates, nothing is
; appended to the string or displayed on the screen.
;
; _len2_ is the length of the string stored at _ca1_.
;
; }doc
dw span_,off_
dw question_dup_
dw zero_branch_,accept.end
dw to_r_ ; ( ca1 ) ( R: len1 )
accept.begin: ; ( ca )
dw xkey_ ; ( ca c )
dw dup_ ; ( ca c c )
_literal delete_char
dw equals_ ; delete key?
dw zero_branch_,accept.maybe_carriage_return
; Delete key ( ca c )
dw drop_
dw span_,fetch_
dw zero_branch_,accept.begin ; nothing to delete
; Do delete the last char
dw one_minus_ ; update the current address
_literal -1
dw span_,plus_store_ ; update `span`
_literal backspace_char
dw branch_,accept.emit
accept.maybe_carriage_return: ; ( ca c )
dw dup_
_literal carriage_return_char
dw equals_ ; carriage return?
dw zero_branch_,accept.ordinary_key
; Carriage return ( ca c )
dw drop_,r_drop_
dw branch_,accept.end
accept.ordinary_key: ; ( ca c )
dw span_,fetch_,r_fetch_,less_than_
dw zero_branch_,accept.begin ; the string is full
_literal 1
dw span_,plus_store_ ; update `span`
dw two_dup_,swap_,c_store_
dw swap_,one_plus_,swap_
accept.emit: ; ( ca c )
dw emit_
dw branch_,accept.begin
accept.end: ( ca )
dw drop_
dw span_,fetch_
dw semicolon_s_
Added cursor-char to the kernel, in order to make it easy to change the cursor used by xkey.
Modified query to use accept. This is a temporary change, until query is removed.
_colon_header query_,'QUERY'
dw tib_,dup_
dw number_tib_,fetch_
dw two_dup_,blank_ ; clean the input buffer
if 1 ; accept instead of expect
dw accept_,space_
else
dw expect_,span_,fetch_
endif
dw plus_,stream_end_
dw to_in_,off_
dw semicolon_s_
Changed all push ix and pop ix to next ix ldp#, it's much faster with the same length.
2015-09-03
Finished the word xy-emit-udg, that prints a user defined graphic at high resolution coordinates. It's based on code written by Simon N. Goodwin.
( xy-emit-udg )
require (xy-emit) require z80-asm
code xy-emit-udg ( x y b -- )
\ Display the used graphic character _b_ (0..255) at graphic
\ coordinates _x y_. The system variable "UDG" is supossed to
\ hold the address of a graphic charset (the address of the
\ char 0 bitmap).
\
\ The UDG character will be printed with overwritting
\ (equivalent to `1 overwritte`).
hl pop l a ld
de pop hl pop bc push e b ld l c ld
5C7B de ftp \ system variable UDG
(xy-emit) call
bc pop next ix ldp# jpnext
end-code
\ (xy-emit) \
require z80-asm require (pixel-addr)
\ [Code Adapted from "SMOOTH MOVE",
\ written by Simon N. Goodwin,
\ published in Todospectrum, issue 2 (1984-10), page
\ 16. http://microhobby.speccy.cz/zxsf/revistas-ts.htm]
create (xy-emit) ( -- )
\ Print a 8x8 bits char at high resolution coordinates.
\ Input:
\ DE = address of the first char (0) bitmap in a charset
\ A = char code (0..255)
\ B = y coordinate
\ C = x coordinate
\ Modifies:
\ AF BC HL IX DE
asm
0 h ld# a l ld hl addp hl addp hl addp de addp
hl push ix pop bc hl ldp hl push 8 c ld#
begin
hl pop h dec hl push h inc
\ next line
bc push hl bc ldp (pixel-addr) call bc pop
\ convert the coords H (x) and L (y) to an address in HL
\ and a bit in A
a b ld a xor b or 0 ix a ftx
nz if exde 0 h ld# a l ld 8 a ld# b sub a b ld
begin hl addp step exde
m a ld d xor a m ld
hl incp e a ld then
m xor a m ld ix incp c dec
\ next char scan, one screen line less
z until hl pop ret end-asm
2015-09-04
A bit faster set-pixel, reset-pixel and toggle-pixel.
Finished and tested the words that get attributes or attribute addresses.
( attr )
require z80-asm require (attr-addr)
code attr ( col line -- b )
\ Return the color attribute of the given cursor coordinates.
de pop hl pop l d ld
\ d = col
\ e = line
(attr-addr) call
\ hl = attribute address
m l ld 0 h ld#
\ hl = attribute
pushhl jp
end-code
( attr-addr )
require z80-asm require (attr-addr)
code attr-addr ( col line -- a )
\ Return the color attribute address of the given cursor
\ coordinates.
de pop hl pop l d ld
\ d = col
\ e = line
(attr-addr) call
\ hl = attribute address
pushhl jp
end-code
\ (attr-addr) \
require z80-asm
create (attr-addr) ( -- a )
\ Address of a Z80 routine that calculates the color
\ attribute address of a cursor position. This is a modified
\ version of the ROM routine at 0x2583.
\ Input:
\ d = column (0..31)
\ e = line (0..23)
\ Output:
\ hl = address of the attribute in the screen
asm
e a ld \ line to a 0x00..0x17 (max 00010111)
rrca rrca rrca \ rotate bits left
a e ld \ store in d as an intermediate value
E0 and# \ pick up bits 11100000 (was 00011100)
d xor \ combine with column 0x00..0x1F
a l ld \ low byte now correct
e a ld \ bring back intermediate result from d
03 and# 58 xor#
\ mask to give correct third of screen
\ combine with base address
a h ld \ high byte correct
ret
end-asm
Removed the old version of pixel? that returned 1 as true flag. Removed the conditional compilation in the kernel for true=1 instead of true=-1. No way back to true=1.
Moved unresolved from the FZX module to the assembler. It is an useful solution to resolve unstructured branches or references in assembly code. Nevertheless, using the circular string buffer as storage is not safe. It's a temporary solution until the heap is implemented.
6 cells allocate-string
\ Temporary space to store unresolved addresses during
\ compilation. `pad` can not be used because it's transient
\ and changes during the compilation. The circular string
\ buffer is used.
\
\ XXX TODO -- use the heap instead, when implemented
: unresolved ( n -- a ) cells [ dup ] literal + ; drop
\ Return the address of the _n_ unresolved address. Note:
\ The address returned by `allocate-string` is directly
\ compiled into `unresolved`. This saves a definition. `dup`
\ and `drop` are used to pass the compiler security that
\ checks the stack is balanced at the end of the definition.
2015-09-05
Finished ocr (formerly called emitted). It can be configurated to use the main charset (32..127) or, by default, the user defined graphics (128..255 in Solo Forth). A slower alternative definition that recognizes also inverse mode characters is under development.
( ocr )
\ [Adapted from anonymous code published in Todospectrum,
\ issue 19 (1986-03), page 65.
\ http://microhobby.speccy.cz/zxsf/revistas-ts.htm]
require z80-asm require ocr-chars
code ocr ( col line -- n )
\ Recognize the char printed at the given cursor
\ coordinates, using the charset whose first printable char
\ is pointed by the variable `ocr-charset`. The variable
\ `ocr-chars` holds the number of chars in the charset,
\ and `ocr-first` holds the code of the first char in the
\ charset. If succesful, return the char number _n_
\ according to the said variables. If no char is recognized,
\ return 0. Inverse characters are not recognized.
de pop hl pop bc push
\ get row, get col, save the Forth IP
l b ld e c ld ocr-charset hl ftp
\ b=colum, c=row, hl=udg
c a ld rrca rrca rrca E0 and# b xor a e ld
c a ld 18 and# 40 xor# a d ld
\ de = screen address
0 de stp here 2- 0 unresolved !
\ modify the code to get the screen address later
ocr-chars fta a b ld
\ number of chars in the charset
begin
\ b=remaining chars
\ hl = address of scan 0 of the current char
bc push hl push
0 de ldp# \ restore the screen address
here 2- 0 unresolved @ !
\ compilation: resolve the address of the screen address
\ de = screen address
-->
( ocr )
08 b ld# \ scans
begin
de ftap m xor \ scan match?
here jrnz >relmark 1 unresolved !
\ if not, goto next_char
d inc hl incp \ update the pointers
step \ next scan
\ all eight scans match: udg found
bc pop bc pop
\ discard the saved pointer
\ b = chars left
ocr-chars fta b sub a b ld
ocr-first fta b add a b ld
\ b = char number
here jr >relmark 2 unresolved !
\ go to end
\ next_char:
1 unresolved @ here >relresolve
hl pop 0008 de ldp# de addp bc pop
step
\ b = 0 (no char matches)
\ end:
2 unresolved @ here >relresolve 0 h ld# b l ld
bc pop pushhl jp end-code
( ocr-charset ocr-first ocr-chars ocr-ascii ocr-udg )
variable ocr-charset
\ doc{
\
\ ocr-charset ( -- a )
\
\ Variable that holds the address of the first printable char
\ in the charset used by `ocr`. By default it contains
\ 0x3D00, the address of the space char in the ROM charset.
\
\ }doc
variable ocr-first
\ doc{
\
\ ocr-first ( -- a )
\
\ Variable that holds the code of the first printable char in the
\ charset used by `ocr`. By default it contais 0x80, the
\ first UDG.
\
\ }doc
variable ocr-chars
\ doc{
\
\ ocr-charset ( -- a )
\
\ Variable that holds the number of printable chars in the
\ charset used by `ocr`. By default it contais 0x5F, the
\ number of printable ASCII chars in the ROM charset.
\
\ }doc
: ocr-ascii ( -- )
\ Set `ocr` to work with the ASCII charset pointed by the
\ system variable CHARS.
23606 @ 256 + ocr-charset !
32 ocr-first !
95 ocr-chars ! ;
: ocr-udg ( n -- )
\ Set `ocr` to work with the first _n_ chars of the UDG
\ charset pointed by the system variable UDG.
23675 @ ocr-charset !
128 ocr-first !
ocr-chars ! ;
19 ocr-udg \ default
Fixed ahead and modified else to use it.
New version of (emit), the default behaviour of emit: Now chars 128..255 are user defined graphics. This was an old objective. Eventually, the code will be included as an independent routine, not as a Forth word; and the output channel of the operating system will be pointed to it, so rst 0x10 can be used for graphics.
_code_header paren_emit_,'(EMIT)'
; doc{
;
; (emit) ( b -- )
;
; Send the character _b_ to the current channel.
;
; }doc
pop hl
push bc
ld (iy+sys_scr_ct_offset),0xFF ; no scroll message
ld a,l
cp 128 ; control or ASCII character?
jp nc,paren_emit.print_udg ; is not, jump
; use the ROM routine to print a control or ASCII character
rst 0x10
pop bc
_jp_next
paren_emit.print_udg:
; hl = UDG code (128..255)
sub 128
ld l,a ; hl = UDG index code (0..127)
ld de,(sys_udg)
add hl,hl
add hl,hl
add hl,hl
add hl,de
ex de,hl ; de = char address in the font
ld bc,(sys_s_posn) ; cursor position
ld hl,(sys_df_cc) ; current screen address
call rom_pr_all
ld (sys_s_posn),bc
ld (sys_df_cc),hl
pop bc
_jp_next
First tries with alternative 42 cpl printing routines.
2015-09-06
Added printing, a flag set by printer, reset by display and checked by page. This way page can do the right thing.
Changed the order of parameters in the assembler commands for bit manipulation. Example of the old syntax: 5 b set, 2 FF IX bit; new syntax: b 5 set, FF IX 2 bit. Now the position of the displacement is the same in all instructions with index registers, what is easier to remember, and the bit number is right before the instruction, what is clearer.
Renamed overwrite to overprint.
Renamed ocr-udg to udg-ocr and ocr-ascii to ascii-ocr; they look clearer now, because they set the mode of ocr.
2015-09-07
Converted 0, 1 and 2 to byte constants.
After trying several routines to print 36, 42, 51 and 64 characters per line, the only one that supports all control characters and works fine is Print-42, by Ricardo Serral Wigge, published in 1986 in Microhobby. Two temporary words have been added to turn the 42 cpl mode on and off, but the code of the new printing routine still has to be loaded from disk. It's being disassembled in order to integrate it into the Forth library.
( mode32 mode42 )
[defined] sys-chans ?\ 23631 constant sys-chans
[defined] sys-chars ?\ 23606 constant sys-chars
: (mode) ( a1 a2 -- )
\ Set the system font to _a2_ and associate the output
\ routine at _a1_ to the system channels "K", "S" and "P".
\ a1 = character output routine
\ a2 = address of char 0x00 in a font
sys-chars !
sys-chans @ 2dup ! 2dup 5 + ! 15 + ! ;
: mode32 ( -- ) 2548 15360 (mode) ;
\ Set the default printing mode, 32 cpl and the ROM font.
: mode42 ( -- ) 63900 [ 64600 256 - ] literal (mode) ;
\ Set the 42 cpl printing mode.
\ [Author of the 42 cpl printing code: Ricardo Serral Wigge.
\ Published in Microhobby, issue 66 (1986-02), page 24:
\ http://microhobby.org/numero066.htm
\ http://microhobby.speccy.cz/mhf/066/MH066_24.jpg]
![http://microhobby.speccy.cz/mhf/066/MH066_24.jpg]](http://microhobby.speccy.cz/mhf/066/MH066_24.jpg]){kind=link}
Added unnest, a code synonym of rdrop.
Finished don't, a simple temporary alternative to ?do.
2015-09-08
Started adapting the 4x8 font driver written by Andrew Owen: removed the channels stuff, that will be done in Forth, and added the delete control code.
Fixed a silly bug in ?exhausted, a typo in the code.
Modified key and xkey to share a common routine that waits for a key press.
Added value to the library. Three alternative versions with non-parsing to are included too.
( value )
\ `value` with parsing and state-smart `to`
\ This implementation conforms to ANS Forth.
\ ANS Forth explicitly requires that `to` must parse.
\ Adapted from Afera.
\ http://programandala.net/en.program.afera.html
: value ( n "name" -- ) constant ;
: to ( Interpretation: n "name" -- )
( Compilation: "name" -- )
' cfa>pfa comp? if postpone literal postpone !
else ! then ; immediate
2015-09-09
Added <file-as-is (temporary name) to load a code file from disk, using the start and length stored in its header.
( <file-as-is )
require z80-asm require ufia require --hook-codes--
require >ufia require ior>error
code (<file-as-is) ( -- ior )
\ Load a file from disk, using the data hold in UFIA, the
\ file header and the parameters specified by the high level
\ command.
bc push \ save the Forth IP
ufia ix ldp# hgfile hook \ get the file
nc if \ no error? -- load the file header:
hd00 de ldp# 9 b ld# \ destination and count
begin lbyte hook de stap de incp step
\ Load the file header.
hd0d de ftp hd0b bc ftp hldbk hook
\ Use the address and length from the header.
\ Then load the file data.
then bc pop next ix ldp# af push
\ restore the Forth registers and save the ior
jpnext end-code
: <file-as-is ( ca len -- f n )
\ Load a file from disk.
\ ca len = filename
\ f = error?
\ n = error
0 0 2swap >ufia (<file-as-is) ior>error ;
<file-as-is was needed in order to load the alternative screen mode drivers from the disk, though the current method to activate and switch the screen modes is provisional.
( mode32 )
[defined] sys-chans ?\ 23631 constant sys-chans
[defined] sys-chars ?\ 23606 constant sys-chars
: channels! ( a -- )
\ Associate the output
\ routine at _a_ to the system channels "K", "S" and "P".
sys-chans @ 2dup ! 2dup 5 + ! 15 + ! ;
: set-mode ( a1 a2 -- )
\ Set the system font to _a1_ and associate the output
\ routine at _a2_ to the system channels "K", "S" and "P".
sys-chars ! channels! ;
: mode32 ( -- ) 2548 15360 set-mode ;
\ Set the default printing mode, 32 cpl and the ROM font.
( mode42 )
require mode32 require <file-as-is
drive@ 1 drive!
s" print-42" <file-as-is ?error
s" ea5aky.f42" <file-as-is ?error
drive!
\ Load the driver and the font.
: mode42 ( -- ) 63900 [ 64600 256 - ] literal set-mode ;
\ Set the 42 cpl printing mode.
\ Credits:
\ Author of the 42 cpl printing routine: Ricardo Serral Wigge.
\ Published in Microhobby, issue 66 (1986-02), page 24:
\ http://microhobby.org/numero066.htm
\ http://microhobby.speccy.cz/mhf/066/MH066_24.jpg
\ Adapted to Solo Forth by Marcos Cruz.
( mode64 )
require mode32 require <file-as-is
drive@ 1 drive!
s" 4x8fd.tap" <file-as-is ?error
drive!
\ Load the driver and the font.
: mode64 ( -- ) 60000 channels! ;
\ Set the 64 cpl printing mode.
\ Credits:
\ Author of the 4x8 font driver: Andrew Owen.
\ Published in the World of Spectrum forum:
\ http://www.worldofspectrum.org/forums/discussion/14526/redirect/p1
\ Modified and adapted to Solo Forth by Marcos Cruz.
2015-09-10
Added from to make it possible for require start searching from the first screen of a library section, therefore avoiding possible name clashes.
( require ) \ scr 2
\ This screen must be at a fixed location.
: reload ( -- ) scr @ load ;
: contains ( ca1 len1 ca2 len2 -- f ) search nip nip ;
\ Does the string ca1 len1 contains the string ca2 len2?
variable default-first-locatable
variable first-locatable
8 dup default-first-locatable ! first-locatable !
variable last-locatable scr/disk last-locatable !
: located ( ca len -- screen | false )
last-locatable @ 1+ first-locatable @
default-first-locatable @ first-locatable !
do
0 i (line) 2over contains if 2drop i unloop exit then
\ break-key? ?exhaust
loop 2drop false ;
: locate ( "name" -- screen | false )
parse-name save-string located ;
-->
( require ) \ scr 3
: ?located ( screen | false -- ) dup 0= 29 ?error ;
: from ( "name" -- ) locate ?located first-locatable ! ;
\ Locate the given _name_ and set its screen the first one
\ `require` will search from.
: do-required ( ca len -- ) located ?located load ;
: do-require ( "name" -- )
parse-name save-string do-required ;
: required ( ca len -- )
\ XXX FIXME usually the final check fails because the saved
\ string has been overwritten. the only solution is to store
\ the string apart, in an ad hoc zone.
\ XXX OLD
\ 2dup undefined?
\ if 2dup do-required then
\ 2dup undefined? warnings @ and
\ if type 28 warning exit then 2drop ;
\ XXX TMP
2dup undefined? if do-required else 2drop then ;
: require ( "name" -- )
parse-name save-string required ;
In order to use from, a unique identifier name must be added to the first line of the first screen of library sections. Example from the double numbers section:
( du.r u.r du. ) \ ==doublenumbers==
Finished n>r and nr>, after Forth 2012.
( n>r )
require z80-asm
code n>r ( x1..xn n -- ) ( R: -- x1..xn n )
exx
bc pop 0000 bc stp here 2- 0 unresolved !
rp hl ftp
begin bc tstp nz while
de pop hl decp d m ld hl decp e m ld bc decp
repeat
0000 de ldp# here 2- 0 unresolved @ !
hl decp d m ld hl decp e m ld
rp hl stp exx jpnext
end-code
require nr>
( nr> )
require z80-asm
code nr> ( -- x1..xn n ) ( R: x1..xn n -- )
exx
rp hl ftp
m c ld hl incp m b ld hl incp
0000 bc stp here 2- 0 unresolved !
begin bc tstp nz while
m e ld hl incp m d ld hl incp de push bc decp
repeat
rp hl stp exx
0000 hl ldp# here 2- 0 unresolved @ !
pushhl jp
end-code
require n>r
Improved the method to resolve absolute and relative references in assembler, but more changes will be necessary to make it simpler.
Finished the needed changes in the 4x8 font driver written by Andrew Owen: order of parameters; left control char; scroll. Extracted the font; now it's compiled in the dictionary space. The driver is ready to be converted to the Forth Z80 assembler and included in the library.
2015-09-11
Adapted the line editor of ZX Spectrum Specforth (Specforth Editor V1.1, by Chris A. Thornton, 1983). Beside the usual changes to remove or adapt the fig-Forth specific issues, text had to be rewritten, with an interesting factor, provisionally called command, that will be moved outside the editor
\ XXX OLD
\ : text ( c "text<c>" -- )
\ here c/l 1+ blank word pad c/l 1+ cmove ;
\ Parse a text string delimited by character _c_ and store it
\ into `pad`, blank-filling the remainder of `pad` to `c/l`
\ characters.
\ XXX NEW
: command ( "text<eol>" -- ca len )
source span @ min c/l min >in @ span @ min /string
dup >in +! save-string ;
\ Get the text string until the end of line.
\ Note: this is possibly useful factor of the editor's
\ `text`.
: text ( "text<eol>" -- )
pad c/l 1+ blank command pad place ;
\ Get the text string until end of line and store it
\ into `pad` as a counted string, blank-filling the remainder
\ of `pad` to `c/l` characters.
Beside, the documented problem of `c` has been fixed (typing `c` with no text copied a null into the text at the cursor position), with a simple check and a factor:
: (c) ( ca len -- )
#lag rot over min >r r@ r# +! r@ - >r
dup here r@ cmove here #lead + r> cmove r> cmove 0 m
update ;
\ Copy the string _ca len_ to the cursor line at the cursor
\ position.
: c ( "text<eol>" -- )
text pad count dup if (c) else 2drop then ;
\ Copy in "text" to the cursor line at the cursor position.
Though Solo Forth is not intended to edit the sources in the system, it's useful to have a classic Forth editor in the library, to do quick changes and tests during the development. Beside, it works great with the mode64 screen mode.
2015-09-12
Fixed words-like: the order of the compared strings was wrong!
( words-like )
\ Credits:
\ Code adapted from pForth.
require break-key?
[defined] contains
?\ : contains ( ca1 len1 ca2 len2 -- f ) search nip nip ;
\ Does the string _ca1 len1_ contains the string _ca2
\ len2?_
[defined] tab
?\ : tab ( -- ) 6 emit ;
: words-like ( "name" -- )
\ Print all words (from the `context` vocabulary) containing a substring.
parse-name 2dup uppers trail ( ca len nfa )
begin dup 0<> break-key? 0= and while
dup >r
nfa>string 2over contains if r@ id. tab then
r> nfa>lfa @n
repeat drop 2drop ;
Added c#, a shortcut for char and [char], inspired by pForth's d#, h# and b#, still being adapted.
( c# )
: c# ( "name" -- c )
parse-name drop c@ postpone literal ; immediate
\ Parse a name and return the code of the its first
\ character.
\ Note: This word depends on the fig-Forth's `literal`.
\ XXX TODO change when `literal` is updated.
Wrote two assembler macros to call any Forth word from code words.
( execute-hl call-cfa )
\ Assembler macros to call any Forth word from code words.
\ Credits:
\
\ Code inspired by Spectrum Forth-83, where similar code is
\ embedded in `KEY` and `PAUSE` to call a cfa hold in a
\ variable. The code has been converted from DTC to ITC and
\ factored to two assembler macros in order to make it
\ reusable.
macro execute-hl ( -- )
\ Compile an `execute` with the cfa hold in HL.
here 6 + bc ldp# \ point IP to phony_compiled_word
next2 jp \ execute the cfa in HL
\ phony_compiled_word:
here cell+ , \ point to the phony cfa following
here cell+ , \ phony cfa, point to the code following
endm
macro call-cfa ( cfa -- )
\ Compile a call to _cfa_.
\ This is the low-level equivalent of `execute`.
hl ldp# execute-hl
endm
Finished adapting pause from Spectrum Forth-83: it waits a number of ticks. A vectored call is done during the wait. Though the goal is to use a user variable to hold the cfa, instead of a deferred word.
( pause )
\ Credits:
\ Code adapted from Spectrum Forth-83.
require z80-asm require call-cfa
defer (wait) ' noop ' (wait) defer!
code pause ( u --- )
\ u = number of ticks
de pop bc push
begin
de push
' (wait) call-cfa
de pop halt de decp de tstp \ finished?
z until
bc pop jpnext
end-code
Improved key, xkey and key?: now they use the 5th bit of the system variable FLAGS to check if a new key is available, and reset it, instead of LASTK.
Moved and old version of key? to the library, that still may be useful, and renamed it to key??.
( key?? )
\ An alternative to `key?` that works also when the system
\ interrupts are off. Variant with relative jumps.
require z80-asm
code key?? ( -- f )
bc push
028E call \ ROM KEY_SCAN
here jrnz >relmark 0 unresolved ! \ to return_false
031E call \ ROM KEY_TEST
here jrnc >relmark 1 unresolved ! \ to return_false
\ return_true:
bc pop ' true cfa>pfa jp
\ return_false:
0 unresolved @ >relresolve
1 unresolved @ >relresolve
bc pop ' false cfa>pfa jp
end-code
( key?? )
\ An alternative to `key?` that works also when the system
\ interrupts are off. Faster variant with absolute jumps.
require z80-asm
code key?? ( -- f )
bc push
028E call \ ROM KEY_SCAN
0000 jpnz |mark 0 unresolved ! \ to return_false
031E call \ ROM KEY_TEST
0000 jpnc |mark 1 unresolved ! \ to return_false
\ return_true:
bc pop ' true cfa>pfa jp
\ return_false:
0 unresolved @ >resolve
1 unresolved @ >resolve
bc pop ' false cfa>pfa jp
end-code
Wrote index-like and index-ilike, with a nice factor from index: .index. The insensitive case version index-ilike is not a good solution: Eventually, the kernel search and compare will be configurable to use case sensitive or case insensitive modes, after DZX-Forth.
( index .index )
require break-key?
: .index ( n -- ) cr dup 3 .r space 0 swap .line ;
\ Print the first line of the screen _n_.
: index ( n1 n2 -- )
\ doc{
\
\ index ( n1 n2 -- )
\
\ Print the first line of each screen over the range from
\ _n1_ to _n2_.
\
\ }doc
1+ swap do
cr i 3 .r space 0 i .line
break-key? if exhaust then
loop ;
( index-like )
require break-key? require .index
[defined] contains
?\ : contains ( ca1 len1 ca2 len2 -- f ) search nip nip ;
\ Does the string _ca1 len1_ contains the string _ca2
\ len2?_
: index-like ( n1 n2 "name" -- )
\ doc{
\
\ index-like ( n1 n2 "name" -- )
\
\ Print the first line of each screen over the range from
\ _n1_ to _n2_, as long as the string "name" is included in
\ the line. The string comparison is case-sensitive.
\
\ }doc
parse-name 2swap
1+ swap do
0 i (line) 2over contains if i .index then
break-key? if exhaust then
loop 2drop ;
( index-ilike )
require break-key? require .index
[defined] contains
?\ : contains ( ca1 len1 ca2 len2 -- f ) search nip nip ;
\ Does the string _ca1 len1_ contains the string _ca2
\ len2?_
: index-ilike ( n1 n2 "name" -- )
\ doc{
\
\ index-ilike ( n1 n2 "name" -- )
\
\ Print the first line of each screen over the range from
\ _n1_ to _n2_, as long as the string "name" is included in
\ the line. The string comparison is case-insensitive.
\
\ }doc
parse-name save-string 2dup uppers
2swap 1+ swap do
save-string 0 i (line) save-string 2dup uppers
2over contains if i .index then
break-key? if exhaust then
loop 2drop ;
\ Note: The parsed string is re-saved to the circular string
\ buffer in every iteration in order to prevent it from being
\ overwritten by the strings of the index lines, because the
\ circular string buffer is small.
Removed unless from the kernel:
; ----------------------------------------------
_colon_header unless_,'UNLESS',immediate
; Equivalent to `0= if`, but faster.
dw compile_,question_branch_
dw branch_,if.do
dw semicolon_s_
And rewrote it in the library:
( unless )
\ Equivalent to `0= if`, but faster.
: unless ( f -- ) postpone ?branch >mark 2 ; immediate
\ XXX TODO Alternative for when compiler security is removed:
\ : unless ( f -- ) postpone ?branch >mark ; immediate
Added up (name after fig-Forth) (the user area pointer), up0 (its default value) and /user (the length of the user variables) to the kernel, because they will be needed by the multitasking words, currently being adapted from Spectrum Forth-83.
2015-09-13
Renamed the original assembler instruction ldhl to fthl, an oversight. Converted, in the library, all occurences of hl ftp to fthl, and hl stp to sthl; the new forms compile shorter Z80 opcodes.
Renamed require to need, required to needed, and so the variants with the "re" prefix. The reason is require and required are standard words (in Forth 94 and Forth 2012), and should not be used for different purposes.
Renamed the kernel code word $! to place and removed the library high-level word place; they did the same: stored a string into a memory address as a counted string.
Added s+, converted from Afera:
( s+ )
\ Credits:
\ Code adapted from Afera.
[defined] lengths
?\ : lengths 2over nip over ;
( ca1 len1 ca2 len2 -- ca1 len1 ca2 len2 len1 len2 )
: s+ ( ca1 len1 ca2 len2 -- ca3 len3 )
\ Append the string _ca2 len2_ to the end of string _ca1
\ len1_ returning the string _ca3 len3_ in the circular
\ string buffer.
lengths + >r ( ca1 len2 ca2 len2 ) ( r: len3 )
r@ allocate-string >r ( r: len3 ca3 )
2 pick r@ + ( ca1 len1 ca2 len2 len1+ca3 )
smove ( ca1 len1 ) \ 2nd string to buffer
r@ smove \ 1st string to buffer
r> r> ;
Fixed 2constant: the value was not stored!
Implemented search-wordlist, needed to implement s\".
: search-wordlist ( ca len wid -- 0 | xt 1 | xt -1 )
>r 2dup uppers save-counted-string r>
@ (find) dup ?exit nip ;
Implemented Forth-2012's s\". Some new words were needed.
( parse-char )
: parse-char ( "c" -- c ) stream c@ 0 parsed ;
\ Parse the next char in the input stream and return its
\ code.
\
\ Note: `0 parsed` increments `>in` because `parsed` adds 1
\ to its parameter (to include the delimiter).
( s\" ) \ ==strings==
only forth definitions
need wid-of need parse-char
vocabulary escaped-voc
wid-of escaped-voc constant escaped-wordlist
also escaped-voc definitions
\ The `escaped-voc` contains the words whose names are
\ characters that must be escaped after a backslash. Their
\ execution returns the new character(s) on the stack (the
\ first one at the top) and the count.
\
\ Most of the escaped chars are translated to one char, so
\ they are defined as double constants.
7 1 2constant a 8 1 2constant b 27 1 2constant e
\ \a = backspace
\ \b = alert
\ \e = escape
12 1 2constant f 10 1 2constant l 13 1 2constant n
\ \f = form feed
\ \l = line feed
\ \n = new line (implementation dependent)
char " 1 2constant q 13 1 2constant r 9 1 2constant t
\ \q = double quote
\ \r = carriage return
\ \t = horizontal tab
11 1 2constant v 0 1 2constant z
\ \v = vertical tab
\ \z = null character
char " 1 2constant " char \ 1 2constant \
\ \" = double quote
\ \\ = backslash
: m ( -- c1 c2 2 ) 10 13 2 ;
\ \m = carriage return and line feed
: (x) ( "c" -- n ) parse-char upper 16 digit 0= 14 ?error ;
\ Parse an hex digit and convert it to a number.
: x ( "cc" -- c 1 ) (x) 16 * (x) + 1 ;
\ \x = hex character code
\ Parse the 8-bit hex number of a character code.
-->
( s\" )
only forth definitions
need char>string need search-wordlist
need chars>string need s+
: unescape-char ( c -- c1..cn n )
dup char>string escaped-wordlist search-wordlist
if nip execute else [char] \ 2 then ;
\ Translate a escaped char to a number of chars and their
\ count.
\ c1..cn = chars to make the string with
\ (_c1_ is the last one)
\ n = number of chars
: (s\") ( "text<quote>" -- ca len )
pad 0 \ empty string to start with
begin parse-char dup [char] " <> while \ not finished?
dup [char] \ = \ possibly escaped char?
if drop parse-char unescape-char
else 1 then chars>string s+
repeat drop ;
\ Parse a text string delimited by a double quote, using the
\ translation rules described by Forth 2012's `s\"`, and
\ returning the string _ca len_ in the circular string
\ buffer.
: s\" ( "text<quote>" - ca len ) \ Forth 2012
(s\") comp? if postpone sliteral then ; immediate
( char>string chars>string )
: char>string ( c -- ca len ) 1 allocate-string tuck c! 1 ;
\ Convert the char _c_ to a string _ca len_ in the circular
\ string buffer.
: chars>string ( c1..cn n -- ca len )
dup if
dup allocate-string swap 2dup 2>r ( c1..cn ca n )
bounds do i c! loop 2r>
else pad swap then ;
\ Convert _n_ chars to a string _ca len_ in the circular
\ string buffer.
\ c1..cn = chars to make the string with
\ (_c1_ is the last one)
\ n = number of chars
Moved /string to the kernel, and rewrote it in assembler. It will be needed in order to improve the parsing primitives after Forth-83 and ANS Forth.
_code_header slash_string_,'/STRING'
; doc{
;
; /string ( ca1 len1 n -- ca2 len2 ) \ Forth 2012
;
; ----
; : /string ( ca1 len1 n -- ca2 len2 ) rot over + -rot - ;
; \ Alternative definition:
; : /string ( ca1 len1 n -- ca2 len2 ) \ dup >r - swap r> + swap ;
; ----
;
; }doc
pop de ; n
pop hl ; len1
and a ; cy=0
sbc hl,de ; hl=len2
ex (sp),hl ; (sp)=len2 hl=ca1
add hl,de ; hl=ca2
ex (sp),hl ; (sp)=ca2 hl=len2
jp push_hl
Removed expect from the kernel. It will modified and added to the library. The kernel byte-coded version uses low-level branches that can not be reproduced with control structures, so the word will be rewritten from scratch.
2015-09-15
Moved continued to the library.
Added assert( to the library, copied from Gforth.
Added invert to the kernel, adapted from Z88 CamelForth.
2015-09-16
Added words to manage the "jiffy call", a configurable routine G+DOS can call after processing a system interrupt.
( jiffy! jiffy@ -jiffy )
\ Credits:
\ Idea inspired by an article by Paul King, published in
\ Format, vol. 2 no. 3 (1988-10).
\ XXX TODO link to the WoS archive ftp, when available
need !dosvar need @dosvar
: jiffy! ( a -- ) 16 !dosvar ;
\ Set the Z80 routine to be called by G+DOS after the OS
\ interrupts routine, every 50th of a second.
: jiffy@ ( -- a ) 16 @dosvar ;
\ Get the current Z80 routine that is called by G+DOS after
\ the OS interrupts routine, every 50th of a second.
: -jiffy ( -- ) 8335 jiffy! ;
\ Deactivate the jiffy call, setting its default value
\ (a noop routine in the RAM of the +D interface).
Done a lot of work on the new improved parsing method, that does not need a null word added at the end of the input buffers. Wrote new versions of scan, skip, query, stream, parse, parse-name, word, error, interpret, quit and defined. Added some new words. The parsing method can be selected with a conditional compilation flag in the kernel.
2015-09-17
Added >number and number?, because fig-Forth number and (number) can not work with the new parsing method. Renamed digit to digit?.
Improved d+. The current code was from Abersoft Forth:
_code_header d_plus_,'D+'
; doc{
;
; d+ ( d1|ud1 d2|ud2 -- d3|ud3 )
;
; Add _d2|ud2_ to _d1|ud1_, giving the sum _d3|ud3_.
;
; }doc
; [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
The new code is adapted from Z88 CamelForth. It's faster and smaller, even with the additional pop and push (Z88 CamelForth keeps TOS in the BC register).
; [Code adapted from Z88 CamelForth.]
; t B
; -- --
pop de ; 10 01 ; DE=d2hi
exx ; 04 01
pop de ; 10 01 ; DE'=d2lo
exx ; 04 01
pop hl ; 10 01 ; HL=d1hi,DE=d2hi
exx ; 04 01
pop hl ; 10 01 ; HL'=d1lo
add hl,de ; 11 01
push hl ; 11 01 ; 2OS=d1lo+d2lo
exx ; 04 01
adc hl,de ; 15 02 ; HL=d1hi+d2hi+cy
push hl ; 11 01
_jp_next ; 08 02
; -- --
; 112 15 TOTALS
Added d- to the library, also adapted from Z88 CamelForth:
( d- )
need z80-asm
\ Credits:
\ Code adapted from Z88 CamelForth.
code d- ( d1|ud1 d2|ud2 -- d3|ud3 )
de pop \ DE=d2hi
exx
de pop \ DE'=d2lo
exx
hl pop \ HL=d1hi,DE=d2hi
exx
hl pop \ HL'=d1lo
de subp
hl push \ 2OS=d1lo-d2lo
exx
de sbcp \ HL=d1hi-d2hi-cy
pushhl jp
end-code
2015-09-18
Wrote find-name to substitute the old standard word find. This change makes it possible to forget counted strings (word will be substituted by parse-name).
; ----------------------------------------------
_colon_header find_name_,'FIND-NAME'
; doc{
; find-name ( ca len -- ca len 0 | cfa 1 | cfa -1 )
;
; Find the definition identified by the string _ca len_ in the
; current search order. If the definition is not found after
; searching all the vocabularies in the search order, return _ca
; len_ (converted to uppercase) and zero. If the definition is
; found, return its _cfa_. If the definition is immediate, also
; return one (1); otherwise also return minus-one (-1).
;
; The search is case-insensitive.
; ----
; : find-name ( ca len -- ca len 0 | cfa 1 | cfa -1 )
; 2dup uppers
; #vocs 0 do
; context i cells + @ ?dup
; if @ >r 2dup r> (find-name) ?dup
; if 2swap 2drop unloop exit then drop
; then
; loop false ;
; ----
; }doc
dw two_dup_,uppers_
dw hash_vocs_,zero_,paren_do_
find_name.do:
; ( ca len )
dw context_,i_,cells_,plus_,fetch_
dw question_dup_ ; a vocabulary in the search order?
dw zero_branch_,find_name.loop ; if not, next
; ( ca len wid )
; valid vocabulary in the search order
dw fetch_,to_r_,two_dup_,from_r_ ; ( ca len ca len nfa )
dw paren_find_name_,question_dup_ ; word found in the vocabulary?
dw zero_branch_,find_name.not_found
dw two_swap_,two_drop_
dw unloop_,exit_
find_name.not_found:
dw drop_
find_name.loop:
dw paren_loop_,find_name.do
dw false_
dw semicolon_s_
Wrote the required (find-name):
; ----------------------------------------------
_code_header paren_find_name_,'(FIND-NAME)'
; doc{
;
; (find-name) ( ca len nfa -- x 0 | cfa 1 | cfa -1 )
;
; Find the definition named in the string at _ca len_, starting
; at _nfa_. If the definition is not found, return an undefined
; cell _x_ and zero. If the definition is found, return its
; _cfa_. If the definition is immediate, also return one (1);
; otherwise also return minus-one (-1).
;
; The search is case-sensitive.
;
; }doc
ld (paren_find_name.ip_backup),bc ; save the Forth IP
ld e,names_bank
call bank.e ; page the memory bank in
pop de ; nfa
pop bc ; C=len, B is supposed to be 0
ld a,c
ld (paren_find_name.string_length),a
pop hl ; ca
ld (paren_find_name.string_address),hl
; XXX FIXME the string searched for must be in the string
; buffer, below 0xC000! This is not a problem now, during the
; development, because the dictionary is small.
paren_find_name.begin:
; Compare the string with a new word.
; de = nfa
ld (paren_find_name.nfa_backup),de ; save the nfa for later
paren_find_name.string_address: equ $+1
ld hl,0x0000 ; string address
ld a,(de) ; length byte of the name field
ld (paren_find_name.length_byte_backup),a ; save it for later
and max_word_length_mask ; length
paren_find_name.string_length: equ $+1
ld c,0x00 ; length of the string
cp c ; same length?
jr nz,paren_find_name.not_a_match ; lengths differ
; Lengths match, compare the characters.
paren_find_name.compare_next_char:
inc de
ld a,(de)
cpi
jr nz,paren_find_name.not_a_match ; mismatch
jp pe, paren_find_name.compare_next_char ; count not exhausted
; The string matches.
ld hl,(paren_find_name.nfa_backup)
dec hl
dec hl ; lfa
dec hl ; high part of the pointer to cfa
ld d,(hl)
dec hl ; low part of the pointer to cfa
ld e,(hl) ; de = cfa
ld hl,1 ; 1=immediate word
paren_find_name.length_byte_backup: equ $+1
ld a,0 ; name field length byte
and precedence_mask ; immediate word?
jp nz,paren_find_name.end
; non-immediate word
dec hl
dec hl ; -1 = non-immediate word
jr paren_find_name.end
paren_find_name.not_a_match:
; Not a match, try the next word.
paren_find_name.nfa_backup: equ $+1
ld hl,0x0000 ; nfa
dec hl ; high address of lfa
ld d,(hl) ; high part of the next nfa
dec hl ; low address of lfa
ld e,(hl) ; low part of the next nfa
ld a,d
or e ; end of dictionary? (next nfa=0)
jp nz,paren_find_name.begin ; if not, continue
; End of dictionary, no match found.
ld hl,0x0000
paren_find_name.end:
; If match found:
; de = cfa
; hl = -1 | 1
; If no match found:
; de = ?
; hl = 0
exx
ld e,default_bank
call bank.e ; page the default memory bank in
exx
paren_find_name.ip_backup: equ $+1
ld bc,0x0000 ; restore the Forth IP
jp push_hlde
And finally updated the library definition of search-wordlist:
: search-wordlist ( ca len wid -- 0 | cfa 1 | cfa -1 )
>r 2dup uppers r>
@ (find-name) dup ?exit nip ;
Improved some definitions of the circular string buffer, to make them more versatile. Some addresses of the buffer had been included as literals in the byte-coded definitions, because no word returned them. Documented all words of the circular string buffer.
2015-09-20
Finished fixing some bugs caused by the changes of the parsing system.
2015-09-21
Wrote number-base and modified >number to use it. This way number prefixes "$", "%" and "#" are recognized.
; ----------------------------------------------
_colon_header number_base_,'NUMBER-BASE'
; doc{
;
; number-base ( ca len -- ca' len' n )
;
; If the first char of string _ca len_ is a radix prefix, return
; its value _n_ and the updated string _ca' len'_ (which does
; not include the radix prefix). Otherwise return _ca len_
; untouched and the current value of `base`.
; ----
; : number-base ( ca len -- ca' len' n )
; over c@ [char] $ = if 1 /string 16 exit then
; over c@ [char] % = if 1 /string 2 exit then
; over c@ [char] # = if 1 /string 10 exit then
; base @ ;
; ----
; }doc
number_base.try_hex:
dw over_,c_fetch_
_literal '$'
dw equals_,zero_branch_,number_base.try_binary
_literal 1
dw slash_string_
_literal 16
dw exit_
number_base.try_binary:
dw over_,c_fetch_
_literal '%'
dw equals_,zero_branch_,number_base.try_decimal
_literal 1
dw slash_string_
_literal 2
dw exit_
number_base.try_decimal:
dw over_,c_fetch_
_literal '#'
dw equals_,zero_branch_,number_base.current
_literal 1
dw slash_string_
_literal 10
dw exit_
number_base.current:
dw base_,fetch_
dw semicolon_s_
2015-09-22
Tried alternative code for um*, from hForth and Z88 CamelForth, but the current code from DZX-Forth is faster, what was a surprise because the original code from DX-Forth is not Z80-specific, and consists of several routines that call each other. hForth and Z88 CamelForth use relative jumps in their code, but absolute jumps don't make it faster than the current code.
This is the version adapted from hForth, with absolute jumps:
_code_header u_m_star_,'UM*'
; doc{
;
; um* ( u1 u2 -- ud )
;
; Multiply _u1_ by _u2_, giving the unsigned double-cell product
; _ud_. All values and arithmetic are unsigned.
;
; Standard: Forth 94
;
; }doc
; XXX -- adapted from hForth
exx
pop bc ; BC = u2
pop de ; DE = u1
ld hl,0x0000
ld a,0x10
u_m_star.1:
add hl,hl
ex de,hl
adc hl,hl
ex de,hl
jp nc,u_m_star.3
u_m_star.2:
add hl,bc
jp nc,u_m_star.3
u_m_star.5:
inc de
u_m_star.3:
dec a
jp nz,u_m_star.1
u_m_star.4:
push hl
push de
exx
_jp_next
This is the version adapted from Z88 CamelForth, with absolute jumps:
_code_header u_m_star_,'UM*'
; doc{
;
; um* ( u1 u2 -- ud )
;
; Multiply _u1_ by _u2_, giving the unsigned double-cell product
; _ud_. All values and arithmetic are unsigned.
;
; Standard: Forth 94
;
; }doc
; XXX -- adapted from Z88 CamelForth
exx
pop bc ; u2 in BC
pop de ; u1 in DE
ld hl,0 ; result will be in HLDE
ld a,17 ; loop counter
or a ; clear cy
u_m_star.do:
rr h
rr l
rr d
rr e
jp nc,u_m_star.noadd
add hl,bc
u_m_star.noadd:
dec a
jp nz,u_m_star.do
push de ; lo result
push hl ; hi result
exx
_jp_next
And the benchmarks:
( um*-bench )
2 load need frames@ need frames0
: um*-bench ( times -- )
frames0 0 do i i um* 2drop loop frames@ d. ;
\ Times Frames (1 frame = 50th of second)
\ ----- -----------------------------------
\ DZX hForth R hForth A Z88 R Z88 A
\ ----- -------- -------- ----- -----
\ 00100 3 3 3 3 3
\ 01000 29 32 31 32 31
\ 10000 297 328 319 323 316
\ 20000 598 659 643 647 633
\ 32000 961 1060 1037 1037 1016
\ Bytes free Code from
\ ---------- ---------
\ DZX = 33783 DZX-Forth
\ hForth R = 33787 hForth, with relative jumps
\ hForth A = 33784 hForth, with absolute jumps
\ Z88 R = 33786 Z88 CamelForth, with relative jumps
\ Z88 A = 33784 Z88 CamelForth, with absolute jumps
Renamed fig-Forth's +- and d+- to ?negate and ?dnegate, better names, already used by other Forth systems.
Tested and benchmarked the Abersoft Forth implementation of fig-Forth's m/ and the Z88 CamelForth implementation of Forth-94's sm/rem. Confirmed m/ does a symmetric division, and so both words are equivalent. The code of m/ is much faster, therefore it's renamed to sm/rem. m/ is converted to a deferred word in order to use fm/mod when needed.
( /-test )
\ 2015-09-22: This test shows that Abersoft Forth's `m/` does
\ a symmetric division, and so it's equivalent to Forth-94's
\ `sm/rem`.
\ From the Forth-94 documentation:
\ Table 3.4 - Symmetric Division Example
\ Dividend Divisor Remainder Quotient
\ -------- ------- --------- --------
\ 10 7 3 1
\ -10 7 -3 -1
\ 10 -7 3 -1
\ -10 -7 -3 1
[defined] (/) ?\ defer (/)
: ((/-test)) ( dividend divisor -- )
>r s>d r> (/) swap . . space ;
: (/-test) ( -- )
cr 10 7 ((/-test)) -10 7 ((/-test))
10 -7 ((/-test)) -10 -7 ((/-test)) ;
: /-test ( -- )
dup ['] m/ ['] (/) defer! (/-test)
['] sm/rem ['] (/) defer! (/-test) ;
( /-bench )
\ 2015-09-22: This bench compares the execution speed of
\ Abersoft Forth's `m/` and Z88 CamelForth's `sm/rem`. Both
\ words are equivalent. Abersoft Forth's `m/` is much
\ faster.
need frames@ need frames0 need rnd
: drnd ( -- d ) rnd rnd ;
[defined] (/) ?\ defer (/)
: (/-bench) ( n -- )
frames0 1+ 1 do drnd i (/) 2drop loop frames@ cr d. ;
: /-bench ( n -- )
dup ['] m/ ['] (/) defer! (/-bench)
['] sm/rem ['] (/) defer! (/-bench) ;
\ Times Frames (1 frame = 50th of second)
\ ----- -----------------------------------
\ m/ sm/rem
\ ----- ------
\ 00010 3 4
\ 00100 33 44
\ 01000 326 442
\ m/ = word from Abersoft Forth
\ sm/rem = word from Z88 Camel Forth
Fixed a silly bug recently introduced in asm and end-asm.
Wrote a new implementation of defer that calls the deferred words more than 200% faster. The implementation used so far is the classic one, with create and does>:
; ----------------------------------------------
_colon_header defer_,'DEFER'
; doc{
;
; defer ( "name" -- )
;
; Create a deferred word.
;
; Standard: Forth-2012.
;
; ----
; : defer ( "name" -- )
; create ['] (defer) ,
; does> ( pfa ) @ execute ;
; ----
;
; }doc
dw create_
_literal paren_defer_
dw compile_comma_
dw paren_semicolon_code_
do_defer:
call do_does
dw fetch_,execute_
dw semicolon_s_
; ----------------------------------------------
_colon_header defer_fetch_,'DEFER@'
; doc{
;
; defer@ ( cfa1 -- cfa2 )
;
; Return the word _cfa2_ currently associated to the deferred
; word _cfa1_.
;
; Standard: Forth-2012.
;
; }doc
dw cfa_to_pfa_,fetch_
dw semicolon_s_
; ----------------------------------------------
_colon_header defer_store_,'DEFER!'
; doc{
;
; defer! ( cfa1 cfa2 -- )
;
; Change the deferred word _cfa2_ to execute _cfa1_.
;
; Standard: Forth-2012.
;
; }doc
dw cfa_to_pfa_,store_
dw semicolon_s_
The new implementation of defer creates a code word with a direct jump to the inner interpreter. This is not only much faster, but does not create an additional nesting level, which may be a problem in some cases. defer! and defer@ need a little change.
; ----------------------------------------------
_colon_header defer_,'DEFER' ; XXX TMP
; doc{
;
; defer ( "name" -- )
;
; Create a deferred word.
;
; Standard: Forth-2012.
;
; }doc
dw header_
_literal 0x21 ; Z80 opcode for `ld hl,NN`
dw c_comma_
_literal paren_defer_ ; default cfa to execute
dw comma_
_literal 0xC3 ; Z80 opcode for `jp NN`
dw c_comma_
_literal next2 ; address to jump to
dw comma_
dw semicolon_s_
; ----------------------------------------------
_colon_header defer_fetch_,'DEFER@'
; doc{
;
; defer@ ( cfa1 -- cfa2 )
;
; Return the word _cfa2_ currently associated to the deferred
; word _cfa1_.
;
; Standard: Forth-2012.
;
; }doc
dw cfa_to_pfa_,one_plus_,fetch_
dw semicolon_s_
; ----------------------------------------------
_colon_header defer_store_,'DEFER!'
; doc{
;
; defer! ( cfa1 cfa2 -- )
;
; Change the deferred word _cfa2_ to execute _cfa1_.
;
; Standard: Forth-2012.
;
; }doc
dw cfa_to_pfa_,one_plus_,store_
dw semicolon_s_
Adapted the deferred words in the kernel (cr, emit, at-xy and home). Conditional compilation will used for a while, just in case. Example:
if old_defer
_does_header emit_,'EMIT',,do_defer
dw paren_emit_
else
_code_header emit_,'EMIT'
ld hl,paren_emit_
jp next2
endif
Added xy to get the current cursor position. This word is deferred because it depends on the screen mode.
; ----------------------------------------------
_colon_header paren_mode32_xy_,'(MODE32-XY)'
; doc{
;
; (mode32-xy) ( -- col row )
; Return the current column and row, in mode 32.
; ----
; : (mode32-xy) ( -- row col )
; 24 23689 c@ -
; 33 23688 c@ - dup 32 = if drop 1+ 0 then ;
; ----
; }doc
; Credits:
; Code from the Spectrum Forth-83 manual.
_literal 24
_literal sys_s_posy
dw c_fetch_,minus_
_literal 33
_literal sys_s_posx
dw c_fetch_,minus_
dw dup_
_literal 32 ; XXX TODO -- chars per line in the current mode
dw equals_
dw zero_branch_,paren_mode32_xy.end
dw drop_,one_plus_
_literal 0
paren_mode32_xy.end:
dw semicolon_s_
; ----------------------------------------------
if old_defer
_does_header at_xy_,'XY',,do_defer
; doc{
;
; xy ( -- col row )
;
; Return the current column and row of the text cursor.
;
; }doc
dw paren_mode32_xy_
else
_code_header xy_,'XY'
ld hl,paren_mode32_xy_
jp next2
endif
Tidied the user data space to move the free space to the end.
removed the fld user variable, not used. It's defined but not used in fig-Forth; it's defined also in Forth-79 and Forth-83.
Added a new user variable, udp, to hold an offset to the free space in the user data space. This way an improved version of user will be possible, without requiring an offset as parameter.
Renamed the fig-Forth user variable out (called #out by the F83 Forth system) to #emit.
2015-09-23
Started implementing the Forth-2012 floating point word set, using the ROM calculator. Its stack can be used as the Forth floating point stack. So far the coding has been easy, because most o the words require only one or two calculator instructions. But it seems the ROM calculator uses the BASIC error routines after an error condition, what crashes the system. Not sure yet. If so, some ROM routines would have to be replicated and modified.
Fixed the problem of bye crashing when the screen mode is changed by mode42 or mode64. Now bye restores mode32. The previous mode is restored by warm and cold.
Converted boot to a deferred word. Formerly it was a constant that returned an address inside a definition to be patched with a cfa...
2015-09-24
Converted the error codes to the Forth-2012 standard. This change required a new version of error>line, with the new word error>ordinal:
; ----------------------------------------------
_colon_header error_to_ordinal_,'ERROR>ORDINAL'
; : error>ordinal ( -n1 -- +n2 )
; \ Convert an error code to its ordinal position in the
; \ library.
; \ -n1 = -90..-1 \ Forth-2012 error codes
; \ -285..-256 \ Solo Forth error codes
; \ -1024..-1000 \ G+DOS error codes
; \ +n2 = 1..146
; abs
; dup 256 < ?exit
; dup 1000 < if [ 255 091 - ] literal - exit then
; [ 1000 286 - 255 091 - + ] literal - ;
dw abs_,dup_
_literal 256
dw less_than_,question_exit_
dw dup_
_literal 1000
dw less_than_,zero_branch_,error_to_ordinal.g_plus_dos
_literal 255-91
dw minus_,exit_
error_to_ordinal.g_plus_dos:
_literal (1000-286)+(255-91)
dw minus_
dw semicolon_s_
; ----------------------------------------------
_colon_header error_to_line_,'ERROR>LINE'
; doc{
;
; error>line ( n1 -- n2 )
;
; Convert an error number to its correspondent line offset. This
; is used in order to skip the first line of screens and use
; them as screen headers as usual.
;
; : error>line ( n1 -- n2 )
; error>ordinal dup 1+ 1 do i 16 mod 0= abs + loop ;
;
; }doc
dw error_to_ordinal_
dw dup_,one_plus_,one_,paren_do_
error_to_number.do
dw i_
_literal 16
dw mod_,zero_equals_,abs_,plus_
dw paren_loop_,error_to_number.do
dw semicolon_s_
The old error codes were based on fig-Forth, with some system specific codes and all G+DOS codes added:
\ }}} =======================================================
\ Error messages {{{
( Error messages 1..15 ) \ scr 4
\ Error #01: Not a word nor a number.
\ Error #02: Stack empty.
\ XXX not used:
\ Error #03: Dictionary overflow.
\ Error #04: Warning: Is not unique.
\ Error #05: Word not found.
\ XXX not used:
\ Error #06: Out of disk range
\ Error #07: Stack overflow.
\ Error #08: Stack imbalance.
\ Error #09: Trying to load from screen 0.
\ Error #10:
\ Error #11:
\ Error #12:
\ Error #13:
\ Error #14: Wrong digit.
\ Error #15: Deferred word is uninitialized.
( Error messages 16..30 ) \ scr 5
\ Error #16: Assertion failed.
\ Error #17: Compilation only, use in definition.
\ Error #18: Execution only.
\ Error #19: Conditionals not paired.
\ Error #20: Definition not finished.
\ Error #21:
\ Error #22: Use only when loading.
\ Error #23: Off current editing screen.
\ Error #24:
\ XXX TMP -- not used yet:
\ Error #25: Unsupported tape operation.
\ XXX TMP -- not used yet:
\ Error #26: Unsupported disk operation.
\ Error #27: Source file needed.
\ Error #28: Warning: Not present, though required.
\ Error #29: Required, but not located.
\ Assembler:
\ Error #30: Relative jump too long.
( Error messages 31..46 ) \ scr 6
\ G+DOS Error codes and messages.
\ Some of them are useless for this implementation.
\ XXX useless:
\ G+DOS error #00: Nonsense in G+DOS
\ XXX useless:
\ G+DOS error #01: Nonsense in GNOS
\ XXX useless:
\ G+DOS error #02: Statement end error
\ XXX useless:
\ G+DOS error #03: Break requested
\ G+DOS error #04: Sector error
\ G+DOS error #05: Format data lost
\ G+DOS error #06: Check disk in drive
\ XXX useless:
\ G+DOS error #07: No +SYS file
\ G+DOS error #08: Invalid file name
\ XXX useless:
\ G+DOS error #09: Invalid station
\ G+DOS error #10: Invalid device
\ XXX useless:
\ G+DOS error #11: Variable not found
\ G+DOS error #12: Verify failed
\ G+DOS error #13: Wrong file type
\ XXX useless:
\ G+DOS error #14: Merge error
( Error messages 47..62 ) \ scr 7
\ G+DOS Error codes and messages.
\ Some of them are useless for this implementation.
\ G+DOS error #15: Code error
\ XXX useless:
\ G+DOS error #16: Pupil set
\ G+DOS error #17: Invalid code
\ G+DOS error #18: Reading a write file
\ G+DOS error #19: Writing a read file
\ XXX useless:
\ G+DOS error #20: O.K. G+DOS
\ XXX useless:
\ G+DOS error #21: Network off
\ G+DOS error #22: Wrong drive
\ G+DOS error #23: Disk write protected
\ G+DOS error #24: Not enough space on disk
\ G+DOS error #25: Directory full
\ G+DOS error #26: File not found
\ G+DOS error #27: End of file
\ G+DOS error #28: File name used
\ XXX useless:
\ G+DOS error #29: No G+DOS loaded
( Error messages 63..78 ) \ scr 8
\ G+DOS Error codes and messages.
\ Some of them are useless for this implementation.
\ XXX useless:
\ G+DOS error #30: STREAM used
\ XXX useless:
\ G+DOS error #31: CHANNEL used
The new error codes are those of the Forth-2012 standard, with two additional ranges for Solo Forth codes and G+DOS codes:
\ }}} =======================================================
\ Error messages {{{
( Error messages -01..-15 ) \ scr 4
\ #-01 ABORT
\ #-02 ABORT"
\ #-03 stack overflow
\ #-04 stack underflow
\ #-05 return stack overflow
\ #-06 return stack underflow
\ #-07 do-loops nested too deeply during execution
\ #-08 dictionary overflow
\ #-09 invalid memory address
\ #-10 division by zero
\ #-11 result out of range
\ #-12 argument type mismatch
\ #-13 undefined word
\ #-14 interpreting a compile-only word
\ #-15 invalid FORGET
( Error messages -16..-30 )
\ #-16 attempt to use zero-length string as a name
\ #-17 pictured numeric output string overflow
\ #-18 parsed string overflow
\ #-19 definition name too long
\ #-20 write to a read-only location
\ #-21 unsupported operation
\ #-22 control structure mismatch
\ #-23 address alignment exception
\ #-24 invalid numeric argument
\ #-25 return stack imbalance
\ #-26 loop parameters unavailable
\ #-27 invalid recursion
\ #-28 user interrupt
\ #-29 compiler nesting
\ #-30 obsolescent feature
( Error messages -31..-45 )
\ #-31 >BODY used on non-CREATEd definition
\ #-32 invalid name argument
\ #-33 block read exception
\ #-34 block write exception
\ #-35 invalid block number
\ #-36 invalid file position
\ #-37 file I/O exception
\ #-38 non-existent file
\ #-39 unexpected end of file
\ #-40 invalid BASE for floating point conversion
\ #-41 loss of precision
\ #-42 floating-point divide by zero
\ #-43 floating-point result out of range
\ #-44 floating-point stack overflow
\ #-45 floating-point stack underflow
( Error messages -46..-60 )
\ #-46 floating-point invalid argument
\ #-47 compilation word list deleted
\ #-48 invalid POSTPONE
\ #-49 search-order overflow
\ #-50 search-order underflow
\ #-51 compilation word list changed
\ #-52 control-flow stack overflow
\ #-53 exception stack overflow
\ #-54 floating-point underflow
\ #-55 floating-point unidentified fault
\ #-56 QUIT
\ #-57 exception in sending or receiving a character
\ #-58 [IF], [ELSE], or [THEN] exception
\ #-59 ALLOCATE
\ #-60 FREE
( Error messages -61..-75 )
\ #-61 RESIZE
\ #-62 CLOSE-FILE
\ #-63 CREATE-FILE
\ #-64 DELETE-FILE
\ #-65 FILE-POSITION
\ #-66 FILE-SIZE
\ #-67 FILE-STATUS
\ #-68 FLUSH-FILE
\ #-69 OPEN-FILE
\ #-70 READ-FILE
\ #-71 READ-LINE
\ #-72 RENAME-FILE
\ #-73 REPOSITION-FILE
\ #-74 RESIZE-FILE
\ #-75 WRITE-FILE
( Error messages -76..-79 )
\ #-76 WRITE-LINE
\ #-77 malformed xchar
\ #-78 SUBSTITUTE
\ #-79 REPLACES
\ #-80
\ #-81
\ #-82
\ #-83
\ #-84
\ #-85
\ #-86
\ #-87
\ #-88
\ #-89
\ #-90
( Error messages -256..-268 )
\ #-256 not a word nor a number
\ #-257 warning: not unique
\ #-258 stack imbalance
\ #-259 trying to load from screen 0
\ #-260 wrong digit
\ #-261 deferred word is uninitialized
\ #-262 assertion failed
\ #-263 execution only
\ #-264 definition not finished
\ #-265 loading only
\ #-266 off current editing screen
\ #-267 warning: not present, though required
\ #-268 required, but not located
\ #-269 relative jump too long
( Error messages -270..-285 )
\ #-270 text not found
\ #-271
\ #-272
\ #-273
\ #-274
\ #-275
\ #-276
\ #-277
\ #-278
\ #-279
\ #-281
\ #-282
\ #-283
\ #-284
\ #-285
( Error messages -1000..-1014 )
\ #-1000 G+DOS: Nonsense in G+DOS
\ #-1001 G+DOS: Nonsense in GNOS
\ #-1002 G+DOS: Statement end error
\ #-1003 G+DOS: Break requested
\ #-1004 G+DOS: Sector error
\ #-1005 G+DOS: Format data lost
\ #-1006 G+DOS: Check disk in drive
\ #-1007 G+DOS: No +SYS file
\ #-1008 G+DOS: Invalid file name
\ #-1009 G+DOS: Invalid station
\ #-1010 G+DOS: Invalid device
\ #-1011 G+DOS: Variable not found
\ #-1012 G+DOS: Verify failed
\ #-1013 G+DOS: Wrong file type
\ #-1014 G+DOS: Merge error
( Error messages -1015..-1029 )
\ #-1015 G+DOS: Code error
\ #-1016 G+DOS: Pupil set
\ #-1017 G+DOS: Invalid code
\ #-1018 G+DOS: Reading a write file
\ #-1019 G+DOS: Writing a read file
\ #-1020 G+DOS: O.K. G+DOS
\ #-1021 G+DOS: Network off
\ #-1022 G+DOS: Wrong drive
\ #-1023 G+DOS: Disk write protected
\ #-1024 G+DOS: Not enough space on disk
\ #-1025 G+DOS: Directory full
\ #-1026 G+DOS: File not found
\ #-1027 G+DOS: End of file
\ #-1028 G+DOS: File name used
\ #-1029 G+DOS: No G+DOS loaded
( Error messages -1030..-1031 )
\ #-1030 G+DOS: STREAM used
\ #-1031 G+DOS: CHANNEL used
Rewrote ?negate and ?dnegate in assembler. They are faster and each of them saves two bytes.
; ----------------------------------------------
_code_header question_negate_,'?NEGATE'
; doc{
;
; ?negate ( n1 f -- n1|n2 )
;
; If _f_ is not zero, negate _n1_, giving its arithmetic inverse
; _n2_.
;
; ----
; : ?negate ( n1 f -- n1|n2 )
; if negate then ;
; ----
; }doc
; XXX OLD
; _colon_header question_negate_,'?NEGATE'
; dw zero_less_than_
; dw zero_branch_,question_negate.end
; dw negate_
; question_negate.end:
; dw semicolon_s_
pop hl
ld a,h
or l
jp nz,negate_pfa
_jp_next
; ----------------------------------------------
_code_header question_d_negate_,'?DNEGATE'
; doc{
;
; ?dnegate ( d1 f -- d1|d2 )
;
; If _f_ is not zero, negate _d1_, giving its arithmetic inverse
; _d2_.
;
; ----
; : ?dnegate ( d1 f -- d1|d2 )
; if dnegate then ;
; ----
; }doc
; XXX OLD
;_colon_header question_d_negate_,'?DNEGATE'
; dw zero_less_than_
; dw zero_branch_,question_d_negate.end
; dw d_negate_
; question_d_negate.end:
; dw semicolon_s_
pop hl
ld a,h
or l
jp nz,dnegate_pfa
_jp_next
2015-09-25
Fixed silly bug recently introduced: The fig-Forth +- and d+- changed the sign of a number when the TOS is negative; that's different from the behaviour of their new versions ?negate and ?negate, that change the sign when TOS is not zero! Restored the original behaviour, because some words need it.
Documented many words.
Benchmarked three implementations of fill: the original one from Abersoft Forth, a modified variant and the one from Z88 CamelForth. The later uses the Z80 instruction ldir and is almost 200% faster.
Reorganized and renamed most of the files. Moved the GNU binutils versions to /_old/gnu_binutils. Updated Makefile and the Vim session accordingly. Formerly most of the files used the same base name, "solo_forth". Now they are called "kernel", "library", "loader" or "boot":
- ACKNOWLEDGMENTS.adoc
- Makefile
- Makefile.pasmo
- README.adoc
- TO-DO.adoc
- _dev_tools/
- _diff/
- _doc/
- _draft/
- _ideas/
- _old/
- _solo_forth_session.vim
- _solo_forth_sessionx.vim
- _tests/
- _tmp/
- boot.debug.sh
- boot.sh
- fzx/
- inc/
- kernel.bin.tap
- kernel.symbols.z80s
- kernel.z80s
- library.fsb
- loader.bas
- loader.bas.tap
- solo_forth_disk_1.mgt
- solo_forth_disk_2.mgt
- sys/
Fixed error>ordinal: the range -256..-286 returned a number incremented by one.
Renamed (line) (name from fig-Forth) to line>string.
Documented more words of the kernel.
Added more alternative implementations for single-cell and double-cell values and benchmarked all of them. The benchmarks are the following:
( to-value-bench )
need frames@ need frames0
0 value v1
: to-value-bench ( n -- )
frames0 0
do 0 to v1 loop
frames@ cr d. ;
( to-2value-bench )
need frames@ need frames0
0. 2value v2
: to-2value-bench ( n -- )
frames0 0
do 0. to v2 loop
frames@ cr d. ;
( 2to-2value-bench )
need frames@ need frames0
0. 2value v2
: 2to-2value-bench ( n -- )
frames0 0
do 0. 2to v2 loop
frames@ cr d. ;
The benchmarked versions:
( value 2value to )
\ Standard: Forth-2012.
: value ( n "name" -- ) create 0 c, , does> 1+ @ ;
: 2value ( n "name" -- ) create 1 c, , , does> 1+ 2@ ;
: !value ( n|d pfa -- ) dup c@ if 1+ 2! exit then 1+ ! ;
: to ( Interpretation: n "name" -- )
( Compilation: "name" -- )
' cfa>pfa
comp? if postpone literal postpone !value exit then
!value ; immediate
( value to )
\ Standard: Forth-94.
\ Credits:
\ Code adapted from Afera.
: value ( n "name" -- ) constant ;
: to ( Interpretation: n "name" -- )
( Compilation: "name" -- )
' cfa>pfa comp? if postpone literal postpone !
else ! then ; immediate
( 2value 2to )
\ Implementation of `2value` (from Forth-2012) but with
\ the non-standard word `2to`
: 2value ( d "name" -- ) 2constant ;
: 2to ( Interpretation: d "name" -- )
( Compilation: "name" -- )
' cfa>pfa comp? if postpone literal postpone 2!
else 2! then ; immediate
( value )
\ Non-standard implementation of `value` with non-parsing
\ `to` -- version with flag.
\ Credits:
\ Code from lina.
variable to-message
: from ( -- ) to-message off ; from
: to ( -- ) to-message on ;
: value ( n "name" -- )
create , does> to-message @ if ! else @ then from ;
( value )
\ Non-standard implementation of `value` with non-parsing
\ `to` -- version with `perform`
\ Credits:
\ Code inspired by lina.
variable (value)
: from ( -- ) ['] @ (value) ! ; from
: to ( -- ) ['] ! (value) ! ;
: value ( n "name" -- )
create , does> (value) perform from ;
( value )
\ Non-standard implementation of `value` with non-parsing
\ `to` -- version with `defer`
\ Credits:
\ Code inspired by lina.
defer (value)
: from ( -- ) ['] @ ['] (value) defer! ; from
: to ( -- ) ['] ! ['] (value) defer! ;
: value ( n "name" -- )
create , does> (value) from ;
The benchmarks (for compiled to or 2to):
( to-value-bench )
need frames@ need frames0
0 value v1
: to-value-bench ( n -- )
frames0 0
do 0 to v1 loop
frames@ cr d. ;
( to-2value-bench )
need frames@ need frames0
0. 2value v2
: to-2value-bench ( n -- )
frames0 0
do 0. to v2 loop
frames@ cr d. ;
( 2to-2value-bench )
need frames@ need frames0
0. 2value v2
: 2to-2value-bench ( n -- )
frames0 0
do 0. 2to v2 loop
frames@ cr d. ;
Results:
| Implementation for single-cell values | Frames (1 frame= 50th of second) |
|---|---|
Forth-94 to |
0339 |
Forth-2012 to with single-cell value |
0744 |
Non-parsing to with flag |
1208 |
Non-parsing to with perform |
1208 |
Non-parsing to with defer |
1719 |
| Implementation for double-cell values | Frames (1 frame= 50th of second) |
Non-standard 2to |
0425 |
Forth-2012 to with double-cell value |
0968 |
2015-09-26
Renamed comp? to compiling? and made it return a well-formed flag; renamed ?comp to ?compiling and ?exec to ?executing. Documented all of them.
Wrote a second, better implementation of Forth-2012 to:
( value 2value to )
\ Standard: Forth-2012.
: value ( n "name" -- ) create 0 c, , does> 1+ @ ;
: 2value ( n "name" -- ) create 1 c, , , does> 1+ 2@ ;
: to ( Interpretation: n "name" -- )
( Compilation: "name" -- )
' cfa>pfa dup 1+ swap c@
compiling? if swap postpone literal
if postpone 2! else postpone ! then exit
then
if 2! else ! then
; immediate
Now the code compiled by to is exactly the same than the Forth-94 version, and so the benchmarks. Wrote simplified and a bit faster versions of the non-parsing implementations of to, without from. Example:
( value to )
\ Alternative non-standard implementation of `value` with
\ non-parsing `to` -- version with flag.
\ Note: this version of is 3.6 times slower than the Forth-94
\ and Forth-2012 implementations (for compiled `to`).
\ Credits:
\ Code modified from lina.
variable to-message to-message off
: to ( -- ) to-message on ;
: value ( n "name" -- )
create ,
does> to-message @ if ! else @ then to-message off ;
All benchmark results so far:
| Implementation for single-cell values | Frames (1 frame= 50th of second) |
|---|---|
Forth-94 to |
0339 |
Forth-2012 to (2nd version) |
0339 |
Non-parsing to with perform (without from) |
0670 |
Non-parsing to with defer (without from) |
0670 |
Forth-2012 to (1st version) |
0744 |
Non-parsing to with flag (without from) |
1051 |
Non-parsing to with flag (with from) |
1208 |
Non-parsing to with perform (with from) |
1208 |
Non-parsing to with defer (with from) |
1719 |
| Implementation for double-cell values | Frames (1 frame= 50th of second) |
Non-standard 2to |
0425 |
Forth-2012 to (2nd version) |
0425 |
Forth-2012 to (1st version) |
0968 |
Then benchmarked the fetching from single-cell and double-cell values, with the following code:
( value-bench )
need frames@ need frames0
0 value v1
: value-bench ( n -- )
frames0 0 do v1 drop loop frames@ cr d. ;
( 2value-bench )
need frames@ need frames0
0. 2value v2
: 2value-bench ( n -- )
frames0 0 do v2 2drop loop frames@ cr d. ;
| Implementation for single-cell values | Frames (1 frame= 50th of second) |
|---|---|
Forth-94 value |
0256 |
Forth-2012 to (2nd version) |
0480 |
Forth-2012 to (1st version) |
0670 |
Non-parsing to with perform (without from) |
0670 |
Non-parsing to with flag (without from) |
0719 |
Non-parsing to with defer (with from) |
0842 |
Non-parsing to with perform (with from) |
0851 |
Non-parsing to with flag (with from) |
0874 |
Non-parsing to with defer (without from) |
0899 |
| Implementation for double-cell values | Frames (1 frame= 50th of second) |
Non-standard 2to |
0283 |
Forth-2012 to (2nd version) |
0500 |
Forth-2012 to (1st version) |
0500 |
Finally, noted the dictionary space required by each implementation. Note that in Solo Forth the names are stored apart.
| Implementation for single-cell values | Bytes |
|---|---|
Forth-94 to |
032 |
Non-parsing to with perform (without from) |
041 |
Non-parsing to with flag (without from) |
045 |
Non-parsing to with perform (with from) |
047 |
Non-parsing to with defer (without from) |
047 |
Non-parsing to with flag (with from) |
051 |
Non-parsing to with defer (with from) |
053 |
Forth-2012 to (1st version), without 2value |
067 |
Forth-2012 to (2nd version), without 2value |
077 |
| Implementation for double-cell values | Bytes |
Non-standard 2to |
032 |
Forth-2012 to (1st version), without value |
069 |
Forth-2012 to (2nd version), without value |
079 |
| Implementation for single-cell and double-cell values | Bytes |
Forth 94 to with non-standard 2to |
064 |
Forth-2012 to (1st version) |
090 |
Forth-2012 to (2nd version) |
100 |
The conclusion is easy: Forth-94 to and the non-standard 2to are the winners in all aspects. The second version of the Forth-2012 implementation will be kept as an alternative, in case the smart to is needed for compatibility. Finally, also a non-parsing version of to will be kept, because it may be useful for special cases. The version implemented with perform and without from is the best of all non-parsing versions in every aspect.
Improved header to issue an error when the name is empty.
2015-09-27
Fixed a calculation error in error>ordinal.
Modified ior>error to suite the new error codes:
: ior>error ( ior -- f n )
\ Convert a DOS ior to a Forth error number.
\ ior = the AF register returned by a DOS command:
\ bit 0 = set: error
\ bits 8-14 = error code
\ bit 15 = set: OS error; unset: DOS error
\ f = error?
\ n = error number: 1000..1031: G+DOS error number
\ 1128..1154: OS error number
dup 1 and negate swap \ calculate f
flip %11111111 and \ upper 8 bits of ior
1000 + negate ;
Modified header, now it's smarter and faster: it uses parse-name instead of defined (which executes find-name). This way, the name is searched for only when warnings is on, and only the current vocabulary is searched (with search-wordlist), not the current search order. Did some benchmarking, loading many screens directly by their number: Given the time needed by the old method is always 1.0, the time needed by the new method is 0.86 when warnings is on, and 0.82 when warnings is off.
; ----------------------------------------------
_colon_header header_,'HEADER'
; header ( "name" -- )
if 0 ; XXX OLD
dw defined_ ; ( x 0 | cfa 1 | cfa -1 )
dw abs_,star_,question_dup_ ; ( 0 | cfa cfa )
dw zero_branch_,header.continue
; The word is not unique.
; Note: `warnings` is already checked by `warning`,
; but it has to be done here too, in order to show the
; offending word or not before executing `warning`.
dw warnings_,fetch_
dw zero_branch_,header.no_warning
dw cfa_to_nfa_,id_dot_
_literal error.not_unique
dw warning_
dw zero_ ; for the `drop`, faster and smaller than a branch
header.no_warning:
dw drop_
header.continue:
dw parsed_name_,two_fetch_
dw two_dup_,uppers_ ; XXX TMP
; XXX FIXME -- the problem is `parsed-name` is updated by
; `parse-name`, thus before `find` converted the word to uppercase.
; The solution is to write an alternative to `find`:
; `find-name ( ca len -- 0 | cfa 1 | cfa -1 )`
dw dup_,zero_equals_
_question_error error.zero_length_name
; XXX TODO error if name is too long? (see lina)
dw width_,fetch_,min_
dw tuck_ ; ( len ca len )
_names_bank
dw here_,comma_np_ ; store a pointer to the cfa
dw latest_,comma_np_ ; link field
; Now `np` contains the address of the nfa.
dw np_fetch_
dw place_ ; store the name
dw np_fetch_,current_,fetch_,store_ ; update contents of `latest` in the current vocabulary
dw smudge_ ; set the smudge bit and page the default bank
dw one_plus_,np_,plus_store_ ; update the names pointer with the length+1
dw here_,two_plus_,comma_ ; compile the pfa into code field
dw semicolon_s_
else
; XXX NEW -- smarter and faster
; XXX Note: This version checks wether the word is unique only when
; `warnings` is on, and by searching only `current`.
dw parse_name_ ; ( ca len )
dw dup_,zero_equals_
_question_error error.zero_length_name
dw warnings_,fetch_
dw zero_branch_,header.continue
; `warnings` is on
dw two_dup_,current_,fetch_,search_wordlist_
dw zero_branch_,header.continue
; the word is not unique in `current`
; ( ca len cfa )
dw cfa_to_nfa_,id_dot_
_literal error.not_unique
dw message_ ; XXX TMP -- `warning`?
header.continue:
; ( ca len )
dw two_dup_,uppers_ ; XXX FIXME -- do this modifies the buffer?
; XXX TODO error if name is too long? (see lina)
dw width_,fetch_,min_
dw tuck_ ; ( len ca len )
_names_bank
dw here_,comma_np_ ; store a pointer to the cfa
dw latest_,comma_np_ ; link field
; Now `np` contains the address of the nfa.
dw np_fetch_
dw place_ ; store the name
dw np_fetch_,current_,fetch_,store_ ; update contents of `latest` in the current vocabulary
dw smudge_ ; set the smudge bit and page the default bank
dw one_plus_,np_,plus_store_ ; update the names pointer with the length+1
dw here_,two_plus_,comma_ ; compile the pfa into code field
dw semicolon_s_
endif
Fixed the restoration of the previous screen mode in warm.