VolksForth/sources/msdos/dos.fth

307 lines
19 KiB
Forth
Raw Normal View History

\ *** Block No. 0 Hexblock 0
\ 28 jun 88
DOS loads higher level file functions which go beyond
including a screen file. Calls to MS-DOS are implemented
and used for directory manipulation. These functions may
not work for versions before MS-DOS 3.0.
\ *** Block No. 1 Hexblock 1
\ MS-DOS file handli cas 09jun20
Onlyforth \needs Assembler 2 loadfrom asm.fb
: fswap isfile@ fromfile @ isfile ! fromfile ! ;
$80 Constant dta
| : COMSPEC ( -- string ) [ dos ]
$2C @ ( DOS-environment:seg) 8 ds@ filename &60 lmove
filename counted &60 min filename place filename ;
1 &12 +thru .( MS-DOS functions loaed ) cr
Onlyforth
\ *** Block No. 2 Hexblock 2
\ moving blocks ks 04 okt 87
| : full? ( -- flag ) prev BEGIN @ dup @ 0= UNTIL 6 + @ 0< ;
: used? ( blk -- f )
block count b/blk 1- swap skip nip 0<> ;
| : (copy ( from to -- )
full? IF save-buffers THEN isfile@ fromfile @ -
IF dup used? Abort" target block not empty" THEN
dup isfile@ core? IF prev @ emptybuf THEN
isfile@ 0= IF offset @ + THEN
isfile@ rot fromfile @ (block 6 - 2! update ;
\ *** Block No. 3 Hexblock 3
\ moving blocks ks 04 okt 87
| : blkmove ( from to quan -- ) 3 arguments save-buffers
>r over r@ + over u> >r 2dup u< r> and
IF r@ r@ d+ r> 0 ?DO -1 -2 d+ 2dup (copy LOOP
ELSE r> 0 ?DO 2dup (copy 1 1 d+ LOOP
THEN save-buffers 2drop ;
: copy ( from to -- ) 1 blkmove ;
: convey ( blk1 blk2 to.blk -- )
3 arguments >r 2dup swap - >r
fswap dup capacity 1- > isfile@ 0<> and
fswap r> r@ + capacity 1- > isfile@ 0<> and or >r
1+ over - dup 0> not r> or Abort" nein" r> swap blkmove ;
\ *** Block No. 4 Hexblock 4
\ MORE extending forth files ks 10 okt 87
Dos also definitions
| : addblock ( blk -- ) dup buffer dup b/blk blank
isfile@ f.size dup 2@ b/blk 0 d+ rot 2!
swap isfile@ fblock! ;
Forth definitions
: more ( n -- ) 1 arguments isfile@
IF capacity swap bounds ?DO I addblock LOOP close exit
THEN drop ;
\ *** Block No. 5 Hexblock 5
\ file eof? create dta-addressing ks 03 apr 88
Dos definitions
: ftime ( -- mm hh )
isfile@ f.time @ $20 u/mod nip $40 u/mod ;
: fdate ( -- dd mm yy )
isfile@ f.date @ $20 u/mod $10 u/mod &80 + ;
: .when base push decimal
fdate rot 3 .r ." ." swap 2 .r ." ." 2 .r
ftime 3 .r ." :" 2 .r ;
\ *** Block No. 6 Hexblock 6
\ ks 20mar88
: (.fcb ( fcb -- )
dup .file ?dup 0=exit pushfile
isfile ! &13 tab ." is"
isfile@ f.handle @ 2 .r
isfile@ f.size 2@ 7 d.r .when
space isfile@ f.name count type ;
Forth definitions
: files file-link
BEGIN @ dup WHILE cr dup (.fcb stop? UNTIL drop ;
: ?file isfile@ (.fcb ;
\ *** Block No. 7 Hexblock 7
\ dir make makefile ks 25 okt 87
Forth definitions
: killfile close
isfile@ f.name filename >asciz ~unlink drop ;
: emptyfile isfile@ 0=exit
isfile@ f.name filename >asciz 0 ~creat ?diskerror
isfile@ f.handle ! isfile@ f.size 4 erase ;
: make close name isfile@ fname! emptyfile ;
: makefile File last @ name> execute emptyfile ;
\ *** Block No. 8 Hexblock 8
\ getpath ks 10 okt 87
Dos definitions
| &40 Constant pathlen
| Create pathes 0 c, pathlen allot
| : (setpath ( string -- ) count
dup pathlen u> Abort" path too long" pathes place ;
| : getpath ( +n -- string / ff )
>r 0 pathes count r> 0
DO rot drop Ascii ; skip stash Ascii ; scan LOOP
drop over - ?dup
IF here place here dup count + 1- c@
?" :\" ?exit Ascii \ here append exit
THEN 0= ;
\ *** Block No. 9 Hexblock 9
\ pathsearch .path path ks 09 okt 87
: pathsearch ( string -- asciz *f ) dup >r
(fsearch dup 0= IF rdrop exit THEN 2drop 0 0
BEGIN drop 1+ dup getpath ?dup 0=
IF drop r> filename >asciz 2 exit THEN
r@ count 2 pick attach (fsearch
0= UNTIL nip rdrop false ;
' pathsearch Is fsearch
Forth definitions
: .path pathes count type ;
: path name nullstring? IF .path exit THEN (setpath ;
\ *** Block No. 10 Hexblock A
\ call another executable file ks 04 aug 87
Dos definitions
| Create cpb 0 , \ inherit parent environment
dta , ds@ , $5C , ds@ , $6C , ds@ , Label ssave 0 ,
| Code ~exec ( asciz -- *f )
I push R push U push S ssave #) mov cpb # R mov
$4B00 # A mov $21 int C: D mov D D: mov D S: mov
D E: mov ssave #) S mov CS not
?[ A A xor A push $2F # A+ mov $21 int E: A mov
A D: mov C: A mov A E: mov R I mov dta # W mov
$40 # C mov rep movs A D: mov A pop
]? A W xchg dta # D mov $1A # A+ mov $21 int
W D mov U pop R pop I pop Next
end-code
\ *** Block No. 11 Hexblock B
\ calling MS-DOS thru forth interpreter ks 19 mr 88
| : execute? ( extension -- *f )
count filename count Ascii . scan drop swap
2dup 1+ erase move filename 1+ ~exec ;
: fcall ( string -- ) count filename place ds@ cpb 4+ !
" .EXE" execute? dup IF drop " .COM" execute? THEN
?diskerror ;
: fdos ( string -- )
dta $80 erase " /c " count dta place count dta attach
status push status off .status COMSPEC fcall curat? at ;
\ *** Block No. 12 Hexblock C
\ einige MS-DOS Funktionen msdos call ks 10 okt 87
: dos: Create ," Does> count here place
Ascii " parse here attach here fdos ;
Forth definitions
dos: dir dir "
dos: ren ren "
dos: md md "
dos: cd cd "
dos: rd rd "
dos: fcopy copy "
dos: delete del "
dos: ftype type "
\ *** Block No. 13 Hexblock D
\ msdos call ks 23 okt 88
: msdos savevideo status push status off .status
flush dta off COMSPEC fcall restorevideo ;
: call name source >in @ /string c/l umin
dta place dta dta >asciz drop [compile] \
status push status off .status fcall curat? at ;
\ *** Block No. 14 Hexblock E
\ time date ks 19 mr 88
Dos definitions
: ftime ( -- mm hh )
open isfile@ f.time @ $20 u/mod nip $40 u/mod ;
: fdate ( -- dd mm yy )
open isfile@ f.date @ $20 u/mod $10 u/mod &80 + ;
\ *** Block No. 15 Hexblock F
\ ~lseek position? ks 10 okt 87
Dos definitions
Code ~lseek ( d handle method -- d' )
R W mov D A mov R pop C pop D pop
$42 # A+ mov $21 int W R mov CS not
?[ A push Next ]? A D xchg ;c: ?diskerror ;
Forth definitions
: position? ( -- dfaddr )
isfile@ f.handle @ 0= Abort" file not open"
0 0 isfile@ f.handle @ 1 ~lseek ;
\ *** Block No. 16 Hexblock 10
\ *** Block No. 17 Hexblock 11