home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / swat / scheme / tk-mit.scm < prev    next >
Text File  |  1997-10-02  |  12KB  |  384 lines
  1. ; -*- Scheme -*-
  2. ;;;;; C external interfaces to Tk procedures not associated with
  3. ;;;;; a particular widget.
  4. ;;;; $Id: tk-mit.scm,v 1.4 1997/10/02 19:19:44 adams Exp $
  5.  
  6. ;;;; This is the lowest level Scheme interface to general TK/TCL data
  7. ;;;; structures.  Primitives are defined in tk-mit.c and tk.c
  8.  
  9. (define-primitives
  10.   (%tclGlobalEval 2)
  11.   (%tkCompletelyHandlesEvent? 1)
  12.   (%tkCreateTopLevelWindow 3)
  13.   (%tkDoEvents 0)
  14.   (%tkDrainCallBacks 2)
  15.   (%tkGenerateSchemeEvent 2)
  16.   (%tkInit 2)
  17.   (%tkInvokeCommand -1)
  18.   (%tkKillApplication 1)
  19.   (%tkManageGeometry 2)
  20.   (%tkMapWindow 1)
  21.   (%tkMoveResizeWindow 5)
  22.   (%tkMoveWindow 3)
  23.   (%tkNextWakeup 0)
  24.   (%tkResizeWindow 3)
  25.   (%tkUnmapWindow 1)
  26.   (%tkWidget.tkwin 1)
  27.   (%tkWinDisplay 1)
  28.   (%tkWinReqHeight 1)
  29.   (%tkWinReqWidth 1)
  30.   (%tkWinHeight 1)
  31.   (%tkWinIsMapped? 1)
  32.   (%tkWinName 1)
  33.   (%tkWinPathName 1)
  34.   (%tkWinWidth 1)
  35.   (%tkWinWindow 1)
  36.   (%tkWinX 1)
  37.   (%tkWinY 1)
  38. )
  39.  
  40. ;;;; Support code
  41.  
  42. (define tk-gen-name
  43.   (let ((count 0))
  44.     (lambda (name)
  45.       (set! count (+ 1 count))
  46.       (string-append name (number->string count)))))
  47.  
  48. ;;;; Entry points in alphabetical order
  49.  
  50. (define (get-interval-to-tk-wakeup)
  51.   (%tkNextWakeup))
  52.  
  53.  
  54. ;; A not-so-precise number->string that is faster and more than
  55. ;; sufficient for our purposes.  Note that the output always has a
  56. ;; leading digit to prevent tk from thinking that .7 is a name and
  57. ;; not a number.
  58.  
  59. (define (swat:number->string x)
  60.  
  61.   (define (digits x n tail)
  62.     (define (next* ch x*)
  63.       (cons ch (digits x* (fix:- n 1) tail)))
  64.     (define-integrable (next ch delta)
  65.       (next* ch (flo:* (flo:- x delta) 10.0)))
  66.     (cond ((< n 0)  tail)
  67.       ((flo:< x 1.e-10)  tail)
  68.       ((flo:< x 1.0) (next #\0 0.0))
  69.       ((flo:< x 2.0) (next #\1 1.0))
  70.       ((flo:< x 3.0) (next #\2 2.0))
  71.       ((flo:< x 4.0) (next #\3 3.0))
  72.       ((flo:< x 5.0) (next #\4 4.0))
  73.       ((flo:< x 6.0) (next #\5 5.0))
  74.       ((flo:< x 7.0) (next #\6 6.0))
  75.       ((flo:< x 8.0) (next #\7 7.0))
  76.       ((flo:< x 9.0) (next #\8 8.0))
  77.       (else          (next #\9 9.0))))
  78.     
  79.   (define (format-exponent e)
  80.     (define (format-integer n tail)
  81.       (define (+digit k) (cons (ascii->char (fix:+ k 48)) tail))
  82.       (if (fix:< n 10)
  83.       (+digit n)
  84.       (let ((front (fix:quotient n 10))
  85.         (back  (fix:remainder n 10)))
  86.         (format-integer front (+digit back)))))
  87.     (cond ((fix:= e 0) '())
  88.       ((fix:< e 0)
  89.        (cons* #\e #\- (format-integer (fix:- 0 e) '())))
  90.       (else
  91.        (cons* #\e (format-integer e '())))))
  92.  
  93.   (define (scale x e)
  94.     (cond ((flo:< x 1.0e-30) '(#\0 #\. #\0))
  95.       ((flo:< x 1.0)     (scale (flo:* x 1000.0) (- e 3)))
  96.       ((flo:< x 10.0)
  97.        (let* ((tail  (format-exponent e))
  98.           (ds (digits x 8 tail)))
  99.          (if (eq? (cdr ds) tail)
  100.          (cons* (car ds) #\. #\0 (cdr ds))
  101.          (cons* (car ds) #\. (cdr ds)))))
  102.       (else          (scale (flo:* x 0.1) (+ e 1)))))
  103.  
  104.   (if (flo:flonum? x)
  105.       (list->string
  106.        (if (flo:< x 0.0)
  107.        (cons #\- (scale (flo:- 0.0 x) 0))
  108.        (scale x 0)))
  109.       (number->string x 10)))
  110.  
  111. (define (stringify-for-tk arg)
  112.   (define (->string arg)
  113.     (cond ((string? arg)      arg)
  114.       ((number? arg)      (swat:number->string arg))
  115.       ((symbol? arg)      (symbol-name arg))
  116.       ((TK-variable? arg) (TK-variable.tk-name arg))
  117.       ((pair? arg)        (apply string-append (map stringify-for-tk arg)))
  118.       ((procedure? arg)   (->string (arg)))
  119.       (else (error "tcl-global-eval: Unknown argument type" arg))))
  120.  
  121.   (string-append "{" (->string arg) "} "))
  122.  
  123. (define (tk-op thunk)
  124.   (let ((result (thunk)))
  125.     (kick-uitk-thread)
  126.     result))
  127.    
  128. (define (tcl-global-eval application command-name args)
  129.   (tk-op
  130.    (lambda ()
  131.      (%tclGlobalEval
  132.       (application->TKMainWindow application)
  133.       (apply string-append (map stringify-for-tk (cons command-name args)))))))
  134.  
  135.  
  136. ;;;turn off all floating errors around TK processing
  137. ;;;Note that we don't need a dynamic wind because
  138. ;;;%tkCompletelyHandlesEvent? always completes.  If the argument is
  139. ;;;bad it returns a 0.
  140.  
  141. (define (tk-completely-handles-event? os-event)
  142.   (let ((old-mask (set-floating-error-mask! 0)))
  143.     (let ((result (%tkCompletelyHandlesEvent? os-event)))
  144.       (set-floating-error-mask! old-mask)
  145.       (if (eqv? result 0)
  146.       (error "bad argument to tk-completely-handles-event?" os-event)
  147.       result))))
  148.  
  149. (define (tk-create-top-level-window main-window callbackhash)
  150.   (tk-op
  151.    (lambda ()
  152.      (%tkCreateTopLevelWindow main-window
  153.                   (tk-gen-name "top-level-window")
  154.                   callbackhash))))
  155.  
  156. (define (tk-doevents)
  157.   ;; Turn off floating errors
  158.   (let ((old-mask (set-floating-error-mask! 0)))
  159.     ;; Do all pending Tk events, which should only be do-when-idles
  160.     (%tkDoEvents)
  161.     (set-floating-error-mask! old-mask))
  162.   (do-tk-callbacks))
  163.  
  164. (define (tk-generate-Scheme-event event-mask unwrapped-tk-window)
  165.   ;; Cause TK to signal us that Scheme wants to know about these kinds
  166.   ;; of events on this window.
  167.   (%tkGenerateSchemeEvent event-mask unwrapped-tk-window))
  168.  
  169. (define (tk-init xdisplay)
  170.   ;; Set up an initial environment with a Tcl interpreter
  171.   (tk-op
  172.    (lambda ()
  173.      (%tkInit (->xdisplay xdisplay)
  174.           (tk-gen-name
  175.            (string-append "main-window-for-display-"
  176.                   (number->string (->xdisplay xdisplay))))))))
  177.  
  178. (define (tk-invoke-command command-name main-window arg-strings)
  179.   (define commands
  180.     `((After . 0)
  181.       (Bind . 1)
  182.       (Destroy . 2)
  183.       (Focus . 3)
  184.       (Grab . 4)
  185.       (Option . 5)
  186.       (Pack . 6)
  187.       (Place . 7)
  188.       (Selection . 8)
  189.       (Tk . 9)
  190.       (Tkwait . 10)
  191.       (Update . 11)
  192.       (Winfo . 12)
  193.       (Wm . 13)))
  194.   (tk-op 
  195.    (lambda ()
  196.      (apply %tkInvokeCommand (cdr (assq command-name commands))
  197.         main-window
  198.         arg-strings))))
  199.  
  200. (define (tk-kill-application main-window)
  201.   ;; main-window is an integer, not wrapped
  202.   (%tkKillApplication main-window))
  203.  
  204. (define (tk-manage-geometry widget manager-procedure)
  205.   ;; Arrange for manager-procedure to be called with no arguments
  206.   ;; whenever TK requests geometry operations on widget.
  207.   (tk-op
  208.    (lambda ()
  209.      (%tkManageGeometry (tk-widget.tkwin widget)
  210.             (and manager-procedure
  211.                  (hash manager-procedure
  212.                    *our-hash-table*))))))
  213.  
  214. (define (tk-map-window tkwin)
  215.   (tk-op (lambda () (%tkmapwindow tkwin))))
  216.  
  217. (define (tk-move-resize-widget widget screen-area)
  218.   (tk-op
  219.    (lambda ()
  220.      (%tkMoveResizeWindow (tk-widget.tkwin widget)
  221.               (Point.X (UITKRectangle.Offset screen-area))
  222.               (Point.Y (UITKRectangle.Offset screen-area))
  223.               (UITKRectangle.Width screen-area)
  224.               (UITKRectangle.Height screen-area)))))
  225.  
  226. (define (TK-Unmap-Window tkwin)
  227.   (tk-op (lambda () (%tkUnmapWindow tkwin))))
  228.  
  229. (define (tk-widget.tkwin widget)
  230.   (%tkWidget.tkwin (->widget widget)))
  231.  
  232. (define (tkwin.display tkwin)
  233.   (%tkWinDisplay tkwin))
  234.  
  235. (define (tkwin.req-height tkwin)
  236.   (%tkWinReqHeight tkwin))
  237.  
  238. (define (tkwin.req-width tkwin)
  239.   (%tkWinReqWidth tkwin))
  240.  
  241. (define (tkwin.height tkwin)
  242.   (%tkWinHeight tkwin))
  243.  
  244. (define (tkwin.IsMapped? tkwin)
  245.   (%tkWinIsMapped? tkwin))
  246.  
  247. (define (tkwin.width tkwin)
  248.   (%tkWinWidth tkwin))
  249.  
  250. (define (tkwin.window tkwin)
  251.   ;; Deliberately don't do a wrap-window. Instead, allow a higher
  252.   ;; level to do it, since the server maintains the window hierarchy
  253.   ;; and effectively keeps pointers for us.
  254.   (%tkWinWindow tkwin))
  255.  
  256. (define (tkwin.name tkwin)
  257.   (%tkWinName tkwin))
  258.  
  259. (define (tkwin.pathname tkwin)
  260.   (%tkWinPathName tkwin))
  261.  
  262. (define (tkwin.x tkwin)
  263.   (%tkWinX tkwin))
  264.  
  265. (define (tkwin.y tkwin)
  266.   (%tkWinY tkwin))
  267.  
  268. ;;;; TK Callback handling
  269.  
  270. (define (do-tk-callbacks-from-string string)
  271.   ;; The string has the following format:
  272.   ;;  <char. count>
  273.   ;;    <nchars>chars
  274.   ;;    <nchars>chars
  275.   ;;  ...
  276.   ;;  where <char. count> is the number of characters in the object ID
  277.   ;;  and its associated string arguments.  The "<" and ">" are NOT
  278.   ;;  meta-characters; they are used for separating the entries and
  279.   ;;  error detection.
  280.   (define (split-string-by-number string receiver)
  281.     ;; Expects a character count in angle brackets.  Calls receiver
  282.     ;; with the counted string and the rest, or #F/#F if the string is
  283.     ;; empty.
  284.     (cond
  285.      ((string-null? string) (receiver #F #F))
  286.      ((not (char=? (string-ref string 0) #\<))
  287.       (error "Split-String-By-Number: Badly formed entry"
  288.          string))
  289.      (else
  290.       (let ((break-at (string-find-next-char string #\>)))
  291.     (if (not break-at)
  292.         (error "Split-String-By-Number: entry not terminated"
  293.            string)
  294.         (let ((count (string->number (substring string 1 break-at)))
  295.           (after-count (+ break-at 1))
  296.           (slength (string-length string)))
  297.           (cond
  298.            ((not count)
  299.         (error "Split-String-By-Number: non-numeric count" string))
  300.            ((> (+ after-count count) slength)
  301.         (error "Split-String-By-Number: count too big" string))
  302.            (else
  303.         (let ((end (+ after-count count)))
  304.           (receiver (substring string after-count end)
  305.                 (substring string end slength)))))))))))
  306.   (define (parse-entry string receiver)
  307.     ;; Entry starts with a character count in angle brackets
  308.     ;; Receiver is called with an object, a vector of strings, and the
  309.     ;; remaining string.
  310.     (split-string-by-number string
  311.      (lambda (entry after-entry)
  312.        (let loop ((rest entry)
  313.           (strings '()))
  314.      (split-string-by-number rest
  315.       (lambda (this-string rest-of-strings)
  316.         (if this-string
  317.         (loop rest-of-strings
  318.               (cons this-string strings))
  319.         (let ((all-strings (reverse strings)))
  320.           (if (null? all-strings)
  321.               (error "Parse-Entry: no entries" string))
  322.           (let* ((Object-Name (car all-strings))
  323.              (Object-ID (string->number object-name)))
  324.             (if (not object-id)
  325.             (error "Parse-Entry: non-number object ID"
  326.                    string object-name))
  327.             ;; Note that the object associated with object-id
  328.             ;; may have been GCed away!
  329.             (receiver (object-unhash object-id *our-hash-table*)
  330.                   (cdr all-strings)
  331.                   after-entry))))))))))
  332.   (if string
  333.       (let callback-loop ((string string))
  334.     (if (string-null? string)
  335.         'done
  336.         (parse-entry string
  337.              (lambda (callback list-of-string-args rest-of-string)
  338.                ;; "callback" will be #F if it GC'ed away
  339.                (if callback
  340.                    (our-with-thread-mutex-locked
  341.                 'do-tk-callback
  342.                 *event-processing-mutex*
  343.                 (lambda ()
  344.                   (apply-callback callback list-of-string-args))))
  345.                (callback-loop rest-of-string))))))
  346.   'OK)
  347.  
  348. (define (apply-callback callback arglist)
  349.   (cond ((ignore-errors
  350.       (lambda () (apply callback arglist)))
  351.      => (lambda (result)
  352.           (if (condition? result)
  353.           (let ((port  (notification-output-port)))
  354.             (newline port)
  355.             (write-string ";Error in callback " port)
  356.             (display callback port)
  357.             (newline port)
  358.             (write-string ";" port)
  359.             (write-condition-report result port)
  360.             (newline port)
  361.             (write-string ";To debug, type (debug #@" port)
  362.             (write (hash result) port)
  363.             (write-string ")" port)
  364.             (newline port)))))))
  365.  
  366.  
  367. (define *event-processing-mutex* (make-thread-mutex))
  368.  
  369. (define do-tk-callbacks
  370.   (let ((nchars 0)
  371.     (string (make-string 0)))
  372.     (lambda ()
  373.       (let ((nchars-ready (%tkDrainCallBacks nchars string)))
  374.     (if nchars-ready
  375.         (if
  376.          (positive? nchars-ready)
  377.          (begin
  378.            (set! nchars nchars-ready)
  379.            (set! string (make-string nchars-ready))
  380.            (do-tk-callbacks))
  381.          'OK)
  382.         (do-tk-callbacks-from-string string))))))
  383.  
  384.