;;; **********************************************************************
;;; This code was written as part of the Spice Lisp project at
;;; Carnegie-Mellon University, and has been placed in the public domain.
;;; Spice Lisp is currently incomplete and under active development.
;;; If you want to use this code or any part of Spice Lisp, please contact
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; Spice Lisp interface to the viewport manager of Sapphire.
;;;
;;; Written by Daniel Aronson
;;;
;;; **********************************************************************
;;; **********************************************************************
(declare (special null-port ;reply port when we don't want a reply.
*user-window* ;initial user window
*viewport-x-size* ;width of user viewport
*viewport-y-size* ;height of user viewport
*user-viewport* ;port to send viewport messages to.
*user-font* ;default font
data-port
viewport-reply-port
))
;;; viewport-reply-port holds the port which this process receives replies
;;; from the viewport server on. It is initialized by viewport-init.
(defvar *current-viewport* ()
"The viewport that is currently being written to.")
(defvar *current-font* ()
"The current system font.")
;;; VIEWPORT-STATE
;;; The global special to-viewport-state stores an alien structure of type
;;; to-viewport-state This structure holds the message sent to the viewport
;;; manager by the viewport-state function. To-viewport-state is initialized
;;; by viewport-init.
(defvar to-viewport-state)
(def-alien-structure to-viewport-state
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 22)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18 :default *user-viewport*)
(msg-id unsigned-integer 18 22 :constant 2402)
)
(defvar from-viewport-state)
(def-alien-structure from-viewport-state
(msg-size unsigned-integer 2 6 :constant 76)
(msg-local-port port 10 14 :constant viewport-reply-port)
(curlx unsigned-integer 32 34 :direction read)
(curty unsigned-integer 38 40 :direction read)
(curwidth unsigned-integer 44 46 :direction read)
(curheight unsigned-integer 50 52 :direction read)
(currank unsigned-integer 56 58 :direction read)
;; the following should be selections, but are not for speed.
(memory (selection () t) 62 64 :direction read)
(courteous (selection () t) 68 70 :direction read)
(transparent (selection () t) 74 76 :direction read)
)
;;; Viewport-state returns the viewport state from the viewport server.
(defun viewport-state (&optional (viewport *current-viewport*))
(setf (to-viewport-state-msg-remote-port to-viewport-state) viewport)
(simple-send to-viewport-state)
(simple-receive from-viewport-state)
(values (from-viewport-state-curlx from-viewport-state)
(from-viewport-state-curty from-viewport-state)
(from-viewport-state-curwidth from-viewport-state)
(from-viewport-state-curheight from-viewport-state)
(from-viewport-state-currank from-viewport-state)
(from-viewport-state-memory from-viewport-state)
(from-viewport-state-courteous from-viewport-state)
(from-viewport-state-transparent from-viewport-state)
)
)
;;; VIEW-ROP
;;; The global special to-view-rop stores an alien structure of type
;;; to-view-rop This structure holds the message sent to the viewport
;;; manager by the view-rop function. To-view-rop is initialized
;;; by viewport-init.
(defvar to-view-rop)
(def-alien-structure to-view-rop
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 72)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18 :default *user-viewport*)
(msg-id unsigned-integer 18 22 :constant 2410)
(funct-type1 unsigned-integer 22 24 :constant 4097)
(funct-type2 unsigned-integer 24 26 :constant 4097)
;; the folowing should be a selection but is not for speed
(funct unsigned-integer 26 28)
(dx-type1 unsigned-integer 28 30 :constant 4097)
(dx-type2 unsigned-integer 30 32 :constant 4097)
(dx unsigned-integer 32 34)
(dy-type1 unsigned-integer 34 36 :constant 4097)
(dy-type2 unsigned-integer 36 38 :constant 4097)
(dy unsigned-integer 38 40)
(width-type1 unsigned-integer 40 42 :constant 4097)
(width-type2 unsigned-integer 42 44 :constant 4097)
(width unsigned-integer 44 46)
(height-type1 unsigned-integer 46 48 :constant 4097)
(height-type2 unsigned-integer 48 50 :constant 4097)
(height unsigned-integer 50 52)
(srcVP-type1 unsigned-integer 52 54 :constant 8198)
(srcVP-type2 unsigned-integer 54 56 :constant 4097)
(srcVP port 56 60)
(sx-type1 unsigned-integer 60 62 :constant 4097)
(sx-type2 unsigned-integer 62 64 :constant 4097)
(sx unsigned-integer 64 66)
(sy-type1 unsigned-integer 66 68 :constant 4097)
(sy-type2 unsigned-integer 68 70 :constant 4097)
(sy unsigned-integer 70 72)
)
(defconstant trap-rop 11)
(defvar to-kernel-view-rop)
(def-alien-structure to-kernel-view-rop
(GR unsigned-integer 0 2)
(srcvp port 2 6)
(destvp port 6 10 :default *user-viewport*)
(funct unsigned-integer 10 12)
(height unsigned-integer 12 14)
(width unsigned-integer 14 16)
(sx unsigned-integer 16 18)
(sy unsigned-integer 18 20)
(dx unsigned-integer 20 22)
(dy unsigned-integer 22 24))
;;; View-rop performs a rasterop function on the specified viewport. We
;;; first try the kernel trap, and then send a message if we need to.
;;; Note: (0,0) is the upper left hand corner of the viewport.
;;; The arguments are:
;;; FUNCTION - one of: Rrpl, Rnot, Rand, Randnot, Ror, Rornot, Rxor,
;;; Rxnor.
;;; DX - destination left start.
;;; DY - destination top start.
;;; WIDTH - width of the region to rasterop
;;; HEIGHT - height of the region to rasterop.
;;; SrcVP - Source viewport.
;;; SX - source left start.
;;; SY - source top start.
(defun view-rop (funct dx dy width height srcvp sx sy &optional
(viewport *current-viewport*))
" View-rop performs a rasterop function on the specified viewport.
Note: (0,0) is the upper laft hand corner of the viewport.
The arguments are:
FUNCTION - one of:
0 -- Rrpl,
1 -- Rnot,
2 -- Rand,
3 -- Randnot,
4 -- Ror,
5 -- Rornot,
6 -- Rxor,
7 -- Rxnor.
DX - destination left start.
DY - destination top start.
WIDTH - width of the region to rasterop
HEIGHT - height of the region to rasterop.
SrcVP - Source viewport.
SX - source left start.
SY - source top start."
(multiple-alien-setq-to-kernel-view-rop
to-kernel-view-rop
(:destvp viewport)
(:funct funct)
(:dx dx)
(:dy dy)
(:width width)
(:height height)
(:srcvp srcvp)
(:sx sx)
(:sy sy))
(%sp-kernel-trap (alien-structure-data to-kernel-view-rop)
trap-rop)
(when (/= (to-kernel-view-rop-gr to-kernel-view-rop) rc-success)
(multiple-alien-setq-to-view-rop
to-view-rop
(:msg-remote-port viewport)
(:funct funct)
(:dx dx)
(:dy dy)
(:width width)
(:height height)
(:srcvp srcvp)
(:sx sx)
(:sy sy))
(simple-send to-view-rop)))
;;; VIEW-COLOR-RECT
;;; The global special to-View-Color-Rect stores an alien structure of type
;;; to-View-Color-Rect This structure holds the message sent to the viewport
;;; manager by the View-Color-Rect function. To-View-Color-Rect is
;;; initialized by viewport-init.
(defvar to-View-Color-Rect)
(def-alien-structure to-View-Color-Rect
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 52)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18 :default *user-viewport*)
(msg-id unsigned-integer 18 22 :constant 2411)
(funct-type1 unsigned-integer 22 24 :constant 4097)
(funct-type2 unsigned-integer 24 26 :constant 4097)
;; the folowing should be a selection but is not for speed
(funct unsigned-integer 26 28)
(x-type1 unsigned-integer 28 30 :constant 4097)
(x-type2 unsigned-integer 30 32 :constant 4097)
(x unsigned-integer 32 34)
(y-type1 unsigned-integer 34 36 :constant 4097)
(y-type2 unsigned-integer 36 38 :constant 4097)
(y unsigned-integer 38 40)
(width-type1 unsigned-integer 40 42 :constant 4097)
(width-type2 unsigned-integer 42 44 :constant 4097)
(width unsigned-integer 44 46)
(height-type1 unsigned-integer 46 48 :constant 4097)
(height-type2 unsigned-integer 48 50 :constant 4097)
(height unsigned-integer 50 52)
)
(defconstant trap-color-rect 23)
;;; View-Color-Rect colors the rectangle with the upper lefthand
;;; corner (x,y), width WIDTH and height HEIGHT to the given color.
;;; We try to use the kernel trap, etc. This guy shares the argblock
;;; with To-Kernel-View-Rop.
(defun view-color-rect (funct x y width height
&optional (viewport *current-viewport*))
" View-Color-Rect colors the rectange the specified color.
Note: (0,0) is the upper laft hand corner of the viewport.
The arguments are:
FUNCTION - one of:
0 -- RectBlack,
1 -- RectWhite,
2 -- RectInvert.
X - destination left start.
Y - destination top start.
WIDTH - width of the rectangle.
HEIGHT - height of the rectangle."
(multiple-alien-setq-to-kernel-view-rop
to-kernel-view-rop
(:destvp viewport)
(:funct funct)
(:dx x)
(:dy y)
(:width width)
(:height height))
(%sp-kernel-trap (alien-structure-data to-kernel-view-rop)
trap-color-rect)
(when (/= (to-kernel-view-rop-gr to-kernel-view-rop)
rc-success)
(multiple-alien-setq-to-view-color-rect
to-view-color-rect
(:msg-remote-port viewport)
(:funct funct)
(:x x)
(:y y)
(:width width)
(:height height))
(simple-send to-view-color-rect)))
;;; VIEW-LINE
;;; The global special to-View-line stores an alien structure of type
;;; to-View-line This structure holds the message sent to the viewport
;;; manager by the View-line function. To-View-line is
;;; initialized by viewport-init.
(defvar to-View-line)
(def-alien-structure to-View-line
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 52)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18 :default *user-viewport*)
(msg-id unsigned-integer 18 22 :constant 2413)
(funct-type1 unsigned-integer 22 24 :constant 4097)
(funct-type2 unsigned-integer 24 26 :constant 4097)
;; the folowing should be a selection but is not for speed
(funct unsigned-integer 26 28)
(x1-type1 unsigned-integer 28 30 :constant 4097)
(x1-type2 unsigned-integer 30 32 :constant 4097)
(x1 unsigned-integer 32 34)
(y1-type1 unsigned-integer 34 36 :constant 4097)
(y1-type2 unsigned-integer 36 38 :constant 4097)
(y1 unsigned-integer 38 40)
(x2-type1 unsigned-integer 40 42 :constant 4097)
(x2-type2 unsigned-integer 42 44 :constant 4097)
(x2 unsigned-integer 44 46)
(y2-type1 unsigned-integer 46 48 :constant 4097)
(y2-type2 unsigned-integer 48 50 :constant 4097)
(y2 unsigned-integer 50 52)
)
(defconstant trap-line 10)
(defvar to-kernel-view-line)
(def-alien-structure to-kernel-view-line
(GR unsigned-integer 0 2)
(srcvp port 2 6)
(x1 unsigned-integer 6 8)
(y1 unsigned-integer 8 10)
(x2 unsigned-integer 10 12)
(y2 unsigned-integer 12 14)
(funct unsigned-integer 14 16))
;;; View-line draw a line with the given function from point (x1,y1)
;;; to (x2,y2).
(defun view-line (funct x1 y1 x2 y2 &optional (viewport *current-viewport*))
"View-line draw a line with the given function from point (x1,y1)
to (x2,y2).
FUNCTION - one of:
0 -- DrawLine,
1 -- EraseLine,
2 -- XORLine"
(multiple-alien-setq-to-kernel-view-line
to-kernel-view-line
(:srcvp viewport)
(:funct funct)
(:x1 x1)
(:y1 y1)
(:x2 x2)
(:y2 y2))
(%sp-kernel-trap (alien-structure-data to-kernel-view-line)
trap-line)
(when (/= (to-kernel-view-line-gr to-kernel-view-line) rc-success)
(multiple-alien-setq-to-view-line to-view-line
(:msg-remote-port viewport)
(:funct funct)
(:x1 x1)
(:y1 y1)
(:x2 x2)
(:y2 y2))
(simple-send to-view-line)))
;;; ENABLE-INPUT
;;; The global special to-Enable-Input stores an alien structure of type
;;; to-Enable-Input This structure holds the message sent to the viewport
;;; manager by the Enable-Input function. To-Enable-Input is
;;; initialized by viewport-init.
(defvar to-Enable-Input)
(def-alien-structure to-Enable-Input
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 296)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18 :default *user-viewport*)
(msg-id unsigned-integer 18 22 :constant 2430)
(string-type1 unsigned-integer 22 24 :constant 0)
(string-type2 unsigned-integer 24 26 :constant 12288)
(string-name unsigned-integer 26 28 :constant 12)
(string-size unsigned-integer 28 30 :constant 2048)
(string-num unsigned-integer 30 34 :constant 1)
(string perq-string 34 290)
(timeout-type1 unsigned-integer 290 292 :constant 4097)
(timeout-type2 unsigned-integer 292 294 :constant 4097)
(timeout unsigned-integer 294 296 :constant 0)
)
(defvar from-enable-input)
(def-alien-structure from-enable-input
(msg-size unsigned-integer 2 6 :constant 28)
(msg-local-port port 10 14 :constant viewport-reply-port)
(rc unsigned-integer 26 28 :direction read)
)
;;; Enable-Input reads in a keytran file
(defun enable-input (keytrantab &optional (viewport *current-viewport*))
"Reads in a keytran file."
(multiple-alien-setq-to-enable-input to-enable-input
(:msg-remote-port viewport)
(:string keytrantab))
(simple-send to-enable-input)
(simple-receive from-enable-input)
(from-enable-input-rc from-enable-input))
(def-alien-field-type character ;Move this to alien sometime.
'character
'unsigned-integer
#'code-char
#'char-code)
;;; GET-EVENT
;;; The global special to-Get-event stores an alien structure of type
;;; to-Get-event This structure holds the message sent to the viewport
;;; manager by the Get-event function. To-Get-event is
;;; initialized by viewport-init.
(defvar to-Get-event)
(def-alien-structure to-Get-event
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 28)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18 :default *user-viewport*)
(msg-id unsigned-integer 18 22 :constant 2432)
(how-wait-type1 unsigned-integer 22 24 :constant 4097)
(how-wait-type2 unsigned-integer 24 26 :constant 4097)
;; the folowing should be a selection but is not for speed
(how-wait unsigned-integer 26 28)
)
(defvar from-get-event)
(def-alien-structure from-get-event
(msg-size unsigned-integer 2 6 :constant 42)
(msg-local-port port 10 14 :constant viewport-reply-port)
(cmd unsigned-integer 32 34 :direction read)
(char character 34 36 :direction read)
(region unsigned-integer 36 38 :direction read)
(x unsigned-integer 38 40 :direction read)
(y unsigned-integer 40 42 :direction read)
)
;;; Get-event gets a keyboard event
(defun get-event (how-wait &optional (viewport *current-viewport*))
"Gets a keyboard event
HowWait is one of
0 -- KEYWAITDIFFPOS
1 -- KEYDONTWAIT
2 -- KEYWAITEVENT
"
(multiple-alien-setq-to-get-event to-get-event
(:msg-remote-port viewport)
(:how-wait how-wait))
(simple-send to-get-event)
(simple-receive from-get-event)
(values (from-get-event-cmd from-get-event)
(from-get-event-char from-get-event)
(from-get-event-x from-get-event)
(from-get-event-y from-get-event)
))
;;; GET-SYS-FONT
;;; The global special to-get-sys-font stores an alien structure of type
;;; to-get-sys-font This structure holds the message sent to the viewport
;;; manager by the get-sys-font function. To-get-sys-font is initialized
;;; by viewport-init.
(defvar to-get-sys-font)
(def-alien-structure to-get-sys-font
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 22)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2424)
)
(defvar from-get-sys-font)
(def-alien-structure from-get-sys-font
(msg-size unsigned-integer 2 6 :constant 36)
(msg-local-port port 10 14 :constant viewport-reply-port)
(font port 32 36 :direction read)
)
;;; Get-sys-font retrieves the system font.
(defun get-sys-font (&optional (viewport *current-viewport*))
"return the system font"
(setf (to-get-sys-font-msg-remote-port to-get-sys-font) viewport)
(simple-send to-get-sys-font)
(simple-receive from-get-sys-font)
(setq *user-font* (from-get-sys-font-font from-get-sys-font)))
;;; LOAD-FONT
;;; The global special to-load-font stores an alien structure of type
;;; to-load-font This structure holds the message sent to the viewport
;;; manager by the load-font function. To-load-font is initialized
;;; by viewport-init.
(defvar to-load-font)
(def-alien-structure to-load-font
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 290)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18 :constant *user-viewport*)
(msg-id unsigned-integer 18 22 :constant 2423)
(tt1-1 unsigned-integer 22 24 :constant 0)
(tt1-2 unsigned-integer 24 26 :constant 12288)
(tt1-3 unsigned-integer 26 28 :constant 12)
(tt1-4 unsigned-integer 28 30 :constant 2048)
(tt1-5 unsigned-integer 30 34 :constant 1)
(font-file perq-string 34 290)
)
(defvar from-load-font)
(def-alien-structure from-load-font
(msg-size unsigned-integer 2 6 :constant 36)
(msg-local-port port 10 14 :constant viewport-reply-port)
(font port 32 36 :direction read)
)
;;; Load-font
(defun load-font (font-file)
"Loads a font file and return the viewport."
(setf (to-load-font-font-file to-load-font) font-file)
(simple-send to-load-font)
(simple-receive from-load-font)
(from-load-font-font from-load-font))
;;; VIEW-PUT-CH-ARRAY
;;; The global special to-view-put-ch-array stores an alien structure of type
;;; to-view-put-ch-array This structure holds the message sent to the
;;; viewport manager by the view-put-ch-array function.
;;; To-view-put-ch-array is initialized by viewport-init.
(defvar to-view-put-ch-array)
(def-alien-structure to-view-put-ch-array
(msg-simplep (selection () t) 0 2 :constant ())
(msg-size unsigned-integer 2 6 :constant 76)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18 :default *user-viewport*)
(msg-id unsigned-integer 18 22 :constant 2418)
(font-type1 unsigned-integer 22 24 :constant 8198)
(font-type2 unsigned-integer 24 26 :constant 4097)
(font port 26 30)
(funct-type1 unsigned-integer 30 32 :constant 4097)
(funct-type2 unsigned-integer 32 34 :constant 4097)
;; the folowing should be a selection but is not for speed
(funct unsigned-integer 34 36)
(dx-type1 unsigned-integer 36 38 :constant 4097)
(dx-type2 unsigned-integer 38 40 :constant 4097)
(dx unsigned-integer 40 42)
(dy-type1 unsigned-integer 42 44 :constant 4097)
(dy-type2 unsigned-integer 44 46 :constant 4097)
(dy unsigned-integer 46 48)
(chars-type1 unsigned-integer 48 50 :constant 0)
(chars-type2 unsigned-integer 50 52 :constant 8192)
(chars-type3 unsigned-integer 52 54 :constant 8)
(chars-size unsigned-integer 54 56 :constant 8)
(count unsigned-integer 56 60)
(chars-lsw unsigned-integer 60 62)
(chars-msw unsigned-integer 62 64)
(first-ch-type1 unsigned-integer 64 66 :constant 4097)
(first-ch-type2 unsigned-integer 66 68 :constant 4097)
(first-ch unsigned-integer 68 70)
(last-ch-type1 unsigned-integer 70 72 :constant 4097)
(last-ch-type2 unsigned-integer 72 74 :constant 4097)
(last-ch unsigned-integer 74 76)
)
(defconstant trap-put-string 16)
(defvar to-kernel-put-string)
(def-alien-structure to-kernel-put-string
(GR unsigned-integer 0 2)
(dest port 2 6 :default *user-viewport*)
(font port 6 10)
(funct unsigned-integer 10 12)
(x unsigned-integer 12 14)
(y unsigned-integer 14 16)
(max-x unsigned-integer 16 18 :constant 1024)
(start unsigned-integer 18 20)
(end unsigned-integer 20 22)
(string-lsw unsigned-integer 22 24)
(string-msw unsigned-integer 24 26)
(result unsigned-integer 26 28))
;;; View-put-ch-array
(defun view-put-ch-array (funct dx dy string first-ch last-ch
&optional (viewport *current-viewport*)
(font *current-font*))
"Outputs the string pointed to by CHARS (whose length is COUNT)
to the location in *user-viewport* starting at (dx,dy). The
first character output is the one pointed to by FIRST-CH and the
last is pointed to by LAST-CH.
FUNCTION - one of:
0 -- Rrpl,
1 -- Rnot,
2 -- Rand,
3 -- Randnot,
4 -- Ror,
5 -- Rornot,
6 -- Rxor,
7 -- Rxnor."
(make-pointer-f string
(to-kernel-put-string-string-lsw to-kernel-put-string)
(to-kernel-put-string-string-msw to-kernel-put-string))
(multiple-alien-setq-to-kernel-put-string to-kernel-put-string
(:dest viewport)
(:font font)
(:funct funct)
(:x dx)
(:y dy)
(:start first-ch)
(:end last-ch))
(%sp-kernel-trap (alien-structure-data to-kernel-put-string)
trap-put-string)
(when (/= (to-kernel-put-string-gr to-kernel-put-string) rc-success)
(make-pointer-f string
(to-view-put-ch-array-chars-lsw to-view-put-ch-array)
(to-view-put-ch-array-chars-msw to-view-put-ch-array))
(multiple-alien-setq-to-view-put-ch-array
to-view-put-ch-array
(:msg-remote-port viewport)
(:font font)
(:funct funct)
(:dx dx)
(:dy dy)
(:count (length string))
(:first-ch first-ch)
(:last-ch last-ch))
(simple-send to-view-put-ch-array)))
;;; SET-CURSOR-POS
;;; Set-cursor-pos takes an x,y pair (the origin is the upper left
;;;hand corner) and moves the cursor to that point.
(defvar to-set-cursor-pos)
(def-alien-structure to-set-cursor-pos
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 34)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18 :default *user-viewport*)
(msg-id unsigned-integer 18 22 :constant 2444)
(tt1-1 unsigned-integer 22 24 :constant 4097)
(tt1-2 unsigned-integer 24 26 :constant 4097)
(x unsigned-integer 26 28)
(tt2-1 unsigned-integer 28 30 :constant 4097)
(tt2-2 unsigned-integer 30 32 :constant 4097)
(y unsigned-integer 32 34)
)
(defun set-cursor-pos (x y &optional (viewport *current-viewport*))
"Set-cursor-pos moves the cursor to (x,y) in the current viewport."
(multiple-alien-setq-to-set-cursor-pos to-set-cursor-pos
(:msg-remote-port viewport)
(:x x)
(:y y))
(simple-send to-set-cursor-pos))
;;; Font Stuff
;;; FONT-SIZE
(defvar to-font-size)
(def-alien-structure to-font-size
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 22)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2420)
)
(defvar from-font-size)
(def-alien-structure from-font-size
(msg-size unsigned-integer 2 6 :constant 176)
(msg-local-port port 10 14 :constant viewport-reply-port)
(name perq-string 40 122 :direction read)
(point-size unsigned-integer 126 128 :direction read)
(rotation unsigned-integer 132 134 :direction read)
(face-code unsigned-integer 138 140 :direction read)
(max-width unsigned-integer 144 146 :direction read)
(max-height unsigned-integer 150 152 :direction read)
(x-origin unsigned-integer 156 158 :direction read)
(y-origin unsigned-integer 162 164 :direction read)
(fixed-width (selection () t) 168 170 :direction read)
(fixed-height (selection () t) 174 176 :direction read)
)
;;; Font-Size gets various boring features of the font specified.
(defun font-size (font)
(setf (to-font-size-msg-remote-port to-font-size) font)
(simple-send to-font-size)
(simple-receive from-font-size)
(values (from-font-size-name from-font-size)
(from-font-size-point-size from-font-size)
(from-font-size-rotation from-font-size)
(from-font-size-face-code from-font-size)
(from-font-size-max-width from-font-size)
(from-font-size-max-height from-font-size)
(from-font-size-x-origin from-font-size)
(from-font-size-y-origin from-font-size)
(from-font-size-fixed-width from-font-size)
(from-font-size-fixed-height from-font-size)
)
)
;;; FONT-CHAR-SIZE
(def-alien-field-type character ;Move this to alien sometime.
'character
'unsigned-integer
#'code-char
#'char-code)
(defvar to-font-char-size)
(def-alien-structure to-font-char-size
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 28)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2421)
(tt1-1 unsigned-integer 22 24 :constant 2056)
(tt1-2 unsigned-integer 24 26 :constant 4097)
(char character 26 28)
)
(defvar from-font-char-size)
(def-alien-structure from-font-char-size
(msg-size unsigned-integer 2 6 :constant 40)
(msg-local-port port 10 14 :constant viewport-reply-port)
(dx unsigned-integer 32 34 :direction read)
(dy unsigned-integer 38 40 :direction read)
)
;;; Font-Size gets the size of the character.
(defun font-char-size (font char)
(multiple-alien-setq-to-font-char-size to-font-char-size
(:msg-remote-port font)
(:char char))
(simple-send to-font-char-size)
(simple-receive from-font-char-size)
(values (from-font-char-size-dx from-font-char-size)
(from-font-char-size-dy from-font-char-size)
)
)
;;; FONT-STRING-SIZE
(defvar to-font-string-size)
(def-alien-structure to-font-string-size
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 302)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2422)
(tt1-1 unsigned-integer 22 24 :constant 0)
(tt1-2 unsigned-integer 24 26 :constant 12288)
(tt1-3 unsigned-integer 26 28 :constant 12)
(tt1-4 unsigned-integer 28 30 :constant 2048)
(tt1-5 unsigned-integer 30 34 :constant 1)
(string perq-string 34 290)
(tt2-1 unsigned-integer 290 292 :constant 4097)
(tt2-2 unsigned-integer 292 294 :constant 4097)
(firstch unsigned-integer 294 296)
(tt3-1 unsigned-integer 296 298 :constant 4097)
(tt3-2 unsigned-integer 298 300 :constant 4097)
(lastch unsigned-integer 300 302)
)
(defvar from-font-string-size)
(def-alien-structure from-font-string-size
(msg-size unsigned-integer 2 6 :constant 40)
(msg-local-port port 10 14 :constant viewport-reply-port)
(dx unsigned-integer 32 34 :direction read)
(dy unsigned-integer 38 40 :direction read)
)
;;; Font-String-Size gets the x and y size of the string.
(defun font-string-size (font string firstch lastch)
(multiple-alien-setq-to-font-string-size to-font-string-size
(:msg-remote-port font)
(:string string)
(:firstch firstch)
(:lastch lastch))
(simple-send to-font-string-size)
(simple-receive from-font-string-size)
(values (from-font-string-size-dx from-font-string-size)
(from-font-string-size-dy from-font-string-size)
)
)
;;; SET-LISTENER
(defvar to-Set-Listener)
(def-alien-structure to-Set-Listener
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 22)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2431)
)
(defvar from-Set-Listener)
(def-alien-structure from-Set-Listener
(msg-size unsigned-integer 2 6 :constant 28)
(msg-local-port port 10 14 :constant viewport-reply-port)
(rc unsigned-integer 26 28 :direction read)
)
;;; Set-Listener makes the passed viewport the current listener
(defun set-listener (&optional (viewport *current-viewport*))
(setf (to-set-listener-msg-remote-port to-set-listener) viewport)
(simple-send to-set-listener)
(simple-receive from-set-listener)
(from-set-listener-rc from-set-listener)
)
;;; DESTROY-VIEWPORT
(defvar to-Destroy-Viewport)
(def-alien-structure to-Destroy-viewport
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 22)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2401)
)
;;; Destroy-viewport destroys VIEWPORT
(defun destroy-viewport (viewport)
"Destoys VIEWPORT and removes it from screen. All sub-viewports are also
destroyed."
(setf (to-destroy-viewport-msg-remote-port to-destroy-viewport) viewport)
(simple-send to-destroy-viewport)
)
;;; MAKE-VIEWPORT
(defvar to-make-viewport)
(def-alien-structure to-make-viewport
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 70)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2400)
(tt2-1 unsigned-integer 22 24 :constant 4097)
(tt2-2 unsigned-integer 24 26 :constant 4097)
(x signed-integer 26 28)
(tt3-1 unsigned-integer 28 30 :constant 4097)
(tt3-2 unsigned-integer 30 32 :constant 4097)
(y signed-integer 32 34)
(tt4-1 unsigned-integer 34 36 :constant 4097)
(tt4-2 unsigned-integer 36 38 :constant 4097)
(w signed-integer 38 40)
(tt5-1 unsigned-integer 40 42 :constant 4097)
(tt5-2 unsigned-integer 42 44 :constant 4097)
(h signed-integer 44 46)
(tt6-1 unsigned-integer 46 48 :constant 4097)
(tt6-2 unsigned-integer 48 50 :constant 4097)
(rank signed-integer 50 52)
(tt7-1 unsigned-integer 52 54 :constant 4096)
(tt7-2 unsigned-integer 54 56 :constant 4097)
(memory (selection () t) 56 58)
(tt8-1 unsigned-integer 58 60 :constant 4096)
(tt8-2 unsigned-integer 60 62 :constant 4097)
(courteous (selection () t) 62 64)
(tt9-1 unsigned-integer 64 66 :constant 4096)
(tt9-2 unsigned-integer 66 68 :constant 4097)
(transparent (selection () t) 68 70)
)
(defvar from-make-viewport)
(def-alien-structure from-make-viewport
(msg-size unsigned-integer 2 6 :constant 36)
(msg-local-port port 10 14 :constant viewport-reply-port)
(rc unsigned-integer 26 28 :direction read)
(viewport port 32 36 :direction read)
)
;;; Make-Viewport creates a new viewport (which is clipped inside of the
;;; parent viewport).
(defun make-viewport (x y w h rank memory courteous transparent
&optional (port *user-viewport*))
"Make-Viewport creates a new viewport (which is clipped inside of the
parent viewport). X,Y - upper left corner (may be -32002 for offscreen).
W,H - Width and height of new viewport. RANK (increasing means further down).
MEMORY - whther the viewport will have off-screen memory to back up any parts
of the picture that are covered. CURTEOUS - whether the viewport saves the bit
map underneath it SET THIS TO NIL!! TRANSPARENT - wheher the viewport
covers viewports it is on top of."
(multiple-alien-setq-to-make-viewport to-make-viewport
(:msg-remote-port port)
(:x x)
(:y y)
(:w w)
(:h h)
(:rank rank)
(:memory memory)
(:courteous courteous)
(:transparent transparent))
(simple-send to-make-viewport)
(simple-receive from-make-viewport)
(if (/= (from-make-viewport-rc from-make-viewport) rc-success)
(error "RC = ~s." (from-make-viewport-rc from-make-viewport)))
(from-make-viewport-viewport from-make-viewport))
;;; MODIFY-VIEWPORT
(defvar to-modify-viewport)
(def-alien-structure to-modify-viewport
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 58)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2403)
(tt2-1 unsigned-integer 22 24 :constant 4097)
(tt2-2 unsigned-integer 24 26 :constant 4097)
(newlx unsigned-integer 26 28)
(tt3-1 unsigned-integer 28 30 :constant 4097)
(tt3-2 unsigned-integer 30 32 :constant 4097)
(newty unsigned-integer 32 34)
(tt4-1 unsigned-integer 34 36 :constant 4097)
(tt4-2 unsigned-integer 36 38 :constant 4097)
(newwidth unsigned-integer 38 40)
(tt5-1 unsigned-integer 40 42 :constant 4097)
(tt5-2 unsigned-integer 42 44 :constant 4097)
(newheight unsigned-integer 44 46)
(tt6-1 unsigned-integer 46 48 :constant 4097)
(tt6-2 unsigned-integer 48 50 :constant 4097)
(newrank unsigned-integer 50 52)
(tt7-1 unsigned-integer 52 54 :constant 4096)
(tt7-2 unsigned-integer 54 56 :constant 4097)
(wantvpchex (selection () t) 56 58)
)
(defvar from-modify-viewport)
(def-alien-structure from-modify-viewport
(msg-size unsigned-integer 2 6 :constant 28)
(msg-local-port port 10 14 :constant viewport-reply-port)
(rc unsigned-integer 26 28 :direction read)
)
;;; Changes the position, size, and/or rank of a viewport.
(defun modify-viewport (newlx newty newwidth newheight newrank wantvpchex
&optional (port *user-viewport*))
"Changes the position, size, and/or rank of a viewport.
NEWLX NEWLY - the new upper left corner of this viewport with respect to
its parent (-32001 means unchanged). NEWWIDTH, NEWHEIGHT, NEWRANK - the new
width and new-height of the viewport (these can also be unchanged). WANTVPCHEX -
if true and the change exception is enabled, then raises an exception after the
viewport is modified."
(multiple-alien-setq-to-modify-viewport to-modify-viewport
(:msg-remote-port port)
(:newlx newlx)
(:newty newty)
(:newwidth newwidth)
(:newheight newheight)
(:newrank newrank)
(:wantvpchex wantvpchex))
(simple-send to-modify-viewport)
(simple-receive from-modify-viewport)
(if (/= (from-modify-viewport-rc from-modify-viewport) rc-success)
(error "RC = ~s." (from-modify-viewport-rc from-modify-viewport)))
)
;;; PUT-VIEWPORT-RECTANGLE
(defvar to-put-viewport-rectangle)
(def-alien-structure to-put-viewport-rectangle
(msg-simplep (selection () t) 0 2 :constant ())
(msg-size unsigned-integer 2 6 :constant 86)
(msg-type (selection 'normal-message 'emergency-message)
6 10 :constant 'normal-message)
(msg-local-port port 10 14 :constant viewport-reply-port)
(msg-remote-port port 14 18 :default *user-viewport*)
(msg-id unsigned-integer 18 22 :constant 2428)
(tt2-1 unsigned-integer 22 24 :constant 4097)
(tt2-2 unsigned-integer 24 26 :constant 4097)
(funct unsigned-integer 26 28)
(tt3-1 unsigned-integer 28 30 :constant 4097)
(tt3-2 unsigned-integer 30 32 :constant 4097)
(x unsigned-integer 32 34)
(tt4-1 unsigned-integer 34 36 :constant 4097)
(tt4-2 unsigned-integer 36 38 :constant 4097)
(y unsigned-integer 38 40)
(tt5-1 unsigned-integer 40 42 :constant 4097)
(tt5-2 unsigned-integer 42 44 :constant 4097)
(width unsigned-integer 44 46)
(tt6-1 unsigned-integer 46 48 :constant 4097)
(tt6-2 unsigned-integer 48 50 :constant 4097)
(height unsigned-integer 50 52)
(tt7-1 unsigned-integer 52 54 :constant 0)
(tt7-2 unsigned-integer 54 56 :constant 8192)
(tt7-3 unsigned-integer 56 58 :constant 1)
(tt7-4 unsigned-integer 58 60 :constant 16)
(size unsigned-integer 60 64)
(data-lsw unsigned-integer 64 66)
(data-msw unsigned-integer 66 68)
(tt8-1 unsigned-integer 68 70 :constant 4097)
(tt8-2 unsigned-integer 70 72 :constant 4097)
(words-across unsigned-integer 72 74)
(tt9-1 unsigned-integer 74 76 :constant 4097)
(tt9-2 unsigned-integer 76 78 :constant 4097)
(ux unsigned-integer 78 80)
(tt10-1 unsigned-integer 80 82 :constant 4097)
(tt10-2 unsigned-integer 82 84 :constant 4097)
(uy unsigned-integer 84 86))
(defvar from-put-viewport-rectangle)
(def-alien-structure from-put-viewport-rectangle
(msg-size unsigned-integer 2 6 :constant 28)
(msg-local-port port 10 14 :constant viewport-reply-port)
(rc unsigned-integer 26 28 :direction read))
;;; Put-Viewport-Rectangle dumps a chunk of memory (i.e. an array) into a
;;; viewport. The parameters are :
;;; DESTVP - viewport to dump into.
;;; FUNCT - Rasterop function
;;; X,Y - The top lefthand corner of the viewport
;;; WIDTH, HEIGHT - The size of the rectangle in bits.
;;; SIZE - The size of the array in bits.
;;; DATA - The array
;;; WORDS-ACROSS - The number of words in one scan line of the array.
;;; - Must be a multiple of 4.
;;; UX,UY - The upper left corner of the rectangle in the array.
(defun put-viewport-rectangle (destvp funct x y width height size data
words-across ux uy)
"Put-Viewport-Rectangle dumps a chunk of memory (i.e. an array) into a
viewport. The parameters are :
DESTVP - viewport to dump into.
FUNCT - Rasterop function
X,Y - The top lefthand corner of the viewport
WIDTH, HEIGHT - The size of the rectangle in bits.
SIZE - The size of the array in bits.
DATA - The array
WORDS-ACROSS - The number of words in one scan line of the array.
- Must be a multiple of 4.
UX,UY - The upper left corner of the rectangle in the array."
(make-pointer-f data
(to-put-viewport-rectangle-data-lsw to-put-viewport-rectangle)
(to-put-viewport-rectangle-data-msw to-put-viewport-rectangle))
(multiple-alien-setq-to-put-viewport-rectangle
to-put-viewport-rectangle
(:msg-remote-port destvp)
(:funct funct)
(:x x)
(:y y)
(:width width)
(:size size)
(:height height)
(:words-across words-across)
(:ux ux)
(:uy uy))
(simple-send to-put-viewport-rectangle)
(simple-receive from-put-viewport-rectangle)
(from-put-viewport-rectangle-rc from-put-viewport-rectangle))
;;; VIEWPORT-INIT
;;; Viewport-init initializes the alien arg blocks for the viewport
;;; functions. Also VIEWPORT-REPLY-PORT is set to DATA-PORT
(defun viewport-init ()
(setq viewport-reply-port (allocate-port 0))
;; get *user-viewport*
(multiple-value-setq (*user-viewport* *viewport-x-size* *viewport-y-size*)
(window-viewport))
(setq to-put-viewport-rectangle (make-to-put-viewport-rectangle))
(setq from-put-viewport-rectangle (make-from-put-viewport-rectangle))
(setq to-viewport-state (make-to-viewport-state))
(setq from-viewport-state (make-from-viewport-state))
(setq to-view-rop (make-to-view-rop))
(setq to-kernel-view-rop (make-to-kernel-view-rop))
(setq to-view-color-rect (make-to-view-color-rect))
(setq to-kernel-view-line (make-to-kernel-view-line))
(setq to-view-line (make-to-view-line))
(setq to-enable-input (make-to-enable-input))
(setq from-enable-input (make-from-enable-input))
(setq to-get-event (make-to-get-event))
(setq from-get-event (make-from-get-event))
(setq to-view-put-ch-array (make-to-view-put-ch-array))
(setq to-kernel-put-string (make-to-kernel-put-string))
(setq to-get-sys-font (make-to-get-sys-font))
(setq from-get-sys-font (make-from-get-sys-font))
(setq to-set-cursor-pos (make-to-set-cursor-pos))
(setq to-load-font (make-to-load-font))
(setq from-load-font (make-from-load-font))
(setq to-font-size (make-to-font-size))
(setq from-font-size (make-from-font-size))
(setq to-font-char-size (make-to-font-char-size))
(setq from-font-char-size (make-from-font-char-size))
(setq to-font-string-size (make-to-font-string-size))
(setq from-font-string-size (make-from-font-string-size))
(setq to-set-listener (make-to-set-listener))
(setq from-set-listener (make-from-set-listener))
(setq to-destroy-viewport (make-to-destroy-viewport))
(setq to-make-viewport (make-to-make-viewport))
(setq from-make-viewport (make-from-make-viewport))
(setq to-modify-viewport (make-to-modify-viewport))
(setq from-modify-viewport (make-from-modify-viewport))
;; get *user-font*
(setq *current-viewport* *user-viewport*) ;;; we need to know
;;;*current-viewport*
;;;for get-sys-font
(get-sys-font)
(setq *current-font* *user-font*)
)