--- /dev/null
+/ SPEAK - Types out messages from the database\r
+/ Also includes TTY output routines that unpack\r
+/ packed sixbit into mixed case ASCII.\r
+/\r
+ FIELD1 ADVTTY\r
+\r
+TTY, 0 / TTY Output routine, dupe of FRTS\r
+ IOF / Protect from race conditions\r
+ SNA / Input or output?\r
+ JMP KBD / Input - read character\r
+ DCA HANGPT / Output - save char\r
+ RDF\r
+ TAD CDIF00\r
+ DCA CDFX\r
+ CDF 0\r
+ TAD% TOCHR / Output character status in FRTS\r
+ SMA SZA CLA / If gt 0, char backed up\r
+ JMP BUSY / Else must wait\r
+LOOP, TAD% TOCHR / Get the status\r
+ CLL RAL /Busy flag in link\r
+ CLA CML RAR /Complement of busy in sign\r
+ TAD HANGPT\r
+ SPA /If tty not busy, \r
+ TLS /Send it\r
+ DCA% TOCHR /Store pos or neg, backed up or busy\r
+TTYRET, ION /Interrupts back on\r
+CDFX, HLT /Caller's field\r
+ JMP% TTY /Return\r
+\r
+CDIF00, CIF CDF\r
+\r
+BUSY, CDF 10 /Busy, must wait. Call Field 0 HANG routine\r
+ CIF 0\r
+ JMS% HANGPT+1\r
+ 0451 / TTUHNG\r
+ CDF 0\r
+ JMP LOOP / Try output again\r
+\r
+KBD, RDF\r
+ TAD CDIF00\r
+ DCA CDFX\r
+ CDF 0\r
+ TAD% TICHR / Any input?\r
+ SNA CLA\r
+ JMP WAIT / No, wait\r
+GETIN, TAD% TICHR / Get character\r
+ DCA HANGPT / Save\r
+ DCA% TICHR / Clear buffer\r
+ TAD HANGPT\r
+ JMP TTYRET / Return\r
+\r
+WAIT, CDF 10\r
+ CIF 0\r
+ JMS% HANGPT+1 /Hang\r
+ 465 /KBUHNG\r
+ CDF 0\r
+ JMP GETIN /Get input\r
+TOCHR, 4\r
+TICHR, 5\r
+HANGPT, ADDR #HANG\r
+/\r
+/ Terminal line input routine. Used because the FRTS input is quite limited.\r
+/ This one handles scope rubouts and allows lower case input.\r
+/ Inputs: Array Returned characters, stored one sixbit per array word\r
+/ (The FORTRAN input routine is set up this way to unpack)\r
+/ Size Number of characters to allow\r
+/ Prompt Prompt string\r
+ FIELD1 RDLIN\r
+/\r
+ ENTRY RDLINE\r
+RDLINE, JA #RLST\r
+#RLXR, ORG .+10\r
+ TEXT +RDLINE+\r
+#RLRET, SETX #RLXR\r
+ SETB #RLBAS\r
+ JA .+3\r
+#RLBAS, ORG .+6\r
+BUFPT, ORG .+3\r
+BUFLEN, ORG .+3\r
+\r
+ ORG #RLBAS+30\r
+ FNOP\r
+ JA #RLRET\r
+ FNOP\r
+#RGOBK, 0;0\r
+#RLRTN, BASE #RLBAS\r
+ JA #RGOBK\r
+#RLST, STARTD\r
+ 0210\r
+ FSTA #RGOBK,0\r
+ 0200\r
+ SETX #RLXR\r
+ SETB #RLBAS\r
+ LDX 0,1\r
+ FSTA #RLBAS\r
+ FLDA% #RLBAS,1+\r
+ FSTA BUFPT\r
+ FLDA% #RLBAS,1+\r
+ FSTA BUFLEN\r
+ STARTF\r
+/\r
+/ Pass down size to '8' code\r
+/\r
+ SETX BUFSIZ \r
+ FLDA% BUFLEN\r
+ FNEG / Make it negative\r
+ ATX 0 / Pass buffer len\r
+ SETX #RLXR\r
+ TRAP4 GETLIN / Get input line\r
+ JA #RLRTN / And return\r
+/ Input reader\r
+\r
+ FIELD1 GETLN\r
+\r
+GETLIN, 0\r
+ CLA\r
+ DCA OFFSET / Start at offset zero\r
+ TAD% SCOPT\r
+ AND K200\r
+ DCA SCOPE\r
+ TAD% BUFFLD+1 / Get CDF for buffer\r
+ AND FLDMSK\r
+ CLL RTL\r
+ RAL\r
+ TAD CDFG\r
+ DCA BUFCDF\r
+/\r
+/ Go get an input character\r
+/\r
+GETNXT, JMS% PTTY+1 / Called with zero to get char\r
+ DCA INCH / Save input\r
+/\r
+/ Specials?\r
+/\r
+ TAD INCH\r
+ TAD MDEL / Delete?\r
+ SNA CLA\r
+ JMP DELETE / Handle that\r
+ TAD INCH\r
+ TAD MCR / CR?\r
+ SNA CLA\r
+ JMP ENTER / End of line, let's go.\r
+ TAD INCH\r
+ TAD MSPC / Less than space?\r
+ SPA CLA\r
+ JMP BELL / Nope, ignore\r
+ TAD OFFSET\r
+ TAD BUFSIZ / Room left?\r
+ SMA CLA\r
+ JMP BELL / Bell if not\r
+ TAD INCH\r
+ JMS% PTTY+1 / Echo it\r
+ TAD INCH\r
+ TAD LWRA / Is it lowercase?\r
+ SPA CLA\r
+ JMP UPPER / No, store it\r
+ TAD INCH\r
+ TAD LWRZ\r
+ SMA CLA\r
+ JMP UPPER / More than lowercase z\r
+ TAD INCH\r
+ TAD AMINA / Adjust to uppercase\r
+ DCA INCH\r
+UPPER, JMS STORE / Store this character\r
+ JMP GETNXT / Get more\r
+/ Store a character in the output buffer\r
+/ using the current offset\r
+/\r
+\r
+STORE, 0\r
+ TAD OFFSET\r
+ TAD OFFSET\r
+ TAD OFFSET / Count FPP words\r
+ TAD% BUFPTR+1 / Pointer to exponent word\r
+ DCA BPT\r
+ TAD K27 / Exponent 27 for integer\r
+ JMS STO\r
+ JMS STO / Zero high word\r
+ TAD INCH / Char value\r
+ AND SIXMSK / Convert to sixbit\r
+ JMS STO / Store in buffer\r
+ CDF 10 / Back to my field\r
+ ISZ OFFSET / One more in the buffer\r
+SPC, 240 / Really shouldn't overflow; harmless AND\r
+ JMP% STORE / Return\r
+STO, 0\r
+BUFCDF, HLT / Gets CDF for buffer field\r
+ DCA% BPT\r
+ ISZ BPT / Next word\r
+ JMP% STO / Return if no skip\r
+ TAD BUFCDF\r
+ TAD BS / Next field\r
+ DCA BUFCDF\r
+ JMP% STO\r
+\r
+BELL, TAD BEL / Warn the user\r
+ JMS% PTTY+1\r
+ JMP GETNXT\r
+\r
+DELETE, TAD OFFSET / How far into the buffer are we?\r
+ SNA CLA\r
+ JMP BELL / Ignore extra deletes\r
+ TAD SCOPE\r
+ SNA CLA\r
+ JMP DUMBDL / Simple fortran-format delete\r
+ TAD BS\r
+ JMS% PTTY+1\r
+ TAD SPC\r
+ JMS% PTTY+1\r
+ TAD BS\r
+ JMS% PTTY+1\r
+ JMP FIXOFF / Fix the offset\r
+DUMBDL, TAD K334 / Backslash\r
+ JMS% PTTY+1\r
+FIXOFF, CLA CMA\r
+ TAD OFFSET\r
+ DCA OFFSET\r
+ JMP GETNXT\r
+\r
+ENTER, TAD CR / Send a RETURN\r
+ JMS% PTTY+1\r
+CLRLP, TAD OFFSET / Is there space available?\r
+ TAD BUFSIZ\r
+ SMA CLA\r
+ JMP CLRDN\r
+ TAD SPC\r
+ DCA INCH\r
+ JMS STORE\r
+ JMP CLRLP\r
+CLRDN, CIF CDF 0\r
+ JMP% GETLIN\r
+\r
+BUFSIZ, 0\r
+SCOPT, 7726 / Scope flag in OS/8\r
+K200, 200\r
+MDEL, -377 / Delete \r
+MCR, -215\r
+CR, 215\r
+MSPC, -240\r
+BEL, 207\r
+LWRA, -341\r
+LWRZ, -373\r
+AMINA, -40 / Add to "a" to make "A"\r
+BPT,\r
+BUFFLD, ADDR BUFPT+1\r
+SCOPE,\r
+BUFPTR, ADDR BUFPT+2\r
+OFFSET,\r
+PTTY, ADDR TTY\r
+BS, 10\r
+K334, 334\r
+CDFG, CDF 0\r
+K27, 27\r
+SIXMSK, 77\r
+FLDMSK, 7\r
+INCH, 0\r
+\r
+/\r
+/ Fortran-callable message printer\r
+/ Put here to avoid wasting the rest of the page.\r
+/ Arguments:\r
+/ BUF Buffer pointer\r
+/ COUNT Number of characters to write, zero to look for end\r
+/ CRFLAG Carriage return flags.\r
+/ Bit 11 (1) = no lead LF\r
+/ Bit 10 (2) = no trail CR\r
+/ Bit 9 (4) = start lowercase\r
+/\r
+ ENTRY SIXOUT\r
+SIXOUT, JA #STRT\r
+#SXR, ORG .+10\r
+ TEXT +SIXOUT+\r
+#SRET, SETX #SXR\r
+ SETB #SBASE\r
+ JA .+3\r
+#SBASE, ORG .+6\r
+CNT, ORG .+3\r
+SFLAG, ORG .+3\r
+\r
+ ORG #SBASE+30\r
+ FNOP\r
+ JA #SRET\r
+ FNOP\r
+#SGOBK, 0;0\r
+#SRTN, BASE #SBASE\r
+ JA #SGOBK\r
+#STRT, STARTD\r
+ 0210\r
+ FSTA #SGOBK,0\r
+ 0200\r
+ SETX #SXR\r
+ SETB #SBASE\r
+ LDX 0,1\r
+ FSTA #SBASE\r
+ FLDA% #SBASE,1+\r
+ FSTA BUF / Buffer pointer\r
+ FLDA% #SBASE,1+ / Count\r
+ FSTA CNT\r
+ FLDA% #SBASE,1+ / Carriage control flag\r
+ FSTA SFLAG\r
+ STARTF\r
+ FLDA% CNT\r
+ SETX COUNT\r
+ ATX 0\r
+ FLDA% SFLAG\r
+ ATX 1\r
+ SETX #SXR\r
+ TRAP4 SIX8 /Call the 8-mode output routine\r
+ JA #SRTN\r
+\r
+ FIELD1 SXOUT\r
+ ENTRY SIX8 / Mixed case output routine\r
+\r
+SIX8, 0\r
+ TAD CRFLAG /Suppresss carriage control?\r
+ RAR /Low bit suppresses lead LF\r
+ SZL CLA\r
+ JMP .+4 /No leading LF\r
+ CDF 10 / My field\r
+ TAD LF /Linefeed\r
+ JMS% TTYPTR+1 /Output it\r
+ TAD CRFLAG\r
+ AND K4 /Start in lower case?\r
+ SZA CLA\r
+ TAD K40 /Yes\r
+ TAD HUN /Reset conversion factor\r
+ DCA SHIFT\r
+ TAD BUF /Buffer field\r
+ AND K7 /Just the field bits\r
+ CLL RAL\r
+ RTL /Into place\r
+ TAD CDF0 /Into CDF instruction\r
+ DCA CDF1\r
+ TAD CDF1\r
+ DCA CDF2\r
+ TAD COUNT /Get buffer length\r
+ SNA\r
+ JMP NOTRIM /Zero means it has a terminating "@"\r
+/\r
+/ Find the end of the string\r
+/\r
+ CLA CMA /End is start + len - 1\r
+ TAD COUNT /String len in words\r
+ TAD BUF+1 /End of the string\r
+ DCA PTR /Pointer to end\r
+ TAD COUNT /Invert count\r
+ CMA IAC\r
+ DCA COUNT\r
+CDF1, HLT\r
+FNDEND, TAD% PTR\r
+ TAD K3740 / - ' ' (two spaces)\r
+ SZA CLA / Skip if blank\r
+ JMP NONBLK\r
+ ISZ COUNT /Count another\r
+ SKP\r
+ JMP NONBLK /If empty, done\r
+ CLA CMA / -1\r
+ TAD PTR\r
+ DCA PTR /Back pointer up\r
+ JMP FNDEND /Keep looking\r
+\r
+NONBLK, TAD COUNT\r
+ SNA CLA /Skip if output left\r
+ JMP DONE /Nothing if count zero already\r
+NOTRIM, TAD BUF+1 /Reset pointer to start\r
+ DCA PTR\r
+CDF2, HLT\r
+ TAD% PTR /Get word\r
+ DCA STEMP /Save\r
+ TAD STEMP\r
+ RTR\r
+ RTR\r
+ RTR /First sixbit\r
+ JMS OUTONE /Convert and output it\r
+ TAD STEMP /Second sixbit\r
+ JMS OUTONE\r
+ ISZ PTR /Bump pointer\r
+ SKP /OK if no skip\r
+ JMP NEWFLD /Next field otherwise\r
+INCCNT, ISZ COUNT\r
+ JMP CDF2 /Keep outputting\r
+DONE, CLA\r
+ TAD CRFLAG /Suppress trailing CR?\r
+ RTR /2 bit suppresses trailing CR\r
+ SZL CLA /If zero, write it.\r
+ JMP OUT /Yes, leave now\r
+ CDF 10 /My field\r
+ TAD CRTN\r
+ JMS% TTYPTR+1\r
+OUT, CIF CDF 0\r
+ JMP% SIX8\r
+\r
+NEWFLD, TAD CDF1\r
+ TAD K10 /Next field\r
+ DCA CDF1\r
+ TAD CDF1\r
+ DCA CDF2\r
+ JMP INCCNT\r
+\r
+OUTONE, 0\r
+ AND K77 /Mask\r
+ SNA\r
+ JMP DONE / End of string\r
+ TAD K7743 / minus '['\r
+ SNA\r
+ JMP SETLWR /Set to lowercase shift\r
+ TAD K2 / ok, ']'?\r
+ SNA\r
+ JMP SETUPR /Set to uppercase\r
+ TAD K7773 /Restore\r
+ SPA\r
+ TAD SHIFT /For positive, shift it\r
+ TAD K40 /Else it's not alphabetic\r
+ CDF 10 /My field\r
+ JMS% TTYPTR+1 /Output it\r
+ JMP% OUTONE /Done\r
+\r
+SETLWR, TAD K40 /Reset shift\r
+SETUPR, TAD HUN /For upper/lower\r
+ DCA SHIFT\r
+ JMP% OUTONE\r
+\r
+TTYPTR, ADDR TTY\r
+SHIFT, 140 /Shift value\r
+/ COUNT and CRFLAG must stay together\r
+COUNT, 0 /Num words to output. \r
+CRFLAG, 0 /1 - no leading LF, 2 no trailing CR\r
+PTR, 0\r
+CRTN, 15\r
+LF, 12\r
+K3740, 3740 /minus blank\r
+BUF, 0;0;0 /Buffer 15-bit address\r
+STEMP, 0\r
+K77, 77 /sixbit mask\r
+K7, 7\r
+K4, 4\r
+K40, 40\r
+CDF0, CDF\r
+HUN, 100\r
+K7743, 7743\r
+K7773, 7773\r
+K10, 10 /Field increment\r
+K2, 2\r
+\r
+ SECT SPEAK\r
+/C\r
+/ SUBROUTINE SPEAK(N)\r
+/C\r
+/C PRINT THE MESSAGE IN RECORD N OF THE RANDOM ACCESS MESSAGE FILE.\r
+/C\r
+/ IMPLICIT INTEGER (A-Z)\r
+/ COMMON /TXTCOM/ RTEXT,LINES,ASCVAR\r
+/ COMMON /ALPHAS/ BLANK,EOF\r
+/ DIMENSION RTEXT(205),LINES(36)\r
+/C\r
+ EXTERN IO\r
+ EXTERN #HANG\r
+ JA #ST\r
+#XR, ORG .+10\r
+ TEXT +SPEAK+\r
+#RET, SETX #XR\r
+ SETB #BASE\r
+ JA .+3\r
+#BASE, ORG .+6\r
+N, ORG .+3\r
+#DOTMP, ORG .+3\r
+BLANK, TEXT + +\r
+EOF, TEXT +>$< +\r
+ONE, F 1.0\r
+FOUR, F 4.0\r
+ ORG #BASE+30\r
+ FNOP\r
+ JA #RET\r
+ FNOP\r
+#GOBAK, 0;0\r
+I, ORG .+0003\r
+L, ORG .+0003\r
+OLDLOC, ORG .+0003\r
+ #LBL=.\r
+ COMMON TXTCOM\r
+RTEXT, ORG .+1147\r
+LINES, ORG .+0044\r
+ASCVAR, ORG .+0003\r
+TXTLOC, ORG .+0003\r
+DATA, ORG .+0352\r
+ ORG #LBL\r
+#RTN, BASE #BASE\r
+ JA #GOBAK\r
+#ST, STARTD\r
+ 0210\r
+ FSTA #GOBAK,0\r
+ 0200\r
+ SETX #XR\r
+ SETB #BASE\r
+ LDX 0,1\r
+ FSTA #BASE\r
+ FLDA% #BASE,1+\r
+ FSTA N\r
+ STARTF\r
+/ IF(N.EQ.0)RETURN\r
+ FLDA% N\r
+ JEQ #RTN\r
+/ READ(2'N) LOC,LINES\r
+ FLDA N\r
+ STARTD\r
+ FSTA #G0002\r
+ STARTF\r
+ JSR IO\r
+ JA .+0004\r
+#G0002, JA .\r
+/ IF(LINES(1).EQ.EOF)RETURN\r
+ FLDA ONE\r
+ ATX 7\r
+ FLDA LINES-0003,7\r
+ FSUB EOF\r
+ JEQ #RTN\r
+/1 OLDLOC = LOC\r
+#1, FLDA TXTLOC\r
+ FSTA OLDLOC\r
+ FLDA ONE\r
+ FSTA I\r
+\r
+/ DO 3 I=36,1,-1\r
+/ Set COUNT to the number of words (36 or 44 octal)\r
+ SETX COUNT\r
+ LDX 44,0 /44 words\r
+ LDX 0,1 /With carriage control\r
+ SETX #XR\r
+/ L=I\r
+/3 CONTINUE\r
+/5 TYPE 2,(LINES(I),I=1,L)\r
+#5, FLDA LINEPT\r
+ FSTA BUF /Set buffer pointer\r
+ TRAP4 SIX8\r
+\r
+ FLDA% N\r
+ FADD ONE\r
+ FSTA% N\r
+ FLDA N\r
+/ READ(2'ASCVAR) LOC,LINES\r
+ STARTD\r
+ FSTA #G0006\r
+ STARTF\r
+ JSR IO\r
+ JA .+0004\r
+#G0006, JA .\r
+/ IF(LOC .EQ. OLDLOC) GO TO 1\r
+ FLDA TXTLOC\r
+ FSUB OLDLOC\r
+ JEQ #1\r
+ EXTERN #WRITO\r
+ TRAP3 #WRITO\r
+ JA FOUR\r
+ JA #10+2\r
+ EXTERN #RENDO\r
+ TRAP3 #RENDO\r
+\r
+/10 RETURN\r
+#10, JA #RTN\r
+/ (1X)\r
+ 5061\r
+ 3051\r
+/2 FORMAT(' ',36A2) PDP/8: (' ',12A6)\r
+LINEPT, ADDR LINES\r
+ 0\r
+ END\r
projects / pdp8.git / blobdiff