(FILECREATED "21-Feb-85 10:48:24" {ERIS}<LISPCORE>SOURCES>LLDISPLAY.;33 148301
changes to: (FNS BITBLT)
previous date: "14-Feb-85 01:12:05" {ERIS}<LISPCORE>SOURCES>LLDISPLAY.;31)
(* Copyright (c) 1981, 1982, 1983, 1984, 1985 by Xerox Corporation. All rights reserved.)
(PRETTYCOMPRINT LLDISPLAYCOMS)
(RPAQQ LLDISPLAYCOMS [(DECLARE: DONTCOPY (EXPORT (RECORDS PILOTBBT \DISPLAYDATA DISPLAYSTATE)
(MACROS \GETDISPLAYDATA)))
(* User-visible records are on ADISPLAY - must be init'ed here)
(INITRECORDS BITMAP PILOTBBT REGION \DISPLAYDATA)
[COMS (* BITMASKS)
(FNS \FBITMAPBIT \NEWPAGE.DISPLAY INITBITMASKS)
[EXPORT (DECLARE: DONTCOPY (MACROS \BITMASK \4BITMASK \NOTBITMASK \NOT4BITMASK)
(GLOBALVARS BITMASKARRAY NOTBITMASKARRAY 4BITMASKARRAY
NOT4BITMASKARRAY)
(CONSTANTS (WORDMASK 65535]
(DECLARE: DONTEVAL@LOAD DOCOPY (P (INITBITMASKS]
[COMS (* init cursor)
(FNS \CreateCursorBitMap)
(DECLARE: DONTEVAL@LOAD DOCOPY (VARS (CursorBitMap (\CreateCursorBitMap]
[COMS (* bitmap functions.)
(FNS BITBLT BLTSHADE \BITBLTSUB \GETPILOTBBTSCRATCHBM BITMAPCOPY BITMAPCREATE BITMAPBIT
BLTCHAR \BLTCHAR \SLOWBLTCHAR TEXTUREP INVERT.TEXTURE INVERT.TEXTURE.BITMAP
BITMAPWIDTH READBITMAP)
(FNS \BITBLT.1BITDISPLAY \BITBLT.BITMAP \BITBLT.COLORDISPLAY \BITBLT.MERGE
\BLTSHADE.1BITDISPLAY \BLTSHADE.BITMAP \BLTSHADE.COLORDISPLAY)
(DECLARE: DONTCOPY (CONSTANTS (\DisplayWordAlign 16)
(\MaxBitMapWidth 65535)
(\MaxBitMapHeight 65535)
(\MaxBitMapWords 131066))
(EXPORT (MACROS \DSPGETCHARWIDTH \DSPGETCHAROFFSET \CONVERTOP \SFInvert
\SFReplicate \SETPBTFUNCTION \BITBLT1))
(GLOBALVARS \SYSBBTEXTURE \BBSCRATCHTEXTURE \SYSPILOTBBT \PILOTBBTSCRATCHBM))
(VARS (\BBSCRATCHTEXTURE)
(\PILOTBBTSCRATCHBM))
[DECLARE: DONTEVAL@LOAD DOCOPY (P (MOVD? (QUOTE BITBLT)
(QUOTE BKBITBLT]
(* macro for this file so that BITBLT can be broken by users)
(EXPORT (DECLARE: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE
(P (PUTPROP (QUOTE BITBLT)
(QUOTE MACRO)
(QUOTE (= . BKBITBLT]
(COMS (* display stream functions)
(FNS DISPLAYSTREAMP DSPSOURCETYPE DSPXOFFSET DSPYOFFSET)
(FNS DSPCREATE DSPDESTINATION DSPTEXTURE \DISPLAYSTREAMINCRXPOSITION \SFFixDestination
\SFFixClippingRegion \SFFixFont \SFFIXLINELENGTH \SFFixY)
(FNS \DSPCLIPPINGREGION.DISPLAY \DSPFONT.DISPLAY \DSPFONT.COLORDISPLAY
\DSPLINEFEED.DISPLAY \DSPLEFTMARGIN.DISPLAY \DSPOPERATION.DISPLAY
\DSPRIGHTMARGIN.DISPLAY \DSPXPOSITION.DISPLAY \DSPYPOSITION.DISPLAY)
(EXPORT (MACROS \DDMARKUNFONTED \DDHASFONT))
(P (MOVD? (QUOTE \ILLEGAL.ARG)
(QUOTE \COERCETODS))
(MOVD? (QUOTE NILL)
(QUOTE WFROMDS))
(MOVD? (QUOTE NILL)
(QUOTE WINDOWP))
(MOVD? (QUOTE NILL)
(QUOTE INVERTW)))
(INITVARS (PROMPTWINDOW T)))
[COMS (* Stub for window package)
[DECLARE: DOCOPY (DECLARE: EVAL@LOADWHEN (EQ (SYSTEMTYPE)
(QUOTE D))
(INITVARS (\TOPWDS))
(P (MOVD? (QUOTE NILL)
(QUOTE \TOTOPWDS]
(DECLARE: DONTCOPY EVAL@COMPILE (EXPORT (MACROS \INSURETOPWDS .WHILE.TOP.DS.
.WHILE.TOP.IF.DS. \PIXELOFBITADDRESS)
(ADDVARS (GLOBALVARS \TOPWDS]
(COMS (* DisplayStream TTY functions)
(FNS TTYDISPLAYSTREAM \REMOVEDRIBBLECHECK \ADDDRIBBLECHECK)
(EXPORT (MACROS TTYDISPLAYSTREAM))
(FNS DSPSCROLL CHANGETTYDEVICE OUTPUTDSP PAGEHEIGHT)
(INITVARS (\CURRENTTTYDEVICE (QUOTE BCPLDISPLAY))
(\SystemColorMap))
(FNS \DSPRESET.DISPLAY \DSPPRINTCHAR \DSPPRINTCR/LF)
(FNS \TTYBACKGROUND)
(FNS DSPBACKUP)
(INITVARS (\CARET.UP))
(DECLARE: DONTEVAL@LOAD DOCOPY (VARS (BELLCNT 2)
(BELLRATE 60)
(\DisplayStoppedForLogout)
(TtyDisplayStream)))
(FNS COLORDISPLAYP)
(FNS DISPLAYBEFOREEXIT DISPLAYAFTERENTRY)
(EXPORT (GLOBALVARS BELLCNT BELLRATE TTYBACKGROUNDFNS \DisplayStoppedForLogout
\SystemColorMap \CARET.UP)
(MACROS \CHECKCARET)))
[COMS (* transformation related functions.)
(FNS \DSPCLIPTRANSFORMX \DSPCLIPTRANSFORMY \DSPTRANSFORMREGION \DSPUNTRANSFORMY
\DSPUNTRANSFORMX \OFFSETCLIPPINGREGION)
(DECLARE: DONTCOPY (EXPORT (MACROS \DSPTRANSFORMX \DSPTRANSFORMY \OFFSETBOTTOM
\OFFSETLEFT]
[COMS (* screen related functions)
(FNS UPDATESCREENWIDTH SCREENRASTERWIDTH \CreateScreenBitMap)
(DECLARE: DONTEVAL@LOAD DOCOPY (P (UPDATESCREENWIDTH))
(VARS (SCREENHEIGHT 808)
(\MaxScreenPage -1)
(ScreenBitMap (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT]
(COMS (* initialization)
(INITVARS (LastCreatedDisplayDevice))
(FNS \CoerceToDisplayDevice \CREATEDISPLAY DISPLAYSTREAMINIT \STARTDISPLAY \STOPDISPLAY)
(EXPORT (GLOBALVARS \DisplayStarted \DisplayStreamsInitialized \DisplayInitialed
WHOLEDISPLAY WHOLESCREEN))
(ADDVARS (GLOBALVARS WHOLESCREEN))
(DECLARE: DONTEVAL@LOAD DOCOPY (VARS (\DisplayStarted NIL)
(\LastTTYLines 12)))
(EXPORT (MACROS DISPLAYINITIALIZEDP DISPLAYSTARTEDP))
(FNS INITIALIZEDISPLAYSTREAMS)
(DECLARE: DOCOPY DONTEVAL@LOAD (P (INITIALIZEDISPLAYSTREAMS)
(DISPLAYSTREAMINIT 1000])
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
[DECLARE: EVAL@COMPILE
(DATATYPE PILOTBBT ((PBTDESTLO WORD)
(PBTDESTHI WORD)
(PBTDESTBIT WORD) (* Destination bit address)
(PBTDESTBPL SIGNEDWORD) (* Destination bits per line -- distance in bits to
move between items)
(PBTSOURCELO WORD)
(PBTSOURCEHI WORD)
(PBTSOURCEBIT WORD) (* Source bit address)
(PBTSOURCEBPL SIGNEDWORD) (* Source bits per line)
(PBTWIDTH WORD) (* Width of an item in bits)
(PBTHEIGHT WORD) (* Number of items -- height in scanlines)
(PBTFLAGS WORD)
(NIL 5 WORD) (* Unused, needed to make 16-alignment)
)
(BLOCKRECORD PILOTBBT ((NIL 7 WORD)
(NIL BITS 4) (* Overlay on PBTSOURCEBPL when PBTUSEGRAY)
(PBTGRAYOFFSET BITS 4) (* Offset in gray block where BITBLT should start)
(PBTGRAYWIDTHLESSONE BITS 4)
(* Width-1 of gray block in words)
(PBTGRAYHEIGHTLESSONE BITS 4)
(* Height-1 of gray block)
(NIL 2 WORD) (* Overlay on PBTFLAGS ...)
(PBTBACKWARD FLAG)
(PBTDISJOINT FLAG)
(PBTDISJOINTITEMS FLAG)
(PBTUSEGRAY FLAG)
(PBTSOURCETYPE BITS 1)
(PBTOPERATION BITS 2)
(NIL BITS 9)))
[ACCESSFNS PILOTBBT ([PBTSOURCE (\VAG2 (fetch PBTSOURCEHI of DATUM)
(fetch PBTSOURCELO of DATUM))
(PROGN (replace PBTSOURCEHI of DATUM
with (\HILOC NEWVALUE))
(replace PBTSOURCELO of DATUM
with (\LOLOC NEWVALUE]
(PBTDEST (\VAG2 (fetch PBTDESTHI of DATUM)
(fetch PBTDESTLO of DATUM))
(PROGN (replace PBTDESTHI of DATUM with (\HILOC NEWVALUE))
(replace PBTDESTLO of DATUM with (\LOLOC NEWVALUE]
(SYSTEM))
(DATATYPE \DISPLAYDATA (DDXPOSITION DDYPOSITION DDXOFFSET DDYOFFSET DDDestination DDClippingRegion
DDFONT DDSlowPrintingCase DDWIDTHSCACHE
(* array of the distance to be moved in X when each
character is printed.)
DDOFFSETSCACHE DDCOLOR DDLINEFEED DDRightMargin DDLeftMargin
DDScroll DDOPERATION DDSOURCETYPE (DDClippingLeft WORD)
(DDClippingRight WORD)
(DDClippingBottom WORD)
(DDClippingTop WORD)
(DDobsoletefield WORD) (* this used to be the DDtexture field and was left in
so that world doesn't have to be recompiled)
(DDHELDFLG FLAG)
(XWINDOWHINT XPOINTER)
(DDPILOTBBT POINTER)
DDXSCALE DDYSCALE DDCHARIMAGEWIDTHS
(* array of image widths for each character)
DDEOLFN DDPAGEFULLFN DDTexture DDMICAXPOS DDMICAYPOS
DDMICARIGHTMARGIN)
DDPILOTBBT ←(create PILOTBBT
PBTDISJOINT ← T)
DDLeftMargin ← 0 DDRightMargin ← SCREENWIDTH DDXPOSITION ← 0 DDYPOSITION ← 0
DDXOFFSET ← 0 DDYOFFSET ← 0 DDClippingRegion ←(create REGION)
DDDestination ←(SCREENBITMAP)
DDXSCALE ← 1 DDYSCALE ← 1 DDTexture ← 0
[ACCESSFNS ((DDFOREGROUNDCOLOR (OR (CAR (fetch (\DISPLAYDATA DDCOLOR)
of DATUM))
BLACKCOLOR))
(DDBACKGROUNDCOLOR (OR (CDR (fetch (\DISPLAYDATA DDCOLOR)
of DATUM))
WHITECOLOR]
(SYSTEM))
(RECORD DISPLAYSTATE (RUNNING?))
]
(/DECLAREDATATYPE (QUOTE PILOTBBT)
(QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD
WORD WORD WORD WORD)))
(/DECLAREDATATYPE (QUOTE \DISPLAYDATA)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
WORD WORD WORD WORD WORD FLAG XPOINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER)))
(DECLARE: EVAL@COMPILE
(PUTPROPS \GETDISPLAYDATA MACRO [ARGS (COND
[(CADR ARGS)
(SUBPAIR (QUOTE (STRM STRMVAR))
ARGS
(QUOTE (\DTEST (fetch IMAGEDATA
of (SETQ STRMVAR (\OUTSTREAMARG
STRM)))
(QUOTE \DISPLAYDATA]
(T (SUBST (CAR ARGS)
(QUOTE STRM)
(QUOTE (\DTEST (fetch IMAGEDATA
of (\OUTSTREAMARG STRM))
(QUOTE \DISPLAYDATA])
)
(* END EXPORTED DEFINITIONS)
)
(* User-visible records are on ADISPLAY - must be init'ed here)
(/DECLAREDATATYPE (QUOTE BITMAP)
(QUOTE (POINTER WORD WORD WORD WORD)))
(/DECLAREDATATYPE (QUOTE PILOTBBT)
(QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD
WORD WORD WORD WORD)))
(/DECLAREDATATYPE (QUOTE \DISPLAYDATA)
(QUOTE (POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER POINTER
WORD WORD WORD WORD WORD FLAG XPOINTER POINTER POINTER POINTER
POINTER POINTER POINTER POINTER POINTER POINTER POINTER)))
(* BITMASKS)
(DEFINEQ
(\FBITMAPBIT
[LAMBDA (BASE X Y OPERATION HEIGHTMINUS1 RASTERWIDTH) (* rmk: " 2-APR-82 00:09")
(* fast version of stuffing a bit into a bitmap.)
(change [fetch (BITMAPWORD BITS) of (\ADDBASE BASE (IPLUS (ITIMES (IDIFFERENCE HEIGHTMINUS1 Y)
RASTERWIDTH)
(LRSH X 4]
(SELECTQ OPERATION
(INVERT (LOGXOR DATUM (\BITMASK X)))
(ERASE (LOGAND DATUM (\NOTBITMASK X)))
(LOGOR DATUM (\BITMASK X])
(\NEWPAGE.DISPLAY
[LAMBDA (STREAM) (* hdj "10-Dec-84 12:31")
(DSPRESET STREAM])
(INITBITMASKS
[LAMBDA NIL (* rrb "24-SEP-82 15:13")
(* initialization of bit masks for line drawing routines. BITMASK is an array of single bit masks;
NOTBITMASK is an array of masks for getting everything except the nth bit.)
(SETQ BITMASKARRAY (ARRAY 16 (QUOTE SMALLPOSP)
0 0))
(SETQ NOTBITMASKARRAY (ARRAY 16 (QUOTE SMALLPOSP)
0 0))
(for I from 0 to 15 bind (MASK ←(CONSTANT (EXPT 2 15))) do (SETA BITMASKARRAY I MASK)
(SETA NOTBITMASKARRAY I
(LOGXOR MASK WORDMASK))
(SETQ MASK (LRSH MASK 1)))
(SETQ 4BITMASKARRAY (ARRAY 4 (QUOTE SMALLPOSP)
0 0))
(SETQ NOT4BITMASKARRAY (ARRAY 4 (QUOTE SMALLPOSP)
0 0))
(for I from 0 to 3 bind [MASK ←(CONSTANT (IDIFFERENCE (EXPT 2 16)
(EXPT 2 12]
do (SETA 4BITMASKARRAY I MASK)
(SETA NOT4BITMASKARRAY I (LOGXOR MASK WORDMASK))
(SETQ MASK (LRSH MASK 4])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \BITMASK MACRO ((N)
(\WORDELT BITMASKARRAY (LOGAND N 15))))
(PUTPROPS \4BITMASK MACRO ((N)
(\WORDELT 4BITMASKARRAY (LOGAND N 3))))
(PUTPROPS \NOTBITMASK MACRO ((N)
(DECLARE (GLOBALVARS NOTBITMASKARRAY))
(\WORDELT NOTBITMASKARRAY (LOGAND N 15))))
(PUTPROPS \NOT4BITMASK MACRO ((N)
(\WORDELT NOT4BITMASKARRAY (LOGAND N 3))))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS BITMASKARRAY NOTBITMASKARRAY 4BITMASKARRAY NOT4BITMASKARRAY)
)
(DECLARE: EVAL@COMPILE
(RPAQQ WORDMASK 65535)
(CONSTANTS (WORDMASK 65535))
)
)
(* END EXPORTED DEFINITIONS)
(DECLARE: DONTEVAL@LOAD DOCOPY
(INITBITMASKS)
)
(* init cursor)
(DEFINEQ
(\CreateCursorBitMap
[LAMBDA NIL (* lmm "13-MAY-82 00:24")
(* creates a BITMAP which points at the cursor bits.)
(* pointer to cursor is stored using hiloc and loloc rather that BITMAPBASE so that it won't be reference counted.
It is on an odd boundary.)
(create BITMAP
BITMAPRASTERWIDTH ← 1
BITMAPWIDTH ← 20Q
BITMAPHEIGHT ← 20Q
BITMAPBASE ← \EM.CURSORBITMAP])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQ CursorBitMap (\CreateCursorBitMap))
)
(* bitmap functions.)
(DEFINEQ
(BITBLT
[LAMBDA (SOURCE SOURCELEFT SOURCEBOTTOM DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT
SOURCETYPE OPERATION TEXTURE CLIPPINGREGION)
(* hdj "21-Feb-85 10:46")
(DECLARE (LOCALVARS . T))
(COND
[(EQ SOURCETYPE (QUOTE TEXTURE))
(COND
((type? BITMAP DESTINATION)
(\BLTSHADE.BITMAP TEXTURE DESTINATION (OR DESTINATIONLEFT 0)
(OR DESTINATIONBOTTOM 0)
WIDTH HEIGHT OPERATION CLIPPINGREGION))
(T (PROG ((STREAM (\OUTSTREAMARG DESTINATION)))
(RETURN (IMAGEOP (QUOTE IMBLTSHADE)
STREAM TEXTURE STREAM (OR DESTINATIONLEFT 0)
(OR DESTINATIONBOTTOM 0)
WIDTH HEIGHT OPERATION CLIPPINGREGION]
(T (PROG (SOURCEDD SOURCEBM CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM)
[COND
[(type? BITMAP SOURCE)
(OR SOURCELEFT (SETQ SOURCELEFT 0))
(OR SOURCEBOTTOM (SETQ SOURCEBOTTOM 0))
(SETQ SOURCEBM SOURCE)
(SETQ CLIPPEDSOURCELEFT SOURCELEFT)
(SETQ CLIPPEDSOURCEBOTTOM SOURCEBOTTOM) (* limit the WIDTH and HEIGHT to the source size.)
[SETQ WIDTH (COND
(WIDTH (IMIN WIDTH (IDIFFERENCE (\PIXELOFBITADDRESS (fetch (BITMAP
BITMAPBITSPERPIXEL)
of SOURCEBM)
(fetch BITMAPWIDTH
of SOURCE))
SOURCELEFT)))
(T (\PIXELOFBITADDRESS (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBM)
(fetch BITMAPWIDTH of SOURCE]
(SETQ HEIGHT (COND
(HEIGHT (IMIN HEIGHT (IDIFFERENCE (fetch BITMAPHEIGHT of SOURCE)
SOURCEBOTTOM)))
(T (fetch BITMAPHEIGHT of SOURCE]
((SETQ SOURCEDD (\GETDISPLAYDATA SOURCE))
[OR SOURCELEFT (SETQ SOURCELEFT (fetch (REGION LEFT) of (ffetch DDClippingRegion
of SOURCEDD]
[OR SOURCEBOTTOM (SETQ SOURCEBOTTOM (fetch (REGION BOTTOM)
of (ffetch DDClippingRegion of SOURCEDD]
(* do transformations coming out of source)
(SETQ SOURCEBM (fetch DDDestination of SOURCEDD))
(SETQ CLIPPEDSOURCELEFT (IMAX (SETQ SOURCELEFT (\DSPTRANSFORMX SOURCELEFT SOURCEDD)
)
(fetch DDClippingLeft of SOURCEDD)))
(SETQ CLIPPEDSOURCEBOTTOM (IMAX (SETQ SOURCEBOTTOM (\DSPTRANSFORMY SOURCEBOTTOM
SOURCEDD))
(fetch DDClippingBottom of SOURCEDD)))
(* limit the WIDTH and HEIGHT by the source
dimensions.)
[SETQ WIDTH (COND
(WIDTH (IMIN WIDTH (IDIFFERENCE (fetch DDClippingRight of SOURCEDD)
CLIPPEDSOURCELEFT)))
(T (IDIFFERENCE (fetch DDClippingRight of SOURCEDD)
CLIPPEDSOURCELEFT]
[SETQ HEIGHT (COND
(HEIGHT (IMIN HEIGHT (IDIFFERENCE (fetch DDClippingTop of SOURCEDD)
CLIPPEDSOURCEBOTTOM)))
(T (IDIFFERENCE (fetch DDClippingTop of SOURCEDD)
CLIPPEDSOURCEBOTTOM]
(* if texture is not given, use the display stream's.)
(OR TEXTURE (SETQ TEXTURE (ffetch DDTexture of SOURCEDD]
(RETURN (COND
((type? BITMAP DESTINATION)
(\BITBLT.BITMAP SOURCEBM SOURCELEFT SOURCEBOTTOM DESTINATION
(OR DESTINATIONLEFT 0)
(OR DESTINATIONBOTTOM 0)
WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION
CLIPPEDSOURCELEFT CLIPPEDSOURCEBOTTOM))
(T (PROG ((STREAM (\OUTSTREAMARG DESTINATION)))
(RETURN (IMAGEOP (QUOTE IMBITBLT)
STREAM SOURCEBM SOURCELEFT SOURCEBOTTOM STREAM
(OR DESTINATIONLEFT 0)
(OR DESTINATIONBOTTOM 0)
WIDTH HEIGHT SOURCETYPE OPERATION TEXTURE
CLIPPINGREGION CLIPPEDSOURCELEFT
CLIPPEDSOURCEBOTTOM])
(BLTSHADE
[LAMBDA (TEXTURE DESTINATION DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION
CLIPPINGREGION) (* rmk: "22-Jun-84 16:43")
(DECLARE (LOCALVARS . T))
(COND
((type? BITMAP DESTINATION)
(\BLTSHADE.BITMAP TEXTURE DESTINATION (OR DESTINATIONLEFT 0)
(OR DESTINATIONBOTTOM 0)
WIDTH HEIGHT OPERATION CLIPPINGREGION))
(T (PROG ((STREAM (\OUTSTREAMARG DESTINATION)))
(RETURN (IMAGEOP (QUOTE IMBLTSHADE)
STREAM TEXTURE STREAM (OR DESTINATIONLEFT 0)
(OR DESTINATIONBOTTOM 0)
WIDTH HEIGHT OPERATION CLIPPINGREGION])
(\BITBLTSUB
[LAMBDA (PILOTBBT SourceBitMap SLX STY DestinationBitMap DLX DTY HEIGHT SourceType Operation
Texture) (* bvm: "14-Feb-85 00:44")
(PROG ((DBMR (fetch BITMAPRASTERWIDTH of DestinationBitMap))
SBMR GRAY SOURCEADDR DESTADDR X)
(replace PBTFLAGS of PILOTBBT with 0)
(replace PBTDESTBPL of PILOTBBT with (UNFOLD DBMR BITSPERWORD))
(SETQ DESTADDR (\ADDBASE (fetch BITMAPBASE of DestinationBitMap)
(ITIMES DBMR DTY))) (* Combine Destination base and top Y into a single
Destination word offset)
(replace PBTDESTBIT of PILOTBBT with DLX)
(SELECTQ SourceType
[TEXTURE (replace PBTUSEGRAY of PILOTBBT with T)
(replace PBTSOURCEBIT of PILOTBBT with (MOD DLX BITSPERWORD))
(* Source is offset in a gray block where we want to start. Microcode finds the start of the gray block by
subtracting PBTGRAYOFFSET from it)
(replace PBTSOURCEBPL of PILOTBBT with 0)
(* Zero out this word first)
(COND
[(FIXP Texture)
(SETQ GRAY (fetch BITMAPBASE of \SYSBBTEXTURE))
(replace PBTSOURCE of PILOTBBT
with (\ADDBASE GRAY
(COND
((OR (EQ (SETQ Texture (LOGAND Texture WORDMASK))
0)
(EQ Texture BLACKSHADE))
(* special cases of solid texture occur often)
(\PUTBASE GRAY 0 Texture)
(* PBTGRAYHEIGHTLESSONE and PBTGRAYOFFSET are both 0 in
this case)
0)
(T (\PUTBASE GRAY 0 (\SFReplicate (LRSH Texture
12)))
[\PUTBASE GRAY 1
(\SFReplicate (LOGAND 15
(LRSH Texture
8]
[\PUTBASE GRAY 2
(\SFReplicate (LOGAND 15
(LRSH Texture
4]
(\PUTBASE GRAY 3 (\SFReplicate (LOGAND 15
Texture)))
(replace PBTGRAYHEIGHTLESSONE of PILOTBBT
with 3)
(replace PBTGRAYOFFSET of PILOTBBT
with (MOD DTY 4]
(T (* A bitmap that is 16 bits wide.
BITBLT verified this back in interruptable section)
[replace PBTGRAYHEIGHTLESSONE of PILOTBBT
with (SUB1 (SETQ X (IMIN [ffetch BITMAPHEIGHT
of (SETQ Texture (\DTEST
Texture
(QUOTE BITMAP]
16]
(replace PBTGRAYOFFSET of PILOTBBT with (SETQ X (IREMAINDER DTY X)))
(replace PBTSOURCE of PILOTBBT with (\ADDBASE (ffetch BITMAPBASE
of Texture)
X]
(MERGE (RETURN (RAID "Hard bitblt case")))
(PROGN (* INPUT or INVERT)
(replace PBTUSEGRAY of PILOTBBT with NIL)
(replace PBTSOURCEBPL of PILOTBBT with (UNFOLD (SETQ SBMR
(fetch BITMAPRASTERWIDTH
of SourceBitMap))
BITSPERWORD))
(SETQ SOURCEADDR (\ADDBASE (fetch BITMAPBASE of SourceBitMap)
(ITIMES SBMR STY)))
(* Combine Source base and top Y into a single Source
word offset)
(replace PBTSOURCEBIT of PILOTBBT with SLX)
[COND
((NEQ SourceBitMap DestinationBitMap)
(* Assume distinct bitmaps do not overlap, i.e. that we
do not have sub-bitmaps)
(replace PBTDISJOINT of PILOTBBT with T))
[(IGREATERP STY DTY) (* Source > Dest means we can go top to bottom always)
(COND
((IGREATERP STY (IPLUS DTY HEIGHT))
(* Dest ends before source starts, so is completely
disjoint)
(replace PBTDISJOINT of PILOTBBT with T))
(T (* Not disjoint, but the items are disjoint)
(replace PBTDISJOINTITEMS of PILOTBBT with T]
((IGREATERP DTY (IPLUS STY HEIGHT))
(* Source ends before dest starts, so is completely
disjoint)
(replace PBTDISJOINT of PILOTBBT with T))
([OR (NEQ STY DTY)
(AND (ILESSP SLX DLX)
(ILESSP DLX (IPLUS SLX (fetch PBTWIDTH of PILOTBBT]
(* Not disjoint, with source above dest (bottom to top) or source and dest the same line with source to left of dest
(right to left))
(replace PBTBACKWARD of PILOTBBT with T)
(* What's more, the source and dest addresses are to be
of the LAST item, and bpl is negative)
(* note SBMR = DBMR if we have gotten this far)
[SETQ SOURCEADDR (\ADDBASE SOURCEADDR (SETQ X (ITIMES SBMR
(SUB1 HEIGHT]
(SETQ DESTADDR (\ADDBASE DESTADDR X))
[replace PBTSOURCEBPL of PILOTBBT with (SETQ X (IMINUS (UNFOLD SBMR
BITSPERWORD]
(replace PBTDESTBPL of PILOTBBT with X)
(COND
((NEQ STY DTY) (* At least the items are disjoint)
(replace PBTDISJOINTITEMS of PILOTBBT with T]
(replace PBTSOURCE of PILOTBBT with SOURCEADDR)))
(replace PBTDEST of PILOTBBT with DESTADDR)
(\SETPBTFUNCTION PILOTBBT SourceType Operation)
(RETURN (\PILOTBITBLT PILOTBBT 0])
(\GETPILOTBBTSCRATCHBM
[LAMBDA (WIDTH HEIGHT)
(DECLARE (GLOBALVARS \PILOTBBTSCRATCHBM)) (* bvm: "24-MAY-82 12:46")
(* Return a scratch bitmap at least WIDTH by HEIGHT.
Called only under uninterruptable bitblt, so don't worry
about global resource conflicts)
(COND
((AND (type? BITMAP \PILOTBBTSCRATCHBM)
(ILEQ WIDTH (fetch BITMAPWIDTH of \PILOTBBTSCRATCHBM))
(ILEQ HEIGHT (fetch BITMAPHEIGHT of \PILOTBBTSCRATCHBM)))
\PILOTBBTSCRATCHBM)
(T (SETQ \PILOTBBTSCRATCHBM (BITMAPCREATE WIDTH HEIGHT])
(BITMAPCOPY
[LAMBDA (BITMAP) (* rrb "22-DEC-82 11:09")
(* makes a copy of an existing BitMap)
(PROG (NEWBITMAP)
(BITBLT (SETQ BITMAP (\DTEST BITMAP (QUOTE BITMAP)))
0 0 (SETQ NEWBITMAP (BITMAPCREATE (BITMAPWIDTH BITMAP)
(ffetch BITMAPHEIGHT of BITMAP)
(ffetch BITMAPBITSPERPIXEL of BITMAP)))
0 0 NIL NIL (QUOTE INPUT)
(QUOTE REPLACE)
0)
(RETURN NEWBITMAP])
(BITMAPCREATE
[LAMBDA (WIDTH HEIGHT BITSPERPIXEL) (* rrb "21-DEC-82 17:12")
(* creates a bitmap data structure.)
(OR (AND (IGEQ WIDTH 0)
(ILEQ WIDTH \MaxBitMapWidth))
(\ILLEGAL.ARG WIDTH))
(OR (AND (IGEQ HEIGHT 0)
(ILEQ HEIGHT \MaxBitMapHeight))
(\ILLEGAL.ARG HEIGHT))
(SELECTQ BITSPERPIXEL
((NIL 4 8 1))
(\ILLEGAL.ARG BITSPERPIXEL))
(PROG ((BPP (OR BITSPERPIXEL 1))
RW BITWIDTH)
(SETQ BITWIDTH (ITIMES WIDTH BPP))
(SETQ RW (FOLDHI BITWIDTH BITSPERWORD))
(RETURN (create BITMAP
BITMAPRASTERWIDTH ← RW
BITMAPWIDTH ← BITWIDTH
BITMAPHEIGHT ← HEIGHT
BITMAPBITSPERPIXEL ← BPP
BITMAPBASE ←(COND
((IGREATERP (SETQ RW (ITIMES RW HEIGHT))
\MaxBitMapWords)
(ERROR (ITIMES WIDTH HEIGHT)
"bits in BITMAP -- too big"))
(T (\ALLOCBLOCK (FOLDHI RW WORDSPERCELL)
NIL
(AND (NULL WINDFLG)
0])
(BITMAPBIT
[LAMBDA (BITMAP X Y NEWVALUE) (* bvm: "14-Feb-85 00:45")
(* reads and optionally sets a bit in a bitmap.
If bitmap is a displaystream, it works on the
destination through the coordinate transformations.)
(* version of BITMAPBIT that works for multiple bit per
pixel bitmaps.)
(PROG (NBITS BITX OLDVALUE oldword bitmapbase)
(RETURN
(COND
[(type? BITMAP BITMAP)
(SETQ NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP))
(COND
((OR (IGREATERP 0 X)
(IGEQ (SETQ BITX (ITIMES X NBITS))
(ffetch BITMAPWIDTH of BITMAP))
(IGREATERP 0 Y)
(IGEQ Y (ffetch BITMAPHEIGHT of BITMAP)))
(* all bitmaps are 0 outside)
0)
(T [SETQ bitmapbase (\ADDBASE (ffetch BITMAPBASE of BITMAP)
(IPLUS (ITIMES (SUB1 (\SFInvert BITMAP Y))
(ffetch BITMAPRASTERWIDTH
of BITMAP))
(FOLDLO BITX BITSPERWORD]
(SELECTQ NBITS
(1 (COND
((EQ (LOGAND (SETQ oldword (\GETBASE bitmapbase 0))
(SETQ BITX (\BITMASK X)))
0) (* old value was 0)
[COND
((AND NEWVALUE (NEQ NEWVALUE 0))
(* change value Since old value is 0, ok to OR.)
(\PUTBASE bitmapbase 0 (LOGOR oldword BITX]
0)
(T (* old value was 1)
[COND
((AND NEWVALUE (EQ NEWVALUE 0))
(* change, use XOR since old value is 1)
(\PUTBASE bitmapbase 0 (LOGXOR oldword BITX]
1)))
[4 (* take the color cursor down before the old word value
is fetched. NIL)
[COND
(NEWVALUE (* check NEWVALUE before going uninterruptable.)
(COND
((NOT (AND (SMALLPOSP NEWVALUE)
(ILESSP NEWVALUE 16)))
(\ILLEGAL.ARG NEWVALUE]
[.WHILE.TOP.IF.DS.
NIL T (SETQ OLDVALUE (LOGAND (SETQ oldword (\GETBASE bitmapbase 0))
(\4BITMASK X)))
(AND NEWVALUE (\PUTBASE bitmapbase 0
(LOGOR (LOGXOR oldword OLDVALUE)
(LLSH NEWVALUE
(ITIMES 4
(IDIFFERENCE
3
(LOGAND X 3]
(* move the 4 bit current value to the right most
bits.)
(LRSH OLDVALUE (ITIMES 4 (IDIFFERENCE 3 (LOGAND X 3]
(8 (* take down cursor before returning the value of the
bit.)
[COND
(NEWVALUE (* check NEWVALUE before going uninterruptable.)
(COND
((NOT (AND (SMALLPOSP NEWVALUE)
(ILESSP NEWVALUE 256)))
(\ILLEGAL.ARG NEWVALUE]
[.WHILE.TOP.IF.DS. NIL T
(COND
((EQ (LOGAND X 1)
0)
(* left half of word)
(SETQ OLDVALUE (LOGAND (SETQ oldword
(\GETBASE bitmapbase
0))
65280))
[AND NEWVALUE (\PUTBASE bitmapbase 0
(LOGOR (LOGXOR
oldword
OLDVALUE)
(LLSH NEWVALUE
8]
(SETQ OLDVALUE (LRSH OLDVALUE 8)))
(T (* right half of word)
(SETQ OLDVALUE (LOGAND (SETQ oldword
(\GETBASE
bitmapbase 0))
255))
(AND NEWVALUE
(\PUTBASE bitmapbase 0
(LOGOR (LOGXOR oldword
OLDVALUE)
NEWVALUE]
OLDVALUE)
(ERROR "unknown bits per pixel size." NBITS]
(T (PROG (TX TY (DD (\GETDISPLAYDATA BITMAP BITMAP)))
(SETQ TX (\DSPCLIPTRANSFORMX X DD))
(SETQ TY (\DSPCLIPTRANSFORMY Y DD))
(RETURN (COND
((AND TX TY)
(\INSURETOPWDS BITMAP)
(* We try to handle the slow case while we are still interruptable, but we do it again just in case the user got
us.)
(.WHILE.TOP.DS. BITMAP (SETQ TX (BITMAPBIT (fetch DDDestination
of DD)
TX TY NEWVALUE)))
TX)
(T (* anything outside the clipping region returns 0.0)
0])
(BLTCHAR
[LAMBDA (CHARCODE DISPLAYSTREAM) (* rrb " 4-NOV-83 10:44")
(* user entry -
seldom used)
(* puts a character on a display stream. Much of the information needed by the BitBlt microcode is prestored by
the routines that change it. This is kept in the BitBltTable.)
(\BLTCHAR CHARCODE DISPLAYSTREAM (\GETDISPLAYDATA DISPLAYSTREAM])
(\BLTCHAR
[LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* rrb " 9-Jan-84 19:17")
(* puts a character on a display stream. Much of the information needed by the BitBlt microcode is prestored by
the routines that change it. This is kept in the BitBltTable.)
(* knows about the representation of a DisplayStream.)
(DECLARE (LOCALVARS . T))
(PROG (LOCAL1 RIGHT LEFT CURX)
[COND
((ffetch (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA)
(RETURN (\SLOWBLTCHAR CHARCODE DISPLAYSTREAM]
CRLP[COND
((IGREATERP (SETQ RIGHT (IPLUS (SETQ CURX (ffetch DDXPOSITION of DISPLAYDATA))
(\DSPGETCHARWIDTH CHARCODE DISPLAYDATA)))
(ffetch DDRightMargin of DISPLAYDATA))
(* would go past right margin, force a cr)
(COND
((IGREATERP CURX (ffetch DDLeftMargin of DISPLAYDATA))
(* don't bother CR if position is at left margin anyway.
This also serves to break the loop.)
(\DSPPRINTCR/LF (CHARCODE EOL)
DISPLAYSTREAM) (* reuse the code in the test of this conditional rather
than repeat it here.)
(GO CRLP] (* update the display stream x position.)
(freplace DDXPOSITION of DISPLAYDATA with RIGHT) (* transforms an x coordinate into the destination
coordinate.)
[SETQ CURX (IPLUS CURX (SETQ LOCAL1 (ffetch DDXOFFSET of DISPLAYDATA]
(SETQ RIGHT (IPLUS RIGHT LOCAL1))
(COND
((IGREATERP RIGHT (SETQ LOCAL1 (ffetch DDClippingRight of DISPLAYDATA)))
(* character overlaps right edge of clipping region.)
(SETQ RIGHT LOCAL1)))
(SETQ LEFT (COND
((IGREATERP CURX (SETQ LOCAL1 (ffetch DDClippingLeft of DISPLAYDATA)))
CURX)
(T LOCAL1)))
(RETURN (COND
((AND (ILESSP LEFT RIGHT)
(NEQ (fetch PBTHEIGHT of (SETQ LOCAL1 (ffetch DDPILOTBBT of DISPLAYDATA)))
0))
(.WHILE.TOP.DS. DISPLAYSTREAM (freplace PBTDESTBIT of LOCAL1 with LEFT)
(freplace PBTWIDTH of LOCAL1 with (IDIFFERENCE RIGHT LEFT))
(freplace PBTSOURCEBIT of LOCAL1
with (IDIFFERENCE (IPLUS (\DSPGETCHAROFFSET CHARCODE
DISPLAYDATA)
LEFT)
CURX))
(\PILOTBITBLT LOCAL1 0))
T])
(\SLOWBLTCHAR
[LAMBDA (CHARCODE DISPLAYSTREAM) (* rrb "24-Dec-83 10:56")
(* case of BLTCHAR where either font is rotated or
destination is a color bitmap.
DISPLAYSTREAM is known to be a display stream.)
(PROG (ROTATION (DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of (fetch DDFONT of DD)))
(RETURN
(COND
[(EQ 0 ROTATION)
(PROG (NEWX LEFT RIGHT (CURX (ffetch DDXPOSITION of DD)))
[COND
((IGREATERP (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHARCODE DD)))
(ffetch DDRightMargin of DD))
(* past RIGHT margin, force eol)
(\DSPPRINTCR/LF (CHARCODE EOL)
DISPLAYSTREAM)
(SETQ CURX (ffetch DDXPOSITION of DD))
(SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHARCODE DD]
(* update the x position.)
(freplace DDXPOSITION of DD with NEWX)
(SETQ CURX (\DSPTRANSFORMX CURX DD))
(SETQ LEFT (IMAX (ffetch DDClippingLeft of DD)
CURX))
(SETQ RIGHT (IMIN (ffetch DDClippingRight of DD)
(\DSPTRANSFORMX NEWX DD)))
(RETURN (COND
((AND (ILESSP LEFT RIGHT)
(NEQ (fetch PBTHEIGHT of (SETQ NEWX (ffetch DDPILOTBBT
of DD)))
0))
(SELECTQ (fetch (BITMAP BITMAPBITSPERPIXEL)
of (ffetch (\DISPLAYDATA DDDestination) of DD))
(1 (.WHILE.TOP.DS. DISPLAYSTREAM
(freplace PBTDESTBIT of NEWX
with LEFT)
(freplace PBTWIDTH of NEWX
with (IDIFFERENCE RIGHT LEFT))
(freplace PBTSOURCEBIT of NEWX
with (IDIFFERENCE
(IPLUS (\DSPGETCHAROFFSET
CHARCODE DD)
LEFT)
CURX))
(\PILOTBITBLT NEWX 0)))
(4 (OR (\DDHASFONT DD)
(\DDSETCOLORFONT DISPLAYSTREAM))
(.WHILE.TOP.DS.
DISPLAYSTREAM
(freplace PBTDESTBIT of NEWX
with (SETQ LEFT (LLSH LEFT 2)))
(freplace PBTWIDTH of NEWX
with (IDIFFERENCE (LLSH RIGHT 2)
LEFT))
(freplace PBTSOURCEBIT of NEWX
with (IDIFFERENCE (IPLUS (LLSH (\DSPGETCHAROFFSET
CHARCODE DD)
2)
LEFT)
(LLSH CURX 2)))
(\PILOTBITBLT NEWX 0)))
(8 (OR (\DDHASFONT DD)
(\DDSETCOLORFONT DISPLAYSTREAM))
(.WHILE.TOP.DS.
DISPLAYSTREAM
(freplace PBTDESTBIT of NEWX
with (SETQ LEFT (LLSH LEFT 3)))
(freplace PBTWIDTH of NEWX
with (IDIFFERENCE (LLSH RIGHT 3)
LEFT))
(freplace PBTSOURCEBIT of NEWX
with (IDIFFERENCE (IPLUS (LLSH (\DSPGETCHAROFFSET
CHARCODE DD)
3)
LEFT)
(LLSH CURX 3)))
(\PILOTBITBLT NEWX 0)))
(SHOULDNT))
T]
(T (* handle rotated fonts)
(PROG ((YPOS (ffetch DDYPOSITION of DD))
(HEIGHTMOVED (\DSPGETCHARWIDTH CHARCODE DD))
(FONT (ffetch DDFONT of DD)))
(RETURN (COND
((EQ ROTATION 90) (* don't force CR for rotated fonts.)
(\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IPLUS YPOS HEIGHTMOVED))
(* update the display stream x position.)
(BITBLT (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONT)
0
(\DSPGETCHAROFFSET CHARCODE DD)
DISPLAYSTREAM
(ADD1 (IDIFFERENCE (ffetch DDXPOSITION of DD)
(FONTASCENT FONT)))
YPOS
(FONTHEIGHT FONT)
HEIGHTMOVED))
((EQ ROTATION 270)
(\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE YPOS HEIGHTMOVED)
)
(BITBLT (fetch (FONTDESCRIPTOR CHARACTERBITMAP) of FONT)
0
(\DSPGETCHAROFFSET CHARCODE DD)
DISPLAYSTREAM
(IDIFFERENCE (ffetch DDXPOSITION of DD)
(FONTDESCENT FONT))
(ffetch DDYPOSITION of DISPLAYSTREAM)
(FONTHEIGHT FONT)
HEIGHTMOVED))
(T (ERROR "Not implemented to rotate by other than 0, 90 or 270"])
(TEXTUREP
[LAMBDA (OBJECT) (* bvm: "26-MAY-82 17:51")
(OR (FIXP OBJECT)
(AND (type? BITMAP OBJECT)
(EQ (fetch BITMAPRASTERWIDTH of OBJECT)
1)
OBJECT])
(INVERT.TEXTURE
[LAMBDA (TEXTURE SCRATCHBM) (* bvm: "31-MAY-82 14:41")
(COND
((FIXP TEXTURE)
(LOGXOR (LOGAND TEXTURE BLACKSHADE)
BLACKSHADE))
(T (INVERT.TEXTURE.BITMAP TEXTURE SCRATCHBM])
(INVERT.TEXTURE.BITMAP
[LAMBDA (BM SCRATCHBM) (* edited: "15-SEP-82 09:17")
(* Returns a bitmap that is the complement of BM. If SCRATCHBM is supplied, then does it to SCRATCHBM, else
creates and returns a new bitmap)
(COND
((NEQ (fetch BITMAPRASTERWIDTH of BM)
1)
(\ILLEGAL.ARG BM)))
(PROG [(NEWBM (COND
((type? BITMAP SCRATCHBM)
(COND
((OR (NEQ (fetch BITMAPRASTERWIDTH of SCRATCHBM)
1)
(IGREATERP (fetch BITMAPHEIGHT of BM)
(fetch BITMAPHEIGHT of SCRATCHBM)))
(\ILLEGAL.ARG SCRATCHBM)))
SCRATCHBM)
(T (BITMAPCREATE BITSPERWORD (fetch BITMAPHEIGHT of BM]
(bind (BASE1 ←(fetch BITMAPBASE of BM))
(LASTBASE ←(\ADDBASE (fetch BITMAPBASE of NEWBM)
(fetch BITMAPHEIGHT of BM)))
for (BASE2 ←(fetch BITMAPBASE of NEWBM)) by (\ADDBASE BASE2 1) until (EQ BASE2 LASTBASE)
do (\PUTBASE BASE2 0 (LOGXOR (\GETBASE BASE1 0)
WORDMASK))
(SETQ BASE1 (\ADDBASE BASE1 1)))
(RETURN NEWBM])
(BITMAPWIDTH
[LAMBDA (BM) (* hdj "14-Dec-84 14:52")
(* returns the width of a bitmap in pixels)
(COND
((type? BITMAP BM)
(SELECTQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BM)
(1 (ffetch (BITMAP BITMAPWIDTH) of BM))
(4 (FOLDLO (ffetch (BITMAP BITMAPWIDTH) of BM)
4))
(8 (FOLDLO (ffetch (BITMAP BITMAPWIDTH) of BM)
8))
(SHOULDNT)))
((WINDOWP BM) (* if it is a window, return the width of its
interior.)
(WINDOWPROP BM (QUOTE WIDTH)))
(T (\ILLEGAL.ARG BM])
(READBITMAP
(LAMBDA (FILE) (* rrb "10-NOV-83 15:11")
(* reads the a bitmap from the input file.)
(SKIPSEPRS FILE)
(OR (EQ (READC FILE)
(QUOTE %())
(ERROR "BAD FORMAT OF BITMAP IN FILE"))
(PROG (BASE BM W BITSPERPIXEL (WIDTH (RATOM FILE))
(HEIGHT (RATOM FILE))
(STRM (GETSTREAM FILE (QUOTE INPUT))))
(SETQ BITSPERPIXEL (COND
((EQ (SKIPSEPRS STRM)
(QUOTE %"))
1)
(T (* after height can come the bits per pixel.)
(RATOM FILE))))
(SETQ W (FOLDHI (ITIMES BITSPERPIXEL WIDTH)
BITSPERWORD))
(SETQ BM (BITMAPCREATE WIDTH HEIGHT BITSPERPIXEL))
(SETQ BASE (fetch BITMAPBASE of BM))
(COND
((OR (EQ WIDTH 0)
(EQ HEIGHT 0)))
((EQ (SKIPSEPRS STRM)
(QUOTE %"))
(FRPTQ HEIGHT (SKIPSEPRS STRM)
(OR (EQ (\BIN STRM)
(CHARCODE %"))
(GO BAD))
(FRPTQ W (\PUTBASEBYTE BASE 0 (LOGOR (LLSH (IDIFFERENCE (\BIN STRM)
(SUB1 (CHARCODE A)))
4)
(IDIFFERENCE (\BIN STRM)
(SUB1 (CHARCODE A)))))
(\PUTBASEBYTE BASE 1 (LOGOR (LLSH (IDIFFERENCE (\BIN STRM)
(SUB1 (CHARCODE A)))
4)
(IDIFFERENCE (\BIN STRM)
(SUB1 (CHARCODE A)))))
(SETQ BASE (\ADDBASE BASE 1)))
(OR (EQ (\BIN STRM)
(CHARCODE %"))
(GO BAD))))
(T (GO BAD)))
(SKIPSEPRS STRM)
(OR (EQ (\BIN STRM)
(CHARCODE %)))
(GO BAD))
(RETURN BM)
BAD (ERROR "BAD FORMAT OF BITMAP IN FILE"))))
)
(DEFINEQ
(\BITBLT.1BITDISPLAY
[LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH
HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT
CLIPPEDSOURCEBOTTOM) (* rmk: " 4-Dec-84 11:46")
(DECLARE (LOCALVARS . T))
(COND
((NEQ 1 (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP))
(* going from color map into black and white map.)
(ERROR "not implemented to blt between bitmaps of different pixel size.")))
(PROG (stodx stody left top bottom right DESTBITMAP (DESTDD (fetch IMAGEDATA of DESTSTRM)))
(SETQ DESTBITMAP (fetch DDDestination of DESTDD))
(SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD))
(SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD))
[PROGN (* compute limits based on clipping regions.)
(SETQ left (fetch DDClippingLeft of DESTDD))
(SETQ bottom (fetch DDClippingBottom of DESTDD))
(SETQ right (fetch DDClippingRight of DESTDD))
(SETQ top (fetch DDClippingTop of DESTDD))
(COND
(CLIPPINGREGION (* hard case, two destination clipping regions: do
calculations to merge them.)
(PROG (CRLEFT CRBOTTOM)
[SETQ left (IMAX left (SETQ CRLEFT
(\DSPTRANSFORMX (fetch LEFT of
CLIPPINGREGION)
DESTDD]
[SETQ bottom (IMAX bottom (SETQ CRBOTTOM
(\DSPTRANSFORMY (fetch BOTTOM
of CLIPPINGREGION)
DESTDD]
[SETQ right (IMIN right (IPLUS CRLEFT (fetch WIDTH
of CLIPPINGREGION]
(SETQ top (IMIN top (IPLUS CRBOTTOM (fetch HEIGHT
of CLIPPINGREGION]
(* left, right top and bottom are the limits in destination taking into account Clipping Regions.
Clip to region in the arguments of this call.)
[PROGN (SETQ left (IMAX DESTINATIONLEFT left))
(SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
[COND
(WIDTH (* WIDTH is optional)
(SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
right]
(COND
(HEIGHT (* HEIGHT is optional)
(SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
top] (* Clip and translate coordinates.)
(SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT))
(SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM))
(* compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be
moved with the limits of the region to be moved in the destination coordinates.)
[PROGN (* compute left margin)
(SETQ left (IMAX CLIPPEDSOURCELEFT (IDIFFERENCE left stodx)
0)) (* compute bottom margin)
(SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE bottom stody)
0))
[PROGN (* compute right margin)
(SETQ right (IMIN (ffetch BITMAPWIDTH of SOURCEBITMAP)
(IDIFFERENCE right stodx)
(IPLUS CLIPPEDSOURCELEFT WIDTH]
(PROGN (* compute top margin)
(SETQ top (IMIN (ffetch BITMAPHEIGHT of SOURCEBITMAP)
(IDIFFERENCE top stody)
(IPLUS CLIPPEDSOURCEBOTTOM HEIGHT]
(COND
((OR (ILEQ right left)
(ILEQ top bottom)) (* there is nothing to move.)
(RETURN)))
(OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD)))
(SELECTQ SOURCETYPE
[MERGE (* Need to use complement of TEXTURE)
(SETQ TEXTURE (COND
((NULL TEXTURE)
BLACKSHADE)
((FIXP TEXTURE)
(LOGXOR (LOGAND TEXTURE BLACKSHADE)
BLACKSHADE))
[(type? BITMAP TEXTURE)
(INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE
(SETQ \BBSCRATCHTEXTURE
(BITMAPCREATE 16 16]
(T (\ILLEGAL.ARG TEXTURE]
NIL)
(\INSURETOPWDS DESTSTRM)
(* We'd rather handle the slow case when we are interruptable, so we do it here as a heuristic.
But we might get interrupted before we go interruptable, so we do it there too.)
(UNINTERRUPTABLY
(\INSURETOPWDS DESTSTRM)
[PROG ([PILOTBBT (COND
((type? PILOTBBT \SYSPILOTBBT)
\SYSPILOTBBT)
(T (SETQ \SYSPILOTBBT (create PILOTBBT]
(HEIGHT (IDIFFERENCE top bottom))
(WIDTH (IDIFFERENCE right left))
(DTY (\SFInvert DESTBITMAP (IPLUS top stody)))
(DLX (IPLUS left stodx))
(STY (\SFInvert SOURCEBITMAP top))
(SLX left))
(replace PBTWIDTH of PILOTBBT with WIDTH)
(replace PBTHEIGHT of PILOTBBT with HEIGHT)
(COND
((EQ SOURCETYPE (QUOTE MERGE))
(\BITBLT.MERGE PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT
OPERATION TEXTURE))
(T (\BITBLTSUB PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT
SOURCETYPE OPERATION TEXTURE])
(RETURN T])
(\BITBLT.BITMAP
[LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH
HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT
CLIPPEDSOURCEBOTTOM) (* rmk: " 4-Dec-84 12:34")
(DECLARE (LOCALVARS . T))
(PROG (stodx stody right (top (fetch BITMAPHEIGHT of DESTBITMAP))
(DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTBITMAP))
(left 0)
(bottom 0)
(SOURCENBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP)))
(SETQ right (\PIXELOFBITADDRESS DESTINATIONNBITS (fetch BITMAPWIDTH of DESTBITMAP)))
[COND
(CLIPPINGREGION (* adjust limits)
(SETQ left (IMAX left (fetch LEFT of CLIPPINGREGION)))
(SETQ bottom (IMAX bottom (fetch BOTTOM of CLIPPINGREGION)))
[SETQ right (IMIN right (IPLUS (fetch WIDTH of CLIPPINGREGION)
(fetch LEFT of CLIPPINGREGION]
(SETQ top (IMIN top (IPLUS (fetch BOTTOM of CLIPPINGREGION)
(fetch HEIGHT of CLIPPINGREGION]
(* left, right top and bottom are the limits in destination taking into account Clipping Regions.
Clip to region in the arguments of this call.)
[PROGN (SETQ left (IMAX DESTINATIONLEFT left))
(SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
[COND
(WIDTH (* WIDTH is optional)
(SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
right]
(COND
(HEIGHT (* HEIGHT is optional)
(SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
top] (* Clip and translate coordinates.)
(SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT))
(SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM))
(* compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be
moved with the limits of the region to be moved in the destination coordinates.)
[PROGN (* compute left margin)
(SETQ left (IMAX CLIPPEDSOURCELEFT 0 (IDIFFERENCE left stodx)))
(* compute bottom margin)
(SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM 0 (IDIFFERENCE bottom stody)))
(* compute right margin)
(SETQ right (IMIN (\PIXELOFBITADDRESS SOURCENBITS (ffetch BITMAPWIDTH of
SOURCEBITMAP))
(IDIFFERENCE right stodx)
(IPLUS CLIPPEDSOURCELEFT WIDTH)))
(* compute top margin)
(SETQ top (IMIN (ffetch BITMAPHEIGHT of SOURCEBITMAP)
(IDIFFERENCE top stody)
(IPLUS CLIPPEDSOURCEBOTTOM HEIGHT]
(COND
((OR (ILEQ right left)
(ILEQ top bottom)) (* there is nothing to move.)
(RETURN)))
(SELECTQ SOURCETYPE
[MERGE (* Need to use complement of TEXTURE)
(* MAY NOT WORK FOR COLOR CASE.)
(SETQ TEXTURE (COND
((NULL TEXTURE)
BLACKSHADE)
((FIXP TEXTURE)
(LOGXOR (LOGAND TEXTURE BLACKSHADE)
BLACKSHADE))
((AND (NEQ DESTINATIONNBITS 1)
(COLORNUMBERP TEXTURE)))
[(type? BITMAP TEXTURE)
(INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE
(SETQ \BBSCRATCHTEXTURE
(BITMAPCREATE 16 16]
(T (\ILLEGAL.ARG TEXTURE]
NIL)
(COND
[(EQ SOURCENBITS DESTINATIONNBITS) (* going from one to another of the same size.)
(SELECTQ DESTINATIONNBITS
[4 (* use UNFOLD with constant value rather than multiple
because it compiles into opcodes.)
(SETQ left (UNFOLD left 4))
(SETQ right (UNFOLD right 4))
(SETQ stodx (UNFOLD stodx 4)) (* set texture if it will ever get looked at.)
(AND (EQ SOURCETYPE (QUOTE MERGE))
(SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS]
[8 (SETQ left (UNFOLD left 8)) (* 8)
(SETQ right (UNFOLD right 8))
(SETQ stodx (UNFOLD stodx 8))
(AND (EQ SOURCETYPE (QUOTE MERGE))
(SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS]
NIL) (* easy case of black and white bitmap into black and
white or color to color or texture filling.)
(UNINTERRUPTABLY
(AND (NEQ DESTINATIONNBITS 1)
\COLORCURSORBM
(\TAKEDOWNCOLORCURSOR)) (* this actually takes down the cursor whenever a
bitblt is done to any color bitmap.
Not optimal but works.)
[PROG ([PILOTBBT (COND
((type? PILOTBBT \SYSPILOTBBT)
\SYSPILOTBBT)
(T (SETQ \SYSPILOTBBT (create PILOTBBT]
(HEIGHT (IDIFFERENCE top bottom))
(WIDTH (IDIFFERENCE right left))
(DTY (\SFInvert DESTBITMAP (IPLUS top stody)))
(DLX (IPLUS left stodx))
(STY (\SFInvert SOURCEBITMAP top))
(SLX left))
(replace PBTWIDTH of PILOTBBT with WIDTH)
(replace PBTHEIGHT of PILOTBBT with HEIGHT)
(COND
((EQ SOURCETYPE (QUOTE MERGE))
(\BITBLT.MERGE PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH
HEIGHT OPERATION TEXTURE))
(T (\BITBLTSUB PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT
SOURCETYPE OPERATION TEXTURE]
(AND \COLORCURSORDOWN (\PUTUPCOLORCURSOR)))]
[(EQ SOURCENBITS 1) (* going from a black and white bitmap to a color map)
(AND SOURCETYPE (NEQ SOURCETYPE (QUOTE INPUT))
(ERROR "SourceType not implemented from B&W to color bitmaps." SOURCETYPE))
(PROG ((HEIGHT (IDIFFERENCE top bottom))
(WIDTH (IDIFFERENCE right left))
(DBOT (IPLUS bottom stody))
(DLFT (IPLUS left stodx)))
(SELECTQ OPERATION
((NIL REPLACE)
(\BWTOCOLORBLT SOURCEBITMAP left bottom DESTBITMAP DLFT DBOT WIDTH
HEIGHT WHITECOLOR BLACKCOLOR DESTINATIONNBITS))
(PAINT)
(INVERT)
(ERASE)
(SHOULDNT]
(T (* going from color map into black and white map.)
(ERROR "not implemented to blt between bitmaps of different pixel size.")))
(RETURN T])
(\BITBLT.COLORDISPLAY
[LAMBDA (SOURCEBITMAP SOURCELEFT SOURCEBOTTOM DESTSTRM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH
HEIGHT SOURCETYPE OPERATION TEXTURE CLIPPINGREGION CLIPPEDSOURCELEFT
CLIPPEDSOURCEBOTTOM) (* rmk: " 4-Dec-84 12:13")
(DECLARE (LOCALVARS . T))
(PROG (stodx stody left top bottom right DESTBITMAP DESTINATIONNBITS (SOURCENBITS
(fetch (BITMAP BITMAPBITSPERPIXEL) of SOURCEBITMAP))
(DESTDD (fetch IMAGEDATA of DESTSTRM)))
(SETQ DESTBITMAP (fetch DDDestination of DESTDD))
(SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD))
(SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD))
[PROGN (* compute limits based on clipping regions.)
(SETQ left (fetch DDClippingLeft of DESTDD))
(SETQ bottom (fetch DDClippingBottom of DESTDD))
(SETQ right (fetch DDClippingRight of DESTDD))
(SETQ top (fetch DDClippingTop of DESTDD))
(COND
(CLIPPINGREGION (* hard case, two destination clipping regions: do
calculations to merge them.)
(PROG (CRLEFT CRBOTTOM)
[SETQ left (IMAX left (SETQ CRLEFT
(\DSPTRANSFORMX (fetch LEFT of
CLIPPINGREGION)
DESTDD]
[SETQ bottom (IMAX bottom (SETQ CRBOTTOM
(\DSPTRANSFORMY (fetch BOTTOM
of CLIPPINGREGION)
DESTDD]
[SETQ right (IMIN right (IPLUS CRLEFT (fetch WIDTH
of CLIPPINGREGION]
(SETQ top (IMIN top (IPLUS CRBOTTOM (fetch HEIGHT
of CLIPPINGREGION]
(SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTBITMAP))
(* left, right top and bottom are the limits in destination taking into account Clipping Regions.
Clip to region in the arguments of this call.)
[PROGN (SETQ left (IMAX DESTINATIONLEFT left))
(SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
[COND
(WIDTH (* WIDTH is optional)
(SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
right]
(COND
(HEIGHT (* HEIGHT is optional)
(SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
top] (* Clip and translate coordinates.)
(SETQ stodx (IDIFFERENCE DESTINATIONLEFT SOURCELEFT))
(SETQ stody (IDIFFERENCE DESTINATIONBOTTOM SOURCEBOTTOM))
(* compute the source dimensions (left right bottom top) by intersecting the source bit map, the source area to be
moved with the limits of the region to be moved in the destination coordinates.)
[PROGN (* compute left margin)
(SETQ left (IMAX CLIPPEDSOURCELEFT (IDIFFERENCE left stodx)
0)) (* compute bottom margin)
(SETQ bottom (IMAX CLIPPEDSOURCEBOTTOM (IDIFFERENCE bottom stody)
0)) (* compute right margin)
(SETQ right (IMIN (\PIXELOFBITADDRESS SOURCENBITS (ffetch BITMAPWIDTH of
SOURCEBITMAP))
(IDIFFERENCE right stodx)
(IPLUS CLIPPEDSOURCELEFT WIDTH)))
(* compute top margin)
(SETQ top (IMIN (ffetch BITMAPHEIGHT of SOURCEBITMAP)
(IDIFFERENCE top stody)
(IPLUS CLIPPEDSOURCEBOTTOM HEIGHT]
(COND
((AND (IGREATERP right left)
(IGREATERP top bottom)))
(T (* there is nothing to move.)
(RETURN)))
(OR OPERATION (SETQ OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD)))
(SELECTQ SOURCETYPE
[MERGE (* Need to use complement of TEXTURE)
(* MAY NOT WORK FOR COLOR CASE.)
(SETQ TEXTURE (COND
((NOT TEXTURE)
BLACKSHADE)
((FIXP TEXTURE)
(LOGXOR (LOGAND TEXTURE BLACKSHADE)
BLACKSHADE))
((COLORNUMBERP TEXTURE))
[(type? BITMAP TEXTURE)
(BITMAP (INVERT.TEXTURE.BITMAP TEXTURE (OR \BBSCRATCHTEXTURE
(SETQ \BBSCRATCHTEXTURE
(BITMAPCREATE 16 16]
(T (\ILLEGAL.ARG TEXTURE]
NIL)
(\INSURETOPWDS DESTSTRM)
(* We'd rather handle the slow case when we are interruptable, so we do it here as a heuristic.
But we might get interrupted before we go interruptable, so we do it there too.)
(COND
[(EQ SOURCENBITS DESTINATIONNBITS) (* going from one to another of the same size.)
(* use LLSH with constant value rather than multiple
because it compiles into opcodes.)
[COND
((EQ DESTINATIONNBITS 4)
(SETQ left (LLSH left 2))
(SETQ right (LLSH right 2))
(SETQ stodx (LLSH stodx 2)))
(T (SETQ left (LLSH left 3))
(SETQ right (LLSH right 3))
(SETQ stodx (LLSH stodx 3] (* set texture if it will ever get looked at.)
(AND (EQ SOURCETYPE (QUOTE MERGE))
(SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS)))
(* easy case of color to color)
(.WHILE.TOP.IF.DS. DESTSTRM DESTINATIONNBITS
(* Just in case the user got in and screwed our window)
(PROG ([PILOTBBT (COND
((type? PILOTBBT \SYSPILOTBBT)
\SYSPILOTBBT)
(T (SETQ \SYSPILOTBBT (create PILOTBBT]
(HEIGHT (IDIFFERENCE top bottom))
(WIDTH (IDIFFERENCE right left))
(DTY (\SFInvert DESTBITMAP (IPLUS top stody)))
(DLX (IPLUS left stodx))
(STY (\SFInvert SOURCEBITMAP top))
(SLX left))
(replace PBTWIDTH of PILOTBBT with WIDTH)
(replace PBTHEIGHT of PILOTBBT with HEIGHT)
(COND
((EQ SOURCETYPE (QUOTE MERGE))
(\BITBLT.MERGE PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP
DLX DTY WIDTH HEIGHT OPERATION TEXTURE))
(T (\BITBLTSUB PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX
DTY HEIGHT SOURCETYPE OPERATION TEXTURE]
[(EQ SOURCENBITS 1) (* going from a black and white bitmap to a color map)
(AND SOURCETYPE (NEQ SOURCETYPE (QUOTE INPUT))
(ERROR "SourceType not implemented from B&W to color bitmaps." SOURCETYPE))
(PROG ((HEIGHT (IDIFFERENCE top bottom))
(WIDTH (IDIFFERENCE right left))
(DBOT (IPLUS bottom stody))
(DLFT (IPLUS left stodx)))
(SELECTQ OPERATION
((NIL REPLACE)
(\BWTOCOLORBLT SOURCEBITMAP left bottom DESTBITMAP DLFT DBOT WIDTH
HEIGHT (COLORNUMBERP (fetch (\DISPLAYDATA
DDBACKGROUNDCOLOR)
of DESTDD))
(COLORNUMBERP (fetch (\DISPLAYDATA DDFOREGROUNDCOLOR)
of DESTDD))
DESTINATIONNBITS))
(PAINT)
(INVERT)
(ERASE)
(SHOULDNT]
(T (* going from color map into black and white map.)
(ERROR "not implemented to blt between bitmaps of different pixel size.")))
(RETURN T])
(\BITBLT.MERGE
[LAMBDA (PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY WIDTH HEIGHT OPERATION TEXTURE)
(* rmk: "21-Jun-84 23:10")
(* Can't do MERGE in Pilot bitblt, so simulate by blting source to scratch bitmap, erasing bits not in Texture, then
blting scratch to ultimate destination. Note that TEXTURE has already been complemented above in preparation for
this)
(COND
((AND (EQ OPERATION (QUOTE REPLACE))
(NEQ SOURCEBITMAP DESTBITMAP)) (* Don't need a scratch bitmap, just do two blts)
(\BITBLTSUB PILOTBBT SOURCEBITMAP SLX STY DESTBITMAP DLX DTY HEIGHT (QUOTE INPUT)
(QUOTE REPLACE)) (* Blt the source, then erase bits that aren't in
TEXTURE)
(\BITBLTSUB PILOTBBT NIL NIL NIL DESTBITMAP DLX DTY HEIGHT (QUOTE TEXTURE)
(QUOTE ERASE)
TEXTURE))
(T (PROG (SCRATCH (SCRATCHLEFT (MOD DLX BITSPERWORD))
(SCRATCHTOP (MOD DTY 4)))
(SETQ SCRATCH (\GETPILOTBBTSCRATCHBM (IPLUS WIDTH SCRATCHLEFT)
(IPLUS HEIGHT SCRATCHTOP)))
(* Get scratch bm, slightly larger than WIDTH and
HEIGHT to allow texture to align)
(\BITBLTSUB PILOTBBT SOURCEBITMAP SLX STY SCRATCH SCRATCHLEFT SCRATCHTOP HEIGHT
(QUOTE INPUT)
(QUOTE REPLACE)) (* Blt source into scratch)
(\BITBLTSUB PILOTBBT NIL NIL NIL SCRATCH SCRATCHLEFT SCRATCHTOP HEIGHT (QUOTE TEXTURE)
(QUOTE ERASE)
TEXTURE) (* Erase what isn't in TEXTURE)
(* Finally do original operation using the merged
source)
(\BITBLTSUB PILOTBBT SCRATCH SCRATCHLEFT SCRATCHTOP DESTBITMAP DLX DTY HEIGHT
(QUOTE INPUT)
OPERATION])
(\BLTSHADE.1BITDISPLAY
[LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)
(* rmk: "22-Jun-84 17:11")
(* BLTSHADE to a stream with a 1-bit bitmap
destination)
(DECLARE (LOCALVARS . T))
(PROG (left top bottom right DESTINATIONBITMAP (DESTDD (fetch IMAGEDATA of STREAM)))
(SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD))
(SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD))
[PROGN (* compute limits based on clipping regions.)
(SETQ left (fetch DDClippingLeft of DESTDD))
(SETQ bottom (fetch DDClippingBottom of DESTDD))
(SETQ right (fetch DDClippingRight of DESTDD))
(SETQ top (fetch DDClippingTop of DESTDD))
(COND
(CLIPPINGREGION (* hard case, two destination clipping regions: do
calculations to merge them.)
(PROG (CRLEFT CRBOTTOM)
[SETQ left (IMAX left (SETQ CRLEFT
(\DSPTRANSFORMX (fetch LEFT of
CLIPPINGREGION)
DESTDD]
[SETQ bottom (IMAX bottom (SETQ CRBOTTOM
(\DSPTRANSFORMY (fetch BOTTOM
of CLIPPINGREGION)
DESTDD]
[SETQ right (IMIN right (IPLUS CRLEFT (fetch WIDTH
of CLIPPINGREGION]
(SETQ top (IMIN top (IPLUS CRBOTTOM (fetch HEIGHT
of CLIPPINGREGION]
(SETQ DESTINATIONBITMAP (fetch DDDestination of DESTDD))
(* left, right top and bottom are the limits in destination taking into account Clipping Regions.
Clip to region in the arguments of this call.)
[PROGN (SETQ left (IMAX DESTINATIONLEFT left))
(SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
[COND
(WIDTH (* WIDTH is optional)
(SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
right]
(COND
(HEIGHT (* HEIGHT is optional)
(SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
top]
(COND
((AND (IGREATERP right left)
(IGREATERP top bottom)))
(T (* there is nothing to move.)
(RETURN)))
(SELECTQ (TYPENAME TEXTURE)
[LITATOM (* includes NIL case)
(COND
((NULL TEXTURE) (* default texture to background texture.)
(SETQ TEXTURE (ffetch (\DISPLAYDATA DDTexture) of DESTDD)))
(T (\ILLEGAL.ARG TEXTURE]
((SMALLP FIXP)
(SETQ TEXTURE (LOGAND TEXTURE BLACKSHADE)))
(BITMAP NIL)
(\ILLEGAL.ARG TEXTURE))
(\INSURETOPWDS STREAM)
(* We'd rather handle the slow case when we are interruptable, so we do it here as a heuristic.
But we might get interrupted before we go interruptable, so we do it there too.)
(UNINTERRUPTABLY
(\INSURETOPWDS STREAM)
(PROG ([PILOTBBT (COND
((type? PILOTBBT \SYSPILOTBBT)
\SYSPILOTBBT)
(T (SETQ \SYSPILOTBBT (create PILOTBBT]
(HEIGHT (IDIFFERENCE top bottom)))
(replace PBTWIDTH of PILOTBBT with (IDIFFERENCE right left))
(replace PBTHEIGHT of PILOTBBT with HEIGHT)
(\BITBLTSUB PILOTBBT NIL left NIL DESTINATIONBITMAP left (\SFInvert
DESTINATIONBITMAP top)
HEIGHT
(QUOTE TEXTURE)
(OR OPERATION (ffetch (\DISPLAYDATA DDOPERATION) of DESTDD))
TEXTURE)))
(RETURN T])
(\BLTSHADE.BITMAP
[LAMBDA (TEXTURE DESTINATIONBITMAP DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION
CLIPPINGREGION) (* rmk: "22-Jun-84 17:09")
(DECLARE (LOCALVARS . T))
(PROG ((left 0)
(bottom 0)
(top (fetch BITMAPHEIGHT of DESTINATIONBITMAP))
(right (fetch BITMAPWIDTH of DESTINATIONBITMAP))
(DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of DESTINATIONBITMAP)))
[COND
((EQ DESTINATIONNBITS 1) (* DESTINATIONNBITS is NIL for the case of 1 bit per
pixel.)
(SETQ DESTINATIONNBITS NIL))
(T (* keep track of how many bits per pixel)
(SETQ right (\PIXELOFBITADDRESS DESTINATIONNBITS right]
[COND
(CLIPPINGREGION (* adjust limits)
(SETQ left (IMAX left (fetch LEFT of CLIPPINGREGION)))
(SETQ bottom (IMAX bottom (fetch BOTTOM of CLIPPINGREGION)))
[SETQ right (IMIN right (IPLUS (fetch WIDTH of CLIPPINGREGION)
(fetch LEFT of CLIPPINGREGION]
(SETQ top (IMIN top (IPLUS (fetch BOTTOM of CLIPPINGREGION)
(fetch HEIGHT of CLIPPINGREGION]
(OR DESTINATIONLEFT (SETQ DESTINATIONLEFT 0))
(OR DESTINATIONBOTTOM (SETQ DESTINATIONBOTTOM 0))
(* left, right top and bottom are the limits in destination taking into account Clipping Regions.
Clip to region in the arguments of this call.)
[PROGN (SETQ left (IMAX DESTINATIONLEFT left))
(SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
[COND
(WIDTH (* WIDTH is optional)
(SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
right]
(COND
(HEIGHT (* HEIGHT is optional)
(SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
top]
(COND
((OR (ILEQ right left)
(ILEQ top bottom)) (* there is nothing to move.)
(RETURN)))
(SETQ TEXTURE (SELECTQ (TYPENAME TEXTURE)
(LITATOM (* includes NIL case)
(COND
(DESTINATIONNBITS (COND
(TEXTURE
(* should be a color name)
(OR (COLORNUMBERP TEXTURE
DESTINATIONNBITS T)
(\ILLEGAL.ARG TEXTURE)))
(T BLACKCOLOR)))
(TEXTURE (\ILLEGAL.ARG TEXTURE))
(T WHITESHADE)))
[(SMALLP FIXP)
(COND
[DESTINATIONNBITS (* if fixp use the low order bits as a color number.
This picks up the case of BLACKSHADE being used to
INVERT.)
(OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T)
(LOGAND TEXTURE (COND
((EQ DESTINATIONNBITS 4)
15)
(T 255]
(T (LOGAND TEXTURE BLACKSHADE]
(BITMAP TEXTURE)
[LISTP (* should be a list of levels rgb or hls.)
(COND
(DESTINATIONNBITS (OR (COLORNUMBERP TEXTURE)
(\ILLEGAL.ARG TEXTURE)))
(T (\ILLEGAL.ARG TEXTURE]
(\ILLEGAL.ARG TEXTURE))) (* filling an area with a texture.)
[COND
(DESTINATIONNBITS (SETQ left (ITIMES DESTINATIONNBITS left))
(SETQ right (ITIMES DESTINATIONNBITS right))
(SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS]
(* easy case of black and white bitmap into black and
white or color to color or texture filling.)
(UNINTERRUPTABLY
(AND DESTINATIONNBITS \COLORCURSORBM (\TAKEDOWNCOLORCURSOR))
(* this actually takes down the cursor whenever a
bitblt is done to ANY color bitmap.
Not optimal but works.)
(PROG ([PILOTBBT (COND
((type? PILOTBBT \SYSPILOTBBT)
\SYSPILOTBBT)
(T (SETQ \SYSPILOTBBT (create PILOTBBT]
(HEIGHT (IDIFFERENCE top bottom)))
(replace PBTWIDTH of PILOTBBT with (IDIFFERENCE right left))
(replace PBTHEIGHT of PILOTBBT with HEIGHT)
(\BITBLTSUB PILOTBBT NIL left NIL DESTINATIONBITMAP left (\SFInvert
DESTINATIONBITMAP top)
HEIGHT
(QUOTE TEXTURE)
OPERATION TEXTURE))
(AND \COLORCURSORDOWN (\PUTUPCOLORCURSOR)))
(RETURN T])
(\BLTSHADE.COLORDISPLAY
[LAMBDA (TEXTURE STREAM DESTINATIONLEFT DESTINATIONBOTTOM WIDTH HEIGHT OPERATION CLIPPINGREGION)
(* rmk: "22-Jun-84 17:09")
(* BLTSHADE to color display stream)
(DECLARE (LOCALVARS . T))
(PROG (left top bottom right DESTINATIONNBITS DESTINATIONBITMAP (DESTDD (fetch IMAGEDATA
of STREAM)))
(SETQ DESTINATIONLEFT (\DSPTRANSFORMX DESTINATIONLEFT DESTDD))
(SETQ DESTINATIONBOTTOM (\DSPTRANSFORMY DESTINATIONBOTTOM DESTDD))
[PROGN (* compute limits based on clipping regions.)
(SETQ left (fetch DDClippingLeft of DESTDD))
(SETQ bottom (fetch DDClippingBottom of DESTDD))
(SETQ right (fetch DDClippingRight of DESTDD))
(SETQ top (fetch DDClippingTop of DESTDD))
(COND
(CLIPPINGREGION (* hard case, two destination clipping regions: do
calculations to merge them.)
(PROG (CRLEFT CRBOTTOM)
[SETQ left (IMAX left (SETQ CRLEFT
(\DSPTRANSFORMX (fetch LEFT of
CLIPPINGREGION)
DESTDD]
[SETQ bottom (IMAX bottom (SETQ CRBOTTOM
(\DSPTRANSFORMY (fetch BOTTOM
of CLIPPINGREGION)
DESTDD]
[SETQ right (IMIN right (IPLUS CRLEFT (fetch WIDTH
of CLIPPINGREGION]
(SETQ top (IMIN top (IPLUS CRBOTTOM (fetch HEIGHT
of CLIPPINGREGION]
[SETQ DESTINATIONNBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of (SETQ DESTINATIONBITMAP
(fetch DDDestination
of DESTDD]
(SETQ right (\PIXELOFBITADDRESS DESTINATIONNBITS right))
(* left, right top and bottom are the limits in destination taking into account Clipping Regions.
Clip to region in the arguments of this call.)
[PROGN (SETQ left (IMAX DESTINATIONLEFT left))
(SETQ bottom (IMAX DESTINATIONBOTTOM bottom))
[COND
(WIDTH (* WIDTH is optional)
(SETQ right (IMIN (IPLUS DESTINATIONLEFT WIDTH)
right]
(COND
(HEIGHT (* HEIGHT is optional)
(SETQ top (IMIN (IPLUS DESTINATIONBOTTOM HEIGHT)
top]
(COND
((OR (ILEQ right left)
(ILEQ top bottom)) (* there is nothing to move.)
(RETURN)))
[SETQ TEXTURE (COND
((NULL TEXTURE)
(DSPBACKCOLOR NIL STREAM))
((LITATOM TEXTURE) (* should be a color name)
(OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T)
(\ILLEGAL.ARG TEXTURE)))
[(FIXP TEXTURE) (* if fixp use the low order bits as a color number.
This picks up the case of BLACKSHADE being used to
INVERT.)
(OR (COLORNUMBERP TEXTURE DESTINATIONNBITS T)
(LOGAND TEXTURE (COND
((EQ DESTINATIONNBITS 4)
15)
(T 255]
((LISTP TEXTURE) (* should be a list of levels rgb or hls.)
(OR (COLORNUMBERP TEXTURE)
(\ILLEGAL.ARG TEXTURE)))
(T (\ILLEGAL.ARG TEXTURE] (* filling an area with a texture.)
(SETQ left (ITIMES DESTINATIONNBITS left))
(SETQ right (ITIMES DESTINATIONNBITS right))
(SETQ TEXTURE (COLORTEXTUREFROMCOLOR# TEXTURE DESTINATIONNBITS))
(* easy case of black and white bitmap into black and
white or color to color or texture filling.)
(\INSURETOPWDS STREAM)
(* We'd rather handle the slow case when we are interruptable, so we do it here as a heuristic.
But we might get interrupted before we go interruptable, so we do it there too.)
(.WHILE.TOP.IF.DS. STREAM DESTINATIONNBITS (* Just in case the user got in and screwed our window)
(PROG ([PILOTBBT (COND
((type? PILOTBBT \SYSPILOTBBT)
\SYSPILOTBBT)
(T (SETQ \SYSPILOTBBT (create PILOTBBT]
(HEIGHT (IDIFFERENCE top bottom)))
(replace PBTWIDTH of PILOTBBT with (IDIFFERENCE right left))
(replace PBTHEIGHT of PILOTBBT with HEIGHT)
(\BITBLTSUB PILOTBBT NIL left NIL DESTINATIONBITMAP left
(\SFInvert DESTINATIONBITMAP top)
HEIGHT
(QUOTE TEXTURE)
(OR OPERATION (ffetch (\DISPLAYDATA DDOPERATION)
of DESTDD))
TEXTURE)))
(RETURN T])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(RPAQQ \DisplayWordAlign 16)
(RPAQQ \MaxBitMapWidth 65535)
(RPAQQ \MaxBitMapHeight 65535)
(RPAQQ \MaxBitMapWords 131066)
(CONSTANTS (\DisplayWordAlign 16)
(\MaxBitMapWidth 65535)
(\MaxBitMapHeight 65535)
(\MaxBitMapWords 131066))
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \DSPGETCHARWIDTH MACRO ((CHARCODE DD)
(\FGETWIDTH (ffetch DDWIDTHSCACHE of DD)
CHARCODE)))
(PUTPROPS \DSPGETCHAROFFSET MACRO ((CHARCODE DD)
(\GETBASE (ffetch DDOFFSETSCACHE of DD)
CHARCODE)))
(PUTPROPS \CONVERTOP MACRO ((OP) (* rrb "14-NOV-80 11:14")
(* Only for alto bitblt !!)
(SELECTQ OP
(REPLACE 0)
(PAINT 1)
(INVERT 2)
(ERASE 3)
0)))
(PUTPROPS \SFInvert MACRO ((BitMap y)
(* corrects for the fact that alto bitmaps are stored with 0,0 as upper left while lisp bitmaps have 0,0 as lower
left. The correction is actually off by one (greater) because a majority of the places that it is called actually
need one more than corrected Y value.)
(IDIFFERENCE (fetch BITMAPHEIGHT of BitMap)
y)))
(PUTPROPS \SFReplicate MACRO [LAMBDA (pattern)
(LOGOR pattern (LLSH pattern 8)
(SETQ pattern (LLSH pattern 4))
(LLSH pattern 8])
(PUTPROPS \SETPBTFUNCTION MACRO [OPENLAMBDA (PILOTBBT SourceType Operation)
(PROGN (replace PBTOPERATION of PILOTBBT
with (SELECTQ Operation
(ERASE 1)
(PAINT 2)
(INVERT 3)
0))
(replace PBTSOURCETYPE of PILOTBBT
with (COND
((EQ (EQ SourceType (QUOTE INVERT))
(EQ Operation (QUOTE ERASE)))
0)
(T 1])
(PUTPROPS \BITBLT1 MACRO ((bbt)
(BitBltSUBR bbt)))
)
(* END EXPORTED DEFINITIONS)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \SYSBBTEXTURE \BBSCRATCHTEXTURE \SYSPILOTBBT \PILOTBBTSCRATCHBM)
)
)
(RPAQQ \BBSCRATCHTEXTURE NIL)
(RPAQQ \PILOTBBTSCRATCHBM NIL)
(DECLARE: DONTEVAL@LOAD DOCOPY
(MOVD? (QUOTE BITBLT)
(QUOTE BKBITBLT))
)
(* macro for this file so that BITBLT can be broken by users)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DONTCOPY DONTEVAL@LOAD DOEVAL@COMPILE
(PUTPROP (QUOTE BITBLT)
(QUOTE MACRO)
(QUOTE (= . BKBITBLT)))
)
(* END EXPORTED DEFINITIONS)
(* display stream functions)
(DEFINEQ
(DISPLAYSTREAMP
[LAMBDA (X) (* rmk: "31-AUG-83 22:37")
(* Is X a displaystream?)
(AND (type? STREAM X)
(EQMEMB (QUOTE DISPLAY)
(fetch (IMAGEOPS IMAGETYPE) of (fetch (STREAM IMAGEOPS) of X)))
X])
(DSPSOURCETYPE
[LAMBDA (SOURCETYPE DISPLAYSTREAM) (* rmk: "21-AUG-83 22:34")
(* sets the operation field of a display stream)
(PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)))
(RETURN (PROG1 (fetch DDSOURCETYPE of DD)
(COND
(SOURCETYPE (OR (FMEMB SOURCETYPE (QUOTE (INPUT INVERT)))
(LISPERROR "ILLEGAL ARG" SOURCETYPE))
(UNINTERRUPTABLY
(freplace DDSOURCETYPE of DD with SOURCETYPE)
(* update other fields that depend on operation.)
(\SETPBTFUNCTION (fetch DDPILOTBBT of DD)
SOURCETYPE
(fetch DDOPERATION of DD)))])
(DSPXOFFSET
[LAMBDA (XOFFSET DISPLAYSTREAM) (* rmk: "22-AUG-83 23:01")
(* coordinate position is stored in 15 bits in the range
-2↑15 to +2↑15.)
(COND
[DISPLAYSTREAM (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)))
(RETURN (PROG1 (fetch DDXOFFSET of DD)
(COND
((NULL XOFFSET))
((NUMBERP XOFFSET)
(UNINTERRUPTABLY
(freplace DDXOFFSET of DD with XOFFSET)
(\SFFixClippingRegion DD)))
(T (\ILLEGAL.ARG XOFFSET]
(T (* check done specially for NIL so that it won't default
to primary output file.)
(\ILLEGAL.ARG DISPLAYSTREAM])
(DSPYOFFSET
[LAMBDA (YOFFSET DISPLAYSTREAM) (* rmk: "21-AUG-83 23:50")
(COND
[DISPLAYSTREAM (PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)))
(RETURN (PROG1 (ffetch DDYOFFSET of DD)
(COND
((NULL YOFFSET))
((NUMBERP YOFFSET)
(UNINTERRUPTABLY
(freplace DDYOFFSET of DD with YOFFSET)
(\SFFixClippingRegion DD)
(\SFFixY DD)))
(T (\ILLEGAL.ARG YOFFSET]
(T (* check done specially for NIL so that it won't default
to primary output file.)
(\ILLEGAL.ARG DISPLAYSTREAM])
)
(DEFINEQ
(DSPCREATE
[LAMBDA (DESTINATION) (* hdj "31-Jan-85 16:22")
(* Creates a stream-of-type-display on the DESTINATION
bitmap or display device)
(DECLARE (GLOBALVARS \DISPLAYIMAGEOPS DisplayFDEV))
(OR (NULL DESTINATION)
(BITMAPP DESTINATION)
(\ILLEGAL.ARG DESTINATION))
(PROG [(DSTRM (create STREAM
DEVICE ← DisplayFDEV
ACCESS ←(QUOTE OUTPUT)
USERCLOSEABLE ← NIL
OUTCHARFN ←(FUNCTION \DSPPRINTCHAR)
IMAGEOPS ← \DISPLAYIMAGEOPS
IMAGEDATA ←(create \DISPLAYDATA] (* initial x and y positions are 0 when the data is
created.)
(\DSPFONT.DISPLAY DSTRM (DEFAULTFONT (QUOTE DISPLAY)))
(* initialize the core fields that affect the relatively constant fields in the \DISPLAYDATA structure then call the
function DSPFONT which will update that information in the right format.)
(DSPSOURCETYPE (QUOTE INPUT)
DSTRM)
(DSPOPERATION (QUOTE REPLACE)
DSTRM) (* called to cause the updating of the bitblt table
from the fields initialized earlier.)
(DSPDESTINATION (OR DESTINATION (SCREENBITMAP))
DSTRM)
(RETURN DSTRM])
(DSPDESTINATION
[LAMBDA (DESTINATION DISPLAYSTREAM) (* rmk: "22-Jun-84 17:39")
(DECLARE (GLOBALVARS \DISPLAYIMAGEOPS \COLORDISPLAYIMAGEOPS))
(PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM)))
(RETURN (PROG1 (ffetch DDDestination of DD)
(COND
(DESTINATION (SETQ DESTINATION (\DTEST DESTINATION (QUOTE BITMAP)))
(UNINTERRUPTABLY
[COND
((NEQ (fetch BITMAPBITSPERPIXEL (fetch DDDestination
of DD))
(fetch BITMAPBITSPERPIXEL of DESTINATION))
(replace IMAGEOPS of DISPLAYSTREAM
with (COND
((EQ 1 (fetch BITMAPBITSPERPIXEL
of DESTINATION))
\DISPLAYIMAGEOPS)
(T \COLORDISPLAYIMAGEOPS]
(freplace DDDestination of DD with DESTINATION)
(\SFFixDestination DD DISPLAYSTREAM))])
(DSPTEXTURE
[LAMBDA (TEXTURE DISPLAYSTREAM) (* rrb "16-May-84 18:04")
(PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)))
(RETURN (PROG1 (fetch DDTexture of DD)
(COND
((NULL TEXTURE))
((AND (BITMAPP TEXTURE)
(EQ (fetch (BITMAP BITMAPRASTERWIDTH) of TEXTURE)
1)
(ILEQ (BITMAPHEIGHT TEXTURE)
16)) (* allow small bitmaps)
(freplace DDTexture of DD with TEXTURE))
((FIXP TEXTURE)
(freplace DDTexture of DD with (LOGAND TEXTURE WORDMASK)))
(T (\ILLEGAL.ARG TEXTURE])
(\DISPLAYSTREAMINCRXPOSITION
[LAMBDA (N DD) (* rmk: "23-AUG-83 14:12")
(* increases the x position by N.
This is used internally. Returns the new value.)
(add (fetch DDXPOSITION of DD)
N])
(\SFFixDestination
[LAMBDA (DISPLAYDATA DISPLAYSTREAM) (* rmk: "25-AUG-83 12:35")
(* fixes up those parts of the bitblt array which are
dependent upon the destination)
(PROG ((PBT (ffetch DDPILOTBBT of DISPLAYDATA))
(BM (ffetch DDDestination of DISPLAYDATA)))
(replace PBTDESTBPL of PBT with (UNFOLD (ffetch BITMAPRASTERWIDTH of BM)
BITSPERWORD))
(* line width information will be updated by \SFFixFont)
(* ({also needs to be updated to include merger of bitmaps and colorbitmaps}) This change should be put in but it
has ramifications to people that create bitmaps that are as wide as a string and then PRIN1 instead of PRIN3 so I
am taking it out for the Dec release. (freplace (DISPLAYDATA DDRightMargin) of DISPLAYDATA with
(COND (COLOR? (IQUOTIENT (ffetch BITMAPWIDTH of BM) (ffetch (COLORBITMAP COLORBITSPERPIXEL) of COLOR?)))
(T (ffetch (BITMAP BITMAPWIDTH) of BM)))))
(\SFFixClippingRegion DISPLAYDATA)
(\SFFixY DISPLAYDATA) (* if destination from a black and white to a color
bitmap the font will have to change also.)
(\SFFixFont DISPLAYSTREAM DISPLAYDATA)
(RETURN])
(\SFFixClippingRegion
[LAMBDA (DISPLAYDATA) (* rmk: "21-AUG-83 23:58")
(* compute the top, bottom, left and right edges of the clipping region in destination coordinates to save
computation every BltChar and coordinate transformation taking into account the size of the bit map as well as the
clipping region.)
(PROG ((CLIPREG (ffetch DDClippingRegion of DISPLAYDATA))
(BM (ffetch DDDestination of DISPLAYDATA)))
[freplace DDClippingRight of DISPLAYDATA
with (IMAX 0 (IMIN (\DSPTRANSFORMX (IPLUS (ffetch LEFT of CLIPREG)
(ffetch WIDTH of CLIPREG))
DISPLAYDATA)
(IQUOTIENT (ffetch (BITMAP BITMAPWIDTH) of BM)
(fetch (BITMAP BITMAPBITSPERPIXEL) of BM]
(freplace DDClippingLeft of DISPLAYDATA with (IMIN (IMAX (\DSPTRANSFORMX (ffetch LEFT
of CLIPREG)
DISPLAYDATA)
0)
MAX.SMALL.INTEGER))
[freplace DDClippingTop of DISPLAYDATA
with (IMAX 0 (IMIN (\DSPTRANSFORMY (IPLUS (ffetch BOTTOM of CLIPREG)
(ffetch HEIGHT of CLIPREG))
DISPLAYDATA)
(ffetch BITMAPHEIGHT of BM]
(freplace DDClippingBottom of DISPLAYDATA
with (IMIN (IMAX (\DSPTRANSFORMY (ffetch BOTTOM of CLIPREG)
DISPLAYDATA)
0)
MAX.SMALL.INTEGER])
(\SFFixFont
[LAMBDA (DISPLAYSTREAM DISPLAYDATA) (* rmk: "24-AUG-83 10:31")
(* used to fix up those parts of the bitblt table which
depend upon the FONT. DISPLAYDATA is the IMAGEDATA for
DISPLAYSTREAM, for convenience.)
[PROG [(PBT (ffetch DDPILOTBBT of DISPLAYDATA))
(FONT (ffetch DDFONT of DISPLAYDATA))
FONTBITMAP
(NBITS (fetch (BITMAP BITMAPBITSPERPIXEL) of (fetch DDDestination of DISPLAYDATA]
(SETQ FONTBITMAP (fetch CHARACTERBITMAP of FONT))
(replace DDWIDTHSCACHE of DISPLAYDATA with (fetch (ARRAYP BASE)
of (fetch \SFWidths of FONT)))
(* cache the widths and offsets so that charcter
printing will be faster.)
[COND
((NEQ NBITS 1)
(* mark the displaystream as not having a calculated font yet. It will be put in by BLTCHAR the first time it is
printed too. This avoids creating color fonts for streams that are not printed to.)
(\DDMARKUNFONTED DISPLAYDATA))
(T (replace DDOFFSETSCACHE of DISPLAYDATA with (fetch (ARRAYP BASE)
of (fetch \SFOffsets of FONT)))
(replace PBTSOURCEBPL of PBT with (UNFOLD (fetch BITMAPRASTERWIDTH of FONTBITMAP)
BITSPERWORD]
(replace DDSlowPrintingCase of DISPLAYDATA with (OR (NEQ NBITS 1)
(NEQ (fetch (FONTDESCRIPTOR ROTATION)
of FONT)
0]
(\SFFixY DISPLAYDATA)
(\SFFIXLINELENGTH DISPLAYSTREAM])
(\SFFIXLINELENGTH
[LAMBDA (DISPLAYSTREAM) (* rmk: "27-Nov-84 18:44")
(* DISPLAYSTREAM is known to be a stream of type display. Called by RIGHTMARGIN LEFTMARGIN and \SFFIXFONT to update
the LINELENGTH field in the stream. also called when the display stream is created.)
(PROG (LLEN (DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(freplace (STREAM LINELENGTH) of DISPLAYSTREAM
with (COND
((IGREATERP [SETQ LLEN (IQUOTIENT (IDIFFERENCE (ffetch (\DISPLAYDATA
DDRightMargin)
of DD)
(ffetch (\DISPLAYDATA DDLeftMargin)
of DD))
(ffetch FONTAVGCHARWIDTH
of (ffetch DDFONT of DD]
1)
LLEN)
(T 10])
(\SFFixY
[LAMBDA (DISPLAYDATA) (* rmk: "21-AUG-83 23:48")
(* makes that part of the bitblt table of a display stream which deals with the Y information consistent.
This is called whenever any of the information which effects it changes by the DSPFn eg DSPPosition.
If the change affected the clipping region, \SFFixClippingRegion should be called before \SFFixY)
(* assumes DISPLAYDATA has already been type checked.)
(PROG ((PBT (ffetch DDPILOTBBT of DISPLAYDATA))
(FONT (ffetch DDFONT of DISPLAYDATA))
(Y (\DSPTRANSFORMY (ffetch DDYPOSITION of DISPLAYDATA)
DISPLAYDATA))
TOP CHARTOP BM)
(SETQ CHARTOP (IPLUS Y (ffetch \SFAscent of FONT)))
[freplace PBTDEST of PBT with (\ADDBASE (fetch BITMAPBASE of (SETQ BM
(ffetch DDDestination
of DISPLAYDATA)))
(ITIMES (ffetch BITMAPRASTERWIDTH of BM)
(\SFInvert BM
(SETQ TOP
(IMAX (IMIN (ffetch
DDClippingTop
of DISPLAYDATA)
CHARTOP)
0]
[freplace PBTSOURCE of PBT with (\ADDBASE (ffetch BITMAPBASE
of (SETQ BM (ffetch CHARACTERBITMAP
of FONT)))
(ITIMES (ffetch BITMAPRASTERWIDTH of BM)
(IMIN (IMAX (IDIFFERENCE CHARTOP TOP)
0)
MAX.SMALL.INTEGER]
(freplace PBTHEIGHT of PBT with (IMAX (IDIFFERENCE TOP (IMAX (IDIFFERENCE Y
(ffetch
\SFDescent
of FONT))
(ffetch DDClippingBottom
of DISPLAYDATA)))
0])
)
(DEFINEQ
(\DSPCLIPPINGREGION.DISPLAY
[LAMBDA (DISPLAYSTREAM REGION) (* jds "11-Jan-85 16:52")
(* sets the clipping region of a display stream.)
(PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)))
(RETURN (PROG1 (ffetch DDClippingRegion of DD)
(COND
(REGION (OR (type? REGION REGION)
(ERROR REGION " is not a REGION."))
(UNINTERRUPTABLY
(freplace DDClippingRegion of DD with REGION)
(\SFFixClippingRegion DD)
(\SFFixY DD))])
(\DSPFONT.DISPLAY
[LAMBDA (DISPLAYSTREAM FONT) (* rmk: "25-Jun-84 14:59")
(* sets the font that a display stream uses to print
characters. DISPLAYSTREAM is guaranteed to be a stream
of type display)
(PROG (XFONT OLDFONT (DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(* save old value to return, smash new value and update
the bitchar portion of the record.)
(RETURN (PROG1 (SETQ OLDFONT (fetch DDFONT of DD))
(COND
(FONT (SETQ XFONT (OR (\GETFONTDESC FONT (QUOTE DISPLAY)
T)
(FONTCOPY (ffetch DDFONT of DD)
FONT)))
(* updating font information is fairly expensive
operation. Don't bother unless font has changed.)
(OR (EQ XFONT OLDFONT)
(UNINTERRUPTABLY
(freplace DDFONT of DD with XFONT)
(freplace DDLINEFEED of DD
with (IMINUS (fetch \SFHeight of XFONT)))
(\SFFixFont DISPLAYSTREAM DD))])
(\DSPFONT.COLORDISPLAY
[LAMBDA (DISPLAYSTREAM FONT) (* rmk: "25-Jun-84 14:57")
(* sets the font that a display stream uses to print
characters. DISPLAYSTREAM is guaranteed to be a stream
of type display)
(PROG (XFONT OLDFONT (DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(* save old value to return, smash new value and update
the bitchar portion of the record.)
(RETURN (PROG1 (SETQ OLDFONT (fetch DDFONT of DD))
(COND
(FONT (SETQ XFONT (OR (\GETFONTDESC FONT (QUOTE DISPLAY)
T)
(FONTCOPY (ffetch DDFONT of DD)
FONT)))
(* color case, create a font with the current
foreground and background colors.)
[SETQ XFONT (\GETCOLORFONT XFONT (DSPCOLOR NIL DISPLAYSTREAM)
(DSPBACKCOLOR NIL DISPLAYSTREAM)
(ffetch (BITMAP BITMAPBITSPERPIXEL)
of (ffetch (\DISPLAYDATA DDDestination)
of DD]
(* updating font information is fairly expensive
operation. Don't bother unless font has changed.)
(OR (EQ XFONT OLDFONT)
(UNINTERRUPTABLY
(freplace DDFONT of DD with XFONT)
(freplace DDLINEFEED of DD
with (IMINUS (fetch \SFHeight of XFONT)))
(\SFFixFont DISPLAYSTREAM DD))])
(\DSPLINEFEED.DISPLAY
[LAMBDA (DISPLAYSTREAM DELTAY) (* rmk: " 2-SEP-83 10:56")
(* sets the amount that a line feed increases the y
coordinate by.)
(PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(RETURN (PROG1 (ffetch DDLINEFEED of DD)
(AND DELTAY (COND
((NUMBERP DELTAY)
(freplace DDLINEFEED of DD with DELTAY))
(T (\ILLEGAL.ARG DELTAY])
(\DSPLEFTMARGIN.DISPLAY
[LAMBDA (DISPLAYSTREAM XPOSITION) (* rmk: " 2-SEP-83 10:56")
(* sets the xposition that a carriage return returns
to.)
(PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(RETURN (PROG1 (ffetch DDLeftMargin of DD)
(AND XPOSITION (COND
((AND (SMALLP XPOSITION)
(IGREATERP XPOSITION -1))
(UNINTERRUPTABLY
(freplace DDLeftMargin of DD with XPOSITION)
(\SFFIXLINELENGTH DISPLAYSTREAM)))
(T (\ILLEGAL.ARG XPOSITION])
(\DSPOPERATION.DISPLAY
[LAMBDA (DISPLAYSTREAM OPERATION) (* rmk: "12-Sep-84 09:56")
(* sets the operation field of a display stream)
(PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)))
(RETURN (PROG1 (fetch DDOPERATION of DD)
(COND
(OPERATION (OR (FMEMB OPERATION (QUOTE (PAINT REPLACE INVERT ERASE)))
(LISPERROR "ILLEGAL ARG" OPERATION))
(UNINTERRUPTABLY
(freplace DDOPERATION of DD with OPERATION)
(* update other fields that depend on operation.)
(\SETPBTFUNCTION (fetch DDPILOTBBT of DD)
(fetch DDSOURCETYPE of DD)
OPERATION))])
(\DSPRIGHTMARGIN.DISPLAY
[LAMBDA (DISPLAYSTREAM XPOSITION) (* rmk: " 2-SEP-83 10:56")
(* Sets the right margin that determines when a cr is
inserted by print.)
(PROG (OLDRM (DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(SETQ OLDRM (ffetch DDRightMargin of DD))
(COND
((NULL XPOSITION))
[(AND (SMALLP XPOSITION)
(IGREATERP XPOSITION -1)) (* Avoid fixing linelength if right margin hasn't
changed.)
(OR (EQ XPOSITION OLDRM)
(UNINTERRUPTABLY
(freplace DDRightMargin of DD with XPOSITION)
(\SFFIXLINELENGTH DISPLAYSTREAM))]
(T (\ILLEGAL.ARG XPOSITION)))
(RETURN OLDRM])
(\DSPXPOSITION.DISPLAY
[LAMBDA (DISPLAYSTREAM XPOSITION) (* rmk: " 2-SEP-83 10:56")
(* coordinate position is stored in 15 bits in the range
-2↑15 to +2↑15.)
(PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(RETURN (PROG1 (fetch DDXPOSITION of DD)
(COND
((NULL XPOSITION))
((NUMBERP XPOSITION)
(freplace DDXPOSITION of DD with XPOSITION)
(* reset the charposition field so that PRINT etc. won't
put out eols.)
(freplace (STREAM CHARPOSITION) of DISPLAYSTREAM with 0))
(T (\ILLEGAL.ARG XPOSITION])
(\DSPYPOSITION.DISPLAY
[LAMBDA (DISPLAYSTREAM YPOSITION) (* rmk: " 2-SEP-83 10:57")
(PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(RETURN (PROG1 (ffetch DDYPOSITION of DD)
(COND
((NULL YPOSITION))
((NUMBERP YPOSITION)
(UNINTERRUPTABLY
(freplace DDYPOSITION of DD with YPOSITION)
(\SFFixY DD)))
(T (\ILLEGAL.ARG YPOSITION])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \DDMARKUNFONTED MACRO ((DD)
(freplace (\DISPLAYDATA DDOFFSETSCACHE) of DD with NIL)))
(PUTPROPS \DDHASFONT MACRO ((DD)
(ffetch (\DISPLAYDATA DDOFFSETSCACHE) of DD)))
)
(* END EXPORTED DEFINITIONS)
(MOVD? (QUOTE \ILLEGAL.ARG)
(QUOTE \COERCETODS))
(MOVD? (QUOTE NILL)
(QUOTE WFROMDS))
(MOVD? (QUOTE NILL)
(QUOTE WINDOWP))
(MOVD? (QUOTE NILL)
(QUOTE INVERTW))
(RPAQ? PROMPTWINDOW T)
(* Stub for window package)
(DECLARE: DOCOPY
(DECLARE: EVAL@LOADWHEN (EQ (SYSTEMTYPE)
(QUOTE D))
(RPAQ? \TOPWDS )
(MOVD? (QUOTE NILL)
(QUOTE \TOTOPWDS))
)
)
(DECLARE: DONTCOPY EVAL@COMPILE
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \INSURETOPWDS DMACRO (OPENLAMBDA (DS)
(OR (EQ DS \TOPWDS)
(\TOTOPWDS DS))))
(PUTPROPS \INSURETOPWDS MACRO ((DS) (* For non-window implementations)
(PROGN)))
(PUTPROPS .WHILE.TOP.DS. MACRO [(FIRST . REST) (* FIRST should be a displaystream and a variable.)
(UNINTERRUPTABLY
(AND \COLORCURSORBM (\IFCOLORDS\TAKEDOWNCOLORCURSOR FIRST))
(\INSURETOPWDS FIRST)
(PROGN . REST)
(AND \COLORCURSORDOWN (\PUTUPCOLORCURSOR)))])
(PUTPROPS .WHILE.TOP.IF.DS. MACRO [(FIRST COLOR? . REST) (* FIRST should be a displaystream and a variable.)
(UNINTERRUPTABLY
(COND
(FIRST (\INSURETOPWDS FIRST)))
[COND
(COLOR? (* this actually takes down the cursor whenever a
bitblt is done to any color bitmap.
Not optimal but works.)
(AND \COLORCURSORBM (\TAKEDOWNCOLORCURSOR]
(PROGN . REST)
(AND \COLORCURSORDOWN (\PUTUPCOLORCURSOR)))])
(PUTPROPS \PIXELOFBITADDRESS MACRO (OPENLAMBDA (BITSPERPIXEL BITADDRESS)
(SELECTQ BITSPERPIXEL
(1 BITADDRESS)
(4 (LRSH BITADDRESS 2))
(LRSH BITADDRESS 3))))
)
(ADDTOVAR GLOBALVARS \TOPWDS)
(* END EXPORTED DEFINITIONS)
)
(* DisplayStream TTY functions)
(DEFINEQ
(TTYDISPLAYSTREAM
[LAMBDA (DISPLAYSTREAM) (* bvm: "30-Jul-84 17:25")
(* Makes DISPLAYSTREAM be the ttydisplaystream)
(DECLARE (GLOBALVARS \DEFAULTTTYDISPLAYSTREAM))
(COND
((NULL DISPLAYSTREAM) (* this case normally macros out)
TtyDisplayStream)
(T (SETQ DISPLAYSTREAM (OR (DISPLAYSTREAMP (\OUTSTREAMARG DISPLAYSTREAM))
(\ILLEGAL.ARG DISPLAYSTREAM)))
(PROG1 TtyDisplayStream
(UNINTERRUPTABLY
(COND
((NEQ DISPLAYSTREAM TtyDisplayStream)
(* * First remove the old one (if any))
[COND
((AND TtyDisplayStream (NEQ TtyDisplayStream \DEFAULTTTYDISPLAYSTREAM))
(\CHECKCARET) (* make sure caret is off before changing display
streams.)
(\CLEAROFD) (* \TERM.OFD is guaranteed to be the stream of
TtyDisplayStream)
(* change the full file name back to the display stream
from T which it was set to when it became the terminal
device.)
(replace FULLFILENAME of \TERM.OFD with NIL)
(\REMOVEDRIBBLECHECK \TERM.OFD)
(* Change the outcharfn back to an ordinary display)
(PROG ((WIN (WFROMDS TtyDisplayStream T)))
(AND WIN (WINDOWPROP WIN (QUOTE \LINEBUF.OFD)
\LINEBUF.OFD]
(* * Now install the new one.)
(replace FULLFILENAME of DISPLAYSTREAM with T)
[COND
((NEQ DISPLAYSTREAM \DEFAULTTTYDISPLAYSTREAM)
(COND
(\DRIBBLE.OFD (\ADDDRIBBLECHECK DISPLAYSTREAM]
(* if old T was the primary output, change it to the new
ttydisplaystream.)
(COND
((EQ \PRIMOUT.OFD \TERM.OFD)
(SETQ \PRIMOUT.OFD DISPLAYSTREAM)))
(SETQ \TERM.OFD DISPLAYSTREAM) (* save and restore line buffer from the displaystream
window if any.)
(COND
([EQ \PRIMIN.OFD (PROG1 \LINEBUF.OFD
(PROG ((WIN (WFROMDS DISPLAYSTREAM T)))
(SETQ \LINEBUF.OFD
(OR [COND
(WIN (WINDOWPROP WIN (QUOTE PROCESS)
(THIS.PROCESS))
(* For the PROC world to worry about tty moving)
(WINDOWPROP WIN (QUOTE
\LINEBUF.OFD]
(\CREATELINEBUFFER]
(* primary input is line buffer, switch it too.)
(SETQ \PRIMIN.OFD \LINEBUF.OFD)))
(SETQ TtyDisplayStream DISPLAYSTREAM)))
(* change scroll mode of tty stream to scroll.)
(DSPSCROLL (QUOTE ON)
DISPLAYSTREAM) (* Reset page characteristics.)
[PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(PAGEHEIGHT (IQUOTIENT (IDIFFERENCE (fetch DDClippingTop of DD)
(fetch DDClippingBottom of DD))
(IABS (ffetch DDLINEFEED of DD])])
(\REMOVEDRIBBLECHECK
[LAMBDA (DISPLAYSTREAM) (* rmk: " 8-NOV-83 19:44")
(PROG [(OC (LISTGET (fetch OTHERPROPS of DISPLAYSTREAM)
(QUOTE \OUTCHAR]
(COND
(OC (replace OUTCHARFN of DISPLAYSTREAM with OC)
(replace OTHERPROPS of DISPLAYSTREAM with (LISTPUT (fetch OTHERPROPS of DISPLAYSTREAM)
(QUOTE \OUTCHAR)
NIL])
(\ADDDRIBBLECHECK
[LAMBDA (DISPLAYSTREAM) (* rmk: " 8-NOV-83 19:41")
(push (fetch OTHERPROPS of DISPLAYSTREAM)
(QUOTE \OUTCHAR)
(fetch OUTCHARFN of DISPLAYSTREAM))
(replace OUTCHARFN of DISPLAYSTREAM with (FUNCTION \TTYOUTCHARFN])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS TTYDISPLAYSTREAM MACRO [X (COND
((NULL (CAR X))
(QUOTE TtyDisplayStream))
(T (QUOTE IGNOREMACRO])
)
(* END EXPORTED DEFINITIONS)
(DEFINEQ
(DSPSCROLL
[LAMBDA (SWITCHSETTING DISPLAYSTREAM) (* rmk: "23-AUG-83 13:02")
(* sets the SCROLL characteristics of the font in a display stream. If SWITCHSETTING in ON, when bottom of screen
is reached, contents will be blted DSPLineFeed bits.)
(PROG ((DD (\GETDISPLAYDATA DISPLAYSTREAM)))
(RETURN (PROG1 (OR (ffetch DDScroll of DD)
(QUOTE OFF))
(AND SWITCHSETTING (freplace DDScroll of DD with (NEQ SWITCHSETTING
(QUOTE OFF])
(CHANGETTYDEVICE
[LAMBDA (NEWTTYDEVICE) (* rmk: "23-AUG-83 13:04")
(* resetform format functions to change the channel T to
be a display stream or the bcpl text buffer.)
(DECLARE (GLOBALVARS \TERM.OFD.SAV \STOPSCROLLMESSAGE TtyDisplayStream.SAVE \CURRENTTTYDEVICE
\DEFAULTTTYDISPLAYSTREAM))
(SELECTQ NEWTTYDEVICE
(NIL (SETQQ NEWTTYDEVICE BCPLDISPLAY))
(T (SETQQ NEWTTYDEVICE LISPDISPLAY))
NIL)
(\CLEAROFD)
(COND
[(EQ NEWTTYDEVICE (QUOTE BCPLDISPLAY)) (* restore terminal to BCPL device)
(COND
((NEQ \CURRENTTTYDEVICE (QUOTE BCPLDISPLAY)) (* T was changed to a display stream.
change it back and return the display stream as value.)
(PROG1 \TERM.OFD (COND
((EQ TtyDisplayStream \DEFAULTTTYDISPLAYSTREAM)
(* don't think this should ever happen but if it did we
don't want it to continue.)
(HELP)))
(UNINTERRUPTABLY
(SETQQ \CURRENTTTYDEVICE BCPLDISPLAY)
(replace FULLFILENAME of \TERM.OFD with NIL)
(replace OUTCHARFN of \TERM.OFD with (FUNCTION \DSPPRINTCHAR))
(COND
((EQ \PRIMOUT.OFD \TERM.OFD) (* if primary output is to T, change it as well.)
(SETQ \PRIMOUT.OFD \TERM.OFD.SAV)))
(SETQ TtyDisplayStream.SAVE TtyDisplayStream)
(SETQ TtyDisplayStream NIL)
(SETQ \TERM.OFD \TERM.OFD.SAV)
(replace OUTCHARFN of \TERM.OFD with (FUNCTION \TTYOUTCHARFN)))
(SETQ \STOPSCROLLMESSAGE "------TYPE ANY CHARACTER TO CONTINUE------"]
[(DISPLAYSTREAMP (OR (AND (EQ NEWTTYDEVICE (QUOTE LISPDISPLAY))
(SETQ NEWTTYDEVICE (OR TtyDisplayStream TtyDisplayStream.SAVE)))
NEWTTYDEVICE)) (* make the terminal be the same as the
ttydisplaystream)
(UNINTERRUPTABLY
(COND
((NEQ \CURRENTTTYDEVICE (QUOTE LISPDISPLAY))
(SETQQ \CURRENTTTYDEVICE LISPDISPLAY)
(SETQ \STOPSCROLLMESSAGE "")))
(SETQ TtyDisplayStream.SAVE NIL)
(OR (TTYDISPLAYSTREAM NEWTTYDEVICE)
(QUOTE BCPLDISPLAY)))]
(T (\ILLEGAL.ARG NEWTTYDEVICE])
(OUTPUTDSP
[LAMBDA (FILE) (* rmk: "31-AUG-83 16:27")
(* Returns displaystream of FILE, coercing NIL to OUTPUT, not current displaystream. Called from CHANGFONT.
This probably should be included in \COERCETODS, when CURRENTDISPLAYSTREAM is eliminated.)
(DISPLAYSTREAMP (\OUTSTREAMARG FILE])
(PAGEHEIGHT
[LAMBDA (N) (* rrb "23-JUL-83 15:08")
(* sets the page height in lines of the screen.)
(PROG1 \#DISPLAYLINES (COND
((NUMBERP N)
(SETQ \#DISPLAYLINES N)
(SETQ \CURRENTDISPLAYLINE 0])
)
(RPAQ? \CURRENTTTYDEVICE (QUOTE BCPLDISPLAY))
(RPAQ? \SystemColorMap )
(DEFINEQ
(\DSPRESET.DISPLAY
[LAMBDA (DISPLAYSTREAM) (* rrb "29-Aug-84 15:30")
(DECLARE (GLOBALVARS \CURRENTDISPLAYLINE)) (* resets a display stream)
(PROG [CREG FONT FONTASCENT (DD (\DTEST (fetch IMAGEDATA of (SETQ DISPLAYSTREAM (\OUTSTREAMARG
DISPLAYSTREAM)))
(QUOTE \DISPLAYDATA]
(SETQ CREG (ffetch DDClippingRegion of DD))
(SETQ FONT (fetch DDFONT of DD))
(SETQ FONTASCENT (FONTASCENT FONT))
(SELECTQ (fetch (FONTDESCRIPTOR ROTATION) of FONT)
[0 (\DSPXPOSITION.DISPLAY DISPLAYSTREAM (ffetch DDLeftMargin of DD))
(\DSPYPOSITION.DISPLAY DISPLAYSTREAM (ADD1 (IDIFFERENCE (fetch TOP
of CREG)
FONTASCENT]
(90 (\DSPXPOSITION.DISPLAY DISPLAYSTREAM (IPLUS (fetch LEFT of CREG)
FONTASCENT))
(\DSPYPOSITION.DISPLAY DISPLAYSTREAM (fetch BOTTOM of CREG)))
(270 (\DSPXPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE (fetch RIGHT of CREG)
FONTASCENT))
(\DSPYPOSITION.DISPLAY DISPLAYSTREAM (fetch TOP of CREG)))
(ERROR "only supported rotations are 0, 90 and 270"))
(BITBLT NIL NIL NIL DISPLAYSTREAM (fetch LEFT of CREG)
(fetch BOTTOM of CREG)
(fetch WIDTH of CREG)
(fetch HEIGHT of CREG)
(QUOTE TEXTURE)
(QUOTE REPLACE)
(ffetch DDTexture of DD)) (* if this display stream is the tty display stream of
a process, reset the # of lines in that process.)
(PROG ((X (WFROMDS DISPLAYSTREAM)))
(COND
((AND X (SETQ X (WINDOWPROP X (QUOTE PROCESS)))
(EQ (PROCESS.TTY X)
DISPLAYSTREAM))
(PROCESS.EVAL X (QUOTE (SETQ \CURRENTDISPLAYLINE 0])
(\DSPPRINTCHAR
[LAMBDA (STREAM CHARCODE) (* lmm " 3-May-84 10:05")
(* Displays the character and increments the Xposition.
STREAM is guaranteed to be of type display.)
(\CHECKCARET STREAM)
(PROG ((DD (fetch IMAGEDATA of STREAM)))
(SELECTC (fetch CCECHO of (\SYNCODE \PRIMTERMSA CHARCODE))
[INDICATE.CCE (PROG ((CC CHARCODE))
(add (fetch CHARPOSITION of STREAM)
(IPLUS (COND
((IGREATERP CC 177Q)
(* META character)
(\BLTCHAR (CHARCODE #)
STREAM DD)
(SETQ CC (LOGAND CC 177Q))
1)
(T 0))
(COND
((ILESSP CC 40Q)
(* CONTROL character)
(\BLTCHAR (CHARCODE ↑)
STREAM DD)
(SETQ CC (LOGOR CC 100Q))
1)
(T 0))
(PROGN (\BLTCHAR CC STREAM DD)
1]
[SIMULATE.CCE
(SELCHARQ CHARCODE
((EOL CR LF)
(\DSPPRINTCR/LF CHARCODE STREAM)
(replace CHARPOSITION of STREAM with 0))
(ESCAPE (\BLTCHAR (CHARCODE $)
STREAM DD)
(add (fetch CHARPOSITION of STREAM)
1))
[BELL (* make switching of bits uninterruptable but allow
interrupts between flashes.)
(SELECTQ (MACHINETYPE)
[DANDELION (PLAYTUNE (QUOTE ((1560Q . 4704Q]
(FLASHWINDOW (WFROMDS STREAM]
[TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE)
STREAM)))
(SETQ TABWIDTH (UNFOLD SPACEWIDTH 10Q))
(COND
((IGREATERP (\DISPLAYSTREAMINCRXPOSITION
(SETQ TABWIDTH
(IDIFFERENCE TABWIDTH
(MOD (IDIFFERENCE
(fetch DDXPOSITION
of DD)
(ffetch DDLeftMargin
of DD))
TABWIDTH)))
DD)
(ffetch DDRightMargin of DD))
(* tab was past rightmargin, force cr.)
(\DSPPRINTCR/LF (CHARCODE EOL)
STREAM)))
(* return the number of spaces taken.)
(add (fetch CHARPOSITION of STREAM)
(IQUOTIENT TABWIDTH SPACEWIDTH]
(PROGN (* this case was copied from \DSCCOUT.)
(\BLTCHAR CHARCODE STREAM DD)
(add (fetch CHARPOSITION of STREAM)
1]
[REAL.CCE (SELECTC CHARCODE
((CHARCODE (EOL CR LF))
(\DSPPRINTCR/LF CHARCODE STREAM)
(replace CHARPOSITION of STREAM with 0))
(ERASECHARCODE (DSPBACKUP (CHARWIDTH (CHARCODE A)
STREAM)
STREAM)
(* line buffering routines have already taken care of
backing up the position)
0)
(PROGN (\BLTCHAR CHARCODE STREAM DD)
(add (fetch CHARPOSITION of STREAM)
1]
(IGNORE.CCE)
(SHOULDNT])
(\DSPPRINTCR/LF
[LAMBDA (CHARCODE DS) (* rmk: "14-Sep-84 15:04")
(* CHARCODE is EOL, CR, or LF Assumes that DS has been
checked by \DSPPRINTCHAR)
(* changed to call DSPXPOSITION and DSPYPOSITION instead of \DSPxPOSITION.DISPLAY so that it could be used in the
hardcopy display stream case as well. Could go back to other method if efficiency becomes an issue.)
(COND
((EQ DS (TTYDISPLAYSTREAM))
(\STOPSCROLL?) (* \STOPSCROLL may have turned on the caret.)
(\CHECKCARET DS)))
(PROG (BTM AMOUNT/BELOW Y ROTATION FONT (DD (fetch IMAGEDATA of DS)))
(COND
((AND (fetch DDSlowPrintingCase of DD)
(NEQ (SETQ ROTATION (fetch (FONTDESCRIPTOR ROTATION) of (fetch DDFONT of DD)))
0))
(PROG ((CLIPREG (ffetch DDClippingRegion of DD))
X)
(COND
((EQ CHARCODE (CHARCODE EOL)) (* on LF, no change in X)
(COND
((SETQ Y (fetch DDEOLFN of DD)) (* call the eol function for ds.)
(APPLY* Y DS)))
(DSPYPOSITION (SELECTQ ROTATION
(90 (fetch (REGION BOTTOM) of CLIPREG))
(270 (fetch (REGION TOP) of CLIPREG))
(ERROR "Only rotations supported are 0, 90 and 270"))
DS)))
[SETQ X (IPLUS (fetch DDXPOSITION of DD)
(SELECTQ ROTATION
(90 (IMINUS (ffetch DDLINEFEED of DD)))
(270 (ffetch DDLINEFEED of DD))
(ERROR "Only rotations supported are 0, 90 and 270"]
[COND
((AND (fetch DDScroll of DD)
(SELECTQ ROTATION
(90 (IGREATERP [SETQ AMOUNT/BELOW
(IDIFFERENCE (\DSPTRANSFORMX X DD)
(IDIFFERENCE (fetch
DDClippingRight
of DD)
(fetch \SFDescent
of (fetch DDFONT
of DD]
0))
(270 (IGREATERP (SETQ AMOUNT/BELOW
(IDIFFERENCE (IPLUS (fetch DDClippingLeft
of DD)
(fetch \SFDescent
of (fetch DDFONT
of DD)))
(\DSPTRANSFORMX X DD)))
0))
(SHOULDNT)))
(* automatically scroll up enough to make the entire next character visible. Descent check is so that the bottoms of
characters will be printed also.)
[PROG ((LFT (fetch DDClippingLeft of DD))
WDTH BKGRND (DBITMAP (fetch DDDestination of DD))
HGHT KEPTWIDTH)
(SETQ BTM (fetch DDClippingBottom of DD))
(SETQ HGHT (IDIFFERENCE (ffetch DDClippingTop of DD)
BTM))
(SETQ WDTH (IDIFFERENCE (fetch DDClippingRight of DD)
LFT))
[SETQ BKGRND (COND
((NEQ (fetch (BITMAP BITMAPBITSPERPIXEL) of DBITMAP)
1) (* this is a color case.)
(DSPBACKCOLOR NIL DS))
(T (ffetch DDTexture of DD]
(.WHILE.TOP.DS. DS
(COND
((IGREATERP AMOUNT/BELOW WDTH)
(* scrolling more than the window size, use different
method.)
(* clear the window with background.)
(BITBLT NIL 0 0 DBITMAP LFT BTM WDTH HGHT
(QUOTE TEXTURE)
(QUOTE REPLACE)
BKGRND))
((EQ ROTATION 90)
(BITBLT DBITMAP (IPLUS LFT AMOUNT/BELOW)
BTM DBITMAP LFT BTM (SETQ KEPTWIDTH
(IDIFFERENCE WDTH AMOUNT/BELOW))
HGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT NIL 0 0 DBITMAP (IPLUS LFT KEPTWIDTH)
BTM AMOUNT/BELOW HGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
BKGRND))
(T (BITBLT DBITMAP LFT BTM DBITMAP (IPLUS LFT
AMOUNT/BELOW)
BTM
(IDIFFERENCE WDTH AMOUNT/BELOW)
HGHT
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT NIL 0 0 DBITMAP LFT BTM AMOUNT/BELOW HGHT
(QUOTE TEXTURE)
(QUOTE REPLACE)
BKGRND]
(SETQ X (SELECTQ ROTATION
(90 (IDIFFERENCE X AMOUNT/BELOW))
(IPLUS X AMOUNT/BELOW]
(DSPXPOSITION X DS)))
(T (COND
((EQ CHARCODE (CHARCODE EOL)) (* on LF, no change in X)
(COND
((SETQ Y (fetch DDEOLFN of DD)) (* call the eol function for ds.)
(APPLY* Y DS)))
(DSPXPOSITION (ffetch DDLeftMargin of DD)
DS)))
(SETQ Y (IPLUS (ffetch DDYPOSITION of DD)
(ffetch DDLINEFEED of DD)))
[COND
((AND (fetch DDScroll of DD)
(IGREATERP (SETQ AMOUNT/BELOW (IDIFFERENCE (IPLUS (SETQ BTM
(fetch DDClippingBottom
of DD))
(fetch \SFDescent
of (fetch DDFONT
of DD)))
(\DSPTRANSFORMY Y DD)))
0))
(* automatically scroll up enough to make the entire next character visible. Descent check is so that the bottoms of
characters will be printed also.)
[PROG ((LFT (fetch DDClippingLeft of DD))
WDTH BKGRND (DBITMAP (fetch DDDestination of DD))
(HGHT (IDIFFERENCE (ffetch DDClippingTop of DD)
BTM)))
(SETQ WDTH (IDIFFERENCE (fetch DDClippingRight of DD)
LFT))
[SETQ BKGRND (COND
((NEQ (fetch (BITMAP BITMAPBITSPERPIXEL) of DBITMAP)
1) (* this is a color case.)
(DSPBACKCOLOR NIL DS))
(T (ffetch DDTexture of DD]
(.WHILE.TOP.DS. DS (COND
((IGREATERP AMOUNT/BELOW HGHT)
(* scrolling more than the window size, use different
method.)
(* clear the window with background.)
(BITBLT NIL 0 0 DBITMAP LFT BTM WDTH HGHT (QUOTE TEXTURE)
(QUOTE REPLACE)
BKGRND))
(T (BITBLT DBITMAP LFT BTM DBITMAP LFT (IPLUS BTM
AMOUNT/BELOW)
WDTH
(IDIFFERENCE HGHT AMOUNT/BELOW)
(QUOTE INPUT)
(QUOTE REPLACE))
(BITBLT NIL 0 0 DBITMAP LFT BTM WDTH AMOUNT/BELOW
(QUOTE TEXTURE)
(QUOTE REPLACE)
BKGRND]
(SETQ Y (IPLUS Y AMOUNT/BELOW]
(DSPYPOSITION Y DS])
)
(DEFINEQ
(\TTYBACKGROUND
[LAMBDA NIL (* bvm: "24-OCT-83 17:27")
(* called each time through a tty keyboard wait loop. First executes the TTYBACKGROUNDFNS which do things like
flashing the caret (and SAVEVM) and then allows other background things to run (including other processes.))
(OR (TTY.PROCESSP)
(PROCESS.PREPARE.FOR.INPUT))
(for X in TTYBACKGROUNDFNS do (APPLY* X))
(\BACKGROUND])
)
(DEFINEQ
(DSPBACKUP
[LAMBDA (WIDTH DISPLAYSTREAM) (* rrb "21-Aug-84 10:30")
(PROG (FONT ROTATION BLTWIDTH XPOS (DD (\GETDISPLAYDATA DISPLAYSTREAM DISPLAYSTREAM)))
[SETQ BLTWIDTH (IMIN WIDTH (IDIFFERENCE (SETQ XPOS (fetch DDXPOSITION of DD))
(ffetch DDLeftMargin of DD]
(SETQ FONT (fetch DDFONT of DD))
(SETQ ROTATION (COND
((fetch DDSlowPrintingCase of DD)
(fetch (FONTDESCRIPTOR ROTATION) of FONT))
(T 0)))
(RETURN (COND
((IGREATERP BLTWIDTH 0)
(\CHECKCARET DISPLAYSTREAM)
[COND
((EQ ROTATION 0) (* uses DSPXPOSITION so that it works on both display
streams and hardcopy display streams.)
(DSPXPOSITION (IDIFFERENCE XPOS BLTWIDTH)
DISPLAYSTREAM)
(BITBLT NIL 0 0 DISPLAYSTREAM (fetch DDXPOSITION of DD)
(IDIFFERENCE (ffetch DDYPOSITION of DD)
(FONTDESCENT FONT))
BLTWIDTH
(FONTHEIGHT FONT)
(QUOTE TEXTURE)
(QUOTE REPLACE)))
((EQ ROTATION 90)
(BITBLT NIL 0 0 DISPLAYSTREAM (IDIFFERENCE (fetch DDXPOSITION of DD)
(FONTASCENT FONT))
(add (fetch DDYPOSITION of DD)
(IMINUS BLTWIDTH))
(FONTHEIGHT FONT)
BLTWIDTH
(QUOTE TEXTURE)
(QUOTE REPLACE)))
((EQ ROTATION 270)
(BITBLT NIL 0 0 DISPLAYSTREAM (IDIFFERENCE (fetch DDXPOSITION of DD)
(FONTDESCENT FONT))
(add (fetch DDYPOSITION of DD)
BLTWIDTH)
(FONTHEIGHT FONT)
BLTWIDTH
(QUOTE TEXTURE)
(QUOTE REPLACE]
T])
)
(RPAQ? \CARET.UP )
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQQ BELLCNT 2)
(RPAQQ BELLRATE 60)
(RPAQQ \DisplayStoppedForLogout NIL)
(RPAQQ TtyDisplayStream NIL)
)
(DEFINEQ
(COLORDISPLAYP
[LAMBDA NIL (* rrb "16-Feb-84 18:50")
(* is the color display on?)
\SystemColorMap])
)
(DEFINEQ
(DISPLAYBEFOREEXIT
[LAMBDA (EXITFN) (* hdj " 5-Feb-85 12:44")
(COND
((DISPLAYSTARTEDP) (* save cursor and background border so that they can
be restored by DISPLAYAFTERENTRY when this sysout is
restarted.)
[SETQ \DisplayStoppedForLogout (CONS (CURSOR)
(AND (EQ \MACHINETYPE \DANDELION)
(CHANGEBACKGROUNDBORDER]
(SELECTQ EXITFN
(LOGOUT (* Shut off display during logout)
(SHOWDISPLAY))
(MAKESYS (* on MAKESYS, clear screen)
(DSPRESET (TTYDISPLAYSTREAM))
(AND (WINDOWWORLDP)
(DSPRESET PROMPTWINDOW)))
(SYSOUT NIL)
(SHOULDNT])
(DISPLAYAFTERENTRY
[LAMBDA (ENTRYFN) (* hdj " 5-Feb-85 17:33")
(* set address of Cursor bitmap every time because it
changes from machine to machine and StartDisplay is a
convenient place to reset it.)
(replace BITMAPBASE of CursorBitMap with \EM.CURSORBITMAP)
(COND
(\DisplayStoppedForLogout (\STARTDISPLAY) (* restore the cursor.)
(CURSOR (CAR \DisplayStoppedForLogout))
(* restore the display border.
Only does anything on a DANDELION)
(CHANGEBACKGROUNDBORDER (CDR \DisplayStoppedForLogout))
(SETQ \DisplayStoppedForLogout NIL)))
(* reset the time that the caret will flash.)
(COND
((GETD (QUOTE CARETRATE)) (* the caret rate has some global state which depends
on the machine dependent clock.
This resets the internal state)
(CARETRATE (CARETRATE])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS BELLCNT BELLRATE TTYBACKGROUNDFNS \DisplayStoppedForLogout \SystemColorMap \CARET.UP)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS \CHECKCARET MACRO ((X)
(AND \CARET.UP (\CARET.DOWN X))))
)
(* END EXPORTED DEFINITIONS)
(* transformation related functions.)
(DEFINEQ
(\DSPCLIPTRANSFORMX
[LAMBDA (X DD) (* rmk: "23-AUG-83 15:03")
(* returns the transformed coordinate value of X in the system of the destination. It also clips according to the
clipping region and returns NIL if it falls outside.)
(PROG ((TX (\DSPTRANSFORMX X DD)))
(RETURN (AND (NOT (IGREATERP (fetch DDClippingLeft of DD)
TX))
(IGREATERP (fetch DDClippingRight of DD)
TX)
TX])
(\DSPCLIPTRANSFORMY
[LAMBDA (Y DD) (* rmk: "23-AUG-83 15:09")
(* returns the transformed coordinate value of Y in the system of the destination. It also clips according to the
clipping region and returns NIL if it falls outside.)
(PROG ((TY (\DSPTRANSFORMY Y DD))) (* ClippingTop points past the top edge.)
(RETURN (AND (NOT (IGREATERP (fetch DDClippingBottom of DD)
TY))
(IGREATERP (fetch DDClippingTop of DD)
TY)
TY])
(\DSPTRANSFORMREGION
[LAMBDA (REGION DS) (* rrb " 3-DEC-80 18:11")
(* transforms a region into the destination coordinates
of the display stream.)
(create REGION
LEFT ←(\DSPTRANSFORMX (fetch LEFT of REGION)
DS)
BOTTOM ←(\DSPTRANSFORMY (fetch BOTTOM of REGION)
DS)
WIDTH ←(fetch WIDTH of REGION)
HEIGHT ←(fetch HEIGHT of REGION])
(\DSPUNTRANSFORMY
[LAMBDA (Y DD) (* rmk: "23-AUG-83 14:34")
(* transforms a y coordinate from destination coords
into the display streams)
(IDIFFERENCE Y (fetch DDYOFFSET of DD])
(\DSPUNTRANSFORMX
[LAMBDA (X DD) (* rmk: "23-AUG-83 14:25")
(* transforms a x coordinate from destination coords
into the display streams)
(IDIFFERENCE X (fetch DDXOFFSET of DD])
(\OFFSETCLIPPINGREGION
[LAMBDA (DD OLDREGION) (* bvm: "14-Feb-85 00:45")
(* calculates the clipping region from the displaydata
of a display stream in destination coordinates.
if OLDREGION is given, it is reused.)
(PROG ((CREG (fetch DDClippingRegion of DD)))
(RETURN (COND
(OLDREGION (replace LEFT of OLDREGION with (\DSPTRANSFORMX (fetch LEFT
of CREG)
DD))
(replace BOTTOM of OLDREGION with (\DSPTRANSFORMY (fetch BOTTOM
of CREG)
DD))
(replace WIDTH of OLDREGION with (fetch WIDTH of CREG))
(replace HEIGHT of OLDREGION with (fetch HEIGHT of CREG))
OLDREGION)
((AND (EQ (fetch DDXOFFSET of DD)
0)
(EQ (fetch DDYOFFSET of DD)
0)) (* special case of no offset to avoid storage
creation.)
CREG)
(T (create REGION
LEFT ←(\DSPTRANSFORMX (fetch LEFT of CREG)
DD)
BOTTOM ←(\DSPTRANSFORMY (fetch BOTTOM of CREG)
DD)
WIDTH ←(fetch WIDTH of CREG)
HEIGHT ←(fetch HEIGHT of CREG])
)
(DECLARE: DONTCOPY
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS \DSPTRANSFORMX MACRO ((X DD) (* transforms an x coordinate into the destination
coordinate.)
(IPLUS X (fetch DDXOFFSET of DD))))
(PUTPROPS \DSPTRANSFORMY MACRO ((Y DD) (* transforms an y coordinate into the destination
coordinate.)
(IPLUS Y (fetch DDYOFFSET of DD))))
(PUTPROPS \OFFSETBOTTOM MACRO ((X) (* gives the destination coordinate address of the
origin.)
(fetch DDYOFFSET of X)))
(PUTPROPS \OFFSETLEFT MACRO ((DD) (* returns the x origin of display data destination
coordinates.)
(fetch DDXOFFSET of DD)))
)
(* END EXPORTED DEFINITIONS)
)
(* screen related functions)
(DEFINEQ
(UPDATESCREENWIDTH
[LAMBDA NIL (* sets the vaariable SCREENWIDTH from the interface
page that gives the hardware width.)
(SETQ SCREENWIDTH (ITIMES BITSPERWORD (SCREENRASTERWIDTH])
(SCREENRASTERWIDTH
[LAMBDA NIL (* bas: " 7-APR-81 00:28")
(fetch ScreenWidth of \InterfacePage])
(\CreateScreenBitMap
[LAMBDA (WIDTH HEIGHT) (* bvm: "25-MAR-83 11:12")
(DECLARE (GLOBALVARS \MaxScreenPage))
(* creates and locks the pages for the display bit map. Returns a BITMAP descriptor for it.
Uses the first words of the segment \DISPLAYREGION.)
(PROG ((RASTERWIDTH (FOLDHI (CEIL WIDTH (UNFOLD \DisplayWordAlign BITSPERWORD))
BITSPERWORD))
MAXPAGE#) (* the display microcode needs to have the display fall
on \DisplayWordAlign word boundaries.)
(COND
((IGREATERP (SETQ MAXPAGE# (SUB1 (FOLDHI (ITIMES RASTERWIDTH HEIGHT)
WORDSPERPAGE)))
\MaxScreenPage)
(* new screen size is larger, allocate more pages. All pages are locked. NOERROR is true in \NEWPAGE call in case
pages are already there, e.g. DLBOOT allocated them.)
(for I from (ADD1 \MaxScreenPage) to MAXPAGE# do (\NEWPAGE (\ADDBASE \DISPLAYREGION
(UNFOLD I
WORDSPERPAGE))
T T))
(SETQ \MaxScreenPage MAXPAGE#)))
(RETURN (COND
((BITMAPP ScreenBitMap) (* reuse the same BITMAP ptr so that it will stay EQ to
the one in user datastructures.)
(replace BITMAPBASE of ScreenBitMap with \DISPLAYREGION)
(replace BITMAPWIDTH of ScreenBitMap with WIDTH)
(replace BITMAPRASTERWIDTH of ScreenBitMap with RASTERWIDTH)
(replace BITMAPHEIGHT of ScreenBitMap with HEIGHT)
ScreenBitMap)
(T (create BITMAP
BITMAPBASE ← \DISPLAYREGION
BITMAPRASTERWIDTH ← RASTERWIDTH
BITMAPWIDTH ← WIDTH
BITMAPHEIGHT ← HEIGHT])
)
(DECLARE: DONTEVAL@LOAD DOCOPY
(UPDATESCREENWIDTH)
(RPAQQ SCREENHEIGHT 808)
(RPAQQ \MaxScreenPage -1)
(RPAQ ScreenBitMap (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT))
)
(* initialization)
(RPAQ? LastCreatedDisplayDevice )
(DEFINEQ
(\CoerceToDisplayDevice
[LAMBDA (NameOrDevice) (* hdj " 4-Feb-85 09:34")
(DECLARE (GLOBALVARS LastCreatedDisplayDevice))
(LET ((DEV (OR NameOrDevice LastCreatedDisplayDevice)))
(if (type? FDEV DEV)
then DEV
else (\GETDEVICEFROMNAME DEV NIL T])
(\CREATEDISPLAY
[LAMBDA (DISPLAYNAME DEVICEMETHODS DEVICEDATA DEVICEEVENT)
(* hdj "11-Feb-85 15:34")
(* * create a new display device. Mainly used by device-independent color code)
(DECLARE (GLOBALVARS LastCreatedDisplayDevice))
(LET [(DEVICE (create FDEV
DEVICENAME ←(LIST DISPLAYNAME (QUOTE COLOR)
(QUOTE DISPLAY))
RESETABLE ← NIL
RANDOMACCESSP ← NIL
PAGEMAPPED ← NIL
CLOSEFILE ←(FUNCTION NILL)
DELETEFILE ←(FUNCTION NILL)
GETFILEINFO ←(FUNCTION NILL)
OPENFILE ←(FUNCTION [LAMBDA (NAME ACCESS RECOG OTHERINFO FDEV)
NAME])
READPAGES ←(FUNCTION \ILLEGAL.DEVICEOP)
SETFILEINFO ←(FUNCTION NILL)
GENERATEFILES ←(FUNCTION \GENERATENOFILES)
TRUNCATEFILE ←(FUNCTION NILL)
WRITEPAGES ←(FUNCTION \ILLEGAL.DEVICEOP)
GETFILENAME ←(FUNCTION [LAMBDA (NAME RECOG FDEV)
NAME])
REOPENFILE ←(FUNCTION [LAMBDA (NAME)
NAME])
EVENTFN ← DEVICEEVENT
DIRECTORYNAMEP ←(FUNCTION NILL)
HOSTNAMEP ←(FUNCTION NILL)
BIN ←(FUNCTION \ILLEGAL.DEVICEOP)
BOUT ←(FUNCTION \DSPPRINTCHAR)
PEEKBIN ←(FUNCTION \ILLEGAL.DEVICEOP)
BACKFILEPTR ←(FUNCTION \PAGEDBACKFILEPTR)
BLOCKIN ←(FUNCTION \ILLEGAL.DEVICEOP)
BLOCKOUT ←(FUNCTION \NONPAGEDBOUTS)
WINDOWOPS ← DEVICEMETHODS
WINDOWDATA ← DEVICEDATA
DEVICEINFO ←(create DISPLAYSTATE]
(\DEFINEDEVICE DISPLAYNAME DEVICE)
(SETQ LastCreatedDisplayDevice DEVICE])
(DISPLAYSTREAMINIT
[LAMBDA (N) (* rmk: "23-AUG-83 22:22")
(DECLARE (GLOBALVARS \LastTTYLines \TopLevelTtyWindow))
(* starts display and sets N lines for tty at top)
(\STARTDISPLAY)
(PROG (TTYHEIGHT TTYFONTHEIGHT (TTYFONT (DSPFONT NIL TtyDisplayStream)))
(SETQ TTYFONTHEIGHT (FONTHEIGHT TTYFONT))
(DSPDESTINATION (SCREENBITMAP)
TtyDisplayStream) (* this is done here so that processes that are created
before window world is turned on have an acceptable
binding for their tty.)
(SETQ \TopLevelTtyWindow (SETQ \DEFAULTTTYDISPLAYSTREAM TtyDisplayStream))
(RETURN (PROG1 \LastTTYLines (SETQ TTYHEIGHT (ITIMES (COND
[(NUMBERP N)
(SETQ \LastTTYLines
(COND
((IGREATERP (ITIMES N
TTYFONTHEIGHT)
SCREENHEIGHT)
(* too many lines, reduce to fit leaving two lines
bottom margin.)
(IDIFFERENCE (IQUOTIENT
SCREENHEIGHT
TTYFONTHEIGHT)
2))
(T N]
(T \LastTTYLines))
TTYFONTHEIGHT))
(* put TTY region on top)
(DSPYOFFSET (IDIFFERENCE SCREENHEIGHT TTYHEIGHT)
TtyDisplayStream)
(DSPYPOSITION (FONTDESCENT TTYFONT)
TtyDisplayStream)
(DSPXOFFSET 0 TtyDisplayStream)
(DSPCLIPPINGREGION (create REGION
LEFT ← 0
BOTTOM ← 0
WIDTH ← SCREENWIDTH
HEIGHT ← TTYHEIGHT)
TtyDisplayStream)
(* called after clipping region for TTYDISPLAYSTREAM has
been set so that \#DISPLAYLINES will get set correctly.)
(DSPRIGHTMARGIN SCREENWIDTH TtyDisplayStream])
(\STARTDISPLAY
[LAMBDA NIL (* bvm: "25-MAR-83 11:15")
(DECLARE (GLOBALVARS \MouseEnabled \MouseEventQueue))
(UPDATESCREENWIDTH)
(SETQ ScreenBitMap (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT))
(UNINTERRUPTABLY
(SHOWDISPLAY (fetch BITMAPBASE of ScreenBitMap)
(fetch BITMAPRASTERWIDTH of ScreenBitMap))
(CHANGETTYDEVICE (QUOTE LISPDISPLAY))
[COND
(\MouseEnabled (* reenable mouse if it was enabled before Logout.)
(\LOCKPAGES \MouseEventQueue 1)
(ENABLEMOUSE (CAR \MouseEnabled)
(CDR \MouseEnabled]
(SETQ \DisplayStarted T))
(SETQ WHOLESCREEN (SETQ WHOLEDISPLAY
(create REGION
LEFT ← 0
BOTTOM ← 0
WIDTH ← SCREENWIDTH
HEIGHT ← SCREENHEIGHT])
(\STOPDISPLAY
[LAMBDA NIL (* bvm: "25-MAR-83 11:18")
(DECLARE (GLOBALVARS \MaxScreenPage)) (* Turn off Lisp display, go back to bcpl display.
Exists only for emergency use)
(UNINTERRUPTABLY
(SHOWDISPLAY)
(CHANGETTYDEVICE (QUOTE BCPLDISPLAY))
(\UNLOCKPAGES (fetch BITMAPBASE of ScreenBitMap)
(ADD1 \MaxScreenPage))
(SETQ \MaxScreenPage -1)
(SETQ \DisplayStarted NIL))
(PAGEHEIGHT 58])
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \DisplayStarted \DisplayStreamsInitialized \DisplayInitialed WHOLEDISPLAY WHOLESCREEN)
)
(* END EXPORTED DEFINITIONS)
(ADDTOVAR GLOBALVARS WHOLESCREEN)
(DECLARE: DONTEVAL@LOAD DOCOPY
(RPAQQ \DisplayStarted NIL)
(RPAQQ \LastTTYLines 12)
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS DISPLAYINITIALIZEDP MACRO (NIL (* always initialized now)
T))
(PUTPROPS DISPLAYSTARTEDP MACRO (NIL \DisplayStarted))
)
(* END EXPORTED DEFINITIONS)
(DEFINEQ
(INITIALIZEDISPLAYSTREAMS
[LAMBDA NIL
(DECLARE (GLOBALVARS TtyDisplayStream.SAVE)) (* rmk: "20-Sep-84 11:44")
(SETQ WHOLEDISPLAY (create REGION))
(SETQ \SYSPILOTBBT (create PILOTBBT)) (* For BITBLT)
(SETQ \SYSBBTEXTURE (BITMAPCREATE 16 16)) (* For texture handling in \BITBLTSUB)
(* A guaranteed display font is initialized here after
pup, font, and bitmap code has been loaded.)
(SETQ \GUARANTEEDDISPLAYFONT (FONTCREATE (QUOTE GACHA)
10 NIL NIL (QUOTE DISPLAY)))
(SETQ DEFAULTFONT (FONTCLASS (QUOTE DEFAULTFONT)
(LIST 1 \GUARANTEEDDISPLAYFONT)))
(SETQ TtyDisplayStream.SAVE (DSPCREATE])
)
(DECLARE: DOCOPY DONTEVAL@LOAD
(INITIALIZEDISPLAYSTREAMS)
(DISPLAYSTREAMINIT 1000)
)
(PUTPROPS LLDISPLAY COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (10858 12571 (\FBITMAPBIT 10868 . 11399) (\NEWPAGE.DISPLAY 11401 . 11540) (INITBITMASKS
11542 . 12569)) (13387 13881 (\CreateCursorBitMap 13397 . 13879)) (13993 44366 (BITBLT 14003 . 18232)
(BLTSHADE 18234 . 18893) (\BITBLTSUB 18895 . 25198) (\GETPILOTBBTSCRATCHBM 25200 . 25874) (BITMAPCOPY
25876 . 26433) (BITMAPCREATE 26435 . 27474) (BITMAPBIT 27476 . 32479) (BLTCHAR 32481 . 32968) (
\BLTCHAR 32970 . 35684) (\SLOWBLTCHAR 35686 . 40244) (TEXTUREP 40246 . 40480) (INVERT.TEXTURE 40482 .
40733) (INVERT.TEXTURE.BITMAP 40735 . 41904) (BITMAPWIDTH 41906 . 42653) (READBITMAP 42655 . 44364)) (
44367 81577 (\BITBLT.1BITDISPLAY 44377 . 50203) (\BITBLT.BITMAP 50205 . 57376) (\BITBLT.COLORDISPLAY
57378 . 65414) (\BITBLT.MERGE 65416 . 67464) (\BLTSHADE.1BITDISPLAY 67466 . 71532) (\BLTSHADE.BITMAP
71534 . 76452) (\BLTSHADE.COLORDISPLAY 76454 . 81575)) (84281 87067 (DISPLAYSTREAMP 84291 . 84638) (
DSPSOURCETYPE 84640 . 85463) (DSPXOFFSET 85465 . 86330) (DSPYOFFSET 86332 . 87065)) (87068 97949 (
DSPCREATE 87078 . 88495) (DSPDESTINATION 88497 . 89501) (DSPTEXTURE 89503 . 90143) (
\DISPLAYSTREAMINCRXPOSITION 90145 . 90486) (\SFFixDestination 90488 . 91957) (\SFFixClippingRegion
91959 . 93467) (\SFFixFont 93469 . 95240) (\SFFIXLINELENGTH 95242 . 96088) (\SFFixY 96090 . 97947)) (
97950 105858 (\DSPCLIPPINGREGION.DISPLAY 97960 . 98629) (\DSPFONT.DISPLAY 98631 . 99961) (
\DSPFONT.COLORDISPLAY 99963 . 101721) (\DSPLINEFEED.DISPLAY 101723 . 102242) (\DSPLEFTMARGIN.DISPLAY
102244 . 102914) (\DSPOPERATION.DISPLAY 102916 . 103752) (\DSPRIGHTMARGIN.DISPLAY 103754 . 104595) (
\DSPXPOSITION.DISPLAY 104597 . 105381) (\DSPYPOSITION.DISPLAY 105383 . 105856)) (108184 112304 (
TTYDISPLAYSTREAM 108194 . 111537) (\REMOVEDRIBBLECHECK 111539 . 111979) (\ADDDRIBBLECHECK 111981 .
112302)) (112558 116205 (DSPSCROLL 112568 . 113111) (CHANGETTYDEVICE 113113 . 115483) (OUTPUTDSP
115485 . 115860) (PAGEHEIGHT 115862 . 116203)) (116287 128862 (\DSPRESET.DISPLAY 116297 . 118301) (
\DSPPRINTCHAR 118303 . 121700) (\DSPPRINTCR/LF 121702 . 128860)) (128863 129361 (\TTYBACKGROUND 128873
. 129359)) (129362 131087 (DSPBACKUP 129372 . 131085)) (131270 131507 (COLORDISPLAYP 131280 . 131505)
) (131508 133616 (DISPLAYBEFOREEXIT 131518 . 132384) (DISPLAYAFTERENTRY 132386 . 133614)) (133981
137741 (\DSPCLIPTRANSFORMX 133991 . 134512) (\DSPCLIPTRANSFORMY 134514 . 135103) (\DSPTRANSFORMREGION
135105 . 135635) (\DSPUNTRANSFORMY 135637 . 135963) (\DSPUNTRANSFORMX 135965 . 136291) (
\OFFSETCLIPPINGREGION 136293 . 137739)) (138687 140948 (UPDATESCREENWIDTH 138697 . 138956) (
SCREENRASTERWIDTH 138958 . 139122) (\CreateScreenBitMap 139124 . 140946)) (141203 146651 (
\CoerceToDisplayDevice 141213 . 141552) (\CREATEDISPLAY 141554 . 143210) (DISPLAYSTREAMINIT 143212 .
145273) (\STARTDISPLAY 145275 . 146116) (\STOPDISPLAY 146118 . 146649)) (147255 148115 (
INITIALIZEDISPLAYSTREAMS 147265 . 148113)))))
STOP