an array of label addresses?

[Aslan Babakhanov]

I have both PB9 and PB10 installed separately.
Version with numebred label compiling and running fine with PB9.
But gives error with PB10.

[Dean Gwilliam]

In taking a while to respond to John yesterday I think I missed some of the discussion and code.
Here's the sort of thing I had in mind.
I'm sure Paul's right re the problem of using codeptrs outside of Interpreter() but...
as you can see...
the table of codeptrs is built INSIDE the proc containing them and then passed out so...no problem!
i.e. it seems to work ok.
I've included only enough code to show the concept
i.e. I've omitted writing the "program" using string tokens and building higher level words
i.e. I've just provided a ready-compiled "program" and run it.
I was an advocate of Fastproc's creation and have only gone for GOSUB because I think it's about 2X faster.
More to come!

BTW I'd like to chop the decision code down, under 'compile:' to save as many cycles as possible
ie the code which decides whether to gosub dword <the number> or place <the number> on the stack.

#COMPILE EXE
#DIM ALL
#DEBUG ERROR ON
#DEBUG DISPLAY ON


TYPE tJmp_tbl
    wrd AS ASCIZ * 100
    pSub AS DWORD
END TYPE


SUB Interpreter(aPrg&(), OPT aPrg$(), aJmp_tbl() AS tJmp_tbl)
    LOCAL i&,j&,ln$,tkn$,found&
    STATIC aJmp() AS tJmp_tbl,aStk() AS DWORD
    DIM aStk(10)
    IF ISFALSE ISMISSING(aJmp_tbl()) THEN GOSUB fill_jmp_tbl : EXIT SUB
    IF ISMISSING(aPrg$()) THEN GOSUB compile : EXIT SUB
    GOSUB interpret
    EXIT SUB
fill_jmp_tbl:
    REDIM aJmp(4)
    aJmp(0).wrd = "prim0" : aJmp(0).pSub = CODEPTR(prim0)
    aJmp(1).wrd = "prim1" : aJmp(1).pSub = CODEPTR(prim1)
    aJmp(2).wrd = "colon" : aJmp(2).pSub = CODEPTR(colon)
    aJmp(3).wrd = "comma" : aJmp(3).pSub = CODEPTR(comma)
    DIM aJmp_tbl(LBOUND(aJmp) TO UBOUND(aJmp)) AT VARPTR(aJmp(0))
    RETURN
compile:
    FOR i& = LBOUND(aPrg&) TO UBOUND(aPrg&) 'why is UBOUND 4 and not 3???
        found& = -1
        FOR j& = LBOUND(aJmP) TO UBOUND(aJmp)
            IF aPrg&(i&) = aJmp(j&).pSub THEN
                found& = j&
                EXIT FOR
            END IF
        NEXT
        IF found& <> -1 THEN
            GOSUB DWORD aPrg&(i&)
        ELSE
            ? "placing " & STR$(aPrg&(i&)) & " on aStk()"
        END IF
    NEXT
    RETURN
interpret:
    'not implemented yet but you get the idea
    FOR i& = LBOUND(aPrg$) TO UBOUND(aPrg$)
        ln$ = aPrg$(i&)
        FOR j& = 1 TO PARSECOUNT(ln$,$SPC)
            tkn$ = PARSE$(ln$,$SPC,j&)
            'process tkn$
        NEXT
    NEXT
    RETURN
prim0:
    ? "prim0"
    RETURN
prim1:
    ? "prim1"
    RETURN
colon:
    ? "colon"
    RETURN
comma:
    ? "comma"
    RETURN
END SUB


FUNCTION PBMAIN () AS LONG
    LOCAL aInterpreted$() : DIM aInterpreted$(7)
    LOCAL aJmp_tbl() AS tJmp_tbl
    LOCAL aCompiled&() : DIM aCompiled&(3)
'make primitives jmp tbl
    Interpreter(aCompiled&(),aInterpreted$(),aJmp_tbl())
'"compiled" program
    aCompiled&(0) = aJmp_tbl(0).pSub
'   aCompiled&(1) = aJmp_tbl(1).pSub
'   replace with a number just to show what happens to non-words
    aCompiled&(1) = 3
    aCompiled&(2) = aJmp_tbl(2).pSub
    aCompiled&(3) = aJmp_tbl(3).pSub
'run "compiled program"
    Interpreter(aCompiled&())
END FUNCTION

[Michael Mattias]

Version with numebred label compiling and running fine with PB9.
But gives error with PB10.

If the code is truly identical and none of the intrinsics are "Improved!" then that should be reported to PowerBASIC support.

That said, the change to wide chars as the default condition means the source code cannot be identical, at the very least you'd need an #OPTION ANSIAPI directive.

However I would think the inclusion of that directive should create sufficient equality that the program should run identically without regard to the compiler version used.

All that said...

'why is UBOUND 4 and not 3???

.... your problem is here....

DIM aJmp_tbl(LBOUND(aJmp) TO UBOUND(aJmp)) AT VARPTR(aJmp(0))

A second DIM (vs REDIM) of the same array is ignored without warning or error. In essence, that statement never happened so your bounds do not change.

MCM

[Dean Gwilliam]

Re 'why is UBOUND 4 and not 3???...is just my ramblings.
I'd misunderstood that you get 1+the subscript size cells due to cell 0
i.e. at the time I thought 3 would give me 0 to 2 cells until I read help.

aJmp_tbl() is dim'd only once
i.e. it's just LOCAL'd outside of Interpreter()...and then supplied as an argument, byref, for dim-ing and filling.

Your observations are understandable given my comment which should have been removed and I thank you for them.

If anyone's wondering why the asm sub-forum...it's because this is likely to be a mixed PB/asm app.
I have no problem moving it to the programming sub-forum if that's more appropriate.

[Chris Holbrook]

Dean, what does your code do that couldn't be done with an ON GOSUB?

[Dean Gwilliam]

A good question
I wasn't aware of ON GOSUB so thanks for pointing it out.

I'm storing and copying the codeptrs of labels using arrays and
ultimately jumping to where they point to using gosub dword a(x)

Can you store labels in an array?
I suppose you could store line numbers but they'd be a bit cryptic and my program would be difficult to maintain.

Also I don't think the mechanism is suited to the sort of processing I have in mind because it's more about searching and then gosub-ing streams of addresses rather than selecting one.

I've been working on some stuff and have asked PB if it's ok to continue discussion because, even though this is a pure PB/asm implementation, Forth isn't Basic. If I get the green I'll post and you'll see what I mean.

Thank you for your interest.

[Chris Holbrook]

Originally Posted by Dean Gwilliam

Can you store labels in an array?

at runtime labels are just addresses so storing them as dwords is appropriate.

I've been working on some stuff and have asked PB if it's ok to continue discussion because, even though this is a pure PB/asm implementation, Forth isn't Basic. If I get the green I'll post and you'll see what I mean.

It would be cruel to withold it.

[Michael Mattias]

[My $0.02]

Seems to me this is definitely a "PB" topic... "Using my PB-developed code with other language products, an application prominently suggested in the PowerBASIC sales literature."

[/My $0.02]

MCM

[Dean Gwilliam]

>at runtime labels are just addresses so storing them as dwords is appropriate
I'm currently storing the codeptrs of labels as dwords for use with 'gosub dword' so...labels might not be dwords at the time they need to go into arrays.
Here's a little test...I couldn't see how to do the second line

#COMPILE EXE
#DIM ALL

SUB proc(a() AS DWORD)
    GOSUB blob   'this works fine
    'a(0) = blob '<======how do you do this?
    EXIT SUB
blob:
    ? "do blob"
    RETURN
END SUB

FUNCTION PBMAIN () AS LONG
    REDIM a(0) AS DWORD
    proc(a())
END FUNCTION

> My $0.02
I hope so too because I've really struggled with the existing asm stuff that motivated this and it would be nice to see it in PB/asm. I envisage the sort of debate that happened when implementing that SQUISH-type facility, but bigger.

[Dean Gwilliam]

Pb have kindly given their blessing so...our little "adventure" begins!
Here's where I've got to...Just run the following code and look at the trace that pops up...
It's very much a work in progress and really only a throwaway prototype to test some ideas I had that seem to work...so far.
The real thing is in asm.
I'd like to prototype it all in high-level PB and then re-implement those bits, that need it, back in asm. I'll just finish this "throwaway" and then draw attention to that asm stuff properly.
Thank you for your patience.

 
version 2
#COMPILE EXE
#DIM ALL
#DEBUG ERROR ON
#DEBUG DISPLAY ON



MACRO dbg(s) = PRINT #fDbg, s
MACRO cell_append(arr) = REDIM PRESERVE arr(UBOUND(arr) + 1)
MACRO cell_last(arr) = arr(UBOUND(arr))
MACRO ub(arr) = UBOUND(arr)

MACRO sSz(n) = "\" & REPEAT$(n,$SPC) & "\"



GLOBAL fDbg AS LONG
'dictionary is all of these arrays +
GLOBAL aWrd() AS STRING, aOff() AS LONG, aLen() AS LONG, aDef() AS DWORD


'
''data structures
'GLOBAL aWrd() AS STRING
'GLOBAL aOff() AS LONG
'GLOBAL aLen() AS LONG
'GLOBAL aDef() AS DWORD 'you can't call a LONG var ie it must be a DWORD for some reason.
''GLOBAL nxtw AS LONG
'GLOBAL nxtd AS LONG
'
''primitives
'Def do_a : ? "doing a" : END Def
'Def do_b : ? "doing b" : END Def
'
'Def Do_wrd(wrd AS STRING)
'    LOCAL i AS LONG, j AS LONG
'    ARRAY SCAN aWrd(),COLLATE UCASE, = wrd, TO i
'    IF ISFALSE i THEN
'        dbg("no such wrd " & wrd)
'        EXIT Def
'    END IF
'    FOR j = aOff(i) TO aOff(i) + aLen(i)-1
'        CALL DWORD aDef(j) 'only for primitives so do_c yes but do_d which contain do_c no
'    NEXT
'? "just finished Do_wrd(" & wrd & ")",,"Do_wrd()"
'END Def


UNION slot
    lng AS LONG
    sgl AS SINGLE
    dwd AS DWORD
END UNION


SUB Dbg_outer(itm$, isa$, cmplflg&, sodo$)
    LOCAL ln$
    ln$ =  USING$(  sSz(15) & " is a " & sSz(15) & " cmpl=# so " & _
                    sSz(40),itm$,isa$,cmplflg&,sodo$ _
                 )
    dbg(ln$)
END SUB



'new Def
SUB Outer(mandate$, OPT aCode&(), aLn$())
    LOCAL i&,j&,k&,l&,m&
    LOCAL ln$,tkn$,wrd&
    STATIC aStk() AS slot
    STATIC aPrim() AS STRING
    STATIC aSub() AS DWORD
    STATIC T AS slot PTR 'top of data stack
    STATIC cmpl_flg&
    STATIC nm_done&

    SELECT CASE mandate$
        CASE "interpret"
            GOSUB init
            GOSUB interpret
        CASE "run_code"
            GOSUB run_code
    END SELECT
    EXIT SUB
init:
    DIM aPrim(3), aSub(3)
    aPrim(0) = ":"  : aSub(0) = CODEPTR(colon)
    aPrim(1) = ";"  : aSub(1) = CODEPTR(semi_colon)
    aPrim(2) = "+"  : aSub(2) = CODEPTR(plus)
    aPrim(3) = "."  : aSub(3) = CODEPTR(dot)
    REDIM aStk(17)
    T = VARPTR(aStk(LBOUND(aStk)))
    DECR T 'set up for use INCR + assign
    RETURN
interpret:
    FOR i& = LBOUND(aLn$) TO UBOUND(aLn$)
        ln$ = aLn$(i&)
        IF ln$ = "" THEN ITERATE

        dbg("forth line___________________________________" & ln$)

        FOR j& = 1 TO PARSECOUNT(ln$,$SPC)
            tkn$ = PARSE$(ln$,$SPC,j&)
? tkn$,,"interpreting"
            ARRAY SCAN aPrim(), = tkn$, TO k&
            IF k& THEN 'is primitive
                DECR k& 'to give absolute not relative index
                IF cmpl_flg& THEN
                    IF tkn$ = ";" THEN
                        Dbg_outer(tkn$, "semi", cmpl_flg&, "do wrd")
                        GOSUB DWORD aSub(k&)
                        Dbg_dictionary()
                    ELSE
                        Dbg_outer(tkn$, "prim", cmpl_flg&, "inject aDef")
                        cell_append(aDef)
                        cell_last(aDef) = aSub(k&)
                        cell_last(aLen) += 1
                    END IF
                ELSE
                    Dbg_outer(tkn$, "prim", cmpl_flg&, "do wrd")
                    GOSUB DWORD aSub(k&)
                END IF
                GOTO over
            END IF
            IF UBOUND(awrd) > -1 THEN
                ARRAY SCAN aWrd(), = tkn$, TO k&
                IF k& THEN 'is EXISTING wrd
                    DECR k& 'to give absolute not relative index
                    IF cmpl_flg& THEN
                        Dbg_outer(tkn$, "existing wrd", cmpl_flg&, "inject sub-wrds aDef")
                    ELSE
                        Dbg_outer(tkn$, "existing wrd", cmpl_flg&, "do sub-wrds " & _
                                STR$(aOff(k&)) & " to " & STR$(aOff(k&) + aLen(k&) - 1 ) )
                        FOR l& = aOff(k&) TO aOff(k&) + aLen(k&) - 1
                            ARRAY SCAN aSub(), = aDef(l&), TO m&
                            IF m& THEN 'sub
                                GOSUB DWORD aDef(l&)
                            ELSE
                                INCR T
                                @T.sgl = aDef(l&)
                            END IF
                        NEXT
                    END IF
                    GOTO over
                END IF
            END IF
            'new wrd or number
            IF cmpl_flg& THEN
                IF ISFALSE nm_done& THEN
                    Dbg_outer(tkn$, "NEW wrd", cmpl_flg&, "inject aDef")
                    cell_append(aWrd)
                    cell_last(aWrd) = tkn$
                    cell_append(aOff)
                    cell_last(aOff) = ub(aDef)+1
                    cell_append(aLen)
                    nm_done = 1
                ELSE
                    Dbg_outer(tkn$, "num", cmpl_flg&, "inject aDef")
                    cell_append(aDef)
                    cell_last(aDef) = VAL(tkn$)
                    cell_last(aLen) += 1
                END IF
            ELSE
                Dbg_outer(tkn$, "num", cmpl_flg&, "on aStk")
                INCR T
                @T.sgl = VAL(tkn$)
            END IF
over:



'            cell_append(aCode&) 'you may need more than just one cell so...bug
'            IF wrd& THEN
'                IF ISFALSE cmpl_flg& THEN
'                    dbg("tkn$ = " & tkn$ & " wrd& = " & STR$(wrd&) & " cmpl_flg& = " & STR$(cmpl_flg&))
'                    GOSUB DWORD wrd&
'                    dbg("tkn$ = " & tkn$ & " wrd& = " & STR$(wrd&) & " cmpl_flg& = " & STR$(cmpl_flg&))
'                ELSE
'                    IF tkn$ = ";" THEN
'                        GOSUB DWORD wrd&
'                    ELSE
'                        cell_append(aDef)
'                        cell_last(aDef) = wrd&
'                        cell_last(aLen) += 1
'                    END IF
'                    dbg("tkn$ = " & tkn$ & " wrd& = " & STR$(wrd&) & " cmpl_flg& = " & STR$(cmpl_flg&))
'                    cell_last(aCode&) = wrd&
'                END IF
'            ELSE
'                IF ISFALSE cmpl_flg& THEN
'                    INCR T
'                    @T.sgl = VAL(tkn$)
'                    dbg("tkn$ = " & tkn$ & " wrd& = " & STR$(wrd&) & " cmpl_flg& = " & STR$(cmpl_flg&))
'                ELSE
'                    IF ISFALSE nm_done& THEN
'                        cell_append(aWrd)
'                        cell_last(aWrd) = tkn$
'                        cell_append(aOff)
'                        cell_last(aOff) = ub(aDef)+1
'                        cell_append(aLen)
'                        nm_done& = 1
'                    ELSE
'                        cell_append(aDef)
'                        cell_last(aDef) = VAL(tkn$)
'                        cell_last(aLen) += 1
'                    END IF
'                    dbg("tkn$ = " & tkn$ & " wrd& = " & STR$(wrd&) & "cmpl_flg& = " & STR$(cmpl_flg&))
'                END IF
'            END IF
        NEXT
    NEXT
    RETURN
run_code:
''? "starting run_code"
'    FOR i& = LBOUND(aCode&) TO UBOUND(aCode&) 'why is UBOUND 4 and not 3???
'        wrd& = 0
'        FOR j& = LBOUND(aJmP) TO UBOUND(aJmp)
'           IF aCode&(i&) = aJmp(j&).pJmp THEN
'               wrd& = aJmp(j&).pJmp
'               EXIT FOR
'           END IF
'        NEXT
'        IF wrd& THEN
'            GOSUB DWORD wrd&
'        ELSE
'            INCR T
'            @T.sgl = aCode&(i&)
'        END IF
'    NEXT
    RETURN
'=================================================
'forth primitives
colon:
    dbg("doing colon")
    cmpl_flg& = 1
    nm_done& = 0
    RETURN
semi_colon:
    dbg("doing semi_colon")
    cmpl_flg& = 0
    RETURN
plus: 'singles only
    dbg("doing plus")
    @T.sgl = @T.sgl + @T[-1].sgl
    RETURN
dot:
    dbg("doing dot")
    ? STR$(@T.sgl),,"dot"
    RETURN
END SUB

'
'SUB New_wrd(wrd$,defn$)
'    LOCAL i&, j&, k&, l&, pcnt&, csv$, w$
'    aOff(nxtw) = nxtd
'    pcnt& = PARSECOUNT(defn$,",")
'    FOR i = 1 TO pcnt&
'        w$ = PARSE$(defn$,",",i)
'        ARRAY SCAN aWrd(),COLLATE UCASE, = w$, TO j&
'        IF ISFALSE j& THEN
'            ' ? "not a wrd probably a number",,"New_wrd()"
'        ELSE
'            IF aLen(j) = 1 THEN 'primitive
'                aDef(nxtd) = aDef(aOff(j&)+k&)
'                INCR nxtd
'                INCR aLen(nxtw)
'            ELSE
'                l& = aLen(j)-1
'                FOR k& = 0 TO l&
'                    aDef(nxtd) = aDef(aOff(j&)+k&)
'                    INCR nxtd
'                    INCR aLen(nxtw)
'                NEXT
'            END IF
'        END IF
'    NEXT
'    aWrd(nxtw) = wrd$
'    INCR nxtw
'END SUB

ENUM eDisp
    index
    aWrd
    aOff
    aLen
    aDef
END ENUM

SUB Dbg_dictionary()
    LOCAL i&,j&,ln$,sOff$,sLen$,sDct$,s$

    LOCAL aDisp() AS STRING
'    ? STR$(%eDisp.index) & "," & STR$(%eDisp.aDef) & "," & STR$(LBOUND(aDef)) & "," & STR$(UBOUND(aDef))
    DIM aDisp(%eDisp.index TO %eDisp.aDef,LBOUND(aDef) TO UBOUND(aDef))

    dbg("Dbg_dictionary_______________________")

    ln$ = USING$(   sSz(5) & sSz(5) & sSz(5) & sSz(5) & sSz(5), _
                    "index", "aWrd()","aOff()","aLen()","aDef()")
    dbg(ln$)
    '? STR$(LBOUND(aDef)) & "," & STR$(UBOUND(aDef))
    '? STR$(%eDisp.index) & "," & STR$(%eDisp.aDef) & "," & STR$(LBOUND(aDef)) & "," & STR$(UBOUND(aDef))
    FOR i& = LBOUND(aDef) TO UBOUND(aDef)
        aDisp(%eDisp.index,i&) = TRIM$(STR$(i&))
        IF i& <= UBOUND(aWrd) THEN
            IF aWrd(i&) <> "" THEN
            '? STR$(%eDisp.aWrd) & "," & STR$(aOff(i&)) & "," & TRIM$(aWrd(i&))
            aDisp(%eDisp.aWrd,aOff(i&)) = TRIM$(aWrd(i&))
            aDisp(%eDisp.aOff,aOff(i&)) = TRIM$(STR$(aOff(i&)))
            aDisp(%eDisp.aLen,aOff(i&)) = TRIM$(STR$(aLen(i&)))
        END IF
        END IF
        aDisp(%eDisp.aDef,i) = TRIM$(STR$(aDef(i&)))
        ln$ = USING$(   sSz(5) & sSz(5) & sSz(5) & sSz(5) & sSz(5), _
                        aDisp(%eDisp.index,i), _
                        aDisp(%eDisp.aWrd,i), _
                        aDisp(%eDisp.aOff,i), _
                        aDisp(%eDisp.aLen,i), _
                        aDisp(%eDisp.aDef,i) _
                    )
        dbg(ln$)
        ln$ = ""
    NEXT
    dbg("_____________________________________")
END SUB



FUNCTION PBMAIN () AS LONG
    fDbg = FREEFILE : OPEN "debug.txt" FOR OUTPUT AS #fDbg
    dbg("test")

'    DIM aWrd(1 TO %ARRAY_LENGTH) AS STRING
'    DIM aOff(1 TO %ARRAY_LENGTH) AS LONG
'    DIM aLen(1 TO %ARRAY_LENGTH) AS LONG
'    DIM aDef(1 TO %ARRAY_LENGTH) AS DWORD

    'set up primitives
'    aWrd(1) = "do_a" : aOff(1) = 1 : aLen(1) = 1 : aDef(1) = CODEPTR(do_a)
'    aWrd(2) = "do_b" : aOff(2) = 2 : aLen(2) = 1 : aDef(2) = CODEPTR(do_b)
'    nxtw = 3
'    nxtd = 3

'    'test level 0/primitive words
'    Do_wrd("do_a")
'    Do_wrd("do_b")
'    'create and test level 1 words
'    New_wrd("do_c","do_a,do_b")
'    Do_wrd("do_c")
'    'create and test level 2 words
'    New_wrd("do_d","do_c,do_a")
'    Do_wrd("do_d")
'    New_wrd("do_e","do_b")
'    Do_wrd("do_e")
'    'check data structures
'replaced by
    LOCAL i&
    LOCAL aLn$() : DIM aLn$(100)
    LOCAL aCode&()


'    aCode&(0) = aJmp_tbl(0).pJmp
'    aCode&(1) = 3
''    aCode&(1) = aJmp_tbl(1).pJmp
'    aCode&(2) = aJmp_tbl(2).pJmp
'    aCode&(3) = aJmp_tbl(3).pJmp
'    Outer("run_code", aCode&())

'    aLn$(0) = "3 4 + ."
'    aLn$(1) = "5 + ."

    aLn$(0) = ": w1 + . ;"
    aLn$(1) = ": w2 10 ;"
    aLn$(2) = "3 w2 w1"

'    aLn$(2) = ": wrd1 prim0 prim1 ;"
'    aLn$(3) = "wrd1"
'    aLn$(4) = ": wrd2 wrd1 prim0 ;"
'    aLn$(5) = "wrd2"
'    aLn$(6) = ": wrd3 prim1 ;"
'    aLn$(7) = "wrd3"

    Outer("interpret",aCode&(),aLn$())

'FOR i& = LBOUND(aCode&) TO UBOUND(aCode&)
'    dbg(aCode&(i&))
'NEXT

    Outer("run_code",aCode&())

'    Dbg_dictionary()

    CLOSE #fDbg : SHELL ENVIRON$("COMSPEC") + " /C Notepad.exe " & "debug.txt"
END FUNCTION

[Mike Doty]

I'm putting an interpreter together and am not clever enough to do a BASIC one so I'm reverting to a Forth-like one

MACROs might be used instead of constants, functions, labels and codeptr.

[Dean Gwilliam]

I've just replaced version1 above with version 2 and...
it works i.e. you end up with 13.
So...we've now got something to hack and contrast with Charle's Moore's MACHINE FORTH which I've always liked the look of.
Problem is...my asm's non-existent so I've always struggled but...
I'm determined to thoroughly understand this now by implementing it in PB
For those interested...here are some links.
http://www.ultratechnology.com/mfp21.htm
http://c2.com/cgi/wiki?MachineForth
http://www.colorforth.com/forth.html
try googling "Special Issue June 2000 An Introduction to Machine Forth John" to get the pdf

As an example of the sort of thing I'd like to do...
One thing I noticed is that where mutiple subroutine returns are adjacent, machine forth SQUISHES them and replaces them with a single JMP to the last RET's destination...I'm guessing I need my own return stack instead of the GOSUB one.

Mike
Thanks for your interest and suggestion.
I use macros a lot and and find them extremely useful.
I don't think they can provide the syntax I'm after
i.e. I don't think they could represent things like these operators

v+ and v= ... in e.g ... revs cogs v+ profit v=

where you have a spreadsheet

______2002 2003 2004....
revs___34_____42__14
cogs___22_____13__17
---------------------------
profit___56_____55__31

FWIW I have tried.

Here's the sort of syntax we're talking about, from version 2 above.

    : w1 + . ;
    : w2 10 ;
    3 w2 w1

[Dean Gwilliam]

I've hacked the above interpreter to acommodate the words 'equals' and 'if'
I've attempted them in asm.
I tested equals i.e. cmp...the top two values in aStk() by changing the "program" with two equal numbers prior to 'if' and then using jz dummy and jnz dummy and it seemed to work.

My tests show that you can jz to a label e.g. dummy but I'm storing label codeptrs in an array so...
how would you jz to a label codeptr stored in an array?
BTW Chris H...jz label does suggest that a label is an address/dword so...you appear to be right on that!
Is a code ptr therefore just a VARPTR of a dword/address
i.e. what is a codeptr

re replacing gosub/return with it's asm equivalent...
p89 of my book by John Sacha and Peter Norton 'Assembly Language for the PC'
actually contrasts BASIC with it's asm equivalent (albeit in DOS)
i.e. call/ret
WOW! Was this considered a good book?

equals: 'EBX, ESI, & EDI auto push & pop'd on entry and exit to sub
'    pb_to_asm
    ! MOV EAX, T
    ! MOV EAX, [EAX]
    ! MOV EBX, S         ;MACRO S = T[-%env.wrd_sz]
    ! MOV EBX, [EBX]
    ! cmp eax, ebx       ;sets up zero flg ready for eg iff
'    asm_to_pb
    ! ret
iff: 'can use tkn "if" though
    dbg("doing iff")
    LOCAL x& : x& = &HDEADBEEF
    INCR tkn_no& 'ok
    tkn$ = PARSE$(ln$,$SPC,tkn_no&)
    ARRAY SCAN aW(), = tkn$, TO iPos&
    IF iPos& THEN
        DECR iPos&
        LOCAL d AS DWORD
        d = aD(aX(iPos&))
        pb_to_asm
        ! call d
        asm_to_pb
    END IF
    ! ret

Here's how it fits in...i.e. a compile-able example...complete with design spec at the top

'The Registers
'======================================
'PC     The Program counter
'A      The Address register for memory access
'T      Top of data stack, the implied operand for arithmetic, logic and IF instructions
'done
'S      The 'subtop' register, the second on the data stack.
'done
'R      Top of return stack

'The Circular Stacks
'======================================
'The Data Stack     (S2 .. S11) A 16-element circular stack below T and S
'done
'The Return Stack   (R1 .. R10) A 16-element circular stack below R
'
'The Instruction Set
'======================================
'   Control
'======================================
'ELSE  Unconditional jump
'IF    Non-Destructive IF. Jump if T(19..0) is false (leaves stack untouched)
'   I understand this as jmp if @T = 0
'-IF   Non-destructive jump if-carry-false
'   http://stackoverflow.com/questions/3139772/check-if-carry-flag-is-set
'CALL  A Subroutine call. Push PC+1 to R
'RET   Return from Subroutine. Pop R to PC

'A Register
'======================================
'A      ( -- A ; T = A )                Push A to T
'@A     ( -- n0 ; T = ^A )              Fetch contents of memory at address A and push to T.
'@A+    ( -- n0 ; T = ^A, A=A+1 )       Fetch A and push to T. Increment A. ('Auto Post-Increment')
'!A     ( n0 --  ; mem(A) = n0 )        Pop T to memory at address A
'!A+    ( n0 --  ; mem(A) = n0, A=A+1 ) Pop T to memory at address A. Increment A
'A!     ( a0 -- ; A = T )               Pop T to A

'R Register and the Return Stack
'======================================
'POP    ( -- r0 ;  r0 -R- ;  T = R )    Pop R and push to T
'PUSH   ( n0 -- ;  -R- n0 ;  R = T )    Pop T and push to R
'@R+    ( -- n0 ; T = ^R, R=R+1 )       Fetch from address in R, push to T.  Increment R
'!R+    ( n0 -- ; mem(R) = n0, R=R+1 )  Pop T to memory at address R. Increment R

'Data Stack Manipulation
'======================================
'DUP    ( n0 -- n0 n0 )                 Push T to T
'DROP   ( n0 -- )                       Pop T
'OVER   ( n1 n0 -- n1 n0 n1 )           Push S to T

'Arithmetic
'======================================
'+      ( n1 n0 -- n0'  ; T = T + S )
'       ie Add S to T.
'+*     ( n1 n0 -- n1 n0'  ; T = T + S  {T(0)=1} )
'       ie If  T(0) is true, add S to T non-destructively. A multiply step.
'       (  n1 n0 -- n1 n0  ; {T(0)=0} )
'       ie If T(0) is false, do nothing.

'Bitwise
'======================================
'COM    ( n0 -- n0' ; T = NOT(T) )      Complement T. Invert each bit.
'AND    ( n1 n0 -- n0' ; T = S AND T )  AND S to T
'-OR    ( n1 n0 -- n0' ; T = S XOR T )  Exclusive OR S to T
'2*     ( n0 -- n0' ; T = T * 2 )       Shift Left one bit. Write 0 to T(0)
'2/     ( n0 -- n0' ; T = T div 2 )     Shift Right one bit. WriteT(20..1) to T(19..0). Write 0 to T(20).

'Miscellaneous
'======================================
'#      ( -- n0 , | <number )           Fetch a number from PC+1 and push to T. Increment PC .
'NOP    (  )                            Do nothing for 1 cycle.

'The Extensions
'======================================
'Very few words need to be added to an assembler based on the above instruction
'set to produce a working Forth system. The main categories are:
'Definitions
':                       Colon starts a new definition
';                       Return. Does not end a definition
'CREATE ... DOES          To allow new types
'CODE  ... ENDCODE       For machine code
'Control Structures
'======================================
'These structures have the same meanings as Classical Forth but...
'the flag/carry remain on the stack after execution.
'flag? IF <tt THEN <ff                  If flag? is true execute <tt
'carry? -IF <tt THEN <ff                If carry? is true execute <tt
'flag? IF <tt ELSE <ff THEN             If flag? is true execute <tt, else execute <ff
'carry? -IF <tt ELSE <ff THEN           If carry? is true execute <tt, else execute <ff
'( index ) BEGIN ... NEXT               A loop with an single index
'BEGIN  flag?  WHILE <tt REPEAT         While flag? is true execute <tt
'BEGIN carry? -WHILE <tt REPEAT         While carry is true execute <tt
'BEGIN ...  flag?  UNTIL                Loop until flag? is true
'BEGIN ... carry? -UNTIL                Loop until carry? is true
'
'


#COMPILE EXE
#DIM ALL
#DEBUG ERROR ON
#DEBUG DISPLAY ON


%primitives = 6

UNION slot
    num AS SINGLE
    wrd AS DWORD
END UNION

ENUM env
    wrd_sz = 4 'bytes
    debug_on = 1
    trace_on = 0
END ENUM

ENUM typ
    num
    wrd
END ENUM 'is there a more direct way of tieing enum to union other than eg select

ENUM cmpl_flg
    OFF
    ON = 10   '10 for adding to other flags
END ENUM

ENUM eDisp
    index
    aW
    aX
    aL
    aD
END ENUM



MACRO dbg(s) = PRINT #fDbg, s
MACRO cell_append(arr,n) = REDIM PRESERVE arr(UBOUND(arr) + n)
MACRO cell_last(arr) = arr(UBOUND(arr))
MACRO ub(arr) = UBOUND(arr)

MACRO sSz(n) = "\" & REPEAT$(n,$SPC) & "\"
MACRO S = T[-%env.wrd_sz]


GLOBAL fDbg AS LONG
'dictionary is all of these arrays +
'ie aW(), aDefinition(), aIndex of 1st cell of word in aDefintion
GLOBAL aW() AS STRING, aX() AS LONG, aL() AS LONG, aD() AS DWORD



'
''data structures
'GLOBAL aW() AS STRING
'GLOBAL aX() AS LONG
'GLOBAL aLen() AS LONG
'GLOBAL aD() AS DWORD 'you can't call a LONG var ie it must be a DWORD for some reason.
''GLOBAL nxtw AS LONG
'GLOBAL nxtd AS LONG
'
''primitives
'Def do_a : ? "doing a" : END Def
'Def do_b : ? "doing b" : END Def
'
'Def Do_wrd(wrd AS STRING)
'    LOCAL i AS LONG, j AS LONG
'    ARRAY SCAN aW(),COLLATE UCASE, = wrd, TO i
'    IF ISFALSE i THEN
'        dbg("no such wrd " & wrd)
'        EXIT Def
'    END IF
'    FOR j = aX(i) TO aX(i) + aLen(i)-1
'        CALL DWORD aD(j) 'only for primitives so do_c yes but do_d which contain do_c no
'    NEXT
'? "just finished Do_wrd(" & wrd & ")",,"Do_wrd()"
'END Def




SUB Dbg_outer(itm$, isa$, cmplflg&, sodo$)
    LOCAL ln$
    ln$ =  USING$(  sSz(15) & " is a " & sSz(15) & " cmpl=# so " & _
                    sSz(40),itm$,isa$,cmplflg&,sodo$ _
                 )
    dbg(ln$)
END SUB




'new Def
SUB Outer(mandate$, OPT aCode&(), aLn$())
    'subs beginning UA, uB etc are internal utils not primitives
    LOCAL i&,j&,k&,l&,m&
    LOCAL ln$,ln_no&, tkn$, tkn_no&, nxt$,wrd&,typ&, pD AS DWORD PTR, lngth&
    LOCAL iPos&, ctr&
    LOCAL cmpl_flg&
    LOCAL wrd_nm$
    LOCAL addr1&, addr2& '
    STATIC aStk() AS slot, T AS slot PTR
    SELECT CASE mandate$
        CASE "interpret"
            GOSUB uInit
            GOSUB uInterpret
        CASE "run_code"
            'GOSUB uRun_code
    END SELECT
    EXIT SUB
uInit:
    cell_append(aW,%primitives)
    cell_append(aX,%primitives)
    cell_append(aL,%primitives)
    cell_append(aD,%primitives)
    aW(0) = ":"       : aX(0) = 0 : aL(0) = 1  : aD(0) = CODEPTR(colon)
    aW(1) = ";"       : aX(1) = 1 : aL(1) = 1  : aD(1) = CODEPTR(semi_colon)
    aW(2) = "+"       : aX(2) = 2 : aL(2) = 1  : aD(2) = CODEPTR(plus)
    aW(3) = "."       : aX(3) = 3 : aL(3) = 1  : aD(3) = CODEPTR(dot)
    aW(4) = "if"      : aX(4) = 4 : aL(4) = 1  : aD(4) = CODEPTR(iff)
    aW(5) = "dummy"   : aX(5) = 5 : aL(5) = 1  : aD(5) = CODEPTR(dummy)
    REDIM aStk(17)
    T = VARPTR(aStk(LBOUND(aStk)))
    DECR T 'set up for use INCR + assign
    RETURN
uInterpret:
    FOR ln_no& = LBOUND(aLn$) TO UBOUND(aLn$)
        ln$ = aLn$(ln_no&)
? ln$
        IF ln$ = "" THEN ? "no more lines" : EXIT SUB
        dbg("forth line___________________________________" & ln$)
        FOR tkn_no& = 1 TO PARSECOUNT(ln$,$SPC) 'you need to look ahead at ALL tokens to do 'if'
            tkn$ = PARSE$(ln$,$SPC,tkn_no&)
? tkn$
            REGEXPR "^[.]*[0-9]+" IN tkn$ TO iPos& 'careful cos . on it's own is a wrd
            IF iPos& THEN typ& = %typ.num ELSE typ& = %typ.wrd
            SELECT CASE AS LONG typ& + cmpl_flg& 'flattens decisions
                CASE 0
                    dbg("num and cmpl_flg off...on stack ") & tkn$
                    INCR T : @T.num = VAL(tkn$)
                CASE 1
                    dbg("existing wrd and cmpl_flg off...doing") & tkn$
                    GOSUB do_tkn
                CASE 10 'num and cmpl_flg on
                    dbg("num and cmpl_flg on") & tkn$
                    cell_append(aD,1)
                    cell_last(aD) = VAL(tkn$)
                    INCR cell_last(aL)
                CASE 11 'wrd and cmpl_flg on
                    IF tkn$ = ";" THEN
                        dbg("wrd and cmpl_flg on...doing ") & tkn$
                        GOSUB do_tkn
                    ELSE 'compile existing wrd
                        dbg("wrd and cmpl_flg on...compiling ") & tkn$
                        ARRAY SCAN aW(), = tkn$, TO iPos&
                        DECR iPos& 'relative to actual index
                        FOR ctr& = aX(iPos&) TO aX(iPos&) + aL(iPos&) - 1
                            cell_append(aD,1)
                            cell_last(aD) = aD(ctr&)
                            INCR cell_last(aL)
                        NEXT
                    END IF
            END SELECT
        NEXT
    NEXT
    RETURN
do_tkn: 'ie there will be a do_wrd which just searches aX() which will be faster
    ARRAY SCAN aW(), = tkn$, TO iPos&
    IF iPos& THEN
        DECR iPos& 'relative to actual index
        IF iPos& < %primitives THEN 'primitive i.e. 0-5 is < 6 i.e. no of primitives
            ? tkn$ & " is prinitive"
            GOSUB DWORD aD(aX(iPos&))
        ELSE 'higher word
            ? tkn$ & " is higher wrd"
            FOR ctr& = aX(iPos&) TO aX(iPos&) + aL(iPos&) - 1
                'this lower level is a prim or number
                ARRAY SCAN aD() FOR %primitives, = aD(ctr&), TO iPos&
                IF iPos& THEN
                    GOSUB DWORD aD(ctr&)
                ELSE
                    INCR T : @T.num = aD(ctr&)
                END IF
            NEXT
        END IF
    ELSE 'num
        ? tkn$ & " is num"
        INCR T : @T.num = VAL(tkn$)
    END IF
    RETURN
'forth primitives
'don't use ESB EBP ie pb uses these
'pb lines require constant EBX, ESI, & EDI so must push & pop before and after any asm
'this is automatically done on entering and leaving a sub
'if you asm uses EAX, ECX, or EDX you should push&pop these either side of any pb
'pushad,popad,pushfd,popfd
colon:
    dbg("doing colon")
    INCR tkn_no&
    wrd_nm$ = PARSE$(ln$,$SPC,tkn_no&)
    cell_append(aW,1)
    cell_last(aW) = wrd_nm$

    cell_append(aX,1) 'comes after appending new aD() cell
    cell_last(aX) = ub(aD) + 1

    cell_append(aL,1) 'comes after appending new aD() cell
    cell_last(aL) = 0

    cmpl_flg& = %cmpl_flg.on
    RETURN
semi_colon:
    dbg("doing semi_colon")
    cmpl_flg& = %cmpl_flg.off
    RETURN
plus: 'singles only
    dbg("doing plus")
    @T.num = @T.num + @T[-1].num
    RETURN
equals: 'EBX, ESI, & EDI auto push & pop'd on entry and exit to sub
    ! PUSH EAX : PUSH ECX : PUSH EDX
    ! MOV EAX, T
    ! MOV EAX, [EAX]
    ! MOV EBX, S         ;MACRO S = T[-%env.wrd_sz]
    ! MOV EBX, [EBX]
    ! cmp eax, ebx       ;sets up zero flg ready for eg iff
    ! pop EAX : PUSH ECX : PUSH EDX
     RETURN
iff: 'can use tkn "if" though
    dbg("doing iff")
    LOCAL x& : x& = &HDEADBEEF
    INCR j& 'ok
    tkn$ = PARSE$(ln$,$SPC,j&)
    'turn tkn$ into addr
    ! jz sddr but is this a gosub?
    RETURN
minus_if:
    dbg("doing minus_if")
    IF @T.num < 0 THEN
        'jmp to address in next slot to the one holding this jmp
    ELSE
        'jmp to address in slot after else if there is an else
    END IF
    RETURN
dot:
    dbg("doing dot")
    ? STR$(@T.num),,"dot"
    RETURN
dummy:
    dbg("doing dummy")
    ? "dummy"
    RETURN
END SUB
'
'SUB New_wrd(wrd$,defn$)
'    LOCAL i&, j&, k&, l&, pcnt&, csv$, w$
'    aX(nxtw) = nxtd
'    pcnt& = PARSECOUNT(defn$,",")
'    FOR i = 1 TO pcnt&
'        w$ = PARSE$(defn$,",",i)
'        ARRAY SCAN aW(),COLLATE UCASE, = w$, TO j&
'        IF ISFALSE j& THEN
'            ' ? "not a wrd probably a number",,"New_wrd()"
'        ELSE
'            IF aLen(j) = 1 THEN 'primitive
'                aD(nxtd) = aD(aX(j&)+k&)
'                INCR nxtd
'                INCR aLen(nxtw)
'            ELSE
'                l& = aLen(j)-1
'                FOR k& = 0 TO l&
'                    aD(nxtd) = aD(aX(j&)+k&)
'                    INCR nxtd
'                    INCR aLen(nxtw)
'                NEXT
'            END IF
'        END IF
'    NEXT
'    aW(nxtw) = wrd$
'    INCR nxtw
'END SUB


SUB Dbg_dictionary()
    LOCAL i&,j&,ln$,sOff$,sLen$,sDct$
    LOCAL w&
    w& = 20
    LOCAL aDisp() AS STRING
    DIM aDisp(%eDisp.index TO %eDisp.aD,LBOUND(aD) TO UBOUND(aD))
    dbg("Dbg_dictionary_______________________")
    ln$ = USING$(   sSz(w&) & sSz(w&) & sSz(w&) & sSz(w&) & sSz(w&), _
                    "index", "aW()","aX()","aL()","aD()")
    dbg(ln$)
    FOR i& = LBOUND(aD) TO UBOUND(aD)
        aDisp(%eDisp.index,i&) = TRIM$(STR$(i&))
        IF i& <= UBOUND(aW) AND aW(i&) <> "" THEN
            aDisp(%eDisp.aW,aX(i&)) = TRIM$(aW(i&))
            aDisp(%eDisp.aX,aX(i&)) = TRIM$(STR$(aX(i&)))
            aDisp(%eDisp.aL,aX(i&)) = TRIM$(STR$(aL(i&)))
        END IF
        aDisp(%eDisp.aD,i) = TRIM$(STR$(aD(i&)))
        ln$ = USING$(   sSz(w&) & sSz(w&) & sSz(w&) & sSz(w&) & sSz(w&), _
                        aDisp(%eDisp.index,i), _
                        aDisp(%eDisp.aW,i), _
                        aDisp(%eDisp.aX,i), _
                        aDisp(%eDisp.aL,i), _
                        aDisp(%eDisp.aD,i) _
                    )
        dbg(ln$)
        ln$ = ""
    NEXT
    dbg("_____________________________________")
END SUB



FUNCTION PBMAIN () AS LONG
#IF %env.debug_on = 1
    fDbg = FREEFILE : OPEN "debug.txt" FOR OUTPUT AS #fDbg
    dbg("test")
#ENDIF
#IF %env.trace_on = 1
    TRACE NEW "trace.txt" : TRACE ON
#ENDIF
'    DIM aW(1 TO %ARRAY_LENGTH) AS STRING
'    DIM aX(1 TO %ARRAY_LENGTH) AS LONG
'    DIM aLen(1 TO %ARRAY_LENGTH) AS LONG
'    DIM aD(1 TO %ARRAY_LENGTH) AS DWORD

    'set up primitives
'    aW(1) = "do_a" : aX(1) = 1 : aLen(1) = 1 : aD(1) = CODEPTR(do_a)
'    aW(2) = "do_b" : aX(2) = 2 : aLen(2) = 1 : aD(2) = CODEPTR(do_b)
'    nxtw = 3
'    nxtd = 3

'    'test level 0/primitive words
'    Do_wrd("do_a")
'    Do_wrd("do_b")
'    'create and test level 1 words
'    New_wrd("do_c","do_a,do_b")
'    Do_wrd("do_c")
'    'create and test level 2 words
'    New_wrd("do_d","do_c,do_a")
'    Do_wrd("do_d")
'    New_wrd("do_e","do_b")
'    Do_wrd("do_e")
'    'check data structures
'replaced by
    LOCAL i&
    LOCAL aLn$() : DIM aLn$(100)
    LOCAL aCode&()


'    aCode&(0) = aJmp_tbl(0).pJmp
'    aCode&(1) = 3
''    aCode&(1) = aJmp_tbl(1).pJmp
'    aCode&(2) = aJmp_tbl(2).pJmp
'    aCode&(3) = aJmp_tbl(3).pJmp
'    Outer("run_code", aCode&())

'    aLn$(0) = "3 4 + ."
'    aLn$(1) = "5 + ."

    aLn$(0) = ": w1 + . ;"
    aLn$(1) = ": w2 10 ;"
    aLn$(2) = "3 w2 w1"
    aLn$(3) = "0 if dummy"

'    aLn$(2) = ": wrd1 prim0 prim1 ;"
'    aLn$(3) = "wrd1"
'    aLn$(4) = ": wrd2 wrd1 prim0 ;"
'    aLn$(5) = "wrd2"
'    aLn$(6) = ": wrd3 prim1 ;"
'    aLn$(7) = "wrd3"

    Outer("interpret",aCode&(),aLn$())

'dbg_dictionary

'    Outer("run_code",aCode&())

'    Dbg_dictionary()
#IF %env.debug_on = 1
    CLOSE #fDbg : SHELL ENVIRON$("COMSPEC") + " /C Notepad.exe " & "debug.txt"
#ENDIF
#IF %env.trace_on = 1
    TRACE OFF : TRACE CLOSE : SHELL ENVIRON$("COMSPEC") + " /C Notepad.exe " & "trace.txt"
#ENDIF
END FUNCTION

[Chris Holbrook]

Originally Posted by Dean Gwilliam

BTW Chris H...jz label does suggest that a label is an address/dword so...you appear to be right on that!

Careful, I'll only get big-headed..

Is a code ptr therefore just a VARPTR of a dword/address

Yes.

There are addresses, and values stored at those addresses. Everything else is a confection of these served up by the CPU (and his evil henchman, the Compiler) working in opposition to the coder. Oh, and Ports, whatever they are.

[Dean Gwilliam]

I've just reposted my asm attempt in sub iff above (the first piece of code in post 28) and wonder if you can see a way to do it. Perhaps i should be storing the labels and not ptrs to them. I'll give it a whirl.

Edit:
Well..I tried...and failed. Cost posted above again (in first code window of post 28)

Edit:
I can 'call <dword var>' but I'm not getting the address now...to call... inside iff i.e. the label after 'if' in the program i.e. dummy. I'm more comfortable tracking this one down.

Edit sorted!