VolksForth/sources/cpm/FILEINT.FB.src
Carsten Strotmann 3dd6197fbf CPM Source files
2020-06-20 18:59:14 +02:00

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.scr \ Define already existing Files
9 File fileint.scr File startup.scr
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.scr \ 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