Forth demo

This is the source to the DX-Forth installer program.

INSTALL customises the DX-Forth compiler and turnkey
applications for a variety of video terminals.  Also,
the CPU speed, terminal delay times, arrow key codes
and no-warmboot option may be adjusted.

empty  forth definitions  decimal
application

: TITLE ( -- )  ." DX-INSTALL 2.2" cr ;

cr ." loading " title  2 #screens 1- thru

cr ." Save to disk? " y/n [if]
  turnkey install INSTALL
[then]

1 fload ZINS.SCR

: CLS ( -- )  25 0 do cr loop ;  \ simple clear screen

: EMITS ( n char -- )  swap 0 ?do dup emit loop drop ;

: +PLACE ( a u a2 -- )  count +string swap 1- c! ;

: ?PLACE ( a u a2 -- )  over if place end  drop 2drop ;

: CHANGE? ( -- f )  ."  Change? " y/n ;

: .HB ( u -- )  2 (h.n)  [char] $ hold  #> type space ;

: .ONOFF ( flag -- )  if ." ON " end  ." OFF " ;

integer cf ( -- a )  \ current file handle

-? : HANDLE  create  max-path 1+ cell+ allot  does> to cf ;

: !FNAME ( a n -- )  max-path min  cf cell+ place ;
: @FNAME ( -- a n )  cf cell+ count ;

\ File handles
handle IN-FILE   handle DTA-FILE

\ Show help and exit
: HELP ( -- )
  cr ." Installer for DX-Forth and applications" cr
  cr ." Use: INSTALL filename[.com] [termfile[.dta]]"  abort ;

\ Encountered file error, display msg, filename then quit
: FERR ( ? ior a u -- ? )  rot 0= if  2drop  end
  cr ." File error: "  type  ."  - "  @fname type  abort ;

: FOPEN  ( a n fam -- )  open-file  s" open"  ferr  cf ! ;
: FCREAT ( a n fam -- )  create-file  s" create"  ferr  cf ! ;
: FREAD  ( a n -- n' )  cf @ read-file  s" read"  ferr ;
: FWRITE ( a n -- )  cf @ write-file  s" write"  ferr ;
: FSEEK  ( ud -- )  cf @ reposition-file  s" position"  ferr ;
: FCLOSE ( -- )  cf @ close-file  s" close"  ferr ;

\ 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.
: ARG ( n -- adr len -1 | 0 )
  >r  0 0  cmdtail  r> 0 ?do
    2nip
    bl skip  2dup bl scan
    rot over - -rot
  loop 2drop
  dup if  -1  end  and ;

integer #TERMS          \ number of terminals in DTA file
integer TERM            \ working terminal#
$95  constant TLEN      \ length of each term definition
$100 constant CHUNK     \ in-file chunk to get
20   constant ISIZ      \ size input buffer / terminal name
200  constant TMAX      \ max #terminals

\ Storage areas allocated at run-time
integer IN-BASE  ( -- a )  \ in-file
integer DTA-BASE ( -- a )  \ dta-file
integer TBUF     ( -- a )  \ temp terminal buffer
integer SBUF     ( -- a )  \ swap/work buffer
integer IBUF     ( -- a )  \ console input
integer XBUF     ( -- a )  \ terminal index

\ Convert logical adr to target adr
: >TARGET ( a -- a' )  $100 - in-base + ;

\ Get input from console
: ENTER ( -- adr len )  ibuf dup isiz accept -blanks ;

\ First terminal in DTA
: 0TERM ( -- a )  dta-base 2 cells + ;

\ DTA end + 1
: DTA-END ( -- a )  0term  #terms tlen * + ;

\ Get adr of terminal n
: >DTA ( n -- a )  cells xbuf + @ ;

\ Get adr of selected terminal
: DBUF ( -- a )  term >dta ;

\ Get name of terminal n
: NAME ( n -- adr len )  >dta count ;

\ Install terminal data at offs to target at adr
: SET.S ( a ofs -- )  dbuf +  count rot  >target place ;
: SET.W ( a ofs -- )  dbuf +  @ swap  >target ! ;
: SET.B ( a ofs -- )  dbuf +  c@ swap  >target c! ;

hex
110 constant 'WBT    \ warm boot
124 constant 'SPD    \ cpu speed
14E constant 'BKSP   \ backspace
14F constant 'UP     \ cursor keys
150 constant 'DN     \
151 constant 'RT     \
152 constant 'LFT    \
153 constant 'TNAME  \ terminal name
1A0 constant 'TDCM   \ terminal delays
1BA constant 'TDCLS  \
1CE constant 'TDEOL  \
decimal

hex
: TNAME ( -- ) 'tname  0 set.s ;  \ terminal name
: TINIT ( -- ) 16B    16 set.s ;  \ term init
: TEXIT ( -- ) 17B    26 set.s ;  \ term exit
: TCM   ( -- ) 18B    36 set.s ;  \ cursor motion template
: TBIN  ( -- ) 19B    46 set.b ;  \ binary mode
: TPOS  ( -- ) 19E    47 set.w ;  \ col row pos
: TOFFS ( -- ) 19C    49 set.w ;  \ col row offset
: TDCM  ( -- ) 'tdcm  4B set.w ;  \ cm delay
: TCLS  ( -- ) 1A2    4D set.s ;  \ clear screen
: THOM  ( -- ) 1A8    53 set.s ;  \ home cursor
: TDCLS ( -- ) 'tdcls 59 set.w ;  \ cls delay
decimal

hex
: THIL  ( -- ) 1C2    5B set.s ;  \ hilight video
: TNOR  ( -- ) 1C8    61 set.s ;  \ normal video
: TDEOL ( -- ) 'tdeol 67 set.w ;  \ eol delay
: TEOL  ( -- ) 1BC    69 set.s ;  \ clear to end-of-line
: TINS  ( -- ) 1AE    6F set.s ;  \ insert line
: TDEL  ( -- ) 1B4    75 set.s ;  \ delete line
: TCR   ( -- ) 168    7B set.w ;  \ # cols rows
decimal

\ Initialize target with terminal data
: !TDATA ( -- )
  tname tinit texit tcm tbin tpos toffs tdcm tcls thom
  tdcls thil tnor tdeol teol tins tdel tcr ;

\ ZINS install area excluding speed
'up  $100 chunk +  over - 2constant ZDATA ( -- a u )

: SWAP-OUT ( -- )
  sbuf  'spd @ over !  cell+ zdata rot swap cmove ;

: SWAP-IN ( -- )
  sbuf  dup @ 'spd !  cell+ zdata cmove ;

: ZINSTALL ( -- )
  swap-out                         \ save existing
  zins                             \ install from Termcap
  'spd  dup @  swap >target !      \ move speed
  zdata  over >target  swap cmove  \ move zdata
  swap-in ;                        \ restore existing

\ Read first chunk of target file into memory
: OPEN-TARGET ( -- )
  in-file                               \ select filehandle
  1 arg  0= if help then                \ get first filename
  s" COM" +ext  !fname                  \ append filetype
  @fname r/w fopen                      \ open target file
  chunk reserve to in-base              \ allot buffer
  in-base chunk fread ( u)              \ read target file
  chunk -                               \ check size
  $111 >target @ $4683 -  or            \ check DX-Forth id.
  s" not a DX-Forth application"  ferr ;

\ Read DTA file into memory
: READ-DTA ( -- )
  dta-file                              \ select filehandle
  2 arg                                 \ if second filename
  if    s" DTA" +ext                    \ append filetype
  else  s" INSTALL.DTA"  then  !fname   \ else use default
  @fname r/w fopen                      \ open DTA file
  pad 256 + to dta-base                 \ assign buffer
  dta-base unused fread drop            \ read DTA file
  fclose                                \ close
  dta-base  dup @ to #terms             \ get #terminals
  cell+ @  tlen -                       \ check DTA id.
  s" not a TPascal terminal file"  ferr ;

: CLOSE-TARGET ( -- )  in-file  fclose ;

: SAVE-TARGET ( -- )  \ update target file
  in-file  0. fseek  in-base chunk fwrite ;

variable ALTERED  \ DTA changed

: SAVE-DTA ( -- )  \ overwrite DTA file
  altered @ if
    dta-file  @fname r/w fcreat
    dta-base 2 cells fwrite ( hdr)
    xbuf  #terms 0 ?do  dup @ tlen fwrite  cell+  loop drop
    fclose
  then ;

\ Bubblesort addr/cells
defer PRECEDES ( x1 x2 -- f )  \ comparison

: SORT ( adr siz -- )
  begin dup while 1-
    2dup cells bounds ?do
      i 2@ precedes if  i 2@ swap i 2!  altered on  then
    1 cells +loop
  repeat 2drop ;

\ Compare counted strings
: $COMP ( a1 a2 -- f )
  >r  count  r> count  caps compare  0< ;

' $comp is precedes

\ Sort terminals by name
: SORT-TERMS ( -- )  xbuf #terms sort ;

\ Create list of pointers to each terminal definition
: IDX ( -- )
  xbuf  dta-end 0term  ?do  i over !  cell+  tlen +loop  drop ;

\ Index & sort terminals
: CATALOG ( -- )
  #terms tmax > if  cr ." Too many terminals" abort  then
  idx  sort-terms ;

\ Select number in range n1 to n2.  Return n3 true | false
: #SELECT ( n1 n2 adr len -- n3 -1 | 0 )
  cr ." Enter"  type  ." : "  enter  cr
  number? if
    d>s  dup 2swap between  dup if end
  then  2drop 0 ;

: SELECT ( n1 n2 -- n3 -1 | 0 )  s" "  #select ;

: ANYKEY ( -- )  cr ." Press any key to continue "  key drop ;

: INVALID ( -- )  cr ." Invalid or nothing entered" cr ;

\ Edit CPU speed
: CPU-SPEED ( -- )
  cls  ." CPU speed is "
  'spd >target  dup @ u. ." MHz "  change? if
    1 8191  s"  (1-8191)"  #select if
      over !
    else  invalid  then  anykey
  then  drop ;

\ Change delay specified by adr & string
: CHG-DELAY ( a adr len -- )
  cr cr  type ."  delay "
  >target  dup c@ . ." mS "  change? if
    0 255  s"  (0-255)"  #select if
      over c!
    else  invalid  then  anykey
  then  drop ;

\ Change delay times
: DELAY-TIMES ( -- )  cls
  'tdcm  s" Cursor Motion"  chg-delay
  'tdcls s" Clear Screen"  chg-delay
  'tdeol s" Clear to End-of-Line"  chg-delay ;

\ Convert offset to adr in terminal buffer
: >BUF ( n -- a )  tbuf + ;

: @STR ( ofs -- a u )  >buf count ;
: !STR ( a u ofs -- )  >buf place ;
: @BYT ( ofs -- c )    >buf c@ ;
: !BYT ( c ofs -- )    >buf c! ;

: CMT  ( -- a )    $36 >buf ;  \ cursor motion template
: #CMT ( -- ofs )  $36 @byt ;  \ current size/offset
: BIN? ( -- f )    $46 @byt ;  \ binary?
: COL? ( -- f )    $92 @byt ;  \ column first?
: #ASC ( -- n )    $93 @byt ;  \ ASCII digits for row/col

: RC$ ( -- a n )  \ row/col string
  bin? if  s" \00"  end  s" 000" drop #asc ;

: !RCOFS ( cofs rofs -- )  \ store template offsets
  col? if  swap  then  $47 !byt  $48 !byt ;

: !CMT ( -- )  \ init cursor motion template
  $80 @str  cmt  place          \ lead-in
  rc$       cmt +place   #cmt   \ col, offs
  $86 @str  cmt +place          \ between
  rc$       cmt +place   #cmt   \ row, offs
  $8C @str  cmt +place          \ after
  !rcofs ;                      \ row/col offsets

8 constant <BS>   13 constant <CR>

: VISIBLE? ( c -- flag )  bl 127 within ;

: .CHR ( c -- )
  10   of ." <LF> "   end   <cr> of ." <CR> "   end
  27   of ." <ESC> "  end   bl   of ." <SP> "   end
  127  of ." <DEL> "  end
  dup bl < if  ." Ctrl-"  [char] @ +  emit  space  end
  dup visible? if  emit  space  end
  .hb ;

: .DEC ( adr len -- )
  ."  ("  begin  dup while  over c@ 0 .r  1 /string
  dup while  space  repeat then  2drop  ." ) " ;

: .STR ( offs -- )
  @str  dup if
    2dup  bounds ?do  i c@ .chr  loop  .dec
  end  2drop  ." <none> " ;

variable #DIGIT  \ #digits entered

: /FIELD ( n -- 0 )
  drop  #digit @  begin  dup while
    <bs> emit  space  <bs> emit  1-
  repeat  decimal  #digit off ;

: .VIS ( c -- )
  dup visible? if  emit  1 #digit +!  end  drop ;

: ?$ ( n c -- n' c' )
  [char] $ of  /field  hex  [char] $ .vis  key  then ;

: +DIGIT ( u c -- u' err )
  base @ >digit if  swap base @ * +  dup 255 u>  end
  drop true ;

: BUILD# ( c -- n c2 )  \ CR or BL exits
  decimal  #digit off  0 swap  begin
    dup bl <>  over <cr> <>  and while
    ?$  upcase  dup .vis  +digit if  beep  /field  then  key
  repeat  decimal ;

: GET# ( -- n )  key build# drop ;

variable LEN   integer MAXCHR

: ROOM? ( -- f )  len @  maxchr <  ;

: +CHR ( c -- )  ibuf len @ +  c!  1 len +! ;

: DO-NUM ( c -- )  \ CR or BL BL exits
  begin  room? while
    build#  swap  #digit @ if  +chr  else  drop  then
    <cr> = if end  space  key  bl of <cr> then
  repeat  drop ;

: DO-ASC ( c -- )
  begin  dup <cr> -  room?  and while
    dup .chr  +chr  key
  repeat  drop ;

: DIGIT? ( c -- f )
  dup [char] $ =  swap [char] 0 [char] 9 between  or ;

: GET$ ( maxlen -- adr len )
  to maxchr  len off
  key  dup digit? if  do-num  else  do-asc  then
  ibuf len @ ;

: SET$ ( ofs size -- )
  over .str  change?
  if  cr ." : "  get$  rot !str  end  2drop ;

: SET# ( ofs -- )
  dup @byt .  change? if ." : "  get#  swap !byt  end  drop ;

: SETF ( ofs -- 0|1 )
  dup @byt  dup .yn  change? if  0= 1 and  then  dup rot !byt ;

\ Set offset2 flag according to string offset1
: !FLAG ( ofs1 ofs2 -- )  >r  @byt  0<> 1 and  r> !byt ;

: ?NAME ( -- )
  0 0  begin
    2drop
    cr ." Terminal type: "  0 @str type  space
    isiz  dup [char] _ emits  <bs> emits
    enter  dup  0 @byt  or
  until  tbuf ?place ;

: ?INIT ( -- )
  cr ." Term INIT string: "  $16  dup 15 set$  $7D !flag ;

: ?RESET ( -- )
  cr ." Term RESET string: "  $26  dup 15 set$  $7E !flag ;

: ?LEADIN ( -- )
  cr ." CURSOR LEAD-IN command: "  $80 5 set$ ;

: ?BETWEEN ( -- )
  cr ." CURSOR command BETWEEN row/col: "  $86 5 set$ ;

: ?AFTER ( -- )
  cr ." CURSOR command AFTER row/col: "  $8C 5 set$ ;

: ?COLFIRST ( -- )
  cr ." Column first? "  $92 setf drop ;

: ?ROFS ( -- )  cr ." OFFSET to add to ROW: "  $4A set# ;

: ?COFS ( -- )  cr ." OFFSET to add to COL: "  $49 set# ;

: ?DIGITS ( -- n )
  cr ." ASCII digits (2 or 3): "
  #asc  dup .  change?  0= if end  ." : "
  begin  drop  key  [char] 0 -  dup 2 3 between not
  while  beep  repeat  dup . ;

: ?BINARY ( -- )
  cr ." Binary address? "  $46 setf
  0 of  ?digits  then  $93 !byt ;

: ?CLS ( -- )  cr ." CLEAR SCREEN command: "  $4D 5 set$ ;

: ?HOM ( -- )
  cr ." Does CLEAR SCREEN also HOME cursor? "
  $53  dup @byt  dup not .yn  change?  over 0<> xor if
    drop  cr ." HOME command: "  5 set$
  end  if  0 over !byt  then  drop ;

: ?DEL ( -- )  cr ." DELETE LINE command: "  $75 5 set$ ;

: ?INS ( -- )  cr ." INSERT LINE command: "  $6F 5 set$ ;

: ?EOL ( -- )  cr ." ERASE TO EOL command: "  $69 5 set$ ;

: ?BOLD ( -- )  cr ." BOLD VIDEO command: "  $5B 5 set$ ;

: ?NORM ( -- )  cr ." NORMAL VIDEO command: "  $61 5 set$ ;

: ?ROWS ( -- )  cr ." Number of screen rows: "  $7C set# ;

: ?COLS ( -- )  cr ." Number of screen cols: "  $7B set# ;

: ?DCUR ( -- )
  cr ." Delay after CURSOR ADDRESS: "  $4B set# ;

: ?DCLS ( -- )
  cr ." Delay after CLEAR, DELETE, INSERT: "  $59 set# ;

: ?DEOL ( -- )
  cr ." Delay after ERASE-EOL, BOLD, NORMAL: "  $67 set# ;

\ Modify terminal definition in temp buffer
: MODIFY ( -- )  cls
  ?name ?init ?reset ?leadin ?between ?after ?colfirst
  ?rofs ?cofs ?binary ?cls ?hom ?del ?ins ?eol
  ?bold ?norm ?rows ?cols ?dcur ?dcls ?deol
  !cmt
  0 $94 !byt ;                  \ TINST always clears?

\ Bump #terms & update DTA header
: +TERM ( n -- )
   #terms +  dup to #terms  dta-base !
   catalog  altered on ;

: GET-TERM ( -- )  \ copy term in DTA to buffer
  dbuf tbuf tlen cmove ;

: INS-TERM ( -- )  \ insert a terminal
  tbuf dta-end tlen cmove  1 +term ;

: DEL-TERM ( -- )  \ delete selected terminal
  dbuf tlen +  dta-end over -  dbuf swap cmove  -1 +term ;

: SAVE-MOD? ( -- f )
  cr ." Save modifications? "  y/n ;

: INIT-TERM ( -- )  \ defaults
  tbuf tlen erase
  1  $46 !byt  1  $92 !byt     \ binary, column first
  24 $7C !byt  80 $7B !byt ;   \ #rows, #columns

: COPY-TERM ( -- )
  1 #terms s"  terminal # to copy" #select if
    1-  dup to term  name  cr type
    ."   Are you sure? "  y/n if  get-term  then  cr
  end  invalid  anykey ;

: ?NEW-TERM ( -- )
  cr ." New definition? "  y/n  0= if end
  init-term  copy-term  modify  save-mod? if  ins-term  then ;

: ?DELETE ( -- )
  #terms 0= if  cr ." Nothing to delete" cr  end
  1 #terms s"  terminal # to delete" #select if
    1-  dup to term  name  cr type
    ."   Are you sure? "  y/n if  del-term  then  cr
  end  invalid  anykey ;

\ Modify selected terminal
: ?MODIFY ( -- )
  cr ." Modify definition? "  y/n  0= if end
  get-term  modify  save-mod? if  del-term  ins-term  then ;

\ Install selected terminal
: !TERM ( -- )
  cr ." Terminal selected: "  term name type cr
  ?modify !tdata cpu-speed ;

\ Install from Z-System TCAP
: !ZTCAP ( -- )  zenv if  zinstall  cpu-speed  end
  cr ." Z-System not present" cr  anykey  unnest unnest ;

: DO-TERM ( -- )
  term
  #terms    of  !ztcap     end
  #terms 1+ of  ?new-term  end
  #terms 2+ of  ?delete    end
  drop  !term ;

10 constant #LINES  \ lines to display

: VALID? ( n -- n f )  dup #terms 1+ < ;

: ?SPACES ( -- )  out @  ?dup if  25 swap - spaces  then ;

: .LINE ( n adr len -- )  ?spaces  rot 1+  3 .r  space type ;

: .TERM ( n -- )
  dup #terms < if  dup name .line  end
  dup #terms = if  s" Z-System Termcap" .line  end
  drop ;

: .TERMS ( n -- )  \ one page of terminals
  cr  #lines 0 do
    valid? if  cr  then
    dup .term  dup #lines + .term  1+
  loop drop  cr ;

: .OPTIONS ( -- )  cr
  #terms 1+  s" None of the above"    .line
  #terms 2+  s" Delete a definition"  .line  cr ;

\ Display terminals and select
: SEL-TERM ( -- )
  0  begin  cls
    dup .terms  .options
    1 #terms 3 + select if ( exec)
      1- to term  do-term  cr  #lines 2* -  true
    else
      invalid  cr ." ESC to exit, other key for more "
      key  27 ( Esc) -
    then
  while
    #lines 2* +  valid? and  \ looping
  repeat drop ;

: CHANGE-TERM ( -- )
  cls  ." Terminal is: "
  'tname >target count type
  cr anykey  sel-term ;

\ Change key specified by adr & string
: CHG-KEY ( a adr len -- )
  cr cr  type ."  code "
  >target  dup c@  .hb  change? if
    cr ." Enter new value in hex"
    0 $FF  s"  (00-FF)"  hex #select decimal  if
      over c!
    else  invalid  then  anykey
  then  drop ;

\ Change key codes
: KEY-CODES ( -- )
  cls  ." Use default backspace & arrow keys? "  y/n if
    $08         'bksp >target c!
    $18051304.  'up   >target 2!
  end
  'bksp s" BACKSPACE"    chg-key
  'up   s" UP    arrow"  chg-key
  'dn   s" DOWN  arrow"  chg-key
  'rt   s" RIGHT arrow"  chg-key
  'lft  s" LEFT  arrow"  chg-key
;

\ Change the warmboot option
: NOBOOT ( -- )
  cls  ." NO WARMBOOT is "
  'wbt >target ( a)  dup c@
  dup .onoff  ?dup if  ." ("  0 .r  ."  pages)"  then
  change? if
    0 32  s"  CCP pages (0-32)"  #select if
      over c!
    else  invalid  then  anykey
  then  drop ;

\ Save to disk and exit
: SAVE-SETUP ( -- )
  beep  cr ." Save current setup to disk? "  y/n if
    save-target  save-dta  unnest ( exit menu loop)
  then ;

\ Display main menu
: .MENU ( -- )
  cr ."    1. Terminal selection"
  cr ."    2. CPU speed"
  cr ."    3. Time delays"
  cr ."    4. Key codes"
  cr ."    5. No Warmboot"
  cr ."    6. Save changes and exit" ;

\ Main menu loop. Exit if invalid option or nothing entered.
: MENU ( -- )
  begin  .menu cr  1 6 select while
    cond  1 of  change-term  else
          2 of  cpu-speed    else
          3 of  delay-times  else
          4 of  key-codes    else
          5 of  noboot       else
          6 of  save-setup   else
          drop
    cont  cls
  repeat ;

: INIT ( -- )
  altered off                 \ clear
  isiz       reserve to ibuf  \ console input
  tlen       reserve to tbuf  \ temp terminal buffer
  chunk      reserve to sbuf  \ swap/work buffer
  tmax cells reserve to xbuf  \ terminal index
;

\ Main
: INSTALL ( -- )
  cls title  init
  open-target  read-dta  catalog
  menu
  close-target
;