merge

benchmarks/shootout/binarytrees.chibi

@@ -0,0 +1,46 @@
+#! /usr/bin/env chibi-scheme
+
+;;; The Computer Language Benchmarks Game
+;;; http://shootout.alioth.debian.org/
+
+(import (srfi 9))
+
+(define-record-type node
+  (make-node value left right)
+  node?
+  (value node-value node-value-set!)
+  (left node-left node-left-set!)
+  (right node-right node-right-set!))
+
+(define (make value depth)
+  (if (zero? depth)
+      (make-node value #f #f)
+      (let ((v (* value 2))
+            (d (- depth 1)))
+        (make-node value (make (- v 1) d) (make v d)))))
+
+(define (check n)
+  (if n
+      (+ (node-value n) (- (check (node-left n)) (check (node-right n))))
+      0))
+
+(define (print . args) (for-each display args) (newline))
+
+(define (main args)
+  (let* ((n (string->number (car args)))
+         (min-depth 4)
+         (max-depth (max (+ min-depth 2) n))
+         (stretch-depth (+ max-depth 1)))
+    (print "stretch tree of depth " stretch-depth "\t check: "
+           (check (make 0 stretch-depth)))
+    (let ((long-lived-tree (make 0 max-depth)))
+      (do ((d min-depth (+ d 2)))
+          ((>= d max-depth))
+        (let ((iterations (* 2 (+ (- max-depth d) min-depth))))
+          (print (* 2 iterations) "\t trees of depth " d "\t check: "
+                 (do ((i 0 (+ i 1))
+                      (c 0 (+ c (check (make i d)) (check (make (- i) d)))))
+                     ((>= i iterations)
+                      c)))))
+      (print "long lived tree of depth " max-depth "\t check: "
+             (check long-lived-tree)))))

benchmarks/shootout/chameneos-redux.chibi

@@ -0,0 +1,106 @@
+#! /usr/bin/env chibi-scheme
+
+;;; The Computer Language Benchmarks Game
+;;; http://shootout.alioth.debian.org/
+
+;;; based on Racket version by Matthew Flatt
+
+(import (srfi 18)
+        (chibi match))
+
+(define (print . args)
+  (for-each display args)
+  (newline))
+
+(define (change c1 c2)
+  (case c1
+    ((red)
+     (case c2 ((blue) 'yellow) ((yellow) 'blue) (else c1)))
+    ((yellow)
+     (case c2 ((blue) 'red) ((red) 'blue) (else c1)))
+    ((blue)
+     (case c2 ((yellow) 'red) ((red) 'yellow) (else c1)))))
+
+(let ((colors '(blue red yellow)))
+  (for-each
+   (lambda (a)
+     (for-each
+      (lambda (b)
+        (print a " + " b " -> " (change a b)))
+      colors))
+   colors))
+
+(define (place meeting-ch n)
+  (thread-start!
+   (make-thread
+    (lambda ()
+      (let loop ((n n))
+        (if (<= n 0)
+            ;; Fade all:
+            (let loop ()
+              (let ((c (channel-get meeting-ch)))
+                (channel-put (car c) #f)
+                (loop)))
+            ;; Let two meet:
+            (match-let (((ch1 . v1) (channel-get meeting-ch))
+                        ((ch2 . v2) (channel-get meeting-ch)))
+                       (channel-put ch1 v2)
+                       (channel-put ch2 v1)
+                       (loop (- n 1)))))))))
+
+(define (creature color meeting-ch result-ch)
+  (thread-start!
+   (make-thread
+    (lambda ()
+      (let ((ch (make-channel))
+            (name (gensym)))
+        (let loop ((color color) (met 0) (same 0))
+          (channel-put meeting-ch (cons ch (cons color name)))
+          (match (channel-get ch)
+                 ((other-color . other-name)
+                  ;; Meet:
+                  (sleep)         ; avoid imbalance from weak fairness
+                  (loop (change color other-color)
+                        (add1 met)
+                        (+ same (if (eq? name other-name)
+                                    1
+                                    0))))
+                 (#f
+                  ;; Done:
+                  (channel-put result-ch (cons met same))))))))))
+
+(define (spell n)
+  (for-each
+   (lambda (i)
+     (display " ")
+     (display (vector-ref digits (- (char->integer i) (char->integer #\0)))))
+   (string->list (number->string n))))
+
+(define digits
+  '#("zero" "one" "two" "three" "four" "five" "six" "seven" "eight" "nine"))
+
+(define (go n inits)
+  (let ((result-ch (make-channel))
+        (meeting-ch (make-channel)))
+    (place meeting-ch n)
+    (newline)
+    (for-each
+     (lambda (init)
+       (print " " init)
+       (creature init meeting-ch result-ch))
+     inits)
+    (newline)
+    (let ((results (map (lambda (i) (channel-get result-ch)) inits)))
+      (for-each
+       (lambda (r)
+         (display (car r))
+         (spell (cdr r))
+         (newline))
+       results)
+      (spell (apply + (map car results)))
+      (newline))))
+
+(let ((n (command-line #:args (n) (string->number n))))
+  (go n '(blue red yellow))
+  (go n '(blue red yellow red yellow blue red yellow red blue))
+  (newline))

benchmarks/shootout/knucleotide-output.txt

@@ -0,0 +1,27 @@
+A 30.279
+T 30.113
+G 19.835
+C 19.773
+
+AA 9.161
+AT 9.138
+TA 9.108
+TT 9.060
+CA 6.014
+GA 5.996
+AG 5.993
+AC 5.988
+TG 5.987
+GT 5.967
+TC 5.958
+CT 5.948
+GG 3.944
+GC 3.928
+CG 3.910
+CC 3.899
+
+1474	GGT
+459	GGTA
+49	GGTATT
+1	GGTATTTTAATT
+1	GGTATTTTAATTTATAGT

benchmarks/shootout/knucleotide.chibi

@@ -0,0 +1,85 @@
+#! /usr/bin/env chibi-scheme
+
+;;; The Computer Language Benchmarks Game
+;;; http://shootout.alioth.debian.org/
+
+;;; based on Racket version by Matthew Flatt
+
+(import (srfi 69)
+        (srfi 95)
+        (chibi io))
+
+(define (print . args)
+  (for-each display args)
+  (newline))
+
+(define (string-copy! dst dstart src start end)
+  (do ((i dstart (+ i 1))
+       (j start (+ j 1)))
+      ((>= j end))
+    (string-set! dst i (string-ref src j))))
+
+(define (string-upcase str)
+  (let* ((len (string-length str))
+         (res (make-string len)))
+    (do ((i 0 (+ i 1)))
+        ((>= i len) res)
+      (string-set! res i (char-upcase (string-ref str i))))))
+
+(define (all-counts len dna)
+  (let ((table (make-hash-table eq?))
+        (seq (make-string len)))
+    (do ((s (- (string-length dna) len) ( - s 1)))
+        ((< s 0) table)
+      (string-copy! seq 0 dna s (+ s len))
+      (let ((key (string->symbol seq)))
+        (let ((cnt (hash-table-ref/default table key 0)))
+          (hash-table-set! table key (+ cnt 1)))))))
+
+(define (write-freqs table)
+  (let* ((content (hash-table->alist table))
+         (total (exact->inexact (apply + (map cdr content)))))
+    (for-each
+     (lambda (a)
+       (print (car a) " "
+              (/ (round (* 100000.0 (/ (cdr a) total))) 1000.0)))
+     (sort content > cdr))))
+
+(define (write-one-freq table key)
+  (print (hash-table-ref/default table key 0) "\t" key))
+
+(define dna
+  (let ((in (current-input-port)))
+    ;; Skip to ">THREE ..."
+    (let lp ()
+      (let ((line (read-line in)))
+        (cond ((eof-object? line))
+              ((and (>= (string-length line) 6)
+                    (eqv? #\> (string-ref line 0))
+                    (equal? (substring line 0 6) ">THREE")))
+              (else (lp)))))
+    (let ((out (open-output-string)))
+      ;; Copy everything but newlines to out:
+      (let lp ()
+        (let ((line (read-line in)))
+          (cond ((eof-object? line))
+                (else
+                 (display line out)
+                 (lp)))))
+      ;; Extract the string from out:
+      (string-upcase (get-output-string out)))))
+
+;; 1-nucleotide counts:
+(write-freqs (all-counts 1 dna))
+(newline)
+
+;; 2-nucleotide counts:
+(write-freqs (all-counts 2 dna))
+(newline)
+
+;; Specific sequences:
+(for-each
+ (lambda (seq)
+   (write-one-freq (all-counts (string-length seq) dna)
+                   (string->symbol seq)))
+ '("GGT" "GGTA" "GGTATT" "GGTATTTTAATT" "GGTATTTTAATTTATAGT"))

lib/chibi/generic.module

@@ -0,0 +1,5 @@
+
+(define-module (chibi generic)
+  (export define-generic define-method make-generic generic-add!)
+  (import-immutable (scheme))
+  (include "generic.scm"))

lib/chibi/generic.scm

@@ -0,0 +1,79 @@
+
+(define-syntax define-generic
+  (syntax-rules ()
+    ((define-generic name)
+     (define name (make-generic 'name)))))
+
+'(define-syntax define-method
+  (syntax-rules ()
+    ((define-method (name (param type) ...) . body)
+     (generic-add! name
+                   (list type ...)
+                   (lambda (next param ...)
+                     (let-syntax ((call))
+                       . body))))))
+
+(define-syntax define-method
+  (er-macro-transformer
+   (lambda (e r c)
+     (let ((name (caadr e))
+           (params (cdadr e))
+           (body (cddr e)))
+       `(,(r 'generic-add!) ,name
+         (,(r 'list) ,@(map cadr params))
+         (,(r 'lambda) (next ,@(map car params))
+          (,(r 'let-syntax) ((call-next-method
+                              (,(r 'syntax-rules) ()
+                               ((_) (next)))))
+           ,@body)))))))
+
+(define (no-applicable-method-error name args)
+  (error "no applicable method" name args))
+
+(define (satisfied? preds args)
+  (cond ((null? preds) (null? args))
+        ((null? args) #f)
+        (((car preds) (car args)) (satisfied? (cdr preds) (cdr args)))
+        (else #f)))
+
+(define add-method-tag (list 'add-method-tag))
+
+(define (make-generic name)
+  (let ((name name)
+        (methods (make-vector 6 '())))
+    (vector-set! methods
+                 3
+                 (list (cons (list (lambda (x) (eq? x add-method-tag))
+                                   (lambda (x) (list? x))
+                                   procedure?)
+                             (lambda (next t p f)
+                               (set! methods (insert-method! methods p f))))))
+    (lambda args
+      (let ((len (length args)))
+        (cond
+         ((>= len (vector-length methods))
+          (no-applicable-method-error name args))
+         (else
+          (let lp ((ls (vector-ref methods len)))
+            (cond
+             ((null? ls)
+              (no-applicable-method-error name args))
+             ((satisfied? (car (car ls)) args)
+              (apply (cdr (car ls)) (lambda () (lp (cdr ls))) args))
+             (else
+              (lp (cdr ls)))))))))))
+
+(define (insert-method! vec preds f)
+  (let ((vlen (vector-length vec))
+        (plen (length preds)))
+    (let ((res (if (>= plen vlen)
+                   (let ((r (make-vector (+ vlen 1) '())))
+                     (do ((i 0 (+ i 1)))
+                         ((>= i vlen) r)
+                       (vector-set! r i (vector-ref vec i))))
+                   vec)))
+      (vector-set! res plen (cons (cons preds f) (vector-ref res plen)))
+      res)))
+
+(define (generic-add! g preds f)
+  (g add-method-tag preds f))

lib/srfi/55.module

@@ -0,0 +1,9 @@
+
+(define-module (srfi 55)
+  (export require-extension)
+  (import-immutable (scheme))
+  (body
+   (define-syntax require-extension
+     (syntax-rules ()
+       ((require-extension (prefix mod ...))
+        (begin (import (prefix mod) ...)))))))