home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / xlib / xwss.t < prev   
Encoding:
Text File  |  1990-06-07  |  15.3 KB  |  538 lines
  1. ;;; This module contains the interface routines which are not automatically
  2. ;;; generated.
  3.  
  4. (herald xwss (env tsys (xlib interface)))
  5.  
  6. ;;; Internal functions.
  7.  
  8. (define (POINTER-LIST->STRING lst typep)
  9.     (do ((i 0 (+ i 1))
  10.      (array (make-bytev (* 4 (length lst))))
  11.      (lst lst (cdr lst)))
  12.     ((null? lst)
  13.      array)
  14.     (set-mref-pointer! array i (typep (car lst)))))
  15.  
  16. (define (ARRAY-POINTER->LIST arrayptr count type)
  17.   (let ((arrayptr (c->extend arrayptr)))
  18.     (iterate loop ((x 0))
  19.      (if (eq? x count)
  20.          '()
  21.          (cons (if type
  22.                (cons type (extend-elt arrayptr x))
  23.                (extend-elt arrayptr x))
  24.            (loop (+ x 1)))))))
  25.  
  26. (define-foreign xfree ("XFree" (in rep/c-pointer)) ignore)
  27.  
  28. (define (CHK-STRING x)
  29.     (if (string? x) x (error "Argument is incorrect type: ~s" x)))
  30.  
  31.  
  32. (define (STRING-LIST->STRING-ARRAY strings)
  33.   (let ((texts (map (lambda (x) (string-text (string->asciz! (copy-string x)))) strings))
  34.     (str (make-bytev (fx* (length strings) 4))))
  35.     (do ((i 0 (fx+ i 4))
  36.      (texts texts (cdr texts)))
  37.     ((null? texts) str)
  38.       (set-mref-pointer! str i
  39.              (fx+ (descriptor->fixnum (car texts)) 1)))))
  40.  
  41. (define (STRING-ARRAY->STRING-LIST ptr cnt)
  42.   (let ((ptr (c->extend ptr)))
  43.     (iterate loop ((x 0))
  44.      (if (eq? x cnt)
  45.          '()
  46.          (cons (asciz->string (extend-elt ptr x))
  47.            (loop (fx+ x 1)))))))
  48.  
  49. (define (COPY-PTR-TO-STRUCT ptr struct)
  50.     (let* ((array (cdr struct))
  51.        (size (bytev-length array)))
  52.       (iterate loop ((x 0))
  53.            (cond ((neq? x size)
  54.               (set-mref-pointer! array x (mref-pointer ptr x))
  55.               (loop (+ x 4)))))
  56.       struct))
  57.  
  58. (define (ARRAY-STRUCT->LIST ptr count make-struct)
  59.   (let ((ptr (c->extend ptr)))
  60.     (iterate loop ((ptr ptr) (x count))
  61.      (if (eq? x 0)
  62.          '()
  63.          (let* ((struct (copy-ptr-to-struct ptr (make-struct)))
  64.             (size (fx/ (bytev-length (cdr struct)) 4)))
  65.            (cons struct (loop (make-pointer ptr size) (- x 1))))))))
  66.  
  67. (define (STRUCT-LIST->bytev lst typep)
  68.     (apply bytev-append
  69.        (map typep lst)))
  70.  
  71.  
  72. ;;; Misc. Utility functions.
  73.  
  74. (define (NULL-POINTER? x) (or (eq? x 0) (and (pair? x) (eq? (cdr x) 0))))
  75.  
  76. (define (POINTER-TYPE x) (and (pair? x) (car x)))
  77.  
  78. (define (POINTER-VALUE x) (and (pair? x) (cdr x)))
  79.  
  80. (define (TYPE/VALUE->POINTER type value) (cons type value))
  81.  
  82. ;;; Chapter 2.
  83.  
  84. (define-foreign xfree* ("XFree" (in rep/c-pointer)) ignore)
  85.  
  86. (define (YFREE ptr)
  87.     (if (pair? ptr)
  88.     (xfree* (pointer-value ptr))
  89.     (xfree* ptr))
  90.     '#f)
  91.  
  92. ;;; Chapter 4.
  93.  
  94. (define-foreign xquerytree*
  95.   ("XQueryTree" (in rep/c-pointer)
  96.         (in rep/integer)
  97.         (in rep/extend)
  98.         (in rep/extend)
  99.         (in rep/extend)
  100.         (in rep/extend))
  101.     int)
  102.  
  103.  
  104. (define (YQUERYTREE dpy window)
  105.     (let ((dpy (chk-displayp dpy))
  106.       (root (make-bytev 4))
  107.       (parent (make-bytev 4))
  108.       (children (make-bytev 4))
  109.       (nchildren (make-bytev 4)))
  110.      (if (eq? 0 (xquerytree* dpy window root parent children nchildren))
  111.          '#f
  112.          (let ((result (list (mref-integer root 0)
  113.                  (mref-integer parent 0)
  114.                  (array-pointer->list
  115.                      (mref-pointer children 0)
  116.                      (mref-integer nchildren 0)
  117.                      '#f))))
  118.           (xfree (mref-pointer children 0))
  119.           result))))
  120.  
  121. (define-foreign xgetatomname* 
  122.   ("XGetAtomName" (in rep/c-pointer) (in rep/integer)) rep/pointer)
  123.  
  124. (define (YGETATOMNAME dpy atom)
  125.     (let* ((dpy (chk-displayp dpy))
  126.        (result (xgetatomname* dpy atom))
  127.        (name (asciz->string result)))
  128.       (xfree result)
  129.       name))
  130.  
  131. (define-foreign xlistproperties*
  132.   ("XListProperties" (in rep/c-pointer) (in rep/integer)
  133.              (in rep/extend))
  134.   rep/pointer)
  135.  
  136. (define (YLISTPROPERTIES dpy window)
  137.     (let* ((dpy (chk-displayp dpy))
  138.        (n_props (make-bytev 4))
  139.        (c-atomap (xlistproperties* dpy window n_props))
  140.        (limit (fx* (mref-integer n_props 0) 4))
  141.        (atomap (c->extend c-atomap)))
  142.       (iterate loop ((i 0))
  143.            (if (eq? i limit)
  144.            (begin (xfree c-atomap)
  145.               '())
  146.            (cons (mref-integer atomap i) (loop (+ i 4)))))))
  147.  
  148. ;;; Chapter 6.
  149.  
  150. (define-foreign xlistfonts*
  151.   ("XListFonts" (in rep/c-pointer) (in rep/string) (in rep/integer) 
  152.         (in rep/extend))
  153.   rep/pointer)
  154.  
  155.  
  156. (define-foreign xfreefontnames* 
  157.   ("XFreeFontNames" (in rep/c-pointer))
  158.   ignore)
  159.  
  160. (define (YLISTFONTS dpy pattern maxnames)
  161.     (let* ((dpy (chk-displayp dpy))
  162.        (pattern (chk-string pattern))
  163.        (count (make-bytev 4))
  164.        (charpap (xlistfonts* dpy pattern maxnames count))
  165.        (result (string-array->string-list charpap (mref-integer count 0))))
  166.       (xfreefontnames* charpap)
  167.       result))
  168.  
  169. (define-foreign xlistfontswithinfo* 
  170.   ("XListFontsWithInfo" (in rep/c-pointer)
  171.             (in rep/string)
  172.             (in rep/integer)
  173.             (in rep/extend)
  174.             (in rep/extend))
  175.   rep/pointer)
  176.  
  177. (define-foreign xfreefontinfo* 
  178.   ("XFreeFontInfo" (in rep/c-pointer) (in rep/c-pointer) (in rep/integer))
  179.   ignore)
  180.  
  181. (define (YLISTFONTSWITHINFO dpy pattern maxnames)
  182.     (let* ((dpy (chk-displayp dpy))
  183.        (pattern (chk-string pattern))
  184.        (count_ret (make-bytev 4))
  185.        (info_ret (make-bytev 4))
  186.        (charap (xlistfontswithinfo* dpy pattern maxnames count_ret
  187.                info_ret))
  188.        (count (mref-integer count_ret 0))
  189.        (info (mref-pointer info_ret 0))
  190.        (fonts (array-struct->list info
  191.                       count
  192.                       make-xfontstruct))
  193.        (names (string-array->string-list charap count)))
  194.       (xfreefontinfo* charap info count)
  195.       (map cons names fonts)))
  196.  
  197. (define-foreign xsetfontpath* 
  198.   ("XSetFontPath" (in rep/c-pointer) (in rep/c-pointer) (in rep/integer))
  199.   ignore)
  200.  
  201. (define (YSETFONTPATH dpy directories)
  202.     (let ((dpy (chk-displayp dpy))
  203.       (charap (string-list->string-array directories)))
  204.      (xsetfontpath* dpy charap (length directories))
  205.      directories))
  206.  
  207. (define-foreign xgetfontpath* 
  208.   ("XGetFontPath" (in rep/c-pointer) (in rep/extend)) rep/pointer)
  209.  
  210. (define-foreign xfreefontpath* 
  211.   ("XFreeFontPath" (in rep/c-pointer))
  212.   ignore)
  213.  
  214. (define (YGETFONTPATH dpy)
  215.     (let* ((dpy (chk-displayp dpy))
  216.        (npaths (make-bytev 4))
  217.        (charap (xgetfontpath* dpy npaths))
  218.        (result (string-array->string-list charap (mref-integer npaths 0))))
  219.       (xfreefontpath* charap)
  220.       result))
  221.  
  222. ;;; Chapter 7.
  223.  
  224. (define-foreign xlistinstalledcolormaps* 
  225.   ("XListInstalledColormaps" (in rep/c-pointer) (in rep/integer) (in rep/extend))
  226.   rep/pointer)
  227.  
  228. (define (YLISTINSTALLEDCOLORMAPS dpy window)
  229.     (let* ((dpy (chk-displayp dpy))
  230.        (n_ret (make-bytev 4))
  231.        (cmapaddr (xlistinstalledcolormaps* dpy window n_ret))
  232.        (result (iterate loop ((x (mref-integer n_ret 0)) 
  233.                   (cmapaddr (c->extend cmapaddr)))
  234.             (if (eq? x 0)
  235.                 '()
  236.                 (cons (mref-integer cmapaddr 0)
  237.                   (loop (fx- x 1) (make-pointer cmapaddr 0)))))))
  238.       (xfree cmapaddr)
  239.       result))
  240. #|
  241. (define (FAMILY-ADDRESS->XHOSTADDRESS family address)
  242.     (let ((array (string-append (make-string 12) address)))
  243.      (c-int-set! array 0 family)
  244.      (c-int-set! array 4 (string-length address))
  245.      (c-unsigned-set! array 8 ((lap (x) (_TSCP (PLUS (INT x) 3))) array))
  246.      array))
  247. |#
  248. ;;; Chapter 8.
  249.  
  250. (define-foreign xnextevent* 
  251.   ("XNextEvent" (in rep/pointer) (in rep/extend)) ignore)
  252.  
  253. (define (YNEXTEVENT dpy event)
  254.     (xnextevent* (chk-displayp dpy) (chk-xeventp event))
  255.     '#f)
  256.  
  257. (define-foreign unix_select 
  258.   ("select" (in rep/integer) (in rep/extend)
  259.         (in rep/c-pointer) (in rep/c-pointer) (in rep/extend))
  260.   rep/integer)
  261.  
  262. (define (YSELECT dpy . ports-time)
  263.     (let* ((timeval (make-bytev 8))
  264.        (ports (iterate loop ((x ports-time))
  265.                (cond ((fx> (length x) 2)
  266.                   (cons (car x) (loop (cdr x))))
  267.                  (else
  268.                   (set-mref-integer! timeval 0 (car x))
  269.                   (set-mref-integer! timeval 4 (cadr x))
  270.                   '()))))
  271.        (nfds 0)
  272.        (file->result (make-vector 32 '#f))
  273.        (read-mask (let* ((mask (make-bytev 4))
  274.                  (xfile (xconnectionnumber dpy)))
  275.                 (vset file->result xfile dpy)
  276.                 (set-mref-integer! mask 0
  277.                 (iterate loop ((ports ports)
  278.                        (mask (fixnum-ashl 1 xfile))
  279.                        (maxfile xfile))
  280.                      (if ports
  281.                      (let* ((port (car ports))
  282.                         (x (iob-xeno (port->iob    port))))
  283.                            (vset file->result x port)
  284.                            (loop (cdr ports)
  285.                              (fixnum-logior 
  286.                               (fixnum-ashl 1 x)
  287.                               mask)
  288.                              (max x maxfile)))
  289.                      (block (set nfds (fx+ maxfile 1))
  290.                         mask))))
  291.                 mask)))
  292.       
  293.       (cond ((not (zero? (xpending dpy))) dpy)
  294.         ((iterate loop ((ports ports))
  295.               (if ports
  296.               (if (char-ready? (car ports))
  297.                   (car ports)
  298.                   (loop (cdr ports)))
  299.               '#f)))
  300.         (else (let* ((nfiles (unix_select nfds read-mask 0 0 timeval))
  301.                  (bits (mref-integer read-mask 0)))
  302.                 (if (positive? nfiles)
  303.                 (iterate loop ((mask 1) (index 0))
  304.                      (if (not (zero? (fixnum-logand bits mask)))
  305.                      (vref file->result index)
  306.                      (loop (fx+ mask mask) (fx+ index 1))))
  307.                 '#f))))))
  308.  
  309. (define-foreign xgetmotionevents* 
  310.   ("XGetMotionEvents" (in rep/c-pointer) (in rep/integer)
  311.               (in rep/integer) (in rep/integer)
  312.               (in rep/extend))
  313.   rep/pointer)
  314.  
  315. (define (YGETMOTIONEVENTS dpy window start stop)
  316.     (let* ((dpy (chk-displayp dpy))
  317.        (nevents_ret (make-bytev 4))
  318.        (rawptr (xgetmotionevents* dpy window start stop nevents_ret))
  319.        (ptr (c->extend rawptr))
  320.        (result (iterate loop ((x (mref-integer nevents_ret 0)) (i 0))
  321.             (if (eq? x 0)
  322.                 '()
  323.                 (cons (list (mref-integer ptr i)
  324.                     (mref-16-s ptr (fx+ i 4))
  325.                     (mref-16-s ptr (fx+ i 6)))
  326.                   (loop (fx- x 1) (fx+ i 6)))))))
  327.       (xfree rawptr)
  328.       result))
  329.  
  330. ;;; Chapter 9.
  331.  
  332. (define-foreign xsetstandardproperties* 
  333.   ("XSetStandardProperties" (in rep/c-pointer)
  334.                 (in rep/integer)
  335.                 (in rep/string)
  336.                 (in rep/string)
  337.                 (in rep/integer)
  338.                 (in rep/c-pointer)
  339.                 (in rep/integer)
  340.                 (in rep/c-pointer))
  341.   ignore)
  342.  
  343.  
  344. (define (YSETSTANDARDPROPERTIES dpy window name icon_string icon_pixmap
  345.         commands hints)
  346.     (let ((dpy (chk-displayp dpy))
  347.       (name (chk-string name))
  348.       (icon_string (chk-string icon_string))
  349.       (commands (string-list->string-array commands))
  350.       (hints (chk-xsizehintsp hints)))
  351.      (xsetstandardproperties* dpy window name icon_string icon_pixmap
  352.          commands (length commands) hints)
  353.      '#f))
  354.  
  355. (define-foreign xfetchname* 
  356.   ("XFetchName" (in rep/c-pointer) (in rep/integer) (in rep/extend))
  357.   rep/integer)
  358.  
  359. (define (YFETCHNAME dpy window)
  360.     (let* ((dpy (chk-displayp dpy))
  361.        (name_ret (make-bytev 4))
  362.        (status (xfetchname* dpy window name_ret))
  363.        (name (mref-pointer name_ret 0))
  364.        (string (if (or (eq? status 0) (eq? name 0))
  365.                '#f
  366.                (asciz->string name))))
  367.       (if string (xfree name))
  368.       string))
  369.  
  370. (define-foreign xgeticonname* 
  371.   ("XGetIconName" (in rep/c-pointer) (in rep/integer) (in rep/extend))
  372.   rep/integer)
  373.  
  374. (define (YGETICONNAME dpy window)
  375.     (let* ((dpy (chk-displayp dpy))
  376.        (name_ret (make-bytev 4))
  377.        (status (xgeticonname* dpy window name_ret))
  378.        (name (mref-pointer name_ret 0))
  379.        (string (if (or (eq? status 0) (eq? name 0))
  380.                '#f
  381.                (asciz->string name))))
  382.       (if string (xfree name))
  383.       string))
  384.  
  385. (define-foreign xsetcommand* 
  386.   ("XSetCommand" (in rep/c-pointer) (in rep/integer) 
  387.          (in rep/c-pointer) (rep/integer))
  388.   ignore)
  389.  
  390. (define (YSETCOMMAND dpy window commands)
  391.     (let ((dpy (chk-displayp dpy))
  392.       (commands-array (string-list->string-array commands)))
  393.      (xsetcommand* dpy window commands-array (length commands))
  394.      '#f))
  395.  
  396. (define-foreign xgetwmhints* 
  397.   ("XGetWMHints" (in rep/c-pointer) (in rep/integer))
  398.   rep/pointer)
  399.  
  400. (define (YGETWMHINTS dpy window)
  401.     (let* ((dpy (chk-displayp dpy))
  402.        (ptr (xgetwmhints* dpy window))
  403.        (result (if (eq? ptr 0)
  404.                '#f
  405.                (copy-ptr-to-struct ptr (make-xwmhints)))))
  406.       (if result (xfree ptr))
  407.       result))
  408.  
  409. (define-foreign xseticonsizes* 
  410.   ("XSetIconSizes" (in rep/c-pointer) (in rep/integer)
  411.            (in rep/c-pointer) (in rep/integer))
  412.   ignore)
  413.  
  414. (define (YSETICONSIZES dpy window iconsizelist)
  415.     (let* ((dpy (chk-displayp dpy))
  416.        (arrayp (struct-list->bytev iconsizelist chk-xiconsizep)))
  417.       (xseticonsizes* dpy window arrayp (length iconsizelist))
  418.       '#f))
  419.  
  420. (define-foreign xgeticonsizes* 
  421.   ("XGetIconSizes" (in rep/c-pointer) (in rep/integer)
  422.            (in rep/extend) (in rep/extend))
  423.   rep/integer)
  424.            
  425.   
  426.  
  427.  
  428. (define (YGETICONSIZES dpy window)
  429.     (let* ((dpy (chk-displayp dpy))
  430.        (array_ret (make-bytev 4))
  431.        (count_ret (make-bytev 4))
  432.        (status (xgeticonsizes* dpy window array_ret count_ret))
  433.        (array (mref-pointer array_ret 0))
  434.        (count (mref-integer count_ret 0))
  435.        (result (if (neq? status 0)
  436.                (array-struct->list array count make-xiconsize)
  437.                '#f)))
  438.       (if result (xfree array))
  439.       result))
  440.  
  441. (define-foreign xsetclasshint* 
  442.   ("XSetClassHint" (in rep/c-pointer) (in rep/integer) (in rep/c-extend))
  443.   ignore)
  444.  
  445. (define (YSETCLASSHINT dpy window name-class)
  446.     (let* ((dpy (chk-displayp dpy))
  447.        (hint (string-list->string-array  name-class)))
  448.       (xsetclasshint* dpy window hint)
  449.       '#f))
  450.  
  451. (define-foreign xgetclasshint* 
  452.   ("XGetClassHint" (in rep/c-pointer) (in rep/integer) (in rep/extend))
  453.   rep/integer)
  454.  
  455. (define (YGETCLASSHINT dpy window)
  456.     (let* ((dpy (chk-displayp dpy))
  457.        (hint_ret (make-bytev 4))
  458.        (status (xgetclasshint* dpy window hint_ret))
  459.        (hint (mref-pointer hint_ret 0)))
  460.       (if (eq? status 0)
  461.           '#f
  462.           (let ((result (string-array->string-list hint 2)))
  463.            (xfree (mref-pointer hint 0))
  464.            (xfree (mref-pointer hint 4))
  465.            result))))
  466.  
  467. ;;; Chapter 10
  468.  
  469.  
  470. (define-foreign xlookupstring*
  471.   ("XLookupString" (in rep/extend) (in rep/string) (in rep/integer)
  472.            (in rep/c-pointer) (in rep/c-pointer)) rep/integer)
  473.     
  474.  
  475. (define XLOOKUPSTRING-BUFFER (make-string 50))
  476.  
  477.  
  478. (define (YLOOKUPSTRING event . opt)
  479.     (let* ((event (chk-xeventp event))
  480.        (keysym (if (and opt (car opt)) (make-bytev 4) 0))
  481.        (status (if (= (length opt) 2) (chk-xcomposestatusp (cadr opt)) 0))
  482.        (result (xlookupstring* event xlookupstring-buffer 50 keysym
  483.                status)))
  484.       (if opt
  485.           (list (substring xlookupstring-buffer 0 result)
  486.               (if (car opt) (mref-integer keysym 0) '#f))
  487.           (substring xlookupstring-buffer 0 result))))
  488.       
  489. ;;; Write-around for XrmGetResource in the standard Scheme->C X library:
  490. (DEFINE-FOREIGN XRMGETRESOURCE*
  491.                 ("XrmGetResource" (IN REP/C-POINTER)
  492.                                   (IN REP/string)
  493.                                   (IN REP/string)
  494.                                   (IN REP/EXTEND)
  495.                                   (IN REP/EXTEND))
  496.                 REP/INTEGER)
  497.  
  498.  
  499. (DEFINE
  500.   (XRMGETRESOURCE DB NAME_STR CLASS_STR)
  501.   (LET*
  502.       ((DB (CHK-XRMdatabase DB))
  503.        (NAME_STR
  504.         (IF
  505.          (STRING? name_str)
  506.          (string->asciz! name_str)
  507.          (ERROR "Argument is incorrect type: ~s" name_str)))
  508.        (CLASS_STR
  509.         (IF
  510.          (STRING? class_str)
  511.          (string->asciz! class_str)
  512.          (ERROR "Argument is incorrect type: ~s" class_str)))
  513.        (PTYPE_STR (MAKE-bytev 4))
  514.        (PVALUE (MAKE-xrmvalue))
  515.        (RETURN-VALUE (XRMGETRESOURCE* DB NAME_STR CLASS_STR PTYPE_STR
  516. (chk-xrmvalueptr PVALUE))))
  517.     (return
  518.      RETURN-VALUE
  519.      (mref-pointer PTYPE_STR 0)
  520.      pvalue)))
  521.  
  522. (define (YrmGetResource db name_str class_str)
  523.   (receive (return-code type-chara rmvalue) (XrmGetResource db name_str class_str)
  524.     (if (zero? return-code)
  525.         '()
  526.         (let ((type-string (asciz->string type-chara)))
  527.           (if (equal? type-string "String")
  528.               (asciz->string (chk-charap (xrmvalue-addr rmvalue)))
  529.               (error "Unimplemented resource type in YrmGetResource"
  530. type-string))))))
  531.  
  532. (define (YrmMergeDatabases new into)
  533.   (let ((into-p (make-bytev 4)))
  534.     (set-mref-pointer! into-p 0 (chk-xrmdatabase into))
  535.     (XrmMergeDatabases new (type/value->pointer 'xrmdatabasep into-p))
  536.     (type/value->pointer 'xrmdatabase (mref-pointer into-p 0))))
  537.  
  538.