\ Do not use this file except in compliance with the License. You may \ obtain a copy of the License at http://www.microcore.org/License/ \ Software distributed under the License is distributed on an "AS IS" basis, \ WITHOUT WARRANTY OF ANY KIND, either express or implied. \ See the License for the specific language governing rights and limitations \ under the License. \ \ The Original Code is: MICROCORE.FS \ \ Last change: KS 22.10.2015 15:36:25 \ \ The Initial Developer of the Original Code is Klaus.Schleisiek AT microcore.org. \ Port to the gforth system, extensions and adding the debugger by Ulrich.E.Hoffmann AT xlerb.de \ \ MicroCore Forth Cross-compiler \ This code loads on the public domain gforth http://www.gnu.org/software/gforth/gforth.html Forth definitions : $Rev: &36 parse s, postpone \ ; immediate : $Date:: [char] # parse s, postpone \ ; immediate Create revision $Rev$ Subversion revision number Create datum $Date:: $ zuletzt in Subversion eingescheckt : .version ( -- ) ." 2.54 " ; \ revision count type ; : .date ( -- ) datum count type ; \ Debugger forward references Defer t_execute Defer >t Defer t> Defer t_@ Defer t_! Defer send-image : 2** ( n -- 2**n ) 1 swap 0 ?DO 2* LOOP ; : 2// ( n -- log2_n ) >r 0 BEGIN dup 2** r@ < WHILE 1+ REPEAT r> drop ; prog_ram_width 0<> Constant VAN_NEUMANN immediate \ read/writeable program memory? prog_addr_width 2** Constant #maxprog rs_base_width 2** Constant #maxdata \ size of data memory below return stack data_width 8 /mod swap 0= 1+ + Constant #bytes \ bytes per cell data_width 2** 1- Constant #datamask data_width 1- 2** negate Constant #signbit data_width Constant #databits inst_width Constant #code #code 2** 1- Constant #codemask data_width #code 1- /mod swap 0= 1+ + Constant #nibbles \ nibbles needed to represent any number : tu. ( addr -- ) #datamask and u. ; Variable goto_nibbles prog_addr_width 1+ #code 1- /mod swap 0= 1+ + goto_nibbles ! \ default number of nibbles to be used for forward referencing GOTO and ?GOTO : #goto_nibbles ( -- u ) goto_nibbles @ ; \ --------------------------------------------------------------------------- \ accessing the target's program memory \ --------------------------------------------------------------------------- Create Memory #datamask #maxprog umin 5 + cells allot Variable Verbose Verbose off Variable Tcp \ TargetCodePointer Variable Transferred \ Target image transfer pointer Variable Tdp \ TargetDataPointer Variable Sequential \ number of past opcodes available for peep-hole optimization Variable Defining Defining on \ differentiates between cross-compilation and Macro and Compiler extensions Variable Macro Macro off \ holds the current macro tag to be included in code compilation. 0 => no macro Variable Macro# Macro# off \ holds the last assigned macro number $FF000000 Constant #macromask \ macro# is embedded in opcode field #macromask invert Constant #linkmask \ unresolved link in lower 24 bits of the target memory Variable Macros Macros off \ linked list of all macros Variable Labels Labels off \ linked list of all labels Variable Colons Colons off \ Builds a linked list of :-definitions for the disassembler Variable Operators Operators off \ Linked list of all operators, used by the disassembler Variable Branches Branches off \ Linked list of all branch operators, used by the disassembler Variable Constants Constants off \ linked list of all constants Variable Variables Variables off \ linked list of all creates and variables Variable Reinterpreted Reinterpreted off \ Reinterpreted will be set to true on second compilation run Variable Start \ Source code location for reinterpretation Variable Marking \ Marker for reinterpretation Variable Shorter \ number of instructions the program will be shorter after reinterpretation Variable Gotos \ counter for the number of gotos used 0 Constant #shift \ Tcp offset for first compilation run. Seems not to be necessary, but I am not sure. : Op ( n -- opcode ) #litmask and ; : >memory ( caddr -- addr ) cells Memory + ; : t! ( n caddr -- ) >memory ! ; : t@ ( caddr -- n ) >memory @ ; : opcode@ ( caddr -- op ) t@ #codemask and ; : macro@ ( caddr -- # ) t@ -&24 shift ; : macro! ( n caddr -- ) swap Macro @ &24 shift or swap t! ; : link@ ( caddr -- link ) t@ #linkmask and ; : there ( -- addr ) Tcp @ ; : tallot ( n -- ) dup Sequential @ + 0 max Sequential ! Tcp +! Tcp @ #maxprog u< ?EXIT true Abort" out of program memory" ; : t, ( n -- ) dup [ #codemask invert ] Literal and abort" not an opcode" there macro! 1 tallot ; : trap-addr ( n -- addr ) usr_vect_width 2** * ; \ --------------------------------------------------------------------------- \ manipulating the stack field \ --------------------------------------------------------------------------- : patch_stack ( op stack -- op' ) swap [ $18 invert $FF and ] Literal and or ; : Stack: ( stack -- ) Create , Does> ( op -- op' ) @ patch_stack ; #none Stack: NONE #pop Stack: POP #push Stack: PUSH #both Stack: BOTH \ --------------------------------------------------------------------------- \ peep-hole optimizer \ --------------------------------------------------------------------------- : | ( -- ) Sequential off ; \ break peep-hole optimizer : prev@ ( -- opcode | 0 ) Sequential @ IF there 1 - t@ #codemask and EXIT THEN false ; : pprev@ ( -- opcode | 0 ) Sequential @ 1 > IF there 2 - t@ #codemask and EXIT THEN false ; : ppprev@ ( -- opcode | 0 ) Sequential @ 2 > IF there 3 - t@ #codemask and EXIT THEN false ; : Match ( opcode -- ) Create Op , Does> ( opcode -- f ) @ xor #codemask and 0= ; op_NOP Match nop? op_DUP Match dup? op_QDUP Match ?dup? op_ZEQU Match 0=? op_ZLESS Match 0r? op_RPOP Match r>? op_ADD Match plus? op_SUB Match minus? op_CARRYQ Match c_op? op_OVFLQ Match ovl_op? \ --------------------------------------------------------------------------- \ Opcode-field compilers and Opcode compiler \ --------------------------------------------------------------------------- : tempcode ( addr -- ) there >r @ dup t, Macro @ IF rdrop drop EXIT THEN op_EXIT t, there r@ - r> Tcp ! there swap false send-image Verbose @ IF cr . ." instruction " ELSE drop THEN there t_execute ; : Op: ( n (comment -- ) Create , \ here the instruction code is layed down which will be compiled into the target memory postpone ( \ skip over comment ) also Forth ' , previous \ here the xt of the word is layed down which will be executed during interpretation in the target here Operators @ , Operators ! Does> ( -- ) comp? IF @ t, EXIT THEN dbg? IF tempcode EXIT THEN cell+ @ execute ; : don't ( -- ) True abort" can not be executed" ; : Brn: ( n (comment -- ) Create , \ here the instruction code is layed down which will be compiled into the target memory postpone ( \ skip over comment ) also Forth ' , previous \ here the xt of the word is layed down which will be executed during interpretation in the target here Branches @ , Branches ! Does> ( -- ) comp? IF @ t, EXIT THEN dbg? IF tempcode EXIT THEN cell+ @ execute ; : (Macro: ( -- addr ) \ | xt | macro# | link | Create here 0 , 1 Macro# +! Macro# @ , here Macros @ , Macros ! Does> Macro @ 0= dup IF over cell+ @ Macro ! \ set Macro when NOT already executing a macro definition dbg? exec? and dup IF there >r ] THEN >r THEN >r @ execute r> 0= ?EXIT Macro @ Macro off r> IF op_EXIT t, postpone [ there r@ - r> Tcp ! there swap false send-image Verbose @ IF cr dup . ." macro " THEN there t_execute THEN drop ; 1414 Constant #macro : Macro: ( -- addr # ) (Macro: :noname #macro ; : ;macro ( addr xt #macro -- ) #macro ?pairs postpone ; ( addr xt ) swap ! ; immediate : ; ( # -- ) \ redefine ; so that it can be used to terminate macro definitions dup #macro = IF postpone ;macro EXIT THEN postpone ; ; immediate Vocabulary Target \ Vocabulary for all Target definitions Root definitions ' Forth Alias H immediate \ "Host" - short-hand definition to switch context also within a definition ' Target Alias T immediate Forth definitions Vocabulary Commandlist : Commands: ( -- ) Commandlist definitions ; \ --------------------------------------------------------------------------- \ Target literals and addresses are composed of literal-nibbles \ preceeding opcodes which use them \ --------------------------------------------------------------------------- : /nibble ( lit -- nib lit' ) dup #litmask and #literal or swap #literal / ; : last_nibble? ( nib lit -- f ) 0 case? IF [ #literal u2/ ] Literal and 0= EXIT THEN -1 = IF [ #literal u2/ ] Literal and EXIT THEN drop False ; : >nibbles ( lit -- nib_q .. nib_1 q ) \ convert literal into q nibbles 0 >r BEGIN r> 1+ >r /nibble 2dup last_nibble? UNTIL drop r> ; : nibbles ( lit -- quan ) \ number of nibbles needed to represent lit 0 >r BEGIN r> 1+ >r /nibble tuck last_nibble? UNTIL drop r> ; : *nibble ( nib lit' -- lit ) #literal * swap #litmask and or ; : nibbles> ( nib_q .. nib_1 q -- lit ) \ convert q nibbles into literal dup 0= ABORT" no nibbles available" >r #litmask and dup [ #literal u2/ ] Literal and IF #literal negate or THEN r> 1 ?DO *nibble LOOP ; : nibbles! ( nib_q .. nib_1 quan caddr -- ) swap bounds DO I macro! LOOP ; : lit_op? ( op -- f ) #literal and 0<> ; : ?nop, ( -- ) prev@ lit_op? 0= ?EXIT op_NOP t, ; : nibbles, ( nib_q .. nib_1 quan -- ) ?nop, there over tallot nibbles! ; : nibble_count ( caddr -- quan ) dup BEGIN dup t@ lit_op? WHILE 1+ REPEAT swap - ; : nibbles@ ( caddr -- nib_q .. nib_1 quan ) dup BEGIN dup t@ lit_op? WHILE dup t@ >r 1+ REPEAT swap - dup BEGIN ?dup WHILE 1- r> -rot REPEAT ; : lit_addr ( caddr -- caddr' | 0 ) \ search for the beginning of a sequence of lits >r 0 BEGIN r@ over - t@ lit_op? WHILE 1+ REPEAT dup IF r@ swap 1- - THEN rdrop ; : last_lit ( -- lit ) there 1- lit_addr ?dup 0= ?EXIT nibbles@ dup negate tallot nibbles> ; : nibbles_needed ( caddr -- quan ) nibbles@ nibbles> nibbles ; : ?literal ( lit -- lit' ) \ range check and sign extension dup dup 0< IF #datamask or 1+ ELSE [ #datamask invert ] Literal and THEN IF u. true abort" number beyond data path width" THEN dup #signbit and IF [ #datamask invert ] Literal or ELSE #datamask and THEN \ sign extension ; : lit, ( n -- ) \ compiles a literal into the minimum number of nibbles. ?literal >nibbles nibbles, ; : fixed, ( n quan -- ) \ compiles a literal into quan nibbles. >r ?literal r@ 0 ?DO /nibble LOOP 2dup last_nibble? 0= abort" literal does not fit into fixed field" drop r> nibbles, ; \ --------------------------------------------------------------------------- \ Arithmetic optimizer, looking for "2dup " and "swap -" \ --------------------------------------------------------------------------- : 2dup? ( -- f ) prev@ over? IF pprev@ over? EXIT THEN false ; : Arith: ( n (comment -- ) Op: Does> ( -- ) comp? IF @ 2dup? IF -2 tallot | #both xor THEN t, EXIT THEN dbg? IF tempcode EXIT THEN cell+ @ execute ; : Sub: ( n (comment -- ) Op: Does> ( -- ) comp? IF @ prev@ swap? IF [ #group invert ] Literal and op_SSUB #group and or -1 tallot THEN 2dup? IF -2 tallot | #both xor THEN t, EXIT THEN dbg? IF tempcode EXIT THEN cell+ @ execute ; \ --------------------------------------------------------------------------- \ stack optimizers \ --------------------------------------------------------------------------- : Drop: ( n (comment -- ) Op: Does> ( -- ) comp? IF @ prev@ swap? IF -1 tallot drop op_NIP THEN t, EXIT THEN dbg? IF tempcode EXIT THEN cell+ @ execute ; : Over: ( n (comment -- ) Op: Does> ( -- ) comp? IF @ prev@ swap? IF -1 tallot drop op_TUCK THEN t, EXIT THEN dbg? IF tempcode EXIT THEN cell+ @ execute ; : Swap: ( n (comment -- ) Op: Does> ( -- ) comp? IF @ prev@ over? IF -1 tallot drop op_UNDER THEN t, EXIT THEN \ "over swap" = "under" prev@ swap? IF -1 tallot EXIT THEN \ throw out "swap swap" dbg? IF tempcode EXIT THEN cell+ @ execute ; \ --------------------------------------------------------------------------- \ "r> >r" is a noop \ --------------------------------------------------------------------------- : Tor: ( n (comment -- ) Op: Does> ( -- ) comp? IF @ prev@ r>? IF -1 tallot drop EXIT THEN t, EXIT THEN dbg? IF tempcode EXIT THEN cell+ @ execute ; \ --------------------------------------------------------------------------- \ replace "call exit" by branch \ --------------------------------------------------------------------------- : Ex: ( n (comment -- ) Op: Does> ( -- ) comp? IF @ prev@ call? IF -1 tallot drop op_ALWAYS THEN t, EXIT THEN dbg? IF tempcode EXIT THEN cell+ @ execute ; \ --------------------------------------------------------------------------- \ Optimizer: Zwei Literale hintereinander gefolgt von "+" während der \ Kompilation addieren und zu einem Literal machen \ --------------------------------------------------------------------------- \ : prevlit? ( -- caddr | 0 ) \ prev@ nop? IF 2 \ BEGIN Sequential @ over > there over - t@ literal? and WHILE 1+ REPEAT \ 1- dup 1 > IF there swap - EXIT THEN drop \ THEN false \ ; \ : Add: ( n -- ) Op: \ Does> ( -- ) \ comp? IF @ 2dup? IF -2 tallot | #both xor THEN t, EXIT THEN \ dbg? IF tempcode EXIT THEN \ cell+ @ execute \ ; \ \ : .lit ( caddr -- ) nibbles@ nibbles> . ; \ --------------------------------------------------------------------------- \ Fetch/Load optimizer looking for small address increments \ --------------------------------------------------------------------------- : Mem: ( n -- ) Op: \ optimize "n + ld", "n - st" Does> ( -- ) comp? IF @ 0 prev@ plus? prev@ minus? or IF pprev@ lit_op? IF ppprev@ lit_op? 0= IF pprev@ 1 nibbles> prev@ minus? IF negate THEN [ WITH_BYTES ] [IF] dup -2 3 within [ELSE] dup -4 4 within [THEN] IF #group and -2 tallot nip Sequential @ IF prev@ nop? IF -1 tallot THEN THEN ELSE drop THEN THEN THEN THEN or t, EXIT THEN dbg? IF tempcode EXIT THEN cell+ @ execute ; \ --------------------------------------------------------------------------- \ Instructions and macros \ --------------------------------------------------------------------------- Target definitions \ stack op_NOP Op: nop ( -- ) noop op_DROP Drop: drop ( n -- ) drop Macro: 2drop ( n n -- ) comp? IF T drop drop H EXIT THEN 2drop ; op_DUP Op: dup ( n -- n n ) dup op_OVER Over: over ( 1 2 -- 1 2 1 ) over Macro: 2dup ( d -- d d ) comp? IF T over over H EXIT THEN 2dup ; op_QDUP Op: ?dup ( n -- 0 | n n ) ?dup op_SWAP Swap: swap ( 1 2 -- 2 1 ) swap op_ROT Op: rot ( 1 2 3 -- 3 1 2 ) rot op_NROT Op: -rot ( 1 2 3 -- 2 3 1 ) -rot op_NIP Op: nip ( 1 2 -- 2 ) nip op_UNDER Op: under ( 1 2 -- 1 1 2 ) don't op_TUCK Op: tuck ( 1 2 -- 2 1 2 ) don't \ return stack op_RPUSH Tor: >r ( n -- ) don't op_RPOP Op: r> ( -- n ) don't op_RTOR Op: r@ ( -- n ) don't op_RDROP Op: rdrop ( -- ) don't op_INDEX Op: I ( -- i ) don't \ branch, call, exit op_ALWAYS Brn: branch ( addr -- ) don't \ ELSE, REPEAT op_QZERO Brn: ?-branch ( addr ?f -- ) don't \ ?dup IF op_SIGN Brn: s-branch ( addr f -- ) don't \ 0< 0= IF op_NSIGN Brn: ns-branch ( addr f -- ) don't \ 0< IF op_ZERO Brn: 0=branch ( addr f -- ) don't \ IF op_NZERO Brn: 0<>branch ( addr f -- ) don't \ 0= IF op_NOVFL Brn: no-branch ( addr -- ) don't \ ovfl? IF op_NCARRY Brn: nc-branch ( addr -- ) don't \ carry? IF op_NEXT Brn: tor-branch ( addr -- ) don't \ NEXT op_FWRD Op: >FOR ( n -- R: n ) don't op_BACK Op: ( n -- f ) comp? IF T 0= 0= H EXIT THEN 0= 0= ; Macro: = ( n1 n2 -- f ) comp? IF T - 0= H EXIT THEN = ; Macro: < ( n1 n2 -- f ) comp? IF T - less? H EXIT THEN < ; Macro: > ( n1 n2 -- f ) comp? IF T swap - less? H EXIT THEN > ; \ unary arithmetic op_NOT Op: invert ( u1 -- u2 ) invert WITH_MULT [IF] op_SHIFT Op: shift ( u1 n -- u2 ) don't op_ASHIFT Op: ashift ( n1 n -- n2 ) don't op_DSHIFT Op: dshift ( d1 n -- d2 ) don't op_DASHIFT Op: dashift ( d1 n -- d2 ) don't Macro: 2* ( u1 -- u2 ) comp? IF 1 lit, T shift H EXIT THEN 2* ; Macro: u2/ ( u1 -- u2 ) comp? IF -1 lit, T shift H EXIT THEN u2/ ; Macro: 2/ ( n1 -- n2 ) comp? IF -1 lit, T ashift H EXIT THEN 2/ ; [ELSE] op_SHIFT Op: (shift ( u1 -- u2 ) don't Macro: shift ( n1 n -- n2 ) ?comp T >FOR (shift FOR (ashift FOR (dshift FOR (dashift r (norm float ( n exp -- r ) don't \ Macro: >float ( n exp -- r ) ?comp T normalize (>float H ; op_INTEG Op: float> ( r -- n exp ) don't [THEN] \ load and store op_LOAD Mem: ld ( addr -- n addr' ) don't op_STORE Mem: st ( n addr -- addr' ) don't Macro: @ ( addr -- n ) ?comp T ld drop H ; Macro: ! ( n addr -- ) ?comp T st drop H ; Macro: 2! ( d addr -- ) ?comp T st H 1 lit, T + ! H ; Macro: 2@ ( addr -- d ) ?comp 1 lit, T + ld H -1 lit, T + @ H ; op_PST Op: +st ( n addr -- addr ) don't Macro: +! ( n addr -- ) ?comp T +st drop H ; \ indivisible ld-st operation op_WLOCAL Op: lst ( n rel -- addr ) don't op_RLOCAL Op: lld ( rel -- n addr ) don't Macro: l@ ( rel -- n ) ?comp T lld drop H ; Macro: l! ( n rel -- ) ?comp T lst drop H ; WITH_BYTES [IF] op_cLD Op: cLD ( caddr -- u8b caddr ) don't op_wLD Op: wLD ( caddr -- u16b caddr ) don't op_iLD Op: iLD ( caddr -- n caddr ) don't op_cST Op: cST ( 8b caddr -- addr ) don't op_wST Op: wST ( 16b caddr -- addr ) don't op_iST Op: iST ( n caddr -- addr ) don't Macro: c@ ( caddr -- u8b ) ?comp T cLD drop H ; Macro: w@ ( caddr -- u16b ) ?comp T wLD drop H ; Macro: i@ ( caddr -- n ) ?comp T iLD drop H ; Macro: c! ( 8b caddr -- ) ?comp T cST drop H ; Macro: w! ( 16b caddr -- ) ?comp T wST drop H ; Macro: i! ( n caddr -- ) ?comp T iST drop H ; op_SIGNED Op: signed ( 16b -- n ) don't Macro: >byte ( addr -- caddr ) ?comp T 2* 2* H ; Macro: byte> ( caddr -- addr ) ?comp T u2/ u2/ H ; [THEN] WITH_TASKS [IF] op_WTASK Op: tst ( n rel -- addr ) don't op_RTASK Op: tld ( rel -- n addr ) don't Macro: t@ ( rel -- n ) ?comp T tld drop H ; Macro: t! ( n rel -- ) ?comp T tst drop H ; Macro: task@ ( -- addr ) ?comp task_reg lit, T ld drop H ; Macro: myself ( -- addr ) ?comp task_reg lit, T ld drop H ; Macro: task! ( addr -- ) ?comp task_reg lit, T st drop H ; [THEN] \ registers op_WSTAT Op: status! ( n -- ) don't op_RSTAT Op: status@ ( -- n ) don't op_SSTAT Op: st_set ( mask -- ) don't Macro: st_reset ( mask -- ) ?comp T invert st_set H ; Macro: ei ( -- ) ?comp ie_bit 2** lit, T st_set H ; \ #ie bit Macro: di ( -- ) ?comp [ ie_bit 2** invert ] Literal lit, T st_set H ; \ #ie bit Macro: carry-set ( -- ) ?comp c_bit 2** lit, T st_set H ; \ #c bit Macro: carry-reset ( -- ) ?comp [ c_bit 2** invert ] Literal lit, T st_set H ; \ #c bit op_WDSP Op: dsp! ( n -- ) don't op_RDSP Op: dsp@ ( -- n ) don't op_WRSP Op: rsp! ( n -- ) don't op_RRSP Op: rsp@ ( -- n ) don't Macro: ie! ( n -- ) ?comp int_reg lit, T ! H ; Macro: ints@ ( -- n ) ?comp int_reg lit, T @ H ; Macro: flags@ ( -- n ) ?comp flag_reg lit, T @ H ; Macro: pass ( n -- ) ?comp flag_reg lit, T ! H ; \ operates on semaphor hardware Macro: ctrl! ( mask -- ) ?comp ctrl_reg lit, T ! H ; Macro: ctrl@ ( -- u ) ?comp ctrl_reg lit, T @ H ; \ --------------------------------------------------------------------------- \ branching \ Due to relative addressing, the number of nibbles needed for a branch address \ varies. At first, only one nibble is assumed to be sufficient to hold the offset. \ When the compiler finds that more nibbles are needed, the source code is re-interpreted \ --------------------------------------------------------------------------- Forth definitions Variable Prefix Prefix off \ Prefix codes for conditionals to handle e.g. "carry IF" etc. 0 Constant #if-bit 1 Constant #nif-bit 2 Constant #z-bit 3 Constant #nz-bit 4 Constant #s-bit 5 Constant #ns-bit 6 Constant #c-bit 7 Constant #nc-bit 8 Constant #o-bit 9 Constant #no-bit 10 Constant #docall 12 Constant #branch 14 Constant #?-bit 15 Constant #addr : complement ( -- ) Prefix @ #docall < IF Prefix @ 1 xor Prefix ! THEN ; : if_prefix ( -- ) #if-bit Prefix ! ; : ?strange_prefix ( n -- ) ?dup 0= ?EXIT if_prefix dup . abort" unexpected Prefix " ; : >branch ( caddr -- br.addr quan.nibbles ) \ length of branch lit field 0 BEGIN over t@ lit_op? WHILE 1+ swap 1+ swap REPEAT ; : there ; : r \ minimum length of branch BEGIN over there r@ + 1+ - \ branch offset nibbles r@ > \ does branch offset fit? WHILE r> 1+ >r \ try with offset one nibble longer REPEAT drop ( get rid of prefix ) \ Reinterpreted @ IF r@ there Shorter @ + nibble_count - Shorter +! THEN there r@ + 1+ - r> fixed, drop-source ; : >mark ( quan.nibbles prefix -- sca caddr ) ?nop, | swap >r source> there rot drop ( get rid of prefix ) #literal r> 0 ?DO dup t, LOOP drop ; : >resolve ( sca caddr -- quan.nibbles.needed | 0 ) ?nop, | dup >r dup >branch >r \ R: offset width allocated swap t@ #litmask and + \ fetch numerical value of first emplaced branch offset nibble and correct branch start address there swap 1+ - >nibbles \ branch offset dup r> - \ does offset fit? IF dup >r ndrop \ remove nibbles r> r> Tcp ! swap >source EXIT THEN r> nibbles! drop-source false ; : conditional, ( -- ) Prefix @ if_prefix #docall case? IF T JSR H EXIT THEN #branch case? IF T branch H EXIT THEN #?-bit case? IF T ?-branch H EXIT THEN \ consumes false flag #s-bit case? IF T s-branch H EXIT THEN \ consumes flag #ns-bit case? IF T ns-branch H EXIT THEN \ consumes flag #if-bit case? IF T 0=branch H EXIT THEN \ consumes flag #nif-bit case? IF T 0<>branch H EXIT THEN \ consumes flag #no-bit case? IF T no-branch H EXIT THEN #nc-bit case? IF T nc-branch H EXIT THEN #addr case? IF T nop H EXIT THEN ?strange_prefix ; $101 Constant #if $202 Constant #else $303 Constant #begin $404 Constant #while $505 Constant #for $606 Constant #colon $707 Constant #trap $808 Constant #?for : (if ( quan.offset -- sca caddr # ) Prefix @ #if-bit = IF prev@ ?dup? IF -1 tallot #?-bit Prefix ! THEN THEN Prefix @ #if-bit = IF prev@ 0=? IF -1 tallot #nif-bit Prefix ! THEN THEN Prefix @ #if-bit = IF prev@ 0mark conditional, #if ; : (else ( quan.offset -- sca caddr # ) #branch >mark T branch H #else ; \ --------------------------------------------------------------------------- \ Due to the variable length branch offset fields ELSE does not compile anything \ This is handled by THEN instead. ELSE leaves its unique check digit. Therefore, \ THEN "knows" when it was preceeded by an ELSE. \ \ THEN tests the check digit: If it was #ELSE, \ the branch between ELSE ... THEN is compiled first yielding the actual branch \ offset needed for ELSE. Thereafter, the IF ... ELSE branch is compiled. \ --------------------------------------------------------------------------- Variable (doGoto : doGoto ( -- xt ) (doGoto @ ; Variable (doLabel : doLabel ( -- xt ) (doLabel @ ; Variable (doColon : doColon ( -- xt ) (doColon @ ; : optimize_?goto ( -- ) Prefix @ #if-bit = IF prev@ 0branch H EXIT THEN #nif-bit case? IF T 0=branch H EXIT THEN #o-bit case? IF T no-branch H EXIT THEN #c-bit case? IF T nc-branch H EXIT THEN ?strange_prefix ; : resolved_goto ( caddr -- ) Prefix @ #addr = IF lit, EXIT THEN complement 0 swap Prefix @ r there r@ r@ 1+ nibble_count 1+ >r \ determine # of lit-nibbles allocated r@ + dup t@ nop? IF 2drop there ELSE 1+ - THEN \ abs. address when NOP, relative branch otherwise dup nibbles r@ > abort" goto offset out of range, increase Variable goto_nibbles" r@ 0 ?DO /nibble LOOP drop r> r> nibbles! ; : optimize_goto_branch ( -- ) Reinterpreted @ 0= ?EXIT temp_hex cr there dup . Shorter @ + dup . dup nibbles_needed dup . swap nibble_count dup . over - Shorter +! goto_nibbles ! \ there Shorter @ + dup nibbles_needed swap nibble_count \ over - Shorter +! goto_nibbles ! ; Target definitions Forth : IF ( -- sca caddr #if ) ?comp 1 (if ; : ELSE ( sca1 caddr1 #if -- sca1 caddr1 sca2 caddr2 #else ) ?comp #if ?pairs 1 (else ; : THEN ( sca caddr #if | sca1 caddr1 sca2 caddr2 #else -- ) ?comp #if case? IF >resolve ?dup 0= ?EXIT (if EXIT THEN #else ?pairs dup >r >resolve ?dup IF rdrop (else EXIT THEN r> there >r >branch drop 1+ Tcp ! >resolve ?dup IF rdrop (if EXIT THEN r> Tcp ! ; : BEGIN ( -- sca caddr #begin ) ?comp resolve ?dup IF (if THEN ; : UNTIL ( sca caddr #begin -- ) ?comp #begin ?pairs Prefix @ ? IF -1 tallot ELSE T >r H THEN ? IF -1 tallot ELSE T >r H THEN 1 (else drop data ( daddr -- addr ) dup #maxdata u> abort" data memory access out of range" cells Data + ; : d! ( n daddr -- ) >data ! ; : d@ ( daddr -- n ) >data @ ; Variable Initials Initials off 0 , 0 , \ linked list for data memory initialisation : last_initial ( -- addr ) Initials BEGIN dup @ WHILE @ REPEAT ; : initialised? ( -- f ) last_initial cell+ @ ; : uninitialised? ( -- f ) last_initial cell+ cell+ @ ; : save_dp_block ( from to -- ) over 1- lit, swap ?DO I d@ lit, T op_DATA t, H LOOP \ save values in progmem T op_DROP t, H ; : save-data ( -- ) s" have Dp" evaluate IF Tdp @ s" Dp !" evaluate THEN Initials BEGIN dup cell+ @ ?dup \ anything to initialise? IF invert over cell+ cell+ @ ?dup 0= IF Tdp @ invert THEN invert save_dp_block THEN @ ?dup 0= UNTIL T op_EXIT t, H ; Target definitions Forth : initialised ( -- ) initialised? 0= IF Tdp @ invert last_initial cell+ ! EXIT THEN uninitialised? ?dup 0= ?EXIT invert Tdp @ = IF 0 last_initial cell+ cell+ ! EXIT THEN \ continue previous block here 0 , Tdp @ invert , 0 , last_initial ! ; : uninitialised ( -- ) initialised? 0= ?EXIT Tdp @ invert last_initial cell+ cell+ ! ; \ --------------------------------------------------------------------------- \ data types in data RAM \ --------------------------------------------------------------------------- : code-origin ( caddr -- ) ?exec dbg? IF t> THEN Tcp @ abort" CODE-ORIGIN can only be used once." #shift Reinterpreted @ IF Shorter ! ELSE + THEN Tcp ! | ; : data-origin ( taddr -- ) ?exec dbg? IF t> THEN Tdp ! ; : code@ ( -- caddr ) ?exec Tcp @ dbg? IF >t THEN ; : Constant ( n -- ) dbg? IF t> THEN Constant here Constants @ , Constants ! Does> @ ( -- n ) comp? IF lit, EXIT THEN dbg? IF >t THEN ; : 2constant ( n1 n2 -- ) dbg? IF t> t> swap THEN Constant , here Constants @ , Constants ! Does> dup @ swap cell+ @ ( -- n1 n2 ) comp? IF lit, lit, EXIT THEN dbg? IF >t >t THEN ; : Create ( -- ) Tdp @ Constant here Variables @ , Variables ! Does> @ ( -- n ) comp? IF lit, EXIT THEN dbg? IF >t THEN ; : Variable ( -- ) T Create H 1 Tdp +! ; : Register ( addr -- ) dbg? IF t> THEN Constant here Variables @ , Variables ! Does> @ ( -- n ) comp? IF lit, EXIT THEN dbg? IF >t THEN ; : Label ( -- ) | source> have swap >source IF ' dup cell+ @ doGoto - abort" not a goto" doLabel over cell+ ! \ converts "goto" into a "label" >body dup @ there rot ! \ patch the real target address BEGIN dup link@ swap resolve_goto ?dup 0= UNTIL \ resolve all forward references EXIT THEN Latest there Constant Last ! here Labels @ , Labels ! Does> ( -- caddr ) [ here (doLabel ! ] @ comp? IF lit, EXIT THEN dbg? IF >t THEN ; immediate : ?GOTO ( -- ) 1 Gotos +! optimize_?goto ?nop, | source> have swap >source IF ' dup cell+ @ doGoto case? IF ( goto-xt ) optimize_goto_branch >body dup @ unresolved_goto swap ! EXIT THEN dup doLabel = swap doColon = or 0= abort" not a label or colon definition" >body @ resolved_goto EXIT THEN optimize_goto_branch Latest 0 unresolved_goto Constant Last ! here Labels @ , Labels ! Does> ( -- ) [ here (doGoto ! ] abort" unresolved forward reference" ; immediate : GOTO ( -- ) #branch Prefix ! T postpone ?goto H ; immediate : CALL ( -- ) #docall Prefix ! T postpone ?goto H ; immediate : ADDR ( -- ) #addr Prefix ! T postpone ?goto H ; immediate : Version ( f -- ) Constant immediate ; : [ ( -- ) postpone [ ; immediate : ] ( -- ) ?exec ] ; : trap-addr ( n -- addr ) ?exec trap-addr dbg? IF >t THEN ; \ --------------------------------------------------------------------------- \ Words which are useful to execute interactively during target compilation. \ To be extended when the need arises \ --------------------------------------------------------------------------- : . ?exec . ; : .s ?exec .s ; : u. ?exec tu. ; : ( postpone ( ; immediate \ ) : \ postpone \ ; immediate : \\ ?exec postpone \\ ; : decimal ?exec decimal ; : hex ?exec hex ; : include ?exec include ; : 2** ?exec 2** ; : 2// ?exec 2// ; : reveal ?exec reveal ; : ' ( -- caddr ) ?exec ' >body @ ; \ undebugged : postpone ( -- ) ?comp postpone postpone ; immediate Forth definitions : Message ( n -- ) Current save Context save source> Forth definitions over Constant >source Target definitions T Constant H ; : ;USR ( there trapaddr # -- ) ?comp #trap ?pairs postpone [ there swap - [ 1 trap-addr ] Literal u> IF cr ." USR vector definition longer than " [ 1 trap-addr ] Literal . ." bytes." THEN Tcp ! ; Root definitions Forth ' ' Alias h' ' Target Alias Target ' \ Alias -- immediate -- VHDL compatibility mode ' definitions Alias definitions ' \\ Alias \\ immediate Forth definitions include oop.fs Target definitions Forth : TRAP: ( trap-number -- there trapaddr # ) dup #usrmask > abort" USR number out of range" ?exec Create dup #usr or , trap-addr there over Tcp ! swap ] #trap | \ leaves there, addr and #trap for check by ;USR here Operators @ , Operators ! Does> ( -- ) comp? IF @ t, EXIT THEN dbg? IF tempcode EXIT THEN don't ; : : ( -- # ) ?exec source> >r have ?dup IF dup cell+ @ doGoto = IF doColon over cell+ ! \ convert a goto into a colon definition >body dup cell+ >r dup @ there rot ! \ patch the real target address BEGIN dup link@ swap resolve_goto ?dup 0= UNTIL \ resolve all forward references Labels BEGIN dup @ r@ - WHILE @ REPEAT r@ @ swap ! \ link word out of LABELS list Colons @ r@ ! r> Colons ! \ and link it into COLONS list rdrop ] #colon EXIT ELSE drop THEN THEN r> >source Create hide there , ] #colon \ leaves #colon during compilation for ";" to recognize here Colons @ , Colons ! | if_prefix Does> ( -- ) [ here (doColon ! ] @ comp? IF source> swap #docall -- # ) \ define a Method ?exec Create hide there , ] #colon \ leaves #colon during compilation for ";" to recognize here Colons @ , Colons ! | if_prefix Does> ( -- ) Method @ comp? IF source> swap #docall r? IF -1 tallot ?nop, T branch H ELSE T exit H THEN THEN postpone [ reveal dbg? IF Transferred @ there over - false send-image there Transferred ! THEN EXIT THEN dup #trap = IF T exit H ;USR EXIT THEN postpone ; ; immediate : ;noexit ( # -- ) ?comp #colon ?pairs postpone [ reveal ; immediate : recursive ( -- ) ?comp reveal ; immediate : recurse ( -- ) ?comp reveal source> Latest name>int >body @ #docall -- caddr ) ?comp ' >body @ lit, ; immediate : Literal ( n -- ) ?comp Defining @ IF postpone Literal postpone lit, EXIT THEN dbg? IF t> THEN lit, ; immediate : [char] ( -- ) ?comp bl parse drop c@ lit, ; immediate : char ( -- n ) ?exec bl parse drop c@ dbg? IF >t THEN ; : here ( -- addr ) ?exec Tdp @ dbg? 0= IF >t THEN ; : allot ( n -- ) ?exec Tdp +! ; : , ( n -- ) ?exec Tdp @ 1 Tdp +! d! ; : ! ( n addr -- ) dbg? comp? or IF T ! H EXIT THEN d! ; : @ ( addr -- n ) dbg? comp? or IF T @ H EXIT THEN d@ ; : 2! ( d addr -- ) dbg? comp? or IF T 2! H EXIT THEN dup >r d! r> 1+ d! ; : immediate ( -- ) ?exec immediate ; Forth Root definitions gforth_062 [IF] : host-compile ( -- ) ['] host-compiler 'interpreter ! ['] host-compiler 'compiler ! ['] host-compiler IS parser Defining on Only Forth also ; [THEN] gforth_070 [IF] : host-compile ( -- ) ['] host-compiler1 'interpreter ! ['] host-compiler1 'compiler ! ['] host-compiler1 IS parser1 Defining on Only Forth also ; [THEN] : Host ( -- ) host-compile definitions ; : t' ( -- caddr ) Context @ >r Target defined 0= ?missing r> Context ! >body @ ; : [t'] ( -- caddr ) t' postpone Literal ; immediate ' [IF] Alias [IF] immediate ' [ELSE] Alias [ELSE] immediate ' [THEN] Alias [THEN] immediate ' cr Alias cr ' .( Alias .( immediate ' * Alias * Forth definitions Commands: get-current Host Constant debugger-wordlist : target-compiler ( addr len -- ) ClassContext @ IF 2dup search-classes ?dup IF nip nip name>int execute EXIT THEN ELSE exec? dbg? and IF 2dup debugger-wordlist search-wordlist IF nip nip execute EXIT THEN THEN 2dup find-name ?dup IF nip nip name>int execute EXIT THEN THEN 2dup 2>r snumber? 0 case? IF 2r> interpreter-notfound EXIT THEN 2rdrop comp? IF 0> IF swap lit, THEN lit, EXIT THEN dbg? IF 0> IF swap >t THEN >t EXIT THEN drop ; gforth_062 [IF] : target-compile ( -- ) ['] target-compiler 'interpreter ! ['] target-compiler 'compiler ! ['] target-compiler IS parser Defining off Only Target also ; [THEN] gforth_070 [IF] : target-compiler1 ( addr len -- xt ) target-compiler ['] noop ; : target-compile ( -- ) ['] target-compiler1 'interpreter ! ['] target-compiler1 'compiler ! ['] target-compiler1 IS parser1 Defining off Only Target also ; [THEN] : new ( -- ) \ Initialize cross-compiler for another compilation run Reinterpreted @ IF cr ." reinterpreted " ELSE marker, Marking ! source> Start ! cr ." uCore cross-compiler: uForth_" .version ." vom " .date ." by ks, gforth port and debugger by uho" cr Memory [ #datamask #maxprog umin 1+ cells ] Literal erase THEN Data #maxdata cells erase Initials 3 cells erase Tcp off Tdp off if_prefix Colons off Sequential off Labels off Macro off Shorter off Gotos off [ Macro# @ ] Literal Macro# ! [ Macros @ ] Literal Macros ! [ Branches @ ] Literal Branches ! [ Operators @ ] Literal Operators ! [ Constants @ ] Literal Constants ! [ Variables @ ] Literal Variables ! ; 3535 Constant #host Target definitions Forth : end ( -- ) Gotos off \ no reinterpretation, not yet fully debugged! s" Label Initialisation" evaluate save-data T Host H Reinterpreted @ 0= IF Gotos @ IF Reinterpreted on Marking @ marker! Start @ >source New EXIT THEN Start @ drop-source THEN ." Object code: " there . ." bytes " ; : Host: ( -- # ) ?exec : host-compile drop #host ; : Macro: ( -- addr # ) Macro: host-compile ; Forth definitions : ; ( # -- ) #host case? IF target-compile 0 THEN dup #macro = IF target-compile THEN postpone ; ; immediate : Target ( -- ) target-compile definitions ; Target H Simulation T Version Simulation H WITH_MULT T Version WITH_MULT \ hardware multiply available? H WITH_TASKS T Version WITH_TASKS \ base-offset TASK addressing? H VAN_NEUMANN T Version VAN_NEUMANN \ read/writeable program memory? H SAT_ARITH T Version SAT_ARITH H WITH_BYTES T Version WITH_BYTES H WITH_FLOAT T Version WITH_FLOAT H data_width T Constant data_width H dcache_addr_width T Constant dcache_addr_width H exp_width T Constant exp_width H prog_addr_width T Constant prog_addr_width H prog_ram_width T Constant prog_ram_width H ticks_per_ms T Constant ticks_per_ms H rs_base_width T Constant rs_base_width H rs_addr_width T Constant rs_addr_width H ds_addr_width T Constant ds_addr_width H tasks_addr_width T Constant tasks_addr_width H #signbit T Constant #signbit H #databits T Constant #databits H #bytes T Constant #bytes \ umbilical control characters H mark_start T Constant mark_start H mark_reset T Constant mark_reset H mark_debug T Constant mark_debug H mark_ack T Constant mark_ack H mark_nack T Constant mark_nack tasks_addr_width 2** Constant #tasks rs_addr_width 2** Constant #rstack rs_base_width 2** Constant #rbase ds_addr_width 2** Constant #dstack dcache_addr_width 2** Constant #ram \ total blockRAM size #ram #rstack #tasks * - Constant #top \ first address used for return stack, equivalent to dataRAM size \ this value is only valid if data_mem is fully 2**n sized. \ otherwise #top is defined in CONSTANTS.FS \ hard wired trap vectors 0 T Constant #reset \ reset vector H op_INT #usrmask and T Constant #isr \ interrupt service routine H op_EXC #usrmask and T Constant #esr \ exception service routine H op_QOVFL #usrmask and T Constant #osr \ overflow service routine H op_BREAK #usrmask and T Constant #break \ debugger breakpoint routine H op_DATA #usrmask and T Constant #data! \ for data memory initialisation H op_ADDR #usrmask and T Constant #asr \ byte address error w@/! i@/! Host