Replaced for-each function with faster alternative

Added scheme_error() for error reporting from C code
load-extension exists now, althought it does not do what I want
Added timeit-start, timeit-end and timeit-result functions for easier timing
Some map, and my map timing for comparison

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)

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))

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 ;

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")

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);

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);
 }
-
-
-
-
-
-

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;

tools/capone/src/scheme.c

@@ -17,9 +17,9 @@
 #ifndef WIN32
 # include <unistd.h>
 #endif
-#if USE_DL
+/*#if USE_DL
 # include "dynload.h"
-#endif
+#endif*/
 #if USE_MATH
 # include <math.h>
 #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);

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
 

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 "</" "<a href=\"foo\">foo</a>xxx<a href=\"baz\">baz</a>"))
-(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 "</" "<a href=\"foo\">foo</a>xxx<a href=\"baz\">baz</a>"))
+;(for i in l
+; (print i "\n")
+;)
 
 
 ;(print (re-replace "-" "@this--is-foo" "<p>") "\n")