Solo Forth development history in 2016-03.
Description of the page content
Solo Forth development history in 2016-03.
Tags:
2016-03-01
Simplified (cat), calling only the SCAN_CAT routine:
code (cat) ( n -- )
\ n = cat type: 2=compact; 4=detailed
hl pop bc push exx
\ Get the parameter in hl' and save the Forth IP
patch hook
ufia hl ldp# ufia1 de ldp# /ufia bc ldp# ldir
\ Copy Forth UFIA to G+DOS UFIA1.
\ exx l a ld 24B5 call 168E call \ XXX OLD
\ 24B5 = CAT_RUN (input: cat type in the A register)
\ 168E = BORD_REST (restore the border)
exx l a ld 09A5 call \ XXX NEW
\ 09A5 = SCAN_CAT (input: cat or search type in the A register)
E7 out bc pop next ix ldp# jpnext end-code
\ page +D out
\ restore the Forth registers and exit
2016-03-02
Wrote standard delete-file, after the old -file:
\ XXX OLD:
: ior>error ( ior -- f n )
dup 1 and negate swap \ calculate f
flip %11111111 and \ upper 8 bits of ior
1000 + negate ;
\ Convert a DOS ior to a Forth error number.
\ ior = the AF register returned by a DOS command:
\ bit 0 = set: error
\ bits 8-14 = error code
\ bit 15 = set: OS error; unset: DOS error
\ f = error?
\ n = error number:
\ -1000..-1031: G+DOS error number 0..31
\ -1128..-1154: OS error number 0..26
: -file ( ca len -- f n ) filename>ufia (-file) ior>error ;
\ Delete a disk file _ca len_. If error, _f_ is true and
\ _n_ is the error code.
\ XXX NEW:
: dosior>ior ( ior1 -- ior2 )
dup 1 and negate \ error?
swap flip %11111111 and \ get upper 8 bits of ior
1000 + negate and ;
\ Convert a DOS ior to a Forth ior.
\ ior1 = the AF register returned by a DOS command:
\ bit 0 = set: error
\ bits 8-14 = error code
\ bit 15 = set: OS error; unset: DOS error
\ ior2 = error number:
\ 0: no error
\ -1000..-1031: G+DOS error number 0..31
\ -1128..-1154: OS error number 0..26
: delete-file ( ca len -- ior )
filename>ufia (-file) dosior>ior ;
\ Delete a disk file _ca len_ and return I/O result code
\ _ior_.
2016-03-05
Deleted old -file.
Renamed drive@ and drive! to get-drive and set-drive, which seems more logical.
Added assert and assert= to the library.
2016-03-07
First draft of a command line history. It will be part of the library:
( hp hp0 unused-history allot-history allocate-history )
\ 2016-03-07: Start.
\ Command line history is implemented as a list of counted
\ string at the top of the memory bank which is used also to
\ store the name fields. Name files are stored upwards from
\ the bottom of the 16-KiB space; command line history grows
\ downwards from the top.
\
\ The length of the counted strings is used as link field.
\ The bottom of the list is the hights address of the bank,
\ and it holds one byte, the length of the first string
\ stored in the history, or zero when the history is empty.
\
\ There's a maximum space usable for the history. When
\ there's no free space left, the oldest string is removed
\ in a loop until the necessary space is freed.
\ XXX TODO
variable hp
\ Pointer to the most recent string in the history.
$FFFF constant hp0
\ Pointer to the bottom of the history, which contains a copy
\ of the length of the first string.
1024 constant /history
\ Size of the history space, where all strings are hold.
: init-hp0 ( -- ) 0 hp0 c!n ;
: empty-history ( -- ) init-hp0 hp0 hp ! ; empty-history
: history-bounds ( -- ca1 ca2 ) hp0 hp @ ;
\ Return bottom of history _a1_ and address of the latest
\ string _ca2:
: used-history ( -- u ) history-bounds - ;
\ Used space _u_ in the history.
: unused-history ( -- n ) /history @ used-history - ;
\ Unused space _n_ in the history.
: allot-history ( +n -- ) negate hp +! ;
\ Reserve _+n_ bytes in the history.
: history-empty? ( -- f ) history-bounds = ;
\ Is the history empty?
: allocate-history ( +n -- ior )
dup /history @ > if drop #-274 exit then
\ command line history overflow?
." allocate-history" \ XXX INFORMER
0 ; \ XXX TMP
\ Allocate _+n_ bytes in the history.
\ XXX TODO -- remove older strings if needed
-->
( >history history> )
need s=
: latest-history ( -- ca len )
names-bank hp @ count save-string default-bank ;
\ Return the latest string in the command line history,
\ copied in the circular string buffer, without affecting
\ the contents of the command line history.
: history> ( -- ca len )
\ XXX OLD
\ names-bank hp @ count 2dup + hp ! save-string
\ default-bank
\ XXX NEW
latest-history dup 1+ negate allot-history
history-empty? if init-hp0 then ;
\ Get a string from the command line history, and return it
\ as _ca len_ in the circular string buffer.
: duplicated-history? ( ca len -- f ) latest-history s= ;
\ Is string _ca len_ identical to the latest string in
\ the command line history?
: >history ( ca len -- )
dup 0= if 2drop exit then
\ If string is empty, do nothing.
history-empty? if dup hp0 c!n then
\ If history is empty, init its bottom with the lenght
\ of the string.
2dup duplicated-history? if 2drop exit then
dup 1+ unused-history >
if dup 1+ allocate-history throw then
\ If there's no space left, allocate it.
dup 1+ allot-history
hp @ names-bank place default-bank ;
\ Save string _ca len_ into the command line history.
Started modifying accept in order to implement the command line history into it. Did some improvements and fixes during the process.
2016-03-13
Made accept a deferred word. Replaced its old default behaviour default-accept with a simple smaller version, adapted from eForth, with an additional filter for control characters, and renamed it to simple-accept:
; ----------------------------------------------
_defer_header accept_,'ACCEPT',,simple_accept_
; doc{
;
; accept ( ca1 len1 -- len2 )
;
; Receive a string of at most _len1_ characters. No characters
; are received or transferred if _len1_ is zero. Display
; graphic characters as they are received.
;
; Input terminates when an implementation-defined line
; terminator is received. When input terminates, nothing is
; appended to the string or displayed on the screen.
;
; _len2_ is the length of the string stored at _ca1_.
;
; Origin: Forth-94 (CORE), Forth-2012 (CORE).
;
; In Solo Forth `accept` is a deferred word. Its default
; behaviour is `default-accept`, which provides only the basic
; editing options Alternative definitions are provided in the
; library.
;
; }doc
; ----------------------------------------------
_colon_header simple_accept_,'SIMPLE-ACCEPT'
; Credits:
;
; Code adapted from eForth.
; doc{
;
; simple-accept ( ca1 len1 -- len2 )
;
; Default behaviour of the deferred word `accept`:
;
; Receive a string of at most _len1_ characters. No characters
; are received or transferred if _len1_ is zero. Display
; graphic characters as they are received.
;
; Input terminates when the Return key is pressed. When input
; terminates, nothing is appended to the string or displayed on
; the screen.
;
; The only control key accepted is Delete.
;
; _len2_ is the length of the string stored at _ca1_.
;
; ----
; : simple-accept ( ca len -- len' )
; over + over ( bot eot cur )
; begin xkey dup 13 <> \ not carriage return?
; while
; dup 12 = \ delete?
; if drop >r over r@ < dup \ any chars?
; if 8 dup emit bl emit emit then r> +
; else \ printable
; >r 2dup <> \ more?
; r@ [ bl 1- ] literal > and \ and printable?
; if r@ over c! char+ r@ emit then r> drop
; then
; repeat ( bot eot cur c ) drop nip swap - ;
; ----
;
; }doc
dw over_,plus_,over_
simple_accept.begin ; begin
dw xkey_,dup_
_literal carriage_return_char
dw not_equals_
dw zero_branch_,simple_accept.end ; while
dw dup_
_literal delete_char
dw equals_ ; delete?
dw zero_branch_,simple_accept.printable ; if
dw drop_,to_r_,over_,r_fetch_,less_than_,dup_ ; any chars?
dw zero_branch_,simple_accept.delete_end ; if
_literal backspace_char
dw dup_,emit_,b_l_,emit_,emit_
simple_accept.delete_end ; then
dw from_r_,plus_
dw branch_,simple_accept.repeat
simple_accept.printable ; else
; printable
dw to_r_,two_dup_,not_equals_ ; more?
dw r_fetch_
_literal space_char-1
dw greater_than_,and_ ; and printable?
dw zero_branch_,simple_accept.printable_end ; if
dw r_fetch_,over_,c_store_,char_plus_,r_fetch_,emit_
simple_accept.printable_end ; then
dw from_r_,drop_
simple_accept.repeat
dw branch_,simple_accept.begin ; repeat
simple_accept.end
; ( bot eot cur c )
dw drop_,nip_,swap_,minus_
dw exit_
; ----------------------------------------------
_colon_header default_accept_,'DEFAULT-ACCEPT'
; doc{
;
; default-accept ( ca1 len1 -- len2 )
;
; Default behaviour of the deferred word `accept`:
;
; Receive a string of at most _len1_ characters. No characters
; are received or transferred if _len1_ is zero. Display
; graphic characters as they are received.
;
; Input terminates when the Return key is pressed. When input
; terminates, nothing is appended to the string or displayed on
; the screen.
;
; The only control key accepted is Delete.
;
; _len2_ is the length of the string stored at _ca1_.
;
; }doc
dw span_,off_
dw question_dup_
dw zero_branch_,default_accept.end
dw to_r_ ; ( ca1 ) ( R: len1 )
default_accept.begin: ; ( ca )
dw xkey_ ; ( ca c )
dw dup_ ; ( ca c c )
_literal delete_char
dw equals_ ; delete key?
dw zero_branch_,default_accept.maybe_carriage_return
; Delete key ( ca c )
dw drop_
dw span_,fetch_
dw zero_branch_,default_accept.begin ; nothing to delete
; Do delete the last char
dw one_minus_ ; update the current address
_literal -1
dw span_,plus_store_ ; update `span`
_literal backspace_char
dw branch_,default_accept.emit
default_accept.maybe_carriage_return: ; ( ca c )
dw dup_
_literal carriage_return_char
dw equals_ ; carriage return?
dw question_branch_,default_accept.carriage_return
default_accept.ordinary_key: ; ( ca c )
dw dup_,b_l_,less_than_ ; is it a control key?
dw question_branch_,default_accept.discard ; if so, discard the char
default_accept.printable_key ; ( ca c )
; Printable key
dw span_,fetch_,r_fetch_,less_than_ ; enough free space left?
dw zero_branch_,default_accept.discard ; if not, discard the char
dw two_dup_,swap_,c_store_ ; add the char to the string
dw swap_,one_plus_,swap_ ; increase the address
_literal 1
dw span_,plus_store_ ; increase `span`
default_accept.emit: ; ( ca c )
dw emit_
dw branch_,default_accept.begin
default_accept.discard: ; ( ca c )
; Discard the typed char
dw drop_
dw branch_,default_accept.begin
default_accept.carriage_return: ; ( ca c )
dw drop_,r_drop_
default_accept.end: ; ( ca )
dw drop_
dw accept_buffer_,fetch_,span_,fetch_,to_history_
dw span_,fetch_
dw exit_
2016-03-14
Fixed cliteral.
Wrote c", with a new implementation of csilteral:
( csliteral c" )
: csliteral ( Compilation: ca len -- )
( Run-time: -- ca )
2>r postpone ahead here 2r> s, >r postpone then
r> postpone literal ; immediate compile-only
\ doc{
\
\ csliteral ( Compilation: "text<quote>" -- ) ( Run-time: -- ca )
\
\ Compile a string _ca len_ which at run-time will
\ be returned as a counted string.
\
\ }doc
\
\ Credits:
\ Code from Gforth's `CLiteral`.
: c" ( Compilation: "text<quote>" -- )
( Run-time: -- ca )
[char] " parse postpone csliteral ; immediate compile-only
\ doc{
\
\ c" ( Compilation: "text<quote>" -- ) ( Run-time: -- ca )
\
\ Parse a string delimited by double quotes and
\ compile it into the current definition.
\ At run-time the string will be returned as a
\ counted string _ca_.
\
\ Origin: Forth-94 (CORE EXT), Forth-2012 (CORE EXT).
\
\ }doc
Wrote basic tools to control the caps lock:
( capslock )
need os-flags2
need c!toggle-bits need c@test-bits
need c!reset-bits need c!reset-bits
%1000 os-flags2 2constant capslock
\ Bit and system variable that control the capslock.
: toggle-capslock ( -- ) capslock c!toggle-bits ;
: set-capslock ( -- ) capslock c!set-bits ;
: unset-capslock ( -- ) capslock c!reset-bits ;
: capslock? ( -- f ) capslock c@test-bits 0<> ;
Removed the old ITC code, which was deactivated by default with conditional compilation.
Old ITC code in header macros:
_code_header: macro _base_label,_name,_flags
_header _base_label,_name,_flags
if 0 ; itc
dw _base_label##pfa ; code field
endif
_base_label##pfa: ; parameter field address
_base_label##code: ; address of the actual code
endm
_defer_header: macro _base_label,_name,_flags,_xt
_code_header _base_label,_name,_flags
if 0 ; itc
ld hl,_xt
jp next2
else ; DTC
jp _xt
endif
endm
_code_alias_header: macro _base_label,_name,_flags,_xt
_header _base_label,_name,_flags
if 0 ; itc
dw _xt##pfa ; code field
else ; DTC
jp _xt
endif
endm
_colon_header: macro _base_label,_name,_flags
_header _base_label,_name,_flags
if 0 ; itc
dw do_colon ; code field
else
call do_colon ; code field
endif
_base_label##pfa: ; parameter field address
endm
_user_variable_header: macro _base_label,_name,_flags
_header _base_label,_name,_flags
if 0 ; itc
dw do_user ; code field
else
call do_user ; code field
endif
_base_label##pfa: ; parameter field address
endm
_does_header: macro _base_label,_name,_flags,_runtime_routine
_header _base_label,_name,_flags
if 0 ; itc
dw _runtime_routine ; code field
else
call _runtime_routine ; code field ; XXX TODO confirm this
endif
_base_label##pfa: ; parameter field address
endm
_constant_header: macro _base_label,_name,_flags
_header _base_label,_name,_flags
if 0 ; itc
dw do_constant ; code field
else
call do_constant ; code field
endif
_base_label##pfa: ; parameter field address
endm
_two_constant_header: macro _base_label,_name,_flags
_header _base_label,_name,_flags
if 0 ; itc
dw do_two_constant ; code field
else
call do_two_constant ; code field
endif
_base_label##pfa: ; parameter field address
endm
_c_constant_header: macro _base_label,_name,_flags
_header _base_label,_name,_flags
if 0 ; itc
dw do_c_constant ; code field
else
call do_c_constant ; code field
endif
_base_label##pfa: ; parameter field address
endm
_variable_header: macro _base_label,_name,_flags
_header _base_label,_name,_flags
if 0 ; itc
dw do_create ; code field
else
call do_create ; code field
endif
_base_label##pfa: ; parameter field address
endm
_two_variable_header: macro _base_label,_name,_flags
_variable_header _base_label,_name,_flags
endm
Old ITC code in the inner interpreter:
; ==============================================================
; :Inner interpreter
push_hlde:
push de
push_hl:
push hl
if 0 ; itc
next:
; Execute the word whose xt is in the address pointed by the bc register.
; Forth: W <-- (IP)
; Z80: hl <-- (bc)
ld a,(bc)
ld l,a
inc bc ; inc IP
ld a,(bc)
ld h,a
inc bc ; inc IP
; bc = address of the next xt
; hl = xt
next2:
; Execute the word whose xt is in the hl register.
; Forth: PC <-- (W)
; Z80: pc <-- (hl)
ld e,(hl)
inc hl
ld d,(hl)
ex de,hl
; hl = (xt) = address of the code
; de = xt+1 = pfa-1
next2_end: ; XXX TMP label for debugging
jp (hl)
else ; DTC
next:
; Execute the word whose xt is in the address pointed by the bc register.
; Forth: W <-- (IP)
; Z80: hl <-- (bc)
ld a,(bc)
ld l,a
inc bc ; inc IP
ld a,(bc)
ld h,a
inc bc ; inc IP
; bc = address of the next xt
; hl = xt
next2:
; Execute the word whose xt is in the hl register.
; Forth: PC <-- (W)
; Z80: pc <-- (hl)
next2_end: ; XXX TMP label for debugging
jp (hl)
endif
Old ICT code in some words:
; ----------------------------------------------
_code_header execute_,'EXECUTE'
; doc{
;
; execute ( xt -- )
;
; }doc
pop hl
if 0 ; itc
jp next2
else ; DTC
jp (hl)
endif
; ----------------------------------------------
_colon_header colon_,':'
dw store_csp_
dw header_
if 0 ; itc
else ; DTC
dw lit_,do_colon
dw code_field_comma_
endif
dw right_bracket_
dw paren_semicolon_code_
do_colon:
ld hl,(return_stack_pointer)
dec hl
ld (hl),b
dec hl
ld (hl),c
ld (return_stack_pointer),hl ; save the updated IP
if 0 ; itc
; T B
; -- --
inc de ; de=pfa ; 06 01
ld c,e ; 04 01
ld b,d ; bc=pfa ; 04 01
else ; DTC
; T B
; -- --
pop bc ; bc=pfa ; 10 01
endif
do_colon.end: ; XXX TMP for debugging
_jp_next
; ----------------------------------------------
_colon_header colon_no_name_,':NONAME',immediate
; doc{
;
; :noname ( -- xt )
;
; Origin: Forth-94 (CORE EXT), Forth-2012 (CORE EXT).
;
; ----
; }doc
; Credits:
; Code from the Afera library.
; XXX TODO move to the library?
; first `do_colon` must be defined as a constant
dw here_ ; xt
dw store_csp_
dw lit_,do_colon
if 0 ; itc
dw comma_ ; create the code field
else ; DTC
dw code_field_comma_
endif
dw noname_question_,on_
dw right_bracket_
dw exit_
; ----------------------------------------------
if 0 ; itc
else ; DTC
_colon_header code_field_comma_,'CODE-FIELD,'
; doc{
;
; code-field, ( a -- )
;
; Compile a code field for a high-level word, to execute the
; actual Z80 code at _a_.
; ----
; : code-field, ( a -- )
; $CD c, \ Z80 opcode for "call"
; , ;
; ----
;
; }doc
_literal 0xCD ; Z80 opcode for "call"
dw c_comma_ ; compile it
dw comma_ ; compile _a_
dw exit_
endif
; ----------------------------------------------
_header noop_,'NOOP'
; doc{
;
; noop ( -- )
;
; }doc
if 0 ; itc
dw next ; code field
else ; DTC
_jp_next ; code field
endif
; ----------------------------------------------
_colon_header c_constant_,'CCONSTANT'
dw create_,c_comma_
dw paren_semicolon_code_
do_c_constant:
if 0 ; itc
; T B
; -- --
inc de ; de=pfa ; 06 01
ex de,hl ; hl=pfa ; 04 01
else
; T B
; -- --
pop hl ; 10 01
endif
jp c_fetch.hl
; ----------------------------------------------
_colon_header constant_,'CONSTANT'
dw create_,comma_
dw paren_semicolon_code_
do_constant:
if 0 ; itc
; T B
; -- --
inc de ; de=pfa ; 06 01
ex de,hl ; hl=pfa ; 04 01
else
; T B
; -- --
pop hl ; 10 01
; _z80_border_wait 4 ; XXX INFORMER
; _z80_border 0 ; XXX INFORMER
endif
jp fetch.hl
; ----------------------------------------------
_colon_header user_,'USER'
; doc{
;
; user ( "name" -- )
;
; Create a user variable _name_ in the first available offset
; within the user area. Execution of _name_ leaves its absolute
; user area storage address.
;
; }doc
; XXX UNDER DEVELOPMENT
; XXX TODO
dw c_constant_
dw paren_semicolon_code_
do_user:
if 0 ; itc
inc de ; de=pfa
ex de,hl
else ; DTC
pop hl
endif
ld e,(hl)
ld d,0x00 ; de = index of the user variable
ld hl,(user_variables_pointer)
add hl,de ; hl= address of the user variable
jp push_hl
; ----------------------------------------------
if 0 ; itc
_code_alias_header from_body_,'BODY>',,two_minus_
else ; DTC
_code_header from_body_,'BODY>'
pop hl
dec hl
dec hl
dec hl
jp push_hl
endif
; ----------------------------------------------
if 0 ; itc
_code_alias_header to_body_,'>BODY',,two_plus_
else ; DTC
_code_header to_body_,'>BODY'
pop hl
inc hl
inc hl
inc hl
jp push_hl
endif
; ----------------------------------------------
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
; ----------------------------------------------
_colon_header paren_semicolon_code_,'(;CODE)'
; doc{
;
; (;code) ( -- )
;
; The run-time procedure compiled by `;code`. Rewrite the code
; field of the most recently defined word to point to the
; following machine code sequence.
;
; }doc
if 0 ; itc
; ----
; : (;code) ( -- )
; r> \ Pop the address of the next instruction off the return stack,
; \ which is the starting address of the run-time code routine.
; latest \ Get the name token of the word under construction.
; name> ! \ Find its execution token and store the address of
; \ the code routine to be executed at run-time into it.
; ;
; ----
dw from_r_,latest_,from_name_,store_
dw exit_
else ; DTC
; ----
; : (;code) ( -- )
; r> latest name> 1+ ! ;
; ----
dw from_r_,latest_,from_name_,one_plus_,store_
dw exit_
endif
; ----------------------------------------------
_colon_header does_,'DOES>',immediate+compile_only
if 0 ; itc
dw compile_,paren_semicolon_code_
_literal 0xCD ; Z80 opcode for "call"
dw c_comma_ ; compile it
dw lit_,do_does,comma_ ; compile the routine address
dw exit_
do_does:
; Save the IP on the return stack.
ld hl,(return_stack_pointer)
dec hl
ld (hl),b
dec hl
ld (hl),c
ld (return_stack_pointer),hl
; Pop the address of the run-time routine
; (put there bye `call do_does`) in IP.
pop bc ; new Forth IP
; Push the pfa.
inc de ; de=pfa
push de
; Execute the run-time routine.
_jp_next
else ; DTC
do_does equ do_colon
dw compile_,paren_semicolon_code_
_literal 0xCD ; Z80 opcode for "call"
dw c_comma_ ; compile it
dw lit_,do_does,comma_ ; compile the routine address
dw exit_
;do_does:
; XXX UNDER DEVELOPMENT
; XXX FIXME
; pop de
; push de
; push de
; jp do_colon
endif
; ----------------------------------------------
_colon_header header_comma_,'HEADER,'
; doc{
;
; header, ( ca len -- )
;
; Create a dictionary header with the name _ca len_.
;
; }doc
; XXX TODO -- complete the description, depending on ITC and
; DTC
dw dup_,zero_equals_
_question_throw error.zero_length_name
dw warnings_,fetch_
dw zero_branch_,header_comma.continue
; `warnings` is on
dw two_dup_,get_current_,search_wordlist_
dw zero_branch_,header_comma.continue
; the word is not unique in `current`
; ( ca len xt )
dw to_name_,dot_name_
_literal error.not_unique
dw dot_throw_ ; XXX TMP -- `warning`?
header_comma.continue:
; ( ca len )
dw width_,fetch_,min_
dw tuck_ ; ( len ca len )
dw names_bank_
dw here_,comma_np_ ; store a pointer to the xt
dw latest_,comma_np_ ; link field
; Now `np` contains the address of the nt.
dw np_fetch_
dw dup_,to_r_
dw place_ ; store the name
dw from_r_,count_,uppers_
dw np_fetch_,get_current_,store_ ; update contents of `latest` in the current vocabulary
dw hide_
dw one_plus_,np_,plus_store_ ; update the names pointer with the length+1
if 0 ; itc
dw here_,cell_plus_,comma_ ; compile the pfa into code field
else ; DTC
; no code field is created
endif
dw exit_
; ----------------------------------------------
_colon_header create_,'CREATE'
; XXX TODO factor `header reveal` to `visible-header`? it's
; used also by `defer`.
dw header_
if 0 ; itc
else ; DTC
dw lit_,do_create
dw code_field_comma_
endif
dw reveal_
dw paren_semicolon_code_
do_create:
if 0 ; itc
inc de ; de=pfa
push de
else ; DTC
; DTC does not require any code, because `call do_create` already
; left the pfa on the stack.
endif
_jp_next
; ----------------------------------------------
_colon_header defer_,'DEFER'
; doc{
;
; defer ( "name" -- )
;
; Create a deferred word.
;
; Origin: Forth-2012 (CORE EXT).
;
; }doc
dw header_,reveal_
if 0 ; itc
_literal 0x21 ; Z80 opcode for `ld hl,NN`
dw c_comma_
_literal paren_defer_ ; default xt to execute
dw comma_
_literal 0xC3 ; Z80 opcode for `jp NN`
dw c_comma_
_literal next2 ; address to jump to
dw comma_
else ; DTC
_literal 0xC3 ; Z80 opcode for `jp NN`
dw c_comma_
_literal paren_defer_ ; default xt to execute
dw comma_
endif
dw exit_
if 0 ; itc
; ----------------------------------------------
_colon_header to_defer_,'>DEFER'
; doc{
;
; >defer ( xt1 -- a )
;
; Return the address _a_ that holds the xt currently associated
; to the deferred word _xt1_.
;
; }doc
dw to_body_,one_plus_
dw exit_
else ; DTC
; ----------------------------------------------
_code_alias_header to_defer_,'>DEFER',,one_plus_
; doc{
;
; >defer ( xt1 -- a )
;
; Return the address _a_ that holds the xt currently associated
; to the deferred word _xt1_.
;
; }doc
endif
; ----------------------------------------------
_colon_header two_constant_,'2CONSTANT'
dw create_,two_comma_
dw paren_semicolon_code_
do_two_constant:
if 0 ; itc
inc de ; de=pfa
ex de,hl ; hl=pfa
else
pop hl
endif
jp two_fetch.hl
The word >code was an abstraction required to make some code words from the library work on both ITC and DTC. Now it can be removed.
Also some words from the library can be removed. For example, the ITC implementation of alias, which was quite complex:
( alias )
\ XXX NEW -- DTC
: alias ( xt "name" -- ) defer latest name> defer! ;
\ doc{
\
\ alias ( xt "name" -- )
\
\ Create an alias _name_ that will execute _xt_.
\
\ }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
Converted execute-hl back to DTC:
( execute-hl call-xt )
\ Assembler macros to call any Forth word from code words.
\ Credits:
\
\ Code inspired by Spectrum Forth-83, where similar code is
\ embedded in `KEY` and `PAUSE` to call an xt hold in a
\ variable. The code was factored to two assembler macros in
\ order to make it reusable.
macro execute-hl ( -- )
here 6 + bc ldp# \ point IP to phony_compiled_word
next2 jp \ execute the xt in HL
\ phony_compiled_word:
here cell+ , \ point to the phony xt following
endm
\ Compile an `execute` with the xt hold in HL.
macro call-xt ( xt -- )
hl ldp# execute-hl
endm
\ Compile a call to _xt_.
\ This is the low-level equivalent of `execute`.
2016-03-15
Tested the previous implementation of csliteral, which is system-dependent but more versatile, and thus used by default:
( cslit csliteral c" )
\ This is the default definition of `csliteral`, based on a
\ system-dependent `cslit`, which makes it possible to decode
\ `c"`.
\ XXX REMARK -- 43 bytes used
: cslit ( -- ca ) r@ dup c@ 1+ r> + >r ;
\ doc{
\
\ cslit ( -- ca )
\
\ Return a string that is compiled after the calling word, and
\ adjust the instruction pointer to step over the inline string.
\
\ }doc
: csliteral ( ca len -- )
compile cslit s, ; immediate compile-only
\ doc{
\
\ csliteral ( Compilation: "text<quote>" -- ) ( Run-time: -- ca )
\
\ Compile a string _ca len_ which at run-time will
\ be returned as a counted string.
\
\ }doc
: c" ( Compilation: "text<quote>" -- )
( Run-time: -- ca )
[char] " parse postpone csliteral ; immediate compile-only
\ doc{
\
\ c" ( Compilation: "text<quote>" -- ) ( Run-time: -- ca )
\
\ Parse a string delimited by double quotes and
\ compile it into the current definition.
\ At run-time the string will be returned as a
\ counted string _ca_.
\
\ Origin: Forth-94 (CORE EXT), Forth-2012 (CORE EXT).
\
\ }doc
( csliteral c" )
\ This is an alternative system-independent definition of
\ `csliteral`.
\ XXX REMARK -- 43 bytes used
: csliteral ( Compilation: ca len -- )
( Run-time: -- ca )
2>r postpone ahead here 2r> s, >r postpone then
r> postpone literal ; immediate compile-only
\ Credits:
\ Code from Gforth's `CLiteral`.
: c" ( Compilation: "text<quote>" -- )
( Run-time: -- ca )
[char] " parse postpone csliteral ; immediate compile-only
Replaced the Abersoft and Gforth definition of ud/mod with code adapted from Z88 CamelForth, which is a bit faster and a bit smaller, but which needs -rot to be moved from the library:
; ----------------------------------------------
_colon_header u_d_slash_mod_,'UD/MOD'
if 0 ; XXX OLD
; doc{
;
; ud/mod ( ud1 u2 -- urem udquot )
;
; ----
; : ud/mod ( ud1 u2 -- urem udquot )
; >r 0 r@ um/mod r> swap
; >r um/mod r> ;
; ----
; Origin: fig-Forth (`m/mod`), Gforth.
;
; }doc
; Credits:
;
; Code from fig-Forth (where this word is called `m/mod`)
; and Gforth.
dw to_r_
_literal 0
dw r_fetch_
dw u_m_slash_mod_
dw from_r_
dw swap_
dw to_r_
dw u_m_slash_mod_
dw from_r_
dw exit_
else ; XXX NEW
_colon_header u_d_slash_mod_,'UD/MOD'
; doc{
;
; ud/mod ( ud1 u2 -- urem udquot )
;
; ----
; : ud/mod ( ud1 u1 -- urem udquot )
; >r 0 r@ um/mod -rot r> um/mod rot ;
; ----
; Credits:
; Code modified from Z88 CamelForth.
dw to_r_
_literal 0
dw r_fetch_
dw u_m_slash_mod_
dw minus_rot_
dw from_r_
dw u_m_slash_mod_
dw rot_
dw exit_
; ----------------------------------------------
_code_header minus_rot_,'-ROT'
pop hl
pop de
ex (sp),hl
ex de,hl
jp push_hlde
endif
Fixed number?: wrong numbers left a double cell under the TOS false flag. This error was not detected before because the interpreter forced and error, which clears the stacks.
Improved number?: now any number of decimal points is accepted, not only one (also Gforth works this way).
2016-03-16
Fixed number?: base was not restored on exit caused by a wrong number, so bad numbers with base prefixes, like "$" and "%", left base with the value set by the prefix.
Improved number?: now also colon, slash, comma, plus and hyphen are allowed as punctuation.
Added number to the library, and a new error code for it:
: number ( ca len -- n | d ) number? 0= #-275 ?throw ;
Made .\" independent from s\", by a commond dependency on parse-escaped-string.
Replaced Z80 jumps to the push_hl entry point of the inner interpreter with a push hl and the usual jp (ix) (jump to next). This saves 2 T states and needs no additional bytes. Benchmarks are 1% faster.
Added jppushhl to the assembler word list in the kernel.
Made number? to reject initial or duplicated points:
; ----------------------------------------------
_defer_header number_point_question_,'NUMBER-POINT?',,standard_number_point_question_
; doc{
;
; number-point? ( c -- f )
;
; Is character _c_ a valid point in a number? This is a
; deferred word used in `number?`. Its default behaviour is
; `standard-number-point?`, which only allows the period.
;
; The library provides alternatives which accept more points.
;
; }doc
; ----------------------------------------------
_colon_header standard_number_point_question_,'STANDARD-NUMBER-POINT?'
; doc{
;
; standard-number-point? ( c -- f )
;
; Is character _c_ a valid point in a number? The only allowed
; point is period.
;
; This is the default behaviour of the deferred word
; `number-point?`, which is used in `number?`.
;
; The library provides alternatives which accept more points.
; ----
; : number-point? ( c -- f )
; [char] . = ;
; ----
;
; }doc
; ----------------------------------------------
_colon_header number_question_,'NUMBER?'
; XXX TODO make it a deferred word
; doc{
;
; number? ( ca len -- 0 | n 1 | d 2 )
;
; Convert a string _ca len_ to a number. Return 0 if the
; conversion is not possible. If the result is a single number,
; return _n_ and 1. If the result is a double number, return _d_
; and 2.
;
; This word accepts valid point anywhere on the number and
; updates `dpl` with the position of the last one. If no
; point is found, `dpl` contains -1.
;
; Chars between single quotes are recognized, after Forth-2012.
; ----
; : number? ( ca len -- 0 | n 1 | d 2 )
;
; dup 0= if 2drop 0 exit then \ reject empty strings
;
; 2dup char? if nip nip 1 exit then \ char format
;
; over c@ number-point? \ first char is a point?
; if 2drop 0 exit then \ is so, reject the string
;
; base @ >r number-base base ! ( R: radix )
; skip-sign? >r ( R: radix sign )
; 0 0 2swap dpl on
;
; begin ( d ca len ) >number dup while
;
; over c@ number-point? 0= \ invalid point?
; if 2drop 2drop rdrop r> base ! 0 exit then
;
; dup dpl @ = \ previous char was a point?
; if 2drop 2drop rdrop r> base ! 0 exit then
;
; dup 1- dpl ! \ update the position of the last point
; 1 /string \ skip the point
;
; repeat
;
; 2drop \ discard the empty string
; dpl @ 0< \ single-cell number?
; if d>s r> ?negate 1 \ single-cell number
; else r> ?dnegate 2 \ double-cell number
; then r> base ! ; \ restore the radix
; ----
; }doc
dw dup_,zero_equals_ ; empty string?
dw zero_branch_,number_question.try_char
; reject an empty string
number_question.reject:
dw two_drop_,false_
dw exit_
number_question.try_char:
dw two_dup_,char_question_ ; a char?
dw zero_branch_,number_question.try_initial_point
; return the char code
dw nip_,nip_
_literal 1
dw exit_
number_question.try_initial_point:
dw over_,c_fetch_ ; first char...
dw number_point_question_ ; ...is point?
dw question_branch_,number_question.reject ; is so, reject the string
dw base_,fetch_,to_r_
dw number_base_,base_,store_
dw skip_sign_question_,to_r_
dw two_lit_,0,0 ; initial value
dw two_swap_,dpl_,on_
number_question.begin:
dw to_number_
dw dup_ ; are there non-recognized chars?
dw zero_branch_,number_question.done ; while
; The conversion was not completed, so it may be because of a
; point that indicates it's a double number.
dw over_,c_fetch_ ; get the non-digit character
dw number_point_question_ ; is it valid point?
dw question_branch_,number_question.point
number_question.invalid_character:
dw two_drop_,two_drop_,r_drop_,false_
dw branch_,number_question.end
number_question.point:
dw dup_,dpl_,fetch_,equals_ ; was the previous character a point?
dw question_branch_,number_question.invalid_character ; if so, invalid
number_question.valid_point:
dw dup_,one_minus_,dpl_,store_ ; update the position of the last point
_literal 1
dw slash_string_ ; skip the point
dw branch_,number_question.begin ; repeat
number_question.done:
dw two_drop_ ; discard the empty string
dw dpl_,fetch_,zero_less_than_ ; single-cell number?
dw zero_branch_,number_question.double
; single-cell number
dw d_to_s_,from_r_,question_negate_
_literal 1
dw branch_,number_question.end
number_question.double:
; double-cell number
dw from_r_,question_d_negate_
_literal 2
number_question.end:
dw from_r_,base_,store_ ; restore `base`
dw exit_
Added two alternatives to number-point? to the library:
( standard-number-point? extended-number-point? )
need [if]
[needed] classic-number-point? [if]
: classic-number-point? ( c -- f )
dup [char] : = swap [char] , - 4 u< or ;
\ doc{
\
\ standard-number-point? ( c -- f )
\
\ Is character _c_ a classic number point? Allowed
\ points are: comma, hyphen, period, slash and
\ colon.
\
\ This word is an alternative behaviour for the deferred word
\ `number-point?`, which is used in `number?`.
\
\ }doc
[then]
[needed] extended-number-point? [if]
: extended-number-point? ( c -- f )
dup [char] : = swap [char] + - 5 u< or ;
\ doc{
\
\ extended-number-point? ( c -- f )
\
\ Is character _c_ an extended number point? Allowed
\ points are: plus sign, comma, hyphen, period, slash and
\ colon, after _Forth Programmer's Handbook_.
\
\ This word is an alternative behaviour for the deferred word
\ `number-point?`, which is used in `number?`.
\
\ }doc
\
\ Credits:
\
\ Code by Wil Baden, from Forth Dimensions (volume 20, number
\ 3 page 26, 1998-10).
[then]
2016-03-19
Added there to set dp and updated the library accordingly.
Made compile, an alias of ,,
Since DTC makes aliases of colon words possible, the following words are converted to alias: compile,, begin, <mark, <resolve and then.
Removed next2. Updated pause and execute-hl accordingly.
Updated some development benchmarks.
Moved the stack notation description to its own file.
Reorganized the source, binary and temporary files into directories.
Added bank-start:
; ----------------------------------------------
_constant_header bank_start_,'BANK-START'
; doc{
;
; bank-start ( -- a )
;
; A constant: Memory address where banks are paged in.
;
; }doc
bank_start equ 0xC000
dw bank_start
Added save-here and restore-here:
( save-here restore-here )
variable here-backup
: save-here ( -- ) here here-backup ! ;
: restore-here ( -- ) here-backup there ;
Renamed the "names bank" to "system bank", because it will be used also for the command line history, and maybe more things. Renamed all related words and kernel labels accordingly.
Added the code-bank tool:
( code-bank )
need save-here need call
variable cp bank-start cp ! \ code pointer
: code-here ( -- a ) cp @ ;
: code-there ( a -- ) cp ! ;
: code-allot ( n -- ) cp +! ;
variable code-bank# 3 code-bank# !
\ Memory bank used as code bank.
: code-bank ( -- ) code-bank# @ bank ;
\ Page the code bank in.
: code-bank{ ( -- ) save-here code-here there code-bank ;
\ Start compiling code into the code bank.
: }code-bank ( -- ) default-bank restore-here ;
\ End compiling code into the code bank.
: ?bank ( -- ) bank-start here u< #-276 ?throw ;
\ Issue error -276 if the dictionary has reached
\ the zone of memory banks. This check is required after
\ compiling code which must manipulate memory banks.
: code-bank-routine ( i*x a "name" -- j*x )
create ?bank ,
does> ( -- ) ( pfa ) @ code-bank call default-bank ;
\ Create a word "name" which will call the machine code
\ routine at _a_, in the code bank.
Restored list, wich was removed by mistake in version 0.3.0-rc.0+20160316.
Converted >wid and wid> to aliases.
2016-03-20
Added +under, a variant of the current under+:
( under+ ) \ ==operators==
code under+ ( n1|u1 x n2|u2 -- n3|u3 x )
D9 c, \ exx
D1 c, \ pop de
C1 c, \ pop bc
E1 c, \ pop hl
19 c, \ add hl,de
E5 c, \ push hl
C5 c, \ push bc
D9 c, \ exx
jpnext end-code
\ doc{
\
\ under+ ( n1|u1 x n2|u2 -- n3|u3 x )
\
\ Add _n2|u2_ to _n1|u2_, giving the sum _n3|u3_.
\
\ Origin: Comus.
\
\ ----
\ : under+ ( n1|u1 x n2|u2 -- n3|u3 x )
\ rot + swap ;
\ ----
\
\ }doc
( +under )
code +under ( n1|u1 n2|u2 x -- n3|u3 x )
D9 c, \ exx
C1 c, \ pop bc
D1 c, \ pop de
E1 c, \ pop hl
19 c, \ add hl,de
E5 c, \ push hl
C5 c, \ push bc
D9 c, \ exx
jpnext end-code
\ doc{
\
\ +under ( n1|u1 n2|u2 x -- n3|u3 x )
\
\ Add _n2|u2_ to _n1|u2_, giving the sum _n3|u3_.
\
\ Origin: Comus.
\
\ ----
\ : +under ( n1|u1 n2|u2 x -- n3|u3 x )
\ >r + r> ;
\ ----
\
\ }doc
\ XXX TODO -- variant after PFE's `(under+)`:
\ : +under ( n1 n2 -- n1+n2 n2 ) tuck + swap ;
Replaced get-order with the version of eForth:
( get-order order@ )
\ Credits: Code from eForth.
: order@ ( a -- u*wid u )
dup @ dup if >r cell+ recurse r> swap 1+ exit
then nip ;
\ XXX TODO use the actual number of vocs in context,
\ not a trailing zero
: get-order ( -- u*wid u ) context order@ ;
2016-03-21
There is a problem: the default bank is restored. Added set-default-bank and get-default-bank and default-bank#.
Removed parens from names of the printing mode vectors.
Commented out the contrast ink calculation done in border.
2016-03-22
Removed the game _Nuclear Invaders_, which temporarily had been included in the library.
Splitted the library into 65 files. This makes it possible to include only the modules needed by the user application. The Makefile has been updated accordingly.
2016-03-23
Splitted the library files even more: strings, tools, value, data structures, control structures...
Added for-i for the for step loop and renamed di to dfor-i for the dfor dstep loop.
Renamed the words of Wil Baden's case structure, to avoid standard names:
( thiscase )
\ An alternative `case` structure that makes any
\ calculation easier.
\ 2015-11-14: First version.
\ 2016-03-24: Renamed to avoid standard names `case`, `of`
\ and `endof`.
\ Credits:
\
\ Adapted and modified from code written by Wil Baden,
\ published on Forth Dimensions (volume 8, number 5, page 29,
\ 1987-01).
need alias
' dup alias thiscase ( n -- n n )
' drop alias othercase ( n -- )
: ifcase ( n f -- )
postpone if postpone drop ; immediate compile-only
: exitcase ( n f -- )
postpone exit postpone then ; immediate compile-only
\ Usage example
\ ----
\ : say0 ." nul" ;
\ : say1 ." unu" ;
\ : say2 ." du" ;
\ : say-other ." alia" ;
\ : test ( n -- )
\ thiscase 0 = ifcase say0 exitcase
\ thiscase 1 = ifcase say1 exitcase
\ thiscase 2 = ifcase say2 exitcase
\ othercase say-other ;
\ ----
Fixed -suffix.
2016-03-24
Removed old fig-Forth loop indexes from the library.
Splitted the memory, benchmarking and locals library files.
Modified the license. Updated and completed all of the source file headers.
Added ?repeat.
2016-03-25
Splitted the numbers and printing library files. Renamed some library files to reduce the number of sections. Now there are 144 library files.
Extracted the code related to modules from the compilation library file. There are four implementations of modules. Renamed some words in order to prevent name clashes, or for clarity, and documented all of them.
Modified and factored wid>name: now it returns a name token, after >name and similar words, not its address:
: (wid>name) ( wid -- a ) [ 2 cells ] literal + ;
\ doc{
\
\ (wid>name) ( wid -- a )
\
\ Return the address _a_ which holds the _nt_ of _wid_ (or
\ zero if the word list has no associated name).
\
\ }doc
: wid>name ( wid -- nt|0 ) (wid>name) @ ;
\ doc{
\
\ wid>name ( wid -- nt|0 )
\
\ Return the _nt_ of _wid_ (or zero if the word list has no
\ associated name).
\
\ }doc
Simplified the storage and printing of the version number, by making release candidates start from 1 instead of 0.
2016-03-31
Added a new random number generator and updated the benchmarks:
( cgm-random )
\ Random Number Generator by C. G. Montgomery
\ 2015-12-13: found here:
\ http://web.archive.org/web/20060707001752/http://www.tinyboot.com/index.html
\
\ 2016-03-31: adapted to Solo Forth.
need rng-benchmark
2variable rloc $111 rloc ! \ seed with nonzero
: cgm-rnd ( -- u )
rloc 2@ $61BF um* rot 0 d+ over rloc 2! ;
\ good values for 16-bit systems: 61BF 62DC 6594 6363 5E9B 65E8
: cgm-random ( n -- 0..n-1 ) cgm-rnd um* nip ;
: cgm-rng-benchmark ( -- )
s" C. G. Montgomery $61BF" ['] cgm-random rng-benchmark ;
' rng-benchmark2 ' rng-benchmark defer!
cgm-rng-benchmark
' rng-benchmark1 ' rng-benchmark defer!
cgm-rng-benchmark
In the following benchmarks, a "cycle" is a loop of 49152 iterations. In every iteration, a random pixel is plot on the screen. The "Cycles" column shows how many cycles were done before the number of pixels didn't change anymore. Benchmarks that require more than one cycle have an additional entry with the data of their first cycle.
Results of the 16-bit versions of random:
| Code | Pixels | Time per cycle in frames (and seconds) | Cycles |
|---|---|---|---|
| C. G. Montgomery $5E9B | 49151 (099%) | 06917 (138 s) | 11 |
| C. G. Montgomery $5E9B | 30985 (063%) | 06917 (138 s) | first only |
| C. G. Montgomery $61BF | 49152 (100%) | 06916 (138 s) | 11 |
| C. G. Montgomery $61BF | 31024 (063%) | 06916 (138 s) | first only |
| C. G. Montgomery $62DC | 49152 (100%) | 06917 (138 s) | 12 |
| C. G. Montgomery $62DC | 30964 (063%) | 06916 (138 s) | first only |
| C. G. Montgomery $6363 | 49152 (100%) | 06917 (138 s) | 11 |
| C. G. Montgomery $6363 | 30917 (062%) | 06917 (138 s) | first only |
| C. G. Montgomery $6594 | 49151 (099%) | 06917 (138 s) | 10 |
| C. G. Montgomery $6594 | 31009 (063%) | 06916 (138 s) | first only |
| C. G. Montgomery $65E8 | 49152 (100%) | 06917 (138 s) | 12 |
| C. G. Montgomery $65E8 | 31006 (063%) | 06917 (138 s) | first only |
| DX-Forth | 49152 (100%) | 17733 (354 s) | 12 |
| DX-Forth | 31076 (063%) | 17734 (354 s) | first only |
| Gforth | 31189 (063%) | 09746 (194 s) | 1 |
| J. E. Rickenbacker | 08149 (016%) | 18458 (369 s) | 1 |
| J.M. Lazo | 12637 (025%) | 03349 (066 s) | 1 |
| Jupiter ACE manual | 05937 (012%) | 07652 (153 s) | 1 |
| Leo Brodie | 20818 (042%) | 09150 (183 s) | 1 |
| lina | 23945 (048%) | 09179 (183 s) | 1 |
| Milos Bazelides | 28465 (057%) | 03316 (066 s) | 1 |
| Spectrum Forth-83 | 05194 (010%) | 08741 (174 s) | 1 |
| Tetris for terminals | 02038 (004%) | 14200 (284 s) | 1 |
| vForth | 27448 (055%) | 14806 (296 s) | 10 |
| vForth | 20804 (042%) | 14806 (296 s) | first only |
| Z88 CamelForth | 05496 (011%) | 15683 (313 s) | 1 |
| Z80 Heaven | 32599 (066%) | 03371 (067 s) | 1 |
Results of the 8-bit versions of rnd:
| Code | Pixels | Time per cycle in frames (and seconds) | Cycles |
|---|---|---|---|
| Joe Wingbermuehle | 49145 (099%) | 01076 (021 s) | 29 |
| Joe Wingbermuehle | 25234 (051%) | 01075 (021 s) | first only |
| Milos Bazelides 1 | 00096 (000%) | 01047 (020 s) | 1 |
| Milos Bazelides 2 | 00096 (000%) | 01048 (021 s) | 1 |
| Z80 Heaven | 00096 (000%) | 01055 (021 s) | 1 |