From baabc46391d2a2d0a28d8d21360dd3cdac4afab6 Mon Sep 17 00:00:00 2001 From: Carsten Strotmann Date: Sun, 11 Apr 2021 23:38:30 +0200 Subject: [PATCH] Stripped file and block words, english translation --- 8086/pc-baremetal/kernel.fth | 613 +++-------------------------------- 1 file changed, 38 insertions(+), 575 deletions(-) diff --git a/8086/pc-baremetal/kernel.fth b/8086/pc-baremetal/kernel.fth index f268664..0b5af21 100644 --- a/8086/pc-baremetal/kernel.fth +++ b/8086/pc-baremetal/kernel.fth @@ -12,44 +12,43 @@ Port to C16 "ultraFORTH" by C.Vogt Port to 8088/86 and MS-DOS by K.Schleisiek dez 87 ( ----- 001 ) \ MS-DOS volksForth Load Screen ks cas 18jul20 + warning off \ disable warnings during compilation Onlyforth \needs Transient include meta.fb - 2 loadfrom META.fb new FORTH.COM Onlyforth Target definitions 4 &111 thru \ Standard 8088-System - + warning on flush \ close FORTH.COM -cr .( new kernel as "FORTH.COM" written) cr bell bye +cr .( new kernel as "FORTH.COM" written) cr bell ( bye ) ( ----- 002 ) -\\ Die Nutzung der 8088/86 Register ks 27 oct 86 +\\ The use of the 8088/86 register ks 27 oct 86 -Im Assembler sind Forthgemaesse Namen fuer die Register gewaehlt -Dabei ist die Zuordnung zu den Intel Namen folgendermassen: +The assembler uses forth style names for the register +The assiciation to the Intel register names: A <=> AX A- <=> AL A+ <=> AH C <=> CX C- <=> CL C+ <=> CH - Register A und C sind zur allgemeinen Benutzung frei + Register A and C are available for general use D <=> DX D- <=> DL D+ <=> DH - das oberste Element des (Daten)-Stacks. + the Top of (Data-) Stack (TOS) R <=> BX R- <=> RL R+ <=> RH - der Return_stack_pointer + the Return_stack_pointer ( ----- 003 ) -\\ Die Nutzung der 8088/86 Register ks 27 oct 86 +\\ The use of the 8088/86 register ks 27 oct 86 U <=> BP User_area_pointer S <=> SP Daten_stack_pointer I <=> SI Instruction_pointer -W <=> DI Word_pointer, im allgemeinen zur Benutzung frei. +W <=> DI Word_pointer, free for general use D: <=> DS E: <=> ES S: <=> SS C: <=> CS - Alle Segmentregister werden beim booten auf den Wert des - Codesegments C: gesetzt und muessen, wenn sie "verstellt" - werden, wieder auf C: zurueckgesetzt werden. + All segment registers are set to the value of code-segment + C: and must be restored to the same if changed in the code ( ----- 004 ) \ FORTH Preamble and ID ks 11 m„r 89 Assembler @@ -58,12 +57,12 @@ nop 5555 # jmp here 2- >label >cold nop 5555 # jmp here 2- >label >restart Create origin here origin! here $100 0 fill -\ Hier beginnen die Kaltstartwerte der Benutzervariablen +\ Coldstart valued for user variables $E9 int end-code -4 , $FC allot \ this is the multitasker initialization in the user area -| Create logo ," volksFORTH-83 rev. 3.81.41" +| Create logo ," volksFORTH-83 Version 3.9.3" ( ----- 005 ) \ Next ks 27 oct 86 @@ -74,8 +73,8 @@ Create origin here origin! here $100 0 fill : Next lods A W xchg W ) jmp there tnext-link @ T , H tnext-link ! ; -\ Next ist in-line code. Fuer den debugger werden daher alle -\ "nexts" in einer Liste mit dem Anker NEXT-LINK verbunden. +\ Next is in-line code. All "nexts" are linked into a +\ list with the anchor NEXT-LINK for the debugger : u' ( -- offset ) T ' 2+ c@ H ; @@ -99,9 +98,9 @@ Target Code noop here 2- ! end-code ( ----- 007 ) \ User variables ks 16 sep 88 - 8 uallot drop \ Platz fuer Multitasker - \ Felder: entry link spare SPsave - \ Laenge kompatibel zum 68000, 6502 und 8080 volksFORTH + 8 uallot drop \ Space for the multitasker + \ Fields: entry link spare SPsave + \ Length compatible to 68000, 6502 and 8080 volksFORTH User s0 User r0 User dp @@ -112,7 +111,7 @@ Target User errorhandler \ pointer for Abort" -code User aborted \ code address of latest error User voc-link - User file-link cr .( Wieso ist UDP Uservariable? ) + User file-link ( TODO: Why is UDP a user variable? ) User udp \ points to next free addr in User_area ( ----- 008 ) \ manipulate system pointers ks 03 aug 87 @@ -723,7 +722,7 @@ Label domove I W cmp moveup CS ?] A- W ) mov W inc C0= ?] ]? Next end-code -\\ high level, ohne Umlaute +\\ high level definition, without umlauts : capital ( char -- char') dup Ascii a [ Ascii z 1+ ] Literal @@ -757,10 +756,9 @@ swap ]? C >in #) add ( ----- 054 ) \ source word parse name ks 03 aug 87 - Variable loadfile loadfile off - - : source ( -- addr len ) blk @ ?dup - IF loadfile @ (block b/blk exit THEN tib #tib @ exit ; + defer source + : (source ( -- addr len ) tib #tib @ exit ; + ' source Is (source : word ( char -- addr ) source (word ; @@ -911,10 +909,10 @@ swap ]? C >in #) add : | ?head @ ?exit ?head on ; + \ no alignment required on x86 : even ( addr -- addr1 ) ; immediate : align ( -- ) ; immediate : halign ( -- ) ; immediate -\ machen nichts beim 8088. 8086 koennte etwas schneller werden Variable warning warning on @@ -1154,7 +1152,7 @@ Target Forth also definitions \ : ?stack sp@ here - $100 u< IF stackfull THEN \ sp@ s0 @ u> Abort" stack empty" ; ( ----- 080 ) -\ .status push load ks 29 oct 86 +\ .status push ks 29 oct 86 | Create: pull r> r> ! ; : push ( addr -- ) @@ -1162,27 +1160,13 @@ Target Forth also definitions Defer .status ' noop Is .status - : (load ( blk offset -- ) isfile@ >r - loadfile @ >r fromfile @ >r blk @ >r >in @ >r - >in ! blk ! isfile@ loadfile ! .status interpret - r> >in ! r> blk ! r> fromfile ! r> loadfile ! - r> isfile ! ; - : load ( blk -- ) ?dup 0=exit 0 (load ; ( ----- 081 ) -\ +load thru +thru --> rdepth depth ks 26 jul 87 - - : +load ( offset -- ) blk @ + load ; - - : thru ( from to -- ) 1+ swap DO I load LOOP ; - - : +thru ( off0 off1 -- ) 1+ swap DO I +load LOOP ; - - : --> 1 blk +! >in off .status ; immediate : rdepth ( -- +n ) r0 @ rp@ 2+ - 2/ ; : depth ( -- +n ) sp@ s0 @ swap - 2/ ; + ( ----- 082 ) \ prompt quit ks 16 sep 88 @@ -1272,18 +1256,11 @@ Target Forth also definitions : .s sp@ s0 @ over - $20 umin bounds ?DO I @ u. 2 +LOOP ; ( ----- 088 ) -\ list c/l l/s ks 19 m„r 88 +\ c/l l/s ks 19 m„r 88 &64 Constant c/l \ Screen line length &16 Constant l/s \ lines per screen - : list ( scr -- ) dup capacity u< - IF scr ! ." Scr " scr @ . - ." Dr " drv . isfile@ .file - l/s 0 DO cr I 2 .r space scr @ block - I c/l * + c/l -trailing type - LOOP cr exit - THEN 9 ?diskerror ; ( ----- 089 ) \ multitasker primitives ks 29 oct 86 @@ -1302,140 +1279,28 @@ Target Forth also definitions end-code $E9 4 * >label >taskINT ( ----- 090 ) -\\ Struktur der Blockpuffer ks 04 jul 87 - 0 : link zum naechsten Puffer - 2 : file 0 = direct access - -1 = leer, - sonst adresse eines file control blocks - 4 : blocknummer - 6 : statusflags Vorzeichenbit kennzeichnet update - 8 : Data ... 1 Kb ... ( ----- 091 ) -\ buffer mechanism ks 04 okt 87 - - Variable isfile isfile off \ addr of file control block - Variable fromfile fromfile off \ fcb in kopieroperationen - - Variable prev prev off \ Listhead -| Variable buffers buffers off \ Semaphor - + $10000 Constant limit Variable first $408 Constant b/buf \ physikalische Groesse $400 Constant b/blk \ bytes/block Defer r/w \ physikalischer Diskzugriff - Variable error# error# off \ Nummer des letzten Fehlers - Defer ?diskerror \ Fehlerbehandlung + ( ----- 092 ) -\ (core? ks 28 mai 87 - Code (core? ( blk file -- dataaddr / blk file ) - A pop A push D D or 0= ?[ u' offset U D) A add ]? - prev #) W mov 2 W D) D cmp 0= - ?[ 4 W D) A cmp 0= - ?[ 8 W D) D lea A pop ' exit @ # jmp ]? ]? - [[ [[ W ) C mov C C or 0= ?[ Next ]? - C W xchg 4 W D) A cmp 0= ?] 2 W D) D cmp 0= ?] - W ) A mov prev #) D mov D W ) mov W prev #) mov - 8 W D) D lea C W mov A W ) mov A pop - ' exit @ # jmp - end-code ( ----- 093 ) -\\ (core? ks 31 oct 86 -| : this? ( blk file bufadr -- flag ) - dup 4+ @ swap 2+ @ d= ; - - .( (core?: offset is handled differently in code! ) - -| : (core? ( blk file -- dataaddr / blk file ) - BEGIN over offset @ + over prev @ this? - IF rdrop 2drop prev @ 8 + exit THEN - 2dup >r offset @ + >r prev @ - BEGIN dup @ ?dup 0= IF rdrop rdrop drop exit THEN - dup r> r> 2dup >r >r rot this? 0= - WHILE nip REPEAT - dup @ rot ! prev @ over ! prev ! rdrop rdrop - REPEAT ; ( ----- 094 ) -\ backup emptybuf readblk ks 23 jul 87 -| : backup ( bufaddr -- ) dup 6+ @ 0< - IF 2+ dup @ 1+ \ buffer empty if file = -1 - IF BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w - WHILE 1 ?diskerror REPEAT - THEN 4+ dup @ $7FFF and over ! THEN - drop ; - - : emptybuf ( bufaddr -- ) 2+ dup on 4+ off ; - -| : readblk ( blk file addr -- blk file addr ) - dup emptybuf >r - BEGIN 2dup 0= offset @ and + - over r@ 8 + -rot 1 r/w - WHILE 2 ?diskerror REPEAT r> ; ( ----- 095 ) -\ take mark updates? full? core? ks 04 jul 87 -| : take ( -- bufaddr) prev - BEGIN dup @ WHILE @ dup 2+ @ -1 = UNTIL - buffers lock dup backup ; - -| : mark ( blk file bufaddr -- blk file ) 2+ >r - 2dup r@ ! over 0= offset @ and + r@ 2+ ! - r> 4+ off buffers unlock ; - -| : updates? ( -- bufaddr / flag) - prev BEGIN @ dup WHILE dup 6+ @ 0< UNTIL ; - - : core? ( blk file -- addr /false ) (core? 2drop false ; ( ----- 096 ) -\ block & buffer manipulation ks 01 okt 87 - : (buffer ( blk file -- addr ) - BEGIN (core? take mark REPEAT ; - - : (block ( blk file -- addr ) - BEGIN (core? take readblk mark REPEAT ; - - Code isfile@ ( -- addr ) - D push isfile #) D mov Next end-code -\ : isfile@ ( -- addr ) isfile @ ; - - : buffer ( blk -- addr ) isfile@ (buffer ; - - : block ( blk -- addr ) isfile@ (block ; ( ----- 097 ) -\ block & buffer manipulation ks 02 okt 87 - : update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ; - - : save-buffers buffers lock - BEGIN updates? ?dup WHILE backup REPEAT buffers unlock ; - - : empty-buffers buffers lock prev - BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ; - - : flush file-link - BEGIN @ ?dup WHILE dup fclose REPEAT - save-buffers empty-buffers ; ( ----- 098 ) -\ Allocating buffers ks 31 oct 86 - $10000 Constant limit Variable first - : allotbuffer ( -- ) - first @ r0 @ - b/buf 2+ u< ?exit - b/buf negate first +! first @ dup emptybuf - prev @ over ! prev ! ; - - : freebuffer ( -- ) first @ limit b/buf - u< - IF first @ backup prev - BEGIN dup @ first @ - WHILE @ REPEAT - first @ @ swap ! b/buf first +! THEN ; - - : all-buffers BEGIN first @ allotbuffer first @ = UNTIL ; - -| : init-buffers prev off limit first ! all-buffers ; ( ----- 099 ) \ endpoints of forget uh 27 apr 88 @@ -1483,7 +1348,7 @@ Target Forth also definitions Defer custom-remove ' noop Is custom-remove : trim ( dic symb -- ) next-link remove - over remove-tasks remove-vocs remove-words remove-files + over remove-tasks remove-vocs remove-words custom-remove heap swap - hallot dp ! last off ; ( ----- 102 ) \ deleting words from dict. ks 02 okt 87 @@ -1557,7 +1422,7 @@ Target Forth also definitions | : (cold origin up@ $100 cmove $80 count $50 umin >r tib r@ move r> #tib ! >in off blk off - init-vocabularys init-buffers flush 'cold + init-vocabularys 'cold Onlyforth page &24 spaces logo count type cr (restart ; ( ----- 107 ) \ (boot ks 11 m„r 89 @@ -1599,7 +1464,7 @@ Target Forth also definitions $21 int warmboot # call end-code - : bye flush empty page (bye ; + : bye empty page (bye ; ( ----- 110 ) \ cold ks 09 m„r 89 @@ -1616,7 +1481,7 @@ Target Forth also definitions ( ----- 111 ) \ System patchup ks 16 sep 88 - 1 &35 +thru \ MS-DOS interface + 1 &9 +thru \ MS-DOS interface : forth-83 ; \ last word in Dictionary @@ -1660,10 +1525,10 @@ Target Forth also definitions A D: mov D pop Next end-code ( ----- 114 ) \ BDOS keyboard input ks 16 sep 88 -\ es muss wirklich so kompliziert sein, da sonst kein ^C und ^P +\ it really needs to be this complicated, else ^C und ^P would +\ not work \\ | Variable newkey newkey off - Code (key@ ( -- 8b ) D push newkey #) D mov D+ D+ or 0= ?[ $7 # A+ mov $21 int A- D- mov ]? 0 # D+ mov D+ newkey 1+ #) mov Next @@ -1739,407 +1604,5 @@ Target Forth also definitions Output: display [ here output ! ] (emit (cr tipp (del (page (at (at? [ drop + ( ----- 120 ) -\ MSDOS printer I/O Port access ks 09 aug 87 - - Code lst! ( 8b -- ) $5 # A+ mov $21 int D pop Next - end-code - - Code pc@ ( port -- 8b ) - D byte in A- D- mov D+ D+ xor Next - end-code - - Code pc! ( 8b port -- ) - A pop D byte out D pop Next - end-code -( ----- 121 ) -\ zero terminated strings ks 09 aug 87 - - : counted ( asciz -- addr len ) - dup -1 0 scan drop over - ; - - : >asciz ( string addr -- asciz ) 2dup >r - - IF count r@ place r@ THEN 0 r> count + c! 1+ ; - - - - : asciz ( -- asciz ) name here >asciz ; -( ----- 122 ) -\ Disk capacities ks 08 aug 88 - Vocabulary Dos Dos also definitions - - 6 Constant #drives - - Create capacities $4B0 , $4B0 , $1B31 , $1B31 , $1B0F , 0 , - -| Code ?capacity ( +n -- cap ) D shl capacities # W mov - D W add W ) D mov Next end-code -( ----- 123 ) -\ MS-dos disk handlers direct access ks 31 jul 87 - -| Code block@ ( addr blk drv -- ff ) - D- A- mov D pop C pop R push U push - I push C R mov 2 # C mov D shl $25 int - Label end-r/w I pop I pop U pop R pop 0 # D mov - CS ?[ D+ A+ mov A error# #) mov D dec ]? Next - end-code - -| Code block! ( addr blk drv -- ff ) D- A- mov D pop - C pop R push U push I push C R mov 2 # C mov - D shl $26 int end-r/w # jmp - end-code -( ----- 124 ) -\ MS-dos disk handlers direct access ks cas 18jul20 - -| : ?drive ( +n -- +n ) dup #drives u< ?exit - Error" beyond drive capacity" ; - - : /drive ( blk1 -- blk2 drive ) 0 swap #drives 0 - DO dup I ?capacity under u< IF drop LEAVE THEN - - swap 1+ swap LOOP swap ; - - : blk/drv ( -- capacity ) drv ?capacity ; - - Forth definitions - - : >drive ( blk1 +n -- blk2 ) ?drive - 0 swap drv 2dup u> dup >r 0= IF swap THEN - ?DO I ?capacity + LOOP r> IF negate THEN - ; -( ----- 125 ) -\ MS-DOS file access ks 18 m„r 88 - Dos definitions - -| Variable fcb fcb off \ last fcb accessed -| Variable prevfile \ previous active file - - &30 Constant fnamelen \ default length in FCB - - Create filename &62 allot \ max 60 + count + null - - Variable attribut 7 attribut ! \ read-only, hidden, system -( ----- 126 ) -\ MS-DOS disk errors ks cas 18jul20 - -| : .error# ." error # " base push decimal error# @ . ; - -| : .ferrors error# @ &18 case? IF 2 THEN - 1 case? Abort" file exists" - 2 case? Abort" file not found" - 3 case? Abort" path not found" - 4 case? Abort" too many open files" - 5 case? Abort" no access" - 9 case? Abort" beyond end of file" - &15 case? Abort" illegal drive" - &16 case? Abort" current directory" - &17 case? Abort" wrong drive" - drop ." Disk" .error# abort ; -( ----- 127 ) -\ MS-DOS disk errors ks cas 18jul20 - - : (diskerror ( *f -- ) ?dup 0=exit - fcb @ IF error# ! .ferrors exit THEN - input push output push standardi/o 1- - IF ." read" ELSE ." write" THEN - .error# ." retry? (y/n)" - key cr capital Ascii Y = not Abort" aborted" ; - - ' (diskerror Is ?diskerror -( ----- 128 ) -\ ~open ~creat ~close ks 04 aug 87 - - Code ~open ( asciz mode -- handle ff / err# ) - A D xchg $3D # A+ mov - Label >open D pop $21 int A D xchg - CS not ?[ D push 0 # D mov ]? Next - end-code - - Code ~creat ( asciz attribut -- handle ff / err# ) - D C mov $3C # A+ mov >open ]] end-code - - Code ~close ( handle -- ) D R xchg - $3E # A+ mov $21 int R D xchg D pop Next - end-code -( ----- 129 ) -\ ~first ~unlink ~select ~disk? ks 04 aug 87 - - Code ~first ( asciz attr -- err# ) - D C mov D pop $4E # A+ mov - [[ $21 int 0 # D mov CS ?[ A D xchg ]? Next - end-code - - Code ~unlink ( asciz -- err# ) $41 # A+ mov ]] end-code - - Code ~select ( n -- ) - $E # A+ mov $21 int D pop Next end-code - - Code ~disk? ( -- n ) D push $19 # A+ mov - $21 int A- D- mov 0 # D+ mov Next - end-code -( ----- 130 ) -\ ~next ~dir ks 04 aug 87 - - Code ~next ( -- err# ) D push $4F # A+ mov - $21 int 0 # D mov CS ?[ A D xchg ]? Next - end-code - - Code ~dir ( addr drive -- err# ) I W mov - I pop $47 # A+ mov $21 int W I mov - 0 # D mov CS ?[ A D xchg ]? Next - end-code -( ----- 131 ) -\ MS-DOS file control Block cas 19jun20 - -| : Fcbytes ( n1 len -- n2 ) Create over c, + - Does> ( fcbaddr -- fcbfield ) c@ + ; - -\ first field for file-link -2 1 Fcbytes f.no \ must be first field - 2 Fcbytes f.handle - 2 Fcbytes f.date - 2 Fcbytes f.time - 4 Fcbytes f.size - fnamelen Fcbytes f.name Constant b/fcb - -b/fcb Host ' tb/fcb >body ! - Target Forth also Dos also definitions -( ----- 132 ) -\ (.file fname fname! ks 10 okt 87 - - : fname! ( string fcb -- ) f.name >r count - dup fnamelen < not Abort" file name too long" r> place ; - -| : filebuffer? ( fcb -- fcb bufaddr / fcb ff ) - prev BEGIN @ dup WHILE 2dup 2+ @ = UNTIL ; - -| : flushfile ( fcb -- ) - BEGIN filebuffer? ?dup - WHILE dup backup emptybuf REPEAT drop ; - - : fclose ( fcb -- ) ?dup 0=exit - dup f.handle @ ?dup 0= IF drop exit THEN - over flushfile ~close f.handle off ; -( ----- 133 ) -\ (.file fname fname! ks 18 m„r 88 - -| : getsize ( -- d ) [ $80 &26 + ] Literal 2@ swap ; - - : (fsearch ( string -- asciz *f ) - filename >asciz dup attribut @ ~first ; - - Defer fsearch ( string -- asciz *f ) - - ' (fsearch Is fsearch - -\ graceful behaviour if file does not exist -| : ?notfound ( f* -- ) ?dup 0=exit last' @ [fcb] = - IF hide file-link @ @ file-link ! prevfile @ setfiles - last @ 4 - dp ! last off filename count here place - THEN ?diskerror ; -( ----- 134 ) -\ freset fseek ks 19 m„r 88 - - : freset ( fcb -- ) ?dup 0=exit - dup f.handle @ ?dup IF ~close THEN dup >r - f.name fsearch ?notfound getsize r@ f.size 2! - [ $80 &22 + ] Literal @ r@ f.time ! - [ $80 &24 + ] Literal @ r@ f.date ! - 2 ~open ?diskerror r> f.handle ! ; - - - Code fseek ( dfaddr fcb -- ) - D W mov u' f.handle W D) W mov W W or 0= - ?[ ;c: dup freset fseek ; Assembler ]? R W xchg - C pop D pop $4200 # A mov $21 int W R mov - CS not ?[ D pop Next ]? A D xchg ;c: ?diskerror ; -( ----- 135 ) -\ lfgets fgetc file@ ks 07 jul 88 - -\ Code ~read ( seg:addr quan handle -- #read ) D W mov -Assembler [[ W R xchg C pop D pop - D: pop $3F # A+ mov $21 int C: C mov C D: mov - W R mov A D xchg CS not ?[ Next ]? ;c: ?diskerror ; - - Code lfgets ( seg:addr quan fcb -- #read ) - D W mov u' f.handle W D) W mov ]] end-code - - true Constant eof - - : fgetc ( fcb -- 8b / eof ) - >r 0 sp@ ds@ swap 1 r> lfgets ?exit 0= ; - - : file@ ( dfaddr fcb -- 8b / eof ) dup >r fseek r> fgetc ; -( ----- 136 ) -\ lfputs fputc file! ks 24 jul 87 - -| Code ~write ( seg:addr quan handle -- ) D W mov -[[ W R xchg C pop D pop - D: pop $40 # A+ mov $21 int W R mov A D xchg - C: W mov W D: mov CS ?[ ;c: ?diskerror ; Assembler ]? - C D sub 0= ?[ D pop Next ]? ;c: Abort" Disk voll" ; - - Code lfputs ( seg:addr quan fcb -- ) - D W mov u' f.handle W D) W mov ]] end-code - - : fputc ( 8b fcb -- ) >r sp@ ds@ swap 1 r> lfputs drop ; - - : file! ( 8b dfaddr fcb -- ) dup >r fseek r> fputc ; -( ----- 137 ) -\ /block *block ks 02 okt 87 - - Code /block ( d -- rest blk ) A D xchg C pop - C D mov A shr D rcr A shr D rcr D+ D- mov - A- D+ xchg $3FF # C and C push Next - end-code -\ : /block ( d -- rest blk ) b/blk um/mod ; - - Code *block ( blk -- d ) A A xor D+ D- xchg D+ A+ xchg - A+ sal D rcl A+ sal D rcl A push Next - end-code -\ : *block ( blk -- d ) b/blk um* ; -( ----- 138 ) -\ fblock@ fblock! ks 19 m„r 88 - Dos definitions - -| : ?beyond ( blk -- blk ) dup 0< 0=exit 9 ?diskerror ; - -| : fblock ( addr blk fcb -- seg:addr quan fcb ) - fcb ! ?beyond dup *block fcb @ fseek ds@ -rot - fcb @ f.size 2@ /block rot - ?beyond - IF drop b/blk THEN fcb @ ; - - : fblock@ ( addr blk fcb -- ) fblock lfgets drop ; - - : fblock! ( addr blk fcb -- ) fblock lfputs ; -( ----- 139 ) -\ (r/w flush ks 18 m„r 88 - Forth definitions - - : (r/w ( addr blk fcb r/wf -- *f ) over fcb ! over - IF IF fblock@ false exit THEN fblock! false exit - THEN >r drop /drive ?drive - r> IF block@ exit THEN block! ; - - ' (r/w Is r/w - -| : setfiles ( fcb -- ) isfile@ prevfile ! - dup isfile ! fromfile ! ; - - : direct 0 setfiles ; -( ----- 140 ) -\ File >file ks 23 m„r 88 - - : File Create file-link @ here file-link ! , - here [ b/fcb 2 - ] Literal dup allot erase - file-link @ dup @ f.no c@ 1+ over f.no c! - last @ count $1F and rot f.name place - Does> setfiles ; - - File kernel.scr ' kernel.scr @ Constant [fcb] - - Dos definitions - - : .file ( fcb -- ) - ?dup IF body> >name .name exit THEN ." direct" ; -( ----- 141 ) -\ .file pushfile close open ks 12 mai 88 - Forth definitions - - : file? isfile@ .file ; - - : pushfile r> isfile push fromfile push >r ; restrict - - : close isfile@ fclose ; - - : open isfile@ freset ; - - : assign isfile@ dup fclose name swap fname! open ; -( ----- 142 ) -\ use from loadfrom include ks 18 m„r 88 - - : use >in @ name find - 0= IF swap >in ! File last' THEN nip - dup @ [fcb] = over ['] direct = or - 0= Abort" not a file" execute open ; - - : from isfile push use ; - - : loadfrom ( n -- ) pushfile use load close ; - - : include 1 loadfrom ; -( ----- 143 ) -\ drive drv capacity drivenames ks 18 m„r 88 - - : drive ( n -- ) isfile@ IF ~select exit THEN - ?drive offset off 0 ?DO I ?capacity offset +! LOOP ; - - : drv ( -- n ) - isfile@ IF ~disk? exit THEN offset @ /drive nip ; - - : capacity ( -- n ) isfile@ ?dup - IF dup f.handle @ 0= IF dup freset THEN - f.size 2@ /block swap 0<> - exit THEN blk/drv ; - -| : Drv: Create c, Does> c@ drive ; - - 0 Drv: A: 1 Drv: B: 2 Drv: C: 3 Drv: D: - 4 Drv: E: 5 Drv: F: 6 Drv: G: 7 Drv: H: -( ----- 144 ) -\ lfsave savefile savesystem ks 10 okt 87 - - : lfsave ( seg:addr quan string -- ) - filename >asciz 0 ~creat ?diskerror - dup >r ~write r> ~close ; - - : savefile ( addr len -- ) ds@ -rot - name nullstring? Abort" needs name" lfsave ; - - : savesystem save flush $100 here savefile ; -( ----- 145 ) -\ viewing ks 19 m„r 88 - Dos definitions -| $400 Constant viewoffset - - : (makeview ( -- n ) - blk @ dup 0=exit loadfile @ ?dup 0=exit f.no c@ ?dup - IF viewoffset * + $8000 or exit THEN 0= ; - ' (makeview Is makeview - - : @view ( acf -- blk fno ) >name 4 - @ dup 0< - IF $7FFF and viewoffset u/mod exit THEN - ?dup 0= Error" eingetippt" 0 ; - - : >file ( fno -- fcb ) dup 0=exit file-link - BEGIN @ dup WHILE 2dup f.no c@ = UNTIL nip ; -( ----- 146 ) -\ forget FCB's ks 23 okt 88 - Forth definitions -| : 'file ( -- scr ) r> scr push isfile push >r - [ Dos ] ' @view >file isfile ! ; - - : view 'file list ; - : help 'file capacity 2/ + list ; - -| : remove? ( dic symb addr -- dic symb addr f ) - 2 pick over 1+ u< ; - -| : remove-files ( dic symb -- dic symb ) file-link - BEGIN @ ?dup WHILE remove? IF dup fclose THEN REPEAT - file-link remove - isfile@ remove? nip IF file-link @ isfile ! THEN - fromfile @ remove? nip 0=exit isfile@ fromfile ! ; -( ----- 147 ) -\ BIOS keyboard input ks 16 sep 88 - - Code (key@ ( -- 8b ) D push A+ A+ xor $16 int - 0 # D+ mov A- D- mov A- A- or - 0= ?[ A+ D- mov D+ com ]? Next end-code - - : test BEGIN (key@ #esc case? ?exit - cr dup emit 5 .r key 5 .r REPEAT ; -\\ - Code (key? ( -- f ) D push 1 # A+ mov D D xor - $16 int 0= not ?[ D dec ]? Next end-code - - Code empty-keys $C00 # A mov $21 int Next end-code - - : (key ( -- 8b ) BEGIN pause (key? UNTIL (key@ ;