Scheme tests for learning

test-alist-ref: pass

(define (test-alist-ref _)
  (let ((alst '((a 3) (b 2))))
    (⊦= '(3) (alist-ref 'a alst))
    (⊦= '(2) (alist-ref 'b alst))
    (⊦= #f (alist-ref 'c alst))))
((eta 0.0) (memory #(6291456 1298192 1048576)) (stdout "") (stderr ""))

test/len: pass

(define (test/len _)
  (let ((my-strlen
          (foreign-lambda*
            int
            ((scheme-object cons))
            "C_return(C_header_size(cons));")))
    (⊦= 2 (my-strlen (cons 1 '())))
    (⊦= 2 (my-strlen (cons 1 (cons 2 (cons 3 '())))))
    (⊦= 11 (my-strlen "hello world"))))
((eta 0.0) (memory #(6291456 1298800 1048576)) (stdout "") (stderr ""))

test/unquote: pass

Very interesting test about quasiquotation [1] : it shows how unquote can be used in a quasiquotation pattern in the cdr slot.

(define (test/unquote _) (let1 (a '(3)) (⊦= (cons 1 a) `(1 unquote a))))
((eta 0.0) (memory #(6291456 1299744 1048576)) (stdout "") (stderr ""))

test/c_callback: pass

(define (test/c_callback _)
  (let ((witness (gensym))
        (my-strlen
          (foreign-safe-lambda*
            scheme-object
            ((scheme-object f))
            "\t\t\t\t\t  C_word res = C_callback(f, 0);\n\t\t\t\t\t  printf(\"from within a safe lambda\\n\");\n\t\t\t\t\t  C_return (res);")))
    (⊦= witness (car (my-strlen (lambda () (list witness 4)))))))
((eta 0.001) (memory #(6291456 1300376 1048576)) (stdout "") (stderr ""))

test/foreign-safe-lambda*/allocate_string/inline: pass

(define (test/foreign-safe-lambda*/allocate_string/inline _)
  (let1 (allocate_string
          (foreign-safe-lambda*
            scheme-object
            ()
            "                            char* str = \"hello world\";\n                            C_word length = strlen(str);\n                            C_word* ptr = C_alloc (C_SIZEOF_STRING (length));\n                            C_word res = C_string (&ptr, length, str);\n                            C_return (res);"))
        (⊦= "hello world" (allocate_string))))
((eta 0.0) (memory #(6291456 1301008 1048576)) (stdout "") (stderr ""))

test/foreign-primitive/allocate-string: pass

An example of foreign-primitive [2] that allocates a string in C and returns it to Scheme. The C code is inlined in the Scheme source code.

(define (test/foreign-primitive/allocate-string _)
  (let1 (allocate_string
          (foreign-primitive scheme-object () "C_my_allocate_string(C_k);"))
        (⊦= "hello world" (allocate_string))))
((eta 0.0) (memory #(6291456 1302096 1048576)) (stdout "") (stderr ""))

test/foreign-safe-lambda/list-walk: pass

(define (test/foreign-safe-lambda/list-walk _)
  (let1 (list-walk
          (foreign-safe-lambda
            scheme-object
            "C_list_walk"
            scheme-object
            scheme-object))
        (⊦= '(1 2 3) (list-walk '(1 2 3) identity))))
((eta 0.0) (memory #(6291456 1302728 1048576)) (stdout "") (stderr ""))

test/foreign/callout-callin: pass

This test shows how to call out to C code that in turn calls back into Scheme code. The C code is in the file bar.c, and the function called from Scheme is callout. The function that is called back from C into Scheme is callin. Taken from the Chicken Scheme manual [3].

(define (test/foreign/callout-callin _)
  (define callout (foreign-safe-lambda int "callout" int int int))
  (define-external
    (callin (scheme-object xyz))
    int
    (print "This is 'callin': " xyz)
    123)
  (⊦= 123 (callout 1 2 3)))
((eta 0.0)
 (memory #(6291456 1304016 1048576))
 (stdout "This is 'callin': (1 2 3)\n")
 (stderr ""))

test/matchable/?: pass

(define (test/matchable/? _)
  (⊦= '(a) (match '(1 a) (((? odd?) a) (list a)))))
((eta 0.0) (memory #(6291456 1304648 1048576)) (stdout "") (stderr ""))

test/string/ref: pass

(define (test/string/ref _) (⊦ equal? #\o (string-ref "hello" 4)))
((eta 0.0) (memory #(6291456 1305280 1048576)) (stdout "") (stderr ""))

test/string/last: pass

(define (test/string/last _) (⊦ equal? #\o (string-last "hello")))
((eta 0.0) (memory #(6291456 1305912 1048576)) (stdout "") (stderr ""))

test/string/take-right: pass

(define (test/string/take-right _)
  (⊦ equal? "o" (string-take-right "hello" 1)))
((eta 0.0) (memory #(6291456 1306544 1048576)) (stdout "") (stderr ""))

test-null-eq?: pass

(define (test-null-eq? _) (⊨ (eq? '() '())))
((eta 0.0) (memory #(6291456 1307176 1048576)) (stdout "") (stderr ""))

See also