\ EXEC.SEQ      A utility for calling DOS from Forth.   by Tom Zimmer

only forth also hidden also definitions

hex

create exec.param 10 allot      exec.param 10 erase

variable ss_save
variable sp_save

code <exec>     ( string --- return-code )
                pop dx                          \ DX contains string
                push es                 push si
                push bp                 push ds
                mov ax, cs              mov es, ax
                mov bx, # exec.param
                mov ax, # 4B00
                                                \ Save Sp and SS
                mov sp_save sp          mov ss_save ss
                int 21
                                                \ Restore SP and SS
                mov cs: ss, ss_save     mov cs: sp, sp_save
                pop ds                  pop bp
                pop si                  pop es
             U< IF                      \ ONLY when carry is NON ZERO
                        AND AX, # $FF
                ELSE    MOV AX, # 0
                THEN
                PUSH AX
                JMP ' SET_VECTORS
                END-CODE
\                1push end-code                  \ AX contains error code

decimal

handle cmdpath                  \ These two lines could be replaced with
                                \ CREATE CMDPATH ," \COMMAND.COM" 0 ,
cmdpath !hcb \COMMAND.COM

: initcmdpath   ( --- )         \ Initialize the Command path
                defers initstuff
                comspec@ comspec$ cmdpath $>handle ;

' initcmdpath is initstuff      \ Put into initialization chain.

: $sys          ( countedstring --- f1 ) \ spawn a shell
                exec.param 16 erase
                dup c@
        if      count tuck pad 4 + swap cmove
                " /c " pad 1+ swap cmove
                3 + pad c! pad count + off
        else    drop pad off
        then    44 @    exec.param      !   \ environment segmnt
                ?cs:    exec.param  4 + !   \ command line seg
                pad     exec.param  2 + !   \ and offset
                $0D pad count + c!          \ append a carraige return
                cmdpath >nam
                RESTORE_VECTORS
                <exec> ;

: ?syserror     ( n1 --- )      \ handle ONLY error codes 2 and 8 from $sys
                                  \ and -2 meaning wrong DOS version.
                dup  2 = abort" Can't find COMMAND.COM"
                dup  8 = abort" Not enough memory"
                drop ;

forth definitions

: sys           ( command --- )
                0  word cr $sys 0 24 AT cr ?syserror ;

' SYS ALIAS `   ( command --- )

comment:

The SYS word relys on a string compiled in the handle CMDPATH, to
contain the name and path to COMMAND.COM. For SYS to work, this string
must specify the actual location of COMMAND.COM on your hard disk,
or floppy. The drive may be omitted, which will cause SYS to look on
the current drive.

comment;

hidden definitions

: cmdbuf        rp0 @ 100 - ;           \ Down from return stack,
                                        \ yet above TIB.

: "syscommand   ( a1 n1 c1 --- )        \ pass string a1,n1 to dos with line
                                        \ following appended to it.
                >r ">$ cmdbuf over c@ 1+ cmove
                r> word count dup >r cmdbuf count + swap cmove
                r> cmdbuf c@ + cmdbuf c!
                cmdbuf count + off
                cmdbuf $sys 0 24 at cr ?syserror ;

: dir.name      ( --- )
                tabsize @ >r 16 tabsize !
                #OUT @ 64 > IF CR THEN
                #out @ >r pad 30 + 12 bounds
                do      i c@ ?dup
                        if emit else leave then
                loop    10 #out @ r> - - spaces
                pad 21 + c@ 16 and
                if      ." <DIR>"
                then    tab r> tabsize ! ;

: $dir          ( a1 --- )
                here over c@ 1+ cmove
                here pathset drop
                ."  For directory " here count type
                here count + off here 1+
                CR  PAD SET-DTA findfirst
                BEGIN   255 and 0=
                WHILE   dir.name findnext REPEAT  ;

forth definitions

: dir           ( <filespec> --- )      \ directory of <filespec>.
                " dir " 0 "syscommand ;

: del           ( <filespec> --- )      \ delete files
                " del " bl "syscommand ;

\ ' del alias delete

: chdir         ( <filespec> --- )      \ change directory
                " chdir " bl "syscommand shndl @ >hndle @ 0<
                IF      shndl @ dup clr-hcb pathset drop
                        -2 shndl @ >hndle !
                THEN    ;

' chdir alias cd        \ Watch OUT, this is also a HEX number.

: copy          ( <filespec> --- )      \ copy files
                " copy " 0 "syscommand ;

: ren           ( <filespec> --- )      \ rename files
                " ren " 0 "syscommand ;

' ren alias rename

comment:

: "setdrive     ( a1 n1 --- )           \ set drive a as default drive.
                ">$ $sys ?syserror
                shndl @ >hndle @ -2 =
                if      -1 shndl @ >hndle !
                then    ;

: a:            ( --- )                 \ set drive b as default drive.
                " a:" "setdrive ;

: b:            ( --- )                 \ set drive b as default drive.
                " b:" "setdrive ;

: c:            ( --- )                 \ set drive c as default drive.
                " c:" "setdrive ;

comment;

                \ Here are some additional system commands you can
                  \ add if you need them. Just un-comment: them out.
comment:

: rd            ( <filespec> --- )      \ remove directory
                " rd " bl "syscommand ;

' rd alias rmdir

: md            ( <filespec> --- )      \ make directory
                " md " bl "syscommand ;

' md alias mkdir

: format        ( <drivespec> --- )     \ format disk
                " format " bl "syscommand ;

: ftype         ( <filespec> --- )      \ type a file
                " type " bl "syscommand ;

: path          ( <pathspec> --- )      \ gt or set search path
                " path " bl "syscommand ;

: cls           ( --- )
                " cls " bl "syscommand ;

comment;

only forth also definitions