;;; **********************************************************************
;;; 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*)
  )