;;; **********************************************************************
;;; 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 sapphire.
;;;
;;; Written by Daniel Aronson
;;;
;;; **********************************************************************
;;; **********************************************************************
(declare (special null-port ;reply port when we don't want a reply.
*user-viewport* ;port to send viewport messages to.
data-port
sapphire-reply-port
*user-window*
*viewport-x-size*
*viewport-y-size*
port-death-message
))
(defvar *full-window* ()
"Full Sapphire window.")
;;; sapphire-reply-port holds the port which this process receives replies
;;; from the sapphire server on. It is initialized by sapphire-init.
;;; Window-Viewport
;;; The global special to-window-viewport stores an alien structure of type
;;; to-window-viewport This structure holds the message sent to sapphire
;;; by the window-viewport function. To-window-viewport is initialized
;;; by sapphire-init.
(defvar to-window-viewport)
(def-alien-structure to-window-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 sapphire-reply-port)
(msg-remote-port port 14 18 :default *user-window*)
(msg-id unsigned-integer 18 22 :constant 2204)
)
(defvar from-window-viewport)
(def-alien-structure from-window-viewport
(msg-size unsigned-integer 2 6 :constant 48)
(msg-local-port port 10 14 :constant sapphire-reply-port)
(viewport port 32 36 :direction read)
(width unsigned-integer 40 42 :direction read)
(height unsigned-integer 46 48 :direction read)
)
;;; Window-viewport fetches the viewport associated with *user-window*
;;; as well as the width and height of that viewport.
(defun window-viewport (&optional window)
(if window (setf (to-window-viewport-msg-remote-port
to-window-viewport)
window))
(simple-send to-window-viewport)
(simple-receive from-window-viewport)
(values (from-window-viewport-viewport from-window-viewport)
(from-window-viewport-width from-window-viewport)
(from-window-viewport-height from-window-viewport))
)
;;;CREATE-WINDOW
;;;Creates a window.
(defvar to-create-window)
(def-alien-structure to-create-window
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 244)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant sapphire-reply-port)
(msg-remote-port port 14 18 :default *user-window*)
(msg-id unsigned-integer 18 22 :constant 2201)
(tt1-1 unsigned-integer 22 24 :constant 4096)
(tt1-2 unsigned-integer 24 26 :constant 4097)
(fixed-position (selection () t) 26 28)
(tt2-1 unsigned-integer 28 30 :constant 4097)
(tt2-2 unsigned-integer 30 32 :constant 4097)
(leftx signed-integer 32 34)
(tt3-1 unsigned-integer 34 36 :constant 4097)
(tt3-2 unsigned-integer 36 38 :constant 4097)
(topy signed-integer 38 40)
(tt4-1 unsigned-integer 40 42 :constant 4096)
(tt4-2 unsigned-integer 42 44 :constant 4097)
(fixed-size (selection () t) 44 46)
(tt5-1 unsigned-integer 46 48 :constant 4097)
(tt5-2 unsigned-integer 48 50 :constant 4097)
(width signed-integer 50 52)
(tt6-1 unsigned-integer 52 54 :constant 4097)
(tt6-2 unsigned-integer 54 56 :constant 4097)
(height signed-integer 56 58)
(tt7-1 unsigned-integer 58 60 :constant 4096)
(tt7-2 unsigned-integer 60 62 :constant 4097)
(hastitle (selection () t) 62 64)
(tt8-1 unsigned-integer 64 66 :constant 4096)
(tt8-2 unsigned-integer 66 68 :constant 4097)
(hasborder (selection () t) 68 70)
(tt9-1 unsigned-integer 70 72 :constant 0)
(tt9-2 unsigned-integer 72 74 :constant 12288)
(tt9-3 unsigned-integer 74 76 :constant 12)
(tt9-4 unsigned-integer 76 78 :constant 1144)
(tt9-5 unsigned-integer 78 82 :constant 1)
(title perq-string 82 226)
(tt10-1 unsigned-integer 226 228 :constant 14348)
(tt10-2 unsigned-integer 228 230 :constant 4097)
(progname perq-string 230 238)
(tt11-1 unsigned-integer 238 240 :constant 4096)
(tt11-2 unsigned-integer 240 242 :constant 4097)
(hasicon (selection () t) 242 244)
)
(defvar from-create-window)
(def-alien-structure from-create-window
(msg-size unsigned-integer 2 6 :constant 80)
(msg-local-port port 10 14 :constant sapphire-reply-port)
(leftx unsigned-integer 32 34 :direction read)
(topy unsigned-integer 38 40 :direction read)
(width unsigned-integer 44 46 :direction read)
(height unsigned-integer 50 52 :direction read)
(progname perq-string 56 64 :direction read)
(viewport port 68 72 :direction read)
(window port 76 80 :direction read)
)
(defun create-window (fixedposition leftx topy fixedsize width height hastitle hasborder title progname hasicon &optional window)
(if window (setf (to-create-window-msg-remote-port to-create-window)
window))
(if (or (< width 10) (< height 15) (> width 16000) (> height 16000))
(error "Illegal size for Create-Window. Width = ~s, height = ~s."
width height))
(multiple-alien-setq-to-create-window
to-create-window
(:fixed-position fixedposition)
(:leftx leftx)
(:topy topy)
(:fixed-size fixedsize)
(:width width)
(:height height)
(:hastitle hastitle)
(:hasborder hasborder)
(:title title)
(:progname progname)
(:hasicon hasicon))
(simple-send to-create-window)
(simple-receive from-create-window)
(values (from-create-window-window from-create-window)
(from-create-window-viewport from-create-window)
(from-create-window-leftx from-create-window)
(from-create-window-topy from-create-window)
(from-create-window-width from-create-window)
(from-create-window-height from-create-window)
(from-create-window-progname from-create-window))
)
;;;GET-FULL-WINDOW
(defvar to-get-full-window)
(def-alien-structure to-get-full-window
(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 sapphire-reply-port)
(msg-remote-port port 14 18 :constant *user-window*)
(msg-id unsigned-integer 18 22 :constant 2226)
)
(defvar from-get-full-window)
(def-alien-structure from-get-full-window
(msg-size unsigned-integer 2 6 :constant 36)
(msg-local-port port 10 14 :constant sapphire-reply-port)
(full-window port 32 36 :direction read)
)
(defun get-full-window ()
(simple-send to-get-full-window)
(simple-receive from-get-full-window)
(from-get-full-window-full-window from-get-full-window))
;;;SET-TITLE
;;; Set-title Sets the title of the lisp listener.
(defvar to-set-title)
(def-alien-structure to-set-title
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 176)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant null-port)
(msg-remote-port port 14 18 :default *user-window*)
(msg-id unsigned-integer 18 22 :constant 2202)
(ipc-name1-1 unsigned-integer 22 24 :constant 0)
(ipc-name1-2 unsigned-integer 24 26 :constant 12288)
(tname2 unsigned-integer 26 28 :constant 12)
(tsize2 unsigned-integer 28 30 :constant 1144)
(num-elts unsigned-integer 30 34 :constant 1)
(string perq-string 34 176)
)
(defun set-title (title &optional window)
(if window (setf (to-set-title-msg-remote-port to-set-title)
window))
(setf (to-set-title-string to-set-title) title)
(simple-send to-set-title))
;;;DESTROY-WINDOW
(defvar to-destroy-window)
(def-alien-structure to-destroy-window
(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 null-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2203)
)
;;; After the window is destroyed we must receive the port death messages.
(defun destroy-window (window)
(setf (to-destroy-window-msg-remote-port to-destroy-window) window)
(simple-send to-destroy-window)
(simple-receive port-death-message)
(simple-receive port-death-message)
)
;;; MODIFY-WINDOW
(defvar to-modify-window)
(def-alien-structure to-modify-window
(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 sapphire-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2200)
(tt2-1 unsigned-integer 22 24 :constant 4097)
(tt2-2 unsigned-integer 24 26 :constant 4097)
(newleftx signed-integer 26 28)
(tt3-1 unsigned-integer 28 30 :constant 4097)
(tt3-2 unsigned-integer 30 32 :constant 4097)
(newtopy signed-integer 32 34)
(tt4-1 unsigned-integer 34 36 :constant 4097)
(tt4-2 unsigned-integer 36 38 :constant 4097)
(newouterwidth signed-integer 38 40)
(tt5-1 unsigned-integer 40 42 :constant 4097)
(tt5-2 unsigned-integer 42 44 :constant 4097)
(newouterheight signed-integer 44 46)
(tt6-1 unsigned-integer 46 48 :constant 4097)
(tt6-2 unsigned-integer 48 50 :constant 4097)
(newrank signed-integer 50 52)
)
(defvar from-modify-window)
(def-alien-structure from-modify-window
(msg-size unsigned-integer 2 6 :constant 28)
(msg-local-port port 10 14 :constant sapphire-reply-port)
(rc unsigned-integer 26 28 :direction read)
)
;;; Modify-window changes the size position and/or rank of a window. If
;;; any of the parameters are (-32005) then the user is required to supply the
;;; missing information.
(defun modify-window (newleftx newtopy newouterwidth newouterheight newrank
&optional (port *user-window*))
"Modify-window changes the size position and/or rank of a window. If
any of the parameters are (-32005) then the user is required to supply the
missing information."
(multiple-alien-setq-to-modify-window to-modify-window
(:msg-remote-port port)
(:newleftx newleftx)
(:newtopy newtopy)
(:newouterwidth newouterwidth)
(:newouterheight newouterheight)
(:newrank newrank))
(simple-send to-modify-window)
(simple-receive from-modify-window)
(if (/= (from-modify-window-rc from-modify-window) rc-success)
(error "RC = ~s." (from-modify-window-rc from-modify-window)))
)
;;; SET-WINDOW-PROGRESS
(defvar to-set-window-progress)
(def-alien-structure to-set-window-progress
(msg-simplep (selection () t) 0 2 :constant t)
(msg-size unsigned-integer 2 6 :constant 44)
(msg-type (selection 'normal-message 'emergency-message)
6 10
:constant 'normal-message)
(msg-local-port port 10 14 :constant sapphire-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2213)
(tt2-1 unsigned-integer 22 24 :constant 4097)
(tt2-2 unsigned-integer 24 26 :constant 4097)
(nestlevel unsigned-integer 26 28)
(tt3-1 unsigned-integer 28 30 :constant 8194)
(tt3-2 unsigned-integer 30 32 :constant 4097)
(value unsigned-integer 32 36)
(tt4-1 unsigned-integer 36 38 :constant 8194)
(tt4-2 unsigned-integer 38 40 :constant 4097)
(max unsigned-integer 40 44)
)
;;; Set-window-progress shows the progress in the icon and title area if
;;; appropriate. If MAX is 0 then random progress is done. If VALUE>=MAX
;;; then the progress bar is removed. NESTLEVEL determines which bar to show.
(defun set-window-progress (nestlevel value max
&optional (port *user-window*))
"Set-window-progress shows the progress in the icon and title area if
appropriate. If MAX is 0 then random progress is done. If VALUE>=MAX
then the progress bar is removed. NESTLEVEL determines which bar to show."
(multiple-alien-setq-to-set-window-progress to-set-window-progress
(:msg-remote-port port)
(:nestlevel nestlevel)
(:value value)
(:max max))
(simple-send to-set-window-progress)
)
;;; Window moving utilities
(defvar to-expand-window)
(def-alien-structure to-expand-window
(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 sapphire-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2220)
)
;;; Expands the specified window to be full screen.
(defun expand-window (port)
"Expands the specified window to be full screen."
(setf (to-expand-window-msg-remote-port to-expand-window) port)
(simple-send to-expand-window)
)
;;; ***************************************************************************
(defvar to-shrink-window)
(def-alien-structure to-shrink-window
(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 sapphire-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2221)
)
;;; Shrinks the window back to its original size.
(defun shrink-window (port)
"Shrinks the window back to its original size."
(setf (to-shrink-window-msg-remote-port to-shrink-window) port)
(simple-send to-shrink-window)
)
;;; ***************************************************************************
(defvar to-remove-window)
(def-alien-structure to-remove-window
(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 sapphire-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2222)
)
;;; Removes window from screen.
(defun remove-window (port)
"Removes window from screen."
(setf (to-remove-window-msg-remote-port to-remove-window) port)
(simple-send to-remove-window)
)
;;; ***************************************************************************
(defvar to-restore-window)
(def-alien-structure to-restore-window
(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 sapphire-reply-port)
(msg-remote-port port 14 18)
(msg-id unsigned-integer 18 22 :constant 2223)
)
;;; Restores window to old position on screen.
(defun restore-window (port)
"Restores window to old position on screen."
(setf (to-restore-window-msg-remote-port to-restore-window) port)
(simple-send to-restore-window)
)
(defun sapphire-init ()
(setq sapphire-reply-port (allocate-port 0))
(setq to-window-viewport (make-to-window-viewport))
(setq from-window-viewport (make-from-window-viewport))
(setq to-set-title (make-to-set-title))
(setq to-create-window (make-to-create-window))
(setq from-create-window (make-from-create-window))
(setq to-destroy-window (make-to-destroy-window))
(setq to-get-full-window (make-to-get-full-window))
(setq from-get-full-window (make-from-get-full-window))
(setq to-modify-window (make-to-modify-window))
(setq from-modify-window (make-from-modify-window))
(setq to-set-window-progress (make-to-set-window-progress))
(setq to-expand-window (make-to-expand-window))
(setq to-shrink-window (make-to-shrink-window))
(setq to-remove-window (make-to-remove-window))
(setq to-restore-window (make-to-restore-window))
(setq *full-window* (get-full-window))
)