(FILECREATED "17-AUG-83 12:27:58" {PHYLUM}<LISPCORE>SOURCES>ATERM.;30 106141Q
changes to: (VARS ATERMCOMS)
(RECORDS LINEBUFFER)
previous date: "24-JUL-83 23:10:27" {PHYLUM}<LISPCORE>SOURCES>ATERM.;29)
(* Copyright (c) 1982, 1983 by Xerox Corporation)
(PRETTYCOMPRINT ATERMCOMS)
(RPAQQ ATERMCOMS ((* Line-buffering)
(FNS BKLINBUF CLEARBUF DSPSOUT LINBUF SETLINELENGTH SYSBUF \CHDEL1 \CLOSELINE \DECPARENCOUNT
\DSCCOUT \ECHOCHAR \FILLBUFFER \GETCHAR \INCPARENCOUNT \RESETLINE \RESETTERMINAL
\SAVELINEBUF \STOPSCROLL? PAGEFULLFN \PAGEFULLINVERTWFN)
[DECLARE: DOCOPY DONTEVAL@LOAD (P (MOVD? (QUOTE NILL)
(QUOTE SETDISPLAYHEIGHT]
(DECLARE: DONTCOPY (MACROS \RAISECHAR))
(FNS \PEEKREFILL \READREFILL \RATOM/RSTRING-REFILL \READCREFILL)
(FNS DRIBBLE DRIBBLEFILE SETDRIBBLEFILE \STOP.DRIBBLE? RESTARTDRIBBLE)
(FNS \SETUP.DEFAULT.LINEBUF \CREATELINEBUFFER \LINEBUF.READP \OPENLINEBUF)
[DECLARE: DOCOPY DONTEVAL@LOAD (VARS (\DRIBBLE.OFD NIL)
(\#DISPLAYLINES 72Q)
(\DISPLAYLINELENGTH 122Q)
(\CURRENTDISPLAYLINE 0)
(\STOPSCROLLMESSAGE
"------TYPE ANY CHARACTER TO CONTINUE------"))
(VARS (\SYSBUF NIL)
(\LINBUF NIL))
(P (\NODIRCOREFDEV (QUOTE LINEBUFFER)
(FUNCTION \LINEBUF.READP))
(\OPENLINEBUF))
(VARS (\DEFAULTLINEBUF (\SETUP.DEFAULT.LINEBUF]
(FNS \INTERMP \OUTTERMP)
(EXPORT (DECLARE: DONTCOPY (RECORDS LINEBUFFER)
(CONSTANTS * LINEBUFFERSTATES)
(MACROS \INTERMP \OUTTERMP)
(GLOBALVARS \DEFAULTLINEBUF)))
(DECLARE: DONTCOPY (CONSTANTS * FILLTYPES))
(LOCALVARS . T)))
(* Line-buffering)
(DEFINEQ
(BKLINBUF
[LAMBDA (STR) (* lmm "30-SEP-80 16:19")
(DECLARE (GLOBALVARS \SYSREADTABLE))
(COND
((STRINGP STR)
(\RESETLINE)
(for J C (SA ←(fetch READSA of \SYSREADTABLE)) from 1 while (SETQ C (NTHCHARCODE STR J))
do (\BOUT \LINEBUF.OFD C)
(\INCPARENCOUNT (\SYNCODE SA C)))
(\CLOSELINE)
STR])
(CLEARBUF
[LAMBDA (FILE FLG) (* bvm: "24-JUL-83 23:09")
(DECLARE (GLOBALVARS \MouseEnabled))
[PROG (OFD LINBUF SYSBUF)
(COND
((AND (EQ FILE T)
(EQ \LINEBUF.OFD \DEFAULTLINEBUF)) (* Process has no line buffer, hence nothing to clear or
save)
)
([\INTERMP (SETQ OFD (\GETOFD FILE (QUOTE INPUT]
(COND
[FLG (COND
((OR (NOT (EQUAL (SETQ LINBUF (\SAVELINEBUF))
""))
(SETQ SYSBUF (\SAVESYSBUF))) (* I don't know why these are in different formats -
rrb)
(* note in manual: if both buffers are empty, don't
change saved ones.)
(SETQ \LINBUF LINBUF)
(SETQ \SYSBUF SYSBUF]
(T (\CLEARSYSBUF))) (* check for mouse events enabled and coordinated with
keyboard)
(COND
((CDR \MouseEnabled)
(CLEARMOUSEBUF FLG)))
(\RESETTERMINAL]
NIL])
(DSPSOUT
[LAMBDA (X) (* bvm: "24-JUL-83 17:59")
(* Puts a string on the display)
(for I from 1 bind (STREAM ←(\GETOFD T (QUOTE OUTPUT))) do (\BOUT STREAM (OR (NTHCHARCODE X I)
(RETURN])
(LINBUF
[LAMBDA (FLG) (* rrb "21-JUL-83 15:33")
(COND
(FLG (AND \LINBUF (CONCAT \LINBUF)))
(T (SETQ \LINBUF NIL])
(SETLINELENGTH
[LAMBDA (N) (* rrb "22-JUL-83 10:10")
(LINELENGTH (OR N (fetch (STREAM LINELENGTH) of \TERM.OFD))
T])
(SYSBUF
[LAMBDA (FLG) (* rrb "21-JUL-83 15:34")
(COND
(FLG (AND \SYSBUF (CONCAT \SYSBUF)))
(T (SETQ \SYSBUF NIL])
(\CHDEL1
[LAMBDA NIL (* rmk: "30-JUN-82 23:56")
(\UPDATEOF \LINEBUF.OFD) (* EOF must be updated for \PEEKBIN to work correctly --
bas & rrb)
(COND
((\BACKFILEPTR \LINEBUF.OFD)
(PROG1 (\PEEKBIN \LINEBUF.OFD)
(\SETEOFPTR \LINEBUF.OFD (GETFILEPTR \LINEBUF.OFD])
(\CLOSELINE
[LAMBDA NIL (* rrb "21-JUL-83 15:03")
(SETQ \CURRENTDISPLAYLINE 0)
[COND
(\DRIBBLE.OFD (UNINTERRUPTABLY
(\SETFILEPTR \LINEBUF.OFD 0)
(replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with RETYPING.LBS))
(until (\EOFP \LINEBUF.OFD) do (\OUTCHAR \DRIBBLE.OFD (\BIN \LINEBUF.OFD]
(UNINTERRUPTABLY
(\SETFILEPTR \LINEBUF.OFD 0)
(replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with READING.LBS))])
(\DECPARENCOUNT
[LAMBDA (RSNX) (* rrb "21-JUL-83 15:03")
(* This updates parencounts as characters are removed
from the buffer due to line-editting.
RSNX is a readtable syntax code)
(COND
[(EQ RSNX STRINGDELIM.RC)
(replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with (NOT (fetch (LINEBUFFER INSTRINGP)
of \LINEBUF.OFD]
((NOT (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD))
(SELECTC RSNX
[LEFTPAREN.RC (COND
((ZEROP (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD))
(add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD)
-1]
[RIGHTPAREN.RC (COND
((ZEROP (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD))
(add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD)
1]
(LEFTBRACKET.RC (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)
-1))
(RIGHTBRACKET.RC (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)
1))
NIL])
(\DSCCOUT
[LAMBDA (STREAM CHARCODE) (* rrb "21-JUL-83 14:54")
(* The terminal outcharfn, prior for non-displaystream systems. STREAM is always \TERM.OFD, but passed as an
argument so that calling structure is the same as the more general display outcharfn, and thus, so that a simple
MOVD can be done to install the display world.)
(SELECTC (fetch CCECHO of (\SYNCODE \PRIMTERMSA CHARCODE))
[INDICATE.CCE (PROG ((CC CHARCODE))
(add (fetch XPOSITION of STREAM)
(IPLUS (COND
((IGREATERP CC 127)
(* META character)
(DSPBOUT (CHARCODE #))
(SETQ CC (LOGAND CC 127))
1)
(T 0))
(COND
((ILESSP CC 32)
(* CONTROL character)
(DSPBOUT (CHARCODE ↑))
(SETQ CC (LOGOR CC 64))
1)
(T 0))
(PROGN (DSPBOUT CC)
1]
[SIMULATE.CCE (SELCHARQ CHARCODE
(LF (DSPBOUT (CHARCODE EOL))
(RPTQ (fetch XPOSITION of STREAM)
(DSPBOUT (CHARCODE SPACE)))
(\STOPSCROLL?))
(EOL (DSPBOUT (CHARCODE EOL))
(\STOPSCROLL?)
(replace XPOSITION of STREAM with 0))
(ESCAPE (DSPBOUT (CHARCODE $))
(* change to $)
(add (fetch XPOSITION of STREAM)
1))
(TAB (FRPTQ (IDIFFERENCE 8 (MOD (fetch XPOSITION of STREAM)
8))
(DSPBOUT (CHARCODE SPACE))
(add (fetch XPOSITION of STREAM)
1)))
(BELL (RESETFORM (VIDEOCOLOR (NOT (VIDEOCOLOR)))
(DISMISS 150)))
(PROGN (DSPBOUT CHARCODE)
(add (fetch XPOSITION of STREAM)
1]
[REAL.CCE (DSPBOUT CHARCODE)
(COND
((EQ CHARCODE (CHARCODE EOL))
(\STOPSCROLL?)
(replace XPOSITION of STREAM with 0))
(T (add (fetch XPOSITION of STREAM)
1]
(IGNORE.CCE)
(SHOULDNT])
(\ECHOCHAR
[LAMBDA (C) (* rrb "21-JUL-83 07:18")
(COND
((fetch ECHOFLG of \PRIMTERMTABLE)
(\BOUT \TERM.OFD (COND
((AND (ZEROP (fetch RAISEFLG of \PRIMTERMTABLE))
(IGEQ C (CHARCODE a))
(ILEQ C (CHARCODE z))) (* This is doing a raise if flag is set)
(IDIFFERENCE C 32))
(T C])
(\FILLBUFFER
[LAMBDA (FILLTYPE) (* rrb "21-JUL-83 14:53")
(* While filling the line, the current file pointer is the end of the line. When the line is closed, this is made
the eof. -
#CURRENTRDTBL# is used for syntactic delimiters and paren counting on READ and RATOM calls but isn't referenced
(or bound) for READC)
(DECLARE (USEDFREE #CURRENTRDTBL# FLG))
(\RESETLINE)
(PROG (C TCLASS RSNX (RTBLSA (AND (NEQ FILLTYPE READC.FT)
(fetch READSA of #CURRENTRDTBL#)))
(CONTROLTON (fetch CONTROLFLG of \PRIMTERMTABLE))
(ILP (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD))
(ISP (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD))
(ILB (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)))
(* TCLASS is terminal syntax class, RSNX is read-table
code)
(COND
((AND CONTROLTON (EQ FILLTYPE READC.FT))
(\BOUT \LINEBUF.OFD (\GETCHAR))
(GO EXIT)))
NEXT[SETQ TCLASS (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA (SETQ C (\GETCHAR]
(* Echoing is done in \GETCHAR)
REDO[SELECTC TCLASS
(RETYPE.TC (\BOUT \TERM.OFD (CHARCODE EOL))
(\SETEOFPTR \LINEBUF.OFD (\GETFILEPTR \LINEBUF.OFD))
(* Make the EOF be accurate during retyping, in case an
interrupt happens and the buffer gets saved via
\SAVELINEBUF.)
(UNINTERRUPTABLY
(\SETFILEPTR \LINEBUF.OFD 0)
(replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with
RETYPING.LBS))
(until (\EOFP \LINEBUF.OFD) do (\BOUT \TERM.OFD (\BIN \LINEBUF.OFD)))
(replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with FILLING.LBS))
(LINEDELETE.TC (DSPSOUT (fetch LINEDELETE of \PRIMTERMTABLE))
(UNINTERRUPTABLY
(replace (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD with ILP)
(* Eventually, should back up 1 char at a time, erasing
and doing \DECPARENCOUNT. Then the I* variables won't be
needed.)
(replace (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD with ILB)
(replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with ISP)
(\SETFILEPTR \LINEBUF.OFD 0)
(\SETEOFPTR \LINEBUF.OFD 0)))
((LIST CHARDELETE.TC WORDDELETE.TC)
(COND
((NULL (SETQ C (\CHDEL1)))
(DSPSOUT (fetch EMPTYCHDEL of \PRIMTERMTABLE))
(GO NEXT)))
(DSPSOUT (fetch 1STCHDEL of \PRIMTERMTABLE))
[PROG (C1 (DELECHO (EQ (fetch DELCHARECHO of \PRIMTERMTABLE)
(QUOTE ECHO)))
(NTH (fetch NTHCHDEL of \PRIMTERMTABLE))
(ESCAPE? (AND (NEQ FILLTYPE READC.FT)
(fetch ESCAPEFLG of #CURRENTRDTBL#)
ESCAPE.RC)))
(GO FIRST)
AGAIN
(COND
((NULL (SETQ C (\CHDEL1)))
(DSPSOUT (fetch EMPTYCHDEL of \PRIMTERMTABLE))
(GO NEXT)))
(DSPSOUT NTH)
FIRST
(AND DELECHO (\ECHOCHAR C)) (* Delete 2nd thru Nth)
[COND
((NEQ FILLTYPE READC.FT) (* Don't process escapes if READC)
(SETQ RSNX (\SYNCODE RTBLSA C))
[COND
((SETQ C1 (\CHDEL1)) (* Check preceding char C1 for escape)
(COND
((EQ ESCAPE? (\SYNCODE RTBLSA C1))
(DSPSOUT NTH)
(AND DELECHO (\ECHOCHAR C1))
(SETQ RSNX OTHER.RC))
(T (* Put the non-escape back in the buffer)
(\BOUT \LINEBUF.OFD C1]
(\DECPARENCOUNT RSNX)
(COND
((EQ TCLASS WORDDELETE.TC)
(* Cycle back until first non-sepr/non-other, or first non-other after sepr string and other string.
Note that a terminal wordsepr is treated as if it were a read-sepr)
(SELECTC RSNX
(SEPRCHAR.RC (OR (ZEROP (\GETFILEPTR \LINEBUF.OFD))
(GO AGAIN)))
(OTHER.RC [COND
((EQ WORDSEPR.TC (\SYNCODE \PRIMTERMSA C))
(OR (ZEROP (\GETFILEPTR \LINEBUF.OFD))
(GO AGAIN]
(PROG NIL
(* The first OTHER)
TRY (COND
((NULL (SETQ C (\CHDEL1)))
(RETURN)))
(SETQ RSNX (\SYNCODE RTBLSA C))
(SETQ TCLASS (\SYNCODE \PRIMTERMSA C))
CHK [COND
((AND (NEQ TCLASS WORDSEPR.TC)
(OR (EQ OTHER.RC RSNX)
(EQ ESCAPE? RSNX)))
(* Erase it)
(DSPSOUT NTH)
(AND DELECHO (\ECHOCHAR C))
(GO TRY))
((SETQ C1 (\CHDEL1))
(\BOUT \LINEBUF.OFD C1)
(* Put it back)
(COND
((EQ ESCAPE? (\SYNCODE RTBLSA C1))
(SETQ RSNX OTHER.RC)
(SETQ TCLASS NONE.TC)
(GO CHK]
(\BOUT \LINEBUF.OFD C)))
NIL]
(* Use \GETKEY for next character to suppress echoing in case we have to print the post message first.
If it's a real character, we echo it and raise it)
(SETQ C (\GETKEY))
(SELECTC [SETQ TCLASS (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA
(\RAISECHAR C]
((LIST CHARDELETE.TC WORDDELETE.TC)
(GO AGAIN))
((LIST LINEDELETE.TC RETYPE.TC))
(PROGN (DSPSOUT (fetch POSTCHDEL of \PRIMTERMTABLE))
(\ECHOCHAR C)
(SETQ C (\RAISECHAR C]
(GO REDO))
[CTRLV.TC
(* The reasonable thing to do is coerce the character, set TCLASS to NONE.TC, and go REDO.
But on the 10, ctlv disables the immediacy of read-macros. This is quite bizarre, cause a macro that was suppose
to do something in the middle of reading will be done out of context. We simulate that behavior, however.)
(\BOUT \LINEBUF.OFD (COND
([OR (AND (IGEQ (SETQ C (\GETCHAR))
(CHARCODE A))
(ILEQ C (CHARCODE Z)))
(AND (IGEQ C (CHARCODE a))
(ILEQ C (CHARCODE z]
(LOGAND C 31))
(T C]
(EOL.TC (\BOUT \LINEBUF.OFD C)
(GO EXIT))
(PROGN (\BOUT \LINEBUF.OFD C)
(AND (EQ FILLTYPE READC.FT)
(GO NEXT))
(COND
((EQ ESCAPE.RC (SETQ RSNX (\SYNCODE RTBLSA C)))
(* On Tenex the escape inhibits the action of all
terminal characters except control-V.)
(COND
([EQ CTRLV.TC (SETQ TCLASS (fetch TERMCLASS
of (\SYNCODE \PRIMTERMSA (SETQ C
(\GETCHAR]
(GO REDO)))
(\BOUT \LINEBUF.OFD C)
(GO NEXT)))
(SELECTC FILLTYPE
[RATOM/RSTRING.FT (COND
((AND CONTROLTON (fetch STOPATOM of RSNX))
(GO EXIT]
[READ.FT (COND
([AND CONTROLTON (ZEROP (fetch (LINEBUFFER LBRKCOUNT)
of \LINEBUF.OFD))
(ZEROP (fetch (LINEBUFFER LPARCOUNT)
of \LINEBUF.OFD))
(fetch STOPATOM of RSNX)
(SELECTC RSNX
((LIST LEFTPAREN.RC LEFTBRACKET.RC)
NIL)
(STRINGDELIM.RC (fetch (LINEBUFFER
INSTRINGP)
of \LINEBUF.OFD))
(NOT (fetch (LINEBUFFER INSTRINGP)
of \LINEBUF.OFD]
(* READ is reading an atom. Return when atom ends, but
also obey bracket/paren exception noted on page 14.33 of
manual.)
(GO EXIT)))
(COND
((\INCPARENCOUNT RSNX)
(* Parens balance--throw the carriage if the closing paren or bracket character was not a CR, and if FLG argument
of READ is NIL. (We know we are under a READ call because of FILLTYPE))
(\CLOSELINE)
(* \CLOSELINE first so dribble happens before EOL)
(AND (NEQ C (CHARCODE EOL))
(NOT FLG)
(\OUTCHAR \TERM.OFD (CHARCODE EOL)))
(RETURN))
((EQ IMMEDIATE.RMW (fetch WAKEUP of RSNX))
(* Immediate read-macro)
(GO EXIT]
(SHOULDNT]
(GO NEXT)
EXIT(\CLOSELINE])
(\GETCHAR
[LAMBDA NIL (* rmk: "11-APR-81 11:40")
(PROG ((C (\GETKEY)))
(\ECHOCHAR C) (* Echo here so raise-echo is correct)
(RETURN (\RAISECHAR C])
(\INCPARENCOUNT
[LAMBDA (RSNX) (* rrb "21-JUL-83 15:03")
(* This maintains the paren count as characters are
added to the buffer. RSNX is a readtable syntax code.
Returns T when parens balance.)
(COND
((EQ RSNX STRINGDELIM.RC)
(replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with (NOT (fetch (LINEBUFFER INSTRINGP)
of \LINEBUF.OFD)))
NIL)
((NOT (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD))
(SELECTC RSNX
(LEFTPAREN.RC (AND (ZEROP (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD))
(add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD)
1))
NIL)
[RIGHTPAREN.RC (* NOTE: RP's never match left-brackets, just like on
10)
(AND (ZEROP (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD))
(OR (ZEROP (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD))
(ZEROP (add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD)
-1]
(LEFTBRACKET.RC (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)
1)
NIL)
[RIGHTBRACKET.RC (COND
((ZEROP (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD))
(replace (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD with 0))
(T (AND (ZEROP (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)
-1))
(ZEROP (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD]
NIL])
(\RESETLINE
[LAMBDA NIL (* rrb "21-JUL-83 14:53")
(UNINTERRUPTABLY
(replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with FILLING.LBS)
(\SETFILEPTR \LINEBUF.OFD 0)
(\SETEOFPTR \LINEBUF.OFD 0))
(SETQ \CURRENTDISPLAYLINE 0])
(\RESETTERMINAL
[LAMBDA NIL (* rrb "21-JUL-83 15:05")
(DECLARE (GLOBALVARS \VideoColor)) (* Called by CLEARBUF and by RESET and ERROR! when
returning to the TOPFRAME on the stack)
(replace (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD with 0)
(replace (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD with 0)
(replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with NIL)
(\RESETLINE) (* Since we aren't immediately filling the buffer,
guarantee that the next read causes an EOF error)
(\SETEOF \LINEBUF.OFD 0 0)
(VIDEOCOLOR \VideoColor])
(\SAVELINEBUF
[LAMBDA NIL (* rrb "21-JUL-83 16:31")
(* Don't have to set the fileptr to its original place
cause we are heading for a \RESETTERMINAL in CLEARBUF)
(SELECTC (fetch (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD)
(FILLING.LBS (\CLOSELINE))
(RETYPING.LBS (* EOF is valid, but current fileptr isn't)
(\SETFILEPTR \LINEBUF.OFD 0))
NIL)
(for J [STR ←(ALLOCSTRING (IDIFFERENCE (\GETEOFPTR \LINEBUF.OFD)
(\GETFILEPTR \LINEBUF.OFD]
from 1 until (\EOFP \LINEBUF.OFD) do (RPLCHARCODE STR J (\BIN \LINEBUF.OFD))
finally (RETURN STR])
(\STOPSCROLL?
[LAMBDA NIL (* rrb "22-JUL-83 10:12")
(* Called whenever a carriage-return is printed on the display. Keeps track of number of lines since last user
input. If this one would scroll information off the screen, it calls the users window specific function or the
function PAGEFULLFN which waits for the user to type a character.)
(DECLARE (GLOBALVARS \STOPSCROLLMESSAGE)) (* Set \#DISPLAYLINEs to NIL to disable)
(COND
[(AND (NEQ \CURRENTDISPLAYLINE -1)
(OR (ZEROP \#DISPLAYLINES)
(NOT (SMALLP \#DISPLAYLINES]
([OR (EQ \CURRENTDISPLAYLINE -1)
(EQ \#DISPLAYLINES (SETQ \CURRENTDISPLAYLINE (ADD1 \CURRENTDISPLAYLINE]
(SETQ \CURRENTDISPLAYLINE 0)
(PROG (WINDOWFN)
(RETURN (COND
([AND (TYPENAMEP TOPW (QUOTE WINDOW))
(SETQ WINDOWFN (WINDOWPROP (WFROMDS (TTYDISPLAYSTREAM))
(QUOTE PAGEFULLFN]
(APPLY* WINDOWFN (TTYDISPLAYSTREAM)))
(T (PAGEFULLFN (TTYDISPLAYSTREAM])
(PAGEFULLFN
[LAMBDA (STREAM) (* bvm: "24-JUL-83 16:00")
(* default function that is called by \STOPSCROLL? when
more lines are printed in a row than will fit on the
screen or window.)
(* If no input is pending, it waits for a character to
be typed.)
(COND
((\SYSBUFP))
[(\DISPLAYSTREAMP STREAM) (* reverse only this window.)
(AND (WINDOWWORLD)
(RESETLST (RESETSAVE (SETDISPLAYHEIGHT T))
[COND
((AND (NOT (TTY.PROCESSP))
(EQ (PROCESSPROP (THIS.PROCESS)
(QUOTE NAME))
(QUOTE MOUSE))) (* Running under mouse, so can't make this proc be the
tty process)
(RESETSAVE (TTY.PROCESS (THIS.PROCESS]
(RESETSAVE (INVERTW STREAM)
(LIST (FUNCTION \PAGEFULLINVERTWFN)
STREAM))
(\GETKEY]
(T (RESETFORM (VIDEOCOLOR (NOT (VIDEOCOLOR))) (* Don't go through \DSCCOUT, so interaction won't
appear on dribble file)
[for I from 1 do (DSPBOUT (OR (NTHCHARCODE \STOPSCROLLMESSAGE I)
(RETURN]
(\GETKEY) (* Now erase the message)
(FRPTQ (NCHARS \STOPSCROLLMESSAGE)
(DSPBOUT ERASECHARCODE])
(\PAGEFULLINVERTWFN
[LAMBDA (STREAM) (* rrb " 2-APR-82 11:38")
(* inverts a window. Needs to be a separate function because if an error occurred, the window was scrolled and
hence it does not want to invert the bottom line of the window.)
(COND
((AND RESETSTATE (EQ (TTYDISPLAYSTREAM)
STREAM))
(BITBLT NIL NIL NIL STREAM NIL (IDIFFERENCE (fetch (REGION BOTTOM) of (DSPCLIPPINGREGION
NIL STREAM))
(DSPLINEFEED NIL STREAM))
NIL NIL (QUOTE TEXTURE)
(QUOTE INVERT)
BLACKSHADE))
(T (INVERTW STREAM])
)
(DECLARE: DOCOPY DONTEVAL@LOAD
(MOVD? (QUOTE NILL)
(QUOTE SETDISPLAYHEIGHT))
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \RAISECHAR MACRO (OPENLAMBDA (C)
(COND
((AND (fetch RAISEFLG of \PRIMTERMTABLE)
(IGEQ C (CHARCODE a))
(ILEQ C (CHARCODE z)))
(IDIFFERENCE C 40Q))
(T C))))
)
)
(DEFINEQ
(\PEEKREFILL
[LAMBDA NIL (* rrb "21-JUL-83 16:31")
(* Called from \ENDOFFILE via \RefillBufferFn when the
linebuffer is empty)
(\RESETLINE)
(\BOUT \LINEBUF.OFD (\GETCHAR))
(\CLOSELINE)
(\PEEKBIN \LINEBUF.OFD])
(\READREFILL
[LAMBDA NIL (* rrb "21-JUL-83 16:32")
(* Called from \ENDOFFILE via \RefillBufferFn when the
linebuffer is empty)
(\FILLBUFFER READ.FT)
(APPLY* (STKNAME (QUOTE (\BIN \PEEKBIN)))
\LINEBUF.OFD])
(\RATOM/RSTRING-REFILL
[LAMBDA NIL (* rrb "21-JUL-83 16:32")
(* Called from \ENDOFFILE via \RefillBufferFn when the
linebuffer is empty)
(\FILLBUFFER RATOM/RSTRING.FT)
(\BIN \LINEBUF.OFD])
(\READCREFILL
[LAMBDA NIL (* rrb "21-JUL-83 16:32")
(* Called from \ENDOFFILE via \RefillBufferFn when the
linebuffer is empty)
(\FILLBUFFER READC.FT)
(\BIN \LINEBUF.OFD])
)
(DEFINEQ
(DRIBBLE
[LAMBDA (FILE APPENDFLG THAWEDFLG) (* rrb "22-JUL-83 16:00")
(* Dribbling is on if \DRIBBLE.OFD is set.)
(PROG (NEWDRIBFILE (OLDDRIBFILE (AND (OR \DRIBBLE.OFD (RESTARTDRIBBLE T))
\DRIBBLE.OFD))) (* RESTARTDRIBBLE gets the "saved" dribble file if it
was turned off in a panic)
(SETQ \DRIBBLE.OFD NIL)
(COND
(OLDDRIBFILE (replace USERCLOSEABLE of OLDDRIBFILE with T)
(replace USERVISIBLE of OLDDRIBFILE with T)
(CLOSEF OLDDRIBFILE))) (* CLOSEF works once the dribbling has been turned off.)
(COND
((AND FILE (NEQ FILE T))
(SETQ NEWDRIBFILE (\GETOFD (OPENFILE FILE (COND
(APPENDFLG (QUOTE APPEND))
(T (QUOTE OUTPUT)))
NIL NIL (AND THAWEDFLG (QUOTE THAWED)))
(QUOTE OUTPUT)))
(replace USERCLOSEABLE of NEWDRIBFILE with NIL)
(replace USERVISIBLE of NEWDRIBFILE with NIL)
(SETQ \DRIBBLE.OFD NEWDRIBFILE)))
(RETURN (AND OLDDRIBFILE (fetch FULLNAME of OLDDRIBFILE])
(DRIBBLEFILE
[LAMBDA NIL (* rrb "22-JUL-83 16:00")
(AND \DRIBBLE.OFD (fetch FULLNAME of \DRIBBLE.OFD])
(SETDRIBBLEFILE
[LAMBDA (FILE) (* rrb "22-JUL-83 16:00")
(* Makes FILE be the current dribble file.
Disables dribbling if FILE is NIL.
This is a user (=DLISP) entry.)
(PROG1 (DRIBBLEFILE)
(COND
((AND FILE (NEQ FILE T))
(PROG [(DF (\GETOFD FILE (QUOTE OUTPUT]
(replace USERCLOSEABLE of DF with NIL)
(replace USERVISIBLE of DF with NIL)
(SETQ \DRIBBLE.OFD DF])
(\STOP.DRIBBLE?
[LAMBDA (FILE)
(DECLARE (GLOBALVARS \DRIBBLE.OFD.SAVE)) (* rrb "22-JUL-83 16:02")
(* * If FILE (name or stream) is the dribble file, turn it off. This is needed in places where there is an error
in handling the dribble file and we want to be able to recover somehow... Returns T if this is indeed the dribble
file. RESTARTDRIBBLE restores dribble file after this)
(COND
([AND \DRIBBLE.OFD (EQ FILE (COND
((type? STREAM FILE)
\DRIBBLE.OFD)
(T (fetch FULLNAME of \DRIBBLE.OFD]
(UNINTERRUPTABLY
(SETQ \DRIBBLE.OFD.SAVE \DRIBBLE.OFD)
(SETQ \DRIBBLE.OFD NIL)
(printout T T "Problem with dribblefile " (fetch FULLNAME of \DRIBBLE.OFD.SAVE)
T "Dribbling disabled; call RESTARTDRIBBLE[] to restore it." T)
T)])
(RESTARTDRIBBLE
[LAMBDA (QUIET) (* rrb "22-JUL-83 16:02")
(DECLARE (GLOBALVARS \DRIBBLE.OFD.SAVE \OPENFILES))
(* * Called to get back after a \STOP.DRIBBLE?)
(COND
(\DRIBBLE.OFD.SAVE (COND
((FMEMB \DRIBBLE.OFD.SAVE \OPENFILES)
(OR QUIET (printout T "Restoring dribblefile " (fetch FULLNAME
of \DRIBBLE.OFD.SAVE)
T))
(UNINTERRUPTABLY
(SETQ \DRIBBLE.OFD \DRIBBLE.OFD.SAVE)
(SETQ \DRIBBLE.OFD.SAVE NIL))
(fetch FULLNAME of \DRIBBLE.OFD))
(T (SETQ \DRIBBLE.OFD.SAVE NIL])
)
(DEFINEQ
(\SETUP.DEFAULT.LINEBUF
[LAMBDA NIL (* rrb "24-JUL-83 18:28")
(* creates a line buffer device which creates a line
buffer the first time one is needed.)
(PROG [(STREAM (\OPENFILE (QUOTE {LINEBUFFER})
(QUOTE BOTH)
(QUOTE NEW]
(replace FULLFILENAME of STREAM with T)
(* No-one cares about the true file-name after this, so we make it convenient for code that wants to give a name
back to the user)
(replace LINEBUFSTATE of STREAM with READING.LBS)
(replace USERCLOSEABLE of STREAM with NIL)
(replace USERVISIBLE of STREAM with NIL) (* Other linebuffer fields default properly)
[replace ENDOFSTREAMOP of STREAM with (FUNCTION (LAMBDA (STREAM)
(* create a TTY window and make it the tty stream.
This also sets up a line buffer.)
(\CREATE.TTYDISPLAYSTREAM)
(STREAMOP (QUOTE ENDOFSTREAMOP)
\LINEBUF.OFD \LINEBUF.OFD]
(RETURN STREAM])
(\CREATELINEBUFFER
(LAMBDA NIL (* JonL "19-JUL-83 03:02")
(PROG ((STREAM (\OPENFILE (QUOTE {LINEBUFFER})
(QUOTE BOTH)
(QUOTE NEW))))
(replace FULLFILENAME of STREAM with T)
(* No-one cares about the true file-name after this, so we make it convenient for code that wants to give a name
back to the user)
(replace LINEBUFSTATE of STREAM with READING.LBS)
(replace USERCLOSEABLE of STREAM with NIL)
(replace USERVISIBLE of STREAM with NIL) (* Other linebuffer fields default properly)
(replace ENDOFSTREAMOP of STREAM with (FUNCTION (LAMBDA (STREAM)
(APPLY* \RefillBufferFn))))
(RETURN STREAM))))
(\LINEBUF.READP
(LAMBDA (STREAM FLG) (* JonL " 9-JUN-83 20:04")
(OR (\SYSBUFP)
(\PAGEDREADP STREAM))))
(\OPENLINEBUF
[LAMBDA NIL (* rrb "21-JUL-83 12:25")
(* Don't assume that \LINEBUF.OFD or \TERM.OFD have been
initialized. That way, they won't get smashed if ATERM
is reloaded.)
(DECLARE (GLOBALVARS DisplayFDEV))
(\CLEAROFD)
(PROG (STREAM) (* Output parameters)
[COND
((NOT (type? STREAM \TERM.OFD))
(SETQ STREAM (create STREAM
FULLFILENAME ← T
DEVICE ←(create FDEV using DisplayFDEV BOUT ←(FUNCTION \DSCCOUT))
ACCESS ←(QUOTE OUTPUT)
LINELENGTH ← 72
USERCLOSEABLE ← NIL
USERVISIBLE ← NIL
OUTCHARFN ←(FUNCTION \TTYOUTCHARFN)))
(* Use a temporary so can test against previous
\PRIMOUT.OFD)
(COND
((OR (NOT (type? STREAM \PRIMOUT.OFD))
(EQ \PRIMOUT.OFD \TERM.OFD))
(SETQ \PRIMOUT.OFD STREAM))) (* \TERM.OFD.SAV saves a copy so that it can be restored
if it was changed to output to a display stream.
-
rrb)
(SETQ \TERM.OFD.SAV (SETQ \TERM.OFD STREAM] (* Input parameters)
[COND
((NOT (type? STREAM \LINEBUF.OFD))
(SETQ \LINEBUF.OFD (\CREATELINEBUFFER))
(OR (type? STREAM \PRIMIN.OFD)
(SETQ \PRIMIN.OFD \LINEBUF.OFD]
(\RESETTERMINAL])
)
(DECLARE: DOCOPY DONTEVAL@LOAD
(RPAQQ \DRIBBLE.OFD NIL)
(RPAQQ \#DISPLAYLINES 72Q)
(RPAQQ \DISPLAYLINELENGTH 122Q)
(RPAQQ \CURRENTDISPLAYLINE 0)
(RPAQ \STOPSCROLLMESSAGE "------TYPE ANY CHARACTER TO CONTINUE------")
(RPAQQ \SYSBUF NIL)
(RPAQQ \LINBUF NIL)
(\NODIRCOREFDEV (QUOTE LINEBUFFER)
(FUNCTION \LINEBUF.READP))
(\OPENLINEBUF)
(RPAQ \DEFAULTLINEBUF (\SETUP.DEFAULT.LINEBUF))
)
(DEFINEQ
(\INTERMP
[LAMBDA (OFD) (* rrb "21-JUL-83 16:33")
(EQ OFD \LINEBUF.OFD])
(\OUTTERMP
[LAMBDA (OFD) (* rrb "21-JUL-83 07:23")
(EQ OFD \TERM.OFD])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DONTCOPY
[DECLARE: EVAL@COMPILE
(ACCESSFNS LINEBUFFER ((LPARCOUNT (fetch FW6 of DATUM)
(replace FW6 of DATUM with NEWVALUE))
(LBRKCOUNT (fetch FW7 of DATUM)
(replace FW7 of DATUM with NEWVALUE))
(INSTRINGP (fetch F4 of DATUM)
(replace F4 of DATUM with NEWVALUE))
(LINEBUFSTATE (fetch F5 of DATUM)
(replace F5 of DATUM with NEWVALUE))))
]
(RPAQQ LINEBUFFERSTATES (FILLING.LBS READING.LBS RETYPING.LBS))
(DECLARE: EVAL@COMPILE
(RPAQQ FILLING.LBS 0)
(RPAQQ READING.LBS 1)
(RPAQQ RETYPING.LBS 2)
(CONSTANTS FILLING.LBS READING.LBS RETYPING.LBS)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \INTERMP MACRO ((OFD)
(EQ OFD \LINEBUF.OFD)))
(PUTPROPS \OUTTERMP MACRO ((OFD)
(EQ OFD \TERM.OFD)))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(ADDTOVAR GLOBALVARS \DEFAULTLINEBUF)
)
)
(* END EXPORTED DEFINITIONS)
(DECLARE: DONTCOPY
(RPAQQ FILLTYPES ((READ.FT 0)
(RATOM/RSTRING.FT 1)
(READC.FT 2)))
(DECLARE: EVAL@COMPILE
(RPAQQ READ.FT 0)
(RPAQQ RATOM/RSTRING.FT 1)
(RPAQQ READC.FT 2)
(CONSTANTS (READ.FT 0)
(RATOM/RSTRING.FT 1)
(READC.FT 2))
)
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(LOCALVARS . T)
)
(PUTPROPS ATERM COPYRIGHT ("Xerox Corporation" 3676Q 3677Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3160Q 60071Q (BKLINBUF 3172Q . 4025Q) (CLEARBUF 4027Q . 6103Q) (DSPSOUT 6105Q . 6627Q)
(LINBUF 6631Q . 7121Q) (SETLINELENGTH 7123Q . 7416Q) (SYSBUF 7420Q . 7710Q) (\CHDEL1 7712Q . 10515Q) (
\CLOSELINE 10517Q . 11573Q) (\DECPARENCOUNT 11575Q . 13773Q) (\DSCCOUT 13775Q . 20246Q) (\ECHOCHAR
20250Q . 21076Q) (\FILLBUFFER 21100Q . 42453Q) (\GETCHAR 42455Q . 43074Q) (\INCPARENCOUNT 43076Q .
46232Q) (\RESETLINE 46234Q . 46722Q) (\RESETTERMINAL 46724Q . 50305Q) (\SAVELINEBUF 50307Q . 51741Q) (
\STOPSCROLL? 51743Q . 54003Q) (PAGEFULLFN 54005Q . 56701Q) (\PAGEFULLINVERTWFN 56703Q . 60067Q)) (
60652Q 63462Q (\PEEKREFILL 60664Q . 61454Q) (\READREFILL 61456Q . 62227Q) (\RATOM/RSTRING-REFILL
62231Q . 62754Q) (\READCREFILL 62756Q . 63460Q)) (63463Q 72366Q (DRIBBLE 63475Q . 65755Q) (DRIBBLEFILE
65757Q . 66232Q) (SETDRIBBLEFILE 66234Q . 67340Q) (\STOP.DRIBBLE? 67342Q . 71122Q) (RESTARTDRIBBLE
71124Q . 72364Q)) (72367Q 102006Q (\SETUP.DEFAULT.LINEBUF 72401Q . 74756Q) (\CREATELINEBUFFER 74760Q
. 76472Q) (\LINEBUF.READP 76474Q . 76727Q) (\OPENLINEBUF 76731Q . 102004Q)) (102664Q 103306Q (
\INTERMP 102676Q . 103101Q) (\OUTTERMP 103103Q . 103304Q)))))
STOP