1 /* -*- mode: C; mode: fold; -*- */
2 /* Standard intrinsic functions for S-Lang. Included here are string
3 and array operations */
4 /*
5 Copyright (C) 2004-2017,2018 John E. Davis
6
7 This file is part of the S-Lang Library.
8
9 The S-Lang Library is free software; you can redistribute it and/or
10 modify it under the terms of the GNU General Public License as
11 published by the Free Software Foundation; either version 2 of the
12 License, or (at your option) any later version.
13
14 The S-Lang Library is distributed in the hope that it will be useful,
15 but WITHOUT ANY WARRANTY; without even the implied warranty of
16 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
17 General Public License for more details.
18
19 You should have received a copy of the GNU General Public License
20 along with this library; if not, write to the Free Software
21 Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
22 USA.
23 */
24
25 #define _BSD_SOURCE 1 /* to get strtoll */
26 #define _SVID_SOURCE /* for putenv */
27 #define _DEFAULT_SOURCE 1
28 #include "slinclud.h"
29 /*{{{ Include Files */
30
31 #include <time.h>
32
33 #ifndef __QNX__
34 # if defined(__GO32__) || defined(__WATCOMC__)
35 # include <dos.h>
36 # include <bios.h>
37 # endif
38 #endif
39
40 #if SLANG_HAS_FLOAT
41 # include <math.h>
42 #endif
43
44 #if defined(__APPLE__) && defined(HAVE_ENVIRON)
45 # include <crt_externs.h> /* for _NSGetEnviron */
46 #endif
47
48 #include "slang.h"
49 #include "_slang.h"
50
51 /*}}}*/
52
53 /* builtin stack manipulation functions */
SLdo_pop(void)54 int SLdo_pop(void) /*{{{*/
55 {
56 return SLdo_pop_n (1);
57 }
58
59 /*}}}*/
60
SLdo_pop_n(unsigned int n)61 int SLdo_pop_n (unsigned int n)
62 {
63 SLang_Object_Type x;
64
65 while (n--)
66 {
67 if (SLang_pop(&x)) return -1;
68 SLang_free_object (&x);
69 }
70
71 return 0;
72 }
73
do_dup(void)74 static void do_dup(void) /*{{{*/
75 {
76 (void) SLdup_n (1);
77 }
78
79 /*}}}*/
80
length_cmd(void)81 static void length_cmd (void)
82 {
83 SLang_Class_Type *cl;
84 SLang_Object_Type obj;
85 VOID_STAR p;
86 SLuindex_Type length;
87 SLindex_Type ilen;
88
89 if (-1 == SLang_pop (&obj))
90 return;
91
92 cl = _pSLclass_get_class (obj.o_data_type);
93 p = _pSLclass_get_ptr_to_value (cl, &obj);
94
95 ilen = 1;
96 if (cl->cl_length != NULL)
97 {
98 if (0 == (*cl->cl_length)(obj.o_data_type, p, &length))
99 ilen = (SLindex_Type) length;
100 else
101 ilen = -1;
102 }
103
104 SLang_free_object (&obj);
105 (void) SLang_push_array_index (ilen);
106 }
107
108 /* convert integer to a string of length 1 */
char_cmd(SLwchar_Type * x)109 static void char_cmd (SLwchar_Type *x) /*{{{*/
110 {
111 SLuchar_Type buf[SLUTF8_MAX_MBLEN + 1];
112 int is_byte;
113
114 is_byte = ((signed)*x < 0);
115 if (is_byte)
116 {
117 buf[0] = (SLuchar_Type) (-(signed)*x);
118 buf[1] = 0;
119 }
120 else if ((_pSLinterp_UTF8_Mode == 0)
121 || (*x < 0x80))
122 {
123 buf[0] = (SLuchar_Type) *x;
124 buf[1] = 0;
125 }
126 else
127 {
128 SLuchar_Type *p;
129
130 p = SLutf8_encode (*x, buf, SLUTF8_MAX_MBLEN);
131 if (p == NULL) p = buf;
132
133 *p = 0;
134 }
135
136 SLang_push_string ((char *)buf);
137 }
138
139 /*}}}*/
140
141 /* format object into a string and returns slstring */
_pSLstringize_object(SLang_Object_Type * obj)142 char *_pSLstringize_object (SLang_Object_Type *obj) /*{{{*/
143 {
144 SLang_Class_Type *cl;
145 SLtype stype;
146 VOID_STAR p;
147 char *s, *s1;
148
149 stype = obj->o_data_type;
150 p = (VOID_STAR) &obj->v.ptr_val;
151
152 cl = _pSLclass_get_class (stype);
153
154 s = (*cl->cl_string) (stype, p);
155 if (s != NULL)
156 {
157 s1 = SLang_create_slstring (s);
158 SLfree (s);
159 s = s1;
160 }
161 return s;
162 }
163 /*}}}*/
164
SLang_run_hooks(SLFUTURE_CONST char * hook,unsigned int num_args,...)165 int SLang_run_hooks (SLFUTURE_CONST char *hook, unsigned int num_args, ...)
166 {
167 unsigned int i;
168 va_list ap;
169
170 if (SLang_get_error ())
171 return -1;
172
173 if (0 == SLang_is_defined (hook))
174 return 0;
175
176 (void) SLang_start_arg_list ();
177 va_start (ap, num_args);
178 for (i = 0; i < num_args; i++)
179 {
180 char *arg;
181
182 arg = va_arg (ap, char *);
183 if (-1 == SLang_push_string (arg))
184 break;
185 }
186 va_end (ap);
187 (void) SLang_end_arg_list ();
188
189 if (_pSLang_Error) return -1;
190 return SLang_execute_function (hook);
191 }
192
intrin_getenv_cmd(char * s)193 static void intrin_getenv_cmd (char *s)
194 {
195 SLang_push_string (getenv (s));
196 }
197
198 #ifdef HAVE_PUTENV
199 /* This is a silly hack to deal with the ambiguity of whether or not to free
200 * a pointer passed to putenv. Here it is attached to an array so that leak
201 * checkers can located it.
202 */
203 # define MAX_PUTENV_ARRAY_SIZE 64
204 static char *Putenv_Pointer_Array[MAX_PUTENV_ARRAY_SIZE];
205 unsigned int Num_Putenv_Pointers = 0;
intrin_putenv(void)206 static void intrin_putenv (void) /*{{{*/
207 {
208 char *s;
209
210 /* Some putenv implementations require malloced strings. */
211 if (SLpop_string(&s)) return;
212
213 if (putenv (s))
214 {
215 SLang_set_error (SL_OS_Error);
216 SLfree (s);
217 }
218 /* Note that s is NOT freed */
219
220 if (Num_Putenv_Pointers < MAX_PUTENV_ARRAY_SIZE)
221 Putenv_Pointer_Array[Num_Putenv_Pointers++] = s;
222 }
223
224 /*}}}*/
225
226 #endif
227
byte_compile_file(char * f,int * m)228 static void byte_compile_file (char *f, int *m)
229 {
230 SLang_byte_compile_file (f, *m);
231 }
232
intrin_type_info1(void)233 static void intrin_type_info1 (void)
234 {
235 SLang_Object_Type obj;
236 unsigned int type;
237
238 if (-1 == SLang_pop (&obj))
239 return;
240
241 type = obj.o_data_type;
242 if (type == SLANG_ARRAY_TYPE)
243 type = obj.v.array_val->data_type;
244
245 SLang_free_object (&obj);
246
247 SLang_push_datatype (type);
248 }
249
intrin_type_info(void)250 static void intrin_type_info (void)
251 {
252 SLang_Object_Type obj;
253
254 if (-1 == SLang_pop (&obj))
255 return;
256
257 SLang_push_datatype (obj.o_data_type);
258 SLang_free_object (&obj);
259 }
260
_pSLstring_intrinsic(void)261 void _pSLstring_intrinsic (void) /*{{{*/
262 {
263 SLang_Object_Type x;
264 char *s;
265
266 if (SLANG_STRING_TYPE == SLang_peek_at_stack ())
267 return;
268
269 if (-1 == SLang_pop (&x))
270 return;
271
272 if (NULL != (s = _pSLstringize_object (&x)))
273 _pSLang_push_slstring (s);
274
275 SLang_free_object (&x);
276 }
277
278 /*}}}*/
279
intrin_typecast(void)280 static void intrin_typecast (void)
281 {
282 SLtype to_type;
283 if (0 == SLang_pop_datatype (&to_type))
284 (void) SLclass_typecast (to_type, 0, 1);
285 }
286
287 #if SLANG_HAS_FLOAT
intrin_double(void)288 static void intrin_double (void)
289 {
290 (void) SLclass_typecast (SLANG_DOUBLE_TYPE, 0, 1);
291 }
292
293 #endif
294
intrin_int(void)295 static void intrin_int (void) /*{{{*/
296 {
297 (void) SLclass_typecast (SLANG_INT_TYPE, 0, 1);
298 }
299
300 /*}}}*/
301
302 static SLCONST char *
intrin_function_name(void)303 intrin_function_name (void)
304 {
305 SLCONST char *name;
306 if (NULL == (name = _pSLang_current_function_name ()))
307 return "";
308 return name;
309 }
310
intrin_message(char * s)311 static void intrin_message (char *s)
312 {
313 SLang_vmessage ("%s", s);
314 }
315
intrin_error(char * s)316 static void intrin_error (char *s)
317 {
318 _pSLang_verror (SL_RunTime_Error, "%s", s);
319 }
320
intrin_pop_n(int * n)321 static void intrin_pop_n (int *n)
322 {
323 SLdo_pop_n ((unsigned int) *n);
324 }
325
intrin_reverse_stack(int * n)326 static void intrin_reverse_stack (int *n)
327 {
328 SLreverse_stack (*n);
329 }
330
intrin_roll_stack(int * n)331 static void intrin_roll_stack (int *n)
332 {
333 SLroll_stack (*n);
334 }
335
usage(void)336 static void usage (void)
337 {
338 char *msg;
339
340 _pSLstrops_do_sprintf_n (SLang_Num_Function_Args - 1); /* do not include format */
341
342 if (-1 == SLang_pop_slstring (&msg))
343 return;
344
345 _pSLang_verror (SL_USAGE_ERROR, "Usage: %s", msg);
346 SLang_free_slstring (msg);
347 }
348
guess_type(char * s)349 static void guess_type (char *s)
350 {
351 SLang_push_datatype (SLang_guess_type(s));
352 }
353
load_string_or_file(int (* f)(SLFUTURE_CONST char *,SLFUTURE_CONST char *))354 static int load_string_or_file (int (*f) (SLFUTURE_CONST char *, SLFUTURE_CONST char *))
355 {
356 char *file;
357 char *ns = NULL;
358 int status;
359
360 if (SLang_Num_Function_Args == 2)
361 {
362 if (-1 == SLang_pop_slstring (&ns))
363 return -1;
364 if (-1 == _pSLns_check_name (ns))
365 {
366 SLang_free_slstring (ns);
367 return -1;
368 }
369 }
370
371 if (-1 == SLang_pop_slstring (&file))
372 {
373 SLang_free_slstring (ns);
374 return -1;
375 }
376
377 status = (*f) (file, ns);
378 SLang_free_slstring (file);
379 SLang_free_slstring (ns);
380 return status;
381 }
382
load_file(void)383 static int load_file (void)
384 {
385 return (0 == load_string_or_file (SLns_load_file));
386 }
387
load_string(void)388 static void load_string (void)
389 {
390 /* FIXME: This should use the namespace of the currently executing code */
391 (void) load_string_or_file (SLns_load_string);
392 }
393
get_doc_string(char * file,char * topic)394 static int get_doc_string (char *file, char *topic)
395 {
396 FILE *fp;
397 char line[1024];
398 size_t topic_len, str_len;
399 char *str;
400 char ch;
401
402 topic_len = strlen (topic);
403 if (topic_len == 0)
404 return -1;
405
406 if (NULL == (fp = fopen (file, "r")))
407 return -1;
408
409 while (1)
410 {
411 char *pos;
412
413 if (NULL == fgets (line, sizeof(line), fp))
414 {
415 fclose (fp);
416 return -1;
417 }
418 ch = *line;
419 if ((ch == ' ') || (ch == '\t') || (ch == '\n') || (ch == '-'))
420 continue;
421
422 pos = strstr (line, topic);
423 if (pos == NULL)
424 continue;
425
426 ch = pos[topic_len];
427
428 /* Most common case */
429 if ((pos == line)
430 && ((ch == '\n') || (ch == 0) || (ch == ' ') || (ch == '\t') || (ch == ',')))
431 break;
432
433 pos = line;
434 while (NULL != (pos = strchr (pos, ',')))
435 {
436 /* Here *pos == ',' */
437 if (NULL == (pos = strstr (pos+1, topic)))
438 break;
439 ch = pos[-1];
440 if ((ch != ' ') && (ch != ',') && (ch != '\t'))
441 {
442 pos += topic_len;
443 continue;
444 }
445 ch = pos[topic_len];
446 if ((ch == '\n') || (ch == ',')
447 || (ch == ' ') || (ch == '\t') || (ch == 0))
448 break;
449 }
450 if (pos != NULL)
451 break;
452 }
453
454 if (NULL == (str = SLmake_string (line)))
455 {
456 fclose (fp);
457 return -1;
458 }
459 str_len = strlen (str);
460
461 while (NULL != fgets (line, sizeof (line), fp))
462 {
463 size_t len;
464 char *new_str;
465
466 ch = *line;
467 if (ch == '#') continue;
468 if (ch == '-') break;
469
470 len = strlen (line);
471 if (NULL == (new_str = (char *)SLrealloc (str, str_len + len + 1)))
472 {
473 SLfree (str);
474 str = NULL;
475 break;
476 }
477 str = new_str;
478 strcpy (str + str_len, line);
479 str_len += len;
480 }
481
482 fclose (fp);
483
484 (void) SLang_push_malloced_string (str);
485 return 0;
486 }
487
488 static _pSLString_List_Type *Doc_Files;
489
add_doc_file(char * file)490 static int add_doc_file (char *file)
491 {
492 if (Doc_Files == NULL)
493 {
494 Doc_Files = _pSLstring_list_new (5, 5);
495 if (Doc_Files == NULL)
496 return -1;
497 }
498
499 if ((file == NULL) || (*file == 0))
500 return 0;
501
502 return _pSLstring_list_append_copy (Doc_Files, file);
503 }
504
add_doc_file_intrin(char * file)505 static void add_doc_file_intrin (char *file)
506 {
507 (void) add_doc_file (file);
508 }
509
get_doc_files_intrin(void)510 static void get_doc_files_intrin (void)
511 {
512 if (Doc_Files == NULL)
513 Doc_Files = _pSLstring_list_new (5, 5);
514 (void) _pSLstring_list_push (Doc_Files, 0);
515 }
516
set_doc_files_intrin(void)517 static void set_doc_files_intrin (void)
518 {
519 SLang_Array_Type *at;
520 size_t i, num;
521 char **data;
522
523 if (-1 == SLang_pop_array_of_type (&at, SLANG_STRING_TYPE))
524 return;
525
526 _pSLstring_list_delete (Doc_Files);
527 Doc_Files = NULL;
528
529 num = at->num_elements;
530 data = (char **) at->data;
531 for (i = 0; i < num; i++)
532 {
533 if (-1 == add_doc_file (data[i]))
534 break;
535 }
536 SLang_free_array (at);
537 }
538
get_doc_string_intrin(char * topic)539 static void get_doc_string_intrin (char *topic)
540 {
541 char *file;
542 char **files;
543 unsigned int i, num_files;
544
545 if (SLang_Num_Function_Args == 2)
546 {
547 if (-1 == SLang_pop_slstring (&file))
548 return;
549
550 if (-1 == get_doc_string (file, topic))
551 (void) SLang_push_null ();
552
553 SLang_free_slstring (file);
554 return;
555 }
556
557 if ((Doc_Files == NULL)
558 || (NULL == (files = Doc_Files->buf)))
559 {
560 SLang_push_null ();
561 return;
562 }
563 num_files = Doc_Files->num;
564 for (i = 0; i < num_files; i++)
565 {
566 file = files[i];
567 if (file == NULL)
568 continue;
569
570 if (0 == get_doc_string (file, topic))
571 return;
572 }
573 (void) SLang_push_null ();
574 }
575
push_string_array_elements(SLang_Array_Type * at)576 static int push_string_array_elements (SLang_Array_Type *at)
577 {
578 char **strs;
579 size_t num;
580 size_t i;
581
582 if (at == NULL)
583 return -1;
584
585 strs = (char **)at->data;
586 num = at->num_elements;
587 for (i = 0; i < num; i++)
588 {
589 if (-1 == SLang_push_string (strs[i]))
590 {
591 SLdo_pop_n (i);
592 return -1;
593 }
594 }
595 SLang_push_integer ((int) num);
596 return 0;
597 }
598
intrin_apropos(void)599 static void intrin_apropos (void)
600 {
601 int num_args;
602 char *pat;
603 char *namespace_name;
604 unsigned int flags;
605 SLang_Array_Type *at;
606
607 num_args = SLang_Num_Function_Args;
608
609 if (-1 == SLang_pop_uinteger (&flags))
610 return;
611 if (-1 == SLang_pop_slstring (&pat))
612 return;
613
614 namespace_name = NULL;
615 at = NULL;
616 if (num_args == 3)
617 {
618 if (-1 == SLang_pop_slstring (&namespace_name))
619 goto free_and_return;
620 }
621
622 at = _pSLang_apropos (namespace_name, pat, flags);
623 if (num_args == 3)
624 {
625 (void) SLang_push_array (at, 0);
626 goto free_and_return;
627 }
628
629 /* Maintain compatibility with old version of the function. That version
630 * did not take three arguments and returned everything to the stack.
631 * Yuk.
632 */
633 (void) push_string_array_elements (at);
634
635 free_and_return:
636 /* NULLs ok */
637 SLang_free_slstring (namespace_name);
638 SLang_free_slstring (pat);
639 SLang_free_array (at);
640 }
641
intrin_get_defines(void)642 static int intrin_get_defines (void)
643 {
644 int n = 0;
645 SLFUTURE_CONST char **s = _pSLdefines;
646
647 while (*s != NULL)
648 {
649 if (-1 == SLang_push_string (*s))
650 {
651 SLdo_pop_n ((unsigned int) n);
652 return -1;
653 }
654 s++;
655 n++;
656 }
657 return n;
658 }
659
intrin_get_reference(char * name)660 static void intrin_get_reference (char *name)
661 {
662 if (*name == '&') name++;
663 _pSLang_push_nt_as_ref (_pSLlocate_name (name));
664 }
665
intrin_get_namespaces(void)666 static void intrin_get_namespaces (void)
667 {
668 SLang_push_array (_pSLns_list_namespaces (), 1);
669 }
670
671 #ifdef HAVE_SYS_UTSNAME_H
672 # include <sys/utsname.h>
673 #endif
674
uname_cmd(void)675 static void uname_cmd (void)
676 {
677 #ifdef HAVE_UNAME
678 struct utsname u;
679 SLFUTURE_CONST char *field_names [6];
680 SLtype field_types[6];
681 VOID_STAR field_values [6];
682 char *ptrs[6];
683 int i;
684
685 if (-1 == uname (&u))
686 (void) SLang_push_null ();
687
688 field_names[0] = "sysname"; ptrs[0] = u.sysname;
689 field_names[1] = "nodename"; ptrs[1] = u.nodename;
690 field_names[2] = "release"; ptrs[2] = u.release;
691 field_names[3] = "version"; ptrs[3] = u.version;
692 field_names[4] = "machine"; ptrs[4] = u.machine;
693
694 for (i = 0; i < 5; i++)
695 {
696 field_types[i] = SLANG_STRING_TYPE;
697 field_values[i] = (VOID_STAR) &ptrs[i];
698 }
699
700 if (0 == SLstruct_create_struct (5, field_names, field_types, field_values))
701 return;
702 #endif
703
704 SLang_push_null ();
705 }
706
uninitialize_ref_intrin(SLang_Ref_Type * ref)707 static void uninitialize_ref_intrin (SLang_Ref_Type *ref)
708 {
709 (void) _pSLang_uninitialize_ref (ref);
710 }
711
class_type_intrinsic(void)712 static int class_type_intrinsic (void)
713 {
714 SLtype type;
715
716 if (-1 == SLang_pop_datatype (&type))
717 return -1;
718 return _pSLclass_get_class (type)->cl_class_type;
719 }
720
class_id_intrinsic(void)721 static int class_id_intrinsic (void)
722 {
723 SLtype type;
724
725 if (-1 == SLang_pop_datatype (&type))
726 return -1;
727 return _pSLclass_get_class (type)->cl_data_type;
728 }
729
datatype_intrinsic(SLtype * t)730 static void datatype_intrinsic (SLtype *t)
731 {
732 SLang_Class_Type *cl;
733
734 if (0 == SLclass_is_class_defined (*t))
735 {
736 (void) SLang_push_null ();
737 return;
738 }
739
740 cl = _pSLclass_get_class (*t);
741 (void) SLang_push_datatype (cl->cl_data_type);
742 }
743
do_obj_cmp_fun(int (* fun)(SLang_Object_Type *,SLang_Object_Type *))744 static int do_obj_cmp_fun (int (*fun)(SLang_Object_Type *, SLang_Object_Type *))
745 {
746 int eqs;
747 SLang_Object_Type a, b;
748
749 if (-1 == SLang_pop (&b))
750 return -1;
751
752 if (-1 == SLang_pop (&a))
753 {
754 SLang_free_object (&b);
755 return -1;
756 }
757
758 eqs = (*fun) (&a, &b);
759
760 SLang_free_object (&a);
761 SLang_free_object (&b);
762 return eqs;
763 }
764
is_same_intrinsic(void)765 static int is_same_intrinsic (void)
766 {
767 return do_obj_cmp_fun (_pSLclass_is_same_obj);
768 }
769
eqs_intrinsic(void)770 static int eqs_intrinsic (void)
771 {
772 return do_obj_cmp_fun (_pSLclass_obj_eqs);
773 }
774
is_callable_intrinsic(void)775 static int is_callable_intrinsic (void)
776 {
777 SLang_Ref_Type *ref;
778 int ret;
779
780 if (SLang_peek_at_stack () != SLANG_REF_TYPE)
781 {
782 (void) SLdo_pop ();
783 return 0;
784 }
785
786 if (-1 == SLang_pop_ref (&ref))
787 return -1;
788
789 ret = _pSLang_ref_is_callable (ref);
790 SLang_free_ref (ref);
791
792 return ret;
793 }
794
is_numeric(SLtype type)795 static int is_numeric (SLtype type)
796 {
797 /* Version 2: Add attributes to the class tables to simplify this.
798 * Also clarify exactly what _pSLang_is_arith_type is supposed to return.
799 */
800 if (0 == _pSLang_is_arith_type ((SLtype) type))
801 {
802 if (type == SLANG_COMPLEX_TYPE)
803 return 3;
804
805 return 0;
806 }
807 if ((type == SLANG_DOUBLE_TYPE) || (type == SLANG_FLOAT_TYPE))
808 return 2;
809
810 return 1;
811 }
812
is_numeric_intrinsic(void)813 static int is_numeric_intrinsic (void)
814 {
815 int type;
816
817 if (-1 == (type = SLang_peek_at_stack1 ()))
818 return -1;
819
820 (void) SLdo_pop ();
821 return is_numeric ((SLtype) type);
822 }
823
is_datatype_numeric_intrinsic(void)824 static int is_datatype_numeric_intrinsic (void)
825 {
826 SLtype type;
827
828 if (-1 == SLang_pop_datatype (&type))
829 return -1;
830
831 return is_numeric (type);
832 }
833
lang_print_stack(void)834 static void lang_print_stack (void)
835 {
836 (void) _pSLang_dump_stack ();
837 }
838
pop_array_or_string(SLtype itype,char ** sp,SLang_Array_Type ** atsp,SLang_Array_Type ** atip)839 static int pop_array_or_string (SLtype itype, char **sp,
840 SLang_Array_Type **atsp, SLang_Array_Type **atip)
841 {
842 char *s;
843
844 if (SLang_peek_at_stack () == SLANG_ARRAY_TYPE)
845 {
846 SLang_Array_Type *ats, *ati;
847
848 *sp = NULL;
849 if (-1 == SLang_pop_array_of_type (&ats, SLANG_STRING_TYPE))
850 {
851 *atsp = NULL;
852 *atip = NULL;
853 return -1;
854 }
855 if (NULL == (ati = SLang_create_array1 (itype, 0, NULL, ats->dims, ats->num_dims, 1)))
856 {
857 *atsp = NULL;
858 *atip = NULL;
859 SLang_free_array (ats);
860 return -1;
861 }
862 *atsp = ats;
863 *atip = ati;
864 return 0;
865 }
866
867 *atsp = NULL;
868 *atip = NULL;
869 if (-1 == SLang_pop_slstring (&s))
870 {
871 *sp = NULL;
872 return -1;
873 }
874 *sp = s;
875 return 0;
876 }
877
878 #if SLANG_HAS_FLOAT
intrin_atof(void)879 static void intrin_atof (void)
880 {
881 char *s;
882 SLang_Array_Type *ats;
883 SLang_Array_Type *ati;
884 double *ip;
885 char **strp, **strpmax;
886
887 if (-1 == pop_array_or_string (SLANG_DOUBLE_TYPE, &s, &ats, &ati))
888 return;
889
890 if (s != NULL)
891 {
892 (void) SLang_push_double(_pSLang_atof(s));
893 SLang_free_slstring (s);
894 return;
895 }
896
897 strp = (char **) ats->data;
898 strpmax = strp + ats->num_elements;
899 ip = (double *) ati->data;
900
901 while (strp < strpmax)
902 {
903 if (*strp == NULL)
904 *ip++ = _pSLang_NaN;
905 else
906 *ip++ = _pSLang_atof (*strp);
907 strp++;
908 }
909 SLang_free_array (ats);
910 (void) SLang_push_array (ati, 1);
911 }
912 #endif
913
914 /* Convert string to integer */
intrin_integer(void)915 static void intrin_integer (void)
916 {
917 char *s;
918 SLang_Array_Type *ats;
919 SLang_Array_Type *ati;
920 int *ip;
921 unsigned char **strp, **strpmax;
922
923 if (-1 == pop_array_or_string (SLANG_INT_TYPE, &s, &ats, &ati))
924 return;
925
926 if (s != NULL)
927 {
928 (void) SLang_push_integer (SLatoi ((unsigned char *) s));
929 SLang_free_slstring (s);
930 return;
931 }
932
933 strp = (unsigned char **) ats->data;
934 strpmax = strp + ats->num_elements;
935 ip = (int *) ati->data;
936
937 while ((strp < strpmax) && (_pSLang_Error == 0))
938 {
939 if (*strp == NULL)
940 *ip++ = 0;
941 else
942 *ip++ = SLatoi (*strp);
943 strp++;
944 }
945 SLang_free_array (ats);
946 (void) SLang_push_array (ati, 1);
947 }
948 /*}}}*/
949
atoi_intrin(void)950 static void atoi_intrin (void)
951 {
952 char *s;
953 SLang_Array_Type *ats;
954 SLang_Array_Type *ati;
955 int *ip;
956 char **strp, **strpmax;
957
958 if (-1 == pop_array_or_string (SLANG_INT_TYPE, &s, &ats, &ati))
959 return;
960
961 if (s != NULL)
962 {
963 (void) SLang_push_integer (atoi (s));
964 SLang_free_slstring (s);
965 return;
966 }
967
968 strp = (char **) ats->data;
969 strpmax = strp + ats->num_elements;
970 ip = (int *) ati->data;
971
972 while (strp < strpmax)
973 {
974 if (*strp == NULL)
975 *ip++ = 0;
976 else
977 *ip++ = atoi (*strp);
978 strp++;
979 }
980 SLang_free_array (ats);
981 (void) SLang_push_array (ati, 1);
982 }
983
atol_intrin(void)984 static void atol_intrin (void)
985 {
986 char *s;
987 SLang_Array_Type *ats;
988 SLang_Array_Type *ati;
989 long *ip;
990 char **strp, **strpmax;
991
992 if (-1 == pop_array_or_string (_pSLANG_LONG_TYPE, &s, &ats, &ati))
993 return;
994
995 if (s != NULL)
996 {
997 (void) SLang_push_long (atol (s));
998 SLang_free_slstring (s);
999 return;
1000 }
1001
1002 strp = (char **) ats->data;
1003 strpmax = strp + ats->num_elements;
1004 ip = (long *) ati->data;
1005
1006 while (strp < strpmax)
1007 {
1008 if (*strp == NULL)
1009 *ip++ = 0;
1010 else
1011 *ip++ = atol (*strp);
1012 strp++;
1013 }
1014 SLang_free_array (ats);
1015 (void) SLang_push_array (ati, 1);
1016 }
1017
1018 #ifdef HAVE_LONG_LONG
1019 # ifdef HAVE_ATOLL
1020 # define ATOLL_FUN(s) atoll(s)
1021 # else
1022 # ifdef HAVE_STRTOLL
1023 # define ATOLL_FUN(s) strtoll((s), NULL, 10)
1024 # else
1025 # define ATOLL_FUN(s) strtol((s), NULL, 10)
1026 # endif
1027 # endif
atoll_intrin(void)1028 static void atoll_intrin (void)
1029 {
1030 char *s;
1031 SLang_Array_Type *ats;
1032 SLang_Array_Type *ati;
1033 long long *ip;
1034 char **strp, **strpmax;
1035
1036 if (-1 == pop_array_or_string (_pSLANG_LLONG_TYPE, &s, &ats, &ati))
1037 return;
1038
1039 if (s != NULL)
1040 {
1041 (void) SLang_push_long_long (ATOLL_FUN(s));
1042 SLang_free_slstring (s);
1043 return;
1044 }
1045
1046 strp = (char **) ats->data;
1047 strpmax = strp + ats->num_elements;
1048 ip = (long long *) ati->data;
1049
1050 while (strp < strpmax)
1051 {
1052 if (*strp == NULL)
1053 *ip++ = 0;
1054 else
1055 *ip++ = ATOLL_FUN (*strp);
1056 strp++;
1057 }
1058 SLang_free_array (ats);
1059 (void) SLang_push_array (ati, 1);
1060 }
1061 #endif
1062
autoload_intrinsic(char * a,char * b)1063 static void autoload_intrinsic (char *a, char *b)
1064 {
1065 SLang_autoload (a, b);
1066 }
is_defined_intrin(char * s)1067 static int is_defined_intrin (char *s)
1068 {
1069 return SLang_is_defined (s);
1070 }
1071
system_intrinsic(char * s)1072 static int system_intrinsic (char *s)
1073 {
1074 return SLsystem (s);
1075 }
1076
system_intr_intrinsic(char * s)1077 static int system_intr_intrinsic (char *s)
1078 {
1079 return SLsystem_intr (s);
1080 }
1081
stack_depth_intrin(void)1082 static int stack_depth_intrin (void)
1083 {
1084 return SLstack_depth ();
1085 }
1086
expand_dollar_string(char * s)1087 static void expand_dollar_string (char *s)
1088 {
1089 (void) _pSLpush_dollar_string (s);
1090 }
1091
1092 #if SLANG_HAS_QUALIFIERS
get_qualifiers_intrin(void)1093 static void get_qualifiers_intrin (void)
1094 {
1095 SLang_Struct_Type *q;
1096 if (0 == _pSLang_get_qualifiers_intrin (&q))
1097 (void) SLang_push_struct (q);
1098 }
1099
qualifier_exists_intrin(char * name)1100 static int qualifier_exists_intrin (char *name)
1101 {
1102 SLang_Struct_Type *q;
1103
1104 if (-1 == _pSLang_get_qualifiers_intrin (&q))
1105 return -1;
1106
1107 if ((q == NULL)
1108 || (NULL == _pSLstruct_get_field_value (q, name)))
1109 return 0;
1110
1111 return 1;
1112 }
1113
qualifier_intrin(void)1114 static void qualifier_intrin (void)
1115 {
1116 int has_default;
1117 char *name;
1118 SLang_Struct_Type *q;
1119 SLang_Object_Type *objp;
1120
1121 if (-1 == _pSLang_get_qualifiers_intrin (&q))
1122 return;
1123
1124 has_default = (SLang_Num_Function_Args == 2);
1125 if (has_default)
1126 {
1127 if (-1 == SLroll_stack (2))
1128 return;
1129 }
1130
1131 if (-1 == SLang_pop_slstring (&name))
1132 return;
1133
1134 if (q != NULL)
1135 objp = _pSLstruct_get_field_value (q, name);
1136 else
1137 objp = NULL;
1138
1139 SLang_free_slstring (name);
1140
1141 if (objp != NULL)
1142 {
1143 if (has_default)
1144 SLdo_pop ();
1145 _pSLpush_slang_obj (objp);
1146 }
1147 else if (has_default == 0)
1148 (void) SLang_push_null ();
1149
1150 /* Note: objp and q should _not_ be freed since they were not allocated */
1151 }
1152 #endif
1153
clear_error_intrin(void)1154 static void clear_error_intrin (void)
1155 {
1156 (void) _pSLerr_clear_error (1);
1157 }
1158
1159 #ifdef HAVE_ENVIRON
1160
1161 /* In a shared library, macos requires a call to _NSGetEnviron to get the environ. */
1162 # if !defined(__APPLE__)
1163 extern char **environ; /* POSIX and ??? */
1164 # endif
1165
get_sys_environ(void)1166 static char **get_sys_environ (void)
1167 {
1168 # if defined(__APPLE__)
1169 char ***e = _NSGetEnviron ();
1170 if (e == NULL) return NULL;
1171 return *e;
1172 # else
1173 return environ;
1174 # endif
1175 }
1176
get_environment(void)1177 static void get_environment (void)
1178 {
1179 unsigned int num;
1180 char **env, **e;
1181
1182 if (NULL == (env = get_sys_environ ()))
1183 {
1184 (void) SLang_push_null ();
1185 return;
1186 }
1187
1188 e = env;
1189 num = 0;
1190 while (*e != NULL)
1191 {
1192 num++;
1193 e++;
1194 }
1195
1196 (void) SLang_push_array (_pSLstrings_to_array (env, num), 1); /* NULL ok */
1197 }
1198 #endif /* HAVE_ENVIRON */
1199
1200 static void set_argv_intrinsic (void);
1201 static SLang_Intrin_Fun_Type SLang_Basic_Table [] = /*{{{*/
1202 {
1203 MAKE_INTRINSIC_0("__is_callable", is_callable_intrinsic, SLANG_INT_TYPE),
1204 MAKE_INTRINSIC_0("__is_numeric", is_numeric_intrinsic, SLANG_INT_TYPE),
1205 MAKE_INTRINSIC_0("__is_datatype_numeric", is_datatype_numeric_intrinsic, SLANG_INT_TYPE),
1206 MAKE_INTRINSIC_1("__is_initialized", _pSLang_is_ref_initialized, SLANG_INT_TYPE, SLANG_REF_TYPE),
1207 MAKE_INTRINSIC_S("__get_reference", intrin_get_reference, SLANG_VOID_TYPE),
1208 MAKE_INTRINSIC_1("__uninitialize", uninitialize_ref_intrin, SLANG_VOID_TYPE, SLANG_REF_TYPE),
1209 MAKE_INTRINSIC_0("__is_same", is_same_intrinsic, SLANG_INT_TYPE),
1210 MAKE_INTRINSIC_0("__class_type", class_type_intrinsic, SLANG_INT_TYPE),
1211 MAKE_INTRINSIC_0("__class_id", class_id_intrinsic, SLANG_INT_TYPE),
1212 MAKE_INTRINSIC_1("__datatype", datatype_intrinsic, SLANG_VOID_TYPE, SLANG_SLTYPE_INT_TYPE),
1213 MAKE_INTRINSIC_0("_eqs", eqs_intrinsic, SLANG_INT_TYPE),
1214 MAKE_INTRINSIC_S("get_doc_string_from_file", get_doc_string_intrin, SLANG_VOID_TYPE),
1215 MAKE_INTRINSIC_S("add_doc_file", add_doc_file_intrin, SLANG_VOID_TYPE),
1216 MAKE_INTRINSIC_0("get_doc_files", get_doc_files_intrin, SLANG_VOID_TYPE),
1217 MAKE_INTRINSIC_0("set_doc_files", set_doc_files_intrin, SLANG_VOID_TYPE),
1218 MAKE_INTRINSIC_SS("autoload", autoload_intrinsic, SLANG_VOID_TYPE),
1219 MAKE_INTRINSIC_S("is_defined", is_defined_intrin, SLANG_INT_TYPE),
1220 MAKE_INTRINSIC_0("string", _pSLstring_intrinsic, SLANG_VOID_TYPE),
1221 MAKE_INTRINSIC_0("uname", uname_cmd, SLANG_VOID_TYPE),
1222 MAKE_INTRINSIC_S("getenv", intrin_getenv_cmd, SLANG_VOID_TYPE),
1223 #ifdef HAVE_PUTENV
1224 MAKE_INTRINSIC_0("putenv", intrin_putenv, SLANG_VOID_TYPE),
1225 #endif
1226 #ifdef HAVE_ENVIRON
1227 MAKE_INTRINSIC_0("get_environ", get_environment, SLANG_VOID_TYPE),
1228 #endif
1229 MAKE_INTRINSIC_0("evalfile", load_file, SLANG_INT_TYPE),
1230 MAKE_INTRINSIC_I("char", char_cmd, SLANG_VOID_TYPE),
1231 MAKE_INTRINSIC_0("eval", load_string, SLANG_VOID_TYPE),
1232 MAKE_INTRINSIC_0("dup", do_dup, SLANG_VOID_TYPE),
1233 MAKE_INTRINSIC_0("integer", intrin_integer, SLANG_VOID_TYPE),
1234 MAKE_INTRINSIC_S("system", system_intrinsic, SLANG_INT_TYPE),
1235 MAKE_INTRINSIC_S("system_intr", system_intr_intrinsic, SLANG_INT_TYPE),
1236 MAKE_INTRINSIC_0("_apropos", intrin_apropos, SLANG_VOID_TYPE),
1237 MAKE_INTRINSIC_0("_get_namespaces", intrin_get_namespaces, SLANG_VOID_TYPE),
1238 MAKE_INTRINSIC_S("_trace_function", _pSLang_trace_fun, SLANG_VOID_TYPE),
1239 #if SLANG_HAS_FLOAT
1240 MAKE_INTRINSIC_0("atof", intrin_atof, SLANG_VOID_TYPE),
1241 MAKE_INTRINSIC_0("double", intrin_double, SLANG_VOID_TYPE),
1242 #endif
1243 MAKE_INTRINSIC_0("atoi", atoi_intrin, SLANG_VOID_TYPE),
1244 MAKE_INTRINSIC_0("atol", atol_intrin, SLANG_VOID_TYPE),
1245 #ifdef HAVE_LONG_LONG
1246 MAKE_INTRINSIC_0("atoll", atoll_intrin, SLANG_VOID_TYPE),
1247 #endif
1248 MAKE_INTRINSIC_0("int", intrin_int, SLANG_VOID_TYPE),
1249 MAKE_INTRINSIC_0("typecast", intrin_typecast, SLANG_VOID_TYPE),
1250 MAKE_INTRINSIC_0("_stkdepth", stack_depth_intrin, SLANG_INT_TYPE),
1251 MAKE_INTRINSIC_I("_stk_reverse", intrin_reverse_stack, SLANG_VOID_TYPE),
1252 MAKE_INTRINSIC_0("typeof", intrin_type_info, VOID_TYPE),
1253 MAKE_INTRINSIC_0("_typeof", intrin_type_info1, VOID_TYPE),
1254 MAKE_INTRINSIC_I("_pop_n", intrin_pop_n, SLANG_VOID_TYPE),
1255 MAKE_INTRINSIC_0("_print_stack", lang_print_stack, SLANG_VOID_TYPE),
1256 MAKE_INTRINSIC_I("_stk_roll", intrin_roll_stack, SLANG_VOID_TYPE),
1257 MAKE_INTRINSIC_SI("byte_compile_file", byte_compile_file, SLANG_VOID_TYPE),
1258 MAKE_INTRINSIC_0("_clear_error", clear_error_intrin, SLANG_VOID_TYPE),
1259 MAKE_INTRINSIC_0("_function_name", intrin_function_name, SLANG_STRING_TYPE),
1260 #if SLANG_HAS_FLOAT
1261 MAKE_INTRINSIC_S("set_float_format", _pSLset_double_format, SLANG_VOID_TYPE),
1262 MAKE_INTRINSIC_0("get_float_format", _pSLget_double_format, SLANG_STRING_TYPE),
1263 #endif
1264 MAKE_INTRINSIC_S("_slang_guess_type", guess_type, SLANG_VOID_TYPE),
1265 MAKE_INTRINSIC_S("error", intrin_error, SLANG_VOID_TYPE),
1266 MAKE_INTRINSIC_S("message", intrin_message, SLANG_VOID_TYPE),
1267 MAKE_INTRINSIC_0("__get_defined_symbols", intrin_get_defines, SLANG_INT_TYPE),
1268 MAKE_INTRINSIC_I("__pop_args", _pSLstruct_pop_args, SLANG_VOID_TYPE),
1269 MAKE_INTRINSIC_1("__push_args", _pSLstruct_push_args, SLANG_VOID_TYPE, SLANG_ARRAY_TYPE),
1270 MAKE_INTRINSIC_0("usage", usage, SLANG_VOID_TYPE),
1271 MAKE_INTRINSIC_S("implements", _pSLang_implements_intrinsic, SLANG_VOID_TYPE),
1272 MAKE_INTRINSIC_S("use_namespace", _pSLang_use_namespace_intrinsic, SLANG_VOID_TYPE),
1273 MAKE_INTRINSIC_0("current_namespace", _pSLang_cur_namespace_intrinsic, SLANG_STRING_TYPE),
1274 MAKE_INTRINSIC_0("length", length_cmd, SLANG_VOID_TYPE),
1275 MAKE_INTRINSIC_0("__set_argc_argv", set_argv_intrinsic, SLANG_VOID_TYPE),
1276 MAKE_INTRINSIC_S("_$", expand_dollar_string, SLANG_VOID_TYPE),
1277 #if SLANG_HAS_QUALIFIERS
1278 MAKE_INTRINSIC_0("__qualifiers", get_qualifiers_intrin, SLANG_VOID_TYPE),
1279 MAKE_INTRINSIC_0("qualifier", qualifier_intrin, SLANG_VOID_TYPE),
1280 MAKE_INTRINSIC_S("qualifier_exists", qualifier_exists_intrin, SLANG_INT_TYPE),
1281 #endif
1282 SLANG_END_INTRIN_FUN_TABLE
1283 };
1284
1285 /*}}}*/
1286
1287 #ifdef SLANG_DOC_DIR
1288 SLFUTURE_CONST char *SLang_Doc_Dir = SLANG_DOC_DIR;
1289 #else
1290 SLFUTURE_CONST char *SLang_Doc_Dir = "";
1291 #endif
1292
1293 #ifdef SLANG_INSTALL_PREFIX
1294 static SLCONST char *Install_Prefix = SLANG_INSTALL_PREFIX;
1295 #else
1296 static char *Install_Prefix = "";
1297 #endif
1298
1299 static int obsolete_int_variable;
1300 static SLang_Intrin_Var_Type Intrin_Vars[] =
1301 {
1302 MAKE_VARIABLE("_debug_info", &obsolete_int_variable, SLANG_INT_TYPE, 0),
1303 #if SLANG_HAS_BOSEOS
1304 MAKE_VARIABLE("_boseos_info", &_pSLang_Compile_BOSEOS, SLANG_INT_TYPE, 0),
1305 MAKE_VARIABLE("_bofeof_info", &_pSLang_Compile_BOFEOF, SLANG_INT_TYPE, 0),
1306 #endif
1307 MAKE_VARIABLE("_auto_declare", &_pSLang_Auto_Declare_Globals, SLANG_INT_TYPE, 0),
1308 MAKE_VARIABLE("_slangtrace", &_pSLang_Trace, SLANG_INT_TYPE, 0),
1309 MAKE_VARIABLE("_slang_utf8_ok", &_pSLinterp_UTF8_Mode, SLANG_INT_TYPE, 1),
1310 MAKE_VARIABLE("_slang_install_prefix", &Install_Prefix, SLANG_STRING_TYPE, 1),
1311 MAKE_VARIABLE("NULL", NULL, SLANG_NULL_TYPE, 1),
1312 SLANG_END_INTRIN_VAR_TABLE
1313 };
1314
SLang_init_slang(void)1315 int SLang_init_slang (void) /*{{{*/
1316 {
1317 char name[3];
1318 unsigned int i;
1319 SLFUTURE_CONST char **s;
1320 static SLFUTURE_CONST char *sys_defines [] =
1321 {
1322 #if defined(__os2__)
1323 "OS2",
1324 #endif
1325 #if defined(__MSDOS__)
1326 "MSDOS",
1327 #endif
1328 #if defined(__WIN16__)
1329 "WIN16",
1330 #endif
1331 #if defined (__WIN32__)
1332 "WIN32",
1333 #endif
1334 #if defined(__NT__)
1335 "NT",
1336 #endif
1337 #if defined (VMS)
1338 "VMS",
1339 #endif
1340 #ifdef REAL_UNIX_SYSTEM
1341 "UNIX",
1342 #endif
1343 #if SLANG_HAS_FLOAT
1344 "SLANG_DOUBLE_TYPE",
1345 #endif
1346 NULL
1347 };
1348
1349 if (-1 == _pSLerr_init ())
1350 return -1;
1351
1352 if (-1 == _pSLregister_types ()) return -1;
1353
1354 if ((-1 == SLadd_intrin_fun_table(SLang_Basic_Table, NULL))
1355 || (-1 == SLadd_intrin_var_table (Intrin_Vars, NULL))
1356 || (-1 == _pSLang_init_slstrops ())
1357 || (-1 == _pSLang_init_sltime ())
1358 || (-1 == _pSLang_init_sllist ())
1359 || (-1 == _pSLstruct_init ())
1360 #if SLANG_HAS_ASSOC_ARRAYS
1361 || (-1 == SLang_init_slassoc ())
1362 #endif
1363 #if SLANG_HAS_BOSEOS
1364 || (-1 == _pSLang_init_boseos ())
1365 #endif
1366 || (-1 == _pSLang_init_exceptions ())
1367 )
1368 return -1;
1369
1370 /* More nonsense for the windoze loader */
1371 if ((-1 == SLadd_intrinsic_variable ("_NARGS", &SLang_Num_Function_Args, SLANG_INT_TYPE, 1))
1372 || (-1 == SLadd_intrinsic_variable ("_traceback", &SLang_Traceback, SLANG_INT_TYPE, 0))
1373 || (-1 == SLadd_intrinsic_variable ("_slang_version", &SLang_Version, SLANG_INT_TYPE, 1))
1374 || (-1 == SLadd_intrinsic_variable ("_slang_version_string", &SLang_Version_String, SLANG_STRING_TYPE, 1))
1375 || (-1 == SLadd_intrinsic_variable ("_slang_doc_dir", &SLang_Doc_Dir, SLANG_STRING_TYPE, 1)))
1376 return -1;
1377
1378 SLadd_global_variable (SLANG_SYSTEM_NAME);
1379
1380 s = sys_defines;
1381 while (*s != NULL)
1382 {
1383 if (-1 == SLdefine_for_ifdef (*s)) return -1;
1384 s++;
1385 }
1386
1387 /* give temp global variables $0 --> $9 */
1388 name[2] = 0; name[0] = '$';
1389 for (i = 0; i < 10; i++)
1390 {
1391 name[1] = (char) (i + '0');
1392 SLadd_global_variable (name);
1393 }
1394
1395 SLang_init_case_tables ();
1396
1397 /* Now add a couple of macros */
1398 SLang_load_string (".(_NARGS 1 - Sprintf error)verror");
1399 SLang_load_string (".(_NARGS 1 - Sprintf message)vmessage");
1400
1401 #if SLANG_HAS_SIGNALS
1402 if (-1 == SLang_add_interrupt_hook (_pSLang_check_signals_hook, NULL))
1403 return -1;
1404 #endif
1405
1406 if ((SLang_Doc_Dir != NULL)
1407 && (*SLang_Doc_Dir != 0))
1408 {
1409 char *docfile = SLpath_dircat (SLang_Doc_Dir, "slangfun.txt");
1410 /* NULL ok */
1411 (void) add_doc_file (docfile);
1412 SLfree (docfile);
1413 }
1414
1415 if (_pSLang_Error)
1416 return -1;
1417
1418 return 0;
1419 }
1420
1421 /*}}}*/
1422
1423 static int This_Argc;
1424 static SLang_Array_Type *This_Argv = NULL;
1425
add_argc_argv(SLang_Array_Type * at)1426 static int add_argc_argv (SLang_Array_Type *at)
1427 {
1428 This_Argc = at->num_elements;
1429 if (-1 == SLadd_intrinsic_variable ("__argc", (VOID_STAR)&This_Argc,
1430 SLANG_INT_TYPE, 1))
1431 return -1;
1432
1433 if (-1 == SLadd_intrinsic_variable ("__argv", (VOID_STAR)at, SLANG_ARRAY_TYPE, 0))
1434 return -1;
1435 if (This_Argv != NULL)
1436 SLang_free_array (This_Argv);
1437 This_Argv = at;
1438 return 0;
1439 }
1440
set_argv_intrinsic(void)1441 static void set_argv_intrinsic (void)
1442 {
1443 SLang_Array_Type *at;
1444
1445 if (-1 == SLang_pop_array_of_type (&at, SLANG_STRING_TYPE))
1446 return;
1447
1448 if (-1 == add_argc_argv (at))
1449 SLang_free_array (at);
1450 }
1451
SLang_set_argc_argv(int argc,char ** argv)1452 int SLang_set_argc_argv (int argc, char **argv)
1453 {
1454 SLang_Array_Type *at = _pSLstrings_to_array (argv, argc);
1455
1456 if (at == NULL)
1457 return -1;
1458
1459 if (-1 == add_argc_argv (at))
1460 {
1461 SLang_free_array (at);
1462 return -1;
1463 }
1464
1465 return 0;
1466 }
1467
1468 #if 0
1469 int SLang_set_argc_argv (int argc, char **argv)
1470 {
1471 static int this_argc;
1472 static char **this_argv;
1473 int i;
1474
1475 if (argc < 0) argc = 0;
1476 this_argc = argc;
1477
1478 if (NULL == (this_argv = (char **) _SLcalloc ((argc + 1), sizeof (char *))))
1479 return -1;
1480 memset ((char *) this_argv, 0, sizeof (char *) * (argc + 1));
1481
1482 for (i = 0; i < argc; i++)
1483 {
1484 if (NULL == (this_argv[i] = SLang_create_slstring (argv[i])))
1485 goto return_error;
1486 }
1487
1488 if (-1 == SLadd_intrinsic_variable ("__argc", (VOID_STAR)&this_argc,
1489 SLANG_INT_TYPE, 1))
1490 goto return_error;
1491
1492 if (-1 == SLang_add_intrinsic_array ("__argv", SLANG_STRING_TYPE, 1,
1493 (VOID_STAR) this_argv, 1, argc))
1494 goto return_error;
1495
1496 return 0;
1497
1498 return_error:
1499 for (i = 0; i < argc; i++)
1500 SLang_free_slstring (this_argv[i]); /* NULL ok */
1501 SLfree ((char *) this_argv);
1502
1503 return -1;
1504 }
1505 #endif
1506