Solo Forth development history in 2015-12
Description of the page content
Solo Forth development history in 2015-12.
Tags:
2015-12-04
Moved >order to the kernel.
Started adapting the tape words from Afera.
2015-12-14
Added a new control structured, adapted from Pygmy Forth:
( associative-case: )
\ Credits:
\
\ Code adapted from Pygmy Forth's `case:`
need create:
: associative-case: ( "name" -- )
create:
does> ( n -- ) ( n pfa ) cell+ \ move past `lit`
begin 2dup @ dup 0= >r ( n a n n')
= r> or 0= ( n a f )
while ( n a ) [ 3 cells ] literal + \ no match
repeat nip cell+ perform ;
\ doc{
\ associative-case: ( "name" -- )
\
\ Create an associative case definition "name":
\ `name ( i*x n -- j*x )`.
\ Usage example:
\ ----
\ : red ." red" ;
\ : blue ." blue" ;
\ : orange ." orange" ;
\ : pink ." pink" ;
\ : black ." black" ;
\
\ associative-case: color ( n -- )
\ 7 red 12 blue 472 orange 15 pink 0 black ;
\
\ 7 color cr 472 color cr 3000 color cr
\ ----
\ _n_ for default must be 0 and the default pair must be
\ last. Numbers can be in any order except 0 must be last.
\ An actual zero or a no match causes the default to be
\ executed. Numbers can't be constants.
\ }doc
For clarity, renamed the current case: (adapted from F83) to positional-case:.
Added time and date support, to some extent. No real clock, but only the system frames counter. The date is not updated anyway.
( set-date get-date )
create (date) 1 c, 1 c, 2016 ,
\ day, month, year
: get-date ( -- day month year )
(date) c@
[ (date) 1+ ] literal c@
[ (date) 2+ ] literal @ ;
\ doc{
\
\ get-date ( -- day month year )
\
\ Get the current date. The default date is 2016-01-01. It
\ can be changed with `set-date`. The date is not updated by
\ the system.
\
\ }doc
: set-date ( day month year -- )
[ (date) 2+ ] literal !
[ (date) 1+ ] literal c!
(date) ! ;
\ doc{
\
\ set-date ( day month year -- )
\
\ Set the current date. The default date is 2016-01-01. It
\ can be fetch with `get-date`. The date is not updated by
\ the system.
\
\ }doc
( set-time get-time reset-time )
need frames@ need frames! need m+ need alias need ud*
: get-time ( -- second minute hour )
frames@ 50 um/mod nip s>d ( sec . )
60 um/mod s>d ( sec min . )
60 um/mod ( sec min hour ) ;
\ doc{
\
\ get-time ( -- second minute hour )
\
\ Return the current time.
\
\ The system doesn't have an actual clock. The system frames
\ counter is used instead. It is increased by the interrupts
\ routine every 20th ms. The counter is a 24-bit value, so
\ its maximum is $FFF ticks of 20 ms (5592 minutes, 93
\ hours), then it starts again from zero.
\
\ }doc
: set-time ( second minute hour -- )
3600 um* rot 60 * m+ rot m+ ( seconds )
50. ud* frames! ;
\ doc{
\
\ set-time ( second minute hour -- )
\
\ Set the current time. See `get-time`.
\
\ }doc
' reset-frames alias reset-time ( -- )
\ doc{
\
\ reset-time ( -- )
\
\ Reset the current time to 00:00:00. See `get-time`.
\
\ }doc
( .time .system-time .date .system-date .time&date time&date )
\ XXX TODO document
need get-time need get-date
: .00 ( n -- ) s>d <# # # #> type ;
: .0000 ( n -- ) s>d <# # # # # #> type ;
: .time ( second minute hour -- )
.00 ':' emit .00 ':' emit .00 ;
: .system-time ( -- ) get-time .time ;
: .date ( day month year -- )
.0000 '-' emit .00 '-' emit .00 ;
: .system-date ( -- ) get-date .date ;
: .time&date ( second minute hour day month year -- )
.date 'T' emit .time ;
: time&date ( -- second minute hour day month year )
get-time get-date ;
\ doc{
\
\ time&date ( -- second minute hour day month year )
\
\ Return the current time and date: second (0..59), minute
\ (0..59), hour (0..23), day (1..31), month (1..12) and year
\ (e.g., 2016).
\
\ See: `get-time`, `get-date`, `set-time`, `set-date`.
\
\ Standard: Forth-94 (FACILITY EXT), Forth-201 (FACILITY
\ EXT).
\
\ }doc
2015-12-15
Rewrote under+ in Z80.
Added #spaces:
( #spaces )
need under+
: #spaces ( ca len -- +n )
0 rot rot 0 do count bl = under+ loop drop abs ;
\ Count spaces in a string.
\ Credits:
\ Code improved from:
\ http://forth.sourceforge.net/mirror/comus/index.html
Started implementing a new more versatile method to manage the input buffer, in order to implement evaluate. The new method under development is being written from scratch but inspired by some features of eForth, hForth, Z88 CamelForth and other Forth systems.
2015-12-16
Added some unusual stack operations:
( nup drup dip )
code nup ( x1 x2 -- x1 x1 x2 )
E1 c, D1 c, D5 c, C3 c, pushhlde ,
\ pop hl
\ pop de
\ push de
\ jp pushhlde
end-code
\ Also called `under`.
code drup ( x1 x2 -- x1 x1 )
D1 c, E1 c, E5 c, E5 c, jpnext
\ pop de
\ pop hl
\ push hl
\ push hl
\ jp next
end-code
code dip ( x1 x2 -- x2 x2 )
E1 c, D1 c, E5 c, E5 c, jpnext
\ pop hl
\ pop de
\ push hl
\ push hl
\ jp next
end-code
First working version of the new input buffer method. Everything seems to work fine. evaluate has been implemented by the first time. Also nesting of different sources works, for example evaluating a string that loads a block that evaluates a string...
The first change is source doesn't return tib #tib # anymore but a string saved in a new double variable called input-buffer:
; ----------------------------------------------
_two_variable_header input_buffer_,'INPUT-BUFFER'
; doc{
;
; input-buffer ( -- a )
;
; A double-cell variable that holds the address and length of
; the current input buffer.
;
; }doc
dw 0 ; len
dw 0 ; address
; ----------------------------------------------
_colon_header source_,'SOURCE'
; doc{
;
; source ( -- ca len )
;
; ----
; : source ( -- ca len )
; blk @ ?dup if block b/buf exit then
; input-buffer 2@ ;
; ----
;
; Standard: Forth-94 (CORE), Forth-2012 (CORE).
;
; }doc
dw blk_,fetch_,question_dup_
dw zero_branch_,source.other
; disk block
dw block_,b_slash_buf_,exit_
source.other:
dw input_buffer_,two_fetch_
dw exit_
Next, some new words set the current source:
; ----------------------------------------------
_colon_header set_source_,'SET-SOURCE'
; doc{
;
; set-source ( ca len -- )
;
; Set the memory zone _ca len_ as the current source by pointing
; the input buffer to it.
;
; ----
; : set-source ( ca len -- )
; input-buffer 2! >in off ;
; ----
;
; }doc
dw input_buffer_,two_store_
dw to_in_,off_
dw exit_
; ----------------------------------------------
_colon_header string_to_source_,'STRING>SOURCE'
; doc{
;
; string>source ( ca len -- )
;
; Set the string _ca len_ as the current source.
;
; ----
; : string>source ( ca len -- )
; blk off
; [ ' source-id >body ] literal on
; set-source ;
; ----
; }doc
dw blk_,off_
_literal source_id_pfa
dw on_
dw set_source_
dw exit_
; ----------------------------------------------
_colon_header terminal_to_source_,'TERMINAL>SOURCE'
; doc{
;
; terminal>source ( -- )
;
; Set the terminal as the current source.
;
; ----
; : terminal>source ( -- )
; blk off
; [ ' source-id >body ] literal off
; tib #tib @ set-source ;
; ----
;
; }doc
dw blk_,off_
_literal source_id_pfa
dw off_
dw tib_,number_tib_,fetch_,set_source_
dw exit_
; ----------------------------------------------
_colon_header block_to_source_,'BLOCK>SOURCE'
; doc{
;
; block>source ( +n -- )
;
; Set block _+n_ as the current source.
;
; ----
; : block>source ( +n -- )
; blk ! >in off ;
; ----
;
; }doc
dw blk_,store_,to_in_,off_
dw exit_
Next, two words to nest and unnest sources:
; ----------------------------------------------
_colon_header nest_source_,'NEST-SOURCE',compile_only
; doc{
;
; nest-source ( R: -- source-sys )
;
; _source-sys_ describe the current source specification for
; later use by `unnest-source`.
; ----
; : nest-source ( R: -- source-sys )
; r>
; source 2>r
; source-id >r
; >in @ >r
; blk @ >r
; #tib @ >@
; >r ;
; ----
; }doc
dw from_r_ ; save the return address
dw source_,two_to_r_
dw source_id_,to_r_
dw to_in_,fetch_,to_r_
dw blk_,fetch_,to_r_
dw number_tib_,fetch_,to_r_
dw to_r_ ; restore the return address
dw exit_
; ----------------------------------------------
_colon_header unnest_source_,'UNNEST-SOURCE',compile_only
; doc{
;
; unnest-source ( R: source-sys -- )
;
; Restore the source specification described by _source-sys_.
; ----
; : unnest-source ( R: source-sys -- )
; r>
; r> #tib !
; r> blk !
; r> >in !
; r> [ ' source-id >body ] literal !
; 2r> input-buffer 2!
; >r ;
; ----
; }doc
dw from_r_ ; save the return address
dw from_r_,number_tib_,store_
dw from_r_,blk_,store_
dw from_r_,to_in_,store_
dw from_r_
_literal source_id_pfa
dw store_
dw two_from_r_,input_buffer_,two_store_
dw to_r_ ; restore the return address
dw exit_
Finally, some words must be updated after the new method: quit, query, load, -->, (load). And evaluate can be defined:
: evaluate ( i*x ca len -- j*x )
nest-source string>source interpret unnest-source ;
Factored out the part of (MODE32-EMIT) that prints User Defined Graphics to a new word called emit-udg. No speed penalty when executing emit, but executing emit-udg directly is faster because scroll and character checking are omitted.
2015-12-17
Finished implementing the standard do loop, adapting the code Spectrum Forth-83. A benchmark showed they are even faster than the original fig-Forth version:
( do-bench )
\ 2015-12-17
need bench
32767 0 2constant range
: forth-83-do ( -- ) bench range do83 loop83 marque ;
: forth-79-do ( -- ) bench range do loop marque ;
: forth-83-i ( -- )
bench range do83 i83 drop loop83 marque ;
: forth-79-i ( -- ) bench range do i drop loop marque ;
: forth-83-+loop ( -- )
bench range do83 2 +loop83 marque ;
: forth-79-+loop ( -- ) bench range do 2 +loop marque ;
: do-bench ( -- )
forth-83-do forth-79-do
forth-83-i forth-79-i
forth-83-+loop forth-79-+loop ;
\ Frames by 32767 iterations
\ --------------------------
\ Bench fig-Forth Forth-83
\ -------- --------- --------
\ loop 143 109
\ i 264 258
\ +loop 108 97
\ Note: 1 frame = 50th of second
Beside, the new code is only 83 bytes larger than the old one, and includes ?do.
The few loops already compiled in the kernel had to be adapted: the fig-Forth loops compiled the address of do at loop. The Forth-83 loops do the other way around.
The old code:
; ----------------------------------------------
_code_alias_header unloop_,'UNLOOP',,two_r_drop_
; doc{
;
; unloop ( -- ) ( R: loop-sys -- )
;
; Discard the loop-control parameters for the current nesting
; level. An `unloop` is required for each nesting level before
; the definition may be exited with `exit`. An ambiguous
; condition exists if the loop-control parameters are
; unavailable.
;
; In Solo Forth, the stack effect is:
;
; unloop ( -- ) ( R: n1 n2 -- )
;
; n1 = loop index
; n2 = loop limit
;
; Standard: Forth-94.
;
; }doc
; ----------------------------------------------
_code_header paren_do_,'(DO)'
; Credits:
; Code from CP/M fig-Forth 1.1g.
exx ; 04t 01b
pop de ; 10t 01b
pop bc ; 10t 01b
ld hl,(return_stack_pointer) ; 20t 03b
dec hl ; 06t 01b
ld (hl),b ; 07t 01b
dec hl ; 06t 01b
ld (hl),c ; 07t 01b
dec hl ; 06t 01b
ld (hl),d ; 07t 01b
dec hl ; 06t 01b
ld (hl),e ; 07t 01b
ld (return_stack_pointer),hl ; 16t 03b
exx ; 04t 01b
;116t 18b TOTAL
_jp_next
; ----------------------------------------------
_colon_header plus_loop_,'+LOOP',immediate+compile_only
; doc{
;
; +loop ( n -- )
;
; Add the signed increment _n_ to the loop index using
; the convention for `+`, and compare the total to the limit.
; Return execution to the corresponding `do` until the new index
; is equal to or greater than the limit (n>0), or until the new
; index is less than the limit (n<0). Upon the exiting from
; the loop, discard the loop control parameters, continuing
; execution ahead. Index and limit are signed integers in
; the range {-32,768..32,767}.
;
; Standard: fig-Forth, Forth-79.
;
; }doc
dw compile_,paren_plus_loop_
dw backward_resolve_
dw exit_
; ----------------------------------------------
_colon_header loop_,'LOOP',immediate+compile_only
; XXX TODO documentation
; doc{
;
; loop ( -- )
;
; Increment the `do-loop` index by one, terminating the loop if
; the new index is equal to or greater than the limit.
;
; Standard: fig-Forth, Forth-79.
;
; }doc
dw compile_,paren_loop_
dw backward_resolve_
dw exit_
; ----------------------------------------------
_colon_header do_,'DO',immediate+compile_only
; doc{
;
; do ( n1 n2 -- )
;
; Standard: fig-Forth, Forth-79.
;
; }doc
dw compile_,paren_do_
dw backward_mark_
dw exit_
; ----------------------------------------------
_code_alias_header i_,'I',,r_fetch_
; doc{
;
; i ( -- x ) ( R: loop-sys -- loop-sys )
;
; Return a copy of the current (innermost) loop index.
;
; }doc
; ----------------------------------------------
_code_header exhaust_,'EXHAUST'
; doc{
;
; exhaust ( -- ) ( R: n1 n2 -- n2 n2 )
;
; n1 = loop limit
; n2 = loop index
;
; Force termination of a do-loop at the next opportunity by
; setting the loop limit equal to the current value of the
; index. The index itself remains unchanged, and execution
; proceeds normally until `loop` or `+loop` is encountered.
;
; Note: This is the equivalent of fig-Forth's `leave`.
;
; }doc
; XXX TODO rename to `leave-next`.
ld hl,(return_stack_pointer)
ld e,(hl)
inc hl
ld d,(hl)
inc hl
ld (hl),e
inc hl
ld (hl),d
_jp_next
; ----------------------------------------------
_code_header question_exhaust_,'?EXHAUST'
; doc{
;
; ?exhaust ( f -- ) ( R: n1 n2 -- n1 n2 | n2 n2 )
;
; n1 = loop limit
; n2 = loop index
;
; If _f_ is not false, force termination of a do-loop at the
; next opportunity by setting the loop limit equal to the
; current value of the index. The index itself remains
; unchanged, and execution proceeds normally until `loop` or
; `+loop` is encountered.
;
; }doc
; XXX TODO rename to `?leave-next`.
pop hl
ld a,h
or l
jp nz,exhaust_pfa
_jp_next
; ----------------------------------------------
_code_header paren_plus_loop_,'(+LOOP)'
pop de
jp paren_loop.step_in_de
; ----------------------------------------------
_code_header paren_loop_,'(LOOP)'
; doc{
;
; (loop) ( n -- )
;
; Add the signed increment _n_ to the loop index using
; the convention for `+`, and compare the total to the limit.
; Return execution to the corresponding `do` until the new index
; is equal to or greater than the limit (n>0), or until the new
; index is less than the limit (n<0). Upon the exiting from
; the loop, discard the loop control parameters, continuing
; execution ahead. Index and limit are signed integers in
; the range {-32,768..32,767}.
;
; }doc
; Credits:
;
; This code is from Abersoft Forth. It's the same code used
; in `(+loop)` in fig-Forth 1.1g. The author of Abersoft
; Forth used it to write `(loop)` and wrote `(+loop)` with a
; simple call to it, what saves code.
ld de,0x0001
paren_loop.step_in_de:
ld hl,(return_stack_pointer)
ld a,(hl)
add a,e
ld (hl),a
ld e,a
inc hl
ld a,(hl)
adc a,d
ld (hl),a
inc hl ; (hl) = limit
inc d
dec d
ld d,a ; de = new index
jp m,paren_loop.negative_step
; increment>0
ld a,e
sub (hl)
ld a,d
inc hl
sbc a,(hl)
jp paren_loop.end
paren_loop.negative_step:
; increment<0
ld a,(hl) ; limit-index
sub e
inc hl
ld a,(hl)
sbc a,d ; a<0?
paren_loop.end:
jp m,branch_pfa ; loop again if a<0
; done, discard loop parameters
inc hl
ld (return_stack_pointer),hl
; skip branch offset
inc bc
inc bc
_jp_next
The new code, not fully documented yet:
; ----------------------------------------------
_code_header unloop_,'UNLOOP'
; doc{
;
; unloop ( -- ) ( R: loop-sys -- )
;
; Discard the loop-control parameters for the current nesting
; level. An `unloop` is required for each nesting level before
; the definition may be exited with `exit`. An ambiguous
; condition exists if the loop-control parameters are
; unavailable.
;
; Standard: Forth-94 (CORE), Forth-2012 (CORE).
;
; }doc
ld hl,(return_stack_pointer)
ld de,cell*3
add hl,de
ld (return_stack_pointer),hl
_jp_next
; ----------------------------------------------
_code_header paren_question_do_,'(?DO)'
; Credits:
; Code based on Spectrum Forth-83.
pop hl
pop de
and a
sbc hl,de
jp z,branch_pfa
add hl,de ; reverse the substraction
jp paren_do.de_hl
; ----------------------------------------------
_colon_header question_do_,'?DO',immediate+compile_only
; doc{
;
; ?do ( n1 n2 -- )
;
; Standard: Forth-83, Forth-94, Forth-2012.
;
; ----
; : ?do ( n1 n2 -- )
; postpone (?do) >mark ; immediate compile-only
; ----
;
; }doc
dw compile_,paren_question_do_
dw forward_mark_
dw exit_
_colon_header do_,'DO',immediate+compile_only
; doc{
;
; do ( n1 n2 -- )
;
; Standard: Forth-83, Forth-94, Forth-2012.
;
; ----
; : do ( n1 n2 -- )
; postpone (do) >mark ; immediate compile-only
; ----
;
; }doc
dw compile_,paren_do_
dw forward_mark_
dw exit_
; ----------------------------------------------
_colon_header loop_,'LOOP',immediate+compile_only
; doc{
;
; loop ( -- )
;
; Increment the `do-loop` index by one, terminating the loop if
; the new index is equal to or greater than the limit.
;
; Standard: Forth-83, Forth-94, Forth-2012.
;
; }doc
dw compile_,paren_loop_
dw forward_resolve_
dw exit_
; ----------------------------------------------
_colon_header plus_loop_,'+LOOP',immediate+compile_only
; doc{
;
; loop ( -- )
;
; Increment the `do-loop` index by one, terminating the loop if
; the new index is equal to or greater than the limit.
;
; Standard: Forth-83, Forth-94, Forth-2012.
;
; }doc
dw compile_,paren_plus_loop_
dw forward_resolve_
dw exit_
; ----------------------------------------------
_code_header paren_do_,'(DO)'
; Credits:
; Code from Spectrum Forth-83.
pop hl ; 10t 01b ; init
pop de ; 10t 01b ; limit
paren_do.de_hl:
push hl ; 11t 01b
ld hl,(return_stack_pointer) ; 20t 03b
dec hl ; 06t 01b
ld (hl),d ; 07t 01b
dec hl ; 06t 01b
ld (hl),e ; 07t 01b ; push limit on return stack
inc bc
inc bc ; skip branch address
dec hl ; 06t 01b
ld (hl),b ; 07t 01b
dec hl ; 06t 01b
ld (hl),c ; 07t 01b ; push IP on return stack
ex (sp),hl ; hl=init, (sp)=rp@
and a
sbc hl,de ; hl=init-limit
ld a,h
xor 0x80 ; flip most significant bit
ld d,a
ld e,l
pop hl ; hl=rp@
dec hl
ld (hl),d ; 07t 01b
dec hl ; 06t 01b
ld (hl),e ; 07t 01b ; push (init-limit) xor 0x8000 on return stack
ld (return_stack_pointer),hl ; 16t 03b
;116t 18b TOTAL
_jp_next
; ----------------------------------------------
_code_header i_,'I'
ld hl,(return_stack_pointer)
; Note: `j` and `k`jump here (body of `i` + 3), with updated
; hl.
ld e,(hl)
inc hl
ld d,(hl) ; de= current index, wich is: (index-limit) xor 0x8000
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 0x80 ; flip most significant bit, getting true index value
ld d,a
push de ; result
_jp_next
; ----------------------------------------------
_code_header question_leave_,'?LEAVE'
; doc{
;
; ?leave ( f -- ) ( R: loop-sys -- | loop-sys )
;
; }doc
pop hl
ld a,h
or l
jp nz,leave_pfa
_jp_next
; ----------------------------------------------
_code_header leave_,'LEAVE'
ld hl,(return_stack_pointer)
inc hl
inc hl
ld c,(hl)
inc hl
ld b,(hl) ; bc = start address
inc hl
inc hl
inc hl
ld (return_stack_pointer),hl ; write updated return stack pointer (6 was added)
dec bc
dec bc ; point IP to forward branch address
jp branch_pfa
; ----------------------------------------------
_code_header paren_plus_loop_,'(+LOOP)'
ld hl,(return_stack_pointer)
ld e,(hl)
inc hl
ld d,(hl) ; de = current index
ex (sp),hl ; hl = the increment value
and a
adc hl,de ; add increment to index
; Note: `and a` and `adc` are used because `add` does not affect the po flag
jp po,paren_plus_loop.continue
; If overflow, then boundary between limit-1 and limit is
; crossed, terminate loop.
pop hl ; return stack pointer
ld de,0x0005
add hl,de
ld (return_stack_pointer),hl
; Increment return stack pointer by 5 (1 increment already done)
_jp_next
paren_plus_loop.continue:
ld d,h
ld e,l ; de = updated index
pop hl ; return stack pointer
paren_loop.continue:
ld (hl),d
dec hl
ld (hl),e ; update the index on the return stack
inc hl
inc hl
ld c,(hl)
inc hl
ld b,(hl) ; IP = start address, repeat loop
_jp_next
; ----------------------------------------------
_code_header paren_loop_,'(LOOP)'
ld hl,(return_stack_pointer)
ld e,(hl)
inc hl
ld d,(hl) ; de = index value
inc de ; increment the index
ld a,d
xor 0x80
or e ; index=0x8000?
jp nz,paren_loop.continue
; limit reached
ld de,0x0005
add hl,de ; increment RP by 5 (1 already done)
ld (return_stack_pointer),hl
_jp_next
In the library, j and k needed a little rewriting, because the loops use three cells of the return stack of the return stack, and i must calculate the actual index. i', j' and k' also need a little change.
Added support for semantic versioning. So far the development version was the build time in ISO format. Start of version 0.1.0.
2015-12-18
Fixed udg! and .s for the same reason: with a negative number the Forth-83 +loop doesn't work the same way than the fig-Forth version.
Benchmarked emit-udg: 0.97 the execution time of emit.
2015-12-19
Moved break-key? to the kernel, else it could not be used by located. Converted it to a deferred word with its default behaviour default-break-key?, so it can be deactivated or customized.
Moved set-order to the kernel, and added a copy to the root vocabulary, the minimum search order, after standard Forth.
Added find-name-in to the library, simply : find-name-in ( ca len wid -- nfa | 0 ) @ find-name-from ;
2015-12-20
Made set-order standard; so far parameter zero was not recognized.
; ----------------------------------------------
_colon_header set_order_,'SET-ORDER'
; doc{
;
; set-order ( -1 | 0 | widn..wid1 n -- )
;
; Set the search order to the word lists identified by
; _widn..wid1_. Subsequently, word list _wid1_ will be
; searched first, and word list _widn_ searched last. If _n_
; is zero, empty the search order. If _n_ is minus one, set
; the search order to the implementation-defined minimum
; search order.
;
; Standard: Forth-94 (SEARCH), Forth-2012 (SEARCH).
;
; }doc
; ----
; : set-order ( -1 | 0 | widn..wid1 n -- )
; dup -1 = if drop only exit then -order
; ?dup if (set-order) else -order then ;
; ----
if 0 ; XXX OLD -- 14 cells
dw dup_
_literal -1
dw equals_
dw zero_branch_,set_order.do_set_order
dw drop_,only_,exit_
set_order.do_set_order
dw question_dup_
dw zero_branch_,minus_order_pfa
dw paren_set_order_
dw exit_
endif
; XXX NEW -- 12 cells
dw question_dup_
dw zero_branch_,minus_order_pfa ; 0
dw dup_
_literal -1
dw equals_
dw zero_branch_,paren_set_order_pfa ; <>-1
dw drop_,only_ ; -1
dw exit_
Changed the notation in the sources: _xt_, _xtp_ and _nt_ instead of _cfa_, _cfap_ and _nfa_.
First changes to implement DTC as an alternative. Adapted all header macros with conditional compilation.
| Word type | Number | Bytes |
|---|---|---|
| code | 145 | -290 |
| colon | 248 | +248 |
| variable | 42 | +42 |
| user variable | 20 | +20 |
| constant | 38 | +38 |
| deferred | 12 | -36 |
| TOTAL | +22 |
Wrote >defer ( xt -- a ), a common factor of defer! and defer@, which must be diferent for DCT and ITC.
Wrote the standard word find, just in case in could be useful for old programs.
: find ( ca -- ca 0 | xt 1 | xt -1 )
dup count find-name dup
if nip name>immediate? 1 or negate then ;
2015-12-21
Added more random number generators and wrote a benchmark to compare them all.
Benchmarked three versions of ud/mod (one shared by fig-Forth and Gforth, and two variants from Z88 CamelForth). The modified version from Z88 CamelForth is the winner, but the speed difference is almost unremarkable, only two bytes are saved, and the code needs -rot to be moved to the kernel. The fig-Forth version is kept, until -rot is needed by more words.
Added polarity:
( polarity )
\ Credits:
\
\ Code adapted from Z88 CamelForth.
code polarity ( n -- -1 | 0 | 1 )
D1 c, 78 02 + c, B0 03 + c, CA c, ' false >body ,
\ pop de
\ ld a,d
\ or e
\ jp z,false_pfa
CB c, 10 03 + c, ED c, 62 c,
\ rl d ; set carry if DE -ve
\ sbc hl,hl ; HL=0 if DE +ve, or -1 if DE -ve
78 05 + c, F6 c, 01 c, 68 07 + c, C3 c, pushhl ,
\ ld a,l
\ or 1
\ ld l,a ; HL=1 or -1
\ jp push_hl
end-code
Removed some old unused words from the kernel, already commented out: the original fig-Forth ;s and its correspondent versions of exit and ?exit.
Added two new control structures:
( 0exit -exit )
code 0exit ( f -- ) ( R: nest-sys | -- nest-sys | )
E1 c, \ pop hl
78 04 + c, \ ld a,h
B0 05 + c, \ or l
CA c, ' exit >body , \ jp z,exit_pfa
jpnext \ jp next
end-code
\ doc{
\
\ 0exit ( f -- ) ( R: nest-sys | -- nest-sys | )
\
\ If _f_ is zero, return control to the calling definition,
\ specified by _nest-sys_.
\
\ `0exit` is not intended to be used within a do-loop. Use
\ `if unloop exit then` instead.
\
\ In Solo Forth `0exit` can be used in interpretation mode to
\ stop the interpretation of a block.
\
\ }doc
code -exit ( n -- ) ( R: nest-sys | -- nest-sys | )
E1 c, \ pop hl
CB c, 7C c, \ bit 7,h ; negative?
C2 c, ' exit >body , \ jp nz,exit_pfa
jpnext \ jp next
end-code
\ doc{
\
\ -exit ( n -- ) ( R: nest-sys | -- nest-sys | )
\
\ If _n_ is negative, return control to the calling definition,
\ specified by _nest-sys_.
\
\ `-exit` is not intended to be used within a do-loop. Use
\ `0< if unloop exit then` instead.
\
\ In Solo Forth `-exit` can be used in interpretation mode to
\ stop the interpretation of a block.
\
\ }doc
Added ?do to the words that required it. They were already marked. So far they used an if wrapper.
Fixed decode-special (part of the decode tool) after the Forth-83 version of do loop: now the branch address is after do or ?do; also added -branch to it, in case it is already defined during the compilation of decode-special.
2015-12-22
Substituted the d* with an alternative definition, from DX-Forth, which is slighty faster.
Added pixels, needed to finish the random number generator benchmark:
( pixels )
\ Credits:
\ Original code 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 pixels ( -- u )
\ Return the number of pixels set on the screen.
exx
4000 hl ldp# l b ld l c ld
begin \ byte
08 d ld#
begin \ bit
m rrc cy if bc incp then d dec
z until
hl incp h a ld 58 cp#
z until
bc push
exx
jpnext
end-code
Factored 0.r and 0d.r to print numbers without a trailing blank.
- Added
m*/, using the code of Gforth.
Wrote % and u% to calculate percentages:
( % u% )
: % ( n1 n2 -- n3 ) 100 swap */ ;
\ _n1_ is percentage _n3_ of _n2_
: u% ( u1 u2 -- u3 ) >r 100 um* r> um/mod nip ;
\ _u1_ is percentage _u3_ of _u2_
First version of the random number generator benchmark:
( rng-bench )
\ Random number generator benchmark
need set-pixel need bench{ need pixels need u%
256 192 * constant #pixels
\ number of pixels of the screen
defer rng ( n -- 0..n-1 )
: pixels%. ( u -- ) #pixels u% 0.r ." %" ;
\ Print _u_ pixels as a percentage.
: pixels. ( u -- )
dup u. ." pixels (" %pixels ." )" ;
\ Print _u_ as the number of pixels.
: rng-bench ( ca len xt -- )
['] rng defer! cls bench{
#pixels 0 do 256 rng 193 rng set-pixel loop frames@ 2>r
pixels >r ." Code: " type cr r> pixels. cr 2r> bench.
key drop ;
\ Do the RNG benchmark using _xt_;
\ print title _ca len_ before the results.
Renamed and factored the words used to make benchmarks. Now they are more versatile.
( bench{ }bench }bench. bench. )
\ Code adapted from:
\ Forth Dimensions Volume XVII number 4 page 11.
\ System-dependent timing routines.
need reset-frames need frames@
: bench{ ( -- ) reset-frames ;
\ start timing
: }bench ( -- d ) frames@ ;
\ stop timing
: bench. ( d -- )
2dup d. ." frames (" 50 m/ nip . ." s) " cr ;
\ print the result _d_
: }bench. ( -- ) }bench bench. ;
\ stop timing and print the result
Rewrote 3dup in Z80 and extracted it from the assembler.
( 3dup )
code 3dup ( x1 x2 x3 -- x1 x2 x3 x1 x2 x3 )
D9 c,
\ exx
C1 c, D1 c, E1 c,
\ pop bc
\ pop de
\ pop hl
E5 c, D5 c, C5 c,
\ push hl
\ push de
\ push bc
E5 c, D5 c, C5 c,
\ push hl
\ push de
\ push bc
D9 c,
\ exx
jpnext end-code
exit \ slow and smaller version:
: 3dup ( x1 x2 x3 -- x1 x2 x3 x1 x2 x3 ) dup 2over rot ;
Some new double-cell operators:
( dxor dor dand )
\ Credits:
\
\ Code written by Everett F. Carter, published on Forth
\ Dimensions (volume 16, number 2, page 17, 1994-08).
need -rot
[unneeded] dxor
?\ : dxor ( d1 d2 -- d3 ) rot xor -rot xor swap ;
[unneeded] dor
?\ : dor ( d1 d2 -- d3 ) rot or -rot or swap ;
[unneeded] dand
?\ : dand ( d1 d2 -- d3 ) rot and -rot and swap ;
New double benchmark for random number generators: the second benchmark counts the cycles until no pixel has changed.
( rng-benchmark )
\ Random number generator benchmark
need set-pixel need bench{ need pixels need u% need 3dup
256 192 * constant #pixels
\ number of pixels of the screen
defer rng ( n -- 0..n-1 )
: pixels%. ( u -- ) #pixels u% 0.r ." %" ;
\ Print _u_ pixels as a percentage of the maximum
\ number of pixels.
: .pixels ( u -- ) dup u. ." pixels (" pixels%. ." )" ;
\ Print _u_ as the number of pixels.
: .origin ( ca len -- ) ." Code: " type ;
: fill-screen ( -- )
#pixels 0 do 256 rng 193 rng set-pixel loop ;
\ Fill the screen with random pixels.
: (rng-benchmark) ( -- d ) bench{ fill-screen }bench ;
\ Do the current RNG benchmark and return its result.
: .result ( ca len d -- )
2>r pixels >r .origin cr r> .pixels cr 2r> bench. ;
\ Calculate and print the result of the benchmark.
\ _d_ is the time in frames; _ca len_ is the title.
: init-rng ( xt -- ) ['] rng defer! page ;
: wait ( -- ) key drop ;
-->
( rng-benchmark )
: rng-benchmark1 ( ca len xt -- )
init-rng (rng-benchmark) .result wait ;
\ Do the RNG basic benchmark for _xt_ with title _ca len_:
\ one single cycle of 49152 random pixels.
variable cycles
: .cycles ( -- )
cycles ? s" cycles" cycles @ 1 = + type ;
\ Print the number of cycles.
: signal ( -- ) cycles @ %111 and border ;
\ Change the border color according to the current count
\ of cycles, just to show that the benchmark is running.
: rng-benchmark+ ( ca len xt -- )
init-rng -1 cycles ! bench{
0 begin signal 1 cycles +!
fill-screen pixels tuck = until drop
}bench 0 border .result .cycles wait ;
\ Do the RNG extended benchmark for _xt_ with title _ca len_:
\ as many cycles of 49152 random pixels as required, until
\ the number of pixels doesn't change.
: rng-benchmark ( ca len xt -- )
3dup rng-benchmark1 rng-benchmark+ ;
\ Do the RNG basic and extended benchmarks for _xt_ with
\ title _ca len_:
( every-random )
need rng-benchmark need +thru
1 11 +thru
ace-rng-benchmark
dx-rng-benchmark
g-rng-benchmark
jer-rng-benchmark
jml-rng-benchmark
lb-rng-benchmark
lina-rng-benchmark
sf83-rng-benchmark
tt-rng-benchmark
v-rng-benchmark
2015-12-23
Fixed du/mod, by Wil Baden, published on Forth Dimensions (volume 19, number 6, page 34, 1998-04). One code line was missing:
: du/mod ( ud1 ud2 -- ud3 ud4 )
?dup 0= if
\ there is a leading zero "digit" in divisor
>r 0 r@ um/mod r> swap >r um/mod 0 swap r> exit
then
normalize-divisor dup >r rot rot 2>r
1 swap lshift tum*
\ normalize divisor and dividend
dup r@ = if -1 else 2dup r@ um/mod nip then
\ guess leading "digit" of quotient
2r@ rot dup >r tum* t-
\ multiply divisor by trial quot and substract from
\ dividend
dup 0< if r> 1- 2r@ rot >r 0 t+
\ if negative, decrement quot and add to dividend
dup 0< if r> 1- 2r@ rot >r 0 t+ then
\ if still negative, do it one more time
then
r> 2r> 2drop 1 r> rot >r lshift tum/ r> 0 ;
\ undo nurmalization of dividend to get remainder
\ Double unsigned divide with remainder. Given a dividend
\ _ud1_ and a divisor _ud2_, return remainder _ud3_ and
\ quotient _ud4_.
New version of synonym, without create does>:
( synonym )
need alias
: synonym ( "newname" "oldname" -- )
parse-name nextname ' dup >r alias
r> >name dup immediate? if immediate then
compile-only? if compile-only then ;
exit
\ XXX OLD -- first version
\ XXX FIXME -- `' newname` would not work fine
\ Credits:
\
\ This code of `synonym` is adapted from the example provided
\ in the Forth-2012 documentation, and improved with
\ `compile-only?`.
: synonym ( "newname" "oldname" -- )
create immediate
hide ' , reveal
does> ( -- )
( pfa ) @ ( xt ) dup >name dup ( xt nt nt )
compile-only? executing? and -14 ?throw
immediate? executing? or
if execute else compile, then ;
Compiled all system variables into one block, and changed their prefix "sys-" to "os-", also for seed. Formerly their definitions where scattered and repeated, with conditional compilation.
( os-chars os-chans os-seed os-frames os-udg )
[unneeded] os-chars ?\ 23606 constant os-chars
\ address of the font (characters 32..127)
[unneeded] os-chans ?\ 23631 constant os-chans
\ address of the channels
[unneeded] os-seed ?\ 23670 constant os-seed
\ seed of the random number generator
[unneeded] os-frames ?\ 23672 constant os-frames
\ 24-bit counter of frames (1 frame = 20 ms)
[unneeded] os-udg ?\ 23675 constant os-udg
\ address of the User Defined Graphics (characters 128..255)
Factored save-mode from bye, and restore-mode from warm.
Worked on the tape support.
Fixed some bugs that made the DTC version crash: in macro _defer_header and words .version and noop. Also made execute and defer faster and smaller with DTC. Finally, the DTC version boots, but there are more bugs: it doesn't recognize words. But there's a suprise: The DTC version saves 35 bytes more than expected; the reasen is the deferred definitions were not included in the draft calculations.
Factored finish-code from ; to be reused in ;code.
2015-12-24
Fixed header,: so far it created a default code field specific for ITC. Modified : and create accordingly: now they create their own DTC code fields, with the new word code-field,. DTC works: The kernel can be assembled with ITC or DTC just changing a directive.
Did some benchmarks, already adapted from Forth Dimensions volume 17, number 4, page 11 (1995-11). The execution times of DTC are 80-90% of ITC.
\ BYTE Magazine Benchmark
\
\ Times Frames (1 frame = 50th of second)
\ ----- -----------------------------------
\ ITC DTC
\ ----- -----
\ 00010 6397 5216
\ 00100 63970 (1.00) 52159 (0.81)
\ Interface Age Benchmark
\
\ Times Frames (1 frame = 50th of second)
\ ----- -----------------------------------
\ ITC DTC
\ ------------ ------------
\ 05000 80091 (1.00) 72445 (0.90)
\ Vector Loop Benchmarks
\
\ Benchmark Frames (1 frame = 50th of second)
\ --------- -----------------------------------
\ ITC DTC
\ ------ -------------
\ Vector noop 10919 (1.0) 9033 (0.82)
\ Vector + 58650 (1.0) 47462 (0.80)
\ Vector * 107770 (1.0) 91611 (0.85)
\ Vector / 149002 (1.0) 127495 (0.85)
\ Vector */ 178854 (1.0) 154480 (0.86)
The used memory didn't change significantly: After executing cold, DTC has 32625 bytes free, and ITC has 32598. After compiling all three benchmarks, the amounts are 17255 and 17275 respectively.
2015-12-25
Started an alternative version of the assembler, with a modified syntax.
Finished an improved combined version of the RNG benchmark. It shows the execution time of one cycle, plus the number of cycles. An additional simpler variant is provided, to show the result of the first cycle:
( rng-benchmark )
\ Random number generator benchmark
need set-pixel need bench{ need pixels need u% need 3dup
256 192 * constant #pixels
\ number of pixels of the screen
defer rng ( n -- 0..n-1 )
: pixels%. ( u -- ) #pixels u% 0.r ." %" ;
\ Print _u_ pixels as a percentage of the maximum
\ number of pixels.
: .pixels ( u -- ) dup u. ." pixels (" pixels%. ." )" ;
\ Print _u_ as the number of pixels.
: .title ( ca len -- ) ." Code: " type ;
variable cycles
defer .cycles ( -- )
: (.cycles) ( -- )
cycles ? s" cycles" cycles @ 1 = + type ;
\ Print the number of cycles.
: .time ( d -- ) bench. ." per cycle" cr ;
: .result ( ca len d -- )
2>r pixels >r .title cr r> .pixels cr
2r> .time .cycles ;
\ Calculate and print the result of the benchmark.
\ _d_ is the time in frames; _ca len_ is the title.
-->
( rng-benchmark )
: fill-screen ( -- )
#pixels 0 do 256 rng 193 rng set-pixel loop ;
\ Fill the screen with random pixels.
: signal ( -- ) cycles @ %111 and border ;
\ Change the border color according to the current count
\ of cycles, just to show that the benchmark is running.
: (rng-benchmark) ( -- d )
1 cycles +! signal bench{ fill-screen }bench ;
\ Do the RNG benchmark of ony cycle and return its result.
: wait ( -- ) key drop ;
: finish ( ca len d -- ) 0 border .result wait ;
\ Finish the benchmark.
\ _d_ is the time in frames; _ca len_ is the title.
: init ( xt1 xt2 -- )
['] .cycles defer! ['] rng defer! page -1 cycles ! ;
defer finish? ( i*x -- j*x f )
\ Finish the benchmark?
: new-pixels? ( n1 -- n2 f ) pixels tuck = ;
\ Are there new pixels on the screen, comparing the previous
\ count _n1_ with the new count _n2_?
' new-pixels? ' finish? defer!
-->
( rng-benchmark )
defer rng-benchmark ( ca len xt -- )
\ Do a RNG benchmark for the `random` word _xt_ with title
\ _ca len_.
: rng-benchmark2 ( ca len xt -- )
['] (.cycles) init
0 begin (rng-benchmark) 2>r
finish? dup 0= if 2rdrop then
until drop 2r> finish ;
\ Do a double RNG benchmark for the `random` word _xt_ with
\ title _ca len_: The time required to complete one cycle
\ (49152 random pixels), plus the number of cycles required
\ until the number of pixels doesn't change.
\ The best `random` words need several cycles. In such cases
\ it's useful a simpler test to show only the pixels set at
\ the end of the first cycle:
: (.cycle) ( -- ) ." First cycle only" ;
: rng-benchmark1 ( ca len xt -- )
['] (.cycle) init
(rng-benchmark) .result wait ;
\ Do a one-cycle RNG benchmark for `random` word _xt_ with
\ title _ca len_: Only the time required to complete one
\ cycle (49152 random pixels).
' rng-benchmark2 ' rng-benchmark defer! \ default
2015-12-26
New version of alias, adapted to DTC:
( deferred? alias )
\ XXX NEW -- DTC
: deferred? ( xt -- wf ) c@ $C3 = ;
\ Is _xt_ a deferred word?
\ The code of a deferred word starts with a Z80 jump ($C3)
\ to the word it's associated.
: alias ( xt "name" -- )
dup deferred? if 1+ @ then defer latest name> defer! ;
\ doc{
\
\ alias ( xt "name" -- )
\
\ Create an alias _name_ that will execute _xt_.
\
\ If _xt_ is a deferred word, the alias will point to the
\ word it's associated to.
\
\ }doc
( code? code-alias? defer-alias code-alias alias )
\ XXX OLD -- ITC
: code? ( xt -- wf ) dup >body swap @ = ;
\ Is _xt_ a word created by `code`?
: code-alias? ( xt -- wf ) @ dup body> @ = ;
\ Is _xt_ a word created by `code-alias` or `code`?
: defer-alias ( xt "name" -- )
defer latest name> defer! ;
\ Create a deferred word _name_ that executes _xt_.
: code-alias ( xt "name" -- )
@ header reveal latest name> ! ;
\ Create a code word that executes the code pointed by _xt_.
: alias ( xt "name" -- )
dup code-alias? if code-alias exit then defer-alias ;
\ doc{
\
\ alias ( xt "name" -- )
\
\ Create an alias _name_ that will execute _xt_. If _xt_
\ is a primitive word, the address hold in _name_'s own xt
\ will be the same than the address hold in _xt_. Otherwise
\ _name_ will be a deferred word executing _xt_.
\
\ }doc
Checked and fixed some scroll and clear screen words written in assembler.
Wrote >code. Some assembly words in the library calculated jump points using >body, but it doesn't work with DTC. For the same reason, an additional label with the "_code" prefix is created for code words in the kernel; it's the same address of the body, but the code is clearer. All this is temporary, until the ITC option will be removed from the kernel.
; ----------------------------------------------
if 0 ; ITC
_code_alias_header to_code_,'>CODE',,two_plus_
else ; DTC
_code_alias_header to_code_,'>CODE',immediate,noop_
endif
; doc{
;
; >code ( xt -- a )
;
; Convert _xt_ of a primitive word to the actual address where
; the Z80 code is.
;
; This word is an abstraction: On ITC Solo Forth, `>code` is
; equivalent to `>body`; on DTC, it does nothing.
;
; }doc
Started a better implementation of wordlist and vocabulary, after eForth. The current implementation does not allow to associate wordlists to names.
2015-12-29
Added a second sqrt:
( sqrt )
\ Integer square root by Newton's method
\ Credits:
\
\ Adapted from Sinclair QL's Computer One Forth.
: sqrt ( n1 -- n2 )
dup 0< -24 ?throw \ invalid numeric argument
dup
if dup 2/ 20 0
do 2dup / + 2/
loop swap drop
then ;