~vertigo/shoehorn

128166d5daed8f266c62539f219f0bf404cf7143 — Samuel A. Falvo II 7 months ago 74a06ce
Introduce basic header generation.

Doesn't yet support multiple vocabularies, but it can potentially be
easy to do by swapping the contents of vocab out.
2 files changed, 53 insertions(+), 4 deletions(-)

M colon.fs
M w65c816.fs
M colon.fs => colon.fs +8 -2
@@ 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 ;

M w65c816.fs => w65c816.fs +45 -2
@@ 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
;