20 int allargs=1,allvalues=1,i;
54 Errorline(
"Illegal argument in %P.\n",funct);
62 if (argi[i].options&POLYTYPE) {
72 if (argi[i].options&JUSTFAIL)
return FALSE;
73 Errorline(
"Illegal argument in %P.\n",funct);
79 else if (!(argi[i].options&
NOVALUE)) allvalues=0;
85 Errorline(
"Missing argument '%s' in %P.\n",argi[i].feature,funct);
88 else if (argi[i].options&
REQUIRED) allargs=0;
93 return fun(argo,result,funct,info);
98 if (argo[i] && !(argi[i].options&
UNEVALED) && !argo[i]->value_3)
118 char *b = (
char *)
heap_alloc(bytes+
sizeof(bytes));
119 *((
long *) b) = bytes;
120 bzero(b+
sizeof(bytes),bytes);
122 temp_result->
type=sort;
127 #define BYTEDATA_SIZE(X) (*(unsigned long *)(X->value_3))
128 #define BYTEDATA_DATA(X) ((char*)((char*)X->value_3 + sizeof(unsigned long)))
141 long bits = *(
REAL *)args[0]->value_3;
143 Errorline(
"negative argument in %P.\n",funct);
146 unsigned long bytes = bits /
sizeof(char);
148 if ((bits %
sizeof(
char)) != 0) bytes++;
168 unsigned
long *bv1,*bv2;
172 unsigned long size1 = *bv1;
173 unsigned long size2 = *bv2;
174 unsigned long size3 = (size1>size2)?size1:size2;
176 unsigned char *s1 = ((
unsigned char*)bv1)+
sizeof(size1);
177 unsigned char *s2 = ((
unsigned char*)bv2)+
sizeof(size2);
178 unsigned char *s3 = ((
unsigned char *) temp_result->
value_3) +
sizeof(size3);
182 for(i=0;i<size3;i++) s3[i] = s1[i] & s2[i];
183 if (size1<size2)
for(;i<size2;i++) s3[i] = 0;
184 else for(;i<size1;i++) s3[i] = 0;
187 for(i=0;i<size3;i++) s3[i] = s1[i] | s2[i];
188 if (size1<size2)
for(;i<size2;i++) s3[i] = s2[i];
189 else for(;i<size1;i++) s3[i] = s1[i];
192 for(i=0;i<size3;i++) s3[i] = s1[i] ^ s2[i];
193 if (size1<size2)
for(;i<size2;i++) s3[i] = (
unsigned char) 0 ^ s2[i];
194 else for(;i<size1;i++) s3[i] = s1[i] ^ (
unsigned char) 0;
211 (
unsigned long *)args[1]->value_3,
252 unsigned long size1 = *bv1;
253 unsigned char *s1 = ((
unsigned char*)bv1)+
sizeof(size1);
260 s3 = ((
unsigned char *) temp_result->
value_3) +
sizeof(size1);
261 for(i=0;i<size1;i++) s3[i] = ~(s1[i]);
266 register unsigned char c;
267 for(i=0;i<size1;i++) {
276 if (c & 1<<7) cnt++; }
330 unsigned long size1 = *bv1;
331 unsigned char *s1 = ((
unsigned char*)bv1)+
sizeof(size1);
332 unsigned long i = idx /
sizeof(char);
333 int j = idx %
sizeof(char);
336 if (idx<0 || idx>=size1) {
337 Errorline(
"Index out of bound in %P.\n",funct);
345 s2 = ((
unsigned char *) temp_result->
value_3) +
sizeof(size1);
351 s2 = ((
unsigned char *) temp_result->
value_3) +
sizeof(size1);
366 (
long)*((
REAL*)args[1]->value_3),
401 #include "regexp/regexp.h"
407 fprintf(stderr,
"Regexp Error: %s\n",s);
420 regexp * re = regcomp((
char *)args[0]->value_3);
423 Errorline(
"compilation of regular expression failed in %P.\n",funct);
433 bytes = last_regsize();
443 if (re->regmust !=
NULL)
444 re->regmust = (
char *) ((
unsigned long) (re->regmust - (
char *)re));
445 bcopy((
char*)re,((
char*)temp_result->
value_3)+
sizeof(
unsigned long),bytes);
472 regexp * re = (regexp*)(((
char *)args[0]->value_3)+
sizeof(
unsigned long));
473 char * must = re->regmust;
478 offset = *(
REAL*)args[3]->value_3;
479 if (offset < 0 || offset > strlen((
char*)args[1]->value_3)) {
480 Errorline(
"Illegal offset in %P.\n",funct);
485 re->regmust = (
char*)re+(
unsigned long)must;
487 if (regexec(re,((
char *)args[1]->value_3) + offset) == 0) {
488 if (must !=
NULL) re->regmust = must;
493 char **sp = re->startp;
494 char **ep = re->endp;
498 if (must !=
NULL) re->regmust = must;
502 for (i=0;i<NSUBEXP;i++,sp++,ep++) {
503 if (*sp==
NULL)
break;
504 (void)snprintf(buffer_loc,5,
"%d",i);
512 stack_int(*ep - (
char *)args[1]->value_3 + 1));
523 for (i=0;i<NSUBEXP;i++,sp++,ep++) {
524 if (*sp==
NULL)
break;
525 (void)snprintf(buffer_loc,5,
"%d",i);
527 stack_int(*ep - (
char *)args[1]->value_3 + 1));
567 #define FP_PREPARE(s,OP) \
568 if (s->op != OP && s->op != FP_NONE) fflush(s->fp); \
585 FILE *fp = fdopen((
int)*(
REAL*)args[0]->value_3,
586 (
char*)args[1]->value_3);
610 FILE *fp = fopen((
char*)args[0]->value_3,
611 (
char*)args[1]->value_3);
655 char* txt = (
char*)args[1]->value_3;
657 if (txt && *txt!=
'\0' &&
658 fwrite((
void*)txt,
sizeof(
char),strlen(txt),srm->
fp)<=0)
679 if (fflush(srm->
fp)!=0)
return FALSE;
697 long size = *(
REAL*)args[1]->value_3;
701 bzero((
char*)t->
value_3,size+1);
703 if (fread((
void*)t->
value_3,
sizeof(
char),size,srm->
fp) <= 0)
731 if (buf->data[idx] == c) {
755 if (!*str || buf->data[idx] != *str)
757 else { idx++; str++; }
758 if (!*str && !buf->next)
return str;
778 (*buf)->
data[(*buf)->top++] = c;
783 fprintf(stderr,
"Fatal error: malloc failed in text_buffer_push\n");
786 bzero((
char*)(*buf)->next,
sizeof(
struct text_buffer));
813 int lastidx = 0,size;
816 char *sep = (
char*)args[1]->value_3;
822 bzero((
char*)&rootbuf,
sizeof(rootbuf));
825 while ((c=getc(fp)) != EOF)
832 while ((c=getc(fp)) != EOF) {
842 if ((c=getc(fp)) == EOF)
goto PackUpAndLeave;
847 lastidx=curbuf->
top - 1;
850 else goto WaitForStart;
853 if (!*cursep || (c=getc(fp))==EOF)
goto PackUpAndLeave;
855 if (c!=*cursep)
goto TryAgain;
868 for(lastbuf=&rootbuf,size=0;lastbuf!=
NULL;lastbuf=lastbuf->
next)
869 size += lastbuf->
top;
873 for(lastbuf=&rootbuf,sep=(
char*)t->
value_3;
874 lastbuf!=
NULL;sep+=lastbuf->
top,lastbuf=lastbuf->
next)
875 bcopy(lastbuf->
data,sep,lastbuf->
top);
876 ((
char*)t->
value_3)[size]=
'\0';
898 if ((c=getc(srm->
fp)) == EOF)
return FALSE;
949 (
long)*(
REAL*)args[1]->value_3,
1004 #include <sys/socket.h>
1005 #include <netinet/in.h>
1008 #include <arpa/inet.h>
1015 int addr_family=AF_INET,type=SOCK_STREAM,protocol=0;
1020 s=(
char*)args[0]->value_3;
1021 if (!strcmp(s,
"AF_UNIX")) addr_family=AF_UNIX;
1022 else if (!strcmp(s,
"AF_INET")) addr_family=AF_INET;
1024 Errorline(
"Unknown address family in %P.\n",funct);
1029 s=(
char*)args[1]->value_3;
1030 if (!strcmp(s,
"SOCK_STREAM")) type=SOCK_STREAM;
1031 else if (!strcmp(s,
"SOCK_DGRAM" )) type=SOCK_DGRAM;
1032 else if (!strcmp(s,
"SOCK_RAW" )) {
1033 Errorline(
"SOCK_RAW not supported in %P.\n",funct);
1036 Errorline(
"Unknown socket type in %P.\n",funct);
1040 if ((fd=socket(addr_family,type,protocol))<0)
1043 { FILE*fp = fdopen(fd,
"r+");
1047 Errorline(
"fdopen failed on socket in %P.\n",funct);
1071 if (s==
NULL)
return 0;
1073 if (!isdigit(*s) && *s!=
'.')
return 0;
1084 int do_bind = info==
NULL;
1086 if (args[1] || args[2]) {
1088 struct sockaddr_in name_loc;
1089 char* hostname = args[1]?(
char*)args[1]->value_3:
NULL;
1092 Errorline(
"Missing port number in %P.\n",funct);
1096 bzero((
char*)&name_loc,
sizeof(name_loc));
1097 name_loc.sin_family = AF_INET;
1098 name_loc.sin_port = htons((
unsigned short)*(
REAL*)args[2]->value_3);
1100 if (!hostname || *hostname==
'\0' || !strcasecmp(hostname,
"localhost"))
1101 name_loc.sin_addr.s_addr = INADDR_ANY;
1106 int i = inet_addr(hostname);
1107 h = gethostbyaddr((
char*)&i,
sizeof(i),AF_INET);
1108 }
else h = gethostbyname(hostname);
1111 ipaddr?
"gethostbyaddr":
"gethostbyname",funct);
1114 bcopy(h->h_addr,(
char*)&(name_loc.sin_addr.s_addr),h->h_length);
1117 bind(fd,(
struct sockaddr *)&name_loc,
sizeof(name_loc)):
1118 connect(fd,(
struct sockaddr *)&name_loc,
sizeof(name_loc))) < 0) {
1119 Errorline(
"%s failed in %P.\n",do_bind?
"bind":
"connect",funct);
1125 struct sockaddr_un name_loc;
1126 char* path = (
char*)args[3]->value_3;
1128 name_loc.sun_family = AF_UNIX;
1129 strcpy(name_loc.sun_path,path);
1132 bind(fd,(
struct sockaddr *)&name_loc,
sizeof(name_loc)):
1133 connect(fd,(
struct sockaddr *)&name_loc,
sizeof(name_loc))) < 0) {
1134 Errorline(
"%s failed in %P.\n",do_bind?
"bind":
"connect",funct);
1139 Errorline(
"Too few arguments in %P.\n",funct);
1172 int n = *(
REAL*)args[1]->value_3;
1174 if (listen(fd,n) < 0)
return FALSE;
1196 FILE * fp = fdopen(s,
"r+");
1200 Errorline(
"fdopen failed on socket in %P.\n",funct);
1244 long n = args[0]?(long)*(
REAL*)args[0]->
value_3:errno;
1275 key=args[1]->type->keyword;
1278 args[0]->type->keyword->symbol);
1292 key->
symbol=args[0]->type->keyword->symbol;
1321 if (
id < 0)
return FALSE;
1336 #define SETFEATURE(lst,n,nam,val) ((lst[n].name_str=nam),(lst[n].value_str=val))
1348 fprintf(stderr,
"unify_pterm_result called with n<0: n=%d\n",n);
1363 if (n==1)
return one;
1364 else if (n==2)
return two;
1365 else if (n==3)
return three;
1368 (void)snprintf(buf,100,
"%ld",n);
1374 #include <sys/wait.h>
1394 if (
id == -1 || status == -1) {
1395 if (errno==ECHILD) {
1401 else if (WIFEXITED(status)) {
1405 else if (WIFSIGNALED(status)) {
1409 else if (WIFSTOPPED(status)) {
1414 else if (WIFCONTINUED(status)) {
1421 Errorline(
"Unexpected wait status: %d",status2);
1432 pid_t
id = wait(&status);
1447 pid_t
id = waitpid((pid_t)(
long)*(
REAL*)args[0]->value_3,&status,
1448 args[1]?(
int)(
long)*(
REAL*)args[1]->value_3:0);
1465 return (kill((pid_t)*(
REAL*)args[0]->value_3,
1499 #ifndef MAXHOSTNAMELEN
1500 #include <sys/param.h>
1507 char name_loc[MAXHOSTNAMELEN+1];
1508 if (gethostname(name_loc,MAXHOSTNAMELEN+1) == 0) {
1529 char buffer_loc[100];
1530 if (args[1]->type ==
top) {
1536 snprintf(buffer_loc,100,
"%ld",(
long)*(
REAL*)args[1]->value_3);
1538 strcpy(buffer_loc,(
char*)args[1]->value_3);
1540 strcpy(buffer_loc,args[1]->type->keyword->symbol);
1567 char buffer_loc[100];
1568 if (args[1]->type ==
top) {
1574 snprintf(buffer_loc,100,
"%ld",(
long)*(
REAL*)args[1]->value_3);
1576 strcpy(buffer_loc,(
char*)args[1]->value_3);
1578 strcpy(buffer_loc,args[1]->type->keyword->symbol);
1603 char buffer_loc[100];
1604 if (args[1]->type ==
top) {
1610 snprintf(buffer_loc,100,
"%ld",(
long)*(
REAL*)args[1]->value_3);
1612 strcpy(buffer_loc,(
char*)args[1]->value_3);
1614 strcpy(buffer_loc,args[1]->type->keyword->symbol);
1615 if (
find(
FEATCMP,buffer_loc,args[0]->attr_list)) {
1676 Errorline(
"1st arg not a function in %P.\n",funct);
1686 feat = (
char *)args[1]->value_3;
1729 make_ndbm_type_links();
1754 check_ndbm_definitions();
1828 insert_ndbm_builtins();
static long bitvector_unop(long op)
void new_built_in(ptr_module m, char *s, def_type t, long(*r)())
new_built_in
char * text_buffer_cmp(struct text_buffer *buf, int idx, char *str)
ptr_keyword hash_lookup(ptr_hash_table table, char *symbol)
HASH_LOOKUP.
void insert_sys_builtins()
ptr_definition sys_regexp
static long c_make_bitvector()
static long c_bitvector_not()
void make_sys_type_links()
static long lazy_project_internal(args, result, funct)
void clear_copy()
clear_copy
void residuate(ptr_psi_term t)
residuate
static long wait_internal(args, result, funct)
static long gethostname_internal(args, result, funct)
static long get_code_internal(args, result, funct)
static long bitvector_bit_internal(args, result, funct, GENERIC op)
long call_primitive(long(*fun)(), int num, argi, GENERIC info)
ptr_module current_module
static long bitvector_bit_code(unsigned long *bv1, long idx, ptr_psi_term result, int op, ptr_psi_term funct)
static long my_wait_on_feature_internal(args, result, funct)
#define SETARG(args, i, the_feature, the_type, the_options)
void push_choice_point(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
push_choice_point
void push_goal(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
push_goal
static long int2stream_internal(args, result, funct)
void text_buffer_free(struct text_buffer *buf)
static long c_call_once()
static long unify_pterm_result(ptr_psi_term t, ptr_definition sym, lst, int n)
void unify_bool_result(ptr_psi_term t, long v)
unify_bool_result
char * make_module_token(ptr_module module, char *str)
static long kill_internal(args, result, funct)
static long c_stream2sys_stream()
static long bitvector_binop_code(unsigned long *bv1, unsigned long *bv2, ptr_psi_term result, GENERIC op)
static long c_regexp_compile()
static long c_int2stream()
ptr_definition definition
ptr_definition sys_file_stream
ptr_psi_term fileptr2stream(FILE *fp, ptr_definition typ)
static long fwrite_internal(args, result, funct)
static long c_get_record()
static long bitvector_unop_internal(args, result, funct, GENERIC op)
ptr_definition sys_stream
static long fopen_internal(args, result, funct)
ptr_hash_table symbol_table
static long c_bitvector_set()
static long regexp_compile_internal(args, result, funct)
static long waitpid_internal(args, result, funct)
static long errno_internal(args, result, funct)
long overlap_type(ptr_definition t1, ptr_definition t2)
static long bitvector_bit(long op)
ptr_definition update_symbol(ptr_module module, char *symbol)
static long get_buffer_internal(args, result, funct)
char * get_numeric_feature(long n)
static long c_bitvector_xor()
long sub_type(ptr_definition t1, ptr_definition t2)
static long getpid_internal(args, result, funct)
struct a_stream * ptr_stream
static long bitvector_binop(long op)
void Errorline(char *format,...)
char * heap_copy_string(char *s)
static long bitvector_binop_internal(ptr_psi_term *args, ptr_psi_term result, ptr_psi_term funct, GENERIC op)
static long socket_internal(args, result, funct)
static long unify_wait_result(ptr_psi_term result, pid_t id, int status)
#define SETFEATURE(lst, n, nam, val)
ptr_psi_term stack_pair(ptr_psi_term left, ptr_psi_term right)
stack_pair
static long c_import_symbol()
ptr_node stack_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
static long errmsg_internal(args, result, funct)
static long accept_internal(args, result, funct)
ptr_definition sys_process_signaled
void check_sys_definitions()
void hash_insert(ptr_hash_table table, char *symbol, ptr_keyword keyword)
HASH_INSERT.
static long fflush_internal(args, result, funct)
static long ftell_internal(args, result, funct)
ptr_psi_term distinct_copy(ptr_psi_term t)
distinct_copy
ptr_definition sys_bitvector
static long sys_stream2stream_internal(args, result, funct)
void make_type_link(ptr_definition t1, ptr_definition t2)
static long cuserid_internal(args, result, funct)
ptr_psi_term stack_int(long n)
stack_int
static long bitvector_unop_code(unsigned long *bv1, ptr_psi_term result, int op)
int text_buffer_next(struct text_buffer *buf, int idx, char c, struct text_buffer **rbuf, int *ridx)
ptr_definition quoted_string
ptr_definition sys_process_stopped
ptr_psi_term stack_psi_term(long stat)
stack_psi_term
ptr_definition sys_process_continued
static long c_bitvector_count()
static long import_symbol_internal(args, result, funct)
void insert_dbm_builtins()
static long c_wait_on_feature()
static long make_bitvector_internal(args, result, funct)
ptr_node find(long comp, char *keystr, ptr_node tree)
static long fclose_internal(args, result, funct)
static long c_regexp_execute()
static long fork_internal(args, result, funct)
void check_definition(ptr_definition *d)
check_definition
static long c_bitvector_or()
#define FP_PREPARE(s, OP)
ptr_definition sys_bytedata
ptr_definition sys_socket_stream
ptr_definition sys_process_exited
struct wl_psi_term * ptr_psi_term
long unify_real_result(ptr_psi_term t, REAL v)
unify_real_result
static long wait_on_feature_internal(args, result, funct)
static long c_bitvector_and()
static long get_record_internal(args, result, funct)
static ptr_psi_term make_bytedata(ptr_definition sort, unsigned long bytes)
static long c_lazy_project()
static long c_my_wait_on_feature()
static long c_bitvector_get()
static long c_bitvector_clear()
static long apply1_internal(args, result, funct)
static long c_sys_stream2stream()
ptr_psi_term stack_string(char *s)
stack_string
static long listen_internal(args, result, funct)
static long stream2sys_stream_internal(args, result, funct)
struct text_buffer * next
static long bind_or_connect_internal(args, result, funct, void *info)
static long c_gethostname()
ptr_module set_current_module(ptr_module module)
static long c_get_buffer()
static long call_once_internal(args, result, funct)
ptr_definition sys_process_no_children
GENERIC heap_alloc(long s)
heap_alloc
void stack_insert_copystr(char *keystr, ptr_node *tree, GENERIC info)
ptr_choice_point choice_stack
static long regexp_execute_internal(args, result, funct)
static long fseek_internal(args, result, funct)
void text_buffer_push(struct text_buffer **buf, char c)