SamForth2z80dasm

Description of the page content

Tool program to disassemble SamForth.

Tags:

This Gforth program helps to disassemble SamForth. The details and the usage are in the code. It needs the Forth Foundation Library.

Source code

#! /usr/bin/env gforth

\ samforth2z80dasm.fs
\
\ SamForth2z80dasm
\ Version A-04-201301241713
\
\ This file is part of the
\ "SamForth disassembled" project
\ (<http://programandala.net/en.program.samforth>).
\
\ This program reads the SamForth code and creates two files
\ needed by z80dasm in order to disassemble it: the data blocks
\ file and the symbols file.

\ Copyright (C) 2012,2013 Marcos Cruz (programandala.net)

\ SamForth2z80dasm is free software; you can redistribute
\ it and/or modify it under the terms of the GNU General
\ Public License as published by the Free Software
\ Foundation; either version 2 of the License, or (at your
\ option) any later version.

\ SamForth2z80dasm is distributed in the hope that it will be useful,
\ but WITHOUT ANY WARRANTY; without even the implied
\ warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
\ PURPOSE.  See the GNU General Public License for more
\ details.

\ You should have received a copy of the GNU General Public
\ License along with this program; if not, see
\ <http://gnu.org/licenses>.

\ SamForth2z80dasm is written in Forth
\ with Gforth (<http://bernd-paysan.de/gforth.html>).

\ }}} **********************************************************
\ Development history {{{

\ See at the end of this file.

\ }}} **********************************************************
\ Todo {{{

\ -origin argument
\ -v verbose argument
\
\ mark more known routines

\ }}} **********************************************************
\ Stack notation {{{

\ In this program the following stack notation is used:

0 [if]

+n    = 32-bit positive number
-n    = 32-bit negative number
a     = 32-bit memory address
ca    = 32-bit character aligned memory address
ca u  = character aligned memory zone (e.g. a string)
b     = 8-bit byte
c     = 8-bit character
f     = flag (true if not 0; false if 0)
false = 0
ff    = 32-bit well formed flag (true if -1; false if 0)
i*x   = undefined group of elements (maybe empty)
j*x   = undefined group of elements (maybe empty)
n     = 32-bit signed number
nt    = name token
true  = 32-bit -1
u     = 32-bit unsigned number
x     = undefined element
xc    = x-character (UTF-8)
xca   = 32-bit x-character aligned memory address (for UTF-8)
xca u = x-character aligned memory zone (a UTF-8 string)
xt    = execution token

[then]

\ }}} **********************************************************
\ Requirements {{{

\ From Forth Foundation Library
\ (<http://code.google.com/p/ffl/>)
require ffl/str.fs  \ dynamic strings

\ The Forth Foundation Library's config.fs file nullifies the
\ words 'argc' and 'arg', and defines its own versions '#args'
\ and 'arg@'.

[defined] ffl.version [if]

  \ Re-create the original Gforth words 'argc' and 'arg', based
  \ on the words defined by the Forth Foundation Library's
  \ config.fs. 

  warnings @ warnings off

  variable argc  #args 1+ argc !
  : arg  ( n -- ca u )
    1- arg@
    ;

  warnings !

[then]

\ }}} **********************************************************
\ Dynamic strings {{{

str-create samforth_word_label$  \ base for the Z80 labels
str-create tmp$

\ }}} **********************************************************
\ Files {{{

variable 'samforth  \ address of the SamForth code
variable /samforth  \ length of the SamForth code  / xxx not used
: get_the_binary  ( ca u -- )
  \ Read the SamForth's binary.
  \ ca u = filename
  slurp-file /samforth ! 'samforth !
  ;
variable blocks_fid  \ file identifier
: create_blocks_file  ( ca u -- )
  \ Create the z80dasm's blocks file.
  \ ca u = filename
  w/o create-file abort" Error creating the blocks file"
  blocks_fid !
  ;
variable symbols_fid  \ file identifier
: create_symbols_file  ( ca u -- )
  \ Create the z80dasm's symbols file.
  \ ca u = filename
  w/o create-file abort" Error creating the symbols file"
  symbols_fid !
  ;
: close_files  ( -- )
  \ Close the new files.
  symbols_fid @ close-file abort" Error closing the symbols file"
  blocks_fid @ close-file abort" Error closing the blocks file"
  ;
: open_files  ( ca u -- )
  \ Open or create all needed files using the binary's filename.
  \ ca u = filename of the binary
  2dup get_the_binary
  2dup s" _blocks.txt" s+ create_blocks_file
  s" _symbols.z80s" s+ create_symbols_file
  ;

\ }}} **********************************************************
\ SamForth memory {{{

false value samforth-b?  \ variant: SamForth-B instead of SamForth-A?

: samforth-a?  ( a -- ff )
  \ SamForth-A instead of SamForth-B?
  samforth-b? 0=
  ;
: z80@  ( a1 -- a2 )
  \ Fetch a 16-bit number from a Z80 address.
  dup c@ swap 1+ c@ 256 * +
  ;
: sam>heap  ( a1 -- a2 )
  \ Convert a SamForth address to a real heap address.
  samforth-b? abs 16384 * -
  'samforth @ +
  ;
: samforth@  ( a1 -- u )
  \ Fetch a 16-bit number from a SamForth address.
  sam>heap z80@
  ;
: samforthc@  ( a1 -- b )
  \ Fetch an 8-bit number from a SamForth address.
  sam>heap c@
  ;
: choose  ( a1 a2 -- a1 | a2 )
  \ Choose one of two addresses, depending on the current
  \ version of SamForth.
  samforth-b? if  nip  else  drop  then
  ;
: var  ( a -- a | a' )
  \ Convert a variable address from SamForth to SamForth-B, if
  \ needed.
  16292 samforth-b? abs * +
  ;
: samforth_var_RSTACK  ( -- a )
  \ Return the content of the SamForth's variable "RSTACK":
  \ the start address of the return stack:
  \ the stack bottom, higher in memory.
  414 var samforth@
  ;
: samforth_var_STACK  ( -- a )
  \ Return the content of the SamForth's variable "STACK":
  \ the start address of the data stack:
  \ the stack bottom, higher in memory.
  414 var samforth@
  ;
: samforth_var_STKEND  ( -- a )
  \ Return the content of the SamForth's variable "STKEND":
  \ the end address of the data stack:
  \ the stack max top, lower in memory.
  416 var samforth@
  ;
: samforth_var_CLATE  ( -- a )
  \ Return the content of the SamForth's variable "CLATE":
  \ the address of the last SamForth word in the dictionary.
  421 var samforth@
  ;
: samforth_var_TIB  ( -- a )
  \ Return the content of the SamForth's variable "TIB":
  \ the start address of the Terminal Input Buffer.
  433 var samforth@
  ;
: samforth_var_PAD  ( -- a )
  \ Return the content of the SamForth's variable "PAD":
  \ the start address of the temporary data holding area.
  435 var samforth@
  ;
: samforth_var_ETIB  ( -- a )
  \ Return the content of the SamForth's variable "ETIB":
  \ the end address of the Terminal Input Buffer.
  472 var samforth@
  ;

\ }}} **********************************************************
\ SamForth words structure {{{

variable 'word_name  \ address of the current word name in the SamForth code

: 'name>'link_field  ( a1 -- a2 )
  \ Convert the address of a SamForth word name
  \ to the address of its link field address.
  3 -
  ;
: 'name>'name_field  ( a1 -- a2 )
  \ Convert the address of a SamForth word name
  \ to the address of its name field address.
  1-
  ;
: 'name>'length  ( a1 -- a2 )
  \ Convert the address of a SamForth word name
  \ to the address of its length.
  1-
  ;
: -flags  ( u1 -- u2 )
  \ u1 = content of the name length byte of a word
  \ u2 = actual length of the word
  %00111111 and
  ;
: 'name>length  ( a1 -- u )
  \ Convert the address of a SamForth word name
  \ to its length.
  'name>'length samforthc@ -flags
  ;
: word_name_length  ( -- u )
  \ Return the length of the current SamForth word.
  'word_name @ 'name>length
  ;
: counted  ( a -- ca u )
  \ Convert the address of a SamForth word name to a counted
  \ string.
  dup sam>heap swap 'name>length
  ;
: 'link_field  ( -- a )
  \ Return the link field address of the current SamForth word. 
  'word_name @ 'name>'link_field
  ;
: 'name_field  ( -- a )
  \ Return the name field address of the current SamForth word. 
  'word_name @ 'name>'name_field
  ;
: 'code_field  ( -- a )
  \ Return the code field address of the current SamForth word. 
  'word_name @ word_name_length +
  ;
: header_start  ( -- a )
  \ Return the start address of the current SamForth word's header.
  'link_field
  ;
: header_end  ( -- a )
  \ Return the end address of the current SamForth word's header.
  'code_field
  ;

\ }}} **********************************************************
\ Strings manipulation {{{

: c>s  ( c u -- ca u )
  \ Make a temporary string from a character and a length.
  pad swap 2dup 2>r  rot fill  2r>
  ;
: /spaces  ( n1 n2 -- ca u )
  \ Return a string of n2 spaces minus n1; 
  \ used to tabulate the data on the files.
  swap - dup 0<= if
    drop 1
  then  bl swap c>s
  ;
: indentation+  ( ca u -- ca' u' )
  \ Add indentation spaces to a data field.
  dup 32 /spaces s+
  ;
: bl+  ( ca u -- ca' u' )
  \ Add a space to a string.
  s"  " s+
  ;
: n>hex  ( n -- ca u )
  \ Convert a number to a 4-digit hexadecimal string.
  base @ >r hex  s>d <# # # # # #>  r> base !
  ;
: n>0x  ( n -- ca u )
  \ Convert a number to a 4-digit hexadecimal string with the "0x" prefix.
  s" 0x" rot n>hex s+
  ;
: n>h  ( n -- ca u )
  \ Convert a number to a 4-digit hexadecimal string with the "h" sufix.
  n>hex s" h" s+
  ;

\ }}} **********************************************************
\ File data fields {{{

: blocks_file_abort  ( ff -- )
  \ Abort if an error ocurred while writing to the blocks file.
  abort" Error writing the blocks file"
  ;
: >blocks_file  ( ca u -- )
  \ Write a string into the blocks file.
  blocks_fid @ write-file blocks_file_abort
  ;
: >blocks_file_cr  ( ca u -- )
  \ Write a line into the blocks file.
  blocks_fid @ write-line blocks_file_abort
  ;
: .block_id  ( ca u -- )
  \ Print a block identifier field into the blocks file.
  \ ca u = id 
  s" :" s+ indentation+ >blocks_file
  ;
: .block_bound  ( a ca1 u1 -- )
  \ Print a block bound field into the blocks file.
  \ a = address of the bound
  \ ca1 u1 = name of the bound ("start" or "end")
  bl+ rot n>0x s+ bl+ >blocks_file
  ;
: .block_start  ( a -- )
  \ Print a block start field into the blocks file.
  \ a = block start address
  s" start" .block_bound
  ;
: .block_end  ( a -- )
  \ Print a block end field into the blocks file.
  \ a = block end address
  \ Note: for the z80dasm disassembler, the it's the block end
  \ address is the 16-bit address of the last byte in the block
  \ plus one.
  s" end" .block_bound
  ;
: .block_type  ( ca u -- )
  \ Print a block type field into the blocks file.
  \ ca u = type
  s" type " 2swap s+  >blocks_file_cr
  ;
: word_header_block  ( -- )
  \ Create a new block definition in the blocks file.
  \ xxx todo -- create own block for the name
  samforth_word_label$ str-get s" _header" s+
  \ 2dup type  \ xxx debug check
  .block_id
  header_start .block_start
  header_end .block_end
  s" bytedata" .block_type
  \ ." [end of word_header_block]"  \ xxx todo
  ;

: symbols_file_abort  ( ff -- )
  \ Abort if an error ocurred while writing to the symbols file.
  abort" Error writing the symbols file"
  ;
: >symbols_file  ( ca u -- )
  \ Write a string into the symbols file.
  symbols_fid @ write-file symbols_file_abort
  ;
: >symbols_file_cr  ( ca u -- )
  \ Write a line into the symbols file.
  symbols_fid @ write-line symbols_file_abort
  ;
: .symbol_id  ( ca u -- )
  \ Print a symbol identifier field into the symbols file.
  \ ca u = id
  s" :" s+ indentation+ >symbols_file
  ;
: .symbol_value  ( x -- )
  \ Print a symbol value field into the symbols file.
  \ x = value
  s" equ " rot n>0x s+ >symbols_file_cr
  ;
: .symbol  ( x ca u -- )
  \ Print a symbol into the symbols file.
  \ x = value
  \ ca u = id
  .symbol_id .symbol_value
  ;
: code_field  ( -- )
  \ Create a symbol for the code field of the current SamForth
  \ word.
  'code_field
  samforth_word_label$ str-get s" _code_field" s+ .symbol
  ;
: link_field  ( -- )
  \ Create a block for the link field of the current SamForth word.
  samforth_word_label$ str-get s" _link_field" s+ .block_id
  'link_field dup .block_start
  2 + .block_end
  s" worddata" .block_type
  ;
: name_field  ( -- )
  \ Create the symbols and blocks for the name field
  \ of the current SamForth word.
  samforth_word_label$ str-get s" _name_field" s+ .block_id
  'name_field dup .block_start
  word_name_length + 1+ .block_end
  s" bytedata" .block_type
  'word_name @
  samforth_word_label$ str-get s" _name" s+ .symbol
  ;

\ }}} **********************************************************
\ Usage {{{

: usage  ( -- )
  \ Show the usage instructions.
  cr
  ." SamForth2z80dasm" cr
  ." Copyright (C) 2012 Marcos Cruz (programandala.net)" cr cr
  ." Usage:" cr
  ."   One or two filenames are accepted as parameters." cr
  ."   The first one must be the binary of SamForth;" cr
  ."   the second one must be the binary of SamForth-B." cr cr
  ." Examples:" cr
  ."    samforth2z80dasm.fs samforth.bin" cr
  ."    samforth2z80dasm.fs samforth.bin samforth-b.bin" cr cr
  ." More information:" cr
  ."   <http://programandala.net/en.program.samforth2z80dasm>" cr
  ;

\ }}} **********************************************************
\ SamForth words {{{

\ The following words return the base label name of every
\ SamForth word.
\ They will be executed with 'evaluate', as a way
\ to map the original Forth word names to their Z80 labels.
\ A string table approach would be more elegant, though.
: samforth_word_LIT  ( -- ca u )  s" lit" ;
: samforth_word_EXECUTE  ( -- ca u )  s" execute" ;
: samforth_word_BRANCH  ( -- ca u )  s" branch" ;
: samforth_word_0BRANCH  ( -- ca u )  s" zero_branch" ;
: samforth_word_SWAP  ( -- ca u )  s" swap" ;
: samforth_word_DUP  ( -- ca u )  s" dup" ;
: samforth_word_DROP  ( -- ca u )  s" drop" ;
: samforth_word_INTERPRET  ( -- ca u )  s" interpret" ;
: samforth_word_(FIND)  ( -- ca u )  s" paren_find" ;
: samforth_word_U*  ( -- ca u )  s" u_mult" ;
: samforth_word_+  ( -- ca u )  s" plus" ;
: samforth_word_D+  ( -- ca u )  s" d_plus" ;
: samforth_word_-  ( -- ca u )  s" minus" ;
: samforth_word_MINUS  ( -- ca u )  s" do_minus" ;
: samforth_word_DMINUS  ( -- ca u )  s" d_do_minus" ;
: samforth_word_NUMBER  ( -- ca u )  s" number" ;
: samforth_word_EMIT  ( -- ca u )  s" emit" ;
: samforth_word_U.  ( -- ca u )  s" u_dot" ;
: samforth_word_/MOD  ( -- ca u )  s" slash_mod" ;
: samforth_word_CLS  ( -- ca u )  s" cls" ;
: samforth_word_CREATE  ( -- ca u )  s" create" ;
: samforth_word_:  ( -- ca u )  s" colon" ;
: samforth_word_;  ( -- ca u )  s" semicolon" ;
: samforth_word_CR  ( -- ca u )  s" cr" ;
: samforth_word_MODE  ( -- ca u )  s" mode" ;
: samforth_word_VLIST  ( -- ca u )  s" vlist" ;
: samforth_word_BASE  ( -- ca u )  s" base" ;
: samforth_word_DECIMAL  ( -- ca u )  s" decimal" ;
: samforth_word_HEX  ( -- ca u )  s" hex" ;
: samforth_word_C,  ( -- ca u )  s" c_comma" ;
: samforth_word_,  ( -- ca u )  s" comma" ;
: samforth_word_ALLOT  ( -- ca u )  s" allot" ;
: samforth_word_!  ( -- ca u )  s" store" ;
: samforth_word_C!  ( -- ca u )  s" c_store" ;
: samforth_word_@  ( -- ca u )  s" fetch" ;
: samforth_word_C@  ( -- ca u )  s" c_fetch" ;
: samforth_word_HERE  ( -- ca u )  s" here" ;
: samforth_word_LATEST  ( -- ca u )  s" latest" ;
: samforth_word_;CODE  ( -- ca u )  s" semicolon_code" ;
: samforth_word_CODE:  ( -- ca u )  s" code_colon" ;
: samforth_word_IN  ( -- ca u )  s" in" ;
: samforth_word_OUT  ( -- ca u )  s" out" ;
: samforth_word_PAGE  ( -- ca u )  s" page" ;
: samforth_word_DO  ( -- ca u )  s" do" ;
: samforth_word_+LOOP  ( -- ca u )  s" plus_loop" ;
: samforth_word_LOOP  ( -- ca u )  s" loop" ;
: samforth_word_I  ( -- ca u )  s" i" ;
: samforth_word_LINK  ( -- ca u )  s" link" ;
: samforth_word_AT  ( -- ca u )  s" at" ;
: samforth_word_BORDER  ( -- ca u )  s" border" ;
: samforth_word_BEEP  ( -- ca u )  s" beep" ;
: samforth_word_."  ( -- ca u )  s" dot_quote" ;
: samforth_word_SC!  ( -- ca u )  s" sc_store" ;
: samforth_word_SC@  ( -- ca u )  s" sc_fetch" ;
: samforth_word_P  ( -- ca u )  s" p" ;
: samforth_word_CLEAR  ( -- ca u )  s" clear" ;
: samforth_word_L  ( -- ca u )  s" l" ;
: samforth_word_B  ( -- ca u )  s" b" ;
: samforth_word_R  ( -- ca u )  s" r" ;
: samforth_word_C  ( -- ca u )  s" c" ;
: samforth_word_E  ( -- ca u )  s" e" ;
: samforth_word_UP  ( -- ca u )  s" up" ;
: samforth_word_DN  ( -- ca u )  s" dn" ;
: samforth_word_NEWL  ( -- ca u )  s" newl" ;
: samforth_word_LIST  ( -- ca u )  s" list" ;
: samforth_word_T  ( -- ca u )  s" t" ;
: samforth_word_ES  ( -- ca u )  s" es" ;
: samforth_word_FROM  ( -- ca u )  s" from" ;
: samforth_word_F  ( -- ca u )  s" f" ;
: samforth_word_TO  ( -- ca u )  s" to" ;
: samforth_word_EDIT  ( -- ca u )  s" edit" ;
: samforth_word_N  ( -- ca u )  s" n" ;
: samforth_word_DEL  ( -- ca u )  s" del" ;
: samforth_word_D  ( -- ca u )  s" d" ;
: samforth_word_INS  ( -- ca u )  s" ins" ;
: samforth_word_S  ( -- ca u )  s" s" ;
: samforth_word_H  ( -- ca u )  s" h" ;
: samforth_word_LOAD  ( -- ca u )  s" load" ;
: samforth_word_WHERE  ( -- ca u )  s" where" ;
: samforth_word_*  ( -- ca u )  s" star" ;
: samforth_word_TYPE  ( -- ca u )  s" type" ;
: samforth_word_SAM  ( -- ca u )  s" sam" ;
: samforth_word_SAVE  ( -- ca u )  s" save" ;
: samforth_word_DIR  ( -- ca u )  s" dir" ;
: samforth_word_=  ( -- ca u )  s" equals" ;
: samforth_word_/  ( -- ca u )  s" slash" ;
: samforth_word_MOD  ( -- ca u )  s" mod" ;
: samforth_word_BEGIN  ( -- ca u )  s" begin" ;
: samforth_word_UNTIL  ( -- ca u )  s" until" ;
: samforth_word_<  ( -- ca u )  s" less_than" ;
: samforth_word_>  ( -- ca u )  s" greater_than" ;
: samforth_word_R>  ( -- ca u )  s" to_r" ;
: samforth_word_>R  ( -- ca u )  s" r_from" ;
: samforth_word_KEY  ( -- ca u )  s" key" ;
: samforth_word_OVER  ( -- ca u )  s" over" ;
: samforth_word_ROT  ( -- ca u )  s" rot" ;
: samforth_word_2DUP  ( -- ca u )  s" two_dup" ;
: samforth_word_PAD  ( -- ca u )  s" pad" ;
: samforth_word_QUERY  ( -- ca u )  s" query" ;
: samforth_word_RETYPE  ( -- ca u )  s" retype" ;
: samforth_word_WORD  ( -- ca u )  s" word" ;
: samforth_word_IF  ( -- ca u )  s" if" ;
: samforth_word_ELSE  ( -- ca u )  s" else" ;
: samforth_word_ENDIF  ( -- ca u )  s" endif" ;
: samforth_word_THEN  ( -- ca u )  s" then" ;
: samforth_word_<BUILDS  ( -- ca u )  s" builds" ;
: samforth_word_DOES>  ( -- ca u )  s" does" ;
: samforth_word_WHILE  ( -- ca u )  s" while" ;
: samforth_word_REPEAT  ( -- ca u )  s" repeat" ;
: samforth_word_VARIABLE  ( -- ca u )  s" variable" ;
: samforth_word_CONSTANT  ( -- ca u )  s" constant" ;
: samforth_word_.  ( -- ca u )  s" dot" ;
: samforth_word_CMOVE  ( -- ca u )  s" cmove" ;
: samforth_word_AND  ( -- ca u )  s" and" ;
: samforth_word_OR  ( -- ca u )  s" or" ;
: samforth_word_XOR  ( -- ca u )  s" xor" ;
: samforth_word_NOT  ( -- ca u )  s" not" ;
: samforth_word_FIND  ( -- ca u )  s" find" ;
: samforth_word_COLD  ( -- ca u )  s" cold" ;
: samforth_word_FENCE  ( -- ca u )  s" fence" ;
: samforth_word_U/MOD  ( -- ca u )  s" u_slash_mod" ;
: samforth_word_<#  ( -- ca u )  s" less_number_sign" ;
: samforth_word_#>  ( -- ca u )  s" number_sign_greater" ;
: samforth_word_#  ( -- ca u )  s" number_sign" ;
: samforth_word_#S  ( -- ca u )  s" number_sign_s" ;
: samforth_word_D.  ( -- ca u )  s" d_dot" ;
: samforth_word_HOLD  ( -- ca u )  s" hold" ;
: samforth_word_SIGN  ( -- ca u )  s" sign" ;
: samforth_word_0=  ( -- ca u )  s" zero_equals" ;
: samforth_word_0<  ( -- ca u )  s" zero_less" ;
: samforth_word_INKEY  ( -- ca u )  s" inkey" ;
: samforth_word_FORGET  ( -- ca u )  s" forget" ;
: samforth_word_ERROR  ( -- ca u )  s" error" ;
: samforth_word_(  ( -- ca u )  s" paren" ;
: samforth_word_PICK  ( -- ca u )  s" pick" ;
: samforth_word_ROLL  ( -- ca u )  s" roll" ;
: samforth_word_ASCII  ( -- ca u )  s" ascii" ;
: samforth_word_PAPER  ( -- ca u )  s" paper" ;
: samforth_word_PEN  ( -- ca u )  s" pen" ;
: samforth_word_BRIGHT  ( -- ca u )  s" bright" ;
: samforth_word_FLASH  ( -- ca u )  s" flash" ;
: samforth_word_COLOUR  ( -- ca u )  s" colour" ;
: samforth_word_PLOT  ( -- ca u )  s" plot" ;
: samforth_word_DRAW  ( -- ca u )  s" draw" ;
: samforth_word_DRAWBY  ( -- ca u )  s" drawby" ;
: samforth_word_?SCROLL  ( -- ca u )  s" question_scroll" ;
: samforth_word_PALETTE  ( -- ca u )  s" palette" ;
: samforth_word_DRIVE  ( -- ca u )  s" drive" ;
: samforth_word_SV@  ( -- ca u )  s" sv_fetch" ;
: samforth_word_SV!  ( -- ca u )  s" sv_store" ;
: samforth_word_SVC@  ( -- ca u )  s" sv_c_fetch" ;
: samforth_word_SVC!  ( -- ca u )  s" sv_c_store" ;
: samforth_word_SOUND  ( -- ca u )  s" sound" ;
: samforth_word_SOFF  ( -- ca u )  s" soff" ;
: samforth_word_ROLS  ( -- ca u )  s" rols" ;
: samforth_word_CSIZE  ( -- ca u )  s" csize" ;
: samforth_word_UDGDEF  ( -- ca u )  s" udgdef" ;
: samforth_word_SCREEN  ( -- ca u )  s" screen" ;
: samforth_word_BLITZ  ( -- ca u )  s" blitz" ;
: samforth_word_BLITZ$  ( -- ca u )  s" blitz_dollar" ;
: samforth_word_PUT  ( -- ca u )  s" put" ;
: samforth_word_PUT$  ( -- ca u )  s" put_dollar" ;
: samforth_word_FILL  ( -- ca u )  s" fill" ;
: samforth_word_GRAB  ( -- ca u )  s" grab" ;
: samforth_word_GRAB$  ( -- ca u )  s" grab_dollar" ;
: samforth_word_TAB  ( -- ca u )  s" tab" ;
: samforth_word_OVERP  ( -- ca u )  s" overp" ;
: samforth_word_INVERSE  ( -- ca u )  s" inverse" ;
: samforth_word_BLOAD  ( -- ca u )  s" bload" ;
: samforth_word_BSAVE  ( -- ca u )  s" bsave" ;
: samforth_word_DLOAD  ( -- ca u )  s" dload" ;
: samforth_word_DSAVE  ( -- ca u )  s" dsave" ;
: samforth_word_EXPAND  ( -- ca u )  s" expand" ;

\ SamForth-B only:
: samforth_word_POP-DE  ( -- ca u )  s" pop_de" ;
: samforth_word_POP-HL  ( -- ca u )  s" pop_hl" ;
: samforth_word_PUSH-DE  ( -- ca u )  s" push_de" ;
: samforth_word_PUSH-HL  ( -- ca u )  s" push_hl" ;

: samforth_word>label  ( ca1 u1 -- ca2 u2 )
  \ Convert the real name of a SamForth word
  \ to its base label name for z80dasm.
  s" samforth_word_" 2swap s+
  \ 2dup space ." [EVALUATE: " type ." ]"  \ xxx debug check
  evaluate
  \ 2dup space ." [LABEL: " type ." ]" cr .s  \ xxx debug check
  ;

: samforth_word  ( a -- )
  \ Extract the information from a SamForth word.
  \ a = address of the word name in the SAM memory. 
  \ ca1 u1 = word name
  dup 'word_name !  counted  ( ca1 u1 )
  \ 2dup cr type \ key drop  \ xxx debug check
  samforth_word>label samforth_word_label$ str-set
  \ word_header_block
  link_field
  name_field
  code_field
  ;
: last_word?  ( a -- ff )
  \ a = SamForth address of the previous Forth word name in the
  \ dictionary
  $ffff =
  ;
: samforth_words  ( -- )
  \ Extract the information from all SamForth words.
  samforth_var_CLATE
  begin
    ( a )
    \ a = SamForth address of a Forth word name
    dup samforth_word
    'name>'link_field samforth@ dup last_word?
  until  drop
  ;

\ }}} **********************************************************
\ SamForth variables {{{

: (samforth_var)  ( ca1 u1 a2 -- a2 )
  \ Create a symbol, the block identifier and block start of a SamForth variable.
  \ ca1 u1 = name of the variable
  \ a2 = address of the variable
  >r 2dup .block_id .symbol_id
  r> dup .block_start dup .symbol_value
  ;
: samforth_short_var  ( ca1 u1 a2 -- )
  \ Create the symbol and the block of a SamForth 1-byte variable.
  \ ca1 u1 = name of the variable
  \ a2 = address of the variable
  >r .symbol_id
  r> .symbol_value
  ;
: samforth_long_var  ( ca1 u1 a2 -- )
  \ Create the symbol and the block of a SamForth 2-byte variable.
  \ ca1 u1 = name of the variable
  \ a2 = address of the variable
  >r .symbol_id
  r> .symbol_value
  \ >r 2dup .block_id .symbol_id
  \ r> dup .block_start dup .symbol_value
  \ 1+ .block_end
  \ s" worddata" .block_type
  ;
variable vars_start  \ start address of the SamForth variables
variable vars_end  \ end address of the SamForth variables
: update_var_bounds  ( a u -- )
  \ Update the start and end of the SamForth variables region
  \ with the address of the current SamForth variable.
  \ a = address of the variable
  \ u = length of the variable (1 or 2 bytes)
  1- + dup
  vars_start @ min vars_start !
  vars_end @ max vars_end !
  ;
: samforth_var  ( ca1 u1 a2 u2 -- )
  \ Create the symbol and the block of a SamForth variable.
  \ ca1 u1 = name of the variable
  \ a2 u2 = start and length of the variable
  2swap s" _fvar" s+ 2swap
  swap var swap
  2dup update_var_bounds
  case
    1 of  samforth_short_var  endof
    2 of  samforth_long_var  endof
  endcase
  ;

: (samforth_vars)  ( -- )
  \ Create the symbols and the blocks of all SamForth variables.
  s" flags" 400 1 samforth_var  \ various flags to control the system.
  s" lastk" 401 1 samforth_var  \ ASCII code of last key pressed.
  s" bord" 402 1 samforth_var  \ current border colour.
  s" frames1" 403 2 samforth_var  \ counts television picture frames into a double number.
  s" frames2" 405 2 samforth_var  \ counts television picture frames into a double number.
  s" ycord" 407 1 samforth_var  \ last Y position plotted or drawn.
  s" xcord" 408 2 samforth_var  \ last X position plotted or drawn.
  s" rstack" 410 2 samforth_var  \ address of return stack (Z80 stack).
  s" stp" 412 2 samforth_var  \ stack pointer to Forth stack.
  s" stack" 414 2 samforth_var  \ start of Forth stack.
  s" stkend" 416 2 samforth_var  \ end of Forth stack.
  s" samerr" 418 1 samforth_var  \ holds SAM error number.
  s" nmi" 419 2 samforth_var  \ address to jump to when NMI button pressed.
  s" clate" 421 2 samforth_var  \ address of last Forth word in dictionary at cold start.
  s" chere" 423 2 samforth_var  \ next vacant address in dictionary at cold start.
  s" latest" 425 2 samforth_var  \ address of last Forth word in dictionary.
  s" here" 427 2 samforth_var  \ next vacant address in dictionary.
  s" base" 429 2 samforth_var  \ current number base.
  s" fence" 431 2 samforth_var  \ address below which FORGET will not operate. It can be changed with the command FENCE.
  s" tib" 433 2 samforth_var  \ start address of the Terminal Input Buffer.
  s" pad" 435 2 samforth_var  \ start address of the temporary data holding area.
  s" st" 437 2 samforth_var  \ star address of source, usually 32768. The page holding the source file is paged in at C & D.
  s" tempstk" 439 2 samforth_var  \ used as temporary stack store.
  s" rampage" 441 1 samforth_var  \ page number where source file will be held. Defaults to page 7.
  s" errsp" 442 2 samforth_var  \ address at which return stack is set upon an error.
  s" corestore" 444 2 samforth_var  \ next vacant address in dictionary at cold start.
  s" state" 446 1 samforth_var  \ flag showing compile or imemediate mode.
  s" length" 447 1 samforth_var  \ used to test for the length of a word being looked for in the dictionary.
  s" leng" 448 1 samforth_var  \ used to test for the length of a word being looked for in the dictionary.
  s" ip" 449 2 samforth_var  \ address of interpreter pointer within source being compiled.
  s" dubflag" 451 1 samforth_var  \ flag indicating double number.
  s" bastack" 452 2 samforth_var  \ holds stack pointer from SAM BASIC.
  s" edits" 454 2 samforth_var  \ start address of source to be edited.
  s" numbit" 456 2 samforth_var  \ temporary store used during number output.
  s" part1" 458 2 samforth_var  \ temporary addresses used during number input.
  s" part2" 460 2 samforth_var  \ temporary addresses used during number input.
  s" endf" 462 2 samforth_var  \ temporary store used during number output.
  s" nega" 464 2 samforth_var  \ flag for negative number during number output.
  s" temp1" 466 2 samforth_var  \ temporary store for HERE during compiling.
  s" temp2" 468 2 samforth_var  \ temporary store for LATEST during compiling.
  s" il1" 470 1 samforth_var  \ length of input line before cursor.
  s" il2" 471 1 samforth_var  \ length of input line after cursor.
  s" etib" 472 2 samforth_var  \ end address of Terminal Input Buffer.
  s" iflag" 474 1 samforth_var  \ flag indicating that characters may be inserted into the input line and existing input is not over written.
  s" ldflg" 475 1 samforth_var  \ flag showing that source is being compiled.
  s" errhld" 476 2 samforth_var  \ address of interpreter pointer position when an error occurred during source compilation.
  s" svblk" 478 2 samforth_var  \ flag used during LOAD, SAVE, & DIR commands.
  s" slen" 480 2 samforth_var  \ length of source to be saved.
  s" se" 482 2 samforth_var  \ end address of source.
  s" sadd" 484 2 samforth_var  \ address from where source will be LOADed or SAVEd.
  s" hlds" 486 2 samforth_var  \ temporary store during number formatting.
  s" pairs" 488 2 samforth_var  \ flags to indicate whether pairs such as DO..LOOP match up during compilation.
  s" pageno" 490 2 samforth_var  \ holds number of page paged in at 32768 in sections C & D.
  s" cur" 492 2 samforth_var  \ address of cursor in input buffer.
  s" smode" 494 2 samforth_var  \ indicates SAM screen mode 1,2,3, or 4.
  s" notused0" 496 2 samforth_var
  s" notused1" 498 2 samforth_var
  s" notused2" 500 2 samforth_var
  s" len2" 502 2 samforth_var  \ used to increase or decrease length of source during editing.
  s" len1" 504 2 samforth_var  \ used to increase or decrease length of source during editing.
  s" lists" 506 2 samforth_var  \ start address of source list on screen, or of source to be SAVEd. Changed with T, N, FROM.
  s" elist" 508 2 samforth_var  \ end address of source list on screen or source to be SAVed. Changed with N or ES.
  s" blong" 510 2 samforth_var  \ used during source editing.
  s" endline" 512 2 samforth_var  \ used during source editing.
  ;

: init_samforth_vars_bounds  ( -- )
  \ Init the SamForth variables bounds.
  $ffff vars_start !  \ Z80 highest address
  0 vars_end !
  ;
: vars_block  ( -- )
  \ Create the SamForth variables block.
  s" variables" .block_id
  vars_start @ .block_start
  vars_end @ 1+ .block_end
  s" bytedata" .block_type
  ;
: samforth_vars  ( -- )
  \ Create the symbols and the blocks of all SamForth variables.
  init_samforth_vars_bounds
  (samforth_vars)
  vars_block
  ;

\ }}} **********************************************************
\ SamForth call parameters {{{

: jsvin_parameter  ( a -- )
  \ Create a worddata block for the call parameter of the JSVIN
  \ ROM routine.
  dup s" JSVIN_parameter_" rot n>h s+ .block_id
  dup .block_start  2 + .block_end
  s" worddata" .block_type
  ;
: (samforth-b_call_parameters)  ( -- )
  \ Create the blocks for the call parameters of ROM routines,
  \ in SamForth-B.
  $44b4 jsvin_parameter
  $44bb jsvin_parameter
  $44c1 jsvin_parameter
  $44d2 jsvin_parameter
  $44ea jsvin_parameter
  $460a jsvin_parameter
  $4613 jsvin_parameter
  $4644 jsvin_parameter
  $4652 jsvin_parameter
  $4740 jsvin_parameter
  $47de jsvin_parameter
  $47fe jsvin_parameter
  $4d19 jsvin_parameter
  $4d2a jsvin_parameter
  $4d3b jsvin_parameter
  $4d53 jsvin_parameter
  $4dd1 jsvin_parameter
  $5a83 jsvin_parameter
  $5a8c jsvin_parameter
  $5a9b jsvin_parameter
  $5eec jsvin_parameter
  ;
: samforth_call_parameters  ( -- )
  \ Create the blocks for the call parameters of ROM routines.
  samforth-b? if
    (samforth-b_call_parameters)
  then
  ;

\ }}} **********************************************************
\ SamForth RST {{{

\ SamForth is paged at 0000h, so RST calls SamForth routines,
\ not ROM routines.

: samforth_rst  ( n -- )
  \ Create a RST symbol in the symbols file. 
  base @ hex
  swap dup s>d <# # # #>
  s" rst" 2swap s+ .symbol_id
  .symbol_value
  base !
  ;
: samforth_rsts  ( -- )
  \ Create symbols for the RST commands used by SamForth.
  samforth-a? if
    $08 samforth_rst
    $10 samforth_rst
    $18 samforth_rst
    $20 samforth_rst
    $28 samforth_rst
    $30 samforth_rst
    $38 samforth_rst
  then
  ;

\ }}} **********************************************************
\ SamForth routines {{{

: .rom_routine  ( a ca1 u1 -- )
  \ Create symbols for a ROM routine.
  s" _rom_routine" s+ .symbol
  ;
: (samforth-b_routines)  ( -- )
  \ Create symbols for SamForth-B routines.
  $0103 s" jsvin" .rom_routine
  $014e s" jclsbl" .rom_routine
  $0112 s" jsetstrm" .rom_routine
  $4021 s" jp_push_hl" .symbol
  $4024 s" jp_pop_hl" .symbol
  $402a s" jp_pop_hl_de" .symbol
  $402d s" jp_error_a" .symbol
  $4d50 s" print_a" .symbol
  $4632 s" print_a_and_tos" .symbol
  $44be s" print_a_xxx_duplicated" .symbol
  $4060 s" jp_clear_lower_screen" .symbol
  $4641 s" clear_lower_screen" .symbol
  $4647 s" set_palette_l_to_e" .symbol
  \ The following symbols are not used because
  \ the jumps are direct to their routines:
  $4027 s" jp_push_hl_de" .symbol
  $4030 s" jp_print_a_xxx_duplicated" .symbol
  $6274 s" call_push_hl" .symbol
  $4fda s" return_from_basic" .symbol
  ;
: (samforth-a_routines)  ( -- )
  \ Create symbols for SamForth-A routines.
  $0066 s" nmi_routine" .symbol
  $0030 s" jp_error_a" .symbol  \ Synonym for RST 30
  $00db s" jp_rom_rst10" .symbol  \ Called by RST 8
  $05e6 s" rom_rst10" .symbol  \ Jumped at jp_rom_rst10
  $195e s" get_keypress_with_what_xxx" .symbol
  $0743 s" print_a_and_tos" .symbol
  $0e36 s" error_0x08_break_xxx_not_called" .symbol
  $0cf9 s" jp_page_pageno_in_and_set_iy_to_flags_and_error_0x0a_not_found" .symbol
  $0d39 s" error_0x0b_editor_error" .symbol
  $06e4 s" error_0x0c_xxx_unknown" .symbol
  $010b s" jp_clear_lower_screen_and_set_palette_l_to_e" .symbol
  $074c s" clear_lower_screen_and_set_palette_l_to_e" .symbol
  ;
: (samforth_routines)  ( -- )
  \ Create symbols for routines common to SamForth-A and
  \ SamForth-B (at different addresses).
  $00cc $4012 choose s" jp_page_pageno_in_and_set_iy_to_flags" .symbol
  $0811 $4718 choose s" jp_jp_page_pageno_in_and_set_iy_to_flags" .symbol
  $00d5 $401b choose s" jp_wait_for_keypress_and_return_it_in_a" .symbol
  $00c0 $4006 choose s" jp_main_loop" .symbol
  $00c6 $400c choose s" jp_u_dot_code_field" .symbol
  $00cf $4015 choose s" jp_interpret_code_field" .symbol
  $00d2 $4018 choose s" jp_keyboard_input" .symbol
  $00d8 $401e choose s" jp_de_hl_slash_mod" .symbol
  $0126 $407b choose s" jp_c_fetch_from_page_0" .symbol
  $0129 $407e choose s" jp_c_store_into_page_0" .symbol
  $00f0 $4045 choose s" jp_fetch_from_page_0" .symbol
  $0123 $4078 choose s" jp_store_into_page_0" .symbol
  $068a $4577 choose s" return_to_basic" .symbol
  $0799 $4698 choose s" c_fetch_from_page_0" .symbol
  $078c $4689 choose s" c_store_into_page_0" .symbol
  $077b $4674 choose s" fetch_from_page_0" .symbol
  $076c $4663 choose s" store_into_page_0" .symbol
  $0e05 $4d56 choose s" pop_hl" .symbol  \ Called by RST 18 
  $0e1f $4d70 choose s" push_hl" .symbol  \ Called by RST 10
  $0e3b $4d8c choose s" pop_hl_de" .symbol  \ Called by RST 28
  $0e60 $4db1 choose s" push_hl_de" .symbol  \ Called by RST 20
  $0e85 $4dce choose s" wait_for_keypress_and_return_it_in_a" .symbol
  $0e9d $4dd8 choose s" restore_the_input_pointer" .symbol
  $0eab $4de6 choose s" keyboard_input" .symbol
  $0f5a $4e9c choose s" print_cr" .symbol
  $1092 $501b choose s" main_loop" .symbol
  $10a0 $5029 choose s" error_a" .symbol  \ Called by RST 30
  $10a3 $502c choose s" error_message_not_found_yet" .symbol
  $10ab $5034 choose s" next_error_message_char" .symbol
  $10b4 $503f choose s" warm_restart" .symbol
  $117c $510a choose s" init" .symbol
  $11a9 $5136 choose s" save_dictionary_pointers" .symbol
  $11b6 $5143 choose s" restore_dictionary_pointers_and_set_interpretation_mode" .symbol
  $1234 $51d3 choose s" skip_space" .symbol
  $14ee $54f7 choose s" de_hl_slash_mod" .symbol
  $2135 $62c3 choose s" page_pageno_in_and_set_iy_to_flags" .symbol
  $066f $4558 choose s" sound_out_a_l" .symbol
  $00ea $403f choose s" jp_do_sound" .symbol
  $067a $4563 choose s" do_sound" .symbol
  $012c $4081 choose s" jp_sound_off" .symbol
  $0667 $4550 choose s" sound_off" .symbol
  $00de $4033 choose s" jp_change_drive_to_tos" .symbol
  $0760 $4655 choose s" change_drive_to_tos" .symbol
  $0117 $406c choose s" jp_call_jpalette" .symbol
  $0759 $464f choose s" call_jpalette" .symbol
  $00e4 $4039 choose s" jp_call_jdrawto" .symbol
  $071f $460d choose s" call_jdrawto" .symbol
  $0729 $4616 choose s" get_stack_coords_and_copy_to_bc" .symbol
  $00e1 $4036 choose s" jp_call_jplot" .symbol
  $0715 $4604 choose s" call_jplot" .symbol
  $1525 $5532 choose s" create_header_with_name_from_the_input_stream" .symbol
  $0111 $4066 choose s" jp_pen" .symbol
  $0739 $4628 choose s" pen" .symbol
  $010e $4063 choose s" jp_paper" .symbol
  $0735 $4624 choose s" paper" .symbol
  $0120 $4075 choose s" jp_bright" .symbol
  $0748 $463d choose s" bright" .symbol
  $011d $4072 choose s" jp_flash" .symbol
  $0741 $4630 choose s" flash" .symbol
  $0144 $4099 choose s" jp_inverse" .symbol
  $073d $462c choose s" inverse" .symbol
  $0141 $4096 choose s" jp_overp" .symbol
  $08e9 $4813 choose s" overp" .symbol
  $013e $4093 choose s" jp_tab" .symbol
  $08df $4801 choose s" tab" .symbol
  $00ff $4054 choose s" jp_at" .symbol
  $0614 $44ed choose s" at" .symbol
  $011a $406f choose s" jp_border" .symbol
  $061f $4500 choose s" border" .symbol
  $00e7 $403c choose s" jp_beep" .symbol
  $0627 $450a choose s" beep" .symbol
  $0153 $40a8 choose s" jp_editor_command_p" .symbol
  $094f $487d choose s" editor_command_p" .symbol
  $00c3 $4009 choose s" jp_page_rampage_in" .symbol
  $210f $6261 choose s" page_rampage_in" .symbol
  $0156 $40ab choose s" jp_clear" .symbol
  $0971 $489f choose s" clear" .symbol
  $0159 $40ae choose s" jp_editor_command_l" .symbol
  $097b $48a9 choose s" editor_command_l" .symbol
  $016b $40c0 choose s" jp_list" .symbol
  $0d54 $4c9a choose s" list" .symbol
  $0177 $40cc choose s" jp_editor_command_h" .symbol
  $0da4 $4cee choose s" editor_command_h" .symbol
  $00f9 $404e choose s" jp_load" .symbol
  $0a5f $4993 choose s" load" .symbol
  $0165 $40ba choose s" jp_where" .symbol
  $0aaf $49e3 choose s" where" .symbol
  $1085 $4fcb choose s" type_bc_chars_at_hl" .symbol
  $0147 $409c choose s" jp_bload" .symbol
  $08ee $4818 choose s" bload" .symbol
  $014a $409f choose s" jp_bsave" .symbol
  $08fd $4829 choose s" bsave" .symbol
  $014d $40a2 choose s" jp_dload" .symbol
  $0910 $483e choose s" dload" .symbol
  $0150 $40a5 choose s" jp_dsave" .symbol
  $0926 $4854 choose s" dsave" .symbol
  $1240 $51df choose s" first_char_to_interpret_found" .symbol
  $0f9e $4ee2 choose s" keyboard_input_cursor_left" .symbol
  $0fb8 $4efc choose s" keyboard_input_cursor_right" .symbol
  $0fda $4f1e choose s" keyboard_input_up" .symbol
  $0ff3 $4f37 choose s" keyboard_input_down" .symbol
  $0f38 $4e7e choose s" toggle_caps_lock" .symbol
  $1032 $4f76 choose s" toggle_insert_mode" .symbol
  $0f43 $4e85 choose s" keyboard_input_cr" .symbol
  $0f5e $4ea2 choose s" keyboard_input_backspace" .symbol
  $0f88 $4ecc choose s" keyboard_input_delete" .symbol
  $0f18 $4e53 choose s" keyboard_input_edit" .symbol
  $015f $40b4 choose s" jp_editor_command_to" .symbol
  $0a35 $4969 choose s" editor_command_to" .symbol
  $0180 $40d5 choose s" jp_editor_command_from" .symbol
  $09d9 $490d choose s" editor_command_from" .symbol
  $015c $40b1 choose s" jp_editor_command_f" .symbol
  $0a2b $495f choose s" editor_command_f" .symbol
  $013b $4090 choose s" jp_blitz" .symbol
  $08c6 $47e7 choose s" blitz" .symbol
  $0138 $408d choose s" jp_screen" .symbol
  $08b7 $47d6 choose s" screen" .symbol
  $0135 $408a choose s" jp_udgdef" .symbol
  $0861 $477c choose s" udgdef" .symbol
  $0132 $4087 choose s" jp_csize" .symbol
  $082f $4743 choose s" csize" .symbol
  $012f $4084 choose s" jp_rols" .symbol
  $0815 $471c choose s" rols" .symbol
  $00f6 $404b choose s" jp_colour" .symbol
  $07aa $46ad choose s" colour" .symbol
  $00f3 $4048 choose s" jp_mode" .symbol
  $05ed $44c4 choose s" mode" .symbol
  $00ed $4042 choose s" jp_cls" .symbol
  $05d6 $44a7 choose s" cls" .symbol
  $109a $5023 choose s" error_0x01_stack_empty" .symbol
  $109e $5027 choose s" error_0x02_stack_full" .symbol
  $12e0 $5295 choose s" error_0x04_colon_definitions_only_xxx_1" .symbol
  $1578 $5587 choose s" error_0x04_colon_definitions_only_xxx_2" .symbol
  $1495 $5486 choose s" error_0x03_undefined_word_xxx_1" .symbol
  $1e10 $5f20 choose s" error_0x03_undefined_word_xxx_2" .symbol
  $1503 $550e choose s" error_0x05_division_by_zero" .symbol
  $1e13 $5f25 choose s" error_0x08_break" .symbol
  $1701 $574a choose s" error_0x09_incomplete_form" .symbol
  $1597 $55aa choose s" error_0x0a_not_found" .symbol
  $15e4 $5601 choose s" base_a" .symbol
  $0162 $40b7 choose s" jp_editor_command_n" .symbol
  $0a4c $4980 choose s" editor_command_n" .symbol
  $0168 $40bd choose s" jp_edit" .symbol
  $0ac9 $49fd choose s" edit" .symbol
  $016e $40c3 choose s" jp_newl" .symbol
  $0d3c $4c82 choose s" newl" .symbol
  $0186 $40db choose s" jp_grab" .symbol
  $0dc1 $4d0b choose s" grab" .symbol
  $018c $40e1 choose s" jp_fill" .symbol
  $0ddd $4d2d choose s" fill" .symbol
  $0189 $40de choose s" jp_put" .symbol
  $0dcf $4d1c choose s" put" .symbol
  $0114 $4069 choose s" jp_dir" .symbol
  $0705 $45f4 choose s" dir" .symbol
  $0108 $405d choose s" jp_sam" .symbol
  $0682 $456f choose s" sam" .symbol
  $0102 $4057 choose s" jp_link" .symbol
  $05fd $44d5 choose s" link" .symbol
  $0105 $405a choose s" jp_link_l" .symbol
  $05fe $44d8 choose s" link_l" .symbol
  $0609 $44e7 choose s" link_a_not_to_channel_p" .symbol
  $060d $4478 choose s" link_a" .symbol
  $00fc $4051 choose s" jp_save" .symbol
  $06e7 $45d6 choose s" save" .symbol
  $070d $45fc choose s" call_rom_address_in_iy" .symbol
  $070d $45fc choose s" call_rom_address_in_iy" .symbol
  $12d0 $5283 choose s" compile_call_tos" .symbol
  $12d2 $5287 choose s" compile_call_de" .symbol
  $1985 $59ec choose s" push_true" .symbol
  $198a $59f3 choose s" push_false" .symbol
  ;
: samforth_routines  ( -- )
  \ Create symbols for SamForth routines.
  (samforth_routines)
  samforth-b? if
    (samforth-b_routines)
  else
    (samforth-a_routines)
  then
  ;

\ }}} **********************************************************
\ SAM Coupé symbols {{{

: sam_coupé_symbols  ( -- )
  \ Create symbols related to SAM Coupé.
  \ xxx Not used.
  \ This is useless, because z80dasm only translates
  \ used addresses. This has to be done during
  \ the postprocessing of the assembly.
  250 s" LMPR" .symbol  \ Low Memory Page Register
  251 s" HMPR" .symbol  \ High Memory Page Register
  ;

\ }}} **********************************************************
\ SamForth data zones {{{

: samforth_return_stack  ( -- )
  \ Create the block for the SamForth return stack.
  s" return_stack" .block_id
  samforth_var_RSTACK dup .block_start
  256 + .block_end
  s" worddata" .block_type
  ;
: samforth_data_stack  ( -- )
  \ Create the block for the SamForth data stack.
  s" data_stack" .block_id
  samforth_var_STKEND .block_start
  samforth_var_STACK .block_end
  s" worddata" .block_type
  ;
: samforth_tib  ( -- )
  \ Create the block for the SamForth TIB.
  s" tib" .block_id
  samforth_var_TIB .block_start
  samforth_var_PAD .block_end
  s" bytedata" .block_type
  ;
: samforth_pad  ( -- )
  \ Create the block for the SamForth PAD.
  s" pad" .block_id
  samforth_var_PAD .block_start
  samforth_var_STKEND .block_end
  s" bytedata" .block_type
  ;
: samforth_error_messages  ( -- )
  \ Create the block for the SamForth error messages. 
  s" errors" .block_id
  $10e1 $506f choose .block_start
  $117c $510a choose .block_end
  s" bytedata" .block_type
  ;
: samforth-b_special_zones  ( -- )
  \ Create some SamForth-B special block zones.
  samforth-b? if
    s" xxx_unknown_zone_00b" .block_id
    $40e4 .block_start
    $4133 1+ .block_end
    s" bytedata" .block_type
    s" xxx_unknown_zone_01b" .block_id
    $4d3e .block_start
    $4d4f 1+ .block_end
    s" bytedata" .block_type
  endif
  ;
: a>hex  ( a -- ca u )
  \ Convert an address to a 4-digit lowarcase hex string. 
  base @ swap hex
  s>d <# # # # # #> tmp$ str-set
  tmp$ str-lower
  base !
  tmp$ str-get
  ;
: a>branch  ( a -- ca u )
  \ Convert an address to a label name.
  a>hex s" branch_" 2swap s+
  ;
: samforth_0branch_datum  ( a1 a2 -- )
  \ Create block zone for one '0BRANCH'.
  \ a1 = start address in SamForth-A
  \ a2 = start address in SamForth-B
  2dup choose dup a>branch .block_id .block_start
  choose 2 + .block_end
  s" worddata" .block_type
  ;
: samforth_0branch_jump  ( a1 a2 -- )
  \ Create a symbol for a '0BRANCH jump.
  \ a1 = address in SamForth-A
  \ a2 = address in SamForth-B
  choose dup a>branch .symbol
  ;
: samforth_0branch_data  ( -- )
  \ Create block zones and jump symbols for all '0BRANCH'.
  $1d32 $5e2e samforth_0branch_datum
  $1d3b $5e39 samforth_0branch_jump
  $1d5d $5e5d samforth_0branch_datum
  $1d4b $5e4b samforth_0branch_jump
  $1d9a $5e9e samforth_0branch_datum
  $1da3 $5ea9 samforth_0branch_jump
  $1dad $5eb3 samforth_0branch_datum
  $1db2 $5eb8 samforth_0branch_jump
  ;
: samforth_special_zones  ( -- )
  \ Create some special block zones.
  s" xxx_unknown_zone_00" .block_id
  $0703 $45f2 choose .block_start
  $0704 $45f3 choose 1+ .block_end
  s" bytedata" .block_type
  $215b $62e9 choose s" cold_here" .symbol
  samforth-b_special_zones
  samforth_0branch_data
  ;
: samforth_data_zones  ( -- )
  \ Create the blocks for the SamForth data zones.
  samforth_return_stack
  samforth_data_stack
  samforth_tib
  samforth_pad
  samforth_error_messages
  samforth_special_zones
  ;

\ }}} **********************************************************
\ Argument checks {{{

: check_arguments#  ( -- )
  \ Make sure the number of parameters is one
  \ (the Gforth executable counts as one). 
  #args 1 3 within 0= if  \ 1 or 2 arguments?
    cr ." Error: Wrong number of arguments." cr
    usage bye
  then
  ;
: check_argument  ( n -- )
  \ Make sure the argument is right.
  arg 2dup  \ 2dup cr ." «" type ." »" \ xxx debug check
  file-status nip
  if
    cr ." Error: the '" type
    ." ' file can not be found." cr
    usage bye
  else
    2drop
  then  \ xxx todo check the status
  [ false ] [if]  \ xxx todo check the size
  32768 s>d d<>
  if
    cr ." Error: the'" type
    ." ' file length should be 32768." cr
    usage bye
  then
  [then]
  ;
: samforth-b_too?  ( -- ff )
  \ Is there a second argument (the SamForth-B binary file)?
  #args 2 =
  ;
: check_arguments  ( n -- )
  1 check_argument
  samforth-b_too? if  2 check_argument  then
  ;
: check
  \ Make sure the arguments are right.
  check_arguments# check_arguments
  ;
: .args  ( -- )
  \ Show all parameters. For debugging.
  argc @ 0 ?do
    i dup . ." arg = " arg type cr
    i dup . ." arg@ = " arg@ type cr
  loop
  ;

\ }}} **********************************************************
\ Main {{{

: ((samforth2z80dasm))  ( ca u -- )
  \ ca u = filename of the binary
  \ 'samforth-b?' is set
  open_files
  samforth_vars
  samforth_words
  samforth_routines
  samforth_data_zones
  samforth_rsts
  samforth_call_parameters
  sam_coupé_symbols
  close_files
  ;
: (samforth2z80dasm)  ( n -- )
  \ n = 0:SamForth, 1:SamForth-B
  dup 0<> to samforth-b?
  arg@ ((samforth2z80dasm))
  ;
: samforth2z80dasm  ( -- )
  \ Main word
  #args 0 ?do
    i (samforth2z80dasm)
  loop
  ;
: run ( -- )
  check samforth2z80dasm
  ;

\ .args
run bye

\ }}} **********************************************************

Downloads

Related pages

SamForth disassembled
Disassembling of SamForth.
SamForth documentation
Edited documentation of SamForth, a Forth system for the SAM Coupé computer.