Welcome to the CHICKEN Scheme pasting service

;;; GOAL: Create a wrapper around the example C function below, so
;;; that users can pass a normal Scheme procedure as a callback. The
;;; module can be compiled, but users should be able to use it from
;;; csi, passing a non-compiled Scheme procedure as the callback.
;;;
;;; CHALLENGE: The callback procedure might trigger the GC, which
;;; could cause the callback procedure itself to move while the C
;;; function is still iterating.

(module foo (foo-iterate)
  (import scheme
          (chicken base)
          (chicken foreign))

  ;; Minimal example C library.
  (foreign-declare "
   typedef void (*fooCallback)(int i, void *data);

   void fooIterate(int loops, fooCallback callback, void *data) {
     for (int i=0; i < loops; i++) {
       callback(i, data);
     }
   }")

  ;; Treats the data pointer as a Scheme procedure and calls it.
  ;; Not reliable!
  (define-external
    (callbackAdapter (int i) (scheme-object data))
    void
    (assert (procedure? data)
            "Procedure invalid" data i)
    (data i))

  ;; Binding to fooIterate which uses callbackAdapter as the callback,
  ;; passing along the Scheme procedure as the data pointer.
  (define foo-iterate
    (foreign-safe-lambda*
     void
     ((int loops)
      (scheme-object proc))
     "fooIterate(loops, (fooCallback)callbackAdapter, (void*)proc);")))


;;; Everything below should be able to run in csi.

(import foo)

(define *results* (make-parameter '()))
(define (push-result! i)
  (*results* (cons i (*results*))))

;;; Usually works ok with a small number of iterations.
(print "Running with 50")
(foo-iterate 50 push-result!)
(print "Length of results: " (length (*results*)))

;;; Fails after a while, presumably because the GC runs and relocates
;;; push-result!, and fooIterate is still using the old location.
(print "Running with 1,000,000")
(foo-iterate 1000000 push-result!)
(print "Length of results: " (length (*results*)))


;;; $ csc foo.scm; ./foo
;;;
;;; Running with 50
;;; Length of results: 50
;;; Running with 1,000,000
;;;
;;; Error: (foo.scm:30) Procedure invalid
;;; #<invalid forwarded object>
;;; 11418
;;;
;;; 	Call history:
;;;
;;; 	foo.scm:32: data
;;; 	foo.scm:50: *results*
;;; 	foo.scm:50: *results*
;;; 	foo.scm:32: data
;;; 	foo.scm:50: *results*
;;; 	foo.scm:50: *results*
;;; 	foo.scm:32: data
;;; 	foo.scm:50: *results*
;;; 	foo.scm:50: *results*
;;; 	foo.scm:32: data
;;; 	foo.scm:50: *results*
;;; 	foo.scm:50: *results*
;;; 	foo.scm:32: data
;;; 	foo.scm:50: *results*
;;; 	foo.scm:50: *results*
;;; 	foo.scm:30: ##sys#error	  	<--

;;; GOAL: Create a wrapper around the example C function below, so
;;; that users can pass a normal Scheme procedure as a callback. The
;;; module can be compiled, but users should be able to use it from
;;; csi, passing a non-compiled Scheme procedure as the callback.
;;;
;;; CHALLENGE: The callback procedure might trigger the GC, which
;;; could cause the callback procedure itself to move while the C
;;; function is still iterating.

(module foo (foo-iterate)
  (import scheme
          (chicken base)
          (chicken foreign))

  ;; Minimal example C library.
  (foreign-declare "
   typedef void* (*fooCallback)(int i, void *data);

   void fooIterate(int loops, fooCallback callback, void *data) {
     for (int i=0; i < loops; i++) {
        data = callback(i, data);
     }
   }")

  ;; Treats the data pointer as a Scheme procedure and calls it.
  ;; Not reliable!
  (define-external
    (callbackAdapter (int i) (scheme-object data))
    scheme-object
    (assert (procedure? data)
            "Procedure invalid" data i)
    (data i)
    data)

  ;; Binding to fooIterate which uses callbackAdapter as the callback,
  ;; passing along the Scheme procedure as the data pointer.
  (define foo-iterate
    (foreign-safe-lambda*
     void
     ((int loops)
      (scheme-object proc))
     "fooIterate(loops, (fooCallback)callbackAdapter, (void*)proc);")))


;;; Everything below should be able to run in csi.

(import foo)

(define *results* (make-parameter '()))
(define (push-result! i)
  (*results* (cons i (*results*))))

;;; Usually works ok with a small number of iterations.
(print "Running with 50")
(foo-iterate 50 push-result!)
(print "Length of results: " (length (*results*)))

;;; Fails after a while, presumably because the GC runs and relocates
;;; push-result!, and fooIterate is still using the old location.
(print "Running with 1,000,000")
(foo-iterate 1000000 push-result!)
(print "Length of results: " (length (*results*)))