Menu
▾
▴
clisp-cvs Digest, Vol 32, Issue 25
|
From: <cli...@li...> - 2008-12-19 17:24:48
|
Send clisp-cvs mailing list submissions to cli...@li... To subscribe or unsubscribe via the World Wide Web, visit https://lists.sourceforge.net/lists/listinfo/clisp-cvs or, via email, send a message with subject or body 'help' to cli...@li... You can reach the person managing the list at cli...@li... When replying, please edit your Subject line so it is more specific than "Re: Contents of clisp-cvs digest..." CLISP CVS commits for today Today's Topics: 1. clisp/src ChangeLog, 1.6726, 1.6727 pathname.d, 1.489, 1.490 spvw.d, 1.472, 1.473 zthread.d, 1.33, 1.34 (Vladimir Tzankov) 2. clisp/src ChangeLog,1.6727,1.6728 (Sam Steingold) 3. clisp/modules/berkeley-db dbi.lisp,1.28,1.29 (Sam Steingold) 4. clisp/src ChangeLog, 1.6728, 1.6729 foreign.d, 1.189, 1.190 foreign1.lisp, 1.127, 1.128 lispbibl.d, 1.842, 1.843 (Sam Steingold) 5. clisp/src ChangeLog,1.6729,1.6730 (Sam Steingold) 6. clisp/modules/libsvm preload.lisp, NONE, 1.1 Makefile, 1.3, 1.4 libsvm.lisp, 1.13, 1.14 link.sh, 1.3, 1.4 svm.cpp, 1.7, 1.8 svm.h, 1.4, 1.5 test.tst, 1.9, 1.10 (Sam Steingold) ---------------------------------------------------------------------- Message: 1 Date: Fri, 19 Dec 2008 14:22:55 +0000 From: Vladimir Tzankov <vt...@us...> Subject: clisp/src ChangeLog, 1.6726, 1.6727 pathname.d, 1.489, 1.490 spvw.d, 1.472, 1.473 zthread.d, 1.33, 1.34 To: cli...@li... Message-ID: <E1L...@dd...> Update of /cvsroot/clisp/clisp/src In directory ddv4jf1.ch3.sourceforge.com:/tmp/cvs-serv3916/src Modified Files: ChangeLog pathname.d spvw.d zthread.d Log Message: release (and warn) locked mutexes on thread termination Index: spvw.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/spvw.d,v retrieving revision 1.472 retrieving revision 1.473 diff -u -d -r1.472 -r1.473 --- spvw.d 19 Dec 2008 10:17:18 -0000 1.472 +++ spvw.d 19 Dec 2008 14:22:53 -0000 1.473 @@ -3774,6 +3774,7 @@ } #if defined(MULTITHREAD) +extern maygc void thread_cleanup(); /* in zthread.d */ /* UP: main_actions() replacement in MT. > param: clisp_thread_t structure of the first lisp thread */ local void* mt_main_actions (void *param) { @@ -3793,6 +3794,7 @@ Symbol_thread_value(S(thread_whostate_symbol)) = NIL; /* now we are ready to start main_actions()*/ main_actions(args); + thread_cleanup(); delete_thread(me,false); /* just delete ourselves */ /* NB: the LISP stack is "leaked" - in a sense nobody will ever use it anymore !!!*/ Index: zthread.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/zthread.d,v retrieving revision 1.33 retrieving revision 1.34 diff -u -d -r1.33 -r1.34 --- zthread.d 5 Dec 2008 15:59:19 -0000 1.33 +++ zthread.d 19 Dec 2008 14:22:53 -0000 1.34 @@ -93,6 +93,45 @@ } } +/* UP: called at thread exitting. performs cleanup/checks. + currently checks whether the exitting thread doesnot hold any mutex. +The function is called when the current thread does not have established +DRIVER frame. If the thread is interrupted and error occurs the unwinding +will reach the stack bottom and will barf. So we establish a driver +frame to prevent this case. */ +global maygc void thread_cleanup(); +global maygc void thread_cleanup() +{ + var clisp_thread_t *me = current_thread(); + var gcv_object_t* top_of_frame = STACK; /* pointer above frame */ + var sp_jmp_buf returner; /* remember entry point */ + finish_entry_frame(DRIVER,returner,,{skipSTACK(2);return;}); + WITH_OS_MUTEX_LOCK(0,&all_mutexes_lock,{ + var object list = O(all_mutexes); + while (!endp(list)) { + if (eq(TheMutex(Car(list))->xmu_owner, me->_lthread)) { + /* we own the mutex. warn and release */ + pushSTACK(list); + pushSTACK(Car(list)); + { /* warn */ + pushSTACK(NIL); pushSTACK(me->_lthread); + pushSTACK(Car(list)); + STACK_2 = CLSTEXT("Thread ~S is exiting while still owning mutex ~S. The mutex will be released."); + funcall(S(warn),3); + } + /* release the mutex */ + TheMutex(STACK_0)->xmu_recurse_count = 0; + GC_SAFE_MUTEX_UNLOCK(&TheMutex(STACK_0)->xmu_system); + TheMutex(STACK_0)->xmu_owner = NIL; + skipSTACK(1); /* mutex */ + list = popSTACK(); + } + list = Cdr(list); + } + }); + skipSTACK(2); /* driver frame */ +} + /* All newly created threads start here.*/ local /*maygc*/ void *thread_stub(void *arg) { @@ -152,6 +191,7 @@ /* we should always have empty stack - this is an error. */ NOTREACHED; } + thread_cleanup(); /* just unregister it from the active threads. the allocated memory will be released during GC (if there are no references to thread object)*/ delete_thread(me,false); @@ -555,6 +595,8 @@ skipSTACK(3); } + + LISPFUNN(mutexp,1) { /* (MUTEXP object) */ var object obj = popSTACK(); Index: pathname.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/pathname.d,v retrieving revision 1.489 retrieving revision 1.490 diff -u -d -r1.489 -r1.490 --- pathname.d 19 Dec 2008 10:17:17 -0000 1.489 +++ pathname.d 19 Dec 2008 14:22:53 -0000 1.490 @@ -9033,6 +9033,21 @@ pushSTACK(subr_self); error(control_error,GETTEXT("~S: There are multiple running threads. Currently they do not survive image saving/loading.")); } + /* we are the only one running. let's check mutexes. we do not allow + to have locked mutexes saved in the memory image */ + var object list = O(all_mutexes); + while (!endp(list)) { + if (!eq(NIL,TheMutex(Car(list))->xmu_owner)) { + /* we have a locked mutex. this is an error. */ + pushSTACK(NIL); /* CELL-ERROR Slot NAME */ + /* mutex owner (should be eq() to current thread) */ + pushSTACK(TheMutex(Car(list))->xmu_owner); + pushSTACK(Car(list)); /* mutex */ + pushSTACK(subr_self); + error(control_error,GETTEXT("~S: Mutex ~S is locked by thread ~S. Currently locked mutexes are not allowed in memory files.")); + } + list = Cdr(list); + } #endif var uintL executable = nullp(STACK_0) ? 0 : eq(Fixnum_0,STACK_0) ? 2 : 1; skipSTACK(1); /* drop executable */ Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.6726 retrieving revision 1.6727 diff -u -d -r1.6726 -r1.6727 --- ChangeLog 19 Dec 2008 10:17:17 -0000 1.6726 +++ ChangeLog 19 Dec 2008 14:22:52 -0000 1.6727 @@ -1,5 +1,13 @@ 2008-12-19 Vladimir Tzankov <vtz...@gm...> + * zthread.d (thread_cleanup): performs cleanup just before thread + termination. currently releases (and warns) held mutexes + (thread_stub): use it + * spvw.d (mt_main_actions): call thread_cleanup() for the first thread + * pathname.d (SAVEMEM): do not allow locked mutexes in memory image + +2008-12-19 Vladimir Tzankov <vtz...@gm...> + * pathname.d (SAVEMEM): signal an error if there are multiple running threads * spvw.d (single_running_threadp): returns true if the caller is the ------------------------------ Message: 2 Date: Fri, 19 Dec 2008 15:44:34 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src ChangeLog,1.6727,1.6728 To: cli...@li... Message-ID: <E1L...@dd...> Update of /cvsroot/clisp/clisp/src In directory ddv4jf1.ch3.sourceforge.com:/tmp/cvs-serv10879/src Modified Files: ChangeLog Log Message: (db-log-stat): fix type of mode slot Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.6727 retrieving revision 1.6728 diff -u -d -r1.6727 -r1.6728 --- ChangeLog 19 Dec 2008 14:22:52 -0000 1.6727 +++ ChangeLog 19 Dec 2008 15:44:32 -0000 1.6728 @@ -1,3 +1,7 @@ +2008-12-19 Sam Steingold <sd...@gn...> + + * modules/berkeley-db/dbi.lisp (db-log-stat): fix type of mode slot + 2008-12-19 Vladimir Tzankov <vtz...@gm...> * zthread.d (thread_cleanup): performs cleanup just before thread ------------------------------ Message: 3 Date: Fri, 19 Dec 2008 15:44:34 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/modules/berkeley-db dbi.lisp,1.28,1.29 To: cli...@li... Message-ID: <E1L...@dd...> Update of /cvsroot/clisp/clisp/modules/berkeley-db In directory ddv4jf1.ch3.sourceforge.com:/tmp/cvs-serv10879/modules/berkeley-db Modified Files: dbi.lisp Log Message: (db-log-stat): fix type of mode slot Index: dbi.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/berkeley-db/dbi.lisp,v retrieving revision 1.28 retrieving revision 1.29 diff -u -d -r1.28 -r1.29 --- dbi.lisp 12 Nov 2008 04:54:48 -0000 1.28 +++ dbi.lisp 19 Dec 2008 15:44:31 -0000 1.29 @@ -208,7 +208,7 @@ ;; The version of the log file type. (version 0 :type (unsigned-byte 32) :read-only t) ;; The mode of any created log files. - (mode 0 :type int :read-only t) + (mode 0 :type (unsigned-byte 32) :read-only t) ;; The in-memory log record cache size. (lg_bsize 0 :type (unsigned-byte 32) :read-only t) ;; The current log file size. ------------------------------ Message: 4 Date: Fri, 19 Dec 2008 16:22:52 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src ChangeLog, 1.6728, 1.6729 foreign.d, 1.189, 1.190 foreign1.lisp, 1.127, 1.128 lispbibl.d, 1.842, 1.843 To: cli...@li... Message-ID: <E1L...@dd...> Update of /cvsroot/clisp/clisp/src In directory ddv4jf1.ch3.sourceforge.com:/tmp/cvs-serv13539/src Modified Files: ChangeLog foreign.d foreign1.lisp lispbibl.d Log Message: (convert-from-foreign, convert-to-foreign): new functions to partially inline convert_from_foreign & convert_to_foreign (note-c-call-in): use them Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.6728 retrieving revision 1.6729 diff -u -d -r1.6728 -r1.6729 --- ChangeLog 19 Dec 2008 15:44:32 -0000 1.6728 +++ ChangeLog 19 Dec 2008 16:22:50 -0000 1.6729 @@ -1,5 +1,13 @@ 2008-12-19 Sam Steingold <sd...@gn...> + * lispbibl.d (make_faddress): declare + * foreign.d (make_faddress): make global for ... + * foreign1.lisp (convert-from-foreign, convert-to-foreign): new + functions to partially inline convert_from_foreign & convert_to_foreign + (note-c-call-in): use them + +2008-12-19 Sam Steingold <sd...@gn...> + * modules/berkeley-db/dbi.lisp (db-log-stat): fix type of mode slot 2008-12-19 Vladimir Tzankov <vtz...@gm...> Index: foreign1.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/src/foreign1.lisp,v retrieving revision 1.127 retrieving revision 1.128 diff -u -d -r1.127 -r1.128 --- foreign1.lisp 31 Jul 2008 20:16:41 -0000 1.127 +++ foreign1.lisp 19 Dec 2008 16:22:50 -0000 1.128 @@ -1134,8 +1134,52 @@ (NOTE-C-CALL-IN ',name ',c-name ',alist ',whole-form)) ',name))) -(defun convert-to-foreign-C (flags) - (if (flag-set-p flags ff-flag-malloc-free) "mallocing" "nomalloc")) +;; convert-from-foreign & convert-to-foreign inline +;; foreign.d:convert_from_foreign and foreign.d:convert_to_foreign +;; for callbacks into lisp. +;; we inline only a few most common cases - those used in the supplied modules. +(defun convert-from-foreign (argtype argname) + ;; keep in sync with foreign.d:convert_from_foreign + (case argtype + (nil "NIL") + (boolean (format nil "~A ? T : NIL" argname)) + ;; (character ...) too hairy + ((char sint8) (format nil "sint8_to_I(~A)" argname)) + ((uchar uint8) (format nil "uint8_to_I(~A)" argname)) + (sint16 (format nil "sint16_to_I(~A)" argname)) + (uint16 (format nil "uint16_to_I(~A)" argname)) + (sint32 (format nil "sint32_to_I(~A)" argname)) + (uint32 (format nil "uint32_to_I(~A)" argname)) + (sint64 (format nil "sint64_to_I(~A)" argname)) + (uint64 (format nil "uint64_to_I(~A)" argname)) + (int (format nil "sint_to_I(~A)" argname)) + (uint (format nil "uint_to_I(~A)" argname)) + (long (format nil "slong_to_I(~A)" argname)) + (ulong (format nil "ulong_to_I(~A)" argname)) + (single-float (format nil "c_float_to_FF((const ffloatjanus*)&~A)" argname)) + (double-float (format nil "c_double_to_FF((const dfloatjanus*)&~A)" argname)) + (c-pointer (format nil "~A == NULL ? NIL : make_faddress(GLO(fp_zero),~A)" argname argname)) + (c-string (format nil "~A == NULL ? NIL : asciz_to_string(~A,GLO(foreign_encoding))" argname argname)) + (t (format nil "convert_from_foreign(~A,&~A)" + (object-to-c-value (pass-object argtype)) argname)))) + +(defun convert-to-foreign (rettype lispobj retaddr flags) + ;; keep in sync with foreign.d:convert_to_foreign + (case rettype + (int (format nil "if (sint_p(~A)) *~A=I_to_sint(~A); else error_sint(~A)" + lispobj retaddr lispobj lispobj)) + (uint (format nil "if (uint_p(~A)) *~A=I_to_uint(~A); else error_uint(~A)" + lispobj retaddr lispobj lispobj)) + (long + (format nil "if (slong_p(~A)) *~A=I_to_slong(~A); else error_slong(~A)" + lispobj retaddr lispobj lispobj)) + (ulong + (format nil "if (ulong_p(~A)) *~A=I_to_ulong(~A); else error_ulong(~A)" + lispobj retaddr lispobj lispobj)) + (t (format nil "convert_to_foreign(~A,~A,~A,&~A)" + (object-to-c-value (pass-object rettype)) lispobj retaddr + (if (flag-set-p flags ff-flag-malloc-free) + "mallocing" "nomalloc"))))) (defun note-c-call-in (name c-name alist whole) ; ABI (when (compiler::prepare-coutput-file) @@ -1174,9 +1218,8 @@ (flag-output (logior ff-flag-out ff-flag-in-out))) (mapc #'(lambda (argtype argflag argname) (unless (flag-set-p argflag ff-flag-out) - (format *coutput-stream* - " pushSTACK(convert_from_foreign(~A,&~A));~%" - (object-to-c-value (pass-object argtype)) argname) + (format *coutput-stream* " pushSTACK(~A);~%" + (convert-from-foreign argtype argname)) (incf inargcount)) (when (flag-set-p argflag flag-output) (incf outargcount))) @@ -1184,28 +1227,24 @@ (format *coutput-stream* " funcall(~A,~D);~%" (object-to-c-value (pass-object name)) inargcount) (unless (eq rettype 'NIL) - (format *coutput-stream* " {~% ~A;~%~: - convert_to_foreign(~A,value1,&retval,&~A);~%" + (format *coutput-stream* " {~% ~A;~% ~A;~%" (to-c-typedecl rettype "retval") - (object-to-c-value (pass-object rettype)) - (convert-to-foreign-C flags))) + (convert-to-foreign rettype "value1" "&retval" flags))) (let ((outargcount (if (eq rettype 'NIL) 0 1))) (mapc #'(lambda (argtype argflag argname) (when (flag-set-p argflag flag-output) (unless (eq (ctype-type argtype) 'C-PTR) (error (TEXT "~S: :OUT argument is not a pointer: ~S") 'DEF-CALL-IN argtype)) - (format *coutput-stream* - " ~Aconvert_to_foreign(~A,~A,~A,&~A);~%" + (format *coutput-stream* " ~A~A;~%" (if (eql outargcount 0) "" (format nil "if (mv_count >= ~D) " (+ outargcount 1))) - (object-to-c-value - (pass-object (svref argtype 1))) - (if (eql outargcount 0) - "value1" - (format nil "mv_space[~D]" outargcount)) - argname (convert-to-foreign-C argflag)) + (convert-to-foreign + (svref argtype 1) + (if (eql outargcount 0) "value1" + (format nil "mv_space[~D]" outargcount)) + argname argflag)) (incf outargcount))) argtypes argflags argnames)) (format *coutput-stream* " end_callback();~%") Index: lispbibl.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/lispbibl.d,v retrieving revision 1.842 retrieving revision 1.843 diff -u -d -r1.842 -r1.843 --- lispbibl.d 19 Dec 2008 10:07:44 -0000 1.842 +++ lispbibl.d 19 Dec 2008 16:22:50 -0000 1.843 @@ -16769,6 +16769,16 @@ #define Faddress_value(obj) \ ((void*)((uintP)Fpointer_value(TheFaddress(obj)->fa_base) + TheFaddress(obj)->fa_offset)) +/* Allocate a foreign address. + make_faddress(base,offset) + > base: base address + > offset: offset relative to the base address + < result: Lisp object + can trigger GC */ +extern maygc object make_faddress (object base, uintP offset); +/* used by FOREIGN & modules (see foreign1.lisp:convert-from-foreign) */ +%% puts("extern object make_faddress (object base, uintP offset);"); + /* ensure that the Faddress is valid < fa: foreign address (not checked!) can trigger GC */ Index: foreign.d =================================================================== RCS file: /cvsroot/clisp/clisp/src/foreign.d,v retrieving revision 1.189 retrieving revision 1.190 diff -u -d -r1.189 -r1.190 --- foreign.d 6 Oct 2008 20:57:23 -0000 1.189 +++ foreign.d 19 Dec 2008 16:22:50 -0000 1.190 @@ -27,7 +27,7 @@ > offset: offset relative to the base address < result: Lisp object can trigger GC */ -local maygc object make_faddress (object base, uintP offset) +global maygc object make_faddress (object base, uintP offset) { pushSTACK(base); var object result = allocate_faddress(); @@ -1089,7 +1089,7 @@ error(error_condition,GETTEXT("~S: element type has size 0: ~S")); } global maygc object convert_from_foreign (object fvd, const void* data) -{ +{ /* keep in sync with foreign1.lisp:convert-from-foreign */ check_SP(); check_STACK(); if (NULL == data) { @@ -1909,7 +1909,7 @@ can trigger GC */ global maygc void convert_to_foreign (object fvd, object obj, void* data, converter_malloc_t *converter_malloc) -{ +{ /* keep in sync with foreign1.lisp:convert-to-foreign */ check_SP(); check_STACK(); if (NULL == data) { ------------------------------ Message: 5 Date: Fri, 19 Dec 2008 17:24:41 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/src ChangeLog,1.6729,1.6730 To: cli...@li... Message-ID: <E1L...@dd...> Update of /cvsroot/clisp/clisp/src In directory ddv4jf1.ch3.sourceforge.com:/tmp/cvs-serv16810/src Modified Files: ChangeLog Log Message: redirect libsvm output to a lisp stream from C stdout * modules/libsvm/libsvm.lisp (*libsvm-output*): new variable (write-string-to-libsvm-output): new C call-in (callback) set "print_string=&libsvm_print_string" in init_2 * modules/libsvm/Makefile, modules/libsvm/link.sh: callbacks require libsvm.c and ... * modules/libsvm/preload.lisp: new file for (make-package "LIBSVM" ...) submitted to upstream but not yet accepted: * modules/libsvm/svm.cpp (print_string_stdout): new function (print_string): new variable, initialized to print_string_stdout (info): use vsprintf and (*print_string) * modules/libsvm/svm.h (print_string, print_string_stdout): declare Index: ChangeLog =================================================================== RCS file: /cvsroot/clisp/clisp/src/ChangeLog,v retrieving revision 1.6729 retrieving revision 1.6730 diff -u -d -r1.6729 -r1.6730 --- ChangeLog 19 Dec 2008 16:22:50 -0000 1.6729 +++ ChangeLog 19 Dec 2008 17:24:39 -0000 1.6730 @@ -1,5 +1,20 @@ 2008-12-19 Sam Steingold <sd...@gn...> + redirect libsvm output to a lisp stream from C stdout + * modules/libsvm/libsvm.lisp (*libsvm-output*): new variable + (write-string-to-libsvm-output): new C call-in (callback) + set "print_string=&libsvm_print_string" in init_2 + * modules/libsvm/Makefile, modules/libsvm/link.sh: callbacks + require libsvm.c and ... + * modules/libsvm/preload.lisp: new file for (make-package "LIBSVM" ...) + submitted to upstream but not yet accepted: + * modules/libsvm/svm.cpp (print_string_stdout): new function + (print_string): new variable, initialized to print_string_stdout + (info): use vsprintf and (*print_string) + * modules/libsvm/svm.h (print_string, print_string_stdout): declare + +2008-12-19 Sam Steingold <sd...@gn...> + * lispbibl.d (make_faddress): declare * foreign.d (make_faddress): make global for ... * foreign1.lisp (convert-from-foreign, convert-to-foreign): new ------------------------------ Message: 6 Date: Fri, 19 Dec 2008 17:24:41 +0000 From: Sam Steingold <sd...@us...> Subject: clisp/modules/libsvm preload.lisp, NONE, 1.1 Makefile, 1.3, 1.4 libsvm.lisp, 1.13, 1.14 link.sh, 1.3, 1.4 svm.cpp, 1.7, 1.8 svm.h, 1.4, 1.5 test.tst, 1.9, 1.10 To: cli...@li... Message-ID: <E1L...@dd...> Update of /cvsroot/clisp/clisp/modules/libsvm In directory ddv4jf1.ch3.sourceforge.com:/tmp/cvs-serv16810/modules/libsvm Modified Files: Makefile libsvm.lisp link.sh svm.cpp svm.h test.tst Added Files: preload.lisp Log Message: redirect libsvm output to a lisp stream from C stdout * modules/libsvm/libsvm.lisp (*libsvm-output*): new variable (write-string-to-libsvm-output): new C call-in (callback) set "print_string=&libsvm_print_string" in init_2 * modules/libsvm/Makefile, modules/libsvm/link.sh: callbacks require libsvm.c and ... * modules/libsvm/preload.lisp: new file for (make-package "LIBSVM" ...) submitted to upstream but not yet accepted: * modules/libsvm/svm.cpp (print_string_stdout): new function (print_string): new variable, initialized to print_string_stdout (info): use vsprintf and (*print_string) * modules/libsvm/svm.h (print_string, print_string_stdout): declare --- NEW FILE: preload.lisp --- (make-package "LIBSVM" :case-sensitive t :case-inverted t) Index: svm.h =================================================================== RCS file: /cvsroot/clisp/clisp/modules/libsvm/svm.h,v retrieving revision 1.4 retrieving revision 1.5 diff -u -d -r1.4 -r1.5 --- svm.h 16 Dec 2008 22:54:16 -0000 1.4 +++ svm.h 19 Dec 2008 17:24:39 -0000 1.5 @@ -67,6 +67,9 @@ const char *svm_check_parameter(const struct svm_problem *prob, const struct svm_parameter *param); int svm_check_probability_model(const struct svm_model *model); +extern void (*print_string) (char *); +void print_string_stdout (char *); + #ifdef __cplusplus } #endif Index: test.tst =================================================================== RCS file: /cvsroot/clisp/clisp/modules/libsvm/test.tst,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- test.tst 16 Dec 2008 22:54:16 -0000 1.9 +++ test.tst 19 Dec 2008 17:24:39 -0000 1.10 @@ -4,6 +4,8 @@ (integerp (show libsvm:*libsvm-version*)) T +(open-stream-p (setq libsvm:*libsvm-output* (make-string-output-stream))) T + (defparameter f-parameter (libsvm:make-parameter)) F-PARAMETER @@ -46,7 +48,7 @@ (ffi:with-c-place (p-parameter f-parameter) (setf (ffi:slot p-parameter 'libsvm::gamma) (float (/ maxindex) 0d0) (ffi:slot p-parameter 'libsvm::C) 1d0 - (ffi:slot p-parameter 'libsvm::kernel_type) libsvm::LINEAR)) + (ffi:slot p-parameter 'libsvm::kernel_type) libsvm:LINEAR)) (setf v-parameter (ffi:foreign-value f-parameter)) (show (libsvm:parameter-alist f-parameter) :pretty t) (list (= maxindex (floor (log (1- 1000) 7))) @@ -146,6 +148,8 @@ (libsvm:destroy-parameter f-parameter) NIL (ffi:validp f-parameter) NIL +(length (get-output-stream-string libsvm:*libsvm-output*)) 10713 + (progn (makunbound 'f-parameter) (makunbound 'v-parameter) (makunbound 'f-problem-2-7) Index: Makefile =================================================================== RCS file: /cvsroot/clisp/clisp/modules/libsvm/Makefile,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- Makefile 13 Oct 2006 05:08:37 -0000 1.3 +++ Makefile 19 Dec 2008 17:24:39 -0000 1.4 @@ -1,5 +1,7 @@ # Makefile for CLISP module set libsvm +AR = ar +RANLIB = ranlib CC = gcc CXX = g++ CPPFLAGS = @@ -14,18 +16,28 @@ SHELL = /bin/sh -DISTRIBFILES = svm.so link.sh Makefile libsvm.lisp +DISTRIBFILES = svm.so link.sh Makefile libsvm.lisp libsvm.o distribdir = -all : libsvm.fas svm.so +all : libsvm.fas svm.so libsvm.o svm.so : svm.cpp svm.h $(CXX) $(CPPFLAGS) $(CXXFLAGS) -I$(INCLUDES) \ -fPIC -shared -o svm.so svm.cpp -lm -libsvm.fas : libsvm.lisp +svm.o : svm.cpp svm.h + $(CXX) $(CPPFLAGS) $(CXXFLAGS) -I$(INCLUDES) -c svm.cpp + +svm.a : svm.o + $(AR) rcv svm.a svm.o + $(RANLIB) svm.a + +libsvm.c libsvm.fas : libsvm.lisp $(CLISP) -c libsvm.lisp +libsvm.o : libsvm.c $(INCLUDES)/clisp.h svm.h + $(CC) $(CPPFLAGS) $(CFLAGS) -I$(INCLUDES) -c libsvm.c + # Make a module clisp-module : all Index: link.sh =================================================================== RCS file: /cvsroot/clisp/clisp/modules/libsvm/link.sh,v retrieving revision 1.3 retrieving revision 1.4 diff -u -d -r1.3 -r1.4 --- link.sh 23 May 2008 14:17:54 -0000 1.3 +++ link.sh 19 Dec 2008 17:24:39 -0000 1.4 @@ -1,7 +1,7 @@ file_list='' mod_list='' if test -f libsvm.c; then # if we use :library in ffi, no C file is created - file_list="$file_list"' libsvm.o' + file_list="$file_list libsvm.o `pwd`/svm.so" mod_list="$mod_list"' libsvm' fi ${MAKE-make} clisp-module \ @@ -11,3 +11,4 @@ NEW_LIBS="${file_list} -lm" NEW_MODULES="${mod_list}" TO_LOAD='libsvm' +TO_PRELOAD="preload.lisp" Index: svm.cpp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/libsvm/svm.cpp,v retrieving revision 1.7 retrieving revision 1.8 diff -u -d -r1.7 -r1.8 --- svm.cpp 16 Dec 2008 22:55:52 -0000 1.7 +++ svm.cpp 19 Dec 2008 17:24:39 -0000 1.8 @@ -35,14 +35,21 @@ #define INF HUGE_VAL #define TAU 1e-12 #define Malloc(type,n) (type *)malloc((n)*sizeof(type)) +void print_string_stdout (char *s) +{ + fputs(s,stdout); + fflush(stdout); +} +void (*print_string) (char *) = &print_string_stdout; #if 1 static void info(const char *fmt,...) { + char buf[BUFSIZ]; va_list ap; va_start(ap,fmt); - vprintf(fmt,ap); + vsprintf(buf,fmt,ap); va_end(ap); - fflush(stdout); + (*print_string)(buf); } #else static void info(char *fmt,...) {} Index: libsvm.lisp =================================================================== RCS file: /cvsroot/clisp/clisp/modules/libsvm/libsvm.lisp,v retrieving revision 1.13 retrieving revision 1.14 diff -u -d -r1.13 -r1.14 --- libsvm.lisp 16 Dec 2008 22:54:16 -0000 1.13 +++ libsvm.lisp 19 Dec 2008 17:24:39 -0000 1.14 @@ -9,7 +9,7 @@ (:modern t) (:use "CL" "FFI") (:shadowing-import-from "EXPORTING" #:def-c-enum #:def-c-struct #:def-call-out #:def-c-type #:def-c-var - #:defun)) + #:defun #:defvar)) (in-package "LIBSVM") (setf (documentation (find-package "LIBSVM") 'sys::impnotes) "libsvm") @@ -17,6 +17,15 @@ (default-foreign-library (namestring (merge-pathnames "svm.so" *load-pathname*))) +(c-lines "#include \"svm.h\"~%") + +(defvar *libsvm-output* *standard-output* "The stream for svm.so messages.") +(cl:defun write-string-to-libsvm-output (s) + (write-string s *libsvm-output*) (force-output *libsvm-output*)) +(def-call-in write-string-to-libsvm-output (:name "libsvm_print_string") + (:arguments (s c-string)) (:return-type nil)) +(c-lines :init-always "print_string = &libsvm_print_string;~%") + ;;; ;;; types and constants ;;; ------------------------------ ------------------------------------------------------------------------------ ------------------------------ _______________________________________________ clisp-cvs mailing list cli...@li... https://lists.sourceforge.net/lists/listinfo/clisp-cvs End of clisp-cvs Digest, Vol 32, Issue 25 ***************************************** |