\ tools.f: ANS Compliant Meta Compiler tools for qs4 \ ========================================================================= \ Copyright 1997-98 by John Rible, \ Permission is granted for individual non-commercial use, provided this \ notice is included. Contact the author concerning other uses. \ ========================================================================= HEX +META DEFINITIONS \ Dictionary listing ------------------------------------------------------- : >CHAR ( c -- c' ) DUP 07F BL WITHIN IF DROP [CHAR] _ THEN ; : #### ( d - d' ) # # # # ; : .CELL ( x -- ) 0 <# #### #> TYPE ; : .ALPHA ( a n -- a+ ) [O] CHARS 0 ?DO [O] COUNT >CHAR EMIT LOOP ; : .ID+ ( na -- fa ) [O] COUNT .ALPHA ; : SAME? ( ca1 ca2 cc -- f ) \ note: zero-length strings match ( ca1 ca2 cc ) >R ( R: cc ) ( ca1 ca2 ) BEGIN R> DUP 1 - >R WHILE ( R: cc- ) >R [O] COUNT R> [O] COUNT ROT XOR ( ca1+ ca2+ dif? ) UNTIL 2DROP R> DROP 0 EXIT \ not same ( R: ) THEN 2DROP R> \ same ; : WIDWORDS ( ca cc wid -- ca cc ) ( ca cc wid ) SWAP >R CR @ ( R: cc ) ( ca na ) BEGIN DUP WHILE \ non-empty wordlist 2DUP [O] CHAR+ R@ SAME? IF \ match? SPACE DUP .ID+ DROP THEN [O] CELL- [O] @ ( ca na' ) NUF? UNTIL THEN DROP R> ( R: ) ; :O NAMES ( -- ) 0 DUP TLAST @ IF TLAST WIDWORDS THEN 2DROP ;O \ memory dump -------------------------------------------------------------- :O DUMP ( ca u -- ) ( ca u ) BASE @ >R HEX [O] CHARS BOUNDS ( a1 a ) BEGIN 2DUP SWAP U< WHILE \ for each line CR DUP .CELL SPACE SPACE \ show address 8 2* [O] CHARS 2DUP BOUNDS ( a1 a n a2 a ) BEGIN 2DUP XOR WHILE \ show bytes [O] @++ .CELL SPACE REPEAT 2DROP ( a1 a n ) SPACE .ALPHA \ show alpha ( a1 a2 ) NUF? UNTIL THEN 2DROP R> BASE ! ;O : ####_ ( d - d' ) #### [CHAR] _ HOLD ; : <@HEX> ( u - ca cc ) \ convert to "@####" BASE @ >R HEX 0 <# #### [CHAR] @ HOLD #> R> BASE ! ; : ( u - ca cc ) <@HEX> SWAP 1+ SWAP 1- ; : ( u - ca cc ) BASE @ >R 2 BASE ! 0 <# ####_ ####_ ####_ #### #> R> BASE ! ; \ Dissassembly listing for both Verilog 'readmemb' input and Forth reassembly VARIABLE _(( : .(( ( - ) _(( @ EXECUTE ; : .Forth ( - ) ." ( " ; : asForth ( - ) ['] .Forth _(( ! ; : .Verilog ( - ) ; : asVerilog ( - ) ['] .Verilog _(( ! ; asVerilog : .version ( - ) .(( 19 SPACES ." // " .META .QASM ." )" ; : .ADBIN ( x aa - ) .(( <@HEX> TYPE SPACE TYPE ." //) " ; : .BIN ( x - ) .(( 6 SPACES TYPE ." //) " ; : .NOBIN ( - ) .(( 19 SPACES ." //) " ; : NAMED? ( aa -- na | 0 ) \ check for a name with whose xt points to aa ( aa ) TNP @ DUP TSIZE @ [O] CELLS = IF 2DROP 0 EXIT THEN ( aa XA ) BEGIN 2DUP [O] @ [O] >ADR = IF SWAP DROP [O] CELL+ [O] CELL+ EXIT THEN ( aa xa ) [O] CELL+ [O] @ ( aa na ) DUP WHILE [O] CELL- [O] CELL- ( aa xa ) REPEAT ( aa 0 ) SWAP DROP \ not found ; : .LIT ( a x - f ) SPACE DUP ROT < OVER [O] >ADR NAMED? AND ?DUP IF DUP [O] CHAR+ [O] C@ [CHAR] _ = >R ." ' " .ID+ 2DROP R> ELSE .CELL 0 THEN ; : .end-code ( f - ) IF .NOBIN ." end-code" CR THEN ; : .CODE ( aa x f - aa' f' ) OVER unburned @ = IF .end-code DROP 0 EXIT THEN >R 2DUP SWAP [O] CELL- 2/ .ADBIN DUP 1 AND IF .OP IF [O] @++ 2DUP .LIT DROP CR .BIN THEN ELSE R@ IF ." call" OVER SWAP .LIT IF [O] @++ DUP SPACE .CELL ." ," CR .BIN THEN ELSE OVER [O] CELL- .CELL ." org " .CELL ." ," THEN THEN CR R> ; : SEA ( aa u -- ) \ symbolic dump routine ( aa u ) [O] CELLS BOUNDS 0 >R .version ( a2 a1 ) BEGIN 2DUP SWAP U< WHILE DUP NAMED? ?DUP IF R> 1 >R .end-code ( a2 a1 na ) CR .NOBIN OVER .CELL ." org code " .ID+ DROP CR ( a2 a1 ) THEN [O] @++ R> .CODE >R ( a2 A1 ) NUF? UNTIL THEN 2DROP R> .end-code ; :O SEA ( aa u -- ) SEA ;O :O SEE ( 'name' -- ) [O] ' [O] >ADR -1 SEA ;O \ Vector TYPE EMIT and CR to a file ---------------------------------------- \ originally done by Skip Inskeep \ usage example: 0 TSIZE @ ' SEA ToFile ..\testqs4.mem CREATE crlf$ 02 c, 0d c, 0a c, 0 c, VARIABLE fout \ file handle of output file CREATE charbuf 1 CHARS ALLOT \ buffer for EMIT : ftype ( ca cc - ) fout @ write-file THROW ; : femit ( c - ) charbuf TUCK C! 1 ftype ; : fcr ( - ) crlf$ COUNT ftype ; : ToFile ( ... xt 'file' - ??? ) \ all of xt's output goes to file PARSE-WORD R/W CREATE-FILE THROW fout ! [ Win32Forth ] [IF] \ win32forth vectors ['] ftype ['] type >body @ >r IS type \ replace i/o vectors ['] femit ['] emit >body @ >r IS emit ['] fcr ['] cr >body @ >r IS cr CATCH \ r> IS cr r> IS emit r> IS type \ restore original vectors [THEN] [ SwiftForth ] [IF] \ Swiftforth vectors ['] ftype 'type dup @ >r ! \ replace i/o vectors ['] femit 'emit dup @ >r ! ['] fcr 'cr dup @ >r ! CATCH \ execute r> 'cr ! r> 'emit ! r> 'type ! \ restore original vectors [THEN] fout @ CLOSE-FILE THROW THROW \ before THROWing any error ; :O SAVEFILE ( 'file' - ) HEX 0 SHORE @ ['] SEA ToFile ;O \ Command line interface --------------------------------------------- :O -c ( 'number' - ) [O] H# 2 =image ;O \ 2 bytes/cell for qs* :O -nosym ( - ) TDP @ SHORE ! ;O \ won't disassemble the headers :O -i ( 'file' - ) [O] INCLUDE ;O :O -f ( 'file' - ) asForth [O] SAVEFILE ;O :O -v ( 'file' - ) asVerilog [O] SAVEFILE ;O :O -x ( - ) [O] ]image BYE ;O :O -? ( - ) \ short help list cr ." QASM commands:" cr cr ." -c nnnn hex target memory size in 16-bit cells (MUST BE FIRST)" cr ." -nosym don't include the symbol table in the output file" cr ." -i include assembler source file (may be more than one)" cr ." -f write Forth output file" cr ." -v write Verilog output file" cr ." -x exit assembler (interactive if this isn't on command line)" cr cr ." Plus the whole assembler is available in interactive mode." ;O :O help ( - ) [O] -? ;O