/[cmucl]/src/motif/lisp/main.lisp
ViewVC logotype

Contents of /src/motif/lisp/main.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.2 - (show annotations)
Mon Oct 31 04:54:48 1994 UTC (19 years, 5 months ago) by ram
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, double-double-array-base, post-merge-intl-branch, release-19b-pre1, release-19b-pre2, merged-unicode-utf16-extfmt-2009-06-11, double-double-init-sparc-2, unicode-utf16-extfmt-2009-03-27, double-double-base, snapshot-2007-09, snapshot-2007-08, snapshot-2008-08, snapshot-2008-09, ppc_gencgc_snap_2006-01-06, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2007-05, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, intl-branch-working-2010-02-19-1000, snapshot-2006-11, snapshot-2006-10, double-double-init-sparc, snapshot-2006-12, unicode-string-buffer-impl-base, sse2-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, RELEASE_18d, sse2-packed-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, snapshot-2003-10, snapshot-2004-10, release-18e-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, intl-2-branch-base, snapshot-2004-08, snapshot-2004-09, remove_negative_zero_not_zero, snapshot-2007-01, snapshot-2007-02, snapshot-2004-05, snapshot-2004-06, snapshot-2004-07, release-19e, release-19d, GIT-CONVERSION, double-double-init-ppc, release-19c, dynamic-extent-base, unicode-utf16-sync-2008-12, LINKAGE_TABLE, release-19c-base, cross-sol-x86-merged, label-2009-03-16, release-19f-base, PRE_LINKAGE_TABLE, merge-sse2-packed, mod-arith-base, sparc_gencgc_merge, merge-with-19f, snapshot-2004-12, snapshot-2004-11, intl-branch-working-2010-02-11-1000, RELEASE_18a, RELEASE_18b, RELEASE_18c, unicode-snapshot-2009-05, unicode-snapshot-2009-06, amd64-merge-start, ppc_gencgc_snap_2005-12-17, double-double-init-%make-sparc, unicode-utf16-sync-2008-07, release-18e-pre2, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, prm-before-macosx-merge-tag, cold-pcl-base, RELEASE_20b, snapshot-2008-04, snapshot-2003-11, snapshot-2005-07, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, snapshot-2007-03, release-20a-base, cross-sol-x86-base, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, release-19a-base, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, sparc_gencgc, snapshot-2007-04, snapshot-2010-12, snapshot-2010-11, unicode-utf16-sync-2008-11, snapshot-2007-07, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2007-06, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, snapshot-2003-12, release-19a-pre1, release-19a-pre3, release-19a-pre2, pre-merge-intl-branch, release-19a, UNICODE-BASE, double-double-array-checkpoint, double-double-reader-checkpoint-1, release-19d-base, release-19e-pre1, double-double-irrat-end, release-19e-pre2, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, release-19d-pre2, release-19d-pre1, snapshot-2010-08, release-18e, double-double-init-checkpoint-1, double-double-reader-base, label-2009-03-25, snapshot-2005-03, release-19b-base, cross-sol-x86-2010-12-20, double-double-init-x86, sse2-checkpoint-2008-10-01, intl-branch-2010-03-18-1300, snapshot-2005-11, double-double-sparc-checkpoint-1, snapshot-2004-04, sse2-merge-with-2008-11, sse2-merge-with-2008-10, snapshot-2005-10, RELEASE_20a, snapshot-2005-12, release-20a-pre1, snapshot-2005-01, snapshot-2009-11, snapshot-2009-12, unicode-utf16-extfmt-2009-06-11, portable-clx-import-2009-06-16, unicode-utf16-string-support, release-19c-pre1, cross-sparc-branch-base, release-19e-base, intl-branch-base, double-double-irrat-start, snapshot-2005-06, snapshot-2005-05, snapshot-2005-04, ppc_gencgc_snap_2005-05-14, snapshot-2005-02, unicode-utf16-base, portable-clx-base, snapshot-2005-09, snapshot-2005-08, lisp-executable-base, snapshot-2009-08, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-07, snapshot-2009-05, snapshot-2009-04, snapshot-2006-02, snapshot-2006-03, release-18e-pre1, snapshot-2006-01, snapshot-2006-06, snapshot-2006-07, snapshot-2006-04, snapshot-2006-05, pre-telent-clx, snapshot-2006-08, snapshot-2006-09, HEAD
Branch point for: release-19b-branch, double-double-reader-branch, double-double-array-branch, mod-arith-branch, RELEASE-19F-BRANCH, portable-clx-branch, sparc_gencgc_branch, cross-sparc-branch, RELEASE-20B-BRANCH, RELENG_18, unicode-string-buffer-branch, sparc-tramp-assem-branch, dynamic-extent, UNICODE-BRANCH, release-19d-branch, ppc_gencgc_branch, sse2-packed-branch, lisp-executable, RELEASE-20A-BRANCH, amd64-dd-branch, double-double-branch, unicode-string-buffer-impl-branch, intl-branch, release-18e-branch, cold-pcl, unicode-utf16-branch, cross-sol-x86-branch, release-19e-branch, sse2-branch, release-19a-branch, release-19c-branch, intl-2-branch, unicode-utf16-extfmt-branch
Changes since 1.1: +3 -1 lines
Fix headed boilerplate.
1 ;;;; -*- Mode: Lisp ; Package: Toolkit -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;; This code was written as part of the CMU Common Lisp project at
5 ;;; Carnegie Mellon University, and has been placed in the public domain.
6 ;;;
7 (ext:file-comment
8 "$Header: /tiger/var/lib/cvsroots/cmucl/src/motif/lisp/main.lisp,v 1.2 1994/10/31 04:54:48 ram Rel $")
9 ;;;
10 ;;; **********************************************************************
11 ;;;
12 ;;; Written by Michael Garland
13 ;;;
14 ;;; Various high-level interface functions for use with the Motif toolkit.
15 ;;;
16
17 (in-package "TOOLKIT")
18
19
20
21 ;;; These are just randomly placed here at the moment.
22 (defconstant string-default-charset ""
23 "The default character set used in building Motif compound strings.")
24
25 (defun font-list-add-component (flist charset font-spec)
26 (let ((font (xlib:open-font *x-display* font-spec)))
27 (xlib:display-force-output *x-display*)
28 (font-list-add flist font charset)))
29
30 (defun build-simple-font-list (name font-spec)
31 (let ((font (xlib:open-font *x-display* font-spec)))
32 (xlib:display-force-output *x-display*)
33 (font-list-create font name)))
34
35
36 (defun build-font-list (specs)
37 (let* ((first (car specs))
38 (flist (build-simple-font-list (car first) (cadr first)))
39 (specs (cdr specs)))
40 (dolist (spec specs)
41 (setf flist (font-list-add-component flist (car spec) (cadr spec))))
42 flist))
43
44
45
46 ;;;; Some standard useful callbacks
47
48 (defun quit-application ()
49 "Standard function for quitting an X Toolkit application."
50 (quit-server)
51 (close-motif-connection *motif-connection*)
52 (throw 'lisp::top-level-catcher nil))
53
54 (defun quit-application-callback (widget call-data)
55 "Standard callback for quitting an X Toolkit application."
56 (declare (ignore widget call-data))
57 (quit-application))
58
59 (defun destroy-callback (widget call-data &rest targets)
60 (declare (ignore call-data))
61 (if targets
62 (dolist (target targets)
63 (destroy-widget target))
64 (destroy-widget widget)))
65
66 (defun manage-callback (widget call-data &rest targets)
67 (declare (ignore call-data))
68 (if targets
69 (apply #'manage-children targets)
70 (manage-child widget)))
71
72 (defun unmanage-callback (widget call-data &rest targets)
73 (declare (ignore call-data))
74 (if targets
75 (apply #'unmanage-children targets)
76 (unmanage-child widget)))
77
78 (defun popup-callback (widget call-data kind &rest targets)
79 (declare (ignore call-data))
80 (if targets
81 (dolist (target targets)
82 (popup target kind))
83 (popup widget kind)))
84
85 (defun popdown-callback (widget call-data &rest targets)
86 (declare (ignore call-data))
87 (if targets
88 (dolist (target targets)
89 (popdown target))
90 (popdown widget)))
91
92
93
94 ;;;; A convenient (and CLM compatible) way to start Motif applications
95
96 (defun run-motif-application (init-function
97 &key
98 (init-args nil)
99 (application-class "Lisp")
100 (application-name "lisp")
101 (server-host *default-server-host*)
102 (display *default-display*)
103 (sync-clx *debug-mode*))
104 (declare (ignore sync-clx))
105 (let ((connection (open-motif-connection server-host display
106 application-name
107 application-class)))
108 (with-motif-connection (connection)
109 (apply init-function init-args))
110 connection))

  ViewVC Help
Powered by ViewVC 1.1.5