ronbe@tekred.UUCP (Little Guy) (07/17/85)
Actually, it's my first BASIC program in over 6 months.
But, just so as not to get away from Z80 (my language),
this BASIC program uses Z80 routines...
It's a bulletin board program. There are four Z80
routines that the program uses. The first (FNI) sets
up the RS232 and waits for carrier detect, the second
(FNS) sends a BASIC string, the third (FNR) receives a
BASIC string, and the fourth (FNQ) resets the RS232 and
clears the line. FNR actually puts the characters
right into your BASIC program's string.
The following shar has all you need to get it running.
It's set up at 300 baud, but easy to change via POKE or
a small change in the source. The included BASIC
program is just an example, I'm sure it will grow for
me as I do more things. I'd like to have random access
files with user's names, person-to-person mail, and all
sorts of other things that the "big" BBS's have.
Anyway, here it is. Enjoy.
Ron Bemis
tektronix!tekred!ronbe
# This is a shell archive. Remove anything before this line,
# then unpack it by saving it in a file and typing "sh file".
#
# Wrapped by tekred!ronbe on Tue Jul 16 20:42:05 PDT 1985
# Contents: Makefile vectors.z80 setup.z80 send.z80 receive.z80 quit.z80
# bbs.cmd bbs.equ bbs.bas
echo x - Makefile
sed 's/^@//' > "Makefile" <<'@//E*O*F Makefile//'
TITLE= bbs
OBJS= vectors.obj setup.obj send.obj receive.obj quit.obj
SHAR= Makefile vectors.z80 setup.z80 send.z80 receive.z80 quit.z80 bbs.cmd bbs.equ bbs.bas
BASE= FE00
SIZE= 200
ASM= /usr/local/z80/lasasm
SASM= /usr/local/z80/asm
LNK= /usr/local/link/link
HEX= /usr/local/ehex
CHK= /usr/local/chks
LST= /usr/local/lstr
$(TITLE).rom: $(OBJS) $(TITLE).cmd
$(LNK) -v -d -r -o $(TITLE).lnk -c $(TITLE).cmd > $(TITLE).log
$(HEX) -s $(TITLE).lnk > $(TITLE).tek
$(HEX) -i $(TITLE).lnk > $(TITLE).hex
$(CHK) -b $(BASE) -s $(SIZE) < $(TITLE).tek > $(TITLE).rom
$(LST) -s $(TITLE).lnk >> $(TITLE).log
vectors.obj: vectors.z80 $(TITLE).equ
$(SASM) vectors.obj vectors.prn vectors.z80
setup.obj: setup.z80 $(TITLE).equ
$(SASM) setup.obj setup.prn setup.z80
send.obj: send.z80 $(TITLE).equ
$(SASM) send.obj send.prn send.z80
receive.obj: receive.z80 $(TITLE).equ
$(SASM) receive.obj receive.prn receive.z80
quit.obj: quit.z80 $(TITLE).equ
$(SASM) quit.obj quit.prn quit.z80
new: clean
make
clean:
rm -f *.obj *.lnk *.prn *.hex *.tek *.rom *.log
list:
lpr *.log *.prn
shar: $(SHAR)
shar $(SHAR) > shar
@//E*O*F Makefile//
chmod u=rw,g=r,o=r Makefile
echo "Send BBS updates to $USER" | mail tektronix!tekred!ronbe
echo x - vectors.z80
sed 's/^@//' > "vectors.z80" <<'@//E*O*F vectors.z80//'
title 'Bulletin Board Program'
stitle 'Jump Vectors'
list page(64)
include 'bbs.equ'
section vectors
global setup,send,rline,quit
jp setup
jp send
jp rline
jp quit
@//E*O*F vectors.z80//
chmod u=rw,g=r,o=r vectors.z80
echo x - setup.z80
sed 's/^@//' > "setup.z80" <<'@//E*O*F setup.z80//'
title 'Bulletin Board Program'
stitle 'Set up RS232'
list page(64)
include 'bbs.equ'
section code
global setup,quit
setup ld a,15
call vdchar ;cursor off
xor a
out (rsrset),a ;reset uart
ld a,55h ;300 baud
out (baudsl),a ;set it
ld a,0b4h ;parameters
out (rscntl),a ;set it
waitcd call kbbrk ;break pressed?
jp nz,quit ;return if so
in a,(rsrset) ;read status
and 20h ;check bit 5
jp nz,waitcd ;wait for cd
ld a,14
call vdchar ;cursor on
ld hl,0 ;got dcd!
jp basret ;return to BASIC
@//E*O*F setup.z80//
chmod u=rw,g=r,o=r setup.z80
echo x - send.z80
sed 's/^@//' > "send.z80" <<'@//E*O*F send.z80//'
title 'Bulletin Board Program'
stitle 'Send A String'
list page(64)
include 'bbs.equ'
section code
global send,txchar,quit
send call basget
ld b,(hl) ;length of string
inc hl
ld a,(hl)
inc hl
ld h,(hl) ;!!!
ld l,a ;hl points to data
txeach call kbbrk ;break pressed?
jp nz,quit ;go if so
ld a,b ;get length
or a
jp z,txend ;go if last
ld c,(hl) ;put data in c
call txchar ;send it
call vdchar ;display it
inc hl
dec b
jp txeach
txend ld c,13 ;create return
call txchar ;send it
call vdchar ;display it
ld c,10 ;create linefeed
call txchar ;send it
ld hl,0 ;status good
jp basret ;return to BASIC
txchar in a,(rscntl) ;check status
and 40h ;transmit buffer empty?
jp z,txchar ;wait if not
ld a,c ;get the data
out (rsdata),a ;send it
ret
@//E*O*F send.z80//
chmod u=rw,g=r,o=r send.z80
echo x - receive.z80
sed 's/^@//' > "receive.z80" <<'@//E*O*F receive.z80//'
title 'Bulletin Board Program'
stitle 'Receive A Line'
list page(64)
include 'bbs.equ'
section code
global rline,txchar,quit
rline call basget ;get pointer
ld a,(hl) ;get old length
ld ix,length ;point to storage
ld (ix+1),a ;(ix+1) = # left to fill
ld (ix+0),0 ;new length = 0
inc hl
ld a,(hl)
inc hl
ld h,(hl) ;!!
ld l,a ;hl points to data
timer ld bc,0 ;delay counter
loop call kbbrk ;break pressed?
jp nz,quit ;go if so
call rca ;character available?
jp nz,got1 ;go if so
push bc
ld b,40h ;makes about 30 secs
djnz $
pop bc
djnz loop ;keep checking
dec c
jr nz,loop ;keep checking
ld hl,-1 ;timeout
jp basret ;return to BASIC
got1 cp 22h ;double quote?
jp z,timer ;nice try, jerk!
cp ' ' ;less than space?
jp nc,normal ;go if not
cp 13 ;return?
jp z,return
cp 10 ;linefeed?
jp z,return
cp 8 ;backspace?
jp z,backsp
cp 15h ;control-u?
jp z,cancel
cp 3 ;etx?
jp z,erase
cp 18h ;cancel (control-x)?
jp z,erase
jp timer ;ignore others
normal ld c,a ;move it to C
ld a,(ix+1) ;# left to fill
or a ;enough room?
jp z,timer ;ignore if not
ld (hl),c ;put it in
inc hl ;bump the pointer
inc (ix+0) ;bump the length
dec (ix+1) ;one less to fill
call txchar ;echo it
call vdchar ;display it
jp timer ;wait for next
backsp ld c,a ;move it to C
ld a,(ix+0) ;get the length
or a ;is it 0?
jp z,timer ;ignore if so
dec (ix+0) ;back off length
dec hl ;back off pointer
inc (ix+1) ;one more to fill
call txchar ;echo it
call vdchar ;display it
jp timer ;wait for next
cancel ld c,5eh ;create control-
call txchar ;echo it
call vdchar ;display it
ld c,'U' ;create U
call txchar ;echo it
call vdchar ;display it
ld c,13 ;create carriage return
call txchar ;echo it
call vdchar ;display it
ld c,10 ;create line feed
call txchar ;echo it
mtloop ld a,(ix+0) ;get the length
or a ;is it 0?
jp z,timer ;go if so
dec (ix+0) ;back off length
dec hl ;back off pointer
inc (ix+1) ;one more to fill
jp mtloop ;until length = 0
erase ld a,(ix+0) ;get the length
or a ;is it 0?
jp z,timer ;go if so
dec (ix+0) ;back off length
dec hl ;back off pointer
inc (ix+1) ;one more to fill
ld c,8 ;create backspace
call txchar ;echo it
call vdchar ;display it
jp erase ;until length = 0
return ld c,13 ;create return
call txchar ;echo it
call vdchar ;display it
ld c,10 ;create linefeed
call txchar ;send it
ld h,0
ld l,(ix+0) ;length in HL
jp basret ;return to BASIC
rca in a,(rscntl) ;get uart status
and 80h ;character available?
ret z ;return if not
in a,(rsdata) ;get the data
and 7fh ;strip top bit
cp 7fh ;all 1's?
ret z ;return if so
or a ;null?
ret ;return with Z flag
length block 1 ;string length
tofill block 1 ;initial length
@//E*O*F receive.z80//
chmod u=rw,g=r,o=r receive.z80
echo x - quit.z80
sed 's/^@//' > "quit.z80" <<'@//E*O*F quit.z80//'
title 'Bulletin Board Program'
stitle 'Reset the RS232'
list page(64)
include 'bbs.equ'
section code
global quit
quit xor 0
out (rsrset),a ;reset modem
dec a
out (rscntl),a ;turn off everything
ld a,14
call vdchar ;cursor on
ld hl,-1
jp basret
@//E*O*F quit.z80//
chmod u=rw,g=r,o=r quit.z80
echo x - bbs.cmd
sed 's/^@//' > "bbs.cmd" <<'@//E*O*F bbs.cmd//'
-O vectors.obj setup.obj send.obj receive.obj quit.obj
-m MEM=0FE00-0FFFF ;location for code
;assign class names to sections
-L SEC=VECTORS BASE MEM ;VECTORS at beginning
-L SEC=CODE RANGE MEM ;locate CODE in MEM
-x 402D ;entry address
@//E*O*F bbs.cmd//
chmod u=rw,g=r,o=r bbs.cmd
echo x - bbs.equ
sed 's/^@//' > "bbs.equ" <<'@//E*O*F bbs.equ//'
VDCHAR EQU 0033H
KBBRK EQU 028DH
BASGET EQU 0A7FH
BASRET EQU 0A9AH
RSRSET EQU 0E8H
BAUDSL EQU 0E9H
RSCNTL EQU 0EAH
RSDATA EQU 0EBH
@//E*O*F bbs.equ//
chmod u=rw,g=r,o=r bbs.equ
echo x - bbs.bas
sed 's/^@//' > "bbs.bas" <<'@//E*O*F bbs.bas//'
10 POKE 16562,&HFD:POKE 16561,&HFE:CLEAR 2000:CMD "L","BBS/CMD"
20 DEFUSR0=&HFE00:DEFFNI=USR0(0) 'SETUP RS232, WAIT FOR CD
30 DEFUSR1=&HFE03:DEFFNS(S$)=USR1(VARPTR(S$)) 'SEND ROUTINE
40 DEFUSR2=&HFE06:DEFFNR(R$)=USR2(VARPTR(R$)) 'RECEIVE ROUTINE
50 DEFUSR3=&HFE09:DEFFNQ=USR3(0) 'QUIT ROUTINE
60 ON ERROR GOTO 230
70 CLS:X=FNI:ST$=TIME$:FOR X=1 TO 1000:NEXT
80 SR$="********** " 'FOR PRINTER MESSAGES
90 N$="Anonymous" 'NO NAME YET
100 X=FNS("")
110 X=FNS("-----------------------------------")
120 X=FNS(" TRS-80 Model III Bulletin Board")
130 X=FNS(" TRSBBS (c) 1985 by Ron Bemis")
140 X=FNS("-----------------------------------")
150 X=FNS("")
160 GOTO 470
170 REM *************************************
180 REM * RECEIVE A LINE - STUFF IT INTO C$ *
190 REM *************************************
200 C$="--------------------------------------------------"
210 X=FNR(C$):IF X=-1 THEN 320 'TIMED OUT
220 C$=LEFT$(C$,X):RETURN
230 REM *****************
240 REM * PROGRAM ERROR *
250 REM *****************
260 LPRINT SR$"ERROR CODE "ERR/2+1
270 LPRINT SR$"ON LINE "ERL:LPRINT
280 X=FNS("")
290 X=FNS("Program Error! Sorry, but I can't continue...")
300 RESUME 360
310 REM ***************************************************
320 REM * TIMEOUT -- SEND MESSAGE, HANG UP AND START OVER *
330 REM ***************************************************
340 X=FNS("")
350 X=FNS("Timeout...")
360 REM *******************
370 REM * END THE SESSION *
380 REM *******************
390 ET$=TIME$
400 X=FNS("Connected from "+ST$+" to "+ET$)
410 X=FNS("Thanks for calling, "+N$+"!")
420 FOR X=1 TO 100:NEXT
430 X=FNQ
440 LPRINT SR$N$" was connected from "ST$" to "ET$:LPRINT
450 FOR X=1 TO 15000:NEXT 'ABOUT 30 SECONDS
460 RUN 20
470 REM *************************
480 REM * START THE INTERACTION *
490 REM *************************
500 X=FNS("What is your name?")
510 GOSUB 170 :IF C$<>"" THEN N$=C$:GOTO 560
520 X=FNS("No anonymous calls allowed.")
530 X=FNS("What is your name?")
540 GOSUB 170 :IF C$<>"" THEN N$=C$:GOTO 560
550 X=FNS("Shall we get serious now?"):GOTO 500
560 REM *************
570 REM * Main Menu *
580 REM *************
590 X=FNS("")
600 X=FNS("Main Menu:")
610 X=FNS("")
620 X=FNS(" 1: System Message")
630 X=FNS(" 2: Leave a message for the SysOp")
640 X=FNS(" 3: Chat with the SysOp")
650 MX=3
660 X=FNS("ENTER: Quit")
670 X=FNS("")
680 X=FNS("Your selection:")
690 GOSUB 170 :IF C$="" THEN GOTO 360 'END THE SESSION
700 S=VAL(C$):IF S>0 AND S<=MX THEN GOTO 780 'GOOD CHOICE
710 X=FNS("Invalid selection, try again:")
720 GOSUB 170 :IF C$="" THEN GOTO 360 'END THE SESSION
730 S=VAL(C$):IF S>0 AND S<=MX THEN GOTO 780 'GOOD CHOICE
740 GOTO 560
750 REM *****************************
760 REM * POINTERS TO MENU ROUTINES *
770 REM *****************************
780 ON S GOTO 790 ,890 ,970
790 REM ******************
800 REM * SYSTEM MESSAGE *
810 REM ******************
820 OPEN "I",1,"SYSMSG/BLD"
830 IF EOF(1) THEN 870
840 LINEINPUT #1,C$
850 X=FNS(C$)
860 GOTO 840 'NEXT LINE
870 CLOSE 1:X=FNS("Press ENTER...")
880 GOSUB 170 :GOTO 560
890 REM ***************************
900 REM * LEAVE MESSAGE FOR SYSOP *
910 REM ***************************
920 LPRINT SR$"MESSAGE FROM "N$
930 X=FNS("Type up to 20 lines; enter a blank line to end.")
940 FOR I=1 TO 20:GOSUB 170 :IF C$="" THEN 950 :LPRINT C$:NEXT I
950 LPRINT SR$"END OF MESSAGE":LPRINT
960 X=FNS("Message logged."):GOTO 560
970 REM ***********************
980 REM * CHAT WITH THE SYSOP *
990 REM ***********************
1000 LPRINT SR$N$" CHAT SESSION"
1010 X=FNS("Wait just a moment while I make some noise...")
1020 PRINT "Hey, boss! "N$" would like a word with you..."
1030 FOR X=1 TO 15:LPRINT CHR$(7);:FOR Y=1 TO 100:IF INKEY$<>"" THEN 1080 ELSE NEXT Y:NEXT X
1040 LPRINT SR$"GOT NO REPLY":LPRINT
1050 X=FNS("Looks like nobody's around.")
1060 X=FNS("You might want to try again later.")
1070 GOTO 560
1080 X=FNS("Ok! Somebody's here...")
1090 X=FNS("Here's how we do this: You start, and type your")
1100 X=FNS("message first. Send a blank line to tell me")
1110 X=FNS("that you're finished. You can type up to ten")
1120 X=FNS("lines. The Sysop follows the same rules. If")
1130 X=FNS("either of you want to stop, just send 'DONE'")
1140 X=FNS("all by itself on a line. It must be capitalized.")
1150 X=FNS("I (the TRS-80) keep track of whose turn it is.")
1160 X=FNS("Your turn...")
1170 FOR I=1 TO 10
1180 GOSUB 170 :IF C$="" THEN 1210 'SYSOP'S TURN
1190 LPRINT C$:IF C$="DONE" THEN 1270 'CHAT DONE
1200 NEXT I
1210 PRINT "SysOp Reply..."
1220 FOR I=1 TO 10
1230 LINEINPUT C$:IF C$="" THEN 1260 'USER'S TURN
1240 LPRINT SR$C$:X=FNS(C$):IF C$="DONE" THEN 1270 'CHAT DONE
1250 NEXT I
1260 GOTO 1160
1270 LPRINT SR$"CHAT SESSION OVER":LPRINT
1280 GOTO 560
@//E*O*F bbs.bas//
chmod u=rw,g=r,o=r bbs.bas
exit 0
--
Be careful tonight, if you drive, don't park.
Remember, accidents are the major cause of people.
...tektronix!tekred!ronbe (Ron Bemis)