mirror of
https://github.com/forth-ev/VolksForth.git
synced 2024-12-22 06:29:17 +00:00
Update cpmfiles
This commit is contained in:
Philip Zembrod
parent
3b2a10550c
commit
24b745e6a4
@ -1,35 +0,0 @@
|
||||
\ From: John Hayes S1I
|
||||
\ Subject: core.fr
|
||||
\ Date: Mon, 27 Nov 95 13:10
|
||||
|
||||
\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY
|
||||
\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS.
|
||||
\ VERSION 1.2
|
||||
\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM.
|
||||
\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE
|
||||
\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND
|
||||
\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1.
|
||||
\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"...
|
||||
\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?...
|
||||
|
||||
CR
|
||||
TESTING CORE WORDS
|
||||
HEX
|
||||
|
||||
\ ------------------------------------------------------------------------
|
||||
TESTING INPUT: ACCEPT
|
||||
|
||||
CREATE ABUF 50 CHARS ALLOT
|
||||
|
||||
: ACCEPT-TEST
|
||||
CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR
|
||||
ABUF 50 ACCEPT
|
||||
CR ." RECEIVED: " [CHAR] " EMIT
|
||||
ABUF SWAP TYPE [CHAR] " EMIT CR
|
||||
;
|
||||
|
||||
T{ ACCEPT-TEST -> }T
|
||||
|
||||
CR .( End of Core input word set tests) CR
|
||||
|
||||
|
||||
@ -1,10 +0,0 @@
|
||||
|
||||
\needs (type include extend.fb include multi.vid include dos.fb
|
||||
include log2file.fb
|
||||
logopen output.log
|
||||
|
||||
.( hello, world) cr
|
||||
: test-hello ." hello, world, from test-hello" cr ;
|
||||
test-hello
|
||||
|
||||
logclose
|
||||
@ -1,78 +0,0 @@
|
||||
|
||||
|
||||
\ Experimental code and test for text logs that can be closed
|
||||
\ and reopened for appending.
|
||||
\ Already integrated into log2file.fb/.fth
|
||||
\ Yet to be done: A more permanent test for m+!
|
||||
\ and an extension of logtest.fb/.fth to also cover the reopen feature.
|
||||
|
||||
|
||||
\ Code +! ( 16b addr -- )
|
||||
\ D W mov A pop A W ) add D pop Next end-code
|
||||
|
||||
Code m+! ( 16b addr -- )
|
||||
D W mov W inc W inc A pop A W ) add
|
||||
CS ?[ W dec W dec W ) inc ]?
|
||||
D pop Next end-code
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 2, Hexblock 2
|
||||
|
||||
\ log-type log-emit log-cr alsologtofile phz 04jan22
|
||||
context @ dos also context !
|
||||
\ vocabulary log dos also log definitions
|
||||
file logfile
|
||||
variable logfcb
|
||||
variable logpos 0 ,
|
||||
|
||||
: log-type
|
||||
dup logpos m+!
|
||||
2dup (type ds@ -rot logfcb @ lfputs ;
|
||||
|
||||
: log-emit
|
||||
1 logpos m+!
|
||||
dup (emit logfcb @ fputc ;
|
||||
|
||||
: log-cr
|
||||
2 logpos m+!
|
||||
(cr #cr logfcb @ fputc #lf logfcb @ fputc ;
|
||||
|
||||
Output: alsologtofile
|
||||
log-emit log-cr log-type (del (page (at (at? ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 3, Hexblock 3
|
||||
|
||||
\ logopen logclose phz 11jan22
|
||||
|
||||
: logopen ( -- )
|
||||
isfile push logpos dup 2+ off off
|
||||
logfile make isfile@ dup freset logfcb !
|
||||
alsologtofile ;
|
||||
|
||||
: logclose ( -- ) display logfcb @ fclose ;
|
||||
|
||||
: logreopen ( -- )
|
||||
logfcb @ freset logpos 2@ logfcb @ fseek
|
||||
alsologtofile ;
|
||||
|
||||
logopen output.log
|
||||
.( logtest started) cr
|
||||
logpos @ cr u. cr
|
||||
.( logtest interrupted) cr
|
||||
logclose
|
||||
logreopen
|
||||
create 2v 4 allot
|
||||
hex
|
||||
12345. 2v 2!
|
||||
1 2v m+!
|
||||
2v 2@ d. cr
|
||||
1ffff. 2v 2!
|
||||
1 2v m+!
|
||||
2v 2@ d. cr
|
||||
.( logtest done) cr
|
||||
logclose
|
||||
50
8080/CPM/cpmfiles/logfile.fth
Normal file
50
8080/CPM/cpmfiles/logfile.fth
Normal file
@ -0,0 +1,50 @@
|
||||
|
||||
\ *** Block No. 2, Hexblock 2
|
||||
|
||||
\ logfile phz 20aug23
|
||||
|
||||
Dos also Forth definitions
|
||||
|
||||
$18 constant fcb\nam
|
||||
create logfile ," LOGFILE TXT" fcb\nam allot 1 logfile c!
|
||||
create logdma b/rec allot
|
||||
variable logoffset 0 logoffset !
|
||||
|
||||
: logflush logdma dma! logfile $15 bdos $80 dma! ;
|
||||
|
||||
: logc! ( c -- )
|
||||
logoffset @ dup >r logdma + c! r> 1+
|
||||
dup logoffset ! b/rec =
|
||||
IF logflush 0 logoffset ! THEN ;
|
||||
|
||||
|
||||
\ *** Block No. 3, Hexblock 3
|
||||
|
||||
\ log-emit log-type log-cr alsologtofile pphz 03sep23
|
||||
|
||||
: log-emit ( char -- )
|
||||
dup (emit logc! ;
|
||||
|
||||
: log-type ( addr count -- )
|
||||
0 ?DO count log-emit LOOP drop ;
|
||||
|
||||
: log-cr ( -- )
|
||||
(cr #cr logc! #lf logc! ;
|
||||
|
||||
Output: alsologtofile
|
||||
log-emit log-cr log-type (del noop 2drop (at? ;
|
||||
|
||||
|
||||
\ *** Block No. 4, Hexblock 4
|
||||
|
||||
\ logopen phz 20aug23
|
||||
|
||||
: logopen ( -- )
|
||||
logfile filenamelen + 1+ fcb\nam erase
|
||||
0 logoffset !
|
||||
logfile killfile
|
||||
logfile createfile
|
||||
alsologtofile ;
|
||||
|
||||
: logclose ( -- )
|
||||
cr display &26 logc! logflush logfile closefile ;
|
||||
@ -1,14 +0,0 @@
|
||||
|
||||
include extend2.fth
|
||||
\needs drv : drv 2 ; \ showing C: if drv isn't defined
|
||||
include multivid.fth
|
||||
|
||||
\ : .blk|tib
|
||||
\ blk @ ?dup IF ." Blk " u. ?cr exit THEN
|
||||
\ incfile @ IF tib #tib @ cr type THEN ;
|
||||
|
||||
\ ' .blk|tib Is .status
|
||||
|
||||
\ include dos2.fth
|
||||
include dos3.fth
|
||||
include log2file.fth
|
||||
@ -1,38 +0,0 @@
|
||||
|
||||
\ *** Block No. 0, Hexblock 0
|
||||
|
||||
\ logtest.fb phz 04jan22
|
||||
|
||||
basic tests for log2file.fb
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 1, Hexblock 1
|
||||
|
||||
\ loadscreen phz 22jan22
|
||||
|
||||
include log2file.fb
|
||||
|
||||
logopen output.log
|
||||
.( logtest done) cr
|
||||
logclose
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
86
8080/CPM/cpmfiles/sblkint.fth
Normal file
86
8080/CPM/cpmfiles/sblkint.fth
Normal file
@ -0,0 +1,86 @@
|
||||
|
||||
Dos definitions
|
||||
|
||||
: 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 ;
|
||||
|
||||
\ backup was made visible in vf-blk.fth so no need to peek its address
|
||||
\ ' (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 ;
|
||||
|
||||
' (flushfile is flushfile
|
||||
|
||||
Forth definitions
|
||||
|
||||
: 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. 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 ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
: loadfrom ( n -- )
|
||||
isfile push fromfile push use load close ;
|
||||
|
||||
| : 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 ;
|
||||
|
||||
\ *** 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
|
||||
|
||||
' (makeview Is makeview
|
||||
' file-r/w Is r/w
|
||||
|
||||
334
8080/CPM/cpmfiles/sfileint.fth
Normal file
334
8080/CPM/cpmfiles/sfileint.fth
Normal file
@ -0,0 +1,334 @@
|
||||
|
||||
\ *** 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. 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
|
||||
Binary file not shown.
@ -1,5 +1,5 @@
|
||||
|
||||
include log2file.fb
|
||||
include logfile.fth
|
||||
' noop Is .status
|
||||
logopen
|
||||
|
||||
|
||||
22
8080/CPM/cpmfiles/test-krn.fth
Normal file
22
8080/CPM/cpmfiles/test-krn.fth
Normal file
@ -0,0 +1,22 @@
|
||||
|
||||
include log2file.fb
|
||||
logopen
|
||||
|
||||
include ans-shim.fth
|
||||
: \vf [compile] \ ; immediate
|
||||
|
||||
include prelim.fth
|
||||
include tester.fth
|
||||
|
||||
\ 1 verbose !
|
||||
include core.fr
|
||||
include coreplus.fth
|
||||
|
||||
include util.fth
|
||||
include errorrep.fth
|
||||
|
||||
include coreext.fth
|
||||
|
||||
REPORT-ERRORS
|
||||
|
||||
logclose
|
||||
@ -1,5 +1,5 @@
|
||||
|
||||
include log2file.fb
|
||||
include logfile.fth
|
||||
logopen
|
||||
|
||||
include ans-shim.fth
|
||||
|
||||
@ -3,7 +3,7 @@
|
||||
\ blk @ ?dup IF ." Blk " u. ?cr exit THEN
|
||||
\ incfile @ IF tib #tib @ cr type THEN ;
|
||||
|
||||
include log2file.fb
|
||||
include logfile.fth
|
||||
logopen
|
||||
|
||||
include ans-shim.fth
|
||||
|
||||
@ -1,38 +0,0 @@
|
||||
|
||||
\ *** Block No. 0, Hexblock 0
|
||||
|
||||
\ include file to bundle what test-*.fth need phz 30jan22
|
||||
\ on top of kernel.com
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 1, Hexblock 1
|
||||
|
||||
\ loadscreen to prepare kernel.com for test-*.fth phz 30jan22
|
||||
|
||||
include extend.fb
|
||||
include multi.vid
|
||||
include dos.fb
|
||||
include include.fb
|
||||
include log2file.fb
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
Binary file not shown.
@ -1,13 +1,13 @@
|
||||
|
||||
Onlyforth
|
||||
$9000 displace !
|
||||
$8000 displace !
|
||||
Target definitions $100 here!
|
||||
|
||||
include vf-core.fth
|
||||
include vf-io.fth
|
||||
include vf-bufs.fth
|
||||
include vf-sys.fth
|
||||
include vf-bdos.fth
|
||||
include vf-file.fth
|
||||
include vf-end.fth
|
||||
|
||||
cr .( unresolved: ) .unresolved ( ' .blk is .status )
|
||||
|
||||
BIN
8080/CPM/cpmfiles/v4thblk.com
Normal file
BIN
8080/CPM/cpmfiles/v4thblk.com
Normal file
Binary file not shown.
16
8080/CPM/cpmfiles/v4thblk.fth
Normal file
16
8080/CPM/cpmfiles/v4thblk.fth
Normal file
@ -0,0 +1,16 @@
|
||||
|
||||
Onlyforth
|
||||
$8000 displace !
|
||||
Target definitions $100 here!
|
||||
|
||||
include vf-core.fth
|
||||
include vf-io.fth
|
||||
include vf-bufs.fth
|
||||
include vf-sys.fth
|
||||
include vf-bdos.fth
|
||||
include vf-file.fth
|
||||
include vf-end.fth
|
||||
|
||||
cr .( unresolved: ) .unresolved ( ' .blk is .status )
|
||||
|
||||
save-target V4THBLK.COM
|
||||
@ -83,12 +83,14 @@ Input: keyboard [ here input ! ]
|
||||
Dos definitions
|
||||
' 2- | Alias dosfcb> ' 2+ | Alias >dosfcb
|
||||
|
||||
: dos-error? ( n -- f ) $FF = ;
|
||||
: dos-error? ( n -- f ) 0<> ;
|
||||
|
||||
$5C Constant fcb
|
||||
: reset ( -- ) 0 &13 bdos ;
|
||||
: openfile ( fcb -- f ) &15 bdosa dos-error? ;
|
||||
: closefile ( fcb -- f ) &16 bdosa dos-error? ;
|
||||
: read-seq ( fcb -- f ) $14 bdosa dos-error? ;
|
||||
: write-seq ( fcb -- f ) $15 bdosa dos-error? ;
|
||||
: dma! ( dma -- ) &26 bdos ;
|
||||
: rec@ ( fcb -- f ) &33 bdosa ;
|
||||
: rec! ( fcb -- f ) &34 bdosa ;
|
||||
@ -97,7 +99,9 @@ $5C Constant fcb
|
||||
|
||||
\ Default Disk Interface: open and close 20Nov87
|
||||
|
||||
Target Dos also Defer drvinit Dos definitions
|
||||
Target Dos also Defer drvinit
|
||||
|
||||
Dos definitions
|
||||
|
||||
| Variable opened
|
||||
: default ( -- ) opened off
|
||||
@ -106,35 +110,20 @@ Target Dos also Defer drvinit Dos definitions
|
||||
openfile Abort" default file not found!" opened on ;
|
||||
' default Is drvinit
|
||||
|
||||
Defer save-dos-buffers
|
||||
|
||||
: close-default ( -- ) opened @ not ?exit
|
||||
fcb closefile Abort" can't close default-file!" ;
|
||||
' close-default Is save-dos-buffers
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 125, Hexblock 7d
|
||||
|
||||
\ Default Disk Interface: read/write 14Feb88
|
||||
|
||||
Target Dos also
|
||||
|
||||
| : rec# ( 'dosfcb -- 'rec# ) &33 + ;
|
||||
|
||||
: (r/w ( adr blk file r/wf -- flag ) >r
|
||||
dup 0= Abort" no Direct Disk IO supported! " >dosfcb
|
||||
swap rec/blk * over rec# 0 over 2+ c! !
|
||||
r> rot b/blk bounds
|
||||
DO I dma! 2dup IF rec@ drop
|
||||
ELSE rec! IF 2drop true endloop exit THEN THEN
|
||||
over rec# 0 over 2+ c! 1 swap +!
|
||||
b/rec +LOOP 2drop false ;
|
||||
|
||||
' (r/w Is r/w
|
||||
|
||||
\ *** Block No. 126, Hexblock 7e
|
||||
|
||||
\ Postlude 20Nov87
|
||||
|
||||
Target Dos also
|
||||
|
||||
Defer postlude
|
||||
|
||||
| : (bye ( -- ) postlude 0 0 bdos ;
|
||||
|
||||
@ -2,12 +2,9 @@
|
||||
|
||||
\ buffer mechanism 20Oct86 07Oct87
|
||||
|
||||
User isfile 0 isfile ! \ addr of file control block
|
||||
Variable fromfile 0 fromfile !
|
||||
Variable prev 0 prev ! \ Listhead
|
||||
| Variable buffers 0 buffers ! \ Semaphor
|
||||
$408 Constant b/buf \ physikalische Groesse
|
||||
$400 Constant b/blk
|
||||
\ \\ Struktur eines Buffers: 0 : link
|
||||
\ 2 : file
|
||||
\ 4 : blocknummer
|
||||
@ -97,7 +94,7 @@ Defer r/w
|
||||
|
||||
\ backup emptybuf readblk 20Oct86
|
||||
|
||||
| : backup ( bufaddr -- ) dup 6+ @ 0<
|
||||
: backup ( bufaddr -- ) dup 6+ @ 0<
|
||||
IF 2+ dup @ 1+ \ buffer empty if file = -1
|
||||
IF input push output push standardi/o
|
||||
BEGIN dup 6+ over 2+ @ 2 pick @ 0 r/w
|
||||
@ -141,13 +138,16 @@ Defer r/w
|
||||
: (block ( blk file -- addr )
|
||||
BEGIN (core? take readblk mark REPEAT ;
|
||||
|
||||
Code isfile@ ( -- addr ) user' isfile D lxi
|
||||
UP lhld D dad fetch jmp end-code
|
||||
|
||||
: buffer ( blk -- addr ) isfile@ (buffer ;
|
||||
|
||||
: block ( blk -- addr ) isfile@ (block ;
|
||||
|
||||
: (blk-source ( -- addr len)
|
||||
blk @ ?dup IF loadfile @ (block b/blk exit THEN
|
||||
tib #tib @ ;
|
||||
|
||||
' (blk-source IS source
|
||||
|
||||
\ : isfile@ ( -- addr ) isfile @ ;
|
||||
|
||||
\ *** Block No. 102, Hexblock 66
|
||||
@ -156,11 +156,10 @@ Code isfile@ ( -- addr ) user' isfile D lxi
|
||||
|
||||
: update $80 prev @ 6+ 1+ ( Byte-Order! ) c! ;
|
||||
|
||||
Defer save-dos-buffers
|
||||
|
||||
: save-buffers ( -- ) buffers lock
|
||||
: (save-buffers ( -- ) buffers lock
|
||||
BEGIN updates? ?dup WHILE backup REPEAT save-dos-buffers
|
||||
buffers unlock ;
|
||||
' (save-buffers IS save-buffers
|
||||
|
||||
: empty-buffers ( -- ) buffers lock prev
|
||||
BEGIN @ ?dup WHILE dup emptybuf REPEAT buffers unlock ;
|
||||
@ -172,7 +171,7 @@ Defer save-dos-buffers
|
||||
\ *** Block No. 103, Hexblock 67
|
||||
|
||||
\ Allocating buffers 10Oct87
|
||||
$10000 Constant limit Variable first
|
||||
Variable first
|
||||
|
||||
: allotbuffer ( -- )
|
||||
first @ r0 @ - b/buf 2+ u< ?exit
|
||||
@ -186,5 +185,30 @@ $10000 Constant limit Variable first
|
||||
|
||||
: all-buffers BEGIN first @ allotbuffer first @ = UNTIL ;
|
||||
|
||||
| : init-buffers prev off limit first ! all-buffers ;
|
||||
| : (init-buffers prev off limit first ! all-buffers flush ;
|
||||
' (init-buffers IS init-buffers
|
||||
|
||||
\ *** Block No. 125, Hexblock 7d
|
||||
|
||||
\ Default Disk Interface: read/write 14Feb88
|
||||
|
||||
Target Dos also
|
||||
|
||||
| : rec# ( 'dosfcb -- 'rec# ) &33 + ;
|
||||
|
||||
: (r/w ( adr blk file r/wf -- flag ) >r
|
||||
dup 0= Abort" no Direct Disk IO supported! " >dosfcb
|
||||
swap rec/blk * over rec# 0 over 2+ c! !
|
||||
r> rot b/blk bounds
|
||||
DO I dma! 2dup IF rec@ drop
|
||||
ELSE rec! IF 2drop true endloop exit THEN THEN
|
||||
over rec# 0 over 2+ c! 1 swap +!
|
||||
b/rec +LOOP 2drop false ;
|
||||
|
||||
' (r/w Is r/w
|
||||
|
||||
: list ( blk -- )
|
||||
scr ! ." Scr " scr @ u.
|
||||
l/s 0 DO
|
||||
cr I 2 .r space scr @ block I c/l * + c/l -trailing type
|
||||
LOOP cr ;
|
||||
|
||||
@ -1010,10 +1010,11 @@ Code (word ( char adr0 len0 -- addr )
|
||||
|
||||
\ source word parse name 20Oct86UH 25Jan88
|
||||
|
||||
Variable loadfile
|
||||
defer source
|
||||
|
||||
: source ( -- addr len ) blk @ ?dup
|
||||
IF loadfile @ (block b/blk exit THEN tib #tib @ ;
|
||||
: (source ( -- addr len) tib #tib @ ;
|
||||
|
||||
' (source IS source
|
||||
|
||||
: word ( char -- addr ) source (word ;
|
||||
|
||||
@ -1054,7 +1055,9 @@ Code "lit RP lhld M E mov H inx M D mov H dcx
|
||||
: ( ascii ) parse 2drop ; immediate
|
||||
: .( ascii ) parse type ; immediate
|
||||
|
||||
: \ >in @ negate c/l mod >in +! ; immediate
|
||||
: \ blk @ IF >in @ negate c/l mod >in +!
|
||||
ELSE #tib @ >in ! THEN ; immediate
|
||||
|
||||
: \\ b/blk >in ! ; immediate
|
||||
: \needs name find nip 0=exit [compile] \ ;
|
||||
|
||||
|
||||
@ -1,52 +1,13 @@
|
||||
|
||||
\ *** Block No. 0, Hexblock 0
|
||||
|
||||
\ include for stream sources for cp/m phz 30aug23
|
||||
|
||||
cr .( order) order cr
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 1, Hexblock 1
|
||||
|
||||
\ load screen phz 02sep23
|
||||
|
||||
\ onlyforth dos also forth definitions
|
||||
|
||||
: idos-error? ( n -- f ) 0<> ;
|
||||
: iread-seq ( dosfcb -- f ) $14 bdosa idos-error? ;
|
||||
: cr+ex@ ( fcb -- cr+256*ex )
|
||||
dup &34 + c@ swap &14 + c@ $100 * + ;
|
||||
: cr+ex! ( cr+256*ex fcb -- )
|
||||
>r $100 u/mod r@ &14 + c! r> &34 + c! ;
|
||||
|
||||
\ 1 7 +thru
|
||||
| variable tibeof tibeof off
|
||||
| $1a constant ctrl-z
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 2, Hexblock 2
|
||||
|
||||
\ fib /fib #fib eolf? phz 09okt24
|
||||
|
||||
\ context @ dos also context !
|
||||
\ $50 constant /tib
|
||||
variable tibeof tibeof off
|
||||
$1a constant ctrl-z
|
||||
|
||||
: eolf? ( c -- f )
|
||||
| : eolf? ( c -- f )
|
||||
\ f=-1: not yet eol; store c and continue
|
||||
\ f=0: eol but not yet eof; return line and flag continue
|
||||
\ f=1: eof: return line and flag eof
|
||||
@ -54,32 +15,22 @@ cr .( order) order cr
|
||||
dup #lf = IF drop 0 exit THEN
|
||||
ctrl-z = IF tibeof on 1 ELSE -1 THEN ;
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 3, Hexblock 3
|
||||
|
||||
\ incfile incpos inc-fgetc phz 02sep23
|
||||
|
||||
variable incfile
|
||||
variable increc
|
||||
variable rec-offset
|
||||
$80 constant dmabuf | $ff constant dmabuf-last
|
||||
variable increc-offset
|
||||
| $80 constant dmabuf
|
||||
| $ff constant dmabuf-last
|
||||
|
||||
: readrec ( fcb -- f )
|
||||
: increadrec ( fcb -- f )
|
||||
dup cr+ex@ increc !
|
||||
rec-offset off dmabuf dma! drive iread-seq ;
|
||||
increc-offset off dmabuf dma! >dosfcb read-seq ;
|
||||
|
||||
: inc-fgetc ( -- c )
|
||||
rec-offset @ b/rec u< 0=
|
||||
IF incfile @ readrec IF ctrl-z exit THEN THEN
|
||||
rec-offset @ dmabuf + c@ 1 rec-offset +! ;
|
||||
| : inc-fgetc ( -- c )
|
||||
increc-offset @ b/rec u< 0=
|
||||
IF incfile @ increadrec IF ctrl-z exit THEN THEN
|
||||
increc-offset @ dmabuf + c@ 1 increc-offset +! ;
|
||||
|
||||
|
||||
\ *** Block No. 4, Hexblock 4
|
||||
|
||||
\ freadline probe-for-fb phz 25aug23
|
||||
|
||||
: freadline ( -- eof )
|
||||
| : freadline ( -- eof )
|
||||
tib /tib bounds DO
|
||||
inc-fgetc dup eolf? under 0< IF I c! ELSE drop THEN
|
||||
0< 0= IF I tib - #tib ! ENDLOOP tibeof @ exit THEN
|
||||
@ -92,80 +43,28 @@ cr .( order) order cr
|
||||
dmabuf BEGIN dup c@ #lf = IF drop 0 exit THEN
|
||||
1+ dup dmabuf-last u> UNTIL drop 1 ;
|
||||
|
||||
| $50 constant /stash
|
||||
| create stash[ /stash allot here | constant ]stash
|
||||
| variable stash> stash[ stash> !
|
||||
| : clear-tibstash stash[ stash> ! ;
|
||||
|
||||
|
||||
\ *** Block No. 5, Hexblock 5
|
||||
|
||||
\ save/restoretib phz 06okt22
|
||||
|
||||
$50 constant /stash
|
||||
create stash[ /stash allot here constant ]stash
|
||||
variable stash> stash[ stash> !
|
||||
|
||||
: savetib ( -- n )
|
||||
| : savetib ( -- n )
|
||||
#tib @ >in @ - dup stash> @ + ]stash u>
|
||||
abort" tib stash overflow" >r
|
||||
tib >in @ + stash> @ r@ cmove
|
||||
r@ stash> +! r> ;
|
||||
|
||||
: restoretib ( n -- )
|
||||
| : restoretib ( n -- )
|
||||
dup >r negate stash> +! stash> @ tib r@ cmove
|
||||
r> #tib ! >in off ;
|
||||
|
||||
|
||||
\ *** Block No. 6, Hexblock 6
|
||||
|
||||
\ interpret-via-tib inner-include phz 02sep23
|
||||
|
||||
: interpret-via-tib
|
||||
| : interpret-via-tib
|
||||
BEGIN freadline >r .status >in off interpret r> UNTIL ;
|
||||
|
||||
: include-inner ( -- )
|
||||
: include-isfile ( -- )
|
||||
increc push 0 isfile@ cr+ex!
|
||||
isfile@ readrec Abort" can't read start of file"
|
||||
isfile@ increadrec Abort" can't read start of file"
|
||||
probe-for-fb IF 1 load exit THEN
|
||||
incfile push isfile@ incfile !
|
||||
savetib >r interpret-via-tib close r> restoretib ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 7, Hexblock 7
|
||||
|
||||
\ include phz 02sep23
|
||||
|
||||
: include ( -- )
|
||||
rec-offset push isfile push fromfile push
|
||||
use cr file?
|
||||
include-inner
|
||||
incfile @
|
||||
IF increc @ incfile @ cr+ex!
|
||||
incfile @ readrec Abort" error re-reading after include"
|
||||
THEN ;
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
\ *** Block No. 8, Hexblock 8
|
||||
|
||||
\ \ phz 02sep23
|
||||
|
||||
: (stashquit stash[ stash> ! incfile off increc off
|
||||
(quit ;
|
||||
: stashrestore ['] (stashquit IS 'quit ;
|
||||
' stashrestore IS 'restart
|
||||
|
||||
: \ blk @ IF >in @ negate c/l mod >in +!
|
||||
ELSE #tib @ >in ! THEN ; immediate
|
||||
|
||||
\ : \needs have 0=exit
|
||||
\ blk @ IF >in @ negate c/l mod >in +!
|
||||
\ ELSE #tib @ >in ! THEN ;
|
||||
|
||||
|
||||
|
||||
savetib >r interpret-via-tib r> restoretib
|
||||
incfile @ 2+ closefile Abort" error closing file" ;
|
||||
|
||||
@ -8,6 +8,7 @@ Defer .status ' noop Is .status
|
||||
|
||||
: push ( addr -- ) r> swap dup >r @ >r pull >r >r ;
|
||||
restrict
|
||||
Variable loadfile
|
||||
|
||||
: (load ( blk offset -- )
|
||||
isfile push loadfile push fromfile push blk push >in push
|
||||
@ -45,7 +46,7 @@ Defer .status ' noop Is .status
|
||||
|
||||
Defer prompt ' (prompt Is prompt
|
||||
|
||||
: (quit BEGIN prompt query interpret REPEAT ;
|
||||
: (quit clear-tibstash BEGIN prompt query interpret REPEAT ;
|
||||
|
||||
Defer 'quit ' (quit Is 'quit
|
||||
: quit r0 @ rp! level off [compile] [ 'quit ;
|
||||
@ -159,11 +160,6 @@ $20 Constant bl
|
||||
$40 Constant c/l \ Screen line length
|
||||
$10 Constant l/s \ lines per screen
|
||||
|
||||
: list ( blk -- )
|
||||
scr ! ." Scr " scr @ u.
|
||||
l/s 0 DO
|
||||
cr I 2 .r space scr @ block I c/l * + c/l -trailing type
|
||||
LOOP cr ;
|
||||
|
||||
|
||||
|
||||
@ -187,3 +183,18 @@ Code pause >next here 2- ! end-code
|
||||
Label wake H pop H dcx UP shld
|
||||
6 D lxi D dad M A mov H inx M H mov A L mov sphl
|
||||
H pop RP shld IP pop Next end-code
|
||||
|
||||
\ file related definitions moved here from vf-bufs.fth
|
||||
|
||||
User isfile 0 isfile ! \ addr of file control block
|
||||
Variable fromfile 0 fromfile !
|
||||
|
||||
Code isfile@ ( -- addr ) user' isfile D lxi
|
||||
UP lhld D dad fetch jmp end-code
|
||||
|
||||
$FF00 Constant limit
|
||||
|
||||
Defer save-buffers ' noop IS save-buffers
|
||||
Defer init-buffers ' noop IS init-buffers
|
||||
|
||||
$400 Constant b/blk
|
||||
|
||||
@ -82,7 +82,8 @@ Defer custom-remove ' noop Is custom-remove
|
||||
voc-link @ BEGIN dup 4- @ over 2- ! @ ?dup 0= UNTIL
|
||||
up@ origin $100 cmove ;
|
||||
|
||||
: bye flush empty (bye ;
|
||||
: bye save-buffers (bye ;
|
||||
\ : bye flush empty (bye ;
|
||||
|
||||
| : end? key #cr = IF true rdrop THEN ;
|
||||
|
||||
@ -146,7 +147,7 @@ Defer 'cold ' noop Is 'cold
|
||||
|
||||
| : (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 init-buffers 'cold
|
||||
Onlyforth page &24 spaces logo count type cr (restart ;
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user