xVersion" 2012.10.30.1" module 24xxxx #document 24xxxx ( Value initialization must be called explictly now - used to be auto. ) ( Cell size is 16 bits for data, 16 bits are also used for RAM ) ( addresses. ) ( All quad and most tripple words were removed. ) ( RomPtr and RamPtr words were moved to utils.4th, any var can be a ram ) ( byte pointer now using a bytePtr on it. ) // //////////////////////////////////////////////////////////////////// // // Code templates for Pic4th. // (C) Copyright 1999 .. 2008, LOGIN b.v. // // 24xxxx.4th, for : // // 24fj128da106 // 24fj256da106 // 24fj128da110 // 24fj256da110 // 24fj128da206 // 24fj256da206 // 24fj128da210 // 24fj256da210 // // Stacks : // // //////////////////////////////////////////////////////////////////// // // Adressing : // // //////////////////////////////////////////////////////////////////// #endDoc only Forth definitions { 2 constant cell // A cell uses two bytes : cells ( n -- n ) cell * ; 1 cells IntSize // An integer uses one cell 1 cells ramPtrSize // A ram pointer uses one cell 2 cells romPtrSize // A rom pointer uses two cells 2 cells ramStrSize // A $ram variable uses 2 cells 3 cells romStrSize // A $rom variable uses 3 cells 2 cells setSize // A set uses two cells (32 set members max) 2 cells floatSize // A float is four bytes } // ======== Rom specs ================================================= // Only starting address of rom banks is used, but for PIC 24 it's not // very usable at all ... just for compatibility. // ForceRomBank has been changed to do nothing for PIC 24 processors { // ////////////////////////////////////////////////////////////////////////// // Define some meta stuff for processor selection administration. // ////////////////////////////////////////////////////////////////////////// variable processorUnDefined // Keep track of processor being defined or not variable processorInclude // Keep track of include file to use variable processorName // Keep track of the processor name // ////////////////////////////////////////////////////////////////////////// : procSelect ( -- ) #// Start processor initialization section true processorUndefined ! // Set undefined processor " " processorInclude ! // Set undefined include file cr // CR for prettier user feedback ; // ////////////////////////////////////////////////////////////////////////// macro procType? ( aName aRomSize aRamSize ) ( -- ) // Specific processor setup endMacro // ////////////////////////////////////////////////////////////////////////// : procSelectEnd ( -- ) #// Finish processor initialization section #// Include the processor specific x4th bit definitions // Check processor selection processorUndefined @ if " Processor" " undefined" addDoc " No supported processor was defined" message cr " a processor should be defined in make.4th with #define " message " where is one of the supported processors; these are:" message cr " 24fj128da106 24fj256da106 24fj128da110 24fj256da110" message " 24fj128da206 24fj256da206 24fj128da210 24fj256da210" message cr " No supported processor was defined, compilitaion was aborted." runError cr else // Handle include file processorInclude @ " " <> if processorInclude @ include endIf endif ; // ////////////////////////////////////////////////////////////////////////// } procSelect // proc ROM in bytes RAM in bytes procType? 24fj128da106 131072 24576 procType? 24fj128da110 131072 24576 procType? 24fj128da206 131072 73728 procType? 24fj128da210 131072 73728 procType? 24fj256da106 262144 24576 procType? 24fj256da110 262144 24576 procType? 24fj256da206 262144 73728 procType? 24fj256da210 262144 73728 procSelectEnd // ======== Ram specs ================================================= // These must match the MaxRam related definitions // see : @ram@ $00 localBank // This is a dummy for pic24, locals are on the return stack // //////////////////////////////////////////////////////////////////////////// macro list ( aFormat ) ( -- ) // Invoke the assemblers LIST directive, incompatible with GNU assembler endMacro // //////////////////////////////////////////////////////////////////////////// macro hexFormat ( aFormat ) ( -- ) // Control the default assembler HEX file type, not supported for GNU assembler endMacro // //////////////////////////////////////////////////////////////////////////// macro title ( aTitle ) ( -- ) // Sets a title for the assembler .title $aTitle$ endMacro // //////////////////////////////////////////////////////////////////////////// macro page ( ) ( -- ) // Ejects a page in the assmbly list file .eject endMacro // //////////////////////////////////////////////////////////////////////////// // //////////////////////////////////////////////////////////////////////////// // A couple of words to track the last header in flash // this needs further support by the 'final' module. 2variable last defer lastPFA only compiler definitions also forth // Low level abstraction code and maro's // The compiler relies on these to be present // //////////////////////////////////////////////////////////////////////////// // // Value initialization, not fully automated anymore. // // Not used when the compiler is set to use initialized variables // for values, in that case the linker will take care of this. // // The InitValues ( -- ) forth word performs a call // to _DoInitValues, the forth main function should issues // InitValues after memory and register initialization // to get the value words initialized. // macro valueBegin ( ) ( -- ) // Label generation for values (initialized variables) ; // =========================================== ; // ======== Value initialization code ======== .ifdef __C30ELF .type _DoInitValues, @function .endif _DoInitValues: ; // Between here and [[ValueEnd]] the compiler will generate value ; // initialization code, if present. ; // endMacro // macro valueEnd ( MainBank ) ( -- ) // End directive for values (initialized variables) ; // ; // This provides for the return from the 4th word [[InitValues]] ( -- ) return ; // ----> done ; // ======== End of value initialization code ======== ; // ================================================== endMacro // // End of values stuff, also see InitValues // //////////////////////////////////////////////////////////////////////////// // The following (varbegin), (varend), (valuebegin) anf (valueend) macros // contain section directives to allow the linker to arrange for variable // and value initialization. macro (varbegin) ( ) ( -- ) ; // (varbegin) ( -- ) .pushsection .bss ; // Compile variables into uninitialized data space endMacro // //////////////////////////////////////////////////////////////////////////// macro (varend) ( ) ( -- ) ; // (varend) ( -- ) .popsection ; // Return to previous section endMacro // //////////////////////////////////////////////////////////////////////////// macro (valuebegin) ( ) ( -- ) ; // (valuebegin) ( -- ) .pushsection .data ; // Compile values into initialized data space endMacro // //////////////////////////////////////////////////////////////////////////// macro (valueend) ( ) ( -- ) ; // (valueend) ( -- ) .popsection ; // Return to previous section endMacro // //////////////////////////////////////////////////////////////////////////// macro (forceRomBank) ( Nr Address ) ( -- ) // Force new rom bank start, a nop for PIC 24 ; // (ForceRomBank) ( -- ) $Nr$ $Address$ -- a NOOP for PIC 24, it has no rom banking. endMacro // //////////////////////////////////////////////////////////////////////////// // TypeDefs as used for the Type field in headers, every compiler word type // which can lead to target code generation (thrrough it's implement method) // should be listed here. Items marked with X are currently not generated // by the compiler. only forth definitions enum type_Word #// X - effectively a NULL type type_Primitive #// - a code word type_Colon #// - a secondary word, does not differ from a primitive type_Create #// X - can currently not generate target code type_Inline #// X - maps to TMacro, the name type_Macro caused compiler trouble type_StringConstant #// - string constant, should push next inline address type_DataConstant #// - Same as StringConstant type_RawDataConstant #// - Same as Data Constant, but no leading size byte. type_Constant #// X - type_2Constant #// X - type_3Constant #// X - type_4Constant #// X - type_FConstant #// X - type_Variable #// X - type_2Variable #// X - type_3Variable #// X - type_4Variable #// X - type_FloatVariable #// X - type_Value #// X - type_Array #// X - type_PastLast #// X - must be last entry, never generated, invalid endEnum only compiler definitions also forth macro (header) ( Size Name Flags Type LastLink NewLink ) ( -- ) $NewLink$: ; // ----------------------------; // (header) .pword $LastLink$ ; // LFA : Link Field : Pointer to next header .pword $Flags$ | 0xffff00 ; // FFA : Flag Field : Flags and backward scan pattern .pascii <$Size$>, "$Name$" ; // NFA : Name Field : Length and name .palign 2 ; // Align TFA to next even address .pword <*" type_$Type$"> ; // TFA : Type Field : holds the word's type ; // -----------------------------; // PFA : Parm Field : holds the data or code for the word endMacro // //////////////////////////////////////////////////////////////////////////// // //////////////////////////////////////////////////////////////////////////// macro (colon) ( MLabel NLabel Bank ) ( -- ) // Colon ([[:]]) definition call macro ; // (colon) $Bank$:$NLabel$ rcall $MLabel$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (code) ( MLabel NLabel Bank ) ( -- ) // [[code]] primary definition call macro ; // (code) $Bank$:$NLabel$ rcall $MLabel$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (semi) ( ) ( -- ) // Compiled [[;]] return ; // B/ ----> (semi) endMacro // //////////////////////////////////////////////////////////////////////////// macro (seminoreturn) ( ) ( -- ) // Compiled [[noreturn;]] ; // (seminoreturn) endMacro // //////////////////////////////////////////////////////////////////////////// macro (interruptreturn) ( ) ( -- ) // Compiled [[interrupt;]] ; // (interrupt;) retfie ; // B/ ----> (interruptreturn) endMacro // //////////////////////////////////////////////////////////////////////////// macro (lit) ( Arg Sign ) ( -- n ) // Compiled [[literal]] ; // (lit) ( -- n ) $Sign$$Arg$ PushLit $Sign$$Arg$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (dlit) ( Arg Sign ) ( -- d ) // Compiled [[dliteral]] ; // (dlit) ( -- d ) $Sign$$Arg$ PushLit ( $Sign$$Arg$ >> 0) & 65535 PushLit ( $Sign$$Arg$ >> 16) & 65535 endMacro // //////////////////////////////////////////////////////////////////////////// macro (str-constdef) ( Name Mangled Size Value ) ( -- ) // Compiled [[string]] constant definition <@" $Name$">: ; // (str-constdef) [[$Name$]] .pascii <$Size$>, "$Value$" endMacro // //////////////////////////////////////////////////////////////////////////// macro (data-constdef) ( Name Mangled Size Value ) ( -- ) // Compiled [[data]] constant definition <@" $Name$">: ; // (data-constdef) [[$Name$]] .pascii <$Size$>, $Value$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (raw-data-constdef) ( Name Mangled Value ) ( -- ) // Compiled [[rawdata]] constant definition <@" $Name$">: ; // (raw-data-constdef) [[$Name$]] .pbyte $Value$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (str-constant) ( Name Mangled ) ( -- dRomAddr ) // String constant evocation ; // (str-constant) ( -- dRomAddress )[[$Name$]] PushLit tbloffset( <@" $Name$">) PushLit.b tblpage ( <@" $Name$">) endMacro // //////////////////////////////////////////////////////////////////////////// macro (constdef) ( Name Mangled Value Sign ) ( -- ) // constant definition .equiv $Mangled$, $Sign$$Value$ ; // (constdef) [[$Name$]] endMacro // //////////////////////////////////////////////////////////////////////////// macro (constant) ( Name Value Sign ) ( -- n ) // constant evocation ; // (constant) ( -- n ) [[$Name$]] ( $Sign$$Value$) PushLit <@" $Name$"> endMacro // //////////////////////////////////////////////////////////////////////////// macro (2constdef) ( Name Mangled Value Sign ) ( -- ) // Double constant definition .equiv $Mangled$, $Sign$$Value$ ; // (2constdef) [[$Name$]] endMacro // //////////////////////////////////////////////////////////////////////////// macro (2constant) ( Name Value Sign ) ( -- d ) // Double constant evocation ; // (2constant) ( -- d ) [[$Name$]] ( $Sign$$Value$) PushLit ( <@" $Name$"> >> 0) & 65535 PushLit ( <@" $Name$"> >> 16) & 65535 endMacro // //////////////////////////////////////////////////////////////////////////// macro (3constdef) ( Name Mangled Value Sign ) ( -- ) // Tripple constant definition .equiv $Mangled$, $Sign$$Value$ ; // (3constdef) [[$Name$]] endMacro // //////////////////////////////////////////////////////////////////////////// macro (3constant) ( Name Value Sign ) ( -- t ) // Tripple constant evocation ; // (3constant) ( -- t ) [[$Name$]] ( $Sign$$Value$) PushLit ( <@" $Name$"> >> 0) & 65535 PushLit ( <@" $Name$"> >> 16) & 65535 PushLit ( <@" $Name$"> >> 32) & 65535 endMacro // //////////////////////////////////////////////////////////////////////////// macro (vardef) ( Name Mangled Value Bank ) ( -- ) // Vriable definition $Mangled$: .space 2 ; // (vardef) [[$Name$]] endMacro // //////////////////////////////////////////////////////////////////////////// macro (variable) ( Name Mangled Value Bank ) ( -- nRamAddr ) // variable evocation ; // (variable) [[$Name$]] ( $Bank$:$Value$) ; <@" $Name$"> PushLit $Mangled$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (2vardef) ( Name Mangled Value Bank ) ( -- ) // Double variable definition $Mangled$: .space 4 ; // (2vardef) [[$Name$]] endMacro // //////////////////////////////////////////////////////////////////////////// macro (2variable) ( Name Mangled Value Bank ) ( -- nRamAddr ) // Double variabale evocation ; // (2variable) [[$Name$]] ( $Bank$:$Value$) ; <@" $Name$"> PushLit $Mangled$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (3vardef) ( Name Mangled Value Bank ) ( -- ) // Tripple variable definition $Mangled$: .space 6 ; // (3vardef) [[$Name$]] endMacro // //////////////////////////////////////////////////////////////////////////// macro (3variable) ( Name Mangled Value Bank ) ( -- nRamAddr ) // Tripple variabale evocation ; // (3variable) [[$Name$]] ( $Bank$:$Value$) ; <@" $Name$"> PushLit $Mangled$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (arraydef) ( Name Mangled Value Size Bank ) ( -- ) // Array definition $Mangled$: .space $Size$ ; // (arraydef) $Size$ Array [[$Name$]] .align 2 endMacro // //////////////////////////////////////////////////////////////////////////// macro (array) ( Name Mangled Value Size Bank ) ( -- nRamAddr ) // Array evocation ; // (array) $Size$ [[$Name$]] ( $Bank$:$Value$) ; $Mangled$ PushLit $Mangled$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (fielddef) ( Name Mangled Value Sign ) ( -- ) // Structure field definition .equiv $Mangled$, $Sign$$Value$ ; // (fielddef) [[$Name$]] endMacro // //////////////////////////////////////////////////////////////////////////// macro (field) ( Name Value Sign ) ( -- n ) // Structue field evocation ; // (field) [[$Name$]] ( $Sign$$Value$) PushLit <@" $Name$"> endMacro // //////////////////////////////////////////////////////////////////////////// macro (>field) ( Name Value Sign ) ( u1 u2 -- u3 ) // Structure field offset calculation ; // (>field) ( u1 u2 -- u3 ) [[$Name$]] ( $Sign$$Value$) ; // ( bBase -- bBase+bOffset ) PushLit <@" $Name$"> add w0, [w9--], w0 ; // (+) ( u1 u2 -- u3 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (s>field) ( Name Value Sign ) ( d -- d ) // Structure field offset calculation ; // (s>Field) [[$Name$]] ( $Sign$$Value$) ; // ( dBase -- dBase+dOffset ) PushLit ( <@" $Name$"> >> 0 ) & 65535 PushLit ( <@" $Name$"> >> 16 ) & 65535 rcall <@" +"> endMacro // //////////////////////////////////////////////////////////////////////////// macro (2fielddef) ( Name Mangled Value Sign ) ( -- ) // Double field definition .equiv $Mangled$, $Sign$$Value$ ; // (2fielddef) [[$Name$]] endMacro // //////////////////////////////////////////////////////////////////////////// macro (2field) ( Name Value Sign ) ( -- d ) // Double field evocation ; // (2field) ( -- d ) [[$Name$]] ( $Sign$$Value$) PushLit ( <@" $Name$"> >> 0) & 65535 PushLit ( <@" $Name$"> >> 16) & 65535 endMacro // //////////////////////////////////////////////////////////////////////////// macro (>2field) ( Name Value Sign ) ( d -- d ) // Structure field offset calculation ; // (>2field) ( d -- d ) [[$Name$]] ( $Sign$$Value$) ; // ( dBase -- dBase+dOffset ) PushLit ( <@" $Name$"> >> 0 ) & 65535 PushLit ( <@" $Name$"> >> 16 ) & 65535 rcall <@" +"> endMacro // //////////////////////////////////////////////////////////////////////////// macro (s>2field) ( Name Value Sign ) ( n -- d ) // Structure field offset calculation ; // (s>2field) ( n -- d ) [[$Name$]] ( $Sign$$Value$) ; // ( bBase -- bBase+dOffset ) PushLit 0 ; // perform u>d PushLit ( <@" $Name$"> >> 0 ) & 65535 PushLit ( <@" $Name$"> >> 16 ) & 65535 rcall <@" +"> endMacro // //////////////////////////////////////////////////////////////////////////// macro (structdef) ( Name Mangled Value Sign ) ( -- ) // Structure definition .equiv $Mangled$, $Sign$$Value$ ; // (structdef) [[$Name$]] endMacro // //////////////////////////////////////////////////////////////////////////// macro (struct) ( Name Value Sign ) ( -- n ) // Structure evocation ; // (struct) ( -- n ) [[$Name$]] ( $Sign$$Value$) PushLit <@" $Name$"> endMacro // //////////////////////////////////////////////////////////////////////////// macro (valuestartup) ( Name Mangled Address Bank Value Sign ) ( -- ) // Value startup evocation ; // (valuestartup) ( -- ) - value initialization ; // Value [[$Name$]] ( $Bank$:$Address$) := $Sign$$Value$ ; <@" $Name$"> movlw $Sign$$Value$ movwf $Address$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (valuedef) ( Name Mangled Value Bank Sign ) ( -- ) // Value definition $Mangled$: .word $Sign$$Value$ ; // (valuedef) [[$Name$]] endMacro // //////////////////////////////////////////////////////////////////////////// macro (value) ( Name Mangled Address Bank Fetch ) ( -- n ) // Value evocation ; // (value) ( -- n ) Value [[$Name$]] ( $Bank$:$Address$) ; <@" $Name$"> PushReg <@" $Name$"> endMacro // //////////////////////////////////////////////////////////////////////////// macro (to) ( Name Mangled ) ( n -- ) // Comiled to or =: ; // (to) ( n -- ) $Name$ / [[To]] [[$Name$]] ( w -- ) ; <@" $Name$"> PopReg <@" $Name$"> endMacro // //////////////////////////////////////////////////////////////////////////// macro (initLocalSpace) ( aLocalStart ) ( -- ) // Setup local variables ; // (initLocalSpace) Initialize the local data pointer (LDP), nothing for pic24 locals are in stack frames endMacro // //////////////////////////////////////////////////////////////////////////// macro (getLocalSpace) ( anAmount ) ( -- ) // Reserve space for local variables ; // (getLocalSpace) ( -- ) Reserve $anAmount$ bytes for local variables. lnk #$anAmount$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (freeLocalSpace) ( anAmount ) ( -- ) // Free local variables ; // (freeLocalSpace) ( -- ) Free $anAmount$ bytes of local space ulnk endMacro // //////////////////////////////////////////////////////////////////////////// macro (locvar) ( Name Mangled Value Bank Sign ) ( -- nRamAddr ) // Local variable evocation ; // (locvar) ( -- nRamAddr ) [[$Name$]] ( $Bank$:$Sign$$Value$) ; <@" $Name$"> PushReg w14 ; // Push frame pointer and add offset add #$Sign$$Value$, w0 endMacro // //////////////////////////////////////////////////////////////////////////// macro (loc2var) ( Name Mangled Value Bank Sign ) ( -- nRamAddr ) // Local double variable evocation ; // (loc2var) ( -- nRamAddr ) [[$Name$]] ( $Bank$:$Sign$$Value$) ; <@" $Name$"> PushReg w14 ; // Push frame pointer and add offset add #$Sign$$Value$, w0 endMacro // //////////////////////////////////////////////////////////////////////////// macro (label) ( Label ) ( -- ) // Label definition ; // (label) $Label$: endMacro // //////////////////////////////////////////////////////////////////////////// macro (debug-info-func) ( aName ) ( -- ) // Debug info for function definitions .ifdef __C30ELF .type $aName$, @function .endif endMacro // //////////////////////////////////////////////////////////////////////////// macro (global) ( aName ) ( -- ) // Make a compiled 4th word global - visible to externally linked modules ; // (global) .global $aName$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (goto) ( Label ) ( -- ) // Jump definition ; // (goto) $Label$ bra $Label$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (jumpto) ( Name Mangled ) ( -- ) // Named jump definition ; // (jumpto) $Name$ bra <@" $Name$"> endMacro // //////////////////////////////////////////////////////////////////////////// macro (call) ( Label ) ( -- ) // Call definition ; // (call) $Label$ rcall $Label$ endMacro // //////////////////////////////////////////////////////////////////////////// macro ((fbranch)) ( ) ( f -- ) // [[(fbranch)]] helper ; // ((fbranch)) ( f -- ) PopReg w1 cp0 w1 endMacro // //////////////////////////////////////////////////////////////////////////// macro (begin) ( Label ) ( -- ) // Compiled [[begin]] ; // (begin) $Label$: endMacro // //////////////////////////////////////////////////////////////////////////// macro (until) ( Label ) ( -- ) // Compiled [[until]] ; // (until) - branch if Z flag fBranch $Label$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (again) ( Label ) ( -- ) // Compiled [[again]] ; // (again) - unconditional branch bra $Label$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (while) ( Label ) ( -- ) // Compiled [[while]] ; // (while) - branch if Z flag set fBranch $Label$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (repeat) ( Label1 label2 ) ( -- ) // Compiled [[repeat]] ; // (repeat) - unconditional branch bra $Label1$ $Label2$: endMacro // //////////////////////////////////////////////////////////////////////////// macro (if) ( Label ) ( -- ) // Compiled [[if]] ; // (if) - branch if Z flag set fBranch $Label$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (else) ( Label1 Label2 ) ( -- ) // Compiled [[else]] ; // (else) - unconditional branch bra $Label2$ $Label1$: endMacro // //////////////////////////////////////////////////////////////////////////// macro (then) ( Label ) ( -- ) // Compiled [[then]] or [[endIf]] ; // (then) or (endif) - a label $Label$: endMacro // //////////////////////////////////////////////////////////////////////////// macro (case) ( ) ( -- ) // Compiled [[case]] ; // (case) endMacro // //////////////////////////////////////////////////////////////////////////// macro (endcase) ( Label ) ( -- ) // Compiled [[endCase]] ; // (endcase) - a label $Label$: endMacro // //////////////////////////////////////////////////////////////////////////// code ((of)) ( n1 n2 -- n1 | n1 n2 -- ) // Helper for [[(of)]] PopReg w1 ; // Pop n2 into w1 cp w1, w0 ; // Check if n1 == n2 , setting Z flag as needed btsc SR, #Z ; // S/ n1 <> n2 , not changing Z flag mov [w9--], w0 ; // n1 == n2 drop ( n1 -- ), not changing Z flag btg SR, #Z ; // Toggle zero flag return ; // B ----> done endCode behead // //////////////////////////////////////////////////////////////////////////// macro (of) ( Label ) ( -- ) // Compiled [[of]] ; // (of) - branch if Z flag set fBranch $Label$ endMacro // //////////////////////////////////////////////////////////////////////////// macro (endof) ( Label1 Label2 ) ( -- ) // Compiled [[endOf]] ; // (endof) - unconditional branch bra $Label1$ $Label2$: endMacro // //////////////////////////////////////////////////////////////////////////// code ((+loop)) ( w -- ) // Helper for [[(+loop)]] add w0, [w10], [w10] ; // inc( index, b) mov [w10++], w0 ; // Get index LSP++ subr w0, [w10--], w0 ; // Limit - Index LSP-- bra nz, 1f ; // B/ not zero, not done LDrop ; // Drop DoLoop control frame LDrop Drop ; // Drop b bclr SR, #Z ; // signal index = limit return 1: Drop ; // Drop b bset SR, #Z ; // signal index <> limit return endCode behead // //////////////////////////////////////////////////////////////////////////// code ((loop)) ( -- ) // Helper for [[(loop)]] PushLit 1 bra <@" ((+loop))"> endCode behead // //////////////////////////////////////////////////////////////////////////// code ((do)) ( bLimit bStart -- ) PopReg w1 ; // Start into tmp1 PopReg w2 ; // Limit into tmp2 LPshReg w2 ; // Limit on loop stack LPshReg w1 ; // Start on loop stack (as Index) bclr SR, #Z ; // Return with zero flag cleared return ; // B/ ----> done (loop taken) endCode behead // //////////////////////////////////////////////////////////////////////////// code ((?do)) ( bLimit bStart -- ) mov [w9], w1 cpseq w0, w1 ; // S/ if start = limit bra <@" ((do))"> ; // B/ start <> Limit, perform ((do)) ; // Start is limit, skip do ... (+)loop Drop ; // drop start Drop ; // drop Limit bset SR, #Z ; // Return with zero flag set (loop skipped) return ; // B/ ----> done endCode behead // //////////////////////////////////////////////////////////////////////////// macro (do) ( SkipLabel LoopLabel ) ( bLimit bStart -- ) ; // (do) ( bLimit bStart -- ) rcall <@" ((do))"> $LoopLabel$: endMacro // //////////////////////////////////////////////////////////////////////////// macro (?do) ( SkipLabel LoopLabel ) ( bLimit bStart -- ) ; // (?do) ( bLimit bStart -- ) : check if limit is count, if so skip loop rcall <@" ((?do))"> fBranch $SkipLabel$ $LoopLabel$: endMacro // //////////////////////////////////////////////////////////////////////////// macro (loop) ( LoopLabel SkipLabel ) ( -- ) ; // (loop) ( -- ) branch if Z flag set fBranch $LoopLabel$ $SkipLabel$: endMacro // //////////////////////////////////////////////////////////////////////////// macro (leave) ( ) ( -- ) ; // (leave) mov [w10 + 2], w1 dec w1, [w10] ; // Get limit, dec limit, result into Index endMacro // //////////////////////////////////////////////////////////////////////////// code ((try)) ( dRomAddr_REVERSED -- ) // Helper for [[(try)]] ; // create (except) frame on return stack ; // ( dRomAddress -- ) [ -- (except) ] PopReg [--w10] ; // >r addr_except_low PopReg [--w10] ; // >r addr_except_high ; // >r return stack pointer LPshReg w15 ; // >r frame pointer LPshReg w14 ; // >r TOS LPshReg w0 ; // >r data stack pointer LPshReg w9 AddExceptionFrame ; // Link in a new exception frame ; // Exception frame as on loop stack now. ; // The loop stack grows downwards and uses w10 ; // On pussh first w10 is decremented then the new ; // value is stored into the stack. ; // ; // +--> | prev_exc_frame | ---- a possible previous frame (old_EFP ; // | +-------------------+ is zero for outermost frame). ; // | | | -+-- possible loop stack data from do..loop or >r ; // | ~ ~ -+ ; // | | | -+ ; // | +-------------------+ ; // | | addr_except_lo | -+-- ROM address of ((except)) to invoke ; // | | addr_except_hi | -+ ; // | | old_stkptr | ---- Old return stack pointer ; // | | old_frame_ptr | ---- Old frame pointer ; // | | old_wreg | ---- Value that was on top of old stack ; // | | old_data_sp | -+-- old data stack imcluding wreg ; // +-<- | old_EFP | <--- +---------+------+ ; // +-------------------+ | new EFP | LSP | ; // +---------+------+ return ; // B/ ----> done endCode behead // //////////////////////////////////////////////////////////////////////////// code ((raise)) ( bException -- bException ) // Helper for [[(raise)]] ; // Should check for original data stack corruption here ; // that is, when we have a relative stack underflow ; // that's definitly no good. ; // ; // Use the current (except) frame to determine ; // a jump to the nearest (except) handler. ; // Exception frame as on loop stack ; // ; // +--> | prev_frame | ; // | +-------------------+ ; // | | | ; // | ~ ~ ; // | | | ; // | +-------------------+ ; // | | addr_except_lo | -+-- ROM address of ((except)) to invoke ; // | | addr_except_hi | -+ ; // | | old_stkptr | ---- Old return stack pointer ; // | | old_frame_ptr | ---- Old frame pointer ; // | | old_wreg | ---- Value that was on top of old stack ; // | | old_data_sp | -+-- old data stack imcluding wreg ; // +-<- | old_EFP | <--- +-----+ ; // +-------------------+ + EFP | ; // +-----+ ; // | | ; // ~ ~ +-----+ ; // | | <--- + LSP | ; // +-----+ pop w3 ; // Pop old return address from return stack pop w2 ; // into w32 - could be useful for debugging later. mov w0, w1 ; // Keep bException in tmp1 RemoveExceptionFrame ; // Unwind one exception level LPopReg w9 ; // restore data stack pointer LPopReg w0 ; // restore TOS LPopReg w14 ; // Pop old frame pointer LPopReg w15 ; // Pop old return stack pointer pop w4 ; // Remove a stack entry pop w4 LPopReg w4 ; // Pop (except) handler from loop stack push w4 ; // and push onto return stack LPopReg w4 push w4 PushReg w1 ; // Repush bException on restored data stack ; // Exception frame as on loop stack ; // +-----+------+ ; // | prev_frame | <--- | EFP | LSP | ; // +-------------------+ +-----+------+ ; // | | ; // ~ ~ ; // | | ; // +-------------------+ ; // | addr_except | ; // ~ ~ return ; // B/ ----> Returns to (except) or (finally) handler endCode behead // //////////////////////////////////////////////////////////////////////////// code ((no_except)) ( -- ) // Helper for (except) and [[(finally)]] ; // Discard one (except) frame ; // Exception frame as on loop stack ; // ; // +--> | prev_frame | ; // | +-------------------+ ; // | | | ; // | ~ ~ ; // | | | ; // | +-------------------+ ; // | | addr_except_lo | -+-- ROM address of ((except)) to invoke ; // | | addr_except_hi | -+ ; // | | old_stkptr | ---- Old return stack pointer ; // | | old_frame_ptr | ---- Old frame pointer ; // | | old_wreg | ---- Value that was on top of old stack ; // | | old_data_sp | -+-- old data stack imcluding wreg ; // +-<- | old_EFP | <--- +-----+ ; // +-------------------+ + EFP | ; // +-----+ ; // | | ; // ~ ~ +-----+ ; // | | <--- + LSP | ; // +-----+ RemoveExceptionFrame ; // Unwind one exception level LFree 12 ; // Drop old_data_sp, old_wreg and addr_except ; // Exception frame as on loop stack ; // +-----+------+ ; // | prev_frame | <--- | EFP | LSP | ; // +-------------------+ +-----+------+ ; // | | ; // ~ ~ ; // | | ; // +-------------------+ ; // | addr_except | ; // ~ ~ return ; // B/ ----> done endCode behead // //////////////////////////////////////////////////////////////////////////// macro (try) ( aTryLabel ) ( -- ) // Compiled [[try]] ; // (try) ( -- ) . Setup a return address for (raise) PushLit tbloffset( $aTryLabel$) PushLit.b tblpage ( $aTryLabel$) ; // ((try)) Create (except) frame on return stack rcall <@" ((try))"> ; // ( dRomAddress -- ) [ -- dRomAddress dDSP ] ; // end (try) ( -- ) [ -- dRomAddress dDSP ] endMacro // //////////////////////////////////////////////////////////////////////////// macro (except) ( aTryLabel anEndLabel ) ( w -- w | -- w ) // Compiled [[except]] ; // (except) ( wException -- wExcpetion | -- wException | ) ; // OK :: We fell trough, no exception, nothing on stack ; // ( ) . ((no_except)) remove (except) frame rcall <@" ((no_except))"> ; // B/ skip to (endtry) bra $anEndLabel$ $aTryLabel$: ; // EXCEPTION :: We came in thhrough a Raise action, exception on stack ; // ( bException ) ; // end (except) endMacro // //////////////////////////////////////////////////////////////////////////// macro (finally) ( aTryLabel aDummyForCompatibiltyReasons ) ( n -- | -- ) // Compiled [[finally]] ; // (finally) ( n -- | -- ) ; // OK :: We fell trough, no exception, nothing on stack ; // ( ) . ((no_except)) remove(except) frame rcall <@" ((no_except))"> PushLit 0 ; // Signal 'no exception' ; // (finally) Fall through to $aTryLabel$ $aTryLabel$: ; // EXCEPTION :: We came in through a Raise action, exception on stack ; // or we fell having no exception, zero on stack ; // ( bException ) Drop ; // But just forget about it for now. ; // (This should be re-raised at EndTry) ; // end ( finally) endMacro // //////////////////////////////////////////////////////////////////////////// macro (endtry) ( anEndLabel ) ( -- ) // Compiled [[endTry]] ; // (endtry) ( -- ) , place holder $anEndLabel$: endMacro // //////////////////////////////////////////////////////////////////////////// macro (raise) ( ) ( n -- ) // Compiled [[Raise]] ; // (raise) ( n -- ) ( bExceptionOnCurrentDataStack -- bExceptionOnOldDataStack ) [ dRomAddress dDSP -- ] rcall <@" ((raise))"> ; // ((raise)) jump to (except) or (finally) handler ; // through (except) frame on return stack endMacro // //////////////////////////////////////////////////////////////////////////// macro (default) ( ) ( -- ) // Compiled [[default]] ; // (default) endMacro // //////////////////////////////////////////////////////////////////////////// macro (exit) ( ) ( -- ) // Compiled [[Exit]] return ; // /B --> (exit) endMacro // //////////////////////////////////////////////////////////////////////////// macro (+) ( ) ( u u -- u ) // + (addition) add w0, [w9--], w0 ; // (+) ( u1 u2 -- u3 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (-) ( ) ( u u -- u ) // - (minus) subr w0, [w9--], w0 ; // (-) ( u1 u2 -- u3 ), reversed subtract endMacro // //////////////////////////////////////////////////////////////////////////// macro (*) ( ) ( n1 n2 -- n3 ) // * (multiplication), signed mul.ss w0, [w9--], w0 ; // (*) ( n1 n2 -- n3 ) signed multiplication endMacro // //////////////////////////////////////////////////////////////////////////// code (/) ( n1 n2 -- n3 ) // / (division) signed ; // also calculates remainder, ; // but we don't care about that! PopReg w2 ; // Pop u2 (divisor) repeat #17 div.s w0, w2 ; // One div step of w0/w2 return ; // B/ ----> done endCode behead // //////////////////////////////////////////////////////////////////////////// code (/mod) ( nDividend nDivisor -- nrem nquot ) // Division with remainder, signed PopReg w2 ; // Pop u2 (divisor) repeat #17 div.s w0, w2 ; // One div step of w0/w2 exch w0, w1 PushReg w1 ; // Push quotient return ; // B/ ----> done endCode behead // //////////////////////////////////////////////////////////////////////////// macro (and) ( ) ( u u -- u ) // Bitwise and and w0, [w9--], w0 ; // (and) ( u u -- u ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (or) ( ) ( u u -- u ) // Bitwise or ior w0, [w9--], w0 ; // (or) ( u u -- u ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (xor) ( ) ( u u -- u ) // Bitwise xor xor w0, [w9--], w0 ; // (xor) ( u u -- u ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (drop) ( ) ( n -- ) // Drop TOS Drop ; // (drop) ( n -- ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (dup) ( ) ( n -- n n ) // Duplicate TOS Dup ; // (dup) ( n -- n n ) endMacro // //////////////////////////////////////////////////////////////////////////// code (swap) ( n1 n2 -- n2 n1 ) // Exchange top two stack elements mov [w9], w2 mov w0, [w9] mov w2, w0 return endCode behead // //////////////////////////////////////////////////////////////////////////// macro (true) ( ) ( -- f ) // Push boolean true value PushLit True ; // (True) ( -- f ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (false) ( ) ( -- f ) // Push boolean false value PushLit False ; // (False) ( -- f ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (space) ( ) ( -- n ) // Push space character value PushLit 0x20 ; // (space) ( -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (negate) ( ) ( n1 -- n2 ) // Unary minus on TOS neg w0, w0 ; // (negate) ( n1 -- n2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (not) ( ) ( n1 -- n2 ) // Bitwise invert on TOS com w0, w0 ; // (not) ( n1 -- n2 ) endMacro // //////////////////////////////////////////////////////////////////////////// code (=) ( n1 n2 -- f ) // Return true when top two stack elements are equal sub w0, [w9--], w0 ; // sub n1 and n2 sub w0, #1 ; // subtract one, setting borrow if result was zero subb w0, w0, w0 ; // 0 if result was not 0, $ffff otherwise return endCode behead // //////////////////////////////////////////////////////////////////////////// code (<>) ( n1 n2 -- f ) // Return true when top two stack elements are not equal sub w0, [w9--], w0 ; // sub n1 and n2 neg w0, w0 ; // negate subb w0, w0, w0 ; // 0 if result was not 0, $ffff otherwise return endCode behead // //////////////////////////////////////////////////////////////////////////// code (<) ( n1 n2 -- f ) // Return true when n1 < n2, signed compare mov #True, w2 ; // Assume result to be true PopReg w1 ; // Pop n2 into w1 cpslt w0, w1 ; // S/ w0 < w1 :: n1 < n2, contents w2 OK mov #False, w2 ; // Assumption was false, change w2 mov w2, w0 ; // Result into w0 return ; // B/ ----> done endCode behead // //////////////////////////////////////////////////////////////////////////// code (>) ( n1 n2 -- f ) // Return true when n1 > n2, signed compare mov #True, w2 ; // Assume result to be true PopReg w1 ; // Pop n2 into w1 cpsgt w0, w1 ; // S/ w0 > w1 :: n1 > n2, contents w2 OK mov #False, w2 ; // Assumption was false, change w2 mov w2, w0 ; // Result into w0 return ; // B/ ----> done endCode behead // //////////////////////////////////////////////////////////////////////////// : (<=) ( n1 n2 -- f ) // Return true when n1 <= n2, signed compare > not ; behead // //////////////////////////////////////////////////////////////////////////// : (>=) ( n1 n2 -- f ) // Return true when u1 >= u2, signed < not ; behead // //////////////////////////////////////////////////////////////////////////// macro (?dup) ( ) ( n -- n n | n -- 0 ) // Duplicate TOS when it's not zero ; // (?dup) ( n -- n n | n -- 0 ) cp0 w0 ; // Test if TOS == 0 btss SR, #Z ; // Skip dup if zero mov w0, [++w9] ; // Dup ( n1 -- n1 n1 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (over) ( ) ( n1 n2 -- n1 n2 n1 ) // Copy 2ndon stack to top ; // (over) ( n1 n2 -- n1 n2 n1 ) PushReg [w9 - 2] endMacro // //////////////////////////////////////////////////////////////////////////// macro (lshift) ( ) ( u1 -- u2 ) //Shift TOS one bit left sl w0, w0 ; // (lshift) ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (rshift) ( ) ( u1 -- u2 ) // Shift TOS one bit right lsr w0, w0 ; // (rshift) ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro (<<) ( ) ( u1 u -- u2 ) // Shift n1 left over u bits PopReg w1 ; // (<<) ( u1 u -- u2 ) Shift u1 left over u positions sl w0, w1, w0 endMacro // //////////////////////////////////////////////////////////////////////////// macro (>>) ( ) ( u1 u -- u2 ) // Shift n1 right over u bits PopReg w1 ; // (>>) ( u1 u -- u2 ) Shift u1 right over u positions lsr w0, w1, w0 endMacro // //////////////////////////////////////////////////////////////////////////// code (rot) ( n1 n2 n3 -- n2 n3 n1 ) // Rotate 3rd stack element to the top mov w0, w3 mov [w9--], w2 mov [w9--], w1 mov w2, [++w9] mov w3, [++w9] mov w1, w0 return endCode behead alias (rot) (+rot) #// (rot) also known as (+rot) // //////////////////////////////////////////////////////////////////////////// code (-rot) ( n1 n2 n3 -- n3 n1 n2 ) mov w0, w3 mov [w9--], w2 mov [w9--], w1 mov w3, [++w9] mov w1, [++w9] mov w2, w0 return endCode behead // //////////////////////////////////////////////////////////////////////////// macro (pick) ( ) ( u1 -- n ) // Copy u1'th element to the top of the stack, 0 pick :: dup ; // (pick) ( ) ( u1 -- n ) add w0, w0, w1 ; // Copy u1'th element to the top of the stack, 0 pick :: dup neg w1, w1 ; // Negate offset, stack goes up mov [w9 + w1], w0 endMacro // //////////////////////////////////////////////////////////////////////////// code (put) ( n u -- ) // Change u'th byte on the stack to n ; // u th byte of stack replaced by value b ; // 0th byte = top of stack PopReg w1 ; // Get u into w1 add w1, w1, w1 neg w1, w1 mov w0, [w9 + w1] ; // Stuff n into w1'th item Drop ; // Drop n return endCode behead // //////////////////////////////////////////////////////////////////////////// macro (abs) ( ) ( n -- u ) // Change n into it's absolute value u ; // (abs) ( n -- u ) Change n into it's absolute value u btsc w0, #15 ; // S/ w0 < 0 neg w0, w0 ; // w0 >= 0, negate it endMacro // //////////////////////////////////////////////////////////////////////////// code (max) ( u1 u2 -- u3 ) // Return the maximum of the top two stack elements PopReg w1 cpslt w1, w0 ; // S/ w1 < w0, so w0 is maximum mov w1, w0 ; // w1 >= w0, so w1 is maximum return endCode behead // //////////////////////////////////////////////////////////////////////////// code (min) ( u1 u2 -- u3 ) // Return the minimum of the top two stack elements PopReg w1 cpsgt w1, w0 ; // S/ w1 > w0, so w0 is minimum mov w1, w0 ; // w1 <= w0, so w1 is minimum return endCode behead // //////////////////////////////////////////////////////////////////////////// macro (@) ( ) ( nRamAddr -- n ) // [Fetch] get the contenets of a RAM location mov [w0], w0 ; // (@) ( nRamAddr -- n ) Fetch RAM data endMacro // //////////////////////////////////////////////////////////////////////////// macro (!) ( ) ( n nRamAddr -- ) // [Store] store n into a RAM location mov [w9--], [w0] ; // (!) ( n nRamAddr -- ) Store n at address pointed to by w0 Drop endMacro // //////////////////////////////////////////////////////////////////////////// code (+!) ( n nRamAddr -- ) // Add n to the value pointed to by nRamAddr PopReg w1 ; // Get address into w1 add w0, [w1], [w1] ; // Add n to value at address Drop ; // Drop n return endCode behead // //////////////////////////////////////////////////////////////////////////// code (-!) ( n nRamAddr -- ) // Subtract b from the value pointed to by nRamAddr PopReg w1 ; // Get address into w1 subr w0, [w1], [w1] ; // Sub n from value at address Drop ; // Drop n return endCode behead // //////////////////////////////////////////////////////////////////////////// macro (i) ( ) ( -- u ) // Compiled [[i]] - inner loop index PushReg [w10] ; // (i) ( -- u ) Get inner loop index endMacro // //////////////////////////////////////////////////////////////////////////// macro (j) ( ) ( -- u ) // Compiled [[j]] - 2nd loop index PushReg [w10 + 4] ; // (j) ( -- u ) Get 2nd loop index endMacro // //////////////////////////////////////////////////////////////////////////// macro (k) ( ) ( -- u ) // Compiled [[k]] - 3rd loop index PushReg [w10 + 8] ; // (k) ( -- u ) Get 3rd loop index endMacro // //////////////////////////////////////////////////////////////////////////// macro (>r) ( ) ( n -- ) // [ -- n ] move n from data stack to loop stack PopReg [--w10] ; // (r>) ( n -- ) [ -- n ] move n from data stack to loop stack endMacro // //////////////////////////////////////////////////////////////////////////// macro (r>) ( ) ( -- n ) // [ n -- ] move n from loop to data stack PushReg [w10++] ; // (r>) ( -- n ) [ n -- ] move n from loop to data stack endMacro // //////////////////////////////////////////////////////////////////////////// macro (2drop) ( ) ( d -- ) // Drop a double byte Drop ; // (2drop) ( d -- ) Drop endMacro // //////////////////////////////////////////////////////////////////////////// : (2dup) ( d -- d d ) #// Duplicate a double byte Over Over ; behead // //////////////////////////////////////////////////////////////////////////// : (2over) ( d1 d2 -- d1 d2 d1 ) // Copy 2nd double on stack to the stack top 3 pick 3 pick ; behead // //////////////////////////////////////////////////////////////////////////// // //////////////////////////////////////////////////////////////////////////// only forth definitions // Definitions directly visible to user programs // //////////////////////////////////////////////////////////////////////////// // //////////////////////////////////////////////////////////////////////////// // Clear all allocated RAM : clearMemory ( -- ) #// Clear all of our RAM memory #// Must be called by user code #// Not used for pic24+, startup code will do this ; behead // //////////////////////////////////////////////////////////////////////////// // Forth hook to perform value initialization macro initValues ( ) ( -- ) ; // ** initValues, not used for pic24+ (see docs for InitValues for more on this) endMacro #// Call the value (initialized variable) initialization code, #// must be called by user code. #// Note : #// #// This is not used for pic24+, the linker and the target startup up code #// deal with it instead. x4th must be set to to compile 4th values as #// initialized variables for this to work (Complier tab). // //////////////////////////////////////////////////////////////////////////// // Finalization code, just the End statement wanted by the assembler. macro finalization ( ) ( -- ) // Finalize code generation ; // ;;;;;;;;;;;;;;;;;;;; finalization ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; .end endMacro // //////////////////////////////////////////////////////////////////////////// // //////////////////////////////////////////////////////////////////////////// // //////////////////////////////////////////////////////////////////////////// // Forth register and memory layout, this should match the ram bank definitions See @ram@ // macro initialization ( ) ( -- ) // Initialize code generation, contains target system initializtion code ; // initialization ( ) ( -- ) .equiv False, 0 .equiv True , -1 ; // //////////////////////////////////////////////////////////////////////////// ; // Forth register and memory layout ; // ; // ; // The as assembler can't handle register renaming .. apparently ... ; // ; // The following mapping is used : ; // ; // .equiv r_tos , w0 ; // Cached Top Of data Stack ; // ; // .equiv tmp1 , w1 ; // Scratch register for compiled forth, high word of cached TOS for internal forth ; // .equiv tmp2 , w2 ; // Scratch registers ; // .equiv tmp3 , w3 ; // .equiv tmp4 , w4 ; // .equiv tmp5 , w5 ; // User pointer for internal forth ; // .equiv tmp6 , w6 ; // high word of W register for internal forth engine ; // .equiv tmp7 , w7 ; // low word of W register for internal forth engine ; // .equiv tmp8 , w8 ; // Low word of IP register for internal forth, high word is in TBLPAG ; // ; // .equiv DSP , w9 ; // Data stack pointer ; // .equiv LSP , w10 ; // Loop stack pointer ; // .equiv IND0 , w11 ; // Indirection register 0 ; // .equiv IND1 , w12 ; // Indirection register 1 ; // .equiv EFP , w13 ; // word : Exception Frame Pointer, ; // ; // used for exception handling ; // .equiv LDP , w14 ; // byte : Local Data Pointer, ; // ; // Base pointer for local variable access ; // ; // mapped onto the frame pointer ; // .equiv RSP , w15 ; // Return stack pointer, processor managed ; // .pushsection .bss ; // Define the 4th stacks in data space SZero: ; // Top of data stack + 1, bank 1, 96 bytes stack ; // The data stack grows upwards .space 256 ; // Get 256 bytes or 128 words for return and loop stack LZero: ; // Top of Return/Loop Stack + 1 ; // The loop stack grows downwards ISZero: ; // Top of interrupt data stack + 1, bank 1, 96 bytes stack ; // The data stack grows upwards .space 256 ; // Get 256 bytes or 128 words for interrupt return and loop stack ILZero: ; // Top of interrupt Return/Loop Stack + 1 ; // The loop stack grows downwards .popsection ; // Return to previous space (if any ...) // ================================== // AsmHelpers ( ) Some helper macro's // ================================== // // fBranch macro aLabel ; // fBranch bra z, aLabel endm // // =============================================== // // Parameter Stack macro's // =============================================== // PopReg macro Reg mov w0, Reg mov [w9--], w0 ; // PopReg ( n -- ) endm // // // =============================================== // Drop macro mov [w9--], w0 ; // drop ( n -- ) endm // // // =============================================== // PushLit macro Arg mov w0, [++w9] ; // Push Arg ( -- n ) mov #Arg, w0 endm // // // =============================================== // PushLit.b macro Arg mov w0, [++w9] ; // Push Arg ( -- n ) mov #Arg, w0 and #0x0ff, w0 endm // // // =============================================== // PushReg macro Reg mov w0, [++w9] ; // Push Reg ( -- n ) mov Reg, w0 endm // // // =============================================== // PushNothing macro mov w0, [++w9] ; // Push nothing, free TOS endm // // // =============================================== // Dup macro mov w0, [++w9] ; // Dup ( n1 -- n1 n1 ) endm // // // =============================================== // SwapDrop macro dec2 w9, w9 ; // SwapDrop ( n1 n2 -- n2 ) endm // // // =============================================== // // Return (loop) Stack macro's // =============================================== // LPshReg macro Reg ; // Push Reg [ -- n ] to loop stack mov Reg, [--w10] endm // // // =============================================== // LPshLit macro Arg ; // LPshLit (Arg) mov #Arg, [--w10] endm // // // =============================================== // LDrop macro ; // drop [ n -- ] from loop stack inc2 w10, w10 endm // // // =============================================== // LFree macro item_count ; // drop [ n1 .. nn -- ] from loop stack add #item_count, w10 endm // // // =============================================== // LPopReg macro Reg ; // Pop Reg [ n -- ] from loop stack mov [w10++], Reg endm // // // =============================================== // AddExceptionFrame macro ; // AddExceptionFrame : link in a new exception frame LPshReg w13 ; // Push Except Frame Pointer mov w10, w13 ; // And set up a new Except Frame Pointer endm // // // =============================================== // RemoveExceptionFrame macro ; // RemoveExceptionFrame, unwind one exception level mov w13, w10 ; // Set loop stack back to EFP LPopReg w13 ; // Pop back old exception frame pointer endm // // =============================================== // // Utility macro's // =============================================== // PushNextRomAddress macro local BeyondMe ; // PushNextRomAddress ( -- dRomAddress ) PushLit tbloffset( BeyondMe) PushLit.b tblpage ( BeyondMe) return BeyondMe: endm // // // =============================================== // PushHere macro local Here ; // PushNextRomAddress ( -- dRomAddress ) Here: PushLit tbloffset( Here) PushLit.b tblpage ( Here) return endm // // // =============================================== // // BreakPoint macro halts simulator // breakPoint macro aMsg .pword 0xDA4000 ; // breakPoint aMsg nop endm // // // =============================================== // GoSleep macro pwrsav #0 ; // enter sleep mode endm // // // =============================================== // GoIdle macro pwrsav #1 ; // enter idle mode endm // // // =============================================== // Disable macro ; // ======== DISABLE ======== user interrupts ; // mov SR, w1 ; // Status register to w1 LPshReg w1 ; // Push old status on loop stack ior #0xe0, w1 ; // Set CPU prio to 7 mov w1, SR ; // Move to Statu Register ; // endm // // // =============================================== // Enable macro ; // LPopReg w1 ; // Pop old status register mov w1, SR ; // Restore old status register ; // ; // ======== ENABLE ======== user interrupts endm // // // =============================================== // jr_f macro reg ; // jr_f bra reg endm // // ; ========================================= // ; End of AsmHelpers, Some helper macro's // ; ========================================= // endMacro used // //////////////////////////////////////////////////////////////////////////// macro asmConfig ( errorLevel LinesPerPage Radix ) ( -- ) // Assembler configuration, processor specific .eject endMacro // ////////////////////////////////////////////////////////////////////////// code forthSetup ( -- ) // Initialize the 4th virtual machine mov #SZero - 2, w9 ; // Initialize data stack pointer mov #LZero , w10 ; // Initialize loop stack pointer mov #SZero , w0 ; // Set SZero as current stack value clr w13 ; // Clear EFP (Exception Frame Pointer) to zero return endCode behead // ////////////////////////////////////////////////////////////////////////// code forthInterruptSetup ( -- ) // Initialize the 4th virtual interrupt machine mov #ISZero - 2, w9 ; // Initialize interrupt data stack pointer mov #ILZero , w10 ; // Initialize interrupt loop stack pointer mov #ISZero , w0 ; // Set ISZero as current interrupt stack value clr w13 ; // Clear EFP to zero return endCode behead // //////////////////////////////////////////////////////////////////////////// macro breakPoint ( aMsg ) ( -- ) // Target debug helper ; // =================== breakPoint $aMsg$ ; // =================== endMacro // //////////////////////////////////////////////////////////////////////////// macro nop ( ) ( -- ) // No OPeration nop ; // nop ( -- ) endMacro // //////////////////////////////////////////////////////////////////////////// macro c@ ( ) ( nRamAddr -- w ) mov.b [w0], w0 ; // c@ ( nRamAddr -- w ) Fetch RAM data byte and #0xff, w0 ; // mask out high byte endMacro // //////////////////////////////////////////////////////////////////////////// macro c! ( ) ( n nRamAddr -- ) // [cStore] store n as a byte into a RAM location mov.b [w9--], [w0] ; // c! ( n nRamAddr -- ) Store n as a byte at address pointed to by w0 dec w9, w9 ; // Another decrement on SP needed Drop endMacro // //////////////////////////////////////////////////////////////////////////// code dabs ( d -- ud ) // Calculate the absulute value of a double byte ; // 32 bits Abs btss w0, #15 bra 1f com [w9], [w9] inc [w9], [w9] bra nz, 2f dec w0, w0 2: com w0, w0 1: Return endCode behead // //////////////////////////////////////////////////////////////////////////// Code negative? ( n -- f ) btss w0, #15 retlw #False, w0 mov #True , w0 return endCode behead // //////////////////////////////////////////////////////////////////////////// Code dnegative? ( d -- f ) SwapDrop bra <@" negative?"> endCode behead // //////////////////////////////////////////////////////////////////////////// : positive? ( n -- f ) 0 > ; behead // //////////////////////////////////////////////////////////////////////////// Code dpositive? ( d -- f ) SwapDrop bra <@" positive?"> endCode behead // //////////////////////////////////////////////////////////////////////////// code (2swap) ( w1 w2 -- w2 w1 ) // Swap the top two double words mov w0, w4 ; // TOS to w4 mov [w9--], w3 ; // pop w3 mov [w9--], w2 ; // pop w2 mov [w9--], w1 ; // pop w1 mov w3, [++w9] ; // Push w3 mov w4, [++w9] ; // Push w4 mov w1, [++w9] ; // Push w1 mov w2, w0 ; // w2 to TOS return endCode behead // //////////////////////////////////////////////////////////////////////////// macro a+ ( ) ( w1 w2 -- w3 ) // Add of a word offset w2 to a RAM address w1 add w0, [w9--], w0 ; // a+ ( w1 w2 -- w3 ) endMacro alias a+ +a // For historic reasons // //////////////////////////////////////////////////////////////////////////// macro 1a+ ( ) ( w -- w ) // Add 1 to a RAM address inc w0, w0 ; // 1a+ ( w1 -- w2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 2a+ ( ) ( w -- w ) // Add 2 to a RAM addres inc2 w0, w0 ; // 2a+ ( w1 -- w2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 3a+ ( ) ( w1 -- w2 ) // Add 3 to RAM address add #3, w0 ; // 3a+ ( w1 -- w2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 4a+ ( ) ( w1 -- w2 ) // Add 4 to RAM address add #4, w0 ; // 4a+ ( w1 -- w2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro a- ( ) ( w1 u -- w2 ) // Subtract u from RAM address subr w0, [w9--], w0 ; // a- ( w1 u -- w2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 1a- ( ) ( w -- w ) // Subtract 1 from RAM address dec w0, w0 ; // 1a- ( w1 -- w2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 2a- ( ) ( w -- w ) // Subtract 2 from RAM address dec2 w0, w0 ; // 2a- ( w1 -- w2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 3a- ( ) ( w1 -- w2 ) // Subtract 3 from RAM address sub #3, w0 ; // 3a- ( w1 -- w2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 4a- ( ) ( w1 -- w2 ) // Subtract 4 from RAM address sub #4, w0 ; // 4a- ( w1 -- w2 ) endMacro // //////////////////////////////////////////////////////////////////////////// also compiler alias (drop) aDrop ( wAddr -- ) #// Drop RAM address alias (dup) aDup ( wAddr -- wAddr wAddr ) #// Dup RAM address alias (over) aOver ( wAddr1 wAddr2 -- wAddr1 wAddr2 wAddr1 ) #// Copy 2nd ram address to TOS alias (!) a! ( w w -- ) #// Address store alias (@) a@ ( w -- w ) #// Address fetch alias (2drop) ddrop alias (2dup) ddup alias (2over) dover alias (2swap) dswap ( wAddr1 wAddr2 -- wAddr2 wAddr1 ) #// Swap top two doubles alias (>) .gt. alias (<) .lt. alias (=) .eq. alias (<=) .le. alias (>=) .ge. alias (<>) .ne. alias (<>) != only forth definitions alias swap aSwap ( wAddr1 wAddr2 -- wAddr2 wAddr1 ) #// Swap top two RAM addresses // //////////////////////////////////////////////////////////////////////////// : noop ( -- ) #// Do nothing. ; behead // //////////////////////////////////////////////////////////////////////////// macro r@ ( ) ( -- n ) // [ n -- n ] peek n from loop to data stack PushReg [w10] ; // r@ ( -- n ) [ n -- ] copy n from loop to data stack endMacro // //////////////////////////////////////////////////////////////////////////// macro r! ( ) ( n1 -- ) // [ n2 -- n1 ] poke n from data to top of loop stack PopReg [w10] ; // r! ( n1 -- ) [ n2 -- n1 ] copy n from data to top of loop stack endMacro // //////////////////////////////////////////////////////////////////////////// code and! ( n nRamAddr -- ) // And contents of nRamAddr with n, result stored at nRamAddr PopReg w1 and w0, [w1], [w1] Drop return endCode behead // //////////////////////////////////////////////////////////////////////////// code nand! ( n nRamAddr -- ) // And contents of nRamAddr with not n, result stored at nRamAddr PopReg w1 com w0, w0 and w0, [w1], [w1] Drop return endCode behead // //////////////////////////////////////////////////////////////////////////// code or! ( n nRamAddr -- ) // Or contents of nRamAddr with n, result stored at nRamAddr PopReg w1 ior w0, [w1], [w1] Drop return endCode behead // //////////////////////////////////////////////////////////////////////////// code nor! ( n nRamAddr -- ) // Or contents of nRamAddr with not n, result stored at nRamAddr PopReg w1 com w0, w0 ior w0, [w1], [w1] Drop return endCode behead // //////////////////////////////////////////////////////////////////////////// code xor! ( n nRamAddr -- ) // Xor contents of nRamAddr with n, result stored at nRamAddr PopReg w1 xor w0, [w1], [w1] Drop return endCode behead // //////////////////////////////////////////////////////////////////////////// code xnor! ( n nRamAddr -- ) // Xor contents of nRamAddr with not n, result stored at nRamAddr PopReg w1 com w0, w0 xor w0, [w1], [w1] Drop return endCode behead // //////////////////////////////////////////////////////////////////////////// macro dup! ( ) ( n nRamAddr -- n ) // Dup n and store it at nRamAddr as well ; // dup! ( n nRamAddr -- b ) dup n, store at nRamAddr PopReg w1 mov w0, [w1] endMacro // //////////////////////////////////////////////////////////////////////////// macro true! ( ) ( nRamAddr -- ) // Store boolean true value at nRamAddr ; // True! ( nRamAddr -- ), store true at nRamAddr PopReg w1 setm [w1] endMacro // //////////////////////////////////////////////////////////////////////////// macro false! ( ) ( nRamAddr -- ) // Store boolean false value at nRamAddr ; // False! ( nRamAddr -- ), store false at nRamAddr PopReg w1 clr [w1] endMacro alias false! 0! ( nRamAddr -- ) #// False! also known as 0! alias false! off ( nRamAddr -- ) #// False! also known as Off alias true! ffff! ( nRamAddr -- ) #// True! also known as ff! alias true! on ( nRamAddr -- ) #// True! also known as On // //////////////////////////////////////////////////////////////////////////// : aDup@ ( nRamAddr -- nRamAddr n ) aDup @ ; behead // //////////////////////////////////////////////////////////////////////////// : aDupc@ ( nRamAddr -- nRamAddr n ) aDup c@ ; behead // //////////////////////////////////////////////////////////////////////////// // //////////////////////////////////////////////////////////////////////////// macro 1+ ( ) ( n -- n ) // Increment TOS add #1, w0 ; // 1+ ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 2+ ( ) ( n -- n ) // Increment TOS by 2 add #2, w0 ; // 2+ ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 3+ ( ) ( n -- n ) // Increment TOS by 3 add #3, w0 ; // 3+ ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 4+ ( ) ( n -- n ) // Increment TOS by 4 add #4, w0 ; // 4+ ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 5+ ( ) ( n -- n ) // Increment TOS by 5 add #5, w0 ; // 5+ ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 6+ ( ) ( n -- n ) // Increment TOS by 6 add #6, w0 ; // 6+ ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 7+ ( ) ( n -- n ) // Increment TOS by 7 add #7, w0 ; // 7+ ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 8+ ( ) ( n -- n ) // Increment TOS by 8 add #8, w0 ; // 8+ ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 9+ ( ) ( n -- n ) // Increment TOS by 9 add #9, w0 ; // 9+ ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 10+ ( ) ( n -- n ) // Increment TOS by 10 add #10, w0 ; // 10+ ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro '0+ ( ) ( n -- n ) // Add ASCII 0 ($30) to TOS add #0x30, w0 ; // '0+ ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 1- ( ) ( n -- n ) // Decrement TOS sub #1, w0 ; // 1- ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 2- ( ) ( n -- n ) // Decrement TOS by 2 sub #2, w0 ; // 2- ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 3- ( ) ( n -- n ) // Decrement TOS by 3 sub #3, w0 ; // 3- ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 4- ( ) ( n -- n ) // Decrement TOS by 4 sub #4, w0 ; // 4- ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 5- ( ) ( n -- n ) // Decrement TOS by 5 sub #5, w0 ; // 5- ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 6- ( ) ( n -- n ) // Decrement TOS by 6 sub #6, w0 ; // 6- ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 7- ( ) ( n -- n ) // Decrement TOS by 7 sub #7, w0 ; // 7- ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 8- ( ) ( n -- n ) // Decrement TOS by 8 sub #8, w0 ; // 8- ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 9- ( ) ( n -- n ) // Decrement TOS by 9 sub #9, w0 ; // 9- ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 10- ( ) ( n -- n ) // Decrement TOS by 10 sub #10, w0 ; // 10- ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro '0- ( ) ( n -- n ) sub #0x30, w0 ; // '0- ( n -- n ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 1-! ( ) ( nRamAddr -- ) dec [w0], [w0] ; // 1-! ( nRamAddr -- ) drop endMacro // //////////////////////////////////////////////////////////////////////////// macro 1+! ( ) ( nRamAddr -- ) inc [w0], [w0] ; // 1+! ( nRamAddr -- ) drop endMacro // //////////////////////////////////////////////////////////////////////////// macro 2-! ( ) ( nRamAddr -- ) dec2 [w0], [w0] ; // 2-! ( nRamAddr -- ) drop endMacro // //////////////////////////////////////////////////////////////////////////// macro 2+! ( ) ( nRamAddr -- ) inc2 [w0], [w0] ; // 2+! ( nRamAddr -- ) drop endMacro // //////////////////////////////////////////////////////////////////////////// macro swapDrop ( ) ( n1 n2 -- n2 ) // Loose 2nd stack entry SwapDrop ; // SwapDrop ( n1 n2 -- n2 ) endMacro alias swapDrop nip ( n1 n2 -- n2 ) // Loose 2nd stack entry // ////////////////////////////////////////////////////////////////////// macro dropFalse ( ) ( n -- f ) clr w0 ; // dropFalse ( n -- f ) endMacro alias dropFalse drop0 // ////////////////////////////////////////////////////////////////////// macro dropTrue ( ) ( n -- f ) setm w0 ; // dropTrue ( n -- f ) endMacro // ////////////////////////////////////////////////////////////////////// : tuck ( n1 n2 -- n2 n1 n2 ) #// Tuck top entry under 2nd swap over ; behead // //////////////////////////////////////////////////////////////////////////// macro 0= ( ) ( n -- f ) ; // 0= ( n -- f ) // Return true when n = 0 sub #1, w0 ; // Subtract one, borrow set if 0= holds subb w0, w0, w0 ; // when borrow set $ffff, 0 otherwise endMacro // //////////////////////////////////////////////////////////////////////////// : 1= ( n -- f ) // Return true when n = 1 1- 0= ; behead // //////////////////////////////////////////////////////////////////////////// : -1= ( n -- f ) // Return true when n = -1 1+ 0= ; behead // //////////////////////////////////////////////////////////////////////////// macro 0<> ( ) ( n -- f ) ; // 0<> ( n -- f ) sub #1, w0 ; // Subtract one, borrow set if 0= holds subb w0, w0, w0 ; // when borrow set $ffff, 0 otherwise com w0, w0 ; // 1's complement EndMacro // ////////////////////////////////////////////////////////////////////////// : 0> ( n -- f ) #// true if n > 0 0 > ; behead // ////////////////////////////////////////////////////////////////////////// : 0< ( n -- f ) #// true if n < 0 0 < ; behead // ////////////////////////////////////////////////////////////////////////// macro 2/ ( ) ( u -- u ) // Divide b by 2 lsr w0, w0 ; // 2/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 4/ ( ) ( u1 -- u2 ) // Divide b by 4 lsr w0, #2, w0 ; // 4/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 8/ ( ) ( u1 -- u2 ) // Divide b by 8 lsr w0, #3, w0 ; // 8/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 16/ ( ) ( u -- u ) // Divide b by 16 lsr w0, #4, w0 ; // 16/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 32/ ( ) ( u1 -- u2 ) // Divide b by 32 lsr w0, #5, w0 ; // 32/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 64/ ( ) ( u1 -- u2 ) // Divide b by 64 lsr w0, #6, w0 ; // 64/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 128/ ( ) ( u1 -- u2 ) // Divide b by 128 lsr w0, #7, w0 ; // 128/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 256/ ( ) ( u1 -- u2 ) // Divide b by 256 lsr w0, #8, w0 ; // 256/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 512/ ( ) ( u1 -- u2 ) // Divide b by 512 lsr w0, #9, w0 ; // 512/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 1024/ ( ) ( u1 -- u2 ) // Divide b by 1024 lsr w0, #10, w0 ; // 1024/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 2048/ ( ) ( u1 -- u2 ) // Divide b by 2048 lsr w0, #11, w0 ; // 2048/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 4096/ ( ) ( u1 -- u2 ) // Divide b by 4096 lsr w0, #12, w0 ; // 4096/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 8192/ ( ) ( u1 -- u2 ) // Divide b by 8192 lsr w0, #13, w0 ; // 8192/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 16384/ ( ) ( u1 -- u2 ) // Divide b by 16384 lsr w0, #14, w0 ; // 16384/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 32768/ ( ) ( u1 -- u2 ) // Divide b by 32768 lsr w0, #15, w0 ; // 32768/ ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 2* ( ) ( u -- u ) // Multiply b with 2 sl w0, w0 ; // 2* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 3* ( ) ( u1 -- u2 ) // Multiply b with 3 mul.uu w0, #3, w0 ; // 3* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 4* ( ) ( u1 -- u2 ) // Multiply b with 4 sl w0, #2, w0 ; // 4* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 8* ( ) ( u1 -- u2 ) // Multiply b with 8 sl w0, #3, w0 ; // 8* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 16* ( ) ( u -- u ) // Multiply b with 16 sl w0, #4, w0 ; // 16* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 32* ( ) ( u1 -- u2 ) // Multiply b with 32 sl w0, #5, w0 ; // 32* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 64* ( ) ( u1 -- u2 ) // Multiply b with 64 sl w0, #6, w0 ; // 64* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 128* ( ) ( u1 -- u2 ) // Multiply b with 128 sl w0, #7, w0 ; // 128* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 256* ( ) ( u1 -- u2 ) // Multiply b with 256 sl w0, #8, w0 ; // 256* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 512* ( ) ( u1 -- u2 ) // Multiply b with 512 sl w0, #9, w0 ; // 512* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 1024* ( ) ( u1 -- u2 ) // Multiply b with 1024 sl w0, #10, w0 ; // 1024* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 2048* ( ) ( u1 -- u2 ) // Multiply b with 2048 sl w0, #11, w0 ; // 2048* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 4096* ( ) ( u1 -- u2 ) // Multiply b with 4096 sl w0, #12, w0 ; // 4096* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 8192* ( ) ( u1 -- u2 ) // Multiply b with 8192 sl w0, #13, w0 ; // 8192* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 16384* ( ) ( u1 -- u2 ) // Multiply b with 16384 sl w0, #14, w0 ; // 16384* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// macro 32768* ( ) ( u1 -- u2 ) // Multiply b with 32768 sl w0, #15, w0 ; // 32768* ( u1 -- u2 ) endMacro // //////////////////////////////////////////////////////////////////////////// : 2pick ( n0 n1 n3 -- n0 n1 n2 n0 ) #// Copy 2nd stack entry to top 2 pick ; behead // //////////////////////////////////////////////////////////////////////////// : 3pick ( n0 n1 n2 b4 -- n0 n1 n2 n4 n0 ) #// Copy 3rd stack entry to top 3 pick ; behead // //////////////////////////////////////////////////////////////////////////// : 4pick ( n0 n1 n2 n3 n4 -- n0 n1 n2 n3 n4 n0 ) #// Copy 4th stack entry to top 4 pick ; behead // //////////////////////////////////////////////////////////////////////////// macro d@ ( ) ( nRamAddr -- d ) // Double byte fetch mov [w0++], [++w9] ; // d@ ( nRamAddr -- d ) // Double byte fetch mov [w0++], w0 endMacro // //////////////////////////////////////////////////////////////////////////// code d! ( d nRamAddr -- ) // Store a double byte at nRamAddr add #2, w0 mov [w9--], [w0--] mov [w9--], [w0] mov [w9--], w0 return endCode behead // //////////////////////////////////////////////////////////////////////////// macro t@ ( ) ( nRamAddr -- t ) // tripple byte fetch ; // t@ ( nRamAddr -- t ) // tripple byte fetch mov [w0++], [++w9] ; // w0 is nRamAddr, push low ram data mov [w0++], [++w9] ; // push high ram data mov [w0++], w0 ; // upper ram data into wreg endMacro // //////////////////////////////////////////////////////////////////////////// code t! ( t nRamAddr -- ) // Store a tripple byte at nRamAddr add #4, w0 mov [w9--], [w0--] mov [w9--], [w0--] mov [w9--], [w0] mov [w9--], w0 return endCode behead // //////////////////////////////////////////////////////////////////////////// : d>r ( d -- ) #// [ -- d ] move d from data to loop stack swap >r >r ; behead // //////////////////////////////////////////////////////////////////////////// : dr> ( -- d ) #// [ d -- ] move d from loop to data stack r> r> swap ; behead // //////////////////////////////////////////////////////////////////////////// todo' optimize dr@ and dr!' : dr@ ( -- d ) #// [ d -- d ] Peek d from loop stack to data stack dr> ddup d>r ; behead // //////////////////////////////////////////////////////////////////////////// : dr! ( d1 -- ) #// [ d2 -- d1 ] Poke d1 from data stack to top of loop stack dr> dswap d>r ddrop ; behead // //////////////////////////////////////////////////////////////////////////// code d+ ( ud1 ud2 -- ud3 ) // Double unsigned addition PopReg w3 PopReg w2 PopReg w1 add w2, w0, w0 ; // Add low words addc w3, w1, w1 ; // Add high words PushReg w1 ; // Push High over low return endCode behead // //////////////////////////////////////////////////////////////////////////// code d- ( ud1 ud2 -- ud3 ) // Double unsigned subtraction of wu2 from wu1 PopReg w3 ; // Pop hi(ud2) into w1, leaving lo(ud2) in w0 PopReg w2 PopReg w1 sub w0, w2, w0 ; // Sub low words subb w1, w3, w1 ; // Sub high words PushReg w1 ; // Push High over low return endCode behead // //////////////////////////////////////////////////////////////////////////// code dand ( ud1 ud2 -- ud3 ) // Double bit wise and PopReg w3 ; // Pop hi(ud2) into w1, leaving lo(ud2) in w0 PopReg w2 PopReg w1 and w0, w2, w0 ; // And low words and w1, w3, w1 ; // And high words PushReg w1 ; // Push High over low return endCode behead // //////////////////////////////////////////////////////////////////////////// code dor ( ud1 ud2 -- ud3 ) // Double bit wise or PopReg w3 ; // Pop hi(ud2) into w1, leaving lo(ud2) in w0 PopReg w2 PopReg w1 ior w0, w2, w0 ; // Or low words ior w1, w3, w1 ; // Or high words PushReg w1 ; // Push High over low return endCode behead // //////////////////////////////////////////////////////////////////////////// code dxor ( ud1 ud2 -- ud3 ) // Double bit wise xor PopReg w3 ; // Pop hi(ud2) into w1, leaving lo(ud2) in w0 PopReg w2 PopReg w1 xor w0, w2, w0 ; // Xor low words xor w1, w3, w1 ; // Xor high words PushReg w1 ; // Push High over low return endCode behead // //////////////////////////////////////////////////////////////////////////// code dnegate ( d -- d ) // Double negation mov [w9], w1 neg w1, w1 neg w0, w0 subb #0, w1 mov w1, [w9] return endCode behead // //////////////////////////////////////////////////////////////////////////// : dnot ( ud1 -- ud2 ) #// bitwise not, 1's complement $ffff.ffff dxor ; behead // //////////////////////////////////////////////////////////////////////////// : dnotAnd ( ud1 ud2 -- ud3 ) #// bitwise: ! qu2 and qu1 dNot dAnd ; behead // //////////////////////////////////////////////////////////////////////////// code d= ( d1 d2 -- f ) // Compare top two double values, return true when equal PopReg w1 ; // u4 PopReg w2 ; // u3 PopReg w3 ; // u2 cpseq w0, w2 retlw #False, w0 cpseq w1, w3 retlw #False, w0 mov #True , w0 return endCode behead // //////////////////////////////////////////////////////////////////////////// code d< ( d1 d2 -- f ) // Compare top two double values, return true when ud1 < ud2 PopReg w3 ; // Calculate d1 - d2 PopReg w2 PopReg w1 sub w0, w2, w0 ; // Sub low words subb w1, w3, w1 ; // Sub high words btss w1, #15 ; // Test if result negative : d1 < d2 retlw #False, w0 ; // Assumption wrong, return false mov #True , w0 return endCode behead // //////////////////////////////////////////////////////////////////////////// code d> ( d1 d2 -- f ) // Compare top two double values, return true when ud1 > ud2 PopReg w3 ; // Calculate d2 - d1 PopReg w2 PopReg w1 sub w2, w0, w0 ; // Sub low words subb w3, w1, w1 ; // Sub high words btss w1, #15 ; // Test if result negative : d1 > d2 retlw #False, w0 ; // Assumption wrong, return false mov #True , w0 return endCode behead // //////////////////////////////////////////////////////////////////////////// : d<> ( d1 d2 -- f ) d= not ; behead alias d<> d!= behead // ////////////////////////////////////////////////////////////////////////// : d>= ( d1 d2 -- f ) d< not ; behead // ////////////////////////////////////////////////////////////////////////// : d<= ( d1 d2 -- f ) d> not ; behead // ////////////////////////////////////////////////////////////////////////// : d0 ( -- w ) #// Double 0 0. ; behead // //////////////////////////////////////////////////////////////////////////// : d0< ( d -- f ) // True when d < 0 swapDrop 0< ; behead // //////////////////////////////////////////////////////////////////////////// : d0= ( d -- f ) or 0= ; behead // //////////////////////////////////////////////////////////////////////////// : d0<> ( d -- f ) or 0<> ; behead // //////////////////////////////////////////////////////////////////////////// code 1d+ ( d -- d ) mov #1, w1 ; // 1d+ ( n -- n ) add w1, [w9], [w9] addc #0, w0 return endCode behead // //////////////////////////////////////////////////////////////////////////// code 1d- ( d -- d ) mov #1, w1 ; // 1d+ ( n -- n ) sub w1, [w9], [w9] subb #0, w0 return endCode behead // //////////////////////////////////////////////////////////////////////////// macro u>d ( ) ( u -- ud ) // Unsigned single to unsigned double PushLit 0 ; // u>d ( u -- ud ) endMacro // //////////////////////////////////////////////////////////////////////////// code >d ( n -- d ) // Signed single to signed double mov #0xffff, w1 ; // Assume sign extension is needed btss w0, #15 ; // S/ sign extension needed clr w1 ; // Assumption wrong, clear sign extension PushReg w1 return endCode behead // //////////////////////////////////////////////////////////////////////////// macro sp@ ( ) ( -- n ) // Get current data stack pointer value ; // sp@ ( -- n ) - get current data stack pointer PushReg w9 endMacro // //////////////////////////////////////////////////////////////////////////// macro sp0 ( ) ( -- n ) // Get initial data stack pointer value ; // sp0 ( -- n ) - get initial data stack pointer PushLit SZero - 2 endMacro // //////////////////////////////////////////////////////////////////////////// code sp0<>? ( -- f ) // True when current data stack pointer <> initial value PushNothing ; // Make room for result mov #SZero, w0 ; // SZero and not SZero - 2, as we just pushed cpsne w9, w0 ; // S/ stack not in error retlw #False, w0 ; // ----> stack ok -> False mov #True, w0 ; // ----> stack error -> True return endCode behead // //////////////////////////////////////////////////////////////////////////// variable spsave : @spSave ( -- nRamAddr ) spSave ; behead : spSave@ ( -- nRamAddr ) @spSave @ ; behead : spSave! ( nRamAddr -- ) @spSave ! ; behead // //////////////////////////////////////////////////////////////////////////// : sp! ( -- ) #// Store current SP into spSave sp@ spSave! ; behead // //////////////////////////////////////////////////////////////////////////// : sp+! ( w -- ) #// Add w to spSave contents spSave@ + spSave! ; behead // //////////////////////////////////////////////////////////////////////////// : sp-! ( w -- ) #// Subtract w from spSave contents spSave@ swap - spSave! ; behead // //////////////////////////////////////////////////////////////////////////// : sp? ( -- f ) #// Return True when current SP equal to saved SP sp@ spSave@ = ; behead // //////////////////////////////////////////////////////////////////////////// : spCheck ( bAmount -- f ) sp+! sp? ; behead // //////////////////////////////////////////////////////////////////////////// macro dup>r ( ) ( n -- n ) ; // dup>r ( n -- n ) LPshReg w0 endMacro // //////////////////////////////////////////////////////////////////////////// macro r>drop ( ) ( -- ) ; // r>drop ( n -- n ) LDrop endMacro // //////////////////////////////////////////////////////////////////////////// macro rp> ( ) ( -- dRomAddr ) // Copy return address to data stack ; // rp> ( -- dRomAddr ) Pop w1 ; // Pop old return address from return stack Pop w2 PushReg w2 ; // Push it onto the data stack PushReg w1 endMacro // //////////////////////////////////////////////////////////////////////////// macro >rp ( ) ( dRomAddr -- ) // Copy data stack to return address ; // >rp ( dRomAddr -- ) PopReg w1 PopReg w2 Push w2 Push w1 endMacro // //////////////////////////////////////////////////////////////////////////// macro rp! ( ) ( dRomAddr -- ) // On return stack: replace return address with dRomAddr ; // rp! ( dRomAddr -- ) Pop w1 ; // Pop old return address from return stack Pop w1 PopReg w1 ; // Pop dRomAddr from data stack and push onto return stack PopReg w2 Push w2 Push w1 endMacro // //////////////////////////////////////////////////////////////////////////// macro rp@ ( ) ( -- dRomAddr ) // Copy return address to data stack ; // rp@ ( -- dRomAddr ) Pop w1 ; // Pop old return address from return stack Pop w2 PushReg w2 ; // Push it onto the data stack PushReg w1 Push w2 ; // And push it back onto the return stack as well Push w1 endMacro // //////////////////////////////////////////////////////////////////////////// : exec ( ? dRomAddr -- ? ) // execute code at dRomAddr #// Execute machine code at dRomAddr, that code should end in #// a return instruction, which will return to our caller then. rp! ; behead // //////////////////////////////////////////////////////////////////////////// macro ` ( name ) ( -- dRomAddr ) ; // compiled ` $name$ ( -- dRomAddr ) // push the address of $name$ PushLit tbloffset( <@" $name$">) ; // Push low word PushLit.b tblpage ( <@" $name$">) ; // Push high wird endMacro #document ` // ` (backtick) : Get a ROM addrress valid for [[exec]] // // Obtain the ROM address of the symbol passed in the input stream, // this can be used subsequently as the pRom argument for [[exec]] #endDoc // //////////////////////////////////////////////////////////////////////////// // // Calling C functions from x4th // // See documentation after c_exec macro c_exec ( CName ) ( ? nCount -- nResult ) ; // -------------------------------- ; // c_exec thunk, perform a C code call. ; // Define the C function as external .extern <@" $CName$"> ; // Build the thunk push w14 ; // Build the stack frame. Not statically mov w15, w14 ; // known how many args there will be so ; // can't use " lnk #amount" opcode ; // here ... and so ... dynamically fill ; // the stack frame instead. mov w0, w1 ; // Setup counter in w1 (nCount) ; // keeping w0 unchanged dec w1, w1 ; // Repeats do 'one too many', compensate. bra n, cex$CName$1 ; // B/ no arguments ( except for nCount ; // ( == 0) itself) repeat w1 ; // Pop/Push w1+1 arguments from 4th push [w9--] ; // stack to the call stack; this only ; // pops the ? bit from the 4th stack, ; // and not the nCount; so there is a ; // stack entry left free to be used ; // for the return value. cex$CName$1: push w0 ; // Push nCount on call stack ; // Then call into the C function call <@" $CName$"> ; // Function call result in w0 (TOS) ulnk ; // Remove stack frame ; // ---- end of c_exec thunk ; // ------------------------ ; // endMacro #document c_exec // // C functions to be called from x4th should have the following declaration : // // int test_func( int ArgCount, ...); // // The ellipsis argument will cause the C compiler to expect an unspecified // number of arguments to be present on the call stack, so the x4th code can // just copy ArgCount numbers from the 4th stack to the call stack to pass // them to the C function. The ArgCount argument itself needs to present on // top of the call stack (non of the arguments will be passed through // registers). // // So, the x4th word [[c_exec]] expects a number of arguments on the 4th // data stack topped by the number of arguments present, it will generate a // thunk to push those arguments on the processor call stack and then it // will push the count over it. // // A stack frame must be built in order to be able to clean up the call // stack after the call to the C function, as the caller is responsible for // that in C. // // The result of the function call will be on top of the x4th stack // (in TOS = w0) after the C function and the x4th stub return. // // Register handling : // // w0 .. w7 are scratch, both in C and x4th, no need to save those // w8 .. w15 should be preserved by the callee no need to save those // either. // // The C function should be written like : // // int test_func( int ArgCount, ...) // The function called from 4th // { // va_list ap; // int i, sum; // // va_start( ap, ArgCount); // // sum = 0; // for( i = 0; i < ArgCount; i++) // { // sum += va_arg( ap, int); // } // // va_end( ap); // // sum = test_call( sum); // // return sum; // } // // This example calculates and returns the sum of all arguments passed. // // #endDoc // //////////////////////////////////////////////////////////////////////////// macro u* ( ) ( u1 u2 -- u3 ) // unsigned 16 * 16 -> 16 multiplication mul.uu w0, [w9--], w0 ; // u* ( u1 u2 -- u3 ) unsigned multiplication endMacro // //////////////////////////////////////////////////////////////////////////// macro m* ( ) ( n1 n2 -- d ) // signed 16 * 16 -> 32 multiplication mul.ss w0, [w9--], w0 ; // m* ( u1 u2 -- ud ) signed multiplication PushReg w1 endMacro // //////////////////////////////////////////////////////////////////////////// macro um* ( ) ( u1 u2 -- ud ) // unsigned 16 * 16 -> 32 multiplication mul.uu w0, [w9--], w0 ; // um* ( n1 n2 -- d ) unsigned multiplication PushReg w1 endMacro // //////////////////////////////////////////////////////////////////////////// code d* ( d1 d2 -- d3 ) // Signed 32 * 32 -> 32 PopReg w3 ; // high d2 = c PopReg w2 ; // low d2 = d PopReg w1 ; // high d1 = a ; // low d1 = b in w0 ; // Determine sign as: a xor c and $8000 xor w1, w3, w8 ; // when w8.15 set result is negative mov #0x8000, w4 ; // keep bit 15 only (and $8000) and w4, w8, w8 bclr w1, #15 ; // Clear sign bits of operands bclr w3, #15 ; // (bit 15 of high word) mul.uu w0, w3, w4 ; // w5:w4 <- bc mul.uu w1, w2, w6 ; // w7:w6 <- ad mul.uu w0, w2, w0 ; // w1:w0 <- bd add w1, w4, w1 ; // bd.h + bc.l add w1, w6, w1 ; // bd.h + bc.l + ad.l bclr w1, #15 ; // Clear sign bit ior w1, w8, w1 ; // Or in sign bit as calculated before PushReg w1 return endCode behead #// #// d1 * d2 ~~> ab * cd, let w = 2^16 #// #// (b+wa)*(d+wc) = bd + wad + wbc + w^2ac, with abcd being 16 bit numbers #// #// w^2ac = 0 in a 32 bit representation and we can ignore that, so : #// #// bd.l +w(ad.l + bc.l + bd.h) // //////////////////////////////////////////////////////////////////////////// code ud* ( u1 u2 -- u3 ) // Unsigned 32 * 32 -> 32 PopReg w3 ; // high d2 = c PopReg w2 ; // low d2 = d PopReg w1 ; // high d1 = a ; // low d1 = b in w0 mul.uu w0, w3, w4 ; // w5:w4 <- bc mul.uu w1, w2, w6 ; // w7:w6 <- ad mul.uu w0, w2, w0 ; // w1:w0 <- bd add w1, w4, w1 ; // bd.h + bc.l add w1, w6, w1 ; // bd.h + bc.l + ad.l PushReg w1 return endCode behead #// #// d1 * d2 ~~> ab * cd, let w = 2^16 #// #// (b+wa)*(d+wc) = bd + wad + wbc + w^2ac, with abcd being 16 bit numbers #// #// w^2ac = 0 in a 32 bit representation and we can ignore that, so : #// #// bd.l +w(ad.l + bc.l + bd.h) // //////////////////////////////////////////////////////////////////////////// code u/ ( u1 u2 -- u3 ) // / unsigned division 16 / 16 -> 16 PopReg w2 ; // Pop u2 (divisor) repeat #17 div.u w0, w2 ; // One div step of w0/w2 return ; // B/ ----> done endCode behead // //////////////////////////////////////////////////////////////////////////// code u/mod ( uDividend uDivisor -- urem uquot ) // Division with remainder, unsigned 16 / 16 -> 16 PopReg w2 ; // Pop u2 (divisor) repeat #17 div.u w0, w2 ; // One div step of w0/w2 exch w0, w1 PushReg w1 ; // Push remainder return ; // B/ ----> done endCode behead // //////////////////////////////////////////////////////////////////////////// code div32 ( n -- n ) // Div helper, not to be called on it's own ( 32 / 32 -> 32 / 32) ; // Pre Carry w0.bit15 ; // Loop counter w1 ; // Divisor in w3:w2 ; // Quotient in w5:w4 ; // Remainder in w7:w6 clr w6 ; // Clear remainder clr w7 mov #32, w1 ; // Setup loop counter clr w0 ; // clear Pre Carry bit 1: sl w0, w0 ; // Shift bit 15 of w0 into carry, clearing w0 rlc w4, w4 ; // rlc quotient lo/hi rlc w5, w5 rlc w6, w6 ; // rlc remainder lo/hi rlc w7, w7 bra c, 2f ; // When carry set subtraction is possible ; // Otherwise see if we can subtract divisor from remainder cp w3, w7 ; // cp divisor hi, remainder hi, bra gtu, 3f ; // B/ divisor hi > remainder hi, no not subtract bra ltu, 2f ; // B/ divisor hi < remainder hi, do subtract ; // divisor hi = remainder hi, check lo words cp w2, w6 ; // cp divisor_lo, remainder lo bra gtu, 3f ; // B/ Subtraction not possible, skip 2: sub w6, w2, w6 ; // sub remainder lo, divisor lo subb w7, w3, w7 ; // sub remainder hi, divisor hi bset w0, #15 ; // Set Pre Carry bit 3: dec w1, w1 ; // Loop Counter -- bra nz, 1b ; // B/ Loop Counter <> 0 sl w0, w0 ; // Shift Pre Carry into carry rlc w4, w4 ; // rlc quotient lo/hi rlc w5, w5 return ; // B/ ----> done endCode behead // //////////////////////////////////////////////////////////////////////////// code ud/mod ( udDividend udDivisor -- udRemainder udQuotient ) // 32 / 32 -> 32 + 32 unsigned divide plus modulo ; // Pop arguments from stack into helper variables PopReg w3 ; // hi divisor PopReg w2 ; // lo divisor PopReg w5 ; // hi dividend - into quotient mov w0, w4 ; // lo dividend ; // Divisor in w3:w2 ; // Quotient in w5:w4 ; // Remainder in w7:w6 ; // Perform double division rcall <@" div32"> mov w6, w0 ; // Push remainder PushReg w7 PushReg w4 ; // Push quotient PushReg w5 return endCode behead // //////////////////////////////////////////////////////////////////////////// code um/mod ( udDividend uDivisor -- uRemainder uQuotient ) // 32 / 16 -> 16 + 16 unsigned divide plus modulo ; // Pop arguments from stack into helper variables clr w3 ; // hi divisor PopReg w2 ; // lo divisor PopReg w5 ; // hi dividend - into quotient mov w0, w4 ; // lo dividend ; // Divisor in w3:w2 ; // Quotient in w5:w4 ; // Remainder in w7:w6 ; // Perform double division rcall <@" div32"> mov w6, w0 ; // Push remainder PushReg w4 ; // Push quotient return endCode behead // //////////////////////////////////////////////////////////////////////////// // code m/ ( d n -- nquot ) // signed 32 / 16 -> 16 // // ; // 32 / 16 support does only work correctly when the result // ; // of division fits into a 16 bit register // // PopReg w2 ; // Pop u2 (divisor) // PopReg w1 ; // Get dividend into w1:w0 // // repeat #17 // div.sd w0, w2 ; // One div step of w1:w0/w2 // // return ; // B/ ----> done // endCode behead // //////////////////////////////////////////////////////////////////////////// // code m/mod ( d n -- nrem nquot ) // signed 32 / 16 -> // // PopReg w2 ; // Pop u2 (divisor) // PopReg w1 ; // Get dividend into w1:w0 // // repeat #17 // div.sd w0, w2 ; // One div step of w1:w0/w2 // // exch w0, w1 // PushReg w1 ; // Push remainder // return ; // B/ ----> done // endCode behead // ////////////////////////////////////////////////////////////////////////// : mod ( n n -- n ) /mod drop ; behead // ////////////////////////////////////////////////////////////////////////// : umod ( u u -- u ) u/mod drop ; behead // //////////////////////////////////////////////////////////////////////////// : ud/ ( ud ud -- udquot ) // unsigned 32 / 32 -> 32 ud/mod dswap ddrop ; behead // //////////////////////////////////////////////////////////////////////////// : udmod ( ud ud -- udrem ) // unsigned 32 / 32 -> 32 ud/mod dDrop ; behead // //////////////////////////////////////////////////////////////////////////// : um/ ( ud u -- nquot ) // unsigned 32 / 16 -> 16 um/mod nip ; behead // //////////////////////////////////////////////////////////////////////////// : umrem ( ud u -- nquot ) // unsigned 32 / 16 -> 16 um/mod drop ; behead // //////////////////////////////////////////////////////////////////////////// // : */mod ( n1 n2 u3 -- nquot nrem ) // n1 * n2 / n3 , 32 bit intermediate, signed // // >r m* // r> m/mod // ; // //////////////////////////////////////////////////////////////////////////// : u*/mod ( u1 u2 u3 -- uquot urem ) // u1 * u2 / u3 , 32 bit intermediate, unsigned >r um* r> um/mod ; behead // //////////////////////////////////////////////////////////////////////////// // //////////////////////////////////////////////////////////////////////////// // // Meta stuff { : .info ( n n -- ) #// print name = value to console #// where name ios supposed to end in " :" #// (as in [[.CompileTime]]) + message ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : .infoTime ( n n -- ) #// print name = value as time to console #// where name ios supposed to end in " :" #// (as in [[.CompileTime]]) unix>str + message ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : .compileTime ( -- ) #// Type CompileTime = value to console " CompileTime : " compileTime .infoTime ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : build ( -- ) #// Build all target code initialization // Expand the startup code from the library file. generatecode // Compile the program defined before finalization // Generate finalization code from the library file .CompileTime cr // Show CompileTime on console ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : pfa@@ ( pfa -- nObjContents ) #// Given a pfa the object pointed to by that field will be obtained #// and then the contents of that object are returned. #// #// This is not standard Forth, as object values are not compiled #// directly into the parameter field of a word. Instead a pointer #// to a pascal object is being compiled; to get an object's actual #// value this word is needed to first obtain the pointer to the #// object and then obtain the value contained in that object. pfa@ @ ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . macro varInterface ( aName ) ( -- ) // Define a couple of helper words for 16 bit variables endMacro // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . macro 2varInterface ( aName ) ( -- ) // Define a couple of helper words for 32 bit variables endMacro // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . macro fvarInterface ( aName ) ( -- ) endMacro // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . macro arrayInterface ( aName ) ( -- ) endMacro // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . macro bytePtr ( aName ) ( -- ) endMacro // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . macro vector ( pointer name ) ( -- ) endMacro #document vector // Vector is used to create function pointers // It takes the name of a pointer, that needs not exist already and the name // of a function; multiple definitions can be made this way resulting in // colon words set.name that can later be used to set the address of name // into the function pointer. // When function poihnters are used this way the system is able to keep track // properly of defined words, all words that get assigned with set.name will // have their used flag set when needed. #endDoc // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . // Some helper definitions for configuration words and peripheral register // setup. // // Example usage // // RegDef CNEN2 // RegBit CN16IE .off // Disable all pin change notifications // RegBit CN17IE .off // // RegBit CN18IE .off // // RegBit CN22IE .off // // RegBit CN23IE .off // // endRegDef macro config ( aName aValue ) ( -- ) // Setup a processor configuration word config $aName$ $aValue$ endMacro // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : bits ( nBits nShift -- ) #// defines a bitset constant, expects a name in the input stream << constant ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : .mask ( nBit -- nMask ) #// Convert bit number to bit mask by shifting 1 left over n bits. 1 swap << ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : .or ( nMask nBit -- nMask ) #// Inlude bit into mask .mask or ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : .nand ( nMask nBit -- nMask ) #// exlude bit from mask .mask not and ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : nand ( nMask nMask -- nMask ) #// exlude bits from mask not and ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . alias .or .on ( n nBit -- n ) #// Define one bit to be on alias .nand .off ( n nBit -- n ) #// Define one bit to be off alias .or .in ( n nBit -- n ) #// Define one pin to be input alias .or .io ( n nBit -- n ) #// Define one pin to be bi-directional alias .nand .out ( n nBit -- n ) #// Define one pin to be an output alias .or .digital ( n nBit -- n ) #// Define one pin to be digital i/o alias .nand .analog ( n nBit -- n ) #// Define one pin to be an analog input // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . alias or .use ( n nMask -- n ) #// Include a bit mask alias nand .usenot ( n nMask -- n ) #// Exclude a bit mask alias nand .ignore ( n nMask -- n ) #// Exclude a bit mask // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . variable __registerName #// Used for register initialization varInterface __registerName // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : RegDef ( -- 0 ) // ( aName -- ) [ -- ] #// Starts a register initialization definition #// #// aName is scanned from the input stream and stored for later #// use into __RegisterName variable. A start value of zero is #// left on the data stack. bl token // Scan register name __registerName! // And store for later use 0 // Leave start value on stack ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : endRegDef ( n -- ) #// Ends a register definition, it retrieves the name given #// with RegDef, appends " _IniVal" and pushes into the input stream #// to be used to create a constant with value n. #// Later use of RegInit RegName will use the RegName_IniVal value #// created here. __registerName@ // Retrieve register name " _IniVal" + // Append " _IniVal" bl untoken // Push into input stream constant // Create the constant ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : regBit ( -- n ) // ( aBitName aBitOperator -- ) [ -- ] #// Defines one register bit to be included in the initial #// value for the register under definition. #// It expects a pin definition in the input stream #// followed by a pin operator (any of .on, .off .in etc.) #// the name of the pin definition will be looked up and #// when it's defined it will be executed, otherwise #// a warning for an invalid pin name will be issued #// and the operator will be eaten from the stream #// to make the definition have no effect. bl Token dup // Get inline token (bit name) bl Untoken // Push a copy back into the input stream // for consuption by #defined postpone #defined // Check if the token is known if // When it's known : bl untoken // Make it being executed // and leave the operator untouched else // And when it's not known : " undefined bit name " // warn user about this " (definition ignored) : " + // (it could be a spelling issue) swap + warning bl token drop // And eat the pin operator from the input stream endIf ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . // Helpers for port and pin definitions // the 'private' part variable __portName #// Current port name variable __pinNumber #// Current pin number variable __portDirs #// Direction bit accumulator variable __portVals #// Inivalue bit accumulator varInterface __portName varInterface __pinNumber varInterface __portDirs varInterface __portVals // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : __dirDef ( bDir -- ) #// Incorporate bDir into current direction values in __portDirs __pinNumber@ << __portDirs@ or __portDirs! ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : __valDef ( bVal -- ) #// Incorporate bVal into current startup values in __portVals __pinNumber@ << __portVals@ or __portVals! ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : __pin++ ( -- ) #// Advance current pin number __pinNumber@ 1 + __pinNumber! ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : __extend ( nBase nPrefix -- nBase ) #// Extend nPrefix with nBase and push it into the input stream. #// Leave a copy of nPrefix on the stack. over + bl untoken ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : __ini_def ( bVal nStem -- ) #// Define an _IniVal constant with value bVal #// Used to construct PORT

_IniVal and TRIS

_IniVal #// constants. __portName@ + " _IniVal" + bl untoken constant ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : __pinDef ( bVal bDir -- ) // ( name ) #// Pin definition, bVal is the startupvalue to be used for the pin #// and bDir is the initial pin direction (0 is output, 1 is input). #// #// This defines a couple of constants : #// #// PORT_ - A meta constant holding the port id for this pin. #// When A is the current port the value of this constant #// will be PORTA. #// LAT_ - A meta constant holding the latch id for this pin. #// When A is the current port the value of this constant #// will be LATA. #// TRIS_ - A meta constant holding the tris id for this pin. #// When A is the current port the value of this constant #// will be TRISA. #// PIN_ - The pin's name, the value will the current value #// of [[__pinNumber]], __pinNumber will be incremented #// for the next pin definition. [[portDef]] will set #// the initial value of __pinNumber to zero. #// #// Furthermore an initial value and an initial port direction will be #// maintained in the __portVals and __portDirs variables. [[endPortDef]] #// will later use these values to set up the port initializers. __dirDef // Incorporate bDir into __portDirs __valDef // Incorporate bVal into __portVals bl token // Get pin name " PORT_" __extend // Build PORT name " PORT" __portName@ + { constant } // do "__portName@ constant PORT_" as a meta constant " LAT_" __extend // Build LAT name " LAT" __portName@ + { constant } // do "__portName@ constant LAT_" as a meta constant " TRIS_" __extend // Build TRIS name " TRIS" __portName@ + { constant } // do "__portName@ constant TRIS_" as a meta constant " PIN_" __extend drop // Build PIN name, drop base name __pinNumber @ constant // Get current pin number __pin++ // Advance current pin number ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . // the 'public' part : input ( -- ) // ( name ) #// Define an input pin #// See [[portDef]] for how to use this #// See [[__pinDef]] for how this works 0 1 __pinDef // Setup pin as input with initial value 0 ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : output ( bIniVal -- ) // ( name ) #// Define an output pin with initial value bIniVal #// See [[portDef]] for how to use this #// See [[__pinDef]] for how this works 0 __pinDef // Setup pin as output ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : in/out ( bIniVal -- ) // ( name ) #// Define an in/out pin with initial value bIniVal #// that is initially set up as an input. #// See [[portDef]] for how to use this #// See [[__pinDef]] for how this works 1 __pinDef // Setup pin as I/O - initially set as input ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : (nc) ( -- ) // ( name ) #// place holder for undefined pins, this is needed #// when there are gaps in the pin range. 0 0 __Pindef // Setup pin as output with value 0 ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : portDef ( -- ) // ( name ) #// Start a port pin definition section #// #// to be used as : #// #// portDef B #// 0 output b0 #// 0 - not used #// 0 output !GSM-RES #// 1 - GSM reset #// input GSM-MON #// 2 - GSM monitor #// 0 output b3 #// 3 - not used #// 0 output GSM-PWR #// 4 - Gsm power #// 0 output GSM-ONOFF #// 5 - GSM on/off line #// input S-CLK #// 6 - Flash update and debug #// 0 in/out SDATA #// 7 - Flash update and debug #// endPortDef bl token __portName! // Get and store port name as a meta variable 0 __pinNumber! // Clear pin number 0 __portDirs! // Clear directions register 0 __portVals! // Clear Inivalues register ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : endPortDef ( -- ) #// End a port pin definition section, see [[portDef]] for how to use #// this. #// #// See [[__pinDef]] and [[portDef]] for how [[__portVals]] and #// [[__portDirs]] are set up. __portVals@ " LAT" __ini_def __portDirs@ " TRIS" __ini_def ; // //////////////////////////////////////////////////////////////////////// // //////////////////////////////////////////////////////////////////////// // // Exception stuff variable exceptionsList 0 exceptionsList ! // Head of the list of exception definitions variable lastException 0 lastException ! // Ordinal value for last exception definition variable codeBuffer // Buffer used for code composition (a string) // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : createException ( nStr -- ) #// Creates an an exception definition with the following data field #// #// pfa + 0 : pointer to object containing the link to previous definiton's pfa + 0 #// pfa + 1 : pointer to object containing the the name of the exception #// pfa + 2 : pointer to object containing the the error text associated with the exception #// #// When the word defined with CreateException is later executed #// it will return pfa bl token // Grab next token dup dup " _" swap + // ( tok tok _tok ) swap bl untoken // ( tok _tok ) lastException @ dup constant // We need to build a target constant as we need to // have a definition available right away. 1 + lastException ! // Advance current exception number bl untoken // ( tok ) create // And we need some data record for later use here // Next value for ExceptionsList exceptionsList @ , // Get head of list and enclose it exceptionsList ! // Store new value for head of list , // Enclose the name , // Enclose nStr does> // Nothing, returning the pfa is default behaviour ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : _cr ( -- nStr ) #// Returns CR LF " \r\n" ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : cb+ ( nStr -- ) #// Append nStr to the contents of CodeBuffer codeBuffer @ swap + codeBuffer ! ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : cr_cb+ ( -- ) #// Append CR LF to CodeBuffer _cr cb+ ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : cb+cr+ ( nStr -- ) #// Append nStr to CodeBuffer then append CR and LF cb+ cr_cb+ ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : startExceptionMessage ( -- ) #// Begin creating a code definition in CodeBufer #// this will be used to create a word called #// ExceptionMessage which will translate an exception #// number into a pointer to it's descriptive text. #// The word created is a target word, i.e. it will later #// be compiled into assembly code to run on the target #// system. " " CodeBuffer ! " : exceptionMessage ( bException -- tsa )" cb+cr+ cr_cb+ " #// Translate bException into a (target) string address tsa, this is a target word" cb+cr+ cr_cb+ " case" cb+cr+ ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : addExceptionMessage ( nList -- nList ) #// Add a line to the case statement making up the body #// of the word ExceptionMessage we are creating in #// CodeBuffer dup 1 + pfa@@ cb+ " of \" " cb+ dup 2 + pfa@@ cb+ " \" endOf " cb+cr+ ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : endExceptionMessage ( -- ) #// End the creation of the code definition in CodeBuffer #// and then execute the definition we just built - resulting #// in the actual creation odf the target word ExceptionMessage . " default" cb+cr+ " drop" cb+cr+ " \" Unknown error\"" cb+cr+ " endCase" cb+cr+ " ;" cb+cr+ codeBuffer @ evaluate ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . : buildExceptionMessages ( -- ) #// Create the word ExceptionBuffer, this is a target word #// which wil translate an exception number into an exception #// message. startExceptionMessage // Start building the text representation exceptionsList @ // Get the exception definion list's head (a pfa) begin // begin a repeat loop dup 0 <> // execute as long there are definitions while addExceptionMessage // Add the translation line for the current definition pfa@@ // Get a pfa for the next definition repeat drop // Drop the 0 endExceptionMessage // Finalize the text representation an evaluate it // to actually build the target word ExceptionMessage ; // . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . // Exception stuff to be used as : // Define exceptions // " Not an error" CreateException ftNone // " Intentional reboot" CreateException ftSystemDown // " Data stack not empty" CreateException ftStackNotEmpty // " Stack depth not equal to last saved" CreateException ftStackError // " BSR does not have the default value" CreateException ftBsrError // " Assertion failed" CreateException ftAssertionFailed // And then before we can use the ExceptionMessage word // for target code we have to call BuildExceptioMessage. // The exceptions themselves were immediately compiled // as constants though and they can be used right afeter // CreateException. We could delay the execution of // BuildExceptionMessages by using some defer trickery. // BuildExceptionMessages // That's it ... // The defer trickery would be something like : // // defer TranslateException // To promise the compiler we're working on it // // afte which TranlateException can freely be // // used in target words. // BuildExceptionMessages // To build the word ExceptionMessage // ' ExceptionMessage is TranslateExecption // To resolve TranslateException onto ExceptionMessage // //////////////////////////////////////////////////////////////////////// } // ////////////////////////////////////////////////////////////////////////// endmodule