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