home *** CD-ROM | disk | FTP | other *** search
/ Power-Programmierung / CD1.mdf / forth / compiler / fpc / source / exec.seq < prev    next >
Text File  |  1991-04-10  |  10KB  |  251 lines
  1. \ EXEC.SEQ      A utility for calling DOS from Forth.   by Tom Zimmer
  2.  
  3. only forth also hidden also definitions
  4.  
  5. : fpc>emm       ( --- )      \ move FPC to expanded memory
  6.                 true emm-status !       \ init flag to failed, will reset
  7.                                         \ if all goes ok
  8.                 emm-present? 0= ?exit           \ is there any EMM in system?
  9.                 emm-page-frame emm-status @ ?exit       \ set the page frame
  10.                 emm-get-version emm-status @ ?exit      \ get the EMM version
  11.                 255 and $30 <                           \ stop if OLD
  12.                 if      emm-status on exit
  13.                 then
  14.                 ?cs: emmpars @ + emmparst !             \ set start of saved
  15.                 #pars @ emmpars @ - u2/ $200 / 1+       \ calc pages needed
  16.                 #fpcpages !                             \ set pages needed
  17.                 emm-avail-pages emm-status @ ?exit      \ get available EMM
  18.                 #fpcpages @ <                           \ if not enough memory
  19.                 if      emm-status on exit
  20.                 then
  21.                 #fpcpages @ emm-alloc-pages emmhndl !   \ allocate pages
  22.                 emm-status @ ?exit                      \ leave if error
  23.                 #fpcpages @ 0                           \ move FPC to EMM
  24.                 ?do     i 0 emmhndl @ emm-map-pages     \ get page
  25.                         emm-status @ ?leave             \ leave on error
  26.                         emmparst @ I $400 * + 0         \ source of move
  27.                         ?emm: 0 16384 cmovel            \ move the page to EMM
  28.                 loop    ;
  29.  
  30. \ the handle EXTHNDL is located in the file EMMEXEC.SEQ
  31.  
  32. : fpc>disk      ( --- )      \ move FPC to a disk file
  33.                 true dsk-status !                       \ init to failed
  34.                 ['] 0= save!> pathset                   \ disable pathset
  35.                 exthndl hcreate                         \ make the file
  36.                 restore> pathset                        \ restore it
  37.                 ?exit                                   \ leave if error
  38.                 ?cs: emmpars @ + emmparst !             \ set start of saved
  39.                 #pars @ emmpars @ - u2/ $200 / 1+       \ calc pages needed
  40.                 #fpcpages !                             \ set pages needed
  41.                 dsk-status off                          \ reset error status
  42.                 #fpcpages @ 0                           \ move FPC to EMM
  43.                 ?do     dsk-status @ ?leave             \ leave on error
  44.                         0 16384                         \ source addr & len
  45.                         exthndl                         \ file handle
  46.                         emmparst @ I $400 * +           \ source seg of move
  47.                         exhwrite                        \ move page to file
  48.                         16384 - dsk-status !            \ set status
  49.                 loop    dsk-status @                    \ if error occured
  50.                 if      exthndl hdelete drop            \ then delete file
  51.                 then    ;
  52.  
  53. : fpc>out       ( -- )          \ try to flush F-PC out of memory
  54.                 emm-present? use-emm @ and
  55.                 if      fpc>emm
  56.                 else    emm-status on
  57.                         use-disk @
  58.                         if      fpc>disk
  59.                         else    dsk-status on
  60.                         then
  61.                 then    ;
  62.  
  63. : initcmdpath   ( --- )         \ Initialize the Command path
  64.                 defers initstuff
  65.                 comspec@ comspec$ cmdpath $>handle ;
  66.  
  67. ' initcmdpath is initstuff      \ Put into initialization chain.
  68.  
  69. : $sys          ( countedstring --- f1 ) \ spawn a shell
  70.                 emmsysend paragraph emmpars !  \ set needed paragraphs
  71.                 exec$      $100 erase
  72.                 exec.param $10  erase
  73.                 dup c@
  74.         if      count tuck exec$ 4 + swap cmove
  75.                 " /c " exec$ 1+ swap cmove
  76.                 3 + exec$ c! exec$ count + off
  77.         else    drop exec$ off
  78.         then    44 @    exec.param      !       \ environment segmnt
  79.                 ?cs:    exec.param  4 + !       \ command line seg
  80.                 exec$   exec.param  2 + !       \ and offset
  81.                 $0D exec$ count + c!            \ append a carraige return
  82.                 FPC>OUT                         \ copy FPC to expanded mem
  83.                 RESTORE_VECTORS                 \ restore interrupt vectors
  84.                 <extexec>                       \ actually do the system call
  85.                 SET_VECTORS                     \ recapture interrupt vectors
  86.                 SETCRITICAL                     \ reset critical interrupt
  87.                 cursor_pos_init                 \ restore cursor position
  88. \u blinkoff     blinkoff                        \ disable background blink
  89.                 ;
  90.  
  91. : ?syserror     ( n1 --- )      \ handle ONLY error codes 2 and 8 from $sys
  92.                 dup  2 = abort" Can't find COMMAND.COM"
  93.                 dup  8 = abort" Not enough memory"
  94.                 drop ;
  95.  
  96. defer clearmem  ' noop is clearmem
  97.  
  98. : nd$sys        ( countedstring -- f1 )         \ shell with no disksave
  99.                 save> use-disk diskoff                  \ don't save to disk
  100.                 $sys
  101.                 restore> use-disk                       \ restore state of
  102.                 use-disk @                              \ disk save flag
  103.                 if      diskon                          \ and select mode
  104.                 then    ;
  105.  
  106. forth definitions
  107.  
  108. : "swapfile     ( a1 n1 -- )            \ set the disk swapfile for $SYS
  109.                 dup 0=
  110.                 if      2drop
  111.                         " FPCIMAGE.$$$"                 \ set to default name
  112.                 then    exthndl ">handle                \ set drive & file
  113.                 diskon ;                                \ enable disk save
  114.  
  115. : swapfile      ( | name -- )
  116.                 bl word count "swapfile ;
  117.  
  118. comment:
  119.  
  120. The SYS word relys on a string compiled in the handle CMDPATH, to
  121. contain the name and path to COMMAND.COM. For SYS to work, this string
  122. must specify the actual location of COMMAND.COM on your hard disk,
  123. or floppy. The drive may be omitted, which will cause SYS to look on
  124. the current drive.
  125.  
  126. comment;
  127.  
  128. : sys           ( command --- )
  129.                 clearmem
  130.                 0  word cr $sys ?syserror ;
  131.  
  132. ' SYS ALIAS `   ( command --- )
  133.  
  134. : ``            ( command --- )
  135.                 clearmem
  136.                 0  word cr nd$sys ?syserror ;
  137.  
  138. hidden definitions
  139.  
  140. : cmdbuf        rp0 @ 100 - ;           \ Down from return stack,
  141.                                         \ yet above TIB.
  142.  
  143. : "syscommand   ( a1 n1 c1 --- )        \ pass string a1,n1 to dos with line
  144.                                         \ following appended to it.
  145.                 clearmem
  146.                 >r ">$ cmdbuf over c@ 1+ cmove
  147.                 r> word count
  148.                 dup>r cmdbuf count + swap cmove
  149.                 r> cmdbuf c@ + cmdbuf c!
  150.                 cmdbuf count + off
  151.                 cmdbuf nd$sys ?syserror ;
  152.  
  153. : dir.name      ( --- )
  154.                 16 save!> tabsize
  155.                 #OUT @ 64 > IF CR THEN
  156.                 #out @ >r pad 30 + 12 bounds
  157.                 do      i c@ ?dup
  158.                         if emit else leave then
  159.                 loop    10 #out @ r> - - spaces
  160.                 pad 21 + c@ 16 and
  161.                 if      ." <DIR>"
  162.                 then    tab restore> tabsize ;
  163.  
  164. : $dir          ( a1 --- )
  165.                 here over c@ 1+ cmove
  166.                 here pathset drop
  167.                 ."  For directory " here count type
  168.                 here count + off here 1+
  169.                 CR  PAD SET-DTA findfirst
  170.                 BEGIN   255 and 0=
  171.                 WHILE   dir.name findnext REPEAT  ;
  172.  
  173. forth definitions
  174.  
  175. : dir           ( <filespec> --- )      \ directory of <filespec>.
  176.                 " dir " 0 "syscommand ;
  177.  
  178. : del           ( <filespec> --- )      \ delete files
  179.                 " del " bl "syscommand ;
  180.  
  181. \ ' del alias delete
  182.  
  183. : chdir         ( <filespec> --- )      \ change directory
  184.                 " chdir " bl "syscommand seqhandle >hndle @ 0<
  185.                 IF      seqhandle dup clr-hcb pathset drop
  186.                         -2 seqhandle >hndle !
  187.                 THEN    ;
  188.  
  189. ' chdir alias cd        \ Watch OUT, this is also a HEX number.
  190.  
  191. : copy          ( <filespec> --- )      \ copy files
  192.                 " copy " 0 "syscommand ;
  193.  
  194. : ren           ( <filespec> --- )      \ rename files
  195.                 " ren " 0 "syscommand ;
  196.  
  197. ' ren  alias rename
  198. ' dark alias cls
  199.  
  200. comment:
  201.  
  202. : "setdrive     ( a1 n1 --- )           \ set drive a as default drive.
  203.                 clearmem
  204.                 ">$ nd$sys ?syserror
  205.                 seqhandle >hndle @ -2 =
  206.                 if      -1 seqhandle >hndle !
  207.                 then    ;
  208.  
  209. : a:            ( --- )                 \ set drive b as default drive.
  210.                 " a:" "setdrive ;
  211.  
  212. : b:            ( --- )                 \ set drive b as default drive.
  213.                 " b:" "setdrive ;
  214.  
  215. : c:            ( --- )                 \ set drive c as default drive.
  216.                 " c:" "setdrive ;
  217.  
  218. comment;
  219.  
  220.                 \ Here are some additional system commands you can
  221.                   \ add if you need them. Just un-comment: them out.
  222. comment:
  223.  
  224. : rd            ( <filespec> --- )      \ remove directory
  225.                 " rd " bl "syscommand ;
  226.  
  227. ' rd alias rmdir
  228.  
  229. : md            ( <filespec> --- )      \ make directory
  230.                 " md " bl "syscommand ;
  231.  
  232. ' md alias mkdir
  233.  
  234. : format        ( <drivespec> --- )     \ format disk
  235.                 " format " bl "syscommand ;
  236.  
  237. : ftype         ( <filespec> --- )      \ type a file
  238.                 " type " bl "syscommand ;
  239.  
  240. : path          ( <pathspec> --- )      \ gt or set search path
  241.                 " path " bl "syscommand ;
  242.  
  243. : cls           ( --- )
  244.                 " cls " bl "syscommand ;
  245.  
  246. comment;
  247.  
  248. only forth also definitions
  249.  
  250.  
  251.