home *** CD-ROM | disk | FTP | other *** search
/ Programmer 7500 / MAX_PROGRAMMERS.iso / PROGRAMS / UTILS / LASER / FPC35_5.ZIP / FPCSRC.ZIP / EXEC.SEQ < prev    next >
Encoding:
Text File  |  1989-02-22  |  6.4 KB  |  195 lines
  1. \ EXEC.SEQ      A utility for calling DOS from Forth.   by Tom Zimmer
  2.  
  3. only forth also hidden also definitions
  4.  
  5. create exec.param $10 allot      exec.param $10 erase
  6.  
  7. variable ss_save
  8. variable sp_save
  9.  
  10. code <exec>     ( string --- return-code )
  11.                 pop dx                          \ DX contains string
  12.                 push es                 push si
  13.                 push bp                 push ds
  14.                 mov ax, cs              mov es, ax
  15.                 mov bx, # exec.param
  16.                 mov ax, # $4B00
  17.                                                 \ Save Sp and SS
  18.                 mov sp_save sp          mov ss_save ss
  19.                 int $21
  20.                                                 \ Restore SP and SS
  21.                 mov cs: ss, ss_save     mov cs: sp, sp_save
  22.                 pop ds                  pop bp
  23.                 pop si                  pop es
  24.              U< IF                      \ ONLY when carry is NON ZERO
  25.                         AND AX, # $FF
  26.                 ELSE    MOV AX, # 0
  27.                 THEN
  28.                 PUSH AX
  29.                 JMP ' SET_VECTORS
  30.                 END-CODE
  31. \                1push end-code                  \ AX contains error code
  32.  
  33. handle cmdpath                  \ These two lines could be replaced with
  34.                                 \ CREATE CMDPATH ," \COMMAND.COM" 0 ,
  35. cmdpath !hcb \COMMAND.COM
  36.  
  37. : initcmdpath   ( --- )         \ Initialize the Command path
  38.                 defers initstuff
  39.                 comspec@ comspec$ cmdpath $>handle ;
  40.  
  41. ' initcmdpath is initstuff      \ Put into initialization chain.
  42.  
  43. : $sys          ( countedstring --- f1 ) \ spawn a shell
  44.                 exec.param 16 erase
  45.                 dup c@
  46.         if      count tuck pad 4 + swap cmove
  47.                 " /c " pad 1+ swap cmove
  48.                 3 + pad c! pad count + off
  49.         else    drop pad off
  50.         then    44 @    exec.param      !   \ environment segmnt
  51.                 ?cs:    exec.param  4 + !   \ command line seg
  52.                 pad     exec.param  2 + !   \ and offset
  53.                 $0D pad count + c!          \ append a carraige return
  54.                 cmdpath >nam
  55.                 RESTORE_VECTORS
  56.                 <exec> cursor_pos_init ;
  57.  
  58. : ?syserror     ( n1 --- )      \ handle ONLY error codes 2 and 8 from $sys
  59.                 dup  2 = abort" Can't find COMMAND.COM"
  60.                 dup  8 = abort" Not enough memory"
  61.                 drop ;
  62.  
  63. defer clearmem  ' noop is clearmem
  64.  
  65. forth definitions
  66.  
  67. : sys           ( command --- )
  68.                 clearmem
  69.                 0  word cr $sys ?syserror ;
  70.  
  71. ' SYS ALIAS `   ( command --- )
  72.  
  73. comment:
  74.  
  75. The SYS word relys on a string compiled in the handle CMDPATH, to
  76. contain the name and path to COMMAND.COM. For SYS to work, this string
  77. must specify the actual location of COMMAND.COM on your hard disk,
  78. or floppy. The drive may be omitted, which will cause SYS to look on
  79. the current drive.
  80.  
  81. comment;
  82.  
  83. hidden definitions
  84.  
  85. : cmdbuf        rp0 @ 100 - ;           \ Down from return stack,
  86.                                         \ yet above TIB.
  87.  
  88. : "syscommand   ( a1 n1 c1 --- )        \ pass string a1,n1 to dos with line
  89.                                         \ following appended to it.
  90.                 clearmem
  91.                 >r ">$ cmdbuf over c@ 1+ cmove
  92.                 r> word count dup>r cmdbuf count + swap cmove
  93.                 r> cmdbuf c@ + cmdbuf c!
  94.                 cmdbuf count + off
  95.                 cmdbuf $sys ?syserror ;
  96.  
  97. : dir.name      ( --- )
  98.                 16 save!> tabsize
  99.                 #OUT @ 64 > IF CR THEN
  100.                 #out @ >r pad 30 + 12 bounds
  101.                 do      i c@ ?dup
  102.                         if emit else leave then
  103.                 loop    10 #out @ r> - - spaces
  104.                 pad 21 + c@ 16 and
  105.                 if      ." <DIR>"
  106.                 then    tab restore> tabsize ;
  107.  
  108. : $dir          ( a1 --- )
  109.                 here over c@ 1+ cmove
  110.                 here pathset drop
  111.                 ."  For directory " here count type
  112.                 here count + off here 1+
  113.                 CR  PAD SET-DTA findfirst
  114.                 BEGIN   255 and 0=
  115.                 WHILE   dir.name findnext REPEAT  ;
  116.  
  117. forth definitions
  118.  
  119. : dir           ( <filespec> --- )      \ directory of <filespec>.
  120.                 " dir " 0 "syscommand ;
  121.  
  122. : del           ( <filespec> --- )      \ delete files
  123.                 " del " bl "syscommand ;
  124.  
  125. \ ' del alias delete
  126.  
  127. : chdir         ( <filespec> --- )      \ change directory
  128.                 " chdir " bl "syscommand seqhandle >hndle @ 0<
  129.                 IF      seqhandle dup clr-hcb pathset drop
  130.                         -2 seqhandle >hndle !
  131.                 THEN    ;
  132.  
  133. ' chdir alias cd        \ Watch OUT, this is also a HEX number.
  134.  
  135. : copy          ( <filespec> --- )      \ copy files
  136.                 " copy " 0 "syscommand ;
  137.  
  138. : ren           ( <filespec> --- )      \ rename files
  139.                 " ren " 0 "syscommand ;
  140.  
  141. ' ren  alias rename
  142. ' dark alias cls
  143.  
  144. comment:
  145.  
  146. : "setdrive     ( a1 n1 --- )           \ set drive a as default drive.
  147.                 clearmem
  148.                 ">$ $sys ?syserror
  149.                 seqhandle >hndle @ -2 =
  150.                 if      -1 seqhandle >hndle !
  151.                 then    ;
  152.  
  153. : a:            ( --- )                 \ set drive b as default drive.
  154.                 " a:" "setdrive ;
  155.  
  156. : b:            ( --- )                 \ set drive b as default drive.
  157.                 " b:" "setdrive ;
  158.  
  159. : c:            ( --- )                 \ set drive c as default drive.
  160.                 " c:" "setdrive ;
  161.  
  162. comment;
  163.  
  164.                 \ Here are some additional system commands you can
  165.                   \ add if you need them. Just un-comment: them out.
  166. comment:
  167.  
  168. : rd            ( <filespec> --- )      \ remove directory
  169.                 " rd " bl "syscommand ;
  170.  
  171. ' rd alias rmdir
  172.  
  173. : md            ( <filespec> --- )      \ make directory
  174.                 " md " bl "syscommand ;
  175.  
  176. ' md alias mkdir
  177.  
  178. : format        ( <drivespec> --- )     \ format disk
  179.                 " format " bl "syscommand ;
  180.  
  181. : ftype         ( <filespec> --- )      \ type a file
  182.                 " type " bl "syscommand ;
  183.  
  184. : path          ( <pathspec> --- )      \ gt or set search path
  185.                 " path " bl "syscommand ;
  186.  
  187. : cls           ( --- )
  188.                 " cls " bl "syscommand ;
  189.  
  190. comment;
  191.  
  192. only forth also definitions
  193.  
  194.  
  195.