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 / structures2.scm < prev    next >
Text File  |  1995-08-02  |  3KB  |  119 lines
  1. ;;; -*- Scheme -*-
  2.  
  3. ;;; More structures.  With all this macro expansion, the compiler runs
  4. ;;; out of space if they are all in one file.
  5.  
  6. (scc-define-structure Application%
  7.   UIObjInternals
  8.   %child-windows         ; Locked list of all children
  9.   %%%code%%%               ; Asynchronous code to be
  10.                         ; executed when data arrives
  11.                         ; from the display connection
  12.   application-name
  13.   Xdisplay               ; A SCXL-wrapped display
  14.   TKMainWindow
  15.   context)
  16.  
  17. (scc-define-structure Interactor%
  18.   UIObjInternals
  19.   handlers
  20.   ;; Map from children of the interactor -- things it manages --
  21.   ;; to Sensitive-Surface data structures.  These are implemented
  22.   ;; at the end of the file and maintain the correspondence
  23.   ;; between drawing surfaces, event generation masks, and
  24.   ;; <interactor> objects.
  25.   (sensitive-surface-map '()))
  26.  
  27. (scc-define-structure Shape%
  28.   UIObjInternals
  29.   x-draw
  30.   calculate-used-screen-area
  31.   color
  32.   point-within?
  33.   rectangle-overlaps?
  34.   (x-erase #F)
  35.   gc-function
  36.   (graphics-context #F))
  37.  
  38. (scc-define-structure Box%
  39.   UIObjInternals
  40.   sizer
  41.   arranger
  42.   get-hglue
  43.   get-vglue
  44.   (kids '()))
  45.  
  46. (scc-define-structure ArrayBox%
  47.   UIObjInternals
  48.   kids-lists
  49.   (kids '()))
  50.  
  51. (scc-define-structure TKWidget%
  52.   UIObjInternals
  53.   Ask-Widget-procedure
  54.   Add-Event-Handler!-procedure
  55.   Set-Callback!-procedure
  56.   (deferred-ask-widget-commands '())
  57.   (how-to-make-me 'later)
  58.   ;; Parent-Window -- stored as assigned screen area
  59.   (Set-Glue!-procedure 'later)
  60.   (%c-callback 'later)
  61.   (%binding-callbacks '())
  62.   (%scheme-geometry-manager 'later)
  63.   (%scheme-callback-hash 'later)
  64.   (%callback #F)
  65.   (%callback-command #F)
  66.   (%children '())
  67.   (handle #F)
  68.   (do-screen-area? 'later)
  69.   ;; The following is weird.  TK does finalization of some TK objects
  70.   ;; (sub-menus bit us ...) and we can *not* destroy these on our own.
  71.   ;; We simply reflect the ownership (via add-child!) to prevent them
  72.   ;; from being GCed away if the TK parent exists.  And the child
  73.   ;; better hold on to the parent, too.
  74.   (do-not-gc-protect #F))
  75.  
  76. (scc-define-structure CanvasItem
  77.   Ask-Widget-procedure
  78.   Add-Event-Handler!-procedure
  79.   Set-Callback!-procedure
  80.   Name
  81.   Canvas
  82.   %binding-callbacks)
  83.  
  84. (scc-define-structure CanvasItemGroup
  85.   Ask-Widget-procedure
  86.   Add-Event-Handler!-procedure
  87.   Set-Callback!-procedure
  88.   Tag
  89.   Canvas
  90.   %binding-callbacks)
  91.  
  92. (scc-define-structure MenuRecord Menu Items)
  93.  
  94. (scc-define-structure MenuItem
  95.   ask-widget-procedure
  96.   Add-event-handler!-procedure
  97.   Set-callback!-procedure
  98.   MenuRecord
  99.   %callback
  100.   index)
  101.  
  102. (scc-define-structure TextTag
  103.   ask-widget-procedure
  104.   Add-event-handler!-procedure
  105.   Set-callback!-procedure
  106.   Name
  107.   Text
  108.   Callbacks)
  109.  
  110. ;;; procedures that are generic over CanvasItem, CanvasTag, MenuItem,
  111. ;;; TextTag, and TKWidget
  112.  
  113. (define-integrable ask-widget-procedure-index 1)
  114. (define-integrable add-event-handler!-procedure-index 2)
  115. (define-integrable set-callback!-procedure-index 3)
  116.  
  117.  
  118.  
  119.