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