mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-06-01 06:41:37 +00:00
545 lines
35 KiB
Plaintext
545 lines
35 KiB
Plaintext
Screen 0 not modified
|
|
0 \ CP/M 2.2 File-Interface (3.80a) UH 05Oct87
|
|
1
|
|
2 Dieses File enthaelt das File-Interface von volksFORTH zu CP/M.
|
|
3 Damit ist Zugriff auf normale CP/M-Files moeglich.
|
|
4 Wenn ein File mit USE benutzt wird, beziehen sich alle Worte,
|
|
5 die mit dem Massenspeicher arbeiten, auf dieses File.
|
|
6
|
|
7 Benutzung:
|
|
8 USE <name> \ benutze ein schon existierendes File
|
|
9 FILE <name> \ erzeuge ein Forthfile mit dem Namen <name>.
|
|
10 MAKE <name> \ Erzeuge ein File mit <name> und ordne
|
|
11 \ es dem aktuellen Forthfile zu.
|
|
12 MAKEFILE <name> \ Erzeuge ein File mit CP/M und FORTH-Namen
|
|
13 <name>.
|
|
14 INCLUDE <name> \ Lade File mit Forthnamen <name> ab Screen 1
|
|
15 DOS RESET \ zum Wechsel von Disketten. (Oh! CP/M)
|
|
Screen 1 not modified
|
|
0 \ CP/M 2.2 File-Interface load-Screen UH 18Feb88
|
|
1 OnlyForth
|
|
2
|
|
3 2 load \ view numbers for this file
|
|
4 3 4 thru \ DOS File Functions
|
|
5 5 $11 thru \ Forth File Functions
|
|
6 $12 $16 thru \ User Interface
|
|
7
|
|
8 File source.fb \ Define already existing Files
|
|
9 File fileint.fb File startup.fbr
|
|
10
|
|
11 ' (makeview Is makeview
|
|
12 ' remove-files Is custom-remove
|
|
13 ' file-r/w Is r/w
|
|
14 ' noop Is drvinit
|
|
15 \ include startup.fb \ load Standard System
|
|
Screen 2 not modified
|
|
0 \ Build correct view-numbers for this file UUH 19Nov87
|
|
1
|
|
2 | : fileintview ( -- ) $400 blk @ + ;
|
|
3
|
|
4 ' fileintview Is makeview
|
|
5
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 3 not modified
|
|
0 \ File Control Blocks UH 18Feb88
|
|
1 Dos definitions also
|
|
2 | : Fcbyte ( n len -- len' ) Create over c, + does> c@ + ;
|
|
3 &11 Constant filenamelen
|
|
4 0 2 | Fcbyte nextfile immediate
|
|
5 1 Fcbyte drive ' drive | Alias >dosfcb
|
|
6 filenamelen 3 - Fcbyte filename
|
|
7 3 Fcbyte extension
|
|
8 &21 + \ ex, s1, s2, rc, d0, ... dn, cr
|
|
9 2 Fcbyte record \ r0, r1
|
|
10 1+ \ r2
|
|
11 2 Fcbyte opened
|
|
12 2 Fcbyte fileno
|
|
13 2 Fcbyte filesize \ in 128-Byte-Records
|
|
14 4 Fcbyte position
|
|
15 Constant b/fcb
|
|
Screen 4 not modified
|
|
0 \ dos primitives UH 10Oct87
|
|
1
|
|
2 ' 2- | Alias body> ' 2- | Alias dosfcb>
|
|
3
|
|
4 : drive! ( drv -- ) $0E bdos ;
|
|
5 : search0 ( dosfcb -- dir ) $11 bdosa ;
|
|
6 : searchnext ( dosfcb -- dir ) $12 bdosa ;
|
|
7 : read-seq ( dosfcb -- f ) $14 bdosa dos-error? ;
|
|
8 : write-seq ( dosfcb -- f ) $15 bdosa dos-error? ;
|
|
9 : createfile ( dosfcb -- f ) $16 bdosa dos-error? ;
|
|
10 : size ( dos -- size ) dup $23 bdos dosfcb> record @ ;
|
|
11 : drive@ ( -- drv ) 0 $19 bdosa ;
|
|
12 : killfile ( dosfcb -- ) $13 bdos ;
|
|
13
|
|
14
|
|
15
|
|
Screen 5 not modified
|
|
0 \ File sizes UH 05Oct87
|
|
1
|
|
2 : (capacity ( fcb -- n ) \ filecapacity in blocks
|
|
3 filesize @ rec/blk u/mod swap 0= ?exit 1+ ;
|
|
4
|
|
5 : in-range ( block fcb -- )
|
|
6 (capacity u< not Abort" beyond capacity!" ;
|
|
7
|
|
8 Forth definitions
|
|
9
|
|
10 : capacity ( -- n ) isfile@ (capacity ;
|
|
11
|
|
12 Dos definitions
|
|
13
|
|
14
|
|
15
|
|
Screen 6 not modified
|
|
0 \ (open UH 18Feb88
|
|
1
|
|
2 : (open ( fcb -- )
|
|
3 dup opened @ IF drop exit THEN dup position 0. rot 2!
|
|
4 dup >dosfcb openfile Abort" not found!" dup opened on
|
|
5 dup >dosfcb size swap filesize ! ;
|
|
6
|
|
7 : (make ( fcb -- )
|
|
8 dup >dosfcb killfile
|
|
9 dup >dosfcb createfile Abort" directory full!"
|
|
10 dup position 0. rot 2!
|
|
11 dup filesize off opened on offset off ;
|
|
12
|
|
13 : file-r/w ( buffer block fcb f -- f )
|
|
14 over 0= Abort" no Direct Disk IO supported! "
|
|
15 >r dup (open 2dup in-range r> (r/w ;
|
|
Screen 7 not modified
|
|
0 \ Print Filenames UH 10Oct87
|
|
1
|
|
2 : .file ( fcb -- ) 0 case? IF ." DIRECT" exit THEN
|
|
3 fcb dosfcb> case? IF ." DEFAULT" exit THEN
|
|
4 body> >name .name ;
|
|
5
|
|
6 : .drive ( fcb -- ) drive c@ ?dup 0=exit
|
|
7 [ Ascii A 1- ] Literal + emit Ascii : emit ;
|
|
8
|
|
9 : .dosfile ( fcb -- ) dup filename 8 -trailing type
|
|
10 Ascii . emit extension 3 type ;
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 8 not modified
|
|
0 \ Print Filenames UH 10Oct87
|
|
1
|
|
2 : tab ( -- ) col &59 > IF cr exit THEN
|
|
3 &20 col &20 mod - 0 max spaces ;
|
|
4
|
|
5 : .fcb ( fcb -- ) dup fileno @ 3 u.r tab
|
|
6 dup .file tab dup .drive dup .dosfile
|
|
7 tab dup opened @ IF ." opened" ELSE ." closed" THEN
|
|
8 3 spaces base push decimal (capacity 3 u.r ." kB" ;
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 9 not modified
|
|
0 \ Filenames UH 05Oct87
|
|
1
|
|
2 : !name ( addr len fcb -- )
|
|
3 dup >r filename filenamelen bl fill
|
|
4 over 1+ c@ Ascii : =
|
|
5 IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r>
|
|
6 ELSE 0 THEN r@ drive c! r> dup filename 2swap
|
|
7 filenamelen 1+ min bounds
|
|
8 ?DO I c@ Ascii . =
|
|
9 IF drop dup extension ELSE I c@ over c! 1+ THEN
|
|
10 LOOP 2drop ;
|
|
11
|
|
12 : !fcb ( fcb -- ) dup opened off name count rot !name ;
|
|
13
|
|
14
|
|
15
|
|
Screen 10 not modified
|
|
0 \ Print Directory UH 18Nov87
|
|
1
|
|
2 | Create dirbuf b/rec allot dirbuf b/rec erase
|
|
3 | Create fcb0 b/fcb allot fcb0 b/fcb erase
|
|
4
|
|
5 | : wildchard? ( f c -- f' ) Ascii * = IF drop Ascii ? THEN ;
|
|
6 | : (expand ( addr len -- ) false -rot bounds
|
|
7 ?DO I c@ wildchard? dup ?dup IF I c! THEN LOOP drop ;
|
|
8 | : expand ( fcb -- ) \ expand * to ???
|
|
9 dup filename 8 (expand extension 3 (expand ;
|
|
10
|
|
11 : (dir ( addr len -- )
|
|
12 fcb0 !name fcb0 expand dirbuf dma! fcb0 >dosfcb search0
|
|
13 BEGIN dup dos-error? not
|
|
14 WHILE $20 * dirbuf + dosfcb> tab .dosfile
|
|
15 fcb0 >dosfcb searchnext stop? UNTIL drop ;
|
|
Screen 11 not modified
|
|
0 \ File List UH 10Oct87
|
|
1
|
|
2 User file-link file-link off
|
|
3
|
|
4 | : #file ( -- n ) file-link @ dup IF fileno c@ THEN 1+ ;
|
|
5
|
|
6
|
|
7 Forth definitions
|
|
8
|
|
9 : forthfiles ( -- )
|
|
10 file-link @
|
|
11 BEGIN dup WHILE cr dup .fcb @ stop? UNTIL drop ;
|
|
12
|
|
13 Dos definitions
|
|
14
|
|
15
|
|
Screen 12 not modified
|
|
0 \ Close a file UH 10Oct87
|
|
1
|
|
2 ' save-buffers >body $0C + @ | Alias backup
|
|
3
|
|
4 | : filebuffer? ( fcb -- fcb bufaddr/flag )
|
|
5 prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ;
|
|
6
|
|
7 | : flushfile ( fcb -- ) \ flush file buffers
|
|
8 BEGIN filebuffer? ?dup WHILE
|
|
9 dup backup emptybuf REPEAT drop ;
|
|
10
|
|
11 : (close ( fcb -- ) \ close file in fcb
|
|
12 dup flushfile
|
|
13 dup opened dup @ 0= IF 2drop exit THEN off
|
|
14 >dosfcb closefile Abort" not found!" ;
|
|
15
|
|
Screen 13 not modified
|
|
0 \ Create fcbs UH 10Oct87
|
|
1
|
|
2 : !files ( fcb -- ) dup isfile ! fromfile ! ;
|
|
3
|
|
4 ' r@ | Alias newfcb
|
|
5
|
|
6 Forth definitions
|
|
7
|
|
8 : File ( -- )
|
|
9 Create here >r b/fcb allot newfcb b/fcb erase
|
|
10 last @ count $1F and newfcb !name
|
|
11 #file newfcb fileno !
|
|
12 file-link @ newfcb nextfile ! r> file-link !
|
|
13 Does> !files ;
|
|
14
|
|
15 : direct 0 !files ;
|
|
Screen 14 not modified
|
|
0 \ flush buffers & misc. UH 10Oct87 UH 28Nov87
|
|
1 Dos definitions
|
|
2
|
|
3 : save-files ( -- ) file-link BEGIN @ ?dup WHILE
|
|
4 dup opened @ IF dup >dosfcb closefile drop THEN REPEAT ;
|
|
5
|
|
6 ' save-files Is save-dos-buffers
|
|
7
|
|
8 \ : close-files ( -- ) file-link
|
|
9 \ BEGIN @ ?dup WHILE dup (close REPEAT ;
|
|
10
|
|
11 Forth definitions
|
|
12
|
|
13 : file? isfile@ .file ; \ print current file
|
|
14
|
|
15 : list ( n -- ) 3 spaces file? list ;
|
|
Screen 15 not modified
|
|
0 \ words for viewing UH 10Oct87
|
|
1
|
|
2 Forth definitions
|
|
3
|
|
4 | $200 Constant viewoffset \ max. %512 kB files
|
|
5
|
|
6 : (makeview ( -- n ) \ calc. view filed for a name
|
|
7 blk @ dup 0= ?exit
|
|
8 loadfile @ ?dup IF fileno @ viewoffset * + THEN ;
|
|
9
|
|
10 : (view ( blk -- blk' ) \ select file and leave block
|
|
11 dup 0=exit
|
|
12 viewoffset u/mod file-link
|
|
13 BEGIN @ dup WHILE 2dup fileno @ = UNTIL
|
|
14 !files drop ; \ not found: direct access
|
|
15
|
|
Screen 16 not modified
|
|
0 \ FORGETing files UH 10Oct87
|
|
1
|
|
2 | : remove? ( dic symb addr -- dic symb addr f )
|
|
3 dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ;
|
|
4
|
|
5
|
|
6 | : remove-files ( dic symb -- dic symb ) \ flush files !
|
|
7 isfile@ remove? nip IF direct THEN
|
|
8 fromfile @ remove? nip IF fromfile off THEN
|
|
9 file-link
|
|
10 BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT
|
|
11 file-link remove ;
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 17 not modified
|
|
0 \ print a list of all buffers UH 20Oct86
|
|
1
|
|
2 : .buffers
|
|
3 prev BEGIN @ ?dup WHILE stop? abort" stopped"
|
|
4 cr dup u. dup 2+ @ dup 1+
|
|
5 IF ." Block: " over 4+ @ 5 .r
|
|
6 ." File : " [ Dos ] .file
|
|
7 dup 6 + @ 0< IF ." updated" THEN
|
|
8 ELSE ." Buffer empty" drop THEN REPEAT ;
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 18 not modified
|
|
0 \ File Interface User words UH 11Oct87
|
|
1
|
|
2 | : same ( addr -- ) >in ! ;
|
|
3 : open isfile@ (open offset off ;
|
|
4 : close isfile@ (close ;
|
|
5 : assign close isfile@ !fcb open ;
|
|
6 : make isfile@ dup !fcb (make ;
|
|
7
|
|
8 | : isfile? ( addr -- addr f ) \ is adr a fcb?
|
|
9 file-link BEGIN @ dup 0=exit 2dup body> = UNTIL drop true ;
|
|
10
|
|
11 : use >in @ name find \ create a fcb if not present
|
|
12 IF isfile? IF execute drop exit THEN THEN drop
|
|
13 dup same File same ' execute open ;
|
|
14
|
|
15
|
|
Screen 19 not modified
|
|
0 \ File Interface User words UH 25May88
|
|
1
|
|
2 : makefile >in @ File dup same ' execute same make ;
|
|
3 : emptyfile isfile@ >dosfcb createfile ;
|
|
4
|
|
5 : from isfile push use ;
|
|
6 : loadfrom ( n -- )
|
|
7 isfile push fromfile push use load close ;
|
|
8 : include 1 loadfrom ;
|
|
9
|
|
10 : eof ( -- f ) isfile@ dup filesize @ swap record @ = ;
|
|
11
|
|
12 : files " *.*" count (dir ;
|
|
13 : files" Ascii " word count 2dup upper (dir ;
|
|
14
|
|
15 ' files Alias dir ' files" Alias dir"
|
|
Screen 20 not modified
|
|
0 \ extend Files UH 20Nov87
|
|
1
|
|
2 | : >fileend isfile@ >dosfcb size drop ;
|
|
3
|
|
4 | : addblock ( n -- ) \ add block n to file
|
|
5 dup buffer under b/blk bl fill
|
|
6 isfile@ rec/blk over filesize +! false file-r/w
|
|
7 IF close Abort" disk full!" THEN ;
|
|
8
|
|
9 : more ( n -- ) open >fileend
|
|
10 capacity swap bounds ?DO I addblock LOOP close
|
|
11 open close ;
|
|
12
|
|
13 : Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ;
|
|
14 0 Drive: a: Drive: b: Drive: c: Drive: d:
|
|
15 5 + Drive: j: drop
|
|
Screen 21 not modified
|
|
0 \ save memory-image as disk-file UH 29Nov86
|
|
1
|
|
2 Forth definitions
|
|
3
|
|
4 : savefile ( from count -- ) \ filename
|
|
5 isfile push makefile bounds
|
|
6 ?DO I dma! isfile@ >dosfcb write-seq Abort" disk full!"
|
|
7 b/rec +LOOP close ;
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 22 not modified
|
|
0 \ Status UH 10OCt87
|
|
1
|
|
2
|
|
3 : .blk ( -- ) blk @ ?dup 0=exit
|
|
4 dup 1 = IF cr file? THEN base push hex ." Blk " . ?cr ;
|
|
5
|
|
6 ' .blk Is .status
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 23 not modified
|
|
0
|
|
1
|
|
2
|
|
3
|
|
4
|
|
5
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 24 not modified
|
|
0
|
|
1
|
|
2
|
|
3
|
|
4
|
|
5
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 25 not modified
|
|
0
|
|
1
|
|
2
|
|
3
|
|
4
|
|
5
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 26 not modified
|
|
0
|
|
1
|
|
2
|
|
3
|
|
4
|
|
5
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 27 not modified
|
|
0
|
|
1
|
|
2
|
|
3
|
|
4
|
|
5
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 28 not modified
|
|
0
|
|
1
|
|
2
|
|
3
|
|
4
|
|
5
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 29 not modified
|
|
0
|
|
1
|
|
2
|
|
3
|
|
4
|
|
5
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 30 not modified
|
|
0
|
|
1
|
|
2
|
|
3
|
|
4
|
|
5
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|
|
Screen 31 not modified
|
|
0
|
|
1
|
|
2
|
|
3
|
|
4
|
|
5
|
|
6
|
|
7
|
|
8
|
|
9
|
|
10
|
|
11
|
|
12
|
|
13
|
|
14
|
|
15
|