Solo Forth development history in 2015-11
Description of the page content
Solo Forth development history in 2015-11.
Tags:
2015-11-01
Wrote a double-number version of the for loop.
( dfor dstep di )
: (dstep) ( R: x ud -- x ud' )
\ doc{
\
\ (dstep) ( R: x ud -- x ud' | x )
\
\ The run-time procedure compiled by `dstep`.
\
\ If the loop index _ud_ is zero, discard it and continue
\ execution after the loop. Otherwise decrement the loop
\ index and continue execution at the beginning of the loop.
\
\ }doc
r> \ save the return address
2r> 2dup or \ is the index zero?
if -1. d+ 2>r
\ decrement the index
else 2drop [ 2 cells ] literal +
\ discard the index and skip the branch offset
then >r ;
\ restore the return address
: dfor ( ud -- ) postpone 2>r <mark ; immediate compile-only
\ doc{
\
\ dfor
\
\ Compilation: ( R: -- dest )
\ Run-time: ( ud -- )
\
\ Start of a `dfor dstep` loop, that will iterate _ud+1_
\ times, starting with _du_ and ending with 0.
\
\ The current value of the index can be retrieved with `di`.
\
\ }doc
: dstep ( -- )
postpone (dstep) postpone branch <resolve
; immediate compile-only
\ doc{
\
\ dstep
\
\ Compilation: ( dest -- )
\
\ Append the run-time semantics given below to the current
\ definition. Resolve the destination of `dfor`.
\
\ Run-time: ( R: ud -- ud' )
\
\ If the loop index is zero, discard the loop parameters and
\ continue execution after the loop. Otherwise decrement the
\ loop index and continue execution at the beginning of the
\ loop.
\
\ }doc
: di ( -- ud ) ( R: x ud -- x ud )
r> 2r@ rot >r ;
\ doc{
\
\ di ( -- ud ) ( R: x ud -- x ud )
\
\ Return the current index _ud_ of a `dfor` loop.
\
\ }doc
Finished two versions of rshift; and added a new version of lshift, adapted from Z88 CamelForth. Then benchmarked them all.
( lshift )
need z80-asm
\ Credits:
\ Code adapted from Z88 CamelForth.
\ 16 bytes used
code lshift ( x1 u -- x2 )
exx
bc pop \ C = loop counter
c b ld
hl pop \ hi 8 bits ignored!
b inc ahead 0 unresolved !
begin hl addp 0 unresolved @ >relresolve step
hl push
exx
jpnext
end-code
( lshift )
\ Credits:
\ Code adapted from DZX-Forth.
\ This version is smaller (13 bytes used) but slower (169%
\ the execution time of the version adapted from Z88 CamelForth).
code lshift ( x1 u -- x2 )
D1 c, \ pop de
E1 c, \ pop hl
1C c, \ inc e
here \ begin:
1D c, \ dec e
CA c, pushhl , \ jp z,push_hl
29 c, \ add hl,hl
C3 c, , \ jp begin
end-code
( rshift )
need z80-asm
\ Credits:
\ Code adapted from Z88 CamelForth.
\ 19 bytes used
code rshift ( x1 u -- x2 )
exx
bc pop \ C = loop counter
c b ld
hl pop \ hi 8 bits ignored!
b inc ahead 0 unresolved !
begin h srl l rr 0 unresolved @ >relresolve step
hl push
exx
jpnext
end-code
( rshift )
\ Credits:
\ Code adapted from DZX-Forth.
\ This version is smaller (16 bytes used) but slower (133%
\ the execution time of the version adapted from Z88 CamelForth).
code rshift ( x1 u -- x2 )
D1 c, \ pop de
E1 c, \ pop hl
1C c, \ inc e
here \ begin:
1D c, \ dec e
CA c, pushhl , \ jp z,push_hl
CB c, 3C c, \ srl h
CB c, 1D c, \ rr l
C3 c, , \ jp begin
end-code
A simple benchmark showed the versions adapted from Z88 CamelForth are much faster:
( rshift-bench lshift-bench )
need frames@ need frames0
: rshift-bench ( n -- )
frames0 0
do 128 255 rshift drop loop
frames@ cr d. ;
: lshift-bench ( n -- )
frames0 0
do 128 255 lshift drop loop
frames@ cr d. ;
\ Times Frames (1 frame = 50th of second)
\ ----- -----------------------------------
\ rshift lshift
\ -------------- --------------
\ Z88 DZX % Z88 DZX %
\ ---- ---- ---- ---- ---- ----
\ 10000 1203 1609 133% 1016 1723 169%
\ 30000 3607 4826 133% 3048 5170 169%
\ Z88 = code adapted from Z88 CamelForth
\ DZX = code adapted from DZX-Forth
2015-11-02
Started implementing a standard 1024-byte disk buffer, instead of the current 512-byte one. Both systems will be used, with conditional compilation, until benchmarked and tested.
The current blk holds the sequential number of a 512-byte disk sector (0..1600 in G+DOS) and two such sectors form an actual Forth block or screen; but with the new standard method blk will hold the number of a 1024-byte Forth disk block (0..800 in G+DOS). Some calculations must be modified or moved.
Renamed b/scr to rec/blk and created b/rec, both after F83. Renamed scr/disk to blk/disk.
Fixed free-buffer.
2015-11-03
Finished the implementation of a 1024-byte disk buffer.
2015-11-04
Did some benchmarks: the new 1024-byte buffer is slower: locate needs 136% the original time; compiling from disk blocks needs 115% the original time. The new buffer is 512 bytes bigger, but the used space is 436 bytes, because the code required by a 1024-byte buffer is simpler and several words and calculations can be removed. An speed improvement may achieved by unfactoring some useful words (for example, the word that transfer one disk sector), but it's not a good idea.
( dummy-needed )
( buffer-benchmark-1 )
2 load need frames0
frames0
need dummy-needed need dummy-needed need dummy-needed
need dummy-needed need dummy-needed need dummy-needed
need dummy-needed need dummy-needed need dummy-needed
need dummy-needed need dummy-needed need dummy-needed
need dummy-needed need dummy-needed need dummy-needed
need dummy-needed
frames@ cr .( Frames ) d. cr
\ Benchmark: Locate and load 16 times empty screen #457.
\ Frames (1 frame = 50th of second)
\ -----------------------------------
\ 512-byte buffer 1024-byte buffer
\ ---------------- ----------------
\ 6323 8621 (136%)
( buffer-benchmark-2 )
2 load need frames0 warnings off frames0
need list need dump need wdump need decode
need life need hanoi need tt need siderator need pong
need doer need a! need defer need value need editor
need case need times need dtimes need for
frames@ cr .( Frames ) d. cr
\ 512-byte buffer 1024-byte buffer
\ ---------------- ----------------
\ Frames 20960 24310 (115%)
\ Bytes free 33242 32777 (-465)
\ 1 frame = 50th of second
Many things are simpler with a 1024-byte buffer. For example, copy is part of a classic line editor:
\ XXX OLD -- version for 512-byte buffer
: copy ( n1 n2 -- )
rec/blk * swap rec/blk * rec/blk over + swap
do
dup i block cell- ! 1+ update
loop drop flush ;
\ Copy screen _n1_ to screen _n2_.
\ XXX NEW -- version for 1024-byte buffer
: copy ( n1 n2 -- )
swap block cell- ! update save-buffers ;
\ Copy screen _n1_ to screen _n2_.
Finally, removed the code required to use a 512-byte buffer and made some optimizations. Now the result of buffer benchmark 2 is slightly better: 23862 frames (112% the speed of a 512-byte buffer).
Removed read-buffer and write-buffer, which were an unuseful layer above read-block and write-block. Converted buffer-data to a constant (it was a run-time simple calculation).
Removed the old unused versions of +D, already commented out: from Abersoft Forth and Z80 fig-Forth 1.1g (which had a bug). The version from Z88 CamelForth is faster and smaller.
2015-11-05
Fixed header: the name is not converted to uppercase in the input buffer anymore, but after being moved to the name field.
Added the benchmarks from Forth Dimensions Volume XVII number 4 page 11.
2015-11-06
Renamed unless to -if; wrote -while and -until:
( -if -while -until )
\ Equivalent to `0= if`, but faster.
: -if ( f -- )
postpone ?branch >mark 2 ; immediate compile-only
\ XXX TODO Alternative for when compiler security is removed:
\ : unless ( f -- )
\ postpone ?branch >mark ; immediate compile-only
: -while ( f -- )
postpone -if 2+ ; immediate compile-only
\ XXX TODO Alternative for when compiler security is removed:
\ : -while ( f -- )
\ postpone -if ; immediate compile-only
: -until ( f -- )
1 ?pairs postpone ?branch <resolve ; immediate compile-only
\ XXX TODO Alternative for when compiler security is removed:
\ : -until ( f -- )
\ postpone ?branch <resolve ; immediate compile-only
2015-11-07
Added retry to the library. It does an unconditional branch to the start of the word.
( retry )
\ Credits:
\ Code of `retry` from an article by Richard Astle in
\ Forth Dimensions 17/4 p. 36 (1995-11).
: retry ( -- )
latest name> >body 1 postpone again
; immediate compile-only
\ XXX TODO -- remove `1` when compiler security is disabled
: ?retry ( run-time: f -- )
postpone if postpone retry postpone then
; immediate compile-only
2015-11-08
Added d*, by Wil Baden:
( d* )
\ Credits:
\ Code by Wil Baden, published on Forth Dimensions
\ (volume 19, number 6, page 33, 1998-04).
: d* ( d1 d2 -- d3 )
>r swap >r ( d1lo d2lo ) ( R: d2hi d1hi )
2dup um* 2swap ( d1lo*d2lo d1lo d2lo )
r> * swap r> * + + ; ( d1*d2 ) ( R: )
Added also du/mod, by the same author and from the same number of Forth Dimensions; but it depends on d2*, not defined yet.
Reorganized the library sections that contained code related to double numbers.
2015-11-09
Adapted module: from Galope:
( begin-module: begin-module public private end-module )
\ Credits:
\ Code adapted and modified from Galope.
need get-order need get-current need wordlist need >order
need set-current
\ Inner words
get-order get-current
wordlist dup set-current >order
variable current-wid variable module-wid
: (module) ( -- wid )
get-current current-wid !
wordlist dup module-wid ! dup >order ;
set-current
\ Interface words
: public ( -- ) current-wid @ set-current ;
\ Public definitions follow.
: private ( -- ) module-wid @ set-current ;
\ Private definitions follow.
: begin-module: ( "name" -- ) (module) constant private ;
\ Start a named module.
\ Private definitions follow.
: begin-module ( -- ) (module) drop private ;
\ Start an anonymous module.
\ Private definitions follow.
: end-module ( -- ) public previous ;
\ End a module.
set-order
\ Description and usage.
\ Modules hide the internal implementation and leave visible the
\ words of the outer interface. Example:
\ begin-module: my_module
\ \ Inner/helper words.
\ public
\ \ Interface words,
\ \ compiled in the outer vocabulary,
\ \ thus seen from the extern.
\ private
\ \ Inner/helper words again.
\ public
\ \ Interface words again. And so on.
\ end-module
\ As an alternative, the word 'begin-module' starts an unnamed module.
Wrote swapped, based on code found on Forth Dimensions:
( swapped )
\ Credits:
\ Adapted from code written by Sam Suan Chen, published
\ on Forth Dimensions (volume 6, number 6, page 9, 1985-03).
: swapped ( i*x n1 n2 -- j*x )
>r 1+ cells sp@ + ( i*x a1 ) ( R: n2 )
r> 2+ cells sp@ + ( i*x a1 a2 )
over @ over @ ( i*x a1 a2 x1 x2 )
>r swap ! r> swap ! ;
\ Usage example:
\
\ ( 1 2 3 4 5 ) 1 4 swapped ( 4 2 3 1 5 )
\ Original code by Sam Suan Chen,
\ with an equivalent usage example:
\ : xyswap ( i*x n -- j*x )
\ 16 /mod >r dup + sp@ + sp@ r> dup + +
\ over @ over @
\ >r swap ! r> swap ! ;
\
\ ( 1 2 3 4 5 ) $25 xyswap ( 4 2 3 1 5 )
Benchmarked the current d* and an alternative definition that happened to be bigger and slower:
( d* )
\ Credits:
\ Code by Wil Baden, published on Forth Dimensions
\ (volume 19, number 6, page 33, 1998-04).
\ This implementation uses 30 bytes.
: d* ( d1 d2 -- d3 )
>r swap >r ( d1lo d2lo ) ( R: d2hi d1hi )
2dup um* 2swap ( d1lo*d2lo d1lo d2lo )
r> * swap r> * + + ; ( d1*d2 ) ( R: )
\ Alternative implementation.
\
\ Credits:
\ Adapted from code written by Robert L. Smith,
\ published on Forth Dimensions (volume 4, number 1, page 3).
\
\ This implementation uses 36 bytes and is 5% slower.
\
\ : d* ( d1 d2 -- d3 )
\ over 4 pick um* 5 roll 3 roll * + 2swap * + ;
Wrote m+:
( m+ )
\ Credits:
\ Code adapted from Z88 CamelForth.
need z80-asm
code m+ ( d1 n -- d2 )
exx \ save Forth IP
bc pop \ n
de pop \ d1 hi cell
hl pop \ d1 lo cell
bc addp hl push
cy if de inc then de push
exx \ restore Forth IP
jpnext
end-code
\ doc{
\
\ m+ ( d1|ud1 n -- d2|ud2 )
\
\ Add _n_ to _d1|ud1_, giving the sum _d2|ud2_.
\
\ Standard: Forth-94 (DOUBLE) Forth-2012 (DOUBLE).
\
\ }doc
First working version of the Pong demo game.
Moved 2/ to the library.
2015-11-10
First changes to make also a +3DOS version, from the same sources.
2015-11-11
Wrote any-of, another addon for the case structure, based on any?, already ported from F83:
( any-of )
need any?
: (any-of) ( x0 x1..xn n -- x0 x0 | x0 0 )
dup 1+ pick >r any? r> tuck and ;
: any-of ( Compilation: -- of-sys )
( Run-time: x0 x1..xn n -- | x0 )
postpone (any-of) postpone of ; immediate compile-only
\ Usage example:
\ : test ( n -- )
\ case
\ 1 of ." one" endof
\ 2 7 10 3 any-of ." two, seven or ten" endof
\ 6 of ." six" endof
\ endcase ;
( any? )
\ Credits:
\ Code from F83.
need roll
variable (any?)
: any? ( x0 x1..xn n -- f )
\ Is any _x1..xn_ equal to _x0_?
dup 1+ roll (any?) ! 0 swap 0 do swap (any?) @ = or loop ;
Improved the Pong game with delay counters and Z80 halts.
Started adapting the Dijkstra Guarded Command Control Structures, by M. Edward Borasky, 1996-08-03, originally published in Forth Dimensions volume 18, number 4 (1996-11), pages 5-14: Towards a Discipline of ANS Forth Programming, and later already adapted to hForth v0.9.9 by Wonyong Koh.
2015-11-12
Started removing the fig-Forth compiler security from control structures. They are inconvenient to build new structures. Beside, 62 bytes will be saved in the kernel.
Modified interpret: Now it uses an execution table to determine what to do with a number. First, two new words are required:
if 1 ; interpret_numbers_with_execution_table ; XXX NEW
_variable_header numbers_execution_table_,'NUMBERS-EXECUTION-TABLE'
dw two_literal_ ; compiling a 2-cell number
dw literal_ ; compiling a 1-cell number
dw not_understood_ ; error
dw 0 ; interpreting a 1-cell number: do nothing
dw 0 ; interpreting a 2-cell number: do nothing
_colon_header not_understood_,'NOT-UNDERSTOOD'
_literal error.not_understood
dw throw_
endif
Then, interpret can be simplified:
if 1 ; interpret_numbers_with_execution_table ; XXX NEW
dw parsed_name_,two_fetch_
; try to convert the text to a number
; ( ca len )
dw number_question_ ; is it a number? ( 0 | n 1 | d 2 )
dw compiling_question_,question_negate_ ; ( d -2 | n -1 | 0 | n 1 | d 2 )
dw cells_
_literal numbers_execution_table_pfa+(2*cell)
dw plus_,perform_
dw branch_,interpret.begin ; repeat
else ; XXX OLD
dw parsed_name_,two_fetch_
; ( ca len )
dw number_question_ ; is it a number?
; ( 0 | n 1 | d 2 )
dw zero_equals_
_question_throw error.not_understood ; error if not
dw dpl_,fetch_,zero_less_than_ ; single number?
dw question_branch_,interpret.16bit_number
; decimal point detected, so it's a double, 32-bit, number
dw compiling_question_
dw zero_branch_,interpret.begin
dw two_literal_
dw branch_,interpret.begin
interpret.16bit_number:
dw compiling_question_
dw zero_branch_,interpret.begin
dw literal_
dw branch_,interpret.begin ; repeat
endif
The new method is only 1% faster, and saves only 4 bytes. Its main advantage is the code is simpler and more versatile (the execution table may be modified by the application).
Tried a similar method for the interpretion of words. It's only 1% faster and needs 24 bytes more:
if 1 ; table_interpret ; XXX NEW
_colon_header compilation_only_,'COMPILATION-ONLY'
_literal error.compilation_only
dw throw_
_variable_header interpret_execution_table_,'INTERPRET-EXECUTION-TABLE'
dw execute_ ; compiling an immediate and compile-only word
dw compile_comma_ ; compiling a compile-only word
dw execute_ ; compiling an immediate word
dw compile_comma_ ; compiling an ordinary word
interpret_execution_table.0
dw 0 ; not used
dw execute_ ; interpreting an ordinary word
dw execute_ ; interpreting an immediate word
dw compilation_only_ ; interpreting a compile-only word
dw compilation_only_ ; interpreting an immediate and compile-only word
endif
; ----------------------------------------------
_colon_header interpret_,'INTERPRET'
; doc{
;
; interpret ( -- )
;
; The outer text interpreter which sequentially executes or
; compiles text from the input stream (terminal or disk)
; depending on `state`. if the word name cannot be found after a
; search of the `context` search order it is converted to a
; number according to the current `base`. That also failing, an
; error message echoing the name with a "?" will be given.
;
; }doc
interpret.begin:
dw question_stack_
if 1 ; table_interpret ; XXX NEW
dw parse_name_ ; ( ca len )
dw dup_ ; end of stream?
dw zero_branch_,interpret.end ; if so, finish
dw find_name_ ; ( nfa | 0 )
dw question_dup_ ; found?
dw zero_branch_,interpret.word_not_found
; Found ( nfa )
dw dup_,from_name_,swap_ ; ( cfa nfa )
dw dup_,immediate_question_
dw swap_,compile_only_question_,two_star_
dw plus_,abs_ ; ( cfa +n )
dw one_plus_ ; adjust the index
dw compiling_question_,question_negate_ ; (cfa n )
dw cells_
_literal interpret_execution_table.0
dw plus_,perform_
dw branch_,interpret.begin
else ; XXX OLD
dw parse_name_ ; ( ca len )
dw dup_ ; end of stream?
dw zero_branch_,interpret.end ; if so, finish
dw find_name_ ; ( nfa | 0 )
dw question_dup_ ; found?
dw zero_branch_,interpret.word_not_found
; Found ( nfa )
dw dup_,compile_only_question_,executing_question_, and_
; executing a compile-only word?
_literal -14
dw question_throw_ ; is so, throw error -14
; ( nfa )
dw dup_,from_name_ ; ( nfa cfa )
dw swap_,immediate_question_,zero_equals_ ; ( cfa non-immediate? )
dw compiling_question_ ; ( nfa non-immediate? compiling? )
dw and_ ; compiling a non-immediate word?
dw zero_branch_,interpret.execute ; else, execute it
; Compiling a non-immediate word ( cfa )
dw compile_comma_
dw branch_,interpret.begin
interpret.execute:
; Executing or immediate ( cfa )
dw execute_
dw branch_,interpret.begin
endif
The combination of both execution tables and their associated code is easy. The final solution needs only 5 bytes more than the original interpret without execution tables. The speed gain is only 1%, but the code is much versatile.
; ----------------------------------------------
_variable_header interpret_table_,'INTERPRET-TABLE'
; compiling...
dw execute_ ; ...immediate and compile-only word
dw compile_comma_ ; ...compile-only word
dw execute_ ; ...immediate word
dw compile_comma_ ; ...ordinary word
dw two_literal_ ; ...2-cell number
dw literal_ ; ...1-cell number
interpret_table.0:
dw not_understood_ ; not a number (error)
; interpreting...
dw 0 ; ...1-cell number (do nothing)
dw 0 ; ...2-cell number (do nothing)
dw execute_ ; ...ordinary word
dw execute_ ; ...immediate word
dw compilation_only_ ; ...compile-only word (error)
dw compilation_only_ ; ...immediate and compile-only word (error)
; ----------------------------------------------
_colon_header interpret_,'INTERPRET'
; doc{
;
; interpret ( -- )
;
; The outer text interpreter which sequentially executes or
; compiles text from the input stream (terminal or disk)
; depending on `state`. if the word name cannot be found after a
; search of the `context` search order it is converted to a
; number according to the current `base`. That also failing, an
; error message echoing the name with a "?" will be given.
;
; }doc
interpret.begin:
dw question_stack_
dw parse_name_ ; ( ca len )
dw dup_ ; end of stream?
dw zero_branch_,interpret.end ; if so, finish
dw find_name_ ; ( nfa | 0 )
dw question_dup_ ; found?
dw zero_branch_,interpret.word_not_found
; Word found
; ( nfa )
dw dup_,from_name_,swap_ ; ( cfa nfa )
dw dup_,immediate_question_
dw swap_,compile_only_question_,two_star_
dw plus_,abs_ ; ( cfa +n )
_literal 3
dw plus_ ; adjust the table index
interpret.do_it:
; ( +n )
; Execute element _+n_ of `interpret-table`,
; depending on `state`.
dw compiling_question_,question_negate_,cells_
_literal interpret_table.0
dw plus_,perform_
dw branch_,interpret.begin
interpret.word_not_found:
dw parsed_name_,two_fetch_ ; ( ca len )
dw number_question_ ; is it a number? ( 0 | n 1 | d 2 )
dw branch_,interpret.do_it
interpret.end:
dw two_drop_
dw semicolon_s_
2015-11-13
Found the bug that caused stack underflow when compiler security was deactivated in the kernel: a swap was missing in the new version of else!
Removed the fig-Forth compiler security checks from the kernel and the library. This makes the kernel 74 bytes smaller. The library words that included compiler security are -if, -while, -until, retry, the unused original case from Abersoft Forth Disassembled (a version without compiler security was already written, beside two smaller versions).
Only the assembler still uses compiler security, with ?pairs, but at the moment it seems a good idea. ?pairs has been moved from the kernel to the library.
After removing the compiler security from the kernel, the implementation of the Dijkstra Guarded Command Control Structures works fine:
( {if if} if> |if| )
\ Dijkstra Guarded Command Control Structures
\ Credits:
\ Adapted from:
\ Dijkstra Guarded Command Control Structures
\ M. Edward Borasky, 1996-08-03
\ Listing in "Towards a Discipline of ANS Forth Programming"
\ Originally published in Forth Dimensions XVIII, No.4, pp5-14
\ Adapted to hForth v0.9.9 by Wonyong Koh
need cs-roll
: {if ( -- 0 ) 0 ; immediate compile-only
\ start a conditional
\ put counter on stack
: if>
\ ( count -- count+1 )
\ ( c: -- orig1 )
1+ >r postpone if r> ; immediate compile-only
\ right-arrow for {if ... if}
: |if|
\ ( count -- count )
\ ( c: orig ... orig1 -- orig ... orig2 )
>r postpone ahead \ new orig
1 cs-roll postpone then \ resolve old orig
r> ; immediate compile-only
\ bar for {if ... if}
: if} \ end of conditional
\ ( count -- )
\ ( c: orig1 ... orign -- )
>r postpone ahead
1 cs-roll postpone then \ resolve old orig
-22 postpone literal postpone throw
\ 'control structure mismatch'
r> 0 do postpone then loop ; immediate compile-only
\ end a conditional
\ XXX TODO use `?do` when available
( {do do} do> |do| )
\ Dijkstra Guarded Command Control Structures
\ Credits:
\ Adapted from:
\ Dijkstra Guarded Command Control Structures
\ M. Edward Borasky, 1996-08-03
\ Listing in "Towards a Discipline of ANS Forth Programming"
\ Originally published in Forth Dimensions XVIII, No.4, pp5-14
\ Adapted to hForth v0.9.9 by Wonyong Koh
need cs-pick need cs-roll
: {do ( c: -- dest ) postpone begin ; immediate compile-only
\ start a loop
: do> ( c: dest -- orig1 dest )
postpone if 1 cs-roll ; immediate compile-only
\ right arrow for {do ... od}
: |do| ( c: orig1 dest -- dest )
0 cs-pick postpone again \ resolve a copy of dest
1 cs-roll postpone then \ resolve old orig
; immediate compile-only
\ bar for {do ... do}
: do} ( c: orig dest -- )
\ end of loop
postpone again \ resolve dest
postpone then \ resolve orig
; immediate compile-only
\ end a loop
Modified interpret to save 6 bytes, using name>immediate?:
; Word found
; ( nfa )
if 0 ; XXX OLD
dw dup_,from_name_,swap_ ; ( cfa nfa )
dw dup_,immediate_question_ ; ( cfa nfa f1 )
dw swap_,compile_only_question_,two_star_ ; ( cfa f1 n2 )
else ; XXX NEW
dw dup_,name_to_immediate_question_ ; ( nfa cfa f1 )
dw rot_,compile_only_question_,two_star_ ; ( cfa f1 n2 )
endif
Removed from the kernel the unused alternative of ." that compiled slit and type instead of (."). Every compiled string needed one more cell.
Added environment?, with only the Forth-2012 queries, not the obsolescent word set queries of Forth-94.
Added some words written by Wil Baden and published on Forth Dimensions (volume 18, number 5, page 27): sqrt, q2* and dsqrt.
Wrote d2*, and d2/, converting the 8080 code of DZX-Forth to Z80.
2015-11-14
Included a simple implementation of local variables:
( local )
\ This is a simple solution to use an ordinary variable as
\ local, saving its current value on the return stack and
\ restoring it at the end.
\ Credits:
\ Original code by Henning Hanseng, published on
\ Forth Dimensions 9/5 p. 6 (1988-01).
: restore-local ( -- ) ( R: a x -- ) 2r> swap ! ;
\ a = address of a variable
\ x = its original value
\ Restore variable address and value.
: local ( a0 -- ) ( R: a1 -- a0 x pfa a1 )
\ a0 = address of a variable
\ x = its current value
\ a1 = return address
\ pfa = pfa of `restore-local`
r> swap \ save top return address
dup @ 2>r \ save variable address and value
['] restore-local >body >r \ force exit via `restore-local`
>r ; \ restore top return address
\ Usage example:
\
\ variable v
\ 1 v ! v ? \ default value
\ : test ( -- )
\ v local
\ v ? 1887 v ! v ? ;
\ v ? \ default value
Renamed -if, -while and -until:
( 0if 0while 0until )
: 0if ( f -- )
postpone ?branch >mark ; immediate compile-only
: 0while ( f -- )
postpone 0if postpone swap ; immediate compile-only
\ XXX TODO use cs-swap
: 0until ( f -- )
postpone ?branch <resolve ; immediate compile-only
Their former names are better for checking negative numbers, after cmForth.
Factored the main code of header to the new word (header), that accepts a string. This is more versatile.
Wrote a new alternative implementation of local variables:
( create-anon anon +anon n>anon )
\ 2015-11-14
\ Anonymous variables.
\ Credits:
\
\ Adapted, modified, improved and commented from original
\ code written by Leonard Morgenstern, published on Forth
\ Dimensions 6/1 p. 33 (1984-05).
variable (anon) ( -- a )
\ cfa of the latest anonymous variable.
: create-anon ( -- )
here (anon) !
[ (anon) body> @ ] literal compile, 0 , ;
\ Create a new anonymous variable. `(anon)` is used to get
\ and compile the cfa executed by all variables.
: anon ( Compilation: -- ) ( Run-time: -- a )
(anon) @
compiling? if compile, else execute then ; immediate
\ Current anonymous variable (first cell),
\ equivalent to `0 +anon`.
: +anon ( Compilation: n -- ) ( Run-time: -- )
cells (anon) @ execute +
compiling? if postpone literal then ; immediate
\ Current anonymous variable (cell _n_, first is 0).
: n>anon ( x1..xn n -- )
cells postpone anon swap bounds do i ! cell +loop ;
\ Store the given _n_ cells into the current anonymous
\ variable.
\ Usage example:
\ create-anon 5 cells allot
\
\ : test
\ 400 300 200 100 000 5 n>anon
\ anon ? \ prints 0
\ 123 anon !
\ anon ? \ prints 123
\ [ 2 ] +anon ? \ prints 200
\ 555 [ 2 ] +anon !
\ [ 2 ] +anon ? \ prints 555
\ ;
Added two alternative case structures:
( cases: )
\ `cases:` structure, alternative to the standard `case`.
\ It saves space, but is slower.
\ 2015-11-14
\ Credits:
\
\ Adapted, renamed and commented from code written by Dan
\ Lerner, published on Forth Dimensions (volume 3, number 6,
\ page 189, 1982-03).
\ 109 bytes used
: cases: ( "name" -- orig 0 )
create >mark 0
does> ( selector -- ) ( selector pfa )
true rot rot dup ( true selector pfa pfa )
cell+ swap @ ( true selector pfa+2 options )
0 do ( true selector a )
2dup @ = ( true selector a f )
if dup cell+ perform
2>r 0= 2r> ( false selector a ) exhaust
else cell+ cell+ then
loop ( true selector a | false selector a )
rot if perform else drop then drop ;
\ doc{
\
\ cases: ( "name" -- orig 0 )
\
\ Define a `cases:` structure "name", built as an array of
\ pairs (value and associated vector).
\
\ Usage example:
\
\ ----
\ : say10 ." dek" ;
\ : say100 ." cent" ;
\ : say1000 ." mil" ;
\ : sayother ." alia" ;
\
\ cases: say ( n -- )
\ 10 case> say10
\ 100 case> say100
\ 1000 case> say1000
\ other> sayother
\
\ 10 say 100 say 1000 say 1001 say
\ ----
\
\ }doc
: case> ( orig counter selector "name" -- orig counter' )
, ' compile, 1+ ;
\ doc{
\
\ case> ( orig counter selector "name" -- orig counter' )
\
\ Compile an option into a `cases:` structure. The given
\ _selector_ will cause the word "name" to be executed.
\
\ See `cases:` for an usage example.
\
\ }doc
: other> ( orig counter "name" -- ) ' compile, swap ! ;
\ doc{
\
\ other> ( orig counter "name" -- )
\
\ Compile the default option of a `cases:` to be the word
\ "name" . This must be the last option of the structure and
\ is mandatory. When no default action is required, `other>
\ noop` can be used.
\
\ See `cases:` for an usage example.
\
\ }doc
( case ) \ baden-case )
\ An alternative `case` structure that makes any
\ calculation easier.
\ 2015-11-14
\ Credits:
\
\ Adapted and modified from code written by Wil Baden,
\ published on Forth Dimensions (volume 8, number 5, page 29,
\ 1987-01).
\ XXX TODO rename, avoid standard names: `case`, `of`,
\ `endof`.
defer case ( n -- n n ) ' dup ' case defer!
defer othercase ( n -- ) ' drop ' othercase defer!
: of ( n f -- )
postpone if postpone drop ; immediate compile-only
: endof ( n f -- )
postpone exit postpone then ; immediate compile-only ;s
\ Usage example
\ ----
\ : say0 ." nul" ;
\ : say1 ." unu" ;
\ : say2 ." du" ;
\ : say-other ." alia" ;
\ : test ( n -- )
\ case 0 = of say0 endof
\ case 1 = of say1 endof
\ case 2 = of say2 endof
\ othercase say-other ;
\ ----
Benchmarked all case structures in the library:
\ Bytes used Speed (3)
\ --------------------- --------------
\ Structure Code (1) Example (2) Frames Seconds
\ --------- --------- ----------- ------ -------
\ case (7) 48 62 1365 27
\ eforth-case (8) 54 62 1366 27
\ 94-doc-case (6) 54 62 1365 27
\ abersoft-case (5) 64 62 1365 27
\ case: (4) 21 12 823 16
\ options[ (9) 166 24 3627 72
\ cases: (10) 109 18 3155 63
\ baden-case (11) 18 56 1472 29
\ baden-case (12) 36 56 1472 29
\ baden-case (13) 0 50 1353 27
\ (1) Bytes used by the compilation of the structure's code.
\
\ (2) Bytes used by the tested example: a structure with
\ three options plus default, that execute a `noop`.
\
\ (3) For 32767 iterations with parameter 0..3. One system
\ frame is 20 ms.
\ (4) A port of F83's `case:`. It is more specific than the
\ other structures: it lacks a default option and its
\ argument is positional.
\
\ (5) Eaker/Forth-94 `case` of Abersoft Forth, but with
\ compiler security removed.
\
\ (6) Eaker/Forth-94 `case` copied from the Forth-94
\ documentation.
\
\ (7) Eaker/Forth-94 `case` of eForth, with a little
\ simplification.
\
\ (8) Eaker/Forth-94 `case` of eForth.
\
\ (9) A port of IsForth's `case:`.
\
\ (10) A port of a structure written by Dan Lerner, published
\ on Forth Dimensions (volume 3, number 6, page 189,
\ 1982-03).
\
\ (11) "Ultimate CASE Statement", written by Wil Baden,
\ published on Forth Dimensions (volume 8, number 5, page 29,
\ 1987-01).
\
\ (12) The same "Ultimate CASE Statement", by Wil Baden, with
\ two syntactic sugar words added: `endof` and `othercase`.
\
\ (13) The same "Ultimate CASE Statement", by Wil Baden,
\ emulated with standard words. This is a bit faster
\ because, without the syntactic sugar definitions, one `dup`
\ and two `drop` are saved.
2015-11-15
Implemented the Noble arrays.
( 1array ) \ noble-arrays )
\ Toolset for one- and two-dimensional arrays in ANS Forth
\ ---------------------------------------------------
\ (c) Copyright 2001 Julian V. Noble. \
\ Permission is granted by the author to \
\ use this software for any application pro- \
\ vided this copyright notice is preserved. \
\ ---------------------------------------------------
\ ...........................................................
\ References:
\
\ http://forth.sourceforge.net/techniques/arrays-jvn/index-v.txt
\ http://forth.sourceforge.net/techniques/
\ http://www.phys.virginia.edu/classes/551.jvn.fall01/arrays.f
\ ...........................................................
\ Implementation:
\ words for 1-dimensional arrays
need <=
: long ; immediate
: 1array ( len #bytes/datum --) \ ( #b len data ...)
create 2dup , , * allot ;
: _len ( base_addr -- len) cell+ @ ;
\ determine length of an array
: } ( base_adr indx -- adr[indx] )
over _len over <= over 0< or #-272 ?throw
\ #-272 = index out of range
over @ * + cell+ cell+ ;
( 2array ) \ noble-arrays )
\ words for 2-dimensional arrays
need 1array
: wide ; immediate
: 2array ( hgt wid data_size --) \ ( wid #b len data ...)
create >r tuck , ( wid hgt)
r@ , * dup , r> * allot ;
: }} ( base_adr m n -- adr[m,n] ) \ data stored row-wise
2>r cell+ dup cell- @
r> * r> + ( base_adr+cell m+n*w)
} ;
\ ...........................................................
\ Usage examples:
\ 20 long 2 floats 1array a{
\ \ complex vector
\
\ 20 long 20 wide 1 floats 2array m{{
\ \ real matrix
\
\ 20 long 1 cells 1array irow{
\ \ single-length, integer-valued vector
\
\ a{ i } ( -- adr[a_i] )
\ m{{ i j }} ( -- adr[m_ij] )
\ irow{{ i j }} ( -- adr[irow_i] )
Included Leo Wong's array:
( array ato ) \ wong-arrays )
\ One-dimensional arrays by Leo Wong
\ ...........................................................
\ References:
\ http://forth.sourceforge.net/techniques/arrays-lw/index-v.txt
\ http://forth.sourceforge.net/techniques/
\ ...........................................................
\ Description:
\ This approach is unique in having no proponents. It is part
\ of Flight, a Forth scripting language. Several Flight
\ programs can be found by Googling comp.lang.forth. In
\ conformance with the design goals of Flight, bounds
\ checking is included.
\ ...........................................................
\ Main idea:
\ Treat arrays like values.
\ \ Example of use:
\ 4 array bar
\ 10 0 ato bar 20 1 ato bar 30 2 ato bar 40 3 ato bar
\ 3 bar .
\ 0 bar .
\ 123 3 ato bar
\ 3 bar .
\ 1 3 +ato bar
\ 3 bar .
\ Note that as in most Forth numerical arguments go before:
\ 1 3 +ato bar NOT: 1 +ato 3 bar
\ This approach can be extended to different-sized data
\ (including strings) and 2 or more dimensions by having
\ their own versions of array array> ato +ato. A Flight
\ scripter would not be expected to implement these words.
\ ...........................................................
\ Sample implementation:
need within
: array> ( n 'array -- a )
2dup @ 0 swap within 0= #-272 ?throw
\ #-272 = array index out of range
cell+ swap cells + ;
\ if in range, return element address, else abort
: array ( n "name" -- )
create dup , cells allot
does> ( n -- x ) ( n pfa ) array> @ ;
\ define array
: (ato) ( x n array -- ) >body array> ! ;
\ store to array
: ato ( x n "name" -- )
compiling? if postpone ['] postpone (ato)
else ' (ato) then ; immediate
\ store to array
\ usage: x n ato <name>
: (+ato) ( x n array -- ) >body array> +! ;
\ add to array
: +ato ( n "name" -- )
compiling? if postpone ['] postpone (+ato)
else ' (+ato) then ; immediate
\ add to array
Added a new switch structure:
( link@ link, )
\ 2015-11-15
\ Credits:
\
\ Code written after the description by Rick VanNorman,
\ published on Forth Dimensions (volume 20, number 3, pages
\ 19..22, 1998-09).
defer link@ ( node1 -- node2 )
' @ ' link@ defer!
\ Fetch the linked list node _node_ is pointing to.
: link, ( node -- ) here over @ , swap ! ;
\ Create a new linked list node, pointing to _node_.
( :switch )
\ 2015-11-15
\ Credits:
\
\ Original code by Rick VanNorman, published on Forth
\ Dimensions (volume 20, number 3, pages 19..22, 1998-09).
need link@ need link,
: switcher ( i*x n head -- j*x )
dup cell+ @ >r \ save default cfa
begin link@ ?dup while ( n a )
2dup cell+ @ = if \ match
nip cell+ cell+ perform r> drop exit
then
repeat r> execute ;
\ Search the linked list from its _head_ for a match to the
\ value _n_. If a match is found, discard _n_ and execute the
\ associated matched cfa. If no match is found, leave _n_ on
\ the stack and execute the default cfa.
: :switch ( cfa "name" -- a )
create >mark swap ,
does> ( n -- ) ( n pfa ) switcher ;
\ Create a code switch whose default behaviour is given by
\ _cfa_. Leave the address of the head of its list on the
\ stack.
: <switch ( head cfa n -- head )
2 pick link, , , ;
\ Define a new clause to execute _cfa_ when the key _n_
\ is matched.
-->
( :switch )
: [switch ( "name1" "name2" -- head )
create >mark ' ,
does> ( n -- ) ( n pfa ) switcher ;
\ Define a new switch "name1" with its default behaviour
\ "name2". The head of the switch is left on the stack for
\ defining clauses.
: [+switch ( "name" -- head ) ' >body ;
\ Leave the head of the given switch "name", for clauses to
\ append to.
: switch] ( head -- ) drop ;
\ Discard the switch head from the stack.
\ Used after defining clauses.
: runs ( head n "name" -- ) ' swap <switch ;
\ Associate the cfa of "name" to clause _n_ of switch _head_.
;s
\ XXX TODO -- `run:`
: run: ( head n "text<;>" -- )
:noname [char] ; parse evaluate postpone ; ( cfa )
swap >switch ;
( :switch-test ) \ without syntactic sugar
: one ( -- ) ." unu " ;
: two ( -- ) ." du " ;
: three ( -- ) ." tri " ;
: many ( n -- ) . ." is too much! " ;
' many :switch numbers
\ `many` is the default behaviour of the new switch `numbers`
' one 1 <switch
' two 2 <switch
' three 3 <switch drop
cr 1 numbers 2 numbers 3 numbers 4 numbers
' numbers >body :noname ." kvar " ; 4 <switch drop
\ add a new clause for the number 4
cr 1 numbers 2 numbers 3 numbers 4 numbers
-->
( :switch-test ) \ with syntactic sugar
[switch sugar-numbers many
1 runs one
2 runs two
3 runs three
switch]
cr 1 sugar-numbers 2 sugar-numbers
3 sugar-numbers 4 sugar-numbers
: four ( -- ) ." kvar " ;
[+switch sugar-numbers
4 runs four
switch]
\ add a new clause for the number 4
cr 1 sugar-numbers 2 sugar-numbers
3 sugar-numbers 4 sugar-numbers
Added a leapy year calculation:
( leapy-year? )
\ 2015-11-15
\ Credits:
\
\ Code written by Wil Baden, published on Forth Dimensions
\ (volume 8, number 5, page 31, 1987-01).
: leapy-year? ( n -- f )
dup 400 mod 0= if drop true exit then
dup 100 mod 0= if drop false exit then
4 mod 0= if false exit then
false ;
\ Alternative.
\ need baden-case
\
\ : leapy-year? ( n -- f )
\ case 400 mod 0= of true endof
\ case 100 mod 0= of false endof
\ case 4 mod 0= of true endof
\ othercase false ;
2015-11-16
Improved header: The new double variable next-name is checked for a name string. This feature was inspired by Gforth's nextname. A double variable is simpler and saves memory in this case.
_colon_header header_,'HEADER'
; doc{
;
; header ( "name" | -- )
; Create a dictionary header with its code field pointing to its
; parameter field.
;
; The double variable `next-name` may hold a string to be used
; as the name. If its length is zero, "name" is parsed from the
; stream as usual.
; ----
; : header ( "name" | -- )
; next-name 2@
; dup if next-name off
; else 2drop parse-name then (header) ;
; ----
; }doc
dw next_name_,two_fetch_
dw dup_
dw zero_branch_,header.parse_name
dw next_name_,off_
dw branch_,header.end
header.parse_name
dw two_drop_,parse_name_
header.end
dw paren_header_
dw semicolon_s_
Confirmed the recent implementation of wordlist works fine. (vocabulary) was factored from vocabulary to implement wordlist, though it could be simpler to write vocabulary based on wordlist. Beside, the association of existing word lists to names is not solved yet. For example, order hangs the system when a word list is in the search order, because >name is supposed to find the associated name field, and does no check the end of the name fields bank...
; ----------------------------------------------
_colon_header paren_vocabulary_,'(VOCABULARY)'
; doc{
;
; (vocabulary) ( -- )
;
; Create the parameter field of a vocabulary or word list just created.
;
; ----
; : (vocabulary) ( -- )
; 0 , here voc-link @ , voc-link ! ;
; ----
;
; }doc
_literal 0
dw comma_ ; nfa of the latest word defined in the vocabulary
dw here_ ; new contents of vocabulary link
dw voc_link_,fetch_,comma_ ; compile the previous contents of `voc-link`
dw voc_link_,store_ ; update `voc-link`
dw semicolon_s_
; ----------------------------------------------
_colon_header vocabulary_,'VOCABULARY'
; doc{
;
; vocabulary ( "name" -- )
;
; Create a vocabulary with the parsed "name" as its name. The
; run-time efect of `name` is to replace `context`, the top
; vocabulary in the search order.
;
; ----
; : vocabulary ( "name" -- )
; create (vocabulary)
; does> ( -- ) ( pfa ) context ! ;
; ----
; }doc
dw create_,paren_vocabulary_
dw paren_semicolon_code_
do_vocabulary:
call do_does
; The next words are to be executed when the vocabulary is invoked.
dw context_,store_
dw semicolon_s_
; ----------------------------------------------
_colon_header wordlist_,'WORDLIST'
; doc{
;
; wordlist ( -- wid )
;
; : wordlist ( -- wid )
; :noname (vocabulary) postpone ; >body ;
;
; }doc
dw colon_no_name_,paren_vocabulary_,semicolon_,to_body_
dw semicolon_s_
Made : non-immediate.
2015-11-17
Wrote an alternative method to set a string as the name of the next word to be defined. The new approach (and the word names) is adapted from Gforth:
; ----------------------------------------------
_two_variable_header nextname_string_,'NEXTNAME-STRING'
; doc{
;
; next-name ( -- a )
;
; A double variable that may hold the address and length of a
; name to be used by the next defining word. This variable is
; set by `nextname`.
;
; }doc
dw 0,0
if 1 ; nextname
; XXX NEW -- This alternative was inspired by Gforth.
; ----------------------------------------------
_defer_header header_,'HEADER',,input_stream_header_
; ----------------------------------------------
_colon_header input_stream_header_,'INPUT-STREAM-HEADER'
; doc{
;
; header ( "name" -- )
; Create a dictionary header "header" with its code field
; pointing to its parameter field.
; ----
; : input-stream-header ( "name" | -- )
; parse-name header, ;
; ----
; }doc
dw parse_name_,header_comma_
dw semicolon_s_
; ----------------------------------------------
_colon_header nextname_header_,'NEXTNAME-HEADER'
; doc{
;
; nextname-header ( -- )
; Create a dictionary header with its code field pointing to its
; parameter field, using the name string set by `nextname`.
; ----
; : nextname-header ( -- )
; nextname-string 2@ header,
; ['] input-stream-header ['] header defer! ;
; ----
; }doc
dw nextname_string_,two_fetch_,header_comma_
_literal input_stream_header_
_literal header_
dw defer_store_ ; restore the default behaviour of `header`
dw semicolon_s_
; ----------------------------------------------
_colon_header nextname_,'NEXTNAME'
; doc{
;
; nextname ( ca len -- )
;
; ----
; : nextname ( ca len -- )
; nextname-string 2!
; ['] nextname-header ['] header defer! ;
; ----
;
; }doc
dw nextname_string_,two_store_
_literal nextname_header_
_literal header_
dw defer_store_ ; change the default behaviour of `header`
dw semicolon_s_
else
; XXX OLD
; ----------------------------------------------
_colon_header header_,'HEADER'
; doc{
;
; header ( "name" | -- )
; Create a dictionary header with its code field pointing to its
; parameter field.
;
; The double variable `next-name` may hold a string to be used
; as the name. If its length is zero, "name" is parsed from the
; stream as usual.
; ----
; : header ( "name" | -- )
; nextname-string 2@
; dup if nextname-string off
; else 2drop parse-name then header, ;
; ----
; }doc
dw nextname_string_,two_fetch_
dw dup_
dw zero_branch_,header.parse_name
dw nextname_string_,off_
dw branch_,header.end
header.parse_name
dw two_drop_,parse_name_
header.end
dw header_comma_
dw semicolon_s_
endif
Some benchmarking revealed both methods are equally fast.
2015-11-18
Started writting an alternative implementation of the heap, using a bitmap, after an example provided by Javier Gil in his book Introducción a Forth.
2015-11-19
Factored >digit from # and rewrote it in Z80. Faster, smaller and more versatile.
Modernized two old names that still remained from Abersoft Forth: Forth-79's u/mod to um/mod, after Forth-94 and Forth-2012; fig-Forth's m/mod to ud/mod, after common usage.
Converted sign to modern Forth. The fig-Forth definition was : sign ( n d -- d ) rot 0< if [char] - hold then ; instead of simply : sign ( n -- ) 0< if [char] - hold then ;.
2015-11-22
Added two simple words to the library: create: (from CP/M-volksForth 3.80a) and swap-current (from lpForth). Modified F83's case: to use create:.
Added also nuf? and aborted?:
( nuf? )
\ Credits:
\
\ Code adapted from lpForth and Forth Dimensions (volume 10,
\ number 1, page 29).
need aborted?
[defined] 'cr' ?\ 13 constant 'cr' \ code of carriage return
: nuf? ( -- f ) 'cr' aborted? ;
\ XXX OLD -- Classic definition:
\
\ : nuf? ( -- f ) key? dup if key 2drop key 'cr' = then ;
\ doc{
\
\ nuf? ( -- f )
\
\ If no key is pressed return _false_. If a key is pressed,
\ discard it and wait for a second key. Then return _true_ if
\ it's a carriage return, else return _false_.
\ Usage example:
\
\ : listing ( -- )
\ begin ." bla " nuf? until ." Aborted" ;
\
\ }doc
( aborted? )
: aborted? ( c -- f )
key? dup if key 2drop key =
else nip then ;
\ doc{
\
\ aborted? ( c -- f )
\
\ If no key is pressed return _false_. If a key is pressed,
\ discard it and wait for a second key. Ther return _true_ if
\ it's _c_, else return _false_.
\ Usage example:
\
\ : listing ( -- )
\ begin ." bla " bl aborted? until ." Aborted" ;
\
\ }doc
Added 3drop and 4drop:
( 3drop 4drop )
code 3drop ( x1 x2 x3 -- )
E1 c, E1 c, E1 c,
\ pop hl
\ pop hl
\ pop hl
jpnext end-code
code 4drop ( x1 x2 x3 x4 -- )
E1 c, E1 c, E1 c, E1 c,
\ pop hl
\ pop hl
\ pop hl
\ pop hl
jpnext end-code
Added negative-check versions of branch and conditionals:
( -branch )
code -branch ( f -- )
E1 c,
\ pop hl
CB c, 7C c,
\ bit 7,h ; negative?
CA c, ' branch >body ,
\ jp z,branch_pfa ; if not, branch
03 c, 03 c,
\ inc bc
\ inc bc ; skip the inline branch address
jpnext
end-code
\ doc{
\
\ -branch ( f -- )
\
\ A run-time procedure to branch conditionally. If _f_ on
\ stack is negative, the following in-line address is copied
\ to IP to branch forward or backward.
\
\ Compiled by `-if`, `-while` and `-until`.
\
\ }doc
( -if -while -until )
\ XXX TODO Compilation stack notation.
need -branch need cs-swap
: -if ( f -- )
postpone -branch >mark ; immediate compile-only
\ doc{
\
\ -if ( f -- )
\
\ Faster and smaller alternative to the idiom `0< if`.
\
\ }doc
: -while ( f -- )
postpone -if postpone cs-swap ; immediate compile-only
\ doc{
\
\ -while ( f -- )
\
\ Faster and smaller alternative to the idiom `0< while`.
\
\ }doc
: -until ( f -- )
postpone -branch <resolve ; immediate compile-only
\ doc{
\
\ -until ( f -- )
\
\ Faster and smaller alternative to the idiom `0< until`.
\
\ }doc
2015-11-23
Added the variable limit to implement an upper memory limit. This way data can be allocated outside the dictionary.
Fixed accept: useless control keys were not filtered out.
Made max a bit faster with a little optimization of the assembler.
Factored the "ok" prompt out from quit: created the defered word ok and its default vector .ok. This way the some useful customizations are possible.
Finished the first version of the character translation table. So far the translations were hardcoded in xkey, the temporary version of key used by accept.
2015-11-24
Substituted the assembler code of um/mod (from Abersoft Forth's u/mod, a word from Forth-79) with the version of Z88 CamelForth. It's 18 bytes shorter and c. 25% faster. Beside, an obscure bug of the Abersoft Forth version caused wrong results with certain values.
_code_header u_m_slash_mod_,'UM/MOD'
; doc{
;
; um/mod ( ud u1 -- u2 u3 )
;
; Divide _ud_ by _u1_, giving the quotient _u3_ and the
; remainder _u2_. All values and arithmetic are unsigned.
;
; Standard: Forth-94 (CORE), Forth-2012 (CORE).
;
; }doc
; Credits:
;
; Code adapted from Z88 CamelForth.
exx
pop bc ; BC = divisor
pop hl ; HLDE = dividend
pop de
ld a,16 ; loop counter
sla e
rl d ; hi bit DE -> carry
u_m_slash_mod.do:
adc hl,hl ; rot left w/ carry
jr nc,u_m_slash_mod.3
; case 1: 17 bit, cy:HL = 1xxxx
or a ; we know we can subtract
sbc hl,bc
or a ; clear cy to indicate sub ok
jr u_m_slash_mod.4
; case 2: 16 bit, cy:HL = 0xxxx
u_m_slash_mod.3:
sbc hl,bc ; try the subtract
jr nc,u_m_slash_mod.4 ; if no cy, subtract ok
add hl,bc ; else cancel the subtract
scf ; and set cy to indicate
u_m_slash_mod.4:
rl e ; rotate result bit into DE,
rl d ; and next bit of DE into cy
dec a
jr nz,u_m_slash_mod.do
; now have complemented quotient in DE,
; and remainder in HL
ld a,d
cpl
ld b,a
ld a,e
cpl
ld c,a
push hl ; remainder
push bc ; quotient
exx
_jp_next
if 0 ; XXX OLD
; Credits:
;
; Code from Abersoft Forth.
; The original word was called `u/mod`, from Forth-79.
; XXX FIXME -- This word, has a bug that affects `line>string`, used
; by `message`, and other words that use it: `*/mod`, `mod` and
; `/mod`, with certain negative values, return different values
; in Abersoft Forth and other Forth systems that have been
; tested (some of them are fig-Forth).
ld hl,0x0004
add hl,sp
ld e,(hl)
ld (hl),c
inc hl
ld d,(hl)
ld (hl),b
pop bc
pop hl
ld a,l
sub c
ld a,h
sbc a,b
jr c,l60a0h
ld hl,0xFFFF
ld de,0xFFFF
jr l60c0h
l60a0h:
ld a,0x10
l60a2h:
add hl,hl
rla
ex de,hl
add hl,hl
jr nc,l60aah
inc de
and a
l60aah:
ex de,hl
rra
push af
jr nc,l60b4h
and l
sbc hl,bc
jr l60bbh
l60b4h:
and a
sbc hl,bc
jr nc,l60bbh
add hl,bc
dec de
l60bbh:
inc de
pop af
dec a
jr nz,l60a2h
l60c0h:
pop bc
push hl
push de
_jp_next
endif
Moved get-current and set-current to the kernel. This costs only 8 bytes, because all current @ and current ! used in the kernel can be substituted.
Removed the old unused alternative versions of throw and documented the current version:
_colon_header throw_,'THROW'
; Credits:
; Code from DZX-Forth.
; Comments from MPE Forth for TiniARM.
; doc{
;
; throw ( n -- )
; Standard: Forth-94 (EXCEPTION), Forth-2012 (EXCEPTION).
; ----
; : throw ( n -- )
; ?dup if
; catcher @ ?dup 0= \ no catcher?
; if error then \ `error` does not return
; rp! \ restore previous return stack
; r> catcher ! ( n ) \ restore previous catcher
; r> swap >r ( saved-sp ) ( R: n )
; sp! drop r> ( n ) \ restore stack
; \ Return to the caller of `catch` because return stack is
; \ restored to the state that existed when `catch` began
; \ execution.
; then ;
; ----
; }doc
dw question_dup_
dw zero_branch_,throw.end
dw catcher_,fetch_,question_dup_ ; catcher?
dw question_branch_,throw.catcher ; if so, branch
dw error_ ; no return from `error`.
throw.catcher:
dw rp_store_ ; restore previous return stack
dw from_r_,catcher_,store_ ; ( n ) restore previous catcher
dw from_r_,swap_,to_r_ ; ( saved-sp ) ( R: n )
dw sp_store_,drop_,from_r_ ; ( n ) restore stack
; Return to the caller of `catch` because return stack is
; restored to the state that existed when `catch` began
; execution.
throw.end:
dw semicolon_s_
Substituted the code of 2swap with a faster (0.89 the execution time) and smaller version, adapted from Z88 CamelForth:
_code_header two_swap_,'2SWAP'
; doc{
;
; 2swap ( x1 x2 x3 x4 -- x3 x4 x1 x2 )
;
; }doc
if 0 ; XXX OLD
; Credits:
; Code from DZX-Forth.
; T B
; --- --
pop hl ; 10 01
pop de ; 10 01
ex (sp),hl ; 19 01
push hl ; 11 01
ld hl,5 ; 10 03
add hl,sp ; 11 01
ld a,(hl) ; 07 01
ld (hl),d ; 07 01
ld d,a ; 04 01
dec hl ; 06 01
ld a,(hl) ; 07 01
ld (hl),e ; 07 01
ld e,a ; 04 01
pop hl ; 10 01
jp push_hlde ; 10 03
; 11 00 push de
; 11 00 push hl
; --- --
; 155 19 TOTAL
else ; XXX NEW
; Credits:
; Code adapted from Z88 CamelForth
; T B
; --- --
exx ; 04 01
pop hl ; hl'=x4 ; 10 01
pop de ; de'=x3 ; 10 01
exx ; 04 01
pop hl ; hl=x2 ; 10 01
pop de ; de=x1 ; 10 01
exx ; 04 01
push de ; x3 ; 11 01
push hl ; x4 ; 11 01
exx ; 04 01
jp push_hlde ; 10 03
; 11 00 push de
; 11 00 push hl
; --- --
; 110 13 TOTAL
endif
Compared the current code of dnegate with the code of Spectrum Forth-83. The current code is faster and only 1 byte bigger:
_code_header d_negate_,'DNEGATE'
; doc{
;
; dnegate ( d1 -- d2 )
;
; Negate _d1_, giving its arithmetic inverse _d2_.
;
; Standard: Forth-79 (Required word set), Forth-83 (Required
; word set), Forth-94 (CORE), Forth-2012 (CORE).
;
; }doc
if 0
; Credits:
; Code from Abersoft Forth, also found in White Lightning.
; XXX TODO optimize?
; T B
; --- --
pop hl ; high part ; 10 01
pop de ; low part ; 10 01
sub a ; zero ; 04 01
sub e ; two's complement to carry ; 04 01
ld e,a ; 04 01
ld a,0x00 ; 07 02
sbc a,d ; two's complement with carry ; 04 01
ld d,a ; 04 01
ld a,0x00 ; 07 02
sbc a,l ; two's complement with carry ; 04 01
ld l,a ; 04 01
ld a,0x00 ; 07 02
sbc a,h ; two's complement with carry ; 04 01
ld h,a ; 04 01
jp push_hlde ; 10 03
; 11 00 push de
; 11 00 push hl
; --- --
; 109 20
else
; Credits:
; Code from Spectrum Forth-83.
;
; Comparison with the Abersoft Forth version:
; Speed: 1.04
; Size: -1
; T B
; --- --
pop hl ; high part ; 10 01
pop de ; low part ; 10 01
push hl ; save copy ; 11 01
ld hl,0x0000 ; 10 03
and a ; 04 01
sbc hl,de ; hl = negated low part ; 15 02
pop de ; high part ; 10 01
push hl ; negated low part ; 11 01
ld hl,0x0000 ; 10 03
sbc hl,de ; hl = negated high part ; 15 02
jp push_hl ; 10 03
; 11 00 push hl
; --- --
; 127 19
endif
2015-11-25
Reorganized the code of ;s, exit and ?exit. Removed the old ;s. It may be redefined as an alias of exit, but exit and ?exit can be used instead.
if 0 ; XXX OLD
; ----------------------------------------------
_code_header semicolon_s_,';S'
; doc{
;
; ;s ( -- )
;
; Return execution to the calling definition. Unnest one level.
;
; It is used to stop interpretation of a screen. It is also the
; run-time word compiled at the end of a colon-definition which
; returns execution to the calling procedure.
; Standard: fig-Forth.
;
; }doc
ld hl,(return_stack_pointer)
ld c,(hl)
inc hl
ld b,(hl)
inc hl
ld (return_stack_pointer),hl
_jp_next
; ----------------------------------------------
_colon_header exit_,'EXIT',compile_only
; doc{
;
; exit ( -- ) ( R: nest-sys -- )
; Return control to the calling definition, specified by
; _nest-sys_.
;
; Before executing `exit` within a do-loop, a program shall
; discard the loop-control parameters by executing `unloop`.
;
; Standard: Forth-94 (CORE), Forth-2012 (CORE).
;
; }doc
dw r_drop_
dw exit_
; ----------------------------------------------
_colon_header question_exit_,'?EXIT',compile_only
; doc{
;
; ?exit ( f -- ) ( R: a | -- a | )
;
; If _f_ is non-zero, return control to the calling definition,
; specified by the address on the return stack.
;
; `?exit` is not intended to be used within a do-loop. Use `if
; unloop exit then` instead.
;
; }doc
dw question_branch_,exit_pfa
dw exit_
else ; XXX NEW
; ----------------------------------------------
_code_header exit_,'EXIT'
; doc{
;
; exit ( -- ) ( R: nest-sys -- )
; Return control to the calling definition, specified by
; _nest-sys_.
;
; Before executing `exit` within a do-loop, a program shall
; discard the loop-control parameters by executing `unloop`.
;
; In Solo Forth `exit` can be used in interpretation mode to
; stop the interpretation of a block.
;
; Standard: Forth-94 (CORE), Forth-2012 (CORE).
;
; }doc
ld hl,(return_stack_pointer)
ld c,(hl)
inc hl
ld b,(hl)
inc hl
ld (return_stack_pointer),hl
_jp_next
; ----------------------------------------------
_code_header question_exit_,'?EXIT'
; doc{
;
; ?exit ( f -- ) ( R: nest-sys | -- nest-sys | )
;
; If _f_ is non-zero, return control to the calling definition,
; specified by _nest-sys_.
;
; `?exit` is not intended to be used within a do-loop. Use `if
; unloop exit then` instead.
;
; In Solo Forth `?exit` can be used in interpretation mode to
; stop the interpretation of a block.
;
; }doc
pop hl
ld a,h
or l
jp nz,exit_pfa
_jp_next