SamForth2z80dasm
Description of the page content
Tool program to disassemble SamForth.
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
\ }}} **********************************************************
\ Development history {{{
0 [if]
2012-12-22
Version A-00. Brute force search: the whole binary is searched
for name fields (the length plus the name); words are searched
in the order they are defined; every search starts where the
last search finished. The problem is some short words produce
wrong matches.
2012-12-23
Version A-01. Words are explored using their name link address.
The top word on the dictionary is get from a SamForth variable.
Version A-02. Also SamForth variables are converted to blocks
and symbols. Fixed: the end of data blocks was one byte less
than needed by z80dasm.
2012-12-26
Version A-03. Also SamForth RST addresses and some discovered
routines are included as symbols. New: '.symbol'.
2012-12-28
Several new routines. 'TIB', 'PAD' and error messages.
2012-12-29
Version A-04. Support for SamForth-B. One or two filenames as
arguments. Symbol for word name field. More routines.
2013-01-01
A new routine marked with a symbol.
2013-01-04
Several new routines marked.
Symbols file indentation fixed: it failed with labels exactly 30 chars long.
2013-01-05
Many new routines marked with symbols.
2013-01-06
Return stack marked.
2013-01-07
Fixed the address of 'cls' in SamForth-A.
Several new routines marked.
New symbols.
2013-01-08
Two 'nop' unknown zones in SamForth-B are marked in order to
convert them to 'defs' during the postprocessing.
Symbol for 0x0066 (the NMI routine), needed in SamForth-A.
2013-01-15
Updated the stack notation for strings.
2013-01-21
Fix: 'jp_u_dot_header_end' renamed to 'jp_u_dot_code_field'.
Fix: the 'call_rom_address_in_iy' symbol was not defined in SamForth-B.
The routine exits, but it's not used.
New symbols: 'compile_call_tos', 'compile_call_de',
'error_0x01_stack_empty', 'error_0x02_stack_full',
'call_push_hl', 'return_from_basic'.
New symbols of the keybord input routine.
2013-01-22
New: block zones for all '0branch'.
2013-01-23
New names for unknown symbols: 'toggle_caps_lock',
'toggle_insert_mode'.
2013-01-24
New symbols: 'push_true', 'push_false'.
[then]