Artifact bdc67c6426a42838d5b1f7ec62a6ed7e75947b587d96031a5ab93d58e78bb994:
- Executable file
r36/cslbase/sockets.c
— part of check-in
[f2fda60abd]
at
2011-09-02 18:13:33
on branch master
— Some historical releases purely for archival purposes
git-svn-id: https://svn.code.sf.net/p/reduce-algebra/code/trunk/historical@1375 2bfe0521-f11c-4a00-b80e-6202646ff360 (user: arthurcnorman@users.sourceforge.net, size: 11299) [annotate] [blame] [check-ins using] [more...]
/* sockets.c Copyright (C) 1995 NAG Ltd */ /* * Functions to support operations on sockets for AXIOM: basically just * interfaces to some of the functions in libspad.a (sockio-c.c). We * assume that all integers returned as Lisp objects can be represented * as CCL fixnums, i.e. do not lie in the range +/-(2^28 .. 2^32-1). * * Version 1.0 September 1995 * * Author: Mike Dewar * */ /* Signature: 1cca4b86 27-Jan-1997 */ #include <stdarg.h> #include <sys/types.h> #include <string.h> #ifdef __WATCOMC__ #include <dos.h> #endif #include "machine.h" #include "tags.h" #include "cslerror.h" #include "externs.h" #include "arith.h" #if defined(UNIX) #define RealSockets #endif #if defined(__linux__) void glnag(char * s, char * t) { } #endif #ifdef FLEX Lisp_Object Linit_lm(Lisp_Object nil, Lisp_Object dummy) { static int first_time =0; extern void glnag(char *prod_code, char *user_opts); extern void rlnag(); /* If glnag fails it calls displmmsg and exits */ if (first_time == 0) { #if defined(__alpha) glnag("AXDAU21NA",""); #elif defined(__sparc) && defined(sparc) glnag("AXSU421NA",""); #elif defined(__sparc) glnag("AXSOL21NA",""); #elif defined(__hp9000s800) glnag("AXH9721NA",""); #elif defined(__sgi) && defined(__mips) && __mips==1 glnag("AXSG521NA",""); #elif defined(__sgi) && defined(__mips) && __mips==3 glnag("AXSG621NA",""); #elif defined(_AIX) glnag("AXIB621NA",""); #elif defined(__linux__) glnag("AXLUX21NA",""); #elif defined(WINDOWS_NT) glnag("AXW3222NA",""); #ifndef CWIN rlnag(); #endif #endif first_time = 1; } return onevalue(fixnum_of_int(1)); } #ifdef CWIN #undef exit #endif void displmmsg(int unlicensed, char *message) { /* term_printf only handles strings less than 256 characters long */ if (strlen(message) > 255) { char *line; line = strtok(message,"\n"); term_printf("%s\n",line); while ((line=strtok(NULL,"\n")) != NULL) term_printf("%s\n",line); } else term_printf("%s\n",message); #ifdef CWIN ensure_screen(); #endif if (unlicensed > 0) { term_printf("+++ This copy of AXIOM is unlicensed ... exiting.\n"); #ifdef CWIN ensure_screen(); #endif sleep(10); my_exit(2); } } Lisp_Object MS_CDECL Lclose_lm(Lisp_Object nil, int32 nargs, ...) { #ifdef WINDOWS_NT extern void rlnag(); argcheck(nargs,0,"close-lm"); rlnag(); #endif return nil; } #else Lisp_Object Linit_lm(Lisp_Object nil, Lisp_Object dummy) { return onevalue(fixnum_of_int(1)); } #endif #ifdef RealSockets /* These are all in sockio-c.c */ extern int32 open_server(char *server_name); extern int32 sock_get_int(int32 purpose); extern int32 sock_send_int(int32 purpose, int32 val); extern char *sock_get_string_buf(int32 purpose, char *buf, int32 buf_len); extern int32 sock_send_string_len(int32 purpose, char *str, int32 len); extern double sock_get_float(int32 purpose); extern int32 sock_send_float(int32 purpose, double num); extern int32 sock_send_wakeup(int32 purpose); extern int32 server_switch(); extern int32 flush_stdout(); extern int32 sock_send_signal(int purpose, int sig); extern int32 print_line(char *s); /* Utility function to test for CCL integers and turn them into C ints */ int32 ccl2int(Lisp_Object i, char *fcn) { if (is_fixnum(i)) return (int_of_fixnum(i)); else if (is_numbers(i) && is_bignum(i) ) return (thirty_two_bits(i)); else return aerror(fcn); } Lisp_Object LopenServer(Lisp_Object nil, Lisp_Object server) { if (!(is_vector(server) && type_of_header(vechdr(server)) == TYPE_STRING) ) return aerror("open_server"); else return onevalue(fixnum_of_int(open_server(&celt(server,0)))); } Lisp_Object LsockGetInt(Lisp_Object nil, Lisp_Object purpose) { return onevalue(fixnum_of_int(sock_get_int(ccl2int(purpose,"sock_get_int")))); } Lisp_Object LsockSendInt(Lisp_Object nil, Lisp_Object purpose, Lisp_Object val) { return onevalue(fixnum_of_int( sock_send_int(ccl2int(purpose,"sock_send_int"), ccl2int(val,"sock_send_int")))); } Lisp_Object MS_CDECL LsockGetStringBuf(Lisp_Object nil, int nargs, ...) { va_list args; Lisp_Object purpose, buf, buf_length; argcheck(nargs,3,"sock_get_string_buf"); va_start(args,nargs); purpose = va_arg(args, Lisp_Object); buf = va_arg(args, Lisp_Object); buf_length = va_arg(args, Lisp_Object); va_end(args); if (!(is_vector(buf) && type_of_header(vechdr(buf)) == TYPE_STRING) ) aerror("sock_get_string_buf"); else sock_get_string_buf(ccl2int(purpose,"sock_get_string_buf"), &celt(buf,0), ccl2int(buf_length,"sock_get_string_buf") ); /* AXIOM always ignores the return value */ return buf; } Lisp_Object MS_CDECL LsockSendStringLen(Lisp_Object nil, int nargs, ...) { va_list args; Lisp_Object purpose, buf, buf_length; argcheck(nargs,3,"sock_send_string_len"); va_start(args,nargs); purpose = va_arg(args, Lisp_Object); buf = va_arg(args, Lisp_Object); buf_length = va_arg(args, Lisp_Object); va_end(args); if (!(is_vector(buf) && type_of_header(vechdr(buf)) == TYPE_STRING) ) return aerror("sock_send_string_len"); else return onevalue(fixnum_of_int( sock_send_string_len(ccl2int(purpose,"sock_send_string_len"), &celt(buf,0), ccl2int(buf_length,"sock_send_string_len") ))); } Lisp_Object LsockGetFloat(Lisp_Object nil, Lisp_Object purpose) { return onevalue(make_boxfloat(sock_get_float( ccl2int(purpose,"sock_get_float")), TYPE_DOUBLE_FLOAT) ); } Lisp_Object LsockSendFloat(Lisp_Object nil, Lisp_Object purpose, Lisp_Object val) { if (!is_number(val)) aerror("sock_send_float"); return onevalue(fixnum_of_int(sock_send_float( ccl2int(purpose,"sock_send_float"), float_of_number(val) ))); } Lisp_Object LsockSendWakeup(Lisp_Object nil, Lisp_Object purpose) { return onevalue(fixnum_of_int(sock_send_wakeup(ccl2int(purpose, "sock_send_wakeup")))); } Lisp_Object MS_CDECL LserverSwitch(Lisp_Object nil, int nargs, ...) { argcheck(nargs, 0, "server_switch"); return onevalue(fixnum_of_int(server_switch())); } Lisp_Object MS_CDECL LflushStdout(Lisp_Object nil, int nargs, ...) { argcheck(nargs, 0, "flush_stdout"); return onevalue(fixnum_of_int(flush_stdout())); } Lisp_Object LsockSendSignal(Lisp_Object nil,Lisp_Object purpose,Lisp_Object sig) { return onevalue(fixnum_of_int(sock_send_signal( ccl2int(purpose,"sock_send_signal"), ccl2int(sig,"sock_send_signal")))); } Lisp_Object LprintLine(Lisp_Object nil, Lisp_Object buf) { if (!(is_vector(buf) && type_of_header(vechdr(buf)) == TYPE_STRING) ) return aerror("print_line"); else return onevalue(fixnum_of_int(print_line(&celt(buf,0)))); } #endif /* UNIX */ #if defined(__i386__) || defined(__i486__)|| defined(__i386)||defined(__i586) static signed char plus_infinity[8]= {0x0,0x0,0x0,0x0,0x0,0x0,0xf0,0x7f}, minus_infinity[8]={0x0,0x0,0x0,0x0,0x0,0x0,0xf0,0xff}, NANQ[8]= {0x0,0x0,0x0,0x0,0x0,0x0,0xf8,0xff}; #elif defined(__alpha) static signed char plus_infinity[8]= {0x0,0x0,0x0,0x0,0x0,0x0,0xf0,0x7f}, minus_infinity[8]={0x0,0x0,0x0,0x0,0x0,0x0,0xf0,0xff}, NANQ[8]= {0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x7f}; #else static signed char plus_infinity[8]= {0x7f,0xf0,0x0,0x0,0x0,0x0,0x0,0x0}, minus_infinity[8]={0xff,0xf0,0x0,0x0,0x0,0x0,0x0,0x0}, NANQ[8]= {0x7f,0xff,0xff,0xff,0xff,0xff,0xff,0xff}; #endif Lisp_Object MS_CDECL LplusInfinity(Lisp_Object nil, int nargs, ...) { argcheck(nargs, 0, "plus_infinity"); return onevalue(make_boxfloat(*(double *)plus_infinity,TYPE_DOUBLE_FLOAT)); } Lisp_Object MS_CDECL LminusInfinity(Lisp_Object nil, int nargs, ...) { argcheck(nargs, 0, "minus_infinity"); return onevalue(make_boxfloat(*(double *)minus_infinity,TYPE_DOUBLE_FLOAT)); } Lisp_Object MS_CDECL Lnanq(Lisp_Object nil, int nargs, ...) { argcheck(nargs, 0, "NANQ"); return onevalue(make_boxfloat(*(double *)NANQ,TYPE_DOUBLE_FLOAT)); } Lisp_Object sock_error1(Lisp_Object nil, Lisp_Object arg) { return aerror0("Attempt to call socket function on non-unix platform"); } Lisp_Object sock_error2(Lisp_Object nil, Lisp_Object arg1, Lisp_Object arg2) { return aerror0("Attempt to call socket function on non-unix platform"); } Lisp_Object MS_CDECL sock_error0(Lisp_Object nil, int nargs, ...) { return aerror0("Attempt to call socket function on non-unix platform"); } setup_type const socket_setup[] = { #ifdef FLEX {"init-lm", Linit_lm, too_many_1, wrong_no_1}, {"close-lm", wrong_no_0a, wrong_no_0b, Lclose_lm}, #else {"init-lm", Linit_lm, too_many_1, wrong_no_1}, {"close-lm", sock_error1, sock_error2, sock_error0}, #endif #ifdef RealSockets {"open_server", LopenServer, too_many_1, wrong_no_1}, {"sock_get_int", LsockGetInt, too_many_1, wrong_no_1}, {"sock_send_int", too_few_2, LsockSendInt, wrong_no_2}, {"sock_get_string_buf", wrong_no_na, wrong_no_nb, LsockGetStringBuf}, {"sock_send_string_len", wrong_no_na, wrong_no_nb, LsockSendStringLen}, {"sock_get_float", LsockGetFloat, too_many_1, wrong_no_1}, {"sock_send_float", too_few_2, LsockSendFloat, wrong_no_2}, {"sock_send_wakeup", LsockSendWakeup, too_many_1, wrong_no_1}, {"server_switch", wrong_no_0a, wrong_no_0b, LserverSwitch}, {"flush_stdout", wrong_no_0a, wrong_no_0b, LflushStdout}, {"sock_send_signal", too_few_2, LsockSendSignal, wrong_no_2}, {"print_line", LprintLine, too_many_1, wrong_no_1}, #else {"open_server", sock_error1, sock_error2, sock_error0}, {"sock_get_int", sock_error1, sock_error2, sock_error0}, {"sock_send_int", sock_error1, sock_error2, sock_error0}, {"sock_get_string_buf", sock_error1, sock_error2, sock_error0}, {"sock_send_string_len", sock_error1, sock_error2, sock_error0}, {"sock_get_float", sock_error1, sock_error2, sock_error0}, {"sock_send_float", sock_error1, sock_error2, sock_error0}, {"sock_send_wakeup", sock_error1, sock_error2, sock_error0}, {"server_switch", sock_error1, sock_error2, sock_error0}, {"flush_stdout", sock_error1, sock_error2, sock_error0}, {"sock_send_signal", sock_error1, sock_error2, sock_error0}, {"print_line", sock_error1, sock_error2, sock_error0}, #endif {"plus_infinity", wrong_no_0a, wrong_no_0b, LplusInfinity}, {"minus_infinity", wrong_no_0a, wrong_no_0b, LminusInfinity}, {"NANQ", wrong_no_0a, wrong_no_0b, Lnanq}, {NULL, 0, 0, 0} };