home *** CD-ROM | disk | FTP | other *** search
/ Columbia Kermit / kermit.zip / hp86 / hp8ker.boo < prev    next >
Text File  |  2020-01-01  |  22KB  |  583 lines
  1. KERMIT BOO
  2. 100 DIM IBUFF$[264],OBUFF$[264]
  3. 105 DIM K$[1],k$[1],I$[256]
  4. 110 DIM CR$[1],LF$[1],ESC$[1],BEL$[1]
  5. 115 DIM EL$[1],BS$[1],DEL$[1],NULL$[1]
  6. 120 DIM SP$[1]
  7. 125 INTEGER S1,S2,S3,S4,K,R,C,I,F
  8. 130 CR$[1]=CHR$ (13) @ LF$=CHR$ (10)
  9. 135 ESC$[1]=CHR$ (27) @ BEL$=CHR$ (7)
  10. 140 EL$[1]=CHR$ (154) @ BS$=CHR$ (155)
  11. 145 DEL$[1]=CHR$ (127) @ NULL$=CHR$ (0)
  12. 150 SP$=" "
  13. 155 DIM RP$[96],OP$[96],ID$[91],OD$[91]
  14. 160 DIM S$[256],DB$[256],SF$[17],DF$[40],T$[1],RT$[1],c$[1]
  15. 165 DIM SI$[1],SH$[1],SD$[1],SE$[1],SB$[1],TM$[1],AK$[1],NK$[1]
  16. 170 DIM RQCTL$[1],SQCTL$[1],RPADC$[1],SPADC$[1]
  17. 175 DIM MK$[1],SEOL$[1],REOL$[1],CRLF$[4]
  18. 180 INTEGER N,S,T,e,f,i,j,l,m,r,t
  19. 185 INTEGER n,rn,db,tmo,nk,bp,rr,rc,sr,sc
  20. 190 INTEGER RMAXL,SMAXL,MAXL,MINL,RTO,STO,RNPAD,SNPAD,REOL,SEOL,TMO,STM,RLIM
  21. 195 SI$="S" @ SH$="F" @ SD$="D" @ SE$="Z" @ SB$="B"
  22. 200 AK$="Y" @ NK$="N" @ TM$="T" @ ER$="E"
  23. 205 MK$=CHR$ (1) @ CRLF$="#M#J"
  24. 210 SEOL$,REOL$=CR$ @ RPADC$=NULL$ @ SQCTL$="#"
  25. 215 RMAXL=94 @ RTO,STO=20 @ RNPAD=0 @ SEOL=13
  26. 220 RLIM=10 @ STM=10000 @ rr=17 @ sr=15 @ rc,sc=10
  27. 225 db=1
  28. 250 DIM F$[80],CL$[61],CP$[24]
  29. 255 CL$="CONNECT, SEND, RECEIVE, SET, SHOW, EXIT, QUIT, CAT"
  30. 260 KP$="KERMIT-HP86" @ CP$=KP$
  31. 265 DIM VC$[63],DT$[1],CN$[1],UL$[1],FTYP$[8]
  32. 270 VC$=".1234567890ABCDEFGHIJKLMNOPQRSTUVWXYZ"
  33. 275 DT$="." @ CN$=":" @ UL$="_" @ Q$=CHR$ (34)
  34. 280 FTYP$="DATA"
  35. 300 ALPHALL @ PAGESIZE 24 @ CLEAR @ R=0
  36. 310 DIM EM$(24)[24]
  37. 320 EM$(0)="Transfer successfull" @ EM$(1)="Timeout receiving"
  38. 325 EM$(2)="NAK received" @ EM$(3)="Checksum error" @ EM$(4)="Incorrect packet"
  39. 330 EM$(5)="Timeout sending" @ EM$(6)="Cannot rename file"
  40. 335 EM$(7)="Disc write protected" @ EM$(8)="*File closed*"
  41. 340 EM$(9)="File does not exist" @ EM$(10)="Incorrect file type"
  42. 345 EM$(11)="*Random overflow*" @ EM$(12)="Read error"
  43. 350 EM$(13)="End of file" @ EM$(14)="Record does not exist"
  44. 355 EM$(15)="No M.S. device" @ EM$(16)="Directory full"
  45. 360 EM$(17)="Volume not found" @ EM$(18)="MSUS not found"
  46. 365 EM$(19)="Read verify error" @ EM$(20)="Disc full"
  47. 370 EM$(21)="Medium damaged" @ EM$(22)="Disc drive fault"
  48. 372 EM$(23)="Data type error" @ EM$(24)="Transfer aborted"
  49. 375 FSE$=CHR$ (60) @ FOR i=66 TO 72 @ FSE$=FSE$&CHR$ (i) @ NEXT i
  50. 380 FSE$=FSE$&CHR$ (120) @ FOR i=124 TO 130 @ FSE$=FSE$&CHR$ (i) @ NEXT i
  51. 390 DIM A$(9)[18],ST$(1)[9],st$(1)[8]
  52. 395 A$(0)="initialise        " @ A$(1)="file header      "
  53. 400 A$(2)="data              " @ A$(3)="end of file      "
  54. 405 A$(4)="break             " @ A$(5)="error            "
  55. 410 A$(6)="ACK               " @ A$(7)="NAK              "
  56. 415 A$(8)="file header/break " @ A$(9)="data/EOF         "
  57. 420 ST$(0)="Sending" @ st$(0)="sent" @ ST$(1)="Receiving" @ st$(1)="received"
  58. 425 DIM RE$[4],PF$[18]
  59. 430 INTEGER RE,RL,NR
  60. 435 RE$=CR$&LF$ @ RE=LEN (RE$) @ RL=256 @ NR=40 @ FS=RL*NR/1024 @ PF$=""
  61. 440 DIM SL$[164],OO$[7],DX$[10],FC$[23],PT$[28],BR$[8],HS$[29]
  62. 445 SL$="TIMEOUT, RETRIES, SEND-CONVERT, DEBUG, PREFIX, END-OF-LINE, "
  63. 450 SL$=SL$&"RECORD-END, FILE-SIZE, RECORD-LENGTH, NO-OF-RECORDS, "
  64. 455 SL$=SL$&"DUPLEX, LOCAL-ECHO, FLOW-CONTROL, HANDSHAKE, PARITY"
  65. 460 OO$="OFF, ON" @ DX$="FULL, HALF" @ FC$="NONE, XON/XOFF, DTR/RTS"
  66. 462 PT$="NONE, ODD, EVEN, MARK, SPACE" @ BR$="110, 300"
  67. 463 HS$="NONE, BELL, LF, CR, XON, XOFF"
  68. 465 DIM SS$[47],RS$[32]
  69. 470 SS$="SEND "&Q$&"Source filename"&Q$&" <"&Q$&"Destination filespec"&Q$&">"
  70. 475 RS$="RECEIVE <"&Q$&"Destination filespec"&Q$&">"
  71. 480 DIM IO$[14],IC$[14],IV$[13]
  72. 485 IO$="Illegal option" @ IC$="Illegal string" @ IV$="Illegal value"
  73. 490 INTEGER BR,DX,LE,FC,HS,PT,SC,ps
  74. 495 BR,DX,LE=1 @ PT=3 @ FC,SC,ps=0 @ HS=4 @ GOSUB rs_set
  75. 600 com_proc: GOSUB dkeys
  76. 610 AWRITE 20,0 @ DISP CP$&" > Enter command ";! Display command prompt
  77. 620 RELEASE KEYBOARD
  78. 630 INPUT S$@ CP$=KP$
  79. 640 TAKE KEYBOARD
  80. 645 AWRITE 19,0,RPT$ (" ",80)
  81. 646 AWRITE 22,0,RPT$ (" ",160)
  82. 650 GOSUB split
  83. 660 C=FNinlist(F$,CL$)
  84. 670 IF C=0 THEN AWRITE 22,0,"Invalid command - "&F$
  85. 675 IF C<1 THEN 610
  86. 680 ON C GOSUB connect ,send_file ,rec_file ,set ,show_pars ,exit ,exit ,dir
  87. 690 GOTO com_proc
  88. 730 split: S$=TRIM$ (S$)
  89. 740 p=POS (S$,Q$) @ P=POS (S$,SP$)
  90. 745 IF p*P=0 THEN P=MAX (P,p) ELSE P=MIN (P,p)
  91. 750 IF P=0 THEN F$=S$ @ S$="" ELSE F$=S$[1,P-1] @ S$=S$[P,LEN (S$)]
  92. 760 RETURN
  93. 880 exit: CLEAR @ RELEASE KEYBOARD @ ABORTIO 10 @ DISP "Kermit finished" @ END
  94. 930 dir: ON ERROR GOSUB fserr  @ f=0
  95. 935 S$=TRIM$ (S$) @ IF S$#"" THEN CAT S$ ELSE CAT
  96. 940 IF f#0 THEN AWRITE 19,0,EM$(f) @ RETURN
  97. 950 FOR I=1 TO 4 @ DISP @ NEXT I @ RETURN
  98. 1050 connect: F,f=0
  99. 1070 C=0 @ START CRT AT R
  100. 1080 AWRITE 0,0 @ CLEAR
  101. 1090 DISP "HP86 Kermit - Terminal emulation mode" @ DISP
  102. 1100 DISP "Function key   Escape character   Action"
  103. 1110 DISP "--------------------------------------------------"
  104. 1120 DISP "   k1                 C           Return to KERMIT"
  105. 1130 DISP "   k7                 B           Transmit break"
  106. 1135 DISP "   k14                            Enable transmit"
  107. 1140 AWRITE 23,0
  108. 1150 DEL=5
  109. 1160 ON KEY# 1 GOTO EXIT1
  110. 1170 ON KEY# 7 GOSUB BREAK
  111. 1172 ON KEY# 14 GOSUB TX_EN
  112. 1180 ON EOT 10 GOSUB BUFFULL
  113. 1190 TAKE KEYBOARD
  114. 1200 k$=" " @ AWRITE 23,0,HGL?$ (k$,1)
  115. 1240 START: STATUS 10,9 ; S1,S2
  116. 1270 IF BINAND (S1,128)=0 OR BINAND (S2,32)=0 THEN RSGET
  117. 1310 K$=KEY$  @ IF K$="" THEN RSGET
  118. 1320 IF F=0 THEN KOUT ELSE F=0
  119. 1330 IF K$=ESC$ THEN 1500
  120. 1340 IF K$="C" OR K$="c" THEN EXIT1
  121. 1350 IF K$="B" OR K$="b" THEN GOSUB BREAK
  122. 1360 GOTO START
  123. 1370 KOUT: IF K$=BS$ THEN K$=DEL$
  124. 1380 IF K$=EL$ THEN K$=CR$ @ f=HS#0
  125. 1390 IF K$=ESC$ THEN F=1 @ BEEP @ GOTO RSGET
  126. 1400 IF K$>DEL$ THEN RSGET
  127. 1405 IF LE=0 THEN 1500
  128. 1410 AWRITE 23,C,k$
  129. 1420 IF K$ >= SP$ THEN 1450
  130. 1430 IF K$=CR$ THEN C=0 @ GOTO 1490
  131. 1440 IF K$=LF$ THEN 1470
  132. 1450 AWRITE 23,C,K$
  133. 1460 C=C+1 @ IF C<80 THEN 1490 ELSE C=0
  134. 1470 R=R+1 @ IF R=204 THEN R=0
  135. 1480 AWRITE 24,0,RPT$ (SP$,80) @ START CRT AT R
  136. 1490 AWRITE 23,C @ AREAD k$ @ AWRITE 23,C,HGL?$ (k$,1)
  137. 1500 OUTPUT OBUFF$ USING "#,A" ; K$
  138. 1502 IF f THEN OUTPUT OBUFF$ USING "#,A" ; HC$
  139. 1506 STATUS OBUFF$,1 ; S1,S,S3
  140. 1508 IF S1=0 OR S3#0 THEN 1520
  141. 1510 TRANSFER OBUFF$ TO  10 INTR
  142. 1520 WAIT DEL
  143. 1560 RSGET: STATUS IBUFF$,1 ; S3
  144. 1565 IF S3=0 THEN START
  145. 1570 AWRITE 23,C,k$
  146. 1580 ENTER IBUFF$ USING "#,#K" ; I$
  147. 1590 FOR I=1 TO LEN (I$)
  148. 1600 K$=I$[I,I]
  149. 1610 IF K$ >= SP$ THEN 1660
  150. 1620 IF K$=CR$ THEN C=0 @ GOTO 1700
  151. 1630 IF K$=LF$ THEN 1680
  152. 1640 IF K$=BEL$ THEN BEEP @ GOTO 1700
  153. 1650 GOTO 1700
  154. 1660 AWRITE 23,C,K$
  155. 1670 C=C+1 @ IF C<80 THEN 1700 ELSE C=0
  156. 1680 R=R+1 @ IF R=204 THEN R=0
  157. 1690 AWRITE 24,0,RPT$ (SP$,80) @ START CRT AT R
  158. 1700 NEXT I
  159. 1710 AWRITE 23,C @ AREAD k$ @ AWRITE 23,C,HGL?$ (k$,1)
  160. 1720 GOTO START
  161. 1760 BUFFULL: OFF EOT 10 @ STATUS 10,11 ; S4
  162. 1765 IF BINAND (S4,64)#0 THEN 1810
  163. 1770 IF f=0 THEN 1850
  164. 1780 f=0 @ STATUS 10,9 ; S@ S=BINAND (S,127)
  165. 1790 ABORTIO 10 @ CONTROL 10,9 ; S@ TRANSFER 10 TO  IBUFF$ INTR
  166. 1800 GOTO 1850
  167. 1810 ENTER IBUFF$ USING "#,#K" ; I$@ TRANSFER 10 TO  IBUFF$ INTR
  168. 1830 DISP I$
  169. 1840 DISP "BUFFER FULL POSSIBLE DATA LOSS !"
  170. 1850 ON EOT 10 GOSUB BUFFULL  @ RETURN
  171. 1890 EXIT1:
  172. 1900 RELEASE KEYBOARD @ OFF EOT 10 @ CLEAR
  173. 1910 RETURN
  174. 1950 BREAK: REQUEST 10;8 @ RETURN
  175. 1990 TX_EN: RESUME 10 @ RETURN
  176. 2190 send_file: S$=TRIM$ (S$) @ DF$=""
  177. 2195 IF S$="?" THEN AWRITE 22,0,SS$ @ RETURN
  178. 2200 p=FNfsplit(S$) @ IF p=0 THEN errfn
  179. 2210 SF$=TRIM$ (S$[2,p])
  180. 2220 IF l<p+2 THEN volrem
  181. 2230 S$=TRIM$ (S$[p+2,l])
  182. 2240 p=FNfsplit(S$) @ IF p=0 THEN errfn
  183. 2250 S$=TRIM$ (S$[2,p]) @ GOTO chckfn
  184. 2290 volrem: S$=SF$
  185. 2300 p=POS (S$,DT$) @ IF p=0 THEN p=POS (S$,CN$)
  186. 2310 IF p>0 THEN S$=S$[1,p-1]
  187. 2350 chckfn: l=LEN (S$) @ f=0 @ j=0
  188. 2360 S$=UPC$ (S$)
  189. 2370 IF POS (S$,DT$) THEN 2410
  190. 2380 p=POS (S$,SP$) @ IF p>0 THEN 2400
  191. 2390 p=POS (S$,UL$) @ IF p=0 THEN 2410
  192. 2400 S$[p,p]=DT$
  193. 2410 FOR i=1 TO l @ p=POS (VC$,S$[i,i])
  194. 2420 IF p=0 OR p=1 AND (f=1 OR j=0 OR j=l-1) THEN 2450
  195. 2430 IF p=1 THEN f=1
  196. 2440 j=j+1 @ DF$[j,j]=S$[i,i]
  197. 2450 NEXT i
  198. 2460 IF j=0 THEN DF$=SF$ @ GOTO 2800
  199. 2470 l=LEN (DF$) @ p=POS (DF$,DT$)
  200. 2480 IF p=0 THEN DF$=DF$&"." @ p=l
  201. 2490 IF p=l THEN DF$=DF$&FTYP$
  202. 2800 n,pc,st,k,SNPAD=0 @ RT$="" @ sr=15 @ rr=17
  203. 2805 GOSUB open_read  @ IF f#0 THEN srexit
  204. 2810 GOSUB dsend  @ ON KEY# 1 GOSUB abort
  205. 2840 send_init: n=0 @ T$=SI$ @ T=0 @ IBUFF$=""
  206. 2845 GOSUB init_pack  @ OD$=IN$
  207. 2890 GOSUB send_pack  @ IF f#0 THEN srexit
  208. 2930 GOSUB dcd_init
  209. 3040 send_head: T$=SH$ @ T=1 @ OD$=DF$
  210. 3050 GOSUB send_pack  @ IF f#0 THEN srexit
  211. 3090 T$=SD$ @ T=2 @ DB$="" @ e=0 @ MAXL=SMAXL-3
  212. 3100 MINL=IP (MAXL/2) @ IF MINL<1 THEN MINL=1
  213. 3110 GOSUB get_data  @ IF f#0 THEN RETURN
  214. 3120 IF OD$="" THEN send_eof
  215. 3130 GOSUB send_pack  @ IF f#0 THEN srexit
  216. 3135 IF LEN (ID$)=0 THEN 3110
  217. 3140 IF ID$[1,1]#"Z" AND ID$[1,1]#"X" THEN 3110
  218. 3180 send_eof: T$=SE$ @ T=3
  219. 3190 GOSUB send_pack  @ IF f#0 THEN srexit
  220. 3200 T$=SB$ @ T=4 @ GOSUB send_pack
  221. 3210 GOTO srexit
  222. 3540 errfn: CP$="Filename error" @ RETURN
  223. 4080 rec_file: S$=TRIM$ (S$)
  224. 4083 IF S$="?" THEN AWRITE 22,0,RS$ @ RETURN
  225. 4085 sr=17 @ rr=15 @ st=1 @ GOSUB dsend
  226. 4090 p=FNfsplit(S$) @ IF p=0 THEN ft=1 @ GOTO 4200
  227. 4100 DF$=TRIM$ (S$[2,p]) @ ft=0
  228. 4110 p=POS (DF$,DT$) @ IF p=0 THEN p=POS (DF$,CN$)
  229. 4120 IF p=0 THEN 4150
  230. 4130 VN$=DF$[p] @ IF p=1 OR LEN (VN$)>6 THEN errfn
  231. 4140 DF$=DF$[1,p-1]
  232. 4150 IF LEN (DF$)>10 THEN errfn
  233. 4155 AWRITE 4,2,ST$(1)&" as '"&DF$&"'"
  234. 4200 rec_init: n,nf,pc,k=0 @ IBUFF$="" @ ON KEY# 1 GOSUB abort
  235. 4210 GOSUB init_pack  @ A$=SI$ @ T=0
  236. 4220 GOSUB get_pack  @ IF f#0 THEN srexit
  237. 4230 GOSUB dcd_init
  238. 4240 rec_head: A$="FBSZ" @ DB$=""
  239. 4250 T=8 @ GOSUB get_pack
  240. 4260 IF RT$=SB$ OR f#0 THEN srexit
  241. 4270 SF$=ID$ @ k=0
  242. 4272 IF ft=0 THEN 4330 ELSE DF$=SF$
  243. 4275 l=LEN (DF$) @ p=POS (DF$,DT$)
  244. 4280 IF l=0 THEN DF$=DFN$&DFT$ @ GOTO 4275
  245. 4285 IF p=0 THEN 4330
  246. 4290 IF p=l THEN DF$=DF$&DFT$ @ GOTO 4275
  247. 4295 IF p=1 THEN DF$=DFN$&DF$ @ GOTO 4275
  248. 4300 F$=DF$[1,p-1] @ IF LEN (F$)>6 THEN F$=F$[1,6]
  249. 4310 S$=DF$[p+1,l] @ IF LEN (S$)>3 THEN S$=S$[1,3]
  250. 4320 DF$=F$&SP$&S$ @ ft=LEN (F$)+1
  251. 4330 GOSUB open_write  @ IF f#0 THEN srexit
  252. 4335 AWRITE 4,2,ST$(1)&" '"&SF$&"' as '"&DF$&"'"
  253. 4370 rec_data: A$="DZF" @ T=9
  254. 4380 GOSUB get_pack  @ IF f#0 THEN srexit
  255. 4390 IF RT$=SE$ THEN GOSUB close_write  @ GOTO rec_head
  256. 4400 GOSUB put_data  @ IF f#0 THEN srexit
  257. 4410 GOTO rec_data
  258. 5050 show_pars: IF S$="" THEN sa
  259. 5060 set: GOSUB split  @ S$=TRIM$ (S$)
  260. 5070 p=FNinlist(F$,SL$)
  261. 5080 IF p<1 THEN DF$=F$ @ I$=IO$ @ GOTO 5150
  262. 5090 I$=FNxlist$(SL$,p)
  263. 5100 IF C=5 THEN 5140
  264. 5110 DF$=S$ @ O=p
  265. 5120 ON p GOSUB S0 ,S1 ,S2 ,S3 ,S4 ,S5 ,S6 ,S7 ,S8 ,S9 ,S10 ,S11 ,S12 ,S13 ,S14
  266. 5130 IF p<1 THEN 5150 ELSE p=O @ S$=DF$
  267. 5140 ON p GOSUB s0 ,s1 ,s2 ,s3 ,s4 ,s5 ,s6 ,s7 ,s8 ,s9 ,s10 ,s11 ,s12 ,s13 ,s14
  268. 5150 IF p>-1 THEN AWRITE 22,0,I$&" - "&DF$
  269. 5160 RETURN
  270. 5550 S0: RTO=FNpval(S$,RTO) @ RETURN
  271. 5560 S1: RLIM=FNpval(S$,RLIM) @ RETURN
  272. 5570 S2: ps=FNlset(S$,SC,OO$) @ RETURN
  273. 5580 S3: db=FNlset(S$,db,OO$) @ RETURN
  274. 5590 S4: p=0 @ IF LEN (S$)#1 THEN I$=IC$ @ RETURN
  275. 5600 SQCTL$=S$ @ RETURN
  276. 5610 S5: SEOL=FNpval(S$,SEOL) @ RETURN
  277. 5620 S6: T=0 @ DB$=""
  278. 5630 GOSUB split  @ k=FNpval(F$,0)
  279. 5640 IF k=0 THEN RETURN
  280. 5650 DB$=DB$&CHR$ (k) @ T=T+1
  281. 5660 IF S$#"" AND T<4 THEN 5630
  282. 5670 RE=T @ RE$=DB$ @ p=7 @ RETURN
  283. 5680 S7: FS=FNpval(S$,FS) @ NR=FS*1024/RL @ RETURN
  284. 5690 S8: RL=FNpval(S$,RL) @ NR=FS*1024/RL @ RETURN
  285. 5700 S9: NR=FNpval(S$,NR) @ FS=NR*RL/1024 @ RETURN
  286. 5710 S10: DX=FNlset(S$,DX,DX$) @ LE=DX @ GOTO 5760
  287. 5720 S11: LE=FNlset(S$,LE,OO$) @ GOTO 5760
  288. 5730 S12: FC=FNlset(S$,FC,FC$) @ IF FC#0 THEN HS=0
  289. 5735 GOTO 5760
  290. 5740 S13: HS=FNlset(S$,HS,HS$) @ IF HS#0 THEN FC=0
  291. 5745 GOTO 5760
  292. 5750 S14: PT=FNlset(S$,PT,PT$)
  293. 5760 GOSUB rs_set  @ RETURN
  294. 6110 sa: CLEAR
  295. 6120 FOR N=0 TO 14 @ n=N+1
  296. 6130 AWRITE 2+N DIV 2,40*(N MOD 2),FNxlist$(SL$,n)
  297. 6140 ON n GOSUB s0 ,s1 ,s2 ,s3 ,s4 ,s5 ,s6 ,s7 ,s8 ,s9 ,s10 ,s11 ,s12 ,s13 ,s14
  298. 6150 AWRITE 2+N DIV 2,15+40*(N MOD 2),DF$
  299. 6160 NEXT N
  300. 6170 RETURN
  301. 6200 s0: DF$=VAL$ (RTO) @ RETURN
  302. 6210 s1: DF$=VAL$ (RLIM) @ RETURN
  303. 6220 s2: DF$=FNxlist$(OO$,SC+1) @ RETURN
  304. 6230 s3: DF$=FNxlist$(OO$,db+1) @ RETURN
  305. 6240 s4: DF$=SQCTL$ @ RETURN
  306. 6250 s5: DF$=VAL$ (SEOL) @ RETURN
  307. 6260 s6: DF$=""
  308. 6262 FOR I=1 TO RE @ DF$=DF$&VAL$ (NUM (RE$[I,I]))&SP$ @ NEXT I
  309. 6265 RETURN
  310. 6270 s7: DF$=VAL$ (FS)&"k" @ RETURN
  311. 6280 s8: DF$=VAL$ (RL) @ RETURN
  312. 6290 s9: DF$=VAL$ (NR) @ RETURN
  313. 6300 s10: DF$=FNxlist$(DX$,DX+1) @ RETURN
  314. 6310 s11: DF$=FNxlist$(OO$,LE+1) @ RETURN
  315. 6320 s12: DF$=FNxlist$(FC$,FC+1) @ RETURN
  316. 6330 s13: DF$=FNxlist$(HS$,HS+1) @ RETURN
  317. 6340 s14: DF$=FNxlist$(PT$,PT+1) @ RETURN
  318. 10080 rec_pack: m=0 @ ID$=""
  319. 10090 ON TIMER# 1,TMO GOTO rto
  320. 10100 b_chk: STATUS IBUFF$,1 ; S
  321. 10105 K$=KEY$  @ IF K$#"" THEN rto
  322. 10110 IF S=0 THEN WAIT TMO/5 @ GOTO b_chk
  323. 10120 ENTER IBUFF$ USING "#,#K" ; I$
  324. 10130 l=LEN (I$) @ i=1
  325. 10140 n_chr: k$=I$[i,i]
  326. 10145 IF k$=MK$ THEN m=1 @ RP$="" @ j=0
  327. 10150 IF m=0 THEN i_chr
  328. 10160 IF k$=REOL$ THEN e_pck
  329. 10170 RP$=RP$&k$ @ j=j+1
  330. 10180 i_chr: i=i+1 @ IF i>l THEN b_chk ELSE n_chr
  331. 10190 e_pck: IF j<5 THEN 10100
  332. 10200 OFF TIMER# 1
  333. 10210 IF i<l THEN IBUFF$=I$[i+1,l]&IBUFF$
  334. 10220 IF db=1 THEN AWRITE rr,rc,RP$
  335. 10230 c$=FNcbyte$(RP$[2,j-1])
  336. 10240 IF c$#RP$[j,j] THEN RT$=FNstbit$(RP$[j]) @ bp=bp+1 @ RETURN
  337. 10250 RT$=RP$[4,4] @ rn=FNunchar(RP$[3,3])
  338. 10260 f=0 @ FOR i=5 TO j-1 @ k$=RP$[i,i]
  339. 10270 IF f=0 THEN 10300
  340. 10280 IF k$#RQCTL$ THEN k$=FNctl$(k$)
  341. 10290 f=0 @ GOTO 10310
  342. 10300 IF k$=RQCTL$ THEN f=1 @ GOTO 10320
  343. 10310 ID$=ID$&k$
  344. 10320 NEXT i @ RETURN
  345. 10330 rto: OFF TIMER# 1
  346. 10333 IF m=1 THEN m=2 @ GOTO 10090
  347. 10335 IF HS#0 THEN RESUME 10
  348. 10338 tmo=tmo+1 @ RT$="T" @ RETURN
  349. 10370 send_pack: f=0 @ r=0 @ GOSUB c_pack
  350. 10380 send1: s=T @ GOSUB disp_state
  351. 10390 IF db THEN AWRITE sr,0,RPT$ (SP$,320) @ AWRITE sr,sc,OP$
  352. 10400 GOSUB send_buff  @ IF f#0 THEN RETURN
  353. 10410 s=6 @ GOSUB disp_state  @ GOSUB rec_pack
  354. 10415 IF RT$>DEL$ OR RT$=TM$ THEN 10450
  355. 10420 N=BINAND (rn-BINAND (n,63),63) @ f=0
  356. 10430 IF RT$=AK$ AND N=0 OR RT$=NK$ AND N=1 THEN pc,n=n+1 @ RETURN
  357. 10435 IF RT$=AK$ AND N=63 THEN 10410
  358. 10440 IF RT$#NK$ THEN f=4 @ RETURN ELSE nk=nk+1
  359. 10450 r=r+1 @ IF r<RLIM THEN send1
  360. 10460 IF RT$=TM$ THEN f=1 @ RETURN
  361. 10470 IF RT$=NK$ THEN f=2 ELSE f=3
  362. 10480 RETURN
  363. 10540 c_pack: OP$=FNchar$(BINAND (n,63))&T$&OD$
  364. 10550 OP$=FNchar$(LEN (OP$)+1)&OP$
  365. 10560 OP$=MK$&OP$&FNcbyte$(OP$)
  366. 10570 IF SNPAD>0 THEN OBUFF$=RPT$ (SPADC$,SNPAD)
  367. 10580 OUTPUT OBUFF$ USING "#,K" ; OP$&CHR$ (SEOL)
  368. 10585 IF HS#0 THEN OUTPUT OBUFF$ USING "#,A" ; HC$
  369. 10590 STATUS OBUFF$,1 ; bl@ RETURN
  370. 10620 send_buff:
  371. 10630 ON TIMER# 1,STM GOTO 10690
  372. 10640 CONTROL OBUFF$,1 ; bl
  373. 10650 TRANSFER OBUFF$ TO  10 INTR
  374. 10660 STATUS OBUFF$,1 ; S
  375. 10670 IF S>0 THEN 10660
  376. 10673 IF HS=0 THEN 10680
  377. 10675 STATUS 10,9 ; S@ S=BINAND (S,127)
  378. 10678 ABORTIO 10 @ CONTROL 10,9 ; S@ TRANSFER 10 TO  IBUFF$ INTR
  379. 10680 OFF TIMER# 1 @ IBUFF$=""
  380. 10685 RETURN
  381. 10690 f=5 @ OFF TIMER# 1 @ RETURN
  382. 10730 get_pack: r=0
  383. 10740 s=T @ GOSUB disp_state  @ AWRITE rr,0,RPT$ (SP$,320)
  384. 10745 f,p=0 @ GOSUB rec_pack
  385. 10750 IF RT$=TM$ THEN f=1 @ GOTO 10830
  386. 10760 IF RT$>DEL$ THEN f=3 @ GOTO 10830
  387. 10770 p=POS (A$,RT$) @ N=BINAND (rn-n,63)
  388. 10780 IF N#0 AND N#63 OR p=0 THEN f=4 @ RETURN
  389. 10790 OD$="" @ IF RT$=SI$ THEN OD$=IN$
  390. 10800 T$=AK$ @ s=6 @ n=rn @ GOSUB c_pack
  391. 10810 n=(n+1) MOD 64 @ GOTO 10850
  392. 10830 r=r+1 @ IF r>RLIM THEN RETURN
  393. 10840 T$=NK$ @ s=7 @ OD$="" @ nk=nk+1 @ GOSUB c_pack
  394. 10850 GOSUB disp_state  @ IF db THEN AWRITE sr,sc,OP$
  395. 10860 f=0 @ GOSUB send_buff  @ IF f#0 THEN RETURN
  396. 10870 IF p#1 AND p#2 OR N#0 THEN 10740
  397. 10880 pc=pc+1 @ RETURN
  398. 11080 init_pack: tmo,nk,bp=0
  399. 11090 TMO=RTO*1000
  400. 11100 IN$=FNchar$(RMAXL)
  401. 11110 IN$=IN$&FNchar$(STO)
  402. 11120 IN$=IN$&FNchar$(RNPAD)&FNctl$(RPADC$)
  403. 11130 IN$=IN$&FNchar$(SEOL)&SQCTL$
  404. 11140 SMAXL=80 @ SNPAD=0 @ SPADC$=NULL$ @ REOL=13 @ RQCTL$="#"
  405. 11150 RETURN
  406. 11190 dcd_init: l=LEN (RP$)-5 @ IF l=0 THEN RETURN
  407. 11200 IF l<7 THEN ON l GOTO maxl ,tmo ,npad ,padc ,elc ,qctl
  408. 11210 qctl: IF RP$[10,10]#SP$ THEN RQCTL$=RP$[10,10]
  409. 11220 elc: IF RP$[9,9]#SP$ THEN SEOL=FNunchar(RP$[9,9])
  410. 11230 padc: IF RP$[8,8]#SP$ THEN SPADC$=FNctl$(RP$[8,8])
  411. 11240 npad: IF RP$[7,7]#SP$ THEN SNPAD=FNunchar(RP$[7,7])
  412. 11250 tmo: IF RP$[6,6]#SP$ THEN RTO=FNunchar(RP$[6,6])
  413. 11260 maxl: IF RP$[5,5]#SP$ THEN SMAXL=FNunchar(RP$[5,5])
  414. 11270 RETURN
  415. 12030 srexit: IF f=0 OR f=5 THEN 12080
  416. 12040 IF f#4 OR RT$#ER$ THEN 12060
  417. 12050 AWRITE 19,0,"Error message from remote - "&ID$ @ RETURN
  418. 12060 OD$=EM$(f) @ T$=ER$ @ T=5
  419. 12070 GOSUB c_pack  @ GOSUB send_buff
  420. 12080 AWRITE 19,0,EM$(f)
  421. 12082 BEEP (f#1)*20+20,200
  422. 12085 IF f>6 AND f<23 THEN AWRITE 19,LEN (EM$(f))+1,"(error no - "&VAL$ (e)&")"
  423. 12090 RETURN
  424. 12130 abort: f=24 @ RETURN
  425. 20080 DEF FNchar$(n) = CHR$ (n+32)
  426. 20120 DEF FNunchar(c$[1]) = NUM (c$)-32
  427. 20160 DEF FNctl$(c$[1]) = CHR$ (BINEOR (NUM (c$),64))
  428. 20200 DEF FNstbit$(c$[1]) = CHR$ (BINEOR (NUM (c$),128))
  429. 20240 DEF FNcbyte$(S$[96])
  430. 20250 t=0 @ l=LEN (S$) @ FOR i=1 TO l @ t=t+NUM (S$[i,i]) @ NEXT i
  431. 20260 FNcbyte$=FNchar$(BINAND (t+BINAND (t,192)/64,63))
  432. 20270 FN END
  433. 30290 dsend: CLEAR
  434. 30300 AWRITE 1,2,"HP86 Kermit - "&ST$(st)&" file"
  435. 30310 AWRITE 2,2,RPT$ ("-",LEN (ST$(st))+19)
  436. 30320 IF st=0 THEN AWRITE 4,2,ST$(st)&" "&SF$&" as "&DF$
  437. 30330 AWRITE 6,2,"Current action :" @ AWRITE 6,46,"Retries :"
  438. 30340 AWRITE 8,2,"Packets          :" @ AWRITE 8,40,"NAKs          :"
  439. 30350 AWRITE 9,2,"Bytes            :" @ AWRITE 9,40,"Timeouts      :"
  440. 30360 AWRITE 10,40,"Bad packets   :"
  441. 30370 AWRITE 8,10,st$(st) @ AWRITE 8,45,st$(1-st) @ AWRITE 9,8,st$(st)
  442. 30380 RETURN
  443. 30420 disp_state: t=s>7 OR s=6 AND st=0 OR s=0 AND st=1
  444. 30425 IF t THEN D$="Wait for " ELSE D$="Send "
  445. 30427 AWRITE 6,18,RPT$ (SP$,26)
  446. 30430 AWRITE 6,18,D$&A$(s) @ AWRITE 6,56,VAL$ (r)
  447. 30440 AWRITE 8,21,VAL$ (pc) @ AWRITE 8,56,VAL$ (nk)
  448. 30450 AWRITE 9,21,FNkb$(k) @ AWRITE 9,56,VAL$ (tmo)
  449. 30460 AWRITE 10,56,VAL$ (bp)
  450. 30470 RETURN
  451. 30500 DEF FNkb$(k) = VAL$ (IP (k/102.4)/10)&"k  "
  452. 40080 open_read: ON ERROR GOTO fserr  @ ASSIGN# 1 TO  SF$
  453. 40090 OFF ERROR @ f=0 @ RETURN
  454. 40210 get_data: b=0 @ ON ERROR GOTO 40380
  455. 40220 l=LEN (DB$) @ IF l>= MINL THEN 40330
  456. 40230 t=TYP (1) @ IF t#3 THEN 40250
  457. 40240 e=1 @ OFF ERROR
  458. 40245 IF l=0 THEN OD$="" @ RETURN ELSE 40335
  459. 40250 IF t=1 THEN 40320
  460. 40260 READ# 1 ; S$@ S$=S$&RE$ @ L=LEN (S$) @ k=k+L
  461. 40270 FOR i=1 TO L @ k$=S$[i,i]
  462. 40280 IF k$ <= DEL$ THEN 40300 ELSE k$=FNstbit$(k$)
  463. 40290 IF b=0 THEN DISP "Eight bit data" @ BEEP @ b=1
  464. 40300 IF k$<SP$ THEN DB$=DB$&SQCTL$ @ k$=FNctl$(k$)
  465. 40305 IF k$=SQCTL$ THEN DB$=DB$&k$
  466. 40310 DB$=DB$&k$ @ NEXT i @ GOTO 40220
  467. 40320 IF SC=0 THEN f=23 @ RETURN
  468. 40323 READ# 1,S @ S$=VAL$ (S)
  469. 40325 DB$=DB$&SP$&S$ @ k=k+LEN (S$)+1 @ GOTO 40220
  470. 40330 OFF ERROR
  471. 40335 IF l<= MAXL THEN OD$=DB$ @ DB$="" @ RETURN
  472. 40340 S=MAXL
  473. 40350 IF DB$[S,S]=SQCTL$ THEN S=S-1 @ GOTO 40350
  474. 40360 OD$=DB$[1,S] @ DB$=DB$[S+1,l]
  475. 40370 RETURN
  476. 40380 OFF ERROR @ IF ERRN =71 OR ERRN =72 THEN 40240
  477. 40390 IF ERRN =33 THEN f=23 @ RETURN
  478. 40400 GOTO fserr
  479. 40530 open_write: f=0
  480. 40540 IF DF$#PF$ THEN nf=0 @ GOTO 40560
  481. 40550 IF nf>99 THEN f=6 @ RETURN
  482. 40555 DF$=FNnofile$(DF$)
  483. 40560 ON ERROR GOTO fserr
  484. 40570 CREATE DF$,NR,RL
  485. 40580 ASSIGN# 1 TO  DF$
  486. 40585 OFF ERROR @ PF$=DF$
  487. 40590 RETURN
  488. 40630 put_data: DB$=DB$&ID$ @ k=k+LEN (ID$)
  489. 40635 ON ERROR GOTO fserr
  490. 40640 p=POS (DB$,RE$)
  491. 40645 IF p=0 THEN OFF ERROR @ RETURN
  492. 40650 IF p>1 THEN S$=DB$[1,p-1] ELSE S$=""
  493. 40660 PRINT# 1 ; S$ @ l=LEN (DB$)
  494. 40670 IF l>p+(RE-1) THEN DB$=DB$[p+RE] ELSE DB$=""
  495. 40680 GOTO 40640
  496. 40730 close_write: ON ERROR GOTO fserr
  497. 40740 IF LEN (DB$)>0 THEN PRINT# 1 ; DB$ @ DB$=""
  498. 40750 ASSIGN# 1 TO  *
  499. 40760 OFF ERROR
  500. 40770 RETURN
  501. 41030 fserr: e=ERRN  @ l=ERRL  @ OFF ERROR
  502. 41040 IF e=63 AND l=40570 THEN 40550
  503. 41050 p=POS (FSE$,CHR$ (e))
  504. 41060 IF p>0 THEN f=6+p @ RETURN
  505. 41070 RELEASE KEYBOARD @ DISP "UNEXPECTED ERROR !"
  506. 41080 DISP USING "6A,K,9A,K" ; "ERROR ",e," AT LINE ",l @ END
  507. 42030 DEF FNnofile$(F$)
  508. 42040 IF nf>0 THEN 42120
  509. 42080 IF ft<2 THEN 42110
  510. 42090 np,p=ft @ IF np>5 THEN np=5
  511. 42100 F$[np]="00"&F$[p] @ GOTO 42130
  512. 42110 np=LEN (F$)+1 @ IF np>9 THEN np=9
  513. 42120 F$[np,np+1]=VAL$ (nf DIV 10)&VAL$ (nf MOD 10)
  514. 42130 nf=nf+1 @ FNnofile$=F$
  515. 42140 FN END
  516. 50020 rs_set: ABORTIO 10
  517. 50025 IF BR=0 THEN S=2 ELSE S=6
  518. 50030 CONTROL 10,3 ; S
  519. 50035 IF PT=0 THEN S=3 ELSE S=2+((PT-1)*2+1)*8
  520. 50040 CONTROL 10,4 ; S
  521. 50045 IF FC=2 THEN S=48 ELSE S=0
  522. 50050 CONTROL 10,5 ; S
  523. 50055 IF FC=1 OR HS#0 THEN S=128+64*(FC=1) ELSE S=0
  524. 50060 CONTROL 10,11 ; S
  525. 50065 IF FC=2 THEN S=128 ELSE S=0
  526. 50070 CONTROL 10,16 ; S
  527. 50075 IF HS#0 THEN S=4+HS*3+(HS=4) @ HC$=CHR$ (S) ELSE S=17
  528. 50080 CONTROL 10,15 ; S
  529. 50090 CONTROL 10,9 ; 225
  530. 50100 CONTROL 10,14 ; 19
  531. 50120 IOBUFFER IBUFF$
  532. 50130 IOBUFFER OBUFF$
  533. 50140 TRANSFER 10 TO  IBUFF$ INTR
  534. 50145 RETURN
  535. 50180 dummy: RETURN
  536. 50220 dkeys: FOR i=1 TO 14 @ ON KEY# i GOSUB dummy  @ NEXT i @ RETURN
  537. 50530 DEF FNfsplit(F$[80])
  538. 50540 p=0 @ l=LEN (F$)
  539. 50545 IF l<3 THEN 50570
  540. 50550 IF F$[1,1]#Q$ THEN 50570
  541. 50560 p=POS (F$[2],Q$) @ IF p<2 THEN p=0
  542. 50570 FNfsplit=p
  543. 50580 FN END
  544. 51010 DEF FNinlist(c$,l$[195])
  545. 51020 c$=UPC$ (c$) @ l,j=1 @ L=LEN (l$)
  546. 51030 IF c$#"?" THEN 51100
  547. 51040 j=-1 @ IF L<68 THEN P=L @ GOTO 51070
  548. 51045 AWRITE 22,0,RPT$ (SP$,160)
  549. 51050 p=POS (l$[l],", ")
  550. 51055 IF p=0 THEN P=L @ GOTO 51070
  551. 51060 l=l+p @ IF l<68 THEN P=l-1 @ GOTO 51045
  552. 51070 AWRITE 22,0,"Options :- "&l$[1,P] @ IF P=L THEN 51150
  553. 51080 l$=l$[P+2] @ L=L-P-1 @ l=1
  554. 51085 AWRITE 23,0,"Press any key for more"
  555. 51090 k$=KEY$  @ IF k$="" THEN 51090 ELSE 51045
  556. 51100 cp=POS (l$[l],",")
  557. 51110 IF cp>0 THEN cp=cp+l-1 ELSE cp=L
  558. 51120 p=POS (l$[l,cp],c$) @ IF p=1 THEN 51150
  559. 51130 j=j+1 @ l=cp+2 @ IF l<L THEN 51100
  560. 51140 j=0
  561. 51150 FNinlist=j
  562. 51160 FN END
  563. 51230 DEF FNpval(c$,o)
  564. 51240 IF c$#"?" THEN 51270
  565. 51250 DF$="value" @ p=0
  566. 51260 GOTO 51300
  567. 51270 c=NUM (c$)
  568. 51280 IF c<48 OR c>58 THEN I$=IV$ @ p=0 @ GOTO 51300
  569. 51290 o=VAL (c$)
  570. 51300 FNpval=o
  571. 51310 FN END
  572. 51430 DEF FNlset(c$,o,l$[183])
  573. 51440 p=FNinlist(c$,l$) @ IF p<1 THEN I$=IO$ ELSE o=p-1
  574. 51450 FNlset=o @ FN END
  575. 52030 DEF FNxlist$(l$[183],p)
  576. 52040 j=1 @ l=1 @ L=LEN (l$)
  577. 52050 cp=POS (l$[l],", ")
  578. 52060 IF cp>0 THEN cp=cp+l-2 ELSE cp=L
  579. 52070 IF j=p THEN FNxlist$=l$[l,cp] @ GOTO 52100
  580. 52080 j=j+1 @ l=cp+3 @ IF l<L THEN 52050
  581. 52090 FNxlist$=""
  582. 52100 FN END
  583.