Article-I.D.: tekred.384
Posted: Tue Jul 16 23:51:52 1985
Date-Received: Fri, 19-Jul-85 03:27:13 EDT
Organization: The Hollow Tree
Lines: 466

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)