\ Install - Information                                                                                                         This is the source to the DX-Forth installer program.                                                                           INSTALL customises the DX-Forth compiler or turnkey applicationsfor a variety of video terminals.  In addition, the CPU speed,  terminal delay times, arrow key codes and no-warmboot option maybe adjusted.                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                    \ Load block                                                    empty forth definitions  decimal                                application                                                                                                                     : TITLE ( -- )  ." DX-INSTALL 1.3" cr ;                                                                                         cr .( loading ) title  2 #screens 1- thru                                                                                       cr .( Save to disk? ) y/n [if]                                    turnkey install INSTALL   \ create turnkey application        [then]                                                                                                                                                                                                                                                                                                                                                                                          \ (Z1) (Z2)                                                     hex                                                             \ Parse null-terminated string                                  label (Z1)  ( de=src hl=dst ; de=src' b=len )                     0FF b mvi  h push                                              1 $:  b inr  h inx  d ldax  d inx  a ora                         3 $ jz  char \ cpi  2 $ jnz  d ldax  d inx                     2 $:  a m mov  1 $ jmp                                          3 $:  h pop  b m mov  ret  end-code                                                                                            \ Place counted string                                          label (Z2)  ( de=src hl=dst b=len )                               b m mov  b inr                                                 1 $:  b dcr  rz  d ldax  d inx  h inx                            a m mov  1 $ jmp  end-code                                                                                                    \ (Z3)                                                          \ Parse cursor motion string                                    label (Z3)  ( de=src hl=dst ; de=scr' )                           0FF b mvi  a xra  019C sta  019D sta  \ zero offsets            016B sta  016C sta  h push            \ reset temp flags       1 $:  b inr  h inx                                              2 $:  d ldax  d inx  a ora  4 $ jz     \ end                     char % cpi  5 $ jz                    \ command follows         char \ cpi  3 $ jnz  d ldax  d inx    \ literal char follows   3 $:  a m mov  1 $ jmp                                          4 $:  h pop  b m mov                   \ insert count            016B lda  a ora  rz                   \ make col first if req.  019C lhld  l a mov  h l mov  a h mov  019C shld                 019E lhld  l a mov  h l mov  a h mov  019E shld  ret                                                                                                                                          \ (Z3)                                                           5 $:  d ldax  d inx            \ get next char                   char a cpi  6 $ jc            \ make uppercase                  char z 1+ cpi  6 $ jnc  20 sui                                 6 $:                                                             char + cpi  0B $ jz           \ binary + offset                 char . cpi  0D $ jz           \ binary                          char > cpi  0E $ jz           \ binary greater + offset         char R cpi  0F $ jz           \ output col first                char I cpi  10 $ jz           \ home is 1,1                     char N cpi  11 $ jz           \ insert a null                   char 2 cpi   8 $ jz           \ decimal 2 digits                char 3 cpi   7 $ jz           \ decimal 3 digits                char D cpi   3 $ jnz          \ decimal else unknown command                                                                                                                                  \ (Z3)                                                            0168 lda  64 cpi  8 $ jc          \ test if max columns < 100  7 $:  char 0 m mvi  h inx  b inr   \ insert '000'               8 $:  char 0 m mvi  h inx  b inr   \ insert '00'                      char 0 m mvi                                               a xra                             \ set decimal                9 $:  019B sta                                                   h push                                                          019F h lxi  016C lda              \ set row or col position     a ora  0A $ jz  h dcx             \ in cm template             0A $:  b m mov  m inr                                            1 a mvi  016C sta                 \ set flag                    h pop  1 $ jmp                                                                                                                                                                                                                                                \ (Z3)                                                           0B $:  h push  019D h lxi          \ binary + offset             016C lda  a ora  0C $ jz  h dcx                                0C $:  d ldax  d inx                                             m add  a m mov  h pop                                          0D $:  a xra  a m mov              \ binary                      a inr  9 $ jmp                    \ set mode                   0E $:  d inx  d inx  0D $ jmp      \ skip parameters            0F $:  016B sta  2 $ jmp           \ set col first flag         10 $:  h push  019C h lxi  m inr   \ home co-ords = 1,1          h inx  m inr  h pop  2 $ jmp                                   11 $:  a xra  3 $ jmp              \ insert null                 end-code                                                                                                                                                                                                                                                      \ ZINS                                                          \ Install terminal patch area with Z-System TermCap             code ZINS ( -- )                                                  0109 lhld  h a mov  l ora  7 $ jz       \ exit if bad zenv      b push                                  \ save forth IP         02B d lxi  d dad  m a mov  0124 sta     \ cpu speed MHz                             a xra  0125 sta     \ cpu speed high          6 d lxi  d dad  m a mov  0168 sta     \ number of columns                h inx  m a mov  0169 sta     \ number of rows        04E d lxi  d dad  xchg  0153 h lxi      \ terminal name          0E b mvi  (z2) call  xchg  h inx  h inx                        014F b lxi    m a mov  a ora  2 $ jnz   \ up arrow               5 a mvi  2 $:  b stax                                          b inx  h inx  m a mov  a ora  3 $ jnz   \ down arrow            18 a mvi  3 $:  b stax                                                                                                        \ ZINS                                                            b inx  h inx  m a mov  a ora  4 $ jnz   \ right arrow            4 a mvi  4 $: b stax                                           b inx  h inx  m a mov  a ora  5 $ jnz   \ left arrow            13 a mvi  5 $: b stax                                           h inx  m a mov  01BA sta              \ delay after cls         h inx  m a mov  01A0 sta              \ delay after cm          h inx  m a mov  01CE sta              \ delay after cleol       h inx  xchg                                                     016B h lxi  (z1) call                 \ clear screen            d push                                                          016C d lxi                                                      01A8 h lxi  0 m mvi                   \ zero home               b a mov  6 cpi  6 $ jc                \ if cls too long         5 sui  a c mov  5 b mvi               \ split between ...                                                                     \ ZINS                                                            (z2) call                     \ home sequence and               c b mov  016C 5 + d lxi                                        6 $:  01A2 h lxi  (z2) call    \ cls sequence                    d pop                                                           018B h lxi  (z3) call         \ cursor motion                   01BC h lxi  (z1) call         \ clear-to-EOL                    01C2 h lxi  (z1) call         \ hilight                         01C8 h lxi  (z1) call         \ normal                          016B h lxi  (z1) call         \ video init                      017B h lxi  (z1) call         \ video exit                      01B4 h lxi  (z1) call         \ delete line                     01AE h lxi  (z1) call         \ insert line                     b pop                         \ restore forth IP               7 $:  next  end-code                                           decimal                                                         \ CF 'FID FID 'FNAME SETFNAME .FNAME FILE IN-FILE DTA-FILE      variable cf                                                                                                                     : 'FID ( -- a )  cf @ ;                                         : FID ( -- fid )  'fid @ ;                                      : 'FNAME ( -- a )  'fid cell+ ;                                 : SETFNAME ( a n -- a n' )  16 min  2dup 'fname place ;         : .FNAME ( -- a n )  'fname count type ;                                                                                        warning off                                                     : FILE  create [ 1 cells 16 1+ + ] literal allot  does> cf ! ;  warning on                                                                                                                      \ File handles                                                  file IN-FILE   file DTA-FILE                                                                                                    \ #TERMS TLEN TERMINAL TSIZE TEMP IN-BASE DTA-BASE BUFSIZE      variable #TERMS         \ number of terminals in dta file       variable TLEN           \ length of each term definition        variable TERMINAL       \ terminal selected                                                                                     $1D0 $14F - constant TSIZE    \ size term install area                                                                          \ Storage areas                                                 : TEMP     ( -- adr )  pad 80 + ;       \ temporary storage     : IN-BASE  ( -- adr )  temp 256 + ;     \ target file (2 recs)  : DTA-BASE ( -- adr )  in-base 256 + ;  \ dta file                                                                              : BUFSIZE ( -- u )  sp@ 256 - dta-base - ;                                                                                                                                                                                                                      \ TDATA !STR !VAL                                               \ Get base address for n'th terminal data                       : TDATA ( n -- adr )                                              tlen @  *  dta-base +  4 + ;                                                                                                  \ Place string from terminal data at offset to adr              : !STR ( adr offs -- )                                            terminal @  tdata  + count rot place ;                                                                                        \ Place value from terminal data at offset to adr               : !VAL ( adr offs -- )                                            terminal @  tdata  + @ swap ! ;                                                                                                                                                                                                                                                                                               \ TNAME TINIT TEXIT TCM TCLS THIL TNOR TINS                     hex                                                             \ Store terminal data strings                                   : TNAME ( -- ) 153  0 !str ;    \ terminal name                 : TINIT ( -- ) 16B 16 !str ;    \ term init                     : TEXIT ( -- ) 17B 26 !str ;    \ term exit                     : TCM   ( -- ) 18B 36 !str ;    \ cursor motion template        : TCLS  ( -- ) 1A2 4D !str ;    \ clear screen                  : THOM  ( -- ) 1A8 53 !str ;    \ home cursor                   : THIL  ( -- ) 1C2 5B !str ;    \ hilight video                 : TNOR  ( -- ) 1C8 61 !str ;    \ normal video                  : TEOL  ( -- ) 1BC 69 !str ;    \ clear to end-of-line          : TINS  ( -- ) 1AE 6F !str ;    \ insert line                   : TDEL  ( -- ) 1B4 75 !str ;    \ delete line                   decimal                                                                                                                         \ TBIN TPOS TOFFS TDCM TDCLS TDEOL TCR                          hex                                                             \ Store terminal data values                                    : TBIN  ( -- ) 19B 46 !val ;    \ binary mode                   ( note: TBIN must be executed before TOFFS )                    : TPOS  ( -- ) 19E 47 !val ;    \ col row pos                   : TOFFS ( -- ) 19C 49 !val ;    \ col row offset                : TDCM  ( -- ) 1A0 4B !val ;    \ cm delay                      : TDCLS ( -- ) 1BA 59 !val ;    \ cls delay                     : TDEOL ( -- ) 1CE 67 !val ;    \ eol delay                     : TCR   ( -- ) 168 7B !val ;    \ # cols rows                   decimal                                                                                                                                                                                                                                                                                                                         \ SWAP-OUT SWAP-IN MOVE-DATA                                    \ Save memory data before install                               : SWAP-OUT ( -- )                                                 $124 c@  temp c!  $14F  temp 1+  tsize move ;                                                                                 \ Restore memory data after install                             : SWAP-IN ( -- )                                                  temp c@  $124 c!  temp 1+  $14F  tsize move ;                                                                                 \ Move memory data to in-file                                   : MOVE-DATA ( -- )                                                $14F in-base $4F + tsize move  $124 c@  in-base $24 + c! ;                                                                                                                                                                                                                                                                    \ CMD                                                           \ Parse the CP/M command line for the n'th blank delimited      \ parameter.  Return the address and length and a true flag if  \ found, otherwise return false.                                : CMD ( n -- adr u -1 | 0 )                                       0 0 rot  128 count  rot 0 ?do                                     2swap 2drop                                                     bl skip  2dup bl scan                                           rot over - -rot                                               loop 2drop                                                      dup if  -1  else  and  then ;                                                                                                                                                                                                                                                                                                                                                                 \ HELP ARG FILE-ERROR                                           \ Show help and exit                                            : HELP ( -- )                                                     cr ." Installer for DX-Forth or compiled applications." cr      cr ." Use: INSTALL filename[.com] [termfile[.dta]]" abort ;                                                                   \ Get argument - if none show help                              : ARG ( n -- adr u )                                              cmd 0= if ( none ) help then ;                                                                                                \ Encountered file error, display msg, filename then quit       : FILE-ERROR ( adr u -- )                                         cr type  .fname  abort ;                                                                                                                                                                                                                                      \ READ-TARGET                                                   \ Read first 2 records of target file into memory               : READ-TARGET ( -- )                                              in-file                               \ select filehandle       1 arg                                 \ get first filename      s" COM" +ext                          \ append filetype         setfname r/w open-file                \ open target file        if S" Error opening: " file-error then  'fid !                  in-base 256  2dup erase               \ clear buffer            fid read-file drop                    \ read 2 records          256 =                                 \ check if got 2          in-base 17 + @  18051 =               \ check DX-Forth id.      and 0= if                                                         s" Not a DX-Forth application: " file-error                   then ;                                                                                                                        \ READ-DTA                                                      \ Read DTA file into memory                                     : READ-DTA ( -- )                                                 dta-file                              \ select filehandle       2 cmd                                 \ if second filename      if    s" DTA" +ext                    \ append filetype         else  s" INSTALL.DTA"  then           \ else use default        setfname r/o open-file                \ open DTA file           if  S" Error opening: " file-error  then  'fid !                dta-base bufsize  2dup erase          \ buffer                  fid read-file 2drop                   \ read DTA file           fid close-file drop                   \ close file              dta-base  dup @ #terms !              \ get # terminals         2+ @ tlen ! ;                         \ get term data length                                                                                                                                  \ WRITE-TARGET CLOSE-TARGET CLS                                 \ Write data to file                                            : WRITE-TARGET ( -- )                                             in-file                       \ select filehandle               0. fid reposition-file drop   \ reset filepointer               in-base 256 fid write-file    \ write 2 recs                    if s" Error writing: " file-error then ;                                                                                      \ Close target file                                             : CLOSE-TARGET ( -- )                                             in-file fid close-file                                          if s" Error closing: " file-error then ;                                                                                      \ Simple clear screen                                           : CLS ( -- )  25 0 do cr loop ;                                                                                                 \ SELECT INVALID ANYKEY                                         \ Select number in range n1 to n2.  Return n3 and true | false  : SELECT ( n1 n2 -- n3 -1 | 0 )                                   cr ." Select: "  pad 10 accept cr     \ get input string        ?dup if                                                           pad swap number? if                 \ convert to number           drop  dup  2swap  1+ within       \ check range                 dup 0= if  and  then  exit                                    then                                                          then  2drop  0 ;                                                                                                              \ Bad or empty input                                            : INVALID ( -- )  beep cr ." Invalid or nothing entered" cr ;                                                                   \ Wait for a keypress                                           : ANYKEY ( -- )  cr ." Press any key to continue "  key drop ;  \ (ROWS) .TERMINALS                                             \ Display terminal names including Z-System TCAP                : (ROWS) ( -- n )  #terms @ 1+  3 /mod  swap if 1+ then  ;                                                                      : .TERMINALS  ( -- )                                              cr  (rows) 0 ?do                                                  3 0 ?do                                                           i  (rows)  *  j +                                               dup  #terms @ 1+ <                                              if  dup 1+ 2 .r  space  dup #terms @ <                            if  tdata count                                                 else  drop s" Z-SYSTEM TERMCAP"  then                           dup >r  type  23 r> - spaces                                  else  drop  then                                              loop  cr                                                      loop ;                                                        \ !TERM                                                         \ Install selected terminal                                     : !TERM ( -- )                                                    swap-out  terminal @  #terms @  =  if                             zenv if  zins  else  cr ." Z-SYSTEM not present" cr  then     else                                                              tname tinit texit tcm tcls thom thil tnor teol tins tdel        tbin tpos toffs tdcm tdcls tdeol tcr                          then                                                            move-data  swap-in ;                                                                                                                                                                                                                                                                                                                                                                                                                                          \ TERM-SELECT                                                   \ Edit terminal type                                            : TERM-SELECT ( -- )                                              cls  ." Terminal is currently "                                 in-base 83 +  count  -trailing type                             ." .  Change? "  y/n  if                                          cr  .terminals                          \ list terminals        1 #terms @ 1+ select  if                \ select                  1- terminal !  !term                  \ store it              else  invalid  then                                             anykey                                                        then ;                                                                                                                                                                                                                                                                                                                        \ CPU-SPEED                                                     \ Edit CPU speed                                                : CPU-SPEED ( -- )                                                cls  ." CPU speed is currently "                                in-base 36 +  @ u.                                              ." MHz.  Change? "  y/n  if                                       cr ." Enter new value (1-8191) "                                1 8191 select  if                                                 in-base 36 +  !                                               else  invalid  then                                             anykey                                                        then ;                                                                                                                                                                                                                                                                                                                        \ DELAY                                                         \ Change the delay specified by the offset and string           : DELAY ( offs adr u -- )                                         cr cr  type ."  delay is currently "                            dup  in-base +  c@ .                                            ." mS.  Change? " y/n if                                          cr ." Enter new value (0-255) "                                 0 255 select  if                                                  swap  in-base +  c!                                           else  drop invalid  then                                        anykey                                                        then ;                                                                                                                                                                                                                                                                                                                        \ DELAY-TIMES                                                   \ Edit delay times                                              : DELAY-TIMES ( -- )                                              cls                                                             160  s" Cursor Motion"  delay                                   186  s" Clear Screen"  delay                                    206  s" Clear to End-of-Line"  delay ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        \ ARROW                                                         \ Change the arrow key specified by the offset and string       : ARROW ( offs adr u -- )                                         cr cr  type ."  arrow key code is currently "                   dup  in-base +  c@                                              hex  s>d <# # # #> type  decimal                                ."  hex.  Change? " y/n if                                        cr ." Enter new value in hexadecimal (00-FF) "                  hex  0 255 select  decimal  if                                    swap  in-base +  c!                                           else  drop invalid  then                                        anykey                                                        then ;                                                                                                                                                                                                                                                        \ WS-KEYS ARROW-KEYS                                            \ Store default WordStar arrow key codes                        : WS-KEYS ( -- )                                                  $18051304.  in-base 79 +  2! ;                                                                                                \ Edit arrow key codes                                          : ARROW-KEYS  ( -- )                                              cls  ." Use default WordStar arrow keys? "  y/n  if               ws-keys  cr anykey                                            else                                                              79  s" UP"     arrow                                            80  s" DOWN"   arrow                                            81  s" RIGHT"  arrow                                            82  s" LEFT"   arrow                                          then ;                                                                                                                        \ NOBOOT                                                        \ Change the warmboot option                                    : NOBOOT ( -- )                                                   cls  ." NO WARMBOOT option is currently "                       in-base 16 +  c@  if ." ON"  else ." OFF"  then                 ." .  Change? "  y/n  if                                          in-base 16 +  dup c@  0=  swap c!                               cr anykey                                                     then ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                        \ SAVE-SETUP .MENU                                              \ Save setup to disk and exit                                   : SAVE-SETUP ( -- )                                               beep cr ." Save current setup to disk? " y/n if                   write-target close-target 0 return                            then ;                                                                                                                        \ Display main menu                                             : .MENU ( -- )                                                    cr ."    1. Terminal selection"                                 cr ."    2. CPU speed"                                          cr ."    3. Time delays"                                        cr ."    4. Arrow key codes"                                    cr ."    5. No Warmboot option"                                 cr ."    6. Save changes and exit" ;                                                                                          \ MENU                                                          \ Main menu loop. Exit if invalid option or nothing is entered. : MENU ( -- )                                                     begin                                                             .menu  cr  1 6 select  if                                         case  1 of  term-select  endof                                        2 of  cpu-speed    endof                                        3 of  delay-times  endof                                        4 of  arrow-keys   endof                                        5 of  noboot       endof                                        6 of  save-setup   endof                                  endcase                                                       else  exit  then  cls                                         again ;                                                                                                                                                                                       \ INSTALL                                                       \ Main                                                          : INSTALL ( -- )                                                  cls title                                                       read-target                                                     read-dta                                                        menu                                                          ;                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                                               