;;; **********************************************************************
;;; 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 TypeScript server.
;;; 
;;; Written by  Daniel Aronson
;;;
;;; **********************************************************************

(proclaim '(special null-port data-port typescript-reply-port))

;;; typescript-reply-port holds the port which this process receives replies 
;;; from the typescript server on.  It is initialized by typescript-init.

(defvar typescript-reply-port)
;;; sts-get-string

;;; The global special to-sts-get-string stores an alien structure of type
;;;  to-sts-get-string  This structure holds the message sent to the typescript
;;;  server by the sts-get-string function.  To-sts-get-string is initialized by
;;;  typescript-init.

(defvar to-sts-get-string)
(def-alien-structure to-sts-get-string
  (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 typescript-reply-port)
  (msg-remote-port port 14 18 :direction write)
  (msg-id unsigned-integer 18 22 :constant 2806)
  )


(defvar from-sts-get-string)
(def-alien-structure from-sts-get-string
  (msg-size unsigned-integer 2 6 :constant 296)
  (msg-local-port port 10 14 :constant typescript-reply-port)
  (string perq-string 40 296 :direction read))

;;; sts-get-string returns the string from the typescript server.

(defun sts-get-string (typescript)
  (setf (to-sts-get-string-msg-remote-port to-sts-get-string) typescript)
  (simple-send to-sts-get-string)
  (simple-receive from-sts-get-string)
  (from-sts-get-string-string from-sts-get-string))


(defvar to-sts-put-string)
(def-alien-structure to-sts-put-string
  (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 typescript-reply-port)
  (msg-remote-port port 14 18 :direction write)
  (msg-id unsigned-integer 18 22 :constant 2808)
  (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 2048)
  (num-elts unsigned-integer 30 34 :constant 1)
  (string perq-string 34 290 :direction write)
  )




(defun sts-put-string (typescript string &optional (length (length string)))
  "write out the string STRING to TYPESCRIPT.  Make its length LENGTH."
  (setf (to-sts-put-string-string to-sts-put-string) string)
  (%sp-typed-v-store 3 (alien-structure-data to-sts-put-string) 34 length)
  (simple-send to-sts-put-string)) 


(def-alien-field-type character 		;Move this to alien sometime.
  'character
  'unsigned-integer
  #'code-char
  #'char-code)



(defvar to-sts-put-char)
(def-alien-structure to-sts-put-char
  (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 typescript-reply-port)
  (msg-remote-port port 14 18 :direction write)
  (msg-id unsigned-integer 18 22 :constant 2807)
  (char-type1 unsigned-integer 22 24 :constant 2056)
  (char-type2 unsigned-integer 24 26 :constant 4097)
  (char character 26 28 :direction write)
  )

(defun sts-put-char (typescript char)
  "Outputs character CHAR to the typescript"
  (multiple-alien-setq-to-sts-put-char to-sts-put-char
    (:msg-remote-port typescript)
    (:char char))
  (simple-send to-sts-put-char))


(defvar to-sts-put-char-array)
(def-alien-structure to-sts-put-char-array
  (msg-simplep (selection () t) 0 2 :constant nil)
  (msg-size unsigned-integer 2 6 :constant 50)
  (msg-type (selection 'normal-message 'emergency-message)
	    6 10
	    :constant 'normal-message)
  (msg-local-port port 10 14 :constant typescript-reply-port)
  (msg-remote-port port 14 18 :direction write)
  (msg-id unsigned-integer 18 22 :constant 2813)
  (chars-type1 unsigned-integer 22 24 :constant 0)
  (chars-type2 unsigned-integer 24 26 :constant 8192)
  (chars-type3 unsigned-integer 26 28 :constant 8)
  (chars-size unsigned-integer 28 30 :constant 8)
  (count unsigned-integer 30 34 :direction write)
  (chars-lsw unsigned-integer 34 36 :direction write)
  (chars-msw unsigned-integer 36 38 :direction write)
  (first-ch-type1 unsigned-integer 38 40 :constant 4097)
  (first-ch-type2 unsigned-integer 40 42 :constant 4097)
  (first-ch unsigned-integer 42 44 :direction write)
  (last-ch-type1 unsigned-integer 44 46 :constant 4097)
  (last-ch-type2 unsigned-integer 46 48 :constant 4097)
  (last-ch unsigned-integer 48 50 :direction write))

(defun sts-put-char-array (typescript string start end)
  (make-pointer-f string
		  (to-sts-put-char-array-chars-lsw to-sts-put-char-array)
		  (to-sts-put-char-array-chars-msw to-sts-put-char-array))
  (multiple-alien-setq-to-sts-put-char-array to-sts-put-char-array
    (:msg-remote-port typescript)
    (:first-ch start)
    (:last-ch (1- end))
    (:count (- end start)))
  (simple-send to-sts-put-char-array))

(defun typescript-init ()
  "Initialize global variables used by typescript functions."
  (setq typescript-reply-port (allocate-port 0))
  (setq to-sts-get-string (make-to-sts-get-string))
  (setq from-sts-get-string (make-from-sts-get-string))
  (setq to-sts-put-string (make-to-sts-put-string))
  (setq to-sts-put-char (make-to-sts-put-char))
  (setq to-sts-put-char-array (make-to-sts-put-char-array))
  )