Announcement

Collapse
No announcement yet.

an array of label addresses?

Collapse
X
  • Filter
  • Time
  • Show
Clear All
new posts

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

    Comment


    • #17
      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.


      Code:
      #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
      Last edited by Dean Gwilliam; 7 May 2012, 09:55 AM.

      Comment


      • #18
        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...
        Code:
        'why is UBOUND 4 and not 3???
        .... your problem is here....

        Code:
        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
        Michael Mattias
        Tal Systems Inc.
        Racine WI USA
        mailto:mmattias@talsystems.com
        www.talsystems.com

        Comment


        • #19
          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.
          Last edited by Dean Gwilliam; 9 May 2012, 03:11 PM.

          Comment


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

            Comment


            • #21
              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.
              Last edited by Dean Gwilliam; 9 May 2012, 04:27 PM.

              Comment


              • #22
                Originally posted by Dean Gwilliam View Post
                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.

                Comment


                • #23
                  [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
                  Michael Mattias
                  Tal Systems Inc.
                  Racine WI USA
                  mailto:mmattias@talsystems.com
                  www.talsystems.com

                  Comment


                  • #24
                    >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
                    Code:
                    #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.

                    Comment


                    • #25
                      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.
                      Code:
                       
                      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
                      Last edited by Dean Gwilliam; 10 May 2012, 01:16 PM.

                      Comment


                      • #26
                        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.

                        Comment


                        • #27
                          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.
                          Code:
                              : w1 + . ;
                              : w2 10 ;
                              3 w2 w1
                          Last edited by Dean Gwilliam; 10 May 2012, 01:14 PM.

                          Comment


                          • #28
                            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?

                            Code:
                            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

                            Code:
                            '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
                            Last edited by Dean Gwilliam; 14 May 2012, 03:05 PM.

                            Comment


                            • #29
                              Originally posted by Dean Gwilliam View Post
                              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.
                              Last edited by Chris Holbrook; 14 May 2012, 12:53 PM.

                              Comment


                              • #30
                                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!
                                Last edited by Dean Gwilliam; 14 May 2012, 03:06 PM.

                                Comment

                                Working...
                                X