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

Contents of /src/clx/sockcl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.4 - (hide annotations)
Wed Jun 17 18:22:46 2009 UTC (4 years, 10 months ago) by rtoy
Branch: MAIN
CVS Tags: sparc-tramp-assem-base, post-merge-intl-branch, intl-branch-working-2010-02-19-1000, unicode-string-buffer-impl-base, release-20b-pre1, release-20b-pre2, unicode-string-buffer-base, sparc-tramp-assem-2010-07-19, amd64-dd-start, intl-2-branch-base, GIT-CONVERSION, cross-sol-x86-merged, intl-branch-working-2010-02-11-1000, RELEASE_20b, release-20a-base, cross-sol-x86-base, snapshot-2010-12, snapshot-2010-11, snapshot-2011-09, snapshot-2011-06, snapshot-2011-07, snapshot-2011-04, snapshot-2011-02, snapshot-2011-03, snapshot-2011-01, pre-merge-intl-branch, snapshot-2010-05, snapshot-2010-04, snapshot-2010-07, snapshot-2010-06, snapshot-2010-01, snapshot-2010-03, snapshot-2010-02, snapshot-2010-08, cross-sol-x86-2010-12-20, intl-branch-2010-03-18-1300, RELEASE_20a, release-20a-pre1, snapshot-2009-11, snapshot-2009-12, cross-sparc-branch-base, intl-branch-base, snapshot-2009-08, snapshot-2009-07, HEAD
Branch point for: cross-sparc-branch, RELEASE-20B-BRANCH, unicode-string-buffer-branch, sparc-tramp-assem-branch, RELEASE-20A-BRANCH, amd64-dd-branch, unicode-string-buffer-impl-branch, intl-branch, cross-sol-x86-branch, intl-2-branch
Changes since 1.3: +1 -1 lines
Merge portable-clx (2009-06-16) to main branch.  Tested by running
src/contrib/games/feebs and hemlock which works (in non-unicode
builds).
1 ram 1.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 fgilham 1.3 #+cmu
27 rtoy 1.4 (ext:file-comment "$Id: sockcl.lisp,v 1.4 2009/06/17 18:22:46 rtoy Rel $")
28 fgilham 1.3
29 ram 1.1 (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