\ *** Block No. 0, Hexblock 0 \ CP/M 2.2 File-Interface (3.80a) UH 05Oct87 \ Dieses File enthaelt das File-Interface von volksFORTH zu CP/M. \ Damit ist Zugriff auf normale CP/M-Files moeglich. \ Wenn ein File mit USE benutzt wird, beziehen sich alle Worte, \ die mit dem Massenspeicher arbeiten, auf dieses File. \ Benutzung: \ USE \ benutze ein schon existierendes File \ FILE \ erzeuge ein Forthfile mit dem Namen . \ MAKE \ Erzeuge ein File mit und ordne \ \ es dem aktuellen Forthfile zu. \ MAKEFILE \ Erzeuge ein File mit CP/M und FORTH-Namen \ . \ INCLUDE \ Lade File mit Forthnamen ab Screen 1 \ DOS RESET \ zum Wechsel von Disketten. (Oh! CP/M) \ *** Block No. 1, Hexblock 1 \ CP/M 2.2 File-Interface load-Screen UH 18Feb88 OnlyForth \ 2 load \ view numbers for this file \ 3 4 thru \ DOS File Functions \ 5 $11 thru \ Forth File Functions \ $12 $16 thru \ User Interface \ File source.fb \ Define already existing Files \ File fileint.fb File startup.fbr \ ' (makeview Is makeview \ ' remove-files Is custom-remove \ ' file-r/w Is r/w \ ' noop Is drvinit \ include startup.fb \ load Standard System \ *** Block No. 3, Hexblock 3 \ File Control Blocks UH 18Feb88 Dos definitions also | : Fcbyte ( n len -- len' ) Create over c, + does> c@ + ; &11 Constant filenamelen 0 2 | Fcbyte nextfile immediate 1 Fcbyte drive ' drive | Alias >dosfcb filenamelen 3 - Fcbyte filename 3 Fcbyte extension &21 + \ ex, s1, s2, rc, d0, ... dn, cr 2 Fcbyte record \ r0, r1 1+ \ r2 2 Fcbyte opened 2 Fcbyte fileno 2 Fcbyte filesize \ in 128-Byte-Records 4 Fcbyte position Constant b/fcb \ *** Block No. 4, Hexblock 4 \ dos primitives UH 10Oct87 ' 2- | Alias body> ' 2- | Alias dosfcb> : drive! ( drv -- ) $0E bdos ; : search0 ( dosfcb -- dir ) $11 bdosa ; : searchnext ( dosfcb -- dir ) $12 bdosa ; : createfile ( dosfcb -- f ) $16 bdosa dos-error? ; : size ( dos -- size ) dup $23 bdos dosfcb> record @ ; : drive@ ( -- drv ) 0 $19 bdosa ; : killfile ( dosfcb -- ) $13 bdos ; \ *** Block No. 5, Hexblock 5 \ File sizes UH 05Oct87 : (capacity ( fcb -- n ) \ filecapacity in blocks filesize @ rec/blk u/mod swap 0= ?exit 1+ ; : in-range ( block fcb -- ) (capacity u< not Abort" beyond capacity!" ; Forth definitions : capacity ( -- n ) isfile@ (capacity ; Dos definitions \ *** Block No. 6, Hexblock 6 \ (open UH 18Feb88 : (open ( fcb -- ) dup opened @ IF drop exit THEN dup position 0. rot 2! dup >dosfcb openfile Abort" not found!" dup opened on dup >dosfcb size swap filesize ! ; : (make ( fcb -- ) dup >dosfcb killfile dup >dosfcb createfile Abort" directory full!" dup position 0. rot 2! dup filesize off opened on offset off ; \ *** Block No. 7, Hexblock 7 \ Print Filenames UH 10Oct87 : .file ( fcb -- ) 0 case? IF ." DIRECT" exit THEN fcb dosfcb> case? IF ." DEFAULT" exit THEN body> >name .name ; : .drive ( fcb -- ) drive c@ ?dup 0=exit [ Ascii A 1- ] Literal + emit Ascii : emit ; : .dosfile ( fcb -- ) dup filename 8 -trailing type Ascii . emit extension 3 type ; \ *** Block No. 8, Hexblock 8 \ Print Filenames UH 10Oct87 : tab ( -- ) col &59 > IF cr exit THEN &20 col &20 mod - 0 max spaces ; : .fcb ( fcb -- ) dup fileno @ 3 u.r tab dup .file tab dup .drive dup .dosfile tab dup opened @ IF ." opened" ELSE ." closed" THEN 3 spaces base push decimal (capacity 3 u.r ." kB" ; \ *** Block No. 9, Hexblock 9 \ Filenames UH 05Oct87 : !name ( addr len fcb -- ) dup >r filename filenamelen bl fill over 1+ c@ Ascii : = IF over c@ [ Ascii A 1- ] Literal - >r 2 /string r> ELSE 0 THEN r@ drive c! r> dup filename 2swap filenamelen 1+ min bounds ?DO I c@ Ascii . = IF drop dup extension ELSE I c@ over c! 1+ THEN LOOP 2drop ; : !fcb ( fcb -- ) dup opened off name count rot !name ; \ *** Block No. 10, Hexblock a \ Print Directory UH 18Nov87 | Create dirbuf b/rec allot dirbuf b/rec erase | Create fcb0 b/fcb allot fcb0 b/fcb erase | : wildchard? ( f c -- f' ) Ascii * = IF drop Ascii ? THEN ; | : (expand ( addr len -- ) false -rot bounds ?DO I c@ wildchard? dup ?dup IF I c! THEN LOOP drop ; | : expand ( fcb -- ) \ expand * to ??? dup filename 8 (expand extension 3 (expand ; : (dir ( addr len -- ) fcb0 !name fcb0 expand dirbuf dma! fcb0 >dosfcb search0 BEGIN dup dos-error? not WHILE $20 * dirbuf + dosfcb> tab .dosfile fcb0 >dosfcb searchnext stop? UNTIL drop ; \ *** Block No. 11, Hexblock b \ File List UH 10Oct87 User file-link file-link off | : #file ( -- n ) file-link @ dup IF fileno c@ THEN 1+ ; Forth definitions : forthfiles ( -- ) file-link @ BEGIN dup WHILE cr dup .fcb @ stop? UNTIL drop ; Dos definitions \ *** Block No. 12, Hexblock c \ Close a file UH 10Oct87 Defer flushfile ' noop is flushfile : (close ( fcb -- ) \ close file in fcb dup flushfile dup opened dup @ 0= IF 2drop exit THEN off >dosfcb closefile Abort" not found!" ; \ *** Block No. 13, Hexblock d \ Create fcbs UH 10Oct87 : !files ( fcb -- ) dup isfile ! fromfile ! ; ' r@ | Alias newfcb Forth definitions : File ( -- ) Create here >r b/fcb allot newfcb b/fcb erase last @ count $1F and newfcb !name #file newfcb fileno ! file-link @ newfcb nextfile ! r> file-link ! Does> !files ; : direct 0 !files ; \ *** Block No. 14, Hexblock e \ flush buffers & misc. UH 10Oct87 UH 28Nov87 Dos definitions : save-files ( -- ) file-link BEGIN @ ?dup WHILE dup opened @ IF dup >dosfcb closefile drop THEN REPEAT ; ' save-files Is save-dos-buffers \ : close-files ( -- ) file-link \ BEGIN @ ?dup WHILE dup (close REPEAT ; Forth definitions : file? isfile@ .file ; \ print current file \ *** Block No. 16, Hexblock 10 \ FORGETing files UH 10Oct87 | : remove? ( dic symb addr -- dic symb addr f ) dup heap? IF 2dup u> exit THEN 2 pick over 1+ u< ; | : remove-files ( dic symb -- dic symb ) \ flush files ! isfile@ remove? nip IF direct THEN fromfile @ remove? nip IF fromfile off THEN file-link BEGIN @ ?dup WHILE remove? IF dup (close THEN REPEAT file-link remove ; \ *** Block No. 18, Hexblock 12 \ File Interface User words UH 11Oct87 | : same ( addr -- ) >in ! ; : open isfile@ (open offset off ; : close isfile@ (close ; : assign close isfile@ !fcb open ; : make isfile@ dup !fcb (make ; | : isfile? ( addr -- addr f ) \ is adr a fcb? file-link BEGIN @ dup 0=exit 2dup body> = UNTIL drop true ; : use >in @ name find \ create a fcb if not present IF isfile? IF execute drop exit THEN THEN drop dup same File same ' execute open ; \ *** Block No. 19, Hexblock 13 \ File Interface User words UH 25May88 : makefile >in @ File dup same ' execute same make ; : emptyfile isfile@ >dosfcb createfile ; : from isfile push use ; : include ( -- ) increc-offset push isfile push fromfile push use cr file? include-isfile incfile @ IF increc @ incfile @ cr+ex! incfile @ increadrec Abort" error re-reading after include" THEN ; : eof ( -- f ) isfile@ dup filesize @ swap record @ = ; : files " *.*" count (dir ; : files" Ascii " word count 2dup upper (dir ; ' files Alias dir ' files" Alias dir" \ *** Block No. 20, Hexblock 14 \ extend Files UH 20Nov87 | : >fileend isfile@ >dosfcb size drop ; : Drive: ( n -- n' ) dup Constant 1+ Does> @ drive! ; 0 Drive: a: Drive: b: Drive: c: Drive: d: 5 + Drive: j: drop \ *** Block No. 21, Hexblock 15 \ save memory-image as disk-file UH 29Nov86 Forth definitions : savefile ( from count -- ) \ filename isfile push makefile bounds ?DO I dma! isfile@ >dosfcb write-seq Abort" disk full!" b/rec +LOOP close ; ' remove-files Is custom-remove ' noop Is drvinit