From: ·····@uicsrd.csrd.uiuc.edu
Subject: KCL question
Date: Sun, 15 Apr 1990 16:38:42 +0000
Message-ID: <47400024@uicsrd.csrd.uiuc.edu> I'm sorry this kind of posting bothers you again - please bear with me.
Can anyone help my problem installing KCL on SUN(SunOS release 4.0.3)?
It crashes(memory fault) in the last step for saved_kcl.
Here is the messages:
/* during init_kcl.lsp, i think. */
Loading ../cmpnew/cmpmain.lsp
sh: 22560 Memory fault - core dumped
*** Error code 139
make: Fatal error: Command failed for target `saved_kcl'
Current working directory /s1/home6/kwang/kcl/unixport
*** Error code 1
make: Fatal error: Command failed for target `all'
Thankyou for any comment, -kwang
·····@uicsrd.csrd.uiuc.edu From: ········@uicbert.eecs.uic.edu
Subject: Re: KCL question
Date: Thu, 19 Apr 1990 11:13:26 +0000
Message-ID: <63200012@uicbert.eecs.uic.edu> i can't believe it!!! i just came onto this board tonight to ask
precisely the same question ( i got precisely the same problem ).
so, if your question is boring, then that makes two of us bores!!!
any of you who take a moment to answer the question for my colleague
at my sister institution, would you take a moment to answer the
question ( same ) for me as well??
jp woodward
univ of ill at chicago From: Steve Wampler
Subject: Re: KCL question
Date: Thu, 19 Apr 1990 15:50:29 +0000
Message-ID: <2060@naucse.UUCP> From article <········@uicbert.eecs.uic.edu>, by ········@uicbert.eecs.uic.edu:
>
> i can't believe it!!! i just came onto this board tonight to ask
> precisely the same question ( i got precisely the same problem ).
> so, if your question is boring, then that makes two of us bores!!!
>
> any of you who take a moment to answer the question for my colleague
> at my sister institution, would you take a moment to answer the
> question ( same ) for me as well??
>
I cannot answer it, but I have some vague idea of what's happening.
(If someone has a working solution, let me know.) KCL provides
its own versions of malloc, free, etc., now, under Ultrix at least,
fopen() and fclose() do malloc and free of buffers (I don't think the
early versions of Unix did this). For some reason, something clashes
and things die on a free from inside fclose. I haven't figured out
why the clash, since it seems to me that fopen() and fclose() would
both be referencing the routines supplied with KCL, but clearly there
is a problem.
--
Steve Wampler
{....!arizona!naucse!sbw}
····@naucse.cse.nau.edu} From: Mike McDonald
Subject: Re: KCL question
Date: Mon, 23 Apr 1990 14:59:36 +0000
Message-ID: <3500@trantor.harris-atd.com> In article <····@naucse.UUCP>, ···@naucse.UUCP (Steve Wampler) writes:
|>From article <········@uicbert.eecs.uic.edu>, by
········@uicbert.eecs.uic.edu:
|>>
|>> i can't believe it!!! i just came onto this board tonight to ask
|>> precisely the same question ( i got precisely the same problem ).
|>> so, if your question is boring, then that makes two of us bores!!!
|>>
|>> any of you who take a moment to answer the question for my colleague
|>> at my sister institution, would you take a moment to answer the
|>> question ( same ) for me as well??
|>>
|>I cannot answer it, but I have some vague idea of what's happening.
|>(If someone has a working solution, let me know.) KCL provides
|>its own versions of malloc, free, etc., now, under Ultrix at least,
|>fopen() and fclose() do malloc and free of buffers (I don't think the
|>early versions of Unix did this). For some reason, something clashes
|>and things die on a free from inside fclose. I haven't figured out
|>why the clash, since it seems to me that fopen() and fclose() would
|>both be referencing the routines supplied with KCL, but clearly there
|>is a problem.
|>--
|> Steve Wampler
|> {....!arizona!naucse!sbw}
|> ····@naucse.cse.nau.edu}
My understanding of this problem is that KCL doesn't include the
networking routines in it's standard image. Inorder to get these,
socket.c needs to be linked with the C library. Unfortunetly, this
causes socket.c to get the standard versions of malloc, free, ... The
only solution that I can think of is to go back to the initial
compilation stages of making KCL and add socket.c as part of the
standard make. I have not had any free time, nor the guts, to try doing
this yet. If someone succeeds, I hope they'll be kind enough to share
their wisdom with the rest of us.
Mike McDonald
···@trantor.harris-atd.com
··········@trantor.harris-atd.com
(407) 727-5060
Advanced Technology Dept.
Harris Corp.
M.S. 3A-1912
P.O. Box 37
Melbourne, Florida
32902 From: Toshimi sawada
Subject: Re: KCL question
Date: Thu, 26 Apr 1990 13:06:20 +0000
Message-ID: <42205@etlcom.etl.go.jp> [···@trantor.harris-atd.com in <····@trantor.harris-atd.com>]:
| My understanding of this problem is that KCL doesn't include the
|networking routines in it's standard image. Inorder to get these,
|socket.c needs to be linked with the C library. Unfortunetly, this
|causes socket.c to get the standard versions of malloc, free, ... The
|only solution that I can think of is to go back to the initial
|compilation stages of making KCL and add socket.c as part of the
|standard make. I have not had any free time, nor the guts, to try doing
|this yet. If someone succeeds, I hope they'll be kind enough to share
|their wisdom with the rest of us.
KCL of UNIX BSD version has "faslink" function which loads compiled
file while linking the object files and libraries specified.
For instance, (faslink "foo.o" "bar.o baz.o -lc")
loads foo.o while linking two object files (bar.o and baz.o) and the
C library. ("faslink" uses incremental loading facility of 'ld'
command).
I think that this will suffice to the above problem.
By the way, about 3 years ago, I wrote a package which offers
some low and medium level socket i/o facilities.
I implemented it embedding in KCL image as Mr. McDonald says,
but for the ease to modify, I rewrote whole. It now uses "faslink".
The package is never complete, but it will be useful to those who
have no experience in making C coded lisp functions of KCl, and it
works. It also has some extensions of "defentry" macro.
It's free, if you have any interest mail me or post please.
--
Toshimi Sawada
Software Reserach Associates Inc.
on leave at Computer Language Section, Electrotechnical Laboratory
1-1-4 Umezono, Tsukuba, Ibaraki 305, JAPAN
TEL: +81 298 58 5890
E-Mail: ······@etl.go.jp From: Toshimi sawada
Subject: Re: KCL question
Date: Fri, 27 Apr 1990 12:06:18 +0000
Message-ID: <42239@etlcom.etl.go.jp> [······@etl.go.jp in <·····@etlcom.etl.go.jp>]:
|By the way, about 3 years ago, I wrote a package which offers
|some low and medium level socket i/o facilities.
|I implemented it embedding in KCL image as Mr. McDonald says,
|but for the ease to modify, I rewrote whole. It now uses "faslink".
|
|The package is never complete, but it will be useful to those who
|have no experience in making C coded lisp functions of KCl, and it
|works. It also has some extensions of "defentry" macro.
|It's free, if you have any interest mail me or post please.
I received some requests to post my package.
This is a package for (Austin)KCl which offers foreign data interface
facilities. It is far from sofisticated, but it works well and is
useful (at least for me). socket i/o will be in the next post.
--
Toshimi Sawada
Software Reserach Associates Inc.
on leave at Computer Language Section, Electrotechnical Laboratory
1-1-4 Umezono, Tsukuba, Ibaraki 305, JAPAN
TEL: +81 298 58 5890
E-Mail: ······@etl.go.jp
-------------------------<cut>-----------------------------------------
# This is a shell archive. Remove anything before this line,
# then unpack it by saving it in a file and typing "sh file".
#
# Wrapped by on Fri Apr 27 20:58:45 JST 1990
# Contents: README fi_lib.c foreign.lsp
echo x - README
sed ····@//' > "README" <<·@//E*O*F README//'
Usage:
1) change directory where "foreign.lsp" and "fi_lib.c" are.
invoke (A)KCl and ...
>(compile-file "foreign")
Compiling foreign.lsp.
End of Pass 1.
End of Pass 2.
OPTIMIZE levels: Safety=0 (No runtime error checking), Space=0, Speed=3
Finished compiling foreign.
#"foreign.o"
>(load "foreign")
Loading foreign.o
start address -T 28a000 Finished loading foreign.o
31968
>
@//E*O*F README//
chmod u=rw,g=rw,o=r README
echo x - fi_lib.c
sed ····@//' > "fi_lib.c" <<·@//E*O*F fi_lib.c//'
/* -*- Mode:C -*-
*
* Foreign Data Interface for (A) KCL , C part.
* Copyright (c) Toshimi Sawada
* Permission to use, copy, modify, and distribute this software for any
* purpose is hereby granted without fee.
* ······@sra.co.jp
*/
#define LOCAL static
/* TYPE MAGIC CODES */
#define C_INT 0
#define C_UINT 1
#define C_FLOAT 2
#define C_SHORT 3
#define C_UCHAR 4
#define C_USHORT 5
#define C_LONG 6
#define C_DOUBLE 7
#define C_POINTER 8
#define C_STRING 9
#define C_CHAR 10
#define C_ULONG 11
#define C_GSTRING 12
#define C_INTP 20
#define C_UINTP 21
#define C_FLOATP 22
#define C_SHORTP 23
#define C_UCHARP 24
#define C_USHORTP 25
#define C_LONGP 26
#define C_DOUBLEP 27
#define C_POINTERP 28
#define C_STRINGP 29
#define C_CHARP 30
#define C_ULONGP 31
#define G_STRINGP 32
#define C_OBJECT 50
#define C_OBJECTP 70
/* Cribbed from object.h of AKCL (has upper compatibility to KCl */
enum aelttype { /* array element type */
aet_object, /* t */
aet_ch, /* string-char */
aet_bit, /* bit */
aet_fix, /* fixnum */
aet_sf, /* short-float */
aet_lf, /* long-float */
aet_char, /* signed char */
aet_uchar, /* unsigned char */
aet_short, /* signed short */
aet_ushort, /* unsigned short */
};
/* Cribbed from external.h KCL December 19, 1986 version */
extern void FEerror();
extern void FEwrong_type_argument();
extern object Sarray;
/*
* _CHECK_IF_SIMPLE_SEQUENCE
*/
LOCAL void _check_if_simple_sequence (x)
object x;
{
enum aelttype type;
switch(type_of(x))
{
case t_array:
case t_vector:
type = (enum aelttype)x->a.a_elttype;
if ((type != aet_fix) && (type != aet_ch))
break;
return;
case t_string:
return;
default:
FEwrong_type_argument(Sarray, x);
}
FEerror ("array element type must be a character or fixnum!",0);
return;
}
/*
*
* c_aref
*
*/
object c_aref (sequence, offset, type)
object sequence;
register int offset;
register int type;
{
object pointer_ref();
register char *pointer = (char *)(sequence->fixa.fixa_self);
return(pointer_ref(pointer, offset, type));
}
/*
* pointer_ref
*/
object pointer_ref(pointer, offset, type)
register char *pointer;
register int offset, type;
{
object x;
pointer += offset;
switch (type){
case C_OBJECT:
x = *(object*)pointer;
break;
case C_INT:
x = make_fixnum(*(int *)pointer);
break;
case C_UINT:
x = make_fixnum(*(unsigned int *)pointer);
break;
case C_FLOAT:
x = make_shortfloat(*(float *)pointer);
break;
case C_SHORT:
x = make_fixnum(*(short *)pointer);
break;
case C_CHAR:
x = make_fixnum(*(char *)pointer);
break;
case C_UCHAR:
x = make_fixnum(*(unsigned char *)pointer);
break;
case C_USHORT:
x = make_fixnum(*(unsigned short *)pointer);
break;
case C_LONG:
x = make_fixnum(*(long *) pointer);
break;
case C_ULONG:
x = make_fixnum(*(unsigned long *) pointer);
break;
case C_DOUBLE:
x = make_longfloat(*(double *)pointer);
break;
case C_POINTER:
x = make_fixnum(*(int *)pointer);
break;
case C_STRING:
case C_GSTRING:
if (*(char **)pointer)
x = make_simple_string (*(char **)pointer);
else
x = Cnil;
break;
case C_OBJECTP:
x = (**(object **)pointer);
break;
case C_INTP:
x = make_fixnum(**(int **)pointer);
break;
case C_UINTP:
x = make_fixnum(**(unsigned int **)pointer);
break;
case C_FLOATP:
x = make_shortfloat(**(float **) pointer);
break;
case C_SHORTP:
x = make_fixnum(**(int **)pointer);
break;
case C_CHARP:
x = make_fixnum(**(char **)pointer);
break;
case C_UCHARP:
x = make_fixnum(**(unsigned char **)pointer);
break;
case C_USHORTP:
x = make_fixnum(**(unsigned short **)pointer);
break;
case C_LONGP:
x = make_fixnum(**(long **)pointer);
break;
case C_ULONGP:
x = make_fixnum(**(unsigned long **)pointer);
break;
case C_DOUBLEP:
x = make_longfloat(**(double **)pointer);
break;
case C_POINTERP:
x = make_fixnum(**(int **) pointer);
break;
}
return x;
}
object c_aref1 (sequence, offset, type)
object sequence;
register int offset;
register int type;
{
_check_if_simple_sequence(sequence);
return(pointer_ref(sequence->fixa.fixa_self,
offset,
type));
}
/*
*
* c_aset
*
*/
object c_aset (sequence, offset, type, value)
object sequence;
register int offset;
object value;
register int type;
{ object pointer_set();
register char *pointer = (char *)(sequence->fixa.fixa_self);
return(pointer_set(pointer, offset, type, value));
}
/*
* pointer_set
*/
object pointer_set(p, offset, type, value)
char *p;
int offset,type;
object value;
{
register char *pointer = p + offset;
switch (type){
case C_OBJECT:
*(object *)pointer = value;
break;
case C_INT:
case C_LONG:
case C_POINTER:
*(int *)pointer = fixint(value);
break;
case C_FLOAT:
*(float *)pointer = (float)object_to_double(value);
break;
case C_DOUBLE:
*(double *)pointer = object_to_double(value);
break;
case C_SHORT:
*(short *)pointer = (short)fixint(value);
break;
case C_CHAR:
*(char *)pointer = (short)fixint(value);
break;
case C_UINT:
*(unsigned int *)pointer = (unsigned int)fixint(value);
break;
case C_USHORT:
*(unsigned short *)pointer = (unsigned short)fixint(value);
break;
case C_UCHAR:
*(unsigned char *)pointer = (unsigned char)fixint(value);
break;
case C_STRING:
{ char *new_str = malloc(value->st.st_fillp + 1);
char *str_body1;
str_body1 = new_str ;
strncpy(new_str,value->st.st_self, value->st.st_fillp);
new_str += value->st.st_fillp;
*new_str++=0;
if (* ((char * *) pointer))
free (* ((char * *) pointer));
*(char **)pointer = str_body1;
}
break;
case C_GSTRING:
{ char *new_str = malloc(value->st.st_fillp + 1);
char *str_body1;
str_body1 = new_str ;
strncpy(new_str,value->st.st_self, value->st.st_fillp);
new_str += value->st.st_fillp;
*new_str++=0;
*(char **)pointer = str_body1;
}
break;
case C_OBJECTP:
**(object **)pointer = value;
case C_INTP:
**(int **)pointer = fixint(value);
break;
case C_LONGP:
**(long **)pointer = fixint(value);
break;
case C_POINTERP:
**(int **)pointer = fixint(value);
break;
case C_FLOATP:
**(float **)pointer = (float)object_to_double(value);
break;
case C_DOUBLEP:
**(double **)pointer = object_to_double(value);
break;
case C_SHORTP:
**(short **)pointer = (short)fixint(value);
break;
case C_CHARP:
**(char **)pointer = (short)fixint(value);
break;
case C_UINTP:
**(unsigned int **)pointer = (unsigned int)fixint(value);
break;
case C_USHORTP:
**(unsigned short **)pointer = (unsigned short)fixint(value);
break;
case C_UCHARP:
**(unsigned char **)pointer = (unsigned char)fixint(value);
break;
case C_STRINGP:
{ char *new_str = malloc(value->st.st_dim + 1);
register int i;
for (i = 0; i <= value->st.st_dim; i++){
new_str[i] = value->st.st_self[i];
}
new_str[i] = 0;
if (** ((char ***) pointer))
free (** ((char ***) pointer));
**(char ***)pointer = new_str;
}
break;
case G_STRINGP:
/* not implemented yet */
break;
}
return value;
}
object c_aset1 (sequence, offset, type, value)
object sequence;
register int offset;
object value;
register int type;
{
_check_if_simple_sequence(sequence);
return(pointer_set(sequence->fixa.fixa_self,
offset, type, value));
}
/*
*
* REBIND_SELF
*
*/
object rebind_self (vector, address, size)
object vector;
object *address;
int size;
{
vs_push(vector);
vector->v.v_dim = size;
vector->v.v_fillp = size;
vector->v.v_self = address;
return vector;
}
object rebind_self1 (vector, address, size)
object vector;
object *address;
int size;
{
_check_if_simple_sequence(vector);
vs_push(vector);
vector->v.v_dim = size;
vector->v.v_fillp = size;
vector->v.v_self = address;
return vector;
}
/*
* SELF_POINTER
*/
int self_pointer (vector)
object vector;
{
return((int)vector->fixa.fixa_self);
}
int self_pointer1 (vector)
object vector;
{
_check_if_simple_sequence(vector);
return((int)vector->fixa.fixa_self);
}
/*
* copy_subsequence
*/
copy_subsequence (to, start1, end1, from, start2)
object to, from;
int start1, end1, start2;
{
register char *pto, *pfrom;
/* _check_if_simple_sequence(to);
_check_if_simple_sequence(from);
*/
pto = (char *)to->fixa.fixa_self + start1;
pfrom = (char *)from->fixa.fixa_self + start2;
bcopy(pfrom, pto, (end1 - start1));
}
@//E*O*F fi_lib.c//
chmod u=rw,g=rw,o=r fi_lib.c
echo x - foreign.lsp
sed ····@//' > "foreign.lsp" <<·@//E*O*F foreign.lsp//'
;;;-*-Mode:Lisp; Syntax:Common-lisp ; Package: FI-*-
(provide 'foreign)
(in-package :FI :use '("LISP" "SYSTEM"))
;;;;*************************************************************************
;;;
;;; FOREIGN DATA INTERFACE FOR (A)KCL
;;;
;;;
;;; Copyright (c) 1987, 1988, 1989, 1990 Toshimi Sawada
;;; Permission to use, copy, modify, and distribute this software for any
;;; purpose is hereby granted without fee.
;;; ······@sra.co.jp
;;;
;;;***************************************************************************
(export '(pointer-ref
pointer-ref-setf
&
->
&->
byte-to-cell
type-id-magic))
(export '(rebind-self
size-of
make-memory-block
f-body
*int
*uint
*float
*short
*uchar
*ushort
*long
*double
*pointer
*char
*ulong
*object
**int
**uint
**float
**short
**uchar
**ushort
**long
**double
**pointer
**char
**ulong
**object
def-foreign-struct
map-foreign-struct
map-foreign-struct*
make-foreign-struct-with-object))
(export '(define-cvar-accessor
copy-subsequence))
;;;
;;; C coded primitive definition
;;;
(Clines
"#include \"fi_lib.c\"")
(defentry c-aref (object int int) (object c_aref))
(defentry c-aset (object int int object) (object c_aset))
(defentry rebind-self-internal (object int int) (object rebind_self))
(defentry self-pointer (object) (int self_pointer))
(defentry pointer-ref (int int int) (object pointer_ref))
(defentry pointer-ref-setf (int int int object) (object pointer_set))
;;(defentry get-symbol-address (object) (int akcl_get_symbol_address))
(defentry c-aref-safe (object int int) (object c_aref1))
(defentry c-aset-safe (object int int object) (object c_aset1))
(defentry rebind-self-internal-safe (object int int) (object rebind_self1))
(defentry self-pointer-safe (object) (int self_pointer1))
(defsetf c-aref (x offset type) (v)
`(c-aset ,x ,offset ,type ,v))
(defsetf pointer-ref(x offset type) (v)
`(pointer-ref-setf ,x ,offset ,type ,v))
;;;-------------------------------------------------------------------------
;;; Machine and implemenation dependent type informations
;;;-------------------------------------------------------------------------
(defmacro set-type-information (type byte-size enum-value lisp-type)
`(progn
(setf (get ',type 'byte-size) ,byte-size)
(setf (get ',type 'c-type-value) ,enum-value)
(setf (get ',type 'lisp-type) ',lisp-type)))
(eval-when (eval compile load)
(set-type-information :cell 4 -1 fixnum)
;;; following types are used to specify a type of the MEMORY-BLOCK
;;; and the slot type of the FOREIGN-STRUCTURE
;;;
(set-type-information :int 4 0 fixnum)
(set-type-information :uint 4 1 fixnum)
(set-type-information :float 4 2 short-float)
(set-type-information :short 2 3 fixnum)
(set-type-information :uchar 1 4 fixnum)
(set-type-information :ushort 2 5 fixnum)
(set-type-information :long 4 6 fixnum)
(set-type-information :double 8 7 long-float)
(set-type-information :pointer 4 8 fixnum)
(set-type-information :string 4 9 string-char)
(set-type-information :char 1 10 fixnum)
(set-type-information :ulong 4 11 fixnum)
(set-type-information :gstring 4 12 string-char)
(set-type-information :int* 4 20 fixnum)
(set-type-information :uint* 4 21 fixnum)
(set-type-information :float* 4 22 fixnum)
(set-type-information :short* 4 23 fixnum)
(set-type-information :uchar* 4 24 fixnum)
(set-type-information :ushort* 4 25 fixnum)
(set-type-information :long* 4 26 fixnum)
(set-type-information :double* 4 27 fixnum)
(set-type-information :pointer* 4 28 fixnum)
(set-type-information :string* 4 29 fixnum)
(set-type-information :char* 4 30 fixnum)
(set-type-information :ulong* 4 31 fixnum)
(set-type-information :gstring* 4 32 fixnum)
(set-type-information :object 4 50 fixnum)
(set-type-information :object* 4 70 fixnum)
)
;;;
;;; SIZE-OF
;;; returns 8bit byte size of the given type.
;;; TYPE can be the one which defined by the def-foreign-struct.
(defmacro size-of (type)
`(if (get ,type 'is-a-structure)
(get ,type 'structure-offset)
(or (get ,type 'byte-size)
(error "Invalid type specifier ~A" ,type))))
(defmacro primitive-type? (type)
`(get ,type 'c-type-value))
(defmacro type-id-magic (type)
`(get ,type 'c-type-value))
(defmacro lisp-type (type)
`(get ,type 'lisp-type))
;;; *object-hash*
;;; Newly created foreign-structures are entried into
;;; *object-hash*, the KEY is a memory address of their body.
;;; We never make the different foreign-structure with
;;; the same body.
(defvar *object-hash* (make-hash-table))
;;;---------------------------------------------------------------------------
;;; MEMORY BLOCKS
;;;
;;; Memory Blocks are array-like blocks of memory.
;;; The current implementation of memory-blocks is as fixed typed vectors
;;; and is allocated STATICALLY in the contiguous blocks (never reallocated
;;; by the GC).
;;;
;;; This can be passed to the foreign languages directly by using Oinuma's
;;; NEW DEFENTRY macro.
;;;
;;;---------------------------------------------------------------------------
;; ;; machine dependent code
;;; BYTE-TO-CELL converts 8bit byte size into number of memory block cells.
;;;
(defun byte-to-cell (byte-size)
(floor (+ #.(1- (size-of :cell))
byte-size)
#.(size-of :cell)))
;;; MAKE-MEMORY-BLOCK number-of-elements &optional element-type
;;; creates new memory block with given number of elements of type.
;;; The ELEMENT-TYPE must be an one of
;;; :int :uint :float :short :uchar :ushort
;;; :long :double :pointer :char :ulong
;;; :int* :uint* :float* :short* :ushort*
;;; :long* :double* :pointer* :string* :char* :ulong*
;;; or an one which is previously defined by the def-forign-struct macro.
;;;
(defmacro make-memory-block (elements &optional (type :int))
`(make-array (byte-to-cell (* ,elements (size-of ,type)))
:element-type (if (primitive-type? ,type)
(lisp-type ,type)
'fixnum)
:static t))
;;;
;;; Accessing memory blocks via pointer ---------------------------------------
;;;
;;; VERY DANGEROUS!
;;; &
;;; The & operator returns the body address of a memory-block
(defmacro & (mem-block)
`(self-pointer ,mem-block))
;;; ->
;;; (-> pointer &optional type offset)
;;; A primitive for accessing via "pointer"(returned from `&' macro).
;;; This can be used for accessing an arbitrary memory block through GLASSES
;;; of specified type.
;;; For example, you can inspect an object header.(The object header address
;;; of a certain LISP object is given by the KCL function `si:address')
;;;
;;; The type argument must be an one of
;;; :int :uint :float :short :uchar :ushort
;;; :long :double :pointer :char :ulong
;;; :int* :uint* :float* :short* :ushort*
;;; :long* :double* :pointer* :string* :char* :ulong*
;;; offset IS 8bit byte size order.
(defmacro -> (pointer &optional (type :int) (offset 0))
`(pointer-ref ,pointer ,offset
,(type-id-magic type)))
;;; &->
;;; similar to ->, but accepts a memory block, not a memory block pointer
;;;
(defmacro &-> (mblock &optional (type :int) (offset 0))
`(pointer-ref (& ,mblock)
,offset
,(type-id-magic type)))
;;;
;;; C language style memory blocks accessors via pointer.
;;; All of these accept a "pointer" to a memory block object,
;;; and returns indirectly accessed object.
;;;
;;; Very dagerous of cource, use with care.
(eval-when (eval load compile)
(defun power-of-type (type)
(1- (integer-length (size-of type))))
(defmacro define-c-style-accessor (type)
(let ((accessor (intern (concatenate 'string "*"
(symbol-name type))))
(size (power-of-type type)))
`(progn
(defmacro ,accessor (pointer &optional (offset 0))
`(-> ,pointer ,,type (ash ,offset ,,size))))))
)
(eval-when (eval load)
(define-c-style-accessor :int)
(define-c-style-accessor :uint)
(define-c-style-accessor :float)
(define-c-style-accessor :short)
(define-c-style-accessor :uchar)
(define-c-style-accessor :ushort)
(define-c-style-accessor :long)
(define-c-style-accessor :ulong)
(define-c-style-accessor :double)
(define-c-style-accessor :pointer)
(define-c-style-accessor :string)
(define-c-style-accessor :gstring)
(define-c-style-accessor :char)
(define-c-style-accessor :object)
;;; Double indirection :
;;; "pointer" assumed as a pointer to a pointer to a typed memory block.
(define-c-style-accessor :int*)
(define-c-style-accessor :uint*)
(define-c-style-accessor :float*)
(define-c-style-accessor :short*)
(define-c-style-accessor :uchar*)
(define-c-style-accessor :ushort*)
(define-c-style-accessor :long*)
(define-c-style-accessor :ulong*)
(define-c-style-accessor :double*)
(define-c-style-accessor :pointer*)
(define-c-style-accessor :string*)
(define-c-style-accessor :gstring*)
(define-c-style-accessor :char*)
(define-c-style-accessor :object*)
)
;;;------------------------------------------------------------------------
;;;
;;; DEF-FOREIGN-STRUCT
;;;
;;;------------------------------------------------------------------------
;;;
;;; DEF-FOREIGN-STRUCT
;;; defines a data structure which can easily interface with
;;; foreign languages.
;;;
;;; Foreign data objects are implemeted by using MEMORY-BLOCKS with
;;; type 'fixnum as their bulding stone.
;;; Because of the performance issues, foreign-struct has two different
;;; implementation. One is, a foreign-struct which has a wrapper
;;; structure around the MEMORY-BLOCK body. This is more comfortable
;;; for interactive use, and newly defined forign-struct has its
;;; type check predicate, but aceessing foreign-struct data is less
;;; efficient because it must be accessed via a wrapping structure.
;;; Another is a foreign-struct with no wrapper, that is,
;;; pure MEMORY-BLOCK organizes the foreign-struct.
;;; The selection is controlled by the *feature* WITH-NO-WRAPPER.
;;;
;;; Def-foreign-struct provides most of the Common Lisp DEFSTRUCT's functionality.
;;; DEFSTRUCT OPTIONS
;;; :type :named defstruct options are not supported because
;;; they are meaningless in our case,
;;; and :print-function is also not supported now.
;;; Other defstruct options (:include :conc-name :constructor :copier
;;; :predicate :initial-offset)
;;; have the same syntax and semantics as of DEFSTRUCT of Common Lisp ,
;;; except that :initial-offset is in terms of 8bit byte size order,
;;; and :predicate option has no effect if foreign-struct has no wrapper
;;; structure with it.
;;;
;;; SLOT DESCRIPTIONS
;;; slot-descriptions of the def-foreign-struct is a expansion of the
;;; Common Lisp's DEFSTRUCT.
;;; Slot-descriptions of the DEFSTRUCT are all supported, and have same
;;; syntax and semantics.
;;; But, :type specifier must be
;;; (1) a one of the
;;; :int :uint :float :short :uchar :ushort
;;; :long :double :pointer :char :oulong
;;; :object
;;; (2) one which is previously defined by the def-foreign-struct,
;;; (3) pointer to the type (1)~(2),
;;; (4) and array of type (1)~(3)
;;; :type Notation
;;; foo --- type named foo
;;; foo* --- pointer to the type foo
;;; foo[n] --- array of type foo with n elements
;;;
;;; Examples of :type spec.
;;; int[10] --- denotes int array with 10 elements.
;;; char*[256] --- denotes array of pointer to the char type object
;;; with 256 elements
;;; foo --- foo is a name which previously defined by def-foreign-struct
;;; foo* --- denotes pointer to a foo type object
;;; The expansions are :
;;; :offset : specifies slot's byte offset from the head of the body.
;;; this enables us to construct a C language's UNION like
;;; data structure, and can be used as an alignment specification.
;;; :offset+ : same as :offset but offset value is counted from previous
;;; slot's position.
;;; :offset- : same as :offsewt+.
;;; The user can define his own slot access function,
;;; :get-function and :put-function provides this facility.
;;; :get-function : user defined slot value read function.
;;; the function is called with three args:
;;; the foreign-struct body, slot's byte offset and
;;; slot's type.
;;; :put-funtion : user defined slot value set function.
;;; the function called with four args:
;;; foreign-struct-body, slot's byte offset,
;;; new value, and slot's type.
;;; DEF-FOREIGN-STRUCT creates a creater, slot accessors, a predicate,
;;; and a copier function like as in DEFSTRUCT,
;;; DEF-FOREIGN-STRUCT also creates a ADDRESS function, that is,
;;; it returns the given foreign-structure's body address.
;;; The name of the ADDRESS function is the name of the foreign-structure
;;; prefixed '&'. (EX. (def-foreign-struct foo (slot1 nil :type foo*))
;;; defines the ADRESS function &foo.)
;;;; This can be used to pass a structure pointer to foreign functions.
;;;
;;; FOREIGN-OBJECT structure
;;; The Wrapper structure of a foreign-struct data object.
;;; This provides more readability for interactive usage, and
;;; type checking predicate function for defined foreign-structure,
;;; but less efficient than the one without this.
#-FI-NO-WRAPPER
(defstruct (foreign-object (:print-function pr-foreign-object))
(name nil :type string :read-only t)
(body nil ))
(eval-when (eval compile load)
#+FI-NO-WRAPPER
(defmacro foreign-object-body (x)
x)
#+FI-NO-WRAPPER
(defmacro make-foreign-object (&key name body)
(declare (ignore name))
body)
)
#-FI-NO-WRAPPER
(defun pr-foreign-object (instance stream level)
(declare (ignore level))
(format stream "#<Foreign-Data-Object ~A ~D>"
(foreign-object-name instance)
(self-pointer (foreign-object-body instance))))
;;; Function F-BODY returns a body of the foreign data object(MEMORY-BLOKS),
;;; and this can be directly passed to the foreign language using OIchan's
;;; NEW DEFENTRY facility.
;;;
#-FI-NO-WRAPPER
(eval-when (eval load compile)
(setf (macro-function 'f-body )
(macro-function 'foreign-object-body))
#+FI-NO-WRAPPER
(defmacro f-body (object)
object))
;;; SLOT-DESCRIPTION
;;; is a list of the form
;;; (SLOT-NAME DEFAULT-INIT SLOT-TYPE READ-ONLY OFFSET
;;; GET-FUNCTION PUT-FUNCTION TYPE-ID BASE-TYPE SIZE
;;; ACCESS-FUNCTION-NAME)
(defmacro slotd-name (slotd)
`(nth 0 ,slotd))
(defmacro slotd-default (slotd)
`(nth 1 ,slotd))
(defmacro slotd-type (slotd)
`(nth 2 ,slotd))
(defmacro slotd-read-only (slotd)
`(nth 3 ,slotd))
(defmacro slotd-offset (slotd)
`(nth 4 ,slotd))
(defmacro slotd-get-fun (slotd)
`(nth 5 ,slotd))
(defmacro slotd-put-fun (slotd)
`(nth 6 ,slotd))
(defmacro slotd-type-id (slotd)
`(nth 7 ,slotd))
(defmacro slotd-base-type (slotd)
`(nth 8 ,slotd))
(defmacro slotd-size (slotd)
`(nth 9 ,slotd))
(defmacro slotd-access-fun (slotd)
`(nth 10 ,slotd))
;;; This code is based on the KCL's defstruct macro of its distribution.
(defmacro DEF-FOREIGN-STRUCT (name &rest slots)
(let ((slot-descriptions slots)
options
offset
documentation)
(when (consp name)
;; The defstruct options are supplied.
(setq options (cdr name))
(setq name (car name)))
;; Skip the documentation string.
(when (and (not (endp slot-descriptions))
(stringp (car slot-descriptions)))
(setq documentation (car slot-descriptions))
(setq slot-descriptions (cdr slot-descriptions)))
;; Parse Desfstruct Options
(multiple-value-bind
(conc-name constructors copier include initial-offset predicate)
(parse-dsoptions name options)
;; Set OFFSET.
(cond ((null include)
(setq offset 0))
(t
(setq offset (get (car include) 'structure-offset))))
;; Increment OFFSET.
(when (and initial-offset)
(setq offset (+ offset initial-offset)))
;; Parse slot-descriptions, incrementing OFFSET.
(do ((ds slot-descriptions (cdr ds))
(sds nil))
((endp ds)
(setq slot-descriptions (nreverse sds)))
(setq sds (cons
(parse-foreign-struct-slot-description
(car ds) offset conc-name)
sds))
(setq offset (+ (slotd-size (car sds))
(slotd-offset (car sds)))))
;; Pad the slot-descriptions with the initial-offset number of NILs.
(when initial-offset
(setq slot-descriptions
(append (make-list initial-offset) slot-descriptions)))
;; Append the slot-descriptions of the included structure.
;; The slot-descriptions in the include option are also counted.
(cond ((null include))
((endp (cdr include))
(setq slot-descriptions
(append (rename-accessor
(get (car include) 'structure-slot-descriptions)
conc-name)
slot-descriptions)))
(t
(setq slot-descriptions
(append (overwrite-slot-descriptions
(mapcar #'(lambda (sd)
(parse-foreign-struct-slot-description
sd 0 conc-name))
(cdr include))
(rename-accessor
(get (car include) 'structure-slot-descriptions)
conc-name))
slot-descriptions))))
(when include (setq include (car include)))
`(progn (si:putprop ',name
'(defstruct ,name ,@slots)
'defstruct-form)
(si:putprop ',name t 'is-a-structure)
(si:putprop ',name
',slot-descriptions
'structure-slot-descriptions)
(si:putprop ',name ',include 'structure-include)
(si:putprop ',name ',conc-name 'structure-conc-name)
,@(mapcan #'(lambda (x)
(if (and x (car x))
(funcall #'make-foreign-struct-access-function
name
x)))
slot-descriptions)
(si:putprop ',name ,(compute-struct-offset slot-descriptions)
'structure-offset)
,@(mapcar #'(lambda (constructor)
(make-foreign-struct-constructor name constructor
slot-descriptions))
constructors)
(si:putprop ',name ',constructors 'structure-constructors)
,@(if copier
(list (make-foreign-struct-copier name copier)))
#-FI-NO-WRAPPER
,@(if predicate
(list (make-foreign-struct-predicate name predicate)))
(si:putprop ',name ,documentation 'structure-documentation)
',name))))
;;;
;;; PARSE-DSOPTIONS
;;; parsing def-foreign-struct options and returns multiple values
;;; CONC-NAME CONSTTUCTORS COPIER INCLUDE INITIAL-OFFSET PREDICATE
(defun parse-dsoptions (name options)
(let ((conc-name (si:string-concatenate (string name) "-"))
(default-constructor
(intern (si:string-concatenate "MAKE-" (string name))))
(copier (intern (si:string-concatenate "COPY-" (string name))))
(predicate (intern (si:string-concatenate (string name) "-P")))
constructors no-constructor include initial-offset)
;; Parse the defstruct options.
(do ((os options (cdr os))
(o)
(v))
((endp os))
(cond ((and (consp (car os)) (not (endp (cdar os))))
(setq o (caar os) v (cadar os))
(case o
(:conc-name
(if (null v)
(setq conc-name "")
(setq conc-name v)))
(:constructor
(if (null v)
(setq no-constructor t)
(if (endp (cddar os))
(setq constructors (cons v constructors))
(setq constructors (cons (cdar os) constructors)))))
(:copier (setq copier v))
(:predicate
(setq predicate v))
(:include
(setq include (cdar os))
(unless (get v 'is-a-structure)
(error "~S is an illegal included structure." v)))
(:initial-offset (setq initial-offset v))
(t (error "~S is an illegal def-foreign-struct option." o))))
(t
(if (consp (car os))
(setq o (caar os))
(setq o (car os)))
(case o
(:constructor
(setq constructors
(cons default-constructor constructors)))
((:conc-name :copier :predicate :print-function))
(t (error "~S is an illegal def-foreign-struct option." o))))))
(cond (no-constructor
;; If a constructor option is NIL,
;; no constructor should have been specified.
(when constructors
(error "Contradictory constructor options.")))
((null constructors)
;; If no constructor is specified,
;; the default-constructor is made.
(setq constructors (list default-constructor))))
(values conc-name constructors copier include initial-offset predicate)))
;;;
;;; PARSE-FOREIGN-STRUCT-SLOT-DESCRIPTION parses the given slot-description
;;; and returns a SLOT-DESCRIPTION
;;;
(defun parse-foreign-struct-slot-description (slot-description offset conc-name)
(let (slot-name
default-init
(slot-type 'int)
read-only
get-function
put-function
detailed-type-spec)
(cond ((atom slot-description)
(setq slot-name slot-description))
((endp (cdr slot-description))
(setq slot-name (car slot-description)))
(t
(setq slot-name (car slot-description))
(setq default-init (cadr slot-description))
(do ((os (cddr slot-description) (cddr os)) (o) (v))
((endp os))
(setq o (car os))
(when (endp (cdr os))
(error "~S is an illegal structure slot option."
os))
(setq v (cadr os))
(case o
(:type (setq slot-type v))
(:read-only (setq read-only v))
(:offset (setq offset v))
(:offset+ (setq offset (+ offset v)))
(:offset- (setq offset (- offset v)))
(:get-function (setq get-function
(if (and (consp v)
(eq (car v) 'function))
v
(list 'function v))))
(:put-function (setq put-function
(if (and (consp v)
(eq (car v) 'function))
v
(list 'function v))))
(t
(error "~S is an illegal structure slot option."
os))))))
(setq detailed-type-spec
(scan-type-spec slot-type))
(append (list slot-name default-init slot-type read-only offset
get-function put-function)
detailed-type-spec
(list (make-access-fun-name conc-name slot-name detailed-type-spec)))))
;;; SCAN-TYPE-SPEC
;;; scans the type specification and returns the list
;;; of the form (type-id base-type size).
;;; ** type-id is one of :primitive :structure :array
;;; :structure-pointer :array-pointer :primitive-pointer
;;; ** base type is meaningful iff type-id is :array,
;;; :structure-pointer :array-pointer ,or :primitive-pointer
;;; and specifies array of WHAT or pointer to WHAT type.
;;;
(defun scan-type-spec (type-spec)
(let ((type-spec-string (symbol-name type-spec))
type-id
base-type
size)
(when (pointer-form? type-spec-string)
(setq size (size-of :pointer))
(setq type-spec-string
(subseq type-spec-string 0
(search "*" type-spec-string :from-end t))))
(cond ((array-form? type-spec-string)
(setq base-type (base-name type-spec-string "["))
(if (null size)
;; pure array
(setq type-id :array
size (* (size-of base-type)
(get-array-size type-spec-string)))
;; array-pointer
(setq type-id :array-pointer)))
((primitive-type? type-spec)
(setq base-type (intern type-spec-string (find-package "KEYWORD")))
(if size
;; pointer to primitive type
(setq type-id :primitive-pointer)
;; primitive
(setq type-id :primitive
size (size-of base-type))))
(t
;; may be a structure or pointer to a structure
(setq base-type (intern type-spec-string))
(if size
;; pointer to a structure
(setq type-id :structure-pointer)
;; structure included
(setq type-id :structure
size (size-of base-type)))))
(list type-id base-type size)))
(defun pointer-form? (t-str)
(char= #\* (elt (reverse t-str) 0)))
(defun array-form? (t-str)
(char= #\] (elt (reverse t-str) 0)))
(defun base-name (name-string delimitter)
(let ((pos (search delimitter name-string :from-end t)))
(if pos
(intern (subseq name-string 0 pos)(find-package "KEYWORD")))))
(defun get-array-size (array-definition)
(let ((st (search "[" array-definition :from-end t))
(end (search "]" array-definition :from-end t)))
(read-from-string (subseq array-definition (1+ st) end ))))
;;; OVERWRITE-SLOT-DESCRIPTIONS overwrites the old slot-descriptions
;;; with the new descriptions which are specified in the
;;; :include defstruct option.
(defun overwrite-slot-descriptions (news olds)
(if (null olds)
nil
(let ((sds (member (slotd-name (car olds)) news :key #'car)))
(cond (sds
(when (and (null (slotd-read-only (car sds)))
(slotd-read-only (car olds)))
;; If read-only is true in the old
;; and false in the new, signal an error.
(error "~S is an illegal include slot-description."
sds))
(cons (list (slotd-name (csr sds))
(slotd-default (car sds))
(slotd-type (car sds))
(slotd-read-only (car sds))
(slotd-offset (car olds)) ; The offset is from the old.
(slotd-type-id (car sds))
(slotd-base-type (car sds))
(slotd-size (car sds))
(slotd-access-fun (car sds)))
(overwrite-slot-descriptions news (cdr olds))))
(t
(cons (car olds)
(overwrite-slot-descriptions news (cdr olds))))))))
(defun rename-accessor (slotds conc-name)
(mapcar #'(lambda (slotd)
(setq slotd (copy-tree slotd))
(setf (car (last slotd))
(make-access-fun-name conc-name (slotd-name slotd)))
slotd)
slotds))
;;;
;;; MAKE-ACCESS-FUN-NAME
;;;
(defun make-access-fun-name (conc-name slot-name &rest type-specs)
(declare (ignore type-specs))
(intern (si:string-concatenate (string conc-name)
(string slot-name))))
;;;;;
;;; Slot Access-Function Creators
;;;;;
;;;
;;; MAKE-FOREIGN-STRUCT-ACCESS-FUNCTION
;;;
(defun make-foreign-struct-access-function (name slotd)
(list* (make-access-form name slotd)
`(defun ,(make-address-fun-name name)(x)
(self-pointer (foreign-object-body x)))
(if (not (slotd-read-only slotd))
(list (make-access-form-setf name slotd))
;; Removing the DEFSETF definitions.
;; This code is implementation-dependent.
(list `(remprop ',(slotd-access-fun slotd) 'setf-update-fn)
`(remprop ',(slotd-access-fun slotd) 'setf-lambda)
`(remprop ',(slotd-access-fun slotd)
'setf-documentation)))))
(defun make-address-fun-name (name)
(intern (format nil "&~A" (symbol-name name)) (symbol-package name)))
;;;
;;; make-access-form
;;; creates slot value retract form
(defun make-access-form (name slotd)
(declare (ignore name))
(let* ((fun-name (slotd-access-fun slotd))
(offset (slotd-offset slotd))
(base-type (slotd-base-type slotd))
(type-num (type-id-magic base-type)))
(if (slotd-get-fun slotd)
`(defun ,fun-name (x)
(funcall ,(slotd-get-fun slotd) x ,offset))
(case (slotd-type-id slotd)
((:primitive)
`(defun ,fun-name (x)
(c-aref (foreign-object-body x) ,offset ,type-num)))
((:structure )
`(defun ,fun-name (x)
(make-foreign-struct-with-object
',base-type
(c-aref (foreign-object-body x) ,offset ,(type-id-magic :pointer)))))
((:array)
`(defun ,fun-name (x)
(make-foreign-struct-with-object
',base-type
(c-aref (foreign-object-body x) ,offset ,(type-id-magic :pointer))
:size ,(slotd-size slotd))))
((:primitive-pointer)
`(progn
(defun ,fun-name (x)
(c-aref (foreign-object-body x) ,(slotd-offset slotd)
,(type-id-magic :pointer)))
(defun
,(make-access-fun-name-stared fun-name)
(x)
(c-aref (foreign-object-body x) ,(slotd-offset slotd) ,(+ 20 type-num)))))
((:structure-pointer)
`(progn
(defun ,fun-name (x)
(c-aref (foreign-object-body x) ,offset ,(type-id-magic :pointer)))
(defun
,(make-access-fun-name-stared fun-name)
(x)
(make-foreign-struct-with-object
',base-type
(c-aref (foreign-object-body x) ,offset ,(type-id-magic :pointer))))))
((:array-pointer)
`(progn
(defun ,fun-name (x)
(c-aref (foreign-object-body x) ,offset ,(type-id-magic :pointer)))
(defun ,(make-access-fun-name-stared fun-name)
(x)
(make-foreign-struct-with-object
',base-type
(c-aref (foreign-object-body x) ,offset ,(type-id-magic :pointer))
:size ,(slotd-size slotd)))))))))
(defun make-access-form-setf (name slotd)
(declare (ignore name))
(let ((fun-name (slotd-access-fun slotd))
(offset (slotd-offset slotd))
(type-num (type-id-magic (slotd-base-type slotd))))
(if (slotd-put-fun slotd)
`(defsetf ,fun-name (x) (v)
`(funcall ,',(slotd-put-fun slotd) ,x ,,offset ,v))
(case (slotd-type-id slotd)
((:primitive)
`(defsetf ,fun-name (x)(v)
`(c-aset (foreign-object-body ,x)
,,offset ,,type-num ,v)))
((:primitive-pointer)
`(progn
(defsetf ,fun-name (x)(v)
`(c-aset (foreign-object-body ,x) ,,offset ,(type-id-magic :pointer) ,v))
(defsetf ,(make-access-fun-name-stared fun-name) (x) (v)
`(c-aset (foreign-object-body ,x) ,,offset ,,(+ 20 type-num) ,v))))
((:structure )
`(defsetf ,fun-name (x)(v)
`(do* ((offset ,,(byte-to-cell offset) (1+ offset)) ; must be 32bit word boundary!
(body (foreign-object-body ,x))
(body-address (& body))
(s-body (foreign-object-body ,v))
(s-body-address (& s-body))
(s-offset 0 (1+ s-offset))
(cnt (length s-body)(1- cnt)))
((= cnt 0)
(make-foreign-struct-with-object
#-FI-NO-WRAPPER (foreign-object-name ,v)
#+FI-NO-WRAPPER ,(quote ',(slotd-type slotd))
(c-aref body ,,offset
,,(type-id-magic :pointer))
:reuse nil))
(setf (*int body-address offset)
(*int s-body-address s-offset)))))
((:array)
`(defsetf ,fun-name (x)(v)
`(do* ((offset ,,(byte-to-cell offset) (1+ offset));; must 32bit word boundary !
(body-address (& (foreign-object-body ,x)))
(s-body-address (& (foreign-object-body ,v)))
(s-offset 0 (1+ s-offset))
(cnt (length s-body) (1- cnt)))
((= cnt 0) ,v)
(setf (*int body-address offset)
(*int s-body-address s-offset)))))
((:structure-pointer)
`(progn
(defsetf ,fun-name (x)(v)
`(c-aset (foreign-object-body ,x) ,,offset ,,(type-id-magic :pointer) ,v))
(defsetf
,(make-access-fun-name-stared fun-name)
(x)(v)
`(c-aset (foreign-object-body ,x) ,,offset ,,(type-id-magic :pointer)
(self-pointer ,v)
))))
((:array-pointer)
`(progn
(defsetf ,fun-name (x)(v)
`(c-aset (foreign-object-body ,x) ,,offset ,,(type-id-magic :pointer) ,v))
(defsetf ,(make-access-fun-name-stared fun-name)
(x)(v)
`(c-aset (foreign-object-body ,x) ,,offset
,,(type-id-magic :pointer)
(self-pointer ,v)))))))))
(defun make-access-fun-name-stared (fun-name)
(intern (format nil "*~A" (symbol-name fun-name))))
;;;
;;; make-foreign-struct-predicate
;;;
(defun make-foreign-struct-predicate (name predicate)
;; The predicate searches the link
;; of structure-include, until there is no included structure.
`(defun ,predicate (x)
(and (si:structurep x)
(do ((n (foreign-object-name x)))
((null n) nil)
(when (eq n ',name) (return t))
(setq n (get n 'structure-include))))))
;;;;;;
;;; Foreign-Struct constructor constructor
;;;;;;
;;; most parts of this code is lifted from KCL's.
(defun make-foreign-struct-constructor (name constructor
slot-descriptions)
(let ((slot-names
;; Collect the slot-names.
(mapcar #'(lambda (x)
(cond ((null x)
;; If the slot-description is NIL,
;; it is in the padding of initial-offset.
nil)
((null (slotd-name x))
;; If the slot name is NIL,
;; it is the structure name.
;; This is for typed structures with names.
(list 'quote (cadr x)))
(t (slotd-name x))))
slot-descriptions))
(keys
;; Make the keyword parameters.
(mapcan #'(lambda (x)
(cond ((null x) nil)
((null (slotd-name x)) nil)
((null (slotd-default x)) (list (slotd-name x)))
(t (list (list (slotd-name x) (slotd-default x))))))
slot-descriptions)))
(cond ((consp constructor)
;; The case for a BOA constructor.
;; Dirty code!!
;; We must add an initial value for an optional parameter,
;; if the default value is not specified
;; in the given parameter list and yet the initial value
;; is supplied in the slot description.
(do ((a (cadr constructor) (cdr a)) (l nil) (vs nil))
((endp a)
;; Add those options that do not appear in the parameter list
;; as auxiliary paramters.
;; The parameters are accumulated in the variable VS.
(setq keys
(nreconc (cons '&aux l)
(mapcan #'(lambda (k)
(if (member (if (atom k) k (car k))
vs)
nil
(list k)))
keys))))
;; Skip until &OPTIONAL appears.
(cond ((eq (car a) '&optional)
(setq l (cons '&optional l))
(do ((aa (cdr a) (cdr aa)) (ov) (y))
((endp aa)
;; Add those options that do not appear in the
;; parameter list.
(setq keys
(nreconc (cons '&aux l)
(mapcan #'(lambda (k)
(if (member (if (atom k)
k
(car k))
vs)
nil
(list k)))
keys)))
(return nil))
(when (member (car aa) lambda-list-keywords)
(when (eq (car aa) '&rest)
;; &REST is found.
(setq l (cons '&rest l))
(setq aa (cdr aa))
(unless (and (not (endp aa))
(symbolp (car aa)))
(illegal-boa))
(setq vs (cons (car aa) vs))
(setq l (cons (car aa) l))
(setq aa (cdr aa))
(when (endp aa)
(setq keys
(nreconc
(cons '&aux l)
(mapcan
#'(lambda (k)
(if (member (if (atom k)
k
(car k))
vs)
nil
(list k)))
keys)))
(return nil)))
;; &AUX should follow.
(unless (eq (car aa) '&aux)
(illegal-boa))
(setq l (cons '&aux l))
(do ((aaa (cdr aa) (cdr aaa)))
((endp aaa))
(setq l (cons (car aaa) l))
(cond ((and (atom (car aaa))
(symbolp (car aaa)))
(setq vs (cons (car aaa) vs)))
((and (symbolp (caar aaa))
(or (endp (cdar aaa))
(endp (cddar aaa))))
(setq vs (cons (caar aaa) vs)))
(t (illegal-boa))))
;; End of the parameter list.
(setq keys
(nreconc l
(mapcan
#'(lambda (k)
(if (member (if (atom k)
k
(car k))
vs)
nil
(list k)))
keys)))
(return nil))
;; Checks if the optional paramter without a default
;; value has a default value in the slot-description.
(if (and (cond ((atom (car aa)) (setq ov (car aa)) t)
((endp (cdar aa)) (setq ov (caar aa)) t)
(t nil))
(setq y (member ov
keys
:key
#'(lambda (x)
(if (consp x)
;; With default value.
(car x))))))
;; If no default value is supplied for
;; the optional parameter and yet appears
;; in KEYS with a default value,
;; then cons the pair to L,
(setq l (cons (car y) l))
;; otherwise cons just the parameter to L.
(setq l (cons (car aa) l)))
;; Checks the form of the optional parameter.
(cond ((atom (car aa))
(unless (symbolp (car aa))
(illegal-boa))
(setq vs (cons (car aa) vs)))
((not (symbolp (caar aa)))
(illegal-boa))
((or (endp (cdar aa)) (endp (cddar aa)))
(setq vs (cons (caar aa) vs)))
((not (symbolp (caddar aa)))
(illegal-boa))
((not (endp (cdddar aa)))
(illegal-boa))
(t
(setq vs (cons (caar aa) vs))
(setq vs (cons (caddar aa) vs)))))
;; RETURN from the outside DO.
(return nil))
(t
(unless (symbolp (car a))
(illegal-boa))
(setq l (cons (car a) l))
(setq vs (cons (car a) vs)))))
(setq constructor (car constructor)))
(t
;; If not a BOA constructor, just cons &KEY.
(setq keys (cons '&key keys))))
#-FI-NO-WRAPPER
`(defun ,constructor ,keys
(let ((instance (make-foreign-object :name ',name
:body (make-memory-block 1 ',name))))
(setf (gethash (self-pointer (foreign-object-body instance))
*object-hash*)
instance)
,@(create-initialize-form 'instance slot-descriptions slot-names)
instance))
#+FI-NO-WRAPPER
`(defun ,constructor ,keys
(let ((instance (make-memory-block 1 ',name)))
(setf (gethash (self-pointer instance) *object-hash*)
instance)
,@(create-initialize-form 'instance slot-descriptions slot-names)
instance))
))
(defun illegal-boa ()
(error "An illegal BOA constructor."))
(defun compute-struct-offset (slotds)
(let ((max-offset -1))
(dolist (slotd slotds)
(if (> (+ (slotd-offset slotd)
(slotd-size slotd))
max-offset)
(setq max-offset (+ (slotd-offset slotd)
(slotd-size slotd)))))
max-offset))
(defun create-initialize-form (inst-sym slotds contents)
(do* ((init-form nil)
(slotds slotds (cdr slotds))
(slotd (car slotds) (car slotds))
(access-fun (slotd-access-fun slotd)
(slotd-access-fun slotd))
(contents contents (cdr contents))
(value (car contents) (car contents)))
((endp slotds) init-form)
(push `(if ,value
(setf (,access-fun ,inst-sym) ,value))
init-form)))
(defun make-foreign-struct-copier (name copier)
(declare (ignore name))
`(defun ,copier (x) (copy-seq (f-body x))))
;;;-----------------------------------------------------------------------------
;;; Map-Foreign-Struct foreign-struct-name lisp-object
;;; maps foreign-structure templete to exisiting object.
;;; returns a instance of specified foreign-struct which contains
;;; given lisp-object as a body.
;;;------------------------------------------------------------------------------
(defun map-foreign-struct (name object &optional size)
(map-foreign-struct* name (si:address object) size))
;;;-----------------------------------------------------------------------------
;;; Map-Foreign-Struct* foreign-struct-name object-address
;;; similar to `map-foreign-struct' but accepts address of the object
;;;-----------------------------------------------------------------------------
(defun map-foreign-struct* (name obj-adrs &optional size)
(let* ((alloc-size (if size size (size-of name)))
(body (make-memory-block 0 name))
(instance (make-foreign-object :name name
:body body)))
(setf (gethash obj-adrs *object-hash*) instance)
(rebind-self body obj-adrs (byte-to-cell alloc-size))
instance))
;;;-----------------------------------------------------------------------------
;;; Make-Foreign-Struct-With-Object
;;; given a memory block address pointer, cretes a new foreign-structure.
;;;
;;; if :reuse option is nil and there already exists the memory block
;;; with same memory block object as its body,
;;; the memory block is retracted from *object-hash*.
;;;
;;; size is 8bit byte size order, and round up to CELL size.
;;;------------------------------------------------------------------------------
(defun make-foreign-struct-with-object (type address &key (size #.(size-of :cell)) (reuse t))
(or (and reuse (gethash address *object-hash*))
(let* ((body (make-memory-block 0 type))
(instance (if (get type 'is-a-structure)
(make-foreign-object :name type
:body body)
body)))
(setf (gethash address *object-hash*) instance)
(rebind-self body address (byte-to-cell size))
instance)))
;;;
;;; Rebind-Self
;;;
(defun rebind-self (instance pointer &optional (size 1))
(remhash (self-pointer instance) *object-hash*)
(rebind-self-internal instance pointer size))
;;;
;;; DEFINE-CVAR-ACCESSOR
;;;
;;; (define-cvar-accessor lisp-sym foreign-var-entry-name type)
;;; lisp-sym : symbol
;;; foreign-var-entry : string
;;; type :string
(defmacro define-cvar-accessor (lisp-sym foreign-var &optional (type "int"))
(let ((setf (intern (concatenate 'string "SET-" (string lisp-sym))
(symbol-package lisp-sym)))
(cgetf (format nil "fi_get_~A_~A" lisp-sym type))
(csetf (format nil "fi_set_~A_~A" lisp-sym type))
(vtype (intern (string-upcase type))))
`(progn
(CLINES
,(format nil "~A ~A () { return ~A ; }~%"
type
cgetf
foreign-var)
,(format nil "~A ~A (new) ~%~
~A new; ~%~
{ return ~A = new; } ~%"
type csetf type foreign-var))
(DEFENTRY ,lisp-sym () (,vtype ,cgetf))
(DEFENTRY ,setf (,vtype) (,vtype ,csetf))
(DEFSETF ,lisp-sym ,setf))))
;;;
;;; copy-subsequence to start1 end1 from start2
;;;
(defentry copy-subsequence (object int int object int) (void copy_subsequence))
@//E*O*F foreign.lsp//
chmod u=rw,g=rw,o=r foreign.lsp
exit 0 From: Toshimi sawada
Subject: Re: KCL question
Date: Wed, 02 May 1990 11:38:53 +0000
Message-ID: <42367@etlcom.etl.go.jp> | I received some requests to post my package.
|
| This is a package for (Austin)KCl which offers foreign data interface
| facilities. It is far from sofisticated, but it works well and is
| useful (at least for me).
I forgot an example program showing how to use the package.
Thanks those who asked me "How should I use this pacage?"
Sorry, but there is not a documentation.
Comments, suggestions, and questions are welcom, mail me please.
-----------------------<cut here>--------------------------------
;;; -*- Mode: LISP; Syntax: Common-lisp; Package: USER; Base: 10 -*-
(use-package :FI)
;;; NOTE: This test only works on AKCL 1.465 - ??
;;; defininig some internal data structures of AKCL
(def-foreign-struct FIRSTWORD
(type 0 :type :short)
(mark 0 :type :short))
(def-foreign-struct (%fixnum (:include firstword))
(fixval 0 :type :int))
(def-foreign-struct (%long-float (:include firstword))
(lfval 0.0 :type :double))
(def-foreign-struct (%symbol (:include firstword))
(dbind 0 :type :object)
(sfdef 0 :type :int)
(fillp 0 :type :int)
(self 0 :type :string)
(gfdef 0 :type :object)
(plist 0 :type :object)
(hpack 0 :type :object)
(stype 0 :type :short)
(mflag 0 :type :short))
(def-foreign-struct (%package (:include firstword))
(name 0 :type :object)
(nickname 0 :type :object)
(shadowings 0 :type :object)
(uselist 0 :type :object)
(usedbylist 0 :type :object)
(internal 0 :type :object*)
(external 0 :type :object*)
(internal-size 0 :type :int)
(external-size 0 :type :int)
(internal-fp 0 :type :int)
(external-fp 0 :type :int)
(package 0 :type :pointer))
(def-foreign-struct (%cfdata (:include firstword))
(start 0 :type :char*)
(size 0 :type :int)
(fillp 0 :type :int)
(self 0 :type :object))
(def-foreign-struct (%cfun (:include firstword))
(name 0 :type :object)
(self 0 :type :int)
(data 0 :type %cfdata))
(def-foreign-struct (%cclosure (:include firstword))
(name 0 :type :object)
(self 0 :type :int)
(env 0 :type :object)
(data 0 :type :object)
(turbo 0 :type :object))
(def-foreign-struct (%sfun (:include firstword))
(name 0 :type :object)
(self 0 :type :int)
(data 0 :type :object)
(argd 0 :type :int))
(def-foreign-struct (%vfun (:include firstword))
(name 0 :type :object)
(self 0 :type :int)
(data 0 :type :object)
(minargs 0 :type :ushort)
(maxargs 0 :type :ushort))
#| test tes test .....
(setq int (map-foreign-struct '%fixnum-struct 10))
(%fixnum-fixval int)
(setq float (map-foreign-struct %long-float 1.234))
(%long-floatl-fval float)
;;;;
(setq car (map-foreign-struct %symbol 'car))
(%symbol-type car)
(%symbol-mark car)
(%symbol-dbind car)
(%symbol-sfdef car)
(%symbol-fillp car)
(%symbol-self car)
(%symbol-gfdef car)
(%symbol-plist car)
(%symbol-hpack car)
(%symbol-stype car)
(%symbol-mflag car)
(setq foo (map-foreign-struct '%symbol 'foo))
(setf (%symbol-gfdef foo) (%symbol-gfdef car))
(foo '(1 2 3 4))
(setq bar (map-foreign-struct '%package (find-package "FI")))
(%package-name bar)
(%package-nickname bar)
(%package-shadowings bar)
(%package-uselist bar)
(%package-uselist bar)
(%package-usedbylist bar)
(%package-internal bar)
(%package-external bar)
(*%package-internal bar)
(*%package-external bar)
(%package-internal-size bar)
(%package-external-size bar)
(%package-internal-fp bar)
(%package-external-fp bar)
(%package-package bar)
(setq baz (make-foreign-struct* '%package (%package-package bar)))
(%package-name baz)
;;;
(setq x (map-foreign-struct '%cfun (symbol-function 'map-foreign-struct)))
(%cfun-name x)
(%cfun-self x)
(setq y (%cfun-data x))
(%cfdata-start y)
(%cfdata-size y)
(%cfdata-fillp y)
(%cfdata-self y)
|#
--
Toshimi Sawada
Software Reserach Associates Inc.
on leave at Computer Language Section, Electrotechnical Laboratory
1-1-4 Umezono, Tsukuba, Ibaraki 305, JAPAN
TEL: +81 298 58 5890
E-Mail: ······@etl.go.jp From: Toshimi sawada
Subject: Re: KCL question
Date: Fri, 27 Apr 1990 12:09:15 +0000
Message-ID: <42240@etlcom.etl.go.jp> Here is a socket i/o package for (A)KCl.
If you have any questions, and suggestion, please mail me.
--
Toshimi Sawada
Software Reserach Associates Inc.
on leave at Computer Language Section, Electrotechnical Laboratory
1-1-4 Umezono, Tsukuba, Ibaraki 305, JAPAN
TEL: +81 298 58 5890
E-Mail: ······@etl.go.jp
-----------------------------------<cut>----------------------------
# This is a shell archive. Remove anything before this line,
# then unpack it by saving it in a file and typing "sh file".
#
# Wrapped by on Thu Apr 26 21:27:04 JST 1990
# Contents: unix-ipc.lsp unix_io.c defentry+.lsp test.lsp
echo x - unix-ipc.lsp
sed ····@//' > "unix-ipc.lsp" <<·@//E*O*F unix-ipc.lsp//'
;;;-*- Mode:Lisp; Syntax:Common-lisp; Package:UNIX -*-
;;;
;;; UNIX raw I/O package for KCl
;;;
;;; Copyright (c) Toshimi Sawada.
;;; Permission to use, copy, modify, and distribute this software for any
;;; purpose is hereby granted without fee.
;;; ······@sra.co.jp
;;;
;;; USAGE: compile this file and load with
;;; (si:faslink "unix-ipc.o" "unix_io.o -lc")
;;;
(in-package "UNIX")
;;; uses extension of defentry macro.
(require 'compiler::defentry+)
(export '(connect-to-server
open-tcp-stream
make-socket-stream
make-sockaddr
address-family
address-port
address-address
connect-socket-stream
bind-socket-stream
listen-socket-stream
accept-socket-stream
get-sockname
get-peername
set-sockopt
perror
fd->output-stream
fd->input-stream
fd->io-stream
stream-fd
stream-fp
two-way->output-stream
two-way->input-stream
peek-input-stream
define-selector
unix-select
select-input-stream
fcntl))
;;;
;;; Socket Address families.
;;;
(defconstant family-table
(vector
:AF-UNSPEC ; unspecified
:AF-UNIX ; local to host (pipes, portals)
:AF-INET ; internetwork: UDP, TCP, etc.
:AF-IMPLINK ; arpanet imp addresses
:AF-PUP ; pup protocols: e.g. BSP
:AF-CHAOS ; mit CHAOS protocols
:AF-NS ; XEROX NS protocols
:AF-NBS ; nbs protocols
:AF-ECMA ; european computer manufacturers
:AF-DATAKIT ; datakit protocols
:AF-CCITT ; CCITT protocols, X.25 etc
:AF-SNA ; IBM SNA
:AF-DECNET ; DECnet
:AF-DLI ; Direct data link interface
:AF-LAT ; LAT
:AF-HYLINK ; NSC Hyperchannel
:AF-APPLETALK ; Apple Talk
:AF-NIT ; Network Interface Tap
:AF-802 ; IEEE 802.2, also ISO 8802
:AF-OSI ; umbrella for all families used by OSI
:AF-X25 ; CCITT X.25 in particular
:AF-OSINET ; AFI = 47, IDI = 4
:AF-GOSIP ; U.S. Goverment OSI
:AF-MAX ;
))
;;;
;;; Socket Types
;;;
(defconstant type-table
(vector
'DUMMY
:SOCK-STREAM ; stream socket
:SOCK-DGRAM ; datagram socket
:SOCK-RAW ; raw-protocol interface
:SOCK-RDM ; reliably-delivered message
:SOCK-SEQPACKET ; sequenced packet stream
))
;;;
;;; Socket Protocol families, same as address families for now.
;;;
(defconstant protocol-table
(vector
:PF-UNSPEC
:PF-UNIX
:PF-INET
:PF-IMPLINK
:PF-PUP
:PF-CHAOS
:PF-NS
:PF-NBS
:PF-ECMA
:PF-DATAKIT
:PF-CCITT
:PF-SNA
:PF-DECNET
:PF-DLI
:PF-LAT
:PF-HYLINK
:PF-APPLETALK
:PF-NIT
:PF-802
:PF-OSI
:PF-X25
:PF-OSINET
:PF-GOSIP
:PF-MAX
))
;;;
;;; Option flags per-socket.
;;;
(eval-when (eval load)
(setf (get :SO-DEBUG 'sockopt) #x01) ;turn on debugging info recording
(setf (get :SO-ACCEPTCONN 'sockopt) #x02) ;socket has had listen()
(setf (get :SO-REUSEADDR 'sockopt) #x04) ;allow local address reuse
(setf (get :SO-KEEPALIVE 'sockopt) #x08) ;keep connections alive
(setf (get :SO-DONTROUTE 'sockopt) #x10) ;just use interface addresses
; #x20 was SO-NEWFDONCONN
(setf (get :SO-USELOOPBACK 'sockopt) #x40) ;bypass hardware when possible
(setf (get :SO-LINGER 'sockopt) #x80) ;linger on close if data present
(setf (get :SO-DONTLINGER 'sockopt) (lognot #x80)) ;~SO-LINGER
(setf (get :SO-OOBINLINE 'sockopt) #x100) ; leave received OOB data in line
)
;;;
;;; SADDRESS:
;;; Socket Address structure
;;;
(defstruct (saddress (:constructor create-sockaddr)
(:print-function pr-saddr))
(sockaddr)
(addr-len))
(defun pr-saddr (saddr stream level)
(declare (ignore level))
(format stream "#<SockAddr Family:~A Port:~A Address:~A>"
(address-family saddr)
(address-port saddr)
(address-address saddr)))
;;;
;;; MAKE-SOCKADDR host port
;;; Creates new sockaddr object.
;;; args host : (or string null), host name, nil means "unix" domain socket.
;;; host name can be a ip address (i.e., a.b.c.d).
;;; port : (or integer string), port number in decimal, if host is nil then
;;; port shold be a path name (string).
(defentry make-sockaddr-internal (string string object)
(int "make_sockaddr"))
(defun make-sockaddr (host port)
;; CAUTION!!
;; current implementation allocates sockaddr as array of size 32 words at static area.
(let ((sockaddr (make-array 32 :element-type 'fixnum :static t))
(addrlen nil))
(if (and (null host)
(stringp port))
;; unix domain socket.
(setq addrlen (make-sockaddr-internal "" port sockaddr))
;; inter net domain.
(if (not (integerp port))
(error "Ivalid Port ~A for host ~A" port host)
(setq addrlen (make-sockaddr-internal host
(int->string port)
sockaddr))))
(create-sockaddr :sockaddr sockaddr :addr-len addrlen)))
(defun int->string (num)
(do ((inum num (floor inum 10))
(str nil))
((< inum 10) (progn
(push (code-char
(+ (char-code #\0)inum)) str)
(coerce str 'string)))
(push (code-char (+ (char-code #\0) (rem inum 10))) str)))
;;; THE-EMPTY-SOCKADDR &optional length
;;; creates empty sockaddr with length 'length'.
;;;
(defun the-empty-sockaddr (&optional (length 32))
(let ((sockaddr (make-array length :element-type 'fixnum :static t)))
(create-sockaddr :sockaddr sockaddr :addr-len (* 4 length))))
;;;
;;; ADDRESS-FAMILY sockaddr
;;; Given a SOCKADDR (saddr structure) returns its address_family slot.
;;;
(defentry address-family-internal (object) (int "address_family"))
(defun address-family (saddr)
(let ((family (address-family-internal (saddress-sockaddr saddr))))
(aref family-table family)))
;;;
;;; ADDRESS-PORT sockaddr
;;; returns port of the sockaddr.
(defentry port-internal (object) (object "port_internal"))
(defun address-port (saddr)
(port-internal (saddress-sockaddr saddr)))
;;;
;;; ADDRESS-ADDRESS sockaddr
;;;
(defentry address-internal (object) (object "address_internal"))
(defun address-address (saddr)
(address-internal (saddress-sockaddr saddr)))
;;;
;;; GET-SOCKNAME socket-stream address
;;;
(defentry get-sockname-internal (object object int) (int "get_sock_name_internal"))
(defun get-sockname (sock-stream saddr)
(get-sockname-internal sock-stream
(saddress-sockaddr saddr)
(saddress-addr-len saddr)))
;;;
;;; GET-PEERNAME socket-stream saddress
;;;
(defentry get-peername-internal (object object int) (int "get_peer_name_internal"))
(defun get-peername (sock-stream saddr)
(get-peername-internal sock-stream
(saddress-sockaddr saddr)
(saddress-addr-len saddr)))
;;;
;;; MAKE-SOCKET-STREAM addres-family socket-type &optional protocol
;;; creates a two-way stream object which holds unix socket
;;;
(defentry make-socket-stream-internal
(int int int) (object "make_socket_stream"))
(defun make-socket-stream (af type &optional (protocol :pf-unspec))
(make-socket-stream-internal
(position af family-table)
(position type type-table)
(position protocol protocol-table)))
;;;
;;; CONNECT-SOCKET-STREAM socket-stream address &optional ignore-sigpipe
;;; connect socket to address.
(defentry connect-socket-internal
(object object int bool) (object "connect_socket"))
(defun connect-socket-stream (socket-stream address &optional (ignore-sigpipe nil))
(connect-socket-internal socket-stream
(saddress-sockaddr address)
(saddress-addr-len address)
ignore-sigpipe))
;;;
;;; BIND-SOCKET-STREAM socket-stream address
;;; bind socket with address.
(defentry bind-socket-internal (object object int) (object "bind_socket"))
(defun bind-socket-stream (socket-stream address)
(bind-socket-internal socket-stream
(saddress-sockaddr address)
(saddress-addr-len address)))
;;;
;;; LISTEN-SOCKET-STREAM socket-stream backlog
;;; listen socket.
(defentry listen-socket-stream (object int) (object "listen_socket"))
;;;
;;; ACCEPT-SOCKET socket-stream &optional address.
;;; accepts a connection on a socket of socket-stream.
;;;
(defentry accept-socket-internal (object object int) (object "accept_socket"))
(defun accept-socket-stream (socket-stream &optional address)
(if address
(accept-socket-internal socket-stream
(saddress-sockaddr address)
(saddress-addr-len address))
(accept-socket-internal socket-stream
nil
0)))
;;;
;;; SET-SOCKOPT socket-stream option value
;;; setsockopt(2) interface.
;;; value is T or NIL.
(defentry set-sockopt-internal (int int int) (object "set_sockopt"))
(defun set-sockopt (socket option value)
(set-sockopt-internal (stream-fd socket)
(get option 'sockopt)
value))
;;;
;;; GET-SOCKOPT socket-stream option
;;; getsockopt(2) interface
;;;
(defentry get-sockopt-internal (int int) (object "get_sockopt"))
(defun get-sockopt (socket option)
(let* ((opt (get option 'sockopt))
(res (if (null opt)
(error "GET-SOCKOPT: unknown option ~S" option)
(get-sockopt-internal (stream-fd socket)
(get option 'sockopt)))))
(if res
(if (= res -1)
(progn
(perror "get-sockopt")
nil)
res))))
;;;
;;; CONNECT-TO-SERVER host port &optional ignore-sigpipe
;;; Attempt to connect to server, given host and port.
;;; Returns two-way stream or NIL if connection fails.
;;;
;;; args host : (or string null), host name, nil means "unix" domain socket.
;;; host name can be a ip address (i.e., a.b.c.d).
;;; port : (or integer string), port number in decimal, if host is nil then
;;; port shold be a path name (string).
(defentry connect-to-server-internal
(string string bool) (object "connect_to_server"))
(defun connect-to-server (host port &optional (ignore-sigpipe nil))
(let ((r-port (if (integerp port)
(int->string port)
port)))
(connect-to-server-internal host r-port ignore-sigpipe)))
;;;
;;; OPEN-TCP-STREAM
;;; This is for CLX.
;;; synonym of connect-to-server for our implementation.
(defmacro open-tcp-tream (host port &optional (ignore-sigpipe nil))
`(connect-to-server ,host ,port ,ignore-sigpipe))
;;;
;;; for debug
(defentry perror (string) (void "print_error"))
;;;============================================================================
;;; UNIX I/O
;;;============================================================================
;;;
;;; FD->OUTPUT-STREAM
;;; Given a file descriptor, creates a new KCL output stream
(defentry fd->output-stream (int) (object "fd_to_output"))
;;;
;;; FD->INPUT-STREAM
;;; Given a file descriptor, creates a new KCL input stream
(defentry fd->input-stream (int) (object "fd_to_input"))
;;;
;;; FD->IO-STREAM
;;;
(defentry fd->io-stream (int) (object "fd_to_io"))
;;;
;;; STREAM-FD
;;; Returns a STREAM file descriptor
(defentry stream-fd (object) (int "stream_fd"))
;;;
;;; STREAM-FP
;;; Returns a FILE POINTER of a given stream
(defentry stream-fp (object) (int "stream_fp"))
;;;
;;; TWO-WAY->OUTPUT-STREAM
;;; Extracts a output stream from a given two-way stream
(defentry two-way->output-stream (object) (object "two_way_output_stream"))
;;;
;;; TWO-WAY->INPUT-STREAM
;;; Extracts a input stream from a given two-way stream
(defentry two-way->inout-stream (object) (object "two_way_input_stream"))
;;;
;;; PEEK-INPUT-STREAM
;;;
(defentry peek-input-stream (object) (object "peek_input_stream1"))
;;;----------------------------------------------------------------------------
;;; SELECTOR
;;; slect(2) interface.
;;;----------------------------------------------------------------------------
(defmacro define-selector (sym &key read write exception (timer 0.0))
`(setf (symbol-function ',sym)
(make-selector ,read ,write ,exception ,timer)))
(defentry unix-select (int int int int object int int)
(object "unix_select_internal"))
;;; SELECT-INPUT-STREAM stream timer
;;; wait untill the stream is ready for reading.
;;; if timer is nil, blocks indefinitely, else it specifies
;;; the time to be wait (in sec order).
(si::define-inline-function select-input-stream (stream timer)
(if (peek-input-stream stream)
T
(progn
(let ((sec 0) (usec 0) res )
(when timer
(multiple-value-setq (sec usec)
(round timer))
(setq usec (round (* usec 1000))))
(setq res (unix-select 32 (ash 1 (stream-fd stream)) 0 0
(if timer T NIL)
sec usec))
(if (zerop (first res))
(if timer
:timeout
NIL)
T)))))
;;; MAKE-SELCTOR read-stream write-stream exception-stream timer
;;; creates closure which acts as a selector of specified streams.
;;;
(defun make-selector (read write exception timer)
(let ((fd-map nil)
(read-mask 0)
(write-mask 0)
(exception-mask 0)
(timer-on nil)
(sec 0)
(usec 0))
(labels ((stream->mask (streams)
(if (and streams (atom streams))
(setq streams (list streams)))
(let ((imap 0))
(dolist (stream streams imap)
(setq imap (logior (ash 1 (stream-fd stream)))))))
(add-map (streams)
(if (and streams (atom streams))
(setq streams (list streams)))
(dolist (stream streams)
(pushnew (cons stream (stream-fd stream)) fd-map
:test #'equal)))
(new (&key read write exception)
(when read
(setq read-mask (stream->mask read))
(add-map read))
(when write
(setq write-mask (stream->mask write))
(add-map write))
(when exception
(setq exception-mask (stream->mask exception))
(add-map exception)))
(delete (&key read write exception)
;; fd-map is not mentained
(setq read-mask (logand read-mask (lognot (stream->mask read))))
(setq write-mask (logand write-mask (lognot (stream->mask write))))
(setq exception-mask (logand exception-mask (lognot (stream->mask exception)))))
(set-timer (timer)
(multiple-value-setq (sec usec)
(round timer))
(setq usec (round (* usec 1000)))
(timer-on))
(mask->stream (mask)
(let ((streams nil))
(dolist (map fd-map streams)
(if (logbitp (cdr map) mask)
(push (car map) streams)))))
(check-result (result)
(let ((nfiles (first result))
(rf (second result))
(wf (third result))
(ef (fourth result)))
(if (and (= nfiles 0) timer-on)
:time-out
(when (> nfiles 0)
(list (mask->stream rf)
(mask->stream wf)
(mask->stream ef))))))
(timer-off ()
(setq timer-on nil))
(timer-on ()
(setq timer-on t)))
(set-timer timer)
(new :read read :write write :exception exception)
#'(lambda (command &rest args)
(ecase command
(:select
(check-result
(unix-select 32 read-mask write-mask exception-mask timer-on sec usec)))
(:add-stream
(apply #'new args))
(:delete-stream
(apply #'delete args))
(:set-timer
(apply #'set-timer args))
(:timer-on
(timer-on))
(:timer-off
(timer-off))
(:show-status
(format t "~%MAP: ~A" fd-map)
(format t "~%Read-mask: ~A, Write-mask: ~A, Eception-mask: ~A"
read-mask write-mask exception-mask)
(format t "~%Timer ~A" (if timer-on 'ON 'OFF))
(if timer-on
(format t "~% Sec: ~A, uSec: ~A" sec usec))))))))
;;;----------------------------------------------------------------------------
;;; FCNTL
;;; Unix fcntl(2) interface
;;;----------------------------------------------------------------------------
;;; fcntl(2) requests
(defconstant *fcntl-commands*
(vector
:F-DUPFD ;Duplicate fildes
:F-GETFD ;Get fildes flags
:F-SETFD ;Set fildes flags
:F-GETFL ;Get file flags
:F-SETFL ;Set file flags
:F-GETOWN ;Get owner
:F-SETOWN ;Set owner
))
;;; Flag values accessible to fcntl(2)
;;; (The first three can only be set by open)
;;;
(eval-when (eval load)
(setf (get :O-RDONLY 'fcntl) 0)
(setf (get :O-WRONLY 'fcntl) 1)
(setf (get :O-RDWR 'fcntl) 2)
(setf (get :FNDELAY 'fcntl) #o00004) ;non-blocking reads
(setf (get :FAPPEND 'fcntl) #o00010) ;append on each write
(setf (get :FASYNC 'fcntl) #o00100) ;signal pgrp when data ready
)
;;;
;;; FCNTL stream cmd arg
;;;
;;;DESCRIPTION
;;; Fcntl provides for control over streams. The argument
;;; stream is a stream to be operated on by cmd as follows:
;;;
;;; :F-DUPFD Return a new descriptor as follows:
;;; Lowest numbered available descriptor greater
;;; than or equal to arg.
;;; Same object references as the original
;;; descriptor.
;;; New descriptor shares the same file pointer
;;; if the object was a file.
;;; Same access mode (read, write or read/write).
;;; Same file status flags (i.e., both file
;;; descriptors share the same file status
;;; flags).
;;; The close-on-exec flag associated with the
;;; new file descriptor is set to remain open
;;; across execv(2) system calls.
;;; :F-GETFD Get the close-on-exec flag associated with
;;; the file descriptor fd. If the low-order bit
;;; is 0, the file will remain open across exec,
;;; otherwise the file will be closed upon execu-
;;; tion of exec.
;;; :F-SETFD Set the close-on-exec flag associated with fd
;;; to the low order bit of arg (0 or 1 as
;;; above).
;;; :F-GETFL Get descriptor status flags, as described
;;; below.
;;; :F-SETFL Set descriptor status flags.
;;; :F-GETOWN Get the process ID or process group currently
;;; receiving SIGIO and SIGURG signals; process
;;; groups are returned as negative values.
;;; :F-SETOWN Set the process or process group to receive
;;; SIGIO and SIGURG signals; process groups are
;;; specified by supplying arg as negative, oth-
;;; erwise arg is interpreted as a process ID.
;;;
;;; The flags for the :F-GETFL and :F-SETFL flags are as follows:
;;; :FNDELAY Non-blocking I/O; if no data is available to
;;; a read call, or if a write operation would
;;; block, the call returns NIL with the error
;;; EWOULDBLOCK.
;;; :FAPPEND Force each write to append at the end of
;;; file; corresponds to the O-APPEND flag of
;;; open(2).
;;; :FASYNC Enable the SIGIO signal to be sent to the
;;; process group when I/O is possible, e.g.
;;; upon availability of data to be read.
;;;RETURN VALUE
;;; Upon successful completion, the value returned depends on
;;; cmd as follows:
;;; :F-DUPFD A new file descriptor.
;;; :F-GETFD Value of flag (only the low-order bit is defined).
;;; :F-GETFL Value of flags.
;;; :F-GETOWN Value of file descriptor owner.
;;; other Integer value other than NIL.
;;; Otherwise, a value of NIL is returned and errno is set to
;;; Indicate the error.
(defentry fcntl-internal (int int int) (int "fcntl"))
(defun fcntl(stream command &optional arg &aux res)
(if arg
(setq arg (get arg 'fcntl))
(setq arg 0))
(setq res (fcntl-internal (stream-fd stream)
(position command *fcntl-commands*)
arg))
(if (= res -1)
NIL
res))
@//E*O*F unix-ipc.lsp//
chmod u=rw,g=rw,o=r unix-ipc.lsp
echo x - unix_io.c
sed ····@//' > "unix_io.c" <<·@//E*O*F unix_io.c//'
/* -*- Mode:C -*- */
/*
* UNIX-IO offers several basic UNIX (BSD 4.3) system
* dependent I/O functions for KCL and/or AKCL.
* This is a file of its C lang. part.
*
* Copyright (c) Toshimi Sawada
* Permission to use, copy, modify, and distribute this software for any
* purpose is hereby granted without fee.
* ······@sra.co.jp
*-----------------------------------------------------------------------------
* NOTE:
* In UNIX-IO, from the KCl users' point of view,
* any UNIX-IO cahnnel can a LISP STREAM, but its type is restricted to one of
* OUTPUT-STREAM, INPUT-STREAM, TWO-WAY-STREAM, and IO-STREAM.
* Other types of streams are not implemented yet.
* SEE "unix-io.lsp" for Lisp entry definitions.
*/
/*
* Compile command:
*
* cc -c unix_io.c -DMAXPAGE=16384 -DVSSIZE=8152 -I${KCLHDIR}
* ,where KCLHDIR is the h subdirectory in the kcl distribution
*
*/
/* uses KCl include files of its distribution */
#include "include.h"
#include <stdio.h>
#include <sys/types.h>
#include <errno.h>
#include <netinet/in.h>
#include <sys/ioctl.h>
#include <netdb.h>
#include <fcntl.h>
#include <sys/socket.h>
#include <strings.h>
#include <sys/un.h>
#include <sys/time.h>
#include <signal.h>
#include <sys/wait.h>
#include <ctype.h>
#define inetaddr(x) (*(struct sockaddr_in *)x)
extern int errno;
/*
* MAKE_KCL_STREAM
* Given a name, file dscriptor, and stream mode,
* creates a new KCL stream
* This is a LOCAL function.
*/
static object make_kcl_stream(name,fd,smm)
char *name; /* not really used */
int fd; /* file descriptor */
enum smmode smm; /* lisp mode */
{
object stream;
char *mode; /* file open mode */
FILE *fp; /* file pointer */
vs_mark;
switch(smm){
case smm_input:
mode = "r";
break;
case smm_output:
mode = "w";
break;
case smm_io:
mode = "w+";
break;
default:
FEerror("make_stream : wrong mode");
}
fp = fdopen(fd,mode);
if (fp <= 0) {
close(fd);
return(Cnil); /* failed to fdopen */
}
stream = alloc_object(t_stream);
stream->sm.sm_mode = (short)smm;
stream->sm.sm_fp = fp;
fp->_base = BASEFF;
stream->sm.sm_object0 = Sstring_char;
vs_push(stream);
stream->sm.sm_object1 = make_simple_string(name);
stream->sm.sm_int0 = stream->sm.sm_int1 = 0;
setbuf(fp, alloc_contblock(BUFSIZ));
vs_pop;
return(stream);
}
/*
* FD_TO_INPUT
* Given a file desciptor, creates KCL input stream.
*/
object fd_to_input(fd)
int fd;
{
object x ;
char fname[64];
sprintf(fname, "INPUT Stream:%d", fd);
x = make_kcl_stream(fname, fd, smm_input);
return x;
}
/*
* FD_TO_OUTPUT
* Given a file desciptor, creates a KCL output stream.
*/
object fd_to_output (fd)
int fd;
{
object x ;
char fname[64];
sprintf(fname, "IPC OUTPUT Stream:%d", fd);
x = make_kcl_stream(fname, fd, smm_output);
return(x);
}
/*
* FD_TO_IO
* Given a file descriptor, creates a KCL I/O stream
*/
object fd_to_io(fd)
int fd ;
{
object x ;
char fname[64];
sprintf(fname, "IPC I/O Stream:%d", fd);
x = make_kcl_stream(fname, fd, smm_io);
return(x);
}
/*
* STREAM_FD: returns pointer to a file-desriptor of given stream.
* used by LISP function STREAM-FILE-DESCRIPTOR
*/
int stream_fd(strm)
struct stream *strm;
{
register struct stream *x;
register FILE *fp;
if (type_of(strm) != t_stream)
FEwrong_type_argument(Sstream, strm);
BEGIN:
switch (strm->sm_mode)
{
case smm_two_way:
case smm_echo:
strm = strm->sm_object1; /* incomplete!! */
case smm_input:
case smm_output:
case smm_io:
case smm_probe:
case smm_string_input:
case smm_string_output:
return(fileno(strm->sm_fp));
case smm_synonym:
strm = symbol_value(strm->sm_object0);
if (type_of(strm) != t_stream)
FEwrong_type_argument(Sstream, strm);
goto BEGIN;
default:
FEerror("Sorry, can't find...",0);
}
}
/*
* STREAM_FP: returns file-pointer of given stream object
* used by LISP function STREAM-FP
*/
int stream_fp(strm)
struct stream *strm;
{
register struct stream *x;
register FILE *fp;
if (type_of(strm) != t_stream)
FEwrong_type_argument(Sstream, strm);
BEGIN:
switch (strm->sm_mode)
{
case smm_two_way:
case smm_echo:
strm = strm->sm_object1; /* incomplete */
case smm_input:
case smm_output:
case smm_io:
case smm_probe:
case smm_string_input:
case smm_string_output:
return(strm->sm_fp);
case smm_synonym:
strm = symbol_value(strm->sm_object0);
if (type_of(strm) != t_stream)
FEwrong_type_argument(Sstream, strm);
goto BEGIN;
default:
FEerror("Sorry, can't find",0);
}
}
/*
* TWO_WAY_OUTPUT_STREAM
* returns output side of stream of two way stream
*/
object two_way_output_stream(strm)
struct stream *strm;
{
if (type_of(strm) != t_stream)
FEwrong_type_argument(Sstream, strm);
if (strm->sm_mode != smm_two_way)
FEerror("Not a Two-Way stream",0);
return(strm->sm_object1);
}
/*
* TWO_WAY_INPUT_STREAM
* returns output side of stream of two way stream
*/
object two_way_input_stream(strm)
struct stream *strm;
{
if (type_of(strm) != t_stream)
FEwrong_type_argument(Sstream, strm);
if (strm->sm_mode != smm_two_way)
FEerror("Not a Two-Way stream",0);
return(strm->sm_object0);
}
/* raw I/O */
/*
* peek_input_stream
* Used by LISP Function PEEK-STREAM
*
*
*/
object peek_input_stream(strm)
struct stream *strm;
{
object x;
int c;
begin:
switch (strm->sm_mode) {
case smm_two_way:
case smm_echo:
strm = strm->sm_object0;
case smm_input:
case smm_io:
if (strm->sm_fp == NULL)
closed_stream(strm);
c = strm->sm_fp->_cnt;
if (c > 0)
return(make_fixnum (c));
c = 0;
ioctl(strm->sm_fp->_file, FIONREAD, &c);
if (c > 0)
return(make_fixnum (c));
else
return(Cnil);
case smm_synonym:
strm = symbol_value(strm->sm_object0);
if (type_of(strm) != t_stream)
FEwrong_type_argument(Sstream, strm);
goto begin;
case smm_concatenated:
if (endp(strm->sm_object0))
return(Cnil);
strm = strm->sm_object0->c.c_car; /* incomplete! */
goto begin;
case smm_string_input:
c = strm->sm_int1 - strm->sm_int0;
if (c > 0)
return(make_fixnum(c));
else
return(Cnil);
case smm_output:
case smm_probe:
case smm_broadcast:
case smm_string_output:
FEerror("Can't listen to ~S.", 1, strm);
default:
FEerror("illegal stream mode",0);
}
}
int peek_input_stream1(strm)
struct stream *strm;
{
object x;
int c;
if (type_of(strm) != t_stream)
FEwrong_type_argument(Sstream, strm);
return(peek_input_stream(strm));
}
/*
* unix_select_internal, "select" system call interface for KCL.
*/
object unix_select_internal(nfds, readfds, writefds, exceptfds, timeout, sec, usec)
int nfds, readfds, writefds, exceptfds;
object timeout;
int sec, usec;
{
int readf[1], writef[1], exceptf[1];
struct timeval time;
int nfound;
object *base;
readf[0] = readfds;
writef[0] = writefds;
exceptf[0] = exceptfds;
time.tv_sec = sec;
time.tv_usec = usec;
if (timeout == Cnil)
nfound = select(nfds, readf, writef, exceptf, 0);
else
nfound = select(nfds, readf, writef, exceptf, &time);
base = vs_top;
vs_push(make_fixnum (nfound));
vs_push(make_fixnum (readf[0]));
vs_push(make_fixnum (writef[0]));
vs_push(make_fixnum (exceptf[0]));
vs_push(make_cons(base[3],Cnil));
vs_push(make_cons(base[2],base[4]));
vs_push(make_cons(base[1],base[5]));
vs_push(make_cons(base[0],base[6]));
return(base[7]);
}
/* Basic IPC for KCL
* Creates inter-process conmmunication channel using SOCKET mechanisms,
* also provides low-level socket controll.
* 1988 ······@SRA
*/
extern int errno;
extern object fd_to_input();
extern object fd_to_output();
extern void bcopy();
/* make_socket_stream
* creates stream object which holds unix socket
*/
object make_socket_stream(af, type, protocol)
int af; /* address family */
int type; /* socket type */
int protocol; /* protocol */
{
int fd;
object in, out, sock_two_way;
if ((fd = socket(af, type, protocol)) < 0) /* ignore protocol now */
return(Cnil); /* Error set by system call */
/* make two-way stream */
if ((in = fd_to_input(fd)) == Cnil)
return(Cnil);
vs_push(in);
if ((out = fd_to_output(fd)) == Cnil)
return(Cnil);
vs_push(out);
sock_two_way = make_two_way_stream(in, out);
vs_pop; vs_pop;
return sock_two_way;
}
static object allocate_sockaddr()
{
object x;
/* extern void array_allocself; */
x = alloc_object(t_vector);
vs_push(x);
x->v.v_self = NULL;
x->v.v_displaced = Cnil;
x->v.v_dim = sizeof(struct sockaddr_un); /* Yes, BIG enough */
x->v.v_adjustable = 0;
x->v.v_offset = (short) 0;
x->v.v_elttype = (short) t_fixnum;
x->v.v_hasfillp = 0;
x->v.v_fillp = x->v.v_dim;
array_allocself(x, 1); /* allocates to a STATIC area */
vs_pop;
return(x);
}
/* make_sockaddr
* creates C language sockaddr structure.
* In this implementation, sockaddr is a KCL array
* which is created by the lisp function MAKE-SOCKADDR.
* make_sockaddr is called by MAKE-SOCKADDR ,and it creates
* C language sockaddr structure embedded in a KCL simple array object,
* returns its address length.
*/
int make_sockaddr (host, port, x)
char *host; /* name of host. Nil means "unix" domain
else host name or "a.b.c" (ip address) */
char *port; /* Port number in decimal -- case of INTERNET
or socket's path_name -- case of UNIX domain
or service name (TCP only) -- case of INTERNET */
object x; /* KCL fixnum array used for constructing sockaddr */
{
int addrlen; /* length of address */
struct sockaddr *addr; /* address to connect to */
struct sockaddr_un *unaddr; /* UNIX socket address */
struct sockaddr_in *inaddr; /* INET socket address */
struct hostent *host_ptr;
extern struct hostent *gethostbyname();
/* make KCL fixnum simple array used as sockaddr*/
/* x = allocate_sockaddr(); */
vs_push(x);
if ((host == 0) || (host[0] == '\0')){
/* UNIX DOMAIN socket */
unaddr = (struct sockaddr_un *)(x->v.v_self);
unaddr->sun_family = AF_UNIX;
/* port is used as name of the socket */
(void) strcpy(unaddr->sun_path, port);
addr = (struct sockaddr *) unaddr;
addrlen = strlen(unaddr->sun_path) + 2;
}else{
/* INTERNET DMAIN */
inaddr = (struct sockaddr_in *)(x->v.v_self);
if (host >='0' && host <= '9')
inaddr->sin_addr.s_addr = inet_addr(host);
else{
/* Get the statistics on the specified host. */
if ((inaddr->sin_addr.s_addr = inet_addr(host)) == -1) {
if ((host_ptr = gethostbyname(host)) == NULL) {
/* No such host! */
errno = EINVAL;
return(Cnil);
}
/* Check the address type for an internet host. */
if (host_ptr->h_addrtype != AF_INET) {
/* Not an Internet host! */
errno = EPROTOTYPE;
return(Cnil);
}
/* Set up the socket data. */
inaddr->sin_family = host_ptr->h_addrtype; /* AF_INET */
bcopy((char *)host_ptr->h_addr,
(char *)&inaddr->sin_addr,
sizeof(inaddr->sin_addr));
} else {
inaddr->sin_family = AF_INET;
}
}
addr = (struct sockaddr *) inaddr;
addrlen = sizeof (struct sockaddr_in);
if (isdigit(port[0])){
inaddr->sin_port = atoi(port);
} else {
struct servent *pp ;
struct servent *getservbyname() ;
if( pp = getservbyname(port,"tcp"))
inaddr->sin_port = pp->s_port ;
else
/* Unknown services */
return (Cnil) ;
}
/* Resolve endian problems */
inaddr->sin_port = htons(inaddr->sin_port);
}
/* OK sockaddr is now completely set */
vs_pop;
return(addrlen);
}
/* address_family
* given a sockaddr (KCL fixnum array) returns address_family slot.
*/
int address_family (address)
object address; /* sockaddr */
{
struct sockaddr *addr;
short x;
addr = (struct sockaddr *) (address->v.v_self);
x = addr->sa_family;
return x;
}
object port_internal(address)
object address; /* sockaddr */
{
u_short x;
if ((x = address_family(address)) == AF_INET){
struct sockaddr_in *iaddr;
u_short iport;
iaddr = (struct sockaddr_in *) (address->v.v_self);
iport = iaddr->sin_port;
return (make_fixnum(iport));
}
else if ( x == AF_UNIX){
struct sockaddr_un *uaddr;
char *path;
uaddr = (struct sockaddr_un *)(address->v.v_self);
path = (char *) (uaddr->sun_path);
return (make_simple_string (path));
};
return (Cnil);
}
/* address_internal address
*/
object address_internal (address)
object address;
{
struct hostent *hp;
char * ad = "INADDR-ANY";
struct sockaddr_in *addr;
addr = (struct sockaddr_in *)(address->v.v_self);
if (addr->sin_addr.s_addr == INADDR_ANY)
return (make_simple_string (ad));
else{
hp = gethostbyaddr((char *)&(addr->sin_addr), 4,AF_INET);
if (hp != NULL)
return (make_simple_string (hp->h_name));
else
return (make_simple_string (inet_ntoa(addr->sin_addr)));
}
}
/* get_sock_name_internal
*/
int get_sock_name_internal (sock, address, adrlen)
object sock;
object address;
int adrlen;
{
int fd;
int len[1];
struct sockaddr * addr;
addr = (struct sockaddr*)(address->v.v_self);
len[0] = adrlen;
fd = stream_fd(sock);
if (getsockname(fd, addr, len) != -1)
return(len[0]);
else
return -1;
}
/* get_peer_name_internal
*/
int get_peer_name_internal (sock, address, adrlen)
object sock;
object address;
int adrlen;
{
int fd;
int len[1];
struct sockaddr *addr;
len[0] = adrlen;
addr = (struct sockaddr *)(address->v.v_self);
fd = stream_fd(sock);
if (getpeername(fd, addr, len) != -1)
return len[0];
else
return -1;
}
/* connect_socket
* creates connection request.
* inplements Lisp function CONNECT-SOCKET's C language part.
*/
object connect_socket(socket, addr, addrlen, sigignore)
object socket; /* a stream coressponding to the socket */
object addr; /* socket address */
int addrlen; /* length of address */
int sigignore; /* if T ignores sigpipe */
{
struct sockaddr *address;
int fd;
address = (struct sockaddr *) (addr->v.v_self);
/* get socket file descriptor */
fd = stream_fd(socket);
/* request to connect */
if (connect(fd, address, addrlen) == -1) {
/* (void) close(fd); */
return(Cnil);
}
if (sigignore)
(void) signal(SIGPIPE,SIG_IGN);
return(socket);
}
/* bind_socket
* make bind request
* called by the Lisp function BIND-SOCKET
*/
object bind_socket(socket, address, addrlen)
object socket;
object address;
int addrlen;
{
int fd;
struct sockaddr *addr;
fd = stream_fd(socket);
addr = (struct sockaddr *) (address->v.v_self);
if (bind(fd, addr, addrlen) == -1) {
/* (void) close(fd); */
return(Cnil);
}
return(socket);
}
/* listen_socket
* make listen request
*/
object listen_socket(socket, backlog)
object socket;
int backlog;
{
int fd;
fd = stream_fd(socket);
if (listen(fd, socket) == -1){
/* (void) close(fd); */
return(Cnil);
}
return(socket);
}
/* accept_socket
* make accept request
* called by Lisp function ACCEPT-SOCKET
*/
object accept_socket(socket, address, addrlen)
object socket;
object address;
int addrlen;
{
int fd;
int addrlen;
struct sockaddr *addr ;
int ns;
int len[1];
object in, out, sock_two_way;
fd = stream_fd(socket);
if (address == Cnil){
ns = accept(fd, 0, 0);
} else {
addr = (struct sockaddr *) (address->v.v_self);
ns = accept(fd, addr, len);
}
if (ns == -1){
/* (void) close(fd); */
return(Cnil);
}
/* create KCL Stream for newly created socket */
if ((in = fd_to_input(ns)) == Cnil)
return(Cnil);
vs_push(in);
if ((out = fd_to_output(ns)) == Cnil){
vs_pop;
return(Cnil);
}
vs_push(out);
sock_two_way = make_two_way_stream(in, out);
vs_pop; vs_pop;
return sock_two_way;
}
/* set_sockopt
*/
object set_sockopt (socket, option, value)
int socket, option, value;
{
if ((setsockopt(socket, SOL_SOCKET, option, &value, 1)) == 0){
return(Ct);
}else{
return(Cnil);
}
}
object get_sockopt (socket, option)
int socket, option;
{
int result;
int len;
if (getsockopt(socket, SOL_SOCKET, option, &result, &len) == 0)
{
if (len != 0){
fprintf(stderr, "len = %d", len);
return(make_fixnum(result));
}else
return(Cnil);
}else{
return(make_fixnum(-1));
}
}
/*
* CONNECT_TO_SERVER
* Cribbed from X11 beta connection code in XLIB.
* Attempts to connect to server, given host and port number.
* Returns Two-Way stream or NIL if connection fails.
*/
object connect_to_server (host, port, ignore_sigpipe)
char *host; /* Name of host. null string means "unix" domain
else host name or "a.b.c" (ip address) */
char *port; /* Port number in decimal (In case INTERNET)
or Service name (TCP only)(In case INTERNET),
or path name (UNIX domain). */
int ignore_sigpipe ; /* Ignores all SIGPIPE when non zero value is specified */
{
struct sockaddr_in inaddr; /* INET socket address. */
struct sockaddr_un unaddr; /* UNIX socket address. */
struct sockaddr *addr; /* address to connect to */
int addrlen; /* length of address */
struct hostent *host_ptr;
extern struct hostent *gethostbyname();
int fd; /* Network socket */
if ((host == 0) || (host[0] == '\0')) {
/* Connect in UNIX domain. */
host="unix" ;
unaddr.sun_family = AF_UNIX;
/* parameter port is used for name of socket. */
(void) strcpy(unaddr.sun_path,port) ;
addr = (struct sockaddr *) &unaddr;
addrlen = strlen(unaddr.sun_path) + 2;
}else if (host >='0' && host <= '9') /* internet domain */
inaddr.sin_addr.s_addr = inet_addr(host);
else{
/* Get the statistics on the specified host. */
if ((inaddr.sin_addr.s_addr = inet_addr(host)) == -1) {
if ((host_ptr = gethostbyname(host)) == NULL) {
/* No such host! */
errno = EINVAL;
return(Cnil);
}
/* Check the address type for an internet host. */
if (host_ptr->h_addrtype != AF_INET) {
/* Not an Internet host! */
errno = EPROTOTYPE;
return(Cnil);
}
/* Set up the socket data. */
inaddr.sin_family = host_ptr->h_addrtype; /* AF_INET */
bcopy((char *)host_ptr->h_addr,
(char *)&inaddr.sin_addr,
sizeof(inaddr.sin_addr));
} else {
inaddr.sin_family = AF_INET;
}
addr = (struct sockaddr *) &inaddr;
addrlen = sizeof (struct sockaddr_in);
if (isdigit(port[0])){
inaddr.sin_port = atoi(port);
} else {
struct servent *pp ;
struct servent *getservbyname() ;
if( pp = getservbyname(port,"tcp"))
inaddr.sin_port = pp->s_port ;
else
/* Unknown services */
return (Cnil) ;
}
/* Resolve endian problems */
inaddr.sin_port = htons(inaddr.sin_port);
}
/*
* Open the network connection.
*/
if ((fd = socket((int) addr->sa_family, SOCK_STREAM, 0)) < 0)
return(Cnil); /* errno set by system call. */
if (connect(fd, addr, addrlen) == -1) {
/* (void) close (fd); */
return(Cnil); /* errno set by system call. */
}
/*
* Ignore SIGPIPE if required.
*/
if (ignore_sigpipe)
(void) signal(SIGPIPE,SIG_IGN) ;
/*
* Make up Lisp stream
*/
{
FILE *ipc_ifp;
FILE *ipc_ofp;
struct stream *out, *in;
object x;
char fname[1024]; /* path name (gag) */
ipc_ofp = fdopen(fd, "w");
ipc_ifp = fdopen(fd, "r");
if (ipc_ifp == 0 || ipc_ofp == 0) {
/* close(fd); */
return(Cnil); /* failed to fdopen */
}
/*
* make KCL streams
*/
ipc_ifp->_base = ipc_ofp->_base = BASEFF ;
out = (struct stream*)alloc_object(t_stream);
out->sm_mode = (short)smm_output;
out->sm_fp = ipc_ofp;
out->sm_object0 = Sstring_char;
out->sm_object1 = out->sm_int0 = out->sm_int1 = 0;
vs_push(out);
setbuf(ipc_ofp, alloc_contblock(BUFSIZ));
sprintf(fname, "IPC out (%s:%s) %d", host, port, fd);
out->sm_object1 = make_simple_string(fname);
in = (struct stream *)alloc_object(t_stream);
in->sm_mode = (short)smm_input;
in->sm_fp = ipc_ifp ;
in->sm_object0 = Sstring_char;
in->sm_int0 = in->sm_int1 = in->sm_object1 = 0 ;
vs_push(in);
setbuf(ipc_ifp, alloc_contblock(BUFSIZ));
sprintf(fname, "IPC in (%s:%s) %d", host, port, fd);
in->sm_object1 = make_simple_string(fname);
/* creates Two-Way stream */
x = make_two_way_stream(in, out);
vs_pop ; vs_pop ;
return x;
}
}
void print_error (str)
char * str;
{
perror(str);
}
/* UNIX 4.2 BSD System Calls entry for KCL */
/* Compile Command"
*
* cc -c unix-ssyscall.c -DNEWS -DMAXPAGE=16384 -DVSSIZE=8152 -I${KCLHDIR}
*
* where KCLHDIR is the h subdirectory in the kcl distribution
*/
typedef union {
char *name;
int num;
} call_args;
static call_args call_arg[10];
static int
_SYSCALL(n, num_args)
int n ; /* system call number */
int num_args; /* number of arguments */
{
int r;
switch (num_args)
{
case 0: r = syscall(n); break;
case 1: r = syscall(n, call_arg[0]); break;
case 2: r = syscall(n, call_arg[0], call_arg[1]); break;
case 3: r = syscall(n, call_arg[0], call_arg[1], call_arg[2]); break;
case 4: r = syscall(n, call_arg[0], call_arg[1], call_arg[2],
call_arg[3]); break;
case 5: r = syscall(n, call_arg[0], call_arg[1], call_arg[2],
call_arg[3], call_arg[4]); break;
case 6: r = syscall(n, call_arg[0], call_arg[1], call_arg[2],
call_arg[3], call_arg[4], call_arg[5]); break;
default: FEerror("~S is too many arguments for syscall.", 1, make_fixnum(num_args));
break;
}
return r;
}
int
L_SYSCALL()
{
int n, r, call_num;
call_num = (int) fix(vs_base[0]);
n = get_syscall_arguments(vs_base[1]);
r = _SYSCALL(call_num, n);
return(r);
}
static int
get_syscall_arguments(x)
object x;
{
object y,z;
register int i, j, len, m;
char * p;
for (i = 0; type_of(x) == t_cons; i++, x = x->c.c_cdr){
y = x->c.c_car;
if (type_of(y) == t_fixnum){
call_arg[i].num = (int) fix(y);
}else if (type_of(y) == t_string) {
len = y->st.st_fillp;
z = alloc_simple_string(len + 1);
vs_push(x);
p = alloc_relblock(len + 1);
for (m = 0; m < len; m++){
p[m] = y->st.st_self[m];
}
p[m] = '\0';
z->st.st_self = p;
call_arg[i].name = p;
}else{
FEerror("~S is wrong type for syscall argument(should be fixnum or string).", 1, y);
}
};
return(i);
}
#undef endp
#define endp(obje) ((enum type)((endp_temp = (obje))->d.t) == t_cons ? \
FALSE : endp_temp == Cnil ? TRUE : \
(bool)FEwrong_type_argument(Slist, endp_temp))
static object endp_temp;
static int
list_length(x)
object x;
{
int n;
object fast, slow;
n = 0;
fast = slow = x;
for (;;) {
if (endp(fast)) {
return n;
}
if (endp(fast->c.c_cdr)) {
return(n + 1);
}
if (fast == slow && n > 0) {
return(Cnil);
}
n += 2;
fast = fast->c.c_cdr->c.c_cdr;
slow = slow->c.c_cdr;
}
}
/* this is for test using defentry */
int l_syscall(num, args)
int num;
object args;
{
int n;
n = get_syscall_arguments(args);
return (_SYSCALL(num, n));
}
@//E*O*F unix_io.c//
chmod u=rw,g=rw,o=r unix_io.c
echo x - defentry+.lsp
sed ····@//' > "defentry+.lsp" <<·@//E*O*F defentry+.lsp//'
;;-*-Mode:Lisp; Syntax:Common-lisp; Package:Compiler -*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; New defentry for KCL
;;
;; This is a extension of defentry macro of KCL with keeping
;; upper compatibility.
;;
;; Originally written by Tatsuya Oinuma, and slitely modefied
;; by Sawada for adapting AKCL verison.
;; Tue Mar 29 16:37:34 JST 1988
;; ······@sra.co.jp
;; Thu Apr 26 20:53:56 JST 1990
;; ······@sra.co.jp
;; 2.New features
;;
;; (1) Following argument type specifiers are allowd:
;;
;; object char int float double int* float* double*
;; char* void* file* bool loob string
;;
;; For instance,
;; (defentry getrlimit (int int*) (bool getrlimit))
;; (defentry getenv (string) (string getenv))
;;
;; >(setq val (make-array 2 :element-type 'fixnum))
;; #(0 0)
;;
;; >(getrlimit 1 val)
;; t
;; ;; Values got by getrlimit resides in the array val.
;;
;; >(getenv "HOME")
;; "/usr/kcl"
;;
;; New argument type allowed:
;; defentry spec lisp object type
;; ------------------------------------------------------------
;; int* vector of fixnum
;; float* vector of short-float
;; double* vector of load-float
;; char* vector of string-char
;; void* array of fixnum, short-float,
;; long-float, string-char,
;; or bit-vector
;; char* string with (code-char 0) at end
;; string string
;; file* stream
;; bool non-nil or nil
;; loob non-nil or nil
;; ---------------------------------------------------------------
;; NOTES:
;;
;; BITVECTOR with length 8 is regarded as char[1] in the C language, and
;; length 32 is int[1].
;;
;; If C function expects the (char *) argument to be an null terminated string,
;; lisp string must contains (code-char 0) in the end of it.
;; When you want to use lisp string as an argument to C
;; and C function treates it as a null terminated string,
;; specify the argument type as string.
;; In this case, parameter passing mechanizm automaticaly creates new
;; NULL terminated string and pass the copied one to C function.
;; The maximal lenth of the string passed is limited to 2048 bytes in the
;; current implementation.
;; You can change this limitation by changing the value of global variable
;; named *c-string-maxmum-length*.
;; Lisp strings is copied into temporary space and added null at end ,
;; then the pointer to this copied is passed to the C function.
;; After returning from the C function, temporary string is freed.
;; (this area is obtained from C stack.)
;; This implementation assumes that C function never holds address
;; of the string in it , and passed string is not used to return a value.
;; If you want to do such a kind of things, you must declare the argument
;; to be char*.
;; And, If address of these objcts are hold and kept in the C function,
;; you must protect lisp objects from GBC.
;;
;; It is possble to pass NIL for int* float* double* char* void*
;; and string. In this case, pointer to a NULL byte is passed
;; to the C function.
;;
;; When you specified bool, the real argument can be any type of lisp object.
;; If object is NIL, then 0 is passed to the C function else
;; 1 is passed.
;; In case loob, NIL is treated as 1 and non nil is 0.
;;
;; If argument type is declared as file*,the type of stream must be one of
;; INPUT-STREAM OUTPUT-STREAM IO-STREAM or SYNONYM-STREAM.
;; You can not pass two-way-stream or string-mumble-stream.
;; Lisp STREAM object is coerced into C FILE* pointer and pased to the function.
;; For example,
;; (defentry fclose (file*) (int fclose))
;;
;; CAUTION :
;; Note that parameter passing mechanizm dose not checks
;; type of object passed. But, if you specified
;; (procraim '(optimize (safety 2)))
;; when compile your defentries, generated code checks type of objects.
;;
;; (2) Extension on return value type:
;;
;; void object char int float double string bool loob syscall.
;;
;; In general, it is not possible to return structured data such as array
;; or struct. Dispite, (char *) terminated with NULL can be
;; coerced into lisp simple string. In this case, body of
;; string is copied into lisp heap area and a new lisp string is
;; created. If C function returned NULL, then NIL is returnd.
;;
;; Type syscall returns if C function returnd an negative value,
;; NIL. Positive value is returnd as a fixnum. This interpretation
;; is usefull when implementing interfacies to UNIX systemcalls.
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(in-package 'compiler)
(provide 'defentry+)
(defconstant aet_ch 1)
(defconstant aet_bit 2)
(defconstant aet_fix 3)
(defconstant aet_sf 4)
(defconstant aet_lf 5)
(defparameter *cfun-result-types* '("void" "object" "char" "syscall"
"int" "float" "double" "string" "bool" "loob" ))
(defparameter *cfun-arg-types* '("object" "char" "int" "float" "double" "string" "file*"
"void*" "char*" "int*" "float*" "double*" "bool" "loob"))
(defun t1defentry (args &aux type cname (cfun (next-cfun)) cfspec)
(when (or (endp args) (endp (cdr args)) (endp (cddr args)))
(too-few-args 'defentry 3 (length args)))
(cmpck (not (symbolp (car args)))
"The function name ~s is not a symbol." (car args))
(dolist** (x (cadr args))
(cmpck (not (member (string-downcase (string x))
*cfun-arg-types*
:test #'string-equal))
"The C-type ~s is illegal." x))
(setq cfspec (caddr args))
(cond ((symbolp cfspec)
(setq type "object")
(setq cname (string-downcase (symbol-name cfspec))))
((stringp cfspec)
(setq type "object")
(setq cname cfspec))
((and (consp cfspec)
(member (string-downcase (string (car cfspec)))
*cfun-result-types* :test #'string-equal)
(consp (cdr cfspec))
(or (symbolp (cadr cfspec)) (stringp (cadr cfspec)))
(endp (cddr cfspec)))
(setq cname (if (symbolp (cadr cfspec))
(string-downcase (symbol-name (cadr cfspec)))
(cadr cfspec)))
(setq type (string-downcase (string(car cfspec)))))
(t (cmperr "The C function specification ~s is illegal." cfspec)))
(push (list 'defentry (car args) cfun (cadr args) type cname)
*top-level-forms*)
(push (cons (car args) cfun) *global-funs*)
)
#+(and KCL (not AKCL))
(defun t2defentry (fname cfun arg-types type cname
&aux (vv (add-symbol fname)))
(declare (ignore arg-types type cname))
(wt-h "static L" cfun "();")
(wt-nl "MF(VV[" vv "],L" cfun ",start,size,data);")
)
#+AKCL
(defun t2defentry (fname cfun arg-types type cname)
(declare (ignore arg-types type cname))
(wt-h "static L" cfun "();")
(add-init `(si::mf ',fname ,(add-address "&L" cfun)) )
)
(defmacro wt-nl-s (&rest body)
`(when *safe-compile* (wt-nl ,@body)))
(defun t3defentry (fname cfun arg-types type cname)
(wt-comment "function definition for " fname)
(wt-nl1 "static L" cfun "()")
(wt-nl1 "{ object *old_base=vs_base;")
(setq type (string-downcase (string type)))
(cond ((string-equal type "string")
(wt-nl "char * x=0;"))
((member type '("bool" "loob" "syscall") :test #'string-equal)
(wt-nl "int x=0;"))
(t
(unless (string-equal type "void") (wt-nl type " x=0;"))))
(setq arg-types (mapcar #'(lambda (x) (string-downcase (string x)))
arg-types))
(do ((argn arg-types (cdr argn))
(n 0 (1+ n))
(body-gen nil)
(file-gen nil))
((null argn))
(when (string-equal (car argn) "string")
(when (null body-gen)
(wt-nl "char str_body[2048];")
(wt-nl "char *str_bodyp = str_body;")
(setq body-gen t))
(wt-nl "char *str_body" n ";"))
(when (string-equal (car argn) "file*")
(when (null file-gen)
(wt-nl "enum smmode{ /* stream mode */" )
(wt-nl "smm_input, /* input */" )
(wt-nl "smm_output, /* output */" )
(wt-nl "smm_io, /* input-output */" )
(wt-nl "smm_probe, /* probe */" )
(wt-nl "smm_synonym, /* synonym */" )
(wt-nl "smm_broadcast, /* broadcast */" )
(wt-nl "smm_concatenated, /* concatenated */" )
(wt-nl "smm_two_way, /* two way */" )
(wt-nl "smm_echo, /* echo */" )
(wt-nl "smm_string_input, /* string input */" )
(wt-nl "smm_string_output /* string output */" )
(wt-nl "};" )
(wt-nl "extern object Sstream;")
(wt-nl "struct stream {")
(wt-nl "short t, m;")
(wt-nl "FILE *sm_fp;")
(wt-nl "object sm_object0;")
(wt-nl "object sm_object1;")
(wt-nl "int sm_int0;")
(wt-nl "int sm_int1;")
(wt-nl "short sm_mode;")
(wt-nl "} *strm ;"))
(wt-nl "FILE *file_"n";")))
(wt-nl-s "check_arg(" (length arg-types) ");")
(do ((argn arg-types (cdr argn))
(n 0 (1+ n)))
((null argn))
(cond ((string-equal (car argn) "string")
(wt-nl "if (vs_base[" n "] != Cnil ) {")
(wt-nl-s "check_type_string(vs_base+"n");")
(wt-nl "str_body"n" = str_bodyp ;")
(wt-nl "strncpy(str_bodyp,vs_base["n"]->st.st_self, vs_base["n"]->st.st_fillp);")
(wt-nl "str_bodyp += vs_base["n"]->st.st_fillp;")
(wt-nl "*str_bodyp++=0;")
(wt-nl "} else str_body"n" = 0 ;"))
((string-equal (car argn) "char*")
(wt-nl-s "if(vs_base["n"]!=Cnil) {")
(wt-nl-s "check_type_array(vs_base+"n");")
(wt-nl-s "if(array_elttype(vs_base[" n "]) != "aet_ch")")
(wt-nl-s "FEerror(\"~S is not an array of string-char.\",1,vs_base["n"]);")
(wt-nl-s "}"))
((string-equal (car argn) "int*")
(wt-nl-s "if(vs_base["n"]!=Cnil) {")
(wt-nl-s "check_type_array(vs_base+"n");")
(wt-nl-s "if(array_elttype(vs_base[" n "]) != "aet_fix")")
(wt-nl-s "FEerror(\"~S is not an array of fixnum.\",1,vs_base["n"]);")
(wt-nl-s "}"))
((string-equal (car argn) "float*")
(wt-nl-s "if(vs_base["n"]!=Cnil) {")
(wt-nl-s "check_type_array(vs_base+"n");")
(wt-nl-s "if(array_elttype(vs_base[" n "]) != "aet_sf")")
(wt-nl-s "FEerror(\"~S is not an array of short-float.\",1,vs_base["n"]);")
(wt-nl-s "}"))
((string-equal (car argn) "double*")
(wt-nl-s "if(vs_base["n"]!=Cnil) {")
(wt-nl-s "check_type_array(vs_base+"n");")
(wt-nl-s "if(array_elttype(vs_base[" n "]) != "aet_lf")")
(wt-nl-s "FEerror(\"~S is not an array of double-float.\",1,vs_base["n"]);")
(wt-nl-s "}"))
((string-equal (car argn) "void*")
(wt-nl-s "if(vs_base["n"]!=Cnil) {")
(wt-nl-s "int aet;")
(wt-nl-s "check_type_array(vs_base+"n");")
(wt-nl-s "aet = array_elttype(vs_base["n"]);")
(wt-nl-s "if (aet!="aet_fix"&&aet!="aet_sf"&&")
(wt-nl-s " aet!="aet_lf"&&aet!="aet_ch"&&aet!="aet_bit")")
(wt-nl-s "FEerror(\"~S is not a type specified array.\",1,vs_base["n"]);")
(wt-nl-s "}"))
((string-equal (car argn) "file*")
(wt-nl-s "check_type_stream(vs_base+"n");")
(wt-nl "strm = vs_base["n"];")
(wt-nl "BEGIN"n":")
(wt-nl "switch (strm->sm_mode) { ")
(wt-nl "case smm_input: ")
(wt-nl "case smm_io: ")
(wt-nl "case smm_output: ")
(wt-nl "if (strm->sm_fp == NULL) ")
(wt-nl "closed_stream(strm); ")
(wt-nl "file_"n"=strm->sm_fp ; break ;")
(wt-nl "case smm_synonym: ")
(wt-nl "strm = symbol_value(strm->sm_object0); ")
(wt-nl "if (type_of(strm) != t_stream) ")
(wt-nl "FEwrong_type_argument(Sstream, strm); ")
(wt-nl "goto BEGIN"n"; ")
(wt-nl "default: ")
(wt-nl "FEerror(\"~S is not an io stream which can be passed to foreign function.\",1,strm);")
(wt-nl " }"))))
(unless (string-equal (string-downcase (string type)) "void") (wt-nl "x="))
(wt-nl cname "(")
(unless (endp arg-types)
(do ((types arg-types (cdr types))
(argtype-string nil)
(i 0 (1+ i)))
(nil)
(setq argtype-string (car types))
(cond ((string-equal argtype-string "object")
(wt-nl "vs_base[" i "]"))
((member argtype-string
'("char*" "int*" "float*" "double*" "void*")
:test #'string-equal)
(wt-nl "(vs_base[" i "]==Cnil)?0:((object)(vs_base[" i "]))->a.a_self"))
((string-equal argtype-string "string")
(wt-nl "str_body" i ))
((string-equal argtype-string "bool")
(wt-nl "(vs_base[" i "]==Cnil)?0:1"))
((string-equal argtype-string "loob")
(wt-nl "(vs_base[" i "]==Cnil)?1:0"))
((string-equal argtype-string "file*")
(wt-nl "file_"i))
(t
(wt-nl "object_to_"
argtype-string
"(vs_base[" i "])")))
(when (endp (cdr types)) (return))
(wt ",")))
(wt ");")
(wt-nl "vs_top=(vs_base=old_base)+1;")
(wt-nl "vs_base[0]=")
(cond ((string-equal type "void") (wt "Cnil"))
((string-equal type "object") (wt "x"))
((string-equal type "char") (wt "code_char(x)"))
((string-equal type "int")
(when (zerop *space*) (wt "CMP"))
(wt "make_fixnum(x)"))
((string-equal type "float") (wt "make_shortfloat(x)"))
((string-equal type "double") (wt "make_longfloat(x)"))
((string-equal type "string") (wt "(x==0)?Cnil:make_simple_string(x)"))
((string-equal type "syscall") (wt "((x<0)?Cnil:make_fixnum(x))"))
((string-equal type "bool") (wt "((x==0)?Cnil:Ct)"))
((string-equal type "loob") (wt "((x==0)?Ct:Cnil)")))
(wt ";")
(wt-nl1 "}")
)
@//E*O*F defentry+.lsp//
chmod u=rw,g=rw,o=r defentry+.lsp
echo x - test.lsp
sed ····@//' > "test.lsp" <<·@//E*O*F test.lsp//'
;;;-*-Mode:Lisp; Syntax:Common-lisp; Package:UNIX -*-
;;; Interactive tester
;;; test test test...
(in-package "UNIX")
(defvar *domain*)
(defvar *type*)
;; a socket returned by make-socket-stream, or accept-socket
;; various functions are applied to this socket stream.
(defvar *socket*)
(defvar *old-socket* nil)
;;
(defvar *addr*)
(defstruct (test-menu (:type list))
(name)
(value))
;;; domain test menu
(defparameter domain-menu
(list (make-test-menu :name 'unix :value :AF-UNIX)
(make-test-menu :name 'inet :value :AF-INET)))
;; type test menu
(defparameter type-menu
(list (make-test-menu :name 'stream :value :SOCK-STREAM)
(make-test-menu :name 'dgram :value :SOCK-DGRAM)
(make-test-menu :name 'packet :value :SOCK-SEQPACKET)))
;;;
;;; TEST MAIN
;;;
(defun test ()
(catch 'quit-test
(loop
(setq *domain* (c-input "Select domain" domain-menu 'inet))
(setq *type* (c-input "Select socket type" type-menu 'stream))
(setq *socket* (make-socket-stream *domain* *type*)
*old-socket* *socket*)
(if *socket*
(loop
(catch 'again
(case (p-input
"Enter action(bind, listen, accept, connect, read, write, status, option)")
(bind (do-bind))
(listen (do-listen))
(accept (do-accept))
(connect (do-connect))
(read (do-read))
(write (do-write))
(status (do-status))
(option (do-option))))
)))))
;;; c-input menu
;;; prompts and returns user input
(defvar *eof* (list nil nil))
(defun c-input (prompt menu default)
(catch 'again
(format t "~%~a (~{~a ~}): " prompt (map 'list #'test-menu-name menu))
(let* ((inp (read *standard-input* nil *eof*))
(val (and inp
(test-menu-value (assoc inp menu)))))
(if (or (eq inp *eof*)
(eq inp :quit))
(throw 'quit-test nil))
(if (null inp)
default
(or val
(format t "unkown selection try again")
(throw 'again nil))))))
(defun p-input (prompt)
(format t "~%~a " prompt)
(let ((inp (read *standard-input* nil *eof*)))
(if (or (eq inp *eof*) (eq inp :quit))
(throw 'quit-test nil))
inp))
;;;
;;; get a socket address from user input.
;;;
(defun get-addr ()
(let* ((host (p-input "host name ('unix'\,host name or ip address in string)?"))
(port (if (eq 'unix host)
(p-input "socket file path name (string)?")
(p-input "port number (in decimal)?"))))
(if (and (symbolp host)
(eq host 'unix))
(setq *addr* (make-sockaddr nil port))
(setq *addr* (make-sockaddr host port)))))
;;;
;;; do-bind
(defun do-bind ()
(get-addr)
(unless (bind-socket-stream *socket* *addr*)
(perror "Bind")))
;;;
;;; do-listen
(defun do-listen ()
(let ((log (p-input "number of back log?")))
(unless (listen-socket-stream *socket* log)
(perror "Listen"))))
;;;
;;; do-connect
(defun do-connect ()
(get-addr)
(unless (connect-socket-stream *socket* *addr* t)
(perror "Connect")))
;;;
;;; do-accept
(defun do-accept ()
(if (not (eq *old-socket* *socket*))
(format t "~%Sorry, only one accept!")
(if (null (setq *socket* (accept-socket-stream *socket* *addr*)))
(perror "Accept")
(format t "~% accept from ~A" *addr*))))
;;;
;;; do-read
(defun do-read ()
(format t "Read: ~{~A ~}" (do ((res nil)
(done nil))
(done (nreverse res))
(if (peek-input-stream *socket*)
(push (read *socket*) res)
(setq done t)))))
;;;
;;; do-write
(defun do-write ()
(let ((data (p-input "Type in data:")))
(format *socket* "~S" data)
(force-output *socket*)))
;;;
;;; do-status
(defun do-status ()
(let ((eaddr (the-empty-sockaddr)))
(get-sockname *socket* eaddr)
(format t "~%Name : ~A" eaddr)
(get-peername *socket* eaddr)
(format t "~%PeerName : ~A" eaddr)
(format t "~%:SO-DEBUG : ~A" (get-sockopt *socket* :SO-DEBUG))
(format t "~%:SO-ACCEPTCONN : ~A" (get-sockopt *socket* :SO-ACCEPTCONN))
(format t "~%:SO-REUSEADDR : ~A" (get-sockopt *socket* :SO-REUSEADDR))
(format t "~%:SO-KEEPALIVE : ~A" (get-sockopt *socket* :SO-KEEPALIVE))
(format t "~%:SO-DONTROUTE : ~A" (get-sockopt *socket* :SO-DONTROUTE))
(format t "~%:SO-USELOOPBACK : ~A" (get-sockopt *socket* :SO-USELOOPBACK))
;(format t "~%:SO-LINGER : ~A" (get-sockopt *socket* :SO-LINGER))
(format t "~%:SO-DONTLINGER : ~A" (get-sockopt *socket* :SO-DONTLINGER))
(format t "~%:SO-OOBINLINE : ~A" (get-sockopt *socket* :SO-OOBINLINE))))
;;;
;;; do-option
(defun do-option ()
(let* ((op-name (p-input "Input option name"))
(op-value (p-input " value?")))
(set-sockopt *socket* op-name op-value)))
@//E*O*F test.lsp//
chmod u=rw,g=rw,o=r test.lsp
exit 0