diff --git a/tools/capone/lib/capone.init b/tools/capone/lib/capone.init index cfbac61..cb24b2f 100644 --- a/tools/capone/lib/capone.init +++ b/tools/capone/lib/capone.init @@ -197,15 +197,27 @@ (cdrs (cdr unz))) (cons (apply proc cars) (apply map (cons proc cdrs))))))) -(define (for-each proc . lists) - (if (null? lists) - (apply proc) - (if (null? (car lists)) - #t - (let* ((unz (apply unzip1-with-cdr lists)) - (cars (car unz)) - (cdrs (cdr unz))) - (apply proc cars) (apply map (cons proc cdrs)))))) +;; +;; Original implementation that pretty sucks +;; Althought it behaves as given in Dybvig's book, PLT and chicken +;; versions does not allow multiple list arguments +;; +;(define (for-each proc . lists) +; (if (null? lists) +; (apply proc) +; (if (null? (car lists)) +; #t +; (let* ((unz (apply unzip1-with-cdr lists)) +; (cars (car unz)) +; (cdrs (cdr unz))) +; (apply proc cars) (apply map (cons proc cdrs)))))) + +(define (for-each proc lst) + (if (null? lst) + lst + (begin + (proc (car lst)) + (for-each proc (cdr lst))))) (define (list-tail x k) (if (zero? k) diff --git a/tools/capone/lib/common.ss b/tools/capone/lib/common.ss index 0a058e4..40c2ec1 100644 --- a/tools/capone/lib/common.ss +++ b/tools/capone/lib/common.ss @@ -105,3 +105,15 @@ (set! v2 (clock)) ;; 1000000 is value of CLOCKS_PER_SEC (/ (- v2 v1) 1000000))) + +(define *timeit-start-value* 0) +(define *timeit-end-value* 0) + +(define (timeit-start) + (set! *timeit-start-value* (clock))) + +(define (timeit-end) + (set! *timeit-end-value* (clock))) + +(define (timeit-result) + (/ (- *timeit-end-value* *timeit-start-value*) 1000000)) diff --git a/tools/capone/src/Jamfile b/tools/capone/src/Jamfile index d33b23a..5e1914e 100644 --- a/tools/capone/src/Jamfile +++ b/tools/capone/src/Jamfile @@ -11,6 +11,7 @@ SubDir TOP tools capone src ; PCRE_SRC = pcre/pcre.c ; +ObjectCcFlags $(PCRE_SRC) : $(GLOBALFLAGS) ; Library $(SUBDIR)/pcre/libpcre : $(PCRE_SRC) ; SCHEME_SRC = scheme.c dynload.c ; diff --git a/tools/capone/src/bbb.ss b/tools/capone/src/bbb.ss index 617edbe..34ab68f 100644 --- a/tools/capone/src/bbb.ss +++ b/tools/capone/src/bbb.ss @@ -21,26 +21,36 @@ (map-more (cdr lst) (map3 cdr more))))))) -(define v1 0) -(define v2 0) +(define lst (iota 9000)) -(set! v1 (clock)) -(define l (iota 1009)) -;(define l (iota 10)) -(set! v2 (clock)) -(println "=== Pass 1: " (/ (- v2 v1) 1000000)) +(print "Working my map... ") +;; my map +(timeit-start) +(map3 + (fn (x) + (+ 1 x)) lst) +(timeit-end) +(println (timeit-result) " ms") -(println "Doing map...") +(print "Working with builtin map... ") +;; real map +(timeit-start) +(map + (fn (x) + (+ 1 x)) lst) +(timeit-end) +(println (timeit-result) " ms") -(set! v1 (clock)) -(println (map3 (lambda (x) (+ 1 x)) l)) -(set! v2 (clock)) -(println "=== Pass 2: " (/ (- v2 v1) 1000000)) -;(println (map + l l)) - -(println "Time is: " (timeit - (lambda () - (define v1 (iota 100)) - (map + v1 v1) - ))) +(print "Working my map [2]... ") +;; my map +(timeit-start) +(map3 + lst lst lst) +(timeit-end) +(println (timeit-result) " ms") +(print "Working with builtin map [2]... ") +;; real map +(timeit-start) +(map + lst lst lst) +(timeit-end) +(println (timeit-result) " ms") diff --git a/tools/capone/src/capone.cpp b/tools/capone/src/capone.cpp index f60824f..0c11ffd 100644 --- a/tools/capone/src/capone.cpp +++ b/tools/capone/src/capone.cpp @@ -4,6 +4,7 @@ extern "C" { #include "scheme.h" #include "scheme-private.h" +#include "dynload.h" } #include "dbus.h" @@ -56,6 +57,10 @@ void do_file_or_expr(FILE* f, const char* expr, const char* dir) { if(sc.retcode != 0) puts("Errors in " BASE_FILE); + + /* define 'load-extension' function first */ + scheme_define(&sc, sc.global_env, mk_symbol(&sc,"load-extension"), mk_foreign_func(&sc, scm_load_ext)); + register_dbus_functions(&sc); register_re_functions(&sc); register_sys_functions(&sc); diff --git a/tools/capone/src/dynload.c b/tools/capone/src/dynload.c index 81adea0..50e0560 100644 --- a/tools/capone/src/dynload.c +++ b/tools/capone/src/dynload.c @@ -137,9 +137,3 @@ static void make_init_fn(const char *name, char *init_fn) { strcpy(init_fn,"init_"); strcat(init_fn,p); } - - - - - - diff --git a/tools/capone/src/scheme-private.h b/tools/capone/src/scheme-private.h index ae7b508..aab1a44 100644 --- a/tools/capone/src/scheme-private.h +++ b/tools/capone/src/scheme-private.h @@ -58,8 +58,9 @@ func_dealloc free; int retcode; int tracing; -#define CELL_SEGSIZE 5000 /* # of cells in one segment */ -#define CELL_NSEGMENT 10 /* # of segments for cells */ +#define CELL_SEGSIZE 8000 /* # of cells in one segment, original was 5000 */ +#define CELL_NSEGMENT 100 /* # of segments for cells, original was 10 */ + char *alloc_seg[CELL_NSEGMENT]; pointer cell_seg[CELL_NSEGMENT]; int last_cell_seg; diff --git a/tools/capone/src/scheme.c b/tools/capone/src/scheme.c index 70885d7..9b790da 100644 --- a/tools/capone/src/scheme.c +++ b/tools/capone/src/scheme.c @@ -17,9 +17,9 @@ #ifndef WIN32 # include #endif -#if USE_DL +/*#if USE_DL # include "dynload.h" -#endif +#endif*/ #if USE_MATH # include #endif @@ -100,6 +100,10 @@ static const char *strlwr(char *s) { # define InitFile "init.scm" #endif +#ifndef ErrorHeader +# define ErrorHeader "*** Error: " +#endif + #ifndef FIRST_CELLSEGS # define FIRST_CELLSEGS 3 #endif @@ -3403,7 +3407,7 @@ static pointer opexe_4(scheme *sc, enum scheme_opcodes op) { sc->args=cons(sc,mk_string(sc," -- "),sc->args); setimmutable(car(sc->args)); } - putstr(sc, "Error: "); + putstr(sc, ErrorHeader); putstr(sc, strvalue(car(sc->args))); sc->args = cdr(sc->args); s_goto(sc,OP_ERR1); @@ -4198,7 +4202,9 @@ static struct scheme_interface vtbl ={ setimmutable, scheme_load_file, - scheme_load_string + scheme_load_string, + + scheme_error }; #endif @@ -4423,6 +4429,12 @@ void scheme_define(scheme *sc, pointer envir, pointer symbol, pointer value) { } } +void scheme_error(scheme *sc, const char *str) { + putstr(sc, ErrorHeader); + putstr(sc, str); + putstr(sc, "\n"); +} + #if !STANDALONE void scheme_apply0(scheme *sc, const char *procname) { pointer carx=mk_symbol(sc,procname); diff --git a/tools/capone/src/scheme.h b/tools/capone/src/scheme.h index ed4df93..5bab588 100644 --- a/tools/capone/src/scheme.h +++ b/tools/capone/src/scheme.h @@ -136,6 +136,7 @@ void scheme_apply0(scheme *sc, const char *procname); SCHEME_EXPORT pointer scheme_apply1(scheme *sc, const char *procname, pointer); void scheme_set_external_data(scheme *sc, void *p); SCHEME_EXPORT void scheme_define(scheme *sc, pointer env, pointer symbol, pointer value); +SCHEME_EXPORT void scheme_error(scheme *sc, const char *str); typedef pointer (*foreign_func)(scheme *, pointer); @@ -211,6 +212,8 @@ struct scheme_interface { void (*setimmutable)(pointer p); void (*load_file)(scheme *sc, FILE *fin); void (*load_string)(scheme *sc, const char *input); + + void (*error)(scheme *sc, const char *str); }; #endif diff --git a/tools/capone/src/xxx.ss b/tools/capone/src/xxx.ss index f18ff39..d17b09a 100644 --- a/tools/capone/src/xxx.ss +++ b/tools/capone/src/xxx.ss @@ -26,21 +26,21 @@ (print i "\n") ) -(print (first (re-match "-" "some-sample-string" 0)) "\n") - -(define pos (re-match "http://(.*):" "http://www.google.com:8080")) -(print pos "\n") -(set! i (first pos)) - -(while [< i (first (rest pos))] - (print (string-ref "http://www.google.com:8080" i) "\n") - (set! i (+ i 1)) -) +;(print (first (re-match "-" "some-sample-string" 0)) "\n") ; -(set! l (re-split "fooxxxbaz")) -(for i in l - (print i "\n") -) +;(define pos (re-match "http://(.*):" "http://www.google.com:8080")) +;(print pos "\n") +;(set! i (first pos)) +; +;(while [< i (first (rest pos))] +; (print (string-ref "http://www.google.com:8080" i) "\n") +; (set! i (+ i 1)) +;) +;; +;(set! l (re-split "fooxxxbaz")) +;(for i in l +; (print i "\n") +;) ;(print (re-replace "-" "@this--is-foo" "

") "\n")