Pretty list VLIST

doc/PLFORTH.md

@@ -11,6 +11,10 @@ PLFORTH is a PLASMA module written in PLASMA itself. As a first class citizen of
 
 There are quite a few missing word that a standard FORTH would have. Mostly due to deliberately keeping PLFORTH as minimal as possible to reduce the memory footpring and load time. Most of the missing words can be synthesized using existing PLASMA modules and some glue words. The double word have mostly been made avialable through PLASMA's 32 bit integer module, `INT32` by way of the `int32.4th` script. You can always petition to get your favorite FORTH word included in the default vocabulary. Speaking of `VOCABULARY`, PLFORTH only has one.
 
+## PLFORTH built-in words
+
+![VLIST](forthwords.png)
+
 ## PLFORTH specific words
 
 ### Words for looking at internal structures:

src/toolsrc/plforth.pla

@@ -6,9 +6,10 @@ include "inc/longjmp.plh"
 //
 // Internal variables
 //
-word  vlist
-word  startheap, arg, infunc, inptr, IIP, W
+word  vlist, infunc, inptr, IIP, W
+word  vmvect, startheap, arg
 word  keyinbuf   = $1FF
+const JSR        = $20 // 6502 JSR opcode needed for VM entry
 const SRCREFS    = 2
 const INBUF_SIZE = 128
 byte  srclevel   = 0
@@ -85,6 +86,7 @@ byte               = $60           // RTS
 const inline_flag     = $01
 const inlinew_flag    = $02
 const param_flag      = $04
+const showcr_flag     = $08 // Help pretty print SHOW
 const itc_flag        = $10
 const imm_flag        = $20
 const componly_flag   = $40
@@ -92,15 +94,9 @@ const interponly_flag = $80
 //
 // Predefine instrinsics
 //
-predef _drop_(a)#0, _swap_(a,b)#2, _dup_(a)#2, _dashdup_(a)#1, _over_(a,b,c)#4, _rot_(a,b,c)#3
-predef _add_(a,b)#1, _inc_(a)#1, _inc2_(a)#1, _dec_(a)#1, _dec2_(a)#1
-predef _sub_(a,b)#1, _mul_(a,b)#1, _div_(a,b)#1
-predef _neg_(a)#1, _and_(a,b)#1, _or_(a,b)#1, _xor_(a,b)#1, _complement_(a)#1, _not_(a)#1
-predef _mod_(a,b)#1, _abs_(a)#1, _max_(a,b)#1, _min_(a,b)#1
-predef _lshift_(a,b)#1, _rshift_(a,b)#1
-predef _cset_(a,b)#0, _cget_(a)#1, _wset_(a,b)#0, _wplusset_(a,b)#0, _wget_(a)#1
+predef _swap_(a,b)#2, _dashdup_(a)#1, _over_(a,b,c)#4, _rot_(a,b,c)#3
+predef _abs_(a)#1, _max_(a,b)#1, _min_(a,b)#1, _wplusset_(a,b)#0
 predef _ffa_(a)#1, _lfa_(a)#1, _hfa_(a)#1, _cfa_(a)#1, _pfa_(a)#1, _allot_(a)#0
-predef _eq_(a,b)#1, _gt_(a,b)#1, _lt_(a,b)#1, _0lt_(a)#1, _0eq_(a)#1
 predef _branch_#0, _0branch_(a)#0, _if_#0, _else_#0, _then_#0
 predef _begin_#0, _again_#0, _until_#0, _while_#0, _repeat_#0
 predef _case_#0, _of_#0, _endof_#0, _endcase_#0
@@ -123,8 +119,8 @@ predef _abort_(a)#0, _doabortstr_(a,b)#0, _abortstr_#0
 predef _compword_(dentry)#0, _compliteral_(a)#0, _execword_(dentry)#0, _isnum_(a,b)#2
 // DROP
 char d_drop = "DROP"
-byte = inline_flag
-word = 0, 0, @_drop_, $30
+byte = inline_flag | showcr_flag
+word = 0, 0, 0, $30
 // SWAP
 char d_swap = "SWAP"
 byte = 0
@@ -132,7 +128,7 @@ word = @d_drop, 0, @_swap_
 // DUP
 char d_dup = "DUP"
 byte = inline_flag
-word = @d_swap, 0, @_dup_, $34
+word = @d_swap, 0, 0, $34
 // -DUP
 char d_dashdup = "-DUP"
 byte = 0
@@ -148,87 +144,87 @@ word = @d_over, 0, @_rot_
 // ADD
 char d_add = "+"
 byte = inline_flag
-word = @d_rot, 0, @_add_, $82
+word = @d_rot, 0, 0, $82
 // ONE PLUS
 char d_inc = "1+"
 byte = inline_flag
-word = @d_add, 0, @_inc_, $8C
+word = @d_add, 0, 0, $8C
 // TWO PLUS
 char d_inc2 = "2+"
 byte = inlinew_flag
-word = @d_inc, 0, @_inc2_, $8C8C
+word = @d_inc, 0, 0, $8C8C
 // ONE MINUS
 char d_dec = "1-"
 byte = inline_flag
-word = @d_inc2, 0, @_dec_, $8E
+word = @d_inc2, 0, 0, $8E
 // TWO MINUS
 char d_dec2 = "2-"
 byte = inlinew_flag
-word = @d_dec, 0, @_dec2_, $8E8E
+word = @d_dec, 0, 0, $8E8E
 // SUB
 char d_sub = "-"
 byte = inline_flag
-word = @d_dec2, 0, @_sub_, $84
+word = @d_dec2, 0, 0, $84
 // MUL
 char d_mul = "*"
 byte = inline_flag
-word = @d_sub, 0, @_mul_, $86
+word = @d_sub, 0, 0, $86
 // DIV
 char d_div = "/"
 byte = inline_flag
-word = @d_mul, 0, @_div_, $88
+word = @d_mul, 0, 0, $88
 // DIVMOD
 char d_divmod = "/MOD"
 byte = inline_flag
-word = @d_div, 0, @divmod, $36
+word = @d_div, 0, 0, $36
 // MOD
 char d_mod = "MOD"
 byte = inline_flag
-word = @d_divmod, 0, @_mod_, $8A
+word = @d_divmod, 0, 0, $8A
 // NEG
 char d_neg = "NEGATE"
 byte = inline_flag
-word = @d_mod, 0, @_neg_, $90
+word = @d_mod, 0, 0, $90
 // AND
 char d_and = "AND"
 byte = inline_flag
-word = @d_neg, 0, @_and_, $94
+word = @d_neg, 0, 0, $94
 // OR
 char d_or = "OR"
 byte = inline_flag
-word = @d_and, 0, @_or_, $96
+word = @d_and, 0, 0, $96
 // XOR
 char d_xor = "XOR"
 byte = inline_flag
-word = @d_or, 0, @_xor_, $98
+word = @d_or, 0, 0, $98
 // COMPLEMENT
 char d_complement = "COMPLEMENT"
 byte = inline_flag
-word = @d_xor, 0, @_complement_, $92
+word = @d_xor, 0, 0, $92
 // NOT
 char d_not = "NOT"
 byte = inline_flag
-word = @d_complement, 0, @_not_, $80
+word = @d_complement, 0, 0, $80
 // LEFT SHIFT
 char d_lshift = "LSHIFT"
 byte = inline_flag
-word = @d_not, 0, @_lshift_, $9A
+word = @d_not, 0, 0, $9A
 // RIGHT SHIFT
 char d_rshift = "RSHIFT"
 byte = inline_flag
-word = @d_lshift, 0, @_rshift_, $9C
+word = @d_lshift, 0, 0, $9C
 // EQUALS
 char d_eq = "="
 byte = inline_flag
-word = @d_rshift, 0, @_eq_, $40
+word = @d_rshift, 0, 0, $40
 // GREATER THAN
 char d_gt = ">"
 byte = inline_flag
-word = @d_eq, 0, @_gt_, $44
+word = @d_eq, 0, 0, $44
 // LESS THAN
 char d_lt = "<"
 byte = inline_flag
-word = @d_gt, 0, @_lt_, $46
+word = @d_gt, 0, 0, $46
 // UNSIGNED GREATER THAN
 char d_ugt = "U>"
 byte = 0
@@ -240,11 +236,11 @@ word = @d_ugt, 0, @isult
 // LESS THAN ZERO
 char d_0lt = "0<"
 byte = inlinew_flag
-word = @d_ult, 0, @_0lt_, $4600 // ZERO ISLT
+word = @d_ult, 0, 0, $4600 // ZERO ISLT
 // EQUALS ZERO
 char d_0eq = "0="
 byte = inlinew_flag
-word = @d_0lt, 0, @_0eq_, $4000 // ZERO ISEQ
+word = @d_0lt, 0, 0, $4000 // ZERO ISEQ
 // ABS
 char d_abs = "ABS"
 byte = 0
@@ -259,31 +255,31 @@ byte = 0
 word = @d_min, 0, @_max_
 // CHAR PUT
 char d_cset = "C!"
-byte = inline_flag
-word = @d_max, 0, @_cset_, $70
+byte = inline_flag | showcr_flag
+word = @d_max, 0, 0, $70
 // WORD PUT
 char d_wset = "!"
-byte = inline_flag
-word = @d_cset, 0, @_wset_, $72
+byte = inline_flag | showcr_flag
+word = @d_cset, 0, 0, $72
 // WORD PLUS PUT
 char d_wplusset = "+!"
-byte = 0
+byte = showcr_flag
 word = @d_wset, 0, @_wplusset_
 // CHAR GET
 char d_cget = "C@"
 byte = inline_flag
-word = @d_wplusset, 0, @_cget_, $60
+word = @d_wplusset, 0, 0, $60
 // WORD SET
 char d_wget = "@"
 byte = inline_flag
-word = @d_cget, 0, @_wget_, $62
+word = @d_cget, 0, 0, $62
 // EXECUTE
 char d_execute = "EXECUTE"
-byte = 0
+byte = showcr_flag
 word = @d_wget, 0, @_execword_
 // TO RSTACK
 char d_torstk = ">R"
-byte = 0
+byte = showcr_flag
 word = @d_execute, 0, @_tors_
 // FROM RSTACK
 char d_fromrstk = "R>"
@@ -331,11 +327,11 @@ byte = 0
 word = @d_pad, 0, @_allot_
 // BRANCH ( not in vocabulary )
 char d_branch = "(BRANCH)"
-byte = param_flag | inline_flag
+byte = param_flag | inline_flag | showcr_flag
 word = 0, 0, @_branch_, $C4
 // BRANCH IF 0 ( not in vocabulary )
 char d_0branch = "(0BRANCH)"
-byte = param_flag | inline_flag
+byte = param_flag | inline_flag | showcr_flag
 word = 0, 0, @_0branch_, $C2
 // IF
 char d_if = "IF"
@@ -367,7 +363,7 @@ byte = imm_flag | componly_flag
 word = @d_endof, 0, @_endcase_
 // COMPILED DO ( not in vocabulary )
 char d_dodo = "(DO)"
-byte = 0
+byte = showcr_flag
 word = 0, 0, @_dodo_
 // DO
 char d_do = "DO"
@@ -379,7 +375,7 @@ byte = componly_flag
 word = @d_do, 0, @_leave_
 // COMPILED LOOP ( not in vocabulary )
 char d_doloop = "(DOLOOP)"
-byte = param_flag
+byte = param_flag | showcr_flag
 word = 0, 0, @_doloop_
 // LOOP
 char d_loop = "LOOP"
@@ -387,7 +383,7 @@ byte = imm_flag | componly_flag
 word = @d_leave, 0, @_loop_
 // COMPILED LOOP+ ( not in vocabulary )
 char d_doplusloop = "(+DOLOOP)"
-byte = param_flag
+byte = param_flag | showcr_flag
 word = 0, 0, @_doplusloop_
 // LOOP
 char d_plusloop = "+LOOP"
@@ -423,15 +419,15 @@ byte = imm_flag | componly_flag
 word = @d_while, 0, @_repeat_
 // FORGET
 char d_forget = "FORGET"
-byte = 0
+byte = interponly_flag
 word = @d_repeat, 0, @_forget_
 // CREATE
 char d_create = "CREATE"
-byte = 0
+byte = showcr_flag
 word = @d_forget, 0, @_create_
 // RECREATE/DOES COMPILE TIME ( not in vocabulary )
 char d_createdoes = "(CREATEDOES)"
-byte = 0
+byte = showcr_flag
 word = 0, 0, @_itcdoes_
 // DOES
 char d_does = "DOES>"
@@ -439,11 +435,11 @@ byte = imm_flag | componly_flag
 word = @d_create, 0, @_does_
 // COMMA
 char d_comma = ","
-byte = 0
+byte = showcr_flag
 word = @d_does, 0, @_dictaddw_
 // COMMA
 char d_commab = "C,"
-byte = 0
+byte = showcr_flag
 word = @d_comma, 0, @_dictaddb_
 // COLON
 char d_colon = ":"
@@ -475,7 +471,7 @@ byte = imm_flag
 word = @d_interponly, 0, @_immediate_
 // EXIT
 char d_exit = "EXIT"
-byte = imm_flag | componly_flag
+byte = imm_flag | componly_flag | showcr_flag
 word = @d_immediate, 0, @_exit_
 // SEMI
 char d_semi = ";"
@@ -527,19 +523,19 @@ byte = 0
 word = @d__isnum_, 0, @_trailing_
 // PRINT @TOS
 char d_prat = "?"
-byte = 0
+byte = showcr_flag
 word = @d_trailing, 0, @_prat_
 // PRINT TOS
 char d_prtos = "."
-byte = 0
+byte = showcr_flag
 word = @d_prat, 0, @_prval_
 // PRINT TOS HEX
 char d_prtoshex = "$."
-byte = 0
+byte = showcr_flag
 word = @d_prtos, 0, @_prhex_
 // PRINT TOS HEX BYTE
 char d_prtosbyte = "C$."
-byte = 0
+byte = showcr_flag
 word = @d_prtoshex, 0, @_prbyte_
 // EMIT
 char d_emit = "EMIT"
@@ -579,7 +575,7 @@ byte = param_flag | inline_flag
 word = 0, 0, @_slit_, $2E
 // PRINT STRING FROM STACK
 char d_doprstr = "(.\")"
-byte = 0
+byte = showcr_flag
 word = @d_str, 0, @puts
 // PRINT STRING
 char d_prstr = ".\""
@@ -591,7 +587,7 @@ byte = imm_flag
 word = @d_prstr, 0, @_prpstr_
 // READ SOURCE FILE FROM STACK
 char d_src = "SRC"
-byte = 0
+byte = showcr_flag
 word = @d_prpstr, 0, @_src_
 // READ SOURCE FILE FROM INPUT
 char d_srcstr = "SRC\""
@@ -599,7 +595,7 @@ byte = imm_flag
 word = @d_src, 0, @_srcstr_
 // END SOURCE FILE
 char d_endsrc = "ENDSRC"
-byte = 0
+byte = showcr_flag
 word = @d_srcstr, 0, @_endsrc_
 // CONTINUE AFTER BRK
 char d_cont = "CONT"
@@ -607,15 +603,15 @@ byte = interponly_flag
 word = @d_endsrc, 0, @_cont_
 // QUIT
 char d_quit = "QUIT"
-byte = 0
+byte = showcr_flag
 word = @d_cont, 0, @_quit_
 // ABORT IF <> 0
 char d_abort = "ABORT"
-byte = 0
+byte = showcr_flag
 word = @d_quit, 0, @_abort_
 // DOABORTSTR
 char d_doabortstr = "(ABORT\")"
-byte = 0
+byte = showcr_flag
 word = @d_abort, 0, @_doabortstr_
 // ABORTSTR
 char d_abortstr = "ABORT\""
@@ -623,11 +619,11 @@ byte = imm_flag
 word = @d_doabortstr, 0, @_abortstr_
 // COLD exitforth
 char d_exitforth = "COLD"
-byte = 0
+byte = showcr_flag
 word = @d_abortstr, 0, @_restart_
 // COMMENT
 char d_comment = "("
-byte = imm_flag
+byte = imm_flag | showcr_flag
 word = @d_exitforth, 0, @_comment_
 //
 // PLFORTH custom words
@@ -1064,15 +1060,9 @@ end
 //
 // Intrinsics
 //
-def _drop_(a)#0
-  return
-end
 def _swap_(a,b)#2
   return b,a
 end
-def _dup_(a)#2
-  return a,a
-end
 def _dashdup_(a)#1
   if a; (@push)(a)#0; fin
   return a
@@ -1083,78 +1073,6 @@ end
 def _rot_(a,b,c)#3
   return b,c,a
 end
-def _add_(a,b)#1
-  return a+b
-end
-def _inc_(a)
-  return a + 1
-end
-def _inc2_(a)
-  return a + 2
-end
-def _dec_(a)
-  return a - 1
-end
-def _dec2_(a)
-  return a - 2
-end
-def _sub_(a,b)#1
-  return a-b
-end
-def _mul_(a,b)#1
-  return a*b
-end
-def _div_(a,b)#1
-  return a/b
-end
-def _mod_(a,b)#1
-    return a%b
-end
-def _neg_(a)#1
-  return -a
-end
-def _lshift_(a,b)#1
-    return a<<b
-end
-def _rshift_(a,b)#1
-    return a>>b
-end
-def _and_(a,b)#1
-  return a & b
-end
-def _or_(a,b)#1
-  return a | b
-end
-def _xor_(a,b)#1
-  return a ^ b
-end
-def _complement_(a)#1
-  return ~a
-end
-def _not_(a)#1
-  return not a
-end
-def _eq_(a,b)#1
-  return a == b
-end
-def _gt_(a,b)#1
-  return a > b
-end
-def _lt_(a,b)#1
-  return a < b
-end
-def _0lt_(a)#1
-  return a < 0
-end
-def _0eq_(a)#1
-  return a == 0
-end
-def _cset_(a,b)#0
-  ^b = a
-end
-def _wset_(a,b)#0
-  *b = a
-end
 def _wplusset_(a,b)#0
   *b = *b + a
 end
@@ -1167,12 +1085,6 @@ end
 def _max_(a,b)
   return a > b ?? a :: b
 end
-def _cget_(a)#1
-  return ^a
-end
-def _wget_(a)#1
-  return *a
-end
 def _ffa_(dentry)#1
   return dentry + ^dentry + 1
 end
@@ -1237,7 +1149,7 @@ def _pad_#1
   return heapmark + 128
 end
 def _trailing_(a,b)#2
-  while b and ^(a + b) == ' '
+  while b and ^(a + b - 1) == ' '
     b--
   loop
   return a, b
@@ -1267,13 +1179,13 @@ def newdict#0
 end
 def _plasma_(a)#0
   newdict
+  ^(_ffa_(vlist)) = showcr_flag
   *(_cfa_(vlist)) = a  // PLASMA code address
   addhash(vlist)
 end
 def _var_(a)#0
   newdict
-  _dictaddb_($20)          // Hack - get VM entry vector from divmod
-  _dictaddw_(*(@divmod + 1))
+  _dictaddb_(JSR); _dictaddw_(vmvect)
   _dictaddb_($2C)          // CONSTANT WORD
   _dictaddw_(heapmark + 3) // Poiner to variable in PFA
   _dictaddb_($5C)          // RET
@@ -1282,8 +1194,7 @@ def _var_(a)#0
 end
 def _const_(a)#0
   newdict
-  _dictaddb_($20)          // Hack - get VM entry vector from divmod
-  _dictaddw_(*(@divmod + 1))
+  _dictaddb_(JSR); _dictaddw_(vmvect)
   _dictaddb_($2C)          // CONSTANT WORD
   _dictaddw_(a)
   _dictaddb_($5C)          // RET
@@ -1291,8 +1202,7 @@ def _const_(a)#0
 end
 def _create_#0
   newdict
-  _dictaddb_($20)          // Hack - get VM entry vector from divmod
-  _dictaddw_(*(@divmod + 1))
+  _dictaddb_(JSR); _dictaddw_(vmvect)
   _dictaddb_($2C)          // CONSTANT WORD
   _dictaddw_(heapmark + 5) // Pointer to rest of PFA
   _dictaddb_($5C)          // RET
@@ -1325,8 +1235,9 @@ end
 def _does_#0
   if state & comp_itc_flag
     _dictaddw_(@d_lit)
-    _dictaddw_(heapmark + 6) // Pointer to DOES code
+    _dictaddw_(heapmark + 8) // Pointer to DOES code
     _dictaddw_(@d_createdoes)
+    _dictaddw_(0)            //  Double zero for SHOW
     _dictaddw_(0)
     // End of <BUILDS, beginning of DOES>
   else // comp_pbc_flag
@@ -1345,11 +1256,11 @@ def _colon_#0
   newdict
   state = state | comp_mode
   if state & comp_itc_flag
-    ^(_ffa_(vlist)) = itc_flag
+    ^(_ffa_(vlist)) = itc_flag | showcr_flag
     *(_cfa_(vlist)) = @_docolon_
   else // comp_pbc_flag
-    _dictaddb_($20)            // Hack - get VM entry vector from divmod
-    _dictaddw_(*(@divmod + 1))
+    ^(_ffa_(vlist)) = showcr_flag
+    _dictaddb_(JSR); _dictaddw_(vmvect)
   fin
   if state & trace_flag
     puts(vlist); putc(' ')
@@ -1367,6 +1278,9 @@ def _exit_#0
 end
 def _semi_#0
   _exit_
+  if state & comp_itc_flag // Add double zero at end of definition for SHOW
+    _dictaddw_(0)
+  fin
   addhash(vlist)
   state = state & ~comp_flag
 end
@@ -1811,7 +1725,7 @@ def _show_#0
     fin
     w = *pfa
     while w
-      puts("  ")
+      puts(" ")
       if ^_ffa_(w) & param_flag
         pfa = pfa + 2
       fin
@@ -1825,9 +1739,17 @@ def _show_#0
       else
         puts(w)
       fin
-      putln
+      if ^_ffa_(w) & showcr_flag; putln; fin
       pfa = pfa + 2
       w = *pfa
+      if !w
+        puts(" EXIT\n")
+        pfa = pfa + 2
+        w = *pfa
+      fin
+      if conio:keypressed()
+        getc; getc
+      fin
     loop
   fin
 end
@@ -1911,10 +1833,19 @@ def _comment_#0
 end
 def _vlist_#0
   word d
+  byte tab
 
-  d = vlist
+  tab = 0
+  d   = vlist
   while d
-    puts(d); puts("  ")
+    tab = tab + 1 + ^d
+    if tab > 39
+      putln;
+      tab = ^d
+    else
+      puts(" ")
+    fin 
+    puts(d)
     if conio:keypressed()
       getc; getc
     fin
@@ -1967,18 +1898,47 @@ end
 def _bye_#0
   throw(@exitforth, TRUE)
 end
-
-puts("FORTH (Alpha) for PLASMA 2.1\n")
+//
+// Start FORTH
+//
+puts("FORTH for PLASMA 2.1\n")
 if cmdsys:sysver < $0201
   puts("PLASMA >= 2.01 required\n")
   return
 fin
+//
+// Compile ITC version of inline words ( speeds it up a smidge )
+//
+vmvect = *(@divmod + 1)  // Hack - get VM entry vector from divmod
+vlist  = @d_vlist
+while vlist
+  if *_cfa_(vlist) == 0
+    *_cfa_(vlist) = heapmark
+    _dictaddb_(JSR); _dictaddw_(vmvect)
+    if ^_ffa_(vlist) & inline_flag
+      _dictaddb_(^_pfa_(vlist))
+    elsif ^_ffa_(vlist) & inlinew_flag
+      _dictaddw_(*_pfa_(vlist))
+    else
+      puts(vlist); puts(": Invalid dictionary\n")
+      return -1
+    fin
+    _dictaddb_($5C) // RET
+  fin
+  vlist = *_lfa_(vlist)
+loop
 _estkl = ^(@syscall + 1) // Hack to fill in parameter stack locations
 _estkh = ^(@syscall + 3)
 fileio:iobufalloc(4) // Allocate a bunch of file buffers
 startheap = heapmark
 coldstart
+//
+// Check for command line argument
+//
 inptr = argNext(argFirst)
+//
+// Main start and restart entry
+//
 if not except(@exitforth)
   if ^inptr; inptr++; _srcstr_; fin
   _interpret_