(FILECREATED "15-Aug-85 15:08:54" {ERIS}<LISPCORE>SOURCES>LLDISPLAY.;52 166337
changes to: (FNS \MOVE.WINDOWS.ONTO.SCREEN)
previous date: "13-Aug-85 19:02:53" {ERIS}<LISPCORE>SOURCES>LLDISPLAY.;50)
(* 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
\BITMAPBIT BLTCHAR \BLTCHAR \CHANGECHARSET.DISPLAY \INDICATESTRING \SLOWBLTCHAR
TEXTUREP INVERT.TEXTURE INVERT.TEXTURE.BITMAP BITMAPWIDTH READBITMAP)
(DECLARE: DONTCOPY (MACROS \INVALIDATEDISPLAYCACHE))
(MACROS BITMAPBIT)
(FNS BITMAPBIT.EXPANDER)
(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 UPDATESCREENDIMENSIONS \CreateScreenBitMap)
[DECLARE: DONTEVAL@LOAD DOCOPY (P (UPDATESCREENDIMENSIONS))
(INITVARS (SCREENHEIGHT 808)
(SCREENWIDTH 1024)
(\OLDSCREENHEIGHT 808)
(\OLDSCREENWIDTH 1024)
(\MaxScreenPage -1)
(ScreenBitMap (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT]
(GLOBALVARS \OLDSCREENHEIGHT \OLDSCREENWIDTH \MaxScreenPage ScreenBitMap))
(COMS (* initialization)
(INITVARS (LastCreatedDisplayDevice))
(FNS \CoerceToDisplayDevice \CREATEDISPLAY DISPLAYSTREAMINIT \STARTDISPLAY
\MOVE.WINDOWS.ONTO.SCREEN \UPDATE.PBT.RASTERWIDTHS \STOPDISPLAY)
(DECLARE: EVAL@COMPILE DONTCOPY (ADDVARS (DONTCOMPILEFNS \UPDATE.PBT.RASTERWIDTHS)))
(EXPORT (MACROS DISPLAYINITIALIZEDP DISPLAYSTARTEDP)
(GLOBALVARS \DisplayStarted \DisplayStreamsInitialized \DisplayInitialed
WHOLEDISPLAY WHOLESCREEN SCREENWIDTH SCREENHEIGHT))
(ADDVARS (GLOBALVARS WHOLESCREEN))
(FNS INITIALIZEDISPLAYSTREAMS)
(DECLARE: DOCOPY DONTEVAL@LOAD (VARS (\DisplayStarted NIL)
(\LastTTYLines 12))
(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 DDCHARSET (DDCHARSETASCENT WORD)
(DDCHARSETDESCENT WORD)
DDCHARHEIGHTDELTA
(DDSPACEWIDTH WORD))
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))
[QUOTE ((PILOTBBT 0 (BITS . 15))
(PILOTBBT 1 (BITS . 15))
(PILOTBBT 2 (BITS . 15))
(PILOTBBT 3 (SIGNEDBITS . 15))
(PILOTBBT 4 (BITS . 15))
(PILOTBBT 5 (BITS . 15))
(PILOTBBT 6 (BITS . 15))
(PILOTBBT 7 (SIGNEDBITS . 15))
(PILOTBBT 8 (BITS . 15))
(PILOTBBT 9 (BITS . 15))
(PILOTBBT 10 (BITS . 15))
(PILOTBBT 11 (BITS . 15))
(PILOTBBT 12 (BITS . 15))
(PILOTBBT 13 (BITS . 15))
(PILOTBBT 14 (BITS . 15))
(PILOTBBT 15 (BITS . 15]
(QUOTE 16))
(/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 POINTER
WORD WORD POINTER WORD))
[QUOTE ((\DISPLAYDATA 0 POINTER)
(\DISPLAYDATA 2 POINTER)
(\DISPLAYDATA 4 POINTER)
(\DISPLAYDATA 6 POINTER)
(\DISPLAYDATA 8 POINTER)
(\DISPLAYDATA 10 POINTER)
(\DISPLAYDATA 12 POINTER)
(\DISPLAYDATA 14 POINTER)
(\DISPLAYDATA 16 POINTER)
(\DISPLAYDATA 18 POINTER)
(\DISPLAYDATA 20 POINTER)
(\DISPLAYDATA 22 POINTER)
(\DISPLAYDATA 24 POINTER)
(\DISPLAYDATA 26 POINTER)
(\DISPLAYDATA 28 POINTER)
(\DISPLAYDATA 30 POINTER)
(\DISPLAYDATA 32 POINTER)
(\DISPLAYDATA 34 (BITS . 15))
(\DISPLAYDATA 35 (BITS . 15))
(\DISPLAYDATA 36 (BITS . 15))
(\DISPLAYDATA 37 (BITS . 15))
(\DISPLAYDATA 38 (BITS . 15))
(\DISPLAYDATA 32 (FLAGBITS . 0))
(\DISPLAYDATA 40 XPOINTER)
(\DISPLAYDATA 42 POINTER)
(\DISPLAYDATA 44 POINTER)
(\DISPLAYDATA 46 POINTER)
(\DISPLAYDATA 48 POINTER)
(\DISPLAYDATA 50 POINTER)
(\DISPLAYDATA 52 POINTER)
(\DISPLAYDATA 54 POINTER)
(\DISPLAYDATA 56 POINTER)
(\DISPLAYDATA 58 POINTER)
(\DISPLAYDATA 60 POINTER)
(\DISPLAYDATA 62 POINTER)
(\DISPLAYDATA 39 (BITS . 15))
(\DISPLAYDATA 64 (BITS . 15))
(\DISPLAYDATA 66 POINTER)
(\DISPLAYDATA 65 (BITS . 15]
(QUOTE 68))
(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))
[QUOTE ((BITMAP 0 POINTER)
(BITMAP 2 (BITS . 15))
(BITMAP 3 (BITS . 15))
(BITMAP 4 (BITS . 15))
(BITMAP 5 (BITS . 15]
(QUOTE 6))
(/DECLAREDATATYPE (QUOTE PILOTBBT)
(QUOTE (WORD WORD WORD SIGNEDWORD WORD WORD WORD SIGNEDWORD WORD WORD WORD WORD
WORD WORD WORD WORD))
[QUOTE ((PILOTBBT 0 (BITS . 15))
(PILOTBBT 1 (BITS . 15))
(PILOTBBT 2 (BITS . 15))
(PILOTBBT 3 (SIGNEDBITS . 15))
(PILOTBBT 4 (BITS . 15))
(PILOTBBT 5 (BITS . 15))
(PILOTBBT 6 (BITS . 15))
(PILOTBBT 7 (SIGNEDBITS . 15))
(PILOTBBT 8 (BITS . 15))
(PILOTBBT 9 (BITS . 15))
(PILOTBBT 10 (BITS . 15))
(PILOTBBT 11 (BITS . 15))
(PILOTBBT 12 (BITS . 15))
(PILOTBBT 13 (BITS . 15))
(PILOTBBT 14 (BITS . 15))
(PILOTBBT 15 (BITS . 15]
(QUOTE 16))
(/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 POINTER
WORD WORD POINTER WORD))
[QUOTE ((\DISPLAYDATA 0 POINTER)
(\DISPLAYDATA 2 POINTER)
(\DISPLAYDATA 4 POINTER)
(\DISPLAYDATA 6 POINTER)
(\DISPLAYDATA 8 POINTER)
(\DISPLAYDATA 10 POINTER)
(\DISPLAYDATA 12 POINTER)
(\DISPLAYDATA 14 POINTER)
(\DISPLAYDATA 16 POINTER)
(\DISPLAYDATA 18 POINTER)
(\DISPLAYDATA 20 POINTER)
(\DISPLAYDATA 22 POINTER)
(\DISPLAYDATA 24 POINTER)
(\DISPLAYDATA 26 POINTER)
(\DISPLAYDATA 28 POINTER)
(\DISPLAYDATA 30 POINTER)
(\DISPLAYDATA 32 POINTER)
(\DISPLAYDATA 34 (BITS . 15))
(\DISPLAYDATA 35 (BITS . 15))
(\DISPLAYDATA 36 (BITS . 15))
(\DISPLAYDATA 37 (BITS . 15))
(\DISPLAYDATA 38 (BITS . 15))
(\DISPLAYDATA 32 (FLAGBITS . 0))
(\DISPLAYDATA 40 XPOINTER)
(\DISPLAYDATA 42 POINTER)
(\DISPLAYDATA 44 POINTER)
(\DISPLAYDATA 46 POINTER)
(\DISPLAYDATA 48 POINTER)
(\DISPLAYDATA 50 POINTER)
(\DISPLAYDATA 52 POINTER)
(\DISPLAYDATA 54 POINTER)
(\DISPLAYDATA 56 POINTER)
(\DISPLAYDATA 58 POINTER)
(\DISPLAYDATA 60 POINTER)
(\DISPLAYDATA 62 POINTER)
(\DISPLAYDATA 39 (BITS . 15))
(\DISPLAYDATA 64 (BITS . 15))
(\DISPLAYDATA 66 POINTER)
(\DISPLAYDATA 65 (BITS . 15]
(QUOTE 68))
(* 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])
(\BITMAPBIT
[LAMBDA (BITMAP X Y NEWVALUE) (* hdj " 9-Jul-85 19:29")
(* reads and optionally sets a bit in a bitmap.
If bitmap is a displaystream, it works on the
destination through the coordinate transformations.)
(* works for multiple bit per pixel bitmaps.)
(PROG (NBITS BITX OLDVALUE oldword bitmapbase)
(RETURN
(COND
[(type? BITMAP BITMAP) (* BITMAP is a 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]
[(type? WINDOW BITMAP)
(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]
((STREAMP BITMAP) (* BITMAP is an imagestream)
(if NEWVALUE
then (IMAGEOP (QUOTE IMWRITEPIXEL)
(SETQ BITMAP (\OUTSTREAMARG BITMAP))
BITMAP X Y NEWVALUE)
else (ERROR "Can't read a pixel from an imagestream" BITMAP)))
(T (\ILLEGAL.ARG BITMAP])
(BLTCHAR
[LAMBDA (CHARCODE DISPLAYSTREAM) (* rmk: " 4-Apr-85 11:45")
(* 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 (COND
((\CHARCODEP CHARCODE)
CHARCODE)
(T (\ILLEGAL.ARG CHARCODE)))
DISPLAYSTREAM
(\GETDISPLAYDATA DISPLAYSTREAM])
(\BLTCHAR
[LAMBDA (CHARCODE DISPLAYSTREAM DISPLAYDATA) (* rmk: "26-Apr-85 08:48")
(* 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 (CHAR8CODE (\CHAR8CODE CHARCODE)))
CRLP[COND
((NEQ (ffetch DDCHARSET of DISPLAYDATA)
(\CHARSET CHARCODE))
(\CHANGECHARSET.DISPLAY DISPLAYDATA (\CHARSET CHARCODE]
[COND
((ffetch (\DISPLAYDATA DDSlowPrintingCase) of DISPLAYDATA)
(RETURN (\SLOWBLTCHAR CHARCODE DISPLAYSTREAM]
[COND
((IGREATERP (SETQ RIGHT (IPLUS (SETQ CURX (ffetch DDXPOSITION of DISPLAYDATA))
(\DSPGETCHARWIDTH CHAR8CODE 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 CHAR8CODE
DISPLAYDATA)
LEFT)
CURX))
(\PILOTBITBLT LOCAL1 0))
T])
(\CHANGECHARSET.DISPLAY
[LAMBDA (DISPLAYDATA CHARSET) (* rmk: "11-Apr-85 17:29")
(* Called when the character set information cached in
a display stream doesn't correspond to CHARSET)
(PROG [BM (PBT (ffetch DDPILOTBBT of DISPLAYDATA))
(CSINFO (\GETCHARSETINFO CHARSET (ffetch DDFONT of DISPLAYDATA]
(UNINTERRUPTABLY
(freplace DDWIDTHSCACHE of DISPLAYDATA with (ffetch (CHARSETINFO WIDTHS) of CSINFO))
(freplace DDOFFSETSCACHE of DISPLAYDATA with (ffetch (CHARSETINFO OFFSETS)
of CSINFO))
(freplace DDCHARIMAGEWIDTHS of DISPLAYDATA with (ffetch (CHARSETINFO IMAGEWIDTHS)
of CSINFO))
(freplace DDCHARSET of DISPLAYDATA with CHARSET)
(SETQ BM (ffetch CHARSETBITMAP of CSINFO))
(freplace PBTSOURCEBPL of PBT with (UNFOLD (ffetch BITMAPRASTERWIDTH of BM)
BITSPERWORD))
[if (OR (NEQ (ffetch DDCHARSETASCENT of DISPLAYDATA)
(ffetch CHARSETASCENT of CSINFO))
(NEQ (ffetch DDCHARSETDESCENT of DISPLAYDATA)
(ffetch CHARSETDESCENT of CSINFO)))
then (\SFFixY DISPLAYDATA CSINFO)
else (freplace PBTSOURCE of PBT with (\ADDBASE (ffetch BITMAPBASE of BM)
(ITIMES (ffetch BITMAPRASTERWIDTH
of BM)
(ffetch DDCHARHEIGHTDELTA
of DISPLAYDATA])])
(\INDICATESTRING
[LAMBDA (CHARCODE) (* rmk: "26-Apr-85 10:27")
(* This returns the string of characters by which CHARCODE would be indicated on the display.
This could be fixed up to use a global resource passed in from the outside, but this should almost never be called
so it doesn't matter (except perhaps when SEEing a compiled file))
(CONCAT (COND
((IGREATERP CHARCODE 127) (* META character)
(SETQ CHARCODE (LOGAND CHARCODE 127))
(QUOTE #))
(T ""))
(COND
((ILESSP CHARCODE 32) (* CONTROL character)
(SETQ CHARCODE (LOGOR CHARCODE 64))
(QUOTE ↑))
(T ""))
(CHARACTER CHARCODE])
(\SLOWBLTCHAR
[LAMBDA (CHARCODE DISPLAYSTREAM) (* rmk: " 4-Apr-85 15:48")
(* case of BLTCHAR where either font is rotated or destination is a color bitmap. DISPLAYSTREAM is known to be a
display stream, and its cache fields have been updated for CHARCODE's charset)
(LET (ROTATION (CHAR8CODE (\CHAR8CODE CHARCODE))
(DD (ffetch IMAGEDATA of DISPLAYSTREAM)))
(SETQ ROTATION (ffetch (FONTDESCRIPTOR ROTATION) of (ffetch DDFONT of DD)))
(COND
[(EQ 0 ROTATION)
(LET (NEWX LEFT RIGHT (CURX (ffetch DDXPOSITION of DD)))
[COND
((IGREATERP (SETQ NEWX (IPLUS CURX (\DSPGETCHARWIDTH CHAR8CODE 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 CHAR8CODE 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)))
(COND
((AND (ILESSP LEFT RIGHT)
(NEQ (ffetch PBTHEIGHT of (SETQ NEWX (ffetch DDPILOTBBT of DD)))
0))
(SELECTQ (ffetch (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 CHAR8CODE
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
CHAR8CODE 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
CHAR8CODE DD)
3)
LEFT)
(LLSH CURX 3)))
(\PILOTBITBLT NEWX 0)))
(SHOULDNT))
T]
(T (* handle rotated fonts)
(LET [(YPOS (ffetch DDYPOSITION of DD))
(HEIGHTMOVED (\DSPGETCHARWIDTH CHAR8CODE DD))
(CSINFO (\GETCHARSETINFO (\CHARSET CHARCODE)
(ffetch DDFONT of DD]
(COND
((EQ ROTATION 90) (* don't force CR for rotated fonts.)
(\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IPLUS YPOS HEIGHTMOVED))
(* update the display stream x position.)
(BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
0
(\DSPGETCHAROFFSET CHAR8CODE DD)
DISPLAYSTREAM
(ADD1 (IDIFFERENCE (ffetch DDXPOSITION of DD)
(ffetch (CHARSETINFO CHARSETASCENT) of CSINFO)))
YPOS
(IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO)
(ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
HEIGHTMOVED))
((EQ ROTATION 270)
(\DSPYPOSITION.DISPLAY DISPLAYSTREAM (IDIFFERENCE YPOS HEIGHTMOVED))
(BITBLT (ffetch (CHARSETINFO CHARSETBITMAP) of CSINFO)
0
(\DSPGETCHAROFFSET CHAR8CODE DD)
DISPLAYSTREAM
(IDIFFERENCE (ffetch DDXPOSITION of DD)
(ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
(ffetch DDYPOSITION of DISPLAYSTREAM)
(IPLUS (ffetch (CHARSETINFO CHARSETASCENT) of CSINFO)
(ffetch (CHARSETINFO CHARSETDESCENT) of CSINFO))
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 (BITMAP) (* hdj " 5-Jul-85 11:48")
(* returns the width of a bitmap in pixels)
(COND
((type? BITMAP BITMAP)
(SELECTQ (fetch (BITMAP BITMAPBITSPERPIXEL) of BITMAP)
(1 (ffetch (BITMAP BITMAPWIDTH) of BITMAP))
(4 (FOLDLO (ffetch (BITMAP BITMAPWIDTH) of BITMAP)
4))
(8 (FOLDLO (ffetch (BITMAP BITMAPWIDTH) of BITMAP)
8))
(SHOULDNT)))
((WINDOWP BITMAP) (* if it is a window, return the width of its
interior.)
(WINDOWPROP BITMAP (QUOTE WIDTH)))
(T (\ILLEGAL.ARG BITMAP])
(READBITMAP
[LAMBDA (FILE) (* rmk: "27-Mar-85 00:20")
(* 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 (SELECTQ (SKIPSEPRS STRM)
((%" %))
1)
(PROGN (* 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"])
)
(DECLARE: DONTCOPY
(DECLARE: EVAL@COMPILE
(PUTPROPS \INVALIDATEDISPLAYCACHE MACRO ((DISPLAYDATA)
(* This marks the character-printing caches of the displaystream as invalid. Needed when
the font or Y position changes)
(freplace DDCHARSET of DISPLAYDATA with MAX.SMALLP)
(freplace DDCHARSETASCENT of DISPLAYDATA with MAX.SMALLP)))
)
)
(DECLARE: EVAL@COMPILE
(PUTPROPS BITMAPBIT DMACRO (ARGS (BITMAPBIT.EXPANDER ARGS)))
)
(DEFINEQ
(BITMAPBIT.EXPANDER
[LAMBDA (ARGS) (* hdj "19-Mar-85 12:14")
(PROG ((BM (CAR ARGS))
(X (CADR ARGS))
(Y (CADDR ARGS))
NEWVALUE)
(if (EQ (LENGTH ARGS)
4)
then (SETQ NEWVALUE (CADDDR ARGS)))
(RETURN (BQUOTE ((OPCODES MISC4 6)
, BM , X , Y , NEWVALUE])
)
(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)
(* hdj "24-Jun-85 12:01")
(* 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]
(* 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: " 4-Apr-85 13:43")
(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)
(\INVALIDATEDISPLAYCACHE 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: " 4-Apr-85 12:55")
(* 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)
(\INVALIDATEDISPLAYCACHE 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: " 4-Apr-85 14:07")
(* 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))
(NBITS (ffetch (BITMAP BITMAPBITSPERPIXEL) of (ffetch DDDestination of DISPLAYDATA]
(* 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)))
(freplace DDSlowPrintingCase of DISPLAYDATA with (OR (NEQ NBITS 1)
(NEQ (ffetch (FONTDESCRIPTOR ROTATION)
of FONT)
0]
(\INVALIDATEDISPLAYCACHE 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 CSINFO) (* rmk: " 4-Apr-85 13:50")
(* makes that part of the bitblt table of a display stream which deals with the Y information consistent.
This is called from \BLTCHAR whenever a character is being printed and the charset/y-position caches are invalid)
(* assumes DISPLAYDATA has already been type checked.)
(PROG ((PBT (ffetch DDPILOTBBT of DISPLAYDATA))
(Y (\DSPTRANSFORMY (ffetch DDYPOSITION of DISPLAYDATA)
DISPLAYDATA))
TOP CHARTOP BM)
[SETQ CHARTOP (IPLUS Y (freplace DDCHARSETASCENT of DISPLAYDATA
with (ffetch CHARSETASCENT of CSINFO]
[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 (CHARSETINFO
CHARSETBITMAP)
of CSINFO)))
(ITIMES (ffetch BITMAPRASTERWIDTH of BM)
(freplace DDCHARHEIGHTDELTA of
DISPLAYDATA
with (IMIN (IMAX (IDIFFERENCE CHARTOP
TOP)
0)
MAX.SMALL.INTEGER]
(freplace PBTHEIGHT of PBT with (IMAX (IDIFFERENCE TOP
(IMAX (IDIFFERENCE Y
(freplace
DDCHARSETDESCENT
of DISPLAYDATA
with (ffetch
CHARSETDESCENT
of CSINFO))
)
(ffetch DDClippingBottom
of DISPLAYDATA)))
0])
)
(DEFINEQ
(\DSPCLIPPINGREGION.DISPLAY
[LAMBDA (DISPLAYSTREAM REGION) (* rmk: " 4-Apr-85 13:44")
(* 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)
(\INVALIDATEDISPLAYCACHE DD))])
(\DSPFONT.DISPLAY
[LAMBDA (DISPLAYSTREAM FONT) (* rmk: " 4-Apr-85 15:00")
(* sets the font that a display stream uses to print
characters. DISPLAYSTREAM is guaranteed to be a stream
of type display)
(LET (XFONT OLDFONT (DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(* save old value to return, smash new value and update
the bitchar portion of the record.)
(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)))
(freplace DDSPACEWIDTH of DD with (\FGETCHARWIDTH XFONT (CHARCODE SPACE))
) (* This will be different when spacefactor is
implemented for the display)
(\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: " 4-Apr-85 13:45")
(PROG ((DD (fetch IMAGEDATA of DISPLAYSTREAM)))
(RETURN (PROG1 (ffetch DDYPOSITION of DD)
(COND
((NULL YPOSITION))
((NUMBERP YPOSITION)
(UNINTERRUPTABLY
(freplace DDYPOSITION of DD with YPOSITION)
(\INVALIDATEDISPLAYCACHE 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
[PROGN [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) (* AJB " 7-Jun-85 14:49")
(* Makes DISPLAYSTREAM be the ttydisplaystream)
(DECLARE (GLOBALVARS \DEFAULTTTYDISPLAYSTREAM))
(COND
((NULL DISPLAYSTREAM) (* this case normally macros out)
TtyDisplayStream)
(T (SETQ DISPLAYSTREAM (OR (IMAGESTREAMP (\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.)
[COND
((IMAGESTREAMTYPEP DISPLAYSTREAM (QUOTE DISPLAY))
(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) (* rmk: "29-Apr-85 17:47")
(* Displays the character and increments the Xposition.
STREAM is guaranteed to be of type display.)
(\CHECKCARET STREAM)
(PROG ((DD (ffetch IMAGEDATA of STREAM)))
(SELECTC (ffetch CCECHO of (\SYNCODE \PRIMTERMSA CHARCODE))
[REAL.CCE (* All fat characters are defined as REAL according to
\SYNCODE, so we don't have worry about any of the
special cases)
(SELECTC CHARCODE
((CHARCODE (EOL CR LF))
(\DSPPRINTCR/LF CHARCODE STREAM)
(freplace 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 (ffetch CHARPOSITION of STREAM)
1]
[INDICATE.CCE (* Make sure that all the chars in the indicate-string
fit on the line or wrap-around together.)
(LET ((STR (\INDICATESTRING CHARCODE)))
(* This isn't right for rotated fonts.
But then there should probably be a separate rotated
outcharfn)
(if (IGREATERP (\STRINGWIDTH.DISPLAY STREAM STR)
(IDIFFERENCE (ffetch DDRightMargin of DD)
(ffetch DDXPOSITION of DD)))
then (\DSPPRINTCR/LF (CHARCODE EOL)
STREAM)
(freplace CHARPOSITION of STREAM with (NCHARS STR))
else (add (ffetch CHARPOSITION of STREAM)
(NCHARS STR)))
(for I from 1 do (\BLTCHAR (OR (NTHCHARCODE STR I)
(RETURN))
STREAM DD]
[SIMULATE.CCE
(SELCHARQ CHARCODE
((EOL CR LF)
(\DSPPRINTCR/LF CHARCODE STREAM)
(freplace CHARPOSITION of STREAM with 0))
(ESCAPE (\BLTCHAR (CHARCODE $)
STREAM DD)
(add (ffetch CHARPOSITION of STREAM)
1))
[BELL (* make switching of bits uninterruptable but allow
interrupts between flashes.)
(SELECTQ (MACHINETYPE)
[DANDELION (PLAYTUNE (QUOTE ((880 . 2500]
(FLASHWINDOW (WFROMDS STREAM]
[TAB (PROG (TABWIDTH (SPACEWIDTH (CHARWIDTH (CHARCODE SPACE)
STREAM)))
(SETQ TABWIDTH (UNFOLD SPACEWIDTH 8))
(COND
((IGREATERP (\DISPLAYSTREAMINCRXPOSITION
(SETQ TABWIDTH
(IDIFFERENCE TABWIDTH
(MOD (IDIFFERENCE
(ffetch 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 (ffetch CHARPOSITION of STREAM)
(IQUOTIENT TABWIDTH SPACEWIDTH]
(PROGN (* this case was copied from \DSCCOUT.)
(\BLTCHAR CHARCODE STREAM DD)
(add (ffetch 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
(UPDATESCREENDIMENSIONS
[LAMBDA NIL (* bvm: "10-Aug-85 23:06")
(* * Sets SCREENWIDTH and SCREENHEIGHT according to machine)
(SELECTC \MACHINETYPE
((LIST \DOLPHIN \DORADO \DANDELION)
(SETQ SCREENWIDTH 1024)
(SETQ SCREENHEIGHT 808))
(\DAYBREAK (SETQ SCREENWIDTH (\DoveDisplay.ScreenWidth))
(SETQ SCREENHEIGHT (\DoveDisplay.ScreenHeight)))
(SHOULDNT])
(\CreateScreenBitMap
[LAMBDA (WIDTH HEIGHT) (* bvm: "10-Aug-85 23:24")
(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.)
(LET ((RASTERWIDTH (FOLDHI WIDTH 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#)))
(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
(UPDATESCREENDIMENSIONS)
(RPAQ? SCREENHEIGHT 808)
(RPAQ? SCREENWIDTH 1024)
(RPAQ? \OLDSCREENHEIGHT 808)
(RPAQ? \OLDSCREENWIDTH 1024)
(RPAQ? \MaxScreenPage -1)
(RPAQ? ScreenBitMap (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \OLDSCREENHEIGHT \OLDSCREENWIDTH \MaxScreenPage ScreenBitMap)
)
(* initialization)
(RPAQ? LastCreatedDisplayDevice )
(DEFINEQ
(\CoerceToDisplayDevice
[LAMBDA (NameOrDevice) (* hdj " 8-Mar-85 10:29")
(DECLARE (GLOBALVARS LastCreatedDisplayDevice))
(LET ((DEV (OR NameOrDevice LastCreatedDisplayDevice)))
(if (type? FDEV DEV)
then DEV
else (OR (\GETDEVICEFROMNAME DEV T T)
(ERROR "No color drivers have been loaded"])
(\CREATEDISPLAY
[LAMBDA (DISPLAYNAME DEVICEMETHODS DEVICEDATA DEVICEEVENT)
(* hdj "25-Jun-85 15:28")
(* * 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 ←(OR DEVICEEVENT (FUNCTION NILL))
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: "13-Aug-85 17:31")
(LET (OLDWINDOWS)
(UPDATESCREENDIMENSIONS)
[COND
((AND (OR (NEQ SCREENWIDTH \OLDSCREENWIDTH)
(NEQ SCREENHEIGHT \OLDSCREENHEIGHT))
(WINDOWWORLD)) (* Need to move windows around so that they remain on
screen, and/or fix the display to account for new
raster width)
(SETQ OLDWINDOWS (REVERSE (OPENWINDOWS))) (* Returns bottom window first)
(COND
((OR (LESSP SCREENWIDTH \OLDSCREENWIDTH)
(LESSP SCREENHEIGHT \OLDSCREENHEIGHT)) (* Screen shrank, movement needed)
(\MOVE.WINDOWS.ONTO.SCREEN OLDWINDOWS)))
(* Finally, close the windows to save their images. Do this in separate pass from the moving, in case somebody's
MOVEFN tried to do something with a window we had closed)
(for W in OLDWINDOWS do (\CLOSEW1 W))
(COND
((AND NIL (NEQ SCREENWIDTH \OLDSCREENWIDTH))
(\UPDATE.PBT.RASTERWIDTHS]
(UNINTERRUPTABLY
(SETQ ScreenBitMap (\CreateScreenBitMap SCREENWIDTH SCREENHEIGHT))
(SHOWDISPLAY (fetch BITMAPBASE of ScreenBitMap)
(fetch BITMAPRASTERWIDTH of ScreenBitMap))
(CHANGETTYDEVICE (QUOTE LISPDISPLAY))
(SETQ \DisplayStarted T))
(SETQ WHOLESCREEN (SETQ WHOLEDISPLAY
(create REGION
LEFT ← 0
BOTTOM ← 0
WIDTH ← SCREENWIDTH
HEIGHT ← SCREENHEIGHT)))
[COND
(OLDWINDOWS (* Now that we've created ScreenBitMap with the right
raster width, put the windows back up)
(CHANGEBACKGROUND CURRENTBACKGROUNDSHADE)
(for W in (REVERSE OLDWINDOWS) do (\OPENW1 W]
(SETQ \OLDSCREENHEIGHT SCREENHEIGHT)
(SETQ \OLDSCREENWIDTH SCREENWIDTH])
(\MOVE.WINDOWS.ONTO.SCREEN
[LAMBDA (WINDOWS) (* bvm: "15-Aug-85 15:08")
(COND
([for W in WINDOWS thereis (LET ((REG (fetch (WINDOW REG) of W)))
(OR (GREATERP (fetch (REGION RIGHT) of REG)
SCREENWIDTH)
(GREATERP (fetch (REGION TOP) of REG)
SCREENHEIGHT]
(* Move all windows some if any are off screen)
(LET (XFACTOR YFACTOR REG)
(SETQ XFACTOR (FQUOTIENT SCREENWIDTH \OLDSCREENWIDTH))
(SETQ YFACTOR (FQUOTIENT SCREENHEIGHT \OLDSCREENHEIGHT))
(for W in WINDOWS unless (NEQ W (MAINWINDOW W))
do (* In the case of attached windows, move only the main
one, so that attached windows are properly dragged
along)
(MOVEW (SETQ W (MAINWINDOW W T))
(IMAX 0 (IDIFFERENCE [FIXR (FTIMES XFACTOR (fetch (REGION RIGHT)
of (SETQ REG
(fetch (WINDOW REG)
of W]
(fetch (REGION WIDTH) of REG)))
(IMAX 0 (IDIFFERENCE (FIXR (FTIMES YFACTOR (fetch (REGION TOP)
of REG)))
(fetch (REGION HEIGHT) of REG])
(\UPDATE.PBT.RASTERWIDTHS
[LAMBDA NIL (* bvm: "11-Aug-85 00:12")
(* * Fix all the cached bitblt tables that think they know what the screen width is)
(\MAPMDS (QUOTE PILOTBBT)
(FUNCTION (LAMBDA (PAGENO)
(to (FOLDLO \MDSIncrement 16) bind (PBT ←(create POINTER
PAGE# ← PAGENO))
do
(* * NOTE: We are depending on PILOTBBT structures being 16-word units, and that the first 32-bit field is NOT the
one we are smashing. That's so we don't trash links in the free list. In fact, since PBTDESTLO and PBTDESTHI are in
the first 32-bit field, we are actually guaranteed by the AND below not to touch any free PILOTBBT structures)
(COND
((AND (EQ (fetch (PILOTBBT PBTDESTHI) of PBT)
(FOLDLO \VP.DISPLAY PAGESPERSEGMENT))
(EQ (fetch (PILOTBBT PBTDESTLO) of PBT)
0)) (* Destination is screen)
(replace (PILOTBBT PBTDESTBPL) of PBT with SCREENWIDTH)))
(SETQ PBT (\ADDBASE PBT 16])
(\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])
)
(DECLARE: EVAL@COMPILE DONTCOPY
(ADDTOVAR DONTCOMPILEFNS \UPDATE.PBT.RASTERWIDTHS)
)
(* FOLLOWING DEFINITIONS EXPORTED)
(DECLARE: EVAL@COMPILE
(PUTPROPS DISPLAYINITIALIZEDP MACRO (NIL (* always initialized now)
T))
(PUTPROPS DISPLAYSTARTEDP MACRO (NIL \DisplayStarted))
)
(DECLARE: DOEVAL@COMPILE DONTCOPY
(GLOBALVARS \DisplayStarted \DisplayStreamsInitialized \DisplayInitialed WHOLEDISPLAY WHOLESCREEN
SCREENWIDTH SCREENHEIGHT)
)
(* END EXPORTED DEFINITIONS)
(ADDTOVAR GLOBALVARS WHOLESCREEN)
(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
(RPAQQ \DisplayStarted NIL)
(RPAQQ \LastTTYLines 12)
(INITIALIZEDISPLAYSTREAMS)
(DISPLAYSTREAMINIT 1000)
)
(PUTPROPS LLDISPLAY COPYRIGHT ("Xerox Corporation" 1981 1982 1983 1984 1985))
(DECLARE: DONTCOPY
(FILEMAP (NIL (15208 16921 (\FBITMAPBIT 15218 . 15749) (\NEWPAGE.DISPLAY 15751 . 15890) (INITBITMASKS
15892 . 16919)) (17649 18143 (\CreateCursorBitMap 17659 . 18141)) (18255 57507 (BITBLT 18265 . 22494)
(BLTSHADE 22496 . 23155) (\BITBLTSUB 23157 . 29460) (\GETPILOTBBTSCRATCHBM 29462 . 30136) (BITMAPCOPY
30138 . 30695) (BITMAPCREATE 30697 . 31736) (BITMAPBIT 31738 . 36741) (\BITMAPBIT 36743 . 42115) (
BLTCHAR 42117 . 42698) (\BLTCHAR 42700 . 45766) (\CHANGECHARSET.DISPLAY 45768 . 47426) (
\INDICATESTRING 47428 . 48247) (\SLOWBLTCHAR 48249 . 53097) (TEXTUREP 53099 . 53333) (INVERT.TEXTURE
53335 . 53586) (INVERT.TEXTURE.BITMAP 53588 . 54757) (BITMAPWIDTH 54759 . 55534) (READBITMAP 55536 .
57505)) (57951 58366 (BITMAPBIT.EXPANDER 57961 . 58364)) (58367 95505 (\BITBLT.1BITDISPLAY 58377 .
64203) (\BITBLT.BITMAP 64205 . 71376) (\BITBLT.COLORDISPLAY 71378 . 79414) (\BITBLT.MERGE 79416 .
81464) (\BLTSHADE.1BITDISPLAY 81466 . 85532) (\BLTSHADE.BITMAP 85534 . 90452) (\BLTSHADE.COLORDISPLAY
90454 . 95503)) (97892 100730 (DISPLAYSTREAMP 97902 . 98249) (DSPSOURCETYPE 98251 . 99074) (DSPXOFFSET
99076 . 99941) (DSPYOFFSET 99943 . 100728)) (100731 111451 (DSPCREATE 100741 . 102158) (
DSPDESTINATION 102160 . 103164) (DSPTEXTURE 103166 . 103806) (\DISPLAYSTREAMINCRXPOSITION 103808 .
104149) (\SFFixDestination 104151 . 105640) (\SFFixClippingRegion 105642 . 107150) (\SFFixFont 107152
. 108466) (\SFFIXLINELENGTH 108468 . 109314) (\SFFixY 109316 . 111449)) (111452 119547 (
\DSPCLIPPINGREGION.DISPLAY 111462 . 112144) (\DSPFONT.DISPLAY 112146 . 113610) (\DSPFONT.COLORDISPLAY
113612 . 115370) (\DSPLINEFEED.DISPLAY 115372 . 115891) (\DSPLEFTMARGIN.DISPLAY 115893 . 116563) (
\DSPOPERATION.DISPLAY 116565 . 117401) (\DSPRIGHTMARGIN.DISPLAY 117403 . 118244) (
\DSPXPOSITION.DISPLAY 118246 . 119030) (\DSPYPOSITION.DISPLAY 119032 . 119545)) (121688 125869 (
TTYDISPLAYSTREAM 121698 . 125102) (\REMOVEDRIBBLECHECK 125104 . 125544) (\ADDDRIBBLECHECK 125546 .
125867)) (126087 129734 (DSPSCROLL 126097 . 126640) (CHANGETTYDEVICE 126642 . 129012) (OUTPUTDSP
129014 . 129389) (PAGEHEIGHT 129391 . 129732)) (129816 143002 (\DSPRESET.DISPLAY 129826 . 131830) (
\DSPPRINTCHAR 131832 . 135840) (\DSPPRINTCR/LF 135842 . 143000)) (143003 143501 (\TTYBACKGROUND 143013
. 143499)) (143502 145227 (DSPBACKUP 143512 . 145225)) (145410 145647 (COLORDISPLAYP 145420 . 145645)
) (145648 147756 (DISPLAYBEFOREEXIT 145658 . 146524) (DISPLAYAFTERENTRY 146526 . 147754)) (148101
151861 (\DSPCLIPTRANSFORMX 148111 . 148632) (\DSPCLIPTRANSFORMY 148634 . 149223) (\DSPTRANSFORMREGION
149225 . 149755) (\DSPUNTRANSFORMY 149757 . 150083) (\DSPUNTRANSFORMX 150085 . 150411) (
\OFFSETCLIPPINGREGION 150413 . 151859)) (152566 154874 (UPDATESCREENDIMENSIONS 152576 . 153075) (
\CreateScreenBitMap 153077 . 154872)) (155344 164701 (\CoerceToDisplayDevice 155354 . 155750) (
\CREATEDISPLAY 155752 . 157436) (DISPLAYSTREAMINIT 157438 . 159499) (\STARTDISPLAY 159501 . 161597) (
\MOVE.WINDOWS.ONTO.SCREEN 161599 . 163001) (\UPDATE.PBT.RASTERWIDTHS 163003 . 164166) (\STOPDISPLAY
164168 . 164699)) (165227 166087 (INITIALIZEDISPLAYSTREAMS 165237 . 166085)))))
STOP