/[cmucl]/src/clx/sockcl.lisp
ViewVC logotype

Contents of /src/clx/sockcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.3 - (show annotations)
Tue Aug 21 15:49:28 2007 UTC (6 years, 8 months ago) by fgilham
Branch: MAIN
CVS Tags: merged-unicode-utf16-extfmt-2009-06-11, unicode-utf16-extfmt-2009-03-27, snapshot-2007-09, snapshot-2008-08, snapshot-2008-09, sse2-packed-2008-11-12, snapshot-2008-05, snapshot-2008-06, snapshot-2008-07, snapshot-2008-01, snapshot-2008-02, snapshot-2008-03, sse2-base, sse2-packed-base, release-19f-pre1, snapshot-2008-12, snapshot-2008-11, release-19e, release-19d, unicode-utf16-sync-2008-12, label-2009-03-16, release-19f-base, merge-sse2-packed, merge-with-19f, unicode-snapshot-2009-05, unicode-snapshot-2009-06, unicode-utf16-sync-2008-07, unicode-utf16-sync-2008-09, unicode-utf16-extfmts-sync-2008-12, snapshot-2008-04, unicode-utf16-sync-label-2009-03-16, RELEASE_19f, unicode-utf16-char-support-2009-03-26, unicode-utf16-char-support-2009-03-25, unicode-utf16-extfmts-pre-sync-2008-11, snapshot-2008-10, unicode-utf16-sync-2008-11, release-19e-pre1, release-19e-pre2, label-2009-03-25, sse2-checkpoint-2008-10-01, sse2-merge-with-2008-11, sse2-merge-with-2008-10, unicode-utf16-extfmt-2009-06-11, unicode-utf16-string-support, release-19e-base, unicode-utf16-base, portable-clx-base, snapshot-2007-12, snapshot-2007-10, snapshot-2007-11, snapshot-2009-02, snapshot-2009-01, snapshot-2009-05, snapshot-2009-04
Branch point for: RELEASE-19F-BRANCH, portable-clx-branch, sse2-packed-branch, unicode-utf16-branch, release-19e-branch, sse2-branch, unicode-utf16-extfmt-branch
Changes since 1.2: +3 -0 lines
Telent CLX import
1 ;;; -*- Mode: LISP; Syntax: Common-lisp; Package: XLIB; Base: 10; Lowercase: Yes -*-
2
3 ;;;; Server Connection for kcl and ibcl
4
5 ;;; Copyright (C) 1987, 1989 Massachussetts Institute of Technology
6 ;;;
7 ;;; Permission is granted to any individual or institution to use, copy,
8 ;;; modify, and distribute this software, provided that this complete
9 ;;; copyright and permission notice is maintained, intact, in all copies and
10 ;;; supporting documentation.
11 ;;;
12 ;;; Massachussetts Institute of Technology provides this software "as is"
13 ;;; without express or implied warranty.
14 ;;;
15
16 ;;; Adapted from code by Roman Budzianowski - Project Athena/MIT
17
18 ;;; make-two-way-stream is probably not a reasonable thing to do.
19 ;;; A close on a two way stream probably does not close the substreams.
20 ;;; I presume an :io will not work (maybe because it uses 1 buffer?).
21 ;;; There should be some fast io (writes and reads...).
22
23 ;;; Compile this file with compile-file.
24 ;;; Load it with (si:faslink "sockcl.o" "socket.o -lc")
25
26 #+cmu
27 (ext:file-comment "$Id: sockcl.lisp,v 1.3 2007/08/21 15:49:28 fgilham Exp $")
28
29 (in-package :xlib)
30
31 ;;; The cmpinclude.h file does not have this type definition from
32 ;;; <kcldistribution>/h/object.h. We include it here so the
33 ;;; compile-file will work without figuring out where the distribution
34 ;;; directory is located.
35 ;;;
36 (CLINES "
37 enum smmode { /* stream mode */
38 smm_input, /* input */
39 smm_output, /* output */
40 smm_io, /* input-output */
41 smm_probe, /* probe */
42 smm_synonym, /* synonym */
43 smm_broadcast, /* broadcast */
44 smm_concatenated, /* concatenated */
45 smm_two_way, /* two way */
46 smm_echo, /* echo */
47 smm_string_input, /* string input */
48 smm_string_output, /* string output */
49 smm_user_defined /* for user defined */
50 };
51 ")
52
53 #-akcl
54 (CLINES "
55 struct stream {
56 short t, m;
57 FILE *sm_fp; /* file pointer */
58 object sm_object0; /* some object */
59 object sm_object1; /* some object */
60 int sm_int0; /* some int */
61 int sm_int1; /* some int */
62 short sm_mode; /* stream mode */
63 /* of enum smmode */
64 };
65 ")
66
67
68 ;;;; Connect to the server.
69
70 ;;; A lisp string is not a reasonable type for C, so copy the characters
71 ;;; out and then call connect_to_server routine defined in socket.o
72
73 (CLINES "
74 int
75 konnect_to_server(host,display)
76 object host; /* host name */
77 int display; /* display number */
78 {
79 int fd; /* file descriptor */
80 int i;
81 char hname[BUFSIZ];
82 FILE *fout, *fin;
83
84 if (host->st.st_fillp > BUFSIZ - 1)
85 too_long_file_name(host);
86 for (i = 0; i < host->st.st_fillp; i++)
87 hname[i] = host->st.st_self[i];
88 hname[i] = '\\0'; /* doubled backslash for lisp */
89
90 fd = connect_to_server(hname,display);
91
92 return(fd);
93 }
94 ")
95
96 (defentry konnect-to-server (object int) (int "konnect_to_server"))
97
98
99 ;;;; Make a one-way stream from a file descriptor.
100
101 (CLINES "
102 object
103 konnect_stream(host,fd,flag,elem)
104 object host; /* not really used */
105 int fd; /* file descriptor */
106 int flag; /* 0 input, 1 output */
107 object elem; /* 'string-char */
108 {
109 struct stream *stream;
110 char *mode; /* file open mode */
111 FILE *fp; /* file pointer */
112 enum smmode smm; /* lisp mode (a short) */
113 vs_mark;
114
115 switch(flag){
116 case 0:
117 smm = smm_input;
118 mode = \"r\";
119 break;
120 case 1:
121 smm = smm_output;
122 mode = \"w\";
123 break;
124 default:
125 FEerror(\"konnect_stream : wrong mode\");
126 }
127
128 fp = fdopen(fd,mode);
129
130 if (fp == NULL) {
131 stream = Cnil;
132 vs_push(stream);
133 } else {
134 stream = alloc_object(t_stream);
135 stream->sm_mode = (short)smm;
136 stream->sm_fp = fp;
137 stream->sm_object0 = elem;
138 stream->sm_object1 = host;
139 stream->sm_int0 = stream->sm.sm_int1 = 0;
140 vs_push(stream);
141 setbuf(fp, alloc_contblock(BUFSIZ));
142 }
143 vs_reset;
144 return(stream);
145 }
146 ")
147
148 (defentry konnect-stream (object int int object) (object "konnect_stream"))
149
150
151 ;;;; Open an X stream
152
153 (defun open-socket-stream (host display)
154 (when (not (and (typep host 'string) ; sanity check the arguments
155 (typep display 'fixnum)))
156 (error "Host ~s or display ~s are bad." host display))
157
158 (let ((fd (konnect-to-server host display))) ; get a file discriptor
159 (if (< fd 0)
160 NIL
161 (let ((stream-in (konnect-stream host fd 0 'string-char)) ; input
162 (stream-out (konnect-stream host fd 1 'string-char))) ; output
163 (if (or (null stream-in) (null stream-out))
164 (error "Could not make i/o streams for fd ~d." fd))
165 (make-two-way-stream stream-in stream-out))
166 )))

  ViewVC Help
Powered by ViewVC 1.1.5