This file is indexed.

/usr/lib/clisp-2.49/clx/new-clx/resource.lisp is in clisp-module-clx 1:2.49-9ubuntu1.

This file is owned by root:root, with mode 0o644.

The actual contents of the file can be viewed below.

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
;;; -*- Mode: LISP; Package:XLIB; Syntax:COMMON-LISP; Base:10; Lowercase:T -*-

;; RESOURCE - Lisp version of XLIB's Xrm resource manager

;;;
;;;			 TEXAS INSTRUMENTS INCORPORATED
;;;				  P.O. BOX 2909
;;;			       AUSTIN, TEXAS 78769
;;;
;;; Copyright (C) 1987 Texas Instruments Incorporated.
;;;
;;; Permission is granted to any individual or institution to use, copy, modify,
;;; and distribute this software, provided that this complete copyright and
;;; permission notice is maintained, intact, in all copies and supporting
;;; documentation.
;;;
;;; Texas Instruments Incorporated provides this software "as is" without
;;; express or implied warranty.
;;;

(require "clx")
(in-package :xlib)
(declaim (declaration clx-values))

;; The C version of this uses a 64 entry hash table at each entry.
;; Small hash tables lose in Lisp, so we do linear searches on lists.

(defstruct (resource-database (:copier nil) (:predicate nil)
			      (:constructor make-resource-database-internal))
  (name nil :type stringable :read-only t)
  (value nil)
  (tight nil :type list) ;; List of resource-database
  (loose nil :type list) ;; List of resource-database
  )

(defmethod print-object ((database resource-database) (stream stream))
  (declare (type resource-database database))
  (print-unreadable-object (database stream :type t)
    (write-string (string (resource-database-name database)) stream)
    (when (resource-database-value database)
      (write-string " " stream)
      (prin1 (resource-database-value database) stream))))

;; The value slot of the top-level resource-database structure is used for a
;; time-stamp.

(defun make-resource-database ()
  ;; Make a resource-database with initial timestamp of 0
  (make-resource-database-internal :name "Top-Level" :value 0))

(defun resource-database-timestamp (database)
  (declare (type resource-database database))
  (resource-database-value database))

(defun incf-resource-database-timestamp (database)
  ;; Increment the timestamp
  (declare (type resource-database database))
  (let ((timestamp (resource-database-value database)))
    (setf (resource-database-value database)
	  (if (= timestamp most-positive-fixnum)
	      most-negative-fixnum
	    (1+ timestamp)))))

;; DEBUG FUNCTION  (not exported)
(defun print-db (entry &optional (level 0) type)
  ;; Debug function to print a resource database
  (format t "~%~v@t~s~:[~; *~]~@[ Value ~s~]"
	  level
	  (resource-database-name entry)
	  (eq type 'loose)
	  (resource-database-value entry))
  (when (resource-database-tight entry)
    (dolist (tight (resource-database-tight entry))
      (print-db tight (+ 2 level) 'tight)))
  (when (resource-database-loose entry)
    (dolist (loose (resource-database-loose entry))
      (print-db loose (+ 2 level) 'loose))))

;; DEBUG FUNCTION
#+comment
(defun print-search-table (table)
  (terpri)
  (dolist (dbase-list table)
    (format t "~%~s" dbase-list)
    (dolist (db dbase-list)
      (print-db db)
      (dolist (dblist table)
	(unless (eq dblist dbase-list)
	  (when (member db dblist)
	    (format t "  duplicate at ~s" db))))
      )))

;;
;; If this is true, resource symbols will be compared in a case-insensitive
;; manner, and converting a resource string to a keyword will uppercaseify it.
;;
(defparameter *uppercase-resource-symbols* nil)

(defun resource-key (stringable)
  ;; Ensure STRINGABLE is a keyword.
  (declare (type stringable stringable))
  (etypecase stringable
    (symbol
      (if (keywordp (the symbol stringable))
	  stringable
	  (kintern (symbol-name (the symbol stringable)))))
    (string
      (if *uppercase-resource-symbols*
	  (setq stringable (string-upcase
			    (the string stringable))))
      (kintern (the string stringable)))))

(defun stringable-equal (a b)
  ;; Compare two stringables.
  ;; Ignore case when comparing to a symbol.
  (declare (type stringable a b))
  (declare (clx-values generalized-boolean))
  (etypecase a
    (string
      (etypecase b
	(string
	  (string= (the string a) (the string b)))
	(symbol
	  (if *uppercase-resource-symbols*
	      (string-equal (the string a)
			    (the string (symbol-name (the symbol b))))
	      (string= (the string a)
		       (the string (symbol-name (the symbol b))))))))
    (symbol
      (etypecase b
	(string
	  (if *uppercase-resource-symbols*
	      (string-equal (the string (symbol-name (the symbol a)))
			    (the string b))
	      (string= (the string (symbol-name (the symbol a)))
		       (the string b))))
	(symbol
	  (string= (the string (symbol-name (the symbol a)))
		   (the string (symbol-name (the symbol b)))))))))


;;;-----------------------------------------------------------------------------
;;; Add/delete resource

(defun add-resource (database name-list value)
  ;; name-list is a list of either strings or symbols. If a symbol,
  ;; case-insensitive comparisons will be used, if a string,
  ;; case-sensitive comparisons will be used.  The symbol '* or
  ;; string "*" are used as wildcards, matching anything or nothing.
  (declare (type resource-database database)
	   (type (clx-list stringable) name-list)
	   (type t value))
  (unless value (error "Null resource values are ignored"))
  (incf-resource-database-timestamp database)
  (do* ((list name-list (cdr list))
	(name (car list) (car list))
	(node database)
	(loose-p nil))
       ((endp list)
	(setf (resource-database-value node) value))
    ;; Key is the first name that isn't *
    (if (stringable-equal name "*")
	(setq loose-p t)
      ;; find the entry associated with name
      (progn
	(do ((entry (if loose-p
			(resource-database-loose node)
		      (resource-database-tight node))
		    (cdr entry)))
	    ((endp entry)
	     ;; Entry not found - create a new one
	     (setq entry (make-resource-database-internal :name name))
	     (if loose-p
		 (push entry (resource-database-loose node))
	       (push entry (resource-database-tight node)))
	     (setq node entry))
	  (when (stringable-equal name (resource-database-name (car entry)))
	    ;; Found entry - use it
	    (return (setq node (car entry)))))
	(setq loose-p nil)))))


(defun delete-resource (database name-list)
  (declare (type resource-database database)
	   (type list name-list))
  (incf-resource-database-timestamp database)
  (delete-resource-internal database name-list))

(defun delete-resource-internal (database name-list)
  (declare (type resource-database database)
	   (type (clx-list stringable) name-list))
  (do* ((list name-list (cdr list))
	(string (car list) (car list))
	(node database)
	(loose-p nil))
       ((endp list) nil)
    ;; Key is the first name that isn't *
    (if (stringable-equal string "*")
	(setq loose-p t)
      ;; find the entry associated with name
      (progn
	(do* ((first-entry (if loose-p
			       (resource-database-loose node)
			     (resource-database-tight node)))
	      (entry-list first-entry (cdr entry-list))
	      (entry (car entry-list) (car entry-list)))
	     ((endp entry-list)
	      ;; Entry not found - exit
	      (return-from delete-resource-internal nil))
	  (when (stringable-equal string (resource-database-name entry))
	    (when (cdr list) (delete-resource-internal entry (cdr list)))
	    (when (and (null (resource-database-loose entry))
		       (null (resource-database-tight entry)))
	      (if loose-p
		  (setf (resource-database-loose node)
			(delete entry (resource-database-loose node)
				:test #'eq :count 1))
		(setf (resource-database-tight node)
		      (delete entry (resource-database-tight node)
			      :test #'eq :count 1))))
	    (return-from delete-resource-internal t)))
	(setq loose-p nil)))))

;;;-----------------------------------------------------------------------------
;;; Get Resource

(defun get-resource (database value-name value-class full-name full-class)
  ;; Return the value of the resource in DATABASE whose partial name
  ;; most closely matches (append full-name (list value-name)) and
  ;;                      (append full-class (list value-class)).
  (declare (type resource-database database)
	   (type stringable value-name value-class)
	   (type (clx-list stringable) full-name full-class))
  (declare (clx-values value))
  (let ((names (append full-name (list value-name)))
	(classes (append full-class (list value-class))))
    (let* ((result (get-entry (resource-database-tight database)
			      (resource-database-loose database)
			      names classes)))
      (when result
	(resource-database-value result)))))

(defun get-entry-lookup (table name names classes)
  (declare (type list table names classes)
	   (type stringable name))
  (dolist (entry table)
    (declare (type resource-database entry))
    (when (stringable-equal name (resource-database-name entry))
      (if (null (cdr names))
	  (return entry)
	(let ((result (get-entry (resource-database-tight entry)
				 (resource-database-loose entry)
				 (cdr names) (cdr classes))))
	  (declare (type (or null resource-database) result))
	  (when result
	    (return result)
	    ))))))

(defun get-entry (tight loose names classes &aux result)
  (declare (type list tight loose names classes))
  (let ((name (car names))
	(class (car classes)))
    (declare (type stringable name class))
    (cond ((and tight
		(get-entry-lookup tight name names classes)))
	  ((and loose
		(get-entry-lookup loose name names classes)))
	  ((and tight
		(not (stringable-equal name class))
		(get-entry-lookup tight class names classes)))
	  ((and loose
		(not (stringable-equal name class))
		(get-entry-lookup loose class names classes)))
	  (loose
	   (loop
	     (pop names) (pop classes)
	     (unless (and names classes) (return nil))
	     (setq name (car names)
		   class (car classes))
	     (when (setq result (get-entry-lookup loose name names classes))
	       (return result))
	     (when (and (not (stringable-equal name class))
			(setq result
			      (get-entry-lookup loose class names classes)))
	       (return result))
	     )))))


;;;-----------------------------------------------------------------------------
;;; Get-resource with search-table

(defun get-search-resource (table name class)
  ;; (get-search-resource (get-search-table database full-name full-class)
  ;;                      value-name value-class)
  ;; is equivalent to
  ;; (get-resource database value-name value-class full-name full-class)
  ;; But since most of the work is done by get-search-table,
  ;; get-search-resource is MUCH faster when getting several resources with
  ;; the same full-name/full-class
  (declare (type list table)
	   (type stringable name class))
  (let ((do-class (and class (not (stringable-equal name class)))))
    (dolist (dbase-list table)
      (declare (type list dbase-list))
      (dolist (dbase dbase-list)
	(declare (type resource-database dbase))
	(when (stringable-equal name (resource-database-name dbase))
	  (return-from get-search-resource
	    (resource-database-value dbase))))
      (when do-class
	(dolist (dbase dbase-list)
	  (declare (type resource-database dbase))
	  (when (stringable-equal class (resource-database-name dbase))
	    (return-from get-search-resource
	      (resource-database-value dbase))))))))

(defvar *get-table-result*)

(defun get-search-table (database full-name full-class)
  ;; Return a search table for use with get-search-resource.
  (declare (type resource-database database)
	   (type (clx-list stringable) full-name full-class))
  (declare (clx-values value))
  (let* ((tight (resource-database-tight database))
	 (loose (resource-database-loose database))
	 (result (cons nil nil))
	 (*get-table-result* result))
    (declare (type list tight loose)
	     (type cons result))
    (when (or tight loose)
      (when full-name
	(get-tables tight loose full-name full-class))

      ;; Pick up bindings of the form (* name). These are the elements of
      ;; top-level loose without further tight/loose databases.
      ;;
      ;; (Hack: these bindings belong in ANY search table, so recomputing them
      ;; is a drag.  True fix involves redesigning entire lookup
      ;; data-structure/algorithm.)
      ;;
      (let ((universal-bindings
	      (remove nil loose :test-not #'eq
		      :key #'(lambda (database)
			       (or (resource-database-tight database)
				   (resource-database-loose database))))))
	(when universal-bindings
	  (setf (cdr *get-table-result*) (list universal-bindings)))))
    (cdr result)))

(defun get-tables-lookup (dbase name names classes)
  (declare (type list dbase names classes)
	   (type stringable name))
  #-clx-debugging
  (declare (optimize speed))
  (dolist (entry dbase)
    (declare (type resource-database entry))
    (when (stringable-equal name (resource-database-name entry))
      (let ((tight (resource-database-tight entry))
	    (loose (resource-database-loose entry)))
	(declare (type list tight loose))
	(when (or tight loose)
	  (if (cdr names)
	      (get-tables tight loose (cdr names) (cdr classes))
	    (when tight
	      (let ((result *get-table-result*))
		;; Put tight at end of *get-table-result*
		(setf (cdr result)
		      (setq *get-table-result* (cons tight nil))))))
	  (when loose
	    (let ((result *get-table-result*))
	      ;; Put loose at end of *get-table-result*
	      (setf (cdr result)
		    (setq *get-table-result* (cons loose nil))))))))))

(defun get-tables (tight loose names classes)
  (declare (type list tight loose names classes))
  (let ((name (car names))
	(class (car classes)))
    (declare (type stringable name class))
    (when tight
      (get-tables-lookup tight name names classes))
    (when loose
      (get-tables-lookup loose name names classes))
    (when (and tight (not (stringable-equal name class)))
      (get-tables-lookup tight class names classes))
    (when (and loose (not (stringable-equal name class)))
      (get-tables-lookup loose class names classes))
    (when loose
      (loop
	(pop names) (pop classes)
	(unless (and names classes) (return nil))
	(setq name (car names)
	      class (car classes))
	(get-tables-lookup loose name names classes)
	(unless (stringable-equal name class)
	  (get-tables-lookup loose class names classes))
	))))


;;;-----------------------------------------------------------------------------
;;; Utility functions

(defun map-resource (database function &rest args)
  ;; Call FUNCTION on each resource in DATABASE.
  ;; FUNCTION is called with arguments (name-list value . args)
  (declare (type resource-database database)
	   (type (function (list t &rest t) t) function)
	   (dynamic-extent function)
	   (dynamic-extent args))
  (declare (clx-values nil))
  (labels ((map-resource-internal (database function args name)
	     (declare (type resource-database database)
		      (type (function (list t &rest t) t) function)
		      (type list name)
		      (dynamic-extent function))
	     (let ((tight (resource-database-tight database))
		   (loose (resource-database-loose database)))
	       (declare (type list tight loose))
	       (dolist (resource tight)
		 (declare (type resource-database resource))
		 (let ((value (resource-database-value resource))
		       (name (append
			       name
			       (list (resource-database-name resource)))))
		   (if value
		       (apply function name value args)
		     (map-resource-internal resource function args name))))
	       (dolist (resource loose)
		 (declare (type resource-database resource))
		 (let ((value (resource-database-value resource))
		       (name (append
			       name
			       (list "*" (resource-database-name resource)))))
		   (if value
		       (apply function name value args)
		     (map-resource-internal resource function args name)))))))
    (map-resource-internal database function args nil)))

(defun merge-resources (database with-database)
  (declare (type resource-database database with-database))
  (declare (clx-values resource-database))
  (map-resource
    database
    #'(lambda (name value database)
	(add-resource database name value))
    with-database)
  with-database)

(defun char-memq (key char)
  ;; Used as a test function for POSITION
  (declare (type base-char char))
  (member char key))

(defmacro resource-with-open-file ((stream pathname &rest options) &body body)
  ;; Private WITH-OPEN-FILE, which, when pathname is a stream, uses it as the
  ;; stream
  (let ((abortp (gensym))
	(streamp (gensym)))
    `(let* ((,abortp t)
	    (,streamp (streamp pathname))
	    (,stream (if ,streamp pathname (open ,pathname ,@options))))
       (unwind-protect
	   (multiple-value-prog1
	     (progn ,@body)
	     (setq ,abortp nil))
	 (unless ,streamp
	   (close stream :abort ,abortp))))))

(defun read-resources (database pathname &key key test test-not)
  ;; Merges resources from a file in standard X11 format with DATABASE.
  ;; KEY is a function used for converting value-strings, the default is
  ;; identity.  TEST and TEST-NOT are predicates used for filtering
  ;; which resources to include in the database.  They are called with
  ;; the name and results of the KEY function.
  (declare (type resource-database database)
	   (type (or pathname string stream) pathname)
	   (type (or null (function (string) t)) key)
	   (type (or null (function (list t) generalized-boolean))
                 test test-not))
  (declare (clx-values resource-database))
  (resource-with-open-file (stream pathname)
    (loop
      (let ((string (read-line stream nil :eof)))
	(declare (type (or string keyword) string))
	(when (eq string :eof) (return database))
	(let* ((end (length string))
	       (i (position '(#\tab #\space) string
			    :test-not #'char-memq :end end))
	       (term nil))
	  (declare (type array-index end)
		   (type (or null array-index) i term))
	  (when i ;; else blank line
	    (case (char string i)
	      (#\! nil)  ;; Comment - skip
	      ;;(#.(card8->char 0) nil) ;; terminator for C strings - skip
	      (#\#       ;; Include
	       (setq term (position '(#\tab #\space) string :test #'char-memq
				    :start i :end end))
	       (when (string-equal string "#INCLUDE" :start1 i :end1 term)
		 (let ((path (merge-pathnames
			      (string-trim '(#\tab #\space #\")
					   (subseq string (1+ term)))
			      (truename stream))))
		   (read-resources database path
				   :key key :test test :test-not test-not))))
	      (otherwise
	       (multiple-value-bind (name-list value)
		   (parse-resource string i end)
		 (when name-list
		   (when key (setq value (funcall key value)))
		   (when
		     (cond (test (funcall test name-list value))
			   (test-not (not (funcall test-not name-list value)))
			   (t t))
		     (add-resource database name-list value))))))))))))

(defun parse-resource (string &optional (start 0) end)
  ;; Parse a resource specfication string into a list of names and a value
  ;; string
  (declare (type string string)
	   (type array-index start)
	   (type (or null array-index) end))
  (declare (clx-values name-list value))
  (do ((i start)
       (end (or end (length string)))
       (term)
       (name-list))
      ((>= i end))
    (declare (type array-index end)
	     (type (or null array-index) i term))
    (setq term (position '(#\. #\* #\:) string
			 :test #'char-memq :start i :end end))
    (case (and term (char string term))
      ;; Name seperator
      (#\. (when (> term i)
	     (push (subseq string i term) name-list)))
      ;; Wildcard seperator
      (#\* (when (> term i)
	     (push (subseq string i term) name-list))
	   (push '* name-list))
      ;; Value separator
      (#\:
       (push (subseq string i term) name-list)
       (return
	 (values
	   (nreverse name-list)
	   (string-trim '(#\tab #\space) (subseq string (1+ term))))))
      (otherwise
	(return
	  (values
	    (nreverse name-list)
	    (subseq string i term)))))
    (setq i (1+ term))))

(defun write-resources (database pathname &key write test test-not)
  ;; Write resources to PATHNAME in the standard X11 format.
  ;; WRITE is a function used for writing values, the default is #'princ
  ;; TEST and TEST-NOT are predicates used for filtering which resources
  ;; to include in the database.  They are called with the name and value.
  (declare (type resource-database database)
	   (type (or pathname string stream) pathname)
	   (type (or null (function (string stream) t)) write)
	   (type (or null (function (list t) generalized-boolean))
                 test test-not))
  (resource-with-open-file (stream pathname :direction :output)
    (map-resource
      database
      #'(lambda (name-list value stream write test test-not)
	  (when
	    (cond (test (funcall test name-list value))
		  (test-not (not (funcall test-not name-list value)))
		  (t t))
	    (let ((previous (car name-list)))
	      (princ previous stream)
	      (dolist (name (cdr name-list))
		(unless (or (stringable-equal name "*")
			    (stringable-equal previous "*"))
		  (write-char #\. stream))
		(setq previous name)
		(princ name stream)))
	    (write-string ":	" stream)
	    (funcall write value stream)
	    (terpri stream)))
      stream (or write #'princ) test test-not))
  database)

(defun wm-resources (database window &key key test test-not)
  ;; Takes the resources associated with the RESOURCE_MANAGER property
  ;; of WINDOW (if any) and merges them with DATABASE.
  ;; KEY is a function used for converting value-strings, the default is
  ;; identity.  TEST and TEST-NOT are predicates used for filtering
  ;; which resources to include in the database.  They are called with
  ;; the name and results of the KEY function.
  (declare (type resource-database database)
	   (type window window)
	   (type (or null (function (string) t)) key)
	   (type (or null (function (list t) generalized-boolean))
                 test test-not))
  (declare (clx-values resource-database))
  (let ((string (get-property window :RESOURCE_MANAGER :type :STRING
			      :result-type 'string
			      :transform #'xlib::card8->char)))
    (when string
      (with-input-from-string (stream string)
	(read-resources database stream
			:key key :test test :test-not test-not)))))

(defun set-wm-resources (database window &key write test test-not)
  ;; Sets the resources associated with the RESOURCE_MANAGER property
  ;; of WINDOW.
  ;; WRITE is a function used for writing values, the default is #'princ
  ;; TEST and TEST-NOT are predicates used for filtering which resources
  ;; to include in the database.  They are called with the name and value.
  (declare (type resource-database database)
	   (type window window)
	   (type (or null (function (string stream) t)) write)
	   (type (or null (function (list t) generalized-boolean))
                 test test-not))
  (xlib::set-string-property
    window :RESOURCE_MANAGER
    (with-output-to-string (stream)
      (write-resources database stream :write write
		       :test test :test-not test-not))))

(defun root-resources (screen &key database key test test-not)
  "Returns a resource database containing the contents of the root window
   RESOURCE_MANAGER property for the given SCREEN. If SCREEN is a display,
   then its default screen is used. If an existing DATABASE is given, then
   resource values are merged with the DATABASE and the modified DATABASE is
   returned.

   TEST and TEST-NOT are predicates for selecting which resources are
   read.  Arguments are a resource name list and a resource value. The KEY
   function, if given, is called to convert a resource value string to the
   value given to TEST or TEST-NOT."

  (declare (type (or screen display) screen)
	   (type (or null resource-database) database)
	   (type (or null (function (string) t)) key)
	   (type (or null (function (list t) generalized-boolean)) test test-not)
	   (clx-values resource-database))
  (let* ((screen (if (typep screen 'display)
		     (display-default-screen screen)
		   screen))
	 (window (screen-root screen))
	 (database (or database (make-resource-database))))
    (wm-resources database window :key key :test test :test-not test-not)
    database))

(defun set-root-resources (screen &key test test-not (write #'princ) database)
  "Changes the contents of the root window RESOURCE_MANAGER property for the
   given SCREEN. If SCREEN is a display, then its default screen is used.

   TEST and TEST-NOT are predicates for selecting which resources from the
   DATABASE are written.  Arguments are a resource name list and a resource
   value.  The WRITE function is used to convert a resource value into a
   string stored in the property."

  (declare (type (or screen display) screen)
	(type (or null resource-database) database)
	(type (or null (function (list t) generalized-boolean)) test test-not)
	(type (or null (function (string stream) t)) write)
	(clx-values resource-database))
  (let* ((screen (if (typep screen 'display)
		     (display-default-screen screen)
		   screen))
	 (window (screen-root screen)))
    (set-wm-resources database window
		      :write write :test test :test-not test-not)
    database))

(defsetf root-resources (screen &key test test-not (write #'princ))(database)
  `(set-root-resources
    ,screen :test ,test :test-not ,test-not :write ,write :database ,database))

(defun default-resources-pathname ()
  (make-pathname :name ".Xdefaults" :defaults (user-homedir-pathname)))
(defun resources-pathname ()
  (or (let ((string (ext:getenv "XENVIRONMENT")))
	(and string (pathname string)))
     (make-pathname
      :name (ext:string-concat
             ".Xdefaults-" (let ((s (machine-instance))) ; hostname
                             (subseq s 0 (position #\Space s))))
      :defaults (user-homedir-pathname))))

(defun initialize-resource-database (display)
  ;; This function is (supposed to be) equivalent to the Xlib initialization
  ;; code.
  (declare (type display display))
  (let ((rdb (make-resource-database))
	(rootwin (screen-root (car (display-roots display)))))
    ;; First read the server defaults if present, otherwise from the default
    ;; resource file
    (if (get-property rootwin :RESOURCE_MANAGER)
	(wm-resources rdb rootwin)
      (let ((path (default-resources-pathname)))
	(when (and path (probe-file path))
	  (read-resources rdb path))))
    ;; Next read from the resources file
    (let ((path (resources-pathname)))
      (when (and path (probe-file path))
	(read-resources rdb path)))
    ;; do we need to record the database?
    ;; (setf (display-xdefaults display) rdb)
    ))