int _SLns_set_namespace_name (SLang_NameSpace_Type *t, char *name) { SLang_NameSpace_Type *t1; t1 = _SLns_find_namespace (name); if (t == t1) return 0; /* already has this name */ if (t1 == NULL) t1 = t; if ((t != t1) || (*name == 0)) { SLang_verror (SL_INTRINSIC_ERROR, "Namespace \"%s\" already exists", name); return -1; } if (t->namespace_name != NULL) { SLang_verror (SL_INTRINSIC_ERROR, "An attempt was made to redefine namespace from \"%s\" to \"%s\"\n", t->namespace_name, name); return -1; } if (NULL == (name = SLang_create_slstring (name))) return -1; SLang_free_slstring (t->namespace_name); /* NULL ok */ t->namespace_name = name; return 0; }
static int bind_af_unix (Socket_Type *s, int nargs) { struct sockaddr_un addr; char *file; if (nargs != 1) { SLang_verror (SL_NumArgs_Error, "This socket expects a filename"); return -1; } if (-1 == SLang_pop_slstring (&file)) return -1; if (strlen (file) >= sizeof(addr.sun_path)) { SLang_verror (SL_InvalidParm_Error, "filename too long for PF_UNIX socket"); SLang_free_slstring (file); return -1; } memset ((char *)&addr, 0, sizeof (struct sockaddr_un)); addr.sun_family = AF_UNIX; strcpy (addr.sun_path, file); /* \0 terminated */ (void) unlink (file); s->socket_data = (VOID_STAR) file; return perform_bind (s->fd, (struct sockaddr *)&addr, sizeof (addr)); }
static Png_Type *open_png_file (char *file) { png_byte header[8]; Png_Type *p; if (NULL == (p = alloc_png_type ('r'))) return NULL; if ((NULL == (p->fp = fopen (file, "rb"))) || (8 != fread (header, 1, 8, p->fp)) || (0 != png_sig_cmp(header, 0, 8))) { SLang_verror (SL_Open_Error, "Unable to open %s as a png file", file); free_png_type (p); return NULL; } if (NULL == (p->png = png_create_read_struct (PNG_LIBPNG_VER_STRING, NULL, NULL, NULL))) { SLang_verror (SL_Open_Error, "Unable to read png structure from %s", file); free_png_type (p); return NULL; } if (NULL == (p->info = png_create_info_struct (p->png))) { SLang_verror (SL_Read_Error, "Unable to create info struct for %s", file); free_png_type (p); return NULL; } return p; }
int init_slsmg_module_ns (char *ns_name) { SLang_NameSpace_Type *ns; static int inited = 0; if (inited == 0) { #if defined(VMS) || defined(REAL_UNIX_SYSTEM) int status; char *term = getenv ("TERM"); if (term == NULL) { SLang_verror (SL_Application_Error, "The TERM environment variable is not set"); return -1; } status = SLtt_initialize (term); if (status == -1) { SLang_verror (SL_RunTime_Error, "Cannot deduce properties for '%s' terminal", term); return -1; } if (status < 0) { SLang_verror (SL_RunTime_Error, "The terminal '%s' lacks sufficient capabilities for controlling it", term); return -1; } #else SLtt_get_terminfo (); #endif inited = 1; } ns = SLns_create_namespace (ns_name); if (ns == NULL) return -1; if ((-1 == SLns_add_intrin_fun_table (ns, Smg_Intrinsics, "__SLSMG__")) || (-1 == SLns_add_iconstant_table (ns, Smg_Constants, NULL))) return -1; if ((-1 == SLns_add_intrinsic_variable(ns, "SLsmg_Display_Eight_Bit", (VOID_STAR)&SLsmg_Display_Eight_Bit, SLANG_INT_TYPE, 0)) || (-1 == SLns_add_intrinsic_variable(ns, "SLsmg_Tab_Width", (VOID_STAR)&SLsmg_Tab_Width, SLANG_INT_TYPE, 0)) || (-1 == SLns_add_intrinsic_variable(ns, "SLsmg_Newline_Behavior", (VOID_STAR)&SLsmg_Newline_Behavior, SLANG_INT_TYPE, 0)) || (-1 == SLns_add_intrinsic_variable(ns, "SLsmg_Backspace_Moves", (VOID_STAR)&SLsmg_Backspace_Moves, SLANG_INT_TYPE, 0)) || (-1 == SLns_add_intrinsic_variable(ns, "SLsmg_Screen_Rows", (VOID_STAR)&SLtt_Screen_Rows, SLANG_INT_TYPE, 0)) || (-1 == SLns_add_intrinsic_variable(ns, "SLsmg_Screen_Cols", (VOID_STAR)&SLtt_Screen_Cols, SLANG_INT_TYPE, 0))) return -1; Smg_Initialized = 0; return 0; }
static void accept_intrin (void) { SLFile_FD_Type *f; Socket_Type *s, *s1; Domain_Methods_Type *methods; int nargs = SLang_Num_Function_Args; SLang_Ref_Type *refs[MAX_ACCEPT_REF_ARGS]; int i; if (nargs <= 0) { SLang_verror (SL_Usage_Error, "s1 = accept (s [,&v...])"); return; } if (-1 == SLroll_stack (-nargs)) return; if (NULL == (s = pop_socket (&f))) return; nargs--; if (nargs > MAX_ACCEPT_REF_ARGS) { SLang_verror (SL_NumArgs_Error, "accept: too many reference args"); SLfile_free_fd (f); } memset ((char *)refs, 0, sizeof (refs)); i = nargs; while (i != 0) { i--; if (-1 == SLang_pop_ref (refs+i)) goto free_return; } methods = s->methods; if (NULL != (s1 = (*methods->accept)(s, nargs, refs))) (void) push_socket (s1); /* frees it upon error */ /* drop */ free_return: for (i = 0; i < nargs; i++) { if (refs[i] != NULL) SLang_free_ref (refs[i]); } SLfile_free_fd (f); }
static void run_hooks_cmd (void) { unsigned int n; SLang_Array_Type *at; int method; char *hook; n = (unsigned int) SLang_Num_Function_Args; at = NULL; hook = NULL; switch (n) { case 3: if (-1 == SLang_pop_array_of_type (&at, SLANG_STRING_TYPE)) return; /* drop */ case 2: if (-1 == SLang_pop_integer (&method)) goto the_return; if (-1 == SLang_pop_slstring (&hook)) goto the_return; break; default: SLang_verror (SL_USAGE_ERROR, "usage: expecting 2 or 3 arguments"); return; } switch (method) { case JED_HOOKS_RUN_ALL: case JED_HOOKS_RUN_UNTIL_0: case JED_HOOKS_RUN_UNTIL_NON_0: break; default: SLang_verror (SL_INVALID_PARM, "run method %d is not supported", method); goto the_return; } if (at == NULL) (void) jed_run_hooks (hook, method, 0, NULL); else (void) jed_run_hooks (hook, method, at->num_elements, (char **) at->data); the_return: SLang_free_slstring (hook); SLang_free_array (at); }
static int connect_af_inet (Socket_Type *s, int nargs) { struct sockaddr_in s_in; int port; char *host; Host_Addr_Info_Type *hinfo; unsigned int i; if (-1 == pop_host_port ("connect", nargs, &host, &port)) return -1; if (NULL == (hinfo = get_host_addr_info (host))) { SLang_free_slstring (host); return -1; } if (hinfo->h_addrtype != AF_INET) { # ifdef AF_INET6 if (hinfo->h_addrtype == AF_INET6) SLang_verror (SL_NOT_IMPLEMENTED, "AF_INET6 not implemented"); else # endif SLang_verror (SocketError, "Unknown socket family for host %s", host); SLang_free_slstring (host); free_host_addr_info (hinfo); return -1; } memset ((char *) &s_in, 0, sizeof(s_in)); s_in.sin_family = hinfo->h_addrtype; s_in.sin_port = htons((unsigned short) port); for (i = 0; i < hinfo->num; i++) { memcpy ((char *) &s_in.sin_addr, hinfo->h_addr_list[i], hinfo->h_length); if (-1 == perform_connect (s->fd, (struct sockaddr *)&s_in, sizeof (s_in), 0)) continue; free_host_addr_info (hinfo); SLang_free_slstring (host); return 0; } throw_errno_error ("connect", errno); free_host_addr_info (hinfo); SLang_free_slstring (host); return -1; }
int user_create_ray (double *delta_t, double *energy, double *cosx, double *cosy, double *cosz) { if (Num_Rays == 0) { if (-1 == SLexecute_function (Create_Ray)) { SLang_verror (0, "Encountered an error processing %s\n", "user_create_ray"); return -1; } if (SLang_peek_at_stack () == SLANG_NULL_TYPE) return -1; /* done */ if ((-1 == pop_array (&CosZ_Array)) || (-1 == pop_array (&CosY_Array)) || (-1 == pop_array (&CosX_Array)) || (-1 == pop_array (&Energy_Array)) || (-1 == pop_array (&dT_Array))) { SLang_verror (0, "Encountered an error processing %s\n", "user_create_ray"); return -1; } if (Num_Rays == 0) return -1; if (CosX_Array.num_elements < Num_Rays) CosX_Array.di = 0; if (CosY_Array.num_elements < Num_Rays) CosY_Array.di = 0; if (CosZ_Array.num_elements < Num_Rays) CosZ_Array.di = 0; if (dT_Array.num_elements < Num_Rays) dT_Array.di = 0; if (Energy_Array.num_elements < Num_Rays) Energy_Array.di = 0; } *cosx = next_element (&CosX_Array); *cosy = next_element (&CosY_Array); *cosz = next_element (&CosZ_Array); *delta_t = next_element (&dT_Array); *energy = next_element (&Energy_Array); Num_Rays--; return 0; }
static int test_type_sput (SLtype type, SLFUTURE_CONST char *name) { Test_Type *t; int status; (void) type; if (-1 == pop_test_type (&t)) return -1; status = -1; if (0 == strcmp (name, "field1")) status = SLang_pop_int (&t->field1); else if (0 == strcmp (name, "field2")) status = SLang_pop_int (&t->field2); else if (0 == strcmp (name, "any")) { SLang_Any_Type *any; if (0 == (status = SLang_pop_anytype (&any))) { SLang_free_anytype (t->any); t->any = any; } } else SLang_verror (SL_INVALID_PARM, "Test_Type.%s is invalid", name); free_test_type (t); return status; }
/* printing arrays [code adapted from jdl functions by John Davis] */ static int pop_matrix (SLang_Array_Type **at_ptr, unsigned int *nr, unsigned int *nc) /*{{{*/ { SLang_Array_Type *at; if (-1 == SLang_pop_array (&at, 0)) return -1; switch (at->num_dims) { case 0: *nr = *nc = 0; break; case 1: *nr = (unsigned int)at->dims[0]; *nc = 1; break; case 2: *nr = (unsigned int)at->dims[0]; *nc = (unsigned int)at->dims[1]; break; default: SLang_verror (SL_TYPE_MISMATCH, "operation limited to 2-d arrays"); SLang_free_array (at); *at_ptr = NULL; return -1; } *at_ptr = at; return 0; }
static void _iconv_open(char *tocode, char *fromcode) { iconv_t cd; SLang_MMT_Type *mmt; cd = iconv_open(tocode, fromcode); if (cd == (iconv_t)(-1)) { SLang_verror (SL_INTRINSIC_ERROR, "Error preparing iconv to convert from '%s' to '%s'.", fromcode, tocode); return; } if (NULL == (mmt = allocate_iconv_type (cd))) { iconv_close(cd); return; } if (-1 == SLang_push_mmt (mmt)) { SLang_free_mmt (mmt); return; } return; }
/* This function is reentrant */ static int handle_signal (Signal_Type *s) { int status = 0; int was_blocked; (void) block_signal (s->sig, &was_blocked); /* At this point, sig is blocked and the handler is about to be called. * The pending flag can be safely set to 0 here. */ s->pending = 0; if (s->handler != NULL) { int depth = SLstack_depth (); if ((-1 == SLang_start_arg_list ()) || (-1 == SLang_push_integer (s->sig)) || (-1 == SLang_end_arg_list ()) || (-1 == SLexecute_function (s->handler))) status = -1; if ((status == 0) && (depth != SLstack_depth ())) { SLang_verror (SL_Application_Error, "The signal handler %s corrupted the stack", s->handler->name); status = -1; } } if (was_blocked == 0) (void) unblock_signal (s->sig); return status; }
static int do_onig_search_internal (Onig_Type *o, OnigOptionType option, UChar *str, UChar *str_end, int start_pos, int end_pos) { UChar *start, *range; int status; onig_region_clear (o->region); start = str + start_pos; range = str + end_pos; /* fwd search: (start <= search string < range) * bkw search: (range <= search string <= start) */ if ((start < str) || (start > str_end) || (range < str) || (range > str_end)) { SLang_verror (SL_InvalidParm_Error, "Invalid string offsets"); return -1; } status = onig_search (o->re, str, str_end, start, range, o->region, option); if (status >= 0) return status; if (status == ONIG_MISMATCH) return -1; throw_onig_error (status, NULL); return -2; }
/* Here nx corresponds to the fastest varying dimension and ny the slowest */ static SLang_Array_Type *pop_2d_float_array (float **data, unsigned int *ny, unsigned int *nx) { SLang_Array_Type *at; *data = NULL; *nx = *ny = 0; if (-1 == SLclass_typecast (SLANG_FLOAT_TYPE, 1, 1)) return NULL; if (-1 == SLang_pop_array (&at, 1)) return NULL; if (at->num_dims > 2) { SLang_verror (SL_TYPE_MISMATCH, "A 2d numeric array is expected"); SLang_free_array (at); return NULL; } *data = (float *)at->data; *ny = at->dims[0]; if (at->num_dims == 1) *nx = 1; else *nx = at->dims[1]; return at; }
static void sl_ssl_read(void){ SLssl_Type *ssl; SLang_MMT_Type *sslmmt; SLang_Ref_Type *buff; void *ibuff; SLang_BString_Type *data; int r, rlen; if (SLang_pop_integer(&rlen)==-1 || SLang_pop_ref(&buff)==-1 || NULL==(sslmmt=SLang_pop_mmt(SLssl_Type_Id))) return; ssl=(SLssl_Type *)SLang_object_from_mmt(sslmmt); ibuff=(void *)malloc(rlen); r=SSL_read((SSL *)ssl->ssl,ibuff,rlen); data=SLbstring_create((unsigned char *)ibuff,r); SLang_assign_to_ref(buff, SLANG_BSTRING_TYPE, (VOID_STAR)&data); if (r>=0) SLang_push_integer(r); else SLang_verror(r,"SSL read returned error code %d", SSL_get_error((SSL *)ssl->ssl,r)); SLang_free_ref(buff); }
static int setup_onig (void) { static int inited = 0; if (inited) return 0; if ((-1 == slOnig_Error) && (-1 == (slOnig_Error = SLerr_new_exception (SL_RunTime_Error, "OnigError", "Onig Error")))) return -1; if (-1 == onig_init ()) { SLang_verror (slOnig_Error, "onig_init failed"); return -1; } onig_set_warn_func (&warn_func); onig_set_verb_warn_func (&verb_warn_func); onig_set_default_syntax (ONIG_SYNTAX_PERL); inited = 1; return 0; }
static void throw_onig_error (int err_code, OnigErrorInfo *einfo) { UChar err_buf[ONIG_MAX_ERROR_MESSAGE_LEN]; (void) onig_error_code_to_str (err_buf, err_code, einfo); SLang_verror (slOnig_Error, "%s", err_buf); }
static void termios_set_cc (void) { SLang_Array_Type *at; SLang_MMT_Type *mmt; struct termios *s; unsigned char *at_data; int i; if (-1 == SLang_pop_array_of_type (&at, SLANG_UCHAR_TYPE)) return; if (NULL == (mmt = SLang_pop_mmt (Termios_Type_Id))) goto free_and_return; s = (struct termios *) SLang_object_from_mmt (mmt); if (at->num_elements != NCCS) { SLang_verror (SL_TYPE_MISMATCH, "Expecting UChar_Type[%d]", NCCS); goto free_and_return; } at_data = (unsigned char *) at->data; for (i = 0; i < NCCS; i++) s->c_cc[i] = at_data[i]; /* drop */ free_and_return: SLang_free_array (at); SLang_free_mmt (mmt); }
static void pipe_intrin (void) { int fds[2]; SLFile_FD_Type *f0; SLFile_FD_Type *f1; while (-1 == pipe (fds)) { if (errno == EINTR) { if (-1 != SLang_handle_interrupt ()) continue; } SLerrno_set_errno (errno); SLang_verror (SL_OS_Error, "pipe failed: %s", SLerrno_strerror(errno)); return; } f0 = SLfile_create_fd ("*pipe*", fds[0]); f1 = SLfile_create_fd ("*pipe*", fds[1]); if ((NULL != f0) && (NULL != f1)) { /* Ignore errors and allow the free_fd routines to clean up */ (void) SLfile_push_fd (f0); (void) SLfile_push_fd (f1); } SLfile_free_fd (f1); SLfile_free_fd (f0); }
static int execve_intrin (void) { if (SLang_Num_Function_Args != 2) SLang_verror (SL_Usage_Error, "Usage: ret = execvp(path, argv[]);"); return exec_what (CALL_EXECVE, 0); }
static SLang_BString_Type *create_bstring_of_type (char *bytes, unsigned int len, int type) { SLang_BString_Type *b; unsigned int size; unsigned int malloced_len = len; size = sizeof(SLang_BString_Type); if (type == IS_BSTRING) { unsigned int dlen = BSTRING_EXTRA_BYTES(len); malloced_len = len + dlen; if ((malloced_len < len) || (size + malloced_len < size)) { SLang_verror (SL_Malloc_Error, "Unable to create a binary string of the desired size"); return NULL; } size += malloced_len; } if (NULL == (b = (SLang_BString_Type *)SLmalloc (size))) return NULL; b->len = len; b->malloced_len = malloced_len; b->num_refs = 1; b->ptr_type = type; switch (type) { default: case IS_BSTRING: if (bytes != NULL) memcpy ((char *) b->v.bytes, bytes, len); /* Now \0 terminate it because we want to also use it as a C string * whenever possible. Note that sizeof(SLang_BString_Type) includes * space for 1 character and we allocated len extra bytes. Thus, it is * ok to add a \0 to the end. */ b->v.bytes[len] = 0; break; case IS_SLSTRING: if (NULL == (b->v.ptr = (unsigned char *)SLang_create_nslstring (bytes, len))) { SLfree ((char *) b); return NULL; } break; case IS_MALLOCED: case IS_NOT_TO_BE_FREED: b->v.ptr = (unsigned char *)bytes; bytes [len] = 0; /* NULL terminate */ break; } return b; }
static MMap_Type *mmap_file (char *file, size_t offset, size_t num_bytes) { FILE *fp; int fd; struct stat st; VOID_STAR addr; MMap_Type *m; fp = fopen (file, "rb"); if (fp == NULL) { SLang_verror (SL_OBJ_NOPEN, "mmap_array: unable to open %s for reading", file); return NULL; } fd = fileno (fp); if (-1 == fstat (fd, &st)) { SLang_verror (SL_INTRINSIC_ERROR, "mmap_array: stat %s failed", file); fclose (fp); return NULL; } if (NULL == (m = (MMap_Type *) SLmalloc (sizeof (MMap_Type)))) { fclose (fp); return NULL; } m->size_mmapped = num_bytes + offset; addr = (VOID_STAR)mmap (NULL, m->size_mmapped, PROT_READ, MAP_SHARED, fd, 0); if (addr == (VOID_STAR)MAP_FAILED) { SLang_verror (SL_INTRINSIC_ERROR, "mmap_array: mmap %s failed", file); SLfree ((char *) m); fclose (fp); return NULL; } m->addr = addr; m->data = (VOID_STAR) ((char *)addr + offset); fclose (fp); return m; }
static int check_vectors (SLang_Array_Type *a, SLang_Array_Type *b) { if (a->num_elements != b->num_elements) { SLang_verror (SL_TYPE_MISMATCH, "Arrays do not match in size"); return -1; } return 0; }
static void sl_ssl_client (void){ // create an ssl object and return the memory managed type back to // SLang. It needs the file descriptor of the object upon which // communication will occur, and the protocol to use. // SSL_CTX *ctx; SSL *ssl; int proto, cret; SLang_MMT_Type *mmt, *sslmmt; SLsslctx_Type *slctx; char *cadir=NULL, *cafile=NULL; if (SLang_Num_Function_Args == 3) if (SLang_pop_slstring(&cadir) == -1) return; if (SLang_Num_Function_Args > 1) if (SLANG_NULL_TYPE==SLang_peek_at_stack()) SLdo_pop(); else if (SLang_pop_slstring(&cafile) == -1) goto free; if (SLang_pop_integer(&proto) == -1) goto free; if (proto==SSL_PROTO_SSL2) ctx = SSL_CTX_new(SSLv23_client_method()); else if (proto==SSL_PROTO_SSL3) ctx = SSL_CTX_new(SSLv3_client_method()); else if (proto==SSL_PROTO_TLS1) ctx = SSL_CTX_new(TLSv1_client_method()); else if (proto==SSL_PROTO_ANY) ctx = SSL_CTX_new(SSLv23_client_method()); cret = SSL_CTX_load_verify_locations(ctx, cafile, cadir); if (cret == 0 && SLang_Num_Function_Args > 1){ SLang_verror(SL_APPLICATION_ERROR, "Failed to load CA file or path"); goto free; } slctx = (SLsslctx_Type *)malloc(sizeof(SLsslctx_Type)); slctx->is_server = 0; slctx->ctx = (void *)ctx; sslmmt = SLang_create_mmt(SLsslctx_Type_Id, (VOID_STAR) slctx); if (0!=SLang_push_mmt(sslmmt)) SLang_free_mmt(sslmmt); free: if (NULL!=cadir) SLang_free_slstring(cadir); if (NULL!=cafile) SLang_free_slstring(cafile); }
static Socket_Type *socket_from_fd (SLFile_FD_Type *f) { Socket_Type *s; if (-1 == SLfile_get_clientdata (f, Socket_Type_Id, (VOID_STAR *)&s)) { SLang_verror (SL_TypeMismatch_Error, "File descriptor does not represent a socket"); return NULL; } return s; }
static SLang_IStruct_Field_Type *istruct_pop_field (char *name, int no_readonly, VOID_STAR *addr) { _SLang_IStruct_Type *s; SLang_IStruct_Field_Type *f; char *struct_addr; /* Note: There is no need to free this object */ if (-1 == SLclass_pop_ptr_obj (SLANG_ISTRUCT_TYPE, (VOID_STAR *) &s)) return NULL; if (NULL == (struct_addr = *(char **)s->addr)) { SLang_verror (SL_INTRINSIC_ERROR, "%s is NULL. Unable to access field", s->name); return NULL; } f = s->fields; while (f->field_name != NULL) { /* Since both these are slstrings, just test pointers */ if (f->field_name != name) { f++; continue; } if (no_readonly && f->read_only) { SLang_verror (SL_READONLY_ERROR, "%s.%s is read-only", s->name, name); return NULL; } *addr = (VOID_STAR) (struct_addr + f->offset); return f; } SLang_verror (SL_TYPE_MISMATCH, "%s has no field called %s", s->name, name); return NULL; }
static void sl_decrypt (void){ /* input types */ char *ctype; unsigned char *outbuf, *iiv, *ikey, *idata; SLang_BString_Type *iv, *key, *data; /* internal types */ EVP_CIPHER_CTX ctx; const EVP_CIPHER *cipher; int outlen, tmplen, dlen, i; /* output types */ SLang_BString_Type *output; if (SLang_Num_Function_Args != 4 || SLang_pop_slstring(&ctype) == -1 ){ return; } cipher = EVP_get_cipherbyname(ctype); if (!cipher){ SLang_verror(SL_UNDEFINED_NAME,"could not find cipher %s",ctype); return; } if (SLang_pop_bstring(&iv) == -1 || SLang_pop_bstring(&key) == -1 || SLang_pop_bstring(&data) == -1 ){ return; } iiv = SLbstring_get_pointer (iv,&i); ikey = SLbstring_get_pointer (key,&i); idata = SLbstring_get_pointer (data,&dlen); outbuf = (char*)malloc(dlen+EVP_CIPHER_block_size(cipher)); EVP_CIPHER_CTX_init(&ctx); EVP_DecryptInit_ex(&ctx, cipher, NULL, ikey, iiv); if (!EVP_DecryptUpdate(&ctx, outbuf, &outlen, idata, dlen)){ return; /*emit an error here*/ } if (!EVP_DecryptFinal(&ctx, outbuf + outlen, &tmplen)){ return; /*emit an error here*/ } outlen+=tmplen; output = SLbstring_create (outbuf, outlen); SLang_push_bstring(output); SLbstring_free(output); SLbstring_free(data); SLbstring_free(key); SLbstring_free(iv); free(outbuf); }
static int init_slang (void) { if ((-1 == SLang_init_all ()) || (-1 == SLang_init_array_extra ()) || (-1 == SLang_init_import ()) /* dynamic linking */ || (-1 == SLadd_intrin_fun_table (Intrinsics, NULL))) { SLang_verror (0, "Unable to initialize S-Lang.\n"); return -1; } return 0; }
static void getitimer_intrinsic (int *wp) { struct itimerval it; if (-1 == getitimer (*wp, &it)) { SLerrno_set_errno (errno); SLang_verror (SL_OS_Error, "getitimer failed: %s", SLerrno_strerror (errno)); return; } (void) SLang_push_double (timeval_to_double (&it.it_value)); (void) SLang_push_double (timeval_to_double (&it.it_interval)); }
static int intp_pop (SLtype unused, VOID_STAR ptr) { int *addr; (void) unused; addr = *(int **)ptr; if (addr == NULL) { SLang_verror (SL_VariableUninitialized_Error, "_IntegerP_Type: integer pointer address is NULL"); return -1; } return SLang_pop_integer (addr); }