disk8: Initial commit
[pdp8.git] / sw / adventure / SPEAK.RA
1 / SPEAK - Types out messages from the database
2 / Also includes TTY output routines that unpack
3 / packed sixbit into mixed case ASCII.
4 /
5 FIELD1 ADVTTY
6
7 TTY, 0 / TTY Output routine, dupe of FRTS
8 IOF / Protect from race conditions
9 SNA / Input or output?
10 JMP KBD / Input - read character
11 DCA HANGPT / Output - save char
12 RDF
13 TAD CDIF00
14 DCA CDFX
15 CDF 0
16 TAD% TOCHR / Output character status in FRTS
17 SMA SZA CLA / If gt 0, char backed up
18 JMP BUSY / Else must wait
19 LOOP, TAD% TOCHR / Get the status
20 CLL RAL /Busy flag in link
21 CLA CML RAR /Complement of busy in sign
22 TAD HANGPT
23 SPA /If tty not busy,
24 TLS /Send it
25 DCA% TOCHR /Store pos or neg, backed up or busy
26 TTYRET, ION /Interrupts back on
27 CDFX, HLT /Caller's field
28 JMP% TTY /Return
29
30 CDIF00, CIF CDF
31
32 BUSY, CDF 10 /Busy, must wait. Call Field 0 HANG routine
33 CIF 0
34 JMS% HANGPT+1
35 0451 / TTUHNG
36 CDF 0
37 JMP LOOP / Try output again
38
39 KBD, RDF
40 TAD CDIF00
41 DCA CDFX
42 CDF 0
43 TAD% TICHR / Any input?
44 SNA CLA
45 JMP WAIT / No, wait
46 GETIN, TAD% TICHR / Get character
47 DCA HANGPT / Save
48 DCA% TICHR / Clear buffer
49 TAD HANGPT
50 JMP TTYRET / Return
51
52 WAIT, CDF 10
53 CIF 0
54 JMS% HANGPT+1 /Hang
55 465 /KBUHNG
56 CDF 0
57 JMP GETIN /Get input
58 TOCHR, 4
59 TICHR, 5
60 HANGPT, ADDR #HANG
61 /
62 / Terminal line input routine. Used because the FRTS input is quite limited.
63 / This one handles scope rubouts and allows lower case input.
64 / Inputs: Array Returned characters, stored one sixbit per array word
65 / (The FORTRAN input routine is set up this way to unpack)
66 / Size Number of characters to allow
67 / Prompt Prompt string
68 FIELD1 RDLIN
69 /
70 ENTRY RDLINE
71 RDLINE, JA #RLST
72 #RLXR, ORG .+10
73 TEXT +RDLINE+
74 #RLRET, SETX #RLXR
75 SETB #RLBAS
76 JA .+3
77 #RLBAS, ORG .+6
78 BUFPT, ORG .+3
79 BUFLEN, ORG .+3
80
81 ORG #RLBAS+30
82 FNOP
83 JA #RLRET
84 FNOP
85 #RGOBK, 0;0
86 #RLRTN, BASE #RLBAS
87 JA #RGOBK
88 #RLST, STARTD
89 0210
90 FSTA #RGOBK,0
91 0200
92 SETX #RLXR
93 SETB #RLBAS
94 LDX 0,1
95 FSTA #RLBAS
96 FLDA% #RLBAS,1+
97 FSTA BUFPT
98 FLDA% #RLBAS,1+
99 FSTA BUFLEN
100 STARTF
101 /
102 / Pass down size to '8' code
103 /
104 SETX BUFSIZ
105 FLDA% BUFLEN
106 FNEG / Make it negative
107 ATX 0 / Pass buffer len
108 SETX #RLXR
109 TRAP4 GETLIN / Get input line
110 JA #RLRTN / And return
111 / Input reader
112
113 FIELD1 GETLN
114
115 GETLIN, 0
116 CLA
117 DCA OFFSET / Start at offset zero
118 TAD% SCOPT
119 AND K200
120 DCA SCOPE
121 TAD% BUFFLD+1 / Get CDF for buffer
122 AND FLDMSK
123 CLL RTL
124 RAL
125 TAD CDFG
126 DCA BUFCDF
127 /
128 / Go get an input character
129 /
130 GETNXT, JMS% PTTY+1 / Called with zero to get char
131 DCA INCH / Save input
132 /
133 / Specials?
134 /
135 TAD INCH
136 TAD MDEL / Delete?
137 SNA CLA
138 JMP DELETE / Handle that
139 TAD INCH
140 TAD MCR / CR?
141 SNA CLA
142 JMP ENTER / End of line, let's go.
143 TAD INCH
144 TAD MSPC / Less than space?
145 SPA CLA
146 JMP BELL / Nope, ignore
147 TAD OFFSET
148 TAD BUFSIZ / Room left?
149 SMA CLA
150 JMP BELL / Bell if not
151 TAD INCH
152 JMS% PTTY+1 / Echo it
153 TAD INCH
154 TAD LWRA / Is it lowercase?
155 SPA CLA
156 JMP UPPER / No, store it
157 TAD INCH
158 TAD LWRZ
159 SMA CLA
160 JMP UPPER / More than lowercase z
161 TAD INCH
162 TAD AMINA / Adjust to uppercase
163 DCA INCH
164 UPPER, JMS STORE / Store this character
165 JMP GETNXT / Get more
166 / Store a character in the output buffer
167 / using the current offset
168 /
169
170 STORE, 0
171 TAD OFFSET
172 TAD OFFSET
173 TAD OFFSET / Count FPP words
174 TAD% BUFPTR+1 / Pointer to exponent word
175 DCA BPT
176 TAD K27 / Exponent 27 for integer
177 JMS STO
178 JMS STO / Zero high word
179 TAD INCH / Char value
180 AND SIXMSK / Convert to sixbit
181 JMS STO / Store in buffer
182 CDF 10 / Back to my field
183 ISZ OFFSET / One more in the buffer
184 SPC, 240 / Really shouldn't overflow; harmless AND
185 JMP% STORE / Return
186 STO, 0
187 BUFCDF, HLT / Gets CDF for buffer field
188 DCA% BPT
189 ISZ BPT / Next word
190 JMP% STO / Return if no skip
191 TAD BUFCDF
192 TAD BS / Next field
193 DCA BUFCDF
194 JMP% STO
195
196 BELL, TAD BEL / Warn the user
197 JMS% PTTY+1
198 JMP GETNXT
199
200 DELETE, TAD OFFSET / How far into the buffer are we?
201 SNA CLA
202 JMP BELL / Ignore extra deletes
203 TAD SCOPE
204 SNA CLA
205 JMP DUMBDL / Simple fortran-format delete
206 TAD BS
207 JMS% PTTY+1
208 TAD SPC
209 JMS% PTTY+1
210 TAD BS
211 JMS% PTTY+1
212 JMP FIXOFF / Fix the offset
213 DUMBDL, TAD K334 / Backslash
214 JMS% PTTY+1
215 FIXOFF, CLA CMA
216 TAD OFFSET
217 DCA OFFSET
218 JMP GETNXT
219
220 ENTER, TAD CR / Send a RETURN
221 JMS% PTTY+1
222 CLRLP, TAD OFFSET / Is there space available?
223 TAD BUFSIZ
224 SMA CLA
225 JMP CLRDN
226 TAD SPC
227 DCA INCH
228 JMS STORE
229 JMP CLRLP
230 CLRDN, CIF CDF 0
231 JMP% GETLIN
232
233 BUFSIZ, 0
234 SCOPT, 7726 / Scope flag in OS/8
235 K200, 200
236 MDEL, -377 / Delete
237 MCR, -215
238 CR, 215
239 MSPC, -240
240 BEL, 207
241 LWRA, -341
242 LWRZ, -373
243 AMINA, -40 / Add to "a" to make "A"
244 BPT,
245 BUFFLD, ADDR BUFPT+1
246 SCOPE,
247 BUFPTR, ADDR BUFPT+2
248 OFFSET,
249 PTTY, ADDR TTY
250 BS, 10
251 K334, 334
252 CDFG, CDF 0
253 K27, 27
254 SIXMSK, 77
255 FLDMSK, 7
256 INCH, 0
257
258 /
259 / Fortran-callable message printer
260 / Put here to avoid wasting the rest of the page.
261 / Arguments:
262 / BUF Buffer pointer
263 / COUNT Number of characters to write, zero to look for end
264 / CRFLAG Carriage return flags.
265 / Bit 11 (1) = no lead LF
266 / Bit 10 (2) = no trail CR
267 / Bit 9 (4) = start lowercase
268 /
269 ENTRY SIXOUT
270 SIXOUT, JA #STRT
271 #SXR, ORG .+10
272 TEXT +SIXOUT+
273 #SRET, SETX #SXR
274 SETB #SBASE
275 JA .+3
276 #SBASE, ORG .+6
277 CNT, ORG .+3
278 SFLAG, ORG .+3
279
280 ORG #SBASE+30
281 FNOP
282 JA #SRET
283 FNOP
284 #SGOBK, 0;0
285 #SRTN, BASE #SBASE
286 JA #SGOBK
287 #STRT, STARTD
288 0210
289 FSTA #SGOBK,0
290 0200
291 SETX #SXR
292 SETB #SBASE
293 LDX 0,1
294 FSTA #SBASE
295 FLDA% #SBASE,1+
296 FSTA BUF / Buffer pointer
297 FLDA% #SBASE,1+ / Count
298 FSTA CNT
299 FLDA% #SBASE,1+ / Carriage control flag
300 FSTA SFLAG
301 STARTF
302 FLDA% CNT
303 SETX COUNT
304 ATX 0
305 FLDA% SFLAG
306 ATX 1
307 SETX #SXR
308 TRAP4 SIX8 /Call the 8-mode output routine
309 JA #SRTN
310
311 FIELD1 SXOUT
312 ENTRY SIX8 / Mixed case output routine
313
314 SIX8, 0
315 TAD CRFLAG /Suppresss carriage control?
316 RAR /Low bit suppresses lead LF
317 SZL CLA
318 JMP .+4 /No leading LF
319 CDF 10 / My field
320 TAD LF /Linefeed
321 JMS% TTYPTR+1 /Output it
322 TAD CRFLAG
323 AND K4 /Start in lower case?
324 SZA CLA
325 TAD K40 /Yes
326 TAD HUN /Reset conversion factor
327 DCA SHIFT
328 TAD BUF /Buffer field
329 AND K7 /Just the field bits
330 CLL RAL
331 RTL /Into place
332 TAD CDF0 /Into CDF instruction
333 DCA CDF1
334 TAD CDF1
335 DCA CDF2
336 TAD COUNT /Get buffer length
337 SNA
338 JMP NOTRIM /Zero means it has a terminating "@"
339 /
340 / Find the end of the string
341 /
342 CLA CMA /End is start + len - 1
343 TAD COUNT /String len in words
344 TAD BUF+1 /End of the string
345 DCA PTR /Pointer to end
346 TAD COUNT /Invert count
347 CMA IAC
348 DCA COUNT
349 CDF1, HLT
350 FNDEND, TAD% PTR
351 TAD K3740 / - ' ' (two spaces)
352 SZA CLA / Skip if blank
353 JMP NONBLK
354 ISZ COUNT /Count another
355 SKP
356 JMP NONBLK /If empty, done
357 CLA CMA / -1
358 TAD PTR
359 DCA PTR /Back pointer up
360 JMP FNDEND /Keep looking
361
362 NONBLK, TAD COUNT
363 SNA CLA /Skip if output left
364 JMP DONE /Nothing if count zero already
365 NOTRIM, TAD BUF+1 /Reset pointer to start
366 DCA PTR
367 CDF2, HLT
368 TAD% PTR /Get word
369 DCA STEMP /Save
370 TAD STEMP
371 RTR
372 RTR
373 RTR /First sixbit
374 JMS OUTONE /Convert and output it
375 TAD STEMP /Second sixbit
376 JMS OUTONE
377 ISZ PTR /Bump pointer
378 SKP /OK if no skip
379 JMP NEWFLD /Next field otherwise
380 INCCNT, ISZ COUNT
381 JMP CDF2 /Keep outputting
382 DONE, CLA
383 TAD CRFLAG /Suppress trailing CR?
384 RTR /2 bit suppresses trailing CR
385 SZL CLA /If zero, write it.
386 JMP OUT /Yes, leave now
387 CDF 10 /My field
388 TAD CRTN
389 JMS% TTYPTR+1
390 OUT, CIF CDF 0
391 JMP% SIX8
392
393 NEWFLD, TAD CDF1
394 TAD K10 /Next field
395 DCA CDF1
396 TAD CDF1
397 DCA CDF2
398 JMP INCCNT
399
400 OUTONE, 0
401 AND K77 /Mask
402 SNA
403 JMP DONE / End of string
404 TAD K7743 / minus '['
405 SNA
406 JMP SETLWR /Set to lowercase shift
407 TAD K2 / ok, ']'?
408 SNA
409 JMP SETUPR /Set to uppercase
410 TAD K7773 /Restore
411 SPA
412 TAD SHIFT /For positive, shift it
413 TAD K40 /Else it's not alphabetic
414 CDF 10 /My field
415 JMS% TTYPTR+1 /Output it
416 JMP% OUTONE /Done
417
418 SETLWR, TAD K40 /Reset shift
419 SETUPR, TAD HUN /For upper/lower
420 DCA SHIFT
421 JMP% OUTONE
422
423 TTYPTR, ADDR TTY
424 SHIFT, 140 /Shift value
425 / COUNT and CRFLAG must stay together
426 COUNT, 0 /Num words to output.
427 CRFLAG, 0 /1 - no leading LF, 2 no trailing CR
428 PTR, 0
429 CRTN, 15
430 LF, 12
431 K3740, 3740 /minus blank
432 BUF, 0;0;0 /Buffer 15-bit address
433 STEMP, 0
434 K77, 77 /sixbit mask
435 K7, 7
436 K4, 4
437 K40, 40
438 CDF0, CDF
439 HUN, 100
440 K7743, 7743
441 K7773, 7773
442 K10, 10 /Field increment
443 K2, 2
444
445 SECT SPEAK
446 /C
447 / SUBROUTINE SPEAK(N)
448 /C
449 /C PRINT THE MESSAGE IN RECORD N OF THE RANDOM ACCESS MESSAGE FILE.
450 /C
451 / IMPLICIT INTEGER (A-Z)
452 / COMMON /TXTCOM/ RTEXT,LINES,ASCVAR
453 / COMMON /ALPHAS/ BLANK,EOF
454 / DIMENSION RTEXT(205),LINES(36)
455 /C
456 EXTERN IO
457 EXTERN #HANG
458 JA #ST
459 #XR, ORG .+10
460 TEXT +SPEAK+
461 #RET, SETX #XR
462 SETB #BASE
463 JA .+3
464 #BASE, ORG .+6
465 N, ORG .+3
466 #DOTMP, ORG .+3
467 BLANK, TEXT + +
468 EOF, TEXT +>$< +
469 ONE, F 1.0
470 FOUR, F 4.0
471 ORG #BASE+30
472 FNOP
473 JA #RET
474 FNOP
475 #GOBAK, 0;0
476 I, ORG .+0003
477 L, ORG .+0003
478 OLDLOC, ORG .+0003
479 #LBL=.
480 COMMON TXTCOM
481 RTEXT, ORG .+1147
482 LINES, ORG .+0044
483 ASCVAR, ORG .+0003
484 TXTLOC, ORG .+0003
485 DATA, ORG .+0352
486 ORG #LBL
487 #RTN, BASE #BASE
488 JA #GOBAK
489 #ST, STARTD
490 0210
491 FSTA #GOBAK,0
492 0200
493 SETX #XR
494 SETB #BASE
495 LDX 0,1
496 FSTA #BASE
497 FLDA% #BASE,1+
498 FSTA N
499 STARTF
500 / IF(N.EQ.0)RETURN
501 FLDA% N
502 JEQ #RTN
503 / READ(2'N) LOC,LINES
504 FLDA N
505 STARTD
506 FSTA #G0002
507 STARTF
508 JSR IO
509 JA .+0004
510 #G0002, JA .
511 / IF(LINES(1).EQ.EOF)RETURN
512 FLDA ONE
513 ATX 7
514 FLDA LINES-0003,7
515 FSUB EOF
516 JEQ #RTN
517 /1 OLDLOC = LOC
518 #1, FLDA TXTLOC
519 FSTA OLDLOC
520 FLDA ONE
521 FSTA I
522
523 / DO 3 I=36,1,-1
524 / Set COUNT to the number of words (36 or 44 octal)
525 SETX COUNT
526 LDX 44,0 /44 words
527 LDX 0,1 /With carriage control
528 SETX #XR
529 / L=I
530 /3 CONTINUE
531 /5 TYPE 2,(LINES(I),I=1,L)
532 #5, FLDA LINEPT
533 FSTA BUF /Set buffer pointer
534 TRAP4 SIX8
535
536 FLDA% N
537 FADD ONE
538 FSTA% N
539 FLDA N
540 / READ(2'ASCVAR) LOC,LINES
541 STARTD
542 FSTA #G0006
543 STARTF
544 JSR IO
545 JA .+0004
546 #G0006, JA .
547 / IF(LOC .EQ. OLDLOC) GO TO 1
548 FLDA TXTLOC
549 FSUB OLDLOC
550 JEQ #1
551 EXTERN #WRITO
552 TRAP3 #WRITO
553 JA FOUR
554 JA #10+2
555 EXTERN #RENDO
556 TRAP3 #RENDO
557
558 /10 RETURN
559 #10, JA #RTN
560 / (1X)
561 5061
562 3051
563 /2 FORMAT(' ',36A2) PDP/8: (' ',12A6)
564 LINEPT, ADDR LINES
565 0
566 END