(FILECREATED "19-Sep-86 18:19:05" {ERIS}<LISPCORE>SOURCES>ATERM.;40 53668
changes to: (FNS DRIBBLE DRIBBLEFILE)
previous date: "16-Sep-86 20:01:50" {ERIS}<LISPCORE>SOURCES>ATERM.;38)
(* Copyright (c) 1982, 1983, 1984, 1985, 1986 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT ATERMCOMS)
(RPAQQ ATERMCOMS
((* Line-buffering)
(FNS BKLINBUF CLEARBUF LINBUF PAGEFULLFN SETLINELENGTH SYSBUF TERMCHARWIDTH TERMINAL-INPUT
TERMINAL-OUTPUT \CHDEL1 \CLOSELINE \DECPARENCOUNT \ECHOCHAR \FILLBUFFER
\FILLBUFFER.WORDSEPRP \FILLBUFFER.BACKUP \GETCHAR \INCPARENCOUNT \RESETLINE
\RESETTERMINAL \SAVELINEBUF \STOPSCROLL?)
(COMS * BCPLDISPLAYCOMS)
(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)
(FNS \SETUP.DEFAULT.LINEBUF \CREATELINEBUFFER \LINEBUF.READP \OPENLINEBUF)
(DECLARE: DOCOPY DONTEVAL@LOAD (VARS (\#DISPLAYLINES 58)
(\DISPLAYLINELENGTH 82)
(\CURRENTDISPLAYLINE 0)
(\STOPSCROLLMESSAGE "---MORE---"))
(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
TERMINAL-OUTPUT
TERMINAL-INPUT)))))
(* Line-buffering)
(DEFINEQ
(BKLINBUF
[LAMBDA (STR) (* bvm: " 5-May-86 11:38")
(COND
((STRINGP STR)
(\RESETLINE)
(for J C [SA ← (fetch READSA of (\DTEST *READTABLE* (QUOTE READTABLEP] 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])
(LINBUF
[LAMBDA (FLG) (* rrb "21-JUL-83 15:33")
(COND
(FLG (AND \LINBUF (CONCAT \LINBUF)))
(T (SETQ \LINBUF NIL])
(PAGEFULLFN
[LAMBDA (STREAM) (* lmm "10-Jan-86 01:19")
(* 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.)
(LET ((KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD)))
(COND
((READP KEYSTREAM))
((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))
(BIN KEYSTREAM)))
(T (PRIN1 \STOPSCROLLMESSAGE STREAM)
(BIN KEYSTREAM) (* Now erase the message)
(FRPTQ (NCHARS \STOPSCROLLMESSAGE)
(\OUTCHAR STREAM ERASECHARCODE))
(BLOCK])
(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])
(TERMINAL-INPUT
[LAMBDA U (* lmm " 9-Jan-86 03:21")
(* * Return the current terminal output stream.
If an argument is supplied, make it the new terminal output stream)
(PROG1 \LINEBUF.OFD (COND
((IGEQ U 1)
(LET [(STREAM (GETSTREAM (ARG U 1)
(QUOTE INPUT]
(if (EQ \PRIMIN.OFD \LINEBUF.OFD)
then (SETQ \PRIMIN.OFD STREAM))
(SETQ \LINEBUF.OFD STREAM])
(TERMINAL-OUTPUT
[LAMBDA U (* lmm " 9-Jan-86 03:20")
(* * Return the current terminal output stream.
If an argument is supplied, make it the new terminal output stream)
(PROG1 \TERM.OFD (COND
((IGEQ U 1)
(LET [(STREAM (GETSTREAM (ARG U 1)
(QUOTE OUTPUT]
(IF (EQ \PRIMOUT.OFD \TERM.OFD)
THEN (SETQ \PRIMOUT.OFD STREAM))
(SETQ TtyDisplayStream (SETQ \TERM.OFD STREAM])
(\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 (* lmm "10-Jan-86 03:07")
(SETQ \CURRENTDISPLAYLINE 0)
(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])
(\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) (* bvm: " 5-May-86 13:40")
(* While filling the line, the current file pointer is the end of the line.
When the line is closed, this is made the eof.
-
*READTABLE* is used for syntactic delimiters and paren counting on READ and
RATOM calls but isn't referenced (or bound) for READC)
(DECLARE (USEDFREE *READTABLE* FLG))
(\RESETLINE)
(PROG ((ILB (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD))
(ISP (fetch (LINEBUFFER INSTRINGP) of \LINEBUF.OFD))
(ILP (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD))
(KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD))
(RTBLSA (AND (NEQ FILLTYPE READC.FT)
(fetch READSA of *READTABLE*)))
(CONTROLTON (fetch CONTROLFLG of \PRIMTERMTABLE))
RSNX TCLASS CHAR RAISEDCHAR PEEKEDECHOED)
(DECLARE (SPECVARS RTBLSA)) (* TCLASS is terminal syntax class,
RSNX is read-table code)
[COND
((SETQ CHAR (fetch (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD))
(* Account for peeked character)
(SETQ CHAR (IABS CHAR)) (* 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 CHAR)))
(replace (LINEBUFFER PEEKEDCHAR) of \LINEBUF.OFD with NIL)
(SETQ PEEKEDECHOED T)
(SETQ RAISEDCHAR (\RAISECHAR CHAR]
(COND
((AND CONTROLTON (EQ FILLTYPE READC.FT))
(\LINEBUFBOUT \LINEBUF.OFD (OR CHAR (\GETCHAR)))
(GO EXIT)))
(COND
(CHAR (GO NEXTTCLASS)))
NEXT
(SETQ CHAR (BIN KEYSTREAM))
NEXTTCLASS
[SETQ TCLASS (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA (SETQ RAISEDCHAR (\RAISECHAR CHAR]
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))
(CHARDELETE.TC
(COND
((SETQ CHAR (\CHDEL1))
(\FILLBUFFER.BACKUP CHAR)))
(GO RECOMPUTE))
(LINEDELETE.TC
(while (SETQ CHAR (\CHDEL1)) do (\FILLBUFFER.BACKUP CHAR))
(GO RECOMPUTE))
(WORDDELETE.TC
(if (SETQ CHAR (\CHDEL1))
then (while (\FILLBUFFER.WORDSEPRP CHAR) do
(* first chars are seprs, delete them
all)
(\FILLBUFFER.BACKUP CHAR)
(OR (SETQ CHAR (\CHDEL1))
(GO RECOMPUTE)))
(\FILLBUFFER.BACKUP CHAR)
(OR (SETQ CHAR (\CHDEL1))
(GO RECOMPUTE))
(while (NULL (\FILLBUFFER.WORDSEPRP CHAR))
do (\FILLBUFFER.BACKUP CHAR)
(OR (SETQ CHAR (\CHDEL1))
(GO RECOMPUTE))) (* put CHAR back)
(\LINEBUFBOUT \LINEBUF.OFD CHAR)
(GO RECOMPUTE))
(GO NEXT))
(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 CHAR) (* 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 CHAR)
(\LINEBUFBOUT \LINEBUF.OFD RAISEDCHAR)
(GO EXIT))
NIL)
(COND
(PEEKEDECHOED (SETQ PEEKEDECHOED NIL))
(T (\ECHOCHAR CHAR))) (* 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 (EQ (fetch (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD)
0)
(EQ (fetch (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD)
0)
(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)
RECOMPUTE
(AND (EQ FILLTYPE READ.FT)
(PROGN (UNINTERRUPTABLY
(\SETFILEPTR \LINEBUF.OFD 0)
(replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with RETYPING.LBS)
(replace (LINEBUFFER LBRKCOUNT) of \LINEBUF.OFD with ILB)
(replace (LINEBUFFER INSTRINGP) of \LINEBUF.OFD with ISP)
(replace (LINEBUFFER LPARCOUNT) of \LINEBUF.OFD with ILP))
[until (\EOFP \LINEBUF.OFD) do (SETQ CHAR (\NSIN \LINEBUF.OFD (UNFOLD
\NORUNCODE
256)))
(COND
[(EQ ESCAPE.RC (SETQ RSNX (\SYNCODE RTBLSA
CHAR)))
(OR (\EOFP \LINEBUF.OFD)
(\NSIN \LINEBUF.OFD (UNFOLD \NORUNCODE
256]
(T (\INCPARENCOUNT RSNX]
(replace (LINEBUFFER LINEBUFSTATE) of \LINEBUF.OFD with FILLING.LBS)))
(GO NEXT)
EXIT
(\CLOSELINE])
(\FILLBUFFER.WORDSEPRP
[LAMBDA (CHAR) (* lmm "17-Jan-86 19:44")
(OR (EQ WORDSEPR.TC (fetch TERMCLASS of (\SYNCODE \PRIMTERMSA CHAR)))
(NEQ OTHER.RC (\SYNCODE RTBLSA CHAR])
(\FILLBUFFER.BACKUP
[LAMBDA (CHAR) (* lmm "10-Jan-86 18:32")
(DSPBACKUP (CHARWIDTH CHAR \TERM.OFD)
\TERM.OFD])
(\GETCHAR
[LAMBDA NIL (* lmm "30-Dec-85 17:25")
(PROG [(C (BIN (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD]
(\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 (* lmm "11-Feb-86 09:56")
(* 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)
(LET ([W (AND \WINDOWWORLD (WFROMDS (TTYDISPLAYSTREAM]
WINDOWFN)
(COND
([AND W (SETQ WINDOWFN (WINDOWPROP W (QUOTE PAGEFULLFN]
(APPLY* WINDOWFN (TTYDISPLAYSTREAM)))
(T (PAGEFULLFN (TTYDISPLAYSTREAM])
)
(RPAQQ BCPLDISPLAYCOMS ((FNS \DSCCOUT \INITBCPLDISPLAY)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (\INITBCPLDISPLAY)))
(EXPORT (GLOBALVARS \BCPLDISPLAY))))
(DEFINEQ
(\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 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 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 8 (MOD (fetch CHARPOSITION of STREAM)
8))
(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])
(\INITBCPLDISPLAY
[LAMBDA NIL (* lmm " 9-Jan-86 00:40")
(SETQ \BCPLDISPLAY (create STREAM
DEVICE ← (create FDEV
BOUT ← (FUNCTION \DSCCOUT))
ACCESS ← (QUOTE OUTPUT)
LINELENGTH ← 72
USERCLOSEABLE ← NIL
USERVISIBLE ← NIL
OUTCHARFN ← (FUNCTION \DSCCOUT)))
(OR (STREAMP \TERM.OFD)
(SETQ \TERM.OFD \BCPLDISPLAY))
(OR (STREAMP \PRIMOUT.OFD)
(SETQ \PRIMOUT.OFD \BCPLDISPLAY])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(\INITBCPLDISPLAY)
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \BCPLDISPLAY)
)
(* END EXPORTED DEFINITIONS)
(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 (* ejs: " 8-Jul-85 16:19")
(* 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 (BIN (fetch (LINEBUFFER KEYBOARDSTREAM) of \LINEBUF.OFD]
(* 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 (* AJB "15-Jan-86 14:52")
(* Called from \ENDOFFILE via
\RefillBufferFn when the linebuffer is
empty)
(DECLARE (USEDFREE \LINEBUF.OFD))
(* * If the LINEBUFFER has a REFILLBUFFERFN use it, otherwise call \FILLBUFFER
as default)
(COND
((STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN))
(APPLY* (STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN))
READ.FT))
(T (\FILLBUFFER READ.FT)))
(APPLY* (STKNAME (QUOTE (\BIN \PEEKBIN)))
\LINEBUF.OFD])
(\RATOM/RSTRING-REFILL
[LAMBDA NIL (* AJB "15-Jan-86 14:53")
(* Called from \ENDOFFILE via
\RefillBufferFn when the linebuffer is
empty)
(DECLARE (USEDFREE \LINEBUF.OFD))
(* * If the LINEBUFFER has a REFILLBUFFERFN use it, otherwise call \FILLBUFFER
as default)
(COND
((STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN))
(APPLY* (STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN))
RATOM/RSTRING.FT))
(T (\FILLBUFFER RATOM/RSTRING.FT)))
(\BIN \LINEBUF.OFD])
(\READCREFILL
[LAMBDA NIL (* AJB "15-Jan-86 14:53")
(* Called from \ENDOFFILE via
\RefillBufferFn when the linebuffer is
empty)
(DECLARE (USEDFREE \LINEBUF.OFD))
(* * If the LINEBUFFER has a REFILLBUFFERFN use it, otherwise call \FILLBUFFER
as default)
(COND
((STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN))
(APPLY* (STREAMPROP \LINEBUF.OFD (QUOTE REFILLBUFFERFN))
READC.FT))
(T (\FILLBUFFER READC.FT)))
(\BIN \LINEBUF.OFD])
)
(DEFINEQ
(DRIBBLE
(LAMBDA (FILE APPENDFLG) (* hdj "19-Sep-86 18:15")
(* ;; "Turn on/off dribbling for this process")
(* ;; "")
(* ;;
"Dribbling is on if the TTYDISPLAYSTREAM has a DRIBBLESTREAM property")
(LET ((OLD-DRIBBLE-STREAM (DRIBBLEFILE))
(NEW-DRIBBLE-STREAM NIL))
(if OLD-DRIBBLE-STREAM
then (* ;; "disable dribbling to old dribble stream")
(\REMOVEDRIBBLECHECK (TTYDISPLAYSTREAM))
(replace (STREAM USERCLOSEABLE) of OLD-DRIBBLE-STREAM with T)
(replace (STREAM USERVISIBLE) of OLD-DRIBBLE-STREAM with T)
(CLOSEF OLD-DRIBBLE-STREAM))
(if (AND FILE (NEQ FILE T))
then (SETQ NEW-DRIBBLE-STREAM (OPENSTREAM FILE (COND
(APPENDFLG (QUOTE APPEND))
(T (QUOTE OUTPUT)))))
(UNINTERRUPTABLY
(replace (STREAM USERCLOSEABLE) of NEW-DRIBBLE-STREAM with NIL)
(replace (STREAM USERVISIBLE) of NEW-DRIBBLE-STREAM with NIL)
(* ;; "fix up \TTYOUTCHARFN to dribble")
(\ADDDRIBBLECHECK (TTYDISPLAYSTREAM)
NEW-DRIBBLE-STREAM)))
(AND OLD-DRIBBLE-STREAM (fetch (STREAM FULLNAME) of OLD-DRIBBLE-STREAM)))))
(DRIBBLEFILE
(LAMBDA NIL (* hdj "19-Sep-86 17:43")
(STREAMPROP (TTYDISPLAYSTREAM)
(QUOTE DRIBBLESTREAM))))
)
(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 (TERMINAL.STREAM) (* lmm " 7-Jan-86 12:53")
(PROG [(STREAM (\OPENFILE (QUOTE {LINEBUFFER})
(QUOTE BOTH)
(QUOTE NEW)
(QUOTE ((CHARSET T]
(replace LINEBUFSTATE of STREAM with READING.LBS)
(replace (LINEBUFFER KEYBOARDSTREAM) of STREAM with (OR TERMINAL.STREAM \KEYBOARD.STREAM))
(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) (* lmm "30-Dec-85 19:20")
(LET ((KEYSTREAM (fetch (LINEBUFFER KEYBOARDSTREAM) of STREAM)))
(OR (AND KEYSTREAM (READP KEYSTREAM))
(fetch (LINEBUFFER PEEKEDCHAR) of STREAM)
(\PAGEDREADP STREAM])
(\OPENLINEBUF
[LAMBDA NIL (* lmm " 7-Jan-86 17:09")
(* 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))
(PROG (STREAM) (* Output parameters)
(* 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 \#DISPLAYLINES 58)
(RPAQQ \DISPLAYLINELENGTH 82)
(RPAQQ \CURRENTDISPLAYLINE 0)
(RPAQ \STOPSCROLLMESSAGE "---MORE---")
(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))
(LINEBUFSTATE (fetch F5 of DATUM)
(replace F5 of DATUM with NEWVALUE))
(* F4 is free. EJS, 7/8/85)
(KEYBOARDSTREAM (fetch F2 of DATUM)
(replace F2 of DATUM with NEWVALUE))
(PEEKEDCHAR (fetch F3 of DATUM)
(replace F3 of DATUM with NEWVALUE))
(* Character read by PEEKC)
(LBFLAGS (fetch FW9 of DATUM)
(replace FW9 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)
)
(ACCESSFNS LINEBUFFER ((LBFLAGBASE (LOCF (fetch LBFLAGS of DATUM))))
(BLOCKRECORD LBFLAGBASE ((PEEKEDECHOFLG FLAG)
(INSTRINGP FLAG)))))
]
(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 TERMINAL-OUTPUT TERMINAL-INPUT)
)
(PUTPROPS ATERM COPYRIGHT ("Xerox Corporation" 1982 1983 1984 1985 1986))
(DECLARE: DONTCOPY
(FILEMAP (NIL (2719 31822 (BKLINBUF 2729 . 3206) (CLEARBUF 3208 . 4817) (LINBUF 4819 . 5009) (
PAGEFULLFN 5011 . 6892) (SETLINELENGTH 6894 . 7094) (SYSBUF 7096 . 7286) (TERMCHARWIDTH 7288 . 7748) (
TERMINAL-INPUT 7750 . 8420) (TERMINAL-OUTPUT 8422 . 9092) (\CHDEL1 9094 . 9400) (\CLOSELINE 9402 .
9695) (\DECPARENCOUNT 9697 . 11397) (\ECHOCHAR 11399 . 12022) (\FILLBUFFER 12024 . 24277) (
\FILLBUFFER.WORDSEPRP 24279 . 24528) (\FILLBUFFER.BACKUP 24530 . 24713) (\GETCHAR 24715 . 25044) (
\INCPARENCOUNT 25046 . 27540) (\RESETLINE 27542 . 27870) (\RESETTERMINAL 27872 . 28908) (\SAVELINEBUF
28910 . 30571) (\STOPSCROLL? 30573 . 31820)) (32024 35879 (\DSCCOUT 32034 . 35185) (\INITBCPLDISPLAY
35187 . 35877)) (36065 37646 (VIDEOCOLOR 36075 . 37644)) (38417 44000 (\PEEKREFILL 38427 . 41580) (
\READREFILL 41582 . 42407) (\RATOM/RSTRING-REFILL 42409 . 43215) (\READCREFILL 43217 . 43998)) (44001
46013 (DRIBBLE 44011 . 45827) (DRIBBLEFILE 45829 . 46011)) (46014 50156 (\SETUP.DEFAULT.LINEBUF 46024
. 47791) (\CREATELINEBUFFER 47793 . 48721) (\LINEBUF.READP 48723 . 49059) (\OPENLINEBUF 49061 . 50154
)) (50596 50878 (\INTERMP 50606 . 50741) (\OUTTERMP 50743 . 50876)))))
STOP