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