\ 4tH source patcher - Copyright 2008, 2009 J.L. Bezemer
\ You can redistribute this file and/or modify it under
\ the terms of the GNU General Public License
include lib/ncoding.4th \ for selected structure members
include lib/files.4th \ for REWIND
include lib/scanfile.4th \ for SCAN-FILE
include lib/argopen.4th \ for ARG-OPEN
include lib/row.4th \ for ROW
include lib/startend.4th \ for STARTS?
include lib/parsname.4th \ for PARSE-NAME
include lib/padding.4th \ for padding the fields
include lib/leading.4th \ for -LEADING
\ ***
\ Data section
\ ***
256 constant #size \ size of array; assume all tokens used
151 constant #available \ how many tokens are still available
32 constant /mnemonic \ the size of a name_4th[] mnemonic
12 constant /cmds_mask \ the width of a cmds_4th.h column
12 constant /save_marg \ left margin of save_4th()
19 constant /load_marg \ left margin of load_4th()
13 constant /name_mask \ the width of a name_4th[] column
5 constant #name_cols \ the number of name_4th[] columns
char ~ constant tilde \ ASCII code of ~
[hex] 35d [decimal] constant version# \ 4tH version for this script
\ all comp_4th() types
0 enum _CONS_ enum _IMME_ constant _WORD_
\ check for correct 4tH version
version# 4th# [negate] [+] [if] [abort] [then]
\ structure for a word
struct
width +field name \ the name of the word
nell +field length \ the length of the word
16 +field token \ C macro for the token
1 +field datatype \ datatype of the word
32 +field fixedparm \ any fixed parameter (e.g. constant)
nell +field symbol \ number of symboltable entries
nell +field correction \ any allocation corrections
16 +field delimiter \ any delimiters (e.g. strings)
32 +field cfunction \ the C function of an immediate word
end-struct /word
\ structure for a token
struct
16 +field tname \ the name of the token
1 +field tparm \ does it take any parameters
nell +field tcode \ numeric value of the token
32 +field tmnemo \ mnemonic of name_4th[]
end-struct /token
#size /mnemonic [*] string mnemonics \ array for mnemonics
#size /word [*] string words \ array for words
#size /token [*] string tokens \ array for token
#size string temp \ string for premature read string
#size string #using \ string for temporary formatting
\ calculate addresses from index
:this words does> swap /word * + ;
:this tokens does> swap /token * + ;
:this mnemonics does> swap /mnemonic * + ;
\ translation table for booleans
create booleans
," yes" true ,
," no" false ,
NULL ,
\ look it up straight away
:this booleans does>
2 string-key row 0= abort" Bad boolean" nip nip cell+ @c
; \ get the value
\ translation table for datatypes
create datatypes
," constant" _CONS_ ,
," immediate" _IMME_ ,
," word" _WORD_ ,
NULL ,
\ look it up straight away
:this datatypes does>
2 string-key row 0= abort" Bad datatype" nip nip cell+ @c
; \ get the value
variable #user-words \ number of defined words
variable #user-tokens \ number of defined tokens
variable #mnemonics \ number of defined mnemonics
\ ***
\ Generic words
\ ***
( a1 n1 a2 n2 -- a1 n1 f)
: marker? tib count -leading 2over starts? nip nip ;
: "," [char] , emit ; ( --)
: restore-line temp count type cr ; ( --)
: save-line 0 parse temp place ; ( --)
: ?number number error? abort" Bad number" ;
: DONE ." .. done" cr ; ( --)
: .tib 0 parse type cr ; ( ..)
: .all begin refill while .tib repeat ;
\ copies everything up to marker
: >marker ( a n --)
begin
refill \ get new line
while \ compare it to marker
marker? 0= \ marker found?
while \ if marker not found
.tib \ print the line
repeat 2drop \ drop marker
;
: skip>marker ( a n --)
begin
refill \ get new line
while \ compare it to marker
marker? 0= \ marker found?
while \ if marker not found
repeat 2drop \ drop marker
;
\ inserts parameter tokens
: io-user ( n --)
>r #user-tokens @ 0 ?do \ save margin
i tokens -> tparm c@ \ get the parameter
if \ if it is set
j spaces \ write margin spaces and the token
." case (" i tokens -> tname count type ." ):" cr
then
loop .tib r> drop \ write line in tib
;
\ ***
\ This subsystem reads the initial definitions
\ ***
\ read word from file
: read-word ( n -- n+1)
>r \ save index
tilde parse tuck r@ words -> name place
r@ words -> length n! \ copy data to structure
tilde parse r@ words -> token place
tilde parse datatypes r@ words -> datatype c!
tilde parse r@ words -> fixedparm place
tilde parse ?number r@ words -> symbol n!
tilde parse ?number r@ words -> correction n!
tilde parse r@ words -> delimiter place
tilde parse r@ words -> Cfunction place
r> 1+ \ increase index
;
\ read a token from file
: read-token ( n -- n+1)
>r \ save index
tilde parse r@ tokens -> tname place
tilde parse booleans r@ tokens -> tparm c!
tilde parse r@ tokens -> tmnemo place
r> 1+ \ increase index
;
\ read tokens from file
: read-tokens ( h -- h)
s" [tokens]" scan-file 0= abort" Cannot find [tokens]" 2drop
0 begin refill while tib count -trailing nip while read-token repeat
dup #available > abort" Too many tokens"
dup #user-tokens ! . ." tokens read" cr
;
\ read words from file
: read-words ( h -- h)
s" [words]" scan-file 0= abort" Cannot find [words]" 2drop
0 begin refill while tib count -trailing nip while read-word repeat
dup #user-words ! . ." words read" cr
;
\ ***
\ This subsystem patches cmds_4th.h
\ ***
\ read current tokens
: read-cmds ( -- n)
0 begin \ start with 0
tib count s" /* ranges */" starts? 0=
while \ all tokens read
2drop parse-name nip \ if not an empty line
if parse-name 2drop parse-name ?number max then
refill 0= abort" Cannot find /* ranges */"
repeat \ take the higher token
2drop save-line \ save /* ranges */ line
;
\ assign number to new tokens
: scan-cmds ( --)
s" #define NOOP" scan-file 0= abort" Cannot find NOOP token" 2drop
read-cmds #user-tokens @ 0 ?do 1+ dup i tokens -> tcode n! loop drop
;
\ terminate cmds_4th.h properly
: cmds-lastword ( --)
restore-line \ write saved line
." #define LastWord4th " #user-tokens @ 1- tokens -> tname count type cr
s" #define LastWord4th" scan-file 0= abort" Cannot find LastWord4th" 2drop
; \ update LastWord4th
\ write the user tokens
: cmds-user ( --)
#user-tokens @ 0 ?do \ add all user tokens
." #define " i tokens -> tname count tuck type
/cmds_mask swap - i tokens -> tcode n@ swap .r cr
loop cr
;
\ write new cmds_4th.h
: write-cmds ( --)
s" cmds_4th.h" output open error? abort" Cannot open cmds_4th.h" dup use
s" /* ranges */" >marker cmds-user cmds-lastword .all close
;
\ open cmds_4th.txt file
: cmds_4th ( --)
s" cmds_4th.txt" input open error? abort" Cannot open cmds_4th.txt"
dup use scan-cmds dup rewind abort" Cannot rewind cmds_4th.txt"
write-cmds close DONE \ write tokens and signal we're done
;
\ ***
\ This subsystem patches save_4th.c
\ ***
\ write the new save_4th.c
: write-save ( --)
s" save_4th.c" output open error? abort" Cannot open save_4th.c"
dup use s" case (CALL):" >marker /save_marg io-user .all close
; \ search marker and insert tokens
\ open save_4th.txt file
: save_4th ( --)
s" save_4th.txt" input open error? abort" Cannot open save_4th.txt"
dup use write-save close DONE \ write new file and done!
;
\ ***
\ This subsystem patches load_4th.c
\ ***
\ write the new save_4th.c
: write-load ( --)
s" load_4th.c" output open error? abort" Cannot open load_4th.c"
dup use s" case (CALL):" >marker /load_marg io-user .all close
; \ search marker and insert tokens
\ open load_4th.txt file
: load_4th ( --)
s" load_4th.txt" input open error? abort" Cannot open load_4th.txt"
dup use write-load close DONE \ write new file and done
;
\ ***
\ This subsystem patches name_4th.c
\ ***
\ get the system defined mnemonics
: get-mnemonics ( -- n)
0 >r begin \ reset count
refill \ get a new line
while \ when not end-of -file
tib count -leading -trailing s" };" compare
while \ when not end-of function()
begin parse-name dup while r@ mnemonics place r> 1+ >r repeat
2drop \ add mnemonic to the table
repeat save-line s" ," r@ 1- mnemonics +place r>
; \ save the final mnemonic
\ add the user mnemonics
: add-mnemonics ( n --)
#user-tokens @ tuck 0 ?do \ for all user mnemonics
dup i tokens -> tmnemo count rot i + mnemonics dup >r place s" ," r> +place
loop + #mnemonics ! \ add them to the table
; \ save total mnemonics
\ format the currently printed mnemonic
: format-mnemonic ( n1 -- a n2)
#name_cols mod if space else cr 2 spaces then mnemonics count
; \ decide which layout for mnemonic
\ write all mnemonics
: write-mnemonics ( --)
#mnemonics @ 1- dup 0 ?do \ for all but one mnemonics
i dup format-mnemonic /name_mask .padding
loop dup format-mnemonic 1- type cr restore-line
; \ print them
\ controls all mnemonics writing
: name-user ( --)
get-mnemonics add-mnemonics write-mnemonics
; \ get mnemonics, add the users', write
\ write the new name_4th.c
: write-name ( --)
s" name_4th.c" output open error? abort" Cannot open name_4th.c" dup use
s" char *name_4th [] = {" >marker 0 parse type name-user close
;
\ open name_4th.txt file
: name_4th ( --)
s" name_4th.txt" input open error? abort" Cannot open name_4th.txt"
dup use write-name close DONE \ write new file and done
;
\ ***
\ This subsystem patches exec_4th.c
\ ***
\ write custom I/O functions
: custom-io ( hp ho a n -- hp ho)
2drop ." /* Custom I/O functions added by 'patch4th' */" cr cr .tib
s" [vm.support]" >marker cr cr dup use
s" /* This function is roughly equivalent with Forths <# */" skip>marker
;
\ write standard I/O functions
: standard-io ( hp ho a n -- hp ho)
2drop restore-line dup use
s" /* This function is roughly equivalent with Forths <# */" >marker
;
\ write the new exec_4th.c
: write-exec ( hp ho -- hp ho)
s" exec_4th.c" output open error? abort" Cannot open exec_4th.c" >r r@ use
s" #include <time.h>" >marker .tib over use
s" [vm.include]" scan-file 0= abort" Cannot find [vm.include]" 2drop
s" [vm.globals]" >marker dup use
s" static jmp_buf Thrown;" >marker .tib over use
s" [vm.io]" >marker dup use
s" /* This baby simply prints a single character." >marker
save-line over use refill 0= abort" Cannot find [vm.support]"
s" [vm.support]" marker? if standard-io else custom-io then .tib
s" Main routine and the only external." >marker save-line
." User code added by 'patch4th'" cr ." */" cr cr cr over use
s" [vm.vars]" >marker cr cr ." /*" cr restore-line dup use
s" va_list Vals;" >marker .tib over use
s" [vm.extension]" >marker dup use
s" default:" >marker save-line over use
s" [immediate.words]" >marker restore-line dup use .all r> close
;
\ open name_4th.txt file
: exec_4th ( --)
s" exec_4th.txt" input open error? abort" Cannot open exec_4th.txt"
dup use write-exec close DONE \ write new file and done
;
\ ***
\ token insertion subsystem
\ ***
\ several formatting words
: .{ spaces ." { " ; \ print an aligned curly brace
: >"string" #using >r s| "| r@ place count r@ +place s| "| r> +place ;
: >string count #using place ; \ copy string to #using
: +, s" ," #using +place ; \ append a comma to #using
: .padded #using count rot .padding ; \ print #using with padding
: .blurted #using count type ; \ print #using without formatting
: .} count type ." }," cr ; \ finish the line
\ this word prints a constant token
: .constant
9 .{ dup words -> length n@ 0 .r "," space
dup words -> name >"string" +, .blurted space
dup words -> token >string +, .blurted space
words -> fixedparm .}
;
\ this word prints an immediate token
: .immediate ( i --)
2 .{ dup words -> length n@ 0 .r ","
dup words -> symbol n@ 3 .r ","
dup words -> correction n@ 3 .r "," space
dup words -> name >"string" +, 15 .padded
dup words -> delimiter >string +, 7 .padded
words -> cfunction .}
;
\ this words print a simple word
: .word
9 .{ dup words -> length n@ 0 .r "," space
dup words -> name >"string" +, .blurted space
words -> token .}
;
\ matching methods with types
create methods
_CONS_ , ' .constant ,
_IMME_ , ' .immediate ,
_WORD_ , ' .word ,
NULL ,
:this methods does>
2 num-key row 0= abort" Bad datatype" nip cell+ @c execute
;
\ get the size from the table
: get-size ( -- n)
parse-name 2drop \ drop curly brace
[char] , parse -leading -trailing \ get the number
number error? if drop max-n then 0 >in !
; \ check if it is a valid number
\ check if token should be included
: applicable? ( t l i -- i t f)
>r r@ words -> length n@ = ( t f)
over r@ words -> datatype c@ = and ( t f)
r> -rot ( i t f)
;
\ insert tokens at appropriate place
: insert-tokens ( t l i -- t l i)
2dup 2>r width min 1+ swap do
#user-words @ 0 ?do \ if a word is applicable
dup j i applicable? if methods else drop drop then
loop \ apply the appropriate method (print)
loop 2r>
; \ this checks the table against value
( t l -- t l i f)
: size? get-size over over > dup >r 0= if insert-tokens then r> .tib ;
\ inner loop of token detection
: next? ( l -- l f)
begin max-n refill while drop size? while drop repeat nip dup max-n <>
; \ drop lower count and create flag
\ outer loop of token detection
: patch-tokens 1 begin next? while 1+ repeat 2drop ;
\ words for patching in tokens
\ ***
\ This subsystem patches comp_4th.c
\ ***
\ write the new name_4th.c
: write-comp ( --)
s" comp_4th.c" output open error? abort" Cannot open comp_4th.c" dup use
s" This list contains all immediate words." >marker save-line
." User code added by 'patch4th'" cr ." */" cr cr cr
>r >r dup use r> r> .all cr cr ." /*" cr restore-line over use
s" static Immed4th ImmedList [] = {" >marker .tib _IMME_ patch-tokens
s" static Word4th WordList [] = {" >marker .tib _WORD_ patch-tokens
s" static Const4th ConstList [] = {" >marker .tib _CONS_ patch-tokens
over use .all close
;
\ open comp_4th.txt file
: comp_4th ( --)
s" comp_4th.txt" input open error? abort" Cannot open comp_4th.txt"
dup use write-comp close DONE \ write new file and done
;
\ ***
\ This is the control subsystem that monitors all patching
\ ***
\ main word
: patch-4th ( --)
argn 2 < abort" Usage: patch4th patch-file"
." Opening " 1 dup args type cr input swap arg-open
." .. " read-tokens \ read tokens
." .. " read-words \ read words
." Processing cmds_4th.txt" cr cmds_4th
." Processing save_4th.txt" cr save_4th
." Processing load_4th.txt" cr load_4th
." Processing name_4th.txt" cr name_4th
." Processing exec_4th.txt" cr exec_4th
." Processing comp_4th.txt" cr comp_4th
." Closing " 1 args type cr close \ close file
DONE \ signal all done
;
patch-4th
|
