aboutsummaryrefslogtreecommitdiff
path: root/src
diff options
context:
space:
mode:
Diffstat (limited to 'src')
-rw-r--r--src/ChangeLog21
-rw-r--r--src/boot/ast.boot4
-rw-r--r--src/boot/translator.boot59
-rw-r--r--src/include/cfuns.h1
-rw-r--r--src/include/sockio.h44
-rw-r--r--src/interp/br-saturn.boot22
-rw-r--r--src/interp/cfuns.lisp3
-rw-r--r--src/interp/server.boot17
-rw-r--r--src/interp/sockio.lisp15
-rw-r--r--src/interp/sys-os.boot6
-rw-r--r--src/lib/cfuns-c.c27
-rw-r--r--src/lib/sockio-c.c66
-rw-r--r--src/lisp/core.lisp.in37
13 files changed, 219 insertions, 103 deletions
diff --git a/src/ChangeLog b/src/ChangeLog
index e9cb3f3a..f25b4744 100644
--- a/src/ChangeLog
+++ b/src/ChangeLog
@@ -1,3 +1,24 @@
+2008-04-29 Gabriel Dos Reis <gdr@cs.tamu.edu>
+
+ * lisp/core.lisp.in: Export %ByteArray and makeByteArray.
+ (CONCAT): Tdiy.
+ * lib/sockio-c.c: Tidy.
+ * lib/cfuns-c.c (oa_getenv): Define.
+ * interp/sys-os.boot (getEnv): Import.
+ (sockGetString): Tidy.
+ * interp/sockio.lisp (sockGetString): Remove GCL's defentry.
+ * interp/server.boot (serverReadLine): sockGetString now takes
+ only one argument.
+ * interp/br-saturn.boot (operationIsNiladicConstructor): New.
+ (operationIsConstructor): Likewise.
+ (displayDomainOp): Use them.
+ * include/cfuns.h (oa_getenv): Declare.
+ * include/sockio.h: Tidy.
+ * boot/translator.boot (needsStableReference?): New.
+ (coerceToNativeType): Likewise.
+ (prepareArgumentsForNativeCall): Likewise.
+ (genImportDeclaration): Use them.
+
2008-04-25 Gabriel Dos Reis <gdr@cs.tamu.edu>
* sman/spadclient.c: Cleanup.
diff --git a/src/boot/ast.boot b/src/boot/ast.boot
index 9026ea7a..6f240fd2 100644
--- a/src/boot/ast.boot
+++ b/src/boot/ast.boot
@@ -1131,7 +1131,7 @@ bfCreateDef x==
if null cdr x
then
f:=car x
- ["SETQ",f,["LIST",["QUOTE",f]]]
+ ["DEFPARAMETER",f,["LIST",["QUOTE",f]]]
else
a:=[bfGenSymbol() for i in cdr x]
["DEFUN",car x,a,["CONS",["QUOTE",car x],["LIST",:a]]]
@@ -1211,5 +1211,5 @@ bootSymbol s ==
nativeType t ==
null t => t
- t' := ASSOC(coreSymbol t,$NativeTypeTable) => bootSymbol rest t'
+ t' := ASSOC(coreSymbol t,$NativeTypeTable) => rest t'
fatalError CONCAT('"unsupported native type: ", SYMBOL_-NAME t)
diff --git a/src/boot/translator.boot b/src/boot/translator.boot
index e4957c02..1f906a2f 100644
--- a/src/boot/translator.boot
+++ b/src/boot/translator.boot
@@ -310,6 +310,40 @@ shoeConsoleTrees s ==
shoeAddComment l==
strconc('"; ", first l)
+++ True if objects of type native type `t' are sensible to GC.
+needsStableReference? t ==
+ %hasFeature KEYWORD::GCL => false --
+ %hasFeature KEYWORD::SBCL or %hasFeature KEYWORD::CLISP =>
+ t = "pointer" or t = "buffer"
+ true -- don't know; conservatively answer `yes'.
+
+
+++ coerce argument `a' to native type `t', in preparation for
+++ a call to a native functions.
+coerceToNativeType(a,t) ==
+ %hasFeature KEYWORD::GCL => a
+ %hasFeature KEYWORD::SBCL =>
+ t = "buffer" => [bfColonColon("SB-SYS","VECTOR-SAP"),a]
+ t = "string" => a -- 'string's are automatically converted.
+ needsStableReference? t =>
+ fatalError '"don't know how to coerce argument for native type"
+ a
+ %hasFeature KEYWORD::CLISP =>
+ needsStableReference? t =>
+ fatalError '"don't know how to coerce argument for native type"
+ a
+ fatalError '"don't know how to coerce argument for native type"
+
+++ filter out arguments that need stable references during call
+++ to native function, and convert all arguments as necessary.
+prepareArgumentsForNativeCall(args,types) ==
+ unstableArgs := [a for a in args for t in types
+ | needsStableReference? t]
+ preparedArgs := [coerceToNativeType(a,t)
+ for a in args for t in types]
+ [unstableArgs,preparedArgs]
+
+
++ Generate an import declaration for `op' as equivalent of the
++ foreign signature `sig'. Here, `foreign' operationally means that
++ the entity is from the C language world.
@@ -317,15 +351,29 @@ genImportDeclaration(op, sig) ==
sig isnt ["Signature", op', m] => coreError '"invalid signature"
m isnt ["Mapping", t, s] => coreError '"invalid function type"
if not null s and SYMBOLP s then s := [s]
+
+ -- we don't deal with non-trivial return values (yet)
+ needsStableReference? t =>
+ fatalError '"non trivial return type for native function"
+
%hasFeature KEYWORD::GCL =>
[["DEFENTRY", op, [nativeType x for x in s],
[nativeType t, SYMBOL_-NAME op']]]
+
args := [GENSYM() for x in s]
%hasFeature KEYWORD::SBCL =>
+ [unstableArgs,newArgs] := prepareArgumentsForNativeCall(args,s)
+ null unstableArgs =>
+ [["DEFUN",op,args,
+ [INTERN('"ALIEN-FUNCALL",'"SB-ALIEN"),
+ [INTERN('"EXTERN-ALIEN",'"SB-ALIEN"),SYMBOL_-NAME op',
+ ["FUNCTION",nativeType t,:[nativeType x for x in s]]], :args]]]
[["DEFUN",op,args,
- [INTERN('"ALIEN-FUNCALL",'"SB-ALIEN"),
- [INTERN('"EXTERN-ALIEN",'"SB-ALIEN"),SYMBOL_-NAME op',
- ["FUNCTION",nativeType t,:[nativeType x for x in s]]], :args]]]
+ [bfColonColon("SB-SYS","WITH-PINNED-OBJECTS"),unstableArgs,
+ [INTERN('"ALIEN-FUNCALL",'"SB-ALIEN"),
+ [INTERN('"EXTERN-ALIEN",'"SB-ALIEN"),SYMBOL_-NAME op',
+ ["FUNCTION",nativeType t,:[nativeType x for x in s]]], :newArgs]]]]
+
%hasFeature KEYWORD::CLISP =>
-- there is a curious bug in the CLisp's FFI support whereby
-- foreign declarations compiled separately will have the wrong
@@ -340,7 +388,9 @@ genImportDeclaration(op, sig) ==
bfColonColon("FFI", nativeType x)] for x in s for a in args]],
[KEYWORD::RETURN_-TYPE,bfColonColon("FFI",nativeType t)],
[KEYWORD::LANGUAGE,KEYWORD::STDC]]
- forwardingFun := ["DEFUN",op,args,[n,:args]]
+ forwardingFun :=
+ ["DEFUN",op,args,
+ [n,:[coerceToNativeType(a,t) for a in args for x in s]]
[foreignDecl,forwardingFun]
fatalError '"import declaration not implemented for this Lisp"
@@ -748,7 +798,6 @@ loadNativeModule m ==
EVAL [bfColonColon("FFI","DEFAULT-FOREIGN-LIBRARY"), m]
systemError '"don't know how to load a dynamically linked module"
-
$OpenAxiomCoreModuleLoaded := false
loadSystemRuntimeCore() ==
diff --git a/src/include/cfuns.h b/src/include/cfuns.h
index fbed8438..52ad54f7 100644
--- a/src/include/cfuns.h
+++ b/src/include/cfuns.h
@@ -50,5 +50,6 @@ OPENAXIOM_EXPORT int oa_unlink(const char*);
OPENAXIOM_EXPORT int oa_rename(const char*, const char*);
OPENAXIOM_EXPORT int oa_mkdir(const char*);
OPENAXIOM_EXPORT int oa_system(const char*);
+OPENAXIOM_EXPORT char* oa_getenv(const char*);
#endif /* OPENAXIOM_CFUNS_included */
diff --git a/src/include/sockio.h b/src/include/sockio.h
index e3eb8978..652e0bda 100644
--- a/src/include/sockio.h
+++ b/src/include/sockio.h
@@ -78,25 +78,37 @@ typedef struct openaxiom_sio {
} openaxiom_sio;
-/* Close a socket communication endpoint. */
+
+OPENAXIOM_EXPORT int sread(openaxiom_sio*, openaxiom_byte*, int, const char*);
+OPENAXIOM_EXPORT int swrite(openaxiom_sio*, const openaxiom_byte*, int,
+ const char*);
+
+OPENAXIOM_EXPORT int wait_for_client_read(openaxiom_sio*, openaxiom_byte*,
+ int, const char*);
+OPENAXIOM_EXPORT int wait_for_client_write(openaxiom_sio*,
+ const openaxiom_byte*, int,
+ const char*);
+
+OPENAXIOM_EXPORT int make_server_name(char*, const char*);
+OPENAXIOM_EXPORT int make_server_number(void);
+OPENAXIOM_EXPORT openaxiom_sio* connect_to_local_server(char*, int, int);
+OPENAXIOM_EXPORT int open_server(const char*);
+OPENAXIOM_EXPORT int accept_connection(openaxiom_sio*);
+OPENAXIOM_EXPORT int sselect(int, fd_set*, fd_set*, fd_set*, void*);
+OPENAXIOM_EXPORT void close_socket(openaxiom_socket, const char*);
OPENAXIOM_EXPORT void axiom_close_socket(openaxiom_socket);
OPENAXIOM_EXPORT int get_int(openaxiom_sio*);
-OPENAXIOM_EXPORT char* get_string(openaxiom_sio*);
OPENAXIOM_EXPORT double get_float(openaxiom_sio*);
-OPENAXIOM_EXPORT openaxiom_sio* connect_to_local_server(char*, int, int);
-OPENAXIOM_EXPORT int sread(openaxiom_sio*, char*, int, const char*);
+OPENAXIOM_EXPORT double sock_get_float(int);
+OPENAXIOM_EXPORT int get_sfloats(openaxiom_sio*, float*, int);
+OPENAXIOM_EXPORT char* get_string(openaxiom_sio*);
OPENAXIOM_EXPORT double plus_infinity(void);
OPENAXIOM_EXPORT double minus_infinity(void);
OPENAXIOM_EXPORT double NANQ(void);
OPENAXIOM_EXPORT void sigpipe_handler(int);
-OPENAXIOM_EXPORT int wait_for_client_read(openaxiom_sio*, char*,
- int, const char*);
-OPENAXIOM_EXPORT int wait_for_client_write(openaxiom_sio*, const char*,
- int, const char*);
-OPENAXIOM_EXPORT int swrite(openaxiom_sio*, const char*, int, const char*);
-OPENAXIOM_EXPORT int sselect(int, fd_set*, fd_set*, fd_set*, void*);
-OPENAXIOM_EXPORT int fill_buf(openaxiom_sio*, char*, int, char*);
+OPENAXIOM_EXPORT int fill_buf(openaxiom_sio*, openaxiom_byte*, int,
+ const char*);
OPENAXIOM_EXPORT int sock_get_int(int);
OPENAXIOM_EXPORT int get_ints(openaxiom_sio*, int*, int);
OPENAXIOM_EXPORT int sock_get_ints(int, int*, int);
@@ -121,8 +133,6 @@ OPENAXIOM_EXPORT int send_sfloats(openaxiom_sio*, const float*, int);
OPENAXIOM_EXPORT int sock_send_sfloats(int, const float*, int);
OPENAXIOM_EXPORT int send_floats(openaxiom_sio*, const double*, int);
OPENAXIOM_EXPORT int sock_send_floats(int, const double*, int);
-OPENAXIOM_EXPORT double sock_get_float(int);
-OPENAXIOM_EXPORT int get_sfloats(openaxiom_sio*, float*, int);
OPENAXIOM_EXPORT int sock_get_sfloats(int, float*, int);
OPENAXIOM_EXPORT int get_floats(openaxiom_sio*, double*, int);
OPENAXIOM_EXPORT int sock_get_floats(int, double*, int);
@@ -132,21 +142,15 @@ OPENAXIOM_EXPORT int send_signal(openaxiom_sio*, int);
OPENAXIOM_EXPORT int sock_send_signal(int, int);
OPENAXIOM_EXPORT int send_wakeup(openaxiom_sio*);
OPENAXIOM_EXPORT int sock_send_wakeup(int);
-OPENAXIOM_EXPORT openaxiom_sio* connect_to_local_server_new(char*, int, int);
OPENAXIOM_EXPORT void remote_stdio(openaxiom_sio*);
OPENAXIOM_EXPORT void init_purpose_table(void);
-OPENAXIOM_EXPORT int make_server_number(void);
-OPENAXIOM_EXPORT void close_socket(openaxiom_socket, char*);
-OPENAXIOM_EXPORT int make_server_name(char*, char*);
-OPENAXIOM_EXPORT int open_server(char*);
-OPENAXIOM_EXPORT int accept_connection(openaxiom_sio*);
OPENAXIOM_EXPORT void get_socket_type(openaxiom_sio*);
OPENAXIOM_EXPORT int sock_accept_connection(int);
OPENAXIOM_EXPORT void redirect_stdio(openaxiom_sio*);
OPENAXIOM_EXPORT void init_socks(void);
OPENAXIOM_EXPORT int server_switch(void);
OPENAXIOM_EXPORT void flush_stdout(void);
-OPENAXIOM_EXPORT void print_line(char*);
+OPENAXIOM_EXPORT void print_line(const char*);
#define MaxClients 150
diff --git a/src/interp/br-saturn.boot b/src/interp/br-saturn.boot
index b4960abb..6c18cdfd 100644
--- a/src/interp/br-saturn.boot
+++ b/src/interp/br-saturn.boot
@@ -1176,6 +1176,18 @@ htShowPageStarSaturn() ==
-- Redefinitions from br-op2.boot
--=======================================================================
+++ returns true if op designate a niladic constructor. Note that
+++ constructors are symbols whereas ordinary operations are strings.
+operationIsNiladicConstructor op ==
+ IDENTP op => niladicConstructorFromDB op
+ false
+
+++ Like operationIsNiladicConstructor() except that we just want
+++ to know whether `op' is a constructor, arity is unimportant.
+operationIsConstructor op ==
+ IDENTP op => getDualSignatureFromDB op
+ nil
+
--------------> NEW DEFINITION (see br-op2.boot.pamphlet)
displayDomainOp(htPage,which,origin,op,sig,predicate,
doc,index,chooseFn,unexposed?,$generalSearch?) ==
@@ -1209,12 +1221,14 @@ displayDomainOp(htPage,which,origin,op,sig,predicate,
ops := escapeSpecialChars STRINGIMAGE op
n := #sig
do
- n = 2 and LASSOC('Nud,PROPLIST op) => htSay(ops,'" {\em ",quickForm2HtString KAR args,'"}")
- n = 3 and LASSOC('Led,PROPLIST op) => htSay('"{\em ",quickForm2HtString KAR args,'"} ",ops,'" {\em ",quickForm2HtString KAR KDR args,'"}")
+ n = 2 and LASSOC('Nud,PROPLIST op) =>
+ htSay(ops,'" {\em ",quickForm2HtString KAR args,'"}")
+ n = 3 and LASSOC('Led,PROPLIST op) =>
+ htSay('"{\em ",quickForm2HtString KAR args,'"} ",ops,'" {\em ",quickForm2HtString KAR KDR args,'"}")
if unexposed? and $includeUnexposed? then
htSayUnexposed()
htSay(ops)
- predicate='ASCONST or niladicConstructorFromDB op or member(op,'(0 1)) => 'skip
+ predicate='ASCONST or operationIsNiladicConstructor op or member(op,'(0 1)) => 'skip
which = '"attribute" and null args => 'skip
htSay('"(")
if IFCAR args then htSay('"{\em ",quickForm2HtString IFCAR args,'"}")
@@ -1254,7 +1268,7 @@ displayDomainOp(htPage,which,origin,op,sig,predicate,
htSaySaturn '"{\em Arguments:}"
htSaySaturnAmpersand()
firstTime := true
- coSig := KDR getDualSignatureFromDB op --check if op is constructor
+ coSig := KDR operationIsConstructor op --check if op is constructor
for a in args for t in rest $sig repeat
if not firstTime then
htSaySaturn '"\\ "
diff --git a/src/interp/cfuns.lisp b/src/interp/cfuns.lisp
index 9ae4f3bc..84ce0ac3 100644
--- a/src/interp/cfuns.lisp
+++ b/src/interp/cfuns.lisp
@@ -35,9 +35,6 @@
(import-module "boot-pkg")
(in-package "BOOT")
-#+:GCL
-(defun |getEnv| (var-name) (system::getenv var-name))
-
;;stolen from AXIOM-XL src/strops.c
#+(AND KCL (NOT ELF))
(Clines
diff --git a/src/interp/server.boot b/src/interp/server.boot
index 02525de7..ea65ff3c 100644
--- a/src/interp/server.boot
+++ b/src/interp/server.boot
@@ -79,17 +79,15 @@ serverReadLine(stream) ==
$EndServerSession := true
action = $LispCommand =>
$NeedToSignalSessionManager := true
- stringBuf := MAKE_-STRING $sockBufferLength
- sockGetString($MenuServer, stringBuf, $sockBufferLength)
- form := unescapeStringsInForm READ_-FROM_-STRING stringBuf
+ buf := sockGetString $MenuServer
+ form := unescapeStringsInForm READ_-FROM_-STRING buf
protectedEVAL form
action = $QuietSpadCommand =>
$NeedToSignalSessionManager := true
executeQuietCommand()
action = $SpadCommand =>
$NeedToSignalSessionManager := true
- stringBuf := MAKE_-STRING 512
- sockGetString($MenuServer, stringBuf, 512)
+ stringBuf := sockGetString $MenuServer
CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER,
parseAndInterpret stringBuf)))
PRINC MKPROMPT()
@@ -116,8 +114,7 @@ oldParseAndInterpret str ==
executeQuietCommand() ==
$QuietCommand: fluid := true
- stringBuf := MAKE_-STRING 512
- sockGetString($MenuServer, stringBuf, 512)
+ stringBuf := sockGetString $MenuServer
CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER,
parseAndInterpret stringBuf)))
@@ -150,15 +147,13 @@ serverLoop() ==
action = $EndSession =>
$EndServerSession := true
action = $LispCommand =>
- stringBuf := MAKE_-STRING 512
- sockGetString($MenuServer, stringBuf, 512)
+ stringBuf := sockGetString $MenuServer
form := unescapeStringsInForm READ_-FROM_-STRING stringBuf
EVAL form
action = $QuietSpadCommand =>
executeQuietCommand()
action = $SpadCommand =>
- stringBuf := MAKE_-STRING 512
- sockGetString($MenuServer, stringBuf, 512)
+ stringBuf := sockGetString $MenuServer
CATCH('coerceFailure,CATCH('top__level, CATCH('SPAD__READER,
parseAndInterpret stringBuf)))
PRINC MKPROMPT()
diff --git a/src/interp/sockio.lisp b/src/interp/sockio.lisp
index ab963588..0ed33463 100644
--- a/src/interp/sockio.lisp
+++ b/src/interp/sockio.lisp
@@ -36,21 +36,6 @@
(import-module "boot-pkg")
(in-package "BOOT")
-#+KCL
-(progn
-;; GCL may pass strings by value. 'sock_get_string_buf' should fill
-;; string with data read from connection, therefore needs address of
-;; actual string buffer. We use 'sock_get_string_buf_wrapper' to
-;; resolve the problem
- (clines "int sock_get_string_buf_wrapper(int i, object x, int j)"
- "{ if (type_of(x)!=t_string) FEwrong_type_argument(sLstring,x);"
- " if (x->st.st_fillp<j)"
- " FEerror(\"string too small in sock_get_string_buf_wrapper\",0);"
- " return sock_get_string_buf(i, x->st.st_self, j); }")
- (defentry |sockGetString| (int object int)
- (int "sock_get_string_buf_wrapper"))
- )
-
;; Macros for use in Boot
;; Socket types. This list must be consistent with the one in com.h
diff --git a/src/interp/sys-os.boot b/src/interp/sys-os.boot
index 019228d2..61ace016 100644
--- a/src/interp/sys-os.boot
+++ b/src/interp/sys-os.boot
@@ -63,6 +63,9 @@ import renameFile for
import mkdir for
oa__mkdir: string -> int -- 0: sucess, -1: failure.
+import getEnv for
+ oa__getenv: string -> string
+
++ socket interface
import openServer for
open__server: string -> int
@@ -73,9 +76,8 @@ import sockGetInt for
import sockSendInt for
sock__send__int: (int,int) -> int
-)if not %hasFeature KEYWORD::GCL
import sockGetString for
- sock__get__string__buf: (int,pointer,int) -> int
+ sock__get__string: int -> string
)endif
import doSendString for
diff --git a/src/lib/cfuns-c.c b/src/lib/cfuns-c.c
index d7eae316..4a1e596f 100644
--- a/src/lib/cfuns-c.c
+++ b/src/lib/cfuns-c.c
@@ -439,3 +439,30 @@ oa_system(const char* cmd)
return system(cmd);
}
+
+
+/* Return the value of an environment variable. */
+OPENAXIOM_EXPORT char*
+oa_getenv(const char* var)
+{
+#ifdef __MINGW32__
+#define BUFSIZE 128
+ char* buf = (char*) malloc(BUFSIZE);
+ int len = GetEnvironmentVariable(var, buf, BUFSIZE);
+ if (len == 0) {
+ free(buf);
+ return NULL;
+ }
+ else if (len > BUFSIZE) {
+ buf = (char*) realloc(len);
+ len = GetEnvironmentVariable(var, buf, len);
+ if (len == 0) {
+ free(buf);
+ return NULL;
+ }
+ }
+ return buf;
+#else
+ return getenv(var);
+#endif
+}
diff --git a/src/lib/sockio-c.c b/src/lib/sockio-c.c
index a0f4b536..baab6445 100644
--- a/src/lib/sockio-c.c
+++ b/src/lib/sockio-c.c
@@ -196,13 +196,13 @@ openaxiom_close_socket(openaxiom_socket s)
send(). */
static inline int
-openaxiom_write(openaxiom_sio* s, const char* buf, size_t n)
+openaxiom_write(openaxiom_sio* s, const openaxiom_byte* buf, size_t n)
{
return send(s->socket, buf, n, 0);
}
static inline int
-openaxiom_read(openaxiom_sio* s, char* buf, size_t n)
+openaxiom_read(openaxiom_sio* s, openaxiom_byte* buf, size_t n)
{
return recv(s->socket, buf, n, 0);
}
@@ -240,7 +240,7 @@ sigpipe_handler(int sig)
}
OPENAXIOM_EXPORT int
-wait_for_client_read(openaxiom_sio *sock, char *buf, int buf_size,
+wait_for_client_read(openaxiom_sio *sock, openaxiom_byte* buf, int buf_size,
const char* msg)
{
int ret_val;
@@ -258,8 +258,8 @@ wait_for_client_read(openaxiom_sio *sock, char *buf, int buf_size,
}
OPENAXIOM_EXPORT int
-wait_for_client_write(openaxiom_sio *sock, const char *buf,int buf_size,
- const char* msg)
+wait_for_client_write(openaxiom_sio* sock, const openaxiom_byte* buf,
+ int buf_size, const char* msg)
{
int ret_val;
switch(sock->purpose) {
@@ -276,7 +276,7 @@ wait_for_client_write(openaxiom_sio *sock, const char *buf,int buf_size,
}
OPENAXIOM_EXPORT int
-sread(openaxiom_sio *sock, char *buf, int buf_size, const char *msg)
+sread(openaxiom_sio* sock, openaxiom_byte* buf, int buf_size, const char *msg)
{
int ret_val;
char err_msg[256];
@@ -301,7 +301,8 @@ sread(openaxiom_sio *sock, char *buf, int buf_size, const char *msg)
}
OPENAXIOM_EXPORT int
-swrite(openaxiom_sio *sock, const char* buf,int buf_size, const char* msg)
+swrite(openaxiom_sio* sock, const openaxiom_byte* buf, int buf_size,
+ const char* msg)
{
int ret_val;
char err_msg[256];
@@ -337,7 +338,7 @@ sselect(int n,fd_set *rd, fd_set *wr, fd_set *ex, void *timeout)
}
OPENAXIOM_EXPORT int
-fill_buf(openaxiom_sio *sock,char *buf, int len, char *msg)
+fill_buf(openaxiom_sio *sock, openaxiom_byte* buf, int len, const char* msg)
{
int bytes = 0, ret_val;
while(bytes < len) {
@@ -352,7 +353,7 @@ OPENAXIOM_EXPORT int
get_int(openaxiom_sio *sock)
{
int val = -1, len;
- len = fill_buf(sock, (char *)&val, sizeof(int), "integer");
+ len = fill_buf(sock, (openaxiom_byte*)&val, sizeof(int), "get_int");
if (len != sizeof(int)) {
#ifdef DEBUG
fprintf(stderr,"get_int: caught error\n",val);
@@ -394,7 +395,7 @@ OPENAXIOM_EXPORT int
send_int(openaxiom_sio *sock,int val)
{
int ret_val;
- ret_val = swrite(sock, (char *)&val, sizeof(int), NULL);
+ ret_val = swrite(sock, (const openaxiom_byte*)&val, sizeof(int), "send_int");
if (ret_val == -1) {
return -1;
}
@@ -437,14 +438,14 @@ send_string_len(openaxiom_sio *sock, const char *str,int len)
strncpy(buf,str,len);
buf[len]='\0';
send_int(sock,len+1);
- val = swrite(sock, buf, len+1, NULL);
+ val = swrite(sock, (const openaxiom_byte*) buf, len+1, "send_string_len");
free(buf);
} else {
static char buf[1024];
strncpy(buf, str, len);
buf[len] = '\0';
send_int(sock, len+1);
- val = swrite(sock, buf, len+1, NULL);
+ val = swrite(sock, (const openaxiom_byte*) buf, len+1, "send_string_len");
}
if (val == -1) {
return -1;
@@ -453,11 +454,11 @@ send_string_len(openaxiom_sio *sock, const char *str,int len)
}
OPENAXIOM_EXPORT int
-send_string(openaxiom_sio *sock, const char *str)
+send_string(openaxiom_sio* sock, const char* str)
{
int val, len = strlen(str);
send_int(sock, len+1);
- val = swrite(sock, str, len+1, NULL);
+ val = swrite(sock, (const openaxiom_byte*) str, len+1, "send_string");
if (val == -1) {
return -1;
}
@@ -482,7 +483,7 @@ sock_send_string_len(int purpose, const char* str, int len)
}
OPENAXIOM_EXPORT int
-send_strings(openaxiom_sio *sock, const char ** vals, int num)
+send_strings(openaxiom_sio *sock, const char** vals, int num)
{
int i;
for(i=0; i<num; i++)
@@ -492,7 +493,7 @@ send_strings(openaxiom_sio *sock, const char ** vals, int num)
}
OPENAXIOM_EXPORT int
-sock_send_strings(int purpose, const char **vals, int num)
+sock_send_strings(int purpose, const char**vals, int num)
{
if (accept_if_needed(purpose) != -1)
return send_strings(purpose_table[purpose], vals, num);
@@ -507,7 +508,7 @@ get_string(openaxiom_sio *sock)
len = get_int(sock);
if (len <0) return NULL;
buf = malloc(len*sizeof(char));
- val = fill_buf(sock, buf, len, "string");
+ val = fill_buf(sock, (openaxiom_byte*) buf, len, "get_string");
if (val == -1){
free(buf);
return NULL;
@@ -537,7 +538,8 @@ get_string_buf(openaxiom_sio *sock, char *buf, int buf_len)
nbytes_to_read = sock->nbytes_pending > buf_len
? buf_len
: sock->nbytes_pending;
- nbytes_read = fill_buf(sock, buf, nbytes_to_read, "buffered string");
+ nbytes_read = fill_buf(sock, (openaxiom_byte*)buf, nbytes_to_read,
+ "get_string_buf");
if (nbytes_read == -1) {
sock->nbytes_pending = 0;
return NULL;
@@ -547,7 +549,7 @@ get_string_buf(openaxiom_sio *sock, char *buf, int buf_len)
}
OPENAXIOM_EXPORT char *
-sock_get_string_buf(int purpose, char * buf, int buf_len)
+sock_get_string_buf(int purpose, char* buf, int buf_len)
{
if (accept_if_needed(purpose) != -1)
return get_string_buf(purpose_table[purpose], buf, buf_len);
@@ -555,7 +557,7 @@ sock_get_string_buf(int purpose, char * buf, int buf_len)
}
OPENAXIOM_EXPORT int
-get_strings(openaxiom_sio *sock,char **vals,int num)
+get_strings(openaxiom_sio *sock, char** vals,int num)
{
int i;
for(i=0; i<num; i++)
@@ -564,7 +566,7 @@ get_strings(openaxiom_sio *sock,char **vals,int num)
}
OPENAXIOM_EXPORT int
-sock_get_strings(int purpose, char ** vals, int num)
+sock_get_strings(int purpose, char** vals, int num)
{
if (accept_if_needed(purpose) != -1)
return get_strings(purpose_table[purpose], vals, num);
@@ -575,7 +577,7 @@ OPENAXIOM_EXPORT int
send_float(openaxiom_sio *sock, double num)
{
int val;
- val = swrite(sock, (char *)&num, sizeof(double), NULL);
+ val = swrite(sock, (const openaxiom_byte*)&num, sizeof(double),"send_float");
if (val == -1) {
return -1;
}
@@ -631,7 +633,7 @@ get_float(openaxiom_sio *sock)
{
int val;
double num = -1.0;
- val = fill_buf(sock, (char *)&num, sizeof(double), "double");
+ val = fill_buf(sock, (openaxiom_byte*)&num, sizeof(double), "get_float");
#ifdef DEBUG
fprintf(stderr,"get_float: received %f\n",num);
#endif
@@ -878,16 +880,10 @@ remote_stdio(openaxiom_sio *sock)
if (FD_ISSET(0, &rd)) {
fgets(buf,1024,stdin);
len = strlen(buf);
- /*
- gets(buf);
- len = strlen(buf);
- *(buf+len) = '\n';
- *(buf+len+1) = '\0';
- */
- swrite(sock, buf, len, "writing to remote stdin");
+ swrite(sock, (const openaxiom_byte*)buf, len, "remote_stdio::write");
}
if (FD_ISSET(sock->socket, &rd)) {
- len = sread(sock, buf, 1024, "stdio");
+ len = sread(sock, (openaxiom_byte*)buf, 1024, "remote_stdio::read");
if (len == -1)
return;
else {
@@ -918,7 +914,7 @@ make_server_number(void)
}
OPENAXIOM_EXPORT void
-close_socket(openaxiom_socket socket_num, char *name)
+close_socket(openaxiom_socket socket_num, const char *name)
{
openaxiom_close_socket(socket_num);
#ifndef RTplatform
@@ -927,7 +923,7 @@ close_socket(openaxiom_socket socket_num, char *name)
}
OPENAXIOM_EXPORT int
-make_server_name(char *name,char * base)
+make_server_name(char *name, const char* base)
{
char *num;
if (spad_server_number != -1) {
@@ -948,7 +944,7 @@ make_server_name(char *name,char * base)
/* client Spad server sockets. Two sockets are created: server[0]
is the internet server socket, and server[1] is a local domain socket. */
OPENAXIOM_EXPORT int
-open_server(char *server_name)
+open_server(const char* server_name)
{
char *s, name[256];
@@ -1174,7 +1170,7 @@ flush_stdout(void)
}
OPENAXIOM_EXPORT void
-print_line(char *s)
+print_line(const char* s)
{
printf("%s\n", s);
}
diff --git a/src/lisp/core.lisp.in b/src/lisp/core.lisp.in
index eaba3a3d..8f549803 100644
--- a/src/lisp/core.lisp.in
+++ b/src/lisp/core.lisp.in
@@ -62,6 +62,9 @@
"resetErrorCount"
"warn"
+ "%ByteArray"
+ "makeByteArray"
+
"%hasFeature"
"%systemOptions"
"%systemArguments"
@@ -294,6 +297,7 @@
:init-function entry-point
:executable t
:norc t
+ :quiet t
)
(ext::saveinitmem core-image
:executable t
@@ -349,13 +353,22 @@
(setq |$errorCount| 0))
;; utils
+
+;; GCL has a hard limit on the number of arguments for concatenate.
+;; However, it has a specialized versions for catenating string
+;; that seems immune to that hard limit. Specialized accordingly.
+(defun |catenateStrings| (&rest l)
+ #+ :gcl (apply #'si::string-concatenate l)
+ #- :gcl (apply #'concatenate 'string l))
+
(defun concat (a b &rest l)
- (let ((type (cond ((bit-vector-p a) 'bit-vector) (t 'string))))
- (cond ((eq type 'string)
- (setq a (string a) b (string b))
- (if l (setq l (mapcar #'string l)))))
- (if l (apply #'concatenate type a b l)
- (concatenate type a b))) )
+ (cond ((bit-vector-p a)
+ (apply #'concatenate 'bit-vector a b l))
+ (t
+ (apply #'|catenateStrings|
+ (string a)
+ (string b)
+ (mapcar #'string l)))))
(defun |fatalError| (msg)
(|countError|)
@@ -814,6 +827,17 @@
;; -*- Native Datatype correspondance -*-
;;
+;; Datatype for buffers mostly used for transmitting data between
+;; the Lisp world and Native World.
+(deftype |%ByteArray| ()
+ '(simple-array (unsigned-byte 8)))
+
+(declaim (ftype (function (fixnum) |%ByteArray|) |makeByteArray|))
+(defun |makeByteArray| (n)
+ (make-array n
+ :element-type '(unsigned-byte 8)
+ :initial-element 0))
+
;; native data type translation table
(defconstant |$NativeTypeTable|
'((|void| . @void_type@)
@@ -822,4 +846,5 @@
(|float| . @float_type@)
(|double| . @double_type@)
(|string| . @string_type@)
+ (|buffer| . @pointer_type@)
(|pointer| . @pointer_type@)))
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-01 13:08:47 +0000