2 files changed, 53 insertions(+), 4 deletions(-)

M colon.fs
M w65c816.fs

@@ 12,17 12,23 @@ variable label#
 
 label0
 
+\ Set to ON to enable header generation; leave OFF otherwise.
+VARIABLE headers
+  headers OFF
+
 \ Creates a header for a Forth word whose symbol name is a valid
 \ assembler listing symbol name.
 : header ( caddr u -- )
-  2dup xref emit:entry ;
+  2dup xref headers @ if 2dup 2dup emit:header then emit:entry ;
 
 \ Creates a header for a Forth word whose symbol name is not a
 \ valid assembler listing symbol name.  Two names are required,
 \ one which is a valid assembler symbol, and one which is the
 \ equivalent Forth symbol.  For example, `oneplus 1+`.
 : 2header ( n[caddr u] s[caddr u] -- )
-  2over 2over xname 2drop emit:entry ;
+  2over 2over xname
+  headers @ if 2over 2over emit:header then
+  2drop emit:entry ;
 
 : call ( caddr u -- )
   xquery emit:call ;

@@ 3,11 3,41 @@
 \ file, You can obtain one at https://mozilla.org/MPL/2.0/.
 
 
+\ Header generation is hashed into one of eight buckets.
+\ Unfortunately, we can only work with symbols, not addresses.
+\ Thus, instead of a convenient record of eight cells to
+\ keep track of the state of the vocabulary linkage, we need
+\ to record eight full-length name buffers instead.
+
+64 CONSTANT b/name
+: fits ( u -- u )
+  b/name 1- OVER U>= 0= ABORT" Name Too Long to Hash" ;
+8 CONSTANT #buckets
+b/name #buckets * CONSTANT b/vocab
+CREATE vocab
+  b/vocab ALLOT
+: bucket ( n -- addr )
+  b/name * vocab + ;
+: remember ( caddr u addr -- )
+  >R fits R> ( caddr u addr )
+  2DUP C!
+  1+ SWAP MOVE ;
+: recall ( addr -- caddr u )
+  count ;
+: 0vocab
+  #buckets 0 DO S" 00" I bucket remember LOOP ;
+0vocab
+: hash ( caddr -- addr )
+  C@ 7 AND bucket ;
+: name>bucket ( caddr u -- addr )
+  DROP hash ;
+
 : .n                        s>d <# #s #> type ;
 : .L ( L -- )               s>d <# #s [CHAR] L hold #> type ;
 
 : indent ( -- )             ."   " ;
 : .entry ( -- )             ." entry_" ;
+: .hdr ( -- )               ." header_" ;
 : opc                       indent type space ;
 
 : abs$ ( cap up cao uo - )  opc type cr ;


@@ 39,13 69,13 @@
 
 : emit:0branch ( L -- )     >z beqL ;
 : emit:call ( caddr u - )   jsrE ;
-: emit:close ( -- )         [char] . emit [char] ) emit cr ;
+: emit:close ( -- )         ." .)" cr ;
 : emit:entry ( caddr u - )  .entry type ." :" cr ;
 : emit:exit ( - )           rts ;
 : emit:jumpL ( L - )        jmpL ;
 : emit:label ( L - )        .L ." :" cr ;
 : emit:lit ( n -- )         s" i_literal" jsr  .word ;
-: emit:open ( -- )          [char] . emit [char] ( emit cr ;
+: emit:open ( -- )          ." .(" cr ;
 : emit:str ( caddr u -- )   s" i_string" jsr  dup .word  .byte"" ;
 : emit:brkpt ( -- )         $FF00 .word ;
 : emit:create ( -- )        S" i_create" jsr ;


@@ 53,3 83,16 @@
 : emit:char ( c -- )        .byte ;
 : emit:litaddr ( caddr u -- ) reserve lda#name >t ;
 
+
+VARIABLE hsh
+
+: emit:header ( caddr u caddr u -- )
+              ( `-asm-' `forth'    )
+  OVER hash hsh !
+  >R >R 2DUP .hdr type ." :" cr
+  R> R> DUP DUP >R .byte .byte"" R> .byte 
+  0 .word
+  S" .word" opc .entry hsh @ recall type cr
+  hsh @ remember
+;
+