~ chicken-core (chicken-5) 9a1d9456d3f4ae2348767ef481f31d83b0615dea
commit 9a1d9456d3f4ae2348767ef481f31d83b0615dea
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Dec 8 05:08:36 2010 -0500
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Wed Dec 8 05:08:36 2010 -0500
improved command-line list creation code
diff --git a/chicken.h b/chicken.h
index c228f028..85b67b3a 100644
--- a/chicken.h
+++ b/chicken.h
@@ -1683,7 +1683,8 @@ C_fctexport void C_ccall C_exact_to_inexact(C_word c, C_word closure, C_word k,
C_fctexport void C_ccall C_quotient(C_word c, C_word closure, C_word k, C_word n1, C_word n2) C_noret;
C_fctexport void C_ccall C_string_to_number(C_word c, C_word closure, C_word k, C_word str, ...) C_noret; /*XXX left for binary compatibility */
C_fctexport void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num, ...) C_noret;
-C_fctexport void C_ccall C_get_argv(C_word c, C_word closure, C_word k) C_noret;
+C_fctexport void C_ccall C_get_argv(C_word c, C_word closure, C_word k) C_noret; /* OBSOLETE */
+C_fctexport void C_ccall C_get_argument(C_word c, C_word closure, C_word k, C_word index) C_noret;
C_fctexport void C_ccall C_make_structure(C_word c, C_word closure, C_word k, C_word type, ...) C_noret;
C_fctexport void C_ccall C_make_symbol(C_word c, C_word closure, C_word k, C_word name) C_noret;
C_fctexport void C_ccall C_make_pointer(C_word c, C_word closure, C_word k) C_noret;
diff --git a/library.scm b/library.scm
index 30fbce6b..17198442 100644
--- a/library.scm
+++ b/library.scm
@@ -185,7 +185,6 @@ EOF
(define (##sys#setslot x i y) (##core#inline "C_i_setslot" x i y))
(define (##sys#setislot x i y) (##core#inline "C_i_set_i_slot" x i y))
(define ##sys#allocate-vector (##core#primitive "C_allocate_vector"))
-(define argv (##core#primitive "C_get_argv"))
(define (argc+argv) (##sys#values main_argc main_argv))
(define ##sys#make-structure (##core#primitive "C_make_structure"))
(define ##sys#ensure-heap-reserve (##core#primitive "C_ensure_heap_reserve"))
@@ -1099,6 +1098,7 @@ EOF
((not (##core#inline "C_sametypep" x y)) #f)
((##core#inline "C_specialp" x)
(and (##core#inline "C_specialp" y)
+ (not (##core#inline "C_closurep" x))
(compare-slots x y 1)))
((##core#inline "C_byteblockp" x)
(and (##core#inline "C_byteblockp" y)
@@ -4336,12 +4336,25 @@ EOF
[else (##sys#read-error port "unreadable object")] ) ] ) ) ) )
-;;; Script invocation:
+;;; command-line handling
+
+(define ##sys#get-argument (##core#primitive "C_get_argument"))
+
+(define argv ; includes program name
+ (let ((cache #f))
+ (lambda ()
+ (or cache
+ (let ((v (let loop ((i 0))
+ (let ((arg (##sys#get-argument i)))
+ (if arg
+ (cons arg (loop (fx+ i 1)))
+ '())))))
+ (set! cache v)
+ v)))))
(define program-name
(make-parameter
- (let* ((av (argv)))
- (if (pair? av) (car av) "<unknown>") )
+ (or (##sys#get-argument 0) "<unknown>") ; may happen if embedded in C application
(lambda (x)
(##sys#check-string x 'program-name)
x) ) )
diff --git a/runtime.c b/runtime.c
index 08ca44f8..61efe5eb 100644
--- a/runtime.c
+++ b/runtime.c
@@ -173,10 +173,13 @@ extern void _C_do_apply_hack(void *proc, C_word *args, int count) C_noret;
#endif
#define WORDS_PER_FLONUM C_SIZEOF_FLONUM
-#define MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS 32
#define INITIAL_TIMER_INTERRUPT_PERIOD 10000
#define HDUMP_TABLE_SIZE 1001
+/* only for relevant for Windows: */
+
+#define MAXIMAL_NUMBER_OF_COMMAND_LINE_ARGUMENTS 256
+
/* Constants: */
@@ -489,7 +492,8 @@ static C_ccall void call_cc_wrapper(C_word c, C_word closure, C_word k, C_word r
static C_ccall void call_cc_values_wrapper(C_word c, C_word closure, C_word k, ...) C_noret;
static void gc_2(void *dummy) C_noret;
static void allocate_vector_2(void *dummy) C_noret;
-static void get_argv_2(void *dummy) C_noret;
+static void get_argv_2(void *dummy) C_noret; /* OBSOLETE */
+static void get_argument_2(void *dummy) C_noret;
static void make_structure_2(void *dummy) C_noret;
static void generic_trampoline(void *dummy) C_noret;
static void file_info_2(void *dummy) C_noret;
@@ -724,7 +728,7 @@ int CHICKEN_initialize(int heap, int stack, int symbols, void *toplevel)
static C_PTABLE_ENTRY *create_initial_ptable()
{
/* hardcoded table size - this must match the number of C_pte calls! */
- C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 64);
+ C_PTABLE_ENTRY *pt = (C_PTABLE_ENTRY *)C_malloc(sizeof(C_PTABLE_ENTRY) * 65);
int i = 0;
if(pt == NULL)
@@ -737,7 +741,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(call_cc_wrapper);
C_pte(C_gc);
C_pte(C_allocate_vector);
- C_pte(C_get_argv);
+ C_pte(C_get_argv); /* OBSOLETE */
C_pte(C_make_structure);
C_pte(C_ensure_heap_reserve);
C_pte(C_return_to_host);
@@ -763,7 +767,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_quotient);
C_pte(C_flonum_fraction);
C_pte(C_expt);
- C_pte(C_exact_to_inexact); /*XXX left for binary compatbility */
+ C_pte(C_exact_to_inexact); /* OBSOLETE */
C_pte(C_string_to_number);
C_pte(C_number_to_string);
C_pte(C_make_symbol);
@@ -792,6 +796,7 @@ static C_PTABLE_ENTRY *create_initial_ptable()
C_pte(C_copy_closure);
C_pte(C_dump_heap_state);
C_pte(C_filter_heap_objects);
+ C_pte(C_get_argument);
/* did you remember the hardcoded pte table size? */
pt[ i ].id = NULL;
@@ -7532,6 +7537,7 @@ void C_ccall C_number_to_string(C_word c, C_word closure, C_word k, C_word num,
}
+/* OBSOLETE */
void C_ccall C_get_argv(C_word c, C_word closure, C_word k)
{
int i, cells;
@@ -7553,6 +7559,7 @@ void C_ccall C_get_argv(C_word c, C_word closure, C_word k)
}
+/* OBSOLETE */
void get_argv_2(void *dummy)
{
int cells = C_unfix(C_restore),
@@ -7568,6 +7575,39 @@ void get_argv_2(void *dummy)
}
+void C_ccall C_get_argument(C_word c, C_word closure, C_word k, C_word index)
+{
+ int i = C_unfix(index);
+ int cells;
+
+ if(i >= C_main_argc)
+ C_kontinue(k, C_SCHEME_FALSE);
+
+ cells = C_SIZEOF_STRING(C_strlen(C_main_argv[ i ]));
+ C_save(k);
+ C_save(C_fix(cells));
+ C_save(index);
+
+ if(!C_demand(cells)) C_reclaim(get_argument_2, NULL);
+
+ get_argument_2(NULL);
+}
+
+
+void get_argument_2(void *dummy)
+{
+ int i = C_unfix(C_restore);
+ int cells = C_unfix(C_restore);
+ C_word
+ k = C_restore,
+ *a = C_alloc(cells),
+ str;
+
+ str = C_string2(&a, C_main_argv[ i ]);
+ C_kontinue(k, str);
+}
+
+
void C_ccall C_make_structure(C_word c, C_word closure, C_word k, C_word type, ...)
{
va_list v;
Trap