(FILECREATED "27-Jul-85 22:49:06" {ERIS}<LISPCORE>SOURCES>ATERM.;14 43535
changes to: (FNS VIDEOCOLOR)
previous date: "17-Jul-85 12:08:23" {ERIS}<LISPCORE>SOURCES>ATERM.;13)
(* Copyright (c) 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ATERMCOMS)
(RPAQQ ATERMCOMS [(* Line-buffering)
(FNS BKLINBUF CLEARBUF DSPSOUT LINBUF PAGEFULLFN SETLINELENGTH SYSBUF TERMCHARWIDTH \CHDEL1
\CLOSELINE \DECPARENCOUNT \DSCCOUT \ECHOCHAR \FILLBUFFER \GETCHAR \INCPARENCOUNT
\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 \LINEBUFBOUT))
(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 58)
(\DISPLAYLINELENGTH 82)
(\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) (* rmk: "24-Apr-85 13:31")
(DECLARE (GLOBALVARS \SYSREADTABLE))
(COND
((STRINGP STR)
(\RESETLINE)
(for J C (SA ←(fetch READSA of \SYSREADTABLE)) from 1 while (SETQ C (NTHCHARCODE STR J))
do (\OUTCHAR \LINEBUF.OFD C)
(\INCPARENCOUNT (\SYNCODE SA C)))
(\CLOSELINE)
STR])
(CLEARBUF
[LAMBDA (FILE FLG) (* bvm: "11-Jul-84 23:30")
[PROG ([STRM (SELECTQ FILE
(T \LINEBUF.OFD)
(NIL \PRIMIN.OFD)
(\GETSTREAM FILE (QUOTE INPUT]
SYSBUF LINBUF) (* Do the stream coercion in line so we don't
needlessly create a tty window just to clear input)
(COND
((AND (EQ STRM \LINEBUF.OFD)
(NEQ STRM \DEFAULTLINEBUF)) (* Don't do this if \LINEBUF.OFD is the default, since
then there really isn't anything to save)
(COND
[FLG (SETQ LINBUF (\SAVELINEBUF))
(SETQ SYSBUF (\SAVESYSBUF))
(COND
((OR LINBUF SYSBUF) (* 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)
(\RESETTERMINAL]
NIL])
(DSPSOUT
[LAMBDA (X) (* lmm " 8-May-84 10:01")
(* Puts a string on the display)
(bind (STREAM ←(GETSTREAM T (QUOTE OUTPUT))) for CHAR instring X do (BOUT STREAM CHAR])
(LINBUF
[LAMBDA (FLG) (* rrb "21-JUL-83 15:33")
(COND
(FLG (AND \LINBUF (CONCAT \LINBUF)))
(T (SETQ \LINBUF NIL])
(PAGEFULLFN
[LAMBDA (STREAM) (* bvm: " 7-Feb-85 21:53")
(* 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 INVERTW)
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: "28-Mar-85 18:25")
(COND
((\BACKNSCHAR \LINEBUF.OFD (UNFOLD \NORUNCODE 256))
(PROG1 (\NSPEEK \LINEBUF.OFD (UNFOLD \NORUNCODE 256))
(\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) (* bvm: "14-Feb-85 00:29")
(* 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
((EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)
0)
(add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD)
-1]
[RIGHTPAREN.RC (COND
((EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)
0)
(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) (* rmk: "26-Apr-85 08:50")
(if (fetch ECHOFLG of \PRIMTERMTABLE)
then (if (AND (EQ (fetch RAISEFLG of \PRIMTERMTABLE)
0)
(IGEQ C (CHARCODE a))
(ILEQ C (CHARCODE z)))
then (* This is doing a raise if flag is set)
(SETQ C (IDIFFERENCE C 32)))
(\OUTCHAR \TERM.OFD C])
(\FILLBUFFER
[LAMBDA (FILLTYPE) (* jds "11-Apr-85 10:36")
(* 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 ((ILB (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD))
(ISP (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD))
(ILP (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD))
(RTBLSA (AND (NEQ FILLTYPE READC.FT)
(fetch READSA of #CURRENTRDTBL#)))
(CONTROLTON (fetch CONTROLFLG of \PRIMTERMTABLE))
RSNX TCLASS C RAISEDCHAR PEEKEDECHOED) (* TCLASS is terminal syntax class, RSNX is read-table
code)
[COND
((SETQ C (fetch (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD))
(* Account for peeked character)
(SETQ C (IABS C)) (* The peeked char may be negative because it was
BIN'ed earlier. Make sure it is positive.)
(COND
((AND NIL (NULL (fetch (LINEBUFFER PEEKEDECHOFLG) of \LINEBUF.OFD)))
(* It wasn't echoed when first read, so echo it now if
desired)
(* Incompatible with I-10 to do it this way)
(\ECHOCHAR C)))
(replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with NIL)
(SETQ PEEKEDECHOED T)
(SETQ RAISEDCHAR (\RAISECHAR C]
(COND
((AND CONTROLTON (EQ FILLTYPE READC.FT))
(\LINEBUFBOUT \LINEBUF.OFD (OR C (\GETCHAR)))
(GO EXIT)))
(COND
(C (GO NEXTTCLASS)))
NEXT(SETQ C (\GETKEY))
NEXTTCLASS
[SETQ TCLASS (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA (SETQ RAISEDCHAR (\RAISECHAR C]
REDO(SELECTC TCLASS
(RETYPE.TC (\OUTCHAR \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 (\OUTCHAR \TERM.OFD
(\NSIN \LINEBUF.OFD
(UNFOLD \NORUNCODE 256]
(replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with FILLING.LBS)
(GO NEXT))
(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)
(GO NEXT)))
((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)
(\LINEBUFBOUT \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))
(\LINEBUFBOUT \LINEBUF.OFD C1)
(* Put it back)
(COND
((EQ ESCAPE? (\SYNCODE RTBLSA C1))
(SETQ RSNX OTHER.RC)
(SETQ TCLASS NONE.TC)
(GO CHK]
(\LINEBUFBOUT \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
(SETQ RAISEDCHAR
(\RAISECHAR C]
((LIST CHARDELETE.TC WORDDELETE.TC)
(GO AGAIN))
((LIST LINEDELETE.TC RETYPE.TC))
(DSPSOUT (fetch POSTCHDEL of \PRIMTERMTABLE]
(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.)
(\ECHOCHAR C) (* Want to echo ↑V)
(\LINEBUFBOUT \LINEBUF.OFD (COND
([OR (AND (IGEQ (SETQ RAISEDCHAR (\GETCHAR))
(CHARCODE A))
(ILEQ RAISEDCHAR (CHARCODE Z)))
(AND (IGEQ RAISEDCHAR (CHARCODE a))
(ILEQ RAISEDCHAR (CHARCODE z]
(LOGAND RAISEDCHAR 31))
(T RAISEDCHAR)))
(GO NEXT))
(EOL.TC (\ECHOCHAR C)
(\LINEBUFBOUT \LINEBUF.OFD RAISEDCHAR)
(GO EXIT))
NIL)
(COND
(PEEKEDECHOED (SETQ PEEKEDECHOED NIL))
(T (\ECHOCHAR C))) (* Here if it isn't a terminal class.
Only echo if it isn't a special terminal class)
(\LINEBUFBOUT \LINEBUF.OFD RAISEDCHAR)
(AND (EQ FILLTYPE READC.FT)
(GO NEXT))
(COND
((EQ ESCAPE.RC (SETQ RSNX (\SYNCODE RTBLSA RAISEDCHAR)))
(* 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 RAISEDCHAR
(\GETCHAR]
(GO REDO)))
(\LINEBUFBOUT \LINEBUF.OFD RAISEDCHAR)
(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 RAISEDCHAR (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) (* bvm: "14-Feb-85 00:30")
(* 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 (EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)
0)
(add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD)
1))
NIL)
[RIGHTPAREN.RC (* NOTE: RP's never match left-brackets, just like on
10)
(AND (EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)
0)
(OR (EQ (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD)
0)
(EQ (add (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD)
-1)
0]
(LEFTBRACKET.RC (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)
1)
NIL)
[RIGHTBRACKET.RC (COND
((EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)
0)
(replace (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD with 0))
(T (AND (EQ (add (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)
-1)
0)
(EQ (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD)
0]
NIL])
(\RESETLINE
[LAMBDA NIL (* jds "10-Apr-85 23:17")
(UNINTERRUPTABLY
(replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with FILLING.LBS)
(\SETFILEPTR \LINEBUF.OFD 0)
(\SETEOFPTR \LINEBUF.OFD 0))
(SETQ \CURRENTDISPLAYLINE 0])
(\RESETTERMINAL
[LAMBDA NIL (* bvm: "11-Jul-84 23:15")
(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)
(replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with NIL)
(\RESETLINE) (* Since we aren't immediately filling the buffer,
guarantee that the next read causes an EOF error)
(VIDEOCOLOR \VideoColor])
(\SAVELINEBUF
[LAMBDA NIL (* jds "12-Apr-85 18:19")
(* 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))
(bind [STR ←(ALLOCSTRING (IDIFFERENCE (\GETEOFPTR \LINEBUF.OFD)
(\GETFILEPTR \LINEBUF.OFD]
for J from 1 until (\EOFP \LINEBUF.OFD)
do (* Allocate a string, and save the chars from the
linebuffer in it.)
(* (The string is THIN, because we're BINning from the
line buffer--giving us thin chars.))
(RPLCHARCODE STR J (\BIN \LINEBUF.OFD))
finally (RETURN STR])
(\STOPSCROLL?
[LAMBDA NIL (* bvm: "14-Feb-85 00:30")
(* 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 (EQ \#DISPLAYLINES 0)
(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 (* MPL "27-Jul-85 22:47")
(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 2048 (fetch DLDISPCONTROL
of \IOPAGE)))
(T (LOGAND (LOGXOR 2048 MAX.SMALLP)
(fetch DLDISPCONTROL of \IOPAGE]
(\DAYBREAK (\DoveDisplay.SetVideoColor \VideoColor))
(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 32))
(T C]
[PUTPROPS \LINEBUFBOUT MACRO (OPENLAMBDA (STRM CHAR)
(\BOUT STRM (\CHARSET CHAR))
(\BOUT STRM (\CHAR8CODE CHAR]
)
)
(DEFINEQ
(\PEEKREFILL
[LAMBDA NIL (* jds "11-Apr-85 11:17")
(* Called from \ENDOFFILE via \RefillBufferFn when the
linebuffer is empty)
(PROG (C)
[COND
((SETQ C (fetch (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD))
(* Saved char, just return it.
Ideally we might want to pay attention to echo state,
but Interlisp-10 doesn't, so be compatible)
[COND
([EQ (QUOTE \BIN)
(STKNAME (QUOTE (\BIN \PEEKBIN] (* He is doing a \BIN -- remember for later calls that
we have passed over the left half of the character)
(replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with (IMINUS C))
(* Mark the passing by making the peeked char negative)
(RETURN (\CHARSET (\RAISECHAR C]
(COND
[(IGREATERP C 0) (* We're still looking at the left half.
Return it.)
(RETURN (\CHARSET (\RAISECHAR C]
(T (* We looked at the left half before.
Now look at the right half.)
(replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with (IMINUS C))
(RETURN (\CHAR8CODE (\RAISECHAR (IMINUS C]
(\ECHOCHAR (SETQ C (\GETKEY))) (* First time thru this: Get a key, and echo it.)
(\RESETLINE) (* Clear the line buffer.)
(replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with C)
(* Save the peeked character OUTSIDE the line buffer,
to avoid problems if the guy later types ↑E before the
character is really read.)
(RETURN (\CHARSET (\RAISECHAR C])
(\READREFILL
[LAMBDA NIL (* edited: "16-Jun-85 18:03")
(* Called from \ENDOFFILE via \RefillBufferFn when the
linebuffer is empty)
(DECLARE (USEDFREE \TERM.OFD))
(COND
((IMAGESTREAMTYPEP \TERM.OFD (QUOTE TEXT))
(TEXEC.FILLBUFFER READ.FT))
(T (\FILLBUFFER READ.FT)))
(APPLY* (STKNAME (QUOTE (\BIN \PEEKBIN)))
\LINEBUF.OFD])
(\RATOM/RSTRING-REFILL
[LAMBDA NIL (* edited: "17-Jun-85 09:35")
(* Called from \ENDOFFILE via \RefillBufferFn when the
linebuffer is empty)
(DECLARE (USEDFREE \TERM.OFD))
(COND
((IMAGESTREAMTYPEP \TERM.OFD (QUOTE TEXT))
(TEXEC.FILLBUFFER RATOM/RSTRING.FT))
(T (\FILLBUFFER RATOM/RSTRING.FT)))
(\BIN \LINEBUF.OFD])
(\READCREFILL
[LAMBDA NIL (* edited: "17-Jun-85 09:34")
(* Called from \ENDOFFILE via \RefillBufferFn when the
linebuffer is empty)
(DECLARE (USEDFREE \TERM.OFD))
(COND
((IMAGESTREAMTYPEP \TERM.OFD (QUOTE TEXT))
(TEXEC.FILLBUFFER READC.FT))
(T (\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 (* rmk: "28-Mar-85 17:56")
(PROG [(STREAM (\OPENFILE (QUOTE {LINEBUFFER})
(QUOTE BOTH)
(QUOTE NEW)
(QUOTE ((CHARSET T]
(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) (* bvm: "11-Jul-84 23:15")
(OR (\SYSBUFP)
(fetch (LINEBUFFER PEEKEDCHAR) of STREAM)
(\PAGEDREADP STREAM])
(\OPENLINEBUF
[LAMBDA NIL (* rmk: "14-Sep-84 15:15")
(* 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 \DSCCOUT)))
(* 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 58)
(RPAQQ \DISPLAYLINELENGTH 82)
(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))
(PEEKEDCHAR (fetch F3 of DATUM)
(replace F3 of DATUM with NEWVALUE))
(* Character read by PEEKC)
(PEEKEDECHOFLG (fetch F2 of DATUM)
(replace F2 of DATUM with NEWVALUE))
(* True if peeked char was echoed when peeked. Could use this to determine whether to echo later or not, but that
would be incompatible with Interlisp-10, so this field not used)
)
(SYSTEM))
]
(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
(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" 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (1960 27526 (BKLINBUF 1970 . 2410) (CLEARBUF 2412 . 3549) (DSPSOUT 3551 . 3860) (LINBUF
3862 . 4046) (PAGEFULLFN 4048 . 5622) (SETLINELENGTH 5624 . 5811) (SYSBUF 5813 . 5997) (TERMCHARWIDTH
5999 . 6421) (\CHDEL1 6423 . 6726) (\CLOSELINE 6728 . 7284) (\DECPARENCOUNT 7286 . 8492) (\DSCCOUT
8494 . 10674) (\ECHOCHAR 10676 . 11174) (\FILLBUFFER 11176 . 22004) (\GETCHAR 22006 . 22277) (
\INCPARENCOUNT 22279 . 24021) (\RESETLINE 24023 . 24345) (\RESETTERMINAL 24347 . 25149) (\SAVELINEBUF
25151 . 26354) (\STOPSCROLL? 26356 . 27524)) (27527 28520 (VIDEOCOLOR 27537 . 28518)) (29067 32660 (
\PEEKREFILL 29077 . 31206) (\READREFILL 31208 . 31707) (\RATOM/RSTRING-REFILL 31709 . 32195) (
\READCREFILL 32197 . 32658)) (32661 36508 (DRIBBLE 32671 . 34105) (DRIBBLEFILE 34107 . 34278) (
SETDRIBBLEFILE 34280 . 34950) (\STOP.DRIBBLE? 34952 . 35832) (RESTARTDRIBBLE 35834 . 36506)) (36509
40665 (\SETUP.DEFAULT.LINEBUF 36519 . 37781) (\CREATELINEBUFFER 37783 . 38686) (\LINEBUF.READP 38688
. 38892) (\OPENLINEBUF 38894 . 40663)) (41162 41436 (\INTERMP 41172 . 41303) (\OUTTERMP 41305 . 41434
)))))
STOP