1
;; Copyright (C) 1994 W. Schelter
3
;; This file is part of GNU Common Lisp, herein referred to as GCL
5
;; GCL is free software; you can redistribute it and/or modify it under
6
;; the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
7
;; the Free Software Foundation; either version 2, or (at your option)
10
;; GCL is distributed in the hope that it will be useful, but WITHOUT
11
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
12
;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
13
;; License for more details.
18
(eval-when (load eval compile)
23
(proclaim '(ftype (function (t fixnum fixnum) fixnum) set-message-header
25
(proclaim '(ftype (function (t t fixnum) t) store-circle))
26
(proclaim '(ftype (function (t fixnum) t) get-circle))
27
(proclaim '(ftype (function (t fixnum fixnum fixnum) fixnum)
31
(defvar *tk-package* (find-package "TK"))
33
(eval-when (compile eval load)
35
(defconstant *header* '(magic1 magic2 type flag body-length nil nil msg-index nil nil))
37
;;enum print_arglist_codes {..};
38
(defvar *print-arglist-codes*
45
begin_join_no_leading_space
47
no_quote_no_leading_space
49
no_quotes_and_no_leading_space
59
m_tcl_command_wait_response
60
m_tcl_clear_connection
61
m_tcl_link_text_variable
63
m_tcl_set_text_variable
64
m_tcl_unlink_text_variable
66
m_lisp_eval_wait_response
69
(defconstant *magic1* #\)
70
(defconstant *magic2* #\A)
73
(defvar *some-fixnums* (make-array 3 :element-type 'fixnum))
74
(defmacro msg-index () `(the fixnum
75
(aref (the (array fixnum) *some-fixnums*) 0)))
76
;;; (defmacro safe-car (x)
77
;;; (cond ((symbolp x) `(if (consp ,x) (car ,x) (if (null ,x) nil
78
;;; (not-a-cons ,x))))
79
;;; (t (let ((sym (gensym)))
81
;;; (safe-car ,sym))))))
82
;;; (defmacro safe-cdr (x)
83
;;; (cond ((symbolp x) `(if (consp ,x) (cdr ,x) (if (null ,x) nil
84
;;; (not-a-cons ,x))))
85
;;; (t (let ((sym (gensym)))
87
;;; (safe-cdr ,sym))))))
90
(defun desetq-consp-check (val)
91
(or (consp val) (error "~a is not a cons" val)))
93
(defun desetq1 (form val)
95
(cond (form ;(push form *desetq-binds*)
99
(desetq-consp-check ,val)
100
,(desetq1 (car form) `(car ,val))
101
,@ (if (consp (cdr form))
102
(list(desetq1 (cdr form) `(cdr ,val)))
103
(and (cdr form) `((setf ,(cdr form) (cdr ,val)))))))
106
(defmacro desetq (form val)
107
(cond ((atom val) (desetq1 form val))
108
(t (let ((value (gensym)))
109
`(let ((,value ,val)) , (desetq1 form value))))))
110
(defmacro while (test &body body)
111
`(sloop while ,test do ,@ body))
115
(defmacro nth-value (n form)
116
`(multiple-value-bind ,(make-list (+ n 1) :initial-element 'a) ,form a))
118
(defvar *tk-command* nil)
120
(defvar *debugging* nil)
121
(defvar *break-on-errors* nil)
123
(defvar *tk-connection* nil )
125
;; array of functions to be invoked from lisp.
126
(defvar *call-backs* (make-array 20 :fill-pointer 0 :adjustable t ))
128
;;array of message half read. Ie read header but not body.
129
(defvar *pending* nil)
131
;;circular array for replies,requests esp for debugging
132
;; replies is used for getting replies.
133
(defvar *replies* (make-array (expt 2 7)) "circle of replies to requests in *requests*")
136
(defvar *requests* (make-array (expt 2 7)))
138
;; these are lisp forms
139
(defvar *request-forms* (make-array 40))
142
(defvar *read-buffer* (make-array 400 :element-type 'standard-char
143
:fill-pointer 0 :static t))
145
(defvar *text-variable-locations*
146
(make-array 10 :fill-pointer 0 :adjustable t))
151
(defmacro pos (flag lis)
153
(member flag (symbol-value lis))
154
(error "~a is not in ~a" flag lis))
155
(position flag (symbol-value lis)))
161
;;; (defun p1 (a &aux tem)
162
;;; ;;Used for putting A into a string for sending a command to TK
164
;;; ((and (symbolp a) (setq tem (get a 'tk-print)))
165
;;; (format *tk-command* tem))
167
;;; (format *tk-command* "-~(~a~)" a))
169
;;; (format *tk-command* "~a" a))
171
;;; (format *tk-command* "\"~a\"" a))
172
;;; ((and (consp a)(eq (car a) 'a))
173
;;; (format *tk-command* "~a" (cdr a)))
174
;;; ((and (consp a)(eq (car a) 'd))
175
;;; (format *tk-command* "~(~a~)" (cdr a)))
176
;;; ((and (symbolp a)
177
;;; (eql (aref (symbol-name a) 0)
179
;;; (format *tk-command* "~(~a~)" a))
180
;;; (t (error "unrecognized term ~s" a))))
183
(defvar *command-strings*
184
(sloop for i below 2 collect
185
(make-array 200 :element-type 'standard-char :fill-pointer 0 :adjustable t)))
187
(defvar *string-streams* (list (make-string-input-stream "") (make-string-input-stream "")))
189
(defmacro with-tk-command (&body body)
190
`(let (tk-command (*command-strings* *command-strings*))
191
(declare (type string tk-command))
192
(setq tk-command (grab-tk-command))
195
(defun grab-tk-command( &aux x)
196
;; keep a list of available *command-strings* and grab one
198
((cdr *command-strings*))
200
(setq x (list (make-array 70
201
:element-type 'standard-char
202
:fill-pointer 0 :adjustable t))
204
(or *command-strings* (error "how??"))
206
(setq *command-strings* (nconc *command-strings* x))))
207
(let ((x (car *command-strings*)))
208
(setq *command-strings* (cdr *command-strings*))
209
(setf (fill-pointer x ) #.(length *header*))
213
(defun print-to-string (str x code)
215
(cond ((eq (car x) 'a)
217
code (pos no_quote *print-arglist-codes*)))
220
code (pos no_quote_downcase *print-arglist-codes*)))
221
(t (error "bad arg ~a" x)))))
222
(while (null (si::print-to-string1 str x code))
223
(cond ((typep x 'bignum)
224
(setq x (format nil "~a" x)))
225
(t (setq str (adjust-array str
228
(array-total-size str))
232
(length (the string x))
235
:fill-pointer (fill-pointer str)
236
:element-type 'string-char)))))
239
(defmacro pp (x code)
240
(let ((u `(pos ,code *print-arglist-codes*)))
241
`(print-to-string tk-command ,x ,u)))
243
(defun print-arglist (to-string l &aux v in-join x)
244
;; (sloop for v in l do (p :| | v))
250
(print-to-string to-string x
252
(pos join_follows *print-arglist-codes*)
253
(pos begin_join *print-arglist-codes*)))
257
(print-to-string to-string x (pos end_join *print-arglist-codes*))
259
(t;; code == (pos normal *print-arglist-codes*)
260
(print-to-string to-string x (pos normal *print-arglist-codes*))))
265
(defmacro p (&rest l)
266
`(progn ,@ (sloop for v in l collect `(p1 ,v))))
268
(defvar *send-and-wait* nil "If not nil, then wait for answer and check result")
270
(defun tk-call (fun &rest l &aux result-type)
272
(pp fun no_leading_space)
273
(setq result-type (prescan-arglist l nil nil))
274
(print-arglist tk-command l)
276
(call-with-result-type tk-command result-type))
277
(t (send-tcl-cmd *tk-connection* tk-command nil)
280
(defun tk-do (str &rest l &aux )
282
(pp str no_quotes_and_no_leading_space)
283
;; leading keyword printed without '-' at beginning.
285
(pp (car l) no_quotes_and_no_leading_space)
287
(call-with-result-type tk-command 'string)))
289
(defun tk-do-no-wait (str &aux (n (length str)))
291
(si::copy-array-portion str tk-command 0 #.(length *header*) n)
292
(setf (fill-pointer tk-command) (the fixnum (+ n #.(length *header*))))
294
(send-tcl-cmd *tk-connection* tk-command nil))))
296
(defun send-tcl-cmd (c str send-and-wait )
297
;(notice-text-variables)
298
(or send-and-wait (setq send-and-wait *send-and-wait*))
299
; (setq send-and-wait t)
300
(vector-push-extend (code-char 0) str)
301
(let ((msg-id (set-message-header str
303
(pos m_tcl_command_wait_response *mtypes*)
304
(pos m_tcl_command *mtypes*))
307
#.(length *header*))))))
311
(store-circle *requests* (subseq str #.(length *header*))
313
(store-circle *replies* nil msg-id)
314
(execute-tcl-cmd c str))
315
(t (store-circle *requests* nil msg-id)
316
(write-to-connection c str)))))
319
(defun send-tcl-create-command (c str)
320
(vector-push-extend (code-char 0) str)
321
(set-message-header str (pos m_create_command *mtypes*)
322
(- (length str) #.(length *header*)))
323
(write-to-connection c str))
325
(defun write-to-connection (con string &aux tem)
327
;; dont let us get interrupted while writing!!
331
(declare (Fixnum n m))
332
(or con (error "Trying to write to non open connection "))
333
(if *debugging* (describe-message string))
334
(or (typep fd 'string)
335
(error "~a is not a connection" con))
336
(setq m (si::our-write fd string n))
337
(or (eql m n) (error "Failed to write ~a bytes to file descriptor ~a" n fd))
339
;; a signal at this instruction would not be noticed...since it
340
;; would set *sigusr1* to :received but that would be too late for tem
341
;; since the old value will be popped off the binding stack at the next 'paren'
343
(cond ((eq tem :received)
348
(defun coerce-string (a)
349
(cond ((stringp a) a)
350
((fixnump a) (format nil "~a" a))
351
((numberp a) (format nil "~,2f" (float a)))
353
(format nil "-~(~a~)" a))
355
(format nil "~(~a~)" a))
356
(t (error "bad type"))))
360
(setq a (coerce-string a))
361
(setq b (coerce-string b))
362
(concatenate 'string a b ))
364
;; In an arglist 'a : b' <==> (tk-conc a b)
365
;; eg: 1 : "b" <==> "1b"
366
; "c" : "b" <==> "cb"
368
; '.a : '.b <==> ".a.b"
369
; ':ab : "b" <==> "abb"
371
;;Convenience for concatenating symbols, strings, numbers
372
;; (tk-conc '.joe.bill ".frame.list yview " 3) ==> ".joe.bill.frame.list yview 3"
373
(defun tk-conc (&rest l)
374
(declare (:dynamic-extent l))
376
(make-array 30 :element-type 'standard-char
377
:fill-pointer 0 :adjustable t)))
379
(t (pp (car l) no_quote_no_leading_space)))
382
(pp (car l) join_follows) (setq l (cdr l)))
383
(and l (pp (car l) no_quote_no_leading_space))
388
;;; (defun verify-list (l)
390
;;; (cond ((null l)(return t))
391
;;; ((consp l) (setq l (cdr l)))
392
;;; (t (error "not a true list ~s"l)))))
394
;;; (defun prescan-arglist (l pathname name-caller &aux result-type)
395
;;; (let ((v l) tem prev a b c)
400
;;; ((keywordp (car v))
403
;;; (setq b (car c) c (cadr c))
404
;;; (cond ((eq a :bind)
405
;;; (cond ((setq tem (cdddr v))
406
;;; (or (eq (cadr tem) ': )
408
;;; (tcl-create-command (car tem)
412
;;; ((member a'(:yscroll :command
418
;;; (cond ((setq tem (cdr v))
420
;;; (tcl-create-command (car tem)
421
;;; (or (get a 'command-arg)
426
;;; ((eq (car v) :return)
427
;;; (setf result-type (cadr v))
429
;;; (setf (cdr prev) (cddr v)))
430
;;; (t (setf (car v) '(a . ""))
431
;;; (setf (cdr v) (cddr v)))))
432
;;; ((eq (car v) :textvariable)
433
;;; (setf (second v) (link-variable b 'string)))
434
;;; ((member (car v) '(:value :onvalue :offvalue))
435
;;; (let* ((va (get pathname 'variable))
436
;;; (type (get va 'linked-variable-type))
437
;;; (fun (cdr (get type
438
;;; 'coercion-functions))))
441
;;; "Must specify :variable before :value so that we know the type"))
442
;;; (or fun (error "No coercion-functions for type ~s" type))
443
;;; (setf (cadr v) (funcall fun b))))
444
;;; ((eq (car v) :variable)
445
;;; (let ((va (second v))
446
;;; (type (cond ((eql name-caller 'checkbutton) 'boolean)
448
;;; (cond ((consp va)
449
;;; (desetq (type va) va)
451
;;; (error "should be :variable (type symbol)"))))
452
;;; (setf (get pathname 'variable) va)
454
;;; (link-variable va type))))
463
(defun prescan-arglist (l pathname name-caller &aux result-type)
464
(let ((v l) tem prev a )
465
; (verify-list l) ; unnecessary all are from &rest args.
466
; If pathname supplied, then this should be an alternating list
467
;; of keywords and values.....
473
((eq (car v) :return)
474
(setf result-type (cadr v))
476
(setf (cdr prev) (cddr v)))
477
(t (setf (car v) '(a . ""))
478
(setf (cdr v) (cddr v)))))
479
((setq tem (get a 'prescan-function))
480
(funcall tem a v pathname name-caller)))))
485
(eval-when (compile eval load)
486
(defun set-prescan-function (fun &rest l)
487
(dolist (v l) (setf (get v 'prescan-function) fun)))
491
(set-prescan-function 'prescan-bind :bind)
493
(x v pathname name-caller &aux tem)
494
name-caller pathname x
495
(cond ((setq tem (cdddr v))
500
(tcl-create-command (car tem)
504
(set-prescan-function 'prescan-command :yscroll :command
511
(defun prescan-command (x v pathname name-caller &aux tem arg)
513
(setq arg (cond (( member v '(:xscroll
519
((get name-caller 'command-arg))))
520
(cond ((setq tem (cdr v))
521
(cond ((eq (car tem) :return ) :return)
524
(tcl-create-command (car tem) arg nil)))))))
526
(defun prescan-value (a v pathname name-caller)
528
(let* ((va (get pathname ':variable))
529
(type (get va 'linked-variable-type))
531
'coercion-functions))))
534
"Must specify :variable before :value so that we know the type"))
535
(or fun (error "No coercion-functions for type ~s" type))
538
(setf (car v) (funcall fun (car v))))))
540
(set-prescan-function 'prescan-value :value :onvalue :offvalue)
542
(set-prescan-function
543
#'(lambda (a v pathname name-caller)
545
(let ((va (second v))
546
(type (cond ((eql name-caller 'checkbutton) 'boolean)
549
(desetq (type va) va)
551
(error "should be :variable (type symbol)"))))
553
(setf (get pathname a) va)
555
(link-variable va type))))))
556
:variable :textvariable)
558
(defun make-widget-instance (pathname widget)
559
;; ??make these not wait for response unless user is doing debugging..
560
(or (symbolp pathname) (error "must give a symbol"))
561
#'(lambda ( &rest l &aux result-type (option (car l)))
562
(declare (:dynamic-extent l))
563
(setq result-type (prescan-arglist l pathname widget))
564
(if (and *break-on-errors* (not result-type))
565
(store-circle *request-forms*
566
(cons pathname (copy-list l))
569
(pp pathname no_leading_space)
570
;; the leading keyword gets printed with no leading -
571
(or (keywordp option)
572
(error "First arg to ~s must be an option keyword not ~s"
577
(cond ((and (keywordp (car l))
578
(not (eq option :configure))
579
(not (eq option :config))
580
(not (eq option :itemconfig))
581
(not (eq option :cget))
582
(not (eq option :postscript))
584
(pp (car l) no_quote)
586
(print-arglist tk-command l)
588
(call-with-result-type tk-command result-type))
589
(t (send-tcl-cmd *tk-connection* tk-command nil)
592
(defmacro def-widget (widget &key (command-arg 'sssss))
593
`(eval-when (compile eval load)
594
(setf (get ',widget 'command-arg) ',command-arg)
595
(defun ,widget (pathname &rest l)(declare (:dynamic-extent l))
596
(widget-function ',widget pathname l))))
599
;; comand-arg "asaa" means pass second arg back as string, and others not quoted
600
;; ??make these always wait for response
601
;; since creating a window failure is likely to cause many failures.
602
(defun widget-function (widget pathname l )
603
(or (symbolp pathname)
604
(error "First arg to ~s must be a symbol not ~s" widget pathname))
605
(if *break-on-errors*
606
(store-circle *request-forms* (cons pathname (copy-list l))
608
(prescan-arglist l pathname widget)
610
(pp widget no_leading_space)
612
(print-arglist tk-command l )
613
(multiple-value-bind (res success)
614
(send-tcl-cmd *tk-connection* tk-command t)
616
(setf (symbol-function pathname)
617
(make-widget-instance pathname widget))
619
"Cant define ~(~a~) pathnamed ~(~a~): ~a"
620
widget pathname res)))
624
(def-widget scale :command-arg a)
627
(def-widget scrollbar)
628
(def-widget checkbutton)
629
(def-widget menubutton)
635
(def-widget radiobutton)
636
(def-widget toplevel)
638
(defmacro def-control (name &key print-name before)
639
(cond ((null print-name )(setq print-name name))
640
(t (setq print-name (cons 'a print-name))))
641
`(defun ,name (&rest l)
642
,@ (if before `((,before ',print-name l)))
643
(control-function ',print-name l)))
645
(defun call-with-result-type (tk-command result-type)
648
(send-tcl-cmd *tk-connection* tk-command t)
649
(values (if result-type (coerce-result res result-type) res)
652
(defun control-function (name l &aux result-type)
653
;(store-circle *request-forms* (cons name l) (msg-index))
654
(setq result-type (prescan-arglist l nil name))
657
;; leading keyword printed without '-' at beginning.
658
(cond ((keywordp (car l))
659
(pp (car l) no_quote)
661
(print-arglist tk-command l)
662
(call-with-result-type tk-command result-type)))
666
'( |%%| |%#| |%a| |%b| |%c| |%d| |%f| |%h| |%k| |%m| |%o| |%p| |%s| |%t|
667
|%v| |%w| |%x| |%y| |%A| |%B| |%D| |%E| |%K| |%N| |%R| |%S| |%T| |%W| |%X| |%Y|))
668
(progn (setf (get v 'event-symbol)
670
(or (member v '(|%d| |%m| |%p| |%K| ;|%W|
672
(setf (get v 'event-symbol)
673
(cons (get v 'event-symbol) 'fixnum )))))
675
(defvar *percent-symbols-used* nil)
676
(defun get-per-cent-symbols (expr)
678
(and (symbolp expr) (get expr 'event-symbol)
679
(pushnew expr *percent-symbols-used*)))
680
(t (get-per-cent-symbols (car expr))
681
(setq expr (cdr expr))
682
(get-per-cent-symbols expr))))
685
(defun reserve-call-back ( &aux ind)
686
(setq ind (fill-pointer *call-backs*))
687
(vector-push-extend nil *call-backs* )
691
;; For bind windowSpec SEQUENCE COMMAND
692
;; COMMAND is called when the event SEQUENCE occurs to windowSpec.
693
;; If COMMAND is a symbol or satisfies (functionp COMMAND), then
694
;; it will be funcalled. The number of args supplied in this
695
;; case is determined by the widget... for example a COMMAND for the
696
;; scale widget will be supplied exactly 1 argument.
697
;; If COMMAND is a string then this will be passed to the graphics
698
;; interpreter with no change,
699
;; This allows invoking of builtin functionality, without bothering the lisp process.
700
;; If COMMAND is a lisp expression to eval, and it may reference
701
;; details of the event via the % constructs eg: %K refers to the keysym
702
;; of the key pressed (case of BIND only). A function whose body is the
703
;; form, will actually be constructed which takes as args all the % variables
704
;; actually appearing in the form. The body of the function will be the form.
705
;; Thus (print (list |%w| %W) would turn into #'(lambda(|%w| %W) (print (list |%w| %W)))
706
;; and when invoked it would be supplied with the correct args.
708
(defvar *arglist* nil)
709
(defun tcl-create-command (command arg-data allow-percent-data)
711
(cond ((or (null command) (equal command ""))
712
(return-from tcl-create-command ""))
714
(return-from tcl-create-command command)))
715
(let (*percent-symbols-used* tem ans name ind)
716
(setq ind (reserve-call-back))
717
(setq name (format nil "callback_~d" ind))
718
;; install in tk the knowledge that callback_ind will call back to here.
719
;; and tell it arg types expected.
720
;; the percent commands are handled differently
721
(push-number-string tk-command ind #.(length *header*) 3)
722
(setf (fill-pointer tk-command) #.(+ (length *header*) 3))
723
(if arg-data (pp arg-data no_leading_space))
724
(send-tcl-create-command *tk-connection* tk-command)
725
(if (and arg-data allow-percent-data) (error "arg data and percent data not allowed"))
726
(cond ((or (symbolp command)
727
(functionp command)))
729
(get-per-cent-symbols command)
730
(and *percent-symbols-used* (setq ans ""))
731
(sloop for v in *percent-symbols-used*
732
do (setq tem (get v 'event-symbol))
734
(setq ans (format nil "~a \"~a\"" ans tem)))
735
((eql (cdr tem) 'fixnum)
736
(setq ans (format nil "~a ~a" ans (car tem))))
737
(t (error "bad arg"))))
738
(if ans (setq ans (concatenate 'string "{(" ans ")}")))
739
(setq command `(lambda ,*percent-symbols-used*
741
(if ans (setq name (concatenate 'string "{"name " " ans"}"))))
742
(t (setq command `(lambda (&rest *arglist*) ,command))))
743
(setf (aref *call-backs* ind) command)
744
;; the command must NOT appear as "{[...]}" or it will be eval'd.
748
(defun bind (window-spec &optional sequence command type)
749
"command may be a function name, or an expression which
750
may involve occurrences of elements of *percent-symbols*
751
The expression will be evaluated in an enviroment in which
752
each of the % symbols is bound to the value of the corresponding
753
event value obtained from TK."
754
(cond ((equal sequence :return)
757
(cond ((equal command :return)
758
(or (eq type 'string)
759
(tkerror "bind only returns type string"))
762
(setq command (tcl-create-command command nil t))))
764
(pp 'bind no_leading_space)
765
(pp window-spec normal)
766
(and sequence (pp sequence normal))
767
(and command (pp command normal))
768
(send-tcl-cmd *tk-connection* tk-command (or (null sequence)(null command)))))
770
(defmacro tk-connection-fd (x) `(caar ,x))
783
;; problem on waiting. Waiting for dialog to kill self
784
;; wont work because the wait blocks even messages which go
787
;; (grab :set :global .fo)
788
;; and sometimes the gcltkaux gets blocked and cant accept input when
789
;; in grabbed state...
792
(def-control destroy :before destroy-aux)
795
(def-control selection)
796
(def-control tkerror)
798
(def-control tk-listbox-single-select :print-name "tk_listboxSingleSelect")
799
(def-control tk-menu-bar :print-name "tk_menuBar")
800
(def-control tk-dialog :print-name "tk_dialog")
801
(def-control get_tag_range)
803
(def-control lsearch)
807
(defun tk-wait-til-exists (win)
808
(tk-do (tk-conc "if ([winfo exists " win " ]) { } else {tkwait visibility " win "}")))
810
(defun destroy-aux (name l)
815
(dolist (prop '(:variable :textvariable))
819
(t (error "not a pathname : ~s" v))))
823
(defvar *default-timeout* (* 100 internal-time-units-per-second))
825
(defun execute-tcl-cmd (connection cmd)
826
(let (id tem (time *default-timeout*))
827
(declare (fixnum time))
828
(setq id (get-number-string cmd (pos msg-index *header*) 3))
829
(store-circle *replies* nil id)
830
(write-to-connection connection cmd)
832
(cond ((setq tem (get-circle *replies* id))
833
(cond ((or (car tem) (null *break-on-errors*))
834
(return-from execute-tcl-cmd (values (cdr tem) (car tem))))
835
(t (cerror "Type :r to continue" "Cmd failed: ~a : ~a "
836
(subseq cmd (length *header*)
842
(cond ((> (si::check-state-input
843
(tk-connection-fd connection) 10) 0)
846
(setq time (- time 10))
848
(cerror ":r resumes waiting for *default-timeout*"
849
"Did not get a reply for cmd ~a" cmd)
850
(setq time *default-timeout*)
853
(defun push-number-string (string number ind bytes )
854
(declare (fixnum ind number bytes))
855
;; a number #xabcdef is stored "<ef><cd><ab>" where <ef> is (code-char #xef)
856
(declare (string string))
857
(declare (fixnum number bytes ))
858
(sloop while (>= bytes 1) do
859
(setf (aref string ind)
860
(the character (code-char
861
(the fixnum(logand number 255)))))
863
(setq bytes (- bytes 1))
864
; (setq number (* number 256))
865
(setq number (ash number -8))
868
(defun get-number-string (string start bytes &aux (number 0))
869
;; a number #xabcdef is stored "<ef><cd><ab>" where <ef> is (code-char #xef)
870
(declare (string string))
871
(declare (fixnum number bytes start))
872
(setq start (+ start (the fixnum (- bytes 1))))
873
(sloop while (>= bytes 1) do
874
(setq number (+ number (char-code (aref string start))))
875
(setq start (- start 1) bytes (- bytes 1))
876
(cond ((> bytes 0) (setq number (ash number 8)))
877
(t (return number)))))
880
(defun quit () (tkdisconnect) (bye))
883
(setq *debugging* x))
885
(defmacro dformat (&rest l)
886
`(if *debugging* (dformat1 ,@l)))
887
(defun dformat1 (&rest l)
888
(declare (:dynamic-extent l))
889
(format *debug-io* "~%Lisp:")
890
(apply 'format *debug-io* l))
892
(defvar *sigusr1* nil)
893
;;??NOTE NOTE we need to make it so that if doing code inside an interrupt,
894
;;then we do NOT do a gc for relocatable. This will kill US.
895
;;One hack would be that if relocatable is low or cant be grown.. then
896
;;we just set a flag which says run our sigusr1 code at the next cons...
897
;;and dont do anything here. Actually we can always grow relocatable via sbrk,
898
;;so i think it is ok.....??......
900
(defun system::sigusr1-interrupt (x)
903
(setq *sigusr1* :received))
906
(dformat "Received SIGUSR1. ~a"
907
(if (> (si::check-state-input
908
(tk-connection-fd *tk-connection*) 0) 0) ""
909
"No Data left there."))
910
;; we put 4 here to wait for a bit just in case
912
(si::check-state-input
913
(tk-connection-fd *tk-connection*) 4 )
914
(read-and-act nil)))))
915
(setf (symbol-function 'si::SIGIO-INTERRUPT) (symbol-function 'si::sigusr1-interrupt))
918
(defun store-circle (ar reply id)
919
(declare (type (array t) ar)
921
(setf (aref ar (the fixnum (mod id (length ar)))) reply))
923
(defun get-circle (ar id)
924
(declare (type (array t) ar)
926
(aref ar (the fixnum (mod id (length ar)))))
928
(defun decode-response (str &aux reply-from )
929
(setq reply-from (get-number-string str
930
#.(+ 1 (length *header*))
933
(subseq str #.(+ 4 (length *header*)))
934
(eql (aref str #.(+ 1 (length *header*))) #\0)
936
(get-circle *requests* reply-from)))
938
(defun describe-message (vec)
940
(let ((body-length (get-number-string vec (pos body-length *header*) 3))
941
(msg-index (get-number-string vec (pos msg-index *header*) 3))
942
(mtype (nth (char-code (aref vec (pos type *header*))) *mtypes*))
945
(format t "~%Msg-id=~a, type=~a, leng=~a, " msg-index mtype body-length)
948
(setq from-id (get-number-string vec #.(+ 1 (length *header*))
950
(setq success (eql (aref vec #.(+ 0 (length *header*)))
952
(setq requ (get-circle *requests* from-id))
953
(format t "result-code=~a[bod:~s](form msg ~a)[hdr:~s]"
955
(subseq vec #.(+ 4 (length *header*)))
957
(subseq vec 0 (length *header*))
960
((m_create_command m_call
962
m_lisp_eval_wait_response)
963
(let ((islot (get-number-string vec #.(+ 0 (length *header*)) 3)))
964
(format t "islot=~a(callback_~a), arglist=~s" islot islot
965
(subseq vec #.(+ 3 (length *header*))))))
966
((m_tcl_command m_tcl_command_wait_response
967
M_TCL_CLEAR_CONNECTION
969
(format t "body=[~a]" (subseq vec (length *header*)) ))
970
((m_tcl_set_text_variable)
971
(let* ((bod (subseq vec (length *header*)))
972
(end (position (code-char 0) bod))
973
(var (subseq bod 0 end)))
974
(format t "name=~s,val=[~a],body=" var (subseq bod (+ 1 end)
977
((m_tcl_link_text_variable
978
m_tcl_unlink_text_variable
981
(let (var (islot (get-number-string vec #.(+ 0 (length *header*)) 3)))
982
(format t "array_slot=~a,name=~s,type=~s body=[~a]" islot
983
(setq var (aref *text-variable-locations* islot))
984
(get var 'linked-variable-type)
985
(subseq vec #.(+ 3 (length *header*))))))
987
(otherwise (error "unknown message type ~a [~s]" mtype vec )))))
989
(defun clear-tk-connection ()
990
;; flush both sides of connection and discard any partial command.
993
(si::clear-connection-state (car (car *tk-connection*)))
996
(set-message-header tk-command (pos m_tcl_clear_connection *mtypes*) 0)
997
(write-to-connection *tk-connection* tk-command))
1000
(defun read-tk-message (ar connection timeout &aux
1002
(declare (fixnum timeout n-read)
1005
(read-message-body *pending* connection timeout)))
1007
(setq n-read(si::our-read-with-offset (tk-connection-fd connection)
1008
ar 0 #.(length *header*) timeout))
1010
(cond ((not (eql n-read #.(length *header*)))
1013
(cerror ":r to resume "
1014
"Read got an error, have closed connection"))
1015
(t (error "Bad tk message"))))
1018
(eql (aref ar (pos magic1 *header*)) *magic1*)
1019
(eql (aref ar (pos magic2 *header*)) *magic2*))
1020
(error "Bad magic"))
1021
(read-message-body ar connection timeout))))
1023
(defun read-message-body (ar connection timeout &aux (m 0) (n-read 0))
1024
(declare (fixnum m n-read))
1025
(setq m (get-number-string ar (pos body-length *header*) 3))
1026
(or (>= (array-total-size ar) (the fixnum (+ m #.(length *header*))))
1027
(setq ar (adjust-array ar (the fixnum (+ m 40)))))
1029
(setq n-read (si::our-read-with-offset (tk-connection-fd connection)
1031
#.(length *header*) m timeout))
1032
(setq *pending* nil)
1034
(error "Failed to read ~a bytes" m))
1035
(setf (fill-pointer ar) (the fixnum (+ m #.(length *header*))))))
1036
(if *debugging* (describe-message ar))
1039
(defun tkdisconnect ()
1040
(cond (*tk-connection*
1041
(si::close-sd (caar *tk-connection*))
1042
(si::close-fd (cadr *tk-connection*))))
1043
(setq *sigusr1* t);; disable it...
1044
(setq *pending* nil)
1045
(setf *tk-connection* nil)
1049
(defun read-and-act (id)
1053
(let* ((*sigusr1* t) tem fun string)
1057
(or (> (si::check-state-input
1058
(tk-connection-fd *tk-connection*) 0) 0)
1059
(return-from read-and-act))
1060
(setq string (read-tk-message tk-command *tk-connection* *default-timeout*))
1062
(let ((type (char-code (aref string (pos type *header*))))
1066
(#.(pos m_reply *mtypes*)
1067
(setq from-id (get-number-string tk-command #.(+ 1 (length *header*))
1069
(setq success (eql (aref tk-command #.(+ 0 (length *header*)))
1071
(cond ((and (not success)
1073
(not (get-circle *requests* from-id)))
1075
":r to resume ignoring"
1076
"request ~s failed: ~s"
1077
(or (get-circle *request-forms* from-id) "")
1078
(subseq tk-command #.(+ 4 (length *header*))))))
1080
(store-circle *replies*
1082
(if (eql (length tk-command) #.(+ 4 (length *header*))) ""
1083
(subseq tk-command #.(+ 4 (length *header*)))))
1085
(#.(pos m_call *mtypes*)
1086
;; Can play a game of if read-and-act called with request-id:
1087
;; When we send a request which waits for an m_reply, we note
1088
;; at SEND time, the last message id received from tk. We
1089
;; dont process any funcall's with lower id than this id,
1090
;; until after we get the m_reply back from tk.
1092
(get-number-string tk-command #.(+ 0 (length *header*))3))
1093
(n (length tk-command)))
1094
(declare (fixnum islot n))
1095
(setq tem (our-read-from-string tk-command
1096
#.(+ 0 (length *header*)3)))
1097
(or (< islot (length *call-backs*))
1098
(error "out of bounds call back??"))
1099
(setq fun (aref (the (array t) *call-backs*) islot))
1100
(cond ((equal n #.(+ 3 (length *header*)))
1103
(setq tem (our-read-from-string
1105
#.(+ 3(length *header*))))
1106
(cond ((null tem) (funcall fun))
1107
((consp tem) (apply fun tem))
1108
(t (error "bad m_call message ")))))))
1109
(#.(pos m_set_lisp_loc *mtypes*)
1110
(let* ((lisp-var-id (get-number-string tk-command #.(+ 0 (length *header*))
1112
(var (aref *text-variable-locations* lisp-var-id))
1113
(type (get var 'linked-variable-type))
1115
(setq val (coerce-result (subseq tk-command #.(+ 3 (length *header*))) type))
1116
(setf (aref *text-variable-locations* (the fixnum
1117
( + lisp-var-id 1)))
1120
(otherwise (format t "Unknown response back ~a" tk-command)))
1122
(if (eql *sigusr1* :received)
1123
(dformat "<<received signal while reading>>"))
1127
(defun our-read-from-string (string start)
1128
(let* ((s (car *string-streams*))
1129
(*string-streams* (cdr *string-streams*)))
1130
(or s (setq s (make-string-input-stream "")))
1131
(si::reset-string-input-stream s string start (length string))
1135
(defun atoi (string)
1136
(if (numberp string) string
1137
(our-read-from-string string 0)))
1140
(defun conc (a b &rest l &aux tem)
1141
(declare (:dynamic-extent l))
1144
(or (symbolp a) (error "not a symbol ~s" a))
1145
; (or (symbolp b) (error "not a symbol ~s" b))
1146
(cond ((setq tem (get a b)))
1148
(setq tem (intern (format nil "~a~a" a b)
1153
(setq a tem b (car l) l (cdr l)))
1159
(defun dpos (x) (wm :geometry x "+60+25"))
1161
(defun string-list (x)
1163
(make-array 30 :element-type 'standard-char :fill-pointer 0 :adjustable t)))
1164
(string-list1 tk-command x)
1167
(defun string-list1 (tk-command l &aux x)
1168
;; turn a list into a tk list
1170
(pp x no_leading_space)
1177
(string-list1 tk-command x)
1178
(pp '} no_leading_space)))))
1180
(defun list-string (x &aux
1182
skipping (ch #\space)
1185
(declare (Fixnum brace-level n)
1188
(if (eql n 0) (return-from list-string nil))
1189
(sloop for i below n
1190
with beg = 0 and ans
1191
do (setq ch (aref x i))
1194
(cond (skipping nil)
1195
((eql brace-level 0)
1197
(setq ans (cons (subseq x beg i) ans)))
1201
(t (cond (skipping (setq skipping nil)
1204
(#\{ (cond ((eql brace-level 0)
1205
(setq beg (+ i 1))))
1207
(#\} (cond ((eql brace-level 1)
1208
(setq ans (cons (subseq x beg i) ans))
1210
(incf brace-level -1)))))
1213
(setq ans (cons (subseq x beg i) ans)))
1214
(return (nreverse ans))
1217
;; unless keyword :integer-value, :string-value, :list-strings, :list-forms
1218
;; (foo :return 'list) "ab 2 3" --> (ab 2 3)
1219
;; (foo :return 'list-strings) "ab 2 3" --> ("ab" "2" "3") ;;ie
1220
;; (foo :return 'string) "ab 2 3" --> "ab 2 3"
1221
;; (foo :return 't) "ab 2 3" --> AB
1222
;; (foo :return 'boolean) "1" --> t
1225
(defun coerce-result (string key)
1227
(list (our-read-from-string (tk-conc "("string ")") 0))
1229
(number (our-read-from-string string 0))
1230
((t) (our-read-from-string string 0))
1231
(t (let ((funs (get key 'coercion-functions)))
1233
(error "Undefined coercion for type ~s" key)))
1234
(funcall (car funs) string)))))
1236
;;convert "2c" into screen units or points or something...
1239
;; If loc is suitable for handing to setf, then
1240
;; (setf loc (coerce-result val type)
1243
(defvar *unbound-var* "<unbound>")
1245
(defun link-variable (var type)
1247
(ar *text-variable-locations*)
1251
(declare (fixnum i n)
1252
(type (array (t)) ar))
1253
(cond ((stringp var)
1254
(return-from link-variable var))
1258
(setq type (car var))
1259
(setq var (cadr var))))
1260
(or (and (symbolp type)
1261
(get type 'coercion-functions))
1262
(error "Need coercion functions for type ~s" type))
1263
(or (symbolp var) (error "illegal text variable ~s" var))
1264
(setq tem (get var 'linked-variable-type))
1265
(unless (if (and tem (not (eq tem type)))
1266
(format t "~%;;Warning: ~s had type ~s, is being changed to type ~s"
1269
(setf (get var 'linked-variable-type) type)
1271
(cond ((eq (aref ar i) var)
1272
(return-from link-variable var))
1275
(t (setq i (+ i 2)))))
1276
;; i is positioned at the write place
1278
(vector-push-extend nil ar)
1279
(vector-push-extend nil ar)))
1280
(setf (aref ar i) var)
1281
(setf (aref ar (the fixnum (+ i 1)))
1286
(push-number-string tk-command i #.(length *header*) 3)
1287
(setf (fill-pointer tk-command) #. (+ 3 (length *header*)))
1288
(pp var no_quotes_and_no_leading_space)
1289
(vector-push-extend (code-char 0) tk-command)
1290
(set-message-header tk-command (pos m_tcl_link_text_variable *mtypes*)
1291
(- (length tk-command) #.(length *header*)))
1292
(write-to-connection *tk-connection* tk-command)))
1293
(notice-text-variables)
1296
(defun unlink-variable (var )
1298
(ar *text-variable-locations*)
1302
(declare (fixnum i n)
1303
(type (array (t)) ar))
1305
(cond ((eq (aref ar i) var)
1306
(setf (aref ar i) nil)
1307
(setf (aref ar (+ i 1)) nil)
1310
(t (setq i (+ i 2)))))
1314
(push-number-string tk-command i #.(length *header*) 3)
1315
(setf (fill-pointer tk-command) #. (+ 3 (length *header*)))
1316
(pp var no_quotes_and_no_leading_space)
1317
(vector-push-extend (code-char 0) tk-command)
1318
(set-message-header tk-command (pos m_tcl_unlink_text_variable *mtypes*)
1319
(- (length tk-command) #.(length *header*)))
1320
(write-to-connection *tk-connection* tk-command))
1323
(defun notice-text-variables ()
1325
(ar *text-variable-locations*)
1329
(declare (fixnum i n)
1330
(type (array (t)) ar))
1333
(unless (or (not (boundp (setq var (aref ar i))))
1334
(eq (setq tem (symbol-value var))
1335
(aref ar (the fixnum (+ i 1)))))
1336
(setf (aref ar (the fixnum (+ i 1))) tem)
1337
(setq type (get var 'linked-variable-type))
1339
;(push-number-string tk-command i #.(length *header*) 3)
1340
;(setf (fill-pointer tk-command) #. (+ 3 (length *header*)))
1341
(pp var no_quote_no_leading_space)
1342
(vector-push (code-char 0) tk-command )
1344
(string (or (stringp tem) (go error)))
1345
(number (or (numberp tem) (go error)))
1346
((t) (setq tem (format nil "~s" tem )))
1348
(let ((funs (get type 'coercion-functions)))
1349
(or funs (error "no writer for type ~a" type))
1350
(setq tem (funcall (cdr funs) tem)))))
1351
(pp tem no_quotes_and_no_leading_space)
1352
(vector-push (code-char 0) tk-command )
1353
(set-message-header tk-command (pos m_tcl_set_text_variable *mtypes*)
1354
(- (length tk-command) #.(length *header*)))
1355
(write-to-connection *tk-connection* tk-command)))
1357
(return-from notice-text-variables)
1359
(error "~s has value ~s which is not of type ~s" (aref ar i)
1362
(defmacro setk (&rest l)
1364
(notice-text-variables)))
1366
(setf (get 'boolean 'coercion-functions)
1367
(cons #'(lambda (x &aux (ch (aref x 0)))
1368
(cond ((eql ch #\0) nil)
1370
(t (error "non boolean value ~s" x))))
1371
#'(lambda (x) (if x "1" "0"))))
1373
(setf (get 't 'coercion-functions)
1374
(cons #'(lambda (x) (our-read-from-string x 0))
1375
#'(lambda (x) (format nil "~s" x))))
1377
(setf (get 'string 'coercion-functions)
1379
(cond ((stringp x) x)
1380
(t (format nil "~s" x))))
1384
(setf (get 'list-strings 'coercion-functions)
1385
(cons 'list-string 'list-to-string))
1386
(defun list-to-string (l &aux (x l) v (start t))
1391
(t (error "Not a true list ~s" l)))
1392
(cond (start (pp v no_leading_space) (setq start nil))
1395
(subseq tk-command #.(length *header*))))
1399
(defvar *tk-library* nil)
1400
(defun tkconnect (&key host can-rsh gcltksrv (display (si::getenv "DISPLAY"))
1402
&aux hostid (loopback "127.0.0.1"))
1403
(if *tk-connection* (tkdisconnect))
1404
(or display (error "DISPLAY not set"))
1405
(or *tk-library* (setq *tk-library* (si::getenv "TK_LIBRARY")))
1408
(cond (host "gcltksrv")
1409
((si::getenv "GCL_TK_SERVER"))
1410
((probe-file (tk-conc si::*lib-directory* "/gcl-tk/gcltksrv")))
1411
((probe-file (tk-conc si::*lib-directory* "gcl-tk/gcltksrv")))
1412
(t (error "Must setenv GCL_TK_SERVER ")))))
1413
(let ((pid (if host -1 (si::getpid)))
1414
(tk-socket (si::open-named-socket 0))
1416
(cond ((not host) (setq hostid loopback))
1417
(host (setq hostid (si::hostname-to-hostid (si::gethostname)))))
1418
(or hostid (error "Can't find my address"))
1419
(setq tk-socket (si::open-named-socket 0))
1420
(if (pathnamep gcltksrv) (setq gcltksrv (namestring gcltksrv)))
1422
(tk-conc gcltksrv " " hostid " "
1428
(cond ((not host) (system command))
1430
(system (tk-conc "rsh " host " " command
1432
(t (format t "Waiting for you to invoke GCL_TK_SERVER,
1433
on ~a as in: ~s~%" host command )))
1434
(let ((ar *text-variable-locations*))
1435
(declare (type (array (t)) ar))
1436
(sloop for i below (length ar) by 2
1437
do (remprop (aref ar i) 'linked-variable-type)))
1438
(setf (fill-pointer *text-variable-locations*) 0)
1439
(setf (fill-pointer *call-backs*) 0)
1441
(setq *tk-connection* (si::accept-socket-connection tk-socket ))
1443
(si::SET-SIGIO-FOR-FD (car (car *tk-connection*))))
1444
(setf *sigusr1* nil)
1445
(tk-do (tk-conc "source " si::*lib-directory* "gcl-tk/gcl.tcl"))
1450
(defun children (win)
1451
(let ((ans (list-string (winfo :children win))))
1452
(cond ((null ans) win)
1453
(t (cons win (mapcar 'children ans))))))
1456
;; read nth item from a string in
1460
(defun nth-a (n string &optional (separator #\space) &aux (j 0) (i 0)
1461
(lim (length string)) ans)
1462
(declare (fixnum j n i lim))
1465
(setq ans (our-read-from-string string i))
1467
((eql (aref string i) separator)
1474
(defun set-message-header(vec mtype body-length &aux (m (msg-index)) )
1475
(declare (fixnum mtype body-length m)
1477
(setf (aref vec (pos magic1 *header*)) *magic1*)
1478
(setf (aref vec (pos magic2 *header*)) *magic2*)
1479
; (setf (aref vec (pos flag *header*)) (code-char (make-flag flags)))
1480
(setf (aref vec (pos type *header*)) (code-char mtype))
1481
(push-number-string vec body-length (pos body-length *header*) 3)
1482
(push-number-string vec m (pos msg-index *header*) 3)
1483
(setf (msg-index) (the fixnum (+ m 1)))
1486
(defun get-autoloads (&optional (lis (directory "*.lisp")) ( out "index.lsp")
1489
(declare (special *paths*))
1491
(st out :direction :output)
1492
(format st "~%(in-package ~s)" (package-name *package*))
1493
(dolist (v lis) (get-file-autoloads v st))
1494
(format st "~%(in-package ~s)" (package-name *package*))
1495
(format st "~2%~s" `(setq si::*load-path* (append ',*paths* si::*load-path*)))
1501
(defun get-file-autoloads (file &optional (out t)
1503
(*package* *package*)
1506
(declare (special *paths*))
1507
(setq name (pathname-name (pathname file)))
1510
(if (boundp '*paths*)
1511
(pushnew (namestring (make-pathname :directory
1514
*paths* :test 'equal))
1515
(sloop for tem = (read st nil eof)
1516
while (not (eq tem eof))
1517
do (cond ((and (consp tem) (eq (car tem) 'defun))
1519
(format t "~%;;Warning:(in ~a) a defun not preceded by package declaration" file))
1520
(format out "~%(~s '~s '|~a|)"
1523
((and (consp tem) (eq (car tem) 'in-package))
1524
(setq saw-package t)
1525
(or (equal (find-package (second tem)) *package*)
1526
(format out "~%~s" tem))
1530
;; execute form return values as usual unless error
1531
;; occurs in which case if symbol set-var is supplied, set it
1532
;; to the tag, returning the tag.
1533
(defmacro myerrorset (form &optional set-var)
1534
`(let ((*break-enable* nil)(*debug-io* si::*null-io*)
1535
(*error-output* si::*null-io*))
1536
(multiple-value-call 'error-set-help ',set-var
1537
(si::error-set ,form))))
1539
(defun error-set-help (var tag &rest l)
1540
(cond (tag (if var (set var tag))) ;; got an error
1541
(t (apply 'values l))))
1543
;;; Local Variables: ***
1545
;;; version-control:t ***
1546
;;; comment-column:0 ***
1547
;;; comment-start: ";;; " ***
added
removed
gcl-tk/tkl.lisp
