Dump a Turbo Pascal 2/3 terminal data file

Dump a Turbo Pascal 2/3 terminal data file

empty forth definitions decimal application
warning on

: TITLE ." DTADMP version 1.2  2024-05-09" cr ;

cr .( Compiling: )  title  2 load

cr .( Save to disk? )  y/n  [if]
\  tally @  pad + #256 + limit s0 @ - +  set-limit
  turnkey program DTADMP
[then]

variable TALLY  0 tally !           \ run-time memory tally
defer ?STOP   ' noop is ?stop       \ user abort check
defer CON-IO  ' bios-io is con-io   \ default console i/o mode
defer ONERROR ' noop is onerror     \ reset on-error handler
defer ONSTART ' noop is onstart     \ startup initialization

blk @ 1+ #screens 1- thru       \ load electives & application

 ' ?stopkey is ?stop            \ enable user abort
 ' dos-io is con-io             \ enable console redirection
\ ' delout +is onerror           \ delete outfile on error
\ wrtchk off                     \ disable overwrite check

1 fload DOSLIB  \ DOSLIB library
 _Errors        \ error handler
 _Inout1        \ number output
\ _Inout2        \
\ _Compare1      \ basic compare
 _String1       \ basic strings
\ _String2       \ extra strings
 _Parse1        \ cmdline parsing
\ _Parse2        \ cmdline extra
 _Files         \ default files
\ _Bread         \ buffer read char
\ _Bread2        \ buffer read data/text
 _Bwrite        \ buffer write char
\ _Bwrite2       \ buffer write data/text

: HELP ( -- )  dos-io  cr cr title
  cr ." Use: DTADMP file[.DTA] [file[.DMP]]" cr
  cr ." -D  Disk output"
  cr
  cr ." Dump a Turbo Pascal terminal data file."
  con-io  abort ;

integer #TERM  ( -- u )  \ # terminals in DTA file
integer TSIZE  ( -- u )  \ size of each terminal entry
integer TBASE  ( -- a )  \ terminals base addr
integer CTERM  ( -- a )  \ current terminal addr
integer #DATUM ( -- u )  \ # fields in each terminal entry
integer CONOUT ( -- f )  \ console output flag

\ Set EMIT to OFILE
: DISK ( -- )
  ['] writechr [ sys-vec 4 + ] literal ! ;

\ Set options
:noname ( a u char -- a' u' )
  upcase
  [char] D  of  false to conout  end
  .bad ;  is setopt

\ Parse filenames
:noname ( -- )
  argv 0= if  help  then
  s" DTA" +ext  ifile !fname
  conout if end
  argv 0= if  ifile @fname  -path -ext  then
  s" DMP" +ext  ofile !fname
;  is parsefn

\ Fetch & increment
: @+ ( a -- a' x )  dup cell+ swap @ ;

\ Move to column
: TAB ( col# -- )  out @ -  spaces ;

\ Output
: DB. ( c -- )  0 .r ;
: HB. ( c -- )  (hb.) type  [char] h emit ;

: .D  ( a -- )  c@ db. ;
: .H  ( a -- )  c@ hb. ;

integer QUOTE ( -- f )  \ quote mode

: !Q ( f -- )  to quote  [char] ' emit ;
: +Q ( -- )    quote if end  [char] , emit  true !q ;
: -Q ( -- )    quote if  false !q  then ;

: QUOTABLE? ( c -- f )
  dup $20 $7F within  swap [char] ' <>  and ;

: .$ ( a -- )
  false to quote  count  dup db.  bounds ?do
    i c@  dup quotable? if  +q  emit
    else  -q  [char] , emit  hb.  then
  loop  -q ;

\ table of offsets to data
create OFFSET ( -- a )  hex
00 c,  15 c,  16 c,  26 c,  36 c,  46 c,  47 c,  48 c,
49 c,  4A c,  4B c,  4D c,  53 c,  59 c,  5B c,  61 c,
67 c,  69 c,  6F c,  75 c,  7B c,  7C c,  7D c,  7E c,
7F c,  80 c,  86 c,  8C c,  92 c,  93 c,  94 c,
decimal  here offset - to #datum

\ corresponding data actions
create ACTION ( -- a )
] .$   .h   .$   .$   .$   .d   .d   .d
  .d   .d   .d   .$   .$   .d   .$   .$
  .d   .$   .$   .$   .d   .d   .d   .d
  .h   .$   .$   .$   .d   .d   .h   [

\ Convert index to offset
: >OFFSET ( idx -- offs )  offset + c@ ;

\ Show data - byte or string
: .DATATYPE ( idx -- )
  dup >offset  cterm +  ( idx a )
  swap cells  action +  @execute ;

create NAMES ( -- a )
( 00) ," Terminal name"
( 15) ," ???"
( 16) ," Init string"
( 26) ," Exit string"
( 36) ," Cursor motion template"
( 46) ," 0=decimal 1=binary"
( 47) ," col offset in cm template"
( 48) ," row offset in cm template"
( 49) ," offset added to column"
( 4A) ," offset added to row"
( 4B) ," delay after cursor motion"
( 4D) ," clear screen"

( 53) ," home cursor"
( 59) ," delay after cls, delete line"
( 5B) ," hilite video"
( 61) ," normal video"
( 67) ," delay after clear-to-EOL, hilite"
( 69) ," clear-to-EOL"
( 6F) ," insert line"
( 75) ," delete line"
( 7B) ," screen columns"
( 7C) ," screen rows"
( 7D) ," init string flag"
( 7E) ," exit string flag"
( 7F) ," ???"

( 80) ," cursor lead-in"
( 86) ," string sent between row/col"
( 8C) ," string sent after row/col"
( 92) ," 1=column first  0=row first"
( 93) ," # col/row digits in cm template"
( 94) ," ???"

: NAME ( idx -- adr len )
  names  swap 0 ?do count + loop  count ;

\ Show description
: .NAME ( idx -- )  space  30 tab  name type ;

\ Show offset
: .OFFSET ( idx -- )  >offset hb. space ;

\ Show one field
: .FIELD ( idx -- )
  cr  dup .offset  dup .datatype  .name ;

\ Show one terminal
: .TERMINAL ( a -- )
  to cterm  #datum 0 ?do i .field loop  cr cr ;

\ Dump all terminals
: .ALL ( -- )
  tbase  #term 0 ?do  dup .terminal  tsize +  loop drop ;

\ Read DTA file into memory
: GETDTA ( -- )
  here unused read  ( a u) allot  ( a)
  @+ to #term  \ number of terminals in file
  @+ to tsize  \ size of each terminal
     to tbase  \ base address of terminals
  tsize $95 - if
    cr ." Not a TP2/3 terminal DTA file" .abort
  then ;

: OPENFILES ( -- )
  cr ." i: "  .ifile  r/o openin
  conout not if
  cr ." o: "  .ofile  r/w makeout
  then
  cr
;

\ Run application
: (RUN) ( -- )
  openfiles
  getdta
  conout not if  disk  then
  .all
  console
  closefiles
;

\ Set application defaults
: DEFAULTS ( -- )
  true to conout
;

defaults

\ Run application with error handling
: RUN ( -- )
  ['] (run) catch ?dup if  >r onerror r> throw  then ;

\ Main
: PROGRAM ( -- )
  onstart           \ startup initialization
  con-io            \ default console mode
  defaults          \ set defaults
  cr title          \ show application name
  cmdtail parsecmd  \ process command-line
  run               \ run application
  cr ." done"       \ show success
  ;