mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-11-22 20:34:07 +00:00
545 lines
34 KiB
Forth
545 lines
34 KiB
Forth
|
\ *** 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 <name> \ benutze ein schon existierendes File
|
||
|
|
FILE <name> \ erzeuge ein Forthfile mit dem Namen <name>.
|
||
|
|
MAKE <name> \ Erzeuge ein File mit <name> und ordne
|
||
|
|
\ es dem aktuellen Forthfile zu.
|
||
|
|
MAKEFILE <name> \ Erzeuge ein File mit CP/M und FORTH-Namen
|
||
|
|
<name>.
|
||
|
|
INCLUDE <name> \ Lade File mit Forthnamen <name> 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. 2 Hexblock 2
|
||
|
|
\ Build correct view-numbers for this file UUH 19Nov87
|
||
|
|
|
||
|
|
| : fileintview ( -- ) $400 blk @ + ;
|
||
|
|
|
||
|
|
' fileintview Is makeview
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** 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 ;
|
||
|
|
: read-seq ( dosfcb -- f ) $14 bdosa dos-error? ;
|
||
|
|
: write-seq ( dosfcb -- f ) $15 bdosa dos-error? ;
|
||
|
|
: 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 ;
|
||
|
|
|
||
|
|
: file-r/w ( buffer block fcb f -- f )
|
||
|
|
over 0= Abort" no Direct Disk IO supported! "
|
||
|
|
>r dup (open 2dup in-range r> (r/w ;
|
||
|
|
\ *** 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
|
||
|
|
|
||
|
|
' save-buffers >body $0C + @ | Alias backup
|
||
|
|
|
||
|
|
| : filebuffer? ( fcb -- fcb bufaddr/flag )
|
||
|
|
prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ;
|
||
|
|
|
||
|
|
| : flushfile ( fcb -- ) \ flush file buffers
|
||
|
|
BEGIN filebuffer? ?dup WHILE
|
||
|
|
dup backup emptybuf REPEAT drop ;
|
||
|
|
|
||
|
|
: (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
|
||
|
|
|
||
|
|
: list ( n -- ) 3 spaces file? list ;
|
||
|
|
\ *** Block No. 15 Hexblock F
|
||
|
|
\ words for viewing UH 10Oct87
|
||
|
|
|
||
|
|
Forth definitions
|
||
|
|
|
||
|
|
| $200 Constant viewoffset \ max. %512 kB files
|
||
|
|
|
||
|
|
: (makeview ( -- n ) \ calc. view filed for a name
|
||
|
|
blk @ dup 0= ?exit
|
||
|
|
loadfile @ ?dup IF fileno @ viewoffset * + THEN ;
|
||
|
|
|
||
|
|
: (view ( blk -- blk' ) \ select file and leave block
|
||
|
|
dup 0=exit
|
||
|
|
viewoffset u/mod file-link
|
||
|
|
BEGIN @ dup WHILE 2dup fileno @ = UNTIL
|
||
|
|
!files drop ; \ not found: direct access
|
||
|
|
|
||
|
|
\ *** 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. 17 Hexblock 11
|
||
|
|
\ print a list of all buffers UH 20Oct86
|
||
|
|
|
||
|
|
: .buffers
|
||
|
|
prev BEGIN @ ?dup WHILE stop? abort" stopped"
|
||
|
|
cr dup u. dup 2+ @ dup 1+
|
||
|
|
IF ." Block: " over 4+ @ 5 .r
|
||
|
|
." File : " [ Dos ] .file
|
||
|
|
dup 6 + @ 0< IF ." updated" THEN
|
||
|
|
ELSE ." Buffer empty" drop THEN REPEAT ;
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** 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 ;
|
||
|
|
: loadfrom ( n -- )
|
||
|
|
isfile push fromfile push use load close ;
|
||
|
|
: include 1 loadfrom ;
|
||
|
|
|
||
|
|
: 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 ;
|
||
|
|
|
||
|
|
| : addblock ( n -- ) \ add block n to file
|
||
|
|
dup buffer under b/blk bl fill
|
||
|
|
isfile@ rec/blk over filesize +! false file-r/w
|
||
|
|
IF close Abort" disk full!" THEN ;
|
||
|
|
|
||
|
|
: more ( n -- ) open >fileend
|
||
|
|
capacity swap bounds ?DO I addblock LOOP close
|
||
|
|
open close ;
|
||
|
|
|
||
|
|
: 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 ;
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 22 Hexblock 16
|
||
|
|
\ Status UH 10OCt87
|
||
|
|
|
||
|
|
|
||
|
|
: .blk ( -- ) blk @ ?dup 0=exit
|
||
|
|
dup 1 = IF cr file? THEN base push hex ." Blk " . ?cr ;
|
||
|
|
|
||
|
|
' .blk Is .status
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 23 Hexblock 17
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 24 Hexblock 18
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 25 Hexblock 19
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 26 Hexblock 1A
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 27 Hexblock 1B
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 28 Hexblock 1C
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 29 Hexblock 1D
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 30 Hexblock 1E
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
\ *** Block No. 31 Hexblock 1F
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|
||
|
|
|