(FILECREATED "10-Jan-84 12:42:47" {PHYLUM}<LISPCORE>SOURCES>ATERM.;42 113047Q
changes to: (FNS VIDEOCOLOR)
previous date: " 8-NOV-83 03:36:03" {PHYLUM}<LISPCORE>SOURCES>ATERM.;41)
(* Copyright (c) 1982, 1983, 1984 by Xerox Corporation)
(PRETTYCOMPRINT ATERMCOMS)
(RPAQQ ATERMCOMS [(* Line-buffering)
(FNS BKLINBUF CLEARBUF DSPSOUT LINBUF PAGEFULLFN SETLINELENGTH SYSBUF TERMCHARWIDTH \CHDEL1
\CLOSELINE \DECPARENCOUNT \DSCCOUT \ECHOCHAR \FILLBUFFER \GETCHAR \INCPARENCOUNT
\PAGEFULLINVERTWFN \RESETLINE \RESETTERMINAL \SAVELINEBUF \STOPSCROLL?)
(COMS (FNS VIDEOCOLOR)
(VARS (\VideoColor))
(PROP ARGNAMES VIDEOCOLOR))
[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 (MOVD? (QUOTE \OPENLINEBUF)
(QUOTE \CREATE.TTYDISPLAYSTREAM))
(\NODIRCOREFDEV (QUOTE LINEBUFFER)
(FUNCTION \LINEBUF.READP)))
(VARS (\DEFAULTLINEBUF (\SETUP.DEFAULT.LINEBUF)))
(P (\OPENLINEBUF)))
(FNS \INTERMP \OUTTERMP)
(EXPORT (DECLARE: DONTCOPY (RECORDS LINEBUFFER)
(CONSTANTS * LINEBUFFERSTATES)
(MACROS \INTERMP \OUTTERMP)
(GLOBALVARS \DEFAULTLINEBUF)))
(DECLARE: DONTCOPY (CONSTANTS * FILLTYPES))
(LOCALVARS . T)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA)
(NLAML)
(LAMA VIDEOCOLOR])
(* 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) (* rmk: "16-SEP-83 23:24")
(DECLARE (GLOBALVARS \MouseEnabled))
[PROG (LINBUF SYSBUF (STRM (\INSTREAMARG FILE)))
(COND
((AND (EQ STRM \LINEBUF.OFD)
(EQ \LINEBUF.OFD \DEFAULTLINEBUF)) (* Process has no line buffer, hence nothing to clear or
save)
)
((\INTERMP STRM)
(COND
[FLG (COND
((OR (SETQ LINBUF (\SAVELINEBUF))
(SETQ SYSBUF (\SAVESYSBUF))) (* 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])
(PAGEFULLFN
[LAMBDA (STREAM) (* rmk: "31-AUG-83 14:54")
(* 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))
((SETQ STREAM (DISPLAYSTREAMP STREAM)) (* reverse only this window.)
(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])
(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])
(TERMCHARWIDTH
(LAMBDA (CHARCODE STREAM TTBL) (* JonL " 8-NOV-83 03:28")
(* Returns the width that the printed representation of CHARCODE would occupy if printed on the terminal STREAM,
allowing for the various escape sequences. Used by \ECHOCHAR)
(\STREAMCHARWIDTH (LOGAND CHARCODE \CHARMASK)
(\OUTSTREAMARG STREAM)
(GETTERMTABLE TTBL))))
(\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) (* lmm " 5-OCT-83 18:31")
(* 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 CHARPOSITION of STREAM)
(IPLUS (COND
((IGREATERP CC 177Q)
(* META character)
(DSPBOUT (CHARCODE #))
(SETQ CC (LOGAND CC 177Q))
1)
(T 0))
(COND
((ILESSP CC 40Q)
(* CONTROL character)
(DSPBOUT (CHARCODE ↑))
(SETQ CC (LOGOR CC 100Q))
1)
(T 0))
(PROGN (DSPBOUT CC)
1]
[SIMULATE.CCE (SELCHARQ CHARCODE
(LF (DSPBOUT (CHARCODE EOL))
(RPTQ (fetch CHARPOSITION of STREAM)
(DSPBOUT (CHARCODE SPACE)))
(\STOPSCROLL?))
(EOL (DSPBOUT (CHARCODE EOL))
(\STOPSCROLL?)
(replace CHARPOSITION of STREAM with 0))
(ESCAPE (DSPBOUT (CHARCODE $))
(* change to $)
(add (fetch CHARPOSITION of STREAM)
1))
(TAB (FRPTQ (IDIFFERENCE 10Q (MOD (fetch CHARPOSITION
of STREAM)
10Q))
(DSPBOUT (CHARCODE SPACE))
(add (fetch CHARPOSITION of STREAM)
1)))
(PROGN (DSPBOUT CHARCODE)
(add (fetch CHARPOSITION of STREAM)
1]
[REAL.CCE (DSPBOUT CHARCODE)
(COND
((EQ CHARCODE (CHARCODE EOL))
(\STOPSCROLL?)
(replace CHARPOSITION of STREAM with 0))
(T (add (fetch CHARPOSITION of STREAM)
1]
(IGNORE.CCE)
(SHOULDNT])
(\ECHOCHAR
(LAMBDA (C) (* JonL " 7-NOV-83 17:47")
(if (fetch ECHOFLG of \PRIMTERMTABLE)
then (if (AND (ZEROP (fetch RAISEFLG of \PRIMTERMTABLE))
(IGEQ C (CHARCODE a))
(ILEQ C (CHARCODE z)))
then (* This is doing a raise if flag is set)
(SETQ C (IDIFFERENCE C 32)))
(if (IGREATERP (IPLUS (DSPXPOSITION NIL \TERM.OFD)
(OR (\STREAMCHARWIDTH C \TERM.OFD \PRIMTERMTABLE)
0))
(DSPRIGHTMARGIN NIL \TERM.OFD))
then (* past RIGHT margin, force eol)
(TERPRI \TERM.OFD))
(\BOUT \TERM.OFD 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])
(\PAGEFULLINVERTWFN
[LAMBDA (STREAM) (* rmk: "31-AUG-83 14:54")
(* inverts a window. Needs to be a separate function because if an error occurred, the stream, if it was the T
stream, was scrolled by INTERRUPTED 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])
(\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 (* rmk: "16-SEP-83 23:30")
(* 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)
(COND
((NOT (\EOFP \LINEBUF.OFD))
(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])
)
(DEFINEQ
(VIDEOCOLOR
[LAMBDA NARGS (* bvm: "10-Jan-84 12:41")
(DECLARE (GLOBALVARS \VideoColor)) (* sets the interpretation of bits that are displayed on
the screen so that 1 is black {NIL} or 1 is white
{anything else}.)
(PROG1 \VideoColor (COND
((NEQ NARGS 0)
(SETQ \VideoColor (AND (ARG NARGS 1)
T))
(SELECTC \MACHINETYPE
[\DANDELION (replace DLDISPCONTROL of \IOPAGE
with (COND
(\VideoColor
(* Inverse video)
(LOGOR 4000Q (fetch DLDISPCONTROL
of \IOPAGE)))
(T (LOGAND (LOGXOR 4000Q MAX.SMALLP)
(fetch DLDISPCONTROL of \IOPAGE]
(SETSCREENCOLOR \VideoColor])
)
(RPAQQ \VideoColor NIL)
(PUTPROPS VIDEOCOLOR ARGNAMES (BLACKFLG))
(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) (* rmk: "25-OCT-83 16:32")
(* 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)
(UNINTERRUPTABLY
(SETQ \DRIBBLE.OFD NIL)
(\REMOVEDRIBBLECHECK (TTYDISPLAYSTREAM)))
(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 (OPENSTREAM FILE (COND
(APPENDFLG (QUOTE APPEND))
(T (QUOTE OUTPUT)))
NIL NIL (AND THAWEDFLG (QUOTE THAWED]
(replace USERCLOSEABLE of NEWDRIBFILE with NIL)
(replace USERVISIBLE of NEWDRIBFILE with NIL)
(UNINTERRUPTABLY
(SETQ \DRIBBLE.OFD NEWDRIBFILE)
(\ADDDRIBBLECHECK (TTYDISPLAYSTREAM)))] (* fix up \TTYOUTCHARFN to check for dribble or not -
TTYDISPLAYSTREAM sets this up)
(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) (* rmk: "25-OCT-83 16:33")
(* 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 (\GETSTREAM FILE (QUOTE OUTPUT]
(replace USERCLOSEABLE of DF with NIL)
(replace USERVISIBLE of DF with NIL)
(UNINTERRUPTABLY
(SETQ \DRIBBLE.OFD DF)
(\ADDDRIBBLECHECK (TTYDISPLAYSTREAM)))])
(\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 (* rmk: "23-SEP-83 17:40")
(* 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 (* rmk: "23-SEP-83 21:50")
(* 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
((OR (NOT (type? STREAM \LINEBUF.OFD))
(EQ \LINEBUF.OFD \DEFAULTLINEBUF))
(SETQ \LINEBUF.OFD (\CREATELINEBUFFER))
(OR (AND (type? STREAM \PRIMIN.OFD)
(NEQ \PRIMIN.OFD \DEFAULTLINEBUF))
(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)
(MOVD? (QUOTE \OPENLINEBUF)
(QUOTE \CREATE.TTYDISPLAYSTREAM))
(\NODIRCOREFDEV (QUOTE LINEBUFFER)
(FUNCTION \LINEBUF.READP))
(RPAQ \DEFAULTLINEBUF (\SETUP.DEFAULT.LINEBUF))
(\OPENLINEBUF)
)
(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)
)
(DECLARE: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS
(ADDTOVAR NLAMA )
(ADDTOVAR NLAML )
(ADDTOVAR LAMA VIDEOCOLOR)
)
(PUTPROPS ATERM COPYRIGHT ("Xerox Corporation" 3676Q 3677Q 3700Q))
(DECLARE: DONTCOPY
(FILEMAP (NIL (3627Q 61707Q (BKLINBUF 3641Q . 4474Q) (CLEARBUF 4476Q . 6310Q) (DSPSOUT 6312Q . 7034Q)
(LINBUF 7036Q . 7326Q) (PAGEFULLFN 7330Q . 12172Q) (SETLINELENGTH 12174Q . 12467Q) (SYSBUF 12471Q .
12761Q) (TERMCHARWIDTH 12763Q . 13631Q) (\CHDEL1 13633Q . 14436Q) (\CLOSELINE 14440Q . 15514Q) (
\DECPARENCOUNT 15516Q . 17714Q) (\DSCCOUT 17716Q . 24122Q) (\ECHOCHAR 24124Q . 25475Q) (\FILLBUFFER
25477Q . 47052Q) (\GETCHAR 47054Q . 47473Q) (\INCPARENCOUNT 47475Q . 52631Q) (\PAGEFULLINVERTWFN
52633Q . 54070Q) (\RESETLINE 54072Q . 54560Q) (\RESETTERMINAL 54562Q . 56143Q) (\SAVELINEBUF 56145Q .
57643Q) (\STOPSCROLL? 57645Q . 61705Q)) (61710Q 63474Q (VIDEOCOLOR 61722Q . 63472Q)) (64371Q 67201Q (
\PEEKREFILL 64403Q . 65173Q) (\READREFILL 65175Q . 65746Q) (\RATOM/RSTRING-REFILL 65750Q . 66473Q) (
\READCREFILL 66475Q . 67177Q)) (67202Q 76611Q (DRIBBLE 67214Q . 72046Q) (DRIBBLEFILE 72050Q . 72323Q)
(SETDRIBBLEFILE 72325Q . 73563Q) (\STOP.DRIBBLE? 73565Q . 75345Q) (RESTARTDRIBBLE 75347Q . 76607Q)) (
76612Q 106366Q (\SETUP.DEFAULT.LINEBUF 76624Q . 101202Q) (\CREATELINEBUFFER 101204Q . 102716Q) (
\LINEBUF.READP 102720Q . 103153Q) (\OPENLINEBUF 103155Q . 106364Q)) (107352Q 107774Q (\INTERMP 107364Q
. 107567Q) (\OUTTERMP 107571Q . 107772Q)))))
STOP