;;Copyright (C) 1994 W. Schelter

;; This file is part of GNU Common Lisp, herein referred to as GCL
;;
;; GCL is free software; you can redistribute it and/or modify it under
;;  the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; 
;; GCL is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
;; FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
;; License for more details.
;; 

;;; Ported to work under CMU Lisp by Thorsten Schnier
;;; January 1997
;;;
;;; PLEASE SEND ALL QUESTIONS REGARDING THIS PORT TO ME 
;;; (thorsten@arch.usyd.edu.au) !!!!!
;;;
;;; Please read the README !




#+cmu
(defpackage "TK"
  (:use :extensions :common-lisp :c-call))

#+allegro
(defpackage "TK"
  (:use :common-lisp))


(in-package "TK")

(defconstant *tk-package* (find-package :tk))


;;; Some configuration variables:

;;; The interrupt number for SIGUSR1
;;; the first linux beta needed 10 there (build-ins  are incorrect)
;;; newer versions and other OSs should have the correct numbering
;;; Allegro however gets the numbering wrong

#+cmu
(defconstant *sigusr1-number* unix:sigusr1)	;linux signal # for sigusr1
#+(and allegro linux86)
(defconstant *sigusr1-number* 10)	;linux signal # for sigusr1
#+(and allegro sparc)
(defconstant *sigusr1-number* 16)	;solaris signal # for sigusr1

;;; where to find gcltksrv; it also searches a few build-in paths, and
;;; GCLTKSRV if set in the environment (prefered)

#+sparc (defconstant *gcltksrv-path* "/packages/depot/lisp/lib/gcl-2.2/gcl-tk/gcltksrv")
#-sparc (defconstant *gcltksrv-path* "/usr/lib/cmucl/gcltksrv")


;;; where to find the gcltk tcl init file
#-sparc (defconstant *gcltcl-path* "/usr/lib/cmucl/gcl.tcl")
#+sparc (defconstant *gcltcl-path* "/packages/depot/lisp/lib/gcl-2.2/gcl-tk/gcl.tcl")



(eval-when (compile) 
  (proclaim '(ftype (function (t fixnum fixnum) fixnum) set-message-header
		    get-number-string))
  (proclaim '(ftype (function (t t fixnum) t) store-circle))
  (proclaim '(ftype (function (t fixnum) t) get-circle))
  (proclaim '(ftype (function (t fixnum fixnum fixnum) fixnum)
		    push-number-string))
)

; Functions added to get it working under CMU and Allegro

; I have modified the blocking behaviour, sigio comes more often than sigusr,
; therefore it has to be blocked at additional positions. After a block is
; resolved, I always call read-and act just in case.


(defvar *block-tk-input* nil)
(defvar *old-sigusr1-handler* :not-set)	;we can't use nil, since nil is a valid handler

(defmacro without-input-processing (&rest body)
  "this blocks interrupts, and calls (read-and-act) afterwards to process any data that
might have arrived"
  `(prog1
       (let ((*block-tk-input* t))
	 (block nil ,@body))
     (unless *block-tk-input* (read-and-act nil))))


#+cmu
(defmacro getenv (symbol)
  `(cdr (assoc ,symbol *environment-list*)))

#+allegro
(defmacro getenv (symbol)
  (system:getenv (symbol-name symbol)))

(defvar *nothing-needs-quoting* (make-array 256 :element-type '(member nil t)
					    :initial-element nil))
(defvar *some-need-quoting* (make-array 256 :element-type '(member nil t) :initial-element nil))
(setf (svref *some-need-quoting* (char-code #\")) t
      (svref *some-need-quoting* (char-code #\$)) t
      (svref *some-need-quoting* (char-code #\\)) t
      (svref *some-need-quoting* (char-code #\[)) t
      )


(defun convert-string (string needs-quoting downcase result-string)
  (declare (special *some-need-quoting*)
	   (type (simple-array (member t nil) (256)) *some-need-quoting*)
	   (type (member nil t) needs-quoting downcase)
	   (type string string result-string))
  (do ((index 0 (1+ index))
       (current #\space))
      ((= index (length string)) t)
    (declare (fixnum index) (character current))
  (setf current (char string index))
    (when (and needs-quoting (svref *some-need-quoting* (char-code current)))
      (vector-push-extend #\\ result-string))
    (vector-push-extend (if downcase (char-downcase current) current) result-string)))


(defun write-float (float-value array)
  "writes a float into a fill-pointer-array, with 2 trailing digits precision"
  (declare (single-float float-value)
	   (string array))
  (when (minusp float-value)
    (setf float-value (- float-value))
    (vector-push #\- array))
  (do* ((short-value float-value)
	(zero (char-code #\0))
	(digits (max 0 (the fixnum (if (= 0.0 short-value) 0
			 (floor (log short-value 10)))))
		(1- digits))
	(normalized-value (/ short-value (the single-float (expt 10.0 digits)))))
      ((= digits -3) array)
    (declare (fixnum digits)
	     (single-float normalized-value short-value))
    (when (= digits -1) (vector-push #\. array))
    (multiple-value-bind (digit remainder) (floor normalized-value)
      (declare (short-float remainder) (fixnum digit))
      (setf normalized-value (the single-float (* 10.0 remainder)))
      (vector-push-extend (code-char (the fixnum (+ zero digit))) array))))
	

(defun write-integer (int-value array)
  "writes an integer into a fill-pointer-array"
  (declare (fixnum int-value)
	   (string array))
  (when (minusp int-value)
    (setf int-value (- int-value))
    (vector-push #\- array))
  (do* ((zero (char-code #\0))
	(digits (if (= 0 int-value) 0
		  (floor (log int-value 10)))
		(1- digits))
	(divisor (expt 10 digits) (max 1 (/ divisor 10))))
      ((= digits -1) array)
    (declare (fixnum digits divisor))
    (multiple-value-bind (digit remainder) (floor int-value divisor)
      (declare (fixnum digit remainder))
      (setf int-value remainder)
      (vector-push-extend (code-char (+ zero digit)) array))))
	


(declaim (inline convert-string write-float write-integer))

(defun print-to-string1 (result-string object code)
  "Print to STRING the object X according to CODE.   The string must have fill pointer, and this will be advanced."
  (declare (type keyword object))
  (let ((downcase (symbolp object))
	(do-end-quote nil)
	(needs-quoting
	 (null (member code '(:no-code :no-quotes-and-and-no-leading-space)))))
    (declare (type (member nil t) downcase do-end-quote needs-quoting))
    (unless (and (arrayp result-string)
		 (array-has-fill-pointer-p result-string))
      (error "Must be given string with fill pointer"))
    
    (case code
      (:no-quote-downcase (setf downcase t) (vector-push #\space result-string))
      (:no-quote (vector-push-extend #\space result-string))
      (:normal (vector-push-extend #\space result-string)
	       (when (stringp object)
		 (setf do-end-quote t)
		 (vector-push-extend #\" result-string)))
      (:no-leading-space (when (stringp object)
			   (setf do-end-quote t)
			   (vector-push-extend #\" result-string)))
      (:begin-join (vector-push-extend #\space result-string)
		   (vector-push-extend #\" result-string))
      (:begin-join-no-leading-space (vector-push-extend #\" result-string))
      (:end-join (setf do-end-quote t))
      ((:no-quote-no-leading-space :no-quotes-and-no-leading-space) t)
      (:join-follows t)
      (t (error "unknown code ~s" code)))
	
    (typecase object
      (keyword (when (eql code :normal) (vector-push-extend #\- result-string))
	       (convert-string (symbol-name object) needs-quoting downcase result-string))
      (symbol (convert-string (symbol-name object) needs-quoting downcase result-string))
      (string (convert-string object needs-quoting downcase result-string))
      (bignum (return-from print-to-string1 nil)) 
      (fixnum (write-integer (coerce object 'fixnum) result-string)) ;bug in CMU requires this cast ?
      (float  (write-float (coerce object 'single-float) result-string))
      (t (error "Bad type for print_string %s" (type-of object))))
    
    (when do-end-quote (vector-push-extend #\" result-string))
  t))
      


(defstruct cs
  (stream nil)
  (fd -1 :type fixnum)
  (port 0 :type fixnum)
  (total-bytes-sent 0 :type fixnum)
  (total-bytes-recieved 0 :type fixnum)
  (bytes-recieved-not-confirmed 0 :type fixnum)
  (bytes-sent-not-recieved 0 :type fixnum)
  (left-in-packet 0 :type fixnum)
  (max-allowed-in-pipe 2200 :type fixnum))


#+cmu
(defmacro socket-stream-read-char-no-hang (stream &optional (timeout 0))
  `(let ((old-timeout (lisp::fd-stream-timeout ,stream)))
     (setf (lisp::fd-stream-timeout ,stream) ,timeout)
     (prog1 
	 (handler-case (read-char ,stream)
		       (system:io-timeout nil)
		       (:no-error (char) char))
       (setf (lisp::fd-stream-timeout ,stream) old-timeout))))

#+allegro
(defmacro socket-stream-read-char-no-hang (stream &optional (timeout 0))
  `(do* ((end-time (+ (get-universal-time) ,timeout))
	 (data
	  (handler-case (read-char-no-hang ,stream)
			(file-error ()) ;ignore, to protect against 'interrupted-system call
			(:no-error (result) result))
	  (handler-case (read-char-no-hang ,stream)
			(file-error ()) ;ignore, to protect against 'interrupted-system call
			(:no-error (result) result))))
       ((or data (>= (get-universal-time) end-time)) data)))

#+never
(defmacro socket-stream-read-char-no-hang (stream &optional (timeout 0))
  `(do* ((end-time (+ (get-universal-time) ,timeout))
	 (data (read-char-no-hang ,stream) (read-char-no-hang ,stream)))
       ((or data (>= (get-universal-time) end-time)) data)))



(defun check-state-input (stream timeout)
  (dformat "check-state-input ~d" timeout)
  (let ((char (socket-stream-read-char-no-hang stream timeout)))
    (if char (progn (unread-char char stream) char)
      nil)))

  
(defun clear-connection-state (connection)
  (do
      ((count 0 (1+ count)))
      ((not (socket-stream-read-char-no-hang (cs-stream connection)))
       (incf (cs-bytes-recieved-not-confirmed connection) count)
       (setf (cs-left-in-packet connection) 0)
       count)
    (declare (fixnum count))))
       

  
(defun copy-string-portion
  (from-string to-string from-start to-start
	       &optional (count (min (- (length from-string) from-start)
				     (- (length to-string) to-start))))
  (declare (type string from-string to-string)
	   (fixnum from-start to-start count))
  (do
      ((from-pointer from-start (1+ from-pointer))
       (to-pointer to-start (1+ to-pointer)))
      ((= from-pointer (+ from-start count)) to-string)
    (declare (fixnum from-pointer to-pointer))
    (setf (char to-string to-pointer) (char from-string from-pointer))))
  

(defconstant *ll-max-packet-size* 1000) 
(defvar *ll-header* (make-string 5 :initial-element (code-char 0)))
(defconstant *ll-magic* (code-char 134))
(defconstant *ll-header-size* 5)
(defconstant *ll-must-confirm* 2000)




(defun our-read (state buffer length)
  (declare (type cs state)
	   (type base-string buffer)
	   (type fixnum length))
  (dformat "entering our-read with ~d bytes left in packet buffer, wanting ~d"
	   (cs-left-in-packet state) length)
  (do* 
      ((wanted length (- wanted read-last-time))
       (bytes-read 0 (+ bytes-read read-last-time))
       (read-last-time 0 0)		;is set during the loop and used above (sequential binding)
       (first t nil))			;go read once at least
      ((and (>= 0 wanted) (not first))
       (dformat "exiting our-read with ~d bytes left in packet buffer" (cs-left-in-packet state))
       (incf (cs-total-bytes-recieved state) bytes-read)
       length)				;cheating a bit, always returning success
    (declare (fixnum wanted bytes-read))
    (when (= 0 (cs-left-in-packet state)) ;end of previous packet, or none yet
      (let ((magic-recieved  (read-char (cs-stream state))))
	(unless (char= *ll-magic* magic-recieved)
	  (error "wrong low-level magic recieved: got ~d wanted ~d"
		 (char-code *ll-magic*) (char-code magic-recieved))))
      (setf (cs-left-in-packet state) (+ (char-code (read-char (cs-stream state)))
					 (* 256 (char-code (read-char (cs-stream state))))))
      (dformat "Package size ~d" (cs-left-in-packet state))
      (decf (cs-bytes-sent-not-recieved state) (+ (char-code (read-char (cs-stream state)))
						  (* 256 (char-code (read-char (cs-stream state))))))
      (incf bytes-read 5)
      (incf (cs-bytes-recieved-not-confirmed state) 5)
      (decf (cs-left-in-packet state) 5) ;header is counted as part of packet
      (when (and (= 0 (cs-left-in-packet state)) (not (check-state-input (cs-stream state) 0)))
	(return-from our-read 0))) ;only empty packet, nothing else, no sense in trying 
    (when (and (< 0 (cs-left-in-packet state)) ;maybe empty packet recieved
	       (< 0 wanted))
      (vector-push (read-char (cs-stream state)) buffer)
      (incf (cs-bytes-recieved-not-confirmed state))
      (decf (cs-left-in-packet state))
      (setf read-last-time 1))
    (when (> (cs-bytes-recieved-not-confirmed state) *ll-must-confirm*)
      (send-confirmation state))
    ))


(defun send-confirmation (state) (our-write state ""))

(defun our-write (state text)
  (declare (type cs state)
	   (type base-string text))
  (do*
      ((bytes (length text) (- bytes (- n-to-send *ll-header-size*)))
       (n-to-send (min *ll-max-packet-size* (+ bytes *ll-header-size*))
		  (min *ll-max-packet-size* (+ bytes *ll-header-size*)))
       (offset 0)
       (first t nil))
      ((and (= 0 bytes) (not first)) n-to-send)
    (declare (fixnum bytes n-to-send offset))
    ;;do we really have to have the server confirm sent bytes? Maybe, not to drown him.
;    (loop  while (and (< 0 bytes)
;		      (> (cs-bytes-sent-not-recieved state) (cs-max-allowed-in-pipe state)))
;	   do (dformat "~%calling read to get byte confirmation")
;	   (our-read state "" 0))	;try to get confirmation of recieved bytes
    (setf (schar *ll-header* 0) *ll-magic*)
    (setf (schar *ll-header* 1) (code-char (ldb (byte 8 0) n-to-send)))
					;low nibble packet size
    (setf (schar *ll-header* 2) (code-char (ldb (byte 8 8) n-to-send)))
					;high nibble 
    (setf (schar *ll-header* 3) (code-char (ldb (byte 8 0)
						(cs-bytes-recieved-not-confirmed state))))
    (setf (schar *ll-header* 4) (code-char (ldb (byte 8 8)
						(cs-bytes-recieved-not-confirmed state))))
    (setf (cs-bytes-recieved-not-confirmed state) 0)
    (incf (cs-bytes-sent-not-recieved state) n-to-send)
    (incf (cs-total-bytes-sent state) n-to-send)
    (write-string *ll-header* (cs-stream state))
    (write-string (subseq text offset (+ offset (- n-to-send *ll-header-size*)))
		  (cs-stream state))
    (incf offset (- n-to-send *ll-header-size*))
    (finish-output (cs-stream state))
     ))



;(eval-when (compile eval load)

(defconstant *header* '(magic1 magic2 type flag body-length nil nil msg-index nil nil))

;;enum print_arglist_codes {..};
(defvar *print-arglist-codes*
  '(
    :normal
    :no-leading-space
    :join-follows
    :end-join
    :begin-join
    :begin-join-no-leading-space
    :no-quote
    :no-quote-no-leading-space
    :no-quote-downcase
    :no-quotes-and-no-leading-space

    ))

(defconstant *mtypes*
  '( m_not_used
     m_create_command
     m_reply
     m_call
     m_tcl_command
     m_tcl_command_wait_response
     m_tcl_clear_connection  
     m_tcl_link_text_variable
     m_set_lisp_loc
     m_tcl_set_text_variable
     m_tcl_unlink_text_variable
     ))

(defconstant *magic1* #\)
(defconstant *magic2* #\A)


(defvar *some-fixnums* (make-array 3 :element-type 'fixnum))
(defmacro msg-index () `(the fixnum
      		    (aref (the (simple-array fixnum) *some-fixnums*) 0)))


(defmacro pos (flag lis)
  (locally
   (declare (list lis) (symbol flag))
   (or
    (member flag (symbol-value lis))
    (error "~a is not in ~a" flag lis))
   (position flag (symbol-value lis))))

(defmacro pos2 (flag lis)
  (locally
   (declare (list lis) (symbol flag))
   (or
    (member flag (symbol-value lis))
    (error "~a is not in ~a" flag lis))
  flag))


(defun desetq-consp-check (val)
  (or (consp val) (error "~a is not a cons" val)))

(defun desetq1 (form val)
  (cond ((symbolp form)
	 (cond (form			;(push form *desetq-binds*)
		`(setf ,form ,val))))
	((consp form)
	 `(progn
	    (desetq-consp-check ,val)
	    ,(desetq1 (car form) `(car ,val))
	    ,@ (if (consp (cdr form))
		   (list(desetq1 (cdr form) `(cdr ,val)))
		 (and (cdr form) `((setf ,(cdr form) (cdr ,val)))))))
	(t (error ""))))

(defmacro desetq (form val)
  (cond ((atom val) (desetq1 form val))
	(t (let ((value (gensym)))
	     `(let ((,value ,val)) , (desetq1 form value))))))

(defmacro while (test &body body)
  `(loop while ,test do ,@ body))

;)

;(defmacro nth-value (n form)
;  (declare (fixnum n))
;  `(multiple-value-bind ,(make-list (+ n 1) :initial-element 'a) ,form  a))

(defvar *tk-command* nil)

(defvar *debugging* nil)
(defvar *break-on-errors* nil)

(defvar *tk-connection* nil )

;; array of functions to be invoked from lisp.
(defvar *call-backs* (make-array 20 :fill-pointer 0 :adjustable t ))

;;array of message half read. Ie read header but not body.
(defvar *pending* nil)

;;circular array for replies,requests esp for debugging
;; replies is used for getting replies.
(defvar *replies* (make-array (expt 2 7)) "circle of replies to requests in *requests*")

;; these are strings
(defvar *requests* (make-array (expt 2 7)))

;; these are lisp forms
(defvar *request-forms* (make-array 40))



(defvar *read-buffer* (make-array 400 :element-type 'standard-char
				  :fill-pointer 0 ))

(defvar *text-variable-locations*
  (make-array 10 :fill-pointer 0 :adjustable t))



(defvar *command-strings*
  (loop for i fixnum  below 2 collect
       (make-array 500 :element-type 'standard-char :fill-pointer 0 :adjustable t :initial-element #\space )))

(defvar *string-streams* (list (make-string-input-stream "") (make-string-input-stream "")))

(defmacro with-tk-command (&body body)
  `(let ((tk-command "")
	 (*command-strings* *command-strings*))
     (declare (type string tk-command))
     (setq tk-command (grab-tk-command))
     ,@ body))

(defun grab-tk-command( &aux x)
  ;; keep a list of available *command-strings* and grab one
  (unless (cdr *command-strings*)
    (setq x (list (make-array 500
			      :element-type 'standard-char
			      :fill-pointer 0 :adjustable t
			      :initial-element #\space ))
	  )
    (unless  *command-strings* (error "how??"))
    (setq *command-strings* (nconc *command-strings* x)))
  (let ((x (car *command-strings*)))
    (setq  *command-strings* (cdr *command-strings*))
    (setf (fill-pointer x ) #.(length *header*))
    x
    ))

(defun print-to-string (str x code)
  (declare (type base-string str)
	   (type keyword code))
  (cond ((consp x)
	 (cond ((eq (car x) 'a)
		(setq x (cdr x)
		      code (pos2 :no-quote *print-arglist-codes*)))
	       ((eq (car x) 'd)
		(setq x (cdr x)
		      code (pos2 :no-quote-downcase *print-arglist-codes*)))
	       (t (error "bad arg ~a" x)))))
  (while (null (print-to-string1 str x code))
    (cond ((typep x 'bignum)
	   (setq x (format nil "~a" x)))
	  (t (setq str (adjust-array str
				     (the fixnum
					  (+ (the fixnum
						  (array-total-size str))
					     (the fixnum
						  (+ 
						   (if (stringp x)
						       (length (the string x))
						     0)
					      70))))
				     :fill-pointer (fill-pointer str)
				     :element-type 'string-char)))))
  str)


;(defmacro pp (x code)
;  (let ((u `(pos2 ,code *print-arglist-codes*)))
;  `(print-to-string tk-command ,x ,u)))

(defmacro pp (x code)
  `(print-to-string tk-command ,x ,code))

(defun print-arglist (to-string l &aux v in-join x)
  (while l
    (setq v (cdr l))
    (setq x (car l))
    (cond
     ((eql (car v) ':|| )
      (print-to-string to-string x
		       (if in-join
			   (pos2 :join-follows *print-arglist-codes*)
			 (pos2 :begin-join *print-arglist-codes*)))
      (setq in-join t)
      (setq v (cdr v)))
     (in-join
      (print-to-string to-string x (pos2 :end-join *print-arglist-codes*))
      (setq in-join nil))
     (t
      (print-to-string to-string x (pos2 :normal *print-arglist-codes*))))

    (setq l v)
    ))
     
(defmacro p (&rest l)
  `(progn ,@ (loop for v in l collect `(p1 ,v))))

(defvar *send-and-wait* nil "If not nil, then wait for answer and check result")

(defun tk-call (fun &rest l &aux result-type)
  (with-tk-command
   (pp fun :no-leading-space)
   (setq result-type (prescan-arglist l nil nil))
   (print-arglist tk-command l)
   (cond (result-type
	  (call-with-result-type tk-command result-type))
	 (t  (send-tcl-cmd *tk-connection* tk-command nil)
	     (values)))))

(defun tk-do (str &rest l &aux )
  (with-tk-command
       (pp str :no-quotes-and-no-leading-space)
       ;; leading keyword printed without '-' at beginning.
       (while l
	 (pp (car l) :no-quotes-and-no-leading-space)
	 (setq l (cdr l)))
       (call-with-result-type tk-command 'string)))

;;; I've converted copy-string-portion, but this function isn't actually called
(defun tk-do-no-wait (str &aux (n (length str)))
  (declare (type base-string str)
	   (fixnum n))
  (with-tk-command
   (copy-string-portion str  tk-command 0  #.(length *header*) n)
   (setf (fill-pointer tk-command) (the fixnum (+ n  #.(length *header*))))
   (let ()
     (send-tcl-cmd *tk-connection* tk-command nil))))

(defun send-tcl-cmd (connection str send-and-wait)
  (declare (type base-string str)
	   (type cs connection))
  (or send-and-wait (setq send-and-wait *send-and-wait*))
  (vector-push-extend (code-char 0) str)
  (let ((msg-id (set-message-header str
				    (if send-and-wait
					(pos m_tcl_command_wait_response *mtypes*)
				      (pos m_tcl_command *mtypes*))
				    (the fixnum
				      (- (length str)
					 #.(length *header*))))))
    
    (cond (send-and-wait
	   (if *debugging*
	       (store-circle *requests* (subseq str #.(length *header*))
			     msg-id))
	   (store-circle *replies* nil  msg-id)
	   (execute-tcl-cmd connection str))
	  (t (store-circle *requests* nil msg-id)
	   (write-to-connection connection str)))))

  
(defun send-tcl-create-command (c str)
  (declare (type base-string str))
  (vector-push-extend (code-char 0) str)
  (set-message-header str (pos m_create_command *mtypes*)
		      (- (length str) #.(length *header*)))
  (write-to-connection c str))

(defun write-to-connection (connection string)
  (without-input-processing 
   (unless (and connection (open-stream-p (cs-stream connection)))
     (error "Trying to write to non open connection "))
   (if *debugging* (describe-message string))
   (our-write connection string)))

(defun coerce-string (a)
  (typecase a
    (string a)
    (fixnum  (format nil "~a" a))
    (number  (format nil "~,2f" (float a)))
    (keyword (format nil "-~(~a~)" a))
    (symbol (format nil "~(~a~)" a))
    (t (error "bad type"))))

;;2 decimals

(defun my-conc (a b)
  (setq a (coerce-string a))
  (setq b (coerce-string b))
  (concatenate 'string a b ))

;; In an arglist   'a : b' <==> (tk-conc a b)
;; eg:   1  : "b" <==> "1b"
;        "c" : "b" <==> "cb"
;        'a  : "b" <==> "ab"
;       '.a  : '.b  <==> ".a.b"
;       ':ab : "b"  <==> "abb"

;;Convenience for concatenating symbols, strings, numbers
;;  (tk-conc '.joe.bill ".frame.list yview " 3) ==> ".joe.bill.frame.list yview 3"

(defun tk-conc (&rest l)
  (let ((tk-command
	 (make-array 300 :element-type 'standard-char
		     :fill-pointer 0 :adjustable t :initial-element #\space)))
    (cond ((null l))
	  (t (pp (car l) :no-quote-no-leading-space)))
    (setq l (cdr l))
    (while (cdr l)
      (pp (car l) :join-follows) (setq l (cdr l)))
    (and l (pp (car l) :no-quote-no-leading-space))
    tk-command
    ))



(defun prescan-arglist (l pathname name-caller &aux result-type)
  (let ((v l) tem prev a )
;    (verify-list l) ; unnecessary all are from &rest args.
; If pathname supplied, then this should be an alternating list
;; of keywords and values.....
    (loop while v
       do 	 (setq a (car v))
       (cond
	((keywordp a)
	 (cond
	  ((eq (car v) :return)
	   (setf result-type (cadr v))
	   (cond (prev
		  (setf (cdr prev) (cddr v)))
		 (t (setf (car v) '(a . ""))
		    (setf (cdr v) (cddr v)))))
	  ((setq tem (get a 'prescan-function))
	   (funcall tem a v pathname name-caller)))))
       (setq prev v)
       (setq v (cdr v)))
    result-type))

(eval-when (compile eval load)
(defun set-prescan-function (fun &rest l)
  (dolist (v l) (setf (get v 'prescan-function) fun)))
)
	 
	  
(set-prescan-function 'prescan-bind :bind)
(defun prescan-bind
       (x  v pathname name-caller &aux tem)
      name-caller pathname x
      (cond ((setq tem (cdddr v))
	     (or
	      (keywordp (car tem))
	      (eq (cadr tem) ':|| )
		 (setf (car tem)
		       (tcl-create-command (car tem)
					   nil 
					   t))))))

(set-prescan-function 'prescan-command :yscroll :command
		      :postcommand
		      :xscroll
		      :yscrollcommand
		      :xscrollcommand
		      :scrollcommand)

(defun prescan-command (x v pathname name-caller &aux tem arg)
  x pathname
  (setq arg (cond (( member v     '(:xscroll
				    :yscrollcommand
				    :xscrollcommand
				    :scrollcommand))
		   
		   'aaaa)
		  ((get name-caller 'command-arg))))
  (cond ((setq tem (cdr v))
	 (cond ((eq (car tem) :return ) :return)
	       (t
		(setf (car tem)
		      (tcl-create-command (car tem) arg nil)))))))
  
(defun prescan-value (a v pathname name-caller)
  a name-caller
  (let* ((va (get pathname ':variable))
	 (type (get va 'linked-variable-type))
	 (fun (cdr (get type
			'coercion-functions))))
    (or va
	(error
	 "Must specify :variable before :value so that we know the type"))
    (or fun (error "No coercion-functions for type ~s" type))
    (setq v (cdr v))
    (if v
	(setf (car v) (funcall fun (car v))))))

(set-prescan-function 'prescan-value :value :onvalue :offvalue)

(set-prescan-function
 #'(lambda (a v pathname name-caller)
     a
     (let ((va (second v))
	   (type (cond ((eql name-caller 'checkbutton) 'boolean)
		       (t 'string))))
       (cond ((consp va)
	      (desetq (type va) va)
	      (or (symbolp va)
		  (error "should be :variable (type symbol)"))))
       (cond (va
	      (setf (get pathname a) va)
	      (setf (second v)
		    (link-variable   va type))))))
 :variable :textvariable)

(defun make-widget-instance (pathname widget)
  ;; ??make these not wait for response unless user is doing debugging..
  (or (symbolp pathname) (error "must give a symbol"))
  #'(lambda ( &rest l &aux result-type (option (car l)))
      (setq result-type (prescan-arglist l pathname  widget))
      (if (and *break-on-errors* (not result-type))
	  (store-circle *request-forms*
			(cons pathname (copy-list l))
			(msg-index)))
      (with-tk-command
       (pp pathname :no-leading-space)
       ;; the leading keyword gets printed with no leading -
       (or (keywordp option)
	   (error "First arg to ~s must be an option keyword not ~s"
		  pathname option ))
       (pp option :no-quote)
       (setq l (cdr l))
       (cond ((and (keywordp (car l))
		   (not (eq option :configure))
		   (not (eq option :config))
		   (not (eq option :postscript))
			)
	      (pp (car l) :no-quote)
	      (setq l (cdr l))))
       (print-arglist tk-command l)
       (cond (result-type
	      (call-with-result-type tk-command result-type))
	    (t  (send-tcl-cmd *tk-connection* tk-command nil)
		(values))))))

(defmacro def-widget (widget &key (command-arg 'sssss))
  `(eval-when (compile eval load)
    (setf (get ',widget 'command-arg) ',command-arg)
    (defun ,widget (pathname &rest l) ;(declare (:dynamic-extent l))
      (widget-function ',widget pathname l))))

     
;; comand-arg "asaa" means pass second arg back as string, and others not quoted
  ;; ??make these always wait for response
  ;; since creating a window failure is likely to cause many failures.
(defun widget-function (widget pathname l )
  (or (symbolp pathname)
      (error "First arg to ~s must be a symbol not ~s" widget pathname))
  (if *break-on-errors*
      (store-circle *request-forms* (cons pathname (copy-list l))
		    (msg-index)))
  (prescan-arglist l pathname widget)
  (with-tk-command
   (pp widget :no-leading-space)
   (pp pathname :normal)
   (print-arglist tk-command l )
   (multiple-value-bind (res success)
			(send-tcl-cmd *tk-connection* tk-command t)
			(if success
			    (setf (symbol-function pathname)
				  (make-widget-instance pathname widget))
			  (error
			   "Cant define ~(~a~) pathnamed ~(~a~): ~a"
			   widget pathname res)))
   pathname))
(def-widget button)
(def-widget listbox)
(def-widget scale :command-arg a)
(def-widget canvas)
(def-widget menu)
(def-widget scrollbar)
(def-widget checkbutton)
(def-widget menubutton)
(def-widget text)
(def-widget entry)
(def-widget message)
(def-widget frame)
(def-widget label)
(def-widget radiobutton)
(def-widget toplevel)

(defmacro def-control (name &key print-name before)
  (cond ((null print-name )(setq print-name name))
	(t  (setq print-name (cons 'a print-name))))
  `(defun ,name (&rest l)
     ,@ (if before `((,before ',print-name l)))
     (control-function ',print-name l)))

(defun call-with-result-type (tk-command result-type)
  (multiple-value-bind
   (res suc)
   (send-tcl-cmd *tk-connection* tk-command t)
   (values (if result-type (coerce-result res result-type) res)
	   suc)))

(defun control-function (name l &aux result-type)
      (setq result-type (prescan-arglist l nil name))
      (with-tk-command
       (pp name :normal)
       ;; leading keyword printed without '-' at beginning. 
       (cond ((keywordp (car l))
	      (pp (car l) :no-quote)
	      (setq l (cdr l))))
       (print-arglist tk-command l)
       (call-with-result-type tk-command result-type)))


(dolist (v
  '( |%%| |%a| |%b| |%c| |%d| |%f| |%h| |%k| |%m| |%o| |%p| |%s| |%t|
     |%v| |%w| |%x| |%y| |%A| |%B| |%D| |%E| |%K| |%N| |%R| |%S| |%T| |%W| |%X| |%Y|))
  (progn   (setf (get v 'event-symbol)
		 (symbol-name v))
	   (or (member v '(|%d| |%m| |%p| |%K| ;|%W|
			   |%A|))
	       (setf (get v 'event-symbol)
		     (cons (get v 'event-symbol) 'fixnum )))))

(setf (get '|%#| ;;|#; to make emacs fontlock happy
	    'event-symbol) (symbol-name '|%#|)) ;; |#;


(defvar *percent-symbols-used* nil)
(defun get-per-cent-symbols (expr)
  (cond ((atom expr)
	 (and (symbolp expr) (get expr 'event-symbol)
	      (pushnew expr *percent-symbols-used*)))
	(t (get-per-cent-symbols (car expr))
	   (setq expr (cdr expr))
	   (get-per-cent-symbols expr))))


(defun reserve-call-back ( &aux ind)
  (setq ind (fill-pointer *call-backs*))
  (vector-push-extend nil *call-backs* )
  ind)

;; The command arg:
;; For bind windowSpec SEQUENCE COMMAND
;;  COMMAND is called when the event SEQUENCE occurs to windowSpec.
;;    If COMMAND is a symbol or satisfies (functionp COMMAND), then
;;  it will be funcalled.   The number of args supplied in this
;;  case is determined by the widget... for example a COMMAND for the
;;  scale widget will be supplied exactly 1 argument.
;;    If COMMAND is a string then this will be passed to the graphics
;;  interpreter with no change, 
;;  This allows invoking of builtin functionality, without bothering the lisp process.
;;    If COMMAND is a lisp expression to eval, and it may reference
;;  details of the event via the % constructs eg:  %K refers to the keysym
;;  of the key pressed (case of BIND only).   A function whose body is the
;;  form, will actually be  constructed which takes as args all the % variables
;;  actually appearing in the form.  The body of the function will be the form.
;;  Thus (print (list |%w| %W) would turn into #'(lambda(|%w| %W) (print (list |%w| %W)))
;;  and when invoked it would be supplied with the correct args.  

(defvar *arglist* nil)

(defun tcl-create-command (command  arg-data allow-percent-data)
  (with-tk-command
   (cond ((or (null command) (equal command ""))
	  (return-from tcl-create-command ""))
	 ((stringp command)
	  (return-from tcl-create-command command)))
   (let (*percent-symbols-used* tem name (ind 0) ans)
     (declare (type (or base-string null) ans)
	      (type (or base-string null cons) tem)
	      (type (or base-string null) name)
	      (fixnum ind))
     (setq ind  (reserve-call-back))
     (setq name (format nil "callback_~d" ind))
     ;; install in tk the knowledge that callback_ind will call back to here.
     ;; and tell it arg types expected.
     ;; the percent commands are handled differently
     (push-number-string tk-command ind #.(length *header*) 3)
     (setf (fill-pointer tk-command) #.(+ (length *header*) 3))
     (if arg-data (pp arg-data :no-leading-space))
     (send-tcl-create-command *tk-connection* tk-command)
     (if (and arg-data allow-percent-data) (error "arg data and percent data not allowed"))
     (cond ((or (symbolp command)
		(functionp command)))
	   (allow-percent-data
	    (get-per-cent-symbols command)
	    (and *percent-symbols-used* (setq ans ""))
	    (loop for v in *percent-symbols-used* 
	       do (setq tem (get v 'event-symbol))
	       (cond ((stringp tem)
		      (setq ans (format nil "~a \"~a\"" ans tem)))
		     ((eql (cdr tem) 'fixnum)
		      (setq ans (format nil "~a ~a" ans (car tem))))
		     (t (error "bad arg"))))
	    (if ans (setq ans (concatenate 'string "{(" ans ")}")))
	    (setq command (eval `(function (lambda ,*percent-symbols-used*
					     ,command)))) ;ansi requires function, not lambda-expr
	    (if ans (setq name (concatenate 'string "{"name " " ans"}"))))
	   (t (setq command (eval `(function (lambda (&rest *arglist*) ,command))))))
     (setf (aref *call-backs* ind)  command)
     ;; the command must NOT appear as "{[...]}" or it will be eval'd. 
     (cons 'a name)
     )))
   
(defun bind (window-spec &optional sequence command type)
  "command may be a function name, or an expression which
 may involve occurrences of elements of *percent-symbols*
 The expression will be evaluated in an enviroment in which
 each of the % symbols is bound to the value of the corresponding
 event value obtained from TK."
  (cond ((equal sequence :return)
	 (setq sequence nil)
	 (setq command nil)))
  (cond ((equal command :return)
	 (or (eq type 'string)
	     (tkerror "bind only returns type string"))
	 (setq command nil))
	(command
	 (setq command  (tcl-create-command command nil t))))
  (with-tk-command
   (pp 'bind :no-leading-space)
   (pp window-spec :normal)
   (and sequence (pp sequence :normal))
   (and command (pp command :normal))
   (send-tcl-cmd *tk-connection* tk-command (or (null sequence)(null command)))))

(defmacro tk-connection-fd (x) `(caar ,x))

(def-control after)
(def-control exit)
(def-control lower)
(def-control place)
(def-control send)
(def-control tkvars)
(def-control winfo)
(def-control focus)
(def-control option)
(def-control raise)
(def-control tk)
;; problem on waiting.  Waiting for dialog to kill self
;; wont work because the wait blocks even messages which go
;; to say to kill...
;; must use
;; (grab :set :global .fo)
;; and sometimes the gcltkaux gets blocked and cant accept input when
;; in grabbed state...
(def-control tkwait)
(def-control wm)
(def-control destroy :before destroy-aux)
(def-control grab)
(def-control pack)
(def-control selection)
(def-control tkerror)
(def-control update)
(def-control tk-listbox-single-select :print-name "tk_listboxSingleSelect")
(def-control tk-menu-bar :print-name "tk_menuBar")
(def-control tk-dialog :print-name "tk_dialog")
(def-control get_tag_range)

(defun tk-wait-til-exists (win)
  (tk-do (tk-conc "if ([winfo exists " win " ]) { } else {tkwait visibility " win "}")))

(defun destroy-aux (name  l)
  name
  (dolist (v l)
	  (cond ((stringp v))
		((symbolp v) 
		 (dolist (prop '(:variable :textvariable))
			 (remprop v prop))
		 (fmakunbound v)
		 )
		(t (error "not a pathname : ~s" v))))
	  
  )

(defvar *default-timeout* 30)		;30 secs

(defun execute-tcl-cmd (connection cmd)
  (declare (type cs connection)
	   (type base-string cmd))
  (without-input-processing
   (let
       (id tem (time *default-timeout*))
     (declare (fixnum  time))
     (setq id (get-number-string cmd  (pos msg-index *header*) 3))
     (store-circle *replies* nil  id)
     (write-to-connection connection cmd)
     (loop
      (cond ((setq tem (get-circle *replies* id))
	     (cond ((or (car tem) (null *break-on-errors*))
		    (return-from execute-tcl-cmd  (values (cdr tem) (car tem))))
		   (t (cerror "Type :r to continue" "Cmd failed: ~a : ~a "
			      (subseq cmd #.(length *header*)
				      (- (length cmd) 1)
				      )
			      (cdr tem))
		      (return (cdr tem))
		      ))))
      (when (check-state-input (cs-stream connection) 3) (read-and-act id))
      (decf time 3)
      (when (< time 0)
	(cerror ":r resumes waiting for *default-timeout*"
		"Did not get a reply for cmd ~a" cmd)
	(setq time *default-timeout*)
	)))))

(defun push-number-string (string number ind  bytes )
  (declare (fixnum ind number bytes)
	   (type base-string string))
  ;; a number #xabcdef is stored "<ef><cd><ab>" where <ef> is (code-char #xef)
  (loop while (>= bytes 1) do
     (setf (aref string ind)
	   (the character (code-char
				  (the fixnum (logand number 255)))))
     (setq ind (+ ind 1))
     (setq bytes (- bytes 1))
;     (setq number (* number 256))
     (setq number (ash number -8)))
  nil)

(defun get-number-string (string  start  bytes &aux (number 0))
  ;; a number #xabcdef is stored "<ef><cd><ab>" where <ef> is (code-char #xef)
  (declare (string string))
  (declare (fixnum  number bytes start))
  (setq start (+ start (the fixnum (- bytes 1))))
  (loop while (>= bytes 1) do
     (setq number (+ number (char-code (aref string start))))
     (setq start (- start 1) bytes (- bytes 1))
     (cond ((> bytes 0) (setq number (ash number 8)))
	   (t (return number)))))



(defun debugging (x)
  (setq *debugging* x))
	
(defmacro dformat (&rest l)
  `(if *debugging* (dformat1 ,@l)))

(defun dformat1 (&rest l)
  (format *debug-io* "~%Lisp:")
  (apply 'format *debug-io* l))



(defun sigusr1-handler (&rest others)
  (declare (ignore others)
	   (special *block-tk-input*))
  (cond (*block-tk-input* t)		;block active, ignore
	(*tk-connection*
	 (without-input-processing)
	   (dformat "Received SIGUSR1. ~a"
		    (if (check-state-input (cs-stream *tk-connection*) 0)
			"" "No Data left there."))
	   ;; we put 4 here to wait for a bit just in case
	   ;; data comes
	   (when (< 0 (cs-left-in-packet *tk-connection*))
		     (break "interrupt while still bytes in buffer"))
	   ; (check-state-input (cs-stream *tk-connection*) 4)
	   (read-and-act nil))))



(defun store-circle (ar reply id)
  (declare (type (simple-array t) ar)
	   (fixnum id))
  (setf (aref ar (the fixnum (mod id (length ar)))) reply))

(defun get-circle (ar  id)
  (declare (type (simple-array t) ar)
	   (fixnum id))
  (aref ar (the fixnum (mod id (length ar)))))

(defun decode-response (str &aux reply-from )
  (declare (type base-string str))
  (setq reply-from (get-number-string str
			      #.(+ 1 (length *header*))
			      3))
  (values
   (subseq str #.(+ 4 (length *header*)))
   (eql (aref str #.(+ 1 (length *header*))) #\0)
   reply-from
   (get-circle *requests* reply-from)))


(defun describe-message (vec)
  (declare (type base-string vec))
  (let ((body-length (get-number-string vec  (pos body-length *header*) 3))
	(msg-index (get-number-string vec  (pos msg-index *header*) 3))
	(mtype (nth (char-code (aref vec (pos type *header*))) *mtypes*))
	success from-id)
    (format t "~%Msg-id=~a, type=~a, leng=~a, " msg-index mtype body-length)
    (case mtype
      (m_reply
       (setq from-id (get-number-string vec #.(+ 1  (length *header*))
					3))
       (setq success (eql (aref vec #.(+ 0  (length *header*)))
			  #\0))
       (format t "result-code=~a[bod:~s](form msg ~a)[hdr:~s]"
	       success
	       (subseq vec #.(+ 4 (length *header*)))
	       from-id
		       (subseq vec 0 #.(length *header*))
	       )
       )
      ((m_create_command m_call)
       (let ((islot (get-number-string vec #.(+ 0 (length *header*)) 3)))
	 (format t "islot=~a(callback_~a), arglist=~s" islot  islot
		 (subseq vec #.(+ 3 (length *header*))))))
      ((m_tcl_command m_tcl_command_wait_response 
		      M_TCL_CLEAR_CONNECTION
		      )
       (format t "body=[~a]"  (subseq vec #.(length *header*)) ))
      ((m_tcl_set_text_variable)
       (let* ((bod (subseq vec #.(length *header*)))
	      (end (position (code-char 0) bod))
	      (var (subseq bod 0 end)))
	 (format t "name=~s,val=[~a],body=" var (subseq bod (+ 1 end)
							(- (length bod) 1))
		 bod)))
      ((m_tcl_link_text_variable
	m_tcl_unlink_text_variable
	m_set_lisp_loc)

       (let (var (islot (get-number-string vec #.(+ 0 (length *header*)) 3)))
	 (format t "array_slot=~a,name=~s,type=~s body=[~a]" islot
		 (setq var (aref *text-variable-locations* islot))
		 (get var 'linked-variable-type)
		 (subseq vec #.(+ 3 (length *header*))))))
      (otherwise (error "unknown message type ~a [~s]" mtype vec )))))

(defun clear-tk-connection ()
  ;; flush both sides of connection and discard any partial command.
  ;; this kills the server at the next command. But it does that in GCL, too.
  (when *tk-connection*
    (clear-connection-state *tk-connection*)
    (setq *pending* nil)
    (with-tk-command
     (set-message-header tk-command (pos m_tcl_clear_connection *mtypes*) 0)
     (write-to-connection *tk-connection* tk-command))))
    

(defun read-tk-message (ar connection timeout &aux 
			   (n-read 0))
  (declare (fixnum timeout n-read)
	   (type base-string ar))
  (without-input-processing
   (cond (*pending*
	  (dformat "reading old message from *pending*")
	  (break)
	  (read-message-body *pending* connection timeout)))
   (setf (fill-pointer ar) 0)
   (setq n-read (our-read connection ar #.(length *header*)))
   ;;it can happen that read-and-act is called for an empty block (sigio, but no sigusr1)
   ;; so we have to allow for that here, in read-and-act, and in our-read 
   (if (= 0 n-read) (return-from read-tk-message nil)) ;nothing to process
   (setq *pending* ar)
   (cond ((not  (eql n-read #.(length *header*)))
	  (cond ((< n-read 0)
		 (tkdisconnect)
		 (cerror ":r to resume "
			 "Read got an error, have closed connection"))
		(t 	       (error "Bad tk message, wanted ~d got ~d"
				      #.(length *header*) n-read ))))
	 (t
	  (or (and 
	       (eql (aref ar (pos magic1 *header*)) *magic1*)
	       (eql (aref ar (pos magic2 *header*)) *magic2*))
	      (error "Bad magic, got ~d ~d"
		     (char-code (aref ar (pos magic1 *header*)))
		     (char-code (aref ar (pos magic2 *header*)))))
	  (read-message-body ar connection timeout)))))
  
(defun read-message-body (ar connection timeout &aux (m 0) (n-read 0))
  (declare (fixnum m n-read)
	   (ignore timeout)
	   (type base-string ar))
  (without-input-processing
   (setq m (get-number-string ar (pos body-length *header*) 3))
   (dformat "reading ~d bytes message" m)
   (or (>= (array-total-size ar) (the fixnum (+ m #.(length *header*))))
       (setq ar (adjust-array ar (the fixnum (+ m 40)))))
   (cond (*pending*
	  (setq n-read (our-read  connection ar m))
	  (setq *pending* nil)
	  (or (eql n-read m)
	      (error "Failed to read ~a bytes" m))
	  (setf (fill-pointer ar) (the fixnum (+ m #.(length *header*))))))
   (if *debugging* (describe-message ar))
  ar))


(defun tkdisconnect ()
  (when *tk-connection*
    (close (cs-stream *tk-connection*))
    #+cmu (close-socket (cs-fd *tk-connection*))
    (setq *pending* nil)
    (setf *tk-connection* nil)
    #+cmu (unless (eql :not-set *old-sigusr1-handler*)
	    (system:enable-interrupt *sigusr1-number* *old-sigusr1-handler*))
    t
))


(defun read-and-act (id)
  (declare (ignore id))
  (without-input-processing
   (when *tk-connection*
     (let* (tem fun string)
       (declare (type (or null base-string cons) string tem)
		(type (or null function symbol cons) fun))
       (with-tk-command
	(tagbody
	 TOP
	 (unless (check-state-input (cs-stream *tk-connection*) 0)
	   (return-from read-and-act))
	 (setq string (read-tk-message tk-command *tk-connection* *default-timeout*))
	 (unless string (return-from read-and-act))
	 
	 (dformat "read and act read data")
	 (let ((type (char-code (aref string (pos type *header*))))
	       from-id success)
	   (case
	       type
	     (#.(position 'm_reply *mtypes*)
		(setq from-id (get-number-string tk-command #.(+ 1  (length *header*))
						 3))
		(setq success (eql (aref tk-command  #.(+ 0  (length *header*)))
				   #\0))
		(cond ((and (not success)
			    *break-on-errors*
			    (not (get-circle *requests* from-id)))
		       (cerror
			":r to resume ignoring"
			"request ~s failed: ~s"
			(or (get-circle *request-forms* from-id) "")
			(subseq tk-command #.(+ 4 (length *header*))))))
		
		(store-circle *replies*
			      (cons success
				    (if (eql (length tk-command) #.(+ 4 (length *header*))) ""
				      (subseq tk-command #.(+ 4 (length *header*)))))
			      from-id))
	     (#.(position 'm_call *mtypes*)
		;; Can play a game of if read-and-act called with request-id:
		;; When we send a request which waits for an m_reply, we note
		;; at SEND time, the last message id received from tk.   We
		;; dont process any funcall's with lower id than this id,
		;; until after we get the m_reply back from tk.
		(let ((islot
		       (get-number-string tk-command #.(+ 0 (length *header*))3))
		      (n (length tk-command)))
		  (declare (fixnum islot n))
		  (setq tem (our-read-from-string tk-command
						  #.(+ 0 (length *header*) 3)))
		  (or (< islot (length *call-backs*))
		      (error "out of bounds call back??"))
		  (setq fun (aref (the (array t) *call-backs*) islot))
		  (cond ((equal n #.(+ 3 (length *header*)))
			 (funcall fun))		      
			(t
			 (setq tem (our-read-from-string
				    tk-command
				    #.(+ 3 (length *header*))))
			 (cond ((null tem) (funcall fun))
			       ((consp tem) (apply fun tem))
			       (t (error "bad m_call message: ~s" tk-command)))))))
	     (#.(position 'm_set_lisp_loc *mtypes*)
		(let* ((lisp-var-id (get-number-string tk-command #.(+ 0  (length *header*))
						       3))
		       (var (aref *text-variable-locations* lisp-var-id))
		       (type (get var 'linked-variable-type))
		       val)
		  (setq val (coerce-result (subseq tk-command  #.(+ 3 (length *header*))) type))
		  (setf (aref *text-variable-locations* (the fixnum
							  ( + lisp-var-id 1)))
			val)
		  (set var val)))
	     (otherwise (format t "Unknown response back ~d in ~a" type tk-command)))
	   (go TOP)
	   )))))))


(defun our-read-from-string (string start)
  (declare (type (or null base-string) string)
	   (fixnum start))
  (and string (< start (length string))
       (read-from-string string nil nil :start start)))


(defun atoi (string)
  (if (numberp string) string
    (our-read-from-string string 0)))


(defun string-list (x)
  (let ((tk-command
	 (make-array 30 :element-type 'standard-char :fill-pointer 0 :adjustable t)))
    (string-list1 tk-command x)
    tk-command))

(defun string-list1 (tk-command l &aux x)
  ;; turn a list into a tk list
    (desetq (x . l) l)
    (pp x :no-leading-space)
    (while l
      (desetq (x . l) l)
      (cond ((atom x)
	     (pp x :normal))
	    ((consp x)
	     (pp "{" :no-quote)
	     (string-list1 tk-command x)
	     (pp '} :no-leading-space)))))

(defun list-string (x &aux
		      (brace-level 0)
		      skipping (ch #\space)
		      (n (length x))
		      )
  (declare (Fixnum brace-level n)
	   (string x)
	   (character ch))
  (if (eql n 0) (return-from list-string nil)) 
  (loop for i below n
     with beg = 0 and ans
     do (setq ch (aref x i))
     (cond
      ((eql ch #\space)
       (cond (skipping nil)
	     ((eql brace-level 0)
	      (if (> i beg)
		  (setq ans (cons (subseq x beg i) ans)))
	      
	      (setq beg (+ i 1))
		       )))
      (t (cond (skipping (setq skipping nil)
			 (setq beg i)))
       (case ch
       (#\{ (cond ((eql brace-level 0)
		   (setq beg (+ i 1))))
	    (incf brace-level))
       (#\} (cond ((eql brace-level 1)
		   (setq ans (cons (subseq x beg i) ans))
		   (setq skipping t)))
	    (incf brace-level -1)))))
     finally
     (unless skipping
	     (setq ans (cons (subseq x beg i) ans)))
     (return (nreverse ans))
     ))

;; unless keyword :integer-value, :string-value, :list-strings, :list-forms
;; (foo :return 'list)  "ab 2 3" --> (ab 2 3)
;; (foo :return 'list-strings)  "ab 2 3" --> ("ab" "2" "3")  ;;ie 
;; (foo :return 'string)  "ab 2 3" --> "ab 2 3"
;; (foo :return 't)  "ab 2 3" --> AB
;; (foo :return 'boolean)  "1" --> t

  
(defun coerce-result (string key)
  (case key
    (list (our-read-from-string (tk-conc "("string ")") 0))
    (string string)
    (number (our-read-from-string string 0))
    ((t) (our-read-from-string string 0))
    (t (let ((funs (get key 'coercion-functions)))
	 (cond ((null funs)
		(error "Undefined coercion for type ~s" key)))
	 (funcall (car funs) string)))))

;;convert "2c" into screen units or points or something...
   

;; If loc is suitable for handing to setf,  then
;; (setf loc (coerce-result val type)
;; (radio-button

(defvar *unbound-var* "<unbound>")

(defun link-variable (var type)
  (let* ((i 0)
	 (ar  *text-variable-locations*)
	 (n (length ar))
	   tem
	 )
    (declare (fixnum i n)
	     (type (array t) ar))
    (cond ((stringp var)
	   (return-from link-variable var))
	  ((symbolp var))
	  ((and (consp var)
		(consp (cdr var)))
	   (setq type (car var))
	   (setq var (cadr var))))
    (or (and (symbolp type)
	     (get type 'coercion-functions))
	(error "Need coercion functions for type ~s" type))
    (or (symbolp var) (error "illegal text variable ~s" var))
    (setq tem (get var 'linked-variable-type))
    (unless (if (and tem (not (eq tem type)))
		(format t "~%;;Warning: ~s had type ~s, is being changed to type ~s"
			var tem type
			)))
    (setf (get var 'linked-variable-type) type)
    (while (< i n)
      (cond ((eq (aref ar i) var)
	     (return-from link-variable var))
	    ((null (aref ar i))
	     (return nil))
	    (t   (setq i (+ i 2)))))
;; i is positioned at the write place
    (cond ((= i n)
	   (vector-push-extend nil ar)
	   (vector-push-extend nil ar)))
    (setf (aref ar i) var)
    (setf (aref ar (the fixnum (+ i 1)))
		(if (boundp var)
		    (symbol-value var)
		  *unbound-var*))
    (with-tk-command
     (push-number-string tk-command i #.(length *header*) 3)
     (setf (fill-pointer tk-command) #.(+ 3  (length *header*)))
     (pp var :no-quotes-and-no-leading-space)
     (vector-push-extend (code-char 0) tk-command)
     (set-message-header tk-command (pos m_tcl_link_text_variable *mtypes*)
			 (- (length tk-command) #.(length *header*)))
     (write-to-connection *tk-connection* tk-command)))
  (notice-text-variables)
  var)

(defun unlink-variable (var )
  (let* ((i 0)
	 (ar  *text-variable-locations*)
	 (n (length ar))

	 )
    (declare (fixnum i n)
	     (type (array t) ar))
    (while (< i n)
      (cond ((eq (aref ar i) var)
	     (setf (aref ar i) nil)
	     (setf (aref ar (+ i 1)) nil)
	     (return nil)
	     )
	    (t   (setq i (+ i 2)))))
    
    (cond ((< i n)
	   (with-tk-command
	    (push-number-string tk-command i #.(length *header*) 3)
	    (setf (fill-pointer tk-command) #.(+ 3  (length *header*)))
	    (pp var :no-quotes-and-no-leading-space)
	    (vector-push-extend (code-char 0) tk-command)
	    (set-message-header tk-command (pos m_tcl_unlink_text_variable *mtypes*)
				(- (length tk-command) #.(length *header*)))
	    (write-to-connection *tk-connection* tk-command))
	   var))))
  
(defun notice-text-variables ()
  (let* ((i 0)
	 (ar  *text-variable-locations*)
	 (n (length ar))
	  tem var type
	 )
    (declare (fixnum i n)
	     (type (array t) ar))
    (tagbody
     (while (< i n)
       (unless (or (not (boundp (setq var  (aref ar i))))
		   (eq (setq tem (symbol-value var))
		       (aref ar (the fixnum (+ i 1)))))
	       (setf (aref ar (the fixnum (+ i 1))) tem)
	       (setq type (get var 'linked-variable-type))
	       (with-tk-command
		;(push-number-string tk-command i #.(length *header*) 3)
		;(setf (fill-pointer tk-command) #. (+ 3  (length *header*)))
		(pp var :no-quote-no-leading-space)
		(vector-push (code-char 0) tk-command )
		(case type
		  (string (or (stringp tem) (go error)))
		  (number (or (numberp tem) (go error)))
		  ((t) (setq tem (format nil "~s" tem )))
		  (t 
		   (let ((funs (get type 'coercion-functions)))
		     (or funs (error "no writer for type ~a" type))
		     (setq tem (funcall (cdr funs) tem)))))
		(pp tem :no-quotes-and-no-leading-space)
		(vector-push (code-char 0) tk-command )
		(set-message-header tk-command (pos m_tcl_set_text_variable *mtypes*)
				    (- (length tk-command) #.(length *header*)))
		(write-to-connection *tk-connection* tk-command)))
       (setq i (+ i 2)))
     (return-from notice-text-variables)
     error
     (error "~s has value ~s which is not of type ~s" (aref ar i)
	    tem type)
     )))
(defmacro setk (&rest l)
  `(prog1 (setf ,@ l)
    (notice-text-variables)))

(setf (get 'boolean 'coercion-functions)
      (cons #'(lambda (x &aux (ch (aref x 0)))
		(cond ((eql ch #\0) nil)
		      ((eql ch #\1) t)
		      (t (error "non boolean value ~s" x))))
	    #'(lambda (x) (if x "1" "0"))))

(setf (get 't 'coercion-functions)
      (cons #'(lambda (x) (our-read-from-string x 0))
	    #'(lambda (x) (format nil "~s" x))))

(setf (get 'string 'coercion-functions)
      (cons #'(lambda (x)
		(cond ((stringp x) x)
		      (t (format nil "~s" x))))
	    'identity))


(setf (get 'list-strings 'coercion-functions)
      (cons 'list-string 'list-to-string))

(defun list-to-string  (l &aux (x l) v (start t))
  (with-tk-command
   (while x
     (cond ((consp x)
	    (setq v (car  x)))
	   (t (error "Not a true list ~s" l)))
     (cond (start (pp v :no-leading-space) (setq start nil))
	   (t (pp v :normal)))
     (setf x (cdr x)))
   (subseq tk-command #.(length *header*))))



(defvar *tk-library* nil)


;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;
;;;;;;;;;;;   CMU functions


#+cmu
(defun start-gcltk-server (host can-rsh gcltksrv port-number display args)
  (let* ((process-id (if host  -1 (unix:unix-getpid)))
	 (host-id (or (if host (host-entry-addr (lookup-host-entry
						 (unix:unix-gethostname)))
			(host-entry-addr (lookup-host-entry
					  "127.0.0.1")))
		      (error "Can't find my address")))
	 (arguments 
	  (list (format nil "~a ~d ~d ~a ~a"
			host-id 
			(htons port-number) ;;; gcltk gets it wrong
			process-id
			display 
			args
			))))
    (cond ((not host)
	   (dformat  "~% Running ~s ~s:" gcltksrv arguments)
	   (run-program gcltksrv arguments :wait nil))
	  (can-rsh
	   (run-program "rsh" (list (format nil "~a ~a ~a < /dev/null &"
					    host gcltksrv arguments))
			:wait nil))
	  (t (format t "Waiting for you to invoke GCL_TK_SERVER,
on ~s as in: ~s ~s (real port ~d) ~%" host gcltksrv arguments port-number)))))


#+cmu
(defun setup-gcltk-connection (host can-rsh gcltksrv display args)
  (do* ((port 1024 (1+ port))
	(fd nil))
      (fd (progn
	    (start-gcltk-server host can-rsh gcltksrv (1- port) display args)    
	    (make-cs
	     :stream (unix::make-fd-stream
		      (accept-tcp-connection fd)
		      :input t :output t :buffering :none
		      :timeout 30)
	     :fd fd
	     :port (1- port))))	 
    (handler-case (create-inet-listener port :stream)
		  (error ())	;ignore errors, just continue trying
		  (:no-error (socket-fd) (setf fd socket-fd)))
    ))

#+cmu
(defun init-gcltk-interrupts (fd)
  (declare (ignore fd))
  (setf *old-sigusr1-handler*
	(system:enable-interrupt *sigusr1-number* #'sigusr1-handler)))



;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;;;;;;;;;;;;;;;;;;;;;
;;;; Allegro Versions 
;;;;
;;;; you also have to load tkl-acl.lisp



#+allegro
(ff:def-c-type (internet-host-name :in-foreign-space) 100 :char)
#+allegro
(ff:def-c-type (internet-address-long :in-foreign-space) :unsigned-long)
#+allegro
(ff:def-c-type (address-array :in-foreign-space) 10 :long)
#+allegro
(ff:def-c-type (hostent :in-foreign-space) :struct
	       (host-name * long)
	       (alias-list * 'address-array)
	       (address-type :int)
	       (address-length :int)
	       (address-list * 'address-array))

#+allegro
(ff:defforeign 'gethostname :arguments '(t t) :return-type :integer)
#+allegro
(ff:defforeign 'gethostbyname :arguments '(t) :return-type :integer)
#+allegro
(ff:defforeign 'siginterrupt :arguments '(t t) :return-type :fixnum)



#+allegro
(defun my-get-host-by-name (hostname)
  (let ((result (gethostbyname hostname)))
    (and (/= 0 result) 
	 (internet-address-long
	  (address-array (hostent-address-list result) 0)))))

#+allegro
(defun start-gcltk-server (host can-rsh gcltksrv port-number display args)
  (let* ((process-id (excl::getpid))
	 (host-id (let ((hostname (make-internet-host-name)))
		    (if (= -1 (gethostname hostname 100))
			(error "Can't find my address"))
		    (my-get-host-by-name (ff:char*-to-string hostname))))
	 (arguments 
	  (format nil "~a ~d ~d ~a ~a"
		  #-sparc(ipc::lisp_htonl host-id) 
		  #+sparc host-id 
		  (ipc::lisp_htons port-number) ;;; gcltk gets it wrong
		  process-id
		  display 
		  args
		  )))
    (cond ((not host)
	   (dformat  "~% Running ~a ~a:" gcltksrv arguments)
	   (excl:shell (concatenate 'string gcltksrv " "  arguments)))
	  (can-rsh
	   (excl:shell (concatenate 'string  "rsh " gcltksrv " " arguments "< /dev/null &")))
	  (t (format t "Waiting for you to invoke GCL_TK_SERVER,
on ~a as in: ~a ~a (real port ~d) ~%" host gcltksrv arguments port-number)))))



#+allegro  
(defun init-gcltk-interrupts (fd)
  (sys:set-sigio-handler fd  'sigusr1-handler)
  (excl::unix-signal *sigusr1-number* 1) ;ignore sigusr1
  #-sparc  (dolist (interrupt '(29 14 11 10))	;sigio sigalarm sigusr1 sisegv
	     (siginterrupt interrupt 0))	;tell unix to restart interrupted calls
  )


;;;;;;;;;;;;
;;;;;;;;;;;
;;;;;;;;;; Back to common functions

(defun init-gcltk-variables ()
  (let ((ar *text-variable-locations*))
    (declare (type (array t) ar)) 
    (loop for i below (length ar) by 2
	  do (remprop (aref ar i) 'linked-variable-type)))
  (setf (fill-pointer *text-variable-locations*) 0)
  (setf (fill-pointer *call-backs*) 0))



(defun tkconnect (&key host can-rsh gcltksrv (display (getenv :DISPLAY))
		       (args  ""))
  (declare (special *tk-connection*))
  (if *tk-connection*  (tkdisconnect))
  (or display (error "DISPLAY not set"))
  (when (getenv :TK_LIBRARY)  (setq *tk-library* (getenv :TK_LIBRARY)))
  (or gcltksrv
      (setq gcltksrv
	    (cond (host "gcltksrv")
		  ((and (getenv :GCL_TK_SERVER) (probe-file (getenv :GCL_TK_SERVER))))
		  ((probe-file *gcltksrv-path*))
		  ((probe-file (concatenate 'string (getenv :CMUCLLIB) "/gcltksrv")))
		  ((probe-file "/usr/lib/cmucl/gcltksrv"))
		  ((probe-file "gcltksrv"))
		  (t (error "Must setenv GCL_TK_SERVER ")))))
  (when (pathnamep gcltksrv) (setq gcltksrv (namestring gcltksrv)))
  (init-gcltk-variables)
  (setf *tk-connection*
	(setup-gcltk-connection host can-rsh gcltksrv display args))
  (init-gcltk-interrupts (cs-fd *tk-connection*))
  (tk-do (tk-conc "source " *gcltcl-path*))
  )


  
(defun children (win)
  (let ((ans (list-string (winfo :children win))))
    (cond ((null ans) win)
	  (t (cons win (mapcar 'children ans))))))


;; read nth item from a string in



(defun nth-a (n string &optional (separator #\space) &aux (j 0) (i 0)
		(lim (length string)) ans)
  (declare (fixnum j n i lim))
  (declare (type base-string string))
  (while (< i lim)
    (cond ((eql j n)
	   (setq ans (our-read-from-string string i))
	   (setq i lim))
	  ((eql (aref string i) separator)
	   (setq j (+ j 1))))
    (setq i (+ i 1)))
  ans)



(defun set-message-header(vec mtype body-length &aux (m (msg-index)) )
  (declare (fixnum mtype body-length m)
	   (string vec) )
  (setf (aref vec (pos magic1 *header*)) *magic1*)
  (setf (aref vec (pos magic2 *header*)) *magic2*)
;  (setf (aref vec (pos flag *header*)) (code-char (make-flag flags)))
  (setf (aref vec (pos type *header*)) (code-char mtype))
  (push-number-string vec body-length (pos body-length *header*) 3)
  (push-number-string vec  m (pos msg-index *header*) 3)
  (setf (msg-index) (the fixnum (+ m 1)))
  m)


       
       
       






;;these are required to run the examples

; used in example
(defun conc (a b &rest l &aux tem)
  (loop
     do
     (or (symbolp a) (error "not a symbol ~s" a))
     (cond ((setq tem (get a b)))
           (t (setf (get a b)
                    (setq tem (intern (format nil "~a~a" a b)
                                      *tk-package*
                                      )))))
     while l
     do
     (setq a  tem b (car l) l (cdr l)))
  tem)

     

(defun dpos (x)  (wm :geometry x "width 60 height 25"))



